diff -Nru openmolcas-22.02/cmake/custom/gen1int.cmake openmolcas-22.10/cmake/custom/gen1int.cmake --- openmolcas-22.02/cmake/custom/gen1int.cmake 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/cmake/custom/gen1int.cmake 2022-10-10 14:22:40.000000000 +0000 @@ -51,7 +51,7 @@ # git references for GEN1INT module # ##################################### set(reference_git_repo https://gitlab.com/Molcas/gen1int-molcas.git) -set(reference_git_commit 4b486d698258401a8b94450affb1f0dc8334630a) +set(reference_git_commit 75353eea270b4cccb746efbb919e7f96dd605d7c) set(EP_PROJECT gen1int) # Enabling source changes to keep ExternalProject happy diff -Nru openmolcas-22.02/CMakeLists.txt openmolcas-22.10/CMakeLists.txt --- openmolcas-22.02/CMakeLists.txt 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -117,6 +117,7 @@ option (GROMACS "Compile Gromacs interface." OFF) option (BLOCK "Activate BLOCK-DMRG support." OFF) option (CHEMPS2 "Activate CheMPS2-DMRG support." OFF) +option (DICE "Activate Dice-SHCI support." OFF) option (GPERFTOOLS "Activate gperftools CPU profiling." OFF) option (GCOV "Activate code coverage profiling (use with Debug/-O0)." OFF) @@ -629,7 +630,7 @@ set (FFLAGS_Intel_BASIC "") set (FFLAGS_Intel_PREPROCESS "-fpp") set (FFLAGS_Intel_OPENMP "-qopenmp") -set (FFLAGS_Intel_ILP64 "-i8 -r8 -heap-arrays") +set (FFLAGS_Intel_ILP64 "-i8 -heap-arrays") # build targets set (FFLAGS_Intel_DEBUG "-debug -traceback -warn all,nodeclarations") set (FFLAGS_Intel_GARBLE "-O2 -debug -traceback -warn all,nodeclarations -check all,nobounds,noarg_temp_created") @@ -1023,8 +1024,11 @@ if ((BLOCK AND CHEMPS2) OR (BLOCK AND DMRG) OR - (CHEMPS2 AND DMRG)) - message (FATAL_ERROR "BLOCK, CHEMPS2 and DMRG options are not compatible.") + (BLOCK AND DICE) OR + (CHEMPS2 AND DMRG) OR + (CHEMPS2 AND DICE) OR + (DICE AND DMRG)) + message (FATAL_ERROR "BLOCK, CHEMPS2, DICE, and DMRG options are not compatible.") endif () # Install directory @@ -1588,11 +1592,20 @@ set (Libxc_REPO https://gitlab.com/libxc/libxc.git) set (Libxc_HASH 9bf3b642) # Release 5.2.2 + if (";Debug;Release;RelWithDebInfo;" MATCHES ";${CMAKE_BUILD_TYPE};") + set (LIBXC_BUILD_TYPE ${CMAKE_BUILD_TYPE}) + elseif (";Garble;" MATCHES ";${CMAKE_BUILD_TYPE};") + set (LIBXC_BUILD_TYPE "Debug") + else () + set (LIBXC_BUILD_TYPE "Release") + endif () + # Note shared libraries won't work here because of installation issues. # TODO: Solving this will require creating a wrapper main project that includes # both Libxc and OpenMolcas as ExternalProject. This could also simplify # the handling of other codes like GlobalArrays or QCMaquis. list (APPEND LibxcCMakeArgs + -D CMAKE_BUILD_TYPE=${LIBXC_BUILD_TYPE} -D CMAKE_INSTALL_PREFIX=${EP_INSTALL} -D BUILD_SHARED_LIBS=NO -D CMAKE_C_COMPILER=${CMAKE_C_COMPILER} @@ -1970,6 +1983,32 @@ message ("CHEMPS2 interface DISABLED") endif () +# Dice-SHCI support +#================== + +if (DICE) + mark_as_advanced (CLEAR DICE_DIR) + + message ("Configuring Dice-SHCI support:") + + find_program (DICE_EXE Dice) + if (NOT DICE_EXE) + message (WARNING "No Dice installation found, you will have to make sure it is available at run time.") + endif () + + foreach (prog + wfn_util + rasscf + ) + list (APPEND ${prog}_defs "_ENABLE_DICE_SHCI_") + endforeach () + message ("-- DICE_EXE: ${DICE_EXE}") + unset (DICE_EXE CACHE) +else () + mark_as_advanced (FORCE DICE_DIR) + message ("DICE interface DISABLED") +endif () + # GPerfTools: CPU profiling #========================== @@ -2118,6 +2157,10 @@ # NECI Full-CI Quantum Monte-Carlo if (NECI) + message(FATAL_ERROR "At the moment the embedded NECI does not work. " + "Please use external NECI instead and contact the developers. " + "If https://gitlab.com/Molcas/OpenMolcas/-/issues/346 is resolved we can enable it again." + ) if (NOT MPI) message (FATAL_ERROR "NECI requires MPI (-DMPI=ON).") endif () @@ -2500,6 +2543,7 @@ list (REMOVE_ITEM utils block_dmrg_util chemps2_util + dice_util delayed_util dga_util embedding_util @@ -2655,6 +2699,17 @@ else () message (FATAL_ERROR "\"${util}\" not found in source directories.") endif () +endif () + +if (DICE) + set (util dice_util) + find_source (${util} ${source_roots}) + if (DEFINED ${util}_src) + list (APPEND utils ${util}) + list (APPEND ${util}_defs "_ENABLE_DICE_SHCI_") + else () + message (FATAL_ERROR "\"${util}\" not found in source directories.") + endif () endif () # activate libwfa support diff -Nru openmolcas-22.02/configure-cmake openmolcas-22.10/configure-cmake --- openmolcas-22.02/configure-cmake 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/configure-cmake 2022-10-10 14:22:40.000000000 +0000 @@ -83,7 +83,7 @@ "omp!", # linear algebra library locations "mkl=s", - "acml=s", + "aocl=s", "openblas=s", "cublas=s", "nvblas=s", @@ -153,7 +153,7 @@ push(@name, 'omp') if $opt{omp}; push(@name, 'ga') if defined $opt{ga}; push(@name, 'mkl') if defined $opt{mkl}; - push(@name, 'acml') if defined $opt{acml}; + push(@name, 'aocl') if defined $opt{aocl}; push(@name, 'openblas') if defined $opt{openblas}; push(@name, 'bounds') if defined $opt{bounds}; $opt{name} = join('_', @name); @@ -237,10 +237,10 @@ checkdir('mkl'); $ENV{MKLROOT} = $opt{mkl}; push @cmake_options, '-DLINALG=MKL'; -} elsif ($opt{acml}) { - checkdir('acml'); - $ENV{ACMLROOT} = $opt{acml}; - push @cmake_options, '-DLINALG=ACML'; +} elsif ($opt{aocl}) { + checkdir('aocl'); + $ENV{AOCLROOT} = $opt{aocl}; + push @cmake_options, '-DLINALG=AOCL'; } elsif ($opt{openblas}) { checkdir('openblas'); $ENV{OPENBLASROOT} = $opt{openblas}; @@ -386,7 +386,7 @@ of the chosen BLAS/LAPACK libraries --mkl PATH link to Intel MKL located in PATH - --acml PATH link to ACML located in PATH + --aocl PATH link to AOCL located in PATH --openblas PATH link to OpenBLAS located in PATH advanced: diff -Nru openmolcas-22.02/CONTRIBUTORS.md openmolcas-22.10/CONTRIBUTORS.md --- openmolcas-22.02/CONTRIBUTORS.md 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/CONTRIBUTORS.md 2022-10-10 14:22:40.000000000 +0000 @@ -75,6 +75,7 @@ Maurizio Cossi Joel Creutzberg Oleh Danyliv +Danjo De Chavez Mickaël G. Delcey Ajitha Devarajan Luca De Vico @@ -125,6 +126,7 @@ Neil Martinsen-Burrell Andy May Manuela Merchán +Isabella C. D. Merritt Samuel Mikes Abdul Rehaman Moughal Shahi Thomas Müller @@ -150,6 +152,7 @@ Björn O. Roos Ulf Ryde Andrzej J. Sadlej +Arta Safari Pawel Salek Andrew M. Sand Michael A. Saunders @@ -193,4 +196,3 @@ Yan Zhao Chen Zhou J. Patrick Zobel - diff -Nru openmolcas-22.02/debian/changelog openmolcas-22.10/debian/changelog --- openmolcas-22.02/debian/changelog 2022-06-11 16:41:44.000000000 +0000 +++ openmolcas-22.10/debian/changelog 2023-01-07 18:23:59.000000000 +0000 @@ -1,3 +1,16 @@ +openmolcas (22.10-1) unstable; urgency=medium + + * New upstream release. + * debian/patches/mkl_library_dir.patch: Refreshed. + * debian/patches/pymolcas_default_directories.patch: Likewise. + * debian/patches/install_locations.patch: Likewise. + * debian/patches/linux_platform_support.patch: Likewise. + * debian/patches/libxc_hardcode_includedir.patch: Likewise. + * debian/patches/python_interpreter.patch: Likewise. + * debian/patches/fix_libxc_interface.patch: Removed, no longer needed. + + -- Michael Banck Sat, 07 Jan 2023 19:23:59 +0100 + openmolcas (22.02-6) unstable; urgency=medium * debian/rules (FFLAGS): Replaced -fno-expensive-optimizations with diff -Nru openmolcas-22.02/debian/patches/fix_libxc_interface.patch openmolcas-22.10/debian/patches/fix_libxc_interface.patch --- openmolcas-22.02/debian/patches/fix_libxc_interface.patch 2022-04-01 16:23:20.000000000 +0000 +++ openmolcas-22.10/debian/patches/fix_libxc_interface.patch 1970-01-01 00:00:00.000000000 +0000 @@ -1,20 +0,0 @@ ---- ./src/dft_util/functionals.f90.orig 2022-04-01 18:22:25.208736509 +0200 -+++ ./src/dft_util/functionals.f90 2022-04-01 18:23:00.812925160 +0200 -@@ -87,7 +87,7 @@ - - write(u6,*) - do i=1,Def_nFuncs -- call xc_f03_func_init(func,Def_func_id(i),0_LibxcInt) -+ call xc_f03_func_init(func,Def_func_id(i),1_LibxcInt) - info = xc_f03_func_get_info(func) - write(u6,100) trim(xc_f03_func_info_get_name(info)) - ! old_j is a workaround for a bug in Libxc 5.2.0 -@@ -196,7 +196,7 @@ - ! Now the file is read, process the functional(s) - - do i=1,Def_nFuncs -- call xc_f03_func_init(func(i),Def_func_id(i),0_LibxcInt) -+ call xc_f03_func_init(func(i),Def_func_id(i),1_LibxcInt) - info(i) = xc_f03_func_get_info(func(i)) - flags(i) = xc_f03_func_info_get_flags(info(i)) - end do diff -Nru openmolcas-22.02/debian/patches/install_locations.patch openmolcas-22.10/debian/patches/install_locations.patch --- openmolcas-22.02/debian/patches/install_locations.patch 2022-03-12 17:44:05.000000000 +0000 +++ openmolcas-22.10/debian/patches/install_locations.patch 2023-01-07 18:21:29.000000000 +0000 @@ -2,7 +2,7 @@ =================================================================== --- openmolcas.orig/CMakeLists.txt +++ openmolcas/CMakeLists.txt -@@ -3373,13 +3373,13 @@ install (FILES +@@ -3428,13 +3428,13 @@ install (FILES ${PROJECT_BINARY_DIR}/molcas.rte ${PROJECT_BINARY_DIR}/LICENSE ${PROJECT_BINARY_DIR}/CONTRIBUTORS.md @@ -18,7 +18,7 @@ ) if (BUILD_SHARED_LIBS AND BUILD_STATIC_LIBS) -@@ -3391,7 +3391,7 @@ install (TARGETS +@@ -3446,7 +3446,7 @@ install (TARGETS ${PROGRAM_EXECUTABLES} ${MOLCAS_LIBRARIES} OPTIONAL @@ -27,7 +27,7 @@ LIBRARY DESTINATION ${CMAKE_INSTALL_PREFIX}/lib ARCHIVE DESTINATION ${CMAKE_INSTALL_PREFIX}/lib${subdir} ) -@@ -3402,7 +3402,7 @@ install (PROGRAMS +@@ -3457,7 +3457,7 @@ install (PROGRAMS ${PROJECT_BINARY_DIR}/sbin/help_doc ${PROJECT_BINARY_DIR}/sbin/setup ${PROJECT_BINARY_DIR}/sbin/version @@ -36,7 +36,7 @@ ) if (INSTALL_TESTS) -@@ -3419,7 +3419,7 @@ endif () +@@ -3474,7 +3474,7 @@ endif () if (TARGET pymolcas_target) install (PROGRAMS ${PYMOLCAS_SCRIPT} diff -Nru openmolcas-22.02/debian/patches/libxc_hardcode_includedir.patch openmolcas-22.10/debian/patches/libxc_hardcode_includedir.patch --- openmolcas-22.02/debian/patches/libxc_hardcode_includedir.patch 2022-03-12 18:00:30.000000000 +0000 +++ openmolcas-22.10/debian/patches/libxc_hardcode_includedir.patch 2023-01-07 18:21:33.000000000 +0000 @@ -1,6 +1,8 @@ ---- ./CMakeLists.txt.orig 2022-03-12 18:59:49.046412022 +0100 -+++ ./CMakeLists.txt 2022-03-12 19:00:28.334488285 +0100 -@@ -1553,19 +1553,19 @@ +Index: openmolcas/CMakeLists.txt +=================================================================== +--- openmolcas.orig/CMakeLists.txt ++++ openmolcas/CMakeLists.txt +@@ -1558,19 +1558,19 @@ message ("Configuring Libxc:") if (EXTERNAL_LIBXC) message ("-- External Libxc root specified at: ${EXTERNAL_LIBXC}") diff -Nru openmolcas-22.02/debian/patches/linux_platform_support.patch openmolcas-22.10/debian/patches/linux_platform_support.patch --- openmolcas-22.02/debian/patches/linux_platform_support.patch 2022-03-12 17:45:39.000000000 +0000 +++ openmolcas-22.10/debian/patches/linux_platform_support.patch 2023-01-07 18:21:32.000000000 +0000 @@ -2,7 +2,7 @@ =================================================================== --- openmolcas.orig/CMakeLists.txt +++ openmolcas/CMakeLists.txt -@@ -418,17 +418,7 @@ message ("-- ADDRMODE: ${ADDRMODE}") +@@ -419,17 +419,7 @@ message ("-- ADDRMODE: ${ADDRMODE}") # platform settings if (${CMAKE_SYSTEM_NAME} STREQUAL "Linux") add_compile_definitions (_LINUX_) diff -Nru openmolcas-22.02/debian/patches/mkl_library_dir.patch openmolcas-22.10/debian/patches/mkl_library_dir.patch --- openmolcas-22.02/debian/patches/mkl_library_dir.patch 2022-03-12 17:43:53.000000000 +0000 +++ openmolcas-22.10/debian/patches/mkl_library_dir.patch 2023-01-07 18:21:10.000000000 +0000 @@ -2,7 +2,7 @@ =================================================================== --- openmolcas.orig/CMakeLists.txt +++ openmolcas/CMakeLists.txt -@@ -1194,60 +1194,60 @@ if (LINALG STREQUAL "MKL") +@@ -1198,60 +1198,60 @@ if (LINALG STREQUAL "MKL") # core library if (${CMAKE_SYSTEM_NAME} STREQUAL "Darwin") find_library (LIBMKL_CORE NAMES "libmkl_core.a" diff -Nru openmolcas-22.02/debian/patches/pymolcas_default_directories.patch openmolcas-22.10/debian/patches/pymolcas_default_directories.patch --- openmolcas-22.02/debian/patches/pymolcas_default_directories.patch 2022-01-02 22:57:38.000000000 +0000 +++ openmolcas-22.10/debian/patches/pymolcas_default_directories.patch 2023-01-07 18:21:12.000000000 +0000 @@ -26,7 +26,7 @@ =================================================================== --- openmolcas.orig/Tools/pymolcas/pymolcas.py +++ openmolcas/Tools/pymolcas/pymolcas.py -@@ -93,10 +93,12 @@ def main(my_name): +@@ -94,10 +94,12 @@ def main(my_name): parser.usage = '{0} [options] [input_file | script ...]'.format(parser.prog) args = vars(parser.parse_args()) @@ -40,7 +40,7 @@ if (args['version']): print('python driver version = {0}'.format(Molcas_wrapper.version)) print('(after the original perl EMIL interpreter of Valera Veryazov)') -@@ -127,7 +129,7 @@ def main(my_name): +@@ -128,7 +130,7 @@ def main(my_name): if (args['extra']): in_sbin = False for path in ['MOLCAS', 'OPENMOLCAS_SOURCE', 'MOLCAS_SOURCE']: diff -Nru openmolcas-22.02/debian/patches/python_interpreter.patch openmolcas-22.10/debian/patches/python_interpreter.patch --- openmolcas-22.02/debian/patches/python_interpreter.patch 2022-04-04 16:28:49.000000000 +0000 +++ openmolcas-22.10/debian/patches/python_interpreter.patch 2023-01-07 18:21:34.000000000 +0000 @@ -1,5 +1,7 @@ ---- openmolcas-22.02.orig/CMakeLists.txt -+++ openmolcas-22.02/CMakeLists.txt +Index: openmolcas/CMakeLists.txt +=================================================================== +--- openmolcas.orig/CMakeLists.txt ++++ openmolcas/CMakeLists.txt @@ -48,7 +48,10 @@ find_program (GIT "git") find_program (PERL "perl") mark_as_advanced (FORCE GIT PERL) @@ -12,7 +14,7 @@ ################################################################################ # # -@@ -3242,9 +3245,9 @@ add_custom_target (prgms ALL +@@ -3297,9 +3300,9 @@ add_custom_target (prgms ALL add_dependencies (mods_obj prgms) # generate help databases from doc @@ -24,7 +26,7 @@ ERROR_VARIABLE EXTRACT_ERROR RESULT_VARIABLE EXTRACT_RESULT ) -@@ -3265,7 +3268,7 @@ if (Python_FOUND) +@@ -3320,7 +3323,7 @@ if (Python_FOUND) endif () endif () else () @@ -33,8 +35,10 @@ endif () # generate rcodes.txt file ---- openmolcas-22.02.orig/Tools/dynamixtools/CMakeLists.txt -+++ openmolcas-22.02/Tools/dynamixtools/CMakeLists.txt +Index: openmolcas/Tools/dynamixtools/CMakeLists.txt +=================================================================== +--- openmolcas.orig/Tools/dynamixtools/CMakeLists.txt ++++ openmolcas/Tools/dynamixtools/CMakeLists.txt @@ -16,11 +16,11 @@ endif () file (RELATIVE_PATH tooldir ${BASE_DIR} ${CMAKE_CURRENT_LIST_DIR}) set (EXECUTABLE_OUTPUT_PATH ${PROJECT_BINARY_DIR}/${tooldir}) @@ -57,8 +61,10 @@ + message (WARNING "No appropriate python interpreter found, dynamixtools will be disabled") endif () ---- openmolcas-22.02.orig/Tools/pymolcas/CMakeLists.txt -+++ openmolcas-22.02/Tools/pymolcas/CMakeLists.txt +Index: openmolcas/Tools/pymolcas/CMakeLists.txt +=================================================================== +--- openmolcas.orig/Tools/pymolcas/CMakeLists.txt ++++ openmolcas/Tools/pymolcas/CMakeLists.txt @@ -19,14 +19,14 @@ set (OUTPUT_PATH ${PROJECT_BINARY_DIR}/) file (GLOB py_sources "*.py") list (REMOVE_ITEM py_sources "${CMAKE_CURRENT_LIST_DIR}/pack.py") diff -Nru openmolcas-22.02/debian/patches/series openmolcas-22.10/debian/patches/series --- openmolcas-22.02/debian/patches/series 2022-04-04 16:28:55.000000000 +0000 +++ openmolcas-22.10/debian/patches/series 2023-01-07 18:23:22.000000000 +0000 @@ -5,4 +5,3 @@ linux_platform_support.patch libxc_hardcode_includedir.patch python_interpreter.patch -fix_libxc_interface.patch diff -Nru openmolcas-22.02/doc/doxygen/Doxyfile openmolcas-22.10/doc/doxygen/Doxyfile --- openmolcas-22.02/doc/doxygen/Doxyfile 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/doxygen/Doxyfile 2022-10-10 14:22:40.000000000 +0000 @@ -282,7 +282,7 @@ # Note that for custom extensions you also need to set FILE_PATTERNS otherwise # the files are not read by doxygen. -EXTENSION_MAPPING = +EXTENSION_MAPPING = fh=Fortran # If the MARKDOWN_SUPPORT tag is enabled then doxygen pre-processes all comments # according to the Markdown format, which allows for more readable @@ -798,7 +798,7 @@ # *.m, *.markdown, *.md, *.mm, *.dox, *.py, *.pyw, *.f90, *.f, *.for, *.tcl, # *.vhd, *.vhdl, *.ucf, *.qsf, *.as and *.js. -FILE_PATTERNS = +FILE_PATTERNS = *.c *.h *.f *.f90 *.F90 *.fh *.dox # The RECURSIVE tag can be used to specify whether or not subdirectories should # be searched for input files as well. @@ -900,7 +900,7 @@ # need to set EXTENSION_MAPPING for the extension otherwise the files are not # properly processed by doxygen. -FILTER_PATTERNS = "*.f=./filter.sh" +FILTER_PATTERNS = "*.f=./filter.sh" "*.f90=./filter.sh" "*.F90=./filter.sh" # If the FILTER_SOURCE_FILES tag is set to YES, the input filter (if set using # INPUT_FILTER) will also be used to filter the input files that are used for @@ -2021,7 +2021,7 @@ # preprocessor. # This tag requires that the tag SEARCH_INCLUDES is set to YES. -INCLUDE_PATH = +INCLUDE_PATH = ../../src/Include # You can use the INCLUDE_FILE_PATTERNS tag to specify one or more wildcard # patterns (like *.h and *.hpp) to filter out the header-files in the @@ -2039,7 +2039,7 @@ # recursively expanded use the := operator instead of the = operator. # This tag requires that the tag ENABLE_PREPROCESSING is set to YES. -PREDEFINED = +PREDEFINED = _I8_ _HDF5_ # If the MACRO_EXPANSION and EXPAND_ONLY_PREDEF tags are set to YES then this # tag can be used to specify a list of macro names that should be expanded. The @@ -2378,7 +2378,7 @@ # Minimum value: 0, maximum value: 10000, default value: 50. # This tag requires that the tag HAVE_DOT is set to YES. -DOT_GRAPH_MAX_NODES = 100 +DOT_GRAPH_MAX_NODES = 500 # The MAX_DOT_GRAPH_DEPTH tag can be used to set the maximum depth of the graphs # generated by dot. A depth value of 3 means that only nodes reachable from the diff -Nru openmolcas-22.02/doc/doxygen/filter.sh openmolcas-22.10/doc/doxygen/filter.sh --- openmolcas-22.02/doc/doxygen/filter.sh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/doxygen/filter.sh 2022-10-10 14:22:40.000000000 +0000 @@ -14,10 +14,4 @@ # Preprocess file cat $1 | \ # Fix case of automatic links - ./fix_links.py | \ - # Disable #include directives (using "C" to avoid mis-detection as free format) - sed -e 's/^#include/Cinclude/' -e 's/^[*cC!]/C/' | \ - # Preprocess with cpp - #cpp -undef -w -fdirectives-only -dU -P -nostdinc - # Preprocess with gpp - gpp -n -U "" "" "(" "," ")" "(" ")" "#" "" -M "\n#\w" "\n" " " " " "\n" "" "" + ./fix_links.py diff -Nru openmolcas-22.02/doc/doxygen/fix_links.py openmolcas-22.10/doc/doxygen/fix_links.py --- openmolcas-22.02/doc/doxygen/fix_links.py 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/doxygen/fix_links.py 2022-10-10 14:22:40.000000000 +0000 @@ -17,10 +17,10 @@ import re doxygen_re = re.compile(r"^[*Cc!]>") -link_re = re.compile(r"::(\w*)") +link_re = re.compile(r" ::(\w*)") # Replace [::FuncName] with [\ref funcname "FuncName"] -reflink = lambda pat: r'\ref {} "{}"'.format(pat.group(1).lower(), pat.group(1)) +reflink = lambda pat: r' \ref {} "{}"'.format(pat.group(1).lower(), pat.group(1)) for line in fileinput.input(): if (doxygen_re.search(line)): diff -Nru openmolcas-22.02/doc/doxygen/source.bib openmolcas-22.10/doc/doxygen/source.bib --- openmolcas-22.02/doc/doxygen/source.bib 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/doxygen/source.bib 2022-10-10 14:22:40.000000000 +0000 @@ -158,3 +158,15 @@ title = {Modern Quantum Chemistry}, year = {1989} } + +@article{Sei2022-JCTC-18-4164, + author = {Seidl, Christopher and Barca, Giuseppe M. J.}, + title = {{Q}-{N}ext: A Fast, Parallel, and Diagonalization-Free Alternative to Direct Inversion of the Iterative Subspace}, + journal = JCTC, + year = {2022}, + volume = {18}, + pages = {4164-4176}, + number = {7}, + doi = {10.1021/acs.jctc.2c00073}, +} + diff -Nru openmolcas-22.02/doc/extensions/float.py openmolcas-22.10/doc/extensions/float.py --- openmolcas-22.02/doc/extensions/float.py 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/extensions/float.py 2022-10-10 14:22:40.000000000 +0000 @@ -9,18 +9,21 @@ # For more details see the full text of the license in the file * # LICENSE or in . * # * -# Copyright (C) 2015,2016, Ignacio Fdez. Galván * +# Copyright (C) 2015,2016,2022, Ignacio Fdez. Galván * #*********************************************************************** +import sphinx from docutils import nodes from docutils.parsers.rst import Directive, directives from docutils.statemachine import ViewList from sphinx.util.nodes import set_source_info +from sphinx.builders.latex.nodes import captioned_literal_block -class float_container(nodes.General, nodes.Element): pass -class table_container(nodes.General, nodes.Element): pass -class figure_container(nodes.General, nodes.Element): pass -class code_container(nodes.General, nodes.Element): pass +class container(nodes.General, nodes.Element): pass +class float_container(container): pass +class table_container(container): pass +class figure_container(container): pass +class code_container(container): pass # Create the float directive # @@ -73,20 +76,49 @@ ids += self.hypertarget(node['ids'][0], anchor=False) if (isinstance(node, table_container)): floattype = 'table' - elif (isinstance(node, figure_container)): - floattype = 'figure' - elif (isinstance(node, code_container)): - floattype = 'code' + self.body.append('\\sphinxcapstartof{%s}\n' % floattype) + self.context.append(ids + '\n') else: - floattype = 'float' - self.body.append('\\begin{%s}\n' % floattype) - if any(isinstance(child, nodes.caption) for child in node): - self.body.append('\\capstart\n') - self.context.append(ids + '\\end{%s}\n' % floattype) + if (isinstance(node, figure_container)): + floattype = 'figure' + elif (isinstance(node, code_container)): + floattype = 'code' + else: + floattype = 'float' + self.body.append('\\begin{%s}\n' % floattype) + if any(isinstance(child, nodes.caption) for child in node): + self.body.append('\\capstart\n') + self.context.append(ids + '\\end{%s}\n' % floattype) def depart_float_latex(self, node): self.body.append(self.context.pop()) +# Patch caption formatting in containers +# +visit_caption_orig = sphinx.writers.latex.LaTeXTranslator.visit_caption +depart_caption_orig = sphinx.writers.latex.LaTeXTranslator.depart_caption +def visit_caption_patched(self, node: nodes.Element) -> None: + if isinstance(node.parent, container): + if node.parent[0] is node: + self.body.append('\\sphinxthecaptionisattop\n') + self.in_caption += 1 + if isinstance(node.parent, table_container): + self.body.append('\\sphinxcaption{') + else: + self.body.append('\\caption{') + else: + visit_caption_orig(self, node) +def depart_caption_patched(self, node: nodes.Element) -> None: + if isinstance(node.parent, container): + self.body.append('}') + if node.parent[0] is node: + self.body.append('\n\\sphinxaftertopcaption') + self.in_caption -= 1 + else: + depart_caption_orig(self, node) +sphinx.writers.latex.LaTeXTranslator.visit_caption = visit_caption_patched +sphinx.writers.latex.LaTeXTranslator.depart_caption = depart_caption_patched + # Setup # def setup(app): diff -Nru openmolcas-22.02/doc/extensions/molcasbib.py openmolcas-22.10/doc/extensions/molcasbib.py --- openmolcas-22.02/doc/extensions/molcasbib.py 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/extensions/molcasbib.py 2022-10-10 14:22:40.000000000 +0000 @@ -445,12 +445,7 @@ self.format_volume_and_series(e), sentence [ field('publisher'), - optional_field('address'), - optional [ - words [field('edition'), 'edition'] - ], date, - optional_field('note'), ], self.format_web_refs(e), ] @@ -462,7 +457,6 @@ words [ 'In', sentence [ - optional [ self.format_editor(e, as_sentence=False) ], self.format_btitle(e, 'booktitle', as_sentence=False), self.format_volume_and_series(e, as_sentence=False), self.format_chapter_and_pages(e), @@ -470,13 +464,25 @@ ], sentence [ optional_field('publisher'), - optional_field('address'), - self.format_edition(e), date, ], self.format_web_refs(e), ] return template + + def get_book_template(self, e): + template = toplevel [ + self.format_author_or_editor(e), + self.format_btitle(e, 'title'), + self.format_volume_and_series(e), + sentence [ + field('publisher'), + date + ], + sentence [ optional_field('note') ], + self.format_web_refs(e), + ] + return template def get_phdthesis_template(self, e): template = toplevel [ diff -Nru openmolcas-22.02/doc/extensions/patch.py openmolcas-22.10/doc/extensions/patch.py --- openmolcas-22.02/doc/extensions/patch.py 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/extensions/patch.py 2022-10-10 14:22:40.000000000 +0000 @@ -15,7 +15,7 @@ import sphinx # Patch to work around Sphinx bug #9529 -if sphinx.version_info >= (3, 5, 0, '', 0): +if (3, 5, 0, '', 0) <= sphinx.version_info < (4, 5, 0, '', 0): from sphinx.writers.latex import CR from docutils import nodes from docutils.nodes import Element diff -Nru openmolcas-22.02/doc/.gitlab-ci.yml openmolcas-22.10/doc/.gitlab-ci.yml --- openmolcas-22.02/doc/.gitlab-ci.yml 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/.gitlab-ci.yml 2022-10-10 14:22:40.000000000 +0000 @@ -59,11 +59,23 @@ #- echo 'CALL_GRAPH = YES' >> Doxyfile #- echo 'CALLER_GRAPH = YES' >> Doxyfile - doxygen + - > + if [ "$(wc -l < doxygen.log)" == "0" ] ; then + true + else + echo "***********************************" + echo "* Doxygen finished with warnings! *" + echo "***********************************" + cat doxygen.log + echo "***********************************" + # Unfortunately, doxygen warnings are not quite reliable + #false + true + fi after_script: - | if [ -z "${install_path}" ] ; then export install_path="/opt/OpenMolcas"; fi - mv ${install_path} install_dir - - cat doc/doxygen/doxygen.log artifacts: reports: dotenv: variables.env diff -Nru openmolcas-22.02/doc/README.md openmolcas-22.10/doc/README.md --- openmolcas-22.02/doc/README.md 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/README.md 2022-10-10 14:22:40.000000000 +0000 @@ -10,8 +10,8 @@ The `.rst` files contain embedded blocks that are used to generate command-line help (accessed with `pymolcas help_doc`) and an XML input description for MolGUI. These blocks use the `.. xmldoc::` directive and follow a format -similar to that described -[here](https://gitlab.com/Molcas/OpenMolcas/wikis/Programming%20guide/Documentation). +described +[here](https://gitlab.com/Molcas/OpenMolcas/wikis/xml%20syntax%20documentation). To build the documentation, after configuring OpenMolcas with `cmake`, run `make doc_html` or `make doc_pdf`. diff -Nru openmolcas-22.02/doc/source/advanced.examples/ex-ex.rst openmolcas-22.10/doc/source/advanced.examples/ex-ex.rst --- openmolcas-22.02/doc/source/advanced.examples/ex-ex.rst 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/advanced.examples/ex-ex.rst 2022-10-10 14:22:40.000000000 +0000 @@ -1219,7 +1219,7 @@ "Fr", "In", "Ac", "Se" or "De" for frozen (uncorrelated), inactive, active, secondary, and deleted orbitals. In the wave operator, the only possible orbital labels are "In" and "Se". -The active superindex is given in formulae as :math:`\mu`, :math:`\nu`, etc so it is +The active superindex is given in formulae as :math:`\mu`, :math:`\nu`, etc. so it is given a prefix "Mu". Most of the cases are further subdivided into a plus and a minus linear combination diff -Nru openmolcas-22.02/doc/source/conf.py openmolcas-22.10/doc/source/conf.py --- openmolcas-22.02/doc/source/conf.py 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/conf.py 2022-10-10 14:22:40.000000000 +0000 @@ -9,7 +9,7 @@ # For more details see the full text of the license in the file * # LICENSE or in . * # * -# Copyright (C) 2015-2018, Ignacio Fdez. Galván * +# Copyright (C) 2015-2018,2022, Ignacio Fdez. Galván * #*********************************************************************** # # This file is execfile()d with the current directory set to its @@ -461,6 +461,14 @@ \old@spx@thefnmark{#1}{#2}% }% \makeatother% +% Fix sphinx bug #10188 +\let\sphinxstepexplicit\relax% +% Fix sphinx bug #10342 +\makeatletter% +\ifdefined\sphinxAtStartPar% + \g@addto@macro\sphinxAtStartPar{\@ifnextchar\par{\@gobble}{}}% +\fi% +\makeatother% ''' latex_additional_files = [ '_latex/molcas.sty' ] diff -Nru openmolcas-22.02/doc/source/installation.guide/diceinst.rst openmolcas-22.10/doc/source/installation.guide/diceinst.rst --- openmolcas-22.02/doc/source/installation.guide/diceinst.rst 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/doc/source/installation.guide/diceinst.rst 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,46 @@ +.. _sec\:dice_installation: + +Installation of Dice--|molcas| interface for HCI calculations +============================================================= + +.. only:: html + + .. contents:: + :local: + :backlinks: none + + +The Dice--|molcas| interface allows one to use heat-bath configuration interaction (HCI) +implemented in Dice as an FCI solver in CASSCF calculations, referred to as HCI-CASSCF :cite:`Sharma2017,Holmes2016`. +A large active space, up to around 100 active orbitals, can be calculated with HCI-CASSCF. +Currently, the interface supports ground state HCI-CASSCF calculations. + +The interface requires the Dice 1.0 binary (https://github.com/sanshar/Dice). +For installation of Dice, consult https://sanshar.github.io/Dice/installation.html. +The interface supports both parallel Dice and |molcas|. + +The Dice--|molcas| interface is built by activating in CMake: + +:: + + -D DICE=ON + +Before runing HCI-CASSCF calculations with the Dice--|molcas| interface, make sure to increase stack size; +and export the Dice binary and all the required libraries for Dice. + +:: + + ulimit -s unlimited + export PATH=/path/to/dice/binary:$PATH + +To run parallel Dice, export the environment variable :variable:`MOLCAS_DICE`, for example when running on 16 nodes use: + +:: + + export MOLCAS_DICE=16 + +Verify the installation: + +:: + + molcas verify .all -w dice diff -Nru openmolcas-22.02/doc/source/installation.guide/ig.rst openmolcas-22.10/doc/source/installation.guide/ig.rst --- openmolcas-22.02/doc/source/installation.guide/ig.rst 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/installation.guide/ig.rst 2022-10-10 14:22:40.000000000 +0000 @@ -7,5 +7,6 @@ install parainst dmrginst + diceinst stochcas maintain diff -Nru openmolcas-22.02/doc/source/molcas.bib openmolcas-22.10/doc/source/molcas.bib --- openmolcas-22.02/doc/source/molcas.bib 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/molcas.bib 2022-10-10 14:22:40.000000000 +0000 @@ -3699,3 +3699,25 @@ Number = {2}, Doi = {10.1002/jcc.20702} } + +@Article{Sharma2017, + Title = {Semistochastic heat-bath configuration interaction method: Selected configuration interaction with semistochastic perturbation theory}, + Author = {Sharma, Sandeep and Holmes, Adam A. and Jeanmairet, Guillaume and Alavi, Ali and Umrigar, Cyrus J.}, + Journal = jctc, + Volume = {13}, + Number = {4}, + Pages = {1595-1604}, + Year = {2017}, + Doi = {10.1021/acs.jctc.6b01028} +} + +@Article{Holmes2016, + Title = {Heat-bath configuration interaction: An efficient selected configuration interaction algorithm inspired by heat-bath sampling}, + Author = {Holmes, Adam A. and Tubman, Norm M. and Umrigar, C. J.}, + Journal = jctc, + Volume = {12}, + Number = {8}, + Pages = {3674-3680}, + Year = {2016}, + Doi = {10.1021/acs.jctc.6b00407} +} diff -Nru openmolcas-22.02/doc/source/_theme/molcas/static/molcas.css_t openmolcas-22.10/doc/source/_theme/molcas/static/molcas.css_t --- openmolcas-22.02/doc/source/_theme/molcas/static/molcas.css_t 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/_theme/molcas/static/molcas.css_t 2022-10-10 14:22:40.000000000 +0000 @@ -45,6 +45,10 @@ /* Default body styles */ +* { + scrollbar-color: {{ theme_linkcolor }} {{ theme_faintcolor }} ; +} + a { color: {{ theme_linkcolor }}; } @@ -332,6 +336,7 @@ font-size: 0.9em; background-color: {{ theme_sidebarbg }}; color: {{ theme_sidebarcolor }}; + scrollbar-color: {{ theme_sidebarcolor }} {{ theme_sidebarhlcolor }}; padding: 1em; margin-top: -20px; border: solid {{ theme_headerbordercolor }}; diff -Nru openmolcas-22.02/doc/source/_theme/molcas/theme.conf openmolcas-22.10/doc/source/_theme/molcas/theme.conf --- openmolcas-22.02/doc/source/_theme/molcas/theme.conf 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/_theme/molcas/theme.conf 2022-10-10 14:22:40.000000000 +0000 @@ -17,7 +17,7 @@ textcolor = #000000 bgcolor = #ffffff -faintcolor = #888888 +faintcolor = #dddddd linkcolor = #010165 hlcolor = #cbcca8 diff -Nru openmolcas-22.02/doc/source/tutorials/nutshell.rst openmolcas-22.10/doc/source/tutorials/nutshell.rst --- openmolcas-22.02/doc/source/tutorials/nutshell.rst 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/tutorials/nutshell.rst 2022-10-10 14:22:40.000000000 +0000 @@ -515,7 +515,7 @@ options, compared to GV. LUSCUS can be obtained from http://luscus.sourceforge.net/, or -from http://www.molcas.org/LUSCUS. +from https://www.molcas.org/LUSCUS. LUSCUS can read the files only in one format: Luscus internal format (:file:`.lus`). This format contains two sections: XYZ cartesian coordinates, and XML diff -Nru openmolcas-22.02/doc/source/users.guide/dft_functionals.inc openmolcas-22.10/doc/source/users.guide/dft_functionals.inc --- openmolcas-22.02/doc/source/users.guide/dft_functionals.inc 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/users.guide/dft_functionals.inc 2022-10-10 14:22:40.000000000 +0000 @@ -1,7 +1,8 @@ DFT functionals: :::::::::::::::: -Below is listed the keywords for the DFT functionals currently implemented in the package. +Below is a partial list of the keywords for DFT functionals currently implemented in the package. +Note that most `Libxc `_ functionals are available too. .. class:: keywordlist diff -Nru openmolcas-22.02/doc/source/users.guide/emil.rst openmolcas-22.10/doc/source/users.guide/emil.rst --- openmolcas-22.02/doc/source/users.guide/emil.rst 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/users.guide/emil.rst 2022-10-10 14:22:40.000000000 +0000 @@ -183,7 +183,7 @@ A compulsory value for this command is the filename. A command to inline a file in the input file. The file will be extracted into WorkDir before the start of the calculation. The end of file should be marked as :command:`EOF` command. - Not that the file is only created in the master process WorkDir, if the slaves + Note that the file is only created in the master process WorkDir, if the slaves need access to it, you'll need to use the :command:`COPY` command (see below). All files specified with :command:`FILE` are created at the beginning of the calculation, regardless of their placement in the input. diff -Nru openmolcas-22.02/doc/source/users.guide/molden.inc openmolcas-22.10/doc/source/users.guide/molden.inc --- openmolcas-22.02/doc/source/users.guide/molden.inc 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/users.guide/molden.inc 2022-10-10 14:22:40.000000000 +0000 @@ -53,7 +53,7 @@ real spherical harmonics, otherwise no MOLDEN file for orbitals will be generated. For further details with respect to Molden consult -http://www.cmbi.ru.nl/molden/. +https://www.theochem.ru.nl/molden/. For further details with respect to LUSCUS consult http://luscus.sourceforge.net/. diff -Nru openmolcas-22.02/doc/source/users.guide/programs/cht3.rst openmolcas-22.10/doc/source/users.guide/programs/cht3.rst --- openmolcas-22.02/doc/source/users.guide/programs/cht3.rst 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/users.guide/programs/cht3.rst 2022-10-10 14:22:40.000000000 +0000 @@ -155,17 +155,17 @@ -:kword:`MHKEy` - Integer on the following line specifies if library BLAS (MHKEy=1) or hard-coded - fortran vector-vector, matrix-vector and matrix-matrix manipulation is used. - This keyword is *optional*. (Default=1) + .. :kword:`MHKEy` + Integer on the following line specifies if library BLAS (MHKEy=1) or hard-coded + fortran vector-vector, matrix-vector and matrix-matrix manipulation is used. + This keyword is *optional*. (Default=1) - .. xmldoc:: - %%Keyword: MHKEy - - Specifies if BLAS libraries (=1) or hard-code fortran is used. - - + .. xmldoc:: + %%Keyword: MHKEy + + Specifies if BLAS libraries (=1) or hard-code fortran is used. + + :kword:`NOGEnerate` This keyword specifies that the pre-(T) steps (generation of integrals from diff -Nru openmolcas-22.02/doc/source/users.guide/programs/espf.rst openmolcas-22.10/doc/source/users.guide/programs/espf.rst --- openmolcas-22.02/doc/source/users.guide/programs/espf.rst 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/users.guide/programs/espf.rst 2022-10-10 14:22:40.000000000 +0000 @@ -69,9 +69,9 @@ The interface to :program:`GROMACS` differs from the :program:`TINKER` interface in that the MM code is not run as a separate program but included in |molcas| as a library. In this way, the communication between the QM and MM codes is handled by simple function calls instead of using data files. The interface is automatically installed along with |molcas| provided that the :program:`GROMACS` library (currently a development version\ [#fn2]_) is available at configuration time\ [#fn3]_. Instructions how to install the :program:`GROMACS` library can be found at the official web site\ [#fn4]_. Make sure that the installation is done in double precision since this is the precision used by |molcas|. Also make sure to source the :program:`GROMACS` GMXR script in your shell startup file. otherwise the |molcas| configuration procedure will not be able to detect the relevant library path. -.. [#fn2] http://repo.or.cz/w/gromacs.git/shortlog/refs/heads/qmmm +.. [#fn2] https://repo.or.cz/w/gromacs.git/shortlog/refs/heads/qmmm .. [#fn3] Configuration with CMake requires the flag ``-D GROMACS=ON`` -.. [#fn4] http://www.gromacs.org/ +.. [#fn4] https://www.gromacs.org/ The recommended (and the only verified) approach of using the |molcas|/:program:`GROMACS` interface is to define the full QM+MM system in the :program:`GROMACS` input. The system definition can then be imported into |molcas| by adding the keyword :kword:`GROMACS` in :program:`GATEWAY` (see :numref:`UG:sec:gateway` for details). For efficiency reasons, the |molcas| part of the interface separates the MM subsystem into two different atom types: *inner* MM atoms and *outer* MM atoms. These are completely equivalent as far as interactions are concerned. However, whereas the coordinates of the inner MM atoms are stored and updated using |molcas| standard mechanism, the outer MM atoms are handled using a mechanism specifically designed with large systems in mind. The division into inner and outer MM atoms can be controlled with options to the :kword:`GROMACS` keyword in :program:`GATEWAY` (see :numref:`UG:sec:gateway`). diff -Nru openmolcas-22.02/doc/source/users.guide/programs/gateway.rst openmolcas-22.10/doc/source/users.guide/programs/gateway.rst --- openmolcas-22.02/doc/source/users.guide/programs/gateway.rst 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/users.guide/programs/gateway.rst 2022-10-10 14:22:40.000000000 +0000 @@ -627,7 +627,7 @@ orbitals in R-matrix calculations. The label is truncated to four characters. Observe that this label must be unique to each center. The coordinate unit can - be specified as an option. The default unit is Bohr. + be specified as an option. The default unit is bohr. There should at least be one card of this type in a basis set definition. @@ -970,7 +970,7 @@ Use the RI-J basis in the density fitting (DF) approach to treat the two-electron integrals. Note that the valence basis set must have a supporting auxiliary basis set for this to work. - .. xmldoc:: + .. xmldoc:: %%Keyword: RIJ Use the RI-J auxiliary basis in the density fitting (DF) approach to treat the two-electron integrals. @@ -982,7 +982,7 @@ Use the RI-JK auxiliary basis in the density fitting (DF) approach to treat the two-electron integrals. Note that the valence basis set must have a supporting auxiliary basis set for this to work. - .. xmldoc:: + .. xmldoc:: %%Keyword: RIJK Use the RI-JK auxiliary basis in the density fitting (DF) approach to treat the two-electron integrals. @@ -994,7 +994,7 @@ Use the RI-C auxiliary basis in the density fitting (DF) approach to treat the two-electron integrals. Note that the valence basis set must have a supporting auxiliary basis set for this to work. - .. xmldoc:: + .. xmldoc:: %%Keyword: RIC Use the RI-C auxiliary basis in the density fitting (DF) approach to treat the two-electron integrals. @@ -1006,7 +1006,7 @@ Use the aCD or acCD approach :cite:`Aquilante:07b` to treat the two-electron integrals. This procedure will use an on-the-fly generated auxiliary basis set. - .. xmldoc:: + .. xmldoc:: %%Keyword: RICD Use the aCD or acCD approach to treat the two-electron integrals. @@ -1014,11 +1014,21 @@ +:kword:`XRICd` + Use an externally generated RICD basis set available in the file :file:`$Project.RICDLib`. + + .. xmldoc:: + %%Keyword: xRICD + + Use an externally generated RICD basis set available in the file $Project.RICDLib. + + + :kword:`NOCD` Disable Cholesky decomposition. Useful in the case :kword:`RICD` has been made the default with :variable:`MOLCAS_NEW_DEFAULTS`. - .. xmldoc:: + .. xmldoc:: %%Keyword: NOCD Disable Cholesky decomposition. @@ -1026,8 +1036,6 @@ - .. xmldoc:: - :kword:`CDTHreshold` Threshold for on-the-fly generation of aCD or acCD auxiliary basis sets for RI calculations (default value 1.0d-4). @@ -1260,7 +1268,7 @@ It indicates the beginning of the specification of the reaction field parameters. The subsequent line will contain the dielectric constant of the medium, the radius of the - cavity in Bohrs (the cavity is always centered around the + cavity in bohrs (the cavity is always centered around the origin), and the angular quantum number of the highest multipole moment used in the expansion of the change distribution of the molecule (only charge is specified as 0, charge and dipole @@ -1279,7 +1287,7 @@ This indicated the beginning of the specification of the reaction field parameters. The subsequent line will contain the dielectric constant of the medium, the radius of the - cavity in Bohrs (the cavity is always centered around the + cavity in bohrs (the cavity is always centered around the origin), and the angular quantum number of the highest multipole moment used in the expansion of the change distribution of the molecule (only charge is specified as 0, charge and dipole @@ -1699,7 +1707,7 @@ be 0 or 1 (where 0 is default), specifying whether an element number (e.g. 8 for oxygen) should be read for each multipole. In that case the default radius for that element is used to determine which Langevin grid points should be annihilated. A negative element number signifies that a particular - radius should be used for that multipole, in thousands of a Bohr (-1400 meaning 1.4 Bohr). + radius should be used for that multipole, in thousandths of a bohr (-1400 meaning 1.4 bohr). Then follows nXF lines, one for each center. On each line is first nFrag+nRead (which may equal 0) integers, specifying the fragments that the multipole should not contribute to (the first fragment is taken as the fragment that the polarisability belongs to) and the element number. Then follows @@ -1735,7 +1743,7 @@ be 0 or 1 (where 0 is default), specifying whether an element number (e.g. 8 for oxygen) should be read for each multipole. In that case the default radius for that element is used to determine which Langevin grid points should be annihilated. A negative element number signifies that a particular - radius should be used for that multipole, in thousands of a Bohr (-1400 meaning 1.4 Bohr). + radius should be used for that multipole, in thousandths of a bohr (-1400 meaning 1.4 bohr). Then follows nXF lines, one for each center. On each line is first nFrag+nRead (which may equal 0) integers, specifying the fragments that the multipole should not contribute to (the first fragment is taken as the fragment that the polarisability belongs to) and the element number. Then follows diff -Nru openmolcas-22.02/doc/source/users.guide/programs/mcpdft.rst openmolcas-22.10/doc/source/users.guide/programs/mcpdft.rst --- openmolcas-22.02/doc/source/users.guide/programs/mcpdft.rst 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/users.guide/programs/mcpdft.rst 2022-10-10 14:22:40.000000000 +0000 @@ -152,7 +152,7 @@ :kword:`MSPDFT` - This keyword allows one to run Multi-State Pair-Density Functional Theory (MS-PDFT). This keyword is only effective when a file named :file:`H0_Rotate.txt` is present in the scratch directory, otherwise only state-specific MC-PDFT calculations will be performed. With the :kword:`MSPD` keyword, the program reads the Hamiltonian matrix from :file:`H0_Rotate.txt`, replaces the diagonal elements with the MC-PDFT energies of the rotated states (presumably obtained from a previous :program:`RASSCF` module in which the keyword :kword:`ROST`, :kword:`XMSI` or :kword:`CMSI` is used), and diagonalizes the Hamiltonian matrix in the intermediate basis (called the effective Hamiltonian matrix) to obtain the MS-PDFT states and energies. An input example is shown below. More details regarding the theory, the input, and the output can be found on the Minnesota OpenMolcas page\ [#fn1]_. + This keyword allows one to run Multi-State Pair-Density Functional Theory (MS-PDFT). This keyword is only effective when a file named :file:`H0_Rotate.txt` is present in the scratch directory, otherwise only state-specific MC-PDFT calculations will be performed. With the :kword:`MSPD` keyword, the program reads the Hamiltonian matrix from :file:`H0_Rotate.txt`, replaces the diagonal elements with the MC-PDFT energies of the rotated states (presumably obtained from a previous :program:`RASSCF` module in which the keyword :kword:`ROST`, :kword:`XMSI` or :kword:`CMSI` is used), and diagonalizes the Hamiltonian matrix in the intermediate basis (called the effective Hamiltonian matrix) to obtain the MS-PDFT states and energies. An input example is shown below. More details regarding the theory, the input, and the output can be found on the Minnesota OpenMolcas page\ [#fn1]_. XMS-PDFT and CMS-PDFT are two MS-PDFT options in the code. @@ -161,7 +161,7 @@ .. xmldoc:: %%Keyword: MSPDFT - Enable MS-PDFT. Requires H0_Rotate.txt file in the scratch directory. + Enables MS-PDFT. Requires H0_Rotate.txt file in the scratch directory. @@ -176,6 +176,16 @@ +:kword:`LAMBda` + This keyword is used to run a hybrid MC-PDFT or hybrid MS-PDFT calculation. In hybrid MC-PDFT calculations, the total energy is a weighted sum of the MC-PDFT energy and the wave function energy. In hybrid MS-PDFT calculations, the intermediate state energies (the diagonal elements of the model-space Hamiltonian) are weighted sums of the MC-PDFT energy and the wave function energy. The weight of the wave function energy is given by Lambda, and the weight of the PDFT energy is one minus Lambda; for example, to run MC-PDFT with tPBE0, the value for Lambda should be 0.25. The default is Lambda=0.0. + + .. xmldoc:: + %%Keyword: MSPDFT + + Enables hybrid PDFT calculations. + + + :kword:`FILEORB` This keyword allows one to set as reference wave function file instead of :file:`JOBIPH` a different one, in particular an HDF5 file. If the MC-PDFT is to be followed by an MPSSI calculation for a reference DMRG wave function, please also add the keyword :kword:`WJOB`. Example: ``FileOrb = wavefunction.h5`` diff -Nru openmolcas-22.02/doc/source/users.guide/programs/rasscf.rst openmolcas-22.10/doc/source/users.guide/programs/rasscf.rst --- openmolcas-22.02/doc/source/users.guide/programs/rasscf.rst 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/users.guide/programs/rasscf.rst 2022-10-10 14:22:40.000000000 +0000 @@ -263,13 +263,14 @@ The Stochastic-CASSCF :cite:`limanni2016` has been developed since 2015 by Li Manni and Alavi, initially into a locally modified version of |molcas| and now available in |openmolcas|. -The method retains the simplicity of CASSCF, while circuventing the the exponential scaling of CAS wave functions. +The method retains the simplicity of CASSCF, while circumventing the exponential scaling of CAS wave functions. This is obtained by replacing the Davidson diagonalization technique, in its direct-CI implementation (default in |molcas|), with the full-CI quantum Monte-Carlo (FCIQMC) algorithm :cite:`Alavi2009`, whilst the Super-CI method is used for the orbital optimization. -The method is compatible with density fitting techniques available within |openmolcas|. -The method is also compatible with subsequent MC-PDFT method to recover correlation outside the active space. +The method is compatible with density fitting techniques available within +|openmolcas|, subsequent MC-PDFT calculations to recover correlation +outside the active space and state-averaging across multiple multiplicities. .. _UG\:sec\:StochCAS_dependencies: @@ -291,7 +292,7 @@ .. class:: filelist :file:`FCIINP` - The :file:`$Project.FciInp` (or :file:`FCIINP`) file contains input keywords for the NECI code. + The :file:`$Project.FciInp` (or :file:`FCIINP`) file contains input keywords for the :program:`NECI` code. These keywords need to be adjusted depending on the chemical system under investigation for an optimal FCIQMC dynamics. :file:`FCIDMP` @@ -301,11 +302,16 @@ The Input and the FCIDUMP files are the only files necessary to :program:`NECI` to run a FCIQMC simulation from scratch. For questions about the FCIQMC dynamics we invite to contact its developers. -As accurate density matrices are necessary for a successful Stochastic-CASSCF calculation, -users are invited to use the :file:`dneci.x` binary (this will run the FCIQMC dynamic in replica mode) :cite:`Overy2014`. -The FCIQMC dymanics can be followed in the :file:`fciqmc.out` output file or in the NECI generated :file:`FCIMCStats` file. -In the :file:`fciqmc.out` there are important pieces of information, such as the list of Slater determinants dominating the FCI wave function and the RDM energy. The latter is passed to |molcas| as shown in the script below. -When a stationary condition is reached and density matrices sampled these are passed to the :file:`RASSCF` program to continue. +As accurate density matrices are necessary for a successful Stochastic-CASSCF +calculation, users are required to use the :file:`dneci.x` and :file:`mneci.x` +binaries (this will run the FCIQMC dynamic in replica mode) :cite:`Overy2014`. +The FCIQMC dymanics can be followed in the :file:`fciqmc.out` output file or in +the :program:`NECI` generated :file:`FCIMCStats` file. In the +:file:`fciqmc.out` file there are important pieces of information, such as the list +of Slater determinants dominating the FCI wave function and the RDM energy. The +latter is passed to |openmolcas| as shown in the script below. When a stationary +condition is reached and density matrices sampled these are passed to the +:file:`RASSCF` program to continue. This can be achieved by a simple script, such as the following: :: cp TwoRDM_aaaa.1 $WorkDir/$Project.TwoRDM_aaaa @@ -318,10 +324,42 @@ grep 'REDUCED D' fciqmc.out | sed "s/^.*: //" > NEWCYCLE mv NEWCYCLE $WorkDir/. +When performing state-averaging, the user has to ensure that the ordering of +all roots is consistent between |openmolcas| and :program:`NECI`. For instance, consider a +SA-CASSCF on a system admitting 2 doublets, 4 quartets, 3 sextets, 2 octets and +1 dectet. Using the :file:`FCIDUMP` provided by |openmolcas| (multiplicity in the |openmolcas| +input is disabled for these calculations, but should nevertheless be provided), +one can complete the :program:`NECI` dynamics, afterwards |openmolcas| will prompt for 12 +consecutively numbered density matrices and energies, i.e.: :: + + When finished do: + cp TwoRDM_* /$YOUR_WORKDIR/ + echo $your_RDM_Energy > /$YOUR_WORKDIR/NEWCYCLE + +A shell script which also takes care of renaming the RDMs might look +like this: :: + + export CALCBASE="location of your calculation" + export YOUR_WORKDIR="location of your scratch" + + cd $CALCBASE/neci-doublet/ # contains roots 1 and 2 + grep '*REDUCED' $YOUR_INPUT.out | awk '{ print $9 }' >> $CALCBASE/NEWCYCLE + + cd $CALCBASE/neci-quartet/ # contains roots 3 to 6 + grep '*REDUCED' mn3o4.out | awk '{ print $9 }' >> $CALCBASE/NEWCYCLE + # reverse order required, otherwise redundant rename + rename .4 .6 *.4; rename .3 .5 *.3 ; rename .2 .4 *.2; rename .1 .3 *.1 + + [for the other roots same procedure] + + cd $CALCBASE + cp neci-doublet/run$1/TwoRDM_* neci-quartet/run$1/TwoRDM_* [other roots] $YOUR_WORKDIR + cp NEWCYCLE $YOUR_WORKDIR + .. class:: filelist :file:`$Project.TwoRDM_XXXX` - These files are ASCII NECI generated output files. + These files are ASCII :program:`NECI` generated output files. They contain spin-resolved two-body density matrix elements (and one-RDM) and are necessary to |molcas| to continue with the Stochastic-CASSSCF calculation. @@ -338,7 +376,7 @@ :kword:`NECI` This keyword is needed to enable the Stochastic-CASSCF method. - Additional keywords like ``totalwalkers`` have the same meaning as in NECI + Additional keywords like ``totalwalkers`` have the same meaning as in :program:`NECI` and are just passed on. .. xmldoc:: @@ -452,8 +490,6 @@ REOR 3 4 5 1 - - leads to an order of [4 2 3 5 1 6]. @@ -462,49 +498,35 @@ Input Example ............. -A minimal input example follows where the use of the Stochastic-CASSCF joinlty with RICD and MC-PDFT is shown: :: +A minimal input example for using state-averaged Stochastic-CASSCF jointly with RICD MC-PDFT is shown below: :: &GATEWAY RICD - COORD - coor.xyz - BASIS - ANO-RCC-VTZP - GROUP - full + COORD = coor.xyz + BASIS = ANO-RCC-VTZP + GROUP = full &SEWARD &RASSCF - NECI - ExNe - NACTEL - 26 0 0 - INACTIVE - 20 17 17 14 0 0 0 0 - RAS2 - 0 0 0 0 7 6 6 5 - SYMMETRY - 1 + CIROOT = 2 2 1 * follows standard &RASSCF syntax + NECI = ExNe + NACTEL = 26 0 0 + INACTIVE = 20 17 17 14 0 0 0 0 + RAS2 = 0 0 0 0 7 6 6 5 + SYMMETRY = 1 >>foreach DFT in (T:PBE, T:BLYP, T:LSDA) - >>COPY $CurrDir/converged.RasOrb INPORB &RASSCF - LumOrb + FileOrb = $CurrDir/converged.RasOrb CIONLY - KSDFT - ROKS; $DFT - NECI - ExNe - NACTEL - 26 0 0 - INACTIVE - 20 17 17 14 0 0 0 0 - RAS2 - 0 0 0 0 7 6 6 5 - SYMMETRY - 1 + KSDFT = ROKS; $DFT + NECI = ExNe + NACTEL = 26 0 0 + INACTIVE = 20 17 17 14 0 0 0 0 + RAS2 = 0 0 0 0 7 6 6 5 + SYMMETRY = 1 >>enddo .. _UG\:sec\:gasscf: @@ -918,6 +940,82 @@ +:kword:`MCM7` + Read HDF5 RDMs from M7 in the stochastic-CASSCF interface. For technical + reasons, the RDM formatting between NECI and M7 is different. This keyword + will become mandatory for the stochastic-CASPT2 interface. Currently, M7 + only supports single root calculations. + + .. xmldoc:: + %%Keyword: MCM7 + + This keyword must be used when a RDM from M7 is read. + + + +:kword:`H5DM` + Read HDF5 RDMs instead of ASCII from NECI or M7 in the + stochastic-CASSCF interface. This keyword will become mandatory + for the stochastic-CASPT2 interface. + + .. xmldoc:: + %%Keyword: H5DM + + Read HDF5 RDMs instead of ASCII from NECI or M7 in the + stochastic-CASSCF interface. + + + +:kword:`SSCR` + Computes the orbital resolved spin--spin correlation function between at most + two different ranges of orbitals. For physically meaningful results prior + localisation (Pipek--Mezey recommended) and sorting by atomic sites is + required. The latter step is not performed by the :program:`Localisation` module and + requires manual relabelling within the :file:`LocOrb` file. + + At least one integer is required, specifying the length of the orbital + vectors, whereas an optional second integer determines whether the vectors are + the same (``1``) or different (any other number or no argument). In the latter + case, both orbital vectors must be specified in the following two lines. + + Consider a triangle with sites A B C, each with three unpaired electrons, + corresponding to a CAS(9,9). Below, a few practical examples are given: :: + + * Spin correlation from orbital 1 to 6 + SSCR = 6 1 + * or + SSCR = 6 + 1 2 3 4 5 6 + 1 2 3 4 5 6 + * Spin correlation between sites A (1-3) and C (7-9) + SSCR = 3 + 1 2 3 + 7 8 9 + * or + SSCR = 3 + 1 2 3 + 7 8 9 + + Notice that the numbering is consecutive and each entry in an orbital range + has to be unique. + + .. xmldoc:: + + %%Keyword: SSCR + + Calculate the pairwise orbital resolved spin-spin correlation + function, for instance between two magnetically coupled centers, + after localisation and site-ordering of the corresponding + orbitals. Please consult the manual for further guidance. The + keyword uses a modified syntax already known from CIROots. At + least one input is required, specifying the length of the orbital + vectors, whereas an optional second input determines whether the + vectors are the same (1) or different (any other number or no + argument). In the latter case, both orbital vectors must be + specified in the following two lines. + + + :kword:`CISElect` This keyword is used to select CI roots by an overlap criterion. The input consists of three lines per root @@ -1668,6 +1766,22 @@ +:kword:`PERI` + Write the orbital file per iteration. + The obtained files are named `${Project}.IterOrb.${iter_number}` + and if HDF5 is available `${Project}.rasscf.${iter_number}.h5`. + Note that up until the last iteration all states in a state-averaged calculation + are in the same orbital basis. + + .. xmldoc:: + %%Keyword: PERI + + Write the orbital file per iteration. + The obtained files are named `${Project}.IterOrb.${iter_number}` + and if HDF5 is available `${Project}.rasscf.${iter_number}.h5`. + + + :kword:`LEVShft` Define a level shift value for the super-CI Hamiltonian. Typical values are in the range 0.0--1.5. Increase this value if a calculation diverges. The default value 0.5, @@ -2047,7 +2161,7 @@ sets with occupation numbers 0 (zero). The main use of these orbitals is to act as input to property calculations and for graphical presentations. - This keyword is on by default for up to ten roots. + This keyword is on by default for all roots. An example input follows in which five files are requested containing natural orbitals for roots one to five of a RASSCF calculation. @@ -2249,8 +2363,38 @@ +:kword:`CMSStart` + This keyword gives the file that stores the starting rotation matrix for finding the CMS intermediate states (see :kword:`CMSInter`). The file has the same format as :file:`Do_Rotate.txt`. The default is to use the XMS intermediate states (see :kword:`XMSInter`). + + .. xmldoc:: + %%Keyword: CMSS + + This keyword specifies file that provides the starting rotation matrix for CMS intermediate states. + + + +:kword:`CMSOpt` + This keyword defines the maximization algorithm to find the CMS intermediate states (see :kword:`CMSInter`). The allowed values are: + + * **Newton:** Newton's method. The Hessian and the gradient of the sum-over-states + of the active--active classical Coulomb energies (Q_a-a) are computed. This is the + default for calculations with more than two states. Note that Q_a-a may decrease within + the minimum number of cycles defined by `CMMI` if a step is too big. After the minimum + number of cycles, a smaller step will be taken to ensure that Q_a-a increases, and an + extra cycle will always be taken if a smaller step is used. + * **Jacobi:** Jacobi's method. States are rotated in pairwise succession, + and a trigonometric function is used to fit such rotation to find the + maximum. This is the default for calculations with two states. + + .. xmldoc:: + %%Keyword: CMSO + + This keyword specifies the maximization algorithm to find the CMS intermediate states. + + + :kword:`CMMAx` - This keyword defines the maximum number of cycles to find the CMS intermediate states (see :kword:`CMSInter`). The default value is 100. + This keyword defines the maximum number of cycles to find the CMS intermediate states (see :kword:`CMSInter`). The default value is 100. .. xmldoc:: %%Keyword: CMMA @@ -2260,7 +2404,7 @@ :kword:`CMMIn` - This keyword defines the minimum number of cycles to find the CMS intermediate states (see :kword:`CMSInter`). The default value is 5. + This keyword defines the minimum number of cycles to find the CMS intermediate states (see :kword:`CMSInter`). The default value is 5. .. xmldoc:: %%Keyword: CMMI @@ -2270,9 +2414,9 @@ :kword:`CMTHreshold` - This keyword defines the threshold for the change in the sum over states of the classical Coulomb energy for CMS intermediate states to converge (see :kword:`CMSInter`). The default value is 1.0d-6. + This keyword defines the threshold for the change in the sum over states of the classical Coulomb energy for CMS intermediate states to converge (see :kword:`CMSInter`). The default value is 1.0d-8. - .. xmldoc:: + .. xmldoc:: %%Keyword: CMTH This keyword specifies the threshold for the change of sum over states of the classical Coulomb energy for CMS intermediate states to converge. @@ -2486,6 +2630,84 @@ For calculations of a molecule in a reaction field see :numref:`UG:sec:rfield` of the present manual and :numref:`TUT:sec:cavity` of the examples manual. +HCI-CASSCF keywords +................... + +.. warning:: + + An external package (DICE) is required to run HCI-CASSCF + +.. class:: keywordlist + +:kword:`DICE` + Use this keyword to activate Heat-Bath Configuration Interaction (HCI)-CASSCF, calculated with the Dice--|molcas| interface. + The perturbative component will be calculated deterministically. + + .. xmldoc:: + %%Keyword: DICE + + Use this keyword to activate HCI-CASSCF. + + + +:kword:`EPSIlons` + Array of two thresholds. :math:`\epsilon_1`: the threshold for adding determinants to the Fock space during the variational calculation; and + :math:`\epsilon_2`: the threshold for the second-order perturbative energy correction to the variational energy. :math:`\epsilon_2 < \epsilon_1`. + Lower thresholds will give lower HCI energy, but increase the computational cost. + Default values are: 1.0d-4, 1.0d-5. + + .. xmldoc:: + %%Keyword: EPSIlons + + Thresholds in the variational and pertubational steps. + + (Default: 1.0d-4 1.0d-5) + + +:kword:`DITErations` + Maximum number of iterations in the variational step. + Default value is: 20. + + .. xmldoc:: + %%Keyword: DITErations + + Maximum number of iterations in the variational step (DICE). + + (Default: 20) + + +:kword:`DIREstart` + Use this keyword to activate restart in the first HCI iteration from a previous calculation. + + .. xmldoc:: + %%Keyword: DIREstart + + Use this keyword to activate restart in the first HCI iteration from a previous calculation. + + + +:kword:`DIOCcupy` + Initial electronic configuration for the HCI-CASSCF calculations. This keyword is required. + The keyword requires first the number of configurations :math:`n`, followed by :math:`n` configuration. + Each configuration is inserted as a string of aliases of occupations/couplings of the active (RAS2) orbitals with the aliases ``2`` = full, ``u`` = up, ``d`` = down, ``0`` = empty. + + :: + + DIOCcupy + 3 + u u 2 0 2 0 + 2 0 u u 2 0 + 2 u d 0 u u + + In this CAS(6,6) example, three initial configurations will be read. The first configuration is :math:`\ket{\mathord{\uparrow\uparrow}2020}`. + + .. xmldoc:: + %%Keyword: DIOCcupy + + Set HF determinant start guess for HCI wave functions (DICE). + + + Input example ............. @@ -2531,7 +2753,7 @@ More advanced examples can be found in the tutorial section of the manual. -Input example for DMRG-CASSCF with Molcas-CheMPS2 interface: :: +Input example for DMRG-CASSCF with CheMPS2--|molcas| interface: :: &RASSCF Title= Water molecule. Active orbitals OH and OH* in both symmetries @@ -2542,6 +2764,22 @@ DMRG = 500 3RDM +Input example for HCI-CASSCF with Dice--|molcas| interface: :: + + &RASSCF + Title= Water molecule. Active orbitals OH and OH* in both symmetries + Spin = 1 + Symmetry = 1 + Inactive = 2 0 1 0 + Ras2 = 2 2 0 0 + THRS = 1.0e-07 1.0e-03 1.0e-03 + DICE + EPSIlons = 1.0d-4 1.0d-5 + DITErations = 30 + DIOCuppy + 1 + 2 0 2 0 + .. xmldoc:: .. xmldoc:: diff -Nru openmolcas-22.02/doc/source/users.guide/programs/scf.rst openmolcas-22.10/doc/source/users.guide/programs/scf.rst --- openmolcas-22.02/doc/source/users.guide/programs/scf.rst 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/users.guide/programs/scf.rst 2022-10-10 14:22:40.000000000 +0000 @@ -327,24 +327,36 @@ :kword:`KSDFT` Use this keyword to do density functional theory calculations. - This keyword should be followed by functional keyword: - BLYP, BPBE, B2PLYP_SCF, B3LYP, B3LYP5, B86LYP, B86PBE, GLYP, GPBE, HFB, - HFS, KT2, KT3, LDA, LDA5, LSDA, LSDA5, M06, M06HF, M062X, M06L, OLYP, OPBE, - O2PLYP_SCF, O3LYP, PBE, PBESOL, PBE0, PTCA, RGE2, SSBSW, SVWN, SVWN5, TLYP, SSBD, - BR89B94h. - Example: `KSDFT=B3LYP` + This keyword should be followed by a functional keyword. + Use :command:`pymolcas help_func` to see a list of available functionals, + you can also specify a `Libxc `_ functional name, or a number :math:`N` followed + by :math:`N` lines, each of them containing a weight factor and a Libxc + functional name (or ``HF_X`` for exact exchange). + Examples (all three should be equivalent): :: - .. xmldoc:: + KSDFT=B3LYP * A functional keyword + + :: + + KSDFT=HYB_GGA_XC_B3LYP * A Libxc functional name + + :: + + KSDFT=5 * Five components with their weights + 0.20 HF_X * Keyword for exact exchange + 0.08 XC_LDA_X * Libxc functional names + 0.72 XC_GGA_X_B88 * . + 0.19 XC_LDA_C_VWN_RPA * . + 0.81 XC_GGA_C_LYP * . + + .. xmldoc:: + %%Keyword: KSDFT Use this keyword to do density functional theory calculations - This keyword should be followed by the functional keyword: - BLYP, BPBE, B2PLYP_SCF, B3LYP, B3LYP5, B86LYP, B86PBE, GLYP, GPBE, HFB, - HFS, KT2, KT3, LDA, LDA5, LSDA, LSDA5, M06, M06HF, M062X, M06L, OLYP, OPBE, - O2PLYP_SCF, O3LYP, PBE, PBESOL, PBE0, PTCA, RGE2, SSBSW, SVWN, SVWN5, TLYP, SSBD, - BR89B94h. - Example: KSDFT=B3LYP + This keyword should be followed by a functional keyword , a Libxc functional + name, or a functional specification. See "pymolcas help_func" for + available functionals keywords. diff -Nru openmolcas-22.02/doc/source/users.guide/programs/seward.rst openmolcas-22.10/doc/source/users.guide/programs/seward.rst --- openmolcas-22.02/doc/source/users.guide/programs/seward.rst 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/users.guide/programs/seward.rst 2022-10-10 14:22:40.000000000 +0000 @@ -1322,13 +1322,13 @@ -:kword:`NOPRunning` - It turns off the the angular prunning. Default is to prune. +:kword:`NOPRuning` + It turns off the the angular pruning. Default is to prune. - .. xmldoc:: - %%Keyword: Noprunning (NQ) + .. xmldoc:: + %%Keyword: Nopruning (NQ) - It turns off the the angular prunning. Default is to prune. + It turns off the the angular pruning. Default is to prune. diff -Nru openmolcas-22.02/doc/source/users.guide/programs/single_aniso.rst openmolcas-22.10/doc/source/users.guide/programs/single_aniso.rst --- openmolcas-22.02/doc/source/users.guide/programs/single_aniso.rst 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/users.guide/programs/single_aniso.rst 2022-10-10 14:22:40.000000000 +0000 @@ -671,7 +671,7 @@ values, namely :math:`a`, :math:`b`, :math:`c`, :math:`\alpha`, :math:`\beta`, and :math:`\gamma`, defining the crystal lattice. On the second line, the program will read the Cartesian coordinates of the magnetic center. The computed values in the output correspond to the - crystallographic position of three "dummy atoms" located on the corresponding anisotropy axes, at the distance of 1 ångstrom from the metal site. :: + crystallographic position of three "dummy atoms" located on the corresponding anisotropy axes, at the distance of 1 ångström from the metal site. :: ABCC 20.17 19.83 18.76 90 120.32 90 diff -Nru openmolcas-22.02/doc/source/users.guide/programs/surfacehop.rst openmolcas-22.10/doc/source/users.guide/programs/surfacehop.rst --- openmolcas-22.02/doc/source/users.guide/programs/surfacehop.rst 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/users.guide/programs/surfacehop.rst 2022-10-10 14:22:40.000000000 +0000 @@ -20,7 +20,11 @@ Its purpose is the calculation of the relax root for the next step of the SHMD. -This module deals with surface hop semiclassical molecular dynamics (SHMD) and has to be used together with module DYNAMIX. Its purpose is the calculation of the relax root for the next step of the SHMD. In this moment the implemented algorithm under this module is the Tully's fewest switches :cite:`Tully1990`, along with the Hammes-Schiffer/Tully scheme :cite:`Hammes-Schiffer1994` and the decoherence correction proposed by Granucci and Persico :cite:`Granucci2007`. +This module deals with surface hop semiclassical molecular dynamics (SHMD) and has to be used together with module DYNAMIX. Its purpose is the calculation of the relax root for the next step of the SHMD. The implemented algorithm under this module is the Tully's fewest switches :cite:`Tully1990`, using the Hammes-Schiffer/Tully scheme :cite:`Hammes-Schiffer1994` and the decoherence correction proposed by Granucci and Persico :cite:`Granucci2007`. + +Under the Hammes-Schiffer/Tully scheme, the non-adiabatic population transfer between states of the same multiplicity is determined using the wavefunction overlap between the current timestep and the two previous timesteps, in an interpolation-extrapolation scheme. This is done in lieu of calculating explicitly the non-adiabatic coupling, and thus allows for surface-hopping when explicit non-adiabatic coupling is not available or is too expensive. + +There are two methods to calculate the wavefunction overlap available through the :program:`SURFACEHOP` module. The default implementation calls the :program:`RASSI` module to obtain the overlap matrix between all states at the current and previous timestep. The alternative method (previously default) can be requested using the keyword :kword:`NORASSI` and uses instead a dot product of the CI vectors to approximate the overlap matrix. .. _UG\:sec\:surfacehop_output_files: @@ -32,6 +36,12 @@ :file:`RUNFILE` Surface hop information such as Amatrix and CI coefficients for previous steps are stored in this file. +:file:`$Project.md.xyz` + Contains the geometry of every timestep in the dynamics, in standard xyz coordinates. + +:file:`$Project.md.energies` + Contains the Potential energy of the current active state, Kinetic energy, and Total energy of the system throughout the simulation, followed by the potential energies of all states in the dynamics. + .. _UG\:sec\:surfacehop_inp: Input @@ -88,8 +98,19 @@ +:kword:`NORASSI` + This keyword must be used after the :kword:`TULLY` keyword. It disables the use of :program:`RASSI` to calculate wavefunction overlaps, instead using the dot product of CI vectors (previous default option). + + .. xmldoc:: + %%Keyword: NORAssi + This keyword must be used after the TULLY keyword. + + It disables the use of RASSI to calculate wavefunction overlaps. + + + :kword:`DECOHERENCE` - This keyword must be used after the :kword:`TULLY` keyword. It enables the decoherence correction in the population density matrix as reported by Persico--Granucci. The value is called decay factor and it is usually 0.1 hartree. It can be seen as how strongly this correction is applied. It is recommendable to leave it to 0.1, unless you really know what your're doing. + This keyword must be used after the :kword:`TULLY` keyword. It enables the decoherence correction in the population density matrix as reported by Persico and Granucci. The value is called decay factor and it is usually 0.1 hartree. It can be seen as how strongly this correction is applied. It is recommendable to leave it to 0.1, unless you really know what you're doing. .. xmldoc:: %%Keyword: DECOherence diff -Nru openmolcas-22.02/doc/source/users.guide/programs/wfa.rst openmolcas-22.10/doc/source/users.guide/programs/wfa.rst --- openmolcas-22.02/doc/source/users.guide/programs/wfa.rst 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/users.guide/programs/wfa.rst 2022-10-10 14:22:40.000000000 +0000 @@ -43,7 +43,7 @@ A decomposition into local and charge transfer contributions on different chromophores is possible through the charge transfer number analysis :cite:`Plasser2012`, which has been integrated into |molcas| recently. -Postprocessing is possible through the external `TheoDORE `_ :cite:`TheoDORE` program. +Postprocessing is possible through the external `TheoDORE `_ :cite:`TheoDORE` program. Installation ------------ @@ -146,7 +146,7 @@ :kword:`CTNUmmode` - Specifies what properties are computed in a `TheoDORE `_-style fragment-based analysis (0-3, default: 1). + Specifies what properties are computed in a `TheoDORE `_-style fragment-based analysis (0-3, default: 1). This requires defining fragments via :kword:`ATLIsts`. 0 --- none @@ -169,7 +169,7 @@ :kword:`ATLIsts` - Define the fragments in a `TheoDORE `_-style analysis. + Define the fragments in a `TheoDORE `_-style analysis. The first entry is the number of fragments. Then enter the atomic indices of the fragment followed by a \*. @@ -262,7 +262,7 @@ :kword:`PROPlist` - Manual input of properties to be printed out in a `TheoDORE `_-style fragment based analysis. + Manual input of properties to be printed out in a `TheoDORE `_-style fragment based analysis. Use only if :kword:`CTNUMMODE` does not provide what you want. .. xmldoc:: diff -Nru openmolcas-22.02/doc/source/users.guide/tools.rst openmolcas-22.10/doc/source/users.guide/tools.rst --- openmolcas-22.02/doc/source/users.guide/tools.rst 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/doc/source/users.guide/tools.rst 2022-10-10 14:22:40.000000000 +0000 @@ -2,7 +2,7 @@ === The manual for graphical viewer :program:`GV`, and :program:`LUSCUS` can be found -online: http://www.molcas.org/GV/, http://luscus.sourceforge.net/. +online: https://www.molcas.org/GV/, http://luscus.sourceforge.net/. .. .. include:: gv.inc diff -Nru openmolcas-22.02/.gitlab-ci_configs.yml openmolcas-22.10/.gitlab-ci_configs.yml --- openmolcas-22.02/.gitlab-ci_configs.yml 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/.gitlab-ci_configs.yml 2022-10-10 14:22:40.000000000 +0000 @@ -1,6 +1,6 @@ # Define some configuration groups (variables, tags, etc.) to be used in jobs # - plain: default configuration -# - options: enable several options +# - options: enable several extra options # - linalg: use a link-time linalg library and ninja # - pgi: use PGI compilers # - sun: use Oracle compilers @@ -8,9 +8,9 @@ # - intel13: use Intel 2013 compilers (build on specific runner) # - nag: use NAG Fortran compiler and Garble (build on specific runner) # - garble: setup with Garble option and gcc compilers -# - bounds: enable bounds checking (slow) +# - bounds: enable interprocedural optimization and bounds checking (slow) # - debug: build with no optimization (no tests) -# - qcmaquis: default build with QCMaquis and NEVPT2 support (only qcmaquis tests) +# - qcmaquis: default build with QCMaquis and NEVPT2 support # - mpi: build with Global Arrays, OpenMPI, OpenBLAS .plain: @@ -154,18 +154,18 @@ set (Libxc_EXTRA_CMakeArgs "-DENABLE_XHOST=OFF;-DENABLE_GENERIC=ON" CACHE STRING "extra Libxc args") # more portable Libxc build # -w=obs : disable fixed source form, statement function # -w=x77 : disable real*8 - set (EXTRA_FFLAGS "-w=obs -w=x77 -unsharedrts" CACHE STRING "extra Fortran flags") + set (EXTRA_FFLAGS "-quiet -w=obs -w=x77 -unsharedrts" CACHE STRING "extra Fortran flags") pre_compile_script: | rm -rf ${install_path} pre_make_script: | mkdir -p ${install_path} $${make} 2>&1 | tee nag.log - # Remove CMake and NAG version lines - sed -E '/^Scanning dependencies of target [^ ]*/d ; /^\[ *[0-9]+*%\].*/d ; /^\[?NAG Fortran Compiler.*/d' nag.log > nag2.log ; mv nag2.log nag.log + # Remove CMake lines + sed -E '/^Scanning dependencies of target [^ ]*/d ; /^\[ *[0-9]+*%\].*/d' nag.log > nag2.log ; mv nag2.log nag.log # Wrap lines that start with a space sed -E ':a ; $!N ; s/\n\s+/ / ; ta ; P ; D' nag.log > nag2.log ; mv nag2.log nag.log # Filter only NAG message lines - sed -n -E '/^(Info|Warning|Questionable|Note|Extension|Obsolescent|Deleted feature used|Error):.*/p' nag.log > nag2.log ; mv nag2.log nag.log + sed -n -E '/^(Info|Warning|Questionable|Note|Extension(\(NAG\))?|Obsolescent|Deleted feature used|Error):.*/p' nag.log > nag2.log ; mv nag2.log nag.log # Remove ignored warnings sed -E '/(was not compiled with the -i8 option)/d' nag.log > nag2.log ; mv nag2.log nag.log # More reasonable paths diff -Nru openmolcas-22.02/.gitlab-ci.yml openmolcas-22.10/.gitlab-ci.yml --- openmolcas-22.02/.gitlab-ci.yml 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/.gitlab-ci.yml 2022-10-10 14:22:40.000000000 +0000 @@ -50,6 +50,9 @@ .template: &test-jobs rules: + # manual on drafts + - if: '$CI_MERGE_REQUEST_TITLE =~ /^(\[Draft\]|\(Draft\)|Draft:)/' + when: manual # merge requests - if: '$CI_MERGE_REQUEST_IID' when: on_success @@ -219,6 +222,7 @@ echo "Creating release $TAG" release: tag_name: ${TAG} + tag_message: "verified commit" description: "Automatic release from latest master" ref: $CI_COMMIT_SHA rules: @@ -406,7 +410,7 @@ <<: *run-tests needs: - build:nag - parallel: 6 + parallel: 4 tags: - docker @@ -419,7 +423,7 @@ needs: - build:garble - tinker - parallel: 6 + parallel: 4 build:bounds: extends: .bounds diff -Nru openmolcas-22.02/README.md openmolcas-22.10/README.md --- openmolcas-22.02/README.md 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/README.md 2022-10-10 14:22:40.000000000 +0000 @@ -92,7 +92,7 @@ OpenMolcas is a community-supported software and as such it doesn't have an official technical support. If you have any problems or questions, you can use the [Issues](/../issues) page or the [Molcas -forum](https://cobalt.itc.univie.ac.at/molcasforum/index.php), and hopefully +forum](https://molcasforum.univie.ac.at), and hopefully some other user or developer will be able to help you. If you need technical support, you can acquire a [Molcas @@ -105,7 +105,7 @@ freely (according to the terms of the LGPL). If you would like your contributions to be included in the main repository, please contact one of the developers, write a message in the -[forum](https://cobalt.itc.univie.ac.at/molcasforum/index.php) or submit a +[forum](https://molcasforum.univie.ac.at) or submit a [merge request](https://docs.gitlab.com/ee/user/project/merge_requests/getting_started.html). Everyone is welcome to send patches, suggestions and bug reports, but please diff -Nru openmolcas-22.02/sbin/have_feature openmolcas-22.10/sbin/have_feature --- openmolcas-22.02/sbin/have_feature 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/sbin/have_feature 2022-10-10 14:22:40.000000000 +0000 @@ -159,6 +159,22 @@ Echo ;; + "dice") + Echo "Processing feature: $FEATURE" + DICE=`which Dice` + if [ -n "$DICE" ] ; then + Echo "Found: $DICE" + if ! find_symbol dicectl rasscf ; then + Echo "Not compiled!" + RC=1 + fi + else + Echo "Not found!" + RC=1 + fi + Echo + ;; + "molcas-extra") Echo "Processing feature: $FEATURE" if ! find_symbol mystring gateway ; then diff -Nru openmolcas-22.02/sbin/verify openmolcas-22.10/sbin/verify --- openmolcas-22.02/sbin/verify 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/sbin/verify 2022-10-10 14:22:40.000000000 +0000 @@ -695,14 +695,14 @@ pattern_list = [] if opt['module']: for mod in opt['module'].split(','): - pattern_list.append('&' + mod) + pattern_list.append('&' + mod + r'\b') if opt['word']: for key in opt['word'].split(','): pattern_list.append(key) if opt['grep']: for key in opt['grep'].split(','): - pattern_list.append('[^*]*' + key) - filter_pattern = '^\s*(' + '|'.join(pattern_list) + ')' + pattern_list.append(r'[^*]*' + key) + filter_pattern = r'^\s*(' + '|'.join(pattern_list) + ')' filtered_filelist = [] for filename in filelist: with open(filename, 'rb') as f: diff -Nru openmolcas-22.02/src/' openmolcas-22.10/src/' --- openmolcas-22.02/src/' 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/' 1970-01-01 00:00:00.000000000 +0000 @@ -1,337 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -! * -! Copyright (C) 1987, Bjorn O. Roos * -!*********************************************************************** -!--------------------------------------------* -! 1987 B. O. ROOS * -! DEPARTMENT OF THEORETICAL CHEMISTRY * -! UNIVERSITY OF LUND, SWEDEN * -!--------------------------------------------* - -subroutine tr2NsA2(CMO,X1,nX1,X2,nX2,pqrU,npqrU,pqTU,npqTU) -! SECOND ORDER TWO-ELECTRON TRANSFORMATION ROUTINE -! -! THIS ROUTINE IS CALLED FOR EACH SYMMETRY BLOCK OF INTEGRALS -! (ISP,ISQ,ISR,ISS) WITH ISP >= ISQ AND ISR >= ISS. -! P,Q,R,S are SO indices. -! A,B are MO indices, counting only non-frozen and non-deleted. -! T,U are occupied MO indices, only non-frozen and non-deleted. -! INTEGRALS (AB/TU) ARE ALWAYS GENERATED -! EXCHANGE INTEGRALS (AT/BU) ARE GENERATED AS FOLLOWS: -! (AT/BU) IF ISP >= ISR -! (AT/UB) IF ISP > ISS AND ISP /= ISQ -! (TA/BU) IF ISQ > ISR AND ISP /= ISQ -! (TA/UB) IF ISQ >= ISS AND ISP /= ISQ -! -! This and tr2NsB routines transform non-squared AO integrals. The -! transformed MO integrals are stored as the same as Tr2Sq -! subroutine does. - -use Constants, only: Zero, One -use Definitions, only: wp, iwp - -implicit none -#include "rasdim.fh" -#include "caspt2.fh" -integer(kind=iwp), intent(in) :: nX1, nX2, npqrU, npqTU -real(kind=wp), intent(in) :: CMO(NCMO) -real(kind=wp), intent(out) :: X1(nX1), X2(nX2) -real(kind=wp), intent(inout) :: pqrU(npqrU), pqTU(npqTU) -integer(kind=iwp) :: IAD2S, IAD3, IAD3S, icc, icxc1, icxc5, IPQMX2, IPQMX3, IPQST, IPQTU, IR, IRU, ISPQRS, IST, ITU, IX2, KKTU, & - LAR, LR, NA, NAT, NORU, NOTU, NR, NSYMP, NT, NTM, NTMAX, NU, Num, NUMAX -#include "trafo.fh" -#include "intgrl.fh" - -NSYMP = NSYM*(NSYM+1)/2 -NOTU = NOCR*NOCS -if (ISR == ISS) NOTU = (NOCR**2+NOCR)/2 -NORU = NBR*NOCS -icc = NOP*NOQ*NOCR*NOCS -icxc1 = NOP*NOCQ*NOR*NOCS -icxc5 = NOCP*NOQ*NOR*NOCS - -! Check for in core or out of core transformation - -! 2. SORT OF PARTIALLY TRANSFORMED INTEGRALS (PQ|RU) ON UNIT LUHLF2 -IPQMX2 = NBPQ -if (NBPQ*NORU > LRUPQ) then - IPQMX2 = LRUPQ/NORU - !write(u6,*) 'OUT OF CORE SORT FOR INTEGRALS (PQ|RU)',IPQMX2 - IAD2S = 0 - call dDAFILE(LUHLF2,0,PQRU,IPQMX2,IAD2S) -end if -!4x 3. SORT OF PARTIALLY TRANSFORMED INTEGRALS (PQ|TU) ON UNIT LUHLF3 -IPQMX3 = NBPQ -if (NBPQ*NOTU > LTUPQ) then - IPQMX3 = LTUPQ/NOTU - !write(u6,*) 'OUT OF CORE SORT FOR INTEGRALS (PQ|TU)',IPQMX3 - IAD3S = 0 - call dDAFILE(LUHLF3,0,PQTU,IPQMX3,IAD3S) -end if -IAD3 = 0 - -!==================================================== -! Second half transformation -!==================================================== -!------------------------------------------- -! Second half transformation (AB,TU) coulomb -! Always calculated. -!------------------------------------------- -! Loop over t,u pair, -if (icc /= 0) then - ISPQRS = ((ISR**2-ISR)/2+ISS-1)*NSYMP+(ISP**2-ISP)/2+ISQ - IAD2M(1,ISPQRS) = IAD13 - IPQTU = 0 - ITU = 0 - do NT=1,NOCR - Num = NOCS - if (ISR == ISS) Num = NT - do NU=1,Num - IPQTU = 1+NBPQ*ITU - ITU = ITU+1 - ! Read sorted integral from disk - if (IPQMX3 < NBPQ) then - call RBuf_tra2(LUHLF3,PQTU,NBPQ,IPQMX3,NOTU,ITU,IPQTU,IAD3S) - end if - if (ISP == ISQ) then - ! Square if necessary - call SQUARE(PQTU(IPQTU),X2,1,NBP,NBP) - ! (pq,TU) -> (Aq,TU) - call DGEMM_('N','N',NBQ,NOP,NBP,One,X2,NBQ,CMO(LMOP),NBP,Zero,X1,NBQ) - ! (Aq,TU) -> (AB,TU) -! call MXMT(X1,NBQ,1,CMO(LMOQ),1,NBQ,X2,NOP,NBQ) - Call DGEMM_Tri('T','N',NOP,NOP,NBQ,One,X1,NBQ,CMO(LMOQ),NBQ,Zero,X2,NOP) - IX2 = (NOP+NOP**2)/2 - else - ! (pq,TU) -> (Aq,TU) - call DGEMM_('N','N',NBQ,NOP,NBP,One,PQTU(IPQTU),NBQ,CMO(LMOP),NBP,Zero,X1,NBQ) - ! (Aq,TU) -> (AB,TU) - call DGEMM_('T','N',NOQ,NOP,NBQ,One,CMO(LMOQ),NBQ,X1,NBQ,Zero,X2,NOQ) - IX2 = NOP*NOQ - end if - ! Store (AB,TU) of this t,u pair - call GADSum(X2,IX2) - call dDAFILE(LUINTM,1,X2,IX2,IAD13) - end do - end do - ! End of loop over t,u pair -end if -!----------------------------------------------------------------------- -! Second half transformation Case 1 (AT,BU) -! Always calculated. Both type 1 and 2. Case 2 (BU,AT) can be abandoned -! since always ISP > ISR(equality can be removed by symmetry) -!----------------------------------------------------------------------- -! Loop over r,u pair -NOTU = NOCQ*NOCS -if (ISQ == ISS) NOTU = (NOCQ**2+NOCQ)/2 -if (icxc1 /= 0) then - LAR = LTUPQ/NOTU - LR = LAR/NOP - if (LR > NBR) LR = NBR - LAR = NOP*LR - IAD3S = 0 - call dDAFILE(LUHLF3,0,PQTU,LAR,IAD3S) - IAD3 = 0 - IR = 0 - do NR=1,NBR - IR = IR+1 - do NU=1,NOCS - ! Square if necessary - IRU = NBR*(NU-1)+NR - IPQST = 1+NBPQ*(IRU-1) - if (IPQMX2 < NBPQ) then - call RBuf_tra2(LUHLF2,PQRU,NBPQ,IPQMX2,NORU,IRU,IPQST,IAD2S) - end if - if (ISP == ISQ) then - call Square(PQRU(IPQST),X2,1,NBP,NBP) - else - call dcopy_(NBPQ,PQRU(IPQST),1,X2,1) - end if - ! if (ISQ == ISS) then triangular - if (ISQ == ISS) then - ! (pq,rU) -> (pT,rU) - call DGEMM_('T','N',NBP,NOCQ-NU+1,NBQ,One,X2,NBQ,CMO(LMOQ2+NBQ*(NU-1)),NBQ,Zero,X1,NBP) - ! (pT,rU) -> (AT,rU) - call DGEMM_('T','N',NOCQ-NU+1,NOP,NBP,One,X1,NBP,CMO(LMOP2),NBP,Zero,X2,NOCQ-NU+1) - else - ! (pq,rU) -> (pT,rU) - call DGEMM_('T','N',NBP,NOCQ,NBQ,One,X2,NBQ,CMO(LMOQ2),NBQ,Zero,X1,NBP) - ! (pT,rU) -> (AT,rU) - call DGEMM_('T','N',NOCQ,NOP,NBP,One,X1,NBP,CMO(LMOP),NBP,Zero,X2,NOCQ) - end if - ! Store buffer - if (IR > LR) then - IR = 1 - !vv do I=1,NOTU - !vv call dDAFILE(LUHLF3,1,PQTU(1+LAR*(I-1)),LAR,IAD3) - !vv end do - call dDAFILE(LUHLF3,1,PQTU,LAR*NOTU,IAD3) - end if - ! Sort - NAT = 0 - do NA=1,NOP - NTM = 1 - if (ISQ == ISS) NTM = NU - do NT=NTM,NOCQ - ITU = NOCS*(NT-1)+NU-1 - if (ISQ < ISS) ITU = NOCQ*(NU-1)+NT-1 - if (ISQ == ISS) ITU = (NT**2-NT)/2+NU-1 - NAT = NAT+1 - PQTU(LAR*ITU+NOP*(IR-1)+NA) = X2(NAT) - !if ((isp == 7) .and. (isq == 1) .and. (isr == 6)) write(u6,'(f13.6)') pqtu(1) - end do - end do - ! End of loop over r,u pair - end do - end do - ! Store last buffer - if (LR < NBR) then - !vv do I=1,NOTU - !vv call dDAFILE(LUHLF3,1,PQTU(1+LAR*(I-1)),LAR,IAD3) - !vv end do - call dDAFILE(LUHLF3,1,PQTU,LAR*NOTU,IAD3) - end if - ! Transform fourth index - if (ISQ >= ISS) then - ! Exchange type 1 - ISPQRS = ((ISQ**2-ISQ)/2+ISS-1)*NSYMP+(ISP**2-ISP)/2+ISR - IAD2M(2,ISPQRS) = IAD13 - NTMAX = NOCQ - NUMAX = NOCS - else - ! Exchange type 2 - ISPQRS = ((ISS**2-ISS)/2+ISQ-1)*NSYMP+(ISP**2-ISP)/2+ISR - IAD2M(3,ISPQRS) = IAD13 - NTMAX = NOCS - NUMAX = NOCQ - end if - ! Loop over t,u pair, If (ISQ == ISS) loop should be triangle - IST = 1-NOP*NBR - KKTU = 0 - do NT=1,NTMAX - NUM = NUMAX - if (ISQ == ISS) NUM = NT - do NU=1,NUM - IST = IST+NOP*NBR - KKTU = KKTU+1 - if (LR < NBR) then - call RBuf_tra2(LUHLF3,PQTU,NBR*NOP,LAR,NOTU,KKTU,IST,IAD3S) - end if - ! (AT,rU) -> (AT,BU) - call DGEMM_('T','T',NOR,NOP,NBR,One,CMO(LMOR2),NBR,PQTU(IST),NOP,Zero,X2,NOR) - - ! WRITE THESE BLOCK OF INTEGRALS ON LUINTM - - call GADSum(X2,NOP*NOR) - call dDAFILE(LUINTM,1,X2,NOP*NOR,IAD13) - end do - end do - ! End of loop over t,u pair -end if -!----------------------------------------------------------------------- -! Case 5 (TA,BU) and 6 (UB,AT) -! Calculated if (ISP /= ISQ) .or. ((ISQ < ISR) .and. (ISP == ISR)) -! If ISQ >= ISR then Case 5, which alwats gives type 1 integrals -! If (ISQ < ISR) .and. (ISP /= ISR) -! then Case 6, which alwats gives type 2 integrals -!----------------------------------------------------------------------- -NOTU = NOCP*NOCS -! ISP == ISR in Case 6 should be skipped. -if (((ISQ >= ISR) .or. (ISP /= ISR)) .and. (ISP /= ISQ) .and. (icxc5 /= 0)) then - LAR = LTUPQ/NOTU - LR = LAR/NOQ - if (LR > NBR) LR = NBR - LAR = NOQ*LR - IAD3S = 0 - call dDAFILE(LUHLF3,0,PQTU,LAR,IAD3S) - IAD3 = 0 - IRU = 0 - IR = 0 - ! Loop over r,u pair - do NR=1,NBR - IR = IR+1 - do NU=1,NOCS - ! Square is unnecessary - IRU = NBR*(NU-1)+NR - IPQST = 1+NBPQ*(IRU-1) - if (IPQMX2 < NBPQ) then - call RBuf_tra2(LUHLF2,PQRU,NBPQ,IPQMX2,NORU,IRU,IPQST,IAD2S) - end if - ! Always ISP > ISS i.e. s(T) > s(U) - ! (pq,rU) -> (Tq,rU) - call DGEMM_('N','N',NBQ,NOCP,NBP,One,PQRU(IPQST),NBQ,CMO(LMOP2),NBP,Zero,X1,NBQ) - ! (Tq,rU) -> (TA,rU) - call DGEMM_('T','N',NOCP,NOQ,NBQ,One,X1,NBQ,CMO(LMOQ2),NBQ,Zero,X2,NOCP) - ! Store buffer - if (IR > LR) then - IR = 1 - !vv do I=1,NOTU - !vv call dDAFILE(LUHLF3,1,PQTU(1+LAR*(I-1)),LAR,IAD3) - !vv end do - call dDAFILE(LUHLF3,1,PQTU,LAR*NOTU,IAD3) - end if - ! Sorting - NAT = 0 - do NA=1,NOQ - do NT=1,NOCP - ITU = NOCS*(NT-1)+NU-1 - NAT = NAT+1 - PQTU(LAR*ITU+NOQ*(IR-1)+NA) = X2(NAT) - end do - end do - ! End of loop over r,u pair - end do - end do - ! Store last buffer - if (LR < NBR) then - !vv do I=1,NOTU - !vv call dDAFILE(LUHLF3,1,PQTU(1+LAR*(I-1)),LAR,IAD3) - !vv end do - call dDAFILE(LUHLF3,1,PQTU,LAR*NOTU,IAD3) - end if - if (ISQ >= ISR) then - ! Store(Only type1) - ISPQRS = ((ISP**2-ISP)/2+ISS-1)*NSYMP+(ISQ**2-ISQ)/2+ISR - IAD2M(2,ISPQRS) = IAD13 - else if ((ISP /= ISR) .and. (ISR > ISQ)) then - ! Store(Only type2) - ISPQRS = ((ISP**2-ISP)/2+ISS-1)*NSYMP+(ISR**2-ISR)/2+ISQ - IAD2M(3,ISPQRS) = IAD13 - end if - ! Loop over t,u pair - IST = 1-NOQ*NBR - KKTU = 0 - do NT=1,NOCP - do NU=1,NOCS - IST = IST+NOQ*NBR - KKTU = KKTU+1 - if (LR < NBR) then - call RBuf_tra2(LUHLF3,PQTU,NBR*NOQ,LAR,NOTU,KKTU,IST,IAD3S) - end if - ! (TA,rU) -> (TA,BU) - if (ISQ >= ISR) then - call DGEMM_('T','T',NOR,NOQ,NBR,One,CMO(LMOR),NBR,PQTU(IST),NOQ,Zero,X2,NOR) - else if ((ISP /= ISR) .and. (ISR > ISQ)) then - call DGEMM_('N','N',NOQ,NOR,NBR,One,PQTU(IST),NOQ,CMO(LMOR),NBR,Zero,X2,NOQ) - end if - - ! WRITE THESE BLOCK OF INTEGRALS ON LUINTM - - call GADSum(X2,NOQ*NOR) - call dDAFILE(LUINTM,1,X2,NOQ*NOR,IAD13) - end do - end do - ! End of loop over t,u pair -end if - -return - -end subroutine tr2NsA2 diff -Nru openmolcas-22.02/src/alaska/alaska_super_driver.F90 openmolcas-22.10/src/alaska/alaska_super_driver.F90 --- openmolcas-22.02/src/alaska/alaska_super_driver.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska/alaska_super_driver.F90 2022-10-10 14:22:40.000000000 +0000 @@ -25,9 +25,9 @@ logical(kind=iwp) :: Do_Cholesky, Numerical, Do_DF, Do_ESPF, StandAlone, Exists, Do_Numerical_Cholesky, Do_1CCD, MCLR_Ready character(len=128) :: FileName character(len=180) :: Line -character(len=16) :: KSDFT, StdIn +character(len=80) :: KSDFT +character(len=16) :: mstate1, mstate2, StdIn character(len=8) :: Method -character(Len=16) mstate1, mstate2 real(kind=wp), allocatable :: Grad(:) integer(kind=iwp), external :: iPrintLevel, isFreeUnit logical(kind=iwp), external :: Reduce_Prt @@ -88,7 +88,7 @@ if (iForceAnalytical == 1) Do_Numerical_Cholesky = .false. if ((Method == 'KS-DFT ') .and. Do_Numerical_Cholesky) then - call Get_cArray('DFT functional',KSDFT,16) + call Get_cArray('DFT functional',KSDFT,80) ! RI/DF 1C-CD if (Do_DF .or. (Do_Cholesky .and. Do_1CCD .and. (nSym == 1))) then @@ -313,7 +313,6 @@ ! Andrew - I need to identify the root and make sure it is not a ! state averaged calculation. iGo=1 means do MCLR - ! iGo=99 means the potentials were not calculated during the ! MCPDFT step, which is required for analytic gradients. if (iGO == 99) then diff -Nru openmolcas-22.02/src/alaska/cho_alaska_rdinp.F90 openmolcas-22.10/src/alaska/cho_alaska_rdinp.F90 --- openmolcas-22.02/src/alaska/cho_alaska_rdinp.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska/cho_alaska_rdinp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -16,12 +16,12 @@ ! !*********************************************************************** +use RI_glob, only: dmpK, nScreen use Constants, only: One, Zero use Definitions, only: wp, iwp, u6 implicit none integer(kind=iwp), intent(in) :: LuSpool -#include "exterm.fh" #include "chotime.fh" integer(kind=iwp) :: istatus real(kind=wp) :: dmpK_default diff -Nru openmolcas-22.02/src/alaska/drvdftg.F90 openmolcas-22.10/src/alaska/drvdftg.F90 --- openmolcas-22.02/src/alaska/drvdftg.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska/drvdftg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -42,12 +42,11 @@ #include "print.fh" #include "rctfld.fh" #include "disp.fh" -integer(kind=iwp) :: iDFT, iDumm, iEnd, iI, iIrrep, IK, iOpt, iPrint, iRout, iSpin, jPrint, LuWr, nAct(nIrrep), nDens, ng1, ng2, & - nRoots -real(kind=wp) :: Dummy1(1), Dummy2(1), Dummy3(1), Dummy4, Dumm0(1), Dumm1(1), ExFac, TCpu1, TCpu2, TWall1, TWall2 -logical(kind=iwp) :: First, Dff, Do_Grad, l_casdft +integer(kind=iwp) :: iDFT, iEnd, iI, iIrrep, IK, iOpt, iPrint, iRout, iSpin, jPrint, LuWr, nAct(nIrrep), nDens, ng1, ng2, nRoots +real(kind=wp) :: Dummy(1), ExFac, TCpu1, TCpu2, TWall1, TWall2 +logical(kind=iwp) :: Do_Grad, l_casdft character(len=80) :: Label -character(len=16) :: KSDFT +character(len=80) :: KSDFT character(len=8) Method character(len=4) :: DFTFOCK real(kind=wp), allocatable :: Temp2(:), R(:), G1qs(:), G2qs(:), G1qt(:), G2qt(:), D1AOMS(:), D1SAOMS(:), D1AOt(:), D1SAOt(:) @@ -77,7 +76,7 @@ !call Get_iOption(iDFT) -call Get_cArray('DFT functional',KSDFT,16) +call Get_cArray('DFT functional',KSDFT,80) l_casdft = (KSDFT(1:2) == 'T:') .or. (KSDFT(1:3) == 'FT:') if (l_casdft) then @@ -92,18 +91,15 @@ call StatusLine(' Alaska:',' Computing DFT gradients') - First = .true. - Dff = .false. - call Get_cArray('DFT functional',KSDFT,16) + call Get_cArray('DFT functional',KSDFT,80) ExFac = Zero ! Set to proper value at retrun! Do_Grad = .true. call Get_iScalar('Multiplicity',iSpin) !write(LuWr,*) 'DrvDFTg: KSDFT=',KSDFT !write(LuWr,*) 'DrvDFTg: ExFac=',ExFac - iDumm = 1 call Get_cArray('Relax Method',Method,8) if (Method /= 'MSPDFT') then - call DrvDFT(Dummy1,Dummy2,Dummy3,Dummy4,nDens,First,Dff,lRF,KSDFT,ExFac,Do_Grad,Temp,nGrad,iSpin,Dumm0,Dumm1,iDumm,DFTFOCK) + call DrvDFT(Dummy,nDens,KSDFT,ExFac,Do_Grad,Temp,nGrad,iSpin,DFTFOCK) else ! modifications for MS-PDFT gradient starting here call Get_iScalar('Number of roots',nRoots) @@ -147,7 +143,7 @@ call Put_D1SAO(D1SAOMS((IK-1)*nDens+1),nDens) end if Temp2(:) = Zero - call DrvDFT(Dummy1,Dummy2,Dummy3,Dummy4,nDens,First,Dff,lRF,KSDFT,ExFac,Do_Grad,Temp2,nGrad,iSpin,Dumm0,Dumm1,iDumm,DFTFOCK) + call DrvDFT(Dummy,nDens,KSDFT,ExFac,Do_Grad,Temp2,nGrad,iSpin,DFTFOCK) jPrint = nPrint(112) if (jPrint >= 15) then Label = 'DFT Int Contribution' diff -Nru openmolcas-22.02/src/alaska/drvemb_.F90 openmolcas-22.10/src/alaska/drvemb_.F90 --- openmolcas-22.02/src/alaska/drvemb_.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska/drvemb_.F90 2022-10-10 14:22:40.000000000 +0000 @@ -160,7 +160,7 @@ Grad_A(:) = Zero call mma_allocate(Fcorr,nh1,nFckDim,Label='Fcorr') - call cwrap_DrvNQ(KSDFT,F_DFT(1,3),nFckDim,Func_A,D_DS(1,3),nh1,nFckDim,Do_Grad,Grad_A,nGrad,DFTFOCK,Fcorr) + call cwrap_DrvNQ(KSDFT,nFckDim,Func_A,D_DS(1,3),nh1,nFckDim,Do_Grad,Grad_A,nGrad,DFTFOCK,Fcorr) call get_dScalar('NAD dft energy',Energy_NAD) Fakt_ = Xlambda(abs(Energy_NAD),Xsigma) diff -Nru openmolcas-22.02/src/alaska/drvg1.F90 openmolcas-22.10/src/alaska/drvg1.F90 --- openmolcas-22.02/src/alaska/drvg1.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska/drvg1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -212,6 +212,7 @@ !*********************************************************************** ! * call mma_MaxDBLE(MemMax) +if (MemMax > 1000) MemMax=MemMax-1000 call mma_allocate(Sew_Scr,MemMax,Label='Sew_Scr') ipMem1 = 1 ! * diff -Nru openmolcas-22.02/src/alaska/drvh1_emb.F90 openmolcas-22.10/src/alaska/drvh1_emb.F90 --- openmolcas-22.02/src/alaska/drvh1_emb.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska/drvh1_emb.F90 2022-10-10 14:22:40.000000000 +0000 @@ -29,8 +29,7 @@ character(len=16) :: NamRfil integer(kind=iwp), allocatable :: lOper(:) real(kind=wp), allocatable :: Coor(:,:), D_Var(:) -external :: OvrGrd, KneGrd, NAGrd, PrjGrd, M1Grd, M2Grd, SROGrd, WelGrd, XFdGrd, RFGrd, PCMGrd, PPGrd, FragPGrd, MltGrd, & - OvrMmG, KneMmG, NAMmG, PrjMmG, M1MmG, M2MmG, SROMmG, WelMmg, XFdMmg, RFMmg, PCMMmg, PPMmG, FragPMmG, MltMmG +external :: FragPGrd, FragPMmG, M1Grd, M1MmG, M2Grd, M2MmG, NAGrd, NAMmG, PPGrd, PPMmG, PrjGrd, PrjMmG, SROGrd, SROMmG !... Prologue iRout = 131 diff -Nru openmolcas-22.02/src/alaska/drvn1_emb.F90 openmolcas-22.10/src/alaska/drvn1_emb.F90 --- openmolcas-22.02/src/alaska/drvn1_emb.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska/drvn1_emb.F90 2022-10-10 14:22:40.000000000 +0000 @@ -26,6 +26,7 @@ use Center_Info, only: dc use Symmetry_Info, only: nIrrep use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Half use Definitions, only: wp, iwp, u6 implicit none @@ -34,7 +35,6 @@ real(kind=wp), intent(out) :: Temp(nGrad) #include "Molcas.fh" #include "print.fh" -#include "real.fh" #include "disp.fh" integer(kind=iwp) :: iCar, iCnt, iCnttp, iCnttp_B, iComp, iDCRR(0:7), igu, iIrrep, iM1xp, iM2xp, iPrint, iR, iRout, jCnt, jCntMx, & jCnttp, LmbdR, mdc, nCnttp_B, ndc, nDCRR, nDisp diff -Nru openmolcas-22.02/src/alaska/inputg.F90 openmolcas-22.10/src/alaska/inputg.F90 --- openmolcas-22.02/src/alaska/inputg.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska/inputg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -29,6 +29,7 @@ use Symmetry_Info, only: nIrrep, iChTbl, iOper, lIrrep, lBsFnc use Gateway_global, only: Onenly, Test use Gateway_Info, only: CutInt +use RI_glob, only: Timings_default use OFembed, only: Do_OFemb, KEonly, OFE_first, Xsigma, dFMD, OFE_KSDFT use stdalloc, only: mma_allocate, mma_deallocate use Constants, only: Zero, One @@ -40,14 +41,12 @@ #include "Molcas.fh" #include "print.fh" #include "disp.fh" -#include "iavec.fh" #include "columbus_gamma.fh" -#include "exterm.fh" #include "nac.fh" #include "chotime.fh" -integer(kind=iwp) :: i, iCar, iCnt, iCnttp, iCo, iComp, iElem, iGroup, iIrrep, ijSym, iPL, iPrint, iR, iRout, istatus, iSym(3), & - iTR, ix, iy, iz, j, jIrrep, jOper, jPrint, jRout, jTR, k, kTR, ldsp, lTR, LuWr, mc, mdc, mDisp, n, & - nCnttp_Valence, nDisp, nElem, nGroup, nRoots, nSlct +integer(kind=iwp) :: i, iCar, iCnt, iCnttp, iCo, iComp, iElem, iGroup, iIrrep, ijSym, iPL, iPrint, iRout, istatus, iSym(3), iTR, & + j, jIrrep, jOper, jPrint, jRout, jTR, k, kTR, ldsp, lTR, LuWr, mc, mdc, mDisp, n, nCnttp_Valence, nDisp, & + nElem, nGroup, nRoots, nSlct real(kind=wp) :: alpha, Fact, ovlp logical(kind=iwp) :: TstFnc, ltype, Slct, T_Only, No_Input_OK, Skip character(len=80) :: KWord, Key @@ -835,21 +834,6 @@ write(LuWr,*) end if -! Set up the angular index vector - -i = 0 -do iR=0,iTabMx - do ix=iR,0,-1 - do iy=iR-ix,0,-1 - iz = iR-ix-iy - i = i+1 - ixyz(1,i) = ix - ixyz(2,i) = iy - ixyz(3,i) = iz - end do - end do -end do - Onenly = HF_Force return diff -Nru openmolcas-22.02/src/alaska_util/cosgrd.F90 openmolcas-22.10/src/alaska_util/cosgrd.F90 --- openmolcas-22.02/src/alaska_util/cosgrd.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/cosgrd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -55,8 +55,8 @@ #include "macros.fh" unused_var(rFinal) -unused_var(Ccoor) -unused_var(lOper) +unused_var(Ccoor(1)) +unused_var(nComp) iRout = 151 iPrint = nPrint(iRout) @@ -131,7 +131,7 @@ kat = nint(PCMTess(4,iTs)) if (iPrint >= 99) call RecPrt('C',' ',C,3,1) - ! Generate stabilizor of C + ! Generate stabilizer of C nStb = 1 iStb(0) = 0 @@ -210,7 +210,7 @@ Coori(:,3) = TC(:) Coori(:,4) = TC(:) - call DYaX(nZeta*nDAO,Fact*Q,DAO,1,Array(ipDAO),1) + Array(ipDAO:ipDAO+nZeta*nDAO-1) = Fact*Q*pack(DAO,.true.) ! Compute integrals with the Rys quadrature. diff -Nru openmolcas-22.02/src/alaska_util/drvh1.F90 openmolcas-22.10/src/alaska_util/drvh1.F90 --- openmolcas-22.02/src/alaska_util/drvh1.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/drvh1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -49,18 +49,17 @@ integer(kind=iwp), intent(in) :: nGrad real(kind=wp), intent(inout) :: Grad(nGrad) real(kind=wp), intent(out) :: Temp(nGrad) -integer(kind=iwp) :: i, iComp, iCOSMO, ii, iIrrep, iMltpl, iPrint, iRout, iWel, ix, iy, nComp, nDens, nFock, nOrdOp +integer(kind=iwp) :: i, iComp, iCOSMO, ii, iIrrep, iMltpl, iPrint, iRout, iWel, ix, iy, nComp, nCompf, nDens, nFock, nOrdOp, nOrdOpf real(kind=wp) :: Fact, TCpu1, TCpu2, TWall1, TWall2 character(len=80) :: Label character(len=8) :: Method logical(kind=iwp) :: DiffOp, lECP, lFAIEMP, lPP -integer(kind=iwp), allocatable :: lOper(:) -real(kind=wp), allocatable :: Coor(:,:), D_Var(:), Fock(:) +integer(kind=iwp), allocatable :: lOper(:), lOperf(:) +real(kind=wp), allocatable :: Coor(:,:), Coorf(:,:), D_Var(:), Fock(:) #ifdef _NEXTFFIELD_ !AOM< -integer(kind=iwp) :: ncmp, nCompf, nextfld, nOrdOpf +integer(kind=iwp) :: ncmp, nextfld character(len=30) :: fldname -integer(kind=iwp), allocatable :: lOperf(:) !AOM> #endif external :: COSGrd, FragPGrd, FragPMmG, KneGrd, KneMmG, M1Grd, M1MmG, M2Grd, M2MmG, MltGrd, MltMmG, NAGrd, NAMmG, OvrGrd, OvrMmG, & @@ -299,14 +298,12 @@ if (.not. HF_Force) then if (lRF .and. (.not. lLangevin) .and. (.not. PCM)) then - call mma_deallocate(lOper) - call mma_deallocate(Coor) ! The Kirkwood model - nOrdOp = lMax - nComp = (lMax+1)*(lMax+2)*(lMax+3)/6 - call mma_allocate(lOper,nComp,Label='lOper') + nOrdOpf = lMax + nCompf = (lMax+1)*(lMax+2)*(lMax+3)/6 + call mma_allocate(lOperf,nCompf,Label='lOperf') ! Store permutation symmetry of components of the EF @@ -333,20 +330,23 @@ ! ixyz = 4 ! iSymZ = 2**IrrFnc(ixyz) !end if - !lOper(iComp) = MltLbl(iSymX,MltLbl(iSymY,iSymZ)) + !lOperf(iComp) = MltLbl(iSymX,MltLbl(iSymY,iSymZ)) ! Compute only total symmetric contributions - lOper(iComp) = 1 + lOperf(iComp) = 1 iComp = iComp+1 end do end do end do - call mma_allocate(Coor,3,nComp,Label='Coor') - Coor(:,:) = Zero + call mma_allocate(Coorf,3,nCompf,Label='Coorf') + Coorf(:,:) = Zero DiffOp = .true. Label = ' The Electronic Reaction Field Contribution' - call OneEl_g(RFGrd,RFMmG,Temp,nGrad,DiffOp,Coor,D_Var,nDens,lOper,nComp,nOrdOp,Label) + call OneEl_g(RFGrd,RFMmG,Temp,nGrad,DiffOp,Coorf,D_Var,nDens,lOperf,nCompf,nOrdOpf,Label) Grad(:) = Grad(:)+Temp(:) + call mma_deallocate(lOperf) + call mma_deallocate(Coorf) + else if (lRF .and. PCM) then iCOSMO = 0 ! The PCM / COSMO model diff -Nru openmolcas-22.02/src/alaska_util/knegrd.F90 openmolcas-22.10/src/alaska_util/knegrd.F90 --- openmolcas-22.02/src/alaska_util/knegrd.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/knegrd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -30,8 +30,9 @@ ! Modified to gradients October '91. * !*********************************************************************** -use Her_RW, only: iHerR, iHerW, HerR, HerW +use Her_RW, only: HerR, HerW, iHerR, iHerW use Center_Info, only: dc +use Index_Functions, only: nTri_Elem1 use Definitions, only: wp, iwp, u6 implicit none @@ -42,14 +43,12 @@ #include "macros.fh" unused_var(ZInv) -unused_var(lOper) unused_var(iStabM) +unused_var(nStabM) iRout = 150 iPrint = nPrint(iRout) -ABeq(1) = A(1) == RB(1) -ABeq(2) = A(2) == RB(2) -ABeq(3) = A(3) == RB(3) +ABeq(:) = A == RB nip = 1 ipAxyz = nip @@ -88,9 +87,7 @@ ! Compute the contribution from the multipole moment operator -ABeq(1) = .false. -ABeq(2) = .false. -ABeq(3) = .false. +ABeq(:) = .false. call CrtCmp(Zeta,P,nZeta,Ccoor,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) ! Compute the cartesian components for the multipole moment diff -Nru openmolcas-22.02/src/alaska_util/knemmg.F90 openmolcas-22.10/src/alaska_util/knemmg.F90 --- openmolcas-22.02/src/alaska_util/knemmg.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/knemmg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -17,7 +17,6 @@ use Definitions, only: iwp implicit none -#define _USE_WP_ #include "mem_interface.fh" #include "macros.fh" diff -Nru openmolcas-22.02/src/alaska_util/m1grd.F90 openmolcas-22.10/src/alaska_util/m1grd.F90 --- openmolcas-22.02/src/alaska_util/m1grd.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/m1grd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -22,30 +22,6 @@ ! ECP calculations. The operator is the nuclear attraction * ! operator times a s-type gaussian function. * ! * -! Alpha : exponents of bra gaussians * -! nAlpha: number of primitives (exponents) of bra gaussians * -! Beta : as Alpha but for ket gaussians * -! nBeta : as nAlpha but for the ket gaussians * -! Zeta : sum of exponents (nAlpha x nBeta) * -! ZInv : inverse of Zeta * -! rKappa: gaussian prefactor for the products of bra and ket * -! gaussians. * -! P : center of new gaussian from the products of bra and ket * -! gaussians. * -! rFinal: array for computed integrals * -! nZeta : nAlpha x nBeta * -! nComp : number of components in the operator (e.g. dipolmoment * -! operator has three components) * -! la : total angular momentum of bra gaussian * -! lb : total angular momentum of ket gaussian * -! A : center of bra gaussian * -! B : center of ket gaussian * -! nRys : order of Rys- or Hermite-Gauss polynomial * -! Array : Auxiliary memory as requested by ECPMem * -! nArr : length of Array * -! Ccoor : coordinates of the operator, zero for symmetric oper. * -! NOrdOp: Order of the operator * -! * ! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * ! of Lund, Sweden, and Per Boussard, Dept. of Theoretical * ! Physics, University of Stockholm, Sweden, October '93. * @@ -76,8 +52,9 @@ #include "macros.fh" unused_var(ZInv) unused_var(rFinal) +unused_var(Ccoor(1)) unused_var(nOrdOp) -unused_var(lOper) +unused_var(nComp) iRout = 193 iPrint = nPrint(iRout) @@ -87,7 +64,6 @@ if (iPrint >= 49) then call RecPrt(' In M1Grd: A',' ',A,1,3) call RecPrt(' In M1Grd: RB',' ',RB,1,3) - call RecPrt(' In M1Grd: Ccoor',' ',Ccoor,1,3) call RecPrt(' In M1Grd: P',' ',P,nZeta,3) write(u6,*) ' In M1Grd: la,lb=',' ',la,lb end if @@ -153,155 +129,155 @@ kdc = 0 do kCnttp=1,nCnttp - if (dbsc(kCnttp)%ECP .and. (dbsc(kCnttp)%nM1 /= 0)) then - do kCnt=1,dbsc(kCnttp)%nCntr - C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) - - call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) - iuvwx(3) = dc(kdc+kCnt)%nStab - iuvwx(4) = dc(kdc+kCnt)%nStab - - do lDCRT=0,nDCRT-1 - lOp(3) = NrOpr(iDCRT(lDCRT)) - lOp(4) = lOp(3) - call OA(iDCRT(lDCRT),C,TC) - ! Branch out if one-center integral - if (EQ(A,RB) .and. EQ(A,TC)) cycle - if (iPrint >= 99) call RecPrt(' In M1Grd: TC',' ',TC,1,3) - Coora(:,1) = A(:) - Coora(:,2) = RB(:) - Coori(:,1:2) = Coora(:,1:2) - if ((.not. EQ(A,RB)) .or. (.not. EQ(A,TC))) then - Coori(1,1) = Coori(1,1)+One - !Coora(1,1) = Coora(1,1)+One - end if - CoorAC(:,2) = TC(:) - Coori(:,3) = TC(:) - Coori(:,4) = TC(:) - Coora(:,3:4) = Coori(:,3:4) - - do iM1xp=1,dbsc(kCnttp)%nM1 - Gmma = dbsc(kCnttp)%M1xp(iM1xp) - - JndGrd(:,1:2) = IndGrd(:,:) - do i=1,3 - do j=1,2 - JfGrad(i,j) = IfGrad(i,j) - end do + if (kCnttp > 1) kdc = kdc+dbsc(kCnttp-1)%nCntr + if (.not. dbsc(kCnttp)%ECP) cycle + if (dbsc(kCnttp)%nM1 == 0) cycle + do kCnt=1,dbsc(kCnttp)%nCntr + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + + call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) + iuvwx(3) = dc(kdc+kCnt)%nStab + iuvwx(4) = dc(kdc+kCnt)%nStab + + do lDCRT=0,nDCRT-1 + lOp(3) = NrOpr(iDCRT(lDCRT)) + lOp(4) = lOp(3) + call OA(iDCRT(lDCRT),C,TC) + ! Branch out if one-center integral + if (EQ(A,RB) .and. EQ(A,TC)) cycle + if (iPrint >= 99) call RecPrt(' In M1Grd: TC',' ',TC,1,3) + Coora(:,1) = A(:) + Coora(:,2) = RB(:) + Coori(:,1:2) = Coora(:,1:2) + if ((.not. EQ(A,RB)) .or. (.not. EQ(A,TC))) then + Coori(1,1) = Coori(1,1)+One + !Coora(1,1) = Coora(1,1)+One + end if + CoorAC(:,2) = TC(:) + Coori(:,3) = TC(:) + Coori(:,4) = TC(:) + Coora(:,3:4) = Coori(:,3:4) + + do iM1xp=1,dbsc(kCnttp)%nM1 + Gmma = dbsc(kCnttp)%M1xp(iM1xp) + + JndGrd(:,1:2) = IndGrd(:,:) + do i=1,3 + do j=1,2 + JfGrad(i,j) = IfGrad(i,j) end do + end do - ! Derivatives with respect to the operator is computed - ! via the translational invariance. - ! Some extra care is needed here due to that Rys2Dg will - ! try to avoid some of the work. - - nDisp = IndDsp(kdc+kCnt,iIrrep) - do iCar=0,2 - ! No direct assembly of contribution from the operat. - JfGrad(iCar+1,3) = .false. - JndGrd(iCar+1,3) = 0 - iCmp = 2**iCar - if (TF(kdc+kCnt,iIrrep,iCmp) .and. (.not. dbsc(kCnttp)%pChrg)) then - ! Displacement is symmetric - nDisp = nDisp+1 - if (Direct(nDisp)) then - ! Reset flags for the basis set centers so that - ! we will explicitly compute the derivatives - ! with respect to those centers. Activate flag - ! for the third center so that its derivative - ! will be computed by the translational - ! invariance. + ! Derivatives with respect to the operator is computed + ! via the translational invariance. + ! Some extra care is needed here due to that Rys2Dg will + ! try to avoid some of the work. + + nDisp = IndDsp(kdc+kCnt,iIrrep) + do iCar=0,2 + ! No direct assembly of contribution from the operat. + JfGrad(iCar+1,3) = .false. + JndGrd(iCar+1,3) = 0 + iCmp = 2**iCar + if (TF(kdc+kCnt,iIrrep,iCmp) .and. (.not. dbsc(kCnttp)%pChrg)) then + ! Displacement is symmetric + nDisp = nDisp+1 + if (Direct(nDisp)) then + ! Reset flags for the basis set centers so that + ! we will explicitly compute the derivatives + ! with respect to those centers. Activate flag + ! for the third center so that its derivative + ! will be computed by the translational + ! invariance. + JfGrad(iCar+1,1) = .true. + JfGrad(iCar+1,2) = .true. + if ((A(iCar+1) /= TC(iCar+1)) .and. (RB(iCar+1) /= TC(iCar+1))) then + ! Three center case + JndGrd(iCar+1,1) = abs(JndGrd(iCar+1,1)) + JndGrd(iCar+1,2) = abs(JndGrd(iCar+1,2)) + JndGrd(iCar+1,3) = -nDisp JfGrad(iCar+1,1) = .true. JfGrad(iCar+1,2) = .true. - if ((A(iCar+1) /= TC(iCar+1)) .and. (RB(iCar+1) /= TC(iCar+1))) then - ! Three center case - JndGrd(iCar+1,1) = abs(JndGrd(iCar+1,1)) - JndGrd(iCar+1,2) = abs(JndGrd(iCar+1,2)) - JndGrd(iCar+1,3) = -nDisp - JfGrad(iCar+1,1) = .true. - JfGrad(iCar+1,2) = .true. - else if ((A(iCar+1) == TC(iCar+1)) .and. (RB(iCar+1) /= TC(iCar+1))) then - ! Two center case - JndGrd(iCar+1,1) = -abs(JndGrd(iCar+1,1)) - JndGrd(iCar+1,2) = abs(JndGrd(iCar+1,2)) - JfGrad(iCar+1,1) = .false. - JfGrad(iCar+1,2) = .true. - else if ((A(iCar+1) /= TC(iCar+1)) .and. (RB(iCar+1) == TC(iCar+1))) then - ! Two center case - JndGrd(iCar+1,1) = abs(JndGrd(iCar+1,1)) - JndGrd(iCar+1,2) = -abs(JndGrd(iCar+1,2)) - JfGrad(iCar+1,1) = .true. - JfGrad(iCar+1,2) = .false. - else - ! One center case - JndGrd(iCar+1,1) = 0 - JndGrd(iCar+1,2) = 0 - JfGrad(iCar+1,1) = .false. - JfGrad(iCar+1,2) = .false. - end if + else if ((A(iCar+1) == TC(iCar+1)) .and. (RB(iCar+1) /= TC(iCar+1))) then + ! Two center case + JndGrd(iCar+1,1) = -abs(JndGrd(iCar+1,1)) + JndGrd(iCar+1,2) = abs(JndGrd(iCar+1,2)) + JfGrad(iCar+1,1) = .false. + JfGrad(iCar+1,2) = .true. + else if ((A(iCar+1) /= TC(iCar+1)) .and. (RB(iCar+1) == TC(iCar+1))) then + ! Two center case + JndGrd(iCar+1,1) = abs(JndGrd(iCar+1,1)) + JndGrd(iCar+1,2) = -abs(JndGrd(iCar+1,2)) + JfGrad(iCar+1,1) = .true. + JfGrad(iCar+1,2) = .false. + else + ! One center case + JndGrd(iCar+1,1) = 0 + JndGrd(iCar+1,2) = 0 + JfGrad(iCar+1,1) = .false. + JfGrad(iCar+1,2) = .false. end if end if + end if + end do + ! No derivatives with respect to the fourth center. + JndGrd(:,4) = 0 + JfGrad(1,4) = .false. + JfGrad(2,4) = .false. + JfGrad(3,4) = .false. + mGrad = 0 + do iCar=1,3 + do i=1,2 + if (JfGrad(iCar,i)) mGrad = mGrad+1 end do - ! No derivatives with respect to the fourth center. - JndGrd(:,4) = 0 - JfGrad(1,4) = .false. - JfGrad(2,4) = .false. - JfGrad(3,4) = .false. - mGrad = 0 - do iCar=1,3 - do i=1,2 - if (JfGrad(iCar,i)) mGrad = mGrad+1 - end do - end do - if (iPrint >= 99) write(u6,*) ' mGrad=',mGrad - if (mGrad == 0) cycle - - ! Modify the original basis. Observe that - ! simplification due to A=B are not valid for the - ! exponent index, eq. P-A=/=0. + end do + if (iPrint >= 99) write(u6,*) ' mGrad=',mGrad + if (mGrad == 0) cycle - do iZeta=1,nZeta - PTC2 = (P(iZeta,1)-TC(1))**2+(P(iZeta,2)-TC(2))**2+(P(iZeta,3)-TC(3))**2 - Tmp0 = Zeta(iZeta)+Gmma - Tmp1 = exp(-Zeta(iZeta)*Gmma*PTC2/Tmp0) - Array(ipK+iZeta-1) = rKappa(iZeta)*Tmp1 - Array(ipZ+iZeta-1) = Tmp0 - Array(ipZI+iZeta-1) = One/Tmp0 - Array(ipPx+iZeta-1) = (Zeta(iZeta)*P(iZeta,1)+Gmma*TC(1))/Tmp0 - Array(ipPy+iZeta-1) = (Zeta(iZeta)*P(iZeta,2)+Gmma*TC(2))/Tmp0 - Array(ipPz+iZeta-1) = (Zeta(iZeta)*P(iZeta,3)+Gmma*TC(3))/Tmp0 - end do + ! Modify the original basis. Observe that + ! simplification due to A=B are not valid for the + ! exponent index, eq. P-A=/=0. + + do iZeta=1,nZeta + PTC2 = (P(iZeta,1)-TC(1))**2+(P(iZeta,2)-TC(2))**2+(P(iZeta,3)-TC(3))**2 + Tmp0 = Zeta(iZeta)+Gmma + Tmp1 = exp(-Zeta(iZeta)*Gmma*PTC2/Tmp0) + Array(ipK+iZeta-1) = rKappa(iZeta)*Tmp1 + Array(ipZ+iZeta-1) = Tmp0 + Array(ipZI+iZeta-1) = One/Tmp0 + Array(ipPx+iZeta-1) = (Zeta(iZeta)*P(iZeta,1)+Gmma*TC(1))/Tmp0 + Array(ipPy+iZeta-1) = (Zeta(iZeta)*P(iZeta,2)+Gmma*TC(2))/Tmp0 + Array(ipPz+iZeta-1) = (Zeta(iZeta)*P(iZeta,3)+Gmma*TC(3))/Tmp0 + end do - ! Modify the density matrix with the prefactor + ! Modify the density matrix with the prefactor - Fact = -dbsc(kCnttp)%Charge*dbsc(kCnttp)%M1cf(iM1xp)*(real(nStabM,kind=wp)/real(LmbdT,kind=wp))*Two*Pi - nDAO = nTri_Elem1(la)*nTri_Elem1(lb) - do iDAO=1,nDAO - do iZeta=1,nZeta - Fac = Fact*Array(ipK+iZeta-1)*Array(ipZI+iZeta-1) - ipDAOt = nZeta*(iDAO-1)+iZeta-1+ipDAO - Array(ipDAOt) = Fac*DAO(iZeta,iDAO) - end do + Fact = -dbsc(kCnttp)%Charge*dbsc(kCnttp)%M1cf(iM1xp)*(real(nStabM,kind=wp)/real(LmbdT,kind=wp))*Two*Pi + nDAO = nTri_Elem1(la)*nTri_Elem1(lb) + do iDAO=1,nDAO + do iZeta=1,nZeta + Fac = Fact*Array(ipK+iZeta-1)*Array(ipZI+iZeta-1) + ipDAOt = nZeta*(iDAO-1)+iZeta-1+ipDAO + Array(ipDAOt) = Fac*DAO(iZeta,iDAO) end do - if (iPrint >= 99) then - write(u6,*) ' Charge=',dbsc(kCnttp)%Charge - write(u6,*) ' Fact=',Fact - write(u6,*) ' IndGrd=',IndGrd - write(u6,*) ' JndGrd=',JndGrd - call RecPrt('DAO*Fact',' ',Array(ipDAO),nZeta,nDAO) - end if + end do + if (iPrint >= 99) then + write(u6,*) ' Charge=',dbsc(kCnttp)%Charge + write(u6,*) ' Fact=',Fact + write(u6,*) ' IndGrd=',IndGrd + write(u6,*) ' JndGrd=',JndGrd + call RecPrt('DAO*Fact',' ',Array(ipDAO),nZeta,nDAO) + end if - ! Compute integrals with the Rys quadrature. + ! Compute integrals with the Rys quadrature. - call Rysg1(iAnga,nRys,nZeta,Array(ipA),Array(ipB),[One],[One],Array(ipZ),Array(ipZI),nZeta,[One],[One],1,Array(ipPx), & - nZeta,TC,1,Coori,Coora,CoorAC,Array(ip),nArray,TNAI1,Fake,Cff2D,Array(ipDAO),nDAO,Grad,nGrad,JfGrad,JndGrd, & - lOp,iuvwx) + call Rysg1(iAnga,nRys,nZeta,Array(ipA),Array(ipB),[One],[One],Array(ipZ),Array(ipZI),nZeta,[One],[One],1,Array(ipPx), & + nZeta,TC,1,Coori,Coora,CoorAC,Array(ip),nArray,TNAI1,Fake,Cff2D,Array(ipDAO),nDAO,Grad,nGrad,JfGrad,JndGrd, & + lOp,iuvwx) - end do end do end do - end if - kdc = kdc+dbsc(kCnttp)%nCntr + end do end do return diff -Nru openmolcas-22.02/src/alaska_util/m1mmg.F90 openmolcas-22.10/src/alaska_util/m1mmg.F90 --- openmolcas-22.02/src/alaska_util/m1mmg.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/m1mmg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -32,7 +32,6 @@ use Definitions, only: iwp implicit none -#define _USE_WP_ #include "mem_interface.fh" integer(kind=iwp) :: iAng(4) diff -Nru openmolcas-22.02/src/alaska_util/m2grd.F90 openmolcas-22.10/src/alaska_util/m2grd.F90 --- openmolcas-22.02/src/alaska_util/m2grd.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/m2grd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -21,30 +21,6 @@ ! Object: kernel routine for the computation of M2 integrals used in * ! ECP calculations. The operator is a s-type gaussian * ! * -! Alpha : exponents of bra gaussians * -! nAlpha: number of primitives (exponents) of bra gaussians * -! Beta : as Alpha but for ket gaussians * -! nBeta : as nAlpha but for the ket gaussians * -! Zeta : sum of exponents (nAlpha x nBeta) * -! ZInv : inverse of Zeta * -! rKappa: gaussian prefactor for the products of bra and ket * -! gaussians. * -! P : center of new gaussian from the products of bra and ket * -! gaussians. * -! rFinal: array for computed integrals * -! nZeta : nAlpha x nBeta * -! nComp : number of components in the operator (e.g. dipolmoment * -! operator has three components) * -! la : total angular momentum of bra gaussian * -! lb : total angular momentum of ket gaussian * -! A : center of bra gaussian * -! B : center of ket gaussian * -! nRys : order of Rys- or Hermite-Gauss polynomial * -! Array : Auxiliary memory as requested by ECPMem * -! nArr : length of Array * -! Ccoor : coordinates of the operator, zero for symmetric oper. * -! NOrdOp: Order of the operator * -! * ! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * ! of Lund, Sweden, and Per Boussard, Dept. of Theoretical * ! Physics, University of Stockholm, Sweden, October '93. * @@ -52,7 +28,7 @@ use Basis_Info, only: dbsc, nCnttp use Center_Info, only: dc -use Her_RW, only: iHerR, iHerW, HerR, HerW +use Her_RW, only: HerR, HerW, iHerR, iHerW use Index_Functions, only: nTri_Elem1 use Definitions, only: wp, iwp, u6 @@ -71,7 +47,6 @@ #include "macros.fh" unused_var(ZInv) -unused_var(lOper) iRout = 122 iPrint = nPrint(iRout) @@ -139,133 +114,133 @@ kdc = 0 do kCnttp=1,nCnttp - if (dbsc(kCnttp)%ECP .and. (dbsc(kCnttp)%nM2 /= 0)) then - do kCnt=1,dbsc(kCnttp)%nCntr - C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) - - call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) - Fact = real(nStabM,kind=wp)/real(LmbdT,kind=wp) - iuvwx(3) = dc(kdc+kCnt)%nStab - iuvwx(4) = dc(kdc+kCnt)%nStab - - do lDCRT=0,nDCRT-1 - lOp(3) = NrOpr(iDCRT(lDCRT)) - lOp(4) = lOp(3) - call OA(iDCRT(lDCRT),C,TC) - if (EQ(A,RB) .and. EQ(A,TC)) cycle - - do iM2xp=1,dbsc(kCnttp)%nM2 - Gmma = dbsc(kCnttp)%M2xp(iM2xp) - if (iPrint >= 99) write(u6,*) ' Gmma=',Gmma - - JndGrd(:,1:2) = IndGrd(:,:) - do i=1,3 - do j=1,2 - JfGrad(i,j) = IfGrad(i,j) - end do + if (kCnttp > 1) kdc = kdc+dbsc(kCnttp-1)%nCntr + if (.not. dbsc(kCnttp)%ECP) cycle + if (dbsc(kCnttp)%nM2 == 0) cycle + do kCnt=1,dbsc(kCnttp)%nCntr + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + + call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) + Fact = real(nStabM,kind=wp)/real(LmbdT,kind=wp) + iuvwx(3) = dc(kdc+kCnt)%nStab + iuvwx(4) = dc(kdc+kCnt)%nStab + + do lDCRT=0,nDCRT-1 + lOp(3) = NrOpr(iDCRT(lDCRT)) + lOp(4) = lOp(3) + call OA(iDCRT(lDCRT),C,TC) + if (EQ(A,RB) .and. EQ(A,TC)) cycle + + do iM2xp=1,dbsc(kCnttp)%nM2 + Gmma = dbsc(kCnttp)%M2xp(iM2xp) + if (iPrint >= 99) write(u6,*) ' Gmma=',Gmma + + JndGrd(:,1:2) = IndGrd(:,:) + do i=1,3 + do j=1,2 + JfGrad(i,j) = IfGrad(i,j) end do + end do - ! Derivatives with respect to the operator is computed - ! via the translational invariance. + ! Derivatives with respect to the operator is computed + ! via the translational invariance. - nDisp = IndDsp(kdc+kCnt,iIrrep) - do iCar=0,2 - JfGrad(iCar+1,3) = .false. - iCmp = 2**iCar - if (TF(kdc+kCnt,iIrrep,iCmp) .and. (.not. dbsc(kCnttp)%pChrg)) then - nDisp = nDisp+1 - if (Direct(nDisp)) then - ! Reset flags for the basis set centers so that - ! we will explicitly compute the derivatives - ! with respect to those centers. Activate flag - ! for the third center so that its derivative - ! will be computed by the translational - ! invariance. - JndGrd(iCar+1,1) = abs(JndGrd(iCar+1,1)) - JndGrd(iCar+1,2) = abs(JndGrd(iCar+1,2)) - JndGrd(iCar+1,3) = -nDisp - JfGrad(iCar+1,1) = .true. - JfGrad(iCar+1,2) = .true. - else - JndGrd(iCar+1,3) = 0 - end if + nDisp = IndDsp(kdc+kCnt,iIrrep) + do iCar=0,2 + JfGrad(iCar+1,3) = .false. + iCmp = 2**iCar + if (TF(kdc+kCnt,iIrrep,iCmp) .and. (.not. dbsc(kCnttp)%pChrg)) then + nDisp = nDisp+1 + if (Direct(nDisp)) then + ! Reset flags for the basis set centers so that + ! we will explicitly compute the derivatives + ! with respect to those centers. Activate flag + ! for the third center so that its derivative + ! will be computed by the translational + ! invariance. + JndGrd(iCar+1,1) = abs(JndGrd(iCar+1,1)) + JndGrd(iCar+1,2) = abs(JndGrd(iCar+1,2)) + JndGrd(iCar+1,3) = -nDisp + JfGrad(iCar+1,1) = .true. + JfGrad(iCar+1,2) = .true. else JndGrd(iCar+1,3) = 0 end if - end do - ! No derivatives with respect to the fourth center. - JndGrd(:,4) = 0 - JfGrad(1,4) = .false. - JfGrad(2,4) = .false. - JfGrad(3,4) = .false. - mGrad = 0 - do iCar=1,3 - do i=1,2 - if (JfGrad(iCar,i)) mGrad = mGrad+1 - end do - end do - if (iPrint >= 99) write(u6,*) ' mGrad=',mGrad - if (mGrad == 0) cycle - - ! Modify the original basis. - - do iZeta=1,nZeta - PTC2 = (P(iZeta,1)-TC(1))**2+(P(iZeta,2)-TC(2))**2+(P(iZeta,3)-TC(3))**2 - Tmp0 = Zeta(iZeta)+Gmma - Tmp1 = exp(-Zeta(iZeta)*Gmma*PTC2/Tmp0) - Array(ipK+iZeta-1) = rKappa(iZeta)*Tmp1 - Array(ipZ+iZeta-1) = Tmp0 - Array(ipPx+iZeta-1) = (Zeta(iZeta)*P(iZeta,1)+Gmma*TC(1))/Tmp0 - Array(ipPy+iZeta-1) = (Zeta(iZeta)*P(iZeta,2)+Gmma*TC(2))/Tmp0 - Array(ipPz+iZeta-1) = (Zeta(iZeta)*P(iZeta,3)+Gmma*TC(3))/Tmp0 - end do - if (iPrint >= 99) then - write(u6,*) ' The modified basis set' - call RecPrt(' In M2Grd: Kappa',' ',Array(ipK),nAlpha,nBeta) - call RecPrt(' In M2Grd: Zeta',' ',Array(ipZ),nAlpha,nBeta) - call RecPrt(' In M2Grd: P',' ',Array(ipPx),nZeta,3) - call RecPrt(' In M2Grd: TC',' ',TC,1,3) + else + JndGrd(iCar+1,3) = 0 end if + end do + ! No derivatives with respect to the fourth center. + JndGrd(:,4) = 0 + JfGrad(1,4) = .false. + JfGrad(2,4) = .false. + JfGrad(3,4) = .false. + mGrad = 0 + do iCar=1,3 + do i=1,2 + if (JfGrad(iCar,i)) mGrad = mGrad+1 + end do + end do + if (iPrint >= 99) write(u6,*) ' mGrad=',mGrad + if (mGrad == 0) cycle - ! Compute the cartesian values of the basis functions - ! angular part - - ABeq(1) = (A(1) == RB(1)) .and. (A(1) == TC(1)) - ABeq(2) = (A(2) == RB(2)) .and. (A(2) == TC(2)) - ABeq(3) = (A(3) == RB(3)) .and. (A(3) == TC(3)) - call CrtCmp(Array(ipZ),Array(ipPx),nZeta,A,Array(ipAxyz),la+1,HerR(iHerR(nHer)),nHer,ABeq) - call CrtCmp(Array(ipZ),Array(ipPx),nZeta,RB,Array(ipBxyz),lb+1,HerR(iHerR(nHer)),nHer,ABeq) - - ! Compute the contribution from the multipole moment operator - - ABeq(1) = .false. - ABeq(2) = .false. - ABeq(3) = .false. - call CrtCmp(Array(ipZ),Array(ipPx),nZeta,Ccoor,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) - - ! Compute the cartesian components for the multipole - ! moment integrals. The integrals are factorized into - ! components. - - call Assmbl(Array(ipQxyz),Array(ipAxyz),la+1,Array(ipRxyz),nOrdOp,Array(ipBxyz),lb+1,nZeta,HerW(iHerW(nHer)),nHer) - - ! Combine the cartesian components to the full one - ! electron integral gradient. - - Factor = -dbsc(kCnttp)%Charge*dbsc(kCnttp)%M2cf(iM2xp)*Fact - call CmbnM2(Array(ipQxyz),nZeta,la,lb,Array(ipZ),Array(ipK),rFinal,Array(ipA),Array(ipB),JfGrad,Factor,mVec) - if (iPrint >= 99) call RecPrt(' rFinal in M2Grd',' ',rFinal,nZeta*nTri_Elem1(la)*nTri_Elem1(lb),mVec) + ! Modify the original basis. - ! Distribute the gradient contributions + do iZeta=1,nZeta + PTC2 = (P(iZeta,1)-TC(1))**2+(P(iZeta,2)-TC(2))**2+(P(iZeta,3)-TC(3))**2 + Tmp0 = Zeta(iZeta)+Gmma + Tmp1 = exp(-Zeta(iZeta)*Gmma*PTC2/Tmp0) + Array(ipK+iZeta-1) = rKappa(iZeta)*Tmp1 + Array(ipZ+iZeta-1) = Tmp0 + Array(ipPx+iZeta-1) = (Zeta(iZeta)*P(iZeta,1)+Gmma*TC(1))/Tmp0 + Array(ipPy+iZeta-1) = (Zeta(iZeta)*P(iZeta,2)+Gmma*TC(2))/Tmp0 + Array(ipPz+iZeta-1) = (Zeta(iZeta)*P(iZeta,3)+Gmma*TC(3))/Tmp0 + end do + if (iPrint >= 99) then + write(u6,*) ' The modified basis set' + call RecPrt(' In M2Grd: Kappa',' ',Array(ipK),nAlpha,nBeta) + call RecPrt(' In M2Grd: Zeta',' ',Array(ipZ),nAlpha,nBeta) + call RecPrt(' In M2Grd: P',' ',Array(ipPx),nZeta,3) + call RecPrt(' In M2Grd: TC',' ',TC,1,3) + end if + + ! Compute the cartesian values of the basis functions + ! angular part + + ABeq(1) = (A(1) == RB(1)) .and. (A(1) == TC(1)) + ABeq(2) = (A(2) == RB(2)) .and. (A(2) == TC(2)) + ABeq(3) = (A(3) == RB(3)) .and. (A(3) == TC(3)) + call CrtCmp(Array(ipZ),Array(ipPx),nZeta,A,Array(ipAxyz),la+1,HerR(iHerR(nHer)),nHer,ABeq) + call CrtCmp(Array(ipZ),Array(ipPx),nZeta,RB,Array(ipBxyz),lb+1,HerR(iHerR(nHer)),nHer,ABeq) + + ! Compute the contribution from the multipole moment operator + + ABeq(1) = .false. + ABeq(2) = .false. + ABeq(3) = .false. + call CrtCmp(Array(ipZ),Array(ipPx),nZeta,Ccoor,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) + + ! Compute the cartesian components for the multipole + ! moment integrals. The integrals are factorized into + ! components. + + call Assmbl(Array(ipQxyz),Array(ipAxyz),la+1,Array(ipRxyz),nOrdOp,Array(ipBxyz),lb+1,nZeta,HerW(iHerW(nHer)),nHer) + + ! Combine the cartesian components to the full one + ! electron integral gradient. + + Factor = -dbsc(kCnttp)%Charge*dbsc(kCnttp)%M2cf(iM2xp)*Fact + call CmbnM2(Array(ipQxyz),nZeta,la,lb,Array(ipZ),Array(ipK),rFinal,Array(ipA),Array(ipB),JfGrad,Factor,mVec) + if (iPrint >= 99) call RecPrt(' rFinal in M2Grd',' ',rFinal,nZeta*nTri_Elem1(la)*nTri_Elem1(lb),mVec) - call DistG1X(rFinal,DAO,nZeta,nDAO,mVec,Grad,nGrad,JfGrad,JndGrd,iuvwx,lOp) + ! Distribute the gradient contributions - end do + call DistG1X(rFinal,DAO,nZeta,nDAO,mVec,Grad,nGrad,JfGrad,JndGrd,iuvwx,lOp) end do + end do - end if - kdc = kdc+dbsc(kCnttp)%nCntr + end do end do diff -Nru openmolcas-22.02/src/alaska_util/m2mmg.F90 openmolcas-22.10/src/alaska_util/m2mmg.F90 --- openmolcas-22.02/src/alaska_util/m2mmg.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/m2mmg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -31,7 +31,6 @@ use Definitions, only: iwp implicit none -#define _USE_WP_ #include "mem_interface.fh" #include "macros.fh" diff -Nru openmolcas-22.02/src/alaska_util/mltgrd.F90 openmolcas-22.10/src/alaska_util/mltgrd.F90 --- openmolcas-22.02/src/alaska_util/mltgrd.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/mltgrd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -30,9 +30,10 @@ ! '91. * !*********************************************************************** -use Her_RW, only: iHerR, iHerW, HerR, HerW +use Her_RW, only: HerR, HerW, iHerR, iHerW use Center_Info, only: dc use finfld, only: force +use Index_Functions, only: nTri_Elem1 use Definitions, only: wp, iwp, u6 implicit none @@ -46,8 +47,8 @@ #include "macros.fh" unused_var(ZInv) -unused_var(lOper) unused_var(iStabM) +unused_var(nStabM) ! * !*********************************************************************** @@ -56,9 +57,7 @@ iRout = 122 iPrint = nPrint(iRout) #endif -ABeq(1) = A(1) == RB(1) -ABeq(2) = A(2) == RB(2) -ABeq(3) = A(3) == RB(3) +ABeq(:) = A == RB nip = 1 ipAxyz = nip @@ -98,9 +97,7 @@ ! Compute the contribution from the multipole moment operator -ABeq(1) = .false. -ABeq(2) = .false. -ABeq(3) = .false. +ABeq(:) = .false. call CrtCmp(Zeta,P,nZeta,Ccoor,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) ! Compute the cartesian components for the multipole moment diff -Nru openmolcas-22.02/src/alaska_util/mltgrdnuc.F90 openmolcas-22.10/src/alaska_util/mltgrdnuc.F90 --- openmolcas-22.02/src/alaska_util/mltgrdnuc.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/mltgrdnuc.F90 2022-10-10 14:22:40.000000000 +0000 @@ -35,32 +35,31 @@ if (ff == Zero) cycle kdc = 0 do kCnttp=1,nCnttp - if (dbsc(kCnttp)%Charge /= Zero) then - do kCnt=1,dbsc(kCnttp)%nCntr - C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) - ndc = kdc+kCnt - Fact = -dbsc(kCnttp)%Charge*ff - nDisp = IndDsp(ndc,iIrrep) - do iCar=0,2 - iComp = 2**iCar - if (TF(ndc,iIrrep,iComp) .and. (.not. dbsc(kCnttp)%pChrg)) then - nDisp = nDisp+1 - if (Direct(nDisp)) then - XGrad = Zero - if (iCar == 0) then - if (ixop > 0) XGrad = Fact*real(ixop,kind=wp)*C(1)**(ixop-1)*C(2)**iyop*C(3)**izop - else if (iCar == 1) then - if (iyop > 0) XGrad = Fact*real(iyop,kind=wp)*C(1)**ixop*C(2)**(iyop-1)*C(3)**izop - else - if (izop > 0) XGrad = Fact*real(izop,kind=wp)*C(1)**ixop*C(2)**iyop*C(3)**(izop-1) - end if - Grad(nDisp) = Grad(nDisp)+XGrad + if (kCnttp > 1) kdc = kdc+dbsc(kCnttp-1)%nCntr + if (dbsc(kCnttp)%Charge == Zero) cycle + do kCnt=1,dbsc(kCnttp)%nCntr + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + ndc = kdc+kCnt + Fact = -dbsc(kCnttp)%Charge*ff + nDisp = IndDsp(ndc,iIrrep) + do iCar=0,2 + iComp = 2**iCar + if (TF(ndc,iIrrep,iComp) .and. (.not. dbsc(kCnttp)%pChrg)) then + nDisp = nDisp+1 + if (Direct(nDisp)) then + XGrad = Zero + if (iCar == 0) then + if (ixop > 0) XGrad = Fact*real(ixop,kind=wp)*C(1)**(ixop-1)*C(2)**iyop*C(3)**izop + else if (iCar == 1) then + if (iyop > 0) XGrad = Fact*real(iyop,kind=wp)*C(1)**ixop*C(2)**(iyop-1)*C(3)**izop + else + if (izop > 0) XGrad = Fact*real(izop,kind=wp)*C(1)**ixop*C(2)**iyop*C(3)**(izop-1) end if + Grad(nDisp) = Grad(nDisp)+XGrad end if - end do + end if end do - end if - kdc = kdc+dbsc(kCnttp)%nCntr + end do end do end do end do diff -Nru openmolcas-22.02/src/alaska_util/mltmmg.F90 openmolcas-22.10/src/alaska_util/mltmmg.F90 --- openmolcas-22.02/src/alaska_util/mltmmg.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/mltmmg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -17,7 +17,6 @@ use Definitions, only: iwp implicit none -#define _USE_WP_ #include "mem_interface.fh" nHer = (la+lb+lr+3)/2 diff -Nru openmolcas-22.02/src/alaska_util/nagrd.F90 openmolcas-22.10/src/alaska_util/nagrd.F90 --- openmolcas-22.02/src/alaska_util/nagrd.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/nagrd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -52,9 +52,9 @@ #include "macros.fh" unused_var(rFinal) -unused_var(Ccoor) +unused_var(Ccoor(1)) unused_var(nOrdOp) -unused_var(lOper) +unused_var(nComp) #ifdef _DEBUGPRINT_ iRout = 150 @@ -127,112 +127,112 @@ kdc = 0 do kCnttp=1,nCnttp - if ((kCnttp /= iCnttp_Dummy) .and. (dbsc(kCnttp)%Charge /= Zero)) then - do kCnt=1,dbsc(kCnttp)%nCntr - C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) - - call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) - Fact = -dbsc(kCnttp)%Charge*real(nStabM,kind=wp)/real(LmbdT,kind=wp) - - ! Modify the density matrix with prefactors in case of finite nuclei - - if (Nuclear_Model == Gaussian_Type) then - Eta = dbsc(kCnttp)%ExpNuc - rKappcd = TwoP54/Eta - ! Tag on the normalization factor of the nuclear Gaussian - Fact = Fact*(Eta/Pi)**(Three/Two) - jpDAO = ipDAO - do iDAO=1,nDAO - do iZeta=1,nZeta - ! On flight modification of Kappa - rKappab = TwoP54*rKappa(iZeta)/Zeta(iZeta) - Array(jpDAO) = Fact*DAO(iZeta,iDAO)*rKappab*rKappcd*sqrt(One/(Zeta(iZeta)+Eta)) - jpDAO = jpDAO+1 - end do - end do - else if (Nuclear_Model == Point_Charge) then - call DYaX(nZeta*nDAO,Fact,DAO,1,Array(ipDAO),1) - else - write(u6,*) 'NaGrd: Fermi type nuclear distribution not implemented yet!' - call Abend() - end if - iuvwx(3) = dc(kdc+kCnt)%nStab - iuvwx(4) = dc(kdc+kCnt)%nStab - JndGrd(:,1:2) = IndGrd(:,:) - do i=1,3 - do j=1,2 - JfGrad(i,j) = IfGrad(i,j) + if (kCnttp > 1) kdc = kdc+dbsc(kCnttp-1)%nCntr + if (kCnttp == iCnttp_Dummy) cycle + if (dbsc(kCnttp)%Charge == Zero) cycle + do kCnt=1,dbsc(kCnttp)%nCntr + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + + call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) + Fact = -dbsc(kCnttp)%Charge*real(nStabM,kind=wp)/real(LmbdT,kind=wp) + + ! Modify the density matrix with prefactors in case of finite nuclei + + if (Nuclear_Model == Gaussian_Type) then + Eta = dbsc(kCnttp)%ExpNuc + rKappcd = TwoP54/Eta + ! Tag on the normalization factor of the nuclear Gaussian + Fact = Fact*(Eta/Pi)**(Three/Two) + jpDAO = ipDAO + do iDAO=1,nDAO + do iZeta=1,nZeta + ! On flight modification of Kappa + rKappab = TwoP54*rKappa(iZeta)/Zeta(iZeta) + Array(jpDAO) = Fact*DAO(iZeta,iDAO)*rKappab*rKappcd*sqrt(One/(Zeta(iZeta)+Eta)) + jpDAO = jpDAO+1 end do end do + else if (Nuclear_Model == Point_Charge) then + Array(ipDAO:ipDAO+nZeta*nDAO-1) = Fact*pack(DAO,.true.) + else + write(u6,*) 'NaGrd: Fermi type nuclear distribution not implemented yet!' + call Abend() + end if + iuvwx(3) = dc(kdc+kCnt)%nStab + iuvwx(4) = dc(kdc+kCnt)%nStab + JndGrd(:,1:2) = IndGrd(:,:) + do i=1,3 + do j=1,2 + JfGrad(i,j) = IfGrad(i,j) + end do + end do - ! Derivatives with respect to the operator is computed via the - ! translational invariance. + ! Derivatives with respect to the operator is computed via the + ! translational invariance. - nDisp = IndDsp(kdc+kCnt,iIrrep) - do iCar=0,2 - iComp = 2**iCar - if (TF(kdc+kCnt,iIrrep,iComp) .and. (.not. dbsc(kCnttp)%Frag) .and. (.not. dbsc(kCnttp)%pChrg)) then - nDisp = nDisp+1 - if (Direct(nDisp)) then - ! Reset flags for the basis set centers so that we - ! will explicitly compute the derivatives with - ! respect to those centers. Activate flag for the - ! third center so that its derivative will be computed - ! by the translational invariance. - JndGrd(iCar+1,1) = abs(JndGrd(iCar+1,1)) - JndGrd(iCar+1,2) = abs(JndGrd(iCar+1,2)) - JndGrd(iCar+1,3) = -nDisp - JfGrad(iCar+1,1) = .true. - JfGrad(iCar+1,2) = .true. - JfGrad(iCar+1,3) = .false. - else - JndGrd(iCar+1,3) = 0 - JfGrad(iCar+1,3) = .false. - end if + nDisp = IndDsp(kdc+kCnt,iIrrep) + do iCar=0,2 + iComp = 2**iCar + if (TF(kdc+kCnt,iIrrep,iComp) .and. (.not. dbsc(kCnttp)%Frag) .and. (.not. dbsc(kCnttp)%pChrg)) then + nDisp = nDisp+1 + if (Direct(nDisp)) then + ! Reset flags for the basis set centers so that we + ! will explicitly compute the derivatives with + ! respect to those centers. Activate flag for the + ! third center so that its derivative will be computed + ! by the translational invariance. + JndGrd(iCar+1,1) = abs(JndGrd(iCar+1,1)) + JndGrd(iCar+1,2) = abs(JndGrd(iCar+1,2)) + JndGrd(iCar+1,3) = -nDisp + JfGrad(iCar+1,1) = .true. + JfGrad(iCar+1,2) = .true. + JfGrad(iCar+1,3) = .false. else JndGrd(iCar+1,3) = 0 JfGrad(iCar+1,3) = .false. end if + else + JndGrd(iCar+1,3) = 0 + JfGrad(iCar+1,3) = .false. + end if + end do + ! No derivatives with respect to the fourth center. + JndGrd(:,4) = 0 + JfGrad(1,4) = .false. + JfGrad(2,4) = .false. + JfGrad(3,4) = .false. + mGrad = 0 + do iCar=1,3 + do i=1,2 + if (JfGrad(iCar,i)) mGrad = mGrad+1 end do - ! No derivatives with respect to the fourth center. - JndGrd(:,4) = 0 - JfGrad(1,4) = .false. - JfGrad(2,4) = .false. - JfGrad(3,4) = .false. - mGrad = 0 - do iCar=1,3 - do i=1,2 - if (JfGrad(iCar,i)) mGrad = mGrad+1 - end do - end do - !if (iPrint >= 99) write(u6,*) ' mGrad=',mGrad - if (mGrad == 0) cycle + end do + !if (iPrint >= 99) write(u6,*) ' mGrad=',mGrad + if (mGrad == 0) cycle - do lDCRT=0,nDCRT-1 - lOp(3) = NrOpr(iDCRT(lDCRT)) - lOp(4) = lOp(3) - call OA(iDCRT(lDCRT),C,TC) - CoorAC(:,2) = TC(:) - Coori(:,3) = TC(:) - Coori(:,4) = TC(:) - - if (Nuclear_Model == Gaussian_Type) then - Eta = dbsc(kCnttp)%ExpNuc - EInv = One/Eta - call Rysg1(iAnga,nRys,nZeta,Array(ipA),Array(ipB),[One],[One],Zeta,ZInv,nZeta,[Eta],[EInv],1,P,nZeta,TC,1,Coori,Coori, & - CoorAC,Array(nip),nArray,TERI1,ModU2,vCff2D,Array(ipDAO),nDAO,Grad,nGrad,JfGrad,JndGrd,lOp,iuvwx) - else if (Nuclear_Model == Point_Charge) then - call Rysg1(iAnga,nRys,nZeta,Array(ipA),Array(ipB),[One],[One],Zeta,ZInv,nZeta,[One],[One],1,P,nZeta,TC,1,Coori,Coori, & - CoorAC,Array(nip),nArray,TNAI1,Fake,Cff2D,Array(ipDAO),nDAO,Grad,nGrad,JfGrad,JndGrd,lOp,iuvwx) - else - ! more to come... - end if + do lDCRT=0,nDCRT-1 + lOp(3) = NrOpr(iDCRT(lDCRT)) + lOp(4) = lOp(3) + call OA(iDCRT(lDCRT),C,TC) + CoorAC(:,2) = TC(:) + Coori(:,3) = TC(:) + Coori(:,4) = TC(:) - !call RecPrt('In NaGrd: Grad',' ',Grad,nGrad,1) - end do + if (Nuclear_Model == Gaussian_Type) then + Eta = dbsc(kCnttp)%ExpNuc + EInv = One/Eta + call Rysg1(iAnga,nRys,nZeta,Array(ipA),Array(ipB),[One],[One],Zeta,ZInv,nZeta,[Eta],[EInv],1,P,nZeta,TC,1,Coori,Coori, & + CoorAC,Array(nip),nArray,TERI1,ModU2,vCff2D,Array(ipDAO),nDAO,Grad,nGrad,JfGrad,JndGrd,lOp,iuvwx) + else if (Nuclear_Model == Point_Charge) then + call Rysg1(iAnga,nRys,nZeta,Array(ipA),Array(ipB),[One],[One],Zeta,ZInv,nZeta,[One],[One],1,P,nZeta,TC,1,Coori,Coori, & + CoorAC,Array(nip),nArray,TNAI1,Fake,Cff2D,Array(ipDAO),nDAO,Grad,nGrad,JfGrad,JndGrd,lOp,iuvwx) + else + ! more to come... + end if + + !call RecPrt('In NaGrd: Grad',' ',Grad,nGrad,1) end do - end if - kdc = kdc+dbsc(kCnttp)%nCntr + end do end do return diff -Nru openmolcas-22.02/src/alaska_util/nammg.F90 openmolcas-22.10/src/alaska_util/nammg.F90 --- openmolcas-22.02/src/alaska_util/nammg.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/nammg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -20,7 +20,6 @@ use Definitions, only: iwp implicit none -#define _USE_WP_ #include "mem_interface.fh" integer(kind=iwp) :: iAng(4) diff -Nru openmolcas-22.02/src/alaska_util/oneel_g.F90 openmolcas-22.10/src/alaska_util/oneel_g.F90 --- openmolcas-22.02/src/alaska_util/oneel_g.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/oneel_g.F90 2022-10-10 14:22:40.000000000 +0000 @@ -48,15 +48,6 @@ use Definitions, only: wp, iwp, u6 implicit none -interface - subroutine Kernel( & -# define _CALLING_ -# include "grd_interface.fh" - ) - import :: wp, iwp -# include "grd_interface.fh" - end subroutine Kernel -end interface external :: KrnlMm integer(kind=iwp), intent(in) :: nGrad, nFD, nComp, lOper(nComp), nOrdOp real(kind=wp), intent(out) :: Grad(nGrad) @@ -309,7 +300,7 @@ ! trace the result. call Kernel(Shells(iShll)%Exp,iPrim,Shells(jShll)%Exp,jPrim,Zeta,ZI,Kappa,Pcoor,rFinal,iPrim*jPrim,iAng,jAng,A,RB,nOrder, & - Krnl,MemKer,Ccoor,nOrdOp,Grad,nGrad,IfGrad,IndGrd,DAO,mdci,mdcj,nOp,lOper,nComp,iStabM,nStabM) + Krnl,MemKer,Ccoor,nOrdOp,Grad,nGrad,IfGrad,IndGrd,DAO,mdci,mdcj,nOp,nComp,iStabM,nStabM) if (iPrint >= 49) call PrGrad(' In Oneel',Grad,nGrad,ChDisp) end do diff -Nru openmolcas-22.02/src/alaska_util/ovrgrd.F90 openmolcas-22.10/src/alaska_util/ovrgrd.F90 --- openmolcas-22.02/src/alaska_util/ovrgrd.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/ovrgrd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -30,8 +30,9 @@ ! '91. * !*********************************************************************** -use Her_RW, only: iHerR, iHerW, HerR, HerW +use Her_RW, only: HerR, HerW, iHerR, iHerW use Center_Info, only: dc +use Index_Functions, only: nTri_Elem1 use Definitions, only: wp, iwp, u6 implicit none @@ -42,16 +43,14 @@ #include "macros.fh" unused_var(ZInv) -unused_var(lOper) unused_var(iStabM) +unused_var(nStabM) iRout = 122 iPrint = nPrint(iRout) !write(u6,*) ' IfGrad=',IfGrad !write(u6,*) ' IndGrd=',IndGrd -ABeq(1) = A(1) == RB(1) -ABeq(2) = A(2) == RB(2) -ABeq(3) = A(3) == RB(3) +ABeq(:) = A == RB nip = 1 ipAxyz = nip @@ -88,9 +87,7 @@ ! Compute the contribution from the multipole moment operator -ABeq(1) = .false. -ABeq(2) = .false. -ABeq(3) = .false. +ABeq(:) = .false. call CrtCmp(Zeta,P,nZeta,Ccoor,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) ! Compute the cartesian components for the multipole moment diff -Nru openmolcas-22.02/src/alaska_util/ovrmmg.F90 openmolcas-22.10/src/alaska_util/ovrmmg.F90 --- openmolcas-22.02/src/alaska_util/ovrmmg.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/ovrmmg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -17,7 +17,6 @@ use Definitions, only: iwp implicit none -#define _USE_WP_ #include "mem_interface.fh" #include "macros.fh" diff -Nru openmolcas-22.02/src/alaska_util/pcmgrd.F90 openmolcas-22.10/src/alaska_util/pcmgrd.F90 --- openmolcas-22.02/src/alaska_util/pcmgrd.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/pcmgrd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -29,6 +29,7 @@ use PCM_arrays, only: PCM_SQ, PCMTess use Center_Info, only: dc +use Index_Functions, only: nTri_Elem1 use Constants, only: Zero, One, Two, Pi use Definitions, only: wp, iwp, u6 @@ -36,7 +37,7 @@ #include "grd_interface.fh" integer(kind=iwp) :: i, iAlpha, iAnga(4), iBeta, iCar, iDAO, iDCRT(0:7), ipA, ipAOff, ipB, ipBOff, ipDAO, iPrint, iRout, & iStb(0:7), iTs, iuvwx(4), iZeta, j, JndGrd(3,4), lDCRT, LmbdT, lOp(4), mGrad, mRys, nArray, nDAO, nDCRT, & - nDiff, nip, nRys, nStb + nDiff, nip, nStb real(kind=wp) :: C(3), CoorAC(3,2), Coori(3,4), EInv, Eta, Fact, Q, TC(3) logical(kind=iwp) :: JfGrad(3,4) !character(len=3), parameter :: ChOper(0:7) = ['E ','x ','y ','xy ','z ','xz ','yz ','xyz'] @@ -49,15 +50,13 @@ #include "macros.fh" unused_var(rFinal) -unused_var(nRys) -unused_var(Ccoor) -unused_var(lOper) +unused_var(nHer) +unused_var(Ccoor(1)) +unused_var(nComp) iRout = 151 iPrint = nPrint(iRout) -nRys = nHer - nip = 1 ipA = nip nip = nip+nAlpha*nBeta @@ -128,7 +127,7 @@ call DCR(LmbdT,iStabM,nStabM,iStb,nStb,iDCRT,nDCRT) Fact = -Q*real(nStabM,kind=wp)/real(LmbdT,kind=wp) - call DYaX(nZeta*nDAO,Fact,DAO,1,Array(ipDAO),1) + Array(ipDAO:ipDAO+nZeta*nDAO-1) = Fact*pack(DAO,.true.) iuvwx(3) = nStb iuvwx(4) = nStb diff -Nru openmolcas-22.02/src/alaska_util/pcmmmg.F90 openmolcas-22.10/src/alaska_util/pcmmmg.F90 --- openmolcas-22.02/src/alaska_util/pcmmmg.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/pcmmmg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -20,7 +20,6 @@ use Definitions, only: iwp implicit none -#define _USE_WP_ #include "mem_interface.fh" integer(kind=iwp) :: iAng(4) diff -Nru openmolcas-22.02/src/alaska_util/prepre_g.F90 openmolcas-22.10/src/alaska_util/prepre_g.F90 --- openmolcas-22.02/src/alaska_util/prepre_g.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/prepre_g.F90 2022-10-10 14:22:40.000000000 +0000 @@ -16,7 +16,7 @@ ! * ! Object: to preprescreen the integral derivatives. * ! * -! nZeta, nEta : unpartioned length of primitives. * +! nZeta, nEta : unpartitioned length of primitives. * ! * ! mZeta, mEta : section length due to partioning. These are usually * ! equal to nZeta and nEta. * diff -Nru openmolcas-22.02/src/alaska_util/prjgrd.F90 openmolcas-22.10/src/alaska_util/prjgrd.F90 --- openmolcas-22.02/src/alaska_util/prjgrd.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/prjgrd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -20,30 +20,6 @@ ! * ! Object: kernel routine for the computation of ECP integrals. * ! * -! Alpha : exponents of bra gaussians * -! nAlpha: number of primitives (exponents) of bra gaussians * -! Beta : as Alpha but for ket gaussians * -! nBeta : as nAlpha but for the ket gaussians * -! Zeta : sum of exponents (nAlpha x nBeta) * -! ZInv : inverse of Zeta * -! rKappa: gaussian prefactor for the products of bra and ket * -! gaussians. * -! P : center of new gaussian from the products of bra and ket * -! gaussians. * -! rFinal: array for computed integrals * -! nZeta : nAlpha x nBeta * -! nComp : number of components in the operator (e.g. dipolmoment * -! operator has three components) * -! la : total angular momentum of bra gaussian * -! lb : total angular momentum of ket gaussian * -! A : center of bra gaussian * -! B : center of ket gaussian * -! nRys : order of Rys- or Hermite-Gauss polynomial * -! Array : Auxiliary memory as requested by ECPMem * -! nArr : length of Array * -! Ccoor : coordinates of the operator, zero for symmetric oper. * -! NOrdOp: Order of the operator * -! * ! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * ! of Lund, Sweden, and Per Boussard, Dept. of Theoretical * ! Physics, University of Stockholm, Sweden, October '93. * @@ -51,7 +27,7 @@ use Basis_Info, only: dbsc, nCnttp, Shells use Center_Info, only: dc -use Her_RW, only: iHerR, iHerW, HerR, HerW +use Her_RW, only: HerR, HerW, iHerR, iHerW use Real_Spherical, only: ipSph, RSph use Symmetry_Info, only: iOper use Index_Functions, only: nTri_Elem1 @@ -63,7 +39,8 @@ integer(kind=iwp) :: i, ia, iaC, iAng, ib, iBk, iC, iCar, iCb, iCent, iCmp, iDCRT(0:7), iGamma, iIrrep, ip, ipA, ipaC, ipAxyz, & ipB, ipBxyz, ipCb, ipCxyz, ipF1, ipF1a, ipF2, ipF2a, ipK1, ipK2, ipP1, ipP2, ipQ1, iPrint, ipRxyz, ipTmp, & ipZ1, ipZ2, ipZI1, ipZI2, iRout, iShll, iStrt, iuvwx(4), iVec, j, JndGrd(3,4), kCnt, kCnttp, kdc, ld, lDCRT, & - LmbdT, lOp(4), mGrad, mVec, mVecAC, mVecCB, nac, nBasisi, ncb, nDAO, nDCRT, nDisp, nExpi, nRys, nVecAC, nVecCB + LmbdT, lOp(4), mGrad, mVec, mVecAC, mVecCB, nac, nBasisi, ncb, nDAO, nDCRT, nDisp, nExpi, n_Her, ntmp, & + nVecAC, nVecCB real(kind=wp) :: C(3), Fact, TC(3) character(len=80) :: Label logical(kind=iwp) :: ABeq(3), JfGrad(3,4), EQ @@ -77,8 +54,7 @@ unused_var(Zeta) unused_var(ZInv) unused_var(rKappa) -unused_var(nRys) -unused_var(lOper) +unused_var(nHer) iRout = 192 iPrint = nPrint(iRout) @@ -94,8 +70,6 @@ write(u6,*) ' In PrjGrd: la,lb=',' ',la,lb end if -nRys = nHer - nDAO = nTri_Elem1(la)*nTri_Elem1(lb) iIrrep = 0 iuvwx(1) = dc(mdc)%nStab @@ -105,357 +79,356 @@ kdc = 0 do kCnttp=1,nCnttp - if (dbsc(kCnttp)%ECP) then - do kCnt=1,dbsc(kCnttp)%nCntr - C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) - if (iPrint >= 49) call RecPrt(' In PrjGrd: C',' ',C,1,3) - - call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) - Fact = real(nStabM,kind=wp)/real(LmbdT,kind=wp) - - iuvwx(3) = dc(kdc+kCnt)%nStab - iuvwx(4) = dc(kdc+kCnt)%nStab - JndGrd(:,1:2) = IndGrd(:,:) - do i=1,3 - do j=1,2 - JfGrad(i,j) = IfGrad(i,j) - end do + if (kCnttp > 1) kdc = kdc+dbsc(kCnttp-1)%nCntr + if (.not. dbsc(kCnttp)%ECP) cycle + do kCnt=1,dbsc(kCnttp)%nCntr + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + if (iPrint >= 49) call RecPrt(' In PrjGrd: C',' ',C,1,3) + + call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) + Fact = real(nStabM,kind=wp)/real(LmbdT,kind=wp) + + iuvwx(3) = dc(kdc+kCnt)%nStab + iuvwx(4) = dc(kdc+kCnt)%nStab + JndGrd(:,1:2) = IndGrd(:,:) + do i=1,3 + do j=1,2 + JfGrad(i,j) = IfGrad(i,j) end do + end do - nDisp = IndDsp(kdc+kCnt,iIrrep) - do iCar=0,2 - JfGrad(iCar+1,3) = .false. - iCmp = 2**iCar - if (TF(kdc+kCnt,iIrrep,iCmp) .and. (.not. dbsc(kCnttp)%pChrg)) then - nDisp = nDisp+1 - if (Direct(nDisp)) then - JndGrd(iCar+1,1) = abs(JndGrd(iCar+1,1)) - JndGrd(iCar+1,2) = abs(JndGrd(iCar+1,2)) - JndGrd(iCar+1,3) = -nDisp - JfGrad(iCar+1,1) = .true. - JfGrad(iCar+1,2) = .true. - else - JndGrd(iCar+1,3) = 0 - end if + nDisp = IndDsp(kdc+kCnt,iIrrep) + do iCar=0,2 + JfGrad(iCar+1,3) = .false. + iCmp = 2**iCar + if (TF(kdc+kCnt,iIrrep,iCmp) .and. (.not. dbsc(kCnttp)%pChrg)) then + nDisp = nDisp+1 + if (Direct(nDisp)) then + JndGrd(iCar+1,1) = abs(JndGrd(iCar+1,1)) + JndGrd(iCar+1,2) = abs(JndGrd(iCar+1,2)) + JndGrd(iCar+1,3) = -nDisp + JfGrad(iCar+1,1) = .true. + JfGrad(iCar+1,2) = .true. else JndGrd(iCar+1,3) = 0 end if + else + JndGrd(iCar+1,3) = 0 + end if + end do + JndGrd(:,4) = 0 + JfGrad(1,4) = .false. + JfGrad(2,4) = .false. + JfGrad(3,4) = .false. + mGrad = 0 + do iCar=1,3 + do i=1,2 + if (JfGrad(iCar,i)) mGrad = mGrad+1 end do - JndGrd(:,4) = 0 - JfGrad(1,4) = .false. - JfGrad(2,4) = .false. - JfGrad(3,4) = .false. - mGrad = 0 - do iCar=1,3 - do i=1,2 - if (JfGrad(iCar,i)) mGrad = mGrad+1 - end do - end do - if (iPrint >= 99) write(u6,*) ' mGrad=',mGrad - if (mGrad == 0) cycle + end do + if (iPrint >= 99) write(u6,*) ' mGrad=',mGrad + if (mGrad == 0) cycle - do lDCRT=0,nDCRT-1 - lOp(3) = iDCRT(lDCRT) - lOp(4) = lOp(3) - call OA(iDCRT(lDCRT),C,TC) - if (EQ(A,RB) .and. EQ(A,TC)) cycle - do iAng=0,dbsc(kCnttp)%nPrj-1 - iShll = dbsc(kCnttp)%iPrj+iAng - nExpi = Shells(iShll)%nExp - nBasisi = Shells(iShll)%nBasis - if (iPrint >= 49) then - write(u6,*) 'nExpi=',nExpi - write(u6,*) 'nBasisi=',nBasisi - write(u6,*) ' iAng=',iAng - call RecPrt('TC',' ',TC,1,3) - end if - if ((nExpi == 0) .or. (nBasisi == 0)) cycle - - ip = 1 - ipF1 = ip - nac = nTri_Elem1(la)*nTri_Elem1(iAng)*4 - ip = ip+nAlpha*nExpi*nac - ipP1 = ip - ip = ip+3*nAlpha*nExpi - ipZ1 = ip - ip = ip+nAlpha*nExpi - ipK1 = ip - ip = ip+nAlpha*nExpi - ipZI1 = ip - ip = ip+nAlpha*nExpi - if (ip-1 > nArr*nZeta) then - write(u6,*) ' ip-1 > nArr*nZeta(1) in PrjGrd' - call Abend() - end if - - ! Calculate Effective center and exponent for - - call ZXia(Array(ipZ1),Array(ipZI1),nAlpha,nExpi,Alpha,Shells(iShll)%Exp) - call SetUp1(Alpha,nAlpha,Shells(iShll)%Exp,nExpi,A,TC,Array(ipK1),Array(ipP1),Array(ipZI1)) - - ! Calculate Overlap and derivative - - nHer = ((la+1)+iAng+2)/2 - ipAxyz = ip - ip = ip+nAlpha*nExpi*3*nHer*(la+2) - ipCxyz = ip - ip = ip+nAlpha*nExpi*3*nHer*(iAng+1) - ipRxyz = ip - ip = ip+nAlpha*nExpi*3*nHer*(nOrdOp+1) - ipQ1 = ip - ip = ip+nAlpha*nExpi*3*(la+2)*(iAng+1)*(nOrdOp+1) - ipA = ip - ip = ip+nAlpha*nExpi - if (ip-1 > nArr*nZeta) then - write(u6,*) ' ip-1 > nArr*nZeta(1b) in PrjGrd' - call Abend() - end if - ABeq(1) = A(1) == TC(1) - ABeq(2) = A(2) == TC(2) - ABeq(3) = A(3) == TC(3) - call CrtCmp(Array(ipZ1),Array(ipP1),nAlpha*nExpi,A,Array(ipAxyz),la+1,HerR(iHerR(nHer)),nHer,ABeq) - call CrtCmp(Array(ipZ1),Array(ipP1),nAlpha*nExpi,TC,Array(ipCxyz),iAng,HerR(iHerR(nHer)),nHer,ABeq) - ABeq(1) = .false. - ABeq(2) = .false. - ABeq(3) = .false. - call CrtCmp(Array(ipZ1),Array(ipP1),nAlpha*nExpi,Ccoor,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) - if (iPrint >= 49) then - write(u6,*) ' Array(ipAxyz)=',DNrm2_(nAlpha*nExpi*3*nHer*(la+2),Array(ipAxyz),1) - write(u6,*) ' Array(ipCxyz)=',DNrm2_(nAlpha*nExpi*3*nHer*(iAng+1),Array(ipCxyz),1) - write(u6,*) ' Array(ipRxyz)=',DNrm2_(nAlpha*nExpi*3*nHer*(nOrdOp+1),Array(ipRxyz),1) - end if - call Assmbl(Array(ipQ1),Array(ipAxyz),la+1,Array(ipRxyz),nOrdOp,Array(ipCxyz),iAng,nAlpha*nExpi,HerW(iHerW(nHer)),nHer) - iStrt = ipA - do iGamma=1,nExpi - call dcopy_(nAlpha,Alpha,1,Array(iStrt),1) - iStrt = iStrt+nAlpha - end do - if (iPrint >= 49) then - write(u6,*) ' Array(ipA)=',DNrm2_(nAlpha*nExpi,Array(ipA),1) - end if - call rKappa_Zeta(Array(ipK1),Array(ipZ1),nExpi*nAlpha) - ld = 1 - call CmbnAC(Array(ipQ1),nAlpha*nExpi,la,iAng,Array(ipK1),Array(ipF1),Array(ipA),JfGrad(1,1),ld,nVecAC) - if (iPrint >= 49) then - write(u6,*) ' Array(ipQ1)=',DNrm2_(nAlpha*nExpi*3*(la+2)*(iAng+1)*(nOrdOp+1),Array(ipQ1),1) - write(u6,*) ' Array(ipA)=',DNrm2_(nAlpha*nExpi,Array(ipA),1) - end if - ip = ip-nAlpha*nExpi*(6+3*nHer*(la+2)+3*nHer*(iAng+1)+3*nHer*(nOrdOp+1)+3*(la+2)*(iAng+1)*(nOrdOp+1)+1) - - ipF2 = ip - ncb = nTri_Elem1(iAng)*nTri_Elem1(lb)*4 - ip = ip+nExpi*nBeta*ncb - ipP2 = ip - ip = ip+3*nExpi*nBeta - ipZ2 = ip - ip = ip+nExpi*nBeta - ipK2 = ip - ip = ip+nExpi*nBeta - ipZI2 = ip - ip = ip+nExpi*nBeta - if (ip-1 > nArr*nZeta) then - write(u6,*) ' ip-1 > nArr*nZeta(2) in PrjGrd' - call Abend() - end if - - ! Calculate Effective center and exponent for - - call ZXia(Array(ipZ2),Array(ipZI2),nExpi,nBeta,Shells(iShll)%Exp,Beta) - call SetUp1(Shells(iShll)%Exp,nExpi,Beta,nBeta,TC,RB,Array(ipK2),Array(ipP2),Array(ipZI2)) - - ! Calculate Overlap and - - nHer = (iAng+(lb+1)+2)/2 - ipCxyz = ip - ip = ip+nBeta*nExpi*3*nHer*(iAng+1) - ipBxyz = ip - ip = ip+nBeta*nExpi*3*nHer*(lb+2) - ipRxyz = ip - ip = ip+nBeta*nExpi*3*nHer*(nOrdOp+1) - ipQ1 = ip - ip = ip+nBeta*nExpi*3*(iAng+1)*(lb+2)*(nOrdOp+1) - ipB = ip - ip = ip+nBeta*nExpi - if (ip-1 > nArr*nZeta) then - write(u6,*) ' ip-1 > nArr*nZeta(2b) in PrjGrd' - call Abend() - end if - ABeq(1) = TC(1) == RB(1) - ABeq(2) = TC(2) == RB(2) - ABeq(3) = TC(3) == RB(3) - call CrtCmp(Array(ipZ2),Array(ipP2),nExpi*nBeta,TC,Array(ipCxyz),iAng,HerR(iHerR(nHer)),nHer,ABeq) - call CrtCmp(Array(ipZ2),Array(ipP2),nExpi*nBeta,RB,Array(ipBxyz),lb+1,HerR(iHerR(nHer)),nHer,ABeq) - ABeq(1) = .false. - ABeq(2) = .false. - ABeq(3) = .false. - call CrtCmp(Array(ipZ2),Array(ipP2),nExpi*nBeta,Ccoor,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) - if (iPrint >= 49) then - write(u6,*) ' Array(ipCxyz)=',DNrm2_(nBeta*nExpi*3*nHer*(iAng+1),Array(ipCxyz),1) - write(u6,*) ' Array(ipBxyz)=',DNrm2_(nBeta*nExpi*3*nHer*(lb+2),Array(ipBxyz),1) - write(u6,*) ' Array(ipRxyz)=',DNrm2_(nBeta*nExpi*3*nHer*(nOrdOp+1),Array(ipRxyz),1) - end if - call Assmbl(Array(ipQ1),Array(ipCxyz),iAng,Array(ipRxyz),nOrdOp,Array(ipBxyz),lb+1,nExpi*nBeta,HerW(iHerW(nHer)),nHer) - iStrt = ipB - do iGamma=1,nExpi - call dcopy_(nBeta,Beta,1,Array(iStrt),nExpi) - iStrt = iStrt+1 - end do - if (iPrint >= 49) then - write(u6,*) ' Array(ipB)=',DNrm2_(nExpi*nBeta,Array(ipB),1) - end if - call rKappa_Zeta(Array(ipK2),Array(ipZ2),nExpi*nBeta) - ld = 1 - call CmbnCB(Array(ipQ1),nExpi*nBeta,iAng,lb,Array(ipK2),Array(ipF2),Array(ipB),JfGrad(1,2),ld,nVecCB) - if (iPrint >= 49) then - write(u6,*) ' Array(ipQ1)=',DNrm2_(nExpi*nBeta*3*(la+2)*(iAng+1)*(nOrdOp+1),Array(ipQ1),1) - write(u6,*) ' Array(ipB)=',DNrm2_(nExpi*nBeta,Array(ipB),1) - end if - ip = ip-nBeta*nExpi*(6+3*nHer*(lb+2)+3*nHer*(iAng+1)+3*nHer*(nOrdOp+1)+3*(lb+2)*(iAng+1)*(nOrdOp+1)+1) - nac = nTri_Elem1(la)*nTri_Elem1(iAng)*nVecAC - ncb = nTri_Elem1(iAng)*nTri_Elem1(lb)*nVecCB - ipTmp = ip - ip = ip+max(nAlpha*nExpi*nac,nBeta*ncb*nBasisi) - if (ip-1 > nArr*nZeta) then - write(u6,*) ' ip-1 > nArr*nZeta(3) in PrjGrd' - call Abend() - end if - nac = nTri_Elem1(la)*nTri_Elem1(iAng) - ncb = nTri_Elem1(iAng)*nTri_Elem1(lb) - - ! Calculate Contraction over components of the core - ! orbitals of type Bc where we now have in - ! Array(ipF1) the cartesian components of , and - ! similarily, in Array(ipF2), we have stored the cartesian - ! components of . Observe that the core orbitals - ! orthonomal atomic orbitals. Hence, the transformation - ! to the spherical harmonics has to be for normilized - ! spherical harminics. - - ! From the lefthandside overlap, form iKaC from ikac by - ! 1) i,kac -> k,aci - - call DgeTMo(Array(ipF1),nAlpha,nAlpha,nExpi*nac*nVecAC,Array(ipTmp),nExpi*nac*nVecAC) - - ! 2) aciK = k,aci * k,K (Contract over core orbital) - - call DGEMM_('T','N',nac*nVecAC*nAlpha,nBasisi,nExpi,One,Array(ipTmp),nExpi,Shells(iShll)%pCff,nExpi,Zero,Array(ipF1), & - nac*nVecAC*nAlpha) - - ! 3) Mult by shiftoperators aci,K -> Bk(K) * aci,K - - do iBk=1,nBasisi - call DYaX(nac*nVecAC*nAlpha,Shells(iShll)%Bk(iBk),Array((iBk-1)*nac*nVecAC*nAlpha+ipF1),1, & - Array((iBk-1)*nac*nVecAC*nAlpha+ipTmp),1) - end do + do lDCRT=0,nDCRT-1 + lOp(3) = iDCRT(lDCRT) + lOp(4) = lOp(3) + call OA(iDCRT(lDCRT),C,TC) + if (EQ(A,RB) .and. EQ(A,TC)) cycle + do iAng=0,dbsc(kCnttp)%nPrj-1 + iShll = dbsc(kCnttp)%iPrj+iAng + nExpi = Shells(iShll)%nExp + nBasisi = Shells(iShll)%nBasis + if (iPrint >= 49) then + write(u6,*) 'nExpi=',nExpi + write(u6,*) 'nBasisi=',nBasisi + write(u6,*) ' iAng=',iAng + call RecPrt('TC',' ',TC,1,3) + end if + if ((nExpi == 0) .or. (nBasisi == 0)) cycle - ! 4) a,ciK -> ciKa + ip = 1 + ipF1 = ip + nac = nTri_Elem1(la)*nTri_Elem1(iAng)*4 + ip = ip+nAlpha*nExpi*nac + ipP1 = ip + ip = ip+3*nAlpha*nExpi + ipZ1 = ip + ip = ip+nAlpha*nExpi + ipK1 = ip + ip = ip+nAlpha*nExpi + ipZI1 = ip + ip = ip+nAlpha*nExpi + if (ip-1 > nArr*nZeta) then + write(u6,*) ' ip-1 > nArr*nZeta(1) in PrjGrd' + call Abend() + end if - call DgeTMo(Array(ipTmp),nTri_Elem1(la),nTri_Elem1(la),nTri_Elem1(iAng)*nVecAC*nAlpha*nBasisi,Array(ipF1), & - nTri_Elem1(iAng)*nVecAC*nAlpha*nBasisi) + ! Calculate Effective center and exponent for - ! 5) iKa,C = c,iKa * c,C + call ZXia(Array(ipZ1),Array(ipZI1),nAlpha,nExpi,Alpha,Shells(iShll)%Exp) + call SetUp1(Alpha,nAlpha,Shells(iShll)%Exp,nExpi,A,TC,Array(ipK1),Array(ipP1),Array(ipZI1)) - call DGEMM_('T','N',nVecAC*nAlpha*nBasisi*nTri_Elem1(la),(2*iAng+1),nTri_Elem1(iAng),One,Array(ipF1),nTri_Elem1(iAng), & - RSph(ipSph(iAng)),nTri_Elem1(iAng),Zero,Array(ipTmp),nVecAC*nAlpha*nBasisi*nTri_Elem1(la)) + ! Calculate Overlap and derivative - call DgeTMo(Array(ipTmp),nVecAC,nVecAC,nAlpha*nBasisi*nTri_Elem1(la)*(2*iAng+1),Array(ipF1), & - nAlpha*nBasisi*nTri_Elem1(la)*(2*iAng+1)) + n_Her = ((la+1)+iAng+2)/2 + ipAxyz = ip + ip = ip+nAlpha*nExpi*3*n_Her*(la+2) + ipCxyz = ip + ip = ip+nAlpha*nExpi*3*n_Her*(iAng+1) + ipRxyz = ip + ip = ip+nAlpha*nExpi*3*n_Her*(nOrdOp+1) + ipQ1 = ip + ip = ip+nAlpha*nExpi*3*(la+2)*(iAng+1)*(nOrdOp+1) + ipA = ip + ip = ip+nAlpha*nExpi + if (ip-1 > nArr*nZeta) then + write(u6,*) ' ip-1 > nArr*nZeta(1b) in PrjGrd' + call Abend() + end if + ABeq(1) = A(1) == TC(1) + ABeq(2) = A(2) == TC(2) + ABeq(3) = A(3) == TC(3) + call CrtCmp(Array(ipZ1),Array(ipP1),nAlpha*nExpi,A,Array(ipAxyz),la+1,HerR(iHerR(n_Her)),n_Her,ABeq) + call CrtCmp(Array(ipZ1),Array(ipP1),nAlpha*nExpi,TC,Array(ipCxyz),iAng,HerR(iHerR(n_Her)),n_Her,ABeq) + ABeq(1) = .false. + ABeq(2) = .false. + ABeq(3) = .false. + call CrtCmp(Array(ipZ1),Array(ipP1),nAlpha*nExpi,Ccoor,Array(ipRxyz),nOrdOp,HerR(iHerR(n_Her)),n_Her,ABeq) + if (iPrint >= 49) then + write(u6,*) ' Array(ipAxyz)=',DNrm2_(nAlpha*nExpi*3*n_Her*(la+2),Array(ipAxyz),1) + write(u6,*) ' Array(ipCxyz)=',DNrm2_(nAlpha*nExpi*3*n_Her*(iAng+1),Array(ipCxyz),1) + write(u6,*) ' Array(ipRxyz)=',DNrm2_(nAlpha*nExpi*3*n_Her*(nOrdOp+1),Array(ipRxyz),1) + end if + call Assmbl(Array(ipQ1),Array(ipAxyz),la+1,Array(ipRxyz),nOrdOp,Array(ipCxyz),iAng,nAlpha*nExpi,HerW(iHerW(n_Her)),n_Her) + iStrt = ipA + do iGamma=1,nExpi + call dcopy_(nAlpha,Alpha,1,Array(iStrt),1) + iStrt = iStrt+nAlpha + end do + if (iPrint >= 49) then + write(u6,*) ' Array(ipA)=',DNrm2_(nAlpha*nExpi,Array(ipA),1) + end if + call rKappa_Zeta(Array(ipK1),Array(ipZ1),nExpi*nAlpha) + ld = 1 + call CmbnAC(Array(ipQ1),nAlpha*nExpi,la,iAng,Array(ipK1),Array(ipF1),Array(ipA),JfGrad(1,1),ld,nVecAC) + if (iPrint >= 49) then + write(u6,*) ' Array(ipQ1)=',DNrm2_(nAlpha*nExpi*3*(la+2)*(iAng+1)*(nOrdOp+1),Array(ipQ1),1) + write(u6,*) ' Array(ipA)=',DNrm2_(nAlpha*nExpi,Array(ipA),1) + end if + ip = ip-nAlpha*nExpi*(6+3*n_Her*(la+2)+3*n_Her*(iAng+1)+3*n_Her*(nOrdOp+1)+3*(la+2)*(iAng+1)*(nOrdOp+1)+1) - ! And (almost) the same thing for the righthand side, form - ! KjCb from kjcb - ! 1) jcb,K = k,jcb * k,K + ipF2 = ip + ncb = nTri_Elem1(iAng)*nTri_Elem1(lb)*4 + ip = ip+nExpi*nBeta*ncb + ipP2 = ip + ip = ip+3*nExpi*nBeta + ipZ2 = ip + ip = ip+nExpi*nBeta + ipK2 = ip + ip = ip+nExpi*nBeta + ipZI2 = ip + ip = ip+nExpi*nBeta + if (ip-1 > nArr*nZeta) then + write(u6,*) ' ip-1 > nArr*nZeta(2) in PrjGrd' + call Abend() + end if - call DGEMM_('T','N',nBeta*ncb*nVecCB,nBasisi,nExpi,One,Array(ipF2),nExpi,Shells(iShll)%pCff,nExpi,Zero,Array(ipTmp), & - nBeta*ncb*nVecCB) + ! Calculate Effective center and exponent for - ! 2) j,cbK -> cbK,j + call ZXia(Array(ipZ2),Array(ipZI2),nExpi,nBeta,Shells(iShll)%Exp,Beta) + call SetUp1(Shells(iShll)%Exp,nExpi,Beta,nBeta,TC,RB,Array(ipK2),Array(ipP2),Array(ipZI2)) - call DgeTMo(Array(ipTmp),nBeta,nBeta,ncb*nVecCB*nBasisi,Array(ipF2),ncb*nVecCB*nBasisi) + ! Calculate Overlap and - ! 3) bKj,C = c,bKj * c,C + n_Her = (iAng+(lb+1)+2)/2 + ipCxyz = ip + ip = ip+nBeta*nExpi*3*n_Her*(iAng+1) + ipBxyz = ip + ip = ip+nBeta*nExpi*3*n_Her*(lb+2) + ipRxyz = ip + ip = ip+nBeta*nExpi*3*n_Her*(nOrdOp+1) + ipQ1 = ip + ip = ip+nBeta*nExpi*3*(iAng+1)*(lb+2)*(nOrdOp+1) + ipB = ip + ip = ip+nBeta*nExpi + if (ip-1 > nArr*nZeta) then + write(u6,*) ' ip-1 > nArr*nZeta(2b) in PrjGrd' + call Abend() + end if + ABeq(1) = TC(1) == RB(1) + ABeq(2) = TC(2) == RB(2) + ABeq(3) = TC(3) == RB(3) + call CrtCmp(Array(ipZ2),Array(ipP2),nExpi*nBeta,TC,Array(ipCxyz),iAng,HerR(iHerR(n_Her)),n_Her,ABeq) + call CrtCmp(Array(ipZ2),Array(ipP2),nExpi*nBeta,RB,Array(ipBxyz),lb+1,HerR(iHerR(n_Her)),n_Her,ABeq) + ABeq(1) = .false. + ABeq(2) = .false. + ABeq(3) = .false. + call CrtCmp(Array(ipZ2),Array(ipP2),nExpi*nBeta,Ccoor,Array(ipRxyz),nOrdOp,HerR(iHerR(n_Her)),n_Her,ABeq) + if (iPrint >= 49) then + write(u6,*) ' Array(ipCxyz)=',DNrm2_(nBeta*nExpi*3*n_Her*(iAng+1),Array(ipCxyz),1) + write(u6,*) ' Array(ipBxyz)=',DNrm2_(nBeta*nExpi*3*n_Her*(lb+2),Array(ipBxyz),1) + write(u6,*) ' Array(ipRxyz)=',DNrm2_(nBeta*nExpi*3*n_Her*(nOrdOp+1),Array(ipRxyz),1) + end if + call Assmbl(Array(ipQ1),Array(ipCxyz),iAng,Array(ipRxyz),nOrdOp,Array(ipBxyz),lb+1,nExpi*nBeta,HerW(iHerW(n_Her)),n_Her) + iStrt = ipB + do iGamma=1,nExpi + call dcopy_(nBeta,Beta,1,Array(iStrt),nExpi) + iStrt = iStrt+1 + end do + if (iPrint >= 49) then + write(u6,*) ' Array(ipB)=',DNrm2_(nExpi*nBeta,Array(ipB),1) + end if + call rKappa_Zeta(Array(ipK2),Array(ipZ2),nExpi*nBeta) + ld = 1 + call CmbnCB(Array(ipQ1),nExpi*nBeta,iAng,lb,Array(ipK2),Array(ipF2),Array(ipB),JfGrad(1,2),ld,nVecCB) + if (iPrint >= 49) then + write(u6,*) ' Array(ipQ1)=',DNrm2_(nExpi*nBeta*3*(la+2)*(iAng+1)*(nOrdOp+1),Array(ipQ1),1) + write(u6,*) ' Array(ipB)=',DNrm2_(nExpi*nBeta,Array(ipB),1) + end if + ip = ip-nBeta*nExpi*(6+3*n_Her*(lb+2)+3*n_Her*(iAng+1)+3*n_Her*(nOrdOp+1)+3*(lb+2)*(iAng+1)*(nOrdOp+1)+1) + nac = nTri_Elem1(la)*nTri_Elem1(iAng)*nVecAC + ncb = nTri_Elem1(iAng)*nTri_Elem1(lb)*nVecCB + ipTmp = ip + ip = ip+max(nAlpha*nExpi*nac,nBeta*ncb*nBasisi) + if (ip-1 > nArr*nZeta) then + write(u6,*) ' ip-1 > nArr*nZeta(3) in PrjGrd' + call Abend() + end if + nac = nTri_Elem1(la)*nTri_Elem1(iAng) + ncb = nTri_Elem1(iAng)*nTri_Elem1(lb) - call DGEMM_('T','N',nTri_Elem1(lb)*nVecCB*nBasisi*nBeta,(2*iAng+1),nTri_Elem1(iAng),One,Array(ipF2),nTri_Elem1(iAng), & - RSph(ipSph(iAng)),nTri_Elem1(iAng),Zero,Array(ipTmp),nTri_Elem1(lb)*nVecCB*nBasisi*nBeta) + ! Calculate Contraction over components of the core + ! orbitals of type Bc where we now have in + ! Array(ipF1) the cartesian components of , and + ! similarily, in Array(ipF2), we have stored the cartesian + ! components of . Observe that the core orbitals + ! orthonomal atomic orbitals. Hence, the transformation + ! to the spherical harmonics has to be for normilized + ! spherical harminics. - ! 4) b,KjC -> KjC,b + ! From the lefthandside overlap, form iKaC from ikac by + ! 1) i,kac -> k,aci - call DgeTMo(Array(ipTmp),nTri_Elem1(lb)*nVecCB,nTri_Elem1(lb)*nVecCB,nBasisi*nBeta*(2*iAng+1),Array(ipF2), & - nBasisi*nBeta*(2*iAng+1)) + call DgeTMo(Array(ipF1),nAlpha,nAlpha,nExpi*nac*nVecAC,Array(ipTmp),nExpi*nac*nVecAC) - ! Next Contract (iKaC)*(KjCb) over K and C, producing ijab, - ! by the following procedure: - ! Loop over a and b - ! Loop over C - ! Contract iK(aC)*Kj(Cb), over K producing ij(aCb), - ! accumulate to ij(ab) - ! End loop C - ! End Loop b and a + ! 2) aciK = k,aci * k,K (Contract over core orbital) - rFinal(:,:,:,:) = Zero + call DGEMM_('T','N',nac*nVecAC*nAlpha,nBasisi,nExpi,One,Array(ipTmp),nExpi,Shells(iShll)%pCff,nExpi,Zero,Array(ipF1), & + nac*nVecAC*nAlpha) - mVec = 0 - mVecAC = 1 - mVecCB = 1 - do iCar=1,3 - do iCent=1,2 - if (JfGrad(iCar,iCent)) then - mVec = mVec+1 - if (iCent == 1) then - mVecAC = mVecAC+1 - ipF1a = ipF1+(mVecAC-1)*nAlpha*nBasisi*nTri_Elem1(la)*(2*iAng+1) - ipF2a = ipF2 - else - ipF1a = ipF1 - mVecCB = mVecCB+1 - ipF2a = ipF2+(mVecCB-1)*nBasisi*nBeta*(2*iAng+1)*nTri_Elem1(lb) - end if + ! 3) Mult by shiftoperators aci,K -> Bk(K) * aci,K - do ib=1,nTri_Elem1(lb) - do ia=1,nTri_Elem1(la) + ntmp = nac*nVecAC*nAlpha + do iBk=1,nBasisi + Array(ipTmp+(iBk-1)*ntmp:ipTmp+iBk*ntmp-1) = Shells(iShll)%Bk(iBk)*Array(ipF1+(iBk-1)*ntmp:ipF1+iBk*ntmp-1) + end do - do iC=1,(2*iAng+1) - iaC = (iC-1)*nTri_Elem1(la)+ia - ipaC = (iaC-1)*nAlpha*nBasisi+ipF1a - iCb = (ib-1)*(2*iAng+1)+iC - ipCb = (iCb-1)*nBasisi*nBeta+ipF2a + ! 4) a,ciK -> ciKa - call DGEMM_('N','N',nAlpha,nBeta,nBasisi,Fact,Array(ipaC),nAlpha,Array(ipCb),nBasisi,One, & - rFinal(1,ia,ib,mVec),nAlpha) + call DgeTMo(Array(ipTmp),nTri_Elem1(la),nTri_Elem1(la),nTri_Elem1(iAng)*nVecAC*nAlpha*nBasisi,Array(ipF1), & + nTri_Elem1(iAng)*nVecAC*nAlpha*nBasisi) - end do - end do - end do + ! 5) iKa,C = c,iKa * c,C + call DGEMM_('T','N',nVecAC*nAlpha*nBasisi*nTri_Elem1(la),(2*iAng+1),nTri_Elem1(iAng),One,Array(ipF1),nTri_Elem1(iAng), & + RSph(ipSph(iAng)),nTri_Elem1(iAng),Zero,Array(ipTmp),nVecAC*nAlpha*nBasisi*nTri_Elem1(la)) + + call DgeTMo(Array(ipTmp),nVecAC,nVecAC,nAlpha*nBasisi*nTri_Elem1(la)*(2*iAng+1),Array(ipF1), & + nAlpha*nBasisi*nTri_Elem1(la)*(2*iAng+1)) + + ! And (almost) the same thing for the righthand side, form + ! KjCb from kjcb + ! 1) jcb,K = k,jcb * k,K + + call DGEMM_('T','N',nBeta*ncb*nVecCB,nBasisi,nExpi,One,Array(ipF2),nExpi,Shells(iShll)%pCff,nExpi,Zero,Array(ipTmp), & + nBeta*ncb*nVecCB) + + ! 2) j,cbK -> cbK,j + + call DgeTMo(Array(ipTmp),nBeta,nBeta,ncb*nVecCB*nBasisi,Array(ipF2),ncb*nVecCB*nBasisi) + + ! 3) bKj,C = c,bKj * c,C + + call DGEMM_('T','N',nTri_Elem1(lb)*nVecCB*nBasisi*nBeta,(2*iAng+1),nTri_Elem1(iAng),One,Array(ipF2),nTri_Elem1(iAng), & + RSph(ipSph(iAng)),nTri_Elem1(iAng),Zero,Array(ipTmp),nTri_Elem1(lb)*nVecCB*nBasisi*nBeta) + + ! 4) b,KjC -> KjC,b + + call DgeTMo(Array(ipTmp),nTri_Elem1(lb)*nVecCB,nTri_Elem1(lb)*nVecCB,nBasisi*nBeta*(2*iAng+1),Array(ipF2), & + nBasisi*nBeta*(2*iAng+1)) + + ! Next Contract (iKaC)*(KjCb) over K and C, producing ijab, + ! by the following procedure: + ! Loop over a and b + ! Loop over C + ! Contract iK(aC)*Kj(Cb), over K producing ij(aCb), + ! accumulate to ij(ab) + ! End loop C + ! End Loop b and a + + rFinal(:,:,:,1,:) = Zero + + mVec = 0 + mVecAC = 1 + mVecCB = 1 + do iCar=1,3 + do iCent=1,2 + if (JfGrad(iCar,iCent)) then + mVec = mVec+1 + if (iCent == 1) then + mVecAC = mVecAC+1 + ipF1a = ipF1+(mVecAC-1)*nAlpha*nBasisi*nTri_Elem1(la)*(2*iAng+1) + ipF2a = ipF2 + else + ipF1a = ipF1 + mVecCB = mVecCB+1 + ipF2a = ipF2+(mVecCB-1)*nBasisi*nBeta*(2*iAng+1)*nTri_Elem1(lb) end if - end do - end do - if (iPrint >= 49) then - do iVec=1,mVec - write(u6,*) iVec,sqrt(DNrm2_(nZeta*nTri_Elem1(la)*nTri_Elem1(lb),rFinal(1,1,1,iVec),1)) - end do - end if - if (iPrint >= 99) then - write(u6,*) ' Result in PrjGrd' - do ia=1,nTri_Elem1(la) do ib=1,nTri_Elem1(lb) - do iVec=1,mVec - write(Label,'(A,I2,A,I2,A)') ' rFinal(',ia,',',ib,')' - call RecPrt(Label,' ',rFinal(1,ia,ib,iVec),nAlpha,nBeta) + do ia=1,nTri_Elem1(la) + + do iC=1,(2*iAng+1) + iaC = (iC-1)*nTri_Elem1(la)+ia + ipaC = (iaC-1)*nAlpha*nBasisi+ipF1a + iCb = (ib-1)*(2*iAng+1)+iC + ipCb = (iCb-1)*nBasisi*nBeta+ipF2a + + call DGEMM_('N','N',nAlpha,nBeta,nBasisi,Fact,Array(ipaC),nAlpha,Array(ipCb),nBasisi,One, & + rFinal(:,ia,ib,1,mVec),nAlpha) + + end do end do end do + + end if + end do + end do + + if (iPrint >= 49) then + do iVec=1,mVec + write(u6,*) iVec,sqrt(DNrm2_(nZeta*nTri_Elem1(la)*nTri_Elem1(lb),rFinal(:,:,:,1,iVec),1)) + end do + end if + if (iPrint >= 99) then + write(u6,*) ' Result in PrjGrd' + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb) + do iVec=1,mVec + write(Label,'(A,I2,A,I2,A)') ' rFinal(',ia,',',ib,')' + call RecPrt(Label,' ',rFinal(:,ia,ib,1,iVec),nAlpha,nBeta) + end do end do - end if + end do + end if - ! Distribute contributions to the gradient + ! Distribute contributions to the gradient - call Distg1X(rFinal,DAO,nZeta,nDAO,mVec,Grad,nGrad,JfGrad,JndGrd,iuvwx,lOp) + call Distg1X(rFinal,DAO,nZeta,nDAO,mVec,Grad,nGrad,JfGrad,JndGrd,iuvwx,lOp) - end do end do end do - end if - kdc = kdc+dbsc(kCnttp)%nCntr + end do end do return diff -Nru openmolcas-22.02/src/alaska_util/prjmmg.F90 openmolcas-22.10/src/alaska_util/prjmmg.F90 --- openmolcas-22.02/src/alaska_util/prjmmg.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/prjmmg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -33,7 +33,6 @@ use Definitions, only: iwp implicit none -#define _USE_WP_ #include "mem_interface.fh" integer(kind=iwp) :: iAng, iCnttp, ip, iShll, nac, nBasisi, ncb, nExpi, nOrder diff -Nru openmolcas-22.02/src/alaska_util/psoao1.F90 openmolcas-22.10/src/alaska_util/psoao1.F90 --- openmolcas-22.02/src/alaska_util/psoao1.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/psoao1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -168,7 +168,7 @@ end if cycle end if - ! Subtract one additional word for getmem's internal error check (?) + ! Subtract one additional word (?) Mem0 = Mem0-Mem1-1 ! *** Work2 and Work4 *** @@ -230,7 +230,7 @@ end if cycle end if - ! Subtract one additional word for getmem's internal error check (?) + ! Subtract one additional word (?) Mem0 = Mem0-Mem2-1 ! *** Work3 and Work5 *** @@ -301,7 +301,7 @@ exit end if end do -! Subtract one additional word for getmem's internal error check (?) +! Subtract one additional word (?) Mem0 = Mem0-Mem3-1 MinXtr = min(MinXtr,Mem0) diff -Nru openmolcas-22.02/src/alaska_util/rfgrd.F90 openmolcas-22.10/src/alaska_util/rfgrd.F90 --- openmolcas-22.02/src/alaska_util/rfgrd.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/rfgrd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -25,15 +25,16 @@ ! November '90 * ! Modified to multipole moments November '90 * ! * -! Roland Lindh, Dept. of Theoratical Chemistry, University * +! Roland Lindh, Dept. of Theoretical Chemistry, University * ! of Lund, SWEDEN. * ! Modified to reaction field calculations July '92 * ! Modified to gradient calculations May '95 * !*********************************************************************** -use Her_RW, only: iHerR, iHerW, HerR, HerW +use Her_RW, only: HerR, HerW, iHerR, iHerW use PCM_arrays, only: MM use Center_Info, only: dc +use Index_Functions, only: nTri_Elem1 use Constants, only: Half use Definitions, only: wp, iwp, u6 @@ -46,15 +47,13 @@ #include "macros.fh" unused_var(ZInv) -unused_var(lOper) unused_var(iStabM) +unused_var(nStabM) iRout = 122 iPrint = nPrint(iRout) !iPrint = 99 -ABeq(1) = A(1) == RB(1) -ABeq(2) = A(2) == RB(2) -ABeq(3) = A(3) == RB(3) +ABeq(:) = A == RB nip = 1 ipAxyz = nip @@ -102,9 +101,7 @@ ! Compute the contribution from the multipole moment operator -ABeq(1) = .false. -ABeq(2) = .false. -ABeq(3) = .false. +ABeq(:) = .false. call vCrtCmp(Array(ipTemp1),P,nZeta,Ccoor,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) ! Compute the cartesian components for the multipole moment diff -Nru openmolcas-22.02/src/alaska_util/rfmmg.F90 openmolcas-22.10/src/alaska_util/rfmmg.F90 --- openmolcas-22.02/src/alaska_util/rfmmg.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/rfmmg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -17,7 +17,6 @@ use Definitions, only: iwp implicit none -#define _USE_WP_ #include "mem_interface.fh" nHer = (la+lb+lr+1+2)/2 diff -Nru openmolcas-22.02/src/alaska_util/screen_g.F90 openmolcas-22.10/src/alaska_util/screen_g.F90 --- openmolcas-22.02/src/alaska_util/screen_g.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/screen_g.F90 2022-10-10 14:22:40.000000000 +0000 @@ -18,7 +18,7 @@ ! * ! Object: to prescreen the integral derivatives. * ! * -! nZeta, nEta : unpartioned length of primitives. * +! nZeta, nEta : unpartitioned length of primitives. * ! * ! mZeta, mEta : section length due to partioning. These are usually * ! equal to nZeta and nEta. * diff -Nru openmolcas-22.02/src/alaska_util/srogrd.F90 openmolcas-22.10/src/alaska_util/srogrd.F90 --- openmolcas-22.02/src/alaska_util/srogrd.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/srogrd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -20,29 +20,6 @@ ! * ! Object: kernel routine for the computation of MP integrals. * ! * -! Alpha : exponents of bra gaussians * -! nAlpha: number of primitives (exponents) of bra gaussians * -! Beta : as Alpha but for ket gaussians * -! nBeta : as nAlpha but for the ket gaussians * -! Zeta : sum of exponents (nAlpha x nBeta) * -! ZInv : inverse of Zeta * -! rKappa: gaussian prefactor for the products of bra and ket * -! gaussians. * -! P : center of new gaussian from the products of bra and ket * -! gaussians. * -! rFinal: array for computed integrals * -! nZeta : nAlpha x nBeta * -! nComp : number of components in the operator (e.g. dipol moment * -! operator has three components) * -! la : total angular momentum of bra gaussian * -! lb : total angular momentum of ket gaussian * -! A : center of bra gaussian * -! B : center of ket gaussian * -! Array : Auxiliary memory as requested by ECPMem * -! nArr : length of Array * -! Ccoor : coordinates of the operator, zero for symmetric oper. * -! NOrdOp: Order of the operator * -! * ! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * ! of Lund, Sweden, and Luis Seijo, Dept. of Applied Phys- * ! ical Chemistry, the Free University of Madrid, Spain, * @@ -53,7 +30,7 @@ use Basis_Info, only: dbsc, nCnttp, Shells use Center_Info, only: dc -use Her_RW, only: iHerR, iHerW, HerR, HerW +use Her_RW, only: HerR, HerW, iHerR, iHerW use Real_Spherical, only: ipSph, RSph use Symmetry_Info, only: iOper use Index_Functions, only: nTri_Elem1 @@ -65,7 +42,7 @@ integer(kind=iwp) :: i, ia, iaC, iAng, ib, iC, iCar, iCb, iCent, iCmp, iDCRT(0:7), iGamma, iIrrep, ip, ipA, ipaC, ipAxyz, ipB, & ipBxyz, ipC, ipCb, ipCxyz, ipF1, ipF1a, ipF2, ipF2a, ipK1, ipK2, ipP1, ipP2, ipQ1, iPrint, ipRxyz, ipTmp, & ipZ1, ipZ2, ipZI1, ipZI2, iRout, iShll, iStrt, iuvwx(4), iVec, j, JndGrd(3,4), kCnt, kCnttp, kdc, ld, lDCRT, & - LmbdT, lOp(4), mGrad, mVec, mVecAC, mVecCB, nac, ncb, nDAO, nDCRT, nDisp, nExpi, nVecAC, nVecCB + LmbdT, lOp(4), mGrad, mVec, mVecAC, mVecCB, nac, ncb, nDAO, nDCRT, nDisp, nExpi, n_Her, nVecAC, nVecCB real(kind=wp) :: C(3), Fact, TC(3) character(len=80) :: Label logical(kind=iwp) :: ABeq(3), EQ, JfGrad(3,4) @@ -79,7 +56,7 @@ unused_var(Zeta) unused_var(ZInv) unused_var(rKappa) -unused_var(lOper) +unused_var(nHer) iRout = 191 iPrint = nPrint(iRout) @@ -101,353 +78,353 @@ kdc = 0 do kCnttp=1,nCnttp - if (dbsc(kCnttp)%ECP .and. (dbsc(kCnttp)%nSRO > 0)) then - do kCnt=1,dbsc(kCnttp)%nCntr - C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) - - call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) - Fact = real(nStabM,kind=wp)/real(LmbdT,kind=wp) - - iuvwx(3) = dc(kdc+kCnt)%nStab - iuvwx(4) = dc(kdc+kCnt)%nStab - JndGrd(:,1:2) = IndGrd(:,:) - do i=1,3 - do j=1,2 - JfGrad(i,j) = IfGrad(i,j) - end do + if (kCnttp > 1) kdc = kdc+dbsc(kCnttp-1)%nCntr + if (.not. dbsc(kCnttp)%ECP) cycle + if (dbsc(kCnttp)%nSRO <= 0) cycle + do kCnt=1,dbsc(kCnttp)%nCntr + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + + call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) + Fact = real(nStabM,kind=wp)/real(LmbdT,kind=wp) + + iuvwx(3) = dc(kdc+kCnt)%nStab + iuvwx(4) = dc(kdc+kCnt)%nStab + JndGrd(:,1:2) = IndGrd(:,:) + do i=1,3 + do j=1,2 + JfGrad(i,j) = IfGrad(i,j) end do + end do - nDisp = IndDsp(kdc+kCnt,iIrrep) - do iCar=0,2 - JfGrad(iCar+1,3) = .false. - iCmp = 2**iCar - if (TF(kdc+kCnt,iIrrep,iCmp) .and. (.not. dbsc(kCnttp)%pChrg)) then - nDisp = nDisp+1 - if (Direct(nDisp)) then - JndGrd(iCar+1,1) = abs(JndGrd(iCar+1,1)) - JndGrd(iCar+1,2) = abs(JndGrd(iCar+1,2)) - JndGrd(iCar+1,3) = -nDisp - JfGrad(iCar+1,1) = .true. - JfGrad(iCar+1,2) = .true. - else - JndGrd(iCar+1,3) = 0 - end if + nDisp = IndDsp(kdc+kCnt,iIrrep) + do iCar=0,2 + JfGrad(iCar+1,3) = .false. + iCmp = 2**iCar + if (TF(kdc+kCnt,iIrrep,iCmp) .and. (.not. dbsc(kCnttp)%pChrg)) then + nDisp = nDisp+1 + if (Direct(nDisp)) then + JndGrd(iCar+1,1) = abs(JndGrd(iCar+1,1)) + JndGrd(iCar+1,2) = abs(JndGrd(iCar+1,2)) + JndGrd(iCar+1,3) = -nDisp + JfGrad(iCar+1,1) = .true. + JfGrad(iCar+1,2) = .true. else JndGrd(iCar+1,3) = 0 end if + else + JndGrd(iCar+1,3) = 0 + end if + end do + JndGrd(:,4) = 0 + JfGrad(1,4) = .false. + JfGrad(2,4) = .false. + JfGrad(3,4) = .false. + mGrad = 0 + do iCar=1,3 + do i=1,2 + if (JfGrad(iCar,i)) mGrad = mGrad+1 end do - JndGrd(:,4) = 0 - JfGrad(1,4) = .false. - JfGrad(2,4) = .false. - JfGrad(3,4) = .false. - mGrad = 0 - do iCar=1,3 - do i=1,2 - if (JfGrad(iCar,i)) mGrad = mGrad+1 + end do + if (mGrad == 0) cycle + + do lDCRT=0,nDCRT-1 + lOp(3) = iDCRT(lDCRT) + lOp(4) = lOp(3) + call OA(iDCRT(lDCRT),C,TC) + if (EQ(A,RB) .and. EQ(A,TC)) cycle + do iAng=0,dbsc(kCnttp)%nSRO-1 + iShll = dbsc(kCnttp)%iSRO+iAng + nExpi = Shells(iShll)%nExp + if (nExpi == 0) cycle + + ip = 1 + ipC = ip + ip = ip+nExpi**2 + + if (iPrint >= 49) call RecPrt(' The Akl matrix',' ',Shells(iShll)%Akl(1,1,1),nExpi,nExpi) + call dcopy_(nExpi**2,Shells(iShll)%Akl(1,1,1),1,Array(ipC),1) + if (EQ(A,RB) .and. EQ(A,TC) .and. dbsc(kCnttp)%NoPair) then + call DaXpY_(nExpi**2,One,Shells(iShll)%Akl(1,1,2),1,Array(ipC),1) + if (iPrint >= 49) call RecPrt(' The Adl matrix',' ',Shells(iShll)%Akl(1,1,2),nExpi,nExpi) + end if + + ipF1 = ip + nac = nTri_Elem1(la)*nTri_Elem1(iAng)*4 + ip = ip+nAlpha*nExpi*nac + ipP1 = ip + ip = ip+3*nAlpha*nExpi + ipZ1 = ip + ip = ip+nAlpha*nExpi + ipK1 = ip + ip = ip+nAlpha*nExpi + ipZI1 = ip + ip = ip+nAlpha*nExpi + if (ip-1 > nArr*nZeta) then + write(u6,*) ' ip-1 > nArr*nZeta(1) in SROGrd' + write(u6,*) ' nArr, nZeta=',nArr,nZeta + write(u6,*) ' nac, nAlpha=',nac,nAlpha + write(u6,*) ' nExpi=',nExpi + call Abend() + end if + + ! Calculate Effective center and exponent for + + call ZXia(Array(ipZ1),Array(ipZI1),nAlpha,nExpi,Alpha,Shells(iShll)%Exp) + call SetUp1(Alpha,nAlpha,Shells(iShll)%Exp,nExpi,A,TC,Array(ipK1),Array(ipP1),Array(ipZI1)) + + ! Calculate Overlap and derivative + + n_Her = ((la+1)+iAng+2)/2 + ipAxyz = ip + ip = ip+nAlpha*nExpi*3*n_Her*(la+2) + ipCxyz = ip + ip = ip+nAlpha*nExpi*3*n_Her*(iAng+1) + ipRxyz = ip + ip = ip+nAlpha*nExpi*3*n_Her*(nOrdOp+1) + ipQ1 = ip + ip = ip+nAlpha*nExpi*3*(la+2)*(iAng+1)*(nOrdOp+1) + ipA = ip + ip = ip+nAlpha*nExpi + if (ip-1 > nArr*nZeta) then + write(u6,*) ' ip-1 > nArr*nZeta(1b) in SROGrd' + call Abend() + end if + ABeq(1) = A(1) == TC(1) + ABeq(2) = A(2) == TC(2) + ABeq(3) = A(3) == TC(3) + call CrtCmp(Array(ipZ1),Array(ipP1),nAlpha*nExpi,A,Array(ipAxyz),la+1,HerR(iHerR(n_Her)),n_Her,ABeq) + call CrtCmp(Array(ipZ1),Array(ipP1),nAlpha*nExpi,TC,Array(ipCxyz),iAng,HerR(iHerR(n_Her)),n_Her,ABeq) + ABeq(1) = .false. + ABeq(2) = .false. + ABeq(3) = .false. + call CrtCmp(Array(ipZ1),Array(ipP1),nAlpha*nExpi,Ccoor,Array(ipRxyz),nOrdOp,HerR(iHerR(n_Her)),n_Her,ABeq) + if (iPrint >= 49) then + write(u6,*) ' Array(ipAxyz)=',DNrm2_(nAlpha*nExpi*3*n_Her*(la+2),Array(ipAxyz),1) + write(u6,*) ' Array(ipCxyz)=',DNrm2_(nAlpha*nExpi*3*n_Her*(iAng+1),Array(ipCxyz),1) + write(u6,*) ' Array(ipRxyz)=',DNrm2_(nAlpha*nExpi*3*n_Her*(nOrdOp+1),Array(ipRxyz),1) + end if + call Assmbl(Array(ipQ1),Array(ipAxyz),la+1,Array(ipRxyz),nOrdOp,Array(ipCxyz),iAng,nAlpha*nExpi,HerW(iHerW(n_Her)),n_Her) + iStrt = ipA + do iGamma=1,nExpi + call dcopy_(nAlpha,Alpha,1,Array(iStrt),1) + iStrt = iStrt+nAlpha end do - end do - if (mGrad == 0) cycle + if (iPrint >= 49) then + write(u6,*) ' Array(ipA)=',DNrm2_(nAlpha*nExpi,Array(ipA),1) + end if + call rKappa_Zeta(Array(ipK1),Array(ipZ1),nExpi*nAlpha) + ld = 1 + call CmbnAC(Array(ipQ1),nAlpha*nExpi,la,iAng,Array(ipK1),Array(ipF1),Array(ipA),JfGrad(1,1),ld,nVecAC) + if (iPrint >= 49) then + write(u6,*) ' Array(ipQ1)=',DNrm2_(nAlpha*nExpi*3*(la+2)*(iAng+1)*(nOrdOp+1),Array(ipQ1),1) + write(u6,*) ' Array(ipA)=',DNrm2_(nAlpha*nExpi,Array(ipA),1) + end if + ip = ip-nAlpha*nExpi*(6+3*n_Her*(la+2)+3*n_Her*(iAng+1)+3*n_Her*(nOrdOp+1)+3*(la+2)*(iAng+1)*(nOrdOp+1)+1) - do lDCRT=0,nDCRT-1 - lOp(3) = iDCRT(lDCRT) - lOp(4) = lOp(3) - call OA(iDCRT(lDCRT),C,TC) - if (EQ(A,RB) .and. EQ(A,TC)) cycle - do iAng=0,dbsc(kCnttp)%nSRO-1 - iShll = dbsc(kCnttp)%iSRO+iAng - nExpi = Shells(iShll)%nExp - if (nExpi == 0) cycle - - ip = 1 - ipC = ip - ip = ip+nExpi**2 - - if (iPrint >= 49) call RecPrt(' The Akl matrix',' ',Shells(iShll)%Akl(1,1,1),nExpi,nExpi) - call dcopy_(nExpi**2,Shells(iShll)%Akl(1,1,1),1,Array(ipC),1) - if (EQ(A,RB) .and. EQ(A,TC) .and. dbsc(kCnttp)%NoPair) then - call DaXpY_(nExpi**2,One,Shells(iShll)%Akl(1,1,2),1,Array(ipC),1) - if (iPrint >= 49) call RecPrt(' The Adl matrix',' ',Shells(iShll)%Akl(1,1,2),nExpi,nExpi) - end if - - ipF1 = ip - nac = nTri_Elem1(la)*nTri_Elem1(iAng)*4 - ip = ip+nAlpha*nExpi*nac - ipP1 = ip - ip = ip+3*nAlpha*nExpi - ipZ1 = ip - ip = ip+nAlpha*nExpi - ipK1 = ip - ip = ip+nAlpha*nExpi - ipZI1 = ip - ip = ip+nAlpha*nExpi - if (ip-1 > nArr*nZeta) then - write(u6,*) ' ip-1 > nArr*nZeta(1) in SROGrd' - write(u6,*) ' nArr, nZeta=',nArr,nZeta - write(u6,*) ' nac, nAlpha=',nac,nAlpha - write(u6,*) ' nExpi=',nExpi - call Abend() - end if - - ! Calculate Effective center and exponent for - - call ZXia(Array(ipZ1),Array(ipZI1),nAlpha,nExpi,Alpha,Shells(iShll)%Exp) - call SetUp1(Alpha,nAlpha,Shells(iShll)%Exp,nExpi,A,TC,Array(ipK1),Array(ipP1),Array(ipZI1)) - - ! Calculate Overlap and derivative - - nHer = ((la+1)+iAng+2)/2 - ipAxyz = ip - ip = ip+nAlpha*nExpi*3*nHer*(la+2) - ipCxyz = ip - ip = ip+nAlpha*nExpi*3*nHer*(iAng+1) - ipRxyz = ip - ip = ip+nAlpha*nExpi*3*nHer*(nOrdOp+1) - ipQ1 = ip - ip = ip+nAlpha*nExpi*3*(la+2)*(iAng+1)*(nOrdOp+1) - ipA = ip - ip = ip+nAlpha*nExpi - if (ip-1 > nArr*nZeta) then - write(u6,*) ' ip-1 > nArr*nZeta(1b) in PrjGrd' - call Abend() - end if - ABeq(1) = A(1) == TC(1) - ABeq(2) = A(2) == TC(2) - ABeq(3) = A(3) == TC(3) - call CrtCmp(Array(ipZ1),Array(ipP1),nAlpha*nExpi,A,Array(ipAxyz),la+1,HerR(iHerR(nHer)),nHer,ABeq) - call CrtCmp(Array(ipZ1),Array(ipP1),nAlpha*nExpi,TC,Array(ipCxyz),iAng,HerR(iHerR(nHer)),nHer,ABeq) - ABeq(1) = .false. - ABeq(2) = .false. - ABeq(3) = .false. - call CrtCmp(Array(ipZ1),Array(ipP1),nAlpha*nExpi,Ccoor,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) - if (iPrint >= 49) then - write(u6,*) ' Array(ipAxyz)=',DNrm2_(nAlpha*nExpi*3*nHer*(la+2),Array(ipAxyz),1) - write(u6,*) ' Array(ipCxyz)=',DNrm2_(nAlpha*nExpi*3*nHer*(iAng+1),Array(ipCxyz),1) - write(u6,*) ' Array(ipRxyz)=',DNrm2_(nAlpha*nExpi*3*nHer*(nOrdOp+1),Array(ipRxyz),1) - end if - call Assmbl(Array(ipQ1),Array(ipAxyz),la+1,Array(ipRxyz),nOrdOp,Array(ipCxyz),iAng,nAlpha*nExpi,HerW(iHerW(nHer)),nHer) - iStrt = ipA - do iGamma=1,nExpi - call dcopy_(nAlpha,Alpha,1,Array(iStrt),1) - iStrt = iStrt+nAlpha - end do - if (iPrint >= 49) then - write(u6,*) ' Array(ipA)=',DNrm2_(nAlpha*nExpi,Array(ipA),1) - end if - call rKappa_Zeta(Array(ipK1),Array(ipZ1),nExpi*nAlpha) - ld = 1 - call CmbnAC(Array(ipQ1),nAlpha*nExpi,la,iAng,Array(ipK1),Array(ipF1),Array(ipA),JfGrad(1,1),ld,nVecAC) - if (iPrint >= 49) then - write(u6,*) ' Array(ipQ1)=',DNrm2_(nAlpha*nExpi*3*(la+2)*(iAng+1)*(nOrdOp+1),Array(ipQ1),1) - write(u6,*) ' Array(ipA)=',DNrm2_(nAlpha*nExpi,Array(ipA),1) - end if - ip = ip-nAlpha*nExpi*(6+3*nHer*(la+2)+3*nHer*(iAng+1)+3*nHer*(nOrdOp+1)+3*(la+2)*(iAng+1)*(nOrdOp+1)+1) - - ipF2 = ip - ncb = nTri_Elem1(iAng)*nTri_Elem1(lb)*4 - ip = ip+nExpi*nBeta*ncb - ipP2 = ip - ip = ip+3*nExpi*nBeta - ipZ2 = ip - ip = ip+nExpi*nBeta - ipK2 = ip - ip = ip+nExpi*nBeta - ipZI2 = ip - ip = ip+nExpi*nBeta - if (ip-1 > nArr*nZeta) then - write(u6,*) ' ip-1 > nArr*nZeta(2) in SROGrd' - call Abend() - end if - - ! Calculate Effective center and exponent for - - call ZXia(Array(ipZ2),Array(ipZI2),nExpi,nBeta,Shells(iShll)%Exp,Beta) - call SetUp1(Shells(iShll)%Exp,nExpi,Beta,nBeta,TC,RB,Array(ipK2),Array(ipP2),Array(ipZI2)) - - ! Calculate Overlap and - - nHer = ((iAng+1)+lb+2)/2 - ipCxyz = ip - ip = ip+nBeta*nExpi*3*nHer*(iAng+1) - ipBxyz = ip - ip = ip+nBeta*nExpi*3*nHer*(lb+2) - ipRxyz = ip - ip = ip+nBeta*nExpi*3*nHer*(nOrdOp+1) - ipQ1 = ip - ip = ip+nBeta*nExpi*3*(iAng+1)*(lb+2)*(nOrdOp+1) - ipB = ip - ip = ip+nBeta*nExpi - if (ip-1 > nArr*nZeta) then - write(u6,*) ' ip-1 > nArr*nZeta(2b) in PrjGrd' - call Abend() - end if - ABeq(1) = TC(1) == RB(1) - ABeq(2) = TC(2) == RB(2) - ABeq(3) = TC(3) == RB(3) - call CrtCmp(Array(ipZ2),Array(ipP2),nExpi*nBeta,TC,Array(ipCxyz),iAng,HerR(iHerR(nHer)),nHer,ABeq) - call CrtCmp(Array(ipZ2),Array(ipP2),nExpi*nBeta,RB,Array(ipBxyz),lb+1,HerR(iHerR(nHer)),nHer,ABeq) - ABeq(1) = .false. - ABeq(2) = .false. - ABeq(3) = .false. - call CrtCmp(Array(ipZ2),Array(ipP2),nExpi*nBeta,Ccoor,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) - if (iPrint >= 49) then - write(u6,*) ' Array(ipCxyz)=',DNrm2_(nBeta*nExpi*3*nHer*(iAng+1),Array(ipCxyz),1) - write(u6,*) ' Array(ipBxyz)=',DNrm2_(nBeta*nExpi*3*nHer*(lb+2),Array(ipBxyz),1) - write(u6,*) ' Array(ipRxyz)=',DNrm2_(nBeta*nExpi*3*nHer*(nOrdOp+1),Array(ipRxyz),1) - end if - call Assmbl(Array(ipQ1),Array(ipCxyz),iAng,Array(ipRxyz),nOrdOp,Array(ipBxyz),lb+1,nExpi*nBeta,HerW(iHerW(nHer)),nHer) - iStrt = ipB - do iGamma=1,nExpi - call dcopy_(nBeta,Beta,1,Array(iStrt),nExpi) - iStrt = iStrt+1 - end do - if (iPrint >= 49) then - write(u6,*) ' Array(ipB)=',DNrm2_(nExpi*nBeta,Array(ipB),1) - end if - call rKappa_Zeta(Array(ipK2),Array(ipZ2),nExpi*nBeta) - ld = 1 - call CmbnCB(Array(ipQ1),nExpi*nBeta,iAng,lb,Array(ipK2),Array(ipF2),Array(ipB),JfGrad(1,2),ld,nVecCB) - if (iPrint >= 49) then - write(u6,*) ' Array(ipQ1)=',DNrm2_(nExpi*nBeta*3*(la+2)*(iAng+1)*(nOrdOp+1),Array(ipQ1),1) - write(u6,*) ' Array(ipB)=',DNrm2_(nExpi*nBeta,Array(ipB),1) - end if - ip = ip-nBeta*nExpi*(6+3*nHer*(lb+2)+3*nHer*(iAng+1)+3*nHer*(nOrdOp+1)+3*(lb+2)*(iAng+1)*(nOrdOp+1)+1) - nac = nTri_Elem1(la)*nTri_Elem1(iAng)*nVecAC - ncb = nTri_Elem1(iAng)*nTri_Elem1(lb)*nVecCB - ipTmp = ip - ip = ip+max(nAlpha*nExpi*nac,nExpi*nBeta*ncb) - if (ip-1 > nArr*nZeta) then - write(u6,*) ' ip-1 > nArr*nZeta(3) in SROGrd' - call Abend() - end if - nac = nTri_Elem1(la)*nTri_Elem1(iAng) - ncb = nTri_Elem1(iAng)*nTri_Elem1(lb) - - ! Calculate Contraction over the spectral resolvent basis - ! set of the type A(l;ab) where we now have in - ! Array(ipF1) the cartesian components of , and - ! similarily, in Array(ipF2), we have stored the cartesian - ! components of . Observe that as opposed to the - ! projection operator that this contraction is done in the - ! primitive basis. - - ! From the lefthandside overlap, form ikaCx from ikacx by - ! 1) ika,cx -> cx,ika - - call DgeTMo(Array(ipF1),nAlpha*nExpi*nTri_Elem1(la),nAlpha*nExpi*nTri_Elem1(la),nTri_Elem1(iAng)*nVecAC,Array(ipTmp), & - nTri_Elem1(iAng)*nVecAC) - - ! 2) xika,C = c,xika * c,C - - call DGEMM_('T','N',nVecAC*nAlpha*nExpi*nTri_Elem1(la),(2*iAng+1),nTri_Elem1(iAng),One,Array(ipTmp),nTri_Elem1(iAng), & - RSph(ipSph(iAng)),nTri_Elem1(iAng),Zero,Array(ipF1),nVecAC*nAlpha*nExpi*nTri_Elem1(la)) - - ! 3) x,ikaC -> ikaC,x - - call DGetMo(Array(ipF1),nVecAC,nVecAC,nAlpha*nExpi*nTri_Elem1(la)*(2*iAng+1),Array(ipTmp), & - nAlpha*nExpi*nTri_Elem1(la)*(2*iAng+1)) - call dcopy_(nVecAC*nAlpha*nExpi*nTri_Elem1(la)*(2*iAng+1),Array(ipTmp),1,Array(ipF1),1) - - ! And (almost) the same thing for the righthand side, form - ! kjCbx from kjcbx - ! ) kj,cbx -> cbx,kj - - call DgeTMo(Array(ipF2),nBeta*nExpi,nBeta*nExpi,ncb*nVecCB,Array(ipTmp),ncb*nVecCB) - - ! 2) bxkj,C = c,bxkj * c,C - - call DGEMM_('T','N',nTri_Elem1(lb)*nVecCB*nExpi*nBeta,(2*iAng+1),nTri_Elem1(iAng),One,Array(ipTmp),nTri_Elem1(iAng), & - RSph(ipSph(iAng)),nTri_Elem1(iAng),Zero,Array(ipF2),nTri_Elem1(lb)*nVecCB*nExpi*nBeta) - - ! 3) bx,kjC -> kjC,bx - - call DgeTMo(Array(ipF2),nTri_Elem1(lb)*nVecCB,nTri_Elem1(lb)*nVecCB,nExpi*nBeta*(2*iAng+1),Array(ipTmp), & - nExpi*nBeta*(2*iAng+1)) - call dcopy_(nExpi*nBeta*(2*iAng+1)*nTri_Elem1(lb)*nVecCB,Array(ipTmp),1,Array(ipF2),1) - - ! Next Contract (ikaC)*(klC)*(ljCb) over k,l and C, - ! producing ijab, - ! by the following procedure: - ! Loop over a and b - ! Loop over C - ! Contract ik(aC)*kl(C), over k producing il(aC), - ! Contract il(aC)*lj(Cb), over l producing ij(aCb) - ! accumulate to ij(ab) - ! End loop C - ! End Loop b and a - - rFinal(:,:,:,:) = Zero - - mVec = 0 - mVecAC = 1 - mVecCB = 1 - do iCar=1,3 - do iCent=1,2 - if (JfGrad(iCar,iCent)) then - mVec = mVec+1 - if (iCent == 1) then - mVecAC = mVecAC+1 - ipF1a = ipF1+(mVecAC-1)*nAlpha*nExpi*nTri_Elem1(la)*(2*iAng+1) - ipF2a = ipF2 - else - ipF1a = ipF1 - mVecCB = mVecCB+1 - ipF2a = ipF2+(mVecCB-1)*nExpi*nBeta*(2*iAng+1)*nTri_Elem1(lb) - end if - - do ib=1,nTri_Elem1(lb) - do ia=1,nTri_Elem1(la) - if (iPrint >= 99) write(u6,*) ' ia,ib=',ia,ib - - do iC=1,(2*iAng+1) - if (iPrint >= 99) write(u6,*) ' iC,=',iC - iaC = (iC-1)*nTri_Elem1(la)+ia - ipaC = (iaC-1)*nAlpha*nExpi+ipF1a - iCb = (ib-1)*(2*iAng+1)+iC - ipCb = (iCb-1)*nExpi*nBeta+ipF2a - - if (iPrint >= 99) then - call RecPrt('',' ',Array(ipaC),nAlpha,nExpi) - call RecPrt('',' ',Array(ipCb),nExpi,nBeta) - end if - - call DGEMM_('N','N',nAlpha,nExpi,nExpi,One,Array(ipaC),nAlpha,Array(ipC),nExpi,Zero,Array(ipTmp),nAlpha) - call DGEMM_('N','N',nAlpha,nBeta,nExpi,Fact,Array(ipTmp),nAlpha,Array(ipCb),nExpi,One,rFinal(1,ia,ib,mVec), & - nAlpha) + ipF2 = ip + ncb = nTri_Elem1(iAng)*nTri_Elem1(lb)*4 + ip = ip+nExpi*nBeta*ncb + ipP2 = ip + ip = ip+3*nExpi*nBeta + ipZ2 = ip + ip = ip+nExpi*nBeta + ipK2 = ip + ip = ip+nExpi*nBeta + ipZI2 = ip + ip = ip+nExpi*nBeta + if (ip-1 > nArr*nZeta) then + write(u6,*) ' ip-1 > nArr*nZeta(2) in SROGrd' + call Abend() + end if - end do - end do - end do + ! Calculate Effective center and exponent for + + call ZXia(Array(ipZ2),Array(ipZI2),nExpi,nBeta,Shells(iShll)%Exp,Beta) + call SetUp1(Shells(iShll)%Exp,nExpi,Beta,nBeta,TC,RB,Array(ipK2),Array(ipP2),Array(ipZI2)) + ! Calculate Overlap and + + n_Her = ((iAng+1)+lb+2)/2 + ipCxyz = ip + ip = ip+nBeta*nExpi*3*n_Her*(iAng+1) + ipBxyz = ip + ip = ip+nBeta*nExpi*3*n_Her*(lb+2) + ipRxyz = ip + ip = ip+nBeta*nExpi*3*n_Her*(nOrdOp+1) + ipQ1 = ip + ip = ip+nBeta*nExpi*3*(iAng+1)*(lb+2)*(nOrdOp+1) + ipB = ip + ip = ip+nBeta*nExpi + if (ip-1 > nArr*nZeta) then + write(u6,*) ' ip-1 > nArr*nZeta(2b) in SROGrd' + call Abend() + end if + ABeq(1) = TC(1) == RB(1) + ABeq(2) = TC(2) == RB(2) + ABeq(3) = TC(3) == RB(3) + call CrtCmp(Array(ipZ2),Array(ipP2),nExpi*nBeta,TC,Array(ipCxyz),iAng,HerR(iHerR(n_Her)),n_Her,ABeq) + call CrtCmp(Array(ipZ2),Array(ipP2),nExpi*nBeta,RB,Array(ipBxyz),lb+1,HerR(iHerR(n_Her)),n_Her,ABeq) + ABeq(1) = .false. + ABeq(2) = .false. + ABeq(3) = .false. + call CrtCmp(Array(ipZ2),Array(ipP2),nExpi*nBeta,Ccoor,Array(ipRxyz),nOrdOp,HerR(iHerR(n_Her)),n_Her,ABeq) + if (iPrint >= 49) then + write(u6,*) ' Array(ipCxyz)=',DNrm2_(nBeta*nExpi*3*n_Her*(iAng+1),Array(ipCxyz),1) + write(u6,*) ' Array(ipBxyz)=',DNrm2_(nBeta*nExpi*3*n_Her*(lb+2),Array(ipBxyz),1) + write(u6,*) ' Array(ipRxyz)=',DNrm2_(nBeta*nExpi*3*n_Her*(nOrdOp+1),Array(ipRxyz),1) + end if + call Assmbl(Array(ipQ1),Array(ipCxyz),iAng,Array(ipRxyz),nOrdOp,Array(ipBxyz),lb+1,nExpi*nBeta,HerW(iHerW(n_Her)),n_Her) + iStrt = ipB + do iGamma=1,nExpi + call dcopy_(nBeta,Beta,1,Array(iStrt),nExpi) + iStrt = iStrt+1 + end do + if (iPrint >= 49) then + write(u6,*) ' Array(ipB)=',DNrm2_(nExpi*nBeta,Array(ipB),1) + end if + call rKappa_Zeta(Array(ipK2),Array(ipZ2),nExpi*nBeta) + ld = 1 + call CmbnCB(Array(ipQ1),nExpi*nBeta,iAng,lb,Array(ipK2),Array(ipF2),Array(ipB),JfGrad(1,2),ld,nVecCB) + if (iPrint >= 49) then + write(u6,*) ' Array(ipQ1)=',DNrm2_(nExpi*nBeta*3*(la+2)*(iAng+1)*(nOrdOp+1),Array(ipQ1),1) + write(u6,*) ' Array(ipB)=',DNrm2_(nExpi*nBeta,Array(ipB),1) + end if + ip = ip-nBeta*nExpi*(6+3*n_Her*(lb+2)+3*n_Her*(iAng+1)+3*n_Her*(nOrdOp+1)+3*(lb+2)*(iAng+1)*(nOrdOp+1)+1) + nac = nTri_Elem1(la)*nTri_Elem1(iAng)*nVecAC + ncb = nTri_Elem1(iAng)*nTri_Elem1(lb)*nVecCB + ipTmp = ip + ip = ip+max(nAlpha*nExpi*nac,nExpi*nBeta*ncb) + if (ip-1 > nArr*nZeta) then + write(u6,*) ' ip-1 > nArr*nZeta(3) in SROGrd' + call Abend() + end if + nac = nTri_Elem1(la)*nTri_Elem1(iAng) + ncb = nTri_Elem1(iAng)*nTri_Elem1(lb) + + ! Calculate Contraction over the spectral resolvent basis + ! set of the type A(l;ab) where we now have in + ! Array(ipF1) the cartesian components of , and + ! similarily, in Array(ipF2), we have stored the cartesian + ! components of . Observe that as opposed to the + ! projection operator that this contraction is done in the + ! primitive basis. + + ! From the lefthandside overlap, form ikaCx from ikacx by + ! 1) ika,cx -> cx,ika + + call DgeTMo(Array(ipF1),nAlpha*nExpi*nTri_Elem1(la),nAlpha*nExpi*nTri_Elem1(la),nTri_Elem1(iAng)*nVecAC,Array(ipTmp), & + nTri_Elem1(iAng)*nVecAC) + + ! 2) xika,C = c,xika * c,C + + call DGEMM_('T','N',nVecAC*nAlpha*nExpi*nTri_Elem1(la),(2*iAng+1),nTri_Elem1(iAng),One,Array(ipTmp),nTri_Elem1(iAng), & + RSph(ipSph(iAng)),nTri_Elem1(iAng),Zero,Array(ipF1),nVecAC*nAlpha*nExpi*nTri_Elem1(la)) + + ! 3) x,ikaC -> ikaC,x + + call DGetMo(Array(ipF1),nVecAC,nVecAC,nAlpha*nExpi*nTri_Elem1(la)*(2*iAng+1),Array(ipTmp), & + nAlpha*nExpi*nTri_Elem1(la)*(2*iAng+1)) + call dcopy_(nVecAC*nAlpha*nExpi*nTri_Elem1(la)*(2*iAng+1),Array(ipTmp),1,Array(ipF1),1) + + ! And (almost) the same thing for the righthand side, form + ! kjCbx from kjcbx + ! ) kj,cbx -> cbx,kj + + call DgeTMo(Array(ipF2),nBeta*nExpi,nBeta*nExpi,ncb*nVecCB,Array(ipTmp),ncb*nVecCB) + + ! 2) bxkj,C = c,bxkj * c,C + + call DGEMM_('T','N',nTri_Elem1(lb)*nVecCB*nExpi*nBeta,(2*iAng+1),nTri_Elem1(iAng),One,Array(ipTmp),nTri_Elem1(iAng), & + RSph(ipSph(iAng)),nTri_Elem1(iAng),Zero,Array(ipF2),nTri_Elem1(lb)*nVecCB*nExpi*nBeta) + + ! 3) bx,kjC -> kjC,bx + + call DgeTMo(Array(ipF2),nTri_Elem1(lb)*nVecCB,nTri_Elem1(lb)*nVecCB,nExpi*nBeta*(2*iAng+1),Array(ipTmp), & + nExpi*nBeta*(2*iAng+1)) + call dcopy_(nExpi*nBeta*(2*iAng+1)*nTri_Elem1(lb)*nVecCB,Array(ipTmp),1,Array(ipF2),1) + + ! Next Contract (ikaC)*(klC)*(ljCb) over k,l and C, + ! producing ijab, + ! by the following procedure: + ! Loop over a and b + ! Loop over C + ! Contract ik(aC)*kl(C), over k producing il(aC), + ! Contract il(aC)*lj(Cb), over l producing ij(aCb) + ! accumulate to ij(ab) + ! End loop C + ! End Loop b and a + + rFinal(:,:,:,1,:) = Zero + + mVec = 0 + mVecAC = 1 + mVecCB = 1 + do iCar=1,3 + do iCent=1,2 + if (JfGrad(iCar,iCent)) then + mVec = mVec+1 + if (iCent == 1) then + mVecAC = mVecAC+1 + ipF1a = ipF1+(mVecAC-1)*nAlpha*nExpi*nTri_Elem1(la)*(2*iAng+1) + ipF2a = ipF2 + else + ipF1a = ipF1 + mVecCB = mVecCB+1 + ipF2a = ipF2+(mVecCB-1)*nExpi*nBeta*(2*iAng+1)*nTri_Elem1(lb) end if - end do - end do - if (iPrint >= 49) then - do iVec=1,mVec - write(u6,*) iVec,sqrt(DNrm2_(nZeta*nTri_Elem1(la)*nTri_Elem1(lb),rFinal(1,1,1,iVec),1)) - end do - end if - if (iPrint >= 99) then - write(u6,*) ' Result in PrjGrd' - do ia=1,nTri_Elem1(la) do ib=1,nTri_Elem1(lb) - do iVec=1,mVec - write(Label,'(A,I2,A,I2,A)') ' rFinal(',ia,',',ib,')' - call RecPrt(Label,' ',rFinal(1,ia,ib,iVec),nAlpha,nBeta) + do ia=1,nTri_Elem1(la) + if (iPrint >= 99) write(u6,*) ' ia,ib=',ia,ib + + do iC=1,(2*iAng+1) + if (iPrint >= 99) write(u6,*) ' iC,=',iC + iaC = (iC-1)*nTri_Elem1(la)+ia + ipaC = (iaC-1)*nAlpha*nExpi+ipF1a + iCb = (ib-1)*(2*iAng+1)+iC + ipCb = (iCb-1)*nExpi*nBeta+ipF2a + + if (iPrint >= 99) then + call RecPrt('',' ',Array(ipaC),nAlpha,nExpi) + call RecPrt('',' ',Array(ipCb),nExpi,nBeta) + end if + + call DGEMM_('N','N',nAlpha,nExpi,nExpi,One,Array(ipaC),nAlpha,Array(ipC),nExpi,Zero,Array(ipTmp),nAlpha) + call DGEMM_('N','N',nAlpha,nBeta,nExpi,Fact,Array(ipTmp),nAlpha,Array(ipCb),nExpi,One,rFinal(:,ia,ib,1,mVec), & + nAlpha) + + end do end do end do + + end if + end do + end do + + if (iPrint >= 49) then + do iVec=1,mVec + write(u6,*) iVec,sqrt(DNrm2_(nZeta*nTri_Elem1(la)*nTri_Elem1(lb),rFinal(:,:,:,1,iVec),1)) + end do + end if + if (iPrint >= 99) then + write(u6,*) ' Result in SROGrd' + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb) + do iVec=1,mVec + write(Label,'(A,I2,A,I2,A)') ' rFinal(',ia,',',ib,')' + call RecPrt(Label,' ',rFinal(:,ia,ib,1,iVec),nAlpha,nBeta) + end do end do - end if + end do + end if - ! Distribute contributions to the gradient + ! Distribute contributions to the gradient - call Distg1X(rFinal,DAO,nZeta,nDAO,mVec,Grad,nGrad,JfGrad,JndGrd,iuvwx,lOp) + call Distg1X(rFinal,DAO,nZeta,nDAO,mVec,Grad,nGrad,JfGrad,JndGrd,iuvwx,lOp) - end do end do end do - end if - kdc = kdc+dbsc(kCnttp)%nCntr + end do end do return diff -Nru openmolcas-22.02/src/alaska_util/srommg.F90 openmolcas-22.10/src/alaska_util/srommg.F90 --- openmolcas-22.02/src/alaska_util/srommg.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/srommg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -33,7 +33,6 @@ use Definitions, only: iwp implicit none -#define _USE_WP_ #include "mem_interface.fh" integer(kind=iwp) :: iAng, iCnttp, ip, iShll, nac, ncb, nExpi, nOrder diff -Nru openmolcas-22.02/src/alaska_util/twoel_g.F90 openmolcas-22.10/src/alaska_util/twoel_g.F90 --- openmolcas-22.02/src/alaska_util/twoel_g.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/twoel_g.F90 2022-10-10 14:22:40.000000000 +0000 @@ -92,11 +92,13 @@ subroutine Rysg1(iAnga,nRys,nT,Alpha,Beta,Gmma,Delta,Zeta,ZInv,nZeta,Eta,EInv,nEta,P,lP,Q,lQ,Coori,Coora,CoorAC,Array,nArray, & Tvalue,ModU2,Cff2D,PAO,nPAO,Grad,nGrad,IfGrad,IndGrd,kOp,iuvwx) import :: wp, iwp - integer(kind=iwp) :: iAnga(4), nRys, nT, nZeta, nEta, lP, lQ, nArray, nPAO, nGrad, IndGrd(3,4), kOp(4), iuvwx(4) - real(kind=wp) :: Alpha(nZeta), Beta(nZeta), Gmma(nEta), Delta(nEta), Zeta(nZeta), ZInv(nZeta), Eta(nEta), EInv(nEta), & - P(lP,3), Q(lQ,3), Coori(3,4), Coora(3,4), CoorAC(3,2), Array(nArray), PAO(nT,nPAO), Grad(nGrad) + integer(kind=iwp), intent(in) :: iAnga(4), nRys, nT, nZeta, nEta, lP, lQ, nArray, nPAO, nGrad, IndGrd(3,4), kOp(4), iuvwx(4) + real(kind=wp), intent(in) :: Alpha(nZeta), Beta(nZeta), Gmma(nEta), Delta(nEta), Zeta(nZeta), ZInv(nZeta), Eta(nEta), & + EInv(nEta), P(lP,3), Q(lQ,3), Coori(3,4), Coora(3,4), CoorAC(3,2), PAO(nT,nPAO) + real(kind=wp), intent(inout) :: Grad(nGrad) + real(kind=wp), intent(out) :: Array(nArray) external :: Tvalue, ModU2, Cff2D - logical(kind=iwp) :: IfGrad(3,4) + logical(kind=iwp), intent(in) :: IfGrad(3,4) end subroutine Rysg1 end interface # endif @@ -380,7 +382,7 @@ if (mGrad == 0) cycle ! Find the proper centers to start of with the angular - ! momentum on. If la == lb there will excist an + ! momentum on. If la == lb there will exist an ! ambiguity to which center that angular momentum should ! be accumulated on. In that case we will use A and C of ! the order as defined by the basis functions types. diff -Nru openmolcas-22.02/src/alaska_util/welgrd.F90 openmolcas-22.10/src/alaska_util/welgrd.F90 --- openmolcas-22.02/src/alaska_util/welgrd.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/welgrd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -40,10 +40,10 @@ #include "macros.fh" unused_var(ZInv) unused_var(nHer) -unused_var(Ccoor) +unused_var(Ccoor(1)) unused_var(nOrdOp) -unused_var(lOper) unused_var(iStabM) +unused_var(nStabM) iRout = 122 iPrint = nPrint(iRout) diff -Nru openmolcas-22.02/src/alaska_util/welmmg.F90 openmolcas-22.10/src/alaska_util/welmmg.F90 --- openmolcas-22.02/src/alaska_util/welmmg.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/welmmg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -18,7 +18,6 @@ use Definitions, only: iwp implicit none -#define _USE_WP_ #include "mem_interface.fh" integer(kind=iwp) :: i, jsum, k diff -Nru openmolcas-22.02/src/alaska_util/xfdgrd.F90 openmolcas-22.10/src/alaska_util/xfdgrd.F90 --- openmolcas-22.02/src/alaska_util/xfdgrd.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/xfdgrd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -34,8 +34,8 @@ #include "grd_interface.fh" integer(kind=iwp) :: i, iAlpha, iAnga(4), iBeta, iCar, iChxyz, iDAO, iDCRT(0:7), iDum, iFd, ii, iOrdOp, ipA, ipAOff, ipB, ipBOff, & ipDAO, iPrint, iRout, iStb(0:7), iuvwx(4), iZeta, j, jCoSet(8,8), JndGrd(3,4), jpDAO, lDCRT, LmbdT, lOp(4), & - mGrad, mRys, nArray, nDAO, nDCRT, nDiff, nip, nRys, nStb, nT -real(kind=wp) :: C(3), CoorAC(3,2), Coori(3,4), Fact, TC(3), TZFd(3), ZFd(3), ZFdx, ZFdy, ZFdz + mGrad, mRys, nArray, nDAO, nDCRT, nDiff, nip, nStb, nT +real(kind=wp) :: C(3), CoorAC(3,2), Coori(3,4), Fact, TC(3), TZFd(3), ZFd(3) logical(kind=iwp) :: JfGrad(3,4), NoLoop character(len=3), parameter :: ChOper(0:7) = ['E ','x ','y ','xy ','z ','xz ','yz ','xyz'] integer(kind=iwp), external :: iChAtm, NrOpr @@ -44,16 +44,14 @@ #include "macros.fh" unused_var(rFinal) -unused_var(nRys) -unused_var(Ccoor) +unused_var(nHer) +unused_var(Ccoor(1)) unused_var(nOrdOp) -unused_var(lOper) +unused_var(nComp) iRout = 151 iPrint = nPrint(iRout) -nRys = nHer - ! Modify the density matrix with the prefactor nDAO = nTri_Elem1(la)*nTri_Elem1(lb) @@ -138,7 +136,7 @@ if (iPrint >= 99) call RecPrt('C',' ',C,1,3) - ! Generate stabilizor of C + ! Generate stabilizer of C iChxyz = iChAtm(C) call Stblz(iChxyz,nStb,iStb,iDum,jCoSet) @@ -198,18 +196,15 @@ Coori(:,4) = TC(:) if (iOrdOp == 0) then - call DYaX(nZeta*nDAO,Fact*ZFd(1),DAO,1,Array(ipDAO),1) + Array(ipDAO:ipDAO+nZeta*nDAO-1) = Fact*ZFd(1)*pack(DAO,.true.) else call OA(iDCRT(lDCRT),ZFd,TZFd) jpDAO = ipDAO - ZFdx = TZFd(1) - call DYaX(nZeta*nDAO,Fact*ZFdx,DAO,1,Array(jpDAO),1) + Array(jpDAO:jpDAO+nZeta*nDAO-1) = Fact*TZFd(1)*pack(DAO,.true.) jpDAO = jpDAO+nZeta*nDAO - ZFdy = TZFd(2) - call DYaX(nZeta*nDAO,Fact*ZFdy,DAO,1,Array(jpDAO),1) + Array(jpDAO:jpDAO+nZeta*nDAO-1) = Fact*TZFd(2)*pack(DAO,.true.) jpDAO = jpDAO+nZeta*nDAO - ZFdz = TZFd(3) - call DYaX(nZeta*nDAO,Fact*ZFdz,DAO,1,Array(jpDAO),1) + Array(jpDAO:jpDAO+nZeta*nDAO-1) = Fact*TZFd(3)*pack(DAO,.true.) end if ! Compute integrals with the Rys quadrature. diff -Nru openmolcas-22.02/src/alaska_util/xfdmmg.F90 openmolcas-22.10/src/alaska_util/xfdmmg.F90 --- openmolcas-22.02/src/alaska_util/xfdmmg.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/alaska_util/xfdmmg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -20,7 +20,6 @@ use Definitions, only: iwp implicit none -#define _USE_WP_ #include "mem_interface.fh" integer(kind=iwp) :: iAng(4), iOrdOp, MemTmp diff -Nru openmolcas-22.02/src/amfi_util/amfi.f openmolcas-22.10/src/amfi_util/amfi.f --- openmolcas-22.02/src/amfi_util/amfi.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/amfi.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,312 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1996,1997, Bernd Schimmelpfennig * -************************************************************************ -Change start -c program amfi -c implicit real*8 (a-h,o-z) -Change else - Subroutine amfi(IN,LUPROP,iCenter) - implicit Real*8 (a-h,o-z) -Change end -c########################################################################### -c -c A M F I -c -c Atomic Mean-Field Spin-Orbit Integral Program -c -c Integral-code to generate the one- and two-electron spin-orbit integrals -c in the no-pair approximation for an atom. -c -c basis set is built by atomic functions of the form: -c -c f(r,Omega)= r**l Y_(lm) (Omega) -c -c Allthough the code is created with a lot of care and love for -c the details, the author doesn't give any warranty for it's -c correctness. -c -c B.Schimmelpfennig Fysikum/Stockholm Summer 1996 -c -c If you use this code, please honour the authors work -c by citing this work properly. -c -c The author would like to thank the Deutsche Forschungsgemeinschaft -c for financing this project by a Forschungsstipendium. -c -c -c The spatial integrals are expected to be used with a spin part -c expressed in Paulis spin-matrices rather than with the Spin-operator -c itself. So if a factor of two is somehow missing, check whether the -c same form of the operator is used. -c -c -c WARNING !!! WARNING !! WARNING !! WARNING !! WARNING !! -c -c when writing spin-same-orbit and spin-other-orbit with sigma_i: -c -c For the spin-other-orbit-integrals particle 1 and 2 are exchanged -c on the arrays carteXOO,carteYOO,carteZOO!!!!!!!!! -c -c The reason is to use most of the same-orbit part again and to -c have the same symmetry for the integrals on the arrays. -c -c -c if the spin-other-orbit-part is used in the formulation with -c sigma_j, the particles are of cause not interchanged. -c -c -c -c (i|HSO_mean|j) = (ij) + 1/2 * sum_M occ(M) { -c 2(ij|MM)_same - (iM|jM)_same -2(iM|jM)_other -c + (jM|iM)_same +2(jM|iM)_other } -c -c in the subroutines some signs are changed to reorder indices -c in the integrals to (iM|jM) or (Mi|Mj) accoding to the way they -c were calculated before. -c -c -c -c one-particle integrals (really one-particle or mean-field) -c are written to files in CONTANDMULT. Look there for information on -c the format of files. -c -c -c BUGS: There is still a strange sign-error in the two-electron-integrals -c if one applies straight-forward the formulae of the documentation. -c This problem has been solved by the the cheater... -c -c Everybody is welcome to find the problem in the formulas ........ -c -c First reasonable results on Thallium (SD with frozen 5D) 14.10.96 -c -c -c -c -c -c Connection to MOLCAS: -c How wonderful, they normalize the functions exactly as I do, which -c means they use the correct linear combinations. -c -c Exponents and coefficients are expected in the MOLCAS-Format -c first exponents -c coefficients afterwards -c -c 8.5.97 -c -c -c########################################################################### -#include "para.fh" - logical keep ! parameter to decide about keeping angular -cbs ! integrals in memory - logical keepcart ! parameter to decide about keeping cartesian -cbs ! integrals in memory - logical makemean ! 'true' = generating a meanfield - logical bonn ! 'true' = Bonn-approach for spin-other orbit - logical breit ! if breit is set, BREIT-PAULI only - logical SAMEORB ! parameter for same-orbit only - logical AIMP ! parameter to delete CORE for AIMP - logical oneonly ! parameter to use only oneelectron integrals - character*4 symmetry - parameter (Lpowmax=6) - dimension ixyzpow(3*(Lpowmax+1)*(Lpowmax+1)) ! - data ixyzpow / -cbs the ones and zeros stand four odd and even powers of x,y,z -cbs if you want to go higher than l=6, you have to look up -cbs the powers yourself, and add them to the table - *0,0,0, ! s-function - *0,1,0, 0,0,1, 1,0,0, ! p-functions - *1,1,0, 0,1,1, 0,0,0, 1,0,1, 0,0,0, ! d-functions - *0,1,0, 1,1,1, 0,1,0, 0,0,1, 1,0,0, ! f-functions - *0,0,1, 1,0,0, ! f-functions - *1,1,0, 0,1,1, 1,1,0, 0,1,1, 0,0,0, ! g-functions - *1,0,1, 0,0,0, 1,0,1, 0,0,0, ! g-functions - *0,1,0, 1,1,1, 0,1,0, 1,1,1, 0,1,0, ! h-functions - *0,0,1, 1,0,0, 0,0,1, 1,0,0, 0,0,1, ! h-functions - *1,0,0, ! h-functions - *1,1,0, 0,1,1, 1,1,0, 0,1,1, 1,1,0, ! i-functions - *0,1,1, 0,0,0, 1,0,1, 0,0,0, 1,0,1, ! i-functions - *0,0,0, 1,0,1, 0,0,0 ! i-functions - */ -#include "Molcas.fh" -#include "stdalloc.fh" - Real*8, Allocatable:: oneoverR3(:), CartOne(:,:), OneContr(:), - & CoulOvlp(:), PowExp(:), preY(:), preXZ(:) - Integer, Allocatable:: checkxy(:), checkz(:), interxyz(:,:), - & SgnProd(:) -* -#include "ipowxyz.fh" -c########################################################################## -cbs ##################################################################### -cbs version with all angular integrals in memory -c keep=.true. -cbs ##################################################################### -cbs version without all angular integrals in memory - keep=.false. -cbs ##################################################################### -cbs version without all cartesian integrals in memory - keepcart=.false. -cbs ##################################################################### -cbs version with all cartesian integrals in memory -c keepcart=.true. -cbs ##################################################################### - ifinite=0 -cbs initialize tables with double facultatives... - call inidf -cbs move some powers of x,y,z to the right place BEGIN -cbs check if Lpowmax is high enough.. - if (Lpowmax.lt.Lmax) then - Call SysAbendMsg('amfi', 'increase lpowmax and edit ixyzpow',' ' ) - endif - jrun=1 - do irun=0,Lmax - do Mval=-irun,irun - ipowxyz(1,Mval,irun)=ixyzpow(jrun) - ipowxyz(2,Mval,irun)=ixyzpow(jrun+1) - ipowxyz(3,Mval,irun)=ixyzpow(jrun+2) - jrun=jrun+3 - enddo - enddo -cbs move some powers of x,y,z to the right place END -cbs read the input - call readbas(Lhigh,makemean,bonn,breit,symmetry,sameorb,AIMP, - & oneonly,ncont4,numballcart,IN,ifinite) -cbs - icartdim=mxcontL*MxcontL*(Lmax+Lmax+1)*(Lmax+1)*Lmax - ionecontrdim=mxcontL*MxcontL*(2*Lmax+1)*3*Lmax - ioneoverR3dim=Lmax*(MxprimL*MxprimL+MxprimL)/2 - ipowexpdim=MxprimL*MxprimL*(Lmax+1)*(Lmax+1)*(Lmax+Lmax+6) - icoulovlpdim=MxprimL*MxprimL*(Lmax+1)*(Lmax+1)*10 - Call mma_allocate(oneoverR3,ioneoverR3dim,Label='oneoverR3') - Call mma_allocate(cartone,icartdim,3,Label='cartone') - Call mma_allocate(OneContr,ionecontrdim,Label='OneContr') - Call mma_allocate(CoulOvlp,icoulovlpdim,Label='coulovlp') - Call mma_allocate(PowExp,iPowExpDim,Label='PowExp') - oneoverR3(:)=0.0D0 - cartone(:,:)=0.0D0 - OneContr(:)=0.0D0 - CoulOvlp(:)=0.0D0 - PowExp(:)=0.0D0 -cbs -cbs - 123 if (ifinite.eq.2) call finite -cbs -cbs -! Lhigh is the highest l-value in the basis set - if (makemean.and.(.not.oneonly).and.ifinite.le.1) - & call getAOs(Lhigh) - call genpowers(Lhigh,PowExp,CoulOvlp) -!generate powers of exponents and overlaps -cbs start generating modified contraction coefficients -cbs generate starting adresses of contraction coefficients on -cbs contrarray - call genstar(Lhigh) -cbs generate ovlp of normalized primitives - call genovlp(Lhigh,CoulOvlp) - do lrun=0,Lhigh -cbs cont(L) arranges all the contraction coefficients for a given -cbs L-value and renormalizes them - call cont(lrun,breit,ifinite) - enddo -cbs -cbs beginning the angular part - if (.not.oneonly) then -CBS write(6,*) '***************************************************' -CBS write(6,*) '******** beginning the 2e-part ******************' -CBS write(6,*) '***************************************************' -cbs -cbs ################################################################### -cbs ################################################################### -cbs ################################################################### -cbs -cbs - idim1=(2*Lmax+1)*(2*Lmax+1)*(2*Lmax+1)*(2*Lmax+1) - idim2=(Lmax+1)*(Lmax+1)*(Lmax+1)*(Lmax+1) - Call mma_allocate(preY,idim1,Label='preY') - Call mma_allocate(preXZ,idim1,Label='preXZ') - Call mma_allocate(checkxy,idim2,Label='CheckXY') - Call mma_allocate(checkz,idim2,Label='CheckZ') - Call mma_allocate(interxyz,16,idim2,Label='InterXYZ') - Call mma_allocate(SgnProd,idim1,Label='SgnProd') -* -! subroutine for angular part -* - call angular(Lhigh,keep,keepcart,makemean,bonn,breit, - & sameorb,ifinite, - & cartone(1,1),cartone(1,2),cartone(1,3), - & PowExp,CoulOvlp,preXZ,preY, - & checkxy,checkz,InterXYZ,SgnProd) -* - Call mma_deallocate(SgnProd) - Call mma_deallocate(InterXYZ) - Call mma_deallocate(CheckZ) - Call mma_deallocate(CheckXY) - Call mma_deallocate(preXZ) - Call mma_deallocate(preY) - endif - if (ifinite.eq.1) then ! redo everything for finite core -CBS write(6,*) 'once more the two-electron integrals' - ifinite=2 - goto 123 - endif -cbs #################################################################### -cbs #################################################################### -cbs #################################################################### -CBS write(6,*) '***************************************************' -CBS write(6,*) '******* beginning the 1-electron-part **********' -CBS write(6,*) '***************************************************' -* -cbs The one-electron spin-orbit integrals -* - call gen1overR3(Lhigh,oneoverR3) -* -! 1/r**3 for normalized functions -* - call contandmult(Lhigh,makemean,AIMP,oneonly,numballcart,LUPROP, - & ifinite,CartOne,OneContr,oneoverR3,iCenter) -* -cbs multiplies radial integrals with l,m-dependent -cbs factors and contraction coefficients - Call mma_deallocate(CoulOvlp) - Call mma_deallocate(PowExp) - Call mma_deallocate(OneContr) - Call mma_deallocate(CartOne) - Call mma_deallocate(oneoverR3) -CBS write(6,*) '***************************************************' -CBS write(6,*) '******* end of the 1-electron-part **********' -CBS write(6,*) '***************************************************' -cbs #################################################################### -cbs #################################################################### -cbs #################################################################### - Return - End Subroutine Amfi - subroutine finite -cbs -cbs subroutine to set up parameters for finite nucleus. The -cbs s-functions are replaced by just one exponent which models the -cbs nucleus. -cbs - implicit real*8(a-h,o-z) -#include "para.fh" -#include "param.fh" -#include "nucleus.fh" - noccorb(0)=1 - do l=1,lmax_occ - noccorb(l)=0 - enddo - occup(1,0)=-charge - nprimit_keep=nprimit(0) - ncontrac_keep=ncontrac(0) - nprimit(0)=1 - ncontrac(0)=1 - exponents(1,0)=0.5d0*Exp_finite - return - end subroutine finite diff -Nru openmolcas-22.02/src/amfi_util/amfi.F90 openmolcas-22.10/src/amfi_util/amfi.F90 --- openmolcas-22.02/src/amfi_util/amfi.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/amfi.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,270 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1996,1997, Bernd Schimmelpfennig * +!*********************************************************************** + +subroutine amfi(LUIN,LUPROP,iCenter) +!####################################################################### +! +! A M F I +! +! Atomic Mean-Field Spin-Orbit Integral Program +! +! Integral-code to generate the one- and two-electron spin-orbit integrals +! in the no-pair approximation for an atom. +! +! basis set is built by atomic functions of the form: +! +! f(r,Omega)= r**l Y_(lm) (Omega) +! +! Allthough the code is created with a lot of care and love for +! the details, the author doesn't give any warranty for it's +! correctness. +! +! B.Schimmelpfennig Fysikum/Stockholm Summer 1996 +! +! If you use this code, please honour the authors work +! by citing this work properly. +! +! The author would like to thank the Deutsche Forschungsgemeinschaft +! for financing this project by a Forschungsstipendium. +! +! +! The spatial integrals are expected to be used with a spin part +! expressed in Paulis spin-matrices rather than with the Spin-operator +! itself. So if a factor of two is somehow missing, check whether the +! same form of the operator is used. +! +! +! WARNING !!! WARNING !! WARNING !! WARNING !! WARNING !! +! +! when writing spin-same-orbit and spin-other-orbit with sigma_i: +! +! For the spin-other-orbit-integrals particle 1 and 2 are exchanged +! on the arrays carteXOO,carteYOO,carteZOO!!!!!!!!! +! +! The reason is to use most of the same-orbit part again and to +! have the same symmetry for the integrals on the arrays. +! +! +! if the spin-other-orbit-part is used in the formulation with +! sigma_j, the particles are of cause not interchanged. +! +! +! +! (i|HSO_mean|j) = (ij) + 1/2 * sum_M occ(M) { +! 2(ij|MM)_same - (iM|jM)_same -2(iM|jM)_other +! + (jM|iM)_same +2(jM|iM)_other } +! +! in the subroutines some signs are changed to reorder indices +! in the integrals to (iM|jM) or (Mi|Mj) accoding to the way they +! were calculated before. +! +! +! +! one-particle integrals (really one-particle or mean-field) +! are written to files in CONTANDMULT. Look there for information on +! the format of files. +! +! +! BUGS: There is still a strange sign-error in the two-electron-integrals +! if one applies straight-forward the formulae of the documentation. +! This problem has been solved by the the cheater... +! +! Everybody is welcome to find the problem in the formulas ........ +! +! First reasonable results on Thallium (SD with frozen 5D) 14.10.96 +! +! +! +! Connection to MOLCAS: +! How wonderful, they normalize the functions exactly as I do, which +! means they use the correct linear combinations. +! +! Exponents and coefficients are expected in the MOLCAS-Format +! first exponents +! coefficients afterwards +! +! 8.5.97 +!####################################################################### + +use AMFI_global, only: ipowxyz, MxcontL, MxprimL, Lmax +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: LUIN, LUPROP, iCenter +integer(kind=iwp) :: icartdim, icoulovlpdim, idim1, idim2, ifinite, ionecontrdim, ioneoverR3dim, ipowexpdim, irun, jrun, lhigh, & + lrun, Mval, ncont4, numballcart +logical(kind=iwp) :: AIMP, bonn, breit, keep, makemean, oneonly, SAMEORB +character(len=4) :: symmetry +integer(kind=iwp), allocatable :: checkxy(:), checkz(:), interxyz(:,:), SgnProd(:) +real(kind=wp), allocatable :: CartOne(:,:), CoulOvlp(:), Energy(:), evec(:,:), eval(:), OneContr(:), oneoverR3(:), PowExp(:), & + preXZ(:), preY(:), scratch(:,:,:), TKIN(:,:), type1(:), type2(:) +!bs the ones and zeros stand four odd and even powers of x,y,z +!bs if you want to go higher than l=6, you have to look up +!bs the powers yourself, and add them to the table +integer(kind=iwp), parameter :: Lpowmax = 6, & + ixyzpow(3*(Lpowmax+1)**2) = [ & + 0,0,0, & ! s-function + 0,1,0,0,0,1,1,0,0, & ! p-functions + 1,1,0,0,1,1,0,0,0,1,0,1,0,0,0, & ! d-functions + 0,1,0,1,1,1,0,1,0,0,0,1,1,0,0,0,0,1,1,0,0, & ! f-functions + 1,1,0,0,1,1,1,1,0,0,1,1,0,0,0,1,0,1,0,0,0,1,0,1,0,0,0, & ! g-functions + 0,1,0,1,1,1,0,1,0,1,1,1,0,1,0,0,0,1,1,0,0,0,0,1,1,0,0,0,0,1,1,0,0, & ! h-functions + 1,1,0,0,1,1,1,1,0,0,1,1,1,1,0,0,1,1,0,0,0,1,0,1,0,0,0,1,0,1,0,0,0,1,0,1,0,0,0 & ! i-functions + ] +!keep : parameter to decide about keeping angular integrals in memory +!makemean : 'true' = generating a mean field +!bonn : 'true' = Bonn-approach for spin-other orbit +!breit : if breit is set, BREIT-PAULI only +!SAMEORB : parameter for same-orbit only +!AIMP : parameter to delete CORE for AIMP +!oneonly : parameter to use only one-electron integrals + +!####################################################################### +!bs #################################################################### +!bs version with all angular integrals in memory +!keep = .true. +!bs #################################################################### +!bs version without all angular integrals in memory +keep = .false. +!bs #################################################################### +!bs initialize tables with double factorials... +call inidf() +!bs move some powers of x,y,z to the right place BEGIN +!bs check if Lpowmax is high enough.. +if (Lpowmax < Lmax) call SysAbendMsg('amfi','increase lpowmax and edit ixyzpow',' ') +jrun = 1 +do irun=0,Lmax + do Mval=-irun,irun + ipowxyz(:,Mval,irun) = ixyzpow(jrun:jrun+2) + jrun = jrun+3 + end do +end do +!bs move some powers of x,y,z to the right place END +!bs read the input +call readbas(Lhigh,makemean,bonn,breit,symmetry,sameorb,AIMP,oneonly,ncont4,numballcart,LUIN,ifinite) + +icartdim = MxcontL*MxcontL*(Lmax+Lmax+1)*(Lmax+1)*Lmax +ionecontrdim = MxcontL*MxcontL*(2*Lmax+1)*3*Lmax +ioneoverR3dim = Lmax*(MxprimL*MxprimL+MxprimL)/2 +ipowexpdim = MxprimL*MxprimL*(Lmax+1)*(Lmax+1)*(Lmax+Lmax+6) +icoulovlpdim = MxprimL*MxprimL*(Lmax+1)*(Lmax+1)*10 +call mma_allocate(oneoverR3,ioneoverR3dim,label='oneoverR3') +call mma_allocate(cartone,icartdim,3,label='cartone') +call mma_allocate(OneContr,ionecontrdim,label='OneContr') +call mma_allocate(CoulOvlp,icoulovlpdim,label='coulovlp') +call mma_allocate(PowExp,iPowExpDim,label='PowExp') +call mma_allocate(TKIN,MxprimL,MxprimL,label='TKIN') +call mma_allocate(evec,MxprimL,MxprimL,label='evec') +call mma_allocate(eval,MxprimL,label='eval') +call mma_allocate(Energy,MxprimL,label='Energy') +call mma_allocate(type1,MxprimL,label='type1') +call mma_allocate(type2,MxprimL,label='type2') +call mma_allocate(scratch,MxprimL,MxprimL,3,label='scratch') +oneoverR3(:) = Zero +cartone(:,:) = Zero +OneContr(:) = Zero +CoulOvlp(:) = Zero +PowExp(:) = Zero + +do + if (ifinite == 2) call finite() + + ! Lhigh is the highest l-value in the basis set + if (makemean .and. (.not. oneonly) .and. (ifinite <= 1)) call getAOs(Lhigh) + call genpowers(Lhigh,PowExp,CoulOvlp) + ! generate powers of exponents and overlaps + !bs generate ovlp of normalized primitives + call genovlp(Lhigh,CoulOvlp,eval) + do lrun=0,Lhigh + !bs cont(L) arranges all the contraction coefficients for a given + !bs L-value and renormalizes them + call cont(lrun,breit,ifinite,TKIN,evec,eval,Energy,type1,type2,scratch) + end do + + !bs beginning the angular part + if (.not. oneonly) then + !BS write(u6,*) '***************************************************' + !BS write(u6,*) '******** beginning the 2e-part ******************' + !BS write(u6,*) '***************************************************' + + !bs ################################################################ + !bs ################################################################ + !bs ################################################################ + + idim1 = (2*Lmax+1)*(2*Lmax+1)*(2*Lmax+1)*(2*Lmax+1) + idim2 = (Lmax+1)*(Lmax+1)*(Lmax+1)*(Lmax+1) + call mma_allocate(preY,idim1,label='preY') + call mma_allocate(preXZ,idim1,label='preXZ') + call mma_allocate(checkxy,idim2,label='CheckXY') + call mma_allocate(checkz,idim2,label='CheckZ') + call mma_allocate(interxyz,16,idim2,label='InterXYZ') + call mma_allocate(SgnProd,idim1,label='SgnProd') + + ! subroutine for angular part + + call angular(Lhigh,keep,makemean,bonn,breit,sameorb,ifinite,cartone(1,1),cartone(1,2),cartone(1,3),PowExp,CoulOvlp,preXZ,preY, & + checkxy,checkz,InterXYZ,SgnProd) + + call mma_deallocate(SgnProd) + call mma_deallocate(InterXYZ) + call mma_deallocate(CheckZ) + call mma_deallocate(CheckXY) + call mma_deallocate(preXZ) + call mma_deallocate(preY) + end if + if (ifinite /= 1) exit + ! redo everything for finite core + !BS write(u6,*) 'once more the two-electron integrals' + ifinite = 2 +end do +!bs #################################################################### +!bs #################################################################### +!bs #################################################################### +!BS write(u6,*) '***************************************************' +!BS write(u6,*) '******* beginning the 1-electron-part **********' +!BS write(u6,*) '***************************************************' + +!bs The one-electron spin-orbit integrals + +call gen1overR3(Lhigh,oneoverR3) + +! 1/r**3 for normalized functions + +call contandmult(Lhigh,AIMP,oneonly,numballcart,LUPROP,ifinite,CartOne,OneContr,oneoverR3,iCenter) + +!bs multiplies radial integrals with l,m-dependent +!bs factors and contraction coefficients +call mma_deallocate(CoulOvlp) +call mma_deallocate(PowExp) +call mma_deallocate(OneContr) +call mma_deallocate(CartOne) +call mma_deallocate(oneoverR3) +call mma_deallocate(TKIN) +call mma_deallocate(evec) +call mma_deallocate(eval) +call mma_deallocate(Energy) +call mma_deallocate(type1) +call mma_deallocate(type2) +call mma_deallocate(scratch) +!BS write(u6,*) '***************************************************' +!BS write(u6,*) '******* end of the 1-electron-part **********' +!BS write(u6,*) '***************************************************' +!bs #################################################################### +!bs #################################################################### +!bs #################################################################### + +return + +end subroutine amfi diff -Nru openmolcas-22.02/src/amfi_util/amfi_global.F90 openmolcas-22.10/src/amfi_util/amfi_global.F90 --- openmolcas-22.02/src/amfi_util/amfi_global.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/amfi_global.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,79 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +module AMFI_global + +use Definitions, only: wp, iwp + +implicit none +private + +!bs Lmax : max. angular momentum of basis functions +!bs DO NOT INCREASE TO MORE THAN SIX !!!!! +!bs if you do, you will have to edit the ixyzpow array by hand... +!bs Lmax_occ : highest L-value for occupied orbitals +!bs MxprimL : max. of primitives per angular momentum +!bs MxcontL : max. of contracted functions per angular momentum +!bs MxCart : max. number of contracted functions in the atom +!bs ndfmx : dimension of precomputed double factorials +!bs normovlp : overlap of normalized functions +!bs contrarray : big array with enough space for all modified contraction coefficients +!bs for each l-value there are five blocks of size MxprimL*MxcontL +!bs the original contraction coefficients (for normalized functions) +!bs and four modified blocks depending on different kinematic factors and included exponents +!bs exponents : the exponents +!bs nprimt,ncontrac : the numbers of primitive and contracted functions for each l-value +!bs Lfirst(i) : gives the first L-value, for which radial integrals are calculated +!bs for type i and l1,l2,l3,l4 - Integral block. +!bs Llast(i) : gives the last L-value +!bs Lblocks(i) : gives the number of L-values +!bs Lstarter(i) : gives the adress of each integral block on cont4 +!bs AOcoeffs : express AOs in contracted functions +!bs first index: number of contracted function +!bs second index: number of AO +!bs third index: L-value +!bs occup : occupation numbers +!bs first index: number of AO +!bs second index: L-value +!bs numbofsym : number of symmetries +!bs ipow2ired : gives IR by checking powers +!bs incrLM : shift of orbitalnumber in IR for L,M +!bs shiftIRED : shift to get to absolute number from relative number in IR +!bs iredLM : IR for L and M +!bs shiftIRIR : shift for (IR1,IR2)-block (IR1<=IR2) +!bs Loffunction : gives L value of cartesian function +!bs Moffunction : gives M value of cartesian function +!bs Iredoffunctnew : give IRED of cartesian function incl. add. functions +!bs itotalperIR : total number of functions per IR +!bs df, dffrac : some double factorials and their fractions, initialized by inidf +!bs ipowxyz : array that includes information about +!bs odd powers of x y z in the real harmonics +!bs this is used to check whether integrals in the +!bs cartesian representation appear + +integer(kind=iwp), parameter :: Lmax = 6, Lmax_occ = 3, MxCart = 300, MxcontL = 40, MxprimL = 40, ndfmx = 4*(Lmax+1) + +integer(kind=iwp) :: icore(0:Lmax), ikeeplist(Mxcart), ikeeporb, incrLM(-Lmax:Lmax,0:Lmax), ipow2ired(0:1,0:1,0:1), & + ipowxyz(3,-Lmax:Lmax,0:Lmax), iredLM(-Lmax:Lmax,0:Lmax), Iredoffunctnew(Mxcart), itotalperIR(8), Lblocks(4), & + Lfirst(4), Llast(4), Loffunction(Mxcart), Lstarter(4), Lvalues(4), Moffunction(Mxcart), nblock, & + ncontrac(0:Lmax), ncontrac_keep, noccorb(0:Lmax), nprimit(0:Lmax), nrtofiperIR(8), numbofsym, shiftIRED(8), & + shiftIRIR(8*(8+1)/2) +real(kind=wp) :: AOcoeffs(MxcontL,MxcontL,0:Lmax), charge, cntscrtch(MxPrimL,MxcontL,0:Lmax), & + contrarray(MxcontL*MxprimL,0:4,0:Lmax), df(0:ndfmx), dffrac(0:ndfmx,0:ndfmx), Exp_Finite, & + exponents(MxprimL,0:Lmax), normovlp(MxprimL,MxprimL,0:Lmax), occup(MxcontL,0:Lmax), & + OVLPinv(MxprimL,MxprimL,0:Lmax), rootOVLP(MxprimL,MxprimL,0:Lmax), rootOVLPinv(MxprimL,MxprimL,0:Lmax) + +public :: AOcoeffs, charge, cntscrtch, contrarray, df, dffrac, Exp_finite, exponents, icore, ikeeplist, ikeeporb, incrLM, & + ipow2ired, ipowxyz, iredLM, iredoffunctnew, itotalperIR, Lblocks, Lfirst, Llast, Lmax, Lmax_occ, Loffunction, Lstarter, & + Lvalues, Moffunction, MxCart, MxcontL, MxprimL, nblock, ncontrac, ncontrac_keep, noccorb, normovlp, nprimit, & + nrtofiperIR, numbofsym, occup, OVLPinv, rootOVLP, rootOVLPinv, shiftIRED, shiftIRIR + +end module AMFI_global diff -Nru openmolcas-22.02/src/amfi_util/angular.f openmolcas-22.10/src/amfi_util/angular.f --- openmolcas-22.02/src/amfi_util/angular.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/angular.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,727 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine angular(Lhigh,keep,keepcart,makemean,bonn, - * breit,sameorb,ifinite, - * onecartx,onecarty,onecartz,powexp,coulovlp, - * preXZ,preY,icheckxy,icheckz,interxyz,isgnprod) - -c -cbs COMBINES THE RADIAL INTEGRALS WITH THE ANGULAR FACTORS -c -cbs if keep=.true. then -cbs all the integrals will be kept in memory. -cbs Perhaps, there will be the option to make the -cbs transformation to the cartesian basis-sets -cbs everytime, they are required. -cbs Therefore, the integrals are kept in memory and -cbs can be further transformed, whenever required. -cbs in order not to waste to much memory, the atomic -cbs integrals are thrown away after each l,l,l,l-block - implicit real*8(a-h,o-z) -#include "para.fh" -#include "param.fh" -#include "Molcas.fh" -#include "stdalloc.fh" - Real*8, Allocatable:: ConOO(:), ConSO(:), CartOO(:), CartSO(:), - & AngOO(:), AngSO(:) - logical keep,keepcart,makemean,bonn, - * breiT,sameorb,cleaner,NFINI -cbs NFINI means not finite nucleus - dimension onecartX(mxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1),Lmax), - * onecartY(mxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1),Lmax), - * onecartZ(mxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1),Lmax), - *powexp(MxprimL,MxprimL,0:Lmax,0:Lmax,0:(Lmax+Lmax+5)),coulovlp(*), - *preXZ(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), - *preY(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), - *icheckxy(0:Lmax,0:Lmax,0:Lmax,0:Lmax), - *icheckz(0:Lmax,0:Lmax,0:Lmax,0:Lmax), - *interxyz(16,0:Lmax,0:Lmax,0:Lmax,0:Lmax), - *isgnprod(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) -cbs #################################################################### -cbs some preparation of factors needed later on.. # -cbs #################################################################### - ipnt(i,j)=(max(i,j)*max(i,j)-max(i,j))/2+min(i,j) -cbs calculate some prefactors that will be needed quite often - call prefac(Lmax,preroots,clebsch) - if (ifinite.ne.2) then -cbs clean array for one electron integrals - onecartX(:,:,:,:)=0.0D0 - onecartY(:,:,:,:)=0.0D0 - onecartZ(:,:,:,:)=0.0D0 - NFINI=.true. - else - NFINI=.false. - endif -* -cbs generate an array with sign for (even/odd) m-values - isignM(0)=1 - do I=2,Lmax,2 - isignM(I)=1 - isignM(-I)=1 - enddo - do I=1,Lmax,2 - isignM(I)=-1 - isignM(-I)=-1 - enddo - call genprexyz(preXZ) - call genprexyz2(preXZ) - call genprexyz3(preXZ) - call genprexyz4(preXZ) - call genprexyz5(preXZ) - call genprexyz6(preY,preXZ) - call genprexyz7(preXZ) - call genprexyz8(preXZ) - call genprexyz9(preXZ) - call genprexyz10(preXZ) - call genprexyz11(preY) - call genprexyz12(preY) - call genprexyz13(icheckxy) - call genprexyz14(icheckz,interxyz) - call genprexyz15a(icheckxy,icheckz,interxyz) -cbs ##################################################################### -cbs isgnprod gives the sign due to powers (-1)**M this are again -cbs angular m-values -cbs ##################################################################### - do M4=-Lmax,Lmax - if (M4.gt.0) then - inter4=isignM(M4) - else - inter4=1 - endif - do M3=-Lmax,Lmax - if (M3.gt.0) then - inter3=inter4*isignM(M3) - else - inter3=inter4 - endif - do M2=-Lmax,Lmax - if (M2.gt.0) then - inter2=inter3*isignM(M2) - else - inter2=inter3 - endif - do M1=-Lmax,Lmax - if (M1.gt.0) then - isgnprod(m1,m2,m3,m4)=inter2*isignM(M1) - else - isgnprod(m1,m2,m3,m4)=inter2 - endif - enddo - enddo - enddo - enddo -cbs #################################################################### -cbs some preparation of factors needed later on.. finished # -cbs #################################################################### -c -! set some counters -cbs counter for total number of cartesian integrals - numbcart=0 -cbs same orbit integrals integrals on carteXSO carteYSO and carteSO -cbs other orbit integrals on carteXOO carteYOO and carteOO - iangfirst=0 ! first block of angular integrals -cbs loop over all possible < l1 l2, l3 l4 > blocks -CBS write(6,'(A)') ' L1 L2 L3 L4' - do l1=0,Lhigh ! improving is probably possible... - do l2=0,Lhigh - do l3=0,l1 - do l4=0,l2 -cbs check parity - if (mod(l1+l2+l3+l4,2).eq.0) then -cbs check that Lleft and Lright do not always differ by more than one -cbs a difference of two means two spin flips and is therefore not -cbs allowed - Lleftmax=l1+l2 - Lrightmax=l3+l4 - Lleftmin=iabs(l1-l2) - Lrightmin=iabs(l3-l4) - if ((Lrightmin-Lleftmax.le.1.and.Lrightmax-Lleftmin.gt.-1).or. - *(Lleftmin-Lrightmax.le.1.and.Lleftmax-Lrightmin.gt.-1)) then -cbs additional check for mean-field - if ((l1.eq.l3.and.l2.eq.l4).or.(l1.eq.l2.and.l3.eq.l4)) then - if (l1+l3.ne.0) then -CBS write(6,'(4I5)') l1,l2,l3,l4 -CBS now I determine the size of the angular integral arrays - jblock=0 - do m1=-l1,l1 - do m2=-l2,l2 - do m3=-l3,l3 - m4=m1+m2-m3+1 - if (iabs(m4).le.l4) then - if ((.not.makemean).or. - * (l1.eq.l3.and.l2.eq.l4.and.iabs(m2).eq.iabs(m4)).or. - * (l1.eq.l2.and.l3.eq.l4.and. - * (iabs(m1).eq.iabs(m2).or.iabs(m3).eq.iabs(m4)))) then - jblock=jblock+1 - endif - endif - enddo - enddo - enddo - do m1= 0,l1 - do m2=-l2,l2 - do m3=-l3,l3 - m4=m1+m2-m3 - if ((.not.makemean).or. - * (l1.eq.l3.and.l2.eq.l4.and.iabs(m2).eq.iabs(m4)).or. - * (l1.eq.l2.and.l3.eq.l4.and. - * (iabs(m1).eq.iabs(m2).or.iabs(m3).eq.iabs(m4)))) then - if (m1.ne.0.or.m2.ne.0.or.m3.ne.0) then ! all m=0 make no sense - if (iabs(m4).le.l4) then - jblock=jblock+1 - endif - endif - endif - enddo - enddo - enddo -CBS done !! -cbs number of contracted integrals for each block - ncont=ncontrac(l1)*ncontrac(l2)* - * ncontrac(l3)*ncontrac(l4) - mxangint=jblock*ncont -cbs determine the size icont4 for the radial integrals - call gencoulDIM(l1,l2,l3,l4,makemean,bonn,breit,sameorb,icont4) -* - Call mma_allocate(ANGSO,mxangint,Label='AngSO') - Call mma_allocate(ANGOO,mxangint,Label='AngOO') - Call mma_allocate(CartSO,nCont,Label='CartSO') - Call mma_allocate(CartOO,nCont,Label='CartOO') - Call mma_allocate(ConSO,iCont4,Label='ConSO') - Call mma_allocate(ConOO,iCont4,Label='ConOO') -* - call gencoul(l1,l2,l3,l4,makemean,bonn,breit, - * sameorb,conSO,conOO,icont4,powexp,coulovlp) -!gen and trans integrals -cbs local counter for integral adresses - mblock=0 ! counter of (m,m,m,m)-blocks for (l1,l2,l3,l4) -cbs if keep is set to false, the angular integrals are -cbs thrown away after each block of l-values -cbs which means integrals start at address 0 - if (.not.keep) iangfirst=0 - locstar=iangfirst ! local starting adress counter - do m1=-l1,l1 - do m2=-l2,l2 - do m3=-l3,l3 - do m4=-l4,l4 - mcombina(1,m1,m2,m3,m4)=0 ! will hold type of integrals (1,2,3) - mcombina(2,m1,m2,m3,m4)=0 ! will hold number of block - enddo - enddo - enddo - enddo - do m1=-l1,l1 - do m2=-l2,l2 - do m3=-l3,l3 -cbs m4 is more or less fixed by m1-3 -c####################################################################### -c####################################################################### -c########## the L- -type block to be combined with sigma+ ############## -c####################################################################### -c####################################################################### - m4=m1+m2-m3+1 - if (iabs(m4).le.l4) then !the L- -block to combine with sigma+ -cbs not all m-combinations are needed for the mean-field - if ((.not.makemean).or. - * (l1.eq.l3.and.l2.eq.l4.and.iabs(m2).eq.iabs(m4)).or. - * (l1.eq.l2.and.l3.eq.l4.and. - * (iabs(m1).eq.iabs(m2).or.iabs(m3).eq.iabs(m4)))) then - mcombina(1,m1,m2,m3,m4)=1 - mblock=mblock+1 - if (locstar+ncont.gt.mxangint) then - write(6,*) 'not enough space allocated for angular integrals' - write(6,*) 'increase mxangint to at least ', - * locstar+ncont - Call Abend() - endif -cbs mkangLmin = make_angular_integrals_for_L- type operator -cbs really generates the angular prefactors and combines them with -cbs the radial integrals - call mkangLmin(Lmax,l1,l2,l3,l4,m1,m2,m3,m4, - * AngSO(1+locstar), - * AngOO(1+locstar), - * Lfirst(1),Llast(1),Lblocks(1), - * ncontrac(l1),ncontrac(l2),ncontrac(l3),ncontrac(l4), - * ConSO(Lstarter(1)), - * ConSO(Lstarter(2)), - * ConSO(Lstarter(3)), - * ConSO(Lstarter(4)), - * ConOO(Lstarter(1)), - * ConOO(Lstarter(2)), - * ConOO(Lstarter(3)), - * ConOO(Lstarter(4)), - * preroots,clebsch,scratch4,bonn,breit, - * sameorb) - locstar=locstar+ncont ! increase starting address - mcombina(2,m1,m2,m3,m4)=mblock ! set the block number -c####################################################################### -c####################################################################### -c########## the L+ -type block to be combined with sigma- ############## -c####################################################################### -c####################################################################### -c -c these integrals are obtained by changing the signs of the m-values. -c As the integrals are the same, the pointer points to the same -c integrals... -c -c - mcombina(1,-m1,-m2,-m3,-m4)=3 - mcombina(2,-m1,-m2,-m3,-m4)=mblock - endif - Endif - enddo - enddo - enddo -c####################################################################### -c####################################################################### -c########## the L0 -type block to be combined with sigma0 ############## -c####################################################################### -c####################################################################### - do m1= 0,l1 - do m2=-l2,l2 - do m3=-l3,l3 -cbs m4 is more or less fixed by m1-3 - m4=m1+m2-m3 ! the L0-block to be combined with sigma0 -cbs not all m-combinations are needed for the mean-field - if ((.not.makemean).or. - * (l1.eq.l3.and.l2.eq.l4.and.iabs(m2).eq.iabs(m4)).or. - * (l1.eq.l2.and.l3.eq.l4.and. - * (iabs(m1).eq.iabs(m2).or.iabs(m3).eq.iabs(m4)))) then -c - if (m1.ne.0.or.m2.ne.0.or.m3.ne.0) then !all m=0 make no sense - if (iabs(m4).le.l4) then - mcombina(1,m1,m2,m3,m4)=2 - mblock=mblock+1 - if (locstar+ncont.gt.mxangint) then - write(6,*) 'not enough space allocated for angular integrals' - write(6,*) 'increase mxangint to at least ', - * locstar+ncont - Call Abend() - endif - call mkangL0(Lmax,l1,l2,l3,l4,m1,m2,m3,m4, - * angSO(1+locstar), - * AngOO(1+locstar), - * Lfirst(1),Llast(1),Lblocks(1), - * ncontrac(l1),ncontrac(l2),ncontrac(l3),ncontrac(l4), - * ConSO(Lstarter(1)), - * ConSO(Lstarter(2)), - * ConSO(Lstarter(3)), - * ConSO(Lstarter(4)), - * ConOO(Lstarter(1)), - * ConOO(Lstarter(2)), - * ConOO(Lstarter(3)), - * ConOO(Lstarter(4)), - * preroots,clebsch,scratch4,bonn,breit, - * sameorb) - locstar=locstar+ncont - mcombina(2,m1,m2,m3,m4)=mblock - endif - endif - endif - enddo - enddo - enddo -cbs ################################################################### -cbs ################################################################### -cbs transformation to l,m dependent integrals is finished -cbs ################################################################### -c -cbs ################################################################### -cbs begin transformation to cartesian integrals -cbs ################################################################### -cbs ################################################################### -cbs check out, which combinations of m-values will -cbs contribute to cartesian integrals - do m1=-l1,l1 ! - do m2=-l2,l2 ! these indices now run over the real harmonics - do m3=-l3,l3 ! - do m4=-l4,l4 ! - mcombcart(1,m1,m2,m3,m4)=0 ! will hold the type x=1 y=2 z=3 - mcombcart(2,m1,m2,m3,m4)=0 ! will hold the block number - enddo - enddo - enddo - enddo - mblockx=0 - mblocky=0 - mblockz=0 - do m3=-l3,l3 - do m4=-l4,l4 -cbs if the l-values are the same : triangular matrix over m-values -cbs is sufficient - if (l1.eq.l3) then - m1upper=m3 - else - m1upper=l1 - endif - if (makemean) m1upper=l1 -cbs if the l-values are the same : triangular matrix over m-values -cbs is sufficient - if (l2.eq.l4) then - m2upper=m4 - else - m2upper=l2 - endif - if (makemean) m2upper=l2 - do m1=-l1,m1upper - If (l1.eq.l3.and.m1.eq.m3) then ! clean real zeros by symmetry -cbs this a problem of the spin-other-orbit integrals, as they are by -cbs formula not antisymmetric in the indices for particle 1. - cleaner=.true. - else - cleaner=.false. - endif - do m2=-l2,m2upper -cbs not all m-combinations are needed for the mean-field - if ((.not.makemean).or. - * (l1.eq.l3.and.l2.eq.l4.and.m2.eq.m4).or. - * (l1.eq.l2.and.l3.eq.l4.and.(m1.eq.m2.or.m3.eq.m4))) then -C - indx=ipowxyz(1,m1,l1)+ipowxyz(1,m2,l2)+ - * ipowxyz(1,m3,l3)+ipowxyz(1,m4,l4) - indy=ipowxyz(2,m1,l1)+ipowxyz(2,m2,l2)+ - * ipowxyz(2,m3,l3)+ipowxyz(2,m4,l4) - indz=ipowxyz(3,m1,l1)+ipowxyz(3,m2,l2)+ - * ipowxyz(3,m3,l3)+ipowxyz(3,m4,l4) - indx=mod(indx,2) - indy=mod(indy,2) - indz=mod(indz,2) -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C++++++++++++++++ SIGMA X ++++++++++++++++++++++++++++++++++++ -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - if (indx.eq.0.and.indy.eq.1.and.indz.eq.1.and. - * icheckxy(iabs(m1),iabs(m2),iabs(m3),iabs(m4)).gt.0) then -! Y*Z -> transforms like L_x (B1) -cbs integrals for sigma_x - mblockx=mblockx+1 - mcombcart(1,m1,m2,m3,m4)=1 - mcombcart(2,m1,m2,m3,m4)=mblockx - call tosigX(m1,m2,m3,m4,AngSO(1+iangfirst), - * mcombina,ncontrac(l1),ncontrac(l2),ncontrac(l3), - * ncontrac(l4),CartSO,preXZ, - * interxyz(1,iabs(m1),iabs(m2),iabs(m3),iabs(m4)), - * isgnprod,cleaner) -c - if (.not.bonn.and.(.not.breiT)) - * call tosigX(m1,m2,m3,m4,AngOO(1+iangfirst), - * mcombina,ncontrac(l1),ncontrac(l2),ncontrac(l3), - * ncontrac(l4),cartOO,preXZ, - * interxyz(1,iabs(m1),iabs(m2),iabs(m3),iabs(m4)), - * isgnprod,cleaner) - if (makemean) then ! generate mean-field-contributions -c####################################################################### -c############ mean-field-part ######################################### -c####################################################################### - if (l1.eq.l3.and.l2.eq.l4) then - if (m2.eq.m4.and.m1.lt.m3.and. - * iabs(m1+m3).eq.1.and.l1.ne.0) then - call two2mean13(CartSO,occup(1,l2),AOcoeffs(1,1,l2), - * onecartx(1,1,ipnt(m1+l1+1,m3+l3+1),l1), - * ncontrac(l1),ncontrac(l2),noccorb(l2)) - endif - endif -* - if (NFINI) Then - if (l1.eq.l2.and.l3.eq.l4) then - if (m1.eq.m2.and.l3.ne.0.and.l3.ne.l1) then - if (m3.lt.m4.and.iabs(m4+m3).eq.1) then -cbs for the "Bonn-approach" exchange cartexOO by cartexSO - if (bonn.or.breiT) then - if (NFINI) call two2mean34a(cartSO,cartSO,occup(1,l1), - * AOcoeffs(1,1,l1),onecartx(1,1,ipnt(m3+l3+1,m4+l4+1),l3), - * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) - else - if(NFINI) call two2mean34a(cartSO,cartOO, - * occup(1,l1),AOcoeffs(1,1,l1), - * onecartx(1,1,ipnt(m3+l3+1,m4+l4+1),l3), - * ncontrac(l3),ncontrac(l1), - * noccorb(l2),sameorb) - endif - endif - if (m3.gt.m4.and.iabs(m4+m3).eq.1) then -cbs for the "Bonn-approach" exchange cartexOO by cartexSO - if (bonn.or.breiT) then - if (NFINI) call two2mean34b(CartSO,CartSO,occup(1,l1), - * AOcoeffs(1,1,l1),onecartx(1,1,ipnt(m3+l3+1,m4+l4+1),l3), - * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) - else - if (NFINI) call two2mean34b(CartSO,CartOO,occup(1,l1), - * AOcoeffs(1,1,l1),onecartx(1,1,ipnt(m3+l3+1,m4+l4+1),l3), - * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) - endif - endif - elseif(m3.eq.m4.and.l1.ne.0) then - if (m1.lt.m2.and.iabs(m1+m2).eq.1) then -cbs for the "Bonn-approach" exchange cartexOO by cartexSO - if (bonn.or.breiT) then - if (NFINI) call two2mean12a(CartSO,CartSO,occup(1,l3), - * AOcoeffs(1,1,l3),onecartx(1,1,ipnt(m1+l1+1,m2+l2+1),l1), - * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) - else - if (NFINI) call two2mean12a(CartSO,cartOO,occup(1,l3), - * AOcoeffs(1,1,l3),onecartx(1,1,ipnt(m1+l1+1,m2+l2+1),l1), - * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) - endif - endif - if (m1.gt.m2.and.iabs(m1+m2).eq.1) then -cbs for the "Bonn-approach" exchange cartexOO by cartexSO - if (bonn.or.breiT) then - if (NFINI) call two2mean12b(cartSO,CartSO,occup(1,l3), - * AOcoeffs(1,1,l3),onecartx(1,1,ipnt(m1+l1+1,m2+l2+1),l1), - * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) - else - if (NFINI) call two2mean12b(CartSO,CartOO,occup(1,l3), - * AOcoeffs(1,1,l3),onecartx(1,1,ipnt(m1+l1+1,m2+l2+1),l1), - * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) - endif - endif - endif - endif - endif ! If (NFINI) Then -c####################################################################### -c############ mean-field-part ######################################### -c####################################################################### - endif -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C++++++++++++++++ SIGMA Y ++++++++++++++++++++++++++++++++++++ -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - elseif (indx.eq.1.and.indy.eq.0.and.indz.eq.1.and. - * icheckxy(iabs(m1),iabs(m2),iabs(m3),iabs(m4)).gt.0) then -! X*Z transforms like L_y (B2) -cbs integrals for sigma_y - mblocky=mblocky+1 - mcombcart(1,m1,m2,m3,m4)=2 - mcombcart(2,m1,m2,m3,m4)=mblocky - call tosigY(m1,m2,m3,m4,AngSO(1+iangfirst), - * mcombina,ncontrac(l1),ncontrac(l2),ncontrac(l3), - * ncontrac(l4),CartSO,preY, - * interxyz(1,iabs(m1),iabs(m2),iabs(m3),iabs(m4)), - * isgnprod,cleaner) -c - if (.not.bonn.and.(.not.breit)) - * call tosigY(m1,m2,m3,m4,AngOO(1+iangfirst), - * mcombina,ncontrac(l1),ncontrac(l2),ncontrac(l3), - * ncontrac(l4),cartOO,preY, - * interxyz(1,iabs(m1),iabs(m2),iabs(m3),iabs(m4)),isgnprod, - * cleaner) - if (makemean) then ! generate mean-field-contributions -c####################################################################### -c############ mean-field-part ######################################### -c####################################################################### - if (l1.eq.l3.and.l2.eq.l4) then - if (m2.eq.m4.and.m1.lt.m3. - * and.iabs(m3-m1).eq.1.and.l1.ne.0) then - call two2mean13(CartSO,occup(1,l2), - * AOcoeffs(1,1,l2),onecartY(1,1,ipnt(m1+l1+1,m3+l3+1),l1), - * ncontrac(l1),ncontrac(l2),noccorb(l2)) - endif - endif -* - If (NFINI) Then - if (l1.eq.l2.and.l3.eq.l4) then - if (m1.eq.m2.and.l3.ne.0.and.l3.ne.l1) then - if (m3.lt.m4.and.iabs(m3-m4).eq.1) then -cbs for the "Bonn-approach" exchange carteYOO by carteYSO - if (bonn.or.breiT) then - if (NFINI) call two2mean34a(CartSO,CartSO,occup(1,l1), - * AOcoeffs(1,1,l1),onecartY(1,1,ipnt(m3+l3+1,m4+l4+1),l3), - * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) - else - if (NFINI) call two2mean34a(CartSO,CartOO,occup(1,l1), - * AOcoeffs(1,1,l1),onecartY(1,1,ipnt(m3+l3+1,m4+l4+1),l3), - * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) - endif - endif - if (m3.gt.m4.and.iabs(m3-m4).eq.1) then -cbs for the "Bonn-approach" exchange carteYOO by carteYSO - if (bonn.or.breiT) then - if (NFINI) call two2mean34b(CartSO,CartSO,occup(1,l1), - * AOcoeffs(1,1,l1),onecartY(1,1,ipnt(m3+l3+1,m4+l4+1),l3), - * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) - else - if (NFINI) call two2mean34b(CartSO,CartOO,occup(1,l1), - * AOcoeffs(1,1,l1),onecartY(1,1,ipnt(m3+l3+1,m4+l4+1),l3), - * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) - endif - endif - elseif(m3.eq.m4.and.l1.ne.0) then - if (m1.lt.m2.and.iabs(m1-m2).eq.1) then -cbs for the "Bonn-approach" exchange carteOO by carteSO - if (bonn.or.breiT) then - if (NFINI) call two2mean12a(CartSO,CartSO,occup(1,l3), - * AOcoeffs(1,1,l3),onecartY(1,1,ipnt(m1+l1+1,m2+l2+1),l1), - * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) - else - if (NFINI) call two2mean12a(CartSO,CartOO,occup(1,l3), - * AOcoeffs(1,1,l3),onecartY(1,1,ipnt(m1+l1+1,m2+l2+1),l1), - * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) - endif - endif - if (m1.gt.m2.anD.Iabs(m1-m2).eq.1) then -cbs for the "Bonn-approach" exchange carteYOO by carteYSO - if (bonn.or.breiT) then - if (NFINI) call two2mean12b(CartSO,CartSO,occup(1,l3), - * AOcoeffs(1,1,l3),onecartY(1,1,ipnt(m1+l1+1,m2+l2+1),l1), - * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) - else - if (NFINI) call two2mean12b(CartSO,CartOO,occup(1,l3), - * AOcoeffs(1,1,l3),onecartY(1,1,ipnt(m1+l1+1,m2+l2+1),l1), - * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) - endif - endif - endif - endif - endif ! If (NFINI) Then -c####################################################################### -c############ mean-field-part ######################################### -c####################################################################### - endif -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C++++++++++++++++ SIGMA Z ++++++++++++++++++++++++++++++++++++ -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - elseif (indx.eq.1.and.indy.eq.1.and.indz.eq.0.and. - * icheckz(iabs(m1),iabs(m2),iabs(m3),iabs(m4)).gt.0) then -! X*Y transforms like L_z (A2) -cbs integrals for sigma_z - mblockz=mblockz+1 - mcombcart(1,m1,m2,m3,m4)=3 - mcombcart(2,m1,m2,m3,m4)=mblockz - call tosigZ(m1,m2,m3,m4,angSO(1+iangfirst), - * mcombina,ncontrac(l1),ncontrac(l2),ncontrac(l3), - * ncontrac(l4),CartSO,preXZ, - * interxyz(1,iabs(m1),iabs(m2),iabs(m3),iabs(m4)), - * isgnprod,cleaner) -c - if (.not.bonn.and.(.not.breit)) - * call tosigZ(m1,m2,m3,m4,AngOO(1+iangfirst), - * mcombina,ncontrac(l1),ncontrac(l2),ncontrac(l3), - * ncontrac(l4),CartOO,preXZ, - * interxyz(1,iabs(m1),iabs(m2),iabs(m3),iabs(m4)), - * isgnprod,cleaner) - if (makemean) then ! generate mean-field-contributions -c####################################################################### -c############ mean-field-part ######################################### -c####################################################################### - if (l1.eq.l3.and.l2.eq.l4) then - if (m2.eq.m4.and.m1.lt.m3. - * and.m1.eq.-m3.and.l1.ne.0) then - call two2mean13(CartSO,occup(1,l2), - * AOcoeffs(1,1,l2),onecartz(1,1,ipnt(m1+l1+1,m3+l3+1),l1), - * ncontrac(l1),ncontrac(l2),noccorb(l2)) - endif - endif -* - If (NFINI) Then - if (l1.eq.l2.and.l3.eq.l4) then - if (m1.eq.m2.and.l3.ne.0.and.l3.ne.l1) then - if (m3.lt.m4.and.m3.eq.-m4) then -cbs for the "Bonn-approach" exchange carteOO by carteSO - if (bonn.or.breiT) then - if (NFINI) call two2mean34a(CartSO,CartSO,occup(1,l1), - * AOcoeffs(1,1,l1),onecartz(1,1,ipnt(m3+l3+1,m4+l4+1),l3), - * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) - else - if (NFINI) call two2mean34a(CartSO,CartOO,occup(1,l1), - * AOcoeffs(1,1,l1),onecartz(1,1,ipnt(m3+l3+1,m4+l4+1),l3), - * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) - endif - endif - if (m3.gt.m4.and.m3.eq.-m4) then -cbs for the "Bonn-approach" exchange carteOO by carteSO - if (bonn.or.breiT) then - if (NFINI) call two2mean34b(CartSO,CartSO,occup(1,l1), - * AOcoeffs(1,1,l1),onecartz(1,1,ipnt(m3+l3+1,m4+l4+1),l3), - * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) - else - if (NFINI) call two2mean34b(CartSO,CartOO,occup(1,l1), - * AOcoeffs(1,1,l1),onecartz(1,1,ipnt(m3+l3+1,m4+l4+1),l3), - * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) - endif - endif - elseif(m3.eq.m4.and.l1.ne.0) then - if (m1.lt.m2.and.m1.eq.-m2) then -cbs for the "Bonn-approach" exchange carteOO by carteSO - if (bonn.or.breiT) then - if (NFINI) call two2mean12a(CartSO,CartSO,occup(1,l3), - * AOcoeffs(1,1,l3),onecartz(1,1,ipnt(m1+l1+1,m2+l2+1),l1), - * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) - else - if (NFINI) call two2mean12a(CartSO,CartOO,occup(1,l3), - * AOcoeffs(1,1,l3),onecartz(1,1,ipnt(m1+l1+1,m2+l2+1),l1), - * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) - endif - endif - if (m1.gt.m2.and.m1.eq.-m2) then -cbs for the "Bonn-approach" exchange carteOO by carteSO - if (bonn.or.breiT) then - if (NFINI) call two2mean12b(cartSO,CartSO, - * occup(1,l3), - * AOcoeffs(1,1,l3),onecartz(1,1,ipnt(m1+l1+1,m2+l2+1),l1), - * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) - else - if (NFINI) call two2mean12b(cartSO,cartOO,occup(1,l3), - * AOcoeffs(1,1,l3),onecartz(1,1,ipnt(m1+l1+1,m2+l2+1),l1), - * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) - endif - endif - endif - endif - endif ! If (NFINI) Then -c####################################################################### -c############ mean-field-part ######################################### -c####################################################################### - endif - endif -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - endif ! for check of significance for meanfield. - enddo - enddo - enddo - enddo - numbcart=numbcart+(mblockx+mblocky+mblockz)*ncont -cbs just controlling if x and y integrals have the same number of -cbs blocks - if (mblockx.ne.mblocky) then - write(6,*) - *'numbers of integrals for sigma_x and sigma_y not equal!' - write(6,'(A12,4I3,2(A3,I5))') - *'l1,l2,l3,l4 ',l1,l2,l3,l4,' X:',mblockx,' Y:',mblocky - write(6,*) ' check the ipowxyz-array' - Call Abend() - endif -cbs start adresses for the next block of integrals - Call mma_deallocate(AngSO) - Call mma_deallocate(AngOO) - Call mma_deallocate(CartSO) - Call mma_deallocate(CartOO) - Call mma_deallocate(ConSO) - Call mma_deallocate(ConOO) - endif - endif - endif - endif - enddo - enddo - enddo - enddo - return -c Avoid unused argument warnings - if (.false.) call Unused_logical(keepcart) - end diff -Nru openmolcas-22.02/src/amfi_util/angular.F90 openmolcas-22.10/src/amfi_util/angular.F90 --- openmolcas-22.02/src/amfi_util/angular.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/angular.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,664 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine angular(Lhigh,keep,makemean,bonn,breit,sameorb,ifinite,onecartx,onecarty,onecartz,powexp,coulovlp,preXZ,preY,icheckxy, & + icheckz,interxyz,isgnprod) +!bs COMBINES THE RADIAL INTEGRALS WITH THE ANGULAR FACTORS +! +!bs if keep=.true. then +!bs all the integrals will be kept in memory. +!bs Perhaps, there will be the option to make the +!bs transformation to the cartesian basis-sets +!bs everytime, they are required. +!bs Therefore, the integrals are kept in memory and +!bs can be further transformed, whenever required. +!bs in order not to waste to much memory, the atomic +!bs integrals are thrown away after each l,l,l,l-block + +use AMFI_global, only: AOcoeffs, ipowxyz, Lblocks, Lfirst, Llast, Lmax, Lstarter, MxcontL, MxprimL, ncontrac, noccorb, occup +use index_functions, only: iTri +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, Two, Quart +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: Lhigh, ifinite +logical(kind=iwp), intent(in) :: keep, makemean, bonn, breit, sameorb +real(kind=wp), intent(inout) :: onecartX(MxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1),Lmax), & + onecartY(MxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1),Lmax), & + onecartZ(MxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1),Lmax) +real(kind=wp), intent(in) :: powexp(MxprimL,MxprimL,0:Lmax,0:Lmax,0:(Lmax+Lmax+5)), coulovlp(*) +real(kind=wp), intent(out) :: preXZ(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), preY(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) +integer(kind=iwp), intent(out) :: icheckxy(0:Lmax,0:Lmax,0:Lmax,0:Lmax), icheckz(0:Lmax,0:Lmax,0:Lmax,0:Lmax), & + interxyz(16,0:Lmax,0:Lmax,0:Lmax,0:Lmax), isgnprod(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) +integer(kind=iwp) :: iangfirst, icont4, indx, indy, indz, inter2, inter3, inter4, isignM(-Lmax:Lmax), jblock, l1, l2, l3, l4, & + Lleftmax, Lleftmin, locstar, Lrightmax, Lrightmin, M1, m1upper, M2, m2upper, M3, M4, mblock, mblockx, & + mblocky, mblockz, mxangint, ncont, numbcart +real(kind=wp) :: preroots(2,0:Lmax), scratch(0:2*Lmax+1) +logical(kind=iwp) :: cleaner, NFINI +integer(kind=iwp), allocatable :: mcombcart(:,:,:,:,:), mcombina(:,:,:,:,:) +real(kind=wp), allocatable :: clebsch(:,:,:,:), ConOO(:), ConSO(:), CartOO(:), CartSO(:), AngOO(:), AngSO(:) +!bs NFINI means not finite nucleus + +!bs #################################################################### +!bs some preparation of factors needed later on.. # +!bs #################################################################### +!bs calculate some prefactors that will be needed quite often +call mma_allocate(clebsch,[1,3],[1,2],[-Lmax,Lmax],[0,Lmax],label='clebsch') +call prefac(Lmax,preroots,clebsch) +if (ifinite /= 2) then + !bs clean array for one electron integrals + onecartX(:,:,:,:) = Zero + onecartY(:,:,:,:) = Zero + onecartZ(:,:,:,:) = Zero + NFINI = .true. +else + NFINI = .false. +end if + +!bs generate an array with sign for (even/odd) m-values +if (mod(Lmax,2) == 0) then + isignM(-Lmax:Lmax:2) = 1 + isignM(-Lmax+1:Lmax-1:2) = -1 +else + isignM(-Lmax:Lmax:2) = -1 + isignM(-Lmax+1:Lmax-1:2) = 1 +end if +!bs #################################################################### +!bs prefactors preXZ und preY include the factors 1/root(2) +!bs for the +/- linear combinations of spherical harmonics +!bs #################################################################### +preXZ(:,:,:,:) = Quart +preXZ(:,:,:,0) = preXZ(:,:,:,0)*sqrt(Two) +preXZ(:,:,0,:) = preXZ(:,:,0,:)*sqrt(Two) +preXZ(:,0,:,:) = preXZ(:,0,:,:)*sqrt(Two) +preXZ(0,:,:,:) = preXZ(0,:,:,:)*sqrt(Two) +preY(:,:,:,:) = preXZ(:,:,:,:) +!bs #################################################################### +!bs additional (-) signs from the (-i) factors in the +!bs (-) linear combinations (see tosigX(Y,Z)) +!bs #################################################################### +!bs + - - - => minus +preXZ(0:,:-1,:-1,:-1) = -preXZ(0:,:-1,:-1,:-1) +!bs - + - - => minus +preXZ(:-1,0:,:-1,:-1) = -preXZ(:-1,0:,:-1,:-1) +!bs + + + - => minus +preXZ(0:,0:,0:,:-1) = -preXZ(0:,0:,0:,:-1) +!bs + + - + => minus +preXZ(0:,0:,:-1,0:) = -preXZ(0:,0:,:-1,0:) +!bs + + - - => minus +preY(0:,0:,:-1,:-1) = -preY(0:,0:,:-1,:-1) +!bs - - + + => minus +preY(:-1,:-1,0:,0:) = -preY(:-1,:-1,0:,0:) +call genprexyz13(icheckxy) +call genprexyz14(icheckz,interxyz) +call genprexyz15a(icheckxy,icheckz,interxyz) +!bs #################################################################### +!bs isgnprod gives the sign due to powers (-1)**M this are again +!bs angular m-values +!bs #################################################################### +do M4=-Lmax,Lmax + if (M4 > 0) then + inter4 = isignM(M4) + else + inter4 = 1 + end if + do M3=-Lmax,Lmax + if (M3 > 0) then + inter3 = inter4*isignM(M3) + else + inter3 = inter4 + end if + do M2=-Lmax,Lmax + if (M2 > 0) then + inter2 = inter3*isignM(M2) + else + inter2 = inter3 + end if + do M1=-Lmax,Lmax + if (M1 > 0) then + isgnprod(m1,m2,m3,m4) = inter2*isignM(M1) + else + isgnprod(m1,m2,m3,m4) = inter2 + end if + end do + end do + end do +end do +!bs #################################################################### +!bs some preparation of factors needed later on.. finished # +!bs #################################################################### + +! set some counters +call mma_allocate(mcombina,[1,2],[-Lmax,Lmax],[-Lmax,Lmax],[-Lmax,Lmax],[-Lmax,Lmax],label='mcombina') +call mma_allocate(mcombcart,[1,2],[-Lmax,Lmax],[-Lmax,Lmax],[-Lmax,Lmax],[-Lmax,Lmax],label='mcombcart') +!bs counter for total number of cartesian integrals +numbcart = 0 +!bs same orbit integrals integrals on carteXSO carteYSO and carteSO +!bs other orbit integrals on carteXOO carteYOO and carteOO +iangfirst = 0 ! first block of angular integrals +!bs loop over all possible < l1 l2, l3 l4 > blocks +!BS write(u6,'(A)') ' L1 L2 L3 L4' +do l1=0,Lhigh ! improving is probably possible... + do l2=0,Lhigh + do l3=0,l1 + do l4=0,l2 + !bs check parity + if (mod(l1+l2+l3+l4,2) == 0) then + !bs check that Lleft and Lright do not always differ by more than one + !bs a difference of two means two spin flips and is therefore not allowed + Lleftmax = l1+l2 + Lrightmax = l3+l4 + Lleftmin = abs(l1-l2) + Lrightmin = abs(l3-l4) + if (((Lrightmin-Lleftmax <= 1) .and. (Lrightmax-Lleftmin > -1)) .or. & + ((Lleftmin-Lrightmax <= 1) .and. (Lleftmax-Lrightmin > -1))) then + !bs additional check for mean-field + if (((l1 == l3) .and. (l2 == l4)) .or. ((l1 == l2) .and. (l3 == l4))) then + if (l1+l3 /= 0) then + !BS write(u6,'(4I5)') l1,l2,l3,l4 + !BS now I determine the size of the angular integral arrays + jblock = 0 + do m1=-l1,l1 + do m2=-l2,l2 + do m3=-l3,l3 + m4 = m1+m2-m3+1 + if (abs(m4) <= l4) then + if ((.not. makemean) .or. ((l1 == l3) .and. (l2 == l4) .and. (abs(m2) == abs(m4))) .or. & + ((l1 == l2) .and. (l3 == l4) .and. ((abs(m1) == abs(m2)) .or. (abs(m3) == abs(m4))))) then + jblock = jblock+1 + end if + end if + end do + end do + end do + do m1=0,l1 + do m2=-l2,l2 + do m3=-l3,l3 + m4 = m1+m2-m3 + if ((.not. makemean) .or. ((l1 == l3) .and. (l2 == l4) .and. (abs(m2) == abs(m4))) .or. & + ((l1 == l2) .and. (l3 == l4) .and. ((abs(m1) == abs(m2)) .or. (abs(m3) == abs(m4))))) then + if ((m1 /= 0) .or. (m2 /= 0) .or. (m3 /= 0)) then ! all m=0 make no sense + if (abs(m4) <= l4) then + jblock = jblock+1 + end if + end if + end if + end do + end do + end do + !BS done !! + !bs number of contracted integrals for each block + ncont = ncontrac(l1)*ncontrac(l2)*ncontrac(l3)*ncontrac(l4) + mxangint = jblock*ncont + !bs determine the size icont4 for the radial integrals + call gencoulDIM(l1,l2,l3,l4,makemean,icont4) + + call mma_allocate(ANGSO,mxangint,Label='AngSO') + call mma_allocate(ANGOO,mxangint,Label='AngOO') + call mma_allocate(CartSO,nCont,Label='CartSO') + call mma_allocate(CartOO,nCont,Label='CartOO') + call mma_allocate(ConSO,iCont4,Label='ConSO') + call mma_allocate(ConOO,iCont4,Label='ConOO') + + call gencoul(l1,l2,l3,l4,makemean,bonn,breit,sameorb,conSO,conOO,icont4,powexp,coulovlp) + ! gen and trans integrals + !bs local counter for integral adresses + mblock = 0 ! counter of (m,m,m,m)-blocks for (l1,l2,l3,l4) + !bs if keep is set to false, the angular integrals are + !bs thrown away after each block of l-values + !bs which means integrals start at address 0 + if (.not. keep) iangfirst = 0 + locstar = iangfirst ! local starting adress counter + ! col 1 will hold type of integrals (1,2,3) + ! col 2 will hold number of block + mcombina(:,-l1:l1,-l2:l2,-l3:l3,-l4:l4) = 0 + do m1=-l1,l1 + do m2=-l2,l2 + do m3=-l3,l3 + !bs m4 is more or less fixed by m1-3 + !####################################################################### + !####################################################################### + !########## the L- -type block to be combined with sigma+ ############## + !####################################################################### + !####################################################################### + m4 = m1+m2-m3+1 + if (abs(m4) <= l4) then !the L- -block to combine with sigma+ + !bs not all m-combinations are needed for the mean-field + if ((.not. makemean) .or. ((l1 == l3) .and. (l2 == l4) .and. (abs(m2) == abs(m4))) .or. & + ((l1 == l2) .and. (l3 == l4) .and. ((abs(m1) == abs(m2)) .or. (abs(m3) == abs(m4))))) then + mcombina(1,m1,m2,m3,m4) = 1 + mblock = mblock+1 + if (locstar+ncont > mxangint) then + write(u6,*) 'not enough space allocated for angular integrals' + write(u6,*) 'increase mxangint to at least ',locstar+ncont + call Abend() + end if + !bs mkangLmin = make_angular_integrals_for_L- type operator + !bs really generates the angular prefactors and combines them with + !bs the radial integrals + call mkangLmin(Lmax,l1,l2,l3,l4,m1,m2,m3,m4,AngSO(1+locstar),AngOO(1+locstar),Lfirst,Llast,Lblocks, & + ncontrac(l1),ncontrac(l2),ncontrac(l3),ncontrac(l4),ConSO(Lstarter(1)), & + ConSO(Lstarter(2)),ConSO(Lstarter(3)),ConSO(Lstarter(4)),ConOO(Lstarter(1)), & + ConOO(Lstarter(2)),ConOO(Lstarter(3)),ConOO(Lstarter(4)),preroots,clebsch,scratch,bonn, & + breit,sameorb) + locstar = locstar+ncont ! increase starting address + mcombina(2,m1,m2,m3,m4) = mblock ! set the block number + !####################################################################### + !####################################################################### + !########## the L+ -type block to be combined with sigma- ############## + !####################################################################### + !####################################################################### + + ! these integrals are obtained by changing the signs of the m-values. + ! As the integrals are the same, the pointer points to the same integrals... + + mcombina(1,-m1,-m2,-m3,-m4) = 3 + mcombina(2,-m1,-m2,-m3,-m4) = mblock + end if + end if + end do + end do + end do + !####################################################################### + !####################################################################### + !########## the L0 -type block to be combined with sigma0 ############## + !####################################################################### + !####################################################################### + do m1=0,l1 + do m2=-l2,l2 + do m3=-l3,l3 + !bs m4 is more or less fixed by m1-3 + m4 = m1+m2-m3 ! the L0-block to be combined with sigma0 + !bs not all m-combinations are needed for the mean-field + if ((.not. makemean) .or. ((l1 == l3) .and. (l2 == l4) .and. (abs(m2) == abs(m4))) .or. & + ((l1 == l2) .and. (l3 == l4) .and. ((abs(m1) == abs(m2)) .or. (abs(m3) == abs(m4))))) then + + if ((m1 /= 0) .or. (m2 /= 0) .or. (m3 /= 0)) then !all m=0 make no sense + if (abs(m4) <= l4) then + mcombina(1,m1,m2,m3,m4) = 2 + mblock = mblock+1 + if (locstar+ncont > mxangint) then + write(u6,*) 'not enough space allocated for angular integrals' + write(u6,*) 'increase mxangint to at least ',locstar+ncont + call Abend() + end if + call mkangL0(Lmax,l1,l2,l3,l4,m1,m2,m3,m4,angSO(1+locstar),AngOO(1+locstar),Lfirst,Llast,Lblocks, & + ncontrac(l1),ncontrac(l2),ncontrac(l3),ncontrac(l4),ConSO(Lstarter(1)), & + ConSO(Lstarter(2)),ConSO(Lstarter(3)),ConSO(Lstarter(4)),ConOO(Lstarter(1)), & + ConOO(Lstarter(2)),ConOO(Lstarter(3)),ConOO(Lstarter(4)),preroots,clebsch,scratch,bonn, & + breit,sameorb) + locstar = locstar+ncont + mcombina(2,m1,m2,m3,m4) = mblock + end if + end if + end if + end do + end do + end do + !bs ################################################################### + !bs ################################################################### + !bs transformation to l,m dependent integrals is finished + !bs ################################################################### + + !bs ################################################################### + !bs begin transformation to cartesian integrals + !bs ################################################################### + !bs ################################################################### + !bs check out, which combinations of m-values will + !bs contribute to cartesian integrals + ! col 1 will hold the type x=1 y=2 z=3 + ! col 2 will hold the block number + mcombcart(:,-l1:l1,-l2:l2,-l3:l3,-l4:l4) = 0 + mblockx = 0 + mblocky = 0 + mblockz = 0 + do m3=-l3,l3 + do m4=-l4,l4 + !bs if the l-values are the same : triangular matrix over m-values + !bs is sufficient + if (l1 == l3) then + m1upper = m3 + else + m1upper = l1 + end if + if (makemean) m1upper = l1 + !bs if the l-values are the same : triangular matrix over m-values + !bs is sufficient + if (l2 == l4) then + m2upper = m4 + else + m2upper = l2 + end if + if (makemean) m2upper = l2 + do m1=-l1,m1upper + if ((l1 == l3) .and. (m1 == m3)) then ! clean real zeros by symmetry + !bs this a problem of the spin-other-orbit integrals, as they are by + !bs formula not antisymmetric in the indices for particle 1. + cleaner = .true. + else + cleaner = .false. + end if + do m2=-l2,m2upper + !bs not all m-combinations are needed for the mean-field + if ((.not. makemean) .or. ((l1 == l3) .and. (l2 == l4) .and. (m2 == m4)) .or. & + ((l1 == l2) .and. (l3 == l4) .and. ((m1 == m2) .or. (m3 == m4)))) then + + indx = ipowxyz(1,m1,l1)+ipowxyz(1,m2,l2)+ipowxyz(1,m3,l3)+ipowxyz(1,m4,l4) + indy = ipowxyz(2,m1,l1)+ipowxyz(2,m2,l2)+ipowxyz(2,m3,l3)+ipowxyz(2,m4,l4) + indz = ipowxyz(3,m1,l1)+ipowxyz(3,m2,l2)+ipowxyz(3,m3,l3)+ipowxyz(3,m4,l4) + indx = mod(indx,2) + indy = mod(indy,2) + indz = mod(indz,2) + if ((indx == 0) .and. (indy == 1) .and. (indz == 1) .and. & + (icheckxy(abs(m1),abs(m2),abs(m3),abs(m4)) > 0)) then + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + !++++++++++++++++ SIGMA X ++++++++++++++++++++++++++++++++++++ + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Y*Z -> transforms like L_x (B1) + !bs integrals for sigma_x + mblockx = mblockx+1 + mcombcart(1,m1,m2,m3,m4) = 1 + mcombcart(2,m1,m2,m3,m4) = mblockx + call tosigX(m1,m2,m3,m4,AngSO(1+iangfirst),mcombina,ncontrac(l1),ncontrac(l2),ncontrac(l3), & + ncontrac(l4),CartSO,preXZ,interxyz(1,abs(m1),abs(m2),abs(m3),abs(m4)),isgnprod,cleaner) + + if ((.not. bonn) .and. (.not. breit)) & + call tosigX(m1,m2,m3,m4,AngOO(1+iangfirst),mcombina,ncontrac(l1),ncontrac(l2),ncontrac(l3), & + ncontrac(l4),cartOO,preXZ,interxyz(1,abs(m1),abs(m2),abs(m3),abs(m4)),isgnprod,cleaner) + if (makemean) then ! generate mean-field-contributions + !####################################################################### + !############ mean-field-part ######################################### + !####################################################################### + if ((l1 == l3) .and. (l2 == l4)) then + if ((m2 == m4) .and. (m1 < m3) .and. (abs(m1+m3) == 1) .and. (l1 /= 0)) then + call two2mean13(CartSO,occup(1,l2),AOcoeffs(1,1,l2),onecartx(1,1,iTri(m1+l1+1,m3+l3+1),l1), & + ncontrac(l1),ncontrac(l2),noccorb(l2)) + end if + end if + + if (NFINI) then + if ((l1 == l2) .and. (l3 == l4)) then + if ((m1 == m2) .and. (l3 /= 0) .and. (l3 /= l1)) then + if ((m3 < m4) .and. (abs(m4+m3) == 1)) then + !bs for the "Bonn-approach" exchange cartexOO by cartexSO + if (bonn .or. breit) then + if (NFINI) call two2mean34a(cartSO,cartSO,occup(1,l1),AOcoeffs(1,1,l1), & + onecartx(1,1,iTri(m3+l3+1,m4+l4+1),l3),ncontrac(l3), & + ncontrac(l1),noccorb(l2),sameorb) + else + if (NFINI) call two2mean34a(cartSO,cartOO,occup(1,l1),AOcoeffs(1,1,l1), & + onecartx(1,1,iTri(m3+l3+1,m4+l4+1),l3),ncontrac(l3), & + ncontrac(l1),noccorb(l2),sameorb) + end if + end if + if ((m3 > m4) .and. (abs(m4+m3) == 1)) then + !bs for the "Bonn-approach" exchange cartexOO by cartexSO + if (bonn .or. breit) then + if (NFINI) call two2mean34b(CartSO,CartSO,occup(1,l1),AOcoeffs(1,1,l1), & + onecartx(1,1,iTri(m3+l3+1,m4+l4+1),l3),ncontrac(l3), & + ncontrac(l1),noccorb(l2),sameorb) + else + if (NFINI) call two2mean34b(CartSO,CartOO,occup(1,l1),AOcoeffs(1,1,l1), & + onecartx(1,1,iTri(m3+l3+1,m4+l4+1),l3),ncontrac(l3), & + ncontrac(l1),noccorb(l2),sameorb) + end if + end if + else if ((m3 == m4) .and. (l1 /= 0)) then + if (m1 < m2 .and. abs(m1+m2) == 1) then + !bs for the "Bonn-approach" exchange cartexOO by cartexSO + if (bonn .or. breit) then + if (NFINI) call two2mean12a(CartSO,CartSO,occup(1,l3),AOcoeffs(1,1,l3), & + onecartx(1,1,iTri(m1+l1+1,m2+l2+1),l1),ncontrac(l1), & + ncontrac(l3),noccorb(l3),sameorb) + else + if (NFINI) call two2mean12a(CartSO,cartOO,occup(1,l3),AOcoeffs(1,1,l3), & + onecartx(1,1,iTri(m1+l1+1,m2+l2+1),l1),ncontrac(l1), & + ncontrac(l3),noccorb(l3),sameorb) + end if + end if + if ((m1 > m2) .and. (abs(m1+m2) == 1)) then + !bs for the "Bonn-approach" exchange cartexOO by cartexSO + if (bonn .or. breit) then + if (NFINI) call two2mean12b(cartSO,CartSO,occup(1,l3),AOcoeffs(1,1,l3), & + onecartx(1,1,iTri(m1+l1+1,m2+l2+1),l1),ncontrac(l1), & + ncontrac(l3),noccorb(l3),sameorb) + else + if (NFINI) call two2mean12b(CartSO,CartOO,occup(1,l3),AOcoeffs(1,1,l3), & + onecartx(1,1,iTri(m1+l1+1,m2+l2+1),l1),ncontrac(l1), & + ncontrac(l3),noccorb(l3),sameorb) + end if + end if + end if + end if + end if ! If (NFINI) Then + !####################################################################### + !############ mean-field-part ######################################### + !####################################################################### + end if + else if ((indx == 1) .and. (indy == 0) .and. (indz == 1) .and. & + (icheckxy(abs(m1),abs(m2),abs(m3),abs(m4)) > 0)) then + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + !++++++++++++++++ SIGMA Y ++++++++++++++++++++++++++++++++++++ + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! X*Z transforms like L_y (B2) + !bs integrals for sigma_y + mblocky = mblocky+1 + mcombcart(1,m1,m2,m3,m4) = 2 + mcombcart(2,m1,m2,m3,m4) = mblocky + call tosigY(m1,m2,m3,m4,AngSO(1+iangfirst),mcombina,ncontrac(l1),ncontrac(l2),ncontrac(l3), & + ncontrac(l4),CartSO,preY,interxyz(1,abs(m1),abs(m2),abs(m3),abs(m4)),isgnprod,cleaner) + + if ((.not. bonn) .and. (.not. breit)) & + call tosigY(m1,m2,m3,m4,AngOO(1+iangfirst),mcombina,ncontrac(l1),ncontrac(l2),ncontrac(l3), & + ncontrac(l4),cartOO,preY,interxyz(1,abs(m1),abs(m2),abs(m3),abs(m4)),isgnprod,cleaner) + if (makemean) then ! generate mean-field-contributions + !####################################################################### + !############ mean-field-part ######################################### + !####################################################################### + if ((l1 == l3) .and. (l2 == l4)) then + if ((m2 == m4) .and. (m1 < m3) .and. (abs(m3-m1) == 1) .and. (l1 /= 0)) then + call two2mean13(CartSO,occup(1,l2),AOcoeffs(1,1,l2),onecartY(1,1,iTri(m1+l1+1,m3+l3+1),l1), & + ncontrac(l1),ncontrac(l2),noccorb(l2)) + end if + end if + + if (NFINI) then + if ((l1 == l2) .and. (l3 == l4)) then + if ((m1 == m2) .and. (l3 /= 0) .and. (l3 /= l1)) then + if ((m3 < m4) .and. (abs(m3-m4) == 1)) then + !bs for the "Bonn-approach" exchange carteYOO by carteYSO + if (bonn .or. breit) then + if (NFINI) call two2mean34a(CartSO,CartSO,occup(1,l1),AOcoeffs(1,1,l1), & + onecartY(1,1,iTri(m3+l3+1,m4+l4+1),l3),ncontrac(l3), & + ncontrac(l1),noccorb(l2),sameorb) + else + if (NFINI) call two2mean34a(CartSO,CartOO,occup(1,l1),AOcoeffs(1,1,l1), & + onecartY(1,1,iTri(m3+l3+1,m4+l4+1),l3),ncontrac(l3), & + ncontrac(l1),noccorb(l2),sameorb) + end if + end if + if ((m3 > m4) .and. (abs(m3-m4) == 1)) then + !bs for the "Bonn-approach" exchange carteYOO by carteYSO + if (bonn .or. breit) then + if (NFINI) call two2mean34b(CartSO,CartSO,occup(1,l1),AOcoeffs(1,1,l1), & + onecartY(1,1,iTri(m3+l3+1,m4+l4+1),l3),ncontrac(l3), & + ncontrac(l1),noccorb(l2),sameorb) + else + if (NFINI) call two2mean34b(CartSO,CartOO,occup(1,l1),AOcoeffs(1,1,l1), & + onecartY(1,1,iTri(m3+l3+1,m4+l4+1),l3),ncontrac(l3), & + ncontrac(l1),noccorb(l2),sameorb) + end if + end if + else if ((m3 == m4) .and. (l1 /= 0)) then + if ((m1 < m2) .and. (abs(m1-m2) == 1)) then + !bs for the "Bonn-approach" exchange carteOO by carteSO + if (bonn .or. breit) then + if (NFINI) call two2mean12a(CartSO,CartSO,occup(1,l3),AOcoeffs(1,1,l3), & + onecartY(1,1,iTri(m1+l1+1,m2+l2+1),l1),ncontrac(l1), & + ncontrac(l3),noccorb(l3),sameorb) + else + if (NFINI) call two2mean12a(CartSO,CartOO,occup(1,l3),AOcoeffs(1,1,l3), & + onecartY(1,1,iTri(m1+l1+1,m2+l2+1),l1),ncontrac(l1), & + ncontrac(l3),noccorb(l3),sameorb) + end if + end if + if ((m1 > m2) .and. (abs(m1-m2) == 1)) then + !bs for the "Bonn-approach" exchange carteYOO by carteYSO + if (bonn .or. breit) then + if (NFINI) call two2mean12b(CartSO,CartSO,occup(1,l3),AOcoeffs(1,1,l3), & + onecartY(1,1,iTri(m1+l1+1,m2+l2+1),l1),ncontrac(l1), & + ncontrac(l3),noccorb(l3),sameorb) + else + if (NFINI) call two2mean12b(CartSO,CartOO,occup(1,l3),AOcoeffs(1,1,l3), & + onecartY(1,1,iTri(m1+l1+1,m2+l2+1),l1),ncontrac(l1), & + ncontrac(l3),noccorb(l3),sameorb) + end if + end if + end if + end if + end if ! If (NFINI) Then + !####################################################################### + !############ mean-field-part ######################################### + !####################################################################### + end if + else if ((indx == 1) .and. (indy == 1) .and. (indz == 0) .and. & + (icheckz(abs(m1),abs(m2),abs(m3),abs(m4)) > 0)) then + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + !++++++++++++++++ SIGMA Z ++++++++++++++++++++++++++++++++++++ + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! X*Y transforms like L_z (A2) + !bs integrals for sigma_z + mblockz = mblockz+1 + mcombcart(1,m1,m2,m3,m4) = 3 + mcombcart(2,m1,m2,m3,m4) = mblockz + call tosigZ(m1,m2,m3,m4,angSO(1+iangfirst),mcombina,ncontrac(l1),ncontrac(l2),ncontrac(l3), & + ncontrac(l4),CartSO,preXZ,interxyz(1,abs(m1),abs(m2),abs(m3),abs(m4)),isgnprod,cleaner) + + if ((.not. bonn) .and. (.not. breit)) & + call tosigZ(m1,m2,m3,m4,AngOO(1+iangfirst),mcombina,ncontrac(l1),ncontrac(l2),ncontrac(l3), & + ncontrac(l4),CartOO,preXZ,interxyz(1,abs(m1),abs(m2),abs(m3),abs(m4)),isgnprod,cleaner) + if (makemean) then ! generate mean-field-contributions + !####################################################################### + !############ mean-field-part ######################################### + !####################################################################### + if ((l1 == l3) .and. (l2 == l4)) then + if ((m2 == m4) .and. (m1 < m3) .and. (m1 == -m3) .and. (l1 /= 0)) then + call two2mean13(CartSO,occup(1,l2),AOcoeffs(1,1,l2),onecartz(1,1,iTri(m1+l1+1,m3+l3+1),l1), & + ncontrac(l1),ncontrac(l2),noccorb(l2)) + end if + end if + + if (NFINI) then + if ((l1 == l2) .and. (l3 == l4)) then + if ((m1 == m2) .and. (l3 /= 0) .and. (l3 /= l1)) then + if ((m3 < m4) .and. (m3 == -m4)) then + !bs for the "Bonn-approach" exchange carteOO by carteSO + if (bonn .or. breit) then + if (NFINI) call two2mean34a(CartSO,CartSO,occup(1,l1),AOcoeffs(1,1,l1), & + onecartz(1,1,iTri(m3+l3+1,m4+l4+1),l3),ncontrac(l3), & + ncontrac(l1),noccorb(l2),sameorb) + else + if (NFINI) call two2mean34a(CartSO,CartOO,occup(1,l1),AOcoeffs(1,1,l1), & + onecartz(1,1,iTri(m3+l3+1,m4+l4+1),l3),ncontrac(l3), & + ncontrac(l1),noccorb(l2),sameorb) + end if + end if + if ((m3 > m4) .and. (m3 == -m4)) then + !bs for the "Bonn-approach" exchange carteOO by carteSO + if (bonn .or. breit) then + if (NFINI) call two2mean34b(CartSO,CartSO,occup(1,l1),AOcoeffs(1,1,l1), & + onecartz(1,1,iTri(m3+l3+1,m4+l4+1),l3),ncontrac(l3), & + ncontrac(l1),noccorb(l2),sameorb) + else + if (NFINI) call two2mean34b(CartSO,CartOO,occup(1,l1),AOcoeffs(1,1,l1), & + onecartz(1,1,iTri(m3+l3+1,m4+l4+1),l3),ncontrac(l3), & + ncontrac(l1),noccorb(l2),sameorb) + end if + end if + else if ((m3 == m4) .and. (l1 /= 0)) then + if (m1 < m2 .and. m1 == -m2) then + !bs for the "Bonn-approach" exchange carteOO by carteSO + if (bonn .or. breit) then + if (NFINI) call two2mean12a(CartSO,CartSO,occup(1,l3),AOcoeffs(1,1,l3), & + onecartz(1,1,iTri(m1+l1+1,m2+l2+1),l1),ncontrac(l1), & + ncontrac(l3),noccorb(l3),sameorb) + else + if (NFINI) call two2mean12a(CartSO,CartOO,occup(1,l3),AOcoeffs(1,1,l3), & + onecartz(1,1,iTri(m1+l1+1,m2+l2+1),l1),ncontrac(l1), & + ncontrac(l3),noccorb(l3),sameorb) + end if + end if + if ((m1 > m2) .and. (m1 == -m2)) then + !bs for the "Bonn-approach" exchange carteOO by carteSO + if (bonn .or. breit) then + if (NFINI) call two2mean12b(cartSO,CartSO,occup(1,l3),AOcoeffs(1,1,l3), & + onecartz(1,1,iTri(m1+l1+1,m2+l2+1),l1),ncontrac(l1), & + ncontrac(l3),noccorb(l3),sameorb) + else + if (NFINI) call two2mean12b(cartSO,cartOO,occup(1,l3),AOcoeffs(1,1,l3), & + onecartz(1,1,iTri(m1+l1+1,m2+l2+1),l1),ncontrac(l1), & + ncontrac(l3),noccorb(l3),sameorb) + end if + end if + end if + end if + end if ! If (NFINI) Then + !####################################################################### + !############ mean-field-part ######################################### + !####################################################################### + end if + end if + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + end if ! for check of significance for meanfield. + end do + end do + end do + end do + numbcart = numbcart+(mblockx+mblocky+mblockz)*ncont + !bs just controlling if x and y integrals have the same number of blocks + if (mblockx /= mblocky) then + write(u6,*) 'numbers of integrals for sigma_x and sigma_y not equal!' + write(u6,'(A12,4I3,2(A3,I5))') 'l1,l2,l3,l4 ',l1,l2,l3,l4,' X:',mblockx,' Y:',mblocky + write(u6,*) ' check the ipowxyz-array' + call Abend() + end if + !bs start adresses for the next block of integrals + call mma_deallocate(AngSO) + call mma_deallocate(AngOO) + call mma_deallocate(CartSO) + call mma_deallocate(CartOO) + call mma_deallocate(ConSO) + call mma_deallocate(ConOO) + end if + end if + end if + end if + end do + end do + end do +end do +call mma_deallocate(clebsch) +call mma_deallocate(mcombina) +call mma_deallocate(mcombcart) + +return + +end subroutine angular diff -Nru openmolcas-22.02/src/amfi_util/buildcoul.f openmolcas-22.10/src/amfi_util/buildcoul.f --- openmolcas-22.02/src/amfi_util/buildcoul.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/buildcoul.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,324 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine buildcoul(l1,l2,l3,l4,! angular momenta of primitives - *incl1,incl3, ! shifts for different radial integrals - *Lrun, ! L-value for coulomb integrals - *prmints, - *nprim1,nprim2,nprim3,nprim4, ! number of primitives - *expo1,expo2,expo3,expo4, ! arrays with the exponents - *power13, - *power24, - *quotpow1,quotpow2,coulovlp) -cbs ################################################################## -c -cbs purpose: builds up the coulomb integrals -cbs inbetween primitives and multiplies -cbs with extra factors to correct the -cbs normalization -c -cbs ################################################################## - implicit real*8 (a-h,o-z) -#include "para.fh" -#include "param.fh" -#include "dofuc.fh" -#include "real.fh" - dimension expo1(nprim1), - *expo2(nprim2), - *expo3(nprim3), - *expo4(nprim4), ! the exponents - *prmints(nprim1,nprim2,nprim3,nprim4),!scratch for prim integrals - *power13(MxprimL,MxprimL), - *power24(MxprimL,MxprimL), - *quotpow1(nprim1,nprim2,nprim3,nprim4), - *quotpow2(nprim1,nprim2,nprim3,nprim4), - *fraclist1(0:Lmax+3),fraclist2(0:Lmax+3),fact(MxprimL), - *frac(MxprimL),cfunctx1(MxprimL),cfunctx2(MxprimL) - *,coulovlp(MxprimL,MxprimL,-1:1,-1:1,0:Lmax,0:Lmax) - root8ovpi=sqrt(8d0/pi) -cbs ################################################################## -cbs prepare indices for coulint -cbs ################################################################## - n1=l1+incl1+1 - n2=l2+1 - n3=l3+incl3+1 - n4=l4+1 - n13=n1+n3 - n24=n2+n4 - index1=N13-Lrun-1 - index2=n24+Lrun - index3=N24-Lrun-1 - index4=n13+Lrun - do krun=0,(index1-1)/2 - fraclist1(krun)=dffrac(krun+krun+index2-1,krun+krun)* - *dffrac(1,index2-1) - enddo - do krun=0,(index3-1)/2 - fraclist2(krun)=dffrac(krun+krun+index4-1,krun+krun)* - *dffrac(1,index4-1) - enddo -cbs ################################################################## -cbs common factors including double factorials -cbs ################################################################## - doff1=dffrac(index1-1,n13-1)*dffrac(n24+Lrun-1,n24-1) - doff2=dffrac(index3-1,n24-1)*dffrac(n13+Lrun-1,n13-1) - if (index1.eq.1) then - do irun4=1,nprim4 - do irun3=1,nprim3 - if (l2.eq.l4) then - limit2=irun4 - else - limit2=nprim2 - endif - do irun2=1,limit2 - pow24inv=doff1/power24(irun4,irun2) - if (l1.eq.l3) then - limit1=irun3 - else - limit1=nprim1 - endif - do irun1=1,limit1 - prmints(irun1,irun2,irun3,irun4)= - * quotpow1(irun1,irun2,irun3,irun4)* - * sqrt(0.5d0*(expo1(irun1)+expo3(irun3)))* - * power13(irun3,irun1)*pow24inv - enddo - enddo - enddo - enddo - else - do irun4=1,nprim4 - do irun3=1,nprim3 - if (l2.eq.l4) then - limit2=irun4 - else - limit2=nprim2 - endif - do irun2=1,limit2 - alpha24inv=1d0/(expo2(irun2)+expo4(irun4)) - pow24inv=doff1/power24(irun4,irun2) - if (l1.eq.l3) then - limit1=irun3 - else - limit1=nprim1 - endif - do irun1=1,limit1 - a1324= alpha24inv*(expo1(irun1)+expo3(irun3)) - Cfunctx1(irun1)=fraclist1(0) - frac(irun1)=a1324/(1d0+a1324) - fact(irun1)=frac(irun1) - enddo -*vocl loop,repeat(Lmax+3) - do k=1,(index1-1)/2 - do irun1=1,limit1 - Cfunctx1(irun1)=Cfunctx1(irun1)+fraclist1(k) - * *fact(irun1) - enddo - do irun1=1,limit1 - fact(irun1)=fact(irun1)*frac(irun1) - enddo - enddo - do irun1=1,limit1 - alpha13=0.5d0*(expo1(irun1)+expo3(irun3)) - prmints(irun1,irun2,irun3,irun4)= - * quotpow1(irun1,irun2,irun3,irun4)* - * sqrt(alpha13)*power13(irun3,irun1)*pow24inv* - * Cfunctx1(irun1) - enddo - enddo - enddo - enddo - endif - if (index3.eq.1) then - do irun4=1,nprim4 - do irun3=1,nprim3 - if (l2.eq.l4) then - limit2=irun4 - else - limit2=nprim2 - endif - do irun2=1,limit2 - pow24=doff2*power24(irun4,irun2)* - * sqrt(0.5d0*(expo2(irun2)+expo4(irun4))) - if (l1.eq.l3) then - limit1=irun3 - else - limit1=nprim1 - endif - do irun1=1,limit1 - prmints(irun1,irun2,irun3,irun4)= - * prmints(irun1,irun2,irun3,irun4)+ - * pow24*quotpow2(irun1,irun2,irun3,irun4)/ - * power13(irun3,irun1) - enddo - enddo - enddo - enddo - else - do irun4=1,nprim4 - do irun3=1,nprim3 - if (l2.eq.l4) then - limit2=irun4 - else - limit2=nprim2 - endif - do irun2=1,limit2 - alpha24=expo2(irun2)+expo4(irun4) - pow24=doff2*power24(irun4,irun2)* - * sqrt(0.5d0*alpha24) - if (l1.eq.l3) then - limit1=irun3 - else - limit1=nprim1 - endif - do irun1=1,limit1 - a2413= alpha24/(expo1(irun1)+expo3(irun3)) - Cfunctx2(irun1)=fraclist2(0) - frac(irun1)=a2413/(1d0+a2413) - fact(irun1)=frac(irun1) - enddo -*vocl loop,repeat(Lmax+3) - do k=1,(index3-1)/2 - do irun1=1,limit1 - Cfunctx2(irun1)=Cfunctx2(irun1)+ - * fraclist2(k)*fact(irun1) - enddo - do irun1=1,limit1 - fact(irun1)=fact(irun1)*frac(irun1) - enddo - enddo - do irun1=1,limit1 - prmints(irun1,irun2,irun3,irun4)= - * prmints(irun1,irun2,irun3,irun4)+ - * quotpow2(irun1,irun2,irun3,irun4)* - * Cfunctx2(irun1)* - * pow24/power13(irun3,irun1) - enddo - enddo - enddo - enddo - endif -cbs make some mirroring for identical l-values -cbs for the case that l1=l3 - if (l1.eq.l3) then - do irun4=1,nprim4 - do irun3=1,nprim3 - do irun2=1,nprim2 - do irun1=irun3+1,nprim1 - prmints(irun1,irun2,irun3,irun4)= - *prmints(irun3,irun2,irun1,irun4) - enddo - enddo - enddo - enddo - endif -cbs for the case that l2=l4 - if (l2.eq.l4) then - do irun4=1,nprim4 - do irun3=1,nprim3 - do irun2=irun4+1,nprim2 - do irun1=1,nprim1 - prmints(irun1,irun2,irun3,irun4)= - *prmints(irun1,irun4,irun3,irun2) - enddo - enddo - enddo - enddo - endif -cbs some factors which are the same for all cases - do irun4=1,nprim4 - do irun3=1,nprim3 - do irun2=1,nprim2 - do irun1=1,nprim1 - prmints(irun1,irun2,irun3,irun4)= - *prmints(irun1,irun2,irun3,irun4)* - *coulovlp(irun4,irun2,0,0,l4,l2)* - *coulovlp(irun3,irun1,incl3,incl1,l3,l1)* - *root8ovpi - enddo - enddo - enddo - enddo -cbs -cbs look for additional factors, as the -cbs coulomb integrals are calculated -cbs for normalized functions with that -cbs specific l -cbs -cbs if l was increased by one, the factor is -cbs 0.5*sqrt((2l+3)/(exponent)) -cbs if l was decreased by one, the factor is -cbs 2d0*sqrt(exponent/(2l+1)) -cbs -cbs -cbs check for first function -cbs -cbs - if (incl1.eq.1) then - fact1=0.5d0*sqrt(DBLE(l1+l1+3)) - do irun4=1,nprim4 - do irun3=1,nprim3 - do irun2=1,nprim2 - do irun1=1,nprim1 - factor=fact1/sqrt(expo1(irun1)) - prmints(irun1,irun2,irun3,irun4)= - *prmints(irun1,irun2,irun3,irun4)*factor - enddo - enddo - enddo - enddo - elseif (incl1.eq.-1) then - fact1=2d0/sqrt(DBLE(l1+l1+1)) - do irun4=1,nprim4 - do irun3=1,nprim3 - do irun2=1,nprim2 - do irun1=1,nprim1 - factor=fact1*sqrt(expo1(irun1)) - prmints(irun1,irun2,irun3,irun4)= - *prmints(irun1,irun2,irun3,irun4)*factor - enddo - enddo - enddo - enddo - endif -cbs -cbs -cbs check for third function -cbs -cbs - if (incl3.eq.1) then - fact1=0.5d0*sqrt(DBLE(l3+l3+3)) - do irun4=1,nprim4 - do irun3=1,nprim3 - do irun2=1,nprim2 - do irun1=1,nprim1 - factor=fact1/sqrt(expo3(irun3)) - prmints(irun1,irun2,irun3,irun4)= - *prmints(irun1,irun2,irun3,irun4)*factor - enddo - enddo - enddo - enddo - elseif (incl3.eq.-1) then - fact1=2d0/sqrt(DBLE(l3+l3+1)) - do irun4=1,nprim4 - do irun3=1,nprim3 - do irun2=1,nprim2 - do irun1=1,nprim1 - factor=fact1*sqrt(expo3(irun3)) - prmints(irun1,irun2,irun3,irun4)= - *prmints(irun1,irun2,irun3,irun4)*factor - enddo - enddo - enddo - enddo - endif - return - end diff -Nru openmolcas-22.02/src/amfi_util/buildcoul.F90 openmolcas-22.10/src/amfi_util/buildcoul.F90 --- openmolcas-22.02/src/amfi_util/buildcoul.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/buildcoul.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,279 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine buildcoul(l1,l2,l3,l4,incl1,incl3,Lrun,prmints,nprim1,nprim2,nprim3,nprim4,expo1,expo2,expo3,expo4,power13,power24, & + quotpow1,quotpow2,coulovlp) +!bs ################################################################## +!bs purpose: builds up the coulomb integrals +!bs inbetween primitives and multiplies +!bs with extra factors to correct the +!bs normalization +!bs ################################################################## +! l1,l2,l3,l4 : angular momenta of primitives +! incl1,incl3 : shifts for different radial integrals +! Lrun : L-value for coulomb integrals +! prmints ! scratch for prim integral +! nprim1,nprim2,nprim3,nprim4 : number of primitives +! expo1,expo2,expo3,expo4 : arrays with the exponents + +use AMFI_global, only: dffrac, MxprimL, Lmax +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: One, Two, Eight, Half, Pi +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: l1, l2, l3, l4, incl1, incl3, Lrun, nprim1, nprim2, nprim3, nprim4 +real(kind=wp), intent(inout) :: prmints(nprim1,nprim2,nprim3,nprim4) +real(kind=wp), intent(in) :: expo1(nprim1), expo2(nprim2), expo3(nprim3), expo4(nprim4), power13(MxprimL,MxprimL), & + power24(MxprimL,MxprimL), quotpow1(nprim1,nprim2,nprim3,nprim4), & + quotpow2(nprim1,nprim2,nprim3,nprim4), coulovlp(MxprimL,MxprimL,-1:1,-1:1,0:Lmax,0:Lmax) +integer(kind=iwp) :: index1, index2, index3, index4, irun1, irun2, irun3, irun4, k, krun, limit1, limit2, n1, n13, n2, n24, n3, n4 +real(kind=wp) :: a1324, a2413, alpha13, alpha24, alpha24inv, doff1, doff2, fact1, factor, fraclist1(0:Lmax+3), & + fraclist2(0:Lmax+3), pow24, pow24inv +real(kind=wp), allocatable :: cfunctx(:), fact(:), frac(:) +real(kind=wp), parameter :: root8ovpi = sqrt(Eight/Pi) + +call mma_allocate(cfunctx,MxprimL,label='cfunctx') +call mma_allocate(fact,MxprimL,label='fact') +call mma_allocate(frac,MxprimL,label='frac') + +!bs ################################################################## +!bs prepare indices for coulint +!bs ################################################################## +n1 = l1+incl1+1 +n2 = l2+1 +n3 = l3+incl3+1 +n4 = l4+1 +n13 = n1+n3 +n24 = n2+n4 +index1 = N13-Lrun-1 +index2 = n24+Lrun +index3 = N24-Lrun-1 +index4 = n13+Lrun +do krun=0,(index1-1)/2 + fraclist1(krun) = dffrac(krun+krun+index2-1,krun+krun)*dffrac(1,index2-1) +end do +do krun=0,(index3-1)/2 + fraclist2(krun) = dffrac(krun+krun+index4-1,krun+krun)*dffrac(1,index4-1) +end do +!bs ################################################################## +!bs common factors including double factorials +!bs ################################################################## +doff1 = dffrac(index1-1,n13-1)*dffrac(n24+Lrun-1,n24-1) +doff2 = dffrac(index3-1,n24-1)*dffrac(n13+Lrun-1,n13-1) +if (index1 == 1) then + do irun4=1,nprim4 + do irun3=1,nprim3 + if (l2 == l4) then + limit2 = irun4 + else + limit2 = nprim2 + end if + do irun2=1,limit2 + pow24inv = doff1/power24(irun4,irun2) + if (l1 == l3) then + limit1 = irun3 + else + limit1 = nprim1 + end if + do irun1=1,limit1 + prmints(irun1,irun2,irun3,irun4) = quotpow1(irun1,irun2,irun3,irun4)*sqrt(Half*(expo1(irun1)+expo3(irun3)))* & + power13(irun3,irun1)*pow24inv + end do + end do + end do + end do +else + do irun4=1,nprim4 + do irun3=1,nprim3 + if (l2 == l4) then + limit2 = irun4 + else + limit2 = nprim2 + end if + do irun2=1,limit2 + alpha24inv = One/(expo2(irun2)+expo4(irun4)) + pow24inv = doff1/power24(irun4,irun2) + if (l1 == l3) then + limit1 = irun3 + else + limit1 = nprim1 + end if + do irun1=1,limit1 + a1324 = alpha24inv*(expo1(irun1)+expo3(irun3)) + Cfunctx(irun1) = fraclist1(0) + frac(irun1) = a1324/(One+a1324) + fact(irun1) = frac(irun1) + end do + !vocl loop,repeat(Lmax+3) + do k=1,(index1-1)/2 + do irun1=1,limit1 + Cfunctx(irun1) = Cfunctx(irun1)+fraclist1(k)*fact(irun1) + end do + do irun1=1,limit1 + fact(irun1) = fact(irun1)*frac(irun1) + end do + end do + do irun1=1,limit1 + alpha13 = Half*(expo1(irun1)+expo3(irun3)) + prmints(irun1,irun2,irun3,irun4) = quotpow1(irun1,irun2,irun3,irun4)*sqrt(alpha13)*power13(irun3,irun1)*pow24inv* & + Cfunctx(irun1) + end do + end do + end do + end do +end if +if (index3 == 1) then + do irun4=1,nprim4 + do irun3=1,nprim3 + if (l2 == l4) then + limit2 = irun4 + else + limit2 = nprim2 + end if + do irun2=1,limit2 + pow24 = doff2*power24(irun4,irun2)*sqrt(Half*(expo2(irun2)+expo4(irun4))) + if (l1 == l3) then + limit1 = irun3 + else + limit1 = nprim1 + end if + prmints(1:limit1,irun2,irun3,irun4) = prmints(1:limit1,irun2,irun3,irun4)+pow24*quotpow2(1:limit1,irun2,irun3,irun4)/ & + power13(irun3,1:limit1) + end do + end do + end do +else + do irun4=1,nprim4 + do irun3=1,nprim3 + if (l2 == l4) then + limit2 = irun4 + else + limit2 = nprim2 + end if + do irun2=1,limit2 + alpha24 = expo2(irun2)+expo4(irun4) + pow24 = doff2*power24(irun4,irun2)*sqrt(Half*alpha24) + if (l1 == l3) then + limit1 = irun3 + else + limit1 = nprim1 + end if + Cfunctx(1:limit1) = fraclist2(0) + do irun1=1,limit1 + a2413 = alpha24/(expo1(irun1)+expo3(irun3)) + frac(irun1) = a2413/(One+a2413) + fact(irun1) = frac(irun1) + end do + !vocl loop,repeat(Lmax+3) + do k=1,(index3-1)/2 + Cfunctx(1:limit1) = Cfunctx(1:limit1)+fraclist2(k)*fact(1:limit1) + fact(1:limit1) = fact(1:limit1)*frac(1:limit1) + end do + prmints(1:limit1,irun2,irun3,irun4) = prmints(1:limit1,irun2,irun3,irun4)+ & + quotpow2(1:limit1,irun2,irun3,irun4)*Cfunctx(1:limit1)*pow24/power13(irun3,1:limit1) + end do + end do + end do +end if +call mma_deallocate(cfunctx) +call mma_deallocate(fact) +call mma_deallocate(frac) +!bs make some mirroring for identical l-values +!bs for the case that l1=l3 +if (l1 == l3) then + do irun4=1,nprim4 + do irun3=1,nprim3 + do irun2=1,nprim2 + prmints(irun3+1:,irun2,irun3,irun4) = prmints(irun3,irun2,irun3+1:,irun4) + end do + end do + end do +end if +!bs for the case that l2=l4 +if (l2 == l4) then + do irun4=1,nprim4 + do irun3=1,nprim3 + do irun2=irun4+1,nprim2 + prmints(1:nprim1,irun2,irun3,irun4) = prmints(1:nprim1,irun4,irun3,irun2) + end do + end do + end do +end if +!bs some factors which are the same for all cases +do irun4=1,nprim4 + do irun3=1,nprim3 + do irun2=1,nprim2 + prmints(:,irun2,irun3,irun4) = prmints(:,irun2,irun3,irun4)*coulovlp(irun4,irun2,0,0,l4,l2)* & + coulovlp(irun3,1:nprim1,incl3,incl1,l3,l1)*root8ovpi + end do + end do +end do + +!bs look for additional factors, as the +!bs coulomb integrals are calculated +!bs for normalized functions with that +!bs specific l + +!bs if l was increased by one, the factor is +!bs 0.5*sqrt((2l+3)/(exponent)) +!bs if l was decreased by one, the factor is +!bs 2*sqrt(exponent/(2l+1)) + +!bs check for first function + +if (incl1 == 1) then + fact1 = Half*sqrt(real(l1+l1+3,kind=wp)) + do irun4=1,nprim4 + do irun3=1,nprim3 + do irun2=1,nprim2 + prmints(1:nprim1,irun2,irun3,irun4) = prmints(1:nprim1,irun2,irun3,irun4)*fact1/sqrt(expo1(1:nprim1)) + end do + end do + end do +else if (incl1 == -1) then + fact1 = Two/sqrt(real(l1+l1+1,kind=wp)) + do irun4=1,nprim4 + do irun3=1,nprim3 + do irun2=1,nprim2 + prmints(1:nprim1,irun2,irun3,irun4) = prmints(1:nprim1,irun2,irun3,irun4)*fact1*sqrt(expo1(1:nprim1)) + end do + end do + end do +end if + +!bs check for third function + +if (incl3 == 1) then + fact1 = Half*sqrt(real(l3+l3+3,kind=wp)) + do irun4=1,nprim4 + do irun3=1,nprim3 + factor = fact1/sqrt(expo3(irun3)) + do irun2=1,nprim2 + prmints(1:nprim1,irun2,irun3,irun4) = prmints(1:nprim1,irun2,irun3,irun4)*factor + end do + end do + end do +else if (incl3 == -1) then + fact1 = Two/sqrt(real(l3+l3+1,kind=wp)) + do irun4=1,nprim4 + do irun3=1,nprim3 + factor = fact1*sqrt(expo3(irun3)) + do irun2=1,nprim2 + prmints(1:nprim1,irun2,irun3,irun4) = prmints(1:nprim1,irun2,irun3,irun4)*factor + end do + end do + end do +end if + +return + +end subroutine buildcoul diff -Nru openmolcas-22.02/src/amfi_util/cartonex.f openmolcas-22.10/src/amfi_util/cartonex.f --- openmolcas-22.02/src/amfi_util/cartonex.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/cartonex.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine cartoneX(L,Lmax,onecontr,ncontrac, - *MxcontL,onecartX) - implicit real*8 (a-h,o-z) - dimension onecontr(MxcontL,MxcontL,-Lmax:Lmax,3), - *onecartX(MxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1)) -cbs arranges the cartesian one-electron-integrals for X on a -cbs quadratic matrix - ipnt(I,J)=(max(i,j)*(max(i,j)-1))/2+min(i,j) -cbs - + Integrals m || mprime mprime=m+1 - do Mprime=2,L - M=mprime-1 - iaddr=ipnt(Mprime+L+1,-M+L+1) - do jcont=1,ncontrac - do icont=1,ncontrac - onecartX(icont,jcont,iaddr)= - *onecartX(icont,jcont,iaddr) - *-0.25d0*( - *onecontr(icont,jcont,Mprime,1)+ - *onecontr(icont,jcont,-Mprime,3)) - enddo - enddo - enddo -cbs - + Integrals m || mprime mprime=m-1 - do Mprime=1,L-1 - M=mprime+1 - iaddr=ipnt(Mprime+L+1,-M+L+1) - do jcont=1,ncontrac - do icont=1,ncontrac - onecartX(icont,jcont,iaddr)= - *onecartX(icont,jcont,iaddr) - *-0.25d0*( - *onecontr(icont,jcont,Mprime,3)+ - *onecontr(icont,jcont,-Mprime,1)) - enddo - enddo - enddo -cbs -1 || 0 integrals - pre=sqrt(0.125d0) - iaddr=ipnt(L,L+1) - do jcont=1,ncontrac - do icont=1,ncontrac - onecartX(icont,jcont,iaddr)= - *onecartX(icont,jcont,iaddr) - *-pre* (onecontr(icont,jcont,0,3)+ - *onecontr(icont,jcont,0,1) ) - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/cartonex.F90 openmolcas-22.10/src/amfi_util/cartonex.F90 --- openmolcas-22.02/src/amfi_util/cartonex.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/cartonex.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,48 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine cartoneX(L,Lmax,onecontr,ncontrac,MxcontL,onecartX) +!bs arranges the cartesian one-electron-integrals for X on a square matrix + +use index_functions, only: iTri +use Constants, only: Quart +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: L, Lmax, ncontrac, MxcontL +real(kind=wp), intent(in) :: onecontr(MxcontL,MxcontL,-Lmax:Lmax,3) +real(kind=wp), intent(inout) :: onecartX(MxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1)) +integer(kind=iwp) :: iaddr, M, Mprime +real(kind=wp) :: pre + +!bs - + Integrals m || mprime mprime=m+1 +do Mprime=2,L + M = mprime-1 + iaddr = iTri(Mprime+L+1,-M+L+1) + onecartX(1:ncontrac,1:ncontrac,iaddr) = onecartX(1:ncontrac,1:ncontrac,iaddr)- & + Quart*(onecontr(1:ncontrac,1:ncontrac,Mprime,1)+onecontr(1:ncontrac,1:ncontrac,-Mprime,3)) +end do +!bs - + Integrals m || mprime mprime=m-1 +do Mprime=1,L-1 + M = mprime+1 + iaddr = iTri(Mprime+L+1,-M+L+1) + onecartX(1:ncontrac,1:ncontrac,iaddr) = onecartX(1:ncontrac,1:ncontrac,iaddr)- & + Quart*(onecontr(1:ncontrac,1:ncontrac,Mprime,3)+onecontr(1:ncontrac,1:ncontrac,-Mprime,1)) +end do +!bs -1 || 0 integrals +pre = sqrt(0.125_wp) +iaddr = iTri(L,L+1) +onecartX(1:ncontrac,1:ncontrac,iaddr) = onecartX(1:ncontrac,1:ncontrac,iaddr)- & + pre*(onecontr(1:ncontrac,1:ncontrac,0,3)+onecontr(1:ncontrac,1:ncontrac,0,1)) + +return + +end subroutine cartoneX diff -Nru openmolcas-22.02/src/amfi_util/cartoney.f openmolcas-22.10/src/amfi_util/cartoney.f --- openmolcas-22.02/src/amfi_util/cartoney.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/cartoney.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,60 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine cartoneY(L,Lmax,onecontr,ncontrac, - *MxcontL,onecartY) - implicit real*8 (a-h,o-z) - dimension onecontr(MxcontL,MxcontL,-Lmax:Lmax,3), - *onecartY(MxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1)) -cbs arranges the cartesian one-electron integrals for Y -cbs on a quadratic matrix - ipnt(I,J)=(max(i,j)*(max(i,j)-1))/2+min(i,j) -cbs + + Integrals m || mprime mprime=m+1 - do Mprime=2,L - M=mprime-1 - iaddr=ipnt(Mprime+L+1,M+L+1) - do jcont=1,ncontrac - do icont=1,ncontrac - onecartY(icont,jcont,iaddr)= - *onecartY(icont,jcont,iaddr) - *-0.25d0*( - *onecontr(icont,jcont,Mprime,1)+ - *onecontr(icont,jcont,-Mprime,3)) - enddo - enddo - enddo -cbs - - Integrals m || mprime mprime=m-1 - do Mprime=1,L-1 - M=mprime+1 - iaddr=ipnt(-Mprime+L+1,-M+L+1) - do jcont=1,ncontrac - do icont=1,ncontrac - onecartY(icont,jcont,iaddr)= - *onecartY(icont,jcont,iaddr) - *+0.25d0*( - *onecontr(icont,jcont,Mprime,3)+ - *onecontr(icont,jcont,-Mprime,1)) - enddo - enddo - enddo -cbs 0 || 1 integrals - pre=-sqrt(0.125d0) - iaddr=ipnt(L+1,L+2) - do jcont=1,ncontrac - do icont=1,ncontrac - onecartY(icont,jcont,iaddr)= - *onecartY(icont,jcont,iaddr) - *+pre* - *(onecontr(icont,jcont,1,1)+ - *onecontr(icont,jcont,-1,3)) - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/cartoney.F90 openmolcas-22.10/src/amfi_util/cartoney.F90 --- openmolcas-22.02/src/amfi_util/cartoney.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/cartoney.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,48 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine cartoneY(L,Lmax,onecontr,ncontrac,MxcontL,onecartY) +!bs arranges the cartesian one-electron integrals for Y on a square matrix + +use index_functions, only: iTri +use Constants, only: Quart +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: L, Lmax, ncontrac, MxcontL +real(kind=wp), intent(in) :: onecontr(MxcontL,MxcontL,-Lmax:Lmax,3) +real(kind=wp), intent(inout) :: onecartY(MxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1)) +integer(kind=iwp) :: iaddr, M, Mprime +real(kind=wp) :: pre + +!bs + + Integrals m || mprime mprime=m+1 +do Mprime=2,L + M = mprime-1 + iaddr = iTri(Mprime+L+1,M+L+1) + onecartY(1:ncontrac,1:ncontrac,iaddr) = onecartY(1:ncontrac,1:ncontrac,iaddr)- & + Quart*(onecontr(1:ncontrac,1:ncontrac,Mprime,1)+onecontr(1:ncontrac,1:ncontrac,-Mprime,3)) +end do +!bs - - Integrals m || mprime mprime=m-1 +do Mprime=1,L-1 + M = mprime+1 + iaddr = iTri(-Mprime+L+1,-M+L+1) + onecartY(1:ncontrac,1:ncontrac,iaddr) = onecartY(1:ncontrac,1:ncontrac,iaddr)+ & + Quart*(onecontr(1:ncontrac,1:ncontrac,Mprime,3)+onecontr(1:ncontrac,1:ncontrac,-Mprime,1)) +end do +!bs 0 || 1 integrals +pre = -sqrt(0.125_wp) +iaddr = iTri(L+1,L+2) +onecartY(1:ncontrac,1:ncontrac,iaddr) = onecartY(1:ncontrac,1:ncontrac,iaddr)+ & + pre*(onecontr(1:ncontrac,1:ncontrac,1,1)+onecontr(1:ncontrac,1:ncontrac,-1,3)) + +return + +end subroutine cartoneY diff -Nru openmolcas-22.02/src/amfi_util/cartonez.f openmolcas-22.10/src/amfi_util/cartonez.f --- openmolcas-22.02/src/amfi_util/cartonez.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/cartonez.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine cartoneZ(L,Lmax,onecontr,ncontrac, - *MxcontL,onecartZ) - implicit real*8 (a-h,o-z) - dimension onecontr(MxcontL,MxcontL,-Lmax:Lmax,3), - *onecartZ(MxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1)) -cbs arranges the cartesian one-electron integrals for Z -cbs on a quadratic matrix - ipnt(I,J)=(max(i,j)*(max(i,j)-1))/2+min(i,j) -cbs - + Integrals m || mprime mprime=m - do Mprime=1,L - iaddr=ipnt(Mprime+L+1,-mprime+L+1) - do jcont=1,ncontrac - do icont=1,ncontrac - onecartZ(icont,jcont,iaddr)= - *onecartZ(icont,jcont,iaddr)+ - *0.5d0*( - *onecontr(icont,jcont,Mprime,2)- - *onecontr(icont,jcont,-Mprime,2)) - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/cartonez.F90 openmolcas-22.10/src/amfi_util/cartonez.F90 --- openmolcas-22.02/src/amfi_util/cartonez.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/cartonez.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,34 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine cartoneZ(L,Lmax,onecontr,ncontrac,MxcontL,onecartZ) +!bs arranges the cartesian one-electron integrals for Z on a square matrix + +use index_functions, only: iTri +use Constants, only: Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: L, Lmax, ncontrac, MxcontL +real(kind=wp), intent(in) :: onecontr(MxcontL,MxcontL,-Lmax:Lmax,3) +real(kind=wp), intent(inout) :: onecartZ(MxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1)) +integer(kind=iwp) :: iaddr, Mprime + +!bs - + Integrals m || mprime mprime=m +do Mprime=1,L + iaddr = iTri(Mprime+L+1,-mprime+L+1) + onecartZ(1:ncontrac,1:ncontrac,iaddr) = onecartZ(1:ncontrac,1:ncontrac,iaddr)+ & + Half*(onecontr(1:ncontrac,1:ncontrac,Mprime,2)-onecontr(1:ncontrac,1:ncontrac,-Mprime,2)) +end do + +return + +end subroutine cartoneZ diff -Nru openmolcas-22.02/src/amfi_util/chngcont.f openmolcas-22.10/src/amfi_util/chngcont.f --- openmolcas-22.02/src/amfi_util/chngcont.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/chngcont.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,174 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine chngcont(coeffs,coeffst1,coeffst1a,coeffst2, - *coeffst2a,ncont,nprims,evec, - *type1,type2,work,work2,work3,MxprimL, - *rootOVLP,OVLPinv,exponents) -c############################################################################### -cbs purpose: makes out of old contraction coefficients(in normalized functions) -cbs new coefficients including the kinematical factors -cbs using the diagonal matrices on type1 and type2 (see subroutine kinemat) -cbs coeffst1a and coeffst2a additionally include the exponents alpha -cbs (that is why ....a). So the exponents in the integrals are moved -cbs to the contraction coefficients and not in some way into the primitive -cbs integrals. -cbs -cbs the different cases for contracted integrals differ later on in the -cbs choice of different sets of contraction coefficients. -cbs -c############################################################################### - implicit real*8 (a-h,o-z) - dimension coeffs(nprims,ncont),! original contraction coefficients - *coeffst1(nprims,ncont), ! A * cont coeff - *coeffst1a(nprims,ncont), ! A * alpha*cont coeff - *coeffst2a(nprims,ncont), ! c*A/(E+m) * cont coeff - *coeffst2(nprims,ncont), ! c*A/(E+m) * alpha *cont coeff - *evec(nprims,nprims), - *work(nprims,nprims) , - *work2(nprims,nprims) , - *work3(nprims,nprims) , - *rootOVLP(MxprimL,*), - *OVLPinv(MxprimL,*), - *type1(*),type2(*), - *exponents(*) -cbs -cbs first new coefficients for type1 (A) -cbs generate a transformation matrix on work -cbs - do J=1,nprims - do I=1,nprims - work(I,J)=0d0 - work2(I,J)=0d0 - work3(I,J)=0d0 - enddo - enddo -cbs build up the transformation matrix - do K=1,nprims - do J=1,nprims - do I=1,nprims - work(I,J)=work(I,J)+evec(I,K)*type1(K)*evec(J,K) - enddo - enddo - enddo - do K=1,nprims - do J=1,nprims - do I=1,nprims - work2(I,J)=work2(I,J)+work(I,K)*rootOVLP(K,J) - enddo - enddo - enddo - do K=1,nprims - do J=1,nprims - do I=1,nprims - work3(I,J)=work3(I,J)+rootOVLP(I,K)*work2(K,J) - enddo - enddo - enddo - do J=1,nprims - do I=1,nprims - work(I,J)=0d0 - enddo - enddo - do K=1,nprims - do J=1,nprims - do I=1,nprims - work(J,I)=work(J,I)+OVLPinv(I,K)*work3(K,J) - enddo - enddo - enddo - do K=1,ncont - do I=1,nprims - coeffst1(I,K)=0d0 - enddo - enddo -cbs now transform the vectors - do K=1,ncont - do J=1,nprims - do I=1,nprims - coeffst1(I,K)=coeffst1(I,K)+work(J,I)*coeffs(J,K) - enddo - enddo - enddo -cbs -cbs now with exponent -cbs - do K=1,ncont - do I=1,nprims - coeffst1a(I,K)=exponents(I)*coeffst1(I,K) - enddo - enddo -cbs -cbs and now the same for the other type A/(E+m) -cbs - do J=1,nprims - do I=1,nprims - work(I,J)=0d0 - work2(I,J)=0d0 - work3(I,J)=0d0 - enddo - enddo -cbs build up the transformation matrix - do K=1,nprims - do J=1,nprims - do I=1,nprims - work(I,J)=work(I,J)+evec(I,K)*type2(K)*evec(J,K) - enddo - enddo - enddo - do K=1,nprims - do J=1,nprims - do I=1,nprims - work2(I,J)=work2(I,J)+work(I,K)*rootOVLP(K,J) - enddo - enddo - enddo - do K=1,nprims - do J=1,nprims - do I=1,nprims - work3(I,J)=work3(I,J)+rootOVLP(I,K)*work2(K,J) - enddo - enddo - enddo - do J=1,nprims - do I=1,nprims - work(I,J)=0d0 - enddo - enddo - do K=1,nprims - do J=1,nprims - do I=1,nprims - work(J,I)=work(J,I)+OVLPinv(I,K)*work3(K,J) - enddo - enddo - enddo - do K=1,ncont - do I=1,nprims - coeffst2(I,K)=0d0 - enddo - enddo -cbs now transform the vectors - do K=1,ncont - do J=1,nprims - do I=1,nprims - coeffst2(I,K)=coeffst2(I,K)+work(J,I)*coeffs(J,K) - enddo - enddo - enddo -cbs -cbs now with exponent -cbs - do K=1,ncont - do I=1,nprims - coeffst2a(I,K)=exponents(I)*coeffst2(I,K) - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/chngcont.F90 openmolcas-22.10/src/amfi_util/chngcont.F90 --- openmolcas-22.02/src/amfi_util/chngcont.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/chngcont.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,84 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine chngcont(coeffs,coeffst1,coeffst1a,coeffst2,coeffst2a,ncont,nprims,evec,type1,type2,work,work2,work3,MxprimL,rootOVLP, & + OVLPinv,exponents) +!####################################################################### +!bs purpose: makes out of old contraction coefficients(in normalized functions) +!bs new coefficients including the kinematical factors +!bs using the diagonal matrices on type1 and type2 (see subroutine kinemat) +!bs coeffst1a and coeffst2a additionally include the exponents alpha +!bs (that is why ....a). So the exponents in the integrals are moved +!bs to the contraction coefficients and not in some way into the primitive +!bs integrals. +!bs +!bs the different cases for contracted integrals differ later on in the +!bs choice of different sets of contraction coefficients. +!####################################################################### +!coeffs : original contraction coefficients +!coeffst1 : A * cont coeff +!coeffst1a : A * alpha*cont coeff +!coeffst2a : c*A/(E+m) * cont coeff +!coeffst2 : c*A/(E+m) * alpha *cont coeff + +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: ncont, nprims, MxprimL +real(kind=wp), intent(in) :: coeffs(nprims,ncont), evec(nprims,nprims), type1(*), type2(*), rootOVLP(MxprimL,*), & + OVLPinv(MxprimL,*), exponents(*) +real(kind=wp), intent(out) :: coeffst1(nprims,ncont), coeffst1a(nprims,ncont), coeffst2(nprims,ncont), coeffst2a(nprims,ncont), & + work(nprims,nprims), work2(nprims,nprims), work3(nprims,nprims) +integer(kind=iwp) :: K + +!bs first new coefficients for type1 (A) +!bs generate a transformation matrix on work + +!bs build up the transformation matrix +do K=1,nprims + work2(:,K) = type1(K)*evec(:,K) +end do +call dgemm_('N','T',nprims,nprims,nprims,One,work2,nprims,evec,nprims,Zero,work,nprims) +call dgemm_('N','N',nprims,nprims,nprims,One,work,nprims,rootOVLP,MxprimL,Zero,work2,nprims) +call dgemm_('N','N',nprims,nprims,nprims,One,rootOVLP,MxprimL,work2,nprims,Zero,work3,nprims) +call dgemm_('N','N',nprims,nprims,nprims,One,OVLPinv,MxprimL,work3,nprims,Zero,work,nprims) +!bs now transform the vectors +call dgemm_('N','N',nprims,ncont,nprims,One,work,nprims,coeffs,nprims,Zero,coeffst1,nprims) + +!bs now with exponent + +do K=1,ncont + coeffst1a(:,K) = exponents(1:nprims)*coeffst1(:,K) +end do + +!bs and now the same for the other type A/(E+m) + +!bs build up the transformation matrix +do K=1,nprims + work2(:,K) = type2(K)*evec(:,K) +end do +call dgemm_('N','T',nprims,nprims,nprims,One,work2,nprims,evec,nprims,Zero,work,nprims) +call dgemm_('N','N',nprims,nprims,nprims,One,work,nprims,rootOVLP,MxprimL,Zero,work2,nprims) +call dgemm_('N','N',nprims,nprims,nprims,One,rootOVLP,MxprimL,work2,nprims,Zero,work3,nprims) +call dgemm_('N','N',nprims,nprims,nprims,One,OVLPinv,MxprimL,work3,nprims,Zero,work,nprims) +!bs now transform the vectors +call dgemm_('N','N',nprims,ncont,nprims,One,work,nprims,coeffs,nprims,Zero,coeffst2,nprims) + +!bs now with exponent + +do K=1,ncont + coeffst2a(:,K) = exponents(1:nprims)*coeffst2(:,K) +end do + +return + +end subroutine chngcont diff -Nru openmolcas-22.02/src/amfi_util/CMakeLists.txt openmolcas-22.10/src/amfi_util/CMakeLists.txt --- openmolcas-22.02/src/amfi_util/CMakeLists.txt 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -9,4 +9,73 @@ # LICENSE or in . * #*********************************************************************** +set (sources + amfi.F90 + amfi_global.F90 + angular.F90 + buildcoul.F90 + cartonex.F90 + cartoney.F90 + cartonez.F90 + chngcont.F90 + contandmult.F90 + contcasaoo.F90 + contcasaso.F90 + contcasb1oo.F90 + contcasb1so.F90 + contcasb2oo.F90 + contcasb2so.F90 + contcascoo.F90 + contcascso.F90 + cont.F90 + contone.F90 + contract.F90 + couple3j.F90 + daxpint.F90 + drv_amfi.F90 + finite.F90 + gen1overr3.F90 + gencouldim.F90 + gencoul.F90 + genovlp.F90 + genpowers.F90 + genprexyz13.F90 + genprexyz14.F90 + genprexyz15a.F90 + gentkin.F90 + getaos2.F90 + getaos.F90 + getcg.F90 + getlimit.F90 + getocc_ao.F90 + inidf.F90 + initfrac.F90 + initired.F90 + kindiag.F90 + kinemat.F90 + lmdepang.F90 + mcheckxy.F90 + mcheckz.F90 + mkangl0.F90 + mkanglmin.F90 + prefac.F90 + readbas.F90 + regge3j.F90 + symtrafo.F90 + tkinet.F90 + tosigx.F90 + tosigy.F90 + tosigz.F90 + trans_amfi.F90 + transcon.F90 + two2mean12a.F90 + two2mean12b.F90 + two2mean13.F90 + two2mean34a.F90 + two2mean34b.F90 +) + +# Source files defining modules that should be available to other *_util directories +set (modfile_list "") + include (${PROJECT_SOURCE_DIR}/cmake/util_template.cmake) diff -Nru openmolcas-22.02/src/amfi_util/contandmult.f openmolcas-22.10/src/amfi_util/contandmult.f --- openmolcas-22.02/src/amfi_util/contandmult.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contandmult.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,293 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine contandmult(Lhigh,makemean,AIMP,oneonly,numballcart, - & LUPROP,ifinite,onecart, - & onecontr,oneoverR3,iCenter) - implicit real*8 (a-h,o-z) -#include "para.fh" -#include "param.fh" -#include "ired.fh" -#include "Molcas.fh" -#include "stdalloc.fh" - Real*8, Allocatable:: Dummy(:), OCA(:,:), OCA2(:,:), OCA3(:,:) - logical makemean,AIMP,oneonly - character*8 xa,ya,za - dimension xa(4),ya(4),za(4), - * onecart(mxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1),Lmax,3), - * onecontr(mxcontL,MxcontL,-Lmax:Lmax,3,Lmax), - * oneoverR3((MxprimL*MxprimL+MxprimL)/2,Lmax) -#include "nucleus.fh" -* - IPNT(I,J)=(J*J-J)/2+I -* -cbs get back the real number of functions for the finite nucleus - if (ifinite.eq.2) ncontrac(0)=ncontrac_keep -c############################################################################### -cbs subroutine to contract radial one-electron integrals -cbs and multiply them with angular factors -c############################################################################### - xa(1)='********' - ya(1)='********' - za(1)='********' - xa(2)=' ' - ya(2)=' ' - Za(2)=' ' - xa(3)='ANTISYMM' - ya(3)='ANTISYMM' - Za(3)='ANTISYMM' - xa(4)='X1SPNORB' - ya(4)='Y1SPNORB' - ZA(4)='Z1SPNORB' -c -cbs clean the arrays for cartesian integrals -C - length3=(numbalLcart*numbalLcart+numbalLcart)/2 - Call mma_allocate(OCA,Length3,3,Label='OCA') - Call mma_allocate(OCA2,Length3,3,Label='OCA2') - Call mma_allocate(Dummy,MxContL**2,Label='Dummy') - Dummy(:)=0.0D0 - OCA(:,:)=0.0D0 - OCA2(:,:)=0.0D0 -c -c -c -c -cbs one-electron-integrals: -cbs 1. index: number of first contracted function -cbs 2. index: number of second contracted function -cbs 3. index: pointer(m1,m2) m1< m2 otherwise change sign of integral -cbs 4. index: L-value -cbs onecart(mxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1),Lmax,1), -cbs onecart(mxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1),Lmax,2), -cbs onecart(mxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1),Lmax,3) -c -c -c -cbs generate one-electron integrals for all L greater/equal 1 - if (ifinite.eq.2) charge=0d0 ! nuclear integrals -cbs are modelled for finite nucleus somewhere else - do L=1,Lhigh - call contone(L,oneoverr3(1,L),onecontr(1,1,-Lmax,1,L), - * Lmax,contrarray(iaddtyp3(L)),nprimit(L), - * ncontrac(L),MxcontL,Dummy, - * onecart(1,1,1,L,1), - * onecart(1,1,1,L,2), - * onecart(1,1,1,L,3), - * charge,oneonly) - Enddo -c -cbs *********************************************************************** -cbs now move all integrals to one big arrays for X,Y,Z -cbs *********************************************************************** - do Lrun=1,Lhigh !loop over L-values (integrals are diagonal in L) - mrun=0 - do Msec=-Lrun,Lrun ! cartesian M-values (Mfirst,Msec) with - do Mfirst=-Lrun,Msec ! Mfirst <= Msec (actually '=' does never -c appear as there is no L-component in Ag -C -c -cbs determine if L_X L_Y or L_Z - ipowx=ipowxyz(1,mfirst,Lrun)+ipowxyz(1,msec,Lrun) - ipowy=ipowxyz(2,mfirst,Lrun)+ipowxyz(2,msec,Lrun) - ipowz=ipowxyz(3,mfirst,Lrun)+ipowxyz(3,msec,Lrun) -c - mrun=mrun+1 -cbs now determine the irreducable representations - iredfirst=iredLM(Mfirst,Lrun) - iredsec=iredLM(Msec,Lrun) -cbs check out which IR is the lower one. - if (iredfirst.le.iredsec) then -* -cbs calculate shift to get to the beginning of the block - iredired= shiftIRIR((iredsec*iredsec-iredsec)/2+iredfirst) - * + incrlm(Mfirst,Lrun)*itotalperIR(iredsec) - * + incrLM(Msec,Lrun) - if (mod(ipowx,2).eq.0.and.mod(ipowy,2).eq.1.and. - * mod(ipowz,2).eq.1) then - do icartfirst=1,ncontrac(Lrun) ! loop first index - do icartsec=1,ncontrac(Lrun) ! loop second index - oca(iredired+icartsec,1)=oca(iredired+icartsec,1) - * +onecart(icartfirst,icartsec,mrun,Lrun,1) - enddo -cbs shift pointer by number of functions in IR - iredired=iredired+itotalperIR(iredsec) - enddo - endif - if (mod(ipowx,2).eq.1.and.mod(ipowy,2).eq.0.and. - * mod(ipowz,2).eq.1) then - do icartfirst=1,ncontrac(Lrun) ! loop first index - do icartsec=1,ncontrac(Lrun) ! loop second index - oca(iredired+icartsec,2)=oca(iredired+icartsec,2) - * +onecart(icartfirst,icartsec,mrun,Lrun,2) - enddo -cbs shift pointer by number of functions in IR - iredired=iredired+itotalperIR(iredsec) - enddo - endif - if (mod(ipowx,2).eq.1.and.mod(ipowy,2).eq.1.and. - * mod(ipowz,2).eq.0) then - do icartfirst=1,ncontrac(Lrun) ! loop first index - do icartsec=1,ncontrac(Lrun) ! loop second index - oca(iredired+icartsec,3)=oca(iredired+icartsec,3) - * +onecart(icartfirst,icartsec,mrun,Lrun,3) - enddo -cbs shift pointer by number of functions in IR - iredired=iredired+itotalperIR(iredsec) - enddo - endif - elseif (iredfirst.gt.iredsec) then -cbs In this case, indices are exchanged with respect to former -cbs symmetry of blocks. Therefore, there will be a minus sign -c -cbs calculate shift to get to the beginning of the block - iredired=shiftIRIR((iredfirst*iredfirst-iredfirst)/2+iredsec) - * + incrLM(Msec,Lrun)*itotalperIR(iredfirst) - * + incrLM(Mfirst,Lrun) - if (mod(ipowx,2).eq.0.and.mod(ipowy,2).eq.1.and. - * mod(ipowz,2).eq.1) then - do icartsec=1,ncontrac(Lrun) !loopsecond index - do icartfirst=1,ncontrac(Lrun) !loop first index - oca(iredired+icartfirst,1)= - * oca(iredired+icartfirst,1) - * -onecart(icartsec,icartfirst,mrun,Lrun,1) - enddo -cbs shift pointer by number of functions in IR - iredired=iredired+itotalperIR(iredfirst) - enddo - endif - if (mod(ipowx,2).eq.1.and.mod(ipowy,2).eq.0.and. - * mod(ipowz,2).eq.1) then - do icartsec=1,ncontrac(Lrun) !loop second index - do icartfirst=1,ncontrac(Lrun) !loop first index - oca(iredired+icartfirst,2)= - * oca(iredired+icartfirst,2) - * -onecart(icartsec,icartfirst,mrun,Lrun,2) - enddo -cbs shift pointer by number of functions in IR - iredired=iredired+itotalperIR(iredfirst) - enddo - endif - if (mod(ipowx,2).eq.1.and.mod(ipowy,2).eq.1.and. - * mod(ipowz,2).eq.0) then - do icartsec=1,ncontrac(Lrun) !loop second index - do icartfirst=1,ncontrac(Lrun) !loop first index - oca(iredired+icartfirst,3)= - * oca(iredired+icartfirst,3) - * -onecart(icartsec,icartfirst,mrun,Lrun,3) - enddo -cbs shift pointer by number of functions in IR - iredired=iredired+itotalperIR(iredfirst) - enddo - endif - endif - enddo - enddo - enddo -C -cbs copy integrals on arrays with no symmetry blocking at all -cbs which means huge triangular matrices - irun=0 - do norb2=1,numballcarT - ired2=iredoffunctnew(norb2) - norbsh2=norb2-shiftIRED(ired2) - do norb1=1,norb2 - ired1=iredoffunctnew(norb1) - norbsh1=noRb1-shiftIRED(ired1) - irun=irun+1 - iredired=shiftIRIR((ired2*ired2-ired2)/2+ired1) - if (ired1.ne.ired2) then - oca2(irun,1)= - & oca(iredired+norbsh2+(norbsH1-1)*itotalperIR(IREd2),1) - oca2(irun,2)= - & oca(iredired+norbsh2+(norbsH1-1)*itotalperIR(IREd2),2) - oca2(irun,3)= - & oca(iredired+norbsh2+(norbsH1-1)*itotalperIR(IREd2),3) - else - oca2(irun,1)= - & oca(iredired+norbsh2*(norbsH2-1)/2+norbsh1,1) - oca2(irun,2)= - & oca(iredired+norbsh2*(norbsH2-1)/2+norbsh1,2) - oca2(irun,3)= - & oca(iredired+norbsh2*(norbsH2-1)/2+norbsh1,3) - endif - Enddo - enddo - if (.not.AIMP) then -c write a hermit-like file b.s. 4.10.96 -CBS write(6,*) 'number of orbitals ',numbalLcarT -CBS write(6,*) 'length of triangular matrix ', length3 -CBS This was removed and will be done in SEWARD -CBS OPEN(LUPROP,STATUS='UNKNOWN',FORM='UNFORMATTED', -CBS * FILE='AOPROPER_MF') -CBS rewind LUPROP - write(LUPROP) iCenter - write(LUPROP) xa,numbofsym,(nrtofiperIR(I), - * i=1,numbofsym), - * numballcart,(Loffunction(I),I=1,numballcart), - * (Moffunction(I),I=1,numballcart), - * Lhigh,(ncontrac(I),I=0,Lhigh) - write(LUPROP) (oca2(irun,1),irun=1,length3) - write(LUPROP) Ya - write(LUPROP) (oca2(irun,2),irun=1,length3) - write(LUPROP) Za - write(LUPROP) (oca2(irun,3),irun=1,length3) -CBS close(luprop) - else -cbs reorder for AIMP -cbs write(6,*) 'reorder integrals for AIMP' - length3=ikeeporb*(ikeeporb+1)/2 - Call mma_allocate(OCA3,length3,3,Label='OCA3') - OCA3(:,:)=0.0D0 -cbs write(6,*) 'number of orbitals ',ikeeporb -cbs write(6,*) 'length of triangular matrix ', length3 - do irun2=1,ikeeporb - do irun1=1,irun2 - ind2=ikeeplist(irun2) - ind1=ikeeplist(irun1) - ipntold=ipnt(ind1,ind2) - ipntnew=ipnt(irun1,irun2) -* - oca3(ipntnew,1)=oca2(ipntold,1) - oca3(ipntnew,2)=oca2(ipntold,2) - oca3(ipntnew,3)=oca2(ipntold,3) - enddo - enddo -CBS write(6,*) 'transfered to new blocks' -CBS Luprop=19 -CBS OPEN(LUPROP,STATUS='UNKNOWN',FORM='UNFORMATTED', -CBS * FILE='AOPROPER_MF') -CBS rewind LUPROP -* - write(LUPROP) iCenter - write(LUPROP) xa,numbofsym,(nrtofiperIR(I), - * i=1,numbofsym), - * ikeeporb,(Loffunction(ikeeplist(i)),i=1,ikeeporb), - * (Moffunction(ikeeplist(i)),I=1,ikeeporb), - * Lhigh,((NContrac(I)-icore(I)),I=0,Lhigh) - write(LUPROP) (oca3(irun,1),irun=1,length3) - write(LUPROP) Ya - write(LUPROP) (oca3(irun,2),irun=1,length3) - write(LUPROP) Za - write(LUPROP) (oca3(irun,3),irun=1,length3) -* - Call mma_deallocate(OCA3) -CBS close(luprop) - endif -cbs -cbs that is it!! -cbs - Call mma_deallocate(OCA2) - Call mma_deallocate(OCA) - Call mma_deallocate(Dummy) - return -c Avoid unused argument warnings - if (.false.) call Unused_logical(makemean) - end diff -Nru openmolcas-22.02/src/amfi_util/contandmult.F90 openmolcas-22.10/src/amfi_util/contandmult.F90 --- openmolcas-22.02/src/amfi_util/contandmult.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contandmult.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,234 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine contandmult(Lhigh,AIMP,oneonly,numballcart,LUPROP,ifinite,onecart,onecontr,oneoverR3,iCenter) + +use AMFI_global, only: charge, contrarray, icore, ikeeplist, ikeeporb, incrLM, ipowxyz, iredLM, iredoffunctnew, itotalperIR, & + Lmax, Loffunction, Moffunction, MxcontL, MxprimL, ncontrac, ncontrac_keep, nprimit, nrtofiperIR, numbofsym, & + shiftIRED, shiftIRIR +use index_functions, only: iTri +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: Lhigh, numballcart, LUPROP, ifinite, iCenter +logical(kind=iwp), intent(in) :: AIMP, oneonly +real(kind=wp), intent(inout) :: onecart(MxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1),Lmax,3) +real(kind=wp), intent(out) :: onecontr(MxcontL,MxcontL,-Lmax:Lmax,3,Lmax) +real(kind=wp), intent(in) :: oneoverR3(MxprimL*(MxprimL+1)/2,Lmax) +integer(kind=iwp) :: I, icartfirst, icartsec, ind1, ind2, ipntnew, ipntold, ipowx, ipowy, ipowz, ired1, ired2, iredfirst, & + iredired, iredsec, irun, irun1, irun2, L, length3, Lrun, Mfirst, mrun, Msec, norb1, norb2, norbsh1, norbsh2 +character(len=8) :: xa(4), ya(4), za(4) +real(kind=wp), allocatable :: Dummy(:), OCA(:,:), OCA2(:,:), OCA3(:,:) + +!bs get back the real number of functions for the finite nucleus +if (ifinite == 2) ncontrac(0) = ncontrac_keep +!####################################################################### +!bs subroutine to contract radial one-electron integrals +!bs and multiply them with angular factors +!####################################################################### +xa(:) = ['********',' ','ANTISYMM','X1SPNORB'] +ya(:) = ['********',' ','ANTISYMM','Y1SPNORB'] +za(:) = ['********',' ','ANTISYMM','Z1SPNORB'] + +!bs clean the arrays for cartesian integrals + +length3 = numbalLcart*(numbalLcart+1)/2 +call mma_allocate(OCA,Length3,3,Label='OCA') +call mma_allocate(OCA2,Length3,3,Label='OCA2') +call mma_allocate(Dummy,MxContL**2,Label='Dummy') +Dummy(:) = Zero +OCA(:,:) = Zero +OCA2(:,:) = Zero + +!bs one-electron-integrals: +!bs 1. index: number of first contracted function +!bs 2. index: number of second contracted function +!bs 3. index: pointer(m1,m2) m1< m2 otherwise change sign of integral +!bs 4. index: L-value +!bs onecart(MxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1),Lmax,1), +!bs onecart(MxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1),Lmax,2), +!bs onecart(MxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1),Lmax,3) + +!bs generate one-electron integrals for all L greater/equal 1 +if (ifinite == 2) charge = Zero ! nuclear integrals are modelled for finite nucleus somewhere else +do L=1,Lhigh + call contone(L,oneoverr3(:,L),onecontr(:,:,-Lmax,1,L),Lmax,contrarray(:,3,L),nprimit(L),ncontrac(L),MxcontL,Dummy, & + onecart(:,:,:,L,1),onecart(:,:,:,L,2),onecart(:,:,:,L,3),charge,oneonly) +end do + +!bs ******************************************************************** +!bs now move all integrals to one big arrays for X,Y,Z +!bs ******************************************************************** +do Lrun=1,Lhigh !loop over L-values (integrals are diagonal in L) + mrun = 0 + do Msec=-Lrun,Lrun ! cartesian M-values (Mfirst,Msec) with + do Mfirst=-Lrun,Msec ! Mfirst <= Msec (actually '=' does never appear as there is no L-component in Ag + + !bs determine if L_X L_Y or L_Z + ipowx = ipowxyz(1,mfirst,Lrun)+ipowxyz(1,msec,Lrun) + ipowy = ipowxyz(2,mfirst,Lrun)+ipowxyz(2,msec,Lrun) + ipowz = ipowxyz(3,mfirst,Lrun)+ipowxyz(3,msec,Lrun) + + mrun = mrun+1 + !bs now determine the irreducible representations + iredfirst = iredLM(Mfirst,Lrun) + iredsec = iredLM(Msec,Lrun) + !bs check out which IR is the lower one. + if (iredfirst <= iredsec) then + + !bs calculate shift to get to the beginning of the block + iredired = shiftIRIR((iredsec*iredsec-iredsec)/2+iredfirst)+incrlm(Mfirst,Lrun)*itotalperIR(iredsec)+incrLM(Msec,Lrun) + if ((mod(ipowx,2) == 0) .and. (mod(ipowy,2) == 1) .and. (mod(ipowz,2) == 1)) then + do icartfirst=1,ncontrac(Lrun) ! loop first index + do icartsec=1,ncontrac(Lrun) ! loop second index + oca(iredired+icartsec,1) = oca(iredired+icartsec,1)+onecart(icartfirst,icartsec,mrun,Lrun,1) + end do + !bs shift pointer by number of functions in IR + iredired = iredired+itotalperIR(iredsec) + end do + end if + if ((mod(ipowx,2) == 1) .and. (mod(ipowy,2) == 0) .and. (mod(ipowz,2) == 1)) then + do icartfirst=1,ncontrac(Lrun) ! loop first index + do icartsec=1,ncontrac(Lrun) ! loop second index + oca(iredired+icartsec,2) = oca(iredired+icartsec,2)+onecart(icartfirst,icartsec,mrun,Lrun,2) + end do + !bs shift pointer by number of functions in IR + iredired = iredired+itotalperIR(iredsec) + end do + end if + if ((mod(ipowx,2) == 1) .and. (mod(ipowy,2) == 1) .and. (mod(ipowz,2) == 0)) then + do icartfirst=1,ncontrac(Lrun) ! loop first index + do icartsec=1,ncontrac(Lrun) ! loop second index + oca(iredired+icartsec,3) = oca(iredired+icartsec,3)+onecart(icartfirst,icartsec,mrun,Lrun,3) + end do + !bs shift pointer by number of functions in IR + iredired = iredired+itotalperIR(iredsec) + end do + end if + else if (iredfirst > iredsec) then + !bs In this case, indices are exchanged with respect to former + !bs symmetry of blocks. Therefore, there will be a minus sign + + !bs calculate shift to get to the beginning of the block + iredired = shiftIRIR((iredfirst*iredfirst-iredfirst)/2+iredsec)+incrLM(Msec,Lrun)*itotalperIR(iredfirst)+incrLM(Mfirst,Lrun) + if ((mod(ipowx,2) == 0) .and. (mod(ipowy,2) == 1) .and. (mod(ipowz,2) == 1)) then + do icartsec=1,ncontrac(Lrun) !loop second index + do icartfirst=1,ncontrac(Lrun) !loop first index + oca(iredired+icartfirst,1) = oca(iredired+icartfirst,1)-onecart(icartsec,icartfirst,mrun,Lrun,1) + end do + !bs shift pointer by number of functions in IR + iredired = iredired+itotalperIR(iredfirst) + end do + end if + if ((mod(ipowx,2) == 1) .and. (mod(ipowy,2) == 0) .and. (mod(ipowz,2) == 1)) then + do icartsec=1,ncontrac(Lrun) !loop second index + do icartfirst=1,ncontrac(Lrun) !loop first index + oca(iredired+icartfirst,2) = oca(iredired+icartfirst,2)-onecart(icartsec,icartfirst,mrun,Lrun,2) + end do + !bs shift pointer by number of functions in IR + iredired = iredired+itotalperIR(iredfirst) + end do + end if + if ((mod(ipowx,2) == 1) .and. (mod(ipowy,2) == 1) .and. (mod(ipowz,2) == 0)) then + do icartsec=1,ncontrac(Lrun) !loop second index + do icartfirst=1,ncontrac(Lrun) !loop first index + oca(iredired+icartfirst,3) = oca(iredired+icartfirst,3)-onecart(icartsec,icartfirst,mrun,Lrun,3) + end do + !bs shift pointer by number of functions in IR + iredired = iredired+itotalperIR(iredfirst) + end do + end if + end if + end do + end do +end do + +!bs copy integrals on arrays with no symmetry blocking at all +!bs which means huge triangular matrices +irun = 0 +do norb2=1,numballcart + ired2 = iredoffunctnew(norb2) + norbsh2 = norb2-shiftIRED(ired2) + do norb1=1,norb2 + ired1 = iredoffunctnew(norb1) + norbsh1 = noRb1-shiftIRED(ired1) + irun = irun+1 + iredired = shiftIRIR((ired2*ired2-ired2)/2+ired1) + if (ired1 /= ired2) then + oca2(irun,:) = oca(iredired+norbsh2+(norbsH1-1)*itotalperIR(IREd2),:) + else + oca2(irun,:) = oca(iredired+norbsh2*(norbsH2-1)/2+norbsh1,:) + end if + end do +end do +if (.not. AIMP) then + ! write a hermit-like file b.s. 4.10.96 + !BS write(u6,*) 'number of orbitals ',numbalLcart + !BS write(u6,*) 'length of triangular matrix ', length3 + !BS This was removed and will be done in SEWARD + !BS open(LUPROP,status='UNKNOWN',form='UNFORMATTED',file='AOPROPER_MF') + !BS rewind(LUPROP) + write(LUPROP) iCenter + write(LUPROP) xa,numbofsym,(nrtofiperIR(I),i=1,numbofsym),numballcart,(Loffunction(I),I=1,numballcart), & + (Moffunction(I),I=1,numballcart),Lhigh,(ncontrac(I),I=0,Lhigh) + write(LUPROP) (oca2(irun,1),irun=1,length3) + write(LUPROP) Ya + write(LUPROP) (oca2(irun,2),irun=1,length3) + write(LUPROP) Za + write(LUPROP) (oca2(irun,3),irun=1,length3) + !BS close(LUPROP) +else + !bs reorder for AIMP + !bs write(u6,*) 'reorder integrals for AIMP' + length3 = ikeeporb*(ikeeporb+1)/2 + call mma_allocate(OCA3,length3,3,Label='OCA3') + OCA3(:,:) = Zero + !bs write(u6,*) 'number of orbitals ',ikeeporb + !bs write(u6,*) 'length of triangular matrix ', length3 + do irun2=1,ikeeporb + do irun1=1,irun2 + ind2 = ikeeplist(irun2) + ind1 = ikeeplist(irun1) + ipntold = iTri(ind1,ind2) + ipntnew = iTri(irun1,irun2) + + oca3(ipntnew,:) = oca2(ipntold,:) + end do + end do + !BS write(u6,*) 'transfered to new blocks' + !BS LUPROP = 19 + !BS open(LUPROP,status='UNKNOWN',form='UNFORMATTED',file='AOPROPER_MF') + !BS rewind(LUPROP) + + write(LUPROP) iCenter + write(LUPROP) xa,numbofsym,(nrtofiperIR(I),i=1,numbofsym),ikeeporb,(Loffunction(ikeeplist(i)),i=1,ikeeporb), & + (Moffunction(ikeeplist(i)),I=1,ikeeporb),Lhigh,((ncontrac(I)-icore(I)),I=0,Lhigh) + write(LUPROP) (oca3(irun,1),irun=1,length3) + write(LUPROP) ya + write(LUPROP) (oca3(irun,2),irun=1,length3) + write(LUPROP) za + write(LUPROP) (oca3(irun,3),irun=1,length3) + + call mma_deallocate(OCA3) + !BS close(LUPROP) +end if + +!bs that is it!! + +call mma_deallocate(OCA2) +call mma_deallocate(OCA) +call mma_deallocate(Dummy) + +return + +end subroutine contandmult diff -Nru openmolcas-22.02/src/amfi_util/contcasaOO.f openmolcas-22.10/src/amfi_util/contcasaOO.f --- openmolcas-22.02/src/amfi_util/contcasaOO.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contcasaOO.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,108 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine contcasaOO(l1,l2,l3,l4,nstart,primints, - *scratch1,scratch2,cont4OO) -cbs contraction for powers (+2) with alpha1*alpha3 -cbs other-orbit term -cbs use averaged integrals by interchanging kinematic factors -cbs this is case a in the documentation - implicit real*8 (a-h,o-z) -#include "para.fh" -#include "param.fh" - dimension ncont(4),nprim(4),primints(*),scratch1(*),scratch2(*) - *,cont4OO(*) - ncont(1)=ncontrac(l1) - ncont(2)=ncontrac(l2) - ncont(3)=ncontrac(l3) - ncont(4)=ncontrac(l4) - nprim(1)=nprimit(l1) - nprim(2)=nprimit(l2) - nprim(3)=nprimit(l3) - nprim(4)=nprimit(l4) - ilength=nprim(1)*nprim(2)*nprim(3)*nprim(4) - nprod=ncont(1)*ncont(2)*ncont(3)*ncont(4) -C -C -C -cbs copy primitive integrals to scratch1 - do IRUN=1,ilength - scratch1(IRUN)=primints(IRUN) - enddo - call contract( - *contrarray(iaddtyp2(l1)), !A *alpha - *contrarray(iaddtyp3(l2)), !A/E+m - *contrarray(iaddtyp4(l3)), !A/E+m *alpha - *contrarray(iaddtyp1(l4)), !A - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index - *scratch1,scratch2) - do irun=1,nprod - cont4OO(nstart+irun-1)=0.25d0*scratch1(irun) - enddo -C -C -C -cbs copy primitive integrals to scratch1 - do IRUN=1,ilength - scratch1(IRUN)=primints(IRUN) - enddo - call contract( - *contrarray(iaddtyp4(l1)), - *contrarray(iaddtyp3(l2)), - *contrarray(iaddtyp2(l3)), - *contrarray(iaddtyp1(l4)), - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index - *scratch1,scratch2) - do irun=1,nprod - cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+0.25d0* - *scratch1(irun) - enddo -C -C -C -cbs copy primitive integrals to scratch1 - do IRUN=1,ilength - scratch1(IRUN)=primints(IRUN) - enddo - call contract( - *contrarray(iaddtyp2(l1)), - *contrarray(iaddtyp1(l2)), - *contrarray(iaddtyp4(l3)), - *contrarray(iaddtyp3(l4)), - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index - *scratch1,scratch2) - do irun=1,nprod - cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+0.25d0* - *scratch1(irun) - enddo -C -C -C -cbs copy primitive integrals to scratch1 - do IRUN=1,ilength - scratch1(IRUN)=primints(IRUN) - enddo - call contract( - *contrarray(iaddtyp4(l1)), - *contrarray(iaddtyp1(l2)), - *contrarray(iaddtyp2(l3)), - *contrarray(iaddtyp3(l4)), - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index - *scratch1,scratch2) - do irun=1,nprod - cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+0.25d0* - *scratch1(irun) - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/contcasaoo.F90 openmolcas-22.10/src/amfi_util/contcasaoo.F90 --- openmolcas-22.02/src/amfi_util/contcasaoo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contcasaoo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,75 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine contcasaOO(l1,l2,l3,l4,nstart,primints,scratch1,scratch2,cont4OO) +!bs contraction for powers (+2) with alpha1*alpha3 +!bs other-orbit term +!bs use averaged integrals by interchanging kinematic factors +!bs this is case a in the documentation + +use AMFI_global, only: contrarray, ncontrac, nprimit +use Constants, only: Quart +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: l1, l2, l3, l4, nstart +real(kind=wp), intent(in) :: primints(*) +real(kind=wp), intent(_OUT_) :: scratch1(*), scratch2(*), cont4OO(*) +integer(kind=iwp) :: ilength, ncont(4), nprim(4), nprod + +ncont(1) = ncontrac(l1) +ncont(2) = ncontrac(l2) +ncont(3) = ncontrac(l3) +ncont(4) = ncontrac(l4) +nprod = ncont(1)*ncont(2)*ncont(3)*ncont(4) +nprim(1) = nprimit(l1) +nprim(2) = nprimit(l2) +nprim(3) = nprimit(l3) +nprim(4) = nprimit(l4) +ilength = nprim(1)*nprim(2)*nprim(3)*nprim(4) + +!bs copy primitive integrals to scratch1 +scratch1(1:ilength) = primints(1:ilength) +!contract : A *alpha +!contrarray : A/E+m +!contrarray : A/E+m *alpha +!contrarray : A +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +call contract(contrarray(:,2,l1),contrarray(:,3,l2),contrarray(:,4,l3),contrarray(:,1,l4),ncont,nprim,scratch1,scratch2) +cont4OO(nstart:nstart+nprod-1) = Quart*scratch1(1:nprod) + +!bs copy primitive integrals to scratch1 +scratch1(1:ilength) = primints(1:ilength) +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +call contract(contrarray(:,4,l1),contrarray(:,3,l2),contrarray(:,2,l3),contrarray(:,1,l4),ncont,nprim,scratch1,scratch2) +cont4OO(nstart:nstart+nprod-1) = cont4OO(nstart:nstart+nprod-1)+Quart*scratch1(1:nprod) + +!bs copy primitive integrals to scratch1 +scratch1(1:ilength) = primints(1:ilength) +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +call contract(contrarray(:,2,l1),contrarray(:,1,l2),contrarray(:,4,l3),contrarray(:,3,l4),ncont,nprim,scratch1,scratch2) +cont4OO(nstart:nstart+nprod-1) = cont4OO(nstart:nstart+nprod-1)+Quart*scratch1(1:nprod) + +!bs copy primitive integrals to scratch1 +scratch1(1:ilength) = primints(1:ilength) +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +call contract(contrarray(:,4,l1),contrarray(:,1,l2),contrarray(:,2,l3),contrarray(:,3,l4),ncont,nprim,scratch1,scratch2) +cont4OO(nstart:nstart+nprod-1) = cont4OO(nstart:nstart+nprod-1)+Quart*scratch1(1:nprod) + +return + +end subroutine contcasaOO diff -Nru openmolcas-22.02/src/amfi_util/contcasaSO.f openmolcas-22.10/src/amfi_util/contcasaSO.f --- openmolcas-22.02/src/amfi_util/contcasaSO.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contcasaSO.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,54 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine contcasaSO(l1,l2,l3,l4,nstart,primints, - *scratch1,scratch2,cont4SO) -cbs contraction for powers (+2) with alpha1*alpha3 -cbs same orbit term -cbs this is case a in the documentation - implicit real*8 (a-h,o-z) -#include "para.fh" -#include "param.fh" - dimension ncont(4),nprim(4),primints(*),scratch1(*),scratch2(*), - *cont4SO(*) - ncont(1)=ncontrac(l1) - ncont(2)=ncontrac(l2) - ncont(3)=ncontrac(l3) - ncont(4)=ncontrac(l4) - nprim(1)=nprimit(l1) - nprim(2)=nprimit(l2) - nprim(3)=nprimit(l3) - nprim(4)=nprimit(l4) - ilength=nprim(1)*nprim(2)*nprim(3)*nprim(4) - nprod=ncont(1)*ncont(2)*ncont(3)*ncont(4) -cbs copy primitive integrals to scratch1 - do IRUN=1,ilength - scratch1(IRUN)=primints(IRUN) - enddo -c write(6,*) 'scratch1 ',(scratch1(I),I=1,ilength) -c write(6,*) 'contraction coeff' -c write(6,*) (contrarray(iaddtyp4(l1)+I),I=0,nprim(1)-1) -c write(6,*) (contrarray(iaddtyp1(l2)+I),I=0,nprim(2)-1) -c write(6,*) (contrarray(iaddtyp4(l3)+I),I=0,nprim(3)-1) -c write(6,*) (contrarray(iaddtyp1(l4)+I),I=0,nprim(4)-1) - call contract( - *contrarray(iaddtyp4(l1)), - *contrarray(iaddtyp1(l2)), - *contrarray(iaddtyp4(l3)), - *contrarray(iaddtyp1(l4)), - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index - *scratch1,scratch2) -c write(6,*) 'nstart ',nstart - do irun=1,nprod - cont4SO(nstart+irun-1)=scratch1(irun) - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/contcasaso.F90 openmolcas-22.10/src/amfi_util/contcasaso.F90 --- openmolcas-22.02/src/amfi_util/contcasaso.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contcasaso.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,55 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine contcasaSO(l1,l2,l3,l4,nstart,primints,scratch1,scratch2,cont4SO) +!bs contraction for powers (+2) with alpha1*alpha3 +!bs same orbit term +!bs this is case a in the documentation + +use AMFI_global, only: contrarray, ncontrac, nprimit +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: l1, l2, l3, l4, nstart +real(kind=wp), intent(in) :: primints(*) +real(kind=wp), intent(_OUT_) :: scratch1(*), scratch2(*), cont4SO(*) +integer(kind=iwp) :: ilength, ncont(4), nprim(4), nprod + +ncont(1) = ncontrac(l1) +ncont(2) = ncontrac(l2) +ncont(3) = ncontrac(l3) +ncont(4) = ncontrac(l4) +nprod = ncont(1)*ncont(2)*ncont(3)*ncont(4) +nprim(1) = nprimit(l1) +nprim(2) = nprimit(l2) +nprim(3) = nprimit(l3) +nprim(4) = nprimit(l4) +ilength = nprim(1)*nprim(2)*nprim(3)*nprim(4) + +!bs copy primitive integrals to scratch1 +scratch1(1:ilength) = primints(1:ilength) +!write(u6,*) 'scratch1 ',(scratch1(I),I=1,ilength) +!write(u6,*) 'contraction coeff' +!write(u6,*) (contrarray(I,4,l1),I=1,nprim(1)) +!write(u6,*) (contrarray(I,1,l2),I=1,nprim(2)) +!write(u6,*) (contrarray(I,4,l3),I=1,nprim(3)) +!write(u6,*) (contrarray(I,1,l4),I=1,nprim(4)) +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +call contract(contrarray(:,4,l1),contrarray(:,1,l2),contrarray(:,4,l3),contrarray(:,1,l4),ncont,nprim,scratch1,scratch2) +!write(u6,*) 'nstart ',nstart +cont4SO(nstart:nstart+nprod-1) = scratch1(1:nprod) + +return + +end subroutine contcasaSO diff -Nru openmolcas-22.02/src/amfi_util/contcasb1OO.f openmolcas-22.10/src/amfi_util/contcasb1OO.f --- openmolcas-22.02/src/amfi_util/contcasb1OO.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contcasb1OO.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,107 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine contcasb1OO(l1,l2,l3,l4,nstart,primints, - *scratch1,scratch2,cont4OO) -cbs contraction for powers (0) with alpha1 -cbs this is one of the cases b in the documentation -cbs use averaged integrals by interchanging kinematic factors - implicit real*8 (a-h,o-z) -#include "para.fh" -#include "param.fh" - dimension ncont(4),nprim(4),primints(*),scratch1(*),scratch2(*) - *,cont4OO(*) - ncont(1)=ncontrac(l1) - ncont(2)=ncontrac(l2) - ncont(3)=ncontrac(l3) - ncont(4)=ncontrac(l4) - nprod=ncont(1)*ncont(2)*ncont(3)*ncont(4) - nprim(1)=nprimit(l1) - nprim(2)=nprimit(l2) - nprim(3)=nprimit(l3) - nprim(4)=nprimit(l4) -C -C -c -cbs copy primitive integrals to scratch1 - ilength=nprim(1)*nprim(2)*nprim(3)*nprim(4) - do IRUN=1,ilength - scratch1(IRUN)=primints(IRUN) - enddo - call contract( - *contrarray(iaddtyp2(l1)), - *contrarray(iaddtyp3(l2)), - *contrarray(iaddtyp3(l3)), - *contrarray(iaddtyp1(l4)), - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index - *scratch1,scratch2) - do irun=1,nprod - cont4OO(nstart+irun-1)=0.25d0*scratch1(irun) - enddo -C -C -C -cbs copy primitive integrals to scratch1 - do IRUN=1,ilength - scratch1(IRUN)=primints(IRUN) - enddo - call contract( - *contrarray(iaddtyp4(l1)), - *contrarray(iaddtyp3(l2)), - *contrarray(iaddtyp1(l3)), - *contrarray(iaddtyp1(l4)), - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index - *scratch1,scratch2) - do irun=1,nprod - cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+ - *0.25d0*scratch1(irun) - enddo -C -C -C -cbs copy primitive integrals to scratch1 - do IRUN=1,ilength - scratch1(IRUN)=primints(IRUN) - enddo - call contract( - *contrarray(iaddtyp2(l1)), - *contrarray(iaddtyp1(l2)), - *contrarray(iaddtyp3(l3)), - *contrarray(iaddtyp3(l4)), - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index - *scratch1,scratch2) - do irun=1,nprod - cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+ - *0.25d0*scratch1(irun) - enddo -C -C -C -cbs copy primitive integrals to scratch1 - do IRUN=1,ilength - scratch1(IRUN)=primints(IRUN) - enddo - call contract( - *contrarray(iaddtyp4(l1)), - *contrarray(iaddtyp1(l2)), - *contrarray(iaddtyp1(l3)), - *contrarray(iaddtyp3(l4)), - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index - *scratch1,scratch2) - do irun=1,nprod - cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+ - *0.25d0*scratch1(irun) - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/contcasb1oo.F90 openmolcas-22.10/src/amfi_util/contcasb1oo.F90 --- openmolcas-22.02/src/amfi_util/contcasb1oo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contcasb1oo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,70 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine contcasb1OO(l1,l2,l3,l4,nstart,primints,scratch1,scratch2,cont4OO) +!bs contraction for powers (0) with alpha1 +!bs this is one of the cases b in the documentation +!bs use averaged integrals by interchanging kinematic factors + +use AMFI_global, only: contrarray, ncontrac, nprimit +use Constants, only: Quart +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: l1, l2, l3, l4, nstart +real(kind=wp), intent(in) :: primints(*) +real(kind=wp), intent(_OUT_) :: scratch1(*), scratch2(*), cont4OO(*) +integer(kind=iwp) :: ilength, ncont(4), nprim(4), nprod + +ncont(1) = ncontrac(l1) +ncont(2) = ncontrac(l2) +ncont(3) = ncontrac(l3) +ncont(4) = ncontrac(l4) +nprod = ncont(1)*ncont(2)*ncont(3)*ncont(4) +nprim(1) = nprimit(l1) +nprim(2) = nprimit(l2) +nprim(3) = nprimit(l3) +nprim(4) = nprimit(l4) +ilength = nprim(1)*nprim(2)*nprim(3)*nprim(4) + +!bs copy primitive integrals to scratch1 +scratch1(1:ilength) = primints(1:ilength) +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +call contract(contrarray(:,2,l1),contrarray(:,3,l2),contrarray(:,3,l3),contrarray(:,1,l4),ncont,nprim,scratch1,scratch2) +cont4OO(nstart:nstart+nprod-1) = Quart*scratch1(1:nprod) + +!bs copy primitive integrals to scratch1 +scratch1(1:ilength) = primints(1:ilength) +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +call contract(contrarray(:,4,l1),contrarray(:,3,l2),contrarray(:,1,l3),contrarray(:,1,l4),ncont,nprim,scratch1,scratch2) +cont4OO(nstart:nstart+nprod-1) = cont4OO(nstart:nstart+nprod-1)+Quart*scratch1(1:nprod) + +!bs copy primitive integrals to scratch1 +scratch1(1:ilength) = primints(1:ilength) +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +call contract(contrarray(:,2,l1),contrarray(:,1,l2),contrarray(:,3,l3),contrarray(:,3,l4),ncont,nprim,scratch1,scratch2) +cont4OO(nstart:nstart+nprod-1) = cont4OO(nstart:nstart+nprod-1)+Quart*scratch1(1:nprod) + +!bs copy primitive integrals to scratch1 +scratch1(1:ilength) = primints(1:ilength) +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +call contract(contrarray(:,4,l1),contrarray(:,1,l2),contrarray(:,1,l3),contrarray(:,3,l4),ncont,nprim,scratch1,scratch2) +cont4OO(nstart:nstart+nprod-1) = cont4OO(nstart:nstart+nprod-1)+Quart*scratch1(1:nprod) + +return + +end subroutine contcasb1OO diff -Nru openmolcas-22.02/src/amfi_util/contcasb1SO.f openmolcas-22.10/src/amfi_util/contcasb1SO.f --- openmolcas-22.02/src/amfi_util/contcasb1SO.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contcasb1SO.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine contcasb1SO(l1,l2,l3,l4,nstart,primints, - *scratch1,scratch2,cont4SO) -cbs contraction for powers (0) with alpha1 -cbs this is one of the cases b in the documentation - implicit real*8 (a-h,o-z) -#include "para.fh" -#include "param.fh" - dimension ncont(4),nprim(4),primints(*),scratch1(*),scratch2(*), - *cont4SO(*) - ncont(1)=ncontrac(l1) - ncont(2)=ncontrac(l2) - ncont(3)=ncontrac(l3) - ncont(4)=ncontrac(l4) - nprod=ncont(1)*ncont(2)*ncont(3)*ncont(4) - nprim(1)=nprimit(l1) - nprim(2)=nprimit(l2) - nprim(3)=nprimit(l3) - nprim(4)=nprimit(l4) -cbs copy primitive integrals to scratch1 - ilength=nprim(1)*nprim(2)*nprim(3)*nprim(4) - do IRUN=1,ilength - scratch1(IRUN)=primints(IRUN) - enddo - call contract( - *contrarray(iaddtyp4(l1)), - *contrarray(iaddtyp1(l2)), - *contrarray(iaddtyp3(l3)), - *contrarray(iaddtyp1(l4)), - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index - *scratch1,scratch2) - call dcopy_(nprod,scratch1(1),1,cont4SO(nstart),1) - return - end diff -Nru openmolcas-22.02/src/amfi_util/contcasb1so.F90 openmolcas-22.10/src/amfi_util/contcasb1so.F90 --- openmolcas-22.02/src/amfi_util/contcasb1so.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contcasb1so.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,47 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine contcasb1SO(l1,l2,l3,l4,nstart,primints,scratch1,scratch2,cont4SO) +!bs contraction for powers (0) with alpha1 +!bs this is one of the cases b in the documentation + +use AMFI_global, only: contrarray, ncontrac, nprimit +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: l1, l2, l3, l4, nstart +real(kind=wp), intent(in) :: primints(*) +real(kind=wp), intent(_OUT_) :: scratch1(*), scratch2(*), cont4SO(*) +integer(kind=iwp) :: ilength, ncont(4), nprim(4), nprod + +ncont(1) = ncontrac(l1) +ncont(2) = ncontrac(l2) +ncont(3) = ncontrac(l3) +ncont(4) = ncontrac(l4) +nprod = ncont(1)*ncont(2)*ncont(3)*ncont(4) +nprim(1) = nprimit(l1) +nprim(2) = nprimit(l2) +nprim(3) = nprimit(l3) +nprim(4) = nprimit(l4) +ilength = nprim(1)*nprim(2)*nprim(3)*nprim(4) + +!bs copy primitive integrals to scratch1 +scratch1(1:ilength) = primints(1:ilength) +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +call contract(contrarray(:,4,l1),contrarray(:,1,l2),contrarray(:,3,l3),contrarray(:,1,l4),ncont,nprim,scratch1,scratch2) +cont4SO(nstart:nstart+nprod-1) = scratch1(1:nprod) + +return + +end subroutine contcasb1SO diff -Nru openmolcas-22.02/src/amfi_util/contcasb2OO.f openmolcas-22.10/src/amfi_util/contcasb2OO.f --- openmolcas-22.02/src/amfi_util/contcasb2OO.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contcasb2OO.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,107 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine contcasb2OO(l1,l2,l3,l4,nstart,primints, - *scratch1,scratch2,cont4OO) -cbs contraction for powers (0) with alpha3 -cbs this is one of the cases b in the documentation -cbs use averaged integrals by interchanging kinematic factors - implicit real*8 (a-h,o-z) -#include "para.fh" -#include "param.fh" - dimension ncont(4),nprim(4),primints(*),scratch1(*),scratch2(*) - *,cont4OO(*) - ncont(1)=ncontrac(l1) - ncont(2)=ncontrac(l2) - ncont(3)=ncontrac(l3) - ncont(4)=ncontrac(l4) - nprod=ncont(1)*ncont(2)*ncont(3)*ncont(4) - nprim(1)=nprimit(l1) - nprim(2)=nprimit(l2) - nprim(3)=nprimit(l3) - nprim(4)=nprimit(l4) - ilength=nprim(1)*nprim(2)*nprim(3)*nprim(4) -c -c -C -cbs copy primitive integrals to scratch1 - do IRUN=1,ilength - scratch1(IRUN)=primints(IRUN) - enddo - call contract( - *contrarray(iaddtyp1(l1)), - *contrarray(iaddtyp3(l2)), - *contrarray(iaddtyp4(l3)), - *contrarray(iaddtyp1(l4)), - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index - *scratch1,scratch2) - do irun=1,nprod - cont4OO(nstart+irun-1)=0.25d0*scratch1(irun) - enddo -c -c -C -cbs copy primitive integrals to scratch1 - do IRUN=1,ilength - scratch1(IRUN)=primints(IRUN) - enddo - call contract( - *contrarray(iaddtyp3(l1)), - *contrarray(iaddtyp3(l2)), - *contrarray(iaddtyp2(l3)), - *contrarray(iaddtyp1(l4)), - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index - *scratch1,scratch2) - do irun=1,nprod - cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+ - *0.25d0*scratch1(irun) - enddo -c -c -C -cbs copy primitive integrals to scratch1 - do IRUN=1,ilength - scratch1(IRUN)=primints(IRUN) - enddo - call contract( - *contrarray(iaddtyp1(l1)), - *contrarray(iaddtyp1(l2)), - *contrarray(iaddtyp4(l3)), - *contrarray(iaddtyp3(l4)), - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index - *scratch1,scratch2) - do irun=1,nprod - cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+ - *0.25d0*scratch1(irun) - enddo -c -c -C -cbs copy primitive integrals to scratch1 - do IRUN=1,ilength - scratch1(IRUN)=primints(IRUN) - enddo - call contract( - *contrarray(iaddtyp3(l1)), - *contrarray(iaddtyp1(l2)), - *contrarray(iaddtyp2(l3)), - *contrarray(iaddtyp3(l4)), - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index - *scratch1,scratch2) - do irun=1,nprod - cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+ - *0.25d0*scratch1(irun) - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/contcasb2oo.F90 openmolcas-22.10/src/amfi_util/contcasb2oo.F90 --- openmolcas-22.02/src/amfi_util/contcasb2oo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contcasb2oo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,70 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine contcasb2OO(l1,l2,l3,l4,nstart,primints,scratch1,scratch2,cont4OO) +!bs contraction for powers (0) with alpha3 +!bs this is one of the cases b in the documentation +!bs use averaged integrals by interchanging kinematic factors + +use AMFI_global, only: contrarray, ncontrac, nprimit +use Constants, only: Quart +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: l1, l2, l3, l4, nstart +real(kind=wp), intent(in) :: primints(*) +real(kind=wp), intent(_OUT_) :: scratch1(*), scratch2(*), cont4OO(*) +integer(kind=iwp) :: ilength, ncont(4), nprim(4), nprod + +ncont(1) = ncontrac(l1) +ncont(2) = ncontrac(l2) +ncont(3) = ncontrac(l3) +ncont(4) = ncontrac(l4) +nprod = ncont(1)*ncont(2)*ncont(3)*ncont(4) +nprim(1) = nprimit(l1) +nprim(2) = nprimit(l2) +nprim(3) = nprimit(l3) +nprim(4) = nprimit(l4) +ilength = nprim(1)*nprim(2)*nprim(3)*nprim(4) + +!bs copy primitive integrals to scratch1 +scratch1(1:ilength) = primints(1:ilength) +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +call contract(contrarray(:,1,l1),contrarray(:,3,l2),contrarray(:,4,l3),contrarray(:,1,l4),ncont,nprim,scratch1,scratch2) +cont4OO(nstart:nstart+nprod-1) = Quart*scratch1(1:nprod) + +!bs copy primitive integrals to scratch1 +scratch1(1:ilength) = primints(1:ilength) +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +call contract(contrarray(:,3,l1),contrarray(:,3,l2),contrarray(:,2,l3),contrarray(:,1,l4),ncont,nprim,scratch1,scratch2) +cont4OO(nstart:nstart+nprod-1) = cont4OO(nstart:nstart+nprod-1)+Quart*scratch1(1:nprod) + +!bs copy primitive integrals to scratch1 +scratch1(1:ilength) = primints(1:ilength) +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +call contract(contrarray(:,1,l1),contrarray(:,1,l2),contrarray(:,4,l3),contrarray(:,3,l4),ncont,nprim,scratch1,scratch2) +cont4OO(nstart:nstart+nprod-1) = cont4OO(nstart:nstart+nprod-1)+Quart*scratch1(1:nprod) + +!bs copy primitive integrals to scratch1 +scratch1(1:ilength) = primints(1:ilength) +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +call contract(contrarray(:,3,l1),contrarray(:,1,l2),contrarray(:,2,l3),contrarray(:,3,l4),ncont,nprim,scratch1,scratch2) +cont4OO(nstart:nstart+nprod-1) = cont4OO(nstart:nstart+nprod-1)+Quart*scratch1(1:nprod) + +return + +end subroutine contcasb2OO diff -Nru openmolcas-22.02/src/amfi_util/contcasb2SO.f openmolcas-22.10/src/amfi_util/contcasb2SO.f --- openmolcas-22.02/src/amfi_util/contcasb2SO.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contcasb2SO.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine contcasb2SO(l1,l2,l3,l4,nstart,primints, - *scratch1,scratch2,cont4SO) -cbs contraction for powers (0) with alpha3 -cbs this is one of the cases b in the documentation - implicit real*8 (a-h,o-z) -#include "para.fh" -#include "param.fh" - dimension ncont(4),nprim(4),primints(*),scratch1(*),scratch2(*), - *cont4SO(*) - ncont(1)=ncontrac(l1) - ncont(2)=ncontrac(l2) - ncont(3)=ncontrac(l3) - ncont(4)=ncontrac(l4) - nprod=ncont(1)*ncont(2)*ncont(3)*ncont(4) - nprim(1)=nprimit(l1) - nprim(2)=nprimit(l2) - nprim(3)=nprimit(l3) - nprim(4)=nprimit(l4) - ilength=nprim(1)*nprim(2)*nprim(3)*nprim(4) -cbs copy primitive integrals to scratch1 - do IRUN=1,ilength - scratch1(IRUN)=primints(IRUN) - enddo - call contract( - *contrarray(iaddtyp3(l1)), - *contrarray(iaddtyp1(l2)), - *contrarray(iaddtyp4(l3)), - *contrarray(iaddtyp1(l4)), - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index - *scratch1,scratch2) - call dcopy_(nprod,scratch1(1),1,cont4SO(nstart),1) - return - end diff -Nru openmolcas-22.02/src/amfi_util/contcasb2so.F90 openmolcas-22.10/src/amfi_util/contcasb2so.F90 --- openmolcas-22.02/src/amfi_util/contcasb2so.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contcasb2so.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,47 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine contcasb2SO(l1,l2,l3,l4,nstart,primints,scratch1,scratch2,cont4SO) +!bs contraction for powers (0) with alpha3 +!bs this is one of the cases b in the documentation + +use AMFI_global, only: contrarray, ncontrac, nprimit +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: l1, l2, l3, l4, nstart +real(kind=wp), intent(in) :: primints(*) +real(kind=wp), intent(_OUT_) :: scratch1(*), scratch2(*), cont4SO(*) +integer(kind=iwp) :: ilength, ncont(4), nprim(4), nprod + +ncont(1) = ncontrac(l1) +ncont(2) = ncontrac(l2) +ncont(3) = ncontrac(l3) +ncont(4) = ncontrac(l4) +nprod = ncont(1)*ncont(2)*ncont(3)*ncont(4) +nprim(1) = nprimit(l1) +nprim(2) = nprimit(l2) +nprim(3) = nprimit(l3) +nprim(4) = nprimit(l4) +ilength = nprim(1)*nprim(2)*nprim(3)*nprim(4) + +!bs copy primitive integrals to scratch1 +scratch1(1:ilength) = primints(1:ilength) +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +call contract(contrarray(:,3,l1),contrarray(:,1,l2),contrarray(:,4,l3),contrarray(:,1,l4),ncont,nprim,scratch1,scratch2) +cont4SO(nstart:nstart+nprod-1) = scratch1(1:nprod) + +return + +end subroutine contcasb2SO diff -Nru openmolcas-22.02/src/amfi_util/contcascOO.f openmolcas-22.10/src/amfi_util/contcascOO.f --- openmolcas-22.02/src/amfi_util/contcascOO.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contcascOO.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,107 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBroutine contcascOO(l1,l2,l3,l4,nstart,primints, - *scratch1,scratch2,cont4OO) -cbs contraction for powers (-2) with factor 1 -cbs this is case c in the documentation -cbs use averaged integrals by interchanging kinematic factors - implicit real*8 (a-h,o-z) -#include "para.fh" -#include "param.fh" - dimension ncont(4),nprim(4),primints(*),scratch1(*),scratch2(*) - *,cont4OO(*) - ncont(1)=ncontrac(l1) - ncont(2)=ncontrac(l2) - ncont(3)=ncontrac(l3) - ncont(4)=ncontrac(l4) - nprod=ncont(1)*ncont(2)*ncont(3)*ncont(4) - nprim(1)=nprimit(l1) - nprim(2)=nprimit(l2) - nprim(3)=nprimit(l3) - nprim(4)=nprimit(l4) - ilength=nprim(1)*nprim(2)*nprim(3)*nprim(4) -c -c -C -cbs copy primitive integrals to scratch1 - do IRUN=1,ilength - scratch1(IRUN)=primints(IRUN) - enddo - call contract( - *contrarray(iaddtyp1(l1)), - *contrarray(iaddtyp3(l2)), - *contrarray(iaddtyp3(l3)), - *contrarray(iaddtyp1(l4)), - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index - *scratch1,scratch2) - do irun=1,nprod - cont4OO(nstart+irun-1)=0.25d0*scratch1(irun) - enddo -c -c -C -cbs copy primitive integrals to scratch1 - do IRUN=1,ilength - scratch1(IRUN)=primints(IRUN) - enddo - call contract( - *contrarray(iaddtyp3(l1)), - *contrarray(iaddtyp3(l2)), - *contrarray(iaddtyp1(l3)), - *contrarray(iaddtyp1(l4)), - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index - *scratch1,scratch2) - do irun=1,nprod - cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+ - *0.25d0*scratch1(irun) - enddo -c -c -C -cbs copy primitive integrals to scratch1 - do IRUN=1,ilength - scratch1(IRUN)=primints(IRUN) - enddo - call contract( - *contrarray(iaddtyp1(l1)), - *contrarray(iaddtyp1(l2)), - *contrarray(iaddtyp3(l3)), - *contrarray(iaddtyp3(l4)), - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index - *scratch1,scratch2) - do irun=1,nprod - cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+ - *0.25d0*scratch1(irun) - enddo -c -c -C -cbs copy primitive integrals to scratch1 - do IRUN=1,ilength - scratch1(IRUN)=primints(IRUN) - enddo - call contract( - *contrarray(iaddtyp3(l1)), - *contrarray(iaddtyp1(l2)), - *contrarray(iaddtyp1(l3)), - *contrarray(iaddtyp3(l4)), - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index - *scratch1,scratch2) - do irun=1,nprod - cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+ - *0.25d0*scratch1(irun) - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/contcascoo.F90 openmolcas-22.10/src/amfi_util/contcascoo.F90 --- openmolcas-22.02/src/amfi_util/contcascoo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contcascoo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,70 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine contcascOO(l1,l2,l3,l4,nstart,primints,scratch1,scratch2,cont4OO) +!bs contraction for powers (-2) with factor 1 +!bs this is case c in the documentation +!bs use averaged integrals by interchanging kinematic factors + +use AMFI_global, only: contrarray, ncontrac, nprimit +use Constants, only: Quart +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: l1, l2, l3, l4, nstart +real(kind=wp), intent(in) :: primints(*) +real(kind=wp), intent(_OUT_) :: scratch1(*), scratch2(*), cont4OO(*) +integer(kind=iwp) :: ilength, ncont(4), nprim(4), nprod + +ncont(1) = ncontrac(l1) +ncont(2) = ncontrac(l2) +ncont(3) = ncontrac(l3) +ncont(4) = ncontrac(l4) +nprod = ncont(1)*ncont(2)*ncont(3)*ncont(4) +nprim(1) = nprimit(l1) +nprim(2) = nprimit(l2) +nprim(3) = nprimit(l3) +nprim(4) = nprimit(l4) +ilength = nprim(1)*nprim(2)*nprim(3)*nprim(4) + +!bs copy primitive integrals to scratch1 +scratch1(1:ilength) = primints(1:ilength) +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +call contract(contrarray(:,1,l1),contrarray(:,3,l2),contrarray(:,3,l3),contrarray(:,1,l4),ncont,nprim,scratch1,scratch2) +cont4OO(nstart:nstart+nprod-1) = Quart*scratch1(1:nprod) + +!bs copy primitive integrals to scratch1 +scratch1(1:ilength) = primints(1:ilength) +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +call contract(contrarray(:,3,l1),contrarray(:,3,l2),contrarray(:,1,l3),contrarray(:,1,l4),ncont,nprim,scratch1,scratch2) +cont4OO(nstart:nstart+nprod-1) = cont4OO(nstart:nstart+nprod-1)+Quart*scratch1(1:nprod) + +!bs copy primitive integrals to scratch1 +scratch1(1:ilength) = primints(1:ilength) +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +call contract(contrarray(:,1,l1),contrarray(:,1,l2),contrarray(:,3,l3),contrarray(:,3,l4),ncont,nprim,scratch1,scratch2) +cont4OO(nstart:nstart+nprod-1) = cont4OO(nstart:nstart+nprod-1)+Quart*scratch1(1:nprod) + +!bs copy primitive integrals to scratch1 +scratch1(1:ilength) = primints(1:ilength) +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +call contract(contrarray(:,3,l1),contrarray(:,1,l2),contrarray(:,1,l3),contrarray(:,3,l4),ncont,nprim,scratch1,scratch2) +cont4OO(nstart:nstart+nprod-1) = cont4OO(nstart:nstart+nprod-1)+Quart*scratch1(1:nprod) + +return + +end subroutine contcascOO diff -Nru openmolcas-22.02/src/amfi_util/contcascSO.f openmolcas-22.10/src/amfi_util/contcascSO.f --- openmolcas-22.02/src/amfi_util/contcascSO.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contcascSO.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine contcascSO(l1,l2,l3,l4,nstart,primints, - *scratch1,scratch2,cont4SO) -cbs contraction for powers (-2) with factor 1 -cbs this is case c in the documentation - implicit real*8 (a-h,o-z) -#include "para.fh" -#include "param.fh" - dimension ncont(4),nprim(4),primints(*),scratch1(*),scratch2(*), - *cont4SO(*) - ncont(1)=ncontrac(l1) - ncont(2)=ncontrac(l2) - ncont(3)=ncontrac(l3) - ncont(4)=ncontrac(l4) - nprod=ncont(1)*ncont(2)*ncont(3)*ncont(4) - nprim(1)=nprimit(l1) - nprim(2)=nprimit(l2) - nprim(3)=nprimit(l3) - nprim(4)=nprimit(l4) - ilength=nprim(1)*nprim(2)*nprim(3)*nprim(4) -cbs copy primitive integrals to scratch1 - do IRUN=1,ilength - scratch1(IRUN)=primints(IRUN) - enddo - call contract( - *contrarray(iaddtyp3(l1)), - *contrarray(iaddtyp1(l2)), - *contrarray(iaddtyp3(l3)), - *contrarray(iaddtyp1(l4)), - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index - *scratch1,scratch2) - call dcopy_(nprod,scratch1(1),1,cont4SO(nstart),1) - return - end diff -Nru openmolcas-22.02/src/amfi_util/contcascso.F90 openmolcas-22.10/src/amfi_util/contcascso.F90 --- openmolcas-22.02/src/amfi_util/contcascso.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contcascso.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,47 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine contcascSO(l1,l2,l3,l4,nstart,primints,scratch1,scratch2,cont4SO) +!bs contraction for powers (-2) with factor 1 +!bs this is case c in the documentation + +use AMFI_global, only: contrarray, ncontrac, nprimit +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: l1, l2, l3, l4, nstart +real(kind=wp), intent(in) :: primints(*) +real(kind=wp), intent(_OUT_) :: scratch1(*), scratch2(*), cont4SO(*) +integer(kind=iwp) :: ilength, ncont(4), nprim(4), nprod + +ncont(1) = ncontrac(l1) +ncont(2) = ncontrac(l2) +ncont(3) = ncontrac(l3) +ncont(4) = ncontrac(l4) +nprod = ncont(1)*ncont(2)*ncont(3)*ncont(4) +nprim(1) = nprimit(l1) +nprim(2) = nprimit(l2) +nprim(3) = nprimit(l3) +nprim(4) = nprimit(l4) +ilength = nprim(1)*nprim(2)*nprim(3)*nprim(4) + +!bs copy primitive integrals to scratch1 +scratch1(1:ilength) = primints(1:ilength) +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +call contract(contrarray(:,3,l1),contrarray(:,1,l2),contrarray(:,3,l3),contrarray(:,1,l4),ncont,nprim,scratch1,scratch2) +cont4SO(nstart:nstart+nprod-1) = scratch1(1:nprod) + +return + +end subroutine contcascSO diff -Nru openmolcas-22.02/src/amfi_util/cont.f openmolcas-22.10/src/amfi_util/cont.f --- openmolcas-22.02/src/amfi_util/cont.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/cont.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,53 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine cont(L,breit,ifinite) -cbs########################################################################### -cbs cont prepares all required contraction coefficients for functions -cbs with angular momentum L -cbs########################################################################### - implicit real*8 (a-h,o-z) -#include "para.fh" -#include "param.fh" - dimension tkintria((MxprimL*MxprimL+MxprimL)/2) - logical breit,breit_finite - breit_finite=.true. -cbs transcon transfers and normalizes contracted functions -cbs ore more precizely the coefficients - call transcon(cntscrtch(1,1,L),MxprimL, - *MxcontL,normovlp(1,1,L), - *contrarray(iaddori(L)),nprimit(L),ncontrac(L)) -cbs gentkin generates the matrix of kinetic energy TKIN - call gentkin(L,TKIN,nprimit(L),exponents(1,L),rootOVLPinv(1,1,L)) -cbs kindiag diagonalizes TKIN -cbs for finite nucleus - if (ifinite.eq.2.and.L.eq.0) then - call kindiag(TKIN,TKINTRIA,nprimit(L),evec,eval,breit_finite) - else - call kindiag(TKIN,TKINTRIA,nprimit(L),evec,eval,breit) - endif -cbs kinemat generates kinematic factors in -cbs the basis of eigenvectors - call kinemat(L,nprimit(L),eval,type1,type2,Energy) -cbs chngcont= changecont generates the contraction coeffs -cbs including kinematic factors and even exponents as factors - call chngcont( - *contrarray(iaddori(L)), - *contrarray(iaddtyp1(L)), - *contrarray(iaddtyp2(L)), - *contrarray(iaddtyp3(L)), - *contrarray(iaddtyp4(L)), - *ncontrac(L),nprimit(L),evec, - *type1,type2,scratch4,scratch4(nprimit(L)*nprimit(L)+1), - *scratch4(2*nprimit(L)*nprimit(L)+1),MxprimL, - *rootOVLP(1,1,L),OVLPinv(1,1,L), - *exponents(1,L)) - return - end diff -Nru openmolcas-22.02/src/amfi_util/cont.F90 openmolcas-22.10/src/amfi_util/cont.F90 --- openmolcas-22.02/src/amfi_util/cont.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/cont.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,51 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine cont(L,breit,ifinite,TKIN,evec,eval,Energy,type1,type2,scratch) +!bs #################################################################### +!bs cont prepares all required contraction coefficients for functions +!bs with angular momentum L +!bs #################################################################### + +use AMFI_global, only: cntscrtch, contrarray, exponents, MxcontL, MxprimL, ncontrac, normovlp, nprimit, OVLPinv, rootOVLP, & + rootOVLPinv +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: L, ifinite +logical(kind=iwp), intent(in) :: breit +real(kind=wp), intent(out) :: TKIN(MxprimL,MxprimL), evec(MxprimL,MxprimL), eval(MxprimL), Energy(MxprimL), type1(MxprimL), & + type2(MxprimL), scratch(MxprimL,MxprimL,3) +logical(kind=iwp), parameter :: breit_finite = .true. + +!bs transcon transfers and normalizes contracted functions +!bs ore more precisely the coefficients +call transcon(cntscrtch(:,:,L),MxprimL,MxcontL,normovlp(:,:,L),contrarray(:,0,L),nprimit(L),ncontrac(L)) +!bs gentkin generates the matrix of kinetic energy TKIN +call gentkin(L,TKIN,nprimit(L),exponents(:,L),rootOVLPinv(:,:,L)) +!bs kindiag diagonalizes TKIN +!bs for finite nucleus +if ((ifinite == 2) .and. (L == 0)) then + call kindiag(TKIN,nprimit(L),evec,eval,breit_finite) +else + call kindiag(TKIN,nprimit(L),evec,eval,breit) +end if +!bs kinemat generates kinematic factors in +!bs the basis of eigenvectors +call kinemat(nprimit(L),eval,type1,type2,Energy) +!bs chngcont= changecont generates the contraction coeffs +!bs including kinematic factors and even exponents as factors +call chngcont(contrarray(:,0,L),contrarray(:,1,L),contrarray(:,2,L),contrarray(:,3,L),contrarray(:,4,L),ncontrac(L),nprimit(L), & + evec,type1,type2,scratch(:,:,1),scratch(:,:,2),scratch(:,:,3),MxprimL,rootOVLP(:,:,L),OVLPinv(:,:,L),exponents(:,L)) + +return + +end subroutine cont diff -Nru openmolcas-22.02/src/amfi_util/contone.f openmolcas-22.10/src/amfi_util/contone.f --- openmolcas-22.02/src/amfi_util/contone.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contone.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,88 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine contone(L,oneoverR3,onecontr,Lmax, - *contcoeff,nprim,ncont,MxcontL,dummy, - *onecartx,onecartY,onecartZ,charge,oneonly) -cbs contracts one-electron integrals and multiplies with l,m-dependent -cbs factors for L-,L0,L+ - implicit real*8 (a-h,o-z) - dimension oneoverR3(*), - *onecontr(MxcontL,MxcontL,-Lmax:Lmax,3), - *contcoeff(nprim,ncont),dummy(ncont,ncont), - *onecartx(MxcontL,MxcontL, - *(Lmax+Lmax+1)*(Lmax+1)), - *onecarty(MxcontL,MxcontL, - *(Lmax+Lmax+1)*(Lmax+1)), - *onecartz(MxcontL,MxcontL, - *(Lmax+Lmax+1)*(Lmax+1)) - logical oneonly - ipnt(I,J)=(max(i,j)*(max(i,j)-1))/2+min(i,j) -cbs first of all cleaning dummy and onecontr - do jrun=1,ncont - do irun=1,ncont - dummy(irun,jrun)=0d0 - enddo - enddo - if (oneonly) then - iprod=MxcontL*MxcontL*(Lmax+Lmax+1)*(Lmax+1) - call dzero(onecartx,iprod) - call dzero(onecarty,iprod) - call dzero(onecartz,iprod) - endif - iprod=3*(Lmax+lmax+1)*MxcontL*MxcontL - call dzero(onecontr,iprod) -cbs contract onto dummy - do icont2=1,ncont - do icont1=1,ncont - do iprim2=1,nprim - do iprim1=1,nprim - dummy(icont1,icont2)=dummy(icont1,icont2)+ - *contcoeff(iprim1,icont1)*contcoeff(iprim2,icont2)* - *oneoverR3(ipnt(iprim1,iprim2)) - enddo - enddo - enddo - enddo - do icont2=1,ncont - do icont1=1,ncont - dummy(icont1,icont2)=dummy(icont1,icont2)*charge - enddo - enddo -cbs start to add l,m dependent factors - do M=-L,L - factormin=sqrt(DBLE(L*L-M*M+L+M)) - factor0=DBLE(M) - factorplus=sqrt(DBLE(L*L-M*M+L-M)) - do irun=1,ncont - do jrun=1,ncont - onecontr(irun,jrun,M,1)=dummy(jrun,irun)*factormin ! L-minus - enddo - enddo - do irun=1,ncont - do jrun=1,ncont - onecontr(irun,jrun,M,2)=dummy(jrun,irun)*factor0 ! L-0 - enddo - enddo - do irun=1,ncont - do jrun=1,ncont - onecontr(irun,jrun,M,3)=dummy(jrun,irun)*factorplus ! L-plus - enddo - enddo - enddo -cbs make the final cartesian integrals - call cartoneX(L,Lmax,onecontr,ncont, - *MxcontL,onecartX(1,1,1)) - call cartoneY(L,Lmax,onecontr,ncont, - *MxcontL,onecartY(1,1,1)) - call cartoneZ(L,Lmax,onecontr,ncont, - *MxcontL,onecartZ(1,1,1)) - return - end diff -Nru openmolcas-22.02/src/amfi_util/contone.F90 openmolcas-22.10/src/amfi_util/contone.F90 --- openmolcas-22.02/src/amfi_util/contone.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contone.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,64 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine contone(L,oneoverR3,onecontr,Lmax,contcoeff,nprim,ncont,MxcontL,dummy,onecartX,onecartY,onecartZ,charge,oneonly) +!bs contracts one-electron integrals and multiplies with l,m-dependent +!bs factors for L-,L0,L+ + +use index_functions, only: iTri +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: L, Lmax, nprim, ncont, MxcontL +real(kind=wp), intent(in) :: oneoverR3(*), contcoeff(nprim,ncont), charge +real(kind=wp), intent(out) :: onecontr(MxcontL,MxcontL,-Lmax:Lmax,3), dummy(ncont,ncont) +real(kind=wp), intent(inout) :: onecartX(MxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1)), & + onecartY(MxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1)), onecartZ(MxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1)) +logical(kind=iwp), intent(in) :: oneonly +integer(kind=iwp) :: icont1, icont2, iprim1, iprim2, M +real(kind=wp) :: factor0, factormin, factorplus + +!bs first of all cleaning dummy and onecontr +dummy(:,:) = Zero +if (oneonly) then + onecartx(:,:,:) = Zero + onecarty(:,:,:) = Zero + onecartz(:,:,:) = Zero +end if +onecontr(:,:,:,:) = Zero +!bs contract onto dummy +do icont1=1,ncont + do icont2=1,ncont + do iprim2=1,nprim + do iprim1=1,nprim + dummy(icont2,icont1) = dummy(icont2,icont1)+contcoeff(iprim1,icont1)*contcoeff(iprim2,icont2)*oneoverR3(iTri(iprim1,iprim2)) + end do + end do + end do +end do +!bs start to add l,m dependent factors +do M=-L,L + factormin = charge*sqrt(real(L*L-M*M+L+M,kind=wp)) + factor0 = charge*real(M,kind=wp) + factorplus = charge*sqrt(real(L*L-M*M+L-M,kind=wp)) + onecontr(1:ncont,1:ncont,M,1) = dummy*factormin ! L-minus + onecontr(1:ncont,1:ncont,M,2) = dummy*factor0 ! L-0 + onecontr(1:ncont,1:ncont,M,3) = dummy*factorplus ! L-plus +end do +!bs make the final cartesian integrals +call cartoneX(L,Lmax,onecontr,ncont,MxcontL,onecartX) +call cartoneY(L,Lmax,onecontr,ncont,MxcontL,onecartY) +call cartoneZ(L,Lmax,onecontr,ncont,MxcontL,onecartZ) + +return + +end subroutine contone diff -Nru openmolcas-22.02/src/amfi_util/contract.f openmolcas-22.10/src/amfi_util/contract.f --- openmolcas-22.02/src/amfi_util/contract.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contract.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,173 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine contract( - *coeffs1, !(nprim(1),ncont(1)) modified contraction coefficients - *coeffs2, !(nprim(2),ncont(2)) modified contraction coefficients - *coeffs3, !(nprim(3),ncont(3)) modified contraction coefficients - *coeffs4, !(nprim(4),ncont(4)) modified contraction coefficients - *ncont, ! i-th element is number of contracted functions i. index - *nprim, ! i-th element is number of primitive functions i. index -cbs array one contains at the beginning the uncontracted integrals - *arr1, ! array of size (nprim(1)*nprim(2)*nprim(3)*nprim(4)) - *arr2 ! array of size (nprim(1)*nprim(2)*nprim(3)*nprim(4)) - *) - implicit real*8 (a-h,o-z) - dimension coeffs1(*),coeffs2(*),coeffs3(*),coeffs4(*), - *arr1(*),arr2(*),ncont(4),nprim(4),nolds(4),nnew(4) -C -cbs makes four indextransformations in a row.... -cbs try to find out, which indices should be transformed first... -c - ratio1=DBLE(nprim(1))/DBLE(ncont(1)) - ratio2=DBLE(nprim(2))/DBLE(ncont(2)) - ratio3=DBLE(nprim(3))/DBLE(ncont(3)) - ratio4=DBLE(nprim(4))/DBLE(ncont(4)) - do IBM=1,4 - nolds(IBM)=nprim(IBM) - nnew(IBM)=nprim(IBM) - enddo -cbs determine first, second,third and last index -************************************************************************ -cbs determine the first - xmax=max(ratio1,ratio2,ratio3,ratio4) - if (xmax.eq.ratio1) then - ifirst=1 - ratio1=0d0 - nnew(ifirst)=ncont(ifirst) - call trans_amfi(coeffs1,nprim(1),ncont(1),1,nolds(1),nolds(2), - * nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) - else if (xmax.eq.ratio2) then - ifirst=2 - ratio2=0d0 - nnew(ifirst)=ncont(ifirst) - call trans_amfi(coeffs2,nprim(2),ncont(2),2,nolds(1),nolds(2), - * nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) - else if (xmax.eq.ratio3) then - ifirst=3 - ratio3=0d0 - nnew(ifirst)=ncont(ifirst) - call trans_amfi(coeffs3,nprim(3),ncont(3),3,nolds(1),nolds(2), - * nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) - else if (xmax.eq.ratio4) then - ifirst=4 - ratio4=0d0 - nnew(ifirst)=ncont(ifirst) - call trans_amfi(coeffs4,nprim(4),ncont(4),4,nolds(1),nolds(2), - * nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) - else - ifirst=0 - write (6,*) 'Contract: you should not be here!' - call abend() - endif - nolds(ifirst)=nnew(ifirst) -************************************************************************ -cbs determine the second - xmax=max(ratio1,ratio2,ratio3,ratio4) - if (xmax.eq.ratio1) then - isec=1 - ratio1=0d0 - nnew(isec)=ncont(isec) - call trans_amfi(coeffs1,nprim(1),ncont(1),1,nolds(1),nolds(2), - * nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) - else if (xmax.eq.ratio2) then - isec=2 - ratio2=0d0 - nnew(isec)=ncont(isec) - call trans_amfi(coeffs2,nprim(2),ncont(2),2,nolds(1),nolds(2), - * nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) - else if (xmax.eq.ratio3) then - isec=3 - ratio3=0d0 - nnew(isec)=ncont(isec) - call trans_amfi(coeffs3,nprim(3),ncont(3),3,nolds(1),nolds(2), - * nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) - else if (xmax.eq.ratio4) then - isec=4 - ratio4=0d0 - nnew(isec)=ncont(isec) - call trans_amfi(coeffs4,nprim(4),ncont(4),4,nolds(1),nolds(2), - * nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) - else - isec=0 - write (6,*) 'Contract: you should not be here!' - call abend() - endif - nolds(isec)=nnew(isec) -************************************************************************ -cbs determine the third - xmax=max(ratio1,ratio2,ratio3,ratio4) - if (xmax.eq.ratio1) then - ithird=1 - ratio1=0d0 - nnew(ithird)=ncont(ithird) - call trans_amfi(coeffs1,nprim(1),ncont(1),1,nolds(1),nolds(2), - * nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) - else if (xmax.eq.ratio2) then - ithird=2 - ratio2=0d0 - nnew(ithird)=ncont(ithird) - call trans_amfi(coeffs2,nprim(2),ncont(2),2,nolds(1),nolds(2), - * nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) - else if (xmax.eq.ratio3) then - ithird=3 - ratio3=0d0 - nnew(ithird)=ncont(ithird) - call trans_amfi(coeffs3,nprim(3),ncont(3),3,nolds(1),nolds(2), - * nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) - else if (xmax.eq.ratio4) then - ithird=4 - ratio4=0d0 - nnew(ithird)=ncont(ithird) - call trans_amfi(coeffs4,nprim(4),ncont(4),4,nolds(1),nolds(2), - * nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) - else - ithird=0 - write (6,*) 'Contract: you should not be here!' - call abend() - endif - nolds(ithird)=nnew(ithird) -************************************************************************ -cbs determine the last - xmax=max(ratio1,ratio2,ratio3,ratio4) - if (xmax.eq.ratio1) then - ifourth=1 - ratio1=0d0 - nnew(ifourth)=ncont(ifourth) - call trans_amfi(coeffs1,nprim(1),ncont(1),1,nolds(1),nolds(2), - * nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) - else if (xmax.eq.ratio2) then - ifourth=2 - ratio2=0d0 - nnew(ifourth)=ncont(ifourth) - call trans_amfi(coeffs2,nprim(2),ncont(2),2,nolds(1),nolds(2), - * nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) - else if (xmax.eq.ratio3) then - ifourth=3 - ratio3=0d0 - nnew(ifourth)=ncont(ifourth) - call trans_amfi(coeffs3,nprim(3),ncont(3),3,nolds(1),nolds(2), - * nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) - else if (xmax.eq.ratio4) then - ifourth=4 - ratio4=0d0 - nnew(ifourth)=ncont(ifourth) - call trans_amfi(coeffs4,nprim(4),ncont(4),4,nolds(1),nolds(2), - * nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) - else - ifourth=0 - write (6,*) 'Contract: you should not be here!' - call abend() - endif -cbs contracted integrals are now on -cbs arr1(ncont1,ncont2,ncont3,ncont4) -* - return - end diff -Nru openmolcas-22.02/src/amfi_util/contract.F90 openmolcas-22.10/src/amfi_util/contract.F90 --- openmolcas-22.02/src/amfi_util/contract.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/contract.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,166 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine contract(coeffs1,coeffs2,coeffs3,coeffs4,ncont,nprim,arr1,arr2) +!coeffs1 : (nprim(1),ncont(1)) modified contraction coefficients +!coeffs2 : (nprim(2),ncont(2)) modified contraction coefficients +!coeffs3 : (nprim(3),ncont(3)) modified contraction coefficients +!coeffs4 : (nprim(4),ncont(4)) modified contraction coefficients +!ncont : i-th element is number of contracted functions i. index +!nprim : i-th element is number of primitive functions i. index +!arr1 : array of size (nprim(1)*nprim(2)*nprim(3)*nprim(4)) +!arr2 : array of size (nprim(1)*nprim(2)*nprim(3)*nprim(4)) +!bs arr1 contains at the beginning the uncontracted integrals + +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +real(kind=wp), intent(in) :: coeffs1(*), coeffs2(*), coeffs3(*), coeffs4(*) +integer(kind=iwp), intent(in) :: ncont(4), nprim(4) +real(kind=wp), intent(inout) :: arr1(*) +real(kind=wp), intent(_OUT_) :: arr2(*) +integer(kind=iwp) :: ifirst, ifourth, isec, ithird, nnew(4), nolds(4) +real(kind=wp) :: ratio1, ratio2, ratio3, ratio4, xmax + +!bs makes four index transformations in a row.... +!bs try to find out, which indices should be transformed first... + +ratio1 = real(nprim(1),kind=wp)/real(ncont(1),kind=wp) +ratio2 = real(nprim(2),kind=wp)/real(ncont(2),kind=wp) +ratio3 = real(nprim(3),kind=wp)/real(ncont(3),kind=wp) +ratio4 = real(nprim(4),kind=wp)/real(ncont(4),kind=wp) +nolds(:) = nprim(:) +nnew(:) = nprim(:) +!bs determine first, second,third and last index +!*********************************************************************** +!bs determine the first +xmax = max(ratio1,ratio2,ratio3,ratio4) +if (xmax == ratio1) then + ifirst = 1 + ratio1 = Zero + nnew(ifirst) = ncont(ifirst) + call trans_amfi(coeffs1,nprim(1),ncont(1),1,nolds(1),nolds(2),nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) +else if (xmax == ratio2) then + ifirst = 2 + ratio2 = Zero + nnew(ifirst) = ncont(ifirst) + call trans_amfi(coeffs2,nprim(2),ncont(2),2,nolds(1),nolds(2),nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) +else if (xmax == ratio3) then + ifirst = 3 + ratio3 = Zero + nnew(ifirst) = ncont(ifirst) + call trans_amfi(coeffs3,nprim(3),ncont(3),3,nolds(1),nolds(2),nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) +else if (xmax == ratio4) then + ifirst = 4 + ratio4 = Zero + nnew(ifirst) = ncont(ifirst) + call trans_amfi(coeffs4,nprim(4),ncont(4),4,nolds(1),nolds(2),nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) +else + ifirst = 0 + write(u6,*) 'Contract: you should not be here!' + call abend() +end if +nolds(ifirst) = nnew(ifirst) +!*********************************************************************** +!bs determine the second +xmax = max(ratio1,ratio2,ratio3,ratio4) +if (xmax == ratio1) then + isec = 1 + ratio1 = Zero + nnew(isec) = ncont(isec) + call trans_amfi(coeffs1,nprim(1),ncont(1),1,nolds(1),nolds(2),nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) +else if (xmax == ratio2) then + isec = 2 + ratio2 = Zero + nnew(isec) = ncont(isec) + call trans_amfi(coeffs2,nprim(2),ncont(2),2,nolds(1),nolds(2),nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) +else if (xmax == ratio3) then + isec = 3 + ratio3 = Zero + nnew(isec) = ncont(isec) + call trans_amfi(coeffs3,nprim(3),ncont(3),3,nolds(1),nolds(2),nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) +else if (xmax == ratio4) then + isec = 4 + ratio4 = Zero + nnew(isec) = ncont(isec) + call trans_amfi(coeffs4,nprim(4),ncont(4),4,nolds(1),nolds(2),nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) +else + isec = 0 + write(u6,*) 'Contract: you should not be here!' + call abend() +end if +nolds(isec) = nnew(isec) +!*********************************************************************** +!bs determine the third +xmax = max(ratio1,ratio2,ratio3,ratio4) +if (xmax == ratio1) then + ithird = 1 + ratio1 = Zero + nnew(ithird) = ncont(ithird) + call trans_amfi(coeffs1,nprim(1),ncont(1),1,nolds(1),nolds(2),nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) +else if (xmax == ratio2) then + ithird = 2 + ratio2 = Zero + nnew(ithird) = ncont(ithird) + call trans_amfi(coeffs2,nprim(2),ncont(2),2,nolds(1),nolds(2),nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) +else if (xmax == ratio3) then + ithird = 3 + ratio3 = Zero + nnew(ithird) = ncont(ithird) + call trans_amfi(coeffs3,nprim(3),ncont(3),3,nolds(1),nolds(2),nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) +else if (xmax == ratio4) then + ithird = 4 + ratio4 = Zero + nnew(ithird) = ncont(ithird) + call trans_amfi(coeffs4,nprim(4),ncont(4),4,nolds(1),nolds(2),nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) +else + ithird = 0 + write(u6,*) 'Contract: you should not be here!' + call abend() +end if +nolds(ithird) = nnew(ithird) +!*********************************************************************** +!bs determine the last +xmax = max(ratio1,ratio2,ratio3,ratio4) +if (xmax == ratio1) then + ifourth = 1 + ratio1 = Zero + nnew(ifourth) = ncont(ifourth) + call trans_amfi(coeffs1,nprim(1),ncont(1),1,nolds(1),nolds(2),nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) +else if (xmax == ratio2) then + ifourth = 2 + ratio2 = Zero + nnew(ifourth) = ncont(ifourth) + call trans_amfi(coeffs2,nprim(2),ncont(2),2,nolds(1),nolds(2),nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) +else if (xmax == ratio3) then + ifourth = 3 + ratio3 = Zero + nnew(ifourth) = ncont(ifourth) + call trans_amfi(coeffs3,nprim(3),ncont(3),3,nolds(1),nolds(2),nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) +else if (xmax == ratio4) then + ifourth = 4 + ratio4 = Zero + nnew(ifourth) = ncont(ifourth) + call trans_amfi(coeffs4,nprim(4),ncont(4),4,nolds(1),nolds(2),nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) +else + ifourth = 0 + write(u6,*) 'Contract: you should not be here!' + call abend() +end if +!bs contracted integrals are now on +!bs arr1(ncont1,ncont2,ncont3,ncont4) + +return + +end subroutine contract diff -Nru openmolcas-22.02/src/amfi_util/couple3J.f openmolcas-22.10/src/amfi_util/couple3J.f --- openmolcas-22.02/src/amfi_util/couple3J.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/couple3J.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,47 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - real*8 function couple3J( - *l1, ! integer l1 - *l2, ! integer l2 - *l3, ! integer l3 - *m1, ! integer m1 - *m2, ! integer m2 - *m3) ! integer m3 -cbs this routine calculates the coupling of three angular momenta to zero -cbs -cbs -cbs Int dOmega i^(l1+l2+l3) Y^l1_m1 (Omega) Y^l2_m2 (Omega) Y^l3_m3 (Omega) = -cbs sqrt( (2l1+1)(2l2+1)(2l2+3)/ 4Pi) * 3J(l1,l2,l3,0,0,0) * -cbs 3J(l1,l2,l3,m1,m2,m3) -cbs -cbs - implicit real*8(a-h,o-z) -#include "real.fh" - real*8 inv4pi -cbs (4*PI)**-1 - inv4pi=0.25d0/pi -cbs initialize couple3J-coefficient - couple3J=0d0 -cbs quick check - if (m1+m2+m3.ne.0) return -cbs double all values for regge3j - l1d=l1+l1 - l2d=l2+l2 - l3d=l3+l3 - m1d=m1+m1 - m2d=m2+m2 - m3d=m3+m3 - fac1=sqrt(DBLE(l1d+1)*DBLE(l2d+1)*DBLE(l3d+1)*inv4pi) - fac2=regge3j(l1d,l2d,l3d,0,0,0) - fac3=regge3j(l1d,l2d,l3d,m1d,m2d,m3d) - couple3J=fac1*fac2*fac3 - return - end diff -Nru openmolcas-22.02/src/amfi_util/couple3j.F90 openmolcas-22.10/src/amfi_util/couple3j.F90 --- openmolcas-22.02/src/amfi_util/couple3j.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/couple3j.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,48 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +function couple3J(l1,l2,l3,m1,m2,m3) +!bs this routine calculates the coupling of three angular momenta to zero +!bs +!bs Int dOmega i^(l1+l2+l3) Y^l1_m1 (Omega) Y^l2_m2 (Omega) Y^l3_m3 (Omega) = +!bs sqrt( (2l1+1)(2l2+1)(2l2+3)/ 4Pi) * 3J(l1,l2,l3,0,0,0) * +!bs 3J(l1,l2,l3,m1,m2,m3) + +use Constants, only: Zero, Quart, Pi +use Definitions, only: wp, iwp + +implicit none +real(kind=wp) :: couple3J +integer(kind=iwp), intent(in) :: l1, l2, l3, m1, m2, m3 +integer(kind=iwp) :: l1d, l2d, l3d, m1d, m2d, m3d +real(kind=wp) :: fac1, fac2, fac3 +real(kind=wp), parameter :: inv4pi = Quart/Pi +real(kind=wp), external :: regge3j + +!bs initialize couple3J-coefficient +couple3J = Zero +!bs quick check +if (m1+m2+m3 /= 0) return +!bs double all values for regge3j +l1d = l1+l1 +l2d = l2+l2 +l3d = l3+l3 +m1d = m1+m1 +m2d = m2+m2 +m3d = m3+m3 +fac1 = sqrt(real(l1d+1,kind=wp)*real(l2d+1,kind=wp)*real(l3d+1,kind=wp)*inv4pi) +fac2 = regge3j(l1d,l2d,l3d,0,0,0) +fac3 = regge3j(l1d,l2d,l3d,m1d,m2d,m3d) +couple3J = fac1*fac2*fac3 + +return + +end function couple3J diff -Nru openmolcas-22.02/src/amfi_util/daxpint.f openmolcas-22.10/src/amfi_util/daxpint.f --- openmolcas-22.02/src/amfi_util/daxpint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/daxpint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,30 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine daxpint(from,to,fact,ndim1,ndim2,ndim3,ndim4) - implicit real*8 (a-h,o-z) -cbs subroutine similar to daxpy with interchange of two indices -cbs change from physicists notation to chemists notaion -cbs to(i,j,k,l)=to(i,j,k,l)+fact*from(i,k,j,l) - dimension from(ndim1,ndim2,ndim3,ndim4), - *to(ndim1,ndim3,ndim2,ndim4) - if (fact.eq.0d0) return - do irun4=1,ndim4 - do irun3=1,ndim3 - do irun2=1,ndim2 - do irun1=1,ndim1 - to(irun1,irun3,irun2,irun4)=to(irun1,irun3,irun2,irun4)+ - *fact*from(irun1,irun2,irun3,irun4) - enddo - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/daxpint.F90 openmolcas-22.10/src/amfi_util/daxpint.F90 --- openmolcas-22.02/src/amfi_util/daxpint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/daxpint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,36 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine daxpint(from,to,fact,ndim1,ndim2,ndim3,ndim4) +!bs subroutine similar to daxpy with interchange of two indices +!bs change from physicists notation to chemists notaion +!bs to(i,j,k,l)=to(i,j,k,l)+fact*from(i,k,j,l) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: ndim1, ndim2, ndim3, ndim4 +real(kind=wp), intent(in) :: from(ndim1,ndim2,ndim3,ndim4), fact +real(kind=wp), intent(inout) :: to(ndim1,ndim3,ndim2,ndim4) +integer(kind=iwp) :: irun2, irun3 + +if (fact /= Zero) then + do irun3=1,ndim3 + do irun2=1,ndim2 + to(:,irun3,irun2,:) = to(:,irun3,irun2,:)+fact*from(:,irun2,irun3,:) + end do + end do +end if + +return + +end subroutine daxpint diff -Nru openmolcas-22.02/src/amfi_util/dofuc.fh openmolcas-22.10/src/amfi_util/dofuc.fh --- openmolcas-22.02/src/amfi_util/dofuc.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/dofuc.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,14 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - REAL*8 df(0:ndfmx),dffrac(0:ndfmx,0:ndfmx) - common /dofuc/ df,dffrac -cbs some double facultatives and their fractions are given on this block -cbs the whole arrays are initialized by inidf diff -Nru openmolcas-22.02/src/amfi_util/drv_amfi.f openmolcas-22.10/src/amfi_util/drv_amfi.f --- openmolcas-22.02/src/amfi_util/drv_amfi.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/drv_amfi.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,323 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Drv_AMFI(Label,ip,lOper,nComp,rHrmt,iChO, iAtmNr2, - & Charge2) - use iSD_data - use Basis_Info - use DKH_Info, only: DKroll - use Symmetry_Info, only: nIrrep - Implicit Real*8 (a-h,o-z) - External Rsv_Tsk -#include "Molcas.fh" -#include "angtp.fh" -#include "real.fh" -#include "stdalloc.fh" -#include "nsd.fh" -#include "setup.fh" -#include "para.fh" - Integer, Allocatable :: iDel(:) - Real*8, Allocatable :: SOInt(:) - Real*8 Coor(3) - Logical EQ, IfTest, Rsv_Tsk - Character Label*8 - Integer ip(nComp), lOper(nComp), iChO(nComp) - Integer iAtmNr2(mxdbsc) - Real*8 Charge2(mxdbsc) - Data IfTest/.False./ -* -!#define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - IfTest=.True. - Write (6,*) ' In OneEl: Label', Label - Write (6,*) ' In OneEl: nComp' - Write (6,'(1X,8I5)') nComp - Write (6,*) ' In OneEl: lOper' - Write (6,'(1X,8I5)') lOper - Write (6,*) ' In OneEl: n2Tri' - Do iComp = 1, nComp - ip(iComp) = n2Tri(lOper(iComp)) - End Do - Write (6,'(1X,8I5)') (ip(iComp),iComp=1,nComp) -#endif -* - Eta_Nuc=Zero -* -* Allocate memory for symmetry adapted one electron integrals. -* Will just store the unique elements, i.e. low triangular blocks -* and lower triangular elements in the diagonal blocks. -* - ip(:)=-1 - LenTot=0 - Do iComp = 1, nComp - ip(iComp)=1+LenTot - LenInt=n2Tri(lOper(iComp)) - LenTot=LenTot+LenInt+4 - End Do - Call mma_allocate(SOInt,LenTot,label='SOInt') - SOInt(:)=Zero -* -*---- Generate list of shell information -* - Call Nr_Shells(nSkal) -* -*---- Check that there are not several instances of the same center. -* - nCenter=0 - Do iSkal=1,nSkal - nCenter=Max(nCenter,iSD(10,iSkal)) - If (iSD(1,iSkal).gt.Lmax) Then - Write (6,*) ' Shells higher than ' - & //Angtp(Lmax)//'-functions not allowed in AMFI.' - Call Quit_OnUserError() - End If - If (iSD(1,iSkal).ge.2.and.iAnd(iSD(9,iSkal),1).ne.1) Then - Write (6,*) ' Only real spherical harmonics allowed' - Write (6,*) ' for AMFI.' - Call Quit_OnUserError() - End If - End Do - Coor(:)=Zero - Do iCenter=1,nCenter -* -* Identify which dbsc this center belongs. -* - iCnttp=0 - Do iSkal=1,nSkal - If (iSD(10,iSkal).eq.iCenter) Then - iCnttp=iSD(13,iSkal) - iCnt =iSD(14,iSkal) - Coor(1:3)=dbsc(iCnttp)%Coor(1:3,iCnt) - End If - End Do -* -* If iCenter is not a center in the current list of shells that -* is to be processed then test the next iCenter. -* - If (iCnttp.eq.0) Cycle -* - Do iSkal=1,nSkal - If (iSD(13,iSkal).ne.iCnttp .and. - & iSD(10,iSkal).ne.iCenter) Then - jCnttp=iSD(13,iSkal) - jCnt =iSD(14,iSkal) - If ( EQ(Coor, dbsc(jCnttp)%Coor(1,jCnt)) ) Then - Write (6,*) 'Multiple instances of the same center!' - Write (6,*) 'This is not allowed with AMFI.' - Call Quit_OnUserError() - End If - End If - End Do - End Do - If (MolWgh.ne.0 .and. MolWgh.ne.2) Then - Write (6,*) ' AMFI integrals not implemented for symmetry' - & //' adaptation a la MOLECULE' - Call Quit_OnUserError() - End If -* -*---- Loop over unique center. Observe that multiple shells of the same -* angular momentum is not allowed. -* - Lu_AMFI=21 - LUPROP=22 - call molcas_open(Lu_AMFI,'AMFI_INP') - call molcas_binaryopen_vanilla(LUPROP,'AMFI_INT') - nCenter_node=0 -* - Call Init_Tsk(id_Tsk,nCenter) - 10 Continue - If (.Not.Rsv_Tsk(id_Tsk,iCenter)) Go To 11 -* Do iCenter = 1, nCenter - nCenter_node=nCenter_node+1 -* - Write (Lu_AMFI,'(A)') ' &AMFI &END' - If (IfTest) Write (6,'(A)') ' &AMFI &END' -* -*------- Find atom type -* - mdci=0 - Do iCnttp = 1, nCnttp - Do iCnt = 1, dbsc(iCnttp)%nCntr - mdci=mdci+1 - If (mdci.eq.iCenter) Then - If ((.Not.DKroll).and.(.Not.dbsc(iCnttp)%SODK)) - & Write (Lu_AMFI,'(A)') 'Breit-Pauli' - If (IfTest) Then - If (.Not.DKroll.and..Not.dbsc(iCnttp)%SODK) - & Write (6,'(A)') 'Breit-Pauli' - End If - If (iAtmNr2(iCnttp).ge.1) Then - charge_x=DBLE(iAtmNr2(iCnttp)) - Else If (iAtmNr2(iCnttp).le.0 .and. - & Charge2(iCnttp).eq.Zero) Then - charge_x=0.0D0 - Else - Write (6,*) 'Drv_AMFI: Invalid basis!' - Write (6,*) 'iAtmNr=',iAtmNr2(iCnttp) - Write (6,*) 'Charge2=',Charge2(iCnttp) - Call Abend() - End If - If (Nuclear_Model.eq.Gaussian_Type) Then - Eta_Nuc=dbsc(iCnttp)%ExpNuc - End If - Go To 99 - End If - End Do - End Do - 99 Continue -* - If (Nuclear_Model.eq.Gaussian_Type) Then - Write (Lu_AMFI,'(A)') 'Finite' - If (IfTest) Write (6,'(A)') 'Finite' - Write (Lu_AMFI,*) Eta_Nuc - If (IfTest) Write (6,*) Eta_Nuc - End If -* -*------- Generate input for each atom -* - l_max=-1 - Do iSkal = 1, nSkal - If (iSD(10,iSkal).eq.iCenter) - & l_Max=Max(l_Max,iSD(1,iSkal)) - End Do - If (l_max.gt.LMax) Then - Write (6,*) 'AMFI integrals only implemented up to ' - & //Angtp(Lmax)//'-functions.' - Call Quit_OnUserError() - End If -* -* Check if there are any core orbitals to be deleted -* - nCore=0 - Do l = 0, l_max - Do iSkal = 1, nSkal - If (iSD(10,iSkal).eq.iCenter .and. - & iSD( 1,iSkal).eq.l) Then -* - iCnttp = iSD(13,iSkal) - If (dbsc(iCnttp)%nSOC.ne.0) Then - iShll = dbsc(iCnttp)%iSOC+l -* jShll = dbsc(iCnttp)%iPrj+l -* nCore=nCore+Shells(jShll)%nBasis - nCore=nCore+dbsc(iCnttp)%kDel(l) - End If - End If - End Do - End Do - If (IfTest) Write (6,*) 'nCore: ', nCore -* -* Set up delete array -* - If (nCore.ne.0) Then - lDel=l_Max+1 - Call mma_allocate(iDel,lDel,label='iDel') - Do l = 0, l_max - Do iSkal = 1, nSkal - If (iSD(10,iSkal).eq.iCenter .and. - & iSD( 1,iSkal).eq.l) Then -* - iCnttp = iSD(13,iSkal) - If (dbsc(iCnttp)%nSOC.ne.0) Then - iShll = dbsc(iCnttp)%iSOC+l -* jShll = dbsc(iCnttp)%iPrj+l -* iDel(ip_iDel+l)=Shells(jShll)%nBasis - iDel(1+l)=dbsc(iCnttp)%kDel(l) - End If - End If - End Do - End Do - Write (Lu_AMFI,'(A)') 'AIMP' - Write (Lu_AMFI,*) lDel-1,(iDel(i),i=1,lDel) - If (IfTest) Write (6,'(A)') 'AIMP' - If (IfTest) Write (6,*) lDel, (iDel(i),i=1,lDel) - Call mma_deallocate(iDel) - End If -* - Write (Lu_AMFI,'(A)') ' ' - Write (Lu_AMFI,'(3X,F5.1,I4)') charge_x, l_max - If (IfTest) Write (6,*) charge_x, l_max -* - Do l = 0, l_max - Do iSkal = 1, nSkal - If (iSD(10,iSkal).eq.iCenter .and. - & iSD( 1,iSkal).eq.l) Then -* - iCnttp = iSD(13,iSkal) - If (dbsc(iCnttp)%nSOC.eq.0) Then -* -* Use valence basis -* - iShll = dbsc(iCnttp)%iVal+l - iCase = 2 -* - Else -* -* Use special valence basis in case of a ECP where the -* normal valence might not be adequate. -* - iShll = dbsc(iCnttp)%iSOC+l - iCase = 1 -* - End If - nBas_x = Shells(iShll)%nBasis - nExp_x = Shells(iShll)%nExp -* - If (IfTest) Write (6,*) 'iShll=',iShll - Write (Lu_AMFI,*) nExp_x, nBas_x - If (IfTest) Write (6,*) nExp_x, nBas_x - Write (Lu_AMFI,*) (Shells(iShll)%Exp(iExp_x), - & iExp_x=1,nExp_x) - If (IfTest) Write (6,*) (Shells(iShll)%Exp(iExp_x), - & iExp_x=1,nExp_x) - Do iExp_x = 1, nExp_x - Write (Lu_AMFI,*) - & (Shells(iShll)%Cff_c(iExp_x,iCff_x,iCase), - & iCff_x=1,nBas_x) - If (IfTest) Write (6,*) - & (Shells(iShll)%Cff_c(iExp_x,iCff_x,iCase), - & iCff_x=1,nBas_x) - End Do -* - End If - End Do - End Do - Write (Lu_AMFI,'(A)') 'End of Input' - If (IfTest) Write (6,'(A)') 'End of Input' -* -* -*------- Now call AMFI -* - Rewind(Lu_AMFI) - Call AMFI(Lu_AMFI,LUPROP,iCenter) -* - Rewind(Lu_AMFI) -* - Go To 10 - 11 Continue - Call Free_Tsk(id_Tsk) -* End Do - Close(Lu_AMFI) -* -*---- Now symmetry adopt. -* - Rewind(LUPROP) - Call SymTrafo(LUPROP,ip,lOper,nComp,nBas,nIrrep,Label,MolWgh, - & SOInt,LenTot) -* - Close(LUPROP) -* - Call mma_deallocate(SOInt) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real(rHrmt) - Call Unused_integer_array(iChO) - End If - End diff -Nru openmolcas-22.02/src/amfi_util/drv_amfi.F90 openmolcas-22.10/src/amfi_util/drv_amfi.F90 --- openmolcas-22.02/src/amfi_util/drv_amfi.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/drv_amfi.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,282 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Drv_AMFI(Label,lOper,nComp,iAtmNr2,Charge2) + +use AMFI_global, only: Lmax +use iSD_data, only: iSD +use Basis_Info, only: dbsc, Gaussian_Type, MolWgh, nBas, nCnttp, Nuclear_Model, Shells +use DKH_Info, only: DKroll +use Symmetry_Info, only: nIrrep +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +#include "Molcas.fh" +character(len=8), intent(in) :: Label +integer(kind=iwp), intent(in) :: nComp, lOper(nComp), iAtmNr2(mxdbsc) +real(kind=wp), intent(in) :: Charge2(mxdbsc) +#include "angtp.fh" +integer(kind=iwp) :: i, iCase, iCenter, iCff_x, iCnt, iCnttp, id_Tsk, iExp_x, iShll, iSkal, jCnt, jCnttp, l, l_max, lDel, & + Lu_AMFI, LUPROP, mdci, nBas_x, nCenter, nCenter_node, nCore, nExp_x, nSkal +real(kind=wp) :: charge_x, Coor(3), Eta_Nuc +logical(kind=iwp) :: EQ +integer(kind=iwp), allocatable :: iDel(:) +!#define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +#define _TEST_ .true. +#else +#define _TEST_ .false. +#endif +logical(kind=iwp), parameter :: IfTest = _TEST_ +logical(kind=iwp), external :: Rsv_Tsk + +#ifdef _DEBUGPRINT_ +write(u6,*) ' In OneEl: Label',Label +write(u6,*) ' In OneEl: nComp' +write(u6,'(1X,8I5)') nComp +write(u6,*) ' In OneEl: lOper' +write(u6,'(1X,8I5)') lOper +#endif + +Eta_Nuc = Zero + +! Generate list of shell information + +call Nr_Shells(nSkal) + +! Check that there are not several instances of the same center. + +nCenter = 0 +do iSkal=1,nSkal + nCenter = max(nCenter,iSD(10,iSkal)) + if (iSD(1,iSkal) > Lmax) then + write(u6,*) ' Shells higher than '//Angtp(Lmax)//'-functions not allowed in AMFI.' + call Quit_OnUserError() + end if + if ((iSD(1,iSkal) >= 2) .and. (.not. btest(iSD(9,iSkal),0))) then + write(u6,*) ' Only real spherical harmonics allowed' + write(u6,*) ' for AMFI.' + call Quit_OnUserError() + end if +end do +Coor(:) = Zero +do iCenter=1,nCenter + + ! Identify which dbsc this center belongs. + + iCnttp = 0 + do iSkal=1,nSkal + if (iSD(10,iSkal) == iCenter) then + iCnttp = iSD(13,iSkal) + iCnt = iSD(14,iSkal) + Coor(1:3) = dbsc(iCnttp)%Coor(1:3,iCnt) + end if + end do + + ! If iCenter is not a center in the current list of shells that + ! is to be processed then test the next iCenter. + + if (iCnttp == 0) cycle + + do iSkal=1,nSkal + if ((iSD(13,iSkal) /= iCnttp) .and. (iSD(10,iSkal) /= iCenter)) then + jCnttp = iSD(13,iSkal) + jCnt = iSD(14,iSkal) + if (EQ(Coor,dbsc(jCnttp)%Coor(1,jCnt))) then + write(u6,*) 'Multiple instances of the same center!' + write(u6,*) 'This is not allowed with AMFI.' + call Quit_OnUserError() + end if + end if + end do +end do +if ((MolWgh /= 0) .and. (MolWgh /= 2)) then + write(u6,*) ' AMFI integrals not implemented for symmetry adaptation a la MOLECULE' + call Quit_OnUserError() +end if + +! Loop over unique center. Observe that multiple shells of the same +! angular momentum is not allowed. + +Lu_AMFI = 21 +LUPROP = 22 +call molcas_open(Lu_AMFI,'AMFI_INP') +call molcas_binaryopen_vanilla(LUPROP,'AMFI_INT') +nCenter_node = 0 + +call Init_Tsk(id_Tsk,nCenter) +do + if (.not. Rsv_Tsk(id_Tsk,iCenter)) exit + !do iCenter=1,nCenter + nCenter_node = nCenter_node+1 + + write(Lu_AMFI,'(A)') ' &AMFI' + if (IfTest) write(u6,'(A)') ' &AMFI' + + ! Find atom type + + mdci = 0 + outer: do iCnttp=1,nCnttp + do iCnt=1,dbsc(iCnttp)%nCntr + mdci = mdci+1 + if (mdci == iCenter) then + if ((.not. DKroll) .and. (.not. dbsc(iCnttp)%SODK)) write(Lu_AMFI,'(A)') 'Breit-Pauli' + if (IfTest) then + if ((.not. DKroll) .and. (.not. dbsc(iCnttp)%SODK)) write(u6,'(A)') 'Breit-Pauli' + end if + if (iAtmNr2(iCnttp) >= 1) then + charge_x = real(iAtmNr2(iCnttp),kind=wp) + else if ((iAtmNr2(iCnttp) <= 0) .and. (Charge2(iCnttp) == Zero)) then + charge_x = Zero + else + write(u6,*) 'Drv_AMFI: Invalid basis!' + write(u6,*) 'iAtmNr=',iAtmNr2(iCnttp) + write(u6,*) 'Charge2=',Charge2(iCnttp) + call Abend() + end if + if (Nuclear_Model == Gaussian_Type) Eta_Nuc = dbsc(iCnttp)%ExpNuc + exit outer + end if + end do + end do outer + + if (Nuclear_Model == Gaussian_Type) then + write(Lu_AMFI,'(A)') 'Finite' + if (IfTest) write(u6,'(A)') 'Finite' + write(Lu_AMFI,*) Eta_Nuc + if (IfTest) write(u6,*) Eta_Nuc + end if + + ! Generate input for each atom + + l_max = -1 + do iSkal=1,nSkal + if (iSD(10,iSkal) == iCenter) l_Max = max(l_Max,iSD(1,iSkal)) + end do + if (l_max > LMax) then + write(u6,*) 'AMFI integrals only implemented up to '//Angtp(Lmax)//'-functions.' + call Quit_OnUserError() + end if + + ! Check if there are any core orbitals to be deleted + + nCore = 0 + do l=0,l_max + do iSkal=1,nSkal + if ((iSD(10,iSkal) == iCenter) .and. (iSD(1,iSkal) == l)) then + + iCnttp = iSD(13,iSkal) + if (dbsc(iCnttp)%nSOC /= 0) then + iShll = dbsc(iCnttp)%iSOC+l + !jShll = dbsc(iCnttp)%iPrj+l + !nCore = nCore+Shells(jShll)%nBasis + nCore = nCore+dbsc(iCnttp)%kDel(l) + end if + end if + end do + end do + if (IfTest) write(u6,*) 'nCore: ',nCore + + ! Set up delete array + + if (nCore /= 0) then + lDel = l_Max+1 + call mma_allocate(iDel,lDel,label='iDel') + do l=0,l_max + do iSkal=1,nSkal + if ((iSD(10,iSkal) == iCenter) .and. (iSD(1,iSkal) == l)) then + + iCnttp = iSD(13,iSkal) + if (dbsc(iCnttp)%nSOC /= 0) then + iShll = dbsc(iCnttp)%iSOC+l + !jShll = dbsc(iCnttp)%iPrj+l + !iDel(ip_iDel+l) = Shells(jShll)%nBasis + iDel(1+l) = dbsc(iCnttp)%kDel(l) + end if + end if + end do + end do + write(Lu_AMFI,'(A)') 'AIMP' + write(Lu_AMFI,*) lDel-1,(iDel(i),i=1,lDel) + if (IfTest) write(u6,'(A)') 'AIMP' + if (IfTest) write(u6,*) lDel,(iDel(i),i=1,lDel) + call mma_deallocate(iDel) + end if + + write(Lu_AMFI,'(A)') ' ' + write(Lu_AMFI,'(3X,F5.1,I4)') charge_x,l_max + if (IfTest) write(u6,*) charge_x,l_max + + do l=0,l_max + do iSkal=1,nSkal + if ((iSD(10,iSkal) == iCenter) .and. (iSD(1,iSkal) == l)) then + + iCnttp = iSD(13,iSkal) + if (dbsc(iCnttp)%nSOC == 0) then + + ! Use valence basis + + iShll = dbsc(iCnttp)%iVal+l + iCase = 2 + + else + + ! Use special valence basis in case of a ECP where the + ! normal valence might not be adequate. + + iShll = dbsc(iCnttp)%iSOC+l + iCase = 1 + + end if + nBas_x = Shells(iShll)%nBasis + nExp_x = Shells(iShll)%nExp + + if (IfTest) write(u6,*) 'iShll=',iShll + write(Lu_AMFI,*) nExp_x,nBas_x + if (IfTest) write(u6,*) nExp_x,nBas_x + write(Lu_AMFI,*) (Shells(iShll)%Exp(iExp_x),iExp_x=1,nExp_x) + if (IfTest) write(u6,*) (Shells(iShll)%Exp(iExp_x),iExp_x=1,nExp_x) + do iExp_x=1,nExp_x + write(Lu_AMFI,*) (Shells(iShll)%Cff_c(iExp_x,iCff_x,iCase),iCff_x=1,nBas_x) + if (IfTest) write(u6,*) (Shells(iShll)%Cff_c(iExp_x,iCff_x,iCase),iCff_x=1,nBas_x) + end do + + end if + end do + end do + write(Lu_AMFI,'(A)') 'End of Input' + if (IfTest) write(u6,'(A)') 'End of Input' + + ! Now call AMFI + + rewind(Lu_AMFI) + call AMFI(Lu_AMFI,LUPROP,iCenter) + + rewind(Lu_AMFI) + +end do +call Free_Tsk(id_Tsk) +!end do +close(Lu_AMFI) + +! Now symmetry adapt. + +rewind(LUPROP) + +call SymTrafo(LUPROP,lOper,nComp,nBas,nIrrep,Label,MolWgh) + +close(LUPROP) + +return + +end subroutine Drv_AMFI diff -Nru openmolcas-22.02/src/amfi_util/finite.F90 openmolcas-22.10/src/amfi_util/finite.F90 --- openmolcas-22.02/src/amfi_util/finite.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/finite.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,33 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1996,1997, Bernd Schimmelpfennig * +!*********************************************************************** + +subroutine finite() +!bs subroutine to set up parameters for finite nucleus. The +!bs s-functions are replaced by just one exponent which models the nucleus. + +use AMFI_global, only: charge, Exp_finite, exponents, Lmax_occ, ncontrac, ncontrac_keep, nprimit, noccorb, occup +use Constants, only: Half + +implicit none + +noccorb(0) = 1 +noccorb(1:lmax_occ) = 0 +occup(1,0) = -charge +ncontrac_keep = ncontrac(0) +nprimit(0) = 1 +ncontrac(0) = 1 +exponents(1,0) = Half*Exp_finite + +return + +end subroutine finite diff -Nru openmolcas-22.02/src/amfi_util/gen1overR3.f openmolcas-22.10/src/amfi_util/gen1overR3.f --- openmolcas-22.02/src/amfi_util/gen1overR3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/gen1overR3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine gen1overR3(Lhigh,oneoverR3) - implicit real*8 (a-h,o-z) -cbs generates the radial integrals for the one electron spin orbit integrals -cbs taken the 1/r**3 formula from the documentation and included additional -cbs factors for normalization -#include "para.fh" -#include "param.fh" -#include "dofuc.fh" -#include "real.fh" - dimension oneoverR3((MxprimL*MxprimL+MxprimL)/2,Lmax) - do L=1,Lhigh - icount=0 - do iprim2=1,nprimit(L) - alpha2=exponents(iprim2,L) - do iprim1=1,iprim2 - alpha1=exponents(iprim1,L) - icount=icount+1 - oneoverR3(icount,L)=sqrt(2d0/pi)* - *(df(L+L-2)*DBLE(2**(L+3))* - *(alpha1*alpha2)**(0.25d0* - *DBLE(L+L+3)))/((alpha1+alpha2)**L*df(L+L+1)) - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/gen1overr3.F90 openmolcas-22.10/src/amfi_util/gen1overr3.F90 --- openmolcas-22.02/src/amfi_util/gen1overr3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/gen1overr3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,42 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine gen1overR3(Lhigh,oneoverR3) +!bs generates the radial integrals for the one electron spin orbit integrals +!bs taken the 1/r**3 formula from the documentation and included additional +!bs factors for normalization + +use AMFI_global, only: df, exponents, MxprimL, nprimit, Lmax +use Constants, only: Two, Quart, Pi +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: Lhigh +real(kind=wp), intent(out) :: oneoverR3(MxprimL*(MxprimL+1)/2,Lmax) +integer(kind=iwp) :: icount, iprim1, iprim2, L +real(kind=wp) :: alpha1, alpha2 + +do L=1,Lhigh + icount = 0 + do iprim2=1,nprimit(L) + alpha2 = exponents(iprim2,L) + do iprim1=1,iprim2 + alpha1 = exponents(iprim1,L) + icount = icount+1 + oneoverR3(icount,L) = sqrt(Two/Pi)*(df(L+L-2)*real(2**(L+3),kind=wp)*(alpha1*alpha2)**(Quart*real(L+L+3,kind=wp)))/ & + ((alpha1+alpha2)**L*df(L+L+1)) + end do + end do +end do + +return + +end subroutine gen1overR3 diff -Nru openmolcas-22.02/src/amfi_util/gencoulDIM.f openmolcas-22.10/src/amfi_util/gencoulDIM.f --- openmolcas-22.02/src/amfi_util/gencoulDIM.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/gencoulDIM.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,123 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine gencoulDIM(l1,l2,l3,l4,makemean, - *bonn,breit,sameorb,icont4) - implicit real*8(a-h,o-z) -cbs SUBROUTINE to calculate the dimemsion of the radial integral -cbs arrays. BASICALLY GENCOUL WITHOUT EXPLICIT INTEGRAL CALCULATION -cbs integrals for the four angular momenta l1-l4 -#include "para.fh" -#include "param.fh" - logical makemean,bonn,breit,sameorb -cbs first of all, this routine determines, for which L -cbs values the radial integrals have to be solved -cbs initialize the number of blocks for the different -cbs l-combinations -cbs no (ss|ss) contributions - if (l1.eq.0.and.l2.eq.0.and.l3.eq.0.and.l4.eq.0) return -c ! no integrals for - if (makemean) then - nblock=1 ! sp sp are the first, so the first block - Lstarter(1)=1 - else - Call SysAbendMsg('gencoulDIM', - & 'only mean-field with this version',' ' ) - endif -cbs keep track of L-values for later purposes - Lvalues(1)=l1 - Lvalues(2)=l2 - Lvalues(3)=l3 - Lvalues(4)=l4 -cbs now nanz is given the new value - nanz=ncontrac(l1)*ncontrac(l2)*ncontrac(l3)*ncontrac(l4) -c -cbs prepare the powers needed for cfunctx -c -c -c There are seven different CASES of integrals following -c ( A -- C) -c -c The structure is the same for all cases, therefore comments can be found only on case A -c -c -c -cbs ########################################################################################################### -cbs the (+2) cases CASE A -cbs ########################################################################################################## - incl1=1 ! Those increments define the case - incl3=1 -cbs determine the possible L-values for the integrals by checking for triangular equation -c - call getlimit(l1+incl1,l2,l3+incl3,l4,Lanf,Lend) -c -cbs returns first and last L-values (Lanf,Lend), for which -cbs radial integrals have to be calculated - if(Lend-Lanf.ge.0) then -cbs if there are blocks - Lblocks(1)=(Lend-Lanf)/2+1 ! L increases in steps of 2, -cbs due to parity conservation - Lfirst(1)=Lanf - Llast(1)=Lend - else - Lblocks(1)=0 - endif -cbs ########################################################################################################## -cbs the (0) cases CASE B -cbs ########################################################################################################## - incl1=0 - incl3=0 - call getlimit(l1+incl1,l2,l3+incl3,l4,Lanf,Lend) - if(Lend-Lanf.ge.0) then - Lblocks(2)=(Lend-Lanf)/2+1 - Lfirst(2)=Lanf - Llast(2)=Lend - Lblocks(3)=(Lend-Lanf)/2+1 - Lfirst(3)=Lanf - Llast(3)=Lend - else - Lblocks(2)=0 - Lblocks(3)=0 - endif - Lstarter(2)=Lstarter(1)+ - *nanz*Lblocks(1) - Lstarter(3)=Lstarter(2)+ - *nanz*Lblocks(2) -cbs ########################################################################################################## -cbs the (-2) cases CASE C -cbs ########################################################################################################## - if (l1.eq.0.or.l3.eq.0) then - Lblocks(4)=0 - else - incl1=-1 - incl3=-1 - call getlimit(l1+incl1,l2,l3+incl3,l4,Lanf,Lend) - if(Lend-Lanf.ge.0) then - Lblocks(4)=(Lend-Lanf)/2+1 - Lfirst(4)=Lanf - Llast(4)=Lend - else - Lblocks(4)=0 - endif - endif - Lstarter(4)=Lstarter(3)+ - *nanz*Lblocks(3) -c -CBS now the hole purpose of this routine -c - icont4=Lstarter(4)+nanz*Lblocks(4) - return -c Avoid unused argument warnings - if (.false.) then - call Unused_logical(bonn) - call Unused_logical(breit) - call Unused_logical(sameorb) - end if - end diff -Nru openmolcas-22.02/src/amfi_util/gencouldim.F90 openmolcas-22.10/src/amfi_util/gencouldim.F90 --- openmolcas-22.02/src/amfi_util/gencouldim.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/gencouldim.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,117 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine gencoulDIM(l1,l2,l3,l4,makemean,icont4) +!bs SUBROUTINE to calculate the dimemsion of the radial integral +!bs arrays. BASICALLY GENCOUL WITHOUT EXPLICIT INTEGRAL CALCULATION +!bs integrals for the four angular momenta l1-l4 + +use AMFI_global, only: Lblocks, Lfirst, Llast, Lstarter, Lvalues, nblock, ncontrac +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: l1, l2, l3, l4 +logical(kind=iwp), intent(in) :: makemean +integer(kind=iwp), intent(out) :: icont4 +integer(kind=iwp) :: incl1, incl3, Lanf, Lend, nanz + +!bs first of all, this routine determines, for which L +!bs values the radial integrals have to be solved +!bs initialize the number of blocks for the different +!bs l-combinations +!bs no (ss|ss) contributions +if ((l1 == 0) .and. (l2 == 0) .and. (l3 == 0) .and. (l4 == 0)) return +! no integrals for +if (makemean) then + nblock = 1 ! sp sp are the first, so the first block + Lstarter(1) = 1 +else + call SysAbendMsg('gencoulDIM','only mean-field with this version',' ') +end if +!bs keep track of L-values for later purposes +Lvalues(1) = l1 +Lvalues(2) = l2 +Lvalues(3) = l3 +Lvalues(4) = l4 +!bs now nanz is given the new value +nanz = ncontrac(l1)*ncontrac(l2)*ncontrac(l3)*ncontrac(l4) + +!bs prepare the powers needed for cfunctx +! +! There are seven different CASES of integrals following +! ( A -- C) +! +! The structure is the same for all cases, therefore comments can be found only on case A + +!bs #################################################################### +!bs the (+2) cases CASE A +!bs #################################################################### +incl1 = 1 ! Those increments define the case +incl3 = 1 +!bs determine the possible L-values for the integrals by checking for triangular equation + +call getlimit(l1+incl1,l2,l3+incl3,l4,Lanf,Lend) + +!bs returns first and last L-values (Lanf,Lend), for which +!bs radial integrals have to be calculated +if (Lend-Lanf >= 0) then + !bs if there are blocks + Lblocks(1) = (Lend-Lanf)/2+1 ! L increases in steps of 2, due to parity conservation + Lfirst(1) = Lanf + Llast(1) = Lend +else + Lblocks(1) = 0 +end if +!bs #################################################################### +!bs the (0) cases CASE B +!bs #################################################################### +incl1 = 0 +incl3 = 0 +call getlimit(l1+incl1,l2,l3+incl3,l4,Lanf,Lend) +if (Lend-Lanf >= 0) then + Lblocks(2) = (Lend-Lanf)/2+1 + Lfirst(2) = Lanf + Llast(2) = Lend + Lblocks(3) = (Lend-Lanf)/2+1 + Lfirst(3) = Lanf + Llast(3) = Lend +else + Lblocks(2) = 0 + Lblocks(3) = 0 +end if +Lstarter(2) = Lstarter(1)+nanz*Lblocks(1) +Lstarter(3) = Lstarter(2)+nanz*Lblocks(2) +!bs #################################################################### +!bs the (-2) cases CASE C +!bs #################################################################### +if ((l1 == 0) .or. (l3 == 0)) then + Lblocks(4) = 0 +else + incl1 = -1 + incl3 = -1 + call getlimit(l1+incl1,l2,l3+incl3,l4,Lanf,Lend) + if (Lend-Lanf >= 0) then + Lblocks(4) = (Lend-Lanf)/2+1 + Lfirst(4) = Lanf + Llast(4) = Lend + else + Lblocks(4) = 0 + end if +end if +Lstarter(4) = Lstarter(3)+nanz*Lblocks(3) + +!BS now the whole purpose of this routine + +icont4 = Lstarter(4)+nanz*Lblocks(4) + +return + +end subroutine gencoulDIM diff -Nru openmolcas-22.02/src/amfi_util/gencoul.f openmolcas-22.10/src/amfi_util/gencoul.f --- openmolcas-22.02/src/amfi_util/gencoul.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/gencoul.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,257 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine gencoul(l1,l2,l3,l4,makemean, - * bonn,breit,sameorb,cont4SO,cont4OO,icont4, - * powexp,coulovlp) - implicit real*8(a-h,o-z) -cbs SUBROUTINE to generate all required radial -cbs integrals for the four angular momenta l1-l4 -#include "para.fh" -#include "param.fh" -#include "Molcas.fh" -#include "stdalloc.fh" - Real*8, Allocatable:: Scr1(:), Scr2(:), Prim(:), - & Quot1(:), Quot2(:), QuotP1(:), QuotP2(:) - logical makemean,bonn,breit,sameorb - dimension cont4SO(*),cont4OO(*), - * powexp(MxprimL,MxprimL,0:Lmax,0:Lmax,0:(Lmax+Lmax+5)), - * coulovlp(*) -* -cbs first of all, this routine determines, for which L -cbs values the radial integrals have to be solved -cbs initialize the number of blocks for the different -cbs l-combinations -cbs no (ss|ss) contributions - if (l1.eq.0.and.l2.eq.0.and.l3.eq.0.and.l4.eq.0) return -c ! no integrals for - if (makemean) then - nblock=1 ! sp sp are the first, so the first block - Lstarter(1)=1 - else - Call SysAbendMsg('gencoul', - & 'only mean-field with this version',' ') - endif -cbs keep track of L-values for later purposes - Lvalues(1)=l1 - Lvalues(2)=l2 - Lvalues(3)=l3 - Lvalues(4)=l4 -cbs now nanz is given the new value - nanz=ncontrac(l1)*ncontrac(l2)*ncontrac(l3)*ncontrac(l4) - nprimprod=nprimit(l1)*nprimit(l2)*nprimit(l3)*nprimit(l4) -* - Call mma_allocate(Quot1,nPrimProd,Label='Quot1') - Call mma_allocate(Quot2,nPrimProd,Label='Quot2') - Call mma_allocate(QuotP1,nPrimProd,Label='QuotP1') - Call mma_allocate(QuotP2,nPrimProd,Label='QuotP2') - Call mma_allocate(Prim,nPrimProd,Label='Prim') - Call mma_allocate(Scr1,nPrimProd,Label='Scr1') - Call mma_allocate(Scr2,nPrimProd,Label='Scr2') -c - call initfrac(nprimit(l1),nprimit(l2),nprimit(l3),nprimit(l4), - * Quot1,Quot2,exponents(1,l1),exponents(1,l2), - * exponents(1,l3),exponents(1,l4)) -cbs prepare the powers needed for cfunctx -c -c -c There are seven different CASES of integrals following -c ( A -- C) -c -c The structure is the same for all cases, therefore comments can be found only on case A -c -c -c -cbs ########################################################################################################### -cbs the (+2) cases CASE A -cbs ########################################################################################################## - incl1=1 ! Those increments define the case - incl3=1 -cbs determine the possible L-values for the integrals by checking for triangular equation -c - call getlimit(l1+incl1,l2,l3+incl3,l4,Lanf,Lend) -c -cbs returns first and last L-values (Lanf,Lend), for which -cbs radial integrals have to be calculated - if(Lend-Lanf.ge.0) then -cbs if there are blocks - Lblocks(1)=(Lend-Lanf)/2+1 ! L increases in steps of 2, -cbs due to parity conservation - Lfirst(1)=Lanf - Llast(1)=Lend - else - Lblocks(1)=0 - endif - if (Lblocks(1).gt.0) then ! integrals have to be calculated -cbs### check, whether integrals fit on array ################ - if (Lstarter(1)+nanz*Lblocks(1).gt.icont4) then - write(6,*) 'end at: ',Lstarter(1)+nanz*Lblocks(1) - Call SysAbendMsg('gencoul','increase icont4 in amfi.f',' ') - endif -cbs### check, whether integrals fit on array ################ - istart=Lstarter(1) -c ! gives the address, where to write the contracted integrals -cbs ipow1 and ipow2 are the the numbers of powers in the prefactor -cbs of the function Cfunct -cbs now loop over possible L-values - do Lrun= Lfirst(1),Llast(1),2 - ipow1=2+(l2+l4+Lrun)/2 - ipow2=2+(l1+l3+incl1+incl3+Lrun)/2 -cbs those powers have to be generated... - call getpow(ipow1,Quot1,QuotP1, - * nprimit(l1),nprimit(l2),nprimit(l3),nprimit(l4)) -cbs those powers have to be generated... - call getpow(ipow2,Quot2,QuotP2, - * nprimit(l1),nprimit(l2),nprimit(l3),nprimit(l4)) -c in buildcoul the radial integrals are calculated - call buildcoul(l1,l2,l3,l4,incl1,incl3, - * Lrun,Prim,nprimit(l1),nprimit(l2),nprimit(l3), - * nprimit(l4), - * exponents(1,l1),exponents(1,l2), - * exponents(1,l3),exponents(1,l4), - * powexp(1,1,l3,l1,lrun),powexp(1,1,l4,l2,lrun), - * QuotP1,QuotP2,coulovlp) -cbs in the contcas_ routines the integrals are contracted, including exponents as prefactors... - if (bonn.or.breit.or.sameorb) then - call contcasASO(l1,l2,l3,l4,istart,Prim, - * Scr1,Scr2,cont4SO) - else - call contcasASO(l1,l2,l3,l4,istart,Prim, - * Scr1,Scr2,cont4SO) - call contcasAOO(l1,l2,l3,l4,istart,Prim, - * Scr1,Scr2,cont4OO) - endif - istart=istart+nanz! start for next block contr integr. - enddo - endif -cbs ########################################################################################################## -cbs the (0) cases CASE B -cbs ########################################################################################################## - incl1=0 - incl3=0 - call getlimit(l1+incl1,l2,l3+incl3,l4,Lanf,Lend) - if(Lend-Lanf.ge.0) then - Lblocks(2)=(Lend-Lanf)/2+1 - Lfirst(2)=Lanf - Llast(2)=Lend - Lblocks(3)=(Lend-Lanf)/2+1 - Lfirst(3)=Lanf - Llast(3)=Lend - else - Lblocks(2)=0 - Lblocks(3)=0 - endif - Lstarter(2)=Lstarter(1)+ - *nanz*Lblocks(1) - Lstarter(3)=Lstarter(2)+ - *nanz*Lblocks(2) -cbs primitive integrals are the same for type 2 and 3 !!!!! - if (Lblocks(2).gt.0) then -cbs### check, whether integrals fit on array ################ - if (Lstarter(2)+2*nanz*Lblocks(2).gt.icont4) then - write(6,*) 'end at: ',Lstarter(2)+2*nanz*Lblocks(2) - Call SysAbendMsg ('gencoul','increase icont4 in amfi.f',' ' ) - endif -cbs### check, whether integrals fit on array ################ - istart=Lstarter(2) - istart2=Lstarter(3) - do Lrun= Lfirst(2),Llast(2),2 - ipow1=2+(l2+l4+Lrun)/2 - ipow2=2+(l1+l3+incl1+incl3+Lrun)/2 - call getpow(ipow1,Quot1,QuotP1, - * nprimit(l1),nprimit(l2),nprimit(l3),nprimit(l4)) - call getpow(ipow2,Quot2,QuotP2, - * nprimit(l1),nprimit(l2),nprimit(l3),nprimit(l4)) - call buildcoul(l1,l2,l3,l4,incl1,incl3, - * Lrun,Prim,nprimit(l1),nprimit(l2),nprimit(l3), - * nprimit(l4), - * exponents(1,l1),exponents(1,l2), - * exponents(1,l3),exponents(1,l4), - * powexp(1,1,l3,l1,lrun),powexp(1,1,l4,l2,lrun), - * QuotP1,QuotP2,coulovlp) - if (bonn.or.breit.or.sameorb) then - call contcasB1SO(l1,l2,l3,l4,istart,Prim, - * Scr1,Scr2,cont4SO) - call contcasB2SO(l1,l2,l3,l4,istart2,Prim, - * Scr1,Scr2,cont4SO) - else - call contcasB1SO(l1,l2,l3,l4,istart,Prim, - * Scr1,Scr2,cont4SO) - call contcasB2SO(l1,l2,l3,l4,istart2,Prim, - * Scr1,Scr2,cont4SO) - Call contcasB1OO(l1,l2,l3,l4,istart,Prim, - * Scr1,Scr2,cont4OO) - Call contcasB2OO(l1,l2,l3,l4,istart2,Prim, - * Scr1,Scr2,cont4OO) - endif - istart=istart+nanz - istart2=istart2+nanz - enddo - endif -cbs ########################################################################################################## -cbs the (-2) cases CASE C -cbs ########################################################################################################## - if (l1.eq.0.or.l3.eq.0) then - Lblocks(4)=0 - else - incl1=-1 - incl3=-1 - call getlimit(l1+incl1,l2,l3+incl3,l4,Lanf,Lend) - if(Lend-Lanf.ge.0) then - Lblocks(4)=(Lend-Lanf)/2+1 - Lfirst(4)=Lanf - Llast(4)=Lend - else - Lblocks(4)=0 - endif - endif - Lstarter(4)=Lstarter(3)+ - *nanz*Lblocks(3) - if (Lblocks(4).gt.0) then -cbs### check, whether integrals fit on array ################ - if (Lstarter(4)+nanz*Lblocks(4).gt.icont4) then - write(6,*) 'end at: ',Lstarter(4)+nanz*Lblocks(4) - Call SysAbendMsg('gencoul', 'increase icont4 in amfi.f', ' ' ) - endif -cbs### check, whether integrals fit on array ################ - istart=Lstarter(4) - do Lrun= Lfirst(4),Llast(4),2 - ipow1=2+(l2+l4+Lrun)/2 - ipow2=2+(l1+l3+incl1+incl3+Lrun)/2 - call getpow(ipow1,Quot1,QuotP1, - * nprimit(l1),nprimit(l2),nprimit(l3),nprimit(l4)) - call getpow(ipow2,Quot2,QuotP2, - * nprimit(l1),nprimit(l2),nprimit(l3),nprimit(l4)) - call buildcoul(l1,l2,l3,l4,incl1,incl3, - * Lrun,Prim,nprimit(l1),nprimit(l2),nprimit(l3), - * nprimit(l4), - * exponents(1,l1),exponents(1,l2), - * exponents(1,l3),exponents(1,l4), - * powexp(1,1,l3,l1,lrun),powexp(1,1,l4,l2,lrun), - * QuotP1,QuotP2,coulovlp) - if (bonn.or.breit.or.sameorb) then - call contcasCSO(l1,l2,l3,l4,istart,Prim,Scr1,Scr2,cont4SO) - else - call contcasCSO(l1,l2,l3,l4,istart,Prim,Scr1,Scr2,cont4SO) - call contcasCOO(l1,l2,l3,l4,istart,prim,Scr1,Scr2,cont4OO) - endif - istart=istart+nanz - enddo - endif -* - Call mma_deallocate(Quot2) - Call mma_deallocate(Quot1) - Call mma_deallocate(QuotP2) - Call mma_deallocate(QuotP1) - Call mma_deallocate(Prim) - Call mma_deallocate(Scr2) - Call mma_deallocate(Scr1) - return - end diff -Nru openmolcas-22.02/src/amfi_util/gencoul.F90 openmolcas-22.10/src/amfi_util/gencoul.F90 --- openmolcas-22.02/src/amfi_util/gencoul.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/gencoul.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,226 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine gencoul(l1,l2,l3,l4,makemean,bonn,breit,sameorb,cont4SO,cont4OO,icont4,powexp,coulovlp) +!bs SUBROUTINE to generate all required radial +!bs integrals for the four angular momenta l1-l4 + +use AMFI_global, only: exponents, Lblocks, Lfirst, Llast, Lmax, Lstarter, Lvalues, MxprimL, nblock, ncontrac, nprimit +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Half +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: l1, l2, l3, l4, icont4 +logical(kind=iwp), intent(in) :: makemean, bonn, breit, sameorb +real(kind=wp), intent(_OUT_) :: cont4SO(*), cont4OO(*) +real(kind=wp), intent(in) :: powexp(MxprimL,MxprimL,0:Lmax,0:Lmax,0:(Lmax+Lmax+5)), coulovlp(*) +integer(kind=iwp) :: incl1, incl3, ipow1, ipow2, istart, istart2, Lanf, Lend, Lrun, nanz, nprimprod +real(kind=wp), allocatable :: Prim(:), Quot1(:), Quot2(:), QuotP1(:), QuotP2(:), Scr1(:), Scr2(:) + +!bs first of all, this routine determines, for which L +!bs values the radial integrals have to be solved +!bs initialize the number of blocks for the different +!bs l-combinations +!bs no (ss|ss) contributions +if ((l1 == 0) .and. (l2 == 0) .and. (l3 == 0) .and. (l4 == 0)) return +! no integrals for +if (makemean) then + nblock = 1 ! sp sp are the first, so the first block + Lstarter(1) = 1 +else + call SysAbendMsg('gencoul','only mean-field with this version',' ') +end if +!bs keep track of L-values for later purposes +Lvalues(1) = l1 +Lvalues(2) = l2 +Lvalues(3) = l3 +Lvalues(4) = l4 +!bs now nanz is given the new value +nanz = ncontrac(l1)*ncontrac(l2)*ncontrac(l3)*ncontrac(l4) +nprimprod = nprimit(l1)*nprimit(l2)*nprimit(l3)*nprimit(l4) + +call mma_allocate(Quot1,nPrimProd,Label='Quot1') +call mma_allocate(Quot2,nPrimProd,Label='Quot2') +call mma_allocate(QuotP1,nPrimProd,Label='QuotP1') +call mma_allocate(QuotP2,nPrimProd,Label='QuotP2') +call mma_allocate(Prim,nPrimProd,Label='Prim') +call mma_allocate(Scr1,nPrimProd,Label='Scr1') +call mma_allocate(Scr2,nPrimProd,Label='Scr2') + +call initfrac(nprimit(l1),nprimit(l2),nprimit(l3),nprimit(l4),Quot1,Quot2,exponents(:,l1),exponents(:,l2),exponents(:,l3), & + exponents(:,l4)) +!bs prepare the powers needed for cfunctx +! +! There are seven different CASES of integrals following +! ( A -- C) +! +! The structure is the same for all cases, therefore comments can be found only on case A + +!bs #################################################################### +!bs the (+2) cases CASE A +!bs #################################################################### +incl1 = 1 ! Those increments define the case +incl3 = 1 +!bs determine the possible L-values for the integrals by checking for triangular equation + +call getlimit(l1+incl1,l2,l3+incl3,l4,Lanf,Lend) + +!bs returns first and last L-values (Lanf,Lend), for which +!bs radial integrals have to be calculated +if (Lend-Lanf >= 0) then + !bs if there are blocks + Lblocks(1) = (Lend-Lanf)/2+1 ! L increases in steps of 2, due to parity conservation + Lfirst(1) = Lanf + Llast(1) = Lend +else + Lblocks(1) = 0 +end if +if (Lblocks(1) > 0) then ! integrals have to be calculated + !bs### check, whether integrals fit on array ################ + if (Lstarter(1)+nanz*Lblocks(1) > icont4) then + write(u6,*) 'end at: ',Lstarter(1)+nanz*Lblocks(1) + call SysAbendMsg('gencoul','increase icont4 in amfi.f',' ') + end if + !bs### check, whether integrals fit on array ################ + istart = Lstarter(1) + ! gives the address, where to write the contracted integrals + !bs ipow1 and ipow2 are the the numbers of powers in the prefactor + !bs of the function Cfunct + !bs now loop over possible L-values + do Lrun=Lfirst(1),Llast(1),2 + ipow1 = 2+(l2+l4+Lrun)/2 + ipow2 = 2+(l1+l3+incl1+incl3+Lrun)/2 + !b those powers have to be generated... + QuotP1(:) = Quot1(:)**(real(ipow1,kind=wp)-Half) + !bs those powers have to be generated... + QuotP2(:) = Quot2(:)**(real(ipow2,kind=wp)-Half) + ! in buildcoul the radial integrals are calculated + call buildcoul(l1,l2,l3,l4,incl1,incl3,Lrun,Prim,nprimit(l1),nprimit(l2),nprimit(l3),nprimit(l4),exponents(:,l1), & + exponents(:,l2),exponents(:,l3),exponents(:,l4),powexp(:,:,l3,l1,lrun),powexp(:,:,l4,l2,lrun),QuotP1,QuotP2, & + coulovlp) + !bs in the contcas_ routines the integrals are contracted, including exponents as prefactors... + if (bonn .or. breit .or. sameorb) then + call contcasASO(l1,l2,l3,l4,istart,Prim,Scr1,Scr2,cont4SO) + else + call contcasASO(l1,l2,l3,l4,istart,Prim,Scr1,Scr2,cont4SO) + call contcasAOO(l1,l2,l3,l4,istart,Prim,Scr1,Scr2,cont4OO) + end if + istart = istart+nanz! start for next block contr integr. + end do +end if +!bs #################################################################### +!bs the (0) cases CASE B +!bs #################################################################### +incl1 = 0 +incl3 = 0 +call getlimit(l1+incl1,l2,l3+incl3,l4,Lanf,Lend) +if (Lend-Lanf >= 0) then + Lblocks(2) = (Lend-Lanf)/2+1 + Lfirst(2) = Lanf + Llast(2) = Lend + Lblocks(3) = (Lend-Lanf)/2+1 + Lfirst(3) = Lanf + Llast(3) = Lend +else + Lblocks(2) = 0 + Lblocks(3) = 0 +end if +Lstarter(2) = Lstarter(1)+nanz*Lblocks(1) +Lstarter(3) = Lstarter(2)+nanz*Lblocks(2) +!bs primitive integrals are the same for type 2 and 3 !!!!! +if (Lblocks(2) > 0) then + !bs### check, whether integrals fit on array ################ + if (Lstarter(2)+2*nanz*Lblocks(2) > icont4) then + write(u6,*) 'end at: ',Lstarter(2)+2*nanz*Lblocks(2) + call SysAbendMsg('gencoul','increase icont4 in amfi.f',' ') + end if + !bs### check, whether integrals fit on array ################ + istart = Lstarter(2) + istart2 = Lstarter(3) + do Lrun=Lfirst(2),Llast(2),2 + ipow1 = 2+(l2+l4+Lrun)/2 + ipow2 = 2+(l1+l3+incl1+incl3+Lrun)/2 + QuotP1(:) = Quot1(:)**(real(ipow1,kind=wp)-Half) + QuotP2(:) = Quot2(:)**(real(ipow2,kind=wp)-Half) + call buildcoul(l1,l2,l3,l4,incl1,incl3,Lrun,Prim,nprimit(l1),nprimit(l2),nprimit(l3),nprimit(l4),exponents(:,l1), & + exponents(:,l2),exponents(:,l3),exponents(:,l4),powexp(:,:,l3,l1,lrun),powexp(:,:,l4,l2,lrun),QuotP1,QuotP2, & + coulovlp) + if (bonn .or. breit .or. sameorb) then + call contcasB1SO(l1,l2,l3,l4,istart,Prim,Scr1,Scr2,cont4SO) + call contcasB2SO(l1,l2,l3,l4,istart2,Prim,Scr1,Scr2,cont4SO) + else + call contcasB1SO(l1,l2,l3,l4,istart,Prim,Scr1,Scr2,cont4SO) + call contcasB2SO(l1,l2,l3,l4,istart2,Prim,Scr1,Scr2,cont4SO) + call contcasB1OO(l1,l2,l3,l4,istart,Prim,Scr1,Scr2,cont4OO) + call contcasB2OO(l1,l2,l3,l4,istart2,Prim,Scr1,Scr2,cont4OO) + end if + istart = istart+nanz + istart2 = istart2+nanz + end do +end if +!bs #################################################################### +!bs the (-2) cases CASE C +!bs #################################################################### +if ((l1 == 0) .or. (l3 == 0)) then + Lblocks(4) = 0 +else + incl1 = -1 + incl3 = -1 + call getlimit(l1+incl1,l2,l3+incl3,l4,Lanf,Lend) + if (Lend-Lanf >= 0) then + Lblocks(4) = (Lend-Lanf)/2+1 + Lfirst(4) = Lanf + Llast(4) = Lend + else + Lblocks(4) = 0 + end if +end if +Lstarter(4) = Lstarter(3)+nanz*Lblocks(3) +if (Lblocks(4) > 0) then + !bs### check, whether integrals fit on array ################ + if (Lstarter(4)+nanz*Lblocks(4) > icont4) then + write(u6,*) 'end at: ',Lstarter(4)+nanz*Lblocks(4) + call SysAbendMsg('gencoul','increase icont4 in amfi.f',' ') + end if + !bs### check, whether integrals fit on array ################ + istart = Lstarter(4) + do Lrun=Lfirst(4),Llast(4),2 + ipow1 = 2+(l2+l4+Lrun)/2 + ipow2 = 2+(l1+l3+incl1+incl3+Lrun)/2 + QuotP1(:) = Quot1(:)**(real(ipow1,kind=wp)-Half) + QuotP2(:) = Quot2(:)**(real(ipow2,kind=wp)-Half) + call buildcoul(l1,l2,l3,l4,incl1,incl3,Lrun,Prim,nprimit(l1),nprimit(l2),nprimit(l3),nprimit(l4),exponents(:,l1), & + exponents(:,l2),exponents(:,l3),exponents(:,l4),powexp(:,:,l3,l1,lrun),powexp(:,:,l4,l2,lrun),QuotP1,QuotP2, & + coulovlp) + if (bonn .or. breit .or. sameorb) then + call contcasCSO(l1,l2,l3,l4,istart,Prim,Scr1,Scr2,cont4SO) + else + call contcasCSO(l1,l2,l3,l4,istart,Prim,Scr1,Scr2,cont4SO) + call contcasCOO(l1,l2,l3,l4,istart,prim,Scr1,Scr2,cont4OO) + end if + istart = istart+nanz + end do +end if + +call mma_deallocate(Quot2) +call mma_deallocate(Quot1) +call mma_deallocate(QuotP2) +call mma_deallocate(QuotP1) +call mma_deallocate(Prim) +call mma_deallocate(Scr2) +call mma_deallocate(Scr1) + +return + +end subroutine gencoul diff -Nru openmolcas-22.02/src/amfi_util/genovlp.f openmolcas-22.10/src/amfi_util/genovlp.f --- openmolcas-22.02/src/amfi_util/genovlp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genovlp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,105 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine genovlp(Lhigh,coulovlp) - implicit real*8 (a-h,o-z) -cbs generates overlap of normalized primitives. -#include "para.fh" -#include "param.fh" - dimension evecinv(MxprimL,MxprimL) - *,coulovlp(MxprimL,MxprimL,-1:1,-1:1,0:Lmax,0:Lmax) - do L=0,Lhigh - do Jrun=1,nprimit(L) - do Irun=1,nprimit(L) - normovlp(Irun,Jrun,L)=coulovlp(irun,jrun,0,0,L,L) - enddo - enddo -cbs invert the matrix, not very elegant, but sufficient - ipnt=0 - do jrun=1,nprimit(L) - do irun=1,jrun - ipnt=ipnt+1 - scratchinv(ipnt)=normovlp(irun,jrun,L) - enddo - enddo - do Jrun=1,nprimit(L) - do Irun=1,MxprimL - evecinv(Irun,Jrun)=0d0 - enddo - enddo - do Jrun=1,nprimit(L) - evecinv(jrun,jrun)=1d0 - enddo - call Jacob(scratchinv,evecinv,nprimit(L),MxprimL) - do irun=1,nprimit(L) - eval(irun)=sqrt(scratchinv((irun*irun+irun)/2)) - enddo -cbs ensure normalization of the vectors. - do IRUN=1,nprimit(L) - fact=0d0 - do JRUN=1,nprimit(L) - fact=fact+evecinv(JRUN,IRUN)*evecinv(JRUN,IRUN) - enddo - fact=1d0/sqrt(fact) - do JRUN=1,nprimit(L) - evecinv(JRUN,IRUN)=fact*evecinv(JRUN,IRUN) - enddo - enddo -cbs now generate rootOVLP - do irun=1,nprimit(L) - do jrun=1,nprimit(L) - rootOVLP(irun,jrun,l)=0d0 - enddo - enddo - do jrun=1,nprimit(L) - do irun=1,nprimit(L) - do krun=1,nprimit(L) - rootOVLP(irun,jrun,L)=rootOVLP(irun,jrun,L)+ - *evecinv(irun,krun)*evecinv(jrun,krun)*eval(krun) - enddo - enddo - enddo -cbs now generate rootOVLPinv - do irun=1,nprimit(L) - eval(irun)=1d0/eval(irun) - enddo - do irun=1,nprimit(L) - do jrun=1,nprimit(L) - rootOVLPinv(irun,jrun,l)=0d0 - enddo - enddo - do jrun=1,nprimit(L) - do irun=1,nprimit(L) - do krun=1,nprimit(L) - rootOVLPinv(irun,jrun,L)=rootOVLPinv(irun,jrun,L)+ - *evecinv(irun,krun)*evecinv(jrun,krun)*eval(krun) - enddo - enddo - enddo -cbs now generate OVLPinv - do irun=1,nprimit(L) - eval(irun)=eval(irun)*eval(irun) - enddo - do irun=1,nprimit(L) - do jrun=1,nprimit(L) - OVLPinv(irun,jrun,l)=0d0 - enddo - enddo - do jrun=1,nprimit(L) - do irun=1,nprimit(L) - do krun=1,nprimit(L) - OVLPinv(irun,jrun,L)=OVLPinv(irun,jrun,L)+ - *evecinv(irun,krun)*evecinv(jrun,krun)*eval(krun) - enddo - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/genovlp.F90 openmolcas-22.10/src/amfi_util/genovlp.F90 --- openmolcas-22.02/src/amfi_util/genovlp.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genovlp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,85 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine genovlp(Lhigh,coulovlp,eval) +!bs generates overlap of normalized primitives. + +use AMFI_global, only: Lmax, MxprimL, normovlp, nprimit, OVLPinv, rootOVLP, rootOVLPinv +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: Lhigh +real(kind=wp), intent(in) :: coulovlp(MxprimL,MxprimL,-1:1,-1:1,0:Lmax,0:Lmax) +real(kind=wp), intent(out) :: eval(MxprimL) +integer(kind=iwp) :: ipnt, Irun, Jrun, L, n +real(kind=wp) :: fact +real(kind=wp), allocatable :: evecinv(:,:) +real(kind=wp), allocatable, target :: scratch(:) +real(kind=wp), pointer :: tmp(:,:) + +call mma_allocate(evecinv,MxprimL,MxprimL,label='evecinv') +call mma_allocate(scratch,MxprimL**2,label='scratch') +tmp(1:MxprimL,1:MxprimL) => scratch + +do L=0,Lhigh + n = nprimit(L) + normovlp(1:n,1:n,L) = coulovlp(1:n,1:n,0,0,L,L) + !bs invert the matrix, not very elegant, but sufficient + ipnt = 0 + do jrun=1,n + do irun=1,jrun + ipnt = ipnt+1 + scratch(ipnt) = normovlp(irun,jrun,L) + end do + end do + evecinv(:,1:n) = Zero + do Jrun=1,n + evecinv(jrun,jrun) = One + end do + call Jacob(scratch,evecinv,n,MxprimL) + do irun=1,n + eval(irun) = sqrt(scratch((irun*(irun+1))/2)) + end do + !bs ensure normalization of the vectors. + do IRUN=1,n + fact = Zero + do JRUN=1,n + fact = fact+evecinv(JRUN,IRUN)*evecinv(JRUN,IRUN) + end do + fact = One/sqrt(fact) + evecinv(:,IRUN) = fact*evecinv(:,IRUN) + end do + !bs now generate rootOVLP + do irun=1,n + tmp(1:n,irun) = eval(irun)*evecinv(1:n,irun) + end do + call dgemm_('N','T',n,n,n,One,evecinv,MxprimL,tmp,MxprimL,Zero,rootOVLP(:,:,L),MxprimL) + !bs now generate rootOVLPinv + do irun=1,n + tmp(1:n,irun) = evecinv(1:n,irun)/eval(irun) + end do + call dgemm_('N','T',n,n,n,One,evecinv,MxprimL,tmp,MxprimL,Zero,rootOVLPinv(:,:,L),MxprimL) + !bs now generate OVLPinv + do irun=1,n + tmp(1:n,irun) = evecinv(1:n,irun)/eval(irun)**2 + end do + call dgemm_('N','T',n,n,n,One,evecinv,MxprimL,tmp,MxprimL,Zero,OVLPinv(:,:,L),MxprimL) +end do + +nullify(tmp) +call mma_deallocate(evecinv) +call mma_deallocate(scratch) + +return + +end subroutine genovlp diff -Nru openmolcas-22.02/src/amfi_util/genpowers.f openmolcas-22.10/src/amfi_util/genpowers.f --- openmolcas-22.02/src/amfi_util/genpowers.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genpowers.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,73 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine genpowers(Lhigh,powexp,coulovlp) - implicit real*8 (a-h,o-z) -#include "para.fh" -#include "param.fh" -#include "dofuc.fh" - dimension powexp(MxprimL,MxprimL,0:Lmax,0:Lmax,0:(Lmax+Lmax+5)) - *,coulovlp(MxprimL,MxprimL,-1:1,-1:1,0:Lmax,0:Lmax) -cbs set some often used powers of exponents - do L2=0,Lhigh - do L1=0,L2 - do irun1=1,nprimit(L1) - do irun2=1,nprimit(L2) - powexp(irun1,irun2,L1,L2,0)=1d0 - enddo - enddo - enddo - enddo - do L2=0,Lhigh - do L1=0,L2 - do Lrun=1,(L1+L2+5) - do irun2=1,nprimit(L2) - do irun1=1,nprimit(L1) - fact=sqrt(0.5d0*(exponents(irun1,L1)+exponents(irun2,L2))) -cbs write(6,*) 'fact',fact,'powexp',powexp(irun1,irun2,L1,L2,Lrun-1) - powexp(irun1,irun2,L1,L2,Lrun)= powexp(irun1,irun2,L1,L2,Lrun-1)* - *fact - enddo - enddo - enddo - enddo - enddo -cbs generate coulovlp = overlap for normalized functions, but sometimes -cbs with shifted l-values - do l2=0,lhigh - do incl2=-1,1 - if (l2+incl2.ge.0) then ! do not lower l for s-functions - n2=l2+incl2+1 - df2=1d0/sqrt(df(n2+n2-1)) - do l1=0,l2 - do incl1=-1,1 - if (l1+incl1.ge.0) then ! do not lower l for s-functions - n1=l1+incl1+1 - df1=1d0/sqrt(df(n1+n1-1)) - df12=df(n1+n2-1) - do iprim2=1,nprimit(l2) - fact2=sqrt(powexp(iprim2,iprim2,l2,l2,n2+n2+1)) - factor=fact2*df1*df2*df12 - do iprim1=1,nprimit(l1) - fact1=sqrt(powexp(iprim1,iprim1,l1,l1,n1+n1+1)) - coulovlp(iprim1,iprim2,incl1,incl2,l1,l2)= - * fact1*factor/powexp(iprim1,iprim2,l1,l2,n1+n2+1) -CBS write(6,*) 'fact1',fact1,'factor ',factor, -CBS * 'powexp ', powexp(iprim1,iprim2,l1,l2,n1+n2+1) - enddo - enddo - endif - enddo - enddo - endif - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/genpowers.F90 openmolcas-22.10/src/amfi_util/genpowers.F90 --- openmolcas-22.02/src/amfi_util/genpowers.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genpowers.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,75 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine genpowers(Lhigh,powexp,coulovlp) + +use AMFI_global, only: df, exponents, Lmax, MxprimL, nprimit +use Constants, only: One, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: Lhigh +real(kind=wp), intent(out) :: powexp(MxprimL,MxprimL,0:Lmax,0:Lmax,0:(Lmax+Lmax+5)), & + coulovlp(MxprimL,MxprimL,-1:1,-1:1,0:Lmax,0:Lmax) +integer(kind=iwp) :: incl1, incl2, iprim1, iprim2, irun1, irun2, L1, L2, Lrun, n1, n2 +real(kind=wp) :: df1, df12, df2, fact, fact1, fact2, factor + +!bs set some often used powers of exponents +do L2=0,Lhigh + do L1=0,L2 + powexp(1:nprimit(L1),1:nprimit(L2),L1,L2,0) = One + end do +end do +do L2=0,Lhigh + do L1=0,L2 + do Lrun=1,(L1+L2+5) + do irun2=1,nprimit(L2) + do irun1=1,nprimit(L1) + fact = sqrt(Half*(exponents(irun1,L1)+exponents(irun2,L2))) + !bs write(u6,*) 'fact',fact,'powexp',powexp(irun1,irun2,L1,L2,Lrun-1) + powexp(irun1,irun2,L1,L2,Lrun) = powexp(irun1,irun2,L1,L2,Lrun-1)*fact + end do + end do + end do + end do +end do +!bs generate coulovlp = overlap for normalized functions, but sometimes +!bs with shifted l-values +do l2=0,lhigh + do incl2=-1,1 + if (l2+incl2 >= 0) then ! do not lower l for s-functions + n2 = l2+incl2+1 + df2 = One/sqrt(df(n2+n2-1)) + do l1=0,l2 + do incl1=-1,1 + if (l1+incl1 >= 0) then ! do not lower l for s-functions + n1 = l1+incl1+1 + df1 = One/sqrt(df(n1+n1-1)) + df12 = df(n1+n2-1) + do iprim2=1,nprimit(l2) + fact2 = sqrt(powexp(iprim2,iprim2,l2,l2,n2+n2+1)) + factor = fact2*df1*df2*df12 + do iprim1=1,nprimit(l1) + fact1 = sqrt(powexp(iprim1,iprim1,l1,l1,n1+n1+1)) + coulovlp(iprim1,iprim2,incl1,incl2,l1,l2) = fact1*factor/powexp(iprim1,iprim2,l1,l2,n1+n2+1) + !BS write(u6,*) 'fact1',fact1,'factor ',factor,'powexp ',powexp(iprim1,iprim2,l1,l2,n1+n2+1) + end do + end do + end if + end do + end do + end if + end do +end do + +return + +end subroutine genpowers diff -Nru openmolcas-22.02/src/amfi_util/genprexyz10.f openmolcas-22.10/src/amfi_util/genprexyz10.f --- openmolcas-22.02/src/amfi_util/genprexyz10.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genprexyz10.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine genprexyz10(preXZ) - implicit real*8(a-h,o-z) -#include "para.fh" -#include "Molcas.fh" - Dimension preXZ(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) -cbs ##################################################################### -cbs additional (-) signs from the (-i) factors in the -cbs (-) linear combinations (see tosigX(Y,Z).f) -cbs ##################################################################### -cbs + + - + => minus - do M4= 0,Lmax - do M3=-Lmax,-1 - do M2= 0,Lmax -c do M1= 0,Lmax - call dscal_(Lmax+1,-1d0,preXZ(0,m2,m3,m4),1) -cbs preXZ(m1,m2,m3,m4)=-preXZ(m1,m2,m3,m4) -c enddo - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/genprexyz11.f openmolcas-22.10/src/amfi_util/genprexyz11.f --- openmolcas-22.02/src/amfi_util/genprexyz11.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genprexyz11.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine genprexyz11(preY) - implicit real*8(a-h,o-z) -#include "para.fh" -#include "Molcas.fh" - Dimension preY(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) -cbs ##################################################################### -cbs additional (-) signs from the (-i) factors in the -cbs (-) linear combinations (see tosigX(Y,Z).f) -cbs ##################################################################### -cbs + + - - > - - do M4=-Lmax,-1 - do M3=-Lmax,-1 - do M2=0,Lmax -c do M1=0,Lmax - call dscal_(Lmax+1,-1d0,preY(0,m2,m3,m4),1) -c preY(m1,m2,m3,m4)=-preY(m1,m2,m3,m4) -c enddo - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/genprexyz12.f openmolcas-22.10/src/amfi_util/genprexyz12.f --- openmolcas-22.02/src/amfi_util/genprexyz12.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genprexyz12.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine genprexyz12(preY) - implicit real*8(a-h,o-z) -#include "para.fh" -#include "Molcas.fh" - Dimension preY(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) -cbs ##################################################################### -cbs additional (-) signs from the (-i) factors in the -cbs (-) linear combinations (see tosigX(Y,Z).f) -cbs ##################################################################### -cbs - - + + > - - do M4=0,Lmax - do M3=0,Lmax - do M2=-Lmax,-1 -c do M1=-Lmax,-1 -c preY(m1,m2,m3,m4)=-preY(m1,m2,m3,m4) - call dscal_(Lmax,-1d0,preY(-Lmax,m2,m3,m4),1) -c enddo - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/genprexyz13.f openmolcas-22.10/src/amfi_util/genprexyz13.f --- openmolcas-22.02/src/amfi_util/genprexyz13.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genprexyz13.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,30 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine genprexyz13(icheckxy) - implicit real*8(a-h,o-z) -#include "para.fh" -#include "Molcas.fh" - integer mcheckxy - dimension icheckxy(0:Lmax,0:Lmax,0:Lmax,0:Lmax) -cbs ##################################################################### -cbs some quick decision for interaction -cbs ##################################################################### - do M4=0,Lmax - do M3=0,Lmax - do M2=0,Lmax - do M1=0,Lmax - icheckxy(m1,m2,m3,m4)=mcheckxy(m1,m2,m3,m4) - enddo - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/genprexyz13.F90 openmolcas-22.10/src/amfi_util/genprexyz13.F90 --- openmolcas-22.02/src/amfi_util/genprexyz13.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genprexyz13.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,37 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine genprexyz13(icheckxy) + +use AMFI_global, only: Lmax +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(out) :: icheckxy(0:Lmax,0:Lmax,0:Lmax,0:Lmax) +integer(kind=iwp) :: M1, M2, M3, M4 +integer(kind=iwp), external :: mcheckxy + +!bs #################################################################### +!bs some quick decision for interaction +!bs #################################################################### +do M4=0,Lmax + do M3=0,Lmax + do M2=0,Lmax + do M1=0,Lmax + icheckxy(m1,m2,m3,m4) = mcheckxy(m1,m2,m3,m4) + end do + end do + end do +end do + +return + +end subroutine genprexyz13 diff -Nru openmolcas-22.02/src/amfi_util/genprexyz14.f openmolcas-22.10/src/amfi_util/genprexyz14.f --- openmolcas-22.02/src/amfi_util/genprexyz14.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genprexyz14.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,45 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine genprexyz14(icheckz,interxyz) - implicit real*8(a-h,o-z) -#include "para.fh" -#include "Molcas.fh" - integer mcheckz - dimension icheckz(0:Lmax,0:Lmax,0:Lmax,0:Lmax), - *interxyz(16,0:Lmax,0:Lmax,0:Lmax,0:Lmax) -cbs ##################################################################### -cbs some quick decision for interaction -cbs ##################################################################### - do M4=0,Lmax - do M3=0,Lmax - do M2=0,Lmax - do M1=0,Lmax - icheckz(m1,m2,m3,m4)=mcheckz(m1,m2,m3,m4) - enddo - enddo - enddo - enddo -cbs ##################################################################### -cbs there are at most 16 possible combinations of signs ( 2**4) -cbs ##################################################################### - do M4=0,Lmax - do M3=0,Lmax - do M2=0,Lmax - do M1=0,Lmax - do irun=1,16 - interxyz(irun,m1,m2,m3,m4)=0 - enddo - enddo - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/genprexyz14.F90 openmolcas-22.10/src/amfi_util/genprexyz14.F90 --- openmolcas-22.02/src/amfi_util/genprexyz14.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genprexyz14.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,41 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine genprexyz14(icheckz,interxyz) + +use AMFI_global, only: Lmax +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(out) :: icheckz(0:Lmax,0:Lmax,0:Lmax,0:Lmax), interxyz(16,0:Lmax,0:Lmax,0:Lmax,0:Lmax) +integer(kind=iwp) :: M1, M2, M3, M4 +integer(kind=iwp), external :: mcheckz + +!bs #################################################################### +!bs some quick decision for interaction +!bs #################################################################### +do M4=0,Lmax + do M3=0,Lmax + do M2=0,Lmax + do M1=0,Lmax + icheckz(m1,m2,m3,m4) = mcheckz(m1,m2,m3,m4) + end do + end do + end do +end do +!bs #################################################################### +!bs there are at most 16 possible combinations of signs (2**4) +!bs #################################################################### +interxyz(:,:,:,:,:) = 0 + +return + +end subroutine genprexyz14 diff -Nru openmolcas-22.02/src/amfi_util/genprexyz15a.f openmolcas-22.10/src/amfi_util/genprexyz15a.f --- openmolcas-22.02/src/amfi_util/genprexyz15a.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genprexyz15a.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,117 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine genprexyz15a(icheckxy,icheckz,interxyz) - implicit real*8(a-h,o-z) - dimension icheckxy(*),icheckz(*),interxyz(16,*) -#include "para.fh" -#include "Molcas.fh" -cbs the following M values are the ones from the cartesian -cbs linear combinations. interxyz gives the sign sequence -cbs for interacting spherical functions, starting with -cbs type 1 (++++) and ending with type 16 (-++-) - ilauf=1 - do M4=0,Lmax - do M3=0,Lmax - do M2=0,Lmax - do M1=0,Lmax - irun=0 - if (icheckxy(ilauf)+icheckz(ilauf).gt.0) then - if (iabs(m1+m2-m3-m4).le.1) then - irun=irun+1 - interxyz(irun,ilauf)=1 ! + + + + - if (m1.gt.0.and.m2.gt.0.and. - * m3.gt.0.and.m4.gt.0) then - irun=irun+1 - interxyz(irun,ilauf)=2 ! - - - - - endif - endif - if (iabs(m1+m2-m3+m4).le.1) then - if (m4.gt.0) then - irun=irun+1 - interxyz(irun,ilauf)=3 ! + + + - - endif - if (m1.gt.0.and.m2.gt.0.and. - * m3.gt.0) then - irun=irun+1 - interxyz(irun,ilauf)=4 ! - - - + - endif - endif - if (iabs(m1+m2+m3-m4).le.1) then - if (m3.gt.0) then - irun=irun+1 - interxyz(irun,ilauf)=5 ! + + - + - endif - if (m1.gt.0.and.m2.gt.0.and. - * m4.gt.0) then - irun=irun+1 - interxyz(irun,ilauf)=6 ! - - + - - endif - endif - if (iabs(m1-m2-m3-m4).le.1) then - if (m2.gt.0) then - irun=irun+1 - interxyz(irun,ilauf)=7 ! + - + + - endif - if (m1.gt.0.and.m3.gt.0.and. - * m4.gt.0) then - irun=irun+1 - interxyz(irun,ilauf)=8 ! - + - - - endif - endif - if (iabs(-m1+m2-m3-m4).le.1) then - if (m1.gt.0) then - irun=irun+1 - interxyz(irun,ilauf)=9 ! - + + + - endif - if (m2.gt.0.and.m3.gt.0.and. - * m4.gt.0) then - irun=irun+1 - interxyz(irun,ilauf)=10 ! + - - - - endif - endif - if (iabs(m1+m2+m3+m4).le.1) then - if (m3.gt.0.and.m4.gt.0) then - irun=irun+1 - interxyz(irun,ilauf)=11 ! + + - - - endif - if (m1.gt.0.and.m2.gt.0) then - irun=irun+1 - interxyz(irun,ilauf)=12 ! - - + + - endif - endif - if (iabs(m1-m2-m3+m4).le.1) then - if (m2.gt.0.and.m4.gt.0) then - irun=irun+1 - interxyz(irun,ilauf)=13 ! + - + - - endif - if (m1.gt.0.and.m3.gt.0) then - irun=irun+1 - interxyz(irun,ilauf)=14 ! - + - + - endif - endif - if (iabs(m1-m2+m3-m4).le.1) then - if (m2.gt.0.and.m3.gt.0) then - irun=irun+1 - interxyz(irun,ilauf)=15 ! + - - + - endif - if (m1.gt.0.and.m4.gt.0) then - irun=irun+1 - interxyz(irun,ilauf)=16 ! - + + - - endif - endif - endif - ilauf=ilauf+1 - enddo - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/genprexyz15a.F90 openmolcas-22.10/src/amfi_util/genprexyz15a.F90 --- openmolcas-22.02/src/amfi_util/genprexyz15a.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genprexyz15a.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,118 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine genprexyz15a(icheckxy,icheckz,interxyz) + +use AMFI_global, only: Lmax +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: icheckxy(0:Lmax,0:Lmax,0:Lmax,0:Lmax), icheckz(0:Lmax,0:Lmax,0:Lmax,0:Lmax) +integer(kind=iwp), intent(inout) :: interxyz(16,0:Lmax,0:Lmax,0:Lmax,0:Lmax) +integer(kind=iwp) :: irun, M1, M2, M3, M4 + +!bs the following M values are the ones from the cartesian +!bs linear combinations. interxyz gives the sign sequence +!bs for interacting spherical functions, starting with +!bs type 1 (++++) and ending with type 16 (-++-) +do M4=0,Lmax + do M3=0,Lmax + do M2=0,Lmax + do M1=0,Lmax + irun = 0 + if (icheckxy(m1,m2,m3,m4)+icheckz(m1,m2,m3,m4) > 0) then + if (abs(m1+m2-m3-m4) <= 1) then + irun = irun+1 + interxyz(irun,m1,m2,m3,m4) = 1 ! + + + + + if ((m1 > 0) .and. (m2 > 0) .and. (m3 > 0) .and. (m4 > 0)) then + irun = irun+1 + interxyz(irun,m1,m2,m3,m4) = 2 ! - - - - + end if + end if + if (abs(m1+m2-m3+m4) <= 1) then + if (m4 > 0) then + irun = irun+1 + interxyz(irun,m1,m2,m3,m4) = 3 ! + + + - + end if + if ((m1 > 0) .and. (m2 > 0) .and. (m3 > 0)) then + irun = irun+1 + interxyz(irun,m1,m2,m3,m4) = 4 ! - - - + + end if + end if + if (abs(m1+m2+m3-m4) <= 1) then + if (m3 > 0) then + irun = irun+1 + interxyz(irun,m1,m2,m3,m4) = 5 ! + + - + + end if + if ((m1 > 0) .and. (m2 > 0) .and. (m4 > 0)) then + irun = irun+1 + interxyz(irun,m1,m2,m3,m4) = 6 ! - - + - + end if + end if + if (abs(m1-m2-m3-m4) <= 1) then + if (m2 > 0) then + irun = irun+1 + interxyz(irun,m1,m2,m3,m4) = 7 ! + - + + + end if + if ((m1 > 0) .and. (m3 > 0) .and. (m4 > 0)) then + irun = irun+1 + interxyz(irun,m1,m2,m3,m4) = 8 ! - + - - + end if + end if + if (abs(-m1+m2-m3-m4) <= 1) then + if (m1 > 0) then + irun = irun+1 + interxyz(irun,m1,m2,m3,m4) = 9 ! - + + + + end if + if ((m2 > 0) .and. (m3 > 0) .and. (m4 > 0)) then + irun = irun+1 + interxyz(irun,m1,m2,m3,m4) = 10 ! + - - - + end if + end if + if (abs(m1+m2+m3+m4) <= 1) then + if ((m3 > 0) .and. (m4 > 0)) then + irun = irun+1 + interxyz(irun,m1,m2,m3,m4) = 11 ! + + - - + end if + if ((m1 > 0) .and. (m2 > 0)) then + irun = irun+1 + interxyz(irun,m1,m2,m3,m4) = 12 ! - - + + + end if + end if + if (abs(m1-m2-m3+m4) <= 1) then + if ((m2 > 0) .and. (m4 > 0)) then + irun = irun+1 + interxyz(irun,m1,m2,m3,m4) = 13 ! + - + - + end if + if ((m1 > 0) .and. (m3 > 0)) then + irun = irun+1 + interxyz(irun,m1,m2,m3,m4) = 14 ! - + - + + end if + end if + if (abs(m1-m2+m3-m4) <= 1) then + if ((m2 > 0) .and. (m3 > 0)) then + irun = irun+1 + interxyz(irun,m1,m2,m3,m4) = 15 ! + - - + + end if + if ((m1 > 0) .and. (m4 > 0)) then + irun = irun+1 + interxyz(irun,m1,m2,m3,m4) = 16 ! - + + - + end if + end if + end if + end do + end do + end do +end do + +return + +end subroutine genprexyz15a diff -Nru openmolcas-22.02/src/amfi_util/genprexyz2.f openmolcas-22.10/src/amfi_util/genprexyz2.f --- openmolcas-22.02/src/amfi_util/genprexyz2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genprexyz2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine genprexyz2(preXZ) - implicit real*8(a-h,o-z) -#include "para.fh" -#include "Molcas.fh" - Dimension preXZ(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) - roottwo=sqrt(2d0) -cbs ##################################################################### -cbs prefactors preXZ und preY include the factors 1/root(2) -cbs for the +/- linear combinations of spherical harmonics -cbs ##################################################################### - do M3=-Lmax,Lmax - do M2=-Lmax,Lmax - do M1=-Lmax,Lmax - preXZ(m1,m2,m3,0)=preXZ(m1,m2,m3,0)*roottwo - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/genprexyz3.f openmolcas-22.10/src/amfi_util/genprexyz3.f --- openmolcas-22.02/src/amfi_util/genprexyz3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genprexyz3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine genprexyz3(preXZ) - implicit real*8(a-h,o-z) -#include "para.fh" -#include "Molcas.fh" - Dimension preXZ(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) - roottwo=sqrt(2d0) -cbs ##################################################################### -cbs prefactors preXZ und preY include the factors 1/root(2) -cbs for the +/- linear combinations of spherical harmonics -cbs ##################################################################### - do M3=-Lmax,Lmax - do M2=-Lmax,Lmax - do M1=-Lmax,Lmax - preXZ(m1,m2,0,m3)=preXZ(m1,m2,0,m3)*roottwo - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/genprexyz4.f openmolcas-22.10/src/amfi_util/genprexyz4.f --- openmolcas-22.02/src/amfi_util/genprexyz4.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genprexyz4.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine genprexyz4(preXZ) - implicit real*8(a-h,o-z) -#include "para.fh" -#include "Molcas.fh" - Dimension preXZ(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) - roottwo=sqrt(2d0) -cbs ##################################################################### -cbs prefactors preXZ und preY include the factors 1/root(2) -cbs for the +/- linear combinations of spherical harmonics -cbs ##################################################################### - do M3=-Lmax,Lmax - do M2=-Lmax,Lmax - do M1=-Lmax,Lmax - preXZ(m1,0,m2,m3)=preXZ(m1,0,m2,m3)*roottwo - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/genprexyz5.f openmolcas-22.10/src/amfi_util/genprexyz5.f --- openmolcas-22.02/src/amfi_util/genprexyz5.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genprexyz5.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine genprexyz5(preXZ) - implicit real*8(a-h,o-z) -#include "para.fh" -#include "Molcas.fh" - Dimension preXZ(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) - roottwo=sqrt(2d0) -cbs ##################################################################### -cbs prefactors preXZ und preY include the factors 1/root(2) -cbs for the +/- linear combinations of spherical harmonics -cbs ##################################################################### - do M3=-Lmax,Lmax - do M2=-Lmax,Lmax - do M1=-Lmax,Lmax - preXZ(0,m1,m2,m3)=preXZ(0,m1,m2,m3)*roottwo - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/genprexyz6.f openmolcas-22.10/src/amfi_util/genprexyz6.f --- openmolcas-22.02/src/amfi_util/genprexyz6.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genprexyz6.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine genprexyz6(preY,preXZ) - implicit real*8(a-h,o-z) -#include "para.fh" -#include "Molcas.fh" - Dimension preY(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), - *preXZ(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) -cbs ##################################################################### -cbs prefactors preXZ und preY include the factors 1/root(2) -cbs for the +/- linear combinations of spherical harmonics -cbs ##################################################################### - do M4=-Lmax,Lmax - do M3=-Lmax,Lmax - do M2=-Lmax,Lmax - do M1=-Lmax,Lmax - preY(m1,m2,m3,m4)=preXZ(m1,m2,m3,m4) - enddo - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/genprexyz7.f openmolcas-22.10/src/amfi_util/genprexyz7.f --- openmolcas-22.02/src/amfi_util/genprexyz7.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genprexyz7.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine genprexyz7(preXZ) - implicit real*8(a-h,o-z) -#include "para.fh" -#include "Molcas.fh" - Dimension preXZ(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) -cbs ##################################################################### -cbs additional (-) signs from the (-i) factors in the -cbs (-) linear combinations (see tosigX(Y,Z).f) -cbs ##################################################################### -cbs + - - - => minus - do M4=-Lmax,-1 - do M3=-Lmax,-1 - do M2=-Lmax,-1 -c do M1= 0,Lmax - call dscal_(Lmax+1,-1d0,preXZ(0,m2,m3,m4),1) -c preXZ(m1,m2,m3,m4)=-preXZ(m1,m2,m3,m4) -c enddo - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/genprexyz8.f openmolcas-22.10/src/amfi_util/genprexyz8.f --- openmolcas-22.02/src/amfi_util/genprexyz8.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genprexyz8.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine genprexyz8(preXZ) - implicit real*8(a-h,o-z) -#include "para.fh" -#include "Molcas.fh" - Dimension preXZ(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) -cbs ##################################################################### -cbs additional (-) signs from the (-i) factors in the -cbs (-) linear combinations (see tosigX(Y,Z).f) -cbs ##################################################################### -cbs - + - - => minus - do M4=-Lmax,-1 - do M3=-Lmax,-1 - do M2= 0,Lmax -c do M1=-Lmax,-1 -c preXZ(m1,m2,m3,m4)=-preXZ(m1,m2,m3,m4) - call dscal_(Lmax,-1d0,preXZ(-Lmax,m2,m3,m4),1) -c enddo - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/genprexyz9.f openmolcas-22.10/src/amfi_util/genprexyz9.f --- openmolcas-22.02/src/amfi_util/genprexyz9.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genprexyz9.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine genprexyz9(preXZ) - implicit real*8(a-h,o-z) -#include "para.fh" -#include "Molcas.fh" - Dimension preXZ(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) -cbs ##################################################################### -cbs additional (-) signs from the (-i) factors in the -cbs (-) linear combinations (see tosigX(Y,Z).f) -cbs ##################################################################### -cbs + + + - => minus - do M4=-Lmax,-1 - do M3= 0,Lmax - do M2= 0,Lmax -c do M1= 0,Lmax -c preXZ(m1,m2,m3,m4)=-preXZ(m1,m2,m3,m4) -c enddo - call dscal_(Lmax+1,-1d0,preXZ(0,m2,m3,m4),1) - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/genprexyz.f openmolcas-22.10/src/amfi_util/genprexyz.f --- openmolcas-22.02/src/amfi_util/genprexyz.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genprexyz.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,30 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine genprexyz(preXZ) - implicit real*8(a-h,o-z) -#include "para.fh" -#include "Molcas.fh" - Dimension preXZ(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) -cbs ##################################################################### -cbs prefactors preXZ und preY include the factors 1/root(2) -cbs for the +/- linear combinations of spherical harmonics -cbs ##################################################################### - do M4=-Lmax,Lmax - do M3=-Lmax,Lmax - do M2=-Lmax,Lmax - do M1=-Lmax,Lmax - preXZ(m1,m2,m3,m4)=0.25d0 - enddo - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/genstar.f openmolcas-22.10/src/amfi_util/genstar.f --- openmolcas-22.02/src/amfi_util/genstar.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/genstar.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine genstar(Lhigh) - implicit real*8 (a-h,o-z) -cbs purpose: generate start adresses of contraction coeffs on -cbs contrarray for the different L-Blocks -#include "para.fh" -#include "param.fh" - istart=1 - do L=0,Lhigh - inc=nprimit(L)*ncontrac(L) - iaddori(L)=istart - istart=istart+inc - iaddtyp1(L)=istart - istart=istart+inc - iaddtyp2(L)=istart - istart=istart+inc - iaddtyp3(L)=istart - istart=istart+inc - iaddtyp4(L)=istart - istart=istart+inc - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/gentkin.f openmolcas-22.10/src/amfi_util/gentkin.f --- openmolcas-22.02/src/amfi_util/gentkin.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/gentkin.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine gentkin(L,TKIN,nprims,exponents,rootOVLPinv) - implicit real*8 (a-h,o-z) -#include "para.fh" -cbs subroutine to generate the kinetic energy - dimension TKIN(nprims,nprims),exponents(*), - *dummy(MxprimL,MxprimL),dummy2(MxprimL,MxprimL), - *rootOVLPinv(MxprimL,MxprimL) -cbs one triangular part of the matrix - do irun2=1,nprims - do irun1=1,irun2 - dummy(irun1,irun2)= - * Tkinet(l,exponents(irun1), - * exponents(irun2)) - enddo - enddo -cbs copy to the other triangular part.... - do irun2=1,nprims-1 - do irun1=irun2+1,nprims - dummy(irun1,irun2)=dummy(irun2,irun1) - enddo - enddo -cbs now transform by rootovlp*dummy*rootovlp - do jrun=1,nprims - do irun=1,nprims - TKIN(irun,jrun)=0d0 - dummy2(irun,jrun)=0d0 - enddo - enddo - do irun=1,nprims - do jrun=1,nprims - do krun=1,nprims - dummy2(irun,jrun)=dummy2(irun,jrun)+ - * dummy(irun,krun)*rootovlpinv(krun,jrun) - enddo - enddo - enddo - do irun=1,nprims - do jrun=1,nprims - do krun=1,nprims - Tkin(irun,jrun)=Tkin(irun,jrun)+ - * dummy2(krun,jrun)*rootovlpinv(irun,krun) - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/gentkin.F90 openmolcas-22.10/src/amfi_util/gentkin.F90 --- openmolcas-22.02/src/amfi_util/gentkin.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/gentkin.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,47 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine gentkin(L,TKIN,nprims,exponents,rootOVLPinv) +!bs subroutine to generate the kinetic energy + +use AMFI_global, only: MxprimL +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: L, nprims +real(kind=wp), intent(out) :: TKIN(nprims,nprims) +real(kind=wp), intent(in) :: exponents(nprims), rootOVLPinv(MxprimL,MxprimL) +integer(kind=iwp) :: irun1, irun2 +real(kind=wp), allocatable :: dummy(:,:), dummy2(:,:) +real(kind=wp), external :: Tkinet + +call mma_allocate(dummy,nprims,nprims,label='dummy') +call mma_allocate(dummy2,nprims,nprims,label='dummy2') + +!bs build the symmetric matrix +do irun2=1,nprims + do irun1=1,irun2 + dummy(irun1,irun2) = Tkinet(L,exponents(irun1),exponents(irun2)) + dummy(irun2,irun1) = dummy(irun1,irun2) + end do +end do +!bs now transform by rootOVLPinv*dummy*rootOVLPinv +call dgemm_('N','N',nprims,nprims,nprims,One,dummy,nprims,rootOVLPinv,MxprimL,Zero,dummy2,nprims) +call dgemm_('N','N',nprims,nprims,nprims,One,rootOVLPinv,MxprimL,dummy2,nprims,Zero,Tkin,nprims) + +call mma_deallocate(dummy) +call mma_deallocate(dummy2) + +return + +end subroutine gentkin diff -Nru openmolcas-22.02/src/amfi_util/getAOs2.f openmolcas-22.10/src/amfi_util/getAOs2.f --- openmolcas-22.02/src/amfi_util/getAOs2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/getAOs2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,424 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine getAOs2(lhigh) - implicit real*8(a-h,o-z) -cbs get expansions of atomic orbitals in contracted functions -#include "para.fh" -#include "param.fh" -#include "nucleus.fh" - integer closedshells(0:LMAX),openshells(0:LMAX) - call getocc_ao(int(charge),closedshells,openshells) - do lrun=0,lhigh - do irun=1,MxcontL - do jrun=1,MxcontL - AOcoeffs(jrun,irun,lrun)=0d0 - enddo - enddo - enddo -CBS write(6,*) 'Orbitals for mean-field' - do lrun=0,lhigh -CBS write(6,'(A3,I3)') 'L= ',lrun - do i=1,closedshells(lrun) - occup(i,lrun)=2.0 - AOcoeffs(i,i,lrun)=1d0 - enddo - noccorb(lrun)=closedshells(lrun) - if (openshells(lrun).gt.0) then - i=closedshells(lrun)+1 - occup(i,lrun)=1d0*DBLE(openshells(lrun))/DBLE(lrun+lrun+1) - AOcoeffs(i,i,lrun)=1d0 - noccorb(lrun)=i - endif - if (noccorb(lrun).gt.0) then -CBS write(6,'(A,I3)') 'number of orbitals ',noccorb(lrun) -CBS do iorbital=1,noccorb(lrun) -CBS write(6,'(A,8F8.4)') 'OCCUPATION: ',(occup(iorbital,lrun), -CBS *iorbital=1,noccorb(lrun)) -CBS enddo - endif - enddo - return - end -cbs - subroutine getocc_ao(icharge,iclosed,iopen) - implicit real*8(a-h,o-z) -#include "para.fh" - parameter (ichargemax=103) - dimension iclocc(0:Lmax_occ,0:ichargemax) - dimension iopocc(0:Lmax_occ,0:ichargemax) - character*30 occtxt(0:ichargemax) - character*35 txt - data txt/' SO-integrals were calculated for '/ - dimension iclosed(0:LMAX),iopen(0:LMAX) -* - data (occtxt(i),i= 0,10) / - *'dummy atom (no integrals) ', - *' H: no mean-field ', - *'He: 1s^2 ', - *'Li: [He]2s^1 ', - *'Be: [He]2s^2 ', - *' B: [He]2s^2 2p^1 ', - *' C: [He]2s^2 2p^2 ', - *' N: [He]2s^2 2p^3 ', - *' O: [He]2s^2 2p^4 ', - *' F: [He]2s^2 2p^5 ', - *'Ne: [He]2s^2 2p^6 '/ - data (occtxt(i),i= 11,20) / - *'Na: [Ne]3s^1 ', - *'Mg: [Ne]3s^2 ', - *'Al: [Ne]3s^2 3p^1 ', - *'Si: [Ne]3s^2 3p^2 ', - *' P: [Ne]3s^2 3p^3 ', - *' S: [Ne]3s^2 3p^4 ', - *'Cl: [Ne]3s^2 3p^5 ', - *'Ar: [Ne]3s^2 3p^6 ', - *' K: [Ar]4s^1 ', - *'Ca: [Ar]4s^2 '/ - data (occtxt(i),i= 21,30) / - *'Sc: [Ar]4s^2 3d^1 ', - *'Ti: [Ar]4s^2 3d^2 ', - *' V: [Ar]4s^2 3d^3 ', - *'Cr: [Ar]4s^2 3d^4 ', - *'Mn: [Ar]4s^2 3d^5 ', - *'Fe: [Ar]4s^2 3d^6 ', - *'Co: [Ar]4s^2 3d^7 ', - *'Ni: [Ar]4s^2 3d^8 ', - *'Cu: [Ar]4s^1 3d^10 ', - *'Zn: [Ar]4s^2 3d^10 '/ - data (occtxt(i),i= 31,40) / - *'Ga: [Ar]4s^2 3d^10 4p^1 ', - *'Ge: [Ar]4s^2 3d^10 4p^2 ', - *'As: [Ar]4s^2 3d^10 4p^3 ', - *'Se: [Ar]4s^2 3d^10 4p^4 ', - *'Br: [Ar]4s^2 3d^10 4p^5 ', - *'Kr: [Ar]4s^2 3d^10 4p^6 ', - *'Rb: [Kr]5s^1 ', - *'Sr: [Kr]5s^2 ', - *' Y: [Kr]5s^2 4d^1 ', - *'Zr: [Kr]5s^2 4d^2 '/ - data (occtxt(i),i= 41,50) / - *'Nb: [Kr]5s^2 4d^3 ', - *'Mo: [Kr]5s^2 4d^4 ', - *'Tc: [Kr]5s^2 4d^5 ', - *'Ru: [Kr]5s^2 4d^6 ', - *'Rh: [Kr]5s^2 4d^7 ', - *'Pd: [Kr]5s^2 4d^8 ', - *'Ag: [Kr]5s^1 4d^10 ', - *'Cd: [Kr]5s^2 4d^10 ', - *'In: [Kr]5s^2 4d^10 5p^1 ', - *'Sn: [Kr]5s^2 4d^10 5p^2 '/ - data (occtxt(i),i= 51,60) / - *'Sb: [Kr]5s^2 4d^10 5p^3 ', - *'Te: [Kr]5s^2 4d^10 5p^4 ', - *' I: [Kr]5s^2 4d^10 5p^5 ', - *'Xe: [Kr]5s^2 4d^10 5p^6 ', - *'Cs: [Xe]6s^1 ', - *'Ba: [Xe]6s^2 ', - *'La: [Xe]6s^2 5d^1 ', - *'Ce: [Xe]6s^2 4f^2 ', - *'Pr: [Xe]6s^2 4f^3 ', - *'Nd: [Xe]6s^2 4f^4 '/ - data (occtxt(i),i= 61,70) / - *'Pm: [Xe]6s^2 4f^5 ', - *'Sm: [Xe]6s^2 4f^6 ', - *'Eu: [Xe]6s^2 4f^7 ', - *'Gd: [Xe]6s^2 4f^8 ', - *'Tb: [Xe]6s^2 4f^9 ', - *'Dy: [Xe]6s^2 4f^10 ', - *'Ho: [Xe]6s^2 4f^11 ', - *'Er: [Xe]6s^2 4f^12 ', - *'Tm: [Xe]6s^2 4f^13 ', - *'Yb: [Xe]6s^2 4f^14 '/ - data (occtxt(i),i= 71,80) / - *'Lu: [Xe+4f^14]6s^2 5d^1 ', - *'Hf: [Xe+4f^14]6s^2 5d^2 ', - *'Ta: [Xe+4f^14]6s^2 5d^3 ', - *' W: [Xe+4f^14]6s^2 5d^4 ', - *'Re: [Xe+4f^14]6s^2 5d^5 ', - *'Os: [Xe+4f^14]6s^2 5d^6 ', - *'Ir: [Xe+4f^14]6s^2 5d^7 ', - *'Pt: [Xe+4f^14]6s^1 5d^9 ', - *'Au: [Xe+4f^14]6s^1 5d^10 ', - *'Hg: [Xe+4f^14]6s^2 5d^10 '/ - data (occtxt(i),i= 81,90) / - *'Tl: [Xe+4f^14+5d^10]6s^2 6p^1 ', - *'Pb: [Xe+4f^14+5d^10]6s^2 6p^2 ', - *'Bi: [Xe+4f^14+5d^10]6s^2 6p^3 ', - *'Po: [Xe+4f^14+5d^10]6s^2 6p^4 ', - *'At: [Xe+4f^14+5d^10]6s^2 6p^5 ', - *'Rn: [Xe+4f^14+5d^10]6s^2 6p^6 ', - *'Fr: [Rn]7s^1 ', - *'Ra: [Rn]7s^2 ', - *'Ac: [Rn]7s^2 6d^1 ', - *'Th: [Rn]7s^2 6d^2 '/ - data (occtxt(i),i= 91,iChargeMax) / - *'Pa: [Rn]7s^2 6d^1 5f^2 ', - *' U: [Rn]7s^2 6d^1 5f^3 ', - *'Np: [Rn]7s^2 6d^1 5f^4 ', - *'Pu: [Rn]7s^2 6d^0 5f^6 ', - *'Am: [Rn]7s^2 6d^0 5f^7 ', - *'Cm: [Rn]7s^2 6d^0 5f^8 ', - *'Bk: [Rn]7s^2 6d^0 5f^9 ', - *'Cf: [Rn]7s^2 6d^0 5f^10 ', - *'Es: [Rn]7s^2 6d^0 5f^11 ', - *'Fm: [Rn]7s^2 6d^0 5f^12 ', - *'Md: [Rn]7s^2 6d^0 5f^13 ', - *'No: [Rn]7s^2 6d^0 5f^14 ', - *'Lr: [Rn]7s^2 6d^1 5f^14 '/ -* - data ((iclocc(i,j),i=0,LMAX_occ),j=0,10) / - & 0 , 0, 0, 0, !0 - & 0 , 0, 0, 0, !1 - & 1 , 0, 0, 0, !2 - & 1 , 0, 0, 0, !3 - & 2 , 0, 0, 0, !4 - & 2 , 0, 0, 0, !5 - & 2 , 0, 0, 0, !6 - & 2 , 0, 0, 0, !7 - & 2 , 0, 0, 0, !8 - & 2 , 0, 0, 0, !9 - & 2 , 1, 0, 0/ !10 - data ((iclocc(i,j),i=0,LMAX_occ),j=11,20) / - & 2 , 1, 0, 0, !11 - & 3 , 1, 0, 0, !12 - & 3 , 1, 0, 0, !13 - & 3 , 1, 0, 0, !14 - & 3 , 1, 0, 0, !15 - & 3 , 1, 0, 0, !16 - & 3 , 1, 0, 0, !17 - & 3 , 2, 0, 0, !18 - & 3 , 2, 0, 0, !19 - & 4 , 2, 0, 0/ !20 - data ((iclocc(i,j),i=0,LMAX_occ),j=21,30) / - & 4 , 2, 0, 0, !21 - & 4 , 2, 0, 0, !22 - & 4 , 2, 0, 0, !23 - & 4 , 2, 0, 0, !24 - & 4 , 2, 0, 0, !25 - & 4 , 2, 0, 0, !26 - & 4 , 2, 0, 0, !27 - & 4 , 2, 0, 0, !28 - & 3 , 2, 1, 0, !29 - & 4 , 2, 1, 0/ !30 - data ((iclocc(i,j),i=0,LMAX_occ),j=31,40) / - & 4 , 2, 1, 0, !31 - & 4 , 2, 1, 0, !32 - & 4 , 2, 1, 0, !33 - & 4 , 2, 1, 0, !34 - & 4 , 2, 1, 0, !35 - & 4 , 3, 1, 0, !36 - & 4 , 3, 1, 0, !37 - & 5 , 3, 1, 0, !38 - & 5 , 3, 1, 0, !39 - & 5 , 3, 1, 0/ !40 - data ((iclocc(i,j),i=0,LMAX_occ),j=41,50) / - & 5 , 3, 1, 0, !41 - & 5 , 3, 1, 0, !42 - & 5 , 3, 1, 0, !43 - & 5 , 3, 1, 0, !44 - & 5 , 3, 1, 0, !45 - & 5 , 3, 1, 0, !46 - & 4 , 3, 2, 0, !47 - & 5 , 3, 2, 0, !48 - & 5 , 3, 2, 0, !49 - & 5 , 3, 2, 0/ !50 - data ((iclocc(i,j),i=0,LMAX_occ),j=51,60) / - & 5 , 3, 2, 0, !51 - & 5 , 3, 2, 0, !52 - & 5 , 3, 2, 0, !53 - & 5 , 4, 2, 0, !54 - & 5 , 4, 2, 0, !55 - & 6 , 4, 2, 0, !56 - & 6 , 4, 2, 0, !57 - & 6 , 4, 2, 0, !58 - & 6 , 4, 2, 0, !59 - & 6 , 4, 2, 0/ !60 - data ((iclocc(i,j),i=0,LMAX_occ),j=61,70) / - & 6 , 4, 2, 0, !61 - & 6 , 4, 2, 0, !62 - & 6 , 4, 2, 0, !63 - & 6 , 4, 2, 0, !64 - & 6 , 4, 2, 0, !65 - & 6 , 4, 2, 0, !66 - & 6 , 4, 2, 0, !67 - & 6 , 4, 2, 0, !68 - & 6 , 4, 2, 0, !69 - & 6 , 4, 2, 1/ !70 - data ((iclocc(i,j),i=0,LMAX_occ),j=71,80) / - & 6 , 4, 2, 1, !71 - & 6 , 4, 2, 1, !72 - & 6 , 4, 2, 1, !73 - & 6 , 4, 2, 1, !74 - & 6 , 4, 2, 1, !75 - & 6 , 4, 2, 1, !76 - & 6 , 4, 2, 1, !77 - & 5 , 4, 2, 1, !78 - & 5 , 4, 3, 1, !79 - & 6 , 4, 3, 1/ !80 - data ((iclocc(i,j),i=0,LMAX_occ),j=81,90) / - & 6 , 4, 3, 1, !81 - & 6 , 4, 3, 1, !82 - & 6 , 4, 3, 1, !83 - & 6 , 4, 3, 1, !84 - & 6 , 4, 3, 1, !85 - & 6 , 5, 3, 1, !86 - & 6 , 5, 3, 1, !87 - & 7 , 5, 3, 1, !88 - & 7 , 5, 3, 1, !89 - & 7 , 5, 3, 1/ !90 - data ((iclocc(i,j),i=0,LMAX_occ),j=91,ichargemax) / - & 7 , 5, 3, 1, !91 - & 7 , 5, 3, 1, !92 - & 7 , 5, 3, 1, !93 - & 7 , 5, 3, 1, !94 - & 7 , 5, 3, 1, !95 - & 7 , 5, 3, 1, !96 - & 7 , 5, 3, 1, !97 - & 7 , 5, 3, 1, !98 - & 7 , 5, 3, 1, !99 - & 7 , 5, 3, 1, !100 - & 7 , 5, 3, 1, !101 - & 7 , 5, 3, 2, !102 - & 7 , 5, 3, 2/ !103 -cbs - data ((iopocc(i,j),i=0,LMAX_occ),j=0,10) / - & 0 , 0, 0, 0, !0 - & 0 , 0, 0, 0, ! 1 - & 0 , 0, 0, 0, ! 2 - & 1 , 0, 0, 0, ! 3 - & 0 , 0, 0, 0, ! 4 - & 0 , 1, 0, 0, ! 5 - & 0 , 2, 0, 0, ! 6 - & 0 , 3, 0, 0, ! 7 - & 0 , 4, 0, 0, ! 8 - & 0 , 5, 0, 0, ! 9 - & 0 , 0, 0, 0/ ! 10 - data ((iopocc(i,j),i=0,LMAX_occ),j=11,20) / - & 1 , 0, 0, 0, ! 11 - & 0 , 0, 0, 0, ! 12 - & 0 , 1, 0, 0, ! 13 - & 0 , 2, 0, 0, ! 14 - & 0 , 3, 0, 0, ! 15 - & 0 , 4, 0, 0, ! 16 - & 0 , 5, 0, 0, ! 17 - & 0 , 0, 0, 0, ! 18 - & 1 , 0, 0, 0, ! 19 - & 0 , 0, 0, 0/ ! 20 - data ((iopocc(i,j),i=0,LMAX_occ),j=21,30) / - & 0 , 0, 1, 0, ! 21 - & 0 , 0, 2, 0, ! 22 - & 0 , 0, 3, 0, ! 23 - & 0 , 0, 4, 0, ! 24 - & 0 , 0, 5, 0, ! 25 - & 0 , 0, 6, 0, ! 26 - & 0 , 0, 7, 0, ! 27 - & 0 , 0, 8, 0, ! 28 - & 1 , 0, 0, 0, ! 29 - & 0 , 0, 0, 0/ ! 30 - data ((iopocc(i,j),i=0,LMAX_occ),j=31,40) / - & 0 , 1, 0, 0, ! 31 - & 0 , 2, 0, 0, ! 32 - & 0 , 3, 0, 0, ! 33 - & 0 , 4, 0, 0, ! 34 - & 0 , 5, 0, 0, ! 35 - & 0 , 0, 0, 0, ! 36 - & 1 , 0, 0, 0, ! 37 - & 0 , 0, 0, 0, ! 38 - & 0 , 0, 1, 0, ! 39 - & 0 , 0, 2, 0/ ! 40 - data ((iopocc(i,j),i=0,LMAX_occ),j=41,50) / - & 0 , 0, 3, 0, ! 41 - & 0 , 0, 4, 0, ! 42 - & 0 , 0, 5, 0, ! 43 - & 0 , 0, 6, 0, ! 44 - & 0 , 0, 7, 0, ! 45 - & 0 , 0, 8, 0, ! 46 - & 1 , 0, 0, 0, ! 47 - & 0 , 0, 0, 0, ! 48 - & 0 , 1, 0, 0, ! 49 - & 0 , 2, 0, 0/ ! 50 - data ((iopocc(i,j),i=0,LMAX_occ),j=51,60) / - & 0 , 3, 0, 0, ! 51 - & 0 , 4, 0, 0, ! 52 - & 0 , 5, 0, 0, ! 53 - & 0 , 0, 0, 0, ! 54 - & 1 , 0, 0, 0, ! 55 - & 0 , 0, 0, 0, ! 56 - & 0 , 0, 1, 0, ! 57 - & 0 , 0, 0, 2, ! 58 - & 0 , 0, 0, 3, ! 59 - & 0 , 0, 0, 4/ ! 60 - data ((iopocc(i,j),i=0,LMAX_occ),j=61,70) / - & 0 , 0, 0, 5, ! 61 - & 0 , 0, 0, 6, ! 62 - & 0 , 0, 0, 7, ! 63 - & 0 , 0, 0, 8, ! 64 - & 0 , 0, 0, 9, ! 65 - & 0 , 0, 0, 10, ! 66 - & 0 , 0, 0, 11, ! 67 - & 0 , 0, 0, 12, ! 68 - & 0 , 0, 0, 13, ! 69 - & 0 , 0, 0, 0/ ! 70 - data ((iopocc(i,j),i=0,LMAX_occ),j=71,80) / - & 0 , 0, 1, 0, ! 71 - & 0 , 0, 2, 0, ! 72 - & 0 , 0, 3, 0, ! 73 - & 0 , 0, 4, 0, ! 74 - & 0 , 0, 5, 0, ! 75 - & 0 , 0, 6, 0, ! 76 - & 0 , 0, 7, 0, ! 77 - & 1 , 0, 9, 0, ! 78 - & 1 , 0, 0, 0, ! 79 - & 0 , 0, 0, 0/ ! 80 - data ((iopocc(i,j),i=0,LMAX_occ),j=81,90) / - & 0 , 1, 0, 0, ! 81 - & 0 , 2, 0, 0, ! 82 - & 0 , 3, 0, 0, ! 83 - & 0 , 4, 0, 0, ! 84 - & 0 , 5, 0, 0, ! 85 - & 0 , 0, 0, 0, ! 86 - & 1 , 0, 0, 0, ! 87 - & 0 , 0, 0, 0, ! 88 - & 0 , 0, 1, 0, ! 89 - & 0 , 0, 2, 0/ ! 90 - data ((iopocc(i,j),i=0,LMAX_occ),j=91,ichargemax) / - & 0 , 0, 1, 2, ! 91 - & 0 , 0, 1, 3, ! 92 - & 0 , 0, 1, 4, ! 93 - & 0 , 0, 0, 6, ! 94 - & 0 , 0, 0, 7, ! 95 - & 0 , 0, 0, 8, ! 96 - & 0 , 0, 0, 9, ! 97 - & 0 , 0, 0, 10, ! 98 - & 0 , 0, 0, 11, ! 99 - & 0 , 0, 0, 12, ! 100 - & 0 , 0, 0, 13, ! 101 - & 0 , 0, 0, 0, ! 102 - & 0 , 0, 1, 0/ ! 103 -cbs - if (icharge.gt.ichargemax) then - write(6,*) 'occupations not implemented' - Call Abend() - endif -* - iPL=iPrintLevel(-1) - If (iPL.ge.3) write(6,'(A35,A30)') txt,occtxt(icharge) -* - do irun=0,min(lmax,lmax_occ) - iclosed(irun)=iclocc(irun,icharge) - iopen(irun)=iopocc(irun,icharge) - end do - do irun=min(lmax,lmax_occ)+1,lmax - iclosed(irun)=0 - iopen(irun)=0 - end do - return - end diff -Nru openmolcas-22.02/src/amfi_util/getaos2.F90 openmolcas-22.10/src/amfi_util/getaos2.F90 --- openmolcas-22.02/src/amfi_util/getaos2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/getaos2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,49 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine getAOs2(lhigh) +!bs get expansions of atomic orbitals in contracted functions + +use AMFI_global, only: AOcoeffs, charge, Lmax, noccorb, occup +use Constants, only: Zero, One, Two +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: lhigh +integer(kind=iwp) :: closedshells(0:Lmax), i, lrun, openshells(0:Lmax) + +call getocc_ao(int(charge),closedshells,openshells) +AOcoeffs(:,:,0:lhigh) = Zero +!BS write(u6,*) 'Orbitals for mean-field' +do lrun=0,lhigh + !BS write(u6,'(A3,I3)') 'L= ',lrun + occup(1:closedshells(lrun),lrun) = Two + do i=1,closedshells(lrun) + AOcoeffs(i,i,lrun) = One + end do + noccorb(lrun) = closedshells(lrun) + if (openshells(lrun) > 0) then + i = closedshells(lrun)+1 + occup(i,lrun) = real(openshells(lrun),kind=wp)/real(lrun+lrun+1,kind=wp) + AOcoeffs(i,i,lrun) = One + noccorb(lrun) = i + end if + !BS if (noccorb(lrun) > 0) then + !BS write(u6,'(A,I3)') 'number of orbitals ',noccorb(lrun) + !BS do iorbital=1,noccorb(lrun) + !BS write(u6,'(A,8F8.4)') 'OCCUPATION: ',(occup(iorbital,lrun),iorbital=1,noccorb(lrun)) + !BS end do + !BS end if +end do + +return + +end subroutine getAOs2 diff -Nru openmolcas-22.02/src/amfi_util/getAOs.f openmolcas-22.10/src/amfi_util/getAOs.f --- openmolcas-22.02/src/amfi_util/getAOs.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/getAOs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,53 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine getAOs(lhigh) - Implicit Real*8 (a-h,o-z) -cbs get expansions of atomic orbitals in contracted functions -#include "para.fh" -#include "param.fh" - character*12 occtext,occread - character*18 textnorbmf,textnorbmf2 - logical EX - occtext='OCCUPATION: ' - textnorbmf='Number of orbitals' - call f_inquire('AO-expansion', EX) - if (.not.EX) then -CBS write(6,*) 'get occupations from DATA-block' - call getAOs2(lhigh) - return - endif - Lu_33=33 - Lu_33=IsFreeUnit(Lu_33) - call molcas_open(Lu_33,'AO-expansion') -c open(unit=Lu_33,file='AO-expansion',STATUS='UNKNOWN') -CBS write(6,*) 'Orbitals for mean-field' - do lrun=0,lhigh -CBS write(6,'(A3,I3)') 'L= ',lrun - read(Lu_33,'(A18,I3)') textnorbmf2,noccorb(lrun) - if (textnorbmf.ne.textnorbmf2) call SysAbendMsg('getAOs', - *'wrong keyword for number of orbitals in getAOs',' ') -CBS write(6,*) 'number of orbitals ',noccorb(lrun) - do iorbital=1,noccorb(lrun) - read(Lu_33,'(A12,F5.3)') occread,occup(iorbital,lrun) -CBS write(6,'(A,F8.4)') occtext,occup(iorbital,lrun) - if (occread.ne.occtext) call SysAbendMsg('getAOs', - & 'error reading AOs',' ') - read(Lu_33,*) (AOcoeffs(icont,iorbital,lrun), - *icont=1,ncontrac(lrun)) -CBS write(6,'(8F10.4)') (AOcoeffs(icont,iorbital,lrun), -CBS *icont=1,ncontrac(lrun)) -CBS write(6,*) ' ' - read(Lu_33,*) - enddo - enddo - close(Lu_33) - return - end diff -Nru openmolcas-22.02/src/amfi_util/getaos.F90 openmolcas-22.10/src/amfi_util/getaos.F90 --- openmolcas-22.02/src/amfi_util/getaos.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/getaos.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,57 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine getAOs(lhigh) +!bs get expansions of atomic orbitals in contracted functions + +use AMFI_global, only: AOcoeffs, ncontrac, noccorb, occup +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: lhigh +integer(kind=iwp) :: icont, iorbital, lrun, Lu_33 +logical(kind=iwp) :: EX +character(len=12) :: occread, occtext +character(len=18) :: textnorbmf, textnorbmf2 +integer(kind=iwp), external :: IsFreeUnit + +occtext = 'OCCUPATION: ' +textnorbmf = 'Number of orbitals' +call f_inquire('AO-expansion',EX) +if (.not. EX) then + !BS write(u6,*) 'get occupations from DATA-block' + call getAOs2(lhigh) +else + Lu_33 = IsFreeUnit(33) + call molcas_open(Lu_33,'AO-expansion') + !open(unit=Lu_33,file='AO-expansion',status='UNKNOWN') + !BS write(u6,*) 'Orbitals for mean-field' + do lrun=0,lhigh + !BS write(u6,'(A3,I3)') 'L= ',lrun + read(Lu_33,'(A18,I3)') textnorbmf2,noccorb(lrun) + if (textnorbmf /= textnorbmf2) call SysAbendMsg('getAOs','wrong keyword for number of orbitals in getAOs',' ') + !BS write(u6,*) 'number of orbitals ',noccorb(lrun) + do iorbital=1,noccorb(lrun) + read(Lu_33,'(A12,F5.3)') occread,occup(iorbital,lrun) + !BS write(u6,'(A,F8.4)') occtext,occup(iorbital,lrun) + if (occread /= occtext) call SysAbendMsg('getAOs','error reading AOs',' ') + read(Lu_33,*) (AOcoeffs(icont,iorbital,lrun),icont=1,ncontrac(lrun)) + !BS write(u6,'(8F10.4)') (AOcoeffs(icont,iorbital,lrun),icont=1,ncontrac(lrun)) + !BS write(u6,*) ' ' + read(Lu_33,*) + end do + end do + close(Lu_33) +end if + +return + +end subroutine getAOs diff -Nru openmolcas-22.02/src/amfi_util/getCG.f openmolcas-22.10/src/amfi_util/getCG.f --- openmolcas-22.02/src/amfi_util/getCG.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/getCG.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,49 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - real*8 function getCG( - *j1, ! integer 2*j1 - *j2, ! integer 2*j2 - *j3, ! integer 2*j3 - *m1, ! integer 2*m1 - *m2, ! integer 2*m2 - *m3) ! integer 2*m2 -cbs this routine calculates the Clebsch-Gordan-coefficients -cbs by actually calculating the 3j-symbol -cbs --- --- -cbs | j1 j2 | j3 | j1+m1+j2-m2 -cbs | | | = (-) sqrt (2 j3+1) * -cbs | m1 m2 | m3 | -cbs --- --- -cbs -cbs --- --- -cbs | j1 j2 j3 | -cbs | | -cbs | m1 m2 -m3 | -cbs --- --- - implicit real*8(a-h,o-z) -cbs initialize CG-coefficient - getCG=0d0 -cbs quick check - if (m1+m2.ne.m3) return - if (j1.lt.0.or.j2.lt.0.or.j3.lt.0) return -cbs check the correct sign beginning - idummy=(j1+j2+m1-m2)/2 - if (mod(idummy,2).eq.0) then - isign=1 - else - isign=-1 - endif -cbs check the correct sign end - fac1=sqrt(DBLE(j3+1)) - fac2=regge3j(j1,j2,j3,m1,m2,-m3) - getCG=DBLE(isign)*fac1*fac2 - return - end diff -Nru openmolcas-22.02/src/amfi_util/getcg.F90 openmolcas-22.10/src/amfi_util/getcg.F90 --- openmolcas-22.02/src/amfi_util/getcg.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/getcg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,55 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +function getCG(j1,j2,j3,m1,m2,m3) +!bs this routine calculates the Clebsch-Gordan-coefficients +!bs by actually calculating the 3j-symbol +!bs --- --- +!bs | j1 j2 | j3 | j1+m1+j2-m2 +!bs | | | = (-) sqrt (2 j3+1) * +!bs | m1 m2 | m3 | +!bs --- --- +!bs +!bs --- --- +!bs | j1 j2 j3 | +!bs | | +!bs | m1 m2 -m3 | + +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +real(kind=wp) :: getCG +integer(kind=iwp), intent(in) :: j1, j2, j3, m1, m2, m3 +integer(kind=iwp) :: idummy +real(kind=wp) :: fac1, fac2, sgn +real(kind=wp), external :: regge3j + +!bs initialize CG-coefficient +getCG = Zero +!bs quick check +if (m1+m2 /= m3) return +if ((j1 < 0) .or. (j2 < 0) .or. (j3 < 0)) return +!bs check the correct sign beginning +idummy = (j1+j2+m1-m2)/2 +if (mod(idummy,2) == 0) then + sgn = One +else + sgn = -One +end if +!bs check the correct sign end +fac1 = sqrt(real(j3+1,kind=wp)) +fac2 = regge3j(j1,j2,j3,m1,m2,-m3) +getCG = sgn*fac1*fac2 + +return + +end function getCG diff -Nru openmolcas-22.02/src/amfi_util/getlimit.f openmolcas-22.10/src/amfi_util/getlimit.f --- openmolcas-22.02/src/amfi_util/getlimit.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/getlimit.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine getLIMIT(l1,l2,l3,l4,Lanf,Lend) - implicit Integer (a-z) -cbs get the minimum and maximum L-values -cbs of the the coulomb-potential to interact -cbs with l1-l4 - lower1=iabs(l1-l3) - lower2=iabs(l2-l4) - lupper1=l1+l3 - lupper2=l2+l4 - Lanf=max(lower1,lower2) - Lend=min(lupper1,lupper2) -cbs check for parity - lsum=Lanf+l1+l3 - if (mod(lsum,2).eq.1) Lanf=Lanf+1 - lsum=Lend+l1+l3 - if (mod(lsum,2).eq.1) Lend=Lend-1 -cbs check the other parity - lsum=Lanf+l2+l4 - if (mod(lsum,2).eq.1) then - write(6,*) ' error in getLIMIT: ' - write(6,*) ' parity inconsistency for ' - write(6,*) 'l1,l2,l3,l4= ',l1,l2,l3,l4 - Call Abend() - endif - return - end diff -Nru openmolcas-22.02/src/amfi_util/getlimit.F90 openmolcas-22.10/src/amfi_util/getlimit.F90 --- openmolcas-22.02/src/amfi_util/getlimit.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/getlimit.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,46 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine getLIMIT(l1,l2,l3,l4,Lanf,Lend) +!bs get the minimum and maximum L-values +!bs of the the coulomb-potential to interact +!bs with l1-l4 + +use Definitions, only: iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: l1, l2, l3, l4 +integer(kind=iwp), intent(out) :: Lanf, Lend +integer(kind=iwp) :: lower1, lower2, lsum, lupper1, lupper2 + +lower1 = abs(l1-l3) +lower2 = abs(l2-l4) +lupper1 = l1+l3 +lupper2 = l2+l4 +Lanf = max(lower1,lower2) +Lend = min(lupper1,lupper2) +!bs check for parity +lsum = Lanf+l1+l3 +if (mod(lsum,2) == 1) Lanf = Lanf+1 +lsum = Lend+l1+l3 +if (mod(lsum,2) == 1) Lend = Lend-1 +!bs check the other parity +lsum = Lanf+l2+l4 +if (mod(lsum,2) == 1) then + write(u6,*) ' error in getLIMIT: ' + write(u6,*) ' parity inconsistency for ' + write(u6,*) 'l1,l2,l3,l4= ',l1,l2,l3,l4 + call Abend() +end if + +return + +end subroutine getLIMIT diff -Nru openmolcas-22.02/src/amfi_util/getocc_ao.F90 openmolcas-22.10/src/amfi_util/getocc_ao.F90 --- openmolcas-22.02/src/amfi_util/getocc_ao.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/getocc_ao.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,356 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine getocc_ao(icharge,iclosed,iopen) + +use AMFI_global, only: Lmax, Lmax_occ +use Definitions, only: iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: icharge +integer(kind=iwp), intent(out) :: iclosed(0:Lmax), iopen(0:Lmax) +integer(kind=iwp) :: iPL, ml +integer(kind=iwp), parameter :: ichargemax = 103, & + iclocc(0:Lmax_occ,0:ichargemax) = reshape([0,0,0,0, & !0 + 0,0,0,0, & !1 + 1,0,0,0, & !2 + 1,0,0,0, & !3 + 2,0,0,0, & !4 + 2,0,0,0, & !5 + 2,0,0,0, & !6 + 2,0,0,0, & !7 + 2,0,0,0, & !8 + 2,0,0,0, & !9 + 2,1,0,0, & !10 + 2,1,0,0, & !11 + 3,1,0,0, & !12 + 3,1,0,0, & !13 + 3,1,0,0, & !14 + 3,1,0,0, & !15 + 3,1,0,0, & !16 + 3,1,0,0, & !17 + 3,2,0,0, & !18 + 3,2,0,0, & !19 + 4,2,0,0, & !20 + 4,2,0,0, & !21 + 4,2,0,0, & !22 + 4,2,0,0, & !23 + 4,2,0,0, & !24 + 4,2,0,0, & !25 + 4,2,0,0, & !26 + 4,2,0,0, & !27 + 4,2,0,0, & !28 + 3,2,1,0, & !29 + 4,2,1,0, & !30 + 4,2,1,0, & !31 + 4,2,1,0, & !32 + 4,2,1,0, & !33 + 4,2,1,0, & !34 + 4,2,1,0, & !35 + 4,3,1,0, & !36 + 4,3,1,0, & !37 + 5,3,1,0, & !38 + 5,3,1,0, & !39 + 5,3,1,0, & !40 + 5,3,1,0, & !41 + 5,3,1,0, & !42 + 5,3,1,0, & !43 + 5,3,1,0, & !44 + 5,3,1,0, & !45 + 5,3,1,0, & !46 + 4,3,2,0, & !47 + 5,3,2,0, & !48 + 5,3,2,0, & !49 + 5,3,2,0, & !50 + 5,3,2,0, & !51 + 5,3,2,0, & !52 + 5,3,2,0, & !53 + 5,4,2,0, & !54 + 5,4,2,0, & !55 + 6,4,2,0, & !56 + 6,4,2,0, & !57 + 6,4,2,0, & !58 + 6,4,2,0, & !59 + 6,4,2,0, & !60 + 6,4,2,0, & !61 + 6,4,2,0, & !62 + 6,4,2,0, & !63 + 6,4,2,0, & !64 + 6,4,2,0, & !65 + 6,4,2,0, & !66 + 6,4,2,0, & !67 + 6,4,2,0, & !68 + 6,4,2,0, & !69 + 6,4,2,1, & !70 + 6,4,2,1, & !71 + 6,4,2,1, & !72 + 6,4,2,1, & !73 + 6,4,2,1, & !74 + 6,4,2,1, & !75 + 6,4,2,1, & !76 + 6,4,2,1, & !77 + 5,4,2,1, & !78 + 5,4,3,1, & !79 + 6,4,3,1, & !80 + 6,4,3,1, & !81 + 6,4,3,1, & !82 + 6,4,3,1, & !83 + 6,4,3,1, & !84 + 6,4,3,1, & !85 + 6,5,3,1, & !86 + 6,5,3,1, & !87 + 7,5,3,1, & !88 + 7,5,3,1, & !89 + 7,5,3,1, & !90 + 7,5,3,1, & !91 + 7,5,3,1, & !92 + 7,5,3,1, & !93 + 7,5,3,1, & !94 + 7,5,3,1, & !95 + 7,5,3,1, & !96 + 7,5,3,1, & !97 + 7,5,3,1, & !98 + 7,5,3,1, & !99 + 7,5,3,1, & !100 + 7,5,3,1, & !101 + 7,5,3,2, & !102 + 7,5,3,2 & !103 + ],shape(iclocc)), & + iopocc(0:Lmax_occ,0:ichargemax) = reshape([0,0,0,0, & !0 + 0,0,0,0, & !1 + 0,0,0,0, & !2 + 1,0,0,0, & !3 + 0,0,0,0, & !4 + 0,1,0,0, & !5 + 0,2,0,0, & !6 + 0,3,0,0, & !7 + 0,4,0,0, & !8 + 0,5,0,0, & !9 + 0,0,0,0, & !10 + 1,0,0,0, & !11 + 0,0,0,0, & !12 + 0,1,0,0, & !13 + 0,2,0,0, & !14 + 0,3,0,0, & !15 + 0,4,0,0, & !16 + 0,5,0,0, & !17 + 0,0,0,0, & !18 + 1,0,0,0, & !19 + 0,0,0,0, & !20 + 0,0,1,0, & !21 + 0,0,2,0, & !22 + 0,0,3,0, & !23 + 0,0,4,0, & !24 + 0,0,5,0, & !25 + 0,0,6,0, & !26 + 0,0,7,0, & !27 + 0,0,8,0, & !28 + 1,0,0,0, & !29 + 0,0,0,0, & !30 + 0,1,0,0, & !31 + 0,2,0,0, & !32 + 0,3,0,0, & !33 + 0,4,0,0, & !34 + 0,5,0,0, & !35 + 0,0,0,0, & !36 + 1,0,0,0, & !37 + 0,0,0,0, & !38 + 0,0,1,0, & !39 + 0,0,2,0, & !40 + 0,0,3,0, & !41 + 0,0,4,0, & !42 + 0,0,5,0, & !43 + 0,0,6,0, & !44 + 0,0,7,0, & !45 + 0,0,8,0, & !46 + 1,0,0,0, & !47 + 0,0,0,0, & !48 + 0,1,0,0, & !49 + 0,2,0,0, & !50 + 0,3,0,0, & !51 + 0,4,0,0, & !52 + 0,5,0,0, & !53 + 0,0,0,0, & !54 + 1,0,0,0, & !55 + 0,0,0,0, & !56 + 0,0,1,0, & !57 + 0,0,0,2, & !58 + 0,0,0,3, & !59 + 0,0,0,4, & !60 + 0,0,0,5, & !61 + 0,0,0,6, & !62 + 0,0,0,7, & !63 + 0,0,0,8, & !64 + 0,0,0,9, & !65 + 0,0,0,10, & !66 + 0,0,0,11, & !67 + 0,0,0,12, & !68 + 0,0,0,13, & !69 + 0,0,0,0, & !70 + 0,0,1,0, & !71 + 0,0,2,0, & !72 + 0,0,3,0, & !73 + 0,0,4,0, & !74 + 0,0,5,0, & !75 + 0,0,6,0, & !76 + 0,0,7,0, & !77 + 1,0,9,0, & !78 + 1,0,0,0, & !79 + 0,0,0,0, & !80 + 0,1,0,0, & !81 + 0,2,0,0, & !82 + 0,3,0,0, & !83 + 0,4,0,0, & !84 + 0,5,0,0, & !85 + 0,0,0,0, & !86 + 1,0,0,0, & !87 + 0,0,0,0, & !88 + 0,0,1,0, & !89 + 0,0,2,0, & !90 + 0,0,1,2, & !91 + 0,0,1,3, & !92 + 0,0,1,4, & !93 + 0,0,0,6, & !94 + 0,0,0,7, & !95 + 0,0,0,8, & !96 + 0,0,0,9, & !97 + 0,0,0,10, & !98 + 0,0,0,11, & !99 + 0,0,0,12, & !100 + 0,0,0,13, & !101 + 0,0,0,0, & !102 + 0,0,1,0 & !103 + ],shape(iopocc)) +character(len=35), parameter :: txt = ' SO-integrals were calculated for ' +character(len=30), parameter :: occtxt(0:ichargemax) = ['dummy atom (no integrals) ', & + ' H: no mean-field ', & + 'He: 1s^2 ', & + 'Li: [He]2s^1 ', & + 'Be: [He]2s^2 ', & + ' B: [He]2s^2 2p^1 ', & + ' C: [He]2s^2 2p^2 ', & + ' N: [He]2s^2 2p^3 ', & + ' O: [He]2s^2 2p^4 ', & + ' F: [He]2s^2 2p^5 ', & + 'Ne: [He]2s^2 2p^6 ', & + 'Na: [Ne]3s^1 ', & + 'Mg: [Ne]3s^2 ', & + 'Al: [Ne]3s^2 3p^1 ', & + 'Si: [Ne]3s^2 3p^2 ', & + ' P: [Ne]3s^2 3p^3 ', & + ' S: [Ne]3s^2 3p^4 ', & + 'Cl: [Ne]3s^2 3p^5 ', & + 'Ar: [Ne]3s^2 3p^6 ', & + ' K: [Ar]4s^1 ', & + 'Ca: [Ar]4s^2 ', & + 'Sc: [Ar]4s^2 3d^1 ', & + 'Ti: [Ar]4s^2 3d^2 ', & + ' V: [Ar]4s^2 3d^3 ', & + 'Cr: [Ar]4s^2 3d^4 ', & + 'Mn: [Ar]4s^2 3d^5 ', & + 'Fe: [Ar]4s^2 3d^6 ', & + 'Co: [Ar]4s^2 3d^7 ', & + 'Ni: [Ar]4s^2 3d^8 ', & + 'Cu: [Ar]4s^1 3d^10 ', & + 'Zn: [Ar]4s^2 3d^10 ', & + 'Ga: [Ar]4s^2 3d^10 4p^1 ', & + 'Ge: [Ar]4s^2 3d^10 4p^2 ', & + 'As: [Ar]4s^2 3d^10 4p^3 ', & + 'Se: [Ar]4s^2 3d^10 4p^4 ', & + 'Br: [Ar]4s^2 3d^10 4p^5 ', & + 'Kr: [Ar]4s^2 3d^10 4p^6 ', & + 'Rb: [Kr]5s^1 ', & + 'Sr: [Kr]5s^2 ', & + ' Y: [Kr]5s^2 4d^1 ', & + 'Zr: [Kr]5s^2 4d^2 ', & + 'Nb: [Kr]5s^2 4d^3 ', & + 'Mo: [Kr]5s^2 4d^4 ', & + 'Tc: [Kr]5s^2 4d^5 ', & + 'Ru: [Kr]5s^2 4d^6 ', & + 'Rh: [Kr]5s^2 4d^7 ', & + 'Pd: [Kr]5s^2 4d^8 ', & + 'Ag: [Kr]5s^1 4d^10 ', & + 'Cd: [Kr]5s^2 4d^10 ', & + 'In: [Kr]5s^2 4d^10 5p^1 ', & + 'Sn: [Kr]5s^2 4d^10 5p^2 ', & + 'Sb: [Kr]5s^2 4d^10 5p^3 ', & + 'Te: [Kr]5s^2 4d^10 5p^4 ', & + ' I: [Kr]5s^2 4d^10 5p^5 ', & + 'Xe: [Kr]5s^2 4d^10 5p^6 ', & + 'Cs: [Xe]6s^1 ', & + 'Ba: [Xe]6s^2 ', & + 'La: [Xe]6s^2 5d^1 ', & + 'Ce: [Xe]6s^2 4f^2 ', & + 'Pr: [Xe]6s^2 4f^3 ', & + 'Nd: [Xe]6s^2 4f^4 ', & + 'Pm: [Xe]6s^2 4f^5 ', & + 'Sm: [Xe]6s^2 4f^6 ', & + 'Eu: [Xe]6s^2 4f^7 ', & + 'Gd: [Xe]6s^2 4f^8 ', & + 'Tb: [Xe]6s^2 4f^9 ', & + 'Dy: [Xe]6s^2 4f^10 ', & + 'Ho: [Xe]6s^2 4f^11 ', & + 'Er: [Xe]6s^2 4f^12 ', & + 'Tm: [Xe]6s^2 4f^13 ', & + 'Yb: [Xe]6s^2 4f^14 ', & + 'Lu: [Xe+4f^14]6s^2 5d^1 ', & + 'Hf: [Xe+4f^14]6s^2 5d^2 ', & + 'Ta: [Xe+4f^14]6s^2 5d^3 ', & + ' W: [Xe+4f^14]6s^2 5d^4 ', & + 'Re: [Xe+4f^14]6s^2 5d^5 ', & + 'Os: [Xe+4f^14]6s^2 5d^6 ', & + 'Ir: [Xe+4f^14]6s^2 5d^7 ', & + 'Pt: [Xe+4f^14]6s^1 5d^9 ', & + 'Au: [Xe+4f^14]6s^1 5d^10 ', & + 'Hg: [Xe+4f^14]6s^2 5d^10 ', & + 'Tl: [Xe+4f^14+5d^10]6s^2 6p^1 ', & + 'Pb: [Xe+4f^14+5d^10]6s^2 6p^2 ', & + 'Bi: [Xe+4f^14+5d^10]6s^2 6p^3 ', & + 'Po: [Xe+4f^14+5d^10]6s^2 6p^4 ', & + 'At: [Xe+4f^14+5d^10]6s^2 6p^5 ', & + 'Rn: [Xe+4f^14+5d^10]6s^2 6p^6 ', & + 'Fr: [Rn]7s^1 ', & + 'Ra: [Rn]7s^2 ', & + 'Ac: [Rn]7s^2 6d^1 ', & + 'Th: [Rn]7s^2 6d^2 ', & + 'Pa: [Rn]7s^2 6d^1 5f^2 ', & + ' U: [Rn]7s^2 6d^1 5f^3 ', & + 'Np: [Rn]7s^2 6d^1 5f^4 ', & + 'Pu: [Rn]7s^2 6d^0 5f^6 ', & + 'Am: [Rn]7s^2 6d^0 5f^7 ', & + 'Cm: [Rn]7s^2 6d^0 5f^8 ', & + 'Bk: [Rn]7s^2 6d^0 5f^9 ', & + 'Cf: [Rn]7s^2 6d^0 5f^10 ', & + 'Es: [Rn]7s^2 6d^0 5f^11 ', & + 'Fm: [Rn]7s^2 6d^0 5f^12 ', & + 'Md: [Rn]7s^2 6d^0 5f^13 ', & + 'No: [Rn]7s^2 6d^0 5f^14 ', & + 'Lr: [Rn]7s^2 6d^1 5f^14 ' & + ] +integer(kind=iwp), external :: iPrintLevel + +if (icharge > ichargemax) then + write(u6,*) 'occupations not implemented' + call Abend() +end if + +iPL = iPrintLevel(-1) +if (iPL >= 3) write(u6,'(A35,A30)') txt,occtxt(icharge) + +ml = min(lmax,lmax_occ) +iclosed(:ml) = iclocc(0:ml,icharge) +iclosed(ml+1:) = 0 +iopen(:ml) = iopocc(0:ml,icharge) +iopen(ml+1:) = 0 + +return + +end subroutine getocc_ao diff -Nru openmolcas-22.02/src/amfi_util/getpow.f openmolcas-22.10/src/amfi_util/getpow.f --- openmolcas-22.02/src/amfi_util/getpow.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/getpow.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,46 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine getpow(max,quot,quotpow, - *nprim1,nprim2,nprim3,nprim4) -cbs generates some powers of for the prefactors of cfunct(X) -cbs look out for details there and in initfrac - implicit real*8 (a-h,o-z) -#include "para.fh" - dimension quotpow(nprim1,nprim2, - *nprim3,nprim4), - *quot(nprim1,nprim2,nprim3,nprim4) - do irun4=1,nprim4 - do irun3=1,nprim3 - do irun2=1,nprim2 - do irun1=1,nprim1 - quotpow(irun1,irun2,irun3,irun4)= - *sqrt(quot(irun1,irun2,irun3,irun4)) - enddo - enddo - enddo - enddo - if (max.eq.1) return -cbs - do irun=2,max - do irun4=1,nprim4 - do irun3=1,nprim3 - do irun2=1,nprim2 - do irun1=1,nprim1 - quotpow(irun1,irun2,irun3,irun4)= - *quotpow(irun1,irun2,irun3,irun4)* - *quot(irun1,irun2,irun3,irun4) - enddo - enddo - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/inidf.f openmolcas-22.10/src/amfi_util/inidf.f --- openmolcas-22.02/src/amfi_util/inidf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/inidf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine inidf -cbs initializes the df on common block with double facultatives - implicit real*8 (a-h,o-z) -#include "para.fh" -#include "param.fh" -#include "dofuc.fh" - df(0)=1.d0 - df(1)=1.d0 - do irun=2,ndfmx - df(irun)=DBLE(irun)*df(irun-2) - enddo - do jbm=0,ndfmx-1 - do ibm=jbm,ndfmx - dffrac(ibm,jbm)=df(ibm)/df(jbm) - enddo - enddo - do jbm=1,ndfmx - do ibm=0,jbm-1 - dffrac(ibm,jbm)=1d0/dffrac(jbm,ibm) - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/inidf.F90 openmolcas-22.10/src/amfi_util/inidf.F90 --- openmolcas-22.02/src/amfi_util/inidf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/inidf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,33 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine inidf() +!bs initializes the df on module with double factorials + +use AMFI_global, only: df, dffrac +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp) :: irun, jbm + +df(0) = One +df(1) = One +do irun=2,ubound(df,1) + df(irun) = real(irun,kind=wp)*df(irun-2) +end do +do jbm=0,ubound(df,1) + dffrac(:,jbm) = df(:)/df(jbm) +end do + +return + +end subroutine inidf diff -Nru openmolcas-22.02/src/amfi_util/initfrac.f openmolcas-22.10/src/amfi_util/initfrac.f --- openmolcas-22.02/src/amfi_util/initfrac.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/initfrac.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,45 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine initfrac(nprimit1,nprimit2, - *nprimit3,nprimit4, - *quot1,quot2,expo1,expo2, - *expo3,expo4) -cbs initialize some arrays with factors needed for cfunct(x) - implicit real*8(a-h,o-z) - dimension expo1(*),expo2(*),expo3(*),expo4(*), - *quot1(nprimit1,nprimit2,nprimit3,nprimit4), - *quot2(nprimit1,nprimit2,nprimit3,nprimit4) - do irun4=1,nprimit4 - do irun3=1,nprimit3 - do irun2=1,nprimit2 - sum24=expo2(irun2)+expo4(irun4) - do irun1=1,nprimit1 - quot1(irun1,irun2,irun3,irun4)= - * 1d0/(1d0+(expo1(irun1)+expo3(irun3))/ - * sum24) - enddo - enddo - enddo - enddo - do irun4=1,nprimit4 - do irun3=1,nprimit3 - do irun2=1,nprimit2 - sum24=expo2(irun2)+expo4(irun4) - do irun1=1,nprimit1 - quot2(irun1,irun2,irun3,irun4)= - * 1d0/(1d0+sum24/ - * (expo1(irun1)+expo3(irun3))) - enddo - enddo - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/initfrac.F90 openmolcas-22.10/src/amfi_util/initfrac.F90 --- openmolcas-22.02/src/amfi_util/initfrac.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/initfrac.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,44 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine initfrac(nprimit1,nprimit2,nprimit3,nprimit4,quot1,quot2,expo1,expo2,expo3,expo4) +!bs initialize some arrays with factors needed for cfunct(x) + +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nprimit1, nprimit2, nprimit3, nprimit4 +real(kind=wp), intent(out) :: quot1(nprimit1,nprimit2,nprimit3,nprimit4), quot2(nprimit1,nprimit2,nprimit3,nprimit4) +real(kind=wp), intent(in) :: expo1(*), expo2(*), expo3(*), expo4(*) +integer(kind=iwp) :: irun2, irun3, irun4 +real(kind=wp) :: sum24 + +do irun4=1,nprimit4 + do irun3=1,nprimit3 + do irun2=1,nprimit2 + sum24 = expo2(irun2)+expo4(irun4) + quot1(1:nprimit1,irun2,irun3,irun4) = One/(One+(expo1(1:nprimit1)+expo3(irun3))/sum24) + end do + end do +end do +do irun4=1,nprimit4 + do irun3=1,nprimit3 + do irun2=1,nprimit2 + sum24 = expo2(irun2)+expo4(irun4) + quot2(1:nprimit1,irun2,irun3,irun4) = One/(One+sum24/(expo1(1:nprimit1)+expo3(irun3))) + end do + end do +end do + +return + +end subroutine initfrac diff -Nru openmolcas-22.02/src/amfi_util/initired.f openmolcas-22.10/src/amfi_util/initired.f --- openmolcas-22.02/src/amfi_util/initired.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/initired.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,350 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine initired - implicit real*8 (a-h,o-z) -cbs initialize all information for ireducible representations -cbs later on, it might be useful to have a switch for -cbs changing to other orders of IREDs like e.g. in TURBOMOLE -c -c -c HOW2ADD another symmetry: -c -c 1. add it in readbas.f to be accepted. Add the number of IRs -c -c 2. copy one of the symmetry-blocks in this subroutine and -c edit the multiplication-table for the group -c -c 3. assign the right IRs to L_X, L_Y and L_Z -c -c that is all. Good luck!!! -c -#include "para.fh" -#include "ired.fh" - character*3 symmetry - symmetry='D2H' ! MOLCAS-Version - if (symmetry.eq.'D2H') then - mult(2,1)=2 - mult(3,1)=3 - mult(4,1)=4 - mult(5,1)=5 - mult(6,1)=6 - mult(7,1)=7 - mult(8,1)=8 -c - mult(3,2)=4 - mult(4,2)=3 - mult(5,2)=6 - mult(6,2)=5 - mult(7,2)=8 - mult(8,2)=7 -c - mult(4,3)=2 - mult(5,3)=7 - mult(6,3)=8 - mult(7,3)=5 - mult(8,3)=6 -c - mult(5,4)=8 - mult(6,4)=7 - mult(7,4)=6 - mult(8,4)=5 -c - mult(6,5)=2 - mult(7,5)=3 - mult(8,5)=4 -c - mult(7,6)=4 - mult(8,6)=3 -c - mult(8,7)=2 -c -C - do ired=1,8 - mult(ired,ired)=1 - enddo - do irun=2,8 - do jrun=1,irun-1 - mult(jrun,irun)=mult(irun,jrun) - enddo - enddo -CBS write(6,*) -CBS write(6,*) -CBS *'multiplicitation table (atkins,child and phillips)' -CBS write(6,*) -CBS do ired=1,8 -CBS write(6,'(8I5)') (mult(jred,ired),jred=1,8) -CBS write(6,*) -CBS enddo - -c - IRLX=4 - IRLY=3 - IRLZ=2 -cbs assume same order of ireds as Atkins Child and Phillips use.. -cbs would lead to an order with 1 to 1, 2 to 2 ... -cbs however, this is the molecule/ seward order. - iredorder(1)=1 - iredorder(2)=4 - iredorder(3)=6 - iredorder(4)=7 - iredorder(5)=8 - iredorder(6)=5 - iredorder(7)=3 - iredorder(8)=2 - do ired=1,8 - iredorderinv(iredorder(ired))=ired - enddo - ipow2ired(0,0,0)=iredorder(1) - ipow2ired(1,1,0)=iredorder(2) - ipow2ired(1,0,1)=iredorder(3) - ipow2ired(0,1,1)=iredorder(4) - ipow2ired(1,1,1)=iredorder(5) - ipow2ired(0,0,1)=iredorder(6) - ipow2ired(0,1,0)=iredorder(7) - ipow2ired(1,0,0)=iredorder(8) -c write(6,*) 'interacting IRs ' - do ired=1,8 - IRwithLX(ired)= - *iredorder(mult(IRLX,iredorderinv(ired))) - IRwithLY(ired)= - *iredorder(mult(IRLY,iredorderinv(ired))) - IRwithLZ(ired)= - *iredorder(mult(IRLZ,iredorderinv(ired))) -c write(6,*) IRwithLX(ired),IRwithLY(ired), -c *IRwithLZ(ired) - enddo - elseif(symmetry.eq.'C2V') then -cbs 1. A1 2. A2 3. B1 4. B2 - mult(2,1)=2 - mult(3,1)=3 - mult(4,1)=4 -c - mult(3,2)=4 - mult(4,2)=3 -c - mult(4,3)=2 -C - do ired=1,4 - mult(ired,ired)=1 - enddo - do irun=2,4 - do jrun=1,irun-1 - mult(jrun,irun)=mult(irun,jrun) - enddo - enddo - write(6,*) - write(6,*) - *'multiplicitation table ' - write(6,*) - do ired=1,4 - write(6,'(4I5)') (mult(jred,ired),jred=1,4) - write(6,*) - enddo - -c - IRLX=4 - IRLY=3 - IRLZ=2 -cbs this is the molecule/ seward order. - iredorder(1)=1 - iredorder(2)=4 - iredorder(3)=2 - iredorder(4)=3 - do ired=1,4 - iredorderinv(iredorder(ired))=ired - enddo - ipow2ired(0,0,0)=iredorder(1) - ipow2ired(1,1,0)=iredorder(2) - ipow2ired(1,0,1)=iredorder(3) - ipow2ired(0,1,1)=iredorder(4) - ipow2ired(1,1,1)=iredorder(2) - ipow2ired(0,0,1)=iredorder(1) - ipow2ired(0,1,0)=iredorder(4) - ipow2ired(1,0,0)=iredorder(3) -c write(6,*) 'interacting IRs ' - do ired=1,4 - IRwithLX(ired)= - *iredorder(mult(IRLX,iredorderinv(ired))) - IRwithLY(ired)= - *iredorder(mult(IRLY,iredorderinv(ired))) - IRwithLZ(ired)= - *iredorder(mult(IRLZ,iredorderinv(ired))) -c write(6,*) IRwithLX(ired),IRwithLY(ired), -c *IRwithLZ(ired) - enddo - elseif(symmetry.eq.'D2 ') then -cbs 1. A1 2. B1 3. B2 4. B3 - mult(2,1)=2 - mult(3,1)=3 - mult(4,1)=4 -c - mult(3,2)=4 - mult(4,2)=3 - mult(4,3)=2 -C - do ired=1,4 - mult(ired,ired)=1 - enddo - do irun=2,4 - do jrun=1,irun-1 - mult(jrun,irun)=mult(irun,jrun) - enddo - enddo - write(6,*) - write(6,*) - *'multiplicitation table ' - write(6,*) - do ired=1,4 - write(6,'(4I5)') (mult(jred,ired),jred=1,4) - write(6,*) - enddo - -c - IRLX=4 - IRLY=3 - IRLZ=2 - iredorder(1)=1 - iredorder(2)=2 - iredorder(3)=3 - iredorder(4)=4 - do ired=1,4 - iredorderinv(iredorder(ired))=ired - enddo - ipow2ired(0,0,0)=iredorder(1) - ipow2ired(1,1,0)=iredorder(2) - ipow2ired(1,0,1)=iredorder(3) - ipow2ired(0,1,1)=iredorder(4) - ipow2ired(1,1,1)=iredorder(1) - ipow2ired(0,0,1)=iredorder(2) - ipow2ired(0,1,0)=iredorder(3) - ipow2ired(1,0,0)=iredorder(4) -c write(6,*) 'interacting IRs ' - do ired=1,4 - IRwithLX(ired)= - *iredorder(mult(IRLX,iredorderinv(ired))) - IRwithLY(ired)= - *iredorder(mult(IRLY,iredorderinv(ired))) - IRwithLZ(ired)= - *iredorder(mult(IRLZ,iredorderinv(ired))) -c write(6,*) IRwithLX(ired),IRwithLY(ired), -c *IRwithLZ(ired) - enddo - elseif(symmetry.eq.'C2H') then -cbs assume 1.Ag 2.Au 3.Bg 4.Bu - mult(2,1)=2 - mult(3,1)=3 - mult(4,1)=4 -c - mult(3,2)=4 - mult(4,2)=3 -c - mult(4,3)=2 -C - do ired=1,4 - mult(ired,ired)=1 - enddo - do irun=2,4 - do jrun=1,irun-1 - mult(jrun,irun)=mult(irun,jrun) - enddo - enddo - write(6,*) - write(6,*) - *'multiplicitation table ' - write(6,*) - do ired=1,4 - write(6,'(4I5)') (mult(jred,ired),jred=1,4) - write(6,*) - enddo - -c - IRLX=3 - IRLY=3 - IRLZ=1 - iredorder(1)=1 - iredorder(2)=2 - iredorder(3)=3 - iredorder(4)=4 - do ired=1,4 - iredorderinv(iredorder(ired))=ired - enddo - ipow2ired(0,0,0)=iredorder(1) - ipow2ired(1,1,0)=iredorder(1) - ipow2ired(1,0,1)=iredorder(3) - ipow2ired(0,1,1)=iredorder(3) - ipow2ired(1,1,1)=iredorder(2) - ipow2ired(0,0,1)=iredorder(2) - ipow2ired(0,1,0)=iredorder(4) - ipow2ired(1,0,0)=iredorder(4) -c write(6,*) 'interacting IRs ' - do ired=1,4 - IRwithLX(ired)= - *iredorder(mult(IRLX,iredorderinv(ired))) - IRwithLY(ired)= - *iredorder(mult(IRLY,iredorderinv(ired))) - IRwithLZ(ired)= - *iredorder(mult(IRLZ,iredorderinv(ired))) -c write(6,*) IRwithLX(ired),IRwithLY(ired), -c *IRwithLZ(ired) - enddo - elseif(symmetry.eq.'CS ') then - write(6,*) 'CS in initired ' -cbs assume 1.A' 2.A' - mult(2,1)=2 -C - do ired=1,2 - mult(ired,ired)=1 - enddo - do irun=2,2 - do jrun=1,irun-1 - mult(jrun,irun)=mult(irun,jrun) - enddo - enddo - write(6,*) - write(6,*) - *'multiplicitation table ' - write(6,*) - do ired=1,2 - write(6,'(2I5)') (mult(jred,ired),jred=1,2) - write(6,*) - enddo - -c - IRLX=2 - IRLY=2 - IRLZ=1 - iredorder(1)=1 - iredorder(2)=2 - do ired=1,2 - iredorderinv(iredorder(ired))=ired - enddo - ipow2ired(0,0,0)=iredorder(1) - ipow2ired(1,1,0)=iredorder(1) - ipow2ired(1,0,1)=iredorder(2) - ipow2ired(0,1,1)=iredorder(2) - ipow2ired(1,1,1)=iredorder(2) - ipow2ired(0,0,1)=iredorder(2) - ipow2ired(0,1,0)=iredorder(1) - ipow2ired(1,0,0)=iredorder(1) -c write(6,*) 'interacting IRs ' - do ired=1,2 - IRwithLX(ired)= - *iredorder(mult(IRLX,iredorderinv(ired))) - IRwithLY(ired)= - *iredorder(mult(IRLY,iredorderinv(ired))) - IRwithLZ(ired)= - *iredorder(mult(IRLZ,iredorderinv(ired))) -c write(6,*) IRwithLX(ired),IRwithLY(ired), -c *IRwithLZ(ired) - enddo - endif - return - end diff -Nru openmolcas-22.02/src/amfi_util/initired.F90 openmolcas-22.10/src/amfi_util/initired.F90 --- openmolcas-22.02/src/amfi_util/initired.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/initired.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,211 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine initired(symmetry) +!bs initialize all information for irreducible representations +!bs later on, it might be useful to have a switch for +!bs changing to other orders of IREDs like e.g. in TURBOMOLE +! +! HOW2ADD another symmetry: +! +! 1. add it in readbas to be accepted. Add the number of IRs +! +! 2. copy one of the symmetry-blocks in this subroutine and +! edit the nired for the group +! +! 3. assign the right IRs to L_X, L_Y and L_Z +! +! that is all. Good luck!!! + +use AMFI_global, only: ipow2ired +use Symmetry_Info, only: Mul +use Definitions, only: iwp, u6 + +implicit none +character(len=3), intent(in) :: symmetry +integer(kind=iwp) :: ired, iredorder(8), jred, nired +character(len=5) :: frmt + +nired = 0 + +select case (symmetry) + + case ('D2H') ! MOLCAS-Version + nired = 8 + !BS write(u6,*) + !BS write(u6,*) 'multiplication table (Atkins,Child and Phillips)' + !BS write(u6,*) + !BS write(frmt,'("(",I1,"I5)")') nired + !BS do ired=1,nired + !BS write(u6,frmt) (Mul(jred,ired),jred=1,nired) + !BS write(u6,*) + !BS end do + + !IRLX = 4 + !IRLY = 3 + !IRLZ = 2 + !bs assume same order of ireds as Atkins Child and Phillips use.. + !bs would lead to an order with 1 to 1, 2 to 2 ... + !bs however, this is the molecule/ seward order. + iredorder(1) = 1 + iredorder(2) = 4 + iredorder(3) = 6 + iredorder(4) = 7 + iredorder(5) = 8 + iredorder(6) = 5 + iredorder(7) = 3 + iredorder(8) = 2 + !bs irreducible representation of the cartesian functions in D2H + !bs order taken from Tables for Group theory: + !bs Atkins, Child and Phillips Oxford University Press 1970 + !bs 1. AG: only even powers (0,0,0) + !bs 2. B1G: (1,1,0) L_z + !bs 3. B2G: (1,0,1) L_y + !bs 4. B3G: (0,1,1) L_x + !bs 5. AU: (1,1,1) + !bs 6. B1U: (0,0,1) + !bs 7. B2U: (0,1,0) + !bs 8. B3U: (1,0,0) + ipow2ired(0,0,0) = iredorder(1) + ipow2ired(1,1,0) = iredorder(2) + ipow2ired(1,0,1) = iredorder(3) + ipow2ired(0,1,1) = iredorder(4) + ipow2ired(1,1,1) = iredorder(5) + ipow2ired(0,0,1) = iredorder(6) + ipow2ired(0,1,0) = iredorder(7) + ipow2ired(1,0,0) = iredorder(8) + + case ('C2V') + nired = 4 + !bs 1. A1 2. A2 3. B1 4. B2 + write(u6,*) + write(u6,*) 'multiplication table ' + write(u6,*) + write(frmt,'("(",I1,"I5)")') nired + do ired=1,nired + write(u6,frmt) (Mul(jred,ired),jred=1,nired) + write(u6,*) + end do + + !IRLX = 4 + !IRLY = 3 + !IRLZ = 2 + !bs this is the molecule/seward order. + iredorder(1) = 1 + iredorder(2) = 4 + iredorder(3) = 2 + iredorder(4) = 3 + ipow2ired(0,0,0) = iredorder(1) + ipow2ired(1,1,0) = iredorder(2) + ipow2ired(1,0,1) = iredorder(3) + ipow2ired(0,1,1) = iredorder(4) + ipow2ired(1,1,1) = iredorder(2) + ipow2ired(0,0,1) = iredorder(1) + ipow2ired(0,1,0) = iredorder(4) + ipow2ired(1,0,0) = iredorder(3) + + case ('D2 ') + nired = 4 + !bs 1. A1 2. B1 3. B2 4. B3 + write(u6,*) + write(u6,*) 'multiplication table ' + write(u6,*) + write(frmt,'("(",I1,"I5)")') nired + do ired=1,nired + write(u6,frmt) (Mul(jred,ired),jred=1,nired) + write(u6,*) + end do + + !IRLX = 4 + !IRLY = 3 + !IRLZ = 2 + iredorder(1) = 1 + iredorder(2) = 2 + iredorder(3) = 3 + iredorder(4) = 4 + ipow2ired(0,0,0) = iredorder(1) + ipow2ired(1,1,0) = iredorder(2) + ipow2ired(1,0,1) = iredorder(3) + ipow2ired(0,1,1) = iredorder(4) + ipow2ired(1,1,1) = iredorder(1) + ipow2ired(0,0,1) = iredorder(2) + ipow2ired(0,1,0) = iredorder(3) + ipow2ired(1,0,0) = iredorder(4) + + case ('C2H') + nired = 4 + !bs assume 1.Ag 2.Au 3.Bg 4.Bu + write(u6,*) + write(u6,*) 'multiplication table ' + write(u6,*) + write(frmt,'("(",I1,"I5)")') nired + do ired=1,nired + write(u6,frmt) (Mul(jred,ired),jred=1,nired) + write(u6,*) + end do + + !IRLX = 3 + !IRLY = 3 + !IRLZ = 1 + iredorder(1) = 1 + iredorder(2) = 2 + iredorder(3) = 3 + iredorder(4) = 4 + ipow2ired(0,0,0) = iredorder(1) + ipow2ired(1,1,0) = iredorder(1) + ipow2ired(1,0,1) = iredorder(3) + ipow2ired(0,1,1) = iredorder(3) + ipow2ired(1,1,1) = iredorder(2) + ipow2ired(0,0,1) = iredorder(2) + ipow2ired(0,1,0) = iredorder(4) + ipow2ired(1,0,0) = iredorder(4) + + case ('CS ') + nired = 2 + !bs assume 1.A' 2.A' + write(u6,*) + write(u6,*) 'multiplication table ' + write(u6,*) + write(frmt,'("(",I1,"I5)")') nired + do ired=1,nired + write(u6,frmt) (Mul(jred,ired),jred=1,nired) + write(u6,*) + end do + + !IRLX = 2 + !IRLY = 2 + !IRLZ = 1 + iredorder(1) = 1 + iredorder(2) = 2 + ipow2ired(0,0,0) = iredorder(1) + ipow2ired(1,1,0) = iredorder(1) + ipow2ired(1,0,1) = iredorder(2) + ipow2ired(0,1,1) = iredorder(2) + ipow2ired(1,1,1) = iredorder(2) + ipow2ired(0,0,1) = iredorder(2) + ipow2ired(0,1,0) = iredorder(1) + ipow2ired(1,0,0) = iredorder(1) +end select + +!write(u6,*) 'interacting IRs ' +!do ired=1,nired +! iredorderinv(iredorder(ired)) = ired +!end do +!do ired=1,nired +! IRwithLX(ired) = iredorder(Mul(IRLX,iredorderinv(ired))) +! IRwithLY(ired) = iredorder(Mul(IRLY,iredorderinv(ired))) +! IRwithLZ(ired) = iredorder(Mul(IRLZ,iredorderinv(ired))) +! !write(u6,*) IRwithLX(ired),IRwithLY(ired),IRwithLZ(ired) +!end do + +return + +end subroutine initired diff -Nru openmolcas-22.02/src/amfi_util/ipowxyz.fh openmolcas-22.10/src/amfi_util/ipowxyz.fh --- openmolcas-22.02/src/amfi_util/ipowxyz.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/ipowxyz.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,15 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -cbs the following array includes information about -cbs odd powers of x y z in the real harmonics -cbs this is used to check whether integrals in the -cbs cartesian representation appear - common /ipowxyz/ ipowxyz(3,-Lmax:Lmax,0:Lmax) diff -Nru openmolcas-22.02/src/amfi_util/ired.fh openmolcas-22.10/src/amfi_util/ired.fh --- openmolcas-22.02/src/amfi_util/ired.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/ired.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,46 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -cbs irreducible representation of the cartesian functions in D2H -cbs order taken from Tables for Group theory: -cbs Atkins, Child and Phillips Oxford University Press 1970 -cbs 1. AG: only even powers (0,0,0) -cbs 2. B1G: (1,1,0) L_z -cbs 3. B2G: (1,0,1) L_y -cbs 4. B3G: (0,1,1) L_x -cbs 5. AU: (1,1,1) -cbs 6. B1U: (0,0,1) -cbs 7. B2U: (0,1,0) -cbs 8. B3U: (1,0,0) - integer ipow2ired,iredorder,incrLM,shiftIRED,shiftIRIR - common /ireduceD2H/ numbofsym, ! number of symmetries - *ipow2ired(0:1,0:1,0:1),! gives IR by checking powers - *iredorder(8), ! maybe reordering of IRs is necessary - *iredorderinv(8), - *nfunctions(8,0:Lmax), !number of functions per L and IR - *nfunctperIRED(8), ! number of functions per IR - *incrLM(-Lmax:Lmax,0:Lmax), ! shift of orbitalnumber in IR for L,M - *shiftIRED(8), -c !shift to get to absolute number from relative number in IR - *iredLM(-Lmax:Lmax,0:Lmax), ! IR for L and M - *shiftIRIR(36), ! shift for (IR1,IR2)-block (IR1<=IR2) - *Loffunction(Mxcart), !gives L value of cartesian function - *Moffunction(Mxcart), !gives M value of cartesian function - *Iredoffunction(Mxcart),! give IRED of cartesian function - *Iredoffunctnew(Mxcart), -c ! give IRED of cartesian function incl. add. functions - *IRwithLX(8), ! gives IR interacting by L_X - *IRwithLY(8), ! gives IR interacting by L_y - *IRwithLZ(8), ! gives IR interacting by L_z - *mult(8,8), - *itotalperIR(8), ! total number of functions per IR - *nmbMperIRL(8,0:Lmax), !number of M-values in an IR for an L-value - *numbofcart ! number of cartesian functions -cbs diff -Nru openmolcas-22.02/src/amfi_util/kindiag.f openmolcas-22.10/src/amfi_util/kindiag.f --- openmolcas-22.02/src/amfi_util/kindiag.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/kindiag.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine kindiag(TKIN,TKINTRIA,ndim,evec,eval,breit) - implicit real*8 (a-h,o-z) -cbs determines eigenvectors and -values of TKIN - dimension tkin(ndim,ndim), - *TKINTRIA((ndim*ndim+ndim)/2),eval(ndim),evec(ndim,ndim) - logical breit -cbs move symmetric matrix to triangular matrix - itria=1 - do irun2=1,ndim - do irun1=1,irun2 - TKINTRIA(itria)=TKIN(irun1,irun2) - itria=itria+1 - enddo - enddo - do irun2=1,ndim - do irun1=1,ndim - evec(irun1,irun2)=0d0 - enddo - enddo - do irun1=1,ndim - evec(irun1,irun1)=1d0 - enddo -cbs now diagonalize - CALL Jacob(TKINTRIA,evec,ndim,ndim) -cbs get the eigenvalues - do irun=1,ndim - eval(irun)=TKINTRIA((irun*irun+irun)/2) - enddo - if (breit) then - do irun=1,ndim - eval(irun)=0d0 - enddo - endif -cbs ensure normalization of the vectors. - do IRUN=1,ndim - fact=0d0 - do JRUN=1,ndim - fact=fact+evec(JRUN,IRUN)*evec(JRUN,IRUN) - enddo - fact=1d0/sqrt(fact) - do JRUN=1,ndim - evec(JRUN,IRUN)=fact*evec(JRUN,IRUN) - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/kindiag.F90 openmolcas-22.10/src/amfi_util/kindiag.F90 --- openmolcas-22.02/src/amfi_util/kindiag.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/kindiag.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,65 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine kindiag(TKIN,ndim,evec,eval,breit) +!bs determines eigenvectors and -values of TKIN + +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: ndim +real(kind=wp), intent(in) :: tkin(ndim,ndim) +real(kind=wp), intent(out) :: evec(ndim,ndim), eval(ndim) +logical(kind=iwp), intent(in) :: breit +integer(kind=iwp) :: irun, irun1, irun2, itria, JRUN +real(kind=wp) :: fact +real(kind=wp), allocatable :: TKINTRIA(:) + +call mma_allocate(TKINTRIA,ndim*(ndim+1)/2,label='TKINTRIA') + +!bs move symmetric matrix to triangular matrix +itria = 1 +do irun2=1,ndim + do irun1=1,irun2 + TKINTRIA(itria) = TKIN(irun1,irun2) + itria = itria+1 + end do +end do +evec(:,:) = Zero +do irun1=1,ndim + evec(irun1,irun1) = One +end do +!bs now diagonalize +call Jacob(TKINTRIA,evec,ndim,ndim) +!bs get the eigenvalues +if (breit) then + eval(:) = Zero +else + do irun=1,ndim + eval(irun) = TKINTRIA(irun*(irun+1)/2) + end do +end if +call mma_deallocate(TKINTRIA) +!bs ensure normalization of the vectors. +do IRUN=1,ndim + fact = Zero + do JRUN=1,ndim + fact = fact+evec(JRUN,IRUN)*evec(JRUN,IRUN) + end do + fact = One/sqrt(fact) + evec(:,IRUN) = fact*evec(:,IRUN) +end do + +return + +end subroutine kindiag diff -Nru openmolcas-22.02/src/amfi_util/kinemat.f openmolcas-22.10/src/amfi_util/kinemat.f --- openmolcas-22.02/src/amfi_util/kinemat.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/kinemat.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,45 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine kinemat(L,ndim,evtkin,type1,type2,Energy) - implicit real*8 (a-h,o-z) - parameter (fine=7.29735308D-03) !TO_BE_CHECKED -cbs at least it's identical with Odd's valuE - parameter (speed=1d0/fine) - parameter (speed2=speed*speed) - parameter (speed4=speed2*speed2) -cbs this routine generates the kinematic A-factors=sqrt((E+mc^2)/(2E)) -cbs (type1) and c*A/(E+mc^2) (type2) -cbs The c in the second kinematic factor comes from Jan Almloef and -cbs Odd Gropen in Rev in Comp.Chem. 8(1996) - dimension evtkin(*),type1(*),type2(*),Energy(*) -c E= sqrt(p**2 c**2 + m**2 c**4) -c p**2= 2*m*TKIN -c with m = 1 - do Irun=1,ndim - if (evtkin(Irun).lt.0.0D0) call SysAbendMsg('kinemat', - & 'strange kinetic energy ',' ') - Energy(Irun)=(evtkin(Irun)+evtkin(Irun))*speed2+speed4 - enddo - do Irun=1,ndim - Energy(Irun)=sqrt(energy(irun)) - enddo - do Irun=1,ndim -! sqrt((E+mc^2)/(2E)): - type1(Irun)=sqrt(0.5d0*(1d0+speed2/Energy(Irun))) - enddo -! c*A/(E+mc^2) - do Irun=1,ndim - type2(Irun)=speed*type1(Irun)/(Energy(Irun)+speed2) - enddo - return -c Avoid unused argument warnings - if (.false.) call Unused_integer(L) - end diff -Nru openmolcas-22.02/src/amfi_util/kinemat.F90 openmolcas-22.10/src/amfi_util/kinemat.F90 --- openmolcas-22.02/src/amfi_util/kinemat.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/kinemat.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,42 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine kinemat(ndim,evtkin,type1,type2,Energy) +!bs this routine generates the kinematic A-factors=sqrt((E+mc^2)/(2E)) +!bs (type1) and c*A/(E+mc^2) (type2) +!bs The c in the second kinematic factor comes from Jan Almloef and +!bs Odd Gropen in Rev in Comp.Chem. 8(1996) + +use Constants, only: Zero, One, Half, speed => c_in_au +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: ndim +real(kind=wp), intent(in) :: evtkin(ndim) +real(kind=wp), intent(out) :: type1(ndim), type2(ndim), Energy(ndim) +integer(kind=iwp) :: irun +real(kind=wp), parameter :: fine = One/speed, speed2 = speed**2, speed4 = speed2**2 + +! E= sqrt(p**2 c**2 + m**2 c**4) +! p**2= 2*m*TKIN +! with m = 1 +do irun=1,ndim + if (evtkin(irun) < Zero) call SysAbendMsg('kinemat','strange kinetic energy ',' ') + Energy(irun) = sqrt((evtkin(irun)+evtkin(irun))*speed2+speed4) +end do +! sqrt((E+mc^2)/(2E)): +type1(:) = sqrt(Half*(One+speed2/Energy(:))) +! c*A/(E+mc^2) +type2(:) = speed*type1(:)/(Energy(:)+speed2) + +return + +end subroutine kinemat diff -Nru openmolcas-22.02/src/amfi_util/lmdepang.f openmolcas-22.10/src/amfi_util/lmdepang.f --- openmolcas-22.02/src/amfi_util/lmdepang.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/lmdepang.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,51 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1996, Bernd Schimmelpfennig * -************************************************************************ - REAL*8 function LMdepang( - *L,M,l1,l2,l3,l4,m1,m2,m3,m4,cheater) -cbs l1-l4 and m1-m4 are already shifted !! -cbs purpose: calculates the angular part of the -cbs coulomb-type integrals. See documentation for details... -cbs LMdepang= LM dependent angular factors -cbs cheater included for a correcting signs, as there were some -cbs signs (only signs!!!!) missing when compared to HERMIT -cbs B.S. 08.10.96 - implicit REAL*8 (a-h,o-z) -#include "real.fh" - LMdepang=0d0 -cbs some quick checks - if (L.lt.abs(M)) return - if (l1.lt.abs(m1)) return - if (l2.lt.abs(m2)) return - if (l3.lt.abs(m3)) return - if (l4.lt.abs(m4)) return -cbs prefactor - fact1=4d0*pi/DBLE(L+L+1) -cbs determining the sign - isum=-l3-l1-l4-l2+2*(M+m3+m4) !???? I am not sure - if (mod(isum,4).eq.0) then - isign=1 - elseif (iabs(mod(isum,4)).eq.2) then - isign=-1 - else - isign=0 - write(6,*) 'L,l1,l2,l3,l4,M,m1,m2,m3,m4' - write(6,'(10I3)') L,l1,l2,l3,l4,M,m1,m2,m3,m4 - write(6,*) 'isum= ',isum,' mod = ',mod(isum,4) - Call SysHalt( 'lmdepang' ) - endif - fact2=couple3J(L,l3,l1,-M,m3,-m1) - fact3=couple3J(L,l4,l2,M,m4,-m2) -C write(6,*) 'fact2,fact3 ',fact2,fact3 - LMdepang=cheater*DBLE(isign)*fact1*fact2*fact3 - return - end diff -Nru openmolcas-22.02/src/amfi_util/lmdepang.F90 openmolcas-22.10/src/amfi_util/lmdepang.F90 --- openmolcas-22.02/src/amfi_util/lmdepang.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/lmdepang.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,63 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1996, Bernd Schimmelpfennig * +!*********************************************************************** + +function LMdepang(L,M,l1,l2,l3,l4,m1,m2,m3,m4,cheater) +!bs l1-l4 and m1-m4 are already shifted !! +!bs purpose: calculates the angular part of the +!bs coulomb-type integrals. See documentation for details... +!bs LMdepang= LM dependent angular factors +!bs cheater included for a correcting signs, as there were some +!bs signs (only signs!!!!) missing when compared to HERMIT +!bs B.S. 08.10.96 + +use Constants, only: Zero, One, Four, Pi +use Definitions, only: wp, iwp, u6 + +implicit none +real(kind=wp) :: LMdepang +integer(kind=iwp), intent(in) :: L, M, l1, l2, l3, l4, m1, m2, m3, m4 +real(kind=wp), intent(in) :: cheater +integer(kind=iwp) :: isum +real(kind=wp) :: fact1, fact2, fact3, sgn +real(kind=wp), external :: couple3J + +LMdepang = Zero +!bs some quick checks +if (L < abs(M)) return +if (l1 < abs(m1)) return +if (l2 < abs(m2)) return +if (l3 < abs(m3)) return +if (l4 < abs(m4)) return +!bs prefactor +fact1 = Four*Pi/real(L+L+1,wp) +!bs determining the sign +isum = -l3-l1-l4-l2+2*(M+m3+m4) !???? I am not sure +if (mod(isum,4) == 0) then + sgn = One +else if (abs(mod(isum,4)) == 2) then + sgn = -One +else + sgn = Zero + write(u6,*) 'L,l1,l2,l3,l4,M,m1,m2,m3,m4' + write(u6,'(10I3)') L,l1,l2,l3,l4,M,m1,m2,m3,m4 + write(u6,*) 'isum= ',isum,' mod = ',mod(isum,4) + call SysHalt('lmdepang') +end if +fact2 = couple3J(L,l3,l1,-M,m3,-m1) +fact3 = couple3J(L,l4,l2,M,m4,-m2) +!write(6,*) 'fact2,fact3 ',fact2,fact3 +LMdepang = cheater*sgn*fact1*fact2*fact3 + +return + +end function LMdepang diff -Nru openmolcas-22.02/src/amfi_util/mcheckxy.f openmolcas-22.10/src/amfi_util/mcheckxy.f --- openmolcas-22.02/src/amfi_util/mcheckxy.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/mcheckxy.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - integer function mcheckxy(m1,m2,m3,m4) - integer m1,m2,m3,m4,int12a,int12b, - *int34a,int34b -cbs makes a check, if there is an interaction inbetween cartesian functions -cbs with m-values m1-m4 - mcheckxy=1 - int12a=m1+m2 - int12b=-m1+m2 - int34a=m3+m4 - int34b=-m3+m4 -cbs lots of checks - if (iabs(int12a+int34a).eq.1) return - if (iabs(int12a-int34a).eq.1) return - if (iabs(int12b+int34b).eq.1) return - if (iabs(int12b-int34b).eq.1) return - if (iabs(int12a+int34b).eq.1) return - if (iabs(int12a-int34b).eq.1) return - if (iabs(int12b+int34a).eq.1) return - if (iabs(int12b-int34a).eq.1) return - mcheckxy=0 - return - end diff -Nru openmolcas-22.02/src/amfi_util/mcheckxy.F90 openmolcas-22.10/src/amfi_util/mcheckxy.F90 --- openmolcas-22.02/src/amfi_util/mcheckxy.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/mcheckxy.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,41 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +function mcheckxy(m1,m2,m3,m4) +!bs makes a check, if there is an interaction inbetween cartesian functions +!bs with m-values m1-m4 + +use Definitions, only: iwp + +implicit none +integer(kind=iwp) :: mcheckxy +integer(kind=iwp), intent(in) :: m1, m2, m3, m4 +integer(kind=iwp) :: int12a, int12b, int34a, int34b + +mcheckxy = 1 +int12a = m1+m2 +int12b = -m1+m2 +int34a = m3+m4 +int34b = -m3+m4 +!bs lots of checks +if (abs(int12a+int34a) == 1) return +if (abs(int12a-int34a) == 1) return +if (abs(int12b+int34b) == 1) return +if (abs(int12b-int34b) == 1) return +if (abs(int12a+int34b) == 1) return +if (abs(int12a-int34b) == 1) return +if (abs(int12b+int34a) == 1) return +if (abs(int12b-int34a) == 1) return +mcheckxy = 0 + +return + +end function mcheckxy diff -Nru openmolcas-22.02/src/amfi_util/mcheckz.f openmolcas-22.10/src/amfi_util/mcheckz.f --- openmolcas-22.02/src/amfi_util/mcheckz.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/mcheckz.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - integer function mcheckz(m1,m2,m3,m4) -cbs makes a check, if there is an interaction inbetween cartesian functions -cbs with m-values m1-m4 - integer m1,m2,m3,m4,int12a,int12b, - *int34a,int34b - mcheckz=1 - int12a=m1+m2 - int12b=-m1+m2 - int34a=m3+m4 - int34b=-m3+m4 -cbs lots of checks - if (iabs(int12a+int34a).eq.0) return - if (iabs(int12a-int34a).eq.0) return - if (iabs(int12b+int34b).eq.0) return - if (iabs(int12b-int34b).eq.0) return - if (iabs(int12a+int34b).eq.0) return - if (iabs(int12a-int34b).eq.0) return - if (iabs(int12b+int34a).eq.0) return - if (iabs(int12b-int34a).eq.0) return - mcheckz=0 - return - end diff -Nru openmolcas-22.02/src/amfi_util/mcheckz.F90 openmolcas-22.10/src/amfi_util/mcheckz.F90 --- openmolcas-22.02/src/amfi_util/mcheckz.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/mcheckz.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,41 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +function mcheckz(m1,m2,m3,m4) +!bs makes a check, if there is an interaction inbetween cartesian functions +!bs with m-values m1-m4 + +use Definitions, only: iwp + +implicit none +integer(kind=iwp) :: mcheckz +integer(kind=iwp), intent(in) :: m1, m2, m3, m4 +integer(kind=iwp) :: int12a, int12b, int34a, int34b + +mcheckz = 1 +int12a = m1+m2 +int12b = -m1+m2 +int34a = m3+m4 +int34b = -m3+m4 +!bs lots of checks +if (abs(int12a+int34a) == 0) return +if (abs(int12a-int34a) == 0) return +if (abs(int12b+int34b) == 0) return +if (abs(int12b-int34b) == 0) return +if (abs(int12a+int34b) == 0) return +if (abs(int12a-int34b) == 0) return +if (abs(int12b+int34a) == 0) return +if (abs(int12b-int34a) == 0) return +mcheckz = 0 + +return + +end function mcheckz diff -Nru openmolcas-22.02/src/amfi_util/mkangl0.f openmolcas-22.10/src/amfi_util/mkangl0.f --- openmolcas-22.02/src/amfi_util/mkangl0.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/mkangl0.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,654 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine mkangL0(Lmax,l1,l2,l3,l4,m1,m2,m3,m4, - *angintSO,angintOO, - *Lfirst,Llast,Lblocks, - *ncont1,ncont2,ncont3, - *ncont4, - *caseaSO,caseb1SO,caseb2SO,casecSO, - *caseaOO,caseb1OO,caseb2OO,casecOO, - *preroots,clebsch,dummy,bonn,breit, - *sameorb) - implicit real*8 (a-h,o-z) -cbs subroutine for combining radial integrals with angular -cbs factors for the block with l1,l2,l3,l4,m1,m2,m3m,m4 -cbs this routine mkangL0 = make angular factors for the L0-part -cbs includes both, spin-same and spin-other-orbit parts. - real*8 LMdepang - dimension - *angintSO(ncont1,ncont2,ncont3,ncont4), - *angintOO(ncont1,ncont2,ncont3,ncont4), - *Lfirst(*),Llast(*),Lblocks(*), -cbs all the arrays with the radial integrals for -cbs this combination of l-values - *caseaSO(ncont1*ncont2*ncont3*ncont4,*), -c ! (2,0) integrals with alpha1*alpha3 - *caseb1SO(ncont1*ncont2*ncont3*ncont4,*), -c ! (0,0) integrals with alpha1 - *caseb2SO(ncont1*ncont2*ncont3*ncont4,*), -c ! (0,0) integrals with alpha3 - *casecSO(ncont1*ncont2*ncont3*ncont4,*), -c ! (-2,0) integrals with factor 1 - *caseaOO(ncont1*ncont2*ncont3*ncont4,*), -c ! (2,0) integrals with alpha1*alpha3 - *caseb1OO(ncont1*ncont2*ncont3*ncont4,*), -c ! (0,0) integrals with alpha1 - *caseb2OO(ncont1*ncont2*ncont3*ncont4,*), -c ! (0,0) integrals with alpha3 - *casecOO(ncont1*ncont2*ncont3*ncont4,*), -c ! (-2,0) integrals with factor 1 - *preroots(2,0:Lmax), -c ! some prefactors: sqrt( (l(+1))/(2l+1)) - *clebsch(3,2,-Lmax:Lmax,0:Lmax) -c ! some clebsch gordans, that appear regulary - dimension dummy(0:*) - logical bonn,breiT,sameorb -c write(6,*) 'begin mkangL0 ', -c *l1,l2,l3,l4,m1,m2,m3,m4 -cbs - ncontall=ncont1*ncont2*ncont3*ncont4 -cbs cheater introduced to correct signs, because they were different from HERMIT - if (mod(l1+l2+l3+l4,4).eq.2) then - cheater=1d0 - else - cheater=-1d0 - endif -cbs cleaning up - if (bonn.or.breit.or.sameorb) then - call dzero(angintSO,ncontall) - else - call dzero(angintSO,ncontall) - call dzero(angintOO,ncontall) - endif -cbs starting with the same-orbit-contributions -cbs first term: ########################################################################### - factor=-preroots(2,l1)*preroots(2,l3)* - *clebsch(1,2,m1,l1)* - *clebsch(1,2,m3,l3) - if (factor.ne.0d0) then -cbs get the L,M dependent coefficients - if (Lblocks(1).gt.0) then - do I=0,Lmax+Lmax+1 - dummy(I)=0d0 - enddo - M=m2-m4 - Lrun=1 - do L=Lfirst(1),Llast(1),2 - dummy(L)=LMdepang(L,M,l1+1,l2,l3+1,l4,m1-1,m2,m3-1,m4,cheater) - if (dummy(L).ne.0d0) then - if (bonn.or.breit.or.sameorb) then - Call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall, - * 4.0D0*factor*dummy(L),CaseaOO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - endif -cbs second term: ########################################################################### - factor=-preroots(1,l1)*preroots(2,l3)* - *clebsch(1,1,m1,l1)* - *clebsch(1,2,m3,l3) - if (factor.ne.0d0) then - do I=0,Lmax+Lmax+1 - dummy(I)=0d0 - enddo - Klast=0 - Kfirst=Lmax+Lmax+1 ! just to be sure .. -cbs get the L,M dependent coefficients - if (Lblocks(1).gt.0) then - M=m2-m4 - Kfirst=Lfirst(1) - Klast=Llast(1) - Lrun=1 - do L=Lfirst(1),Llast(1),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1-1,m2,m3-1,m4,cheater) - if (dummy(L).ne.0d0) then - If (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,4.0D0*factor*dummy(L),caseaSO(1,Lrun),1, - * angintSO,1) - else - call daxpy_(ncontall,4.0D0*factor*dummy(L),caseaSO(1,Lrun),1, - * angintSO,1) - call daxpy_(ncontall, - * 4.0D0*factor*dummy(L),caseaOO(1,Lrun),1,AngintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - if (Lblocks(3).gt.0) then - M=m2-m4 - if (Lfirst(3).lt.Kfirst) then - do L=Lfirst(3),Kfirst,2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1-1,m2, - * m3-1,m4,cheater) - enddo - Kfirst=Lfirst(3) - endif - if (Llast(3).gt.Klast) then - do L=Klast,Llast(3),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1-1,m2, - * m3-1,m4,cheater) - enddo - Klast=Llast(3) - endif - Lrun=1 - do L=Lfirst(3),Llast(3),2 - if (dummy(L).ne.0d0) then - If (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,-DBLE(2+4*l1)*factor*dummy(L), - * caseb2SO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,-DBLE(2+4*l1)*factor*dummy(L), - * caseb2SO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall,-DBLE(2+4*l1)* - * factor*dummy(L),caseb2OO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - endif -cbs third term: ########################################################################### - factor=-preroots(2,l1)*preroots(1,l3)* - *clebsch(1,2,m1,l1)* - *clebsch(1,1,m3,l3) - if (factor.ne.0d0) then - do I=0,Lmax+Lmax+1 - dummy(I)=0d0 - enddo - Klast=0 - Kfirst=Lmax+Lmax+1 ! just to be sure .. -cbs get the L,M dependent coefficients - if (Lblocks(1).gt.0) then - M=m2-m4 - Kfirst=Lfirst(1) - Klast=Llast(1) - Lrun=1 - do L=Lfirst(1),Llast(1),2 - dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1-1,m2, - *m3-1,m4,cheater) - if (dummy(L).ne.0d0) then - If (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall, - * 4.0D0*factor*dummy(L),CaseaOO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - if (Lblocks(2).gt.0) then - M=m2-m4 - if (Lfirst(2).lt.Kfirst) then - do L=Lfirst(2),Kfirst,2 - dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1-1,m2, - * m3-1,m4,cheater) - enddo - Kfirst=Lfirst(2) - endif - if (Llast(2).gt.Klast) then - do L=Klast,Llast(2),2 - dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1-1,m2, - * m3-1,m4,cheater) - enddo - Klast=Llast(2) - endif - Lrun=1 - do L=Lfirst(2),Llast(2),2 - if (dummy(L).ne.0d0) then - If (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,-DBLE(2+4*l3)*factor*dummy(L), - * caseb1SO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,-DBLE(2+4*l3)*factor*dummy(L), - * caseb1SO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall, - * -DBLE(2+4*l3)*factor*dummy(L),caseb1OO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - endif -cbs fourth term: ########################################################################### - factor=-preroots(1,l1)*preroots(1,l3)* - *clebsch(1,1,m1,l1)* - *clebsch(1,1,m3,l3) - if (factor.ne.0d0) then - do I=0,Lmax+Lmax+1 - dummy(I)=0d0 - enddo - Klast=0 - Kfirst=Lmax+Lmax+1 ! just to be sure .. -cbs get the L,M dependent coefficients - if (Lblocks(1).gt.0) then - M=m2-m4 - Kfirst=Lfirst(1) - Klast=Llast(1) - Lrun=1 - do L=Lfirst(1),Llast(1),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2,m3-1,m4,cheater) - if (dummy(L).ne.0d0) then - If (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,4.0D0*factor*dummy(L),caseaSO(1,Lrun),1, - * angintSO,1) - else - call daxpy_(ncontall,4.0D0*factor*dummy(L),caseaSO(1,Lrun),1, - * angintSO,1) - call daxpy_(ncontall, - * 4.0D0*factor*dummy(L),caseaOO(1,Lrun),1,AngintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - if (Lblocks(2).gt.0) then - M=m2-m4 - if (Lfirst(2).lt.Kfirst) then - do L=Lfirst(2),Kfirst,2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2, - * m3-1,m4,cheater) - enddo - Kfirst=Lfirst(2) - endif - if (Llast(2).gt.Klast) then - do L=Klast,Llast(2),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2, - * m3-1,m4,cheater) - enddo - Klast=Llast(2) - endif - Lrun=1 - do L=Lfirst(2),Llast(2),2 - if (dummy(L).ne.0d0) then - If (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,-DBLE(2+4*l3)*factor*dummy(L), - * caseb1SO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,-DBLE(2+4*l3)*factor*dummy(L), - * caseb1SO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall, - * -DBLE(2+4*l3)*factor*dummy(L),caseb1OO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - if (Lblocks(3).gt.0) then - M=m2-m4 - if (Lfirst(3).lt.Kfirst) then - do L=Lfirst(3),Kfirst,2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2, - * m3-1,m4,cheater) - enddo - Kfirst=Lfirst(3) - endif - if (Llast(3).gt.Klast) then - do L=Klast,Llast(3),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2, - * m3-1,m4,cheater) - enddo - Klast=Llast(3) - endif - Lrun=1 - do L=Lfirst(3),Llast(3),2 - if (dummy(L).ne.0d0) then - If (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,-DBLE(2+4*l1)*factor*dummy(L), - * caseb2SO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,-DBLE(2+4*l1)*factor*dummy(L), - * caseb2SO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall, - * -DBLE(2+4*l1)*factor*dummy(L),caseb2OO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - if (Lblocks(4).gt.0) then - M=m2-m4 - if (Lfirst(4).lt.Kfirst) then - do L=Lfirst(4),Kfirst,2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2, - * m3-1,m4,cheater) - enddo - Kfirst=Lfirst(4) - endif - if (Llast(4).gt.Klast) then - do L=Klast,Llast(4),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2, - * m3-1,m4,cheater) - enddo - Klast=Llast(4) - endif - Lrun=1 - do L=Lfirst(4),Llast(4),2 - if (dummy(L).ne.0d0) then - If (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,DBLE(4*l1*l3+2*l1+2*l3+1)*factor*dummy(L), - * casecSO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,DBLE(4*l1*l3+2*l1+2*l3+1)*factor*dummy(L), - * casecSO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall, - * DBLE(4*l1*l3+2*l1+2*l3+1)*factor*dummy(L), - * casecOO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - endif -cbs fifth term: ########################################################################### - factor=preroots(2,l1)*preroots(2,l3)* - *clebsch(3,2,m1,l1)* - *clebsch(3,2,m3,l3) - if (factor.ne.0d0) then - do I=0,Lmax+Lmax+1 - dummy(I)=0d0 - enddo -cbs get the L,M dependent coefficients - if (Lblocks(1).gt.0) then - M=m2-m4 - Lrun=1 - do L=Lfirst(1),Llast(1),2 - dummy(L)=LMdepang(L,M,l1+1,l2,l3+1,l4,m1+1,m2,m3+1,m4,cheater) - if (dummy(L).ne.0d0) then - If (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,4.0D0*factor*dummy(L),caseaSO(1,Lrun),1, - * angintSO,1) - else - call daxpy_(ncontall,4.0D0*factor*dummy(L),caseaSO(1,Lrun),1, - * angintSO,1) - call daxpy_(ncontall, - * 4.0D0*factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - endif -cbs sixth term: ########################################################################### - factor=preroots(1,l1)*preroots(2,l3)* - *clebsch(3,1,m1,l1)* - *clebsch(3,2,m3,l3) - if (factor.ne.0d0) then - do I=0,Lmax+Lmax+1 - dummy(I)=0d0 - enddo - Klast=0 - Kfirst=Lmax+Lmax+1 ! just to be sure .. -cbs get the L,M dependent coefficients - if (Lblocks(1).gt.0) then - M=m2-m4 - Kfirst=Lfirst(1) - Klast=Llast(1) - Lrun=1 - do L=Lfirst(1),Llast(1),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1+1,m2,m3+1,m4,cheater) - if (dummy(L).ne.0d0) then - If (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall, - * 4.0D0*factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - if (Lblocks(3).gt.0) then - M=m2-m4 - if (Lfirst(3).lt.Kfirst) then - do L=Lfirst(3),Kfirst,2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1+1,m2, - * m3+1,m4,cheater) - enddo - Kfirst=Lfirst(3) - endif - if (Llast(3).gt.Klast) then - do L=Klast,Llast(3),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1+1,m2, - * m3+1,m4,cheater) - enddo - Klast=Llast(3) - endif - Lrun=1 - do L=Lfirst(3),Llast(3),2 - if (dummy(L).ne.0d0) then - If (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,-DBLE(2+4*l1)*factor*dummy(L), - * caseb2SO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,-DBLE(2+4*l1)*factor*dummy(L), - * caseb2SO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall,-DBLE(2+4*l1)* - * factor*dummy(L),caseb2OO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - endif -cbs seventh term: ########################################################################### - factor=preroots(2,l1)*preroots(1,l3)* - *clebsch(3,2,m1,l1)* - *clebsch(3,1,m3,l3) - if (factor.ne.0d0) then - do I=0,Lmax+Lmax+1 - dummy(I)=0d0 - enddo - Klast=0 - Kfirst=Lmax+Lmax+1 ! just to be sure .. -cbs get the L,M dependent coefficients - if (Lblocks(1).gt.0) then - M=m2-m4 - Kfirst=Lfirst(1) - Klast=Llast(1) - Lrun=1 - do L=Lfirst(1),Llast(1),2 - dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1+1,m2,m3+1,m4,cheater) - if (dummy(L).ne.0d0) then - If (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - Call daxpy_(ncontall, - * 4.0D0*factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - if (Lblocks(2).gt.0) then - M=m2-m4 - if (Lfirst(2).lt.Kfirst) then - do L=Lfirst(2),Kfirst,2 - dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1+1,m2, - * m3+1,m4,cheater) - enddo - Kfirst=Lfirst(2) - endif - if (Llast(2).gt.Klast) then - do L=Klast,Llast(2),2 - dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1+1,m2, - * m3+1,m4,cheater) - enddo - Klast=Llast(2) - endif - Lrun=1 - do L=Lfirst(2),Llast(2),2 - if (dummy(L).ne.0d0) then - If (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,-DBLE(2+4*l3)*factor*dummy(L), - * caseb1SO(1,Lrun),1,angintSO,1) - else - Call daxpy_(ncontall,-DBLE(2+4*l3)*factor*dummy(L), - * caseb1SO(1,Lrun),1,angintSO,1) - Call daxpy_(ncontall,-DBLE(2+4*l3)* - * factor*dummy(L),caseb1OO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - endif -cbs eigth term: ########################################################################### - factor=preroots(1,l1)*preroots(1,l3)* - *clebsch(3,1,m1,l1)* - *clebsch(3,1,m3,l3) - if (factor.ne.0d0) then - do I=0,Lmax+Lmax+1 - dummy(I)=0d0 - enddo - Klast=0 - Kfirst=Lmax+Lmax+1 ! just to be sure .. -cbs get the L,M dependent coefficients - if (Lblocks(1).gt.0) then - M=m2-m4 - Kfirst=Lfirst(1) - Klast=Llast(1) - Lrun=1 - do L=Lfirst(1),Llast(1),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3+1,m4,cheater) - if (dummy(L).ne.0d0) then - If (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall, - * 4.0D0*factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - if (Lblocks(2).gt.0) then - M=m2-m4 - if (Lfirst(2).lt.Kfirst) then - do L=Lfirst(2),Kfirst,2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2, - * m3+1,m4,cheater) - enddo - Kfirst=Lfirst(2) - endif - if (Llast(2).gt.Klast) then - do L=Klast,Llast(2),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2, - * m3+1,m4,cheater) - enddo - Klast=Llast(2) - endif - Lrun=1 - do L=Lfirst(2),Llast(2),2 - if (dummy(L).ne.0d0) then - If (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,-DBLE(2+4*l3)*factor*dummy(L), - * caseb1SO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,-DBLE(2+4*l3)*factor*dummy(L), - * caseb1SO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall, - * -DBLE(2+4*l3)*factor*dummy(L),caseb1OO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - if (Lblocks(3).gt.0) then - M=m2-m4 - if (Lfirst(3).lt.Kfirst) then - do L=Lfirst(3),Kfirst,2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2, - * m3+1,m4,cheater) - enddo - Kfirst=Lfirst(3) - endif - if (Llast(3).gt.Klast) then - do L=Klast,Llast(3),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2, - * m3+1,m4,cheater) - enddo - Klast=Llast(3) - endif - Lrun=1 - do L=Lfirst(3),Llast(3),2 - if (dummy(L).ne.0d0) then - If (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,-DBLE(2+4*l1)*factor*dummy(L), - * caseb2SO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,-DBLE(2+4*l1)*factor*dummy(L), - * caseb2SO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall,-DBLE(2+4*l1)* - * factor*dummy(L),caseb2OO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - if (Lblocks(4).gt.0) then - M=m2-m4 - if (Lfirst(4).lt.Kfirst) then - do L=Lfirst(4),Kfirst,2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2, - * m3+1,m4,cheater) - enddo - Kfirst=Lfirst(4) - endif - if (Llast(4).gt.Klast) then - do L=Klast,Llast(4),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2, - * m3+1,m4,cheater) - enddo - Klast=Llast(4) - endif - Lrun=1 - do L=Lfirst(4),Llast(4),2 - if (dummy(L).ne.0d0) then - If (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,DBLE(4*l1*l3+2*l1+2*l3+1)* - * factor*dummy(L), - * casecSO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,DBLE(4*l1*l3+2*l1+2*l3+1)* - * factor*dummy(L), - * casecSO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall, - * DBLE(4*l1*l3+2*l1+2*l3+1)*factor*dummy(L), - * casecOO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - endif - return - end diff -Nru openmolcas-22.02/src/amfi_util/mkangl0.F90 openmolcas-22.10/src/amfi_util/mkangl0.F90 --- openmolcas-22.02/src/amfi_util/mkangl0.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/mkangl0.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,538 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine mkangL0(Lmax,l1,l2,l3,l4,m1,m2,m3,m4,angintSO,angintOO,Lfirst,Llast,Lblocks,ncont1,ncont2,ncont3,ncont4,caseaSO, & + caseb1SO,caseb2SO,casecSO,caseaOO,caseb1OO,caseb2OO,casecOO,preroots,clebsch,dummy,bonn,breit,sameorb) +!bs subroutine for combining radial integrals with angular +!bs factors for the block with l1,l2,l3,l4,m1,m2,m3m,m4 +!bs this routine mkangL0 = make angular factors for the L0-part +!bs includes both, spin-same and spin-other-orbit parts. + +use Constants, only: Zero, One, Four +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: Lmax, l1, l2, l3, l4, m1, m2, m3, m4, Lfirst(4), Llast(4), Lblocks(4), ncont1, ncont2, ncont3, & + ncont4 +real(kind=wp), intent(out) :: angintSO(ncont1,ncont2,ncont3,ncont4), angintOO(ncont1,ncont2,ncont3,ncont4), dummy(0:2*Lmax+1) +real(kind=wp), intent(in) :: caseaSO(ncont1*ncont2*ncont3*ncont4,*), caseb1SO(ncont1*ncont2*ncont3*ncont4,*), & + caseb2SO(ncont1*ncont2*ncont3*ncont4,*), casecSO(ncont1*ncont2*ncont3*ncont4,*), & + caseaOO(ncont1*ncont2*ncont3*ncont4,*), caseb1OO(ncont1*ncont2*ncont3*ncont4,*), & + caseb2OO(ncont1*ncont2*ncont3*ncont4,*), casecOO(ncont1*ncont2*ncont3*ncont4,*), preroots(2,0:Lmax), & + clebsch(3,2,-Lmax:Lmax,0:Lmax) +logical(kind=iwp), intent(in) :: bonn, breit, sameorb +integer(kind=iwp) :: Kfirst, Klast, L, Lrun, M, ncontall +real(kind=wp) :: cheater, factor +real(kind=wp), external :: LMdepang +!bs all the arrays with the radial integrals for +!bs this combination of l-values +! caseaSO: (2,0) integrals with alpha1*alpha3 +! caseb1SO: (0,0) integrals with alpha1 +! caseb2SO: (0,0) integrals with alpha3 +! casecSO: (-2,0) integrals with factor 1 +! caseaOO: (2,0) integrals with alpha1*alpha3 +! caseb1OO: (0,0) integrals with alpha1 +! caseb2OO: (0,0) integrals with alpha3 +! casecOO: (-2,0) integrals with factor 1 +! preroots: some prefactors: sqrt( (l(+1))/(2l+1)) +! clebsch: some clebsch gordans, that appear regulary + +!write(u6,*) 'begin mkangL0 ',l1,l2,l3,l4,m1,m2,m3,m4 + +ncontall = ncont1*ncont2*ncont3*ncont4 +!bs cheater introduced to correct signs, because they were different from HERMIT +if (mod(l1+l2+l3+l4,4) == 2) then + cheater = One +else + cheater = -One +end if +!bs cleaning up +if (bonn .or. breit .or. sameorb) then + angintSO(:,:,:,:) = Zero +else + angintSO(:,:,:,:) = Zero + angintOO(:,:,:,:) = Zero +end if +!bs starting with the same-orbit-contributions +!bs first term: ######################################################## +factor = -preroots(2,l1)*preroots(2,l3)*clebsch(1,2,m1,l1)*clebsch(1,2,m3,l3) +if (factor /= Zero) then + !bs get the L,M dependent coefficients + if (Lblocks(1) > 0) then + dummy(:) = Zero + M = m2-m4 + Lrun = 1 + do L=Lfirst(1),Llast(1),2 + dummy(L) = LMdepang(L,M,l1+1,l2,l3+1,l4,m1-1,m2,m3-1,m4,cheater) + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,Four*factor*dummy(L),caseaOO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if +end if +!bs second term: ####################################################### +factor = -preroots(1,l1)*preroots(2,l3)*clebsch(1,1,m1,l1)*clebsch(1,2,m3,l3) +if (factor /= Zero) then + dummy(:) = Zero + Klast = 0 + Kfirst = 2*Lmax+1 ! just to be sure .. + !bs get the L,M dependent coefficients + if (Lblocks(1) > 0) then + M = m2-m4 + Kfirst = Lfirst(1) + Klast = Llast(1) + Lrun = 1 + do L=Lfirst(1),Llast(1),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3+1,l4,m1-1,m2,m3-1,m4,cheater) + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,Four*factor*dummy(L),caseaOO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if + if (Lblocks(3) > 0) then + M = m2-m4 + if (Lfirst(3) < Kfirst) then + do L=Lfirst(3),Kfirst,2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3+1,l4,m1-1,m2,m3-1,m4,cheater) + end do + Kfirst = Lfirst(3) + end if + if (Llast(3) > Klast) then + do L=Klast,Llast(3),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3+1,l4,m1-1,m2,m3-1,m4,cheater) + end do + Klast = Llast(3) + end if + Lrun = 1 + do L=Lfirst(3),Llast(3),2 + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2SO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2SO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2OO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if +end if +!bs third term: ######################################################## +factor = -preroots(2,l1)*preroots(1,l3)*clebsch(1,2,m1,l1)*clebsch(1,1,m3,l3) +if (factor /= Zero) then + dummy(:) = Zero + Klast = 0 + Kfirst = 2*Lmax+1 ! just to be sure .. + !bs get the L,M dependent coefficients + if (Lblocks(1) > 0) then + M = m2-m4 + Kfirst = Lfirst(1) + Klast = Llast(1) + Lrun = 1 + do L=Lfirst(1),Llast(1),2 + dummy(L) = LMdepang(L,M,l1+1,l2,l3-1,l4,m1-1,m2,m3-1,m4,cheater) + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,Four*factor*dummy(L),caseaOO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if + if (Lblocks(2) > 0) then + M = m2-m4 + if (Lfirst(2) < Kfirst) then + do L=Lfirst(2),Kfirst,2 + dummy(L) = LMdepang(L,M,l1+1,l2,l3-1,l4,m1-1,m2,m3-1,m4,cheater) + end do + Kfirst = Lfirst(2) + end if + if (Llast(2) > Klast) then + do L=Klast,Llast(2),2 + dummy(L) = LMdepang(L,M,l1+1,l2,l3-1,l4,m1-1,m2,m3-1,m4,cheater) + end do + Klast = Llast(2) + end if + Lrun = 1 + do L=Lfirst(2),Llast(2),2 + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1SO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1SO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1OO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if +end if +!bs fourth term: ####################################################### +factor = -preroots(1,l1)*preroots(1,l3)*clebsch(1,1,m1,l1)*clebsch(1,1,m3,l3) +if (factor /= Zero) then + dummy(:) = Zero + Klast = 0 + Kfirst = 2*Lmax+1 ! just to be sure .. + !bs get the L,M dependent coefficients + if (Lblocks(1) > 0) then + M = m2-m4 + Kfirst = Lfirst(1) + Klast = Llast(1) + Lrun = 1 + do L=Lfirst(1),Llast(1),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2,m3-1,m4,cheater) + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,Four*factor*dummy(L),caseaOO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if + if (Lblocks(2) > 0) then + M = m2-m4 + if (Lfirst(2) < Kfirst) then + do L=Lfirst(2),Kfirst,2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2,m3-1,m4,cheater) + end do + Kfirst = Lfirst(2) + end if + if (Llast(2) > Klast) then + do L=Klast,Llast(2),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2,m3-1,m4,cheater) + end do + Klast = Llast(2) + end if + Lrun = 1 + do L=Lfirst(2),Llast(2),2 + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1SO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1SO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1OO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if + if (Lblocks(3) > 0) then + M = m2-m4 + if (Lfirst(3) < Kfirst) then + do L=Lfirst(3),Kfirst,2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2,m3-1,m4,cheater) + end do + Kfirst = Lfirst(3) + end if + if (Llast(3) > Klast) then + do L=Klast,Llast(3),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2,m3-1,m4,cheater) + end do + Klast = Llast(3) + end if + Lrun = 1 + do L=Lfirst(3),Llast(3),2 + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2SO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2SO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2OO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if + if (Lblocks(4) > 0) then + M = m2-m4 + if (Lfirst(4) < Kfirst) then + do L=Lfirst(4),Kfirst,2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2,m3-1,m4,cheater) + end do + Kfirst = Lfirst(4) + end if + if (Llast(4) > Klast) then + do L=Klast,Llast(4),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2,m3-1,m4,cheater) + end do + Klast = Llast(4) + end if + Lrun = 1 + do L=Lfirst(4),Llast(4),2 + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,real(4*l1*l3+2*l1+2*l3+1,kind=wp)*factor*dummy(L),casecSO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,real(4*l1*l3+2*l1+2*l3+1,kind=wp)*factor*dummy(L),casecSO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,real(4*l1*l3+2*l1+2*l3+1,kind=wp)*factor*dummy(L),casecOO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if +end if +!bs fifth term: ######################################################## +factor = preroots(2,l1)*preroots(2,l3)*clebsch(3,2,m1,l1)*clebsch(3,2,m3,l3) +if (factor /= Zero) then + dummy(:) = Zero + !bs get the L,M dependent coefficients + if (Lblocks(1) > 0) then + M = m2-m4 + Lrun = 1 + do L=Lfirst(1),Llast(1),2 + dummy(L) = LMdepang(L,M,l1+1,l2,l3+1,l4,m1+1,m2,m3+1,m4,cheater) + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,Four*factor*dummy(L),caseaOO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if +end if +!bs sixth term: ######################################################## +factor = preroots(1,l1)*preroots(2,l3)*clebsch(3,1,m1,l1)*clebsch(3,2,m3,l3) +if (factor /= Zero) then + dummy(:) = Zero + Klast = 0 + Kfirst = 2*Lmax+1 ! just to be sure .. + !bs get the L,M dependent coefficients + if (Lblocks(1) > 0) then + M = m2-m4 + Kfirst = Lfirst(1) + Klast = Llast(1) + Lrun = 1 + do L=Lfirst(1),Llast(1),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3+1,l4,m1+1,m2,m3+1,m4,cheater) + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,Four*factor*dummy(L),caseaOO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if + if (Lblocks(3) > 0) then + M = m2-m4 + if (Lfirst(3) < Kfirst) then + do L=Lfirst(3),Kfirst,2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3+1,l4,m1+1,m2,m3+1,m4,cheater) + end do + Kfirst = Lfirst(3) + end if + if (Llast(3) > Klast) then + do L=Klast,Llast(3),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3+1,l4,m1+1,m2,m3+1,m4,cheater) + end do + Klast = Llast(3) + end if + Lrun = 1 + do L=Lfirst(3),Llast(3),2 + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2SO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2SO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2OO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if +end if +!bs seventh term: ###################################################### +factor = preroots(2,l1)*preroots(1,l3)*clebsch(3,2,m1,l1)*clebsch(3,1,m3,l3) +if (factor /= Zero) then + dummy(:) = Zero + Klast = 0 + Kfirst = 2*Lmax+1 ! just to be sure .. + !bs get the L,M dependent coefficients + if (Lblocks(1) > 0) then + M = m2-m4 + Kfirst = Lfirst(1) + Klast = Llast(1) + Lrun = 1 + do L=Lfirst(1),Llast(1),2 + dummy(L) = LMdepang(L,M,l1+1,l2,l3-1,l4,m1+1,m2,m3+1,m4,cheater) + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,Four*factor*dummy(L),caseaOO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if + if (Lblocks(2) > 0) then + M = m2-m4 + if (Lfirst(2) < Kfirst) then + do L=Lfirst(2),Kfirst,2 + dummy(L) = LMdepang(L,M,l1+1,l2,l3-1,l4,m1+1,m2,m3+1,m4,cheater) + end do + Kfirst = Lfirst(2) + end if + if (Llast(2) > Klast) then + do L=Klast,Llast(2),2 + dummy(L) = LMdepang(L,M,l1+1,l2,l3-1,l4,m1+1,m2,m3+1,m4,cheater) + end do + Klast = Llast(2) + end if + Lrun = 1 + do L=Lfirst(2),Llast(2),2 + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1SO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1SO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1OO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if +end if +!bs eighth term: ####################################################### +factor = preroots(1,l1)*preroots(1,l3)*clebsch(3,1,m1,l1)*clebsch(3,1,m3,l3) +if (factor /= Zero) then + dummy(:) = Zero + Klast = 0 + Kfirst = 2*Lmax+1 ! just to be sure .. + !bs get the L,M dependent coefficients + if (Lblocks(1) > 0) then + M = m2-m4 + Kfirst = Lfirst(1) + Klast = Llast(1) + Lrun = 1 + do L=Lfirst(1),Llast(1),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3+1,m4,cheater) + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,Four*factor*dummy(L),caseaOO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if + if (Lblocks(2) > 0) then + M = m2-m4 + if (Lfirst(2) < Kfirst) then + do L=Lfirst(2),Kfirst,2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3+1,m4,cheater) + end do + Kfirst = Lfirst(2) + end if + if (Llast(2) > Klast) then + do L=Klast,Llast(2),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3+1,m4,cheater) + end do + Klast = Llast(2) + end if + Lrun = 1 + do L=Lfirst(2),Llast(2),2 + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1SO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1SO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1OO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if + if (Lblocks(3) > 0) then + M = m2-m4 + if (Lfirst(3) < Kfirst) then + do L=Lfirst(3),Kfirst,2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3+1,m4,cheater) + end do + Kfirst = Lfirst(3) + end if + if (Llast(3) > Klast) then + do L=Klast,Llast(3),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3+1,m4,cheater) + end do + Klast = Llast(3) + end if + Lrun = 1 + do L=Lfirst(3),Llast(3),2 + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2SO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2SO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2OO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if + if (Lblocks(4) > 0) then + M = m2-m4 + if (Lfirst(4) < Kfirst) then + do L=Lfirst(4),Kfirst,2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3+1,m4,cheater) + end do + Kfirst = Lfirst(4) + end if + if (Llast(4) > Klast) then + do L=Klast,Llast(4),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3+1,m4,cheater) + end do + Klast = Llast(4) + end if + Lrun = 1 + do L=Lfirst(4),Llast(4),2 + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,real(4*l1*l3+2*l1+2*l3+1,kind=wp)*factor*dummy(L),casecSO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,real(4*l1*l3+2*l1+2*l3+1,kind=wp)*factor*dummy(L),casecSO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,real(4*l1*l3+2*l1+2*l3+1,kind=wp)*factor*dummy(L),casecOO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if +end if + +return + +end subroutine mkangL0 diff -Nru openmolcas-22.02/src/amfi_util/mkanglmin.f openmolcas-22.10/src/amfi_util/mkanglmin.f --- openmolcas-22.02/src/amfi_util/mkanglmin.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/mkanglmin.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,636 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine mkangLmin(Lmax,l1,l2,l3,l4,m1,m2,m3,m4, - *angintSO,angintOO, - *Lfirst,Llast,Lblocks, - *ncont1,ncont2,ncont3, - *ncont4, - *caseaSO,caseb1SO,caseb2SO,casecSO, - *caseaOO,caseb1OO,caseb2OO,casecOO, - *preroots,clebsch,dummy,bonn,breit, - *sameorb) - implicit real*8 (a-h,o-z) -cbs subroutine for combining radial intgrls with angular -cbs factors for the block with l1,l2,l3,l4,m1,m2,m3m,m4 -cbs this routine mkangLmin = make angular factors for the L- -part -cbs includes both, spin-same and spin-other-orbit parts. - real*8 LMdepang - dimension - *angintSO(ncont1,ncont2,ncont3,ncont4), - *angintOO(ncont1,ncont2,ncont3,ncont4), - *Lfirst(*),Llast(*),Lblocks(*), -cbs all the arrays with the radial intgrls for -cbs this combination of l-values - *caseaSO(ncont1*ncont2*ncont3*ncont4,*), -c ! (2,0) intgrls with alpha1*alpha3 - *caseb1SO(ncont1*ncont2*ncont3*ncont4,*), -c ! (0,0) intgrls with alpha1 - *caseb2SO(ncont1*ncont2*ncont3*ncont4,*), -c ! (0,0) intgrls with alpha3 - *casecSO(ncont1*ncont2*ncont3*ncont4,*), -c ! (-2,0) intgrls with factor 1 - *caseaOO(ncont1*ncont2*ncont3*ncont4,*), -c ! (2,0) intgrls with alpha1*alpha3 - *caseb1OO(ncont1*ncont2*ncont3*ncont4,*), -c ! (0,0) intgrls with alpha1 - *caseb2OO(ncont1*ncont2*ncont3*ncont4,*), -c ! (0,0) intgrls with alpha3 - *casecOO(ncont1*ncont2*ncont3*ncont4,*), -c ! (-2,0) intgrls with factor 1 - *preroots(2,0:Lmax), -c ! some prefactors: sqrt( (l(+1))/(2l+1)) - *clebsch(3,2,-Lmax:Lmax,0:Lmax) -c ! some clebsch gordans, that appear regulary - dimension dummy(0:*) - logical bonn,breiT,sameorb - root2=sqrt(2.0d0) - root2inv=1d0/root2 -c write(6,*) 'begin mkangL- ', -c *l1,l2,l3,l4,m1,m2,m3,m4 -cbs - ncontall=ncont1*ncont2*ncont3*ncont4 -cbs cheater introduced to correct signs, because they were different from HERMIT - if (mod(l1+l2+l3+l4,4).eq.2) then - cheater=1d0 - else - cheater=-1d0 - endiF -cbs cleaning up - if (bonn.or.breit.or.sameorb) then - call dzero(angintSO,ncontall) - else - call dzero(angintSO,ncontall) - call dzero(angintOO,ncontall) - endif -cbs starting with the same-orbit-contributions -cbs first term: ########################################################################### - factor=-root2inv*preroots(2,l1)*preroots(2,l3)* - *clebsch(3,2,m1,l1)* - *clebsch(2,2,m3,l3) - if (factor.ne.0d0) then - do I=0,Lmax+Lmax+1 - dummy(I)=0d0 - enddo -cbs get the L,M dependent coefficients - if (Lblocks(1).gt.0) then - M=m2-m4 - Lrun=1 - do L=Lfirst(1),Llast(1),2 - dummy(L)=LMdepang(L,M,l1+1,l2,l3+1,l4,m1+1,m2,m3,m4,cheater) - if (dummy(L).ne.0d0) then - if (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall, - * 4.0D0*factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) - endif - Endif - Lrun=Lrun+1 - enddo - endif - endif -cbs second term: ########################################################################### - factor=-root2inv*preroots(1,l1)*preroots(2,l3)* - *clebsch(3,1,m1,l1)* - *clebsch(2,2,m3,l3) - if (factor.ne.0d0) then - do I=0,Lmax+Lmax+1 - dummy(I)=0d0 - enddo - Klast=0 - Kfirst=Lmax+Lmax+1 ! just to be sure .. -cbs get the L,M dependent coefficients - if (Lblocks(1).gt.0) then - M=m2-m4 - Kfirst=Lfirst(1) - Klast=Llast(1) - Lrun=1 - do L=Lfirst(1),Llast(1),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1+1,m2,m3,m4,cheater) - if (dummy(L).ne.0d0) then - if (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall, - * 4.0D0*factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - if (Lblocks(3).gt.0) then - M=m2-m4 - if (Lfirst(3).lt.Kfirst) then - do L=Lfirst(3),Kfirst,2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1+1,m2,m3,m4,cheater) - enddo - Kfirst=Lfirst(3) - endif - if (Llast(3).gt.Klast) then - do L=Klast,Llast(3),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1+1,m2,m3,m4,cheater) - enddo - Klast=Llast(3) - endif - Lrun=1 - do L=Lfirst(3),Llast(3),2 - if (dummy(L).ne.0d0) then - if (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,-DBLE(2+4*l1)*factor*dummy(L), - * caseb2SO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,-DBLE(2+4*l1)*factor*dummy(L), - * caseb2SO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall,-DBLE(2+4*l1)* - * factor*dummy(L),caseb2OO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - endif -cbs third term: ########################################################################### - factor=-root2inv*preroots(2,l1)*preroots(1,l3)* - *clebsch(3,2,m1,l1)* - *clebsch(2,1,m3,l3) - if (factor.ne.0d0) then - do I=0,Lmax+Lmax+1 - dummy(I)=0d0 - enddo - Klast=0 - Kfirst=Lmax+Lmax+1 ! just to be sure .. -cbs get the L,M dependent coefficients - if (Lblocks(1).gt.0) then - M=m2-m4 - Kfirst=Lfirst(1) - Klast=Llast(1) - Lrun=1 - do L=Lfirst(1),Llast(1),2 - dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) - if (dummy(L).ne.0d0) then - if (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall, - * 4.0D0*factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - if (Lblocks(2).gt.0) then - M=m2-m4 - if (Lfirst(2).lt.Kfirst) then - do L=Lfirst(2),Kfirst,2 - dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1+1,m2, - * m3,m4,Cheater) - enddo - Kfirst=Lfirst(2) - endif - if (Llast(2).gt.Klast) then - do L=Klast,Llast(2),2 - dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) - enddo - Klast=Llast(2) - endif - Lrun=1 - do L=Lfirst(2),Llast(2),2 - if (dummy(L).ne.0d0) then - if (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,-DBLE(2+4*l3)*factor*dummy(L), - * caseb1SO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,-DBLE(2+4*l3)*factor*dummy(L), - * caseb1SO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall,-DBLE(2+4*l3)* - * factor*dummy(L),caseb1OO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - endif -cbs fourth term: ########################################################################### - factor=-root2inv*preroots(1,l1)*preroots(1,l3)* - *clebsch(3,1,m1,l1)* - *clebsch(2,1,m3,l3) - if (factor.ne.0d0) then - do I=0,Lmax+Lmax+1 - dummy(I)=0d0 - enddo - Klast=0 - Kfirst=Lmax+Lmax+1 ! just to be sure .. -cbs get the L,M dependent coefficients - if (Lblocks(1).gt.0) then - M=m2-m4 - Kfirst=Lfirst(1) - Klast=Llast(1) - Lrun=1 - do L=Lfirst(1),Llast(1),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) - if (dummy(L).ne.0d0) then - if (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall, - * 4.0D0*factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - if (Lblocks(2).gt.0) then - M=m2-m4 - if (Lfirst(2).lt.Kfirst) then - do L=Lfirst(2),Kfirst,2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) - enddo - Kfirst=Lfirst(2) - endif - if (Llast(2).gt.Klast) then - do L=Klast,Llast(2),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) - enddo - Klast=Llast(2) - endif - Lrun=1 - do L=Lfirst(2),Llast(2),2 - if (dummy(L).ne.0d0) then - if (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,-DBLE(2+4*l3)*factor*dummy(L), - * caseb1SO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,-DBLE(2+4*l3)*factor*dummy(L), - * caseb1SO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall,-DBLE(2+4*l3)* - * factor*dummy(L),caseb1OO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - if (Lblocks(3).gt.0) then - M=m2-m4 - if (Lfirst(3).lt.Kfirst) then - do L=Lfirst(3),Kfirst,2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) - enddo - Kfirst=Lfirst(3) - endif - if (Llast(3).gt.Klast) then - do L=Klast,Llast(3),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) - enddo - Klast=Llast(3) - endif - Lrun=1 - do L=Lfirst(3),Llast(3),2 - if (dummy(L).ne.0d0) then - if (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,-DBLE(2+4*l1)*factor*dummy(L), - * caseb2SO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,-DBLE(2+4*l1)*factor*dummy(L), - * caseb2SO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall,-DBLE(2+4*l1)* - * factor*dummy(L),caseb2OO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - if (Lblocks(4).gt.0) then - M=m2-m4 - if (Lfirst(4).lt.Kfirst) then - do L=Lfirst(4),Kfirst,2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) - enddo - Kfirst=Lfirst(4) - endif - if (Llast(4).gt.Klast) then - do L=Klast,Llast(4),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) - enddo - Klast=Llast(4) - endif - Lrun=1 - do L=Lfirst(4),Llast(4),2 - if (dummy(L).ne.0d0) then - if (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,DBLE(4*l1*l3+2*l1+2*l3+1)*factor*dummy(L), - * casecSO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,DBLE(4*l1*l3+2*l1+2*l3+1)*factor*dummy(L), - * casecSO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall, - * DBLE(4*l1*l3+2*l1+2*l3+1)*factor*dummy(L), - * casecOO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - endif -cbs fifth term: ########################################################################### - factor=-root2inv*preroots(2,l1)*preroots(2,l3)* - *clebsch(2,2,m1,l1)* - *clebsch(1,2,m3,l3) - if (factor.ne.0d0) then - do I=0,Lmax+Lmax+1 - dummy(I)=0d0 - enddo -cbs get the L,M dependent coefficients - if (Lblocks(1).gt.0) then - M=m2-m4 - Lrun=1 - do L=Lfirst(1),Llast(1),2 - dummy(L)=LMdepang(L,M,l1+1,l2,l3+1,l4,m1,m2,m3-1,m4,cheater) - if (dummy(L).ne.0d0) then - if (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall, - * 4.0D0*factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - endif -cbs sixth term: ########################################################################### - factor=-root2inv*preroots(1,l1)*preroots(2,l3)* - *clebsch(2,1,m1,l1)* - *clebsch(1,2,m3,l3) - if (factor.ne.0d0) then - do I=0,Lmax+Lmax+1 - dummy(I)=0d0 - enddo - Klast=0 - Kfirst=Lmax+Lmax+1 ! just to be sure .. -cbs get the L,M dependent coefficients - if (Lblocks(1).gt.0) then - M=m2-m4 - Kfirst=Lfirst(1) - Klast=Llast(1) - Lrun=1 - do L=Lfirst(1),Llast(1),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1,m2,m3-1,m4,cheater) - if (dummy(L).ne.0d0) then - if (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall,4.0D0* - * factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - if (Lblocks(3).gt.0) then - M=m2-m4 - if (Lfirst(3).lt.Kfirst) then - do L=Lfirst(3),Kfirst,2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1,m2,m3-1,m4,cheater) - enddo - Kfirst=Lfirst(3) - endif - if (Llast(3).gt.Klast) then - do L=Klast,Llast(3),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1,m2,m3-1,m4,cheater) - enddo - Klast=Llast(3) - endif - Lrun=1 - do L=Lfirst(3),Llast(3),2 - if (dummy(L).ne.0d0) then - if (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,-DBLE(2+4*l1)*factor*dummy(L), - * caseb2SO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,-DBLE(2+4*l1)*factor*dummy(L), - * caseb2SO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall,-DBLE(2+4*l1)* - * factor*dummy(L),caseb2OO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - endif -cbs seventh term: ########################################################################### - factor=-root2inv*preroots(2,l1)*preroots(1,l3)* - *clebsch(2,2,m1,l1)* - *clebsch(1,1,m3,l3) - if (factor.ne.0d0) then - do I=0,Lmax+Lmax+1 - dummy(I)=0d0 - enddo - Klast=0 - Kfirst=Lmax+Lmax+1 ! just to be sure .. -cbs get the L,M dependent coefficients - if (Lblocks(1).gt.0) then - M=m2-m4 - Kfirst=Lfirst(1) - Klast=Llast(1) - Lrun=1 - do L=Lfirst(1),Llast(1),2 - dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) - if (dummy(L).ne.0d0) then - if (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall, - * 4.0D0*factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - if (Lblocks(2).gt.0) then - M=m2-m4 - if (Lfirst(2).lt.Kfirst) then - do L=Lfirst(2),Kfirst,2 - dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) - enddo - Kfirst=Lfirst(2) - endif - if (Llast(2).gt.Klast) then - do L=Klast,Llast(2),2 - dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) - enddo - Klast=Llast(2) - endif - Lrun=1 - do L=Lfirst(2),Llast(2),2 - if (dummy(L).ne.0d0) then - if (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,-DBLE(2+4*l3)*factor*dummy(L), - * caseb1SO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,-DBLE(2+4*l3)*factor*dummy(L), - * caseb1SO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall,-DBLE(2+4*l3)* - * factor*dummy(L),caseb1OO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - endif -cbs eigth term: ########################################################################### - factor=-root2inv*preroots(1,l1)*preroots(1,l3)* - *clebsch(2,1,m1,l1)* - *clebsch(1,1,m3,l3) - if (factor.ne.0d0) then - do I=0,Lmax+Lmax+1 - dummy(I)=0d0 - enddo - Klast=0 - Kfirst=Lmax+Lmax+1 ! just to be sure .. -cbs get the L,M dependent coefficients - if (Lblocks(1).gt.0) then - M=m2-m4 - Kfirst=Lfirst(1) - Klast=Llast(1) - Lrun=1 - do L=Lfirst(1),Llast(1),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) - if (dummy(L).ne.0d0) then - if (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,4.0D0*factor*dummy(L), - * caseaSO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall,4.0D0* - * factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - if (Lblocks(2).gt.0) then - M=m2-m4 - if (Lfirst(2).lt.Kfirst) then - do L=Lfirst(2),Kfirst,2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) - enddo - Kfirst=Lfirst(2) - endif - if (Llast(2).gt.Klast) then - do L=Klast,Llast(2),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) - enddo - Klast=Llast(2) - endif - Lrun=1 - do L=Lfirst(2),Llast(2),2 - if (dummy(L).ne.0d0) then - if (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,-DBLE(2+4*l3)*factor*dummy(L), - * caseb1SO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,-DBLE(2+4*l3)*factor*dummy(L), - * caseb1SO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall,-DBLE(2+4*l3)* - *factor*dummy(L),caseb1OO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - if (Lblocks(3).gt.0) then - M=m2-m4 - if (Lfirst(3).lt.Kfirst) then - do L=Lfirst(3),Kfirst,2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) - enddo - Kfirst=Lfirst(3) - endif - if (Llast(3).gt.Klast) then - do L=Klast,Llast(3),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) - enddo - Klast=Llast(3) - endif - Lrun=1 - do L=Lfirst(3),Llast(3),2 - if (dummy(L).ne.0d0) then - if (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,-DBLE(2+4*l1)*factor*dummy(L), - * caseb2SO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,-DBLE(2+4*l1)*factor*dummy(L), - * caseb2SO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall,-DBLE(2+4*l1)* - * factor*dummy(L),caseb2OO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - if (Lblocks(4).gt.0) then - M=m2-m4 - if (Lfirst(4).lt.Kfirst) then - do L=Lfirst(4),Kfirst,2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) - enddo - Kfirst=Lfirst(4) - endif - if (Llast(4).gt.Klast) then - do L=Klast,Llast(4),2 - dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) - enddo - Klast=Llast(4) - endif - Lrun=1 - do L=Lfirst(4),Llast(4),2 - if (dummy(L).ne.0d0) then - if (bonn.or.breit.or.sameorb) then - call daxpy_(ncontall,DBLE(4*l1*l3+2*l1+2*l3+1)* - * factor*dummy(L), - * casecSO(1,Lrun),1,angintSO,1) - else - call daxpy_(ncontall,DBLE(4*l1*l3+2*l1+2*l3+1)* - * factor*dummy(L), - * casecSO(1,Lrun),1,angintSO,1) - call daxpy_(ncontall, - * DBLE(4*l1*l3+2*l1+2*l3+1)*factor*dummy(L), - * casecOO(1,Lrun),1,angintOO,1) - endif - endif - Lrun=Lrun+1 - enddo - endif - endif - return - end diff -Nru openmolcas-22.02/src/amfi_util/mkanglmin.F90 openmolcas-22.10/src/amfi_util/mkanglmin.F90 --- openmolcas-22.02/src/amfi_util/mkanglmin.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/mkanglmin.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,539 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine mkangLmin(Lmax,l1,l2,l3,l4,m1,m2,m3,m4,angintSO,angintOO,Lfirst,Llast,Lblocks,ncont1,ncont2,ncont3,ncont4,caseaSO, & + caseb1SO,caseb2SO,casecSO,caseaOO,caseb1OO,caseb2OO,casecOO,preroots,clebsch,dummy,bonn,breit,sameorb) +!bs subroutine for combining radial intgrls with angular +!bs factors for the block with l1,l2,l3,l4,m1,m2,m3m,m4 +!bs this routine mkangLmin = make angular factors for the L- -part +!bs includes both, spin-same and spin-other-orbit parts. + +use Constants, only: Zero, One, Two, Four +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: Lmax, l1, l2, l3, l4, m1, m2, m3, m4, Lfirst(4), Llast(4), Lblocks(4), ncont1, ncont2, ncont3, & + ncont4 +real(kind=wp), intent(out) :: angintSO(ncont1,ncont2,ncont3,ncont4), angintOO(ncont1,ncont2,ncont3,ncont4), dummy(0:2*Lmax+1) +real(kind=wp), intent(in) :: caseaSO(ncont1*ncont2*ncont3*ncont4,*), caseb1SO(ncont1*ncont2*ncont3*ncont4,*), & + caseb2SO(ncont1*ncont2*ncont3*ncont4,*), casecSO(ncont1*ncont2*ncont3*ncont4,*), & + caseaOO(ncont1*ncont2*ncont3*ncont4,*), caseb1OO(ncont1*ncont2*ncont3*ncont4,*), & + caseb2OO(ncont1*ncont2*ncont3*ncont4,*), casecOO(ncont1*ncont2*ncont3*ncont4,*), preroots(2,0:Lmax), & + clebsch(3,2,-Lmax:Lmax,0:Lmax) +logical(kind=iwp), intent(in) :: bonn, breit, sameorb +integer(kind=iwp) :: Kfirst, Klast, L, Lrun, M, ncontall +real(kind=wp) :: cheater, factor +real(kind=wp), parameter :: root2 = sqrt(Two), root2inv = One/root2 +real(kind=wp), external :: LMdepang +!bs all the arrays with the radial intgrls for +!bs this combination of l-values +! caseaSO: (2,0) intgrls with alpha1*alpha3 +! caseb1SO: (0,0) intgrls with alpha1 +! caseb2SO: (0,0) intgrls with alpha3 +! casecSO: (-2,0) intgrls with factor 1 +! caseaOO: (2,0) intgrls with alpha1*alpha3 +! caseb1OO: (0,0) intgrls with alpha1 +! caseb2OO: (0,0) intgrls with alpha3 +! casecOO: (-2,0) intgrls with factor 1 +! preroots: some prefactors: sqrt( (l(+1))/(2l+1)) +! clebsch: some clebsch gordans, that appear regulary + +!write(u6,*) 'begin mkangL- ',l1,l2,l3,l4,m1,m2,m3,m4 + +ncontall = ncont1*ncont2*ncont3*ncont4 +!bs cheater introduced to correct signs, because they were different from HERMIT +if (mod(l1+l2+l3+l4,4) == 2) then + cheater = One +else + cheater = -One +end if +!bs cleaning up +if (bonn .or. breit .or. sameorb) then + angintSO(:,:,:,:) = Zero +else + angintSO(:,:,:,:) = Zero + angintOO(:,:,:,:) = Zero +end if +!bs starting with the same-orbit-contributions +!bs first term: ######################################################## +factor = -root2inv*preroots(2,l1)*preroots(2,l3)*clebsch(3,2,m1,l1)*clebsch(2,2,m3,l3) +if (factor /= Zero) then + dummy(:) = Zero + !bs get the L,M dependent coefficients + if (Lblocks(1) > 0) then + M = m2-m4 + Lrun = 1 + do L=Lfirst(1),Llast(1),2 + dummy(L) = LMdepang(L,M,l1+1,l2,l3+1,l4,m1+1,m2,m3,m4,cheater) + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,Four*factor*dummy(L),caseaOO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if +end if +!bs second term: ####################################################### +factor = -root2inv*preroots(1,l1)*preroots(2,l3)*clebsch(3,1,m1,l1)*clebsch(2,2,m3,l3) +if (factor /= Zero) then + dummy(:) = Zero + Klast = 0 + Kfirst = 2*Lmax+1 ! just to be sure .. + !bs get the L,M dependent coefficients + if (Lblocks(1) > 0) then + M = m2-m4 + Kfirst = Lfirst(1) + Klast = Llast(1) + Lrun = 1 + do L=Lfirst(1),Llast(1),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3+1,l4,m1+1,m2,m3,m4,cheater) + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,Four*factor*dummy(L),caseaOO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if + if (Lblocks(3) > 0) then + M = m2-m4 + if (Lfirst(3) < Kfirst) then + do L=Lfirst(3),Kfirst,2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3+1,l4,m1+1,m2,m3,m4,cheater) + end do + Kfirst = Lfirst(3) + end if + if (Llast(3) > Klast) then + do L=Klast,Llast(3),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3+1,l4,m1+1,m2,m3,m4,cheater) + end do + Klast = Llast(3) + end if + Lrun = 1 + do L=Lfirst(3),Llast(3),2 + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2SO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2SO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2OO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if +end if +!bs third term: ######################################################## +factor = -root2inv*preroots(2,l1)*preroots(1,l3)*clebsch(3,2,m1,l1)*clebsch(2,1,m3,l3) +if (factor /= Zero) then + dummy(:) = Zero + Klast = 0 + Kfirst = 2*Lmax+1 ! just to be sure .. + !bs get the L,M dependent coefficients + if (Lblocks(1) > 0) then + M = m2-m4 + Kfirst = Lfirst(1) + Klast = Llast(1) + Lrun = 1 + do L=Lfirst(1),Llast(1),2 + dummy(L) = LMdepang(L,M,l1+1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,Four*factor*dummy(L),caseaOO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if + if (Lblocks(2) > 0) then + M = m2-m4 + if (Lfirst(2) < Kfirst) then + do L=Lfirst(2),Kfirst,2 + dummy(L) = LMdepang(L,M,l1+1,l2,l3-1,l4,m1+1,m2,m3,m4,Cheater) + end do + Kfirst = Lfirst(2) + end if + if (Llast(2) > Klast) then + do L=Klast,Llast(2),2 + dummy(L) = LMdepang(L,M,l1+1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) + end do + Klast = Llast(2) + end if + Lrun = 1 + do L=Lfirst(2),Llast(2),2 + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1SO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1SO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1OO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if +end if +!bs fourth term: ####################################################### +factor = -root2inv*preroots(1,l1)*preroots(1,l3)*clebsch(3,1,m1,l1)*clebsch(2,1,m3,l3) +if (factor /= Zero) then + dummy(:) = Zero + Klast = 0 + Kfirst = 2*Lmax+1 ! just to be sure .. + !bs get the L,M dependent coefficients + if (Lblocks(1) > 0) then + M = m2-m4 + Kfirst = Lfirst(1) + Klast = Llast(1) + Lrun = 1 + do L=Lfirst(1),Llast(1),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,Four*factor*dummy(L),caseaOO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if + if (Lblocks(2) > 0) then + M = m2-m4 + if (Lfirst(2) < Kfirst) then + do L=Lfirst(2),Kfirst,2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) + end do + Kfirst = Lfirst(2) + end if + if (Llast(2) > Klast) then + do L=Klast,Llast(2),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) + end do + Klast = Llast(2) + end if + Lrun = 1 + do L=Lfirst(2),Llast(2),2 + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1SO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1SO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1OO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if + if (Lblocks(3) > 0) then + M = m2-m4 + if (Lfirst(3) < Kfirst) then + do L=Lfirst(3),Kfirst,2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) + end do + Kfirst = Lfirst(3) + end if + if (Llast(3) > Klast) then + do L=Klast,Llast(3),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) + end do + Klast = Llast(3) + end if + Lrun = 1 + do L=Lfirst(3),Llast(3),2 + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2SO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2SO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2OO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if + if (Lblocks(4) > 0) then + M = m2-m4 + if (Lfirst(4) < Kfirst) then + do L=Lfirst(4),Kfirst,2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) + end do + Kfirst = Lfirst(4) + end if + if (Llast(4) > Klast) then + do L=Klast,Llast(4),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) + end do + Klast = Llast(4) + end if + Lrun = 1 + do L=Lfirst(4),Llast(4),2 + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,real(4*l1*l3+2*l1+2*l3+1,kind=wp)*factor*dummy(L),casecSO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,real(4*l1*l3+2*l1+2*l3+1,kind=wp)*factor*dummy(L),casecSO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,real(4*l1*l3+2*l1+2*l3+1,kind=wp)*factor*dummy(L),casecOO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if +end if +!bs fifth term: ######################################################## +factor = -root2inv*preroots(2,l1)*preroots(2,l3)*clebsch(2,2,m1,l1)*clebsch(1,2,m3,l3) +if (factor /= Zero) then + dummy(:) = Zero + !bs get the L,M dependent coefficients + if (Lblocks(1) > 0) then + M = m2-m4 + Lrun = 1 + do L=Lfirst(1),Llast(1),2 + dummy(L) = LMdepang(L,M,l1+1,l2,l3+1,l4,m1,m2,m3-1,m4,cheater) + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,Four*factor*dummy(L),caseaOO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if +end if +!bs sixth term: ######################################################## +factor = -root2inv*preroots(1,l1)*preroots(2,l3)*clebsch(2,1,m1,l1)*clebsch(1,2,m3,l3) +if (factor /= Zero) then + dummy(:) = Zero + Klast = 0 + Kfirst = 2*Lmax+1 ! just to be sure .. + !bs get the L,M dependent coefficients + if (Lblocks(1) > 0) then + M = m2-m4 + Kfirst = Lfirst(1) + Klast = Llast(1) + Lrun = 1 + do L=Lfirst(1),Llast(1),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3+1,l4,m1,m2,m3-1,m4,cheater) + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,Four*factor*dummy(L),caseaOO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if + if (Lblocks(3) > 0) then + M = m2-m4 + if (Lfirst(3) < Kfirst) then + do L=Lfirst(3),Kfirst,2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3+1,l4,m1,m2,m3-1,m4,cheater) + end do + Kfirst = Lfirst(3) + end if + if (Llast(3) > Klast) then + do L=Klast,Llast(3),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3+1,l4,m1,m2,m3-1,m4,cheater) + end do + Klast = Llast(3) + end if + Lrun = 1 + do L=Lfirst(3),Llast(3),2 + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2SO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2SO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2OO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if +end if +!bs seventh term: ###################################################### +factor = -root2inv*preroots(2,l1)*preroots(1,l3)*clebsch(2,2,m1,l1)*clebsch(1,1,m3,l3) +if (factor /= Zero) then + dummy(:) = Zero + Klast = 0 + Kfirst = 2*Lmax+1 ! just to be sure .. + !bs get the L,M dependent coefficients + if (Lblocks(1) > 0) then + M = m2-m4 + Kfirst = Lfirst(1) + Klast = Llast(1) + Lrun = 1 + do L=Lfirst(1),Llast(1),2 + dummy(L) = LMdepang(L,M,l1+1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,Four*factor*dummy(L),caseaOO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if + if (Lblocks(2) > 0) then + M = m2-m4 + if (Lfirst(2) < Kfirst) then + do L=Lfirst(2),Kfirst,2 + dummy(L) = LMdepang(L,M,l1+1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) + end do + Kfirst = Lfirst(2) + end if + if (Llast(2) > Klast) then + do L=Klast,Llast(2),2 + dummy(L) = LMdepang(L,M,l1+1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) + end do + Klast = Llast(2) + end if + Lrun = 1 + do L=Lfirst(2),Llast(2),2 + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1SO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1SO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1OO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if +end if +!bs eighth term: ####################################################### +factor = -root2inv*preroots(1,l1)*preroots(1,l3)*clebsch(2,1,m1,l1)*clebsch(1,1,m3,l3) +if (factor /= Zero) then + dummy(:) = Zero + Klast = 0 + Kfirst = 2*Lmax+1 ! just to be sure .. + !bs get the L,M dependent coefficients + if (Lblocks(1) > 0) then + M = m2-m4 + Kfirst = Lfirst(1) + Klast = Llast(1) + Lrun = 1 + do L=Lfirst(1),Llast(1),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,Four*factor*dummy(L),caseaSO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,Four*factor*dummy(L),caseaOO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if + if (Lblocks(2) > 0) then + M = m2-m4 + if (Lfirst(2) < Kfirst) then + do L=Lfirst(2),Kfirst,2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) + end do + Kfirst = Lfirst(2) + end if + if (Llast(2) > Klast) then + do L=Klast,Llast(2),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) + end do + Klast = Llast(2) + end if + Lrun = 1 + do L=Lfirst(2),Llast(2),2 + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1SO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1SO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,-real(2+4*l3,kind=wp)*factor*dummy(L),caseb1OO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if + if (Lblocks(3) > 0) then + M = m2-m4 + if (Lfirst(3) < Kfirst) then + do L=Lfirst(3),Kfirst,2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) + end do + Kfirst = Lfirst(3) + end if + if (Llast(3) > Klast) then + do L=Klast,Llast(3),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) + end do + Klast = Llast(3) + end if + Lrun = 1 + do L=Lfirst(3),Llast(3),2 + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2SO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2SO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,-real(2+4*l1,kind=wp)*factor*dummy(L),caseb2OO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if + if (Lblocks(4) > 0) then + M = m2-m4 + if (Lfirst(4) < Kfirst) then + do L=Lfirst(4),Kfirst,2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) + end do + Kfirst = Lfirst(4) + end if + if (Llast(4) > Klast) then + do L=Klast,Llast(4),2 + dummy(L) = LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) + end do + Klast = Llast(4) + end if + Lrun = 1 + do L=Lfirst(4),Llast(4),2 + if (dummy(L) /= Zero) then + if (bonn .or. breit .or. sameorb) then + call daxpy_(ncontall,real(4*l1*l3+2*l1+2*l3+1,kind=wp)*factor*dummy(L),casecSO(:,Lrun),1,angintSO,1) + else + call daxpy_(ncontall,real(4*l1*l3+2*l1+2*l3+1,kind=wp)*factor*dummy(L),casecSO(:,Lrun),1,angintSO,1) + call daxpy_(ncontall,real(4*l1*l3+2*l1+2*l3+1,kind=wp)*factor*dummy(L),casecOO(:,Lrun),1,angintOO,1) + end if + end if + Lrun = Lrun+1 + end do + end if +end if + +return + +end subroutine mkangLmin diff -Nru openmolcas-22.02/src/amfi_util/nucleus.fh openmolcas-22.10/src/amfi_util/nucleus.fh --- openmolcas-22.02/src/amfi_util/nucleus.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/nucleus.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,11 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - common /nucleus/ charge,Exp_Finite diff -Nru openmolcas-22.02/src/amfi_util/para.fh openmolcas-22.10/src/amfi_util/para.fh --- openmolcas-22.02/src/amfi_util/para.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/para.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,24 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - parameter (Lmax=6) -c ! max. angular momentum of basis functions DO NOT INCREASE -cbs TO MORE THAN SIX !!!!!!!!!!!!!!!!!!! -cbs if you do, you will have to edit the ixyzpow array by hand............... - parameter (Lmax_occ=3) -c ! highest L-value for occupied orbitals - parameter (MxprimL=40) -c ! max. of primitives per angular momentum - parameter (MxcontL=40) -c ! max. of contracted functions per angular momentum - parameter (MxCart=300) -c ! max. number of contracted functions in the atom - parameter (ndfmx=4*Lmax+4) -c ! dimension of precomputed double factorials diff -Nru openmolcas-22.02/src/amfi_util/param.fh openmolcas-22.10/src/amfi_util/param.fh --- openmolcas-22.02/src/amfi_util/param.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/param.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,110 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -cbs -cbs this include files hold a lot of dimensioning parameters and arrays for -cbs exponents, contraction coefficients and integrals. -cbs I hope, most of the names are selfexplaining... -cbs -cbs All those parameters are constructed to be blown up without any problem -cbs (if there is sufficient memory) except Lmax which is limited to 4 (g-functions) -cbs -cbs ############################################################################### -cbs ################ parameter block ############################################## -cbs ############################################################################### - parameter (Lanz=Lmax+1) ! number of angular momenta -cbs ############################################################################### -cbs ################ parameter block ############################################## -cbs ############################################################################### -cbs overlap of normalized functions - REAL*8 normovlp - common /normovl/ normovlp(MxprimL,MxprimL,0:Lmax), - *OVLPinv(MxprimL,MxprimL,0:Lmax), - *rootOVLP(MxprimL,MxprimL,0:Lmax), - *rootOVLPinv(MxprimL,MxprimL,0:Lmax), - *scratchinv((MxprimL*MxprimL+MxprimL)/2) -cbs defining a big array with enough space for all modified contraction coefficients -cbs for each l-value there are five blocks of size (nprimit(l),ncontrac(l)) -cbs the original contraction coefficients (for normalized functions) -cbs and four modified blocks depending on different kinematic factors and included exponents - common /contco/ - *contrarray((Lmax+1)*5*MxcontL*MxprimL), -cbs the following arrays hold the start adresses of the the contraction coefficients for each l-value - *iaddori(0:Lmax),iaddtyp1(0:Lmax),iaddtyp2(0:Lmax), - *iaddtyp3(0:Lmax),iaddtyp4(0:Lmax) -cbs the exponents - common /expo/ exponents(MxprimL,0:Lmax) -cbs the numbers of primitive and contracted functions for each l-value - common /dims/ nprimit(0:Lmax),ncontrac(0:Lmax),nprimit_keep, - *ncontrac_keep -cbs scratch should explain itself ........... - common /scratch_amfi/ - *scratch4(4*MxprimL*MxprimL), - *mcombina(2,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), - *cntscrtch(MxprimL,MxcontL,0:Lmax) - common /contint/ - *Lfirst(4), - *Llast(4),Lblocks(4),Lstarter(4), - *nblock,Lvalues(4) -cbs cont4 will keep 4 blocks (label(i)) of structure -cbs (ncontrac(l1),ncontrac(l2),ncontrac(l3),ncontrac(l4),(Llast(i)-Lfirst(i))/2+1) -cbs or 0 if no L-value at all -cbs = Lblocks(i) -cbs for each l1,l2,l3,l4-block -cbs Lfirst(i,j) gives the first L-value, for which radial integrals are calculated -cbs for type i and l1,l2,l3,l4 - Integral block. -cbs Llast(i,j) gives the last L-value -cbs Lblocks gives the number of L-values -cbs Lstarter gives the adress of each integral block on cont4 -cbs the following block contains a lot stuff for calculating the kinematic factors - common /diagonalize/ TKIN(MxprimL*MxprimL),evec(MxprimL*MxprimL), - *eval(MxprimL),Energy(MxprimL),type1(MxprimL),type2(MxprimL) -cbs -cbs some factors that appear a lot of times -cbs in the angular factors - common /prefs/ preroots(2,0:Lmax),clebsch(3,2,-Lmax:Lmax,0:Lmax) -cbs common block with the cartesian integrals - common /cartint/ - *mcombcart(2,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), - *istartX,istartY,istartZ, - *isignM(-Lmax:Lmax) -#include "ipowxyz.fh" -c common /onepar/ ! one-particle integrals -c *oneoverR3((MxprimL*MxprimL+MxprimL)/2,Lmax) -c *onecontr(mxcontL,MxcontL,-Lmax:Lmax,3,Lmax) -cbs one-electron-integrals: -cbs 1. index: number of first contracted function -cbs 2. index: number of second contracted function -cbs 3. index: pointer(m1,m2) m1< m2 otherwise change sign of integral -cbs 4. index: L-value -c *onecartX(mxcontL,MxcontL, -c *(Lmax+Lmax+1)*(Lmax+1),Lmax), -c *onecartY(mxcontL,MxcontL, -c *(Lmax+Lmax+1)*(Lmax+1),Lmax), -c *onecartZ(mxcontL,MxcontL, -c *(Lmax+Lmax+1)*(Lmax+1),Lmax) -cbs powexp holds powers of exponents and meam exponents -cbs coulovp holds overlap of functions with shifted -cbs l-values -c common /coulpow/ coulovlp(MxprimL,MxprimL,-1:1,-1:1, -c *0:Lmax,0:Lmax) -c *powexp(MxprimL,MxprimL,0:Lmax, -c *0:Lmax,0:(Lmax+Lmax+5)), -cbs express AOs in contracted functions - common /AOincont/ AOcoeffs(MxcontL,MxcontL,0:Lmax), -cbs first index: number of contracted function -cbs second index: number of AO -cbs third index: L-value - *occup(MxcontL,0:Lmax),noccorb(0:Lmax) -cbs occupation numbers -cbs first index: number of AO -cbs second index: L-value - common /corelist/ icore(0:Lmax),ikeeporb,ikeeplist(Mxcart), - *nrtofiperIR(8) diff -Nru openmolcas-22.02/src/amfi_util/prefac.f openmolcas-22.10/src/amfi_util/prefac.f --- openmolcas-22.02/src/amfi_util/prefac.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/prefac.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,69 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine prefac(Lmax,preroots,clebsch) - implicit real*8 (a-h,o-z) - dimension preroots(2,0:Lmax), - *clebsch(3,2,-Lmax:Lmax,0:Lmax) -cbs the roots appearing in front of all -cbs the contributions -c write(6,*) 'begin of prefac' - do L=0,Lmax - fact=1d0/sqrt(DBLE(L+L+1)) - preroots(1,L)=sqrt(DBLE(L))*fact - preroots(2,L)=sqrt(DBLE(L+1))*fact - enddo -cbs there are Clebsch-Gordan-Coefficients -cbs which always appear: -cbs -cbs ----- ------ -cbs | | -cbs | l +/- 1 1 | l | -cbs | | | -cbs | | | -cbs | m+/-1,0 -1,1,0 | m | -cbs | | | -cbs | | -cbs ----- ----- -cbs -cbs -cbs array clebsch (3,2,-Lmax:Lmax,0:Lmax) -cbs first index 1: m-1 -cbs 2: m -cbs 3: m+1 -cbs second index 1: l-1 -cbs 2: l+1 -cbs third index m -cbs fourth index l -cbs -c write(6,*),'start to generate CGs' - do L=0,Lmax - L2=L+L - do M=-L,L -c write(6,*) 'L,M: ',L,M - M2=M+M -cbs getCG calculates CG-coeffecients. In order to avoid fractions, -cbs e.g. for spins, arguments are doubled values... - clebsch(1,1,M,L)= - *getCG(L2-2,2,L2,M2-2,2,M2) - clebsch(2,1,M,L)= - *getCG(L2-2,2,L2,M2,0,M2) - clebsch(3,1,M,L)= - *getCG(L2-2,2,L2,M2+2,-2,M2) - clebsch(1,2,M,L)= - *getCG(L2+2,2,L2,M2-2,2,M2) - clebsch(2,2,M,L)= - *getCG(L2+2,2,L2,M2,0,M2) - clebsch(3,2,M,L)= - *getCG(L2+2,2,L2,M2+2,-2,M2) - enddo - enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/prefac.F90 openmolcas-22.10/src/amfi_util/prefac.F90 --- openmolcas-22.02/src/amfi_util/prefac.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/prefac.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,74 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine prefac(Lmax,preroots,clebsch) + +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: Lmax +real(kind=wp), intent(out) :: preroots(2,0:Lmax), clebsch(3,2,-Lmax:Lmax,0:Lmax) +integer(kind=iwp) :: L, L2, M, M2 +real(kind=wp) :: fact +real(kind=wp), external :: getCG + +!bs the roots appearing in front of all +!bs the contributions +!write(u6,*) 'begin of prefac' +do L=0,Lmax + fact = One/sqrt(real(L+L+1,kind=wp)) + preroots(1,L) = sqrt(real(L,kind=wp))*fact + preroots(2,L) = sqrt(real(L+1,kind=wp))*fact +end do +!bs there are Clebsch-Gordan-Coefficients +!bs which always appear: +!bs +!bs ----- ------ +!bs | | +!bs | l +/- 1 1 | l | +!bs | | | +!bs | | | +!bs | m+/-1,0 -1,1,0 | m | +!bs | | | +!bs | | +!bs ----- ----- +!bs +!bs +!bs array clebsch (3,2,-Lmax:Lmax,0:Lmax) +!bs first index 1: m-1 +!bs 2: m +!bs 3: m+1 +!bs second index 1: l-1 +!bs 2: l+1 +!bs third index m +!bs fourth index l + +!write(u6,*),'start to generate CGs' +do L=0,Lmax + L2 = 2*L + do M=-L,L + !write(u6,*) 'L,M: ',L,M + M2 = 2*M + !bs getCG calculates CG-coeffecients. In order to avoid fractions, + !bs e.g. for spins, arguments are doubled values... + clebsch(1,1,M,L) = getCG(L2-2,2,L2,M2-2,2,M2) + clebsch(2,1,M,L) = getCG(L2-2,2,L2,M2,0,M2) + clebsch(3,1,M,L) = getCG(L2-2,2,L2,M2+2,-2,M2) + clebsch(1,2,M,L) = getCG(L2+2,2,L2,M2-2,2,M2) + clebsch(2,2,M,L) = getCG(L2+2,2,L2,M2,0,M2) + clebsch(3,2,M,L) = getCG(L2+2,2,L2,M2+2,-2,M2) + end do +end do + +return + +end subroutine prefac diff -Nru openmolcas-22.02/src/amfi_util/readbas.f openmolcas-22.10/src/amfi_util/readbas.f --- openmolcas-22.02/src/amfi_util/readbas.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/readbas.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,391 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SubRoutine ReadBas(Lhigh,makemean,bonn,breit, - & symmetry,sameorb,AIMP,oneonly,ncont4, - & numballcart,IN,ifinite) -* -* Suposed to read the maximum of l-values, the number of primitive and -* contracted functions, the exponents and contraction coefficients -* - Implicit Real*8 (a-h,o-z) -#include "para.fh" -#include "param.fh" -#include "ired.fh" -#include "Molcas.fh" -#include "stdalloc.fh" - Integer, Allocatable:: nOff(:,:) - Character*4 Word - Character*4 Symmetry -#ifdef _DEBUGPRINT_ - Character*21 chCharge -#endif - Character*54 Stars - Logical MakeMean, Bonn, Breit, SameOrb, AIMP, OneOnly, IfTest -#include "nucleus.fh" - Integer OUT, iBeginIRed(8), iDelperSym(8) - Data IfTest/.False./ -* -#ifdef _DEBUGPRINT_ - IfTest=.True. - chCharge=' Charge of nucleus: ' -#endif - OUT=6 - Stars ='******************************************************' - Bonn =.False. - Breit =.False. - SameOrb =.False. - AIMP =.False. - OneOnly =.False. - MakeMean=.True. -* - If (IfTest) Then - Write(OUT,'(/,/,/,24X,A)') Stars - Write(OUT,'(24X,2A)') '******** Starting Atomic Spin-Orbit MF', - & ' code ********' - Write(OUT,'(24X,A,/,/)') Stars - End If -* - Do I = 0, lMax - iCore(I) = 0 - End Do - Call RdNLst(IN,'AMFI') - 123 Read(IN,'(A4)') Word - If (IfTest) Write(OUT,'(A4)') Word - Call UpCase(Word) - If (WORD.eq.'BONN') Then - Bonn=.True. - GoTo 123 - ElseIf (WORD.eq.'BREI') Then - Breit=.True. - GoTo 123 - ElseIf (WORD.eq.'FINI') Then - iFinite=1 - Read(IN,*) Exp_finite - GoTo 123 - ElseIf (WORD.eq.'SAME') then - SameOrb=.True. - GoTo 123 - ElseIf (WORD.eq.'AIMP') then - AIMP=.True. - Read(IN,*) lDel,(iCore(I),I=0,ldel) - If (IfTest) Then - Write(OUT,*) - Write(OUT,*) 'CORE to be deleted ' - Write(OUT,*) ' L #orbs. ' - Write(OUT,*) - Do I = 0, lDel - Write(OUT,'(2I5)') I,iCore(I) - End Do - End If - GoTo 124 - ElseIf (Word.eq.'ONEO') Then - OneOnly=.True. - Write(OUT,*) ' Only one-electron integrals!!' - Write(OUT,*) ' Probably useful for test-purposes only' - GoTo 123 - End If -* - 124 Continue - If (IfTest) Then - Write(OUT,*) ' AMFI: ' - If (BONN) Then - Write(OUT,*) ' Bonn-approach for spin-other-orbit part' - End If - If (BREIT) Then - Write(OUT,*) ' Breit-Pauli type of the SO operator' - Else - Write(OUT,*) ' Douglas-Kroll type of the SO operator' - End If - If (iFinite.eq.0) Then - Write(OUT,*) ' Point nucleus ' - Else - Write(OUT,*) ' Finite nucleus' - End If - End If -* - Symmetry='D2H' - NumbofSym=8 - If (IfTest) Then - Write(OUT,*) ' Symmetry is D2H' - If (SameOrb) then - Write(OUT,*) ' Same-Orbit only' - Else - Write(OUT,*) ' Other-Orbit included' - End If - End If - Read(IN,*) Charge,Lhigh - If (Lhigh.gt.Lmax) Then - Write(OUT,*) ' Sorry, so far this code deals only ', - & ' with maximum l-values of ',Lmax - Call Abend() - End If -#ifdef _DEBUGPRINT_ - Write(OUT,'(A21,F5.2)') chCharge, Charge -#endif - Call InitiRed - Do iredrun=1,numbofsym - Do Lrun=0,Lhigh - nmbMperIRL(iredrun,Lrun)=0 - End Do - End Do - If (IfTest) Write(OUT,'(/,A)') ' Used SOC basis set: ' - Do Lrun=0,Lhigh - Read(IN,*) nprimit(Lrun),ncontrac(Lrun) - If (IfTest) Then - Write(OUT,'(/,A,I2,A,I2)') ' nExp: ', nprimit(Lrun), - & ' lAng: ',lRun - Write(OUT,'(I3,I3)') nprimit(Lrun),ncontrac(Lrun) - End If - If (nprimit(Lrun).gt.MxprimL) Then - Write(OUT,*) 'To many primitives for L=',Lrun, - & ' increase MxprimL in para.fh or reduce ', - & ' the number of primitives to at least ',MxprimL - Call Abend() - End If - If (ncontrac(Lrun).gt.MxcontL) Then - Write(OUT,*) ' To many contracted fncts for L=',Lrun, - & ' increase MxcontL in para.fh or ', - & ' reduce the number of contracted functions', - & ' to at most ',MxcontL - Call Abend() - End If - If (ncontrac(Lrun).gt.nprimit(Lrun)) Then - Write(OUT,*) ' You have more contracted than ', - & ' uncontracted functions, I don''t believe ', - & ' that. Sorry!! ' - Call Abend() - End If -* -* Read input in MOLCAS-style -* - Read(IN,*) (exponents(ILINE,Lrun),ILINE=1,nprimit(Lrun)) - Do ILINE=1,nprimit(Lrun) - Read(IN,*) (cntscrtch(ILINE,JRUN,Lrun),Jrun=1, - & ncontrac(Lrun)) - End Do -* -* End of reading for the current L-value -* - If (IfTest) Then - Write(OUT,'(5E18.8)') (exponents(ILINE,Lrun), - & ILINE=1,nprimit(Lrun)) - Do Irun = 1, ncontrac(Lrun) - Write(OUT,*) ' orbital : ',irun - Write(OUT,'(6(1X,F12.7))') - & (cntscrtch(I,Irun,Lrun),I=1,nprimit(Lrun)) - End Do - End If -* -* Setting the numbers of cartesians per IR -* - Do iRedRun = 1, NumbofSym - nFunctions(iRedRun,Lrun)=0 - End Do - Do mRun=-Lrun,Lrun - nfunctions(ipow2ired(ipowxyz(1,mrun,Lrun), - & ipowxyz(2,mrun,Lrun),Ipowxyz(3,mrun,Lrun)),Lrun)= - & nfunctions(ipow2ired(ipowxyz(1,mrun,Lrun), - & ipowxyz(2,mrun,Lrun),ipowxyz(3,mrun,Lrun)),Lrun)+ - & ncontrac(Lrun) - End Do - Do mRun=-Lrun,Lrun - nmbMperIRL(ipow2ired(ipowxyz(1,mrun,Lrun), - & ipowxyz(2,mrun,Lrun),Ipowxyz(3,mrun,Lrun)),lruN)= - & nmbMperIRL(ipOw2ired(ipowxyz(1,mrun,Lrun), - & ipowxyz(2,mrun,Lrun),IpowxYz(3,mrun,Lrun)),lruN)+1 - End Do - If (IfTest) Then - Write(OUT,'(A,8I4)') - & ' Number of functions per IR: ',(nfunctions(iredrun,Lrun), - & iredrun=1,numbofsym) - End If - End Do ! End Do for loop over L-values -* - If (IfTest) Then - Write(OUT,*) ' Distribution of M-values' - Do Lrun=0,Lhigh - Write(OUT,*) (nmbMperIRL(nsym,Lrun),nsym=1,numbofsym) - End Do - End If -* - numbofcart=0 - Do lrun=0,Lhigh - numbofcart=numbofcart+(Lrun+Lrun+1)* - & ncontrac(Lrun) - End Do -* - Call mma_allocate(nOff,numbofcart,2,Label='nOff') -* - Do iredrun=1,numbofsym - nfunctperIRED(iredrun)=0 - End Do - Do Lrun=0,Lhigh - Do iredrun=1,numbofsym - nfunctperIRED(iredrun)=nfunctperIRED(iredrun)+ - & nfunctions(iredrun,Lrun) - End Do - End Do - If (IfTest) Then - Write(OUT,'(A,8I3)') - & ' Total number of atomic functions per IRED ', - & (nfunctperIRED(iredrun),iredrun=1,numbofsym) - End If - isum=0 - Do iredrun=1,numbofsym - itotalperIR(iredrun)=nfunctperIRED(iredrun) - isum=isum+itotalperIR(iredrun) - End Do - numballcart=isum - iorbrun=0 - Do iredrun=1,numbofsym - Do inired=1,itotalperIR(iredrun) - iorbrun=iorbrun+1 - IREDoffunctnew(Iorbrun)=iredrun - End Do - End Do - If (IfTest) Then - Write(OUT,'(A,8I3)') - & 'including additional functions per IRED ', - & (itotalperIR(iredrun),iredrun=1,numbofsym) - End If - Do iredrun=1,numbofsym - ibeginIRED(iredrun)=0 - End Do - Do lrun=0,Lhigh - Do mrun=-lrun,lrun - iredLM(mrun,lrun)=ipow2ired(ipowxyz(1,mrun,Lrun), - & ipowxyz(2,mrun,Lrun), - & ipowxyz(3,mrun,Lrun)) - incrLM(mrun,lrun)=ibeginIRED(iredLM(mrun,lrun)) - ibeginIRED(iredLM(mrun,lrUn))= - & ibeginIRED(iredLM(mrun,lrun))+ncontrac(lrun) - EndDo - EndDo - If (IfTest) Then - Do lrun=0,Lhigh - Write(OUT,'(A,I4,A,21I3)') 'L= ',lrun, - & ' shifts inside the IRED', - & (incrLM(mrun,lrun),mrun=-lrun,lrun) - End Do - End If - shiftIRED(1)=0 - Do iredrun=2,numbofsym - shiftIRED(iredrun)=shiftIRED(iredrun-1) - & +itotalperIR(iredrun-1) - End Do - If (IfTest) Then - Write(OUT,'(A,8I4)') 'shifts for the IREDs ', - & (shiftIRED(iredrun),iredrun=1,numbofsym) - Do lrun=0,Lhigh - Do mrun=-Lrun,Lrun - Do irun=1,ncontrac(lrun) - Write(OUT,*) 'L,M,contr funct, absolute number ', - & lrun,mrun,irun,shiftired(iredLM(mrun,lrun))+ - & incrLM(mrun,Lrun)+irun - End Do - End Do - End Do - End If - shiftIRIR(1)=0 - irun=1 - Do ired1=2,numbofsym - Do ired2=1,ired1 - irun=irun+1 - If (ired2.eq.1) Then - shiftIRIR(irun)=shiftIRIR(irun-1)+ - & (itotalperIR(ired1-1)*itotalperIR(ired1-1)+ - & itotalperIR(ired1-1))/2 - Else - shiftIRIR(irun)=shiftIRIR(irun-1)+ - & itotalperIR(ired1)*itotalperIR(ired2-1) - End If - End Do - End Do - Do lrun=0,Lhigh - Do Mrun=-Lrun,Lrun - ired=iredLM(Mrun,Lrun) - ishifter=shiftIRED(ired)+incrLM(mrun,lrun) - Do icart=1,ncontrac(Lrun) - moffunction(ishifter+icart)=Mrun - Loffunction(ishifter+icart)=Lrun - IREDoffunction(ishifter+Icart)=ired - nOff(ishifter+Icart,2)=icart - End Do - End Do - End Do - Do irun = 1, numbofcart - nOff(irun,1)=irun - End Do - Do nsymrun=1,numbofsym - idelpersym(nsymrun)=0 - End Do - Do nsymrun=1,numbofsym - nrtofiperIR(nsymrun)=itotalperIR(nsymrun) - End Do - If (AIMP) Then -* -* Generate list of orbitals to be removed -* - If (IfTest) - & Write(OUT,'(/,A)') ' Core removed for use with AIMP' - ikeeporb=0 - numbprev=0 - Do irun=1,numbofcart -4712 If (irun.eq.1.or.(irun.ge.2.and.noff(irun,1).eq. - & numbprev+1)) Then - Lval=Loffunction(irun) - number=nOff(irun,1) - itype=nOff(irun,2) - If (itype.le.icore(lval)) then - Write(OUT,777) number,itype,lval - idelpersym(IREDoffunction(irun))= - & idelpersym(IREDoffunction(irun))+1 - numbprev=number - Else - ikeeporb=ikeeporb+1 - ikeeplist(ikeeporb)=number - numbprev=number - End If - Else - ikeeporb=ikeeporb+1 - ikeeplist(ikeeporb)=numbprev+1 - numbprev=numbprev+1 - GoTo 4712 - End If - End Do - ikeeporb=0 - Do nsymrun=1,numbofsym - nrtofiperIR(nsymrun)= - & itotalperIR(nsymrun)-idelpersym(nsymrun) - End Do - Do nsymrun=1,numbofsym - ikeeporb=ikeeporb+nrtofiperIR(nsymrun) - End Do - If (IfTest) Then - Write(OUT,'(A,8I3)') - & ' Number of funct. per IRED after removing core: ', - & (nrtofiperIR(iredrun),iredrun=1,numbofsym) - Write(OUT,'(I4,A)') ikeeporb, - & ' orbitals left after deleting core' - End If - End If - nmax=max(6,ncontrac(0)) - Do lrun=1,Lhigh - nmax=max(nmax,ncontrac(lrun)) - End Do - ncont4=nmax*nmax*nmax*nmax -* - Call mma_deallocate(nOff) -* - Return -777 Format(' Orbital number ',I4,' is the ',I3,'th of L-value ',I3, - & ' it will be removed !!!') - End diff -Nru openmolcas-22.02/src/amfi_util/readbas.F90 openmolcas-22.10/src/amfi_util/readbas.F90 --- openmolcas-22.02/src/amfi_util/readbas.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/readbas.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,336 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ReadBas(Lhigh,makemean,bonn,breit,symmetry,sameorb,AIMP,oneonly,ncont4,numballcart,LUIN,ifinite) +! Supposed to read the maximum of l-values, the number of primitive and +! contracted functions, the exponents and contraction coefficients + +use AMFI_global, only: charge, cntscrtch, Exp_finite, exponents, icore, ikeeplist, ikeeporb, incrLM, ipow2ired, ipowxyz, iredLM, & + iredoffunctnew, itotalperIR, Lmax, Loffunction, Moffunction, MxcontL, MxprimL, ncontrac, nprimit, & + nrtofiperIR, numbofsym, shiftIRED, shiftIRIR +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: iwp, u6 + +implicit none +integer(kind=iwp), intent(out) :: Lhigh, ncont4, numballcart, ifinite +logical(kind=iwp), intent(out) :: MakeMean, Bonn, Breit, SameOrb, AIMP, OneOnly +character(len=4), intent(out) :: Symmetry +integer(kind=iwp), intent(in) :: LUIN +integer(kind=iwp) :: I, iBeginIRed(8), icart, iDelperSym(8), ILINE, inired, iorbrun, ired, ired1, ired2, iredrun, Irun, ishifter, & + isum, itype, JRUN, lDel, Lrun, Lval, mRun, nfunctperIRED(8), nmax, nsymrun, numbofcart, numbprev, numbr +character(len=54) :: Stars +character(len=4) :: Word +integer(kind=iwp), allocatable :: IREDoffunction(:), nfunctions(:,:), nmbMperIRL(:,:), nOff(:,:) +#ifdef _DEBUGPRINT_ +character(len=21) :: chCharge +#define _TEST_ .true. +#else +#define _TEST_ .false. +#endif +logical(kind=iwp), parameter :: IfTest = _TEST_ + +#ifdef _DEBUGPRINT_ +chCharge = ' Charge of nucleus: ' +#endif +Stars = '******************************************************' +Bonn = .false. +Breit = .false. +SameOrb = .false. +AIMP = .false. +OneOnly = .false. +MakeMean = .true. +ifinite = 0 + +if (IfTest) then + write(u6,'(/,/,/,24X,A)') Stars + write(u6,'(24X,2A)') '******** Starting Atomic Spin-Orbit MF code ********' + write(u6,'(24X,A,/,/)') Stars +end if + +iCore(:) = 0 +call RdNLst(LUIN,'AMFI') +do + read(LUIN,'(A4)') Word + if (IfTest) write(u6,'(A4)') Word + call UpCase(Word) + select case (WORD) + case ('BONN') + Bonn = .true. + case ('BREI') + Breit = .true. + case ('FINI') + iFinite = 1 + read(LUIN,*) Exp_finite + case ('SAME') + SameOrb = .true. + case ('AIMP') + AIMP = .true. + read(LUIN,*) lDel,(iCore(I),I=0,ldel) + if (IfTest) then + write(u6,*) + write(u6,*) 'CORE to be deleted ' + write(u6,*) ' L #orbs. ' + write(u6,*) + do I=0,lDel + write(u6,'(2I5)') I,iCore(I) + end do + end if + exit + case ('ONEO') + OneOnly = .true. + write(u6,*) ' Only one-electron integrals!!' + write(u6,*) ' Probably useful for test-purposes only' + case default + exit + end select +end do + +if (IfTest) then + write(u6,*) ' AMFI: ' + if (BONN) then + write(u6,*) ' Bonn-approach for spin-other-orbit part' + end if + if (BREIT) then + write(u6,*) ' Breit-Pauli type of the SO operator' + else + write(u6,*) ' Douglas-Kroll type of the SO operator' + end if + if (iFinite == 0) then + write(u6,*) ' Point nucleus ' + else + write(u6,*) ' Finite nucleus' + end if +end if + +Symmetry = 'D2H' +NumbofSym = 8 +if (IfTest) then + write(u6,*) ' Symmetry is D2H' + if (SameOrb) then + write(u6,*) ' Same-Orbit only' + else + write(u6,*) ' Other-Orbit included' + end if +end if +read(LUIN,*) Charge,Lhigh +if (Lhigh > Lmax) then + write(u6,*) ' Sorry, so far this code deals only with maximum l-values of ',Lmax + call Abend() +end if +#ifdef _DEBUGPRINT_ +write(u6,'(A21,F5.2)') chCharge,Charge +#endif +call InitiRed(Symmetry) +call mma_allocate(nfunctions,[1,numbofsym],[0,Lhigh],label='nfunctions') +call mma_allocate(nmbMperIRL,[1,numbofsym],[0,Lhigh],label='nmbMperIRL') +nmbMperIRL(:,:) = 0 +if (IfTest) write(u6,'(/,A)') ' Used SOC basis set: ' +do Lrun=0,Lhigh + read(LUIN,*) nprimit(Lrun),ncontrac(Lrun) + if (IfTest) then + write(u6,'(/,A,I2,A,I2)') ' nExp: ',nprimit(Lrun),' lAng: ',lRun + write(u6,'(I3,I3)') nprimit(Lrun),ncontrac(Lrun) + end if + if (nprimit(Lrun) > MxprimL) then + write(u6,*) 'Too many primitives for L=',Lrun, & + ' increase MxprimL in amfi_global or reduce the number of primitives to at least ',MxprimL + call Abend() + end if + if (ncontrac(Lrun) > MxcontL) then + write(u6,*) ' Too many contracted functions for L=',Lrun, & + ' increase MxcontL in amfi_global or reduce the number of contracted functions to at most ',MxcontL + call Abend() + end if + if (ncontrac(Lrun) > nprimit(Lrun)) then + write(u6,*) ' You have more contracted than uncontracted functions, I do not believe that. Sorry! ' + call Abend() + end if + + ! Read input in MOLCAS-style + + read(LUIN,*) (exponents(ILINE,Lrun),ILINE=1,nprimit(Lrun)) + do ILINE=1,nprimit(Lrun) + read(LUIN,*) (cntscrtch(ILINE,JRUN,Lrun),Jrun=1,ncontrac(Lrun)) + end do + + ! End of reading for the current L-value + + if (IfTest) then + write(u6,'(5E18.8)') (exponents(ILINE,Lrun),ILINE=1,nprimit(Lrun)) + do Irun=1,ncontrac(Lrun) + write(u6,*) ' orbital : ',irun + write(u6,'(6(1X,F12.7))') (cntscrtch(I,Irun,Lrun),I=1,nprimit(Lrun)) + end do + end if + + ! Setting the numbers of cartesians per IR + + do iRedRun=1,NumbofSym + nFunctions(iRedRun,Lrun) = 0 + end do + do mRun=-Lrun,Lrun + nfunctions(ipow2ired(ipowxyz(1,mrun,Lrun),ipowxyz(2,mrun,Lrun),ipowxyz(3,mrun,Lrun)),Lrun) = & + nfunctions(ipow2ired(ipowxyz(1,mrun,Lrun),ipowxyz(2,mrun,Lrun),ipowxyz(3,mrun,Lrun)),Lrun)+ncontrac(Lrun) + end do + do mRun=-Lrun,Lrun + nmbMperIRL(ipow2ired(ipowxyz(1,mrun,Lrun),ipowxyz(2,mrun,Lrun),ipowxyz(3,mrun,Lrun)),Lrun) = & + nmbMperIRL(ipOw2ired(ipowxyz(1,mrun,Lrun),ipowxyz(2,mrun,Lrun),ipowxYz(3,mrun,Lrun)),Lrun)+1 + end do + if (IfTest) write(u6,'(A,8I4)') ' Number of functions per IR: ',(nfunctions(iredrun,Lrun),iredrun=1,numbofsym) +end do ! End Do for loop over L-values + +if (IfTest) then + write(u6,*) ' Distribution of M-values' + do Lrun=0,Lhigh + write(u6,*) nmbMperIRL(:,Lrun) + end do +end if + +numbofcart = 0 +do lrun=0,Lhigh + numbofcart = numbofcart+(Lrun+Lrun+1)*ncontrac(Lrun) +end do + +call mma_allocate(nOff,numbofcart,2,Label='nOff') + +nfunctperIRED(1:numbofsym) = 0 +do Lrun=0,Lhigh + nfunctperIRED(1:numbofsym) = nfunctperIRED(1:numbofsym)+nfunctions(1:numbofsym,Lrun) +end do +call mma_deallocate(nfunctions) +call mma_deallocate(nmbMperIRL) +if (IfTest) write(u6,'(A,8I3)') ' Total number of atomic functions per IRED ',(nfunctperIRED(iredrun),iredrun=1,numbofsym) +itotalperIR(1:numbofsym) = nfunctperIRED(1:numbofsym) +isum = 0 +do iredrun=1,numbofsym + isum = isum+itotalperIR(iredrun) +end do +numballcart = isum +iorbrun = 0 +do iredrun=1,numbofsym + do inired=1,itotalperIR(iredrun) + iorbrun = iorbrun+1 + IREDoffunctnew(iorbrun) = iredrun + end do +end do +if (IfTest) then + write(u6,'(A,8I3)') 'including additional functions per IRED ',(itotalperIR(iredrun),iredrun=1,numbofsym) +end if +ibeginIRED(1:numbofsym) = 0 +do lrun=0,Lhigh + do mrun=-lrun,lrun + iredLM(mrun,lrun) = ipow2ired(ipowxyz(1,mrun,Lrun),ipowxyz(2,mrun,Lrun),ipowxyz(3,mrun,Lrun)) + incrLM(mrun,lrun) = ibeginIRED(iredLM(mrun,lrun)) + ibeginIRED(iredLM(mrun,lrUn)) = ibeginIRED(iredLM(mrun,lrun))+ncontrac(lrun) + end do +end do +if (IfTest) then + do lrun=0,Lhigh + write(u6,'(A,I4,A,21I3)') 'L= ',lrun,' shifts inside the IRED',(incrLM(mrun,lrun),mrun=-lrun,lrun) + end do +end if +shiftIRED(1) = 0 +do iredrun=1,numbofsym-1 + shiftIRED(iredrun+1) = shiftIRED(iredrun)+itotalperIR(iredrun) +end do +if (IfTest) then + write(u6,'(A,8I4)') 'shifts for the IREDs ',(shiftIRED(iredrun),iredrun=1,numbofsym) + do lrun=0,Lhigh + do mrun=-Lrun,Lrun + do irun=1,ncontrac(lrun) + write(u6,*) 'L,M,contr funct, absolute number ',lrun,mrun,irun,shiftired(iredLM(mrun,lrun))+incrLM(mrun,Lrun)+irun + end do + end do + end do +end if +shiftIRIR(1) = 0 +irun = 1 +do ired1=2,numbofsym + do ired2=1,ired1 + irun = irun+1 + if (ired2 == 1) then + shiftIRIR(irun) = shiftIRIR(irun-1)+(itotalperIR(ired1-1)*itotalperIR(ired1-1)+itotalperIR(ired1-1))/2 + else + shiftIRIR(irun) = shiftIRIR(irun-1)+itotalperIR(ired1)*itotalperIR(ired2-1) + end if + end do +end do +call mma_allocate(IREDoffunction,numbofcart,label='IREDoffunction') +do lrun=0,Lhigh + do Mrun=-Lrun,Lrun + ired = iredLM(Mrun,Lrun) + ishifter = shiftIRED(ired)+incrLM(mrun,lrun) + do icart=1,ncontrac(Lrun) + Moffunction(ishifter+icart) = Mrun + Loffunction(ishifter+icart) = Lrun + IREDoffunction(ishifter+Icart) = ired + nOff(ishifter+Icart,2) = icart + end do + end do +end do +do irun=1,numbofcart + nOff(irun,1) = irun +end do +idelpersym(1:numbofsym) = 0 +nrtofiperIR(1:numbofsym) = itotalperIR(1:numbofsym) +if (AIMP) then + + ! Generate list of orbitals to be removed + + if (IfTest) write(u6,'(/,A)') ' Core removed for use with AIMP' + ikeeporb = 0 + numbprev = 0 + do irun=1,numbofcart + do + if ((irun == 1) .or. ((irun >= 2) .and. (noff(irun,1) == numbprev+1))) then + Lval = Loffunction(irun) + numbr = nOff(irun,1) + itype = nOff(irun,2) + if (itype <= iCore(lval)) then + write(u6,777) numbr,itype,lval + idelpersym(IREDoffunction(irun)) = idelpersym(IREDoffunction(irun))+1 + numbprev = numbr + else + ikeeporb = ikeeporb+1 + ikeeplist(ikeeporb) = numbr + numbprev = numbr + end if + exit + end if + ikeeporb = ikeeporb+1 + ikeeplist(ikeeporb) = numbprev+1 + numbprev = numbprev+1 + end do + end do + ikeeporb = 0 + nrtofiperIR(1:numbofsym) = itotalperIR(1:numbofsym)-idelpersym(1:numbofsym) + do nsymrun=1,numbofsym + ikeeporb = ikeeporb+nrtofiperIR(nsymrun) + end do + if (IfTest) then + write(u6,'(A,8I3)') ' Number of funct. per IRED after removing core: ',(nrtofiperIR(iredrun),iredrun=1,numbofsym) + write(u6,'(I4,A)') ikeeporb,' orbitals left after deleting core' + end if +end if +call mma_deallocate(IREDoffunction) +nmax = max(6,ncontrac(0)) +do lrun=1,Lhigh + nmax = max(nmax,ncontrac(lrun)) +end do +ncont4 = nmax*nmax*nmax*nmax + +call mma_deallocate(nOff) + +return + +777 format(' Orbital number ',I4,' is the ',I3,'th of L-value ',I3,' it will be removed !!!') + +end subroutine ReadBas diff -Nru openmolcas-22.02/src/amfi_util/regge3j.f openmolcas-22.10/src/amfi_util/regge3j.f --- openmolcas-22.02/src/amfi_util/regge3j.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/regge3j.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,289 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - real*8 function regge3j( - *j1, ! integer 2*j1 - *j2, ! integer 2*j2 - *j3, ! integer 2*j3 - *m1, ! integer 2*m1 - *m2, ! integer 2*m2 - *m3) ! integer 2*m3 -cbs uses magic square of regge (see Lindner pp. 38-39) -cbs -cbs --- --- -cbs | | -cbs | -j1+j2+j3 j1-j2+j3 j1+j2-j3 | -cbs | | -cbs | | -cbs | j1-m1 j2-m2 j3-m3 | -cbs | | -cbs | | -cbs | j1+m1 j2+m2 j3+m3 | -cbs | | -cbs --- --- -cbs - implicit real*8(a-h,o-z) - dimension MAT(3,3) -CBS logical testup,testdown - Integer facul,prim,nprim,iwork - parameter (nprim=11,mxLinRE=36) -cbs nprim is the number of prime-numbers - dimension facul(nprim,0:mxLinRE),prim(nprim), - *iwork(nprim),ihigh(0:mxLinRE) - data prim /2,3,5,7,11,13,17,19,23,29,31/ !prime numbers -c -c decompose facultatives into powers of prime numbers -c - Data facul / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - > 0, 0 ,0, 0, 0, 0, 0, 0, 0, 0, 0, - > 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - > 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, - > 3, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, - > 3, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, - > 4, 2, 1, 0, 0, 0, 0, 0, 0, 0, 0, - > 4, 2, 1, 1, 0, 0, 0, 0, 0, 0, 0, - > 7, 2, 1, 1, 0, 0, 0, 0, 0, 0, 0, - > 7, 4, 1, 1, 0, 0, 0, 0, 0, 0, 0, - > 8, 4, 2, 1, 0, 0, 0, 0, 0, 0, 0, - > 8, 4, 2, 1, 1, 0, 0, 0, 0, 0, 0, - > 10, 5, 2, 1, 1, 0, 0, 0, 0, 0, 0, - > 10, 5, 2, 1, 1, 1, 0, 0, 0, 0, 0, - > 11, 5, 2, 2, 1, 1, 0, 0, 0, 0, 0, - > 11, 6, 3, 2, 1, 1, 0, 0, 0, 0, 0, - > 15, 6, 3, 2, 1, 1, 0, 0, 0, 0, 0, - > 15, 6, 3, 2, 1, 1, 1, 0, 0, 0, 0, - > 16, 8, 3, 2, 1, 1, 1, 0, 0, 0, 0, - > 16, 8, 3, 2, 1, 1, 1, 1, 0, 0, 0, - > 18, 8, 4, 2, 1, 1, 1, 1, 0, 0, 0, - > 18, 9, 4, 3, 1, 1, 1, 1, 0, 0, 0, - > 19, 9, 4, 3, 2, 1, 1, 1, 0, 0, 0, - > 19, 9, 4, 3, 2, 1, 1, 1, 1, 0, 0, - > 22,10, 4, 3, 2, 1, 1, 1, 1, 0, 0, - > 22,10, 6, 3, 2, 1, 1, 1, 1, 0, 0, - > 23,10, 6, 3, 2, 2, 1, 1, 1, 0, 0, - > 23,13, 6, 3, 2, 2, 1, 1, 1, 0, 0, - > 25,13, 6, 4, 2, 2, 1, 1, 1, 0, 0, - > 25,13, 6, 4, 2, 2, 1, 1, 1, 1, 0, - > 26,14, 7, 4, 2, 2, 1, 1, 1, 1, 0, - > 26,14, 7, 4, 2, 2, 1, 1, 1, 1, 1, - > 31,14, 7, 4, 2, 2, 1, 1, 1, 1, 1, - > 31,15, 7, 4, 3, 2, 1, 1, 1, 1, 1, - > 32,15, 7, 4, 3, 3, 1, 1, 1, 1, 1, - > 32,15, 8, 5, 3, 3, 1, 1, 1, 1, 1, - > 34,17, 8, 5, 3, 3, 1, 1, 1, 1, 1/ -c - data ihigh /0,0,1,2,2,3,3,4,4,4,4,5,5, - > 6,6,6,6,7,7,8,8,8,8,9,9,9, - > 9,9,9,10,10,11,11,11,11,11,11/ -cbs facul, integer array (nprim,0:mxLinRE) prime-expansion of factorials -cbs mxLinRE, integer max. number for facul is given -cbs nprim, number of primes for expansion of factorials -cbs prim, integer array with the first nprim prime numbers -cbs iwork) integer array of size nprim - regge3j=0d0 -c write(6,'(A24,6I3)') '3J to be calculated for ', -c *j1,j2,j3,m1,m2,m3 -cbs quick check if =/= 0 at all - icheck=m1+m2+m3 - if (icheck.ne.0) then -c write(6,*) 'sum over m =/= 0' - return - endif -cbs check triangular relation (|j1-j2|<= j3 <= j1+j2 ) - imini=iabs(j1-j2) - imaxi=j1+j2 - if (j3.lt.imini.or.j3.gt.imaxi) then -c write(6,*) 'triangular relation not fulfilled' - return - endif -cbs quick check if =/= 0 at all end -cbs -cbs 3J-symbol is not zero by simple rules -cbs -cbs initialize MAT - MAT(1,1) =-j1+j2+j3 - MAT(2,1) =j1-m1 - MAT(3,1) =j1+m1 - MAT(1,2) =j1-j2+j3 - MAT(2,2) =j2-m2 - MAT(3,2) =j2+m2 - MAT(1,3) =j1+j2-j3 - MAT(2,3) =j3-m3 - MAT(3,3) =j3+m3 - do I=1,3 - do J=1,3 -cbs check for even numbers (2*integer) and positive or zero - if (mod(MAT(J,I),2).ne.0.or.MAT(J,I).lt.0) then -c write(6,*) 'J,I,MAT(J,I): ',J,I,MAT(J,I) - return - endif - MAT(J,I)=MAT(J,I)/2 - if (Mat(j,i).gt.mxLinRE) - *Call SysAbendMsg('regge3j','increase mxLinRE for regge3j',' ') - enddo - enddo - Isigma=(j1+j2+j3)/2 -cbs check the magic sums - do I=1,3 - IROW=0 - ICOL=0 - do J=1,3 - IROW=IROW+MAT(I,J) - ICOL=ICOL+MAT(J,I) - enddo - if (IROW.ne.Isigma.or.ICOL.ne.Isigma) then -c write(6,*) 'I,IROW,ICOL ',I,IROW,ICOL - return - endif - enddo -cbs if j1+j2+j3 is odd: check for equal rows or columns - Isign=1 - if (iabs(mod(Isigma,2)).eq.1) then - isign=-1 - do I=1,3 - do J=I+1,3 - if (MAT(1,I).eq.MAT(1,J).and. - * MAT(2,I).eq.MAT(2,J).and. - * MAT(3,I).eq.MAT(3,J)) return - if (MAT(I,1).eq.MAT(J,1).and. - * MAT(I,2).eq.MAT(J,2).and. - * MAT(I,3).eq.MAT(J,3)) return - enddo - enddo - endif -cbs look for the lowest element indices: IFIRST,ISECOND - imini=MAT(1,1) - IFIRST=1 - ISECOND=1 - do I=1,3 - do J=1,3 - if (MAT(J,I).lt.imini) then - IFIRST=J - ISECOND=I - imini=MAT(J,I) - endif - enddo - enddo -c write(6,*) 'Matrix before commuting vectors' - do ibm=1,3 -c write(6,'(3I5)') (Mat(ibm,j),j=1,3) - enddo - if (IFIRST.ne.1) then !interchange rows -c write(6,*) 'IFIRST = ',ifirst - do I=1,3 - IDUMMY=MAT(1,I) - MAT(1,I)=MAT(IFIRST,I) - MAT(IFIRST,I)=IDUMMY - enddo - endif - if (ISECOND.ne.1) then !interchange columns -c write(6,*) 'ISECOND = ',isecond - do I=1,3 - IDUMMY=MAT(I,1) - MAT(I,1)=MAT(I,ISECOND) - MAT(I,ISECOND)=IDUMMY - enddo - endif -cbs lowest element is now on (1,1) -c write(6,*) 'Matrix after commuting vectors' -c do ibm=1,3 -c write(6,'(3I5)') (Mat(ibm,j),j=1,3) -c enddo -cbs begin to calculate Sum over s_n -cbs first the simple cases - if (Mat(1,1).eq.0) then - isum=1 - elseif (Mat(1,1).eq.1) then - isum=Mat(2,3)*Mat(3,2)-Mat(2,2)*Mat(3,3) - elseif (Mat(1,1).eq.2) then - isum=Mat(2,3)*(Mat(2,3)-1)*Mat(3,2)*(Mat(3,2)-1)- - *2*Mat(2,3)*Mat(3,2)*Mat(2,2)*Mat(3,3)+ - *Mat(2,2)*(Mat(2,2)-1)*Mat(3,3)*(Mat(3,3)-1) - else ! all the cases with Mat(1,1) >= 3 - Icoeff=1 - do Ibm=Mat(3,2)-Mat(1,1)+1,Mat(3,2) - icoeff=icoeff*ibm - enddo - do Ibm=Mat(2,3)-Mat(1,1)+1,Mat(2,3) - icoeff=icoeff*ibm - enddo - isum=icoeff - do Icount=1,MAT(1,1) - icoeff=-icoeff*(Mat(1,1)+1-icount)*(Mat(2,2)+1-icount)* - * (Mat(3,3)+1-icount) - Idenom=icount*(Mat(2,3)-Mat(1,1)+icount)* - * (Mat(3,2)-Mat(1,1)+icount) - icoeff=icoeff/Idenom - isum=isum+icoeff - enddo - endif -cbs additional sign from interchanging rows or columns - if (ifirst.ne.1) isum=isum*isign - if (isecond.ne.1) isum=isum*isign -c write(6,*) 'isum = ',isum -cbs Mat(2,3)+Mat(3,2) -cbs (-) - if (iabs(mod((Mat(2,3)+Mat(3,2)),2)).eq.1) isum=-isum -cbs final factor - LIMIT=ihigh(max(Mat(1,1),Mat(1,2),Mat(1,3), - *Mat(2,1),Mat(2,2),Mat(2,3),Mat(3,1),Mat(3,2), - *Mat(3,3),(Isigma+1))) - do I=1,LIMIT - iwork(I)=facul(I,Mat(1,2))+facul(I,Mat(2,1))+ - *facul(I,Mat(3,1))+facul(I,Mat(1,3))- - *facul(I,Mat(1,1))-facul(I,Mat(2,2))- - *facul(I,Mat(3,3))-facul(I,(Isigma+1))- - *facul(I,Mat(2,3))-facul(I,Mat(3,2)) - enddo -c write(6,*) 'Iwork: ',(iwork(i),i=1,LIMIT) - factor=1d0 -cbs iup=1 -CBS idown=1 -CBS testup=.true. -CBS testdown=.true. -CBS do I=1,LIMIT -CBS do J=1,iwork(I) -CBS iup=iup*prim(i) -CBS if (iup.lt.0) testup=.false. !check for Integer overflow -CBS enddo -CBS Enddo -CBS up=DBLE(iup) -CBS if(.not.testup) then ! if the integers did not run correctly - up=1d0 - do I=1,LIMIT - do J=1,iwork(I) - up=up*DBLE(prim(i)) - enddo - enddo -CBS endif -CBS do I=1,LIMIT -CBS do J=1,-iwork(I) -CBS idown=idown*prim(i) -CBS if (idown.lt.0) testdown=.false. -CBS enddo -CBS enddo -CBS down=DBLE(idown) -CBS if(.not.testdown) then - down=1d0 - do I=1,LIMIT - do J=1,-iwork(I) - down=down*DBLE(prim(i)) - enddo - enddo -CBS endif -c if (.not.(testup.and.testdown)) then -c write(6,*) 'j1,j2,j3,m1,m2,m3 ',j1,j2,j3,m1,m2,m3 -c write(6,*) 'iup,idown ',iup,idown,'up,down ',up,down -c endif - factor=factor*up/down -cbs final result - regge3j=sqrt(factor)*DBLE(isum) - return - end diff -Nru openmolcas-22.02/src/amfi_util/regge3j.F90 openmolcas-22.10/src/amfi_util/regge3j.F90 --- openmolcas-22.02/src/amfi_util/regge3j.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/regge3j.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,273 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +function regge3j(j1,j2,j3,m1,m2,m3) +!bs uses magic square of regge (see Lindner pp. 38-39) +!bs +!bs --- --- +!bs | | +!bs | -j1+j2+j3 j1-j2+j3 j1+j2-j3 | +!bs | | +!bs | | +!bs | j1-m1 j2-m2 j3-m3 | +!bs | | +!bs | | +!bs | j1+m1 j2+m2 j3+m3 | +!bs | | +!bs --- --- + +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +real(kind=wp) :: regge3j +integer(kind=iwp), intent(in) :: j1, j2, j3, m1, m2, m3 +integer(kind=iwp), parameter :: mxLinRE = 36, nprim = 11 +integer(kind=iwp) :: I, ibm, icheck, icoeff, ICOL, icount, Idenom, IDUMMY, IFIRST, imaxi, imini, IROW, ISECOND, Isigma, isgn, & + isum, iwork(nprim), J, LIMIT, MAT(3,3) +real(kind=wp) :: down, factor, up +!BS logical(kind=iwp) :: testup,testdown +! decompose factorials into powers of prime numbers +integer(kind=iwp), parameter :: facul(nprim,0:mxLinRE) = reshape([0,0,0,0,0,0,0,0,0,0,0, & + 0,0,0,0,0,0,0,0,0,0,0, & + 1,0,0,0,0,0,0,0,0,0,0, & + 1,1,0,0,0,0,0,0,0,0,0, & + 3,1,0,0,0,0,0,0,0,0,0, & + 3,1,1,0,0,0,0,0,0,0,0, & + 4,2,1,0,0,0,0,0,0,0,0, & + 4,2,1,1,0,0,0,0,0,0,0, & + 7,2,1,1,0,0,0,0,0,0,0, & + 7,4,1,1,0,0,0,0,0,0,0, & + 8,4,2,1,0,0,0,0,0,0,0, & + 8,4,2,1,1,0,0,0,0,0,0, & + 10,5,2,1,1,0,0,0,0,0,0, & + 10,5,2,1,1,1,0,0,0,0,0, & + 11,5,2,2,1,1,0,0,0,0,0, & + 11,6,3,2,1,1,0,0,0,0,0, & + 15,6,3,2,1,1,0,0,0,0,0, & + 15,6,3,2,1,1,1,0,0,0,0, & + 16,8,3,2,1,1,1,0,0,0,0, & + 16,8,3,2,1,1,1,1,0,0,0, & + 18,8,4,2,1,1,1,1,0,0,0, & + 18,9,4,3,1,1,1,1,0,0,0, & + 19,9,4,3,2,1,1,1,0,0,0, & + 19,9,4,3,2,1,1,1,1,0,0, & + 22,10,4,3,2,1,1,1,1,0,0, & + 22,10,6,3,2,1,1,1,1,0,0, & + 23,10,6,3,2,2,1,1,1,0,0, & + 23,13,6,3,2,2,1,1,1,0,0, & + 25,13,6,4,2,2,1,1,1,0,0, & + 25,13,6,4,2,2,1,1,1,1,0, & + 26,14,7,4,2,2,1,1,1,1,0, & + 26,14,7,4,2,2,1,1,1,1,1, & + 31,14,7,4,2,2,1,1,1,1,1, & + 31,15,7,4,3,2,1,1,1,1,1, & + 32,15,7,4,3,3,1,1,1,1,1, & + 32,15,8,5,3,3,1,1,1,1,1, & + 34,17,8,5,3,3,1,1,1,1,1 & + ],shape(facul)), & + ihigh(0:mxLinRE) = [0,0,1,2,2,3,3,4,4,4,4,5,5,6,6,6,6,7,7,8,8,8,8,9,9,9,9,9,9,10,10,11,11,11,11, & + 11,11], & + prim(nprim) = [2,3,5,7,11,13,17,19,23,29,31] !prime numbers +!bs facul, integer array (nprim,0:mxLinRE) prime-expansion of factorials +!bs mxLinRE, integer max. number for facul is given +!bs nprim, number of primes for expansion of factorials +!bs prim, integer array with the first nprim prime numbers +!bs iwork) integer array of size nprim + +regge3j = Zero +!write(u6,'(A24,6I3)') '3J to be calculated for ',j1,j2,j3,m1,m2,m3 +!bs quick check if =/= 0 at all +icheck = m1+m2+m3 +if (icheck /= 0) then + !write(u6,*) 'sum over m =/= 0' + return +end if +!bs check triangular relation (|j1-j2|<= j3 <= j1+j2 ) +imini = abs(j1-j2) +imaxi = j1+j2 +if ((j3 < imini) .or. (j3 > imaxi)) then + !write(u6,*) 'triangular relation not fulfilled' + return +end if +!bs quick check if =/= 0 at all end +!bs +!bs 3J-symbol is not zero by simple rules +!bs +!bs initialize MAT +MAT(1,1) = -j1+j2+j3 +MAT(2,1) = j1-m1 +MAT(3,1) = j1+m1 +MAT(1,2) = j1-j2+j3 +MAT(2,2) = j2-m2 +MAT(3,2) = j2+m2 +MAT(1,3) = j1+j2-j3 +MAT(2,3) = j3-m3 +MAT(3,3) = j3+m3 +do I=1,3 + do J=1,3 + !bs check for even numbers (2*integer) and positive or zero + if ((mod(MAT(J,I),2) /= 0) .or. (MAT(J,I) < 0)) then + !write(u6,*) 'J,I,MAT(J,I): ',J,I,MAT(J,I) + return + end if + MAT(J,I) = MAT(J,I)/2 + if (Mat(j,i) > mxLinRE) call SysAbendMsg('regge3j','increase mxLinRE for regge3j',' ') + end do +end do +Isigma = (j1+j2+j3)/2 +!bs check the magic sums +do I=1,3 + IROW = 0 + ICOL = 0 + do J=1,3 + IROW = IROW+MAT(I,J) + ICOL = ICOL+MAT(J,I) + end do + if ((IROW /= Isigma) .or. (ICOL /= Isigma)) then + !write(u6,*) 'I,IROW,ICOL ',I,IROW,ICOL + return + end if +end do +!bs if j1+j2+j3 is odd: check for equal rows or columns +isgn = 1 +if (abs(mod(Isigma,2)) == 1) then + isgn = -1 + do I=1,3 + do J=I+1,3 + if ((MAT(1,I) == MAT(1,J)) .and. (MAT(2,I) == MAT(2,J)) .and. (MAT(3,I) == MAT(3,J))) return + if ((MAT(I,1) == MAT(J,1)) .and. (MAT(I,2) == MAT(J,2)) .and. (MAT(I,3) == MAT(J,3))) return + end do + end do +end if +!bs look for the lowest element indices: IFIRST,ISECOND +imini = MAT(1,1) +IFIRST = 1 +ISECOND = 1 +do I=1,3 + do J=1,3 + if (MAT(J,I) < imini) then + IFIRST = J + ISECOND = I + imini = MAT(J,I) + end if + end do +end do +!write(u6,*) 'Matrix before commuting vectors' +!do ibm=1,3 +! write(u6,'(3I5)') (Mat(ibm,j),j=1,3) +!end do +if (IFIRST /= 1) then !interchange rows + !write(u6,*) 'IFIRST = ',ifirst + do I=1,3 + IDUMMY = MAT(1,I) + MAT(1,I) = MAT(IFIRST,I) + MAT(IFIRST,I) = IDUMMY + end do +end if +if (ISECOND /= 1) then !interchange columns + !write(u6,*) 'ISECOND = ',isecond + do I=1,3 + IDUMMY = MAT(I,1) + MAT(I,1) = MAT(I,ISECOND) + MAT(I,ISECOND) = IDUMMY + end do +end if +!bs lowest element is now on (1,1) +!write(u6,*) 'Matrix after commuting vectors' +!do ibm=1,3 +! write(u6,'(3I5)') (Mat(ibm,j),j=1,3) +!end do +!bs begin to calculate Sum over s_n +!bs first the simple cases +if (Mat(1,1) == 0) then + isum = 1 +else if (Mat(1,1) == 1) then + isum = Mat(2,3)*Mat(3,2)-Mat(2,2)*Mat(3,3) +else if (Mat(1,1) == 2) then + isum = Mat(2,3)*(Mat(2,3)-1)*Mat(3,2)*(Mat(3,2)-1)-2*Mat(2,3)*Mat(3,2)*Mat(2,2)*Mat(3,3)+Mat(2,2)*(Mat(2,2)-1)*Mat(3,3)* & + (Mat(3,3)-1) +else ! all the cases with Mat(1,1) >= 3 + icoeff = 1 + do ibm=Mat(3,2)-Mat(1,1)+1,Mat(3,2) + icoeff = icoeff*ibm + end do + do ibm=Mat(2,3)-Mat(1,1)+1,Mat(2,3) + icoeff = icoeff*ibm + end do + isum = icoeff + do icount=1,MAT(1,1) + icoeff = -icoeff*(Mat(1,1)+1-icount)*(Mat(2,2)+1-icount)*(Mat(3,3)+1-icount) + Idenom = icount*(Mat(2,3)-Mat(1,1)+icount)*(Mat(3,2)-Mat(1,1)+icount) + icoeff = icoeff/Idenom + isum = isum+icoeff + end do +end if +!bs additional sign from interchanging rows or columns +if (ifirst /= 1) isum = isum*isgn +if (isecond /= 1) isum = isum*isgn +!write(u6,*) 'isum = ',isum +!bs Mat(2,3)+Mat(3,2) +!bs (-) +if (abs(mod((Mat(2,3)+Mat(3,2)),2)) == 1) isum = -isum +!bs final factor +LIMIT = ihigh(max(Mat(1,1),Mat(1,2),Mat(1,3),Mat(2,1),Mat(2,2),Mat(2,3),Mat(3,1),Mat(3,2),Mat(3,3),(Isigma+1))) +do I=1,LIMIT + iwork(I) = facul(I,Mat(1,2))+facul(I,Mat(2,1))+facul(I,Mat(3,1))+facul(I,Mat(1,3))-facul(I,Mat(1,1))-facul(I,Mat(2,2))- & + facul(I,Mat(3,3))-facul(I,(Isigma+1))-facul(I,Mat(2,3))-facul(I,Mat(3,2)) +end do +!write(u6,*) 'Iwork: ',(iwork(i),i=1,LIMIT) +factor = One +!bs iup = 1 +!BS idown = 1 +!BS testup = .true. +!BS testdown = .true. +!BS do I=1,LIMIT +!BS do J=1,iwork(I) +!BS iup = iup*prim(i) +!BS if (iup < 0) testup = .false. !check for Integer overflow +!BS end do +!BS end do +!BS up = real(iup,kind=wp) +!BS if (.not. testup) then ! if the integers did not run correctly +up = One +do I=1,LIMIT + do J=1,iwork(I) + up = up*real(prim(i),kind=wp) + end do +end do +!BS endif +!BS do I=1,LIMIT +!BS do J=1,-iwork(I) +!BS idown = idown*prim(i) +!BS if (idown < 0) testdown = .false. +!BS end do +!BS end do +!BS down = real(idown,kind=wp) +!BS if (.not. testdown) then +down = One +do I=1,LIMIT + do J=1,-iwork(I) + down = down*real(prim(i),kind=wp) + end do +end do +!BS endif +!if (.not. (testup .and. testdown)) then +! write(u6,*) 'j1,j2,j3,m1,m2,m3 ',j1,j2,j3,m1,m2,m3 +! write(u6,*) 'iup,idown ',iup,idown,'up,down ',up,down +!end if +factor = factor*up/down +!bs final result +regge3j = sqrt(factor)*real(isum,kind=wp) + +return + +end function regge3j diff -Nru openmolcas-22.02/src/amfi_util/symtrafo.f openmolcas-22.10/src/amfi_util/symtrafo.f --- openmolcas-22.02/src/amfi_util/symtrafo.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/symtrafo.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,362 +0,0 @@ -*********************************************************************** -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine SymTrafo(LUPROP,ip,lOper,nComp,nBas,nIrrep,Label, - & MolWgh,SOInt,LenTot) -cbs -cbs Purpose: combine SO-integrals from amfi to symmetry-adapted -cbs integrals on one file AOPROPER_MF_SYM -cbs -cbs - implicit real*8 (a-h,o-z) -#include "para.fh" -#include "Molcas.fh" -#include "real.fh" -#include "stdalloc.fh" - Real*8, Allocatable:: AMFI_Int(:,:), Scr(:,:) - Integer, Allocatable:: iSO_info(:,:) - parameter(maxorbs=MxOrb) - parameter(maxcent=MxAtom) - Real*8 SOInt(LenTot) - character*8 ya,za,xa2 - character*3 END -CBS character*20 filename - logical EX -CBS namelist /SYMTRA/ none - dimension ya(4),za(4) - dimension xa2(4) - dimension ncent(maxorbs), Lval(maxorbs),mval(maxorbs), - * nadpt(maxorbs),nphase(8,maxorbs),idummy(8), - * Lhighcent(maxcent),Lcent(MxCart),Mcent(MxCart), - * ncontcent(0:Lmax),numballcart(maxcent) - allocatable ifirstLM(:,:,:) - Integer ip(nComp), nBas(0:nIrrep-1), lOper(nComp), ipC(MxAtom) - Character Label*8 -c####################################################################### - IPNT(I,J)=(max(i,j)*max(i,j)-max(i,j))/2 +min(i,j) -* - END=' ' ! added due to cray warnings. B.S. 04/10/04 - ya(1)='********' - za(1)='********' - ya(2)=' ' - Za(2)=' ' - ya(3)='ANTISYMM' - Za(3)='ANTISYMM' - ya(4)='Y1SPNORB' - ZA(4)='Z1SPNORB' - call mma_allocate(ifirstLM,[0,Lmax],[-Lmax,Lmax],[1,maxcent], - & label='ifirstLM') -c -c read information from SYMINFO - isymunit=isfreeunit(58) - call f_inquire('SYMINFO',EX) - if (.not.EX) Call SysAbendMsg('systrafo', - & 'SYMINFO not present','Sorry') - call molcas_open(isymunit,'SYMINFO') - rewind(isymunit) -*define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - write(6,*) 'Symmetry adapation of the SO-integrals' -#endif - read(isymunit,*) - read(isymunit,*) - read(isymunit,*) - numboffunct=0 - do while(END.ne.'END') - numboffunct=numboffunct+1 - read(isymunit,'(A3)') END - enddo -#ifdef _DEBUGPRINT_ - write(6,*) 'there are totally ',numboffunct,' functions' -#endif - if (numboffunct.gt.maxorbs) - &Call SysAbendMsg('symtrafo','increase maxorbs in symtrafo',' ') - rewind isymunit - read(isymunit,*) - read(isymunit,*) - numbofcent=0 - do irun=1,numboffunct - read(isymunit,*) index,ncent(irun),lval(irun), - & mval(irun),nadpt(irun), - & (nphase(I,irun),I=1,nadpt(irun)) - numbofcent=max(numbofcent,ncent(irun)) - if (index.ne.irun) - & Call SysAbendMsg('symtrafo', - & 'weird numbering on SYMINFO',' ' ) - End Do - Close(iSymUnit) -#ifdef _DEBUGPRINT_ - write(6,*) 'number of unique centres' , numbofcent -#endif -c -c clean up arrays for new integrals - numboffunct3=(numboffunct*numboffunct+numboffunct)/2 -* - Call mma_allocate(AMFI_Int,numboffunct3,3,Label='AMFI_Int') - AMFI_Int(:,:)=Zero -* - nSOs=0 - Do iIrrep = 0, nIrrep-1 - nSOs=nSOs+nBas(iIrrep) - End Do - Call mma_allocate(iSO_info,2,nSOs,Label='iSO_info') - iSO_a=0 - Do iIrrep=0,nIrrep-1 - iSO_r=0 - Do iBas = 1, nBas(iIrrep) - iSO_a=iSO_a+1 - iSO_r=iSO_r+1 - iSO_info(1,iSO_a)=iIrrep - iSO_info(2,iSO_a)=iSO_r - End Do - End Do -* -* loop over unique centres to read integrals and information -* - iunit=LUPROP - Call mma_allocate(Scr,numboffunct3,3,Label='Scr') - Scr(:,:)=Zero - ipSCR=1 - length3_tot=0 -* -* In a MPI run not all atomic block will be available in -* all processes. Make up so we know later if a particular -* atom is present. -* - ipC(1:numbofcent)=-99 - do jcent=1,numbofcent -* -#ifdef _DEBUGPRINT_ - write(6,*) 'read integrals and info for centre ',jcent -#endif -* -* Note that when running in parallel this list is incomplete. -* Hence, we process the centers which each process host. -* - read(iunit,END=199) iCent - read(iunit) xa2 - & ,numbofsym,(idummy(I), - & i=1,numbofsym), - & numballcart(icent),(Lcent(i), - & I=1,numballcart(icent)), - & (mcent(i),I=1,numballcart(icent)), - & Lhighcent(icent),(ncontcent(I),I=0,Lhighcent(icent)) -#ifdef _DEBUGPRINT_ - write(6,*) numballcart(icent) , - & 'functions on centre ',icent -#endif - length3=ipnt(numballcart(icent),numballcart(icent)) - ipC(iCent)=ipSCR - read(iunit) (Scr(i,1),i=ipSCR,ipSCR+length3-1) - read(iunit) Ya - read(iunit) (Scr(i,2),i=ipSCR,ipSCR+length3-1) - read(iunit) Za - read(iunit) (Scr(i,3),i=ipSCR,ipSCR+length3-1) - ipScr=ipScr+length3 - length3_tot=length3_tot+length3 -culf -c check if any L-value is missing - LLhigh = Lhighcent(icent) - do i=1,Lhighcent(icent) - if(ncontcent(I).eq.0) LLhigh=LLhigh-1 - enddo - Lhighcent(icent)=LLhigh -cbs determize where the first function of a special type is.. - not_defined=ipnt(numboffunct,numboffunct)+1 - do Lrun=0,Lhighcent(icent) - do Mrun=-Lrun,Lrun - ifirstLM(Lrun,Mrun,icent)=not_defined - enddo - enddo - do iorb=1,numballcart(icent) - Lrun=Lcent(iorb) - Mrun=Mcent(iorb) -#ifdef _DEBUGPRINT_ - write(6,*) 'iorb,Lrun,mrun',iorb,Lrun,mrun -#endif - ifirstLM(Lrun,Mrun,icent)=min(iorb,ifirstLM(Lrun,Mrun,icent)) - enddo -* -cbs determined.. -cbs check if all of them were found - do Lrun=0,Lhighcent(icent) - do Mrun=-Lrun,Lrun - if (ifirstLM(Lrun,Mrun,icent).eq.not_defined) then - write(6,*) 'problems for centre,L,M ',icent,Lrun,Mrun - Call SysAbendMsg('symtrafo', - & 'problems with L- and M-values',' ') - endif - enddo - enddo - enddo !end of loop over centres - 199 Continue -#ifdef _DEBUGPRINT_ - Write (6,*) 'length3_tot=',length3_tot - Call RecPrt('SCR(1,1)',' ',Scr(1,1),1,length3_tot) - Call RecPrt('SCR(1,2)',' ',Scr(1,2),1,length3_tot) - Call RecPrt('SCR(1,3)',' ',Scr(1,3),1,length3_tot) - Do iCent = 1, numbofcent - Write (6,*) ipC(iCent) - End Do -#endif -* If this process does not have any blocks of integrals proceed -* directly to the distribution step. - If (Length3_tot.eq.0) Go To 299 -cbs -cbs Finally the transformation!!!! -cbs -cbs - icentprev=0 - jcentprev=0 - ilcentprev=-1 - jlcentprev=-1 - imcentprev=20 - jmcentprev=20 - isame=1 - jsame=1 - lauf=0 - do irun=1,numboffunct -* Skip if center corresponding to this basis function is -* not available at this process. - if (ncent(irun).eq.icentprev.AND.ilcentprev.eq.lval(irun) - & .AND.imcentprev.eq.mval(irun)) then - isame=isame+1 - else - isame=1 - icentprev=ncent(irun) - ilcentprev=lval(irun) - imcentprev=mval(irun) - endif - do jrun=1,irun - lauf=lauf+1 - if (ncent(jrun).eq.jcentprev.and.jlcentprev.eq.lval(jrun) - & .AND.jmcentprev.eq.mval(jrun)) then - jsame=jsame+1 - else - jsame=1 - jcentprev=ncent(jrun) - jlcentprev=lval(jrun) - jmcentprev=mval(jrun) - endif -cbs check for same centers - if (ncent(irun).eq.ncent(jrun)) then - if (lval(irun).eq.lval(jrun).and.lval(irun).gt.0) then - if (iabs(iabs(mval(irun))-iabs(mval(jrun))).le.1) then -* -* -* -cbs the only cases where non-zero integrals occur - if (nadpt(irun).eq.1) then - coeff=1d0 - else - icoeff=0 - do icc=1,nadpt(irun) - icoeff=icoeff+nphase(icc,irun)*nphase(icc,jrun) - enddo - coeff=DBLE(icoeff) - If (MolWgh.eq.2) Then - coeff=coeff/DBLE(nadpt(irun)) - Else - coeff=coeff/DBLE(nadpt(irun)*nadpt(irun)) - End If - endif -cbs determine indices of atomic integrals - indexi=ifirstLM(lval(irun),mval(irun),ncent(irun))+isame-1 - indexj=ifirstLM(lval(irun),mval(jrun),ncent(irun))+jsame-1 - laufalt=ipnt(indexi,indexj) -* - If (ipC(nCent(iRun)).ne.-99) Then - ipSCR=ipC(ncent(irun))-1+laufalt -cDebugDebug -c Write (6,*) 'laufalt=',laufalt -c Write (6,*) 'ip''s:',ipSCR -c Write (6,*) Scr(ipSCR,1),Scr(ipSCR,2),Scr(ipSCR,3) -cDebugDebug - Sgn=One - if (indexi.gt.indexj) Sgn=-Sgn - AMFI_Int(lauf,1)=Sgn*coeff*Scr(ipScr,1) - AMFI_Int(lauf,2)=Sgn*coeff*Scr(ipScr,2) - AMFI_Int(lauf,3)=Sgn*coeff*Scr(ipScr,3) - End If -* -* - endif - endif - endif - enddo ! jrun - enddo ! irun - 299 Continue -* This test is not valid for parallel execusion, since here -* we have only incomplete lists. -* if (lauf.ne.numboffunct3) -* & Call SysAbendMsg('symtrafo', 'error in numbering ',' ' ) - Do iComp = 1, nComp - Do iSO=1, numboffunct - j1= iSO_info(1,iSO) - iSO_r=iSO_info(2,iSO) - Do jSO = 1, iSO - j2= iSO_info(1,jSO) - jSO_r=iSO_info(2,jSO) - j12=iEor(j1,j2) - If (iAnd(lOper(iComp),2**j12).eq.0) Go To 99 -* - iOff = iPntSO(Max(j1,j2),Min(j1,j2),lOper(iComp),nBas) - iOff = iOff + ip(iComp)-1 -* - iOff2= iPnt(iSO,jSO) -* - tmp=-AMFI_Int(iOff2,iComp) - If (j1.eq.j2) Then - ijSO=iPnt(iSO_r,jSO_r) - Else - ijSO=(jSO_r-1)*nBas(j1)+iSO_r - End If - SOInt(iOff+ijSO)=tmp -* - 99 Continue - End Do - End Do -* -*------- Write out integrals to ONEINT for this specific component of the -* operator. -* -* - iOpt=0 - iRC=-1 - iSmLbl=lOper(iComp) - Call GADSum(SOInt(ip(iComp)),n2Tri(iSmLbl)) - Call WrOne(iRC,iOpt,Label,iComp,SOInt(ip(iComp)),iSmLbl) - If (iRC.ne.0) then - Call SysAbendMsg('symtrafo', - & ' Error in subroutine ONEEL ', - & ' Abend in subroutine WrOne') - End If -* - End Do -* -#ifdef _DEBUGPRINT_ - Call PrMtrx(Label,lOper,nComp,ip,SOInt) -#endif -* - Call mma_deallocate(ifirstLM) - Call mma_deallocate(iSO_info) - Call mma_deallocate(Scr) - Call mma_deallocate(AMFI_Int) -CBS write(6,*) 'Symmetry transformation successfully done' - Return -#ifdef _WARNING_WORKAROUND_ - If (.False.) Then - Call Unused_integer_array(idummy) - Call Unused_character(ya) - Call Unused_character(za) - Call Unused_character(xa2) - End If -#endif - End diff -Nru openmolcas-22.02/src/amfi_util/symtrafo.F90 openmolcas-22.10/src/amfi_util/symtrafo.F90 --- openmolcas-22.02/src/amfi_util/symtrafo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/symtrafo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,357 @@ +!********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine SymTrafo(LUPROP,lOper,nComp,nBas,nIrrep,Label,MolWgh) +!bs Purpose: combine SO-integrals from amfi to symmetry-adapted +!bs integrals on one file AOPROPER_MF_SYM + +use AMFI_global, only: Lmax, MxCart +use index_functions, only: iTri +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: LUPROP, nComp, lOper(nComp), nIrrep, nBas(0:nIrrep-1), MolWgh +character(len=8), intent(in) :: Label +#include "Molcas.fh" +integer(kind=iwp) :: I, iBas, icc, iCent, icentprev, icoeff, iComp, idummy(8), iIrrep, ijSO, ilcentprev, imcentprev, indx, indexi, & + indexj, iOff, iOff2, iOpt, iorb, ipSCR, iRC, irun, isame, iSmLbl, iSO, iSO_a, iSO_r, istatus, isymunit, & + iunit, j1, j12, j2, jcent, jcentprev, jlcentprev, jmcentprev, jrun, jsame, jSO, jSO_r, lauf, laufalt, & + length3, length3_tot, LenInt, LenTot, LLhigh, Lrun, Mrun, ncontcent(0:Lmax), not_defined, nSOs, numbofcent, & + numboffunct, numboffunct3, numbofsym +real(kind=wp) :: coeff, Sgn +!BS character(len=20) :: filename +character(len=8) :: xa2(4) +character(len=3) :: send +logical(kind=iwp) :: EX +integer(kind=iwp), allocatable :: C(:), ifirstLM(:,:,:), ip(:), iSO_info(:,:), Lcent(:), Lhighcent(:), Lval(:), Mcent(:), mval(:), & + nadpt(:), ncent(:), nphase(:,:), numballcart(:) +real(kind=wp), allocatable :: AMFI_Int(:,:), Scr(:,:), SOInt(:) +integer(kind=iwp), external :: iPntSO, isfreeunit, n2Tri + +! These variables are just placeholders for reading +#include "macros.fh" +unused_var(idummy) +unused_var(xa2) + +!####################################################################### +call mma_allocate(ifirstLM,[0,Lmax],[-Lmax,Lmax],[1,MxAtom],label='ifirstLM') + +! read information from SYMINFO +isymunit = isfreeunit(58) +call f_inquire('SYMINFO',EX) +if (.not. EX) call SysAbendMsg('systrafo','SYMINFO not present','Sorry') +call molcas_open(isymunit,'SYMINFO') +rewind(isymunit) +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +write(u6,*) 'Symmetry adapation of the SO-integrals' +#endif +read(isymunit,*) +read(isymunit,*) +read(isymunit,*) +numboffunct = 0 +send = '' +do while (send /= 'END') + numboffunct = numboffunct+1 + read(isymunit,'(A3)') send +end do +#ifdef _DEBUGPRINT_ +write(u6,*) 'there are totally ',numboffunct,' functions' +#endif +if (numboffunct > MxOrb) call SysAbendMsg('symtrafo','increase MxOrb in Molcas.fh',' ') +rewind isymunit +read(isymunit,*) +read(isymunit,*) +numbofcent = 0 +call mma_allocate(ncent,numboffunct,label='ncent') +call mma_allocate(Lval,numboffunct,label='Lval') +call mma_allocate(mval,numboffunct,label='mval') +call mma_allocate(nadpt,numboffunct,label='nadpt') +call mma_allocate(nphase,8,numboffunct,label='nphase') +do irun=1,numboffunct + read(isymunit,*) indx,ncent(irun),lval(irun),mval(irun),nadpt(irun),(nphase(I,irun),I=1,nadpt(irun)) + numbofcent = max(numbofcent,ncent(irun)) + if (indx /= irun) call SysAbendMsg('symtrafo','weird numbering on SYMINFO',' ') +end do +close(iSymUnit) +#ifdef _DEBUGPRINT_ +write(u6,*) 'number of unique centres',numbofcent +#endif + +! clean up arrays for new integrals +numboffunct3 = (numboffunct*numboffunct+numboffunct)/2 + +call mma_allocate(AMFI_Int,numboffunct3,3,label='AMFI_Int') +AMFI_Int(:,:) = Zero + +nSOs = 0 +do iIrrep=0,nIrrep-1 + nSOs = nSOs+nBas(iIrrep) +end do +call mma_allocate(iSO_info,2,nSOs,label='iSO_info') +iSO_a = 0 +do iIrrep=0,nIrrep-1 + iSO_r = 0 + do iBas=1,nBas(iIrrep) + iSO_a = iSO_a+1 + iSO_r = iSO_r+1 + iSO_info(1,iSO_a) = iIrrep + iSO_info(2,iSO_a) = iSO_r + end do +end do + +! loop over unique centres to read integrals and information + +iunit = LUPROP +call mma_allocate(Scr,numboffunct3,3,label='Scr') +Scr(:,:) = Zero +ipSCR = 1 +length3_tot = 0 + +call mma_allocate(C,numbofcent,label='C') +call mma_allocate(numballcart,numbofcent,label='numballcart') +call mma_allocate(Lcent,MxCart,label='Lcent') +call mma_allocate(Mcent,MxCart,label='Mcent') +call mma_allocate(Lhighcent,MxAtom,label='Lhighcent') + +! In a MPI run not all atomic block will be available in +! all processes. Make up so we know later if a particular +! atom is present. + +C(:) = -99 +do jcent=1,numbofcent + +# ifdef _DEBUGPRINT_ + write(u6,*) 'read integrals and info for centre ',jcent +# endif + + ! Note that when running in parallel this list is incomplete. + ! Hence, we process the centers which each process host. + + read(iunit,iostat=istatus) iCent + if (istatus < 0) exit + read(iunit) xa2,numbofsym,(idummy(I),i=1,numbofsym),numballcart(icent),(Lcent(i),I=1,numballcart(icent)), & + (mcent(i),I=1,numballcart(icent)),Lhighcent(icent),(ncontcent(I),I=0,Lhighcent(icent)) +# ifdef _DEBUGPRINT_ + write(u6,*) numballcart(icent),'functions on centre ',icent +# endif + length3 = iTri(numballcart(icent),numballcart(icent)) + C(iCent) = ipSCR + read(iunit) (Scr(i,1),i=ipSCR,ipSCR+length3-1) + read(iunit) xa2 + read(iunit) (Scr(i,2),i=ipSCR,ipSCR+length3-1) + read(iunit) xa2 + read(iunit) (Scr(i,3),i=ipSCR,ipSCR+length3-1) + ipScr = ipScr+length3 + length3_tot = length3_tot+length3 + !ulf + ! check if any L-value is missing + LLhigh = Lhighcent(icent) + do i=1,Lhighcent(icent) + if (ncontcent(I) == 0) LLhigh = LLhigh-1 + end do + Lhighcent(icent) = LLhigh + !bs determize where the first function of a special type is.. + not_defined = iTri(numboffunct,numboffunct)+1 + do Lrun=0,Lhighcent(icent) + ifirstLM(Lrun,-Lrun:Lrun,icent) = not_defined + end do + do iorb=1,numballcart(icent) + Lrun = Lcent(iorb) + Mrun = Mcent(iorb) +# ifdef _DEBUGPRINT_ + write(u6,*) 'iorb,Lrun,mrun',iorb,Lrun,mrun +# endif + ifirstLM(Lrun,Mrun,icent) = min(iorb,ifirstLM(Lrun,Mrun,icent)) + end do + + !bs determined.. + !bs check if all of them were found + do Lrun=0,Lhighcent(icent) + do Mrun=-Lrun,Lrun + if (ifirstLM(Lrun,Mrun,icent) == not_defined) then + write(u6,*) 'problems for centre,L,M ',icent,Lrun,Mrun + call SysAbendMsg('symtrafo','problems with L- and M-values',' ') + end if + end do + end do +end do !end of loop over centres +call mma_deallocate(numballcart) +call mma_deallocate(Lcent) +call mma_deallocate(Mcent) +call mma_deallocate(Lhighcent) +#ifdef _DEBUGPRINT_ +write(u6,*) 'length3_tot=',length3_tot +call RecPrt('SCR(1,1)',' ',Scr(1,1),1,length3_tot) +call RecPrt('SCR(1,2)',' ',Scr(1,2),1,length3_tot) +call RecPrt('SCR(1,3)',' ',Scr(1,3),1,length3_tot) +do iCent=1,numbofcent + write(u6,*) C(iCent) +end do +#endif +! If this process does not have any blocks of integrals proceed +! directly to the distribution step. +if (Length3_tot /= 0) then + + !bs Finally the transformation!!!! + + icentprev = 0 + jcentprev = 0 + ilcentprev = -1 + jlcentprev = -1 + imcentprev = 20 + jmcentprev = 20 + isame = 1 + jsame = 1 + lauf = 0 + do irun=1,numboffunct + ! Skip if center corresponding to this basis function is + ! not available at this process. + if ((ncent(irun) == icentprev) .and. (ilcentprev == lval(irun)) .and. (imcentprev == mval(irun))) then + isame = isame+1 + else + isame = 1 + icentprev = ncent(irun) + ilcentprev = lval(irun) + imcentprev = mval(irun) + end if + do jrun=1,irun + lauf = lauf+1 + if ((ncent(jrun) == jcentprev) .and. (jlcentprev == lval(jrun)) .and. (jmcentprev == mval(jrun))) then + jsame = jsame+1 + else + jsame = 1 + jcentprev = ncent(jrun) + jlcentprev = lval(jrun) + jmcentprev = mval(jrun) + end if + !bs check for same centers + if (ncent(irun) == ncent(jrun)) then + if ((lval(irun) == lval(jrun)) .and. (lval(irun) > 0)) then + if (abs(abs(mval(irun))-abs(mval(jrun))) <= 1) then + + !bs the only cases where non-zero integrals occur + if (nadpt(irun) == 1) then + coeff = One + else + icoeff = 0 + do icc=1,nadpt(irun) + icoeff = icoeff+nphase(icc,irun)*nphase(icc,jrun) + end do + coeff = real(icoeff,kind=wp) + if (MolWgh == 2) then + coeff = coeff/real(nadpt(irun),kind=wp) + else + coeff = coeff/real(nadpt(irun)*nadpt(irun),kind=wp) + end if + end if + !bs determine indices of atomic integrals + indexi = ifirstLM(lval(irun),mval(irun),ncent(irun))+isame-1 + indexj = ifirstLM(lval(irun),mval(jrun),ncent(irun))+jsame-1 + laufalt = iTri(indexi,indexj) + + if (C(nCent(iRun)) /= -99) then + ipSCR = C(ncent(irun))-1+laufalt + ! DebugDebug + !write(u6,*) 'laufalt=',laufalt + !write(u6,*) 'ip''s:',ipSCR + !write(u6,*) Scr(ipSCR,1),Scr(ipSCR,2),Scr(ipSCR,3) + ! DebugDebug + Sgn = One + if (indexi > indexj) Sgn = -Sgn + AMFI_Int(lauf,1) = Sgn*coeff*Scr(ipScr,1) + AMFI_Int(lauf,2) = Sgn*coeff*Scr(ipScr,2) + AMFI_Int(lauf,3) = Sgn*coeff*Scr(ipScr,3) + end if + + end if + end if + end if + end do ! jrun + end do ! irun +end if +call mma_deallocate(C) +call mma_deallocate(ncent) +call mma_deallocate(Lval) +call mma_deallocate(mval) +call mma_deallocate(nadpt) +call mma_deallocate(nphase) + +! Allocate memory for symmetry adapted one electron integrals. +! Will just store the unique elements, i.e. low triangular blocks +! and lower triangular elements in the diagonal blocks. + +call mma_allocate(ip,nComp,label='ip') +LenTot = 0 +do iComp=1,nComp + ip(iComp) = 1+LenTot + LenInt = n2Tri(lOper(iComp)) + LenTot = LenTot+LenInt+4 +end do +call mma_allocate(SOInt,LenTot,label='SOInt') +SOInt(:) = Zero + +! This test is not valid for parallel execution, since here +! we have only incomplete lists. +!if (lauf /= numboffunct3) call SysAbendMsg('symtrafo','error in numbering ',' ') +do iComp=1,nComp + do iSO=1,numboffunct + j1 = iSO_info(1,iSO) + iSO_r = iSO_info(2,iSO) + do jSO=1,iSO + j2 = iSO_info(1,jSO) + jSO_r = iSO_info(2,jSO) + j12 = ieor(j1,j2) + if (.not. btest(lOper(iComp),j12)) cycle + + iOff = iPntSO(max(j1,j2),min(j1,j2),lOper(iComp),nBas) + iOff = iOff+ip(iComp)-1 + + iOff2 = iTri(iSO,jSO) + + if (j1 == j2) then + ijSO = iTri(iSO_r,jSO_r) + else + ijSO = (jSO_r-1)*nBas(j1)+iSO_r + end if + SOInt(iOff+ijSO) = -AMFI_Int(iOff2,iComp) + + end do + end do + + ! Write out integrals to ONEINT for this specific component of the operator. + + iOpt = 0 + iRC = -1 + iSmLbl = lOper(iComp) + call GADSum(SOInt(ip(iComp)),n2Tri(iSmLbl)) + call WrOne(iRC,iOpt,Label,iComp,SOInt(ip(iComp)),iSmLbl) + if (iRC /= 0) call SysAbendMsg('symtrafo',' Error in subroutine ONEEL ',' Abend in subroutine WrOne') + +end do + +#ifdef _DEBUGPRINT_ +call PrMtrx(Label,lOper,nComp,ip,SOInt) +#endif + +call mma_deallocate(ifirstLM) +call mma_deallocate(iSO_info) +call mma_deallocate(Scr) +call mma_deallocate(AMFI_Int) +call mma_deallocate(ip) +call mma_deallocate(SOInt) +!BS write(u6,*) 'Symmetry transformation successfully done' + +return + +end subroutine SymTrafo diff -Nru openmolcas-22.02/src/amfi_util/tkinet.f openmolcas-22.10/src/amfi_util/tkinet.f --- openmolcas-22.02/src/amfi_util/tkinet.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/tkinet.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - REAL*8 function Tkinet(l,alpha1,alpha2) -cbs calculates the matrix element of kinetic energy -cbs for primitive normalized functions with the same angular momentum l -cbs and exponents alpha1 and alpha2 -cbs works only, if r**l is assumed for an l-value -cbs formular obtained from the symmetric expression (d/dr's to (') -cbs the left and to the right. -cbs Overlaps of the different powers are partially crossed out -cbs with the overlap of functions with angular momentum l -cbs final formula: -cbs Tkinet=0.5*alpha12 (2l+3) (alpha1*alpha2/alpha12*alpha12)**((2L+7)/4) -cbs with alpha12=0.5*(alpha1+alpha2) -cbs as alpha12 has the dimensions 1/length**2, this can not be that bad... - Implicit REAL*8 (a-h,o-z) -Cbs alpha12 is the effective exponent - Alpha12=0.5d0*(alpha1+alpha2) - alphpro=alpha1*alpha2 - ll3=l+l+3 - ll7=l+l+7 - Tkinet=0.5d0*alpha12*DBLE(ll3)*(alphpro/ - *(alpha12*alpha12))**(0.25D0*DBLE(ll7)) - return - end diff -Nru openmolcas-22.02/src/amfi_util/tkinet.F90 openmolcas-22.10/src/amfi_util/tkinet.F90 --- openmolcas-22.02/src/amfi_util/tkinet.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/tkinet.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,42 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +function Tkinet(l,alpha1,alpha2) +!bs calculates the matrix element of kinetic energy +!bs for primitive normalized functions with the same angular momentum l +!bs and exponents alpha1 and alpha2 +!bs works only, if r**l is assumed for an l-value +!bs formular obtained from the symmetric expression (d/dr's to (') +!bs the left and to the right. +!bs Overlaps of the different powers are partially crossed out +!bs with the overlap of functions with angular momentum l +!bs final formula: +!bs Tkinet=0.5*alpha12 (2l+3) (alpha1*alpha2/alpha12*alpha12)**((2L+7)/4) +!bs with alpha12=0.5*(alpha1+alpha2) +!bs as alpha12 has the dimensions 1/length**2, this can not be that bad... + +use Constants, only: Half, Quart +use Definitions, only: wp, iwp + +implicit none +real(kind=wp) :: Tkinet +integer(kind=iwp), intent(in) :: l +real(kind=wp), intent(in) :: alpha1, alpha2 +real(kind=wp) :: Alpha12, alphpro + +!bs alpha12 is the effective exponent +Alpha12 = Half*(alpha1+alpha2) +alphpro = alpha1*alpha2 +Tkinet = Half*alpha12*real(2*l+3,kind=wp)*(alphpro/(alpha12*alpha12))**(Quart*real(2*l+7,kind=wp)) + +return + +end function Tkinet diff -Nru openmolcas-22.02/src/amfi_util/tosigx.f openmolcas-22.10/src/amfi_util/tosigx.f --- openmolcas-22.02/src/amfi_util/tosigx.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/tosigx.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,301 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine tosigX(m1,m2,m3,m4,angint, - *mcombina,ncontl1,ncontl2,ncontl3, - *ncontl4,carteX,preXZ,interxyz,isgnprod, - *cleaner) -cbs this subroutine combines the angular integrals -cbs to the integrals for the real-valued linear -cbs combinations for the sigma_X part -cbs definition of the real-valued linear combinations: -cbs -cbs -cbs M=0 is the same as Y(L,0) -cbs -cbs -cbs M > 0 -cbs -cbs | L,M,+> = 2**(-0.5) ( (-1)**M Y(L,M) + Y(L,-M)) -cbs -cbs | L,M,-> = -i 2**(-0.5) ( (-1)**M Y(L,M) - Y(L,-M)) ($$$$) -cbs -cbs -cbs due to symmetry, there can be only integrals -cbs with indices one or three (sigma_+ and sigma_-)- combinations -cbs - implicit real*8 (a-h,o-z) -#include "para.fh" - parameter (fine=7.29735308D-03) !TO_BE_CHECKED -cbs at least it's identical with Odd's valuE - parameter (speed=1d0/fine) - parameter (speed2=speed*speed) - logical cleaner - dimension mcombina(2,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), - *angint(ncontl1,ncontl2,ncontl3,ncontl4,*), -cbs !!!!!!!!!!!changing now to the order of chemists notation!!!!!!!!!! - *carteX(ncontl1,ncontl3,ncontl2,ncontl4), - *preXZ(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), - *interxyz(*), - *isgnprod(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), - *isgnM(-1:1,-1:1,-1:1,-1:1) -c write(6,*) ' begin tosigx' -cbs cleaning up the integral-array - irun=ncontl1*ncontl2*ncontl3*ncontl4 - call dzero(cartex,irun) -cbs set some signs -cbs isgnM will give an additonal minus-sign if both m-values -cbs (cartesian and angular) are negative see $$$$ - do irun4=-1,1 - do irun3=-1,1 - do irun2=-1,1 - do irun1=-1,1 - isgnM(irun1,irun2,irun3,irun4)=1 - enddo - enddo - enddo - enddo - if (m1.lt.0) then - do irun4=-1,1 - do irun3=-1,1 - do irun2=-1,1 - isgnM(-1,irun2,irun3,irun4)= - *-isgnM(-1,irun2,irun3,irun4) - enddo - enddo - enddo - endif - if (m2.lt.0) then - do irun4=-1,1 - do irun3=-1,1 - do irun1=-1,1 - isgnM(irun1,-1,irun3,irun4)= - *-isgnM(irun1,-1,irun3,irun4) - enddo - enddo - enddo - endif - if (m3.lt.0) then - do irun4=-1,1 - do irun2=-1,1 - do irun1=-1,1 - isgnM(irun1,irun2,-1,irun4)= - *-isgnM(irun1,irun2,-1,irun4) - enddo - enddo - enddo - endif - if (m4.lt.0) then - do irun3=-1,1 - do irun2=-1,1 - do irun1=-1,1 - isgnM(irun1,irun2,irun3,-1)= - *-isgnM(irun1,irun2,irun3,-1) - enddo - enddo - enddo - endif -cbs define absolute m-values - Mabs1=iabs(m1) - Mabs2=iabs(m2) - Mabs3=iabs(m3) - Mabs4=iabs(m4) - irun=0 - if (interxyz(1).eq.0) then - write(6,*) 'tosigx: no interaction: ',m1,m2,m3,m4 - Call Abend() - endif - prexz1234=preXZ(m1,m2,m3,m4) -c do while (interxyz(irun+1).gt.0) - if(interxyz(irun+1).le.0) goto 777 -666 continue - irun=irun+1 -c write(6,*) 'tosigx: ',irun,interxyz(irun) -c -cbs -cbs -cbs This could be done with gotos, but I am biased to hate those.. -cbs -cbs - if (interxyz(irun).eq.1) then - ityp=mcombina(1,Mabs1,Mabs2,Mabs3,Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigx','wrong ityp in tosigX 1',' ') - iblock=mcombina(2,Mabs1,Mabs2,Mabs3,Mabs4) - factor=DBLE(isgnM(1,1,1,1))*prexz1234* - * DBLE(isgnprod(Mabs1,Mabs2,Mabs3,Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteX, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.2) then - ityp=mcombina(1,-Mabs1,-Mabs2,-Mabs3,-Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigx', 'wrong ityp in tosigX 2',' ') - iblock=mcombina(2,-Mabs1,-Mabs2,-Mabs3,-Mabs4) - factor=DBLE(isgnM(-1,-1,-1,-1))*prexz1234* - * DBLE(isgnprod(-Mabs1,-Mabs2,-Mabs3,-Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteX, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.3) then - ityp=mcombina(1,Mabs1,Mabs2,Mabs3,-Mabs4) - - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigx', 'wrong ityp in tosigX 3',' ') - iblock=mcombina(2,Mabs1,Mabs2,Mabs3,-Mabs4) - factor=DBLE(isgnM(1,1,1,-1))*prexz1234* - * DBLE(isgnprod(Mabs1,Mabs2,Mabs3,-Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteX, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.4) then - ityp=mcombina(1,-Mabs1,-Mabs2,-Mabs3,Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigx', 'wrong ityp in tosigX 4',' ') - iblock=mcombina(2,-Mabs1,-Mabs2,-Mabs3,Mabs4) - factor=DBLE(isgnM(-1,-1,-1,1))*prexz1234* - * DBLE(isgnprod(-Mabs1,-Mabs2,-Mabs3,Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteX, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.5) then - ityp=mcombina(1,Mabs1,Mabs2,-Mabs3,Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigx', 'wrong ityp in tosigX 5',' ') - iblock=mcombina(2,Mabs1,Mabs2,-Mabs3,Mabs4) - factor=DBLE(isgnM(1,1,-1,1))*prexz1234* - * DBLE(isgnprod(Mabs1,Mabs2,-Mabs3,Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteX, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.6) then - ityp=mcombina(1,-Mabs1,-Mabs2,Mabs3,-Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigx', 'wrong ityp in tosigX 6',' ') - iblock=mcombina(2,-Mabs1,-Mabs2,Mabs3,-Mabs4) - factor=DBLE(isgnM(-1,-1,1,-1))*prexz1234* - * DBLE(isgnprod(-Mabs1,-Mabs2,Mabs3,-Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteX, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.7) then - ityp=mcombina(1,Mabs1,-Mabs2,Mabs3,Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigx', 'wrong ityp in tosigX 7',' ') - iblock=mcombina(2,Mabs1,-Mabs2,Mabs3,Mabs4) - factor=DBLE(isgnM(1,-1,1,1))*prexz1234* - * DBLE(isgnprod(Mabs1,-Mabs2,Mabs3,Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteX, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.8) then - ityp=mcombina(1,-Mabs1,Mabs2,-Mabs3,-Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigx', 'wrong ityp in tosigX 8', ' ') - iblock=mcombina(2,-Mabs1,Mabs2,-Mabs3,-Mabs4) - factor=DBLE(isgnM(-1,1,-1,-1))*prexz1234* - * DBLE(isgnprod(-Mabs1,Mabs2,-Mabs3,-Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteX, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.9) then - ityp=mcombina(1,-Mabs1,Mabs2,Mabs3,Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigx', 'wrong ityp in tosigX 9',' ') - iblock=mcombina(2,-Mabs1,Mabs2,Mabs3,Mabs4) - factor=DBLE(isgnM(-1,1,1,1))*prexz1234* - * DBLE(isgnprod(-Mabs1,Mabs2,Mabs3,Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteX, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.10) then - ityp=mcombina(1,Mabs1,-Mabs2,-Mabs3,-Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigx', 'wrong ityp in tosigX 10',' ') - iblock=mcombina(2,Mabs1,-Mabs2,-Mabs3,-Mabs4) - factor=DBLE(isgnM(1,-1,-1,-1))*prexz1234* - * DBLE(isgnprod(Mabs1,-Mabs2,-Mabs3,-Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteX, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.11) then - ityp=mcombina(1,Mabs1,Mabs2,-Mabs3,-Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigx', 'wrong ityp in tosigX 11',' ') - iblock=mcombina(2,Mabs1,Mabs2,-Mabs3,-Mabs4) - factor=DBLE(isgnM(1,1,-1,-1))*prexz1234* - * DBLE(isgnprod(Mabs1,Mabs2,-Mabs3,-Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteX, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.12) then - ityp=mcombina(1,-Mabs1,-Mabs2,Mabs3,Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigx', 'wrong ityp in tosigX 12',' ') - iblock=mcombina(2,-Mabs1,-Mabs2,Mabs3,Mabs4) - factor=DBLE(isgnM(-1,-1,1,1))*prexz1234* - * DBLE(isgnprod(-Mabs1,-Mabs2,Mabs3,Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteX, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.13) then - ityp=mcombina(1,Mabs1,-Mabs2,Mabs3,-Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigx', 'wrong ityp in tosigX 13',' ') - iblock=mcombina(2,Mabs1,-Mabs2,Mabs3,-Mabs4) - factor=DBLE(isgnM(1,-1,1,-1))*prexz1234* - * DBLE(isgnprod(Mabs1,-Mabs2,Mabs3,-Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteX, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.14) then - ityp=mcombina(1,-Mabs1,Mabs2,-Mabs3,Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigx', 'wrong ityp in tosigX 14', ' ') - iblock=mcombina(2,-Mabs1,Mabs2,-Mabs3,Mabs4) - factor=DBLE(isgnM(-1,1,-1,1))*prexz1234* - * DBLE(isgnprod(-Mabs1,Mabs2,-Mabs3,Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteX, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.15) then - ityp=mcombina(1,Mabs1,-Mabs2,-Mabs3,Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigx', 'wrong ityp in tosigX 15',' ') - iblock=mcombina(2,Mabs1,-Mabs2,-Mabs3,Mabs4) - factor=DBLE(isgnM(1,-1,-1,1))*prexz1234* - * DBLE(isgnprod(Mabs1,-Mabs2,-Mabs3,Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteX, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.16) then - ityp=mcombina(1,-Mabs1,Mabs2,Mabs3,-Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigx', 'wrong ityp in tosigX 16',' ') - iblock=mcombina(2,-Mabs1,Mabs2,Mabs3,-Mabs4) - factor=DBLE(isgnM(-1,1,1,-1))*prexz1234* - * DBLE(isgnprod(-Mabs1,Mabs2,Mabs3,-Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteX, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) - endif -c enddo - if(interxyz(irun+1).gt.0) goto 666 -777 continue - if (cleaner) then - do irun4=1,ncontl4 - do irun2=1,ncontl2 - do irun1=1,ncontl1 - cartex(irun1,irun1,irun2,irun4)=0d0 - enddo - enddo - enddo - endif - return - end diff -Nru openmolcas-22.02/src/amfi_util/tosigx.F90 openmolcas-22.10/src/amfi_util/tosigx.F90 --- openmolcas-22.02/src/amfi_util/tosigx.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/tosigx.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,194 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine tosigX(m1,m2,m3,m4,angint,mcombina,ncontl1,ncontl2,ncontl3,ncontl4,carteX,preXZ,interxyz,isgnprod,cleaner) +!bs this subroutine combines the angular integrals +!bs to the integrals for the real-valued linear +!bs combinations for the sigma_X part +!bs definition of the real-valued linear combinations: +!bs +!bs M=0 is the same as Y(L,0) +!bs +!bs M > 0 +!bs +!bs | L,M,+> = 2**(-0.5) ( (-1)**M Y(L,M) + Y(L,-M)) +!bs +!bs | L,M,-> = -i 2**(-0.5) ( (-1)**M Y(L,M) - Y(L,-M)) ($$$$) +!bs +!bs due to symmetry, there can be only integrals +!bs with indices one or three (sigma_+ and sigma_-)- combinations + +use AMFI_global, only: Lmax +use Constants, only: Zero, One, speed => c_in_au +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: m1, m2, m3, m4, mcombina(2,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), ncontl1, ncontl2, & + ncontl3, ncontl4, interxyz(*), isgnprod(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) +real(kind=wp), intent(in) :: angint(ncontl1,ncontl2,ncontl3,ncontl4,*), preXZ(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) +!bs !!!!!!!!!!!changing now to the order of chemists notation!!!!!!!!!! +real(kind=wp), intent(out) :: carteX(ncontl1,ncontl3,ncontl2,ncontl4) +logical(kind=iwp), intent(in) :: cleaner +integer(kind=iwp) :: iblock, irun, isgnM(-1:1,-1:1,-1:1,-1:1), ityp, Mabs1, Mabs2, Mabs3, Mabs4 +real(kind=wp) :: factor, prexz1234 +real(kind=wp), parameter :: fine = One/speed, speed2 = speed**2 + +!write(u6,*) ' begin tosigx' +!bs cleaning up the integral-array +carteX(:,:,:,:) = Zero +!bs set some signs +!bs isgnM will give an additonal minus-sign if both m-values +!bs (cartesian and angular) are negative see $$$$ +isgnM(:,:,:,:) = 1 +if (m1 < 0) isgnM(-1,:,:,:) = -isgnM(-1,:,:,:) +if (m2 < 0) isgnM(:,-1,:,:) = -isgnM(:,-1,:,:) +if (m3 < 0) isgnM(:,:,-1,:) = -isgnM(:,:,-1,:) +if (m4 < 0) isgnM(:,:,:,-1) = -isgnM(:,:,:,-1) +!bs define absolute m-values +Mabs1 = abs(m1) +Mabs2 = abs(m2) +Mabs3 = abs(m3) +Mabs4 = abs(m4) +irun = 0 +if (interxyz(1) == 0) then + write(u6,*) 'tosigx: no interaction: ',m1,m2,m3,m4 + call Abend() +end if +prexz1234 = preXZ(m1,m2,m3,m4) +do while (interxyz(irun+1) > 0) + irun = irun+1 + !write(u6,*) 'tosigx: ',irun,interxyz(irun) + + select case (interxyz(irun)) + + case (1) + ityp = mcombina(1,Mabs1,Mabs2,Mabs3,Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigx','wrong ityp in tosigX 1',' ') + iblock = mcombina(2,Mabs1,Mabs2,Mabs3,Mabs4) + factor = real(isgnM(1,1,1,1),kind=wp)*prexz1234*real(isgnprod(Mabs1,Mabs2,Mabs3,Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteX,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (2) + ityp = mcombina(1,-Mabs1,-Mabs2,-Mabs3,-Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigx','wrong ityp in tosigX 2',' ') + iblock = mcombina(2,-Mabs1,-Mabs2,-Mabs3,-Mabs4) + factor = real(isgnM(-1,-1,-1,-1),kind=wp)*prexz1234*real(isgnprod(-Mabs1,-Mabs2,-Mabs3,-Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteX,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (3) + ityp = mcombina(1,Mabs1,Mabs2,Mabs3,-Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigx','wrong ityp in tosigX 3',' ') + iblock = mcombina(2,Mabs1,Mabs2,Mabs3,-Mabs4) + factor = real(isgnM(1,1,1,-1),kind=wp)*prexz1234*real(isgnprod(Mabs1,Mabs2,Mabs3,-Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteX,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (4) + ityp = mcombina(1,-Mabs1,-Mabs2,-Mabs3,Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigx','wrong ityp in tosigX 4',' ') + iblock = mcombina(2,-Mabs1,-Mabs2,-Mabs3,Mabs4) + factor = real(isgnM(-1,-1,-1,1),kind=wp)*prexz1234*real(isgnprod(-Mabs1,-Mabs2,-Mabs3,Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteX,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (5) + ityp = mcombina(1,Mabs1,Mabs2,-Mabs3,Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigx','wrong ityp in tosigX 5',' ') + iblock = mcombina(2,Mabs1,Mabs2,-Mabs3,Mabs4) + factor = real(isgnM(1,1,-1,1),kind=wp)*prexz1234*real(isgnprod(Mabs1,Mabs2,-Mabs3,Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteX,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (6) + ityp = mcombina(1,-Mabs1,-Mabs2,Mabs3,-Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigx','wrong ityp in tosigX 6',' ') + iblock = mcombina(2,-Mabs1,-Mabs2,Mabs3,-Mabs4) + factor = real(isgnM(-1,-1,1,-1),kind=wp)*prexz1234*real(isgnprod(-Mabs1,-Mabs2,Mabs3,-Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteX,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (7) + ityp = mcombina(1,Mabs1,-Mabs2,Mabs3,Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigx','wrong ityp in tosigX 7',' ') + iblock = mcombina(2,Mabs1,-Mabs2,Mabs3,Mabs4) + factor = real(isgnM(1,-1,1,1),kind=wp)*prexz1234*real(isgnprod(Mabs1,-Mabs2,Mabs3,Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteX,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (8) + ityp = mcombina(1,-Mabs1,Mabs2,-Mabs3,-Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigx','wrong ityp in tosigX 8',' ') + iblock = mcombina(2,-Mabs1,Mabs2,-Mabs3,-Mabs4) + factor = real(isgnM(-1,1,-1,-1),kind=wp)*prexz1234*real(isgnprod(-Mabs1,Mabs2,-Mabs3,-Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteX,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (9) + ityp = mcombina(1,-Mabs1,Mabs2,Mabs3,Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigx','wrong ityp in tosigX 9',' ') + iblock = mcombina(2,-Mabs1,Mabs2,Mabs3,Mabs4) + factor = real(isgnM(-1,1,1,1),kind=wp)*prexz1234*real(isgnprod(-Mabs1,Mabs2,Mabs3,Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteX,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (10) + ityp = mcombina(1,Mabs1,-Mabs2,-Mabs3,-Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigx','wrong ityp in tosigX 10',' ') + iblock = mcombina(2,Mabs1,-Mabs2,-Mabs3,-Mabs4) + factor = real(isgnM(1,-1,-1,-1),kind=wp)*prexz1234*real(isgnprod(Mabs1,-Mabs2,-Mabs3,-Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteX,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (11) + ityp = mcombina(1,Mabs1,Mabs2,-Mabs3,-Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigx','wrong ityp in tosigX 11',' ') + iblock = mcombina(2,Mabs1,Mabs2,-Mabs3,-Mabs4) + factor = real(isgnM(1,1,-1,-1),kind=wp)*prexz1234*real(isgnprod(Mabs1,Mabs2,-Mabs3,-Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteX,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (12) + ityp = mcombina(1,-Mabs1,-Mabs2,Mabs3,Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigx','wrong ityp in tosigX 12',' ') + iblock = mcombina(2,-Mabs1,-Mabs2,Mabs3,Mabs4) + factor = real(isgnM(-1,-1,1,1),kind=wp)*prexz1234*real(isgnprod(-Mabs1,-Mabs2,Mabs3,Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteX,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (13) + ityp = mcombina(1,Mabs1,-Mabs2,Mabs3,-Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigx','wrong ityp in tosigX 13',' ') + iblock = mcombina(2,Mabs1,-Mabs2,Mabs3,-Mabs4) + factor = real(isgnM(1,-1,1,-1),kind=wp)*prexz1234*real(isgnprod(Mabs1,-Mabs2,Mabs3,-Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteX,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (14) + ityp = mcombina(1,-Mabs1,Mabs2,-Mabs3,Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigx','wrong ityp in tosigX 14',' ') + iblock = mcombina(2,-Mabs1,Mabs2,-Mabs3,Mabs4) + factor = real(isgnM(-1,1,-1,1),kind=wp)*prexz1234*real(isgnprod(-Mabs1,Mabs2,-Mabs3,Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteX,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (15) + ityp = mcombina(1,Mabs1,-Mabs2,-Mabs3,Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigx','wrong ityp in tosigX 15',' ') + iblock = mcombina(2,Mabs1,-Mabs2,-Mabs3,Mabs4) + factor = real(isgnM(1,-1,-1,1),kind=wp)*prexz1234*real(isgnprod(Mabs1,-Mabs2,-Mabs3,Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteX,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (16) + ityp = mcombina(1,-Mabs1,Mabs2,Mabs3,-Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigx','wrong ityp in tosigX 16',' ') + iblock = mcombina(2,-Mabs1,Mabs2,Mabs3,-Mabs4) + factor = real(isgnM(-1,1,1,-1),kind=wp)*prexz1234*real(isgnprod(-Mabs1,Mabs2,Mabs3,-Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteX,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + end select +end do +if (cleaner) then + do irun=1,ncontl1 + carteX(irun,irun,:,:) = Zero + end do +end if + +return + +end subroutine tosigX diff -Nru openmolcas-22.02/src/amfi_util/tosigy.f openmolcas-22.10/src/amfi_util/tosigy.f --- openmolcas-22.02/src/amfi_util/tosigy.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/tosigy.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,318 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine tosigY(m1,m2,m3,m4,angint, - *mcombina,ncontl1,ncontl2,ncontl3, - *ncontl4,carteY,preY,interxyz,isgnprod, - *cleaner) -cbs this subroutine combines the angular integrals -cbs to the integrals for the real-valued linear -cbs combinations for the sigma_X part -cbs definition of the real-valued linear combinations: -cbs -cbs -cbs M=0 is the same as Y(L,0) -cbs -cbs -cbs M > 0 -cbs -cbs | L,M,+> = 2**(-0.5) ( (-1)**M Y(L,M) + Y(L,-M)) -cbs -cbs | L,M,-> = -i 2**(-0.5) ( (-1)**M Y(L,M) - Y(L,-M)) ($$$$) -cbs -cbs -cbs due to symmetry, there can be only integrals -cbs with one or three (sigma_+ and sigma_-) - combinations -cbs - implicit real*8 (a-h,o-z) -#include "para.fh" - parameter (fine=7.29735308D-03) !TO_BE_CHECKED -cbs at least it's identical with Odd's valuE - parameter (speed=1d0/fine) - parameter (speed2=speed*speed) - dimension mcombina(2,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), - *angint(ncontl1,ncontl2,ncontl3,ncontl4,*), -cbs !!!!!!!!!!!changing now to the order of chemists notation!!!!!!!!!! - *carteY(ncontl1,ncontl3,ncontl2,ncontl4), - *preY(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), - *interxyz(*), - *isgnprod(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), - *isgnM(-1:1,-1:1,-1:1,-1:1) - logical cleaner -c write(6,*) 'begin tosigy ' -cbs cleaning up the integral-array - irun=ncontl4*ncontl2*ncontl3*ncontl1 - call dzero(carteY,irun) -cbs set some signs -cbs isgnM will give an additonal minus-sign if both m-values -cbs (cartesian and angular) are negative see $$$$ - do irun4=-1,1 - do irun3=-1,1 - do irun2=-1,1 - do irun1=-1,1 - isgnM(irun1,irun2,irun3,irun4)=1 - enddo - enddo - enddo - enddo - if (m1.lt.0) then - do irun4=-1,1 - do irun3=-1,1 - do irun2=-1,1 - isgnM(-1,irun2,irun3,irun4)= - *-isgnM(-1,irun2,irun3,irun4) - enddo - enddo - enddo - endif - if (m2.lt.0) then - do irun4=-1,1 - do irun3=-1,1 - do irun1=-1,1 - isgnM(irun1,-1,irun3,irun4)= - *-isgnM(irun1,-1,irun3,irun4) - enddo - enddo - enddo - endif - if (m3.lt.0) then - do irun4=-1,1 - do irun2=-1,1 - do irun1=-1,1 - isgnM(irun1,irun2,-1,irun4)= - *-isgnM(irun1,irun2,-1,irun4) - enddo - enddo - enddo - endif - if (m4.lt.0) then - do irun3=-1,1 - do irun2=-1,1 - do irun1=-1,1 - isgnM(irun1,irun2,irun3,-1)= - *-isgnM(irun1,irun2,irun3,-1) - enddo - enddo - enddo - endif -cbs define absolute m-values - Mabs1=iabs(m1) - Mabs2=iabs(m2) - Mabs3=iabs(m3) - Mabs4=iabs(m4) - irun=0 - if (interxyz(1).eq.0) then - write(6,*) 'tosigy: no interaction: ',m1,m2,m3,m4 - Call Abend() - endif - prey1234=preY(m1,m2,m3,m4) -c write(6,*) 'prey ',prey1234 -c do while (interxyz(irun+1).gt.0) - if(interxyz(irun+1).le.0) goto 777 -666 continue - irun=irun+1 -c write(6,*) 'tosigy: ',irun,interxyz(irun) -c -cbs -cbs -cbs This could be done with gotos, but I am biased to hate those.. -cbs -cbs - if (interxyz(irun).eq.1) then - ityp=mcombina(1,Mabs1,Mabs2,Mabs3,Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigy', 'wrong ityp in tosigY 1',' ') - iblock=mcombina(2,Mabs1,Mabs2,Mabs3,Mabs4) - factor=isgnM(1,1,1,1)*prey1234* - * DBLE(isgnprod(Mabs1,Mabs2,Mabs3,Mabs4)) - if (ityp.eq.3) factor=-factor - call daxpint(angint(1,1,1,1,iblock),carteY, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.2) then - ityp=mcombina(1,-Mabs1,-Mabs2,-Mabs3,-Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigy', 'wrong ityp in tosigY 2',' ') - iblock=mcombina(2,-Mabs1,-Mabs2,-Mabs3,-Mabs4) - factor=isgnM(-1,-1,-1,-1)*prey1234* - * DBLE(isgnprod(-Mabs1,-Mabs2,-Mabs3,-Mabs4)) - if (ityp.eq.3) factor=-factor - call daxpint(angint(1,1,1,1,iblock),carteY, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.3) then - ityp=mcombina(1,Mabs1,Mabs2,Mabs3,-Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigy', 'wrong ityp in tosigY 3',' ') - iblock=mcombina(2,Mabs1,Mabs2,Mabs3,-Mabs4) - factor=isgnM(1,1,1,-1)*prey1234* - * DBLE(isgnprod(Mabs1,Mabs2,Mabs3,-Mabs4)) - if (ityp.eq.3) factor=-factor - call daxpint(angint(1,1,1,1,iblock),carteY, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.4) then - ityp=mcombina(1,-Mabs1,-Mabs2,-Mabs3,Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigy', 'wrong ityp in tosigY 4',' ') - iblock=mcombina(2,-Mabs1,-Mabs2,-Mabs3,Mabs4) - factor=isgnM(-1,-1,-1,1)*prey1234* - * DBLE(isgnprod(-Mabs1,-Mabs2,-Mabs3,Mabs4)) - if (ityp.eq.3) factor=-factor - call daxpint(angint(1,1,1,1,iblock),carteY, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.5) then - ityp=mcombina(1,Mabs1,Mabs2,-Mabs3,Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigy', 'wrong ityp in tosigY 5',' ') - iblock=mcombina(2,Mabs1,Mabs2,-Mabs3,Mabs4) - factor=isgnM(1,1,-1,1)*prey1234* - * DBLE(isgnprod(Mabs1,Mabs2,-Mabs3,Mabs4)) - if (ityp.eq.3) factor=-factor - call daxpint(angint(1,1,1,1,iblock),carteY, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.6) then - ityp=mcombina(1,-Mabs1,-Mabs2,Mabs3,-Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigy', 'wrong ityp in tosigY 6',' ') - iblock=mcombina(2,-Mabs1,-Mabs2,Mabs3,-Mabs4) - factor=isgnM(-1,-1,1,-1)*prey1234* - * DBLE(isgnprod(-Mabs1,-Mabs2,Mabs3,-Mabs4)) - if (ityp.eq.3) factor=-factor - call daxpint(angint(1,1,1,1,iblock),carteY, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.7) then - ityp=mcombina(1,Mabs1,-Mabs2,Mabs3,Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigy', 'wrong ityp in tosigY 7',' ') - iblock=mcombina(2,Mabs1,-Mabs2,Mabs3,Mabs4) - factor=isgnM(1,-1,1,1)*prey1234* - * DBLE(isgnprod(Mabs1,-Mabs2,Mabs3,Mabs4)) - if (ityp.eq.3) factor=-factor - call daxpint(angint(1,1,1,1,iblock),carteY, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.8) then - ityp=mcombina(1,-Mabs1,Mabs2,-Mabs3,-Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigy', 'wrong ityp in tosigY 8',' ') - iblock=mcombina(2,-Mabs1,Mabs2,-Mabs3,-Mabs4) - factor=isgnM(-1,1,-1,-1)*prey1234* - * DBLE(isgnprod(-Mabs1,Mabs2,-Mabs3,-Mabs4)) - if (ityp.eq.3) factor=-factor - call daxpint(angint(1,1,1,1,iblock),carteY, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.9) then - ityp=mcombina(1,-Mabs1,Mabs2,Mabs3,Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigy', 'wrong ityp in tosigY 9',' ') - iblock=mcombina(2,-Mabs1,Mabs2,Mabs3,Mabs4) - factor=isgnM(-1,1,1,1)*prey1234* - * DBLE(isgnprod(-Mabs1,Mabs2,Mabs3,Mabs4)) - if (ityp.eq.3) factor=-factor - call daxpint(angint(1,1,1,1,iblock),carteY, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.10) then - ityp=mcombina(1,Mabs1,-Mabs2,-Mabs3,-Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigy', 'wrong ityp in tosigY 10',' ') - iblock=mcombina(2,Mabs1,-Mabs2,-Mabs3,-Mabs4) - factor=isgnM(1,-1,-1,-1)*prey1234* - * DBLE(isgnprod(Mabs1,-Mabs2,-Mabs3,-Mabs4)) - if (ityp.eq.3) factor=-factor - call daxpint(angint(1,1,1,1,iblock),carteY, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.11) then - ityp=mcombina(1,Mabs1,Mabs2,-Mabs3,-Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigy', 'wrong ityp in tosigY 11',' ') - iblock=mcombina(2,Mabs1,Mabs2,-Mabs3,-Mabs4) - factor=isgnM(1,1,-1,-1)*prey1234* - * DBLE(isgnprod(Mabs1,Mabs2,-Mabs3,-Mabs4)) - if (ityp.eq.3) factor=-factor - call daxpint(angint(1,1,1,1,iblock),carteY, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.12) then - ityp=mcombina(1,-Mabs1,-Mabs2,Mabs3,Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigy', 'wrong ityp in tosigY 12',' ') - iblock=mcombina(2,-Mabs1,-Mabs2,Mabs3,Mabs4) - factor=isgnM(-1,-1,1,1)*prey1234* - * DBLE(isgnprod(-Mabs1,-Mabs2,Mabs3,Mabs4)) - if (ityp.eq.3) factor=-factor - call daxpint(angint(1,1,1,1,iblock),carteY, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.13) then - ityp=mcombina(1,Mabs1,-Mabs2,Mabs3,-Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigy', 'wrong ityp in tosigY 13',' ') - iblock=mcombina(2,Mabs1,-Mabs2,Mabs3,-Mabs4) - factor=isgnM(1,-1,1,-1)*prey1234* - * DBLE(isgnprod(Mabs1,-Mabs2,Mabs3,-Mabs4)) - if (ityp.eq.3) factor=-factor - call daxpint(angint(1,1,1,1,iblock),carteY, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.14) then - ityp=mcombina(1,-Mabs1,Mabs2,-Mabs3,Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigy', 'wrong ityp in tosigY 14',' ') - iblock=mcombina(2,-Mabs1,Mabs2,-Mabs3,Mabs4) - factor=isgnM(-1,1,-1,1)*prey1234* - * DBLE(isgnprod(-Mabs1,Mabs2,-Mabs3,Mabs4)) - if (ityp.eq.3) factor=-factor - call daxpint(angint(1,1,1,1,iblock),carteY, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.15) then - ityp=mcombina(1,Mabs1,-Mabs2,-Mabs3,Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigy', 'wrong ityp in tosigY 15',' ') - iblock=mcombina(2,Mabs1,-Mabs2,-Mabs3,Mabs4) - factor=isgnM(1,-1,-1,1)*prey1234* - * DBLE(isgnprod(Mabs1,-Mabs2,-Mabs3,Mabs4)) - if (ityp.eq.3) factor=-factor - call daxpint(angint(1,1,1,1,iblock),carteY, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.16) then - ityp=mcombina(1,-Mabs1,Mabs2,Mabs3,-Mabs4) - if (ityp.ne.1.and.ityp.ne.3) - * Call SysAbendMsg('tosigy', 'wrong ityp in tosigY 16',' ') - iblock=mcombina(2,-Mabs1,Mabs2,Mabs3,-Mabs4) - factor=isgnM(-1,1,1,-1)*prey1234* - * DBLE(isgnprod(-Mabs1,Mabs2,Mabs3,-Mabs4)) - if (ityp.eq.3) factor=-factor - call daxpint(angint(1,1,1,1,iblock),carteY, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - endif -c Enddo - if(interxyz(irun+1).gt.0) goto 666 -777 continue - if (cleaner) then - do irun4=1,ncontl4 - do irun2=1,ncontl2 - do irun1=1,ncontl1 - cartey(irun1,irun1,irun2,irun4)=0d0 - enddo - enddo - enddo - endif - return - end diff -Nru openmolcas-22.02/src/amfi_util/tosigy.F90 openmolcas-22.10/src/amfi_util/tosigy.F90 --- openmolcas-22.02/src/amfi_util/tosigy.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/tosigy.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,211 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine tosigY(m1,m2,m3,m4,angint,mcombina,ncontl1,ncontl2,ncontl3,ncontl4,carteY,preY,interxyz,isgnprod,cleaner) +!bs this subroutine combines the angular integrals +!bs to the integrals for the real-valued linear +!bs combinations for the sigma_X part +!bs definition of the real-valued linear combinations: +!bs +!bs M=0 is the same as Y(L,0) +!bs +!bs M > 0 +!bs +!bs | L,M,+> = 2**(-0.5) ( (-1)**M Y(L,M) + Y(L,-M)) +!bs +!bs | L,M,-> = -i 2**(-0.5) ( (-1)**M Y(L,M) - Y(L,-M)) ($$$$) +!bs +!bs due to symmetry, there can be only integrals +!bs with one or three (sigma_+ and sigma_-) - combinations + +use AMFI_global, only: Lmax +use Constants, only: Zero, One, speed => c_in_au +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: m1, m2, m3, m4, mcombina(2,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), ncontl1, ncontl2, & + ncontl3, ncontl4, interxyz(*), isgnprod(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) +real(kind=wp), intent(in) :: angint(ncontl1,ncontl2,ncontl3,ncontl4,*), preY(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) +!bs !!!!!!!!!!!changing now to the order of chemists notation!!!!!!!!!! +real(kind=wp), intent(out) :: carteY(ncontl1,ncontl3,ncontl2,ncontl4) +logical(kind=iwp), intent(in) :: cleaner +integer(kind=iwp) :: iblock, irun, isgnM(-1:1,-1:1,-1:1,-1:1), ityp, Mabs1, Mabs2, Mabs3, Mabs4 +real(kind=wp) :: factor, prey1234 +real(kind=wp), parameter :: fine = One/speed, speed2 = speed*speed + +!write(u6,*) 'begin tosigy ' +!bs cleaning up the integral-array +carteY(:,:,:,:) = Zero +!bs set some signs +!bs isgnM will give an additonal minus-sign if both m-values +!bs (cartesian and angular) are negative see $$$$ +isgnM(:,:,:,:) = 1 +if (m1 < 0) isgnM(-1,:,:,:) = -isgnM(-1,:,:,:) +if (m2 < 0) isgnM(:,-1,:,:) = -isgnM(:,-1,:,:) +if (m3 < 0) isgnM(:,:,-1,:) = -isgnM(:,:,-1,:) +if (m4 < 0) isgnM(:,:,:,-1) = -isgnM(:,:,:,-1) +!bs define absolute m-values +Mabs1 = abs(m1) +Mabs2 = abs(m2) +Mabs3 = abs(m3) +Mabs4 = abs(m4) +irun = 0 +if (interxyz(1) == 0) then + write(u6,*) 'tosigy: no interaction: ',m1,m2,m3,m4 + call Abend() +end if +prey1234 = preY(m1,m2,m3,m4) +!write(u6,*) 'prey ',prey1234 +do while (interxyz(irun+1) > 0) + irun = irun+1 + !write(u6,*) 'tosigy: ',irun,interxyz(irun) + + select case (interxyz(irun)) + + case (1) + ityp = mcombina(1,Mabs1,Mabs2,Mabs3,Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigy','wrong ityp in tosigY 1',' ') + iblock = mcombina(2,Mabs1,Mabs2,Mabs3,Mabs4) + factor = isgnM(1,1,1,1)*prey1234*real(isgnprod(Mabs1,Mabs2,Mabs3,Mabs4),kind=wp) + if (ityp == 3) factor = -factor + call daxpint(angint(:,:,:,:,iblock),carteY,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (2) + ityp = mcombina(1,-Mabs1,-Mabs2,-Mabs3,-Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigy','wrong ityp in tosigY 2',' ') + iblock = mcombina(2,-Mabs1,-Mabs2,-Mabs3,-Mabs4) + factor = isgnM(-1,-1,-1,-1)*prey1234*real(isgnprod(-Mabs1,-Mabs2,-Mabs3,-Mabs4),kind=wp) + if (ityp == 3) factor = -factor + call daxpint(angint(:,:,:,:,iblock),carteY,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (3) + ityp = mcombina(1,Mabs1,Mabs2,Mabs3,-Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigy','wrong ityp in tosigY 3',' ') + iblock = mcombina(2,Mabs1,Mabs2,Mabs3,-Mabs4) + factor = isgnM(1,1,1,-1)*prey1234*real(isgnprod(Mabs1,Mabs2,Mabs3,-Mabs4),kind=wp) + if (ityp == 3) factor = -factor + call daxpint(angint(:,:,:,:,iblock),carteY,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (4) + ityp = mcombina(1,-Mabs1,-Mabs2,-Mabs3,Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigy','wrong ityp in tosigY 4',' ') + iblock = mcombina(2,-Mabs1,-Mabs2,-Mabs3,Mabs4) + factor = isgnM(-1,-1,-1,1)*prey1234*real(isgnprod(-Mabs1,-Mabs2,-Mabs3,Mabs4),kind=wp) + if (ityp == 3) factor = -factor + call daxpint(angint(:,:,:,:,iblock),carteY,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (5) + ityp = mcombina(1,Mabs1,Mabs2,-Mabs3,Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigy','wrong ityp in tosigY 5',' ') + iblock = mcombina(2,Mabs1,Mabs2,-Mabs3,Mabs4) + factor = isgnM(1,1,-1,1)*prey1234*real(isgnprod(Mabs1,Mabs2,-Mabs3,Mabs4),kind=wp) + if (ityp == 3) factor = -factor + call daxpint(angint(:,:,:,:,iblock),carteY,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (6) + ityp = mcombina(1,-Mabs1,-Mabs2,Mabs3,-Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigy','wrong ityp in tosigY 6',' ') + iblock = mcombina(2,-Mabs1,-Mabs2,Mabs3,-Mabs4) + factor = isgnM(-1,-1,1,-1)*prey1234*real(isgnprod(-Mabs1,-Mabs2,Mabs3,-Mabs4),kind=wp) + if (ityp == 3) factor = -factor + call daxpint(angint(:,:,:,:,iblock),carteY,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (7) + ityp = mcombina(1,Mabs1,-Mabs2,Mabs3,Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigy','wrong ityp in tosigY 7',' ') + iblock = mcombina(2,Mabs1,-Mabs2,Mabs3,Mabs4) + factor = isgnM(1,-1,1,1)*prey1234*real(isgnprod(Mabs1,-Mabs2,Mabs3,Mabs4),kind=wp) + if (ityp == 3) factor = -factor + call daxpint(angint(:,:,:,:,iblock),carteY,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (8) + ityp = mcombina(1,-Mabs1,Mabs2,-Mabs3,-Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigy','wrong ityp in tosigY 8',' ') + iblock = mcombina(2,-Mabs1,Mabs2,-Mabs3,-Mabs4) + factor = isgnM(-1,1,-1,-1)*prey1234*real(isgnprod(-Mabs1,Mabs2,-Mabs3,-Mabs4),kind=wp) + if (ityp == 3) factor = -factor + call daxpint(angint(:,:,:,:,iblock),carteY,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (9) + ityp = mcombina(1,-Mabs1,Mabs2,Mabs3,Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigy','wrong ityp in tosigY 9',' ') + iblock = mcombina(2,-Mabs1,Mabs2,Mabs3,Mabs4) + factor = isgnM(-1,1,1,1)*prey1234*real(isgnprod(-Mabs1,Mabs2,Mabs3,Mabs4),kind=wp) + if (ityp == 3) factor = -factor + call daxpint(angint(:,:,:,:,iblock),carteY,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (10) + ityp = mcombina(1,Mabs1,-Mabs2,-Mabs3,-Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigy','wrong ityp in tosigY 10',' ') + iblock = mcombina(2,Mabs1,-Mabs2,-Mabs3,-Mabs4) + factor = isgnM(1,-1,-1,-1)*prey1234*real(isgnprod(Mabs1,-Mabs2,-Mabs3,-Mabs4),kind=wp) + if (ityp == 3) factor = -factor + call daxpint(angint(:,:,:,:,iblock),carteY,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (11) + ityp = mcombina(1,Mabs1,Mabs2,-Mabs3,-Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigy','wrong ityp in tosigY 11',' ') + iblock = mcombina(2,Mabs1,Mabs2,-Mabs3,-Mabs4) + factor = isgnM(1,1,-1,-1)*prey1234*real(isgnprod(Mabs1,Mabs2,-Mabs3,-Mabs4),kind=wp) + if (ityp == 3) factor = -factor + call daxpint(angint(:,:,:,:,iblock),carteY,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (12) + ityp = mcombina(1,-Mabs1,-Mabs2,Mabs3,Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigy','wrong ityp in tosigY 12',' ') + iblock = mcombina(2,-Mabs1,-Mabs2,Mabs3,Mabs4) + factor = isgnM(-1,-1,1,1)*prey1234*real(isgnprod(-Mabs1,-Mabs2,Mabs3,Mabs4),kind=wp) + if (ityp == 3) factor = -factor + call daxpint(angint(:,:,:,:,iblock),carteY,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (13) + ityp = mcombina(1,Mabs1,-Mabs2,Mabs3,-Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigy','wrong ityp in tosigY 13',' ') + iblock = mcombina(2,Mabs1,-Mabs2,Mabs3,-Mabs4) + factor = isgnM(1,-1,1,-1)*prey1234*real(isgnprod(Mabs1,-Mabs2,Mabs3,-Mabs4),kind=wp) + if (ityp == 3) factor = -factor + call daxpint(angint(:,:,:,:,iblock),carteY,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (14) + ityp = mcombina(1,-Mabs1,Mabs2,-Mabs3,Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigy','wrong ityp in tosigY 14',' ') + iblock = mcombina(2,-Mabs1,Mabs2,-Mabs3,Mabs4) + factor = isgnM(-1,1,-1,1)*prey1234*real(isgnprod(-Mabs1,Mabs2,-Mabs3,Mabs4),kind=wp) + if (ityp == 3) factor = -factor + call daxpint(angint(:,:,:,:,iblock),carteY,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (15) + ityp = mcombina(1,Mabs1,-Mabs2,-Mabs3,Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigy','wrong ityp in tosigY 15',' ') + iblock = mcombina(2,Mabs1,-Mabs2,-Mabs3,Mabs4) + factor = isgnM(1,-1,-1,1)*prey1234*real(isgnprod(Mabs1,-Mabs2,-Mabs3,Mabs4),kind=wp) + if (ityp == 3) factor = -factor + call daxpint(angint(:,:,:,:,iblock),carteY,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (16) + ityp = mcombina(1,-Mabs1,Mabs2,Mabs3,-Mabs4) + if ((ityp /= 1) .and. (ityp /= 3)) call SysAbendMsg('tosigy','wrong ityp in tosigY 16',' ') + iblock = mcombina(2,-Mabs1,Mabs2,Mabs3,-Mabs4) + factor = isgnM(-1,1,1,-1)*prey1234*real(isgnprod(-Mabs1,Mabs2,Mabs3,-Mabs4),kind=wp) + if (ityp == 3) factor = -factor + call daxpint(angint(:,:,:,:,iblock),carteY,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + end select +end do +if (cleaner) then + do irun=1,ncontl1 + carteY(irun,irun,:,:) = Zero + end do +end if + +return + +end subroutine tosigY diff -Nru openmolcas-22.02/src/amfi_util/tosigz.f openmolcas-22.10/src/amfi_util/tosigz.f --- openmolcas-22.02/src/amfi_util/tosigz.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/tosigz.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,299 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine tosigZ(m1,m2,m3,m4,angint, - *mcombina,ncontl1,ncontl2,ncontl3, - *ncontl4,carteZ,preXZ,interxyz,isgnprod, - *cleaner) -cbs this subroutine combines the angular integrals -cbs to the integrals for the real-valued linear -cbs combinations for the sigma_Z part -cbs definition of the real-valued linear combinations: -cbs -cbs -cbs M=0 is the same as Y(L,0) -cbs -cbs -cbs M > 0 -cbs -cbs | L,M,+> = 2**(-0.5) ( (-1)**M Y(L,M) + Y(L,-M)) -cbs -cbs | L,M,-> = -i 2**(-0.5) ( (-1)**M Y(L,M) - Y(L,-M)) ($$$$) -cbs -cbs only angular integrals of type 2 (sigma_0) contribute -cbs - implicit real*8 (a-h,o-z) -#include "para.fh" - parameter (fine=7.29735308D-03) !TO_BE_CHECKED -cbs at least it's identical with Odd's valuE - parameter (speed=1d0/fine) - parameter (speed2=speed*speed) - dimension mcombina(2,-Lmax:Lmax,-Lmax:Lmax, - *-Lmax:Lmax,-Lmax:Lmax), - *angint(ncontl1,ncontl2,ncontl3,ncontl4,*), -cbs !!!!!!!!!!!changing now to the order of chemists notation!!!!!!!!!! - *carteZ(ncontl1,ncontl3,ncontl2,ncontl4), - *preXZ(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), - *interxyz(*), - *isgnprod(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), - *isgnM(-1:1,-1:1,-1:1,-1:1) - logical cleaner -cbs cleaning up the integral-array - irun=ncontl4*ncontl2*ncontl3*ncontl1 - call dzero(carteZ,irun) -c write(6,*) 'begin tosigz' -cbs set some signs -cbs isgnM will give an additonal minus-sign if both m-values -cbs (cartesian and angular) are negative see $$$$ - do irun4=-1,1 - do irun3=-1,1 - do irun2=-1,1 - do irun1=-1,1 - isgnM(irun1,irun2,irun3,irun4)=1 - enddo - enddo - enddo - enddo - if (m1.lt.0) then - do irun4=-1,1 - do irun3=-1,1 - do irun2=-1,1 - isgnM(-1,irun2,irun3,irun4)= - *-isgnM(-1,irun2,irun3,irun4) - enddo - enddo - enddo - endif - if (m2.lt.0) then - do irun4=-1,1 - do irun3=-1,1 - do irun1=-1,1 - isgnM(irun1,-1,irun3,irun4)= - *-isgnM(irun1,-1,irun3,irun4) - enddo - enddo - enddo - endif - if (m3.lt.0) then - do irun4=-1,1 - do irun2=-1,1 - do irun1=-1,1 - isgnM(irun1,irun2,-1,irun4)= - *-isgnM(irun1,irun2,-1,irun4) - enddo - enddo - enddo - endif - if (m4.lt.0) then - do irun3=-1,1 - do irun2=-1,1 - do irun1=-1,1 - isgnM(irun1,irun2,irun3,-1)= - *-isgnM(irun1,irun2,irun3,-1) - enddo - enddo - enddo - endif -cbs define absolute m-values - Mabs1=iabs(m1) - Mabs2=iabs(m2) - Mabs3=iabs(m3) - Mabs4=iabs(m4) - irun=0 - if (interxyz(1).eq.0) then - write(6,*) 'tosigz: no interaction: ',m1,m2,m3,m4 - Call Abend() - endif - prexz1234=preXZ(m1,m2,m3,m4) -c do while (interxyz(irun+1).gt.0) - if(interxyz(irun+1).le.0) goto 777 -666 continue - irun=irun+1 -c -cbs -cbs -cbs This could be done with gotos, but I am biased to hate those.. -cbs -cbs - if (interxyz(irun).eq.1) then - ityp=mcombina(1,Mabs1,Mabs2,Mabs3,Mabs4) - if (ityp.ne.2) - * Call SysAbendMsg('tosigz', 'wrong ityp in tosigz 1',' ' ) - iblock=mcombina(2,Mabs1,Mabs2,Mabs3,Mabs4) - factor=isgnM(1,1,1,1)*prexz1234* - * DBLE(isgnprod(Mabs1,Mabs2,Mabs3,Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteZ, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.2) then - ityp=mcombina(1,Mabs1,Mabs2,Mabs3,Mabs4) - if (ityp.ne.2) - * Call SysAbendMsg('tosigz', 'wrong ityp in tosigz 2',' ' ) - iblock=mcombina(2,Mabs1,Mabs2,Mabs3,Mabs4) - factor=-isgnM(-1,-1,-1,-1)*prexz1234* - * DBLE(isgnprod(-Mabs1,-Mabs2,-Mabs3,-Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteZ, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.3) then - ityp=mcombina(1,Mabs1,Mabs2,Mabs3,-Mabs4) - if (ityp.ne.2) - * Call SysAbendMsg('tosigz', 'wrong ityp in tosigz 3',' ' ) - iblock=mcombina(2,Mabs1,Mabs2,Mabs3,-Mabs4) - factor=isgnM(1,1,1,-1)*prexz1234* - * DBLE(isgnprod(Mabs1,Mabs2,Mabs3,-Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteZ, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.4) then - ityp=mcombina(1,Mabs1,Mabs2,Mabs3,-Mabs4) - if (ityp.ne.2) - * Call SysAbendMsg('tosigz', 'wrong ityp in tosigz 4',' ' ) - iblock=mcombina(2,Mabs1,Mabs2,Mabs3,-Mabs4) - factor=-isgnM(-1,-1,-1,1)*prexz1234* - * DBLE(isgnprod(-Mabs1,-Mabs2,-Mabs3,Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteZ, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.5) then - ityp=mcombina(1,Mabs1,Mabs2,-Mabs3,Mabs4) - if (ityp.ne.2) - * Call SysAbendMsg('tosigz', 'wrong ityp in tosigz 5',' ' ) - iblock=mcombina(2,Mabs1,Mabs2,-Mabs3,Mabs4) - factor=isgnM(1,1,-1,1)*prexz1234* - * DBLE(isgnprod(Mabs1,Mabs2,-Mabs3,Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteZ, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.6) then - ityp=mcombina(1,Mabs1,Mabs2,-Mabs3,Mabs4) - if (ityp.ne.2) - * Call SysAbendMsg('tosigz', 'wrong ityp in tosigz 6',' ' ) - iblock=mcombina(2,Mabs1,Mabs2,-Mabs3,Mabs4) - factor=-isgnM(-1,-1,1,-1)*prexz1234* - * DBLE(isgnprod(-Mabs1,-Mabs2,Mabs3,-Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteZ, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.7) then - ityp=mcombina(1,Mabs1,-Mabs2,Mabs3,Mabs4) - if (ityp.ne.2) - * Call SysAbendMsg('tosigz', 'wrong ityp in tosigz 7',' ' ) - iblock=mcombina(2,Mabs1,-Mabs2,Mabs3,Mabs4) - factor=isgnM(1,-1,1,1)*prexz1234* - * DBLE(isgnprod(Mabs1,-Mabs2,Mabs3,Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteZ, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.8) then - ityp=mcombina(1,Mabs1,-Mabs2,Mabs3,Mabs4) - if (ityp.ne.2) - * Call SysAbendMsg('tosigz', 'wrong ityp in tosigz 8',' ' ) - iblock=mcombina(2,Mabs1,-Mabs2,Mabs3,Mabs4) - factor=-isgnM(-1,1,-1,-1)*prexz1234* - * DBLE(isgnprod(-Mabs1,Mabs2,-Mabs3,-Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteZ, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.9) then - ityp=mcombina(1,Mabs1,-Mabs2,-Mabs3,-Mabs4) - if (ityp.ne.2) - * Call SysAbendMsg('tosigz', 'wrong ityp in tosigz 9',' ' ) - iblock=mcombina(2,Mabs1,-Mabs2,-Mabs3,-Mabs4) - factor=-isgnM(-1,1,1,1)*prexz1234* - * DBLE(isgnprod(-Mabs1,Mabs2,Mabs3,Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteZ, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.10) then - ityp=mcombina(1,Mabs1,-Mabs2,-Mabs3,-Mabs4) - if (ityp.ne.2) - * Call SysAbendMsg('tosigz', 'wrong ityp in tosigz 10',' ' ) - iblock=mcombina(2,Mabs1,-Mabs2,-Mabs3,-Mabs4) - factor=isgnM(1,-1,-1,-1)*prexz1234* - * DBLE(isgnprod(Mabs1,-Mabs2,-Mabs3,-Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteZ, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.11) then - ityp=mcombina(1,Mabs1,Mabs2,-Mabs3,-Mabs4) - if (ityp.ne.2) - * Call SysAbendMsg('tosigz', 'wrong ityp in tosigz 11',' ' ) - iblock=mcombina(2,Mabs1,Mabs2,-Mabs3,-Mabs4) - factor=isgnM(1,1,-1,-1)*prexz1234* - * DBLE(isgnprod(Mabs1,Mabs2,-Mabs3,-Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteZ, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.12) then - ityp=mcombina(1,Mabs1,Mabs2,-Mabs3,-Mabs4) - if (ityp.ne.2) - * Call SysAbendMsg('tosigz', 'wrong ityp in tosigz 12',' ' ) - iblock=mcombina(2,Mabs1,Mabs2,-Mabs3,-Mabs4) - factor=-isgnM(-1,-1,1,1)*prexz1234* - * DBLE(isgnprod(-Mabs1,-Mabs2,Mabs3,Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteZ, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.13) then - ityp=mcombina(1,Mabs1,-Mabs2,Mabs3,-Mabs4) - if (ityp.ne.2) - * Call SysAbendMsg('tosigz', 'wrong ityp in tosigz 13',' ' ) - iblock=mcombina(2,Mabs1,-Mabs2,Mabs3,-Mabs4) - factor=isgnM(1,-1,1,-1)*prexz1234* - * DBLE(isgnprod(Mabs1,-Mabs2,Mabs3,-Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteZ, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.14) then - ityp=mcombina(1,Mabs1,-Mabs2,Mabs3,-Mabs4) - if (ityp.ne.2) - * Call SysAbendMsg('tosigz', 'wrong ityp in tosigz 14',' ' ) - iblock=mcombina(2,Mabs1,-Mabs2,Mabs3,-Mabs4) - factor=-isgnM(-1,1,-1,1)*prexz1234* - * DBLE(isgnprod(-Mabs1,Mabs2,-Mabs3,Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteZ, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.15) then - ityp=mcombina(1,Mabs1,-Mabs2,-Mabs3,Mabs4) - if (ityp.ne.2) - * Call SysAbendMsg('tosigz', 'wrong ityp in tosigz 15',' ' ) - iblock=mcombina(2,Mabs1,-Mabs2,-Mabs3,Mabs4) - factor=isgnM(1,-1,-1,1)*prexz1234* - * DBLE(isgnprod(Mabs1,-Mabs2,-Mabs3,Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteZ, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - elseif (interxyz(irun).eq.16) then - ityp=mcombina(1,Mabs1,-Mabs2,-Mabs3,Mabs4) - if (ityp.ne.2) - * Call SysAbendMsg('tosigz', 'wrong ityp in tosigz 16',' ' ) - iblock=mcombina(2,Mabs1,-Mabs2,-Mabs3,Mabs4) - factor=-isgnM(-1,1,1,-1)*prexz1234* - * DBLE(isgnprod(-Mabs1,Mabs2,Mabs3,-Mabs4)) - call daxpint(angint(1,1,1,1,iblock),carteZ, - * factor,ncontl1,ncontl2,ncontl3,ncontl4) -c - endif -c enddo - if(interxyz(irun+1).gt.0) goto 666 -777 continue - if (cleaner) then - do irun4=1,ncontl4 - do irun2=1,ncontl2 - do irun1=1,ncontl1 - cartez(irun1,irun1,irun2,irun4)=0d0 - enddo - enddo - enddo - endif - return - end diff -Nru openmolcas-22.02/src/amfi_util/tosigz.F90 openmolcas-22.10/src/amfi_util/tosigz.F90 --- openmolcas-22.02/src/amfi_util/tosigz.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/tosigz.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,192 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine tosigZ(m1,m2,m3,m4,angint,mcombina,ncontl1,ncontl2,ncontl3,ncontl4,carteZ,preXZ,interxyz,isgnprod,cleaner) +!bs this subroutine combines the angular integrals +!bs to the integrals for the real-valued linear +!bs combinations for the sigma_Z part +!bs definition of the real-valued linear combinations: +!bs +!bs M=0 is the same as Y(L,0) +!bs +!bs M > 0 +!bs +!bs | L,M,+> = 2**(-0.5) ( (-1)**M Y(L,M) + Y(L,-M)) +!bs +!bs | L,M,-> = -i 2**(-0.5) ( (-1)**M Y(L,M) - Y(L,-M)) ($$$$) +!bs +!bs only angular integrals of type 2 (sigma_0) contribute + +use AMFI_global, only: Lmax +use Constants, only: Zero, One, speed => c_in_au +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: m1, m2, m3, m4, mcombina(2,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), ncontl1, ncontl2, & + ncontl3, ncontl4, interxyz(*), isgnprod(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) +real(kind=wp), intent(in) :: angint(ncontl1,ncontl2,ncontl3,ncontl4,*), preXZ(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax) +!bs !!!!!!!!!!!changing now to the order of chemists notation!!!!!!!!!! +real(kind=wp), intent(out) :: carteZ(ncontl1,ncontl3,ncontl2,ncontl4) +logical(kind=iwp), intent(in) :: cleaner +integer(kind=iwp) :: iblock, irun, isgnM(-1:1,-1:1,-1:1,-1:1), ityp, Mabs1, Mabs2, Mabs3, Mabs4 +real(kind=wp) :: factor, prexz1234 +real(kind=wp), parameter :: fine = One/speed, speed2 = speed**2 + +!bs cleaning up the integral-array +carteZ(:,:,:,:) = Zero +!write(u6,*) 'begin tosigz' +!bs set some signs +!bs isgnM will give an additonal minus-sign if both m-values +!bs (cartesian and angular) are negative see $$$$ +isgnM(:,:,:,:) = 1 +if (m1 < 0) isgnM(-1,:,:,:) = -isgnM(-1,:,:,:) +if (m2 < 0) isgnM(:,-1,:,:) = -isgnM(:,-1,:,:) +if (m3 < 0) isgnM(:,:,-1,:) = -isgnM(:,:,-1,:) +if (m4 < 0) isgnM(:,:,:,-1) = -isgnM(:,:,:,-1) +!bs define absolute m-values +Mabs1 = abs(m1) +Mabs2 = abs(m2) +Mabs3 = abs(m3) +Mabs4 = abs(m4) +irun = 0 +if (interxyz(1) == 0) then + write(u6,*) 'tosigz: no interaction: ',m1,m2,m3,m4 + call Abend() +end if +prexz1234 = preXZ(m1,m2,m3,m4) +do while (interxyz(irun+1) > 0) + irun = irun+1 + + select case (interxyz(irun)) + + case (1) + ityp = mcombina(1,Mabs1,Mabs2,Mabs3,Mabs4) + if (ityp /= 2) call SysAbendMsg('tosigz','wrong ityp in tosigz 1',' ') + iblock = mcombina(2,Mabs1,Mabs2,Mabs3,Mabs4) + factor = isgnM(1,1,1,1)*prexz1234*real(isgnprod(Mabs1,Mabs2,Mabs3,Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteZ,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (2) + ityp = mcombina(1,Mabs1,Mabs2,Mabs3,Mabs4) + if (ityp /= 2) call SysAbendMsg('tosigz','wrong ityp in tosigz 2',' ') + iblock = mcombina(2,Mabs1,Mabs2,Mabs3,Mabs4) + factor = -isgnM(-1,-1,-1,-1)*prexz1234*real(isgnprod(-Mabs1,-Mabs2,-Mabs3,-Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteZ,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (3) + ityp = mcombina(1,Mabs1,Mabs2,Mabs3,-Mabs4) + if (ityp /= 2) call SysAbendMsg('tosigz','wrong ityp in tosigz 3',' ') + iblock = mcombina(2,Mabs1,Mabs2,Mabs3,-Mabs4) + factor = isgnM(1,1,1,-1)*prexz1234*real(isgnprod(Mabs1,Mabs2,Mabs3,-Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteZ,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (4) + ityp = mcombina(1,Mabs1,Mabs2,Mabs3,-Mabs4) + if (ityp /= 2) call SysAbendMsg('tosigz','wrong ityp in tosigz 4',' ') + iblock = mcombina(2,Mabs1,Mabs2,Mabs3,-Mabs4) + factor = -isgnM(-1,-1,-1,1)*prexz1234*real(isgnprod(-Mabs1,-Mabs2,-Mabs3,Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteZ,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (5) + ityp = mcombina(1,Mabs1,Mabs2,-Mabs3,Mabs4) + if (ityp /= 2) call SysAbendMsg('tosigz','wrong ityp in tosigz 5',' ') + iblock = mcombina(2,Mabs1,Mabs2,-Mabs3,Mabs4) + factor = isgnM(1,1,-1,1)*prexz1234*real(isgnprod(Mabs1,Mabs2,-Mabs3,Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteZ,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (6) + ityp = mcombina(1,Mabs1,Mabs2,-Mabs3,Mabs4) + if (ityp /= 2) call SysAbendMsg('tosigz','wrong ityp in tosigz 6',' ') + iblock = mcombina(2,Mabs1,Mabs2,-Mabs3,Mabs4) + factor = -isgnM(-1,-1,1,-1)*prexz1234*real(isgnprod(-Mabs1,-Mabs2,Mabs3,-Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteZ,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (7) + ityp = mcombina(1,Mabs1,-Mabs2,Mabs3,Mabs4) + if (ityp /= 2) call SysAbendMsg('tosigz','wrong ityp in tosigz 7',' ') + iblock = mcombina(2,Mabs1,-Mabs2,Mabs3,Mabs4) + factor = isgnM(1,-1,1,1)*prexz1234*real(isgnprod(Mabs1,-Mabs2,Mabs3,Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteZ,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (8) + ityp = mcombina(1,Mabs1,-Mabs2,Mabs3,Mabs4) + if (ityp /= 2) call SysAbendMsg('tosigz','wrong ityp in tosigz 8',' ') + iblock = mcombina(2,Mabs1,-Mabs2,Mabs3,Mabs4) + factor = -isgnM(-1,1,-1,-1)*prexz1234*real(isgnprod(-Mabs1,Mabs2,-Mabs3,-Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteZ,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (9) + ityp = mcombina(1,Mabs1,-Mabs2,-Mabs3,-Mabs4) + if (ityp /= 2) call SysAbendMsg('tosigz','wrong ityp in tosigz 9',' ') + iblock = mcombina(2,Mabs1,-Mabs2,-Mabs3,-Mabs4) + factor = -isgnM(-1,1,1,1)*prexz1234*real(isgnprod(-Mabs1,Mabs2,Mabs3,Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteZ,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (10) + ityp = mcombina(1,Mabs1,-Mabs2,-Mabs3,-Mabs4) + if (ityp /= 2) call SysAbendMsg('tosigz','wrong ityp in tosigz 10',' ') + iblock = mcombina(2,Mabs1,-Mabs2,-Mabs3,-Mabs4) + factor = isgnM(1,-1,-1,-1)*prexz1234*real(isgnprod(Mabs1,-Mabs2,-Mabs3,-Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteZ,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (11) + ityp = mcombina(1,Mabs1,Mabs2,-Mabs3,-Mabs4) + if (ityp /= 2) call SysAbendMsg('tosigz','wrong ityp in tosigz 11',' ') + iblock = mcombina(2,Mabs1,Mabs2,-Mabs3,-Mabs4) + factor = isgnM(1,1,-1,-1)*prexz1234*real(isgnprod(Mabs1,Mabs2,-Mabs3,-Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteZ,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (12) + ityp = mcombina(1,Mabs1,Mabs2,-Mabs3,-Mabs4) + if (ityp /= 2) call SysAbendMsg('tosigz','wrong ityp in tosigz 12',' ') + iblock = mcombina(2,Mabs1,Mabs2,-Mabs3,-Mabs4) + factor = -isgnM(-1,-1,1,1)*prexz1234*real(isgnprod(-Mabs1,-Mabs2,Mabs3,Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteZ,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (13) + ityp = mcombina(1,Mabs1,-Mabs2,Mabs3,-Mabs4) + if (ityp /= 2) call SysAbendMsg('tosigz','wrong ityp in tosigz 13',' ') + iblock = mcombina(2,Mabs1,-Mabs2,Mabs3,-Mabs4) + factor = isgnM(1,-1,1,-1)*prexz1234*real(isgnprod(Mabs1,-Mabs2,Mabs3,-Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteZ,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (14) + ityp = mcombina(1,Mabs1,-Mabs2,Mabs3,-Mabs4) + if (ityp /= 2) call SysAbendMsg('tosigz','wrong ityp in tosigz 14',' ') + iblock = mcombina(2,Mabs1,-Mabs2,Mabs3,-Mabs4) + factor = -isgnM(-1,1,-1,1)*prexz1234*real(isgnprod(-Mabs1,Mabs2,-Mabs3,Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteZ,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (15) + ityp = mcombina(1,Mabs1,-Mabs2,-Mabs3,Mabs4) + if (ityp /= 2) call SysAbendMsg('tosigz','wrong ityp in tosigz 15',' ') + iblock = mcombina(2,Mabs1,-Mabs2,-Mabs3,Mabs4) + factor = isgnM(1,-1,-1,1)*prexz1234*real(isgnprod(Mabs1,-Mabs2,-Mabs3,Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteZ,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + case (16) + ityp = mcombina(1,Mabs1,-Mabs2,-Mabs3,Mabs4) + if (ityp /= 2) call SysAbendMsg('tosigz','wrong ityp in tosigz 16',' ') + iblock = mcombina(2,Mabs1,-Mabs2,-Mabs3,Mabs4) + factor = -isgnM(-1,1,1,-1)*prexz1234*real(isgnprod(-Mabs1,Mabs2,Mabs3,-Mabs4),kind=wp) + call daxpint(angint(:,:,:,:,iblock),carteZ,factor,ncontl1,ncontl2,ncontl3,ncontl4) + + end select +end do +if (cleaner) then + do irun=1,ncontl1 + carteZ(irun,irun,:,:) = Zero + end do +end if + +return + +end subroutine tosigZ diff -Nru openmolcas-22.02/src/amfi_util/trans_amfi.f openmolcas-22.10/src/amfi_util/trans_amfi.f --- openmolcas-22.02/src/amfi_util/trans_amfi.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/trans_amfi.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,98 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine trans_amfi( -cbs makes the transformation for the ich-th index - *coeffs, !(nolds(ith),nnew(ith)) modified contraction coefficients - *idim1, ! first dimension - *idim2, ! second dimension - *ich, ! index to be changed - *nolds1,nolds2,nolds3,nolds4, ! old dimensions - *nnew1,nnew2,nnew3,nnew4, ! new dimensions - *array1, ! array of size (nolds1,nolds2,nolds3,nolds4) - *array2 ! array of size (nnew1,nnew2,nnew3,nnew4) - *) - implicit real*8 (a-h,o-z) - dimension coeffs(idim1,idim2), - *array1(nolds1,nolds2,nolds3,nolds4), - *array2(nnew1,nnew2,nnew3,nnew4) -c write(6,*) 'begin trans ' ,ich -c write(6,'(8I5)') nolds1,nolds2,nolds3,nolds4, -c *nnew1,nnew2,nnew3,nnew4 - do ind4=1,nnew4 - do ind3=1,nnew3 - do ind2=1,nnew2 - do ind1=1,nnew1 - array2(ind1,ind2,ind3,ind4)=0d0 - enddo - enddo - enddo - enddo - if (ich.eq.1) then - do ind4=1,nnew4 - do ind3=1,nnew3 - do ind2=1,nnew2 - do ind5=1,nnew1 - do ind1=1,nolds1 - array2(ind5,ind2,ind3,ind4)=array2(ind5,ind2,ind3,ind4)+ - *coeffs(ind1,ind5)*array1(ind1,ind2,ind3,ind4) - enddo - enddo - enddo - enddo - enddo - elseif (ich.eq.2) then -c write(6,*) 'transform second index ' - do ind4=1,nnew4 - do ind3=1,nnew3 - do ind5=1,nnew2 - do ind2=1,nolds2 - coeff=coeffs(ind2,ind5) - do ind1=1,nnew1 - array2(ind1,ind5,ind3,ind4)=array2(ind1,ind5,ind3,ind4)+ - *coeff*array1(ind1,ind2,ind3,ind4) - enddo - enddo - enddo - enddo - enddo -c write(6,*) 'end to transform second index ' - elseif (ich.eq.3) then - do ind4=1,nnew4 - do ind5=1,nnew3 - do ind3=1,nolds3 - coeff=coeffs(ind3,ind5) - do ind2=1,nnew2 - do ind1=1,nnew1 - array2(ind1,ind2,ind5,ind4)=array2(ind1,ind2,ind5,ind4)+ - *coeff*array1(ind1,ind2,ind3,ind4) - enddo - enddo - enddo - enddo - enddo - elseif (ich.eq.4) then - do ind5=1,nnew4 - do ind4=1,nolds4 - coeff=coeffs(ind4,ind5) - do ind3=1,nnew3 - do ind2=1,nnew2 - do ind1=1,nnew1 - array2(ind1,ind2,ind3,ind5)=array2(ind1,ind2,ind3,ind5)+ - *coeff*array1(ind1,ind2,ind3,ind4) - enddo - enddo - enddo - enddo - enddo - endif -c write(6,*) 'end trans ' - return - end diff -Nru openmolcas-22.02/src/amfi_util/trans_amfi.F90 openmolcas-22.10/src/amfi_util/trans_amfi.F90 --- openmolcas-22.02/src/amfi_util/trans_amfi.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/trans_amfi.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,78 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine trans_amfi(coeffs,idim1,idim2,ich,nolds1,nolds2,nolds3,nolds4,nnew1,nnew2,nnew3,nnew4,array1,array2) +!bs makes the transformation for the ich-th index +!coeffs : (nolds(ith),nnew(ith)) modified contraction coefficients +!idim1 : first dimension +!idim2 : second dimension +!ich : index to be changed +!nolds1,nolds2,nolds3,nolds4 : old dimensions +!nnew1,nnew2,nnew3,nnew4 : new dimensions +!array1 : array of size (nolds1,nolds2,nolds3,nolds4) +!array2 : array of size (nnew1,nnew2,nnew3,nnew4) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: idim1, idim2, ich, nolds1, nolds2, nolds3, nolds4, nnew1, nnew2, nnew3, nnew4 +real(kind=wp), intent(in) :: coeffs(idim1,idim2), array1(nolds1,nolds2,nolds3,nolds4) +real(kind=wp), intent(out) :: array2(nnew1,nnew2,nnew3,nnew4) +integer(kind=iwp) :: ind1, ind2, ind3, ind4, ind5 + +!write(u6,*) 'begin trans ',ich +!write(u6,'(8I5)') nolds1,nolds2,nolds3,nolds4,nnew1,nnew2,nnew3,nnew4 +array2(:,:,:,:) = Zero +if (ich == 1) then + do ind4=1,nnew4 + do ind3=1,nnew3 + do ind2=1,nnew2 + do ind5=1,nnew1 + do ind1=1,nolds1 + array2(ind5,ind2,ind3,ind4) = array2(ind5,ind2,ind3,ind4)+coeffs(ind1,ind5)*array1(ind1,ind2,ind3,ind4) + end do + end do + end do + end do + end do +else if (ich == 2) then + !write(6,*) 'transform second index ' + do ind4=1,nnew4 + do ind3=1,nnew3 + do ind5=1,nnew2 + do ind2=1,nolds2 + array2(:,ind5,ind3,ind4) = array2(:,ind5,ind3,ind4)+coeffs(ind2,ind5)*array1(1:nnew1,ind2,ind3,ind4) + end do + end do + end do + end do + !write(u6,*) 'end to transform second index ' +else if (ich == 3) then + do ind4=1,nnew4 + do ind5=1,nnew3 + do ind3=1,nolds3 + array2(:,:,ind5,ind4) = array2(:,:,ind5,ind4)+coeffs(ind3,ind5)*array1(1:nnew1,1:nnew2,ind3,ind4) + end do + end do + end do +else if (ich == 4) then + do ind5=1,nnew4 + do ind4=1,nolds4 + array2(:,:,:,ind5) = array2(:,:,:,ind5)+coeffs(ind4,ind5)*array1(1:nnew1,1:nnew2,1:nnew3,ind4) + end do + end do +end if +!write(u6,*) 'end trans ' + +return + +end subroutine trans_amfi diff -Nru openmolcas-22.02/src/amfi_util/transcon.f openmolcas-22.10/src/amfi_util/transcon.f --- openmolcas-22.02/src/amfi_util/transcon.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/transcon.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine transcon(contold,idim1,idim2,ovlp,contnew,nprim,ncont) - implicit real*8 (a-h,o-z) - dimension contold(idim1,idim2),contnew(nprim,ncont), - *ovlp(idim1,idim1) -c write(6,*) 'begin transcon nprim,ncont ',nprim,ncont -cbs copy old contraction coefficients in dense form to common block - do Jrun=1,ncont - do Irun=1,nprim - contnew(Irun,Jrun)=contold(Irun,Jrun) - enddo - enddo -cbs ensure normalization - do ICONT=1,ncont - xnorm=0d0 - do Jrun=1,nprim - do Irun=1,nprim - xnorm=xnorm+contnew(Irun,ICONT)*contnew(Jrun,ICONT) - * *ovlp(Irun,Jrun) -c write(6,*) 'Icont,jrun,irun,xnorm ', -c * icont,jrun,irun,xnorm - enddo - enddo -c write(6,*) 'ICONT ',ICONT,xnorm - xnorm=1d0/sqrt(xnorm) -cbs scale with normalization factor - do Irun=1,nprim - contnew(Irun,ICONT)=xnorm*contnew(Irun,ICONT) - enddo - enddo -c write(6,*) 'end transcon nprim,ncont ',nprim,ncont - return - end diff -Nru openmolcas-22.02/src/amfi_util/transcon.F90 openmolcas-22.10/src/amfi_util/transcon.F90 --- openmolcas-22.02/src/amfi_util/transcon.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/transcon.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,45 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine transcon(contold,idim1,idim2,ovlp,contnew,nprim,ncont) + +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: idim1, idim2, nprim, ncont +real(kind=wp), intent(in) :: contold(idim1,idim2), ovlp(idim1,idim1) +real(kind=wp), intent(out) :: contnew(nprim,ncont) +integer(kind=iwp) :: ICONT, Irun, Jrun +real(kind=wp) :: xnorm + +!write(u6,*) 'begin transcon nprim,ncont ',nprim,ncont +!bs copy old contraction coefficients in dense form +contnew(:,:) = contold(1:nprim,1:ncont) +!bs ensure normalization +do ICONT=1,ncont + xnorm = Zero + do Jrun=1,nprim + do Irun=1,nprim + xnorm = xnorm+contnew(Irun,ICONT)*contnew(Jrun,ICONT)*ovlp(Irun,Jrun) + !write(u6,*) 'Icont,jrun,irun,xnorm ',icont,jrun,irun,xnorm + end do + end do + !write(u6,*) 'ICONT ',ICONT,xnorm + xnorm = One/sqrt(xnorm) + !bs scale with normalization factor + contnew(:,ICONT) = xnorm*contnew(:,ICONT) +end do +!write(u6,*) 'end transcon nprim,ncont ',nprim,ncont + +return + +end subroutine transcon diff -Nru openmolcas-22.02/src/amfi_util/two2mean12a.f openmolcas-22.10/src/amfi_util/two2mean12a.f --- openmolcas-22.02/src/amfi_util/two2mean12a.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/two2mean12a.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine two2mean12a(carteSO,carteOO,occup,AOcoeffs,onecart, - *ncontmf,norbsum,noccorb,sameorb) - implicit real*8 (a-h,o-z) -#include "para.fh" - logical sameorb - dimension - *carteSO(ncontmf,norbsum,ncontmf,norbsum), - *carteOO(ncontmf,norbsum,ncontmf,norbsum), - *occup(*),AOcoeffs(MxcontL,*),onecart(MxcontL,MxcontL) - if (sameorb) THEN - do icartleft=1,norbsum - do icartright=1,norbsum - coeff=0d0 - do Mrun=1,noccorb - coeff=coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)* - * AOcoeffs(icartright,Mrun) - enddo - coeff=0.5d0*coeff - do irun=1,ncontmf - do jrun=1,ncontmf - onecart(irun,jrun)=onecart(irun,jrun)-coeff* - *carteSO(irun,icartleft,jrun,icartright) - enddo - enddo - enddo - enddo - else - do icartleft=1,norbsum - do icartright=1,norbsum - coeff=0d0 - do Mrun=1,noccorb - coeff=coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)* - * AOcoeffs(icartright,Mrun) - enddo - coeff=0.5d0*coeff - do irun=1,ncontmf - do jrun=1,ncontmf - onecart(irun,jrun)=onecart(irun,jrun)-coeff* - *(carteSO(irun,icartleft,jrun,icartright)+ - *2d0*carteOO(irun,icartleft,jrun,icartright)) - enddo - enddo - enddo - enddo - endif - return - end diff -Nru openmolcas-22.02/src/amfi_util/two2mean12a.F90 openmolcas-22.10/src/amfi_util/two2mean12a.F90 --- openmolcas-22.02/src/amfi_util/two2mean12a.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/two2mean12a.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,55 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine two2mean12a(carteSO,carteOO,occup,AOcoeffs,onecart,ncontmf,norbsum,noccorb,sameorb) + +use AMFI_global, only: MxcontL +use Constants, only: Zero, Two, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: ncontmf, norbsum, noccorb +real(kind=wp), intent(in) :: carteSO(ncontmf,norbsum,ncontmf,norbsum), carteOO(ncontmf,norbsum,ncontmf,norbsum), occup(*), & + AOcoeffs(MxcontL,*) +real(kind=wp), intent(inout) :: onecart(MxcontL,MxcontL) +logical(kind=iwp), intent(in) :: sameorb +integer(kind=iwp) :: icartleft, icartright, Mrun +real(kind=wp) :: coeff + +if (sameorb) then + do icartleft=1,norbsum + do icartright=1,norbsum + coeff = Zero + do Mrun=1,noccorb + coeff = coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)*AOcoeffs(icartright,Mrun) + end do + coeff = Half*coeff + onecart(1:ncontmf,1:ncontmf) = onecart(1:ncontmf,1:ncontmf)-coeff*carteSO(1:ncontmf,icartleft,1:ncontmf,icartright) + end do + end do +else + do icartleft=1,norbsum + do icartright=1,norbsum + coeff = Zero + do Mrun=1,noccorb + coeff = coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)*AOcoeffs(icartright,Mrun) + end do + coeff = Half*coeff + onecart(1:ncontmf,1:ncontmf) = onecart(1:ncontmf,1:ncontmf)- & + coeff*(carteSO(1:ncontmf,icartleft,1:ncontmf,icartright)+ & + Two*carteOO(1:ncontmf,icartleft,1:ncontmf,icartright)) + end do + end do +end if + +return + +end subroutine two2mean12a diff -Nru openmolcas-22.02/src/amfi_util/two2mean12b.f openmolcas-22.10/src/amfi_util/two2mean12b.f --- openmolcas-22.02/src/amfi_util/two2mean12b.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/two2mean12b.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine two2mean12b(carteSO,carteOO,occup,AOcoeffs,onecart, - *ncontmf,norbsum,noccorb,sameorb) - implicit real*8 (a-h,o-z) -#include "para.fh" - logical sameorb - dimension - *carteSO(ncontmf,norbsum,ncontmf,norbsum), - *carteOO(ncontmf,norbsum,ncontmf,norbsum), - *occup(*),AOcoeffs(MxcontL,*),onecart(MxcontL,MxcontL) - if (sameorb) then - do icartleft=1,norbsum - do icartright=1,norbsum - coeff=0d0 - do Mrun=1,noccorb - coeff=coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)* - * AOcoeffs(icartright,Mrun) - enddo - coeff=0.5d0*coeff - do irun=1,ncontmf - do jrun=1,ncontmf - onecart(irun,jrun)=onecart(irun,jrun)+coeff* - *carteSO(jrun,icartleft,irun,icartright) - enddo - enddo - enddo - enddo - else - do icartleft=1,norbsum - do icartright=1,norbsum - coeff=0d0 - do Mrun=1,noccorb - coeff=coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)* - * AOcoeffs(icartright,Mrun) - enddo - coeff=0.5d0*coeff - do irun=1,ncontmf - do jrun=1,ncontmf - onecart(irun,jrun)=onecart(irun,jrun)+coeff* - *(carteSO(jrun,icartleft,irun,icartright)+ - *2d0*carteOO(jrun,icartleft,irun,icartright)) - enddo - enddo - enddo - enddo - endif - return - end diff -Nru openmolcas-22.02/src/amfi_util/two2mean12b.F90 openmolcas-22.10/src/amfi_util/two2mean12b.F90 --- openmolcas-22.02/src/amfi_util/two2mean12b.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/two2mean12b.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,59 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine two2mean12b(carteSO,carteOO,occup,AOcoeffs,onecart,ncontmf,norbsum,noccorb,sameorb) + +use AMFI_global, only: MxcontL +use Constants, only: Zero, Two, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: ncontmf, norbsum, noccorb +real(kind=wp), intent(in) :: carteSO(ncontmf,norbsum,ncontmf,norbsum), carteOO(ncontmf,norbsum,ncontmf,norbsum), occup(*), & + AOcoeffs(MxcontL,*) +real(kind=wp), intent(inout) :: onecart(MxcontL,MxcontL) +logical(kind=iwp), intent(in) :: sameorb +integer(kind=iwp) :: icartleft, icartright, jrun, Mrun +real(kind=wp) :: coeff + +if (sameorb) then + do icartleft=1,norbsum + do icartright=1,norbsum + coeff = Zero + do Mrun=1,noccorb + coeff = coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)*AOcoeffs(icartright,Mrun) + end do + coeff = Half*coeff + do jrun=1,ncontmf + onecart(1:ncontmf,jrun) = onecart(1:ncontmf,jrun)+coeff*carteSO(jrun,icartleft,1:ncontmf,icartright) + end do + end do + end do +else + do icartleft=1,norbsum + do icartright=1,norbsum + coeff = Zero + do Mrun=1,noccorb + coeff = coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)*AOcoeffs(icartright,Mrun) + end do + coeff = Half*coeff + do jrun=1,ncontmf + onecart(1:ncontmf,jrun) = onecart(1:ncontmf,jrun)+ & + coeff*(carteSO(jrun,icartleft,1:ncontmf,icartright)+ & + Two*carteOO(jrun,icartleft,1:ncontmf,icartright)) + end do + end do + end do +end if + +return + +end subroutine two2mean12b diff -Nru openmolcas-22.02/src/amfi_util/two2mean13.f openmolcas-22.10/src/amfi_util/two2mean13.f --- openmolcas-22.02/src/amfi_util/two2mean13.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/two2mean13.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine two2mean13(carteSO,occup,AOcoeffs,onecart, - *ncontmf,norbsum,noccorb) -cbs gives the two first contributions -cbs < i M | j M > with Malpha and Mbeta -cbs the other orbit parts cancel - implicit real*8 (a-h,o-z) -#include "para.fh" - dimension carteSO(ncontmf,ncontmf,norbsum,norbsum), - *occup(*),AOcoeffs(MxcontL,*),onecart(MxcontL,MxcontL) - do icartleft=1,norbsum - do icartright=1,norbsum - coeff=0d0 - do Mrun=1,noccorb - coeff=coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)* - * AOcoeffs(icartright,Mrun) - enddo - do irun=1,ncontmf - do jrun=1,ncontmf - onecart(irun,jrun)=onecart(irun,jrun)+coeff* - *carteSO(irun,jrun,icartleft,icartright) - enddo - enddo - enddo - enddo -c write(6,*) 'effective integrals' -c do jrun=1,ncontmf -c write(6,'(4E20.14)') (onecart(irun,jrun),irun=1,ncontmf) -c enddo - return - end diff -Nru openmolcas-22.02/src/amfi_util/two2mean13.F90 openmolcas-22.10/src/amfi_util/two2mean13.F90 --- openmolcas-22.02/src/amfi_util/two2mean13.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/two2mean13.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,44 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine two2mean13(carteSO,occup,AOcoeffs,onecart,ncontmf,norbsum,noccorb) +!bs gives the two first contributions +!bs < i M | j M > with Malpha and Mbeta +!bs the other orbit parts cancel + +use AMFI_global, only: MxcontL +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: ncontmf, norbsum, noccorb +real(kind=wp), intent(in) :: carteSO(ncontmf,ncontmf,norbsum,norbsum), occup(*), AOcoeffs(MxcontL,*) +real(kind=wp), intent(inout) :: onecart(MxcontL,MxcontL) +integer(kind=iwp) :: icartleft, icartright, Mrun +real(kind=wp) :: coeff + +do icartleft=1,norbsum + do icartright=1,norbsum + coeff = Zero + do Mrun=1,noccorb + coeff = coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)*AOcoeffs(icartright,Mrun) + end do + onecart(1:ncontmf,1:ncontmf) = onecart(1:ncontmf,1:ncontmf)+coeff*carteSO(1:ncontmf,1:ncontmf,icartleft,icartright) + end do +end do +!write(u6,*) 'effective integrals' +!do jrun=1,ncontmf +! write(u6,'(4E20.14)') (onecart(irun,jrun),irun=1,ncontmf) +!end do + +return + +end subroutine two2mean13 diff -Nru openmolcas-22.02/src/amfi_util/two2mean34a.f openmolcas-22.10/src/amfi_util/two2mean34a.f --- openmolcas-22.02/src/amfi_util/two2mean34a.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/two2mean34a.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine two2mean34a(carteSO,carteOO,occup,AOcoeffs,onecart, - *ncontmf,norbsum,noccorb,sameorb) - implicit real*8 (a-h,o-z) -#include "para.fh" - logical sameorb - dimension - *carteSO(norbsum,ncontmf,norbsum,ncontmf), - *carteOO(norbsum,ncontmf,norbsum,ncontmf), - *occup(*),AOcoeffs(MxcontL,*),onecart(MxcontL,MxcontL) - if (sameorb) then - do icartleft=1,norbsum - do icartright=1,norbsum - coeff=0d0 - do Mrun=1,noccorb - coeff=coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)* - * AOcoeffs(icartright,Mrun) - enddo - coeff=0.5d0*coeff - do irun=1,ncontmf - do jrun=1,ncontmf - onecart(irun,jrun)=onecart(irun,jrun)+coeff* - *carteSO(icartleft,irun,icartright,jrun) - enddo - enddo - enddo - enddo - else - do icartleft=1,norbsum - do icartright=1,norbsum - coeff=0d0 - do Mrun=1,noccorb - coeff=coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)* - * AOcoeffs(icartright,Mrun) - enddo - coeff=0.5d0*coeff - do irun=1,ncontmf - do jrun=1,ncontmf - onecart(irun,jrun)=onecart(irun,jrun)+coeff* - *(carteSO(icartleft,irun,icartright,jrun)+ - *2d0*carteOO(icartleft,irun,icartright,jrun)) - enddo - enddo - enddo - enddo - endif - return - end diff -Nru openmolcas-22.02/src/amfi_util/two2mean34a.F90 openmolcas-22.10/src/amfi_util/two2mean34a.F90 --- openmolcas-22.02/src/amfi_util/two2mean34a.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/two2mean34a.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,55 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine two2mean34a(carteSO,carteOO,occup,AOcoeffs,onecart,ncontmf,norbsum,noccorb,sameorb) + +use AMFI_global, only: MxcontL +use Constants, only: Zero, Two, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: ncontmf, norbsum, noccorb +real(kind=wp), intent(in) :: carteSO(norbsum,ncontmf,norbsum,ncontmf), carteOO(norbsum,ncontmf,norbsum,ncontmf), occup(*), & + AOcoeffs(MxcontL,*) +real(kind=wp), intent(inout) :: onecart(MxcontL,MxcontL) +logical(kind=iwp), intent(in) :: sameorb +integer(kind=iwp) :: icartleft, icartright, Mrun +real(kind=wp) :: coeff + +if (sameorb) then + do icartleft=1,norbsum + do icartright=1,norbsum + coeff = Zero + do Mrun=1,noccorb + coeff = coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)*AOcoeffs(icartright,Mrun) + end do + coeff = Half*coeff + onecart(1:ncontmf,1:ncontmf) = onecart(1:ncontmf,1:ncontmf)+coeff*carteSO(icartleft,1:ncontmf,icartright,1:ncontmf) + end do + end do +else + do icartleft=1,norbsum + do icartright=1,norbsum + coeff = Zero + do Mrun=1,noccorb + coeff = coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)*AOcoeffs(icartright,Mrun) + end do + coeff = Half*coeff + onecart(1:ncontmf,1:ncontmf) = onecart(1:ncontmf,1:ncontmf)+ & + coeff*(carteSO(icartleft,1:ncontmf,icartright,1:ncontmf)+ & + Two*carteOO(icartleft,1:ncontmf,icartright,1:ncontmf)) + end do + end do +end if + +return + +end subroutine two2mean34a diff -Nru openmolcas-22.02/src/amfi_util/two2mean34b.f openmolcas-22.10/src/amfi_util/two2mean34b.f --- openmolcas-22.02/src/amfi_util/two2mean34b.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/two2mean34b.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine two2mean34b(carteSO,carteOO,occup,AOcoeffs,onecart, - *ncontmf,norbsum,noccorb,sameorb) - implicit real*8 (a-h,o-z) -#include "para.fh" - logical sameorb - dimension - *carteSO(norbsum,ncontmf,norbsum,ncontmf), - *carteOO(norbsum,ncontmf,norbsum,ncontmf), - *occup(*),AOcoeffs(MxcontL,*),onecart(MxcontL,MxcontL) - if (sameorb) then - do icartleft=1,norbsum - do icartright=1,norbsum - coeff=0d0 - do Mrun=1,noccorb - coeff=coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)* - * AOcoeffs(icartright,Mrun) - enddo - coeff=0.5D0*coeff - do irun=1,ncontmf - do jrun=1,ncontmf - onecart(irun,jrun)=onecart(irun,jrun)-coeff* - *carteSO(icartleft,jrun,icartright,irun) - enddo - enddo - enddo - enddo - else - do icartleft=1,norbsum - do icartright=1,norbsum - coeff=0d0 - do Mrun=1,noccorb - coeff=coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)* - * AOcoeffs(icartright,Mrun) - enddo - coeff=0.5D0*coeff - do irun=1,ncontmf - do jrun=1,ncontmf - onecart(irun,jrun)=onecart(irun,jrun)-coeff* - *(carteSO(icartleft,jrun,icartright,irun)+ - *2d0*carteOO(icartleft,jrun,icartright,irun)) - enddo - enddo - enddo - enddo - endif - return - end diff -Nru openmolcas-22.02/src/amfi_util/two2mean34b.F90 openmolcas-22.10/src/amfi_util/two2mean34b.F90 --- openmolcas-22.02/src/amfi_util/two2mean34b.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/amfi_util/two2mean34b.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,59 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine two2mean34b(carteSO,carteOO,occup,AOcoeffs,onecart,ncontmf,norbsum,noccorb,sameorb) + +use AMFI_global, only: MxcontL +use Constants, only: Zero, Two, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: ncontmf, norbsum, noccorb +real(kind=wp), intent(in) :: carteSO(norbsum,ncontmf,norbsum,ncontmf), carteOO(norbsum,ncontmf,norbsum,ncontmf), occup(*), & + AOcoeffs(MxcontL,*) +real(kind=wp), intent(inout) :: onecart(MxcontL,MxcontL) +logical(kind=iwp), intent(in) :: sameorb +integer(kind=iwp) :: icartleft, icartright, jrun, Mrun +real(kind=wp) :: coeff + +if (sameorb) then + do icartleft=1,norbsum + do icartright=1,norbsum + coeff = Zero + do Mrun=1,noccorb + coeff = coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)*AOcoeffs(icartright,Mrun) + end do + coeff = Half*coeff + do jrun=1,ncontmf + onecart(1:ncontmf,jrun) = onecart(1:ncontmf,jrun)-coeff*carteSO(icartleft,jrun,icartright,1:ncontmf) + end do + end do + end do +else + do icartleft=1,norbsum + do icartright=1,norbsum + coeff = Zero + do Mrun=1,noccorb + coeff = coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)*AOcoeffs(icartright,Mrun) + end do + coeff = Half*coeff + do jrun=1,ncontmf + onecart(1:ncontmf,jrun) = onecart(1:ncontmf,jrun)- & + coeff*(carteSO(icartleft,jrun,icartright,1:ncontmf)+ & + Two*carteOO(icartleft,jrun,icartright,1:ncontmf)) + end do + end do + end do +end if + +return + +end subroutine two2mean34b diff -Nru openmolcas-22.02/src/aniso_util/dmatrix.f openmolcas-22.10/src/aniso_util/dmatrix.f --- openmolcas-22.02/src/aniso_util/dmatrix.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/aniso_util/dmatrix.f 2022-10-10 14:22:40.000000000 +0000 @@ -10,8 +10,8 @@ ************************************************************************ Subroutine DMATRIX(E,F,Z,IPRINT) -C THIS ROUTINE COMPUTES THE USUAL D-TENSOR ON THA BASIS OF COEFFICINETS -C OF THE STEWENS OPERATORS OF ORDER 2 (ES AND FS) AND DIAGONALIZE IT +C THIS ROUTINE COMPUTES THE USUAL D-TENSOR ON THE BASIS OF COEFFICIENTS +C OF THE STEVENS OPERATORS OF ORDER 2 (ES AND FS) AND DIAGONALIZE IT C TO OBTAIN THE MAIN ANISOTROPY AXES C diff -Nru openmolcas-22.02/src/aniso_util/plot_MH.f90 openmolcas-22.10/src/aniso_util/plot_MH.f90 --- openmolcas-22.02/src/aniso_util/plot_MH.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/aniso_util/plot_MH.f90 2022-10-10 14:22:40.000000000 +0000 @@ -390,8 +390,9 @@ INTEGER, EXTERNAL :: AixRm INTEGER :: Length CHARACTER(LEN=1023) :: realname_plt, realname_dat, realname_png, realname_eps, gnuplot_CMD - INTEGER :: iErr + INTEGER :: iErr, iSeed = 0 INTEGER, EXTERNAL :: IsFreeUnit + REAL*8, EXTERNAL :: Random_Molcas color( 1)="#ffffff"; color( 2)="#000000"; color( 3)="#a0a0a0"; color( 4)="#ff0000"; color( 5)="#00c000" color( 6)="#0080ff"; color( 7)="#c000ff"; color( 8)="#00eeee"; color( 9)="#c04000"; color( 10)="#c8c800" @@ -417,6 +418,8 @@ color(106)="#7f7f7f"; color(107)="#999999"; color(108)="#b3b3b3"; color(109)="#cccccc"; color(110)="#e5e5e5" color(111)="#ffffff" + IF (iSeed == 0) CALL GetSeed(iSeed) + dbg=.false. iErr=0 StdOut=6 @@ -635,8 +638,8 @@ WRITE (LuPlt,'(A)') '# actual plotting' DO iTempMagn=1,nTempMagn ik=iTempMagn+1 - Call RANDOM_NUMBER(r) - ic=INT(111.0_wp*r) + r=Random_Molcas(iSeed) + ic=FLOOR(SIZE(color)*r)+LBOUND(color,1) IF((iTempMagn.eq.1).AND.(nTempMagn.gt.1)) THEN WRITE (LuPlt,'(A,i0,A,F7.3,A)') 'plot "'//trim(realname_dat)//'" using 1:',ik,& ' with lines lt 1 lw 8 lc rgb "'//color(ic)//'" title "Calc. M at T=',TempMagn(iTempMagn),'K.", \' @@ -684,8 +687,8 @@ WRITE (LuPlt,'(A)') '# actual plotting' DO iTempMagn=1,nTempMagn ik=iTempMagn+1 - Call RANDOM_NUMBER(r) - ic=INT(110.0_wp*r) + r=Random_Molcas(iSeed) + ic=FLOOR(SIZE(color)*r)+LBOUND(color,1) IF((iTempMagn.eq.1).AND.(nTempMagn.gt.1)) THEN WRITE (LuPlt,'(A,i0,A,F7.3,A)') 'plot "'//trim(realname_dat)//'" using 1:',ik,& ' with lines lt 1 lw 8 lc rgb "'//color(ic)//'" title "Calc. M at T=',TempMagn(iTempMagn),'K.", \' diff -Nru openmolcas-22.02/src/caspt2/caspt2.f openmolcas-22.10/src/caspt2/caspt2.f --- openmolcas-22.02/src/caspt2/caspt2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/caspt2/caspt2.f 2022-10-10 14:22:40.000000000 +0000 @@ -125,28 +125,31 @@ call dcopy_(Nstate,[1.0d0],0,U0,Nstate+1) * *======================================================================* -* If the EFFE keyword has been used, we already have the multi state -* coupling Hamiltonian effective matrix, just copy the energies and -* proceed to the MS coupling section. -* Otherwise, put the CASSCF energies on the diagonal, i.e. form the +* Put the CASSCF energies on the diagonal of Heff, i.e. form the * first-order corrected effective Hamiltonian: * Heff[1] = PHP * and later on we will add the second-order correction * Heff(2) = PH \Omega_1 P to Heff[1] + DO I=1,NSTATE + HEFF(I,I) = REFENE(I) + END DO + IF (IPRGLB.GE.VERBOSE) THEN + write(6,*)' Heff[1] in the original model space basis:' + call prettyprint(Heff,Nstate,Nstate) + END IF +* If the EFFE keyword has been used, we already have the multi state +* coupling Hamiltonian effective matrix, just copy the energies and +* proceed to the MS coupling section. IF (INPUT%JMS) THEN + ! in case of XMS, XDW, RMS, we need to rotate the states + if (IFXMS .or. IFRMS) then + call xdwinit(Heff,H0,U0) + end if DO I=1,NSTATE ENERGY(I)=INPUT%HEFF(I,I) END DO HEFF(:,:)=INPUT%HEFF(:,:) GOTO 1000 - ELSE - DO I=1,NSTATE - HEFF(I,I) = REFENE(I) - END DO - IF (IPRGLB.GE.VERBOSE) THEN - write(6,*)' Heff[1] in the original model space basis:' - call prettyprint(Heff,Nstate,Nstate) - END IF END IF * In case of a XDW-CASPT2 calculation we first rotate the CASSCF diff -Nru openmolcas-22.02/src/caspt2/prwf_cp2.f openmolcas-22.10/src/caspt2/prwf_cp2.f --- openmolcas-22.02/src/caspt2/prwf_cp2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/caspt2/prwf_cp2.f 2022-10-10 14:22:40.000000000 +0000 @@ -9,7 +9,7 @@ * LICENSE or in . * * * * Copyright (C) 1994, Per Ake Malmqvist * -********************************************************************** +************************************************************************ *--------------------------------------------* * 1994 PER-AAKE MALMQUIST * * DEPARTMENT OF THEORETICAL CHEMISTRY * diff -Nru openmolcas-22.02/src/caspt2/readin_caspt2.F90 openmolcas-22.10/src/caspt2/readin_caspt2.F90 --- openmolcas-22.02/src/caspt2/readin_caspt2.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/caspt2/readin_caspt2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -186,17 +186,16 @@ ! the proc_inp call (processing of input). The only variable needed here ! is nSym, as some input lines assume knowledge of the number of irreps. + Use text_file, Only: extend_line, next_non_comment + Integer(kind=iwp),intent(in) :: LuIn,nSym - Character(len=128) :: Line - Character(len=:),allocatable :: dLine + Character(len=:),allocatable :: dLine, Line Character(len=4) :: Command,Word Integer(kind=iwp) :: i,j,iSym,nStates Integer(kind=iwp) :: iSplit,iError - Logical(kind=iwp),external :: next_non_comment - #ifdef _ENABLE_CHEMPS2_DMRG_ Logical(kind=iwp) :: dochemps2 = .false. #endif @@ -208,10 +207,10 @@ do if (.not. next_non_comment(LuIn,Line)) call EOFError(Line) - Command = Line(1:4) + Command = Line(1:min(4,len(Line))) call Upcase(Command) - !IFG Note that when multiple values are required, ExtendLine may + !IFG Note that when multiple values are required, extend_line may ! be called (0 or more times) until the READ statement gives no error ! this allows the input to be split in lines more or less arbitrarily, ! as if the values were read directly from the file. @@ -253,7 +252,7 @@ if (iError > 0) call IOError(Line) if (iError < 0) then if (.not. next_non_comment(LuIn,Line)) call EOFError(Line) - call ExtendLine(dLine,Line) + call extend_line(dLine,Line) end if end do call mma_deallocate (dLine) @@ -282,7 +281,7 @@ if (iError > 0) call IOError(Line) if (iError < 0) then if (.not. next_non_comment(LuIn,Line)) call EOFError(Line) - call ExtendLine(dLine,Line) + call extend_line(dLine,Line) end if end do call mma_deallocate (dLine) @@ -311,7 +310,7 @@ if (iError > 0) call IOError(Line) if (iError < 0) then if (.not. next_non_comment(LuIn,Line)) call EOFError(Line) - call ExtendLine(dLine,Line) + call extend_line(dLine,Line) end if end do call mma_deallocate (dLine) @@ -355,7 +354,7 @@ if (iError > 0) call IOError(Line) if (iError < 0) then if (.not. next_non_comment(LuIn,Line)) call EOFError(Line) - call ExtendLine(dLine,Line) + call extend_line(dLine,Line) end if end do call mma_deallocate (dLine) @@ -372,7 +371,7 @@ if (iError > 0) call IOError(Line) if (iError < 0) then if (.not. next_non_comment(LuIn,Line)) call EOFError(Line) - call ExtendLine(dLine,Line) + call extend_line(dLine,Line) end if end do call mma_deallocate (dLine) @@ -400,7 +399,7 @@ if (iError > 0) call IOError(Line) if (iError < 0) then if (.not. next_non_comment(LuIn,Line)) call EOFError(Line) - call ExtendLine(dLine,Line) + call extend_line(dLine,Line) end if end do call mma_deallocate (dLine) @@ -450,7 +449,7 @@ if (iError > 0) call IOError(Line) if (iError < 0) then if (.not. next_non_comment(LuIn,Line)) call EOFError(Line) - call ExtendLine(dLine,Line) + call extend_line(dLine,Line) end if end do call mma_deallocate (dLine) @@ -512,7 +511,7 @@ if (iError > 0) call IOError(Line) if (iError < 0) then if (.not. next_non_comment(LuIn,Line)) call EOFError(Line) - call ExtendLine(dLine,Line) + call extend_line(dLine,Line) end if end do call mma_deallocate (dLine) @@ -528,7 +527,7 @@ if (iError < 0) then if (.not. next_non_comment(LuIn,Line)) call EOFError(Line) call Upcase(Line) - call ExtendLine(dLine,Line) + call extend_line(dLine,Line) end if end do call mma_deallocate (dLine) @@ -604,7 +603,7 @@ if (iError > 0) call IOError(Line) if (iError < 0) then if (.not. next_non_comment(LuIn,Line)) call EOFError(Line) - call ExtendLine(dLine,Line) + call extend_line(dLine,Line) end if end do call mma_deallocate (dLine) @@ -663,6 +662,8 @@ endif #endif + call mma_deallocate(Line) + ! Normal exit return @@ -682,20 +683,6 @@ end if end subroutine CleanUp_Input - subroutine ExtendLine(DynLine,Line) - Character(len=:),allocatable,intent(InOut) :: DynLine - Character(len=*),intent(In) :: Line - Character(len=:),allocatable :: Aux - call mma_allocate(Aux,len_trim(DynLine)+len_trim(Line)+1,label='AuxLine') - Aux(:) = trim(DynLine)//' '//trim(Line) - call mma_deallocate(DynLine) - ! move_alloc does not work properly in all compilers - !call move_alloc(Aux,DynLine) - call mma_allocate(DynLine,len(Aux)) - DynLine(:) = Aux - call mma_deallocate(Aux) - end subroutine ExtendLine - subroutine IOError(line) Character(len=*),intent(in) :: line diff -Nru openmolcas-22.02/src/caspt2/tracho2.f openmolcas-22.10/src/caspt2/tracho2.f --- openmolcas-22.02/src/caspt2/tracho2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/caspt2/tracho2.f 2022-10-10 14:22:40.000000000 +0000 @@ -23,9 +23,9 @@ #include "chocaspt2.fh" #include "choglob.fh" #include "WrkSpc.fh" -********************************************************************** +************************************************************************ * Author : P. A. Malmqvist -********************************************************************** +************************************************************************ REAL*8 CMO(NBSQT),DREF(NDREF), & FFAO(NBTRI),FIAO(NBTRI),FAAO(NBTRI) LOGICAL IF_TRNSF @@ -58,7 +58,7 @@ REAL*8, EXTERNAL :: DDOT_ -********************************************************************** +************************************************************************ * ====================================================================== * This section deals with density matrices and CMO''s * Offsets into CMO arrays: diff -Nru openmolcas-22.02/src/caspt2/tracho3.f openmolcas-22.10/src/caspt2/tracho3.f --- openmolcas-22.02/src/caspt2/tracho3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/caspt2/tracho3.f 2022-10-10 14:22:40.000000000 +0000 @@ -22,9 +22,9 @@ #include "chocaspt2.fh" #include "choglob.fh" #include "WrkSpc.fh" -********************************************************************** +************************************************************************ * Author : P. A. Malmqvist -********************************************************************** +************************************************************************ REAL*8 CMO(NBSQT) INTEGER NCES(8),ip_HTVec(8) @@ -41,7 +41,7 @@ INTEGER ip_buffy,ip_chspc,ip_ftspc,ip_htspc INTEGER NUMV,NVECS_RED,NHTOFF,MUSED -********************************************************************** +************************************************************************ * ====================================================================== * This section deals with density matrices and CMO''s * Offsets into CMO arrays: diff -Nru openmolcas-22.02/src/caspt2/trachosz.f openmolcas-22.10/src/caspt2/trachosz.f --- openmolcas-22.02/src/caspt2/trachosz.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/caspt2/trachosz.f 2022-10-10 14:22:40.000000000 +0000 @@ -34,9 +34,9 @@ INTEGER MXFTARR,MXHTARR INTEGER MXSPC INTEGER NVACT,NVACC,NVECS_RED -********************************************************************** +************************************************************************ * Author : P. A. Malmqvist -********************************************************************** +************************************************************************ * ====================================================================== * Determine sectioning size to use for the full-transformed MO vectors diff -Nru openmolcas-22.02/src/casvb_util/axexb_cvb.f openmolcas-22.10/src/casvb_util/axexb_cvb.f --- openmolcas-22.02/src/casvb_util/axexb_cvb.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/casvb_util/axexb_cvb.f 2022-10-10 14:22:40.000000000 +0000 @@ -1,4 +1,4 @@ -*********************************************************************** +************************************************************************ * This file is part of OpenMolcas. * * * * OpenMolcas is free software; you can redistribute it and/or modify * diff -Nru openmolcas-22.02/src/casvb_util/csf2det_cvb.f openmolcas-22.10/src/casvb_util/csf2det_cvb.f --- openmolcas-22.02/src/casvb_util/csf2det_cvb.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/casvb_util/csf2det_cvb.f 2022-10-10 14:22:40.000000000 +0000 @@ -12,8 +12,8 @@ * 1996-2006, David L. Cooper * ************************************************************************ subroutine csf2det_cvb(vec,detvec,isym_loc,iWay) + use csfbas, only: cts, kdtoc implicit real*8 (a-h,o-z) -#include "csfbas.fh" #include "ciinfo.fh" #include "rasdim.fh" #include "rasscf.fh" @@ -28,7 +28,7 @@ jCopy = 0 call csdtvc(vec,detvec,iway,work(kdtoc), - > iwork(kicts(1)),isym_loc,jcopy) + > cts,isym_loc,jcopy) elseif(iWay.eq.2)then if ( nac.eq.0 ) then vec(1)=detvec(1) @@ -37,7 +37,7 @@ jCopy = 0 call csdtvc(vec,detvec,iway,work(kdtoc), - > iwork(kicts(1)),isym_loc,jcopy) + > cts,isym_loc,jcopy) endif return end diff -Nru openmolcas-22.02/src/casvb_util/date2_cvb.f openmolcas-22.10/src/casvb_util/date2_cvb.f --- openmolcas-22.02/src/casvb_util/date2_cvb.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/casvb_util/date2_cvb.f 2022-10-10 14:22:40.000000000 +0000 @@ -14,12 +14,6 @@ subroutine date2_cvb(delcpu) implicit real*8(a-h,o-z) character*120 line - interface - subroutine datimx(TimeStamp) bind(C,name='datimx_') - use, intrinsic :: iso_c_binding, only: c_char - character(kind=c_char) :: TimeStamp(*) - end subroutine - end interface line=' ' call datimx(line) diff -Nru openmolcas-22.02/src/casvb_util/reord2_cvb.f openmolcas-22.10/src/casvb_util/reord2_cvb.f --- openmolcas-22.02/src/casvb_util/reord2_cvb.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/casvb_util/reord2_cvb.f 2022-10-10 14:22:40.000000000 +0000 @@ -12,6 +12,7 @@ * 1996-2006, David L. Cooper * ************************************************************************ subroutine reord2_cvb(cfrom,cto,imode) + use csfbas, only: conf, kcftp implicit real*8(a-h,o-z) c Front-end routine for molcas reord2, transforms c from SGA CSFs to split-graph-GUGA CSFs. @@ -20,17 +21,14 @@ #include "rasdim.fh" #include "rasscf.fh" #include "general.fh" -#include "csfbas.fh" c NAC rasscf.fh c NACTEL general.fh c STSYM general.fh c IPR rasscf.fh -c KICONF csfbas.fh -c KCFTP csfbas.fh call getmem('kcnf','allo','inte',ivkcnf,nactel) call reord2(nac,nactel,stsym,imode, - > iwork(kiconf(1)),iwork(kcftp), + > conf,iwork(kcftp), > cfrom,cto,iWork(ivkcnf)) call getmem('kcnf','free','inte',ivkcnf,nactel) return diff -Nru openmolcas-22.02/src/ccsort_util/abpack.f openmolcas-22.10/src/ccsort_util/abpack.f --- openmolcas-22.02/src/ccsort_util/abpack.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/abpack.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,80 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine abpack (wrk,wrksize, - & syma,symb,symp,symq,a,vint,ndimv1,ndimv2, - & ndimv3,abmap) -c -c this routine pack corresponding parts to ab direct acc. file -c from given integrals <_a,bb,p,q> readed in vint -c -c syma - irrep of first index (I) -c symb - irrep of 2.nd index (I) -c symp - irrep of p (I) -c symq - irrep of q (I) -c a- pivot virtual index (counted in nvb set) (I) -c vint - array of integrals <_a,bb,p,q> (I) -c ndimv1- 1.st dimension of vint - norb(symb) (I) -c ndimv2- 2.nd dimension of vint - norb(symp) (I) -c ndimv3- 3.rd dimension of vint - norb(symq) (I) -c abmap - map for storing of addresses in DA file TEMPDA1 (I) -c -#include "wrk.fh" -#include "ccsort.fh" -#include "reorg.fh" -c - integer syma,symb,symp,symq,a,ndimv1,ndimv2,ndimv3 - real*8 vint(1:ndimv1,1:ndimv2,1:ndimv3) - integer abmap(1:mbas,1:mbas,1:8) -c -c help variables -c - integer p,q,pq,irec0,length,b,bup,bvint -c -cT if there are no ab pair, or no integrals in _a_bpq block return -c - if (nvb(syma)*nvb(symb)*norb(symp)*norb(symq).eq.0) then - return - end if -c -c* def length of _a_b(p,q) block -c - length=norb(symp)*norb(symq) -c - if (syma.eq.symb) then - bup=a - else - bup=nvb(symb) - end if -c -c* cycle over b for given a -c - do 1000 b=1,bup - bvint=nob(symb)+b -c -c* map _a_b(pq) block into #v3 -c - pq=poss30-1 - do 100 q=1,norb(symq) - do 101 p=1,norb(symp) - pq=pq+1 - wrk(pq)=vint(bvint,p,q) - 101 continue - 100 continue -c -c* put this block to iappropriate possition in direct acces file -c - irec0=abmap(a,b,symp) - call dawrite (lunda1,irec0,wrk(poss30),length,recl) -c - 1000 continue -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/abpack.F90 openmolcas-22.10/src/ccsort_util/abpack.F90 --- openmolcas-22.02/src/ccsort_util/abpack.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/abpack.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,76 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine abpack(wrk,wrksize,syma,symb,symp,symq,a,vint,ndimv1,ndimv2,ndimv3,abmap) +! this routine packs corresponding parts to ab direct acc. file +! from given integrals <_a,bb,p,q> read in vint +! +! syma - irrep of first index (I) +! symb - irrep of 2nd index (I) +! symp - irrep of p (I) +! symq - irrep of q (I) +! a - pivot virtual index (counted in nvb set) (I) +! vint - array of integrals <_a,bb,p,q> (I) +! ndimv1- 1st dimension of vint - norb(symb) (I) +! ndimv2- 2nd dimension of vint - norb(symp) (I) +! ndimv3- 3rd dimension of vint - norb(symq) (I) +! abmap - map for storing of addresses in DA file TEMPDA1 (I) + +use ccsort_global, only: lunda1, mbas, nob, NORB, nvb, pos30, reclen +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: wrksize, syma, symb, symp, symq, a, ndimv1, ndimv2, ndimv3, abmap(mbas,mbas,8) +real(kind=wp), intent(_OUT_) :: wrk(wrksize) +real(kind=wp), intent(in) :: vint(ndimv1,ndimv2,ndimv3) +integer(kind=iwp) :: b, bup, bvint, irec0, length, p, pq, q + +!T if there are no ab pair, or no integrals in _a_bpq block return + +if (nvb(syma)*nvb(symb)*norb(symp)*norb(symq) == 0) return + +! def length of _a_b(p,q) block + +length = norb(symp)*norb(symq) + +if (syma == symb) then + bup = a +else + bup = nvb(symb) +end if + +! cycle over b for given a + +do b=1,bup + bvint = nob(symb)+b + + ! map _a_b(pq) block into #v3 + + pq = pos30-1 + do q=1,norb(symq) + do p=1,norb(symp) + pq = pq+1 + wrk(pq) = vint(bvint,p,q) + end do + end do + + ! put this block to appropriate position in direct access file + + irec0 = abmap(a,b,symp) + call dawrite(lunda1,irec0,wrk(pos30),length,reclen) + +end do + +return + +end subroutine abpack diff -Nru openmolcas-22.02/src/ccsort_util/action_ccsort.F90 openmolcas-22.10/src/ccsort_util/action_ccsort.F90 --- openmolcas-22.02/src/ccsort_util/action_ccsort.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/action_ccsort.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,417 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine action_ccsort(foka,fokb,fi,eps) + +use ccsort_global, only: clopkey, daddr, Escf, fullprint, iokey, ISPIN, LSYM, luna1, luna2, luna3, luna4, lunab, lunda1, lunda2, & + lunt3, mapdri, mapiri, maxspace, mbas, NACTEL, noa, nob, NORB, nsize, NSYM, nva, nvb, posri0, reclen, & + t3key, typ +use Symmetry_Info, only: Mul +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp, u6, RtoB + +implicit none +real(kind=wp), intent(out) :: foka(mbas*(mbas+1)/2), fokb(mbas*(mbas+1)/2) +real(kind=wp), intent(in) :: fi(*), eps(mbas) +#include "t3int.fh" +integer(kind=iwp) :: a, freespace, ickey, keyred, ndimv1, ndimv2, ndimv3, ndimvi, p, post, rc, symp, sympq, sympqr, symq, symr, & + syms, t3help1, t3help2, t3help3, t3help4, vsize, wrksize +integer(kind=iwp), allocatable :: AMMAP(:,:,:), ABMAP(:,:,:), JN(:,:), KN(:,:), LN(:,:), PQIND(:,:) +real(kind=wp), allocatable :: CCSORT(:), CCSORT2(:), VALN(:,:) + +! distribute memory + +!.1 calc. work space requirements +call initwrk(wrksize) + +!.2 test if allocation of required memory is possible + +!.2.1 allocate work space +call mma_maxdble(maxspace) +maxspace = maxspace-4 +if (maxspace < wrksize) then + write(u6,*) ' Allocation of work space failed!' + write(u6,*) ' Increase the size of the variable MOLCAS_MEM' + call Abend() +end if +call mma_allocate(CCSORT,wrksize,label='CCSORT') + +!.3 set wrk = 0 +CCSORT(:) = Zero + +! def foka,fokb + +ndimv1 = 0 +do symp=1,nsym + ndimv1 = ndimv1+(norb(symp)+1)*norb(symp)/2 +end do + +foka(1:ndimv1) = fi(1:ndimv1) +fokb(1:ndimv1) = fi(1:ndimv1) + +! make names + +call mktempanam() + +! if T3 are requited, define T3IntPos and calc T3Off +if (t3key == 1) call DefT3par(noa,nsym) + +! open files INTA1,INTA2,INTA3,INTA4 and INTAB + +if (iokey == 1) then + ! Fortran IO + call molcas_binaryopen_vanilla(luna1,'INTA1') + call molcas_binaryopen_vanilla(luna2,'INTA2') + call molcas_binaryopen_vanilla(luna3,'INTA3') + call molcas_binaryopen_vanilla(luna4,'INTA4') + call molcas_binaryopen_vanilla(lunab,'INTAB') + !open(unit=luna1,file='INTA1',form='unformatted') + !open(unit=luna2,file='INTA2',form='unformatted') + !open(unit=luna3,file='INTA3',form='unformatted') + !open(unit=luna4,file='INTA4',form='unformatted') + !open(unit=lunab,file='INTAB',form='unformatted') + +else + ! MOLCAS IO + call daname(luna1,'INTA1') + call daname(luna2,'INTA2') + call daname(luna3,'INTA3') + call daname(luna4,'INTA4') + call daname(lunab,'INTAB') + daddr(luna1) = 0 + daddr(luna2) = 0 + daddr(luna3) = 0 + daddr(luna4) = 0 + daddr(lunab) = 0 +end if + +! define #V1 (for +call mkmappqij() + +! make head of INTAB file for nonsymmetrical (C1) case +if (nsym == 1) call initintabc1() + +! allocate space for ammap,abmap +call mma_allocate(AMMAP,mbas,8,8,Label='AMMAP') +call mma_allocate(ABMAP,mbas,mbas,8,Label='ABMAP') + +do symp=1,nsym + + if (fullprint > 0) write(u6,'(6X,A,2X,I2)') 'Symmetry of the pivot index',symp + + ! define #V2 (for <_a,m,p,q>) + call mkmapampq(symp) + + ! if T3 are required, make maps for R_i + ! get mapd and mapi for R_i(a,bc) + if ((t3key == 1) .and. (noa(symp) > 0)) call ccsort_t3grc0(3,8,4,4,4,0,symp,posri0,post,mapdri,mapiri) + + ! open TEMPDA2 fils for integrals, if there are some virtiuals + ! in symp symmetry + if (nvb(symp) > 0) then + call mkampqmap(AMMAP,symp,rc) + call daopen('TEMPDA2 ',lunda2,reclen) + end if + + do symq=1,nsym + sympq = mul(symp,symq) + + ! open direct access file here, to enable exact specification of + ! the number of records (only for symmetrical cases; syma>=symb) + ! N.B. nrec is not needed now + if ((nsym > 1) .and. (symp >= symq)) call daopen('TEMPDA1 ',lunda1,reclen) + + ! make abmap for syma>=symb + if (symp >= symq) call mkabpqmap(ABMAP,symp,symq,rc) + + do symr=1,nsym + sympqr = mul(sympq,symr) + syms = sympqr + + ! calc size of the integral file + if (symp == symr) then + if (symp == symq) then + vsize = (norb(symp)*(norb(symp)+1))/2 + vsize = vsize*(vsize+1)/2 + ickey = 3 + else + vsize = (norb(symp)*(norb(symp)+1)*norb(symq)*(norb(symq)+1))/4 + ickey = 2 + end if + else + vsize = norb(symp)*norb(symq)*norb(symr)*norb(syms) + ickey = 1 + end if + + if (vsize == 0) cycle + + if (fullprint > 1) write(u6,'(6X,A,I4,4X,4I2)') 'Block',typ(symp,symq,symr),symp,symq,symr,syms + + ! test for incore expansion + call mma_maxdble(freespace) + freespace = freespace-4 + if (fullprint >= 2) then + write(u6,*) + write(u6,'(6X,A,I10)') 'Available freespace ',freespace + write(u6,'(6X,A,I10)') 'Available freespace/MB',freespace*RtoB/1024**2 + write(u6,'(6X,A,I10)') 'Incore expansion ',vsize+mbas*mbas + write(u6,'(6X,A,I10)') 'Out of core expansion ',4*nsize*mbas + end if + + if (freespace >= (vsize+mbas*mbas)) then + ! INCORE EXPANSION + if (fullprint >= 1) then + write(u6,*) + write(u6,'(6X,A)') 'Incore expansion ' + end if + call mma_allocate(CCSORT2,vsize,label='CCSORT2') + + if (ickey == 1) then + ! case V(p,q,r,s) + call esb_ic_1(symp,symq,symr,syms,CCSORT2,norb(symp),norb(symq),norb(symr),norb(syms)) + + else if (ickey == 2) then + ! case V(pr,qs) + call mma_allocate(PQIND,mbas,mbas,label='PQIND') + call esb_ic_2(symp,symq,CCSORT2,norb(symp),norb(symq),PQIND) + call mma_deallocate(PQIND) + + else + ! case V(prqs) + call mma_allocate(PQIND,mbas,mbas,label='PQIND') + call esb_ic_3(symp,CCSORT2,norb(symp),PQIND) + call mma_deallocate(PQIND) + + end if + + else + ! OUT OF CORE EXPANSION + ! init temp files and realize expansion of this block + ickey = 0 + if (fullprint >= 1) write(u6,'(6X,A)') 'Out of core expansion ' + call inittemp(norb(symp)) + if (freespace < (4*nsize*mbas)) then + write(u6,*) ' Allocation of work space for Out-of-core failed!' + write(u6,*) ' Increase the size of the variable MOLCAS_MEM' + call Abend() + end if + + ! allocate space for valn,jn,kn,ln + call mma_allocate(VALN,nsize,mbas,label='VALN') + call mma_allocate(JN,nsize,mbas,label='JN') + call mma_allocate(KN,nsize,mbas,label='KN') + call mma_allocate(LN,nsize,mbas,label='LN') + + call exppsb(symp,symq,symr,syms,VALN,JN,KN,LN) + + ! release space for valn,jn,kn,ln + call mma_deallocate(VALN) + call mma_deallocate(JN) + call mma_deallocate(KN) + call mma_deallocate(LN) + + end if + + ! run over all pivot indices + + do p=1,norb(symp) + + ! def dimensions of vint and read this block of integrals into vint + ndimvi = norb(symp) + ndimv1 = norb(symq) + ndimv2 = norb(symr) + ndimv3 = norb(syms) + + if (ickey == 0) then + ! Out of core expansion + + if (symq == syms) then + keyred = 1 + else + keyred = 0 + end if + call unpackk(p,CCSORT,ndimv1,ndimv2,ndimv3,keyred) + + else if (ickey == 1) then + ! else Incore expansions + + ! case V(p,q,r,s) + call unpackk_ic_1(p,CCSORT,ndimv1,ndimv2,ndimv3,CCSORT2,ndimvi) + else if (ickey == 2) then + ! case V(pr,qs) + call unpackk_ic_2(p,CCSORT,ndimvi,ndimv1,CCSORT2) + else + ! case V(prqs) + call unpackk_ic_3(p,CCSORT,ndimvi,CCSORT2) + end if + + ! cycle + + ! add integrals to T3nam if needed (v nacechranej forme) + + if (t3key == 1) then + if (p <= noa(symp)) then + if (symq > syms) then + + ! calc proper address in t3nam file + t3help4 = 0 + do t3help1=1,symp-1 + t3help4 = t3help4+noa(t3help1) + end do + t3help4 = t3help4+p + t3help1 = mapiri(symr,symq,1) + daddr(lunt3) = T3IntPos(t3help4)+T3Off(t3help1,symp) + + ! def required parameters + t3help1 = nvb(symr) + t3help2 = nvb(symq) + t3help3 = nvb(syms) + + ! do packing + call t3intpck2(CCSORT,CCSORT(posri0),ndimv1,ndimv2,ndimv3,t3help1,t3help2,t3help3,symq,symr,syms,nob,nvb) + + else if (symq == syms) then + + ! calc proper address in t3nam file + t3help4 = 0 + do t3help1=1,symp-1 + t3help4 = t3help4+noa(t3help1) + end do + t3help4 = t3help4+p + t3help1 = mapiri(symr,symq,1) + daddr(lunt3) = T3IntPos(t3help4)+T3Off(t3help1,symp) + + ! def required parameters + t3help1 = nvb(symr) + t3help2 = nvb(symq)*(nvb(symq)+1)/2 + + ! do packing + call t3intpck1(CCSORT,CCSORT(posri0),ndimv1,ndimv2,ndimv3,t3help1,t3help2,symq,symr,syms,nob,nvb) + + end if + end if + end if + + ! add integrals to #1 if needed + + ! contributions only for symi(r)>=symj(s) + if (symr >= syms) call addpqij(CCSORT,wrksize,symp,symq,symr,syms,p,CCSORT,ndimv1,ndimv2,ndimv3) + + ! updete fok if necessary (only for open shell case) + + if (clopkey == 1) then + + if ((symp == symr) .and. (symq == syms) .and. (p > nob(symp)) .and. (p <= (noa(symp)))) then + call fokupdate1(foka,fokb,symq,p,CCSORT,ndimv1,ndimv2,ndimv3) + end if + + if ((symp == syms) .and. (symq == symr) .and. (p > nob(symp)) .and. (p <= (noa(symp)))) then + call fokupdate2(foka,symq,p,CCSORT,ndimv1,ndimv2,ndimv3) + end if + + end if + + ! add corresponding integrals to TEMPDA2 + ! and pack _a_brs to direct access file TEMPDA1 if needed and symm in not C1 + if (p > nob(symp)) then + a = p-nob(symp) + call ampack(CCSORT,wrksize,symp,symq,symr,syms,a,CCSORT,ndimv1,ndimv2,ndimv3,AMMAP) + if ((nsym > 1) .and. (symp >= symq)) then + call abpack(CCSORT,wrksize,symp,symq,symr,syms,a,CCSORT,ndimv1,ndimv2,ndimv3,ABMAP) + end if + end if + + ! add INTAB file (for nonsymmetrical (C1) state) + + if ((nsym == 1) .and. (p > nob(1))) call addintabc1(CCSORT,wrksize,p-nob(1),CCSORT,ndimv1) + + end do + + ! cycle + + ! close temp files + !call closetemp(norb(symp)) + + if (ickey >= 1) call mma_deallocate(CCSORT2) + + end do + + ! cycle + + if ((nsym > 1) .and. (symp >= symq)) then + ! add contributions to INTAB comming from symp,sumq and close TEMPDA1 file + ! only for symmetrical cases; only for syma>=symb + call addintab(CCSORT,wrksize,symp,symq,ABMAP) + close(lunda1) + call vf('TEMPDA1 ',lunda1) + end if + + end do + + ! cycle + + ! add contributions to INTA1-4 if there are some virtuals in symp symmetry + ! and close TEMPDA2 files + + !if (nvb(symp) > 0) then + call addinta(CCSORT,wrksize,symp,AMMAP) + close(lunda2) + call vf('TEMPDA2 ',lunda2) + !end if + +end do + +! if T3 are required, reorganize T3nam file +if (t3key == 1) call t3reorg(CCSORT,wrksize,noa,nsym) + +! release space for ammap,abmap +call mma_deallocate(AMMAP) +call mma_deallocate(ABMAP) + +! close files INTA1,INTA2,INTA3 and INTA4, INTAB1 + +if (iokey == 1) then + ! Fortran IO + close(luna1) + close(luna2) + close(luna3) + close(luna4) + close(lunab) + +else + ! MOLCAS IO + call daclos(luna1) + call daclos(luna2) + call daclos(luna3) + call daclos(luna4) + call daclos(lunab) +end if + +!return + +! def static integrals (file INTSTA) + +call mkintsta(CCSORT,wrksize,foka,fokb) + +! write general informations to INPDAT + +call molcas_binaryopen_vanilla(1,'INPDAT') +!open(unit=1,file='INPDAT',form='unformatted') +write(1) NACTEL,ISPIN,NSYM,LSYM,mul,noa,nob,nva,nvb,norb,eps,Escf +close(1) + +! Release the memory +call mma_deallocate(CCSORT) + +return + +end subroutine action_ccsort diff -Nru openmolcas-22.02/src/ccsort_util/action.f openmolcas-22.10/src/ccsort_util/action.f --- openmolcas-22.02/src/ccsort_util/action.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/action.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,487 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine action (foka, fokb, fi,eps) -c - implicit real*8 (a-h,o-z) -c -c work file declaration - integer wrksize -#include "WrkSpc.fh" -#include "stdalloc.fh" -c -#include "ccsort.fh" -#include "reorg.fh" -#include "files_ccsd.fh" - real*8 fi(*) - real*8 eps(mbas) -c -c help variables -c - integer symp,symq,symr,syms,sympq,sympqr - integer ndimv1,ndimv2,ndimv3,ndimvi - integer p,a,posst,rc - integer keyred,vsize,freespace,ickey,iOff_Vic,iOff - integer t3help1,t3help2,t3help3,t3help4 - integer ipJN,ipKN,ipLN,iOff_valn - integer, allocatable :: AMMAP(:,:,:),ABMAP(:,:,:) - real*8 foka((mbas**2+mbas)/2) - real*8 fokb((mbas**2+mbas)/2) - - -c -c* distribute memory -c -c*.1 calc. work space requirements - call initwrk (wrksize) -c -c*.2 test if allocation of required memory is possible -c -c*.2.1 allocate work space -c - Call GetMem('CCSORT','Max','Real',maxspace,maxspace) - maxspace=maxspace-4 - if (maxspace.lt.wrksize) then - write(6,*) ' Allocation of work space failed!' - write(6,*) ' Increase the size of the variable MOLCAS_MEM' - Call Abend - end if - Call GetMem('CCSORT','Allo','Real',iOff,wrksize) -c -c*.3 set wrk = 0 - call ccsort_mv0zero (wrksize,wrksize,Work(iOff)) -c -c -c* def foka,fokb -c - ndimv1=0 - do 100 symp=1,nsym - ndimv1=ndimv1+(norb(symp)+1)*norb(symp)/2 - 100 continue -c - do 200 ndimv2=1,ndimv1 - foka(ndimv2)=fi(ndimv2) - fokb(ndimv2)=fi(ndimv2) - 200 continue -c -c* make names -c - call mktempanam -c -c* if T3 are requited, define T3IntPoss and calc T3Off - if (t3key.eq.1) then - call DefT3par (noa,nsym) - do symp=1,4 - end do - end if -c -c* open files INTA1,INTA2,INTA3,INTA4 and INTAB -c - if (iokey.eq.1) then -c Fortran IO - call molcas_binaryopen_vanilla(luna1,'INTA1') - call molcas_binaryopen_vanilla(luna2,'INTA2') - call molcas_binaryopen_vanilla(luna3,'INTA3') - call molcas_binaryopen_vanilla(luna4,'INTA4') - call molcas_binaryopen_vanilla(lunab,'INTAB') -c open (unit=luna1,file='INTA1',form='unformatted') -c open (unit=luna2,file='INTA2',form='unformatted') -c open (unit=luna3,file='INTA3',form='unformatted') -c open (unit=luna4,file='INTA4',form='unformatted') -c open (unit=lunab,file='INTAB',form='unformatted') -c - else -c MOLCAS IO - call daname (luna1,'INTA1') - call daname (luna2,'INTA2') - call daname (luna3,'INTA3') - call daname (luna4,'INTA4') - call daname (lunab,'INTAB') - daddr(luna1)=0 - daddr(luna2)=0 - daddr(luna3)=0 - daddr(luna4)=0 - daddr(lunab)=0 - end if -c -c* define #V1 (for - call mkmappqij -c -c* make head of INTAB file for nonsymmetrical (C1) case - if (nsym.eq.1) then - call initintabc1 - end if -c -c allocate space for ammap,abmap - Call mma_Allocate(AMMAP,mbas,8,8,Label='AMMAP') - Call mma_Allocate(ABMAP,mbas,mbas,8,Label='ABMAP') -c - do 1000 symp=1,nsym -c - if (fullprint.gt.0) then - write(6,'(6X,A,2X,I2)') 'Symmetry of the pivot index',symp - end if -c -c* define #V2 (for <_a,m,p,q>) - call mkmapampq (symp) -c -c* if T3 are required, make maps for R_i - if ((t3key.eq.1).and.(noa(symp).gt.0)) then -c* get mapd and mapi for R_i(a,bc) - call ccsort_t3grc0(3,8,4,4,4,0,symp,possri0,posst,mapdri,mapiri) - end if -c -c* open TEMPDA2 fils for integrals, if there are some virtiuals -c in symp symmetry - if (nvb(symp).gt.0) then - call mkampqmap (AMMAP,symp,rc) - call daopen ('TEMPDA2 ',lunda2,recl,1) - end if -c - do 900 symq=1,nsym - sympq=mul(symp,symq) -c - if ((nsym.gt.1).and.(symp.ge.symq)) then -c* open direct acces file here, to enable exact specification of -c the number of records (only for symmetrical cases; syma>=symb) -c N.B. nrec is not needed now - call daopen ('TEMPDA1 ',lunda1,recl,1) - end if -c -c* make abmap for syma>=symb - if (symp.ge.symq) then - call mkabpqmap (ABMAP,symp,symq,rc) - end if -c - do 800 symr=1,nsym - sympqr=mul(sympq,symr) - syms=sympqr -c -c* calc size of the integral file - if (symp.eq.symr) then - if (symp.eq.symq) then - vsize=(norb(symp)*(norb(symp)+1))/2 - vsize=vsize*(vsize+1)/2 - ickey=3 - else - vsize=(norb(symp)*(norb(symp)+1)*norb(symq)*(norb(symq)+1))/4 - ickey=2 - end if - else - vsize=norb(symp)*norb(symq)*norb(symr)*norb(syms) - ickey=1 - end if -c - if (vsize.eq.0) goto 800 -c - if (fullprint.gt.1) then - write(6,'(6X,A,I4,4X,4I2)') 'Block',typ(symp,symq,symr), - & symp,symq,symr,syms - end if -c -c* test for incore expansion - freespace=0 - Call GetMem('CCSORT','Max','Real',freespace,freespace) - freespace=freespace-4 - if (fullprint.ge.2) then - write(6,*) - Write(6,'(6X,A,I10)') 'Available freespace ',freespace - Write(6,'(6X,A,I10)') 'Available freespace/MB',freespace/131072 - write(6,'(6X,A,I10)') 'Incore expansion ',vsize+mbas*mbas - write(6,'(6X,A,I10)') 'Out of core expansion ',4*nsize*mbas - endif -c - if (freespace.ge.(vsize+mbas*mbas)) then -c INCORE EXPANSION - if (fullprint.ge.1) then - write(6,*) - write(6,'(6X,A)') 'Incore expansion ' - end if - Call GetMem('CCSORT','Allo','Real',iOff_Vic,vsize) -c - if (ickey.eq.1) then -c: case V(p,q,r,s) - call esb_ic_1 (symp,symq,symr,syms, - & Work(iOff_Vic),norb(symp),norb(symq),norb(symr),norb(syms)) -c - else if (ickey.eq.2) then -c: case V(pr,qs) - Call GetMem('PQIND','ALLO','INTE',ipPQIND,mbas*mbas) - call esb_ic_2 (symp,symq,Work(iOff_Vic), - & norb(symp),norb(symq),iWork(ipPQIND)) - Call GetMem('PQIND','FREE','INTE',ipPQIND,mbas*mbas) -c - else -c: case V(prqs) - Call GetMem('PQIND','ALLO','INTE',ipPQIND,mbas*mbas) - call esb_ic_3 (symp,Work(iOff_Vic),norb(symp), - & iWork(ipPQIND)) - Call GetMem('PQIND','FREE','INTE',ipPQIND,mbas*mbas) -c - end if -c - else -c OUT OF CORE EXPANSION -c* init temp files and realize expansion of this block - ickey=0 - if (fullprint.ge.1) then - write(6,'(6X,A)') 'Out of core expansion ' - end if - call inittemp (norb(symp)) - if (freespace.lt.(4*nsize*mbas)) then - write(6,*) ' Allocation of work space for Out-of-core failed!' - write(6,*) ' Increase the size of the variable MOLCAS_MEM' - Call Abend - endif -c -c allocate space for valn,jn,kn,ln - Call GetMem('VALN','ALLO','REAL',iOff_valn,nsize*mbas) - Call GetMem('JN','ALLO','INTE',ipJN,nsize*mbas) - Call GetMem('KN','ALLO','INTE',ipKN,nsize*mbas) - Call GetMem('LN','ALLO','INTE',ipLN,nsize*mbas) -c - call exppsb (symp,symq,symr,syms,Work(iOff_valn), - & iWork(ipJN),iWork(ipKN),iWork(ipLN)) -c -c release space for valn,jn,kn,ln - Call GetMem('VALN','FREE','REAL',iOff_valn,nsize*mbas) - Call GetMem('JN','FREE','INTE',ipJN,nsize*mbas) - Call GetMem('KN','FREE','INTE',ipKN,nsize*mbas) - Call GetMem('LN','FREE','INTE',ipLN,nsize*mbas) -c - end if -c -c -c* run over all pivot indexes -c - do 500 p=1,norb(symp) -c -c** def dimensions of vint and read this block of integrals into vint - ndimvi=norb(symp) - ndimv1=norb(symq) - ndimv2=norb(symr) - ndimv3=norb(syms) -c - if (ickey.eq.0) then -c Out of core expansion -c - if (symq.eq.syms) then - keyred=1 - else - keyred=0 - end if - call unpackk (p,Work(iOff),ndimv1,ndimv2,ndimv3,keyred) -c - else if (ickey.eq.1) then -c else Incore expansions -c -c case V(p,q,r,s) - call unpackk_ic_1 (p,Work(iOff),ndimv1,ndimv2,ndimv3, - c Work(iOff_Vic),ndimvi) - else if (ickey.eq.2) then -c case V(pr,qs) - call unpackk_ic_2 (p,Work(iOff),ndimvi,ndimv1,Work(iOff_Vic)) - else -c case V(prqs) - call unpackk_ic_3 (p,Work(iOff),ndimvi,Work(iOff_Vic)) - end if -c -c -c goto 500 -c -c -c** add integrals to T3nam if needed (v nacechranej forme) -c - if (t3key.eq.1) then - if (p.le.noa(symp)) then - if (symq.gt.syms) then -c -c*** calc proper address in t3nam file - t3help4=0 - do t3help1=1,symp-1 - t3help4=t3help4+noa(t3help1) - end do - t3help4=t3help4+p - t3help1=mapiri(symr,symq,1) - daddr(lunt3)=T3IntPoss(t3help4)+T3Off(t3help1,symp) -c -c*** def required parameters - t3help1=nvb(symr) - t3help2=nvb(symq) - t3help3=nvb(syms) -c -c*** do packing - call t3intpck2(Work(iOff),Work(iOff+possri0-1),ndimv1,ndimv2, - & ndimv3,t3help1,t3help2,t3help3, - & symq,symr,syms,nob,nvb) -c - else if (symq.eq.syms) then -c -c*** calc proper address in t3nam file - t3help4=0 - do t3help1=1,symp-1 - t3help4=t3help4+noa(t3help1) - end do - t3help4=t3help4+p - t3help1=mapiri(symr,symq,1) - daddr(lunt3)=T3IntPoss(t3help4)+T3Off(t3help1,symp) -c -c*** def required parameters - t3help1=nvb(symr) - t3help2=nvb(symq)*(nvb(symq)+1)/2 -c -c*** do packing - call t3intpck1(Work(iOff),Work(iOff+possri0-1),ndimv1,ndimv2, - & ndimv3,t3help1,t3help2, - & symq,symr,syms,nob,nvb) -c - end if - end if - end if -c -c** add integrals to #1 if needed -c - if (symr.ge.syms) then -c contributions only for symi(r)>=symj(s) - call addpqij (Work(iOff),wrksize, - & symp,symq,symr,syms,p,Work(iOff),ndimv1,ndimv2,ndimv3) - end if -c -c** updete fok if neccesarry (only for open shell case) -c - if (clopkey.eq.1) then -c - if ((symp.eq.symr).and.(symq.eq.syms) - & .and.(p.gt.nob(symp)).and.(p.le.(noa(symp)))) then - call fokupdate1 (foka,fokb,symq,p,Work(iOff), - & ndimv1,ndimv2,ndimv3) - end if -c - if ((symp.eq.syms).and.(symq.eq.symr) - & .and.(p.gt.nob(symp)).and.(p.le.(noa(symp)))) then - call fokupdate2 (foka,symq,p,Work(iOff), - & ndimv1,ndimv2,ndimv3) - end if -c - end if -c -c** add corresponding interals to TEMPDA2 -c and pack _a_brs to direct acces file TEMPDA1 if need and symm in not C1 - if (p.gt.nob(symp)) then - a=p-nob(symp) - call ampack (Work(iOff),wrksize, - & symp,symq,symr,syms,a,Work(iOff),ndimv1,ndimv2,ndimv3,AMMAP) - if ((nsym.gt.1).and.(symp.ge.symq)) then - call abpack (Work(iOff),wrksize, - & symp,symq,symr,syms,a,Work(iOff),ndimv1,ndimv2,ndimv3,ABMAP) - end if - end if -c -c** add INTAB file (for nonsymmetrycal (C1) state) -c - if ((nsym.eq.1).and.(p.gt.nob(1))) then - call addintabc1 (Work(iOff),wrksize, - & p-nob(1),Work(iOff),ndimv1) - end if -c - 500 continue -c -c goto 800 -c -c -c* close temp files -c call closetemp (norb(symp)) -c - if (ickey.ge.1) then - Call GetMem('CCSORT','Free','Real',iOff_Vic,vsize) - end if -c - 800 continue -c -c goto 900 -c -c - if ((nsym.gt.1).and.(symp.ge.symq)) then -c* add contributions to INTAB comming from symp,sumq and close TEMPDA1 file -c only for symmetrical cases; only for syma>=symb - call addintab (Work(iOff),wrksize,symp,symq,ABMAP) - close (lunda1) - call vf ('TEMPDA1 ',lunda1) - end if -c - 900 continue -c -c goto 1000 -c -c -c* add contributions to INTA1-4 if there are some virtuals in symp symmetry -c and close TEMPDA2 files -c -c if (nvb(symp).gt.0) then - call addinta (Work(iOff),wrksize,symp,AMMAP) - close (lunda2) - call vf ('TEMPDA2 ',lunda2) -c end if -c - 1000 continue -c -c* if T3 are required, reorganize T3nam file - if (t3key.eq.1) then - call t3reorg (Work(iOff),wrksize, - & noa,nsym) - do symp=1,4 - end do - end if -c -c release space for ammap,abmap - Call mma_Deallocate(AMMAP) - Call mma_Deallocate(ABMAP) -c -c -c* close files INTA1,INTA2,INTA3 and INTA4, INTAB1 -c - if (iokey.eq.1) then -c Fortran IO - close (luna1) - close (luna2) - close (luna3) - close (luna4) - close (lunab) -c - else -c MOLCAS IO - call daclos (luna1) - call daclos (luna2) - call daclos (luna3) - call daclos (luna4) - call daclos (lunab) - end if -c -c return -c -c -c* def static integrals (file INTSTA) -c - call mkintsta (Work(iOff),wrksize, - & foka,fokb) -c -c* write general informations to INPDAT -c - call molcas_binaryopen_vanilla(1,'INPDAT') -c open (unit=1,file='INPDAT',form='unformatted') - write (1) NACTEL,ISPIN,NSYM,LSYM,mul, - & noa,nob,nva,nvb,norb,eps,Escf - close (1) -c -c Release the memory - Call GetMem('CCSORT','Free','Real',iOff,wrksize) - - return - end diff -Nru openmolcas-22.02/src/ccsort_util/addintabc1.f openmolcas-22.10/src/ccsort_util/addintabc1.f --- openmolcas-22.02/src/ccsort_util/addintabc1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/addintabc1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine addintabc1 (wrk,wrksize, - & a,vint,ndimv) -c -c this routine add integrals <_a,_b|p,q> for given a -c for nonsymmetrical (C1) case -c from integrals vv _a(u,p,q) -c -#include "wrk.fh" -#include "reorg.fh" -#include "ccsort.fh" - integer a,ndimv - real*8 vint(1:ndimv,1:ndimv,1:ndimv) -c -c help variables -c - integer poss,b,bvint,p,q,length -c -c -cT if there are no _a_b,pq integrals in this symab, -c skip sumation over ab -c - if (nvb(1).eq.0) then - return - end if -c -c* loop over b -c - do 1000 b=1,a - bvint=b+nob(1) -c -c map <_a,b|p,q> to wrk in #3 - poss=poss30 - do 1010 q=1,norb(1) - do 1011 p=1,norb(1) - wrk(poss)=vint(bvint,p,q) - poss=poss+1 - 1011 continue - 1010 continue -c -c -c** since there must be some integrals, write them to TEMPAB -c - length=poss-poss30 - call dawri (lunab,length,wrk(poss30)) -c - 1000 continue -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/addintabc1.F90 openmolcas-22.10/src/ccsort_util/addintabc1.F90 --- openmolcas-22.02/src/ccsort_util/addintabc1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/addintabc1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,55 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine addintabc1(wrk,wrksize,a,vint,ndimv) +! this routine adds integrals <_a,_b|p,q> for given a +! for nonsymmetrical (C1) case +! from integrals vv _a(u,p,q) + +use ccsort_global, only: lunab, nob, NORB, nvb, pos30 +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: wrksize, a, ndimv +real(kind=wp), intent(_OUT_) :: wrk(wrksize) +real(kind=wp), intent(in) :: vint(ndimv,ndimv,ndimv) +integer(kind=iwp) :: b, bvint, length, p, pos, q + +!T if there are no _a_b,pq integrals in this symab, skip summation over ab + +if (nvb(1) == 0) return + +! loop over b + +do b=1,a + bvint = b+nob(1) + + ! map <_a,b|p,q> to wrk in #3 + pos = pos30 + do q=1,norb(1) + do p=1,norb(1) + wrk(pos) = vint(bvint,p,q) + pos = pos+1 + end do + end do + + ! since there must be some integrals, write them to TEMPAB + + length = pos-pos30 + call dawri(lunab,length,wrk(pos30)) + +end do + +return + +end subroutine addintabc1 diff -Nru openmolcas-22.02/src/ccsort_util/addintab.f openmolcas-22.10/src/ccsort_util/addintab.f --- openmolcas-22.02/src/ccsort_util/addintab.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/addintab.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,121 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine addintab (wrk,wrksize, - & syma,symb,abmap) -c -c this routine add contribution to opened INTAB1 file, -c comming from ab syma,symb -c -#include "wrk.fh" -#include "reorg.fh" -#include "ccsort.fh" - integer syma,symb - integer abmap(1:mbas,1:mbas,1:8) -c -c help variables -c - integer nhelp,length,symp,symq,symab,irec0,poss3 - integer poss,a,b,bup,ii,rc -c -c* def symab - symab=mul(syma,symb) -c -c* make mapd3,mapi3 for <_a_b|pq> -c -c** set mapi3=0 (partly) -c - do 100 nhelp=1,nsym - do 101 symq=1,nsym - do 102 symp=1,nsym - mapi3(symp,symq,nhelp)=0 - 102 continue - 101 continue - 100 continue -c -c** def 0-th row -c - mapd3(0,1)=5 - mapd3(0,2)=5 - mapd3(0,3)=0 - mapd3(0,4)=0 - mapd3(0,5)=nsym - mapd3(0,6)=0 -c -c** def other rows -c - poss=poss30 - do 200 ii=1,nsym -c - symp=ii - symq=mul(symab,symp) - length=norb(symp)*norb(symq) - mapd3(ii,1)=poss - mapd3(ii,2)=length - mapd3(ii,3)=symp - mapd3(ii,4)=symq - mapd3(ii,5)=1 - mapd3(ii,6)=1 - mapi3(symp,1,1)=ii - poss=poss+length -c - 200 continue -c -c* write mapd,mapi to INTAB - call dawrtmap (lunab,mapd3,mapi3,rc) -c -cT if there are no _a_b,pq integrals in this symab, -c skip sumation over ab -c - if ((mapd3(nsym,1)+mapd3(nsym,2)).eq.poss30) then - return - end if -c -c* loop over a,b -c - do 1000 a=1,nvb(syma) -c - if (syma.eq.symb) then - bup=a - else - bup=nvb(symb) - end if -c - do 1001 b=1,bup -c -c** loop over symp -c - do 500 symp=1,nsym -c -c*** def irec0 for this a,b,symp in TEMPDA1 - irec0=abmap(a,b,symp) -c -c*** def corresponding possition and length in #3 - ii=mapi3(symp,1,1) - poss3=mapd3(ii,1) - length=mapd3(ii,2) -c -c*** read this block to #3 - if (length.gt.0) then - call daread (lunda1,irec0,wrk(poss3),length,recl) - end if -c - 500 continue -c -c** since there must be some integrals, write them to TEMPAB -c - call deflength (mapd3,length) - call dawri (lunab,length,wrk(poss30)) -c - 1001 continue - 1000 continue -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/addintab.F90 openmolcas-22.10/src/ccsort_util/addintab.F90 --- openmolcas-22.02/src/ccsort_util/addintab.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/addintab.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,110 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine addintab(wrk,wrksize,syma,symb,abmap) +! this routine adds contributions to open INTAB1 file, +! comming from ab syma,symb + +use ccsort_global, only: lunab, lunda1, mapd3, mapi3, mbas, NORB, NSYM, nvb, pos30, reclen +use Symmetry_Info, only: Mul +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: wrksize, syma, symb, abmap(mbas,mbas,8) +real(kind=wp), intent(_OUT_) :: wrk(wrksize) +integer(kind=iwp) :: a, b, bup, ii, irec0, length, pos, pos3, rc, symab, symp, symq + +! def symab +symab = mul(syma,symb) + +! make mapd3,mapi3 for <_a_b|pq> + +! set mapi3=0 (partly) + +mapi3(1:nsym,1:nsym,1:nsym) = 0 + +! def 0-th row + +mapd3(0,1) = 5 +mapd3(0,2) = 5 +mapd3(0,3) = 0 +mapd3(0,4) = 0 +mapd3(0,5) = nsym +mapd3(0,6) = 0 + +! def other rows + +pos = pos30 +do ii=1,nsym + + symp = ii + symq = mul(symab,symp) + length = norb(symp)*norb(symq) + mapd3(ii,1) = pos + mapd3(ii,2) = length + mapd3(ii,3) = symp + mapd3(ii,4) = symq + mapd3(ii,5) = 1 + mapd3(ii,6) = 1 + mapi3(symp,1,1) = ii + pos = pos+length + +end do + +! write mapd,mapi to INTAB +call dawrtmap(lunab,mapd3,mapi3,rc) + +!T if there are no _a_b,pq integrals in this symab, skip summation over ab + +if ((mapd3(nsym,1)+mapd3(nsym,2)) == pos30) return + +! loop over a,b + +do a=1,nvb(syma) + + if (syma == symb) then + bup = a + else + bup = nvb(symb) + end if + + do b=1,bup + + ! loop over symp + + do symp=1,nsym + + ! def irec0 for this a,b,symp in TEMPDA1 + irec0 = abmap(a,b,symp) + + ! def corresponding position and length in #3 + ii = mapi3(symp,1,1) + pos3 = mapd3(ii,1) + length = mapd3(ii,2) + + ! read this block to #3 + if (length > 0) call daread(lunda1,irec0,wrk(pos3),length,reclen) + + end do + + ! since there must be some integrals, write them to TEMPAB + + call deflength(mapd3,length) + call dawri(lunab,length,wrk(pos30)) + + end do +end do + +return + +end subroutine addintab diff -Nru openmolcas-22.02/src/ccsort_util/addinta.f openmolcas-22.10/src/ccsort_util/addinta.f --- openmolcas-22.02/src/ccsort_util/addinta.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/addinta.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,167 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine addinta (wrk,wrksize, - & syma,ammap) -c -c this routine do for all a in syma -c 1- reconstruct #2 <_a,m,p,q> from TEMPDA2 file -c 2- prepair corresponding <_am p q> (like aaaa) to #3 -c and write it to opened INTA1-4 -c N.B. this routine use followuing foreign routines: -c wrtmap -c wri -c -#include "wrk.fh" -#include "reorg.fh" -#include "ccsort.fh" - integer syma - integer ammap(1:mbas,1:8,1:8) -c -c help variables -c - integer lenefaaaa,lenefbaab,lenefbbbb,lenefabab - integer lenejaaaa,lenejbaab,lenejbaba,lenejbbbb,lenejabab, - & lenejabba - integer posst,rc,a -c -c* mapd2 and mapi2 of #2 <_a,m|p,q> are prepaired -c -c* make required mapd3 and mapi3 and write them to INTA1-4 -c define lengths of this mediates -c -c*1 to INTA1 aaaa, baab - call ccsort_grc0(3,2,1,3,3,0,syma,poss30,posst,mapd3,mapi3) - call deflength (mapd3,lenefaaaa) - call dawrtmap (luna1,mapd3,mapi3,rc) - call ccsort_grc0(3,0,2,3,4,0,syma,poss30,posst,mapd3,mapi3) - call deflength (mapd3,lenefbaab) - call dawrtmap (luna1,mapd3,mapi3,rc) -c -c*2 to INTA2 bbbb, abab - call ccsort_grc0(3,2,2,4,4,0,syma,poss30,posst,mapd3,mapi3) - call deflength (mapd3,lenefbbbb) - call dawrtmap (luna2,mapd3,mapi3,rc) - call ccsort_grc0(3,0,1,3,4,0,syma,poss30,posst,mapd3,mapi3) - call deflength (mapd3,lenefabab) - call dawrtmap (luna2,mapd3,mapi3,rc) -c -c*3 to INTA3 aaaa, baab, baba - call ccsort_grc0(3,0,1,3,1,0,syma,poss30,posst,mapd3,mapi3) - call deflength (mapd3,lenejaaaa) - call dawrtmap (luna3,mapd3,mapi3,rc) - call ccsort_grc0(3,0,2,3,2,0,syma,poss30,posst,mapd3,mapi3) - call deflength (mapd3,lenejbaab) - call dawrtmap (luna3,mapd3,mapi3,rc) - call ccsort_grc0(3,0,2,4,1,0,syma,poss30,posst,mapd3,mapi3) - call deflength (mapd3,lenejbaba) - call dawrtmap (luna3,mapd3,mapi3,rc) -c -c*4 to INTA4 bbbb, abba, abab - call ccsort_grc0(3,0,2,4,2,0,syma,poss30,posst,mapd3,mapi3) - call deflength (mapd3,lenejbbbb) - call dawrtmap (luna4,mapd3,mapi3,rc) - call ccsort_grc0(3,0,1,4,1,0,syma,poss30,posst,mapd3,mapi3) - call deflength (mapd3,lenejabba) - call dawrtmap (luna4,mapd3,mapi3,rc) - call ccsort_grc0(3,0,1,3,2,0,syma,poss30,posst,mapd3,mapi3) - call deflength (mapd3,lenejabab) - call dawrtmap (luna4,mapd3,mapi3,rc) -c -c -c* cycle over a -c - do 1000 a=1,nvb(syma) -c -c* reconstruct #2 <_a,m,p,q> for given _a - call mkampq (wrk,wrksize, - & a,ammap) -c -c* get contributions to INTA2 bbbb, abab -c and wtite it there -c - if (lenefbbbb.gt.0) then - call expmpq (wrk,wrksize, - & syma,2,2,4,4,1,1) - call dawri (luna2,lenefbbbb,wrk(mapd3(1,1))) - end if -c - if (lenefabab.gt.0) then - call expmpq (wrk,wrksize, - & syma,0,1,3,4,1,0) - call dawri (luna2,lenefabab,wrk(mapd3(1,1))) - end if -c -c* get contributions to INTA4 bbbb, abba, abab -c and wtite it there -c - if (lenejbbbb.gt.0) then - call expmpq (wrk,wrksize, - & syma,0,2,4,2,1,1) - call dawri (luna4,lenejbbbb,wrk(mapd3(1,1))) - end if -c - if (lenejabba.gt.0) then - call expmpq (wrk,wrksize, - & syma,0,1,4,1,0,1) - call dawri (luna4,lenejabba,wrk(mapd3(1,1))) - end if -c - if (lenejabab.gt.0) then - call expmpq (wrk,wrksize, - & syma,0,1,3,2,1,0) - call dawri (luna4,lenejabab,wrk(mapd3(1,1))) - end if -c - if (a.gt.(nvb(syma)-nva(syma))) then -c contributions to INTA1 and INTA3 only for a-alfa -c -c* get contributions to INTA1 aaaa, baab if any -c and wtite it there -c - if (lenefaaaa.gt.0) then - call expmpq (wrk,wrksize, - & syma,2,1,3,3,1,1) - call dawri (luna1,lenefaaaa,wrk(mapd3(1,1))) - end if -c - if (lenefbaab.gt.0) then - call expmpq (wrk,wrksize, - & syma,0,2,3,4,0,1) - call dawri (luna1,lenefbaab,wrk(mapd3(1,1))) - end if -c -c* get contributions to INTA3 aaaa, baab, baba -c and wtite it there -c - if (lenejaaaa.gt.0) then - call expmpq (wrk,wrksize, - & syma,0,1,3,1,1,1) - call dawri (luna3,lenejaaaa,wrk(mapd3(1,1))) - end if -c - if (lenejbaab.gt.0) then - call expmpq (wrk,wrksize, - & syma,0,2,3,2,0,1) - call dawri (luna3,lenejbaab,wrk(mapd3(1,1))) - end if -c - if (lenejbaba.gt.0) then - call expmpq (wrk,wrksize, - & syma,0,2,4,1,1,0) - call dawri (luna3,lenejbaba,wrk(mapd3(1,1))) - end if -c - end if -c - 1000 continue -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/addinta.F90 openmolcas-22.10/src/ccsort_util/addinta.F90 --- openmolcas-22.02/src/ccsort_util/addinta.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/addinta.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,153 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine addinta(wrk,wrksize,syma,ammap) +! this routine does for all a in syma +! 1- reconstruct #2 <_a,m,p,q> from TEMPDA2 file +! 2- prepare corresponding <_am p q> (like aaaa) to #3 +! and write it to open INTA1-4 +! N.B. this routine uses following foreign routines: +! wrtmap +! wri + +use ccsort_global, only: luna1, luna2, luna3, luna4, mapd3, mapi3, mbas, nva, nvb, pos30 +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: wrksize, syma, ammap(mbas,8,8) +real(kind=wp), intent(_OUT_) :: wrk(wrksize) +integer(kind=iwp) :: a, lenefaaaa, lenefabab, lenefbaab, lenefbbbb, lenejaaaa, lenejabab, lenejabba, lenejbaab, lenejbaba, & + lenejbbbb, post, rc + +! mapd2 and mapi2 of #2 <_a,m|p,q> are prepared + +! make required mapd3 and mapi3 and write them to INTA1-4 +! define lengths of this mediates + +!1 to INTA1 aaaa, baab +call ccsort_grc0(3,2,1,3,3,0,syma,pos30,post,mapd3,mapi3) +call deflength(mapd3,lenefaaaa) +call dawrtmap(luna1,mapd3,mapi3,rc) +call ccsort_grc0(3,0,2,3,4,0,syma,pos30,post,mapd3,mapi3) +call deflength(mapd3,lenefbaab) +call dawrtmap(luna1,mapd3,mapi3,rc) + +!2 to INTA2 bbbb, abab +call ccsort_grc0(3,2,2,4,4,0,syma,pos30,post,mapd3,mapi3) +call deflength(mapd3,lenefbbbb) +call dawrtmap(luna2,mapd3,mapi3,rc) +call ccsort_grc0(3,0,1,3,4,0,syma,pos30,post,mapd3,mapi3) +call deflength(mapd3,lenefabab) +call dawrtmap(luna2,mapd3,mapi3,rc) + +!3 to INTA3 aaaa, baab, baba +call ccsort_grc0(3,0,1,3,1,0,syma,pos30,post,mapd3,mapi3) +call deflength(mapd3,lenejaaaa) +call dawrtmap(luna3,mapd3,mapi3,rc) +call ccsort_grc0(3,0,2,3,2,0,syma,pos30,post,mapd3,mapi3) +call deflength(mapd3,lenejbaab) +call dawrtmap(luna3,mapd3,mapi3,rc) +call ccsort_grc0(3,0,2,4,1,0,syma,pos30,post,mapd3,mapi3) +call deflength(mapd3,lenejbaba) +call dawrtmap(luna3,mapd3,mapi3,rc) + +!4 to INTA4 bbbb, abba, abab +call ccsort_grc0(3,0,2,4,2,0,syma,pos30,post,mapd3,mapi3) +call deflength(mapd3,lenejbbbb) +call dawrtmap(luna4,mapd3,mapi3,rc) +call ccsort_grc0(3,0,1,4,1,0,syma,pos30,post,mapd3,mapi3) +call deflength(mapd3,lenejabba) +call dawrtmap(luna4,mapd3,mapi3,rc) +call ccsort_grc0(3,0,1,3,2,0,syma,pos30,post,mapd3,mapi3) +call deflength(mapd3,lenejabab) +call dawrtmap(luna4,mapd3,mapi3,rc) + +! cycle over a + +do a=1,nvb(syma) + + ! reconstruct #2 <_a,m,p,q> for given _a + call mkampq(wrk,wrksize,a,ammap) + + ! get contributions to INTA2 bbbb, abab + ! and write it there + + if (lenefbbbb > 0) then + call expmpq(wrk,wrksize,syma,2,2,4,4,1,1) + call dawri(luna2,lenefbbbb,wrk(mapd3(1,1))) + end if + + if (lenefabab > 0) then + call expmpq(wrk,wrksize,syma,0,1,3,4,1,0) + call dawri(luna2,lenefabab,wrk(mapd3(1,1))) + end if + + ! get contributions to INTA4 bbbb, abba, abab + ! and write it there + + if (lenejbbbb > 0) then + call expmpq(wrk,wrksize,syma,0,2,4,2,1,1) + call dawri(luna4,lenejbbbb,wrk(mapd3(1,1))) + end if + + if (lenejabba > 0) then + call expmpq(wrk,wrksize,syma,0,1,4,1,0,1) + call dawri(luna4,lenejabba,wrk(mapd3(1,1))) + end if + + if (lenejabab > 0) then + call expmpq(wrk,wrksize,syma,0,1,3,2,1,0) + call dawri(luna4,lenejabab,wrk(mapd3(1,1))) + end if + + if (a > (nvb(syma)-nva(syma))) then + ! contributions to INTA1 and INTA3 only for a-alfa + + ! get contributions to INTA1 aaaa, baab if any + ! and write it there + + if (lenefaaaa > 0) then + call expmpq(wrk,wrksize,syma,2,1,3,3,1,1) + call dawri(luna1,lenefaaaa,wrk(mapd3(1,1))) + end if + + if (lenefbaab > 0) then + call expmpq(wrk,wrksize,syma,0,2,3,4,0,1) + call dawri(luna1,lenefbaab,wrk(mapd3(1,1))) + end if + + ! get contributions to INTA3 aaaa, baab, baba + ! and write it there + + if (lenejaaaa > 0) then + call expmpq(wrk,wrksize,syma,0,1,3,1,1,1) + call dawri(luna3,lenejaaaa,wrk(mapd3(1,1))) + end if + + if (lenejbaab > 0) then + call expmpq(wrk,wrksize,syma,0,2,3,2,0,1) + call dawri(luna3,lenejbaab,wrk(mapd3(1,1))) + end if + + if (lenejbaba > 0) then + call expmpq(wrk,wrksize,syma,0,2,4,1,1,0) + call dawri(luna3,lenejbaba,wrk(mapd3(1,1))) + end if + + end if + +end do + +return + +end subroutine addinta diff -Nru openmolcas-22.02/src/ccsort_util/addpqij.f openmolcas-22.10/src/ccsort_util/addpqij.f --- openmolcas-22.02/src/ccsort_util/addpqij.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/addpqij.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,61 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine addpqij (wrk,wrksize, - & symp,symq,symi,symj,p,vint,ndimv1,ndimv2, - & ndimv3) -c -c this routine add corresponding part to record (#1) -c comming from readed integrals with pivot index p vint_p(q,i,j) -c -#include "wrk.fh" -#include "reorg.fh" -#include "ccsort.fh" - integer symi,symj,symp,symq,p,ndimv1,ndimv2,ndimv3 - real*8 vint(1:ndimv1,1:ndimv2,1:ndimv3) -c -c help variables -c - integer ii,ij,i,j,poss0,possij0,q,pqij -c -c* find number of this symmetry combination -c and initial possition of this symmetry block in (1) -c - ii=mapi1(symp,symq,symi) - poss0=mapd1(ii,1) -c -cT0 if symi integral -c - ij=(j-1)*noa(symi)+i - possij0=poss0+(norb(symp)*norb(symq))*(ij-1) -c - do 200 q=1,norb(symq) - pqij=possij0-1+norb(symp)*(q-1)+p - wrk(pqij)=vint(q,i,j) - 200 continue -c - 1001 continue - 1000 continue -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/addpqij.F90 openmolcas-22.10/src/ccsort_util/addpqij.F90 --- openmolcas-22.02/src/ccsort_util/addpqij.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/addpqij.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,57 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine addpqij(wrk,wrksize,symp,symq,symi,symj,p,vint,ndimv1,ndimv2,ndimv3) +! this routine adds corresponding part to record (#1) +! coming from read integrals with pivot index p vint_p(q,i,j) + +use ccsort_global, only: mapd1, mapi1, noa, NORB +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: wrksize, symp, symq, symi, symj, p, ndimv1, ndimv2, ndimv3 +real(kind=wp), intent(_OUT_) :: wrk(wrksize) +real(kind=wp), intent(in) :: vint(ndimv1,ndimv2,ndimv3) +integer(kind=iwp) :: i, ii, ij, j, pos0, posij0, pqij, q + +! find number of this symmetry combination +! and initial position of this symmetry block in (1) + +ii = mapi1(symp,symq,symi) +pos0 = mapd1(ii,1) + +!T0 if symi integral + + ij = (j-1)*noa(symi)+i + posij0 = pos0+(norb(symp)*norb(symq))*(ij-1) + + do q=1,norb(symq) + pqij = posij0-1+norb(symp)*(q-1)+p + wrk(pqij) = vint(q,i,j) + end do + + end do +end do + +return + +end subroutine addpqij diff -Nru openmolcas-22.02/src/ccsort_util/ampack.f openmolcas-22.10/src/ccsort_util/ampack.f --- openmolcas-22.02/src/ccsort_util/ampack.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ampack.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,70 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine ampack (wrk,wrksize, - & syma,symm,symp,symq,a,vint,ndimv1,ndimv2,ndimv3, - & ammap) -c -c this routine pack corresponding parts to ab direct acc. file -c from given integrals <_a,bb,p,q> readed in vint -c -c syma - irrep of first index (I) -c symm - irrep of 2.nd index - m (I) -c symp - irrep of p (I) -c symq - irrep of q (I) -c a- pivot virtual index (counted in nvb set) (I) -c vint - array of integrals <_a,mm,p,q> (I) -c ndimv1- 1.st dimension of vint - norb(symb) (I) -c ndimv2- 2.nd dimension of vint - norb(symp) (I) -c ndimv3- 3.rd dimension of vint - norb(symq) (I) -c ammap - map for storing of addresses in DA file TEMPDA2 (I) -c -#include "wrk.fh" -#include "ccsort.fh" -#include "reorg.fh" -c - integer syma,symm,symp,symq,a,ndimv1,ndimv2,ndimv3 - real*8 vint(1:ndimv1,1:ndimv2,1:ndimv3) - integer ammap(1:mbas,1:8,1:8) -c -c help variables -c - integer m,p,q,pq,irec0,length -c -cT if there are no a, or no integrals in _a_mpq block return -c - if (nvb(syma)*noa(symm)*norb(symp)*norb(symq).eq.0) then - return - end if -c -c* def length of _a(m,p,q) block -c - length=noa(symm)*norb(symp)*norb(symq) -c -c* map _a(mpq) block into #v3 -c - pq=poss30-1 -c - do 100 q=1,norb(symq) - do 101 p=1,norb(symp) - do 102 m=1,noa(symm) - pq=pq+1 - wrk(pq)=vint(m,p,q) - 102 continue - 101 continue - 100 continue -c -c* put this block to iappropriate possition in direct acces file -c - irec0=ammap(a,symm,symp) - call dawrite (lunda2,irec0,wrk(poss30),length,recl) -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/ampack.F90 openmolcas-22.10/src/ccsort_util/ampack.F90 --- openmolcas-22.02/src/ccsort_util/ampack.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ampack.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,66 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ampack(wrk,wrksize,syma,symm,symp,symq,a,vint,ndimv1,ndimv2,ndimv3,ammap) +! this routine packs corresponding parts to ab direct acc. file +! from given integrals <_a,bb,p,q> read in vint +! +! syma - irrep of first index (I) +! symm - irrep of 2nd index - m (I) +! symp - irrep of p (I) +! symq - irrep of q (I) +! a - pivot virtual index (counted in nvb set) (I) +! vint - array of integrals <_a,mm,p,q> (I) +! ndimv1- 1st dimension of vint - norb(symb) (I) +! ndimv2- 2nd dimension of vint - norb(symp) (I) +! ndimv3- 3rd dimension of vint - norb(symq) (I) +! ammap - map for storing of addresses in DA file TEMPDA2 (I) + +use ccsort_global, only: lunda2, mbas, noa, NORB, nvb, pos30, reclen +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: wrksize, syma, symm, symp, symq, a, ndimv1, ndimv2, ndimv3, ammap(mbas,8,8) +real(kind=wp), intent(_OUT_) :: wrk(wrksize) +real(kind=wp), intent(in) :: vint(ndimv1,ndimv2,ndimv3) +integer(kind=iwp) :: irec0, length, m, p, pq, q + +!T if there are no a, or no integrals in _a_mpq block return + +if (nvb(syma)*noa(symm)*norb(symp)*norb(symq) == 0) return + +! def length of _a(m,p,q) block + +length = noa(symm)*norb(symp)*norb(symq) + +! map _a(mpq) block into #v3 + +pq = pos30-1 + +do q=1,norb(symq) + do p=1,norb(symp) + do m=1,noa(symm) + pq = pq+1 + wrk(pq) = vint(m,p,q) + end do + end do +end do + +! put this block to appropriate position in direct access file + +irec0 = ammap(a,symm,symp) +call dawrite(lunda2,irec0,wrk(pos30),length,reclen) + +return + +end subroutine ampack diff -Nru openmolcas-22.02/src/ccsort_util/ccsort.fh openmolcas-22.10/src/ccsort_util/ccsort.fh --- openmolcas-22.02/src/ccsort_util/ccsort.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ccsort.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,70 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -CFUE start modification -cPN modification (add noa,nob,nva,nvb) -#include "rasdim.fh" -C -C When changing the parameters make shure they match the definitions -C in the file rasdim.fh which defines the dimensions the JOBIPH -C - PARAMETER (MXEXT=MXBAS) -CFUE end modification - PARAMETER (MXTU=MXACT**2,MXTUV=MXACT*MXTU, - & MXTGEU=(MXTU+MXACT)/2,MXTGTU=MXTU-MXTGEU, - & MXIGEJ=(MXINA*(MXINA+1))/2,MXIGTJ=(MXINA*(MXINA-1))/2, - & MXAGEB=(MXEXT*(MXEXT+1))/2,MXAGTB=(MXEXT*(MXEXT-1))/2) - Logical RFpert - INTEGER - & MAXIT,NTIT,IFJAC,NACTEL,ISPIN,NSYM,LSYM,NCONF, - & NFRO,NFROT,NISH,NIES,NISHT,NRAS1,NRAS1T, - & NRAS2,NRAS2T,NRAS3,NRAS3T,NASH,NAES,NASHT, - & NOSH,NOSHT,NSSH,NSES,NSSHT,NORB,NORBT, - & NDEL,NDELT,NBAS,NBAST,MUL,ISCF,IISYM, - & IASYM,IESYM, - & IINAIS,IACTIS,IEXTIS, - & LIST,LROOT,NROOTS,IROOT,IADR15,NBAS2, - & NORB1,IAD1M,NELE3,NHOLE1, - & noa,nob,nva,nvb - REAL*8 CONV,THRSHN,THRSHS,THRSHF,THRENE,THROCC, - & POTNUC,ECORE,EREF - - COMMON/INPUT1/ CONV,THRSHN,THRSHS,THRSHF,THRENE,THROCC, - & POTNUC,ECORE,EREF - COMMON/INPUT2/ MAXIT,NTIT,IFJAC,NACTEL,ISPIN,NSYM,LSYM,NCONF, - & NFRO(8),NFROT,NISH(8),NIES(8),NISHT,NRAS1(8),NRAS1T, - & NRAS2(8),NRAS2T,NRAS3(8),NRAS3T,NASH(8),NAES(8),NASHT, - & NOSH(8),NOSHT,NSSH(8),NSES(8),NSSHT,NORB(8),NORBT, - & NDEL(8),NDELT,NBAS(8),NBAST,MUL(8,8),ISCF,IISYM(MXINA), - & IASYM(MXACT),IESYM(MXEXT), - & IINAIS(MXINA),IACTIS(MXACT),IEXTIS(MXEXT), - & LIST(52),LROOT,NROOTS,IROOT(MXROOT),IADR15(64),NBAS2, - & NORB1,IAD1M(64),NELE3,NHOLE1,RFpert,IPT2, - & noa(8),nob(8),nva(8),nvb(8) -c@ COMMON/VARIA/ EPS(MXORB),EPSI(MXINA),EPSA(MXACT),EPSE(MXEXT), -c@ & EDEA(MXACT),EDIP(MXACT),EOCORR(MXACT,0:2), -c@ & POCC(MXACT,0:2),EASUM,DENORM - COMMON/ALLO/ NCMO,LCMO,NFIMO,LFIMO,NFAMO,LFAMO,NFIFA,LFIFA, - & NHONE,LHONE,NDREF,LDREF,NPREF,LPREF - COMMON/CCSORT_UNITS/ LUINTA,LUONEA,JOBIPH,LUMORB,LUONEM, - & LUHLF1,LUHLF2,LUHLF3,LUINTM,LUDMAT,LUVECT,LUEXT -C Excitation operators, sizes and offsets - PARAMETER (NCASES=13) - COMMON/CCSORT_STRUCT/ NASUP(8,NCASES),NISUP(8,NCASES), - & NINDEP(8,NCASES), - & NEXC(8,NCASES),NEXCES(8,NCASES),NREDCO(8,NCASES) - CHARACTER*8 HZERO,FOCKTYPE,ORBIT,ORBIN,ORBNAM,IINAM,IANAM, - & ISNAM,CASES - CHARACTER*4 NAME,TITLE,METHOD - CHARACTER*2 HEADER - CHARACTER*72 TITLE2 - COMMON/CCSD_STRING/ NAME(2*MXORB),HEADER(72),TITLE2(10), - & TITLE(MXTIT,18),CASES(13),HZERO,FOCKTYPE,ORBIT,ORBIN, - & ORBNAM(MXORB),IINAM(MXINA),IANAM(MXACT),ISNAM(MXEXT),METHOD diff -Nru openmolcas-22.02/src/ccsort_util/ccsort_global.F90 openmolcas-22.10/src/ccsort_util/ccsort_global.F90 --- openmolcas-22.02/src/ccsort_util/ccsort_global.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ccsort_global.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,81 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +module ccsort_global + +use Definitions, only: wp, iwp + +implicit none +private + +!1. parameters for expansion of orbitals +! nsize nmbas +! +!3. names of TEMP files and status matrix for TEMP files +! tmpnam stattemp lrectemp nrectemp +! +!4. arrays for expanding of orbitals +! valh jh kh lh nshow +! +!5. arrays for expanding of orbitals +! reflecting permutation +! np nq nr ns typ idis +! +!6. four mapd,mapi matrices and corresponding initial positions variables +! mapd and mapi for R_i matrix, required for making T3 integrals +! pos10 pos20 pos30 mapd1 mapi1 mapd2 mapi2 mapd3 mapi3 posri0 mapdri mapiri +! +!7. lun for INTA1 aaaa, baab +! lun for INTA2 bbbb, abab +! lun for INTA3 aaaa, baab, baba +! lun for INTA4 bbbb, abab, abba +! lun for INTAB _a_b(p,q) +! lunt3 - Lun for t3nam file +! luna1 luna2 luna3 luna4 lunab lunt3 +! +!8. parameters for direct access file +! lun and reclen (in R8 words) for direct access TEMPDA1,TEMPDA2 +! lunda1 lunda2 reclen +! +!10. input keys +! cckey - key for doing CCSD integrals +! t3key - key for doing T3 integrals +! clopkey - closed/open key +! nfror - forzen orbitals per symmetry in Reorg +! ndelr - deleted orbitals per symmetry in Reorg +! maxspace - maximal allowed allocatable area +! fullprint - output printing control key +! noop - no operation key +! iokey - disk handling control key +! zrkey - key for reading I values and indices simultanously +! cckey t3key clopkey nfror ndelr maxspace fullprint noop iokey zrkey +! +! disk addresses for MOLCAS DA file handling +! daddr + +integer(kind=iwp), parameter :: mbas = 1024, nsize = 8192, reclen = 100 +integer(kind=iwp) :: cckey, clopkey, daddr(128), fullprint, IADR15(64), idis(8,8,8), iokey, IPT2, ISCF, ISPIN, jh(nsize), JOBIPH, & + kh(nsize), lh(nsize), lrectemp(mbas), LROOT, LSYM, LUINTM, luna1, luna2, luna3, luna4, lunab, lunda1, lunda2, & + lunpublic, lunt3, mapd1(0:512,6), mapd2(0:512,6), mapd3(0:512,6), mapdri(0:512,6), mapi1(8,8,8), & + mapi2(8,8,8), mapi3(8,8,8), mapiri(8,8,8), maxspace, NACTEL, NASH(8), NASHT, NBAS(8), nBasX(8), NCONF, & + NDEL(8), ndelr(8), nDelX(8), NELE3, NFRO(8), nfror(8), nFroX(8), NHOLE1, NISH(8), NISHT, noa(8), nob(8), & + noop, NORB(8), np(8,8,8), nq(8,8,8), nr(8,8,8), nrectemp(mbas), NROOTS, ns(8,8,8), nshow(mbas), NSSH(8), & + NSSHT, NSYM, nSymX, nva(8), nvb(8), pos10, pos20, pos30, posri0, stattemp(mbas), t3key, typ(8,8,8), zrkey +real(kind=wp) :: EScf, valh(nsize) +character(len=7) :: tmpnam(mbas) + +public :: cckey, clopkey, daddr, Escf, fullprint, IADR15, idis, iokey, IPT2, ISCF, ISPIN, jh, JOBIPH, kh, lh, lrectemp, LROOT, & + LSYM, LUINTM, luna1, luna2, luna3, luna4, lunab, lunda1, lunda2, lunpublic, lunt3, mapd1, mapd2, mapd3, mapdri, mapi1, & + mapi2, mapi3, mapiri, maxspace, mbas, NACTEL, NASH, NASHT, NBAS, nBasX, NCONF, NDEL, ndelr, nDelX, NELE3, NFRO, nfror, & + nFroX, NHOLE1, NISH, NISHT, noa, nob, noop, NORB, np, nq, nr, nrectemp, NROOTS, ns, nshow, nsize, NSSH, NSSHT, NSYM, & + nSymX, nva, nvb, pos10, pos20, pos30, posri0, reclen, stattemp, t3key, tmpnam, typ, valh, zrkey + +end module ccsort_global diff -Nru openmolcas-22.02/src/ccsort_util/ccsort_grc0.f openmolcas-22.10/src/ccsort_util/ccsort_grc0.f --- openmolcas-22.02/src/ccsort_util/ccsort_grc0.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ccsort_grc0.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,266 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine ccsort_grc0 (nind,typ,typp,typq,typr,typs,stot, - & poss0,posst,mapd,mapi) -c -c this routine defines mapd and mapi for given intermediat -c -#include "ccsort.fh" - integer nind,typ,typp,typq,typr,typs,stot,poss0,posst -c - integer mapd(0:512,1:6) - integer mapi(1:8,1:8,1:8) -c integer mul(1:8,1:8) - integer dimm(1:4,1:8) -c -c help variables -c - integer sp,sq,sr,ss,spq,spqr - integer nsymq,nsymr - integer poss,i,nhelp1,nhelp2,nhelp3,nhelp4 -c -c* !!!!!!!! def dimm to je tu len terazky !!!! -c - do i=1,nsym - dimm(1,i)=noa(i) - dimm(2,i)=nob(i) - dimm(3,i)=nva(i) - dimm(4,i)=nvb(i) - end do -c -c vanishing mapi files -c - do nhelp1=1,nsym - do nhelp2=1,nsym - do nhelp3=1,nsym - mapi(nhelp3,nhelp2,nhelp1)=0 - end do - end do - end do -c -c To get rid of tiring compiler warning - poss=0 - if (nind.eq.1) then -c -c matrix A(p) -c - i=1 - poss=poss0 - sp=mul(stot,1) -c - nhelp1=dimm(typp,sp) -c -c def mapi - mapi(1,1,1)=i -c -c def possition - mapd(i,1)=poss -c -c def length - mapd(i,2)=nhelp1 -c -c def sym p,q - mapd(i,3)=sp - mapd(i,4)=0 - mapd(i,5)=0 - mapd(i,6)=0 -c - poss=poss+mapd(i,2) - i=i+1 -c - else if (nind.eq.2) then -c -c matrix A(p,q) -c - i=1 - poss=poss0 -c - do 100 sp=1,nsym -c - sq=mul(stot,sp) - if ((typ.eq.1).and.(sp.lt.sq)) then -c Meggie out - goto 100 - end if -c - nhelp1=dimm(typp,sp) - nhelp2=dimm(typq,sq) -c -c def mapi - mapi(sp,1,1)=i -c -c def possition - mapd(i,1)=poss -c -c def length - if ((typ.eq.1).and.(sp.eq.sq)) then - mapd(i,2)=nhelp1*(nhelp1-1)/2 - else - mapd(i,2)=nhelp1*nhelp2 - end if -c -c def sym p,q - mapd(i,3)=sp - mapd(i,4)=sq - mapd(i,5)=0 - mapd(i,6)=0 -c - poss=poss+mapd(i,2) - i=i+1 -c - 100 continue -c - else if (nind.eq.3) then -c -c matrix A(p,q,r) -c - i=1 - poss=poss0 -c - do 200 sp=1,nsym - if (typ.eq.1) then - nsymq=sp - else - nsymq=nsym - end if -c - do 201 sq=1,nsymq - spq=mul(sp,sq) -c - sr=mul(stot,spq) - if ((typ.eq.2).and.(sq.lt.sr)) then -c Meggie out - goto 201 - end if -c - nhelp1=dimm(typp,sp) - nhelp2=dimm(typq,sq) - nhelp3=dimm(typr,sr) -c -c def mapi - mapi(sp,sq,1)=i -c -c def possition - mapd(i,1)=poss -c -c def length - if ((typ.eq.1).and.(sp.eq.sq)) then - mapd(i,2)=nhelp1*(nhelp1-1)*nhelp3/2 - else if ((typ.eq.2).and.(sq.eq.sr)) then - mapd(i,2)=nhelp1*nhelp2*(nhelp2-1)/2 - else - mapd(i,2)=nhelp1*nhelp2*nhelp3 - end if -c -c def sym p,q,r - mapd(i,3)=sp - mapd(i,4)=sq - mapd(i,5)=sr - mapd(i,6)=0 -c - poss=poss+mapd(i,2) - i=i+1 -c - 201 continue - 200 continue -c - else if (nind.eq.4) then -c -c matrix A(p,q,r,s) -c - i=1 - poss=poss0 -c - do 300 sp=1,nsym - if ((typ.eq.1).or.(typ.eq.4)) then - nsymq=sp - else - nsymq=nsym - end if -c - do 301 sq=1,nsymq - spq=mul(sp,sq) - if (typ.eq.2) then - nsymr=sq - else - nsymr=nsym - end if -c - do 302 sr=1,nsymr - spqr=mul(spq,sr) -c - ss=mul(stot,spqr) - if (((typ.eq.3).or.(typ.eq.4)).and.(sr.lt.ss)) then -c Meggie out - goto 302 - end if -c - nhelp1=dimm(typp,sp) - nhelp2=dimm(typq,sq) - nhelp3=dimm(typr,sr) - nhelp4=dimm(typs,ss) -c -c def mapi - mapi(sp,sq,sr)=i -c -c def possition - mapd(i,1)=poss -c -c def length - if ((typ.eq.1).and.(sp.eq.sq)) then - mapd(i,2)=nhelp1*(nhelp2-1)*nhelp3*nhelp4/2 - else if ((typ.eq.2).and.(sq.eq.sr)) then - mapd(i,2)=nhelp1*nhelp2*(nhelp3-1)*nhelp4/2 - else if ((typ.eq.3).and.(sr.eq.ss)) then - mapd(i,2)=nhelp1*nhelp2*nhelp3*(nhelp4-1)/2 - else if (typ.eq.4) then - if ((sp.eq.sq).and.(sr.eq.ss)) then - mapd(i,2)=nhelp1*(nhelp2-1)*nhelp3*(nhelp4-1)/4 - else if (sp.eq.sq) then - mapd(i,2)=nhelp1*(nhelp2-1)*nhelp3*nhelp4/2 - else if (sr.eq.ss) then - mapd(i,2)=nhelp1*nhelp2*nhelp3*(nhelp4-1)/2 - else - mapd(i,2)=nhelp1*nhelp2*nhelp3*nhelp4 - end if - else - mapd(i,2)=nhelp1*nhelp2*nhelp3*nhelp4 - end if -c -c def sym p,q,r,s - mapd(i,3)=sp - mapd(i,4)=sq - mapd(i,5)=sr - mapd(i,6)=ss -c - poss=poss+mapd(i,2) - i=i+1 -c - 302 continue - 301 continue - 300 continue -c - end if - -c - posst=poss -c -c definition of other coll -c - mapd(0,1)=typp - mapd(0,2)=typq - mapd(0,3)=typr - mapd(0,4)=typs - mapd(0,5)=i-1 - mapd(0,6)=typ -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/ccsort_grc0.F90 openmolcas-22.10/src/ccsort_util/ccsort_grc0.F90 --- openmolcas-22.02/src/ccsort_util/ccsort_grc0.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ccsort_grc0.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,237 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ccsort_grc0(nind,typ,typp,typq,typr,typs,stot,pos0,post,mapd,mapi) +! this routine defines mapd and mapi for given intermediat + +use ccsort_global, only: noa, nob, NSYM, nva, nvb +use Symmetry_Info, only: Mul +use Definitions, only: iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: nind, typ, typp, typq, typr, typs, stot, pos0 +integer(kind=iwp), intent(out) :: post, mapd(0:512,6), mapi(8,8,8) +integer(kind=iwp) :: dimm(4,8), i, nhelp1, nhelp2, nhelp3, nhelp4, nsymq, nsymr, pos, sp, spq, spqr, sq, sr, ss + +! !!!!!!!! def dimm to je tu len terazky !!!! + +dimm(1,1:nsym) = noa(1:nsym) +dimm(2,1:nsym) = nob(1:nsym) +dimm(3,1:nsym) = nva(1:nsym) +dimm(4,1:nsym) = nvb(1:nsym) + +! vanishing mapi files + +mapi(1:nsym,1:nsym,1:nsym) = 0 + +! To get rid of tiring compiler warning +i = 1 +pos = pos0 +if (nind == 1) then + + ! matrix A(p) + sp = mul(stot,1) + + nhelp1 = dimm(typp,sp) + + ! def mapi + mapi(1,1,1) = i + + ! def position + mapd(i,1) = pos + + ! def length + mapd(i,2) = nhelp1 + + ! def sym p,q + mapd(i,3) = sp + mapd(i,4) = 0 + mapd(i,5) = 0 + mapd(i,6) = 0 + + pos = pos+mapd(i,2) + i = i+1 + +else if (nind == 2) then + + ! matrix A(p,q) + + do sp=1,nsym + + sq = mul(stot,sp) + ! Meggie out + if ((typ == 1) .and. (sp < sq)) cycle + + nhelp1 = dimm(typp,sp) + nhelp2 = dimm(typq,sq) + + ! def mapi + mapi(sp,1,1) = i + + ! def position + mapd(i,1) = pos + + ! def length + if ((typ == 1) .and. (sp == sq)) then + mapd(i,2) = nhelp1*(nhelp1-1)/2 + else + mapd(i,2) = nhelp1*nhelp2 + end if + + ! def sym p,q + mapd(i,3) = sp + mapd(i,4) = sq + mapd(i,5) = 0 + mapd(i,6) = 0 + + pos = pos+mapd(i,2) + i = i+1 + + end do + +else if (nind == 3) then + + ! matrix A(p,q,r) + + do sp=1,nsym + if (typ == 1) then + nsymq = sp + else + nsymq = nsym + end if + + do sq=1,nsymq + spq = mul(sp,sq) + + sr = mul(stot,spq) + ! Meggie out + if ((typ == 2) .and. (sq < sr)) cycle + + nhelp1 = dimm(typp,sp) + nhelp2 = dimm(typq,sq) + nhelp3 = dimm(typr,sr) + + ! def mapi + mapi(sp,sq,1) = i + + ! def position + mapd(i,1) = pos + + ! def length + if ((typ == 1) .and. (sp == sq)) then + mapd(i,2) = nhelp1*(nhelp1-1)*nhelp3/2 + else if ((typ == 2) .and. (sq == sr)) then + mapd(i,2) = nhelp1*nhelp2*(nhelp2-1)/2 + else + mapd(i,2) = nhelp1*nhelp2*nhelp3 + end if + + ! def sym p,q,r + mapd(i,3) = sp + mapd(i,4) = sq + mapd(i,5) = sr + mapd(i,6) = 0 + + pos = pos+mapd(i,2) + i = i+1 + + end do + end do + +else if (nind == 4) then + + ! matrix A(p,q,r,s) + + do sp=1,nsym + if ((typ == 1) .or. (typ == 4)) then + nsymq = sp + else + nsymq = nsym + end if + + do sq=1,nsymq + spq = mul(sp,sq) + if (typ == 2) then + nsymr = sq + else + nsymr = nsym + end if + + do sr=1,nsymr + spqr = mul(spq,sr) + + ss = mul(stot,spqr) + ! Meggie out + if (((typ == 3) .or. (typ == 4)) .and. (sr < ss)) cycle + + nhelp1 = dimm(typp,sp) + nhelp2 = dimm(typq,sq) + nhelp3 = dimm(typr,sr) + nhelp4 = dimm(typs,ss) + + ! def mapi + mapi(sp,sq,sr) = i + + ! def position + mapd(i,1) = pos + + ! def length + if ((typ == 1) .and. (sp == sq)) then + mapd(i,2) = nhelp1*(nhelp2-1)*nhelp3*nhelp4/2 + else if ((typ == 2) .and. (sq == sr)) then + mapd(i,2) = nhelp1*nhelp2*(nhelp3-1)*nhelp4/2 + else if ((typ == 3) .and. (sr == ss)) then + mapd(i,2) = nhelp1*nhelp2*nhelp3*(nhelp4-1)/2 + else if (typ == 4) then + if ((sp == sq) .and. (sr == ss)) then + mapd(i,2) = nhelp1*(nhelp2-1)*nhelp3*(nhelp4-1)/4 + else if (sp == sq) then + mapd(i,2) = nhelp1*(nhelp2-1)*nhelp3*nhelp4/2 + else if (sr == ss) then + mapd(i,2) = nhelp1*nhelp2*nhelp3*(nhelp4-1)/2 + else + mapd(i,2) = nhelp1*nhelp2*nhelp3*nhelp4 + end if + else + mapd(i,2) = nhelp1*nhelp2*nhelp3*nhelp4 + end if + + ! def sym p,q,r,s + mapd(i,3) = sp + mapd(i,4) = sq + mapd(i,5) = sr + mapd(i,6) = ss + + pos = pos+mapd(i,2) + i = i+1 + + end do + end do + end do + +end if + +post = pos + +! definition of other coll + +mapd(0,1) = typp +mapd(0,2) = typq +mapd(0,3) = typr +mapd(0,4) = typs +mapd(0,5) = i-1 +mapd(0,6) = typ + +return + +end subroutine ccsort_grc0 diff -Nru openmolcas-22.02/src/ccsort_util/ccsort_hellopn.f openmolcas-22.10/src/ccsort_util/ccsort_hellopn.f --- openmolcas-22.02/src/ccsort_util/ccsort_hellopn.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ccsort_hellopn.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,12 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine CCSORT_HelloPN - End diff -Nru openmolcas-22.02/src/ccsort_util/ccsort_mv0zero.f openmolcas-22.10/src/ccsort_util/ccsort_mv0zero.f --- openmolcas-22.02/src/ccsort_util/ccsort_mv0zero.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ccsort_mv0zero.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE ccsort_mv0zero - & (DD,LENGTH,MAT) -C - INTEGER DD - INTEGER LENGTH - real*8 MAT(1:DD) - INTEGER INIT - real*8 ZERO -C - DATA ZERO/0.0D+00/ -C -C ...loop over all elements -C - DO 10 INIT=1,LENGTH - MAT(INIT) = ZERO - 10 CONTINUE -C - RETURN - END diff -Nru openmolcas-22.02/src/ccsort_util/ccsort_rea.f openmolcas-22.10/src/ccsort_util/ccsort_rea.f --- openmolcas-22.02/src/ccsort_util/ccsort_rea.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ccsort_rea.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,27 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine ccsort_rea (lun,length,vector) -c -c this routine read length-R8 numbers from opened unformatted file -c with number lun form the given possition as one record -c -c lun - Logical unit number of file, where mediate is stored (Input) -c length - # of R8 numbers to be read (Input) -c vector - space, where numbers are stored after reading (Output) - -c - integer lun,length,i - real*8 vector(1:length) -c - read (lun) (vector(i),i=1,length) -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/ccsort_t3grc0.f openmolcas-22.10/src/ccsort_util/ccsort_t3grc0.f --- openmolcas-22.02/src/ccsort_util/ccsort_t3grc0.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ccsort_t3grc0.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,356 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine ccsort_t3grc0 (nind,typ,typp,typq,typr,typs,stot, - & poss0,posst,mapd,mapi) -c -c N.B. This routine is in principle copy of those in T3, -c but some changes was done: -c 1) mmul is substituted by mul -c 2) dimm is added, since using of ccsd1.com is inpossible -c 3) ccsd1.com is replaced by ccsort.fh -c -c nind - number of indexes (I) -c typ - typ of mediate (I) -c typp - typ of index p (I) -c typq - typ of index q (I) -c typr - typ of index r (I) -c typs - typ of index s (I) -c stot - overall symetry of the mediate (I) -c poss0 - initil possition of mediate (I) -c posst - final possition of the mediate (O) -c mapd - direct map of the mediate (O) -c mapi - inverse map of the mediate (O) -c -c this routine defines mapd and mapi for given intermediat -c it can done exactly the same maps like grc0 in CCSD -c plus additional types of mediates are introduced: -c type meaning -c 5 p>q>r,s ; also p>q>r -c 6 p,q>r>s -c 7 p>=q,r,s ; also p>=q,r; p>=q -c 8 p,q>=r,s ; also p,q>=s -c 9 p,q,q>=s -c 10 p>=q,r>=s -c 11 p>=q>=r,s ; also p>=q>=r -c 12 p,q>=r>=s -c -c currently, these new types are implemented only for nind=3 -c -c $N.B. (this routine cannot run with +OP2) -c N.B. this routine do not test stupidities -c -c - integer nind,typ,typp,typq,typr,typs,stot,poss0,posst -c -c@ include 'ccsd1.com' -#include "ccsort.fh" - integer mapd(0:512,1:6) - integer mapi(1:8,1:8,1:8) - integer dimm(1:5,1:8) -c -c help variables -c - integer sp,sq,sr,ss,spq,spqr - integer nsymq,nsymr - integer poss,i,nhelp1,nhelp2,nhelp3,nhelp4 - integer rsk1,rsk2 -c -c@ !!!!!!!! def dimm to je tu len terazky, lebo nemozeme pouzivat ccsd1.com !!!! -c -c Tutok musim cosi inicializovat - ss=0 - poss=0 - rsk1=0 - rsk2=0 - do i=1,nsym - dimm(1,i)=noa(i) - dimm(2,i)=nob(i) - dimm(3,i)=nva(i) - dimm(4,i)=nvb(i) - dimm(5,i)=nva(i)+noa(i) - end do -c -c@@ -c vanishing mapi files -c - do nhelp1=1,nsym - do nhelp2=1,nsym - do nhelp3=1,nsym - mapi(nhelp3,nhelp2,nhelp1)=0 - end do - end do - end do -c - if (nind.eq.1) then -c -c matrix A(p) -c - i=1 - poss=poss0 - sp=mul(stot,1) -c - nhelp1=dimm(typp,sp) -c -c def mapi - mapi(1,1,1)=i -c -c def possition - mapd(i,1)=poss -c -c def length - mapd(i,2)=nhelp1 -c -c def sym p,q - mapd(i,3)=sp - mapd(i,4)=0 - mapd(i,5)=0 - mapd(i,6)=0 -c - poss=poss+mapd(i,2) - i=i+1 -c - else if (nind.eq.2) then -c -c matrix A(p,q) -c - i=1 - poss=poss0 -c - do 100 sp=1,nsym -c - sq=mul(stot,sp) - if ((typ.eq.1).and.(sp.lt.sq)) then -c Meggie out - goto 100 - end if -c - nhelp1=dimm(typp,sp) - nhelp2=dimm(typq,sq) -c -c def mapi - mapi(sp,1,1)=i -c -c def possition - mapd(i,1)=poss -c -c def length - if ((typ.eq.1).and.(sp.eq.sq)) then - mapd(i,2)=nhelp1*(nhelp1-1)/2 - else - mapd(i,2)=nhelp1*nhelp2 - end if -c -c def sym p,q - mapd(i,3)=sp - mapd(i,4)=sq - mapd(i,5)=0 - mapd(i,6)=0 -c - poss=poss+mapd(i,2) - i=i+1 -c - 100 continue -c - else if (nind.eq.3) then -c -c matrix A(p,q,r) -c -c def reucion sumations keys : rsk1 for pq, rsk2 for qr -c - if (typ.eq.0) then - rsk1=0 - rsk2=0 - else if (typ.eq.1) then - rsk1=1 - rsk2=0 - else if (typ.eq.2) then - rsk1=0 - rsk2=1 - else if (typ.eq.5) then - rsk1=1 - rsk2=1 - else if (typ.eq.7) then - rsk1=1 - rsk2=0 - else if (typ.eq.8) then - rsk1=0 - rsk2=1 - else if (typ.eq.11) then - rsk1=1 - rsk2=1 - end if -c - i=1 - poss=poss0 -c - do 200 sp=1,nsym - if (rsk1.eq.1) then - nsymq=sp - else - nsymq=nsym - end if -c - do 201 sq=1,nsymq - spq=mul(sp,sq) -c - sr=mul(stot,spq) - if ((rsk2.eq.1).and.(sq.lt.sr)) then -c Meggie out - goto 201 - end if -c - nhelp1=dimm(typp,sp) - nhelp2=dimm(typq,sq) - nhelp3=dimm(typr,sr) -c -c def mapi - mapi(sp,sq,1)=i -c -c def possition - mapd(i,1)=poss -c -c def length - if ((typ.eq.1).and.(sp.eq.sq)) then - mapd(i,2)=nhelp1*(nhelp1-1)*nhelp3/2 - else if ((typ.eq.2).and.(sq.eq.sr)) then - mapd(i,2)=nhelp1*nhelp2*(nhelp2-1)/2 - else if (typ.eq.5) then - if (sp.eq.sr) then - mapd(i,2)=nhelp1*(nhelp1-1)*(nhelp1-2)/6 - else if (sp.eq.sq) then - mapd(i,2)=nhelp1*(nhelp1-1)*nhelp3/2 - else if (sq.eq.sr) then - mapd(i,2)=nhelp1*nhelp2*(nhelp2-1)/2 - else - mapd(i,2)=nhelp1*nhelp2*nhelp3 - end if - else if ((typ.eq.7).and.(sp.eq.sq)) then - mapd(i,2)=nhelp1*(nhelp1+1)*nhelp3/2 - else if ((typ.eq.8).and.(sq.eq.sr)) then - mapd(i,2)=nhelp1*nhelp2*(nhelp2+1)/2 - else if (typ.eq.11) then - if (sp.eq.ss) then - mapd(i,2)=nhelp1*(nhelp1+1)*(nhelp1+2)/6 - else if (sp.eq.sq) then - mapd(i,2)=nhelp1*(nhelp1+1)*nhelp3/2 - else if (sq.eq.sr) then - mapd(i,2)=nhelp1*nhelp2*(nhelp2+1)/2 - else - mapd(i,2)=nhelp1*nhelp2*nhelp3 - end if - else - mapd(i,2)=nhelp1*nhelp2*nhelp3 - end if -c -c def sym p,q,r - mapd(i,3)=sp - mapd(i,4)=sq - mapd(i,5)=sr - mapd(i,6)=0 -c - poss=poss+mapd(i,2) - i=i+1 -c - 201 continue - 200 continue -c - else if (nind.eq.4) then -c -c matrix A(p,q,r,s) -c - i=1 - poss=poss0 -c - do 300 sp=1,nsym - if ((typ.eq.1).or.(typ.eq.4)) then - nsymq=sp - else - nsymq=nsym - end if -c - do 301 sq=1,nsymq - spq=mul(sp,sq) - if (typ.eq.2) then - nsymr=sq - else - nsymr=nsym - end if -c - do 302 sr=1,nsymr - spqr=mul(spq,sr) -c - ss=mul(stot,spqr) - if (((typ.eq.3).or.(typ.eq.4)).and.(sr.lt.ss)) then -c Meggie out - goto 302 - end if -c - nhelp1=dimm(typp,sp) - nhelp2=dimm(typq,sq) - nhelp3=dimm(typr,sr) - nhelp4=dimm(typs,ss) -c -c def mapi - mapi(sp,sq,sr)=i -c -c def possition - mapd(i,1)=poss -c -c def length - if ((typ.eq.1).and.(sp.eq.sq)) then - mapd(i,2)=nhelp1*(nhelp2-1)*nhelp3*nhelp4/2 - else if ((typ.eq.2).and.(sq.eq.sr)) then - mapd(i,2)=nhelp1*nhelp2*(nhelp3-1)*nhelp4/2 - else if ((typ.eq.3).and.(sr.eq.ss)) then - mapd(i,2)=nhelp1*nhelp2*nhelp3*(nhelp4-1)/2 - else if (typ.eq.4) then - if ((sp.eq.sq).and.(sr.eq.ss)) then - mapd(i,2)=nhelp1*(nhelp2-1)*nhelp3*(nhelp4-1)/4 - else if (sp.eq.sq) then - mapd(i,2)=nhelp1*(nhelp2-1)*nhelp3*nhelp4/2 - else if (sr.eq.ss) then - mapd(i,2)=nhelp1*nhelp2*nhelp3*(nhelp4-1)/2 - else - mapd(i,2)=nhelp1*nhelp2*nhelp3*nhelp4 - end if - else - mapd(i,2)=nhelp1*nhelp2*nhelp3*nhelp4 - end if -c -c def sym p,q,r,s - mapd(i,3)=sp - mapd(i,4)=sq - mapd(i,5)=sr - mapd(i,6)=ss -c - poss=poss+mapd(i,2) - i=i+1 -c - 302 continue - 301 continue - 300 continue -c - end if - -c - posst=poss -c -c definition of other coll -c - mapd(0,1)=typp - mapd(0,2)=typq - mapd(0,3)=typr - mapd(0,4)=typs - mapd(0,5)=i-1 - mapd(0,6)=typ -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/ccsort_t3grc0.F90 openmolcas-22.10/src/ccsort_util/ccsort_t3grc0.F90 --- openmolcas-22.02/src/ccsort_util/ccsort_t3grc0.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ccsort_t3grc0.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,324 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ccsort_t3grc0(nind,typ,typp,typq,typr,typs,stot,pos0,post,mapd,mapi) +! N.B. This routine is in principle copy of those in T3, +! but some changes were done: +! 1) mmul is substituted by mul +! 2) dimm is added, since using of ccsd1.com is impossible +! 3) ccsd1.com is replaced by ccsort_global +! +! nind - number of indices (I) +! typ - typ of mediate (I) +! typp - typ of index p (I) +! typq - typ of index q (I) +! typr - typ of index r (I) +! typs - typ of index s (I) +! stot - overall symmetry of the mediate (I) +! pos0 - initial position of mediate (I) +! post - final position of the mediate (O) +! mapd - direct map of the mediate (O) +! mapi - inverse map of the mediate (O) +! +! this routine defines mapd and mapi for given intermediate +! it can done exactly the same maps like grc0 in CCSD +! plus additional types of mediates are introduced: +! type meaning +! 5 p>q>r,s ; also p>q>r +! 6 p,q>r>s +! 7 p>=q,r,s ; also p>=q,r; p>=q +! 8 p,q>=r,s ; also p,q>=s +! 9 p,q,q>=s +! 10 p>=q,r>=s +! 11 p>=q>=r,s ; also p>=q>=r +! 12 p,q>=r>=s +! +! currently, these new types are implemented only for nind=3 +! +! N.B. (this routine cannot run with +OP2) +! N.B. this routine does not test stupidities + +use ccsort_global, only: noa, nob, NSYM, nva, nvb +use Symmetry_Info, only: Mul +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: nind, typ, typp, typq, typr, typs, stot, pos0 +integer(kind=iwp), intent(out) :: post, mapd(0:512,6), mapi(8,8,8) +integer(kind=iwp) :: dimm(5,8), i, nhelp1, nhelp2, nhelp3, nhelp4, nsymq, nsymr, pos, rsk1, rsk2, sp, spq, spqr, sq, sr, ss + +! !!!!!!!! def dimm to je tu len terazky, lebo nemozeme pouzivat ccsd1.com !!!! + +! Tutok musim cosi inicializovat +ss = 0 +pos = 0 +rsk1 = 0 +rsk2 = 0 +dimm(1,1:nsym) = noa(1:nsym) +dimm(2,1:nsym) = nob(1:nsym) +dimm(3,1:nsym) = nva(1:nsym) +dimm(4,1:nsym) = nvb(1:nsym) +dimm(5,1:nsym) = nva(1:nsym)+noa(1:nsym) + +! vanishing mapi files + +mapi(1:nsym,1:nsym,1:nsym) = 0 + +i = 1 +pos = pos0 +if (nind == 1) then + + ! matrix A(p) + + sp = mul(stot,1) + + nhelp1 = dimm(typp,sp) + + ! def mapi + mapi(1,1,1) = i + + ! def position + mapd(i,1) = pos + + ! def length + mapd(i,2) = nhelp1 + + ! def sym p,q + mapd(i,3) = sp + mapd(i,4) = 0 + mapd(i,5) = 0 + mapd(i,6) = 0 + + pos = pos+mapd(i,2) + i = i+1 + +else if (nind == 2) then + + ! matrix A(p,q) + + do sp=1,nsym + + sq = mul(stot,sp) + ! Meggie out + if ((typ == 1) .and. (sp < sq)) cycle + + nhelp1 = dimm(typp,sp) + nhelp2 = dimm(typq,sq) + + ! def mapi + mapi(sp,1,1) = i + + ! def position + mapd(i,1) = pos + + ! def length + if ((typ == 1) .and. (sp == sq)) then + mapd(i,2) = nhelp1*(nhelp1-1)/2 + else + mapd(i,2) = nhelp1*nhelp2 + end if + + ! def sym p,q + mapd(i,3) = sp + mapd(i,4) = sq + mapd(i,5) = 0 + mapd(i,6) = 0 + + pos = pos+mapd(i,2) + i = i+1 + + end do + +else if (nind == 3) then + + ! matrix A(p,q,r) + + ! def reucion summation keys : rsk1 for pq, rsk2 for qr + + if (typ == 0) then + rsk1 = 0 + rsk2 = 0 + else if (typ == 1) then + rsk1 = 1 + rsk2 = 0 + else if (typ == 2) then + rsk1 = 0 + rsk2 = 1 + else if (typ == 5) then + rsk1 = 1 + rsk2 = 1 + else if (typ == 7) then + rsk1 = 1 + rsk2 = 0 + else if (typ == 8) then + rsk1 = 0 + rsk2 = 1 + else if (typ == 11) then + rsk1 = 1 + rsk2 = 1 + end if + + do sp=1,nsym + if (rsk1 == 1) then + nsymq = sp + else + nsymq = nsym + end if + + do sq=1,nsymq + spq = mul(sp,sq) + + sr = mul(stot,spq) + ! Meggie out + if ((rsk2 == 1) .and. (sq < sr)) cycle + + nhelp1 = dimm(typp,sp) + nhelp2 = dimm(typq,sq) + nhelp3 = dimm(typr,sr) + + ! def mapi + mapi(sp,sq,1) = i + + ! def position + mapd(i,1) = pos + + ! def length + if ((typ == 1) .and. (sp == sq)) then + mapd(i,2) = nhelp1*(nhelp1-1)*nhelp3/2 + else if ((typ == 2) .and. (sq == sr)) then + mapd(i,2) = nhelp1*nhelp2*(nhelp2-1)/2 + else if (typ == 5) then + if (sp == sr) then + mapd(i,2) = nhelp1*(nhelp1-1)*(nhelp1-2)/6 + else if (sp == sq) then + mapd(i,2) = nhelp1*(nhelp1-1)*nhelp3/2 + else if (sq == sr) then + mapd(i,2) = nhelp1*nhelp2*(nhelp2-1)/2 + else + mapd(i,2) = nhelp1*nhelp2*nhelp3 + end if + else if ((typ == 7) .and. (sp == sq)) then + mapd(i,2) = nhelp1*(nhelp1+1)*nhelp3/2 + else if ((typ == 8) .and. (sq == sr)) then + mapd(i,2) = nhelp1*nhelp2*(nhelp2+1)/2 + else if (typ == 11) then + if (sp == ss) then + mapd(i,2) = nhelp1*(nhelp1+1)*(nhelp1+2)/6 + else if (sp == sq) then + mapd(i,2) = nhelp1*(nhelp1+1)*nhelp3/2 + else if (sq == sr) then + mapd(i,2) = nhelp1*nhelp2*(nhelp2+1)/2 + else + mapd(i,2) = nhelp1*nhelp2*nhelp3 + end if + else + mapd(i,2) = nhelp1*nhelp2*nhelp3 + end if + + ! def sym p,q,r + mapd(i,3) = sp + mapd(i,4) = sq + mapd(i,5) = sr + mapd(i,6) = 0 + + pos = pos+mapd(i,2) + i = i+1 + + end do + end do + +else if (nind == 4) then + + ! matrix A(p,q,r,s) + + do sp=1,nsym + if ((typ == 1) .or. (typ == 4)) then + nsymq = sp + else + nsymq = nsym + end if + + do sq=1,nsymq + spq = mul(sp,sq) + if (typ == 2) then + nsymr = sq + else + nsymr = nsym + end if + + do sr=1,nsymr + spqr = mul(spq,sr) + + ss = mul(stot,spqr) + ! Meggie out + if (((typ == 3) .or. (typ == 4)) .and. (sr < ss)) cycle + + nhelp1 = dimm(typp,sp) + nhelp2 = dimm(typq,sq) + nhelp3 = dimm(typr,sr) + nhelp4 = dimm(typs,ss) + + ! def mapi + mapi(sp,sq,sr) = i + + ! def position + mapd(i,1) = pos + + ! def length + if ((typ == 1) .and. (sp == sq)) then + mapd(i,2) = nhelp1*(nhelp2-1)*nhelp3*nhelp4/2 + else if ((typ == 2) .and. (sq == sr)) then + mapd(i,2) = nhelp1*nhelp2*(nhelp3-1)*nhelp4/2 + else if ((typ == 3) .and. (sr == ss)) then + mapd(i,2) = nhelp1*nhelp2*nhelp3*(nhelp4-1)/2 + else if (typ == 4) then + if ((sp == sq) .and. (sr == ss)) then + mapd(i,2) = nhelp1*(nhelp2-1)*nhelp3*(nhelp4-1)/4 + else if (sp == sq) then + mapd(i,2) = nhelp1*(nhelp2-1)*nhelp3*nhelp4/2 + else if (sr == ss) then + mapd(i,2) = nhelp1*nhelp2*nhelp3*(nhelp4-1)/2 + else + mapd(i,2) = nhelp1*nhelp2*nhelp3*nhelp4 + end if + else + mapd(i,2) = nhelp1*nhelp2*nhelp3*nhelp4 + end if + + ! def sym p,q,r,s + mapd(i,3) = sp + mapd(i,4) = sq + mapd(i,5) = sr + mapd(i,6) = ss + + pos = pos+mapd(i,2) + i = i+1 + + end do + end do + end do + +end if + +post = pos + +! definition of other coll + +mapd(0,1) = typp +mapd(0,2) = typq +mapd(0,3) = typr +mapd(0,4) = typs +mapd(0,5) = i-1 +mapd(0,6) = typ + +return + +end subroutine ccsort_t3grc0 diff -Nru openmolcas-22.02/src/ccsort_util/ccsort_wri.f openmolcas-22.10/src/ccsort_util/ccsort_wri.f --- openmolcas-22.02/src/ccsort_util/ccsort_wri.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ccsort_wri.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,27 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine ccsort_wri (lun,length,vector) -c -c this routine write length-R8 numbers to opened unformatted file -c with number lun at the given possition as one record -c -c lun - Logical unit number of file, where mediate will be stored (Input) -c length - # of R8 numbers to be written (Input) -c vector - space, where numbers are stored (Input) - -c - integer lun,length - real*8 vector(1:length) -c - write (lun) vector -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/ccsort_wrtmap.f openmolcas-22.10/src/ccsort_util/ccsort_wrtmap.f --- openmolcas-22.02/src/ccsort_util/ccsort_wrtmap.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ccsort_wrtmap.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine ccsort_wrtmap (lun,mapd,mapi,rc) -c -c this routine write required mapd and mapi to opened unformatted file -c with number lun -c -c lun - Logical unit number of file, where mediate will be stored (Input) -c mapd - direct map matrix corresponding to given mediate (Input) -c mapi - inverse map matrix corresponding to given mediate (Input) -c rc - return (error) code (Output) -c - integer lun,rc - integer mapd(0:512,1:6) - integer mapi(1:8,1:8,1:8) -c - rc=0 -c -c1 write mapd -c - write (lun) mapd,mapi -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/ccsort_wrtmediate.f openmolcas-22.10/src/ccsort_util/ccsort_wrtmediate.f --- openmolcas-22.02/src/ccsort_util/ccsort_wrtmediate.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ccsort_wrtmediate.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine ccsort_wrtmediate (wrk,wrksize, - & lun,mapd,mapi,rc) -c -c this routine write required mediate to opened unformatted file -c with number lun -c it also store mapd and mapi of the given mediade -c -c lun - Logical unit number of file, where mediate will be stored (Input) -c mapd - direct map matrix corresponding to given mediate (Input) -c mapi - inverse map matrix corresponding to given mediate (Input) -c rc - return (error) code (Output) -c -c N.B. -c all mediates are storred as follows -c 1 - mapd, mapi -c 2 - one record with complete mediate -c -#include "wrk.fh" - integer lun,rc - integer mapd(0:512,1:6) - integer mapi(1:8,1:8,1:8) -c -c help variables -c - integer im,length,poss0 -c - rc=0 -c -c1 write mapd -c - write (lun) mapd,mapi -c -c2 calculate overall length -c - length=0 -c - do 100 im=1,mapd(0,5) - length=length+mapd(im,2) - 100 continue -c -c write mediate in one block -c - if (length.eq.0) then -c RC=1 : there is nothing to write, length of mediate is 0 - rc=1 - return - end if -c - poss0=mapd(1,1) - call ccsort_wri (lun,length,wrk(poss0)) -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/chkinp_ccsort.f openmolcas-22.10/src/ccsort_util/chkinp_ccsort.f --- openmolcas-22.02/src/ccsort_util/chkinp_ccsort.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/chkinp_ccsort.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine ChkInp_ccsort -************************************************************************ -* * -* purpose: * -* Check input for consistency * -* * -************************************************************************ - - Implicit Real*8 (A-H,O-Z) - -#include "ccsort.fh" -#include "motra.fh" -* -c -c Just print warning... - If ( IPT2.eq.0 ) then - Write(6,*) - Write(6,*) ' !!!!!WARNING!!!!!' - Write(6,*) - Write(6,*) ' *** input error ***' - Write(6,*) ' The JOBIPH file does not include '// - & 'canonical orbitals' - Write(6,*) - Write(6,*) ' !!!!!WARNING!!!!!' - Write(6,*) -c Call Quit_OnUserError() - End If -c - If ( NCONF.ne.1 ) then - Write(6,*) - Write(6,*) ' *** input error ***' - Write(6,*) ' The JOBIPH file does not include '// - & 'a RHF or ROHF wave function' - Write(6,*) - Call Quit_OnUserError() - End If -* - iErr = 0 - If ( nSym.ne.nSymX ) iErr = 1 - Do iSym = 1,nSym - If ( nBas(iSym).ne.nBasX(iSym) ) iErr = 1 - End Do - If ( iErr.ne.0 ) then - Write(6,*) - Write(6,*) ' *** input error ***' - Write(6,*) ' The JOBIPH and the TRAONE files '// - & 'are inconsistent' - Write(6,*) - Call Quit_OnUserError() - End If -* - Return - End diff -Nru openmolcas-22.02/src/ccsort_util/chkinp_ccsort.F90 openmolcas-22.10/src/ccsort_util/chkinp_ccsort.F90 --- openmolcas-22.02/src/ccsort_util/chkinp_ccsort.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/chkinp_ccsort.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,65 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ChkInp_ccsort() +!*********************************************************************** +! * +! purpose: * +! Check input for consistency * +! * +!*********************************************************************** + +use ccsort_global, only: IPT2, NBAS, nBasX, NCONF, NSYM, nSymX +use Definitions, only: iwp, u6 + +implicit none +integer(kind=iwp) :: iErr, iSym + +! Just print warning... +if (IPT2 == 0) then + write(u6,*) + write(u6,*) ' !!!!!WARNING!!!!!' + write(u6,*) + write(u6,*) ' *** input error ***' + write(u6,*) ' The JOBIPH file does not include canonical orbitals' + write(u6,*) + write(u6,*) ' !!!!!WARNING!!!!!' + write(u6,*) + !call Quit_OnUserError() +end if + +if (NCONF /= 1) then + write(u6,*) + write(u6,*) ' *** input error ***' + write(u6,*) ' The JOBIPH file does not include a RHF or ROHF wave function' + write(u6,*) + call Quit_OnUserError() +end if + +iErr = 0 +if (nSym /= nSymX) iErr = 1 +do iSym=1,nSym + if (nBas(iSym) /= nBasX(iSym)) then + iErr = 1 + exit + end if +end do +if (iErr /= 0) then + write(u6,*) + write(u6,*) ' *** input error ***' + write(u6,*) ' The JOBIPH and the TRAONE files are inconsistent' + write(u6,*) + call Quit_OnUserError() +end if + +return + +end subroutine ChkInp_ccsort diff -Nru openmolcas-22.02/src/ccsort_util/CMakeLists.txt openmolcas-22.10/src/ccsort_util/CMakeLists.txt --- openmolcas-22.02/src/ccsort_util/CMakeLists.txt 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -9,4 +9,74 @@ # LICENSE or in . * #*********************************************************************** +set (sources + abpack.F90 + action_ccsort.F90 + addintabc1.F90 + addintab.F90 + addinta.F90 + addpqij.F90 + ampack.F90 + ccsort_global.F90 + ccsort_grc0.F90 + ccsort_t3grc0.F90 + chkinp_ccsort.F90 + daopen.F90 + daread.F90 + dawri.F90 + dawrite.F90 + dawrtmap.F90 + dawrtmediate.F90 + deflength.F90 + deft3par.F90 + esb_ic_1.F90 + esb_ic_2.F90 + esb_ic_3.F90 + expandfok.F90 + expmpq.F90 + exppqij.F90 + exppsb.F90 + fokupdate1.F90 + fokupdate2.F90 + initintabc1.F90 + inittemp.F90 + initwrk.F90 + ireorg1.F90 + ireorg2.F90 + ireorg3.F90 + ireorg.F90 + mkabpqmap.F90 + mkaddress.F90 + mkampq.F90 + mkampqmap.F90 + mkintsta.F90 + mkmapampq.F90 + mkmappqij.F90 + mktempanam.F90 + mod1.F90 + mod2.F90 + mreorg1.F90 + mreorg.F90 + prinppn.F90 + rdinppn.F90 + rdtraone.F90 + reorg.F90 + t3intpck1.F90 + t3intpck2.F90 + t3reorg.F90 + unpackk.F90 + unpackk_ic_1.F90 + unpackk_ic_2.F90 + unpackk_ic_3.F90 + unpackk_pck.F90 + unpackk_zr.F90 + vf.F90 + zasun.F90 + zasun_pck.F90 + zasun_zr.F90 +) + +# Source files defining modules that should be available to other *_util directories +set (modfile_list "") + include (${PROJECT_SOURCE_DIR}/cmake/util_template.cmake) diff -Nru openmolcas-22.02/src/ccsort_util/daopen.f openmolcas-22.10/src/ccsort_util/daopen.f --- openmolcas-22.02/src/ccsort_util/daopen.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/daopen.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine daopen (name,lun,recl,nrec) -c -c this routine open direct acces file -c -c name - name of the file A8 (I) -c lun - logical unit number (I) -c recl - record length in R8 (I) -c nrec - number of records (if needed) (I) -c - integer lun,recl,nrec - character*8 name -c -c help variables -c - integer recln,f_iostat - logical is_error -c -#ifdef _DECAXP_ - recln=recl*2 -#else - recln=recl*8 -#endif -c - call molcas_open_ext2(lun,name,'direct','unformatted', - & f_iostat,.true.,recln,'unknown',is_error) -c open (unit=lun,file=name,form='unformatted',access='direct', -c & recl=recln) -c - return -c Avoid unused argument warnings - if (.false.) call Unused_integer(nrec) - end diff -Nru openmolcas-22.02/src/ccsort_util/daopen.F90 openmolcas-22.10/src/ccsort_util/daopen.F90 --- openmolcas-22.02/src/ccsort_util/daopen.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/daopen.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,38 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine daopen(fname,lun,reclen) +! this routine opens direct access file +! +! fname - name of the file A8 (I) +! lun - logical unit number (I) +! reclen- record length in R8 (I) + +use Definitions, only: iwp + +implicit none +character(len=8), intent(in) :: fname +integer(kind=iwp), intent(in) :: lun, reclen +integer(kind=iwp) :: f_iostat, recln +logical(kind=iwp) :: is_error + +#ifdef _DECAXP_ +recln = reclen*2 +#else +recln = reclen*8 +#endif + +call molcas_open_ext2(lun,fname,'direct','unformatted',f_iostat,.true.,recln,'unknown',is_error) +!open(unit=lun,file=fname,form='unformatted',access='direct',recl=recln) + +return + +end subroutine daopen diff -Nru openmolcas-22.02/src/ccsort_util/daread.f openmolcas-22.10/src/ccsort_util/daread.f --- openmolcas-22.02/src/ccsort_util/daread.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/daread.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine daread (lun,irec0,vector,length,recl) -c -c this routine read vector with required length from -c opened direct access file lun starting from record number -c irec0 -c lun - logical unit of direct access file (I) -c irec0 - initial recored number (I) -c vector- vector (O) -c length- number of R8 data to be readed (I) -c recl - length of one record in lun in R8 (I) -c - real*8 vector(1:length) - integer lun,irec0,length,recl -c -c help variables -c - integer ilow,iup,need,irec,i -c - if (length.eq.0) then - return - end if -c -c* def need,ilow,iup,irec -c - need=length - ilow=1 - iup=0 - irec=irec0 -c - 1 if (recl.ge.need) then - iup=iup+need - else - iup=iup+recl - end if -c - read (lun,rec=irec) (vector(i),i=ilow,iup) -c - need=need-(iup-ilow+1) - irec=irec+1 - ilow=ilow+recl -c - if (need.gt.0) goto 1 -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/daread.F90 openmolcas-22.10/src/ccsort_util/daread.F90 --- openmolcas-22.02/src/ccsort_util/daread.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/daread.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,56 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine daread(lun,irec0,vector,length,reclen) +! this routine reads vector with required length from +! open direct access file lun starting from record number +! irec0 +! lun - logical unit of direct access file (I) +! irec0 - initial record number (I) +! vector- vector (O) +! length- number of R8 data to be read (I) +! reclen- length of one record in lun in R8 (I) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: lun, irec0, length, reclen +real(kind=wp), intent(out) :: vector(length) +integer(kind=iwp) :: ilow, irec, iup, need + +if (length == 0) return + +! def need,ilow,iup,irec + +need = length +ilow = 1 +iup = 0 +irec = irec0 + +do + if (reclen >= need) then + iup = iup+need + else + iup = iup+reclen + end if + + read(lun,rec=irec) vector(ilow:iup) + + need = need-(iup-ilow+1) + irec = irec+1 + ilow = ilow+reclen + + if (need <= 0) exit +end do + +return + +end subroutine daread diff -Nru openmolcas-22.02/src/ccsort_util/dawri.f openmolcas-22.10/src/ccsort_util/dawri.f --- openmolcas-22.02/src/ccsort_util/dawri.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/dawri.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine dawri (lun,length,vector) -c -c this routine write length-R8 numbers to opened unformatted file -c with number lun at the given possition as one record -c -c lun - Logical unit number of file, where mediate will be stored (Input) -c length - # of R8 numbers to be written (Input) -c vector - space, where numbers are stored (Input) - -c -#include "files_ccsd.fh" -#include "reorg.fh" - -#include "SysDef.fh" -c - integer lun,length - real*8 vector(1:length) -c - if (iokey.eq.1) then -c Fortran IO - write (lun) vector -c - else -c MOLCAS IO - call ddafile (lun,1,vector,length,daddr(lun)) - end if -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/dawri.F90 openmolcas-22.10/src/ccsort_util/dawri.F90 --- openmolcas-22.02/src/ccsort_util/dawri.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/dawri.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,40 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine dawri(lun,length,vector) +! this routine writes length-R8 numbers to open unformatted file +! with number lun at the given position as one record +! +! lun - Logical unit number of file, where mediate will be stored (Input) +! length - # of R8 numbers to be written (Input) +! vector - space, where numbers are stored (Input) + +use ccsort_global, only: daddr, iokey +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: lun, length +real(kind=wp), intent(_IN_) :: vector(length) + +if (iokey == 1) then + ! Fortran IO + write(lun) vector + +else + ! MOLCAS IO + call ddafile(lun,1,vector,length,daddr(lun)) +end if + +return + +end subroutine dawri diff -Nru openmolcas-22.02/src/ccsort_util/dawrite.f openmolcas-22.10/src/ccsort_util/dawrite.f --- openmolcas-22.02/src/ccsort_util/dawrite.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/dawrite.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine dawrite (lun,irec0,vector,length,recl) -c -c this routine write vector with required length to -c opened direct access file lun starting from record number -c irec0 -c -c lun - logical unit of direct access file (I) -c irec0 - initial recored number (I) -c vector- vector (I) -c length- number of R8 data to be readed (I) -c recl - length of one record in lun in R8 (I) -c - real*8 vector(1:length) - integer lun,irec0,length,recl -c -c help variables -c - integer ilow,iup,need,irec,i -c - if (length.eq.0) then - return - end if -c -c* def need,ilow,iup,irec -c - need=length - ilow=1 - irec=irec0 - iup=0 -c - 1 if (recl.ge.need) then - iup=iup+need - else - iup=iup+recl - end if -c - write (lun,rec=irec) (vector(i),i=ilow,iup) -c - need=need-(iup-ilow+1) - irec=irec+1 - ilow=ilow+recl -c - if (need.gt.0) goto 1 -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/dawrite.F90 openmolcas-22.10/src/ccsort_util/dawrite.F90 --- openmolcas-22.02/src/ccsort_util/dawrite.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/dawrite.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,57 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine dawrite(lun,irec0,vector,length,reclen) +! this routine writes vector with required length to +! open direct access file lun starting from record number +! irec0 +! +! lun - logical unit of direct access file (I) +! irec0 - initial record number (I) +! vector- vector (I) +! length- number of R8 data to be read (I) +! reclen- length of one record in lun in R8 (I) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: lun, irec0, length, reclen +real(kind=wp), intent(in) :: vector(length) +integer(kind=iwp) :: ilow, irec, iup, need + +if (length == 0) return + +! def need,ilow,iup,irec + +need = length +ilow = 1 +irec = irec0 +iup = 0 + +do + if (reclen >= need) then + iup = iup+need + else + iup = iup+reclen + end if + + write(lun,rec=irec) vector(ilow:iup) + + need = need-(iup-ilow+1) + irec = irec+1 + ilow = ilow+reclen + + if (need <= 0) exit +end do + +return + +end subroutine dawrite diff -Nru openmolcas-22.02/src/ccsort_util/dawrtmap.f openmolcas-22.10/src/ccsort_util/dawrtmap.f --- openmolcas-22.02/src/ccsort_util/dawrtmap.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/dawrtmap.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,45 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine dawrtmap (lun,mapd,mapi,rc) -c -c this routine write required mapd and mapi to opened unformatted file -c with number lun -c -c lun - Logical unit number of file, where mediate will be stored (Input) -c mapd - direct map matrix corresponding to given mediate (Input) -c mapi - inverse map matrix corresponding to given mediate (Input) -c rc - return (error) code (Output) -c -#include "files_ccsd.fh" -#include "reorg.fh" - -#include "SysDef.fh" -c - integer lun,rc - integer mapd(0:512,1:6) - integer mapi(1:8,1:8,1:8) -c - rc=0 -c -c1 write mapd -c - if (iokey.eq.1) then -c Fortran IO - write (lun) mapd,mapi -c - else -c MOLCAS IO - call idafile (lun,1,mapd,3078,daddr(lun)) - call idafile (lun,1,mapi,512,daddr(lun)) - end if -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/dawrtmap.F90 openmolcas-22.10/src/ccsort_util/dawrtmap.F90 --- openmolcas-22.02/src/ccsort_util/dawrtmap.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/dawrtmap.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,47 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine dawrtmap(lun,mapd,mapi,rc) +! this routine writes required mapd and mapi to open unformatted file +! with number lun +! +! lun - Logical unit number of file, where mediate will be stored (Input) +! mapd - direct map matrix corresponding to given mediate (Input) +! mapi - inverse map matrix corresponding to given mediate (Input) +! rc - return (error) code (Output) + +use ccsort_global, only: daddr, iokey +use Definitions, only: iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: lun +integer(kind=iwp), intent(_IN_) :: mapd(0:512,6), mapi(8,8,8) +integer(kind=iwp), intent(out) :: rc + +rc = 0 + +!1 write mapd + +if (iokey == 1) then + ! Fortran IO + write(lun) mapd,mapi + +else + ! MOLCAS IO + call idafile(lun,1,mapd,3078,daddr(lun)) + call idafile(lun,1,mapi,512,daddr(lun)) +end if + +return + +end subroutine dawrtmap diff -Nru openmolcas-22.02/src/ccsort_util/dawrtmediate.f openmolcas-22.10/src/ccsort_util/dawrtmediate.f --- openmolcas-22.02/src/ccsort_util/dawrtmediate.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/dawrtmediate.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine dawrtmediate (wrk,wrksize, - & lun,mapd,mapi,rc) -c -c this routine write required mediate to opened unformatted file -c with number lun -c it also store mapd and mapi of the given mediade -c -c lun - Logical unit number of file, where mediate will be stored (Input) -c mapd - direct map matrix corresponding to given mediate (Input) -c mapi - inverse map matrix corresponding to given mediate (Input) -c rc - return (error) code (Output) -c -c N.B. -c all mediates are storred as follows -c 1 - mapd, mapi -c 2 - one record with complete mediate -c -#include "wrk.fh" - integer lun,rc - integer mapd(0:512,1:6) - integer mapi(1:8,1:8,1:8) -c -c help variables -c - integer im,length,poss0 -c - rc=0 -c -c1 write mapd -c - call dawrtmap (lun,mapd,mapi,rc) -c -c2 calculate overall length -c - length=0 -c - do 100 im=1,mapd(0,5) - length=length+mapd(im,2) - 100 continue -c -c write mediate in one block -c - if (length.eq.0) then -c RC=1 : there is nothing to write, length of mediate is 0 - rc=1 - return - end if -c - poss0=mapd(1,1) - call dawri (lun,length,wrk(poss0)) -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/dawrtmediate.F90 openmolcas-22.10/src/ccsort_util/dawrtmediate.F90 --- openmolcas-22.02/src/ccsort_util/dawrtmediate.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/dawrtmediate.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,64 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine dawrtmediate(wrk,wrksize,lun,mapd,mapi,rc) +! this routine writes required mediate to open unformatted file +! with number lun +! it also stores mapd and mapi of the given mediade +! +! lun - Logical unit number of file, where mediate will be stored (Input) +! mapd - direct map matrix corresponding to given mediate (Input) +! mapi - inverse map matrix corresponding to given mediate (Input) +! rc - return (error) code (Output) +! +! N.B. +! all mediates are stored as follows +! 1 - mapd, mapi +! 2 - one record with complete mediate + +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: wrksize, lun +real(kind=wp), intent(_IN_) :: wrk(wrksize) +integer(kind=iwp), intent(_IN_) :: mapd(0:512,6), mapi(8,8,8) +integer(kind=iwp), intent(out) :: rc +integer(kind=iwp) :: im, length, pos0 + +rc = 0 + +!1 write mapd + +call dawrtmap(lun,mapd,mapi,rc) + +!2 calculate overall length + +length = 0 + +do im=1,mapd(0,5) + length = length+mapd(im,2) +end do + +! write mediate in one block + +if (length == 0) then + ! RC=1 : there is nothing to write, length of mediate is 0 + rc = 1 +else + pos0 = mapd(1,1) + call dawri(lun,length,wrk(pos0)) +end if + +return + +end subroutine dawrtmediate diff -Nru openmolcas-22.02/src/ccsort_util/deflength.f openmolcas-22.10/src/ccsort_util/deflength.f --- openmolcas-22.02/src/ccsort_util/deflength.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/deflength.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,26 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine deflength (mapd,length) -c -c this routine defines length of mediate, described by mapd -c - integer mapd(0:512,1:6) - integer length -c -c help variable -c - integer ii -c - ii=mapd(0,5) - length=mapd(ii,1)+mapd(ii,2)-mapd(1,1) -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/deflength.F90 openmolcas-22.10/src/ccsort_util/deflength.F90 --- openmolcas-22.02/src/ccsort_util/deflength.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/deflength.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,27 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine deflength(mapd,length) +! this routine defines length of mediate, described by mapd + +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: mapd(0:512,6) +integer(kind=iwp), intent(out) :: length +integer(kind=iwp) :: ii + +ii = mapd(0,5) +length = mapd(ii,1)+mapd(ii,2)-mapd(1,1) + +return + +end subroutine deflength diff -Nru openmolcas-22.02/src/ccsort_util/deft3par.f openmolcas-22.10/src/ccsort_util/deft3par.f --- openmolcas-22.02/src/ccsort_util/deft3par.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/deft3par.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,89 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine DefT3par (noa,nsym) -c -c this routine do: -c 0) Open t3nam file, with lunt3 lun -c define parameters, required for T3 integral handling, namely -c 1) def T3IndPoss(i) -c address possitions for all occupied orbitals in t3nam file -c 2) def T3Off(ii,isym) -c relative shifts of address for ii-th block of R_i(a,bc) -c for each symmetry -c -c noa - array with occupation numbers -c nsym - actual number of irreps -c - implicit none -#include "reorg.fh" -#include "files_ccsd.fh" -c - integer noa(1:8) - integer nsym -c -c help variables - integer iorb,ii,i,symi,length,posst,idum(1) - real*8 dum(1) -c -c -c0 open t3nam file -c lunt3=1 - call daname (lunt3,t3nam) -c -c1 set address poiter to 0 - daddr(lunt3)=0 -c -c2 first record in t3nam file is T3IntPoss -c (emulate writing of T3IntPoss) - idum(1)=0 - dum(1)=0.0d0 - call idafile (lunt3,0,idum,mbas,daddr(lunt3)) -c - iorb=0 -c3 cycle over irreps - do symi=1,nsym -c -c3.1 make mapd and mapi for R_i(a,bc) - call ccsort_t3grc0 - c (3,8,4,4,4,0,symi,possri0,posst,mapdri,mapiri) -c -c3.2 cycle over occupied orbitals in symi - do i=1,noa(symi) -c -c3.2.1 save initial addres for this orbital - iorb=iorb+1 - T3IntPoss(iorb)=daddr(lunt3) -c -c3.2.2 emulate writing of mapd and mapp - call idafile (lunt3,0,idum,513*6,daddr(lunt3)) - call idafile (lunt3,0,idum,8*8*8,daddr(lunt3)) -c -c3.2.3 cycle over all blocks of R_i(a,bc), which will -c be stored separately - do ii=1,mapdri(0,5) -c -c3.2.3.1 def T3Off(ii,symi) -c note, that iorb is always proper one, since only besides -c first occ. orbital in given irrep T3Off is defined - if (i.eq.1) then - T3Off(ii,symi)=daddr(lunt3)-T3IntPoss(iorb) - end if -c -c3.2.3.2 emulate writing of each block - length=mapdri(ii,2) - call ddafile (lunt3,0,dum,length,daddr(lunt3)) -c - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/deft3par.F90 openmolcas-22.10/src/ccsort_util/deft3par.F90 --- openmolcas-22.02/src/ccsort_util/deft3par.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/deft3par.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,84 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine DefT3par(noa,nsym) +! this routine does: +! 0) Open t3nam file, with lunt3 lun +! define parameters, required for T3 integral handling, namely +! 1) def T3IndPos(i) +! address positions for all occupied orbitals in t3nam file +! 2) def T3Off(ii,isym) +! relative shifts of address for ii-th block of R_i(a,bc) +! for each symmetry +! +! noa - array with occupation numbers +! nsym - actual number of irreps + +use ccsort_global, only: daddr, lunt3, mapdri, mapiri, mbas, posri0 +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: noa(8), nsym +#include "t3int.fh" +integer(kind=iwp) :: i, idum(1), ii, iorb, length, post, symi +real(kind=wp) :: dum(1) + +!0 open t3nam file +!lunt3= 1 +call daname(lunt3,t3nam) + +!1 set address poiter to 0 +daddr(lunt3) = 0 + +!2 first record in t3nam file is T3IntPos +! (emulate writing of T3IntPos) +idum(1) = 0 +dum(1) = Zero +call idafile(lunt3,0,idum,mbas,daddr(lunt3)) + +iorb = 0 +!3 cycle over irreps +do symi=1,nsym + + !3.1 make mapd and mapi for R_i(a,bc) + call ccsort_t3grc0(3,8,4,4,4,0,symi,posri0,post,mapdri,mapiri) + + !3.2 cycle over occupied orbitals in symi + do i=1,noa(symi) + + !3.2.1 save initial address for this orbital + iorb = iorb+1 + T3IntPos(iorb) = daddr(lunt3) + + !3.2.2 emulate writing of mapd and mapp + call idafile(lunt3,0,idum,513*6,daddr(lunt3)) + call idafile(lunt3,0,idum,8*8*8,daddr(lunt3)) + + !3.2.3 cycle over all blocks of R_i(a,bc), which will be stored separately + do ii=1,mapdri(0,5) + + !3.2.3.1 def T3Off(ii,symi) + ! note, that iorb is always proper one, since only besides + ! first occ. orbital in given irrep T3Off is defined + if (i == 1) T3Off(ii,symi) = daddr(lunt3)-T3IntPos(iorb) + + !3.2.3.2 emulate writing of each block + length = mapdri(ii,2) + call ddafile(lunt3,0,dum,length,daddr(lunt3)) + + end do + end do +end do + +return + +end subroutine DefT3par diff -Nru openmolcas-22.02/src/ccsort_util/esb_ic_1.f openmolcas-22.10/src/ccsort_util/esb_ic_1.f --- openmolcas-22.02/src/ccsort_util/esb_ic_1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/esb_ic_1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,314 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine esb_ic_1 (symp,symq,symr,syms, - c Vic,dimp,dimq,dimr,dims) -c -c this routine realize expansion of symmetry block -c symp,symq,symr,syms <-> (IJ|KL), provided such integrals exists -c It found corresponding (IJ|KL) and expand it to -c matrix vic (np,nq,nr,ns) -c - -#include "SysDef.fh" -#include "reorg.fh" -#include "ccsort.fh" -c - integer symp,symq,symr,syms - integer dimp,dimq,dimr,dims - real*8 Vic(1:dimp,1:dimq,1:dimr,1:dims) - real*8 val1 -c - - integer idis13,indtemp - integer ni,nj,nk,nl,nsi,nsj,nsk,nsl,i1,j1,k1,l1 - integer iup,ilow,jup,jlow,kup,lup,iold,jold,kold,lold -c -c help variables - integer yes234,yes5,yes678 - integer typp - integer ind(1:4) -#include "tratoc.fh" - integer INDMAX - parameter (INDMAX=nTraBuf) - REAL*8 TWO(INDMAX) -c -cI get adress - idis13=idis(symp,symq,symr) -c -cIII.1define order of indices -c - ni=np(symp,symq,symr) - nj=nq(symp,symq,symr) - nk=nr(symp,symq,symr) - nl=ns(symp,symq,symr) -c -cIII.2def yes1-8 -c - typp=typ(symp,symq,symr) -c -c:1 combination (ij|kl) -> (ij|kl) -c used in types: 1,2,3,4,5,6,7,8 (all) -c yes1=1 -c -c:2 combination (ij|kl) -> (ji|kl) -c:3 combination (ij|kl) -> (ij|lk) -c:4 combination (ij|kl) -> (ji|lk) -c used in types: 1,5 since 2,3,6,7 never appear - if ((typp.eq.1).or.(typp.eq.5)) then - yes234=1 - else - yes234=0 - end if -c -c:5 combination (ij|kl) -> (kl|ij) -c used in types: 1,2,3,4 - if ((typp.ge.1).and.(typp.le.4)) then - yes5=1 - else - yes5=0 - end if -c -c:6 combination (ij|kl) -> (lk|ij) -c:7 combination (ij|kl) -> (kl|ji) -c:8 combination (ij|kl) -> (lk|ji) -c used in types: 1 (since 2,3 never appeard) - if (typp.eq.1) then - yes678=1 - else - yes678=0 - end if -c -c -c define NSI,NSJ,NSK,NSL - ind(ni)=symp - ind(nj)=symq - ind(nk)=symr - ind(nl)=syms - NSI=ind(1) - NSJ=ind(2) - NSK=ind(3) - NSL=ind(4) -C - indtemp=indmax+1 - KUP=NORB(NSK) - DO 401 KOLD=1,KUP -C - LUP=NORB(NSL) - IF (NSK.EQ.NSL) LUP=KOLD - DO 402 LOLD=1,LUP -C - ILOW=1 - IF (NSI.EQ.NSK) ILOW=KOLD - IUP=NORB(NSI) - DO 403 IOLD=ILOW,IUP -C - JLOW=1 - IF (NSI.EQ.NSK.AND.IOLD.EQ.KOLD) JLOW=LOLD - JUP=NORB(NSJ) - IF (NSI.EQ.NSJ) JUP=IOLD - DO 404 JOLD=JLOW,JUP -C -c -c* read block of integrals if neccesarry -c - if (indtemp.eq.(indmax+1)) then - indtemp=1 -c read block - CALL dDAFILE(LUINTM,2,TWO,INDMAX,IDIS13) - end if -c -c* write integrals to appropriate possitions -c - val1=TWO(indtemp) -c -c:1 combination (ij|kl) -> (ij|kl) -c since yes1 is always 1, if structure is skipped - ind(1)=iold - ind(2)=jold - ind(3)=kold - ind(4)=lold - j1=ind(nj) - l1=ind(nl) - i1=ind(ni) - k1=ind(nk) -c - if (i1.le.dimp) then - if (j1.le.dimq) then - if (k1.le.dimr) then - if (l1.le.dims) then - Vic(i1,j1,k1,l1)=val1 - end if - end if - end if - end if -c - if (yes234.eq.1) then -c -c:2 combination (ij|kl) -> (ji|kl) - ind(1)=jold - ind(2)=iold - ind(3)=kold - ind(4)=lold - j1=ind(nj) - l1=ind(nl) - i1=ind(ni) - k1=ind(nk) -c -c - if (i1.le.dimp) then - if (j1.le.dimq) then - if (k1.le.dimr) then - if (l1.le.dims) then - Vic(i1,j1,k1,l1)=val1 - end if - end if - end if - end if -c -c:3 combination (ij|kl) -> (ij|lk) - ind(1)=iold - ind(2)=jold - ind(3)=lold - ind(4)=kold - j1=ind(nj) - l1=ind(nl) - i1=ind(ni) - k1=ind(nk) -c - if (i1.le.dimp) then - if (j1.le.dimq) then - if (k1.le.dimr) then - if (l1.le.dims) then - Vic(i1,j1,k1,l1)=val1 - end if - end if - end if - end if -c -c:4 combination (ij|kl) -> (ji|lk) - ind(1)=jold - ind(2)=iold - ind(3)=lold - ind(4)=kold - j1=ind(nj) - l1=ind(nl) - i1=ind(ni) - k1=ind(nk) -c - if (i1.le.dimp) then - if (j1.le.dimq) then - if (k1.le.dimr) then - if (l1.le.dims) then - Vic(i1,j1,k1,l1)=val1 - end if - end if - end if - end if -c - end if -c -c:5 combination (ij|kl) -> (kl|ij) - if (yes5.eq.1) then - ind(1)=kold - ind(2)=lold - ind(3)=iold - ind(4)=jold - j1=ind(nj) - l1=ind(nl) - i1=ind(ni) - k1=ind(nk) -c - if (i1.le.dimp) then - if (j1.le.dimq) then - if (k1.le.dimr) then - if (l1.le.dims) then - Vic(i1,j1,k1,l1)=val1 - end if - end if - end if - end if -c - end if -c - if (yes678.eq.1) then -c -c:6 combination (ij|kl) -> (lk|ij) - ind(1)=lold - ind(2)=kold - ind(3)=iold - ind(4)=jold - j1=ind(nj) - l1=ind(nl) - i1=ind(ni) - k1=ind(nk) -c - if (i1.le.dimp) then - if (j1.le.dimq) then - if (k1.le.dimr) then - if (l1.le.dims) then - Vic(i1,j1,k1,l1)=val1 - end if - end if - end if - end if -c -c:7 combination (ij|kl) -> (kl|ji) - ind(1)=kold - ind(2)=lold - ind(3)=jold - ind(4)=iold - j1=ind(nj) - l1=ind(nl) - i1=ind(ni) - k1=ind(nk) -c - if (i1.le.dimp) then - if (j1.le.dimq) then - if (k1.le.dimr) then - if (l1.le.dims) then - Vic(i1,j1,k1,l1)=val1 - end if - end if - end if - end if -c -c:8 combination (ij|kl) -> (lk|ji) - ind(1)=lold - ind(2)=kold - ind(3)=jold - ind(4)=iold - j1=ind(nj) - l1=ind(nl) - i1=ind(ni) - k1=ind(nk) -c - if (i1.le.dimp) then - if (j1.le.dimq) then - if (k1.le.dimr) then - if (l1.le.dims) then - Vic(i1,j1,k1,l1)=val1 - end if - end if - end if - end if -c - end if -c - indtemp=indtemp+1 -c - 404 CONTINUE - 403 CONTINUE - 402 CONTINUE - 401 CONTINUE -C -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/esb_ic_1.F90 openmolcas-22.10/src/ccsort_util/esb_ic_1.F90 --- openmolcas-22.02/src/ccsort_util/esb_ic_1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/esb_ic_1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,241 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine esb_ic_1(symp,symq,symr,syms,Vic,dimp,dimq,dimr,dims) +! this routine realizes expansion of symmetry block +! symp,symq,symr,syms <-> (IJ|KL), provided such integrals exist +! It finds corresponding (IJ|KL) and expands it to +! matrix vic (np,nq,nr,ns) + +use ccsort_global, only: idis, LUINTM, NORB, np, nq, nr, ns, typ +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: symp, symq, symr, syms, dimp, dimq, dimr, dims +real(kind=wp), intent(_OUT_) :: Vic(dimp,dimq,dimr,dims) +#include "tratoc.fh" +integer(kind=iwp) :: i1, idis13, ilow, ind(4), indtemp, iold, iup, j1, jlow, jold, jup, k1, kold, kup, l1, lold, lup, ni, nj, nk, & + nl, nsi, nsj, nsk, nsl, typp, yes234, yes5, yes678 +real(kind=wp) :: val1 +real(kind=wp), allocatable :: TWO(:) + +!I get address +idis13 = idis(symp,symq,symr) + +!III.1 define order of indices + +ni = np(symp,symq,symr) +nj = nq(symp,symq,symr) +nk = nr(symp,symq,symr) +nl = ns(symp,symq,symr) + +!III.2 def yes1-8 + +typp = typ(symp,symq,symr) + +!:1 combination (ij|kl) -> (ij|kl) +! used in types: 1,2,3,4,5,6,7,8 (all) +!yes1 = 1 + +!:2 combination (ij|kl) -> (ji|kl) +!:3 combination (ij|kl) -> (ij|lk) +!:4 combination (ij|kl) -> (ji|lk) +! used in types: 1,5 since 2,3,6,7 never appear +if ((typp == 1) .or. (typp == 5)) then + yes234 = 1 +else + yes234 = 0 +end if + +!:5 combination (ij|kl) -> (kl|ij) +! used in types: 1,2,3,4 +if ((typp >= 1) .and. (typp <= 4)) then + yes5 = 1 +else + yes5 = 0 +end if + +!:6 combination (ij|kl) -> (lk|ij) +!:7 combination (ij|kl) -> (kl|ji) +!:8 combination (ij|kl) -> (lk|ji) +! used in types: 1 (since 2,3 never appeard) +if (typp == 1) then + yes678 = 1 +else + yes678 = 0 +end if + +! define NSI,NSJ,NSK,NSL +ind(ni) = symp +ind(nj) = symq +ind(nk) = symr +ind(nl) = syms +NSI = ind(1) +NSJ = ind(2) +NSK = ind(3) +NSL = ind(4) + +call mma_allocate(TWO,nTraBuf,label='TWO') + +indtemp = nTraBuf+1 +KUP = NORB(NSK) +do KOLD=1,KUP + + LUP = NORB(NSL) + if (NSK == NSL) LUP = KOLD + do LOLD=1,LUP + + ILOW = 1 + if (NSI == NSK) ILOW = KOLD + IUP = NORB(NSI) + do IOLD=ILOW,IUP + + JLOW = 1 + if ((NSI == NSK) .and. (IOLD == KOLD)) JLOW = LOLD + JUP = NORB(NSJ) + if (NSI == NSJ) JUP = IOLD + do JOLD=JLOW,JUP + + ! read block of integrals if necessary + + if (indtemp == (nTraBuf+1)) then + indtemp = 1 + ! read block + call dDAFILE(LUINTM,2,TWO,nTraBuf,IDIS13) + end if + + ! write integrals to appropriate positions + + val1 = TWO(indtemp) + + !:1 combination (ij|kl) -> (ij|kl) + ! since yes1 is always 1, if structure is skipped + ind(1) = iold + ind(2) = jold + ind(3) = kold + ind(4) = lold + j1 = ind(nj) + l1 = ind(nl) + i1 = ind(ni) + k1 = ind(nk) + + if ((i1 <= dimp) .and. (j1 <= dimq) .and. (k1 <= dimr) .and. (l1 <= dims)) Vic(i1,j1,k1,l1) = val1 + + if (yes234 == 1) then + + !:2 combination (ij|kl) -> (ji|kl) + ind(1) = jold + ind(2) = iold + ind(3) = kold + ind(4) = lold + j1 = ind(nj) + l1 = ind(nl) + i1 = ind(ni) + k1 = ind(nk) + + if ((i1 <= dimp) .and. (j1 <= dimq) .and. (k1 <= dimr) .and. (l1 <= dims)) Vic(i1,j1,k1,l1) = val1 + + !:3 combination (ij|kl) -> (ij|lk) + ind(1) = iold + ind(2) = jold + ind(3) = lold + ind(4) = kold + j1 = ind(nj) + l1 = ind(nl) + i1 = ind(ni) + k1 = ind(nk) + + if ((i1 <= dimp) .and. (j1 <= dimq) .and. (k1 <= dimr) .and. (l1 <= dims)) Vic(i1,j1,k1,l1) = val1 + + !:4 combination (ij|kl) -> (ji|lk) + ind(1) = jold + ind(2) = iold + ind(3) = lold + ind(4) = kold + j1 = ind(nj) + l1 = ind(nl) + i1 = ind(ni) + k1 = ind(nk) + + if ((i1 <= dimp) .and. (j1 <= dimq) .and. (k1 <= dimr) .and. (l1 <= dims)) Vic(i1,j1,k1,l1) = val1 + + end if + + !:5 combination (ij|kl) -> (kl|ij) + if (yes5 == 1) then + ind(1) = kold + ind(2) = lold + ind(3) = iold + ind(4) = jold + j1 = ind(nj) + l1 = ind(nl) + i1 = ind(ni) + k1 = ind(nk) + + if ((i1 <= dimp) .and. (j1 <= dimq) .and. (k1 <= dimr) .and. (l1 <= dims)) Vic(i1,j1,k1,l1) = val1 + + end if + + if (yes678 == 1) then + + !:6 combination (ij|kl) -> (lk|ij) + ind(1) = lold + ind(2) = kold + ind(3) = iold + ind(4) = jold + j1 = ind(nj) + l1 = ind(nl) + i1 = ind(ni) + k1 = ind(nk) + + if ((i1 <= dimp) .and. (j1 <= dimq) .and. (k1 <= dimr) .and. (l1 <= dims)) Vic(i1,j1,k1,l1) = val1 + + !:7 combination (ij|kl) -> (kl|ji) + ind(1) = kold + ind(2) = lold + ind(3) = jold + ind(4) = iold + j1 = ind(nj) + l1 = ind(nl) + i1 = ind(ni) + k1 = ind(nk) + + if ((i1 <= dimp) .and. (j1 <= dimq) .and. (k1 <= dimr) .and. (l1 <= dims)) Vic(i1,j1,k1,l1) = val1 + + !:8 combination (ij|kl) -> (lk|ji) + ind(1) = lold + ind(2) = kold + ind(3) = jold + ind(4) = iold + j1 = ind(nj) + l1 = ind(nl) + i1 = ind(ni) + k1 = ind(nk) + + if ((i1 <= dimp) .and. (j1 <= dimq) .and. (k1 <= dimr) .and. (l1 <= dims)) Vic(i1,j1,k1,l1) = val1 + + end if + + indtemp = indtemp+1 + + end do + end do + end do +end do + +call mma_deallocate(TWO) + +return + +end subroutine esb_ic_1 diff -Nru openmolcas-22.02/src/ccsort_util/esb_ic_2.f openmolcas-22.10/src/ccsort_util/esb_ic_2.f --- openmolcas-22.02/src/ccsort_util/esb_ic_2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/esb_ic_2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,335 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine esb_ic_2 (symp,symq,Vic,dimp,dimq,pqind) -c -c this routine realize expansion of symmetry block -c symp,symq,symr,syms <-> (IJ|KL), -c (for case symp=symr,symq=syms) -c provided such integrals exists -c It found corresponding (IJ|KL) and expand it to -c matrix vic (pr,qs) -c - -#include "SysDef.fh" -#include "reorg.fh" -#include "ccsort.fh" -c - integer symp,symq - integer dimp,dimq - real*8 Vic(1:(dimp*(dimp+1)/2),1:(dimq*(dimq+1)/2)) - real*8 val1 -c - - integer idis13,indtemp - integer ni,nj,nk,nl,nsi,nsj,nsk,nsl,i1,j1,k1,l1 - integer iup,ilow,jup,jlow,kup,lup,iold,jold,kold,lold - integer pqind(1:mbas,1:mbas) -c -c help variables - integer i,j,maxx - integer yes234,yes5,yes678 - integer typp - integer ind(1:4) -#include "tratoc.fh" - integer INDMAX - parameter (INDMAX=nTraBuf) - REAL*8 TWO(INDMAX) -c -cI calc pqind -c - if (dimp.ge.dimq) then - maxx=dimp - else - maxx=dimq - end if -c - do i=1,maxx - do j=1,maxx - if (i.ge.j) then - pqind(i,j)=i*(i-1)/2+j - else - pqind(i,j)=j*(j-1)/2+i - end if - end do - end do -c -cII get adress - idis13=idis(symp,symq,symp) -c -cIII.1define order of indices -c - ni=np(symp,symq,symp) - nj=nq(symp,symq,symp) - nk=nr(symp,symq,symp) - nl=ns(symp,symq,symp) -c -cIII.2def yes1-8 -c - typp=typ(symp,symq,symp) -c -c:1 combination (ij|kl) -> (ij|kl) -c used in types: 1,2,3,4,5,6,7,8 (all) -c yes1=1 -c -c:2 combination (ij|kl) -> (ji|kl) -c:3 combination (ij|kl) -> (ij|lk) -c:4 combination (ij|kl) -> (ji|lk) -c used in types: 1,5 since 2,3,6,7 never appear - if ((typp.eq.1).or.(typp.eq.5)) then - yes234=1 - else - yes234=0 - end if -c -c:5 combination (ij|kl) -> (kl|ij) -c used in types: 1,2,3,4 - if ((typp.ge.1).and.(typp.le.4)) then - yes5=1 - else - yes5=0 - end if -c -c:6 combination (ij|kl) -> (lk|ij) -c:7 combination (ij|kl) -> (kl|ji) -c:8 combination (ij|kl) -> (lk|ji) -c used in types: 1 (since 2,3 never appeard) - if (typp.eq.1) then - yes678=1 - else - yes678=0 - end if -c -c -c define NSI,NSJ,NSK,NSL - ind(ni)=symp - ind(nj)=symq - ind(nk)=symp - ind(nl)=symq - NSI=ind(1) - NSJ=ind(2) - NSK=ind(3) - NSL=ind(4) -C - indtemp=indmax+1 - KUP=NORB(NSK) - DO 401 KOLD=1,KUP -C - LUP=NORB(NSL) - IF (NSK.EQ.NSL) LUP=KOLD - DO 402 LOLD=1,LUP -C - ILOW=1 - IF (NSI.EQ.NSK) ILOW=KOLD - IUP=NORB(NSI) - DO 403 IOLD=ILOW,IUP -C - JLOW=1 - IF (NSI.EQ.NSK.AND.IOLD.EQ.KOLD) JLOW=LOLD - JUP=NORB(NSJ) - IF (NSI.EQ.NSJ) JUP=IOLD - DO 404 JOLD=JLOW,JUP -C -c -c* read block of integrals if neccesarry -c - if (indtemp.eq.(indmax+1)) then - indtemp=1 -c read block - CALL dDAFILE(LUINTM,2,TWO,INDMAX,IDIS13) - end if -c -c* write integrals to appropriate possitions -c - val1=TWO(indtemp) -c -c:1 combination (ij|kl) -> (ij|kl) -c since yes1 is always 1, if structure is skipped - ind(1)=iold - ind(2)=jold - ind(3)=kold - ind(4)=lold - j1=ind(nj) - l1=ind(nl) - i1=ind(ni) - k1=ind(nk) -c - if (i1.le.dimp) then - if (j1.le.dimq) then - if (k1.le.dimp) then - if (l1.le.dimq) then - Vic(pqind(i1,k1),pqind(j1,l1))=val1 - end if - end if - end if - end if -c - if (yes234.eq.1) then -c -c:2 combination (ij|kl) -> (ji|kl) - ind(1)=jold - ind(2)=iold - ind(3)=kold - ind(4)=lold - j1=ind(nj) - l1=ind(nl) - i1=ind(ni) - k1=ind(nk) -c -c - if (i1.le.dimp) then - if (j1.le.dimq) then - if (k1.le.dimp) then - if (l1.le.dimq) then - Vic(pqind(i1,k1),pqind(j1,l1))=val1 - end if - end if - end if - end if -c -c:3 combination (ij|kl) -> (ij|lk) - ind(1)=iold - ind(2)=jold - ind(3)=lold - ind(4)=kold - j1=ind(nj) - l1=ind(nl) - i1=ind(ni) - k1=ind(nk) -c - if (i1.le.dimp) then - if (j1.le.dimq) then - if (k1.le.dimp) then - if (l1.le.dimq) then - Vic(pqind(i1,k1),pqind(j1,l1))=val1 - end if - end if - end if - end if -c -c:4 combination (ij|kl) -> (ji|lk) - ind(1)=jold - ind(2)=iold - ind(3)=lold - ind(4)=kold - j1=ind(nj) - l1=ind(nl) - i1=ind(ni) - k1=ind(nk) -c - if (i1.le.dimp) then - if (j1.le.dimq) then - if (k1.le.dimp) then - if (l1.le.dimq) then - Vic(pqind(i1,k1),pqind(j1,l1))=val1 - end if - end if - end if - end if -c - end if -c -c:5 combination (ij|kl) -> (kl|ij) - if (yes5.eq.1) then - ind(1)=kold - ind(2)=lold - ind(3)=iold - ind(4)=jold - j1=ind(nj) - l1=ind(nl) - i1=ind(ni) - k1=ind(nk) -c - if (i1.le.dimp) then - if (j1.le.dimq) then - if (k1.le.dimp) then - if (l1.le.dimq) then - Vic(pqind(i1,k1),pqind(j1,l1))=val1 - end if - end if - end if - end if -c - end if -c - if (yes678.eq.1) then -c -c:6 combination (ij|kl) -> (lk|ij) - ind(1)=lold - ind(2)=kold - ind(3)=iold - ind(4)=jold - j1=ind(nj) - l1=ind(nl) - i1=ind(ni) - k1=ind(nk) -c - if (i1.le.dimp) then - if (j1.le.dimq) then - if (k1.le.dimp) then - if (l1.le.dimq) then - Vic(pqind(i1,k1),pqind(j1,l1))=val1 - end if - end if - end if - end if -c -c:7 combination (ij|kl) -> (kl|ji) - ind(1)=kold - ind(2)=lold - ind(3)=jold - ind(4)=iold - j1=ind(nj) - l1=ind(nl) - i1=ind(ni) - k1=ind(nk) -c - if (i1.le.dimp) then - if (j1.le.dimq) then - if (k1.le.dimp) then - if (l1.le.dimq) then - Vic(pqind(i1,k1),pqind(j1,l1))=val1 - end if - end if - end if - end if -c -c:8 combination (ij|kl) -> (lk|ji) - ind(1)=lold - ind(2)=kold - ind(3)=jold - ind(4)=iold - j1=ind(nj) - l1=ind(nl) - i1=ind(ni) - k1=ind(nk) -c - if (i1.le.dimp) then - if (j1.le.dimq) then - if (k1.le.dimp) then - if (l1.le.dimq) then - Vic(pqind(i1,k1),pqind(j1,l1))=val1 - end if - end if - end if - end if -c - end if -c - indtemp=indtemp+1 -c - 404 CONTINUE - 403 CONTINUE - 402 CONTINUE - 401 CONTINUE -C -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/esb_ic_2.F90 openmolcas-22.10/src/ccsort_util/esb_ic_2.F90 --- openmolcas-22.02/src/ccsort_util/esb_ic_2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/esb_ic_2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,262 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine esb_ic_2(symp,symq,Vic,dimp,dimq,pqind) +! this routine realizes expansion of symmetry block +! symp,symq,symr,syms <-> (IJ|KL), +! (for case symp=symr,symq=syms) +! provided such integrals exist +! It finds corresponding (IJ|KL) and expands it to +! matrix vic (pr,qs) + +use ccsort_global, only: idis, LUINTM, mbas, NORB, np, nq, nr, ns, typ +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: symp, symq, dimp, dimq +real(kind=wp), intent(_OUT_) :: Vic(dimp*(dimp+1)/2,dimq*(dimq+1)/2) +integer(kind=iwp), intent(out) :: pqind(mbas,mbas) +#include "tratoc.fh" +integer(kind=iwp) :: i, i1, idis13, ilow, ind(4), indtemp, iold, iup, j, j1, jlow, jold, jup, k1, kold, kup, l1, lold, lup, maxx, & + ni, nj, nk, nl, nsi, nsj, nsk, nsl, typp, yes234, yes5, yes678 +real(kind=wp) :: val1 +real(kind=wp), allocatable :: TWO(:) + +!I calc pqind + +if (dimp >= dimq) then + maxx = dimp +else + maxx = dimq +end if + +do i=1,maxx + do j=1,maxx + if (i >= j) then + pqind(i,j) = i*(i-1)/2+j + else + pqind(i,j) = j*(j-1)/2+i + end if + end do +end do + +!II get address +idis13 = idis(symp,symq,symp) + +!III.1 define order of indices + +ni = np(symp,symq,symp) +nj = nq(symp,symq,symp) +nk = nr(symp,symq,symp) +nl = ns(symp,symq,symp) + +!III.2 def yes1-8 + +typp = typ(symp,symq,symp) + +!:1 combination (ij|kl) -> (ij|kl) +! used in types: 1,2,3,4,5,6,7,8 (all) +!yes1 = 1 + +!:2 combination (ij|kl) -> (ji|kl) +!:3 combination (ij|kl) -> (ij|lk) +!:4 combination (ij|kl) -> (ji|lk) +! used in types: 1,5 since 2,3,6,7 never appear +if ((typp == 1) .or. (typp == 5)) then + yes234 = 1 +else + yes234 = 0 +end if + +!:5 combination (ij|kl) -> (kl|ij) +! used in types: 1,2,3,4 +if ((typp >= 1) .and. (typp <= 4)) then + yes5 = 1 +else + yes5 = 0 +end if + +!:6 combination (ij|kl) -> (lk|ij) +!:7 combination (ij|kl) -> (kl|ji) +!:8 combination (ij|kl) -> (lk|ji) +! used in types: 1 (since 2,3 never appeard) +if (typp == 1) then + yes678 = 1 +else + yes678 = 0 +end if + +! define NSI,NSJ,NSK,NSL +ind(ni) = symp +ind(nj) = symq +ind(nk) = symp +ind(nl) = symq +NSI = ind(1) +NSJ = ind(2) +NSK = ind(3) +NSL = ind(4) + +call mma_allocate(TWO,nTraBuf,label='TWO') + +indtemp = nTraBuf+1 +KUP = NORB(NSK) +do KOLD=1,KUP + + LUP = NORB(NSL) + if (NSK == NSL) LUP = KOLD + do LOLD=1,LUP + + ILOW = 1 + if (NSI == NSK) ILOW = KOLD + IUP = NORB(NSI) + do IOLD=ILOW,IUP + + JLOW = 1 + if ((NSI == NSK) .and. (IOLD == KOLD)) JLOW = LOLD + JUP = NORB(NSJ) + if (NSI == NSJ) JUP = IOLD + do JOLD=JLOW,JUP + + ! read block of integrals if necessary + + if (indtemp == (nTraBuf+1)) then + indtemp = 1 + ! read block + call dDAFILE(LUINTM,2,TWO,nTraBuf,IDIS13) + end if + + ! write integrals to appropriate positions + + val1 = TWO(indtemp) + + !:1 combination (ij|kl) -> (ij|kl) + ! since yes1 is always 1, if structure is skipped + ind(1) = iold + ind(2) = jold + ind(3) = kold + ind(4) = lold + j1 = ind(nj) + l1 = ind(nl) + i1 = ind(ni) + k1 = ind(nk) + + if ((i1 <= dimp) .and. (j1 <= dimq) .and. (k1 <= dimp) .and. (l1 <= dimq)) Vic(pqind(i1,k1),pqind(j1,l1)) = val1 + + if (yes234 == 1) then + + !:2 combination (ij|kl) -> (ji|kl) + ind(1) = jold + ind(2) = iold + ind(3) = kold + ind(4) = lold + j1 = ind(nj) + l1 = ind(nl) + i1 = ind(ni) + k1 = ind(nk) + + if ((i1 <= dimp) .and. (j1 <= dimq) .and. (k1 <= dimp) .and. (l1 <= dimq)) Vic(pqind(i1,k1),pqind(j1,l1)) = val1 + + !:3 combination (ij|kl) -> (ij|lk) + ind(1) = iold + ind(2) = jold + ind(3) = lold + ind(4) = kold + j1 = ind(nj) + l1 = ind(nl) + i1 = ind(ni) + k1 = ind(nk) + + if ((i1 <= dimp) .and. (j1 <= dimq) .and. (k1 <= dimp) .and. (l1 <= dimq)) Vic(pqind(i1,k1),pqind(j1,l1)) = val1 + + !:4 combination (ij|kl) -> (ji|lk) + ind(1) = jold + ind(2) = iold + ind(3) = lold + ind(4) = kold + j1 = ind(nj) + l1 = ind(nl) + i1 = ind(ni) + k1 = ind(nk) + + if ((i1 <= dimp) .and. (j1 <= dimq) .and. (k1 <= dimp) .and. (l1 <= dimq)) Vic(pqind(i1,k1),pqind(j1,l1)) = val1 + + end if + + !:5 combination (ij|kl) -> (kl|ij) + if (yes5 == 1) then + ind(1) = kold + ind(2) = lold + ind(3) = iold + ind(4) = jold + j1 = ind(nj) + l1 = ind(nl) + i1 = ind(ni) + k1 = ind(nk) + + if ((i1 <= dimp) .and. (j1 <= dimq) .and. (k1 <= dimp) .and. (l1 <= dimq)) Vic(pqind(i1,k1),pqind(j1,l1)) = val1 + + end if + + if (yes678 == 1) then + + !:6 combination (ij|kl) -> (lk|ij) + ind(1) = lold + ind(2) = kold + ind(3) = iold + ind(4) = jold + j1 = ind(nj) + l1 = ind(nl) + i1 = ind(ni) + k1 = ind(nk) + + if ((i1 <= dimp) .and. (j1 <= dimq) .and. (k1 <= dimp) .and. (l1 <= dimq)) Vic(pqind(i1,k1),pqind(j1,l1)) = val1 + + !:7 combination (ij|kl) -> (kl|ji) + ind(1) = kold + ind(2) = lold + ind(3) = jold + ind(4) = iold + j1 = ind(nj) + l1 = ind(nl) + i1 = ind(ni) + k1 = ind(nk) + + if ((i1 <= dimp) .and. (j1 <= dimq) .and. (k1 <= dimp) .and. (l1 <= dimq)) Vic(pqind(i1,k1),pqind(j1,l1)) = val1 + + !:8 combination (ij|kl) -> (lk|ji) + ind(1) = lold + ind(2) = kold + ind(3) = jold + ind(4) = iold + j1 = ind(nj) + l1 = ind(nl) + i1 = ind(ni) + k1 = ind(nk) + + if ((i1 <= dimp) .and. (j1 <= dimq) .and. (k1 <= dimp) .and. (l1 <= dimq)) Vic(pqind(i1,k1),pqind(j1,l1)) = val1 + + end if + + indtemp = indtemp+1 + + end do + end do + end do +end do + +call mma_deallocate(TWO) + +return + +end subroutine esb_ic_2 diff -Nru openmolcas-22.02/src/ccsort_util/esb_ic_3.f openmolcas-22.10/src/ccsort_util/esb_ic_3.f --- openmolcas-22.02/src/ccsort_util/esb_ic_3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/esb_ic_3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,151 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine esb_ic_3 (symp,Vic,dimp,pqind) -c -c this routine realize expansion of symmetry block -c symp,symq,symr,syms <-> (IJ|KL), -c (for case symp=symr=symq=syms) -c provided such integrals exists -c It found corresponding (IJ|KL) and expand it to -c matrix vic (prqs) -c - -#include "SysDef.fh" -#include "reorg.fh" -#include "ccsort.fh" -c - integer symp,dimp -CLD integer symp,dimp,dimq - real*8 Vic(1:(dimp*(dimp+1)/2)*((dimp*(dimp+1)/2)+1)/2) - real*8 val1 -c - - integer idis13,indtemp - integer ni,nj,nk,nl,nsi,nsj,nsk,nsl,i1,j1,k1,l1 - integer iup,ilow,jup,jlow,kup,lup,iold,jold,kold,lold - integer pqind(1:mbas,1:mbas) -c -c help variables - integer i,j,maxx,ik,jl,ikjl - integer ind(1:4) -#include "tratoc.fh" - integer INDMAX - parameter (INDMAX=nTraBuf) - REAL*8 TWO(INDMAX) -c -cI calc pqind -c -CLD if (dimp.ge.dimp) then - maxx=dimp -CLD else -CLD maxx=dimq -CLD end if -c - do i=1,maxx - do j=1,maxx - if (i.ge.j) then - pqind(i,j)=i*(i-1)/2+j - else - pqind(i,j)=j*(j-1)/2+i - end if - end do - end do -c -cII get adress - idis13=idis(symp,symp,symp) -c -cIII.1define order of indices -c - ni=np(symp,symp,symp) - nj=nq(symp,symp,symp) - nk=nr(symp,symp,symp) - nl=ns(symp,symp,symp) -c -c -c define NSI,NSJ,NSK,NSL - ind(ni)=symp - ind(nj)=symp - ind(nk)=symp - ind(nl)=symp - NSI=ind(1) - NSJ=ind(2) - NSK=ind(3) - NSL=ind(4) -C - indtemp=indmax+1 - KUP=NORB(NSK) - DO 401 KOLD=1,KUP - if (fullprint.ge.3) write (6,*) ' * K ind ',KOLD -C - LUP=NORB(NSL) - IF (NSK.EQ.NSL) LUP=KOLD - DO 402 LOLD=1,LUP - if (fullprint.ge.3) write (6,*) ' ** L ind ',LOLD -C - ILOW=1 - IF (NSI.EQ.NSK) ILOW=KOLD - IUP=NORB(NSI) - DO 403 IOLD=ILOW,IUP - if (fullprint.ge.3) write (6,*) ' *** I ind ',IOLD -C - JLOW=1 - IF (NSI.EQ.NSK.AND.IOLD.EQ.KOLD) JLOW=LOLD - JUP=NORB(NSJ) - IF (NSI.EQ.NSJ) JUP=IOLD - DO 404 JOLD=JLOW,JUP - if (fullprint.ge.3) write (6,*) ' **** J ind ',JOLD -C -c -c* read block of integrals if neccesarry -c - if (indtemp.eq.(indmax+1)) then - indtemp=1 -c read block - CALL dDAFILE(LUINTM,2,TWO,INDMAX,IDIS13) - end if -c -c* write integrals to appropriate possitions -c - val1=TWO(indtemp) -c -c:1 combination (ij|kl) -> (ij|kl) -c since yes1 is always 1, if structure is skipped - ind(1)=iold - ind(2)=jold - ind(3)=kold - ind(4)=lold - j1=ind(nj) - l1=ind(nl) - i1=ind(ni) - k1=ind(nk) -c -c:2 def iklj - ik=pqind(i1,k1) - jl=pqind(j1,l1) - if (ik.ge.jl) then - ikjl=ik*(ik-1)/2+jl - else - ikjl=jl*(jl-1)/2+ik - end if -c - Vic(ikjl)=val1 -c -c - indtemp=indtemp+1 -c - 404 CONTINUE - 403 CONTINUE - 402 CONTINUE - 401 CONTINUE -C -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/esb_ic_3.F90 openmolcas-22.10/src/ccsort_util/esb_ic_3.F90 --- openmolcas-22.02/src/ccsort_util/esb_ic_3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/esb_ic_3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,144 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine esb_ic_3(symp,Vic,dimp,pqind) +! this routine realizes expansion of symmetry block +! symp,symq,symr,syms <-> (IJ|KL), +! (for case symp=symr=symq=syms) +! provided such integrals exist +! It finds corresponding (IJ|KL) and expands it to +! matrix vic (prqs) + +use ccsort_global, only: fullprint, idis, LUINTM, mbas, NORB, np, nq, nr, ns +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: symp, dimp +real(kind=wp), intent(_OUT_) :: Vic((dimp*(dimp+1)/2)*((dimp*(dimp+1)/2)+1)/2) +integer(kind=iwp), intent(out) :: pqind(mbas,mbas) +#include "tratoc.fh" +integer(kind=iwp) :: i, i1, idis13, ik, ikjl, ilow, ind(4), indtemp, iold, iup, j, j1, jl, jlow, jold, jup, k1, kold, kup, l1, & + lold, lup, maxx, ni, nj, nk, nl, nsi, nsj, nsk, nsl +real(kind=wp) :: val1 +real(kind=wp), allocatable :: TWO(:) + +!I calc pqind + +!LD if (dimp >= dimp) then +maxx = dimp +!LD else +!LD maxx = dimq +!LD end if + +do i=1,maxx + do j=1,maxx + if (i >= j) then + pqind(i,j) = i*(i-1)/2+j + else + pqind(i,j) = j*(j-1)/2+i + end if + end do +end do + +!II get address +idis13 = idis(symp,symp,symp) + +!III.1 define order of indices + +ni = np(symp,symp,symp) +nj = nq(symp,symp,symp) +nk = nr(symp,symp,symp) +nl = ns(symp,symp,symp) + +! define NSI,NSJ,NSK,NSL +ind(ni) = symp +ind(nj) = symp +ind(nk) = symp +ind(nl) = symp +NSI = ind(1) +NSJ = ind(2) +NSK = ind(3) +NSL = ind(4) + +call mma_allocate(TWO,nTraBuf,label='TWO') + +indtemp = nTraBuf+1 +KUP = NORB(NSK) +do KOLD=1,KUP + if (fullprint >= 3) write(u6,*) ' * K ind ',KOLD + + LUP = NORB(NSL) + if (NSK == NSL) LUP = KOLD + do LOLD=1,LUP + if (fullprint >= 3) write(u6,*) ' ** L ind ',LOLD + + ILOW = 1 + if (NSI == NSK) ILOW = KOLD + IUP = NORB(NSI) + do IOLD=ILOW,IUP + if (fullprint >= 3) write(u6,*) ' *** I ind ',IOLD + + JLOW = 1 + if ((NSI == NSK) .and. (IOLD == KOLD)) JLOW = LOLD + JUP = NORB(NSJ) + if (NSI == NSJ) JUP = IOLD + do JOLD=JLOW,JUP + if (fullprint >= 3) write(u6,*) ' **** J ind ',JOLD + + ! read block of integrals if necessary + + if (indtemp == (nTraBuf+1)) then + indtemp = 1 + ! read block + call dDAFILE(LUINTM,2,TWO,nTraBuf,IDIS13) + end if + + ! write integrals to appropriate positions + + val1 = TWO(indtemp) + + !:1 combination (ij|kl) -> (ij|kl) + ! since yes1 is always 1, if structure is skipped + ind(1) = iold + ind(2) = jold + ind(3) = kold + ind(4) = lold + j1 = ind(nj) + l1 = ind(nl) + i1 = ind(ni) + k1 = ind(nk) + + !:2 def iklj + ik = pqind(i1,k1) + jl = pqind(j1,l1) + if (ik >= jl) then + ikjl = ik*(ik-1)/2+jl + else + ikjl = jl*(jl-1)/2+ik + end if + + Vic(ikjl) = val1 + + indtemp = indtemp+1 + + end do + end do + end do +end do + +call mma_deallocate(TWO) + +return + +end subroutine esb_ic_3 diff -Nru openmolcas-22.02/src/ccsort_util/expandfok.f openmolcas-22.10/src/ccsort_util/expandfok.f --- openmolcas-22.02/src/ccsort_util/expandfok.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/expandfok.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,82 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine expandfok (wrk,wrksize, - & fok) -c -c This routine expand fok operator to #2 -c it also defines new mapd2,mapi2 -c -#include "wrk.fh" -#include "reorg.fh" -#include "ccsort.fh" - real*8 fok(*) -c -c help variables -c - integer symp,symq,symr,posstemp,pqwrk,qpwrk,pqfok,p,q -c -c* set mapi zero -c - do 1 symr=1,nsym - do 2 symq=1,nsym - do 3 symp=1,nsym - mapi2(symp,symq,symr)=0 - 3 continue - 2 continue - 1 continue - -c -c* def zeroth row of mapd -c - mapd2(0,1)=5 - mapd2(0,2)=5 - mapd2(0,3)=0 - mapd2(0,4)=0 - mapd2(0,5)=nsym - mapd2(0,6)=0 -c - posstemp=poss20 - pqfok=0 - do 1000 symp=1,nsym -c -c* def mapd,mapi -c - mapd2(symp,1)=posstemp - mapd2(symp,2)=norb(symp)*norb(symp) - mapd2(symp,3)=symp - mapd2(symp,4)=symp - mapd2(symp,5)=1 - mapd2(symp,6)=1 - mapi2(symp,1,1)=symp -c -c* expand -c - do 100 p=1,norb(symp) - do 101 q=1,p -c -c* calc pq and qp possition in work and fok -c and write integrals to this possitions -c - pqwrk=posstemp+(norb(symp)*(p-1)+q)-1 - qpwrk=posstemp+(norb(symp)*(q-1)+p)-1 - pqfok=pqfok+1 - wrk(pqwrk)=fok(pqfok) - wrk(qpwrk)=fok(pqfok) -c - 101 continue - 100 continue -c - posstemp=posstemp+mapd2(symp,2) -c - 1000 continue -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/expandfok.F90 openmolcas-22.10/src/ccsort_util/expandfok.F90 --- openmolcas-22.02/src/ccsort_util/expandfok.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/expandfok.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,77 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine expandfok(wrk,wrksize,fok) +! This routine expands fok operator to #2 +! it also defines new mapd2,mapi2 + +use ccsort_global, only: mapd2, mapi2, NORB, NSYM, pos20 +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: wrksize +real(kind=wp), intent(_OUT_) :: wrk(wrksize) +real(kind=wp), intent(in) :: fok(*) +integer(kind=iwp) :: p, postemp, pqfok, pqwrk, q, qpwrk, symp + +! set mapi zero + +mapi2(1:nsym,1:nsym,1:nsym) = 0 + +! def zeroth row of mapd + +mapd2(0,1) = 5 +mapd2(0,2) = 5 +mapd2(0,3) = 0 +mapd2(0,4) = 0 +mapd2(0,5) = nsym +mapd2(0,6) = 0 + +postemp = pos20 +pqfok = 0 +do symp=1,nsym + + ! def mapd,mapi + + mapd2(symp,1) = postemp + mapd2(symp,2) = norb(symp)*norb(symp) + mapd2(symp,3) = symp + mapd2(symp,4) = symp + mapd2(symp,5) = 1 + mapd2(symp,6) = 1 + mapi2(symp,1,1) = symp + + ! expand + + do p=1,norb(symp) + do q=1,p + + ! calc pq and qp position in work and fok + ! and write integrals to this positions + + pqwrk = postemp+(norb(symp)*(p-1)+q)-1 + qpwrk = postemp+(norb(symp)*(q-1)+p)-1 + pqfok = pqfok+1 + wrk(pqwrk) = fok(pqfok) + wrk(qpwrk) = fok(pqfok) + + end do + end do + + postemp = postemp+mapd2(symp,2) + +end do + +return + +end subroutine expandfok diff -Nru openmolcas-22.02/src/ccsort_util/expmpq.f openmolcas-22.10/src/ccsort_util/expmpq.f --- openmolcas-22.02/src/ccsort_util/expmpq.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/expmpq.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,96 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine expmpq (wrk,wrksize, - & syma,typv3,typm,typp,typq,directyes, - & inverseyes) -c -c this routine realize reorganization to -c #3 with given typv3 and typm,p,q <- #2 -c #2 is in shape for symm,sympp,symqq with types -c _a m,pp,qq - 1,5,5 -c #3 may be antisymetrized or not, two parameters (directyes, -c inverseyes) can be deduced trom typv3 and typm,p,q and syma -c but for simplicity these are as input parameters -c this routine allow to use typv3=0 and 2 -c -c syma - irrep of a -c typv3 - typ of final #2 (I) -c typm,p,q - types of ind. m,p,q (I) -c directyes - 1 if direct integrals are included (I) -c inverseyes- 1 if inverse integrals are included (I) -c -c foreingh routines used: grc0 -c ccsort_mv0zero -c -c it also defines new mapd2,mapi2 corresponding to #2 -c -#include "wrk.fh" -#include "reorg.fh" -#include "ccsort.fh" - integer typv3,typp,typq,typm,syma,directyes,inverseyes -c -c help variables -c - integer symp,symq,symm,possv3,length - integer ii,iiv2d,iiv2i,possv2d,possv2i - integer posst -c -c* get mapd mapi of as _a(m,p q) into mapd3,mapi3 -c - call ccsort_grc0 (3,typv3,typm,typp,typq,0,syma, - & poss30,posst,mapd3,mapi3) -c -c* realize reorganization psb -c - do 100 ii=1,mapd3(0,5) -c -c* def parameters of #3 - possv3=mapd3(ii,1) - length=mapd3(ii,2) - symm=mapd3(ii,3) - symp=mapd3(ii,4) - symq=mapd3(ii,5) -c -c* vanish #3 - call ccsort_mv0zero (length,length,wrk(possv3)) -c - if (directyes.eq.1) then -c -c** def possition #2 direct (i.e. - iiv2d=mapi2(symm,symq,1) - possv2d=mapd2(iiv2d,1) -c -c** do #3 <- #2 (i.e. direct) - call mreorg (wrk,wrksize, - & symm,symp,symq,typm,typp,typq, - & 1,3,2,1,5,5, - & typv3,possv2d,possv3,1.0d0) -c - end if -c - if (inverseyes.eq.1) then -c -c** def possition #2 inverse (i.e. #2 ) - iiv2i=mapi2(symm,symp,1) - possv2i=mapd2(iiv2i,1) -c -c** do #3 <- - #2 (i.e. inverse) - call mreorg (wrk,wrksize, - & symm,symp,symq,typm,typp,typq, - & 1,2,3,1,5,5, - & typv3,possv2i,possv3,-1.0d0) -c - end if -c - 100 continue -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/expmpq.F90 openmolcas-22.10/src/ccsort_util/expmpq.F90 --- openmolcas-22.02/src/ccsort_util/expmpq.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/expmpq.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,88 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine expmpq(wrk,wrksize,syma,typv3,typm,typp,typq,directyes,inverseyes) +! this routine realizes reorganization to +! #3 with given typv3 and typm,p,q <- #2 +! #2 is in shape for symm,sympp,symqq with types +! _a m,pp,qq - 1,5,5 +! #3 may be antisymmetrized or not, two parameters (directyes, +! inverseyes) can be deduced trom typv3 and typm,p,q and syma +! but for simplicity these are as input parameters +! this routine allows to use typv3=0 and 2 +! +! syma - irrep of a +! typv3 - typ of final #2 (I) +! typm,p,q - types of ind. m,p,q (I) +! directyes - 1 if direct integrals are included (I) +! inverseyes- 1 if inverse integrals are included (I) +! +! foreign routines used: +! grc0 +! +! it also defines new mapd2,mapi2 corresponding to #2 + +use ccsort_global, only: mapd2, mapd3, mapi2, mapi3, pos30 +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: wrksize, syma, typv3, typm, typp, typq, directyes, inverseyes +real(kind=wp), intent(_OUT_) :: wrk(wrksize) +integer(kind=iwp) :: ii, iiv2d, iiv2i, length, post, posv2d, posv2i, posv3, symm, symp, symq + +! get mapd mapi of as _a(m,p q) into mapd3,mapi3 + +call ccsort_grc0(3,typv3,typm,typp,typq,0,syma,pos30,post,mapd3,mapi3) + +! realize reorganization psb + +do ii=1,mapd3(0,5) + + ! def parameters of #3 + posv3 = mapd3(ii,1) + length = mapd3(ii,2) + symm = mapd3(ii,3) + symp = mapd3(ii,4) + symq = mapd3(ii,5) + + ! vanish #3 + wrk(posv3:posv3+length-1) = Zero + + if (directyes == 1) then + + ! def position #2 direct (i.e. + iiv2d = mapi2(symm,symq,1) + posv2d = mapd2(iiv2d,1) + + ! do #3 <- #2 (i.e. direct) + call mreorg(wrk,wrksize,symm,symp,symq,typm,typp,typq,1,3,2,1,5,5,typv3,posv2d,posv3,One) + + end if + + if (inverseyes == 1) then + + ! def position #2 inverse (i.e. #2 ) + iiv2i = mapi2(symm,symp,1) + posv2i = mapd2(iiv2i,1) + + ! do #3 <- - #2 (i.e. inverse) + call mreorg(wrk,wrksize,symm,symp,symq,typm,typp,typq,1,2,3,1,5,5,typv3,posv2i,posv3,-One) + + end if + +end do + +return + +end subroutine expmpq diff -Nru openmolcas-22.02/src/ccsort_util/exppqij.f openmolcas-22.10/src/ccsort_util/exppqij.f --- openmolcas-22.02/src/ccsort_util/exppqij.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/exppqij.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,148 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine exppqij (wrk,wrksize, - & typv2,typp,typq,typr,typs,directyes, - & inverseyes) -c -c this routine realize reorganization to -c #2

with given typv2 and typp-typs <- #1 -c #1 is in shape for sympp,symqq,symi>=symj with types -c pp,qq,i,j -5,5,1,1 -c #2

may be antisymetrized or not, two parameters (directyes, -c inverseyes) can be deduced trom typv2 and typp-s, but for simplicity -c thes are as input parameters -c this routine do not allow to use typv2=2 -c -c typv2 - typ of final #2 (I) -c typp-s - types of ind. p-s (I) -c directyes - 1 if direct integrals are included (I) -c inverseyes- 1 if inverse integrals are included (I) -c -c foreingh routines used: grc0 -c ccsort_mv0zero -c -c it also defines new mapd2,mapi2 corresponding to #2 -c -#include "wrk.fh" -#include "reorg.fh" -#include "ccsort.fh" - integer typv2,typp,typq,typr,typs,directyes,inverseyes -c -c help variables -c - integer symp,symq,symi,symj,possv2,length - integer ii,iiv1d,iiv1i,possv1d,possv1i - integer posst -c -c* get mapd mapi of into mapd2,mapi2 -c - call ccsort_grc0 (4,typv2,typp,typq,typr,typs,1, - & poss20,posst,mapd2,mapi2) -c -c* realize reorganization psb -c - do 100 ii=1,mapd2(0,5) -c -c* def parameters of #2 - possv2=mapd2(ii,1) - length=mapd2(ii,2) - symp=mapd2(ii,3) - symq=mapd2(ii,4) - symi=mapd2(ii,5) - symj=mapd2(ii,6) -c -c* skip this step if length=0 - if (length.eq.0) then - goto 100 - end if -c -c* vanish #2 - call ccsort_mv0zero (length,length,wrk(possv2)) -c - if (symi.ge.symj) then -c* case symi>=symj - integrals in #1 are in that shape -c - if (directyes.eq.1) then -c** def possition #1 direct (i.e. #1 ) -c direct integrals are always used - iiv1d=mapi1(symp,symq,symi) - possv1d=mapd1(iiv1d,1) -c -c** do #2

<- #1 (i.e. direct) -c N.B. Since #1 is always >= symj -c so in this case orede of indices in #1 and #2 is the same - call ireorg (wrk,wrksize, - & symp,symq,symi,symj,typp,typq,typr,typs, - & 1,2,3,4,5,5,1,1, - & typv2,possv1d,possv2,1.0d0) -c - end if -c - if (inverseyes.eq.1) then -c -c** def possition #1 inverse (i.e. #1 ) -c inverse integrals are used only if antysymetry is required - iiv1i=mapi1(symq,symp,symi) - possv1i=mapd1(iiv1i,1) -c -c** do #2

<- - #1 (i.e. inverse) -c N.B. Since #1 is always >= symj -c so in this case orede of indices in #1 and #2 are inversed 1<->2 - call ireorg (wrk,wrksize, - & symp,symq,symi,symj,typp,typq,typr,typs, - & 2,1,3,4,5,5,1,1, - & typv2,possv1i,possv2,-1.0d0) -c - end if -c - else -c* case symi=symj) shape -c - if (directyes.eq.1) then -c -c** def possition #1 direct (i.e. #1 ) -c direct integrals are always used - iiv1d=mapi1(symq,symp,symj) - possv1d=mapd1(iiv1d,1) -c -c** do #2

<- #1 (i.e. direct) -c N.B. Since #1 is always >= symj -c so in this case orede of indices in #1 and #2 is inversed 1<->2, 3<->4 - call ireorg (wrk,wrksize, - & symp,symq,symi,symj,typp,typq,typr,typs, - & 2,1,4,3,5,5,1,1, - & typv2,possv1d,possv2,1.0d0) -c - end if -c - if (inverseyes.eq.1) then -c -c** def possition #1 inverse (i.e. #1 ) -c inverse integrals are used only if antysymetry is required - iiv1i=mapi1(symp,symq,symj) - possv1i=mapd1(iiv1i,1) -c -c** do #2

<- - #1 (i.e. inverse) -c N.B. Since #1 is always >= symj -c so in this case orede of indices in #1 and #2 are inversed 3<->4 - call ireorg (wrk,wrksize, - & symp,symq,symi,symj,typp,typq,typr,typs, - & 1,2,4,3,5,5,1,1, - & typv2,possv1i,possv2,-1.0d0) -c - end if -c - end if -c - 100 continue -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/exppqij.F90 openmolcas-22.10/src/ccsort_util/exppqij.F90 --- openmolcas-22.02/src/ccsort_util/exppqij.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/exppqij.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,132 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine exppqij(wrk,wrksize,typv2,typp,typq,typr,typs,directyes,inverseyes) +! this routine realizes reorganization to +! #2

with given typv2 and typp-typs <- #1 +! #1 is in shape for sympp,symqq,symi>=symj with types +! pp,qq,i,j -5,5,1,1 +! #2

may be antisymmetrized or not, two parameters (directyes, +! inverseyes) can be deduced trom typv2 and typp-s, but for simplicity +! these are as input parameters +! this routine does not allow to use typv2=2 +! +! typv2 - typ of final #2 (I) +! typp-s - types of ind. p-s (I) +! directyes - 1 if direct integrals are included (I) +! inverseyes- 1 if inverse integrals are included (I) +! +! foreign routines used: +! grc0 +! +! it also defines new mapd2,mapi2 corresponding to #2 + +use ccsort_global, only: mapd1, mapd2, mapi1, mapi2, pos20 +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: wrksize, typv2, typp, typq, typr, typs, directyes, inverseyes +real(kind=wp), intent(_OUT_) :: wrk(wrksize) +integer(kind=iwp) :: ii, iiv1d, iiv1i, length, post, posv1d, posv1i, posv2, symi, symj, symp, symq + +! get mapd mapi of into mapd2,mapi2 + +call ccsort_grc0(4,typv2,typp,typq,typr,typs,1,pos20,post,mapd2,mapi2) + +! realize reorganization psb + +do ii=1,mapd2(0,5) + + ! def parameters of #2 + posv2 = mapd2(ii,1) + length = mapd2(ii,2) + symp = mapd2(ii,3) + symq = mapd2(ii,4) + symi = mapd2(ii,5) + symj = mapd2(ii,6) + + ! skip this step if length=0 + if (length == 0) cycle + + ! vanish #2 + wrk(posv2:posv2+length-1) = Zero + + if (symi >= symj) then + ! case symi>=symj - integrals in #1 are in that shape + + if (directyes == 1) then + ! def position #1 direct (i.e. #1 ) + ! direct integrals are always used + iiv1d = mapi1(symp,symq,symi) + posv1d = mapd1(iiv1d,1) + + ! do #2

<- #1 (i.e. direct) + ! N.B. Since #1 is always >= symj + ! so in this case order of indices in #1 and #2 is the same + call ireorg(wrk,wrksize,symp,symq,symi,symj,typp,typq,typr,typs,1,2,3,4,5,5,1,1,typv2,posv1d,posv2,One) + + end if + + if (inverseyes == 1) then + + ! def position #1 inverse (i.e. #1 ) + ! inverse integrals are used only if antisymmetry is required + iiv1i = mapi1(symq,symp,symi) + posv1i = mapd1(iiv1i,1) + + ! do #2

<- - #1 (i.e. inverse) + ! N.B. Since #1 is always >= symj + ! so in this case order of indices in #1 and #2 are inversed 1<->2 + call ireorg(wrk,wrksize,symp,symq,symi,symj,typp,typq,typr,typs,2,1,3,4,5,5,1,1,typv2,posv1i,posv2,-One) + + end if + + else + ! case symi=symj) shape + + if (directyes == 1) then + + ! def position #1 direct (i.e. #1 ) + ! direct integrals are always used + iiv1d = mapi1(symq,symp,symj) + posv1d = mapd1(iiv1d,1) + + ! do #2

<- #1 (i.e. direct) + ! N.B. Since #1 is always >= symj + ! so in this case order of indices in #1 and #2 is inversed 1<->2, 3<->4 + call ireorg(wrk,wrksize,symp,symq,symi,symj,typp,typq,typr,typs,2,1,4,3,5,5,1,1,typv2,posv1d,posv2,One) + + end if + + if (inverseyes == 1) then + + ! def position #1 inverse (i.e. #1 ) + ! inverse integrals are used only if antisymmetry is required + iiv1i = mapi1(symp,symq,symj) + posv1i = mapd1(iiv1i,1) + + ! do #2

<- - #1 (i.e. inverse) + ! N.B. Since #1 is always >= symj + ! so in this case order of indices in #1 and #2 are inversed 3<->4 + call ireorg(wrk,wrksize,symp,symq,symi,symj,typp,typq,typr,typs,1,2,4,3,5,5,1,1,typv2,posv1i,posv2,-One) + + end if + + end if + +end do + +return + +end subroutine exppqij diff -Nru openmolcas-22.02/src/ccsort_util/exppsb.f openmolcas-22.10/src/ccsort_util/exppsb.f --- openmolcas-22.02/src/ccsort_util/exppsb.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/exppsb.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,417 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine exppsb (symp,symq,symr,syms, - & valn,jn,kn,ln) -c -c this routine realize expansion of symmetry block -c symp,symq,symr,syms <-> (IJ|KL), provided such integrals exists -c It found corresponding (IJ|KL) and expand it to opened -c NORB(symp) TEMP files with a structure -c indq,indr,inds,value, each TEMP for one p -c -c N.B. This process can be accelerated, if exppbs would be -c divided into exppsb1-8, each for given typ, since this -c routine is common for all types. -c -c types of (ij|kl) NI,J,K,L defined in III -c -c 1 - si=sk, si=sj, sk=sl -c 2 - si=sk, si=sj, sk>sl -c 3 - si=sk, si>sj, sk=sl -c 4 - si=sk, si>sj, sk>sl -c 5 - si>sk, si=sj, sk=sl -c 6 - si>sk, si=sj, sk>sl -c 7 - si>sk, si>sj, sk=sl -c 8 - si>sk, si>sj, sk>sl -c -c - implicit real*8 (a-h,o-z) - - -#include "SysDef.fh" -#include "reorg.fh" -#include "ccsort.fh" -c - integer symp,symq,symr,syms - real*8 valn(1:nsize,1:mbas) - integer jn(1:nsize,1:mbas) - integer kn(1:nsize,1:mbas) - integer ln(1:nsize,1:mbas) -c -c help variables -c - integer idis13,indtemp - integer ni,nj,nk,nl,nsi,nsj,nsk,nsl,i1,j1,k1,l1 - integer iup,ilow,jup,jlow,kup,lup,iold,jold,kold,lold -c - integer nhelp1,nhelp2,m3 - integer yes234,yes5,yes678 - integer typp - integer ind(1:4) -#include "tratoc.fh" - integer INDMAX - parameter (INDMAX=nTraBuf) - REAL*8 TWO(INDMAX) -c -cI get adress - idis13=idis(symp,symq,symr) -c -cII prepairing nshow vector -c - do nhelp1=1,norb(symp) - nshow(nhelp1)=0 - end do -c -cIII.1define order of indices -c - ni=np(symp,symq,symr) - nj=nq(symp,symq,symr) - nk=nr(symp,symq,symr) - nl=ns(symp,symq,symr) -c -cIII.2def yes1-8 -c - typp=typ(symp,symq,symr) -c -c:1 combination (ij|kl) -> (ij|kl) -c used in types: 1,2,3,4,5,6,7,8 (all) -c yes1=1 -c -c:2 combination (ij|kl) -> (ji|kl) -c:3 combination (ij|kl) -> (ij|lk) -c:4 combination (ij|kl) -> (ji|lk) -c used in types: 1,5 since 2,3,6,7 never appear - if ((typp.eq.1).or.(typp.eq.5)) then - yes234=1 - else - yes234=0 - end if -c -c:5 combination (ij|kl) -> (kl|ij) -c used in types: 1,2,3,4 - if ((typp.ge.1).and.(typp.le.4)) then - yes5=1 - else - yes5=0 - end if -c -c:6 combination (ij|kl) -> (lk|ij) -c:7 combination (ij|kl) -> (kl|ji) -c:8 combination (ij|kl) -> (lk|ji) -c used in types: 1 (since 2,3 never appeard) - if (typp.eq.1) then - yes678=1 - else - yes678=0 - end if -c -c -c define NSI,NSJ,NSK,NSL - ind(ni)=symp - ind(nj)=symq - ind(nk)=symr - ind(nl)=syms - NSI=ind(1) - NSJ=ind(2) - NSK=ind(3) - NSL=ind(4) -C - indtemp=indmax+1 - KUP=NORB(NSK) - DO 401 KOLD=1,KUP - if (fullprint.ge.3) write (6,*) ' * K ind ',KOLD -C - LUP=NORB(NSL) - IF (NSK.EQ.NSL) LUP=KOLD - DO 402 LOLD=1,LUP - if (fullprint.ge.3) write (6,*) ' ** L ind ',LOLD -C - ILOW=1 - IF (NSI.EQ.NSK) ILOW=KOLD - IUP=NORB(NSI) - DO 403 IOLD=ILOW,IUP - if (fullprint.ge.3) write (6,*) ' *** I ind ',IOLD -C - JLOW=1 - IF (NSI.EQ.NSK.AND.IOLD.EQ.KOLD) JLOW=LOLD - JUP=NORB(NSJ) - IF (NSI.EQ.NSJ) JUP=IOLD - DO 404 JOLD=JLOW,JUP - if (fullprint.ge.3) write (6,*) ' **** J ind ',JOLD -C -c -c* read block of integrals if necessary -c - if (indtemp.eq.(indmax+1)) then - indtemp=1 -c read block - CALL dDAFILE(LUINTM,2,TWO,INDMAX,IDIS13) - end if -c -c* write integrals to appropriate positions -c - val1=TWO(indtemp) -c -c:1 combination (ij|kl) -> (ij|kl) -c since yes1 is always 1, if structure is skipped - ind(1)=iold - ind(2)=jold - ind(3)=kold - ind(4)=lold - j1=ind(nj) - l1=ind(nl) - if (symq.eq.syms) then - if (l1.gt.j1) then - goto 21 - end if - end if - i1=ind(ni) - k1=ind(nk) -c - m3=nshow(i1)+1 - jn(m3,i1)=j1 - kn(m3,i1)=k1 - ln(m3,i1)=l1 - valn(m3,i1)=val1 - nshow(i1)=m3 -c - if (m3.eq.nsize) then - call zasun (i1,nsize, - & valn,jn,kn,ln) - nshow(i1)=0 - end if -c - 21 if (yes234.eq.1) then -c -c:2 combination (ij|kl) -> (ji|kl) - ind(1)=jold - ind(2)=iold - ind(3)=kold - ind(4)=lold - j1=ind(nj) - l1=ind(nl) - if (symq.eq.syms) then - if (l1.gt.j1) then - goto 31 - end if - end if - i1=ind(ni) - k1=ind(nk) -c - m3=nshow(i1)+1 - jn(m3,i1)=j1 - kn(m3,i1)=k1 - ln(m3,i1)=l1 - valn(m3,i1)=val1 - nshow(i1)=m3 -c - if (m3.eq.nsize) then - call zasun (i1,nsize, - & valn,jn,kn,ln) - nshow(i1)=0 - end if -c -c:3 combination (ij|kl) -> (ij|lk) - 31 ind(1)=iold - ind(2)=jold - ind(3)=lold - ind(4)=kold - j1=ind(nj) - l1=ind(nl) - if (symq.eq.syms) then - if (l1.gt.j1) then - goto 41 - end if - end if - i1=ind(ni) - k1=ind(nk) -c - m3=nshow(i1)+1 - jn(m3,i1)=j1 - kn(m3,i1)=k1 - ln(m3,i1)=l1 - valn(m3,i1)=val1 - nshow(i1)=m3 -c - if (m3.eq.nsize) then - call zasun (i1,nsize, - & valn,jn,kn,ln) - nshow(i1)=0 - end if -c -c:4 combination (ij|kl) -> (ji|lk) - 41 ind(1)=jold - ind(2)=iold - ind(3)=lold - ind(4)=kold - j1=ind(nj) - l1=ind(nl) - if (symq.eq.syms) then - if (l1.gt.j1) then - goto 51 - end if - end if - i1=ind(ni) - k1=ind(nk) -c - m3=nshow(i1)+1 - jn(m3,i1)=j1 - kn(m3,i1)=k1 - ln(m3,i1)=l1 - valn(m3,i1)=val1 - nshow(i1)=m3 -c - if (m3.eq.nsize) then - call zasun (i1,nsize, - & valn,jn,kn,ln) - nshow(i1)=0 - end if -c - end if -c -c:5 combination (ij|kl) -> (kl|ij) - 51 if (yes5.eq.1) then - ind(1)=kold - ind(2)=lold - ind(3)=iold - ind(4)=jold - j1=ind(nj) - l1=ind(nl) - if (symq.eq.syms) then - if (l1.gt.j1) then - goto 61 - end if - end if - i1=ind(ni) - k1=ind(nk) -c - m3=nshow(i1)+1 - jn(m3,i1)=j1 - kn(m3,i1)=k1 - ln(m3,i1)=l1 - valn(m3,i1)=val1 - nshow(i1)=m3 -c - if (m3.eq.nsize) then - call zasun (i1,nsize, - & valn,jn,kn,ln) - nshow(i1)=0 - end if - end if -c - 61 if (yes678.eq.1) then -c -c:6 combination (ij|kl) -> (lk|ij) - ind(1)=lold - ind(2)=kold - ind(3)=iold - ind(4)=jold - j1=ind(nj) - l1=ind(nl) - if (symq.eq.syms) then - if (l1.gt.j1) then - goto 71 - end if - end if - i1=ind(ni) - k1=ind(nk) -c - m3=nshow(i1)+1 - jn(m3,i1)=j1 - kn(m3,i1)=k1 - ln(m3,i1)=l1 - valn(m3,i1)=val1 - nshow(i1)=m3 -c - if (m3.eq.nsize) then - call zasun (i1,nsize, - & valn,jn,kn,ln) - nshow(i1)=0 - end if -c -c:7 combination (ij|kl) -> (kl|ji) - 71 ind(1)=kold - ind(2)=lold - ind(3)=jold - ind(4)=iold - j1=ind(nj) - l1=ind(nl) - if (symq.eq.syms) then - if (l1.gt.j1) then - goto 81 - end if - end if - i1=ind(ni) - k1=ind(nk) -c - m3=nshow(i1)+1 - jn(m3,i1)=j1 - kn(m3,i1)=k1 - ln(m3,i1)=l1 - valn(m3,i1)=val1 - nshow(i1)=m3 -c - if (m3.eq.nsize) then - call zasun (i1,nsize, - & valn,jn,kn,ln) - nshow(i1)=0 - end if -c -c:8 combination (ij|kl) -> (lk|ji) - 81 ind(1)=lold - ind(2)=kold - ind(3)=jold - ind(4)=iold - j1=ind(nj) - l1=ind(nl) - if (symq.eq.syms) then - if (l1.gt.j1) then - goto 100 - end if - end if - i1=ind(ni) - k1=ind(nk) -c - m3=nshow(i1)+1 - jn(m3,i1)=j1 - kn(m3,i1)=k1 - ln(m3,i1)=l1 - valn(m3,i1)=val1 - nshow(i1)=m3 -c - if (m3.eq.nsize) then - call zasun (i1,nsize, - & valn,jn,kn,ln) - nshow(i1)=0 - end if -c - end if -c - 100 indtemp=indtemp+1 -c - 404 CONTINUE - 403 CONTINUE - 402 CONTINUE - 401 CONTINUE -C -c -cIV write the rest integrals if needed -c - do nhelp1=1,norb(symp) - nhelp2=nshow(nhelp1) - if (nhelp2.gt.0) then - call zasun (nhelp1,nhelp2, - & valn,jn,kn,ln) - end if - end do -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/exppsb.F90 openmolcas-22.10/src/ccsort_util/exppsb.F90 --- openmolcas-22.02/src/ccsort_util/exppsb.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/exppsb.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,366 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine exppsb(symp,symq,symr,syms,valn,jn,kn,ln) +! this routine realizes expansion of symmetry block +! symp,symq,symr,syms <-> (IJ|KL), provided such integrals exist +! It finds corresponding (IJ|KL) and expands it to open +! NORB(symp) TEMP files with a structure +! indq,indr,inds,value, each TEMP for one p +! +! N.B. This process can be accelerated, if exppbs would be +! divided into exppsb1-8, each for given typ, since this +! routine is common for all types. +! +! types of (ij|kl) NI,J,K,L defined in III +! +! 1 - si=sk, si=sj, sk=sl +! 2 - si=sk, si=sj, sk>sl +! 3 - si=sk, si>sj, sk=sl +! 4 - si=sk, si>sj, sk>sl +! 5 - si>sk, si=sj, sk=sl +! 6 - si>sk, si=sj, sk>sl +! 7 - si>sk, si>sj, sk=sl +! 8 - si>sk, si>sj, sk>sl + +use ccsort_global, only: fullprint, idis, LUINTM, mbas, NORB, np, nq, nr, ns, nshow, nsize, typ +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: symp, symq, symr, syms +real(kind=wp), intent(out) :: valn(nsize,mbas) +integer(kind=iwp), intent(out) :: jn(nsize,mbas), kn(nsize,mbas), ln(nsize,mbas) +#include "tratoc.fh" +integer(kind=iwp) :: i1, idis13, ilow, ind(4), indtemp, iold, iup, j1, jlow, jold, jup, k1, kold, kup, l1, lold, lup, m3, nhelp1, & + nhelp2, ni, nj, nk, nl, nsi, nsj, nsk, nsl, typp, yes234, yes5, yes678 +real(kind=wp) :: val1 +real(kind=wp), allocatable :: TWO(:) + +!I get address +idis13 = idis(symp,symq,symr) + +!II preparing nshow vector + +nshow(1:norb(symp)) = 0 + +!III.1 define order of indices + +ni = np(symp,symq,symr) +nj = nq(symp,symq,symr) +nk = nr(symp,symq,symr) +nl = ns(symp,symq,symr) + +!III.2 def yes1-8 + +typp = typ(symp,symq,symr) + +!:1 combination (ij|kl) -> (ij|kl) +! used in types: 1,2,3,4,5,6,7,8 (all) +!yes1 = 1 + +!:2 combination (ij|kl) -> (ji|kl) +!:3 combination (ij|kl) -> (ij|lk) +!:4 combination (ij|kl) -> (ji|lk) +! used in types: 1,5 since 2,3,6,7 never appear +if ((typp == 1) .or. (typp == 5)) then + yes234 = 1 +else + yes234 = 0 +end if + +!:5 combination (ij|kl) -> (kl|ij) +! used in types: 1,2,3,4 +if ((typp >= 1) .and. (typp <= 4)) then + yes5 = 1 +else + yes5 = 0 +end if + +!:6 combination (ij|kl) -> (lk|ij) +!:7 combination (ij|kl) -> (kl|ji) +!:8 combination (ij|kl) -> (lk|ji) +! used in types: 1 (since 2,3 never appeard) +if (typp == 1) then + yes678 = 1 +else + yes678 = 0 +end if + +! define NSI,NSJ,NSK,NSL +ind(ni) = symp +ind(nj) = symq +ind(nk) = symr +ind(nl) = syms +NSI = ind(1) +NSJ = ind(2) +NSK = ind(3) +NSL = ind(4) + +call mma_allocate(TWO,nTraBuf,label='TWO') + +indtemp = nTraBuf+1 +KUP = NORB(NSK) +do KOLD=1,KUP + if (fullprint >= 3) write(u6,*) ' * K ind ',KOLD + + LUP = NORB(NSL) + if (NSK == NSL) LUP = KOLD + do LOLD=1,LUP + if (fullprint >= 3) write(u6,*) ' ** L ind ',LOLD + + ILOW = 1 + if (NSI == NSK) ILOW = KOLD + IUP = NORB(NSI) + do IOLD=ILOW,IUP + if (fullprint >= 3) write(u6,*) ' *** I ind ',IOLD + + JLOW = 1 + if ((NSI == NSK) .and. (IOLD == KOLD)) JLOW = LOLD + JUP = NORB(NSJ) + if (NSI == NSJ) JUP = IOLD + do JOLD=JLOW,JUP + if (fullprint >= 3) write(u6,*) ' **** J ind ',JOLD + + ! read block of integrals if necessary + + if (indtemp == (nTraBuf+1)) then + indtemp = 1 + ! read block + call dDAFILE(LUINTM,2,TWO,nTraBuf,IDIS13) + end if + + ! write integrals to appropriate positions + + val1 = TWO(indtemp) + + !:1 combination (ij|kl) -> (ij|kl) + ! since yes1 is always 1, if structure is skipped + ind(1) = iold + ind(2) = jold + ind(3) = kold + ind(4) = lold + j1 = ind(nj) + l1 = ind(nl) + if ((symq /= syms) .or. (l1 <= j1)) then + i1 = ind(ni) + k1 = ind(nk) + + m3 = nshow(i1)+1 + jn(m3,i1) = j1 + kn(m3,i1) = k1 + ln(m3,i1) = l1 + valn(m3,i1) = val1 + nshow(i1) = m3 + + if (m3 == nsize) then + call zasun(i1,nsize,valn,jn,kn,ln) + nshow(i1) = 0 + end if + end if + + if (yes234 == 1) then + + !:2 combination (ij|kl) -> (ji|kl) + ind(1) = jold + ind(2) = iold + ind(3) = kold + ind(4) = lold + j1 = ind(nj) + l1 = ind(nl) + if ((symq /= syms) .or. (l1 <= j1)) then + i1 = ind(ni) + k1 = ind(nk) + + m3 = nshow(i1)+1 + jn(m3,i1) = j1 + kn(m3,i1) = k1 + ln(m3,i1) = l1 + valn(m3,i1) = val1 + nshow(i1) = m3 + + if (m3 == nsize) then + call zasun(i1,nsize,valn,jn,kn,ln) + nshow(i1) = 0 + end if + end if + + !:3 combination (ij|kl) -> (ij|lk) + ind(1) = iold + ind(2) = jold + ind(3) = lold + ind(4) = kold + j1 = ind(nj) + l1 = ind(nl) + if ((symq /= syms) .or. (l1 <= j1)) then + i1 = ind(ni) + k1 = ind(nk) + + m3 = nshow(i1)+1 + jn(m3,i1) = j1 + kn(m3,i1) = k1 + ln(m3,i1) = l1 + valn(m3,i1) = val1 + nshow(i1) = m3 + + if (m3 == nsize) then + call zasun(i1,nsize,valn,jn,kn,ln) + nshow(i1) = 0 + end if + end if + + !:4 combination (ij|kl) -> (ji|lk) + ind(1) = jold + ind(2) = iold + ind(3) = lold + ind(4) = kold + j1 = ind(nj) + l1 = ind(nl) + if ((symq /= syms) .or. (l1 <= j1)) then + i1 = ind(ni) + k1 = ind(nk) + + m3 = nshow(i1)+1 + jn(m3,i1) = j1 + kn(m3,i1) = k1 + ln(m3,i1) = l1 + valn(m3,i1) = val1 + nshow(i1) = m3 + + if (m3 == nsize) then + call zasun(i1,nsize,valn,jn,kn,ln) + nshow(i1) = 0 + end if + end if + + end if + + !:5 combination (ij|kl) -> (kl|ij) + if (yes5 == 1) then + ind(1) = kold + ind(2) = lold + ind(3) = iold + ind(4) = jold + j1 = ind(nj) + l1 = ind(nl) + if ((symq /= syms) .or. (l1 <= j1)) then + i1 = ind(ni) + k1 = ind(nk) + + m3 = nshow(i1)+1 + jn(m3,i1) = j1 + kn(m3,i1) = k1 + ln(m3,i1) = l1 + valn(m3,i1) = val1 + nshow(i1) = m3 + + if (m3 == nsize) then + call zasun(i1,nsize,valn,jn,kn,ln) + nshow(i1) = 0 + end if + end if + end if + + if (yes678 == 1) then + + !:6 combination (ij|kl) -> (lk|ij) + ind(1) = lold + ind(2) = kold + ind(3) = iold + ind(4) = jold + j1 = ind(nj) + l1 = ind(nl) + if ((symq /= syms) .or. (l1 <= j1)) then + i1 = ind(ni) + k1 = ind(nk) + + m3 = nshow(i1)+1 + jn(m3,i1) = j1 + kn(m3,i1) = k1 + ln(m3,i1) = l1 + valn(m3,i1) = val1 + nshow(i1) = m3 + + if (m3 == nsize) then + call zasun(i1,nsize,valn,jn,kn,ln) + nshow(i1) = 0 + end if + end if + + !:7 combination (ij|kl) -> (kl|ji) + ind(1) = kold + ind(2) = lold + ind(3) = jold + ind(4) = iold + j1 = ind(nj) + l1 = ind(nl) + if ((symq /= syms) .or. (l1 <= j1)) then + i1 = ind(ni) + k1 = ind(nk) + + m3 = nshow(i1)+1 + jn(m3,i1) = j1 + kn(m3,i1) = k1 + ln(m3,i1) = l1 + valn(m3,i1) = val1 + nshow(i1) = m3 + + if (m3 == nsize) then + call zasun(i1,nsize,valn,jn,kn,ln) + nshow(i1) = 0 + end if + end if + + !:8 combination (ij|kl) -> (lk|ji) + ind(1) = lold + ind(2) = kold + ind(3) = jold + ind(4) = iold + j1 = ind(nj) + l1 = ind(nl) + if ((symq /= syms) .or. (l1 <= j1)) then + i1 = ind(ni) + k1 = ind(nk) + + m3 = nshow(i1)+1 + jn(m3,i1) = j1 + kn(m3,i1) = k1 + ln(m3,i1) = l1 + valn(m3,i1) = val1 + nshow(i1) = m3 + + if (m3 == nsize) then + call zasun(i1,nsize,valn,jn,kn,ln) + nshow(i1) = 0 + end if + end if + + end if + + indtemp = indtemp+1 + + end do + end do + end do +end do + +call mma_deallocate(TWO) + +!IV write the rest integrals if needed + +do nhelp1=1,norb(symp) + nhelp2 = nshow(nhelp1) + if (nhelp2 > 0) call zasun(nhelp1,nhelp2,valn,jn,kn,ln) +end do + +return + +end subroutine exppsb diff -Nru openmolcas-22.02/src/ccsort_util/files_ccsd.fh openmolcas-22.10/src/ccsort_util/files_ccsd.fh --- openmolcas-22.02/src/ccsort_util/files_ccsd.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/files_ccsd.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -c -c include file with diska addresses for MOLCAS DA -c file handling -c - integer daddr(1:128) -c - common /diskaddr/ daddr -c diff -Nru openmolcas-22.02/src/ccsort_util/fokupdate1.f openmolcas-22.10/src/ccsort_util/fokupdate1.f --- openmolcas-22.02/src/ccsort_util/fokupdate1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/fokupdate1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,60 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine fokupdate1 (foka,fokb,symp,i,vint,ndimv1,ndimv2, - & ndimv3) -c -c this routine realize update -c foka(p,q) = foka(p,q) + -c fokb(p,q) = fokb(p,q) + -c -c N.B. integrals are of type -c -c foka - packed Fokaa matrix (I,O) -c fokb - packed Fokbb matrix (I,O) -c symp - irrep or p (and also q) index (I) -c i - value of i, (I) -c vint - array of integrals for given i (I) -c ndimv1 - first dimension (norb(symp)) (I) -c ndimv2 - second dimension (norb(symi)) (I) -c ndimv3 - third dimension (norb(symp)) (I) -c -#include "ccsort.fh" - real*8 foka(*) - real*8 fokb(*) - real*8 vint(1:ndimv1,1:ndimv2,1:ndimv3) - integer symp,i,ndimv1,ndimv2,ndimv3 -c -c help variables -c - integer nhelp1,nhelp2,p,q,pq -c -c* calculate shift -c - nhelp1=0 - if (symp.gt.1) then - do 100 nhelp2=1,symp-1 - nhelp1=nhelp1+(norb(nhelp2)**2+norb(nhelp2))/2 - 100 continue - end if -c -c* add integral -c - pq=nhelp1 - do 200 p=1,norb(symp) - do 201 q=1,p - pq=pq+1 - foka(pq)=foka(pq)+vint(p,i,q) - fokb(pq)=fokb(pq)+vint(p,i,q) - 201 continue - 200 continue -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/fokupdate1.F90 openmolcas-22.10/src/ccsort_util/fokupdate1.F90 --- openmolcas-22.02/src/ccsort_util/fokupdate1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/fokupdate1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,57 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine fokupdate1(foka,fokb,symp,i,vint,ndimv1,ndimv2,ndimv3) +! this routine realizes update +! foka(p,q) = foka(p,q) + +! fokb(p,q) = fokb(p,q) + +! +! N.B. integrals are of type +! +! foka - packed Fokaa matrix (I,O) +! fokb - packed Fokbb matrix (I,O) +! symp - irrep or p (and also q) index (I) +! i - value of i, (I) +! vint - array of integrals for given i (I) +! ndimv1 - first dimension (norb(symp)) (I) +! ndimv2 - second dimension (norb(symi)) (I) +! ndimv3 - third dimension (norb(symp)) (I) + +use ccsort_global, only: NORB +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(inout) :: foka(*), fokb(*) +integer(kind=iwp), intent(in) :: symp, i, ndimv1, ndimv2, ndimv3 +real(kind=wp), intent(in) :: vint(ndimv1,ndimv2,ndimv3) +integer(kind=iwp) :: nhelp1, nhelp2, p, pq, q + +! calculate shift + +nhelp1 = 0 +do nhelp2=1,symp-1 + nhelp1 = nhelp1+(norb(nhelp2)**2+norb(nhelp2))/2 +end do + +! add integral + +pq = nhelp1 +do p=1,norb(symp) + do q=1,p + pq = pq+1 + foka(pq) = foka(pq)+vint(p,i,q) + fokb(pq) = fokb(pq)+vint(p,i,q) + end do +end do + +return + +end subroutine fokupdate1 diff -Nru openmolcas-22.02/src/ccsort_util/fokupdate2.f openmolcas-22.10/src/ccsort_util/fokupdate2.f --- openmolcas-22.02/src/ccsort_util/fokupdate2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/fokupdate2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine fokupdate2 (foka,symp,i,vint,ndimv1,ndimv2,ndimv3) -c -c this routine realize update -c foka(p,q) = foka(p,q) - -c -c N.B. integrals are of type -c -c foka - packed Fokaa matrix (I,O) -c symp - irrep or p (and also q) index (I) -c i - value of i, (I) -c vint - array of integrals for given i (I) -c ndimv1 - first dimension (norb(symp)) (I) -c ndimv2 - second dimension (norb(symi)) (I) -c ndimv3 - third dimension (norb(symp)) (I) -c -#include "ccsort.fh" - real*8 foka(*) - real*8 vint(1:ndimv1,1:ndimv2,1:ndimv3) - integer symp,i,ndimv1,ndimv2,ndimv3 -c -c help variables -c - integer nhelp1,nhelp2,p,q,pq -c -c* calculate shift -c - nhelp1=0 - if (symp.gt.1) then - do 100 nhelp2=1,symp-1 - nhelp1=nhelp1+(norb(nhelp2)**2+norb(nhelp2))/2 - 100 continue - end if -c -c* add integral -c - pq=nhelp1 - do 200 p=1,norb(symp) - do 201 q=1,p - pq=pq+1 - foka(pq)=foka(pq)-vint(p,q,i) - 201 continue - 200 continue -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/fokupdate2.F90 openmolcas-22.10/src/ccsort_util/fokupdate2.F90 --- openmolcas-22.02/src/ccsort_util/fokupdate2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/fokupdate2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,54 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine fokupdate2(foka,symp,i,vint,ndimv1,ndimv2,ndimv3) +! this routine realizes update +! foka(p,q) = foka(p,q) - +! +! N.B. integrals are of type +! +! foka - packed Fokaa matrix (I,O) +! symp - irrep or p (and also q) index (I) +! i - value of i, (I) +! vint - array of integrals for given i (I) +! ndimv1 - first dimension (norb(symp)) (I) +! ndimv2 - second dimension (norb(symi)) (I) +! ndimv3 - third dimension (norb(symp)) (I) + +use ccsort_global, only: NORB +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(inout) :: foka(*) +integer(kind=iwp), intent(in) :: symp, i, ndimv1, ndimv2, ndimv3 +real(kind=wp), intent(in) :: vint(ndimv1,ndimv2,ndimv3) +integer(kind=iwp) :: nhelp1, nhelp2, p, pq, q + +! calculate shift + +nhelp1 = 0 +do nhelp2=1,symp-1 + nhelp1 = nhelp1+(norb(nhelp2)**2+norb(nhelp2))/2 +end do + +! add integral + +pq = nhelp1 +do p=1,norb(symp) + do q=1,p + pq = pq+1 + foka(pq) = foka(pq)-vint(p,q,i) + end do +end do + +return + +end subroutine fokupdate2 diff -Nru openmolcas-22.02/src/ccsort_util/getpp_pck.f openmolcas-22.10/src/ccsort_util/getpp_pck.f --- openmolcas-22.02/src/ccsort_util/getpp_pck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/getpp_pck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine getpp_pck (lunpublic,pp,length) -c - -#include "SysDef.fh" - integer lunpublic,length - character*(RtoB+ItoB) pp(1:length) -c - read (lunpublic) pp -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/getpp_zr.f openmolcas-22.10/src/ccsort_util/getpp_zr.f --- openmolcas-22.02/src/ccsort_util/getpp_zr.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/getpp_zr.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine getpp_zr (lunpublic,pp,ipp,length) -c -#include "SysDef.fh" - integer lunpublic,length - Real*8 pp(1:length) - Integer ipp(1:length) -c - read (lunpublic) pp,ipp -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/initintabc1.f openmolcas-22.10/src/ccsort_util/initintabc1.f --- openmolcas-22.02/src/ccsort_util/initintabc1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/initintabc1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,73 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine initintabc1 -c this routine write corresponding mapd and mapi to INTAB -c for nonsymetrical (C1) case -c -#include "reorg.fh" -#include "ccsort.fh" -c -c help variables -c - integer nhelp,length,symp,symq,symab - integer poss,ii,syma,symb,rc -c -c* def symab - syma=1 - symb=1 - symab=mul(syma,symb) -c -c* make mapd3,mapi3 for <_a_b|pq> -c -c** set mapi3=0 (partly) -c - do 100 nhelp=1,nsym - do 101 symq=1,nsym - do 102 symp=1,nsym - mapi3(symp,symq,nhelp)=0 - 102 continue - 101 continue - 100 continue -c -c** def 0-th row -c - mapd3(0,1)=5 - mapd3(0,2)=5 - mapd3(0,3)=0 - mapd3(0,4)=0 - mapd3(0,5)=nsym - mapd3(0,6)=0 -c -c** def other rows -c - poss=poss30 - do 200 ii=1,nsym -c - symp=ii - symq=mul(symab,symp) - length=norb(symp)*norb(symq) - mapd3(ii,1)=poss - mapd3(ii,2)=length - mapd3(ii,3)=symp - mapd3(ii,4)=symq - mapd3(ii,5)=1 - mapd3(ii,6)=1 - mapi3(symp,1,1)=ii - poss=poss+length -c - 200 continue -c -c* write mapd,mapi to INTAB - call dawrtmap (lunab,mapd3,mapi3,rc) -c -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/initintabc1.F90 openmolcas-22.10/src/ccsort_util/initintabc1.F90 --- openmolcas-22.02/src/ccsort_util/initintabc1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/initintabc1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,67 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine initintabc1() +! this routine writes corresponding mapd and mapi to INTAB +! for nonsymmetrical (C1) case + +use ccsort_global, only: lunab, mapd3, mapi3, NORB, NSYM, pos30 +use Symmetry_Info, only: Mul +use Definitions, only: iwp + +implicit none +integer(kind=iwp) :: ii, length, pos, rc, syma, symab, symb, symp, symq + +! def symab +syma = 1 +symb = 1 +symab = mul(syma,symb) + +! make mapd3,mapi3 for <_a_b|pq> + +! set mapi3=0 (partly) + +mapi3(1:nsym,1:nsym,1:nsym) = 0 + +! def 0-th row + +mapd3(0,1) = 5 +mapd3(0,2) = 5 +mapd3(0,3) = 0 +mapd3(0,4) = 0 +mapd3(0,5) = nsym +mapd3(0,6) = 0 + +! def other rows + +pos = pos30 +do ii=1,nsym + + symp = ii + symq = mul(symab,symp) + length = norb(symp)*norb(symq) + mapd3(ii,1) = pos + mapd3(ii,2) = length + mapd3(ii,3) = symp + mapd3(ii,4) = symq + mapd3(ii,5) = 1 + mapd3(ii,6) = 1 + mapi3(symp,1,1) = ii + pos = pos+length + +end do + +! write mapd,mapi to INTAB +call dawrtmap(lunab,mapd3,mapi3,rc) + +return + +end subroutine initintabc1 diff -Nru openmolcas-22.02/src/ccsort_util/inittemp.f openmolcas-22.10/src/ccsort_util/inittemp.f --- openmolcas-22.02/src/ccsort_util/inittemp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/inittemp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine inittemp (num) -c -c this routine initialize status matrix -c num - number of files to be used (I) -c - implicit real*8 (a-h,o-z) -#include "reorg.fh" - integer num -c -c help variables -c - integer nhelp -c - do nhelp=1,num - stattemp(nhelp)=0 - nrectemp(nhelp)=0 - lrectemp(nhelp)=0 - end do -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/inittemp.F90 openmolcas-22.10/src/ccsort_util/inittemp.F90 --- openmolcas-22.02/src/ccsort_util/inittemp.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/inittemp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,28 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine inittemp(num) +! this routine initializes status matrix +! num - number of files to be used (I) + +use ccsort_global, only: lrectemp, nrectemp, stattemp +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: num + +stattemp(1:num) = 0 +nrectemp(1:num) = 0 +lrectemp(1:num) = 0 + +return + +end subroutine inittemp diff -Nru openmolcas-22.02/src/ccsort_util/initwrk.f openmolcas-22.10/src/ccsort_util/initwrk.f --- openmolcas-22.02/src/ccsort_util/initwrk.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/initwrk.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,117 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine initwrk (length) -c -c this routine calculate required size of work space and -c definie initial possitions of work vectors -c -#include "ccsort.fh" -#include "reorg.fh" -c -c help variables -c - integer n - integer sizevint,sizev1,sizev2,sizempq,length,norbmax,sizeri - integer symp,symq,symi,symj,sympq,sympqi,symm,symmp,syma -c -c1* def maxzie of vint -c - norbmax=norb(1) - do 10 n=1,nsym - if (norb(n).gt.norbmax) then - norbmax=norb(n) - end if - 10 continue -c - sizevint=norbmax*norbmax*norbmax -c -c2* def size of =j>, -c - sizev1=0 - sizev2=0 - do 20 symp=1,nsym - do 21 symq=1,nsym - sympq=mul(symp,symq) - do 22 symi=1,nsym - sympqi=mul(sympq,symi) - symj=sympqi -c calc. length - if (symj.gt.symi) then - sizev2=sizev2+noa(symi)*noa(symj)*NORB(symp)*NORB(symq) - else - sizev1=sizev1+noa(symi)*noa(symj)*NORB(symp)*NORB(symq) - sizev2=sizev2+noa(symi)*noa(symj)*NORB(symp)*NORB(symq) - end if -22 continue -21 continue -20 continue -c -c3* def maxsize of <_am|pq> -c - - sizempq=0 - do 50 syma=1,nsym -c - length=0 - do 30 symm=1,nsym - do 31 symp=1,nsym - symmp=mul(symm,symp) - symq=mul(syma,symmp) -c calc. length - length=length+noa(symm)*NORB(symp)*NORB(symq) - 31 continue - 30 continue -c - if (sizempq.lt.length) then - sizempq=length - end if -c - 50 continue -c -c4* def maxsize of R_i if needed -c - sizeri=0 -c - if (t3key.eq.1) then - do 60 symi=1,nsym - call ccsort_t3grc0 (3,8,4,4,4,0,symi,1,length,mapdri,mapiri) - length=length-1 - if (length.gt.sizeri) then - sizeri=length - end if - 60 continue - end if - -c ******* distribution of memory ****** -c - poss10=1+sizevint - poss20=poss10+sizev1 - poss30=poss20+sizev2 - possri0=poss30+sizempq - length=possri0+sizeri-1 -c - if (fullprint.gt.1) then - write(6,*) - write(6,'(6X,A)') 'size of help (work) vectors:' - write(6,'(6X,A)') '----------------------------' - write(6,*) - write(6,'(6X,A,I8)') 'Vints V0 required : ',sizevint - write(6,'(6X,A,I8)') 'PQIJ ints V1 required : ',sizev1 - write(6,'(6X,A,I8)') ' V2 required : ',sizev2 - write(6,'(6X,A,I8)') 'AMIJ ints V3 required : ',sizempq - write(6,'(6X,A,I8)') 'R_i mtx Ri required : ',sizeri - end if -c - if (fullprint.ge.0) - & write(6,'(6X,A,I20)') 'Required WRK size-sum : ',length -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/initwrk.F90 openmolcas-22.10/src/ccsort_util/initwrk.F90 --- openmolcas-22.02/src/ccsort_util/initwrk.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/initwrk.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,109 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine initwrk(length) +! this routine calculates required size of work space and +! defines initial positions of work vectors + +use ccsort_global, only: fullprint, mapdri, mapiri, noa, NORB, NSYM, pos10, pos20, pos30, posri0, t3key +use Symmetry_Info, only: Mul +use Definitions, only: iwp, u6 + +implicit none +integer(kind=iwp), intent(out) :: length +integer(kind=iwp) :: n, norbmax, sizempq, sizeri, sizev1, sizev2, sizevint, syma, symi, symj, symm, symmp, symp, sympq, sympqi, symq + +!1 def maxsize of vint + +norbmax = norb(1) +do n=1,nsym + if (norb(n) > norbmax) norbmax = norb(n) +end do + +sizevint = norbmax*norbmax*norbmax + +!2 def size of =j>, + +sizev1 = 0 +sizev2 = 0 +do symp=1,nsym + do symq=1,nsym + sympq = mul(symp,symq) + do symi=1,nsym + sympqi = mul(sympq,symi) + symj = sympqi + ! calc. length + if (symj > symi) then + sizev2 = sizev2+noa(symi)*noa(symj)*NORB(symp)*NORB(symq) + else + sizev1 = sizev1+noa(symi)*noa(symj)*NORB(symp)*NORB(symq) + sizev2 = sizev2+noa(symi)*noa(symj)*NORB(symp)*NORB(symq) + end if + end do + end do +end do + +!3 def maxsize of <_am|pq> + +sizempq = 0 +do syma=1,nsym + + length = 0 + do symm=1,nsym + do symp=1,nsym + symmp = mul(symm,symp) + symq = mul(syma,symmp) + ! calc. length + length = length+noa(symm)*NORB(symp)*NORB(symq) + end do + end do + + if (sizempq < length) sizempq = length + +end do + +!4 def maxsize of R_i if needed + +sizeri = 0 + +if (t3key == 1) then + do symi=1,nsym + call ccsort_t3grc0(3,8,4,4,4,0,symi,1,length,mapdri,mapiri) + length = length-1 + if (length > sizeri) sizeri = length + end do +end if + +! ******* distribution of memory ****** + +pos10 = 1+sizevint +pos20 = pos10+sizev1 +pos30 = pos20+sizev2 +posri0 = pos30+sizempq +length = posri0+sizeri-1 + +if (fullprint > 1) then + write(u6,*) + write(u6,'(6X,A)') 'size of help (work) vectors:' + write(u6,'(6X,A)') '----------------------------' + write(u6,*) + write(u6,'(6X,A,I8)') 'Vints V0 required : ',sizevint + write(u6,'(6X,A,I8)') 'PQIJ ints V1 required : ',sizev1 + write(u6,'(6X,A,I8)') ' V2 required : ',sizev2 + write(u6,'(6X,A,I8)') 'AMIJ ints V3 required : ',sizempq + write(u6,'(6X,A,I8)') 'R_i mtx Ri required : ',sizeri +end if + +if (fullprint >= 0) write(u6,'(6X,A,I20)') 'Required WRK size-sum : ',length + +return + +end subroutine initwrk diff -Nru openmolcas-22.02/src/ccsort_util/ireorg1.f openmolcas-22.10/src/ccsort_util/ireorg1.f --- openmolcas-22.02/src/ccsort_util/ireorg1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ireorg1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,188 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine ireorg1 (symp,symq,symr,syms,typp,typq,typr,typs, - & posspv1,possqv1,possrv1,posssv1,typpv1,typqv1,typrv1,typsv1, - & typv2,v1,v2,fact,dimpq,dimrs,dimt,dimu,dimv,dimx) -c -c this routine map v2(pq,rs) <+ fact . v1 (t,u,v,z) -c v2 may be of type 0,1,3,4 (typv2) while type v1 is always 0 -c symp-syms and typp-typs are symmetries and types of p-s indexex -c posspv1-posssv1 are corresponding possitions of p-s indexes in v1 -c -c symp-s - symetries of p-s (I) -c typp-s - types of indexes p-s in V2 (I) -c possp-sv1 - possitions of p-s ind. in v1 (I) -c typp-sv1 - types of indices, corresponding to p-s in V1 (I) -c typv2 - type of V2 (0,1,2,4) (I) -c v1,v2 - arrays V1 and V2 (I,O) -c fact - multiplication factors (usually +-1.0d0) (I) -c dimpq,rs - dimensions of V2 (I) -c dimt-x - dimensions of V1 (I) -c -c -c reorg.fh may not be included -#include "ccsort.fh" - integer symp,symq,symr,syms,typp,typq,typr,typs - integer posspv1,possqv1,possrv1,posssv1 - integer typpv1,typqv1,typrv1,typsv1,typv2 - integer dimpq,dimrs,dimt,dimu,dimv,dimx - real*8 v2(1:dimpq,1:dimrs) - real*8 v1(1:dimt,1:dimu,1:dimv,1:dimx) - real*8 fact -c -c help variables -c - integer p,q,r,s,pq,rs,rc,pqyes,rsyes - integer :: pup=0,qup=0,rup=0,sup=0 - integer :: paddv1=-1,qaddv1=-1,raddv1=-1,saddv1=-1 - integer ind(1:4) -c -c* def additive constants -c - call ireorg3 (symp,typp,typpv1,paddv1,rc) - call ireorg3 (symq,typq,typqv1,qaddv1,rc) - call ireorg3 (symr,typr,typrv1,raddv1,rc) - call ireorg3 (syms,typs,typsv1,saddv1,rc) -c -c* def sumation limits -c - call ireorg2 (symp,typp,pup,rc) - call ireorg2 (symq,typq,qup,rc) - call ireorg2 (symr,typr,rup,rc) - call ireorg2 (syms,typs,sup,rc) -c -c* def pqyes, rsyes (i.e. if there is a reduced sumations) -c - if ((typv2.eq.1).or.(typv2.eq.4)) then - if (symp.eq.symq) then - pqyes=1 - else - pqyes=0 - end if - else - pqyes=0 - end if -c - if ((typv2.eq.3).or.(typv2.eq.4)) then - if (symr.eq.syms) then - rsyes=1 - else - rsyes=0 - end if - else - rsyes=0 - end if -c -c - if ((pqyes.eq.1).and.(rsyes.eq.1)) then -c -c* case p>q, r>s -c - rs=0 - do 100 r=2,rup - ind(possrv1)=raddv1+r - do 101 s=1,r-1 - ind(posssv1)=saddv1+s - rs=rs+1 -c - pq=0 - do 102 p=2,pup - ind(posspv1)=paddv1+p - do 103 q=1,p-1 - ind(possqv1)=qaddv1+q - pq=pq+1 -c - v2(pq,rs)=v2(pq,rs)+fact*v1(ind(1),ind(2),ind(3),ind(4)) -c - 103 continue - 102 continue - 101 continue - 100 continue -c - else if (pqyes.eq.1) then -c -c* case p>q, r,s -c - rs=0 - do 200 s=1,sup - ind(posssv1)=saddv1+s - do 201 r=1,rup - ind(possrv1)=raddv1+r - rs=rs+1 -c - pq=0 - do 202 p=2,pup - ind(posspv1)=paddv1+p - do 203 q=1,p-1 - ind(possqv1)=qaddv1+q - pq=pq+1 -c - v2(pq,rs)=v2(pq,rs)+fact*v1(ind(1),ind(2),ind(3),ind(4)) -c - 203 continue - 202 continue - 201 continue - 200 continue -c - else if (rsyes.eq.1) then -c -c* case p,q, r>s -c - rs=0 - do 300 r=2,rup - ind(possrv1)=raddv1+r - do 301 s=1,r-1 - ind(posssv1)=saddv1+s - rs=rs+1 -c - pq=0 - do 302 q=1,qup - ind(possqv1)=qaddv1+q - do 303 p=1,pup - ind(posspv1)=paddv1+p - pq=pq+1 -c - v2(pq,rs)=v2(pq,rs)+fact*v1(ind(1),ind(2),ind(3),ind(4)) -c - 303 continue - 302 continue - 301 continue - 300 continue -c - else -c -c* case p,q, r,s -c - rs=0 - do 400 s=1,sup - ind(posssv1)=saddv1+s - do 401 r=1,rup - ind(possrv1)=raddv1+r - rs=rs+1 -c - pq=0 - do 402 q=1,qup - ind(possqv1)=qaddv1+q - do 403 p=1,pup - ind(posspv1)=paddv1+p - pq=pq+1 -c - v2(pq,rs)=v2(pq,rs)+fact*v1(ind(1),ind(2),ind(3),ind(4)) -c - 403 continue - 402 continue - 401 continue - 400 continue -c - end if -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/ireorg1.F90 openmolcas-22.10/src/ccsort_util/ireorg1.F90 --- openmolcas-22.02/src/ccsort_util/ireorg1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ireorg1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,179 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ireorg1(symp,symq,symr,syms,typp,typq,typr,typs,pospv1,posqv1,posrv1,possv1,typpv1,typqv1,typrv1,typsv1,typv2,v1, & + v2,fact,dimpq,dimrs,dimt,dimu,dimv,dimx) +! this routine maps v2(pq,rs) <+ fact . v1 (t,u,v,z) +! v2 may be of type 0,1,3,4 (typv2) while type v1 is always 0 +! symp-syms and typp-typs are symmetries and types of p-s indices +! pospv1-possv1 are corresponding positions of p-s indices in v1 +! +! symp-s - symmetries of p-s (I) +! typp-s - types of indices p-s in V2 (I) +! posp-sv1 - positions of p-s ind. in v1 (I) +! typp-sv1 - types of indices, corresponding to p-s in V1 (I) +! typv2 - type of V2 (0,1,2,4) (I) +! v1,v2 - arrays V1 and V2 (I,O) +! fact - multiplication factors (usually +-1.0) (I) +! dimpq,rs - dimensions of V2 (I) +! dimt-x - dimensions of V1 (I) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: symp, symq, symr, syms, typp, typq, typr, typs, pospv1, posqv1, posrv1, possv1, typpv1, typqv1, & + typrv1, typsv1, typv2, dimpq, dimrs, dimt, dimu, dimv, dimx +real(kind=wp), intent(in) :: v1(dimt,dimu,dimv,dimx), fact +real(kind=wp), intent(inout) :: v2(dimpq,dimrs) +integer(kind=iwp) :: ind(4), p, paddv1 = -1, pq, pqyes, pup = 0, q, qaddv1 = -1, qup = 0, r, raddv1 = -1, rc, rs, rsyes, rup = 0, & + s, saddv1 = -1, sup = 0 + +! def additive constants + +call ireorg3(symp,typp,typpv1,paddv1,rc) +call ireorg3(symq,typq,typqv1,qaddv1,rc) +call ireorg3(symr,typr,typrv1,raddv1,rc) +call ireorg3(syms,typs,typsv1,saddv1,rc) + +! def summation limits + +call ireorg2(symp,typp,pup,rc) +call ireorg2(symq,typq,qup,rc) +call ireorg2(symr,typr,rup,rc) +call ireorg2(syms,typs,sup,rc) + +! def pqyes, rsyes (i.e. if there is a reduced summation) + +if ((typv2 == 1) .or. (typv2 == 4)) then + if (symp == symq) then + pqyes = 1 + else + pqyes = 0 + end if +else + pqyes = 0 +end if + +if ((typv2 == 3) .or. (typv2 == 4)) then + if (symr == syms) then + rsyes = 1 + else + rsyes = 0 + end if +else + rsyes = 0 +end if + +if ((pqyes == 1) .and. (rsyes == 1)) then + + ! case p>q, r>s + + rs = 0 + do r=2,rup + ind(posrv1) = raddv1+r + do s=1,r-1 + ind(possv1) = saddv1+s + rs = rs+1 + + pq = 0 + do p=2,pup + ind(pospv1) = paddv1+p + do q=1,p-1 + ind(posqv1) = qaddv1+q + pq = pq+1 + + v2(pq,rs) = v2(pq,rs)+fact*v1(ind(1),ind(2),ind(3),ind(4)) + + end do + end do + end do + end do + +else if (pqyes == 1) then + + ! case p>q, r,s + + rs = 0 + do s=1,sup + ind(possv1) = saddv1+s + do r=1,rup + ind(posrv1) = raddv1+r + rs = rs+1 + + pq = 0 + do p=2,pup + ind(pospv1) = paddv1+p + do q=1,p-1 + ind(posqv1) = qaddv1+q + pq = pq+1 + + v2(pq,rs) = v2(pq,rs)+fact*v1(ind(1),ind(2),ind(3),ind(4)) + + end do + end do + end do + end do + +else if (rsyes == 1) then + + ! case p,q, r>s + + rs = 0 + do r=2,rup + ind(posrv1) = raddv1+r + do s=1,r-1 + ind(possv1) = saddv1+s + rs = rs+1 + + pq = 0 + do q=1,qup + ind(posqv1) = qaddv1+q + do p=1,pup + ind(pospv1) = paddv1+p + pq = pq+1 + + v2(pq,rs) = v2(pq,rs)+fact*v1(ind(1),ind(2),ind(3),ind(4)) + + end do + end do + end do + end do + +else + + ! case p,q, r,s + + rs = 0 + do s=1,sup + ind(possv1) = saddv1+s + do r=1,rup + ind(posrv1) = raddv1+r + rs = rs+1 + + pq = 0 + do q=1,qup + ind(posqv1) = qaddv1+q + do p=1,pup + ind(pospv1) = paddv1+p + pq = pq+1 + + v2(pq,rs) = v2(pq,rs)+fact*v1(ind(1),ind(2),ind(3),ind(4)) + + end do + end do + end do + end do + +end if + +return + +end subroutine ireorg1 diff -Nru openmolcas-22.02/src/ccsort_util/ireorg2.f openmolcas-22.10/src/ccsort_util/ireorg2.f --- openmolcas-22.02/src/ccsort_util/ireorg2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ireorg2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,41 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine ireorg2 (symp,typp,pup,rc) -c -c* this routine def. sumation limits for given symp and typp -c i.e. number of indexes for this symmetry and typ -c -c symp - irrep of p index (I) -c typp - typ of p index in v2 (I) -c pup - sumation limit -c rc - return (error) code (O) -c -#include "ccsort.fh" - integer symp,typp,pup,rc -c - if (typp.eq.1) then - pup=noa(symp) - else if (typp.eq.2) then - pup=nob(symp) - else if (typp.eq.3) then - pup=nva(symp) - else if (typp.eq.4) then - pup=nvb(symp) - else if (typp.eq.5) then - pup=norb(symp) - else - rc=1 -c RC=1 : bad typp (Stup) - return - end if -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/ireorg2.F90 openmolcas-22.10/src/ccsort_util/ireorg2.F90 --- openmolcas-22.02/src/ccsort_util/ireorg2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ireorg2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,48 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ireorg2(symp,typp,pup,rc) +! this routine def. summation limits for given symp and typp +! i.e. number of indices for this symmetry and typ +! +! symp - irrep of p index (I) +! typp - typ of p index in v2 (I) +! pup - summation limit +! rc - return (error) code (O) + +use ccsort_global, only: noa, nob, NORB, nva, nvb +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: symp, typp +integer(kind=iwp), intent(out) :: pup, rc + +rc = 0 + +select case (typp) + case (1) + pup = noa(symp) + case (2) + pup = nob(symp) + case (3) + pup = nva(symp) + case (4) + pup = nvb(symp) + case (5) + pup = norb(symp) + case default + rc = 1 + ! RC=1 : bad typp (Stup) +end select + +return + +end subroutine ireorg2 diff -Nru openmolcas-22.02/src/ccsort_util/ireorg3.f openmolcas-22.10/src/ccsort_util/ireorg3.f --- openmolcas-22.02/src/ccsort_util/ireorg3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ireorg3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,73 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine ireorg3 (symp,typp,typpv1,paddv1,rc) -c -c* this routine def. constants to be added to index from v2 -c to determine proper index in v1 -c N.B. typp and typpv1 must be compatible (this is testet -c in this version) -c -c symp - irrep of p index (I) -c typp - typ of p index in v2 (I) -c typpv1- typ of corresponding p index in v1 (I) -c paddv1- constant to be added (O) pv1 = pv2+paddv1 -c rc - return (error) code (O) -c -#include "ccsort.fh" - integer symp,typp,typpv1,paddv1,rc -c - rc=0 -c - if ((typp.eq.1).or.(typp.eq.2)) then - if ((typpv1.eq.1).or.(typpv1.eq.2).or.(typpv1.eq.5)) then - paddv1=0 - else - rc=1 -c RC=1 : typp=1 or 2, incompatible typpv1 (Stup) - return - end if - else if (typp.eq.3) then - if (typpv1.eq.3) then - paddv1=0 - else if (typpv1.eq.4) then - paddv1=nvb(symp)-nva(symp) - else if (typpv1.eq.5) then - paddv1=noa(symp) - else - rc=2 -c RC=2 : typp=3, incompatible typpv1 (Stup) - return - end if - else if (typp.eq.4) then - if (typpv1.eq.4) then - paddv1=0 - else if (typpv1.eq.5) then - paddv1=nob(symp) - else - rc=3 -c RC=3 : typp=4, incompatible typpv1 (Stup) - return - end if - else if (typp.eq.5) then - if (typpv1.eq.5) then - paddv1=0 - else -c RC=4 : typp=5, incompatible typpv1 (Stup) - return - end if - else - rc=5 -c RC=5 : improper typp (Stup) - return - end if -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/ireorg3.F90 openmolcas-22.10/src/ccsort_util/ireorg3.F90 --- openmolcas-22.02/src/ccsort_util/ireorg3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ireorg3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,74 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ireorg3(symp,typp,typpv1,paddv1,rc) +! this routine def. constants to be added to index from v2 +! to determine proper index in v1 +! N.B. typp and typpv1 must be compatible (this is testet +! in this version) +! +! symp - irrep of p index (I) +! typp - typ of p index in v2 (I) +! typpv1- typ of corresponding p index in v1 (I) +! paddv1- constant to be added (O) pv1 = pv2+paddv1 +! rc - return (error) code (O) + +use ccsort_global, only: noa, nob, nva, nvb +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: symp, typp, typpv1 +integer(kind=iwp), intent(out) :: paddv1, rc + +rc = 0 + +select case (typp) + case (1,2) + if ((typpv1 == 1) .or. (typpv1 == 2) .or. (typpv1 == 5)) then + paddv1 = 0 + else + rc = 1 + ! RC=1 : typp=1 or 2, incompatible typpv1 (Stup) + end if + case (3) + if (typpv1 == 3) then + paddv1 = 0 + else if (typpv1 == 4) then + paddv1 = nvb(symp)-nva(symp) + else if (typpv1 == 5) then + paddv1 = noa(symp) + else + rc = 2 + ! RC=2 : typp=3, incompatible typpv1 (Stup) + end if + case (4) + if (typpv1 == 4) then + paddv1 = 0 + else if (typpv1 == 5) then + paddv1 = nob(symp) + else + rc = 3 + ! RC=3 : typp=4, incompatible typpv1 (Stup) + end if + case (5) + if (typpv1 == 5) then + paddv1 = 0 + else + ! RC=4 : typp=5, incompatible typpv1 (Stup) + end if + case default + rc = 5 + ! RC=5 : improper typp (Stup) +end select + +return + +end subroutine ireorg3 diff -Nru openmolcas-22.02/src/ccsort_util/ireorg.f openmolcas-22.10/src/ccsort_util/ireorg.f --- openmolcas-22.02/src/ccsort_util/ireorg.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ireorg.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,84 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine ireorg (wrk,wrksize, - & symp,symq,symr,syms,typp,typq,typr,typs, - & posspv1,possqv1,possrv1,posssv1,typpv1,typqv1,typrv1,typsv1, - & typv2,possv10,possv20,fact) -c -c this routine is up level routine for ireorg1 (also more detailed -c description can be found there). -c v1 must be of type 0, v2 can be 0,1,3 and 4 -c this routine only prepair some constants, required by ireorg1, -c that can be deduced form input data - dimpq,dimrs,dimt-dimx -c -c symp-s - symetries of p-s (I) -c typp-s - types of indexes p-s in V2 (I) -c possp-sv1 - possitions of p-s ind. in v1 (I) -c typp-sv1 - types of indices, corresponding to p-s in V1 (I) -c typv2 - type of V2 (0,1,2,4) (I) -c possv10,20 - initial possitions of V1 and V2 in wrk (I) -c fact - multiplication factors (usually +-1.0d0) (I) -c -#include "wrk.fh" -#include "reorg.fh" -#include "ccsort.fh" - integer symp,symq,symr,syms,typp,typq,typr,typs - integer posspv1,possqv1,possrv1,posssv1,typpv1,typqv1,typrv1, - & typsv1 - integer typv2,possv10,possv20 - real*8 fact -c -c help variables -c - integer ind(1:4) - integer rc,dimpq,dimrs - integer :: nhelp=-1,mhelp=-1 -c -c* define dimensions of V1 -c - call ireorg2 (symp,typpv1,nhelp,rc) - ind(posspv1)=nhelp - call ireorg2 (symq,typqv1,nhelp,rc) - ind(possqv1)=nhelp - call ireorg2 (symr,typrv1,nhelp,rc) - ind(possrv1)=nhelp - call ireorg2 (syms,typsv1,nhelp,rc) - ind(posssv1)=nhelp -c -c* def dimpq,dimrs -c - call ireorg2 (symp,typp,nhelp,rc) - call ireorg2 (symq,typq,mhelp,rc) -c - if (((typv2.eq.1).or.(typv2.eq.4)).and.(symp.eq.symq)) then - dimpq=(nhelp*(nhelp-1))/2 - else - dimpq=nhelp*mhelp - end if -c - call ireorg2 (symr,typr,nhelp,rc) - call ireorg2 (syms,typs,mhelp,rc) -c - if (((typv2.eq.3).or.(typv2.eq.4)).and.(symr.eq.syms)) then - dimrs=(nhelp*(nhelp-1))/2 - else - dimrs=nhelp*mhelp - end if -c -c* use ireorg1 -c - call ireorg1 (symp,symq,symr,syms,typp,typq,typr,typs, - & posspv1,possqv1,possrv1,posssv1,typpv1,typqv1,typrv1,typsv1, - & typv2,wrk(possv10),wrk(possv20),fact,dimpq,dimrs, - & ind(1),ind(2),ind(3),ind(4)) -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/ireorg.F90 openmolcas-22.10/src/ccsort_util/ireorg.F90 --- openmolcas-22.02/src/ccsort_util/ireorg.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/ireorg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,75 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ireorg(wrk,wrksize,symp,symq,symr,syms,typp,typq,typr,typs,pospv1,posqv1,posrv1,possv1,typpv1,typqv1,typrv1,typsv1, & + typv2,posv10,posv20,fact) +! this routine is up level routine for ireorg1 (also more detailed +! description can be found there). +! v1 must be of type 0, v2 can be 0,1,3 and 4 +! this routine only prepares some constants, required by ireorg1, +! that can be deduced form input data - dimpq,dimrs,dimt-dimx +! +! symp-s - symmetries of p-s (I) +! typp-s - types of indices p-s in V2 (I) +! posp-sv1 - positions of p-s ind. in v1 (I) +! typp-sv1 - types of indices, corresponding to p-s in V1 (I) +! typv2 - type of V2 (0,1,2,4) (I) +! posv10,20 - initial positions of V1 and V2 in wrk (I) +! fact - multiplication factors (usually +-1.0) (I) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: wrksize, symp, symq, symr, syms, typp, typq, typr, typs, pospv1, posqv1, posrv1, possv1, typpv1, & + typqv1, typrv1, typsv1, typv2, posv10, posv20 +real(kind=wp), intent(inout) :: wrk(wrksize) +real(kind=wp), intent(in) :: fact +integer(kind=iwp) :: dimpq, dimrs, ind(4), mhelp = -1, nhelp = -1, rc + +! define dimensions of V1 + +call ireorg2(symp,typpv1,nhelp,rc) +ind(pospv1) = nhelp +call ireorg2(symq,typqv1,nhelp,rc) +ind(posqv1) = nhelp +call ireorg2(symr,typrv1,nhelp,rc) +ind(posrv1) = nhelp +call ireorg2(syms,typsv1,nhelp,rc) +ind(possv1) = nhelp + +! def dimpq,dimrs + +call ireorg2(symp,typp,nhelp,rc) +call ireorg2(symq,typq,mhelp,rc) + +if (((typv2 == 1) .or. (typv2 == 4)) .and. (symp == symq)) then + dimpq = (nhelp*(nhelp-1))/2 +else + dimpq = nhelp*mhelp +end if + +call ireorg2(symr,typr,nhelp,rc) +call ireorg2(syms,typs,mhelp,rc) + +if (((typv2 == 3) .or. (typv2 == 4)) .and. (symr == syms)) then + dimrs = (nhelp*(nhelp-1))/2 +else + dimrs = nhelp*mhelp +end if + +! use ireorg1 + +call ireorg1(symp,symq,symr,syms,typp,typq,typr,typs,pospv1,posqv1,posrv1,possv1,typpv1,typqv1,typrv1,typsv1,typv2,wrk(posv10), & + wrk(posv20),fact,dimpq,dimrs,ind(1),ind(2),ind(3),ind(4)) + +return + +end subroutine ireorg diff -Nru openmolcas-22.02/src/ccsort_util/mkabpqmap.f openmolcas-22.10/src/ccsort_util/mkabpqmap.f --- openmolcas-22.02/src/ccsort_util/mkabpqmap.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mkabpqmap.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,74 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine mkabpqmap (abmap,syma,symb,rc) -c -c this routine prepair abmap -c -#include "reorg.fh" -#include "ccsort.fh" -c - integer abmap(1:mbas,1:mbas,1:8) - integer syma,symb,rc -c -c help variables -c - integer a,b,bup,symp,symq,symab - integer lengthpq,nrecc,nrest,irec -c -cT test, if there are any ab pair -c - if (nvb(syma)*nvb(symb).eq.0) then - rc=1 -c RC=1 : there are no ab pair in this symmetry - return - else - rc=0 - end if -c -c* def initial address -c - irec=1 - symab=mul(syma,symb) -c -c* loop over all combinations -c - do 100 symp=1,nsym - symq=mul(symab,symp) -c -c* define number of records, required to store this block -c and determine shift in initial possitions -c - lengthpq=norb(symp)*norb(symq) - nrecc=int(lengthpq/recl) - nrest=lengthpq-nrecc*recl - if (nrest.gt.0) then - nrecc=nrecc+1 - end if -c - do 101 a=1,nvb(syma) -c - if (syma.eq.symb) then - bup=a - else - bup=nvb(symb) - end if -c - do 102 b=1,bup -c - abmap(a,b,symp)=irec - irec=irec+nrecc -c - 102 continue - 101 continue - 100 continue -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/mkabpqmap.F90 openmolcas-22.10/src/ccsort_util/mkabpqmap.F90 --- openmolcas-22.02/src/ccsort_util/mkabpqmap.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mkabpqmap.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,74 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine mkabpqmap(abmap,syma,symb,rc) +! this routine prepares abmap + +use ccsort_global, only: mbas, NORB, NSYM, nvb, reclen +use Symmetry_Info, only: Mul +use Definitions, only: iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(_OUT_) :: abmap(mbas,mbas,8) +integer(kind=iwp), intent(in) :: syma, symb +integer(kind=iwp), intent(out) :: rc +integer(kind=iwp) :: a, b, bup, irec, lengthpq, nrecc, nrest, symab, symp, symq + +rc = 0 + +!T test, if there are any ab pair + +if (nvb(syma)*nvb(symb) == 0) then + rc = 1 + ! RC=1 : there are no ab pair in this symmetry + return +end if + +! def initial address + +irec = 1 +symab = mul(syma,symb) + +! loop over all combinations + +do symp=1,nsym + symq = mul(symab,symp) + + ! define number of records, required to store this block + ! and determine shift in initial positions + + lengthpq = norb(symp)*norb(symq) + nrecc = int(lengthpq/reclen) + nrest = lengthpq-nrecc*reclen + if (nrest > 0) nrecc = nrecc+1 + + do a=1,nvb(syma) + + if (syma == symb) then + bup = a + else + bup = nvb(symb) + end if + + do b=1,bup + + abmap(a,b,symp) = irec + irec = irec+nrecc + + end do + end do +end do + +return + +end subroutine mkabpqmap diff -Nru openmolcas-22.02/src/ccsort_util/mkaddress.F90 openmolcas-22.10/src/ccsort_util/mkaddress.F90 --- openmolcas-22.02/src/ccsort_util/mkaddress.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mkaddress.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,323 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine mkaddress(NOIPSB) +!FUE It is strictly forbidden to use any construct to fetch disk +!FUE addresses which do not make use of subroutines provided in +!FUE the MOLCAS utilities as otherwise transparency and portability +!FUE is lost. +! +! this routine prepares information arrays +! for integral blocks per symmetry in primitive form +! it defines: +! noipsb(nijkl) - number of integrals per symmetry block +! idispsb(nijkl)- initial addresses for each symmetry block +! typ(pa,qa,ra) - type of symmetry block +! types of (ij|kl): +! 1 - si=sk, si=sj, sk=sl +! 2 - si=sk, si=sj, sk>sl +! 3 - si=sk, si>sj, sk=sl +! 4 - si=sk, si>sj, sk>sl +! 5 - si>sk, si=sj, sk=sl +! 6 - si>sk, si=sj, sk>sl +! 7 - si>sk, si>sj, sk=sl +! 8 - si>sk, si>sj, sk>sl +! +! idis(pa,qa,ra)- initial addresses for given symmetry block +! np(pa,qa,ra) - position of p index in original block (ij|kl) (on tape) +! nq(pa,qa,ra) - position of q index in original block (ij|kl) (on tape) +! nr(pa,qa,ra) - position of r index in original block (ij|kl) (on tape) +! ns(pa,qa,ra) - position of s index in original block (ij|kl) (on tape) +! +! N.B. typ,idis,np,nq,nr,ns are imported from ccsort_global + +use ccsort_global, only: fullprint, idis, LUINTM, NORB, np, nq, nr, ns, NSYM, typ +use Symmetry_Info, only: Mul +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(out) :: NOIPSB(106) +#include "tratoc.fh" +integer(kind=iwp) :: idishelp, idistemp, ilow, IND, INDT, iold, ISPQRS, iup, jlow, jold, jup, kold, kup, lold, lup, N_INT, norbp, & + nsi, nsij, nsijk, nsj, nsk, nsl, NSLM, p, pa, q, qa, r, ra, s, sense !, idispsb(106) +real(kind=wp) :: dum(1) + +!FUE - pick the start addresses of each symmetry allowed integral +!FUE block from the tranformed two electron integral file +idistemp = 0 +call iDaFile(LUINTM,0,iTraToc,nTraToc,idistemp) +!FUE - the option 0 in the call to dafile does not make any I/O +!FUE but just returns the updated disk address +!FUE - at this point idistemp points to the first record + +IND = 0 +INDT = 0 +!FUE idistemp = 1 +!FUE idisadd = 150 + +typ(1:NSYM,1:NSYM,1:NSYM) = 0 + +if (fullprint > 0) then + write(u6,'(6X,A)') 'Transformed integral blocks:' + write(u6,'(6X,A)') '----------------------------' + write(u6,*) + write(u6,'(6X,A)') 'block symmetry no. of no. of ' + write(u6,'(6X,A)') ' no. spec. orbitals integrals' + write(u6,'(6X,A)') '-------------------------------------------' +end if + +ISPQRS = 0 +do NSI=1,NSYM + do NSJ=1,NSI + NSIJ = MUL(NSI,NSJ) + do NSK=1,NSI + NSIJK = MUL(NSK,NSIJ) + NSLM = NSK + if (NSK == NSI) NSLM = NSJ + do NSL=1,NSLM + if (NSIJK /= NSL) cycle + NORBP = NORB(NSI)*NORB(NSJ)*NORB(NSK)*NORB(NSL) + if (NORBP == 0) cycle + ISPQRS = ISPQRS+1 + + ! def + + ! redefine indices from Parr to Dirac notation <-> (i,j|k,l) + + p = nsi + q = nsk + r = nsj + s = nsl + + ! def. sense + + ! type (ij|kl) + ! 1 - si=sk, si=sj, sk=sl + ! 2 - si=sk, si=sj, sk>sl + ! 3 - si=sk, si>sj, sk=sl + ! 4 - si=sk, si>sj, sk>sl + ! 5 - si>sk, si=sj, sk=sl + ! 6 - si>sk, si=sj, sk>sl + ! 7 - si>sk, si>sj, sk=sl + ! 8 - si>sk, si>sj, sk>sl + + if (nsi == nsk) then + if (nsi == nsj) then + if (nsk == nsl) then + sense = 1 + else + sense = 2 + end if + else + if (nsk == nsl) then + sense = 3 + else + sense = 4 + end if + end if + else + if (nsi == nsj) then + if (nsk == nsl) then + sense = 5 + else + sense = 6 + end if + else + if (nsk == nsl) then + sense = 7 + else + sense = 8 + end if + end if + end if + + if (nsijk /= nsl) then + sense = 0 + else if (NORB(NSI)*NORB(NSJ)*NORB(NSK)*NORB(NSL) == 0) then + sense = 0 + end if + + !1: perm -> + + pa = p + qa = q + ra = r + typ(pa,qa,ra) = sense + idis(pa,qa,ra) = idistemp + np(pa,qa,ra) = 1 + nq(pa,qa,ra) = 3 + nr(pa,qa,ra) = 2 + ns(pa,qa,ra) = 4 + + !2: perm -> 1-3 + + pa = r + qa = q + ra = p + typ(pa,qa,ra) = sense + idis(pa,qa,ra) = idistemp + np(pa,qa,ra) = 2 + nq(pa,qa,ra) = 3 + nr(pa,qa,ra) = 1 + ns(pa,qa,ra) = 4 + + !3: perm -> 2-4 + + pa = p + qa = s + ra = r + typ(pa,qa,ra) = sense + idis(pa,qa,ra) = idistemp + np(pa,qa,ra) = 1 + nq(pa,qa,ra) = 4 + nr(pa,qa,ra) = 2 + ns(pa,qa,ra) = 3 + + !4: perm -> 1-3,2-4 + + pa = r + qa = s + ra = p + typ(pa,qa,ra) = sense + idis(pa,qa,ra) = idistemp + np(pa,qa,ra) = 2 + nq(pa,qa,ra) = 4 + nr(pa,qa,ra) = 1 + ns(pa,qa,ra) = 3 + + !5: perm -> 1-2,3-4 + + pa = q + qa = p + ra = s + typ(pa,qa,ra) = sense + idis(pa,qa,ra) = idistemp + np(pa,qa,ra) = 3 + nq(pa,qa,ra) = 1 + nr(pa,qa,ra) = 4 + ns(pa,qa,ra) = 2 + + !6: perm -> 1-2,3-4 -> 1-3 + + pa = s + qa = p + ra = q + typ(pa,qa,ra) = sense + idis(pa,qa,ra) = idistemp + np(pa,qa,ra) = 4 + nq(pa,qa,ra) = 1 + nr(pa,qa,ra) = 3 + ns(pa,qa,ra) = 2 + + !7: perm -> 1-2,3-4 -> 2-4 + + pa = q + qa = r + ra = s + typ(pa,qa,ra) = sense + idis(pa,qa,ra) = idistemp + np(pa,qa,ra) = 3 + nq(pa,qa,ra) = 2 + nr(pa,qa,ra) = 4 + ns(pa,qa,ra) = 1 + + !8: perm -> 1-2,3-4 -> 1-3,2-4 + + pa = s + qa = r + ra = q + typ(pa,qa,ra) = sense + idis(pa,qa,ra) = idistemp + np(pa,qa,ra) = 4 + nq(pa,qa,ra) = 2 + nr(pa,qa,ra) = 3 + ns(pa,qa,ra) = 1 + + !idispsb(ispqrs) = idistemp + idishelp = 0 + + !*************************************************************** + + ! LOOP OVER THE USED ORBITALS OF EACH SYMMETRY BLOCK + ! THIS LOOPING IS COPIED FROM THE MANUAL OF THE 4-INDEX + ! TRANSFORMATION PROGRAM + ! + ! N_INT COUNTS INTEGRAL LABELS IN THE GIVEN SYMMETRY BLOCK + + N_INT = 0 + KUP = NORB(NSK) + do KOLD=1,KUP + + LUP = NORB(NSL) + if (NSK == NSL) LUP = KOLD + do LOLD=1,LUP + + ILOW = 1 + if (NSI == NSK) ILOW = KOLD + IUP = NORB(NSI) + do IOLD=ILOW,IUP + + JLOW = 1 + if ((NSI == NSK) .and. (IOLD == KOLD)) JLOW = LOLD + JUP = NORB(NSJ) + if (NSI == NSJ) JUP = IOLD + do JOLD=JLOW,JUP + + IND = IND+1 + INDT = INDT+1 + N_INT = N_INT+1 + idishelp = idishelp+1 + if (idishelp > nTraBuf) then + !FUE - all integrals in the reord were processed, hence + !FUE update the disk address by a dummy I/O + dum(1) = Zero + call dDaFile(LUINTM,0,dum,nTraBuf,idistemp) + !FUE idistemp = idistemp+idisadd + idishelp = 1 + end if + + if (IND >= nTraBuf) IND = 0 + + end do + end do + end do + end do + if (idishelp > 0) then + !FUE - all integrals in the reord were processed, hence + !FUE update the disk address by a dummy I/O + dum(1) = Zero + call dDaFile(LUINTM,0,dum,nTraBuf,idistemp) + !FUE idistemp = idistemp+idisadd + end if + + ! WRITING THE LAST RECORD OF LABELS IN THE GIVEN SYMMETRY BLOCK + ! RECORDS ON LUPACK ARE FORMATTED TO 28KB LENGTH + + if (IND /= 0) IND = 0 + + NOIPSB(ISPQRS) = N_INT + + !*************************************************************** + + if (fullprint > 0) write(u6,'(6X,I5,2X,4I2,2X,4I4,2X,I8)') ISPQRS,NSI,NSJ,NSK,NSL,IUP,JUP,KUP,LUP,N_INT + + !*************************************************************** + + end do + end do + end do +end do +if (fullprint > 0) write(u6,'(6X,A)') '-------------------------------------------' + +return + +end subroutine mkaddress diff -Nru openmolcas-22.02/src/ccsort_util/mkadress.f openmolcas-22.10/src/ccsort_util/mkadress.f --- openmolcas-22.02/src/ccsort_util/mkadress.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mkadress.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,364 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE mkadress (NOIPSB) - -CFUE -CFUE It is strictly forbidden to use any construct to fetch disk -CFUE addresses which do not make use of subroutines provided in -CFUE the MOLCAS utilities as otherwise transparency and portability -CFUE is lost. -CFUE - -C -c this routine prepair information arrays -c for integral blocks per symmetry in primitive form -c it defines: -c noipsb(nijkl) - number of integrals per symmetry block -c idispsb(nijkl)- initial addreses for exach symmetry block -c typ(pa,qa,ra) - typ of symmetry block -c types of (ij|kl): -c 1 - si=sk, si=sj, sk=sl -c 2 - si=sk, si=sj, sk>sl -c 3 - si=sk, si>sj, sk=sl -c 4 - si=sk, si>sj, sk>sl -c 5 - si>sk, si=sj, sk=sl -c 6 - si>sk, si=sj, sk>sl -c 7 - si>sk, si>sj, sk=sl -c 8 - si>sk, si>sj, sk>sl -c -c idis(pa,qa,ra)- initial addreses for given symmetry block -c np(pa,qa,ra) - possition of p index in original block (ij|kl) (on tape) -c nq(pa,qa,ra) - possition of q index in original block (ij|kl) (on tape) -c nr(pa,qa,ra) - possition of r index in original block (ij|kl) (on tape) -c ns(pa,qa,ra) - possition of s index in original block (ij|kl) (on tape) -c -c N.B. typ,idis,np,nq,nr,ns are trensfered thhrough common block /edpand2/ -c -c - IMPLICIT REAL*8(A-H,O-Z) - -#include "tratoc.fh" - integer INDMAX,MXFUNC - PARAMETER (INDMAX=nTraBuf,MXFUNC=200) - - -#include "SysDef.fh" -#include "ccsort.fh" -#include "reorg.fh" - - integer NOIPSB(106) -c integer idispsb(106) -c -c help variables -c - integer sense - integer p,q,r,s,pa,qa,ra - integer IND,INDT,ISPQRS,NINT,NSLM,idistemp,idishelp - integer jlow,ilow,iup,jup,kup,lup,iold,jold,kold,lold - integer norbp,nsi,nsj,nsk,nsl,nsij,nsijk - real*8 dum(1) - -CFUE - pick the start addresses of each symmetry allowed integral -CFUE block from the tranformed two electron integral file - idistemp=0 - Call iDaFile(LUINTM,0,iTraToc,nTraToc,idistemp) -CFUE - the option 0 in the call to dafile does not make any I/O -CFUE but just returns the updated disk address -CFUE - at this point idistemp points to the first record - -C - IND=0 - INDT=0 -CFUE idistemp=1 -CFUE idisadd=150 -C - do 100 NSI=1,NSYM - do 101 NSJ=1,NSYM - do 102 NSK=1,NSYM - typ(NSI,NSJ,NSK)=0 - 102 continue - 101 continue - 100 continue -c - - if (fullprint.gt.0) then - Write(6,'(6X,A)') 'Transformed integral blocks:' - Write(6,'(6X,A)') '----------------------------' - Write(6,*) - Write(6,'(6X,A)') - & 'block symmetry no. of no. of ' - Write(6,'(6X,A)') - & ' no. spec. orbitals integrals' - Write(6,'(6X,A)') - & '-------------------------------------------' - end if -c - ISPQRS=0 - DO 300 NSI=1,NSYM - DO 301 NSJ=1,NSI - NSIJ=MUL(NSI,NSJ) - DO 302 NSK=1,NSI - NSIJK=MUL(NSK,NSIJ) - NSLM=NSK - IF(NSK.EQ.NSI) NSLM=NSJ - DO 303 NSL=1,NSLM - IF(NSIJK.NE.NSL) GO TO 303 - NORBP=NORB(NSI)*NORB(NSJ)*NORB(NSK)*NORB(NSL) - IF(NORBP.EQ.0)GO TO 303 - ISPQRS=ISPQRS+1 -c -c def -c -c redefine indices from Parr to Dirac notation <-> (i,j|k,l) -c - p=nsi - q=nsk - r=nsj - s=nsl -c -c def. sense -c -c type (ij|kl) -c 1 - si=sk, si=sj, sk=sl -c 2 - si=sk, si=sj, sk>sl -c 3 - si=sk, si>sj, sk=sl -c 4 - si=sk, si>sj, sk>sl -c 5 - si>sk, si=sj, sk=sl -c 6 - si>sk, si=sj, sk>sl -c 7 - si>sk, si>sj, sk=sl -c 8 - si>sk, si>sj, sk>sl -c - if (nsi.eq.nsk) then - if (nsi.eq.nsj) then - if (nsk.eq.nsl) then - sense=1 - else - sense=2 - end if - else - if (nsk.eq.nsl) then - sense=3 - else - sense=4 - end if - end if - else - if (nsi.eq.nsj) then - if (nsk.eq.nsl) then - sense=5 - else - sense=6 - end if - else - if (nsk.eq.nsl) then - sense=7 - else - sense=8 - end if - end if - end if -c - if (nsijk.ne.nsl) then - sense=0 - else if (NORB(NSI)*NORB(NSJ)*NORB(NSK)*NORB(NSL).eq.0) then - sense=0 - end if -c -c -c1: perm -> -c - pa=p - qa=q - ra=r - typ(pa,qa,ra)=sense - idis(pa,qa,ra)=idistemp - np(pa,qa,ra)=1 - nq(pa,qa,ra)=3 - nr(pa,qa,ra)=2 - ns(pa,qa,ra)=4 -c -c2: perm -> 1-3 -c - pa=r - qa=q - ra=p - typ(pa,qa,ra)=sense - idis(pa,qa,ra)=idistemp - np(pa,qa,ra)=2 - nq(pa,qa,ra)=3 - nr(pa,qa,ra)=1 - ns(pa,qa,ra)=4 -c -c3: perm -> 2-4 -c - pa=p - qa=s - ra=r - typ(pa,qa,ra)=sense - idis(pa,qa,ra)=idistemp - np(pa,qa,ra)=1 - nq(pa,qa,ra)=4 - nr(pa,qa,ra)=2 - ns(pa,qa,ra)=3 -c -c4: perm -> 1-3,2-4 -c - pa=r - qa=s - ra=p - typ(pa,qa,ra)=sense - idis(pa,qa,ra)=idistemp - np(pa,qa,ra)=2 - nq(pa,qa,ra)=4 - nr(pa,qa,ra)=1 - ns(pa,qa,ra)=3 -c -c5: perm -> 1-2,3-4 -c - pa=q - qa=p - ra=s - typ(pa,qa,ra)=sense - idis(pa,qa,ra)=idistemp - np(pa,qa,ra)=3 - nq(pa,qa,ra)=1 - nr(pa,qa,ra)=4 - ns(pa,qa,ra)=2 -c -c6: perm -> 1-2,3-4 -> 1-3 -c - pa=s - qa=p - ra=q - typ(pa,qa,ra)=sense - idis(pa,qa,ra)=idistemp - np(pa,qa,ra)=4 - nq(pa,qa,ra)=1 - nr(pa,qa,ra)=3 - ns(pa,qa,ra)=2 -c -c7: perm -> 1-2,3-4 -> 2-4 -c - pa=q - qa=r - ra=s - typ(pa,qa,ra)=sense - idis(pa,qa,ra)=idistemp - np(pa,qa,ra)=3 - nq(pa,qa,ra)=2 - nr(pa,qa,ra)=4 - ns(pa,qa,ra)=1 -c -c8: perm -> 1-2,3-4 -> 1-3,2-4 -c - pa=s - qa=r - ra=q - typ(pa,qa,ra)=sense - idis(pa,qa,ra)=idistemp - np(pa,qa,ra)=4 - nq(pa,qa,ra)=2 - nr(pa,qa,ra)=3 - ns(pa,qa,ra)=1 -c -c -c idispsb(ispqrs)=idistemp - idishelp=0 -C -C ****************************************************************** -C -C LOOP OVER THE USED ORBITALS OF EACH SYMMETRY BLOCK -C THIS LOOPING IS COPIED FROM THE MANUAL OF THE 4-INDEX -C TRANSFORMATION PROGRAM -C -C NINT COUNTS INTEGRAL LABELS IN THE GIVEN SYMMETRY BLOCK -C - NINT=0 - KUP=NORB(NSK) - DO 401 KOLD=1,KUP -C - LUP=NORB(NSL) - IF (NSK.EQ.NSL) LUP=KOLD - DO 402 LOLD=1,LUP -C - ILOW=1 - IF (NSI.EQ.NSK) ILOW=KOLD - IUP=NORB(NSI) - DO 403 IOLD=ILOW,IUP -C - JLOW=1 - IF (NSI.EQ.NSK.AND.IOLD.EQ.KOLD) JLOW=LOLD - JUP=NORB(NSJ) - IF (NSI.EQ.NSJ) JUP=IOLD - DO 404 JOLD=JLOW,JUP -C - IND=IND+1 - INDT=INDT+1 - NINT=NINT+1 - idishelp=idishelp+1 - if (idishelp.gt.INDMAX) then -CFUE - all integrals in the reord were processed, hence -CFUE update the disk address by a dummy I/O - dum(1)=0.0d0 - Call dDaFile(LUINTM,0,dum,INDMAX,idistemp) -CFUE idistemp=idistemp+idisadd - idishelp=1 - end if -C - IF (IND.LT.INDMAX) GO TO 404 - IND=0 -C - 404 CONTINUE - 403 CONTINUE - 402 CONTINUE - 401 CONTINUE - if (idishelp.gt.0) then -CFUE - all integrals in the reord were processed, hence -CFUE update the disk address by a dummy I/O - dum(1)=0.0d0 - Call dDaFile(LUINTM,0,dum,INDMAX,idistemp) -CFUE idistemp=idistemp+idisadd - end if -C -C WRITING THE LAST RECORD OF LABELS IN THE GIVEN SYMMETRY BLOCK -C RECORDS ON LUPACK ARE FORMATTED TO 28KB LENGTH -C - IF(IND.NE.0) THEN - IND=0 - ENDIF -C - NOIPSB(ISPQRS)=NINT -C -C ****************************************************************** -C - if (fullprint.gt.0) then - Write(6,'(6X,I5,2X,4I2,2X,4I4,2X,I8)') - & ISPQRS, - & NSI,NSJ,NSK,NSL, - & IUP,JUP,KUP,LUP, - & NINT - end if -C -C ****************************************************************** -C -C - 303 CONTINUE - 302 CONTINUE - 301 CONTINUE - 300 CONTINUE - if (fullprint.gt.0) then - Write(6,'(6X,A)') - & '-------------------------------------------' - end if -C - RETURN - END -c diff -Nru openmolcas-22.02/src/ccsort_util/mkampq.f openmolcas-22.10/src/ccsort_util/mkampq.f --- openmolcas-22.02/src/ccsort_util/mkampq.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mkampq.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,47 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine mkampq (wrk,wrksize, - & a,ammap) -c -c this routine reconstruct #2 V2<_a,m|p,q> from corresponding TEMPDA2 file -c -#include "wrk.fh" -#include "reorg.fh" -#include "ccsort.fh" - integer a - integer ammap(1:mbas,1:8,1:8) -c -c help variables -c - integer symm,symp - integer iiv2,length,poss,irec0 -c -c* loops over symmetry combinations - do 100 symm=1,nsym - do 101 symp=1,nsym -c -c* def initioal record possition in TEMPDA2 -c and corresponding possition and length in wrk (#2) -c - irec0=ammap(a,symm,symp) - iiv2=mapi2(symm,symp,1) - poss=mapd2(iiv2,1) - length=mapd2(iiv2,2) -c - if (length.gt.0) then - call daread (lunda2,irec0,wrk(poss),length,recl) - end if -c - 101 continue - 100 continue -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/mkampq.F90 openmolcas-22.10/src/ccsort_util/mkampq.F90 --- openmolcas-22.02/src/ccsort_util/mkampq.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mkampq.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,44 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine mkampq(wrk,wrksize,a,ammap) +! this routine reconstructs #2 V2<_a,m|p,q> from corresponding TEMPDA2 file + +use ccsort_global, only: lunda2, mapd2, mapi2, mbas, NSYM, reclen +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: wrksize, a, ammap(mbas,8,8) +real(kind=wp), intent(_OUT_) :: wrk(wrksize) +integer(kind=iwp) :: iiv2, irec0, length, pos, symm, symp + +! loops over symmetry combinations +do symm=1,nsym + do symp=1,nsym + + ! def initial record position in TEMPDA2 + ! and corresponding position and length in wrk (#2) + + irec0 = ammap(a,symm,symp) + iiv2 = mapi2(symm,symp,1) + pos = mapd2(iiv2,1) + length = mapd2(iiv2,2) + + if (length > 0) call daread(lunda2,irec0,wrk(pos),length,reclen) + + end do +end do + +return + +end subroutine mkampq diff -Nru openmolcas-22.02/src/ccsort_util/mkampqmap.f openmolcas-22.10/src/ccsort_util/mkampqmap.f --- openmolcas-22.02/src/ccsort_util/mkampqmap.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mkampqmap.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,67 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine mkampqmap (ammap,syma,rc) -c -c this routine prepair ammap -c -#include "reorg.fh" -#include "ccsort.fh" -c - integer syma,rc - integer ammap(1:mbas,1:8,1:8) -c -c help variables -c - integer a,symp,symq,symm,symam - integer lengthmpq,nrecc,nrest,irec -c -cT test, if there are any a in this symmtry -c - if (nvb(syma).eq.0) then - rc=1 -c RC=1 : there are no a in this symmetry - return - else - rc=0 - end if -c -c* def initial address -c - irec=1 -c -c* loop over all combinations -c - do 100 symm=1,nsym - symam=mul(syma,symm) - do 101 symp=1,nsym - symq=mul(symam,symp) -c -c* define number of records, required to store this block -c and determine shift in initial possitions -c - lengthmpq=noa(symm)*norb(symp)*norb(symq) - nrecc=int(lengthmpq/recl) - nrest=lengthmpq-nrecc*recl - if (nrest.gt.0) then - nrecc=nrecc+1 - end if -c - do 102 a=1,nvb(syma) -c - ammap(a,symm,symp)=irec - irec=irec+nrecc -c - 102 continue - 101 continue - 100 continue -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/mkampqmap.F90 openmolcas-22.10/src/ccsort_util/mkampqmap.F90 --- openmolcas-22.02/src/ccsort_util/mkampqmap.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mkampqmap.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,67 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine mkampqmap(ammap,syma,rc) +! this routine prepares ammap + +use ccsort_global, only: noa, mbas, NORB, NSYM, nvb, reclen +use Symmetry_Info, only: Mul +use Definitions, only: iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(_OUT_) :: ammap(mbas,8,8) +integer(kind=iwp), intent(in) :: syma +integer(kind=iwp), intent(out) :: rc +integer(kind=iwp) :: a, irec, lengthmpq, nrecc, nrest, symam, symm, symp, symq + +rc = 0 + +!T test, if there are any a in this symmetry + +if (nvb(syma) == 0) then + rc = 1 + ! RC=1 : there are no a in this symmetry + return +end if + +! def initial address + +irec = 1 + +! loop over all combinations + +do symm=1,nsym + symam = mul(syma,symm) + do symp=1,nsym + symq = mul(symam,symp) + + ! define number of records required to store this block + ! and determine shift in initial positions + + lengthmpq = noa(symm)*norb(symp)*norb(symq) + nrecc = int(lengthmpq/reclen) + nrest = lengthmpq-nrecc*reclen + if (nrest > 0) nrecc = nrecc+1 + + do a=1,nvb(syma) + + ammap(a,symm,symp) = irec + irec = irec+nrecc + + end do + end do +end do + +return + +end subroutine mkampqmap diff -Nru openmolcas-22.02/src/ccsort_util/mkintsta.f openmolcas-22.10/src/ccsort_util/mkintsta.f --- openmolcas-22.02/src/ccsort_util/mkintsta.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mkintsta.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,137 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine mkintsta (wrk,wrksize, - & foka,fokb) -c -c this routine produces integral file INTSTA, which contains -c following integrals: foka,fokb, -c aaaa,bbbb,abab -c aaaa,bbbb,abab,baab -c aaaa,bbbb,abab -c -c N.B. 1. work file #1 is used for integrals, #2,3,4 -c must be free. possb0 must be defined -c N.B. 2. this routine can be used only after definition of -c N.B. 3. this routine use followuing help routines: -c expandfok -c wrtmediate (from SYMM) -c -c -#include "wrk.fh" -#include "reorg.fh" -#include "files_ccsd.fh" - real*8 foka(*) - real*8 fokb(*) -c -c help variables -c - integer rc -c -c* open INTSTA file - if (iokey.eq.1) then -c Fortarn IO - call molcas_binaryopen_vanilla(lunsta,'INTSTA') -c open (unit=lunsta,file='INTSTA',form='unformatted') -c - else -c MOLCAS IO - call daname (lunsta,'INTSTA') - daddr(lunsta)=0 - end if -c -c* expand foka into work #2 and write to INTSTA - call expandfok (wrk,wrksize, - & foka) - call dawrtmediate (wrk,wrksize, - & lunsta,mapd2,mapi2,rc) -c -c* expand fokb into work #2 and write to INTSTA - call expandfok (wrk,wrksize, - & fokb) - call dawrtmediate (wrk,wrksize, - & lunsta,mapd2,mapi2,rc) -c -c -c* get #2 aaaa from #1 and write to INTSTA - call exppqij (wrk,wrksize, - & 4,1,1,1,1,1,1) - call dawrtmediate (wrk,wrksize, - & lunsta,mapd2,mapi2,rc) -c -c* get #2 bbbb from #1 and write to INTSTA - call exppqij (wrk,wrksize, - & 4,2,2,2,2,1,1) - call dawrtmediate (wrk,wrksize, - & lunsta,mapd2,mapi2,rc) -c -c* get #2 abab from #1 and write to INTSTA - call exppqij (wrk,wrksize, - & 0,1,2,1,2,1,0) - call dawrtmediate (wrk,wrksize, - & lunsta,mapd2,mapi2,rc) -c -c -c* get #2 aaaa from #1 and write to INTSTA - call exppqij (wrk,wrksize, - & 3,1,3,1,1,1,1) - call dawrtmediate (wrk,wrksize, - & lunsta,mapd2,mapi2,rc) -c -c* get #2 bbbb from #1 and write to INTSTA - call exppqij (wrk,wrksize, - & 3,2,4,2,2,1,1) - call dawrtmediate (wrk,wrksize, - & lunsta,mapd2,mapi2,rc) -c -c* get #2 abab from #1 and write to INTSTA - call exppqij (wrk,wrksize, - & 0,1,4,1,2,1,0) - call dawrtmediate (wrk,wrksize, - & lunsta,mapd2,mapi2,rc) -c -c* get #2 baab from #1 and write to INTSTA - call exppqij (wrk,wrksize, - & 0,2,3,1,2,0,1) - call dawrtmediate (wrk,wrksize, - & lunsta,mapd2,mapi2,rc) -c -c -c* get #2 aaaa from #1 and write to INTSTA - call exppqij (wrk,wrksize, - & 4,3,3,1,1,1,1) - call dawrtmediate (wrk,wrksize, - & lunsta,mapd2,mapi2,rc) -c -c* get #2 bbbb from #1 and write to INTSTA - call exppqij (wrk,wrksize, - & 4,4,4,2,2,1,1) - call dawrtmediate (wrk,wrksize, - & lunsta,mapd2,mapi2,rc) -c -c* get #2 abab from #1 and write to INTSTA - call exppqij (wrk,wrksize, - & 0,3,4,1,2,1,0) - call dawrtmediate (wrk,wrksize, - & lunsta,mapd2,mapi2,rc) -c -c* close INTSTA file -c - if (iokey.eq.1) then -c Fortran IO - close (lunsta) -c - else -c MOLCAS IO - call daclos (lunsta) - end if -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/mkintsta.F90 openmolcas-22.10/src/ccsort_util/mkintsta.F90 --- openmolcas-22.02/src/ccsort_util/mkintsta.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mkintsta.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,111 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine mkintsta(wrk,wrksize,foka,fokb) +! this routine produces integral file INTSTA, which contains +! following integrals: foka,fokb, +! aaaa,bbbb,abab +! aaaa,bbbb,abab,baab +! aaaa,bbbb,abab +! +! N.B. 1. work file #1 is used for integrals, #2,3,4 +! must be free. posb0 must be defined +! N.B. 2. this routine can be used only after definition of +! N.B. 3. this routine use following help routines: +! expandfok +! wrtmediate (from SYMM) + +use ccsort_global, only: daddr, iokey, mapd2, mapi2 +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: wrksize +real(kind=wp), intent(_OUT_) :: wrk(wrksize) +real(kind=wp), intent(in) :: foka(*), fokb(*) +integer(kind=iwp) :: lunsta, rc + +! open INTSTA file +lunsta = 21 +if (iokey == 1) then + ! Fortarn IO + call molcas_binaryopen_vanilla(lunsta,'INTSTA') + !open(unit=lunsta,file='INTSTA',form='unformatted') + +else + ! MOLCAS IO + call daname(lunsta,'INTSTA') + daddr(lunsta) = 0 +end if + +! expand foka into work #2 and write to INTSTA +call expandfok(wrk,wrksize,foka) +call dawrtmediate(wrk,wrksize,lunsta,mapd2,mapi2,rc) + +! expand fokb into work #2 and write to INTSTA +call expandfok(wrk,wrksize,fokb) +call dawrtmediate(wrk,wrksize,lunsta,mapd2,mapi2,rc) + +! get #2 aaaa from #1 and write to INTSTA +call exppqij(wrk,wrksize,4,1,1,1,1,1,1) +call dawrtmediate(wrk,wrksize,lunsta,mapd2,mapi2,rc) + +! get #2 bbbb from #1 and write to INTSTA +call exppqij(wrk,wrksize,4,2,2,2,2,1,1) +call dawrtmediate(wrk,wrksize,lunsta,mapd2,mapi2,rc) + +! get #2 abab from #1 and write to INTSTA +call exppqij(wrk,wrksize,0,1,2,1,2,1,0) +call dawrtmediate(wrk,wrksize,lunsta,mapd2,mapi2,rc) + +! get #2 aaaa from #1 and write to INTSTA +call exppqij(wrk,wrksize,3,1,3,1,1,1,1) +call dawrtmediate(wrk,wrksize,lunsta,mapd2,mapi2,rc) + +! get #2 bbbb from #1 and write to INTSTA +call exppqij(wrk,wrksize,3,2,4,2,2,1,1) +call dawrtmediate(wrk,wrksize,lunsta,mapd2,mapi2,rc) + +! get #2 abab from #1 and write to INTSTA +call exppqij(wrk,wrksize,0,1,4,1,2,1,0) +call dawrtmediate(wrk,wrksize,lunsta,mapd2,mapi2,rc) + +! get #2 baab from #1 and write to INTSTA +call exppqij(wrk,wrksize,0,2,3,1,2,0,1) +call dawrtmediate(wrk,wrksize,lunsta,mapd2,mapi2,rc) + +! get #2 aaaa from #1 and write to INTSTA +call exppqij(wrk,wrksize,4,3,3,1,1,1,1) +call dawrtmediate(wrk,wrksize,lunsta,mapd2,mapi2,rc) + +! get #2 bbbb from #1 and write to INTSTA +call exppqij(wrk,wrksize,4,4,4,2,2,1,1) +call dawrtmediate(wrk,wrksize,lunsta,mapd2,mapi2,rc) + +! get #2 abab from #1 and write to INTSTA +call exppqij(wrk,wrksize,0,3,4,1,2,1,0) +call dawrtmediate(wrk,wrksize,lunsta,mapd2,mapi2,rc) + +! close INTSTA file + +if (iokey == 1) then + ! Fortran IO + close(lunsta) + +else + ! MOLCAS IO + call daclos(lunsta) +end if + +return + +end subroutine mkintsta diff -Nru openmolcas-22.02/src/ccsort_util/mkmapampq.f openmolcas-22.10/src/ccsort_util/mkmapampq.f --- openmolcas-22.02/src/ccsort_util/mkmapampq.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mkmapampq.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,70 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine mkmapampq (syma) -c -c this routine prepair mapd,mapi -c for for given syma, m, p,q to mapd2,mapi2 -c -#include "ccsort.fh" -#include "reorg.fh" - integer syma -c -c help variables -c - integer symm,symp,symq,symmp - integer nhelp,possition,length -c -c* set mapi1 to zero -c - do 1 symq=1,nsym - do 2 symp=1,nsym - do 3 symm=1,nsym - mapi2(symm,symp,symq)=0 - 3 continue - 2 continue - 1 continue -c -c def zero-th row -c - mapd2(0,1)=1 - mapd2(0,2)=5 - mapd2(0,3)=5 - mapd2(0,4)=0 - mapd2(0,6)=0 - - nhelp=0 - possition=poss20 - do 100 symm=1,nsym - do 101 symp=1,nsym - symmp=mul(symm,symp) - symq=mul(syma,symmp) - nhelp=nhelp+1 -c -c calc. length - length=noa(symm)*NORB(symp)*NORB(symq) -c - mapd2(nhelp,1)=possition - mapd2(nhelp,2)=length - mapd2(nhelp,3)=symm - mapd2(nhelp,4)=symp - mapd2(nhelp,5)=symq - mapd2(nhelp,6)=1 - possition=possition+length -c - mapi2(symm,symp,1)=nhelp -c - 101 continue - 100 continue -c - mapd2(0,5)=nhelp -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/mkmapampq.F90 openmolcas-22.10/src/ccsort_util/mkmapampq.F90 --- openmolcas-22.02/src/ccsort_util/mkmapampq.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mkmapampq.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,64 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine mkmapampq(syma) +! this routine prepares mapd,mapi +! for for given syma, m, p,q to mapd2,mapi2 + +use ccsort_global, only: mapd2, mapi2, noa, NORB, NSYM, pos20 +use Symmetry_Info, only: Mul +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: syma +integer(kind=iwp) :: length, nhelp, pos, symm, symmp, symp, symq + +! set mapi1 to zero + +mapi2(1:nsym,1:nsym,1:nsym) = 0 + +! def zero-th row + +mapd2(0,1) = 1 +mapd2(0,2) = 5 +mapd2(0,3) = 5 +mapd2(0,4) = 0 +mapd2(0,6) = 0 + +nhelp = 0 +pos = pos20 +do symm=1,nsym + do symp=1,nsym + symmp = mul(symm,symp) + symq = mul(syma,symmp) + nhelp = nhelp+1 + + ! calc. length + length = noa(symm)*NORB(symp)*NORB(symq) + + mapd2(nhelp,1) = pos + mapd2(nhelp,2) = length + mapd2(nhelp,3) = symm + mapd2(nhelp,4) = symp + mapd2(nhelp,5) = symq + mapd2(nhelp,6) = 1 + pos = pos+length + + mapi2(symm,symp,1) = nhelp + + end do +end do + +mapd2(0,5) = nhelp + +return + +end subroutine mkmapampq diff -Nru openmolcas-22.02/src/ccsort_util/mkmappqij.f openmolcas-22.10/src/ccsort_util/mkmappqij.f --- openmolcas-22.02/src/ccsort_util/mkmappqij.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mkmappqij.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,73 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine mkmappqij -c -c this routine prepair mapd,mapi -c for for p,q, i>=j to mapd1,mapi1 -c -#include "ccsort.fh" -#include "reorg.fh" -c -c help variables -c - integer symi,symj,symp,symq,sympq,sympqi - integer nhelp,possition,length -c -c* set mapi1 to zero -c - do 1 symi=1,nsym - do 2 symq=1,nsym - do 3 symp=1,nsym - mapi1(symp,symq,symi)=0 - 3 continue - 2 continue - 1 continue -c -c def zero-th row -c - mapd1(0,1)=5 - mapd1(0,2)=5 - mapd1(0,3)=1 - mapd1(0,4)=1 - mapd1(0,6)=3 - - nhelp=0 - possition=poss10 - do 100 symp=1,nsym - do 101 symq=1,nsym - sympq=mul(symp,symq) - do 102 symi=1,nsym - sympqi=mul(sympq,symi) - symj=sympqi - if (symj.gt.symi) goto 102 - nhelp=nhelp+1 -c -c calc. length - length=noa(symi)*noa(symj)*NORB(symp)*NORB(symq) -c - mapd1(nhelp,1)=possition - mapd1(nhelp,2)=length - mapd1(nhelp,3)=symp - mapd1(nhelp,4)=symq - mapd1(nhelp,5)=symi - mapd1(nhelp,6)=symj - possition=possition+length -c - mapi1(symp,symq,symi)=nhelp -c - 102 continue - 101 continue - 100 continue -c - mapd1(0,5)=nhelp -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/mkmappqij.F90 openmolcas-22.10/src/ccsort_util/mkmappqij.F90 --- openmolcas-22.02/src/ccsort_util/mkmappqij.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mkmappqij.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,67 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine mkmappqij() +! this routine prepares mapd,mapi +! for for p,q, i>=j to mapd1,mapi1 + +use ccsort_global, only: mapd1, mapi1, noa, NORB, NSYM, pos10 +use Symmetry_Info, only: Mul +use Definitions, only: iwp + +implicit none +integer(kind=iwp) :: length, nhelp, pos, symi, symj, symp, sympq, sympqi, symq + +! set mapi1 to zero + +mapi1(1:nsym,1:nsym,1:nsym) = 0 + +! def zero-th row + +mapd1(0,1) = 5 +mapd1(0,2) = 5 +mapd1(0,3) = 1 +mapd1(0,4) = 1 +mapd1(0,6) = 3 + +nhelp = 0 +pos = pos10 +do symp=1,nsym + do symq=1,nsym + sympq = mul(symp,symq) + do symi=1,nsym + sympqi = mul(sympq,symi) + symj = sympqi + if (symj > symi) cycle + nhelp = nhelp+1 + + ! calc. length + length = noa(symi)*noa(symj)*NORB(symp)*NORB(symq) + + mapd1(nhelp,1) = pos + mapd1(nhelp,2) = length + mapd1(nhelp,3) = symp + mapd1(nhelp,4) = symq + mapd1(nhelp,5) = symi + mapd1(nhelp,6) = symj + pos = pos+length + + mapi1(symp,symq,symi) = nhelp + + end do + end do +end do + +mapd1(0,5) = nhelp + +return + +end subroutine mkmappqij diff -Nru openmolcas-22.02/src/ccsort_util/mktempanam.f openmolcas-22.10/src/ccsort_util/mktempanam.f --- openmolcas-22.02/src/ccsort_util/mktempanam.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mktempanam.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine mktempanam -c -c this routine prepare names for TEMP and files as -c TEMP001 - TEMPmbas and store them into -c tmpnam and tmanam arrays (mbas-maximum number of basis functions) -c -c variables used: -c tmp-anam - array of TEMP file names (Transported through common /tmnames/) -c this routine (I) -c - implicit real*8 (a-h,o-z) -#include "reorg.fh" - integer lun,itemp,k1 -c - lun=lunpublic - call molcas_open(lun,'TEMP000') -c open (unit=lun,file='TEMP000') -c - itemp=0 - do 100 k1=1,9 - itemp=itemp+1 - if (itemp.gt.mbas) goto 500 - write (lun,99) k1 - 99 format (6hTEMP00,i1) - 100 continue -c - do 200 k1=10,99 - itemp=itemp+1 - if (itemp.gt.mbas) goto 500 - write (lun,199) k1 - 199 format (5hTEMP0,i2) - 200 continue -c - do 300 k1=100,mbas - itemp=itemp+1 - if (itemp.gt.mbas) goto 500 - write (lun,299) k1 - 299 format (4hTEMP,i3) - 300 continue -c - 500 rewind (lun) -c - do 600 itemp=1,mbas - read (lun,599) tmpnam(itemp) - 599 format (a7) - 600 continue -c - rewind (lun) - write (lun,*) ' File scratched' - close (lun) -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/mktempanam.F90 openmolcas-22.10/src/ccsort_util/mktempanam.F90 --- openmolcas-22.02/src/ccsort_util/mktempanam.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mktempanam.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,58 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine mktempanam() +! this routine prepares names for TEMP and files as +! TEMP001 - TEMPmbas and stores them into +! tmpnam and tmanam arrays (mbas-maximum number of basis functions) +! +! variables used: +! tmpnam - array of TEMP file names (imported from ccsort_global) +! this routine (I) + +use ccsort_global, only: lunpublic, mbas, tmpnam +use Definitions, only: iwp + +implicit none +integer(kind=iwp) :: itemp, k1, lun + +lun = lunpublic +call molcas_open(lun,'TEMP000') +!open(unit=lun,file='TEMP000') + +do k1=1,mbas + if (k1 < 10) then + write(lun,99) k1 + else if (k1 < 100) then + write(lun,199) k1 + else + write(lun,299) k1 + end if +end do + +rewind(lun) + +do itemp=1,mbas + read(lun,599) tmpnam(itemp) +end do + +rewind(lun) +write(lun,*) ' File scratched' +close(lun) + +return + +99 format('TEMP00',i1) +199 format('TEMP0',i2) +299 format('TEMP',i3) +599 format(a7) + +end subroutine mktempanam diff -Nru openmolcas-22.02/src/ccsort_util/mod1.f openmolcas-22.10/src/ccsort_util/mod1.f --- openmolcas-22.02/src/ccsort_util/mod1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mod1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,104 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1994, Per Ake Malmqvist * -* 1995,1996, Pavel Neogrady * -************************************************************************ - subroutine mod1 (nsym,nfro,nish,nash,nssh,ndel,norb,nfror,ndelr, - & firas,fi,epsras,eps) -c -c this routine do: -c 1) reduce firas, epsras if nfror>nfro, ndelr>ndel -c 2) redefine nfro,nish,nash,nssh,ndel,norb to proper ones -c - integer nsym - integer nfro(1:8) - integer ndel(1:8) - integer nish(1:8) - integer nash(1:8) - integer nssh(1:8) - integer norb(1:8) - integer nfror(1:8) - integer ndelr(1:8) - real*8 fi(*) - real*8 firas(*) - real*8 eps(*) - real*8 epsras(*) -c -c help variables -c - integer p,q,pqras,pqnew,pras,pnew,isym - integer ndf,ndd,nup,nlow - -c -c1 reduce fi -c - pqras=0 - pqnew=0 - do 100 isym=1,nsym -c - ndf=nfror(isym)-nfro(isym) - ndd=ndelr(isym)-ndel(isym) - nlow=ndf+1 - nup=norb(isym)-ndd -c - do 50 p=1,norb(isym) - do 51 q=1,p - pqras=pqras+1 -c - if ((p.ge.nlow).and.(p.le.nup)) then - if ((q.ge.nlow).and.(q.le.nup)) then - pqnew=pqnew+1 - fi(pqnew)=firas(pqras) - end if - end if -c - 51 continue - 50 continue -c - 100 continue -c -c2 reduce eps -c - pras=0 - pnew=0 - do 200 isym=1,nsym -c - ndf=nfror(isym)-nfro(isym) - ndd=ndelr(isym)-ndel(isym) - nlow=ndf+1 - nup=norb(isym)-ndd -c - do 150 p=1,norb(isym) - pras=pras+1 -c - if ((p.ge.nlow).and.(p.le.nup)) then - pnew=pnew+1 - eps(pnew)=epsras(pras) - end if -c - 150 continue -c - 200 continue -c -c3 define new nfro,nish,nash,nssh,ndel,norb -c - do 300 isym=1,nsym - nash(isym)=nash(isym) - nish(isym)=nish(isym)-nfror(isym)+nfro(isym) - nssh(isym)=nssh(isym)-ndelr(isym)+ndel(isym) - norb(isym)=norb(isym)-nfror(isym)+nfro(isym)-ndelr(isym) - & +ndel(isym) - nfro(isym)=nfror(isym) - 300 continue -c -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/mod1.F90 openmolcas-22.10/src/ccsort_util/mod1.F90 --- openmolcas-22.02/src/ccsort_util/mod1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mod1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,90 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1994, Per Ake Malmqvist * +! 1995,1996, Pavel Neogrady * +!*********************************************************************** + +subroutine mod1(nsym,nfro,nish,nssh,ndel,norb,nfror,ndelr,firas,fi,epsras,eps) +! this routine does: +! 1) reduce firas, epsras if nfror>nfro, ndelr>ndel +! 2) redefine nfro,nish,nssh,ndel,norb to proper ones + +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: nsym, ndel(8), nfror(8), ndelr(8) +integer(kind=iwp), intent(inout) :: nfro(8), nish(8), nssh(8), norb(8) +real(kind=wp), intent(in) :: firas(*), epsras(*) +real(kind=wp), intent(_OUT_) :: fi(*), eps(*) +integer(kind=iwp) :: isym, ndd, ndf, nlow, nup, p, pnew, pqnew, pqras, pras, q + +!1 reduce fi + +pqras = 0 +pqnew = 0 +do isym=1,nsym + + ndf = nfror(isym)-nfro(isym) + ndd = ndelr(isym)-ndel(isym) + nlow = ndf+1 + nup = norb(isym)-ndd + + do p=1,norb(isym) + do q=1,p + pqras = pqras+1 + + if ((p >= nlow) .and. (p <= nup)) then + if ((q >= nlow) .and. (q <= nup)) then + pqnew = pqnew+1 + fi(pqnew) = firas(pqras) + end if + end if + + end do + end do + +end do + +!2 reduce eps + +pras = 0 +pnew = 0 +do isym=1,nsym + + ndf = nfror(isym)-nfro(isym) + ndd = ndelr(isym)-ndel(isym) + nlow = ndf+1 + nup = norb(isym)-ndd + + do p=1,norb(isym) + pras = pras+1 + + if ((p >= nlow) .and. (p <= nup)) then + pnew = pnew+1 + eps(pnew) = epsras(pras) + end if + + end do + +end do + +!3 define new nfro,nish,nssh,ndel,norb + +nish(1:nsym) = nish(1:nsym)-nfror(1:nsym)+nfro(1:nsym) +nssh(1:nsym) = nssh(1:nsym)-ndelr(1:nsym)+ndel(1:nsym) +norb(1:nsym) = norb(1:nsym)-nfror(1:nsym)+nfro(1:nsym)-ndelr(1:nsym)+ndel(1:nsym) +nfro(1:nsym) = nfror(1:nsym) + +return + +end subroutine mod1 diff -Nru openmolcas-22.02/src/ccsort_util/mod2.f openmolcas-22.10/src/ccsort_util/mod2.f --- openmolcas-22.02/src/ccsort_util/mod2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mod2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,64 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1994, Per Ake Malmqvist * -* 1995,1996, Pavel Neogrady * -************************************************************************ - subroutine mod2 (nsym,nish,nash,nssh,norb,fi,eps) -c -c this routine define fi(p,q) = delta(p,q).eps(p) -c and redefine nish=nish+nash, nash=0 -c -c this is suitable for closed shell case -c - integer nsym - integer nish(1:8) - integer nash(1:8) - integer nssh(1:8) - integer norb(1:8) - real*8 fi(*) - real*8 eps(*) -c -c help variables -c - integer p,q,isym,pq,padd -c -c1 redefine foki -c - pq=0 - padd=0 - do 200 isym=1,nsym -c - do 100 p=1,norb(isym) - do 101 q=1,p - pq=pq+1 - if (p.eq.q) then - fi(pq)=eps(padd+p) - else - fi(pq)=0.0d0 - end if - 101 continue - 100 continue -c - padd=padd+norb(isym) - 200 continue -c -c2 redefine n's -c - do 300 isym=1,nsym - nish(isym)=nish(isym)+nash(isym) - nash(isym)=0 - 300 continue -c -c - return -c Avoid unused argument warnings - if (.false.) call Unused_integer_array(nssh) - end diff -Nru openmolcas-22.02/src/ccsort_util/mod2.F90 openmolcas-22.10/src/ccsort_util/mod2.F90 --- openmolcas-22.02/src/ccsort_util/mod2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mod2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,61 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1994, Per Ake Malmqvist * +! 1995,1996, Pavel Neogrady * +!*********************************************************************** + +subroutine mod2(nsym,nish,nash,norb,fi,eps) +! this routine defines fi(p,q) = delta(p,q).eps(p) +! and redefines nish=nish+nash, nash=0 +! +! this is suitable for closed shell case + +use Constants, only: Zero +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: nsym, norb(8) +integer(kind=iwp), intent(inout) :: nish(8) +integer(kind=iwp), intent(out) :: nash(8) +real(kind=wp), intent(_OUT_) :: fi(*) +real(kind=wp), intent(in) :: eps(*) +integer(kind=iwp) :: isym, p, padd, pq, q + +!1 redefine foki + +pq = 0 +padd = 0 +do isym=1,nsym + + do p=1,norb(isym) + do q=1,p + pq = pq+1 + if (p == q) then + fi(pq) = eps(padd+p) + else + fi(pq) = Zero + end if + end do + end do + + padd = padd+norb(isym) +end do + +!2 redefine n's + +nish(1:nsym) = nish(1:nsym)+nash(1:nsym) +nash(1:nsym) = 0 + +return + +end subroutine mod2 diff -Nru openmolcas-22.02/src/ccsort_util/motra.fh openmolcas-22.10/src/ccsort_util/motra.fh --- openmolcas-22.02/src/ccsort_util/motra.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/motra.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Integer nSymX - Integer nBasX(8) - Integer nOrbX(8) - Integer nFroX(8) - Integer nDelX(8) - Real*8 EcorX -c - common /motra1/ nSymX,nBasX,nOrbX,nFroX,nDelX - common /motra2/ EcorX diff -Nru openmolcas-22.02/src/ccsort_util/mreorg1.f openmolcas-22.10/src/ccsort_util/mreorg1.f --- openmolcas-22.02/src/ccsort_util/mreorg1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mreorg1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,117 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine mreorg1 (symp,symq,symr,typp,typq,typr, - & posspv1,possqv1,possrv1,typpv1,typqv1,typrv1, - & typv2,v1,v2,fact,dimp,dimqr,dimt,dimu,dimv) -c -c this routine map v2(p,qr) <+ fact . v1 (t,u,v) -c v2 may be of type 0,2 (typv2) while type v1 is always 0 -c symp-symr and typp-typr are symmetries and types of p-r indexex -c posspv1-possrv1 are corresponding possitions of p-r indexes in v1 -c N.B. v1 and v2 have no direct relation to #1 or #2, since here there -c is no reorg.fh included, v1,v2 corresponds to arbitrary matrices -c -c symp-r - symetries of p-r (I) -c typp-r - types of indexes p-r in V2 (I) -c possp-rv1 - possitions of p-r ind. in v1 (I) -c typp-rv1 - types of indices, corresponding to p-r in V1 (I) -c typv2 - type of V2 (0,1,2,4) (I) -c v1,v2 - arrays V1 and V2 (I,O) -c fact - multiplication factors (usually +-1.0d0) (I) -c dimp,qr - dimensions of V2 (I) -c dimt-s - dimensions of V1 (I) -c -c -c reorg.fh may not be included -#include "ccsort.fh" - integer symp,symq,symr,typp,typq,typr - integer posspv1,possqv1,possrv1 - integer typpv1,typqv1,typrv1,typv2 - integer dimp,dimqr,dimt,dimu,dimv - real*8 v2(1:dimp,1:dimqr) - real*8 v1(1:dimt,1:dimu,1:dimv) - real*8 fact -c -c help variables -c - integer p,q,r,qr,pup,qup,rup,rc,qryes - integer paddv1,qaddv1,raddv1 - integer ind(1:4) -c -c* def additional constants -c - call ireorg3 (symp,typp,typpv1,paddv1,rc) - call ireorg3 (symq,typq,typqv1,qaddv1,rc) - call ireorg3 (symr,typr,typrv1,raddv1,rc) -c -c* def sumation limits -c - call ireorg2 (symp,typp,pup,rc) - call ireorg2 (symq,typq,qup,rc) - call ireorg2 (symr,typr,rup,rc) -c -c* def qryes, rsyes (i.e. if there is a reduced sumations) -c - if (typv2.eq.2) then - if (symq.eq.symr) then - qryes=1 - else - qryes=0 - end if - else - qryes=0 - end if -c -c - if (qryes.eq.1) then -c -c* case p, q>s -c - qr=0 - do 100 q=2,qup - ind(possqv1)=qaddv1+q - do 101 r=1,q-1 - ind(possrv1)=raddv1+r - qr=qr+1 -c - do 102 p=1,pup - ind(posspv1)=paddv1+p -c - v2(p,qr)=v2(p,qr)+fact*v1(ind(1),ind(2),ind(3)) -c - 102 continue - 101 continue - 100 continue -c - else -c -c* case p q,r -c - qr=0 - do 200 r=1,rup - ind(possrv1)=raddv1+r - do 201 q=1,qup - ind(possqv1)=qaddv1+q - qr=qr+1 -c - do 202 p=1,pup - ind(posspv1)=paddv1+p -c - v2(p,qr)=v2(p,qr)+fact*v1(ind(1),ind(2),ind(3)) -c - 202 continue - 201 continue - 200 continue -c - end if -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/mreorg1.F90 openmolcas-22.10/src/ccsort_util/mreorg1.F90 --- openmolcas-22.02/src/ccsort_util/mreorg1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mreorg1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,108 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine mreorg1(symp,symq,symr,typp,typq,typr,pospv1,posqv1,posrv1,typpv1,typqv1,typrv1,typv2,v1,v2,fact,dimp,dimqr,dimt, & + dimu,dimv) +! this routine maps v2(p,qr) <+ fact . v1 (t,u,v) +! v2 may be of type 0,2 (typv2) while type v1 is always 0 +! symp-symr and typp-typr are symmetries and types of p-r indices +! pospv1-posrv1 are corresponding positions of p-r indices in v1 +! N.B. v1 and v2 have no direct relation to #1 or #2, since they +! are not imported, v1,v2 corresponds to arbitrary matrices +! +! symp-r - symmetries of p-r (I) +! typp-r - types of indices p-r in V2 (I) +! posp-rv1 - positions of p-r ind. in v1 (I) +! typp-rv1 - types of indices, corresponding to p-r in V1 (I) +! typv2 - type of V2 (0,1,2,4) (I) +! v1,v2 - arrays V1 and V2 (I,O) +! fact - multiplication factors (usually +-1.0) (I) +! dimp,qr - dimensions of V2 (I) +! dimt-s - dimensions of V1 (I) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: symp, symq, symr, typp, typq, typr, pospv1, posqv1, posrv1, typpv1, typqv1, typrv1, typv2, dimp, & + dimqr, dimt, dimu, dimv +real(kind=wp), intent(in) :: v1(dimt,dimu,dimv), fact +real(kind=wp), intent(inout) :: v2(dimp,dimqr) +integer(kind=iwp) :: ind(4), p, paddv1, pup, q, qaddv1, qr, qryes, qup, r, raddv1, rc, rup + +! def additional constants + +call ireorg3(symp,typp,typpv1,paddv1,rc) +call ireorg3(symq,typq,typqv1,qaddv1,rc) +call ireorg3(symr,typr,typrv1,raddv1,rc) + +! def sumation limits + +call ireorg2(symp,typp,pup,rc) +call ireorg2(symq,typq,qup,rc) +call ireorg2(symr,typr,rup,rc) + +! def qryes, rsyes (i.e. if there is a reduced sumations) + +if (typv2 == 2) then + if (symq == symr) then + qryes = 1 + else + qryes = 0 + end if +else + qryes = 0 +end if + +if (qryes == 1) then + + ! case p, q>s + + qr = 0 + do q=2,qup + ind(posqv1) = qaddv1+q + do r=1,q-1 + ind(posrv1) = raddv1+r + qr = qr+1 + + do p=1,pup + ind(pospv1) = paddv1+p + + v2(p,qr) = v2(p,qr)+fact*v1(ind(1),ind(2),ind(3)) + + end do + end do + end do + +else + + ! case p q,r + + qr = 0 + do r=1,rup + ind(posrv1) = raddv1+r + do q=1,qup + ind(posqv1) = qaddv1+q + qr = qr+1 + + do p=1,pup + ind(pospv1) = paddv1+p + + v2(p,qr) = v2(p,qr)+fact*v1(ind(1),ind(2),ind(3)) + + end do + end do + end do + +end if + +return + +end subroutine mreorg1 diff -Nru openmolcas-22.02/src/ccsort_util/mreorg.f openmolcas-22.10/src/ccsort_util/mreorg.f --- openmolcas-22.02/src/ccsort_util/mreorg.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mreorg.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,73 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine mreorg (wrk,wrksize, - & symp,symq,symr,typp,typq,typr, - & posspv2,possqv2,possrv2,typpv2,typqv2,typrv2, - & typv3,possv20,possv30,fact) -c -c this routine is up level routine for mreorg1 (also more detailed -c description can be found there). -c #2 must be of type 0, #3 can be 0, and 2 -c this routine only prepair some constants, required by ireorg1, -c that can be deduced form input data - dimp,dimqr,dimt-dimv -c -c symp-r - symetries of p-r (I) -c typp-r - types of indexes p-r in V2 (I) -c possp-rv2 - possitions of p-r ind. in V2 (I) -c typp-rv2 - types of indices, corresponding to p-r in V2 (I) -c typv3 - type of V3 (0,2) (I) -c possv20,30 - initial possitions of V2 and V3 in wrk (I) -c fact - multiplication factors (usually +-1.0d0) (I) -c -#include "wrk.fh" -#include "reorg.fh" -#include "ccsort.fh" - integer symp,symq,symr,typp,typq,typr - integer posspv2,possqv2,possrv2,typpv2,typqv2,typrv2 - integer typv3,possv20,possv30 - real*8 fact -c -c help variables -c - integer ind(1:4) - integer nhelp,mhelp,rc,dimp,dimqr -c -c* define dimensions of V2 -c - call ireorg2 (symp,typpv2,nhelp,rc) - ind(posspv2)=nhelp - call ireorg2 (symq,typqv2,nhelp,rc) - ind(possqv2)=nhelp - call ireorg2 (symr,typrv2,nhelp,rc) - ind(possrv2)=nhelp -c -c* def dimp,dimqr -c - call ireorg2 (symp,typp,dimp,rc) -c - call ireorg2 (symq,typq,nhelp,rc) - call ireorg2 (symr,typr,mhelp,rc) -c - if ((typv3.eq.2).and.(symq.eq.symr)) then - dimqr=(nhelp*(nhelp-1))/2 - else - dimqr=nhelp*mhelp - end if -c -c* use mreorg1 -c - call mreorg1 (symp,symq,symr,typp,typq,typr, - & posspv2,possqv2,possrv2,typpv2,typqv2,typrv2, - & typv3,wrk(possv20),wrk(possv30),fact,dimp,dimqr, - & ind(1),ind(2),ind(3)) -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/mreorg.F90 openmolcas-22.10/src/ccsort_util/mreorg.F90 --- openmolcas-22.02/src/ccsort_util/mreorg.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/mreorg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,65 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine mreorg(wrk,wrksize,symp,symq,symr,typp,typq,typr,pospv2,posqv2,posrv2,typpv2,typqv2,typrv2,typv3,posv20,posv30,fact) +! this routine is up level routine for mreorg1 (also more detailed +! description can be found there). +! #2 must be of type 0, #3 can be 0, and 2 +! this routine only prepares some constants, required by ireorg1, +! that can be deduced form input data - dimp,dimqr,dimt-dimv +! +! symp-r - symmetries of p-r (I) +! typp-r - types of indices p-r in V2 (I) +! posp-rv2 - positions of p-r ind. in V2 (I) +! typp-rv2 - types of indices, corresponding to p-r in V2 (I) +! typv3 - type of V3 (0,2) (I) +! posv20,30 - initial positions of V2 and V3 in wrk (I) +! fact - multiplication factors (usually +-1.0) (I) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: wrksize, symp, symq, symr, typp, typq, typr, pospv2, posqv2, posrv2, typpv2, typqv2, typrv2, & + typv3, posv20, posv30 +real(kind=wp), intent(inout) :: wrk(wrksize) +real(kind=wp), intent(in) :: fact +integer(kind=iwp) :: dimp, dimqr, ind(4), mhelp, nhelp, rc + +! define dimensions of V2 + +call ireorg2(symp,typpv2,nhelp,rc) +ind(pospv2) = nhelp +call ireorg2(symq,typqv2,nhelp,rc) +ind(posqv2) = nhelp +call ireorg2(symr,typrv2,nhelp,rc) +ind(posrv2) = nhelp + +! def dimp,dimqr + +call ireorg2(symp,typp,dimp,rc) + +call ireorg2(symq,typq,nhelp,rc) +call ireorg2(symr,typr,mhelp,rc) + +if ((typv3 == 2) .and. (symq == symr)) then + dimqr = (nhelp*(nhelp-1))/2 +else + dimqr = nhelp*mhelp +end if + +! use mreorg1 + +call mreorg1(symp,symq,symr,typp,typq,typr,pospv2,posqv2,posrv2,typpv2,typqv2,typrv2,typv3,wrk(posv20),wrk(posv30),fact,dimp, & + dimqr,ind(1),ind(2),ind(3)) + +return + +end subroutine mreorg diff -Nru openmolcas-22.02/src/ccsort_util/prinppn.f openmolcas-22.10/src/ccsort_util/prinppn.f --- openmolcas-22.02/src/ccsort_util/prinppn.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/prinppn.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,226 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1994, Markus P. Fuelscher * -* 1994, Per Ake Malmqvist * -* Pavel Neogrady * -************************************************************************ - Subroutine PrInpPN -************************************************************************ -* * -* purpose: * -* - echo the input parameters * -* * -* calling parameters: none * -* * -*----------------------------------------------------------------------* -* * -* written by: * -* M.P. Fuelscher and P.-AA. Malmqvist * -* University of Lund, Sweden, 1994 * -* * -*----------------------------------------------------------------------* -* * -* history: none * -* Modified by P.N. * -* * -************************************************************************ - Implicit Real*8 (A-H,O-Z) - -#include "ccsort.fh" -#include "reorg.fh" - -CLD Character*8 Fmt1,Fmt2 -CLD Character*120 Line,BlLine,StLine -*----------------------------------------------------------------------* -* Start and define the paper width * -*----------------------------------------------------------------------* -* lPaper=132 -*----------------------------------------------------------------------* -* Initialize blank and header lines * -*----------------------------------------------------------------------* -* lLine=Len(Line) -* Do i=1,lLine -* BlLine(i:i)=' ' -* StLine(i:i)='*' -* End Do -* lPaper=132 -* left=(lPaper-lLine)/2 -* Write(Fmt1,'(A,I3.3,A)') '(',left,'X,A)' -* Write(Fmt2,'(A,I3.3,A)') '(',left,'X,' -*----------------------------------------------------------------------* -* Print the project title * -*----------------------------------------------------------------------* -* If ( nTit.gt.0 ) then -* Write(*,*) -* nLine=nTit+5 -* Do i=1,nLine -* Line=BlLine -* If ( i.eq.1 .or. i.eq.nLine ) -* & Line=StLine -* If ( i.eq.3 ) -* & Line='Project:' -* If ( i.ge.4 .and. i.le.nLine-2 ) -* & Write(Line,'(18A4)')(Title(i-3,j),j=1,18) -* Call Center_Text(Line) -* Write(*,Fmt1) '*'//Line//'*' -* End Do -* Write(*,*) -* End If -* ---------------------------------------------------------------------* -* Stop if NOOPeration key is used * -*----------------------------------------------------------------------* - If (noop.eq.1) then - write(6,'(6X,A)') ' No operation is required' - write(6,'(6X,A)') ' Happy Landing ' - Call Finish(0) - end if -*----------------------------------------------------------------------* -* Print iokey * -*----------------------------------------------------------------------* - if (iokey.eq.1) then - write(6,'(6X,A)') 'Standard Fortran IO handling used ' - end if -c - if (iokey.eq.2) then - write(6,'(6X,A)') - & 'MOLCAS DA IO handling used ' - end if -*----------------------------------------------------------------------* -* Print zrkey * -*----------------------------------------------------------------------* - if (fullprint.eq.2) then - if (zrkey.eq.1) then - write(6,'(6X,A)') 'Separate V and Ind IO' - end if -c - if (zrkey.eq.0) then - write(6,'(6X,A)') 'Simultanneous V and Ind IO' - end if - end if -*----------------------------------------------------------------------* -* Print cckey and t3key * -*----------------------------------------------------------------------* - if (cckey.eq.1) then - write(6,'(6X,A)') 'Integrals for CCSD will be produced' - end if -c - if (t3key.eq.1) then - write(6,'(6X,A)') - & 'Integrals for Noniterative T3 will be produced' - end if -c - if (clopkey.eq.1) then - write(6,'(6X,A)') 'ROHF open shell reference function' - else - write(6,'(6X,A)') 'RHF closed shell reference function' - end if -*----------------------------------------------------------------------* -* Print allocation and printing parameters * -*----------------------------------------------------------------------* -c if (maxspace.eq.0) then -c write(6,'(6X,A)') ' Allocatable work space : Unlimited' -c else -c write(6,'(6X,A,I10)') ' Allocatable work space : ',maxspace -c end if -c if (fullprint.eq.0) then -c write(6,'(6X,A)') ' Level of output printing : Minimal' -c else if (fullprint.eq.1) then -c write(6,'(6X,A)') ' Level of output printing : Medium ' -c else if (fullprint.eq.2) then -c write(6,'(6X,A)') ' Level of output printing : Full' -c end if -*----------------------------------------------------------------------* -* Print actual frozen and deleted orbitals * -*----------------------------------------------------------------------* - Write(6,*) - Write(6,'(6X,A)')'Actual numbers of frozen and '// - & 'deleted orbitals :' - Write(6,'(6X,A)')'-----------------------------'// - & '------------------' - Write(6,*) - Write(6,'(6X,A,T47,8I4)') 'Symmetry species', - & (iSym,iSym=1,nSym) - Write(6,'(6X,A,T47,8I4)') 'Frozen orbitals', - & (nFror(iSym),iSym=1,nSym) - Write(6,'(6X,A,T47,8I4)') 'Deleted orbitals', - & (nDelr(iSym),iSym=1,nSym) - Write(6,*) -c -*----------------------------------------------------------------------* -* Print orbital and wavefunction specifications * -*----------------------------------------------------------------------* - Write(6,*) - Write(6,'(6X,A)')'Wave function specifications '// - & 'from previous RASSCF:' - Write(6,'(6X,A)')'-----------------------------'// - & '---------------------' - Write(6,*) - Write(6,'(6X,A,T45,I6)')'Number of closed shell electrons', - & 2*NISHT - Write(6,'(6X,A,T45,I6)')'Number of electrons in active shells', - & NACTEL - Write(6,'(6X,A,T45,I6)')'Max number of holes in RAS1 space', - & NHOLE1 - Write(6,'(6X,A,T45,I6)')'Max number of electrons in RAS3 '// - & 'space',NELE3 - Write(6,'(6X,A,T45,I6)')'Number of inactive orbitals', - & NISHT - Write(6,'(6X,A,T45,I6)')'Number of active orbitals', - & NASHT - Write(6,'(6X,A,T45,I6)')'Number of secondary orbitals', - & NSSHT - Write(6,'(6X,A,T45,F6.1)')'Spin quantum number', - & (dble(ISPIN-1))/2. - Write(6,'(6X,A,T45,I6)')'State symmetry', - & LSYM - Write(6,'(6X,A,T45,I6)')'Number of configuration state fnc.', - & NCONF - Write(6,'(6X,A,T45,I6)')'Number of root(s) available', - & NROOTS - Write(6,'(6X,A,T45,5I6)')'CI root used', - & LROOT - If ( ISCF.eq.0 ) then - Write(6,'(6X,A)') - & 'This is a CASSCF reference function' - Else If ( ISCF.eq.1 ) then - Write(6,'(6X,A)') - & 'This is a closed shell RHF reference function' - Else - Write(6,'(6X,A)') - & 'This is a high spin open shell RHF reference function' - End If - Write(6,*) - Write(6,*) - Write(6,'(6X,A)')'Orbital specifications from '// - & 'previous RASSCF:' - Write(6,'(6X,A)')'----------------------------'// - & '----------------' - Write(6,*) - Write(6,'(6X,A,T47,8I4)') 'Symmetry species', - & (iSym,iSym=1,nSym) - Write(6,'(6X,A,T47,8I4)') 'Frozen orbitals', - & (nFro(iSym),iSym=1,nSym) - Write(6,'(6X,A,T47,8I4)') 'Inactive orbitals', - & (nIsh(iSym),iSym=1,nSym) - Write(6,'(6X,A,T47,8I4)') 'Active orbitals', - & (nAsh(iSym),iSym=1,nSym) - Write(6,'(6X,A,T47,8I4)') 'Secondary orbitals', - & (nSsh(iSym),iSym=1,nSym) - Write(6,'(6X,A,T47,8I4)') 'Deleted orbitals', - & (nDel(iSym),iSym=1,nSym) - Write(6,'(6X,A,T47,8I4)') 'Number of basis functions', - & (nBas(iSym),iSym=1,nSym) - Write(6,*) -*----------------------------------------------------------------------* -* Exit * -*----------------------------------------------------------------------* - Return - End diff -Nru openmolcas-22.02/src/ccsort_util/prinppn.F90 openmolcas-22.10/src/ccsort_util/prinppn.F90 --- openmolcas-22.02/src/ccsort_util/prinppn.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/prinppn.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,184 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1994, Markus P. Fuelscher * +! 1994, Per Ake Malmqvist * +! Pavel Neogrady * +!*********************************************************************** + +subroutine PrInpPN() +!*********************************************************************** +! * +! purpose: * +! - echo the input parameters * +! * +! calling parameters: none * +! * +!----------------------------------------------------------------------* +! * +! written by: * +! M.P. Fuelscher and P.-AA. Malmqvist * +! University of Lund, Sweden, 1994 * +! * +!----------------------------------------------------------------------* +! * +! history: none * +! Modified by P.N. * +! * +!*********************************************************************** + +use ccsort_global, only: cckey, clopkey, fullprint, iokey, ISCF, ISPIN, LROOT, LSYM, NACTEL, NASH, NASHT, NBAS, NCONF, NDEL, & + ndelr, NELE3, NFRO, nfror, NHOLE1, NISH, NISHT, noop, NROOTS, NSSH, NSSHT, NSYM, t3key, zrkey +use Constants, only: Half +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp) :: iSym +!LD character(len=120) :: BlLine, Line, StLine +!LD character(len=8) :: Fmt1, Fmt2 + +!----------------------------------------------------------------------* +! Start and define the paper width * +!----------------------------------------------------------------------* +!lPaper = 132 +!----------------------------------------------------------------------* +! Initialize blank and header lines * +!----------------------------------------------------------------------* +!lLine = Len(Line) +!do i=1,lLine +! BlLine(i:i) = ' ' +! StLine(i:i) = '*' +!end do +!lPaper = 132 +!left = (lPaper-lLine)/2 +!write(Fmt1,'(A,I3.3,A)') '(',left,'X,A)' +!write(Fmt2,'(A,I3.3,A)') '(',left,'X,' +!----------------------------------------------------------------------* +! Print the project title * +!----------------------------------------------------------------------* +!if (nTit > 0) then +! write(u6,*) +! nLine = nTit+5 +! do i=1,nLine +! Line = BlLine +! If ((i == 1) .or. (i == nLine)) Line = StLine +! If (i == 3) Line = 'Project:' +! If ((i >= 4) .and. (i <= nLine-2)) write(Line,'(18A4)') (Title(i-3,j),j=1,18) +! call Center_Text(Line) +! write(u6,Fmt1) '*'//Line//'*' +! end do +! write(u6,*) +!end if +!----------------------------------------------------------------------* +! Stop if NOOPeration key is used * +!----------------------------------------------------------------------* +if (noop == 1) then + write(u6,'(6X,A)') ' No operation is required' + write(u6,'(6X,A)') ' Happy Landing ' + call Finish(0) +end if +!----------------------------------------------------------------------* +! Print iokey * +!----------------------------------------------------------------------* +if (iokey == 1) write(u6,'(6X,A)') 'Standard Fortran IO handling used ' + +if (iokey == 2) write(u6,'(6X,A)') 'MOLCAS DA IO handling used ' +!----------------------------------------------------------------------* +! Print zrkey * +!----------------------------------------------------------------------* +if (fullprint == 2) then + if (zrkey == 1) write(u6,'(6X,A)') 'Separate V and Ind IO' + + if (zrkey == 0) write(u6,'(6X,A)') 'Simultanneous V and Ind IO' +end if +!----------------------------------------------------------------------* +! Print cckey and t3key * +!----------------------------------------------------------------------* +if (cckey == 1) write(u6,'(6X,A)') 'Integrals for CCSD will be produced' + +if (t3key == 1) write(u6,'(6X,A)') 'Integrals for Noniterative T3 will be produced' + +if (clopkey == 1) then + write(u6,'(6X,A)') 'ROHF open shell reference function' +else + write(u6,'(6X,A)') 'RHF closed shell reference function' +end if +!----------------------------------------------------------------------* +! Print allocation and printing parameters * +!----------------------------------------------------------------------* +!if (maxspace == 0) then +! write(u6,'(6X,A)') ' Allocatable work space : Unlimited' +!else +! write(u6,'(6X,A,I10)') ' Allocatable work space : ',maxspace +!end if +!if (fullprint == 0) then +! write(u6,'(6X,A)') ' Level of output printing : Minimal' +!else if (fullprint == 1) then +! write(u6,'(6X,A)') ' Level of output printing : Medium ' +!else if (fullprint == 2) then +! write(u6,'(6X,A)') ' Level of output printing : Full' +!end if +!----------------------------------------------------------------------* +! Print actual frozen and deleted orbitals * +!----------------------------------------------------------------------* +write(u6,*) +write(u6,'(6X,A)') 'Actual numbers of frozen and deleted orbitals :' +write(u6,'(6X,A)') '-----------------------------------------------' +write(u6,*) +write(u6,'(6X,A,T47,8I4)') 'Symmetry species',(iSym,iSym=1,nSym) +write(u6,'(6X,A,T47,8I4)') 'Frozen orbitals',(nFror(iSym),iSym=1,nSym) +write(u6,'(6X,A,T47,8I4)') 'Deleted orbitals',(nDelr(iSym),iSym=1,nSym) +write(u6,*) +!----------------------------------------------------------------------* +! Print orbital and wavefunction specifications * +!----------------------------------------------------------------------* +write(u6,*) +write(u6,'(6X,A)') 'Wave function specifications from previous RASSCF:' +write(u6,'(6X,A)') '--------------------------------------------------' +write(u6,*) +write(u6,'(6X,A,T45,I6)') 'Number of closed shell electrons',2*NISHT +write(u6,'(6X,A,T45,I6)') 'Number of electrons in active shells',NACTEL +write(u6,'(6X,A,T45,I6)') 'Max number of holes in RAS1 space',NHOLE1 +write(u6,'(6X,A,T45,I6)') 'Max number of electrons in RAS3 space',NELE3 +write(u6,'(6X,A,T45,I6)') 'Number of inactive orbitals',NISHT +write(u6,'(6X,A,T45,I6)') 'Number of active orbitals',NASHT +write(u6,'(6X,A,T45,I6)') 'Number of secondary orbitals',NSSHT +write(u6,'(6X,A,T45,F6.1)') 'Spin quantum number',Half*real(ISPIN-1,kind=wp) +write(u6,'(6X,A,T45,I6)') 'State symmetry',LSYM +write(u6,'(6X,A,T45,I6)') 'Number of configuration state fnc.',NCONF +write(u6,'(6X,A,T45,I6)') 'Number of root(s) available',NROOTS +write(u6,'(6X,A,T45,5I6)') 'CI root used',LROOT +if (ISCF == 0) then + write(u6,'(6X,A)') 'This is a CASSCF reference function' +else if (ISCF == 1) then + write(u6,'(6X,A)') 'This is a closed shell RHF reference function' +else + write(u6,'(6X,A)') 'This is a high spin open shell RHF reference function' +end if +write(u6,*) +write(u6,*) +write(u6,'(6X,A)') 'Orbital specifications from previous RASSCF:' +write(u6,'(6X,A)') '--------------------------------------------' +write(u6,*) +write(u6,'(6X,A,T47,8I4)') 'Symmetry species',(iSym,iSym=1,nSym) +write(u6,'(6X,A,T47,8I4)') 'Frozen orbitals',(nFro(iSym),iSym=1,nSym) +write(u6,'(6X,A,T47,8I4)') 'Inactive orbitals',(nIsh(iSym),iSym=1,nSym) +write(u6,'(6X,A,T47,8I4)') 'Active orbitals',(nAsh(iSym),iSym=1,nSym) +write(u6,'(6X,A,T47,8I4)') 'Secondary orbitals',(nSsh(iSym),iSym=1,nSym) +write(u6,'(6X,A,T47,8I4)') 'Deleted orbitals',(nDel(iSym),iSym=1,nSym) +write(u6,'(6X,A,T47,8I4)') 'Number of basis functions',(nBas(iSym),iSym=1,nSym) +write(u6,*) + +!----------------------------------------------------------------------* +! Exit * +!----------------------------------------------------------------------* +return + +end subroutine PrInpPN diff -Nru openmolcas-22.02/src/ccsort_util/rdinppn.f openmolcas-22.10/src/ccsort_util/rdinppn.f --- openmolcas-22.02/src/ccsort_util/rdinppn.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/rdinppn.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,346 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1993, Markus P. Fuelscher * -* 1993, Per Ake Malmqvist * -* Pavel Neogrady * -************************************************************************ - Subroutine RdInpPN(run_triples,run_sort) -************************************************************************ -* * -* purpose: * -* - read input * -* - set defaults * -* * -* calling parameters: none * -* * -*----------------------------------------------------------------------* -* * -* written by: * -* M.P. Fuelscher and P.-AA. Malmqvist * -* University of Lund, Sweden, 1993 * -* * -*----------------------------------------------------------------------* -* * -* history: none * -* reduced by P.N. * -* * -************************************************************************ - Implicit Real*8 (A-H,O-Z) - - -#include "SysDef.fh" -#include "ccsort.fh" -#include "reorg.fh" -#include "motra.fh" -* - Real*8 Weights(mxRoot) - Parameter ( nCmd =20 ) - Character*4 Command,Cmd(nCmd) - Character*72 Line,Blank - Data Cmd /'TITL','END ','CCSD','CCT ','CLOS', - & 'OPEN','FROZ','DELE','PRIN','NOOP','IOKE','ZROF', - & 'DENO','SHIF','ACCU','ADAP','EXTR','TRIP','NOSO', - & 'ITER'/ - Logical run_triples,run_sort - -* -*--- Initialize -------------------------------------------------------* - Do i=1,72 - Blank(i:i)=' ' - End Do - LROOT=0 - MAXIT=0 - CONV=1.0D-06 - THRSHN=1.0D-10 - THRSHS=1.0D-08 - THRSHF=0.05D0 - ORBIN='DEFAULT ' - THRENE=1.50D0 - ORBIT='DEFAULT ' - THROCC=0.0D0 - FOCKTYPE='STANDARD' - HZERO='STANDARD' - METHOD='CONJ' - IFJAC=0 - RFpert=.false. - NTIT=0 -c - lunsta=21 - luna1=22 - luna2=23 - luna3=24 - luna4=25 - lunab=50 - lunt3=26 - lunda1=9 - lunda2=10 - lunpublic=29 -c -*--- Open JOBIPH and LUONEM files ------------------------------------* -* -*. Job interface - JOBIPH=15 -*. Job interface - CALL DANAME(JOBIPH,'JOBIPH') -* -*--- Read input from JOBIPH file -------------------------------------* - IAD15=0 - CALL iDAFILE(JOBIPH,2,IADR15,15,IAD15) -cDIVNUO - IAD15=IADR15(1) - CALL WR_RASSCF_Info(JOBIPH,2,iAd15, - & NACTEL,ISPIN,NSYM,LSYM, - & NFRO,NISH,NASH,NDEL,NBAS,8, - & NAME,LENIN8*MXORB, - & NCONF,HEADER,2*72, - & TITLE,4*18*MXTIT,POTNUC, - & LROOTS,NROOTS,IROOT,MXROOT,NRAS1, - & NRAS2,NRAS3,NHOLE1,NELE3,IPT2,Weights) -c -c define defaults for REORG -c - ntAsh = 0 - do isym = 1,nSym - ntAsh = ntAsh+nAsh(iSym) - end do - cckey=1 - t3key=1 - clopkey=1 - if ( ntAsh.eq.0 ) clopkey=2 - do nhelp=1,nsym - ndelr(nhelp)=NDEL(nhelp) - nfror(nhelp)=NFRO(nhelp) - end do -CGG fullprint=0 - noop=0 - iokey=1 - zrkey=1 - run_triples=.true. - run_sort=.true. -* -*--- Read input from TRAONE file -------------------------------------* - Call RdTraOne - Do iSym=1,nSym - nFror(iSym) = nFroX(iSym) - nDelr(iSym) = nDelX(iSym) - End Do -* -*--- Read input from LuSpool -----------------------------------------* - LuSpool = 17 - Call SpoolInp(LuSpool) - Rewind(LuSpool) - Command='&REO' - Call RdNlst(LuSpool,'CCSDT') - 10 Read(LuSpool,'(A)',End=9910) Line - If ( Line(1:1).eq.'*' ) Goto 10 - If ( Line.eq.Blank ) Goto 10 - Command=Line(1:4) - Call UpCase(Command) - jCmd=0 - Do iCmd=1,nCmd - If ( Command.eq.Cmd(iCmd) ) jCmd=iCmd - End Do - If ( jCmd.eq.0 ) Goto 9930 - 20 Goto (100,2100,200,300,400,500,600,700,900,1000,1100,1200, - & 1300,1400,1500,1600,1700,1800,1900,2000) jCmd -* -*--- process TITLE command ----------------------------------------* - 100 continue - Read(LuSpool,'(A)',End=9910) Line - Command=Line(1:4) - Call UpCase(Command) - If ( Command(1:1).eq.'*' ) Goto 100 - jCmd=0 - Do iCmd=1,nCmd - If ( Command.eq.Cmd(iCmd) ) jCmd=iCmd - End Do - If ( jCmd.ne.0 ) Goto 20 - if (nTit.ge.mxTit) Goto 100 - nTit=nTit+1 - If ( nTit.le.mxTit ) Read (Line,'(18A4)') (Title(nTit,i),i=1,18) - Goto 100 -c--- CCSD command ------------ - 200 continue - cckey=1 - t3key=0 - run_triples=.false. - goto 100 -c--- CCT command ------------ - 300 continue - cckey=1 - t3key=1 - run_triples=.true. - goto 100 -c--- CLOSed command ------------ - 400 continue - clopkey=2 - goto 100 -c--- OPEN command ------------ - 500 continue - clopkey=1 - goto 100 -c--- FROZen command ------------ - 600 continue - read (LuSpool,*) (nfror(nhelp),nhelp=1,nsym) - goto 100 -c--- DELEte command ------------ - 700 continue - read (LuSpool,*) (ndelr(nhelp),nhelp=1,nsym) - goto 100 -* -c--- PRINt command ------------ - 900 continue - read (LuSpool,*) fullprint - goto 100 -* -c--- NOOPeration command ------------ - 1000 continue - noop=1 - goto 100 -* -c--- IOKEy command ------------ - 1100 continue - read (LuSpool,*) iokey - if ((iokey.lt.1).or.(iokey.gt.2)) then - iokey=2 - end if - goto 100 -* -c--- ZROFf command ------------ - 1200 continue - zrkey=0 - goto 100 - -c--- DENO command --------- -1300 continue - goto 100 -* -c--- SHIF command --------- -1400 continue - goto 100 -c--- ACCU command --------- -1500 continue - goto 100 -c--- ADAP command --------- -1600 continue - goto 100 -c--- EXTR command --------- -1700 continue - goto 100 -c--- TRIP command --------- -1800 continue - goto 100 -c--- NOSOrt command ------------ -1900 continue - run_sort=.false. - goto 100 -c--- ITER command --------- -2000 continue - goto 100 -* -* -*--- The end of the input section, complete input processing ---------* - 2100 continue - NFROT=0 - NISHT=0 - NASHT=0 - NRAS1T=0 - NRAS2T=0 - NRAS3T=0 - NOSHT=0 - NSSHT=0 - NDELT=0 - NORBT=0 - NBAST=0 - NBAS2=0 - NORB1=0 - DO ISYM=1,NSYM - NIES(ISYM)=NISHT - NAES(ISYM)=NASHT - NSES(ISYM)=NSSHT - NOSH(ISYM)=NISH(ISYM)+NASH(ISYM) - NSSH(ISYM)=NBAS(ISYM)-NFRO(ISYM)-NOSH(ISYM)-NDEL(ISYM) - NORB(ISYM)=NOSH(ISYM)+NSSH(ISYM) - NORBT=NORBT+NORB(ISYM) - NBAS2=NBAS2+NBAS(ISYM)**2 - NORB1=NORB1+(NORB(ISYM)**2+NORB(ISYM))/2 - NFROT=NFROT+NFRO(ISYM) - NISHT=NISHT+NISH(ISYM) - NASHT=NASHT+NASH(ISYM) - NOSHT=NOSHT+NOSH(ISYM) - NRAS1T=NRAS1T+NRAS1(ISYM) - NRAS2T=NRAS2T+NRAS2(ISYM) - NRAS3T=NRAS3T+NRAS3(ISYM) - NSSHT=NSSHT+NSSH(ISYM) - NDELT=NDELT+NDEL(ISYM) - NBAST=NBAST+NBAS(ISYM) - END DO -* -*--- Identify the wave function type ---------------------------------* - ISCF=0 - IF(NASHT.EQ.0) ISCF=1 - IF(NACTEL.EQ.2*NASHT) ISCF=1 - if ( iSpin.gt.1 ) then - IF((ISPIN.EQ.NACTEL+1).AND.(NACTEL.EQ.NASHT)) ISCF=2 - end if -c -c test agreement between REORG input and JOBIPH -c if (clopkey.ne.(3-ISCF)) then -c write(6,*) ' Diference in closed/open specification' -c write(6,*) ' Plaese, correct REORG input file' -c write(6,*) clopkey,ISCF -c Call Quit(16) -c end if -* -c Should not be necessary anymore, let's just hardwire it in. -c This will save a keyword - clopkey = 3-ISCF -*--- Identify the reference function ---------------------------------* - IF(ISCF.GT.0) THEN - LROOT=1 - NROOTS=1 - IROOT(1)=1 - END IF - IF(LROOT.EQ.0 .AND. NROOTS.EQ.1) LROOT=IROOT(1) -* -*--- Create the symmetry multiplication table ------------------------* - MUL(1,1)=1 - M=1 - DO N=1,3 - DO I=1,M - DO J=1,M - MUL(I+M,J)=M+MUL(I,J) - MUL(I,J+M)=MUL(I+M,J) - MUL(I+M,J+M)=MUL(I,J) - END DO - END DO - M=2*M - END DO - Call Close_LuSpool(LuSpool) - -* -* -*--- Exit ------------------------------------------------------------* - Return -* -*--- Error exits -----------------------------------------------------* - 9910 Write(6,*) - Write(6,*) ' *** input error ***' - Write(6,*) ' hitting end of file mark' - Write(6,*) - Call Quit_OnUserError() - 9930 Write(6,*) - Write(6,*) ' *** input error ***' - Write(6,*) ' unknown input' - Write(6,*) ' line: ',Line - Write(6,*) - Call Quit_OnUserError() - End diff -Nru openmolcas-22.02/src/ccsort_util/rdinppn.F90 openmolcas-22.10/src/ccsort_util/rdinppn.F90 --- openmolcas-22.02/src/ccsort_util/rdinppn.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/rdinppn.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,279 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993, Markus P. Fuelscher * +! 1993, Per Ake Malmqvist * +! Pavel Neogrady * +!*********************************************************************** + +subroutine RdInpPN(run_triples,run_sort) +!*********************************************************************** +! * +! purpose: * +! - read input * +! - set defaults * +! * +! calling parameters: none * +! * +!----------------------------------------------------------------------* +! * +! written by: * +! M.P. Fuelscher and P.-AA. Malmqvist * +! University of Lund, Sweden, 1993 * +! * +!----------------------------------------------------------------------* +! * +! history: none * +! reduced by P.N. * +! * +!*********************************************************************** + +use ccsort_global, only: cckey, clopkey, fullprint, IADR15, iokey, IPT2, ISCF, ISPIN, JOBIPH, LROOT, LSYM, luna1, luna2, luna3, & + luna4, lunab, lunda1, lunda2, lunpublic, lunt3, NACTEL, NASH, NASHT, NBAS, NCONF, NDEL, ndelr, nDelX, & + NELE3, NFRO, nfror, nFroX, NHOLE1, NISH, NISHT, noop, NORB, NROOTS, NSSH, NSSHT, NSYM, t3key, zrkey +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp, u6 + +implicit none +logical(kind=iwp), intent(out) :: run_triples, run_sort +#include "rasdim.fh" +integer(kind=iwp) :: IAD15, iCmd, IROOT(mxRoot), istatus, isym, jCmd, LROOTS, LuSpool, nhelp, NOSH, NRAS1(8), NRAS2(8), NRAS3(8), & + ntAsh, nTit +real(kind=wp) :: POTNUC +character(len=72) :: Header(2), Line, Title(mxTit) +character(len=4) :: Command +real(kind=wp), allocatable :: Weights(:) +character(len=LenIn8), allocatable :: CName(:) +character(len=4), parameter :: Cmd(20) = ['TITL','END ','CCSD','CCT ','CLOS','OPEN','FROZ','DELE','PRIN','NOOP','IOKE','ZROF', & + 'DENO','SHIF','ACCU','ADAP','EXTR','TRIP','NOSO','ITER'] + +!--- Initialize -------------------------------------------------------* +LROOT = 0 +nTit = 0 + +luna1 = 22 +luna2 = 23 +luna3 = 24 +luna4 = 25 +lunab = 50 +lunt3 = 26 +lunda1 = 9 +lunda2 = 10 +lunpublic = 29 + +!--- Open JOBIPH file ------------------------------------------------* + +! Job interface +JOBIPH = 15 +! Job interface +call DANAME(JOBIPH,'JOBIPH') + +!--- Read input from JOBIPH file -------------------------------------* +IAD15 = 0 +call iDAFILE(JOBIPH,2,IADR15,15,IAD15) +!DIVNUO +IAD15 = IADR15(1) +call mma_allocate(CName,mxOrb,label='CName') +call mma_allocate(Weights,mxRoot,label='Weights') +call WR_RASSCF_Info(JOBIPH,2,iAd15,NACTEL,ISPIN,NSYM,LSYM,NFRO,NISH,NASH,NDEL,NBAS,8,CName,LenIn8*MxOrb,NCONF,Header,2*72,Title, & + 72*mxTit,POTNUC,LROOTS,NROOTS,IROOT,mxRoot,NRAS1,NRAS2,NRAS3,NHOLE1,NELE3,IPT2,Weights) +call mma_deallocate(CName) +call mma_deallocate(Weights) + +! define defaults for REORG + +ntAsh = 0 +do isym=1,nSym + ntAsh = ntAsh+nAsh(iSym) +end do +cckey = 1 +t3key = 1 +clopkey = 1 +if (ntAsh == 0) clopkey = 2 +ndelr(1:nsym) = NDEL(1:nsym) +nfror(1:nsym) = NFRO(1:nsym) +!GG fullprint = 0 +noop = 0 +iokey = 1 +zrkey = 1 +run_triples = .true. +run_sort = .true. + +!--- Read input from TRAONE file -------------------------------------* +call RdTraOne() +nFror(1:nSym) = nFroX(1:nSym) +nDelr(1:nSym) = nDelX(1:nSym) + +!--- Read input from LuSpool -----------------------------------------* +LuSpool = 17 +call SpoolInp(LuSpool) +rewind(LuSpool) +Command = '&REO' +call RdNlst(LuSpool,'CCSDT') +do + read(LuSpool,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if ((Line(1:1) /= '*') .and. (Line /= '')) exit +end do +Command = Line(1:4) +call UpCase(Command) +jCmd = 0 +do iCmd=1,size(Cmd) + if (Command == Cmd(iCmd)) jCmd = iCmd +end do +if (jCmd == 0) call Error(2) +do + select case (jCmd) + case default !(1) !TITL + !--- process TITLE command -------------------------------------* + do + read(LuSpool,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + Command = Line(1:4) + call UpCase(Command) + if (Command(1:1) == '*') cycle + jCmd = 0 + do iCmd=1,size(Cmd) + if (Command == Cmd(iCmd)) jCmd = iCmd + end do + if (jCmd /= 0) exit + if (nTit >= mxTit) cycle + nTit = nTit+1 + if (nTit <= mxTit) read(Line,'(A72)') Title(nTit) + end do + case (2) !END + exit + case (3) !CCSD + !--- CCSD command ---------------------------------------------* + cckey = 1 + t3key = 0 + run_triples = .false. + jCmd = 1 + case (4) !CCT + !--- CCT command ----------------------------------------------* + cckey = 1 + t3key = 1 + run_triples = .true. + jCmd = 1 + case (5) !CLOS + !--- CLOSed command -------------------------------------------* + clopkey = 2 + jCmd = 1 + case (6) !OPEN + !--- OPEN command ---------------------------------------------* + clopkey = 1 + jCmd = 1 + case (7) !FROZ + !--- FROZen command -------------------------------------------* + read(LuSpool,*) (nfror(nhelp),nhelp=1,nsym) + jCmd = 1 + case (8) !DELE + !--- DELEte command -------------------------------------------* + read(LuSpool,*) (ndelr(nhelp),nhelp=1,nsym) + jCmd = 1 + case (9) !PRIN + !--- PRINt command --------------------------------------------* + read(LuSpool,*) fullprint + jCmd = 1 + case (10) !NOOP + !--- NOOPeration command --------------------------------------* + noop = 1 + jCmd = 1 + case (11) !IOKE + !--- IOKEy command --------------------------------------------* + read(LuSpool,*) iokey + if ((iokey < 1) .or. (iokey > 2)) iokey = 2 + jCmd = 1 + case (12) !ZROF + !--- ZROFf command --------------------------------------------* + zrkey = 0 + jCmd = 1 + case (19) !NOSO + !--- NOSOrt command -------------------------------------------* + run_sort = .false. + jCmd = 1 + case (13:18,20) !DENO, SHIF, ACCU, ADAP, EXTR, TRIP, ITER + !--- DENO command ---------------------------------------------* + !--- SHIF command ---------------------------------------------* + !--- ACCU command ---------------------------------------------* + !--- ADAP command ---------------------------------------------* + !--- EXTR command ---------------------------------------------* + !--- TRIP command ---------------------------------------------* + !--- ITER command ---------------------------------------------* + jCmd = 1 + end select +end do + +!--- The end of the input section, complete input processing ---------* +NISHT = 0 +NASHT = 0 +NSSHT = 0 +do ISYM=1,NSYM + NOSH = NISH(ISYM)+NASH(ISYM) + NSSH(ISYM) = NBAS(ISYM)-NFRO(ISYM)-NOSH-NDEL(ISYM) + NORB(ISYM) = NOSH+NSSH(ISYM) + NISHT = NISHT+NISH(ISYM) + NASHT = NASHT+NASH(ISYM) + NSSHT = NSSHT+NSSH(ISYM) +end do + +!--- Identify the wave function type ---------------------------------* +ISCF = 0 +if (NASHT == 0) ISCF = 1 +if (NACTEL == 2*NASHT) ISCF = 1 +if ((iSpin > 1) .and. (ISPIN == NACTEL+1) .and. (NACTEL == NASHT)) ISCF = 2 + +! test agreement between REORG input and JOBIPH +!if (clopkey /= (3-ISCF)) then +! write(u6,*) ' Diference in closed/open specification' +! write(u6,*) ' Plaese, correct REORG input file' +! write(u6,*) clopkey,ISCF +! call Quit(16) +!end if +! +! Should not be necessary anymore, let's just hardwire it in. +! This will save a keyword +clopkey = 3-ISCF +!--- Identify the reference function ---------------------------------* +if (ISCF > 0) then + LROOT = 1 + NROOTS = 1 + IROOT(1) = 1 +end if +if ((LROOT == 0) .and. (NROOTS == 1)) LROOT = IROOT(1) + +call Close_LuSpool(LuSpool) + +!--- Exit ------------------------------------------------------------* +return + +contains + +!--- Error exits -----------------------------------------------------* +subroutine Error(code) + + integer :: code + + write(u6,*) + select case (code) + case (1) + write(u6,*) ' *** input error ***' + write(u6,*) ' hitting end of file mark' + case (2) + write(u6,*) ' *** input error ***' + write(u6,*) ' unknown input' + write(u6,*) ' line: ',Line + end select + write(u6,*) + call Quit_OnUserError() + +end subroutine Error + +end subroutine RdInpPN diff -Nru openmolcas-22.02/src/ccsort_util/rdtraone.f openmolcas-22.10/src/ccsort_util/rdtraone.f --- openmolcas-22.02/src/ccsort_util/rdtraone.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/rdtraone.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine RdTraOne -************************************************************************ -* * -* purpose: * -* read the header of the transformed one-electron integral file * -* * -************************************************************************ - -#include "Molcas.fh" -#include "motra.fh" -#include "SysDef.fh" - - Integer iDisk,LuTraOne - Integer TocTraOne(64) - Character*(LENIN8) BsLbl(MxOrb) - - LuTraOne = 3 - - Call DaName(LuTraOne,'TRAONE') - -culf - iDisk=0 - - Call WR_MOTRA_Info(LuTraOne,2,iDisk, - & TocTraOne,64, - & EcorX, - & nSymX, - & nBasX,nOrbX,nFroX,nDelX,8, - & BsLbl,LENIN8*MxOrb) - - Call Daclos(LuTraOne) - - Return - End diff -Nru openmolcas-22.02/src/ccsort_util/rdtraone.F90 openmolcas-22.10/src/ccsort_util/rdtraone.F90 --- openmolcas-22.02/src/ccsort_util/rdtraone.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/rdtraone.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,45 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine RdTraOne() +!*********************************************************************** +! * +! purpose: * +! read the header of the transformed one-electron integral file * +! * +!*********************************************************************** + +use ccsort_global, only: nBasX, nDelX, nFroX, nSymX +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp + +implicit none +#include "Molcas.fh" +integer(kind=iwp) :: iDisk, LuTraOne, nOrbX(8), TocTraOne(64) +real(kind=wp) :: EcorX +character(len=LenIn8), allocatable :: BsLbl(:) + +LuTraOne = 3 + +call DaName(LuTraOne,'TRAONE') + +!ulf +iDisk = 0 + +call mma_allocate(BsLbl,MxOrb,label='BsLbl') +call WR_MOTRA_Info(LuTraOne,2,iDisk,TocTraOne,64,EcorX,nSymX,nBasX,nOrbX,nFroX,nDelX,8,BsLbl,LenIn8*MxOrb) +call mma_deallocate(BsLbl) + +call Daclos(LuTraOne) + +return + +end subroutine RdTraOne diff -Nru openmolcas-22.02/src/ccsort_util/reorg.f openmolcas-22.10/src/ccsort_util/reorg.f --- openmolcas-22.02/src/ccsort_util/reorg.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/reorg.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,206 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1994, Per Ake Malmqvist * -* 1995,1996, Pavel Neogrady * -************************************************************************ - SUBROUTINE REORG(run_triples,IRETURN) - IMPLICIT REAL*8 (A-H,O-Z) - Logical run_triples -#include "reorg.fh" -#include "stdalloc.fh" - real*8, allocatable :: FIRAS(:),FI(:) - fullprint=0 - If (iPrintLevel(-1).LE.0) fullprint=-1 - call mma_Allocate(FIRAS,mbas*mbas,Label='FIRAS') - call mma_Allocate(FI,mbas*mbas,Label='FI') - call REORG_(FIRAS,FI,run_triples,IRETURN) - call mma_Deallocate(FIRAS) - call mma_Deallocate(FI) - return - end - SUBROUTINE REORG_(FIRAS,FI,run_triples,IRETURN) - -*----------------------------------------------------------------------* -* 1994 PER-AAKE MALMQUIST * -* DEPARTMENT OF THEORETICAL CHEMISTRY * -* UNIVERSITY OF LUND, SWEDEN * -* * -* modified by P.N. (Dec. 1995) * -* all allocation memory routines removed by P.N. (8.03.1996) * -*----------------------------------------------------------------------* - -C -C FILES USED: -C TRAINT 2 electron MO INTEGRALS -C JOBIPH THE JOB-INTERFACE FILE AS PRODUCED BY THE RASSCF -C PROGRAM -C INPUT -C AT PRESENT: THE INPUT FILE IS SEARCHED FOR THE STRING -C '&REORG '. Input is only TITLE -C -C LIMITATIONS -c Like in CASPT2 -C -************************************************************************ - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" -#include "ccsort.fh" -#include "reorg.fh" -#include "intgrl.fh" -#include "WrkSpc.fh" - - real*8 FIRAS(1:mbas*mbas) - real*8 EPSRAS(1:mbas) - real*8 FI(1:mbas*mbas) - real*8 EPS(1:mbas) - real*8 ene(mxRoot,mxIter) -c real*8 Ene(25,50) -c - INTEGER NOIPSB(106) - Logical run_triples,run_sort -c -c -C PRINT THE PROGRAM HEADER - call ccsort_helloPN - -c* READ AND ECHO INPUT DATA, READ JOBIPH, PRINT INPUT DATA, - CALL RDINPPN(run_triples,run_sort) - If (fullprint.GE.0) CALL PRINPPN - CALL CHKINP_CCSORT -c - if (run_sort) then -c -c* read FI from JOBIPH - ntot3=0 - ntot2=0 - do i=1,nsym - ntot3=ntot3+(norb(i)*(norb(i)+1))/2 - ntot2=ntot2+norb(i) - end do -c -c* pick the total energy from the JOBIPH file -c - iad15=iadr15(6) - lad15=mxroot*mxiter - Call dDaFile(JOBIPH,2,Ene,lad15,iad15) - EScf=0.0d0 - i=1 -c -c* take the last non-zero energy stored -c - Do While ((Ene(LROOT,i).ne.0.0D0) .and. (i.le.mxIter)) - Escf = Ene(LROOT,i) - i=i+1 - End Do - If (fullprint.GE.0) then - write(6,*) - write(6,'(6X,A,F16.8)') 'SCF energy:',Escf - write(6,'(6X,A)') '-----------' - write(6,*) - EndIf -c -c* get fi from previous RASSCF -c - iad15=iadr15(10) - call ddafile(JOBIPH,2,firas(1),ntot3,iad15) -c -c* get eps from previous RASSCF -c - iad15=iadr15(11) - call ddafile(JOBIPH,2,epsras(1),ntot2,iad15) -c -c* reduce fi,eps and update n's - call mod1 (nsym,nfro,nish,nash,nssh,ndel,norb,nfror,ndelr, - & firas,fi,epsras,eps) -c -c* def diagonal Fok for closed shell -c - if (clopkey.eq.2) then - call mod2 (nsym,nish,nash,nssh,norb,fi,eps) - end if -c -c* define noa,nob,nva,nvb -c - do i=1,nsym - noa(i)=nish(i)+nash(i) - nob(i)=nish(i) - nva(i)=nssh(i) - nvb(i)=nssh(i)+nash(i) - end do -c - if (nsym.lt.8) then - do i=1+nsym,8 - noa(i)=0 - nob(i)=0 - nva(i)=0 - nvb(i)=0 - end do - end if -c - if (fullprint.gt.1) then - write(6,*) - write(6,'(6X,A)') 'Diagonal Fock matrix elements and '// - & 'orbital energies:' - write(6,'(6X,A)') '----------------------------------'// - & '-----------------' - write(6,*) - write(6,'(6X,A)') '----------------------------------------' - write(6,'(6X,A)') ' i F(i,i) eps(i) ' - write(6,'(6X,A)') '----------------------------------------' - ij=0 - do i=1,norb(1) - do j=1,i - ij=ij+1 - if (i.eq.j) then - write(6,'(6X,I4,2F18.10)') i,fi(ij),eps(i) - end if - end do - end do - write(6,'(6X,A)') '----------------------------------------' - write(6,*) - end if -c -c* prepair adress (stupid) -c -CFUE -CFUE The unit number of the transformed two electron integrals -CFUE must be 40, 50, 60, 70, 80 or 90. Any other number will -CFUE not be compatible with the I/O driver in MOLCAS. -CFUE - LUINTM=40 -cJR call DANAME (LUINTM,'TRAINT') - call DANAME_MF (LUINTM,'TRAINT') - call mkadress (NOIPSB) -c -c* open TRAINT and call action -c - Call GetMem('FOKA','ALLO','REAL',ipFOKA,(mbas**2+mbas)/2) - Call GetMem('FOKB','ALLO','REAL',ipFOKB,(mbas**2+mbas)/2) - - call action (Work(ipFOKA),Work(ipFOKB),fi,eps) - Call GetMem('FOKA','FREE','REAL',ipFOKA,(mbas**2+mbas)/2) - Call GetMem('FOKB','FREE','REAL',ipFOKB,(mbas**2+mbas)/2) -c -c close files -c - call daclos(luintm) - call daclos(jobiph) -c - else -c case, when SORT was skipped - write (6,*) ' SORT part was skipped' - write (6,*) ' Input parameters are from last actual run of SORT' - end if -c - ireturn=0 - return - END diff -Nru openmolcas-22.02/src/ccsort_util/reorg.F90 openmolcas-22.10/src/ccsort_util/reorg.F90 --- openmolcas-22.02/src/ccsort_util/reorg.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/reorg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,191 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1994, Per Ake Malmqvist * +! 1995,1996, Pavel Neogrady * +!*********************************************************************** + +subroutine REORG(run_triples,IRETURN) +!----------------------------------------------------------------------* +! 1994 PER-AAKE MALMQUIST * +! DEPARTMENT OF THEORETICAL CHEMISTRY * +! UNIVERSITY OF LUND, SWEDEN * +! * +! modified by P.N. (Dec. 1995) * +! all allocation memory routines removed by P.N. (8.03.1996) * +!----------------------------------------------------------------------* +! +! FILES USED: +! TRAINT 2 electron MO INTEGRALS +! JOBIPH THE JOB-INTERFACE FILE AS PRODUCED BY THE RASSCF +! PROGRAM +! INPUT +! AT PRESENT: THE INPUT FILE IS SEARCHED FOR THE STRING +! '&REORG '. Input is only TITLE +! +! LIMITATIONS +! Like in CASPT2 +! +!*********************************************************************** + +use ccsort_global, only: clopkey, Escf, fullprint, IADR15, JOBIPH, LROOT, LUINTM, mbas, NASH, NDEL, ndelr, NFRO, nfror, NISH, noa, & + nob, NORB, NSSH, NSYM, nva, nvb +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +logical(kind=iwp), intent(out) :: run_triples +integer(kind=iwp), intent(out) :: IRETURN +#include "rasdim.fh" +integer(kind=iwp) :: i, iad15, ij, j, lad15, NOIPSB(106), ntot2, ntot3 +logical(kind=iwp) :: run_sort +real(kind=wp), allocatable :: Ene(:,:), EPS(:), EPSRAS(:), FI(:), FIRAS(:), FOKA(:), FOKB(:) +integer(kind=iwp), external :: iPrintLevel + +fullprint = 0 +if (iPrintLevel(-1) <= 0) fullprint = -1 +call mma_allocate(FIRAS,mbas*mbas,Label='FIRAS') +call mma_allocate(FI,mbas*mbas,Label='FI') + +! READ AND ECHO INPUT DATA, READ JOBIPH, PRINT INPUT DATA, +call RDINPPN(run_triples,run_sort) +if (fullprint >= 0) call PRINPPN() +call CHKINP_CCSORT() + +if (run_sort) then + + ! read FI from JOBIPH + ntot3 = 0 + ntot2 = 0 + do i=1,nsym + ntot3 = ntot3+(norb(i)*(norb(i)+1))/2 + ntot2 = ntot2+norb(i) + end do + + ! pick the total energy from the JOBIPH file + + call mma_allocate(Ene,mxRoot,mxIter) + + iad15 = iadr15(6) + lad15 = mxroot*mxiter + call dDaFile(JOBIPH,2,Ene,lad15,iad15) + EScf = Zero + i = 1 + + ! take the last non-zero energy stored + + do while ((Ene(LROOT,i) /= Zero) .and. (i <= mxIter)) + Escf = Ene(LROOT,i) + i = i+1 + end do + call mma_deallocate(Ene) + if (fullprint >= 0) then + write(u6,*) + write(u6,'(6X,A,F16.8)') 'SCF energy:',Escf + write(u6,'(6X,A)') '-----------' + write(u6,*) + end if + + ! get fi from previous RASSCF + + iad15 = iadr15(10) + call ddafile(JOBIPH,2,firas(1),ntot3,iad15) + + ! get eps from previous RASSCF + + call mma_allocate(eps,mbas,label='eps') + call mma_allocate(epsras,ntot2,label='epsras') + + iad15 = iadr15(11) + call ddafile(JOBIPH,2,epsras,ntot2,iad15) + + ! reduce fi,eps and update n's + call mod1(nsym,nfro,nish,nssh,ndel,norb,nfror,ndelr,firas,fi,epsras,eps) + + call mma_deallocate(epsras) + + ! def diagonal Fok for closed shell + + if (clopkey == 2) call mod2(nsym,nish,nash,norb,fi,eps) + + ! define noa,nob,nva,nvb + + noa(1:nsym) = nish(1:nsym)+nash(1:nsym) + nob(1:nsym) = nish(1:nsym) + nva(1:nsym) = nssh(1:nsym) + nvb(1:nsym) = nssh(1:nsym)+nash(1:nsym) + + if (nsym < 8) then + noa(nsym+1:8) = 0 + nob(nsym+1:8) = 0 + nva(nsym+1:8) = 0 + nvb(nsym+1:8) = 0 + end if + + if (fullprint > 1) then + write(u6,*) + write(u6,'(6X,A)') 'Diagonal Fock matrix elements and orbital energies:' + write(u6,'(6X,A)') '---------------------------------------------------' + write(u6,*) + write(u6,'(6X,A)') '----------------------------------------' + write(u6,'(6X,A)') ' i F(i,i) eps(i) ' + write(u6,'(6X,A)') '----------------------------------------' + ij = 0 + do i=1,norb(1) + do j=1,i + ij = ij+1 + if (i == j) write(u6,'(6X,I4,2F18.10)') i,fi(ij),eps(i) + end do + end do + write(u6,'(6X,A)') '----------------------------------------' + write(u6,*) + end if + + ! prepare address (stupid) + + !FUE The unit number of the transformed two electron integrals + !FUE must be 40, 50, 60, 70, 80 or 90. Any other number will + !FUE not be compatible with the I/O driver in MOLCAS. + + LUINTM = 40 + !JR call DANAME(LUINTM,'TRAINT') + call DANAME_MF(LUINTM,'TRAINT') + call mkaddress(NOIPSB) + + ! open TRAINT and call action + + call mma_allocate(FOKA,mbas*(mbas+1)/2,label='FOKA') + call mma_allocate(FOKB,mbas*(mbas+1)/2,label='FOKB') + + call action_ccsort(FOKA,FOKB,fi,eps) + call mma_deallocate(FOKA) + call mma_deallocate(FOKB) + call mma_deallocate(eps) + + ! close files + + call daclos(luintm) + call daclos(jobiph) + +else + ! case, when SORT was skipped + write(u6,*) ' SORT part was skipped' + write(u6,*) ' Input parameters are from last actual run of SORT' +end if + +ireturn = 0 + +call mma_deallocate(FIRAS) +call mma_deallocate(FI) + +return + +end subroutine REORG diff -Nru openmolcas-22.02/src/ccsort_util/reorg.fh openmolcas-22.10/src/ccsort_util/reorg.fh --- openmolcas-22.02/src/ccsort_util/reorg.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/reorg.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,192 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -c -c common for REORG -c -c note: GM - arrays moved from statical allocation to dynamical -c via GetMem (PN&LD 2008) -c -c1. parameters for expansion of orbitals -c - integer nsize,mbas - parameter (nsize=8192) - parameter (mbas=1024) -c -c2. add. constant for lun for T3hf and lun for TEMP files - integer addt3,lunpublic - parameter (addt3=50) -c -c3. names of TEMP files and status matrix for TEMP files - character*7 tmpnam(1:mbas) - integer stattemp(1:mbas) - integer lrectemp(1:mbas) - integer nrectemp(1:mbas) - common /tmpnames/ tmpnam,stattemp,lrectemp,nrectemp -c -c4. arrays for expanding of orbitals -c - real*8 valh(1:nsize) -cGM real*8 valn(1:nsize,1:mbas) -************************************************************************ -c -c For jh,kh,lh -c any type of integer >=I2 is allowed, however corresponding -c TEMP- files will be larger, therefore use smallest possible -c integer type -c -if it is possible, use I2 type of jh,kh,lhmjn,kn,ln it can safe -c some disk space -c -I1 type can safe even more space, but corresponding part of -c routine unpackk must be modified, moreover in such case number -c of orbitals in one symmetry is strongly limited to 256 -c - integer jh(1:nsize),kh(1:nsize),lh(1:nsize) -cGM integer jn(1:nsize,1:mbas) -cGM integer kn(1:nsize,1:mbas) -cGM integer ln(1:nsize,1:mbas) - integer nshow(1:mbas) -cStary common /ccsort_expand1/ valh,valn,jh,kh,lh,jn,kn,ln,nshow - common /ccsort_expand1/ valh,jh,kh,lh,nshow -c -c5. arrays for expanding of orbitals -c reflecting permutation -c - integer np(1:8,1:8,1:8) - integer nq(1:8,1:8,1:8) - integer nr(1:8,1:8,1:8) - integer ns(1:8,1:8,1:8) - integer typ(1:8,1:8,1:8) - integer idis(1:8,1:8,1:8) - common /ccsort_expand2/ np,nq,nr,ns,typ,idis -c -c6.1 four mapd,mapi matrices and corresponding initial possitions variables -c for details see docc.txt -c - integer poss10,poss20,poss30,poss40 - integer mapd1(0:512,1:6) - integer mapi1(1:8,1:8,1:8) - integer mapd2(0:512,1:6) - integer mapi2(1:8,1:8,1:8) - integer mapd3(0:512,1:6) - integer mapi3(1:8,1:8,1:8) - integer mapd4(0:512,1:6) - integer mapi4(1:8,1:8,1:8) -c - common /workcom1/ mapd1,mapd2,mapd3,mapd4,poss10,poss20,poss30, - & poss40, - & mapi1,mapi2,mapi3,mapi4 -c -c6.2 mapd and mapi for R_i matrix, required for making T3 integrals -c - integer possri0 - integer mapdri(0:512,1:6) - integer mapiri(1:8,1:8,1:8) -c - common /workcom2/ mapdri,mapiri,possri0 -c -c7 lun for files, where sorted integrals are stored 21-25 -c -c7.1 lun for INTSTA foka,fokb, -c aaaa,bbbb,abab -c aaaa,bbbb,abab,abab -c aaaa,bbbb,abab - integer lunsta -c -c7.2 lun for INTA1 aaaa, baab - integer luna1 -c -c7.3 lun for INTA2 bbbb, abab - integer luna2 -c -c7.4 lun for INTA3 aaaa, baab, baba - integer luna3 -c -c7.5 lun for INTA4 bbbb, abab, abba - integer luna4 -c -c7.6 lun for INTAB _a_b(p,q) - integer lunab -c -c7.7 lunt3 - Lun for t3nam file - integer lunt3 -c -c8 parameters for direct access file -c -c8.1 lun and recl (in R8 words) for direct access TEMPDA1,TEMPDA2 -c - integer lunda1,lunda2 - integer recl - parameter (recl=100) -c -c9.1 abmap - help map for storing of addresses in direct acces file TEMPDA1 -cGM integer abmap(1:mbas,1:mbas,1:8) -c -c9.2 abmam - help map for storing of addresses in direct acces file TEMPDA2 -cGM integer ammap(1:mbas,1:8,1:8) -c -cGM common /da/ abmap,ammap -c -c10 input keys -c -c10.1 cckey - key for doing CCSD integrals - integer cckey -c -c10.2 t3key - key for doing T3 integrals - integer t3key -c -c10.3 clopkey - closed/open key - integer clopkey -c -c10.4 nfror - forzen orbitals per symmetry in Reorg - integer nfror(1:8) -c -c10.5 ndelr - deleted orbitals per symmetry in Reorg - integer ndelr(1:8) -c -c10.6 maxspace - maximal allowed allocatable area - integer maxspace -c -c10.7 fullprint - output printing control key - integer fullprint -c -c10.8 noop - no operation key - integer noop -c -c10.9 iokey - disk handling control key - integer iokey -c -c10.10 zrkey - key for reading I values and indices simultanously - integer zrkey -c - common /inputkeys/ cckey,t3key,clopkey,nfror,ndelr,maxspace, - & fullprint,noop,iokey,zrkey -c - common /luns/ lunsta,luna1,luna2,luna3,luna4,lunab, - & lunt3,lunda1,lunda2,lunpublic -c -c8 parameters for direct access file -c -c8.1 lun and recl (in R8 words) for direct access TEMPDA1,TEMPDA2 -c -c -CFUE added to transport total energies - real*8 Escf - common /ccsort_energies/ Escf -CFUE -c -c ------ special T3 part ------ -c -c2 name for joinded T3 integral file - character*6 t3nam - parameter (t3nam='T3VVVO') -c - integer mxt3pos - parameter (mxt3pos=mbas) -#include "t3int.fh" diff -Nru openmolcas-22.02/src/ccsort_util/t3intpck1.f openmolcas-22.10/src/ccsort_util/t3intpck1.f --- openmolcas-22.02/src/ccsort_util/t3intpck1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/t3intpck1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,75 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine t3intpck1 (vint,r,dimv1,dimv2,dimv3,dima,dimbc, - & symq,symr,syms,nob,nvb) -c -c this routine pack integral block symi,symq,symr,syms -c R_i(a,bc) = V_i(b,a,c) -c for symq(b)=syms(c) -c and write R block onto proper place of opened t3nam file - lunt3 -c -c vint - integrals for given symetries for given i (I) -c r - final R_i matrix (O) -c dimv1 - 1-st. dimension of V (I) -c dimv2 - 2-nd. dimension of V (I) -c dimv3 - 3-rd. dimension of V (I) -c dima - dimension of a in R (I) -c dimbc - dimension of bc in R (I) -c symq - symmetry of q (b) (I) -c symr - symmetry of r (a) (I) -c syms - symmetry of s (c) (I) -c nob - number of beta occupied in each irrep (I) -c nvb - number of beta virtuals in each irrep (I) -c - implicit none -#include "reorg.fh" -#include "files_ccsd.fh" - integer symq,symr,syms - integer dimv1,dimv2,dimv3,dima,dimbc - integer nob(1:8) - integer nvb(1:8) - real*8 vint(1:dimv1,1:dimv2,1:dimv3) - real*8 r(1:dima,1:dimbc) -c -c help variables -c - integer a,b,c,bc,adda,length,iaddr -c -c* if there are no beta virtuals - goto write section - if (nvb(symq)*nvb(symr)*nvb(syms).eq.0) then - goto 200 - end if -c -c* calc additional constant for a - adda=nob(symr) -c -c* do packing -c - bc=0 - do 100 b=nob(symq)+1,nob(symq)+nvb(symq) - do 101 c=nob(syms)+1,b - bc=bc+1 - do 102 a=1,nvb(symr) - r(a,bc)=vint(b,a+adda,c) - 102 continue - 101 continue - 100 continue -c -c* write section -c - 200 length=dima*dimbc - if (length.gt.0) then - iaddr=daddr(lunt3) - call ddafile (lunt3,1,r(1,1),length,iaddr) - end if - - return - end diff -Nru openmolcas-22.02/src/ccsort_util/t3intpck1.F90 openmolcas-22.10/src/ccsort_util/t3intpck1.F90 --- openmolcas-22.02/src/ccsort_util/t3intpck1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/t3intpck1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,70 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine t3intpck1(vint,r,dimv1,dimv2,dimv3,dima,dimbc,symq,symr,syms,nob,nvb) +! this routine packs integral block symi,symq,symr,syms +! R_i(a,bc) = V_i(b,a,c) +! for symq(b)=syms(c) +! and writes R block onto proper place of open t3nam file - lunt3 +! +! vint - integrals for given symmetries for given i (I) +! r - final R_i matrix (O) +! dimv1 - 1st dimension of V (I) +! dimv2 - 2nd dimension of V (I) +! dimv3 - 3rd dimension of V (I) +! dima - dimension of a in R (I) +! dimbc - dimension of bc in R (I) +! symq - symmetry of q (b) (I) +! symr - symmetry of r (a) (I) +! syms - symmetry of s (c) (I) +! nob - number of beta occupied in each irrep (I) +! nvb - number of beta virtuals in each irrep (I) + +use ccsort_global, only: daddr, lunt3 +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: dimv1, dimv2, dimv3, dima, dimbc, symq, symr, syms, nob(8), nvb(8) +real(kind=wp), intent(in) :: vint(dimv1,dimv2,dimv3) +real(kind=wp), intent(out) :: r(dima,dimbc) +integer(kind=iwp) :: a, adda, b, bc, c, iaddr, length + +! if there are no beta virtuals - skip to write section +if (nvb(symq)*nvb(symr)*nvb(syms) /= 0) then + + ! calc additional constant for a + adda = nob(symr) + + ! do packing + + bc = 0 + do b=nob(symq)+1,nob(symq)+nvb(symq) + do c=nob(syms)+1,b + bc = bc+1 + do a=1,nvb(symr) + r(a,bc) = vint(b,a+adda,c) + end do + end do + end do + +end if + +! write section + +length = dima*dimbc +if (length > 0) then + iaddr = daddr(lunt3) + call ddafile(lunt3,1,r(1,1),length,iaddr) +end if + +return + +end subroutine t3intpck1 diff -Nru openmolcas-22.02/src/ccsort_util/t3intpck2.f openmolcas-22.10/src/ccsort_util/t3intpck2.f --- openmolcas-22.02/src/ccsort_util/t3intpck2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/t3intpck2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,77 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine t3intpck2 (vint,r,dimv1,dimv2,dimv3,dima,dimb,dimc, - & symq,symr,syms,nob,nvb) -c -c this routine pack integral block symi,symq,symr,syms -c R_i(a,b,c) = V_i(b,a,c) -c for symq(b)>syms(c) -c and write R block onto proper place of opened t3nam file - lunt3 -c -c vint - integrals for given symetries for given i (I) -c r - final R_i matrix (O) -c dimv1 - 1-st. dimension of V (I) -c dimv2 - 2-nd. dimension of V (I) -c dimv3 - 3-rd. dimension of V (I) -c dima - dimension of a in R (I) -c dimb - dimension of b in R (I) -c dimc - dimension of c in R (I) -c symq - symmetry of q (b) (I) -c symr - symmetry of r (a) (I) -c syms - symmetry of s (c) (I) -c nob - number of beta occupied in each irrep (I) -c nvb - number of beta virtuals in each irrep (I) -c - implicit none -#include "reorg.fh" -#include "files_ccsd.fh" - integer symq,symr,syms - integer dimv1,dimv2,dimv3,dima,dimb,dimc - integer nob(1:8) - integer nvb(1:8) - real*8 vint(1:dimv1,1:dimv2,1:dimv3) - real*8 r(1:dima,1:dimb,1:dimc) -c -c help variables -c - integer a,b,c,adda,addb,addc,length,iaddr -c -c* if there are no beta virtuals - skip - if (nvb(symq)*nvb(symr)*nvb(syms).eq.0) then - return - end if -c -c* calc additional constants for a,b,c - adda=nob(symr) - addb=nob(symq) - addc=nob(syms) - -c -c* do packing -c - do 100 c=1,nvb(syms) - do 101 b=1,nvb(symq) - do 102 a=1,nvb(symr) - r(a,b,c)=vint(b+addb,a+adda,c+addc) - 102 continue - 101 continue - 100 continue -c -c* write section -c - length=dima*dimb*dimc - if (length.gt.0) then - iaddr=daddr(lunt3) - call ddafile (lunt3,1,r(1,1,1),length,iaddr) - end if -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/t3intpck2.F90 openmolcas-22.10/src/ccsort_util/t3intpck2.F90 --- openmolcas-22.02/src/ccsort_util/t3intpck2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/t3intpck2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,69 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine t3intpck2(vint,r,dimv1,dimv2,dimv3,dima,dimb,dimc,symq,symr,syms,nob,nvb) +! this routine packs integral block symi,symq,symr,syms +! R_i(a,b,c) = V_i(b,a,c) +! for symq(b)>syms(c) +! and writes R block onto proper place of open t3nam file - lunt3 +! +! vint - integrals for given symmetries for given i (I) +! r - final R_i matrix (O) +! dimv1 - 1st dimension of V (I) +! dimv2 - 2nd dimension of V (I) +! dimv3 - 3rd dimension of V (I) +! dima - dimension of a in R (I) +! dimb - dimension of b in R (I) +! dimc - dimension of c in R (I) +! symq - symmetry of q (b) (I) +! symr - symmetry of r (a) (I) +! syms - symmetry of s (c) (I) +! nob - number of beta occupied in each irrep (I) +! nvb - number of beta virtuals in each irrep (I) + +use ccsort_global, only: daddr, lunt3 +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: dimv1, dimv2, dimv3, dima, dimb, dimc, symq, symr, syms, nob(8), nvb(8) +real(kind=wp), intent(in) :: vint(dimv1,dimv2,dimv3) +real(kind=wp), intent(out) :: r(dima,dimb,dimc) +integer(kind=iwp) :: a, adda, addb, addc, b, c, iaddr, length + +! if there are no beta virtuals - skip +if (nvb(symq)*nvb(symr)*nvb(syms) == 0) return + +! calc additional constants for a,b,c +adda = nob(symr) +addb = nob(symq) +addc = nob(syms) + +! do packing + +do c=1,nvb(syms) + do b=1,nvb(symq) + do a=1,nvb(symr) + r(a,b,c) = vint(b+addb,a+adda,c+addc) + end do + end do +end do + +! write section + +length = dima*dimb*dimc +if (length > 0) then + iaddr = daddr(lunt3) + call ddafile(lunt3,1,r(1,1,1),length,iaddr) +end if + +return + +end subroutine t3intpck2 diff -Nru openmolcas-22.02/src/ccsort_util/t3reorg.f openmolcas-22.10/src/ccsort_util/t3reorg.f --- openmolcas-22.02/src/ccsort_util/t3reorg.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/t3reorg.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,104 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine t3reorg (wrk,wrksize, - & noa,nsym) -c -c this routine do final reorganization of t3nam file -c and produce final form of this file -c as it will be required in T3 and close t3nam file -c -c noa - array with occupation numbers -c nsym - actual number of irreps -c - implicit none -#include "wrk.fh" -#include "reorg.fh" -#include "files_ccsd.fh" - integer noa(1:8) - integer nsym -c -c help variables -c - integer length,iri,possri - integer posst - integer symi,i,iaddr,iindex,iPossPack -c -c* def iPossPack -c iPossPack - possition of (maps+Ri) set in packed -c (i.e. final) of T3nam file - iPossPack=T3IntPoss(1) -c - iindex=0 - do symi=1,nsym -c -c0 get map's of R_i(a,bc) - call ccsort_t3grc0 - c (3,8,4,4,4,0,symi,possri0,posst,mapdri,mapiri) -c - do i=1,noa(symi) - iindex=iindex+1 -c -c1 reconstruct R_i(a,bc) per blocks as in is -c actually written in t3man file - do iri=1,mapdri(0,5) -c -c1.1 iind address of this R_i block in t3nam file - iaddr=T3IntPoss(iindex)+T3Off(iri,symi) -c -c1.2 def possition of of this block in R1 - possri=mapdri(iri,1) -c -c1.3 read integrals into proper possition - length=mapdri(iri,2) - if (length.gt.0) then - call ddafile (lunt3,2,wrk(possri),length,iaddr) - end if -c - end do -c -c2 write into t3nam file in packed form -c 1) mapdri, mapiri -c 2) R_i -c2.1 def final (packed) address for i-th set (maps+Ri) - T3intPoss(iindex)=iPossPack - iaddr=T3intPoss(iindex) -c -c2.2 write maps - call idafile (lunt3,1,mapdri,3078,iaddr) - call idafile (lunt3,1,mapiri,512,iaddr) -c -c2.3 def actual length of Ri - length=0 - do iri=1,mapdri(0,5) - length=length+mapdri(iri,2) - end do -c length=mapdri(iri,1)+mapdri(iri,2)-mapdri(1,1) -c -c2.4 write Ri as one block - call ddafile (lunt3,1,wrk(possri0),length,iaddr) -c -c2.5 save updated address as a new packed (final) possition -c for next i - iPossPack=iaddr -c - end do - end do -c -c3 store new packed (final) addreses T3IntPoss in t3nam file -c (at the beggining) - iaddr=0 - call idafile (lunt3,1,T3IntPoss,mbas,iaddr) -c -c4 close t3nam file - call daclos (lunt3) -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/t3reorg.F90 openmolcas-22.10/src/ccsort_util/t3reorg.F90 --- openmolcas-22.02/src/ccsort_util/t3reorg.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/t3reorg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,98 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine t3reorg(wrk,wrksize,noa,nsym) +! this routine does final reorganization of t3nam file +! and produces final form of this file +! as it will be required in T3 and close t3nam file +! +! noa - array with occupation numbers +! nsym - actual number of irreps + +use ccsort_global, only: lunt3, mapdri, mapiri, mbas, posri0 +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: wrksize, noa(8), nsym +real(kind=wp), intent(_OUT_) :: wrk(wrksize) +#include "t3int.fh" +integer(kind=iwp) :: i, iaddr, iindex, iPosPack, iri, length, posri, post, symi + +! def iPosPack +! iPosPack - position of (maps+Ri) set in packed +! (i.e. final) of T3nam file +iPosPack = T3IntPos(1) + +iindex = 0 +do symi=1,nsym + + !0 get map's of R_i(a,bc) + call ccsort_t3grc0(3,8,4,4,4,0,symi,posri0,post,mapdri,mapiri) + + do i=1,noa(symi) + iindex = iindex+1 + + !1 reconstruct R_i(a,bc) per blocks as in is + ! actually written in t3man file + do iri=1,mapdri(0,5) + + !1.1 iind address of this R_i block in t3nam file + iaddr = T3IntPos(iindex)+T3Off(iri,symi) + + !1.2 def position of of this block in R1 + posri = mapdri(iri,1) + + !1.3 read integrals into proper position + length = mapdri(iri,2) + if (length > 0) call ddafile(lunt3,2,wrk(posri),length,iaddr) + + end do + + !2 write into t3nam file in packed form + ! 1) mapdri, mapiri + ! 2) R_i + !2.1 def final (packed) address for i-th set (maps+Ri) + T3intPos(iindex) = iPosPack + iaddr = T3intPos(iindex) + + !2.2 write maps + call idafile(lunt3,1,mapdri,3078,iaddr) + call idafile(lunt3,1,mapiri,512,iaddr) + + !2.3 def actual length of Ri + length = 0 + do iri=1,mapdri(0,5) + length = length+mapdri(iri,2) + end do + !length = mapdri(iri,1)+mapdri(iri,2)-mapdri(1,1) + + !2.4 write Ri as one block + call ddafile(lunt3,1,wrk(posri0),length,iaddr) + + !2.5 save updated address as a new packed (final) position for next i + iPosPack = iaddr + + end do +end do + +!3 store new packed (final) addresses T3IntPos in t3nam file +! (at the beggining) +iaddr = 0 +call idafile(lunt3,1,T3IntPos,mbas,iaddr) + +!4 close t3nam file +call daclos(lunt3) + +return + +end subroutine t3reorg diff -Nru openmolcas-22.02/src/ccsort_util/unpackk.f openmolcas-22.10/src/ccsort_util/unpackk.f --- openmolcas-22.02/src/ccsort_util/unpackk.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/unpackk.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine unpackk (i,vint,ndimv1,ndimv2,ndimv3,key) -c -c unpackk process control routine -c -c i - value of pivot index (I) -c vint - array of integrals (O) -c ndimv1 - first dimension of vint (norb(symj)) (I) -c ndimv2 - second dimension of vint (norb(symk)) (I) -c ndimv3 - third dimension of vint (norb(syml)) (I) -c key - reduced storing key (I) -c = 0 if symj is not syml -c = 1 if symj = syml -c -#include "reorg.fh" - integer i,ndimv1,ndimv2,ndimv3,key - real*8 vint(1:ndimv1,1:ndimv2,1:ndimv3) -c - if (zrkey.eq.1) then - call unpackk_zr (i,vint,ndimv1,ndimv2,ndimv3,key) - else - call unpackk_pck (i,vint,ndimv1,ndimv2,ndimv3,key) - end if -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/unpackk.F90 openmolcas-22.10/src/ccsort_util/unpackk.F90 --- openmolcas-22.02/src/ccsort_util/unpackk.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/unpackk.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,39 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine unpackk(i,vint,ndimv1,ndimv2,ndimv3,key) +! unpackk process control routine +! +! i - value of pivot index (I) +! vint - array of integrals (O) +! ndimv1 - first dimension of vint (norb(symj)) (I) +! ndimv2 - second dimension of vint (norb(symk)) (I) +! ndimv3 - third dimension of vint (norb(syml)) (I) +! key - reduced storing key (I) +! = 0 if symj is not syml +! = 1 if symj = syml + +use ccsort_global, only: zrkey +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: i, ndimv1, ndimv2, ndimv3, key +real(kind=wp), intent(out) :: vint(ndimv1,ndimv2,ndimv3) + +if (zrkey == 1) then + call unpackk_zr(i,vint,ndimv1,ndimv2,ndimv3,key) +else + call unpackk_pck(i,vint,ndimv1,ndimv2,ndimv3,key) +end if + +return + +end subroutine unpackk diff -Nru openmolcas-22.02/src/ccsort_util/unpackk_ic_1.f openmolcas-22.10/src/ccsort_util/unpackk_ic_1.f --- openmolcas-22.02/src/ccsort_util/unpackk_ic_1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/unpackk_ic_1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine unpackk_ic_1 (i,vint,ndimv1,ndimv2,ndimv3, - c Vic,ndimvi) -c -c this routine vint(j,k,l) = -c for given i from incore (nonreduced) expanded block Vic -c -c i - value of pivot index (I) -c vint - array of integrals (O) -c ndimv1 - first dimension of vint (norb(symj)) (I) -c ndimv2 - second dimension of vint (norb(symk)) (I) -c ndimv3 - third dimension of vint (norb(syml)) (I) -c Vic - incore expanded block of integrals (I) -c ndimvi - first dimension of Vic norb(symi) (I) -c -#include "reorg.fh" - -#include "SysDef.fh" - integer i,ndimv1,ndimv2,ndimv3,ndimvi - real*8 vint(1:ndimv1*ndimv2*ndimv3) - real*8 Vic(1:ndimvi,1:ndimv1*ndimv2*ndimv3) -c -c help variables -c - integer jkl -c -c - do jkl=1,ndimv1*ndimv2*ndimv3 - vint(jkl)=Vic(i,jkl) - end do -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/unpackk_ic_1.F90 openmolcas-22.10/src/ccsort_util/unpackk_ic_1.F90 --- openmolcas-22.02/src/ccsort_util/unpackk_ic_1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/unpackk_ic_1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,35 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine unpackk_ic_1(i,vint,ndimv1,ndimv2,ndimv3,Vic,ndimvi) +! this routine vint(j,k,l) = +! for given i from incore (nonreduced) expanded block Vic +! +! i - value of pivot index (I) +! vint - array of integrals (O) +! ndimv1 - first dimension of vint (norb(symj)) (I) +! ndimv2 - second dimension of vint (norb(symk)) (I) +! ndimv3 - third dimension of vint (norb(syml)) (I) +! Vic - incore expanded block of integrals (I) +! ndimvi - first dimension of Vic norb(symi) (I) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: i, ndimv1, ndimv2, ndimv3, ndimvi +real(kind=wp), intent(out) :: vint(ndimv1,ndimv2,ndimv3) +real(kind=wp), intent(in) :: Vic(ndimvi,ndimv1,ndimv2,ndimv3) + +vint(:,:,:) = Vic(i,:,:,:) + +return + +end subroutine unpackk_ic_1 diff -Nru openmolcas-22.02/src/ccsort_util/unpackk_ic_2.f openmolcas-22.10/src/ccsort_util/unpackk_ic_2.f --- openmolcas-22.02/src/ccsort_util/unpackk_ic_2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/unpackk_ic_2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,52 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine unpackk_ic_2 (i,vint,ndimvi,ndimvj,Vic) -c -c this routine vint(j,k,l) = -c for given i from incore (reduced) expanded block Vic -c ie. symp=symr,symq=syms -c -c i - value of pivot index (I) -c vint - array of integrals (O) -c ndimvi - (norb(symi)) (I) -c ndimvj - (norb(symj)) (I) -c Vic - incore expanded block of integrals (I) -c -#include "reorg.fh" - -#include "SysDef.fh" - integer i,ndimvi,ndimvj - real*8 vint(1:ndimvj,1:ndimvi,1:ndimvj) - real*8 Vic(1:(ndimvi*(ndimvi+1)/2),1:(ndimvj*(ndimvj+1)/2)) -c -c help variables -c - integer j,k,l,ik,jl -c -c - do k=1,ndimvi - if (i.ge.k) then - ik=i*(i-1)/2+k - else - ik=k*(k-1)/2+i - end if - jl=0 - do j=1,ndimvj - do l=1,j - jl=jl+1 - vint(j,k,l)=Vic(ik,jl) - vint(l,k,j)=Vic(ik,jl) - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/unpackk_ic_2.F90 openmolcas-22.10/src/ccsort_util/unpackk_ic_2.F90 --- openmolcas-22.02/src/ccsort_util/unpackk_ic_2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/unpackk_ic_2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,49 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine unpackk_ic_2(i,vint,ndimvi,ndimvj,Vic) +! this routine vint(j,k,l) = +! for given i from incore (reduced) expanded block Vic +! ie. symp=symr,symq=syms +! +! i - value of pivot index (I) +! vint - array of integrals (O) +! ndimvi - (norb(symi)) (I) +! ndimvj - (norb(symj)) (I) +! Vic - incore expanded block of integrals (I) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: i, ndimvi, ndimvj +real(kind=wp), intent(out) :: vint(ndimvj,ndimvi,ndimvj) +real(kind=wp), intent(in) :: Vic(ndimvi*(ndimvi+1)/2,ndimvj*(ndimvj+1)/2) +integer(kind=iwp) :: ik, j, jl, k, l + +do k=1,ndimvi + if (i >= k) then + ik = i*(i-1)/2+k + else + ik = k*(k-1)/2+i + end if + jl = 0 + do j=1,ndimvj + do l=1,j + jl = jl+1 + vint(j,k,l) = Vic(ik,jl) + vint(l,k,j) = Vic(ik,jl) + end do + end do +end do + +return + +end subroutine unpackk_ic_2 diff -Nru openmolcas-22.02/src/ccsort_util/unpackk_ic_3.f openmolcas-22.10/src/ccsort_util/unpackk_ic_3.f --- openmolcas-22.02/src/ccsort_util/unpackk_ic_3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/unpackk_ic_3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,65 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine unpackk_ic_3 (i,vint,ndimvi,Vic) -c -c this routine vint(j,k,l) = -c for given i from incore (reduced) expanded block Vic -c ie. symp=symq=symr=syms -c -c i - value of pivot index (I) -c vint - array of integrals (O) -c ndimvi - (norb(symi)) (I) -c Vic - incore expanded block of integrals (I) -c -#include "reorg.fh" - -#include "SysDef.fh" - integer i,ndimvi - real*8 vint(1:ndimvi,1:ndimvi,1:ndimvi) - real*8 Vic(1:(ndimvi*(ndimvi+1)/2)*(1+ndimvi*(ndimvi+1)/2)/2) -c -c help variables -c - integer j,k,l,ik,jl,ikjl -c -c - do k=1,ndimvi -c -c def ik - if (i.ge.k) then - ik=i*(i-1)/2+k - else - ik=k*(k-1)/2+i - end if -c - jl=0 - do j=1,ndimvi - do l=1,j -c -c def jl - jl=jl+1 -c -c def ikjl - if (ik.ge.jl) then - ikjl=ik*(ik-1)/2+jl - else - ikjl=jl*(jl-1)/2+ik - end if -c - vint(j,k,l)=Vic(ikjl) - vint(l,k,j)=Vic(ikjl) -c - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/unpackk_ic_3.F90 openmolcas-22.10/src/ccsort_util/unpackk_ic_3.F90 --- openmolcas-22.02/src/ccsort_util/unpackk_ic_3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/unpackk_ic_3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,62 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine unpackk_ic_3(i,vint,ndimvi,Vic) +! this routine vint(j,k,l) = +! for given i from incore (reduced) expanded block Vic +! ie. symp=symq=symr=syms +! +! i - value of pivot index (I) +! vint - array of integrals (O) +! ndimvi - (norb(symi)) (I) +! Vic - incore expanded block of integrals (I) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: i, ndimvi +real(kind=wp), intent(out) :: vint(ndimvi,ndimvi,ndimvi) +real(kind=wp), intent(in) :: Vic((ndimvi*(ndimvi+1)/2)*(ndimvi*(ndimvi+1)/2+1)/2) +integer(kind=iwp) :: ik, ikjl, j, jl, k, l + +do k=1,ndimvi + + ! def ik + if (i >= k) then + ik = i*(i-1)/2+k + else + ik = k*(k-1)/2+i + end if + + jl = 0 + do j=1,ndimvi + do l=1,j + + ! def jl + jl = jl+1 + + ! def ikjl + if (ik >= jl) then + ikjl = ik*(ik-1)/2+jl + else + ikjl = jl*(jl-1)/2+ik + end if + + vint(j,k,l) = Vic(ikjl) + vint(l,k,j) = Vic(ikjl) + + end do + end do +end do + +return + +end subroutine unpackk_ic_3 diff -Nru openmolcas-22.02/src/ccsort_util/unpackk_pck.f openmolcas-22.10/src/ccsort_util/unpackk_pck.f --- openmolcas-22.02/src/ccsort_util/unpackk_pck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/unpackk_pck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,113 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine unpackk_pck (i,vint,ndimv1,ndimv2,ndimv3,key) -c -c this routine expand integrals packed in i-th TEMP file -c to vint(j,k,l) = -c -c i - value of pivot index (I) -c vint - array of integrals (O) -c ndimv1 - first dimension of vint (norb(symj)) (I) -c ndimv2 - second dimension of vint (norb(symk)) (I) -c ndimv3 - third dimension of vint (norb(syml)) (I) -c key - reduced storing key (I) -c = 0 if symj is not syml -c = 1 if symj = syml -c -#include "reorg.fh" - -#include "SysDef.fh" - integer i,ndimv1,ndimv2,ndimv3,key - real*8 vint(1:ndimv1,1:ndimv2,1:ndimv3) -c -c help variables -c - integer nhelp,length,daddr,nrec -c - integer constj - parameter (constj=1048576) - integer constk - parameter (constk=1024) -c - character*(RtoB+ItoB) pp(1:nsize),pphelp - real*8 rhelp - integer ihelp,ires -c -c* set vint=0 -c - nhelp=ndimv1*ndimv2*ndimv3 - call ccsort_mv0zero (nhelp,nhelp,vint) -c -c* open corresponding TEMP file -c - if (iokey.eq.1) then -c Fortran IO - call molcas_binaryopen_vanilla(lunpublic,tmpnam(i)) -c open (unit=lunpublic,file=tmpnam(i),form='unformatted') - else -c MOLCAS IO - call daname (lunpublic,tmpnam(i)) - daddr=0 - end if -c - do nrec=1,nrectemp(i) -c - if (nrec.ne.nrectemp(i)) then - length=nsize - else - length=lrectemp(i) - end if -c - if (iokey.eq.1) then -c Fortran IO - call getpp_pck (lunpublic,pp,length) - else -c MOLCAS IO - call cdafile (lunpublic,2,pp,(RtoB+ItoB)*length,daddr) - end if - -c -c* get indexes jh,kh,lh and value valh from packed form -c - do nhelp=1,length - pphelp=pp(nhelp) - rhelp=transfer(pphelp(1:RtoB),rhelp) - ihelp=transfer(pphelp(RtoB+1:),ihelp) - valh(nhelp)=rhelp - jh(nhelp)=int(ihelp/constj) - ires=ihelp-constj*jh(nhelp) - kh(nhelp)=int(ires/constk) - lh(nhelp)=ires-constk*kh(nhelp) - end do -c - if (key.eq.0) then - do 100 nhelp=1,length - vint(jh(nhelp),kh(nhelp),lh(nhelp))=valh(nhelp) - 100 continue - else - do 200 nhelp=1,length - vint(jh(nhelp),kh(nhelp),lh(nhelp))=valh(nhelp) - vint(lh(nhelp),kh(nhelp),jh(nhelp))=valh(nhelp) - 200 continue - end if -c - end do -c - if (iokey.eq.1) then -c Fortran IO - close (lunpublic) - else -c Molcas IO - call daclos (lunpublic) - end if -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/unpackk_pck.F90 openmolcas-22.10/src/ccsort_util/unpackk_pck.F90 --- openmolcas-22.02/src/ccsort_util/unpackk_pck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/unpackk_pck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,111 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine unpackk_pck(i,vint,ndimv1,ndimv2,ndimv3,key) +! this routine expands integrals packed in i-th TEMP file +! to vint(j,k,l) = +! +! i - value of pivot index (I) +! vint - array of integrals (O) +! ndimv1 - first dimension of vint (norb(symj)) (I) +! ndimv2 - second dimension of vint (norb(symk)) (I) +! ndimv3 - third dimension of vint (norb(syml)) (I) +! key - reduced storing key (I) +! = 0 if symj is not syml +! = 1 if symj = syml + +use ccsort_global, only: iokey, jh, kh, lh, lrectemp, lunpublic, nrectemp, nsize, tmpnam, valh +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp, ItoB, RtoB + +implicit none +integer(kind=iwp), intent(in) :: i, ndimv1, ndimv2, ndimv3, key +real(kind=wp), intent(out) :: vint(ndimv1,ndimv2,ndimv3) +integer(kind=iwp) :: daddr, ihelp, ires, length, nhelp, nrec +character(len=RtoB+ItoB) :: pphelp +real(kind=wp) :: rhelp +character(len=RtoB+ItoB), allocatable :: pp(:) +integer(kind=iwp), parameter :: constj = 1024**2, constk = 1024 + +! set vint=0 + +vint(:,:,:) = Zero + +! open corresponding TEMP file + +if (iokey == 1) then + ! Fortran IO + call molcas_binaryopen_vanilla(lunpublic,tmpnam(i)) + !open(unit=lunpublic,file=tmpnam(i),form='unformatted') +else + ! MOLCAS IO + call daname(lunpublic,tmpnam(i)) + daddr = 0 +end if + +call mma_allocate(pp,nsize,label='pp') + +do nrec=1,nrectemp(i) + + if (nrec /= nrectemp(i)) then + length = nsize + else + length = lrectemp(i) + end if + + if (iokey == 1) then + ! Fortran IO + read(lunpublic) pp(1:length) + else + ! MOLCAS IO + call cdafile(lunpublic,2,pp,(RtoB+ItoB)*length,daddr) + end if + + ! get indices jh,kh,lh and value valh from packed form + + do nhelp=1,length + pphelp = pp(nhelp) + rhelp = transfer(pphelp(1:RtoB),rhelp) + ihelp = transfer(pphelp(RtoB+1:),ihelp) + valh(nhelp) = rhelp + jh(nhelp) = int(ihelp/constj,kind=kind(jh)) + ires = ihelp-constj*jh(nhelp) + kh(nhelp) = int(ires/constk,kind=kind(kh)) + lh(nhelp) = int(ires-constk*kh(nhelp),kind=kind(lh)) + end do + + if (key == 0) then + do nhelp=1,length + vint(jh(nhelp),kh(nhelp),lh(nhelp)) = valh(nhelp) + end do + else + do nhelp=1,length + vint(jh(nhelp),kh(nhelp),lh(nhelp)) = valh(nhelp) + vint(lh(nhelp),kh(nhelp),jh(nhelp)) = valh(nhelp) + end do + end if + +end do + +call mma_deallocate(pp) + +if (iokey == 1) then + ! Fortran IO + close(lunpublic) +else + ! Molcas IO + call daclos(lunpublic) +end if + +return + +end subroutine unpackk_pck diff -Nru openmolcas-22.02/src/ccsort_util/unpackk_zr.f openmolcas-22.10/src/ccsort_util/unpackk_zr.f --- openmolcas-22.02/src/ccsort_util/unpackk_zr.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/unpackk_zr.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,109 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine unpackk_zr (i,vint,ndimv1,ndimv2,ndimv3,key) -c -c this routine expand integrals packed in i-th TEMP file -c to vint(j,k,l) = -c -c i - value of pivot index (I) -c vint - array of integrals (O) -c ndimv1 - first dimension of vint (norb(symj)) (I) -c ndimv2 - second dimension of vint (norb(symk)) (I) -c ndimv3 - third dimension of vint (norb(syml)) (I) -c key - reduced storing key (I) -c = 0 if symj is not syml -c = 1 if symj = syml -c -#include "reorg.fh" - -#include "SysDef.fh" - integer i,ndimv1,ndimv2,ndimv3,key - real*8 vint(1:ndimv1,1:ndimv2,1:ndimv3) -c -c help variables -c - integer nhelp,length,daddr,nrec -c - integer constj - parameter (constj=1048576) - integer constk - parameter (constk=1024) -c - integer ihelp,ires - Integer iBuf(1:nsize) -c -c* set vint=0 -c - nhelp=ndimv1*ndimv2*ndimv3 - call ccsort_mv0zero (nhelp,nhelp,vint) -c -c* open corresponding TEMP file -c - if (iokey.eq.1) then -c Fortran IO - call molcas_binaryopen_vanilla(lunpublic,tmpnam(i)) -c open (unit=lunpublic,file=tmpnam(i),form='unformatted') - else -c MOLCAS IO - call daname (lunpublic,tmpnam(i)) - daddr=0 - end if -c - do nrec=1,nrectemp(i) -c - if (nrec.ne.nrectemp(i)) then - length=nsize - else - length=lrectemp(i) - end if -c - if (iokey.eq.1) then -c Fortran IO - call getpp_zr (lunpublic,valh,iBuf,length) - else -c MOLCAS IO - call ddafile (lunpublic,2,valh,length,daddr) - call idafile (lunpublic,2,iBuf,length,daddr) - end if -c -c* get indexes jh,kh,lh and value valh from packed form -c - do nhelp=1,length - ihelp=iBuf(nhelp) - jh(nhelp)=int(ihelp/constj) - ires=ihelp-constj*jh(nhelp) - kh(nhelp)=int(ires/constk) - lh(nhelp)=ires-constk*kh(nhelp) - end do -c - if (key.eq.0) then - do 100 nhelp=1,length - vint(jh(nhelp),kh(nhelp),lh(nhelp))=valh(nhelp) - 100 continue - else - do 200 nhelp=1,length - vint(jh(nhelp),kh(nhelp),lh(nhelp))=valh(nhelp) - vint(lh(nhelp),kh(nhelp),jh(nhelp))=valh(nhelp) - 200 continue - end if -c - end do -c - if (iokey.eq.1) then -c Fortran IO - close (lunpublic) - else -c Molcas IO - call daclos (lunpublic) - end if -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/unpackk_zr.F90 openmolcas-22.10/src/ccsort_util/unpackk_zr.F90 --- openmolcas-22.02/src/ccsort_util/unpackk_zr.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/unpackk_zr.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,107 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine unpackk_zr(i,vint,ndimv1,ndimv2,ndimv3,key) +! this routine expands integrals packed in i-th TEMP file +! to vint(j,k,l) = +! +! i - value of pivot index (I) +! vint - array of integrals (O) +! ndimv1 - first dimension of vint (norb(symj)) (I) +! ndimv2 - second dimension of vint (norb(symk)) (I) +! ndimv3 - third dimension of vint (norb(syml)) (I) +! key - reduced storing key (I) +! = 0 if symj is not syml +! = 1 if symj = syml + +use ccsort_global, only: iokey, jh, kh, lh, lrectemp, lunpublic, nrectemp, nsize, tmpnam, valh +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: i, ndimv1, ndimv2, ndimv3, key +real(kind=wp), intent(out) :: vint(ndimv1,ndimv2,ndimv3) +integer(kind=iwp) :: daddr, ihelp, ires, length, nhelp, nrec +integer(kind=iwp), allocatable :: iBuf(:) +integer(kind=iwp), parameter :: constj = 1024**2, constk = 1024 + +! set vint=0 + +vint(:,:,:) = Zero + +! open corresponding TEMP file + +if (iokey == 1) then + ! Fortran IO + call molcas_binaryopen_vanilla(lunpublic,tmpnam(i)) + !open(unit=lunpublic,file=tmpnam(i),form='unformatted') +else + ! MOLCAS IO + call daname(lunpublic,tmpnam(i)) + daddr = 0 +end if + +call mma_allocate(iBuf,nsize) + +do nrec=1,nrectemp(i) + + if (nrec /= nrectemp(i)) then + length = nsize + else + length = lrectemp(i) + end if + + if (iokey == 1) then + ! Fortran IO + read(lunpublic) valh(1:length),iBuf(1:length) + else + ! MOLCAS IO + call ddafile(lunpublic,2,valh,length,daddr) + call idafile(lunpublic,2,iBuf,length,daddr) + end if + + ! get indexes jh,kh,lh and value valh from packed form + + do nhelp=1,length + ihelp = iBuf(nhelp) + jh(nhelp) = int(ihelp/constj,kind=kind(jh)) + ires = ihelp-constj*jh(nhelp) + kh(nhelp) = int(ires/constk,kind=kind(jh)) + lh(nhelp) = int(ires-constk*kh(nhelp),kind=kind(lh)) + end do + + if (key == 0) then + do nhelp=1,length + vint(jh(nhelp),kh(nhelp),lh(nhelp)) = valh(nhelp) + end do + else + do nhelp=1,length + vint(jh(nhelp),kh(nhelp),lh(nhelp)) = valh(nhelp) + vint(lh(nhelp),kh(nhelp),jh(nhelp)) = valh(nhelp) + end do + end if + +end do + +call mma_deallocate(iBuf) + +if (iokey == 1) then + ! Fortran IO + close(lunpublic) +else + ! Molcas IO + call daclos(lunpublic) +end if + +return + +end subroutine unpackk_zr diff -Nru openmolcas-22.02/src/ccsort_util/vf.f openmolcas-22.10/src/ccsort_util/vf.f --- openmolcas-22.02/src/ccsort_util/vf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/vf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,26 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine vf (name,lun) -c -c this routine open file vanisf file with a given name -c name - name of the vanished file (I) -c lun - lun number with which file will be opened (I) -c - character*8 name - integer lun -c - call molcas_open(lun,name) -c open (unit=lun,file=name) - write (lun,*) ' File scratched' - close (lun) -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/vf.F90 openmolcas-22.10/src/ccsort_util/vf.F90 --- openmolcas-22.02/src/ccsort_util/vf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/vf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,30 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine vf(fname,lun) +! this routine opens file vanisf file with a given name +! fname- name of the vanished file (I) +! lun - lun number with which file will be opened (I) + +use Definitions, only: iwp + +implicit none +character(len=8), intent(in) :: fname +integer(kind=iwp), intent(in) :: lun + +call molcas_open(lun,fname) +!open(unit=lun,file=fname) +write(lun,*) ' File scratched' +close(lun) + +return + +end subroutine vf diff -Nru openmolcas-22.02/src/ccsort_util/zashlp1.f openmolcas-22.10/src/ccsort_util/zashlp1.f --- openmolcas-22.02/src/ccsort_util/zashlp1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/zashlp1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine zashlp1 (lunpublic,pp,length) - -#include "SysDef.fh" - integer lunpublic,length - character*(RtoB+ItoB) pp(1:length) - write (lunpublic) pp - return - end diff -Nru openmolcas-22.02/src/ccsort_util/zasun.f openmolcas-22.10/src/ccsort_util/zasun.f --- openmolcas-22.02/src/ccsort_util/zasun.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/zasun.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine zasun (i1,length, - & valn,jn,kn,ln) -c -c control routine over zasun process -c -c i1 - number of pivot index (I) -c length - number of valid integrals in block (I) -c - integer length,i1 -#include "reorg.fh" - real*8 valn(1:nsize,1:mbas) - integer jn(1:nsize,1:mbas) - integer kn(1:nsize,1:mbas) - integer ln(1:nsize,1:mbas) -c - if (zrkey.eq.1) then - call zasun_zr (i1,length, - & valn,jn,kn,ln) - else - call zasun_pck (i1,length, - & valn,jn,kn,ln) - end if -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/zasun.F90 openmolcas-22.10/src/ccsort_util/zasun.F90 --- openmolcas-22.02/src/ccsort_util/zasun.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/zasun.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,35 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine zasun(i1,length,valn,jn,kn,ln) +! control routine over zasun process +! +! i1 - number of pivot index (I) +! length - number of valid integrals in block (I) + +use ccsort_global, only: mbas, nsize, zrkey +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: i1, length, jn(nsize,mbas), kn(nsize,mbas), ln(nsize,mbas) +real(kind=wp), intent(_IN_) :: valn(nsize,mbas) + +if (zrkey == 1) then + call zasun_zr(i1,length,valn,jn,kn,ln) +else + call zasun_pck(i1,length,valn,jn,kn,ln) +end if + +return + +end subroutine zasun diff -Nru openmolcas-22.02/src/ccsort_util/zasun_pck.f openmolcas-22.10/src/ccsort_util/zasun_pck.f --- openmolcas-22.02/src/ccsort_util/zasun_pck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/zasun_pck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,122 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine zasun_pck (i1,length, - & valn,jn,kn,ln) -c -c this routine write one block of 3-indices and appropriate -c values of integrals into an opened TEMP-file -c -c i1 - number of pivot index (I) -c length - number of valid integrals in block (I) -c this routine has also jn,kn,ln,valn -c and stattemp and tmpnam as inputs, but they are -c transpotred through commons in reorg.fh -c - implicit real*8 (a-h,o-z) - integer length,i1 -#include "reorg.fh" - -#include "SysDef.fh" - real*8 valn(1:nsize,1:mbas) - integer jn(1:nsize,1:mbas) - integer kn(1:nsize,1:mbas) - integer ln(1:nsize,1:mbas) -c -c help variable -c - integer m2,iRec -c - integer jkl(1:nsize) - integer constj - parameter (constj=1048576) - integer constk - parameter (constk=1024) -c - character*(RtoB+ItoB) pp(1:nsize),pphelp - real*8 rhelp - integer ihelp -c -c* pack indexes and integral values -c - do m2=1,length - jkl(m2)=ln(m2,i1)+constj*jn(m2,i1) - end do - do m2=1,length - jkl(m2)=jkl(m2)+constk*kn(m2,i1) - end do -c - do m2=1,length - rhelp=valn(m2,i1) - ihelp=jkl(m2) - pphelp(1:RtoB)=transfer(rhelp,pphelp(1:RtoB)) - pphelp(RtoB+1:)=transfer(ihelp,pphelp(RtoB+1:)) - pp(m2)=pphelp - end do -c -c* open corresponding TEMP file in corresponding form -c - if (iokey.eq.1) then -c -c Fortran IO -c - if (stattemp(i1).eq.0) then -c file will be opened first time, it must be opened -c whith the pointer at then first possition - call molcas_binaryopen_vanilla(lunpublic,tmpnam(i1)) -c open (unit=lunpublic, -c & file=tmpnam(i1), -c & form='unformatted', -c & status='unknown') - stattemp(i1)=1 -c - else -c file was alredy used in expansion of this block, it must -c be opened whith the pointer at the end of the file -#ifdef _DECAXP_ - call molcas_open_ext2(lunpublic,tmpnam(i1),'append', - & 'unformatted',f_iostat,.false.,1,'unknown',is_error) - -c open (unit=lunpublic, -c & file=tmpnam(i1), -c & form='unformatted', -c & status='unknown', -c & access='append') -#else - call molcas_binaryopen_vanilla(lunpublic,tmpnam(i1)) -c open (unit=lunpublic, -c & file=tmpnam(i1), -c & form='unformatted', -c & status='unknown') - Do iRec = 1,nrectemp(i1) - Read (lunpublic) m2 - End Do -#endif -c - end if -c - call zashlp1 (lunpublic,pp,length) - close (lunpublic) -c - else -c -c MOLCAS IO -c - call daname (lunpublic,tmpnam(i1)) - call cdafile (lunpublic,1,pp,(RtoB+ItoB)*length,stattemp(i1)) - call daclos (lunpublic) -c - end if -c - nrectemp(i1)=nrectemp(i1)+1 - lrectemp(i1)=length -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/zasun_pck.F90 openmolcas-22.10/src/ccsort_util/zasun_pck.F90 --- openmolcas-22.02/src/ccsort_util/zasun_pck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/zasun_pck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,97 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine zasun_pck(i1,length,valn,jn,kn,ln) +! this routine writes one block of 3-indices and appropriate +! values of integrals into an open TEMP-file +! +! i1 - number of pivot index (I) +! length - number of valid integrals in block (I) +! this routine has also jn,kn,ln,valn +! and stattemp and tmpnam as inputs, but they are +! imported from ccsort_global + +use ccsort_global, only: iokey, lrectemp, lunpublic, mbas, nrectemp, nsize, stattemp, tmpnam +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp, ItoB, RtoB + +implicit none +integer(kind=iwp), intent(in) :: i1, length, jn(nsize,mbas), kn(nsize,mbas), ln(nsize,mbas) +real(kind=wp), intent(in) :: valn(nsize,mbas) +integer(kind=iwp) :: ihelp, iRec, m2 +real(kind=wp) :: rhelp +character(len=RtoB+ItoB) :: pphelp +character(len=RtoB+ItoB), allocatable :: pp(:) +integer(kind=iwp), parameter :: constj = 1024**2, constk = 1024 + +! pack indices and integral values + +call mma_allocate(pp,length,label='pp') + +do m2=1,length + rhelp = valn(m2,i1) + ihelp = ln(m2,i1)+constj*jn(m2,i1)+constk*kn(m2,i1) + pphelp(1:RtoB) = transfer(rhelp,pphelp(1:RtoB)) + pphelp(RtoB+1:) = transfer(ihelp,pphelp(RtoB+1:)) + pp(m2) = pphelp +end do + +! open corresponding TEMP file in corresponding form + +if (iokey == 1) then + + ! Fortran IO + + if (stattemp(i1) == 0) then + ! file will be opened first time, it must be opened + ! with the pointer at then first position + call molcas_binaryopen_vanilla(lunpublic,tmpnam(i1)) + !open(unit=lunpublic,file=tmpnam(i1),form='unformatted',status='unknown') + stattemp(i1) = 1 + + else + ! file was already used in expansion of this block, it must + ! be opened with the pointer at the end of the file +# ifdef _DECAXP_ + call molcas_open_ext2(lunpublic,tmpnam(i1),'append','unformatted',f_iostat,.false.,1,'unknown',is_error) + + !open(unit=lunpublic,file=tmpnam(i1),form='unformatted',status='unknown',access='append') +# else + call molcas_binaryopen_vanilla(lunpublic,tmpnam(i1)) + !open(unit=lunpublic,file=tmpnam(i1),form='unformatted',status='unknown') + do iRec=1,nrectemp(i1) + read(lunpublic) m2 + end do +# endif + + end if + + write(lunpublic) pp + close(lunpublic) + +else + + ! MOLCAS IO + + call daname(lunpublic,tmpnam(i1)) + call cdafile(lunpublic,1,pp,(RtoB+ItoB)*length,stattemp(i1)) + call daclos(lunpublic) + +end if + +call mma_deallocate(pp) + +nrectemp(i1) = nrectemp(i1)+1 +lrectemp(i1) = length + +return + +end subroutine zasun_pck diff -Nru openmolcas-22.02/src/ccsort_util/zasun_zr.f openmolcas-22.10/src/ccsort_util/zasun_zr.f --- openmolcas-22.02/src/ccsort_util/zasun_zr.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/zasun_zr.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,111 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine zasun_zr (i1,length, - & valn,jn,kn,ln) -c -c this routine write one block of 3-indices and appropriate -c values of integrals into an opened TEMP-file -c -c i1 - number of pivot index (I) -c length - number of valid integrals in block (I) -c this routine has also jn,kn,ln,valn -c and stattemp and tmpnam as inputs, but they are -c transpotred through commons in reorg.fh -c - implicit real*8 (a-h,o-z) - integer length,i1 -#include "reorg.fh" - -#include "SysDef.fh" - real*8 valn(1:nsize,1:mbas) - integer jn(1:nsize,1:mbas) - integer kn(1:nsize,1:mbas) - integer ln(1:nsize,1:mbas) -c -c help variable -c - integer m2 ! ,iRec -c - integer jkl(1:nsize) - integer constj - parameter (constj=1048576) - integer constk - parameter (constk=1024) - integer f_iostat - logical is_error -c -c* pack indexes -c - do m2=1,length - jkl(m2)=ln(m2,i1)+constj*jn(m2,i1) - jkl(m2)=jkl(m2)+constk*kn(m2,i1) - end do -c -c* open corresponding TEMP file in corresponding form -c - if (iokey.eq.1) then -c -c Fortran IO -c - if (stattemp(i1).eq.0) then -c file will be opened first time, it must be opened -c whith the pointer at then first possition - call molcas_binaryopen_vanilla(lunpublic,tmpnam(i1)) -c open (unit=lunpublic, -c & file=tmpnam(i1), -c & form='unformatted', -c & status='unknown') - stattemp(i1)=1 -c - else -c file was alredy used in expansion of this block, it must -c be opened whith the pointer at the end of the file -c@#ifdef _DECAXP_ - call molcas_open_ext2(lunpublic,tmpnam(i1),'append', - & 'unformatted',f_iostat,.false.,1,'unknown',is_error) -cvv open (unit=lunpublic, -cvv & file=tmpnam(i1), -cvv & form='unformatted', -cvv & status='unknown', -cvv & access='append') -c@#else -c@ call molcas_binaryopen_vanilla(lunpublic,tmpnam(i1)) -c open (unit=lunpublic, -c & file=tmpnam(i1), -c & form='unformatted', -c & status='unknown') -c@ Do iRec = 1,nrectemp(i1) -c@ Read (lunpublic) m2 -c@ End Do -c@#endif -c - end if -c - write (lunpublic) (valn(i,i1),i=1,length), - & (jkl(i),i=1,length) - close (lunpublic) -c - else -c -c MOLCAS IO -c - call daname (lunpublic,tmpnam(i1)) - call ddafile (lunpublic,1,valn(1,i1),length,stattemp(i1)) - call idafile (lunpublic,1,jkl, length,stattemp(i1)) - call daclos (lunpublic) -c - end if -c - nrectemp(i1)=nrectemp(i1)+1 - lrectemp(i1)=length -c - return - end diff -Nru openmolcas-22.02/src/ccsort_util/zasun_zr.F90 openmolcas-22.10/src/ccsort_util/zasun_zr.F90 --- openmolcas-22.02/src/ccsort_util/zasun_zr.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ccsort_util/zasun_zr.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,90 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine zasun_zr(i1,length,valn,jn,kn,ln) +! this routine writes one block of 3-indices and appropriate +! values of integrals into an open TEMP-file +! +! i1 - number of pivot index (I) +! length - number of valid integrals in block (I) +! this routine has also stattemp and tmpnam as inputs, +! but they are imported from ccsort_global + +use ccsort_global, only: iokey, lrectemp, lunpublic, mbas, nrectemp, nsize, stattemp, tmpnam +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: i1, length, jn(nsize,mbas), kn(nsize,mbas), ln(nsize,mbas) +real(kind=wp), intent(_IN_) :: valn(nsize,mbas) +integer(kind=iwp) :: f_iostat !, iRec +logical(kind=iwp) :: is_error +integer(kind=iwp), allocatable :: jkl(:) +integer(kind=iwp), parameter :: constj = 1024*1024, constk = 1024 + +! pack indices + +call mma_allocate(jkl,length,label='jkl') +jkl(1:length) = ln(1:length,i1)+constj*jn(1:length,i1)+constk*kn(1:length,i1) + +! open corresponding TEMP file in corresponding form + +if (iokey == 1) then + + ! Fortran IO + + if (stattemp(i1) == 0) then + ! file will be opened first time, it must be opened + ! with the pointer at then first position + call molcas_binaryopen_vanilla(lunpublic,tmpnam(i1)) + !open(unit=lunpublic,file=tmpnam(i1),form='unformatted',status='unknown') + stattemp(i1) = 1 + + else + ! file was already used in expansion of this block, it must + ! be opened with the pointer at the end of the file +!# ifdef _DECAXP_ + call molcas_open_ext2(lunpublic,tmpnam(i1),'append','unformatted',f_iostat,.false.,1,'unknown',is_error) + !vv open(unit=lunpublic,file=tmpnam(i1),form='unformatted',status='unknown',access='append') +!# else +! call molcas_binaryopen_vanilla(lunpublic,tmpnam(i1)) +! open(unit=lunpublic,file=tmpnam(i1),form='unformatted',status='unknown') +! do iRec=1,nrectemp(i1) +! Read(lunpublic) m2 +! end do +!# endif + + end if + + write(lunpublic) valn(1:length,i1),jkl(1:length) + close(lunpublic) + +else + + ! MOLCAS IO + + call daname(lunpublic,tmpnam(i1)) + call ddafile(lunpublic,1,valn(:,i1),length,stattemp(i1)) + call idafile(lunpublic,1,jkl,length,stattemp(i1)) + call daclos(lunpublic) + +end if + +call mma_deallocate(jkl) + +nrectemp(i1) = nrectemp(i1)+1 +lrectemp(i1) = length + +return + +end subroutine zasun_zr diff -Nru openmolcas-22.02/src/cct3_util/cct3.f openmolcas-22.10/src/cct3_util/cct3.f --- openmolcas-22.02/src/cct3_util/cct3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cct3_util/cct3.f 2022-10-10 14:22:40.000000000 +0000 @@ -92,7 +92,7 @@ call t3reaccsd (Work(iOff),wrksize, & eccsd) c -cI.7 get address vector T3IntPoss +cI.7 get address vector T3IntPos c they are located at the beggining of the t3nam file call GetIntPoss c diff -Nru openmolcas-22.02/src/cct3_util/cct3_getint.f openmolcas-22.10/src/cct3_util/cct3_getint.f --- openmolcas-22.02/src/cct3_util/cct3_getint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cct3_util/cct3_getint.f 2022-10-10 14:22:40.000000000 +0000 @@ -64,7 +64,7 @@ c3 get R c lun=1 - daddr(lun)=T3IntPoss(num) + daddr(lun)=T3IntPos(num) c call daname (lun,t3nam) c diff -Nru openmolcas-22.02/src/cct3_util/getintposs.f openmolcas-22.10/src/cct3_util/getintposs.f --- openmolcas-22.02/src/cct3_util/getintposs.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cct3_util/getintposs.f 2022-10-10 14:22:40.000000000 +0000 @@ -10,7 +10,7 @@ ************************************************************************ subroutine GetIntPoss c -c this routine read T3IntPoss array from the first record +c this routine read T3IntPos array from the first record c of t3nam file c implicit none @@ -21,7 +21,7 @@ lun=1 call daname (lun,t3nam) daddr(lun)=0 - call idafile (lun,2,T3IntPoss,maxorb,daddr(lun)) + call idafile (lun,2,T3IntPos,maxorb,daddr(lun)) call daclos (lun) c return diff -Nru openmolcas-22.02/src/cct3_util/t31.fh openmolcas-22.10/src/cct3_util/t31.fh --- openmolcas-22.02/src/cct3_util/t31.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cct3_util/t31.fh 2022-10-10 14:22:40.000000000 +0000 @@ -109,13 +109,6 @@ & symimin,symimax,symjmin,symjmax,imin,imax,jmin,jmax c c ------ special T3 part ------ -c -c2 name for joinded T3 integral file - character*6 t3nam - parameter (t3nam='T3VVVO') -c - integer mxt3pos - parameter (mxt3pos=maxorb) #include "t3int.fh" c c5 diska address file diff -Nru openmolcas-22.02/src/chcc/cho_cc_drv.f openmolcas-22.10/src/chcc/cho_cc_drv.f --- openmolcas-22.02/src/chcc/cho_cc_drv.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/chcc/cho_cc_drv.f 2022-10-10 14:22:40.000000000 +0000 @@ -10,12 +10,12 @@ ************************************************************************ SUBROUTINE CHO_CC_drv(rc,CMO) -********************************************************************** +************************************************************************ C C a,b,g,d: AO-index -C p,q,r,s: MO-indeces belonging to (probably frozen excluded ?) +C p,q,r,s: MO-indices belonging to (probably frozen excluded ?) C -********************************************************************** +************************************************************************ use ChoArr, only: nDimRS use ChoSwp, only: InfVec use Data_Structures, only: DSBA_Type, SBA_Type diff -Nru openmolcas-22.02/src/chemps2_util/CMakeLists.txt openmolcas-22.10/src/chemps2_util/CMakeLists.txt --- openmolcas-22.02/src/chemps2_util/CMakeLists.txt 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/chemps2_util/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -14,7 +14,6 @@ chemps2_densi_rasscf.F90 chemps2_load2pdm.F90 chemps2_load3pdm.F90 - fcidump_output.F90 irreps.F90 ) diff -Nru openmolcas-22.02/src/chemps2_util/fcidump_output.F90 openmolcas-22.10/src/chemps2_util/fcidump_output.F90 --- openmolcas-22.02/src/chemps2_util/fcidump_output.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/chemps2_util/fcidump_output.F90 1970-01-01 00:00:00.000000000 +0000 @@ -1,70 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -! * -! Copyright (C) 2016, Sebastian Wouters * -!*********************************************************************** -! Subroutine to write FCIDUMP file -! Written by Sebastian Wouters, Leuven, Aug 2016 - -subroutine FCIDUMP_OUTPUT(NACT,NELEC,TWOMS,ISYM,ORBSYM,ECONST,OEI,TEI,LINSIZE,NUM_TEI) - -use Definitions, only: wp, iwp - -implicit none -integer(kind=iwp), intent(in) :: NACT, NELEC, TWOMS, ISYM, ORBSYM(NACT), LINSIZE, NUM_TEI -real(kind=wp), intent(in) :: ECONST, OEI(LINSIZE), TEI(NUM_TEI) -integer(kind=iwp) :: i, j, k, l, ij, kl, ijkl, writeout -integer(kind=iwp), external :: isFreeUnit - -writeout = isfreeunit(28) -!open(unit=writeout,file='FCIDUMP_CHEMPS2',action='write',status='replace') -call molcas_open(writeout,'FCIDUMP_CHEMPS2') -write(writeout,'(a11,i3,a7,i3,a5,i2,a1)') ' &FCI NORB=',NACT,',NELEC=',NELEC,',MS2=',TWOMS,',' -write(writeout,'(a9)',advance='NO') ' ORBSYM=' -do i=1,NACT - write(writeout,'(i1,a1)',advance='NO') ORBSYM(i),',' -end do -write(writeout,*) -write(writeout,'(a7,i1,a1)') ' ISYM=',ISYM,',' -write(writeout,'(a2)') ' /' - -do i=1,NACT - do j=1,i - ij = ((i-1)*i)/2+(j-1) - do k=1,NACT - do l=1,k - kl = ((k-1)*k)/2+(l-1) - if (kl <= ij) then - ijkl = 1+(ij*(ij+1))/2+kl - if (abs(TEI(ijkl)) >= 1.0e-16_wp) then - write(writeout,'(1x,es23.16e2,i4,i4,i4,i4)') TEI(ijkl),i,j,k,l - end if - end if - end do - end do - end do -end do - -do i=1,NACT - do j=1,i - ij = 1+((i-1)*i)/2+(j-1) - if (abs(OEI(ij)) >= 1.0e-16_wp) then - write(writeout,'(1x,es23.16e2,i4,i4,i4,i4)') OEI(ij),i,j,0,0 - end if - end do -end do - -write(writeout,'(1x,es23.16e2,i4,i4,i4,i4)') ECONST,0,0,0,0 - -close(writeout) - -return - -end subroutine FCIDUMP_OUTPUT diff -Nru openmolcas-22.02/src/cholesky_util/cho_anasize.f openmolcas-22.10/src/cholesky_util/cho_anasize.f --- openmolcas-22.02/src/cholesky_util/cho_anasize.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_anasize.f 2022-10-10 14:22:40.000000000 +0000 @@ -41,7 +41,7 @@ C --------- NBIN = MIN(LBIN,MBIN) - CALL CHO_IZERO(ICOUNT,NBIN) + CALL IZERO(ICOUNT,NBIN) NLOW = 0 NZER = 0 NNEG = 0 diff -Nru openmolcas-22.02/src/cholesky_util/cho_calcdiag.f openmolcas-22.10/src/cholesky_util/cho_calcdiag.f --- openmolcas-22.02/src/cholesky_util/cho_calcdiag.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_calcdiag.f 2022-10-10 14:22:40.000000000 +0000 @@ -74,7 +74,7 @@ C Initialize abs. max. diag. array. C --------------------------------- - CALL CHO_DZERO(DIAMAX,NSYM) + CALL FZERO(DIAMAX,NSYM) C Allocate array for storing 10 most negative diagonals C (there should be none, of course, but they do show up) diff -Nru openmolcas-22.02/src/cholesky_util/cho_dbgint_cho.f openmolcas-22.10/src/cholesky_util/cho_dbgint_cho.f --- openmolcas-22.02/src/cholesky_util/cho_dbgint_cho.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_dbgint_cho.f 2022-10-10 14:22:40.000000000 +0000 @@ -103,7 +103,7 @@ C Initialize integral array. C -------------------------- - CALL CHO_DZERO(WRK(KINT),LENint) + CALL FZERO(WRK(KINT),LENint) C Set up batch over Cholesky vectors. C ----------------------------------- diff -Nru openmolcas-22.02/src/cholesky_util/cho_drv.f openmolcas-22.10/src/cholesky_util/cho_drv.f --- openmolcas-22.02/src/cholesky_util/cho_drv.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_drv.f 2022-10-10 14:22:40.000000000 +0000 @@ -156,7 +156,7 @@ IF (RSTCHO) THEN WRITE(LUPRI,'(//,10X,A,A,A,//)') & '***** ',SECNAM,': restarted calculation converged. *****' - CALL CHO_DZERO(TIMSEC(1,ISEC),4) + CALL FZERO(TIMSEC(1,ISEC),4) ELSE WRITE(LUPRI,'(A,A)') & SECNAM,': logical error: converged but not restart?!?!' @@ -225,7 +225,7 @@ ISEC = 4 IF (LCONV) THEN - CALL CHO_DZERO(TIMSEC(1,ISEC),4) + CALL FZERO(TIMSEC(1,ISEC),4) ELSE IF (IPRINT .GE. INF_TIMING) THEN CALL CHO_TIMER(TIMSEC(1,ISEC),TIMSEC(3,ISEC)) @@ -285,7 +285,7 @@ CALL CHO_PRTMAXMEM('CHO_DRV_ [AFTER INTEGRAL CHECK]') #endif ELSE - CALL CHO_DZERO(TIMSEC(1,ISEC),4) + CALL FZERO(TIMSEC(1,ISEC),4) END IF C REORDER VECTORS. @@ -318,7 +318,7 @@ CALL CHO_PRTMAXMEM('CHO_DRV_ [AFTER VECTOR REORDERING]') #endif ELSE - CALL CHO_DZERO(TIMSEC(1,ISEC),4) + CALL FZERO(TIMSEC(1,ISEC),4) END IF C FAKE PARALLEL: DISTRIBUTE VECTORS. @@ -347,7 +347,7 @@ CALL CHO_PRTMAXMEM('CHO_DRV_ [AFTER CHO_PFAKE_VDIST]') #endif ELSE - CALL CHO_DZERO(TIMSEC(1,ISEC),4) + CALL FZERO(TIMSEC(1,ISEC),4) END IF C FINALIZATIONS. diff -Nru openmolcas-22.02/src/cholesky_util/cho_dzero.f openmolcas-22.10/src/cholesky_util/cho_dzero.f --- openmolcas-22.02/src/cholesky_util/cho_dzero.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_dzero.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE CHO_DZERO(VEC,N) -C -C Purpose: zero double precision vector. -C - IMPLICIT NONE - REAL*8 VEC(*) - INTEGER I, N - - DO I = 1,N - VEC(I) = 0.0D0 - END DO - - END diff -Nru openmolcas-22.02/src/cholesky_util/cho_getdiag1.f openmolcas-22.10/src/cholesky_util/cho_getdiag1.f --- openmolcas-22.02/src/cholesky_util/cho_getdiag1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_getdiag1.f 2022-10-10 14:22:40.000000000 +0000 @@ -37,9 +37,9 @@ IOPT = 2 CALL CHO_IODIAG(DIAG,IOPT) ELSE - CALL CHO_DZERO(DIAG,NNBSTRT(1)) - CALL CHO_IZERO(INDRSH,NNBSTRT(1)) - CALL CHO_IZERO(INDRED,NNBSTRT(1)) + CALL FZERO(DIAG,NNBSTRT(1)) + CALL IZERO(INDRSH,NNBSTRT(1)) + CALL IZERO(INDRED,NNBSTRT(1)) CALL CHO_RDDBUF(DIAG,BUF,IBUF,INDRSH,INDRED, & LENBUF,MMBSTRT,NDUMP) CALL CHO_GADGOP(DIAG,NNBSTRT(1),'+') diff -Nru openmolcas-22.02/src/cholesky_util/cho_getint.f openmolcas-22.10/src/cholesky_util/cho_getint.f --- openmolcas-22.02/src/cholesky_util/cho_getint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_getint.f 2022-10-10 14:22:40.000000000 +0000 @@ -48,7 +48,7 @@ C Initializations. C ---------------- - CALL CHO_IZERO(NQUAL,NSYM) + CALL IZERO(NQUAL,NSYM) ICOUNT = 0 IF (MXSHPR .GT. 0) THEN MCOUNT = MIN(NPOTSH,MXSHPR) diff -Nru openmolcas-22.02/src/cholesky_util/cho_getvec0.f openmolcas-22.10/src/cholesky_util/cho_getvec0.f --- openmolcas-22.02/src/cholesky_util/cho_getvec0.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_getvec0.f 2022-10-10 14:22:40.000000000 +0000 @@ -42,7 +42,7 @@ C Initialize output array. C ------------------------ - CALL CHO_DZERO(CHOVEC,LENVEC*NUMVEC) + CALL FZERO(CHOVEC,LENVEC*NUMVEC) C Read reduced set index arrays for first vector. C ----------------------------------------------- @@ -110,7 +110,7 @@ & IRED,' dim.: ',NNBSTR(ISYM,3) END IF - CALL CHO_DZERO(SCR(KRED1),NNBSTR(ISYM,1)) + CALL FZERO(SCR(KRED1),NNBSTR(ISYM,1)) IF (IRED .GT. 1) THEN DO JAB = 1,NNBSTR(ISYM,3) ! sort into rs1 ordering KAB = IIBSTR(ISYM,3) + JAB diff -Nru openmolcas-22.02/src/cholesky_util/cho_getz.f openmolcas-22.10/src/cholesky_util/cho_getz.f --- openmolcas-22.02/src/cholesky_util/cho_getz.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_getz.f 2022-10-10 14:22:40.000000000 +0000 @@ -175,10 +175,10 @@ Do iSym=1,nSym Do kBlock=1,nBlock(iSym) - Call Cho_dZero(Z(ip_Z(iTri(kBlock,kBlock),iSym)), + Call FZero(Z(ip_Z(iTri(kBlock,kBlock),iSym)), & nV(kBlock,iSym)*(nV(kBlock,iSym)+1)/2) Do jBlock=kBlock+1,nBlock(iSym) - Call Cho_dZero(Z(ip_Z(iTri(jBlock,kBlock),iSym)), + Call FZero(Z(ip_Z(iTri(jBlock,kBlock),iSym)), & nV(jBlock,iSym)*nV(kBlock,iSym)) End Do End Do diff -Nru openmolcas-22.02/src/cholesky_util/cho_gnvc_drv.f openmolcas-22.10/src/cholesky_util/cho_gnvc_drv.f --- openmolcas-22.02/src/cholesky_util/cho_gnvc_drv.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_gnvc_drv.f 2022-10-10 14:22:40.000000000 +0000 @@ -151,7 +151,7 @@ C Reinitialize vector counters. C ----------------------------- - Call Cho_iZero(NumCho,nSym) + Call iZero(NumCho,nSym) NumChT = 0 C Start batch loop over integral passes. @@ -225,7 +225,7 @@ Write(Lupri,'(A,I10,A,F10.3,A,A)') & 'Memory used for integrals/vectors: ',l_Int, & ' 8-byte words; ',dl_Int,' ',Unt - Call Cho_iZero(nScrV,nSym) + Call iZero(nScrV,nSym) Do i = iPass1,iPass+NumPass Do iSym = 1,nSym nScrV(iSym) = nScrV(iSym) + nVecRS(iSym,i) @@ -263,7 +263,7 @@ C reduced set. C ---------------------------------------------------------- - Call Cho_iZero(nQual,nSym) + Call iZero(nQual,nSym) iPass2 = iPass1 + NumPass - 1 Do jPass = iPass1,iPass2 Do iSym = 1,nSym diff -Nru openmolcas-22.02/src/cholesky_util/cho_inimap.f openmolcas-22.10/src/cholesky_util/cho_inimap.f --- openmolcas-22.02/src/cholesky_util/cho_inimap.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_inimap.f 2022-10-10 14:22:40.000000000 +0000 @@ -26,7 +26,7 @@ IADR = 0 CALL IDAFILE(LUMAP,IOPT,INTMAP,NDIM,IADR) ELSE - CALL CHO_IZERO(INTMAP,SIZE(INTMAP)) + CALL IZERO(INTMAP,SIZE(INTMAP)) END IF END diff -Nru openmolcas-22.02/src/cholesky_util/cho_inirsdim.f openmolcas-22.10/src/cholesky_util/cho_inirsdim.f --- openmolcas-22.02/src/cholesky_util/cho_inirsdim.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_inirsdim.f 2022-10-10 14:22:40.000000000 +0000 @@ -30,6 +30,6 @@ END IF NUM = NSYM*(MAXRED - NSET) - CALL CHO_IZERO(nDimRS(1,NSET+1),NUM) + CALL IZERO(nDimRS(1,NSET+1),NUM) END diff -Nru openmolcas-22.02/src/cholesky_util/cho_init1.f openmolcas-22.10/src/cholesky_util/cho_init1.f --- openmolcas-22.02/src/cholesky_util/cho_init1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_init1.f 2022-10-10 14:22:40.000000000 +0000 @@ -37,14 +37,14 @@ C Initialize vector info and counters. C ------------------------------------ - CALL CHO_IZERO(INFVEC,SIZE(INFVEC)) - CALL CHO_IZERO(NUMCHO,NSYM) + CALL IZERO(INFVEC,SIZE(INFVEC)) + CALL IZERO(NUMCHO,NSYM) NUMCHT = 0 C Initialize reduced set info. C ---------------------------- - CALL CHO_IZERO(INFRED,SIZE(INFRED)) + CALL IZERO(INFRED,SIZE(INFRED)) C Initialize global integral pass counter. C ---------------------------------------- @@ -56,6 +56,6 @@ C Parallel init. C -------------- - IF (Cho_Real_Par) CALL CHO_IZERO(MYNUMCHO,NSYM) + IF (Cho_Real_Par) CALL IZERO(MYNUMCHO,NSYM) END diff -Nru openmolcas-22.02/src/cholesky_util/cho_init.f openmolcas-22.10/src/cholesky_util/cho_init.f --- openmolcas-22.02/src/cholesky_util/cho_init.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_init.f 2022-10-10 14:22:40.000000000 +0000 @@ -111,12 +111,12 @@ C Initialize timings etc. C ----------------------- - CALL CHO_DZERO(TDECDRV,2) - CALL CHO_DZERO(TINTEG,2*NINTEG) - CALL CHO_DZERO(TDECOM,2*NDECOM) - CALL CHO_DZERO(TMISC,2*NMISC) - CALL CHO_IZERO(ICHKQ,4*(NCHKQ+1)) - CALL CHO_IZERO(NVECRS1,NSYM) + CALL FZERO(TDECDRV,2) + CALL FZERO(TINTEG,2*NINTEG) + CALL FZERO(TDECOM,2*NDECOM) + CALL FZERO(TMISC,2*NMISC) + CALL IZERO(ICHKQ,4*(NCHKQ+1)) + CALL IZERO(NVECRS1,NSYM) DID_DECDRV = .FALSE. diff -Nru openmolcas-22.02/src/cholesky_util/cho_izero.f openmolcas-22.10/src/cholesky_util/cho_izero.f --- openmolcas-22.02/src/cholesky_util/cho_izero.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_izero.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE CHO_IZERO(IVEC,N) -C -C Purpose: zero integer vector. -C - IMPLICIT NONE - INTEGER IVEC(*) - INTEGER I, N - - DO I = 1,N - IVEC(I) = 0 - END DO - - END diff -Nru openmolcas-22.02/src/cholesky_util/cho_mca_diagint.f openmolcas-22.10/src/cholesky_util/cho_mca_diagint.f --- openmolcas-22.02/src/cholesky_util/cho_mca_diagint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_mca_diagint.f 2022-10-10 14:22:40.000000000 +0000 @@ -22,7 +22,7 @@ PARAMETER (SECNAM = 'CHO_MCA_DIAGINT') #endif - CALL CHO_DZERO(SCR,LSCR) + CALL FZERO(SCR,LSCR) #if defined (_DEBUGPRINT_) CALL CHO_PRESCR(CUTINT1,THRINT1) diff -Nru openmolcas-22.02/src/cholesky_util/chomp2_checkbacktra.f openmolcas-22.10/src/cholesky_util/chomp2_checkbacktra.f --- openmolcas-22.02/src/cholesky_util/chomp2_checkbacktra.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/chomp2_checkbacktra.f 2022-10-10 14:22:40.000000000 +0000 @@ -206,7 +206,7 @@ Else - Call Cho_dZero(Err(1,iSym),4) + Call FZero(Err(1,iSym),4) End If diff -Nru openmolcas-22.02/src/cholesky_util/chomp2_col.f openmolcas-22.10/src/cholesky_util/chomp2_col.f --- openmolcas-22.02/src/cholesky_util/chomp2_col.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/chomp2_col.f 2022-10-10 14:22:40.000000000 +0000 @@ -123,7 +123,7 @@ iSym = NowSym If (NumCho(iSym) .lt. 1) Then - Call Cho_dZero(Col,nDim*nCol) + Call FZero(Col,nDim*nCol) Return End If diff -Nru openmolcas-22.02/src/cholesky_util/chomp2_energy_fll.f openmolcas-22.10/src/cholesky_util/chomp2_energy_fll.f --- openmolcas-22.02/src/cholesky_util/chomp2_energy_fll.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/chomp2_energy_fll.f 2022-10-10 14:22:40.000000000 +0000 @@ -94,7 +94,7 @@ If (ChoAlg .eq. 2) Then ! level 3 BLAS algorithm kMabij = kXaibj ! rename pointer - Call Cho_dZero(Wrk(kMabij),LnT2am) ! initialize + Call FZero(Wrk(kMabij),LnT2am) ! initialize C Loop over Cholesky symmetries. C ------------------------------ diff -Nru openmolcas-22.02/src/cholesky_util/chomp2_energy_org.f openmolcas-22.10/src/cholesky_util/chomp2_energy_org.f --- openmolcas-22.02/src/cholesky_util/chomp2_energy_org.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/chomp2_energy_org.f 2022-10-10 14:22:40.000000000 +0000 @@ -94,7 +94,7 @@ If (jBatch.eq.iBatch .and. ChoAlg.eq.2) Then kMabij = kXaibj ! rename pointer - Call Cho_dZero(Wrk(kMabij),LnT2am) ! initialize + Call FZero(Wrk(kMabij),LnT2am) ! initialize C Loop over Cholesky vector symmetries. C ------------------------------------- diff -Nru openmolcas-22.02/src/cholesky_util/chomp2_energy_prt.f openmolcas-22.10/src/cholesky_util/chomp2_energy_prt.f --- openmolcas-22.02/src/cholesky_util/chomp2_energy_prt.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/chomp2_energy_prt.f 2022-10-10 14:22:40.000000000 +0000 @@ -34,7 +34,7 @@ If (Job .eq. 0) Then - Call Cho_dZero(CME_Time,2*2) + Call FZero(CME_Time,2*2) Write(6,'(/,4X,A,/,4X,A)') & 'Evaluation of MP2 energy correction', diff -Nru openmolcas-22.02/src/cholesky_util/chomp2_energy_srt.f openmolcas-22.10/src/cholesky_util/chomp2_energy_srt.f --- openmolcas-22.02/src/cholesky_util/chomp2_energy_srt.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/chomp2_energy_srt.f 2022-10-10 14:22:40.000000000 +0000 @@ -91,7 +91,7 @@ If (jBatch.eq.iBatch .and. ChoAlg.eq.2) Then kMabij = kXaibj ! rename pointer - Call Cho_dZero(Wrk(kMabij),LnT2am) ! initialize + Call FZero(Wrk(kMabij),LnT2am) ! initialize C Loop over Cholesky vector symmetries. C ------------------------------------- diff -Nru openmolcas-22.02/src/cholesky_util/chomp2_fno_fll.f openmolcas-22.10/src/cholesky_util/chomp2_fno_fll.f --- openmolcas-22.02/src/cholesky_util/chomp2_fno_fll.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/chomp2_fno_fll.f 2022-10-10 14:22:40.000000000 +0000 @@ -86,7 +86,7 @@ If (ChoAlg.eq.2 .and. MP2_small) Then ! level 3 BLAS algorithm kMabij = kXaibj ! rename pointer - Call Cho_dZero(Wrk(kMabij),LnT2am) ! initialize + Call FZero(Wrk(kMabij),LnT2am) ! initialize C Loop over Cholesky symmetries. C ------------------------------ @@ -277,7 +277,7 @@ ElseIf (ChoAlg .eq. 2) Then ! level 3 BLAS algorithm kMabij = kXaibj ! rename pointer - Call Cho_dZero(Wrk(kMabij),LnT2am) ! initialize + Call FZero(Wrk(kMabij),LnT2am) ! initialize C Loop over Cholesky symmetries. C ------------------------------ diff -Nru openmolcas-22.02/src/cholesky_util/chomp2_fno_org.f openmolcas-22.10/src/cholesky_util/chomp2_fno_org.f --- openmolcas-22.02/src/cholesky_util/chomp2_fno_org.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/chomp2_fno_org.f 2022-10-10 14:22:40.000000000 +0000 @@ -79,7 +79,7 @@ If (ChoAlg.eq.2) Then kMabij = kXaibj ! rename pointer - Call Cho_dZero(Wrk(kMabij),LnT2am) ! initialize + Call FZero(Wrk(kMabij),LnT2am) ! initialize C Loop over Cholesky vector symmetries. C ------------------------------------- @@ -307,7 +307,7 @@ If (ChoAlg.eq.2) Then kMabij = kXaibj ! rename pointer - Call Cho_dZero(Wrk(kMabij),LnT2am) ! initialize + Call FZero(Wrk(kMabij),LnT2am) ! initialize C Loop over Cholesky vector symmetries. C ------------------------------------- diff -Nru openmolcas-22.02/src/cholesky_util/chomp2_fno_srt.f openmolcas-22.10/src/cholesky_util/chomp2_fno_srt.f --- openmolcas-22.02/src/cholesky_util/chomp2_fno_srt.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/chomp2_fno_srt.f 2022-10-10 14:22:40.000000000 +0000 @@ -75,7 +75,7 @@ If (ChoAlg.eq.2) Then kMabij = kXaibj ! rename pointer - Call Cho_dZero(Wrk(kMabij),LnT2am) ! initialize + Call FZero(Wrk(kMabij),LnT2am) ! initialize C Loop over Cholesky vector symmetries. C ------------------------------------- @@ -301,7 +301,7 @@ If (ChoAlg.eq.2) Then kMabij = kXaibj ! rename pointer - Call Cho_dZero(Wrk(kMabij),LnT2am) ! initialize + Call FZero(Wrk(kMabij),LnT2am) ! initialize C Loop over Cholesky vector symmetries. C ------------------------------------- diff -Nru openmolcas-22.02/src/cholesky_util/chomp2g_tra_1.f openmolcas-22.10/src/cholesky_util/chomp2g_tra_1.f --- openmolcas-22.02/src/cholesky_util/chomp2g_tra_1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/chomp2g_tra_1.f 2022-10-10 14:22:40.000000000 +0000 @@ -47,7 +47,7 @@ C Initialize Diag (if needed). C ---------------------------- - If (DoDiag) Call Cho_dZero(Diag,nMoMo(iSym,iVecType)) + If (DoDiag) Call FZero(Diag,nMoMo(iSym,iVecType)) C Allocate memory for half-transformed vector. C -------------------------------------------- diff -Nru openmolcas-22.02/src/cholesky_util/chomp2g_travec.f openmolcas-22.10/src/cholesky_util/chomp2g_travec.f --- openmolcas-22.02/src/cholesky_util/chomp2g_travec.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/chomp2g_travec.f 2022-10-10 14:22:40.000000000 +0000 @@ -50,7 +50,7 @@ & nMoAo(iSyScr,iMoType1) Call ChoMP2_Quit(SecNam,'Insufficient scratch space',' ') Else - Call Cho_dZero(Scr,nMoAo(iSyScr,iMoType1)) + Call FZero(Scr,nMoAo(iSyScr,iMoType1)) End If C First half-transformation step: diff -Nru openmolcas-22.02/src/cholesky_util/chomp2_setup.f openmolcas-22.10/src/cholesky_util/chomp2_setup.f --- openmolcas-22.02/src/cholesky_util/chomp2_setup.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/chomp2_setup.f 2022-10-10 14:22:40.000000000 +0000 @@ -155,8 +155,8 @@ End Do End Do Else - Call Cho_iZero(nMatab,8) - Call Cho_iZero(iMatab,64) + Call iZero(nMatab,8) + Call iZero(iMatab,64) End If C If batching over occuped orbitals is forced by user, there better @@ -395,7 +395,7 @@ * * I am not sure if NumOcc is used somewhere else so I will * define it as before even if Im using NumInBat for setting up -* indeces in this routine. //Jonas +* indices in this routine. //Jonas Do iBatch = 1,nBatch If(.false.) Then NumBatOrb(iBatch) = Num diff -Nru openmolcas-22.02/src/cholesky_util/chomp2_tra_1.f openmolcas-22.10/src/cholesky_util/chomp2_tra_1.f --- openmolcas-22.02/src/cholesky_util/chomp2_tra_1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/chomp2_tra_1.f 2022-10-10 14:22:40.000000000 +0000 @@ -42,7 +42,7 @@ C Initialize Diag (if needed). C ---------------------------- - If (DoDiag) Call Cho_dZero(Diag,nT1am(iSym)) + If (DoDiag) Call FZero(Diag,nT1am(iSym)) C Allocate memory for half-transformed vector. C -------------------------------------------- diff -Nru openmolcas-22.02/src/cholesky_util/chomp2_travec.f openmolcas-22.10/src/cholesky_util/chomp2_travec.f --- openmolcas-22.02/src/cholesky_util/chomp2_travec.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/chomp2_travec.f 2022-10-10 14:22:40.000000000 +0000 @@ -45,7 +45,7 @@ & nT1AOT(iSyScr) Call ChoMP2_Quit(SecNam,'Insufficient scratch space',' ') Else - Call Cho_dZero(Scr,nT1AOT(iSyScr)) + Call FZero(Scr,nT1AOT(iSyScr)) End If C First half-transformation step: diff -Nru openmolcas-22.02/src/cholesky_util/cho_p_getlq.f openmolcas-22.10/src/cholesky_util/cho_p_getlq.f --- openmolcas-22.02/src/cholesky_util/cho_p_getlq.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_p_getlq.f 2022-10-10 14:22:40.000000000 +0000 @@ -42,7 +42,7 @@ If (nQSP .gt. 1) Then Call Cho_Quit('Oops! Bug detected in '//SecNam,103) End If - Call Cho_dZero(QVec,l_Qvec) + Call FZero(QVec,l_Qvec) Call Cho_p_QualSwp() Call Cho_GetLQ(QVec,l_QVec,LstQSP,nQSP) Call Cho_p_QualSwp() diff -Nru openmolcas-22.02/src/cholesky_util/cho_p_getmq.f openmolcas-22.10/src/cholesky_util/cho_p_getmq.f --- openmolcas-22.02/src/cholesky_util/cho_p_getmq.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_p_getmq.f 2022-10-10 14:22:40.000000000 +0000 @@ -30,7 +30,7 @@ If (nQSP .gt. 1) Then Call Cho_Quit('Oops! Bug detected in '//SecNam,103) End If - Call Cho_dZero(MQ,l_MQ) + Call FZero(MQ,l_MQ) Call Cho_p_QualSwp() Call Cho_GetMQ(MQ,l_MQ,LstQSP,nQSP) Call Cho_p_QualSwp() diff -Nru openmolcas-22.02/src/cholesky_util/cho_p_setlq.f openmolcas-22.10/src/cholesky_util/cho_p_setlq.f --- openmolcas-22.02/src/cholesky_util/cho_p_setlq.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_p_setlq.f 2022-10-10 14:22:40.000000000 +0000 @@ -33,8 +33,8 @@ If (.not.Cho_Real_Par) Return ! not truely parallel... - Call Cho_iZero(iQuAB_L,SIZE(iQuAB_L)) - Call Cho_iZero(iQL2G,SIZE(iQL2G)) + Call iZero(iQuAB_L,SIZE(iQuAB_L)) + Call iZero(iQL2G,SIZE(iQL2G)) Do iSym = 1,nSym nQL = 0 Do iQ = 1,nQual(iSym) diff -Nru openmolcas-22.02/src/cholesky_util/cho_p_setred_l.f openmolcas-22.10/src/cholesky_util/cho_p_setred_l.f --- openmolcas-22.02/src/cholesky_util/cho_p_setred_l.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_p_setred_l.f 2022-10-10 14:22:40.000000000 +0000 @@ -42,10 +42,10 @@ nDim = nSym*nnShl IndRed(:,2)=0 - Call Cho_iZero(iiBstRSh(:,:,2),nDim) - Call Cho_iZero(nnBstRSh(:,:,2),nDim) - Call Cho_iZero(iiBstR(:,2),nSym) - Call Cho_iZero(nnBstR(:,2),nSym) + Call iZero(iiBstRSh(:,:,2),nDim) + Call iZero(nnBstRSh(:,:,2),nDim) + Call iZero(iiBstR(:,2),nSym) + Call iZero(nnBstR(:,2),nSym) nnBstRT(2) = 0 C Set local nnBstRSh counter at location 2. diff -Nru openmolcas-22.02/src/cholesky_util/cho_p_syncdiag.f openmolcas-22.10/src/cholesky_util/cho_p_syncdiag.f --- openmolcas-22.02/src/cholesky_util/cho_p_syncdiag.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_p_syncdiag.f 2022-10-10 14:22:40.000000000 +0000 @@ -35,7 +35,7 @@ C Zero all entries in global diagonal. C ------------------------------------ - Call Cho_dZero(Diag_G,nnBstRT_G(1)) + Call FZero(Diag_G,nnBstRT_G(1)) C Copy elements from local to global diagonal. C -------------------------------------------- diff -Nru openmolcas-22.02/src/cholesky_util/cho_reoini.f openmolcas-22.10/src/cholesky_util/cho_reoini.f --- openmolcas-22.02/src/cholesky_util/cho_reoini.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_reoini.f 2022-10-10 14:22:40.000000000 +0000 @@ -19,7 +19,7 @@ MULD2H(I,J)=IEOR(I-1,J-1)+1 - CALL CHO_IZERO(NNBST,NSYM) + CALL IZERO(NNBST,NSYM) DO ISYMA = 1,NSYM DO ISYMB = 1,ISYMA-1 NABPK(ISYMA,ISYMB) = NBAS(ISYMA)*NBAS(ISYMB) diff -Nru openmolcas-22.02/src/cholesky_util/cho_reovc1.f openmolcas-22.10/src/cholesky_util/cho_reovc1.f --- openmolcas-22.02/src/cholesky_util/cho_reovc1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_reovc1.f 2022-10-10 14:22:40.000000000 +0000 @@ -99,7 +99,7 @@ C -------- KCHO2 = KREAD - CALL CHO_IZERO(IOFF,64) + CALL IZERO(IOFF,64) ICOUNT = KCHO2 - 1 DO ISYMB = 1,NSYM ISYMA = MULD2H(ISYMB,ISYM) @@ -110,7 +110,7 @@ END IF END DO - CALL CHO_DZERO(WRK(KCHO2),NNBST(ISYM)*NUMV) + CALL FZERO(WRK(KCHO2),NNBST(ISYM)*NUMV) DO IVEC = 1,NUMV KOFF1 = KCHO1 + NNBSTR(ISYM,2)*(IVEC - 1) - 1 DO IRS = 1,NNBSTR(ISYM,2) diff -Nru openmolcas-22.02/src/cholesky_util/cho_rs2rs.f openmolcas-22.10/src/cholesky_util/cho_rs2rs.f --- openmolcas-22.02/src/cholesky_util/cho_rs2rs.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_rs2rs.f 2022-10-10 14:22:40.000000000 +0000 @@ -48,7 +48,7 @@ C Set up mapping array. C --------------------- - CALL CHO_IZERO(IMAP,NNBSTR(ISYM,IRS2)) + CALL IZERO(IMAP,NNBSTR(ISYM,IRS2)) DO ISHLAB = 1,NNSHL N2 = NNBSTRSH(ISYM,ISHLAB,IRS2) N3 = NNBSTRSH(ISYM,ISHLAB,IRS3) diff -Nru openmolcas-22.02/src/cholesky_util/cho_rstof.f openmolcas-22.10/src/cholesky_util/cho_rstof.f --- openmolcas-22.02/src/cholesky_util/cho_rstof.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_rstof.f 2022-10-10 14:22:40.000000000 +0000 @@ -39,7 +39,7 @@ IF (LRDIM .NE. MMBSTRT) THEN CALL CHO_QUIT('Dimension error [2] in '//SECNAM,104) END IF - CALL CHO_IZERO(IRS2F,N*MMBSTRT) + CALL IZERO(IRS2F,N*MMBSTRT) DO ISYMA = 1,NSYM IF (NBAS(ISYMA) .GT. 0) THEN diff -Nru openmolcas-22.02/src/cholesky_util/cho_setglob.f openmolcas-22.10/src/cholesky_util/cho_setglob.f --- openmolcas-22.02/src/cholesky_util/cho_setglob.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_setglob.f 2022-10-10 14:22:40.000000000 +0000 @@ -23,10 +23,10 @@ mmBstRT_G = 0 N = 8*nLoc_G - Call Cho_iZero(iiBstR_G,N) - Call Cho_iZero(nnBstR_G,N) - Call Cho_iZero(nnBstRT_G,nLoc_G) - Call Cho_iZero(NumCho_G,8) + Call iZero(iiBstR_G,N) + Call iZero(nnBstR_G,N) + Call iZero(nnBstRT_G,nLoc_G) + Call iZero(NumCho_G,8) NumChT_G = 0 Do iSym = 1,8 diff -Nru openmolcas-22.02/src/cholesky_util/cho_setredind.f openmolcas-22.10/src/cholesky_util/cho_setredind.f --- openmolcas-22.02/src/cholesky_util/cho_setredind.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_setredind.f 2022-10-10 14:22:40.000000000 +0000 @@ -33,8 +33,8 @@ IF (NNSHL .LT. 1) THEN ! may occur in parallel runs NNBSTRT(J) = 0 - CALL CHO_IZERO(IIBSTR(1,J),NSYM) - CALL CHO_IZERO(NNBSTR(1,J),NSYM) + CALL IZERO(IIBSTR(1,J),NSYM) + CALL IZERO(NNBSTR(1,J),NSYM) RETURN END IF diff -Nru openmolcas-22.02/src/cholesky_util/cho_setsh.f openmolcas-22.10/src/cholesky_util/cho_setsh.f --- openmolcas-22.02/src/cholesky_util/cho_setsh.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_setsh.f 2022-10-10 14:22:40.000000000 +0000 @@ -19,7 +19,7 @@ INTEGER ISYM, IA, ISHL - CALL CHO_IZERO(NBASSH,NSYM*NSHELL) + CALL IZERO(NBASSH,NSYM*NSHELL) DO ISYM = 1,NSYM DO IA = 1,NBAS(ISYM) ISHL = ISOSHL(IBAS(ISYM)+IA) diff -Nru openmolcas-22.02/src/cholesky_util/cho_setshp2q_2.f openmolcas-22.10/src/cholesky_util/cho_setshp2q_2.f --- openmolcas-22.02/src/cholesky_util/cho_setshp2q_2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_setshp2q_2.f 2022-10-10 14:22:40.000000000 +0000 @@ -54,7 +54,7 @@ C ------------------------------------------------------- iShP2Q(:,1:NumAB)=0 - Call Cho_iZero(nAB,nSym) + Call iZero(nAB,nSym) Do iSym = 1,nSym Do iQ = 1,nQual(iSym) diff -Nru openmolcas-22.02/src/cholesky_util/cho_simri_z1cdia.f openmolcas-22.10/src/cholesky_util/cho_simri_z1cdia.f --- openmolcas-22.02/src/cholesky_util/cho_simri_z1cdia.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_simri_z1cdia.f 2022-10-10 14:22:40.000000000 +0000 @@ -35,7 +35,7 @@ Integer Inf_SimRI Parameter (Inf_SimRI = 0) - Call Cho_iZero(Indx,nnBstR(1,1)) + Call iZero(Indx,nnBstR(1,1)) zmx = 0.0d0 n = 0 diff -Nru openmolcas-22.02/src/cholesky_util/cho_stat.f openmolcas-22.10/src/cholesky_util/cho_stat.f --- openmolcas-22.02/src/cholesky_util/cho_stat.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_stat.f 2022-10-10 14:22:40.000000000 +0000 @@ -610,7 +610,7 @@ CALL CHO_SUBSCR_DIA(KRDVEC,NUMV,ISYM,ILOC, & SSNORM) XT = 0.0D0 - CALL CHO_DZERO(XC,NTAU) + CALL FZERO(XC,NTAU) DO ISHAB = 1,NNSHL IF (NNBSTRSH(ISYM,ISHAB,ILOC) .GT. 0) THEN DO ISHGD = ISHAB,NNSHL diff -Nru openmolcas-22.02/src/cholesky_util/cho_subscr_dia.f openmolcas-22.10/src/cholesky_util/cho_subscr_dia.f --- openmolcas-22.02/src/cholesky_util/cho_subscr_dia.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_subscr_dia.f 2022-10-10 14:22:40.000000000 +0000 @@ -47,8 +47,8 @@ C Initialize and check for early return. C -------------------------------------- - Call Cho_dZero(DSubScr,nnBstR(iSym,iLoc)) - Call Cho_dZero(DSPNm,nnShl) + Call FZero(DSubScr,nnBstR(iSym,iLoc)) + Call FZero(DSPNm,nnShl) If (nVec.lt.1 .or. nnBstR(iSym,iLoc).lt.1) return C Compute diagonal. diff -Nru openmolcas-22.02/src/cholesky_util/cho_subtr1.f openmolcas-22.10/src/cholesky_util/cho_subtr1.f --- openmolcas-22.02/src/cholesky_util/cho_subtr1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_subtr1.f 2022-10-10 14:22:40.000000000 +0000 @@ -149,8 +149,8 @@ NUMBAT = 0 XTOT = 0.0D0 XDON = 0.0D0 - CALL CHO_IZERO(IVSTAT,4) - CALL CHO_DZERO(TIMLOC,6) + CALL IZERO(IVSTAT,4) + CALL FZERO(TIMLOC,6) C Start buffer batch loop. C ------------------------ diff -Nru openmolcas-22.02/src/cholesky_util/cho_unini.f openmolcas-22.10/src/cholesky_util/cho_unini.f --- openmolcas-22.02/src/cholesky_util/cho_unini.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_unini.f 2022-10-10 14:22:40.000000000 +0000 @@ -16,7 +16,7 @@ #include "cholesky.fh" LURED = 0 - CALL CHO_IZERO(LUCHO,NSYM) + CALL IZERO(LUCHO,NSYM) LURST = 0 LUMAP = 0 diff -Nru openmolcas-22.02/src/cholesky_util/cho_vecbuf_final.f openmolcas-22.10/src/cholesky_util/cho_vecbuf_final.f --- openmolcas-22.02/src/cholesky_util/cho_vecbuf_final.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_vecbuf_final.f 2022-10-10 14:22:40.000000000 +0000 @@ -22,10 +22,10 @@ If (Allocated(CHVBUF)) Call mma_deallocate(CHVBUF) If (Allocated(CHVBFI)) Call mma_deallocate(CHVBFI) - Call Cho_iZero(ip_ChVBuf_Sym,nSym) - Call Cho_iZero(l_ChVBuf_Sym,nSym) - Call Cho_iZero(ip_ChVBFI_Sym,nSym) - Call Cho_iZero(l_ChVBFI_Sym,nSym) - Call Cho_iZero(nVec_in_Buf,nSym) + Call iZero(ip_ChVBuf_Sym,nSym) + Call iZero(l_ChVBuf_Sym,nSym) + Call iZero(ip_ChVBFI_Sym,nSym) + Call iZero(l_ChVBFI_Sym,nSym) + Call iZero(nVec_in_Buf,nSym) End diff -Nru openmolcas-22.02/src/cholesky_util/cho_vecbuf_init.f openmolcas-22.10/src/cholesky_util/cho_vecbuf_init.f --- openmolcas-22.02/src/cholesky_util/cho_vecbuf_init.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_vecbuf_init.f 2022-10-10 14:22:40.000000000 +0000 @@ -120,15 +120,15 @@ End Do If (Frac.le.0.0d0 .or. Frac.gt.1.0d0 .or. lVecTot.lt.1) Then - Call Cho_iZero(ip_ChVBuf_Sym,nSym) - Call Cho_iZero(l_ChVBuf_Sym,nSym) + Call iZero(ip_ChVBuf_Sym,nSym) + Call iZero(l_ChVBuf_Sym,nSym) Else call mma_MaxDBLE(l_Max) l_ChVBuf = INT(Frac*DBLE(l_Max)) If (l_ChVBuf.lt.nSym .or. l_ChVBuf.lt.lVecTot) Then l_ChVBuf = 0 - Call Cho_iZero(ip_ChVBuf_Sym,nSym) - Call Cho_iZero(l_ChVBuf_Sym,nSym) + Call iZero(ip_ChVBuf_Sym,nSym) + Call iZero(l_ChVBuf_Sym,nSym) Else MemEach = l_ChVBuf/nSym Enough = MemEach .gt. lVec(1) @@ -165,7 +165,7 @@ End If End If - Call Cho_iZero(nVec_in_Buf,nSym) + Call iZero(nVec_in_Buf,nSym) If (LocDbg) Then Call Cho_Word2Byte(l_ChVBuf,8,x,Unt) @@ -226,8 +226,8 @@ End If If (Frac.le.0.0d0 .or. Frac.gt.1.0d0) Then - Call Cho_iZero(l_ChvBuf_Sym,nSym) - Call Cho_iZero(ip_ChvBuf_Sym,nSym) + Call iZero(l_ChvBuf_Sym,nSym) + Call iZero(ip_ChvBuf_Sym,nSym) Else call mma_maxDBLE(l_max) Left = INT(Frac*DBLE(l_Max)) @@ -244,8 +244,8 @@ l_ChVBuf = Cho_iSumElm(l_ChVBuf_Sym,nSym) If (l_ChVBuf .lt. 1) Then l_ChVBuf = 0 - Call Cho_iZero(l_ChvBuf_Sym,nSym) - Call Cho_iZero(ip_ChvBuf_Sym,nSym) + Call iZero(l_ChvBuf_Sym,nSym) + Call iZero(ip_ChvBuf_Sym,nSym) Else Call mma_allocate(CHVBUF,l_ChVBuf,Label='CHVBUF') diff -Nru openmolcas-22.02/src/cholesky_util/cho_vecbuf_integrity.f openmolcas-22.10/src/cholesky_util/cho_vecbuf_integrity.f --- openmolcas-22.02/src/cholesky_util/cho_vecbuf_integrity.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_vecbuf_integrity.f 2022-10-10 14:22:40.000000000 +0000 @@ -91,8 +91,8 @@ Write(LuPri,'(A)') & 'Cholesky vector buffer integrity checks enabled' Else - Call Cho_iZero(l_ChVBfI_Sym,nSym) - Call Cho_iZero(ip_ChVBfI_Sym,nSym) + Call iZero(l_ChVBfI_Sym,nSym) + Call iZero(ip_ChVBfI_Sym,nSym) End If End diff -Nru openmolcas-22.02/src/cholesky_util/cho_x_checkdiag.f openmolcas-22.10/src/cholesky_util/cho_x_checkdiag.f --- openmolcas-22.02/src/cholesky_util/cho_x_checkdiag.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_x_checkdiag.f 2022-10-10 14:22:40.000000000 +0000 @@ -68,7 +68,7 @@ irc = 0 If (nnBstRT(1) .lt. 1) Then - Call Cho_dZero(Err,4) + Call FZero(Err,4) Return End If diff -Nru openmolcas-22.02/src/cholesky_util/cho_xcv_getint.f openmolcas-22.10/src/cholesky_util/cho_xcv_getint.f --- openmolcas-22.02/src/cholesky_util/cho_xcv_getint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_xcv_getint.f 2022-10-10 14:22:40.000000000 +0000 @@ -52,7 +52,7 @@ End If ! Calculate integrals - Call Cho_dZero(xInt,n) + Call FZero(xInt,n) Do iSP=1,l_ListSP Do iCD=1,l_ListCD Call Cho_MCA_CalcInt_4(xInt,n,ListCD(iCD),ListSP(iSP)) diff -Nru openmolcas-22.02/src/cholesky_util/cho_x_get_pardiag.f openmolcas-22.10/src/cholesky_util/cho_x_get_pardiag.f --- openmolcas-22.02/src/cholesky_util/cho_x_get_pardiag.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_x_get_pardiag.f 2022-10-10 14:22:40.000000000 +0000 @@ -14,7 +14,7 @@ SUBROUTINE CHO_X_GET_PARDIAG(jSym,iSO_ab) ************************************************************************ -* Returns an array of the "a" and "b" indeces that give rise to the +* Returns an array of the "a" and "b" indices that give rise to the * parent diagonal from which a given J-index has been originated * by the (molecular) Cholesky decomposition procedure * diff -Nru openmolcas-22.02/src/cholesky_util/cho_x_getvtra.f openmolcas-22.10/src/cholesky_util/cho_x_getvtra.f --- openmolcas-22.02/src/cholesky_util/cho_x_getvtra.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_x_getvtra.f 2022-10-10 14:22:40.000000000 +0000 @@ -79,15 +79,15 @@ Do jDen=kDen,nDen ChoT(jDen)%A0(:)=Zero End Do -* * -*********************************************************************** -*********************************************************************** -* * +* * +************************************************************************ +************************************************************************ +* * IF (DoRead) THEN -* * -*********************************************************************** -*********************************************************************** -* * +* * +************************************************************************ +************************************************************************ +* * JVEC1 = IVEC1 ! Absolute starting index IVEC2 = JVEC1 + NUMV - 1 ! Absolute ending index @@ -114,15 +114,15 @@ JVEC1 = jVec1 + JNUM End Do ! end the while loop -* * -*********************************************************************** -*********************************************************************** -* * +* * +************************************************************************ +************************************************************************ +* * ELSE ! only MO transformation -* * -*********************************************************************** -*********************************************************************** -* * +* * +************************************************************************ +************************************************************************ +* * JNUM = NUMV JVREF= 1 Call cho_vTra(irc,RedVec,lRedVec,JVREF,IVEC1,JNUM,NUMV,ISYM, @@ -131,15 +131,15 @@ if (irc.ne.0) then return endif -* * -*********************************************************************** -*********************************************************************** -* * +* * +************************************************************************ +************************************************************************ +* * END IF -* * -*********************************************************************** -*********************************************************************** -* * +* * +************************************************************************ +************************************************************************ +* * irc=0 RETURN diff -Nru openmolcas-22.02/src/cholesky_util/cho_x_rdrst.f openmolcas-22.10/src/cholesky_util/cho_x_rdrst.f --- openmolcas-22.02/src/cholesky_util/cho_x_rdrst.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_x_rdrst.f 2022-10-10 14:22:40.000000000 +0000 @@ -184,7 +184,7 @@ Go To 100 Else If (NumCho(iSym) .lt. 1) Then - Call Cho_iZero(InfVec(:,:,iSym),MaxVec*InfVec_N2) + Call iZero(InfVec(:,:,iSym),MaxVec*InfVec_N2) Else InfVec(:,:,iSym) = 0 Do j = 1,SIZE(InfVec,2) diff -Nru openmolcas-22.02/src/cholesky_util/cho_x_setinc.f openmolcas-22.10/src/cholesky_util/cho_x_setinc.f --- openmolcas-22.02/src/cholesky_util/cho_x_setinc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/cho_x_setinc.f 2022-10-10 14:22:40.000000000 +0000 @@ -59,9 +59,9 @@ C choorb.fh. C ----------- - Call Cho_iZero(iBas,8) - Call Cho_iZero(nBas,8) - Call Cho_iZero(XnBas,8) + Call iZero(iBas,8) + Call iZero(nBas,8) + Call iZero(XnBas,8) nBasT = 0 C cholesky.fh. @@ -105,9 +105,9 @@ HaltIt = .false. Trace_Idle = .false. - Call Cho_iZero(LuCho,8) - Call Cho_iZero(LuSel,8) - Call Cho_iZero(LuTmp,8) + Call iZero(LuCho,8) + Call iZero(LuSel,8) + Call iZero(LuTmp,8) LuPri = 0 LuScr = 0 LuRed = 0 @@ -119,17 +119,17 @@ nnShl = 0 MxORSh = 0 Mx2Sh = 0 - Call Cho_iZero(iiBstR,8*3) - Call Cho_iZero(nnBstR,8*3) - Call Cho_iZero(nnBstRT,3) + Call iZero(iiBstR,8*3) + Call iZero(nnBstR,8*3) + Call iZero(nnBstRT,3) mmBstRT = 0 nQual_L(:)=0 - Call Cho_iZero(iOffQ,8) + Call iZero(iOffQ,8) - Call Cho_dZero(DiaMax,8) - Call Cho_dZero(DiaMaxT,8) - Call Cho_dZero(DiaMin,8) - Call Cho_dZero(Damp,2) + Call FZero(DiaMax,8) + Call FZero(DiaMaxT,8) + Call FZero(DiaMin,8) + Call FZero(Damp,2) Span = Large XlDiag = Large DiaMnZ = Large @@ -137,7 +137,7 @@ iABMnZ = -iLarge nnZTot = 0 - Call Cho_iZero(NumCho,8) + Call iZero(NumCho,8) NumChT = 0 MaxVec = 0 MaxRed = 0 @@ -150,11 +150,11 @@ ShAB = -iLarge ShCD = -iLarge nColAB = -iLarge - Call Cho_iZero(iOff_Col,8) + Call iZero(iOff_Col,8) XThrCom = Large XThrDiag = Large - Call Cho_dZero(XDamp,2) + Call FZero(XDamp,2) XSpan = Large XThrNeg = Large XWarNeg = Large @@ -166,15 +166,15 @@ XScDiag = .false. XCho_AdrVec = -iLarge - Call Cho_iZero(iChkQ,4*(nChkQ+1)) + Call iZero(iChkQ,4*(nChkQ+1)) nCol_Chk = -iLarge - Call Cho_dZero(TimSec,4*nSection) - Call Cho_dZero(tInteg,2*nInteg) - Call Cho_dZero(tDecom,2*nDecom) - Call Cho_dZero(tMisc,2*nMisc) - Call Cho_dZero(tDecDrv,2) + Call FZero(TimSec,4*nSection) + Call FZero(tInteg,2*nInteg) + Call FZero(tDecom,2*nDecom) + Call FZero(tMisc,2*nMisc) + Call FZero(tDecDrv,2) - Call Cho_iZero(nVecRS1,8) + Call iZero(nVecRS1,8) Cho_AdrVec= -iLarge Cho_IOVec = -iLarge @@ -201,11 +201,11 @@ C chovecbuf.f90. C -------------- - Call Cho_iZero(ip_ChVBuf_Sym,8) - Call Cho_iZero(l_ChVBuf_Sym,8) - Call Cho_iZero(ip_ChVBfI_Sym,8) - Call Cho_iZero(l_ChVBfI_Sym,8) - Call Cho_iZero(nVec_in_Buf,8) + Call iZero(ip_ChVBuf_Sym,8) + Call iZero(l_ChVBuf_Sym,8) + Call iZero(ip_ChVBfI_Sym,8) + Call iZero(l_ChVBfI_Sym,8) + Call iZero(nVec_in_Buf,8) C chosubscr.fh. C -------------- @@ -219,7 +219,7 @@ C chpari.fh. C ----------- - Call Cho_iZero(NumCho_Bak,8) + Call iZero(NumCho_Bak,8) C cho_para_info.fh. C ------------------ diff -Nru openmolcas-22.02/src/cholesky_util/integral_wrout_cho_diag.f openmolcas-22.10/src/cholesky_util/integral_wrout_cho_diag.f --- openmolcas-22.02/src/cholesky_util/integral_wrout_cho_diag.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/integral_wrout_cho_diag.f 2022-10-10 14:22:40.000000000 +0000 @@ -9,26 +9,20 @@ * LICENSE or in . * ************************************************************************ SubRoutine Integral_WrOut_Cho_diag( - & iCmp,iShell,MapOrg, - & iBas,jBas,kBas,lBas,kOp, - & Shijij,IJeqKL,iAO,iAOst,ijkl, - & AOInt,SOInt,nSOint, - & iSOSym,nSkal,nSOs, - & TInt,nTInt,itOffs,nSym) +#define _FIXED_FORMAT_ +#define _CALLING_ +#include "int_wrout_interface.fh" + & ) * calls the proper routines IndSft/PLF * if IntOrd_jikl==.TRUE. integral order within symblk: jikl * else integral order within symblk: ijkl Implicit Real*8 (A-H,O-Z) * - Real*8 AOInt(*), SOInt(*), TInt(nTInt) - Integer iCmp(4), iShell(4), iAO(4), - & iAOst(4), kOp(4), iSOSym(2,nSOs), - & itOffs(0:nSym-1,0:nSym-1,0:nSym-1), MapOrg(4) - Logical Shijij,IJeqKL +#include "int_wrout_interface.fh" * * call sorting routine * - If (nSym.eq.1) Then + If (mSym.eq.1) Then Call PLF_Cho_Diag(TInt,nTInt, & AOInt,ijkl,iCmp(1),iCmp(2),iCmp(3),iCmp(4), & iShell,iAO,iAOst,Shijij.and.IJeqKL, diff -Nru openmolcas-22.02/src/cholesky_util/integral_wrout_cho.f openmolcas-22.10/src/cholesky_util/integral_wrout_cho.f --- openmolcas-22.02/src/cholesky_util/integral_wrout_cho.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cholesky_util/integral_wrout_cho.f 2022-10-10 14:22:40.000000000 +0000 @@ -9,12 +9,10 @@ * LICENSE or in . * ************************************************************************ SubRoutine Integral_WrOut_Cho( - & iCmp,iShell,MapOrg, - & iBas,jBas,kBas,lBas,kOp, - & Shijij,IJeqKL,iAO,iAOst,ijkl, - & AOInt,SOInt,nSOint, - & iSOSym,nSkal,nSOs, - & TInt,nTInt,itOffs,mSym) +#define _FIXED_FORMAT_ +#define _CALLING_ +#include "int_wrout_interface.fh" + & ) * calls the proper routines IndSft/PLF * if IntOrd_jikl==.TRUE. integral order within symblk: jikl * else integral order within symblk: ijkl @@ -25,11 +23,7 @@ Character*18 SecNam Parameter (SecNam = 'Integral_WrOut_Cho') * - Real*8 AOInt(*), SOInt(*), TInt(nTInt) - Integer iCmp(4), iShell(4), iAO(4), - & iAOst(4), kOp(4), iSOSym(2,nSOs), - & itOffs(0:mSym-1,0:mSym-1,0:mSym-1), MapOrg(4) - Logical Shijij,IJeqKL +#include "int_wrout_interface.fh" * * call sorting routine * diff -Nru openmolcas-22.02/src/cht3/barf.f openmolcas-22.10/src/cht3/barf.f --- openmolcas-22.02/src/cht3/barf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/barf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,15 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine barf(a) - character*(*) a - write(6,*) a - call abend - end diff -Nru openmolcas-22.02/src/cht3/block_interf.f openmolcas-22.10/src/cht3/block_interf.f --- openmolcas-22.02/src/cht3/block_interf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/block_interf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,105 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine block_interf( - & ind1f,ind1l, - & ind2f,ind2l, - & b1f,b1l,nind_b1f,nind_b1l, - & b2f,b2l,nind_b2f,nind_b2l) -c -c this routine do : -c -c Interface between Palo and Juzek virtual orbitals blocking structure -c -c ind1f,ind1l,ind2f,ind2l - first and last absolute of the VO indexes of interess -c -c b1f,b1l - first and last Palo's block which contain ind1 -c b2f,b2l - first and last Palo's block which contain ind2 -c -c nind_b1f - sum of VOs in blocks 1,2, ..., b1f-1 -c nind_b2f - sum of VOs in blocks 1,2, ..., b2f-1 -c -c nind_b1l - # of VOs in b1f before ind1 -c nind_b2l - # of VOs in b2f before ind2 -c - implicit none -#include "cht3_ccsd1.fh" -#include "cht3_reord.fh" -#include "ccsd_t3compat.fh" -c - integer i,sum - integer ind1f,ind1l,ind2f,ind2l - integer b1f,b2f,b1l,b2l - integer nind_b1f,nind_b2f,nind_b1l,nind_b2l - logical found1,found2,found3,found4 -c -c set b1f, b2f, b1l, b2l -c - sum=0 - found1=.false. - found2=.false. - found3=.false. - found4=.false. -c - do i=1,NvGrp - sum=sum+DimGrpaR(i) -c - if ((ind1f.le.sum).and.(.not.found1)) then - b1f=i - found1=.true. - end if -c - if ((ind1l.le.sum).and.(.not.found2)) then - b1l=i - found2=.true. - end if -c - if ((ind2f.le.sum).and.(.not.found3)) then - b2f=i - found3=.true. - end if -c - if ((ind2l.le.sum).and.(.not.found4)) then - b2l=i - found4=.true. - end if -c - end do -c -cmp write (*,*) 'b1f, b1l, b2f, b2l ',b1f,b1l,b2f,b2l -c -c set nind_b1f, nind_b1l -c - if (b1f.gt.1) then - sum=0 - do i=1,b1f-1 - sum=sum+DimGrpaR(i) - end do - nind_b1f=sum - else - nind_b1f=0 - end if - nind_b1l=ind1f-nind_b1f-1 -c -c set nind_b1f, nind_b1l -c - if (b2f.gt.1) then - sum=0 - do i=1,b2f-1 - sum=sum+DimGrpaR(i) - end do - nind_b2f=sum - else - nind_b2f=0 - end if - nind_b2l=ind2f-nind_b2f-1 -c - return - end diff -Nru openmolcas-22.02/src/cht3/block_interf.F90 openmolcas-22.10/src/cht3/block_interf.F90 --- openmolcas-22.02/src/cht3/block_interf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/block_interf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,100 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine block_interf(ind1f,ind1l,ind2f,ind2l,b1f,b1l,nind_b1f,nind_b1l,b2f,b2l,nind_b2f,nind_b2l) +! this routine does: +! +! Interface between Palo and Juzek virtual orbitals blocking structure +! +! ind1f,ind1l,ind2f,ind2l - first and last absolute of the VO indices of interest +! +! b1f,b1l - first and last Palo's block which contain ind1 +! b2f,b2l - first and last Palo's block which contain ind2 +! +! nind_b1f - sum of VOs in blocks 1,2, ..., b1f-1 +! nind_b2f - sum of VOs in blocks 1,2, ..., b2f-1 +! +! nind_b1l - # of VOs in b1f before ind1 +! nind_b2l - # of VOs in b2f before ind2 + +use ChT3_global, only: DimGrpaR, NvGrp +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: ind1f, ind1l, ind2f, ind2l +integer(kind=iwp), intent(out) :: b1f, b1l, nind_b1f, nind_b1l, b2f, b2l, nind_b2f, nind_b2l +integer(kind=iwp) :: i, isum +logical(kind=iwp) :: found1, found2, found3, found4 + +! set b1f, b2f, b1l, b2l + +isum = 0 +found1 = .false. +found2 = .false. +found3 = .false. +found4 = .false. + +do i=1,NvGrp + isum = isum+DimGrpaR(i) + + if ((ind1f <= isum) .and. (.not. found1)) then + b1f = i + found1 = .true. + end if + + if ((ind1l <= isum) .and. (.not. found2)) then + b1l = i + found2 = .true. + end if + + if ((ind2f <= isum) .and. (.not. found3)) then + b2f = i + found3 = .true. + end if + + if ((ind2l <= isum) .and. (.not. found4)) then + b2l = i + found4 = .true. + end if + +end do + +!mp write(u6,*) 'b1f, b1l, b2f, b2l ',b1f,b1l,b2f,b2l + +! set nind_b1f, nind_b1l + +if (b1f > 1) then + isum = 0 + do i=1,b1f-1 + isum = isum+DimGrpaR(i) + end do + nind_b1f = isum +else + nind_b1f = 0 +end if +nind_b1l = ind1f-nind_b1f-1 + +! set nind_b1f, nind_b1l + +if (b2f > 1) then + isum = 0 + do i=1,b2f-1 + isum = isum+DimGrpaR(i) + end do + nind_b2f = isum +else + nind_b2f = 0 +end if +nind_b2l = ind2f-nind_b2f-1 + +return + +end subroutine block_interf diff -Nru openmolcas-22.02/src/cht3/calc_mp2.f openmolcas-22.10/src/cht3/calc_mp2.f --- openmolcas-22.02/src/cht3/calc_mp2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/calc_mp2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,46 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine calc_MP2 (w,e,no,nv) -c -c this is primitive checking routine to calculate 2nd order energy -c - implicit none - integer i,j,a,b,no,nv - real*8 e(1:(no+nv)),w(1:nv,1:no,1:nv,1:no) - real*8 e2,integral,denom -c - e2=0.0d0 -c - do j=1,no - do i=1,no - do b=1,nv - do a=1,nv -c - denom=e(no+a)+e(no+b)-e(i)-e(j) -cmp! write (6,'(4(i3,2x),A,3(f17.10,2x))') a,i,b,j,'w1, w2, denom ', -cmp! & w(a,i,b,j),w(a,j,b,i),denom - - integral=(-1.0d0)*w(a,i,b,j)*(2.0d0*w(a,i,b,j)+ - & (-1.0d0)*w(a,j,b,i)) - -c! write (6,*) integral - - e2=e2+(integral/denom) -c - end do - end do - end do - end do -c - write (6,*) 'Druhy rad je asi = ',e2 -c - return - end diff -Nru openmolcas-22.02/src/cht3/calc_mp2.F90 openmolcas-22.10/src/cht3/calc_mp2.F90 --- openmolcas-22.02/src/cht3/calc_mp2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/calc_mp2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,49 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine calc_MP2(w,e,no,nv) +! this is primitive checking routine to calculate 2nd order energy + +use Constants, only: Zero, Two +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: no, nv +real(kind=wp), intent(in) :: w(nv,no,nv,no), e(no+nv) +integer(kind=iwp) :: a, b, i, j +real(kind=wp) :: denom, e2, integral + +e2 = Zero + +do j=1,no + do i=1,no + do b=1,nv + do a=1,nv + + denom = e(no+a)+e(no+b)-e(i)-e(j) + !mp write(u6,'(4(i3,2x),A,3(f17.10,2x))') a,i,b,j,'w1, w2, denom ',w(a,i,b,j),w(a,j,b,i),denom + + integral = -Two*w(a,i,b,j)**2-w(a,j,b,i) + + !write(u6,*) integral + + e2 = e2+integral/denom + + end do + end do + end do +end do + +write(u6,*) 'Druhy rad je asi = ',e2 + +return + +end subroutine calc_MP2 diff -Nru openmolcas-22.02/src/cht3/ccsd_t3compat.fh openmolcas-22.10/src/cht3/ccsd_t3compat.fh --- openmolcas-22.02/src/cht3/ccsd_t3compat.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/ccsd_t3compat.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,20 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - integer NvGrp,maxdim,LunAux - common /ccsd_t3compat/ NvGrp,maxdim,LunAux - - integer MaxNod - parameter (maxNod=512) - -cmp! local number of Cholesky vectors on each node - - integer NChLoc(0:(maxnod-1)) - common /par2_cht3/ NChLoc diff -Nru openmolcas-22.02/src/cht3/check_create_klvab_t3_mem.f openmolcas-22.10/src/cht3/check_create_klvab_t3_mem.f --- openmolcas-22.02/src/cht3/check_create_klvab_t3_mem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/check_create_klvab_t3_mem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,113 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine check_create_klvab_t3_mem (vblock) -c -c this routine finds the upper estimate of the memory -c requirements of the most demanding step in create_klvab_t3 -c - implicit none -c -#include "cht3_ccsd1.fh" -#include "ccsd_t3compat.fh" - integer vblock,vblock_my - integer mem,mem_trial,mem_avail -c -c.0 - calculate vblock_my -c - call my_block (vblock,vblock_my) -c - if (printkey.ge.10) then - write (6,*) - write (6,*) 'check_create_klvab_t3_mem ' - write (6,*) - write (6,'(A,3(i5,1x))') 'nc,no,nv',nc,no,nv - write (6,'(A,3(i5,1x))') 'maxdim,vblock,vblock_my', - & maxdim,vblock,vblock_my - end if -c -c.1 !create - mem=vblock*vblock*(no+nv)+ - & nv*((nv*(nv+1))/2)+nv*nv+nc*maxdim+nc*maxdim*maxdim+ - & max(nc*maxdim*maxdim,nc*no*maxdim,maxdim*maxdim*maxdim) -c.2 !klvaa_vvvo - mem_trial=vblock*vblock*(no+nv)+ - & (nv*(nv*(nv+1))/2)+nv*nv+vblock_my*vblock_my*no*no+ - & 2*maxdim*maxdim*no*no -c - if (mem_trial.gt.mem) mem=mem_trial -c.3 !create - mem_trial=vblock*vblock*(no+nv)+ - & (nv*(nv*(nv+1))/2)+nv*nv+vblock_my*vblock_my*no*no+ - & 2*maxdim*maxdim*no*no -c - if (mem_trial.gt.mem) mem=mem_trial -c.4 !create - mem_trial=no*no*vblock*(no+nv)+ - & no*nv*(no*(no+1)/2)+vblock*no*no+nc*(no*(no+1)/2)+ - & nc*no*nv+max(nc*((no*(no+1))/2),nc*no*maxdim,nc*no*nv) -c - if (mem_trial.gt.mem) mem=mem_trial -c.5 !create - mem_trial=no*no*vblock*(no+nv)+ - & no*nv*(no*(no+1)/2)+vblock*no*no+nv*vblock_my*no*no+ - & 2*maxdim*maxdim*no*no -c - if (mem_trial.gt.mem) mem=mem_trial -c.6 !klvaa_oovo - mem_trial=no*no*vblock*(no+nv)+ - & no*nv*(no*(no+1)/2)+vblock*no*no+ - & nv*vblock_my*(((no-1)*no)/2)+2*maxdim*maxdim*no*no -c - if (mem_trial.gt.mem) mem=mem_trial -c.7 !klvaa_oovo - mem_trial=(((no-1)*no)/2)*vblock*vblock+ - & vblock_my*vblock_my*no*no+nc*no*maxdim+ - & 2*max(nc*no*maxdim,maxdim*maxdim*no*no) -c - if (mem_trial.gt.mem) mem=mem_trial -c.8 !klvaa_oovo - mem_trial=no*no*vblock*vblock+ - & vblock_my*vblock_my*no*no+nc*no*maxdim+ - & 2*max(nc*no*maxdim,maxdim*maxdim*no*no) -c - if (mem_trial.gt.mem) mem=mem_trial -c - if (printkey.ge.10) then - write (6,*) - write (6,'(A,f10.1,A,f7.1,A,f3.1,A)') - & 'Memory required for the reorg. step = ', - & (8.0d0*mem)/(1024),' kb ', - & (8.0d0*mem)/(1024*1024),' Mb ', - & (8.0d0*mem)/(1024*1024*1024),' Gb ' - end if -c -c - calculate available free memory -c - Call GetMem('(T)','Max','Real',mem_avail,mem_avail) -c - if (printkey.ge.10) then - write (6,'(A,f10.1,A,f7.1,A,f3.1,A)') - & 'Available memory = ', - & (8.0d0*mem_avail)/(1024),' kb ', - & (8.0d0*mem_avail)/(1024*1024),' Mb ', - & (8.0d0*mem_avail)/(1024*1024*1024),' Gb ' - write (6,*) - end if -c -c - check, if mem fits -c - if (mem_avail.lt.mem) then - write (6,*) 'Not enough memory for the transformation step ' - call Abend() - end if -c - return - end diff -Nru openmolcas-22.02/src/cht3/check_create_klvab_t3_mem.F90 openmolcas-22.10/src/cht3/check_create_klvab_t3_mem.F90 --- openmolcas-22.02/src/cht3/check_create_klvab_t3_mem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/check_create_klvab_t3_mem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,95 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine check_create_klvab_t3_mem(vblock) +! this routine finds the upper estimate of the memory +! requirements of the most demanding step in create_klvab_t3 + +use ChT3_global, only: maxdim, nc, no, nv, printkey +use Index_Functions, only: nTri_Elem +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: vblock +integer(kind=iwp) :: mem, mem_avail, mem_trial, vblock_my +real(kind=wp), parameter :: kb = 1024.0_wp + +!.0 - calculate vblock_my + +call my_block(vblock,vblock_my) + +if (printkey >= 10) then + write(u6,*) + write(u6,*) 'check_create_klvab_t3_mem ' + write(u6,*) + write(u6,'(A,3(i5,1x))') 'nc,no,nv',nc,no,nv + write(u6,'(A,3(i5,1x))') 'maxdim,vblock,vblock_my',maxdim,vblock,vblock_my +end if + +!.1 !create +mem = vblock*vblock*(no+nv)+nv*nTri_Elem(nv)+nv*nv+nc*maxdim+nc*maxdim*maxdim+ & + max(nc*maxdim*maxdim,nc*no*maxdim,maxdim*maxdim*maxdim) +!.2 !klvaa_vvvo +mem_trial = vblock*vblock*(no+nv)+nv*nTri_Elem(nv)+nv*nv+vblock_my*vblock_my*no*no+2*maxdim*maxdim*no*no + +if (mem_trial > mem) mem = mem_trial +!.3 !create +mem_trial = vblock*vblock*(no+nv)+nv*nTri_Elem(nv)+nv*nv+vblock_my*vblock_my*no*no+2*maxdim*maxdim*no*no + +if (mem_trial > mem) mem = mem_trial +!.4 !create +mem_trial = no*no*vblock*(no+nv)+no*nv*nTri_Elem(no)+vblock*no*no+nc*nTri_Elem(no)+nc*no*nv+ & + max(nc*nTri_Elem(no),nc*no*maxdim,nc*no*nv) + +if (mem_trial > mem) mem = mem_trial +!.5 !create +mem_trial = no*no*vblock*(no+nv)+no*nv*nTri_Elem(no)+vblock*no*no+nv*vblock_my*no*no+2*maxdim*maxdim*no*no + +if (mem_trial > mem) mem = mem_trial +!.6 !klvaa_oovo +mem_trial = no*no*vblock*(no+nv)+no*nv*nTri_Elem(no)+vblock*no*no+nv*vblock_my*nTri_Elem(no-1)+2*maxdim*maxdim*no*no + +if (mem_trial > mem) mem = mem_trial +!.7 !klvaa_oovo +mem_trial = nTri_Elem(no-1)*vblock*vblock+vblock_my*vblock_my*no*no+nc*no*maxdim+2*max(nc*no*maxdim,maxdim*maxdim*no*no) + +if (mem_trial > mem) mem = mem_trial +!.8 !klvaa_oovo +mem_trial = no*no*vblock*vblock+vblock_my*vblock_my*no*no+nc*no*maxdim+2*max(nc*no*maxdim,maxdim*maxdim*no*no) + +if (mem_trial > mem) mem = mem_trial + +if (printkey >= 10) then + write(u6,*) + write(u6,'(A,f10.1,A,f7.1,A,f3.1,A)') 'Memory required for the reorg. step = ',real(8*mem,kind=wp)/kb,' kb ', & + real(8*mem,kind=wp)/kb**2,' Mb ',real(8*mem,kind=wp)/kb**3,' Gb' +end if + +! - calculate available free memory + +call mma_maxDBLE(mem_avail) + +if (printkey >= 10) then + write(u6,'(A,f10.1,A,f7.1,A,f3.1,A)') 'Available memory = ',real(8*mem_avail,kind=wp)/kb,' kb ', & + real(8*mem_avail,kind=wp)/kb**2,' Mb ',real(8*mem_avail,kind=wp)/kb**3,' Gb' + write(u6,*) +end if + +! - check, if mem fits + +if (mem_avail < mem) then + write(u6,*) 'Not enough memory for the transformation step ' + call Abend() +end if + +return + +end subroutine check_create_klvab_t3_mem diff -Nru openmolcas-22.02/src/cht3/check_loops.f openmolcas-22.10/src/cht3/check_loops.f --- openmolcas-22.02/src/cht3/check_loops.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/check_loops.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine check_loops(nv,vblock,nla,nlb) -c - integer nv,vblock,nla,nlb - integer nuga,nga,ngb,ngc - - nuga=nv/vblock -cmp! pridavok - if((nuga*vblock).lt.nv)nuga=nuga+1 -c - nla=0 - do nga=1,nuga - do ngb=1,nga - do ngc=1,ngb - nla=nla+1 - end do - end do - end do -c - nlb=0 - do nga=1,nuga - do ngb=1,nga - do ngc=1,nuga - nlb=nlb+1 - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/check_loops.F90 openmolcas-22.10/src/cht3/check_loops.F90 --- openmolcas-22.02/src/cht3/check_loops.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/check_loops.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,45 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine check_loops(nv,vblock,nla,nlb) + +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: nv, vblock +integer(kind=iwp), intent(out) :: nla, nlb +integer(kind=iwp) :: nga, ngb, ngc, nuga + +nuga = nv/vblock +!mp! pridavok +if ((nuga*vblock) < nv) nuga = nuga+1 + +nla = 0 +do nga=1,nuga + do ngb=1,nga + do ngc=1,ngb + nla = nla+1 + end do + end do +end do + +nlb = 0 +do nga=1,nuga + do ngb=1,nga + do ngc=1,nuga + nlb = nlb+1 + end do + end do +end do + +return + +end subroutine check_loops diff -Nru openmolcas-22.02/src/cht3/check_mat.f openmolcas-22.10/src/cht3/check_mat.f --- openmolcas-22.02/src/cht3/check_mat.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/check_mat.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,26 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine check_mat(mat,dima,dimb) -c - implicit none - integer dima,dimb,i,j - real*8 mat(dima,dimb) -c - do i=1,dima - do j=1,dimb - if (abs(mat(i,j)).gt.10000) then - write (6,*) 'i,j,mat(i,j) ',i,j,mat(i,j) - end if - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/check_mat.F90 openmolcas-22.10/src/cht3/check_mat.F90 --- openmolcas-22.02/src/cht3/check_mat.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/check_mat.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,29 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine check_mat(mat,dima,dimb) + +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: dima, dimb +real(kind=wp), intent(in) :: mat(dima,dimb) +integer(kind=iwp) :: i, j + +do i=1,dima + do j=1,dimb + if (abs(mat(i,j)) > 1.0e5_wp) write(u6,*) 'i,j,mat(i,j) ',i,j,mat(i,j) + end do +end do + +return + +end subroutine check_mat diff -Nru openmolcas-22.02/src/cht3/cht3_casy.fh openmolcas-22.10/src/cht3/cht3_casy.fh --- openmolcas-22.02/src/cht3/cht3_casy.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/cht3_casy.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - -cmp -c include na timingy -c -c TWall, TCpu - pomocne -c TWall0, TCpu0 - zaciatocne hodnoty -c TWall_l, TCpu_l - lokalne hodnoty -c -cmp - REAL*8 TWall,TCpu - REAL*8 TWall0,TCpu0 - REAL*8 TWall_l,TCpu_l - - common /cht3_casujakhusaklasu/ TWall,TCpu, - & TWall0,TCpu0,TWall_l,TCpu_l diff -Nru openmolcas-22.02/src/cht3/cht3_ccsd1.fh openmolcas-22.10/src/cht3/cht3_ccsd1.fh --- openmolcas-22.02/src/cht3/cht3_ccsd1.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/cht3_ccsd1.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,66 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -c -c0 Basic constants for CCSD procedure -c -c0 maximal # of Groups, SubGroups - integer maxGrp,maxSGrp - parameter (maxGrp=32) - parameter (maxSGrp=64) -c -c -c1 Basic parameters for CCSD procedure -c -c no - # of occupied orbitals -c nv - # of virtual orbitals -c nc - # of Cholesky vectors -c nfr- # if frozen orbitals -c -c mhkey - FTN/BLAS switch -c maxiter - Maximal number of iterations -c restkey - key for restart [1/0] -c generkey - key for generation of integrals from L vectors [1/0] -c - integer no,nv,nc,nfr - integer mhkey - integer maxiter - integer restkey - integer generkey - real*8 conv -c - logical gen_files,run_triples - integer t3_starta,t3_stopa,t3_startb,t3_stopb - - integer printkey -c - common /cht3_ccsd1/ no,nv,nc,nfr,mhkey,maxiter,restkey,generkey, - & conv,gen_files,run_triples, - & t3_starta,t3_stopa,t3_startb,t3_stopb, - & printkey -c -c -c2 Possition of Permanent arrays -c -c Fock matrix - PossFoo,PossFvv,PossFvo -c Orbital energies - PossOE -c T1 amplitudes, old, new - PossT1o,PossT1n -c N2 Intermediates for T1 - PossHoo,PossHvv,PossHvo -c N2 Intermediates for T2 - PossGoo,PossGvv -c O2OO Intermediate A - PossA - @@ na zamyslenie, ci nie cez worky -c Possition of Free space - PossFree -c - integer PossFoo,PossFvv,PossFvo,PossOE,PossT1o,PossT1n - integer PossHoo,PossHvv,PossHvo,PossGoo,PossGvv,PossA,PossFree -c - common /cht3_ccsd2/ PossFoo,PossFvv,PossFvo,PossOE,PossT1o, - c PossT1n,PossHoo,PossHvv,PossHvo,PossGoo,PossGvv, - c PossA,PossFree -c diff -Nru openmolcas-22.02/src/cht3/cht3.f openmolcas-22.10/src/cht3/cht3.f --- openmolcas-22.02/src/cht3/cht3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/cht3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,190 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine cht3(ireturn) -c -c main driver for (T) -c - implicit none -c -#include "cht3_casy.fh" -#include "cht3_ccsd1.fh" -#include "files.fh" -#include "cht3_reord.fh" -#include "WrkSpc.fh" - integer ireturn -c DIRCC -cmp! include 'memvir_inc' -#include "ccsd_t3compat.fh" -c - integer wrksize - integer maxspace -c - integer isize - integer iOE,ioeh,ioep -c integer itmp,iW2,il1_1,ioff -c - integer i,nOrbE,nBas(8),nOrb(8) - character*24 Label - logical Found -cmp -cmp -cmp -c vynuluj hodiny - Call CWTime(TCpu,TWall) - TCpu0=TCpu - TWall0=TWall - TCpu_l=TCpu - TCpu_l=TCpu - TWall_l=TWall - TWall_l=TWall -cmp -c.0 read input -c - call IniReord_t3 (NvGrp,wrksize) -c -c.0.1 generate name convention for blocked integrals and T2 files -c - call DefParReord_t3 (NvGrp,maxdim) - if (printkey.ge.10) then - write (6,*) 'Maxdim of virtual segment from CCSD = ', - & maxdim - end if -c -c.0.2 def commons for DIRCC -c - call defcommon (nfr,no,nv) -c -c.2.2 regenerate integrals from the Cholesky vectors (L1) L1(m,I ,A'') -c -c.2.2.1 (vo|vo) for testing purpose -c -c isize=nc*no*nv -c! write (6,*) 'size for l1_1 ',isize -c! write (6,*) 'size for l1_2 ',isize -c Call GetMem('cht3_l1_1','Allo','Real',il1_1,isize) -c Call GetMem('cht3_itmp','Allo','Real',itmp,isize) -c isize=nv*nv*no*no -c! write (6,*) 'size for W2 ',isize -c Call GetMem('cht3_W2','Allo','Real',iW2,isize) -c call gen_vvoo(Work(iW2),Work(il1_1),Work(itmp)) -c -c.2.2.2 get orbital energies - -c -c* Get Oorital energies -c - call Get_iArray('nBas',nBas,1) - call Get_iArray('nOrb',nOrb,1) - - isize=nBas(1) - - if (printkey.ge.10) then - write (6,*) 'Allocating memory for (tmp) OE files', - & isize - end if - - call GetMem('cht3_oe','Allo','Real',iOE,isize) -c - Label='OrbE' - Call qpg_dArray(Label,Found,nOrbE) - if (nOrbE.ne.nBas(1)) then - write (6,*) 'Warning! in cht3 : (nOrbE.ne.nBas)!' - end if - If(.not.Found .or. nOrbE.eq.0) Then - Call SysAbendMsg('get_orbe','Did not find:',Label) - End If - if (printkey.ge.10) then - write (6,*) 'isize = ',isize - write (6,*) 'norbe = ',norbe - end if - call Get_dArray(Label,Work(iOE),nOrbE) -c -c write out the orbital energies -c - if (printkey.ge.10) then - write (6,*) - write (6,*) 'Orbital energies for nfr+no+nv' - write (6,*) - do i=1,nfr+no+nv - write (6,'(A,2x,i5,2x,f18.10)') 'Orbital Energy ', - & i,Work(iOE+i-1) - end do - end if - -c2.2.3 make OEH, OEP -c - isize=2*no - call GetMem('cht3_oeh','Allo','Real',ioeh,isize) - isize=2*nv - call GetMem('cht3_oeh','Allo','Real',ioep,isize) -c - call generate_juzekOE (Work(ioe+nfr), - & Work(ioeh),Work(ioep),no,nv) -c -c.2.3 Checkpoint. Calculate MP2 energy -c -c call calc_MP2 (Work(iW2),Work(iOE+nfr),no,nv) -c call abend() -c -c.3 start (T) calculation -c - call GetMem('(T)','Max','Real',maxspace,maxspace) -c - write (6,*) - write (6,'(A,i13,A,f9.1,A,f5.1,A)') - & ' Memory available for (T) calc = ', - & (maxspace-1),' in r*8 Words', - & ((maxspace-1)*8.0d0)/(1024*1024),' Mb', - & ((maxspace-1)*8.0d0)/(1024*1024*1024),' Gb' -c -cmp call GetMem('t3_ampl_bti','Allo','Real',ioff,1) -cmp ioff=ioff+1 -cmp! write (6,*) 'ioe = ',ioe -cmp! write (6,*) 'ioeh = ',ioeh -cmp! write (6,*) 'ioep = ',ioep -cmp write (6,*) 'ioff volny = ',ioff -cmp! kvir1=ioff+1 -cmp! kvir2=kvir1+(maxspace-1)-1 -c -c toto sa da vyhodit a nahradit iba natvrdo definovanim kvir -cmp call adapt_mem(Work(1),Work(ioff),(maxspace-1), -cmp & kvir1,kvir2) -c -c! call alloc_vm(WORK, maxspace, KVIR1, KVIR2) -c -cmp write (6,*) ' kvir1 = ',kvir1 -cmp write (6,*) ' kvir2 = ',kvir2 -c -cmp call T3AMPL_BTI(Work(ioff),Work(ioeh),Work(ioep)) - - call T3AMPL_BTI(Work(ioeh),Work(ioep)) -c -c.2.4 Free the unnecessary memory -c -cmp isize=nfr+no+nv -cmp isize=nOrb(1) - isize=nBas(1) - call GetMem('cht3_oeh','Free','Real',iOE,isize) -c - isize=2*no - call GetMem('cht3_oeh','Free','Real',ioeh,isize) - isize=2*nv - call GetMem('cht3_oeh','Free','Real',ioep,isize) -cmp ioff=ioff-1 -cmp call GetMem('t3_ampl_bti','Free','Real',ioff,1) - -c! call GetMem('t3_ampl_bti','Free','Real',ioff,maxspace) -c - !Call EndGlb - - ireturn = 0 - return - end diff -Nru openmolcas-22.02/src/cht3/cht3.F90 openmolcas-22.10/src/cht3/cht3.F90 --- openmolcas-22.02/src/cht3/cht3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/cht3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,158 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine cht3(ireturn) +! main driver for (T) + +use ChT3_global, only: DimGrpaR, L1Name, L2Name, maxdim, nfr, no, nv, NvGrp, printkey, T2Name, TCpu, TCpu_l, TCpu0, TWall, & + TWall_l, TWall0 +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(out) :: ireturn +integer(kind=iwp) :: i, maxspace, nBas(8), nOrb(8), nOrbE +character(len=24) :: Label +logical(kind=iwp) :: Found +real(kind=wp), allocatable :: OE(:), oeh(:), oep(:) +real(kind=wp), parameter :: kb = 1024.0_wp + +!mp +! vynuluj hodiny +call CWTime(TCpu,TWall) +TCpu0 = TCpu +TWall0 = TWall +TCpu_l = TCpu +TWall_l = TWall +!mp +!.0 read input + +call IniReord_t3(NvGrp) + +!.0.1 generate name convention for blocked integrals and T2 files + +call DefParReord_t3(NvGrp,maxdim) +if (printkey >= 10) write(u6,*) 'Maxdim of virtual segment from CCSD = ',maxdim + +!.0.2 def commons for DIRCC + +call defcommon(no,nv) + +!.2.2 regenerate integrals from the Cholesky vectors (L1) L1(m,I ,A'') + +!.2.2.1 (vo|vo) for testing purpose + +!isize = nc*no*nv +!!write(u6,*) 'size for l1_1 ',isize +!!write(u6,*) 'size for l1_2 ',isize +!call mma_allocate(l1_1,isize,label='cht3_l1_1') +!call mma_allocate(tmp,isize,label='cht3_itmp') +!isize = nv*nv*no*no +!!write(u6,*) 'size for W2 ',isize +!call mma_allocate(W2,isize,label='cht3_W2') +!call gen_vvoo(W2,l1_1,tmp) + +!.2.2.2 get orbital energies + +! Get Orbital energies + +call Get_iArray('nBas',nBas,1) +call Get_iArray('nOrb',nOrb,1) + +if (printkey >= 10) write(u6,*) 'Allocating memory for (tmp) OE files',nBas(1) + +call mma_allocate(OE,nBas(1),label='cht3_oe') + +Label = 'OrbE' +call qpg_dArray(Label,Found,nOrbE) +if (nOrbE /= nBas(1)) write(u6,*) 'Warning! in cht3 : (nOrbE /= nBas)!' +if ((.not. Found) .or. (nOrbE == 0)) call SysAbendMsg('get_orbe','Did not find:',Label) +if (printkey >= 10) then + write(u6,*) 'nbas(1) = ',nBas(1) + write(u6,*) 'norbe = ',norbe +end if +call Get_dArray(Label,OE,nOrbE) + +! write out the orbital energies + +if (printkey >= 10) then + write(u6,*) + write(u6,*) 'Orbital energies for nfr+no+nv' + write(u6,*) + do i=1,nfr+no+nv + write(u6,'(A,2x,i5,2x,f18.10)') 'Orbital Energy ',i,OE(i) + end do +end if + +!2.2.3 make OEH, OEP + +call mma_allocate(oeh,2*no,label='cht3_oeh') +call mma_allocate(oep,2*nv,label='cht3_oep') + +call generate_juzekOE(OE(nfr+1),oeh,oep,no,nv) + +!.2.3 Checkpoint. Calculate MP2 energy + +!call calc_MP2(W2,OE(nfr+1),no,nv) +!call abend() + +!.3 start (T) calculation + +call mma_maxDBLE(maxspace) + +write(u6,*) +write(u6,'(A,i13,A,f9.1,A,f5.1,A)') ' Memory available for (T) calc = ',maxspace-1,' in r*8 Words', & + real((maxspace-1)*8,kind=wp)/kb**2,' Mb',real((maxspace-1)*8,kind=wp)/kb**3,' Gb' + +!mp call GetMem('t3_ampl_bti','Allo','Real',ioff,1) +!mp ioff = ioff+1 +!mp !write(u6,*) 'ioe = ',ioe +!mp !write(u6,*) 'ioeh = ',ioeh +!mp !write(u6,*) 'ioep = ',ioep +!mp write(u6,*) 'ioff volny = ',ioff +!mp kvir1 = ioff+1 +!mp !kvir2 = kvir1+(maxspace-1)-1 + +! toto sa da vyhodit a nahradit iba natvrdo definovanim kvir +!mp call adapt_mem(Work(1),Work(ioff),(maxspace-1),kvir1,kvir2) + +!!call alloc_vm(WORK,maxspace,KVIR1,KVIR2) + +!mp write(u6,*) ' kvir1 = ',kvir1 +!mp write(u6,*) ' kvir2 = ',kvir2 + +!mp call T3AMPL_BTI(Work(ioff),oeh,oep) + +call T3AMPL_BTI(oeh,oep) + +!.2.4 Free the unnecessary memory + +!mp isize = nfr+no+nv +!mp isize = nOrb(1) +call mma_deallocate(OE) + +call mma_deallocate(oeh) +call mma_deallocate(oep) +!mp ioff = ioff-1 +!mp call GetMem('t3_ampl_bti','Free','Real',ioff,1) + +call mma_deallocate(DimGrpaR) +call mma_deallocate(L1Name) +call mma_deallocate(L2Name) +call mma_deallocate(T2Name) + +!Call EndGlb() + +ireturn = 0 + +return + +end subroutine cht3 diff -Nru openmolcas-22.02/src/cht3/cht3_global.F90 openmolcas-22.10/src/cht3/cht3_global.F90 --- openmolcas-22.02/src/cht3/cht3_global.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/cht3_global.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,46 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +module ChT3_global + +! no - # of occupied orbitals +! nv - # of virtual orbitals +! nc - # of Cholesky vectors +! nfr - # if frozen orbitals +! DimGrpaR - Dimensions of group (a,b) for routines evaluating o3v3 contributions +! [LT][12]Name - Names of all used files +! TWall, TCpu - pomocne +! TWall0, TCpu0 - zaciatocne hodnoty +! TWall_l, TCpu_l - lokalne hodnoty + +! NBLOCK is used for direct-access unformatted I/O via multi_*. +! Count a record size in real(wp) words. Should be 2**k. + +use Definitions, only: wp, iwp + +implicit none +private + +integer(kind=iwp), parameter :: nblock = 2**11 +character, parameter :: ICH(3) = ['A','B','C'] + +integer(kind=iwp) :: IOPT(2), IT, LunAux, maxdim, nc, nfr, NNOAB(3), NNUAB(3), no, NOAB(2), NUAB(2), nv, NvGrp, printkey, & + t3_starta, t3_startb, t3_stopa, t3_stopb +real(kind=wp) :: TCpu, TCpu_l, TCpu0, TWall, TWall_l, TWall0 +logical(kind=iwp) :: gen_files, run_triples +integer(kind=iwp), allocatable :: DimGrpaR(:) +character(len=6), allocatable :: L1Name(:), L2Name(:,:), T2Name(:,:) + +public :: DimGrpaR, gen_files, ICH, IOPT, IT, L1Name, L2Name, LunAux, maxdim, nblock, nc, nfr, NNOAB, NNUAB, no, NOAB, NUAB, nv, & + NvGrp, printkey, run_triples, T2Name, t3_starta, t3_startb, t3_stopa, t3_stopb, TCpu, TCpu_l, TCpu0, TWall, TWall_l, & + TWall0 + +end module ChT3_global diff -Nru openmolcas-22.02/src/cht3/cht3_procedures.F90 openmolcas-22.10/src/cht3/cht3_procedures.F90 --- openmolcas-22.02/src/cht3/cht3_procedures.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/cht3_procedures.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,25 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! This module contains procedures that need an interface +module ChT3_procedures + +implicit none +private + +public :: klvaa_oovo + +contains + +#define _IN_MODULE_ +#include "klvaa_oovo.F90" + +end module ChT3_procedures diff -Nru openmolcas-22.02/src/cht3/cht3_rea.f openmolcas-22.10/src/cht3/cht3_rea.f --- openmolcas-22.02/src/cht3/cht3_rea.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/cht3_rea.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine cht3_rea (lun,length,A) -c -c nacitane bloku dat -c - implicit none - integer lun,length - real*8 A(1:length) -c - read (lun) A -c - return - end diff -Nru openmolcas-22.02/src/cht3/cht3_reord.fh openmolcas-22.10/src/cht3/cht3_reord.fh --- openmolcas-22.02/src/cht3/cht3_reord.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/cht3_reord.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -c -c include for routines evaluating o3v3 contributions -c -c1.1 maximal # of Groups - in cht3_ccsd1.fh -c -c1.2 Dimensions of groups (a,b) - integer DimGrpaR(1:maxGrp) -c - common /cht3_reord1/ DimGrpaR -c -c -c diff -Nru openmolcas-22.02/src/cht3/CMakeLists.txt openmolcas-22.10/src/cht3/CMakeLists.txt --- openmolcas-22.02/src/cht3/CMakeLists.txt 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -9,4 +9,70 @@ # LICENSE or in . * #*********************************************************************** +set (sources + block_interf.F90 + calc_mp2.F90 + check_create_klvab_t3_mem.F90 + check_loops.F90 + check_mat.F90 + cht3.F90 + cht3_global.F90 + cht3_procedures.F90 + create_klvab_t3.F90 + decomp2ind.F90 + defcommon.F90 + defparreord_t3.F90 + delf.F90 + ex23.F90 + exmap3_231.F90 + expa1_uhf.F90 + expa2_uhf.F90 + expand4_12.F90 + ext_o_32.F90 + gather_t2anti_blocked.F90 + gather_t2_blocked.F90 + gather_t2.F90 + gather_t2_fblocked.F90 + generate_juzekoe.F90 + gen_oovo.F90 + gen_vvoo_blocked.F90 + gen_vvoo.F90 + gen_vvvo.F90 + getrest_t3.F90 + getx_t3.F90 + grow_l1.F90 + grow_l2.F90 + grow_t2anti_blocked1.F90 + grow_t2anti_blocked2.F90 + grow_t2_blocked.F90 + grow_t2_fblocked1.F90 + grow_t2_fblocked2.F90 + grow_t2neq.F90 + grow_vvoo_blocked.F90 + grow_vvoo.F90 + grow_w3.F90 + inireord_t3.F90 + klvaa_vvv.F90 + main.F90 + map2_21_t3.F90 + map3_132_t3.F90 + map3_231_t3.F90 + map3_321_t3.F90 + map4_3412_t3.F90 + multi_opendir.F90 + multi_readir.F90 + multi_wridir.F90 + my_block.F90 + t3ampl_bti.F90 + t3_bta_aac.F90 + t3_bt_aaa.F90 + t3_bta_abc.F90 + t3_bt_aac.F90 + t3_bt_abc.F90 + t3_bt_acc.F90 + t3loopa.F90 + t3loopb.F90 + v_size_t3.F90 +) + include (${PROJECT_SOURCE_DIR}/cmake/prog_template.cmake) diff -Nru openmolcas-22.02/src/cht3/comp2ind.f openmolcas-22.10/src/cht3/comp2ind.f --- openmolcas-22.02/src/cht3/comp2ind.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/comp2ind.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,102 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine comp2ind(W,IDM,no) - implicit none - real*8 W,DD - integer IDM,no, IJ,I,IJO,II,K,L,KL,LK, NF, J, JIO - dimension W(IDM,*) -cmp! include 'pvtrace_inc.f' -cmp! include 'pvtrace_inc' -cmp! if (LLtrace) then -cmp! write(6,*) 'Entering COMP2IND' -cmp! call xflush(6) -cmp! endif -C -C comprises the back square to triangle (r,s,p,>t)>>> (r,s,pt) -C remains in the same array! -C -C Fixed DCOPY for no=2 to avoid overlap in input and output fields -C with impredictable behavior on pwr4/ESSL. PV, 12 aug 2004. -C -c write(6,*)'comp2ind:',IDM,no -c check -c do I=1,no -c do J=1,I -c IJ=(I-1)*no+J -c JI=(J-1)*no+I -c DD1=DDOT_(IDM,W(1,IJ),1,W(1,IJ),1) -c DD2=DDOT_(IDM,W(1,JI),1,W(1,JI),1) -c if(abs(DD1-DD2).GT.1D-10)write(6,*)'warning' -c write(6,*)dd1,dd2 -c enddo -c enddo - IJ=2 - do I=2,no - IJO=(I-1)*no+1 -C CALL DCOPY_(IDM*I,W(1,IJO),1,W(1,IJ),1) - if (no.eq.2) then - CALL DCOPY_(IDM,W(1,3),1,W(1,2),1) - CALL DCOPY_(IDM,W(1,4),1,W(1,3),1) - else - CALL DCOPY_(IDM*I,W(1,IJO),1,W(1,IJ),1) - endif - IJ=IJ+I - enddo -cmp! if (LLtrace) then -cmp! write(6,*) 'Leaving COMP2IND' -cmp! call xflush(6) -cmp! endif - return - - entry decomp2ind(W,IDM,no,NF) -cmp! if (LLtrace) then -cmp! write(6,*) 'Entering DECOMP2IND' -cmp! call xflush(6) -cmp! endif -C -C symmetrizes the upper index -C -C write(6,*)'decomp2ind:',IDM,no,NF - DO I=1,no - II=I*(I+1)/2 - DO K=2,NF - DO L=1,K-1 - KL=(K-1)*NF+L - LK=(L-1)*NF+K - DD=0.5d0*(W(KL,II)+W(LK,II)) - W(KL,II)=DD - W(LK,II)=DD - enddo - enddo - enddo - IF(NO.GT.2)THEN - DO I=NO,2,-1 - IJ=I*(I-1)/2+1 - IJO=(I-1)*no+1 - CALL DCOPY_(IDM*I,W(1,IJ),1,W(1,IJO),1) - enddo - ELSEIF(NO.EQ.2)THEN - CALL DCOPY_(IDM,W(1,3),1,W(1,4),1) - CALL DCOPY_(IDM,W(1,2),1,W(1,3),1) - endif - DO I=2,no - DO J=1,I-1 - IJO=(I-1)*no+J - JIO=(J-1)*no+I - call transm(W(1,IJO),W(1,JIO),NF,NF) - enddo - enddo -c stop -cmp! if (LLtrace) then -cmp! write(6,*) 'Leaving DECOMP2IND' -cmp! call xflush(6) -cmp! endif - end diff -Nru openmolcas-22.02/src/cht3/create_klvab_t3.f openmolcas-22.10/src/cht3/create_klvab_t3.f --- openmolcas-22.02/src/cht3/create_klvab_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/create_klvab_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,703 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE create_klvab_t3(vblock) -cmp SUBROUTINE create_klvab_t3(G,vblock) -C -C creates K(alpha-beta,alpha-beta),K(beta-alpha,alpha-beta) -C DA files KMATBA and KMATAB, LMATBA and LMATAB -C creates L(alpha-beta,alpha-beta),K(beta-alpha,alpha-beta) -C max G at this place -C both matrices have to be available at a time (unfortunately) -C -C parallelization irrelevant at the moment -C implemented integer offsets, PV, 14 may 2004. -C - IMPLICIT NONE -#include "ndisk.fh" -#include "dupfiles.fh" -cmp -#include "cht3_ccsd1.fh" -#include "ccsd_t3compat.fh" -#include "WrkSpc.fh" -cmpn -#include "cht3_reord.fh" - integer i_blk,j_blk,b2_chk - integer ngaf,ngal,ngbf,ngbl - integer nind_ngbf,nind_ngbl,nind_ngaf,nind_ngal - integer length,length1,length2 - integer it_exp,RAD_tmp - integer a_tmp,b1_tmp,j_tmp - integer nga,ngb -cmp -cmpn integer AADT_tmp,it -c integer jjj -cmp -cmpn -cmp real*8 G(*),ddot_ -c real*8 ddot_ -cmp integer it,ix,ig,iscr, KADT, IJS, RAD, AADT, IADR - integer ix,ig,iscr, IJS, RAD, AADT, IADR - integer isp,is2,ias,vblock,n,i,j,k,lu,iasblock,ias_aa - INTEGER A,A1,A2,B1,NSTEP,ISTEP - CHARACTER FN*6 - INTEGER NNU,IUHF,NNO,ISPA - integer adim, last,last_aa,nug -c integer bdim -#include "uhf.fh" -#include "ioind.fh" -cmp - integer itmp,il1_1,il2_1,il0,il1,it2_tmp,itmp2 - logical switch -cmp - if (printkey.ge.10) then - write (6,*) - write (6,*) '------ DimGrpaR ------' - write (6,'(8(i5,2x))') (DimGrpaR(a_tmp),a_tmp=1,NvGrp) - write (6,*) - end if -c -c - calculate overall memory requirements -c - call check_create_klvab_t3_mem (vblock) -c -cmp call w_rescope(G,'G create KL') -cmp call w_free(g,0,'G klvab ') - N=noab(1)+nuab(1) -c NNRED=NOAB(1)*(NOAB(1)+1)/2 - IUHF=0 - IF(IOPT(76).NE.0)THEN - IUHF=1 -c NNRED=NNOAB(3) - ENDIF - LU=98 - -cmp call w_alloc(it,NNOAB(3)*NNUAB(3),'IT klvab ') -cmp call w_alloc(ix,vblock*vblock*n,'IX klvab ') -cmpn call GetMem('create_it','Allo','Real',it, -cmpn & NNOAB(3)*NNUAB(3)) - call GetMem('c1_ix','Allo','Real',ix, - & vblock*vblock*n) -cmp! -c! FN(1:6)='T2OLDC' -c! CALL GET3DM(FN,G(it),NNUAB(3),NNRED,0) -cmp! - -cmp call w_alloc(it2_tmp,maxdim*maxdim*no*no,'ITMP klvab ') -cmp call w_alloc(itmp,maxdim*maxdim*no*no,'ITMP klvab ') -cmpn call GetMem('create_it2_tmp','Allo','Real',it2_tmp, -cmpn & maxdim*maxdim*no*no) -cmpn call GetMem('create_itmp','Allo','Real',itmp, -cmpn & maxdim*maxdim*no*no) -c -cmp call gather_t2(G(it),G(it2_tmp),G(itmp)) -cmpn call gather_t2(Work(it),Work(it2_tmp),Work(itmp)) -c -c -cmp call w_free(G(it2_tmp),0,'ITMP klvab ') -cmpn call GetMem('create_itmp','Free','Real',itmp, -cmpn & maxdim*maxdim*no*no) -cmpn call GetMem('create_it2_tmp','Free','Real',it2_tmp, -cmpn & maxdim*maxdim*no*no) - -cmpn write (6,*) 'T2 regenerated from MOLCAS' -cmpn write (6,*) -c -cmp call dscal_(NNUAB(3)*NNRED,-1.d0,G(it),1) -cmp call dscal_(NNUAB(3)*NNOAB(3),-1.d0,G(it),1) -cmpn call dscal_(NNUAB(3)*NNOAB(3),-1.d0,Work(it),1) -cmp IF(IUHF.EQ.0) call decomp2ind(G(it),NNUAB(3),noab(1),NUAB(1)) - !!write(6,*)ddot_(nnoab(3)*nnuab(3),G(it),1,G(it),1) -c -C number of blocks written in a single multiwrite -C - iasblock=vblock*vblock*N/nblock - if((iasblock*nblock).lt.(vblock*vblock*N))iasblock=iasblock+1 -C - do isp=1,IUHF+1 - is2=3-isp - FN(1:4)='KMAT' - FN(6:6)=ich(isp) - FN(5:5)=ich(3-isp) - Write (6,*) 'FN,LU=',FN,LU - call multi_opendir(FN,LU) - ndup=ndup+1 - if (ndup.gt.ndupmx) - $ call barf('create_klvab_t3 -- ndupmx exceeded') - !!write(6,*) FN, isp,ndup - dupfil(ndup)=FN - if(IUHF.eq.0)then - FN(6:6)=ich(isp) - FN(5:5)=ich(isp) - call multi_opendir(FN,LU+1) - !!ndup=ndup+1 - if (ndup.gt.ndupmx) - $ call barf('create_klvab_t3 -- ndupmx exceeded') - !!write(6,*) FN, isp,ndup+1 - dupfil(ndup+1)=FN - endif -C currently using 3-dim (big field) - will be replaced after changing -C stepiv and the rest - nnu=(nuab(is2)*(nuab(is2)+1))/2 -cmp call w_alloc(ig,(nuab(isp)*nnu),'IG klvab') -cmp call w_alloc(iscr,nuab(is2)*nuab(is2),'IG iscr') -cmp - call GetMem('c1_ig','Allo','Real',ig, - & nuab(isp)*nnu) - call GetMem('c1_iscr','Allo','Real',iscr, - & nuab(is2)*nuab(is2)) -cmp - IAS=1 - IAS_AA=1 -c - DO K=1,noab(isp) -!! IF(IUHF.EQ.1)THEN -!! KADT=(K-1)*NNUAB(3)*(NOAB(2)*(2-ISP)+ISP-1) -!! ELSE -!! KADT=0 -!! ENDIF - -cmp! FN(1:5)='VVVAI' -cmp! FN(6:6)=ICH(ISP) -cmp! CALL GET3DM(FN,G(IG),NNU,NUAB(ISP),K) - if (printkey.gt.1) then - write (6,*) 'Regenerating VVVo integrals for o = ',K - end if -cmp -cmp call w_alloc(il1_1,nc*maxdim,'IL1_1 iscr') -cmp call w_alloc(il2_1,nc*maxdim*maxdim,'IL2_1 iscr') -cmp call w_alloc(itmp, -cmp & max(nc*maxdim*maxdim,nc*no*maxdim,maxdim*maxdim*maxdim), -cmp & 'ITMP iscr') -cmp - call GetMem('cc_il1_1','Allo','Real',il1_1, - & nc*maxdim) - call GetMem('cc_il2_1','Allo','Real',il2_1, - & nc*maxdim*maxdim) - call GetMem('cc_itmp','Allo','Real',itmp, - & max(nc*maxdim*maxdim,nc*no*maxdim,maxdim*maxdim*maxdim)) -cmp -cmp call gen_vvvo(K,G(IG),G(il1_1),G(il2_1),G(itmp)) - call gen_vvvo(K,Work(IG), - & Work(il1_1),Work(il2_1),Work(itmp)) -cmp write(6,*) ddot_(nnu*nuab(isp),G(ig),1,G(ig),1) -cmp call zeroma (G(ig),1,NNU*NUAB(ISP)) -c -cmp call w_free(G(il1_1),0,'IL1_1 iscr') - call GetMem('cc_itmp','Free','Real',itmp, - & max(nc*maxdim*maxdim,nc*no*maxdim,maxdim*maxdim*maxdim)) - call GetMem('cc_il2_1','Free','Real',il2_1, - & nc*maxdim*maxdim) - call GetMem('cc_il1_1','Free','Real',il1_1, - & nc*maxdim) -cmp - call delf(FN,K,K) - if(iuhf.eq.0) - $call klvaa_vvv(ix,ig,iscr,vblock,N,nug, - $LU+1,last_aa,iasblock,K,ias_aa) -cmpn $call klvaa_vvv(ix,it,ig,iscr,vblock,N,nug, -cmpn $LU+1,last_aa,iasblock,K,ias_aa) -cmp $call klvaa_vvv(G,ix,it,ig,iscr,vblock,N,nug, -cmp $LU+1,last_aa,iasblock,K,ias_aa) -c - -!! call xflush(6) -C (c>d|AK) - -cmpn - nga=0 -cmpn - DO A1=1,NUAB(ISP),vblock - A2=A1+min(vblock,nuab(isp)-A1+1)-1 - adim=A2-A1+1 - nga=nga+1 - ngb=0 - do B1=1,NUAB(IS2),vblock - ngb=ngb+1 - NSTEP=min(vblock,nuab(is2)-B1+1) -!! bdim=NSTEP - IJS=(A1-1)*NNU+IG -cmpn -cmpn write (6,*) -cmpn write (6,*) '=================================' -cmpn write (6,*) ' nga, ngb',nga,ngb -cmpn write (6,*) '=================================' -cmpn write (6,*) -c -c - check the largest b2 -c -cmpn b2_chk=b1-1+vblock - b2_chk=b1-1+min(vblock,nuab(is2)-B1+1) -c -c - find out which T2 blocked files will be needed -c for particular nga, ngb -c -cmpn write (6,'(A,4(i5,2x))') 'a1,a2,b1,b2_chk = ',a1,a2,b1,b2_chk -c - switch=.false. - if (nga.lt.ngb) then -cmpn write (6,*) 'switching nga, ngb',ngb,nga - switch=.true. -c - call block_interf(b1,b2_chk,a1,a2, - & ngaf,ngal,nind_ngaf,nind_ngal, - & ngbf,ngbl,nind_ngbf,nind_ngbl) -c - else -c - call block_interf(a1,a2,b1,b2_chk, - & ngaf,ngal,nind_ngaf,nind_ngal, - & ngbf,ngbl,nind_ngbf,nind_ngbl) -c - end if -c -cmpn write (6,'(A,4(i5,2x))') 'ngaf, ngal, nind_ngaf, nind_ngal', -cmpn & ngaf,ngal,nind_ngaf,nind_ngal -cmpn write (6,'(A,4(i5,2x))') 'ngbf, ngbl, nind_ngbf, nind_ngbl', -cmpn & ngbf,ngbl,nind_ngbf,nind_ngbl -c -c - read amplitudes from T2_ngaf_ngbf ... T2_ngaf_ngbl, nga>=ngb -c .... .... -c T2ngal_ngbf ... T2_ngal_ngbl, nga>=ngb -c -c - calculate memory requirements (consider squared T2(a',a')) -c - length1=0 - do i_blk=ngaf,ngal - length1=length1+DimGrpaR(i_blk) - end do -c - length2=0 - do j_blk=ngbf,ngbl - length2=length2+DimGrpaR(j_blk) - end do -c -cmpn write (6,*) 'length1, vblock = ',length1,vblock -cmpn write (6,*) 'length2, vblock = ',length2,vblock -c - length=length1*length2*no*no -cmpn write (6,*) 'length for blocked T2 amplitudes = ',length -c -c - setup memory -c -cmpn write (6,*) 'allocating t2_exp = ',length - call GetMem('it2_exp','Allo','Real',it_exp,length) -c -c - read pertinent files and store them in the new blocked structure -c - call GetMem('cd_it2tmp','Allo','Real',it2_tmp, - & maxdim*maxdim*no*no) - call GetMem('cd_itmp','Allo','Real',itmp, - & maxdim*maxdim*no*no) -c - call gather_t2_blocked(length1,length2, - & ngaf,ngal,ngbf,ngbl, - & Work(it_exp),Work(it2_tmp),Work(itmp), - & switch) -c - call GetMem('cd_itmp','Free','Real',itmp, - & maxdim*maxdim*no*no) - call GetMem('cd_it2tmp','Free','Real',it2_tmp, - & maxdim*maxdim*no*no) - - call dscal_(length,-1.d0,Work(it_exp),1) -c - do A=A1,A2 -cmp CALL EXPA1_UHF(G(IJS),1,NUAB(IS2),1,G(ISCR)) - CALL EXPA1_UHF(Work(IJS),1,NUAB(IS2),1,Work(ISCR)) - IJS=IJS+NNU -C Gix -!! not needed B2=B1+min(ng,nuab(is2)-B1+1))-1 -cmpn - if (nga.lt.ngb) then - a_tmp=a-nind_ngbf - b1_tmp=b1-nind_ngaf - else - a_tmp=a-nind_ngaf - b1_tmp=b1-nind_ngbf - end if -cmp write (6,'(A,2(i5,2x),A,i5,2x)') 'b1, a ,i,k = ',b1,a, -cmp & ' i',k -C mv T2(B,A,I,K) >> G(ix) -cmpn - DO I=1,NOAB(IS2) - ISPA=ISP - !!IF(IUHF.EQ.1)THEN - !! IADT=(I-1)*NNUAB(3)*(NOAB(2)*(2-IS2)+IS2-1) - !!ELSE - !! IADT=(MAX(K,I)-1)*(MAX(K,I))/2+MIN(K,I) - !! IADT=(IADT-1)*NNUAB(3) - !! IF(K.LT.I)ISPA=IS2 - !!ENDIF -cmpn BADT=(2-ISPA)*B1+(ISPA-1)*(B1-1)*NUAB(2) -cmpn!!! -cmpn AADT_tmp=IADT+KADT+BADT+A*(ISPA-1) -cmpn $ +(2-ISPA)*(A-1)*NUAB(2)+IT-1 -cmpn!!! -C T2 for isp=1 T2 for isp=2 -!! RAD=(I-1)*vblock*vblock+(A-A1)*vblock+IX - RAD=(I-1)*adim*nstep+(A-A1)*nstep +IX - ISTEP=(ISPA-1)*NUAB(2)+2-ISPA -cmpn - if (nga.ge.ngb) then ! nga> ngb - -cmp write (6,'(A,4(i5,2x),3x,i5)') '(I) a_tmp,b1_tmp,k,i nstep = ', -cmp & a_tmp,b1_tmp,k,i,nstep -c T2(B,A,I,K) =? T2(A,B1,K,I) - do j_tmp=0,NSTEP-1 ! istep je 1 ak dobre tusim -c - AADT=(I-1)*length1*length2*NOAB(2)+(K-1)*length1*length2+ - & (b1_tmp-1+j_tmp)*length1+a_tmp+it_exp-1 -c - RAD_tmp=RAD+j_tmp -c - Work(RAD_tmp)=Work(AADT) -cmp -cmpn if (abs(Work(AADT)-Work(AADT_tmp+j_tmp)). -cmpn & gt.0.00001d0) then -cmpn write (*,*) 'halohaha 1',AADT,AADT_tmp+j_tmp, -cmpn & Work(AADT),Work(AADT_tmp+j_tmp) -cmpn stop -cmpn end if -cmp - end do -c - else ! nga < ngb -c -cmp write (6,'(A,4(i5,2x),3x,i5)') '(II) b1_tmp,a_tmp,k,i nstep = ', -cmp & b1_tmp,a_tmp,i,k,nstep -c T2(B,A,I,K) - do j_tmp=0,NSTEP-1 ! istep je 1 ak dobre tusim -c -cmp AADT=(k-1)*length1*length2*NOAB(2)+(i-1)*length1*length2+ -cmp! AADT=(i-1)*length1*length2*NOAB(2)+(k-1)*length1*length2+ - AADT=(K-1)*length1*length2*NOAB(2)+(I-1)*length1*length2+ - & (a_tmp-1)*length1+b1_tmp+j_tmp+it_exp-1 -c - RAD_tmp=RAD+j_tmp -c - Work(RAD_tmp)=Work(AADT) -cmp -cmpn if (abs(Work(AADT)-Work(AADT_tmp+j_tmp)). -cmpn & gt.0.00001d0) then -cmpn write (*,*) 'halohaha 2',AADT,AADT_tmp+j_tmp, -cmpn & Work(AADT),Work(AADT_tmp+j_tmp) -cmpn stop -cmpn end if -cmp -c - end do - end if -c -cmpn call dcopy_(NSTEP,Work(AADT),ISTEP,Work(RAD),1) -cmpn - enddo ! I - RAD=noab(is2)*adim*nstep+(A-A1)*nstep+IX - DO IADR=ISCR+B1-1,ISCR+NUAB(IS2)*NUAB(IS2)-1, - $ NUAB(IS2) -cmp call dcopy_(NSTEP,G(IADR),1,G(RAD),1) - call dcopy_(NSTEP,Work(IADR),1,Work(RAD),1) - RAD = RAD+adim*nstep - enddo ! IADR - enddo ! A - !!write(6,'(A,4I5,4x,D15.10)') - !!$'block-w: K,a1,b1,IAS,ddot',K,a1,b1,ias, - !!$ ddot_(N*vblock*vblock,G(IX),1,G(IX),1) -cmp call multi_wridir(G(IX),N*vblock*vblock,LU,IAS,last) - -cmp -cmp!! do jjj=0,N*vblock*vblock-1 -cmp!! if (abs(Work(ix+jjj)).gt.10000) then -cmp!! write (6,*) 'prasa 1 ',jjj,Work(ix+jjj) -cmp!! stop -cmp!! end if -cmp!! end do -cmp - call multi_wridir(Work(IX),N*vblock*vblock, - & LU,IAS,last) - !!write (6,*) 'N*vblock*vblock,LU,last ', - !!& N*vblock*vblock,LU,last - ias=ias+iasblock -cmp - call GetMem('it2_exp','Free','Real',it_exp,length) -cmp - enddo ! B1 - enddo ! A1 - enddo ! K - if (printkey.gt.1) then - write (6,*) 'VVVo integrals regenerated from MOLCAS' - write (6,*) - end if -cmp - close (LU) - dupblk(ndup)=last - if(IUHF.EQ.0)then - close(LU+1) - ndup=ndup+1 - dupblk(ndup)=last_aa - endif -! write(6,*) FN, isp, IAS -cmp call w_memchk('IG klvab ') -cmp call w_free(g(ig),0,'IG klvab ') -cmp - call GetMem('c1_iscr','Free','Real',iscr, - & nuab(is2)*nuab(is2)) - call GetMem('c1_ig','Free','Real',ig, - & nuab(isp)*nnu) -cmp - enddo ! ISP - -cmp call dscal_(NNUAB(3)*NNOAB(3),-1.d0,G(it),1) -cmpn call dscal_(NNUAB(3)*NNOAB(3),-1.d0,Work(it),1) -cmp?? - call GetMem('c1_ix','Free','Real',ix, - & vblock*vblock*n) -cmp?? - do isp=1,IUHF+1 -cmp call w_memchk('IX klvab ') -cmp call w_free(g(ix),0,'IX klvab ') -cmp - is2=3-isp - iasblock=nnoab(3)*vblock*N/nblock - if((iasblock*nblock).lt.(nnoab(3)*vblock*N))iasblock=iasblock+1 - FN(1:4)='LMAT' - FN(5:5)=ich(3-isp) - FN(6:6)=ich(isp) - call multi_opendir(FN,LU) - ndup=ndup+1 - if (ndup.gt.ndupmx) - $ call barf('create_klvab_t3 -- ndupmx exceeded') -! write(6,*) FN, isp,ndup - dupfil(ndup)=FN -C - FN(1:5)='OOVAI' - FN(6:6)=ICH(ISP) -cmp call w_alloc(ix,noab(isp)*noab(IS2)*vblock*n,'IX klvabo ') - call GetMem('c2_ix','Allo','Real',ix, - & noab(isp)*noab(IS2)*vblock*n) - nno=noab(is2)*(noab(is2)+1)/2 -cmp call w_alloc(ig,noab(isp)*nuab(isp)*nno,'IG klvabo') -cmp call w_alloc(iscr,vblock*noab(IS2)*noab(IS2),'ISCRo klvabo ') - call GetMem('c2_ig','Allo','Real',ig, - & noab(isp)*nuab(isp)*nno) - call GetMem('c2_iscr','Allo','Real',iscr, - & vblock*noab(IS2)*noab(IS2)) -cmp -cmp! CALL GET3DM(FN,G(ig),NNO,NUAB(ISP)*NOAB(ISP),0) -cmp -cmp call w_alloc(il0,nc*nno,'IL0 klvabo') -cmp call w_alloc(il1,nc*no*nv,'IL1 klvabo') -cmp call w_alloc(itmp, -cmp & max(nc*nno,nc*no*maxdim,nc*no*nv),'ITMP klvabo') -cmp - call GetMem('cr_il0','Allo','Real',il0, - & nc*nno) - call GetMem('cr_il1','Allo','Real',il1, - & nc*no*nv) - call GetMem('cr_itmp','Allo','Real',itmp, - & max(nc*nno,nc*no*maxdim,nc*no*nv)) -cmp - call gen_oovo (Work(ig),Work(il0),Work(il1),Work(itmp)) -cmp call gen_oovo (G(ig),G(il0),G(il1),G(itmp)) -cmp write(6,*)ddot_(NNO*NUAB(ISP)*NOAB(ISP),G(ig),1,G(ig),1) -cmp call zeroma (G(ig),1,NNO*NUAB(ISP)*NOAB(ISP)) -c -cmp call w_free(G(il0),0,'IL0 klvab') - call GetMem('cr_itmp','Free','Real',itmp, - & max(nc*nno,nc*no*maxdim,nc*no*nv)) - call GetMem('cr_il1','Free','Real',il1, - & nc*no*nv) - call GetMem('cr_il0','Free','Real',il0, - & nc*nno) - - if (printkey.gt.1) then - write (6,*) 'OOVO integrals regenerated from MOLCAS' - end if -cmp - IAS=1 -cmpn - nga=0 -cmpn - do A1=1,NUAB(ISP),vblock - A2=A1+min(vblock,nuab(isp)-(A1-1))-1 - NSTEP=min(vblock,nuab(isp)-(A1-1)) -cmpn - nga=nga+1 -c -cmp write (6,*) -cmp write (6,*) '=================================' -cmp write (6,*) ' nga ',nga -cmp write (6,*) '=================================' -cmp write (6,*) -c -cmp write (6,'(A,2(i5,2x))') 'b1,b2 = ',a1,a2 -c -cmp call block_interf(1,1,a1,a2, - call block_interf(1,nuab(1),a1,a2, - & ngaf,ngal,nind_ngaf,nind_ngal, - & ngbf,ngbl,nind_ngbf,nind_ngbl) -c -cmp write (6,'(A,4(i5,2x))') 'ngbf, ngbl, nind_ngbf, nind_ngbl', -cmp & ngbf,ngbl,nind_ngbf,nind_ngbl -c -c - read amplitudes T2(nv,vblock,j for isp=1 T2 for isp=2 - ISTEP=(ISPA-1)*NUAB(2)+2-ISPA - RAD=(I-1)*nstep*n+(A-A1)*n+IX+noab(is2) - $ +(K-1)*noab(is2)*nstep*N -cmp call dcopy_(nuab(is2),G(AADT),ISTEP,G(RAD),1) -cmp - call dcopy_(nuab(is2),Work(AADT),ISTEP,Work(RAD),1) - enddo ! A - enddo ! I -C copies OOVO - DO J=1,noab(is2) - DO A=1,NSTEP - RAD=IX+(A-1)*n+(J-1)*nstep*N+(K-1)*noab(is2) - $ *nstep*N - IADR=ISCR+(A-1)*noab(is2)*noab(is2)+(j-1)*noab(is2) -cmp call dcopy_(noab(is2),G(IADR),1,G(RAD),1) - call dcopy_(noab(is2),Work(IADR),1,Work(RAD),1) - enddo ! A - enddo ! J - enddo ! K -!! write(6,'(A,2I5,4x,D15.10)') -!! $'block-w:a1,IAS,ddot',a1,ias,ddot_(N*vblock*nnoab(3),g(ix),1,g(ix),1) -!! write(6,'(a,a,2I4,D16.8)')'block-w',ich(isp),(A1/vblock)+1,IAS, -!! $ddot_(N*nnoab(3)*NSTEP,g(ix),1,g(ix),1) -cmp call multi_wridir(G(IX),N*nstep*nnoab(3),LU,IAS,last) -cmp -cmp!! do jjj=0,N*nstep*nnoab(3)-1 -cmp!! if (abs(Work(ix+jjj)).gt.10000) then -cmp!! write (*,*) 'prasa 2 ',jjj,Work(ix+jjj) -cmp!! stop -cmp!! end if -cmp!! end do -cmp - call multi_wridir(Work(IX),N*nstep*nnoab(3),LU,IAS,last) -cmp - IAS=IAS+iasblock -cmpn - call GetMem('it3_exp','Free','Real',it_exp,length) -cmpn - enddo ! A1 - close (LU) -! write(6,*) FN, isp, IAS - dupblk(ndup)=last - if(IUHF.EQ.0)then - FN(1:4)='LMAT' - FN(6:6)=ich(isp) - FN(5:5)=ich(isp) - call multi_opendir(FN,LU) - ndup=ndup+1 - if (ndup.gt.ndupmx) - $ call barf('create_klvab_t3 -- ndupmx exceeded') -! write(6,*) FN, isp,ndup - dupfil(ndup)=FN -C this is to ensure correct copy to slaves - IAS_AA=1 -cmp write (6,*) 'test 1 na iscr ',vblock*noab(IS2)*noab(IS2) -cmp write (6,*) 'test 1 na ig ',noab(isp)*nuab(isp)*nno -cmp write (6,*) 'test 1 na ix ',noab(isp)*noab(IS2)*vblock*n -cmp call klvaa_oovo(G,ix,it,ig,iscr,vblock,N,nug, -cmpn call klvaa_oovo(ix,it,ig,iscr,vblock,N,nug, - call klvaa_oovo(ix,ig,iscr,vblock,N,nug, - $LU,last_aa,ias_aa) -cmp -cmp write (6,*) 'klvaa_oovo finished' -cmp - close(LU) - ndup=ndup - dupblk(ndup)=last_aa - endif - enddo ! ISP -cmp call w_memchk('all klvab ') -cmp call w_free(g(it),0,'IT klvab ') -c iscr a ig sa odalokuju v klva_oovo -cmp @@@ call GetMem('create_iscr','Free','Real',iscr, -cmp @@@ & vblock*noab(IS2)*noab(IS2)) -cmp @@@ call GetMem('create_ig','Free','Real',ig, -cmp @@@ & noab(isp)*nuab(isp)*nno) -cmp ??? -cmp?? call GetMem('c2_ix','Free','Real',ix, -cmp?? & noab(isp)*noab(IS2)*vblock*n) -cmpn call GetMem('create_it','Free','Real',it, -cmpn & NNOAB(3)*NNUAB(3)) - call xflush(6) - return - end diff -Nru openmolcas-22.02/src/cht3/create_klvab_t3.F90 openmolcas-22.10/src/cht3/create_klvab_t3.F90 --- openmolcas-22.02/src/cht3/create_klvab_t3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/create_klvab_t3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,591 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine create_klvab_t3(vblock) +!mp subroutine create_klvab_t3(G,vblock) +! +! creates K(alpha-beta,alpha-beta),K(beta-alpha,alpha-beta) +! DA files KMATBA and KMATAB, LMATBA and LMATAB +! creates L(alpha-beta,alpha-beta),K(beta-alpha,alpha-beta) +! max G at this place +! both matrices have to be available at a time (unfortunately) +! +! parallelization irrelevant at the moment +! implemented integer offsets, PV, 14 may 2004. + +use ChT3_global, only: DimGrpaR, ICH, IOPT, maxdim, nblock, nc, NNOAB, no, NOAB, NUAB, nv, NvGrp, printkey +use ChT3_procedures, only: klvaa_oovo +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: vblock +integer(kind=iwp) :: A, A1, A2, a_tmp, AADT, adim, B1, b1_tmp, b2_chk, i, i_blk, IADR, ias, ias_aa, iasblock, IJS, is2, isp, ISPA, & + ISTEP, IUHF, j, j_blk, j_tmp, k, last, last_aa, length, length1, length2, lu, n, nga, ngaf, ngal, ngb, ngbf, & + ngbl, nind_ngaf, nind_ngal, nind_ngbf, nind_ngbl, NNO, NNU, NSTEP, nug, RAD +character(len=6) :: FN +real(kind=wp), allocatable :: g(:), l0(:), l1(:), l1_1(:), l2_1(:), scr(:), t2_exp(:), t2_tmp(:), tmp(:), tmp2(:), x(:) + +if (printkey >= 10) then + write(u6,*) + write(u6,*) '------ DimGrpaR ------' + write(u6,'(8(i5,2x))') (DimGrpaR(a_tmp),a_tmp=1,NvGrp) + write(u6,*) +end if + +! - calculate overall memory requirements + +call check_create_klvab_t3_mem(vblock) + +!mp call w_rescope(G,'G create KL') +!mp call w_free(g,0,'G klvab ') +N = noab(1)+nuab(1) +!NNRED = nTri_Elem(NOAB(1)) +IUHF = 0 +if (IOPT(1) /= 0) then + IUHF = 1 + !NNRED = NNOAB(3) +end if +LU = 98 + +!mp call w_alloc(it,NNOAB(3)*NNUAB(3),'IT klvab') +!mp call w_alloc(ix,vblock*vblock*n,'IX klvab') +!mpn call mma_allocate(t,NNOAB(3)*NNUAB(3),label='create_it') +call mma_allocate(x,vblock*vblock*n,label='c1_ix') +!mp +!!FN = 'T2OLDC' +!!call GET3DM(FN,G(it),NNUAB(3),NNRED,0) +!mp + +!mp call w_alloc(it2_tmp,maxdim*maxdim*no*no,'ITMP klvab') +!mp call w_alloc(itmp,maxdim*maxdim*no*no,'ITMP klvab') +!mpn call mma_allocate(t2_tmp,maxdim*maxdim*no*no,label='create_it2') +!mpn call mma_allocate(tmp,maxdim*maxdim*no*no,label='create_tmp') +! +!mp call gather_t2(G(it),G(it2_tmp),G(itmp)) +!mpn call gather_t2(t,t2_tmp,tmp) +! +! +!mp call w_free(G(it2_tmp),0,'ITMP klvab ') +!mpn call mma_deallocate(tmp) +!mpn call mma_deallocate(t2_tmp) + +!mpn write(u6,*) 'T2 regenerated from MOLCAS' +!mpn write(u6,*) +! +!mp call dscal_(NNUAB(3)*NNRED,-One,G(it),1) +!mp call dscal_(NNUAB(3)*NNOAB(3),-One,G(it),1) +!mpn t(:) = -t +!mp if (IUHF == 0) call decomp2ind(G(it),NNUAB(3),noab(1),NUAB(1)) +!!write(u6,*) ddot_(nnoab(3)*nnuab(3),G(it),1,G(it),1) + +! number of blocks written in a single multiwrite + +iasblock = vblock*vblock*N/nblock +if ((iasblock*nblock) < (vblock*vblock*N)) iasblock = iasblock+1 + +do isp=1,IUHF+1 + is2 = 3-isp + FN = 'KMAT'//ich(3-isp)//ich(isp) + write(u6,*) 'FN,LU=',FN,LU + call multi_opendir(FN,LU) + !ndup = ndup+1 + !if (ndup > ndupmx) then + ! write(u6,*) 'create_klvab_t3 -- ndupmx exceeded' + ! call abend() + !end if + !!write(u6,*) FN,isp,ndup + !dupfil(ndup) = FN + if (IUHF == 0) then + FN(5:6) = ich(isp)//ich(isp) + call multi_opendir(FN,LU+1) + !!ndup = ndup+1 + !if (ndup > ndupmx) then + ! write(u6,*) 'create_klvab_t3 -- ndupmx exceeded' + ! call abend() + !end if + !!write(u6,*) FN,isp,ndup+1 + !dupfil(ndup+1) = FN + end if + ! currently using 3-dim (big field) - will be replaced after changing + ! stepiv and the rest + nnu = nTri_Elem(nuab(is2)) + !mp call w_alloc(ig,(nuab(isp)*nnu),'IG klvab') + !mp call w_alloc(iscr,nuab(is2)*nuab(is2),'IG iscr') + !mp + call mma_allocate(g,nuab(isp)*nnu,label='c1_ig') + call mma_allocate(scr,nuab(is2)*nuab(is2),label='c1_iscr') + !mp + IAS = 1 + IAS_AA = 1 + + do K=1,noab(isp) + !!if (IUHF == 1) then + !! KADT = (K-1)*NNUAB(3)*(NOAB(2)*(2-ISP)+ISP-1) + !!else + !! KADT = 0 + !!end if + + !mp !FN = 'VVVAI'//ICH(ISP) + !mp !call GET3DM(FN,G(IG),NNU,NUAB(ISP),K) + if (printkey > 1) write(u6,*) 'Regenerating VVVo integrals for o = ',K + !mp + !mp call w_alloc(il1_1,nc*maxdim,'IL1_1 iscr') + !mp call w_alloc(il2_1,nc*maxdim*maxdim,'IL2_1 iscr') + !mp call w_alloc(itmp,max(nc*maxdim*maxdim,nc*no*maxdim,maxdim*maxdim*maxdim),'ITMP iscr') + !mp + call mma_allocate(l1_1,nc*maxdim,label='cc_il1_1') + call mma_allocate(l2_1,nc*maxdim*maxdim,label='cc_il2_1') + call mma_allocate(tmp,max(nc*maxdim*maxdim,nc*no*maxdim,maxdim*maxdim*maxdim),label='cc_itmp') + !mp + !mp call gen_vvvo(K,G(IG),G(il1_1),G(il2_1),G(itmp)) + call gen_vvvo(K,g,l1_1,l2_1,tmp) + !mp write(u6,*) ddot_(nnu*nuab(isp),G(ig),1,G(ig),1) + !mp call zeroma(G(ig),1,NNU*NUAB(ISP)) + ! + !mp call w_free(G(il1_1),0,'IL1_1 iscr') + call mma_deallocate(tmp) + call mma_deallocate(l2_1) + call mma_deallocate(l1_1) + !mp + call delf(FN,K,K) + if (iuhf == 0) call klvaa_vvv(x,g,vblock,N,nug,LU+1,last_aa,iasblock,K,ias_aa) + !mpn if (iuhf == 0) call klvaa_vvv(ix,it,ig,iscr,vblock,N,nug,LU+1,last_aa,iasblock,K,ias_aa) + !mp if (iuhf == 0) call klvaa_vvv(G,ix,it,ig,iscr,vblock,N,nug,LU+1,last_aa,iasblock,K,ias_aa) + + !!call xflush(u6) + ! (c>d|AK) + + !mpn + nga = 0 + !mpn + do A1=1,NUAB(ISP),vblock + A2 = A1+min(vblock,nuab(isp)-A1+1)-1 + adim = A2-A1+1 + nga = nga+1 + ngb = 0 + do B1=1,NUAB(IS2),vblock + ngb = ngb+1 + NSTEP = min(vblock,nuab(is2)-B1+1) + !!bdim = NSTEP + IJS = (A1-1)*NNU+1 + !mpn + !mpn write(u6,*) + !mpn write(u6,*) '=================================' + !mpn write(u6,*) ' nga, ngb',nga,ngb + !mpn write(u6,*) '=================================' + !mpn write(u6,*) + + ! - check the largest b2 + + !mpn b2_chk = b1-1+vblock + b2_chk = b1-1+min(vblock,nuab(is2)-B1+1) + + ! - find out which T2 blocked files will be needed + ! for particular nga, ngb + + !mpn write(u6,'(A,4(i5,2x))') 'a1,a2,b1,b2_chk = ',a1,a2,b1,b2_chk + + !switch = .false. + if (nga < ngb) then + !mpn write(u6,*) 'switching nga, ngb',ngb,nga + !switch = .true. + + call block_interf(b1,b2_chk,a1,a2,ngaf,ngal,nind_ngaf,nind_ngal,ngbf,ngbl,nind_ngbf,nind_ngbl) + + else + + call block_interf(a1,a2,b1,b2_chk,ngaf,ngal,nind_ngaf,nind_ngal,ngbf,ngbl,nind_ngbf,nind_ngbl) + + end if + + !mpn write(u6,'(A,4(i5,2x))') 'ngaf, ngal, nind_ngaf, nind_ngal',ngaf,ngal,nind_ngaf,nind_ngal + !mpn write(u6,'(A,4(i5,2x))') 'ngbf, ngbl, nind_ngbf, nind_ngbl',ngbf,ngbl,nind_ngbf,nind_ngbl + + ! - read amplitudes from T2_ngaf_ngbf ... T2_ngaf_ngbl, nga>=ngb + ! .... .... + ! T2ngal_ngbf ... T2_ngal_ngbl, nga>=ngb + + ! - calculate memory requirements (consider squared T2(a',a')) + + length1 = 0 + do i_blk=ngaf,ngal + length1 = length1+DimGrpaR(i_blk) + end do + + length2 = 0 + do j_blk=ngbf,ngbl + length2 = length2+DimGrpaR(j_blk) + end do + + !mpn write(u6,*) 'length1, vblock = ',length1,vblock + !mpn write(u6,*) 'length2, vblock = ',length2,vblock + + length = length1*length2*no*no + !mpn write(u6,*) 'length for blocked T2 amplitudes = ',length + + ! - setup memory + + !mpn write(u6,*) 'allocating t2_exp = ',length + call mma_allocate(t2_exp,length,label='t2_exp') + + ! - read pertinent files and store them in the new blocked structure + + call mma_allocate(t2_tmp,maxdim*maxdim*no*no,label='cd_it2tmp') + call mma_allocate(tmp,maxdim*maxdim*no*no,label='cd_itmp') + + call gather_t2_blocked(length1,length2,ngaf,ngal,ngbf,ngbl,t2_exp,t2_tmp,tmp) + + call mma_deallocate(tmp) + call mma_deallocate(t2_tmp) + + t2_exp(:) = -t2_exp + + do A=A1,A2 + !mp call EXPA1_UHF(G(IJS),1,NUAB(IS2),1,G(ISCR)) + call EXPA1_UHF(g(IJS),1,NUAB(IS2),1,SCR) + IJS = IJS+NNU + ! Gix + !! not needed B2 = B1+min(ng,nuab(is2)-B1+1))-1 + !mpn + if (nga < ngb) then + a_tmp = a-nind_ngbf + b1_tmp = b1-nind_ngaf + else + a_tmp = a-nind_ngaf + b1_tmp = b1-nind_ngbf + end if + !mp write(u6,'(A,2(i5,2x),A,i5,2x)') 'b1, a ,i,k = ',b1,a,' i',k + ! mv T2(B,A,I,K) >> G(ix) + !mpn + do I=1,NOAB(IS2) + ISPA = ISP + !!if (IUHF == 1) then + !! IADT = (I-1)*NNUAB(3)*(NOAB(2)*(2-IS2)+IS2-1) + !!else + !! IADT = iTri(K,I) + !! IADT = (IADT-1)*NNUAB(3) + !! if (K < I) ISPA = IS2 + !!end if + !mpn BADT = (2-ISPA)*B1+(ISPA-1)*(B1-1)*NUAB(2) + !mpn!!! + !mpn AADT_tmp = IADT+KADT+BADT+A*(ISPA-1)+(2-ISPA)*(A-1)*NUAB(2) + !mpn!!! + ! T2 for isp=1 T2 for isp=2 + !! RAD = (I-1)*vblock*vblock+(A-A1)*vblock+1 + RAD = (I-1)*adim*nstep+(A-A1)*nstep+1 + ISTEP = (ISPA-1)*NUAB(2)+2-ISPA + !mpn + if (nga >= ngb) then ! nga> ngb + + !mp write(u6,'(A,4(i5,2x),3x,i5)') '(I) a_tmp,b1_tmp,k,i nstep = ',a_tmp,b1_tmp,k,i,nstep + ! T2(B,A,I,K) =? T2(A,B1,K,I) + do j_tmp=0,NSTEP-1 ! istep je 1 ak dobre tusim + + AADT = (I-1)*length1*length2*NOAB(2)+(K-1)*length1*length2+(b1_tmp-1+j_tmp)*length1+a_tmp + + x(RAD+j_tmp) = t2_exp(AADT) + !mp + !mpn if (abs(t2_exp(AADT)-t(AADT_tmp+j_tmp)) > 1.0e-5_wp) then + !mpn write(u6,*) 'halohaha 1',AADT,AADT_tmp+j_tmp,t2_exp(AADT),t(AADT_tmp+j_tmp) + !mpn stop + !mpn end if + !mp + end do + + else ! nga < ngb + + !mp write(u6,'(A,4(i5,2x),3x,i5)') '(II) b1_tmp,a_tmp,k,i nstep = ',b1_tmp,a_tmp,i,k,nstep + ! T2(B,A,I,K) + do j_tmp=0,NSTEP-1 ! istep je 1 ak dobre tusim + + !mp AADT = (k-1)*length1*length2*NOAB(2)+(i-1)*length1*length2+(a_tmp-1)*length1+b1_tmp+j_tmp + !mp !AADT = (i-1)*length1*length2*NOAB(2)+(k-1)*length1*length2+(a_tmp-1)*length1+b1_tmp+j_tmp + AADT = (K-1)*length1*length2*NOAB(2)+(I-1)*length1*length2+(a_tmp-1)*length1+b1_tmp+j_tmp + + x(RAD+j_tmp) = t2_exp(AADT) + !mp + !mpn if (abs(t2_exp(AADT)-t(AADT_tmp+j_tmp)) > 1.0e-5_wp) then + !mpn write(u6,*) 'halohaha 2',AADT,AADT_tmp+j_tmp,t2_exp(AADT),t(AADT_tmp+j_tmp) + !mpn stop + !mpn end if + !mp + + end do + end if + + !mpn call dcopy_(NSTEP,t2_exp(AADT),ISTEP,x(RAD),1) + !mpn + end do ! I + RAD = noab(is2)*adim*nstep+(A-A1)*nstep+1 + do IADR=B1,NUAB(IS2)*NUAB(IS2),NUAB(IS2) + !mp call dcopy_(NSTEP,G(IADR),1,G(RAD),1) + x(RAD:RAD+NSTEP-1) = scr(IADR:IADR+NSTEP-1) + RAD = RAD+adim*nstep + end do ! IADR + end do ! A + !!write(u6,'(A,4I5,4x,D15.10)') 'block-w: K,a1,b1,IAS,ddot',K,a1,b1,ias,ddot_(N*vblock*vblock,G(IX),1,G(IX),1) + !mp call multi_wridir(G(IX),N*vblock*vblock,LU,IAS,last) + + !mp + !mp !!do jjj = 1,N*vblock*vblock + !mp !!if (abs(x(jjj)) > 1.0e5_wp) then + !mp !! write(u6,*) 'prasa 1 ',jjj,x(jjj) + !mp !! stop + !mp !!end if + !mp !!end do + !mp + call multi_wridir(x,N*vblock*vblock,LU,IAS,last) + !!write(u6,*) 'N*vblock*vblock,LU,last ',N*vblock*vblock,LU,last + ias = ias+iasblock + !mp + call mma_deallocate(t2_exp) + !mp + end do ! B1 + end do ! A1 + end do ! K + if (printkey > 1) then + write(u6,*) 'VVVo integrals regenerated from MOLCAS' + write(u6,*) + end if + !mp + close(LU) + !dupblk(ndup) = last + if (IUHF == 0) then + close(LU+1) + !ndup = ndup+1 + !dupblk(ndup) = last_aa + end if + !write(u6,*) FN,isp,IAS + !mp call w_memchk('IG klvab ') + !mp call w_free(g(ig),0,'IG klvab ') + !mp + call mma_deallocate(scr) + call mma_deallocate(g) + !mp +end do ! ISP + +!mp call dscal_(NNUAB(3)*NNOAB(3),-One,G(it),1) +!mpn t(:) = -t +!mp?? +call mma_deallocate(x) +!mp?? +do isp=1,IUHF+1 + !mp call w_memchk('IX klvab ') + !mp call w_free(g(ix),0,'IX klvab ') + !mp + is2 = 3-isp + iasblock = nnoab(3)*vblock*N/nblock + if ((iasblock*nblock) < (nnoab(3)*vblock*N)) iasblock = iasblock+1 + FN = 'LMAT'//ich(3-isp)//ich(isp) + call multi_opendir(FN,LU) + !ndup = ndup+1 + !if (ndup > ndupmx) then + ! write(u6,*) 'create_klvab_t3 -- ndupmx exceeded' + ! call abend() + !end if + !write(u6,*) FN,isp,ndup + !dupfil(ndup) = FN + + FN = 'OOVAI'//ICH(ISP) + !mp call w_alloc(ix,noab(isp)*noab(IS2)*vblock*n,'IX klvabo') + call mma_allocate(x,noab(isp)*noab(IS2)*vblock*n,label='c2_ix') + nno = nTri_Elem(noab(is2)) + !mp call w_alloc(ig,noab(isp)*nuab(isp)*nno,'IG klvabo') + !mp call w_alloc(iscr,vblock*noab(IS2)*noab(IS2),'ISCRo klvabo') + call mma_allocate(g,noab(isp)*nuab(isp)*nno,label='c2_ig') + call mma_allocate(scr,vblock*noab(IS2)*noab(IS2),label='c2_iscr') + !mp + !mp !call GET3DM(FN,G(ig),NNO,NUAB(ISP)*NOAB(ISP),0) + !mp + !mp call w_alloc(il0,nc*nno,'IL0 klvabo') + !mp call w_alloc(il1,nc*no*nv,'IL1 klvabo') + !mp call w_alloc(itmp,max(nc*nno,nc*no*maxdim,nc*no*nv),'ITMP klvabo') + !mp + call mma_allocate(l0,nc*nno,label='cr_il0') + call mma_allocate(l1,nc*no*nv,label='cr_il1') + call mma_allocate(tmp,max(nc*nno,nc*no*maxdim,nc*no*nv),label='cr_itmp') + !mp + call gen_oovo(g,l0,l1,tmp) + !mp call gen_oovo(G(ig),G(il0),G(il1),G(itmp)) + !mp write(u6,*) ddot_(NNO*NUAB(ISP)*NOAB(ISP),G(ig),1,G(ig),1) + !mp call zeroma(G(ig),1,NNO*NUAB(ISP)*NOAB(ISP)) + + !mp call w_free(G(il0),0,'IL0 klvab') + call mma_deallocate(tmp) + call mma_deallocate(l1) + call mma_deallocate(l0) + + if (printkey > 1) write(u6,*) 'OOVO integrals regenerated from MOLCAS' + !mp + IAS = 1 + !mpn + nga = 0 + !mpn + do A1=1,NUAB(ISP),vblock + A2 = A1+min(vblock,nuab(isp)-(A1-1))-1 + NSTEP = min(vblock,nuab(isp)-(A1-1)) + !mpn + nga = nga+1 + + !mp write(u6,*) + !mp write(u6,*) '=================================' + !mp write(u6,*) ' nga ',nga + !mp write(u6,*) '=================================' + !mp write(u6,*) + + !mp write(u6,'(A,2(i5,2x))') 'b1,b2 = ',a1,a2 + + !mp call block_interf(1,1,a1,a2,ngaf,ngal,nind_ngaf,nind_ngal,ngbf,ngbl,nind_ngbf,nind_ngbl) + call block_interf(1,nuab(1),a1,a2,ngaf,ngal,nind_ngaf,nind_ngal,ngbf,ngbl,nind_ngbf,nind_ngbl) + + !mp write(u6,'(A,4(i5,2x))') 'ngbf, ngbl, nind_ngbf, nind_ngbl',ngbf,ngbl,nind_ngbf,nind_ngbl + + ! - read amplitudes T2(nv,vblock,j for isp=1 T2 for isp=2 + ISTEP = (ISPA-1)*NUAB(2)+2-ISPA + RAD = (I-1)*nstep*n+(A-A1)*n+noab(is2)+(K-1)*noab(is2)*nstep*N+1 + !mp call dcopy_(nuab(is2),G(AADT),ISTEP,G(RAD),1) + !mp + call dcopy_(nuab(is2),t2_exp(AADT),ISTEP,x(RAD),1) + end do ! A + end do ! I + ! copies OOVO + do J=1,noab(is2) + do A=1,NSTEP + RAD = 1+(A-1)*n+(J-1)*nstep*N+(K-1)*noab(is2)*nstep*N + IADR = 1+(A-1)*noab(is2)*noab(is2)+(j-1)*noab(is2) + !mp call dcopy_(noab(is2),G(IADR),1,G(RAD),1) + x(RAD:RAD+noab(is2)-1) = scr(IADR:IADR+noab(is2)-1) + end do ! A + end do ! J + end do ! K + !!write(u6,'(A,2I5,4x,D15.10)') 'block-w:a1,IAS,ddot',a1,ias,ddot_(N*vblock*nnoab(3),g(ix),1,g(ix),1) + !!write(u6,'(a,a,2I4,D16.8)') 'block-w',ich(isp),(A1/vblock)+1,IAS,ddot_(N*nnoab(3)*NSTEP,g(ix),1,g(ix),1) + !mp call multi_wridir(G(IX),N*nstep*nnoab(3),LU,IAS,last) + !mp + !mp !!do jjj=1,N*nstep*nnoab(3) + !mp !! if (abs(x(jjj)) > 1.0e5_wp) then + !mp !! write(u6,*) 'prasa 2 ',jjj,x(jjj) + !mp !! stop + !mp !! end if + !mp !!end do + !mp + call multi_wridir(x,N*nstep*nnoab(3),LU,IAS,last) + !mp + IAS = IAS+iasblock + !mpn + call mma_deallocate(t2_exp) + !mpn + end do ! A1 + close(LU) + call mma_deallocate(scr) + !write(u6,*) FN,isp,IAS + !dupblk(ndup) = last + if (IUHF == 0) then + FN = 'LMAT'//ich(isp)//ich(isp) + call multi_opendir(FN,LU) + !ndup = ndup+1 + !if (ndup > ndupmx) then + ! write(u6,*) 'create_klvab_t3 -- ndupmx exceeded' + ! call abend() + !end if + !write(u6,*) FN,isp,ndup + !dupfil(ndup) = FN + ! this is to ensure correct copy to slaves + IAS_AA = 1 + !mp write(u6,*) 'test 1 na iscr ',vblock*noab(IS2)*noab(IS2) + !mp write(u6,*) 'test 1 na ig ',noab(isp)*nuab(isp)*nno + !mp write(u6,*) 'test 1 na ix ',noab(isp)*noab(IS2)*vblock*n + !mp call klvaa_oovo(G,ix,it,ig,iscr,vblock,N,nug,LU,last_aa,ias_aa) + !mpn call klvaa_oovo(ix,it,ig,iscr,vblock,N,nug,LU,last_aa,ias_aa) + call klvaa_oovo(x,g,vblock,N,nug,LU,last_aa,ias_aa) + !mp + !mp write(u6,*) 'klvaa_oovo finished' + !mp + close(LU) + !ndup = ndup + !dupblk(ndup) = last_aa + end if +end do ! ISP +!mp call w_memchk('all klvab ') +!mp call w_free(g(it),0,'IT klvab ') +! ig sa odalokuju v klva_oovo +!mp @@@ call GetMem('create_ig','Free','Real',ig,noab(isp)*nuab(isp)*nno) +!mp ??? +!mp?? call GetMem('c2_ix','Free','Real',ix,noab(isp)*noab(IS2)*vblock*n) +!mpn call mma_deallocate(t) +call xflush(u6) + +return + +end subroutine create_klvab_t3 diff -Nru openmolcas-22.02/src/cht3/decomp2ind.F90 openmolcas-22.10/src/cht3/decomp2ind.F90 --- openmolcas-22.02/src/cht3/decomp2ind.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/decomp2ind.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,66 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine decomp2ind(W,IDM,no,NF) + +use Index_Functions, only: nTri_Elem +use Constants, only: Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: IDM, no, NF +real(kind=wp), intent(inout) :: W(IDM,*) +integer(kind=iwp) :: IJ, I, IJO, II, K, L, KL, LK, J, JIO +real(kind=wp) :: DD + +!mp if (LLtrace) then +!mp write(u6,*) 'Entering DECOMP2IND' +!mp call xflush(u6) +!mp endif + +! symmetrizes the upper index + +!write(u6,*) 'decomp2ind:',IDM,no,NF +do I=1,no + II = nTri_Elem(I) + do K=2,NF + do L=1,K-1 + KL = (K-1)*NF+L + LK = (L-1)*NF+K + DD = Half*(W(KL,II)+W(LK,II)) + W(KL,II) = DD + W(LK,II) = DD + end do + end do +end do +if (NO > 2) then + do I=NO,2,-1 + IJ = nTri_Elem(I-1)+1 + IJO = (I-1)*no+1 + W(:,IJO:IJO+I-1) = W(:,IJ:IJ+I-1) + end do +else if (NO == 2) then + W(:,3:4) = W(:,2:3) +end if +do I=2,no + do J=1,I-1 + IJO = (I-1)*no+J + JIO = (J-1)*no+I + call map2_21_t3(W(:,IJO),W(:,JIO),NF,NF) + end do +end do +!stop +!mp if (LLtrace) then +!mp write(u6,*) 'Leaving DECOMP2IND' +!mp call xflush(u6) +!mp end if + +end subroutine decomp2ind diff -Nru openmolcas-22.02/src/cht3/defcommon.f openmolcas-22.10/src/cht3/defcommon.f --- openmolcas-22.02/src/cht3/defcommon.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/defcommon.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,97 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine defcommon (nfr,no,nv) -c -c this routine do : -c -c define commons needed in DIRCC routines -c - implicit none - integer nfr,nv,no -cmp! integer me,nprocs -c -#include "uhf.fh" -#include "param_cht3.fh" -cmp! common /my_mpi_world_com/ me, nprocs -c -cmp! include 'task_info_inc' -cmp! include 'ws_conn_inc' -c -c logical llmpi -c -#include "ioind.fh" -c -c ---- UHF ----- -c - noab(1)=no - noab(2)=no -c - nnoab(1)=noab(1)*(noab(1)-1)/2 - nnoab(2)=noab(2)*(noab(2)-1)/2 - nnoab(3)=noab(1)*noab(2) -c - nuab(1)=nv - nuab(2)=nv -c - nnuab(1)=(nuab(1)*(nuab(1)-1))/2 - nnuab(2)=(nuab(2)*(nuab(2)-1))/2 - nnuab(3)=nuab(1)*nuab(2) -c - ich(1)="A" - ich(2)="B" - ich(3)="C" -c -c ---- PARAM ---- -c - nso=0 -c?????????????????? - it=1 - itlast=1 - nbf=nfr+no+nv - nomx=nbf - nu=nv - mx2=(nbf*(nbf+1))/2 - nno=(no*(no+1))/2 - nnu=(nu*(nu+1))/2 - nuo=no*nu -c -c ------ my_mpi_world_com -------- -c -c zatial pre sekvencny chod -c -cmp! me=0 -cmp! nprocs=1 -cmp! llmpi=.false. -cmp! nws=1 -cmp! iws(1)=1 -cmp! lws(1)=.true. -c -c ------ pre Get3DM ----------- -c -c ------ IOPT ----------- -c - IOPT(14)=6 - IOPT(30)=0 - IOPT(76)=0 - IOPT(93)=0 - IOPT(93)=64 - IOPT(95)=0 -c -C sets IOPT(27) to an extreme number to force one file - temporary !!! preskumat !!! -C in prder to be compatible with RHF i=2^31-1 - iopt(27)=2147483647 -c -c -c -c zatial tolko -c - return - end diff -Nru openmolcas-22.02/src/cht3/defcommon.F90 openmolcas-22.10/src/cht3/defcommon.F90 --- openmolcas-22.02/src/cht3/defcommon.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/defcommon.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,70 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine defcommon(no,nv) +! this routine does: +! +! define commons needed in DIRCC routines + +use ChT3_global, only: IOPT, IT, NNOAB, NNUAB, NOAB, NUAB +use Index_Functions, only: nTri_Elem +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: no, nv + +! ---- UHF ----- + +noab(1) = no +noab(2) = no + +nnoab(1) = nTri_Elem(noab(1)-1) +nnoab(2) = nTri_Elem(noab(2)-1) +nnoab(3) = noab(1)*noab(2) + +nuab(1) = nv +nuab(2) = nv + +nnuab(1) = nTri_Elem(nuab(1)-1) +nnuab(2) = nTri_Elem(nuab(2)-1) +nnuab(3) = nuab(1)*nuab(2) + +! ---- PARAM ---- + +!?????????????????? +it = 1 + +! ------ my_mpi_world_com -------- + +! zatial pre sekvencny chod + +!mp !me = 0 +!mp !nprocs = 1 +!mp !llmpi = .false. +!mp !nws = 1 +!mp !iws(1) = 1 +!mp !lws(1) = .true. + +! ------ pre Get3DM ----------- + +! ------ IOPT ----------- + +IOPT(1) = 0 + +! sets IOPT(2) to an extreme number to force one file - temporary !!! preskumat !!! +! in order to be compatible with RHF i=2^31-1 +iopt(2) = 2147483647 + +! zatial tolko + +return + +end subroutine defcommon diff -Nru openmolcas-22.02/src/cht3/defparreordhlp1.f openmolcas-22.10/src/cht3/defparreordhlp1.f --- openmolcas-22.02/src/cht3/defparreordhlp1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/defparreordhlp1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,108 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine DefParReordHlp1 (i,j,Schem,Nomen) -c -c help routine to DefPar..., producing names of Disc files -c ex: Schem='XY', i=1, j=3 -> Nomen='XY0103' -c N.B. suspendovana rutina -c - implicit none - integer i,j - character*2 Schem - character*6 Nomen -c -c help variables - character*1 Chr(1:6) - character*2 digit(1:64) - character*2 ichr,jchr - character*2 baza - character*6 meno -c - equivalence (Chr(1),meno) - equivalence (Chr(1),baza) - equivalence (Chr(3),ichr) - equivalence (Chr(5),jchr) -c -c -c quite a porno this piece - digit(1)='01' - digit(2)='02' - digit(3)='03' - digit(4)='04' - digit(5)='05' - digit(6)='06' - digit(7)='07' - digit(8)='08' - digit(9)='09' - digit(10)='10' - digit(11)='11' - digit(12)='12' - digit(13)='13' - digit(14)='14' - digit(15)='15' - digit(16)='16' - digit(17)='17' - digit(18)='18' - digit(19)='19' - digit(20)='20' - digit(21)='21' - digit(22)='22' - digit(23)='23' - digit(24)='24' - digit(25)='25' - digit(26)='26' - digit(27)='27' - digit(28)='28' - digit(29)='29' - digit(30)='30' - digit(31)='31' - digit(32)='32' - digit(33)='33' - digit(34)='34' - digit(35)='35' - digit(36)='36' - digit(37)='37' - digit(38)='38' - digit(39)='39' - digit(40)='40' - digit(41)='41' - digit(42)='42' - digit(43)='43' - digit(44)='44' - digit(45)='45' - digit(46)='46' - digit(47)='47' - digit(48)='48' - digit(49)='49' - digit(50)='50' - digit(51)='51' - digit(52)='52' - digit(53)='53' - digit(54)='54' - digit(55)='55' - digit(56)='56' - digit(57)='57' - digit(58)='58' - digit(59)='59' - digit(60)='60' - digit(61)='61' - digit(62)='62' - digit(63)='63' - digit(64)='64' -c -c - baza=Schem - ichr=digit(i) - jchr=digit(j) - Nomen=meno -c - return - end diff -Nru openmolcas-22.02/src/cht3/defparreordhlp2.f openmolcas-22.10/src/cht3/defparreordhlp2.f --- openmolcas-22.02/src/cht3/defparreordhlp2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/defparreordhlp2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,103 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine DefParReordHlp2 (i,Schem,Nomen) -c -c help routine to DefParo2v4, producing names of Disc files -c ex: Schem='XYZQ', i=1 -> Nomen='XYZQ01' -c - implicit none - integer i - character*4 Schem - character*6 Nomen -c -c help variables - character*1 Chr(1:6) - character*2 digit(1:64) - character*2 ichr - character*4 baza - character*6 meno -c - equivalence (Chr(1),meno) - equivalence (Chr(1),baza) - equivalence (Chr(5),ichr) -c -c - digit(1)='01' - digit(2)='02' - digit(3)='03' - digit(4)='04' - digit(5)='05' - digit(6)='06' - digit(7)='07' - digit(8)='08' - digit(9)='09' - digit(10)='10' - digit(11)='11' - digit(12)='12' - digit(13)='13' - digit(14)='14' - digit(15)='15' - digit(16)='16' - digit(17)='17' - digit(18)='18' - digit(19)='19' - digit(20)='20' - digit(21)='21' - digit(22)='22' - digit(23)='23' - digit(24)='24' - digit(25)='25' - digit(26)='26' - digit(27)='27' - digit(28)='28' - digit(29)='29' - digit(30)='30' - digit(31)='31' - digit(32)='32' - digit(33)='33' - digit(34)='34' - digit(35)='35' - digit(36)='36' - digit(37)='37' - digit(38)='38' - digit(39)='39' - digit(40)='40' - digit(41)='41' - digit(42)='42' - digit(43)='43' - digit(44)='44' - digit(45)='45' - digit(46)='46' - digit(47)='47' - digit(48)='48' - digit(49)='49' - digit(50)='50' - digit(51)='51' - digit(52)='52' - digit(53)='53' - digit(54)='54' - digit(55)='55' - digit(56)='56' - digit(57)='57' - digit(58)='58' - digit(59)='59' - digit(60)='60' - digit(61)='61' - digit(62)='62' - digit(63)='63' - digit(64)='64' -c - baza=Schem - ichr=digit(i) - Nomen=meno -c - return - end diff -Nru openmolcas-22.02/src/cht3/defparreord_t3.f openmolcas-22.10/src/cht3/defparreord_t3.f --- openmolcas-22.02/src/cht3/defparreord_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/defparreord_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,91 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine DefParReord_t3 (NaGrpR,maxdim) - -c -c This routine do: -c define parameters in cht3_reord.fh using NaGrpR,maxdim -c -c I/O parameter description: -c NxGrpR - # of groups in a (=b) set (I) -c maxdim - # maximal dimension of a (=b) Groups(O) -c - implicit none -#include "cht3_ccsd1.fh" -#include "cht3_reord.fh" -#include "files.fh" -c - integer NaGrpR,maxdim -c -c help variables -c - real*8 rdim - integer i,j - integer Up(1:MaxGrp),Low(1:MaxGrp) -c -c -c1 define parameters of Groups of a set -c - rdim=1.0d0*nv/(1.0d0*NaGrpR) -c - do i=1,NaGrpR -c - if (i.eq.1) then - Up(i)=int(rdim*i) - Low(i)=1 - else if (i.eq.NaGrpR) then - Up(i)=nv - Low(i)=Up(i-1)+1 - else - Up(i)=int(rdim*i) - Low(i)=Up(i-1)+1 - end if -c - DimGrpaR(i)=(Up(i)-Low(i))+1 -c - end do -c -c -c2 find maximal dimensions of a' -c - maxdim=DimGrpaR(1) - do i=1,NaGrpR - if (DimGrpaR(i).gt.maxdim) then - maxdim=DimGrpaR(i) - end if - end do -c -c -c3.1 def L2Name, T2Name, I2Name,I3Name -c - do i=1,MaxGrp - do j=1,MaxGrp - call DefParReordHlp1(i,j,'L2',L2Name(i,j)) - call DefParReordHlp1(i,j,'T2',T2Name(i,j)) - call DefParReordHlp1(i,j,'I2',I2Name(i,j)) - call DefParReordHlp1(i,j,'I3',I3Name(i,j)) - end do - end do -c -c3.2 def L1Name,I1Name -c - do i=1,MaxGrp - call DefParReordHlp2 (i,'L1vc',L1Name(i)) - call DefParReordHlp2 (i,'I1in',I1Name(i)) - end do -c -c3.3 def L0Name,I0Name -c - L0Name='L0vctr' - I0Name='I0intg' -c - return - end diff -Nru openmolcas-22.02/src/cht3/defparreord_t3.F90 openmolcas-22.10/src/cht3/defparreord_t3.F90 --- openmolcas-22.02/src/cht3/defparreord_t3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/defparreord_t3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,73 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine DefParReord_t3(NaGrpR,maxdim) +! This routine does: +! define parameters in cht3_global using NaGrpR,maxdim +! +! I/O parameter description: +! NxGrpR - # of groups in a (=b) set (I) +! maxdim - # maximal dimension of a (=b) Groups(O) + +use ChT3_global, only: DimGrpaR, L1Name, L2Name, nv, T2Name +use stdalloc, only: mma_allocate +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: NaGrpR +integer(kind=iwp), intent(out) :: maxdim +integer(kind=iwp) :: i, j, Low, Up_prev, Up +real(kind=wp) :: rdim + +call mma_allocate(DimGrpaR,NaGrpR,label='DimGrpaR') +call mma_allocate(L1Name,NaGrpR,label='L1Name') +call mma_allocate(L2Name,NaGrpR,NaGrpR,label='L2Name') +call mma_allocate(T2Name,NaGrpR,NaGrpR,label='T2Name') + +!1 define parameters of Groups of a set + +rdim = real(nv,kind=wp)/real(NaGrpR,kind=wp) + +Up_prev = 0 +do i=1,NaGrpR + + Low = Up_prev+1 + if (i == NaGrpR) then + Up = nv + else + Up = int(rdim*i) + end if + Up_prev = Up + + DimGrpaR(i) = Up-Low+1 + +end do + +!2 find maximal dimensions of a' + +maxdim = DimGrpaR(1) +do i=1,NaGrpR + if (DimGrpaR(i) > maxdim) maxdim = DimGrpaR(i) +end do + +!3 def L1Name, L2Name, T2Name + +do i=1,NaGrpR + write(L1Name(i),'(A4,I0.2)') 'L1vc',i + do j=1,NaGrpR + write(L2Name(i,j),'(A2,I0.2,I0.2)') 'L2',i,j + write(T2Name(i,j),'(A2,I0.2,I0.2)') 'T2',i,j + end do +end do + +return + +end subroutine DefParReord_t3 diff -Nru openmolcas-22.02/src/cht3/delf.f openmolcas-22.10/src/cht3/delf.f --- openmolcas-22.02/src/cht3/delf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/delf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine DELF(FNAM,INUM1,INUM2) - Implicit None - Integer I,inum1,inum2 - character FNAM*6,FN*8 - FN(1:6)=FNAM - do I=inum1,inum2 - write(fn(7:8),'(I2.2)')I -c write(6,*)'File ',FN,' to be deleted' - call Molcas_Open(8,fn) - close(8,status='DELETE') - enddo - return - end diff -Nru openmolcas-22.02/src/cht3/delf.F90 openmolcas-22.10/src/cht3/delf.F90 --- openmolcas-22.02/src/cht3/delf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/delf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,34 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine DELF(FNAM,INUM1,INUM2) + +use Definitions, only: iwp + +implicit none +character(len=6), intent(in) :: FNAM +integer(kind=iwp), intent(in) :: INUM1, INUM2 +integer(kind=iwp) :: I, LU +character(len=8) :: FN +integer(kind=iwp), external :: IsFreeUnit + +FN(1:6) = FNAM +do I=inum1,inum2 + write(fn(7:8),'(I2.2)') I + !write(u6,*) 'File ',FN,' to be deleted' + LU = IsFreeUnit(8) + call Molcas_Open(LU,fn) + close(LU,status='DELETE') +end do + +return + +end subroutine DELF diff -Nru openmolcas-22.02/src/cht3/dupfiles.fh openmolcas-22.10/src/cht3/dupfiles.fh --- openmolcas-22.02/src/cht3/dupfiles.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/dupfiles.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,24 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -c List of files to be duplicated over the virtual MPI machine -c input+total: -c List of files MOLECULE.INP and *.BAS related files -c triples: -c List of multi direct access files and corresponding block numbers -c -c PV/LAOG, 11 jul 2003. -c - integer ndupmx,ndup - parameter (ndupmx=20) - integer dupblk(ndupmx) - character dupfil(ndupmx)*132 -cmp! character*132 dupfil(ndupmx) - common/dupfiles/ndup, dupblk, dupfil diff -Nru openmolcas-22.02/src/cht3/ex23.F90 openmolcas-22.10/src/cht3/ex23.F90 --- openmolcas-22.02/src/cht3/ex23.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/ex23.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,32 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine EX23(Y,X,I1,I2,J1,J2) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: I1, I2, J1, J2 +real(kind=wp), intent(in) :: Y(I1,I2,J1,J2) +real(kind=wp), intent(out) :: X(I1,J1,I2,J2) +integer(kind=iwp) :: I, J, L + +do J=1,J2 + do L=1,I2 + do I=1,J1 + X(:,I,L,J) = Y(:,L,I,J) + end do + end do +end do + +return + +end subroutine EX23 diff -Nru openmolcas-22.02/src/cht3/exmap3_231.f openmolcas-22.10/src/cht3/exmap3_231.f --- openmolcas-22.02/src/cht3/exmap3_231.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/exmap3_231.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine exMap3_231 (A,B,d1,d2) -c -c this routine do : -c -c A (a,bc) -> B(b,c,a) -c - implicit none - integer d1,d2,i1,i2,i3,i23 - real*8 A(1:d1,1:(d2*(d2+1))/2) - real*8 B(1:d2,1:d2,1:d1) -c - i23=0 - do i2=1,d2 - do i3=1,i2 - i23=i23+1 - do i1=1,d1 -c - B(i2,i3,i1)=A(i1,i23) - B(i3,i2,i1)=A(i1,i23) -c - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/exmap3_231.F90 openmolcas-22.10/src/cht3/exmap3_231.F90 --- openmolcas-22.02/src/cht3/exmap3_231.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/exmap3_231.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,37 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine exMap3_231(A,B,d1,d2) +! this routine does: +! +! A (a,bc) -> B(b,c,a) + +use Index_Functions, only: nTri_Elem +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: d1, d2 +real(kind=wp), intent(in) :: A(d1,nTri_Elem(d2)) +real(kind=wp), intent(out) :: B(d2,d2,d1) +integer(kind=iwp) :: i2, i23, i3 + +i23 = 0 +do i2=1,d2 + do i3=1,i2 + i23 = i23+1 + B(i2,i3,:) = A(:,i23) + B(i3,i2,:) = A(:,i23) + end do +end do + +return + +end subroutine exMap3_231 diff -Nru openmolcas-22.02/src/cht3/expa1_uhf.f openmolcas-22.10/src/cht3/expa1_uhf.f --- openmolcas-22.02/src/cht3/expa1_uhf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/expa1_uhf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE EXPA1_UHF(ARR1,IDM,LI,NSP,ARR2) - implicit none - REAL*8 ARR1,ARR2 - integer IDM,LI,NSP, IJ, I,J,K -C -C THIS SUBROUTINE EXPANDS THE FIRST INDEX OF A MATRIX ARR1 -C -C LI*(LI+1)/2 - DIMENSION ARR1(*),ARR2(LI,LI,*) - IF(NSP.GT.0)THEN - IJ=1 - DO K=1,IDM - DO I=1,LI - CALL DCOPY_(I,ARR1(IJ),1,ARR2(I,1,K),LI) - CALL DCOPY_(I,ARR1(IJ),1,ARR2(1,I,K),1) - IJ=IJ+I - enddo - enddo - ELSE - IJ=1 - DO K=1,IDM - ARR2(1,1,K)=0.D0 - DO I=2,LI - ARR2(I,I,K)=0.D0 - CALL DCOPY_(I-1,ARR1(IJ),1,ARR2(I,1,K),LI) - DO J=1,I-1 - ARR2(J,I,K)=-ARR1(IJ) - IJ=IJ+1 - ENDDO - enddo - enddo - ENDIF - RETURN - END diff -Nru openmolcas-22.02/src/cht3/expa1_uhf.F90 openmolcas-22.10/src/cht3/expa1_uhf.F90 --- openmolcas-22.02/src/cht3/expa1_uhf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/expa1_uhf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,49 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine EXPA1_UHF(ARR1,IDM,LI,NSP,ARR2) +! THIS SUBROUTINE EXPANDS THE FIRST INDEX OF A MATRIX ARR1 +! +! LI*(LI+1)/2 + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(in) :: ARR1(*) +integer(kind=iwp), intent(in) :: IDM, LI, NSP +real(kind=wp), intent(out) :: ARR2(LI,LI,IDM) +integer(kind=iwp) :: I, IJ, K + +if (NSP > 0) then + IJ = 1 + do K=1,IDM + do I=1,LI + ARR2(I,1:I,K) = ARR1(IJ:IJ+I-1) + ARR2(1:I,I,K) = ARR1(IJ:IJ+I-1) + IJ = IJ+I + end do + end do +else + IJ = 1 + do K=1,IDM + do I=1,LI + ARR2(I,1:I-1,K) = ARR1(IJ:IJ+I-2) + ARR2(1:I-1,I,K) = -ARR1(IJ:IJ+I-2) + ARR2(I,I,K) = Zero + IJ = IJ+I-1 + end do + end do +end if + +return + +end subroutine EXPA1_UHF diff -Nru openmolcas-22.02/src/cht3/expa2_uhf.f openmolcas-22.10/src/cht3/expa2_uhf.f --- openmolcas-22.02/src/cht3/expa2_uhf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/expa2_uhf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE EXPA2_UHF(ARR1,IDM,LI,NSP,ARR2) - implicit none - REAL*8 ARR1,ARR2 - integer IDM,LI,NSP, IJ, I,J -C -C THIS SUBROUTINE EXPANDS THE SECOND INDEX OF A MATRIX ARR1 -C - DIMENSION ARR1(IDM,*),ARR2(IDM,LI,*) - IJ=0 - CALL ZEROMA(ARR2(1,1,1),1,IDM) - DO I=2,LI - DO J=1,I-1 - IJ=IJ+1 - CALL DCOPY_(IDM,ARR1(1,IJ),1,ARR2(1,I,J),1) - CALL DCOPY_(IDM,ARR1(1,IJ),1,ARR2(1,J,I),1) - ENDDO - CALL ZEROMA(ARR2(1,I,I),1,IDM) - ENDDO - IF(NSP.LT.0)THEN - DO I=1,LI - CALL VNEG_CHT3(ARR2(1,1,I),1,ARR2(1,1,I),1,IDM*I) - enddo - ENDIF - RETURN - END diff -Nru openmolcas-22.02/src/cht3/expa2_uhf.F90 openmolcas-22.10/src/cht3/expa2_uhf.F90 --- openmolcas-22.02/src/cht3/expa2_uhf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/expa2_uhf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,42 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine EXPA2_UHF(ARR1,IDM,LI,NSP,ARR2) +! THIS SUBROUTINE EXPANDS THE SECOND INDEX OF A MATRIX ARR1 + +use Index_Functions, only: nTri_Elem +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: IDM, LI, NSP +real(kind=wp), intent(in) :: ARR1(IDM,nTri_Elem(LI-1)) +real(kind=wp), intent(out) :: ARR2(IDM,LI,LI) +integer(kind=iwp) :: I, IJ, J + +IJ = 0 +do I=1,LI + do J=1,I-1 + IJ = IJ+1 + ARR2(:,I,J) = ARR1(:,IJ) + ARR2(:,J,I) = ARR1(:,IJ) + end do + ARR2(:,I,I) = Zero +end do +if (NSP < 0) then + do I=1,LI + ARR2(:,1:I,I) = -ARR2(:,1:I,I) + end do +end if + +return + +end subroutine EXPA2_UHF diff -Nru openmolcas-22.02/src/cht3/expand4_12.f openmolcas-22.10/src/cht3/expand4_12.f --- openmolcas-22.02/src/cht3/expand4_12.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/expand4_12.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine expand4_12 (AA,BB,d1,d2,d3) -c -c this routine do : -c -c A(ab,i,j) -> A(a,b,i,j) -c - implicit none - integer d1,d2,d3,a,b,i,j,ab - real*8 AA(1:(d1*(d1+1))/2,d2,d3),BB(1:d1,1:d1,1:d2,1:d3) -c - ab=0 - do a=1,d1 - do b=1,a - ab=ab+1 - do i=1,d2 - do j=1,d3 - BB(a,b,i,j)=AA(ab,i,j) - if (a.ne.b) BB(b,a,j,i)=AA(ab,i,j) - end do - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/expand4_12.F90 openmolcas-22.10/src/cht3/expand4_12.F90 --- openmolcas-22.02/src/cht3/expand4_12.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/expand4_12.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,41 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine expand4_12(AA,BB,d1,d2,d3) +! this routine does: +! +! A(ab,i,j) -> A(a,b,i,j) + +use Index_Functions, only: nTri_Elem +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: d1, d2, d3 +real(kind=wp), intent(in) :: AA(nTri_Elem(d1),d2,d3) +real(kind=wp), intent(out) :: BB(d1,d1,d2,d3) +integer(kind=iwp) :: a, ab, b, i + +ab = 0 +do a=1,d1 + do b=1,a-1 + ab = ab+1 + BB(a,b,:,:) = AA(ab,:,:) + do i=1,d2 + BB(b,a,:,i) = AA(ab,i,:) + end do + end do + ab = ab+1 + BB(a,a,:,:) = AA(ab,:,:) +end do + +return + +end subroutine expand4_12 diff -Nru openmolcas-22.02/src/cht3/ext_o_32.f openmolcas-22.10/src/cht3/ext_o_32.f --- openmolcas-22.02/src/cht3/ext_o_32.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/ext_o_32.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,30 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine ext_o_32 (A,B,nc,no,dima,occ_ind) -c -c this routine do : -c -c extract B (m,a')_i <- A (m,i,a') -c - implicit none - integer i1,i2,occ_ind,dima,nc,no - real*8 A(1:nc,1:no,1:dima),B(1:nc,1:dima) -c - do i2=1,dima - do i1=1,nc -c - B(i1,i2)=A(i1,occ_ind,i2) -c - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/ext_o_32.F90 openmolcas-22.10/src/cht3/ext_o_32.F90 --- openmolcas-22.02/src/cht3/ext_o_32.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/ext_o_32.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,31 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ext_o_32(A,B,nc,no,dima,occ_ind) +! this routine does: +! +! extract B (m,a')_i <- A (m,i,a') + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nc, no, dima, occ_ind +real(kind=wp), intent(in) :: A(nc,no,dima) +real(kind=wp), intent(out) :: B(nc,dima) +integer(kind=iwp) :: i2 + +do i2=1,dima + B(:,i2) = A(:,occ_ind,i2) +end do + +return + +end subroutine ext_o_32 diff -Nru openmolcas-22.02/src/cht3/files.fh openmolcas-22.10/src/cht3/files.fh --- openmolcas-22.02/src/cht3/files.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/files.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -c -c This include contains Names of all used files -c -c1.1 Names of L0-L2 files - Character*6 L0Name - Character*6 L1Name(1:maxGrp) - Character*6 L2Name(1:maxGrp,1:maxGrp) -c -c1.2 Names of T2 files - Character*6 T2Name(1:maxGrp,1:maxGrp) -c -c1.3 Names of I0-3 files - Character*6 I0Name - Character*6 I1Name(1:maxGrp) - Character*6 I2Name(1:maxGrp,1:maxGrp) - Character*6 I3Name(1:maxGrp,1:maxGrp) -c -c1.4 Names of Tmp1,2 files - Character*6 Tmp1Name(1:maxGrp,1:maxGrp) - Character*6 Tmp2Name(1:maxGrp,1:maxGrp) -c -c1.5 Names of Tmp3 file - Character*6 Tmp3Name(1:maxSGrp,1:maxSGrp) -c -c - common /cht3_FilNam1/ L0Name,L1Name,L2Name, - c T2Name, - c I0Name,I1Name,I2Name,I3Name -c - common /cht3_FilNam2/ Tmp1Name,Tmp2Name,Tmp3Name diff -Nru openmolcas-22.02/src/cht3/gather_t2anti_blocked.f openmolcas-22.10/src/cht3/gather_t2anti_blocked.f --- openmolcas-22.02/src/cht3/gather_t2anti_blocked.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/gather_t2anti_blocked.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,110 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine gather_t2anti_blocked( - & length1,length2, - & ngaf,ngal,ngbf,ngbl, - & t2,t2_tmp,tmp) -c -c length1 = length of the 1st VO index (nv) -c length2 = length of the 2nd VO index (=< vblock) -c -c This routine generates T2 amplitudes in this form : -c -c T2 = t2(a,b,j ; a in nv, b in vblock -c - implicit none -#include "cht3_ccsd1.fh" -#include "cht3_reord.fh" -#include "files.fh" -#include "ccsd_t3compat.fh" -c - integer ngaf,ngal,ngbf,ngbl - integer a,b,dima,dimb - integer length - integer lasta,lastb - integer length1,length2 -c - real*8 t2(*),tmp(*),t2_tmp(*) - integer a_tmp,b_tmp -c - logical switch - integer aa,bb -c -cmp write (6,*) -cmp write (6,*) '------ DimGrpaR ------' -cmp write (6,'(8(i5,2x))') (DimGrpaR(a_tmp),a_tmp=1,NvGrp) -cmp write (6,*) -c - do a=1,NvGrp - do b=ngbf,ngbl -c - switch=.false. - if (a.ge.b) then - aa=a - bb=b - else - aa=b - bb=a - switch=.true. - end if -c - dima=DimGrpaR(aa) - dimb=DimGrpaR(bb) -c - if (aa.eq.bb) then ! aa=bb - length=(dima*(dima+1)*no*no)/2 - call GetX_t3 (tmp,length,LunAux,T2Name(aa,bb),1,1) - else ! aa>bb - length=dima*dimb*no*no - call GetX_t3 (tmp,length,LunAux,T2Name(aa,bb),1,1) - end if -c - lasta=0 - if (a.gt.1) then - do a_tmp=1,a-1 - lasta=lasta+DimGrpaR(a_tmp) - end do - end if -c - lastb=0 - if (b.gt.ngbf) then - do b_tmp=ngbf,b-1 - lastb=lastb+DimGrpaR(b_tmp) - end do - end if -c -cmp write (6,'(A,2(i5,2x),L,2(i3,x))') 'lasta, lastb, switch, a, b = ', -cmp & lasta,lastb,switch,a,b -c - if (aa.eq.bb) then ! expand tmp - call expand4_12 (tmp,t2_tmp,dima,no,no) - call grow_t2anti_blocked1(t2,t2_tmp,dima,dimb,nv,no, - & lasta,lastb,length1,length2,a,b) - else - if (.not.switch) then - call grow_t2anti_blocked1(t2,tmp,dima,dimb,nv,no, - & lasta,lastb,length1,length2,a,b) - else - call grow_t2anti_blocked2(t2,tmp,dima,dimb,nv,no, - & lasta,lastb,length1,length2,a,b) - end if - end if -c - end do - end do -c - return -c Avoid unused argument warnings - if (.false.) then - call Unused_integer(ngaf) - call Unused_integer(ngal) - end if - end diff -Nru openmolcas-22.02/src/cht3/gather_t2anti_blocked.F90 openmolcas-22.10/src/cht3/gather_t2anti_blocked.F90 --- openmolcas-22.02/src/cht3/gather_t2anti_blocked.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/gather_t2anti_blocked.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,94 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine gather_t2anti_blocked(length1,length2,ngbf,ngbl,t2,t2_tmp,tmp) +! length1 = length of the 1st VO index (nv) +! length2 = length of the 2nd VO index (=< vblock) +! +! This routine generates T2 amplitudes in this form : +! +! T2 = t2(a,b,j ; a in nv, b in vblock + +use ChT3_global, only: DimGrpaR, LunAux, no, NvGrp, T2Name +use Index_Functions, only: nTri_Elem +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: length1, length2, ngbf, ngbl +real(kind=wp), intent(inout) :: t2(*) +real(kind=wp), intent(_OUT_) :: t2_tmp(*), tmp(*) +integer(kind=iwp) :: a, a_tmp, aa, b, b_tmp, bb, dima, dimb, lasta, lastb, length +logical(kind=iwp) :: switch + +!mp write(u6,*) +!mp write(u6,*) '------ DimGrpaR ------' +!mp write(u6,'(8(i5,2x))') (DimGrpaR(a_tmp),a_tmp=1,NvGrp) +!mp write(u6,*) + +do a=1,NvGrp + do b=ngbf,ngbl + + switch = .false. + if (a >= b) then + aa = a + bb = b + else + aa = b + bb = a + switch = .true. + end if + + dima = DimGrpaR(aa) + dimb = DimGrpaR(bb) + + if (aa == bb) then ! aa=bb + length = nTri_Elem(dima)*no*no + call GetX_t3(tmp,length,LunAux,T2Name(aa,bb),1,1) + else ! aa>bb + length = dima*dimb*no*no + call GetX_t3(tmp,length,LunAux,T2Name(aa,bb),1,1) + end if + + lasta = 0 + if (a > 1) then + do a_tmp=1,a-1 + lasta = lasta+DimGrpaR(a_tmp) + end do + end if + + lastb = 0 + if (b > ngbf) then + do b_tmp=ngbf,b-1 + lastb = lastb+DimGrpaR(b_tmp) + end do + end if + + !mp write(u6,'(A,2(i5,2x),L,2(i3,x))') 'lasta, lastb, switch, a, b = ',lasta,lastb,switch,a,b + + if (aa == bb) then ! expand tmp + call expand4_12(tmp,t2_tmp,dima,no,no) + call grow_t2anti_blocked1(t2,t2_tmp,dima,dimb,no,lasta,lastb,length1,length2) + else + if (.not. switch) then + call grow_t2anti_blocked1(t2,tmp,dima,dimb,no,lasta,lastb,length1,length2) + else + call grow_t2anti_blocked2(t2,tmp,dima,dimb,no,lasta,lastb,length1,length2) + end if + end if + + end do +end do + +return + +end subroutine gather_t2anti_blocked diff -Nru openmolcas-22.02/src/cht3/gather_t2_blocked.f openmolcas-22.10/src/cht3/gather_t2_blocked.f --- openmolcas-22.02/src/cht3/gather_t2_blocked.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/gather_t2_blocked.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,95 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine gather_t2_blocked( - & length1,length2, - & ngaf,ngal,ngbf,ngbl, - & t2,t2_tmp,tmp,switch) -c -c length1 = length of the 1st VO index (=< vblock) -c length2 = length of the 2nd VO index (=< vblock) -c -c - implicit none -#include "cht3_ccsd1.fh" -#include "cht3_reord.fh" -#include "files.fh" -#include "ccsd_t3compat.fh" -c - integer ngaf,ngal,ngbf,ngbl - integer a,b,dima,dimb -cmp integer length - integer length - integer lasta,lastb - integer length1,length2 -c - real*8 t2(1:(length1*length2*no*no)) - real*8 tmp(1:(maxdim*maxdim*no*no)) - real*8 t2_tmp(1:(maxdim*maxdim*no*no)) - integer a_tmp,b_tmp -c - logical sym - logical switch -c - sym=.false. -c -cmp if (ngaf.eq.ngbf) sym=.true. - if ((ngaf.eq.ngbf).and.(ngal.eq.ngbl)) sym=.true. -c -cmp write (6,*) -cmp write (6,*) '------ DimGrpaR ------' -cmp write (6,'(8(i5,2x))') (DimGrpaR(a_tmp),a_tmp=1,NvGrp) -cmp write (6,*) -c - do a=ngaf,ngal - do b=ngbf,min0(a,ngbl) -c - dima=DimGrpaR(a) - dimb=DimGrpaR(b) -c - if (a.eq.b) then ! a=b - length=(dima*(dima+1)*no*no)/2 - call GetX_t3 (tmp,length,LunAux,T2Name(a,b),1,1) - else ! a>b - length=dima*dimb*no*no - call GetX_t3 (tmp,length,LunAux,T2Name(a,b),1,1) - end if -c - lasta=0 - if (a.gt.ngaf) then - do a_tmp=ngaf,a-1 - lasta=lasta+DimGrpaR(a_tmp) - end do - end if -c - lastb=0 - if (b.gt.ngbf) then - do b_tmp=ngbf,b-1 - lastb=lastb+DimGrpaR(b_tmp) - end do - end if -c -cmp write (6,'(A,2(i5,2x),2(i3,x))') 'lasta, lastb, a, b = ', -cmp & lasta,lastb,a,b -c - if (a.eq.b) then ! expand and map - call expand4_12 (tmp,t2_tmp,dima,no,no) - call grow_t2_blocked(t2,t2_tmp,dima,dimb,nv,no, - & lasta,lastb,length1,length2,a,b,sym,switch) - else - call grow_t2_blocked(t2,tmp,dima,dimb,nv,no, - & lasta,lastb,length1,length2,a,b,sym,switch) - end if -c - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/gather_t2_blocked.F90 openmolcas-22.10/src/cht3/gather_t2_blocked.F90 --- openmolcas-22.02/src/cht3/gather_t2_blocked.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/gather_t2_blocked.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,79 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine gather_t2_blocked(length1,length2,ngaf,ngal,ngbf,ngbl,t2,t2_tmp,tmp) +! length1 = length of the 1st VO index (=< vblock) +! length2 = length of the 2nd VO index (=< vblock) + +use ChT3_global, only: DimGrpaR, LunAux, maxdim, no, T2Name +use Index_Functions, only: nTri_Elem +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: length1, length2, ngaf, ngal, ngbf, ngbl +real(kind=wp), intent(inout) :: t2(length1*length2*no*no) +real(kind=wp), intent(out) :: t2_tmp(maxdim*maxdim*no*no), tmp(maxdim*maxdim*no*no) +integer(kind=iwp) :: a, a_tmp, b, b_tmp, dima, dimb, lasta, lastb, length +logical(kind=iwp) :: sym + +sym = .false. + +!mp if (ngaf == ngbf) sym = .true. +if ((ngaf == ngbf) .and. (ngal == ngbl)) sym = .true. + +!mp write(u6,*) +!mp write(u6,*) '------ DimGrpaR ------' +!mp write(u6,'(8(i5,2x))') (DimGrpaR(a_tmp),a_tmp=1,NvGrp) +!mp write(u6,*) + +do a=ngaf,ngal + do b=ngbf,min(a,ngbl) + + dima = DimGrpaR(a) + dimb = DimGrpaR(b) + + if (a == b) then ! a=b + length = nTri_Elem(dima)*no*no + call GetX_t3(tmp,length,LunAux,T2Name(a,b),1,1) + else ! a>b + length = dima*dimb*no*no + call GetX_t3(tmp,length,LunAux,T2Name(a,b),1,1) + end if + + lasta = 0 + if (a > ngaf) then + do a_tmp=ngaf,a-1 + lasta = lasta+DimGrpaR(a_tmp) + end do + end if + + lastb = 0 + if (b > ngbf) then + do b_tmp=ngbf,b-1 + lastb = lastb+DimGrpaR(b_tmp) + end do + end if + + !mp write(u6,'(A,2(i5,2x),2(i3,x))') 'lasta, lastb, a, b = ',lasta,lastb,a,b + + if (a == b) then ! expand and map + call expand4_12(tmp,t2_tmp,dima,no,no) + call grow_t2_blocked(t2,t2_tmp,dima,dimb,no,lasta,lastb,length1,length2,sym) + else + call grow_t2_blocked(t2,tmp,dima,dimb,no,lasta,lastb,length1,length2,sym) + end if + + end do +end do + +return + +end subroutine gather_t2_blocked diff -Nru openmolcas-22.02/src/cht3/gather_t2.f openmolcas-22.10/src/cht3/gather_t2.f --- openmolcas-22.02/src/cht3/gather_t2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/gather_t2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,117 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine gather_t2(t2,t2_tmp,tmp) -c -c temporary routine. In future T2 block structure will be merged -c with the block structure of the (T) code -c -c this routine do : -c -c cycle through T2XY files and gather them into on T2 array -c T2(nv_beta,nv_alpha,no_beta,no_alpha) -c - implicit none -#include "cht3_ccsd1.fh" -#include "cht3_reord.fh" -#include "files.fh" -#include "ccsd_t3compat.fh" -c - integer a,b,dima,dimb -cmp integer length - integer length - integer lasta,lastb -c - real*8 t2(*),tmp(*),t2_tmp(*) - integer a_tmp,b_tmp -c -cmp write (6,*) -cmp write (6,*) '------ DimGrpaR ------' -cmp write (6,'(8(i5,2x))') (DimGrpaR(a_tmp),a_tmp=1,NvGrp) -cmp write (6,*) -c - do a=1,NvGrp - do b=1,a -c -cmp@@ dima=nv/NvGrp - dima=DimGrpaR(a) - dimb=DimGrpaR(b) -c -cmp write (6,'(A,i3,i3,2x,A6)') 'a,b,T2Name(a,b) ',a,b,T2Name(a,b) -c - if (a.eq.b) then ! a=b -c open the pertinent file -c -cmp@@ if (a.eq.NvGrp) dima=nv-((NvGrp-1)*dima) - dimb=dima -c -cmp write (6,*) 'dima = ',dima - length=(dima*(dima+1)*no*no)/2 -cmp write (6,*) 'length = ',length -cmp! write (6,*) 'file size (g77) = ',16+length*8 -cmp write (6,*) 'file size (ifort) = ',8+length*8 -c - call GetX_t3 (tmp,length,LunAux,T2Name(a,b),1,1) -c - else ! a>b -c open the pertinent file -c -cmp@@ if (a.eq.NvGrp) dima=nv-((NvGrp-1)*dima) -cmp@@ if (b.eq.NvGrp) dimb=nv-((NvGrp-1)*dimb) -c -cmp write (6,*) 'dima = ',dima -cmp write (6,*) 'dimb = ',dimb - length=dima*dimb*no*no -cmp write (6,*) 'length = ',length -cmp! write (6,*) 'file size (g77) = ',16+length*8 -cmp write (6,*) 'file size (ifort) = ',8+length*8 -c - call GetX_t3 (tmp,length,LunAux,T2Name(a,b),1,1) -c - end if -c -c add its contents to the t2 array -c -cmp@@ lasta=(a-1)*(nv/NvGrp) -cmp@@ lastb=(b-1)*(nv/NvGrp) -cmp@@ - lasta=0 - if (a.gt.1) then - do a_tmp=1,a-1 - lasta=lasta+DimGrpaR(a_tmp) - end do - end if -c - lastb=0 - if (b.gt.1) then - do b_tmp=1,b-1 - lastb=lastb+DimGrpaR(b_tmp) - end do - end if -cmp@@ -c -cmp write (6,'(A,2(i5,2x),2(i3,x))') 'lasta, lastb, a, b = ', -cmp & lasta,lastb,a,b -c - if (a.eq.b) then ! expand and map -c expand and map l2_1 (a',b',m) <- tmp (m,ab') - call expand4_12 (tmp,t2_tmp,dima,no,no) - call grow_t2neq(t2,t2_tmp,dima,dimb,nv,no, - & lasta,lastb) - else - call grow_t2neq(t2,tmp,dima,dimb,nv,no, - & lasta,lastb) - end if -c - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/gather_t2.F90 openmolcas-22.10/src/cht3/gather_t2.F90 --- openmolcas-22.02/src/cht3/gather_t2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/gather_t2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,112 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine gather_t2(t2,t2_tmp,tmp) +! temporary routine. In future T2 block structure will be merged +! with the block structure of the (T) code +! +! this routine does: +! +! cycle through T2XY files and gather them into on T2 array +! T2(nv_beta,nv_alpha,no_beta,no_alpha) + +use ChT3_global, only: DimGrpaR, LunAux, no, nv, NvGrp, T2Name +use Index_Functions, only: nTri_Elem +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +real(kind=wp), intent(inout) :: t2(*) +real(kind=wp), intent(_OUT_) :: t2_tmp(*), tmp(*) +integer(kind=iwp) :: a, a_tmp, b, b_tmp, dima, dimb, lasta, lastb, length + +!mp write(u6,*) +!mp write(u6,*) '------ DimGrpaR ------' +!mp write(u6,'(8(i5,2x))') (DimGrpaR(a_tmp),a_tmp=1,NvGrp) +!mp write(u6,*) + +do a=1,NvGrp + do b=1,a + + !mp@@ dima = nv/NvGrp + dima = DimGrpaR(a) + dimb = DimGrpaR(b) + + !mp write(u6,'(A,i3,i3,2x,A6)') 'a,b,T2Name(a,b) ',a,b,T2Name(a,b) + + if (a == b) then ! a=b + ! open the pertinent file + + !mp@@ if (a == NvGrp) dima = nv-((NvGrp-1)*dima) + dimb = dima + + !mp write(u6,*) 'dima = ',dima + length = nTri_Elem(dima)*no*no + !mp write(u6,*) 'length = ',length + !mp !write(u6,*) 'file size (g77) = ',16+length*8 + !mp write(u6,*) 'file size (ifort) = ',8+length*8 + + call GetX_t3(tmp,length,LunAux,T2Name(a,b),1,1) + + else ! a>b + ! open the pertinent file + + !mp@@ if (a == NvGrp) dima = nv-((NvGrp-1)*dima) + !mp@@ if (b == NvGrp) dimb = nv-((NvGrp-1)*dimb) + + !mp write(u6,*) 'dima = ',dima + !mp write(u6,*) 'dimb = ',dimb + length = dima*dimb*no*no + !mp write(u6,*) 'length = ',length + !mp !write(u6,*) 'file size (g77) = ',16+length*8 + !mp write(u6,*) 'file size (ifort) = ',8+length*8 + + call GetX_t3(tmp,length,LunAux,T2Name(a,b),1,1) + + end if + + ! add its contents to the t2 array + + !mp@@ lasta = (a-1)*(nv/NvGrp) + !mp@@ lastb = (b-1)*(nv/NvGrp) + !mp@@ + lasta = 0 + if (a > 1) then + do a_tmp=1,a-1 + lasta = lasta+DimGrpaR(a_tmp) + end do + end if + + lastb = 0 + if (b > 1) then + do b_tmp=1,b-1 + lastb = lastb+DimGrpaR(b_tmp) + end do + end if + !mp@@ + + !mp write(u6,'(A,2(i5,2x),2(i3,x))') 'lasta, lastb, a, b = ',lasta,lastb,a,b + + if (a == b) then ! expand and map + ! expand and map l2_1 (a',b',m) <- tmp (m,ab') + call expand4_12(tmp,t2_tmp,dima,no,no) + call grow_t2neq(t2,t2_tmp,dima,dimb,nv,no,lasta,lastb) + else + call grow_t2neq(t2,tmp,dima,dimb,nv,no,lasta,lastb) + end if + + end do +end do + +return + +end subroutine gather_t2 diff -Nru openmolcas-22.02/src/cht3/gather_t2_fblocked.f openmolcas-22.10/src/cht3/gather_t2_fblocked.f --- openmolcas-22.02/src/cht3/gather_t2_fblocked.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/gather_t2_fblocked.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,110 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine gather_t2_fblocked( - & length1,length2, - & ngaf,ngal,ngbf,ngbl, - & t2,t2_tmp,tmp) -c -c length1 = length of the 1st VO index (nv) -c length2 = length of the 2nd VO index (=< vblock) -c -c This routine generates T2 amplitudes in this form : -c -c T2 = t2(a,b,j ; a in nv, b in vblock -c - implicit none -#include "cht3_ccsd1.fh" -#include "cht3_reord.fh" -#include "files.fh" -#include "ccsd_t3compat.fh" -c - integer ngaf,ngal,ngbf,ngbl - integer a,b,dima,dimb - integer length - integer lasta,lastb - integer length1,length2 -c - real*8 t2(*),tmp(*),t2_tmp(*) - integer a_tmp,b_tmp -c - logical switch - integer aa,bb -c -cmp write (6,*) -cmp write (6,*) '------ DimGrpaR ------' -cmp write (6,'(8(i5,2x))') (DimGrpaR(a_tmp),a_tmp=1,NvGrp) -cmp write (6,*) -c - do a=1,NvGrp - do b=ngbf,ngbl -c - switch=.false. - if (a.ge.b) then - aa=a - bb=b - else - aa=b - bb=a - switch=.true. - end if -c - dima=DimGrpaR(aa) - dimb=DimGrpaR(bb) -c - if (aa.eq.bb) then ! aa=bb - length=(dima*(dima+1)*no*no)/2 - call GetX_t3 (tmp,length,LunAux,T2Name(aa,bb),1,1) - else ! aa>bb - length=dima*dimb*no*no - call GetX_t3 (tmp,length,LunAux,T2Name(aa,bb),1,1) - end if -c - lasta=0 - if (a.gt.1) then - do a_tmp=1,a-1 - lasta=lasta+DimGrpaR(a_tmp) - end do - end if -c - lastb=0 - if (b.gt.ngbf) then - do b_tmp=ngbf,b-1 - lastb=lastb+DimGrpaR(b_tmp) - end do - end if -c -cmp write (6,'(A,2(i5,2x),L,2(i3,x))') 'lasta, lastb, switch, a, b = ', -cmp & lasta,lastb,switch,a,b -c - if (aa.eq.bb) then ! expand tmp - call expand4_12 (tmp,t2_tmp,dima,no,no) - call grow_t2_fblocked1(t2,t2_tmp,dima,dimb,nv,no, - & lasta,lastb,length1,length2,a,b) - else - if (.not.switch) then - call grow_t2_fblocked1(t2,tmp,dima,dimb,nv,no, - & lasta,lastb,length1,length2,a,b) - else - call grow_t2_fblocked2(t2,tmp,dima,dimb,nv,no, - & lasta,lastb,length1,length2,a,b) - end if - end if -c - end do - end do -c - return -c Avoid unused argument warnings - if (.false.) then - call Unused_integer(ngaf) - call Unused_integer(ngal) - end if - end diff -Nru openmolcas-22.02/src/cht3/gather_t2_fblocked.F90 openmolcas-22.10/src/cht3/gather_t2_fblocked.F90 --- openmolcas-22.02/src/cht3/gather_t2_fblocked.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/gather_t2_fblocked.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,94 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine gather_t2_fblocked(length1,length2,ngbf,ngbl,t2,t2_tmp,tmp) +! length1 = length of the 1st VO index (nv) +! length2 = length of the 2nd VO index (=< vblock) +! +! This routine generates T2 amplitudes in this form: +! +! T2 = t2(a,b,j ; a in nv, b in vblock + +use ChT3_global, only: DimGrpaR, LunAux, no, NvGrp, T2Name +use Index_Functions, only: nTri_Elem +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: length1, length2, ngbf, ngbl +real(kind=wp), intent(inout) :: t2(*) +real(kind=wp), intent(_OUT_) :: t2_tmp(*), tmp(*) +integer(kind=iwp) :: a, a_tmp, aa, b, b_tmp, bb, dima, dimb, lasta, lastb, length +logical(kind=iwp) :: switch + +!mp write(u6,*) +!mp write(u6,*) '------ DimGrpaR ------' +!mp write(u6,'(8(i5,2x))') (DimGrpaR(a_tmp),a_tmp=1,NvGrp) +!mp write(u6,*) + +do a=1,NvGrp + do b=ngbf,ngbl + + switch = .false. + if (a >= b) then + aa = a + bb = b + else + aa = b + bb = a + switch = .true. + end if + + dima = DimGrpaR(aa) + dimb = DimGrpaR(bb) + + if (aa == bb) then ! aa=bb + length = nTri_Elem(dima)*no*no + call GetX_t3(tmp,length,LunAux,T2Name(aa,bb),1,1) + else ! aa>bb + length = dima*dimb*no*no + call GetX_t3(tmp,length,LunAux,T2Name(aa,bb),1,1) + end if + + lasta = 0 + if (a > 1) then + do a_tmp=1,a-1 + lasta = lasta+DimGrpaR(a_tmp) + end do + end if + + lastb = 0 + if (b > ngbf) then + do b_tmp=ngbf,b-1 + lastb = lastb+DimGrpaR(b_tmp) + end do + end if + + !mp write(u6,'(A,2(i5,2x),L,2(i3,x))') 'lasta, lastb, switch, a, b = ',lasta,lastb,switch,a,b + + if (aa == bb) then ! expand tmp + call expand4_12(tmp,t2_tmp,dima,no,no) + call grow_t2_fblocked1(t2,t2_tmp,dima,dimb,no,lasta,lastb,length1,length2) + else + if (.not. switch) then + call grow_t2_fblocked1(t2,tmp,dima,dimb,no,lasta,lastb,length1,length2) + else + call grow_t2_fblocked2(t2,tmp,dima,dimb,no,lasta,lastb,length1,length2) + end if + end if + + end do +end do + +return + +end subroutine gather_t2_fblocked diff -Nru openmolcas-22.02/src/cht3/generate_juzekoe.f openmolcas-22.10/src/cht3/generate_juzekoe.f --- openmolcas-22.02/src/cht3/generate_juzekoe.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/generate_juzekoe.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine generate_juzekOE (oe,oeh,oep,no,nv) -c -c this routine do : -c -c modifies standar oe record to one used by DIRCC -c -c oeh = ( oe_occ(alpha) ... oe_occ(beta) ) (alpha=beta for this -c implementation) -c -c oep = ( oe_virt(alpha) ... oe_virt(beta) ) (alpha=beta for this -c implementation) - implicit none - integer i,no,nv -c - real*8 oe(*),oeh(*),oep(*) -c -c - do i=1,no - oeh(i)=oe(i) - oeh(i+no)=oe(i) - end do -c - do i=1,nv - oep(i)=oe(no+i) - oep(i+nv)=oe(no+i) - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/generate_juzekoe.F90 openmolcas-22.10/src/cht3/generate_juzekoe.F90 --- openmolcas-22.02/src/cht3/generate_juzekoe.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/generate_juzekoe.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,36 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine generate_juzekOE(oe,oeh,oep,no,nv) +! this routine does: +! +! modifies standard oe record to one used by DIRCC +! +! oeh = ( oe_occ(alpha) ... oe_occ(beta) ) (alpha=beta for this implementation) +! +! oep = ( oe_virt(alpha) ... oe_virt(beta) ) (alpha=beta for this implementation) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: no, nv +real(kind=wp), intent(in) :: oe(no+nv) +real(kind=wp), intent(out) :: oeh(no,2), oep(nv,2) + +oeh(:,1) = oe(1:no) +oeh(:,2) = oe(1:no) + +oep(:,1) = oe(no+1:no+nv) +oep(:,2) = oe(no+1:no+nv) + +return + +end subroutine generate_juzekOE diff -Nru openmolcas-22.02/src/cht3/gen_oovo.f openmolcas-22.10/src/cht3/gen_oovo.f --- openmolcas-22.02/src/cht3/gen_oovo.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/gen_oovo.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,100 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine gen_oovo (w,l0,l1,tmp) -c -c this routine genetates (ij,a,k) integrals from -c blocked MO cholesky vectors -c -c -------- -c -c L0(m,IJ) L0vctr I>=J -c L1(m,I ,A') L1vcxx xx - Group of A' -c - - implicit none -c -#include "cht3_ccsd1.fh" -#include "cht3_reord.fh" -#include "files.fh" -#include "ccsd_t3compat.fh" -c - real*8 tmp(*),l0(*),l1(*),w(*) - integer a,dima,length,last -c - integer a_tmp -c -c1 read tmp(m,IJ) -c - length=nc*(no*(no+1))/2 -c -cmp! write (6,'(A,A6)') 'L0vcrt ','L0vcrt' -cmp! write (6,*) 'length = ',length -cmp! write (6,*) 'file size (ifort) = ',8+8*length -c - call GetX_t3 (tmp,length,LunAux,'L0vctr',1,1) -c2 map l0(IJ,m) <- tmp(m,IJ) -c - call Map2_21_t3 (tmp,l0,nc,(no*(no+1)/2)) -c -c3 loop over A' -c - do a=1,NvGrp -cmp@@ dima=nv/NvGrp - dima=DimGrpaR(a) -c -c4 read tmp(m,I,A') -c -cmp! write (6,'(A,i3,2x,A6)') 'a,L1Name(a) ',a,L1Name(a) -c -cmp@@ if (a.eq.NvGrp) dima=nv-((NvGrp-1)*dima) -c -cmp! write (6,*) 'dima = ',dima - length=nc*no*dima -cmp! write (6,*) 'length = ',length -cmp! write (6,*) 'file size (ifort) = ',8+8*length -c - call GetX_t3 (tmp,length,LunAux,L1Name(a),1,1) -c -c5 grow l1(m,I,A) -c -cmp last=(a-1)*(nv/NvGrp) -c - last=0 - if (a.gt.1) then - do a_tmp=1,a-1 - last=last+DimGrpaR(a_tmp) - end do - end if -c - call grow_l1(l1,tmp,dima,nc,no,nv,last) -c -c6 end loop over A' -c - end do -c -c7 map tmp(m,A,I) <- l1(m,I,A) -c - call Map3_132_t3 (l1,tmp,nc,no,nv) -c -c7.1 zero w -c - call zeroma (w,1,((no*(no+1))/2)*nv*no) -c -c8 mult w(IJ,A,I) <- l0(IJ,m) . tmp(m,A,I) -c - call mc0c1a3b ( - & (no*(no+1))/2,nc, - & nc,nv*no, - & (no*(no+1))/2,nv*no, - & (no*(no+1))/2,nc,nv*no,l0,tmp,w) -c - return - end diff -Nru openmolcas-22.02/src/cht3/gen_oovo.F90 openmolcas-22.10/src/cht3/gen_oovo.F90 --- openmolcas-22.02/src/cht3/gen_oovo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/gen_oovo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,97 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine gen_oovo(w,l0,l1,tmp) +! this routine genetates (ij,a,k) integrals from +! blocked MO cholesky vectors +! +! -------- +! +! L0(m,IJ) L0vctr I>=J +! L1(m,I ,A') L1vcxx xx - Group of A' + +use ChT3_global, only: DimGrpaR, L1Name, LunAux, nc, no, nv, NvGrp +use Index_Functions, only: nTri_Elem +use Constants, only: Zero +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +real(kind=wp), intent(_OUT_) :: w(*), l0(*), tmp(*) +real(kind=wp), intent(inout) :: l1(*) +integer(kind=iwp) :: a, a_tmp, dima, last, length + +!1 read tmp(m,IJ) + +length = nc*nTri_Elem(no) + +!mp !write(u6,'(A,A6)') 'L0vcrt ','L0vcrt' +!mp !write(u6,*) 'length = ',length +!mp !write(u6,*) 'file size (ifort) = ',8+8*length + +call GetX_t3(tmp,length,LunAux,'L0vctr',1,1) + +!2 map l0(IJ,m) <- tmp(m,IJ) + +call Map2_21_t3(tmp,l0,nc,nTri_Elem(no)) + +!3 loop over A' + +do a=1,NvGrp + !mp@@ dima = nv/NvGrp + dima = DimGrpaR(a) + + !4 read tmp(m,I,A') + + !mp !write(u6,'(A,i3,2x,A6)') 'a,L1Name(a) ',a,L1Name(a) + + !mp@@ if (a == NvGrp) dima = nv-((NvGrp-1)*dima) + + !mp !write(u6,*) 'dima = ',dima + length = nc*no*dima + !mp !write(u6,*) 'length = ',length + !mp !write(u6,*) 'file size (ifort) = ',8+8*length + + call GetX_t3(tmp,length,LunAux,L1Name(a),1,1) + + !5 grow l1(m,I,A) + + !mp last = (a-1)*(nv/NvGrp) + + last = 0 + if (a > 1) then + do a_tmp=1,a-1 + last = last+DimGrpaR(a_tmp) + end do + end if + + call grow_l1(l1,tmp,dima,nc,no,nv,last) + + !6 end loop over A' + +end do + +!7 map tmp(m,A,I) <- l1(m,I,A) + +call Map3_132_t3(l1,tmp,nc,no,nv) + +!7.1 zero w + +w(1:nTri_Elem(no)*nv*no) = Zero + +!8 mult w(IJ,A,I) <- l0(IJ,m) . tmp(m,A,I) + +call mc0c1a3b(nTri_Elem(no),nc,nc,nv*no,nTri_Elem(no),nv*no,nTri_Elem(no),nc,nv*no,l0,tmp,w) + +return + +end subroutine gen_oovo diff -Nru openmolcas-22.02/src/cht3/gen_vvoo_blocked.f openmolcas-22.10/src/cht3/gen_vvoo_blocked.f --- openmolcas-22.02/src/cht3/gen_vvoo_blocked.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/gen_vvoo_blocked.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,119 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine gen_vvoo_blocked (w,l1,tmp,l2, - & length1,length2,ngaf,ngal,ngbf,ngbl) -c -c this routine do -c -c regenerate (ab,ij) integrals from blocked -c MO cholesky vectors -c -c -c -c -------- -c -c L1(m,I,A') -c - implicit none -#include "cht3_ccsd1.fh" -#include "cht3_reord.fh" -#include "files.fh" -#include "ccsd_t3compat.fh" -c - real*8 tmp(*),l1(*),w(*),l2(*) - integer a,b,dima,dimb,length,lasta,lastb - integer a_tmp,b_tmp -c - integer ngaf,ngal,ngbf,ngbl - integer length1,length2 - logical sym -c - sym=.false. -c - if ((ngaf.eq.ngbf).and.(ngal.eq.ngbl)) sym=.true. -c - do a=ngaf,ngal -c -c1 read tmp(m,I,A') -c - dima=DimGrpaR(a) - length=nc*no*dima - call GetX_t3 (tmp,length,LunAux,L1Name(a),1,1) -c -c5 map l1 (A',I,m) <- tmp (m,I,A') -c - call Map3_321_t3 (tmp,l1,nc,no,dima) -c -c ----- read tmp(m,I,B') -c - do b=ngbf,min0(a,ngbl) -c - dimb=DimGrpaR(b) - length=nc*no*dimb - call GetX_t3 (tmp,length,LunAux,L1Name(b),1,1) -c -c4 map l2 (m,B',I) <- tmp (m,I,B') -c - call Map3_132_t3 (tmp,l2,nc,no,dimb) -c -c zero tmp -c - call zeroma (tmp,1,dima*no*dimb*no) -c -c7 mult tmp(A',I,B',J) <- l1 (A',I,m) . l2(m,B',J) -c - call mc0c1a3b ( - & dima*no,nc,nc,dimb*no, - & dima*no,dimb*no, - & dima*no,nc,dimb*no,l1,l2,tmp) -c - lasta=0 - if (a.gt.ngaf) then - do a_tmp=ngaf,a-1 - lasta=lasta+DimGrpaR(a_tmp) - end do - end if -c - lastb=0 - if (b.gt.ngbf) then - do b_tmp=ngbf,b-1 - lastb=lastb+DimGrpaR(b_tmp) - end do - end if -c -c8 grow w(A',B',I,J) <- tmp(A',I,B',J) -c -cmp write (6,'(A,6(i4,x))') 'BB1 dima, dimb, lasta, lastb ', -cmp & dima,dimb,lasta,lastb,a,b - call grow_vvoo_blocked(w,tmp,no,nv,dima,dimb,lasta,lastb, - & length1,length2,a,b,sym) -c -c? if (a.ne.b) then -c?c -c? call Map4_3412_t3 (tmp,l2,dima,no,dimb,no) -c?c -c?c write (6,'(A,4(i4,x))') 'BB2 dima, dimb, lasta, lastb ', -c?c & dimb,dima,lastb,lasta -c? call grow_vvoo_blocked(w,l2,no,nv,dimb,dima,lastb,lasta, -c? & length1,length2,a,b) -c?c -c? end if -c -c3 end loop over B' -c - end do -c -c3 end loop over A' -c - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/gen_vvoo_blocked.F90 openmolcas-22.10/src/cht3/gen_vvoo_blocked.F90 --- openmolcas-22.02/src/cht3/gen_vvoo_blocked.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/gen_vvoo_blocked.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,111 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine gen_vvoo_blocked(w,l1,tmp,l2,length1,length2,ngaf,ngal,ngbf,ngbl) +! this routine does: +! +! regenerate (ab,ij) integrals from blocked +! MO cholesky vectors +! +! +! +! -------- +! +! L1(m,I,A') + +use ChT3_global, only: DimGrpaR, L1Name, LunAux, nc, no +use Constants, only: Zero +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +real(kind=wp), intent(inout) :: w(*) +real(kind=wp), intent(_OUT_) :: l1(*), tmp(*), l2(*) +integer(kind=iwp), intent(in) :: length1, length2, ngaf, ngal, ngbf, ngbl +integer(kind=iwp) :: a, a_tmp, b, b_tmp, dima, dimb, lasta, lastb, length +logical(kind=iwp) :: sym + +sym = .false. + +if ((ngaf == ngbf) .and. (ngal == ngbl)) sym = .true. + +do a=ngaf,ngal + + !1 read tmp(m,I,A') + + dima = DimGrpaR(a) + length = nc*no*dima + call GetX_t3(tmp,length,LunAux,L1Name(a),1,1) + + !5 map l1 (A',I,m) <- tmp (m,I,A') + + call Map3_321_t3(tmp,l1,nc,no,dima) + + ! ----- read tmp(m,I,B') + + do b=ngbf,min(a,ngbl) + + dimb = DimGrpaR(b) + length = nc*no*dimb + call GetX_t3(tmp,length,LunAux,L1Name(b),1,1) + + !4 map l2 (m,B',I) <- tmp (m,I,B') + + call Map3_132_t3(tmp,l2,nc,no,dimb) + + ! zero tmp + + tmp(1:dima*no*dimb*no) = Zero + + !7 mult tmp(A',I,B',J) <- l1 (A',I,m) . l2(m,B',J) + + call mc0c1a3b(dima*no,nc,nc,dimb*no,dima*no,dimb*no,dima*no,nc,dimb*no,l1,l2,tmp) + + lasta = 0 + if (a > ngaf) then + do a_tmp=ngaf,a-1 + lasta = lasta+DimGrpaR(a_tmp) + end do + end if + + lastb = 0 + if (b > ngbf) then + do b_tmp=ngbf,b-1 + lastb = lastb+DimGrpaR(b_tmp) + end do + end if + + !8 grow w(A',B',I,J) <- tmp(A',I,B',J) + + !mp write(u6,'(A,6(i4,x))') 'BB1 dima, dimb, lasta, lastb ',dima,dimb,lasta,lastb,a,b + call grow_vvoo_blocked(w,tmp,no,dima,dimb,lasta,lastb,length1,length2,sym) + + !? if (a /= b) then + !? + !? call Map4_3412_t3 (tmp,l2,dima,no,dimb,no) + !? + !? !write(u6,'(A,4(i4,x))') 'BB2 dima, dimb, lasta, lastb ',dimb,dima,lastb,lasta + !? call grow_vvoo_blocked(w,l2,no,nv,dimb,dima,lastb,lasta,length1,length2,a,b) + !? + !? end if + + !3 end loop over B' + + end do + + !3 end loop over A' + +end do + +return + +end subroutine gen_vvoo_blocked diff -Nru openmolcas-22.02/src/cht3/gen_vvoo.f openmolcas-22.10/src/cht3/gen_vvoo.f --- openmolcas-22.02/src/cht3/gen_vvoo.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/gen_vvoo.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,106 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine gen_vvoo (w,l1,tmp,l2) -c -c this routine do -c -c regenerate (ab,ij) integrals from blocked -c MO cholesky vectors -c -c = (vo|vo) -c -c -------- -c -c L1(m,I,A') -c - implicit none -#include "cht3_ccsd1.fh" -#include "cht3_reord.fh" -#include "files.fh" -#include "ccsd_t3compat.fh" -c - real*8 tmp(*),l1(*),w(*),l2(*) - integer a,b,dima,dimb,length,lasta,lastb - integer a_tmp,b_tmp -c - do a=1,NvGrp -c -c1 read tmp(m,I,A') -c - dima=DimGrpaR(a) - length=nc*no*dima - call GetX_t3 (tmp,length,LunAux,L1Name(a),1,1) -c -c5 map l1 (A',I,m) <- tmp (m,I,A') -c - call Map3_321_t3 (tmp,l1,nc,no,dima) -c -c ----- read tmp(m,I,B') -c - do b=1,a -c - dimb=DimGrpaR(b) - length=nc*no*dimb - call GetX_t3 (tmp,length,LunAux,L1Name(b),1,1) -c -c4 map l2 (m,B',I) <- tmp (m,I,B') -c - call Map3_132_t3 (tmp,l2,nc,no,dimb) -c -c zero tmp -c - call zeroma (tmp,1,dima*no*dimb*no) -c -c7 mult tmp(A',I,B',J) <- l1 (A',I,m) . l2(m,B',J) -c - call mc0c1a3b ( - & dima*no,nc,nc,dimb*no, - & dima*no,dimb*no, - & dima*no,nc,dimb*no,l1,l2,tmp) -c - lasta=0 - if (a.gt.1) then - do a_tmp=1,a-1 - lasta=lasta+DimGrpaR(a_tmp) - end do - end if -c - lastb=0 - if (b.gt.1) then - do b_tmp=1,b-1 - lastb=lastb+DimGrpaR(b_tmp) - end do - end if -c -c write (6,'(A,4(i4,x))') 'BB1 dima, dimb, lasta, lastb ', -c & dima,dimb,lasta,lastb - call grow_vvoo(w,tmp,no,nv,dima,dimb,lasta,lastb) -c - if (a.ne.b) then -c - call Map4_3412_t3 (tmp,l2,dima,no,dimb,no) -c -c write (6,'(A,4(i4,x))') 'BB2 dima, dimb, lasta, lastb ', -c & dimb,dima,lastb,lasta - call grow_vvoo(w,l2,no,nv,dimb,dima,lastb,lasta) -c - end if -c -c3 end loop over B' -c - end do -c -c3 end loop over A' -c - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/gen_vvoo.F90 openmolcas-22.10/src/cht3/gen_vvoo.F90 --- openmolcas-22.02/src/cht3/gen_vvoo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/gen_vvoo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,103 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine gen_vvoo(w,l1,tmp,l2) +! this routine does: +! +! regenerate (ab,ij) integrals from blocked +! MO cholesky vectors +! +! = (vo|vo) +! +! -------- +! +! L1(m,I,A') + +use ChT3_global, only: DimGrpaR, L1Name, LunAux, nc, no, nv, NvGrp +use Constants, only: Zero +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +real(kind=wp), intent(inout) :: w(*) +real(kind=wp), intent(_OUT_) :: l1(*), tmp(*), l2(*) +integer(kind=iwp) :: a, a_tmp, b, b_tmp, dima, dimb, lasta, lastb, length + +do a=1,NvGrp + + !1 read tmp(m,I,A') + + dima = DimGrpaR(a) + length = nc*no*dima + call GetX_t3(tmp,length,LunAux,L1Name(a),1,1) + + !5 map l1 (A',I,m) <- tmp (m,I,A') + + call Map3_321_t3(tmp,l1,nc,no,dima) + + ! ----- read tmp(m,I,B') + + do b=1,a + + dimb = DimGrpaR(b) + length = nc*no*dimb + call GetX_t3(tmp,length,LunAux,L1Name(b),1,1) + + !4 map l2 (m,B',I) <- tmp (m,I,B') + + call Map3_132_t3(tmp,l2,nc,no,dimb) + + ! zero tmp + + tmp(1:dima*no*dimb*no) = Zero + + !7 mult tmp(A',I,B',J) <- l1 (A',I,m) . l2(m,B',J) + + call mc0c1a3b(dima*no,nc,nc,dimb*no,dima*no,dimb*no,dima*no,nc,dimb*no,l1,l2,tmp) + + lasta = 0 + if (a > 1) then + do a_tmp=1,a-1 + lasta = lasta+DimGrpaR(a_tmp) + end do + end if + + lastb = 0 + if (b > 1) then + do b_tmp=1,b-1 + lastb = lastb+DimGrpaR(b_tmp) + end do + end if + + !write(u6,'(A,4(i4,x))') 'BB1 dima, dimb, lasta, lastb ',dima,dimb,lasta,lastb + call grow_vvoo(w,tmp,no,nv,dima,dimb,lasta,lastb) + + if (a /= b) then + + call Map4_3412_t3(tmp,l2,dima,no,dimb,no) + + !write(u6,'(A,4(i4,x))') 'BB2 dima, dimb, lasta, lastb ',dimb,dima,lastb,lasta + call grow_vvoo(w,l2,no,nv,dimb,dima,lastb,lasta) + + end if + + !3 end loop over B' + + end do + + !3 end loop over A' + +end do + +return + +end subroutine gen_vvoo diff -Nru openmolcas-22.02/src/cht3/gen_vvvo.f openmolcas-22.10/src/cht3/gen_vvvo.f --- openmolcas-22.02/src/cht3/gen_vvvo.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/gen_vvvo.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,181 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine gen_vvvo(occ_ind,w3,l1_1,l2_1,tmp) -c -c this routine do -c -c regenerate VVVo integrals from cholesky vectors -c -c ------------------- -c -c structure of the cholesky vector files : -c -c L1(m,I ,A') L1vcxx xx - Group of A' -c -c L2(m,A'B') L2xxyy xx - Group of A', A'>=B' -c yy - Group of B' -c - implicit none -#include "cht3_ccsd1.fh" -#include "cht3_reord.fh" -#include "files.fh" -#include "ccsd_t3compat.fh" -c - integer a,b,c,dima,dimb,dimc,occ_ind - integer length - integer lasta,lastb,lastc -c - real*8 w3(1:(nv*(nv+1))/2,1:nv) - real*8 tmp(*),l1_1(*),l2_1(*) -c - integer a_tmp,b_tmp,c_tmp -c -c algoritmus je dobry ak maxdim > no -c inak treba vymenit citanie L1 za L2 -c -c dalo by sa to urobit podstatne lepsie, kedby -c dircc nevyzadoval VVV ako (ab,c) ale ako (a,b,c) -c -c mozno urob sort L1i (m,c') <- L1(m,i,c') -c --- -c -c1 loop over a' -c - do a=1,NvGrp -c -c2 loop over b' -c - do b=1,a -c -c2.1 read L2(m,a',b') -c - if (a.eq.b) then ! a=b -c open the pertinent file -c -cmp@ dima=nv/NvGrp -cmp@ if (a.eq.NvGrp) dima=nv-((NvGrp-1)*dima) - dima=DimGrpaR(a) -c -cmp! write (6,*) 'dima = ',dima - dimb=dima - length=(dima*(dima+1)*nc)/2 -cmp! write (6,*) 'length L2Name(a,b) = ',L2Name(a,b),length -cmp! write (6,*) 'file size (g77) = ',16+length*8 -cmp! write (6,*) 'file size L2Name(a,b) (ifort) = ', -cmp! & L2Name(a,b),8+length*8 -c - call GetX_t3 (tmp,length,LunAux,L2Name(a,b),1,1) -c - else ! a>b -c open the pertinent file -c -cmp@@ dima=nv/NvGrp -cmp@@ dimb=nv/NvGrp -cmp@@ if (a.eq.NvGrp) dima=nv-((NvGrp-1)*dima) -cmp@@ if (b.eq.NvGrp) dimb=nv-((NvGrp-1)*dimb) - dima=DimGrpaR(a) - dimb=DimGrpaR(b) -c -cmp! write (6,*) 'dima, dimb = ',dima,dimb - length=dima*dimb*nc -cmp! write (6,*) 'length L2Name(a,b) = ',L2Name(a,b),length -cmp! write (6,*) 'file size (g77) = ',16+length*8 -cmp! write (6,*) 'file size L2Name(a,b) (ifort) = ', -cmp! & L2Name(a,b),8+length*8 -c - call GetX_t3 (tmp,length,LunAux,L2Name(a,b),1,1) - end if -c -c2.2 map L2_1(a',b',m) <- tmp(m,a',b') -c - if (a.eq.b) then ! expand and map -c expand and map l2_1 (a',b',m) <- tmp (m,ab') - call exMap3_231 (tmp,l2_1,nc,dima) - else - call Map3_231_t3 (tmp,l2_1,nc,dima,dimb) - end if -c -c3 loop over c' -c - do c=1,NvGrp -c -c3.1 read L1(m,i,c') -c -cmp@@ dimc=nv/NvGrp -cmp@@ if (c.eq.NvGrp) dimc=nv-((NvGrp-1)*dimc) - dimc=DimGrpaR(c) -c -cmp! write (6,*) 'dimc = ',dimc - length=nc*no*dimc -cmp! write (6,*) 'length L1Name(c) = ',L1Name(c),length -cmp! write (6,*) 'file size L1Name(c) (ifort) = ', -cmp! & L1Name(c),8+8*length -c - call GetX_t3 (tmp,length,LunAux,L1Name(c),1,1) -c -c3.2 extract l1_1 (m,c')_i <- tmp (m,i,c') -c toto by sa dalo nahradit mapovanim -c - call ext_o_32 (tmp,l1_1,nc,no,dimc,occ_ind) -c -c3.2.1 zero tmp -c - call zeroma(tmp,1,dima*dimb*dimc) -c -c3.3 mult tmp (a',b',c') <- L2_1 (a',b',m) l1_1 (m,c') -c - call mc0c1a3b - & (dima*dimb,nc,nc,dimc,dima*dimb,dimc, - & dima*dimb,nc,dimc,l2_1,l1_1,tmp) -C -c3.4 add W(ab,c) <- tmp (a'b'c') -c -cmp@@ lasta=(a-1)*(nv/NvGrp) -cmp@@ lastb=(b-1)*(nv/NvGrp) -cmp@@ lastc=(c-1)*(nv/NvGrp) -c - lasta=0 - if (a.gt.1) then - do a_tmp=1,a-1 - lasta=lasta+DimGrpaR(a_tmp) - end do - end if -c - lastb=0 - if (b.gt.1) then - do b_tmp=1,b-1 - lastb=lastb+DimGrpaR(b_tmp) - end do - end if -c - lastc=0 - if (c.gt.1) then - do c_tmp=1,c-1 - lastc=lastc+DimGrpaR(c_tmp) - end do - end if -c -cmp! write (6,'(A,3(i4),2x,3(i4))') 'lasta, lastb, lastc = ', -cmp! & lasta,lastb,lastc,a,b,c - -c sme v gen_vvvo - call grow_w3 (w3,tmp, - & nv,nv,dima,dimb,dimc,lasta,lastb,lastc) -c -c3.5 end loop over c' - end do -c4 end loop over b' - end do -c5 end loop over a' - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/gen_vvvo.F90 openmolcas-22.10/src/cht3/gen_vvvo.F90 --- openmolcas-22.02/src/cht3/gen_vvvo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/gen_vvvo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,173 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine gen_vvvo(occ_ind,w3,l1_1,l2_1,tmp) +! this routine does: +! +! regenerate VVVo integrals from cholesky vectors +! +! ------------------- +! +! structure of the cholesky vector files : +! +! L1(m,I ,A') L1vcxx xx - Group of A' +! +! L2(m,A'B') L2xxyy xx - Group of A', A'>=B' +! yy - Group of B' + +use ChT3_global, only: DimGrpaR, L1Name, L2Name, LunAux, nc, no, nv, NvGrp +use Index_Functions, only: nTri_Elem +use Constants, only: Zero +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: occ_ind +real(kind=wp), intent(inout) :: w3(nTri_Elem(nv),nv) +real(kind=wp), intent(_OUT_) :: l1_1(*), l2_1(*), tmp(*) +integer(kind=iwp) :: a, a_tmp, b, b_tmp, c, c_tmp, dima, dimb, dimc, lasta, lastb, lastc, length + +! algoritmus je dobry ak maxdim > no +! inak treba vymenit citanie L1 za L2 +! +! dalo by sa to urobit podstatne lepsie, kedby +! dircc nevyzadoval VVV ako (ab,c) ale ako (a,b,c) +! +! mozno urob sort L1i (m,c') <- L1(m,i,c') +! --- + +!1 loop over a' + +do a=1,NvGrp + + !2 loop over b' + + do b=1,a + + !2.1 read L2(m,a',b') + + if (a == b) then ! a=b + ! open the pertinent file + + !mp@ dima = nv/NvGrp + !mp@ if (a == NvGrp) dima = nv-((NvGrp-1)*dima) + dima = DimGrpaR(a) + + !mp !write(u6,*) 'dima = ',dima + dimb = dima + length = nTri_Elem(dima)*nc + !mp !write(u6,*) 'length L2Name(a,b) = ',L2Name(a,b),length + !mp !write(u6,*) 'file size (g77) = ',16+length*8 + !mp !write(u6,*) 'file size L2Name(a,b) (ifort) = ',L2Name(a,b),8+length*8 + + call GetX_t3(tmp,length,LunAux,L2Name(a,b),1,1) + + else ! a>b + ! open the pertinent file + + !mp@@ dima = nv/NvGrp + !mp@@ dimb = nv/NvGrp + !mp@@ if (a == NvGrp) dima = nv-((NvGrp-1)*dima) + !mp@@ if (b == NvGrp) dimb = nv-((NvGrp-1)*dimb) + dima = DimGrpaR(a) + dimb = DimGrpaR(b) + + !mp !write(u6,*) 'dima, dimb = ',dima,dimb + length = dima*dimb*nc + !mp !write(u6,*) 'length L2Name(a,b) = ',L2Name(a,b),length + !mp !write(u6,*) 'file size (g77) = ',16+length*8 + !mp !write(u6,*) 'file size L2Name(a,b) (ifort) = ',L2Name(a,b),8+length*8 + + call GetX_t3(tmp,length,LunAux,L2Name(a,b),1,1) + end if + + !2.2 map L2_1(a',b',m) <- tmp(m,a',b') + + if (a == b) then ! expand and map + ! expand and map l2_1 (a',b',m) <- tmp (m,ab') + call exMap3_231(tmp,l2_1,nc,dima) + else + call Map3_231_t3(tmp,l2_1,nc,dima,dimb) + end if + + !3 loop over c' + + do c=1,NvGrp + + !3.1 read L1(m,i,c') + + !mp@@ dimc = nv/NvGrp + !mp@@ if (c == NvGrp) dimc = nv-((NvGrp-1)*dimc) + dimc = DimGrpaR(c) + + !mp !write(u6,*) 'dimc = ',dimc + length = nc*no*dimc + !mp !write(u6,*) 'length L1Name(c) = ',L1Name(c),length + !mp !write(u6,*) 'file size L1Name(c) (ifort) = ',L1Name(c),8+8*length + + call GetX_t3(tmp,length,LunAux,L1Name(c),1,1) + + !3.2 extract l1_1 (m,c')_i <- tmp (m,i,c') + ! toto by sa dalo nahradit mapovanim + + call ext_o_32(tmp,l1_1,nc,no,dimc,occ_ind) + + !3.2.1 zero tmp + + tmp(1:dima*dimb*dimc) = Zero + + !3.3 mult tmp (a',b',c') <- L2_1 (a',b',m) l1_1 (m,c') + + call mc0c1a3b(dima*dimb,nc,nc,dimc,dima*dimb,dimc,dima*dimb,nc,dimc,l2_1,l1_1,tmp) + + !3.4 add W(ab,c) <- tmp (a'b'c') + + !mp@@ lasta = (a-1)*(nv/NvGrp) + !mp@@ lastb = (b-1)*(nv/NvGrp) + !mp@@ lastc = (c-1)*(nv/NvGrp) + + lasta = 0 + if (a > 1) then + do a_tmp=1,a-1 + lasta = lasta+DimGrpaR(a_tmp) + end do + end if + + lastb = 0 + if (b > 1) then + do b_tmp=1,b-1 + lastb = lastb+DimGrpaR(b_tmp) + end do + end if + + lastc = 0 + if (c > 1) then + do c_tmp=1,c-1 + lastc = lastc+DimGrpaR(c_tmp) + end do + end if + + !mp !write(u6,'(A,3(i4),2x,3(i4))') 'lasta, lastb, lastc = ',lasta,lastb,lastc,a,b,c + + ! sme v gen_vvvo + call grow_w3(w3,tmp,nv,nv,dima,dimb,dimc,lasta,lastb,lastc) + + !3.5 end loop over c' + end do + !4 end loop over b' + end do + !5 end loop over a' +end do + +return + +end subroutine gen_vvvo diff -Nru openmolcas-22.02/src/cht3/getrest_t3.f openmolcas-22.10/src/cht3/getrest_t3.f --- openmolcas-22.02/src/cht3/getrest_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/getrest_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,51 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine GetRest_t3 (t1,t1_tmp,E2old) -c -c this file read 1) T1o -c 2) E1old,E2old,niter -c from RstFil file -c - implicit none -#include "cht3_ccsd1.fh" -#include "ccsd_t3compat.fh" - real*8 E1old,E2old - real*8 t1(*),t1_tmp(*) -c -c help variables - integer length,i -c -* open (unit=LunAux,File='RstFil',form='unformatted') - Call MOLCAS_BinaryOpen_Vanilla(LunAux,'RstFil') - length=nv*no -cmp write (*,*) 'no, nv, length = ',no,nv,length - call cht3_rea (LunAux,length,t1) -c - call transp (t1,t1_tmp,nv,no) -c - do i=1,length - t1(i+length)=t1_tmp(i) - t1(i)=t1_tmp(i) - end do -c -c - read (LunAux) E1old,E2old,i - - if (printkey.gt.1) then - write (6,'(A,2(f15.12,1x))') 'Results from CCSD : E1, E2 ', - & E1old,E2old - end if - - close (LunAux) -c -c - return - end diff -Nru openmolcas-22.02/src/cht3/getrest_t3.F90 openmolcas-22.10/src/cht3/getrest_t3.F90 --- openmolcas-22.02/src/cht3/getrest_t3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/getrest_t3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,45 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine GetRest_t3(t1,t1_tmp,E2old) +! this file read 1) T1o +! 2) E1old,E2old,niter +! from RstFil file + +use ChT3_global, only: LunAux, no, nv, printkey +use Definitions, only: wp, iwp, u6 + +implicit none +real(kind=wp), intent(out) :: t1(nv*no,2), t1_tmp(nv*no), E2old +integer(kind=iwp) :: dum +real(kind=wp) :: E1old + +!open(unit=LunAux,File='RstFil',form='unformatted') +call MOLCAS_BinaryOpen_Vanilla(LunAux,'RstFil') +!mp write(u6,*) 'no, nv, length = ',no,nv,length +read(LunAux) t1(:,1) + +call Map2_21_t3(t1,t1_tmp,nv,no) + +t1(:,1) = t1_tmp +t1(:,2) = t1_tmp + +read(LunAux) E1old,E2old,dum +#include "macros.fh" +unused_var(dum) + +if (printkey > 1) write(u6,'(A,2(f15.12,1x))') 'Results from CCSD : E1, E2 ',E1old,E2old + +close(LunAux) + +return + +end subroutine GetRest_t3 diff -Nru openmolcas-22.02/src/cht3/getx_t3.f openmolcas-22.10/src/cht3/getx_t3.f --- openmolcas-22.02/src/cht3/getx_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/getx_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,52 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine GetX_t3 (X,length,Lun,LunName,keyopen,keyclose) -c -c this routine do -c 1) keyopen = 0 - nothing (i.e) file is opened -c 1 - open LunName file with Lun -c 2 - rewind Lun file -c 3 - open LunName file with Lun with ACCESS='append' -c 2) read X of dimension length -c 3) keyclose= 0 - nothing -c 1 - close Lun file -c -c - implicit none - integer length,Lun,keyopen,keyclose - real*8 X(1) - character*6 LunName -c -c1 - if (keyopen.eq.1) then -* open (unit=Lun,file=LunName,form='unformatted') - Call MOLCAS_BinaryOpen_Vanilla(Lun,LunName) - else if (keyopen.eq.2) then - rewind(Lun) - else if (keyopen.eq.3) then -cmp! open (unit=Lun,file=LunName,form='unformatted', -cmp! c ACCESS='append') - - Call MOLCAS_BinaryOpen_Vanilla(Lun,LunName) - call append_file_u(Lun) - - end if -c -c2 - call cht3_rea (Lun,length,X(1)) -c -c3 - if (keyclose.eq.1) then - close (Lun) - end if -c - return - end diff -Nru openmolcas-22.02/src/cht3/getx_t3.F90 openmolcas-22.10/src/cht3/getx_t3.F90 --- openmolcas-22.02/src/cht3/getx_t3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/getx_t3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,53 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine GetX_t3(X,length,Lun,LunName,keyopen,keyclose) +! this routine does: +! 1) keyopen = 0 - nothing (i.e) file is opened +! 1 - open LunName file with Lun +! 2 - rewind Lun file +! 3 - open LunName file with Lun with ACCESS='append' +! 2) read X of dimension length +! 3) keyclose = 0 - nothing +! 1 - close Lun file + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: length, Lun, keyopen, keyclose +real(kind=wp), intent(out) :: X(length) +character(len=6) :: LunName + +!1 +if (keyopen == 1) then + !open(unit=Lun,file=LunName,form='unformatted') + call MOLCAS_BinaryOpen_Vanilla(Lun,LunName) +else if (keyopen == 2) then + rewind(Lun) +else if (keyopen == 3) then + !mp !open(unit=Lun,file=LunName,form='unformatted',ACCESS='append') + + call MOLCAS_BinaryOpen_Vanilla(Lun,LunName) + call append_file_u(Lun) + +end if + +!2 +read(Lun) X(:) + +!3 +if (keyclose == 1) then + close(Lun) +end if + +return + +end subroutine GetX_t3 diff -Nru openmolcas-22.02/src/cht3/grow_l1.f openmolcas-22.10/src/cht3/grow_l1.f --- openmolcas-22.02/src/cht3/grow_l1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_l1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine grow_l1(l1,tmp,dima,nc,no,nv,last) -c -c this routine do : -c -c grow Cholesky vectors L1(m,i,a) by the segment in tmp -c - implicit none - integer a,dima,nc,nv,no,i,m,last - real*8 l1(1:nc,1:no,1:nv) - real*8 tmp(1:nc,1:no,1:dima) -c -cmp write (6,*) 'grow_l1i ',dima -c - do a=1,dima - do i=1,no - do m=1,nc - l1(m,i,last+a)=tmp(m,i,a) - end do - end do - end do -c -c - return - end diff -Nru openmolcas-22.02/src/cht3/grow_l1.F90 openmolcas-22.10/src/cht3/grow_l1.F90 --- openmolcas-22.02/src/cht3/grow_l1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_l1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,30 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine grow_l1(l1,tmp,dima,nc,no,nv,last) +! this routine does: +! +! grow Cholesky vectors L1(m,i,a) by the segment in tmp + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: dima, nc, no, nv, last +real(kind=wp), intent(inout) :: l1(nc,no,nv) +real(kind=wp), intent(in) :: tmp(nc,no,dima) + +!mp write(u6,*) 'grow_l1i ',dima + +l1(:,:,last+1:last+dima) = tmp + +return + +end subroutine grow_l1 diff -Nru openmolcas-22.02/src/cht3/grow_l2.f openmolcas-22.10/src/cht3/grow_l2.f --- openmolcas-22.02/src/cht3/grow_l2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_l2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine grow_l2(A,B,nc,nv,dima,dimb,lasta,lastb) -c -c this routine do : -c -c grow A(A,B,m) from the blocked cholesky vectors -c B(a',b',m) -c - implicit none - integer i1,i2,i3,dima,dimb,nc,nv - integer lasta,lastb - real*8 A(nv,nv,nc),B(dima,dimb,nc) -c - do i3=1,nc - do i1=1,dima - do i2=1,dimb - A(lasta+i1,lastb+i2,i3)=B(i1,i2,i3) - A(lastb+i2,lasta+i1,i3)=B(i1,i2,i3) - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/grow_l2.F90 openmolcas-22.10/src/cht3/grow_l2.F90 --- openmolcas-22.02/src/cht3/grow_l2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_l2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,34 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine grow_l2(A,B,nc,nv,dima,dimb,lasta,lastb) +! this routine does: +! +! grow A(A,B,m) from the blocked cholesky vectors B(a',b',m) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nc, nv, dima, dimb, lasta, lastb +real(kind=wp), intent(inout) :: A(nv,nv,nc) +real(kind=wp), intent(in) :: B(dima,dimb,nc) +integer(kind=iwp) :: i2, i3 + +do i3=1,nc + do i2=1,dimb + A(lasta+1:lasta+dima,lastb+i2,i3) = B(:,i2,i3) + A(lastb+i2,lasta+1:lasta+dima,i3) = B(:,i2,i3) + end do +end do + +return + +end subroutine grow_l2 diff -Nru openmolcas-22.02/src/cht3/grow_t2anti_blocked1.f openmolcas-22.10/src/cht3/grow_t2anti_blocked1.f --- openmolcas-22.02/src/cht3/grow_t2anti_blocked1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_t2anti_blocked1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,54 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine grow_t2anti_blocked1(t2,tmp,dima,dimb,nv,no, - & lasta,lastb,length1,length2,grpa,grpb) -c -c this routine do : -c -c - implicit none - integer a,b,dima,dimb,nv,no,i,j,ij - integer lasta,lastb - integer grpa,grpb - integer length1,length2 -cmp real*8 t2(1:nv,1:nv,1:no,1:no) - real*8 t2(1:length1,1:length2,1:(((no-1)*no)/2)) - real*8 tmp(1:dima,1:dimb,1:no,1:no) -c -cmp write (6,*) 'lasta+dima, length1 ',lasta+dima, length1 -cmp write (6,*) 'lastb+dimb, length2 ',lastb+dimb, length2 -c -cmp write (6,'(A,2(i10,x),i3)') 'length1, length2, no ',length1, length2, no -cmp write (6,'(A,4(i3,x))') 'dima, dimb, lasta, lastb', -cmp & dima,dimb,lasta,lastb -c - ij=0 - do i=2,no - do j=1,i-1 - ij=ij+1 - do b=1,dimb - do a=1,dima -c - t2(lasta+a,lastb+b,ij)=tmp(a,b,i,j)+(-1.0d0*tmp(a,b,j,i)) -c - end do - end do - end do - end do -c - return -c Avoid unused argument warnings - if (.false.) then - call Unused_integer(nv) - call Unused_integer(grpa) - call Unused_integer(grpb) - end if - end diff -Nru openmolcas-22.02/src/cht3/grow_t2anti_blocked1.F90 openmolcas-22.10/src/cht3/grow_t2anti_blocked1.F90 --- openmolcas-22.02/src/cht3/grow_t2anti_blocked1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_t2anti_blocked1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,39 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine grow_t2anti_blocked1(t2,tmp,dima,dimb,no,lasta,lastb,length1,length2) + +use Index_Functions, only: nTri_Elem +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: dima, dimb, no, lasta, lastb, length1, length2 +real(kind=wp), intent(inout) :: t2(length1,length2,nTri_Elem(no-1)) +real(kind=wp), intent(in) :: tmp(dima,dimb,no,no) +integer(kind=iwp) :: i, ij, j + +!mp write(u6,*) 'lasta+dima, length1 ',lasta+dima,length1 +!mp write(u6,*) 'lastb+dimb, length2 ',lastb+dimb,length2 + +!mp write(u6,'(A,2(i10,x),i3)') 'length1, length2, no ',length1,length2,no +!mp write(u6,'(A,4(i3,x))') 'dima, dimb, lasta, lastb',dima,dimb,lasta,lastb + +ij = 0 +do i=2,no + do j=1,i-1 + ij = ij+1 + t2(lasta+1:lasta+dima,lastb+1:lastb+dimb,ij) = tmp(:,:,i,j)-tmp(:,:,j,i) + end do +end do + +return + +end subroutine grow_t2anti_blocked1 diff -Nru openmolcas-22.02/src/cht3/grow_t2anti_blocked2.f openmolcas-22.10/src/cht3/grow_t2anti_blocked2.f --- openmolcas-22.02/src/cht3/grow_t2anti_blocked2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_t2anti_blocked2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,52 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine grow_t2anti_blocked2(t2,tmp,dima,dimb,nv,no, - & lasta,lastb,length1,length2,grpa,grpb) -c -c this routine do : -c -c - implicit none - integer a,b,dima,dimb,nv,no,i,j,ij - integer lasta,lastb - integer grpa,grpb - integer length1,length2 -cmp real*8 t2(1:nv,1:nv,1:no,1:no) - real*8 t2(1:length1,1:length2,1:(((no-1)*no)/2)) - real*8 tmp(1:dima,1:dimb,1:no,1:no) -c -cmp write (6,*) 'lasta+dima, length1 ',lasta+dima, length1 -cmp write (6,*) 'lastb+dimb, length2 ',lastb+dimb, length2 -cmp write (6,*) 'lasta, lastb ',lasta,lastb -cmp write (6,*) 'dima, dimb ',dima,dimb -c - ij=0 - do i=2,no - do j=1,i-1 - ij=ij+1 - do b=1,dima - do a=1,dimb -c - t2(lasta+a,lastb+b,ij)=tmp(b,a,j,i)+(-1.0d0*tmp(b,a,i,j)) -c - end do - end do - end do - end do -c - return -c Avoid unused argument warnings - if (.false.) then - call Unused_integer(nv) - call Unused_integer(grpa) - call Unused_integer(grpb) - end if - end diff -Nru openmolcas-22.02/src/cht3/grow_t2anti_blocked2.F90 openmolcas-22.10/src/cht3/grow_t2anti_blocked2.F90 --- openmolcas-22.02/src/cht3/grow_t2anti_blocked2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_t2anti_blocked2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,40 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine grow_t2anti_blocked2(t2,tmp,dima,dimb,no,lasta,lastb,length1,length2) + +use Index_Functions, only: nTri_Elem +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: dima, dimb, no, lasta, lastb, length1, length2 +real(kind=wp), intent(inout) :: t2(length1,length2,nTri_Elem(no-1)) +real(kind=wp), intent(in) :: tmp(dima,dimb,no,no) +integer(kind=iwp) :: b, i, ij, j + +!mp write(u6,*) 'lasta+dima, length1 ',lasta+dima,length1 +!mp write(u6,*) 'lastb+dimb, length2 ',lastb+dimb,length2 +!mp write(u6,*) 'lasta, lastb ',lasta,lastb +!mp write(u6,*) 'dima, dimb ',dima,dimb + +ij = 0 +do i=2,no + do j=1,i-1 + ij = ij+1 + do b=1,dima + t2(lasta+1:lasta+dimb,lastb+b,ij) = tmp(b,:,j,i)-tmp(b,:,i,j) + end do + end do +end do + +return + +end subroutine grow_t2anti_blocked2 diff -Nru openmolcas-22.02/src/cht3/grow_t2_blocked.f openmolcas-22.10/src/cht3/grow_t2_blocked.f --- openmolcas-22.02/src/cht3/grow_t2_blocked.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_t2_blocked.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,77 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine grow_t2_blocked(t2,tmp,dima,dimb,nv,no, - & lasta,lastb,length1,length2,grpa,grpb,sym,switch) -c -c this routine do : -c -c - implicit none - integer a,b,dima,dimb,nv,no,i,j - integer lasta,lastb - integer grpa,grpb - integer length1,length2 -cmp real*8 t2(1:nv,1:nv,1:no,1:no) - real*8 t2(1:length1,1:length2,1:no,1:no) - real*8 tmp(1:dima,1:dimb,1:no,1:no) - logical sym - logical switch -c -cmp write (6,*) 'grow_t2neq dima , dimb ',dima,dimb -cmp write (6,*) 'grow_t2neq lasta, lastb ',lasta,lastb -cmp write (6,*) 'grow_t2neq no ',no -c -cmp if (lasta.eq.lastb) then -c? if (grpa.eq.grpb) then -c? do j=1,no -c? do i=1,no -c? do a=1,dima -c? do b=1,a -c? t2(lasta+a,lastb+b,i,j)=1.0d0*tmp(a,b,i,j) -c? if (a.ne.b) t2(lastb+b,lasta+a,j,i)=1.0d0*tmp(a,b,i,j) -c? end do -c? end do -c? end do -c? end do -c -c? else -c - do j=1,no - do i=1,no - do b=1,dimb - do a=1,dima - if (.not.switch) then - t2(lasta+a,lastb+b,i,j)=1.0d0*tmp(a,b,i,j) - else -cmp! t2(lasta+a,lastb+b,i,j)=1.0d0*tmp(a,b,j,i) - t2(lasta+a,lastb+b,i,j)=1.0d0*tmp(a,b,i,j) - end if -cmpn t2(lastb+b,lasta+a,j,i)=1.0d0*tmp(a,b,i,j) -c - if (sym) then - t2(lastb+b,lasta+a,j,i)=1.0d0*tmp(a,b,i,j) - end if -c - end do - end do - end do - end do -c -c? end if -c - return -c Avoid unused argument warnings - if (.false.) then - call Unused_integer(nv) - call Unused_integer(grpa) - call Unused_integer(grpb) - end if - end diff -Nru openmolcas-22.02/src/cht3/grow_t2_blocked.F90 openmolcas-22.10/src/cht3/grow_t2_blocked.F90 --- openmolcas-22.02/src/cht3/grow_t2_blocked.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_t2_blocked.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,62 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine grow_t2_blocked(t2,tmp,dima,dimb,no,lasta,lastb,length1,length2,sym) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: dima, dimb, no, lasta, lastb, length1, length2 +real(kind=wp), intent(inout) :: t2(length1,length2,no,no) +real(kind=wp), intent(in) :: tmp(dima,dimb,no,no) +logical(kind=iwp) :: sym +integer(kind=iwp) :: b, i, j + +!mp write(u6,*) 'grow_t2neq dima , dimb ',dima,dimb +!mp write(u6,*) 'grow_t2neq lasta, lastb ',lasta,lastb +!mp write(u6,*) 'grow_t2neq no ',no + +!mp if (lasta == lastb) then +!? if (grpa == grpb) then +!? do j=1,no +!? do i=1,no +!? do a=1,dima +!? do b=1,a +!? t2(lasta+a,lastb+b,i,j) = tmp(a,b,i,j) +!? if (a /= b) t2(lastb+b,lasta+a,j,i) = tmp(a,b,i,j) +!? end do +!? end do +!? end do +!? end do + +!? else + +do j=1,no + do i=1,no + do b=1,dimb + !if (switch) then + ! !mp !t2(lasta+1:lasta+dima,lastb+b,i,j) = tmp(:,b,j,i) + ! t2(lasta+1:lasta+dima,lastb+b,i,j) = tmp(:,b,i,j) + !else + t2(lasta+1:lasta+dima,lastb+b,i,j) = tmp(:,b,i,j) + !end if + !mpn t2(lastb+b,lasta+a,j,i) = tmp(a,b,i,j) + + if (sym) t2(lastb+b,lasta+1:lasta+dima,j,i) = tmp(:,b,i,j) + end do + end do +end do + +!? end if + +return + +end subroutine grow_t2_blocked diff -Nru openmolcas-22.02/src/cht3/grow_t2_fblocked1.f openmolcas-22.10/src/cht3/grow_t2_fblocked1.f --- openmolcas-22.02/src/cht3/grow_t2_fblocked1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_t2_fblocked1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,58 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine grow_t2_fblocked1(t2,tmp,dima,dimb,nv,no, - & lasta,lastb,length1,length2,grpa,grpb) -c -c this routine do : -c -c - implicit none - integer a,b,dima,dimb,nv,no,i,j -c integer ij - integer lasta,lastb - integer grpa,grpb - integer length1,length2 -cmp real*8 t2(1:nv,1:nv,1:no,1:no) - real*8 t2(1:length1,1:length2,1:no,1:no) - real*8 tmp(1:dima,1:dimb,1:no,1:no) -c -cmp write (6,*) 'lasta+dima, length1 ',lasta+dima, length1 -cmp write (6,*) 'lastb+dimb, length2 ',lastb+dimb, length2 -c -cmp write (6,'(A,2(i10,x),i3)') 'length1, length2, no ',length1, length2, no -cmp write (6,'(A,4(i3,x))') 'dima, dimb, lasta, lastb', -cmp & dima,dimb,lasta,lastb -c -cmp ij=0 -cmp do i=2,no -cmp do j=1,i-1 -cmp ij=ij+1 - do i=1,no - do j=1,no - do b=1,dimb - do a=1,dima -c -cmp t2(lasta+a,lastb+b,ij)=tmp(a,b,i,j)+(-1.0d0*tmp(a,b,j,i)) - t2(lasta+a,lastb+b,i,j)=tmp(a,b,i,j) -c - end do - end do - end do - end do -c - return -c Avoid unused argument warnings - if (.false.) then - call Unused_integer(nv) - call Unused_integer(grpa) - call Unused_integer(grpb) - end if - end diff -Nru openmolcas-22.02/src/cht3/grow_t2_fblocked1.F90 openmolcas-22.10/src/cht3/grow_t2_fblocked1.F90 --- openmolcas-22.02/src/cht3/grow_t2_fblocked1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_t2_fblocked1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,45 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine grow_t2_fblocked1(t2,tmp,dima,dimb,no,lasta,lastb,length1,length2) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: dima, dimb, no, lasta, lastb, length1, length2 +real(kind=wp), intent(inout) :: t2(length1,length2,no,no) +real(kind=wp), intent(in) :: tmp(dima,dimb,no,no) +integer(kind=iwp) :: b, i, j + +!mp write(u6,*) 'lasta+dima, length1 ',lasta+dima,length1 +!mp write(u6,*) 'lastb+dimb, length2 ',lastb+dimb,length2 + +!mp write(u6,'(A,2(i10,x),i3)') 'length1, length2, no ',length1,length2,no +!mp write(u6,'(A,4(i3,x))') 'dima, dimb, lasta, lastb',dima,dimb,lasta,lastb + +!mp ij = 0 +!mp do i=2,no +!mp do j=1,i-1 +!mp ij = ij+1 +do i=1,no + do j=1,no + do b=1,dimb + + !mp t2(lasta+1:lasta+dima,lastb+b,ij) = tmp(:,b,i,j)-tmp(:,b,j,i) + t2(lasta+1:lasta+dima,lastb+b,i,j) = tmp(:,b,i,j) + + end do + end do +end do + +return + +end subroutine grow_t2_fblocked1 diff -Nru openmolcas-22.02/src/cht3/grow_t2_fblocked2.f openmolcas-22.10/src/cht3/grow_t2_fblocked2.f --- openmolcas-22.02/src/cht3/grow_t2_fblocked2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_t2_fblocked2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine grow_t2_fblocked2(t2,tmp,dima,dimb,nv,no, - & lasta,lastb,length1,length2,grpa,grpb) -c -c this routine do : -c -c - implicit none - integer a,b,dima,dimb,nv,no,i,j -c integer ij - integer lasta,lastb - integer grpa,grpb - integer length1,length2 -cmp real*8 t2(1:nv,1:nv,1:no,1:no) - real*8 t2(1:length1,1:length2,1:no,1:no) - real*8 tmp(1:dima,1:dimb,1:no,1:no) -c -cmp write (6,*) 'lasta+dima, length1 ',lasta+dima, length1 -cmp write (6,*) 'lastb+dimb, length2 ',lastb+dimb, length2 -cmp write (6,*) 'lasta, lastb ',lasta,lastb -cmp write (6,*) 'dima, dimb ',dima,dimb -c -cmp ij=0 -cmp do i=2,no -cmp do j=1,i-1 -cmp ij=ij+1 - do i=1,no - do j=1,no - do b=1,dima - do a=1,dimb -c -cmp t2(lasta+a,lastb+b,ij)=tmp(b,a,j,i)+(-1.0d0*tmp(b,a,i,j)) - t2(lasta+a,lastb+b,i,j)=tmp(b,a,j,i) -c - end do - end do - end do - end do -c - return -c Avoid unused argument warnings - if (.false.) then - call Unused_integer(nv) - call Unused_integer(grpa) - call Unused_integer(grpb) - end if - end diff -Nru openmolcas-22.02/src/cht3/grow_t2_fblocked2.F90 openmolcas-22.10/src/cht3/grow_t2_fblocked2.F90 --- openmolcas-22.02/src/cht3/grow_t2_fblocked2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_t2_fblocked2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,44 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine grow_t2_fblocked2(t2,tmp,dima,dimb,no,lasta,lastb,length1,length2) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: dima, dimb, no, lasta, lastb, length1, length2 +real(kind=wp), intent(inout) :: t2(length1,length2,no,no) +real(kind=wp), intent(in) :: tmp(dima,dimb,no,no) +integer(kind=iwp) :: b, i, j + +!mp write(u6,*) 'lasta+dima, length1 ',lasta+dima,length1 +!mp write(u6,*) 'lastb+dimb, length2 ',lastb+dimb,length2 +!mp write(u6,*) 'lasta, lastb ',lasta,lastb +!mp write(u6,*) 'dima, dimb ',dima,dimb + +!mp ij = 0 +!mp do i=2,no +!mp do j=1,i-1 +!mp ij = ij+1 +do i=1,no + do j=1,no + do b=1,dima + + !mp t2(lasta+1:lasta+dimb,lastb+b,ij) = tmp(b,:,j,i)-tmp(b,:,i,j) + t2(lasta+1:lasta+dimb,lastb+b,i,j) = tmp(b,:,j,i) + + end do + end do +end do + +return + +end subroutine grow_t2_fblocked2 diff -Nru openmolcas-22.02/src/cht3/grow_t2neq.f openmolcas-22.10/src/cht3/grow_t2neq.f --- openmolcas-22.02/src/cht3/grow_t2neq.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_t2neq.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine grow_t2neq(t2,tmp,dima,dimb,nv,no, - & lasta,lastb) -c -c this routine do : -c -c grow amplitude file t2(a,b,i,j) by the segment in tmp -c for case sa != sb -c - implicit none - integer a,b,dima,dimb,nv,no,i,j - integer lasta,lastb - real*8 t2(1:nv,1:nv,1:no,1:no) - real*8 tmp(1:dima,1:dimb,1:no,1:no) -c -cmp write (6,*) 'grow_t2neq dima , dimb ',dima,dimb -cmp write (6,*) 'grow_t2neq lasta, lastb ',lasta,lastb -cmp write (6,*) 'grow_t2neq no ',no -c -c? if (lasta.eq.lastb) then -c? do j=1,no -c? do i=1,no -c? do a=1,dima -c? do b=1,a -c? t2(lasta+a,lastb+b,i,j)=1.0d0*tmp(a,b,i,j) -c?cmp if (a.ne.b) t2(lastb+b,lasta+a,j,i)=-1.0d0*tmp(a,b,j,i) -c? if (a.ne.b) t2(lastb+b,lasta+a,j,i)=1.0d0*tmp(a,b,i,j) -c? end do -c? end do -c? end do -c? end do -c -c? else -c - do j=1,no - do i=1,no - do b=1,dimb - do a=1,dima - t2(lasta+a,lastb+b,i,j)=1.0d0*tmp(a,b,i,j) -cmp t2(lastb+b,lasta+a,j,i)=-1.0d0*tmp(b,a,j,i) - t2(lastb+b,lasta+a,j,i)=1.0d0*tmp(a,b,i,j) - end do - end do - end do - end do -c -c? end if -c - return - end diff -Nru openmolcas-22.02/src/cht3/grow_t2neq.F90 openmolcas-22.10/src/cht3/grow_t2neq.F90 --- openmolcas-22.02/src/cht3/grow_t2neq.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_t2neq.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,59 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine grow_t2neq(t2,tmp,dima,dimb,nv,no,lasta,lastb) +! this routine does: +! +! grow amplitude file t2(a,b,i,j) by the segment in tmp +! for case sa != sb + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: dima, dimb, nv, no, lasta, lastb +real(kind=wp), intent(inout) :: t2(nv,nv,no,no) +real(kind=wp), intent(in) :: tmp(dima,dimb,no,no) +integer(kind=iwp) :: b, i, j + +!mp write(u6,*) 'grow_t2neq dima , dimb ',dima,dimb +!mp write(u6,*) 'grow_t2neq lasta, lastb ',lasta,lastb +!mp write(u6,*) 'grow_t2neq no ',no + +!? if (lasta == lastb) then +!? do j=1,no +!? do i=1,no +!? do a=1,dima +!? do b=1,a +!? t2(lasta+a,lastb+b,i,j) = tmp(a,b,i,j) +!?cmp if (a /= b) t2(lastb+b,lasta+a,j,i) = -tmp(a,b,j,i) +!? if (a /= b) t2(lastb+b,lasta+a,j,i) = tmp(a,b,i,j) +!? end do +!? end do +!? end do +!? end do + +!? else + +do j=1,no + do i=1,no + do b=1,dimb + t2(lasta+1:lasta+dima,lastb+b,i,j) = tmp(:,b,i,j) + !mp t2(lastb+b,lasta+1:lasta+dima,j,i) = -tmp(b,1:dima,j,i) + t2(lastb+b,lasta+1:lasta+dima,j,i) = tmp(:,b,i,j) + end do + end do +end do + +!? end if + +return + +end subroutine grow_t2neq diff -Nru openmolcas-22.02/src/cht3/grow_vvoo_blocked.f openmolcas-22.10/src/cht3/grow_vvoo_blocked.f --- openmolcas-22.02/src/cht3/grow_vvoo_blocked.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_vvoo_blocked.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,52 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine grow_vvoo_blocked(AA,BB,no,nv,dima,dimb,lasta,lastb, - & length1,length2,a,b,sym) -c -c this routine do : -c -c grow A(1324)/(vvoo) from the blocked cholesky vectors -c B(1234)/(vovo) -c - implicit none - integer i1,i2,i3,i4,dima,dimb,no,nv - integer lasta,lastb - integer length1,length2,a,b - real*8 AA(1:length1,1:length2,1:no,1:no) - real*8 BB(1:dima,1:no,1:dimb,1:no) - logical sym -c -cmp write (6,'(A,4(i3,x))') 'AA lasta, lastb, dima, dimb ', -cmp & lasta,lastb,dima,dimb -cmp write (6,'(A,2(i9,x))') 'chk_a ',lasta+dima,length1 -cmp write (6,'(A,2(i9,x))') 'chk_b ',lastb+dimb,length2 -c - do i4=1,no - do i3=1,no - do i1=1,dima - do i2=1,dimb - AA(lasta+i1,lastb+i2,i3,i4)=BB(i1,i3,i2,i4) -c - if (sym) AA(lastb+i2,lasta+i1,i4,i3)=BB(i1,i3,i2,i4) -c - end do - end do - end do - end do -c - return -c Avoid unused argument warnings - if (.false.) then - call Unused_integer(nv) - call Unused_integer(a) - call Unused_integer(b) - end if - end diff -Nru openmolcas-22.02/src/cht3/grow_vvoo_blocked.F90 openmolcas-22.10/src/cht3/grow_vvoo_blocked.F90 --- openmolcas-22.02/src/cht3/grow_vvoo_blocked.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_vvoo_blocked.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,43 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine grow_vvoo_blocked(AA,BB,no,dima,dimb,lasta,lastb,length1,length2,sym) +! this routine does: +! +! grow A(1324)/(vvoo) from the blocked cholesky vectors B(1234)/(vovo) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: no, dima, dimb, lasta, lastb, length1, length2 +real(kind=wp), intent(inout) :: AA(length1,length2,no,no) +real(kind=wp), intent(in) :: BB(dima,no,dimb,no) +logical(kind=iwp), intent(in) :: sym +integer(kind=iwp) :: i2, i3, i4 + +!mp write(u6,'(A,4(i3,x))') 'AA lasta, lastb, dima, dimb ',lasta,lastb,dima,dimb +!mp write(u6,'(A,2(i9,x))') 'chk_a ',lasta+dima,length1 +!mp write(u6,'(A,2(i9,x))') 'chk_b ',lastb+dimb,length2 + +do i4=1,no + do i3=1,no + do i2=1,dimb + AA(lasta+1:lasta+dima,lastb+i2,i3,i4) = BB(:,i3,i2,i4) + + if (sym) AA(lastb+i2,lasta+1:lasta+dima,i4,i3) = BB(:,i3,i2,i4) + + end do + end do +end do + +return + +end subroutine grow_vvoo_blocked diff -Nru openmolcas-22.02/src/cht3/grow_vvoo.f openmolcas-22.10/src/cht3/grow_vvoo.f --- openmolcas-22.02/src/cht3/grow_vvoo.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_vvoo.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,37 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine grow_vvoo(A,B,no,nv,dima,dimb,lasta,lastb) -c -c this routine do : -c -c grow A(1324)/(vvoo) from the blocked cholesky vectors -c B(1234)/(vovo) -c - implicit none - integer i1,i2,i3,i4,dima,dimb,no,nv - integer lasta,lastb - real*8 A(1:nv,1:nv,1:no,1:no),B(1:dima,1:no,1:dimb,1:no) -c -c! write (6,'(A,4(i3,x))') 'AA lasta, lastb, dima, dimb ', -c! & lasta,lastb,dima,dimb -c - do i4=1,no - do i3=1,no - do i1=1,dima - do i2=1,dimb - A(lasta+i1,lastb+i2,i3,i4)=B(i1,i3,i2,i4) - end do - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/grow_vvoo.F90 openmolcas-22.10/src/cht3/grow_vvoo.F90 --- openmolcas-22.02/src/cht3/grow_vvoo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_vvoo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,37 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine grow_vvoo(A,B,no,nv,dima,dimb,lasta,lastb) +! this routine does: +! +! grow A(1324)/(vvoo) from the blocked cholesky vectors B(1234)/(vovo) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: no, nv, dima, dimb, lasta, lastb +real(kind=wp), intent(inout) :: A(nv,nv,no,no) +real(kind=wp), intent(in) :: B(dima,no,dimb,no) +integer(kind=iwp) :: i2, i3, i4 + +!!write(u6,'(A,4(i3,x))') 'AA lasta, lastb, dima, dimb ',lasta,lastb,dima,dimb + +do i4=1,no + do i3=1,no + do i2=1,dimb + A(lasta+1:lasta+dima,lastb+i2,i3,i4) = B(:,i3,i2,i4) + end do + end do +end do + +return + +end subroutine grow_vvoo diff -Nru openmolcas-22.02/src/cht3/grow_w3.f openmolcas-22.10/src/cht3/grow_w3.f --- openmolcas-22.02/src/cht3/grow_w3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_w3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,76 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine grow_w3 (w3,AA,nv,d2,dima,dimb,dimc, - & lasta,lastb,lastc) -c -c this routine do : -c -c add the block contribution AA(a',b',c') to w3(a>=b,c) -c - implicit none -c - integer a,b,c,dima,dimb,dimc,lasta,lastb,lastc,ab,nv - integer a_point,b_point - integer d2 - real*8 w3(1:(nv*(nv+1))/2,1:d2) - real*8 AA(1:dima,1:dimb,1:dimc) - integer a_old,b_old -c - if ((dima.eq.0).or.(dimb.eq.0)) then - write (6,*) 'dima, dimb = ',dima,dimb - write (6,*) 'zle je' - call abend() - end if -c - a_point=0 - b_point=0 - ab=0 -cmp write (6,'(A,3(i5))') 'lasta, lastb, lastc = ',lasta,lastb,lastc -cmp write (6,'(A,2(i5))') 'dima, dimb = ',dima,dimb -c - a_old=0 - b_old=0 -c - do a=1,nv - b_point=0 - do b=1,a - ab=ab+1 - if ((a.ge.(lasta+1)).and.(a.le.(lasta+dima))) then -c - if (a.ne.a_old) then - a_point=a_point+1 - a_old=a - end if -c - if ((b.ge.max(1,lastb+1)).and. - & (b.le.min(a,lastb+dimb))) then -c -! write (6,*) 'b, b_old = ',b,b_old - if ((b.ne.b_old).or.(b.eq.max(1,lastb+1))) then -! write (6,*) 'wft' - b_point=b_point+1 - b_old=b - end if -c -cmp if (lastc.eq.0) write (6,'(A,5(i5))') 'ab, a, b, a_point, b_point = ', -cmp & ab,a,b,a_point,b_point - do c=1,dimc - w3(ab,lastc+c)=AA(a_point,b_point,c) - end do -c - end if - end if -c - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/grow_w3.F90 openmolcas-22.10/src/cht3/grow_w3.F90 --- openmolcas-22.02/src/cht3/grow_w3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_w3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,72 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine grow_w3(w3,AA,nv,d2,dima,dimb,dimc,lasta,lastb,lastc) +! this routine does: +! +! add the block contribution AA(a',b',c') to w3(a>=b,c) + +use Index_Functions, only: nTri_Elem +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nv, d2, dima, dimb, dimc, lasta, lastb, lastc +real(kind=wp), intent(inout) :: w3(nTri_Elem(nv),d2) +real(kind=wp), intent(in) :: AA(dima,dimb,dimc) +integer(kind=iwp) :: a, a_old, a_point, ab, b, b_old, b_point + +if ((dima == 0) .or. (dimb == 0)) then + write(u6,*) 'dima, dimb = ',dima,dimb + write(u6,*) 'zle je' + call abend() +end if + +a_point = 0 +b_point = 0 +ab = 0 +!mp write(u6,'(A,3(i5))') 'lasta, lastb, lastc = ',lasta,lastb,lastc +!mp write(u6,'(A,2(i5))') 'dima, dimb = ',dima,dimb + +a_old = 0 +b_old = 0 + +do a=1,nv + b_point = 0 + do b=1,a + ab = ab+1 + if ((a >= lasta+1) .and. (a <= lasta+dima)) then + + if (a /= a_old) then + a_point = a_point+1 + a_old = a + end if + + if ((b >= max(1,lastb+1)) .and. (b <= min(a,lastb+dimb))) then + + !write(u6,*) 'b, b_old = ',b,b_old + if ((b /= b_old) .or. (b == max(1,lastb+1))) then + !write(u6,*) 'wft' + b_point = b_point+1 + b_old = b + end if + + !mp if (lastc == 0) write(u6,'(A,5(i5))') 'ab, a, b, a_point, b_point = ',ab,a,b,a_point,b_point + w3(ab,lastc+1:lastc+dimc) = AA(a_point,b_point,:) + + end if + end if + + end do +end do + +return + +end subroutine grow_w3 diff -Nru openmolcas-22.02/src/cht3/grow_w3_old.f openmolcas-22.10/src/cht3/grow_w3_old.f --- openmolcas-22.02/src/cht3/grow_w3_old.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/grow_w3_old.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,76 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine grow_w3_old (w3,AA,nv,d2,dima,dimb,dimc, - & lasta,lastb,lastc) -c -c this routine do : -c -c add the block contribution AA(a',b',c') to w3(a>=b,c) -c - implicit none -c - integer a,b,c,dima,dimb,dimc,lasta,lastb,lastc,ab,nv - integer a_point,b_point - integer d2 - real*8 w3(1:(nv*(nv+1))/2,1:d2) - real*8 AA(1:dima,1:dimb,1:dimc) - integer a_old,b_old -c - if ((dima.eq.0).or.(dimb.eq.0)) then - write (6,*) 'dima, dimb = ',dima,dimb - write (6,*) 'zle je' - call abend() - end if -c - a_point=0 - b_point=0 - ab=0 - write (6,'(A,3(i5))') 'lasta, lastb, lastc = ',lasta,lastb,lastc - write (6,'(A,2(i5))') 'dima, dimb = ',dima,dimb -c - a_old=0 - b_old=0 -c - do a=1,nv - b_point=0 - do b=1,a - ab=ab+1 - if ((a.ge.(lasta+1)).and.(a.le.(lasta+dima))) then -c - if (a.ne.a_old) then - a_point=a_point+1 - a_old=a - end if -c - if ((b.ge.max(1,lastb+1)).and. - & (b.le.min(a,lastb+dimb))) then -c -! write (6,*) 'b, b_old = ',b,b_old - if ((b.ne.b_old).or.(b.eq.max(1,lastb+1))) then -! write (6,*) 'wft' - b_point=b_point+1 - b_old=b - end if -c -c! if (lastc.eq.0) write (6,'(A,5(i5))') 'ab, a, b, a_point, b_point = ', -c! & ab,a,b,a_point,b_point - do c=1,dimc - w3(ab,lastc+c)=AA(a_point,b_point,c) - end do -c - end if - end if -c - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/inireord_t3.f openmolcas-22.10/src/cht3/inireord_t3.f --- openmolcas-22.02/src/cht3/inireord_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/inireord_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,322 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine IniReord_t3(NaGrp,wrksize) -c -c nacitanie vsupu a inicializacia premnennych -c a tlac primitivnej hlavicky pre Reord procesz -c -#ifdef _MOLCAS_MPP_ - use Para_Info, only: MyRank, nProcs -#endif - implicit none -#include "cht3_ccsd1.fh" -#include "cht3_reord.fh" -cmp -#include "cholesky.fh" -#include "ccsd_t3compat.fh" -cmp -c - integer NaGrp - integer wrksize -cmp! - integer nOrb(8),nOcc(8) - integer ndelvirt - - integer LuSpool - character*80 LINE -cmp - integer rc - real*8 FracMem - character*3 msg - -#ifdef _MOLCAS_MPP_ - integer jal1, jal2 -#endif -cmp - -c setup defaults - - Call Get_iArray('nOrb',nOrb,1) - Call Get_iArray('nIsh',nOcc,1) - -c - no = nOcc(1) - nv = nOrb(1) - nOcc(1) -c - FracMem=0.0d0 - Call Cho_X_init(rc,FracMem) ! initialize cholesky info -c -c take local # of Cholesky Vectors on this node -#ifdef _MOLCAS_MPP_ -c - do jal1=0,Nprocs-1 - NChLoc(jal1)=0 - end do -c - NChLoc(MyRank)=NumCho(1) - - call gaigop (NChLoc(0),NProcs,'+') -c - jal2=0 - do jal1=0,NProcs-1 - jal2=jal2+NChLoc(jal1) - end do - - nc = jal2 -#else - nc = NumCho(1) -#endif - - Call Cho_X_final(rc) - - ndelvirt = 0 - LunAux = 13 - mhkey = 1 - generkey = 1 -cmp! NaGrp = 1 - Call get_iScalar('CHCCLarge',NaGrp) - restkey = 0 - printkey = 1 - -c t3 specific keywords - - gen_files = .True. - run_triples = .True. - t3_starta = -1 - t3_stopa = -1 - t3_startb = -1 - t3_stopb = -1 -c -cmp! read input file -c - LuSpool = 17 - Call SpoolInp(LuSpool) - Rewind(LuSpool) - 5 Read(LuSpool,'(A80)') LINE - CALL UPCASE(LINE) - IF( INDEX(LINE,'&CHT3') .EQ. 0 ) GOTO 5 - 6 Read(LuSpool,'(A80)') LINE - IF(LINE(1:1).EQ.'*') GOTO 6 - CALL UPCASE(LINE) -c - IF (LINE(1:4).EQ.'TITL') THEN - Read(LuSpool,*) - - ELSE IF (LINE(1:4).EQ.'FROZ') THEN ! FROZen - Read(LuSpool,*) nfr - if ((nfr.lt.0).or.(nfr.ge.no)) then - write (6,*) - write (6,*) 'Ilegal value for FROZen keyword : ', - & nfr - call abend() - end if - no = no - nfr - - ELSE IF (LINE(1:4).EQ.'DELE') THEN ! DELEted - Read(LuSpool,*) ndelvirt - if ((ndelvirt.lt.0).or.(ndelvirt.ge.nv)) then - write (6,*) - write (6,*) 'Ilegal value for DELEted keyword : ', - & ndelvirt - call abend() - end if - nv = nv - ndelvirt - -cmp! ELSE IF (LINE(1:4).EQ.'LARG') THEN ! LARGegroup -cmp! Read(LuSpool,*) NaGrp -cmp! if ((NaGrp.lt.1).or.(NaGrp.gt.32)) then -cmp! write (6,*) -cmp! write (6,*) 'Ilegal value for LARGegroup keyword : ', -cmp! & NaGrp -cmp! write (6,*) 'Large segmentation must be -le 32' -cmp! call abend() -cmp! end if - -cmp! ELSE IF (LINE(1:4).EQ.'LUNA') THEN ... toto sa nikdy nevyuzivalo -cmp! Read(LuSpool,*) LunAux - - ELSE IF (LINE(1:4).EQ.'MHKE') THEN ! MHKEy - Read(LuSpool,*) mhkey - if ((mhkey.lt.0).or.(mhkey.gt.2)) then - mhkey=1 - write(6,*) - write(6,*) ' Warning!!! ', - & ' MHKEy out of range, changed to 1' - end if - - ELSE IF (LINE(1:4).EQ.'REST') THEN ! RESTart - restkey = 1 - write (6,*) - write (6,*) 'RESTart option is temporary disabled' - write (6,*) 'No Restart possible (... yet).' - call abend() - - ELSE IF (LINE(1:4).EQ.'PRIN') THEN ! PRINtkey - Read(LuSpool,*) printkey - if (((printkey.lt.0).or.(printkey.gt.10)).or. - & ((printkey.gt.2).and.(printkey.lt.10))) then - - write (6,*) - write (6,*) 'Ilegal value of the PRINtkey keyword: ', - & printkey - write (6,*) ' Use: 1 (Minimal) ' - write (6,*) ' 2 (Minimal + Timings)' - write (6,*) ' 10 (Debug) ' - call abend() - end if - - ELSE IF (LINE(1:4).EQ.'NOGE') THEN ! NOGEnerate - gen_files = .False. - - ELSE IF (LINE(1:4).EQ.'NOTR') THEN ! NOTRiples - run_triples = .False. - - ELSE IF (LINE(1:4).EQ.'ALOO') THEN ! ALOOp - Read(LuSpool,*) t3_starta, t3_stopa - if ((t3_starta.lt.-1).or.(t3_stopa.lt.-1)) then - write (6,*) 'ALOOp values can be either: ' - write (6,*) '"-1" : indicating normal run, or' - write (6,*) 'positive numbers!' - call abend() - end if - - ELSE IF (LINE(1:4).EQ.'BLOO') THEN ! BLOOp - Read(LuSpool,*) t3_startb, t3_stopb - if ((t3_startb.lt.-1).or.(t3_stopb.lt.-1)) then - write (6,*) 'BLOOp values can be either: ' - write (6,*) '"-1" : indicating normal run, or' - write (6,*) 'positive numbers!' - call abend() - end if - - ELSE IF (LINE(1:4).EQ.'END ') THEN - GOTO 7 - END IF - GOTO 6 -7 CONTINUE - - Call Close_LuSpool(LuSpool) - -c! take care of the cholesky vectors segmentation -c! to lead to < 100 blocks - -cmp checks - if (t3_starta.gt.t3_stopa) then - write (6,*) 'Mismatch in input : ' - write (6,*) 'T3_STARTA = ',t3_starta - write (6,*) 'T3_STOPA = ',t3_stopa - call abend() - end if -c - if (t3_startb.gt.t3_stopb) then - write (6,*) 'Mismatch in input : ' - write (6,*) 'T3_STARTB = ',t3_startb - write (6,*) 'T3_STOPB = ',t3_stopb - call abend() - end if -c - if ((t3_starta.lt.0).and.(t3_stopa.gt.0)) then - write (6,*) 'Mismatch in input : ' - write (6,*) 'T3_STARTA = ',t3_starta - write (6,*) 'T3_STOPA = ',t3_stopa - call abend() - end if -c - if ((t3_startb.lt.0).and.(t3_stopb.gt.0)) then - write (6,*) 'Mismatch in input : ' - write (6,*) 'T3_STARTB = ',t3_startb - write (6,*) 'T3_STOPB = ',t3_stopb - call abend() - end if -c -cmp! if ((t3_starta.gt.0).and.(t3_startb.lt.0)) then -cmp! write (6,*) 'This restart combination not implemented' -cmp! write (6,*) 'T3_STARTA = ',t3_starta -cmp! write (6,*) 'T3_STARTB = ',t3_startb -cmp! call abend -cmp! end if -c -c2 tlac hlavicky - write (6,*) - write (6,*) ' Cholesky Based Closed-Shell (T) code' - write (6,*) - write (6,*) '--------------------------------------------------' - - write (6,'(A,i9)') ' Frozen Orbitals : ', - & nfr - write (6,'(A,i9)') ' Occupied Orbitals : ', - & no - write (6,'(A,i9)') ' Virtual Orbitals : ', - & nv - write (6,'(A,i9)') ' Total number of Cholesky Vectors : ', - & nc - - write (6,*) '--------------------------------------------------' - - write (6,'(A,i9)') ' Large Virtual Segmentation : ', - & NaGrp - - write (6,*) '--------------------------------------------------' - - msg = 'No' - if (gen_files) msg = 'Yes' - - write (6,'(A,A5)') ' Generate Triples Scratch Files? : ', - & msg - - msg = 'No' - if (.not.run_triples) msg = 'Yes' - - write (6,'(A,A5)') ' Stop after Scratch Files generation? : ', - & msg - - write (6,*) '--------------------------------------------------' - - if (t3_starta.eq.-1) then - write (6,'(A,i4)') ' Calculating full loop A ' - else - write (6,'(A,i4)') - & ' VO index triplet to start with in loop A : ',t3_starta - write (6,'(A,i4)') - & ' VO index triplet to stop at in loop A : ',t3_stopa - end if - - if (t3_starta.eq.-1) then - write (6,'(A,i4)') ' Calculating full loop B ' - else - write (6,'(A,i4)') - & ' VO index triplet to start with in loop B : ',t3_startb - write (6,'(A,i4)') - & ' VO index triplet to stop at in loop B : ',t3_stopb - end if - - write (6,*) '--------------------------------------------------' - - write (6,'(A,i9)') ' Lun Number for Aux. Matrixes : ', - & LunAux - write (6,'(A,i9)') ' BLAS/FTN Matrix Handling : ', - & mhkey - - msg = 'No' - if (restkey.eq.1) msg = 'Yes' - - write (6,'(A,A10)') ' Start from RstFil ? : ', - & msg - write (6,'(A,i9)') ' Print level : ', - & printkey - - write (6,*) '--------------------------------------------------' - write (6,*) -c - return -c Avoid unused argument warnings - if (.false.) call Unused_integer(wrksize) - end diff -Nru openmolcas-22.02/src/cht3/inireord_t3.F90 openmolcas-22.10/src/cht3/inireord_t3.F90 --- openmolcas-22.02/src/cht3/inireord_t3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/inireord_t3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,296 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine IniReord_t3(NaGrp) +! nacitanie vsupu a inicializacia premnennych +! a tlac primitivnej hlavicky pre Reord procesz + +use ChT3_global, only: gen_files, LunAux, nc, nfr, no, nv, printkey, run_triples, t3_starta, t3_startb, t3_stopa, t3_stopb +#ifdef _MOLCAS_MPP_ +use Para_Info, only: MyRank, nProcs +use stdalloc, only: mma_allocate, mma_deallocate +#endif +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(out) :: NaGrp +#include "cholesky.fh" +integer(kind=iwp) :: LuSpool, ndelvirt, nOcc(8), nOrb(8), rc +#ifdef _MOLCAS_MPP_ +integer(kind=iwp) :: jal1, jal2 +integer(kind=iwp), allocatable :: NChLoc(:) +#endif +real(kind=wp) FracMem +character(len=80) :: LINE +character(len=3) :: msg + +! setup defaults + +call Get_iArray('nOrb',nOrb,1) +call Get_iArray('nIsh',nOcc,1) + +no = nOcc(1) +nv = nOrb(1)-nOcc(1) + +FracMem = Zero +call Cho_X_init(rc,FracMem) ! initialize cholesky info + +! take local # of Cholesky Vectors on this node +#ifdef _MOLCAS_MPP_ + +call mma_allocate(NChLoc,NProcs,label='NChLoc') +NChLoc(:) = 0 + +NChLoc(MyRank+1) = NumCho(1) + +call gaigop(NChLoc,NProcs,'+') + +jal2 = 0 +do jal1=1,NProcs + jal2 = jal2+NChLoc(jal1) +end do + +call mma_deallocate(NChLoc) + +nc = jal2 +#else +nc = NumCho(1) +#endif + +call Cho_X_final(rc) + +ndelvirt = 0 +LunAux = 13 +!mhkey = 1 +!generkey = 1 +!mp !NaGrp = 1 +call get_iScalar('CHCCLarge',NaGrp) +!restkey = 0 +printkey = 1 + +! t3 specific keywords + +gen_files = .true. +run_triples = .true. +t3_starta = -1 +t3_stopa = -1 +t3_startb = -1 +t3_stopb = -1 + +!mp read input file + +LuSpool = 17 +call SpoolInp(LuSpool) +rewind(LuSpool) +do + read(LuSpool,'(A80)') LINE + call UPCASE(LINE) + if (index(LINE,'&CHT3') /= 0) exit +end do +do + read(LuSpool,'(A80)') LINE + if (LINE(1:1) == '*') cycle + call UPCASE(LINE) + + select case (LINE(1:4)) + + case ('TITL') + read(LuSpool,*) + + case ('FROZ') ! FROZen + read(LuSpool,*) nfr + if ((nfr < 0) .or. (nfr >= no)) then + write(u6,*) + write(u6,*) 'Ilegal value for FROZen keyword : ',nfr + call abend() + end if + no = no-nfr + + case ('DELE') ! DELEted + read(LuSpool,*) ndelvirt + if ((ndelvirt < 0) .or. (ndelvirt >= nv)) then + write(u6,*) + write(u6,*) 'Ilegal value for DELEted keyword : ',ndelvirt + call abend() + end if + nv = nv-ndelvirt + + !mp !case ('LARG') ! LARGegroup + !mp ! read(LuSpool,*) NaGrp + !mp ! if ((NaGrp < 1) .or. (NaGrp > 32)) then + !mp ! write(u6,*) + !mp ! write(u6,*) 'Ilegal value for LARGegroup keyword : ',NaGrp + !mp ! write(u6,*) 'Large segmentation must be <= 32' + !mp ! call abend() + !mp ! end if + + !mp !case ('LUNA') !... toto sa nikdy nevyuzivalo + !mp ! read(LuSpool,*) LunAux + + !case ('MHKE') ! MHKEy + ! read(LuSpool,*) mhkey + ! if ((mhkey < 0) .or. (mhkey > 2)) then + ! mhkey = 1 + ! write(u6,*) + ! write(u6,*) ' Warning!!! ',' MHKEy out of range, changed to 1' + ! end if + + case ('REST') ! RESTart + !restkey = 1 + write(u6,*) + write(u6,*) 'RESTart option is temporary disabled' + write(u6,*) 'No Restart possible (... yet).' + call abend() + + case ('PRIN') ! PRINtkey + read(LuSpool,*) printkey + if (((printkey < 0) .or. (printkey > 10)) .or. ((printkey > 2) .and. (printkey < 10))) then + + write(u6,*) + write(u6,*) 'Ilegal value of the PRINtkey keyword: ',printkey + write(u6,*) ' Use: 1 (Minimal) ' + write(u6,*) ' 2 (Minimal + Timings)' + write(u6,*) ' 10 (Debug) ' + call abend() + end if + + case ('NOGE') ! NOGEnerate + gen_files = .false. + + case ('NOTR') ! NOTRiples + run_triples = .false. + + case ('ALOO') ! ALOOp + read(LuSpool,*) t3_starta,t3_stopa + if ((t3_starta < -1) .or. (t3_stopa < -1)) then + write(u6,*) 'ALOOp values can be either: ' + write(u6,*) '-1 : indicating normal run, or' + write(u6,*) 'positive numbers!' + call abend() + end if + + case ('BLOO') ! BLOOp + read(LuSpool,*) t3_startb,t3_stopb + if ((t3_startb < -1) .or. (t3_stopb < -1)) then + write(u6,*) 'BLOOp values can be either: ' + write(u6,*) '-1 : indicating normal run, or' + write(u6,*) 'positive numbers!' + call abend() + end if + + case ('END ') + exit + + end select +end do + +call Close_LuSpool(LuSpool) + +!! take care of the cholesky vectors segmentation +!! to lead to < 100 blocks + +!mp checks +if (t3_starta > t3_stopa) then + write(u6,*) 'Mismatch in input : ' + write(u6,*) 'T3_STARTA = ',t3_starta + write(u6,*) 'T3_STOPA = ',t3_stopa + call abend() +end if + +if (t3_startb > t3_stopb) then + write(u6,*) 'Mismatch in input : ' + write(u6,*) 'T3_STARTB = ',t3_startb + write(u6,*) 'T3_STOPB = ',t3_stopb + call abend() +end if + +if ((t3_starta < 0) .and. (t3_stopa > 0)) then + write(u6,*) 'Mismatch in input : ' + write(u6,*) 'T3_STARTA = ',t3_starta + write(u6,*) 'T3_STOPA = ',t3_stopa + call abend() +end if + +if ((t3_startb < 0) .and. (t3_stopb > 0)) then + write(u6,*) 'Mismatch in input : ' + write(u6,*) 'T3_STARTB = ',t3_startb + write(u6,*) 'T3_STOPB = ',t3_stopb + call abend() +end if + +!mp !if ((t3_starta < 0) .and. (t3_startb < 0)) then +!mp ! write(u6,*) 'This restart combination not implemented' +!mp ! write(u6,*) 'T3_STARTA = ',t3_starta +!mp ! write(u6,*) 'T3_STARTB = ',t3_startb +!mp ! call abend() +!mp !end if + +!2 tlac hlavicky +write(u6,*) +write(u6,*) ' Cholesky Based Closed-Shell (T) code' +write(u6,*) +write(u6,*) '--------------------------------------------------' + +write(u6,'(A,i9)') ' Frozen Orbitals : ',nfr +write(u6,'(A,i9)') ' Occupied Orbitals : ',no +write(u6,'(A,i9)') ' Virtual Orbitals : ',nv +write(u6,'(A,i9)') ' Total number of Cholesky Vectors : ',nc + +write(u6,*) '--------------------------------------------------' + +write(u6,'(A,i9)') ' Large Virtual Segmentation : ',NaGrp + +write(u6,*) '--------------------------------------------------' + +msg = 'No' +if (gen_files) msg = 'Yes' + +write(u6,'(A,A5)') ' Generate Triples Scratch Files? : ',msg + +msg = 'No' +if (.not. run_triples) msg = 'Yes' + +write(u6,'(A,A5)') ' Stop after Scratch Files generation? : ',msg + +write(u6,*) '--------------------------------------------------' + +if (t3_starta == -1) then + write(u6,'(A,i4)') ' Calculating full loop A ' +else + write(u6,'(A,i4)') ' VO index triplet to start with in loop A : ',t3_starta + write(u6,'(A,i4)') ' VO index triplet to stop at in loop A : ',t3_stopa +end if + +if (t3_starta == -1) then + write(u6,'(A,i4)') ' Calculating full loop B ' +else + write(u6,'(A,i4)') ' VO index triplet to start with in loop B : ',t3_startb + write(u6,'(A,i4)') ' VO index triplet to stop at in loop B : ',t3_stopb +end if + +write(u6,*) '--------------------------------------------------' + +write(u6,'(A,i9)') ' Lun Number for Aux. Matrixes : ',LunAux +!write(u6,'(A,i9)') ' BLAS/FTN Matrix Handling : ',mhkey + +!msg = 'No' +!if (restkey == 1) msg = 'Yes' + +!write(u6,'(A,A10)') ' Start from RstFil ? : ',msg +write(u6,'(A,i9)') ' Print level : ',printkey + +write(u6,*) '--------------------------------------------------' +write(u6,*) + +return + +end subroutine IniReord_t3 diff -Nru openmolcas-22.02/src/cht3/ioind.fh openmolcas-22.10/src/cht3/ioind.fh --- openmolcas-22.02/src/cht3/ioind.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/ioind.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,12 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - INTEGER IOPT(96) - COMMON/IOIND/IOPT diff -Nru openmolcas-22.02/src/cht3/klvaa_oovo.f openmolcas-22.10/src/cht3/klvaa_oovo.f --- openmolcas-22.02/src/cht3/klvaa_oovo.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/klvaa_oovo.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,702 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE klvaa_oovo(ix,ig,iscr,vblock,N,nug, - $ LU,last,ias) -cmp! SUBROUTINE klvaa_oovo(G,ix,it,ig,iscr,vblock,N,nug, -cmpn SUBROUTINE klvaa_oovo(ix,it,ig,iscr,vblock,N,nug, -C -C creates L(alpha>alpha,alpha-alpha) -C DA files LMATICH(ISP)ICH(ISP) -C max G at this place -C -C parallelization (seems to be) irrelevant at the moment -C implemented integer offsets, PV, 14 may 2004. -C - IMPLICIT NONE -#include "ndisk.fh" -#include "dupfiles.fh" -cmp -#include "cht3_ccsd1.fh" -#include "ccsd_t3compat.fh" -#include "WrkSpc.fh" -cmpn -#include "cht3_reord.fh" - integer i_blk,j_blk,b2_chk - integer ngaf,ngal,ngbf,ngbl - integer nind_ngbf,nind_ngbl,nind_ngaf,nind_ngal - integer length,length1,length2 - integer it_exp,it2_tmp,itmp2 - integer ngaa,a_tmp,b1_tmp - integer j_tmp,RAD_tmp -cmp -c integer jjj -cmp -cmpn -cmp -cmp real*8 G(*),ddot_,one - real*8 one -c real*8 ddot_ - parameter (one=1.d0) - integer ix,ig,iscr, KADT, IJS, RAD, AADT - integer isp,ias,vblock,n,i,j,k,lu,iasblock - INTEGER A,A1,A2,B1,B2,NSTEP,ADIM,NUG,NGA,NGB,R,MAXDIM2 - INTEGER IS2,KI, last,indab -c CHARACTER FN*6 - INTEGER nno -c INTEGER m -cmp - integer il1,itmp,il2 -cmp -#include "uhf.fh" -#include "ioind.fh" - indab(i,j)=(max(i,j)-1)*max(i,j)/2+min(i,j) -c -C -cmp write(6,*) 'Entering klvaa_oovo' -C - ISP=1 - iasblock=NNOAB(ISP)*vblock*N/nblock - if((iasblock*nblock).lt.(NNOAB(ISP)*vblock*N))iasblock=iasblock+1 - nno=(noab(isp)+1)*noab(isp)/2 - !!call w_alloc(ix,nnoab(ISP)*vblock*n,'IX klvaao ') - !!call w_alloc(ig,noab(isp)*nuab(isp)*nnoab(isp),'IG klvaao') - !!call w_alloc(iscr,nuab(isp)*nuab(isp)*nnoab(isp),'ISCR klvaao') - !FN(1:5)='OOVOI' - !FN(6:6)=ICH(ISP) - !!CALL GET3DM(FN,G(ig),NUAB(ISP)*NOAB(ISP),NNOAB(ISP),0) -C -C call EXPA1_UHF(G(IT),nnoab(isp),NUAB(ISP),-1,G(ISCR)) -C expa done here. remains in it address -cmpn IJS=IT -cmpn do i=2,noab(isp) -cmpn do j=1,i-1 -cmpn KADT=IT+(i-1)*noab(isp)*nnuab(3)+(j-1)*nnuab(3) -cmpn !!call dcopy_(NNUAB(3),G(KADT),1,G(IJS),1) -cmpncmp! call vneg_cht3(G(KADT),1,G(IJS),1,NNUAB(3)) -cmpn call vneg_cht3(Work(KADT),1,Work(IJS),1,NNUAB(3)) -cmpncmp! CALL TRANSM_A(G(KADT),G(IJS),NUAB(ISP),NUAB(ISP)) -cmpn CALL TRANSM_A(Work(KADT),Work(IJS),NUAB(ISP),NUAB(ISP)) -cmpn IJS=IJS+NNUAB(3) -cmpn enddo ! j -cmpn enddo ! i -c - IAS=1 - ngaa=0 -cmpn - do A1=1,NUAB(ISP),vblock -C not needed call zeroma(g(ix),1,nnoab(isp)*vblock*n) - adim=min(vblock,nuab(isp)-A1+1) - A2=A1+adim-1 -cmpn - ngaa=ngaa+1 -c -cmp write (6,*) -cmp write (6,*) '=================================' -cmp write (6,*) ' nga ',ngaa -cmp write (6,*) '=================================' -cmp write (6,*) -c -cmp write (6,'(A,2(i5,2x))') 'b1,b2 = ',a1,a2 -c - call block_interf(1,1,a1,a2, - & ngaf,ngal,nind_ngaf,nind_ngal, - & ngbf,ngbl,nind_ngbf,nind_ngbl) -c -cmp write (6,'(A,4(i5,2x))') 'ngbf, ngbl, nind_ngbf, nind_ngbl', -cmp & ngbf,ngbl,nind_ngbf,nind_ngbl -c -c - read amplitudes T2(nv,vblock,jl,ai) - K=0 - do I=2,NOAB(ISP) - do J=1,I-1 - K=K+1 - !!do K=1,NNOAB(ISP) - IJS=IX+(K-1)*adim*n - !!KADT=(a1-1)*noab(isp)+IG+(K-1)*noab(isp)*nuab(isp) - do a=A1,A2 - KADT=(J-1)*nno*nuab(isp)+(A-1)*nno + IG -1 - do r=1,noab(isp) -C -cmp G(IJS+r-1)=G(KADT+indab(r,i)) - Work(IJS+r-1)=Work(KADT+indab(r,i)) - enddo - KADT=(I-1)*nno*nuab(isp)+(A-1)*nno + IG -1 - do r=1,noab(isp) -C - -cmp G(IJS+r-1)=G(IJS+r-1)-G(KADT+indab(r,j)) - Work(IJS+r-1)=Work(IJS+r-1)-Work(KADT+indab(r,j)) - enddo -!! call dcopy_(noab(isp),G(KADT),1,G(IJS),1) - IJS=IJS+N -!! KADT=KADT+noab(isp) - enddo -C now the T2 -cmpn - !!KADT=ISCR+(K-1)*NUAB(ISP)*NUAB(ISP) +(A1-1)*NUAB(ISP) -cmp KADT=IT+(K-1)*NUAB(ISP)*NUAB(ISP) +(A1-1)*NUAB(ISP) - IJS=NOAB(ISP)+IX+(K-1)*adim*n -c - a_tmp=a1-nind_ngbf -cmp write (6,*) 'K, a1, a_tmp',k,a1,a_tmp -c - KADT=it_exp+(K-1)*NUAB(ISP)*length2 - & +(a_tmp-1)*NUAB(ISP) -c - do a=A1,A2 -cmp call dcopy_(NUAB(isp),G(KADT),1,G(IJS),1) - call dcopy_(NUAB(isp),Work(KADT),1,Work(IJS),1) -cmp write (6,*) (Work(KADT+a_tmp),a_tmp=0,NUAB(isp)-1) - !!write(6,'(A,2I3,11D10.4)')'OT',K,a,(G(r),r=IJS-noab(isp) - !!$,IJS+nuab(isp)-1) -c - KADT=KADT+NUAB(ISP) - IJS=IJS+N - enddo !A - enddo !J - enddo !I - !!enddo ! K - !!write(6,'(A,2I5,4x,5D15.10)') - !!$'block-m:a1,IAS,ddot',a1,ias, - !!$ddot_(N*adim*nnoab(ISP),G(IX),1,g(ix),1),(G(I),I=IX,IX+3) -cmp call multi_wridir(G(IX),n*adim*nnoab(isp),LU,IAS, last) -cmp -cmpn do jjj=0,n*adim*nnoab(isp)-1 -cmpn if (abs(Work(ix+jjj)).gt.10000) then -cmpn write (*,*) 'fucko 2' -cmpn write (*,*) jjj,Work(ix+jjj) -cmpn stop -cmpn end if -cmpn end do -cmp - call multi_wridir(Work(IX),n*adim*nnoab(isp),LU,IAS, last) - IAS=IAS+iasblock -c -cmp - call GetMem('it4_exp','Free','Real',it_exp,length) -cmp - enddo ! A1 -cmp write (6,*) 'cast 1 ok' -cmpn - - IS2=3-ISP -C lmat -cmp! Mozes odjbt ix, iscr, ig -cmp write (6,*) 'test 2 na iscr ',vblock*noab(1)*noab(1) -cmp write (6,*) 'test 2 na ig ',noab(1)*nuab(1)*nno -cmp write (6,*) 'test 2 na ix ',noab(1)*noab(1)*vblock*n -cmp write (6,*) 'nno (2) = ',nno - call GetMem('c2_iscr','Free','Real',iscr, - & vblock*noab(1)*noab(1)) - call GetMem('c2_ig','Free','Real',ig, - & noab(1)*nuab(1)*nno) - call GetMem('c2_ix','Free','Real',ix, - & noab(1)*noab(1)*vblock*n) -cmp write (*,*) 'n (2) = ',n -cmp call w_memchk('IX klvaa ') -cmp call w_free(g(ix),0,'klvaaix') -cmp call w_alloc(ix,nnoab(isp)*vblock*vblock,'Ix klvaa-v') -cmp - call GetMem('klv_oo_ix','Allo','Real',ix, - & nnoab(isp)*vblock*vblock) -cmp -C starts integrals -c FN(1:5)='VVOOI' - !!FN(6:6)=ich(isp) -c FN(6:6)=ich(3) -cmp! CALL GET3DM(FN,G(it),NNUAB(3),NNOAB(3),0) -cmp -cmp! call w_alloc(il1,nc*no*maxdim,'IL1 klvaa-v') -cmpn call GetMem('klv_oo_il1','Allo','Real',il1, -cmpn & nc*no*maxdim) -cmp! call w_alloc(itmp, -cmp! & max(nc*no*maxdim,maxdim*maxdim*no*no),'IL2 klvaa-v') -cmpn call GetMem('klv_oo_itmp','Allo','Real',itmp, -cmpn & max(nc*no*maxdim,maxdim*maxdim*no*no)) -cmp! call w_alloc(il2, -cmp! & max(nc*no*maxdim,maxdim*maxdim*no*no),'IL2 klvaa-v') -cmpn call GetMem('klv_oo_il2','Allo','Real',il2, -cmpn & max(nc*no*maxdim,maxdim*maxdim*no*no)) -c -cmp! call gen_vvoo(G(it),G(il1),G(itmp),G(il2)) -cmpn call gen_vvoo(Work(it),Work(il1),Work(itmp),Work(il2)) - -cmp! open (unit=36,file='vvoo_moje') -cmp! do i=0,NNUAB(3)*NNOAB(3)-1 -cmp! if (abs(G(it+i)).lt.1.0d-7) G(it+i)=0.0d0 -cmp! write (36,*) i,G(it+i) -cmp! end do -cmp! close (36) -c -cmp! call w_free(G(il1),0,'IL1 klvaa-v') -cmpn call GetMem('klv_oo_il2','Free','Real',il2, -cmpn & max(nc*no*maxdim,maxdim*maxdim*no*no)) -cmpn call GetMem('klv_oo_itmp','Free','Real',itmp, -cmpn & max(nc*no*maxdim,maxdim*maxdim*no*no)) -cmpn call GetMem('klv_oo_il1','Free','Real',il1, -cmpn & nc*no*maxdim) - -cmp write(6,*)ddot_(nnoab(3)*nnuab(3),G(it),1,G(it),1) - -cmp - !!call dscal_(NNUAB(3)*NNOAB(3),-1.d0,G(it),1) - !!call dscal_(NNUAB(isp)*NNOAB(ISP),-1.d0,G(it),1) -C -C number of blocks written in a single multiwrite -C - iasblock=vblock*vblock*nnoab(isp)/nblock - if((iasblock*nblock).lt.(vblock*vblock*nnoab(isp))) - $ iasblock=iasblock+1 -!! write(6,*)'create_aa vvoo iasblock',iasblock -C -!! FN(1:4)='VMAT' -!! FN(6:6)=ich(isp) -!! FN(5:5)=ich(isp) -!! call multi_opendir(FN,LU) -C currently using 3-dim (big field) - will be replaced after changing -C stepiv and the rest - do nga=1,nug - A1=(nga-1)*vblock+1 - adim=min(vblock,nuab(isp)-A1+1) - A2=A1+adim-1 - do ngb=1,nga - if(nga.eq.ngb)then - maxdim2=adim*(adim-1)/2 - else - maxdim2=adim*vblock - endif - B1=(ngb-1)*vblock+1 -cmpn -cmp write (6,*) -cmp write (6,*) '=================================' -cmp write (6,*) ' nga, ngb',nga,ngb -cmp write (6,*) '=================================' -cmp write (6,*) -c -cmpn -c - check the largest b2 -c -cmp b2_chk=b1-1+min(vblock,a2-b1) -cmpn b2_chk=b1-1+vblock - b2_chk=b1+min(vblock,nuab(isp)-b1+1)-1 -c -c - find out which T2 blocked files will be needed -c for particular nga, ngb -c -cmp write (6,'(A,4(i5,2x))') 'a1,a2,b1,b2_chk = ',a1,a2,b1,b2_chk -c - call block_interf(a1,a2,b1,b2_chk, - & ngaf,ngal,nind_ngaf,nind_ngal, - & ngbf,ngbl,nind_ngbf,nind_ngbl) -c -cmp write (6,'(A,4(i5,2x))') 'ngaf, ngal, nind_ngaf, nind_ngal', -cmp & ngaf,ngal,nind_ngaf,nind_ngal -cmp write (6,'(A,4(i5,2x))') 'ngbf, ngbl, nind_ngbf, nind_ngbl', -cmp & ngbf,ngbl,nind_ngbf,nind_ngbl -c -c - read amplitudes from T2_ngaf_ngbf ... T2_ngaf_ngbl, nga>=ngb -c .... .... -c T2ngal_ngbf ... T2_ngal_ngbl, nga>=ngb -c -c - calculate memory requirements (consider squared T2(a',a')) -c - length1=0 - do i_blk=ngaf,ngal - length1=length1+DimGrpaR(i_blk) - end do -c - length2=0 - do j_blk=ngbf,ngbl - length2=length2+DimGrpaR(j_blk) - end do -c -cmp write (6,*) 'length1, vblock = ',length1,vblock -cmp write (6,*) 'length2, vblock = ',length2,vblock -c - length=length1*length2*no*no -cmp write (6,*) 'length for blocked VVOO integrals = ',length -c -c - setup memory -c -cmp write (6,*) 'allocating t2_exp = ',length - call GetMem('it5_exp','Allo','Real',it_exp,length) -c -c - read pertinent files and generate block of vvoo integrals -c - call GetMem('vvooil1','Allo','Real',il1, - & nc*no*maxdim) - call GetMem('vvooitmp','Allo','Real',itmp, - & max(nc*no*maxdim,maxdim*maxdim*no*no)) - call GetMem('vvooil2','Allo','Real',il2, - & max(nc*no*maxdim,maxdim*maxdim*no*no)) -cmp - call gen_vvoo_blocked(Work(it_exp),Work(il1), - & Work(itmp),Work(il2), - & length1,length2,ngaf,ngal,ngbf,ngbl) -cmp - call GetMem('vvooil2','Free','Real',il2, - & max(nc*no*maxdim,maxdim*maxdim*no*no)) - call GetMem('vvooitmp','Free','Real',itmp, - & max(nc*no*maxdim,maxdim*maxdim*no*no)) - call GetMem('vvooil1','Free','Real',il1, - & nc*no*maxdim) -cmpn - do a=a1,a2 - B2=B1-1+min(vblock,A-B1) - NSTEP=B2-B1+1 - if(nstep.ne.0)then - if(nga.eq.ngb)then - IJS=(a-a1-1)*(a-a1)/2+IX - else - IJS=(a-a1)*vblock+IX - endif - R=0 - do I=2,NOAB(ISP) - do J=1,I-1 - !!R=R+1 - !!do R=1,NNOAB(ISP) - !!KADT=(R-1)*NNUAB(ISP) -cmpn R=(J-1)*noab(isp)+I -cmpn KADT=(R-1)*NNUAB(3) -cmpn KADT=KADT+(a-1)*NUAB(ISP) +B1 +IT -1 -c - a_tmp=a-nind_ngaf - b1_tmp=b1-nind_ngbf -c -cmp write (6,'(A,5(i4,x))') 'a,b1,I,J,nstep ',a,b1,I,J,nstep -cmp write (6,'(A,5(i4,x))') 'a_tmp,b1_tmp ',a_tmp,b1_tmp - do j_tmp=0,nstep-1 -c - KADT=(i-1)*noab(isp)*length1*length2+ - & (j-1)*length1*length2+(b1_tmp+j_tmp-1)*length1+ - & a_tmp+it_exp-1 -c - Work(IJS+j_tmp)=Work(KADT) -c - end do -c -C address and block for the A1-A2x B1-B2 - !!KADT=KADT+(a-1)*(a-2)/2 +B1 +IT -1 -C VO >>> G(IX) -cmpn call dcopy_(NSTEP,Work(KADT),1,Work(IJS),1) -cmpn R=(I-1)*noab(isp)+J -cmpn KADT=(R-1)*NNUAB(3) -cmpn KADT=KADT+(a-1)*NUAB(ISP) +B1 +IT -1 - do j_tmp=0,nstep-1 -c - KADT=(j-1)*noab(isp)*length1*length2+ - & (i-1)*length1*length2+(b1_tmp+j_tmp-1)*length1+ - & a_tmp+it_exp-1 -c - Work(IJS+j_tmp)=Work(IJS+j_tmp)-1.0d0*Work(KADT) -c - end do -cmpn -cmpn call daxpy_(NSTEP,-1.d0,Work(KADT),1,Work(IJS),1) - !!write(6,'(A,2I3,8D15.8)')'T',(I-1)*(I-2)/2+j - !!$,a,(G(r),r=IJS,IJS+NSTEP-1) - IJS=IJS+maxdim2 - enddo ! RI - enddo ! RJ - endif - enddo ! a1 - !!write(6,'(A,4I5,4x,5D15.10)') - !!$'block-m: a1,b1,IAS,ddot',a1,b1,ias,maxdim2, - !!$ ddot_(nnoab(isp)*maxdim2,G(IX),1,G(IX),1),(G(I),I=IX,IX+3) - IF(maxdim2.eq.0)then - maxdim2=1 - endif -cmp call multi_wridir(G(IX),nnoab(isp)*maxdim2,LU,IAS, last) -cmp -cmpn do jjj=0,nnoab(isp)*maxdim2-1 -cmpn if (abs(Work(ix+jjj)).gt.10000) then -cmpn write (*,*) 'fucko 3' -cmpn write (*,*) jjj,Work(ix+jjj) -cmpn stop -cmpn end if -cmpn end do -cmp - call multi_wridir(Work(IX),nnoab(isp)*maxdim2,LU,IAS, last) - ias=ias+iasblock -c -cmp write (6,*) 'deallocating t2_exp = ',length - call GetMem('it5_exp','Free','Real',it_exp,length) -c - enddo ! ngb - enddo ! nga -cmp write (6,*) 'cast 2 ok' -cmp call w_memchk('all klvaa ') -cmp call w_free(g(ix),0,'klvaa ') -cmp - call GetMem('klv_oo_ix','Free','Real',ix, - & nnoab(isp)*vblock*vblock) -cmp - !!call w_free(g(it),0,'klvaa ') -cmp call w_alloc(ix,nnoab(3)*vblock*vblock,'ix-vvoo') -cmp - call GetMem('klv_oo_ix','Allo','Real',ix, - & nnoab(3)*vblock*vblock) -cmp - !!call w_alloc(ig,nnoab(3)*nnuab(3),'ig-vvoo') -cmpn ig=it -C from now on as for uhf - iasblock=nnoab(3)*vblock*vblock/nblock - if((iasblock*nblock).lt.(nnoab(3)*(vblock**2)))iasblock=iasblock+1 -!! FN(1:5)='VVOOI' -!! FN(6:6)=ICH(3) -!! CALL GET3DM(FN,G(IG),NNUAB(3),NNOAB(3),0) -C (c>d|AK) - -cmpn - nga=0 -cmpn - DO A1=1,NUAB(ISP),vblock - A2=A1+min(vblock,nuab(isp)-A1+1)-1 - adim=A2-A1+1 -cmpn - nga=nga+1 - ngb=0 -cmpn - do B1=1,NUAB(IS2),vblock -cmpn - ngb=ngb+1 -cmpn - NSTEP=min(vblock,nuab(is2)-B1+1) -cmpn -cmpn -cmp write (6,*) -cmp write (6,*) '=================================' -cmp write (6,*) ' nga, ngb',nga,ngb -cmp write (6,*) '=================================' -cmp write (6,*) -c -c - check the largest b2 -c -cmp b2_chk=b1-1+min(vblock,nuab(is2)-B1+1) -cmpn b2_chk=b1-1+vblock - b2_chk=b1+min(vblock,nuab(is2)-B1+1)-1 -c -c - find out which T2 blocked files will be needed -c for particular nga, ngb -c -cmp write (6,'(A,4(i5,2x))') 'a1,a2,b1,b2_chk = ',a1,a2,b1,b2_chk -c - if (nga.lt.ngb) then -cmp write (6,*) 'switching nga, ngb',ngb,nga -c - call block_interf(b1,b2_chk,a1,a2, - & ngaf,ngal,nind_ngaf,nind_ngal, - & ngbf,ngbl,nind_ngbf,nind_ngbl) -c - else -c - call block_interf(a1,a2,b1,b2_chk, - & ngaf,ngal,nind_ngaf,nind_ngal, - & ngbf,ngbl,nind_ngbf,nind_ngbl) -c - end if -c -cmp write (6,'(A,4(i5,2x))') 'ngaf, ngal, nind_ngaf, nind_ngal', -cmp & ngaf,ngal,nind_ngaf,nind_ngal -cmp write (6,'(A,4(i5,2x))') 'ngbf, ngbl, nind_ngbf, nind_ngbl', -cmp & ngbf,ngbl,nind_ngbf,nind_ngbl -c -c - read amplitudes from T2_ngaf_ngbf ... T2_ngaf_ngbl, nga>=ngb -c .... .... -c T2ngal_ngbf ... T2_ngal_ngbl, nga>=ngb -c -c - calculate memory requirements (consider squared T2(a',a')) -c - length1=0 - do i_blk=ngaf,ngal - length1=length1+DimGrpaR(i_blk) - end do -c - length2=0 - do j_blk=ngbf,ngbl - length2=length2+DimGrpaR(j_blk) - end do -c -cmp write (6,*) 'length1, vblock = ',length1,vblock -cmp write (6,*) 'length2, vblock = ',length2,vblock -c - length=length1*length2*no*no -cmp write (6,*) 'length for blocked VVOO integrals = ',length -c -c - setup memory -c -cmp write (6,*) 'allocating t2_exp = ',length - call GetMem('it6_exp','Allo','Real',it_exp,length) -c -c - read pertinent files and generate block of vvoo integrals -c - call GetMem('vvooil1','Allo','Real',il1, - & nc*no*maxdim) - call GetMem('vvooitmp','Allo','Real',itmp, - & max(nc*no*maxdim,maxdim*maxdim*no*no)) - call GetMem('vvooil2','Allo','Real',il2, - & max(nc*no*maxdim,maxdim*maxdim*no*no)) -cmp - call gen_vvoo_blocked(Work(it_exp),Work(il1), - & Work(itmp),Work(il2), - & length1,length2,ngaf,ngal,ngbf,ngbl) -cmp - call GetMem('vvooil2','Free','Real',il2, - & max(nc*no*maxdim,maxdim*maxdim*no*no)) - call GetMem('vvooitmp','Free','Real',itmp, - & max(nc*no*maxdim,maxdim*maxdim*no*no)) - call GetMem('vvooil1','Free','Real',il1, - & nc*no*maxdim) -cmpn -!! bdim=NSTEP -C mv T2(B,A,I,K) >> G(ix) - KI=0 - do K=1,noab(isp) - KADT=(K-1)*NNUAB(3)*(NOAB(2)*(2-ISP)+ISP-1) - DO I=1,NOAB(IS2) - KI=KI+1 -cmpn IADT=(I-1)*NNUAB(3)*(NOAB(2)*(2-IS2)+IS2-1) -cmpn BADT=(2-ISP)*B1+(ISP-1)*(B1-1)*NUAB(2) - do A=A1,A2 -cmpn - if (nga.lt.ngb) then - a_tmp=a-nind_ngbf - b1_tmp=b1-nind_ngaf - else - a_tmp=a-nind_ngaf - b1_tmp=b1-nind_ngbf - end if -cmpn -cmpn AADT=IADT+KADT+BADT+A*(ISP-1)+(2-ISP) -cmpn $ *(A-1)*NUAB(2)+IG-1 -C T2 for isp=1 T2 for isp=2 -!! - RAD=(KI-1)*adim*nstep+(A-A1)*nstep +IX -cmpn ISTEP=(ISP-1)*NUAB(2)+2-ISP -cmpn - if (nga.ge.ngb) then ! nga> ngb - -cmp write (6,'(A,4(i5,2x),3x,i5)') '(I) a_tmp,b1_tmp,k,i nstep = ', -cmp & a_tmp,b1_tmp,k,i,nstep -c T2(B1,A,I,K) =? T2(A,B1,K,I) - do j_tmp=0,NSTEP-1 ! istep je 1 ak dobre tusim -c - AADT=(I-1)*length1*length2*NOAB(2)+(K-1)*length1*length2+ - & (b1_tmp-1+j_tmp)*length1+a_tmp+it_exp-1 -c - RAD_tmp=RAD+j_tmp -c - Work(RAD_tmp)=Work(AADT) -c - end do -c - else ! nga < ngb -c -cmp write (6,'(A,4(i5,2x),3x,i5)') '(II) b1_tmp,a_tmp,k,i nstep = ', -cmp & b1_tmp,a_tmp,i,k,nstep -c T2(B1,A,I,K) - do j_tmp=0,NSTEP-1 ! istep je 1 ak dobre tusim -c - AADT=(k-1)*length1*length2*NOAB(2)+(i-1)*length1*length2+ - & (a_tmp-1)*length1+b1_tmp+j_tmp+it_exp-1 -c - RAD_tmp=RAD+j_tmp -c - Work(RAD_tmp)=Work(AADT) -c - end do - end if -cmpn -cmpn call dcopy_(NSTEP,Work(AADT),ISTEP,Work(RAD),1) - - enddo ! A - enddo ! I - enddo ! K - !!write(6,'(A,3I5,4x,5D15.10)') - !!$'block-v: a1,b1,IAS,ddot',a1/vblock+1,b1/vblock+1,ias, - !!$ ddot_(NNOAB(3)*adim*nstep,G(IX),1,G(IX),1),(G(I),I=IX,IX+3) -cmp call multi_wridir(G(IX),NNOAB(3)*adim*nstep,LU,IAS, last) -cmp -cmpn do jjj=0,NNOAB(3)*adim*nstep-1 -cmpn if (abs(Work(ix+jjj)).gt.10000) then -cmpn write (*,*) 'fucko 1' -cmpn write (*,*) jjj,Work(ix+jjj) -cmpn stop -cmpn end if -cmpn end do -cmp - call multi_wridir(Work(IX),NNOAB(3)*adim*nstep,LU,IAS, last) - ias=ias+iasblock -cmpn - call GetMem('it6_exp','Free','Real',it_exp,length) -cmpn - enddo ! B1 - enddo ! A1 -cmp write (6,*) 'cast 3 ok' - !!close (LU) in calling routine -! write(6,*) FN, isp, IAS - !!dupblk(ndup)=last in calling routine -cmp call w_memchk('all klvaa ') - !!call w_free(g(ix),0,'IT klvaa ') in calling routine -cmp - call GetMem('klv_oo_ix','Free','Real',ix, - & nnoab(3)*vblock*vblock) -cmp -cmpn - if (printkey.gt.1) then - write (6,*) 'VVOO integrals regenerated from MOLCAS' - end if - -cmpn - call xflush(6) - !!stop -c - return - end diff -Nru openmolcas-22.02/src/cht3/klvaa_oovo.F90 openmolcas-22.10/src/cht3/klvaa_oovo.F90 --- openmolcas-22.02/src/cht3/klvaa_oovo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/klvaa_oovo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,605 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! This subroutine should be in a module, to avoid explicit interfaces +#ifdef _IN_MODULE_ + +subroutine klvaa_oovo(x,g,vblock,N,nug,LU,last,ias) +!mp !subroutine klvaa_oovo(G,ix,it,ig,iscr,vblock,N,nug,LU,last,ias) +!mpn subroutine klvaa_oovo(ix,it,ig,iscr,vblock,N,nug,LU,last,ias) +! +! creates L(alpha>alpha,alpha-alpha) +! DA files LMATICH(ISP)ICH(ISP) +! max G at this place +! +! parallelization (seems to be) irrelevant at the moment +! implemented integer offsets, PV, 14 may 2004. + +use ChT3_global, only: DimGrpaR, maxdim, nblock, nc, NNOAB, NNUAB, no, NOAB, NUAB, printkey +use Index_Functions, only: iTri, nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +real(kind=wp), allocatable, intent(_OUT_) :: x(:) +real(kind=wp), allocatable, intent(inout) :: g(:) +integer(kind=iwp), intent(in) :: vblock, N, nug, LU +integer(kind=iwp), intent(out) :: last, ias +integer(kind=iwp) :: A, A1, A2, a_tmp, AADT, ADIM, B1, b1_tmp, B2, b2_chk, i, i_blk, iasblock, IJS, IS2, isp, j, j_blk, j_tmp, k, & + KADT, KI, length, length1, length2, MAXDIM2, NGA, ngaa, ngaf, ngal, NGB, ngbf, ngbl, nind_ngaf, nind_ngal, & + nind_ngbf, nind_ngbl, nno, NSTEP, R, RAD +real(kind=wp), allocatable :: l1(:), l2(:), t2_exp(:), t2_tmp(:), tmp(:), tmp2(:), x2(:) + +!mp write(u6,*) 'Entering klvaa_oovo' + +ISP = 1 +iasblock = NNOAB(ISP)*vblock*N/nblock +if ((iasblock*nblock) < (NNOAB(ISP)*vblock*N)) iasblock = iasblock+1 +nno = nTri_Elem(noab(isp)) +!!call w_alloc(ix,nnoab(ISP)*vblock*n,'IX klvaao') +!!call w_alloc(ig,noab(isp)*nuab(isp)*nnoab(isp),'IG klvaao') +!!call w_alloc(iscr,nuab(isp)*nuab(isp)*nnoab(isp),'ISCR klvaao') +!FN = 'OOVOI'//ICH(ISP) +!!call GET3DM(FN,G(ig),NUAB(ISP)*NOAB(ISP),NNOAB(ISP),0) + +!call EXPA1_UHF(G(IT),nnoab(isp),NUAB(ISP),-1,G(ISCR)) +! expa done here. remains in it address +!mpn IJS = IT +!mpn do i=2,noab(isp) +!mpn do j=1,i-1 +!mpn KADT = IT+(i-1)*noab(isp)*nnuab(3)+(j-1)*nnuab(3) +!mpn !!call dcopy_(NNUAB(3),G(KADT),1,G(IJS),1) +!mpncmp !call vneg_cht3(G(KADT),1,G(IJS),1,NNUAB(3)) +!mpn Work(IJS:IJS+NNUAB(3)-1) = -Work(KADT:KADT+NNUAB(3)-1) +!mpncmp !call TRANSM_A(G(KADT),G(IJS),NUAB(ISP),NUAB(ISP)) +!mpn call TRANSM_A(Work(KADT),Work(IJS),NUAB(ISP),NUAB(ISP)) +!mpn IJS = IJS+NNUAB(3) +!mpn end do ! j +!mpn end do ! i + +IAS = 1 +ngaa = 0 +!mpn +do A1=1,NUAB(ISP),vblock + ! not needed call zeroma(g(ix),1,nnoab(isp)*vblock*n) + adim = min(vblock,nuab(isp)-A1+1) + A2 = A1+adim-1 + !mpn + ngaa = ngaa+1 + + !mp write(u6,*) + !mp write(u6,*) '=================================' + !mp write(u6,*) ' nga ',ngaa + !mp write(u6,*) '=================================' + !mp write(u6,*) + + !mp write(u6,'(A,2(i5,2x))') 'b1,b2 = ',a1,a2 + + call block_interf(1,1,a1,a2,ngaf,ngal,nind_ngaf,nind_ngal,ngbf,ngbl,nind_ngbf,nind_ngbl) + + !mp write(u6,'(A,4(i5,2x))') 'ngbf, ngbl, nind_ngbf, nind_ngbl',ngbf,ngbl,nind_ngbf,nind_ngbl + + ! - read amplitudes T2(nv,vblock,jl,ai) + K = 0 + do I=2,NOAB(ISP) + do J=1,I-1 + K = K+1 + !!do K = 1,NNOAB(ISP) + IJS = (K-1)*adim*N + !!KADT = (a1-1)*noab(isp)+(K-1)*noab(isp)*nuab(isp)+1 + do a=A1,A2 + KADT = (J-1)*nno*nuab(isp)+(A-1)*nno + do r=1,noab(isp) + ! + !mp G(IJS+r) = G(KADT+iTri(r,i)) + x(IJS+r) = g(KADT+iTri(r,i)) + end do + KADT = (I-1)*nno*nuab(isp)+(A-1)*nno + do r=1,noab(isp) + ! - + !mp G(IJS+r) = G(IJS+r)-G(KADT+iTri(r,j)) + x(IJS+r) = x(IJS+r)-g(KADT+iTri(r,j)) + end do + !!call dcopy_(noab(isp),G(KADT),1,G(IJS),1) + IJS = IJS+N + !!KADT = KADT+noab(isp) + end do + ! now the T2 + !mpn + !!KADT = ISCR+(K-1)*NUAB(ISP)*NUAB(ISP)+(A1-1)*NUAB(ISP) + !mp KADT = IT+(K-1)*NUAB(ISP)*NUAB(ISP)+(A1-1)*NUAB(ISP) + IJS = 1+NOAB(ISP)+(K-1)*adim*N + + a_tmp = a1-nind_ngbf + !mp write(u6,*) 'K, a1, a_tmp',k,a1,a_tmp + + KADT = 1+(K-1)*NUAB(ISP)*length2+(a_tmp-1)*NUAB(ISP) + + do a=A1,A2 + !mp call dcopy_(NUAB(isp),G(KADT),1,G(IJS),1) + x(IJS:IJS+NUAB(isp)-1) = t2_exp(KADT:KADT+NUAB(isp)-1) + !mp write(u6,*) (t2_exp(KADT+a_tmp),a_tmp=0,NUAB(isp)-1) + !!write(u6,'(A,2I3,11D10.4)')'OT',K,a,(G(r),r=IJS-noab(isp),IJS+nuab(isp)-1) + + KADT = KADT+NUAB(ISP) + IJS = IJS+N + end do !A + end do !J + end do !I + !!enddo !K + !!write(u6,'(A,2I5,4x,5D15.10)') 'block-m:a1,IAS,ddot',a1,ias,ddot_(N*adim*nnoab(ISP),G(IX),1,G(IX),1),(G(I),I=IX,IX+3) + !mp call multi_wridir(G(IX),n*adim*nnoab(isp),LU,IAS,last) + !mp + !mpn do jjj=1,n*adim*nnoab(isp) + !mpn if (abs(x(jjj)) > 1.0e5_wp) then + !mpn write(u6,*) 'fucko 2' + !mpn write(u6,*) jjj,x(jjj) + !mpn stop + !mpn end if + !mpn end do + !mp + call multi_wridir(x,N*adim*nnoab(isp),LU,IAS,last) + IAS = IAS+iasblock + + !mp + call mma_deallocate(t2_exp) + !mp +end do ! A1 + !mp write(u6,*) 'cast 1 ok' + !mpn + +IS2 = 3-ISP +! lmat +!mp ! Mozes odjbt ix, iscr, ig +!mp write(u6,*) 'test 2 na iscr ',vblock*noab(1)*noab(1) +!mp write(u6,*) 'test 2 na ig ',noab(1)*nuab(1)*nno +!mp write(u6,*) 'test 2 na ix ',noab(1)*noab(1)*vblock*n +!mp write(u6,*) 'nno (2) = ',nno +!call GetMem('c2_iscr','Free','Real',iscr,vblock*noab(1)*noab(1)) +call mma_deallocate(g) +call mma_deallocate(x) +!mp write(u6,*) 'n (2) = ',n +!mp call w_memchk('IX klvaa ') +!mp call w_free(g(ix),0,'klvaaix') +!mp call w_alloc(ix,nnoab(isp)*vblock*vblock,'Ix klvaa-v') +!mp +call mma_allocate(x2,nnoab(isp)*vblock*vblock,label='klv_oo_ix') +!mp +! starts integrals +!FN = 'VVOOI'//ich(3) +!!FN = 'VVOOI'//ich(isp) +!mp !call GET3DM(FN,G(it),NNUAB(3),NNOAB(3),0) +!mp +!mp !call w_alloc(il1,nc*no*maxdim,'IL1 klvaa-v') +!mpn call mma_allocate(l1,nc*no*maxdim,label='klv_oo_il1') +!mp !call w_alloc(itmp,max(nc*no*maxdim,maxdim*maxdim*no*no),'IL2 klvaa-v') +!mpn call mma_allocate(tmp,max(nc*no*maxdim,maxdim*maxdim*no*no),label='klv_oo_itmp') +!mp !call w_alloc(il2,max(nc*no*maxdim,maxdim*maxdim*no*no),'IL2 klvaa-v') +!mpn call mma_allocate(l2,max(nc*no*maxdim,maxdim*maxdim*no*no),label='klv_oo_il2') + +!mp !call gen_vvoo(G(it),G(il1),G(itmp),G(il2)) +!mpn call gen_vvoo(Work(it),l1,tmp,l2) + +!mp !open(unit=36,file='vvoo_moje') +!mp !do i=0,NNUAB(3)*NNOAB(3)-1 +!mp ! if (abs(G(it+i)) < 1.0e-7_wp) G(it+i) = Zero +!mp ! write(36,*) i,G(it+i) +!mp !end do +!mp !close (36) + +!mp !call w_free(G(il1),0,'IL1 klvaa-v') +!mpn call mma_deallocate(l2) +!mpn call mma_deallocate(tmp) +!mpn call mma_deallocate(l1) + +!mp write(u6,*) ddot_(nnoab(3)*nnuab(3),G(it),1,G(it),1) + +!mp +!!call dscal_(NNUAB(3)*NNOAB(3),-One,G(it),1) +!!call dscal_(NNUAB(isp)*NNOAB(ISP),-One,G(it),1) + +! number of blocks written in a single multiwrite + +iasblock = vblock*vblock*nnoab(isp)/nblock +if (iasblock*nblock < vblock*vblock*nnoab(isp)) iasblock = iasblock+1 +!!write(u6,*) 'create_aa vvoo iasblock',iasblock + +!!FN = 'VMAT'//ich(isp)//ich(isp) +!!call multi_opendir(FN,LU) +! currently using 3-dim (big field) - will be replaced after changing +! stepiv and the rest +do nga=1,nug + A1 = (nga-1)*vblock+1 + adim = min(vblock,nuab(isp)-A1+1) + A2 = A1+adim-1 + do ngb=1,nga + if (nga == ngb) then + maxdim2 = nTri_Elem(adim-1) + else + maxdim2 = adim*vblock + end if + B1 = (ngb-1)*vblock+1 + !mpn + !mp write(u6,*) + !mp write(u6,*) '=================================' + !mp write(u6,*) ' nga, ngb',nga,ngb + !mp write(u6,*) '=================================' + !mp write(u6,*) + + !mpn + ! - check the largest b2 + + !mp b2_chk = b1-1+min(vblock,a2-b1) + !mpn b2_chk = b1-1+vblock + b2_chk = b1+min(vblock,nuab(isp)-b1+1)-1 + + ! - find out which T2 blocked files will be needed for particular nga, ngb + + !mp write(u6,'(A,4(i5,2x))') 'a1,a2,b1,b2_chk = ',a1,a2,b1,b2_chk + + call block_interf(a1,a2,b1,b2_chk,ngaf,ngal,nind_ngaf,nind_ngal,ngbf,ngbl,nind_ngbf,nind_ngbl) + + !mp write(u6,'(A,4(i5,2x))') 'ngaf, ngal, nind_ngaf, nind_ngal',ngaf,ngal,nind_ngaf,nind_ngal + !mp write(u6,'(A,4(i5,2x))') 'ngbf, ngbl, nind_ngbf, nind_ngbl',ngbf,ngbl,nind_ngbf,nind_ngbl + + ! - read amplitudes from T2_ngaf_ngbf ... T2_ngaf_ngbl, nga>=ngb + ! .... .... + ! T2ngal_ngbf ... T2_ngal_ngbl, nga>=ngb + + ! - calculate memory requirements (consider squared T2(a',a')) + + length1 = 0 + do i_blk=ngaf,ngal + length1 = length1+DimGrpaR(i_blk) + end do + + length2 = 0 + do j_blk=ngbf,ngbl + length2 = length2+DimGrpaR(j_blk) + end do + + !mp write(u6,*) 'length1, vblock = ',length1,vblock + !mp write(u6,*) 'length2, vblock = ',length2,vblock + + length = length1*length2*no*no + !mp write(u6,*) 'length for blocked VVOO integrals = ',length + + ! - setup memory + + !mp write(u6,*) 'allocating t2_exp = ',length + call mma_allocate(t2_exp,length,label='t2_exp') + + ! - read pertinent files and generate block of vvoo integrals + + call mma_allocate(l1,nc*no*maxdim,label='vvooil1') + call mma_allocate(tmp,max(nc*no*maxdim,maxdim*maxdim*no*no),label='vvooitmp') + call mma_allocate(l2,max(nc*no*maxdim,maxdim*maxdim*no*no),label='vvooil2') + !mp + call gen_vvoo_blocked(t2_exp,l1,tmp,l2,length1,length2,ngaf,ngal,ngbf,ngbl) + !mp + call mma_deallocate(l2) + call mma_deallocate(tmp) + call mma_deallocate(l1) + !mpn + do a=a1,a2 + B2 = B1-1+min(vblock,A-B1) + NSTEP = B2-B1+1 + if (nstep /= 0) then + if (nga == ngb) then + IJS = nTri_Elem(a-a1-1)+1 + else + IJS = (a-a1)*vblock+1 + end if + R = 0 + do I=2,NOAB(ISP) + do J=1,I-1 + !!R = R+1 + !!do R=1,NNOAB(ISP) + !! KADT = (R-1)*NNUAB(ISP) + !mpn R = (J-1)*noab(isp)+I + !mpn KADT = (R-1)*NNUAB(3) + !mpn KADT = KADT+(a-1)*NUAB(ISP)+B1+IT-1 + + a_tmp = a-nind_ngaf + b1_tmp = b1-nind_ngbf + + !mp write(u6,'(A,5(i4,x))') 'a,b1,I,J,nstep ',a,b1,I,J,nstep + !mp write(u6,'(A,5(i4,x))') 'a_tmp,b1_tmp ',a_tmp,b1_tmp + do j_tmp=0,nstep-1 + + KADT = (i-1)*noab(isp)*length1*length2+(j-1)*length1*length2+(b1_tmp+j_tmp-1)*length1+a_tmp + + x2(IJS+j_tmp) = t2_exp(KADT) + + end do + + ! address and block for the A1-A2x B1-B2 + !!KADT = KADT+nTri_Elem(a-2)+B1+IT-1 + ! VO >>> G(IX) + !mpn x2(IJS:IJS+NSTEP-1) = t2_exp(KADT:KADT+NSTEP-1) + !mpn R = (I-1)*noab(isp)+J + !mpn KADT = (R-1)*NNUAB(3) + !mpn KADT = KADT+(a-1)*NUAB(ISP)+B1+IT-1 + do j_tmp=0,nstep-1 + + KADT = (j-1)*noab(isp)*length1*length2+(i-1)*length1*length2+(b1_tmp+j_tmp-1)*length1+a_tmp + + x2(IJS+j_tmp) = x2(IJS+j_tmp)-t2_exp(KADT) + + end do + !mpn + !mpn x2(IJS:IJS+NSTEP-1) = x2(IJS:IJS+NSTEP-1)-t2_exp(KADT:KADT+NSTEP-1) + !!write(u6,'(A,2I3,8D15.8)')'T',nTri_Elem(I-2)+j,a,(G(r),r=IJS,IJS+NSTEP-1) + IJS = IJS+maxdim2 + end do ! RI + end do ! RJ + end if + end do ! a1 + !!write(u6,'(A,4I5,4x,5D15.10)') 'block-m: a1,b1,IAS,ddot',a1,b1,ias,maxdim2,ddot_(nnoab(isp)*maxdim2,G(IX),1,G(IX),1), & + !! (G(I),I=IX,IX+3) + if (maxdim2 == 0) then + maxdim2 = 1 + end if + !mp call multi_wridir(G(IX),nnoab(isp)*maxdim2,LU,IAS,last) + !mp + !mpn do jjj=1,nnoab(isp)*maxdim2 + !mpn if (abs(x2(jjj)) > 1.0e5_wp) then + !mpn write(u6,*) 'fucko 3' + !mpn write(u6,*) jjj,x2(jjj) + !mpn stop + !mpn end if + !mpn end do + !mp + call multi_wridir(x2,nnoab(isp)*maxdim2,LU,IAS,last) + ias = ias+iasblock + + !mp write(u6,*) 'deallocating t2_exp = ',length + call mma_deallocate(t2_exp) + + end do ! ngb +end do ! nga +!mp write(u6,*) 'cast 2 ok' +!mp call w_memchk('all klvaa ') +!mp call w_free(g(ix),0,'klvaa ') +!mp +call mma_deallocate(x2) +!mp +!!call w_free(g(it),0,'klvaa ') +!mp call w_alloc(ix,nnoab(3)*vblock*vblock,'ix-vvoo') +!mp +call mma_allocate(x2,nnoab(3)*vblock*vblock,label='klv_oo_ix') +!mp +!!call w_alloc(ig,nnoab(3)*nnuab(3),'ig-vvoo') +!mpn ig = it +! from now on as for uhf +iasblock = nnoab(3)*vblock*vblock/nblock +if (iasblock*nblock < nnoab(3)*vblock**2) iasblock = iasblock+1 +!!FN = 'VVOOI'//ICH(3) +!!CALL GET3DM(FN,G(IG),NNUAB(3),NNOAB(3),0) +! (c>d|AK) + +!mpn +nga = 0 +!mpn +do A1=1,NUAB(ISP),vblock + A2 = A1+min(vblock,nuab(isp)-A1+1)-1 + adim = A2-A1+1 + !mpn + nga = nga+1 + ngb = 0 + !mpn + do B1=1,NUAB(IS2),vblock + !mpn + ngb = ngb+1 + !mpn + NSTEP = min(vblock,nuab(is2)-B1+1) + !mpn + !mpn + !mp write(u6,*) + !mp write(u6,*) '=================================' + !mp write(u6,*) ' nga, ngb',nga,ngb + !mp write(u6,*) '=================================' + !mp write(u6,*) + + ! - check the largest b2 + + !mp b2_chk = b1-1+min(vblock,nuab(is2)-B1+1) + !mpn b2_chk = b1-1+vblock + b2_chk = b1+min(vblock,nuab(is2)-B1+1)-1 + + ! - find out which T2 blocked files will be needed for particular nga, ngb + + !mp write(u6,'(A,4(i5,2x))') 'a1,a2,b1,b2_chk = ',a1,a2,b1,b2_chk + + if (nga < ngb) then + !mp write(u6,*) 'switching nga, ngb',ngb,nga + + call block_interf(b1,b2_chk,a1,a2,ngaf,ngal,nind_ngaf,nind_ngal,ngbf,ngbl,nind_ngbf,nind_ngbl) + + else + + call block_interf(a1,a2,b1,b2_chk,ngaf,ngal,nind_ngaf,nind_ngal,ngbf,ngbl,nind_ngbf,nind_ngbl) + + end if + + !mp write(u6,'(A,4(i5,2x))') 'ngaf, ngal, nind_ngaf, nind_ngal',ngaf,ngal,nind_ngaf,nind_ngal + !mp write(u6,'(A,4(i5,2x))') 'ngbf, ngbl, nind_ngbf, nind_ngbl',ngbf,ngbl,nind_ngbf,nind_ngbl + + ! - read amplitudes from T2_ngaf_ngbf ... T2_ngaf_ngbl, nga>=ngb + ! .... .... + ! T2ngal_ngbf ... T2_ngal_ngbl, nga>=ngb + + ! - calculate memory requirements (consider squared T2(a',a')) + + length1 = 0 + do i_blk=ngaf,ngal + length1 = length1+DimGrpaR(i_blk) + end do + + length2 = 0 + do j_blk=ngbf,ngbl + length2 = length2+DimGrpaR(j_blk) + end do + + !mp write(u6,*) 'length1, vblock = ',length1,vblock + !mp write(u6,*) 'length2, vblock = ',length2,vblock + + length = length1*length2*no*no + !mp write(u6,*) 'length for blocked VVOO integrals = ',length + + ! - setup memory + + !mp write(u6,*) 'allocating t2_exp = ',length + call mma_allocate(t2_exp,length,label='t2_exp') + + ! - read pertinent files and generate block of vvoo integrals + + call mma_allocate(l1,nc*no*maxdim,label='vvooil1') + call mma_allocate(tmp,max(nc*no*maxdim,maxdim*maxdim*no*no),label='tmp') + call mma_allocate(l2,max(nc*no*maxdim,maxdim*maxdim*no*no),label='vvooil2') + !mp + call gen_vvoo_blocked(t2_exp,l1,tmp,l2,length1,length2,ngaf,ngal,ngbf,ngbl) + !mp + call mma_deallocate(l2) + call mma_deallocate(tmp) + call mma_deallocate(l1) + !mpn + !!bdim = NSTEP + ! mv T2(B,A,I,K) >> G(ix) + KI = 0 + do K=1,noab(isp) + KADT = (K-1)*NNUAB(3)*(NOAB(2)*(2-ISP)+ISP-1) + do I=1,NOAB(IS2) + KI = KI+1 + !mpn IADT = (I-1)*NNUAB(3)*(NOAB(2)*(2-IS2)+IS2-1) + !mpn BADT = (2-ISP)*B1+(ISP-1)*(B1-1)*NUAB(2) + do A=A1,A2 + !mpn + if (nga < ngb) then + a_tmp = a-nind_ngbf + b1_tmp = b1-nind_ngaf + else + a_tmp = a-nind_ngaf + b1_tmp = b1-nind_ngbf + end if + !mpn + !mpn AADT = IADT+KADT+BADT+A*(ISP-1)+(2-ISP)*(A-1)*NUAB(2)+IG-1 + ! T2 for isp=1 T2 for isp=2 + + RAD = (KI-1)*adim*nstep+(A-A1)*nstep+1 + !mpn ISTEP = (ISP-1)*NUAB(2)+2-ISP + !mpn + if (nga >= ngb) then ! nga> ngb + + !mp write(u6,'(A,4(i5,2x),3x,i5)') '(I) a_tmp,b1_tmp,k,i nstep = ',a_tmp,b1_tmp,k,i,nstep + ! T2(B1,A,I,K) =? T2(A,B1,K,I) + do j_tmp=0,NSTEP-1 ! istep je 1 ak dobre tusim + + AADT = (I-1)*length1*length2*NOAB(2)+(K-1)*length1*length2+(b1_tmp-1+j_tmp)*length1+a_tmp + + x2(RAD+j_tmp) = t2_exp(AADT) + + end do + + else ! nga < ngb + + !mp write(u6,'(A,4(i5,2x),3x,i5)') '(II) b1_tmp,a_tmp,k,i nstep = ',b1_tmp,a_tmp,i,k,nstep + ! T2(B1,A,I,K) + do j_tmp=0,NSTEP-1 ! istep je 1 ak dobre tusim + + AADT = (k-1)*length1*length2*NOAB(2)+(i-1)*length1*length2+(a_tmp-1)*length1+b1_tmp+j_tmp + + x2(RAD+j_tmp) = t2_exp(AADT) + + end do + end if + !mpn + !mpn x2(RAD:RAD+NSTEP-1) = t2_exp(AADT:AADT+NSTEP-1) + + end do ! A + end do ! I + end do ! K + !!write(u6,'(A,3I5,4x,5D15.10)') 'block-v: a1,b1,IAS,ddot',a1/vblock+1,b1/vblock+1,ias, & + !! ddot_(NNOAB(3)*adim*nstep,G(IX),1,G(IX),1),(G(I),I=IX,IX+3) + !mp call multi_wridir(G(IX),NNOAB(3)*adim*nstep,LU,IAS,last) + !mp + !mpn do jjj=1,NNOAB(3)*adim*nstep + !mpn if (abs(x2(jjj)) > 1.0e5_wp) then + !mpn write(u6,*) 'fucko 1' + !mpn write(u6,*) jjj,x2(jjj) + !mpn stop + !mpn end if + !mpn end do + !mp + call multi_wridir(x2,NNOAB(3)*adim*nstep,LU,IAS,last) + ias = ias+iasblock + !mpn + call mma_deallocate(t2_exp) + !mpn + end do ! B1 +end do ! A1 +!mp write(u6,*) 'cast 3 ok' +!!close(LU) in calling routine +!write(u6,*) FN,isp,IAS +!!dupblk(ndup) = last in calling routine +!mp call w_memchk('all klvaa ') +!!call w_free(g(ix),0,'IT klvaa ') in calling routine +!mp +call mma_deallocate(x2) +!mp +!mpn +if (printkey > 1) write(u6,*) 'VVOO integrals regenerated from MOLCAS' + +!mpn +call xflush(u6) +!!stop + +return + +end subroutine klvaa_oovo + +#endif diff -Nru openmolcas-22.02/src/cht3/klvaa_vvv.f openmolcas-22.10/src/cht3/klvaa_vvv.f --- openmolcas-22.02/src/cht3/klvaa_vvv.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/klvaa_vvv.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,310 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE klvaa_vvv(ix,ig,iscr,vblock,N,nug,lu,last, - $iasblock,K,ias) -cmp SUBROUTINE klvaa_vvv(G,ix,it,ig,iscr,vblock,N,nug,lu,last, -cmpn SUBROUTINE klvaa_vvv(ix,it,ig,iscr,vblock,N,nug,lu,last, -C -C creates K(alpha>alpha,alpha-alpha) or K(beta>beta,beta,beta) -C DA files KMATICH(ISP)ICH(ISP) ISP=A -C generates antisymmetrized integrals from abab (T2) or bbaa (vvvo) -C ix, it, ig iscr allocated in create_klvab_t3 -C K,ias defined in create_klvab_t3.f -C -C parallelization (seems to be) irrelevant at the moment -C implemented integer offsets, PV, 14 may 2004. -C - IMPLICIT NONE -cmp -#include "WrkSpc.fh" -cmp -#include "ndisk.fh" -#include "dupfiles.fh" -cmp real*8 G(*),ddot -cmpn -#include "cht3_ccsd1.fh" -#include "cht3_reord.fh" -#include "ccsd_t3compat.fh" - integer i_blk,j_blk,b2_chk - integer ngaf,ngal,ngbf,ngbl - integer nind_ngbf,nind_ngbl,nind_ngaf,nind_ngal - integer length,length1,length2 - integer it_exp,itmp,it2_tmp - integer a_tmp,b1_tmp,j_tmp -cmp -c integer jjj - logical switch -cmp -cmpn -c real*8 ddot_ -cmpn integer it,ix,ig,iscr, KADT, IJS, RAD, AADT - integer ix,ig,iscr, KADT, IJS, AADT - integer isp,ias,vblock,n,i,j,k,lu,iasblock,indab - INTEGER A,A1,A2,B1,B2,NSTEP,ADIM,NUG,NGA,NGB,R,MAXDIMM,B - INTEGER KI, last -c CHARACTER FN*6 - INTEGER NNU -#include "uhf.fh" -#include "ioind.fh" - indab(i,j)=(max(i,j)-1)*max(i,j)/2+min(i,j) -C - ISP=1 ! - nug=nuab(isp)/vblock - if((vblock*nug).ne.nuab(isp))nug=nug+1 - NNU=NUAB(1)*(NUAB(1)+1)/2 - if (printkey.ge.11) then - write(6,'(A,10I5)')'entering klvaa_vvv', - & vblock,N,nug,lu,last,iasblock,K,ias -cmpn write(6,*)ddot_(nnoab(3)*nnuab(3),Work(it),1,Work(it),1) -cmp write(6,*)ddot_(nnoab(3)*nnuab(3),G(it),1,G(it),1) - endif - !!DO K=1,noab(isp) - !!FN(1:5)='VVVOI' - !!FN(6:6)=ICH(ISP) - !!CALL GET3DM(FN,G(ig),NNUAB(isp),NUAB(ISP),K) - !!call delf(FN,K,K) all done in create_klvab_t3.f - do nga=1,nug - A1=(nga-1)*vblock+1 - adim=min(vblock,nuab(isp)-A1+1) - A2=A1+adim-1 - do ngb=1,nga - if(nga.eq.ngb)then - maxdimm=adim*(adim-1)/2 - else - maxdimm=adim*vblock - endif - call zeroma(Work(IX),1,N*maxdimm) -cmp call zeroma(G(IX),1,N*maxdim) - B1=(ngb-1)*vblock+1 - -cmp! write (6,*) -cmp! write (6,*) '=================================' -cmp! write (6,*) 'nga, ngb',nga,ngb -cmp! write (6,*) '=================================' -cmp! write (6,*) -c` -cmpn -c - check the largest b2 -c -cmp b2_chk=b1-1+min(vblock,a2-b1) -cmpn b2_chk=b1-1+vblock - b2_chk=b1+min(vblock,nuab(isp)-b1+1)-1 -c -c - find out which T2 blocked files will be needed -c for particular nga, ngb -c -cmp! write (6,'(A,4(i5,2x))') 'a1,a2,b1,b2_chk = ',a1,a2,b1,b2_chk -c - call block_interf(a1,a2,b1,b2_chk, - & ngaf,ngal,nind_ngaf,nind_ngal, - & ngbf,ngbl,nind_ngbf,nind_ngbl) -c -cmp! write (6,'(A,4(i5,2x))') 'ngaf, ngal, nind_ngaf, nind_ngal', -cmp! & ngaf,ngal,nind_ngaf,nind_ngal -cmp! write (6,'(A,4(i5,2x))') 'ngbf, ngbl, nind_ngbf, nind_ngbl', -cmp! & ngbf,ngbl,nind_ngbf,nind_ngbl -cmp! write (6,*) 'maxdim = ',maxdim -c -c - read amplitudes from T2_ngaf_ngbf ... T2_ngaf_ngbl, nga>=ngb -c .... .... -c T2ngal_ngbf ... T2_ngal_ngbl, nga>=ngb -c -c - calculate memory requirements (consider squared T2(a',a')) -c - length1=0 - do i_blk=ngaf,ngal - length1=length1+DimGrpaR(i_blk) - end do -c - length2=0 - do j_blk=ngbf,ngbl - length2=length2+DimGrpaR(j_blk) - end do -c -cmp! write (6,*) 'length1, vblock = ',length1,vblock -cmp! write (6,*) 'length2, vblock = ',length2,vblock -c - length=length1*length2*no*no -cmp! write (6,*) 'length for blocked T2 amplitudes = ',length -c -c - setup memory -c -cmp! write (6,*) 'allocating t2_exp = ',length - call GetMem('it1_exp','Allo','Real',it_exp,length) -c -c - read pertinent files and store them in the new blocked structure -c - call GetMem('c1_it2tmp','Allo','Real',it2_tmp, - & maxdim*maxdim*no*no) - call GetMem('c1_itmp','Allo','Real',itmp, - & maxdim*maxdim*no*no) -c - switch=.false. - call gather_t2_blocked(length1,length2, - & ngaf,ngal,ngbf,ngbl, - & Work(it_exp),Work(it2_tmp),Work(itmp), - & switch) -c - call GetMem('c1_itmp','Free','Real',itmp, - & maxdim*maxdim*no*no) - call GetMem('c1_it2tmp','Free','Real',it2_tmp, - & maxdim*maxdim*no*no) - - call dscal_(length,-1.0d0,Work(it_exp),1) -c -cmp - do a=a1,a2 - B2=B1-1+min(vblock,A-B1) - NSTEP=B2-B1+1 -cmp! write (6,*) 'NSTEP = ',NSTEP - if(nstep.ne.0)then - if(nga.eq.ngb)then - IJS=(a-a1-1)*(a-a1)/2+IX -!! IJS=(a-a1-2+1)*(a-a1-1+1)/2+1 - else - IJS=(a-a1)*vblock+IX - endif - do R=1,K-1 -C copies (b1..b2,a,r,k)-(b1..b2,a,k,r) - !!KADT=(K-2)*(K-1)/2+R - !!KADT=(KADT-1)*NNUAB(ISP) -C address and block for the A1-A2x B1-B2 - !!KADT=KADT+(a-1)*(a-2)/2 +B1 +IT -1 -C T2 >>> K - !!call dcopy_(NSTEP,G(KADT),1,G(IJS),1) -cmpn KADT=(k-1)*noab(1)*NNUAB(3)+(r-1)*NNUAB(3)+(a-1)*nuab(1)+B1+IT-1 -cmpn AADT=(r-1)*noab(1)*NNUAB(3)+(k-1)*NNUAB(3)+(a-1)*nuab(1)+B1+IT-1 -c - a_tmp=a-nind_ngaf - b1_tmp=b1-nind_ngbf -cmp! write (6,'(A,4(i5,2x))') 'b1, a ,r,k = ',b1,a,r,k -cmp! write (6,'(A,4(i5,2x))') 'a_tmp,b1_tmp,k,r = ',a_tmp,b1_tmp,k,r -c - do j_tmp=0,NSTEP-1 -c - KADT=(r-1)*noab(1)*length1*length2+(k-1)*length1*length2+ - & (b1_tmp+j_tmp-1)*length1+a_tmp+it_exp-1 -c - AADT=(k-1)*noab(1)*length1*length2+(r-1)*length1*length2+ - & (b1_tmp+j_tmp-1)*length1+a_tmp+it_exp-1 -c - Work(IJS+j_tmp)=Work(AADT)-Work(KADT) -cmp! write (6,'(A,2(i5,2x),3(f18.10,2x))') 'XXXN = ',a_tmp,b1_tmp+j_tmp-1, -cmp! & Work(IJS+j_tmp),Work(AADT),Work(KADT) -c - end do -c -cmp call vsub(G(KADT),1,G(AADT),1,G(IJS),1,NSTEP) -cmpn call vsub(Work(KADT),1,Work(AADT),1,Work(IJS),1,NSTEP) - !!write(6,'(A,3I3,8D15.8)')'T',K,R,a,(G(I),I=IJS,IJS+NSTEP-1) - IJS=IJS+maxdimm - enddo ! R -cmp call zeroma(G(IJS),1,NSTEP) - call zeroma(Work(IJS),1,NSTEP) - IJS=IJS+maxdimm -C T2 >>> K (transposed) -C copies (b1..b2,a,r,k)-(b1..b2,a,k,r) -cmpn -c -c (b1..b2,a,r,k) =? (a,b1...b2,k,r) -c (b1..b2,a,k,r) =? (a,b1...b2,r,k) -c -cmpn - do R=K+1,NOAB(ISP) - !!KADT=(R-2)*(R-1)/2+K - !!KADT=(KADT-1)*NNUAB(ISP) - !!KADT=KADT+(a-1)*(a-2)/2 +B1 +IT -1 - !!call vneg_cht3(G(KADT),1,G(IJS),1,NSTEP) - -cmpn KADT=(k-1)*noab(1)*NNUAB(3)+(r-1)*nnUab(3)+(a-1)*nuab(1)+B1+IT-1 -cmpn AADT=(r-1)*noab(1)*NNUAB(3)+(k-1)*nnUab(3)+(a-1)*nuab(1)+B1+IT-1 -c - a_tmp=a-nind_ngaf - b1_tmp=b1-nind_ngbf -cmp! write (6,'(A,4(i5,2x))') 'b1, a ,r,k = ',b1,a,r,k -cmp! write (6,'(A,4(i5,2x))') 'a_tmp,b1_tmp,k,r = ',a_tmp,b1_tmp,k,r -c - do j_tmp=0,NSTEP-1 -c - KADT=(r-1)*noab(1)*length1*length2+(k-1)*length1*length2+ - & (b1_tmp+j_tmp-1)*length1+a_tmp+it_exp-1 -c - AADT=(k-1)*noab(1)*length1*length2+(r-1)*length1*length2+ - & (b1_tmp+j_tmp-1)*length1+a_tmp+it_exp-1 -c - Work(IJS+j_tmp)=Work(AADT)-Work(KADT) -cmp write (6,'(A,2(i5,2x),3(f18.10,2x))') 'XXXN = ',a_tmp,b1_tmp+j_tmp-1, -cmp & Work(IJS+j_tmp),Work(AADT),Work(KADT) -c - end do -c -cmp call vsub(G(KADT),1,G(AADT),1,G(IJS),1,NSTEP) -cmpn call vsub(Work(KADT),1,Work(AADT),1,Work(IJS),1,NSTEP) - !!write(6,'(A,3I3,8D15.8)')'T',K,R,a,(G(I),I=IJS,IJS+NSTEP-1) -!! call daxpy_(NSTEP,-1.d0,G(KADT),1,G(IJS),1) - IJS=IJS+maxdimm - ENDDO ! R -C >>> K original for aaaa -C (VV|VO( >>> K now aabb needed (AR|BK)-(BR|AK) - - !!CALL EXPA1_UHF(G(IJS),1,NUAB(IS2),1,G(ISCR)) - !!KADT=IG-1+(a-1)*(a-2)/2 +B1 - KADT=IG-1+(B1-1)*NNU - AADT=IG-1+(A-1)*NNU - DO R=1,NUAB(ISP) - !!call dcopy_(NSTEP,G(KADT),1,G(IJS),1) -C first (AR|BK) -cmp call dcopy_(NSTEP,G(KADT+indab(a,r)),NNU,G(IJS),1) - call dcopy_(NSTEP,Work(KADT+indab(a,r)),NNU,Work(IJS),1) -C now -(BR|AK) - KI=IJS - do B=B1,B2 -cmp G(KI)=G(KI)-G(AADT+indab(B,R)) - Work(KI)=Work(KI)-Work(AADT+indab(B,R)) - KI=KI+1 - ENDDO - !!write(6,'(A,3I3,8D15.8)')'V',K,R,a,(G(I),I=IJS,IJS+NSTEP-1) - IJS=IJS+maxdimm - !!KADT=KADT+NNUAB(ISP) - enddo !R - endif ! nstep eq.0 - enddo !A -C >>> K -cmp! write(6,'(A,5I5,4x,5D15.10)') -cmp! $'block-w: K,a1,b1,IAS,ddot',K,a1,b1,ias,maxdim, -cmp! $ ddot_(N*maxdim,Work(IX),1,Work(IX),1),(Work(I),I=IX,IX+3) -cmp $ ddot_(N*maxdim,G(IX),1,G(IX),1),(G(I),I=IX,IX+3) -cmp call multi_wridir(G(IX),N*maxdim,LU,IAS, last) -cmp -cmp!! do jjj=0,N*maxdimm-1 -cmp!! if (abs(Work(ix+jjj)).gt.10000) then -cmp!! write (6,*) 'prasa 3 ',jjj,Work(ix+jjj) -cmp!! stop -cmp!! end if -cmp!! end do -cmp - call multi_wridir(Work(IX),N*maxdimm,LU,IAS, last) - ias=ias+iasblock -cmpn -cmp write (6,*) 'deallocating t2_exp = ',length - call GetMem('it1_exp','Free','Real',it_exp,length) -cmpn - enddo ! ngb - enddo ! nga - !!enddo ! K -cmp! write(6,'(A,10I5)')'leaving klvaa_vvv', -cmp! $vblock,N,nug,lu,last,iasblock,K,ias - call xflush(6) - !!stop - return -c Avoid unused argument warnings - if (.false.) call Unused_integer(iscr) - end diff -Nru openmolcas-22.02/src/cht3/klvaa_vvv.F90 openmolcas-22.10/src/cht3/klvaa_vvv.F90 --- openmolcas-22.02/src/cht3/klvaa_vvv.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/klvaa_vvv.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,274 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine klvaa_vvv(x,g,vblock,N,nug,lu,last,iasblock,K,ias) +!mp subroutine klvaa_vvv(G,ix,it,ig,iscr,vblock,N,nug,lu,last,iasblock,K,ias) +!mpn subroutine klvaa_vvv(ix,it,ig,iscr,vblock,N,nug,lu,last,iasblock,K,ias) +! +! creates K(alpha>alpha,alpha-alpha) or K(beta>beta,beta,beta) +! DA files KMATICH(ISP)ICH(ISP) ISP=A +! generates antisymmetrized integrals from abab (T2) or bbaa (vvvo) +! x, g allocated in create_klvab_t3 +! K, ias defined in create_klvab_t3.f +! +! parallelization (seems to be) irrelevant at the moment +! implemented integer offsets, PV, 14 may 2004. + +use ChT3_global, only: DimGrpaR, maxdim, no, NOAB, NUAB, printkey +use Index_Functions, only: iTri, nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +real(kind=wp), intent(_OUT_) :: x(*) +real(kind=wp), intent(in) :: g(*) +integer(kind=iwp), intent(in) :: vblock, N, lu, iasblock, K +integer(kind=iwp), intent(out) :: nug +integer(kind=iwp), intent(inout) :: last, ias +integer(kind=iwp) :: A, A1, A2, a_tmp, AADT, ADIM, B, B1, b1_tmp, B2, b2_chk, i_blk, IJS, isp, j_blk, j_tmp, KADT, KI, length, & + length1, length2, MAXDIMM, NGA, ngaf, ngal, NGB, ngbf, ngbl, nind_ngaf, nind_ngal, nind_ngbf, nind_ngbl, NNU, & + NSTEP, R +real(kind=wp), allocatable :: t2_exp(:), t2_tmp(:), tmp(:) + +ISP = 1 +nug = nuab(isp)/vblock +if ((vblock*nug) /= nuab(isp)) nug = nug+1 +NNU = nTri_Elem(NUAB(1)) +if (printkey >= 11) then + write(u6,'(A,10I5)') 'entering klvaa_vvv',vblock,N,nug,lu,last,iasblock,K,ias + !mpn write(u6,*) ddot_(nnoab(3)*nnuab(3),Work(it),1,Work(it),1) + !mp write(u6,*) ddot_(nnoab(3)*nnuab(3),G(it),1,G(it),1) +end if +!!do K=1,noab(isp) +!! FN = 'VVVOI'//ICH(ISP) +!! call GET3DM(FN,G(ig),NNUAB(isp),NUAB(ISP),K) +!! call delf(FN,K,K) ! all done in create_klvab_t3.f +do nga=1,nug + A1 = (nga-1)*vblock+1 + adim = min(vblock,nuab(isp)-A1+1) + A2 = A1+adim-1 + do ngb=1,nga + if (nga == ngb) then + maxdimm = nTri_Elem(adim-1) + else + maxdimm = adim*vblock + end if + x(1:N*maxdimm) = Zero + !mp call zeroma(G(IX),1,N*maxdim) + B1 = (ngb-1)*vblock+1 + + !mp !write(u6,*) + !mp !write(u6,*) '=================================' + !mp !write(u6,*) 'nga, ngb',nga,ngb + !mp !write(u6,*) '=================================' + !mp !write(u6,*) + + !mpn + ! - check the largest b2 + + !mp b2_chk = b1-1+min(vblock,a2-b1) + !mpn b2_chk = b1-1+vblock + b2_chk = b1+min(vblock,nuab(isp)-b1+1)-1 + + ! - find out which T2 blocked files will be needed + ! for particular nga, ngb + + !mp !write(u6,'(A,4(i5,2x))') 'a1,a2,b1,b2_chk = ',a1,a2,b1,b2_chk + + call block_interf(a1,a2,b1,b2_chk,ngaf,ngal,nind_ngaf,nind_ngal,ngbf,ngbl,nind_ngbf,nind_ngbl) + + !mp !write(u6,'(A,4(i5,2x))') 'ngaf, ngal, nind_ngaf, nind_ngal',ngaf,ngal,nind_ngaf,nind_ngal + !mp !write(u6,'(A,4(i5,2x))') 'ngbf, ngbl, nind_ngbf, nind_ngbl',ngbf,ngbl,nind_ngbf,nind_ngbl + !mp !write(u6,*) 'maxdim = ',maxdim + + ! - read amplitudes from T2_ngaf_ngbf ... T2_ngaf_ngbl, nga>=ngb + ! .... .... + ! T2ngal_ngbf ... T2_ngal_ngbl, nga>=ngb + + ! - calculate memory requirements (consider squared T2(a',a')) + + length1 = 0 + do i_blk=ngaf,ngal + length1 = length1+DimGrpaR(i_blk) + end do + + length2 = 0 + do j_blk=ngbf,ngbl + length2 = length2+DimGrpaR(j_blk) + end do + + !mp !write(u6,*) 'length1, vblock = ',length1,vblock + !mp !write(u6,*) 'length2, vblock = ',length2,vblock + + length = length1*length2*no*no + !mp !write(u6,*) 'length for blocked T2 amplitudes = ',length + + ! - setup memory + + !mp !write(u6,*) 'allocating t2_exp = ',length + call mma_allocate(t2_exp,length,label='t2_exp') + + ! - read pertinent files and store them in the new blocked structure + + call mma_allocate(t2_tmp,maxdim*maxdim*no*no,label='t2_tmp') + call mma_allocate(tmp,maxdim*maxdim*no*no,label='tmp') + + !switch = .false. + call gather_t2_blocked(length1,length2,ngaf,ngal,ngbf,ngbl,t2_exp,t2_tmp,tmp) + + call mma_deallocate(tmp) + call mma_deallocate(t2_tmp) + + t2_exp(:) = -t2_exp + + !mp + do a=a1,a2 + B2 = B1-1+min(vblock,A-B1) + NSTEP = B2-B1+1 + !mp !write(u6,*) 'NSTEP = ',NSTEP + if (nstep /= 0) then + if (nga == ngb) then + IJS = nTri_Elem(a-a1-1)+1 + !!IJS = nTri_Elem(a-a1-1)+1 + else + IJS = (a-a1)*vblock+1 + end if + do R=1,K-1 + ! copies (b1..b2,a,r,k)-(b1..b2,a,k,r) + !!KADT = nTri_Elem(K-2)+R + !!KADT = (KADT-1)*NNUAB(ISP) + ! address and block for the A1-A2x B1-B2 + !!KADT = KADT+nTri_Elem(a-2)+B1+IT-1 + ! T2 >>> K + !!call dcopy_(NSTEP,G(KADT),1,G(IJS),1) + !mpn KADT = (k-1)*noab(1)*NNUAB(3)+(r-1)*NNUAB(3)+(a-1)*nuab(1)+B1+IT-1 + !mpn AADT = (r-1)*noab(1)*NNUAB(3)+(k-1)*NNUAB(3)+(a-1)*nuab(1)+B1+IT-1 + + a_tmp = a-nind_ngaf + b1_tmp = b1-nind_ngbf + !mp !write(u6,'(A,4(i5,2x))') 'b1, a ,r,k = ',b1,a,r,k + !mp !write(u6,'(A,4(i5,2x))') 'a_tmp,b1_tmp,k,r = ',a_tmp,b1_tmp,k,r + + do j_tmp=0,NSTEP-1 + + KADT = (r-1)*noab(1)*length1*length2+(k-1)*length1*length2+(b1_tmp+j_tmp-1)*length1+a_tmp + + AADT = (k-1)*noab(1)*length1*length2+(r-1)*length1*length2+(b1_tmp+j_tmp-1)*length1+a_tmp + + x(IJS+j_tmp) = t2_exp(AADT)-t2_exp(KADT) + !mp !write(u6,'(A,2(i5,2x),3(f18.10,2x))') 'XXXN = ',a_tmp,b1_tmp+j_tmp-1,x(IJS+j_tmp),t2_exp(AADT),t2_exp(KADT) + + end do + + !mp call vsub(G(KADT),1,G(AADT),1,G(IJS),1,NSTEP) + !mpn x(IJS:IJS+NSTEP-1) = t2_exp(AADT:AADT+NSTEP-1)-t2_exp(KADT:KADT+NSTEP-1) + !!write(u6,'(A,3I3,8D15.8)') 'T',K,R,a,(G(I),I=IJS,IJS+NSTEP-1) + IJS = IJS+maxdimm + end do ! R + !mp call zeroma(G(IJS),1,NSTEP) + x(IJS:IJS+NSTEP-1) = Zero + IJS = IJS+maxdimm + ! T2 >>> K (transposed) + ! copies (b1..b2,a,r,k)-(b1..b2,a,k,r) + !mpn + + ! (b1..b2,a,r,k) =? (a,b1...b2,k,r) + ! (b1..b2,a,k,r) =? (a,b1...b2,r,k) + + !mpn + do R=K+1,NOAB(ISP) + !!KADT = nTri_Elem(R-2)+K + !!KADT = (KADT-1)*NNUAB(ISP) + !!KADT = KADT+nTri_Elem(a-2)+B1+IT-1 + !!call vneg_cht3(G(KADT),1,G(IJS),1,NSTEP) + + !mpn KADT = (k-1)*noab(1)*NNUAB(3)+(r-1)*nnUab(3)+(a-1)*nuab(1)+B1+IT-1 + !mpn AADT = (r-1)*noab(1)*NNUAB(3)+(k-1)*nnUab(3)+(a-1)*nuab(1)+B1+IT-1 + + a_tmp = a-nind_ngaf + b1_tmp = b1-nind_ngbf + !mp !write(u6,'(A,4(i5,2x))') 'b1, a ,r,k = ',b1,a,r,k + !mp !write(u6,'(A,4(i5,2x))') 'a_tmp,b1_tmp,k,r = ',a_tmp,b1_tmp,k,r + + do j_tmp=0,NSTEP-1 + + KADT = (r-1)*noab(1)*length1*length2+(k-1)*length1*length2+(b1_tmp+j_tmp-1)*length1+a_tmp + + AADT = (k-1)*noab(1)*length1*length2+(r-1)*length1*length2+(b1_tmp+j_tmp-1)*length1+a_tmp + + x(IJS+j_tmp) = t2_exp(AADT)-t2_exp(KADT) + !mp write(u6,'(A,2(i5,2x),3(f18.10,2x))') 'XXXN = ',a_tmp,b1_tmp+j_tmp-1,x(IJS+j_tmp),t2_exp(AADT),t2_exp(KADT) + + end do + + !mp call vsub(G(KADT),1,G(AADT),1,G(IJS),1,NSTEP) + !mpn x(IJS:IJS+NSTEP-1) = t2_exp(AADT:AADT+NSTEP-1)-t2_exp(KADT:KADT+NSTEP-1) + !!write(u6,'(A,3I3,8D15.8)') 'T',K,R,a,(G(I),I=IJS,IJS+NSTEP-1) + !!call daxpy_(NSTEP,-One,G(KADT),1,G(IJS),1) + IJS = IJS+maxdimm + end do ! R + ! >>> K original for aaaa + ! (VV|VO( >>> K now aabb needed (AR|BK)-(BR|AK) + + !!call EXPA1_UHF(G(IJS),1,NUAB(IS2),1,G(ISCR)) + !!KADT = IG-1+nTri_Elem(a-2)+B1 + KADT = (B1-1)*NNU + AADT = (A-1)*NNU + do R=1,NUAB(ISP) + !!call dcopy_(NSTEP,G(KADT),1,G(IJS),1) + ! first (AR|BK) + !mp call dcopy_(NSTEP,G(KADT+iTri(a,r)),NNU,G(IJS),1) + call dcopy_(NSTEP,g(KADT+iTri(a,r)),NNU,x(IJS),1) + ! now -(BR|AK) + KI = IJS + do B=B1,B2 + !mp G(KI) = G(KI)-G(AADT+iTri(B,R)) + x(KI) = x(KI)-g(AADT+iTri(B,R)) + KI = KI+1 + end do + !!write(u6,'(A,3I3,8D15.8)') 'V',K,R,a,(G(I),I=IJS,IJS+NSTEP-1) + IJS = IJS+maxdimm + !!KADT = KADT+NNUAB(ISP) + end do !R + end if ! nstep == 0 + end do !A + ! >>> K + !mp !write(u6,'(A,5I5,4x,5D15.10)') 'block-w: K,a1,b1,IAS,ddot',K,a1,b1,ias,maxdim,ddot_(N*maxdim,x,1,x,1),x(1:4) + !mp !write(u6,'(A,5I5,4x,5D15.10)') 'block-w: K,a1,b1,IAS,ddot',K,a1,b1,ias,maxdim,ddot_(N*maxdim,G(IX),1,G(IX),1), & + ! (G(I),I=IX,IX+3) + !mp call multi_wridir(G(IX),N*maxdim,LU,IAS, last) + !mp + !mp !!do jjj=1,N*maxdimm + !mp !! if (abs(x(jjj)) > 1.0e5_wp) then + !mp !! write(u6,*) 'prasa 3 ',jjj,x(jjj) + !mp !! stop + !mp !! end if + !mp !!end do + !mp + call multi_wridir(x,N*maxdimm,LU,IAS,last) + ias = ias+iasblock + !mpn + !mp write(u6,*) 'deallocating t2_exp = ',length + call mma_deallocate(t2_exp) + !mpn + end do ! ngb +end do ! nga +!!end do ! K +!mp !write(u6,'(A,10I5)') 'leaving klvaa_vvv',vblock,N,nug,lu,last,iasblock,K,ias +call xflush(u6) +!!stop + +return + +end subroutine klvaa_vvv diff -Nru openmolcas-22.02/src/cht3/main.f openmolcas-22.10/src/cht3/main.f --- openmolcas-22.02/src/cht3/main.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/main.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - program main -#ifdef _FPE_TRAP_ - Use, Intrinsic :: IEEE_Exceptions -#endif - implicit real*8 (a-h,o-z) -#ifdef _FPE_TRAP_ - Call IEEE_Set_Halting_Mode(IEEE_Usual,.True._4) -#endif - - Call Start('cht3') - Call cht3(ireturn) - Call Finish(ireturn) - end diff -Nru openmolcas-22.02/src/cht3/main.F90 openmolcas-22.10/src/cht3/main.F90 --- openmolcas-22.02/src/cht3/main.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/main.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,31 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +program Main + +#ifdef _FPE_TRAP_ +use, intrinsic :: IEEE_Exceptions, only: IEEE_Set_Halting_Mode, IEEE_Usual +use Definitions, only: DefInt +#endif +use Definitions, only: iwp + +implicit none +integer(kind=iwp) :: rc + +#ifdef _FPE_TRAP_ +call IEEE_Set_Halting_Mode(IEEE_Usual,.true._DefInt) +#endif + +call Start('cht3') +call cht3(rc) +call Finish(rc) + +end program Main diff -Nru openmolcas-22.02/src/cht3/map2_21_t3.f openmolcas-22.10/src/cht3/map2_21_t3.f --- openmolcas-22.02/src/cht3/map2_21_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/map2_21_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine Map2_21_t3 (A,B,d1,d2) -c -c this routine do: -c map B(21) <- A(12) -c - implicit none - integer d1,d2 - real*8 A(1:d1,1:d2) - real*8 B(1:d2,1:d1) -c -c help variables - integer i1,i2 -c - do i1=1,d1 - do i2=1,d2 - b(i2,i1)=a(i1,i2) - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/map2_21_t3.F90 openmolcas-22.10/src/cht3/map2_21_t3.F90 --- openmolcas-22.02/src/cht3/map2_21_t3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/map2_21_t3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,30 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Map2_21_t3(A,B,d1,d2) +! this routine does: +! map B(21) <- A(12) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: d1, d2 +real(kind=wp), intent(in) :: A(d1,d2) +real(kind=wp), intent(out) :: B(d2,d1) +integer(kind=iwp) :: i1 + +do i1=1,d1 + B(:,i1) = A(i1,:) +end do + +return + +end subroutine Map2_21_t3 diff -Nru openmolcas-22.02/src/cht3/map3_123_t3.f openmolcas-22.10/src/cht3/map3_123_t3.f --- openmolcas-22.02/src/cht3/map3_123_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/map3_123_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine Map3_123_t3 (A,B,d1,d2,d3) -c -c this routine do: -c map B(132) <- A(123) -c - implicit none - integer d1,d2,d3 - real*8 A(1:d1,1:d2,1:d3) - real*8 B(1:d1,1:d2,1:d3) -c -c help variables - integer i1,i2,i3 -c - do i3=1,d3 - do i2=1,d2 - do i1=1,d1 - b(i1,i2,i3)=a(i1,i2,i3) - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/map3_132_t3.f openmolcas-22.10/src/cht3/map3_132_t3.f --- openmolcas-22.02/src/cht3/map3_132_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/map3_132_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine Map3_132_t3 (A,B,d1,d2,d3) -c -c this routine do: -c map B(132) <- A(123) -c - implicit none - integer d1,d2,d3 - real*8 A(1:d1,1:d2,1:d3) - real*8 B(1:d1,1:d3,1:d2) -c -c help variables - integer i1,i2,i3 -c - do i2=1,d2 - do i3=1,d3 - do i1=1,d1 - b(i1,i3,i2)=a(i1,i2,i3) - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/map3_132_t3.F90 openmolcas-22.10/src/cht3/map3_132_t3.F90 --- openmolcas-22.02/src/cht3/map3_132_t3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/map3_132_t3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,32 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Map3_132_t3(A,B,d1,d2,d3) +! this routine does: +! map B(132) <- A(123) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: d1, d2, d3 +real(kind=wp), intent(in) :: A(d1,d2,d3) +real(kind=wp), intent(out) :: B(d1,d3,d2) +integer(kind=iwp) :: i2, i3 + +do i2=1,d2 + do i3=1,d3 + B(:,i3,i2) = A(:,i2,i3) + end do +end do + +return + +end subroutine Map3_132_t3 diff -Nru openmolcas-22.02/src/cht3/map3_213_t3.f openmolcas-22.10/src/cht3/map3_213_t3.f --- openmolcas-22.02/src/cht3/map3_213_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/map3_213_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine Map3_213_t3 (A,B,d1,d2,d3) -c -c this routine do: -c map B(213) <- A(123) -c - implicit none - integer d1,d2,d3 - real*8 A(1:d1,1:d2,1:d3) - real*8 B(1:d2,1:d1,1:d3) -c -c help variables - integer i1,i2,i3 -c - do i3=1,d3 - do i2=1,d2 - do i1=1,d1 - b(i2,i1,i3)=a(i1,i2,i3) - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/map3_231_t3.f openmolcas-22.10/src/cht3/map3_231_t3.f --- openmolcas-22.02/src/cht3/map3_231_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/map3_231_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine Map3_231_t3 (A,B,d1,d2,d3) -c -c this routine do: -c map B(231) <- A(123) -c - implicit none - integer d1,d2,d3 - real*8 A(1:d1,1:d2,1:d3) - real*8 B(1:d2,1:d3,1:d1) -c -c help variables - integer i1,i2,i3 -c - do i1=1,d1 - do i2=1,d2 - do i3=1,d3 - b(i2,i3,i1)=a(i1,i2,i3) - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/map3_231_t3.F90 openmolcas-22.10/src/cht3/map3_231_t3.F90 --- openmolcas-22.02/src/cht3/map3_231_t3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/map3_231_t3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,32 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Map3_231_t3(A,B,d1,d2,d3) +! this routine does: +! map B(231) <- A(123) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: d1, d2, d3 +real(kind=wp), intent(in) :: A(d1,d2,d3) +real(kind=wp), intent(out) :: B(d2,d3,d1) +integer(kind=iwp) :: i2, i3 + +do i2=1,d2 + do i3=1,d3 + B(i2,i3,:) = A(:,i2,i3) + end do +end do + +return + +end subroutine Map3_231_t3 diff -Nru openmolcas-22.02/src/cht3/map3_312_t3.f openmolcas-22.10/src/cht3/map3_312_t3.f --- openmolcas-22.02/src/cht3/map3_312_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/map3_312_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine Map3_312_t3 (A,B,d1,d2,d3) -c -c this routine do: -c map B(132) <- A(123) -c - implicit none - integer d1,d2,d3 - real*8 A(1:d1,1:d2,1:d3) - real*8 B(1:d3,1:d1,1:d2) -c -c help variables - integer i1,i2,i3 -c - do i2=1,d2 - do i3=1,d3 - do i1=1,d1 - b(i3,i1,i2)=a(i1,i2,i3) - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/map3_321_t3.f openmolcas-22.10/src/cht3/map3_321_t3.f --- openmolcas-22.02/src/cht3/map3_321_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/map3_321_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine Map3_321_t3 (A,B,d1,d2,d3) -c -c this routine do: -c map B(321) <- A(123) -c - implicit none - integer d1,d2,d3 - real*8 A(1:d1,1:d2,1:d3) - real*8 B(1:d3,1:d2,1:d1) -c -c help variables - integer i1,i2,i3 -c - do i1=1,d1 - do i2=1,d2 - do i3=1,d3 - b(i3,i2,i1)=a(i1,i2,i3) - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/map3_321_t3.F90 openmolcas-22.10/src/cht3/map3_321_t3.F90 --- openmolcas-22.02/src/cht3/map3_321_t3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/map3_321_t3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,32 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Map3_321_t3(A,B,d1,d2,d3) +! this routine does: +! map B(321) <- A(123) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: d1, d2, d3 +real(kind=wp), intent(in) :: A(d1,d2,d3) +real(kind=wp), intent(out) :: B(d3,d2,d1) +integer(kind=iwp) :: i2, i3 + +do i2=1,d2 + do i3=1,d3 + B(i3,i2,:) = A(:,i2,i3) + end do +end do + +return + +end subroutine Map3_321_t3 diff -Nru openmolcas-22.02/src/cht3/map4_1243_t3.f openmolcas-22.10/src/cht3/map4_1243_t3.f --- openmolcas-22.02/src/cht3/map4_1243_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/map4_1243_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine Map4_1243_t3 (A,B,d1,d2,d3,d4) -c -c this routine do: -c map B(1243) <- A(1234) -c - implicit none - integer d1,d2,d3,d4 - real*8 A(1:d1*d2,1:d3,1:d4) - real*8 B(1:d1*d2,1:d4,1:d3) -c -c help variables - integer i12,i3,i4 -c - do i3=1,d3 - do i4=1,d4 - do i12=1,d1*d2 - b(i12,i4,i3)=a(i12,i3,i4) - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/map4_1324_t3.f openmolcas-22.10/src/cht3/map4_1324_t3.f --- openmolcas-22.02/src/cht3/map4_1324_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/map4_1324_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine Map4_1324_t3 (A,B,d1,d2,d3,d4) -c -c this routine do: -c map B(1324) <- A(1234) -c - implicit none - integer d1,d2,d3,d4 - real*8 A(1:d1,1:d2,1:d3,1:d4) - real*8 B(1:d1,1:d3,1:d2,1:d4) -c -c help variables - integer i1,i2,i3,i4 -c - do i4=1,d4 - do i2=1,d2 - do i3=1,d3 - do i1=1,d1 - b(i1,i3,i2,i4)=a(i1,i2,i3,i4) - end do - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/map4_1342_t3.f openmolcas-22.10/src/cht3/map4_1342_t3.f --- openmolcas-22.02/src/cht3/map4_1342_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/map4_1342_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine Map4_1342_t3 (A,B,d1,d2,d3,d4) -c -c this routine do: -c map B(1423) <- A(1234) -c - implicit none - integer d1,d2,d3,d4 - real*8 A(1:d1,1:d2,1:d3,1:d4) - real*8 B(1:d1,1:d4,1:d2,1:d3) -c -c help variables - integer i1,i2,i3,i4 -c - do i3=1,d3 - do i2=1,d2 - do i4=1,d4 - do i1=1,d1 - b(i1,i4,i2,i3)=a(i1,i2,i3,i4) - end do - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/map4_1423_t3.f openmolcas-22.10/src/cht3/map4_1423_t3.f --- openmolcas-22.02/src/cht3/map4_1423_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/map4_1423_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine Map4_1423_t3 (A,B,d1,d2,d3,d4) -c -c this routine do: -c map B(1342) <- A(1234) -c - implicit none - integer d1,d2,d3,d4 - real*8 A(1:d1,1:d2,1:d3,1:d4) - real*8 B(1:d1,1:d3,1:d4,1:d2) -c -c help variables - integer i1,i2,i3,i4 -c - do i2=1,d2 - do i4=1,d4 - do i3=1,d3 - do i1=1,d1 - b(i1,i3,i4,i2)=a(i1,i2,i3,i4) - end do - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/map4_1432_t3.f openmolcas-22.10/src/cht3/map4_1432_t3.f --- openmolcas-22.02/src/cht3/map4_1432_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/map4_1432_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine Map4_1432_t3 (A,B,d1,d2,d3,d4) -c -c this routine do: -c map B(1432) <- A(1234) -c - implicit none - integer d1,d2,d3,d4 - real*8 A(1:d1,1:d2,1:d3,1:d4) - real*8 B(1:d1,1:d4,1:d3,1:d2) -c -c help variables - integer i1,i2,i3,i4 -c - do i2=1,d2 - do i3=1,d3 - do i4=1,d4 - do i1=1,d1 - b(i1,i4,i3,i2)=a(i1,i2,i3,i4) - end do - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/map4_2143_t3.f openmolcas-22.10/src/cht3/map4_2143_t3.f --- openmolcas-22.02/src/cht3/map4_2143_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/map4_2143_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine Map4_2143_t3 (A,B,d1,d2,d3,d4) -c -c this routine do: -c map B(2143) <- A(1234) -c - implicit none - integer d1,d2,d3,d4 - real*8 A(1:d1,1:d2,1:d3,1:d4) - real*8 B(1:d2,1:d1,1:d4,1:d3) -c -c help variables - integer i1,i2,i3,i4 -c - do i3=1,d3 - do i4=1,d4 - do i1=1,d1 - do i2=1,d2 - b(i2,i1,i4,i3)=a(i1,i2,i3,i4) - end do - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/map4_2314_t3.f openmolcas-22.10/src/cht3/map4_2314_t3.f --- openmolcas-22.02/src/cht3/map4_2314_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/map4_2314_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine Map4_2314_t3 (A,B,d1,d2,d3,d4) -c -c this routine do: -c map B(3124) <- A(1234) -c - implicit none - integer d1,d2,d3,d4 - real*8 A(1:d1,1:d2,1:d3,1:d4) - real*8 B(1:d3,1:d1,1:d2,1:d4) -c -c help variables - integer i1,i2,i3,i4 -c - do i4=1,d4 - do i2=1,d2 - do i1=1,d1 - do i3=1,d3 - b(i3,i1,i2,i4)=a(i1,i2,i3,i4) - end do - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/map4_3124_t3.f openmolcas-22.10/src/cht3/map4_3124_t3.f --- openmolcas-22.02/src/cht3/map4_3124_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/map4_3124_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine Map4_3124_t3 (A,B,d1,d2,d3,d4) -c -c this routine do: -c map B(2314) <- A(1234) -c - implicit none - integer d1,d2,d3,d4 - real*8 A(1:d1,1:d2,1:d3,1:d4) - real*8 B(1:d2,1:d3,1:d1,1:d4) -c -c help variables - integer i1,i2,i3,i4 -c - do i4=1,d4 - do i1=1,d1 - do i3=1,d3 - do i2=1,d2 - b(i2,i3,i1,i4)=a(i1,i2,i3,i4) - end do - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/map4_3142_t3.f openmolcas-22.10/src/cht3/map4_3142_t3.f --- openmolcas-22.02/src/cht3/map4_3142_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/map4_3142_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine Map4_3142_t3 (A,B,d1,d2,d3,d4) -c -c this routine do: -c map B(2413) <- A(1234) -c - implicit none - integer d1,d2,d3,d4 - real*8 A(1:d1,1:d2,1:d3,1:d4) - real*8 B(1:d2,1:d4,1:d1,1:d3) -c -c help variables - integer i1,i2,i3,i4 -c - do i3=1,d3 - do i1=1,d1 - do i4=1,d4 - do i2=1,d2 - b(i2,i4,i1,i3)=a(i1,i2,i3,i4) - end do - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/map4_3412_t3.f openmolcas-22.10/src/cht3/map4_3412_t3.f --- openmolcas-22.02/src/cht3/map4_3412_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/map4_3412_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine Map4_3412_t3 (A,B,d1,d2,d3,d4) -c -c this routine do: -c map B(3412) <- A(1234) -c - implicit none - integer d1,d2,d3,d4 - real*8 A(1:d1,1:d2,1:d3,1:d4) - real*8 B(1:d3,1:d4,1:d1,1:d2) -c -c help variables - integer i1,i2,i3,i4 -c - do i2=1,d2 - do i1=1,d1 - do i4=1,d4 - do i3=1,d3 - b(i3,i4,i1,i2)=a(i1,i2,i3,i4) - end do - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/map4_3412_t3.F90 openmolcas-22.10/src/cht3/map4_3412_t3.F90 --- openmolcas-22.02/src/cht3/map4_3412_t3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/map4_3412_t3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,34 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Map4_3412_t3(A,B,d1,d2,d3,d4) +! this routine does: +! map B(3412) <- A(1234) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: d1, d2, d3, d4 +real(kind=wp), intent(in) :: A(d1,d2,d3,d4) +real(kind=wp), intent(out) :: B(d3,d4,d1,d2) +integer(kind=iwp) :: i2, i3, i4 + +do i2=1,d2 + do i4=1,d4 + do i3=1,d3 + B(i3,i4,:,i2) = A(:,i2,i3,i4) + end do + end do +end do + +return + +end subroutine Map4_3412_t3 diff -Nru openmolcas-22.02/src/cht3/map4_3421_t3.f openmolcas-22.10/src/cht3/map4_3421_t3.f --- openmolcas-22.02/src/cht3/map4_3421_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/map4_3421_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine Map4_3421_t3 (A,B,d1,d2,d3,d4) -c -c this routine do: -c map B(4312) <- A(1234) -c - implicit none - integer d1,d2,d3,d4 - real*8 A(1:d1,1:d2,1:d3,1:d4) - real*8 B(1:d4,1:d3,1:d1,1:d2) -c -c help variables - integer i1,i2,i3,i4 -c - do i2=1,d2 - do i1=1,d1 - do i3=1,d3 - do i4=1,d4 - b(i4,i3,i1,i2)=a(i1,i2,i3,i4) - end do - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/map4_4123_t3.f openmolcas-22.10/src/cht3/map4_4123_t3.f --- openmolcas-22.02/src/cht3/map4_4123_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/map4_4123_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine Map4_4123_t3 (A,B,d1,d2,d3,d4) -c -c this routine do: -c map B(2341) <- A(1234) -c - implicit none - integer d1,d2,d3,d4 - real*8 A(1:d1,1:d2,1:d3,1:d4) - real*8 B(1:d2,1:d3,1:d4,1:d1) -c -c help variables - integer i1,i2,i3,i4 -c - do i1=1,d1 - do i4=1,d4 - do i3=1,d3 - do i2=1,d2 - b(i2,i3,i4,i1)=a(i1,i2,i3,i4) - end do - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/map4_4312_t3.f openmolcas-22.10/src/cht3/map4_4312_t3.f --- openmolcas-22.02/src/cht3/map4_4312_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/map4_4312_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine Map4_4312_t3 (A,B,d1,d2,d3,d4) -c -c this routine do: -c map B(3421) <- A(1234) -c - implicit none - integer d1,d2,d3,d4 - real*8 A(1:d1,1:d2,1:d3,1:d4) - real*8 B(1:d3,1:d4,1:d2,1:d1) -c -c help variables - integer i1,i2,i3,i4 -c - do i1=1,d1 - do i2=1,d2 - do i4=1,d4 - do i3=1,d3 - b(i3,i4,i2,i1)=a(i1,i2,i3,i4) - end do - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/multi_opendir.f openmolcas-22.10/src/cht3/multi_opendir.f --- openmolcas-22.02/src/cht3/multi_opendir.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/multi_opendir.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine multi_opendir(FNAM, iunit) - implicit none -c -c Direct fortran I/O with irregular data records -c -c Assume here RECL in byte units (Same assumption in t3smat.f). -c -c PV/LAOG, 22 may 2003. -c -c - character FNAM*(*) - integer iunit, iost -#include "ndisk.fh" - Logical is_error -* open(unit=iunit, file=FNAM, access='direct', -* $ form='unformatted', status='unknown', recl=nblock*8) - Call MOLCAS_Open_Ext2(iUnit,FNam, - & 'direct','unformatted', - & iost,.TRUE., - & nblock*8,'unknown',is_error) - If (iost.gt.0 .or. is_error) Then - Write (6,*) 'Multi_OpenDir: Error opening file!' - End If - return - end diff -Nru openmolcas-22.02/src/cht3/multi_opendir.F90 openmolcas-22.10/src/cht3/multi_opendir.F90 --- openmolcas-22.02/src/cht3/multi_opendir.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/multi_opendir.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,34 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine multi_opendir(FNAM,iunit) +! Direct fortran I/O with irregular data records +! +! Assume here RECL in byte units (Same assumption in t3smat.f). +! +! PV/LAOG, 22 may 2003. + +use ChT3_global, only: nblock +use Definitions, only: iwp, u6 + +implicit none +character(len=*), intent(in) :: FNAM +integer(kind=iwp), intent(in) :: iunit +integer(kind=iwp) :: iost +logical(kind=iwp) is_error + +!open(unit=iunit,file=FNAM,access='direct',form='unformatted',status='unknown',recl=nblock*8) +call MOLCAS_Open_Ext2(iUnit,FNam,'direct','unformatted',iost,.true.,nblock*8,'unknown',is_error) +if ((iost > 0) .or. is_error) write(u6,*) 'Multi_OpenDir: Error opening file!' + +return + +end subroutine multi_opendir diff -Nru openmolcas-22.02/src/cht3/multi_readir.f openmolcas-22.10/src/cht3/multi_readir.f --- openmolcas-22.02/src/cht3/multi_readir.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/multi_readir.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,79 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine multi_readir(G,lg,ifile,ias) -c -c Direct fortran I/O with irregular data records -c -c Each data record is assumed to begin aligned with a disk record -c but may span several disk records. -c -c The price to pay for this flexibility is -c 1) remembering the correspondance between data record numbers -c and corresponding initial disk records. -c 2) wasting some disk space, in average about nu*nblock/2 -c where nu is the number of data records and nblock the disk -c record size. -c -c Arguments -c G Buffer (real*8 words) -c lg Buffer length -c ifile file unit -c ias direct access record to start with -c (nblock direct access record length, defined in include file) -c -c PV/LAOG, 22 may 2003. -c - implicit none -#include "ndisk.fh" - integer lg, ifile, ias, iloc,irest,kas,k, last -#include "ioind.fh" - real*8 G(lg) -c - iloc=1 - irest=lg - kas=ias -c - do while(irest.gt.0) - k=min(irest,nblock) - IF(kas.le.iopt(27))then - call readir(G(iloc),k,ifile,kas) - else - call readir(G(iloc),k,ifile+1,kas-iopt(27)) - endif - iloc=iloc+k - irest=irest-k - kas=kas+1 - enddo - return -c -c -c - entry multi_wridir(G,lg,ifile,ias,last) -c - iloc=1 - irest=lg - kas=ias - -c - do while(irest.gt.0) - k=min(irest,nblock) - IF(kas.le.iopt(27))then - call wridir(G(iloc),k,ifile,kas) - else - call wridir(G(iloc),k,ifile+1,kas-iopt(27)) - endif - iloc=iloc+k - irest=irest-k - kas=kas+1 - enddo - last=kas-1 - return - end diff -Nru openmolcas-22.02/src/cht3/multi_readir.F90 openmolcas-22.10/src/cht3/multi_readir.F90 --- openmolcas-22.02/src/cht3/multi_readir.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/multi_readir.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,58 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine multi_readir(G,lg,ifile,ias) +! Direct fortran I/O with irregular data records +! +! Each data record is assumed to begin aligned with a disk record +! but may span several disk records. +! +! The price to pay for this flexibility is +! 1) remembering the correspondance between data record numbers +! and corresponding initial disk records. +! 2) wasting some disk space, in average about nu*nblock/2 +! where nu is the number of data records and nblock the disk +! record size. +! +! Arguments +! G Buffer (real*8 words) +! lg Buffer length +! ifile file unit +! ias direct access record to start with +! (nblock direct access record length, defined in module) +! +! PV/LAOG, 22 may 2003. + +use ChT3_global, only: IOPT, nblock +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: lg, ifile, ias +real(kind=wp), intent(out) :: G(lg) +integer(kind=iwp) :: iloc, irest, k, kas + +iloc = 1 +irest = lg +kas = ias + +do while (irest > 0) + k = min(irest,nblock) + if (kas <= iopt(2)) then + read(ifile,rec=kas) G(iloc:iloc+k-1) + else + read(ifile+1,rec=kas-iopt(2)) G(iloc:iloc+k-1) + end if + iloc = iloc+k + irest = irest-k + kas = kas+1 +end do + +end subroutine multi_readir diff -Nru openmolcas-22.02/src/cht3/multi_wridir.F90 openmolcas-22.10/src/cht3/multi_wridir.F90 --- openmolcas-22.02/src/cht3/multi_wridir.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/multi_wridir.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,45 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine multi_wridir(G,lg,ifile,ias,last) +! See multi_readir +! +! PV/LAOG, 22 may 2003. + +use ChT3_global, only: IOPT, nblock +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: lg, ifile, ias +real(kind=wp), intent(in) :: G(lg) +integer(kind=iwp), intent(out) :: last +integer(kind=iwp) :: iloc, irest, k, kas + +iloc = 1 +irest = lg +kas = ias + +do while (irest > 0) + k = min(irest,nblock) + if (kas <= iopt(2)) then + write(ifile,rec=kas) G(iloc:iloc+k-1) + else + write(ifile+1,rec=kas-iopt(2)) G(iloc:iloc+k-1) + end if + iloc = iloc+k + irest = irest-k + kas = kas+1 +end do +last = kas-1 + +return + +end subroutine multi_wridir diff -Nru openmolcas-22.02/src/cht3/my_block.f openmolcas-22.10/src/cht3/my_block.f --- openmolcas-22.02/src/cht3/my_block.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/my_block.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,82 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine my_block (vblock,vblock_my) -c -c this subroutine calculates maximum overlap between juzek's -c vblock segmentation and palo's dimgrp -c - implicit none -c -#include "cht3_ccsd1.fh" -#include "ccsd_t3compat.fh" -#include "cht3_reord.fh" -c - integer i,j,i_tmp,i_f,i_l,poss - integer vblock,vblock_my,vblock_my_tmp - logical found -c - vblock_my=0 - i_l=0 - i_f=0 -c - do i=1,nv,vblock -c -c - find initial possition of the i-th juzek's block -c - poss=0 - found=.false. - do j=1,NvGrp - poss=poss+DimGrpaR(j) - if ((i.le.poss).and.(.not.found)) then - i_f=j - found=.true. -cmp write (6,'(A,3(i5,x))') 'i,i_f,poss = ', -cmp & i,i_f,poss - end if - end do -c - if ((i+vblock-1).le.nv) then - i_tmp=i+vblock-1 - else - i_tmp=nv - end if -cmp write (6,'(A,2(i5,x))') 'i,i_tmp = ', -cmp & i,i_tmp -c -c - find terminal possition of the i-th juzek's block -c - poss=0 - found=.false. - do j=1,NvGrp - poss=poss+DimGrpaR(j) - if ((i_tmp.le.poss).and.(.not.found)) then - i_l=j - found=.true. -cmp write (6,'(A,3(i5,x))') 'i_tmp,i_l,poss = ', -cmp & i_tmp,i_l,poss - end if - end do -c - vblock_my_tmp=0 - do j=i_f,i_l - vblock_my_tmp=vblock_my_tmp+DimGrpaR(j) - end do -c - if (vblock_my_tmp.gt.vblock_my) - & vblock_my=vblock_my_tmp -c -cmp write (6,'(A,2(i5,x))') 'vblock_my_tmp, vblock_my', -cmp & vblock_my_tmp, vblock_my -cmp write (6,*) - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/my_block.F90 openmolcas-22.10/src/cht3/my_block.F90 --- openmolcas-22.02/src/cht3/my_block.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/my_block.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,77 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine my_block(vblock,vblock_my) +! this subroutine calculates maximum overlap between juzek's +! vblock segmentation and palo's dimgrp + +use ChT3_global, only: DimGrpaR, nv, NvGrp +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: vblock +integer(kind=iwp), intent(out) :: vblock_my +integer(kind=iwp) :: i, i_f, i_l, i_tmp, j, pos, vblock_my_tmp +logical(kind=iwp) :: found + +vblock_my = 0 +i_l = 0 +i_f = 0 + +do i=1,nv,vblock + + ! - find initial position of the i-th juzek's block + + pos = 0 + found = .false. + do j=1,NvGrp + pos = pos+DimGrpaR(j) + if ((i <= pos) .and. (.not. found)) then + i_f = j + found = .true. + !mp write(u6,'(A,3(i5,x))') 'i,i_f,pos = ',i,i_f,pos + end if + end do + + if ((i+vblock-1) <= nv) then + i_tmp = i+vblock-1 + else + i_tmp = nv + end if + !mp write(u6,'(A,2(i5,x))') 'i,i_tmp = ',i,i_tmp + + ! - find terminal position of the i-th juzek's block + + pos = 0 + found = .false. + do j=1,NvGrp + pos = pos+DimGrpaR(j) + if ((i_tmp <= pos) .and. (.not. found)) then + i_l = j + found = .true. + !mp write(u6,'(A,3(i5,x))') 'i_tmp,i_l,pos = ',i_tmp,i_l,pos + end if + end do + + vblock_my_tmp = 0 + do j=i_f,i_l + vblock_my_tmp = vblock_my_tmp+DimGrpaR(j) + end do + + if (vblock_my_tmp > vblock_my) vblock_my = vblock_my_tmp + + !mp write(u6,'(A,2(i5,x))') 'vblock_my_tmp, vblock_my',vblock_my_tmp,vblock_my + !mp write(u6,*) +end do + +return + +end subroutine my_block diff -Nru openmolcas-22.02/src/cht3/ndisk.fh openmolcas-22.10/src/cht3/ndisk.fh --- openmolcas-22.02/src/cht3/ndisk.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/ndisk.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -c Introduced NDISK parameter to parametrize get3dm/put3dm sequential -c unformatted I/O in DIRCCR12ROS. PV-011115, Bratislava. -c Comments updated by PV, 2 jan 2006. -c -c Record size in put3dm and get3dm is ndisk+1 (in R*8 units) -c and must match /COMBUF/ length. (Original ndisk value was 511.) -c -c **BEWARE** -c NDISK must be (2**k1)-1. -c NDISK must be also a multiple of 3 to match /COMBUF/. -c This latter condition implies k1 to be even. -c Get3dm and put3dm also assume integer*4 in COMBUF. -c - integer ndisk - parameter (ndisk=4095) -c parameter (ndisk=16383) -c -c -c NBLOCK is used for direct-access unformatted I/O via multi.f. -c Count a record size in real*8 words. Should be 2**k2. -c NOTE. k1 and k2 may be different. - integer nblock - parameter (nblock=2048) -cmp! parameter (nblock=8192) diff -Nru openmolcas-22.02/src/cht3/pack23_23.f openmolcas-22.10/src/cht3/pack23_23.f --- openmolcas-22.02/src/cht3/pack23_23.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/pack23_23.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine pack23_23 (AA,BB,d1,d2) -c -c this routine do : -c -c A(a,bc) -> B(a,b,c) bc : b>=c, dimb must eq dimc -c - implicit none - integer d1,d2,a,b,c,bc - real*8 BB(d1,d2,d2),AA(d1,(d2*(d2+1)/2)) -c - bc=0 - do b=1,d2 - do c=1,b - do a=1,d1 -c - bc=bc+1 - BB(a,b,c)=AA(a,bc) - BB(a,c,b)=AA(a,bc) - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/pack32_12.f openmolcas-22.10/src/cht3/pack32_12.f --- openmolcas-22.02/src/cht3/pack32_12.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/pack32_12.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine pack32_12 (AA,BB,d1,d2) -c -c this routine do : -c -c A(a,b,c) -> B(ab,c) bc : b>=c, dimb must eq dimc -c - implicit none - integer d1,d2,a,b,c,ab - real*8 AA(d1,d1,d2),BB(1:(d1*(d1+1)/2),1:d2) -c - do c=1,d2 - ab=0 - do a=1,d1 - do b=1,a - ab=ab+0 -c - BB(ab,c)=AA(a,b,c) - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/pack32_23.f openmolcas-22.10/src/cht3/pack32_23.f --- openmolcas-22.02/src/cht3/pack32_23.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/pack32_23.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine pack32_23 (AA,BB,d1,d2) -c -c this routine do : -c -c A(a,b,c) -> B(a,bc) bc : b>=c, dimb must eq dimc -c - implicit none - integer d1,d2,a,b,c,bc - real*8 AA(d1,d2,d2),BB(d1,(d2*(d2+1)/2)) -c - bc=0 - do b=1,d2 - do c=1,b - do a=1,d1 -c - bc=bc+1 - BB(a,bc)=AA(a,b,c) - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/pack43_34.f openmolcas-22.10/src/cht3/pack43_34.f --- openmolcas-22.02/src/cht3/pack43_34.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/pack43_34.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine pack43_34 (AA,BB,d1,d2,d3) -c -c this routine do : -c -c A(a,b,c,d) -> B(a,b,cd) c>=d -c - implicit none - integer d1,d2,d3,a,b,c,d,cd - real*8 AA(d1,d2,d3,d3),BB(d1,d2,(d3*(d3+1)/2)) -c - cd=0 - do c=1,d3 - do d=1,c - cd=cd+1 - do b=1,d2 - do a=1,d1 -c - BB(a,b,cd)=AA(a,b,c,d) - end do - end do - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/param_cht3.fh openmolcas-22.10/src/cht3/param_cht3.fh --- openmolcas-22.02/src/cht3/param_cht3.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/param_cht3.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,12 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - integer IT,ITLAST,NBF,NOMX,NU,MX2,NNO,NNU,NUO,NSO - COMMON/PARAM/IT,ITLAST,NBF,NOMX,NU,MX2,NNO,NNU,NUO,NSO diff -Nru openmolcas-22.02/src/cht3/reor_mat.f openmolcas-22.10/src/cht3/reor_mat.f --- openmolcas-22.02/src/cht3/reor_mat.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/reor_mat.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,165 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE REOR_MAT(Y,X,I1,I2,J1,J2) - implicit none - integer I1,I2,J1,J2, I,J,IJ,L - REAL*8 Y,X,ONE,SCALAR - PARAMETER (ONE=1.D0) - DIMENSION Y(I1,I2,J1,J2),X(*) -C -CSUBROUTINE EX24 EXCHANGE OF THE 2nd and 4th index in a matrix -C - ENTRY EX24(Y,X,I1,I2,J1,J2) - IJ=1 - DO J=1,I2 - DO L=1,J1 - DO I=1,J2 - CALL DCOPY_(I1,Y(1,J,L,I),1,X(IJ),1) - IJ=IJ+I1 - ENDDO - ENDDO - ENDDO - RETURN -C -C - ENTRY EX24_A(Y,X,I1,I2,J1,J2,SCALAR) -C -CS EX24_A EXCHANGE OF THE 2nd and 4th index in a matrix+ADD -C - IJ=1 - DO J=1,I2 - DO L=1,J1 - DO I=1,J2 - CALL DAXPY_(I1,SCALAR,Y(1,J,L,I),1,X(IJ),1) -! CALL DCOPY_(I1,Y(1,J,L,I),1,X(IJ),1) - IJ=IJ+I1 - ENDDO - ENDDO - ENDDO - RETURN -C -C - ENTRY EX34_A(Y,X,I1,I2,J1,J2,SCALAR) -C -CS EX34_A EXCHANGE OF THE 3nd and 4th index in a matrix+ADD -C - IJ=1 -! DO J=1,I2 - DO L=1,J1 - DO I=1,J2 - CALL DAXPY_(I1*I2,SCALAR,Y(1,1,L,I),1,X(IJ),1) -! CALL DCOPY_(I1,Y(1,J,L,I),1,X(IJ),1) - IJ=IJ+I1*I2 - ENDDO - ENDDO -! ENDDO - RETURN -C -C - ENTRY EX23(Y,X,I1,I2,J1,J2) -C - IJ=1 - DO J=1,J2 - DO L=1,I2 - DO I=1,J1 - CALL DCOPY_(I1,Y(1,L,I,J),1,X(IJ),1) - IJ=IJ+I1 - ENDDO - ENDDO - ENDDO - RETURN -C -C - ENTRY EX23_A(Y,X,I1,I2,J1,J2) -C - IJ=1 - DO J=1,J2 - DO L=1,I2 - DO I=1,J1 - CALL DAXPY_(I1,ONE,Y(1,L,I,J),1,X(IJ),1) - IJ=IJ+I1 - ENDDO - ENDDO - ENDDO - RETURN -C -C - ENTRY EX312(Y,X,I1,I2,J1,J2) -C - IJ=1 - DO J=1,J2 - DO L=1,I2 - DO I=1,I1 - CALL DCOPY_(J1,Y(I,L,1,J),I1*I2,X(IJ),1) - IJ=IJ+J1 - ENDDO - ENDDO - ENDDO - RETURN -C -C - ENTRY EX2413(Y,X,I1,I2,J1,J2) -C - IJ=1 - DO J=1,J1 - DO L=1,I1 - DO I=1,J2 - CALL DCOPY_(I2,Y(L,1,J,I),I1,X(IJ),1) - IJ=IJ+I2 - ENDDO - ENDDO - ENDDO - - RETURN -C -C - ENTRY EX2413_A(Y,X,I1,I2,J1,J2) -C - IJ=1 - DO J=1,J1 - DO L=1,I1 - DO I=1,J2 - CALL DAXPY_(I2,ONE,Y(L,1,J,I),I1,X(IJ),1) - IJ=IJ+I2 - ENDDO - ENDDO - ENDDO - RETURN -C -C - ENTRY EX423(Y,X,I1,I2,J1,J2) -C - IJ=1 - DO J=1,J1 - DO L=1,I2 - DO I=1,J2 - CALL DCOPY_(I1,Y(1,L,J,I),1,X(IJ),1) - IJ=IJ+I1 - ENDDO - ENDDO - ENDDO - RETURN -C -C - ENTRY EX423_A(Y,X,I1,I2,J1,J2,SCALAR) -C - IJ=1 - DO J=1,J1 - DO L=1,I2 - DO I=1,J2 - CALL DAXPY_(I1,SCALAR,Y(1,L,J,I),1,X(IJ),1) -C CALL DCOPY_(I1,Y(1,L,J,I),1,X(IJ),1) - IJ=IJ+I1 - ENDDO - ENDDO - ENDDO - RETURN - END diff -Nru openmolcas-22.02/src/cht3/t3ampl_bti.f openmolcas-22.10/src/cht3/t3ampl_bti.f --- openmolcas-22.02/src/cht3/t3ampl_bti.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/t3ampl_bti.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,898 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE T3AMPL_BTI(OEH,OEP) -cmp SUBROUTINE T3AMPL_BTI(W,OEH,OEP) - -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C *** PROGRAM TRIPLY-UHF/RHF - REDUCED DIMENSION and timing - DRIVER -C -C CALCULATION OF TRIPLE EXCITATION CONTRIBUTION TO -C THE 4TH ORDER CORRELATION ENERGY OF MB RSPT AND CC-TRIPLES -C -C Provides T3AMPL_BLOCKEDIMPROVED: Accelerated algorithm. -c -c Combines triply w/ trick by JN and limited I/Os by buffered -c blocking scheme by PV. Blocks the virtual space to pieces -c optimal either for parallelization or in using the available -c memory -c Involves also more robust and more reliable memory allocator. -c -c History -c Buffered blocking scheme: PV, LAOG Grenoble, 16 april 2003. -c First version w/ trick: JN, June 12, 2003 -c Parallel version: PV, 15 oct 2003. -c Implemented integer offsets, PV, 14 may 2004. -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - use Para_Info, Only: MyRank, nProcs - implicit none - integer IUHF,LU(6) - integer i,nuga,nugc,nga,ngb,ngc,vblock, it1 - integer isp,krem - real*8 OEH(*),OEP(*),ddot_,ccsdt,ccsdt4,energ(4),tccsd, - $ times(10), - $ times_parr(10), totcpu, totwal, timerel -c real*8 cpu0,cpu1,wall0,wall1 - character FN*6 - logical ifvo - integer la,t1a,t1b - logical lastcall,scored -cmp -c integer maxspace - integer nla,nlb - real*8 enx1 -cmp -#include "param_cht3.fh" -#include "ioind.fh" -#include "uhf.fh" -cmp -#include "cht3_casy.fh" -#include "WrkSpc.fh" -cmp -#include "ndisk.fh" -#include "dupfiles.fh" -cmp! include 'task_info_inc' -cmp! include 'ws_conn_inc' -cmp -#include "cht3_ccsd1.fh" -#ifdef _MOLCAS_MPP_ -#include "mafdecls.fh" -#endif -!???#ifdef _MOLCAS_MPP_ -!??? integer mytype, krems(nhmx) -!???#endif -cmp!! integer me, err, len_trim -!? integer nprocs0 -!?cmp common /my_mpi_world_com/ me, nprocs - integer itmp - integer imy_tsk - integer id,j - logical rsv_tsk - external rsv_tsk -c - real*8 e_ccsd, e_scf - real*8 cpu0_aaa,wall0_aaa,cpu0_aab,wall0_aab -c -!? nprocs0=nprocs -c Uncomment the following to force sequential mode -! nprocs=1 - - if (nprocs.gt.1) then - write(6,'(A,i4,A)') ' Parallel run on ',nprocs,' nodes' - else - write(6,'(A,i4,A)') ' Serial run' - endif - call xflush(6) -c -C t^ijk_abc . D^abc_ijk = -C -C alpha-alpha-alpha (K_ab^ir+K_ab^jr-K_ac^kr)*(L_rc^jk+L_rc^ki+L_rc^ij) -C or beta-beta-beta + permutations bca, acb -C - M_abc^iki -M_abc^iij -M_abc^jjk+M_abc^jij-M_abc^kki+M_abc^kjk -C + permutations bca cab -C -C where M_abc^ijk=K_ab^ir*L_ra^jk -C -C strategy: blocks the number of virtuals to pieces by ng -C then everything in the memory! -c -c free everything from W(1) including Hermit space -c (PV) done for slaves in calling routine slave_T3AMPL_BTI -c -C parallelization: distribute common UHF -c (PV) done for slaves in calling routine slave_T3AMPL_BTI -c -cmp!! call gettim(cpu0,wall0) - - do I=1,6 - LU(I)=90+I - enddo - - call zeroma(times,1,10) - call zeroma(energ,1,4) - -c -C calculate the T2-T3 contraction? ifvo is the answer ! open-shell stuff ! -cmp call get3dm('FOC-VO',w,noab(1)*nuab(1)+noab(2)*nuab(2),1,0) -cmp ifvo=(ddot_(noab(1)*nuab(1)+noab(2)*nuab(2),w,1,w,1).gt.1d-14) - ifvo=.false. - -C -C parallelization: do this on each host >>>>>>> start -C -C allocates for two arrays of the size T1 - - it1=NUAB(1)*NOAB(1)+NUAB(2)*NOAB(2) - - call GetMem('t3_t1a','Allo','Real',t1a,it1) - call GetMem('t3_t1b','Allo','Real',t1b,it1) - - call zeroma(Work(t1a),1,it1) - call zeroma(Work(t1b),1,it1) - - call GetMem('t3_t1','Allo','Real',itmp,noab(1)*nuab(1)) - call GetMem('t3_la','Allo','Real',la,it1) - -cmp! read t1 amplitudes - if (printkey.ge.10) then - write (6,*) 'Reading ',it1,' t1_alpha, t1_beta amplitudes' - end if - call GetRest_t3 (Work(la),Work(itmp),e_ccsd) -c -cmp! write (6,*) 'Ze t1 = ', -cmp! & ddot_(it1,Work(la),1,Work(la),1) -c -C t1a and t1b always remain in the memory -- small fields -c -c parallelization: on each host <<<<<<< end - block done -c - -C Remaining space can be used for the blocking in-core algorithms - - Call GetMem('t3_la','Max','Real',krem,krem) - - if (printkey.ge.10) then - write(6,*) - write(6,*) 'Available Memory before v_size_t3 = ', krem - call xflush(6) - end if -C -C determines the virtual block size -C vblock - the virtual orbitals block size -C look for optimal number with respect nprocs to v_size_t3 -C - write (6,*) - write(6,'(2x,A)') - & 'Starting triply with blocked virtuals algorithm' - if (nprocs.gt.1) then - write (6,*) ' Node Number ',MyRank - end if -c -c Compute memory pattern. -c - call v_size_t3(vblock,nprocs,krem,printkey) - - IUHF=1 ! open-shell stuff - IF(IOPT(76).EQ.0)IUHF=0 - - if (printkey.ge.10) then - write (6,'(A,i1)') ' Closed-Shell calculation, IUHF = ',iuhf - end if -c -C create K(beta-alpha,beta-alpha) and L(alpha-beta,beta-alpha) - ndup=0 !????? - -cmp - print information on number of steps in loopa and loopb -c - call check_loops(nuab(1),vblock,nla,nlb) - write (6,*) - write (6,'(A,i6)') 'Number of steps in loopa : ',nla - write (6,'(A,i6)') 'Number of steps in loopb : ',nlb -c -c checking : -c - if (t3_stopa.gt.nla) then - write (6,*) 'Too many steps in t3_loopa requested in input' - write (6,*) 'T3_LOOPA from input : ', - & t3_starta,t3_stopa,t3_stopa-t3_startb+1 - write (6,*) 'total T3_LOOPA steps : ',nla - call abend() - end if -c - if (t3_stopb.gt.nlb) then - write (6,*) 'Too many steps in t3_loopb requested in input' - write (6,*) 'T3_LOOPB from input : ', - & t3_startb,t3_stopb,t3_stopb-t3_startb+1 - write (6,*) 'total T3_LOOPB steps : ',nlb - call abend() - end if -c -cmp - if (gen_files) then -c - write (6,*) - write (6,*) 'Creating KMAT, LMAT Scratch Integral Files'// - & '-----------------------------' - write (6,*) -cmp - call create_klvab_t3(vblock) -cmp - Call CWTime(TCpu,TWall) -c - if (printkey.gt.1) then - write (6,*) - write (6,'(A,f18.1)') ' Cpu last call [s] = ', - & TCpu-TCpu_l - write (6,'(A,f18.1)') 'Wall last call [s] = ', - & TWall-TWall_l - write (6,*) - write (6,'(A,f18.1)') 'Total Cpu [s] = ', - & TCpu - write (6,'(A,f18.1)') 'Total Wall [s] = ', - & TWall-TWall0 - write (6,'(A,f18.2)') 'TCpu/TWall [%] = ', - & 100.0d0*TCpu/(TWall-TWall0) - write (6,*) - end if - - TCpu_l=TCpu - TWall_l=TWall - -cmp - - write (6,*) 'Create of Integrals done', - & '-------------------------------------------------' - write (6,*) -cmp -c - else - write (6,*) - write (6,*) 'Skipping KMAT, LMAT scratch integral', - & ' files generation as requested' - end if -cmp - cpu0_aaa=TCpu - wall0_aaa=TWall -c - if (.not.run_triples) then - write (6,*) - write (6,*) 'Exiting triples after scratch integral', - & ' files generation as requested' - return - !? call abend() - end if -cmp - -C creates K(alpha-alpha,alpha-alpha) (dummy for closed shell) -C (master only) -cmp! -cmp! open-shell stuff -cmp! -cmp! if(iuhf.ne.0)then -cmp! DO isp=1,1+iuhf -cmp! call create_klvaa_t3(w(la),vblock,isp) -cmp! enddo -cmp! endif - -C -C parallelization: files KMATxy LMATxy x=A,B y=A,B (BA - closed shell) -C generated on each host - -c Sorting and initialization timing - -cmp! call gettim(cpu1,wall1) ! prerob na poriadne timingy - Call CWTime(TCpu,TWall) - times(9)=times(9)+TCpu-TCpu0 - times(10)=times(10)+TWall-TWall0 - - DO isp=1,1+iuhf - - nuga=nuab(isp)/vblock - if((nuga*vblock).lt.nuab(isp))nuga=nuga+1 - nugc=nuab(3-isp)/vblock - if((nugc*vblock).lt.nuab(3-isp))nugc=nugc+1 -C creates K(alpha-alpha,alpha-alpha) (dummy for closed shell) -c! if(iuhf.ne.0)then ! open-shell stuff. -c! call create_klvaa_t3(w(la),vblock,isp) -c! endif - FN(5:5)=ich(isp) - FN(6:6)=ich(isp) - FN(1:4)='KMAT' - call multi_opendir(FN,LU(1)) - FN(1:4)='LMAT' - call multi_opendir(FN,LU(2)) -C -C parallelization: files KMATxx LMATxx are assumed to be available -C to all tasks on each host -C -C not for closed shell -C alpha-alpha-alpha or closed shell -c -c - skip t3loopa if needed -c - if ((t3_starta.lt.0).and.(t3_startb.gt.0)) then - write (6,*) - write (6,*) 'Skipping t3loopa on user request ' - write (6,*) - goto 494 - end if -c - i=0 - do nga=1,nuga - do ngb=1,nga - do ngc=1,ngb - i=i+1 - end do - end do - end do -c - if (t3_starta.lt.0) then - call GetMem ('Imy_tsk','Allo','Inte',imy_tsk, - & 3*i) - else - call GetMem ('Imy_tsk','Allo','Inte',imy_tsk, - & (t3_stopa-t3_starta+1)*3) - end if -c - if (t3_starta.lt.0) then - i=0 - do nga=1,nuga - do ngb=1,nga - do ngc=1,ngb - i=i+1 - iWork(imy_tsk-3+3*i)=nga - iWork(imy_tsk-3+3*i+1)=ngb - iWork(imy_tsk-3+3*i+2)=ngc - end do - end do - end do - else - i=0 - do nga=1,nuga - do ngb=1,nga - do ngc=1,ngb - i=i+1 -c - if ((i.ge.t3_starta).and.(i.le.t3_stopa)) then - iWork(imy_tsk-3+3*(i-t3_starta+1))=nga - iWork(imy_tsk-3+3*(i-t3_starta+1)+1)=ngb - iWork(imy_tsk-3+3*(i-t3_starta+1)+2)=ngc - end if -c - end do - end do - end do - end if -c - if (t3_starta.gt.0) then ! for correct deallocation - i=t3_stopa-t3_starta+1 - end if -c - write (6,*) - write (6,*) '# of tasks to be parallelized in t3loop a = ',i - id=666 - lastcall=.false. - scored=.false. - call init_tsk(id,i) -98 if (.not. rsv_tsk(id,j)) goto 99 -c - nga=iWork(imy_tsk-3+3*j) - ngb=iWork(imy_tsk-3+3*j+1) - ngc=iWork(imy_tsk-3+3*j+2) -c -cmp -cmp Call GetMem('(T)','Max','Real',maxspace,maxspace) -cmp write (*,*) 'maxspace before ',maxspace -cmp - call t3loopa( - $ oeh(noab(1)*(isp-1)+1), - $ oep(nuab(1)*(isp-1)+1), - $ Work(t1a+noab(1)*nuab(1)*(isp-1)), - $ Work(t1b+noab(1)*nuab(1)*(isp-1)), - $ nga,ngb,ngc,vblock,energ,isp,LU,ifvo, - & lastcall,scored,j,enx1) -cmp -c update 5th order terms -c - -cmp call vadd(Work(t1a),1,Work(t1a+noab(1)*nuab(1)),1, -cmp $Work(t1a),1,noab(1)*nuab(1)) - - call daxpy_((noab(1)*nuab(1)), 1.0d0, - & Work(t1a+noab(1)*nuab(1)), 1, - & Work(t1a), 1) - ccsdt=2.d0*ddot_(noab(1)*nuab(1),Work(la),1,Work(t1a),1) - call daxpy_((noab(1)*nuab(1)), -1.0d0, - & Work(t1a+noab(1)*nuab(1)), 1, - & Work(t1a), 1) -c -cmp - Call CWTime(TCpu,TWall) -cmp - if (t3_starta.lt.0) then - write (6,'(A,i5,1x,3(i3,1x),2(f21.19,1x),2(f8.1,A,1x))') - & 'Tsk, nga, ngb, ngc, inc = ', - & j, - & nga,ngb,ngc,2.0d0*enx1,ccsdt, - & TCpu-TCpu_l,' CPU [s]',TWall-TWall_l,' Wall [s]' - else - write (6,'(A,i5,1x,3(i3,1x),2(f21.19,1x),2(f8.1,A,1x))') - & 'Tsk, nga, ngb, ngc, inc = ', - & j+t3_starta-1, - & nga,ngb,ngc,2.0d0*enx1,ccsdt, - & TCpu-TCpu_l,' CPU [s]',TWall-TWall_l,' Wall [s]' - end if - - TCpu_l=TCpu - TWall_l=TWall -cmp -cmp Call GetMem('(T)','Max','Real',maxspace,maxspace) -cmp write (*,*) 'maxspace after ',maxspace -cmp -c - goto 98 -99 continue - write (6,*) 't3loopa finished' - write (6,*) - Call Free_tsk(id) - call GetMem ('Imy_tsk','Free','Inte',imy_tsk,3*i) -c -cmp! call gettim(cpu1,wall1) ! dorob timingy !!!!!! - Call CWTime(TCpu,TWall) - times(isp)=times(isp)+TCpu-cpu0_aaa - times(isp+4)=times(isp+4)+TWall-wall0_aaa - - write(6,'(1X,5A,D12.4,A,D12.4,A)') - $ 'Spin case ',ich(isp),ich(isp),ich(isp),' done:', - $ (TCpu-cpu0_aaa),' CPU [s]', - & (TWall-wall0_aaa),' Wall [s]' - call xflush(6) -cmp - Call CWTime(TCpu,TWall) -c - if (printkey.gt.1) then - write (6,*) - write (6,'(A,f18.1)') 'Total Cpu [s] = ', - & TCpu - write (6,'(A,f18.1)') 'Total Wall [s] = ', - & TWall-TWall0 - write (6,'(A,f18.2)') 'TCpu/TWall [%] = ', - & 100.0d0*TCpu/(TWall-TWall0) - write (6,*) - end if - - TCpu_l=TCpu - TWall_l=TWall -cmp - -494 continue - -cmp - cpu0_aab=TCpu - wall0_aab=TWall -cmp - - if ((t3_starta.gt.0).and.(t3_startb.lt.0)) then - write (6,*) - write (6,*) 'Skipping t3loopb on user request ' - write (6,*) - goto 495 - end if -c - -C alpha-alpha-beta or beta-beta-alpha only UHF - !!if(IUHF.ne.0)then -cmp!! call gettim(cpu0,wall0) - FN(5:5)=ich(3-isp) - FN(6:6)=ich(isp) - FN(1:4)='KMAT' - call multi_opendir(FN,LU(3)) - FN(1:4)='LMAT' - call multi_opendir(FN,LU(5)) - - IF(IUHF.NE.0)THEN ! open-shell stuff - FN(5:5)=ich(isp) - FN(6:6)=ich(3-isp) - FN(1:4)='KMAT' - call multi_opendir(FN,LU(4)) - FN(1:4)='LMAT' - call multi_opendir(FN,LU(6)) - ELSE - LU(4)=LU(3) - LU(6)=LU(5) - ENDIF - -cmp - i=0 - do nga=1,nuga - do ngb=1,nga - do ngc=1,nugc - i=i+1 - end do - end do - end do -c - if (t3_startb.lt.0) then - call GetMem ('Imy_tsk','Allo','Inte',imy_tsk,3*i) - else - call GetMem ('Imy_tsk','Allo','Inte',imy_tsk, - & (t3_stopb-t3_startb+1)*3) - end if -c - i=0 - if (t3_startb.lt.0) then - do nga=1,nuga - do ngb=1,nga - do ngc=1,nugc - i=i+1 - iWork(imy_tsk-3+3*i)=nga - iWork(imy_tsk-3+3*i+1)=ngb - iWork(imy_tsk-3+3*i+2)=ngc - end do - end do - end do - else - do nga=1,nuga - do ngb=1,nga - do ngc=1,nugc - i=i+1 - if ((i.ge.t3_startb).and.(i.le.t3_stopb)) then - iWork(imy_tsk-3+3*(i-t3_startb+1))=nga - iWork(imy_tsk-3+3*(i-t3_startb+1)+1)=ngb - iWork(imy_tsk-3+3*(i-t3_startb+1)+2)=ngc - end if - end do - end do - end do - end if -c - if (t3_startb.gt.0) then - i=t3_stopb-t3_startb+1 - end if -c - write (6,*) - write (6,*) '# of tasks to be parallelized in t3loopb = ',i - id=667 - lastcall=.false. - scored=.false. - call init_tsk(id,i) -198 if (.not. rsv_tsk(id,j)) goto 199 -c - nga=iWork(imy_tsk-3+3*j) - ngb=iWork(imy_tsk-3+3*j+1) - ngc=iWork(imy_tsk-3+3*j+2) -cmp write (6,'(A,4(i5,2x))') 'Tsk, nga, ngb, ngc = ',j,nga,ngb,ngc -c -cmp -cmp Call GetMem('(T)','Max','Real',maxspace,maxspace) -cmp write (*,*) 'maxspace before ',maxspace -cmp - call t3loopb(oeh,oep,Work(t1a),Work(t1b), - $ nga,ngb,ngc,vblock,energ(3),isp,LU,ifvo, - & lastcall,scored,j,enx1) -c -cmp??? call vadd(Work(t1a),1,Work(t1a+noab(1)*nuab(1)),1, -cmp??? $Work(t1a),1,noab(1)*nuab(1)) - call daxpy_((noab(1)*nuab(1)), 1.0d0, - & Work(t1a+noab(1)*nuab(1)), 1, - & Work(t1a), 1) - ccsdt=2.d0*ddot_(noab(1)*nuab(1),Work(la),1,Work(t1a),1) - call daxpy_((noab(1)*nuab(1)), -1.0d0, - & Work(t1a+noab(1)*nuab(1)), 1, - & Work(t1a), 1) -c -cmp - Call CWTime(TCpu,TWall) -cmp - if (t3_startb.lt.0) then - write (6,'(A,i5,1x,3(i3,1x),2(f21.19,1x),2(f8.1,A,1x))') - & 'Tsk, nga, ngb, ngc, inc = ', - & j, - & nga,ngb,ngc,2.0d0*enx1,ccsdt, - & TCpu-TCpu_l,' CPU [s]',TWall-TWall_l,' Wall [s]' - else - write (6,'(A,i5,1x,3(i3,1x),2(f21.19,1x),2(f8.1,A,1x))') - & 'Tsk, nga, ngb, ngc, inc = ', - & j+t3_startb-1, - & nga,ngb,ngc,2.0d0*enx1,ccsdt, - & TCpu-TCpu_l,' CPU [s]',TWall-TWall_l,' Wall [s]' - end if - - TCpu_l=TCpu - TWall_l=TWall -c -cmp -cmp Call GetMem('(T)','Max','Real',maxspace,maxspace) -cmp write (*,*) 'maxspace before ',maxspace -cmp -c - goto 198 -199 continue - write (6,*) 't3loopb finished' - write (6,*) - Call Free_tsk(id) - call GetMem ('Imy_tsk','Free','Inte',imy_tsk,3*i) -cmp write (6,*) ' energ = ',energ -cmp -c - deallocate arrays in t3loopb -c -cmp! call gettim(cpu1,wall1) ! urob poriadne timingy !!!! - Call CWTime(TCpu,TWall) - times(2+isp)=times(2+isp)+TCpu-cpu0_aab - times(6+isp)=times(6+isp)+TWall-wall0_aab - write(6,'(1X,5A,D12.4,A,D12.4,A)') - $ 'Spin case ',ich(isp),ich(isp),ich(3-isp),' done:', - $ (TCpu-cpu0_aab),' CPU [s]', - & (TWall-wall0_aab),' Wall [s]' - call xflush(6) - do i=3,6 - close(LU(i)) - enddo - !!endif !! IUHF - close (LU(1)) - close (LU(2)) - enddo ! isp -cmp!! call gettim(cpu0,wall0) ! urob timingy! -cmp - Call CWTime(TCpu,TWall) -c - if (printkey.gt.1) then - write (6,*) - write (6,'(A,f18.1)') 'Total Cpu [s] = ', - & TCpu - write (6,'(A,f18.1)') 'Total Wall [s] = ', - & TWall-TWall0 - write (6,'(A,f18.2)') 'TCpu/TWall [%] = ', - & 100.0d0*TCpu/(TWall-TWall0) - write (6,*) - end if - TCpu_l=TCpu - TWall_l=TWall -cmp - -495 continue - - do i=1,10 - times_parr(i)=times(i) - end do - -#ifdef _MOLCAS_MPP_ - - it1=NUAB(1)*NOAB(1)+NUAB(2)*NOAB(2) - block - real*8 :: real_buffer(1) - real_buffer(1) = ccsdt - call gadgop (real_buffer, size(real_buffer), '+') - ccsdt = real_buffer(1) - end block - call gadgop (energ,4,'+') - call gadgop (times_parr,10,'+') -c -#endif - - call xflush(6) - -c Add MPI_Reduce contribution to sorting timing -cmp!cmp! call gettim(cpu1,wall1) -cmp! Call CWTime(TCpu,TWall) -cmp! times(9)=times(9)+TCpu-TCpu0 -cmp! times(10)=times(10)+TWall-TWall0 - -C -C T(CCSD) -C - IF(IUHF.EQ.0)then - energ(2)=energ(1) - energ(4)=energ(3) - endif - tccsd=energ(1)+energ(2)+energ(3)+energ(4) - -cmp! IF(IUHF.EQ.0)then ! open-shell stuff -cmp! call vadd(Work(t1a),1,Work(t1a+noab(1)*nuab(1)),1, -cmp! $Work(t1a),1,noab(1)*nuab(1)) -cmp! ccsdt=2.d0*ddot_(noab(1)*nuab(1),Work(la),1,Work(t1a),1) -cmp! else -cmp! ccsdt=ddot_(noab(1)*nuab(1)+noab(2)*nuab(2),Work(la),1,Work(t1a),1) -cmp! write (*,*) 'ze co do ... ?' -cmp! stop -cmp! endif - -cmp! for MOLCAS verify - Call Get_dScalar('SCF energy',e_scf) - Call Add_Info('CHT3ene', tccsd + ccsdt, 1, 6) - Call Add_Info('E_CHT3', tccsd + ccsdt, 1, 6) - Call Add_Info('E_HYPE', e_scf + e_ccsd + tccsd + ccsdt, 1, 6) -c for NUMERICAL_GRADIENTS - Call Put_cArray('Relax Method','CHT3 ',8) - Call Store_Energies(1,tccsd+ccsdt+e_ccsd+e_scf,1) -cmp! - - if (printkey.gt.1) then - write (6,*) - write (6,*) '--------------------------------------------------' - write (6,*) - write (6,*) 'GADGOPed energ & ccsdt values: ' - write (6,*) - write (6,'(A,4(f15.12,1x))') 'energ (t2-w-t3 = 2*e1 + 2*e3) ', - & energ - write (6,*) - write (6,'(A,f15.12)') 'Sum ', - & 2.0d0*energ(1)+2.0d0*energ(3) - write (6,'(A,f15.12)') 'ccsdt (e5th ord. ST) ', - & ccsdt - write (6,*) - write (6,*) '--------------------------------------------------' - end if - - -c Contents of times array: -c -c CPU WALL -c sorting -c aaa 1 4 -c bbb 2 6 -c aab 3 7 -c bba 4 8 -c -c Master has only to sum up the results - do i=1,10 - times(i)=times(i)/60.d0 ! now in minutes - enddo - if (nprocs.gt.1) then - do i=1,10 - times_parr(i)=times_parr(i)/60.d0 - enddo - endif - - ccsdt4=0.d0 - if(ifvo)then - write (6,*) 'ifvo correspond to open-shell system. Exiting' - call abend() - -cmp! call get3dm('FOC-VO',w(la),noab(1)*nuab(1)+noab(2)*nuab(2),1,0) -cmp! call transm(w(la),w(t1a),nuab(1),noab(1)) -cmp! call transm(w(noab(1)*nuab(1)+la), -cmp! $ w(noab(1)*nuab(1)+t1a),nuab(2),noab(2)) -c E4 T2FT3 -cmp! IF(IUHF.EQ.0)then -cmp! call vadd(w(t1b),1,w(t1b+noab(1)*nuab(1)),1, -cmp! $w(t1b),1,noab(1)*nuab(1)) -cmp! ccsdt4=2.0*ddot_(noab(1)*nuab(1),w(t1a),1,w(t1b),1) -cmp! else -cmp! ccsdt4=ddot_(noab(1)*nuab(1)+noab(2)*nuab(2),w(t1a),1,w(t1b),1) -cmp! endif - endif - - !RESULT(IT+3,5)=ccsdt4+ccsdt - IF(IT.EQ.0)THEN - !RESULT(IT+1,5)=tccsd+ccsdt4+ccsdt - if(ifvo)then - WRITE(6,9993)TCCSD - WRITE(6,9991)ccsdt4 - WRITE(6,9990)ccsdt - endif - WRITE(6,9994)TCCSD+ccsdt+ccsdt4 - ELSE - !RESULT(IT+2,5)=TCCSD - WRITE(6,9993)TCCSD - if(ifvo)then - WRITE(6,9991)ccsdt4 - WRITE(6,9990)ccsdt - WRITE(6,9995)CCSDT+ccsdt4 - else - WRITE(6,9995)CCSDT - endif - ENDIF - - write (6,*) '*************************************************' - write (6,*) - write (6,*) 'Final Results : ' - write (6,*) - write (6,'(A,f15.12)') ' (T) corr. = ',tccsd + ccsdt - write (6,'(A,f15.12)') ' CCSD(T) corr. = ', - & e_ccsd + tccsd + ccsdt - write (6,*) - write (6,*) '*************************************************' - write (6,*) - -c Timing - if (nprocs.gt.1) write(6,*) 'Master timings:' - if (times(10).le.0.0d0) then - timerel=1.0d0 - else - timerel=times(9)/times(10) - end if - write(6,'(1x,a,2f13.3,a,f6.3)')'sorting cpu & wall', - $ times(9),times(10),' (min); cpu/wall=',timerel - if (times(5).le.0.0d0) then - timerel=1.0d0 - else - timerel=times(1)/times(5) - end if - write(6,'(1x,a,2f13.3,a,f6.3)')'aaa cpu & wall', - $ times(1),times(5),' (min); cpu/wall=',timerel - if (times(6).le.0.0d0) then - timerel=1.0d0 - else - timerel=times(2)/times(6) - end if - IF(IUHF.NE.0) - $write(6,'(1x,a,2f13.3,a,f6.3)')'bbb cpu & wall', - $ times(2),times(6),' (min); cpu/wall=',timerel - if (times(7).le.0.0d0) then - timerel=1.0d0 - else - timerel=times(3)/times(7) - end if - write(6,'(1x,a,2f13.3,a,f6.3)')'aab cpu & wall', - $ times(3),times(7),' (min); cpu/wall=',timerel - if (times(8).le.0.0d0) then - timerel=1.0d0 - else - timerel=times(4)/times(8) - end if - IF(IUHF.NE.0) - $write(6,'(1x,a,2f13.3,a,f6.3)')'bba cpu & wall', - $ times(4),times(8),' (min); cpu/wall=',timerel - totcpu=times(9) - totwal=times(10) - do i=1,4 - totcpu=totcpu+times(i) - totwal=totwal+times(4+i) - enddo - if (totwal.le.0.0d0) then - timerel=1.0d0 - else - timerel=totcpu/totwal - end if - write(6,'(1x,a,2f13.3,a,f6.3)') 'total cpu & wall', - $ totcpu,totwal,' (min); cpu/wall=',timerel - if (nprocs.le.1) goto 2000 - -c Parallel timing - totcpu=times_parr(9) - totwal=times_parr(10) - times(9)=times_parr(9) - do i=1,4 - totcpu=totcpu+times_parr(i) - totwal=totwal+times_parr(4+i) - enddo - if (totwal.le.0.0d0) then - timerel=1.0d0 - else - timerel=totcpu/totwal - end if - write(6,*) - write(6,*) 'Aggregate parallel timings:' - write(6,'(1x,a,2f13.3,a,f6.3)') 'total cpu & wall', - $ totcpu,totwal,' (min); cpu/wall=',timerel - -c Return - 2000 continue -cmp call w_debug(.false.,.false.,'Triply done') -!? nprocs=nprocs0 - - call GetMem('t3_la','Free','Real',la, - & NUAB(1)*NOAB(1)+NUAB(2)*NOAB(2)) - call GetMem('t3_t1','Free','Real',itmp,noab(1)*nuab(1)) - call GetMem('t3_t1a','Free','Real',t1a,it1) - call GetMem('t3_t1b','Free','Real',t1b,it1) - return - - 9993 FORMAT(/1X,'T2-W-T3 contribution from current amplitudes ',D18.10) - 9991 FORMAT(1X,'T2-F-T3 contribution from current amplitudes ',D18.10) - 9990 FORMAT(1X,'T1-W-T3 contribution from current amplitudes ',D18.10) - 9994 FORMAT (/1X,'4th order MBPT tripleexcitation contribution ' - $ ,D18.10) - 9995 FORMAT(/1X,'5th order noniterative E[5] ST correction ' - $ ,D18.10/) -c9997 FORMAT(/1X,'Total ST correction with ROHF reference ' -c $ ,D18.10/) - end diff -Nru openmolcas-22.02/src/cht3/t3ampl_bti.F90 openmolcas-22.10/src/cht3/t3ampl_bti.F90 --- openmolcas-22.02/src/cht3/t3ampl_bti.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/t3ampl_bti.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,759 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine T3AMPL_BTI(OEH,OEP) +!mp subroutine T3AMPL_BTI(W,OEH,OEP) + +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! *** PROGRAM TRIPLY-UHF/RHF - REDUCED DIMENSION and timing - DRIVER +! +! CALCULATION OF TRIPLE EXCITATION CONTRIBUTION TO +! THE 4TH ORDER CORRELATION ENERGY OF MB RSPT AND CC-TRIPLES +! +! Provides T3AMPL_BLOCKEDIMPROVED: Accelerated algorithm. +! +! Combines triply w/ trick by JN and limited I/Os by buffered +! blocking scheme by PV. Blocks the virtual space to pieces +! optimal either for parallelization or in using the available +! memory +! Involves also more robust and more reliable memory allocator. +! +! History +! Buffered blocking scheme: PV, LAOG Grenoble, 16 april 2003. +! First version w/ trick: JN, June 12, 2003 +! Parallel version: PV, 15 oct 2003. +! Implemented integer offsets, PV, 14 may 2004. +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + +use ChT3_global, only: gen_files, ICH, IOPT, IT, NOAB, NUAB, printkey, run_triples, t3_starta, t3_startb, t3_stopa, t3_stopb, & + TCpu, TCpu_l, TCpu0, TWall, TWall_l, TWall0 +use Para_Info, only: MyRank, nProcs +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two +use Definitions, only: wp, iwp, u6, r8 + +implicit none +real(kind=wp), intent(in) :: OEH(*), OEP(*) +integer(kind=iwp) :: i, id, isp, it1, IUHF, j, krem, LU(6), n, nga, ngb, ngc, nla, nlb, nuga, nugc, vblock +real(kind=wp) :: ccsdt, ccsdt4, cpu0_aaa, cpu0_aab, e_ccsd, e_scf, energ(4), enx1, tccsd, timerel, times(10), times_parr(10), & + totcpu, totwal, wall0_aaa, wall0_aab +#ifdef _MOLCAS_MPP_ +real(kind=wp) :: real_buffer(1) +#endif +logical(kind=iwp) :: ifvo, scored, skip +character(len=6) :: FN +integer(kind=iwp), allocatable :: my_tsk(:,:) +real(kind=wp), allocatable :: la(:), t1a(:), t1b(:), tmp(:) +logical(kind=iwp), external :: rsv_tsk +real(kind=r8), external :: ddot_ + +!? nprocs0 = nprocs +! Uncomment the following to force sequential mode +! nprocs = 1 + +if (nprocs > 1) then + write(u6,'(A,i4,A)') ' Parallel run on ',nprocs,' nodes' +else + write(u6,'(A,i4,A)') ' Serial run' +end if +call xflush(u6) + +! t^ijk_abc . D^abc_ijk = +! +! alpha-alpha-alpha (K_ab^ir+K_ab^jr-K_ac^kr)*(L_rc^jk+L_rc^ki+L_rc^ij) +! or beta-beta-beta + permutations bca, acb +! - M_abc^iki -M_abc^iij -M_abc^jjk+M_abc^jij-M_abc^kki+M_abc^kjk +! + permutations bca cab +! +! where M_abc^ijk=K_ab^ir*L_ra^jk +! +! strategy: blocks the number of virtuals to pieces by ng +! then everything in the memory! +! +! free everything from W(1) including Hermit space +! (PV) done for slaves in calling routine slave_T3AMPL_BTI +! +! parallelization: distribute common UHF +! (PV) done for slaves in calling routine slave_T3AMPL_BTI + +!mp !!call gettim(cpu0,wall0) + +do I=1,6 + LU(I) = 90+I +end do + +times(:) = Zero +energ(:) = Zero + +! calculate the T2-T3 contraction? ifvo is the answer ! open-shell stuff ! +!mp call get3dm('FOC-VO',w,noab(1)*nuab(1)+noab(2)*nuab(2),1,0) +!mp ifvo = ddot_(noab(1)*nuab(1)+noab(2)*nuab(2),w,1,w,1) > 1.0e-14_wp +ifvo = .false. + +! parallelization: do this on each host >>>>>>> start + +! allocates for two arrays of the size T1 + +it1 = NUAB(1)*NOAB(1)+NUAB(2)*NOAB(2) + +call mma_allocate(t1a,it1,label='t3_t1a') +call mma_allocate(t1b,it1,label='t3_t1b') + +t1a(:) = Zero +t1b(:) = Zero + +call mma_allocate(tmp,noab(1)*nuab(1),label='t3_t1') +call mma_allocate(la,it1,label='t3_la') + +!mp ! read t1 amplitudes +if (printkey >= 10) write(u6,*) 'Reading ',it1,' t1_alpha, t1_beta amplitudes' +call GetRest_t3(la,tmp,e_ccsd) + +!mp !write(u6,*) 'Ze t1 = ',ddot_(it1,la,1,la,1) + +! t1a and t1b always remain in the memory -- small fields + +! parallelization: on each host <<<<<<< end - block done + +! Remaining space can be used for the blocking in-core algorithms + +call mma_maxDBLE(krem) + +if (printkey >= 10) then + write(u6,*) + write(u6,*) 'Available Memory before v_size_t3 = ',krem + call xflush(u6) +end if + +! determines the virtual block size +! vblock - the virtual orbitals block size +! look for optimal number with respect nprocs to v_size_t3 + +write(u6,*) +write(u6,'(2x,A)') 'Starting triply with blocked virtuals algorithm' +if (nprocs > 1) write(u6,*) ' Node Number ',MyRank + +! Compute memory pattern. + +call v_size_t3(vblock,nprocs,krem,printkey) + +IUHF = 1 ! open-shell stuff +if (IOPT(1) == 0) IUHF = 0 + +if (printkey >= 10) write(u6,'(A,i1)') ' Closed-Shell calculation, IUHF = ',iuhf + +! create K(beta-alpha,beta-alpha) and L(alpha-beta,beta-alpha) +!ndup = 0 !????? + +!mp - print information on number of steps in loopa and loopb + +call check_loops(nuab(1),vblock,nla,nlb) +write(u6,*) +write(u6,'(A,i6)') 'Number of steps in loopa : ',nla +write(u6,'(A,i6)') 'Number of steps in loopb : ',nlb + +! checking : + +if (t3_stopa > nla) then + write(u6,*) 'Too many steps in t3_loopa requested in input' + write(u6,*) 'T3_LOOPA from input : ',t3_starta,t3_stopa,t3_stopa-t3_startb+1 + write(u6,*) 'total T3_LOOPA steps : ',nla + call abend() +end if + +if (t3_stopb > nlb) then + write(u6,*) 'Too many steps in t3_loopb requested in input' + write(u6,*) 'T3_LOOPB from input : ',t3_startb,t3_stopb,t3_stopb-t3_startb+1 + write(u6,*) 'total T3_LOOPB steps : ',nlb + call abend() +end if + +!mp +if (gen_files) then + + write(u6,*) + write(u6,*) 'Creating KMAT, LMAT Scratch Integral Files-----------------------------' + write(u6,*) + !mp + call create_klvab_t3(vblock) + !mp + call CWTime(TCpu,TWall) + + if (printkey > 1) then + write(u6,*) + write(u6,'(A,f18.1)') ' Cpu last call [s] = ',TCpu-TCpu_l + write(u6,'(A,f18.1)') 'Wall last call [s] = ',TWall-TWall_l + write(u6,*) + write(u6,'(A,f18.1)') 'Total Cpu [s] = ',TCpu + write(u6,'(A,f18.1)') 'Total Wall [s] = ',TWall-TWall0 + write(u6,'(A,f18.2)') 'TCpu/TWall [%] = ',100.0_wp*TCpu/(TWall-TWall0) + write(u6,*) + end if + + TCpu_l = TCpu + TWall_l = TWall + + !mp + + write(u6,*) 'Create of Integrals done-------------------------------------------------' + write(u6,*) + !mp + +else + write(u6,*) + write(u6,*) 'Skipping KMAT, LMAT scratch integral files generation as requested' +end if +!mp +cpu0_aaa = TCpu +wall0_aaa = TWall +! +if (.not. run_triples) then + write(u6,*) + write(u6,*) 'Exiting triples after scratch integral files generation as requested' + return + !? call abend() +end if +!mp + +! creates K(alpha-alpha,alpha-alpha) (dummy for closed shell) +! (master only) +!mp +!mp ! open-shell stuff +!mp ! +!mp !if (iuhf /= 0) then +!mp ! do isp=1,1+iuhf +!mp ! call create_klvaa_t3(w(la),vblock,isp) +!mp ! end do +!mp !end if + +! parallelization: files KMATxy LMATxy x=A,B y=A,B (BA - closed shell) +! generated on each host + +! Sorting and initialization timing + +!mp !call gettim(cpu1,wall1) ! prerob na poriadne timingy +call CWTime(TCpu,TWall) +times(9) = times(9)+TCpu-TCpu0 +times(10) = times(10)+TWall-TWall0 + +skip = .false. +do isp=1,1+iuhf + + nuga = nuab(isp)/vblock + if ((nuga*vblock) < nuab(isp)) nuga = nuga+1 + nugc = nuab(3-isp)/vblock + if ((nugc*vblock) < nuab(3-isp)) nugc = nugc+1 + ! creates K(alpha-alpha,alpha-alpha) (dummy for closed shell) + !!if (iuhf /= 0) then ! open-shell stuff. + !! call create_klvaa_t3(w(la),vblock,isp) + !!end if + FN = 'KMAT'//ich(isp)//ich(isp) + call multi_opendir(FN,LU(1)) + FN = 'LMAT'//ich(isp)//ich(isp) + call multi_opendir(FN,LU(2)) + + ! parallelization: files KMATxx LMATxx are assumed to be available + ! to all tasks on each host + + ! not for closed shell + ! alpha-alpha-alpha or closed shell + + ! - skip t3loopa if needed + + if ((t3_starta < 0) .and. (t3_startb > 0)) then + write(u6,*) + write(u6,*) 'Skipping t3loopa on user request ' + write(u6,*) + else + + if (t3_starta < 0) then + i = 0 + do nga=1,nuga + do ngb=1,nga + do ngc=1,ngb + i = i+1 + end do + end do + end do + else + i = t3_stopa-t3_starta+1 + end if + call mma_allocate(my_tsk,3,i,label='my_tsk') + + i = 0 + if (t3_starta < 0) then + do nga=1,nuga + do ngb=1,nga + do ngc=1,ngb + i = i+1 + my_tsk(1,i) = nga + my_tsk(2,i) = ngb + my_tsk(3,i) = ngc + end do + end do + end do + else + do nga=1,nuga + do ngb=1,nga + do ngc=1,ngb + i = i+1 + if ((i >= t3_starta) .and. (i <= t3_stopa)) then + my_tsk(1,i-t3_starta) = nga + my_tsk(2,i-t3_starta) = ngb + my_tsk(3,i-t3_starta) = ngc + end if + end do + end do + end do + end if + + if (t3_starta > 0) then ! for correct deallocation + i = t3_stopa-t3_starta+1 + end if + + write(u6,*) + write(u6,*) '# of tasks to be parallelized in t3loop a = ',i + id = 666 + scored = .false. + call init_tsk(id,i) + do while (rsv_tsk(id,j)) + + nga = my_tsk(1,j) + ngb = my_tsk(2,j) + ngc = my_tsk(3,j) + + !mp + !mp call mma_maxDBLE(maxspace) + !mp write(u6,*) 'maxspace before ',maxspace + !mp + call t3loopa(oeh(noab(1)*(isp-1)+1),oep(nuab(1)*(isp-1)+1),t1a(noab(1)*nuab(1)*(isp-1)+1), & + t1b(noab(1)*nuab(1)*(isp-1)+1),nga,ngb,ngc,vblock,energ,isp,LU,ifvo,scored,enx1) + !mp + ! update 5th order terms + + n = noab(1)*nuab(1) + !mp t1a(1:n) = t1a(1:n)+t1a(n+1:2*n) + ccsdt = Two*(ddot_(n,la,1,t1a,1)+ddot_(n,la,1,t1a(n+1),1)) + + !mp + call CWTime(TCpu,TWall) + !mp + if (t3_starta < 0) then + write(u6,'(A,i5,1x,3(i3,1x),2(f21.19,1x),2(f8.1,A,1x))') 'Tsk, nga, ngb, ngc, inc = ',j,nga,ngb,ngc,Two*enx1,ccsdt, & + TCpu-TCpu_l,' CPU [s]',TWall-TWall_l,' Wall [s]' + else + write(u6,'(A,i5,1x,3(i3,1x),2(f21.19,1x),2(f8.1,A,1x))') 'Tsk, nga, ngb, ngc, inc = ',j+t3_starta-1,nga,ngb,ngc,Two*enx1, & + ccsdt,TCpu-TCpu_l,' CPU [s]',TWall-TWall_l,' Wall [s]' + end if + + TCpu_l = TCpu + TWall_l = TWall + !mp + !mp call mma_maxDBLE(maxspace) + !mp write(u6,*) 'maxspace after ',maxspace + !mp + + end do + write(u6,*) 't3loopa finished' + write(u6,*) + call Free_tsk(id) + call mma_deallocate(my_tsk) + + !mp !call gettim(cpu1,wall1) ! dorob timingy !!!!!! + call CWTime(TCpu,TWall) + times(isp) = times(isp)+TCpu-cpu0_aaa + times(isp+4) = times(isp+4)+TWall-wall0_aaa + + write(u6,'(1X,5A,D12.4,A,D12.4,A)') 'Spin case ',ich(isp),ich(isp),ich(isp),' done:',TCpu-cpu0_aaa,' CPU [s]',TWall-wall0_aaa, & + ' Wall [s]' + call xflush(u6) + !mp + call CWTime(TCpu,TWall) + + if (printkey > 1) then + write(u6,*) + write(u6,'(A,f18.1)') 'Total Cpu [s] = ',TCpu + write(u6,'(A,f18.1)') 'Total Wall [s] = ',TWall-TWall0 + write(u6,'(A,f18.2)') 'TCpu/TWall [%] = ',100.0_wp*TCpu/(TWall-TWall0) + write(u6,*) + end if + + TCpu_l = TCpu + TWall_l = TWall + !mp + + end if + + !mp + cpu0_aab = TCpu + wall0_aab = TWall + !mp + + if ((t3_starta > 0) .and. (t3_startb < 0)) then + write(u6,*) + write(u6,*) 'Skipping t3loopb on user request ' + write(u6,*) + skip = .true. + exit + end if + + ! alpha-alpha-beta or beta-beta-alpha only UHF + !!if (IUHF /= 0)then + !mp!!call gettim(cpu0,wall0) + FN = 'KMAT'//ich(3-isp)//ich(isp) + call multi_opendir(FN,LU(3)) + FN = 'LMAT'//ich(3-isp)//ich(isp) + call multi_opendir(FN,LU(5)) + + if (IUHF /= 0) then ! open-shell stuff + FN = 'KMAT'//ich(isp)//ich(3-isp) + call multi_opendir(FN,LU(4)) + FN = 'LMAT'//ich(isp)//ich(3-isp) + call multi_opendir(FN,LU(6)) + else + LU(4) = LU(3) + LU(6) = LU(5) + end if + + !mp + i = 0 + if (t3_startb < 0) then + do nga=1,nuga + do ngb=1,nga + do ngc=1,nugc + i = i+1 + end do + end do + end do + else + i = t3_stopb-t3_startb+1 + end if + call mma_allocate(my_tsk,3,i,label='my_tsk') + + i = 0 + if (t3_startb < 0) then + do nga=1,nuga + do ngb=1,nga + do ngc=1,nugc + i = i+1 + my_tsk(1,i) = nga + my_tsk(2,i) = ngb + my_tsk(3,i) = ngc + end do + end do + end do + else + do nga=1,nuga + do ngb=1,nga + do ngc=1,nugc + i = i+1 + if ((i >= t3_startb) .and. (i <= t3_stopb)) then + my_tsk(1,i-t3_startb) = nga + my_tsk(2,i-t3_startb) = ngb + my_tsk(3,i-t3_startb) = ngc + end if + end do + end do + end do + end if + + if (t3_startb > 0) then + i = t3_stopb-t3_startb+1 + end if + + write(u6,*) + write(u6,*) '# of tasks to be parallelized in t3loopb = ',i + id = 667 + scored = .false. + call init_tsk(id,i) + do while (rsv_tsk(id,j)) + + nga = my_tsk(1,j) + ngb = my_tsk(2,j) + ngc = my_tsk(3,j) + !mp write(u6,'(A,4(i5,2x))') 'Tsk, nga, ngb, ngc = ',j,nga,ngb,ngc + + !mp + !mp call mma_maxDBLE(maxspace) + !mp write(u6,*) 'maxspace before ',maxspace + !mp + call t3loopb(oeh,oep,t1a,t1b,nga,ngb,ngc,vblock,energ(3),isp,LU,ifvo,scored,enx1) + + n = noab(1)*nuab(1) + !mp??? t1a(1:n) = t1a(1:n)+t1a(n+1:2*n) + ccsdt = Two*(ddot_(n,la,1,t1a,1)+ddot_(n,la,1,t1a(n+1),1)) + + !mp + call CWTime(TCpu,TWall) + !mp + if (t3_startb < 0) then + write(u6,'(A,i5,1x,3(i3,1x),2(f21.19,1x),2(f8.1,A,1x))') 'Tsk, nga, ngb, ngc, inc = ',j,nga,ngb,ngc,Two*enx1,ccsdt, & + TCpu-TCpu_l,' CPU [s]',TWall-TWall_l,' Wall [s]' + else + write(u6,'(A,i5,1x,3(i3,1x),2(f21.19,1x),2(f8.1,A,1x))') 'Tsk, nga, ngb, ngc, inc = ',j+t3_startb-1,nga,ngb,ngc,Two*enx1, & + ccsdt,TCpu-TCpu_l,' CPU [s]',TWall-TWall_l,' Wall [s]' + end if + + TCpu_l = TCpu + TWall_l = TWall + + !mp + !mp call mma_maxDBLE(maxspace) + !mp write(u6,*) 'maxspace before ',maxspace + !mp + + end do + write(u6,*) 't3loopb finished' + write(u6,*) + call Free_tsk(id) + call mma_deallocate(my_tsk) + !mp write(u6,*) ' energ = ',energ + !mp + ! - deallocate arrays in t3loopb + ! + !mp !call gettim(cpu1,wall1) ! urob poriadne timingy !!!! + call CWTime(TCpu,TWall) + times(2+isp) = times(2+isp)+TCpu-cpu0_aab + times(6+isp) = times(6+isp)+TWall-wall0_aab + write(u6,'(1X,5A,D12.4,A,D12.4,A)') 'Spin case ',ich(isp),ich(isp),ich(3-isp),' done:',TCpu-cpu0_aab,' CPU [s]',TWall-wall0_aab, & + ' Wall [s]' + call xflush(u6) + do i=3,6 + close(LU(i)) + end do + !!end if !! IUHF + close(LU(1)) + close(LU(2)) +end do ! isp +if (.not. skip) then + !mp !!call gettim(cpu0,wall0) ! urob timingy! + !mp + call CWTime(TCpu,TWall) + + if (printkey > 1) then + write(u6,*) + write(u6,'(A,f18.1)') 'Total Cpu [s] = ',TCpu + write(u6,'(A,f18.1)') 'Total Wall [s] = ',TWall-TWall0 + write(u6,'(A,f18.2)') 'TCpu/TWall [%] = ',100.0_wp*TCpu/(TWall-TWall0) + write(u6,*) + end if + TCpu_l = TCpu + TWall_l = TWall + !mp +end if + +times_parr(:) = times + +#ifdef _MOLCAS_MPP_ + +it1 = NUAB(1)*NOAB(1)+NUAB(2)*NOAB(2) +real_buffer(1) = ccsdt +call gadgop(real_buffer,size(real_buffer),'+') +ccsdt = real_buffer(1) +call gadgop(energ,4,'+') +call gadgop(times_parr,10,'+') + +#endif + +call xflush(u6) + +! Add MPI_Reduce contribution to sorting timing +!mp !cmp call gettim(cpu1,wall1) +!mp !call CWTime(TCpu,TWall) +!mp !times(9) = times(9)+TCpu-TCpu0 +!mp !times(10) = times(10)+TWall-TWall0 + +! T(CCSD) + +if (IUHF == 0) then + energ(2) = energ(1) + energ(4) = energ(3) +end if +tccsd = energ(1)+energ(2)+energ(3)+energ(4) + +!mp !if (IUHF == 0) then ! open-shell stuff +!mp ! call n = noab(1)*nuab(1) +!mp ! t1a(1:n) = t1a(1:n)+t1a(n+1:2*n) +!mp ! ccsdt = Two*ddot_(n,la,1,t1a,1) +!mp !else +!mp ! ccsdt = ddot_(noab(1)*nuab(1)+noab(2)*nuab(2),la,1,t1a,1) +!mp ! write(u6,*) 'ze co do ... ?' +!mp ! stop +!mp !end if + +!mp for MOLCAS verify +call Get_dScalar('SCF energy',e_scf) +call Add_Info('CHT3ene',tccsd+ccsdt,1,6) +call Add_Info('E_CHT3',tccsd+ccsdt,1,6) +call Add_Info('E_HYPE',e_scf+e_ccsd+tccsd+ccsdt,1,6) +! for NUMERICAL_GRADIENTS +call Put_cArray('Relax Method','CHT3 ',8) +call Store_Energies(1,tccsd+ccsdt+e_ccsd+e_scf,1) +!mp + +if (printkey > 1) then + write(u6,*) + write(u6,*) '--------------------------------------------------' + write(u6,*) + write(u6,*) 'GADGOPed energ & ccsdt values: ' + write(u6,*) + write(u6,'(A,4(f15.12,1x))') 'energ (t2-w-t3 = 2*e1 + 2*e3) ',energ + write(u6,*) + write(u6,'(A,f15.12)') 'Sum ',Two*energ(1)+Two*energ(3) + write(u6,'(A,f15.12)') 'ccsdt (e5th ord. ST) ',ccsdt + write(u6,*) + write(u6,*) '--------------------------------------------------' +end if + +! Contents of times array: +! +! CPU WALL +! sorting +! aaa 1 4 +! bbb 2 6 +! aab 3 7 +! bba 4 8 + +! Master has only to sum up the results +times(:) = times/60.0_wp ! now in minutes +if (nprocs > 1) times_parr(:) = times_parr/60.0_wp + +ccsdt4 = Zero +if (ifvo) then + write(u6,*) 'ifvo correspond to open-shell system. Exiting' + call abend() + + !mp !call get3dm('FOC-VO',w(la),noab(1)*nuab(1)+noab(2)*nuab(2),1,0) + !mp !call map2_21_t3(w(la),w(t1a),nuab(1),noab(1)) + !mp !call map2_21_t3(w(noab(1)*nuab(1)+la),w(t1a+noab(1)*nuab(1)),nuab(2),noab(2)) + ! E4 T2FT3 + !mp !if (IUHF == 0) then + !mp ! n = noab(1)*nuab(1) + !mp ! w(t1b:t1b+n-1) = w(t1b:t1b+n-1)+w(t1b+n:n1b+2*n-1) + !mp ! ccsdt4 = Two*ddot_(noab(1)*nuab(1),w(t1a),1,w(t1b),1) + !mp !else + !mp ! ccsdt4 = ddot_(noab(1)*nuab(1)+noab(2)*nuab(2),w(t1a),1,w(t1b),1) + !mp !end if +end if + +!RESULT(IT+3,5) = ccsdt4+ccsdt +if (IT == 0) then + !RESULT(IT+1,5) = tccsd+ccsdt4+ccsdt + if (ifvo) then + write(u6,9993) TCCSD + write(u6,9991) ccsdt4 + write(u6,9990) ccsdt + end if + write(u6,9994) TCCSD+ccsdt+ccsdt4 +else + !RESULT(IT+2,5) = TCCSD + write(u6,9993) TCCSD + if (ifvo) then + write(u6,9991) ccsdt4 + write(u6,9990) ccsdt + write(u6,9995) CCSDT+ccsdt4 + else + write(u6,9995) CCSDT + end if +end if + +write(u6,*) '*************************************************' +write(u6,*) +write(u6,*) 'Final Results : ' +write(u6,*) +write(u6,'(A,f15.12)') ' (T) corr. = ',tccsd+ccsdt +write(u6,'(A,f15.12)') ' CCSD(T) corr. = ',e_ccsd+tccsd+ccsdt +write(u6,*) +write(u6,*) '*************************************************' +write(u6,*) + +! Timing +if (nprocs > 1) write(u6,*) 'Master timings:' +if (times(10) <= Zero) then + timerel = One +else + timerel = times(9)/times(10) +end if +write(u6,'(1x,a,2f13.3,a,f6.3)') 'sorting cpu & wall',times(9),times(10),' (min); cpu/wall=',timerel +if (times(5) <= Zero) then + timerel = One +else + timerel = times(1)/times(5) +end if +write(u6,'(1x,a,2f13.3,a,f6.3)') 'aaa cpu & wall',times(1),times(5),' (min); cpu/wall=',timerel +if (times(6) <= Zero) then + timerel = One +else + timerel = times(2)/times(6) +end if +if (IUHF /= 0) write(u6,'(1x,a,2f13.3,a,f6.3)') 'bbb cpu & wall',times(2),times(6),' (min); cpu/wall=',timerel +if (times(7) <= Zero) then + timerel = One +else + timerel = times(3)/times(7) +end if +write(u6,'(1x,a,2f13.3,a,f6.3)') 'aab cpu & wall',times(3),times(7),' (min); cpu/wall=',timerel +if (times(8) <= Zero) then + timerel = One +else + timerel = times(4)/times(8) +end if +if (IUHF /= 0) write(u6,'(1x,a,2f13.3,a,f6.3)') 'bba cpu & wall',times(4),times(8),' (min); cpu/wall=',timerel +totcpu = times(9) +totwal = times(10) +do i=1,4 + totcpu = totcpu+times(i) + totwal = totwal+times(4+i) +end do +if (totwal <= Zero) then + timerel = One +else + timerel = totcpu/totwal +end if +write(u6,'(1x,a,2f13.3,a,f6.3)') 'total cpu & wall',totcpu,totwal,' (min); cpu/wall=',timerel + +if (nprocs > 1) then + ! Parallel timing + totcpu = times_parr(9) + totwal = times_parr(10) + times(9) = times_parr(9) + do i=1,4 + totcpu = totcpu+times_parr(i) + totwal = totwal+times_parr(4+i) + end do + if (totwal <= Zero) then + timerel = One + else + timerel = totcpu/totwal + end if + write(u6,*) + write(u6,*) 'Aggregate parallel timings:' + write(u6,'(1x,a,2f13.3,a,f6.3)') 'total cpu & wall',totcpu,totwal,' (min); cpu/wall=',timerel +end if + +! Return +!mp call w_debug(.false.,.false.,'Triply done') +!? nprocs = nprocs0 + +call mma_deallocate(la) +call mma_deallocate(tmp) +call mma_deallocate(t1a) +call mma_deallocate(t1b) + +return + +9993 format(/1X,'T2-W-T3 contribution from current amplitudes ',D18.10) +9991 format(1X,'T2-F-T3 contribution from current amplitudes ',D18.10) +9990 format(1X,'T1-W-T3 contribution from current amplitudes ',D18.10) +9994 format(/1X,'4th order MBPT tripleexcitation contribution ',D18.10) +9995 format(/1X,'5th order noniterative E[5] ST correction ',D18.10/) + +end subroutine T3AMPL_BTI diff -Nru openmolcas-22.02/src/cht3/t3_bta_aac.f openmolcas-22.10/src/cht3/t3_bta_aac.f --- openmolcas-22.02/src/cht3/t3_bta_aac.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/t3_bta_aac.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,193 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine t3_bta_aac(nuga,nugc,kab,kca,kac,kc,la,lxa,lxc,mi,mij, - $adim,cdim,N,noab_a,nuab_a,noab_b,nuab_b,lu,iasblock,nga,ngc, - $oehi,oehk,oepa,oepc,enx,vab,vca,t1aa,t1ba,t1ac,t1bc,t3a,t3b,ifvo) - implicit none - real*8 one,zero,den,dena,denb,denc,enx,xx,yy - parameter (one=1.d0,zero=0.d0) - integer nadim,adim,ncdim,cdim,i,j,k,iasblock(5),lu(6),N - integer noab_a,nuab_a,noab_b,nuab_b,nuga,nno_a,nnoab,nugc, - $ngab_offset,ngca_offset,ngac_offset,nuga_offset,nugc_offset - integer ias,jk,ij,ik,kj,ki,nga,ngc,a,b,c,ab,abb,bab - integer iasabi,iascai,iasack - real*8 kca(adim*cdim,N,*),kac(adim*cdim,N,*) - $,kab(adim*(adim-1)/2,N,*) - $,kc(*),la(N*adim,*),lxa(N*adim,*),lxc(N*cdim,*) - real*8 t3a(*),t3b(*) - real*8 mi(cdim*adim*(adim-1)/2,*),mij(*), - $ vab(adim*(adim-1)/2,*),vca(adim*cdim,*) - real*8 t1aa(noab_a,*),t1ba(noab_a,*),t1ac(noab_b,*),t1bc(noab_b,*) - real*8 oehi(*),oehk(*),oepa(*),oepc(*) - logical ifvo -C -C iasblock(1) > ka,kb,kc iasblock(2) > la,lb iasblock(3) > lxa,lxc,lxb - if(adim.eq.1)return - nno_a=noab_a*(noab_a-1)/2 - nnoab=noab_a*noab_b - nadim=adim*(adim-1)/2 - ncdim=adim*cdim - nuga_offset=iasblock(1)*nuga*(nuga+1)/2 - nugc_offset=iasblock(1)*nuga*nugc - ias=iasblock(2)*(nga-1)+1 - call multi_readir(la,nno_a*adim*N,lu(2),ias) - ias=iasblock(3)*(nga-1)+1 - call multi_readir(lxa,nnoab*adim*N,lu(5),ias) - ias=iasblock(3)*(ngc-1)+1 - call multi_readir(lxc,nnoab*cdim*N,lu(6),ias) -C vvoo ints reading - ngab_offset=iasblock(4)*(nga*(nga-1)/2+nga-1)+1 - ias=iasblock(2)*nuga+ngab_offset - call multi_readir(vab,nno_a*nadim,lu(2),ias) - ngca_offset=iasblock(5)*(nugc*(nga-1)+ngc-1)+1 - ias=iasblock(2)*nuga+iasblock(4)*nuga*(nuga+1)/2+ngca_offset - call multi_readir(vca,nnoab*adim*cdim,lu(2),ias) -!! ngac_offset=iasblock(5)*(nuga*(ngc-1)+nga-1)+1 -C end readin vvoo ints - ngab_offset=iasblock(1)*(nga*(nga-1)/2+nga-1)+1 - ngac_offset=iasblock(1)*(nuga*(ngc-1)+nga-1)+1 - ngca_offset=iasblock(1)*(nugc*(nga-1)+ngc-1)+1 - - do i=1,noab_a - iasabi=(i-1)*nuga_offset+ngab_offset - call multi_readir(kab(1,1,i),N*nadim,lu(1),iasabi) - enddo - do i=1,noab_a - iascai=(i-1)*nugc_offset+ngca_offset - call multi_readir(kca(1,1,i),N*ncdim,lu(3),iascai) - enddo - do k=1,noab_b - do i=1,noab_a - ik=(k-1)*noab_a +i - ki=(i-1)*noab_b +k -C K_ab^ir x L_rc^ik cba - call DGEMM_('T','T',cdim,nadim,N,one,lxc(1,ik),N,kab(1,1,i),nadim, - $ zero,mi(1,i),cdim) -C -C K_ac^ir x L_rb^ki cab - call DGEMM_('N','N',ncdim,adim,N,one,kca(1,1,i),ncdim,lxa(1,ki),N, - $ zero,t3b,ncdim) - ab=1 - do a=2,adim - abb=(a-1)*cdim+1 - bab=(a-1)*ncdim+1 - do b=1,a-1 - call daxpy_(cdim,-1.d0,t3b(abb),1,mi(ab,i),1) - call daxpy_(cdim,1.d0,t3b(bab),1,mi(ab,i),1) - ab=ab+cdim - abb=abb+ncdim - bab=bab+cdim - enddo - enddo - enddo ! i -! end prefactors - iasack=(k-1)*nugc_offset+ngac_offset - call multi_readir(kac,N*ncdim,lu(4),iasack) - ij=0 - do i=2,noab_a - ki=(i-1)*noab_b +k - ik=(k-1)*noab_a +i - kj=k-noab_b - jk=(k-1)*noab_a - do j=1,i-1 - ij=ij+1 - kj=kj+noab_b - jk=jk+1 -C K_bc^kr x L_ra^ij - call DGEMM_('N','N',ncdim,adim,N,one,kac,ncdim,la(1,ij),N, - $ zero,t3a,ncdim) -C transpose the first two inicesd - ab=1 - do a=1,adim - call transm(t3a(ab),t3b(ab),adim,cdim) - ab=ab+ncdim - enddo -C K_ab^ir x L_rc^jk -K_ab^jr x L_rc^ik - call vsub(kab(1,1,j),1,kab(1,1,i),1,kc,1,N*nadim) - call vadd(lxc(1,jk),1,lxc(1,ik),1,mij,1,N*cdim) - call DGEMM_('T','T',cdim,nadim,N,one,mij,N,kc,nadim, - $ zero,t3a,cdim) -C K_ab^ir x L_rc^jk -!! call DGEMM_('T','T',cdim,nadim,N,one,lxc(1,jk),N,ka,nadim, -!! $ zero,t3a,cdim) -C -K_ab^jr x L_rc^ik -!! call DGEMM_('T','T',cdim,nadim,N,-one,lxc(1,ik),N,kb,nadim, -!! $ one,t3a,cdim) -C -C K_bc^ir x L_ra^kj -K_bc^jr x L_ra^ki - call vsub(kca(1,1,j),1,kca(1,1,i),1,kc,1,N*ncdim) - call vadd(lxa(1,kj),1,lxa(1,ki),1,mij,1,N*adim) - call DGEMM_('N','N',ncdim,adim,N,one,kc,ncdim,mij,N, - $ one,t3b,ncdim) -C K_bc^ir x L_ra^kj -!! call DGEMM_('N','N',ncdim,adim,N,one,ka,ncdim,lxa(1,kj),N, -!! $ one,t3b,ncdim) -C -K_bc^jr x L_ra^ki -!! call DGEMM_('N','N',ncdim,adim,N,-one,kb,ncdim,lxa(1,ki),N, -!! $ one,t3b,ncdim) - ab=1 - do a=2,adim - abb=(a-1)*cdim+1 - bab=(a-1)*ncdim+1 - do b=1,a-1 - call daxpy_(cdim,-1.d0,t3b(abb),1,t3a(ab),1) - call daxpy_(cdim,1.d0,t3b(bab),1,t3a(ab),1) - ab=ab+cdim - abb=abb+ncdim - bab=bab+cdim - enddo - enddo -!! - call daxpy_(nadim*cdim,-1.d0,mi(1,i),1,t3a,1) - call daxpy_(nadim*cdim,1.d0,mi(1,j),1,t3a,1) - den=oehi(i)+oehi(j)+oehk(k) - ab=0 - do a=2,adim - dena=den-oepa(a) - do b=1,a-1 - denb=dena-oepa(b) - do c=1,cdim - denc=denb-oepc(c) - ab=ab+1 - xx=t3a(ab) - yy=xx/denc - enx=enx+yy*xx - t3a(ab)=yy -!! t1aa(j,a)=t1aa(j,a)-yy*vca((a-1)*cdim+c,ki) - enddo - enddo - enddo - call expa2_uhf(t3a,cdim,adim,-1,t3b) - call DGEMM_('N','T',1,cdim,nadim, one,vab(1,ij),1, - $ t3a,cdim,one,t1ac(k,1),noab_b) - call DGEMM_('N','N',1,adim,ncdim, one,vca(1,kj),1, - $ t3b,ncdim,one,t1aa(i,1),noab_a) - call DGEMM_('N','N',1,adim,ncdim,-one,vca(1,ki),1, - $ t3b,ncdim,one,t1aa(j,1),noab_a) -C ccsd(T) part t2*t3 - if(ifvo) then - call DGEMM_('N','T',1,cdim,nadim, one,kab(1,i,j),1, - $ t3a,cdim,one,t1bc(k,1),noab_b) - call DGEMM_('N','N',1,adim,ncdim,-one,kca(1,k,j),1, - $ t3b,ncdim,one,t1ba(i,1),noab_a) - call DGEMM_('N','N',1,adim,ncdim, one,kca(1,k,i),1, - $ t3b,ncdim,one,t1ba(j,1),noab_a) - endif - enddo !j - enddo !i - enddo !k - return -c Avoid unused argument warnings - if (.false.) then - call Unused_integer(nuab_a) - call Unused_integer(nuab_b) - end if - end diff -Nru openmolcas-22.02/src/cht3/t3_bta_aac.F90 openmolcas-22.10/src/cht3/t3_bta_aac.F90 --- openmolcas-22.02/src/cht3/t3_bta_aac.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/t3_bta_aac.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,173 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine t3_bta_aac(nuga,nugc,kab,kca,kac,kc,la,lxa,lxc,mi,mij,adim,cdim,N,noab_a,noab_b,lu,iasblock,nga,ngc,oehi,oehk,oepa, & + oepc,enx,vab,vca,t1aa,t1ba,t1ac,t1bc,t3a,t3b,ifvo) + +use Index_Functions, only: nTri_Elem +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: nuga, nugc, adim, cdim, N, noab_a, noab_b, lu(6), iasblock(5), nga, ngc +real(kind=wp), intent(_OUT_) :: kab(nTri_Elem(adim-1),N,*), kca(adim*cdim,N,*), kac(adim*cdim,N,*), kc(*), la(N*adim,*), & + lxa(N*adim,*), lxc(N*cdim,*), mi(cdim*nTri_Elem(adim-1),*), mij(*), vab(nTri_Elem(adim-1),*), & + vca(adim*cdim,*), t3a(*), t3b(*) +real(kind=wp), intent(in) :: oehi(*), oehk(*), oepa(*), oepc(*) +real(kind=wp), intent(inout) :: enx, t1aa(noab_a,*), t1ba(noab_a,*), t1ac(noab_b,*), t1bc(noab_b,*) +logical(kind=iwp), intent(in) :: ifvo +integer(kind=iwp) :: a, ab, abb, b, bab, c, i, ias, iasabi, iasack, iascai, ij, ik, j, jk, k, ki, kj, nadim, ncdim, ngab_offset, & + ngac_offset, ngca_offset, nno_a, nnoab, nuga_offset, nugc_offset +real(kind=wp) :: den, dena, denb, denc, xx, yy + +! iasblock(1) > ka,kb,kc iasblock(2) > la,lb iasblock(3) > lxa,lxc,lxb +if (adim == 1) return +nno_a = nTri_Elem(noab_a-1) +nnoab = noab_a*noab_b +nadim = nTri_Elem(adim-1) +ncdim = adim*cdim +nuga_offset = iasblock(1)*nTri_Elem(nuga) +nugc_offset = iasblock(1)*nuga*nugc +ias = iasblock(2)*(nga-1)+1 +call multi_readir(la,nno_a*adim*N,lu(2),ias) +ias = iasblock(3)*(nga-1)+1 +call multi_readir(lxa,nnoab*adim*N,lu(5),ias) +ias = iasblock(3)*(ngc-1)+1 +call multi_readir(lxc,nnoab*cdim*N,lu(6),ias) +! vvoo ints reading +ngab_offset = iasblock(4)*(nTri_Elem(nga-1)+nga-1)+1 +ias = iasblock(2)*nuga+ngab_offset +call multi_readir(vab,nno_a*nadim,lu(2),ias) +ngca_offset = iasblock(5)*(nugc*(nga-1)+ngc-1)+1 +ias = iasblock(2)*nuga+iasblock(4)*nTri_Elem(nuga)+ngca_offset +call multi_readir(vca,nnoab*adim*cdim,lu(2),ias) +!!ngac_offset = iasblock(5)*(nuga*(ngc-1)+nga-1)+1 +! end readin vvoo ints +ngab_offset = iasblock(1)*(nTri_Elem(nga-1)+nga-1)+1 +ngac_offset = iasblock(1)*(nuga*(ngc-1)+nga-1)+1 +ngca_offset = iasblock(1)*(nugc*(nga-1)+ngc-1)+1 + +do i=1,noab_a + iasabi = (i-1)*nuga_offset+ngab_offset + call multi_readir(kab(:,:,i),N*nadim,lu(1),iasabi) +end do +do i=1,noab_a + iascai = (i-1)*nugc_offset+ngca_offset + call multi_readir(kca(:,:,i),N*ncdim,lu(3),iascai) +end do +do k=1,noab_b + do i=1,noab_a + ik = (k-1)*noab_a+i + ki = (i-1)*noab_b+k + ! K_ab^ir x L_rc^ik cba + call DGEMM_('T','T',cdim,nadim,N,one,lxc(:,ik),N,kab(:,:,i),nadim,zero,mi(:,i),cdim) + + ! K_ac^ir x L_rb^ki cab + call DGEMM_('N','N',ncdim,adim,N,one,kca(:,:,i),ncdim,lxa(:,ki),N,zero,t3b,ncdim) + ab = 1 + do a=2,adim + abb = (a-1)*cdim+1 + bab = (a-1)*ncdim+1 + do b=1,a-1 + mi(ab:ab+cdim-1,i) = mi(ab:ab+cdim-1,i)-t3b(abb:abb+cdim-1)+t3b(bab:bab+cdim-1) + ab = ab+cdim + abb = abb+ncdim + bab = bab+cdim + end do + end do + end do ! i + ! end prefactors + iasack = (k-1)*nugc_offset+ngac_offset + call multi_readir(kac,N*ncdim,lu(4),iasack) + ij = 0 + do i=2,noab_a + ki = (i-1)*noab_b+k + ik = (k-1)*noab_a+i + kj = k-noab_b + jk = (k-1)*noab_a + do j=1,i-1 + ij = ij+1 + kj = kj+noab_b + jk = jk+1 + ! K_bc^kr x L_ra^ij + call DGEMM_('N','N',ncdim,adim,N,one,kac,ncdim,la(:,ij),N,zero,t3a,ncdim) + ! transpose the first two inicesd + ab = 1 + do a=1,adim + call map2_21_t3(t3a(ab),t3b(ab),adim,cdim) + ab = ab+ncdim + end do + ! K_ab^ir x L_rc^jk -K_ab^jr x L_rc^ik + kc(1:N*nadim) = pack(kab(:,:,i)-kab(:,:,j),.true.) + mij(1:N*cdim) = lxc(:,jk)+lxc(:,ik) + call DGEMM_('T','T',cdim,nadim,N,one,mij,N,kc,nadim,zero,t3a,cdim) + ! K_ab^ir x L_rc^jk + !!call DGEMM_('T','T',cdim,nadim,N,one,lxc(1,jk),N,ka,nadim,zero,t3a,cdim) + ! -K_ab^jr x L_rc^ik + !!call DGEMM_('T','T',cdim,nadim,N,-one,lxc(1,ik),N,kb,nadim,one,t3a,cdim) + + ! K_bc^ir x L_ra^kj -K_bc^jr x L_ra^ki + kc(1:N*ncdim) = pack(kca(:,:,i)-kca(:,:,j),.true.) + mij(1:N*adim) = lxa(:,kj)+lxa(:,ki) + call DGEMM_('N','N',ncdim,adim,N,one,kc,ncdim,mij,N,one,t3b,ncdim) + ! K_bc^ir x L_ra^kj + !!call DGEMM_('N','N',ncdim,adim,N,one,ka,ncdim,lxa(1,kj),N,one,t3b,ncdim) + ! -K_bc^jr x L_ra^ki + !!call DGEMM_('N','N',ncdim,adim,N,-one,kb,ncdim,lxa(1,ki),N,one,t3b,ncdim) + ab = 1 + do a=2,adim + abb = (a-1)*cdim+1 + bab = (a-1)*ncdim+1 + do b=1,a-1 + t3a(ab:ab+cdim-1) = t3a(ab:ab+cdim-1)-t3b(abb:abb+cdim-1)+t3b(bab:bab+cdim-1) + ab = ab+cdim + abb = abb+ncdim + bab = bab+cdim + end do + end do + + t3a(1:nadim*cdim) = t3a(1:nadim*cdim)-mi(:,i)+mi(:,j) + den = oehi(i)+oehi(j)+oehk(k) + ab = 0 + do a=2,adim + dena = den-oepa(a) + do b=1,a-1 + denb = dena-oepa(b) + do c=1,cdim + denc = denb-oepc(c) + ab = ab+1 + xx = t3a(ab) + yy = xx/denc + enx = enx+yy*xx + t3a(ab) = yy + !! t1aa(j,a) = t1aa(j,a)-yy*vca((a-1)*cdim+c,ki) + end do + end do + end do + call expa2_uhf(t3a,cdim,adim,-1,t3b) + call DGEMM_('N','T',1,cdim,nadim,one,vab(:,ij),1,t3a,cdim,one,t1ac(k,1),noab_b) + call DGEMM_('N','N',1,adim,ncdim,one,vca(:,kj),1,t3b,ncdim,one,t1aa(i,1),noab_a) + call DGEMM_('N','N',1,adim,ncdim,-one,vca(:,ki),1,t3b,ncdim,one,t1aa(j,1),noab_a) + ! ccsd(T) part t2*t3 + if (ifvo) then + call DGEMM_('N','T',1,cdim,nadim,one,kab(:,i,j),1,t3a,cdim,one,t1bc(k,1),noab_b) + call DGEMM_('N','N',1,adim,ncdim,-one,kca(:,k,j),1,t3b,ncdim,one,t1ba(i,1),noab_a) + call DGEMM_('N','N',1,adim,ncdim,one,kca(:,k,i),1,t3b,ncdim,one,t1ba(j,1),noab_a) + end if + end do !j + end do !i +end do !k + +return + +end subroutine t3_bta_aac diff -Nru openmolcas-22.02/src/cht3/t3_bt_aaa.f openmolcas-22.10/src/cht3/t3_bt_aaa.f --- openmolcas-22.02/src/cht3/t3_bt_aaa.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/t3_bt_aaa.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,110 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine t3_bt_aaa(nug,ka,kb,kc,la,mi,mij,adim,N,noab, - $nuab,nnoab,lu,iasblock,nga,oeh,oep,enx,voa,t1a,t1b,t3a,t3b,ifvo) - implicit none - real*8 one,zero - parameter (one=1.d0,zero=0.d0) - integer a,b,c,aa,ab,bc,ac - real*8 XX,YY,enx,den,dena,denb,denc - integer ndim,adim,noab,nuab,i,j,k,nga,iasblock(3),lu(2),N - integer ias,nga_offset,nug_offset,jk,ij,ik,nug,nnoab - logical ifvo - real*8 ka(adim*(adim-1)/2,N,*),kb(*),kc(*) - real*8 la(N*adim,nnoab),mi(*),mij(*) -!! real*8 lb(N,adim,nnoab),lc(N,adim,nnoab) - real*8 t3a(adim*(adim-1)/2,adim),t3b(adim*(adim-1)/2,adim) -!! real*8 mi(adim*(adim-1)/2,adim,noab),mij(*) - real*8 voa(adim*(adim-1)/2,nnoab) - real*8 t1a(noab,*),t1b(noab,*),oeh(noab),oep(adim) -C - if(adim.eq.1)return -cmp write(6,*)'enter_aaa enx,nga,',nga,enx - ndim=adim*(adim-1)/2 - call zeroma(t3b,1,ndim*adim) - nug_offset=iasblock(1)*nug*(nug+1)/2 - ias=iasblock(2)*(nga-1)+1 - call multi_readir(la,nnoab*adim*N,lu(2),ias) - ias=iasblock(2)*nug+iasblock(3)*(nga*(nga+1)/2-1)+1 - call multi_readir(voa,nnoab*ndim,lu(2),ias) -C - nga_offset=iasblock(1)*(nga*(nga+1)/2-1)+1 - do i=1,noab - ias=(i-1)*nug_offset+nga_offset - call multi_readir(ka(1,1,i),N*ndim,lu(1),ias) - enddo - do i=3,noab - jk=0 - do j=2,i-1 - ij=(i-1)*(i-2)/2+j - ik=(i-1)*(i-2)/2 - do k=1,j-1 - jk=jk+1 - ik=ik+1 -C K_ab^ir x L_rc^jk - call DGEMM_('N','N',ndim,adim,N,one,ka(1,1,i),ndim,la(1,jk),N, - $ zero,t3a,ndim) -C K_ab^kr x L_rc^ij - call DGEMM_('N','N',ndim,adim,N,one,ka(1,1,k),ndim,la(1,ij),N, - $ one,t3a,ndim) -C -K_ab^jr x L_rc^ik - call DGEMM_('N','N',ndim,adim,N,-one,ka(1,1,j),ndim,la(1,ik),N, - $ one,t3a,ndim) - den=oeh(i)+oeh(j)+oeh(k) - do a=3,adim - aa=(a-1)*(a-2)/2 - dena=den-oep(a) - bc=0 - do b=2,a-1 - denb=dena-oep(b) - ab=aa+b - do c=1,b-1 - bc=bc+1 - denc=denb-oep(c) - ac=aa+c - xx=t3a(ab,c)+t3a(bc,a)-t3a(ac,b) - yy=xx/denc - enx=enx+yy*xx - t3b(ab,c)=yy - t3b(bc,a)=yy - t3b(ac,b)=-yy - enddo - enddo - enddo -C ccsd(T) part vvoo*t3 - call DGEMM_('N','N',1,adim,ndim,one,voa(1,ij),1, - $ t3b,ndim,one,t1a(k,1),noab) - call DGEMM_('N','N',1,adim,ndim,one,voa(1,jk),1, - $ t3b,ndim,one,t1a(i,1),noab) - call DGEMM_('N','N',1,adim,ndim,-one,voa(1,ik),1, - $ t3b,ndim,one,t1a(j,1),noab) -C ccsd(T) part t2*t3 - if(ifvo) then - call DGEMM_('N','N',1,adim,ndim,one,ka(1,i,j),1, - $ t3b,ndim,one,t1b(k,1),noab) - call DGEMM_('N','N',1,adim,ndim,one,ka(1,j,k),1, - $ t3b,ndim,one,t1b(i,1),noab) - call DGEMM_('N','N',1,adim,ndim,-one,ka(1,i,k),1, - $ t3b,ndim,one,t1b(j,1),noab) - endif - enddo !k - enddo !j - enddo !i - return -c Avoid unused argument warnings - if (.false.) then - call Unused_real_array(kb) - call Unused_real_array(kc) - call Unused_real_array(mi) - call Unused_real_array(mij) - call Unused_integer(nuab) - end if - end diff -Nru openmolcas-22.02/src/cht3/t3_bt_aaa.F90 openmolcas-22.10/src/cht3/t3_bt_aaa.F90 --- openmolcas-22.02/src/cht3/t3_bt_aaa.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/t3_bt_aaa.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,94 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine t3_bt_aaa(nug,ka,la,adim,N,noab,nnoab,lu,iasblock,nga,oeh,oep,enx,voa,t1a,t1b,t3a,t3b,ifvo) + +use Index_Functions, only: nTri_Elem +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nug, adim, N, noab, nnoab, lu(2), iasblock(3), nga +real(kind=wp), intent(out) :: ka(nTri_Elem(adim-1),N,noab), la(N*adim,nnoab), voa(nTri_Elem(adim-1),nnoab), & + t3a(nTri_Elem(adim-1),adim), t3b(nTri_Elem(adim-1),adim) +real(kind=wp), intent(in) :: oeh(noab), oep(adim) +real(kind=wp), intent(inout) :: enx, t1a(noab,*), t1b(noab,*) +logical(kind=iwp), intent(in) :: ifvo +integer(kind=iwp) :: a, aa, ab, ac, b, bc, c, i, ias, ij, ik, j, jk, k, ndim, nga_offset, nug_offset +real(kind=wp) :: den, dena, denb, denc, XX, YY + +if (adim == 1) return +!mp write(u6,*) 'enter_aaa enx,nga,',nga,enx +ndim = nTri_Elem(adim-1) +t3b(:,:) = Zero +nug_offset = iasblock(1)*nTri_Elem(nug) +ias = iasblock(2)*(nga-1)+1 +call multi_readir(la,nnoab*adim*N,lu(2),ias) +ias = iasblock(2)*nug+iasblock(3)*(nTri_Elem(nga)-1)+1 +call multi_readir(voa,nnoab*ndim,lu(2),ias) + +nga_offset = iasblock(1)*(nTri_Elem(nga)-1)+1 +do i=1,noab + ias = (i-1)*nug_offset+nga_offset + call multi_readir(ka(:,:,i),N*ndim,lu(1),ias) +end do +do i=3,noab + jk = 0 + do j=2,i-1 + ij = nTri_Elem(i-2)+j + ik = nTri_Elem(i-2) + do k=1,j-1 + jk = jk+1 + ik = ik+1 + ! K_ab^ir x L_rc^jk + call DGEMM_('N','N',ndim,adim,N,one,ka(:,:,i),ndim,la(:,jk),N,zero,t3a,ndim) + ! K_ab^kr x L_rc^ij + call DGEMM_('N','N',ndim,adim,N,one,ka(:,:,k),ndim,la(:,ij),N,one,t3a,ndim) + ! -K_ab^jr x L_rc^ik + call DGEMM_('N','N',ndim,adim,N,-one,ka(:,:,j),ndim,la(:,ik),N,one,t3a,ndim) + den = oeh(i)+oeh(j)+oeh(k) + do a=3,adim + aa = nTri_Elem(a-2) + dena = den-oep(a) + bc = 0 + do b=2,a-1 + denb = dena-oep(b) + ab = aa+b + do c=1,b-1 + bc = bc+1 + denc = denb-oep(c) + ac = aa+c + xx = t3a(ab,c)+t3a(bc,a)-t3a(ac,b) + yy = xx/denc + enx = enx+yy*xx + t3b(ab,c) = yy + t3b(bc,a) = yy + t3b(ac,b) = -yy + end do + end do + end do + ! ccsd(T) part vvoo*t3 + call DGEMM_('N','N',1,adim,ndim,one,voa(:,ij),1,t3b,ndim,one,t1a(k,1),noab) + call DGEMM_('N','N',1,adim,ndim,one,voa(:,jk),1,t3b,ndim,one,t1a(i,1),noab) + call DGEMM_('N','N',1,adim,ndim,-one,voa(:,ik),1,t3b,ndim,one,t1a(j,1),noab) + ! ccsd(T) part t2*t3 + if (ifvo) then + call DGEMM_('N','N',1,adim,ndim,one,ka(:,i,j),1,t3b,ndim,one,t1b(k,1),noab) + call DGEMM_('N','N',1,adim,ndim,one,ka(:,j,k),1,t3b,ndim,one,t1b(i,1),noab) + call DGEMM_('N','N',1,adim,ndim,-one,ka(:,i,k),1,t3b,ndim,one,t1b(j,1),noab) + end if + end do !k + end do !j +end do !i + +return + +end subroutine t3_bt_aaa diff -Nru openmolcas-22.02/src/cht3/t3_bta_abc.f openmolcas-22.10/src/cht3/t3_bta_abc.f --- openmolcas-22.02/src/cht3/t3_bta_abc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/t3_bta_abc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,290 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine t3_bta_abc(nuga,nugc,kab,kcb,kca,kac,kbc,kc,la,lb,lxa, - $lxb,lxc,mi,mij,adim,bdim,cdim,N,noab_a,nuab_a,noab_b,nuab_b,lu, - $iasblock,nga,ngb,ngc,oehi,oehk,oepa,oepb,oepc,enx,vab,vcb,vca, - $t1aa,t1ba,t1ab,t1bb,t1ac,t1bc,t3a,t3b,ifvo) - implicit none -cmp -c integer imm -cmp - real*8 one,zero,den,dena,denb,denc,enx,xx,yy -c real*8 sumt3 - parameter (one=1.d0,zero=0.d0) - integer nadim,adim,ncdim,cdim,bdim,nbdim,i,j,k,iasblock(5),lu(6),N - integer noab_a,nuab_a,noab_b,nuab_b,nuga,nno_a,nnoab,nugc, - $ngab_offset,ngca_offset,ngac_offset,nuga_offset,nugc_offset, - $ngcb_offset,ngbc_offset - integer ias,jk,ij,ik,kj,ki,nga,ngb,ngc,a,b,c,ab,ba - integer iasabi,iascai,iasack,iascbi,iasbck - real*8 kab(adim*bdim,N,*),kcb(cdim*bdim,N,*),kca(cdim*adim,N,*) - $,kac(cdim*adim,N),kbc(cdim*bdim,N),kc(*),lxb(N*bdim,*) - real*8 la(N*adim,*),lb(N*bdim,*),lxa(N*adim,*),lxc(N*cdim,*), - $t3a(*),t3b(*),vab(adim*bdim,*),vca(adim*cdim,*),vcb(bdim*cdim,*) - real*8 mi(adim*bdim*cdim,*),mij(*) - real*8 t1aa(noab_a,*),t1ba(noab_a,*),t1ac(noab_b,*) - $ ,t1bc(noab_b,*),t1ab(noab_a,*),t1bb(noab_a,*) - real*8 oehi(*),oehk(*),oepa(*),oepb(*),oepc(*) - logical ifvo -cmp -c -C iasblock(1) > ka,kb,kc iasblock(2) > la,lb iasblock(3) > lxa,lxc,lxb -!! sumt3=0.d0 - nno_a=noab_a*(noab_a-1)/2 - nnoab=noab_a*noab_b - nadim=adim*bdim - nbdim=bdim*cdim - ncdim=adim*cdim - nuga_offset=iasblock(1)*nuga*(nuga+1)/2 - nugc_offset=iasblock(1)*nuga*nugc - ias=iasblock(2)*(nga-1)+1 - call multi_readir(la,nno_a*adim*N,lu(2),ias) - ias=iasblock(2)*(ngb-1)+1 - call multi_readir(lb,nno_a*bdim*N,lu(2),ias) - ias=iasblock(3)*(nga-1)+1 - call multi_readir(lxa,nnoab*adim*N,lu(5),ias) - ias=iasblock(3)*(ngb-1)+1 - call multi_readir(lxb,nnoab*bdim*N,lu(5),ias) - ias=iasblock(3)*(ngc-1)+1 - call multi_readir(lxc,nnoab*cdim*N,lu(6),ias) -C -C vvoo ints reading - ngab_offset=iasblock(4)*(nga*(nga-1)/2+ngb-1)+1 - ias=iasblock(2)*nuga+ngab_offset - call multi_readir(vab,nno_a*nadim,lu(2),ias) - ngca_offset=iasblock(5)*(nugc*(nga-1)+ngc-1)+1 - ias=iasblock(2)*nuga+iasblock(4)*nuga*(nuga+1)/2+ngca_offset - call multi_readir(vca,nnoab*ncdim,lu(2),ias) - ngcb_offset=iasblock(5)*(nugc*(ngb-1)+ngc-1)+1 - ias=iasblock(2)*nuga+iasblock(4)*nuga*(nuga+1)/2+ngcb_offset - call multi_readir(vcb,nnoab*nbdim,lu(2),ias) -C end readin vvoo ints -C - ngab_offset=iasblock(1)*(nga*(nga-1)/2+ngb-1)+1 - ngac_offset=iasblock(1)*(nuga*(ngc-1)+nga-1)+1 - ngbc_offset=iasblock(1)*(nuga*(ngc-1)+ngb-1)+1 - ngca_offset=iasblock(1)*(nugc*(nga-1)+ngc-1)+1 - ngcb_offset=iasblock(1)*(nugc*(ngb-1)+ngc-1)+1 -C saves reading: - do i=1,noab_a - iasabi=(i-1)*nuga_offset+ngab_offset - call multi_readir(kab(1,1,i),N*nadim,lu(1),iasabi) - enddo - do i=1,noab_a - iascai=(i-1)*nugc_offset+ngca_offset - call multi_readir(kca(1,1,i),N*ncdim,lu(3),iascai) -cmp -cmp write (*,*) 'ze tak teraz ju dam',i -cmp call check_mat(kca(1,1,i),1,N*ncdim) -cmp - enddo - do i=1,noab_a - iascbi=(i-1)*nugc_offset+ngcb_offset - call multi_readir(kcb(1,1,i),N*nbdim,lu(3),iascbi) - enddo - do k=1,noab_b - iasbck=(k-1)*nugc_offset+ngbc_offset - call multi_readir(kbc,N*nbdim,lu(4),iasbck) - iasack=(k-1)*nugc_offset+ngac_offset - call multi_readir(kac,N*ncdim,lu(4),iasack) -C start calculating prefactors: -cmp - do i=1,noab_a - ik=(k-1)*noab_a +i - ki=(i-1)*noab_b +k -cmp -C K_ab^ir x L_rc^ik cba - call DGEMM_('T','T',cdim,nadim,N,one,lxc(1,ik),N, - & kab(1,1,i),nadim, - $ zero,mi(1,i),cdim) -C K_bc^ir x L_ra^ki cba - call DGEMM_('N','N',nbdim,adim,N,one,kcb(1,1,i),nbdim, - & lxa(1,ki),N, - $ one ,mi(1,i),nbdim) -cmp -cmp do imm=0,adim*nbdim-1 -cmp if (abs(mi(1+imm,i)).gt.10000) then -cmp write (*,*) 'uz mi dojebane 2',imm+1,i,mi(1+imm,i) -cmp stop -cmp end if -cmp end do -cmp -C -C K_ac^ir x L_rb^ki cab - call DGEMM_('N','N',ncdim,bdim,N,one,kca(1,1,i),ncdim, - & lxb(1,ki),N, - $ zero,t3b,ncdim) -cmp - ab=1 - do a=1,adim - ba=(a-1)*cdim+1 - do b=1,bdim - call daxpy_(cdim,-1.d0,t3b(ba),1,mi(ab,i),1) - ab=ab+cdim - ba=ba+ncdim - enddo - enddo - enddo ! i -cmp -! end prefactors - ij=0 - do i=2,noab_a - ki=(i-1)*noab_b +k - ik=(k-1)*noab_a +i - kj=k-noab_b - jk=(k-1)*noab_a - do j=1,i-1 - ij=ij+1 - kj=kj+noab_b - jk=jk+1 -cmp -C K_ac^kr x L_rb^ij bac - call DGEMM_('T','T',bdim,ncdim,N,-one,lb(1,ij),N,kac,ncdim, - $ zero,t3b,bdim) -C K_bc^kr x L_ra^ij abc - call DGEMM_('T','T',adim,nbdim,N,one,la(1,ij),N,kbc,nbdim, - $ zero,t3a,adim) -C transpose the first two indices -cmp - ab=1 - do c=1,cdim - ba=(c-1)*nadim+1 - do b=1,bdim - call daxpy_(adim,1.d0,t3a(ab),1,t3b(ba),bdim) - ba=ba+1 - ab=ab+adim - enddo - enddo -C t3b bac - call transm(t3b,t3a,nadim,cdim) -C cba in t3a -C K_ab^ir x L_rc^jk -K_ab^jr x L_rc^ik - call vsub(kab(1,1,j),1,kab(1,1,i),1,kc,1,N*nadim) -C call daxpy_(N*nadim,-one,kb,1,ka,1) - call vadd(lxc(1,jk),1,lxc(1,ik),1,mij,1,N*cdim) - call DGEMM_('T','T',cdim,nadim,N,one,mij,N,kc,nadim, - $ one,t3a,cdim) -C K_ab^ir x L_rc^jk -!! call DGEMM_('T','T',cdim,nadim,N,one,lxc(1,jk),N,ka,nadim, -!! $ one,t3a,cdim) -C -K_ab^jr x L_rc^ik -!! call DGEMM_('T','T',cdim,nadim,N,-one,lxc(1,ik),N,kb,nadim, -!! $ one,t3a,cdim) -C -C K_bc^ir x L_ra^kj -K_bc^jr x L_ra^ki cba - call vsub(kcb(1,1,j),1,kcb(1,1,i),1,kc,1,N*nbdim) - call vadd(lxa(1,kj),1,lxa(1,ki),1,mij,1,N*adim) - call DGEMM_('N','N',nbdim,adim,N,one,kc,nbdim,mij,N, - $ one,t3a,nbdim) -C K_bc^ir x L_ra^kj cba -!! call DGEMM_('N','N',nbdim,adim,N,one,ka,nbdim,lxa(1,kj),N, -!! $ one,t3a,nbdim) -C -K_bc^jr x L_ra^ki cba -!! call DGEMM_('N','N',nbdim,adim,N,-one,kb,nbdim,lxa(1,ki),N, -!! $ one,t3a,nbdim) -C K_ac^ir x L_rb^kj -K_ac^jr x L_rb^ki cab - call vsub(kca(1,1,j),1,kca(1,1,i),1,kc,1,N*ncdim) - call vadd(lxb(1,kj),1,lxb(1,ki),1,mij,1,N*bdim) - call DGEMM_('N','N',ncdim,bdim,N,one,kc,ncdim,mij,N, - $ zero,t3b,ncdim) -C K_ac^ir x L_rb^kj cab -!! call DGEMM_('N','N',ncdim,bdim,N,one,ka,ncdim,lxb(1,kj),N, -!! $ zero,t3b,ncdim) -C -K_ac^jr x L_rb^ki cab -!! call DGEMM_('N','N',ncdim,bdim,N,-one,kb,ncdim,lxb(1,ki),N, -!! $ one,t3b,ncdim) -cmp - ab=1 - do a=1,adim - ba=(a-1)*cdim+1 - do b=1,bdim - call daxpy_(cdim,-1.d0,t3b(ba),1,t3a(ab),1) - ab=ab+cdim - ba=ba+ncdim - enddo - enddo -c -cmp do a=1,adim -cmp do b=1,bdim -cmp do c=1,cdim -cmp ab=c+(b-1)*cdim+(a-1)*bdim*cdim -cmp ba=c+(a-1)*cdim+(b-1)*adim*cdim -cmp t3a(ab)=t3a(ab)-t3b(ba) -cmp end do -cmp end do -cmp end do -c -cmp -c - call daxpy_(nadim*cdim,-1.d0,mi(1,i),1,t3a,1) - call daxpy_(nadim*cdim,1.d0,mi(1,j),1,t3a,1) - den=oehi(i)+oehi(j)+oehk(k) - ab=0 - do a=1,adim - ba=ab+1 - dena=den-oepa(a) - do b=1,bdim - denb=dena-oepb(b) - do c=1,cdim - denc=denb-oepc(c) - ab=ab+1 -cmp if ((i.eq.14).and.(j.eq.1).and.(k.eq.1)) then -cmp write (*,'(A,3(i5,x),3(f18.10,x))') -cmp & 'a,b,c, oepa(a), oepb(b), oepc(c)', -cmp & a,b,c,oepa(a),oepb(b),oepc(c) -cmp write (*,*) 'denc = ',denc -cmp write (*,*) 'ab, t3a(ab) ',ab,t3a(ab) -cmp end if - xx=t3a(ab) - yy=xx/denc -!! sumt3=sumt3+xx - enx=enx+yy*xx -cmp if ((i.eq.14).and.(j.eq.1).and.(k.eq.1)) then -cmp write (*,'(A,3(f18.10,x))') 'xx,yy,enx = ',xx,yy,enx -cmp end if - t3a(ab)=yy - enddo - enddo - call transm(t3a(ba),t3b(ba),cdim,bdim) - enddo - call DGEMM_('N','T',1,cdim,nadim, one,vab(1,ij),1, - $ t3a,cdim,one,t1ac(k,1),noab_b) - call DGEMM_('N','N',1,adim,nbdim,-one,vcb(1,kj),1, - $ t3a,nbdim,one,t1aa(i,1),noab_a) - call DGEMM_('N','N',1,adim,nbdim,one,vcb(1,ki),1, - $ t3a,nbdim,one,t1aa(j,1),noab_a) - call DGEMM_('N','T',1,bdim,ncdim,-one,vca(1,ki),1, - $ t3b,bdim,one,t1ab(j,1),noab_a) - call DGEMM_('N','T',1,bdim,ncdim,one,vca(1,kj),1, - $ t3b,bdim,one,t1ab(i,1),noab_a) - if(ifvo) then - call DGEMM_('N','T',1,cdim,nadim, one,kab(1,i,j),1, - $ t3a,cdim,one,t1bc(k,1),noab_b) - call DGEMM_('N','N',1,adim,nbdim,one,kcb(1,k,j),1, - $ t3a,nbdim,one,t1ba(i,1),noab_a) - call DGEMM_('N','N',1,adim,nbdim,-one,kcb(1,k,i),1, - $ t3a,nbdim,one,t1ba(j,1),noab_a) - call DGEMM_('N','T',1,bdim,ncdim,one,kca(1,k,i),1, - $ t3b,bdim,one,t1bb(j,1),noab_a) - call DGEMM_('N','T',1,bdim,ncdim,-one,kca(1,k,j),1, - $ t3b,bdim,one,t1bb(i,1),noab_a) - endif -cmp write (*,'(3(i5,x),f18.10)') i,j,k,enx - enddo !j - enddo !i - enddo !k - return -c Avoid unused argument warnings - if (.false.) then - call Unused_integer(nuab_a) - call Unused_integer(nuab_b) - end if - end diff -Nru openmolcas-22.02/src/cht3/t3_bta_abc.F90 openmolcas-22.10/src/cht3/t3_bta_abc.F90 --- openmolcas-22.02/src/cht3/t3_bta_abc.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/t3_bta_abc.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,248 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine t3_bta_abc(nuga,nugc,kab,kcb,kca,kac,kbc,kc,la,lb,lxa,lxb,lxc,mi,mij,adim,bdim,cdim,N,noab_a,noab_b,lu,iasblock,nga, & + ngb,ngc,oehi,oehk,oepa,oepb,oepc,enx,vab,vcb,vca,t1aa,t1ba,t1ab,t1bb,t1ac,t1bc,t3a,t3b,ifvo) + +use Index_Functions, only: nTri_Elem +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: nuga, nugc, adim, bdim, cdim,N, noab_a, noab_b, lu(6), iasblock(5), nga, ngb, ngc +real(kind=wp), intent(_OUT_) :: kab(adim*bdim,N,*), kcb(cdim*bdim,N,*), kca(cdim*adim,N,*), kc(*), la(N*adim,*), lb(N*bdim,*), & + lxa(N*adim,*), lxb(N*bdim,*), lxc(N*cdim,*), mi(adim*bdim*cdim,*), mij(*), vab(adim*bdim,*), & + vcb(bdim*cdim,*), vca(adim*cdim,*), t3a(*), t3b(*) +real(kind=wp), intent(out) :: kac(cdim*adim,N), kbc(cdim*bdim,N) +real(kind=wp), intent(in) :: oehi(*), oehk(*), oepa(*), oepb(*), oepc(*) +real(kind=wp), intent(inout) :: enx, t1aa(noab_a,*), t1ba(noab_a,*), t1ab(noab_a,*), t1bb(noab_a,*), t1ac(noab_b,*), t1bc(noab_b,*) +logical(kind=iwp), intent(in) :: ifvo +integer(kind=iwp) :: a, ab, b, ba, c, i, ias, iasabi, iasack, iasbck, iascai, iascbi, ij, ik, j, jk, k, ki, kj, nadim, nbdim, & + ncdim, ngab_offset, ngac_offset, ngbc_offset, ngca_offset, ngcb_offset, nno_a, nnoab, nuga_offset, nugc_offset +real(kind=wp) :: den, dena, denb, denc, xx, yy + +! iasblock(1) > ka,kb,kc iasblock(2) > la,lb iasblock(3) > lxa,lxc,lxb +!!sumt3 = Zero +nno_a = nTri_Elem(noab_a-1) +nnoab = noab_a*noab_b +nadim = adim*bdim +nbdim = bdim*cdim +ncdim = adim*cdim +nuga_offset = iasblock(1)*nTri_Elem(nuga) +nugc_offset = iasblock(1)*nuga*nugc +ias = iasblock(2)*(nga-1)+1 +call multi_readir(la,nno_a*adim*N,lu(2),ias) +ias = iasblock(2)*(ngb-1)+1 +call multi_readir(lb,nno_a*bdim*N,lu(2),ias) +ias = iasblock(3)*(nga-1)+1 +call multi_readir(lxa,nnoab*adim*N,lu(5),ias) +ias = iasblock(3)*(ngb-1)+1 +call multi_readir(lxb,nnoab*bdim*N,lu(5),ias) +ias = iasblock(3)*(ngc-1)+1 +call multi_readir(lxc,nnoab*cdim*N,lu(6),ias) + +! vvoo ints reading +ngab_offset = iasblock(4)*(nTri_Elem(nga-1)+ngb-1)+1 +ias = iasblock(2)*nuga+ngab_offset +call multi_readir(vab,nno_a*nadim,lu(2),ias) +ngca_offset = iasblock(5)*(nugc*(nga-1)+ngc-1)+1 +ias = iasblock(2)*nuga+iasblock(4)*nTri_Elem(nuga)+ngca_offset +call multi_readir(vca,nnoab*ncdim,lu(2),ias) +ngcb_offset = iasblock(5)*(nugc*(ngb-1)+ngc-1)+1 +ias = iasblock(2)*nuga+iasblock(4)*nTri_Elem(nuga)+ngcb_offset +call multi_readir(vcb,nnoab*nbdim,lu(2),ias) +! end readin vvoo ints + +ngab_offset = iasblock(1)*(nTri_Elem(nga-1)+ngb-1)+1 +ngac_offset = iasblock(1)*(nuga*(ngc-1)+nga-1)+1 +ngbc_offset = iasblock(1)*(nuga*(ngc-1)+ngb-1)+1 +ngca_offset = iasblock(1)*(nugc*(nga-1)+ngc-1)+1 +ngcb_offset = iasblock(1)*(nugc*(ngb-1)+ngc-1)+1 +! saves reading: +do i=1,noab_a + iasabi = (i-1)*nuga_offset+ngab_offset + call multi_readir(kab(:,:,i),N*nadim,lu(1),iasabi) +end do +do i=1,noab_a + iascai = (i-1)*nugc_offset+ngca_offset + call multi_readir(kca(:,:,i),N*ncdim,lu(3),iascai) + !mp + !mp write(u6,*) 'ze tak teraz ju dam',i + !mp call check_mat(kca(1,1,i),1,N*ncdim) + !mp +end do +do i=1,noab_a + iascbi = (i-1)*nugc_offset+ngcb_offset + call multi_readir(kcb(:,:,i),N*nbdim,lu(3),iascbi) +end do +do k=1,noab_b + iasbck = (k-1)*nugc_offset+ngbc_offset + call multi_readir(kbc,N*nbdim,lu(4),iasbck) + iasack = (k-1)*nugc_offset+ngac_offset + call multi_readir(kac,N*ncdim,lu(4),iasack) + ! start calculating prefactors: + !mp + do i=1,noab_a + ik = (k-1)*noab_a+i + ki = (i-1)*noab_b+k + !mp + ! K_ab^ir x L_rc^ik cba + call DGEMM_('T','T',cdim,nadim,N,one,lxc(:,ik),N,kab(:,:,i),nadim,zero,mi(:,i),cdim) + ! K_bc^ir x L_ra^ki cba + call DGEMM_('N','N',nbdim,adim,N,one,kcb(:,:,i),nbdim,lxa(:,ki),N,one,mi(:,i),nbdim) + !mp + !mp do imm=0,adim*nbdim-1 + !mp if (abs(mi(1+imm,i)) > 1.0e5_wp) then + !mp write(u6,*) 'uz mi dojebane 2',imm+1,i,mi(1+imm,i) + !mp stop + !mp end if + !mp end do + !mp + + ! K_ac^ir x L_rb^ki cab + call DGEMM_('N','N',ncdim,bdim,N,one,kca(:,:,i),ncdim,lxb(:,ki),N,zero,t3b,ncdim) + !mp + ab = 1 + do a=1,adim + ba = (a-1)*cdim+1 + do b=1,bdim + mi(ab:ab+cdim-1,i) = mi(ab:ab+cdim-1,i)-t3b(ba:ba+cdim-1) + ab = ab+cdim + ba = ba+ncdim + end do + end do + end do ! i + !mp + ! end prefactors + ij = 0 + do i=2,noab_a + ki = (i-1)*noab_b+k + ik = (k-1)*noab_a+i + kj = k-noab_b + jk = (k-1)*noab_a + do j=1,i-1 + ij = ij+1 + kj = kj+noab_b + jk = jk+1 + !mp + ! K_ac^kr x L_rb^ij bac + call DGEMM_('T','T',bdim,ncdim,N,-one,lb(:,ij),N,kac,ncdim,zero,t3b,bdim) + ! K_bc^kr x L_ra^ij abc + call DGEMM_('T','T',adim,nbdim,N,one,la(:,ij),N,kbc,nbdim,zero,t3a,adim) + ! transpose the first two indices + !mp + ab = 1 + do c=1,cdim + ba = (c-1)*nadim+1 + do b=1,bdim + call daxpy_(adim,One,t3a(ab),1,t3b(ba),bdim) + ba = ba+1 + ab = ab+adim + end do + end do + ! t3b bac + call map2_21_t3(t3b,t3a,nadim,cdim) + ! cba in t3a + ! K_ab^ir x L_rc^jk -K_ab^jr x L_rc^ik + !call ka(1:N*nadim) = ka(1:N*nadim)-kb(1:N*nadim) + kc(1:N*nadim) = pack(kab(:,:,i)-kab(:,:,j),.true.) + mij(1:N*cdim) = lxc(:,jk)+lxc(:,ik) + call DGEMM_('T','T',cdim,nadim,N,one,mij,N,kc,nadim,one,t3a,cdim) + ! K_ab^ir x L_rc^jk + !!call DGEMM_('T','T',cdim,nadim,N,one,lxc(1,jk),N,ka,nadim,one,t3a,cdim) + ! -K_ab^jr x L_rc^ik + !!call DGEMM_('T','T',cdim,nadim,N,-one,lxc(1,ik),N,kb,nadim,one,t3a,cdim) + + ! K_bc^ir x L_ra^kj -K_bc^jr x L_ra^ki cba + kc(1:N*nbdim) = pack(kcb(:,:,i)-kcb(:,:,j),.true.) + mij(1:N*adim) = lxa(:,kj)+lxa(:,ki) + call DGEMM_('N','N',nbdim,adim,N,one,kc,nbdim,mij,N,one,t3a,nbdim) + ! K_bc^ir x L_ra^kj cba + !!call DGEMM_('N','N',nbdim,adim,N,one,ka,nbdim,lxa(1,kj),N,one,t3a,nbdim) + ! -K_bc^jr x L_ra^ki cba + !!call DGEMM_('N','N',nbdim,adim,N,-one,kb,nbdim,lxa(1,ki),N,one,t3a,nbdim) + ! K_ac^ir x L_rb^kj -K_ac^jr x L_rb^ki cab + kc(1:N*ncdim) = pack(kca(:,:,i)-kca(:,:,j),.true.) + mij(1:N*bdim) = lxb(:,kj)+lxb(:,ki) + call DGEMM_('N','N',ncdim,bdim,N,one,kc,ncdim,mij,N,zero,t3b,ncdim) + ! K_ac^ir x L_rb^kj cab + !!call DGEMM_('N','N',ncdim,bdim,N,one,ka,ncdim,lxb(1,kj),N,zero,t3b,ncdim) + ! -K_ac^jr x L_rb^ki cab + !!call DGEMM_('N','N',ncdim,bdim,N,-one,kb,ncdim,lxb(1,ki),N,one,t3b,ncdim) + !mp + ab = 1 + do a=1,adim + ba = (a-1)*cdim+1 + do b=1,bdim + t3a(ab:ab+cdim-1) = t3a(ab:ab+cdim-1)-t3b(ba:ba+cdim-1) + ab = ab+cdim + ba = ba+ncdim + end do + end do + + !mp do a=1,adim + !mp do b=1,bdim + !mp do c=1,cdim + !mp ab = c+(b-1)*cdim+(a-1)*bdim*cdim + !mp ba = c+(a-1)*cdim+(b-1)*adim*cdim + !mp t3a(ab) = t3a(ab)-t3b(ba) + !mp end do + !mp end do + !mp end do + + t3a(1:nadim*cdim) = t3a(1:nadim*cdim)-mi(:,i)+mi(:,j) + den = oehi(i)+oehi(j)+oehk(k) + ab = 0 + do a=1,adim + ba = ab+1 + dena = den-oepa(a) + do b=1,bdim + denb = dena-oepb(b) + do c=1,cdim + denc = denb-oepc(c) + ab = ab+1 + !mp if ((i == 14) .and. (j == 1) .and. (k == 1)) then + !mp write(u6,'(A,3(i5,x),3(f18.10,x))') 'a,b,c, oepa(a), oepb(b), oepc(c)',a,b,c,oepa(a),oepb(b),oepc(c) + !mp write(u6,*) 'denc = ',denc + !mp write(u6,*) 'ab, t3a(ab) ',ab,t3a(ab) + !mp end if + xx = t3a(ab) + yy = xx/denc + !!sumt3 = sumt3+xx + enx = enx+yy*xx + !mp if ((i == 14) .and. (j == 1) .and. (k == 1)) write(u6,'(A,3(f18.10,x))') 'xx,yy,enx = ',xx,yy,enx + t3a(ab) = yy + end do + end do + call map2_21_t3(t3a(ba),t3b(ba),cdim,bdim) + end do + call DGEMM_('N','T',1,cdim,nadim,one,vab(:,ij),1,t3a,cdim,one,t1ac(k,1),noab_b) + call DGEMM_('N','N',1,adim,nbdim,-one,vcb(:,kj),1,t3a,nbdim,one,t1aa(i,1),noab_a) + call DGEMM_('N','N',1,adim,nbdim,one,vcb(:,ki),1,t3a,nbdim,one,t1aa(j,1),noab_a) + call DGEMM_('N','T',1,bdim,ncdim,-one,vca(:,ki),1,t3b,bdim,one,t1ab(j,1),noab_a) + call DGEMM_('N','T',1,bdim,ncdim,one,vca(:,kj),1,t3b,bdim,one,t1ab(i,1),noab_a) + if (ifvo) then + call DGEMM_('N','T',1,cdim,nadim,one,kab(:,i,j),1,t3a,cdim,one,t1bc(k,1),noab_b) + call DGEMM_('N','N',1,adim,nbdim,one,kcb(:,k,j),1,t3a,nbdim,one,t1ba(i,1),noab_a) + call DGEMM_('N','N',1,adim,nbdim,-one,kcb(:,k,i),1,t3a,nbdim,one,t1ba(j,1),noab_a) + call DGEMM_('N','T',1,bdim,ncdim,one,kca(:,k,i),1,t3b,bdim,one,t1bb(j,1),noab_a) + call DGEMM_('N','T',1,bdim,ncdim,-one,kca(:,k,j),1,t3b,bdim,one,t1bb(i,1),noab_a) + end if + !mp write(u6,'(3(i5,x),f18.10)') i,j,k,enx + end do !j + end do !i +end do !k + +return + +end subroutine t3_bta_abc diff -Nru openmolcas-22.02/src/cht3/t3_bt_aac.f openmolcas-22.10/src/cht3/t3_bt_aac.f --- openmolcas-22.02/src/cht3/t3_bt_aac.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/t3_bt_aac.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,155 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine t3_bt_aac(nug,ka,kb,kc,la,lc,mi,mij,adim,cdim, - $N,noab,nuab,nnoab,lu,iasblock,nga,ngc,oeh,oepa,oepc,enx,voa,voc, - $t1aa,t1ba,t1ac,t1bc,t3a,t3b,ifvo) - implicit none - real*8 one,zero,sumt3 - logical ifvo - parameter (one=1.d0,zero=0.d0) - integer nadim,adim,noab,nuab,i,j,k,nga,iasblock(3),lu(2),N - integer ias,nga_offset,ngc_offset,nug_offset,jk,ij,ik,ncdim,cdim - integer a,b,c,ab,nug,nnoab,ngc,iasci,iasai !,kaka - real*8 dena,denb,denc,xx,yy - real*8 ka(adim*(adim-1)/2,n,*),kc(adim*cdim,n,*),kb(*), - $la(N*adim,nnoab),lc(N*cdim,nnoab) -!! real*8 lb(N,adim,nnoab),lc(N,adim,nnoab) - real*8 t3a(cdim,*),t3b(cdim,adim,*),t1ac(noab,*),t1bc(noab,*) - real*8 mi(*),mij(*),voa(adim*(adim-1)/2,*),voc(adim*cdim,*) - real*8 t1aa(noab,*),t1ba(noab,*),enx,oeh(noab),oepa(adim),den - real*8 oepc(cdim) -C - sumt3=0.d0 - if(adim.eq.1)return - nadim=adim*(adim-1)/2 - ncdim=adim*cdim - nug_offset=iasblock(1)*nug*(nug+1)/2 - ias=iasblock(2)*(nga-1)+1 - call multi_readir(la,nnoab*adim*N,lu(2),ias) - ias=iasblock(2)*(ngc-1)+1 - call multi_readir(lc,nnoab*cdim*N,lu(2),ias) -C reads vvoo - nga_offset=iasblock(3)*(nga*(nga-1)/2+nga-1)+1 - ngc_offset=iasblock(3)*(nga*(nga-1)/2+ngc-1)+1 - ias=iasblock(2)*nug+nga_offset - call multi_readir(voa,nnoab*nadim,lu(2),ias) - ias=iasblock(2)*nug+ngc_offset - call multi_readir(voc,nnoab*ncdim,lu(2),ias) -C - nga_offset=iasblock(1)*(nga*(nga-1)/2+nga-1)+1 - ngc_offset=iasblock(1)*(nga*(nga-1)/2+ngc-1)+1 - do i=1,noab - iasci=(i-1)*nug_offset+ngc_offset - call multi_readir(kc(1,1,i),N*ncdim,lu(1),iasci) - iasai=(i-1)*nug_offset+nga_offset - call multi_readir(ka(1,1,i),N*nadim,lu(1),iasai) - enddo - do i=3,noab - jk=0 - do j=2,i-1 - ij=(i-1)*(i-2)/2+j - ik=(i-1)*(i-2)/2 - do k=1,j-1 - jk=jk+1 - ik=ik+1 -!! write(6,'(9I5)')i,j,k,iasai,iasaj,iasak,iasci,iascj,iasck -C K_ab^ir x L_rc^jk - call DGEMM_('T','T',cdim,nadim,N,one, lc(1,jk),N,ka(1,1,i),nadim, - $ zero,t3a,cdim) -C K_ab^kr x L_rc^ij - call DGEMM_('T','T',cdim,nadim,N,one, lc(1,ij),N,ka(1,1,k),nadim, - $ one,t3a,cdim) -C -K_ab^jr x L_rc^ik - call DGEMM_('T','T',cdim,nadim,N,-one,lc(1,ik),N,ka(1,1,j),nadim, - $ one,t3a,cdim) -C K_bc^ir x L_ra^jk - call DGEMM_('N','N',ncdim,adim,N,one,kc(1,1,i),ncdim,la(1,jk),N, - $ zero,t3b,ncdim) -C K_bc^kr x L_ra^ij - call DGEMM_('N','N',ncdim,adim,N,one,kc(1,1,k),ncdim,la(1,ij),N, - $ one,t3b,ncdim) -C -K_bc^jr x L_ra^ik - call DGEMM_('N','N',ncdim,adim,N,-one,kc(1,1,j),ncdim,la(1,ik),N, - $ one,t3b,ncdim) -!! - ab=0 - do a=2,adim - do b=1,a-1 - ab=ab+1 - call daxpy_(cdim,-1.d0,t3b(1,a,b),1,t3a(1,ab),1) - call daxpy_(cdim,1.d0,t3b(1,b,a),1,t3a(1,ab),1) - enddo - enddo - den=oeh(i)+oeh(j)+oeh(k) - ab=0 -c! kaka=0 - do a=2,adim - dena=den-oepa(a) - do b=1,a-1 - ab=ab+1 - denb=dena-oepa(b) - do c=1,cdim - denc=denb-oepc(c) -c! ab=ab+1 -c! kaka=kaka+1 -c! xx=t3a(ab,1) - xx=t3a(c,ab) - yy=xx/denc - sumt3=sumt3+xx - enx=enx+yy*xx -c! t3a(ab,1)=yy - t3a(c,ab)=yy -c! write (*,*) ab,t3a(ab,1) -c! write (*,*) kaka,t3a(c,ab) - enddo - enddo - enddo - call expa2_uhf(t3a,cdim,adim,-1,t3b) -C ccsd(T) part vvoo*t3 - call DGEMM_('N','T',1,cdim,nadim, one,voa(1,ij),1, - $ t3a,cdim,one,t1ac(k,1),noab) - call DGEMM_('N','T',1,cdim,nadim, one,voa(1,jk),1, - $ t3a,cdim,one,t1ac(i,1),noab) - call DGEMM_('N','T',1,cdim,nadim,-one,voa(1,ik),1, - $ t3a,cdim,one,t1ac(j,1),noab) - call DGEMM_('N','N',1,adim,ncdim,-one,voc(1,ij),1, - $ t3b,ncdim,one,t1aa(k,1),noab) - call DGEMM_('N','N',1,adim,ncdim,-one,voc(1,jk),1, - $ t3b,ncdim,one,t1aa(i,1),noab) - call DGEMM_('N','N',1,adim,ncdim, one,voc(1,ik),1, - $ t3b,ncdim,one,t1aa(j,1),noab) -C ccsd(T) part t2*t3 - if(ifvo) then - call DGEMM_('N','T',1,cdim,nadim, one,ka(1,i,j),1, - $ t3a,cdim,one,t1bc(k,1),noab) - call DGEMM_('N','T',1,cdim,nadim, one,ka(1,j,k),1, - $ t3a,cdim,one,t1bc(i,1),noab) - call DGEMM_('N','T',1,cdim,nadim,-one,ka(1,i,k),1, - $ t3a,cdim,one,t1bc(j,1),noab) - call DGEMM_('N','N',1,adim,ncdim,-one,kc(1,i,j),1, - $ t3b,ncdim,one,t1ba(k,1),noab) - call DGEMM_('N','N',1,adim,ncdim,-one,kc(1,j,k),1, - $ t3b,ncdim,one,t1ba(i,1),noab) - call DGEMM_('N','N',1,adim,ncdim, one,kc(1,i,k),1, - $ t3b,ncdim,one,t1ba(j,1),noab) - endif - enddo !k - enddo !j - enddo !i - return -c Avoid unused argument warnings - if (.false.) then - call Unused_real_array(kb) - call Unused_real_array(mi) - call Unused_real_array(mij) - call Unused_integer(nuab) - end if - end diff -Nru openmolcas-22.02/src/cht3/t3_bt_aac.F90 openmolcas-22.10/src/cht3/t3_bt_aac.F90 --- openmolcas-22.02/src/cht3/t3_bt_aac.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/t3_bt_aac.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,133 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine t3_bt_aac(nug,ka,kc,la,lc,adim,cdim,N,noab,nnoab,lu,iasblock,nga,ngc,oeh,oepa,oepc,enx,voa,voc,t1aa,t1ba,t1ac,t1bc,t3a, & + t3b,ifvo) + +use Index_Functions, only: nTri_Elem +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: nug, adim, cdim, N, noab, nnoab, lu(2), iasblock(3), nga, ngc +real(kind=wp), intent(_OUT_) :: ka(nTri_Elem(adim-1),N,*), kc(adim*cdim,N,*), voa(nTri_Elem(adim-1),*), voc(adim*cdim,*), & + t3a(cdim,*), t3b(cdim,adim,*) +real(kind=wp), intent(out) :: la(N*adim,nnoab), lc(N*cdim,nnoab) +real(kind=wp), intent(in) :: oeh(noab), oepa(adim), oepc(cdim) +real(kind=wp), intent(inout) :: enx, t1aa(noab,*), t1ba(noab,*), t1ac(noab,*), t1bc(noab,*) +logical(kind=iwp), intent(in) :: ifvo +integer(kind=iwp) :: a, ab, b, c, i, ias, iasai, iasci, ij, ik, j, jk, k, nadim, ncdim, nga_offset, ngc_offset, nug_offset +real(kind=wp) :: den, dena, denb, denc, sumt3, xx, yy + +sumt3 = Zero +if (adim == 1) return +nadim = nTri_Elem(adim-1) +ncdim = adim*cdim +nug_offset = iasblock(1)*nTri_Elem(nug) +ias = iasblock(2)*(nga-1)+1 +call multi_readir(la,nnoab*adim*N,lu(2),ias) +ias = iasblock(2)*(ngc-1)+1 +call multi_readir(lc,nnoab*cdim*N,lu(2),ias) +! reads vvoo +nga_offset = iasblock(3)*(nTri_Elem(nga-1)+nga-1)+1 +ngc_offset = iasblock(3)*(nTri_Elem(nga-1)+ngc-1)+1 +ias = iasblock(2)*nug+nga_offset +call multi_readir(voa,nnoab*nadim,lu(2),ias) +ias = iasblock(2)*nug+ngc_offset +call multi_readir(voc,nnoab*ncdim,lu(2),ias) + +nga_offset = iasblock(1)*(nTri_Elem(nga-1)+nga-1)+1 +ngc_offset = iasblock(1)*(nTri_Elem(nga-1)+ngc-1)+1 +do i=1,noab + iasci = (i-1)*nug_offset+ngc_offset + call multi_readir(kc(:,:,i),N*ncdim,lu(1),iasci) + iasai = (i-1)*nug_offset+nga_offset + call multi_readir(ka(:,:,i),N*nadim,lu(1),iasai) +end do +do i=3,noab + jk = 0 + do j=2,i-1 + ij = nTri_Elem(i-2)+j + ik = nTri_Elem(i-2) + do k=1,j-1 + jk = jk+1 + ik = ik+1 + !!write(u6,'(9I5)') i,j,k,iasai,iasaj,iasak,iasci,iascj,iasck + ! K_ab^ir x L_rc^jk + call DGEMM_('T','T',cdim,nadim,N,one,lc(:,jk),N,ka(:,:,i),nadim,zero,t3a,cdim) + ! K_ab^kr x L_rc^ij + call DGEMM_('T','T',cdim,nadim,N,one,lc(:,ij),N,ka(:,:,k),nadim,one,t3a,cdim) + ! -K_ab^jr x L_rc^ik + call DGEMM_('T','T',cdim,nadim,N,-one,lc(:,ik),N,ka(:,:,j),nadim,one,t3a,cdim) + ! K_bc^ir x L_ra^jk + call DGEMM_('N','N',ncdim,adim,N,one,kc(:,:,i),ncdim,la(:,jk),N,zero,t3b,ncdim) + ! K_bc^kr x L_ra^ij + call DGEMM_('N','N',ncdim,adim,N,one,kc(:,:,k),ncdim,la(:,ij),N,one,t3b,ncdim) + ! -K_bc^jr x L_ra^ik + call DGEMM_('N','N',ncdim,adim,N,-one,kc(:,:,j),ncdim,la(:,ik),N,one,t3b,ncdim) + + ab = 0 + do a=2,adim + do b=1,a-1 + ab = ab+1 + t3a(:,ab) = t3a(:,ab)-t3b(:,a,b)+t3b(:,b,a) + end do + end do + den = oeh(i)+oeh(j)+oeh(k) + ab = 0 + !!kaka = 0 + do a=2,adim + dena = den-oepa(a) + do b=1,a-1 + ab = ab+1 + denb = dena-oepa(b) + do c=1,cdim + denc = denb-oepc(c) + !!ab = ab+1 + !!kaka = kaka+1 + !!xx = t3a(ab,1) + xx = t3a(c,ab) + yy = xx/denc + sumt3 = sumt3+xx + enx = enx+yy*xx + !!t3a(ab,1) = yy + t3a(c,ab) = yy + !!write(u6,*) ab,t3a(ab,1) + !!write(u6,*) kaka,t3a(c,ab) + end do + end do + end do + call expa2_uhf(t3a,cdim,adim,-1,t3b) + ! ccsd(T) part vvoo*t3 + call DGEMM_('N','T',1,cdim,nadim,one,voa(:,ij),1,t3a,cdim,one,t1ac(k,1),noab) + call DGEMM_('N','T',1,cdim,nadim,one,voa(:,jk),1,t3a,cdim,one,t1ac(i,1),noab) + call DGEMM_('N','T',1,cdim,nadim,-one,voa(:,ik),1,t3a,cdim,one,t1ac(j,1),noab) + call DGEMM_('N','N',1,adim,ncdim,-one,voc(:,ij),1,t3b,ncdim,one,t1aa(k,1),noab) + call DGEMM_('N','N',1,adim,ncdim,-one,voc(:,jk),1,t3b,ncdim,one,t1aa(i,1),noab) + call DGEMM_('N','N',1,adim,ncdim,one,voc(:,ik),1,t3b,ncdim,one,t1aa(j,1),noab) + ! ccsd(T) part t2*t3 + if (ifvo) then + call DGEMM_('N','T',1,cdim,nadim,one,ka(:,i,j),1,t3a,cdim,one,t1bc(k,1),noab) + call DGEMM_('N','T',1,cdim,nadim,one,ka(:,j,k),1,t3a,cdim,one,t1bc(i,1),noab) + call DGEMM_('N','T',1,cdim,nadim,-one,ka(:,i,k),1,t3a,cdim,one,t1bc(j,1),noab) + call DGEMM_('N','N',1,adim,ncdim,-one,kc(:,i,j),1,t3b,ncdim,one,t1ba(k,1),noab) + call DGEMM_('N','N',1,adim,ncdim,-one,kc(:,j,k),1,t3b,ncdim,one,t1ba(i,1),noab) + call DGEMM_('N','N',1,adim,ncdim,one,kc(:,i,k),1,t3b,ncdim,one,t1ba(j,1),noab) + end if + end do !k + end do !j +end do !i + +return + +end subroutine t3_bt_aac diff -Nru openmolcas-22.02/src/cht3/t3_bt_abc.f openmolcas-22.10/src/cht3/t3_bt_abc.f --- openmolcas-22.02/src/cht3/t3_bt_abc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/t3_bt_abc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,189 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine t3_bt_abc(nug,ka,kb,kc,la,lb,lc,mi,mij,adim,bdim, - $cdim,N,noab,nuab,nnoab,lu,iasblock,nga,ngb,ngc,oeh,oepa,oepb, - $oepc,enx,voa,vob,voc,t1aa,t1ba,t1ab,t1bb,t1ac,t1bc,t3a,t3b,ifvo) - implicit none - real*8 one,zero,ddot_,enx,den,dena,denb,denc - parameter (one=1.d0,zero=0.d0) - logical ifvo - integer nadim,adim,bdim,nbdim,cdim,ncdim,noab,nuab,i,j,k - integer nga,ngb,ngc,N,iasblock(3),lu(2),jk,ij,ik,ac,ca,a,b,c - integer ias,iasai,iasbi,iasci -c integer iasaj,iasak,iascj,iasck - integer nga_offset,ngb_offset,ngc_offset,nug_offset,nug,nnoab - real*8 ka(adim*bdim,N,*),kb(bdim*cdim,N,*),kc(adim*cdim,N,*) - real*8 la(N*adim,nnoab),lb(N*bdim,nnoab),lc(N*cdim,nnoab) - real*8 t1aa(noab,*),t1ba(noab,*),t1ab(noab,*),t1bb(noab,*) - real*8 mi(*),t1ac(noab,*),t1bc(noab,*) - real*8 mij(*),voa(adim*bdim,*),vob(bdim*cdim,*),voc(adim*cdim,*) - real*8 oeh(noab),oepa(adim),oepb(bdim),oepc(cdim),t3a(*),t3b(*) -C -!! write(6,*)'enter_abc enx,nga,ngb,ngc',nga,ngb,ngc,enx - nadim=adim*bdim - nbdim=bdim*cdim - ncdim=adim*cdim - nug_offset=iasblock(1)*nug*(nug+1)/2 -C reads la's - ias=iasblock(2)*(nga-1)+1 - call multi_readir(la,nnoab*adim*N,lu(2),ias) - ias=iasblock(2)*(ngb-1)+1 - call multi_readir(lb,nnoab*bdim*N,lu(2),ias) - ias=iasblock(2)*(ngc-1)+1 - call multi_readir(lc,nnoab*cdim*N,lu(2),ias) -C reads vvoo - nga_offset=iasblock(3)*(nga*(nga-1)/2+ngb-1)+1 - ngb_offset=iasblock(3)*(ngb*(ngb-1)/2+ngc-1)+1 - ngc_offset=iasblock(3)*(nga*(nga-1)/2+ngc-1)+1 - ias=iasblock(2)*nug+nga_offset - call multi_readir(voa,nnoab*nadim,lu(2),ias) - ias=iasblock(2)*nug+ngb_offset - call multi_readir(vob,nnoab*nbdim,lu(2),ias) - ias=iasblock(2)*nug+ngc_offset - call multi_readir(voc,nnoab*ncdim,lu(2),ias) -C - nga_offset=iasblock(1)*(nga*(nga-1)/2+ngb-1)+1 - ngb_offset=iasblock(1)*(ngb*(ngb-1)/2+ngc-1)+1 - ngc_offset=iasblock(1)*(nga*(nga-1)/2+ngc-1)+1 - do i=1,noab - iasci=(i-1)*nug_offset+ngc_offset - call multi_readir(kc(1,1,i),N*ncdim,lu(1),iasci) - iasbi=(i-1)*nug_offset+ngb_offset - call multi_readir(kb(1,1,i),N*nbdim,lu(1),iasbi) - iasai=(i-1)*nug_offset+nga_offset - call multi_readir(ka(1,1,i),N*nadim,lu(1),iasai) - enddo - do i=3,noab - jk=0 - do j=2,i-1 - ij=(i-1)*(i-2)/2+j - ik=(i-1)*(i-2)/2 - do k=1,j-1 - jk=jk+1 - ik=ik+1 -C K_ba^ir x L_rc^jk - call DGEMM_('N','N',nadim,cdim,N,one,ka(1,1,i),nadim,lc(1,jk),N, - $ zero,t3a,nadim) -C K_ba^kr x L_rc^ij - call DGEMM_('N','N',nadim,cdim,N,one,ka(1,1,k),nadim,lc(1,ij),N, - $ one,t3a,nadim) -C -K_ba^jr x L_rc^ik - call DGEMM_('N','N',nadim,cdim,N,-one,ka(1,1,j),nadim,lc(1,ik),N, - $ one,t3a,nadim) -C -K_ca^ir x L_rb^jk ! in the matrix as b,c,a - call DGEMM_('T','T',bdim,ncdim,N,-one,lb(1,jk),N,kc(1,1,i),ncdim, - $ zero,t3b,bdim) -C -K_ca^kr x L_rb^ij - call DGEMM_('T','T',bdim,ncdim,N,-one,lb(1,ij),N,kc(1,1,k),ncdim, - $ one ,t3b,bdim) -C K_ca^jr x L_rb^ik - call DGEMM_('T','T',bdim,ncdim,N,one,lb(1,ik),N,kc(1,1,j),ncdim, - $ one ,t3b,bdim) -!! - ac=1-bdim - do a=1,adim - ca=(a-1)*bdim+1-nadim - do c=1,cdim - ac=ac+bdim - ca=ca+nadim - call daxpy_(bdim,1.d0,t3a(ca),1,t3b(ac),1) - enddo - enddo -C K_cb^ir x L_ra^jk ! in the matrix as b,c,a - call DGEMM_('N','N',nbdim,adim,N,one,kb(1,1,i),nbdim,la(1,jk),N, - $ zero,t3a,nbdim) -C K_cb^kr x L_ra^ij - call DGEMM_('N','N',nbdim,adim,N,one,kb(1,1,k),nbdim,la(1,ij),N, - $ one ,t3a,nbdim) -C -K_cb^jr x L_ra^ik - call DGEMM_('N','N',nbdim,adim,N,-one,kb(1,1,j),nbdim,la(1,ik),N, - $ one ,t3a,nbdim) - den=oeh(i)+oeh(j)+oeh(k) - ac=1 - do a=1,adim - ca=(a-1)*nbdim+1 - do c=1,cdim - call daxpy_(bdim,1.d0,t3a(ca),cdim,t3b(ac),1) - ac=ac+bdim - ca=ca+1 - enddo - enddo - call dcopy_(cdim*bdim*adim,t3b,1,t3a,1) - ac=0 - do a=1,adim - dena=den-oepa(a) - do c=1,cdim - denc=dena-oepc(c) - do b=1,bdim - denb=denc-oepb(b) - ac=ac+1 - t3b(ac)=t3b(ac)/denb - enddo - enddo - enddo - enx=enx+ddot_(cdim*bdim*adim,t3b,1,t3a,1) - call ex23(t3b,t3a,bdim,cdim,adim,1) -C t3a bac -C blok1 voa ka - call DGEMM_('N','N',1,cdim,nadim, one,voa(1,ij),1, - $ t3a,nadim,one,t1ac(k,1),noab) - call DGEMM_('N','N',1,cdim,nadim, one,voa(1,jk),1, - $ t3a,nadim,one,t1ac(i,1),noab) - call DGEMM_('N','N',1,cdim,nadim,-one,voa(1,ik),1, - $ t3a,nadim,one,t1ac(j,1),noab) -C blok 2 t3b bca - call DGEMM_('N','T',1,bdim,ncdim,-one, voc(1,ij),1, - $ t3b,bdim,one,t1ab(k,1),noab) - call DGEMM_('N','T',1,bdim,ncdim,-one, voc(1,jk),1, - $ t3b,bdim,one,t1ab(i,1),noab) - call DGEMM_('N','T',1,bdim,ncdim,one,voc(1,ik),1, - $ t3b,bdim,one,t1ab(j,1),noab) - if(ifvo)then - call DGEMM_('N','N',1,cdim,nadim, one,ka(1,i,j),1, - $ t3a,nadim,one,t1bc(k,1),noab) - call DGEMM_('N','N',1,cdim,nadim, one,ka(1,j,k),1, - $ t3a,nadim,one,t1bc(i,1),noab) - call DGEMM_('N','N',1,cdim,nadim,-one,ka(1,i,k),1, - $ t3a,nadim,one,t1bc(j,1),noab) - call DGEMM_('N','T',1,bdim,ncdim,-one, kc(1,i,j),1, - $ t3b,bdim,one,t1bb(k,1),noab) - call DGEMM_('N','T',1,bdim,ncdim,-one, kc(1,j,k),1, - $ t3b,bdim,one,t1bb(i,1),noab) - call DGEMM_('N','T',1,bdim,ncdim, one,kc(1,i,k),1, - $ t3b,bdim,one,t1bb(j,1),noab) - endif -C part 3 acb in t3b - call transm(t3a,t3b,bdim,ncdim) - call DGEMM_('N','T',1,adim,nbdim,one, vob(1,ij),1, - $ t3b,adim,one,t1aa(k,1),noab) - call DGEMM_('N','T',1,adim,nbdim,one, vob(1,jk),1, - $ t3b,adim,one,t1aa(i,1),noab) - call DGEMM_('N','T',1,adim,nbdim,-one,vob(1,ik),1, - $ t3b,adim,one,t1aa(j,1),noab) - if(ifvo)then - call DGEMM_('N','T',1,adim,nbdim,one, kb(1,i,j),1, - $ t3b,adim,one,t1ba(k,1),noab) - call DGEMM_('N','T',1,adim,nbdim,one, kb(1,j,k),1, - $ t3b,adim,one,t1ba(i,1),noab) - call DGEMM_('N','T',1,adim,nbdim,-one, kb(1,i,k),1, - $ t3b,adim,one,t1ba(j,1),noab) - endif - enddo !k - enddo !j - enddo !i - return -c Avoid unused argument warnings - if (.false.) then - call Unused_real_array(mi) - call Unused_real_array(mij) - call Unused_integer(nuab) - end if - end diff -Nru openmolcas-22.02/src/cht3/t3_bt_abc.F90 openmolcas-22.10/src/cht3/t3_bt_abc.F90 --- openmolcas-22.02/src/cht3/t3_bt_abc.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/t3_bt_abc.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,162 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine t3_bt_abc(nug,ka,kb,kc,la,lb,lc,adim,bdim,cdim,N,noab,nnoab,lu,iasblock,nga,ngb,ngc,oeh,oepa,oepb,oepc,enx,voa,vob,voc, & + t1aa,t1ba,t1ab,t1bb,t1ac,t1bc,t3a,t3b,ifvo) + +use Index_Functions, only: nTri_Elem +use Constants, only: Zero, One +use Definitions, only: wp, iwp, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: nug, adim, bdim, cdim, N, noab, nnoab, lu(2), iasblock(3), nga, ngb, ngc +real(kind=wp), intent(_OUT_) :: ka(adim*bdim,N,*), kb(bdim*cdim,N,*), kc(adim*cdim,N,*), voa(adim*bdim,*), vob(bdim*cdim,*), & + voc(adim*cdim,*), t3a(*), t3b(*) +real(kind=wp), intent(out) :: la(N*adim,nnoab), lb(N*bdim,nnoab), lc(N*cdim,nnoab) +real(kind=wp), intent(in) :: oeh(noab), oepa(adim), oepb(bdim), oepc(cdim) +real(kind=wp), intent(inout) :: enx, t1aa(noab,*), t1ba(noab,*), t1ab(noab,*), t1bb(noab,*), t1ac(noab,*), t1bc(noab,*) +logical(kind=iwp), intent(in) :: ifvo +integer(kind=iwp) :: a, ac, b, c, ca, i, ias, iasai, iasbi, iasci, ij, ik, j, jk, k, nadim, nbdim, ncdim, nga_offset, ngb_offset, & + ngc_offset, nug_offset +real(kind=wp) :: den, dena, denb, denc +real(kind=r8), external :: ddot_ + +!!write(u6,*) 'enter_abc enx,nga,ngb,ngc',nga,ngb,ngc,enx +nadim = adim*bdim +nbdim = bdim*cdim +ncdim = adim*cdim +nug_offset = iasblock(1)*nTri_Elem(nug) +! reads la's +ias = iasblock(2)*(nga-1)+1 +call multi_readir(la,nnoab*adim*N,lu(2),ias) +ias = iasblock(2)*(ngb-1)+1 +call multi_readir(lb,nnoab*bdim*N,lu(2),ias) +ias = iasblock(2)*(ngc-1)+1 +call multi_readir(lc,nnoab*cdim*N,lu(2),ias) +! reads vvoo +nga_offset = iasblock(3)*(nTri_Elem(nga-1)+ngb-1)+1 +ngb_offset = iasblock(3)*(nTri_Elem(ngb-1)+ngc-1)+1 +ngc_offset = iasblock(3)*(nTri_Elem(nga-1)+ngc-1)+1 +ias = iasblock(2)*nug+nga_offset +call multi_readir(voa,nnoab*nadim,lu(2),ias) +ias = iasblock(2)*nug+ngb_offset +call multi_readir(vob,nnoab*nbdim,lu(2),ias) +ias = iasblock(2)*nug+ngc_offset +call multi_readir(voc,nnoab*ncdim,lu(2),ias) + +nga_offset = iasblock(1)*(nTri_Elem(nga-1)+ngb-1)+1 +ngb_offset = iasblock(1)*(nTri_Elem(ngb-1)+ngc-1)+1 +ngc_offset = iasblock(1)*(nTri_Elem(nga-1)+ngc-1)+1 +do i=1,noab + iasci = (i-1)*nug_offset+ngc_offset + call multi_readir(kc(:,:,i),N*ncdim,lu(1),iasci) + iasbi = (i-1)*nug_offset+ngb_offset + call multi_readir(kb(:,:,i),N*nbdim,lu(1),iasbi) + iasai = (i-1)*nug_offset+nga_offset + call multi_readir(ka(:,:,i),N*nadim,lu(1),iasai) +end do +do i=3,noab + jk = 0 + do j=2,i-1 + ij = nTri_Elem(i-2)+j + ik = nTri_Elem(i-2) + do k=1,j-1 + jk = jk+1 + ik = ik+1 + ! K_ba^ir x L_rc^jk + call DGEMM_('N','N',nadim,cdim,N,one,ka(:,:,i),nadim,lc(:,jk),N,zero,t3a,nadim) + ! K_ba^kr x L_rc^ij + call DGEMM_('N','N',nadim,cdim,N,one,ka(:,:,k),nadim,lc(:,ij),N,one,t3a,nadim) + ! -K_ba^jr x L_rc^ik + call DGEMM_('N','N',nadim,cdim,N,-one,ka(:,:,j),nadim,lc(:,ik),N,one,t3a,nadim) + ! -K_ca^ir x L_rb^jk ! in the matrix as b,c,a + call DGEMM_('T','T',bdim,ncdim,N,-one,lb(:,jk),N,kc(:,:,i),ncdim,zero,t3b,bdim) + ! -K_ca^kr x L_rb^ij + call DGEMM_('T','T',bdim,ncdim,N,-one,lb(:,ij),N,kc(:,:,k),ncdim,one,t3b,bdim) + ! K_ca^jr x L_rb^ik + call DGEMM_('T','T',bdim,ncdim,N,one,lb(:,ik),N,kc(:,:,j),ncdim,one,t3b,bdim) + + ac = 1-bdim + do a=1,adim + ca = (a-1)*bdim+1-nadim + do c=1,cdim + ac = ac+bdim + ca = ca+nadim + t3b(ac:ac+bdim-1) = t3b(ac:ac+bdim-1)+t3a(ca:ca+bdim-1) + end do + end do + ! K_cb^ir x L_ra^jk ! in the matrix as b,c,a + call DGEMM_('N','N',nbdim,adim,N,one,kb(:,:,i),nbdim,la(:,jk),N,zero,t3a,nbdim) + ! K_cb^kr x L_ra^ij + call DGEMM_('N','N',nbdim,adim,N,one,kb(:,:,k),nbdim,la(:,ij),N,one,t3a,nbdim) + ! -K_cb^jr x L_ra^ik + call DGEMM_('N','N',nbdim,adim,N,-one,kb(:,:,j),nbdim,la(:,ik),N,one,t3a,nbdim) + den = oeh(i)+oeh(j)+oeh(k) + ac = 1 + do a=1,adim + ca = (a-1)*nbdim+1 + do c=1,cdim + call daxpy_(bdim,One,t3a(ca),cdim,t3b(ac),1) + ac = ac+bdim + ca = ca+1 + end do + end do + t3a(1:cdim*bdim*adim) = t3b(1:cdim*bdim*adim) + ac = 0 + do a=1,adim + dena = den-oepa(a) + do c=1,cdim + denc = dena-oepc(c) + do b=1,bdim + denb = denc-oepb(b) + ac = ac+1 + t3b(ac) = t3b(ac)/denb + end do + end do + end do + enx = enx+ddot_(cdim*bdim*adim,t3b,1,t3a,1) + call ex23(t3b,t3a,bdim,cdim,adim,1) + ! t3a bac + ! blok1 voa ka + call DGEMM_('N','N',1,cdim,nadim,one,voa(:,ij),1,t3a,nadim,one,t1ac(k,1),noab) + call DGEMM_('N','N',1,cdim,nadim,one,voa(:,jk),1,t3a,nadim,one,t1ac(i,1),noab) + call DGEMM_('N','N',1,cdim,nadim,-one,voa(:,ik),1,t3a,nadim,one,t1ac(j,1),noab) + ! blok 2 t3b bca + call DGEMM_('N','T',1,bdim,ncdim,-one,voc(:,ij),1,t3b,bdim,one,t1ab(k,1),noab) + call DGEMM_('N','T',1,bdim,ncdim,-one,voc(:,jk),1,t3b,bdim,one,t1ab(i,1),noab) + call DGEMM_('N','T',1,bdim,ncdim,one,voc(:,ik),1,t3b,bdim,one,t1ab(j,1),noab) + if (ifvo) then + call DGEMM_('N','N',1,cdim,nadim,one,ka(:,i,j),1,t3a,nadim,one,t1bc(k,1),noab) + call DGEMM_('N','N',1,cdim,nadim,one,ka(:,j,k),1,t3a,nadim,one,t1bc(i,1),noab) + call DGEMM_('N','N',1,cdim,nadim,-one,ka(:,i,k),1,t3a,nadim,one,t1bc(j,1),noab) + call DGEMM_('N','T',1,bdim,ncdim,-one,kc(:,i,j),1,t3b,bdim,one,t1bb(k,1),noab) + call DGEMM_('N','T',1,bdim,ncdim,-one,kc(:,j,k),1,t3b,bdim,one,t1bb(i,1),noab) + call DGEMM_('N','T',1,bdim,ncdim,one,kc(:,i,k),1,t3b,bdim,one,t1bb(j,1),noab) + end if + ! part 3 acb in t3b + call map2_21_t3(t3a,t3b,bdim,ncdim) + call DGEMM_('N','T',1,adim,nbdim,one,vob(:,ij),1,t3b,adim,one,t1aa(k,1),noab) + call DGEMM_('N','T',1,adim,nbdim,one,vob(:,jk),1,t3b,adim,one,t1aa(i,1),noab) + call DGEMM_('N','T',1,adim,nbdim,-one,vob(:,ik),1,t3b,adim,one,t1aa(j,1),noab) + if (ifvo) then + call DGEMM_('N','T',1,adim,nbdim,one,kb(:,i,j),1,t3b,adim,one,t1ba(k,1),noab) + call DGEMM_('N','T',1,adim,nbdim,one,kb(:,j,k),1,t3b,adim,one,t1ba(i,1),noab) + call DGEMM_('N','T',1,adim,nbdim,-one,kb(:,i,k),1,t3b,adim,one,t1ba(j,1),noab) + end if + end do !k + end do !j +end do !i + +return + +end subroutine t3_bt_abc diff -Nru openmolcas-22.02/src/cht3/t3_bt_acc.f openmolcas-22.10/src/cht3/t3_bt_acc.f --- openmolcas-22.02/src/cht3/t3_bt_acc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/t3_bt_acc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,142 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine t3_bt_acc(nug,ka,kb,kc,la,lc,mi,mij,adim,cdim, - $N,noab,nuab,nnoab,lu,iasblock,nga,ngc,oeh,oepa,oepc,enx,voa,voc, - $t1aa,t1ba,t1ac,t1bc,t3a,t3b,ifvo) - implicit none - real*8 one,zero,sumt3 - parameter (one=1.d0,zero=0.d0) - logical ifvo - integer nadim,adim,noab,nuab,i,j,k,nga,iasblock(3),lu(2),N - integer ias,nga_offset,ngc_offset,nug_offset,jk,ij,ik,ncdim,cdim - integer a,b,c,bc,abc,nug,nnoab,ngc,iasci,iasai - real*8 ka(adim*cdim,N,*),kc(cdim*(cdim-1)/2,N,*),kb(*) - real*8 t3a(cdim,cdim,*),t3b(*),t1ac(noab,*),t1bc(noab,*) - real*8 lc(N*cdim,nnoab),la(N*adim,nnoab) - real*8 mi(*),mij(*),voa(adim*cdim,*),voc(cdim*(cdim-1)/2,*) - real*8 t1aa(noab,*),t1ba(noab,*),enx,oeh(noab),oepa(adim) - real*8 oepc(cdim),den,dena,denb,denc,xx,yy -C - sumt3=0.d0 - if(cdim.eq.1)return - ncdim=cdim*(cdim-1)/2 - nadim=adim*cdim - nug_offset=iasblock(1)*nug*(nug+1)/2 - ias=iasblock(2)*(nga-1)+1 - call multi_readir(la,nnoab*adim*N,lu(2),ias) - ias=iasblock(2)*(ngc-1)+1 - call multi_readir(lc,nnoab*cdim*N,lu(2),ias) -C reads vvoo - nga_offset=iasblock(3)*(nga*(nga-1)/2+ngc-1)+1 - ngc_offset=iasblock(3)*(ngc*(ngc-1)/2+ngc-1)+1 - ias=iasblock(2)*nug+nga_offset - call multi_readir(voa,nnoab*nadim,lu(2),ias) - ias=iasblock(2)*nug+ngc_offset - call multi_readir(voc,nnoab*ncdim,lu(2),ias) -C - nga_offset=iasblock(1)*(nga*(nga-1)/2+ngc-1)+1 - ngc_offset=iasblock(1)*(ngc*(ngc-1)/2+ngc-1)+1 - do i=1,noab - iasci=(i-1)*nug_offset+ngc_offset - call multi_readir(kc(1,1,i),N*ncdim,lu(1),iasci) - iasai=(i-1)*nug_offset+nga_offset - call multi_readir(ka(1,1,i),N*nadim,lu(1),iasai) - enddo - do i=3,noab - jk=0 - do j=2,i-1 - ij=(i-1)*(i-2)/2+j - ik=(i-1)*(i-2)/2 - do k=1,j-1 - jk=jk+1 - ik=ik+1 -C K_ab^ir x L_rc^jk (stored as c,b,a) - call DGEMM_('T','T',cdim,nadim,N,one, lc(1,jk),N, - $ ka(1,1,i),nadim,zero,t3a,cdim) -C K_ab^kr x L_rc^ij - call DGEMM_('T','T',cdim,nadim,N,one, lc(1,ij),N,ka(1,1,k), - $ nadim,one,t3a,cdim) -C -K_ab^jr x L_rc^ik - call DGEMM_('T','T',cdim,nadim,N,-one,lc(1,ik),N,ka(1,1,j), - $ nadim,one,t3a,cdim) -C -C K_bc^ir x L_ra^jk - call DGEMM_('N','N',ncdim,adim,N,one,kc(1,1,i),ncdim,la(1,jk),N, - $ zero,t3b,ncdim) -C K_bc^kr x L_ra^ij - call DGEMM_('N','N',ncdim,adim,N,one,kc(1,1,k),ncdim,la(1,ij),N, - $ one,t3b,ncdim) -C -K_bc^jr x L_ra^ik - call DGEMM_('N','N',ncdim,adim,N,-one,kc(1,1,j),ncdim, - & la(1,ik),N, - $ one,t3b,ncdim) -!! - den=oeh(i)+oeh(j)+oeh(k) - abc=0 - do a=1,adim - dena=den-oepa(a) - bc=0 - do b=2,cdim - denb=dena-oepc(b) - do c=1,b-1 - denc=denb-oepc(c) - bc=bc+1 - abc=abc+1 - xx=t3b(abc)-t3a(b,c,a)+t3a(c,b,a) - yy=xx/denc - t3b(abc)=yy - sumt3=sumt3+xx - enx=enx+yy*xx - enddo - enddo - enddo - call expa1_uhf(t3b,adim,cdim,-1,t3a) -C t3a bac -C blok1 voa ka - call DGEMM_('N','T',1,cdim,nadim,-one,voa(1,ij),1, - $ t3a,cdim,one,t1ac(k,1),noab) - call DGEMM_('N','T',1,cdim,nadim,-one,voa(1,jk),1, - $ t3a,cdim,one,t1ac(i,1),noab) - call DGEMM_('N','T',1,cdim,nadim, one,voa(1,ik),1, - $ t3a,cdim,one,t1ac(j,1),noab) -C blok 2 t3b bca - call DGEMM_('N','N',1,adim,ncdim,one, voc(1,ij),1, - $ t3b,ncdim,one,t1aa(k,1),noab) - call DGEMM_('N','N',1,adim,ncdim,one, voc(1,jk),1, - $ t3b,ncdim,one,t1aa(i,1),noab) - call DGEMM_('N','N',1,adim,ncdim,-one,voc(1,ik),1, - $ t3b,ncdim,one,t1aa(j,1),noab) - if(ifvo)then - call DGEMM_('N','T',1,cdim,nadim,-one,ka(1,i,j),1, - $ t3a,cdim,one,t1bc(k,1),noab) - call DGEMM_('N','T',1,cdim,nadim,-one,ka(1,j,k),1, - $ t3a,cdim,one,t1bc(i,1),noab) - call DGEMM_('N','T',1,cdim,nadim, one,ka(1,i,k),1, - $ t3a,cdim,one,t1bc(j,1),noab) - call DGEMM_('N','N',1,adim,ncdim,one, kc(1,i,j),1, - $ t3b,ncdim,one,t1ba(k,1),noab) - call DGEMM_('N','N',1,adim,ncdim,one, kc(1,j,k),1, - $ t3b,ncdim,one,t1ba(i,1),noab) - call DGEMM_('N','N',1,adim,ncdim,-one,kc(1,i,k),1, - $ t3b,ncdim,one,t1ba(j,1),noab) - endif - enddo !k - enddo !j - enddo !i - return -c Avoid unused argument warnings - if (.false.) then - call Unused_real_array(kb) - call Unused_real_array(mi) - call Unused_real_array(mij) - call Unused_integer(nuab) - end if - end diff -Nru openmolcas-22.02/src/cht3/t3_bt_acc.F90 openmolcas-22.10/src/cht3/t3_bt_acc.F90 --- openmolcas-22.02/src/cht3/t3_bt_acc.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/t3_bt_acc.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,122 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine t3_bt_acc(nug,ka,kc,la,lc,adim,cdim,N,noab,nnoab,lu,iasblock,nga,ngc,oeh,oepa,oepc,enx,voa,voc,t1aa,t1ba,t1ac,t1bc,t3a, & + t3b,ifvo) + +use Constants, only: Zero, One +use Index_Functions, only: nTri_Elem +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: nug, adim, cdim, N, noab, nnoab, lu(2), iasblock(3), nga, ngc +real(kind=wp), intent(_OUT_) :: ka(adim*cdim,N,*), kc(nTri_Elem(cdim-1),N,*), voa(adim*cdim,*), voc(nTri_Elem(cdim-1),*), & + t3a(cdim,cdim,*), t3b(*) +real(kind=wp), intent(out) :: la(N*adim,nnoab), lc(N*cdim,nnoab) +real(kind=wp), intent(in) :: oeh(noab), oepa(adim), oepc(cdim) +real(kind=wp), intent(inout) :: enx, t1aa(noab,*), t1ba(noab,*), t1ac(noab,*), t1bc(noab,*) +logical(kind=iwp), intent(in) :: ifvo +integer(kind=iwp) :: a, abc, b, bc, c, i, ias, iasai, iasci, ij, ik, j, jk, k, nadim, ncdim, nga_offset, ngc_offset, nug_offset +real(kind=wp) :: den, dena, denb, denc, sumt3, xx, yy + +sumt3 = Zero +if (cdim == 1) return +ncdim = nTri_Elem(cdim-1) +nadim = adim*cdim +nug_offset = iasblock(1)*nTri_Elem(nug) +ias = iasblock(2)*(nga-1)+1 +call multi_readir(la,nnoab*adim*N,lu(2),ias) +ias = iasblock(2)*(ngc-1)+1 +call multi_readir(lc,nnoab*cdim*N,lu(2),ias) +! reads vvoo +nga_offset = iasblock(3)*(nTri_Elem(nga-1)+ngc-1)+1 +ngc_offset = iasblock(3)*(nTri_Elem(ngc-1)+ngc-1)+1 +ias = iasblock(2)*nug+nga_offset +call multi_readir(voa,nnoab*nadim,lu(2),ias) +ias = iasblock(2)*nug+ngc_offset +call multi_readir(voc,nnoab*ncdim,lu(2),ias) + +nga_offset = iasblock(1)*(nTri_Elem(nga-1)+ngc-1)+1 +ngc_offset = iasblock(1)*(nTri_Elem(ngc-1)+ngc-1)+1 +do i=1,noab + iasci = (i-1)*nug_offset+ngc_offset + call multi_readir(kc(:,:,i),N*ncdim,lu(1),iasci) + iasai = (i-1)*nug_offset+nga_offset + call multi_readir(ka(:,:,i),N*nadim,lu(1),iasai) +end do +do i=3,noab + jk = 0 + do j=2,i-1 + ij = nTri_Elem(i-2)+j + ik = nTri_Elem(i-2) + do k=1,j-1 + jk = jk+1 + ik = ik+1 + ! K_ab^ir x L_rc^jk (stored as c,b,a) + call DGEMM_('T','T',cdim,nadim,N,one,lc(:,jk),N,ka(:,:,i),nadim,zero,t3a,cdim) + ! K_ab^kr x L_rc^ij + call DGEMM_('T','T',cdim,nadim,N,one,lc(:,ij),N,ka(:,:,k),nadim,one,t3a,cdim) + ! -K_ab^jr x L_rc^ik + call DGEMM_('T','T',cdim,nadim,N,-one,lc(:,ik),N,ka(:,:,j),nadim,one,t3a,cdim) + + ! K_bc^ir x L_ra^jk + call DGEMM_('N','N',ncdim,adim,N,one,kc(:,:,i),ncdim,la(:,jk),N,zero,t3b,ncdim) + ! K_bc^kr x L_ra^ij + call DGEMM_('N','N',ncdim,adim,N,one,kc(:,:,k),ncdim,la(:,ij),N,one,t3b,ncdim) + ! -K_bc^jr x L_ra^ik + call DGEMM_('N','N',ncdim,adim,N,-one,kc(:,:,j),ncdim,la(:,ik),N,one,t3b,ncdim) + + den = oeh(i)+oeh(j)+oeh(k) + abc = 0 + do a=1,adim + dena = den-oepa(a) + bc = 0 + do b=2,cdim + denb = dena-oepc(b) + do c=1,b-1 + denc = denb-oepc(c) + bc = bc+1 + abc = abc+1 + xx = t3b(abc)-t3a(b,c,a)+t3a(c,b,a) + yy = xx/denc + t3b(abc) = yy + sumt3 = sumt3+xx + enx = enx+yy*xx + end do + end do + end do + call expa1_uhf(t3b,adim,cdim,-1,t3a) + ! t3a bac + ! blok1 voa ka + call DGEMM_('N','T',1,cdim,nadim,-one,voa(:,ij),1,t3a,cdim,one,t1ac(k,1),noab) + call DGEMM_('N','T',1,cdim,nadim,-one,voa(:,jk),1,t3a,cdim,one,t1ac(i,1),noab) + call DGEMM_('N','T',1,cdim,nadim,one,voa(:,ik),1,t3a,cdim,one,t1ac(j,1),noab) + ! blok 2 t3b bca + call DGEMM_('N','N',1,adim,ncdim,one,voc(:,ij),1,t3b,ncdim,one,t1aa(k,1),noab) + call DGEMM_('N','N',1,adim,ncdim,one,voc(:,jk),1,t3b,ncdim,one,t1aa(i,1),noab) + call DGEMM_('N','N',1,adim,ncdim,-one,voc(:,ik),1,t3b,ncdim,one,t1aa(j,1),noab) + if (ifvo) then + call DGEMM_('N','T',1,cdim,nadim,-one,ka(:,i,j),1,t3a,cdim,one,t1bc(k,1),noab) + call DGEMM_('N','T',1,cdim,nadim,-one,ka(:,j,k),1,t3a,cdim,one,t1bc(i,1),noab) + call DGEMM_('N','T',1,cdim,nadim,one,ka(:,i,k),1,t3a,cdim,one,t1bc(j,1),noab) + call DGEMM_('N','N',1,adim,ncdim,one,kc(:,i,j),1,t3b,ncdim,one,t1ba(k,1),noab) + call DGEMM_('N','N',1,adim,ncdim,one,kc(:,j,k),1,t3b,ncdim,one,t1ba(i,1),noab) + call DGEMM_('N','N',1,adim,ncdim,-one,kc(:,i,k),1,t3b,ncdim,one,t1ba(j,1),noab) + end if + end do !k + end do !j +end do !i + +return + +end subroutine t3_bt_acc diff -Nru openmolcas-22.02/src/cht3/t3loopa.f openmolcas-22.10/src/cht3/t3loopa.f --- openmolcas-22.02/src/cht3/t3loopa.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/t3loopa.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,191 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE t3loopa(oeh,oep,t1a,t1b,nga,ngb,ngc,vblock,energ, - $ isp,LU,ifvo,lastcall,scored,jjj,enx) -cmp SUBROUTINE t3loopa(oeh,oep,t1a,t1b,g,nga,ngb,ngc,vblock,energ, -C implemented integer offsets, PV, 16 may 2004. - IMPLICIT NONE -#include "ndisk.fh" -#include "WrkSpc.fh" -cmp real*8 g(*),energ(*),oeh(*),oep(*),enx,t1a(*),t1b(*) - real*8 energ(*),oeh(*),oep(*),enx,t1a(*),t1b(*) - integer nug - integer isp,vblock,n,lu(*),nga,ngb,ngc,adim,bdim,cdim - INTEGER iasblock(3),aset,bset,cset - logical ifvo,lastcall,scored - INTEGER IUHF -cmp - integer jjj -cmp -#include "uhf.fh" -#include "ioind.fh" - integer ka,kb,kc,la,lb,lc,t3a,t3b,voa,vob,voc,mi,mij - SAVE ka,kb,kc,la,lb,lc,t3a,t3b,voa,vob,voc,mi,mij, - $ iasblock,iuhf,nug -C - N=noab(isp)+nuab(isp) - enx=0.d0 - scored=.true. -cmp!!! if (lastcall) goto 321 -cmp write (6,*) 'NOAB,NNOAB,NUAB,NNUAB,ICH' -cmp write (6,*) NOAB,NNOAB,NUAB,NNUAB,ICH -cmp!!! if(energ(isp).eq.0.d0)then -C this is a first entry - initialization (makes no harm if reapeated) - nug=nuab(isp)/vblock - if((nug*vblock).lt.nuab(isp))nug=nug+1 -cmp write(6,*)'first,nug,vblock',nug,vblock,iopt(76) - IUHF=isp - !!IF(IOPT(76).eq.0)IUHF=3 - iasblock(1)=vblock*vblock*N/nblock - if((iasblock(1)*nblock).lt.(vblock*vblock*N)) - $ iasblock(1)=iasblock(1)+1 - iasblock(2)=nnoab(iuhf)*vblock*N/nblock - if((iasblock(2)*nblock).lt.(nnoab(iuhf)*vblock*N)) - $iasblock(2)=iasblock(2)+1 - iasblock(3)=nnoab(iuhf)*vblock*vblock/nblock - if((iasblock(3)*nblock).lt.(nnoab(iuhf)*vblock*vblock)) - $iasblock(3)=iasblock(3)+1 -cmp call w_rescope(G,'G3loopa') -cmp call w_free(g,0,'G3loopa') -c allocations -cmp call w_alloc(ka,noab(isp)*vblock*vblock*n,'kaT3loopa') - call GetMem('loopa_ka','Allo','Real',ka,noab(isp)*vblock*vblock*n) - if(nug.ne.1)then -cmp call w_alloc(kb,noab(isp)*vblock*vblock*n,'kbT3loopa') - call GetMem('loopa_kb','Allo','Real',kb,noab(isp)*vblock*vblock*n) -cmp call w_alloc(kc,noab(isp)*vblock*vblock*n,'kcT3loopa') - call GetMem('loopa_kc','Allo','Real',kc,noab(isp)*vblock*vblock*n) - endif -cmp call w_alloc(la,nnoab(IUHF)*vblock*n,'laT3loopa') - call GetMem('loopa_la','Allo','Real',la,nnoab(IUHF)*vblock*n) -cmp call w_alloc(lb,nnoab(IUHF)*vblock*n,'lbT3loopa') - call GetMem('loopa_lb','Allo','Real',lb,nnoab(IUHF)*vblock*n) -cmp call w_alloc(lc,nnoab(IUHF)*vblock*n,'lcT3loopa') - call GetMem('loopa_lc','Allo','Real',lc,nnoab(IUHF)*vblock*n) -cmp call w_alloc(t3a,vblock*vblock*vblock,'t3aT3loopa') - call GetMem('loopa_t3a','Allo','Real',t3a,vblock*vblock*vblock) -cmp call w_alloc(t3b,vblock*vblock*vblock,'t3bT3loopa') - call GetMem('loopa_t3b','Allo','Real',t3b,vblock*vblock*vblock) -cmp call w_alloc(voa,vblock*vblock*nnoab(IUHF),'voaT3loopa') - call GetMem('loopa_voa','Allo','Real', - & voa,vblock*vblock*nnoab(IUHF)) -cmp call w_alloc(vob,vblock*vblock*nnoab(IUHF),'vobT3loopa') - call GetMem('loopa_vob','Allo','Real', - & vob,vblock*vblock*nnoab(IUHF)) -cmp call w_alloc(voc,vblock*vblock*nnoab(IUHF),'vocT3loopa') - call GetMem('loopa_voc','Allo','Real', - & voc,vblock*vblock*nnoab(IUHF)) -C this is necessary -C prefactors currently a formal allocation -cmp ? call w_alloc(mi,1,'miT3loopa') -cmp ? call w_alloc(mij,1,'T3loopa') - call GetMem('loopa_mi','Allo','Real',mi,1) - call GetMem('loopa_mij','Allo','Real',mij,1) - -cmp!!! endif ! energ - initialization - aset=(nga-1)*vblock - adim=min(vblock,nuab(isp)-aset) - bset=(ngb-1)*vblock - bdim=min(vblock,nuab(isp)-bset) - cset=(ngc-1)*vblock - cdim=min(vblock,nuab(isp)-cset) -C -C case1 nga=ngb=ngc -C if memory is available loops over i,j,k, in subloops can be grouped !!! - if(nga.eq.ngc) then -C -cmp call t3_bt_aaa(nug,g(ka),g(ka),g(ka),g(la),g(mi),g(mij), - call t3_bt_aaa(nug,Work(ka),Work(ka),Work(ka),Work(la), - &Work(mi),Work(mij), - $adim,N,noab(isp),nuab(isp),nnoab(iuhf),lu,iasblock,nga,oeh, - $oep(aset+1),enx,Work(voa), - $t1a(noab(isp)*aset+1),t1b(noab(isp)*aset+1),Work(t3a),Work(t3b), - &ifvo) -cmp $oep(aset+1),enx,g(voa), -cmp $t1a(noab(isp)*aset+1),t1b(noab(isp)*aset+1),g(t3a),g(t3b),ifvo) -C - elseif(nga.eq.ngb)then -cmp call t3_bt_aac(nug,g(ka),g(kb),g(kc),g(la),g(lc),g(mi),g(mij), - call t3_bt_aac(nug,Work(ka),Work(kb),Work(kc),Work(la),Work(lc), - &Work(mi),Work(mij), - $adim,cdim,N,noab(isp),nuab(isp),nnoab(iuhf),lu,iasblock,nga,ngc, - $oeh,oep(aset+1),oep(cset+1),enx,Work(voa),Work(voc), - $t1a(noab(isp)*aset+1),t1b(noab(isp)*aset+1), - $t1a(noab(isp)*cset+1),t1b(noab(isp)*cset+1), - $Work(t3a),Work(t3b),ifvo) -cmp $oeh,oep(aset+1),oep(cset+1),enx,g(voa),g(voc), -cmp $t1a(noab(isp)*aset+1),t1b(noab(isp)*aset+1), -cmp $t1a(noab(isp)*cset+1),t1b(noab(isp)*cset+1), -cmp $g(t3a),g(t3b),ifvo) - elseif(ngb.eq.ngc)then -cmp call t3_bt_acc(nug,g(ka),g(kb),g(kc),g(la),g(lc),g(mi),g(mij), - call t3_bt_acc(nug,Work(ka),Work(kb),Work(kc),Work(la),Work(lc), - &Work(mi),Work(mij), - $adim,cdim,N,noab(isp),nuab(isp),nnoab(iuhf),lu,iasblock,nga,ngc, - $oeh,oep(aset+1),oep(cset+1),enx,Work(voa),Work(voc), - $t1a(noab(isp)*aset+1),t1b(noab(isp)*aset+1), - $t1a(noab(isp)*cset+1),t1b(noab(isp)*cset+1), - $Work(t3a),Work(t3b),ifvo) -cmp $oeh,oep(aset+1),oep(cset+1),enx,g(voa),g(voc), -cmp $t1a(noab(isp)*aset+1),t1b(noab(isp)*aset+1), -cmp $t1a(noab(isp)*cset+1),t1b(noab(isp)*cset+1), -cmp $g(t3a),g(t3b),ifvo) - else -cmp call t3_bt_abc(nug,g(ka),g(kb),g(kc),g(la),g(lb),g(lc),g(mi), -cmp $g(mij),adim,bdim,cdim,N,noab(isp),nuab(isp),nnoab(iuhf),lu, - call t3_bt_abc(nug,Work(ka),Work(kb),Work(kc),Work(la),Work(lb), - &Work(lc),Work(mi), - $Work(mij),adim,bdim,cdim,N,noab(isp),nuab(isp),nnoab(iuhf),lu, - $iasblock,nga,ngb,ngc, - $oeh,oep(aset+1),oep(bset+1),oep(cset+1),enx,Work(voa),Work(vob), - &Work(voc), - $t1a(noab(isp)*aset+1),t1b(noab(isp)*aset+1),t1a(noab(isp)*bset+1), - $t1b(noab(isp)*bset+1),t1a(noab(isp)*cset+1),t1b(noab(isp)*cset+1), - $Work(t3a),Work(t3b),ifvo) -cmp $oeh,oep(aset+1),oep(bset+1),oep(cset+1),enx,g(voa),g(vob),g(voc), -cmp $t1a(noab(isp)*aset+1),t1b(noab(isp)*aset+1),t1a(noab(isp)*bset+1), -cmp $t1b(noab(isp)*bset+1),t1a(noab(isp)*cset+1),t1b(noab(isp)*cset+1), -cmp $g(t3a),g(t3b),ifvo) - endif ! cases - energ(isp)=energ(isp)+enx -cmp write (*,'(A,i5,x,3(i3,1x),f21.19)') 'Tsk, nga, ngb, ngc, inc = ', -cmp & jjj,nga,ngb,ngc,enx -cmp -c321 continue -cmp write (6,*) -cmp write (6,*) 'deallocating arrays in t3loopa' -cmp write (6,*) - call GetMem('loopa_mij','Free','Real',mij,1) - call GetMem('loopa_mi','Free','Real',mi,1) - call GetMem('loopa_voc','Free','Real', - & voc,vblock*vblock*nnoab(IUHF)) - call GetMem('loopa_vob','Free','Real', - & vob,vblock*vblock*nnoab(IUHF)) - call GetMem('loopa_voa','Free','Real', - & voa,vblock*vblock*nnoab(IUHF)) - call GetMem('loopa_t3b','Free','Real',t3b,vblock*vblock*vblock) - call GetMem('loopa_t3a','Free','Real',t3a,vblock*vblock*vblock) - call GetMem('loopa_lc','Free','Real',lc,nnoab(IUHF)*vblock*n) - call GetMem('loopa_lb','Free','Real',lb,nnoab(IUHF)*vblock*n) - call GetMem('loopa_la','Free','Real',la,nnoab(IUHF)*vblock*n) - if(nug.ne.1)then - call GetMem('loopa_kc','Free','Real',kc,noab(isp)*vblock*vblock*n) - call GetMem('loopa_kb','Free','Real',kb,noab(isp)*vblock*vblock*n) - endif - call GetMem('loopa_ka','Free','Real',ka,noab(isp)*vblock*vblock*n) -cmp - return -c Avoid unused argument warnings - if (.false.) then - call Unused_logical(lastcall) - call Unused_integer(jjj) - end if - end diff -Nru openmolcas-22.02/src/cht3/t3loopa.F90 openmolcas-22.10/src/cht3/t3loopa.F90 --- openmolcas-22.02/src/cht3/t3loopa.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/t3loopa.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,144 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine t3loopa(oeh,oep,t1a,t1b,nga,ngb,ngc,vblock,energ,isp,LU,ifvo,scored,enx) +!mp subroutine t3loopa(oeh,oep,t1a,t1b,g,nga,ngb,ngc,vblock,energ, +! implemented integer offsets, PV, 16 may 2004. + +use ChT3_global, only: nblock, NNOAB, NOAB, NUAB +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(in) :: oeh(*), oep(*) +real(kind=wp), intent(inout) :: t1a(*), t1b(*), energ(*) +integer(kind=iwp), intent(in) :: nga, ngb, ngc, vblock, isp, LU(*) +logical(kind=iwp), intent(in) :: ifvo +logical(kind=iwp), intent(out) :: scored +real(kind=wp), intent(out) :: enx +integer(kind=iwp) :: adim, aset, bdim, bset, cdim, cset, iasblock(3), IUHF, n, nug +real(kind=wp), allocatable :: ka(:), la(:), lb(:), lc(:), t3a(:), t3b(:), voa(:), vob(:), voc(:) +real(kind=wp), allocatable, save :: kb(:), kc(:) + +N = noab(isp)+nuab(isp) +enx = Zero +scored = .true. +!mp !!!if (.not. lastcall) then +!mp write(u6,*) 'NOAB,NNOAB,NUAB,NNUAB,ICH' +!mp write(u6,*) NOAB,NNOAB,NUAB,NNUAB,ICH +!mp !!!if (energ(isp) == Zero) then +! this is a first entry - initialization (makes no harm if repeated) +nug = nuab(isp)/vblock +if ((nug*vblock) < nuab(isp)) nug = nug+1 +!mp write(u6,*) 'first,nug,vblock',nug,vblock,iopt(1) +IUHF = isp +!!if (IOPT(1) == 0) IUHF = 3 +iasblock(1) = vblock*vblock*N/nblock +if (iasblock(1)*nblock < vblock*vblock*N) iasblock(1) = iasblock(1)+1 +iasblock(2) = nnoab(iuhf)*vblock*N/nblock +if (iasblock(2)*nblock < nnoab(iuhf)*vblock*N) iasblock(2) = iasblock(2)+1 +iasblock(3) = nnoab(iuhf)*vblock*vblock/nblock +if (iasblock(3)*nblock < nnoab(iuhf)*vblock*vblock) iasblock(3) = iasblock(3)+1 +!mp call w_rescope(G,'G3loopa') +!mp call w_free(g,0,'G3loopa') +! allocations +!mp call w_alloc(ka,noab(isp)*vblock*vblock*n,'kaT3loopa') +call mma_allocate(ka,noab(isp)*vblock*vblock*n,label='loopa_ka') +if (nug /= 1) then + !mp call w_alloc(kb,noab(isp)*vblock*vblock*n,'kbT3loopa') + call mma_allocate(kb,noab(isp)*vblock*vblock*n,label='loopa_kb') + !mp call w_alloc(kc,noab(isp)*vblock*vblock*n,'kcT3loopa') + call mma_allocate(kc,noab(isp)*vblock*vblock*n,label='loopa_kc') +end if +!mp call w_alloc(la,nnoab(IUHF)*vblock*n,'laT3loopa') +call mma_allocate(la,nnoab(IUHF)*vblock*n,label='loopa_la') +!mp call w_alloc(lb,nnoab(IUHF)*vblock*n,'lbT3loopa') +call mma_allocate(lb,nnoab(IUHF)*vblock*n,label='loopa_lb') +!mp call w_alloc(lc,nnoab(IUHF)*vblock*n,'lcT3loopa') +call mma_allocate(lc,nnoab(IUHF)*vblock*n,label='loopa_lc') +!mp call w_alloc(t3a,vblock*vblock*vblock,'t3aT3loopa') +call mma_allocate(t3a,vblock*vblock*vblock,label='loopa_t3a') +!mp call w_alloc(t3b,vblock*vblock*vblock,'t3bT3loopa') +call mma_allocate(t3b,vblock*vblock*vblock,label='loopa_t3b') +!mp call w_alloc(voa,vblock*vblock*nnoab(IUHF),'voaT3loopa') +call mma_allocate(voa,vblock*vblock*nnoab(IUHF),label='loopa_voa') +!mp call w_alloc(vob,vblock*vblock*nnoab(IUHF),'vobT3loopa') +call mma_allocate(vob,vblock*vblock*nnoab(IUHF),label='loopa_vob') +!mp call w_alloc(voc,vblock*vblock*nnoab(IUHF),'vocT3loopa') +call mma_allocate(voc,vblock*vblock*nnoab(IUHF),label='loopa_voc') +! this is necessary +! prefactors currently a formal allocation +!mp ? call w_alloc(mi,1,'miT3loopa') +!mp ? call w_alloc(mij,1,'T3loopa') + +!mp !!!end if ! energ - initialization +aset = (nga-1)*vblock +adim = min(vblock,nuab(isp)-aset) +bset = (ngb-1)*vblock +bdim = min(vblock,nuab(isp)-bset) +cset = (ngc-1)*vblock +cdim = min(vblock,nuab(isp)-cset) + +! case1 nga=ngb=ngc +! if memory is available loops over i,j,k, in subloops can be grouped !!! +if (nga == ngc) then + + !mp call t3_bt_aaa(nug,g(ka),g(ka),g(ka),g(la),g(mi),g(mij),adim,N,noab(isp),nuab(isp),nnoab(iuhf),lu,iasblock,nga,oeh, & + !mp oep(aset+1),enx,g(voa),t1a(noab(isp)*aset+1),t1b(noab(isp)*aset+1),g(t3a),g(t3b),ifvo) + call t3_bt_aaa(nug,ka,la,adim,N,noab(isp),nnoab(iuhf),lu,iasblock,nga,oeh,oep(aset+1),enx,voa,t1a(noab(isp)*aset+1), & + t1b(noab(isp)*aset+1),t3a,t3b,ifvo) + +else if (nga == ngb) then + !mp call t3_bt_aac(nug,g(ka),g(kb),g(kc),g(la),g(lc),g(mi),g(mij),adim,cdim,N,noab(isp),nuab(isp),nnoab(iuhf),lu,iasblock,nga, & + !mp ngc,oeh,oep(aset+1),oep(cset+1),enx,g(voa),g(voc),t1a(noab(isp)*aset+1),t1b(noab(isp)*aset+1), & + !mp t1a(noab(isp)*cset+1),t1b(noab(isp)*cset+1),g(t3a),g(t3b),ifvo) + call t3_bt_aac(nug,ka,kc,la,lc,adim,cdim,N,noab(isp),nnoab(iuhf),lu,iasblock,nga,ngc,oeh,oep(aset+1),oep(cset+1),enx,voa,voc, & + t1a(noab(isp)*aset+1),t1b(noab(isp)*aset+1),t1a(noab(isp)*cset+1),t1b(noab(isp)*cset+1),t3a,t3b,ifvo) +else if (ngb == ngc) then + !mp call t3_bt_acc(nug,g(ka),g(kb),g(kc),g(la),g(lc),g(mi),g(mij),adim,cdim,N,noab(isp),nuab(isp),nnoab(iuhf),lu,iasblock,nga, & + !mp ngc,oeh,oep(aset+1),oep(cset+1),enx,g(voa),g(voc),t1a(noab(isp)*aset+1),t1b(noab(isp)*aset+1), & + !mp t1a(noab(isp)*cset+1),t1b(noab(isp)*cset+1),g(t3a),g(t3b),ifvo) + call t3_bt_acc(nug,ka,kc,la,lc,adim,cdim,N,noab(isp),nnoab(iuhf),lu,iasblock,nga,ngc,oeh,oep(aset+1),oep(cset+1),enx,voa,voc, & + t1a(noab(isp)*aset+1),t1b(noab(isp)*aset+1),t1a(noab(isp)*cset+1),t1b(noab(isp)*cset+1),t3a,t3b,ifvo) +else + !mp call t3_bt_abc(nug,g(ka),g(kb),g(kc),g(la),g(lb),g(lc),g(mi),g(mij),adim,bdim,cdim,N,noab(isp),nuab(isp),nnoab(iuhf),lu, & + !mp iasblock,nga,ngb,ngc,oeh,oep(aset+1),oep(bset+1),oep(cset+1),enx,g(voa),g(vob),g(voc),t1a(noab(isp)*aset+1), & + !mp t1b(noab(isp)*aset+1),t1a(noab(isp)*bset+1),t1b(noab(isp)*bset+1),t1a(noab(isp)*cset+1), & + !mp t1b(noab(isp)*cset+1),g(t3a),g(t3b),ifvo) + call t3_bt_abc(nug,ka,kb,kc,la,lb,lc,adim,bdim,cdim,N,noab(isp),nnoab(iuhf),lu,iasblock,nga,ngb,ngc,oeh,oep(aset+1),oep(bset+1), & + oep(cset+1),enx,voa,vob,voc,t1a(noab(isp)*aset+1),t1b(noab(isp)*aset+1),t1a(noab(isp)*bset+1), & + t1b(noab(isp)*bset+1),t1a(noab(isp)*cset+1),t1b(noab(isp)*cset+1),t3a,t3b,ifvo) +end if ! cases +energ(isp) = energ(isp)+enx +!mp write(u6,'(A,3(i3,1x),f21.19)') 'nga, ngb, ngc, inc = ',nga,ngb,ngc,enx +!mp +!mp !!!end if ! lastcall +!mp write(u6,*) +!mp write(u6,*) 'deallocating arrays in t3loopa' +!mp write(u6,*) +call mma_deallocate(voc) +call mma_deallocate(vob) +call mma_deallocate(voa) +call mma_deallocate(t3a) +call mma_deallocate(t3b) +call mma_deallocate(lc) +call mma_deallocate(lb) +call mma_deallocate(la) +if (nug /= 1) then + call mma_deallocate(kc) + call mma_deallocate(kb) +end if +call mma_deallocate(ka) + +return + +end subroutine t3loopa diff -Nru openmolcas-22.02/src/cht3/t3loopb.f openmolcas-22.10/src/cht3/t3loopb.f --- openmolcas-22.02/src/cht3/t3loopb.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/t3loopb.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,285 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE t3loopb(oeh,oep,t1a,t1b,nga,ngb,ngc,vblock,energ, - $ isp,LU,ifvo,lastcall,scored,jjj,enx) -cmp SUBROUTINE t3loopb(oeh,oep,t1a,t1b,g,nga,ngb,ngc,vblock,energ, -C implemented integer offsets, PV, 16 may 2004. - IMPLICIT NONE -#include "ndisk.fh" -#include "WrkSpc.fh" -cmp real*8 g(*),energ(*),oeh(*),oep(*),enx,t1a(*),t1b(*) - real*8 energ(*),oeh(*),oep(*),enx,t1a(*),t1b(*) - logical ifvo,lastcall,scored - integer isp,vblock,n,lu(6),nga,ngb,ngc,adim,bdim,cdim - integer en_offset_ah,en_offset_bh,en_offset_ap,en_offset_bp - integer t1_offset_a,t1_offset_b - integer nuga,nugc - INTEGER iasblock(5),aset,bset,cset -cmp - integer jjj -cmp -#include "uhf.fh" -#include "ioind.fh" - integer kab,kca,kcb,kac,kbc,kc,la,lb,lxa,lxb,lxc,t3a,t3b, - $ vab,vbc,vac,mij,mi -cmp SAVE kab,kca,kcb,kac,kbc,kc,la,lb,lxa,lxb,lxc,t3a,t3b, -cmp $ vab,vbc,vac,mij,mi, -cmp $ iasblock,nuga,nugc -C - en_offset_ah=(isp-1)*noab(1) - en_offset_bh=(2-isp)*noab(1) - en_offset_ap=(isp-1)*nuab(1) - en_offset_bp=(2-isp)*nuab(1) - t1_offset_a=(isp-1)*noab(1)*nuab(1) - t1_offset_b=(2-isp)*noab(1)*nuab(1) - N=noab(isp)+nuab(isp) -c -cmp - scored=.true. -cmp!!! if (lastcall) goto 321 -cmp - enx=0.d0 -cmpn write (*,*) 'Bef isp, energ(isp), enx = ',isp,energ(isp),enx -cmp!!! if(energ(isp).eq.0.d0)then -C this is a first entry - initialization (makes no harm if reapeated) - nuga=nuab(isp)/vblock - if((nuga*vblock).lt.nuab(isp))nuga=nuga+1 -!! write(6,*)'first,nuga,vblock',nuga,vblock - nugc=nuab(3-isp)/vblock - if((nugc*vblock).lt.nuab(3-isp))nugc=nugc+1 -!! write(6,*)'first,nugc,vblock',nugc,vblock - - iasblock(1)=vblock*vblock*N/nblock - if((iasblock(1)*nblock).lt.(vblock*vblock*N)) - $iasblock(1)=iasblock(1)+1 - - iasblock(2)=nnoab(isp)*vblock*N/nblock - if((iasblock(2)*nblock).lt.(nnoab(isp)*vblock*N)) - $iasblock(2)=iasblock(2)+1 - - iasblock(3)=nnoab(3)*vblock*N/nblock - if((iasblock(3)*nblock).lt.(nnoab(3)*vblock*N)) - $iasblock(3)=iasblock(3)+1 - - iasblock(4)=nnoab(isp)*vblock*vblock/nblock - if((iasblock(4)*nblock).lt.(nnoab(isp)*vblock*vblock)) - $iasblock(4)=iasblock(4)+1 - - iasblock(5)=nnoab(3)*vblock*vblock/nblock - if((iasblock(5)*nblock).lt.(nnoab(3)*vblock*vblock)) - $iasblock(5)=iasblock(5)+1 - -cmp call w_rescope(G,'GT3loopb') -cmp call w_free(g,0,'GT3loopb') -c allocations - if(nuga.ne.1)then -cmp call w_alloc(kab,noab(isp)*vblock*vblock*n,'kaT3loopb') - Call GetMem('loopb_kab','Allo','Real',kab, - & noab(isp)*vblock*vblock*n) -cmp call w_alloc(kcb,noab(isp)*vblock*vblock*n,'kbT3loopb') - Call GetMem('loopb_kcb','Allo','Real',kcb, - & noab(isp)*vblock*vblock*n) -cmp call w_alloc(kbc,vblock*vblock*n,'kcT3loopb') - Call GetMem('loopb_kbc','Allo','Real',kbc, - & vblock*vblock*n) - else -cmp call w_alloc(kab,noab(isp)*N*nnuab(isp),'kaT3loopb') - Call GetMem('loopb_kab','Allo','Real',kab, - & noab(isp)*N*nnuab(isp)) - endif -cmp call w_alloc(kac,vblock*vblock*n,'kcT3loopb') - Call GetMem('loopb_kac','Allo','Real',kac, - & vblock*vblock*n) -cmp call w_alloc(kca,noab(isp)*vblock*vblock*n,'kbT3loopb') - Call GetMem('loopb_kca','Allo','Real',kca, - & noab(isp)*vblock*vblock*n) -cmp call w_alloc(kc,vblock*vblock*n,'kcT3loopb') - Call GetMem('loopb_kc','Allo','Real',kc, - & vblock*vblock*n) -cmp call w_alloc(la,nnoab(isp)*vblock*n,'laT3loopb') - Call GetMem('loopb_la','Allo','Real',la, - & nnoab(isp)*vblock*n) -cmp call w_alloc(lxa,nnoab(3)*vblock*n,'lbaT3loopb') - Call GetMem('loopb_lxa','Allo','Real',lxa, - & nnoab(3)*vblock*n) -cmpn write (*,*) 'check lxa' -cmpn write (*,*) 'nnoab(1), (2), (3) = ', -cmpn & nnoab(1),nnoab(2),nnoab(3) -cmpn write (*,*) 'nnuab(1), (2), (3) = ', -cmpn & nnuab(1),nnuab(2),nnuab(3) - if(nuga.ne.1)then -cmp call w_alloc(lb,nnoab(isp)*vblock*n,'lbT3loopb') - Call GetMem('loopb_lb','Allo','Real',lb, - & nnoab(isp)*vblock*n) -cmp call w_alloc(lxb,nnoab(3)*vblock*n,'labT3loopb') - Call GetMem('loopb_lxb','Allo','Real',lxb, - & nnoab(3)*vblock*n) - endif -cmp call w_alloc(lxc,nnoab(3)*vblock*n,'lacT3loopb') - Call GetMem('loopb_lxc','Allo','Real',lxc, - & nnoab(3)*vblock*n) -cmp call w_alloc(t3a,vblock*vblock*vblock,'t3aT3loopb') - Call GetMem('loopb_t3a','Allo','Real',t3a, - & vblock*vblock*vblock) -cmp call w_alloc(t3b,vblock*vblock*vblock,'t3bT3loopb') - Call GetMem('loopb_t3b','Allo','Real',t3b, - & vblock*vblock*vblock) -cmp call w_alloc(vac,vblock*vblock*nnoab(3),'vbcT3loopb') - Call GetMem('loopb_vac','Allo','Real',vac, - & vblock*vblock*nnoab(3)) - if(nuga.ne.1) then -cmp call w_alloc(vab,vblock*vblock*nnoab(isp),'vabT3loopb') - Call GetMem('loopb_vab','Allo','Real',vab, - & vblock*vblock*nnoab(isp)) -cmp call w_alloc(vbc,vblock*vblock*nnoab(3),'vacT3loopb') - Call GetMem('loopb_vbc','Allo','Real',vbc, - & vblock*vblock*nnoab(3)) - else -cmp call w_alloc(vab,nnoab(isp)*nnuab(isp),'vabT3loopb') - Call GetMem('loopb_vab','Allo','Real',vab, - & nnoab(isp)*nnuab(isp)) - endif -cmp call w_alloc(mi,noab(isp)*vblock**3,'miT3loopb') - Call GetMem('loopb_mi','Allo','Real',mi, - & noab(isp)*vblock**3) -cmp -cmpn write (*,*) 'mi check = ',noab(isp)*vblock**3 -cmpn write (*,*) 'nnoab(1), (2), (3) = ', -cmpn & nnoab(1),nnoab(2),nnoab(3) -cmpn write (*,*) 'nnuab(1), (2), (3) = ', -cmpn & nnuab(1),nnuab(2),nnuab(3) -cmp -cmp call w_alloc(mij,N*vblock,'mijT3loopb') - Call GetMem('loopb_mij','Allo','Real',mij, - & N*vblock) -cmp!!! endif ! energ = 0 - initialization -C - aset=(nga-1)*vblock - adim=min(vblock,nuab(isp)-aset) - bset=(ngb-1)*vblock - bdim=min(vblock,nuab(isp)-bset) - cset=(ngc-1)*vblock - cdim=min(vblock,nuab(3-isp)-cset) -C -C case1 nga=ngb=ngc -C - if(nga.eq.ngb) then -C -C -cmp call t3_bta_aac(nuga,nugc,g(kab),g(kca),g(kac),g(kc),g(la),g(lxa), -cmp $g(lxc),g(mi),g(mij),adim,cdim,N,noab(isp),nuab(isp), -cmpn write (*,*) 'ide call t3_bta_aac' - call t3_bta_aac(nuga,nugc,Work(kab),Work(kca),Work(kac),Work(kc), - &Work(la),Work(lxa), - $Work(lxc),Work(mi),Work(mij),adim,cdim,N,noab(isp),nuab(isp), - $noab(3-isp),nuab(3-isp),lu,iasblock,nga,ngc, - $oeh(en_offset_ah+1),oeh(en_offset_bh+1), - $oep(aset+en_offset_ap+1),oep(cset+en_offset_bp+1) - $,enx,Work(vab),Work(vac),t1a(noab(isp)*aset+t1_offset_a+1), - $t1b(noab(isp)*aset+t1_offset_a+1), - $t1a(noab(3-isp)*cset+t1_offset_b+1), - $t1b(noab(3-isp)*cset+t1_offset_b+1),Work(t3a),Work(t3b),ifvo) -cmp $,enx,g(vab),g(vac),t1a(noab(isp)*aset+t1_offset_a+1), -cmp $t1b(noab(isp)*aset+t1_offset_a+1), -cmp $t1a(noab(3-isp)*cset+t1_offset_b+1), -cmp $t1b(noab(3-isp)*cset+t1_offset_b+1),g(t3a),g(t3b),ifvo) - else -cmp call t3_bta_abc(nuga,nugc,g(kab),g(kcb),g(kca),g(kac),g(kbc),g(kc) -cmp $,g(la),g(lb), -cmp $g(lxa),g(lxb),g(lxc),g(mi),g(mij),adim,bdim,cdim,N,noab(isp), -cmpn write (*,*) 'ide call t3_bta_abc' -cmp - call t3_bta_abc(nuga,nugc,Work(kab),Work(kcb),Work(kca),Work(kac), - &Work(kbc),Work(kc),Work(la),Work(lb), - $Work(lxa),Work(lxb),Work(lxc),Work(mi),Work(mij),adim,bdim,cdim, - &N,noab(isp), - $nuab(isp),noab(3-isp),nuab(3-isp),lu,iasblock,nga,ngb,ngc, - $oeh(en_offset_ah+1),oeh(en_offset_bh+1),oep(aset+en_offset_ap+1), - $oep(bset+en_offset_ap+1),oep(cset+en_offset_bp+1) - $,enx,Work(vab),Work(vbc),Work(vac),t1a(noab(isp)*aset+ - &t1_offset_a+1), - $t1b(noab(isp)*aset+t1_offset_a+1), - $t1a(noab(isp)*bset+t1_offset_a+1), - $t1b(noab(isp)*bset+t1_offset_a+1), - $t1a(noab(3-isp)*cset+t1_offset_b+1), - $t1b(noab(3-isp)*cset+t1_offset_b+1),Work(t3a),Work(t3b),ifvo) -cmp $,enx,g(vab),g(vbc),g(vac),t1a(noab(isp)*aset+t1_offset_a+1), -cmp $t1b(noab(isp)*aset+t1_offset_a+1), -cmp $t1a(noab(isp)*bset+t1_offset_a+1), -cmp $t1b(noab(isp)*bset+t1_offset_a+1), -cmp $t1a(noab(3-isp)*cset+t1_offset_b+1), -cmp $t1b(noab(3-isp)*cset+t1_offset_b+1),g(t3a),g(t3b),ifvo) - endif ! cases -cmpn write (*,*) 'isp, energ(isp), enx = ',isp,energ(isp),enx - energ(isp)=energ(isp)+enx -cmp!!! write (*,'(A,i5,x,3(i5,2x),f21.19)') 'Tsk, nga, ngb, ngc, inc = ', -cmp!!! & jjj,nga,ngb,ngc,enx -c321 continue -cmp write (6,*) -cmp write (6,*) 'deallocating arrays in t3loob' -cmp write (6,*) -cmp - Call GetMem('loopb_mij','Free','Real',mij, - & N*vblock) - Call GetMem('loopb_mi','Free','Real',mi, - & noab(isp)*vblock**3) - if(nuga.ne.1) then - Call GetMem('loopb_vbc','Free','Real',vbc, - & vblock*vblock*nnoab(3)) - Call GetMem('loopb_vab','Free','Real',vab, - & vblock*vblock*nnoab(isp)) - else - Call GetMem('loopb_vab','Free','Real',vab, - & nnoab(isp)*nnuab(isp)) - endif - Call GetMem('loopb_vac','Free','Real',vac, - & vblock*vblock*nnoab(3)) - Call GetMem('loopb_t3b','Free','Real',t3b, - & vblock*vblock*vblock) - Call GetMem('loopb_t3a','Free','Real',t3a, - & vblock*vblock*vblock) - Call GetMem('loopb_lxc','Free','Real',lxc, - & nnoab(3)*vblock*n) - if(nuga.ne.1)then - Call GetMem('loopb_lxb','Free','Real',lxb, - & nnoab(3)*vblock*n) - Call GetMem('loopb_lb','Free','Real',lb, - & nnoab(isp)*vblock*n) - endif - Call GetMem('loopb_lxa','Free','Real',lxa, - & nnoab(3)*vblock*n) - Call GetMem('loopb_la','Free','Real',la, - & nnoab(isp)*vblock*n) - Call GetMem('loopb_kc','Free','Real',kc, - & vblock*vblock*n) - Call GetMem('loopb_kca','Free','Real',kca, - & noab(isp)*vblock*vblock*n) - Call GetMem('loopb_kac','Free','Real',kac, - & vblock*vblock*n) - if(nuga.ne.1)then - Call GetMem('loopb_kbc','Free','Real',kbc, - & vblock*vblock*n) - Call GetMem('loopb_kcb','Free','Real',kcb, - & noab(isp)*vblock*vblock*n) - Call GetMem('loopb_kab','Free','Real',kab, - & noab(isp)*vblock*vblock*n) - else - Call GetMem('loopb_kab','Free','Real',kab, - & noab(isp)*N*nnuab(isp)) - endif -cmp - return -c Avoid unused argument warnings - if (.false.) then - call Unused_logical(lastcall) - call Unused_integer(jjj) - end if - end diff -Nru openmolcas-22.02/src/cht3/t3loopb.F90 openmolcas-22.10/src/cht3/t3loopb.F90 --- openmolcas-22.02/src/cht3/t3loopb.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/t3loopb.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,202 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine t3loopb(oeh,oep,t1a,t1b,nga,ngb,ngc,vblock,energ,isp,LU,ifvo,scored,enx) +!mp subroutine t3loopb(oeh,oep,t1a,t1b,g,nga,ngb,ngc,vblock,energ, +! implemented integer offsets, PV, 16 may 2004. + +use ChT3_global, only: nblock, NNOAB, NNUAB, NOAB, NUAB +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(in) :: oeh(*), oep(*) +real(kind=wp), intent(inout) :: t1a(*), t1b(*), energ(*) +integer(kind=iwp), intent(in) :: nga, ngb, ngc, vblock, isp, lu(6) +logical(kind=iwp), intent(in) :: ifvo +logical(kind=iwp), intent(out) :: scored +real(kind=wp), intent(out) :: enx +integer(kind=iwp) :: adim, aset, bdim, bset, cdim, cset, en_offset_ah, en_offset_ap, en_offset_bh, en_offset_bp, iasblock(5), n, & + nuga, nugc, t1_offset_a, t1_offset_b +real(kind=wp), allocatable :: kab(:), kac(:), kbc(:), kc(:), kca(:), kcb(:), la(:), lb(:), lxa(:), lxb(:), lxc(:), mi(:), mij(:), & + t3a(:), t3b(:), vab(:), vac(:), vbc(:) + +en_offset_ah = (isp-1)*noab(1) +en_offset_bh = (2-isp)*noab(1) +en_offset_ap = (isp-1)*nuab(1) +en_offset_bp = (2-isp)*nuab(1) +t1_offset_a = (isp-1)*noab(1)*nuab(1) +t1_offset_b = (2-isp)*noab(1)*nuab(1) +N = noab(isp)+nuab(isp) + +!mp +scored = .true. +!mp !!!if (.not. lastcall) then +!mp +enx = Zero +!mpn write(u6,*) 'Bef isp, energ(isp), enx = ',isp,energ(isp),enx +!mp !!!if (energ(isp) == Zero) then +! this is a first entry - initialization (makes no harm if repeated) +nuga = nuab(isp)/vblock +if ((nuga*vblock) < nuab(isp)) nuga = nuga+1 +!!write(u6,*) 'first,nuga,vblock',nuga,vblock +nugc = nuab(3-isp)/vblock +if ((nugc*vblock) < nuab(3-isp)) nugc = nugc+1 +!!write(u6,*) 'first,nugc,vblock',nugc,vblock + +iasblock(1) = vblock*vblock*N/nblock +if (iasblock(1)*nblock < vblock*vblock*N) iasblock(1) = iasblock(1)+1 + +iasblock(2) = nnoab(isp)*vblock*N/nblock +if (iasblock(2)*nblock < nnoab(isp)*vblock*N) iasblock(2) = iasblock(2)+1 + +iasblock(3) = nnoab(3)*vblock*N/nblock +if (iasblock(3)*nblock < nnoab(3)*vblock*N) iasblock(3) = iasblock(3)+1 + +iasblock(4) = nnoab(isp)*vblock*vblock/nblock +if (iasblock(4)*nblock < nnoab(isp)*vblock*vblock) iasblock(4) = iasblock(4)+1 + +iasblock(5) = nnoab(3)*vblock*vblock/nblock +if (iasblock(5)*nblock < nnoab(3)*vblock*vblock) iasblock(5) = iasblock(5)+1 + +!mp call w_rescope(G,'GT3loopb') +!mp call w_free(g,0,'GT3loopb') +! allocations +if (nuga /= 1) then + !mp call w_alloc(kab,noab(isp)*vblock*vblock*n,'kaT3loopb') + call mma_allocate(kab,noab(isp)*vblock*vblock*n,label='loopb_kab') + !mp call w_alloc(kcb,noab(isp)*vblock*vblock*n,'kbT3loopb') + call mma_allocate(kcb,noab(isp)*vblock*vblock*n,label='loopb_kcb') + !mp call w_alloc(kbc,vblock*vblock*n,'kcT3loopb') + call mma_allocate(kbc,vblock*vblock*n,label='loopb_kbc') +else + !mp call w_alloc(kab,noab(isp)*N*nnuab(isp),'kaT3loopb') + call mma_allocate(kab,noab(isp)*N*nnuab(isp),label='loopb_kab') +end if +!mp call w_alloc(kac,vblock*vblock*n,'kcT3loopb') +call mma_allocate(kac,vblock*vblock*n,label='loopb_kac') +!mp call w_alloc(kca,noab(isp)*vblock*vblock*n,'kbT3loopb') +call mma_allocate(kca,noab(isp)*vblock*vblock*n,label='loopb_kca') +!mp call w_alloc(kc,vblock*vblock*n,'kcT3loopb') +call mma_allocate(kc,vblock*vblock*n,label='loopb_kc') +!mp call w_alloc(la,nnoab(isp)*vblock*n,'laT3loopb') +call mma_allocate(la,nnoab(isp)*vblock*n,label='loopb_la') +!mp call w_alloc(lxa,nnoab(3)*vblock*n,'lbaT3loopb') +call mma_allocate(lxa,nnoab(3)*vblock*n,label='loopb_lxa') +!mpn write(u6,*) 'check lxa' +!mpn write(u6,*) 'nnoab(1), (2), (3) = ',nnoab(1),nnoab(2),nnoab(3) +!mpn write(u6,*) 'nnuab(1), (2), (3) = ',nnuab(1),nnuab(2),nnuab(3) +if (nuga /= 1) then + !mp call w_alloc(lb,nnoab(isp)*vblock*n,'lbT3loopb') + call mma_allocate(lb,nnoab(isp)*vblock*n,label='loopb_lb') + !mp call w_alloc(lxb,nnoab(3)*vblock*n,'labT3loopb') + call mma_allocate(lxb,nnoab(3)*vblock*n,label='loopb_lxb') +end if +!mp call w_alloc(lxc,nnoab(3)*vblock*n,'lacT3loopb') +call mma_allocate(lxc,nnoab(3)*vblock*n,label='loopb_lxc') +!mp call w_alloc(t3a,vblock*vblock*vblock,'t3aT3loopb') +call mma_allocate(t3a,vblock*vblock*vblock,label='loopb_t3a') +!mp call w_alloc(t3b,vblock*vblock*vblock,'t3bT3loopb') +call mma_allocate(t3b,vblock*vblock*vblock,label='loopb_t3b') +!mp call w_alloc(vac,vblock*vblock*nnoab(3),'vbcT3loopb') +call mma_allocate(vac,vblock*vblock*nnoab(3),label='loopb_vac') +if (nuga /= 1) then + !mp call w_alloc(vab,vblock*vblock*nnoab(isp),'vabT3loopb') + call mma_allocate(vab,vblock*vblock*nnoab(isp),label='loopb_vab') + !mp call w_alloc(vbc,vblock*vblock*nnoab(3),'vacT3loopb') + call mma_allocate(vbc,vblock*vblock*nnoab(3),label='loopb_vbc') +else + !mp call w_alloc(vab,nnoab(isp)*nnuab(isp),'vabT3loopb') + call mma_allocate(vab,nnoab(isp)*nnuab(isp),label='loopb_vab') +end if +!mp call w_alloc(mi,noab(isp)*vblock**3,'miT3loopb') +call mma_allocate(mi,noab(isp)*vblock**3,label='loopb_mi') +!mp +!mpn write(u6,*) 'mi check = ',noab(isp)*vblock**3 +!mpn write(u6,*) 'nnoab(1), (2), (3) = ',nnoab(1),nnoab(2),nnoab(3) +!mpn write(u6,*) 'nnuab(1), (2), (3) = ',nnuab(1),nnuab(2),nnuab(3) +!mp +!mp call w_alloc(mij,N*vblock,'mijT3loopb') +call mma_allocate(mij,N*vblock,label='loopb_mij') +!mp !!!end if ! energ = 0 - initialization + +aset = (nga-1)*vblock +adim = min(vblock,nuab(isp)-aset) +bset = (ngb-1)*vblock +bdim = min(vblock,nuab(isp)-bset) +cset = (ngc-1)*vblock +cdim = min(vblock,nuab(3-isp)-cset) + +! case1 nga=ngb=ngc + +if (nga == ngb) then + + !mpn write(u6,*) 'ide call t3_bta_aac' + !mp call t3_bta_aac(nuga,nugc,g(kab),g(kca),g(kac),g(kc),g(la),g(lxa),g(lxc),g(mi),g(mij),adim,cdim,N,noab(isp),nuab(isp), & + !mp noab(3-isp),nuab(3-isp),lu,iasblock,nga,ngc,oeh(en_offset_ah+1),oeh(en_offset_bh+1), & + !mp oep(aset+en_offset_ap+1),oep(cset+en_offset_bp+1),enx,g(vab),g(vac),t1a(noab(isp)*aset+t1_offset_a+1), & + !mp t1b(noab(isp)*aset+t1_offset_a+1),t1a(noab(3-isp)*cset+t1_offset_b+1),t1b(noab(3-isp)*cset+t1_offset_b+1), & + !mp g(t3a),g(t3b),ifvo) + call t3_bta_aac(nuga,nugc,kab,kca,kac,kc,la,lxa,lxc,mi,mij,adim,cdim,N,noab(isp),noab(3-isp),lu,iasblock,nga,ngc, & + oeh(en_offset_ah+1),oeh(en_offset_bh+1),oep(aset+en_offset_ap+1),oep(cset+en_offset_bp+1),enx,vab,vac, & + t1a(noab(isp)*aset+t1_offset_a+1),t1b(noab(isp)*aset+t1_offset_a+1),t1a(noab(3-isp)*cset+t1_offset_b+1), & + t1b(noab(3-isp)*cset+t1_offset_b+1),t3a,t3b,ifvo) +else + !mpn write(u6,*) 'ide call t3_bta_abc' + !mp call t3_bta_abc(nuga,nugc,g(kab),g(kcb),g(kca),g(kac),g(kbc),g(kc),g(la),g(lb),g(lxa),g(lxb),g(lxc),g(mi),g(mij),adim,bdim, & + !mp cdim,N,noab(isp),nuab(isp),noab(3-isp),nuab(3-isp),lu,iasblock,nga,ngb,ngc,oeh(en_offset_ah+1), & + !mp oeh(en_offset_bh+1),oep(aset+en_offset_ap+1),oep(bset+en_offset_ap+1),oep(cset+en_offset_bp+1),enx,g(vab), & + !mp g(vbc),g(vac),t1a(noab(isp)*aset+t1_offset_a+1),t1b(noab(isp)*aset+t1_offset_a+1), & + !mp t1a(noab(isp)*bset+t1_offset_a+1),t1b(noab(isp)*bset+t1_offset_a+1),t1a(noab(3-isp)*cset+t1_offset_b+1), & + !mp t1b(noab(3-isp)*cset+t1_offset_b+1),g(t3a),g(t3b),ifvo) + call t3_bta_abc(nuga,nugc,kab,kcb,kca,kac,kbc,kc,la,lb,lxa,lxb,lxc,mi,mij,adim,bdim,cdim,N,noab(isp),noab(3-isp),lu,iasblock, & + nga,ngb,ngc,oeh(en_offset_ah+1),oeh(en_offset_bh+1),oep(aset+en_offset_ap+1),oep(bset+en_offset_ap+1), & + oep(cset+en_offset_bp+1),enx,vab,vbc,vac,t1a(noab(isp)*aset+t1_offset_a+1),t1b(noab(isp)*aset+t1_offset_a+1), & + t1a(noab(isp)*bset+t1_offset_a+1),t1b(noab(isp)*bset+t1_offset_a+1),t1a(noab(3-isp)*cset+t1_offset_b+1), & + t1b(noab(3-isp)*cset+t1_offset_b+1),t3a,t3b,ifvo) +end if ! cases +!mpn write(u6,*) 'isp, energ(isp), enx = ',isp,energ(isp),enx +energ(isp) = energ(isp)+enx +!mp !!!write(u6,'(A,3(i5,2x),f21.19)') 'nga, ngb, ngc, inc = ',nga,ngb,ngc,enx +!mp !!!end if ! lastcall +!mp write(u6,*) +!mp write(u6,*) 'deallocating arrays in t3loob' +!mp write(u6,*) +!mp +call mma_deallocate(mij) +call mma_deallocate(mi) +if (nuga /= 1) then + call mma_deallocate(vbc) +end if +call mma_deallocate(vab) +call mma_deallocate(vac) +call mma_deallocate(t3a) +call mma_deallocate(t3b) +call mma_deallocate(lxc) +if (nuga /= 1) then + call mma_deallocate(lxb) + call mma_deallocate(lb) +end if +call mma_deallocate(lxa) +call mma_deallocate(la) +call mma_deallocate(kc) +call mma_deallocate(kca) +call mma_deallocate(kac) +if (nuga /= 1) then + call mma_deallocate(kbc) + call mma_deallocate(kcb) +end if +call mma_deallocate(kab) + +return + +end subroutine t3loopb diff -Nru openmolcas-22.02/src/cht3/transm.f openmolcas-22.10/src/cht3/transm.f --- openmolcas-22.02/src/cht3/transm.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/transm.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE TRANSM(V1,V2,ID1,ID2) - implicit none - integer ID1,ID2, I - REAL*8 V1,V2,ONE - PARAMETER (ONE=1.D0) - DIMENSION V1(ID1,ID2),V2(ID2,ID1) -C usual transposition - IF(ID1.EQ.0.OR.ID2.EQ.0)RETURN - DO I=1,ID1 - CALL DCOPY_(ID2,V1(I,1),ID1,V2(1,I),1) - ENDDO - RETURN -C - ENTRY TRANSM_A(V1,V2,ID1,ID2) -C transposition of the matrix + add to the target matrix - IF(ID1.EQ.0.OR.ID2.EQ.0)RETURN - DO I=1,ID1 - CALL DAXPY_(ID2,ONE,V1(I,1),ID1,V2(1,I),1) - ENDDO - RETURN -C - ENTRY TRANSM_D(V1,V2,ID1,ID2) -C transposition with splitting to "double spacing" - IF(ID1.EQ.0.OR.ID2.EQ.0)RETURN - DO I=1,ID1 - CALL DCOPY_(ID2/2,V1(I,1),ID1,V2(1,I),2) - ENDDO - RETURN - END diff -Nru openmolcas-22.02/src/cht3/transp.f openmolcas-22.10/src/cht3/transp.f --- openmolcas-22.02/src/cht3/transp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/transp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,28 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine transp (AA,BB, dim1,dim2) -c -c this routine do : -c -c AA(a,b) => BB(b,a) -c - implicit none - integer dim1,dim2,i,j - real*8 AA(1:dim1,1:dim2),BB(1:dim2,1:dim1) -c - do i=1,dim1 - do j=1,dim2 - BB(j,i)=AA(i,j) - end do - end do -c - return - end diff -Nru openmolcas-22.02/src/cht3/uhf.fh openmolcas-22.10/src/cht3/uhf.fh --- openmolcas-22.02/src/cht3/uhf.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/uhf.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,13 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - INTEGER NOAB(2),NNOAB(3),NUAB(2),NNUAB(3) - CHARACTER*1 ICH(3) - COMMON/UHF/NOAB,NNOAB,NUAB,NNUAB,ICH diff -Nru openmolcas-22.02/src/cht3/vadd.f openmolcas-22.10/src/cht3/vadd.f --- openmolcas-22.02/src/cht3/vadd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/vadd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE VADD(VEC1,IST1,VEC2,IST2,VEC3,IST3,NS) -CR8 1 - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION VEC1(*),VEC2(*),VEC3(*) - IF(IST1.EQ.1.AND.IST2.EQ.1.AND.IST3.EQ.1)THEN - DO 2 I=1,NS - VEC3(I)=VEC2(I)+VEC1(I) - 2 CONTINUE - ELSE - IS1=1 - IS2=1 - IS3=1 - DO 1 I=1,NS - VEC3(IS3)=VEC2(IS2)+VEC1(IS1) - IS3=IS3+IST3 - IS1=IS1+IST1 - IS2=IS2+IST2 - 1 CONTINUE - ENDIF - RETURN - END diff -Nru openmolcas-22.02/src/cht3/vneg_cht3.f openmolcas-22.10/src/cht3/vneg_cht3.f --- openmolcas-22.02/src/cht3/vneg_cht3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/vneg_cht3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,28 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE VNEG_CHT3(VEC1,IST1,VEC2,IST2,NS) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION VEC1(*),VEC2(*) - IF(IST1.EQ.1.AND.IST2.EQ.1)THEN - DO 2 I=1,NS - VEC2(I )=-VEC1(I ) - 2 CONTINUE - ELSE - IS1=1 - IS2=1 - DO 1 I=1,NS - VEC2(IS2)=-VEC1(IS1) - IS1=IS1+IST1 - IS2=IS2+IST2 - 1 CONTINUE - ENDIF - RETURN - END diff -Nru openmolcas-22.02/src/cht3/vpack4.f openmolcas-22.10/src/cht3/vpack4.f --- openmolcas-22.02/src/cht3/vpack4.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/vpack4.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE VPACK4(IN,IND,NBI,NINT) - implicit none - integer IN,IND,NBI,NINT, I -CR8 1 -C INTEGER*2 IND - DIMENSION IN(*),IND(*) -CREA 2 -C DATA I1,I2,I3 /48,32,16/ -C NBV=4*NBI -CR8 2 - DO 2 I=1,NINT - IND(I)=IN(I) - 2 CONTINUE -CREA 4 -C IF(NINT.NE.NBV)THEN -C DO 1 I=NINT+1,NBV -C1 IN(I)=0 -C ENDIF -CCDC 11 -C CALL Q8SHIFTV (X'08',,IN(1;NBI),,I1,,IND(1;NBI)) -C NN=NBI+1 -C CALL Q8LINKV (X'10') -C CALL Q8SHIFTV (X'08',,IN(NN;NBI),,I2,,IN(1;NBI)) -C CALL Q8ORV (X'02',,IND(1;NBI),,IN(1;NBI),,IND(1;NBI)) -C NN=NBI+NN -C CALL Q8LINKV (X'10') -C CALL Q8SHIFTV (X'08',,IN(NN;NBI),,I3,,IN(1;NBI)) -C CALL Q8ORV (X'02',,IND(1;NBI),,IN(1;NBI),,IND(1;NBI)) -C NN=NBI+NN -C CALL Q8ORV (X'02',,IND(1;NBI),,IN(NN;NBI),,IND(1;NBI)) -CREA 11 -C DO 2 I=1,NBI -C2 IND(I)=SHIFT(IN(I),I1) -C NN=NBI -C DO 3 I=1,NBI -C3 IND(I)=OR(IND(I),SHIFT(IN(I+NN),I2)) -C NN=NBI*2 -C DO 4 I=1,NBI -C4 IND(I)=OR(IND(I),SHIFT(IN(I+NN),I3)) -C NN=NBI*3 -C DO 5 I=1,NBI -C5 IND(I)=OR(IND(I), IN(I+NN)) - RETURN -c Avoid unused argument warnings - IF (.FALSE.) CALL Unused_integer(NBI) - END diff -Nru openmolcas-22.02/src/cht3/v_size_t3.f openmolcas-22.10/src/cht3/v_size_t3.f --- openmolcas-22.02/src/cht3/v_size_t3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/v_size_t3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,223 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine v_size_t3(vblock,nprocs,krem,printkey) - implicit none - integer krem,N - integer t3_size_a,t3_size - integer isp,vblock,maxnu - integer nuga,nugc,vblock_isp(2),nprocs,rest -cmp - integer printkey, tmp -cmp -#include "uhf.fh" -#include "ioind.fh" -C number of elementary subprocesses: nugc*nuga*(nuga+1)/2 -C + nuga*nugc*(nugc+1)/2 -C + nugc**3/6 -C + nuga**3/6 -C check this: - maxnu=max(nuab(1),nuab(2)) - vblock_isp(1)=maxnu/nprocs - -cmp - tmp = 1 - if(maxnu.ge.100)tmp = int((2*nprocs)**(1.0d0/3.0d0)) - - do while ((tmp*(tmp*(tmp+1))/2).lt.nprocs) - tmp = tmp + 1 - enddo - vblock_isp(1) = maxnu/tmp -cmp - -cmp if(vblock_isp(1).lt.40)then -cmp if(maxnu.ge.160)vblock_isp(1)=40 -cmp endif - -C adjusting to reasonably full last block - vblock_isp(2)=vblock_isp(1) - t3_size=krem+1 -C -C brute force -C - t3_size_a=0 - do isp=1,2 - vblock=vblock_isp(isp)+1 - N=noab(isp)+nuab(isp) -C this is a first entry - initialization (makes no harm if reapeated) - do while (krem.lt.t3_size) - vblock=vblock-1 -!! write(6,*)'whiblock',vblock,krem,t3_size - t3_size=0 - nuga=nuab(isp)/vblock - if((nuga*vblock).lt.nuab(isp))nuga=nuga+1 - nugc=nuab(3-isp)/vblock - if((nugc*vblock).lt.nuab(3-isp))nugc=nugc+1 -c dummy allocations - if(nuga.ne.1)then -C call w_alloc(kab, noab(isp)*vblock*vblock*n ,'kaT3loopb') - t3_size=t3_size+ noab(isp)*vblock*vblock*n +1 -C call w_alloc(kcb, noab(isp)*vblock*vblock*n ,'kbT3loopb') - t3_size=t3_size+ noab(isp)*vblock*vblock*n +1 - -C call w_alloc(kbc, vblock*vblock*n ,'kcT3loopb') - t3_size=t3_size+ vblock*vblock*n +1 -C call w_alloc(kbc, vblock*vblock*n ,'kcT3loopb') - t3_size=t3_size+ vblock*vblock*n +1 - - else -C call w_alloc(kab, noab(isp)*N*nnuab(isp) ,'kaT3loopb') - t3_size=t3_size+ noab(isp)*N*nnuab(isp) +1 - - endif -C call w_alloc(kac, vblock*vblock*n ,'kcT3loopb') - t3_size=t3_size+ vblock*vblock*n +1 - -C call w_alloc(kca, noab(isp)*vblock*vblock*n ,'kbT3loopb') - t3_size=t3_size+ noab(isp)*vblock*vblock*n +1 - -C call w_alloc(kc,v block*vblock*n ,'kcT3loopb') - t3_size=t3_size+v block*vblock*n +1 - -C call w_alloc(la,n noab(isp)*vblock*n ,'laT3loopb') - t3_size=t3_size+n noab(isp)*vblock*n +1 - -C call w_alloc(lxa, nnoab(3)*vblock*n ,'lbaT3loopb') - t3_size=t3_size+ nnoab(3)*vblock*n +1 - - if(nuga.ne.1)then -C call w_alloc(lb,n noab(isp)*vblock*n ,'lbT3loopb') - t3_size=t3_size+n noab(isp)*vblock*n +1 - -C call w_alloc(lxb, nnoab(3)*vblock*n ,'labT3loopb') - t3_size=t3_size+ nnoab(3)*vblock*n +1 - endif -C call w_alloc(lxc, nnoab(3)*vblock*n ,'lacT3loopb') - t3_size=t3_size+ nnoab(3)*vblock*n +1 - -C call w_alloc(t3a, vblock*vblock*vblock ,'t3aT3loopb') - t3_size=t3_size+ vblock*vblock*vblock +1 -C call w_alloc(t3b, vblock*vblock*vblock ,'t3bT3loopb') - t3_size=t3_size+ vblock*vblock*vblock +1 - -C call w_alloc(vac, vblock*vblock*nnoab(3) ,'vbcT3loopb') - t3_size=t3_size+ vblock*vblock*nnoab(3) +1 - if(nuga.ne.1) then -C call w_alloc(vab, vblock*vblock*nnoab(isp) ,'vabT3loopb') - t3_size=t3_size+ vblock*vblock*nnoab(isp) +1 - -C call w_alloc(vbc, vblock*vblock*nnoab(3) ,'vacT3loopb') - t3_size=t3_size+ vblock*vblock*nnoab(3) +1 - else -C call w_alloc(vab, nnoab(isp)*nnuab(isp) ,'vabT3loopb') - t3_size=t3_size+ nnoab(isp)*nnuab(isp) +1 - endif -C call w_alloc(mi, noab(isp)*(vblock**3) ,'miT3loopb') - t3_size=t3_size+ noab(isp)*(vblock**3) +1 -C call w_alloc(mij, N*vblock ,'mijT3loopb') - t3_size=t3_size+ N*vblock +1 -C - enddo ! while - vblock_isp(isp)=vblock - if(isp.eq.1)t3_size_a=t3_size - enddo - vblock=min0(vblock_isp(1),vblock_isp(2)) - nuga=maxnu/vblock - if(nuga*vblock.lt.maxnu)nuga=nuga+1 - if(mod(maxnu,vblock).ne.0) - $ vblock=min0(vblock,maxnu/nuga+mod(maxnu,nuga)) -C adjusting to reasonably full last block - rest=mod(maxnu,vblock) - do while (.not.((rest.eq.0).or.(rest.gt.(vblock-nuga)))) - vblock=vblock-1 - rest=mod(maxnu,vblock) - enddo - do isp=1,2 - t3_size=0 - nuga=nuab(isp)/vblock - if((nuga*vblock).lt.nuab(isp))nuga=nuga+1 - nugc=nuab(3-isp)/vblock - if((nugc*vblock).lt.nuab(3-isp))nugc=nugc+1 -c dummy allocations - if(nuga.ne.1)then -C call w_alloc(kab, noab(isp)*vblock*vblock*n ,'kaT3loopb') - t3_size=t3_size+ noab(isp)*vblock*vblock*n +1 -C call w_alloc(kcb, noab(isp)*vblock*vblock*n ,'kbT3loopb') - t3_size=t3_size+ noab(isp)*vblock*vblock*n +1 - -C call w_alloc(kbc, vblock*vblock*n ,'kcT3loopb') - t3_size=t3_size+ vblock*vblock*n +1 -C call w_alloc(kbc, vblock*vblock*n ,'kcT3loopb') - t3_size=t3_size+ vblock*vblock*n +1 - - else -C call w_alloc(kab, noab(isp)*N*nnuab(isp) ,'kaT3loopb') - t3_size=t3_size+ noab(isp)*N*nnuab(isp) +1 - - endif -C call w_alloc(kac, vblock*vblock*n ,'kcT3loopb') - t3_size=t3_size+ vblock*vblock*n +1 - -C call w_alloc(kca, noab(isp)*vblock*vblock*n ,'kbT3loopb') - t3_size=t3_size+ noab(isp)*vblock*vblock*n +1 - -C call w_alloc(kc,v block*vblock*n ,'kcT3loopb') - t3_size=t3_size+v block*vblock*n +1 - -C call w_alloc(la,n noab(isp)*vblock*n ,'laT3loopb') - t3_size=t3_size+n noab(isp)*vblock*n +1 - -C call w_alloc(lxa, nnoab(3)*vblock*n ,'lbaT3loopb') - t3_size=t3_size+ nnoab(3)*vblock*n +1 - - if(nuga.ne.1)then -C call w_alloc(lb,n noab(isp)*vblock*n ,'lbT3loopb') - t3_size=t3_size+n noab(isp)*vblock*n +1 - -C call w_alloc(lxb, nnoab(3)*vblock*n ,'labT3loopb') - t3_size=t3_size+ nnoab(3)*vblock*n +1 - endif -C call w_alloc(lxc, nnoab(3)*vblock*n ,'lacT3loopb') - t3_size=t3_size+ nnoab(3)*vblock*n +1 - -C call w_alloc(t3a, vblock*vblock*vblock ,'t3aT3loopb') - t3_size=t3_size+ vblock*vblock*vblock +1 -C call w_alloc(t3b, vblock*vblock*vblock ,'t3bT3loopb') - t3_size=t3_size+ vblock*vblock*vblock +1 - -C call w_alloc(vac, vblock*vblock*nnoab(3) ,'vbcT3loopb') - t3_size=t3_size+ vblock*vblock*nnoab(3) +1 - if(nuga.ne.1) then -C call w_alloc(vab, vblock*vblock*nnoab(isp) ,'vabT3loopb') - t3_size=t3_size+ vblock*vblock*nnoab(isp) +1 - -C call w_alloc(vbc, vblock*vblock*nnoab(3) ,'vacT3loopb') - t3_size=t3_size+ vblock*vblock*nnoab(3) +1 - else -C call w_alloc(vab, nnoab(isp)*nnuab(isp) ,'vabT3loopb') - t3_size=t3_size+ nnoab(isp)*nnuab(isp) +1 - endif -C call w_alloc(mi, noab(isp)*(vblock**3) ,'miT3loopb') - t3_size=t3_size+ noab(isp)*(vblock**3) +1 -C call w_alloc(mij, N*vblock ,'mijT3loopb') - t3_size=t3_size+ N*vblock +1 - if(isp.eq.1)t3_size_a=t3_size - enddo - write(6,*) - write(6,'(2x,A,I5)') - $ 'Virtual orbitals will be treated in blocks of:',vblock - if (printkey.ge.10) then - write(6,'(2x,A,I11,A,I11,A)')'Memory requirement:', - $ max(t3_size,t3_size_a),' Words; remaining:',krem- - $ max(t3_size,t3_size_a),' Words' - end if - call xflush(6) - return - end diff -Nru openmolcas-22.02/src/cht3/v_size_t3.F90 openmolcas-22.10/src/cht3/v_size_t3.F90 --- openmolcas-22.02/src/cht3/v_size_t3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cht3/v_size_t3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,222 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine v_size_t3(vblock,nprocs,krem,printkey) + +use ChT3_global, only: NNOAB, NNUAB, NOAB, NUAB +use Index_Functions, only: nTri_Elem +use Constants, only: One, Three +use Definitions, only: iwp, u6 + +implicit none +integer(kind=iwp), intent(out) :: vblock +integer(kind=iwp), intent(in) :: nprocs, krem, printkey +integer(kind=iwp) :: isp, maxnu, N, nuga, nugc, rest, t3_size, t3_size_a, tmp, vblock_isp(2) + +! number of elementary subprocesses: nugc*nTri_Elem(nuga) +! + nuga*nTri_Elem(nugc) +! + nugc**3/6 +! + nuga**3/6 +! check this: +maxnu = max(nuab(1),nuab(2)) +vblock_isp(1) = maxnu/nprocs + +!mp +tmp = 1 +if (maxnu >= 100) tmp = int((2*nprocs)**(One/Three)) + +do while (tmp*nTri_Elem(tmp) < nprocs) + tmp = tmp+1 +end do +vblock_isp(1) = maxnu/tmp +!mp + +!mp if (vblock_isp(1) < 40) then +!mp if (maxnu >= 160) vblock_isp(1) = 40 +!mp end if + +! adjusting to reasonably full last block +vblock_isp(2) = vblock_isp(1) +t3_size = krem+1 + +! brute force + +t3_size_a = 0 +do isp=1,2 + vblock = vblock_isp(isp)+1 + N = noab(isp)+nuab(isp) + ! this is a first entry - initialization (makes no harm if repeated) + do while (krem < t3_size) + vblock = vblock-1 + !!write(u6,*) 'whiblock',vblock,krem,t3_size + t3_size = 0 + nuga = nuab(isp)/vblock + if ((nuga*vblock) < nuab(isp)) nuga = nuga+1 + nugc = nuab(3-isp)/vblock + if ((nugc*vblock) < nuab(3-isp)) nugc = nugc+1 + ! dummy allocations + if (nuga /= 1) then + !call w_alloc(kab,noab(isp)*vblock*vblock*n,'kaT3loopb') + t3_size = t3_size+noab(isp)*vblock*vblock*n+1 + !call w_alloc(kcb,noab(isp)*vblock*vblock*n,'kbT3loopb') + t3_size = t3_size+noab(isp)*vblock*vblock*n+1 + + !call w_alloc(kbc,vblock*vblock*n,'kcT3loopb') + t3_size = t3_size+vblock*vblock*n+1 + !call w_alloc(kbc,vblock*vblock*n,'kcT3loopb') + t3_size = t3_size+vblock*vblock*n+1 + + else + !call w_alloc(kab,noab(isp)*N*nnuab(isp),'kaT3loopb') + t3_size = t3_size+noab(isp)*N*nnuab(isp)+1 + + end if + !call w_alloc(kac,vblock*vblock*n,'kcT3loopb') + t3_size = t3_size+vblock*vblock*n+1 + + !call w_alloc(kca,noab(isp)*vblock*vblock*n,'kbT3loopb') + t3_size = t3_size+noab(isp)*vblock*vblock*n+1 + + !call w_alloc(kc,vblock*vblock*n,'kcT3loopb') + t3_size = t3_size+vblock*vblock*n+1 + + !call w_alloc(la,nnoab(isp)*vblock*n,'laT3loopb') + t3_size = t3_size+nnoab(isp)*vblock*n+1 + + !call w_alloc(lxa,nnoab(3)*vblock*n,'lbaT3loopb') + t3_size = t3_size+nnoab(3)*vblock*n+1 + + if (nuga /= 1) then + !call w_alloc(lb,nnoab(isp)*vblock*n,'lbT3loopb') + t3_size = t3_size+nnoab(isp)*vblock*n+1 + + !call w_alloc(lxb,nnoab(3)*vblock*n,'labT3loopb') + t3_size = t3_size+nnoab(3)*vblock*n+1 + end if + !call w_alloc(lxc,nnoab(3)*vblock*n,'lacT3loopb') + t3_size = t3_size+nnoab(3)*vblock*n+1 + + !call w_alloc(t3a,vblock*vblock*vblock,'t3aT3loopb') + t3_size = t3_size+vblock*vblock*vblock+1 + !call w_alloc(t3b,vblock*vblock*vblock,'t3bT3loopb') + t3_size = t3_size+vblock*vblock*vblock+1 + + !call w_alloc(vac,vblock*vblock*nnoab(3),'vbcT3loopb') + t3_size = t3_size+vblock*vblock*nnoab(3)+1 + if (nuga /= 1) then + !call w_alloc(vab,vblock*vblock*nnoab(isp),'vabT3loopb') + t3_size = t3_size+vblock*vblock*nnoab(isp)+1 + + !call w_alloc(vbc,vblock*vblock*nnoab(3),'vacT3loopb') + t3_size = t3_size+vblock*vblock*nnoab(3)+1 + else + !call w_alloc(vab,nnoab(isp)*nnuab(isp),'vabT3loopb') + t3_size = t3_size+nnoab(isp)*nnuab(isp)+1 + end if + !call w_alloc(mi,noab(isp)*(vblock**3),'miT3loopb') + t3_size = t3_size+noab(isp)*(vblock**3)+1 + !call w_alloc(mij,N*vblock,'mijT3loopb') + t3_size = t3_size+N*vblock+1 + + end do ! while + vblock_isp(isp) = vblock + if (isp == 1) t3_size_a = t3_size +end do +vblock = min(vblock_isp(1),vblock_isp(2)) +nuga = maxnu/vblock +if (nuga*vblock < maxnu) nuga = nuga+1 +if (mod(maxnu,vblock) /= 0) vblock = min(vblock,maxnu/nuga+mod(maxnu,nuga)) +! adjusting to reasonably full last block +rest = mod(maxnu,vblock) +do while ((rest /= 0) .and. (rest <= vblock-nuga)) + vblock = vblock-1 + rest = mod(maxnu,vblock) +end do +do isp=1,2 + t3_size = 0 + nuga = nuab(isp)/vblock + if ((nuga*vblock) < nuab(isp)) nuga = nuga+1 + nugc = nuab(3-isp)/vblock + if ((nugc*vblock) < nuab(3-isp)) nugc = nugc+1 + ! dummy allocations + if (nuga /= 1) then + !call w_alloc(kab,noab(isp)*vblock*vblock*n,'kaT3loopb') + t3_size = t3_size+noab(isp)*vblock*vblock*n+1 + !call w_alloc(kcb,noab(isp)*vblock*vblock*n,'kbT3loopb') + t3_size = t3_size+noab(isp)*vblock*vblock*n+1 + + !call w_alloc(kbc,vblock*vblock*n,'kcT3loopb') + t3_size = t3_size+vblock*vblock*n+1 + !call w_alloc(kbc,vblock*vblock*n,'kcT3loopb') + t3_size = t3_size+vblock*vblock*n+1 + + else + !call w_alloc(kab,noab(isp)*N*nnuab(isp),'kaT3loopb') + t3_size = t3_size+noab(isp)*N*nnuab(isp)+1 + + end if + !call w_alloc(kac,vblock*vblock*n,'kcT3loopb') + t3_size = t3_size+vblock*vblock*n+1 + + !call w_alloc(kca,noab(isp)*vblock*vblock*n,'kbT3loopb') + t3_size = t3_size+noab(isp)*vblock*vblock*n+1 + + !call w_alloc(kc,vblock*vblock*n,'kcT3loopb') + t3_size = t3_size+vblock*vblock*n+1 + + !call w_alloc(la,nnoab(isp)*vblock*n,'laT3loopb') + t3_size = t3_size+nnoab(isp)*vblock*n+1 + + !call w_alloc(lxa,nnoab(3)*vblock*n,'lbaT3loopb') + t3_size = t3_size+nnoab(3)*vblock*n+1 + + if (nuga /= 1) then + !call w_alloc(lb,nnoab(isp)*vblock*n,'lbT3loopb') + t3_size = t3_size+nnoab(isp)*vblock*n+1 + + !call w_alloc(lxb,nnoab(3)*vblock*n,'labT3loopb') + t3_size = t3_size+nnoab(3)*vblock*n+1 + end if + !call w_alloc(lxc,nnoab(3)*vblock*n,'lacT3loopb') + t3_size = t3_size+nnoab(3)*vblock*n+1 + + !call w_alloc(t3a,vblock*vblock*vblock,'t3aT3loopb') + t3_size = t3_size+vblock*vblock*vblock+1 + !call w_alloc(t3b,vblock*vblock*vblock,'t3bT3loopb') + t3_size = t3_size+vblock*vblock*vblock+1 + + !call w_alloc(vac,vblock*vblock*nnoab(3),'vbcT3loopb') + t3_size = t3_size+vblock*vblock*nnoab(3)+1 + if (nuga /= 1) then + !call w_alloc(vab,vblock*vblock*nnoab(isp),'vabT3loopb') + t3_size = t3_size+vblock*vblock*nnoab(isp)+1 + + !call w_alloc(vbc,vblock*vblock*nnoab(3),'vacT3loopb') + t3_size = t3_size+vblock*vblock*nnoab(3)+1 + else + !call w_alloc(vab,nnoab(isp)*nnuab(isp),'vabT3loopb') + t3_size = t3_size+nnoab(isp)*nnuab(isp)+1 + end if + !call w_alloc(mi,noab(isp)*(vblock**3),'miT3loopb') + t3_size = t3_size+noab(isp)*(vblock**3)+1 + !call w_alloc(mij,N*vblock,'mijT3loopb') + t3_size = t3_size+N*vblock+1 + if (isp == 1) t3_size_a = t3_size +end do +write(u6,*) +write(u6,'(2x,A,I5)') 'Virtual orbitals will be treated in blocks of:',vblock +if (printkey >= 10) write(u6,'(2x,A,I11,A,I11,A)') 'Memory requirement:',max(t3_size,t3_size_a),' Words; remaining:', & + krem-max(t3_size,t3_size_a),' Words' +call xflush(u6) + +return + +end subroutine v_size_t3 diff -Nru openmolcas-22.02/src/cht3/vsub.f openmolcas-22.10/src/cht3/vsub.f --- openmolcas-22.02/src/cht3/vsub.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/vsub.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE VSUB(VEC1,IST1,VEC2,IST2,VEC3,IST3,NS) - implicit none - integer IST1,IST2,IST3,NS, I, IS1,IS2,IS3 - REAL*8 VEC1,VEC2,VEC3 - DIMENSION VEC1(*),VEC2(*),VEC3(*) -c - IF(IST1.EQ.1.AND.IST2.EQ.1.AND.IST3.EQ.1)THEN - DO I=1,NS - VEC3(I )=VEC2(I )-VEC1(I ) - enddo - ELSE - IS1=1 - IS2=1 - IS3=1 - DO I=1,NS - VEC3(IS3)=VEC2(IS2)-VEC1(IS1) - IS1=IS1+IST1 - IS3=IS3+IST3 - IS2=IS2+IST2 - enddo - ENDIF - RETURN - END diff -Nru openmolcas-22.02/src/cht3/wriseq.f openmolcas-22.10/src/cht3/wriseq.f --- openmolcas-22.02/src/cht3/wriseq.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/wriseq.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,53 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE WRISEQ(G,IDIMENS,IFILE) - implicit none - integer IDIMENS,IFILE,IAS - REAL*8 G(IDIMENS) - integer INDI(IDIMENS) -C write(6,*)'wrote',ifile,idimens - WRITE(IFILE)G - RETURN - - ENTRY REASEQ(G,IDIMENS,IFILE) -C write(6,*)'reading',ifile,idimens - READ(IFILE)G - RETURN - - ENTRY WRIDIR(G,IDIMENS,IFILE,IAS) - WRITE(IFILE,REC=IAS)G - RETURN - - ENTRY READIR(G,IDIMENS,IFILE,IAS) - READ(IFILE,REC=IAS)G - RETURN - - -C WRITTEN BY J. SIMUNEK JULY 2006 -C START PART - - ENTRY WRI_I(INDI,IDIMENS,IFILE,IAS) - WRITE(IFILE,REC=IAS)INDI - RETURN - - ENTRY REA_I(INDI,IDIMENS,IFILE,IAS) - READ(IFILE,REC=IAS)INDI - RETURN - - ENTRY WRI_IR(G,INDI,IDIMENS,IFILE,IAS) - WRITE(IFILE,REC=IAS)INDI,G - RETURN - - ENTRY REA_IR(G,INDI,IDIMENS,IFILE,IAS) - READ(IFILE,REC=IAS)INDI,G - RETURN -C END PART - END diff -Nru openmolcas-22.02/src/cht3/zeroma.f openmolcas-22.10/src/cht3/zeroma.f --- openmolcas-22.02/src/cht3/zeroma.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cht3/zeroma.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE ZEROMA(W,I1,I2) - implicit none - integer I1,I2, I - REAL*8 ZERO,W - PARAMETER (ZERO=0.D0) - DIMENSION W(*) - IF(I2.LT.I1)RETURN - DO I=I1,I2 - W(I)=ZERO - ENDDO - RETURN - END diff -Nru openmolcas-22.02/src/cpf/abcd_cpf.F90 openmolcas-22.10/src/cpf/abcd_cpf.F90 --- openmolcas-22.02/src/cpf/abcd_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/abcd_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,110 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine ABCD_CPF(JSY,INDX,ISAB,C,S,ACBDS,ACBDT,BUFIN) + +use cpf_global, only: IPASS, IRC, IROW, JJS, KBUFF1, LN, LSYM, Lu_TiABCD, NDIAG, NSM, NSYM, NSYS, NVIRT, SQ2 +use Symmetry_Info, only: Mul +use Definitions, only: wp, iwp, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: JSY(*), INDX(*), ISAB(*) +real(kind=wp), intent(inout) :: C(*), S(*) +real(kind=wp), intent(_OUT_) :: ACBDS(*), ACBDT(*), BUFIN(*) +integer(kind=iwp) :: IAC, IACMAX, IACMIN, IAD16, IFIN1, IFIN2, ILOOP, IN1, INB, INDA, INPS, INPT, INS, INSB, INSIN, INUM, INUMB, & + ISAC, IST, IST1, IST2, ISTEP, ISYM, ITAIL, NA, NC, NDMAX, NOV, NSAC, NSACL, NVT +real(kind=wp) :: TERM +real(kind=r8), external :: DDOT_ + +IAD16 = 0 +INSIN = KBUFF1 +INUM = IRC(4)-IRC(3) +call PSQ2(C,S,MUL,INDX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) +NVT = IROW(NVIRT+1) +NOV = (NVT-1)/IPASS+1 +IACMAX = 0 +do ISTEP=1,IPASS + IACMIN = IACMAX+1 + IACMAX = IACMAX+NOV + if (IACMAX > NVT) IACMAX = NVT + if (IACMIN > IACMAX) cycle + do ISYM=1,NSYM + IST1 = IRC(3)+JJS(ISYM+9)+1 + IFIN1 = IRC(3)+JJS(ISYM+10) + INPS = IFIN1-IST1+1 + IST2 = IRC(2)+JJS(ISYM)+1 + IFIN2 = IRC(2)+JJS(ISYM+1) + INPT = IFIN2-IST2+1 + ITAIL = INPS+INPT + if (ITAIL == 0) cycle + IN1 = -NVIRT + do NA=1,NVIRT + IN1 = IN1+NVIRT + do NC=1,NA + IAC = IROW(NA)+NC + if (IAC < IACMIN) cycle + if (IAC > IACMAX) cycle + if (NA == 1) cycle + NSAC = MUL(NSM(LN+NA),NSM(LN+NC)) + NSACL = MUL(NSAC,LSYM) + if (NSACL /= ISYM) cycle + ISAC = ISAB(IN1+NC) + NDMAX = NSYS(NSM(LN+NC)+1) + if (NDMAX > NA) NDMAX = NA + INS = ISAB(IN1+NDMAX) + ILOOP = 0 + do + INSB = INS + do + if (INSIN >= KBUFF1) then + call dDAFILE(Lu_TiABCD,2,BUFIN,KBUFF1,IAD16) + INSIN = 0 + end if + INB = KBUFF1-INSIN + INUMB = INSB + if (INSB > INB) INUMB = INB + IST = INS-INSB+1 + if (ILOOP == 0) call DCOPY_(INUMB,BUFIN(INSIN+1),1,ACBDS(IST),1) + if (ILOOP == 1) call DCOPY_(INUMB,BUFIN(INSIN+1),1,ACBDT(IST),1) + INSIN = INSIN+INUMB + INSB = INSB-INUMB + if (INSB <= 0) exit + end do + ILOOP = ILOOP+1 + if (ILOOP /= 1) exit + end do + if (INPS /= 0) then + do INDA=IST1,IFIN1 + TERM = DDOT_(INS,C(INDX(INDA)+1),1,ACBDS,1) + S(INDX(INDA)+ISAC) = S(INDX(INDA)+ISAC)+TERM + S(INDX(INDA)+1:INDX(INDA)+INS) = S(INDX(INDA)+1:INDX(INDA)+INS)+C(INDX(INDA)+ISAC)*ACBDS(1:INS) + end do + end if + if ((INPT == 0) .or. (NA == NC)) cycle + do INDA=IST2,IFIN2 + TERM = DDOT_(INS,C(INDX(INDA)+1),1,ACBDT,1) + S(INDX(INDA)+ISAC) = S(INDX(INDA)+ISAC)+TERM + S(INDX(INDA)+1:INDX(INDA)+INS) = S(INDX(INDA)+1:INDX(INDA)+INS)+C(INDX(INDA)+ISAC)*ACBDT(1:INS) + end do + end do + end do + end do +end do +call DSQ2(C,S,MUL,INDX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) + +return + +end subroutine ABCD_CPF diff -Nru openmolcas-22.02/src/cpf/abcd.f openmolcas-22.10/src/cpf/abcd.f --- openmolcas-22.02/src/cpf/abcd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/abcd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,98 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE ABCD(JSY,INDEX,ISAB,C,S,ACBDS,ACBDT,BUFIN) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" - DIMENSION JSY(*),INDEX(*),ISAB(*),C(*),S(*),ACBDS(*),ACBDT(*), - & BUFIN(*) - IAD16=0 - KBUFF1=2*9600 - INSIN=KBUFF1 - INUM=IRC(4)-IRC(3) - CALL PSQ2(C,S,MUL,INDEX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) - NVT=IROW(NVIRT+1) - NOV=(NVT-1)/IPASS+1 - IACMAX=0 - DO 70 ISTEP=1,IPASS - IACMIN=IACMAX+1 - IACMAX=IACMAX+NOV - IF(IACMAX.GT.NVT)IACMAX=NVT - IF(IACMIN.GT.IACMAX)GO TO 70 - DO 40 ISYM=1,NSYM - IST1=IRC(3)+JJS(ISYM+9)+1 - IFIN1=IRC(3)+JJS(ISYM+10) - INPS=IFIN1-IST1+1 - IST2=IRC(2)+JJS(ISYM)+1 - IFIN2=IRC(2)+JJS(ISYM+1) - INPT=IFIN2-IST2+1 - ITAIL=INPS+INPT - IF(ITAIL.EQ.0)GO TO 40 - IN1=-NVIRT - DO 50 NA=1,NVIRT - IN1=IN1+NVIRT - DO 60 NC=1,NA - IAC=IROW(NA)+NC - IF(IAC.LT.IACMIN)GO TO 60 - IF(IAC.GT.IACMAX)GO TO 60 - IF(NA.EQ.1)GO TO 60 - NSAC=MUL(NSM(LN+NA),NSM(LN+NC)) - NSACL=MUL(NSAC,LSYM) - IF(NSACL.NE.ISYM)GO TO 60 - ISAC=ISAB(IN1+NC) - NDMAX=NSYS(NSM(LN+NC)+1) - IF(NDMAX.GT.NA)NDMAX=NA - INS=ISAB(IN1+NDMAX) - ILOOP=0 -72 INSB=INS -73 IF(INSIN.LT.KBUFF1)GO TO 75 - CALL dDAFILE(Lu_TiABCD,2,BUFIN,KBUFF1,IAD16) - INSIN=0 -75 INB=KBUFF1-INSIN - INUMB=INSB - IF(INSB.GT.INB)INUMB=INB - IST=INS-INSB+1 - IF(ILOOP.EQ.0)CALL DCOPY_(INUMB,BUFIN(INSIN+1),1, - *ACBDS(IST),1) - IF(ILOOP.EQ.1)CALL DCOPY_(INUMB,BUFIN(INSIN+1),1, - *ACBDT(IST),1) - INSIN=INSIN+INUMB - INSB=INSB-INUMB - IF(INSB.GT.0)GO TO 73 - ILOOP=ILOOP+1 - IF(ILOOP.EQ.1)GO TO 72 - IF(INPS.EQ.0)GO TO 11 - DO 10 INDA=IST1,IFIN1 - FACS=D1 - TERM=DDOT_(INS,C(INDEX(INDA)+1),1,ACBDS,1) - S(INDEX(INDA)+ISAC)=S(INDEX(INDA)+ISAC)+FACS*TERM - CALL DAXPY_(INS,FACS*C(INDEX(INDA)+ISAC),ACBDS,1, - & S(INDEX(INDA)+1),1) -10 CONTINUE -11 IF(INPT.EQ.0.OR.NA.EQ.NC)GO TO 60 - DO 30 INDA=IST2,IFIN2 - FACS=D1 - TERM=DDOT_(INS,C(INDEX(INDA)+1),1,ACBDT,1) - S(INDEX(INDA)+ISAC)=S(INDEX(INDA)+ISAC)+FACS*TERM - CALL DAXPY_(INS,FACS*C(INDEX(INDA)+ISAC),ACBDT,1, - & S(INDEX(INDA)+1),1) -30 CONTINUE -60 CONTINUE -50 CONTINUE -40 CONTINUE -70 CONTINUE - CALL DSQ2(C,S,MUL,INDEX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/abci_cpf.F90 openmolcas-22.10/src/cpf/abci_cpf.F90 --- openmolcas-22.02/src/cpf/abci_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/abci_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,123 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine ABCI_CPF(JSY,INDX,C,S,BMN,IBMN,BIAC,BICA,BUFIN) + +use cpf_global, only: IADABCI, IRC, KBUFF1, LN, LSYM, Lu_CIGuga, Lu_TiABCI, NDIAG, NNS, NSM, NSYS, NVIRT, SQ2 +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Definitions, only: wp, iwp, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: JSY(*), INDX(*) +real(kind=wp), intent(inout) :: C(*), S(*) +real(kind=wp), intent(_OUT_) :: BMN(*), BIAC(*), BICA(*), BUFIN(*) +integer(kind=iwp), intent(_OUT_) :: IBMN(*) +integer(kind=iwp) :: I, IAD15, IADD10, ICCB, ICHK, ICP1, ICP2, IIN, ILEN, ILOOP, IND, INDA, INDB, INS, INSIN, INUM, IOUT, IT, & + ITYP, LB, MA, NB, NI, NSAVE, NSIB, NSLB +real(kind=wp) :: COPL, TERM +logical(kind=iwp) :: Skip +integer(kind=iwp), external :: JSUNP +real(kind=r8), external :: DDOT_ + +INUM = IRC(4)-IRC(3) +call PSQ2(C,S,MUL,INDX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) +ICHK = 0 +INSIN = KBUFF1 +IAD15 = IADABCI +IADD10 = IAD10(4) +call dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) +call iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) +ILEN = ICOP1(nCOP+1) +IIN = 2 +NSAVE = ICOP1(IIN) +do + NI = NSAVE + IOUT = 0 + Skip = .false. + do + IIN = IIN+1 + if (IIN > ILEN) then + call dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) + call iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN <= 0) then + Skip = .true. + exit + end if + IIN = 1 + end if + if (ICHK /= 0) exit + if (ICOP1(IIN) == 0) then + ICHK = 1 + else + IOUT = IOUT+1 + BMN(IOUT) = COP(IIN) + IBMN(IOUT) = ICOP1(IIN) + end if + end do + if (.not. Skip) then + ICHK = 0 + NSAVE = ICOP1(IIN) + end if + do NB=1,NVIRT + NSIB = MUL(NSM(LN+NB),NSM(NI)) + NSLB = MUL(NSM(LN+NB),LSYM) + LB = NB-NSYS(NSM(LN+NB)) + INS = NNS(NSIB) + ILOOP = 0 + do + do I=1,INS + if (INSIN >= KBUFF1) then + call dDAFILE(Lu_TiABCI,2,BUFIN,KBUFF1,IAD15) + INSIN = 0 + end if + INSIN = INSIN+1 + if (ILOOP == 0) BIAC(I) = BUFIN(INSIN) + if (ILOOP == 1) BICA(I) = BUFIN(INSIN) + end do + ILOOP = ILOOP+1 + if (ILOOP /= 1) exit + end do + do IT=1,IOUT + IND = IBMN(IT) + ICP1 = ibits(IND,19,13) + INDA = IRC(1)+ICP1 + if (JSUNP(JSY,INDA) /= NSLB) cycle + MA = INDX(INDA)+LB + ICP2 = ibits(IND,6,13) + ITYP = ibits(IND,0,6) + if (INS == 0) cycle + COPL = BMN(IT)*C(MA) + INDB = IRC(ITYP)+ICP2 + ICCB = INDX(INDB)+1 + if (ITYP == 3) then + TERM = DDOT_(INS,C(ICCB),1,BIAC,1) + S(ICCB:ICCB+INS-1) = S(ICCB:ICCB+INS-1)+COPL*BIAC(1:INS) + else + TERM = DDOT_(INS,C(ICCB),1,BICA,1) + S(ICCB:ICCB+INS-1) = S(ICCB:ICCB+INS-1)+COPL*BICA(1:INS) + end if + S(MA) = S(MA)+BMN(IT)*TERM + end do + end do + if (ILEN < 0) exit +end do +call DSQ2(C,S,MUL,INDX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) + +return + +end subroutine ABCI_CPF diff -Nru openmolcas-22.02/src/cpf/abci.f openmolcas-22.10/src/cpf/abci.f --- openmolcas-22.02/src/cpf/abci.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/abci.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,100 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE ABCI(JSY,INDEX,C,S,BMN,IBMN,BIAC,BICA,BUFIN) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" - DIMENSION JSY(*),INDEX(*),C(*),S(*),BMN(*),IBMN(*), - & BIAC(*),BICA(*),BUFIN(*) - PARAMETER (IPOW6=2**6, IPOW19=2**19) -* - JSYM(L)=JSUNP_CPF(JSY,L) -* - INUM=IRC(4)-IRC(3) - CALL PSQ2(C,S,MUL,INDEX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) - ICHK=0 - INSIN=KBUFF1 - IAD15=IADABCI - IADD10=IAD10(4) - CALL dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) - CALL iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IN=2 - NSAVE=ICOP1(IN) -100 NI=NSAVE - IOUT=0 -110 IN=IN+1 - IF(IN.LE.LEN)GO TO 15 - CALL dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) - CALL iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.LE.0)GO TO 5 - IN=1 -15 IF(ICHK.NE.0)GO TO 460 - IF(ICOP1(IN).EQ.0)GO TO 10 - IOUT=IOUT+1 - BMN(IOUT)=COP(IN) - IBMN(IOUT)=ICOP1(IN) - GO TO 110 -10 ICHK=1 - GO TO 110 -460 ICHK=0 - NSAVE=ICOP1(IN) - 5 CONTINUE - DO 20 NB=1,NVIRT - NSIB=MUL(NSM(LN+NB),NSM(NI)) - NSLB=MUL(NSM(LN+NB),LSYM) - LB=NB-NSYS(NSM(LN+NB)) - INS=NNS(NSIB) - ILOOP=0 -72 DO 75 I=1,INS - IF(INSIN.LT.KBUFF1)GO TO 73 - CALL dDAFILE(Lu_TiABCI,2,BUFIN,KBUFF1,IAD15) - INSIN=0 -73 INSIN=INSIN+1 - IF(ILOOP.EQ.0)BIAC(I)=BUFIN(INSIN) - IF(ILOOP.EQ.1)BICA(I)=BUFIN(INSIN) -75 CONTINUE - ILOOP=ILOOP+1 - IF(ILOOP.EQ.1)GO TO 72 - DO 25 IT=1,IOUT - IND=IBMN(IT) -* ICP1=MOD(IND/IPOW19,8192) - ICP1=IBITS(IND,19,13) - INDA=IRC(1)+ICP1 - IF(JSYM(INDA).NE.NSLB)GO TO 25 - MA=INDEX(INDA)+LB -* ICP2=MOD(IND/IPOW6,8192) -* ITYP=MOD(IND,64) - ICP2=IBITS(IND,6,13) - ITYP=IBITS(IND, 0, 6) - IF(INS.EQ.0)GO TO 25 - COPL=BMN(IT)*C(MA) - INDB=IRC(ITYP)+ICP2 - FACS=D1 - ICCB=INDEX(INDB)+1 - IF(ITYP.EQ.3)GO TO 26 - TERM=DDOT_(INS,C(ICCB),1,BICA,1) - CALL DAXPY_(INS,COPL*FACS,BICA,1,S(ICCB),1) - GO TO 27 -26 TERM=DDOT_(INS,C(ICCB),1,BIAC,1) - CALL DAXPY_(INS,COPL*FACS,BIAC,1,S(ICCB),1) -27 S(MA)=S(MA)+BMN(IT)*FACS*TERM -25 CONTINUE -20 CONTINUE - IF(LEN.GE.0)GO TO 100 - CALL DSQ2(C,S,MUL,INDEX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/ab_cpf.F90 openmolcas-22.10/src/cpf/ab_cpf.F90 --- openmolcas-22.02/src/cpf/ab_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/ab_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,206 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine AB_CPF(ICASE,JSY,INDX,C,S,FC,A,B,F,ENP) + +use cpf_global, only: IDENS, IFIRST, IPRINT, IRC, IREF0, IROW, LN, LSYM, NDIAG, NORBT, NSYM, NSYS, NVIR, NVIRT, SQ2 +use Symmetry_Info, only: Mul +use Constants, only: Zero, One, Half +use Definitions, only: wp, iwp, u6, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: ICASE(*), JSY(*), INDX(*) +real(kind=wp), intent(inout) :: C(*), S(*), FC(*) +real(kind=wp), intent(_OUT_) :: A(*), B(*), F(*) +real(kind=wp), intent(in) :: ENP(*) +integer(kind=iwp) :: I, IAB, IASYM, ICSYM, IFT, II1, IIA, IIC, IIN, IJ, INDA, INMY, INN, INUM, IOC(55), IPF, IPOA(9), IPOF(9), & + ITAIL, ITURN, JOJ, LNA, LNC, MYL, MYSYM, NA, NA1, NA2, NAA, NAB, NAC, NB, NCLIM, NVIRA, NVIRC +real(kind=wp) :: COPI, RSUM, TR, TSUM +integer(kind=iwp), external :: ICUNP, JSUNP +real(kind=r8), external :: DDOT_ + +INUM = IRC(4)-IRC(3) +call PSQ2(C,S,MUL,INDX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) +NCLIM = 4 +NAB = 0 ! dummy initialize +if (IFIRST /= 0) NCLIM = 2 +! MOVE FOCK (DENSITY) MATRIX TO F IN SYMMETRY BLOCKS +call IPO_CPF(IPOF,NVIR,MUL,NSYM,1,-1) +ITURN = 0 +do + do IASYM=1,NSYM + IAB = IPOF(IASYM) + NA1 = NSYS(IASYM)+1 + NA2 = NSYS(IASYM+1) + do NA=NA1,NA2 + do NB=NA1,NA2 + IAB = IAB+1 + if (NA >= NB) NAB = IROW(LN+NA)+LN+NB + if (NB > NA) NAB = IROW(LN+NB)+LN+NA + if (ITURN == 1) then + if (NA < NB) FC(NAB) = F(IAB) + else + if (IDENS == 0) F(IAB) = Zero + if (IDENS == 1) F(IAB) = FC(NAB) + if (NA /= NB) F(IAB) = FC(NAB) + end if + end do + end do + end do + if (ITURN /= 0) then + TR = Zero + IJ = 0 + do I=1,NORBT + IJ = IJ+I + TR = TR+FC(IJ) + end do + if (iPrint >= 15) write(u6,310) TR + exit + end if + II1 = 0 + ITAIL = IRC(NCLIM) + do INDA=1,ITAIL + if (IDENS /= 0) then + do I=1,LN + II1 = II1+1 + JOJ = ICUNP(ICASE,II1) + if (JOJ > 1) JOJ = JOJ-1 + IOC(I) = JOJ + end do + end if + if (INDA <= IRC(1)) then + if ((IDENS == 0) .or. (INDA == IREF0)) cycle + TSUM = C(INDA)*C(INDA)/(sqrt(ENP(INDA))*sqrt(ENP(INDA))) + else + MYSYM = JSUNP(JSY,INDA) + MYL = MUL(MYSYM,LSYM) + INMY = INDX(INDA)+1 + if (INDA <= IRC(2)) then + ! DOUBLET-DOUBLET INTERACTIONS + if (NVIR(MYL) == 0) cycle + if (IDENS /= 1) then + call FMMM(F(IPOF(MYL)+1),C(INMY),A,NVIR(MYL),1,NVIR(MYL)) + S(INMY:INMY+NVIR(MYL)-1) = S(INMY:INMY+NVIR(MYL)-1)+A(1:NVIR(MYL)) + cycle + end if + call FMUL2(C(INMY),C(INMY),A,NVIR(MYL),NVIR(MYL),1) + IPF = IPOF(MYL)+1 + IIN = IPOF(MYL+1)-IPOF(MYL) + COPI = One/(sqrt(ENP(INDA))*sqrt(ENP(INDA))) + F(IPF:IPF+IIN-1) = F(IPF:IPF+IIN-1)+COPI*A(1:IIN) + NVIRA = NVIR(MYL) + LNA = LN+NSYS(MYL) + IIA = IROW(LNA+1) + TSUM = Zero + do I=1,NVIRA + RSUM = COPI*C(INMY)*C(INMY) + INMY = INMY+1 + TSUM = TSUM+RSUM + IIA = IIA+LNA+I + FC(IIA) = FC(IIA)+RSUM + end do + else + ! TRIPLET-TRIPLET AND SINGLET-SINGLET INTERACTIONS + IFT = 1 + if (INDA > IRC(3)) IFT = 0 + call IPO_CPF(IPOA,NVIR,MUL,NSYM,MYL,IFT) + IIN = 0 + TSUM = Zero + do IASYM=1,NSYM + IAB = IPOF(IASYM+1)-IPOF(IASYM) + if (IAB == 0) cycle + ICSYM = MUL(MYL,IASYM) + if (NVIR(ICSYM) == 0) cycle + if (IDENS /= 1) then + if (MYL == 1) then + if (IFT == 0) call SQUAR(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + !if (IFT == 1) call SQUARN(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + if (IFT == 1) call SQUARM(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + NAA = NVIR(IASYM)*NVIR(IASYM) + call FMMM(F(IPOF(IASYM)+1),A,B,NVIR(IASYM),NVIR(IASYM),NVIR(IASYM)) + A(1:NAA) = B(1:NAA) + if (IFT /= 1) then + call SIADD(A,S(INMY+IPOA(IASYM)),NVIR(IASYM)) + else + call TRADD(A,S(INMY+IPOA(IASYM)),NVIR(IASYM)) + end if + A(1:NAA) = Zero + else + NAC = NVIR(IASYM)*NVIR(ICSYM) + if (IASYM <= ICSYM) then + I = INMY+IPOA(ICSYM) + call FMMM(F(IPOF(IASYM)+1),C(I),A,NVIR(IASYM),NVIR(ICSYM),NVIR(IASYM)) + else + I = INMY+IPOA(IASYM) + call FMMM(C(I),F(IPOF(IASYM)+1),A,NVIR(ICSYM),NVIR(IASYM),NVIR(IASYM)) + end if + S(I:I+NAC-1) = S(I:I+NAC-1)+A(1:NAC) + end if + else + if (MYL == 1) then + if (IFT == 0) call SQUAR(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + if (IFT == 1) call SQUARM(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + else if (IASYM <= ICSYM) then + NAC = NVIR(IASYM)*NVIR(ICSYM) + if (IFT == 0) call DCOPY_(NAC,C(INMY+IPOA(ICSYM)),1,A,1) + if (IFT == 1) call VNEG(NAC,C(INMY+IPOA(ICSYM)),1,A,1) + else + call MTRANS(C(INMY+IPOA(IASYM)),A,NVIR(IASYM),NVIR(ICSYM)) + end if + call FMUL2(A,A,B,NVIR(IASYM),NVIR(IASYM),NVIR(ICSYM)) + IPF = IPOF(IASYM)+1 + COPI = One/(sqrt(ENP(INDA))*sqrt(ENP(INDA))) + F(IPF:IPF+IAB-1) = F(IPF:IPF+IAB-1)+COPI*B(1:IAB) + NVIRA = NVIR(IASYM) + NVIRC = NVIR(ICSYM) + INN = 1 + LNC = LN+NSYS(ICSYM) + IIC = IROW(LNC+1) + do I=1,NVIRC + RSUM = DDOT_(NVIRA,A(INN),1,A(INN),1) + RSUM = COPI*RSUM + TSUM = TSUM+RSUM + IIC = IIC+LNC+I + FC(IIC) = FC(IIC)+RSUM + INN = INN+NVIRA + end do + end if + end do + if (IDENS == 0) cycle + TSUM = TSUM*Half + end if + end if + IJ = 0 + do I=1,LN + IJ = IJ+I + FC(IJ) = FC(IJ)+IOC(I)*TSUM + end do + end do + ITURN = 1 + if (IDENS /= 1) exit +end do +call DSQ2(C,S,MUL,INDX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) +!NCONF = JSC(4) +!write(u6,987) (S(I),I=1,NCONF) +!write(u6,986) (W(I),I=1,NCONF) + +return + +310 format(/,6X,'TRACE OF DENSITY MATRIX',F16.8) +!986 format(1X,'W,AB',5F10.6) +!987 format(1X,'S,AB',5F10.6) + +end subroutine AB_CPF diff -Nru openmolcas-22.02/src/cpf/ab.f openmolcas-22.10/src/cpf/ab.f --- openmolcas-22.02/src/cpf/ab.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/ab.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,200 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE AB(ICASE,JSY,INDEX,C,S,FC,A,B,F,ENP) - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "cpfmcpf.fh" - DIMENSION JSY(*),INDEX(*),C(*),S(*),FC(*),A(*),B(*), - & F(*),ENP(*) - DIMENSION ICASE(*) - DIMENSION IPOA(9),IPOF(9) - DIMENSION IOC(55) -CPAM97 INTEGER UNPACK -CPAM97 EXTERNAL UNPACK -CRL JO(L)=IAND(ISHFT(QOCC((L+29)/30),-2*((L+29)/30*30-L)),3) -CPAM97 JO(L)=UNPACK(QOCC((L+29)/30),2*L-(2*L-1)/60*60,2) - JO(L)=ICUNP(ICASE,L) -CRL JSYM(L)=IAND(ISHFT(JSY((L+19)/20),-3*((L+19)/20*20-L)),7)+1 -CPAM96 JSYM(L)=UNPACK(JSY((L+9)/10),3*MOD(L-1,10)+1,3)+1 - JSYM(L)=JSUNP_CPF(JSY,L) - INUM=IRC(4)-IRC(3) - CALL PSQ2(C,S,MUL,INDEX,JSY,NDIAG,INUM,IRC(3), - & LSYM,NVIRT,SQ2) - NCLIM=4 - NAB = 0 ! dummy initialize - IF(IFIRST.NE.0)NCLIM=2 -C MOVE FOCK (DENSITY) MATRIX TO F IN SYMMETRY BLOCKS - CALL IPO_CPF(IPOF,NVIR,MUL,NSYM,1,-1) - ITURN=0 -90 DO 10 IASYM=1,NSYM - IAB=IPOF(IASYM) - NA1=NSYS(IASYM)+1 - NA2=NSYS(IASYM+1) - IF(NA2.LT.NA1)GO TO 10 - DO 15 NA=NA1,NA2 - DO 20 NB=NA1,NA2 - IAB=IAB+1 - IF(NA.GE.NB)NAB=IROW(LN+NA)+LN+NB - IF(NB.GT.NA)NAB=IROW(LN+NB)+LN+NA - IF(ITURN.EQ.1)GO TO 320 - IF(IDENS.EQ.0)F(IAB)=D0 - IF(IDENS.EQ.1)F(IAB)=FC(NAB) - IF(NA.NE.NB)F(IAB)=FC(NAB) - GO TO 20 -320 IF(NA.LT.NB)FC(NAB)=F(IAB) -20 CONTINUE -15 CONTINUE -10 CONTINUE - IF(ITURN.EQ.0)GO TO 11 - TR=D0 - IJ=0 - DO 510 I=1,NORBT - IJ=IJ+I - TR=TR+FC(IJ) -510 CONTINUE - If (iPrint.ge.15) WRITE(6,310)TR -310 FORMAT(/,6X,'TRACE OF DENSITY MATRIX',F16.8) - GO TO 300 -11 II1=0 - ITAIL=IRC(NCLIM) - DO 40 INDA=1,ITAIL - IF(IDENS.EQ.0)GO TO 111 - DO 110 I=1,LN - II1=II1+1 - JOJ=JO(II1) - IF(JOJ.GT.1)JOJ=JOJ-1 - IOC(I)=JOJ -110 CONTINUE -111 IF(INDA.GT.IRC(1))GO TO 120 - IF(IDENS.EQ.0.OR.INDA.EQ.IREF0)GO TO 40 - TSUM=C(INDA)*C(INDA)/(SQRT(ENP(INDA))*SQRT(ENP(INDA))) - GO TO 106 -120 MYSYM=JSYM(INDA) - MYL=MUL(MYSYM,LSYM) - INMY=INDEX(INDA)+1 - FACS=D1 - IF(INDA.GT.IRC(2))GO TO 25 -C DOUBLET-DOUBLET INTERACTIONS - IF(NVIR(MYL).EQ.0)GO TO 40 - IF(IDENS.EQ.1)GO TO 65 - CALL SETZ(A,NVIR(MYL)) - CALL FMMM(F(IPOF(MYL)+1),C(INMY),A,NVIR(MYL),1,NVIR(MYL)) - CALL DAXPY_(NVIR(MYL),FACS,A,1,S(INMY),1) - GO TO 40 -65 CALL FMUL2_CPF(C(INMY),C(INMY),A,NVIR(MYL),NVIR(MYL),1) - IPF=IPOF(MYL)+1 - IN=IPOF(MYL+1)-IPOF(MYL) - COPI=D1/(SQRT(ENP(INDA))*SQRT(ENP(INDA))) - CALL VSMA(A,1,COPI,F(IPF),1,F(IPF),1,IN) - NVIRA=NVIR(MYL) - LNA=LN+NSYS(MYL) - IIA=IROW(LNA+1) - TSUM=D0 - DO 130 I=1,NVIRA - SUM=COPI*C(INMY)*C(INMY) - INMY=INMY+1 - TSUM=TSUM+SUM - IIA=IIA+LNA+I - FC(IIA)=FC(IIA)+SUM -130 CONTINUE - GO TO 106 -C TRIPLET-TRIPLET AND SINGLET-SINGLET INTERACTIONS -25 IFT=1 - IF(INDA.GT.IRC(3))IFT=0 - CALL IPO_CPF(IPOA,NVIR,MUL,NSYM,MYL,IFT) - IN=0 - TSUM=D0 - DO 70 IASYM=1,NSYM - IAB=IPOF(IASYM+1)-IPOF(IASYM) - IF(IAB.EQ.0)GO TO 70 - ICSYM=MUL(MYL,IASYM) - IF(NVIR(ICSYM).EQ.0)GO TO 70 - IF(IDENS.EQ.1)GO TO 75 - IF(MYL.NE.1)GO TO 30 - IF(IFT.EQ.0)CALL SQUAR_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) -C IF(IFT.EQ.1)CALL SQUARN_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) - IF(IFT.EQ.1)CALL SQUARM_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) - NAA=NVIR(IASYM)*NVIR(IASYM) - CALL SETZ(B,NAA) - CALL FMMM(F(IPOF(IASYM)+1),A,B,NVIR(IASYM),NVIR(IASYM), - *NVIR(IASYM)) - CALL SETZ(A,NAA) - CALL DAXPY_(NAA,FACS,B,1,A,1) - IF(IFT.EQ.1)GO TO 230 - CALL SIADD_CPF(A,S(INMY+IPOA(IASYM)),NVIR(IASYM)) - CALL SETZ(A,NAA) - GO TO 70 -230 CALL TRADD_CPF(A,S(INMY+IPOA(IASYM)),NVIR(IASYM)) - CALL SETZ(A,NAA) - GO TO 70 -30 NAC=NVIR(IASYM)*NVIR(ICSYM) - CALL SETZ(A,NAC) - IF(IASYM.GT.ICSYM)GO TO 31 - CALL FMMM(F(IPOF(IASYM)+1),C(INMY+IPOA(ICSYM)),A, - *NVIR(IASYM),NVIR(ICSYM),NVIR(IASYM)) - CALL DAXPY_(NAC,FACS,A,1,S(INMY+IPOA(ICSYM)),1) - GO TO 70 -31 CALL FMMM(C(INMY+IPOA(IASYM)),F(IPOF(IASYM)+1),A, - *NVIR(ICSYM),NVIR(IASYM),NVIR(IASYM)) - CALL DAXPY_(NAC,FACS,A,1,S(INMY+IPOA(IASYM)),1) - GO TO 70 -75 IF(MYL.NE.1)GO TO 330 - IF(IFT.EQ.0)CALL SQUAR_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) - IF(IFT.EQ.1)CALL SQUARM_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) - GO TO 255 -330 IF(IASYM.GT.ICSYM)GO TO 231 - NAC=NVIR(IASYM)*NVIR(ICSYM) - IF(IFT.EQ.0)CALL DCOPY_(NAC,C(INMY+IPOA(ICSYM)),1,A,1) - IF(IFT.EQ.1)CALL VNEG_CPF(C(INMY+IPOA(ICSYM)),1,A,1,NAC) - GO TO 255 -231 CALL MTRANS_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM),NVIR(ICSYM)) -255 CALL FMUL2_CPF(A,A,B,NVIR(IASYM),NVIR(IASYM),NVIR(ICSYM)) - IPF=IPOF(IASYM)+1 - COPI=D1/(SQRT(ENP(INDA))*SQRT(ENP(INDA))) - CALL VSMA(B,1,COPI,F(IPF),1,F(IPF),1,IAB) - NVIRA=NVIR(IASYM) - NVIRC=NVIR(ICSYM) - INN=1 - LNC=LN+NSYS(ICSYM) - IIC=IROW(LNC+1) - DO 105 I=1,NVIRC - SUM=DDOT_(NVIRA,A(INN),1,A(INN),1) - SUM=COPI*SUM - TSUM=TSUM+SUM - IIC=IIC+LNC+I - FC(IIC)=FC(IIC)+SUM - INN=INN+NVIRA -105 CONTINUE -70 CONTINUE - IF(IDENS.EQ.0)GO TO 40 - TSUM=TSUM/D2 -106 IJ=0 - DO 107 I=1,LN - IJ=IJ+I - FC(IJ)=FC(IJ)+IOC(I)*TSUM -107 CONTINUE -40 CONTINUE - ITURN=1 - IF(IDENS.EQ.1)GO TO 90 -300 CALL DSQ2(C,S,MUL,INDEX,JSY,NDIAG,INUM,IRC(3), - *LSYM,NVIRT,SQ2) -C NCONF=JSC(4) -C WRITE(6,987)(S(I),I=1,NCONF) -C 987 FORMAT(1X,'S,AB',5F10.6) -C WRITE(6,986)(W(I),I=1,NCONF) -C 986 FORMAT(1X,'W,AB',5F10.6) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/ai_cpf.f openmolcas-22.10/src/cpf/ai_cpf.f --- openmolcas-22.02/src/cpf/ai_cpf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/ai_cpf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,225 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE AI_CPF(JSY,INDEX,C,S,FC,BUFIN,IBUFIN,A,B,FK,DBK, - *ENP,EPP,KTYP) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" - DIMENSION JSY(*),INDEX(*),C(*),S(*),FC(*),BUFIN(*),IBUFIN(*), - & A(*),B(*),FK(*),DBK(*),ENP(*),EPP(*) - PARAMETER (IPOW10=2**10, IPOW20=2**20) - PARAMETER (IPOW6=2**6, IPOW19=2**19) -* -C KTYP=0 , (A/I) INTEGRALS -C KTYP=1 , (AI/JK) INTEGRALS - DIMENSION IPOB(9) -* - JSYM(L)=JSUNP_CPF(JSY,L) -* - NK = 0 ! dummy initialize - NSK= 0 ! dummy initialize - INUM=IRC(4)-IRC(3) - CALL PSQ2(C,S,MUL,INDEX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) - NVT=IROW(NVIRT+1) - ICHK=0 - IJOLD=0 - NOB2=IROW(NORBT+1) - NOT2=IROW(LN+1) - NOTT=2*NOT2 - NOVST=LN*NVIRT+1+NVT - LBUF0=RTOI*LBUF - LBUF1=LBUF0+LBUF+1 - LBUF2=LBUF1+1 - IF(KTYP.EQ.0)IADD10=IAD10(9) - IF(KTYP.EQ.1)IADD10=IAD10(7) -100 CALL dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) - CALL iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.EQ.0)GO TO 100 - IF(LEN.LT.0)GO TO 200 - DO 10 II=1,LEN - IND=ICOP1(II) - IF(ICHK.NE.0)GO TO 460 - IF(IND.NE.0)GO TO 11 - ICHK=1 - GO TO 10 -460 ICHK=0 - ITURN=0 - IF(IDENS.EQ.1.AND.IJOLD.NE.0)GO TO 20 -21 ITURN=1 - IF(KTYP.EQ.1)GO TO 9 - NK=IND - IJOLD=NK - NSK=NSM(NK) - GO TO 20 -9 INDI=IND -* NI=MOD(INDI,1024) -* NJ=MOD(INDI/IPOW10,1024) -* NK=MOD(INDI/IPOW20,1024) - NI=IBITS(INDI,0,10) - NJ=IBITS(INDI,10,10) - NK=IBITS(INDI,20,10) - NSIJ=MUL(NSM(NI),NSM(NJ)) - NSK=MUL(NSIJ,NSM(NK)) - IJ=IROW(NI)+NJ - IF(IJ.EQ.IJOLD)GO TO 20 - IJOLD=IJ - IADR=LASTAD(NOVST+NOTT+IJ) - DO 105 INN=1,NOB2 - FC(INN)=D0 -105 CONTINUE -90 CALL iDAFILE(Lu_TiABIJ,2,IBUFIN,LBUF2,IADR) - LENGTH=IBUFIN(LBUF1) - IADR=IBUFIN(LBUF2) - IF(LENGTH.EQ.0)GO TO 91 - CALL SCATTER(LENGTH,FC,IBUFIN(LBUF0+1),BUFIN) -91 IF(IADR.NE.-1) GO TO 90 -C FORM VECTOR FK -20 NA1=NSYS(NSK)+1 - NA2=NSYS(NSK+1) - INK=0 - IF(NA2.LT.NA1)GO TO 10 - DO 13 NA=NA1,NA2 - INK=INK+1 - NAK=IROW(LN+NA)+NK - IF(ITURN.EQ.0)FC(NAK)=FK(INK) - IF(ITURN.EQ.1)FK(INK)=FC(NAK) -13 CONTINUE - IF(ITURN.EQ.0)GO TO 21 - GO TO 10 -11 IF(INK.EQ.0)GO TO 10 -CPAM97 ITYP=IAND(IND,63) -CPAM97 ICP2=IAND(ISHFT(IND,-6),8191) -CPAM97 ICP1=IAND(ISHFT(IND,-19),8191) -* ITYP=MOD(IND,64) -* ICP2=MOD(IND/IPOW6,8192) -* ICP1=MOD(IND/IPOW19,8192) - ITYP=IBITS(IND, 0, 6) - ICP2=IBITS(IND,6,13 ) - ICP1=IBITS(IND,19,13 ) - IF(ITYP.GT.1)GO TO 12 - INDA=ICP1 - INDB=IRC(1)+ICP2 - INNY=INDEX(INDB)+1 - IF(IDENS.EQ.1)GO TO 41 - IF(INDA.NE.IREF0)GO TO 42 - COPI=COP(II)/SQRT(ENP(INDB)) - CALL DAXPY_(INK,COPI,FK,1,S(INNY),1) - IF(ITER.EQ.1)GO TO 10 - TERM=DDOT_(INK,FK,1,C(INNY),1) - EPP(INDB)=EPP(INDB)+COPI*TERM - GO TO 10 -42 FACS=D1 - COPI=COP(II)*C(INDA) - CALL DAXPY_(INK,COPI*FACS,FK,1,S(INNY),1) - TERM=DDOT_(INK,FK,1,C(INNY),1) - S(INDA)=S(INDA)+COP(II)*FACS*TERM - GO TO 10 -41 IF(INDA.EQ.IREF0)COPI=C(INDA)*COP(II)/ENP(INDB) - IF(INDA.NE.IREF0)COPI=C(INDA)*COP(II)/ - *(SQRT(ENP(INDA))*SQRT(ENP(INDB))) - CALL DAXPY_(INK,COPI,C(INNY),1,FK,1) -C WRITE(6,654)NK,NSK,INDB -C 654 FORMAT(1X,'TYP1,NK,NSK,INDB',3I7) -C WRITE(6,653)(FK(I),I=1,INK) -C 653 FORMAT(1X,'FK',5F12.6) - GO TO 10 -12 IF(ITER.EQ.1)GO TO 10 - INDA=IRC(1)+ICP1 - INDB=IRC(ITYP)+ICP2 - INMY=INDEX(INDA)+1 - INNY=INDEX(INDB)+1 - MYSYM=JSYM(INDA) - NYSYM=MUL(MYSYM,NSK) - MYL=MUL(MYSYM,LSYM) - NYL=MUL(NYSYM,LSYM) - IFT=0 - IF(ITYP.EQ.2)IFT=1 - CALL IPO_CPF(IPOB,NVIR,MUL,NSYM,NYL,IFT) - NVM=NVIR(MYL) - IF(IDENS.EQ.1)GO TO 210 - FACS=D1 - CALL SETZ(DBK,INK) - CALL DAXPY_(INK,COP(II),FK,1,DBK,1) - IF(NYL.NE.1)GO TO 25 - IF(IFT.EQ.0)CALL SQUAR_CPF(C(INNY+IPOB(MYL)),A,NVM) - IF(IFT.EQ.1)CALL SQUARM_CPF(C(INNY+IPOB(MYL)),A,NVM) - CALL SETZ(B,NVM) - CALL FMMM(DBK,A,B,1,NVM,INK) - CALL DAXPY_(NVM,FACS,B,1,S(INMY),1) - SIGN=D1 - IF(IFT.EQ.1)SIGN=-D1 - IOUT=INNY+IPOB(MYL)-1 - DO 125 I=1,NVM - DO 130 J=1,I - IOUT=IOUT+1 - TERM=DBK(I)*C(INMY+J-1)+SIGN*DBK(J)*C(INMY+I-1) - S(IOUT)=S(IOUT)+FACS*TERM -130 CONTINUE - IF(IFT.EQ.1)GO TO 125 - TERM=DBK(I)*C(INMY+I-1) - S(IOUT)=S(IOUT)-FACS*TERM -125 CONTINUE - GO TO 10 -25 NKM=INK*NVM - CALL SETZ(B,NVM) - IF(NSK.GT.MYL)GO TO 26 - IF(IFT.EQ.1)CALL VNEG_CPF(DBK,1,DBK,1,INK) - CALL FMMM(DBK,C(INNY+IPOB(MYL)),B,1,NVM,INK) - CALL DAXPY_(NVM,FACS,B,1,S(INMY),1) - CALL SETZ(B,NKM) - CALL FMMM(DBK,C(INMY),B,INK,NVM,1) - CALL DAXPY_(NKM,FACS,B,1,S(INNY+IPOB(MYL)),1) - GO TO 10 -26 CALL FMMM(C(INNY+IPOB(NSK)),DBK,B,NVM,1,INK) - CALL DAXPY_(NVM,FACS,B,1,S(INMY),1) - CALL SETZ(B,NKM) - CALL FMMM(C(INMY),DBK,B,NVM,INK,1) - CALL DAXPY_(NKM,FACS,B,1,S(INNY+IPOB(NSK)),1) - GO TO 10 -210 CALL SETZ(B,INK) - COPI=COP(II)/(SQRT(ENP(INDA))*SQRT(ENP(INDB))) -C WRITE(6,652)IFT,NYL,NSK,MYL,INDA,INDB -C 652 FORMAT(1X,'TYP2',6I7) - IF(NYL.NE.1)GO TO 225 - IF(IFT.EQ.0)CALL SQUAR_CPF(C(INNY+IPOB(MYL)),A,NVM) - IF(IFT.EQ.1)CALL SQUARN_CPF(C(INNY+IPOB(MYL)),A,NVM) - CALL FMMM(C(INMY),A,B,1,INK,NVM) -227 CALL VSMA(B,1,COPI,FK,1,FK,1,INK) -C WRITE(6,651)(FK(I),I=1,INK) -C 651 FORMAT(1X,'FK',5F12.6) - GO TO 10 -225 IF(NSK.GT.MYL)GO TO 226 - CALL FMMM(C(INNY+IPOB(MYL)),C(INMY),B,INK,1,NVM) - IF(IFT.EQ.1)COPI=-COPI - GO TO 227 -226 CALL FMMM(C(INMY),C(INNY+IPOB(NSK)),B,1,INK,NVM) - GO TO 227 -10 CONTINUE - GO TO 100 -200 IF(IDENS.EQ.0)GO TO 201 - NA1=NSYS(NSK)+1 - NA2=NSYS(NSK+1) - INK=0 - IF(NA2.LT.NA1)GO TO 201 - DO 213 NA=NA1,NA2 - INK=INK+1 - NAK=IROW(LN+NA)+NK - FC(NAK)=FK(INK) -213 CONTINUE -201 CALL DSQ2(C,S,MUL,INDEX,JSY,NDIAG,INUM,IRC(3), - *LSYM,NVIRT,SQ2) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/ai_cpf.F90 openmolcas-22.10/src/cpf/ai_cpf.F90 --- openmolcas-22.02/src/cpf/ai_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/ai_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,255 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine AI_CPF(JSY,INDX,C,S,FC,BUFIN,A,B,FK,DBK,ENP,EPP,KTYP) +! KTYP=0 , (A/I) INTEGRALS +! KTYP=1 , (AI/JK) INTEGRALS + +use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc +use cpf_global, only: IDENS, IRC, IREF0, IROW, ITER, LASTAD, LBUF, LN, LSYM, Lu_CIGuga, Lu_TiABIJ, NDIAG, NORBT, NSM, NSYM, NSYS, & + NVIR, NVIRT, SQ2 +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Constants, only: Zero, One +use Definitions, only: wp, iwp, r8, RtoI + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: JSY(*), INDX(*), KTYP +real(kind=wp), intent(inout) :: C(*), S(*), FK(*), EPP(*) +real(kind=wp), intent(_OUT_) :: FC(*), BUFIN(*), A(*), B(*), DBK(*) +real(kind=wp), intent(in) :: ENP(*) +integer(kind=iwp) :: IADD10, IADR, ICHK, ICP1, ICP2, IFT, IJ, IJOLD, ILEN, IND, INDA, INDB, INDI, INK, INMY, INNY, INUM, IOUT, & + IPOB(9), ITURN, ITYP, LBUF0, LBUF1, LBUF2, LENGTH, MYL, MYSYM, NA1, NA2, NAK, NI, NJ, NK, NKM, NOB2, NOT2, & + NOTT, NOVST, NSIJ, NSK, NVM, NVT, NYL, NYSYM +real(kind=wp) :: COPI, SGN, TERM +logical(kind=iwp) :: Skip +integer(kind=iwp), external :: JSUNP +real(kind=r8), external :: DDOT_ + +call AI_CPF_INTERNAL(BUFIN) + +! This is to allow type punning without an explicit interface +contains + +subroutine AI_CPF_INTERNAL(BUFIN) + + real(kind=wp), target, intent(_OUT_) :: BUFIN(*) + integer(kind=iwp), pointer :: IBUFIN(:) + integer(kind=iwp) :: I, II, J, NA + + call c_f_pointer(c_loc(BUFIN),iBUFIN,[1]) + + NK = 0 ! dummy initialize + NSK = 0 ! dummy initialize + INUM = IRC(4)-IRC(3) + call PSQ2(C,S,MUL,INDX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) + NVT = IROW(NVIRT+1) + ICHK = 0 + IJOLD = 0 + NOB2 = IROW(NORBT+1) + NOT2 = IROW(LN+1) + NOTT = 2*NOT2 + NOVST = LN*NVIRT+1+NVT + LBUF0 = RTOI*LBUF + LBUF1 = LBUF0+LBUF+1 + LBUF2 = LBUF1+1 + if (KTYP == 0) IADD10 = IAD10(9) + if (KTYP == 1) IADD10 = IAD10(7) + do + call dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) + call iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN == 0) cycle + if (ILEN < 0) exit + do II=1,ILEN + IND = ICOP1(II) + if (ICHK == 0) then + if (IND == 0) then + ICHK = 1 + else if (INK /= 0) then + ITYP = ibits(IND,0,6) + ICP2 = ibits(IND,6,13) + ICP1 = ibits(IND,19,13) + if (ITYP <= 1) then + INDA = ICP1 + INDB = IRC(1)+ICP2 + INNY = INDX(INDB)+1 + if (IDENS /= 1) then + if (INDA == IREF0) then + COPI = COP(II)/sqrt(ENP(INDB)) + S(INNY:INNY+INK-1) = S(INNY:INNY+INK-1)+COPI*FK(1:INK) + if (ITER /= 1) then + TERM = DDOT_(INK,FK,1,C(INNY),1) + EPP(INDB) = EPP(INDB)+COPI*TERM + end if + else + COPI = COP(II)*C(INDA) + S(INNY:INNY+INK-1) = S(INNY:INNY+INK-1)+COPI*FK(1:INK) + TERM = DDOT_(INK,FK,1,C(INNY),1) + S(INDA) = S(INDA)+COP(II)*TERM + end if + else + if (INDA == IREF0) COPI = C(INDA)*COP(II)/ENP(INDB) + if (INDA /= IREF0) COPI = C(INDA)*COP(II)/(sqrt(ENP(INDA))*sqrt(ENP(INDB))) + FK(1:INK) = FK(1:INK)+COPI*C(INNY:INNY+INK-1) + !write(u6,654) NK,NSK,INDB + !write(u6,653) (FK(I),I=1,INK) + end if + else if (ITER /= 1) then + INDA = IRC(1)+ICP1 + INDB = IRC(ITYP)+ICP2 + INMY = INDX(INDA)+1 + INNY = INDX(INDB)+1 + MYSYM = JSUNP(JSY,INDA) + NYSYM = MUL(MYSYM,NSK) + MYL = MUL(MYSYM,LSYM) + NYL = MUL(NYSYM,LSYM) + IFT = 0 + if (ITYP == 2) IFT = 1 + call IPO_CPF(IPOB,NVIR,MUL,NSYM,NYL,IFT) + NVM = NVIR(MYL) + if (IDENS /= 1) then + DBK(1:INK) = COP(II)*FK(1:INK) + if (NYL == 1) then + if (IFT == 0) call SQUAR(C(INNY+IPOB(MYL)),A,NVM) + if (IFT == 1) call SQUARM(C(INNY+IPOB(MYL)),A,NVM) + call FMMM(DBK,A,B,1,NVM,INK) + S(INMY:INMY+NVM-1) = S(INMY:INMY+NVM-1)+B(1:NVM) + SGN = One + if (IFT == 1) SGN = -One + IOUT = INNY+IPOB(MYL)-1 + do I=1,NVM + do J=1,I + IOUT = IOUT+1 + TERM = DBK(I)*C(INMY+J-1)+SGN*DBK(J)*C(INMY+I-1) + S(IOUT) = S(IOUT)+TERM + end do + if (IFT == 1) cycle + TERM = DBK(I)*C(INMY+I-1) + S(IOUT) = S(IOUT)-TERM + end do + else + NKM = INK*NVM + if (NSK <= MYL) then + if (IFT == 1) DBK(1:INK) = -DBK(1:INK) + I = INNY+IPOB(MYL) + call FMMM(DBK,C(I),B,1,NVM,INK) + S(INMY:INMY+NVM-1) = S(INMY:INMY+NVM-1)+B(1:NVM) + call FMMM(DBK,C(INMY),B,INK,NVM,1) + else + I = INNY+IPOB(NSK) + call FMMM(C(I),DBK,B,NVM,1,INK) + S(INMY:INMY+NVM-1) = S(INMY:INMY+NVM-1)+B(1:NVM) + call FMMM(C(INMY),DBK,B,NVM,INK,1) + end if + S(I:I+NKM-1) = S(I:I+NKM-1)+B(1:NKM) + end if + else + COPI = COP(II)/(sqrt(ENP(INDA))*sqrt(ENP(INDB))) + !write(u6,652) IFT,NYL,NSK,MYL,INDA,INDB + if (NYL /= 1) then + if (NSK > MYL) then + call FMMM(C(INMY),C(INNY+IPOB(NSK)),B,1,INK,NVM) + else + call FMMM(C(INNY+IPOB(MYL)),C(INMY),B,INK,1,NVM) + if (IFT == 1) COPI = -COPI + end if + else + if (IFT == 0) call SQUAR(C(INNY+IPOB(MYL)),A,NVM) + if (IFT == 1) call SQUARN(C(INNY+IPOB(MYL)),A,NVM) + call FMMM(C(INMY),A,B,1,INK,NVM) + end if + FK(1:INK) = FK(1:INK)+COPI*B(1:INK) + !write(u6,651) (FK(I),I=1,INK) + end if + end if + end if + else + ICHK = 0 + ITURN = 0 + Skip = .false. + if ((IDENS == 1) .and. (IJOLD /= 0)) Skip = .true. + do + if (Skip) then + Skip = .false. + else + ITURN = 1 + if (KTYP /= 1) then + NK = IND + IJOLD = NK + NSK = NSM(NK) + else + INDI = IND + NI = ibits(INDI,0,10) + NJ = ibits(INDI,10,10) + NK = ibits(INDI,20,10) + NSIJ = MUL(NSM(NI),NSM(NJ)) + NSK = MUL(NSIJ,NSM(NK)) + IJ = IROW(NI)+NJ + if (IJ /= IJOLD) then + IJOLD = IJ + IADR = LASTAD(NOVST+NOTT+IJ) + FC(1:NOB2) = Zero + do + call iDAFILE(Lu_TiABIJ,2,IBUFIN,LBUF2,IADR) + LENGTH = IBUFIN(LBUF1) + IADR = IBUFIN(LBUF2) + if (LENGTH /= 0) call SCATTER(LENGTH,FC,IBUFIN(LBUF0+1:LBUF0+LENGTH),BUFIN) + if (IADR == -1) exit + end do + end if + end if + end if + ! FORM VECTOR FK + NA1 = NSYS(NSK)+1 + NA2 = NSYS(NSK+1) + INK = 0 + if (NA2 < NA1) exit + do NA=NA1,NA2 + INK = INK+1 + NAK = IROW(LN+NA)+NK + if (ITURN == 0) FC(NAK) = FK(INK) + if (ITURN == 1) FK(INK) = FC(NAK) + end do + if (ITURN /= 0) exit + end do + end if + end do + end do + if (IDENS /= 0) then + NA1 = NSYS(NSK)+1 + NA2 = NSYS(NSK+1) + INK = 0 + do NA=NA1,NA2 + INK = INK+1 + NAK = IROW(LN+NA)+NK + FC(NAK) = FK(INK) + end do + end if + call DSQ2(C,S,MUL,INDX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) + + nullify(IBUFIN) + + return + + !651 format(1X,'FK',5F12.6) + !652 format(1X,'TYP2',6I7) + !653 format(1X,'FK',5F12.6) + !654 format(1X,'TYP1,NK,NSK,INDB',3I7) + +end subroutine AI_CPF_INTERNAL + +end subroutine AI_CPF diff -Nru openmolcas-22.02/src/cpf/alloc_cpf.f openmolcas-22.10/src/cpf/alloc_cpf.f --- openmolcas-22.02/src/cpf/alloc_cpf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/alloc_cpf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,251 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE ALLOC_CPF(ISMAX,LPERMA) - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "cpfmcpf.fh" - DIMENSION IPOF(9) - ILIM=4 - IF(IFIRST.NE.0)ILIM=2 -CPAM96 WRITE(6,50) -CPAM9650 FORMAT(/,6X,'DYNAMICAL CORE STORAGE INFORMATION',/) - ISTOP=0 - MAX1=0 - MAX2=0 - NVMAX=0 - DO 10 I=1,NSYM - CALL IPO_CPF(IPOF,NVIR,MUL,NSYM,I,-1) - IF(IPOF(NSYM+1).GT.MAX1)MAX1=IPOF(NSYM+1) - IF(NVIR(I).GT.NVMAX)NVMAX=NVIR(I) - DO 20 J=1,NSYM - IPF=IPOF(J+1)-IPOF(J) - IF(IPF.GT.MAX2)MAX2=IPF -20 CONTINUE -10 CONTINUE -CPAM97 CALL ALSO(LW,IROW,LIC,NORBT,NVIRT,LN,ISTOP,IFIRST, -CPAM97 *MADR,LPERMA,LBUF,KBUF,JBUF,IPASS,IRC(1),ISMAX,KBUFF1) - CALL ALSO(ISTOP,LPERMA,IRC(1),ISMAX) -C VECTORS PERMANENTLY IN CORE DURING CI ITERATIONS -C CI-VECTOR -C C - LW(26)=LPERMA -C S (SIGMA) - LW(27)=LW(26)+JSC(ILIM) -C W - LW(28)=LW(27)+JSC(ILIM) -C ITHE (TETA) - LW(29)=LW(28)+JSC(ILIM) - IF(ICPF.EQ.1.OR.ISDCI.EQ.1.OR.INCPF.EQ.1)LW(29)=LW(28) -C TPQ (ONE ROW) - LW(30)=LW(29)+IRC(ILIM)*IRC(ILIM) - IF(ICPF.EQ.1.OR.ISDCI.EQ.1.OR.INCPF.EQ.1)LW(30)=LW(29) -C ENP (NP) - LW(31)=LW(30)+IRC(ILIM) -C EPP (EPRIME) - LW(32)=LW(31)+IRC(ILIM) -C BST (STORED BIJ MATRIX) - LW(33)=LW(32)+IRC(ILIM) -C ADDRESSES NOT USED - LW(34)=LW(33)+(MAXIT+1)**2 - LW(35)=LW(34) - LPERMB=LW(35) -C DYNAMICAL ALLOCATION FOR AIBJ -C MATRIX ABIJ - LW(36)=LPERMB -C MATRIX AIBJ - LW(37)=LW(36)+MAX1 -C MATRIX AJBI - LW(38)=LW(37)+MAX1 -C BUFIN , IBUFIN - LW(39)=LW(38)+MAX1 -C A -CRL LW(40)=LW(39)+2*LBUF+2 -CPAM96 LW(40)=LW(39)+LBUF+LBUF/2+2 - LW(40)=LW(39)+((RTOI+1)*LBUF+2+(RTOI-1))/RTOI -C B - LW(41)=LW(40)+MAX2 -C F - LW(42)=LW(41)+MAX2 -C FSEC - LW(43)=LW(42)+MAX1 -C ADDRESSES NOT USED - LW(44)=LW(43)+MAX1 - LW(45)=LW(44) - LIM=LW(45) - IF(LIM.GT.LIC) THEN - ISTOP=1 - WRITE(6,*)'ALLOC: Too much storage needed for AIBJ.' - WRITE(6,'(1X,A,2I10)')'LIM,LIC:',LIM,LIC - END IF -C DYNAMICAL ALLOCATION FOR IJKL -C FIJKL - LW(46)=LPERMB - NIJ=IROW(LN+1) - IJKL=(NIJ*(NIJ+1))/2 -C BUFIN , IBUFIN - LW(47)=LW(46)+IJKL -C ADDRESSES NOT USED - LW(48)=LW(47)+KBUFF1+2 - LW(49)=LW(48) - LIM=LW(49) - IF(LIM.GT.LIC) THEN - ISTOP=1 - WRITE(6,*)'ALLOC: Too much storage needed for IJKL.' - WRITE(6,'(1X,A,2I10)')'LIM,LIC:',LIM,LIC - END IF -C DYNAMICAL ALLOCATION FOR ABCI -C BMN - LW(50)=LPERMB -C IBMN - JMAX=IAD10(1) - IF(IFIRST.NE.0)JMAX=0 - LW(51)=LW(50)+JMAX -C BIAC - LW(52)=LW(51)+JMAX -C BICA - LW(53)=LW(52)+ISMAX -C BUFIN - LW(54)=LW(53)+ISMAX -C ADDRESSES NOT USED - LW(55)=LW(54)+KBUFF1 - LW(56)=LW(55) - LIM=LW(56) - IF(LIM.GT.LIC) THEN - ISTOP=1 - WRITE(6,*)'ALLOC: Too much storage needed for ABCI.' - WRITE(6,'(1X,A,2I10)')'LIM,LIC:',LIM,LIC - END IF -C DYNAMICAL ALLOCATION FOR ABCD -C ACBDS - LW(57)=LPERMB -C ACBDT - LW(58)=LW(57)+ISMAX -C BUFIN - LW(59)=LW(58)+ISMAX -C ADDRESSES NOT USED - LW(60)=LW(59)+KBUFF1 - LW(61)=LW(60) - LIM=LW(61) - IF(LIM.GT.LIC) THEN - ISTOP=1 - WRITE(6,*)'ALLOC: Too much storage needed for ABCD.' - WRITE(6,'(1X,A,2I10)')'LIM,LIC:',LIM,LIC - END IF -C DYNAMICAL ALLOCATION FOR FIJ, AI AND AB -C FC - LW(62)=LPERMB - NOB2=IROW(NORBT+1) -C BUFIN , IBUFIN - LW(63)=LW(62)+NOB2 -C A -CRL LW(64)=LW(63)+2*LBUF+2 -CPAM96 LW(64)=LW(63)+LBUF+LBUF/2+2 - LW(64)=LW(63)+((RTOI+1)*LBUF+2+(RTOI-1))/RTOI -C B - LW(65)=LW(64)+MAX2 -C FK IN AI AND F IN AB - LW(66)=LW(65)+MAX2 -C DBK - LW(67)=LW(66)+NVMAX - LIM=LW(67)+NVMAX - LIM1=LW(66)+MAX1 - IF(LIM.LT.LIM1)LIM=LIM1 -C ADDRESSES NOT USED - LW(68)=LIM - LW(69)=LW(68) - LW(70)=LW(69) - LW(71)=LW(70) - LIM=LW(71) - IF(LIM.GT.LIC) THEN - ISTOP=1 - WRITE(6,*)'ALLOC: Too much storage needed for FIJ,AI,AB' - WRITE(6,'(1X,A,2I10)')'LIM,LIC:',LIM,LIC - END IF -C DYNAMICAL ALLOCATION FOR NPSET -C TEMP - LW(72)=LPERMB -C ADDRESSES NOT USED - LW(73)=LW(72)+IRC(ILIM) - LW(74)=LW(73) - LIM=LW(74) -CPAM96 WRITE(6,358)LIM -CPAM96358 FORMAT(6X,'STORAGE FOR NPSET',I14) -C DYNAMICAL ALLOCATION FOR CPFCTL -C EPB (EPBIS) - LW(75)=LPERMB -C AP (APPRIME) - LW(76)=LW(75)+IRC(ILIM) -C BIJ - LW(77)=LW(76)+IRC(ILIM) -C CN - LW(78)=LW(77)+(MAXIT+1)**2 -C TEMP1 - LW(79)=LW(78)+MAXIT+1 - NTMAX=0 - DO 357 I=1,NSYM - IF(NVIR(I).GT.NTMAX)NTMAX=NVIR(I) - IF(NNS(I).GT.NTMAX)NTMAX=NNS(I) -357 CONTINUE - IF(IRC(ILIM).GT.NTMAX)NTMAX=IRC(ILIM) -C TEMP2 - LW(80)=LW(79)+NTMAX - LIM=LW(80)+NTMAX - IF(LIM.GT.LIC) THEN - ISTOP=1 - WRITE(6,*)'ALLOC: Too much storage needed for CPFCTL' - WRITE(6,'(1X,A,2I10)')'LIM,LIC:',LIM,LIC - END IF -C NATURAL ORBITALS -C DENSITY MATRIX AT LPERMB , D -C MOLECULAR ORBITALS ALL SYMMETRIES , CM - LW(87)=LPERMB+NOB2 - LCIN=0 - NBMAX=0 - DO 350 I=1,NSYM - NBMAX = MAX(NBMAX,NBAS(I)) - LCIN=LCIN+NBAS(I)*NBAS(I) -350 CONTINUE -C NATURAL ORBITALS ONE SYMMETRY , CMO - LW(88)=LW(87)+LCIN -C DENSITY MATRIX FOR ONE SYMMETRY , DSYM -C MOLECULAR ORBITAL IN AO-BASIS for one symmetry, CAO - LW(89)=LW(88)+NBMAX*NBMAX -C OCCUPATION NUMBERS FOR ALL POSSIBLE ORBITALS - NTOT=0 - DO 333 I=1,NSYM - NTOT=NTOT+NBAS(I) -333 CONTINUE - LW(90)=LW(89)+NBMAX*NBMAX -C OVERLAP MATRIX IN CHARGE - LW(91)=LW(90)+NTOT -C ADDRESSES NOT USED - LW(92)=LW(91) - LW(93)=LW(92) - LIM=LW(93) -CPAM96 WRITE(6,349)LIM -CPAM96349 FORMAT(6X,'STORAGE FOR DENS',I15) - IF(IPRINT.GE.2) THEN -C LW(94), LW(95) AND LW(96) USED IN SORTING ABCD - WRITE(6,450) - WRITE(6,451)(LW(I),I=1,96) -450 FORMAT(//,6X,'DYNAMICAL STORAGE ADDRESSES LW:',/) -451 FORMAT(6X,5I10) - END IF - IF(ISTOP.EQ.0)RETURN - WRITE(6,*)'ALLOC: Too little memory available.' - WRITE(6,*)'Program stops here.' - CALL Abend - END diff -Nru openmolcas-22.02/src/cpf/alloc_cpf.F90 openmolcas-22.10/src/cpf/alloc_cpf.F90 --- openmolcas-22.02/src/cpf/alloc_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/alloc_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,152 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine ALLOC_CPF() + +use cpf_global, only: IFIRST, ILIM, IPASS, IRC, IROW, JBUF, JMAX, KBUF, KBUFF1, LBUF, LIC, LN, MADR, MAX11, MX1, MX2, NNS, NORBT, & + NOV, NOV1, NSYM, NTIBUF, NTMAX, NVIR, NVIRT, NVMAX, NVT5 +use guga_util_global, only: IAD10 +use Symmetry_Info, only: Mul +use Definitions, only: iwp, u6, RtoI + +implicit none +integer(kind=iwp) :: I, IPF, IPOF(9), ISTOP, J, JBUF1, KBUF1, LBUF1, LICX, LICXX, LPERMX, LSTO3, LSTO4, NOB2, NOT2, NOVT, NVT + +ISTOP = 0 +MX1 = 0 +MX2 = 0 +NVMAX = 0 +do I=1,NSYM + call IPO_CPF(IPOF,NVIR,MUL,NSYM,I,-1) + if (IPOF(NSYM+1) > MX1) MX1 = IPOF(NSYM+1) + if (NVIR(I) > NVMAX) NVMAX = NVIR(I) + do J=1,NSYM + IPF = IPOF(J+1)-IPOF(J) + if (IPF > MX2) MX2 = IPF + end do +end do + +! DYNAMICAL ALLOCATION FOR SORTING +NVT = IROW(NVIRT+1) +! BUFFER FOR INTEGRALS +LPERMX = NTIBUF +LICX = LIC-LPERMX +! DYNAMICAL ALLOCATION FOR SORTING AIBJ +NOB2 = IROW(NORBT+1) +NOT2 = IROW(LN+1) +NOV = 3*NOT2 +LSTO3 = LICX-2*NOV-3*NOB2 +! LBUF1: Nr of available reals per bin +LBUF1 = LSTO3/NOV +!PAM96 LBUF = (LBUF/2)*2 +!PAM96 ! *** FPS *** +!PAM96 !LBUF = (LBUF1-2)/2 +! LBUF: Nr of items per bin +LBUF = (RTOI*LBUF1-2)/(RTOI+1) +if (LBUF > 998) LBUF = 998 +LBUF = ((LBUF+2)/RTOI)*RTOI-2 +!PAM96 write(u6,150) NOV,MADR,LBUF +if (LBUF < 20) then + ISTOP = 3 + write(u6,*) 'ALLOC_CPF: Impossibly small buffers, too many bins,' + write(u6,*) 'for sorting AIBJ. Program will have to stop.' +end if +! MAXIMUM LENGTH OF HDIAG +MAX11 = max(NVT,IRC(1)) +if (MAX11 < IRC(1)) MAX11 = IRC(1) +NOV1 = NOV +! DYNAMICAL ALLOCATION FOR SORTING ABCD +JBUF = 1 +NOVT = 0 +if (IFIRST == 0) then + IPASS = 1 + do + NVT5 = (NVT-1)/IPASS+1 + LICXX = LICX-KBUFF1 + LSTO4 = LICXX-2*NVT5 + !RL JBUF1 = LSTO4/NVT5 + ! JBUF1: Nr of available reals per bin + JBUF1 = LSTO4/NVT5-1 + !PAM96 JBUF = 2*(JBUF1-1)/3 + !PAM96 JBUF = (JBUF/2)*2 + !PAM96 ! *** FPS *** + !PAM96 !RL JBUF = (JBUF1-2)/2 + ! JBUF: Nr of items per bin + JBUF = (RTOI*JBUF1-2)/(RTOI+1) + if (JBUF > 800) exit + IPASS = IPASS+1 + if (IPASS > 5) exit + end do + if (JBUF > 998) JBUF = 998 + NOVT = NOV+NVT + JBUF = ((JBUF+2)/RTOI)*RTOI-2 + !PAM96 write(u6,150) NOVT,MADR,JBUF + !PAM96 write(u6,160) IPASS + if (JBUF < 20) then + ISTOP = 3 + write(u6,*) 'ALLOC_CPF: Impossibly small buffers, too many bins,' + write(u6,*) 'for sorting ABCD. Program will have to stop.' + end if + ! DYNAMICAL ALLOCATION FOR SORTING ABCI + NOV = LN*NVIRT+1 +else + NVT5 = 0 + NOV = 1 +end if +LSTO4 = LICX-2*NOV +! KBUF1: Nr of available reals per bin +KBUF1 = LSTO4/NOV +!PAM96 KBUF = 2*(KBUF1-1)/3 +!PAM96 KBUF = (KBUF/2)*2 +!PAM96 ! *** FPS *** +!PAM96 !RL KBUF = (KBUF1-2)/2 +! KBUF: Nr of items per bin +KBUF = (RTOI*KBUF1-2)/(RTOI+1) +if (KBUF > 998) KBUF = 998 +NOVT = NOVT+NOV +KBUF = ((KBUF+2)/RTOI)*RTOI-2 +!PAM96 write(u6,150) NOVT,MADR,KBUF +if (KBUF < 20) then + ISTOP = 3 + write(u6,*) 'ALLOC_CPF: Impossibly small buffers, too many bins,' + write(u6,*) 'for sorting ABCI. Program will have to stop.' +end if +if (NOVT >= MADR) then + ISTOP = 2 + write(u6,*) 'ALLOC_CPF: Too much storage needed.' + write(u6,'(1X,A,2I10)') 'NOVT,MADR:',NOVT,MADR +end if + +JMAX = IAD10(1) +if (IFIRST /= 0) JMAX = 0 +NTMAX = 0 +do I=1,NSYM + if (NVIR(I) > NTMAX) NTMAX = NVIR(I) + if (NNS(I) > NTMAX) NTMAX = NNS(I) +end do +if (IRC(ILIM) > NTMAX) NTMAX = IRC(ILIM) +if (ISTOP /= 0) then + write(u6,*) 'ALLOC: Too little memory available.' + write(u6,*) 'Program stops here.' + + call Abend() +end if + +return + +!PAM96 150 format(6X,'NUMBER OF CHAINS ON DRUM',I7,/,6X,'PRESENT LIMIT',I18,/,6X,'BUFFERT FOR SORTING',I13,/,6X,'PRESENT LIMIT', & +!PAM96 16X,'20') +!PAM96 160 format(6X,'NUMBER OF PASSES',I15) + +end subroutine ALLOC_CPF diff -Nru openmolcas-22.02/src/cpf/also.f openmolcas-22.10/src/cpf/also.f --- openmolcas-22.02/src/cpf/also.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/also.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,207 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE ALSO(ISTOP,LPERMA,IRC1,ISMAX) - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "cpfmcpf.fh" -C DYNAMICAL ALLOCATION FOR SORTING -C ADDRESSES LW(11)-LW(25) - NVT=IROW(NVIRT+1) -C BUFFER FOR INTEGRALS AT LPERMA = LW(7) ON FPS - LPERMX=LPERMA+NTIBUF - LICX=LIC-LPERMX -C DYNAMICAL ALLOCATION FOR SORTING AIBJ - NOB2=IROW(NORBT+1) - NOT2=IROW(LN+1) - NOV=3*NOT2 - INOV=NOV - LSTO3=LICX-2*INOV-3*NOB2 -C LBUF1: Nr of available reals per bin - LBUF1=LSTO3/NOV -CPAM96 LBUF=(LBUF/2)*2 -CPAM96C *** FPS *** -CPAM96C LBUF=(LBUF1-2)/2 -C LBUF: Nr of items per bin - LBUF=(RTOI*LBUF1-2)/(RTOI+1) - IF(LBUF.GT.998)LBUF=998 - LBUF=((LBUF+2)/RTOI)*RTOI-2 - LBUF1=(LBUF*(RTOI+1)+2+(RTOI-1))/RTOI -CPAM96 WRITE(6,150)NOV,MADR,LBUF -CPAM96150 FORMAT(6X,'NUMBER OF CHAINS ON DRUM',I7, -CPAM96 */,6X,'PRESENT LIMIT',I18, -CPAM96 */,6X,'BUFFERT FOR SORTING',I13, -CPAM96 */,6X,'PRESENT LIMIT',16X,'20') - IF(LBUF.LT.20) THEN - ISTOP=3 - WRITE(6,*)'ALSO: Impossibly small buffers, too many bins,' - WRITE(6,*)'for sorting AIBJ. Program will have to stop.' - END IF -C SORTING AREA , BUFOUT AND INDOUT -C ALSO HDIAG IN DIAG - LW(11)=LPERMX -C CORE ADDRESSES , ICAD -CRL LW(12)=LW(11)+NOV*(2*LBUF+2) -CPAM96 LW(12)=LW(11)+NOV*(LBUF+LBUF/2+2) - LW(12)=LW(11)+NOV*((LBUF*(RTOI+1)+2+(RTOI-1))/RTOI) -C BUFFER-COUNTER , IBUFL - LW(13)=LW(12)+INOV -C FOCK-MATRIX - LW(14)=LW(13)+INOV -C MAXIMUM LENGTH OF HDIAG - MAX11=NVT - IF(MAX11.LT.IRC1)MAX11=IRC1 - IF(LW(14).LT.LW(11)+MAX11)LW(14)=LW(11)+MAX11 -C IIJJ-INTEGRALS - LW(15)=LW(14)+NOB2 -C IJIJ-INTEGRALS - LW(16)=LW(15)+NOB2 - LIM=LW(16)+NOB2-1 -CPAM96 WRITE(6,404)LIM -CPAM96404 FORMAT(6X,'STORAGE FOR SORTING AIBJ',I7) - IF(LIM.GT.LIC) THEN - ISTOP=1 - WRITE(6,*)'ALSO: Too much storage needed for AIBJ.' - WRITE(6,'(1X,A,2I10)')'LIM,LIC:',LIM,LIC - END IF -C DYNAMICAL ALLOCATION FOR SORTING ABCD - JBUF=1 - NOVT=0 - IF(IFIRST.NE.0)GO TO 35 - IPASS=1 -110 NVT5=(NVT-1)/IPASS+1 - INVT5=NVT5 - LICXX=LICX-KBUFF1 - LSTO4=LICXX-2*INVT5 -CRL JBUF1=LSTO4/NVT5 -C JBUF1: Nr of available reals per bin - JBUF1=LSTO4/NVT5-1 -CPAM96 JBUF=2*(JBUF1-1)/3 -CPAM96 JBUF=(JBUF/2)*2 -CPAM96C *** FPS *** -CPAM96CRL JBUF=(JBUF1-2)/2 -C JBUF: Nr of items per bin - JBUF=(RTOI*JBUF1-2)/(RTOI+1) - IF(JBUF.GT.800)GO TO 120 - IPASS=IPASS+1 - IF(IPASS.GT.5)GO TO 120 - GO TO 110 -120 IF(JBUF.GT.998)JBUF=998 - NOVT=NOV+NVT - JBUF=((JBUF+2)/RTOI)*RTOI-2 - JBUF1=(JBUF*(RTOI+1)+2+(RTOI-1))/RTOI -CPAM96 WRITE(6,150)NOVT,MADR,JBUF -CPAM96 WRITE(6,160)IPASS -C160 FORMAT(6X,'NUMBER OF PASSES',I15) - IF(JBUF.LT.20) THEN - ISTOP=3 - WRITE(6,*)'ALSO: Impossibly small buffers, too many bins,' - WRITE(6,*)'for sorting ABCD. Program will have to stop.' - END IF -C BUFACBD - LW(96)=LPERMX -C SORTING AREA , BUFOUT AND INDOUT - LW(17)=LW(96)+KBUFF1 -C CORE ADDRESSES , ICAD -CRL LW(18)=LW(17)+NVT5*(2*JBUF+2) -CPAM96 LW(18)=LW(17)+NVT5*(JBUF+JBUF/2+2) - LW(18)=LW(17)+NVT5*((JBUF*(RTOI+1)+2+(RTOI-1))/RTOI) -C BUFFER-COUNTER , IBUFL - LW(19)=LW(18)+INVT5 - LIM=LW(19)+INVT5-1 -C ACBDS -C (NOTE: FIRST PART OF BUFOUT (=2*JBUF+2) USED DURING CONSTRUCTION O -C ACBDS AND ACBDT VECTORS) -CRL LW(94)=LW(17)+2*JBUF+2 -CPAM96 LW(94)=LW(17)+JBUF+JBUF/2+2 - LW(94)=LW(17)+(JBUF*(RTOI+1)+2+(RTOI-1))/RTOI -C ACBDT - LW(95)=LW(94)+ISMAX - LIMT=LW(95)+ISMAX - IF(LIMT.GT.LW(18)) THEN - ISTOP=1 - WRITE(6,*)'ALSO: Too much storage needed for ABCD.' - WRITE(6,'(1X,A,2I10)')'LIMT,LW(18):',LIMT,LW(18) - END IF -CPAM96 WRITE(6,402) -CPAM96402 FORMAT(6X,'NOT ENOUGH STORAGE IN SORTB') -CPAM96401 WRITE(6,405)LIM -CPAM96405 FORMAT(6X,'STORAGE FOR SORTING ABCD',I7) - IF(LIM.GT.LIC) THEN - ISTOP=1 - WRITE(6,*)'ALSO: Too much storage needed for ABCD.' - WRITE(6,'(1X,A,2I10)')'LIM,LIC:',LIM,LIC - END IF -C DYNAMICAL ALLOCATION FOR SORTING ABCI - NOV=LN*NVIRT+1 -35 IF(IFIRST.NE.0)NOV=1 - INOV=NOV - LSTO4=LICX-2*INOV -C KBUF1: Nr of available reals per bin - KBUF1=LSTO4/NOV -CPAM96 KBUF=2*(KBUF1-1)/3 -CPAM96 KBUF=(KBUF/2)*2 -CPAM96C *** FPS *** -CPAM96CRL KBUF=(KBUF1-2)/2 -C KBUF: Nr of items per bin - KBUF=(RTOI*KBUF1-2)/(RTOI+1) - IF(KBUF.GT.998)KBUF=998 - NOVT=NOVT+NOV - KBUF=((KBUF+2)/RTOI)*RTOI-2 - KBUF1=(KBUF*(RTOI+1)+2+(RTOI-1))/RTOI -CPAM96 WRITE(6,150)NOVT,MADR,KBUF - IF(KBUF.LT.20) THEN - ISTOP=3 - WRITE(6,*)'ALSO: Impossibly small buffers, too many bins,' - WRITE(6,*)'for sorting ABCI. Program will have to stop.' - END IF -C SORTING AREA , BUFOUT AND INDOUT - LW(20)=LPERMX -C CORE ADDRESSES , ICAD -CRL LW(21)=LW(20)+NOV*(2*KBUF+2) -CPAM96 LW(21)=LW(20)+NOV*(KBUF+KBUF/2+2) - LW(21)=LW(20)+NOV*((KBUF*(RTOI+1)+2+(RTOI-1))/RTOI) -C BUFFER-COUNTER , IBUFL - LW(22)=LW(21)+INOV - LIM=LW(22)+MAX(INOV-1,25000) -C BIAC -C (NOTE: FIRST PART OF BUFOUT(=2*KBUF+2) USED WHEN READING THE SORTE -CRL LW(23)=LW(20)+2*KBUF+2 -CPAM96 LW(23)=LW(20)+KBUF+KBUF/2+2 - LW(23)=LW(20)+(KBUF*(RTOI+1)+2+(RTOI-1))/RTOI -C BICA - LW(24)=LW(23)+ISMAX -C BUFBI,INDBI - LW(25)=LW(24)+ISMAX - LIMT=LW(25)+KBUFF1+2 - IF(LIMT.GE.LIM) then - ISTOP=1 - WRITE(6,*)'ALSO: Too much storage needed.' - WRITE(6,'(1X,A,2I10)')'LIMT,LIM:',LIMT,LIM - END IF - IF(LIM.GT.LIC) THEN - ISTOP=1 - WRITE(6,*)'ALSO: Too much storage needed for ABCI.' - WRITE(6,'(1X,A,2I10)')'LIM,LIC:',LIM,LIC - END IF -CPAM96411 WRITE(6,410)LIM -CPAM96410 FORMAT(6X,'STORAGE FOR SORTING ABCI',I7) - IF(NOVT.GE.MADR) THEN - ISTOP=2 - WRITE(6,*)'ALSO: Too much storage needed.' - WRITE(6,'(1X,A,2I10)')'NOVT,MADR:',NOVT,MADR - END IF - RETURN - END diff -Nru openmolcas-22.02/src/cpf/apprim.f openmolcas-22.10/src/cpf/apprim.f --- openmolcas-22.02/src/cpf/apprim.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/apprim.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE APPRIM(EPP,EPB,TPQ,AP,ENP,T1,T2,ICASE) - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "cpfmcpf.fh" - DIMENSION EPP(*),EPB(*),TPQ(*),AP(*),ENP(*),T1(*),T2(*) - DIMENSION ICASE(*) -C - IP=IRC(4) - DO 5 I=1,IP - CALL TPQSET(ICASE,TPQ,I) - CALL VAM(EPP,1,EPB,1,TPQ,1,T1,1,IP) - CALL VDIV(ENP,1,T1,1,T2,1,IP) - CALL VECSUM_CPFMCPF(T2,AP(I),IP) - AP(I)=AP(I)*ENP(I) -5 CONTINUE -C - IF(IPRINT.GT.5)WRITE(6,999)(AP(I),I=1,IP) -999 FORMAT(6X,'AP ',5F10.6) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/apprim.F90 openmolcas-22.10/src/cpf/apprim.F90 --- openmolcas-22.02/src/cpf/apprim.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/apprim.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,42 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine APPRIM(EPP,EPB,TPQ,AP,ENP,T2,ICASE) + +use cpf_global, only: IPRINT, IRC +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +real(kind=wp), intent(in) :: EPP(*), EPB(*), ENP(*) +real(kind=wp), intent(_OUT_) :: TPQ(*), AP(*), T2(*) +integer(kind=iwp), intent(in) :: ICASE(*) +integer(kind=iwp) :: I, IP + +IP = IRC(4) +do I=1,IP + call TPQSET(ICASE,TPQ,I) + T2(1:IP) = (EPP(1:IP)+EPB(1:IP))*TPQ(1:IP)/ENP(1:IP) + call VECSUM_CPFMCPF(T2,AP(I),IP) + AP(I) = AP(I)*ENP(I) +end do + +if (IPRINT > 5) write(u6,999) (AP(I),I=1,IP) + +return + +999 format(6X,'AP ',5F10.6) + +end subroutine APPRIM diff -Nru openmolcas-22.02/src/cpf/CMakeLists.txt openmolcas-22.10/src/cpf/CMakeLists.txt --- openmolcas-22.02/src/cpf/CMakeLists.txt 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -9,4 +9,69 @@ # LICENSE or in . * #*********************************************************************** +set (sources + main.F90 + abcd_cpf.F90 + abci_cpf.F90 + ab_cpf.F90 + ai_cpf.F90 + alloc_cpf.F90 + apprim.F90 + count_cpf.F90 + cpfctl.F90 + cpf.F90 + cpf_global.F90 + cupdate.F90 + decomp.F90 + dens_cpf.F90 + densct_cpf.F90 + diagc_cpf.F90 + diag_cpf.F90 + diagct_cpf.F90 + diis_cpf.F90 + dsq2.F90 + epsbis.F90 + epsprim.F90 + faibj_cpf.F90 + fij_cpf.F90 + ifock.F90 + iijj_cpf.F90 + ijij_cpf.F90 + ijkl_cpf.F90 + indmat_cpf.F90 + ipo_cpf.F90 + mabcd.F90 + mabci.F90 + mab.F90 + mai.F90 + mdiagc.F90 + mdsq2.F90 + mfaibj.F90 + mfij.F90 + mijkl.F90 + mpsq2.F90 + natct.F90 + natorb_cpf.F90 + next.F90 + npset.F90 + onect.F90 + prwf_cpf.F90 + psq2.F90 + readin_cpf.F90 + restart_cpfmcpf.F90 + scatter.F90 + sdci_cpf.F90 + secord.F90 + sing.F90 + solve.F90 + sorta_cpf.F90 + sortb_cpf.F90 + sort_cpf.F90 + start_cpf.F90 + thetset.F90 + tpqset.F90 + twoct.F90 + vecsum_cpfmcpf.F90 +) + include (${PROJECT_SOURCE_DIR}/cmake/prog_template.cmake) diff -Nru openmolcas-22.02/src/cpf/count_cpf.F90 openmolcas-22.10/src/cpf/count_cpf.F90 --- openmolcas-22.02/src/cpf/count_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/count_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,65 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine COUNT_CPF(NINTGR,NSYM,NORB,MUL) + +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(out) :: NINTGR +integer(kind=iwp), intent(in) :: NSYM, NORB(*), MUL(8,8) +integer(kind=iwp) :: NOP, NOQ, NOR, NORBP, NOS, NSP, NSPQ, NSPQR, NSQ, NSR, NSS, NSSM, NT, NTM, NU, NUMAX, NUMIN, NV, NX, NXM + +! COUNT TWO-ELECTRON INTEGRALS +NINTGR = 0 +do NSP=1,NSYM + NOP = NORB(NSP) + do NSQ=1,NSP + NSPQ = MUL(NSP,NSQ) + NOQ = NORB(NSQ) + do NSR=1,NSP + NSPQR = MUL(NSPQ,NSR) + NOR = NORB(NSR) + NSSM = NSR + if (NSR == NSP) NSSM = NSQ + do NSS=1,NSSM + if (NSS /= NSPQR) cycle + NOS = NORB(NSS) + NORBP = NOP*NOQ*NOR*NOS + if (NORBP == 0) cycle + do NV=1,NOR + NXM = NOS + if (NSR == NSS) NXM = NV + do NX=1,NXM + NTM = 1 + if (NSP == NSR) NTM = NV + do NT=NTM,NOP + NUMIN = 1 + if ((NSP == NSR) .and. (NT == NV)) NUMIN = NX + NUMAX = NOQ + if (NSP == NSQ) NUMAX = NT + do NU=NUMIN,NUMAX + NINTGR = NINTGR+1 + end do + end do + end do + end do + end do + end do + end do +end do + +return + +end subroutine COUNT_CPF diff -Nru openmolcas-22.02/src/cpf/count.f openmolcas-22.10/src/cpf/count.f --- openmolcas-22.02/src/cpf/count.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/count.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE COUNT_CPF(NINTGR,NSYM,NORB,MUL) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION NORB(*),MUL(8,8) -C COUNT TWO-ELECTRON INTEGRALS - NINTGR=0 - DO 313 NSP=1,NSYM - NOP=NORB(NSP) - DO 312 NSQ=1,NSP - NSPQ=MUL(NSP,NSQ) - NOQ=NORB(NSQ) - DO 311 NSR=1,NSP - NSPQR=MUL(NSPQ,NSR) - NOR=NORB(NSR) - NSSM=NSR - IF(NSR.EQ.NSP)NSSM=NSQ - DO 310 NSS=1,NSSM - IF(NSS.NE.NSPQR)GO TO 310 - NOS=NORB(NSS) - NORBP=NOP*NOQ*NOR*NOS - IF(NORBP.EQ.0)GO TO 310 - DO 309 NV=1,NOR - NXM=NOS - IF(NSR.EQ.NSS)NXM=NV - DO 308 NX=1,NXM - NTM=1 - IF(NSP.EQ.NSR)NTM=NV - DO 307 NT=NTM,NOP - NUMIN=1 - IF(NSP.EQ.NSR.AND.NT.EQ.NV)NUMIN=NX - NUMAX=NOQ - IF(NSP.EQ.NSQ)NUMAX=NT - DO 306 NU=NUMIN,NUMAX - NINTGR=NINTGR+1 -306 CONTINUE -307 CONTINUE -308 CONTINUE -309 CONTINUE -310 CONTINUE -311 CONTINUE -312 CONTINUE -313 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/cpfctl.f openmolcas-22.10/src/cpf/cpfctl.f --- openmolcas-22.02/src/cpf/cpfctl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/cpfctl.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,116 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE CPFCTL(H) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION H(*) - -#include "SysDef.fh" - -#include "cpfmcpf.fh" -C - CALL CPFCTL_INTERNAL(H) -* -* This is to allow type punning without an explicit interface - CONTAINS - SUBROUTINE CPFCTL_INTERNAL(H) - USE ISO_C_BINDING - REAL*8, TARGET :: H(*) - INTEGER, POINTER :: iH1(:),iH2(:),iH3(:) - CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL C_F_POINTER(C_LOC(H(LW(3))),iH3,[1]) - CALL EPSBIS(iH2,iH3,H(LW(26)),H(LW(28)),H(LW(75))) - NULLIFY(iH2,iH3) - CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL C_F_POINTER(C_LOC(H(LW(3))),iH3,[1]) - CALL EPSPRIM(iH2,iH3,H(LW(26)),H(LW(27)),H(LW(32))) - NULLIFY(iH2,iH3) - IP=IRC(4) - CALL VECSUM_CPFMCPF(H(LW(32)),ENER,IP) - ETOTT=ENER+POTNUC - DELE=ETOTT-ETOT - ETOT=ETOTT - IF(ITER.EQ.1) THEN - WRITE(6,'(1X,A)')' ITER TOTAL ENERGY' - & //' CORR ENERGY DECREASE' - CALL XFLUSH(6) - END IF - WRITE(6,'(1X,I3,3(5X,F16.8))')ITER,ETOT,ENER,DELE - CALL XFLUSH(6) - IF(ABS(DELE).LT.ETHRE.AND.ITPUL.NE.1)ICONV=1 - IF(ICONV.EQ.0.AND.ITER.NE.MAXIT)GO TO 20 -C If more iterations should be done, goto 20. - - IF(ICONV.EQ.1)WRITE(6,37) -37 FORMAT(/,5X,'CALCULATION CONVERGED') - IF(ICONV.EQ.0)WRITE(6,38) -38 FORMAT(/,5X,'CALCULATION NOT COMPLETELY CONVERGED') - IF(ISDCI.EQ.1) WRITE(6,30)ETOT -30 FORMAT(/,5X,'FINAL CI ENERGY',6X,F17.8) - IF(ICPF.EQ.1)WRITE(6,35)ETOT -35 FORMAT(/,5X,'FINAL CPF ENERGY',5X,F17.8) - IF(INCPF.EQ.1)WRITE(6,39)ETOT -39 FORMAT(/,5X,'FINAL ACPF ENERGY',4X,F17.8) - IF(ISDCI.EQ.0.AND.ICPF.EQ.0.AND.INCPF.EQ.0)WRITE(6,36)ETOT -36 FORMAT(/,5X,'FINAL MCPF ENERGY',5X,F17.8) - WRITE(6,31)ENER,POTNUC - CALL XFLUSH(6) -31 FORMAT(5X,'FINAL CORRELATION ENERGY',F14.8,' REFERENCE ENERGY', - *F17.8) - If (ISDCI.EQ.1) Call Add_Info('E_SDCI',[ETOT],1,8) - If (ICPF.EQ.1) Call Add_Info('E_CPF',[ETOT],1,8) - If (INCPF.EQ.1) Call Add_Info('E_ACPF',[ETOT],1,8) - If (ISDCI.EQ.0.AND.ICPF.EQ.0.AND.INCPF.EQ.0) - & Call Add_Info('E_MCPF',[ETOT],1,8) - CALL XFLUSH(6) - IF(ISDCI.EQ.0)GO TO 21 - EENP=H(LW(31)+IRC(4)-1) - C0=D1/SQRT(EENP) - DECORR=ENER*(EENP-D1) - DETOT=ETOT+DECORR - WRITE(6,32)DETOT -32 FORMAT(5X,'DAVIDSON CORR. ENERGY',F17.8) - WRITE(6,33)DECORR,C0 -33 FORMAT(5X,'DAVIDSON CORRECTION',F19.8,' C0 = ',F12.6) - CALL XFLUSH(6) - -21 CONTINUE - IF(IPRINT.GT.5) THEN - ISTA=LW(31) - IEND=ISTA+IRC(4)-1 - IF(IPRINT.GT.5)WRITE(6,34)(H(I),I=ISTA,IEND) -34 FORMAT(/,(5X,'ENP',5F10.6)) - END IF - - RETURN - -20 CONTINUE -C Here if ICONV.EQ.0 and ITER.NE.MAXIT (More iterations to do). - IDIIS=0 - IF(ITPUL.EQ.MAXITP)IDIIS=1 - CALL C_F_POINTER(C_LOC(H(LW(1))),iH1,[1]) - CALL APPRIM(H(LW(32)),H(LW(75)),H(LW(30)),H(LW(76)),H(LW(31)), - & H(LW(79)),H(LW(80)),iH1) - NULLIFY(iH1) - CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL C_F_POINTER(C_LOC(H(LW(3))),iH3,[1]) - CALL CUPDATE(iH2,iH3,H(LW(26)),H(LW(27)), - & H(LW(76)),H(LW(33)),H(LW(80)),H(LW(31))) - NULLIFY(iH2,iH3) - ITP=ITPUL+1 - CALL DIIS_CPF(H(LW(26)),H(LW(27)),H(LW(33)), - & MAXIT,H(LW(77)),ITP,H(LW(78))) - RETURN - END SUBROUTINE CPFCTL_INTERNAL -* - END diff -Nru openmolcas-22.02/src/cpf/cpfctl.F90 openmolcas-22.10/src/cpf/cpfctl.F90 --- openmolcas-22.02/src/cpf/cpfctl.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/cpfctl.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,91 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine CPFCTL(C,S,W,TPQ,ENP,EPP,BST,EPB,AP,BIJ,CN,TEMP) + +use cpf_global, only: DETOT, ETHRE, ETOT, ICASE, ICONV, ICPF, IDIIS, INCPF, INDX, IPRINT, IRC, ISDCI, ITER, ITPUL, JSY, MAXIT, & + MAXITP, NTMAX, POTNUC +use Constants, only: One +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +real(kind=wp), intent(inout) :: C(*), S(*), EPP(*), BST((MAXIT+1)**2) +real(kind=wp), intent(in) :: W(*), ENP(*) +real(kind=wp), intent(_OUT_) :: TPQ(*), EPB(*), AP(*) +real(kind=wp), intent(out) :: BIJ((MAXIT+1)**2), CN(MAXIT+1), TEMP(NTMAX) +integer(kind=iwp) :: I, IP, ITP +real(kind=wp) :: C0, DECORR, DELE, EENP, ENER, ETOTT + +call EPSBIS(JSY,INDX,C,W,EPB) +call EPSPRIM(JSY,INDX,C,S,EPP) +IP = IRC(4) +call VECSUM_CPFMCPF(EPP,ENER,IP) +ETOTT = ENER+POTNUC +DELE = ETOTT-ETOT +ETOT = ETOTT +if (ITER == 1) then + write(u6,'(1X,A)') ' ITER TOTAL ENERGY CORR ENERGY DECREASE' +end if +write(u6,'(1X,I3,3(5X,F16.8))') ITER,ETOT,ENER,DELE +if ((abs(DELE) < ETHRE) .and. (ITPUL /= 1)) ICONV = 1 +if ((ICONV == 0) .and. (ITER /= MAXIT)) then + ! If more iterations should be done. + IDIIS = 0 + if (ITPUL == MAXITP) IDIIS = 1 + call APPRIM(EPP,EPB,TPQ,AP,ENP,TEMP,ICASE) + call CUPDATE(JSY,INDX,C,S,AP,BST,ENP) + ITP = ITPUL+1 + call DIIS_CPF(C,S,BST,MAXIT,BIJ,ITP,CN) +else + if (ICONV == 1) write(u6,37) + if (ICONV == 0) write(u6,38) + if (ISDCI == 1) write(u6,30) ETOT + if (ICPF == 1) write(u6,35) ETOT + if (INCPF == 1) write(u6,39) ETOT + if ((ISDCI == 0) .and. (ICPF == 0) .and. (INCPF == 0)) write(u6,36) ETOT + write(u6,31) ENER,POTNUC + if (ISDCI == 1) call Add_Info('E_SDCI',[ETOT],1,8) + if (ICPF == 1) call Add_Info('E_CPF',[ETOT],1,8) + if (INCPF == 1) call Add_Info('E_ACPF',[ETOT],1,8) + if ((ISDCI == 0) .and. (ICPF == 0) .and. (INCPF == 0)) call Add_Info('E_MCPF',[ETOT],1,8) + if (ISDCI /= 0) then + EENP = ENP(IRC(4)) + C0 = One/sqrt(EENP) + DECORR = ENER*(EENP-One) + DETOT = ETOT+DECORR + write(u6,32) DETOT + write(u6,33) DECORR,C0 + end if + + if (IPRINT > 5) then + if (IPRINT > 5) write(u6,34) (ENP(I),I=1,IRC(4)) + end if +end if + +return + +30 format(/,5X,'FINAL CI ENERGY',6X,F17.8) +31 format(5X,'FINAL CORRELATION ENERGY',F14.8,' REFERENCE ENERGY',F17.8) +32 format(5X,'DAVIDSON CORR. ENERGY',F17.8) +33 format(5X,'DAVIDSON CORRECTION',F19.8,' C0 = ',F12.6) +34 format(/,(5X,'ENP',5F10.6)) +35 format(/,5X,'FINAL CPF ENERGY',5X,F17.8) +36 format(/,5X,'FINAL MCPF ENERGY',5X,F17.8) +37 format(/,5X,'CALCULATION CONVERGED') +38 format(/,5X,'CALCULATION NOT COMPLETELY CONVERGED') +39 format(/,5X,'FINAL ACPF ENERGY',4X,F17.8) + +end subroutine CPFCTL diff -Nru openmolcas-22.02/src/cpf/cpf.f openmolcas-22.10/src/cpf/cpf.f --- openmolcas-22.02/src/cpf/cpf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/cpf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,122 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ -************************************************************************ -* * -* PER SIEGBAHN * -* MARGARETA BLOMBERG * -* DEPARTMENT OF THEORETICAL CHEMISTRY * -* UNIVERSITY OF LUND * -* SWEDEN * -* * -************************************************************************ - SUBROUTINE CPF(IRETURN) -************************************************************************ -* * -* C P F * -* MODIFIED TO IBM BY ROLAND LINDH 02/17/88 * -* MODIFIED TO MOLCAS-2 BY ROLAND LINDH 03/26/91 * -* MODIFIED TO MOLCAS-3 BY M.P. FUELSCHER 08/31/93 * -* MODIFIED TO MOLCAS-4 BY P.A. MALMQVIST AND N.W.MORTIARTY 10/25/96 * -* MODIFIED TO MOLCAS 4.1 BY R. LINDH 02/24/98 (Multi fileing) * -************************************************************************ -C -C UNITS USED IN THE PROGRAM -C UNIT 5 , INPUT -C UNIT 6 , OUTPUT -C UNIT 10 , SYMBOLIC FORMULAS -C UNIT 50 , TRANSFORMED MO 2-EL INTEGRALS -C UNIT 60 , SORTED AIBJ, ABIJ AND AIJK INTEGRALS -C UNIT 70 , SORTED IJKL AND ABCI INTEGRALS -C UNIT 80 , SORTED ABCD INTEGRALS -C UNIT 17 , ONE ELECTRON INTEGRALS -C UNIT 19 , (Formatted sequential!) CPF-ORBITALS OUT -C UNIT 25 , FOCK MATRIX AND DIAGONAL CSF MATRIX ELEMENTS -C UNIT 26 , CI VECTOR -C UNIT 27 , SCRATCH IN IIJJ -C UNIT 30 , -C - IMPLICIT REAL*8 (A-H,O-Z) -* -#include "files_cpf.fh" -#include "WrkSpc.fh" -* -* Prologue -* -* CALL SETTIM -C CALL HELLO -* -* (Workspace allocated in Start() ) -* - Call GetMem('WrkSpc','Max ','Real',MemOff,MEMORY) - MEMORY=INT(MEMORY*0.80D0) - Call GetMem('WrkSpc','Allo','Real',MemOff,MEMORY) -* -* Open files -* - Lu_CIGuga=10 - CALL DANAME(Lu_CIGuga,'CIGUGA') - Lu_TraInt=50 - CALL DANAME_MF(Lu_TraInt,'TRAINT') - Lu_TraOne=17 - CALL DANAME(Lu_TraOne,'TRAONE') - Lu_CI=26 - CALL DANAME(Lu_CI,'CPFVECT') - Lu_CPFORB=19 -C Temporaries: - Lu_TiABIJ=60 - CALL DANAME_MF(Lu_TiABIJ,'TIABIJ') - Lu_TiABCI=70 - CALL DANAME_MF(Lu_TiABCI,'TIABCI') - Lu_TiABCD=80 - CALL DANAME_MF(Lu_TiABCD,'TIABCD') - Lu_25=25 - CALL DANAME(Lu_25,'FT25F001') - Lu_27=27 - CALL DANAME(Lu_27,'FT27F001') - Lu_30=30 - CALL DANAME(Lu_30 ,'FT30F001') -* -* Body -* - iMemOff=ip_of_iWork_d(Work(MemOff)) - CALL SDCI_CPF(Work(MemOff),iWork(iMemOff),MEMORY) -* -* Deallocate the workspace -* - Call GetMem('WrkSpc','Free','Real',MemOff,MEMORY) -* -* Epilogue, end -* -* * -************************************************************************ -* * -* Close open dafiles -* - CALL DACLOS(Lu_CIGuga) - CALL DACLOS(Lu_TraInt) - CALL DACLOS(Lu_TraOne) - CALL DACLOS(Lu_CI) - CALL DACLOS(Lu_TiABIJ) - CALL DACLOS(Lu_TiABCI) - CALL DACLOS(Lu_TiABCD) - CALL DACLOS(Lu_25) - CALL DACLOS(Lu_27) - CALL DACLOS(Lu_30) -* * -************************************************************************ -* * - CALL FASTIO('STATUS') - IRETURN=0 - RETURN - END diff -Nru openmolcas-22.02/src/cpf/cpf.F90 openmolcas-22.10/src/cpf/cpf.F90 --- openmolcas-22.02/src/cpf/cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,107 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine CPF(IRETURN) +!*********************************************************************** +! * +! PER SIEGBAHN * +! MARGARETA BLOMBERG * +! DEPARTMENT OF THEORETICAL CHEMISTRY * +! UNIVERSITY OF LUND * +! SWEDEN * +! * +!*********************************************************************** +!*********************************************************************** +! * +! C P F * +! MODIFIED TO IBM BY ROLAND LINDH 02/17/88 * +! MODIFIED TO MOLCAS-2 BY ROLAND LINDH 03/26/91 * +! MODIFIED TO MOLCAS-3 BY M.P. FUELSCHER 08/31/93 * +! MODIFIED TO MOLCAS-4 BY P.A. MALMQVIST AND N.W. MORTIARTY 10/25/96 * +! MODIFIED TO MOLCAS 4.1 BY R. LINDH 02/24/98 (Multi fileing) * +! MODIFIED TO MODERN FORTRAN BY I. FDEZ. GALVAN 2022 * +!*********************************************************************** + +use cpf_global, only: ICASE, INDX, ISAB, JSY, Lu_25, Lu_27, Lu_30, Lu_CI, Lu_CIGuga, Lu_CPFORB, Lu_TiABCD, Lu_TiABCI, Lu_TiABIJ, & + Lu_TraInt, Lu_TraOne +use stdalloc, only: mma_deallocate +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(out) :: IRETURN +integer(kind=iwp) :: MEMORY + +call mma_maxdble(MEMORY) +MEMORY = int(MEMORY*0.8_wp) + +! Open files + +Lu_CIGuga = 10 +call DANAME(Lu_CIGuga,'CIGUGA') +Lu_TraInt = 50 +call DANAME_MF(Lu_TraInt,'TRAINT') +Lu_TraOne = 17 +call DANAME(Lu_TraOne,'TRAONE') +Lu_CI = 26 +call DANAME(Lu_CI,'CPFVECT') +Lu_CPFORB = 19 +! Temporaries: +Lu_TiABIJ = 60 +call DANAME_MF(Lu_TiABIJ,'TIABIJ') +Lu_TiABCI = 70 +call DANAME_MF(Lu_TiABCI,'TIABCI') +Lu_TiABCD = 80 +call DANAME_MF(Lu_TiABCD,'TIABCD') +Lu_25 = 25 +call DANAME(Lu_25,'FT25F001') +Lu_27 = 27 +call DANAME(Lu_27,'FT27F001') +Lu_30 = 30 +call DANAME(Lu_30,'FT30F001') + +! Body + +call SDCI_CPF(MEMORY) + +! Deallocate the workspace + +call mma_deallocate(ICASE) +call mma_deallocate(JSY) +call mma_deallocate(INDX) +call mma_deallocate(ISAB) + +! * +!*********************************************************************** +! * +! Close open dafiles + +call DACLOS(Lu_CIGuga) +call DACLOS(Lu_TraInt) +call DACLOS(Lu_TraOne) +call DACLOS(Lu_CI) +call DACLOS(Lu_TiABIJ) +call DACLOS(Lu_TiABCI) +call DACLOS(Lu_TiABCD) +call DACLOS(Lu_25) +call DACLOS(Lu_27) +call DACLOS(Lu_30) +! * +!*********************************************************************** +! * +call FASTIO('STATUS') +IRETURN = 0 + +return + +end subroutine CPF diff -Nru openmolcas-22.02/src/cpf/cpf_global.F90 openmolcas-22.10/src/cpf/cpf_global.F90 --- openmolcas-22.02/src/cpf/cpf_global.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/cpf_global.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,55 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +module cpf_global + +use Constants, only: Two +use Definitions, only: wp, iwp + +implicit none +private + +! Lu_CIGuga - SYMBOLIC FORMULAS +! Lu_TraInt - TRANSFORMED MO 2-EL INTEGRALS +! Lu_TiABIJ - SORTED AIBJ, ABIJ AND AIJK INTEGRALS +! Lu_TiABCI - SORTED IJKL AND ABCI INTEGRALS +! Lu_TiABCD - SORTED ABCD INTEGRALS +! Lu_TraOne - ONE ELECTRON INTEGRALS +! Lu_CPFORB - (Formatted sequential!) CPF-ORBITALS OUT +! Lu_25 - FOCK MATRIX AND DIAGONAL CSF MATRIX ELEMENTS +! Lu_CI - CI VECTOR +! Lu_27 - SCRATCH IN IIJJ +! Lu_30 + +#include "Molcas.fh" +#include "tratoc.fh" + +integer(kind=iwp), parameter :: KBUFF1 = 2*9600, MADR = 20000, NTIBUF = nTraBuf +real(kind=wp), parameter :: SQ2 = sqrt(Two) +integer(kind=iwp) :: IAD25S, IADABCI, IADDP(79), ICH(MXORB), ICONV, ICPF, IDENS, IDIIS, IFIRST, ILIM, INCPF, IPASS, IPRINT, & + IPS(200), IR1, IRC(4), IREF0, IREST, IROW(MXORB+1), ISC(4), ISDCI, ISMAX, ITER, ITOC17(64), ITPUL, IV0, IV1, & + JBUF, JJS(18), JMAX, JSC(4), KBUF, LASTAD(MADR), LBUF, LIC, LN, LSYM, Lu_25, Lu_27, Lu_30, Lu_CI, Lu_CIGuga, & + Lu_CPFORB, Lu_TiABCD, Lu_TiABCI, Lu_TiABIJ, Lu_TraInt, Lu_TraOne, MAX11, MAXIT, MAXITP, MX1, MX2, N, NASH(8), & + NBAS(8), NCONF, NDIAG(MXORB), NFRO(8), NISH(8), NNS(8), NORB(8), NORBT, NOV, NOV1, NPFRO(8), NREF, & + NSM(MXORB), NSYM, NSYS(9), NTMAX, NVIR(8), NVIRT, NVMAX, NVT5 +real(kind=wp) :: CTRSH, DETOT, ETHRE, ETOT, POTNUC, WLEV +logical(kind=iwp) :: LWSP +character(len=LenIn8) :: BNAME(MXBAS) +integer(kind=iwp), allocatable :: INDX(:), ISAB(:), JSY(:), ICASE(:) + +public :: BNAME, CTRSH, DETOT, ETHRE, ETOT, IAD25S, IADABCI, IADDP, ICASE, ICH, ICONV, ICPF, IDENS, IDIIS, IFIRST, ILIM, INCPF, & + INDX, IPASS, IPRINT, IPS, IR1, IRC, IREF0, IREST, IROW, ISAB, ISC, ISDCI, ISMAX, ITER, ITOC17, ITPUL, IV0, IV1, JBUF, & + JJS, JMAX, JSC, JSY, KBUF, KBUFF1, LASTAD, LBUF, LIC, LN, LSYM, Lu_25, Lu_27, Lu_30, Lu_CI, Lu_CIGuga, Lu_CPFORB, & + Lu_TiABCD, Lu_TiABCI, Lu_TiABIJ, Lu_TraInt, Lu_TraOne, LWSP, MADR, MAX11, MAXIT, MAXITP, MX1, MX2, N, NASH, NBAS, NCONF, & + NDIAG, NFRO, NISH, NNS, NORB, NORBT, NOV, NOV1, NPFRO, NREF, NSM, NSYM, NSYS, NTIBUF, NTMAX, NVIR, NVIRT, NVMAX, NVT5, & + POTNUC, SQ2, WLEV + +end module CPF_global diff -Nru openmolcas-22.02/src/cpf/cpfmcpf.fh openmolcas-22.10/src/cpf/cpfmcpf.fh --- openmolcas-22.02/src/cpf/cpfmcpf.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/cpfmcpf.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,43 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ -C COMMON INFORMATION FOR MCPF PROGRAM -#include "Molcas.fh" - - COMMON/REAL_CPF/POTNUC,EMY,ETHRE,CTRSH,ETOT,WLEV,DETOT - - COMMON/MISC_CPF/ N,LN,NDIAG(MXORB),LSYM,LIC,KBUF,JJS(18),LW(99), - & NNS(8),IDENS,IREST,NCONF,ICH(MXORB), - & JBUF,IROW(MXORB+1),NSYM,MUL(8,8), - & IPASS,NSM(MXORB),IPRINT,IFIRST,IRC(4), - & ISC(4),JSC(4),LBUF,ITER,IV0,IV1,IV2,IV3, - & NSYS(9),MAXIT,NFREF,ICPF,ISDCI,ITPUL, - & ICONV,IREF0,IDIIS,MAXITP,KBUFF1,INCPF,NREF - COMMON/ORB/ NPFRO(8),NFRO(8),NISH(8),NASH(8),NVAL(8),NVIR(8), - & NDEL(8),NPDEL(8),NORB(8),NBAS(8), - & NPFROT,NFROT,NISHT,NASHT,NVALT,NVIRT,NDELT, - & NPDELT,NORBT,NBAST - CHARACTER*(LENIN8) NAME(MXBAS) - COMMON /CHARAC_CPF/ NAME - - COMMON/DATA_CPF/D0,D1,D2,SQ2 -C - Parameter(mAdr=20 000) - COMMON/RA_CPF/LASTAD(mAdr) -C -C Buffer for reading transformed integrals: -#include "tratoc.fh" - PARAMETER(NTIBUF=nTraBuf) -C GUGA file -#include "cop.fh" - COMMON/ADDR_CPF/IAD25S,IADDP(79),IADC(79),IADABCI,ITOC17(64) diff -Nru openmolcas-22.02/src/cpf/cupdate.f openmolcas-22.10/src/cpf/cupdate.f --- openmolcas-22.02/src/cpf/cupdate.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/cupdate.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,119 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE CUPDATE(JSY,INDEX,C,S,AP,BST,T2,ENP) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION JSY(*),INDEX(*),C(*),S(*),AP(*),BST(*), - * T2(*),ENP(*) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" -* - JSYM(L)=JSUNP_CPF(JSY,L) -C - - W=WLEV - -C VALENCE - IP=IRC(1) - DO 6 I=1,IP - C(I)=AP(I)*C(I)-S(I) -6 CONTINUE - -C SINGLES - IP=IRC(2)-IRC(1) - IN=IRC(1) - DO 5 I=1,IP - NS1=JSYM(IN+I) - NSIL=MUL(NS1,LSYM) - INUM=NVIR(NSIL) - IST=INDEX(IN+I)+1 - CALL VSMSB(C(IST),1,AP(IN+I),S(IST),1,C(IST),1,INUM) -5 CONTINUE - -C DOUBLES - IP=IRC(4)-IRC(2) - IN=IRC(2) - DO 10 I=1,IP - NS1=JSYM(IN+I) - NSIL=MUL(NS1,LSYM) - INUM=NNS(NSIL) - IST=INDEX(IN+I)+1 - CALL VSMSB(C(IST),1,AP(IN+I),S(IST),1,C(IST),1,INUM) -10 CONTINUE - -C WRITE GRADIENT ONTO DISK, UNIT=30 - IAD=IADDP(ITPUL) - CALL dDAFILE(Lu_30,1,C,NCONF,IAD) - -C Reuse array S for HCOUT that was written in IJIJ. - IAD=IAD25S - DO 77 III=1,NCONF,nCOP - JJJ=MIN(nCOP,NCONF+1-III) - CALL dDAFILE(Lu_25,2,S(III),JJJ,IAD) -77 CONTINUE - -C VALENCE - IP=IRC(1) - DO 7 I=1,IP - APW=W-AP(I) - T2(I)=S(I)+APW - C(I)=C(I)/T2(I) - EMP=SQRT(ENP(I)) - C(I)=C(I)*EMP - IF(I.EQ.IREF0)C(I)=0.0D0 -7 CONTINUE - -C SINGLES - IP=IRC(2)-IRC(1) - IN=IRC(1) - DO 8 I=1,IP - NS1=JSYM(IN+I) - NSIL=MUL(NS1,LSYM) - INUM=NVIR(NSIL) - IST=INDEX(IN+I)+1 - APW=W-AP(IN+I) - CALL VSADD(S(IST),1,APW,T2,1,INUM) - CALL VDIV(T2,1,C(IST),1,C(IST),1,INUM) - EMP=SQRT(ENP(IN+I)) - CALL VSMUL(C(IST),1,EMP,C(IST),1,INUM) -8 CONTINUE - -C DOUBLES - IP=IRC(4)-IRC(2) - IN=IRC(2) - DO 11 I=1,IP - NS1=JSYM(IN+I) - NSIL=MUL(NS1,LSYM) - INUM=NNS(NSIL) - IST=INDEX(IN+I)+1 - APW=W-AP(IN+I) - CALL VSADD(S(IST),1,APW,T2,1,INUM) - CALL VDIV(T2,1,C(IST),1,C(IST),1,INUM) - EMP=SQRT(ENP(IN+I)) - CALL VSMUL(C(IST),1,EMP,C(IST),1,INUM) -11 CONTINUE -C - IAD=IADDP(ITPUL+1) - CALL dDAFILE(Lu_CI,1,C,NCONF,IAD) - IADDP(ITPUL+2)=IAD - IF(IPRINT.GE.15)WRITE(6,999)(C(I),I=1,NCONF) -999 FORMAT(6X,'C(UPD)',5F10.6) - A=DDOT_(NCONF,C,1,C,1) - IF(A.GT.D2) THEN - WRITE(6,*)'CUPDATE Error: A>2.0D0 (See code.)' - CALL Abend - END IF - IF(ITPUL.EQ.1)BST(1)=A - RETURN - END diff -Nru openmolcas-22.02/src/cpf/cupdate.F90 openmolcas-22.10/src/cpf/cupdate.F90 --- openmolcas-22.02/src/cpf/cupdate.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/cupdate.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,128 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine CUPDATE(JSY,INDX,C,S,AP,BST,ENP) + +use cpf_global, only: IAD25S, IADDP, IPRINT, IRC, IREF0, ITPUL, LSYM, Lu_25, Lu_30, Lu_CI, NCONF, NNS, NVIR, WLEV +use guga_util_global, only: nCOP +use Symmetry_Info, only: Mul +use Constants, only: Zero, Two +use Definitions, only: wp, iwp, u6, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: JSY(*), INDX(*) +real(kind=wp), intent(inout) :: C(*), S(*), BST(*) +real(kind=wp), intent(in) :: AP(*), ENP(*) +integer(kind=iwp) :: I, IAD, III, IIN, INUM, IP, IST, JJJ, NS1, NSIL +real(kind=wp) :: A, APW, EMP, W +integer(kind=iwp), external :: JSUNP +real(kind=r8), external :: DDOT_ + +W = WLEV + +! VALENCE +IP = IRC(1) +do I=1,IP + C(I) = AP(I)*C(I)-S(I) +end do + +! SINGLES +IP = IRC(2)-IRC(1) +IIN = IRC(1) +do I=1,IP + NS1 = JSUNP(JSY,IIN+I) + NSIL = MUL(NS1,LSYM) + INUM = NVIR(NSIL) + IST = INDX(IIN+I)+1 + C(IST:IST+INUM-1) = C(IST:IST+INUM-1)*AP(IIN+I)-S(IST:IST+INUM-1) +end do + +! DOUBLES +IP = IRC(4)-IRC(2) +IIN = IRC(2) +do I=1,IP + NS1 = JSUNP(JSY,IIN+I) + NSIL = MUL(NS1,LSYM) + INUM = NNS(NSIL) + IST = INDX(IIN+I)+1 + C(IST:IST+INUM-1) = C(IST:IST+INUM-1)*AP(IIN+I)-S(IST:IST+INUM-1) +end do + +! WRITE GRADIENT ONTO DISK, UNIT=30 +IAD = IADDP(ITPUL) +call dDAFILE(Lu_30,1,C,NCONF,IAD) + +! Reuse array S for HCOUT that was written in IJIJ. +IAD = IAD25S +do III=1,NCONF,nCOP + JJJ = min(nCOP,NCONF+1-III) + call dDAFILE(Lu_25,2,S(III),JJJ,IAD) +end do + +! VALENCE +IP = IRC(1) +do I=1,IP + APW = W-AP(I) + C(I) = C(I)/(S(I)+APW) + EMP = sqrt(ENP(I)) + C(I) = C(I)*EMP + if (I == IREF0) C(I) = Zero +end do + +! SINGLES +IP = IRC(2)-IRC(1) +IIN = IRC(1) +do I=1,IP + NS1 = JSUNP(JSY,IIN+I) + NSIL = MUL(NS1,LSYM) + INUM = NVIR(NSIL) + IST = INDX(IIN+I)+1 + APW = W-AP(IIN+I) + C(IST:IST+INUM-1) = C(IST:IST+INUM-1)/(S(IST:IST+INUM-1)+APW) + EMP = sqrt(ENP(IIN+I)) + C(IST:IST+INUM-1) = EMP*C(IST:IST+INUM-1) +end do + +! DOUBLES +IP = IRC(4)-IRC(2) +IIN = IRC(2) +do I=1,IP + NS1 = JSUNP(JSY,IIN+I) + NSIL = MUL(NS1,LSYM) + INUM = NNS(NSIL) + IST = INDX(IIN+I)+1 + APW = W-AP(IIN+I) + C(IST:IST+INUM-1) = C(IST:IST+INUM-1)/(S(IST:IST+INUM-1)+APW) + EMP = sqrt(ENP(IIN+I)) + C(IST:IST+INUM-1) = EMP*C(IST:IST+INUM-1) +end do + +IAD = IADDP(ITPUL+1) +call dDAFILE(Lu_CI,1,C,NCONF,IAD) +IADDP(ITPUL+2) = IAD +if (IPRINT >= 15) write(u6,999) (C(I),I=1,NCONF) +A = DDOT_(NCONF,C,1,C,1) +if (A > Two) then + write(u6,*) 'CUPDATE Error: A>2.0 (See code.)' + call Abend() +end if +if (ITPUL == 1) BST(1) = A + +return + +999 format(6X,'C(UPD)',5F10.6) + +end subroutine CUPDATE diff -Nru openmolcas-22.02/src/cpf/decomp.f openmolcas-22.10/src/cpf/decomp.f --- openmolcas-22.02/src/cpf/decomp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/decomp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,83 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ -C -C - SUBROUTINE DECOMP(NN,A,UL) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(NN,NN),UL(NN,NN),SCALES(200) -#include "ips.fh" - N=NN - IDXPIV=0 ! dummy initialize -C**** INITIALIZE IPS, UL AND SCALES - DO 5 I=1,N - IPS(I)=I - ROWNRM=0.0D00 - DO 2 J=1,N - UL(I,J)=A(I,J) -c IF (ROWNRM-ABS(UL(I,J))) 1,2,2 - IF (ROWNRM-ABS(UL(I,J)).ge.0) goto 2 -c1 CONTINUE - ROWNRM=abs(UL(I,J)) -2 CONTINUE -c IF (ROWNRM) 3,4,3 - IF (ROWNRM.eq.0) goto 4 -c3 CONTINUE - SCALES(I)=1.0D00/ROWNRM - GO TO 5 -4 CALL SING(1) - SCALES(I)=0.0D00 -5 CONTINUE -C**** GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING - NM1=N-1 - DO 17 K=1,NM1 - BIG=0.0D00 - DO 11 I=K,N - IP=IPS(I) - SIZE=ABS(UL(IP,K))*SCALES(IP) -c IF (SIZE-BIG) 11,11,10 - IF (SIZE-BIG.le.0) goto 11 -c10 CONTINUE - BIG=SIZE - IDXPIV=I -11 CONTINUE -c IF (BIG) 13,12,13 - IF (BIG.ne.0) goto 13 -c12 CONTINUE - CALL SING(2) - GOTO 17 -c13 IF (IDXPIV-K) 14,15,14 -13 IF (IDXPIV.eq.K) goto 15 -c14 CONTINUE - J=IPS(K) - IPS(K)=IPS(IDXPIV) - IPS(IDXPIV)=J -15 KP=IPS(K) - PIVOT=UL(KP,K) - KP1=K+1 - DO 16 I=KP1,N - IP=IPS(I) - EM=-UL(IP,K)/PIVOT - UL(IP,K)=-EM - DO 160 J=KP1,N - UL(IP,J)=UL(IP,J)+EM*UL(KP,J) -160 CONTINUE -16 CONTINUE -17 CONTINUE - KP=IPS(N) -c IF (UL(KP,N)) 19,18,19 - IF (UL(KP,N).ne.0) goto 19 -c18 CONTINUE - CALL SING(2) -19 RETURN - END diff -Nru openmolcas-22.02/src/cpf/decomp.F90 openmolcas-22.10/src/cpf/decomp.F90 --- openmolcas-22.02/src/cpf/decomp.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/decomp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,81 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine DECOMP(NN,A) + +use cpf_global, only: IPS +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: NN +real(kind=wp), intent(inout) :: A(NN,NN) +integer(kind=iwp) :: I, IDXPIV, IP, J, K, KP, KP1, N, NM1 +real(kind=wp) :: BIG, EM, PIVOT, ROWNRM, SCALES(200), RSIZE + +N = NN +IDXPIV = 0 ! dummy initialize +! INITIALIZE IPS AND SCALES +do I=1,N + IPS(I) = I + ROWNRM = Zero + do J=1,N + if (ROWNRM < abs(A(I,J))) ROWNRM = abs(A(I,J)) + end do + if (ROWNRM == Zero) then + call SING(1) + SCALES(I) = Zero + else + SCALES(I) = One/ROWNRM + end if +end do +! GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING +NM1 = N-1 +do K=1,NM1 + BIG = Zero + do I=K,N + IP = IPS(I) + RSIZE = abs(A(IP,K))*SCALES(IP) + if (RSIZE > BIG) then + BIG = RSIZE + IDXPIV = I + end if + end do + if (BIG == 0) then + call SING(2) + else + if (IDXPIV /= K) then + J = IPS(K) + IPS(K) = IPS(IDXPIV) + IPS(IDXPIV) = J + end if + KP = IPS(K) + PIVOT = A(KP,K) + KP1 = K+1 + do I=KP1,N + IP = IPS(I) + EM = -A(IP,K)/PIVOT + A(IP,K) = -EM + do J=KP1,N + A(IP,J) = A(IP,J)+EM*A(KP,J) + end do + end do + end if +end do +KP = IPS(N) +if (A(KP,N) == 0) call SING(2) + +return + +end subroutine DECOMP diff -Nru openmolcas-22.02/src/cpf/dens_cpf.F90 openmolcas-22.10/src/cpf/dens_cpf.F90 --- openmolcas-22.02/src/cpf/dens_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/dens_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,52 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine DENS_CPF(C,D,ICASE,AA) + +use cpf_global, only: IREF0, LN, NCONF, NORBT +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6, r8 + +#include "intent.fh" + +implicit none +real(kind=wp), intent(inout) :: C(*) +real(kind=wp), intent(_OUT_) :: D(*) +integer(kind=iwp), intent(in) :: ICASE(*) +real(kind=wp), intent(out) :: AA +integer(kind=iwp) :: I, II, II1, ILIM, JOJ +real(kind=wp) :: EMA +integer(kind=iwp), external :: ICUNP +real(kind=r8), external :: DDOT_ + +ILIM = NORBT*(NORBT+1)/2 +D(1:ILIM) = Zero +C(IREF0) = Zero +AA = DDOT_(NCONF,C,1,C,1) +write(u6,20) AA +C(IREF0) = One +EMA = One-AA +II1 = (IREF0-1)*LN +do I=1,LN + JOJ = ICUNP(ICASE,II1+I) + if (JOJ >= 2) JOJ = JOJ-1 + II = I*(I+1)/2 + D(II) = JOJ*EMA +end do + +return + +20 format(5X,'SUM OF SQUARED CPX(BAR)',F10.4) + +end subroutine DENS_CPF diff -Nru openmolcas-22.02/src/cpf/densct_cpf.F90 openmolcas-22.10/src/cpf/densct_cpf.F90 --- openmolcas-22.02/src/cpf/densct_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/densct_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,44 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine DENSCT_CPF(C,S,W,THET,TPQ,ENP,EPP,ICASE_,FC,BUFIN,A,B,FK,DBK,TEMP) + +use cpf_global, only: ICASE, INDX, JSY +use Constants, only: One +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +real(kind=wp), intent(inout) :: C(*), ENP(*), FK(*) +real(kind=wp), intent(_OUT_) :: S(*), W(*), TPQ(*), EPP(*), FC(*), BUFIN(*), A(*), B(*), DBK(*), TEMP(*) +real(kind=wp), intent(in) :: THET(*) +integer(kind=iwp), intent(in) :: ICASE_(*) +real(kind=wp) :: AA + +call DENS_CPF(C,FC,ICASE,AA) + +! MULTIPLY C BY MP + +call NPSET(JSY,INDX,C,TPQ,ENP,TEMP,S,W,EPP,ICASE_) + +call ONECT(C,S,W,THET,ENP,EPP,FC,BUFIN,A,B,FK,DBK) +if (AA > One) then + write(u6,*) 'DENSCT_CPF Error: AA>1.0 (See code.)' +end if +call NATCT(C,FC) + +return + +end subroutine DENSCT_CPF diff -Nru openmolcas-22.02/src/cpf/densct.f openmolcas-22.10/src/cpf/densct.f --- openmolcas-22.02/src/cpf/densct.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/densct.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,51 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE DENSCT_CPF(H,LIC0) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION H(LIC0) - -#include "SysDef.fh" - -#include "cpfmcpf.fh" - CALL DENSCT_INTERNAL(H) -* -* This is to allow type punning without an explicit interface - CONTAINS - SUBROUTINE DENSCT_INTERNAL(H) - USE ISO_C_BINDING - REAL*8, TARGET :: H(*) - INTEGER, POINTER :: iH1(:),iH2(:),iH3(:),iH34(:) -C - CALL C_F_POINTER(C_LOC(H(LW(1))),iH1,[1]) - CALL DENS_CPF(H(LW(26)),H(LW(62)),iH1,A) - NULLIFY(iH1) -C -C MULTIPLY C BY MP -C - CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL C_F_POINTER(C_LOC(H(LW(3))),iH3,[1]) - CALL C_F_POINTER(C_LOC(H(LW(34))),iH34,[1]) - CALL NPSET(iH2,iH3,H(LW(26)),H(LW(30)),H(LW(31)), - *H(LW(72)),H(LW(27)),H(LW(28)),H(LW(32)),iH34) - NULLIFY(iH2,iH3,iH34) -* - CALL ONECT(H) - IF(A.GT.D1) THEN - WRITE(6,*)'DENSCT_CPF Error: A>1.0D0 (See code.)' - END IF - CALL NATCT(H,LIC0) -* - RETURN - END SUBROUTINE DENSCT_INTERNAL - END diff -Nru openmolcas-22.02/src/cpf/dens.f openmolcas-22.10/src/cpf/dens.f --- openmolcas-22.02/src/cpf/dens.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/dens.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,46 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE DENS_CPF(C,D,ICASE,A) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION C(*),D(*) - DIMENSION ICASE(*) - -#include "SysDef.fh" - -#include "cpfmcpf.fh" -CPAM97 EXTERNAL UNPACK -CPAM97 INTEGER UNPACK -CRL JO(L)=IAND(ISHFT(QOCC((L+29)/30),-2*((L+29)/30*30-L)),3) -CPAM97 JO(L)=UNPACK(QOCC((L+29)/30), 2*L-(2*L-1)/60*60, 2) - JO(L)=ICUNP(ICASE,L) -C - ILIM=NORBT*(NORBT+1)/2 - CALL SETZ(D,ILIM) - C(IREF0)=D0 -CRL CALL DOTPR(C,1,C,1,A,NCONF) - A=DDOT_(NCONF,C,1,C,1) - WRITE(6,20)A - CALL XFLUSH(6) -20 FORMAT(5X,'SUM OF SQUARED CPX(BAR)',F10.4) - C(IREF0)=D1 - EMA=D1-A - II1=(IREF0-1)*LN - DO 5 I=1,LN - JOJ=JO(II1+I) - IF(JOJ.GE.2)JOJ=JOJ-1 - II=I*(I+1)/2 - D(II)=JOJ*EMA -5 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/diagc_cpf.F90 openmolcas-22.10/src/cpf/diagc_cpf.F90 --- openmolcas-22.02/src/cpf/diagc_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/diagc_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,77 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine DIAGC_CPF(JSY,C,S) + +use cpf_global, only: IAD25S, ILIM, IRC, LN, LSYM, Lu_25, NSM, NSYS, NVIRT +use guga_util_global, only: COP, nCOP +use Symmetry_Info, only: Mul +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: JSY(*) +real(kind=wp), intent(in) :: C(*) +real(kind=wp), intent(inout) :: S(*) +integer(kind=iwp) :: IADD25, IIC, IND, INDA, IRL, NA, NA1, NA2, NB, NB1, NB2, NSA, NSS +integer(kind=iwp), external :: JSUNP + +IADD25 = IAD25S +call dDAFILE(Lu_25,2,COP,nCOP,IADD25) +IIC = 0 +IND = 0 +IRL = IRC(ILIM) +do INDA=1,IRL + NSS = MUL(JSUNP(JSY,INDA),LSYM) + if (INDA <= IRC(1)) then + IIC = IIC+1 + IND = IND+1 + S(IND) = S(IND)+COP(IIC)*C(IND) + if (IIC >= nCOP) then + call dDAFILE(Lu_25,2,COP,nCOP,IADD25) + IIC = 0 + end if + else if (INDA <= IRC(2)) then + NA1 = NSYS(NSS)+1 + NA2 = NSYS(NSS+1) + do NA=NA1,NA2 + IIC = IIC+1 + IND = IND+1 + S(IND) = S(IND)+COP(IIC)*C(IND) + if (IIC >= nCOP) then + call dDAFILE(Lu_25,2,COP,nCOP,IADD25) + IIC = 0 + end if + end do + else + do NA=1,NVIRT + NSA = MUL(NSS,NSM(LN+NA)) + NB1 = NSYS(NSA)+1 + NB2 = NSYS(NSA+1) + if (NB2 > NA) NB2 = NA + do NB=NB1,NB2 + IIC = IIC+1 + IND = IND+1 + S(IND) = S(IND)+COP(IIC)*C(IND) + if (IIC >= nCOP) then + call dDAFILE(Lu_25,2,COP,nCOP,IADD25) + IIC = 0 + end if + end do + end do + end if +end do + +return + +end subroutine DIAGC_CPF diff -Nru openmolcas-22.02/src/cpf/diagc.f openmolcas-22.10/src/cpf/diagc.f --- openmolcas-22.02/src/cpf/diagc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/diagc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,70 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE DIAGC_CPF(JSY,C,S) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" - DIMENSION JSY(*),C(*),S(*) -* - JSYM(L)=JSUNP_CPF(JSY,L) - IADD25=IAD25S - CALL dDAFILE(Lu_25,2,COP,nCOP,IADD25) - IIC=0 - IND=0 - ILIM=4 - IF(IFIRST.NE.0)ILIM=2 - IRL=IRC(ILIM) - DO 100 INDA=1,IRL - NSS=MUL(JSYM(INDA),LSYM) - FACS=D1 - IF(INDA.GT.IRC(1))GO TO 120 - IIC=IIC+1 - IND=IND+1 - S(IND)=S(IND)+FACS*COP(IIC)*C(IND) - IF(IIC.LT.nCOP)GO TO 100 - CALL dDAFILE(Lu_25,2,COP,nCOP,IADD25) - IIC=0 - GO TO 100 -120 IF(INDA.GT.IRC(2))GO TO 130 - NA1=NSYS(NSS)+1 - NA2=NSYS(NSS+1) - IF(NA2.LT.NA1)GO TO 100 - DO 121 NA=NA1,NA2 - IIC=IIC+1 - IND=IND+1 - S(IND)=S(IND)+FACS*COP(IIC)*C(IND) - IF(IIC.LT.nCOP)GO TO 121 - CALL dDAFILE(Lu_25,2,COP,nCOP,IADD25) - IIC=0 -121 CONTINUE - GO TO 100 -130 DO 141 NA=1,NVIRT - NSA=MUL(NSS,NSM(LN+NA)) - NB1=NSYS(NSA)+1 - NB2=NSYS(NSA+1) - IF(NB2.GT.NA)NB2=NA - IF(NB2.LT.NB1)GO TO 141 - DO 142 NB=NB1,NB2 - IIC=IIC+1 - IND=IND+1 - S(IND)=S(IND)+FACS*COP(IIC)*C(IND) - IF(IIC.LT.nCOP)GO TO 142 - CALL dDAFILE(Lu_25,2,COP,nCOP,IADD25) - IIC=0 -142 CONTINUE -141 CONTINUE -100 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/diag_cpf.F90 openmolcas-22.10/src/cpf/diag_cpf.F90 --- openmolcas-22.02/src/cpf/diag_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/diag_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,31 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine DIAG_CPF(ICASE,JSY,HDIAG,FC,FIJ,FJI) + +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: ICASE(*), JSY(*) +real(kind=wp), intent(_OUT_) :: HDIAG(*) +real(kind=wp), intent(in) :: FC(*), FIJ(*), FJI(*) + +call IIJJ_CPF(ICASE,JSY,HDIAG,FC,FIJ,FJI) +call IJIJ_CPF(JSY,HDIAG,FJI) + +return + +end subroutine DIAG_CPF diff -Nru openmolcas-22.02/src/cpf/diagct_cpf.F90 openmolcas-22.10/src/cpf/diagct_cpf.F90 --- openmolcas-22.02/src/cpf/diagct_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/diagct_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,74 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine DIAGCT_CPF() + +use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc +use cpf_global, only: ICASE, IFIRST, ILIM, IROW, ISAB, ISMAX, JBUF, JSC, JSY, KBUF, KBUFF1, LBUF, MAX11, NCONF, NORBT, NOV, NOV1, & + NTIBUF, NVT5 +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp, RtoI + +implicit none +integer(kind=iwp) :: JBUF1, KBUF1, LBUF1, NINTGR +integer(kind=iwp), allocatable :: IBUFL(:), INDCAT(:) +real(kind=wp), allocatable :: A1(:), A2(:), FC(:), FIJ(:), FJI(:), TIBUF(:) +real(kind=wp), allocatable, target :: BUF(:), BUFOUT(:) +integer(kind=iwp), pointer :: iBUFBI(:), INDOUT(:) + +NCONF = JSC(ILIM) +KBUF1 = ((RtoI+1)*KBUF+2+(RtoI-1))/RtoI +JBUF1 = ((RtoI+1)*JBUF+2+(RtoI-1))/RtoI +LBUF1 = ((RtoI+1)*LBUF+2+(RtoI-1))/RtoI +call mma_allocate(TIBUF,NTIBUF,label='TIBUF') +call mma_allocate(BUFOUT,max(NVT5*JBUF1,NOV*KBUF1,NOV1*LBUF1,MAX11),label='BUFOUT') +call mma_allocate(INDCAT,max(NVT5,NOV,NOV1),label='INDCAT') +call mma_allocate(IBUFL,max(NVT5,NOV,NOV1,25000),label='IBUFL') +call c_f_pointer(c_loc(BUFOUT),INDOUT,[1]) +! Initialize sorting buffer, so that automatic detection of +! uninitialized variables does not give false alarms. +BUFOUT(1:NOV*KBUF1) = Zero +! Similar before SORTB_CPF and SORT_CPF. +call mma_allocate(BUF,KBUFF1+2,label='BUF') +call mma_allocate(A1,ISMAX,label='A1') +call mma_allocate(A2,ISMAX,label='A2') +call c_f_pointer(c_loc(BUF),iBUFBI,[1]) +call SORTA_CPF(BUFOUT,INDOUT,INDCAT,IBUFL,TIBUF,ISAB,BUF,iBUFBI,A1,A2,NINTGR) +nullify(iBUFBI) +if (IFIRST == 0) then + BUFOUT(1:NVT5*JBUF) = Zero + call SORTB_CPF(BUFOUT,INDOUT,INDCAT,IBUFL,TIBUF,A1,A2,ISAB,BUF) +end if +call mma_deallocate(BUF) +call mma_deallocate(A1) +call mma_deallocate(A2) +BUFOUT(1:NOV1*LBUF) = Zero +call mma_allocate(FC,IROW(NORBT+1),label='FC') +call mma_allocate(FIJ,IROW(NORBT+1),label='FIJ') +call mma_allocate(FJI,IROW(NORBT+1),label='FJI') +call SORT_CPF(BUFOUT,INDOUT,INDCAT,IBUFL,FC,FIJ,FJI,TIBUF) +call DIAG_CPF(ICASE,JSY,BUFOUT,FC,FIJ,FJI) +call mma_deallocate(FC) +call mma_deallocate(FIJ) +call mma_deallocate(FJI) +call mma_deallocate(TIBUF) +nullify(INDOUT) +call mma_deallocate(BUFOUT) +call mma_deallocate(INDCAT) +call mma_deallocate(IBUFL) + +return + +end subroutine DIAGCT_CPF diff -Nru openmolcas-22.02/src/cpf/diagct.f openmolcas-22.10/src/cpf/diagct.f --- openmolcas-22.02/src/cpf/diagct.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/diagct.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,71 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE DIAGCT_CPF(H) - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "cpfmcpf.fh" - DIMENSION H(*) - CALL DIAGCT_INTERNAL(H) -* -* This is to allow type punning without an explicit interface - CONTAINS - SUBROUTINE DIAGCT_INTERNAL(H) - USE ISO_C_BINDING - REAL*8, TARGET :: H(*) - INTEGER, POINTER :: iH1(:),iH2(:),iH4(:),iH11(:),iH12(:),iH13(:), - &iH17(:),iH18(:),iH19(:),iH20(:),iH21(:),iH22(:),iH25(:) - ILIM=4 - IF(IFIRST.NE.0)ILIM=2 - NCONF=JSC(ILIM) -* Initialize sorting buffer, so that automatic detection of -* uninitialized variables does not give false alarms. - CALL DCOPY_(LW(21)-LW(20),[0.0D0],0,H(LW(20)),1) -* Now H(LW(20)) and up are filled with zeroes. -* Similar before SORTB_CPF and SORT_CPF. - CALL C_F_POINTER(C_LOC(H(LW(4))),iH4,[1]) - CALL C_F_POINTER(C_LOC(H(LW(20))),iH20,[1]) - CALL C_F_POINTER(C_LOC(H(LW(21))),iH21,[1]) - CALL C_F_POINTER(C_LOC(H(LW(22))),iH22,[1]) - CALL C_F_POINTER(C_LOC(H(LW(25))),iH25,[1]) - CALL SORTA_CPF(H(LW(20)),iH20,iH21,iH22,H(LW(10)), - & iH4,H(LW(25)),iH25,H(LW(23)),H(LW(24)),NINTGR) - NULLIFY(iH4,iH20,iH21,iH22,iH25) - IF(IFIRST.EQ.0) THEN - CALL DCOPY_(LW(18)-LW(17),[0.0D0],0,H(LW(17)),1) - CALL C_F_POINTER(C_LOC(H(LW(4))),iH4,[1]) - CALL C_F_POINTER(C_LOC(H(LW(17))),iH17,[1]) - CALL C_F_POINTER(C_LOC(H(LW(18))),iH18,[1]) - CALL C_F_POINTER(C_LOC(H(LW(19))),iH19,[1]) - CALL SORTB_CPF(H(LW(17)),iH17,iH18, - & iH19,H(LW(10)),H(LW(94)),H(LW(95)),iH4,H(LW(96))) - NULLIFY(iH4,iH17,iH18,iH19) - END IF - CALL DCOPY_(LW(12)-LW(11),[0.0D0],0,H(LW(11)),1) - CALL C_F_POINTER(C_LOC(H(LW(11))),iH11,[1]) - CALL C_F_POINTER(C_LOC(H(LW(12))),iH12,[1]) - CALL C_F_POINTER(C_LOC(H(LW(13))),iH13,[1]) - CALL SORT_CPF(H(LW(11)),iH11,iH12,iH13,H(LW(14)), - & H(LW(15)),H(LW(16)),H(LW(10))) - NULLIFY(iH11,iH12,iH13) - CALL C_F_POINTER(C_LOC(H(LW(1))),iH1,[1]) - CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL DIAG_CPF(iH1,iH2,H(LW(11)),H(LW(14)),H(LW(15)), - & H(LW(16))) - NULLIFY(iH1,iH2) - RETURN - END SUBROUTINE DIAGCT_INTERNAL -* - END diff -Nru openmolcas-22.02/src/cpf/diag.f openmolcas-22.10/src/cpf/diag.f --- openmolcas-22.02/src/cpf/diag.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/diag.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE DIAG_CPF(ICASE,JSY,HDIAG,FC,FIJ,FJI) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION JSY(*),HDIAG(*),FC(*),FIJ(*),FJI(*) - DIMENSION ICASE(*) - CALL IIJJ_CPF(ICASE,JSY,HDIAG,FC,FIJ,FJI) - CALL IJIJ_CPF(JSY,HDIAG,FJI) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/diis_cpf.F90 openmolcas-22.10/src/cpf/diis_cpf.F90 --- openmolcas-22.02/src/cpf/diis_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/diis_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,96 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine DIIS_CPF(DPI,DPJ,BST,MIT,BIJ,ITP,CN) + +use cpf_global, only: IADDP, IDIIS, IPRINT, ITPUL, Lu_CI, NCONF +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: MIT, ITP +real(kind=wp), intent(inout) :: DPI(*), BST(MIT,MIT) +real(kind=wp), intent(_OUT_) :: DPJ(*), CN(*) +real(kind=wp), intent(inout) :: BIJ(ITP,ITP) +integer(kind=iwp) :: I, IAD, ITM, J +real(kind=wp) :: T, WHS(50) +real(kind=r8), external :: DDOT_ + +if (ITPUL /= 1) then + + ITM = ITPUL-1 + BIJ(1:ITM,1:ITM) = BST(1:ITM,1:ITM) + do I=1,ITPUL + BIJ(ITP,I) = -One + BIJ(I,ITP) = -One + end do + BIJ(ITP,ITP) = Zero + + do I=1,ITM + IAD = IADDP(I+1) + call dDAFILE(Lu_CI,2,DPJ,NCONF,IAD) + T = DDOT_(NCONF,DPI,1,DPJ,1) + BIJ(I,ITPUL) = T + BIJ(ITPUL,I) = T + BST(I,ITPUL) = T + BST(ITPUL,I) = T + if (I == 1) then + T = DDOT_(NCONF,DPJ,1,DPJ,1) + BIJ(1,1) = T + BST(1,1) = T + end if + end do + BIJ(ITPUL,ITPUL) = DDOT_(NCONF,DPI,1,DPI,1) + BST(ITPUL,ITPUL) = BIJ(ITPUL,ITPUL) + + if (IPRINT >= 10) then + do I=1,ITP + write(u6,16) (BIJ(J,I),J=1,ITP) + end do + end if + +end if + +if (IDIIS /= 1) then + do I=1,ITPUL + IAD = IADDP(I) + call dDAFILE(Lu_CI,2,DPJ,NCONF,IAD) + do J=1,NCONF + DPI(J) = DPI(J)+DPJ(J) + end do + end do + if (IPRINT >= 15) write(u6,14) (DPI(I),I=1,NCONF) +else + call DECOMP(ITP,BIJ) + do I=1,ITPUL + WHS(I) = Zero + end do + WHS(ITP) = -One + call SOLVE(ITP,BIJ,WHS,CN) + + ! UPDATE P AND DELTA P + + call NEXT(DPI,DPJ,CN) + + ITPUL = 0 +end if + +return + +14 format(6X,'C(DIIS)',5F10.6) +16 format(6X,'BIJ ',6F12.6) + +end subroutine DIIS_CPF diff -Nru openmolcas-22.02/src/cpf/diis.f openmolcas-22.10/src/cpf/diis.f --- openmolcas-22.02/src/cpf/diis.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/diis.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,85 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE DIIS_CPF(DPI,DPJ,BST,MIT,BIJ,ITP,CN) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION DPI(*),DPJ(*),BST(MIT,MIT),BIJ(ITP,ITP), - *CN(*),WHS(50) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" -* - IF(ITPUL.EQ.1)GO TO 26 -C - ITM=ITPUL-1 - DO 5 I=1,ITM - DO 10 J=1,ITM - BIJ(J,I)=BST(J,I) -10 CONTINUE -5 CONTINUE - DO 15 I=1,ITPUL - BIJ(ITP,I)=-1.0D0 - BIJ(I,ITP)=-1.0D0 -15 CONTINUE - BIJ(ITP,ITP)=0.0D0 -C - DO 20 I=1,ITM - IAD=IADDP(I+1) - CALL dDAFILE(Lu_CI,2,DPJ,NCONF,IAD) - T=DDOT_(NCONF,DPI,1,DPJ,1) - BIJ(I,ITPUL)=T - BIJ(ITPUL,I)=T - BST(I,ITPUL)=T - BST(ITPUL,I)=T - IF(I.EQ.1) THEN - T=DDOT_(NCONF,DPJ,1,DPJ,1) - BIJ(1,1)=T - BST(1,1)=T - END IF -20 CONTINUE - BIJ(ITPUL,ITPUL)=DDOT_(NCONF,DPI,1,DPI,1) - BST(ITPUL,ITPUL)=BIJ(ITPUL,ITPUL) -C - IF(IPRINT.LT.10)GO TO 26 - DO 17 I=1,ITP - WRITE(6,16)(BIJ(J,I),J=1,ITP) - CALL XFLUSH(6) -16 FORMAT(6X,'BIJ ',6F12.6) -17 CONTINUE -C -26 IF(IDIIS.EQ.1)GO TO 25 - DO 7 I=1,ITPUL - IAD=IADDP(I) - CALL dDAFILE(Lu_CI,2,DPJ,NCONF,IAD) - DO 6 J=1,NCONF - DPI(J)=DPI(J)+DPJ(J) -6 CONTINUE -7 CONTINUE - IF(IPRINT.GE.15)WRITE(6,14)(DPI(I),I=1,NCONF) -14 FORMAT(6X,'C(DIIS)',5F10.6) - RETURN -C -25 CALL DECOMP(ITP,BIJ,BIJ) - DO 55 I=1,ITPUL - WHS(I)=0.0D00 -55 CONTINUE - WHS(ITP)=-1.0D00 - CALL SOLVE(ITP,BIJ,WHS,CN) -C -C UPDATE P AND DELTA P -C - CALL NEXT(DPI,DPJ,CN) -C - ITPUL=0 - RETURN - END diff -Nru openmolcas-22.02/src/cpf/dsq2.f openmolcas-22.10/src/cpf/dsq2.f --- openmolcas-22.02/src/cpf/dsq2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/dsq2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE DSQ2(C,S,MUL,INDEX,JSY,NDIAG,INUM,IRC3,LSYM, - *NVIRT,SQ2) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION C(*),S(*),MUL(8,8),INDEX(*),JSY(*),NDIAG(*) -CPAM97 EXTERNAL UNPACK -CPAM97 INTEGER UNPACK -CRL JSYM(L)=IAND(ISHFT(JSY((L+19)/20),-3*((L+19)/20*20-L)),7)+1 -CPAM96 JSYM(L)=UNPACK(JSY((L+9)/10),3*MOD(L-1,10)+1,3)+1 - JSYM(L)=JSUNP_CPF(JSY,L) - DO 10 I=1,INUM - II1=IRC3+I - NS1=JSYM(II1) - NS1L=MUL(NS1,LSYM) - IF(NS1L.NE.1)GO TO 10 - NA=INDEX(II1) - DO 20 MA=1,NVIRT - C(NA+NDIAG(MA))=C(NA+NDIAG(MA))/SQ2 - S(NA+NDIAG(MA))=SQ2*S(NA+NDIAG(MA)) -20 CONTINUE -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/dsq2.F90 openmolcas-22.10/src/cpf/dsq2.F90 --- openmolcas-22.02/src/cpf/dsq2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/dsq2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,40 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine DSQ2(C,S,MUL,INDX,JSY,NDIAG,INUM,IRC3,LSYM,NVIRT,SQ2) + +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(inout) :: C(*), S(*) +integer(kind=iwp), intent(in) :: MUL(8,8), INDX(*), JSY(*), NDIAG(*), INUM, IRC3, LSYM, NVIRT +real(kind=wp), intent(in) :: SQ2 +integer(kind=iwp) :: I, II1, MA, NA, NS1, NS1L +integer(kind=iwp), external :: JSUNP + +do I=1,INUM + II1 = IRC3+I + NS1 = JSUNP(JSY,II1) + NS1L = MUL(NS1,LSYM) + if (NS1L /= 1) cycle + NA = INDX(II1) + do MA=1,NVIRT + C(NA+NDIAG(MA)) = C(NA+NDIAG(MA))/SQ2 + S(NA+NDIAG(MA)) = SQ2*S(NA+NDIAG(MA)) + end do +end do + +return + +end subroutine DSQ2 diff -Nru openmolcas-22.02/src/cpf/epsbis.f openmolcas-22.10/src/cpf/epsbis.f --- openmolcas-22.02/src/cpf/epsbis.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/epsbis.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,69 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE EPSBIS(JSY,INDEX,C,W,EPB) - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "cpfmcpf.fh" - DIMENSION JSY(*),INDEX(*),C(*),W(*),EPB(*) -CPAM97 EXTERNAL UNPACK -CPAM97 INTEGER UNPACK -CRL JSYM(L)=IAND(ISHFT(JSY((L+19)/20),-3*((L+19)/20*20-L)),7)+1 -CPAM96 JSYM(L)=UNPACK(JSY((L+9)/10),3*MOD(L-1,10)+1,3)+1 - JSYM(L)=JSUNP_CPF(JSY,L) -C - CALL SETZ(EPB,IRC(4)) - IF(ICPF.EQ.1.OR.ISDCI.EQ.1.OR.INCPF.EQ.1)RETURN -C -C VALENCE -C - IP=IRC(1) - DO 15 I=1,IP - EPB(I)=C(I)*W(I) -15 CONTINUE -C -C SINGLES -C - IP=IRC(2)-IRC(1) - IN=IRC(1) - DO 5 I=1,IP -CFUE IND=IND+1 - NS1=JSYM(IN+I) - NSIL=MUL(NS1,LSYM) - INUM=NVIR(NSIL) - IST=INDEX(IN+I)+1 -CRL CALL DOTPR(C(IST),1,W(IST),1,EPB(IN+I),INUM) - EPB(IN+I)=DDOT_(INUM,C(IST),1,W(IST),1) -5 CONTINUE -C -C DOUBLES -C - IP=IRC(4)-IRC(2) - IN=IRC(2) - DO 10 I=1,IP - NS1=JSYM(IN+I) - NSIL=MUL(NS1,LSYM) - INUM=NNS(NSIL) - IST=INDEX(IN+I)+1 -CRL CALL DOTPR(C(IST),1,W(IST),1,EPB(IN+I),INUM) - EPB(IN+I)=DDOT_(INUM,C(IST),1,W(IST),1) -10 CONTINUE -C - IP=IRC(4) - IF(IPRINT.GT.5)WRITE(6,998)(EPB(I),I=1,IP) -998 FORMAT(6X,'EPB ',5F10.6) -C - RETURN - END diff -Nru openmolcas-22.02/src/cpf/epsbis.F90 openmolcas-22.10/src/cpf/epsbis.F90 --- openmolcas-22.02/src/cpf/epsbis.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/epsbis.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,74 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine EPSBIS(JSY,INDX,C,W,EPB) + +use cpf_global, only: ICPF, INCPF, IPRINT, IRC, ISDCI, LSYM, NNS, NVIR +use Symmetry_Info, only: Mul +use Constants, only: Zero +use Definitions, only: wp, iwp, u6, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: JSY(*), INDX(*) +real(kind=wp), intent(in) :: C(*), W(*) +real(kind=wp), intent(_OUT_) :: EPB(*) +integer(kind=iwp) :: I, IIN, INUM, IP, IST, NS1, NSIL +integer(kind=iwp), external :: JSUNP +real(kind=r8), external :: DDOT_ + +EPB(1:IRC(4)) = Zero +if ((ICPF == 1) .or. (ISDCI == 1) .or. (INCPF == 1)) return + +! VALENCE + +IP = IRC(1) +do I=1,IP + EPB(I) = C(I)*W(I) +end do + +! SINGLES + +IP = IRC(2)-IRC(1) +IIN = IRC(1) +do I=1,IP + !FUE IND = IND+1 + NS1 = JSUNP(JSY,IIN+I) + NSIL = MUL(NS1,LSYM) + INUM = NVIR(NSIL) + IST = INDX(IIN+I)+1 + EPB(IIN+I) = DDOT_(INUM,C(IST),1,W(IST),1) +end do + +! DOUBLES + +IP = IRC(4)-IRC(2) +IIN = IRC(2) +do I=1,IP + NS1 = JSUNP(JSY,IIN+I) + NSIL = MUL(NS1,LSYM) + INUM = NNS(NSIL) + IST = INDX(IIN+I)+1 + EPB(IIN+I) = DDOT_(INUM,C(IST),1,W(IST),1) +end do + +IP = IRC(4) +if (IPRINT > 5) write(u6,998) (EPB(I),I=1,IP) + +return + +998 format(6X,'EPB ',5F10.6) + +end subroutine EPSBIS diff -Nru openmolcas-22.02/src/cpf/epsprim.f openmolcas-22.10/src/cpf/epsprim.f --- openmolcas-22.02/src/cpf/epsprim.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/epsprim.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,67 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE EPSPRIM(JSY,INDEX,C,S,EPP) - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "cpfmcpf.fh" - DIMENSION JSY(*),INDEX(*),C(*),S(*),EPP(*) -CPAM97 EXTERNAL UNPACK -CPAM97 INTEGER UNPACK -CRL JSYM(L)=IAND(ISHFT(JSY((L+19)/20),-3*((L+19)/20*20-L)),7)+1 -CPAM96 JSYM(L)=UNPACK(JSY((L+9)/10),3*MOD(L-1,10)+1,3)+1 - JSYM(L)=JSUNP_CPF(JSY,L) -C -C VALENCE -C - IP=IRC(1) - DO 15 I=1,IP - EPP(I)=EPP(I)+C(I)*S(I) -15 CONTINUE -C -C -C SINGLES -C - IP=IRC(2)-IRC(1) - IN=IRC(1) - DO 5 I=1,IP - NS1=JSYM(IN+I) - NSIL=MUL(NS1,LSYM) - INUM=NVIR(NSIL) - IST=INDEX(IN+I)+1 -CRL CALL DOTPR(C(IST),1,S(IST),1,T,INUM) - T=DDOT_(INUM,C(IST),1,S(IST),1) - EPP(IN+I)=EPP(IN+I)+T -5 CONTINUE -C -C DOUBLES -C - IP=IRC(4)-IRC(2) - IN=IRC(2) - DO 10 I=1,IP - NS1=JSYM(IN+I) - NSIL=MUL(NS1,LSYM) - INUM=NNS(NSIL) - IST=INDEX(IN+I)+1 -CRL CALL DOTPR(C(IST),1,S(IST),1,T,INUM) - T=DDOT_(INUM,C(IST),1,S(IST),1) - EPP(IN+I)=EPP(IN+I)+T -10 CONTINUE -C - IP=IRC(4) - IF(IPRINT.GT.5)WRITE(6,998)(EPP(I),I=1,IP) -998 FORMAT(6X,'EPP ',5F10.6) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/epsprim.F90 openmolcas-22.10/src/cpf/epsprim.F90 --- openmolcas-22.02/src/cpf/epsprim.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/epsprim.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,70 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine EPSPRIM(JSY,INDX,C,S,EPP) + +use cpf_global, only: IPRINT, IRC, LSYM, NNS, NVIR +use Symmetry_Info, only: Mul +use Definitions, only: wp, iwp, u6, r8 + +implicit none +integer(kind=iwp), intent(in) :: JSY(*), INDX(*) +real(kind=wp), intent(in) :: C(*), S(*) +real(kind=wp), intent(inout) :: EPP(*) +integer(kind=iwp) :: I, IIN, INUM, IP, IST, NS1, NSIL +real(kind=wp) :: T +integer(kind=iwp), external :: JSUNP +real(kind=r8), external :: DDOT_ + +! VALENCE + +IP = IRC(1) +do I=1,IP + EPP(I) = EPP(I)+C(I)*S(I) +end do + +! SINGLES + +IP = IRC(2)-IRC(1) +IIN = IRC(1) +do I=1,IP + NS1 = JSUNP(JSY,IIN+I) + NSIL = MUL(NS1,LSYM) + INUM = NVIR(NSIL) + IST = INDX(IIN+I)+1 + T = DDOT_(INUM,C(IST),1,S(IST),1) + EPP(IIN+I) = EPP(IIN+I)+T +end do + +! DOUBLES + +IP = IRC(4)-IRC(2) +IIN = IRC(2) +do I=1,IP + NS1 = JSUNP(JSY,IIN+I) + NSIL = MUL(NS1,LSYM) + INUM = NNS(NSIL) + IST = INDX(IIN+I)+1 + T = DDOT_(INUM,C(IST),1,S(IST),1) + EPP(IIN+I) = EPP(IIN+I)+T +end do + +IP = IRC(4) +if (IPRINT > 5) write(u6,998) (EPP(I),I=1,IP) + +return + +998 format(6X,'EPP ',5F10.6) + +end subroutine EPSPRIM diff -Nru openmolcas-22.02/src/cpf/faibj_cpf.F90 openmolcas-22.10/src/cpf/faibj_cpf.F90 --- openmolcas-22.02/src/cpf/faibj_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/faibj_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,398 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine FAIBJ_CPF(JSY,INDX,C,S,ABIJ,AIBJ,AJBI,BUFIN,A,B,F,FSEC,ENP,EPP) + +use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc +use cpf_global, only: IRC, IREF0, IROW, ITER, LASTAD, LBUF, LN, LSYM, Lu_CIGuga, Lu_TiABIJ, NDIAG, NSM, NSYM, NVIR, NVIRT, SQ2 +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Constants, only: Zero, One, Half +use Definitions, only: wp, iwp, r8, RtoI + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: JSY(*), INDX(*) +real(kind=wp), intent(inout) :: C(*), S(*), ABIJ(*), AIBJ(*), AJBI(*), FSEC(*), EPP(*) +real(kind=wp), intent(_OUT_) :: BUFIN(*), A(*), B(*), F(*) +real(kind=wp), intent(in) :: ENP(*) +integer(kind=iwp) :: IAB, IADD10, IADR, IBSYM, ICHK, ICOUP, ICOUP1, ICSYM, IFAB, IFT, IFTA, IFTB, IIN, IJ1, ILEN, ILIM, IND, INDA, & + INDB, INDI, INMY, INNY, INS, INUM, IPF, IPF1, IPOA(9), IPOB(9), IPOF(9), ISTAR, ITURN, ITYP, JTURN, LBUF0, & + LBUF1, LBUF2, LENGTH, MYL, MYSYM, NAC, NBC, NI, NJ, NOT2, NOVST, NSIJ, NVT, NYL, NYSYM +real(kind=wp) :: COPI, CPL, CPLA, CPLL, FAC, TERM +logical(kind=iwp) :: Skip +integer(kind=iwp), external :: JSUNP +real(kind=r8), external :: DDOT_ + +call FAIBJ_CPF_INTERNAL(BUFIN) + +! This is to allow type punning without an explicit interface +contains + +subroutine FAIBJ_CPF_INTERNAL(BUFIN) + + real(kind=wp), target, intent(_OUT_) :: BUFIN(*) + integer(kind=iwp), pointer :: IBUFIN(:) + integer(kind=iwp) :: IASYM, II + + call c_f_pointer(c_loc(BUFIN),iBUFIN,[1]) + + ITYP = 0 ! dummy initialize + ICOUP = 0 ! dummy initialize + ICOUP1 = 0 ! dummy initialize + INUM = IRC(4)-IRC(3) + call PSQ2(C,S,MUL,INDX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) + NVT = IROW(NVIRT+1) + ICHK = 0 + IFAB = 0 + NOVST = LN*NVIRT+1+NVT + LBUF0 = RTOI*LBUF + LBUF1 = LBUF0+LBUF+1 + LBUF2 = LBUF1+1 + NOT2 = IROW(LN+1) + IADD10 = IAD10(6) + do + call dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) + call iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN == 0) cycle + if (ILEN < 0) exit + do II=1,ILEN + IND = ICOP1(II) + if (ICHK == 0) then + if (IND /= 0) then + if (IFAB /= 1) then + IFAB = ibits(IND,0,1) + ITURN = ibits(IND,1,1) + ITYP = ibits(IND,2,3) + ICOUP = ibits(IND,5,13) + ICOUP1 = ibits(IND,18,13) + CPL = COP(II) + CPLA = Zero + if (IFAB /= 0) cycle + if (ITURN == 0) then + ! FIRST ORDER INTERACTION + INDA = ICOUP + INDB = IRC(ITYP+1)+ICOUP1 + ISTAR = 1 + if (ITYP == 1) ISTAR = INS+1 + if (INS /= 0) then + if (INDA == IREF0) then + CPLL = CPL/sqrt(ENP(INDB)) + S(INDX(INDB)+1:INDX(INDB)+INS) = S(INDX(INDB)+1:INDX(INDB)+INS)+CPLL*FSEC(ISTAR:ISTAR+INS-1) + if (ITER /= 1) then + TERM = DDOT_(INS,C(INDX(INDB)+1),1,FSEC(ISTAR),1) + EPP(INDB) = EPP(INDB)+CPLL*TERM + end if + else + COPI = CPL*C(INDA) + S(INDX(INDB)+1:INDX(INDB)+INS) = S(INDX(INDB)+1:INDX(INDB)+INS)+COPI*FSEC(ISTAR:ISTAR+INS-1) + TERM = DDOT_(INS,FSEC(ISTAR),1,C(INDX(INDB)+1),1) + S(INDA) = S(INDA)+CPL*TERM + end if + end if + cycle + end if + else + CPLA = COP(II) + IFAB = 0 + end if + ! INTERACTIONS BETWEEN DOUBLES AND + ! INTERACTIONS BETWEEN SINGLES + if (ITER == 1) cycle + !call JTIME(IST) + IFTA = 0 + IFTB = 0 + select case (ITYP) + case default !(1) + INDA = IRC(2)+ICOUP1 + INDB = IRC(2)+ICOUP + IFTA = 1 + IFTB = 1 + case (2) + INDA = IRC(3)+ICOUP1 + INDB = IRC(3)+ICOUP + case (3) + INDA = IRC(2)+ICOUP1 + INDB = IRC(3)+ICOUP + IFTA = 1 + case (4) + INDA = IRC(3)+ICOUP1 + INDB = IRC(2)+ICOUP + IFTB = 1 + case (5) + INDA = IRC(1)+ICOUP1 + INDB = IRC(1)+ICOUP + end select + MYSYM = JSUNP(JSY,INDA) + + NYSYM = MUL(MYSYM,NSIJ) + MYL = MUL(MYSYM,LSYM) + NYL = MUL(NYSYM,LSYM) + call IPO_CPF(IPOA,NVIR,MUL,NSYM,MYL,IFTA) + call IPO_CPF(IPOB,NVIR,MUL,NSYM,NYL,IFTB) + INMY = INDX(INDA)+1 + INNY = INDX(INDB)+1 + if (ITYP == 5) then + ! DOUBLET-DOUBLET INTERACTIONS + IIN = IPOF(MYL+1)-IPOF(MYL) + if (IIN /= 0) then + IPF = IPOF(MYL) + F(1:IIN) = CPL*AIBJ(IPF+1:IPF+IIN)+CPLA*ABIJ(IPF+1:IPF+IIN) + if (INDA == INDB) call DCOPY_(NVIR(MYL),[Zero],0,F,NVIR(MYL)+1) + call FMMM(C(INMY),F,A,1,NVIR(NYL),NVIR(MYL)) + S(INNY:INNY+NVIR(NYL)-1) = S(INNY:INNY+NVIR(NYL)-1)+A(1:NVIR(NYL)) + if (INDA /= INDB) then + call FMMM(F,C(INNY),A,NVIR(MYL),1,NVIR(NYL)) + S(INMY:INMY+NVIR(MYL)-1) = S(INMY:INMY+NVIR(MYL)-1)+A(1:NVIR(MYL)) + end if + end if + else + ! TRIPLET-SINGLET , SINGLET-TRIPLET , + ! TRIPLET-TRIPLET AND SINGLET-SINGLET INTERACTIONS + do IASYM=1,NSYM + IAB = IPOF(IASYM+1)-IPOF(IASYM) + if (IAB == 0) cycle + ICSYM = MUL(MYL,IASYM) + IBSYM = MUL(NYL,ICSYM) + if ((INDA == INDB) .and. (IBSYM > IASYM)) cycle + if (NVIR(ICSYM) == 0) cycle + NAC = NVIR(IASYM)*NVIR(ICSYM) + NBC = NVIR(IBSYM)*NVIR(ICSYM) + if (IASYM > ICSYM) then + if (IBSYM > ICSYM) then + ! CASE 1 , IASYM > ICSYM AND IBSYM > ICSYM + IPF = IPOF(IASYM) + F(1:IAB) = CPL*AIBJ(IPF+1:IPF+IAB)+CPLA*ABIJ(IPF+1:IPF+IAB) + if (INDA == INDB) call DCOPY_(NVIR(IASYM),[Zero],0,F,NVIR(IASYM)+1) + call FMMM(C(INMY+IPOA(IASYM)),F,A,NVIR(ICSYM),NVIR(IBSYM),NVIR(IASYM)) + S(INNY+IPOB(IBSYM):INNY+IPOB(IBSYM)+NBC-1) = S(INNY+IPOB(IBSYM):INNY+IPOB(IBSYM)+NBC-1)+A(1:NBC) + if (INDA /= INDB) then + IPF = IPOF(IBSYM) + F(1:IAB) = CPL*AJBI(IPF+1:IPF+IAB)+CPLA*ABIJ(IPF+1:IPF+IAB) + call FMMM(C(INNY+IPOB(IBSYM)),F,A,NVIR(ICSYM),NVIR(IASYM),NVIR(IBSYM)) + S(INMY+IPOA(IASYM):INMY+IPOA(IASYM)+NAC-1) = S(INMY+IPOA(IASYM):INMY+IPOA(IASYM)+NAC-1)+A(1:NAC) + end if + else + ! CASE 2 , IASYM > ICSYM AND ICSYM > OR = IBSYM + IPF = IPOF(IBSYM) + F(1:IAB) = CPL*AJBI(IPF+1:IPF+IAB)+CPLA*ABIJ(IPF+1:IPF+IAB) + call MTRANS(C(INMY+IPOA(IASYM)),A,NVIR(IASYM),NVIR(ICSYM)) + call FMMM(F,A,B,NVIR(IBSYM),NVIR(ICSYM),NVIR(IASYM)) + if (NYL == 1) then + A(1:NBC) = B(1:NBC) + if (IFTB /= 1) then + call SIADD(A,S(INNY+IPOB(ICSYM)),NVIR(IBSYM)) + A(1:NBC) = Zero + call SQUAR(C(INNY+IPOB(IBSYM)),A,NVIR(IBSYM)) + else + call TRADD(A,S(INNY+IPOB(ICSYM)),NVIR(IBSYM)) + A(1:NBC) = Zero + call SQUARN(C(INNY+IPOB(IBSYM)),A,NVIR(IBSYM)) + end if + else + if (IFTB /= 1) then + S(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1) = S(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1)+B(1:NBC) + else + S(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1) = S(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1)-B(1:NBC) + end if + call MTRANS(C(INNY+IPOB(ICSYM)),A,NVIR(ICSYM),NVIR(IBSYM)) + if (IFTB == 1) A(1:NBC) = -A(1:NBC) + end if + call FMMM(A,F,B,NVIR(ICSYM),NVIR(IASYM),NVIR(IBSYM)) + S(INMY+IPOA(IASYM):INMY+IPOA(IASYM)+NAC-1) = S(INMY+IPOA(IASYM):INMY+IPOA(IASYM)+NAC-1)+B(1:NAC) + end if + else + if (IBSYM > ICSYM) then + ! CASE 3 , ICSYM > OR = IASYM AND IBSYM > ICSYM + IPF = IPOF(IASYM) + F(1:IAB) = CPL*AIBJ(IPF+1:IPF+IAB)+CPLA*ABIJ(IPF+1:IPF+IAB) + if (MYL == 1) then + if (IFTA == 0) call SQUAR(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + if (IFTA == 1) call SQUARN(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + else + call MTRANS(C(INMY+IPOA(ICSYM)),A,NVIR(ICSYM),NVIR(IASYM)) + if (IFTA == 1) A(1:NAC) = -A(1:NAC) + end if + call FMMM(A,F,B,NVIR(ICSYM),NVIR(IBSYM),NVIR(IASYM)) + S(INNY+IPOB(IBSYM):INNY+IPOB(IBSYM)+NBC-1) = S(INNY+IPOB(IBSYM):INNY+IPOB(IBSYM)+NBC-1)+B(1:NBC) + call MTRANS(C(INNY+IPOB(IBSYM)),A,NVIR(IBSYM),NVIR(ICSYM)) + call FMMM(F,A,B,NVIR(IASYM),NVIR(ICSYM),NVIR(IBSYM)) + if (MYL == 1) then + A(1:NAC) = B(1:NAC) + if (IFTA /= 1) then + call SIADD(A,S(INMY+IPOA(IASYM)),NVIR(IASYM)) + else + call TRADD(A,S(INMY+IPOA(IASYM)),NVIR(IASYM)) + end if + A(1:NAC) = Zero + else if (IFTA /= 1) then + S(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1) = S(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1)+B(1:NAC) + else + S(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1) = S(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1)-B(1:NAC) + end if + else + ! CASE 4 , ICSYM > OR = IASYM AND ICSYM > OR = IBSYM + IPF = IPOF(IBSYM) + F(1:IAB) = CPL*AJBI(IPF+1:IPF+IAB)+CPLA*ABIJ(IPF+1:IPF+IAB) + if (INDA == INDB) call DCOPY_(NVIR(IASYM),[Zero],0,F,NVIR(IASYM)+1) + if (MYL == 1) then + if (IFTA == 0) call SQUAR(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + if (IFTA == 1) call SQUARM(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + else + if (IFTA == 0) call DCOPY_(NAC,C(INMY+IPOA(ICSYM)),1,A,1) + if (IFTA == 1) call VNEG(NAC,C(INMY+IPOA(ICSYM)),1,A,1) + end if + call FMMM(F,A,B,NVIR(IBSYM),NVIR(ICSYM),NVIR(IASYM)) + if (NYL == 1) then + A(1:NBC) = B(1:NBC) + if (IFTB /= 1) then + call SIADD(A,S(INNY+IPOB(ICSYM)),NVIR(IBSYM)) + else + call TRADD(A,S(INNY+IPOB(ICSYM)),NVIR(IBSYM)) + end if + A(1:NBC) = Zero + else if (IFTB /= 1) then + S(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1) = S(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1)+B(1:NBC) + else + S(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1) = S(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1)-B(1:NBC) + end if + if (INDA /= INDB) then + IPF = IPOF(IASYM) + F(1:IAB) = CPL*AIBJ(IPF+1:IPF+IAB)+CPLA*ABIJ(IPF+1:IPF+IAB) + if (NYL == 1) then + if (IFTB == 0) call SQUAR(C(INNY+IPOB(IBSYM)),A,NVIR(IBSYM)) + if (IFTB == 1) call SQUARM(C(INNY+IPOB(IBSYM)),A,NVIR(IBSYM)) + else + if (IFTB == 0) call DCOPY_(NBC,C(INNY+IPOB(ICSYM)),1,A,1) + if (IFTB == 1) call VNEG(NBC,C(INNY+IPOB(ICSYM)),1,A,1) + end if + call FMMM(F,A,B,NVIR(IASYM),NVIR(ICSYM),NVIR(IBSYM)) + if (MYL == 1) then + A(1:NAC) = B(1:NAC) + if (IFTA /= 1) then + call SIADD(A,S(INMY+IPOA(ICSYM)),NVIR(IASYM)) + else + call TRADD(A,S(INMY+IPOA(ICSYM)),NVIR(IASYM)) + end if + !A(1:NAC) = Zero + else if (IFTA /= 1) then + S(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1) = S(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1)+B(1:NAC) + else + S(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1) = S(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1)-B(1:NAC) + end if + end if + end if + end if + end do + end if + else + ICHK = 1 + end if + else + ICHK = 0 + INDI = IND + NI = ibits(INDI,0,10) + NJ = ibits(INDI,10,10) + NSIJ = MUL(NSM(NI),NSM(NJ)) + call IPO_CPF(IPOF,NVIR,MUL,NSYM,NSIJ,-1) + IJ1 = IROW(NI)+NJ + ILIM = IPOF(NSYM+1) + ABIJ(1:ILIM) = Zero + AIBJ(1:ILIM) = Zero + AJBI(1:ILIM) = Zero + if (ITER == 1) then + Skip = .true. + else + ! READ (AB/IJ) INTEGRALS + IADR = LASTAD(NOVST+IJ1) + JTURN = 0 + Skip = .false. + end if + do + if (Skip) then + Skip = .false. + else + call iDAFILE(Lu_TiABIJ,2,IBUFIN,LBUF2,IADR) + LENGTH = IBUFIN(LBUF1) + IADR = IBUFIN(LBUF2) + if (LENGTH /= 0) then + if (JTURN /= 1) then + call SCATTER(LENGTH,ABIJ,IBUFIN(LBUF0+1:LBUF0+LENGTH),BUFIN) + else + call SCATTER(LENGTH,AIBJ,IBUFIN(LBUF0+1:LBUF0+LENGTH),BUFIN) + end if + end if + if (IADR /= -1) cycle + if (JTURN == 1) exit + end if + ! READ (AI/BJ) INTEGRALS + IADR = LASTAD(NOVST+NOT2+IJ1) + JTURN = 1 + end do + ! CONSTRUCT FIRST ORDER MATRICES + FAC = Half + if (NI /= NJ) FAC = One + IIN = 0 + IFT = 0 + call IPO_CPF(IPOA,NVIR,MUL,NSYM,NSIJ,IFT) + do + do IASYM=1,NSYM + IBSYM = MUL(NSIJ,IASYM) + if (IBSYM > IASYM) cycle + IAB = IPOA(IASYM+1)-IPOA(IASYM) + if (IAB == 0) cycle + call SECORD(AIBJ(IPOF(IASYM)+1),AIBJ(IPOF(IBSYM)+1),FSEC(IIN+1),FAC,NVIR(IASYM),NVIR(IBSYM),NSIJ,IFT) + IIN = IIN+IAB + end do + if (IFT == 1) exit + INS = IIN + IFT = 1 + FAC = Zero + end do + ! SQUARE ABIJ + if (ITER /= 1) then + do IASYM=1,NSYM + if (NVIR(IASYM) == 0) cycle + IBSYM = MUL(NSIJ,IASYM) + if (NVIR(IBSYM) == 0) cycle + IPF = IPOF(IASYM)+1 + IPF1 = IPOF(IBSYM)+1 + if (IASYM <= IBSYM) then + if (NSIJ == 1) then + call SQUAR2(ABIJ(IPF),NVIR(IASYM)) + if (NI == NJ) call SQUAR2(AIBJ(IPF),NVIR(IASYM)) + call MTRANS(AIBJ(IPF),AJBI(IPF),NVIR(IASYM),NVIR(IBSYM)) + else + call MTRANS(ABIJ(IPF1),ABIJ(IPF),NVIR(IASYM),NVIR(IBSYM)) + call MTRANS(AIBJ(IPF1),AJBI(IPF),NVIR(IASYM),NVIR(IBSYM)) + end if + else + call MTRANS(AIBJ(IPF1),AJBI(IPF),NVIR(IASYM),NVIR(IBSYM)) + end if + end do + end if + end if + end do + end do + call DSQ2(C,S,MUL,INDX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) + + nullify(IBUFIN) + + return + +end subroutine FAIBJ_CPF_INTERNAL + +end subroutine FAIBJ_CPF diff -Nru openmolcas-22.02/src/cpf/faibj.f openmolcas-22.10/src/cpf/faibj.f --- openmolcas-22.02/src/cpf/faibj.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/faibj.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,378 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ -cpgi$g opt=1 - SUBROUTINE FAIBJ_CPF(JSY,INDEX,C,S,ABIJ,AIBJ,AJBI,BUFIN,IBUFIN,A, - *B,F,FSEC,ENP,EPP) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" - DIMENSION JSY(*),INDEX(*),C(*),S(*),ABIJ(*),AIBJ(*),AJBI(*), - & BUFIN(*),IBUFIN(*),A(*),B(*),F(*),FSEC(*), - & ENP(*),EPP(*) - DIMENSION IPOF(9),IPOA(9),IPOB(9) - PARAMETER (IPOW5=2**5, IPOW10=2**10, IPOW18=2**18) -* -c JSYM(L)=JSUNP_CPF(JSY,L) -* - ITYP = 0 ! dummy initialize - ICOUP = 0 ! dummy initialize - ICOUP1= 0 ! dummy initialize - INUM=IRC(4)-IRC(3) - CALL PSQ2(C,S,MUL,INDEX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) - NVT=IROW(NVIRT+1) - ICHK=0 - IFAB=0 - NOVST=LN*NVIRT+1+NVT - LBUF0=RTOI*LBUF - LBUF1=LBUF0+LBUF+1 - LBUF2=LBUF1+1 - NOT2=IROW(LN+1) - IADD10=IAD10(6) -300 CALL dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) - CALL iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.EQ.0)GO TO 300 - IF(LEN.LT.0)GO TO 350 - DO 260 II=1,LEN - IND=ICOP1(II) - IF(ICHK.NE.0)GO TO 460 - IF(IND.NE.0)GO TO 371 - ICHK=1 - GO TO 260 -460 ICHK=0 - INDI=IND -* NI=MOD(INDI,1024) -* NJ=MOD(INDI/IPOW10,1024) - NI=IBITS(INDI,0,10) - NJ=IBITS(INDI,10,10) - NSIJ=MUL(NSM(NI),NSM(NJ)) - CALL IPO_CPF(IPOF,NVIR,MUL,NSYM,NSIJ,-1) - IJ1=IROW(NI)+NJ - ILIM=IPOF(NSYM+1) - CALL FZERO(ABIJ,ILIM) - CALL FZERO(AIBJ,ILIM) - CALL FZERO(AJBI,ILIM) - IF(ITER.EQ.1)GO TO 207 -C READ (AB/IJ) INTEGRALS - IADR=LASTAD(NOVST+IJ1) - JTURN=0 -201 CALL iDAFILE(Lu_TiABIJ,2,IBUFIN,LBUF2,IADR) - LENGTH=IBUFIN(LBUF1) - IADR=IBUFIN(LBUF2) - IF(LENGTH.EQ.0)GO TO 209 - IF(JTURN.EQ.1)GO TO 203 - CALL SCATTER(LENGTH,ABIJ,IBUFIN(LBUF0+1),BUFIN) - GO TO 209 -203 CALL SCATTER(LENGTH,AIBJ,IBUFIN(LBUF0+1),BUFIN) -209 IF(IADR.EQ.-1) GO TO 206 - GO TO 201 -206 IF(JTURN.EQ.1)GO TO 360 -C READ (AI/BJ) INTEGRALS -207 IADR=LASTAD(NOVST+NOT2+IJ1) - JTURN=1 - GO TO 201 -C CONSTRUCT FIRST ORDER MATRICES -360 FAC=D1/D2 - IF(NI.NE.NJ)FAC=D2*FAC - IN=0 - IFT=0 - CALL IPO_CPF(IPOA,NVIR,MUL,NSYM,NSIJ,IFT) -852 DO 170 IASYM=1,NSYM - IBSYM=MUL(NSIJ,IASYM) - IF(IBSYM.GT.IASYM)GO TO 170 - IAB=IPOA(IASYM+1)-IPOA(IASYM) - IF(IAB.EQ.0)GO TO 170 - CALL SECORD(AIBJ(IPOF(IASYM)+1),AIBJ(IPOF(IBSYM)+1), - *FSEC(IN+1),FAC,NVIR(IASYM),NVIR(IBSYM),NSIJ,IFT) - IN=IN+IAB -170 CONTINUE - IF(IFT.EQ.1)GO TO 853 - INS=IN - IFT=1 - FAC=D0 - GO TO 852 -C SQARE ABIJ -853 IF(ITER.EQ.1)GO TO 260 - DO 370 IASYM=1,NSYM - IF(NVIR(IASYM).EQ.0)GO TO 370 - IBSYM=MUL(NSIJ,IASYM) - IF(NVIR(IBSYM).EQ.0)GO TO 370 - IPF=IPOF(IASYM)+1 - IPF1=IPOF(IBSYM)+1 - IF(IASYM.GT.IBSYM)GO TO 369 - IF(NSIJ.NE.1)GO TO 361 - CALL SQUAR2_CPF(ABIJ(IPF),NVIR(IASYM)) - IF(NI.NE.NJ)GO TO 368 - CALL SQUAR2_CPF(AIBJ(IPF),NVIR(IASYM)) -368 CALL MTRANS_CPF(AIBJ(IPF),AJBI(IPF),NVIR(IASYM),NVIR(IBSYM)) - GO TO 370 -361 CALL MTRANS_CPF(ABIJ(IPF1),ABIJ(IPF),NVIR(IASYM),NVIR(IBSYM)) -369 CALL MTRANS_CPF(AIBJ(IPF1),AJBI(IPF),NVIR(IASYM),NVIR(IBSYM)) -370 CONTINUE - GO TO 260 -371 IF(IFAB.EQ.1)GO TO 262 -CPAM97 IFAB=IAND(IND,1) -CPAM97 ITURN=IAND(ISHFT(IND,-1),1) -CPAM97 ITYP=IAND(ISHFT(IND,-2),7) -CPAM97 ICOUP=IAND(ISHFT(IND,-5),8191) -CPAM97 ICOUP1=IAND(ISHFT(IND,-18),8191) -* IFAB=MOD(IND,2) -* ITURN=MOD(IND/2,2) -* ITYP=MOD(IND/4,8) -* ICOUP=MOD(IND/IPOW5,8192) -* ICOUP1=MOD(IND/IPOW18,8192) - IFAB=IBITS(IND, 0,1) - ITURN=IBITS(IND,1,1) - ITYP=IBITS(IND,2,3) - ICOUP=IBITS(IND,5,13 ) - ICOUP1=IBITS(IND,18,13 ) - CPL=COP(II) - CPLA=D0 - IF(IFAB.NE.0)GO TO 260 - IF(ITURN.EQ.0)GO TO 263 - GO TO 100 -262 CPLA=COP(II) - IFAB=0 - GO TO 100 -C FIRST ORDER INTERACTION -263 INDA=ICOUP - INDB=IRC(ITYP+1)+ICOUP1 - ISTAR=1 - IF(ITYP.EQ.1)ISTAR=INS+1 - IF(INS.EQ.0)GO TO 260 - IF(INDA.NE.IREF0)GO TO 342 - CPLL=CPL/SQRT(ENP(INDB)) - CALL DAXPY_(INS,CPLL,FSEC(ISTAR),1,S(INDEX(INDB)+1),1) - IF(ITER.EQ.1)GO TO 260 - TERM=DDOT_(INS,C(INDEX(INDB)+1),1,FSEC(ISTAR),1) - EPP(INDB)=EPP(INDB)+CPLL*TERM - GO TO 260 -342 FACS=D1 - COPI=CPL*C(INDA) - CALL DAXPY_(INS,COPI*FACS,FSEC(ISTAR),1,S(INDEX(INDB)+1),1) - TERM=DDOT_(INS,FSEC(ISTAR),1,C(INDEX(INDB)+1),1) - S(INDA)=S(INDA)+CPL*FACS*TERM - GO TO 260 -C INTERACTIONS BETWEEN DOUBLES AND -C INTERACTIONS BETWEEN SINGLES -100 IF(ITER.EQ.1)GO TO 260 -C CALL JTIME(IST) - IFTA=0 - IFTB=0 - GO TO (109,110,111,112,113),ITYP -109 INDA=IRC(2)+ICOUP1 - INDB=IRC(2)+ICOUP - IFTA=1 - IFTB=1 - GO TO 115 -110 INDA=IRC(3)+ICOUP1 - INDB=IRC(3)+ICOUP - GO TO 115 -111 INDA=IRC(2)+ICOUP1 - INDB=IRC(3)+ICOUP - IFTA=1 - GO TO 115 -112 INDA=IRC(3)+ICOUP1 - INDB=IRC(2)+ICOUP - IFTB=1 - GO TO 115 -113 INDA=IRC(1)+ICOUP1 - INDB=IRC(1)+ICOUP -115 MYSYM=JSUNP_CPF(JSY,INDA) -c JSYM(L)=JSUNP_CPF(JSY,L) - - NYSYM=MUL(MYSYM,NSIJ) - MYL=MUL(MYSYM,LSYM) - NYL=MUL(NYSYM,LSYM) - FACS=D1 - CALL IPO_CPF(IPOA,NVIR,MUL,NSYM,MYL,IFTA) - CALL IPO_CPF(IPOB,NVIR,MUL,NSYM,NYL,IFTB) - INMY=INDEX(INDA)+1 - INNY=INDEX(INDB)+1 - IF(ITYP.NE.5)GO TO 71 -C DOUBLET-DOUBLET INTERACTIONS - IN=IPOF(MYL+1)-IPOF(MYL) - IF(IN.EQ.0)GO TO 260 - IPF=IPOF(MYL)+1 - CALL SETZ(F,IN) - CALL DAXPY_(IN,CPL,AIBJ(IPF),1,F,1) - CALL DAXPY_(IN,CPLA,ABIJ(IPF),1,F,1) - IF(INDA.EQ.INDB)CALL SETZZ_CPF(F,NVIR(MYL)) - CALL SETZ(A,NVIR(NYL)) - CALL FMMM(C(INMY),F,A,1,NVIR(NYL),NVIR(MYL)) - CALL DAXPY_(NVIR(NYL),FACS,A,1,S(INNY),1) - IF(INDA.EQ.INDB)GO TO 260 - CALL SETZ(A,NVIR(MYL)) - CALL FMMM(F,C(INNY),A,NVIR(MYL),1,NVIR(NYL)) - CALL DAXPY_(NVIR(MYL),FACS,A,1,S(INMY),1) - GO TO 260 -C TRIPLET-SINGLET , SINGLET-TRIPLET , -C TRIPLET-TRIPLET AND SINGLET-SINGLET INTERACTIONS -71 DO 70 IASYM=1,NSYM - IAB=IPOF(IASYM+1)-IPOF(IASYM) - IF(IAB.EQ.0)GO TO 70 - ICSYM=MUL(MYL,IASYM) - IBSYM=MUL(NYL,ICSYM) - IF(INDA.EQ.INDB.AND.IBSYM.GT.IASYM)GO TO 70 - IF(NVIR(ICSYM).EQ.0)GO TO 70 - NAC=NVIR(IASYM)*NVIR(ICSYM) - NBC=NVIR(IBSYM)*NVIR(ICSYM) - IF(ICSYM.GE.IASYM)GO TO 31 - IF(ICSYM.GE.IBSYM)GO TO 32 -C CASE 1 , IASYM > ICSYM AND IBSYM > ICSYM - IPF=IPOF(IASYM)+1 - CALL SETZ(F,IAB) - CALL DAXPY_(IAB,CPL,AIBJ(IPF),1,F,1) - CALL DAXPY_(IAB,CPLA,ABIJ(IPF),1,F,1) - IF(INDA.EQ.INDB)CALL SETZZ_CPF(F,NVIR(IASYM)) - CALL SETZ(A,NBC) - CALL FMMM(C(INMY+IPOA(IASYM)),F,A,NVIR(ICSYM), - *NVIR(IBSYM),NVIR(IASYM)) - CALL DAXPY_(NBC,FACS,A,1,S(INNY+IPOB(IBSYM)),1) - IF(INDA.EQ.INDB)GO TO 70 - IPF=IPOF(IBSYM)+1 - CALL SETZ(F,IAB) - CALL DAXPY_(IAB,CPL,AJBI(IPF),1,F,1) - CALL DAXPY_(IAB,CPLA,ABIJ(IPF),1,F,1) - CALL SETZ(A,NAC) - CALL FMMM(C(INNY+IPOB(IBSYM)),F,A,NVIR(ICSYM), - *NVIR(IASYM),NVIR(IBSYM)) - CALL DAXPY_(NAC,FACS,A,1,S(INMY+IPOA(IASYM)),1) - GO TO 70 -C CASE 2 , IASYM > ICSYM AND ICSYM > OR = IBSYM -32 IPF=IPOF(IBSYM)+1 - CALL SETZ(F,IAB) - CALL DAXPY_(IAB,CPL,AJBI(IPF),1,F,1) - CALL DAXPY_(IAB,CPLA,ABIJ(IPF),1,F,1) - CALL MTRANS_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM),NVIR(ICSYM)) - CALL SETZ(B,NBC) - CALL FMMM(F,A,B,NVIR(IBSYM),NVIR(ICSYM),NVIR(IASYM)) - IF(NYL.NE.1)GO TO 35 - CALL SETZ(A,NBC) - CALL DAXPY_(NBC,FACS,B,1,A,1) - IF(IFTB.EQ.1)GO TO 134 - CALL SIADD_CPF(A,S(INNY+IPOB(ICSYM)),NVIR(IBSYM)) - CALL SETZ(A,NBC) - CALL SQUAR_CPF(C(INNY+IPOB(IBSYM)),A,NVIR(IBSYM)) - GO TO 36 -134 CALL TRADD_CPF(A,S(INNY+IPOB(ICSYM)),NVIR(IBSYM)) - CALL SETZ(A,NBC) - CALL SQUARN_CPF(C(INNY+IPOB(IBSYM)),A,NVIR(IBSYM)) - GO TO 36 -35 IF(IFTB.EQ.1)GO TO 135 - CALL DAXPY_(NBC,FACS,B,1,S(INNY+IPOB(ICSYM)),1) - GO TO 136 -135 CALL DAXPY_(NBC,-FACS,B,1,S(INNY+IPOB(ICSYM)),1) -136 CALL MTRANS_CPF(C(INNY+IPOB(ICSYM)),A,NVIR(ICSYM),NVIR(IBSYM)) - IF(IFTB.EQ.1)CALL VNEG_CPF(A,1,A,1,NBC) -36 CALL SETZ(B,NAC) - CALL FMMM(A,F,B,NVIR(ICSYM),NVIR(IASYM),NVIR(IBSYM)) - CALL DAXPY_(NAC,FACS,B,1,S(INMY+IPOA(IASYM)),1) - GO TO 70 -31 IF(ICSYM.GE.IBSYM)GO TO 33 -C CASE 3 , ICSYM > OR = IASYM AND IBSYM > ICSYM - IPF=IPOF(IASYM)+1 - CALL SETZ(F,IAB) - CALL DAXPY_(IAB,CPL,AIBJ(IPF),1,F,1) - CALL DAXPY_(IAB,CPLA,ABIJ(IPF),1,F,1) - IF(MYL.NE.1)GO TO 39 - IF(IFTA.EQ.0)CALL SQUAR_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) - IF(IFTA.EQ.1)CALL SQUARN_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) - GO TO 40 -39 CALL MTRANS_CPF(C(INMY+IPOA(ICSYM)),A,NVIR(ICSYM),NVIR(IASYM)) - IF(IFTA.EQ.1)CALL VNEG_CPF(A,1,A,1,NAC) -40 CALL SETZ(B,NBC) - CALL FMMM(A,F,B,NVIR(ICSYM),NVIR(IBSYM),NVIR(IASYM)) - CALL DAXPY_(NBC,FACS,B,1,S(INNY+IPOB(IBSYM)),1) - CALL MTRANS_CPF(C(INNY+IPOB(IBSYM)),A,NVIR(IBSYM),NVIR(ICSYM)) - CALL SETZ(B,NAC) - CALL FMMM(F,A,B,NVIR(IASYM),NVIR(ICSYM),NVIR(IBSYM)) - IF(MYL.NE.1)GO TO 46 - CALL SETZ(A,NAC) - CALL DAXPY_(NAC,FACS,B,1,A,1) - IF(IFTA.EQ.1)GO TO 146 - CALL SIADD_CPF(A,S(INMY+IPOA(IASYM)),NVIR(IASYM)) - CALL SETZ(A,NAC) - GO TO 70 -146 CALL TRADD_CPF(A,S(INMY+IPOA(IASYM)),NVIR(IASYM)) - CALL SETZ(A,NAC) - GO TO 70 -46 IF(IFTA.EQ.1)GO TO 1146 - CALL DAXPY_(NAC,FACS,B,1,S(INMY+IPOA(ICSYM)),1) - GO TO 70 -1146 CALL DAXPY_(NAC,-FACS,B,1,S(INMY+IPOA(ICSYM)),1) - GO TO 70 -C CASE 4 , ICSYM > OR = IASYM AND ICSYM > OR = IBSYM -33 IPF=IPOF(IBSYM)+1 - CALL SETZ(F,IAB) - CALL DAXPY_(IAB,CPL,AJBI(IPF),1,F,1) - CALL DAXPY_(IAB,CPLA,ABIJ(IPF),1,F,1) - IF(INDA.EQ.INDB)CALL SETZZ_CPF(F,NVIR(IASYM)) - IF(MYL.NE.1)GO TO 41 - IF(IFTA.EQ.0)CALL SQUAR_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) - IF(IFTA.EQ.1)CALL SQUARM_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) - GO TO 42 -41 IF(IFTA.EQ.0)CALL DCOPY_(NAC,C(INMY+IPOA(ICSYM)),1,A,1) - IF(IFTA.EQ.1)CALL VNEG_CPF(C(INMY+IPOA(ICSYM)),1,A,1,NAC) -42 CALL SETZ(B,NBC) - CALL FMMM(F,A,B,NVIR(IBSYM),NVIR(ICSYM),NVIR(IASYM)) - IF(NYL.NE.1)GO TO 43 - CALL SETZ(A,NBC) - CALL DAXPY_(NBC,FACS,B,1,A,1) - IF(IFTB.EQ.1)GO TO 143 - CALL SIADD_CPF(A,S(INNY+IPOB(ICSYM)),NVIR(IBSYM)) - CALL SETZ(A,NBC) - GO TO 44 -143 CALL TRADD_CPF(A,S(INNY+IPOB(ICSYM)),NVIR(IBSYM)) - CALL SETZ(A,NBC) - GO TO 44 -43 IF(IFTB.EQ.1)GO TO 144 - CALL DAXPY_(NBC,FACS,B,1,S(INNY+IPOB(ICSYM)),1) - GO TO 44 -144 CALL DAXPY_(NBC,-FACS,B,1,S(INNY+IPOB(ICSYM)),1) -44 IF(INDA.EQ.INDB)GO TO 70 - IPF=IPOF(IASYM)+1 - CALL SETZ(F,IAB) - CALL DAXPY_(IAB,CPL,AIBJ(IPF),1,F,1) - CALL DAXPY_(IAB,CPLA,ABIJ(IPF),1,F,1) - IF(NYL.NE.1)GO TO 37 - IF(IFTB.EQ.0)CALL SQUAR_CPF(C(INNY+IPOB(IBSYM)),A,NVIR(IBSYM)) - IF(IFTB.EQ.1)CALL SQUARM_CPF(C(INNY+IPOB(IBSYM)),A,NVIR(IBSYM)) - GO TO 38 -37 IF(IFTB.EQ.0)CALL DCOPY_(NBC,C(INNY+IPOB(ICSYM)),1,A,1) - IF(IFTB.EQ.1)CALL VNEG_CPF(C(INNY+IPOB(ICSYM)),1,A,1,NBC) -38 CALL SETZ(B,NAC) - CALL FMMM(F,A,B,NVIR(IASYM),NVIR(ICSYM),NVIR(IBSYM)) - IF(MYL.NE.1)GO TO 45 - CALL SETZ(A,NAC) - CALL DAXPY_(NAC,FACS,B,1,A,1) - IF(IFTA.EQ.1)GO TO 145 - CALL SIADD_CPF(A,S(INMY+IPOA(ICSYM)),NVIR(IASYM)) -C CALL SETZ(A,NAC) - GO TO 70 -145 CALL TRADD_CPF(A,S(INMY+IPOA(ICSYM)),NVIR(IASYM)) -C CALL SETZ(A,NAC) - GO TO 70 -45 IF(IFTA.EQ.1)GO TO 147 - CALL DAXPY_(NAC,FACS,B,1,S(INMY+IPOA(ICSYM)),1) - GO TO 70 -147 CALL DAXPY_(NAC,-FACS,B,1,S(INMY+IPOA(ICSYM)),1) -70 CONTINUE -260 CONTINUE - GO TO 300 -350 CALL DSQ2(C,S,MUL,INDEX,JSY,NDIAG,INUM,IRC(3), - *LSYM,NVIRT,SQ2) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/fij_cpf.F90 openmolcas-22.10/src/cpf/fij_cpf.F90 --- openmolcas-22.02/src/cpf/fij_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/fij_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,121 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine FIJ_CPF(ICASE,JSY,INDX,C,S,FC,A,B,FK,DBK,ENP,EPP) + +use cpf_global, only: IDENS, IRC, IREF0, IROW, ITER, IV0, LSYM, Lu_25, Lu_CIGuga, NNS, NORBT, NVIR +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Definitions, only: wp, iwp, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: ICASE(*), JSY(*), INDX(*) +real(kind=wp), intent(inout) :: C(*), S(*), FC(*), FK(*), EPP(*) +real(kind=wp), intent(_OUT_) :: A(*), B(*), DBK(*) +real(kind=wp), intent(in) :: ENP(*) +integer(kind=iwp) :: IADD10, IADD25, IC1, IC2, ICHK, IIN, IK, ILEN, IND, INDA, INDB, INDI, INUM, IVL, NA, NB, NI, NK, NOB2, NS1, & + NS1L +real(kind=wp) :: COPI, TERM +integer(kind=iwp), external :: JSUNP +real(kind=r8), external :: DDOT_ + +IK = 0 ! dummy initialize +NOB2 = IROW(NORBT+1) +!if (IDENS == 1) write(u6,876) (FC(I),I=1,NOB2) +ICHK = 0 +if (IDENS /= 1) then + NOB2 = IROW(NORBT+1) + IADD25 = 0 + call dDAFILE(Lu_25,2,FC,NOB2,IADD25) +end if +if ((IDENS == 1) .or. (ITER /= 1)) then + IADD10 = IAD10(8) + do + call dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) + call iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN == 0) cycle + if (ILEN < 0) exit + do IIN=1,ILEN + IND = ICOP1(IIN) + if (ICHK == 0) then + if (IND /= 0) then + IVL = ibits(IND,0,6) + IC2 = ibits(IND,6,13) + IC1 = ibits(IND,19,13) + COPI = COP(IIN)*FC(IK) + if (IVL == IV0) then + if (IC1 == IREF0) then + if (IDENS /= 1) then + COPI = COPI/sqrt(ENP(IC2)) + S(IC2) = S(IC2)+COPI + if (ITER /= 1) EPP(IC2) = EPP(IC2)+COPI*C(IC2) + else + FC(IK) = FC(IK)+COP(IIN)*C(IC1)*C(IC2)/ENP(IC2) + end if + else if (IC2 == IREF0) then + if (IDENS /= 1) then + COPI = COPI/sqrt(ENP(IC1)) + S(IC1) = S(IC1)+COPI + if (ITER /= 1) EPP(IC1) = EPP(IC1)+COPI*C(IC1) + else + FC(IK) = FC(IK)+COP(IIN)*C(IC1)*C(IC2)/ENP(IC1) + end if + else if (IDENS /= 1) then + S(IC1) = S(IC1)+COPI*C(IC2) + S(IC2) = S(IC2)+COPI*C(IC1) + else + FC(IK) = FC(IK)+COP(IIN)*C(IC1)*C(IC2)/(sqrt(ENP(IC1))*sqrt(ENP(IC2))) + end if + else + INDA = IRC(IVL)+IC1 + INDB = IRC(IVL)+IC2 + NA = INDX(INDA) + NB = INDX(INDB) + NS1 = JSUNP(JSY,INDA) + NS1L = MUL(NS1,LSYM) + INUM = NVIR(NS1L) + if (IVL >= 2) INUM = NNS(NS1L) + if (IDENS /= 1) then + S(NA+1:NA+INUM) = S(NA+1:NA+INUM)+COPI*C(NB+1:NB+INUM) + S(NB+1:NB+INUM) = S(NB+1:NB+INUM)+COPI*C(NA+1:NA+INUM) + else + TERM = DDOT_(INUM,C(NA+1),1,C(NB+1),1) + FC(IK) = FC(IK)+COP(IIN)*TERM/(sqrt(ENP(INDA))*sqrt(ENP(INDB))) + end if + end if + else + ICHK = 1 + end if + else + ICHK = 0 + INDI = IND + NI = ibits(INDI,0,10) + NK = ibits(INDI,10,10) + IK = IROW(NK)+NI + end if + end do + end do +end if +!if (IDENS == 1) write(u6,876) (FC(I),I=1,NOB2) +call AI_CPF(JSY,INDX,C,S,FC,C,A,B,FK,DBK,ENP,EPP,0) +if (ITER /= 1) call AB_CPF(ICASE,JSY,INDX,C,S,FC,A,B,FK,ENP) + +return + +!876 format(1X,'FIJ',5F12.6) + +end subroutine FIJ_CPF diff -Nru openmolcas-22.02/src/cpf/fij.f openmolcas-22.10/src/cpf/fij.f --- openmolcas-22.02/src/cpf/fij.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/fij.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,128 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ -cpgi$g opt=1 - SUBROUTINE FIJ(ICASE,JSY,INDEX,C,S,FC,A,B,FK,DBK,ENP, - *EPP) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" - DIMENSION JSY(*),INDEX(*),C(*),S(*),FC(*),A(*),B(*), - & FK(*),DBK(*),ENP(*),EPP(*) - DIMENSION ICASE(*) - PARAMETER (IPOW6=2**6, IPOW10=2**10, IPOW19=2**19) -* - JSYM(L)=JSUNP_CPF(JSY,L) -* - IK = 0 ! dummy initialize - NOB2=IROW(NORBT+1) -C IF(IDENS.EQ.1)WRITE(6,876)(FC(I),I=1,NOB2) -C 876 FORMAT(1X,'FIJ',5F12.6) - ICHK=0 - IF(IDENS.EQ.1)GO TO 105 - NOB2=IROW(NORBT+1) - CALL SETZ(FC,NOB2) - IADD25=0 - CALL dDAFILE(Lu_25,2,FC,NOB2,IADD25) - IF(ITER.EQ.1)GO TO 200 -105 IADD10=IAD10(8) -100 CALL dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) - CALL iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.EQ.0)GO TO 100 - IF(LEN.LT.0)GO TO 200 - DO 10 IN=1,LEN - IND=ICOP1(IN) - IF(ICHK.NE.0)GO TO 460 - IF(IND.NE.0)GO TO 11 - ICHK=1 - GO TO 10 -460 ICHK=0 - INDI=IND -* NI=MOD(INDI,1024) -* NK=MOD(INDI/IPOW10,1024) - NI=IBITS(INDI,0,10) - NK=IBITS(INDI,10,10) - IK=IROW(NK)+NI - GO TO 10 -11 CONTINUE -* IVL=MOD(IND,64) -* IC2=MOD(IND/IPOW6,8192) -* IC1=MOD(IND/IPOW19,8192) - IVL=IBITS(IND, 0, 6) - IC2=IBITS(IND,6,13 ) - IC1=IBITS(IND,19,13 ) - COPI=COP(IN)*FC(IK) - IF(IVL.NE.IV0)GO TO 13 - IF(IC1.NE.IREF0)GO TO 16 - IF(IDENS.EQ.1)GO TO 18 - COPI=COPI/SQRT(ENP(IC2)) - S(IC2)=S(IC2)+COPI - IF(ITER.EQ.1)GO TO 10 - EPP(IC2)=EPP(IC2)+COPI*C(IC2) - GO TO 10 -18 FC(IK)=FC(IK)+COP(IN)*C(IC1)*C(IC2)/ENP(IC2) - GO TO 10 -16 IF(IC2.NE.IREF0)GO TO 17 - IF(IDENS.EQ.1)GO TO 19 - COPI=COPI/SQRT(ENP(IC1)) - S(IC1)=S(IC1)+COPI - IF(ITER.EQ.1)GO TO 10 - EPP(IC1)=EPP(IC1)+COPI*C(IC1) - GO TO 10 -19 FC(IK)=FC(IK)+COP(IN)*C(IC1)*C(IC2)/ENP(IC1) - GO TO 10 -17 IF(IDENS.EQ.1)GO TO 21 - FACS=D1 - S(IC1)=S(IC1)+FACS*COPI*C(IC2) - S(IC2)=S(IC2)+FACS*COPI*C(IC1) - GO TO 10 -21 FC(IK)=FC(IK)+COP(IN)*C(IC1)*C(IC2)/ - *(SQRT(ENP(IC1))*SQRT(ENP(IC2))) - GO TO 10 -13 INDA=IRC(IVL)+IC1 - INDB=IRC(IVL)+IC2 - NA=INDEX(INDA) - NB=INDEX(INDB) - NS1=JSYM(INDA) - NS1L=MUL(NS1,LSYM) - INUM=NVIR(NS1L) - IF(IVL.GE.2)INUM=NNS(NS1L) - IF(IDENS.EQ.1)GO TO 15 - FACS=D1 - CALL DAXPY_(INUM,COPI*FACS,C(NB+1),1,S(NA+1),1) - CALL DAXPY_(INUM,COPI*FACS,C(NA+1),1,S(NB+1),1) - GO TO 10 -15 TERM=DDOT_(INUM,C(NA+1),1,C(NB+1),1) - FC(IK)=FC(IK)+COP(IN)*TERM/(SQRT(ENP(INDA))*SQRT(ENP(INDB))) -10 CONTINUE - GO TO 100 -C 200 IF(IDENS.EQ.1)WRITE(6,876)(FC(I),I=1,NOB2) -200 CALL dAI_CPF(C) - IF(ITER.EQ.1)RETURN - CALL AB(ICASE,JSY,INDEX,C,S,FC,A,B,FK,ENP) - RETURN -* -* This is to allow type punning without an explicit interface - CONTAINS - SUBROUTINE dAI_CPF(C) - USE ISO_C_BINDING - REAL*8, TARGET :: C(*) - INTEGER, POINTER :: iC(:) - CALL C_F_POINTER(C_LOC(C(1)),iC,[1]) - CALL AI_CPF(JSY,INDEX,C,S,FC,C,iC,A,B,FK,DBK,ENP,EPP,0) - NULLIFY(iC) - END SUBROUTINE dAI_CPF -* - END diff -Nru openmolcas-22.02/src/cpf/files_cpf.fh openmolcas-22.10/src/cpf/files_cpf.fh --- openmolcas-22.02/src/cpf/files_cpf.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/files_cpf.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ -C -C UNITS USED IN THE PROGRAM -C UNIT 5 , INPUT -C UNIT 6 , OUTPUT -C UNIT 10 , SYMBOLIC FORMULAS -C Lu_CIGuga -C UNIT 50 , TRANSFORMED MO 2-EL INTEGRALS -C Lu_TraInt -C UNIT 60 , SORTED AIBJ, ABIJ AND AIJK INTEGRALS -C Lu_TiABIJ -C UNIT 70 , SORTED IJKL AND ABCI INTEGRALS -C Lu_TiABCI -C UNIT 80 , SORTED ABCD INTEGRALS -C Lu_TiABCD -C UNIT 17 , ONE ELECTRON INTEGRALS -C Lu_TraOne -C UNIT 19 , (Formatted sequential!) CPF-ORBITALS OUT -C Lu_CPFORB -C UNIT 25 , FOCK MATRIX AND DIAGONAL CSF MATRIX ELEMENTS -C Lu_25 -C UNIT 26 , CI VECTOR -C Lu_CI -C UNIT 27 , SCRATCH IN IIJJ -C Lu_27 -C UNIT 30 , -C Lu_30 -C - Common /files_cpf/ Lu_CIGuga, Lu_TraInt, Lu_TraOne, - & Lu_CI, Lu_TiABIJ, Lu_TiABCI, - & Lu_TiABCD, Lu_25, Lu_27, - & Lu_30, Lu_CPFORB diff -Nru openmolcas-22.02/src/cpf/fmul2.f openmolcas-22.10/src/cpf/fmul2.f --- openmolcas-22.02/src/cpf/fmul2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/fmul2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,49 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE FMUL2_CPF(A,B,C,NROW,NCOL,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(NROW,N),B(NCOL,N),CJ(200) - DIMENSION C(NROW,NCOL) - - If ( nRow.gt.200 ) then - WRITE(6,*) - CALL XFLUSH(6) - WRITE(6,*) ' *** Error in Subroutine FMUL2_CPF ***' - CALL XFLUSH(6) - WRITE(6,*) ' row dimension exceeds local buffer size' - CALL XFLUSH(6) - WRITE(6,*) - CALL XFLUSH(6) - CALL Abend - End If - - DO 10 J=1,NCOL - DO 15 I=1,NROW - CJ(I)=0.0D0 -15 CONTINUE - IF(J.EQ.NCOL)GO TO 16 - J1=J+1 - DO 20 K=1,N - FAC=B(J,K) - IF(FAC.EQ.0.0)GO TO 20 - DO 25 I=J1,NROW - CJ(I)=CJ(I)+FAC*A(I,K) -25 CONTINUE -20 CONTINUE -16 DO 30 I=1,NROW - C(I,J)=CJ(I) -30 CONTINUE -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/ifock.f openmolcas-22.10/src/cpf/ifock.f --- openmolcas-22.02/src/cpf/ifock.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/ifock.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,26 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE IFOCK(FC,NI,NJ,NK,FINI,II) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION FC(*) - IF(NI.GT.0)RETURN - IF(NJ.LE.0.OR.NK.LE.0)RETURN - JKPOS=NJ*(NJ-1)/2+NK - IF(NK.GT.NJ)JKPOS=NK*(NK-1)/2+NJ - IF(II.EQ.0)GO TO 10 - FC(JKPOS)=FC(JKPOS)+FINI+FINI - RETURN -10 FC(JKPOS)=FC(JKPOS)-FINI - RETURN - END diff -Nru openmolcas-22.02/src/cpf/ifock.F90 openmolcas-22.10/src/cpf/ifock.F90 --- openmolcas-22.02/src/cpf/ifock.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/ifock.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,40 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine IFOCK(FC,NI,NJ,NK,FINI,II) + +use Constants, only: Two +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +real(kind=wp), intent(_OUT_) :: FC(*) +integer(kind=iwp), intent(in) :: NI, NJ, NK, II +real(kind=wp), intent(in) :: FINI +integer(kind=iwp) :: JKPOS + +if (NI > 0) return +if ((NJ <= 0) .or. (NK <= 0)) return +JKPOS = NJ*(NJ-1)/2+NK +if (NK > NJ) JKPOS = NK*(NK-1)/2+NJ +if (II /= 0) then + FC(JKPOS) = FC(JKPOS)+Two*FINI +else + FC(JKPOS) = FC(JKPOS)-FINI +end if + +return + +end subroutine IFOCK diff -Nru openmolcas-22.02/src/cpf/iijj_cpf.F90 openmolcas-22.10/src/cpf/iijj_cpf.F90 --- openmolcas-22.02/src/cpf/iijj_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/iijj_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,119 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine IIJJ_CPF(ICASE,JSY,HDIAG,FC,FIJ,FJI) + +use cpf_global, only: ILIM, IRC, IROW, LN, LSYM, Lu_27, NSM, NSYS, NVIRT +use Symmetry_Info, only: Mul +use Constants, only: Zero +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: ICASE(*), JSY(*) +real(kind=wp), intent(_OUT_) :: HDIAG(*) +real(kind=wp), intent(in) :: FC(*), FIJ(*), FJI(*) +integer(kind=iwp) :: I, IA, IAD27, IAV, IB, IBV, II, IJ, IND, IOC(55), IR, IRL, J, JOJ, NA, NA1, NA2, NB, NB1, NB2, NSA, NSS +real(kind=wp) :: SUM1, SUM2, TERM +integer(kind=iwp), external :: ICUNP, JSUNP + +IAD27 = 0 +IRL = IRC(ILIM) + +do IR=1,IRL + do I=1,LN + JOJ = ICUNP(ICASE,I+LN*(IR-1)) + IOC(I) = (JOJ+1)/2 + end do + NSS = MUL(JSUNP(JSY,IR),LSYM) + + SUM1 = Zero + do I=1,LN + if (IOC(I) /= 0) then + do J=1,I-1 + IJ = (I*(I-1))/2+J + if (IOC(J) /= 0) then + TERM = IOC(I)*(IOC(J)*FIJ(IJ)-FJI(IJ)) + SUM1 = SUM1+TERM + end if + end do + II = (I*(I+1))/2 + TERM = (IOC(I)-1)*FIJ(II)+IOC(I)*FC(II) + SUM1 = SUM1+TERM + end if + end do + + if (IR <= IRC(1)) then + + ! IR=1..IRC(1), HDIAG(IR)=SUM1 + HDIAG(IR) = SUM1 + if (IR == IRC(1)) call dDAFILE(Lu_27,1,HDIAG,IRC(1),IAD27) + + else if (IR <= IRC(2)) then + + ! IR=IRC(1)+1 ... IRC(2) + IND = 0 + NA1 = NSYS(NSS)+1 + NA2 = NSYS(NSS+1) + if (NA2 >= NA1) then + do NA=NA1,NA2 + IND = IND+1 + IA = IROW(LN+NA) + SUM2 = SUM1+FC(IA+LN+NA) + do I=1,LN + if (IOC(I) /= 0) SUM2 = SUM2+IOC(I)*FIJ(IA+I)-FJI(IA+I) + end do + HDIAG(IND) = SUM2 + end do + call dDAFILE(Lu_27,1,HDIAG,IND,IAD27) + end if + + else + + ! IR=IRC(2)+1 ... IRC(ILIM) + IND = 0 + do NA=1,NVIRT + NSA = MUL(NSS,NSM(LN+NA)) + NB1 = NSYS(NSA)+1 + NB2 = NSYS(NSA+1) + if (NB2 > NA) NB2 = NA + if (NB2 >= NB1) then + IA = IROW(LN+NA) + IAV = IA+LN + do NB=NB1,NB2 + IND = IND+1 + IB = IROW(LN+NB) + IBV = IB+LN + TERM = SUM1+FIJ(IAV+NB)+FC(IAV+NA)+FC(IBV+NB) + if (IR <= IRC(3)) SUM2 = TERM-FJI(IAV+NB) + if (IR > IRC(3)) SUM2 = TERM+FJI(IAV+NB) + do I=1,LN + if (IOC(I) /= 0) then + TERM = IOC(I)*(FIJ(IA+I)+FIJ(IB+I))-FJI(IA+I)-FJI(IB+I) + SUM2 = SUM2+TERM + end if + end do + HDIAG(IND) = SUM2 + end do + end if + end do + if (IND > 0) call dDAFILE(Lu_27,1,HDIAG,IND,IAD27) + + end if +end do + +return + +end subroutine IIJJ_CPF diff -Nru openmolcas-22.02/src/cpf/iijj.f openmolcas-22.10/src/cpf/iijj.f --- openmolcas-22.02/src/cpf/iijj.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/iijj.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,111 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE IIJJ_CPF(ICASE,JSY,HDIAG,FC,FIJ,FJI) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" - DIMENSION JSY(*),HDIAG(*),FC(*),FIJ(*),FJI(*) - DIMENSION ICASE(*) - DIMENSION IOC(55) -* - JO(L)=ICUNP(ICASE,L) - JSYM(L)=JSUNP_CPF(JSY,L) -* - IAD27=0 - ILIM=4 - IF(IFIRST.NE.0)ILIM=2 - IRL=IRC(ILIM) - - DO 100 IR=1,IRL - DO I=1,LN - JOJ=JO(I+LN*(IR-1)) - IOC(I)=(JOJ+1)/2 - END DO - NSS=MUL(JSYM(IR),LSYM) - - SUM=0.0D0 - DO I=1,LN - IF(IOC(I).NE.0) THEN - DO J=1,I-1 - IJ=(I*(I-1))/2+J - IF(IOC(J).NE.0) THEN - TERM=IOC(I)*(IOC(J)*FIJ(IJ)-FJI(IJ)) - SUM=SUM+TERM - END IF - END DO - II=(I*(I+1))/2 - TERM=(IOC(I)-1)*FIJ(II)+IOC(I)*FC(II) - SUM=SUM+TERM - END IF - END DO - - IF(IR.GT.IRC(1))GO TO 120 -C IR=1..IRC(1), HDIAG(IR)=SUM - HDIAG(IR)=SUM - IF(IR.EQ.IRC(1))CALL dDAFILE(Lu_27,1,HDIAG,IRC(1),IAD27) - GO TO 100 - -120 CONTINUE - IF(IR.GT.IRC(2))GO TO 130 -C IR=IRC(1)+1 ... IRC(2) - IND=0 - NA1=NSYS(NSS)+1 - NA2=NSYS(NSS+1) - IF(NA2.LT.NA1)GO TO 100 - DO NA=NA1,NA2 - IND=IND+1 - IA=IROW(LN+NA) - SUM1=SUM+FC(IA+LN+NA) - DO I=1,LN - IF(IOC(I).NE.0) SUM1=SUM1+ - & IOC(I)*FIJ(IA+I)-FJI(IA+I) - END DO - HDIAG(IND)=SUM1 - END DO - CALL dDAFILE(Lu_27,1,HDIAG,IND,IAD27) - GO TO 100 - -130 CONTINUE -C IR=IRC(2)+1 ... IRC(ILIM) - IND=0 - DO NA=1,NVIRT - NSA=MUL(NSS,NSM(LN+NA)) - NB1=NSYS(NSA)+1 - NB2=NSYS(NSA+1) - IF(NB2.GT.NA)NB2=NA - IF(NB2.LT.NB1)GO TO 141 - IA=IROW(LN+NA) - IAV=IA+LN - DO NB=NB1,NB2 - IND=IND+1 - IB=IROW(LN+NB) - IBV=IB+LN - TERM=SUM+FIJ(IAV+NB)+FC(IAV+NA)+FC(IBV+NB) - IF(IR.LE.IRC(3))SUM1=TERM-FJI(IAV+NB) - IF(IR.GT.IRC(3))SUM1=TERM+FJI(IAV+NB) - DO I=1,LN - IF(IOC(I).NE.0) THEN - TERM=IOC(I)*(FIJ(IA+I)+FIJ(IB+I))-FJI(IA+I)-FJI(IB+I) - SUM1=SUM1+TERM - END IF - END DO - HDIAG(IND)=SUM1 - END DO -141 CONTINUE - END DO - IF(IND.GT.0)CALL dDAFILE(Lu_27,1,HDIAG,IND,IAD27) -100 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/ijij_cpf.F90 openmolcas-22.10/src/cpf/ijij_cpf.F90 --- openmolcas-22.02/src/cpf/ijij_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/ijij_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,200 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine IJIJ_CPF(JSY,HDIAG,FJI) + +use cpf_global, only: IAD25S, IRC, IREF0, IROW, IV0, IV1, LN, LSYM, Lu_25, Lu_27, Lu_CIGuga, NNS, NSM, NSYS, NVIR, NVIRT, POTNUC +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: JSY(*) +real(kind=wp), intent(_OUT_) :: HDIAG(*) +real(kind=wp), intent(in) :: FJI(*) +integer(kind=iwp) :: IAD27, IADD10, IADD25, ICHK, ICOUP, ICOUPS, IFS, II, IIJ, IIJ1, IIJ2, IJJ, INB, IND, INDI, INS, IOUT, ITYP, & + IVL, IVSAVE, J, JJ, KK, LENGTH, NA, NA1, NA2, NB, NB1, NB2, NSA, NSS +real(kind=wp) :: HCOUT(nCOP), TERM +integer(kind=iwp), external :: JSUNP + +ICOUP = 0 ! dummy initialize +IVL = 0 ! dummy initialize +NSS = 0 ! dummy initialize + +IADD25 = IAD25S +IAD27 = 0 +if (IREF0 > nCOP) then + write(u6,*) 'IJIJ_CPF Error: IREF0>nCOP (See code.)' +end if +call dDAFILE(Lu_27,2,HDIAG,IRC(1),IAD27) + +IFS = 0 +TERM = Zero +IVSAVE = 0 +ICOUPS = 0 +IOUT = 0 +ICHK = 0 +IADD10 = IAD10(3) + +do + ! Read a new COP buffer: + call dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) + call iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) + LENGTH = ICOP1(nCOP+1) + if (LENGTH == 0) cycle + if (LENGTH < 0) exit + ! A long loop over the COP buffer: + do II=1,LENGTH + IND = ICOP1(II) + if (ICHK == 0) then + if (IND /= 0) then + ITYP = ibits(IND,0,1) + IJJ = ibits(IND,1,11) + if (ITYP == 0) TERM = COP(II)*FJI(IJJ) + if (IVL == IV0) then + + ! IVL == IV0, Valence: + INB = ICOUP + HDIAG(INB) = HDIAG(INB)+TERM + + else if (IVL == IV1) then + + ! IVL == IV1, Singles: + INB = 0 + NA1 = NSYS(NSS)+1 + NA2 = NSYS(NSS+1) + do NA=NA1,NA2 + INB = INB+1 + if (ITYP /= 0) then + IIJ = IROW(LN+NA)+IJJ + TERM = COP(II)*FJI(IIJ) + end if + HDIAG(INB) = HDIAG(INB)+TERM + end do + + else + + INB = 0 + ! Doubles: + do NA=1,NVIRT + NSA = MUL(NSS,NSM(LN+NA)) + NB1 = NSYS(NSA)+1 + NB2 = NSYS(NSA+1) + if (NB2 > NA) NB2 = NA + if (NB2 >= NB1) then + IIJ1 = IROW(LN+NA)+IJJ + do NB=NB1,NB2 + INB = INB+1 + if (ITYP /= 0) then + IIJ2 = IROW(LN+NB)+IJJ + TERM = COP(II)*(FJI(IIJ1)+FJI(IIJ2)) + end if + HDIAG(INB) = HDIAG(INB)+TERM + end do + end if + end do + + end if + else + ICHK = 1 + end if + + else + + ICHK = 0 + INDI = IND + ICOUP = ibits(INDI,0,16) + IVL = ibits(INDI,16,8) + ICHK = 0 + INS = 1 + if (IVSAVE == IV0) then + INS = ICOUPS + INB = ICOUPS + end if + + if (INB > 0) then + ! Transfer HDIAG via buffer HCOUT, write it to unit 25: + do J=INS,INB + IOUT = IOUT+1 + HCOUT(IOUT) = HDIAG(J) + if (IOUT >= nCOP) then + ! Write out the filled HCOUT buffer: + if (IFS /= 1) then + POTNUC = HCOUT(IREF0) + IFS = 1 + end if + do KK=1,nCOP + HCOUT(KK) = HCOUT(KK)-POTNUC + end do + call dDAFILE(Lu_25,1,HCOUT,nCOP,IADD25) + IOUT = 0 + end if + end do + end if + + if (IVL /= IV0) then + JJ = IRC(IVL)+ICOUP + NSS = MUL(JSUNP(JSY,JJ),LSYM) + if (IVL == 1) INB = NVIR(NSS) + if (IVL > 1) INB = NNS(NSS) + if (INB > 0) call dDAFILE(Lu_27,2,HDIAG,INB,IAD27) + end if + IVSAVE = IVL + ICOUPS = ICOUP + + end if + end do +end do + +! Transfer remaining HDIAG elements to 25 via buffer HCOUT: +if (INB /= 0) then + + do J=1,INB + IOUT = IOUT+1 + HCOUT(IOUT) = HDIAG(J) + if (IOUT >= nCOP) then + ! Write out the filled HCOUT buffer: + if (IFS /= 1) then + POTNUC = HCOUT(IREF0) + IFS = 1 + end if + do KK=1,nCOP + HCOUT(KK) = HCOUT(KK)-POTNUC + end do + call dDAFILE(Lu_25,1,HCOUT,nCOP,IADD25) + IOUT = 0 + end if + end do + +end if + +! One last write of the HCOUT buffer: +if (IFS /= 1) then + POTNUC = HCOUT(IREF0) + IFS = 1 +end if +do KK=1,IOUT + HCOUT(KK) = HCOUT(KK)-POTNUC +end do +call dDAFILE(Lu_25,1,HCOUT,nCOP,IADD25) +write(u6,50) POTNUC + +return + +50 format(/,6X,'REFERENCE ENERGY',F18.8) + +end subroutine IJIJ_CPF diff -Nru openmolcas-22.02/src/cpf/ijij.f openmolcas-22.10/src/cpf/ijij.f --- openmolcas-22.02/src/cpf/ijij.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/ijij.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,196 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE IJIJ_CPF(JSY,HDIAG,FJI) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" - DIMENSION JSY(*),HDIAG(*),FJI(*) - DIMENSION HCOUT(nCOP) - JSYM(L)=JSUNP_CPF(JSY,L) -* -* - ICOUP = 0 ! dummy initialize - IVL = 0 ! dummy initialize - NSS = 0 ! dummy initialize -* - IADD25=IAD25S - IAD27=0 - IF(IREF0.GT.nCOP) THEN - WRITE(6,*)'IJIJ_CPF Error: IREF0>nCOP (See code.)' - END IF - CALL dDAFILE(Lu_27,2,HDIAG,IRC(1),IAD27) - - IFS=0 - TERM=0.0d0 - IVSAVE=0 - ICOUPS=0 - IOUT=0 - ICHK=0 - IADD10=IAD10(3) - -300 CONTINUE -C Read a new COP buffer: - 301 CONTINUE - CALL dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) - CALL iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) - LENGTH=ICOP1(nCOP+1) - IF(LENGTH.EQ.0)GO TO 301 - IF(LENGTH.LT.0)GO TO 350 -C A long loop over the COP buffer: - DO 360 II=1,LENGTH - IND=ICOP1(II) - IF(ICHK.EQ.0) THEN - IF(IND.NE.0)GO TO 361 - ICHK=1 - GO TO 360 - END IF - -C Here, if ICHK is 1. - ICHK=0 - INDI=IND -CPAM97 ICOUP=IAND(INDI,65535) -CPAM97 IVL=IAND(ISHFT(INDI,-16),255) -* ICOUP=MOD(INDI,65536) -* IVL=MOD(INDI/65536,256) - ICOUP=IBITS(INDI,0,16) - IVL=IBITS(INDI,16,8) - ICHK=0 - INS=1 - IF(IVSAVE.EQ.IV0) THEN - INS=ICOUPS - INB=ICOUPS - END IF - - IF(INB.GT.0) THEN -C Transfer HDIAG via buffer HCOUT, write it to unit 25: - DO J=INS,INB - IOUT=IOUT+1 - HCOUT(IOUT)=HDIAG(J) - IF(IOUT.GE.nCOP) THEN -C Write out the filled HCOUT buffer: - IF(IFS.NE.1) THEN - POTNUC=HCOUT(IREF0) - IFS=1 - END IF - DO KK=1,nCOP - HCOUT(KK)=HCOUT(KK)-POTNUC - END DO - CALL dDAFILE(Lu_25,1,HCOUT,nCOP,IADD25) - IOUT=0 - END IF - END DO - END IF - - IF(IVL.NE.IV0) THEN - JJ=IRC(IVL)+ICOUP - NSS=MUL(JSYM(JJ),LSYM) - IF(IVL.EQ.1)INB=NVIR(NSS) - IF(IVL.GT.1)INB=NNS(NSS) - IF(INB.GT.0)CALL dDAFILE(Lu_27,2,HDIAG,INB,IAD27) - END IF - IVSAVE=IVL - ICOUPS=ICOUP - GO TO 360 - -361 CONTINUE -C Here, if ICHK.EQ.0 and IND.NE.0 -CPAM97 ITYP=IAND(IND,1) -CPAM97 IJJ=IAND(ISHFT(IND,-1),2047) -* ITYP=MOD(IND,2) -* IJJ=MOD(IND/2,2048) - ITYP=IBITS(IND, 0,1) - IJJ=IBITS(IND,1,11) - IF(ITYP.EQ.0)TERM=COP(II)*FJI(IJJ) - IF(IVL.NE.IV0)GO TO 362 - -C IVL.EQ.IV0, Valence: - INB=ICOUP - HDIAG(INB)=HDIAG(INB)+TERM - GO TO 360 - -362 IF(IVL.NE.IV1)GO TO 363 -C IVL.EQ.IV1, Singles: - INB=0 - NA1=NSYS(NSS)+1 - NA2=NSYS(NSS+1) - IF(NA2.LT.NA1)GO TO 360 - DO NA=NA1,NA2 - INB=INB+1 - IF(ITYP.NE.0) THEN - IIJ=IROW(LN+NA)+IJJ - TERM=COP(II)*FJI(IIJ) - END IF - HDIAG(INB)=HDIAG(INB)+TERM - END DO - GO TO 360 - -363 INB=0 -C Doubles: - DO NA=1,NVIRT - NSA=MUL(NSS,NSM(LN+NA)) - NB1=NSYS(NSA)+1 - NB2=NSYS(NSA+1) - IF(NB2.GT.NA)NB2=NA - IF(NB2.GE.NB1) THEN - IIJ1=IROW(LN+NA)+IJJ - DO NB=NB1,NB2 - INB=INB+1 - IF(ITYP.NE.0) THEN - IIJ2=IROW(LN+NB)+IJJ - TERM=COP(II)*(FJI(IIJ1)+FJI(IIJ2)) - END IF - HDIAG(INB)=HDIAG(INB)+TERM - END DO - END IF - END DO - -360 CONTINUE - GO TO 300 - -C Transfer remaining HDIAG elements to 25 via buffer HCOUT: -350 IF(INB.EQ.0)GO TO 21 - - DO J=1,INB - IOUT=IOUT+1 - HCOUT(IOUT)=HDIAG(J) - IF(IOUT.GE.nCOP) THEN -C Write out the filled HCOUT buffer: - IF(IFS.NE.1) THEN - POTNUC=HCOUT(IREF0) - IFS=1 - END IF - DO KK=1,nCOP - HCOUT(KK)=HCOUT(KK)-POTNUC - END DO - CALL dDAFILE(Lu_25,1,HCOUT,nCOP,IADD25) - IOUT=0 - END IF - END DO - -21 CONTINUE -C One last write of the HCOUT buffer: - IF(IFS.NE.1) THEN - POTNUC=HCOUT(IREF0) - IFS=1 - END IF - DO KK=1,IOUT - HCOUT(KK)=HCOUT(KK)-POTNUC - END DO - CALL dDAFILE(Lu_25,1,HCOUT,nCOP,IADD25) - WRITE(6,50)POTNUC - CALL XFLUSH(6) -50 FORMAT(/,6X,'REFERENCE ENERGY',F18.8) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/ijkl_cpf.F90 openmolcas-22.10/src/cpf/ijkl_cpf.F90 --- openmolcas-22.02/src/cpf/ijkl_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/ijkl_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,131 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine IJKL_CPF(JSY,INDX,C,S,FIJKL,BUFIN,ENP,EPP) + +use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc +use cpf_global, only: IRC, IREF0, IROW, ITER, JSC, KBUFF1, LASTAD, LN, LSYM, Lu_CIGuga, Lu_TiABCI, NCONF, NNS, NVIR +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Constants, only: Zero +use Definitions, only: wp, iwp, RtoI + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: JSY(*), INDX(*) +real(kind=wp), intent(in) :: C(*), ENP(*) +real(kind=wp), intent(inout) :: S(*), EPP(*) +real(kind=wp), intent(_OUT_) :: FIJKL(*), BUFIN(*) +integer(kind=iwp) :: IADD10, IADR, IC1, IC2, ICHK, ILEN, IND, INDA, INDB, INDI, INUM, IP, IVL, JP, KKBUF0, KKBUF1, KKBUF2, KP, & + LENGTH, LP, NA, NB, NIJ, NIJKL, NKL, NS1, NS1L +real(kind=wp) :: COPI, FINI +integer(kind=iwp), external :: JSUNP + +call IJKL_CPF_INTERNAL(BUFIN) + +! This is to allow type punning without an explicit interface +contains + +subroutine IJKL_CPF_INTERNAL(BUFIN) + + real(kind=wp), target, intent(_OUT_) :: BUFIN(*) + integer(kind=iwp), pointer :: IBUFIN(:) + integer(kind=iwp) :: IIN + + call c_f_pointer(c_loc(BUFIN),iBUFIN,[1]) + + FINI = Zero ! dummy initialize + NCONF = JSC(4) + ICHK = 0 + NIJ = IROW(LN+1) + NIJKL = NIJ*(NIJ+1)/2 + FIJKL(1:NIJKL) = Zero + KKBUF0 = (RTOI*(KBUFF1+2)-2)/(RTOI+1) + KKBUF1 = RTOI*KKBUF0+KKBUF0+1 + KKBUF2 = KKBUF1+1 + IADR = LASTAD(1) + do + call iDAFILE(Lu_TiABCI,2,IBUFIN,KKBUF2,IADR) + LENGTH = IBUFIN(KKBUF1) + IADR = IBUFIN(KKBUF2) + if (LENGTH /= 0) call SCATTER(LENGTH,FIJKL,IBUFIN(RTOI*KKBUF0+1:RTOI*KKBUF0+LENGTH),BUFIN) + if (IADR == -1) exit + end do + IADD10 = IAD10(5) + do + call dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) + call iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN == 0) cycle + if (ILEN < 0) exit + do IIN=1,ILEN + IND = ICOP1(IIN) + if (ICHK == 0) then + if (IND /= 0) then + if (abs(FINI) < 1.0e-6_wp) cycle + IVL = ibits(IND,0,6) + IC2 = ibits(IND,6,13) + IC1 = ibits(IND,19,13) + COPI = COP(IIN)*FINI + if (IVL == 0) then + if (IC1 == IREF0) then + COPI = COPI/sqrt(ENP(IC2)) + S(IC2) = S(IC2)+COPI + if (ITER /= 1) EPP(IC2) = EPP(IC2)+COPI*C(IC2) + else if (IC2 == IREF0) then + COPI = COPI/sqrt(ENP(IC1)) + S(IC1) = S(IC1)+COPI + if (ITER /= 1) EPP(IC1) = EPP(IC1)+COPI*C(IC1) + else + S(IC1) = S(IC1)+COPI*C(IC2) + S(IC2) = S(IC2)+COPI*C(IC1) + end if + else + INDA = IRC(IVL)+IC1 + INDB = IRC(IVL)+IC2 + NA = INDX(INDA) + NB = INDX(INDB) + NS1 = JSUNP(JSY,INDA) + NS1L = MUL(NS1,LSYM) + INUM = NVIR(NS1L) + if (IVL >= 2) INUM = NNS(NS1L) + S(NA+1:NA+INUM) = S(NA+1:NA+INUM)+COPI*C(NB+1:NB+INUM) + S(NB+1:NB+INUM) = S(NB+1:NB+INUM)+COPI*C(NA+1:NA+INUM) + end if + else + ICHK = 1 + end if + else + ICHK = 0 + INDI = IND + IP = ibits(INDI,0,8) + JP = ibits(INDI,8,8) + KP = ibits(INDI,16,8) + LP = ibits(INDI,24,8) + NIJ = IROW(IP)+JP + NKL = IROW(KP)+LP + IND = NIJ*(NIJ-1)/2+NKL + FINI = FIJKL(IND) + end if + end do + end do + + nullify(IBUFIN) + + return + +end subroutine IJKL_CPF_INTERNAL + +end subroutine IJKL_CPF diff -Nru openmolcas-22.02/src/cpf/ijkl.f openmolcas-22.10/src/cpf/ijkl.f --- openmolcas-22.02/src/cpf/ijkl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/ijkl.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,115 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ -cpgi$g opt=1 - SUBROUTINE IJKL_CPF(JSY,INDEX,C,S,FIJKL,BUFIN,IBUFIN, - *ENP,EPP) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" - DIMENSION JSY(*),INDEX(*),C(*),S(*),FIJKL(*),BUFIN(*), - & IBUFIN(*),ENP(*),EPP(*) - PARAMETER(IPOW8=2**8,IPOW16=2**16,IPOW24=2**24) - PARAMETER(IPOW6=2**6,IPOW13=2**13,IPOW19=2**19) -* - JSYM(L)=JSUNP_CPF(JSY,L) -* - FINI=0.0D0 ! dummy initialize - NCONF=JSC(4) - ICHK=0 - NIJ=IROW(LN+1) - NIJKL=NIJ*(NIJ+1)/2 - DO 5 I=1,NIJKL - FIJKL(I)=D0 -5 CONTINUE - KKBUF0=(RTOI*(KBUFF1+2)-2)/(RTOI+1) - KKBUF1=RTOI*KKBUF0+KKBUF0+1 - KKBUF2=KKBUF1+1 - IADR=LASTAD(1) -201 CALL iDAFILE(Lu_TiABCI,2,IBUFIN,KKBUF2,IADR) - LENGTH=IBUFIN(KKBUF1) - IADR=IBUFIN(KKBUF2) - IF(LENGTH.EQ.0)GO TO 209 - CALL SCATTER(LENGTH,FIJKL,IBUFIN(RTOI*KKBUF0+1),BUFIN) -209 IF(IADR.NE.-1) GO TO 201 - IADD10=IAD10(5) -100 CALL dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) - CALL iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.EQ.0)GO TO 100 - IF(LEN.LT.0)GO TO 200 - DO 10 IN=1,LEN - IND=ICOP1(IN) - IF(ICHK.NE.0)GO TO 460 - IF(IND.NE.0)GO TO 22 - ICHK=1 - GO TO 10 -460 ICHK=0 - INDI=IND -* IP=MOD(INDI,IPOW8) -* JP=MOD(INDI/IPOW8,IPOW8) -* KP=MOD(INDI/IPOW16,IPOW8) -* LP=MOD(INDI/IPOW24,IPOW8) - IP=IBITS(INDI,0,8) - JP=IBITS(INDI,8,8) - KP=IBITS(INDI,16,8) - LP=IBITS(INDI,24,8) - NIJ=IROW(IP)+JP - NKL=IROW(KP)+LP - IND=NIJ*(NIJ-1)/2+NKL - FINI=FIJKL(IND) - GO TO 10 -22 IF(ABS(FINI).LT.1.d-06)GO TO 10 -CPAM97 IVL=IAND(IND,63) -CPAM97 IC2=IAND(ISHFT(IND,-6),8191) -CPAM97 IC1=IAND(ISHFT(IND,-19),8191) -* IVL=MOD(IND,IPOW6) -* IC2=MOD(IND/IPOW6,IPOW13) -* IC1=MOD(IND/IPOW19,IPOW13) - IVL=IBITS(IND, 0,6) - IC2=IBITS(IND,6,13) - IC1=IBITS(IND,19,13) - COPI=COP(IN)*FINI - IF(IVL.NE.0)GO TO 13 - IF(IC1.NE.IREF0)GO TO 16 - COPI=COPI/SQRT(ENP(IC2)) - S(IC2)=S(IC2)+COPI - IF(ITER.EQ.1)GO TO 10 - EPP(IC2)=EPP(IC2)+COPI*C(IC2) - GO TO 10 -16 IF(IC2.NE.IREF0)GO TO 17 - COPI=COPI/SQRT(ENP(IC1)) - S(IC1)=S(IC1)+COPI - IF(ITER.EQ.1)GO TO 10 - EPP(IC1)=EPP(IC1)+COPI*C(IC1) - GO TO 10 -17 FACS=D1 - S(IC1)=S(IC1)+FACS*COPI*C(IC2) - S(IC2)=S(IC2)+FACS*COPI*C(IC1) - GO TO 10 -13 INDA=IRC(IVL)+IC1 - INDB=IRC(IVL)+IC2 - FACS=D1 - NA=INDEX(INDA) - NB=INDEX(INDB) - NS1=JSYM(INDA) - NS1L=MUL(NS1,LSYM) - INUM=NVIR(NS1L) - IF(IVL.GE.2)INUM=NNS(NS1L) - CALL DAXPY_(INUM,COPI*FACS,C(NB+1),1,S(NA+1),1) - CALL DAXPY_(INUM,COPI*FACS,C(NA+1),1,S(NB+1),1) -10 CONTINUE - GO TO 100 -200 RETURN - END diff -Nru openmolcas-22.02/src/cpf/indmat_cpf.F90 openmolcas-22.10/src/cpf/indmat_cpf.F90 --- openmolcas-22.02/src/cpf/indmat_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/indmat_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,114 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine INDMAT_CPF(JSY,INDX,ISAB,ISMAX,JREFX) + +use cpf_global, only: IFIRST, ILIM, IPRINT, IRC, IREF0, ISC, JJS, JSC, LN, LSYM, NDIAG, NNS, NSM, NSYM, NSYS, NVIR, NVIRT +use Symmetry_Info, only: Mul +use Definitions, only: iwp, u6 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: JSY(*), JREFX(*) +integer(kind=iwp), intent(_OUT_) :: INDX(*), ISAB(*), ISMAX +integer(kind=iwp) :: I, ICOUS(8), II, IIN, IN0, IN2, IND, IR, IR1, IR2, IX1, IX2, IX3, IX4, JCONF, JJM, JSCI, NA, NB, NSAB, NSS +integer(kind=iwp), external :: JSUNP + +! DETERMINE REFERENCE STATE +JCONF = ISC(1) +do IR=1,JCONF + if (JREFX(IR) == 1) IREF0 = IR +end do +if (IPRINT > 5) write(u6,999) IREF0,(JREFX(IR),IR=1,JCONF) + +NSYS(1) = 0 +do I=2,NSYM + NSYS(I) = NSYS(I-1)+NVIR(I-1) +end do +NSYS(NSYM+1) = NVIRT +do I=1,NSYM + ICOUS(I) = 0 + NNS(I) = 0 +end do +ISMAX = 0 +IN0 = -NVIRT +do NA=1,NVIRT + IN0 = IN0+NVIRT + IIN = IN0 + IN2 = -NVIRT+NA + do NB=1,NA + IIN = IIN+1 + IN2 = IN2+NVIRT + NSAB = MUL(NSM(LN+NA),NSM(LN+NB)) + ICOUS(NSAB) = ICOUS(NSAB)+1 + ISAB(IIN) = ICOUS(NSAB) + if (ISMAX < ISAB(IIN)) ISMAX = ISAB(IIN) + ISAB(IN2) = ISAB(IIN) + if (ISAB(IIN) > NNS(NSAB)) NNS(NSAB) = ISAB(IIN) + end do + NDIAG(NA) = ISAB(IIN) +end do +IND = 0 +IR = IRC(1) +do II=1,IR + IND = IND+1 + INDX(II) = IND +end do +JSC(1) = IND +IR1 = IR+1 +IR2 = IRC(2) +do II=IR1,IR2 + INDX(II) = IND + NSS = MUL(JSUNP(JSY,II),LSYM) + IND = IND+NVIR(NSS) +end do +JSC(2) = IND +if (IFIRST == 0) then + IR1 = IR2+1 + IR2 = IRC(4) + JSC(3) = IND + do II=IR1,IR2 + INDX(II) = IND + NSS = MUL(JSUNP(JSY,II),LSYM) + IND = IND+ICOUS(NSS) + if (II == IRC(3)) JSC(3) = IND + end do + JSC(4) = IND +end if +IX1 = JSC(1) +IX2 = JSC(2)-JSC(1) +write(u6,213) +if (IFIRST == 0) then + JJM = (JJS(LSYM+1)-JJS(LSYM))*NVIRT + IX3 = JSC(3)-JSC(2)-JJM + IX4 = JSC(4)-JSC(3) + write(u6,215) IX1,IX2,IX3,IX4 +else + write(u6,216) IX1,IX2 + JJM = 0 +end if +JSCI = JSC(ILIM)-JJM +write(u6,50) ISC(ILIM),JSCI + +return + +50 format(//6X,'FORMAL NUMBER OF CONFIGURATIONS',I8,/8X,'REAL NUMBER OF CONFIGURATIONS',I8) +213 format(//,6X,'FULL-SPACE CONFIGURATIONS (REAL)') +215 format(/,6X,'NUMBER OF VALENCE STATES',I16,/,6X,'NUMBER OF DOUBLET COUPLED SINGLES',I7, & + /,6X,'NUMBER OF TRIPLET COUPLED DOUBLES',I7,/,6X,'NUMBER OF SINGLET COUPLED DOUBLES',I7) +216 format(/,6X,'NUMBER OF VALENCE STATES',I14,/,6X,'NUMBER OF DOUBLET COUPLED SINGLES',I7) +999 format(2X,I3,2X,'JREFX',10I5) + +end subroutine INDMAT_CPF diff -Nru openmolcas-22.02/src/cpf/indmat.f openmolcas-22.10/src/cpf/indmat.f --- openmolcas-22.02/src/cpf/indmat.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/indmat.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,119 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE INDMAT_CPF(JSY,INDEX,ISAB,ISMAX,JREFX) - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "cpfmcpf.fh" - DIMENSION INDEX(*),JSY(*),ISAB(*),JREFX(*) - DIMENSION ICOUS(8) -CPAM97 EXTERNAL UNPACK -CPAM97 INTEGER UNPACK -CRL JSYM(L)=IAND(ISHFT(JSY((L+19)/20),-3*((L+19)/20*20-L)),7)+1 -CPAM96 JSYM(L)=UNPACK(JSY((L+9)/10),3*MOD(L-1,10)+1,3)+1 - JSYM(L)=JSUNP_CPF(JSY,L) -C -C DETERMINE REFERENCE STATE - JCONF=ISC(1) - DO 31 IR=1,JCONF - IF(JREFX(IR).EQ.1)IREF0=IR -31 CONTINUE - IF(IPRINT.GT.5)WRITE(6,999)IREF0,(JREFX(IR),IR=1,JCONF) -999 FORMAT(2X,I3,2X,'JREFX',10I5) -C - ILIM=4 - IF(IFIRST.NE.0)ILIM=2 - NSYS(1)=0 - IF(NSYM.EQ.1)GO TO 1 - DO 2 I=2,NSYM - NSYS(I)=NSYS(I-1)+NVIR(I-1) -2 CONTINUE -1 NSYS(NSYM+1)=NVIRT - DO 5 I=1,NSYM - ICOUS(I)=0 - NNS(I)=0 -5 CONTINUE - ISMAX=0 - IN0=-NVIRT - DO 15 NA=1,NVIRT - IN0=IN0+NVIRT - IN=IN0 - IN2=-NVIRT+NA - DO 25 NB=1,NA - IN=IN+1 - IN2=IN2+NVIRT - NSAB=MUL(NSM(LN+NA),NSM(LN+NB)) - ICOUS(NSAB)=ICOUS(NSAB)+1 - ISAB(IN)=ICOUS(NSAB) - IF(ISMAX.LT.ISAB(IN))ISMAX=ISAB(IN) - ISAB(IN2)=ISAB(IN) - IF(ISAB(IN).GT.NNS(NSAB))NNS(NSAB)=ISAB(IN) -25 CONTINUE - NDIAG(NA)=ISAB(IN) -15 CONTINUE - IND=0 - IR=IRC(1) - DO 10 II=1,IR - IND=IND+1 - INDEX(II)=IND -10 CONTINUE - JSC(1)=IND - IR1=IR+1 - IR2=IRC(2) - DO 20 II=IR1,IR2 - INDEX(II)=IND - NSS=MUL(JSYM(II),LSYM) - IND=IND+NVIR(NSS) -20 CONTINUE - JSC(2)=IND - IF(IFIRST.NE.0)GO TO 22 - IR1=IR2+1 - IR2=IRC(4) - JSC(3)=IND - DO 30 II=IR1,IR2 - INDEX(II)=IND - NSS=MUL(JSYM(II),LSYM) - IND=IND+ICOUS(NSS) - IF(II.EQ.IRC(3))JSC(3)=IND -30 CONTINUE - JSC(4)=IND -22 IX1=JSC(1) - IX2=JSC(2)-JSC(1) - WRITE(6,213) - CALL XFLUSH(6) -213 FORMAT(//,6X,'FULL-SPACE CONFIGURATIONS (REAL)') - IF(IFIRST.NE.0)GO TO 212 - JJM=(JJS(LSYM+1)-JJS(LSYM))*NVIRT - IX3=JSC(3)-JSC(2)-JJM - IX4=JSC(4)-JSC(3) - WRITE(6,215)IX1,IX2,IX3,IX4 - CALL XFLUSH(6) -215 FORMAT(/,6X,'NUMBER OF VALENCE STATES',I16, - */,6X,'NUMBER OF DOUBLET COUPLED SINGLES',I7, - */,6X,'NUMBER OF TRIPLET COUPLED DOUBLES',I7, - */,6X,'NUMBER OF SINGLET COUPLED DOUBLES',I7) - GO TO 211 -212 WRITE(6,216)IX1,IX2 - CALL XFLUSH(6) -216 FORMAT(/,6X,'NUMBER OF VALENCE STATES',I14, - */,6X,'NUMBER OF DOUBLET COUPLED SINGLES',I7) - JJM=0 -211 JSCI=JSC(ILIM)-JJM - WRITE(6,50)ISC(ILIM),JSCI - CALL XFLUSH(6) -50 FORMAT(//6X,'FORMAL NUMBER OF CONFIGURATIONS',I8, - */8X,'REAL NUMBER OF CONFIGURATIONS',I8) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/ipo_cpf.F90 openmolcas-22.10/src/cpf/ipo_cpf.F90 --- openmolcas-22.02/src/cpf/ipo_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/ipo_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,42 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine IPO_CPF(IPOA,NVIR,MUL,NSYM,KLS,IFT) + +use Definitions, only: iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(_OUT_) :: IPOA(*) +integer(kind=iwp), intent(in) :: NVIR(*), MUL(8,8), NSYM, KLS, IFT +integer(kind=iwp) :: M, N, NSUM + +NSUM = 0 +do N=1,NSYM + IPOA(N) = NSUM + M = MUL(N,KLS) + if (IFT < 0) then + NSUM = NSUM+NVIR(N)*NVIR(M) + else if (N == M) then + NSUM = NSUM+NVIR(N)*(NVIR(N)+1)/2 + else if (N > M) then + NSUM = NSUM+NVIR(N)*NVIR(M) + end if +end do +IPOA(NSYM+1) = NSUM + +return + +end subroutine IPO_CPF diff -Nru openmolcas-22.02/src/cpf/ipo.f openmolcas-22.10/src/cpf/ipo.f --- openmolcas-22.02/src/cpf/ipo.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/ipo.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,37 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE IPO_CPF(IPOA,NVIR,MUL,NSYM,KLS,IFT) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION IPOA(*),NVIR(*),MUL(8,8) - NSUM=0 - DO 10 N=1,NSYM - IPOA(N)=NSUM - M=MUL(N,KLS) - IF(IFT.GE.0)GO TO 20 - NSUM=NSUM+NVIR(N)*NVIR(M) - GO TO 10 -20 IF (N-M.LT.0) THEN - GO TO 10 - ELSE IF (N-M.EQ.0) THEN - GO TO 11 - ELSE - GO TO 12 - END IF -11 NSUM=NSUM+NVIR(N)*(NVIR(N)+1)/2 - GO TO 10 -12 NSUM=NSUM+NVIR(N)*NVIR(M) -10 CONTINUE - IPOA(NSYM+1)=NSUM - RETURN - END diff -Nru openmolcas-22.02/src/cpf/ips.fh openmolcas-22.10/src/cpf/ips.fh --- openmolcas-22.02/src/cpf/ips.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/ips.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,11 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - COMMON /IPS/IPS(200) diff -Nru openmolcas-22.02/src/cpf/jsunp.f openmolcas-22.10/src/cpf/jsunp.f --- openmolcas-22.02/src/cpf/jsunp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/jsunp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - INTEGER FUNCTION JSUNP_CPF(INTSYM,L) - DIMENSION INTSYM(*) - - INTW=INTSYM((L+9)/10) - IPOW=2**(27-3*MOD(L-1,10)) - JSUNP_CPF=1+MOD(INTW/IPOW,8) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/mabcd.f openmolcas-22.10/src/cpf/mabcd.f --- openmolcas-22.02/src/cpf/mabcd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/mabcd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,106 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE MABCD(JSY,INDEX,ISAB,C,S,ACBDS,ACBDT,BUFIN, - *W,THET,ENP,NII) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" - DIMENSION JSY(*),INDEX(*),ISAB(*),C(*),S(*),ACBDS(*),ACBDT(*), - & BUFIN(*),W(*),THET(NII,NII),ENP(*) -* - INUM=IRC(4)-IRC(3) - CALL MPSQ2(C,S,W,MUL,INDEX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) - IAD16=0 - KBUFF1=2*9600 - INSIN=KBUFF1 - NVT=IROW(NVIRT+1) - NOV=(NVT-1)/IPASS+1 - IACMAX=0 - DO 70 ISTEP=1,IPASS - IACMIN=IACMAX+1 - IACMAX=IACMAX+NOV - IF(IACMAX.GT.NVT)IACMAX=NVT - IF(IACMIN.GT.IACMAX)GO TO 70 - DO 40 ISYM=1,NSYM - IST1=IRC(3)+JJS(ISYM+9)+1 - IFIN1=IRC(3)+JJS(ISYM+10) - INPS=IFIN1-IST1+1 - IST2=IRC(2)+JJS(ISYM)+1 - IFIN2=IRC(2)+JJS(ISYM+1) - INPT=IFIN2-IST2+1 - ITAIL=INPS+INPT - IF(ITAIL.EQ.0)GO TO 40 - IN1=-NVIRT - DO 50 NA=1,NVIRT - IN1=IN1+NVIRT - DO 60 NC=1,NA - IAC=IROW(NA)+NC - IF(IAC.LT.IACMIN)GO TO 60 - IF(IAC.GT.IACMAX)GO TO 60 - IF(NA.EQ.1)GO TO 60 - NSAC=MUL(NSM(LN+NA),NSM(LN+NC)) - NSACL=MUL(NSAC,LSYM) - IF(NSACL.NE.ISYM)GO TO 60 - ISAC=ISAB(IN1+NC) - NDMAX=NSYS(NSM(LN+NC)+1) - IF(NDMAX.GT.NA)NDMAX=NA - INS=ISAB(IN1+NDMAX) - ILOOP=0 -72 DO 75 I=1,INS - IF(INSIN.LT.KBUFF1)GO TO 73 - CALL dDAFILE(Lu_TiABCD,2,BUFIN,KBUFF1,IAD16) - INSIN=0 -73 INSIN=INSIN+1 - IF(ILOOP.EQ.0)ACBDS(I)=BUFIN(INSIN) - IF(ILOOP.EQ.1)ACBDT(I)=BUFIN(INSIN) -75 CONTINUE - ILOOP=ILOOP+1 - IF(ILOOP.EQ.1)GO TO 72 - IF(INPS.EQ.0)GO TO 11 - DO 10 INDA=IST1,IFIN1 - ENPQ=(D1-THET(INDA,INDA)/D2)*(ENP(INDA)+ENP(INDA)-D1)+ - *THET(INDA,INDA)/D2 - FACS=SQRT(ENP(INDA))*SQRT(ENP(INDA))/ENPQ - FACW=(FACS*(D2-THET(INDA,INDA))/ENPQ)*ENP(INDA)-FACS - TERM=DDOT_(INS,C(INDEX(INDA)+1),1,ACBDS,1) - S(INDEX(INDA)+ISAC)=S(INDEX(INDA)+ISAC)+FACS*TERM - W(INDEX(INDA)+ISAC)=W(INDEX(INDA)+ISAC)+FACW*TERM - CALL DAXPY_(INS,FACS*C(INDEX(INDA)+ISAC),ACBDS,1, - *S(INDEX(INDA)+1),1) - CALL DAXPY_(INS,FACW*C(INDEX(INDA)+ISAC),ACBDS,1, - *W(INDEX(INDA)+1),1) -10 CONTINUE -11 IF(INPT.EQ.0.OR.NA.EQ.NC)GO TO 60 - DO 30 INDA=IST2,IFIN2 - ENPQ=(D1-THET(INDA,INDA)/D2)*(ENP(INDA)+ENP(INDA)-D1)+ - *THET(INDA,INDA)/D2 - FACS=SQRT(ENP(INDA))*SQRT(ENP(INDA))/ENPQ - FACW=(FACS*(D2-THET(INDA,INDA))/ENPQ)*ENP(INDA)-FACS - TERM=DDOT_(INS,C(INDEX(INDA)+1),1,ACBDT,1) - S(INDEX(INDA)+ISAC)=S(INDEX(INDA)+ISAC)+FACS*TERM - W(INDEX(INDA)+ISAC)=W(INDEX(INDA)+ISAC)+FACW*TERM - CALL DAXPY_(INS,FACS*C(INDEX(INDA)+ISAC),ACBDT,1, - *S(INDEX(INDA)+1),1) - CALL DAXPY_(INS,FACW*C(INDEX(INDA)+ISAC),ACBDT,1, - *W(INDEX(INDA)+1),1) -30 CONTINUE -60 CONTINUE -50 CONTINUE -40 CONTINUE -70 CONTINUE - CALL MDSQ2(C,S,W,MUL,INDEX,JSY,NDIAG,INUM,IRC(3), - *LSYM,NVIRT,SQ2) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/mabcd.F90 openmolcas-22.10/src/cpf/mabcd.F90 --- openmolcas-22.02/src/cpf/mabcd.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/mabcd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,114 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine MABCD(JSY,INDX,ISAB,C,S,ACBDS,ACBDT,BUFIN,W,THET,ENP,NII) + +use cpf_global, only: IPASS, IRC, IROW, JJS, KBUFF1, LN, LSYM, Lu_TiABCD, NDIAG, NSM, NSYM, NSYS, NVIRT, SQ2 +use Symmetry_Info, only: Mul +use Constants, only: One, Two, Half +use Definitions, only: wp, iwp, r8 + +#include "intent.fh" + +integer(kind=iwp), intent(in) :: JSY(*), INDX(*), ISAB(*), NII +real(kind=wp), intent(inout) :: C(*), S(*), W(*) +real(kind=wp), intent(_OUT_) :: ACBDS(*), ACBDT(*), BUFIN(*) +real(kind=wp), intent(in) :: THET(NII,NII), ENP(*) +integer(kind=iwp) :: I, IAC, IACMAX, IACMIN, IAD16, IFIN1, IFIN2, ILOOP, IN1, INDA, INPS, INPT, INS, INSIN, INUM, ISAC, IST1, & + IST2, ISTEP, ISYM, ITAIL, NA, NC, NDMAX, NOV, NSAC, NSACL, NVT +real(kind=wp) :: ENPQ, FACS, FACW, TERM +real(kind=r8), external :: DDOT_ + +INUM = IRC(4)-IRC(3) +call MPSQ2(C,S,W,MUL,INDX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) +IAD16 = 0 +INSIN = KBUFF1 +NVT = IROW(NVIRT+1) +NOV = (NVT-1)/IPASS+1 +IACMAX = 0 +do ISTEP=1,IPASS + IACMIN = IACMAX+1 + IACMAX = IACMAX+NOV + if (IACMAX > NVT) IACMAX = NVT + if (IACMIN > IACMAX) cycle + do ISYM=1,NSYM + IST1 = IRC(3)+JJS(ISYM+9)+1 + IFIN1 = IRC(3)+JJS(ISYM+10) + INPS = IFIN1-IST1+1 + IST2 = IRC(2)+JJS(ISYM)+1 + IFIN2 = IRC(2)+JJS(ISYM+1) + INPT = IFIN2-IST2+1 + ITAIL = INPS+INPT + if (ITAIL == 0) cycle + IN1 = -NVIRT + do NA=1,NVIRT + IN1 = IN1+NVIRT + do NC=1,NA + IAC = IROW(NA)+NC + if (IAC < IACMIN) cycle + if (IAC > IACMAX) cycle + if (NA == 1) cycle + NSAC = MUL(NSM(LN+NA),NSM(LN+NC)) + NSACL = MUL(NSAC,LSYM) + if (NSACL /= ISYM) cycle + ISAC = ISAB(IN1+NC) + NDMAX = NSYS(NSM(LN+NC)+1) + if (NDMAX > NA) NDMAX = NA + INS = ISAB(IN1+NDMAX) + ILOOP = 0 + do + do I=1,INS + if (INSIN >= KBUFF1) then + call dDAFILE(Lu_TiABCD,2,BUFIN,KBUFF1,IAD16) + INSIN = 0 + end if + INSIN = INSIN+1 + if (ILOOP == 0) ACBDS(I) = BUFIN(INSIN) + if (ILOOP == 1) ACBDT(I) = BUFIN(INSIN) + end do + ILOOP = ILOOP+1 + if (ILOOP /= 1) exit + end do + if (INPS /= 0) then + do INDA=IST1,IFIN1 + ENPQ = (One-THET(INDA,INDA)*Half)*(ENP(INDA)+ENP(INDA)-One)+THET(INDA,INDA)*Half + FACS = sqrt(ENP(INDA))*sqrt(ENP(INDA))/ENPQ + FACW = (FACS*(Two-THET(INDA,INDA))/ENPQ)*ENP(INDA)-FACS + TERM = DDOT_(INS,C(INDX(INDA)+1),1,ACBDS,1) + S(INDX(INDA)+ISAC) = S(INDX(INDA)+ISAC)+FACS*TERM + W(INDX(INDA)+ISAC) = W(INDX(INDA)+ISAC)+FACW*TERM + S(INDX(INDA)+1:INDX(INDA)+INS) = S(INDX(INDA)+1:INDX(INDA)+INS)+FACS*C(INDX(INDA)+ISAC)*ACBDS(1:INS) + W(INDX(INDA)+1:INDX(INDA)+INS) = W(INDX(INDA)+1:INDX(INDA)+INS)+FACW*C(INDX(INDA)+ISAC)*ACBDS(1:INS) + end do + end if + if ((INPT == 0) .or. (NA == NC)) cycle + do INDA=IST2,IFIN2 + ENPQ = (One-THET(INDA,INDA)*Half)*(ENP(INDA)+ENP(INDA)-One)+THET(INDA,INDA)*Half + FACS = sqrt(ENP(INDA))*sqrt(ENP(INDA))/ENPQ + FACW = (FACS*(Two-THET(INDA,INDA))/ENPQ)*ENP(INDA)-FACS + TERM = DDOT_(INS,C(INDX(INDA)+1),1,ACBDT,1) + S(INDX(INDA)+ISAC) = S(INDX(INDA)+ISAC)+FACS*TERM + W(INDX(INDA)+ISAC) = W(INDX(INDA)+ISAC)+FACW*TERM + S(INDX(INDA)+1:INDX(INDA)+INS) = S(INDX(INDA)+1:INDX(INDA)+INS)+FACS*C(INDX(INDA)+ISAC)*ACBDT(1:INS) + W(INDX(INDA)+1:INDX(INDA)+INS) = W(INDX(INDA)+1:INDX(INDA)+INS)+FACW*C(INDX(INDA)+ISAC)*ACBDT(1:INS) + end do + end do + end do + end do +end do +call MDSQ2(C,S,W,MUL,INDX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) + +return + +end subroutine MABCD diff -Nru openmolcas-22.02/src/cpf/mabci.f openmolcas-22.10/src/cpf/mabci.f --- openmolcas-22.02/src/cpf/mabci.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/mabci.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,119 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ -cpgi$g opt=1 - SUBROUTINE MABCI(JSY,INDEX,C,S,BMN,IBMN,BIAC,BICA,BUFIN, - & W,THET,ENP,NII) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" - DIMENSION JSY(*),INDEX(*),C(*),S(*),BMN(*),IBMN(*), - & BIAC(*),BICA(*),BUFIN(*),W(*),THET(NII,NII),ENP(*) - PARAMETER (IPOW6=2**6,IPOW13=2**13,IPOW19=2**19) -* - JSYM(L)=JSUNP_CPF(JSY,L) -* - INUM=IRC(4)-IRC(3) - CALL MPSQ2(C,S,W,MUL,INDEX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) - ICHK=0 - INSIN=KBUFF1 - IAD15=IADABCI - IADD10=IAD10(4) - CALL dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) - CALL iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IN=2 - NSAVE=ICOP1(IN) -100 NI=NSAVE - IOUT=0 -110 IN=IN+1 - IF(IN.LE.LEN)GO TO 15 - CALL dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) - CALL iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.LE.0)GO TO 5 - IN=1 -15 IF(ICHK.NE.0)GO TO 460 - IF(ICOP1(IN).EQ.0)GO TO 10 - IOUT=IOUT+1 - BMN(IOUT)=COP(IN) - IBMN(IOUT)=ICOP1(IN) - GO TO 110 -10 ICHK=1 - GO TO 110 -460 ICHK=0 - NSAVE=ICOP1(IN) -5 CONTINUE - DO 20 NB=1,NVIRT - NSIB=MUL(NSM(LN+NB),NSM(NI)) - NSLB=MUL(NSM(LN+NB),LSYM) - LB=NB-NSYS(NSM(LN+NB)) - INS=NNS(NSIB) - ILOOP=0 -72 CONTINUE - DO 75 I=1,INS - IF ( INSIN.GE.KBUFF1 ) THEN - CALL dDAFILE(Lu_TiABCI,2,BUFIN,KBUFF1,IAD15) - INSIN=0 - END IF - INSIN=INSIN+1 - IF(ILOOP.EQ.0)BIAC(I)=BUFIN(INSIN) - IF(ILOOP.EQ.1)BICA(I)=BUFIN(INSIN) -75 CONTINUE - ILOOP=ILOOP+1 - IF(ILOOP.EQ.1)GO TO 72 - DO 25 IT=1,IOUT - IND=IBMN(IT) -CPAM97 ICP1=IAND(ISHFT(IND,-19),8191) -* ICP1=MOD(IND/IPOW19,IPOW13) - ICP1=IBITS(IND,19,13) - INDA=IRC(1)+ICP1 - IF(JSYM(INDA).NE.NSLB)GO TO 25 - MA=INDEX(INDA)+LB -CPAM97 ICP2=IAND(ISHFT(IND,-6),8191) -* ICP2=MOD(IND/IPOW6,IPOW13) -CPAM97 ITYP=IAND(IND,63) -* ITYP=MOD(IND,IPOW6) - ICP2=IBITS(IND,6,13) - ITYP=IBITS(IND, 0,6) - IF(INS.EQ.0)GO TO 25 - COPL=BMN(IT)*C(MA) - INDB=IRC(ITYP)+ICP2 - D1=1.0D0 - D2=2.0D0 - XXX=THET(INDA,INDB)/2.0D0 - ENPQ=(D1-XXX)*(ENP(INDA)+ENP(INDB)-D1)+XXX - FACS=SQRT(ENP(INDA))*SQRT(ENP(INDB))/ENPQ - FACW=FACS*(D2-THET(INDA,INDB))/ENPQ - FACWA=FACW*ENP(INDA)-FACS - FACWB=FACW*ENP(INDB)-FACS - ICCB=INDEX(INDB)+1 - IF ( ITYP.EQ.3 ) THEN - TERM=DDOT_(INS,C(ICCB),1,BIAC,1) - CALL DAXPY_(INS,COPL*FACS,BIAC,1,S(ICCB),1) - CALL DAXPY_(INS,COPL*FACWB,BIAC,1,W(ICCB),1) - ELSE - TERM=DDOT_(INS,C(ICCB),1,BICA,1) - CALL DAXPY_(INS,COPL*FACS,BICA,1,S(ICCB),1) - CALL DAXPY_(INS,COPL*FACWB,BICA,1,W(ICCB),1) - END IF - S(MA)=S(MA)+BMN(IT)*FACS*TERM - W(MA)=W(MA)+BMN(IT)*FACWA*TERM -25 CONTINUE -20 CONTINUE - IF(LEN.GE.0)GO TO 100 - CALL MDSQ2(C,S,W,MUL,INDEX,JSY,NDIAG,INUM,IRC(3), - *LSYM,NVIRT,SQ2) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/mabci.F90 openmolcas-22.10/src/cpf/mabci.F90 --- openmolcas-22.02/src/cpf/mabci.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/mabci.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,134 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine MABCI(JSY,INDX,C,S,BMN,IBMN,BIAC,BICA,BUFIN,W,THET,ENP,NII) + +use cpf_global, only: IADABCI, IRC, KBUFF1, LN, LSYM, Lu_CIGuga, Lu_TiABCI, NDIAG, NNS, NSM, NSYS, NVIRT, SQ2 +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Constants, only: One, Two, Half +use Definitions, only: wp, iwp, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: JSY(*), INDX(*), NII +real(kind=wp), intent(_OUT_) :: C(*), S(*), W(*) +real(kind=wp), intent(inout) :: BMN(*), BIAC(*), BICA(*), BUFIN(*) +integer(kind=iwp), intent(_OUT_) :: IBMN(*) +real(kind=wp), intent(in) :: THET(NII,NII), ENP(*) +integer(kind=iwp) :: I, IAD15, IADD10, ICCB, ICHK, ICP1, ICP2, IIN, ILEN, ILOOP, IND, INDA, INDB, INS, INSIN, INUM, IOUT, IT, & + ITYP, LB, MA, NB, NI, NSAVE, NSIB, NSLB +real(kind=wp) :: COPL, ENPQ, FACS, FACW, FACWA, FACWB, TERM, XXX +logical(kind=iwp) :: Skip +integer(kind=iwp), external :: JSUNP +real(kind=r8), external :: DDOT_ + +INUM = IRC(4)-IRC(3) +call MPSQ2(C,S,W,MUL,INDX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) +ICHK = 0 +INSIN = KBUFF1 +IAD15 = IADABCI +IADD10 = IAD10(4) +call dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) +call iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) +ILEN = ICOP1(nCOP+1) +IIN = 2 +NSAVE = ICOP1(IIN) +do + NI = NSAVE + IOUT = 0 + Skip = .false. + do + IIN = IIN+1 + if (IIN > ILEN) then + call dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) + call iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN <= 0) then + Skip = .true. + exit + end if + IIN = 1 + end if + if (ICHK /= 0) exit + if (ICOP1(IIN) /= 0) then + IOUT = IOUT+1 + BMN(IOUT) = COP(IIN) + IBMN(IOUT) = ICOP1(IIN) + else + ICHK = 1 + end if + end do + if (.not. Skip) then + ICHK = 0 + NSAVE = ICOP1(IIN) + end if + do NB=1,NVIRT + NSIB = MUL(NSM(LN+NB),NSM(NI)) + NSLB = MUL(NSM(LN+NB),LSYM) + LB = NB-NSYS(NSM(LN+NB)) + INS = NNS(NSIB) + ILOOP = 0 + do + do I=1,INS + if (INSIN >= KBUFF1) then + call dDAFILE(Lu_TiABCI,2,BUFIN,KBUFF1,IAD15) + INSIN = 0 + end if + INSIN = INSIN+1 + if (ILOOP == 0) BIAC(I) = BUFIN(INSIN) + if (ILOOP == 1) BICA(I) = BUFIN(INSIN) + end do + ILOOP = ILOOP+1 + if (ILOOP /= 1) exit + end do + do IT=1,IOUT + IND = IBMN(IT) + ICP1 = ibits(IND,19,13) + INDA = IRC(1)+ICP1 + if (JSUNP(JSY,INDA) /= NSLB) cycle + MA = INDX(INDA)+LB + ICP2 = ibits(IND,6,13) + ITYP = ibits(IND,0,6) + if (INS == 0) cycle + COPL = BMN(IT)*C(MA) + INDB = IRC(ITYP)+ICP2 + XXX = THET(INDA,INDB)*Half + ENPQ = (One-XXX)*(ENP(INDA)+ENP(INDB)-One)+XXX + FACS = sqrt(ENP(INDA))*sqrt(ENP(INDB))/ENPQ + FACW = FACS*(Two-THET(INDA,INDB))/ENPQ + FACWA = FACW*ENP(INDA)-FACS + FACWB = FACW*ENP(INDB)-FACS + ICCB = INDX(INDB)+1 + if (ITYP == 3) then + TERM = DDOT_(INS,C(ICCB),1,BIAC,1) + S(ICCB:ICCB+INS-1) = S(ICCB:ICCB+INS-1)+COPL*FACS*BIAC(1:INS) + W(ICCB:ICCB+INS-1) = W(ICCB:ICCB+INS-1)+COPL*FACWB*BIAC(1:INS) + else + TERM = DDOT_(INS,C(ICCB),1,BICA,1) + S(ICCB:ICCB+INS-1) = S(ICCB:ICCB+INS-1)+COPL*FACS*BICA(1:INS) + W(ICCB:ICCB+INS-1) = W(ICCB:ICCB+INS-1)+COPL*FACWB*BICA(1:INS) + end if + S(MA) = S(MA)+BMN(IT)*FACS*TERM + W(MA) = W(MA)+BMN(IT)*FACWA*TERM + end do + end do + if (ILEN < 0) exit +end do +call MDSQ2(C,S,W,MUL,INDX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) + +return + +end subroutine MABCI diff -Nru openmolcas-22.02/src/cpf/mab.f openmolcas-22.10/src/cpf/mab.f --- openmolcas-22.02/src/cpf/mab.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/mab.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,228 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE MAB(ICASE,JSY,INDEX,C,S,FC,A,B,F,W,THET,ENP,NII) - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "cpfmcpf.fh" - DIMENSION JSY(*),INDEX(*),C(*),S(*),FC(*),A(*),B(*), - & F(*),W(*),THET(NII,NII),ENP(*) - DIMENSION ICASE(*) - DIMENSION IPOA(9),IPOF(9) - DIMENSION IOC(55) -CPAM97 EXTERNAL UNPACK -CPAM97 INTEGER UNPACK -CRL JO(L)=IAND(ISHFT(QOCC((L+29)/30),-2*((L+29)/30*30-L)),3) -CPAM97 JO(L)=UNPACK(QOCC((L+29)/30), 2*L-(2*L-1)/60*60, 2) - JO(L)=ICUNP(ICASE,L) -CRL JSYM(L)=IAND(ISHFT(JSY((L+19)/20),-3*((L+19)/20*20-L)),7)+1 -CPAM96 JSYM(L)=UNPACK(JSY((L+9)/10),3*MOD(L-1,10)+1,3)+1 - JSYM(L)=JSUNP_CPF(JSY,L) - NAB=0 ! dummy initialize - NOB2=IROW(NORBT+1) - IF(IPRINT.GE.15) THEN - WRITE(6,'(A,/,(10F12.6))')' S,AB',(S(I),I=1,JSC(4)) - CALL XFLUSH(6) - WRITE(6,'(A,/,(10F12.6))')' W,AB',(W(I),I=1,JSC(4)) - CALL XFLUSH(6) - IF(IDENS.EQ.1)WRITE(6,'(A,/,(10F12.6))') - & ' FC,AB',(FC(I),I=1,NOB2) - END IF - INUM=IRC(4)-IRC(3) - CALL MPSQ2(C,S,W,MUL,INDEX,JSY,NDIAG,INUM,IRC(3), - *LSYM,NVIRT,SQ2) - NCLIM=4 - IF(IFIRST.NE.0)NCLIM=2 -C MOVE FOCK (DENSITY) MATRIX TO F IN SYMMETRY BLOCKS - CALL IPO_CPF(IPOF,NVIR,MUL,NSYM,1,-1) - ITURN=0 -90 DO 10 IASYM=1,NSYM - IAB=IPOF(IASYM) - NA1=NSYS(IASYM)+1 - NA2=NSYS(IASYM+1) - IF(NA2.LT.NA1)GO TO 10 - DO 15 NA=NA1,NA2 - DO 20 NB=NA1,NA2 - IAB=IAB+1 - IF(NA.GE.NB)NAB=IROW(LN+NA)+LN+NB - IF(NB.GT.NA)NAB=IROW(LN+NB)+LN+NA - IF(ITURN.EQ.1)GO TO 320 - IF(IDENS.EQ.0)F(IAB)=D0 - IF(IDENS.EQ.1)F(IAB)=FC(NAB) - IF(NA.NE.NB)F(IAB)=FC(NAB) - GO TO 20 -320 IF(NA.LT.NB)FC(NAB)=F(IAB) -20 CONTINUE -15 CONTINUE -10 CONTINUE - IF(ITURN.EQ.0)GO TO 11 - TR=D0 - IJ=0 - DO 510 I=1,NORBT - IJ=IJ+I - TR=TR+FC(IJ) -510 CONTINUE - If (iPrint.ge.15) WRITE(6,310)TR -310 FORMAT(/,6X,'TRACE OF DENSITY MATRIX',F16.8) - GO TO 300 -11 II1=0 - ITAIL=IRC(NCLIM) - DO 40 INDA=1,ITAIL - IF(IDENS.EQ.0)GO TO 111 - DO 110 I=1,LN - II1=II1+1 - JOJ=JO(II1) - IF(JOJ.GT.1)JOJ=JOJ-1 - IOC(I)=JOJ -110 CONTINUE -111 IF(INDA.GT.IRC(1))GO TO 120 - IF(IDENS.EQ.0.OR.INDA.EQ.IREF0)GO TO 40 - ENPQ=(D1-THET(INDA,INDA)/D2)*(ENP(INDA)+ENP(INDA)-D1)+ - *THET(INDA,INDA)/D2 - TSUM=C(INDA)*C(INDA)/ENPQ - GO TO 106 -120 MYSYM=JSYM(INDA) - MYL=MUL(MYSYM,LSYM) - INMY=INDEX(INDA)+1 - ENPQ=(D1-THET(INDA,INDA)/D2)*(ENP(INDA)+ENP(INDA)-D1)+ - *THET(INDA,INDA)/D2 - FACS=SQRT(ENP(INDA))*SQRT(ENP(INDA))/ENPQ - FACW=(FACS*(D2-THET(INDA,INDA))/ENPQ)*ENP(INDA)-FACS - IF(INDA.GT.IRC(2))GO TO 25 -C DOUBLET-DOUBLET INTERACTIONS - IF(NVIR(MYL).EQ.0)GO TO 40 - IF(IDENS.EQ.1)GO TO 65 - CALL SETZ(A,NVIR(MYL)) - CALL FMMM(F(IPOF(MYL)+1),C(INMY),A,NVIR(MYL),1,NVIR(MYL)) - CALL DAXPY_(NVIR(MYL),FACS,A,1,S(INMY),1) - CALL DAXPY_(NVIR(MYL),FACW,A,1,W(INMY),1) - GO TO 40 -65 CALL FMUL2_CPF(C(INMY),C(INMY),A,NVIR(MYL),NVIR(MYL),1) - IPF=IPOF(MYL)+1 - IN=IPOF(MYL+1)-IPOF(MYL) - ENPQ=(D1-THET(INDA,INDA)/D2)*(ENP(INDA)+ENP(INDA)-D1)+ - *THET(INDA,INDA)/D2 - COPI=D1/ENPQ - CALL VSMA(A,1,COPI,F(IPF),1,F(IPF),1,IN) - NVIRA=NVIR(MYL) - LNA=LN+NSYS(MYL) - IIA=IROW(LNA+1) - TSUM=D0 - DO 130 I=1,NVIRA - SUM=COPI*C(INMY)*C(INMY) - INMY=INMY+1 - TSUM=TSUM+SUM - IIA=IIA+LNA+I - FC(IIA)=FC(IIA)+SUM -130 CONTINUE - GO TO 106 -C TRIPLET-TRIPLET AND SINGLET-SINGLET INTERACTIONS -25 IFT=1 - IF(INDA.GT.IRC(3))IFT=0 - CALL IPO_CPF(IPOA,NVIR,MUL,NSYM,MYL,IFT) - IN=0 - TSUM=D0 - DO 70 IASYM=1,NSYM - IAB=IPOF(IASYM+1)-IPOF(IASYM) - IF(IAB.EQ.0)GO TO 70 - ICSYM=MUL(MYL,IASYM) - IF(NVIR(ICSYM).EQ.0)GO TO 70 - IF(IDENS.EQ.1)GO TO 75 - IF(MYL.NE.1)GO TO 30 - IF(IFT.EQ.0)CALL SQUAR_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) -C IF(IFT.EQ.1)CALL SQUARN_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) - IF(IFT.EQ.1)CALL SQUARM_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) - NAA=NVIR(IASYM)*NVIR(IASYM) - CALL SETZ(B,NAA) - CALL FMMM(F(IPOF(IASYM)+1),A,B,NVIR(IASYM),NVIR(IASYM), - *NVIR(IASYM)) - CALL SETZ(A,NAA) - CALL DAXPY_(NAA,FACS,B,1,A,1) - IF(IFT.EQ.1)GO TO 230 - CALL SIADD_CPF(A,S(INMY+IPOA(IASYM)),NVIR(IASYM)) - CALL SETZ(A,NAA) - CALL DAXPY_(NAA,FACW,B,1,A,1) - CALL SIADD_CPF(A,W(INMY+IPOA(IASYM)),NVIR(IASYM)) - GO TO 70 -230 CALL TRADD_CPF(A,S(INMY+IPOA(IASYM)),NVIR(IASYM)) - CALL SETZ(A,NAA) - CALL DAXPY_(NAA,FACW,B,1,A,1) - CALL TRADD_CPF(A,W(INMY+IPOA(IASYM)),NVIR(IASYM)) - GO TO 70 -30 NAC=NVIR(IASYM)*NVIR(ICSYM) - CALL SETZ(A,NAC) - IF(IASYM.GT.ICSYM)GO TO 31 - CALL FMMM(F(IPOF(IASYM)+1),C(INMY+IPOA(ICSYM)),A, - *NVIR(IASYM),NVIR(ICSYM),NVIR(IASYM)) - CALL DAXPY_(NAC,FACS,A,1,S(INMY+IPOA(ICSYM)),1) - CALL DAXPY_(NAC,FACW,A,1,W(INMY+IPOA(ICSYM)),1) - GO TO 70 -31 CALL FMMM(C(INMY+IPOA(IASYM)),F(IPOF(IASYM)+1),A, - *NVIR(ICSYM),NVIR(IASYM),NVIR(IASYM)) - CALL DAXPY_(NAC,FACS,A,1,S(INMY+IPOA(IASYM)),1) - CALL DAXPY_(NAC,FACW,A,1,W(INMY+IPOA(IASYM)),1) - GO TO 70 -75 IF(MYL.NE.1)GO TO 330 - IF(IFT.EQ.0)CALL SQUAR_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) - IF(IFT.EQ.1)CALL SQUARM_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) - GO TO 255 -330 IF(IASYM.GT.ICSYM)GO TO 231 - NAC=NVIR(IASYM)*NVIR(ICSYM) - IF(IFT.EQ.0)CALL DCOPY_(NAC,C(INMY+IPOA(ICSYM)),1,A,1) - IF(IFT.EQ.1)CALL VNEG_CPF(C(INMY+IPOA(ICSYM)),1,A,1,NAC) - GO TO 255 -231 CALL MTRANS_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM),NVIR(ICSYM)) -255 CALL FMUL2_CPF(A,A,B,NVIR(IASYM),NVIR(IASYM),NVIR(ICSYM)) - IPF=IPOF(IASYM)+1 - ENPQ=(D1-THET(INDA,INDA)/D2)*(ENP(INDA)+ENP(INDA)-D1)+ - *THET(INDA,INDA)/D2 - COPI=D1/ENPQ - CALL VSMA(B,1,COPI,F(IPF),1,F(IPF),1,IAB) - NVIRA=NVIR(IASYM) - NVIRC=NVIR(ICSYM) - INN=1 - LNC=LN+NSYS(ICSYM) - IIC=IROW(LNC+1) - DO 105 I=1,NVIRC - SUM=DDOT_(NVIRA,A(INN),1,A(INN),1) - SUM=COPI*SUM - TSUM=TSUM+SUM - IIC=IIC+LNC+I - FC(IIC)=FC(IIC)+SUM - INN=INN+NVIRA -105 CONTINUE -70 CONTINUE - IF(IDENS.EQ.0)GO TO 40 - TSUM=TSUM/D2 -106 IJ=0 - DO 107 I=1,LN - IJ=IJ+I - FC(IJ)=FC(IJ)+IOC(I)*TSUM -107 CONTINUE -40 CONTINUE - ITURN=1 - IF(IDENS.EQ.1)GO TO 90 -300 CALL MDSQ2(C,S,W,MUL,INDEX,JSY,NDIAG,INUM,IRC(3), - *LSYM,NVIRT,SQ2) - IF(IPRINT.GE.15) THEN - WRITE(6,'(A,/,(10F12.6))')' S,AB',(S(I),I=1,JSC(4)) - CALL XFLUSH(6) - WRITE(6,'(A,/,(10F12.6))')' W,AB',(W(I),I=1,JSC(4)) - CALL XFLUSH(6) - IF(IDENS.EQ.1)WRITE(6,'(A,/,(10F12.6))') - & ' FC,AB',(FC(I),I=1,NOB2) - END IF - RETURN - END diff -Nru openmolcas-22.02/src/cpf/mab.F90 openmolcas-22.10/src/cpf/mab.F90 --- openmolcas-22.02/src/cpf/mab.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/mab.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,224 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine MAB(ICASE,JSY,INDX,C,S,FC,A,B,F,W,THET,ENP,NII) + +use cpf_global, only: IDENS, IFIRST, IPRINT, IRC, IREF0, IROW, JSC, LN, LSYM, NDIAG, NORBT, NSYM, NSYS, NVIR, NVIRT, SQ2 +use Symmetry_Info, only: Mul +use Constants, only: Zero, One, Two, Half +use Definitions, only: wp, iwp, u6, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: ICASE(*), JSY(*), INDX(*), NII +real(kind=wp), intent(inout) :: C(*), S(*), FC(*), W(*) +real(kind=wp), intent(_OUT_) :: A(*), B(*), F(*) +real(kind=wp), intent(in) :: THET(NII,NII), ENP(*) +integer(kind=iwp) :: I, IAB, IASYM, ICSYM, IFT, II1, IIA, IIC, IIN, IJ, INDA, INMY, INN, INUM, IOC(55), IPOA(9), IPF, IPOF(9), & + ITAIL, ITURN, JOJ, LNA, LNC, MYL, MYSYM, NA, NA1, NA2, NAA, NAB, NAC, NB, NCLIM, NOB2, NVIRA, NVIRC +real(kind=wp) :: COPI, ENPQ, FACS, FACW, RSUM, TR, TSUM +integer(kind=iwp), external :: ICUNP, JSUNP +real(kind=r8), external :: DDOT_ + +NAB = 0 ! dummy initialize +NOB2 = IROW(NORBT+1) +if (IPRINT >= 15) then + write(u6,'(A,/,(10F12.6))') ' S,AB',(S(I),I=1,JSC(4)) + write(u6,'(A,/,(10F12.6))') ' W,AB',(W(I),I=1,JSC(4)) + if (IDENS == 1) write(u6,'(A,/,(10F12.6))') ' FC,AB',(FC(I),I=1,NOB2) +end if +INUM = IRC(4)-IRC(3) +call MPSQ2(C,S,W,MUL,INDX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) +NCLIM = 4 +if (IFIRST /= 0) NCLIM = 2 +! MOVE FOCK (DENSITY) MATRIX TO F IN SYMMETRY BLOCKS +call IPO_CPF(IPOF,NVIR,MUL,NSYM,1,-1) +ITURN = 0 +do + do IASYM=1,NSYM + IAB = IPOF(IASYM) + NA1 = NSYS(IASYM)+1 + NA2 = NSYS(IASYM+1) + do NA=NA1,NA2 + do NB=NA1,NA2 + IAB = IAB+1 + if (NA >= NB) NAB = IROW(LN+NA)+LN+NB + if (NB > NA) NAB = IROW(LN+NB)+LN+NA + if (ITURN /= 1) then + if (IDENS == 0) F(IAB) = Zero + if (IDENS == 1) F(IAB) = FC(NAB) + if (NA /= NB) F(IAB) = FC(NAB) + else + if (NA < NB) FC(NAB) = F(IAB) + end if + end do + end do + end do + if (ITURN /= 0) then + TR = Zero + IJ = 0 + do I=1,NORBT + IJ = IJ+I + TR = TR+FC(IJ) + end do + if (iPrint >= 15) write(u6,310) TR + exit + end if + II1 = 0 + ITAIL = IRC(NCLIM) + do INDA=1,ITAIL + if (IDENS /= 0) then + do I=1,LN + II1 = II1+1 + JOJ = ICUNP(ICASE,II1) + if (JOJ > 1) JOJ = JOJ-1 + IOC(I) = JOJ + end do + end if + if (INDA <= IRC(1)) then + if ((IDENS == 0) .or. (INDA == IREF0)) cycle + ENPQ = (One-THET(INDA,INDA)*Half)*(ENP(INDA)+ENP(INDA)-One)+THET(INDA,INDA)*Half + TSUM = C(INDA)*C(INDA)/ENPQ + else + MYSYM = JSUNP(JSY,INDA) + MYL = MUL(MYSYM,LSYM) + INMY = INDX(INDA)+1 + ENPQ = (One-THET(INDA,INDA)*Half)*(ENP(INDA)+ENP(INDA)-One)+THET(INDA,INDA)*Half + FACS = sqrt(ENP(INDA))*sqrt(ENP(INDA))/ENPQ + FACW = (FACS*(Two-THET(INDA,INDA))/ENPQ)*ENP(INDA)-FACS + if (INDA > IRC(2)) then + ! TRIPLET-TRIPLET AND SINGLET-SINGLET INTERACTIONS + IFT = 1 + if (INDA > IRC(3)) IFT = 0 + call IPO_CPF(IPOA,NVIR,MUL,NSYM,MYL,IFT) + IIN = 0 + TSUM = Zero + do IASYM=1,NSYM + IAB = IPOF(IASYM+1)-IPOF(IASYM) + if (IAB == 0) cycle + ICSYM = MUL(MYL,IASYM) + if (NVIR(ICSYM) == 0) cycle + if (IDENS /= 1) then + if (MYL == 1) then + if (IFT == 0) call SQUAR(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + !if (IFT == 1) call SQUARN(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + if (IFT == 1) call SQUARM(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + NAA = NVIR(IASYM)*NVIR(IASYM) + call FMMM(F(IPOF(IASYM)+1),A,B,NVIR(IASYM),NVIR(IASYM),NVIR(IASYM)) + A(1:NAA) = FACS*B(1:NAA) + if (IFT /= 1) then + call SIADD(A,S(INMY+IPOA(IASYM)),NVIR(IASYM)) + A(1:NAA) = FACW*B(1:NAA) + call SIADD(A,W(INMY+IPOA(IASYM)),NVIR(IASYM)) + else + call TRADD(A,S(INMY+IPOA(IASYM)),NVIR(IASYM)) + A(1:NAA) = FACW*B(1:NAA) + call TRADD(A,W(INMY+IPOA(IASYM)),NVIR(IASYM)) + end if + else + NAC = NVIR(IASYM)*NVIR(ICSYM) + if (IASYM <= ICSYM) then + I = INMY+IPOA(ICSYM) + call FMMM(F(IPOF(IASYM)+1),C(I),A,NVIR(IASYM),NVIR(ICSYM),NVIR(IASYM)) + else + I = INMY+IPOA(IASYM) + call FMMM(C(I),F(IPOF(IASYM)+1),A,NVIR(ICSYM),NVIR(IASYM),NVIR(IASYM)) + end if + S(I:I+NAC-1) = S(I:I+NAC-1)+FACS*A(1:NAC) + W(I:I+NAC-1) = W(I:I+NAC-1)+FACW*A(1:NAC) + end if + else + if (MYL == 1) then + if (IFT == 0) call SQUAR(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + if (IFT == 1) call SQUARM(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + else if (IASYM <= ICSYM) then + NAC = NVIR(IASYM)*NVIR(ICSYM) + if (IFT == 0) call DCOPY_(NAC,C(INMY+IPOA(ICSYM)),1,A,1) + if (IFT == 1) call VNEG(NAC,C(INMY+IPOA(ICSYM)),1,A,1) + else + call MTRANS(C(INMY+IPOA(IASYM)),A,NVIR(IASYM),NVIR(ICSYM)) + end if + call FMUL2(A,A,B,NVIR(IASYM),NVIR(IASYM),NVIR(ICSYM)) + IPF = IPOF(IASYM)+1 + ENPQ = (One-THET(INDA,INDA)*Half)*(ENP(INDA)+ENP(INDA)-One)+THET(INDA,INDA)*Half + COPI = One/ENPQ + F(IPF:IPF+IAB-1) = F(IPF:IPF+IAB-1)+COPI*B(1:IAB) + NVIRA = NVIR(IASYM) + NVIRC = NVIR(ICSYM) + INN = 1 + LNC = LN+NSYS(ICSYM) + IIC = IROW(LNC+1) + do I=1,NVIRC + RSUM = DDOT_(NVIRA,A(INN),1,A(INN),1) + RSUM = COPI*RSUM + TSUM = TSUM+RSUM + IIC = IIC+LNC+I + FC(IIC) = FC(IIC)+RSUM + INN = INN+NVIRA + end do + end if + end do + if (IDENS == 0) cycle + TSUM = TSUM*Half + else + ! DOUBLET-DOUBLET INTERACTIONS + if (NVIR(MYL) == 0) cycle + if (IDENS /= 1) then + call FMMM(F(IPOF(MYL)+1),C(INMY),A,NVIR(MYL),1,NVIR(MYL)) + S(INMY:INMY+NVIR(MYL)-1) = S(INMY:INMY+NVIR(MYL)-1)+FACS*A(1:NVIR(MYL)) + W(INMY:INMY+NVIR(MYL)-1) = W(INMY:INMY+NVIR(MYL)-1)+FACW*A(1:NVIR(MYL)) + cycle + else + call FMUL2(C(INMY),C(INMY),A,NVIR(MYL),NVIR(MYL),1) + IPF = IPOF(MYL)+1 + IIN = IPOF(MYL+1)-IPOF(MYL) + ENPQ = (One-THET(INDA,INDA)*Half)*(ENP(INDA)+ENP(INDA)-One)+THET(INDA,INDA)*Half + COPI = One/ENPQ + F(IPF:IPF+IIN-1) = F(IPF:IPF+IIN-1)+COPI*A(1:IIN) + NVIRA = NVIR(MYL) + LNA = LN+NSYS(MYL) + IIA = IROW(LNA+1) + TSUM = Zero + do I=1,NVIRA + RSUM = COPI*C(INMY)*C(INMY) + INMY = INMY+1 + TSUM = TSUM+RSUM + IIA = IIA+LNA+I + FC(IIA) = FC(IIA)+RSUM + end do + end if + end if + end if + IJ = 0 + do I=1,LN + IJ = IJ+I + FC(IJ) = FC(IJ)+IOC(I)*TSUM + end do + end do + ITURN = 1 + if (IDENS /= 1) exit +end do +call MDSQ2(C,S,W,MUL,INDX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) +if (IPRINT >= 15) then + write(u6,'(A,/,(10F12.6))') ' S,AB',(S(I),I=1,JSC(4)) + write(u6,'(A,/,(10F12.6))') ' W,AB',(W(I),I=1,JSC(4)) + if (IDENS == 1) write(u6,'(A,/,(10F12.6))') ' FC,AB',(FC(I),I=1,NOB2) +end if + +return + +310 format(/,6X,'TRACE OF DENSITY MATRIX',F16.8) + +end subroutine MAB diff -Nru openmolcas-22.02/src/cpf/mai.f openmolcas-22.10/src/cpf/mai.f --- openmolcas-22.02/src/cpf/mai.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/mai.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,249 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE MAI(JSY,INDEX,C,S,FC,BUFIN,IBUFIN,A,B,FK,DBK,W,THET, - *ENP,EPP,NII,KTYP) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" - DIMENSION JSY(*),INDEX(*),C(*),S(*),FC(*),BUFIN(*),IBUFIN(*), - & A(*),B(*),FK(*),DBK(*),W(*),THET(NII,NII),ENP(*),EPP(*) -C KTYP=0 , (A/I) INTEGRALS -C KTYP=1 , (AI/JK) INTEGRALS - DIMENSION IPOB(9) - PARAMETER (IPOW6=2**6,IPOW13=2**13,IPOW19=2**19) - PARAMETER (IPOW10=2**10,IPOW20=2**20) -* - JSYM(L)=JSUNP_CPF(JSY,L) -* -C IF(IDENS.EQ.1)WRITE(6,876)(FC(I),I=1,NOB2) -C 876 FORMAT(1X,'AI',5F12.6) - NK = 0 ! dummy initialize - NSK = 0 ! dummy initialize - INUM=IRC(4)-IRC(3) - CALL MPSQ2(C,S,W,MUL,INDEX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) - NVT=IROW(NVIRT+1) - ICHK=0 - IJOLD=0 - NOB2=IROW(NORBT+1) - NOT2=IROW(LN+1) - NOTT=2*NOT2 - NOVST=LN*NVIRT+1+NVT - LBUF0=RTOI*LBUF - LBUF1=LBUF0+LBUF+1 - LBUF2=LBUF1+1 - IF(KTYP.EQ.0)IADD10=IAD10(9) - IF(KTYP.EQ.1)IADD10=IAD10(7) -100 CALL dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) - CALL iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.EQ.0)GO TO 100 - IF(LEN.LT.0)GO TO 200 - DO 10 II=1,LEN - IND=ICOP1(II) - IF(ICHK.NE.0)GO TO 460 - IF(IND.NE.0)GO TO 11 - ICHK=1 - GO TO 10 -460 ICHK=0 - ITURN=0 - IF(IDENS.EQ.1.AND.IJOLD.NE.0)GO TO 20 -21 ITURN=1 - IF(KTYP.EQ.1)GO TO 9 - NK=IND - IJOLD=NK - NSK=NSM(NK) - GO TO 20 -9 INDI=IND -* NI=MOD(INDI,IPOW10) -* NJ=MOD(INDI/IPOW10,IPOW10) -* NK=MOD(INDI/IPOW20,IPOW10) - NI=IBITS(INDI,0,10) - NJ=IBITS(INDI,10,10) - NK=IBITS(INDI,20,10) - NSIJ=MUL(NSM(NI),NSM(NJ)) - NSK=MUL(NSIJ,NSM(NK)) - IJ=IROW(NI)+NJ - IF(IJ.EQ.IJOLD)GO TO 20 - IJOLD=IJ - IADR=LASTAD(NOVST+NOTT+IJ) - DO 105 INN=1,NOB2 - FC(INN)=D0 -105 CONTINUE -90 CALL iDAFILE(Lu_TiABIJ,2,IBUFIN,LBUF2,IADR) - LENGTH=IBUFIN(LBUF1) - IADR=IBUFIN(LBUF2) - IF(LENGTH.EQ.0)GO TO 91 - CALL SCATTER(LENGTH,FC,IBUFIN(LBUF0+1),BUFIN) -91 IF(IADR.NE.-1) GO TO 90 -C FORM VECTOR FK -20 NA1=NSYS(NSK)+1 - NA2=NSYS(NSK+1) - INK=0 - IF(NA2.LT.NA1)GO TO 10 - DO 13 NA=NA1,NA2 - INK=INK+1 - NAK=IROW(LN+NA)+NK - IF(ITURN.EQ.0)FC(NAK)=FK(INK) - IF(ITURN.EQ.1)FK(INK)=FC(NAK) -13 CONTINUE - IF(ITURN.EQ.0)GO TO 21 - GO TO 10 -11 IF(INK.EQ.0)GO TO 10 -CPAM97 ITYP=IAND(IND,63) -CPAM97 ICP2=IAND(ISHFT(IND,-6),8191) -CPAM97 ICP1=IAND(ISHFT(IND,-19),8191) -* ITYP=MOD(IND,IPOW6) -* ICP2=MOD(IND/IPOW6,IPOW13) -* ICP1=MOD(IND/IPOW19,IPOW13) - ITYP=IBITS(IND, 0,6) - ICP2=IBITS(IND,6,13) - ICP1=IBITS(IND,19,13) - IF(ITYP.GT.1)GO TO 12 - INDA=ICP1 - INDB=IRC(1)+ICP2 - INNY=INDEX(INDB)+1 - IF(IDENS.EQ.1)GO TO 41 - IF(INDA.NE.IREF0)GO TO 42 - COPI=COP(II)/SQRT(ENP(INDB)) - CALL DAXPY_(INK,COPI,FK,1,S(INNY),1) - IF(ITER.EQ.1)GO TO 10 - TERM=DDOT_(INK,FK,1,C(INNY),1) - EPP(INDB)=EPP(INDB)+COPI*TERM - GO TO 10 -42 ENPQ=(D1-THET(INDA,INDB)/D2)*(ENP(INDA)+ENP(INDB)-D1)+ - *THET(INDA,INDB)/D2 - FACS=SQRT(ENP(INDA))*SQRT(ENP(INDB))/ENPQ - FACW=FACS*(D2-THET(INDA,INDB))/ENPQ - FACWA=FACW*ENP(INDA)-FACS - FACWB=FACW*ENP(INDB)-FACS - COPI=COP(II)*C(INDA) - CALL DAXPY_(INK,COPI*FACS,FK,1,S(INNY),1) - CALL DAXPY_(INK,COPI*FACWB,FK,1,W(INNY),1) - TERM=DDOT_(INK,FK,1,C(INNY),1) - S(INDA)=S(INDA)+COP(II)*FACS*TERM - W(INDA)=W(INDA)+COP(II)*FACWA*TERM - GO TO 10 -41 IF(INDA.EQ.IREF0)COPI=C(INDA)*COP(II)/ENP(INDB) - ENPQ=(D1-THET(INDA,INDB)/D2)*(ENP(INDA)+ENP(INDB)-D1)+ - *THET(INDA,INDB)/D2 - IF(INDA.NE.IREF0)COPI=C(INDA)*COP(II)/ENPQ - CALL DAXPY_(INK,COPI,C(INNY),1,FK,1) -C WRITE(6,654)NK,NSK,INDB -C 654 FORMAT(1X,'TYP1,NK,NSK,INDB',3I7) -C WRITE(6,653)(FK(I),I=1,INK) -C 653 FORMAT(1X,'FK',5F12.6) - GO TO 10 -12 IF(ITER.EQ.1)GO TO 10 - INDA=IRC(1)+ICP1 - INDB=IRC(ITYP)+ICP2 - INMY=INDEX(INDA)+1 - INNY=INDEX(INDB)+1 - MYSYM=JSYM(INDA) - NYSYM=MUL(MYSYM,NSK) - MYL=MUL(MYSYM,LSYM) - NYL=MUL(NYSYM,LSYM) - IFT=0 - IF(ITYP.EQ.2)IFT=1 - CALL IPO_CPF(IPOB,NVIR,MUL,NSYM,NYL,IFT) - NVM=NVIR(MYL) - IF(IDENS.EQ.1)GO TO 210 - ENPQ=(D1-THET(INDA,INDB)/D2)*(ENP(INDA)+ENP(INDB)-D1)+ - *THET(INDA,INDB)/D2 - FACS=SQRT(ENP(INDA))*SQRT(ENP(INDB))/ENPQ - FACW=FACS*(D2-THET(INDA,INDB))/ENPQ - FACWA=FACW*ENP(INDA)-FACS - FACWB=FACW*ENP(INDB)-FACS - CALL SETZ(DBK,INK) - CALL DAXPY_(INK,COP(II),FK,1,DBK,1) - IF(NYL.NE.1)GO TO 25 - IF(IFT.EQ.0)CALL SQUAR_CPF(C(INNY+IPOB(MYL)),A,NVM) - IF(IFT.EQ.1)CALL SQUARM_CPF(C(INNY+IPOB(MYL)),A,NVM) - CALL SETZ(B,NVM) - CALL FMMM(DBK,A,B,1,NVM,INK) - CALL DAXPY_(NVM,FACS,B,1,S(INMY),1) - CALL DAXPY_(NVM,FACWA,B,1,W(INMY),1) - SIGN=D1 - IF(IFT.EQ.1)SIGN=-D1 - IOUT=INNY+IPOB(MYL)-1 - DO 125 I=1,NVM - DO 130 J=1,I - IOUT=IOUT+1 - TERM=DBK(I)*C(INMY+J-1)+SIGN*DBK(J)*C(INMY+I-1) - S(IOUT)=S(IOUT)+FACS*TERM - W(IOUT)=W(IOUT)+FACWB*TERM -130 CONTINUE - IF(IFT.EQ.1)GO TO 125 - TERM=DBK(I)*C(INMY+I-1) - S(IOUT)=S(IOUT)-FACS*TERM - W(IOUT)=W(IOUT)-FACWB*TERM -125 CONTINUE - GO TO 10 -25 NKM=INK*NVM - CALL SETZ(B,NVM) - IF(NSK.GT.MYL)GO TO 26 - IF(IFT.EQ.1)CALL VNEG_CPF(DBK,1,DBK,1,INK) - CALL FMMM(DBK,C(INNY+IPOB(MYL)),B,1,NVM,INK) - CALL DAXPY_(NVM,FACS,B,1,S(INMY),1) - CALL DAXPY_(NVM,FACWA,B,1,W(INMY),1) - CALL SETZ(B,NKM) - CALL FMMM(DBK,C(INMY),B,INK,NVM,1) - CALL DAXPY_(NKM,FACS,B,1,S(INNY+IPOB(MYL)),1) - CALL DAXPY_(NKM,FACWB,B,1,W(INNY+IPOB(MYL)),1) - GO TO 10 -26 CALL FMMM(C(INNY+IPOB(NSK)),DBK,B,NVM,1,INK) - CALL DAXPY_(NVM,FACS,B,1,S(INMY),1) - CALL DAXPY_(NVM,FACWA,B,1,W(INMY),1) - CALL SETZ(B,NKM) - CALL FMMM(C(INMY),DBK,B,NVM,INK,1) - CALL DAXPY_(NKM,FACS,B,1,S(INNY+IPOB(NSK)),1) - CALL DAXPY_(NKM,FACWB,B,1,W(INNY+IPOB(NSK)),1) - GO TO 10 -210 CALL SETZ(B,INK) - ENPQ=(D1-THET(INDA,INDB)/D2)*(ENP(INDA)+ENP(INDB)-D1)+ - *THET(INDA,INDB)/D2 - COPI=COP(II)/ENPQ -C WRITE(6,652)IFT,NYL,NSK,MYL,INDA,INDB -C 652 FORMAT(1X,'TYP2',6I7) - IF(NYL.NE.1)GO TO 225 - IF(IFT.EQ.0)CALL SQUAR_CPF(C(INNY+IPOB(MYL)),A,NVM) - IF(IFT.EQ.1)CALL SQUARN_CPF(C(INNY+IPOB(MYL)),A,NVM) - CALL FMMM(C(INMY),A,B,1,INK,NVM) -227 CALL VSMA(B,1,COPI,FK,1,FK,1,INK) -C WRITE(6,651)(FK(I),I=1,INK) -C 651 FORMAT(1X,'FK',5F12.6) - GO TO 10 -225 IF(NSK.GT.MYL)GO TO 226 - CALL FMMM(C(INNY+IPOB(MYL)),C(INMY),B,INK,1,NVM) - IF(IFT.EQ.1)COPI=-COPI - GO TO 227 -226 CALL FMMM(C(INMY),C(INNY+IPOB(NSK)),B,1,INK,NVM) - GO TO 227 -10 CONTINUE - GO TO 100 -200 IF(IDENS.EQ.0)GO TO 201 - NA1=NSYS(NSK)+1 - NA2=NSYS(NSK+1) - INK=0 - IF(NA2.LT.NA1)GO TO 201 - DO 213 NA=NA1,NA2 - INK=INK+1 - NAK=IROW(LN+NA)+NK - FC(NAK)=FK(INK) -213 CONTINUE -201 CALL MDSQ2(C,S,W,MUL,INDEX,JSY,NDIAG,INUM,IRC(3), - *LSYM,NVIRT,SQ2) -C IF(IDENS.EQ.1)WRITE(6,876)(FC(I),I=1,NOB2) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/mai.F90 openmolcas-22.10/src/cpf/mai.F90 --- openmolcas-22.02/src/cpf/mai.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/mai.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,278 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine MAI(JSY,INDX,C,S,FC,BUFIN,A,B,FK,DBK,W,THET,ENP,EPP,NII,KTYP) +! KTYP=0 , (A/I) INTEGRALS +! KTYP=1 , (AI/JK) INTEGRALS + +use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc +use cpf_global, only: IDENS, IRC, IREF0, IROW, ITER, LASTAD, LBUF, LN, LSYM, Lu_CIGuga, Lu_TiABIJ, NDIAG, NORBT, NSM, NSYM, NSYS, & + NVIR, NVIRT, SQ2 +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Constants, only: Zero, One, Two, Half +use Definitions, only: wp, iwp, r8, RtoI + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: JSY(*), INDX(*), NII, KTYP +real(kind=wp), intent(inout) :: C(*), S(*), FK(*), W(*), EPP(*) +real(kind=wp), intent(_OUT_) :: FC(*), BUFIN(*), A(*), B(*), DBK(*) +real(kind=wp), intent(in) :: THET(NII,NII), ENP(*) +integer(kind=iwp) :: IADD10, IADR, ICHK, ICP1, ICP2, IFT, IJ, IJOLD, ILEN, IND, INDA, INDB, INDI, INK, INMY, INNY, INUM, IOUT, & + IPOB(9), ITURN, ITYP, LBUF0, LBUF1, LBUF2, LENGTH, MYL, MYSYM, NA1, NA2, NAK, NI, NJ, NK, NKM, NOB2, NOT2, & + NOTT, NOVST, NSIJ, NSK, NVM, NVT, NYL, NYSYM +real(kind=wp) :: COPI, ENPQ, FACS, FACW, FACWA, FACWB, SGN, TERM +logical(kind=iwp) :: Skip +integer(kind=iwp), external :: JSUNP +real(kind=r8), external :: DDOT_ + +call MAI_INTERNAL(BUFIN) + +! This is to allow type punning without an explicit interface +contains + +subroutine MAI_INTERNAL(BUFIN) + + real(kind=wp), target, intent(_OUT_) :: BUFIN(*) + integer(kind=iwp), pointer :: IBUFIN(:) + integer(kind=iwp) :: I, II, J, NA + + call c_f_pointer(c_loc(BUFIN),iBUFIN,[1]) + + !if (IDENS == 1) write(u6,876) (FC(I),I=1,NOB2) + NK = 0 ! dummy initialize + NSK = 0 ! dummy initialize + INUM = IRC(4)-IRC(3) + call MPSQ2(C,S,W,MUL,INDX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) + NVT = IROW(NVIRT+1) + ICHK = 0 + IJOLD = 0 + NOB2 = IROW(NORBT+1) + NOT2 = IROW(LN+1) + NOTT = 2*NOT2 + NOVST = LN*NVIRT+1+NVT + LBUF0 = RTOI*LBUF + LBUF1 = LBUF0+LBUF+1 + LBUF2 = LBUF1+1 + if (KTYP == 0) IADD10 = IAD10(9) + if (KTYP == 1) IADD10 = IAD10(7) + do + call dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) + call iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN == 0) cycle + if (ILEN < 0) exit + do II=1,ILEN + IND = ICOP1(II) + if (ICHK == 0) then + if (IND /= 0) then + if (INK == 0) cycle + ITYP = ibits(IND,0,6) + ICP2 = ibits(IND,6,13) + ICP1 = ibits(IND,19,13) + if (ITYP <= 1) then + INDA = ICP1 + INDB = IRC(1)+ICP2 + INNY = INDX(INDB)+1 + if (IDENS /= 1) then + if (INDA == IREF0) then + COPI = COP(II)/sqrt(ENP(INDB)) + S(INNY:INNY+INK-1) = S(INNY:INNY+INK-1)+COPI*FK(1:INK) + if (ITER /= 1) then + TERM = DDOT_(INK,FK,1,C(INNY),1) + EPP(INDB) = EPP(INDB)+COPI*TERM + end if + else + ENPQ = (One-THET(INDA,INDB)*Half)*(ENP(INDA)+ENP(INDB)-One)+THET(INDA,INDB)*Half + FACS = sqrt(ENP(INDA))*sqrt(ENP(INDB))/ENPQ + FACW = FACS*(Two-THET(INDA,INDB))/ENPQ + FACWA = FACW*ENP(INDA)-FACS + FACWB = FACW*ENP(INDB)-FACS + COPI = COP(II)*C(INDA) + S(INNY:INNY+INK-1) = S(INNY:INNY+INK-1)+COPI*FACS*FK(1:INK) + W(INNY:INNY+INK-1) = W(INNY:INNY+INK-1)+COPI*FACWB*FK(1:INK) + TERM = DDOT_(INK,FK,1,C(INNY),1) + S(INDA) = S(INDA)+COP(II)*FACS*TERM + W(INDA) = W(INDA)+COP(II)*FACWA*TERM + end if + else + if (INDA == IREF0) COPI = C(INDA)*COP(II)/ENP(INDB) + ENPQ = (One-THET(INDA,INDB)*Half)*(ENP(INDA)+ENP(INDB)-One)+THET(INDA,INDB)*Half + if (INDA /= IREF0) COPI = C(INDA)*COP(II)/ENPQ + FK(1:INK) = FK(1:INK)+COPI*C(INNY:INNY+INK-1) + !write(u6,654) NK,NSK,INDB + !write(u6,653) (FK(I),I=1,INK) + end if + else if (ITER /= 1) then + INDA = IRC(1)+ICP1 + INDB = IRC(ITYP)+ICP2 + INMY = INDX(INDA)+1 + INNY = INDX(INDB)+1 + MYSYM = JSUNP(JSY,INDA) + NYSYM = MUL(MYSYM,NSK) + MYL = MUL(MYSYM,LSYM) + NYL = MUL(NYSYM,LSYM) + IFT = 0 + if (ITYP == 2) IFT = 1 + call IPO_CPF(IPOB,NVIR,MUL,NSYM,NYL,IFT) + NVM = NVIR(MYL) + if (IDENS /= 1) then + ENPQ = (One-THET(INDA,INDB)*Half)*(ENP(INDA)+ENP(INDB)-One)+THET(INDA,INDB)*Half + FACS = sqrt(ENP(INDA))*sqrt(ENP(INDB))/ENPQ + FACW = FACS*(Two-THET(INDA,INDB))/ENPQ + FACWA = FACW*ENP(INDA)-FACS + FACWB = FACW*ENP(INDB)-FACS + DBK(1:INK) = COP(II)*FK(1:INK) + if (NYL == 1) then + if (IFT == 0) call SQUAR(C(INNY+IPOB(MYL)),A,NVM) + if (IFT == 1) call SQUARM(C(INNY+IPOB(MYL)),A,NVM) + call FMMM(DBK,A,B,1,NVM,INK) + S(INMY:INMY+NVM-1) = S(INMY:INMY+NVM-1)+FACS*B(1:NVM) + W(INMY:INMY+NVM-1) = W(INMY:INMY+NVM-1)+FACWA*B(1:NVM) + SGN = One + if (IFT == 1) SGN = -One + IOUT = INNY+IPOB(MYL)-1 + do I=1,NVM + do J=1,I + IOUT = IOUT+1 + TERM = DBK(I)*C(INMY+J-1)+SGN*DBK(J)*C(INMY+I-1) + S(IOUT) = S(IOUT)+FACS*TERM + W(IOUT) = W(IOUT)+FACWB*TERM + end do + if (IFT /= 1) then + TERM = DBK(I)*C(INMY+I-1) + S(IOUT) = S(IOUT)-FACS*TERM + W(IOUT) = W(IOUT)-FACWB*TERM + end if + end do + else + NKM = INK*NVM + if (NSK <= MYL) then + if (IFT == 1) DBK(1:INK) = -DBK(1:INK) + I = INNY+IPOB(MYL) + call FMMM(DBK,C(I),B,1,NVM,INK) + S(INMY:INMY+NVM-1) = S(INMY:INMY+NVM-1)+FACS*B(1:NVM) + W(INMY:INMY+NVM-1) = W(INMY:INMY+NVM-1)+FACWA*B(1:NVM) + call FMMM(DBK,C(INMY),B,INK,NVM,1) + else + I = INNY+IPOB(NSK) + call FMMM(C(I),DBK,B,NVM,1,INK) + S(INMY:INMY+NVM-1) = S(INMY:INMY+NVM-1)+FACS*B(1:NVM) + W(INMY:INMY+NVM-1) = W(INMY:INMY+NVM-1)+FACWA*B(1:NVM) + call FMMM(C(INMY),DBK,B,NVM,INK,1) + end if + S(I:I+NKM-1) = S(I:I+NKM-1)+FACS*B(1:NKM) + W(I:I+NKM-1) = W(I:I+NKM-1)+FACWB*B(1:NKM) + end if + else + ENPQ = (One-THET(INDA,INDB)*Half)*(ENP(INDA)+ENP(INDB)-One)+THET(INDA,INDB)*Half + COPI = COP(II)/ENPQ + !write(u6,652) IFT,NYL,NSK,MYL,INDA,INDB + if (NYL == 1) then + if (IFT == 0) call SQUAR(C(INNY+IPOB(MYL)),A,NVM) + if (IFT == 1) call SQUARN(C(INNY+IPOB(MYL)),A,NVM) + call FMMM(C(INMY),A,B,1,INK,NVM) + else if (NSK <= MYL) then + call FMMM(C(INNY+IPOB(MYL)),C(INMY),B,INK,1,NVM) + if (IFT == 1) COPI = -COPI + else + call FMMM(C(INMY),C(INNY+IPOB(NSK)),B,1,INK,NVM) + end if + FK(1:INK) = FK(1:INK)+COPI*B(1:INK) + !write(u6,651) (FK(I),I=1,INK) + end if + end if + else + ICHK = 1 + end if + else + ICHK = 0 + ITURN = 0 + Skip = .false. + if ((IDENS == 1) .and. (IJOLD /= 0)) Skip = .true. + do + if (Skip) then + Skip = .false. + else + ITURN = 1 + if (KTYP /= 1) then + NK = IND + IJOLD = NK + NSK = NSM(NK) + else + INDI = IND + NI = ibits(INDI,0,10) + NJ = ibits(INDI,10,10) + NK = ibits(INDI,20,10) + NSIJ = MUL(NSM(NI),NSM(NJ)) + NSK = MUL(NSIJ,NSM(NK)) + IJ = IROW(NI)+NJ + if (IJ /= IJOLD) then + IJOLD = IJ + IADR = LASTAD(NOVST+NOTT+IJ) + FC(1:NOB2) = Zero + do + call iDAFILE(Lu_TiABIJ,2,IBUFIN,LBUF2,IADR) + LENGTH = IBUFIN(LBUF1) + IADR = IBUFIN(LBUF2) + if (LENGTH /= 0) call SCATTER(LENGTH,FC,IBUFIN(LBUF0+1:LBUF0+LENGTH),BUFIN) + if (IADR == -1) exit + end do + end if + end if + end if + ! FORM VECTOR FK + NA1 = NSYS(NSK)+1 + NA2 = NSYS(NSK+1) + INK = 0 + if (NA2 < NA1) exit + do NA=NA1,NA2 + INK = INK+1 + NAK = IROW(LN+NA)+NK + if (ITURN == 0) FC(NAK) = FK(INK) + if (ITURN == 1) FK(INK) = FC(NAK) + end do + if (ITURN /= 0) exit + end do + end if + end do + end do + if (IDENS /= 0) then + NA1 = NSYS(NSK)+1 + NA2 = NSYS(NSK+1) + INK = 0 + do NA=NA1,NA2 + INK = INK+1 + NAK = IROW(LN+NA)+NK + FC(NAK) = FK(INK) + end do + end if + call MDSQ2(C,S,W,MUL,INDX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) + !if (IDENS == 1) write(u6,876) (FC(I),I=1,NOB2) + + nullify(IBUFIN) + + return + + !651 format(1X,'FK',5F12.6) + !652 format(1X,'TYP2',6I7) + !653 format(1X,'FK',5F12.6) + !654 format(1X,'TYP1,NK,NSK,INDB',3I7) + !876 format(1X,'AI',5F12.6) + +end subroutine MAI_INTERNAL + +end subroutine MAI diff -Nru openmolcas-22.02/src/cpf/main.f openmolcas-22.10/src/cpf/main.f --- openmolcas-22.02/src/cpf/main.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/main.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,28 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - program main -#ifdef _FPE_TRAP_ - Use, Intrinsic :: IEEE_Exceptions -#endif - implicit real*8 (a-h,o-z) - Character*20 Module_Name - Parameter (Module_Name = 'cpf') -#ifdef _FPE_TRAP_ - Call IEEE_Set_Halting_Mode(IEEE_Usual,.True._4) -#endif - - Call Start(Module_Name) - Call cpf(ireturn) - Call Finish(ireturn) - end diff -Nru openmolcas-22.02/src/cpf/main.F90 openmolcas-22.10/src/cpf/main.F90 --- openmolcas-22.02/src/cpf/main.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/main.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,31 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +program Main + +#ifdef _FPE_TRAP_ +use, intrinsic :: IEEE_Exceptions, only: IEEE_Set_Halting_Mode, IEEE_Usual +use Definitions, only: DefInt +#endif +use Definitions, only: iwp + +implicit none +integer(kind=iwp) :: rc + +#ifdef _FPE_TRAP_ +call IEEE_Set_Halting_Mode(IEEE_Usual,.true._DefInt) +#endif + +call Start('cpf') +call cpf(rc) +call Finish(rc) + +end program Main diff -Nru openmolcas-22.02/src/cpf/mdiagc.f openmolcas-22.10/src/cpf/mdiagc.f --- openmolcas-22.02/src/cpf/mdiagc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/mdiagc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,77 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE MDIAGC(JSY,C,S,W,THET,ENP,NII) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" - DIMENSION JSY(*),C(*),S(*),W(*),THET(NII,NII),ENP(*) -* - JSYM(L)=JSUNP_CPF(JSY,L) -* - IADD25=IAD25S - CALL dDAFILE(Lu_25,2,COP,nCOP,IADD25) - IIC=0 - IND=0 - ILIM=4 - IF(IFIRST.NE.0)ILIM=2 - IRL=IRC(ILIM) - DO 100 INDA=1,IRL - NSS=MUL(JSYM(INDA),LSYM) - ENPQ=(D1-THET(INDA,INDA)/D2)*(ENP(INDA)+ENP(INDA)-D1)+ - *THET(INDA,INDA)/D2 - FACS=SQRT(ENP(INDA))*SQRT(ENP(INDA))/ENPQ - FACW=(FACS*(D2-THET(INDA,INDA))/ENPQ)*ENP(INDA)-FACS - IF(INDA.GT.IRC(1))GO TO 120 - IIC=IIC+1 - IND=IND+1 - S(IND)=S(IND)+FACS*COP(IIC)*C(IND) - W(IND)=W(IND)+FACW*COP(IIC)*C(IND) - IF(IIC.LT.nCOP)GO TO 100 - CALL dDAFILE(Lu_25,2,COP,nCOP,IADD25) - IIC=0 - GO TO 100 -120 IF(INDA.GT.IRC(2))GO TO 130 - NA1=NSYS(NSS)+1 - NA2=NSYS(NSS+1) - IF(NA2.LT.NA1)GO TO 100 - DO 121 NA=NA1,NA2 - IIC=IIC+1 - IND=IND+1 - S(IND)=S(IND)+FACS*COP(IIC)*C(IND) - W(IND)=W(IND)+FACW*COP(IIC)*C(IND) - IF(IIC.LT.nCOP)GO TO 121 - CALL dDAFILE(Lu_25,2,COP,nCOP,IADD25) - IIC=0 -121 CONTINUE - GO TO 100 -130 DO 141 NA=1,NVIRT - NSA=MUL(NSS,NSM(LN+NA)) - NB1=NSYS(NSA)+1 - NB2=NSYS(NSA+1) - IF(NB2.GT.NA)NB2=NA - IF(NB2.LT.NB1)GO TO 141 - DO 142 NB=NB1,NB2 - IIC=IIC+1 - IND=IND+1 - S(IND)=S(IND)+FACS*COP(IIC)*C(IND) - W(IND)=W(IND)+FACW*COP(IIC)*C(IND) - IF(IIC.LT.nCOP)GO TO 142 - CALL dDAFILE(Lu_25,2,COP,nCOP,IADD25) - IIC=0 -142 CONTINUE -141 CONTINUE -100 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/mdiagc.F90 openmolcas-22.10/src/cpf/mdiagc.F90 --- openmolcas-22.02/src/cpf/mdiagc.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/mdiagc.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,85 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine MDIAGC(JSY,C,S,W,THET,ENP,NII) + +use cpf_global, only: IAD25S, ILIM, IRC, LN, LSYM, Lu_25, NSM, NSYS, NVIRT +use guga_util_global, only: COP, nCOP +use Symmetry_Info, only: Mul +use Constants, only: One, Half, Two +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: JSY(*), NII +real(kind=wp), intent(in) :: C(*), THET(NII,NII), ENP(*) +real(kind=wp), intent(inout) :: S(*), W(*) +integer(kind=iwp) :: IADD25, IIC, IND, INDA, IRL, NA, NA1, NA2, NB, NB1, NB2, NSA, NSS +real(kind=wp) :: ENPQ, FACS, FACW +integer(kind=iwp), external :: JSUNP + +IADD25 = IAD25S +call dDAFILE(Lu_25,2,COP,nCOP,IADD25) +IIC = 0 +IND = 0 +IRL = IRC(ILIM) +do INDA=1,IRL + NSS = MUL(JSUNP(JSY,INDA),LSYM) + ENPQ = (One-THET(INDA,INDA)*Half)*(ENP(INDA)+ENP(INDA)-One)+THET(INDA,INDA)*Half + FACS = sqrt(ENP(INDA))*sqrt(ENP(INDA))/ENPQ + FACW = (FACS*(Two-THET(INDA,INDA))/ENPQ)*ENP(INDA)-FACS + if (INDA <= IRC(1)) then + IIC = IIC+1 + IND = IND+1 + S(IND) = S(IND)+FACS*COP(IIC)*C(IND) + W(IND) = W(IND)+FACW*COP(IIC)*C(IND) + if (IIC >= nCOP) then + call dDAFILE(Lu_25,2,COP,nCOP,IADD25) + IIC = 0 + end if + else if (INDA <= IRC(2)) then + NA1 = NSYS(NSS)+1 + NA2 = NSYS(NSS+1) + do NA=NA1,NA2 + IIC = IIC+1 + IND = IND+1 + S(IND) = S(IND)+FACS*COP(IIC)*C(IND) + W(IND) = W(IND)+FACW*COP(IIC)*C(IND) + if (IIC >= nCOP) then + call dDAFILE(Lu_25,2,COP,nCOP,IADD25) + IIC = 0 + end if + end do + else + do NA=1,NVIRT + NSA = MUL(NSS,NSM(LN+NA)) + NB1 = NSYS(NSA)+1 + NB2 = NSYS(NSA+1) + if (NB2 > NA) NB2 = NA + do NB=NB1,NB2 + IIC = IIC+1 + IND = IND+1 + S(IND) = S(IND)+FACS*COP(IIC)*C(IND) + W(IND) = W(IND)+FACW*COP(IIC)*C(IND) + if (IIC >= nCOP) then + call dDAFILE(Lu_25,2,COP,nCOP,IADD25) + IIC = 0 + end if + end do + end do + end if +end do + +return + +end subroutine MDIAGC diff -Nru openmolcas-22.02/src/cpf/mdsq2.f openmolcas-22.10/src/cpf/mdsq2.f --- openmolcas-22.02/src/cpf/mdsq2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/mdsq2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE MDSQ2(C,S,W,MUL,INDEX,JSY,NDIAG,INUM,IRC3,LSYM, - *NVIRT,SQ2) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION C(*),S(*),W(*),MUL(8,8),INDEX(*),JSY(*),NDIAG(*) -CPAM97 INTEGER UNPACK -CPAM97 EXTERNAL UNPACK -CRL JSYM(L)=IAND(ISHFT(JSY((L+19)/20),-3*((L+19)/20*20-L)),7)+1 -CPAM96 JSYM(L)=UNPACK(JSY((L+9)/10),3*MOD(L-1,10)+1,3)+1 - JSYM(L)=JSUNP_CPF(JSY,L) - DO 10 I=1,INUM - II1=IRC3+I - NS1=JSYM(II1) - NS1L=MUL(NS1,LSYM) - IF(NS1L.NE.1)GO TO 10 - NA=INDEX(II1) - DO 20 MA=1,NVIRT - C(NA+NDIAG(MA))=C(NA+NDIAG(MA))/SQ2 - S(NA+NDIAG(MA))=SQ2*S(NA+NDIAG(MA)) - W(NA+NDIAG(MA))=SQ2*W(NA+NDIAG(MA)) -20 CONTINUE -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/mdsq2.F90 openmolcas-22.10/src/cpf/mdsq2.F90 --- openmolcas-22.02/src/cpf/mdsq2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/mdsq2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,42 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine MDSQ2(C,S,W,MUL,INDX,JSY,NDIAG,INUM,IRC3,LSYM,NVIRT,SQ2) + +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(inout) :: C(*), S(*), W(*) +integer(kind=iwp), intent(in) :: MUL(8,8), INDX(*), JSY(*), NDIAG(*), INUM, IRC3, LSYM, NVIRT +real(kind=wp), intent(in) :: SQ2 +integer(kind=iwp) :: I, II1, MA, NA, NS1, NS1L +integer(kind=iwp), external :: JSUNP + +do I=1,INUM + II1 = IRC3+I + NS1 = JSUNP(JSY,II1) + NS1L = MUL(NS1,LSYM) + if (NS1L == 1) then + NA = INDX(II1) + do MA=1,NVIRT + C(NA+NDIAG(MA)) = C(NA+NDIAG(MA))/SQ2 + S(NA+NDIAG(MA)) = SQ2*S(NA+NDIAG(MA)) + W(NA+NDIAG(MA)) = SQ2*W(NA+NDIAG(MA)) + end do + end if +end do + +return + +end subroutine MDSQ2 diff -Nru openmolcas-22.02/src/cpf/mfaibj.f openmolcas-22.10/src/cpf/mfaibj.f --- openmolcas-22.02/src/cpf/mfaibj.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/mfaibj.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,423 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE MFAIBJ(JSY,INDEX,C,S,ABIJ,AIBJ,AJBI,BUFIN,IBUFIN,A,B, - & F,FSEC,W,THET,ENP,EPP,NII) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" - DIMENSION JSY(*),INDEX(*),C(*),S(*),ABIJ(*),AIBJ(*),AJBI(*) - DIMENSION BUFIN(*),IBUFIN(*),A(*),B(*),F(*),FSEC(*),W(*) - DIMENSION THET(NII,NII),ENP(*),EPP(*) - DIMENSION IPOF(9),IPOA(9),IPOB(9) - PARAMETER (IPOW5=2**5,IPOW13=2**13,IPOW18=2**18) - PARAMETER (IPOW10=2**10) -* - JSYM(L)=JSUNP_CPF(JSY,L) -* - ITYP = 0 ! dummy initialize - ICOUP = 0 ! dummy initialize - ICOUP1 = 0 ! dummy initialize - INUM=IRC(4)-IRC(3) - CALL MPSQ2(C,S,W,MUL,INDEX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) - NVT=IROW(NVIRT+1) - ICHK=0 - IFAB=0 - NOVST=LN*NVIRT+1+NVT - LBUF0=RTOI*LBUF - LBUF1=LBUF0+LBUF+1 - LBUF2=LBUF1+1 - NOT2=IROW(LN+1) - IADD10=IAD10(6) -300 CALL dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) - CALL iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.EQ.0)GO TO 300 - IF(LEN.LT.0)GO TO 350 - DO 260 II=1,LEN - IND=ICOP1(II) - IF(ICHK.NE.0)GO TO 460 - IF(IND.NE.0)GO TO 371 - ICHK=1 - GO TO 260 -460 ICHK=0 - INDI=IND -* NI=MOD(INDI,IPOW10) -* NJ=MOD(INDI/IPOW10,IPOW10) - NI=IBITS(INDI,0,10) - NJ=IBITS(INDI,10,10) - NSIJ=MUL(NSM(NI),NSM(NJ)) - CALL IPO_CPF(IPOF,NVIR,MUL,NSYM,NSIJ,-1) - IJ1=IROW(NI)+NJ - ILIM=IPOF(NSYM+1) - CALL FZERO(ABIJ,ILIM) - CALL FZERO(AIBJ,ILIM) - CALL FZERO(AJBI,ILIM) - IF(ITER.EQ.1)GO TO 207 -C READ (AB/IJ) INTEGRALS - IADR=LASTAD(NOVST+IJ1) - JTURN=0 -201 CALL iDAFILE(Lu_TiABIJ,2,IBUFIN,LBUF2,IADR) - LENGTH=IBUFIN(LBUF1) - IADR=IBUFIN(LBUF2) - IF(LENGTH.EQ.0)GO TO 209 - IF(JTURN.EQ.1)GO TO 203 - CALL SCATTER(LENGTH,ABIJ,IBUFIN(LBUF0+1),BUFIN) - GO TO 209 -203 CALL SCATTER(LENGTH,AIBJ,IBUFIN(LBUF0+1),BUFIN) -209 IF(IADR.EQ.-1) GO TO 206 - GO TO 201 -206 IF(JTURN.EQ.1)GO TO 360 -C READ (AI/BJ) INTEGRALS -207 IADR=LASTAD(NOVST+NOT2+IJ1) - JTURN=1 - GO TO 201 -C CONSTRUCT FIRST ORDER MATRICES -360 FAC=D1/D2 - IF(NI.NE.NJ)FAC=D2*FAC - IN=0 - IFT=0 - CALL IPO_CPF(IPOA,NVIR,MUL,NSYM,NSIJ,IFT) -852 DO 170 IASYM=1,NSYM - IBSYM=MUL(NSIJ,IASYM) - IF(IBSYM.GT.IASYM)GO TO 170 - IAB=IPOA(IASYM+1)-IPOA(IASYM) - IF(IAB.EQ.0)GO TO 170 - CALL SECORD(AIBJ(IPOF(IASYM)+1),AIBJ(IPOF(IBSYM)+1), - *FSEC(IN+1),FAC,NVIR(IASYM),NVIR(IBSYM),NSIJ,IFT) - IN=IN+IAB -170 CONTINUE - IF(IFT.EQ.1)GO TO 853 - INS=IN - IFT=1 - FAC=D0 - GO TO 852 -C SQARE ABIJ -853 IF(ITER.EQ.1)GO TO 260 - DO 370 IASYM=1,NSYM - IF(NVIR(IASYM).EQ.0)GO TO 370 - IBSYM=MUL(NSIJ,IASYM) - IF(NVIR(IBSYM).EQ.0)GO TO 370 - IPF=IPOF(IASYM)+1 - IPF1=IPOF(IBSYM)+1 - IF(IASYM.GT.IBSYM)GO TO 369 - IF(NSIJ.NE.1)GO TO 361 - CALL SQUAR2_CPF(ABIJ(IPF),NVIR(IASYM)) - IF(NI.NE.NJ)GO TO 368 - CALL SQUAR2_CPF(AIBJ(IPF),NVIR(IASYM)) -368 CALL MTRANS_CPF(AIBJ(IPF),AJBI(IPF),NVIR(IASYM),NVIR(IBSYM)) - GO TO 370 -361 CALL MTRANS_CPF(ABIJ(IPF1),ABIJ(IPF),NVIR(IASYM),NVIR(IBSYM)) -369 CALL MTRANS_CPF(AIBJ(IPF1),AJBI(IPF),NVIR(IASYM),NVIR(IBSYM)) -370 CONTINUE - GO TO 260 -371 IF(IFAB.EQ.1)GO TO 262 -CPAM97 IFAB=IAND(IND,1) -CPAM97 ITURN=IAND(ISHFT(IND,-1),1) -CPAM97 ITYP=IAND(ISHFT(IND,-2),7) -CPAM97 ICOUP=IAND(ISHFT(IND,-5),8191) -CPAM97 ICOUP1=IAND(ISHFT(IND,-18),8191) -* IFAB=MOD(IND,2) -* ITURN=MOD(IND/2,2) -* ITYP=MOD(IND/4,8) -* ICOUP=MOD(IND/IPOW5,IPOW13) -* ICOUP1=MOD(IND/IPOW18,IPOW13) - IFAB=IBITS(IND, 0,1) - ITURN=IBITS(IND,1,1) - ITYP=IBITS(IND,2,3) - ICOUP=IBITS(IND,5,13) - ICOUP1=IBITS(IND,18,13) - CPL=COP(II) - CPLA=D0 - IF(IFAB.NE.0)GO TO 260 - IF(ITURN.EQ.0)GO TO 263 - GO TO 100 -262 CPLA=COP(II) - IFAB=0 - GO TO 100 -C FIRST ORDER INTERACTION -263 INDA=ICOUP - INDB=IRC(ITYP+1)+ICOUP1 - ISTAR=1 - IF(ITYP.EQ.1)ISTAR=INS+1 - IF(INS.EQ.0)GO TO 260 - IF(INDA.NE.IREF0)GO TO 342 - CPLL=CPL/SQRT(ENP(INDB)) - CALL DAXPY_(INS,CPLL,FSEC(ISTAR),1,S(INDEX(INDB)+1),1) - IF(ITER.EQ.1)GO TO 260 - TERM=DDOT_(INS,C(INDEX(INDB)+1),1,FSEC(ISTAR),1) - EPP(INDB)=EPP(INDB)+CPLL*TERM - GO TO 260 -342 ENPQ=(D1-THET(INDA,INDB)/D2)*(ENP(INDA)+ENP(INDB)-D1)+ - *THET(INDA,INDB)/D2 - FACS=SQRT(ENP(INDA))*SQRT(ENP(INDB))/ENPQ - FACW=FACS*(D2-THET(INDA,INDB))/ENPQ - FACWA=FACW*ENP(INDA)-FACS - FACWB=FACW*ENP(INDB)-FACS - COPI=CPL*C(INDA) - CALL DAXPY_(INS,COPI*FACS,FSEC(ISTAR),1,S(INDEX(INDB)+1),1) - CALL DAXPY_(INS,COPI*FACWB,FSEC(ISTAR),1,W(INDEX(INDB)+1),1) - TERM=DDOT_(INS,FSEC(ISTAR),1,C(INDEX(INDB)+1),1) - S(INDA)=S(INDA)+CPL*FACS*TERM - W(INDA)=W(INDA)+CPL*FACWA*TERM - GO TO 260 -C INTERACTIONS BETWEEN DOUBLES AND -C INTERACTIONS BETWEEN SINGLES -100 IF(ITER.EQ.1)GO TO 260 -C CALL JTIME(IST) - IFTA=0 - IFTB=0 - GO TO (109,110,111,112,113),ITYP -109 INDA=IRC(2)+ICOUP1 - INDB=IRC(2)+ICOUP - IFTA=1 - IFTB=1 - GO TO 115 -110 INDA=IRC(3)+ICOUP1 - INDB=IRC(3)+ICOUP - GO TO 115 -111 INDA=IRC(2)+ICOUP1 - INDB=IRC(3)+ICOUP - IFTA=1 - GO TO 115 -112 INDA=IRC(3)+ICOUP1 - INDB=IRC(2)+ICOUP - IFTB=1 - GO TO 115 -113 INDA=IRC(1)+ICOUP1 - INDB=IRC(1)+ICOUP -115 MYSYM=JSYM(INDA) - NYSYM=MUL(MYSYM,NSIJ) - MYL=MUL(MYSYM,LSYM) - NYL=MUL(NYSYM,LSYM) - ENPQ=(D1-THET(INDA,INDB)/D2)*(ENP(INDA)+ENP(INDB)-D1)+ - *THET(INDA,INDB)/D2 - FACS=SQRT(ENP(INDA))*SQRT(ENP(INDB))/ENPQ - FACW=FACS*(D2-THET(INDA,INDB))/ENPQ - FACWA=FACW*ENP(INDA)-FACS - FACWB=FACW*ENP(INDB)-FACS - CALL IPO_CPF(IPOA,NVIR,MUL,NSYM,MYL,IFTA) - CALL IPO_CPF(IPOB,NVIR,MUL,NSYM,NYL,IFTB) - INMY=INDEX(INDA)+1 - INNY=INDEX(INDB)+1 - IF(ITYP.NE.5)GO TO 71 -C DOUBLET-DOUBLET INTERACTIONS - IN=IPOF(MYL+1)-IPOF(MYL) - IF(IN.EQ.0)GO TO 260 - IPF=IPOF(MYL)+1 - CALL SETZ(F,IN) - CALL DAXPY_(IN,CPL,AIBJ(IPF),1,F,1) - CALL DAXPY_(IN,CPLA,ABIJ(IPF),1,F,1) - IF(INDA.EQ.INDB)CALL SETZZ_CPF(F,NVIR(MYL)) - CALL SETZ(A,NVIR(NYL)) - CALL FMMM(C(INMY),F,A,1,NVIR(NYL),NVIR(MYL)) - CALL DAXPY_(NVIR(NYL),FACS,A,1,S(INNY),1) - CALL DAXPY_(NVIR(NYL),FACWB,A,1,W(INNY),1) - IF(INDA.EQ.INDB)GO TO 260 - CALL SETZ(A,NVIR(MYL)) - CALL FMMM(F,C(INNY),A,NVIR(MYL),1,NVIR(NYL)) - CALL DAXPY_(NVIR(MYL),FACS,A,1,S(INMY),1) - CALL DAXPY_(NVIR(MYL),FACWA,A,1,W(INMY),1) - GO TO 260 -C TRIPLET-SINGLET , SINGLET-TRIPLET , -C TRIPLET-TRIPLET AND SINGLET-SINGLET INTERACTIONS -71 DO 70 IASYM=1,NSYM - IAB=IPOF(IASYM+1)-IPOF(IASYM) - IF(IAB.EQ.0)GO TO 70 - ICSYM=MUL(MYL,IASYM) - IBSYM=MUL(NYL,ICSYM) - IF(INDA.EQ.INDB.AND.IBSYM.GT.IASYM)GO TO 70 - IF(NVIR(ICSYM).EQ.0)GO TO 70 - NAC=NVIR(IASYM)*NVIR(ICSYM) - NBC=NVIR(IBSYM)*NVIR(ICSYM) - IF(ICSYM.GE.IASYM)GO TO 31 - IF(ICSYM.GE.IBSYM)GO TO 32 -C CASE 1 , IASYM > ICSYM AND IBSYM > ICSYM - IPF=IPOF(IASYM)+1 - CALL SETZ(F,IAB) - CALL DAXPY_(IAB,CPL,AIBJ(IPF),1,F,1) - CALL DAXPY_(IAB,CPLA,ABIJ(IPF),1,F,1) - IF(INDA.EQ.INDB)CALL SETZZ_CPF(F,NVIR(IASYM)) - CALL SETZ(A,NBC) - CALL FMMM(C(INMY+IPOA(IASYM)),F,A,NVIR(ICSYM), - *NVIR(IBSYM),NVIR(IASYM)) - CALL DAXPY_(NBC,FACS,A,1,S(INNY+IPOB(IBSYM)),1) - CALL DAXPY_(NBC,FACWB,A,1,W(INNY+IPOB(IBSYM)),1) - IF(INDA.EQ.INDB)GO TO 70 - IPF=IPOF(IBSYM)+1 - CALL SETZ(F,IAB) - CALL DAXPY_(IAB,CPL,AJBI(IPF),1,F,1) - CALL DAXPY_(IAB,CPLA,ABIJ(IPF),1,F,1) - CALL SETZ(A,NAC) - CALL FMMM(C(INNY+IPOB(IBSYM)),F,A,NVIR(ICSYM), - *NVIR(IASYM),NVIR(IBSYM)) - CALL DAXPY_(NAC,FACS,A,1,S(INMY+IPOA(IASYM)),1) - CALL DAXPY_(NAC,FACWA,A,1,W(INMY+IPOA(IASYM)),1) - GO TO 70 -C CASE 2 , IASYM > ICSYM AND ICSYM > OR = IBSYM -32 IPF=IPOF(IBSYM)+1 - CALL SETZ(F,IAB) - CALL DAXPY_(IAB,CPL,AJBI(IPF),1,F,1) - CALL DAXPY_(IAB,CPLA,ABIJ(IPF),1,F,1) - CALL MTRANS_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM),NVIR(ICSYM)) - CALL SETZ(B,NBC) - CALL FMMM(F,A,B,NVIR(IBSYM),NVIR(ICSYM),NVIR(IASYM)) - IF(NYL.NE.1)GO TO 35 - CALL SETZ(A,NBC) - CALL DAXPY_(NBC,FACS,B,1,A,1) - IF(IFTB.EQ.1)GO TO 134 - CALL SIADD_CPF(A,S(INNY+IPOB(ICSYM)),NVIR(IBSYM)) - CALL SETZ(A,NBC) - CALL DAXPY_(NBC,FACWB,B,1,A,1) - CALL SIADD_CPF(A,W(INNY+IPOB(ICSYM)),NVIR(IBSYM)) - CALL SQUAR_CPF(C(INNY+IPOB(IBSYM)),A,NVIR(IBSYM)) - GO TO 36 -134 CALL TRADD_CPF(A,S(INNY+IPOB(ICSYM)),NVIR(IBSYM)) - CALL SETZ(A,NBC) - CALL DAXPY_(NBC,FACWB,B,1,A,1) - CALL TRADD_CPF(A,W(INNY+IPOB(ICSYM)),NVIR(IBSYM)) - CALL SQUARN_CPF(C(INNY+IPOB(IBSYM)),A,NVIR(IBSYM)) - GO TO 36 -35 IF(IFTB.EQ.1)GO TO 135 - CALL DAXPY_(NBC,FACS,B,1,S(INNY+IPOB(ICSYM)),1) - CALL DAXPY_(NBC,FACWB,B,1,W(INNY+IPOB(ICSYM)),1) - GO TO 136 -135 CALL DAXPY_(NBC,-FACS,B,1,S(INNY+IPOB(ICSYM)),1) - CALL DAXPY_(NBC,-FACWB,B,1,W(INNY+IPOB(ICSYM)),1) -136 CALL MTRANS_CPF(C(INNY+IPOB(ICSYM)),A,NVIR(ICSYM),NVIR(IBSYM)) - IF(IFTB.EQ.1)CALL VNEG_CPF(A,1,A,1,NBC) -36 CALL SETZ(B,NAC) - CALL FMMM(A,F,B,NVIR(ICSYM),NVIR(IASYM),NVIR(IBSYM)) - CALL DAXPY_(NAC,FACS,B,1,S(INMY+IPOA(IASYM)),1) - CALL DAXPY_(NAC,FACWA,B,1,W(INMY+IPOA(IASYM)),1) - GO TO 70 -31 IF(ICSYM.GE.IBSYM)GO TO 33 -C CASE 3 , ICSYM > OR = IASYM AND IBSYM > ICSYM - IPF=IPOF(IASYM)+1 - CALL SETZ(F,IAB) - CALL DAXPY_(IAB,CPL,AIBJ(IPF),1,F,1) - CALL DAXPY_(IAB,CPLA,ABIJ(IPF),1,F,1) - IF(MYL.NE.1)GO TO 39 - IF(IFTA.EQ.0)CALL SQUAR_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) - IF(IFTA.EQ.1)CALL SQUARN_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) - GO TO 40 -39 CALL MTRANS_CPF(C(INMY+IPOA(ICSYM)),A,NVIR(ICSYM),NVIR(IASYM)) - IF(IFTA.EQ.1)CALL VNEG_CPF(A,1,A,1,NAC) -40 CALL SETZ(B,NBC) - CALL FMMM(A,F,B,NVIR(ICSYM),NVIR(IBSYM),NVIR(IASYM)) - CALL DAXPY_(NBC,FACS,B,1,S(INNY+IPOB(IBSYM)),1) - CALL DAXPY_(NBC,FACWB,B,1,W(INNY+IPOB(IBSYM)),1) - CALL MTRANS_CPF(C(INNY+IPOB(IBSYM)),A,NVIR(IBSYM),NVIR(ICSYM)) - CALL SETZ(B,NAC) - CALL FMMM(F,A,B,NVIR(IASYM),NVIR(ICSYM),NVIR(IBSYM)) - IF(MYL.NE.1)GO TO 46 - CALL SETZ(A,NAC) - CALL DAXPY_(NAC,FACS,B,1,A,1) - IF(IFTA.EQ.1)GO TO 146 - CALL SIADD_CPF(A,S(INMY+IPOA(IASYM)),NVIR(IASYM)) - CALL SETZ(A,NAC) - CALL DAXPY_(NAC,FACWA,B,1,A,1) - CALL SIADD_CPF(A,W(INMY+IPOA(IASYM)),NVIR(IASYM)) - GO TO 70 -146 CALL TRADD_CPF(A,S(INMY+IPOA(IASYM)),NVIR(IASYM)) - CALL SETZ(A,NAC) - CALL DAXPY_(NAC,FACWA,B,1,A,1) - CALL TRADD_CPF(A,W(INMY+IPOA(IASYM)),NVIR(IASYM)) - GO TO 70 -46 IF(IFTA.EQ.1)GO TO 1146 - CALL DAXPY_(NAC,FACS,B,1,S(INMY+IPOA(ICSYM)),1) - CALL DAXPY_(NAC,FACWA,B,1,W(INMY+IPOA(ICSYM)),1) - GO TO 70 -1146 CALL DAXPY_(NAC,-FACS,B,1,S(INMY+IPOA(ICSYM)),1) - CALL DAXPY_(NAC,-FACWA,B,1,W(INMY+IPOA(ICSYM)),1) - GO TO 70 -C CASE 4 , ICSYM > OR = IASYM AND ICSYM > OR = IBSYM -33 IPF=IPOF(IBSYM)+1 - CALL SETZ(F,IAB) - CALL DAXPY_(IAB,CPL,AJBI(IPF),1,F,1) - CALL DAXPY_(IAB,CPLA,ABIJ(IPF),1,F,1) - IF(INDA.EQ.INDB)CALL SETZZ_CPF(F,NVIR(IASYM)) - IF(MYL.NE.1)GO TO 41 - IF(IFTA.EQ.0)CALL SQUAR_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) - IF(IFTA.EQ.1)CALL SQUARM_CPF(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) - GO TO 42 -41 IF(IFTA.EQ.0)CALL DCOPY_(NAC,C(INMY+IPOA(ICSYM)),1,A,1) - IF(IFTA.EQ.1)CALL VNEG_CPF(C(INMY+IPOA(ICSYM)),1,A,1,NAC) -42 CALL SETZ(B,NBC) - CALL FMMM(F,A,B,NVIR(IBSYM),NVIR(ICSYM),NVIR(IASYM)) - IF(NYL.NE.1)GO TO 43 - CALL SETZ(A,NBC) - CALL DAXPY_(NBC,FACS,B,1,A,1) - IF(IFTB.EQ.1)GO TO 143 - CALL SIADD_CPF(A,S(INNY+IPOB(ICSYM)),NVIR(IBSYM)) - CALL SETZ(A,NBC) - CALL DAXPY_(NBC,FACWB,B,1,A,1) - CALL SIADD_CPF(A,W(INNY+IPOB(ICSYM)),NVIR(IBSYM)) - GO TO 44 -143 CALL TRADD_CPF(A,S(INNY+IPOB(ICSYM)),NVIR(IBSYM)) - CALL SETZ(A,NBC) - CALL DAXPY_(NBC,FACWB,B,1,A,1) - CALL TRADD_CPF(A,W(INNY+IPOB(ICSYM)),NVIR(IBSYM)) - GO TO 44 -43 IF(IFTB.EQ.1)GO TO 144 - CALL DAXPY_(NBC,FACS,B,1,S(INNY+IPOB(ICSYM)),1) - CALL DAXPY_(NBC,FACWB,B,1,W(INNY+IPOB(ICSYM)),1) - GO TO 44 -144 CALL DAXPY_(NBC,-FACS,B,1,S(INNY+IPOB(ICSYM)),1) - CALL DAXPY_(NBC,-FACWB,B,1,W(INNY+IPOB(ICSYM)),1) -44 IF(INDA.EQ.INDB)GO TO 70 - IPF=IPOF(IASYM)+1 - CALL SETZ(F,IAB) - CALL DAXPY_(IAB,CPL,AIBJ(IPF),1,F,1) - CALL DAXPY_(IAB,CPLA,ABIJ(IPF),1,F,1) - IF(NYL.NE.1)GO TO 37 - IF(IFTB.EQ.0)CALL SQUAR_CPF(C(INNY+IPOB(IBSYM)),A,NVIR(IBSYM)) - IF(IFTB.EQ.1)CALL SQUARM_CPF(C(INNY+IPOB(IBSYM)),A,NVIR(IBSYM)) - GO TO 38 -37 IF(IFTB.EQ.0)CALL DCOPY_(NBC,C(INNY+IPOB(ICSYM)),1,A,1) - IF(IFTB.EQ.1)CALL VNEG_CPF(C(INNY+IPOB(ICSYM)),1,A,1,NBC) -38 CALL SETZ(B,NAC) - CALL FMMM(F,A,B,NVIR(IASYM),NVIR(ICSYM),NVIR(IBSYM)) - IF(MYL.NE.1)GO TO 45 - CALL SETZ(A,NAC) - CALL DAXPY_(NAC,FACS,B,1,A,1) - IF(IFTA.EQ.1)GO TO 145 - CALL SIADD_CPF(A,S(INMY+IPOA(ICSYM)),NVIR(IASYM)) - CALL SETZ(A,NAC) - CALL DAXPY_(NAC,FACWA,B,1,A,1) - CALL SIADD_CPF(A,W(INMY+IPOA(ICSYM)),NVIR(IASYM)) - GO TO 70 -145 CALL TRADD_CPF(A,S(INMY+IPOA(ICSYM)),NVIR(IASYM)) - CALL SETZ(A,NAC) - CALL DAXPY_(NAC,FACWA,B,1,A,1) - CALL TRADD_CPF(A,W(INMY+IPOA(ICSYM)),NVIR(IASYM)) - GO TO 70 -45 IF(IFTA.EQ.1)GO TO 147 - CALL DAXPY_(NAC,FACS,B,1,S(INMY+IPOA(ICSYM)),1) - CALL DAXPY_(NAC,FACWA,B,1,W(INMY+IPOA(ICSYM)),1) - GO TO 70 -147 CALL DAXPY_(NAC,-FACS,B,1,S(INMY+IPOA(ICSYM)),1) - CALL DAXPY_(NAC,-FACWA,B,1,W(INMY+IPOA(ICSYM)),1) -70 CONTINUE -260 CONTINUE - GO TO 300 -350 CALL MDSQ2(C,S,W,MUL,INDEX,JSY,NDIAG,INUM,IRC(3), - *LSYM,NVIRT,SQ2) -C NCONF=JSC(4) -C WRITE(6,787)(S(I),I=1,NCONF) -C 787 FORMAT(1X,'S,FAIBJ',5F10.6) -C WRITE(6,786)(W(I),I=1,NCONF) -C 786 FORMAT(1X,'W,FAIBJ',5F10.6) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/mfaibj.F90 openmolcas-22.10/src/cpf/mfaibj.F90 --- openmolcas-22.02/src/cpf/mfaibj.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/mfaibj.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,442 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine MFAIBJ(JSY,INDX,C,S,ABIJ,AIBJ,AJBI,BUFIN,A,B,F,FSEC,W,THET,ENP,EPP,NII) + +use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc +use cpf_global, only: IRC, IREF0, IROW, ITER, LASTAD, LBUF, LN, LSYM, Lu_CIGuga, Lu_TiABIJ, NDIAG, NSM, NSYM, NVIR, NVIRT, SQ2 +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Constants, only: Zero, One, Two, Half +use Definitions, only: wp, iwp, r8, RtoI + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: JSY(*), INDX(*), NII +real(kind=wp), intent(inout) :: C(*), S(*), ABIJ(*), AIBJ(*), AJBI(*), FSEC(*), W(*), EPP(*) +real(kind=wp), intent(_OUT_) :: BUFIN(*), A(*), B(*), F(*) +real(kind=wp), intent(in) :: THET(NII,NII), ENP(*) +integer(kind=iwp) :: IAB, IADD10, IADR, IBSYM, ICHK, ICOUP, ICOUP1, ICSYM, IFAB, IFT, IFTA, IFTB, IIN, IJ1, ILEN, ILIM, IND, INDA, & + INDB, INDI, INMY, INNY, INS, INUM, IPF, IPF1, IPOA(9), IPOB(9), IPOF(9), ISTAR, ITURN, ITYP, JTURN, LBUF0, & + LBUF1, LBUF2, LENGTH, MYL, MYSYM, NAC, NBC, NI, NJ, NOT2, NOVST, NSIJ, NVT, NYL, NYSYM +real(kind=wp) :: COPI, CPL, CPLA, CPLL, ENPQ, FAC, FACS, FACW, FACWA, FACWB, TERM +logical(kind=iwp) :: Skip +integer(kind=iwp), external :: JSUNP +real(kind=r8), external :: DDOT_ + +call MFAIBJ_INTERNAL(BUFIN) + +! This is to allow type punning without an explicit interface +contains + +subroutine MFAIBJ_INTERNAL(BUFIN) + + real(kind=wp), target, intent(_OUT_) :: BUFIN(*) + integer(kind=iwp), pointer :: IBUFIN(:) + integer(kind=iwp) :: IASYM, II + + call c_f_pointer(c_loc(BUFIN),iBUFIN,[1]) + + ITYP = 0 ! dummy initialize + ICOUP = 0 ! dummy initialize + ICOUP1 = 0 ! dummy initialize + INUM = IRC(4)-IRC(3) + call MPSQ2(C,S,W,MUL,INDX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) + NVT = IROW(NVIRT+1) + ICHK = 0 + IFAB = 0 + NOVST = LN*NVIRT+1+NVT + LBUF0 = RTOI*LBUF + LBUF1 = LBUF0+LBUF+1 + LBUF2 = LBUF1+1 + NOT2 = IROW(LN+1) + IADD10 = IAD10(6) + do + call dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) + call iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN == 0) cycle + if (ILEN < 0) exit + do II=1,ILEN + IND = ICOP1(II) + if (ICHK == 0) then + if (IND /= 0) then + if (IFAB /= 1) then + IFAB = ibits(IND,0,1) + ITURN = ibits(IND,1,1) + ITYP = ibits(IND,2,3) + ICOUP = ibits(IND,5,13) + ICOUP1 = ibits(IND,18,13) + CPL = COP(II) + CPLA = Zero + if (IFAB /= 0) cycle + if (ITURN == 0) then + ! FIRST ORDER INTERACTION + INDA = ICOUP + INDB = IRC(ITYP+1)+ICOUP1 + ISTAR = 1 + if (ITYP == 1) ISTAR = INS+1 + if (INS /= 0) then + if (INDA == IREF0) then + CPLL = CPL/sqrt(ENP(INDB)) + S(INDX(INDB)+1:INDX(INDB)+INS) = S(INDX(INDB)+1:INDX(INDB)+INS)+CPLL*FSEC(ISTAR:ISTAR+INS-1) + if (ITER /= 1) then + TERM = DDOT_(INS,C(INDX(INDB)+1),1,FSEC(ISTAR),1) + EPP(INDB) = EPP(INDB)+CPLL*TERM + end if + else + ENPQ = (One-THET(INDA,INDB)*Half)*(ENP(INDA)+ENP(INDB)-One)+THET(INDA,INDB)*Half + FACS = sqrt(ENP(INDA))*sqrt(ENP(INDB))/ENPQ + FACW = FACS*(Two-THET(INDA,INDB))/ENPQ + FACWA = FACW*ENP(INDA)-FACS + FACWB = FACW*ENP(INDB)-FACS + COPI = CPL*C(INDA) + S(INDX(INDB)+1:INDX(INDB)+INS) = S(INDX(INDB)+1:INDX(INDB)+INS)+COPI*FACS*FSEC(ISTAR:ISTAR+INS-1) + W(INDX(INDB)+1:INDX(INDB)+INS) = W(INDX(INDB)+1:INDX(INDB)+INS)+COPI*FACWB*FSEC(ISTAR:ISTAR+INS-1) + TERM = DDOT_(INS,FSEC(ISTAR),1,C(INDX(INDB)+1),1) + S(INDA) = S(INDA)+CPL*FACS*TERM + W(INDA) = W(INDA)+CPL*FACWA*TERM + end if + end if + cycle + end if + else + CPLA = COP(II) + IFAB = 0 + end if + ! INTERACTIONS BETWEEN DOUBLES AND + ! INTERACTIONS BETWEEN SINGLES + if (ITER == 1) cycle + !call JTIME(IST) + IFTA = 0 + IFTB = 0 + select case (ITYP) + case default !(1) + INDA = IRC(2)+ICOUP1 + INDB = IRC(2)+ICOUP + IFTA = 1 + IFTB = 1 + case (2) + INDA = IRC(3)+ICOUP1 + INDB = IRC(3)+ICOUP + case (3) + INDA = IRC(2)+ICOUP1 + INDB = IRC(3)+ICOUP + IFTA = 1 + case (4) + INDA = IRC(3)+ICOUP1 + INDB = IRC(2)+ICOUP + IFTB = 1 + case (5) + INDA = IRC(1)+ICOUP1 + INDB = IRC(1)+ICOUP + end select + MYSYM = JSUNP(JSY,INDA) + NYSYM = MUL(MYSYM,NSIJ) + MYL = MUL(MYSYM,LSYM) + NYL = MUL(NYSYM,LSYM) + ENPQ = (One-THET(INDA,INDB)*Half)*(ENP(INDA)+ENP(INDB)-One)+THET(INDA,INDB)*Half + FACS = sqrt(ENP(INDA))*sqrt(ENP(INDB))/ENPQ + FACW = FACS*(Two-THET(INDA,INDB))/ENPQ + FACWA = FACW*ENP(INDA)-FACS + FACWB = FACW*ENP(INDB)-FACS + call IPO_CPF(IPOA,NVIR,MUL,NSYM,MYL,IFTA) + call IPO_CPF(IPOB,NVIR,MUL,NSYM,NYL,IFTB) + INMY = INDX(INDA)+1 + INNY = INDX(INDB)+1 + if (ITYP == 5) then + ! DOUBLET-DOUBLET INTERACTIONS + IIN = IPOF(MYL+1)-IPOF(MYL) + if (IIN /= 0) then + IPF = IPOF(MYL) + F(1:IIN) = CPL*AIBJ(IPF+1:IPF+IIN)+CPLA*ABIJ(IPF+1:IPF+IIN) + if (INDA == INDB) call DCOPY_(NVIR(MYL),[Zero],0,F,NVIR(MYL)+1) + call FMMM(C(INMY),F,A,1,NVIR(NYL),NVIR(MYL)) + S(INNY:INNY+NVIR(NYL)-1) = S(INNY:INNY+NVIR(NYL)-1)+FACS*A(1:NVIR(NYL)) + W(INNY:INNY+NVIR(NYL)-1) = W(INNY:INNY+NVIR(NYL)-1)+FACWB*A(1:NVIR(NYL)) + if (INDA /= INDB) then + call FMMM(F,C(INNY),A,NVIR(MYL),1,NVIR(NYL)) + S(INMY:INMY+NVIR(MYL)-1) = S(INMY:INMY+NVIR(MYL)-1)+FACS*A(1:NVIR(MYL)) + W(INMY:INMY+NVIR(MYL)-1) = W(INMY:INMY+NVIR(MYL)-1)+FACWA*A(1:NVIR(MYL)) + end if + end if + else + ! TRIPLET-SINGLET , SINGLET-TRIPLET , + ! TRIPLET-TRIPLET AND SINGLET-SINGLET INTERACTIONS + do IASYM=1,NSYM + IAB = IPOF(IASYM+1)-IPOF(IASYM) + if (IAB == 0) cycle + ICSYM = MUL(MYL,IASYM) + IBSYM = MUL(NYL,ICSYM) + if ((INDA == INDB) .and. (IBSYM > IASYM)) cycle + if (NVIR(ICSYM) == 0) cycle + NAC = NVIR(IASYM)*NVIR(ICSYM) + NBC = NVIR(IBSYM)*NVIR(ICSYM) + if (ICSYM < IASYM) then + if (ICSYM < IBSYM) then + ! CASE 1 , IASYM > ICSYM AND IBSYM > ICSYM + IPF = IPOF(IASYM) + F(1:IAB) = CPL*AIBJ(IPF+1:IPF+IAB)+CPLA*ABIJ(IPF+1:IPF+IAB) + if (INDA == INDB) call DCOPY_(NVIR(IASYM),[Zero],0,F,NVIR(IASYM)+1) + call FMMM(C(INMY+IPOA(IASYM)),F,A,NVIR(ICSYM),NVIR(IBSYM),NVIR(IASYM)) + S(INNY+IPOB(IBSYM):INNY+IPOB(IBSYM)+NBC-1) = S(INNY+IPOB(IBSYM):INNY+IPOB(IBSYM)+NBC-1)+FACS*A(1:NBC) + W(INNY+IPOB(IBSYM):INNY+IPOB(IBSYM)+NBC-1) = W(INNY+IPOB(IBSYM):INNY+IPOB(IBSYM)+NBC-1)+FACWB*A(1:NBC) + if (INDA /= INDB) then + IPF = IPOF(IBSYM) + F(1:IAB) = CPL*AJBI(IPF+1:IPF+IAB)+CPLA*ABIJ(IPF+1:IPF+IAB) + call FMMM(C(INNY+IPOB(IBSYM)),F,A,NVIR(ICSYM),NVIR(IASYM),NVIR(IBSYM)) + S(INMY+IPOA(IASYM):INMY+IPOA(IASYM)+NAC-1) = S(INMY+IPOA(IASYM):INMY+IPOA(IASYM)+NAC-1)+FACS*A(1:NAC) + W(INMY+IPOA(IASYM):INMY+IPOA(IASYM)+NAC-1) = W(INMY+IPOA(IASYM):INMY+IPOA(IASYM)+NAC-1)+FACWA*A(1:NAC) + end if + else + ! CASE 2 , IASYM > ICSYM AND ICSYM > OR = IBSYM + IPF = IPOF(IBSYM) + F(1:IAB) = CPL*AJBI(IPF+1:IPF+IAB)+CPLA*ABIJ(IPF+1:IPF+IAB) + call MTRANS(C(INMY+IPOA(IASYM)),A,NVIR(IASYM),NVIR(ICSYM)) + call FMMM(F,A,B,NVIR(IBSYM),NVIR(ICSYM),NVIR(IASYM)) + if (NYL == 1) then + A(1:NBC) = FACS*B(1:NBC) + if (IFTB /= 1) then + call SIADD(A,S(INNY+IPOB(ICSYM)),NVIR(IBSYM)) + A(1:NBC) = FACWB*B(1:NBC) + call SIADD(A,W(INNY+IPOB(ICSYM)),NVIR(IBSYM)) + call SQUAR(C(INNY+IPOB(IBSYM)),A,NVIR(IBSYM)) + else + call TRADD(A,S(INNY+IPOB(ICSYM)),NVIR(IBSYM)) + A(1:NBC) = FACWB*B(1:NBC) + call TRADD(A,W(INNY+IPOB(ICSYM)),NVIR(IBSYM)) + call SQUARN(C(INNY+IPOB(IBSYM)),A,NVIR(IBSYM)) + end if + else + if (IFTB /= 1) then + S(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1) = S(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1)+FACS*B(1:NBC) + W(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1) = W(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1)+FACWB*B(1:NBC) + else + S(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1) = S(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1)-FACS*B(1:NBC) + W(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1) = W(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1)-FACWB*B(1:NBC) + end if + call MTRANS(C(INNY+IPOB(ICSYM)),A,NVIR(ICSYM),NVIR(IBSYM)) + if (IFTB == 1) A(1:NBC) = -A(1:NBC) + end if + call FMMM(A,F,B,NVIR(ICSYM),NVIR(IASYM),NVIR(IBSYM)) + S(INMY+IPOA(IASYM):INMY+IPOA(IASYM)+NAC-1) = S(INMY+IPOA(IASYM):INMY+IPOA(IASYM)+NAC-1)+FACS*B(1:NAC) + W(INMY+IPOA(IASYM):INMY+IPOA(IASYM)+NAC-1) = W(INMY+IPOA(IASYM):INMY+IPOA(IASYM)+NAC-1)+FACWA*B(1:NAC) + end if + else + if (ICSYM < IBSYM) then + ! CASE 3 , ICSYM > OR = IASYM AND IBSYM > ICSYM + IPF = IPOF(IASYM) + F(1:IAB) = CPL*AIBJ(IPF+1:IPF+IAB)+CPLA*ABIJ(IPF+1:IPF+IAB) + if (MYL == 1) then + if (IFTA == 0) call SQUAR(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + if (IFTA == 1) call SQUARN(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + else + call MTRANS(C(INMY+IPOA(ICSYM)),A,NVIR(ICSYM),NVIR(IASYM)) + if (IFTA == 1) A(1:NAC) = -A(1:NAC) + end if + call FMMM(A,F,B,NVIR(ICSYM),NVIR(IBSYM),NVIR(IASYM)) + S(INNY+IPOB(IBSYM):INNY+IPOB(IBSYM)+NBC-1) = S(INNY+IPOB(IBSYM):INNY+IPOB(IBSYM)+NBC-1)+FACS*B(1:NBC) + W(INNY+IPOB(IBSYM):INNY+IPOB(IBSYM)+NBC-1) = W(INNY+IPOB(IBSYM):INNY+IPOB(IBSYM)+NBC-1)+FACWB*B(1:NBC) + call MTRANS(C(INNY+IPOB(IBSYM)),A,NVIR(IBSYM),NVIR(ICSYM)) + call FMMM(F,A,B,NVIR(IASYM),NVIR(ICSYM),NVIR(IBSYM)) + if (MYL == 1) then + A(1:NAC) = FACS*B(1:NAC) + if (IFTA /= 1) then + call SIADD(A,S(INMY+IPOA(IASYM)),NVIR(IASYM)) + A(1:NAC) = FACWA*B(1:NAC) + call SIADD(A,W(INMY+IPOA(IASYM)),NVIR(IASYM)) + else + call TRADD(A,S(INMY+IPOA(IASYM)),NVIR(IASYM)) + A(1:NAC) = FACWA*B(1:NAC) + call TRADD(A,W(INMY+IPOA(IASYM)),NVIR(IASYM)) + end if + else if (IFTA /= 1) then + S(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1) = S(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1)+FACS*B(1:NAC) + W(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1) = W(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1)+FACWA*B(1:NAC) + else + S(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1) = S(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1)-FACS*B(1:NAC) + W(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1) = W(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1)-FACWA*B(1:NAC) + end if + else + ! CASE 4 , ICSYM > OR = IASYM AND ICSYM > OR = IBSYM + IPF = IPOF(IBSYM) + F(1:IAB) = CPL*AJBI(IPF+1:IPF+IAB)+CPLA*ABIJ(IPF+1:IPF+IAB) + if (INDA == INDB) call DCOPY_(NVIR(IASYM),[Zero],0,F,NVIR(IASYM)+1) + if (MYL == 1) then + if (IFTA == 0) call SQUAR(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + if (IFTA == 1) call SQUARM(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + else + if (IFTA == 0) call DCOPY_(NAC,C(INMY+IPOA(ICSYM)),1,A,1) + if (IFTA == 1) call VNEG(NAC,C(INMY+IPOA(ICSYM)),1,A,1) + end if + call FMMM(F,A,B,NVIR(IBSYM),NVIR(ICSYM),NVIR(IASYM)) + if (NYL == 1) then + A(1:NBC) = FACS*B(1:NBC) + if (IFTB /= 1) then + call SIADD(A,S(INNY+IPOB(ICSYM)),NVIR(IBSYM)) + A(1:NBC) = FACWB*B(1:NBC) + call SIADD(A,W(INNY+IPOB(ICSYM)),NVIR(IBSYM)) + else + call TRADD(A,S(INNY+IPOB(ICSYM)),NVIR(IBSYM)) + A(1:NBC) = FACWB*B(1:NBC) + call TRADD(A,W(INNY+IPOB(ICSYM)),NVIR(IBSYM)) + end if + else if (IFTB /= 1) then + S(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1) = S(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1)+FACS*B(1:NBC) + W(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1) = W(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1)+FACWB*B(1:NBC) + else + S(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1) = S(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1)-FACS*B(1:NBC) + W(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1) = W(INNY+IPOB(ICSYM):INNY+IPOB(ICSYM)+NBC-1)-FACWB*B(1:NBC) + end if + if (INDA /= INDB) then + IPF = IPOF(IASYM) + F(1:IAB) = CPL*AIBJ(IPF+1:IPF+IAB)+CPLA*ABIJ(IPF+1:IPF+IAB) + if (NYL == 1) then + if (IFTB == 0) call SQUAR(C(INNY+IPOB(IBSYM)),A,NVIR(IBSYM)) + if (IFTB == 1) call SQUARM(C(INNY+IPOB(IBSYM)),A,NVIR(IBSYM)) + else + if (IFTB == 0) call DCOPY_(NBC,C(INNY+IPOB(ICSYM)),1,A,1) + if (IFTB == 1) call VNEG(NBC,C(INNY+IPOB(ICSYM)),1,A,1) + end if + call FMMM(F,A,B,NVIR(IASYM),NVIR(ICSYM),NVIR(IBSYM)) + if (MYL == 1) then + A(1:NAC) = FACS*B(1:NAC) + if (IFTA /= 1) then + call SIADD(A,S(INMY+IPOA(ICSYM)),NVIR(IASYM)) + A(1:NAC) = FACWA*B(1:NAC) + call SIADD(A,W(INMY+IPOA(ICSYM)),NVIR(IASYM)) + else + call TRADD(A,S(INMY+IPOA(ICSYM)),NVIR(IASYM)) + A(1:NAC) = FACWA*B(1:NAC) + call TRADD(A,W(INMY+IPOA(ICSYM)),NVIR(IASYM)) + end if + else if (IFTA /= 1) then + S(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1) = S(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1)+FACS*B(1:NAC) + W(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1) = W(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1)+FACWA*B(1:NAC) + else + S(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1) = S(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1)-FACS*B(1:NAC) + W(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1) = W(INMY+IPOA(ICSYM):INMY+IPOA(ICSYM)+NAC-1)-FACWA*B(1:NAC) + end if + end if + end if + end if + end do + end if + else + ICHK = 1 + end if + else + ICHK = 0 + INDI = IND + NI = ibits(INDI,0,10) + NJ = ibits(INDI,10,10) + NSIJ = MUL(NSM(NI),NSM(NJ)) + call IPO_CPF(IPOF,NVIR,MUL,NSYM,NSIJ,-1) + IJ1 = IROW(NI)+NJ + ILIM = IPOF(NSYM+1) + ABIJ(1:ILIM) = Zero + AIBJ(1:ILIM) = Zero + AJBI(1:ILIM) = Zero + if (ITER /= 1) then + ! READ (AB/IJ) INTEGRALS + IADR = LASTAD(NOVST+IJ1) + JTURN = 0 + Skip = .false. + else + Skip = .true. + end if + do + if (Skip) then + Skip = .false. + else + call iDAFILE(Lu_TiABIJ,2,IBUFIN,LBUF2,IADR) + LENGTH = IBUFIN(LBUF1) + IADR = IBUFIN(LBUF2) + if (LENGTH /= 0) then + if (JTURN /= 1) then + call SCATTER(LENGTH,ABIJ,IBUFIN(LBUF0+1:LBUF0+LENGTH),BUFIN) + else + call SCATTER(LENGTH,AIBJ,IBUFIN(LBUF0+1:LBUF0+LENGTH),BUFIN) + end if + end if + if (IADR /= -1) cycle + if (JTURN == 1) exit + end if + ! READ (AI/BJ) INTEGRALS + IADR = LASTAD(NOVST+NOT2+IJ1) + JTURN = 1 + end do + ! CONSTRUCT FIRST ORDER MATRICES + FAC = Half + if (NI /= NJ) FAC = One + IIN = 0 + IFT = 0 + call IPO_CPF(IPOA,NVIR,MUL,NSYM,NSIJ,IFT) + do + do IASYM=1,NSYM + IBSYM = MUL(NSIJ,IASYM) + if (IBSYM <= IASYM) then + IAB = IPOA(IASYM+1)-IPOA(IASYM) + if (IAB /= 0) then + call SECORD(AIBJ(IPOF(IASYM)+1),AIBJ(IPOF(IBSYM)+1),FSEC(IIN+1),FAC,NVIR(IASYM),NVIR(IBSYM),NSIJ,IFT) + IIN = IIN+IAB + end if + end if + end do + if (IFT == 1) exit + INS = IIN + IFT = 1 + FAC = Zero + end do + ! SQUARE ABIJ + if (ITER /= 1) then + do IASYM=1,NSYM + if (NVIR(IASYM) == 0) cycle + IBSYM = MUL(NSIJ,IASYM) + if (NVIR(IBSYM) == 0) cycle + IPF = IPOF(IASYM)+1 + IPF1 = IPOF(IBSYM)+1 + if (IASYM <= IBSYM) then + if (NSIJ == 1) then + call SQUAR2(ABIJ(IPF),NVIR(IASYM)) + if (NI == NJ) call SQUAR2(AIBJ(IPF),NVIR(IASYM)) + call MTRANS(AIBJ(IPF),AJBI(IPF),NVIR(IASYM),NVIR(IBSYM)) + else + call MTRANS(ABIJ(IPF1),ABIJ(IPF),NVIR(IASYM),NVIR(IBSYM)) + call MTRANS(AIBJ(IPF1),AJBI(IPF),NVIR(IASYM),NVIR(IBSYM)) + end if + else + call MTRANS(AIBJ(IPF1),AJBI(IPF),NVIR(IASYM),NVIR(IBSYM)) + end if + end do + end if + end if + end do + end do + call MDSQ2(C,S,W,MUL,INDX,JSY,NDIAG,INUM,IRC(3),LSYM,NVIRT,SQ2) + !NCONF = JSC(4) + !write(u6,787) (S(I),I=1,NCONF) + !write(u6,786) (W(I),I=1,NCONF) + + nullify(IBUFIN) + + return + + !786 format(1X,'W,FAIBJ',5F10.6) + !787 format(1X,'S,FAIBJ',5F10.6) + +end subroutine MFAIBJ_INTERNAL + +end subroutine MFAIBJ diff -Nru openmolcas-22.02/src/cpf/mfij.f openmolcas-22.10/src/cpf/mfij.f --- openmolcas-22.02/src/cpf/mfij.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/mfij.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,146 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ -cpgi$g opt=1 - SUBROUTINE MFIJ(ICASE,JSY,INDEX,C,S,FC,A,B,FK,DBK,W,THET,ENP, - & EPP,NII) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" - DIMENSION JSY(*),INDEX(*),C(*),S(*),FC(*),A(*),B(*) - DIMENSION FK(*),DBK(*),W(*),THET(NII,NII),ENP(*),EPP(*) - DIMENSION ICASE(*) - PARAMETER (IPOW6=2**6,IPOW13=2**13,IPOW19=2**19) - PARAMETER (IPOW10=2**10) -* - JSYM(L)=JSUNP_CPF(JSY,L) -* - IK = 0 ! dummy initialize - NOB2=IROW(NORBT+1) -C IF(IDENS.EQ.1)WRITE(6,876)(FC(I),I=1,NOB2) -C 876 FORMAT(1X,'FIJ',5F12.6) - ICHK=0 - IF(IDENS.EQ.1)GO TO 105 - NOB2=IROW(NORBT+1) - CALL SETZ(FC,NOB2) - IADD25=0 - CALL dDAFILE(Lu_25,2,FC,NOB2,IADD25) - IF(ITER.EQ.1)GO TO 200 -105 IADD10=IAD10(8) -100 CALL dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) - CALL iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.EQ.0)GO TO 100 - IF(LEN.LT.0)GO TO 200 - DO 10 IN=1,LEN - IND=ICOP1(IN) - IF(ICHK.NE.0)GO TO 460 - IF(IND.NE.0)GO TO 11 - ICHK=1 - GO TO 10 -460 ICHK=0 - INDI=IND -* NI=MOD(INDI,IPOW10) -* NK=MOD(INDI/IPOW10,IPOW10) - NI=IBITS(INDI,0,10) - NK=IBITS(INDI,10,10) - IK=IROW(NK)+NI - GO TO 10 -11 CONTINUE -* IVL=MOD(IND,IPOW6) -* IC2=MOD(IND/IPOW6,IPOW13) -* IC1=MOD(IND/IPOW19,IPOW13) - IVL=IBITS(IND, 0,6) - IC2=IBITS(IND,6,13) - IC1=IBITS(IND,19,13) - COPI=COP(IN)*FC(IK) - IF(IVL.NE.IV0)GO TO 13 - IF(IC1.NE.IREF0)GO TO 16 - IF(IDENS.EQ.1)GO TO 18 - COPI=COPI/SQRT(ENP(IC2)) - S(IC2)=S(IC2)+COPI - IF(ITER.EQ.1)GO TO 10 - EPP(IC2)=EPP(IC2)+COPI*C(IC2) - GO TO 10 -18 FC(IK)=FC(IK)+COP(IN)*C(IC1)*C(IC2)/ENP(IC2) - GO TO 10 -16 IF(IC2.NE.IREF0)GO TO 17 - IF(IDENS.EQ.1)GO TO 19 - COPI=COPI/SQRT(ENP(IC1)) - S(IC1)=S(IC1)+COPI - IF(ITER.EQ.1)GO TO 10 - EPP(IC1)=EPP(IC1)+COPI*C(IC1) - GO TO 10 -19 FC(IK)=FC(IK)+COP(IN)*C(IC1)*C(IC2)/ENP(IC1) - GO TO 10 -17 IF(IDENS.EQ.1)GO TO 21 - ENPQ=(D1-THET(IC1,IC2)/D2)*(ENP(IC1)+ENP(IC2)-D1)+ - *THET(IC1,IC2)/D2 - FACS=SQRT(ENP(IC1))*SQRT(ENP(IC2))/ENPQ - FACW=FACS*(D2-THET(IC1,IC2))/ENPQ - FACWA=FACW*ENP(IC1)-FACS - FACWB=FACW*ENP(IC2)-FACS - S(IC1)=S(IC1)+FACS*COPI*C(IC2) - S(IC2)=S(IC2)+FACS*COPI*C(IC1) - W(IC1)=W(IC1)+FACWA*COPI*C(IC2) - W(IC2)=W(IC2)+FACWB*COPI*C(IC1) - GO TO 10 -21 ENPQ=(D1-THET(IC1,IC2)/D2)*(ENP(IC1)+ENP(IC2)-D1)+ - *THET(IC1,IC2)/D2 - FC(IK)=FC(IK)+COP(IN)*C(IC1)*C(IC2)/ENPQ - GO TO 10 -13 INDA=IRC(IVL)+IC1 - INDB=IRC(IVL)+IC2 - NA=INDEX(INDA) - NB=INDEX(INDB) - NS1=JSYM(INDA) - NS1L=MUL(NS1,LSYM) - INUM=NVIR(NS1L) - IF(IVL.GE.2)INUM=NNS(NS1L) - IF(IDENS.EQ.1)GO TO 15 - ENPQ=(D1-THET(INDA,INDB)/D2)*(ENP(INDA)+ENP(INDB)-D1)+ - *THET(INDA,INDB)/D2 - FACS=SQRT(ENP(INDA))*SQRT(ENP(INDB))/ENPQ - FACW=FACS*(D2-THET(INDA,INDB))/ENPQ - FACWA=FACW*ENP(INDA)-FACS - FACWB=FACW*ENP(INDB)-FACS - CALL DAXPY_(INUM,COPI*FACS,C(NB+1),1,S(NA+1),1) - CALL DAXPY_(INUM,COPI*FACS,C(NA+1),1,S(NB+1),1) - CALL DAXPY_(INUM,COPI*FACWA,C(NB+1),1,W(NA+1),1) - CALL DAXPY_(INUM,COPI*FACWB,C(NA+1),1,W(NB+1),1) - GO TO 10 -15 TERM=DDOT_(INUM,C(NA+1),1,C(NB+1),1) - ENPQ=(D1-THET(INDA,INDB)/D2)*(ENP(INDA)+ENP(INDB)-D1)+ - *THET(INDA,INDB)/D2 - FC(IK)=FC(IK)+COP(IN)*TERM/ENPQ -10 CONTINUE - GO TO 100 -C 200 IF(IDENS.EQ.1)WRITE(6,876)(FC(I),I=1,NOB2) -200 CALL dMAI(C) - IF(ITER.EQ.1)RETURN - CALL MAB(ICASE,JSY,INDEX,C,S,FC,A,B,FK,W,THET,ENP,NII) - RETURN -* -* This is to allow type punning without an explicit interface - CONTAINS - SUBROUTINE dMAI(C) - USE ISO_C_BINDING - REAL*8, TARGET :: C(*) - INTEGER, POINTER :: iC(:) - CALL C_F_POINTER(C_LOC(C(1)),iC,[1]) - CALL MAI(JSY,INDEX,C,S,FC,C,iC,A,B,FK,DBK,W,THET,ENP,EPP,NII,0) - NULLIFY(iC) - END SUBROUTINE dMAI -* - END diff -Nru openmolcas-22.02/src/cpf/mfij.F90 openmolcas-22.10/src/cpf/mfij.F90 --- openmolcas-22.02/src/cpf/mfij.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/mfij.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,138 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine MFIJ(ICASE,JSY,INDX,C,S,FC,A,B,FK,DBK,W,THET,ENP,EPP,NII) + +use cpf_global, only: IDENS, IRC, IREF0, IROW, ITER, IV0, LSYM, Lu_25, Lu_CIGuga, NNS, NORBT, NVIR +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Constants, only: One, Two, Half +use Definitions, only: wp, iwp, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: ICASE(*), JSY(*), INDX(*), NII +real(kind=wp), intent(inout) :: C(*), S(*), FC(*), FK(*), W(*), EPP(*) +real(kind=wp), intent(_OUT_) :: A(*), B(*), DBK(*) +real(kind=wp), intent(in) :: THET(NII,NII), ENP(*) +integer(kind=iwp) :: IADD10, IADD25, IC1, IC2, ICHK, IIN, IK, ILEN, IND, INDA, INDB, INDI, INUM, IVL, NA, NB, NI, NK, NOB2, NS1, & + NS1L +real(kind=wp) :: COPI, ENPQ, FACS, FACW, FACWA, FACWB, TERM +integer(kind=iwp), external :: JSUNP +real(kind=r8), external :: DDOT_ + +IK = 0 ! dummy initialize +NOB2 = IROW(NORBT+1) +!if (IDENS == 1) write(6,876) (FC(I),I=1,NOB2) +ICHK = 0 +if (IDENS /= 1) then + NOB2 = IROW(NORBT+1) + IADD25 = 0 + call dDAFILE(Lu_25,2,FC,NOB2,IADD25) +end if +if ((IDENS == 1) .or. (ITER /= 1)) then + IADD10 = IAD10(8) + do + call dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) + call iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN == 0) cycle + if (ILEN < 0) exit + do IIN=1,ILEN + IND = ICOP1(IIN) + if (ICHK == 0) then + if (IND /= 0) then + IVL = ibits(IND,0,6) + IC2 = ibits(IND,6,13) + IC1 = ibits(IND,19,13) + COPI = COP(IIN)*FC(IK) + if (IVL == IV0) then + if (IC1 == IREF0) then + if (IDENS /= 1) then + COPI = COPI/sqrt(ENP(IC2)) + S(IC2) = S(IC2)+COPI + if (ITER /= 1) EPP(IC2) = EPP(IC2)+COPI*C(IC2) + else + FC(IK) = FC(IK)+COP(IIN)*C(IC1)*C(IC2)/ENP(IC2) + end if + else if (IC2 == IREF0) then + if (IDENS /= 1) then + COPI = COPI/sqrt(ENP(IC1)) + S(IC1) = S(IC1)+COPI + if (ITER /= 1) EPP(IC1) = EPP(IC1)+COPI*C(IC1) + else + FC(IK) = FC(IK)+COP(IIN)*C(IC1)*C(IC2)/ENP(IC1) + end if + else if (IDENS /= 1) then + ENPQ = (One-THET(IC1,IC2)*Half)*(ENP(IC1)+ENP(IC2)-One)+THET(IC1,IC2)*Half + FACS = sqrt(ENP(IC1))*sqrt(ENP(IC2))/ENPQ + FACW = FACS*(Two-THET(IC1,IC2))/ENPQ + FACWA = FACW*ENP(IC1)-FACS + FACWB = FACW*ENP(IC2)-FACS + S(IC1) = S(IC1)+FACS*COPI*C(IC2) + S(IC2) = S(IC2)+FACS*COPI*C(IC1) + W(IC1) = W(IC1)+FACWA*COPI*C(IC2) + W(IC2) = W(IC2)+FACWB*COPI*C(IC1) + else + ENPQ = (One-THET(IC1,IC2)*Half)*(ENP(IC1)+ENP(IC2)-One)+THET(IC1,IC2)*Half + FC(IK) = FC(IK)+COP(IIN)*C(IC1)*C(IC2)/ENPQ + end if + else + INDA = IRC(IVL)+IC1 + INDB = IRC(IVL)+IC2 + NA = INDX(INDA) + NB = INDX(INDB) + NS1 = JSUNP(JSY,INDA) + NS1L = MUL(NS1,LSYM) + INUM = NVIR(NS1L) + if (IVL >= 2) INUM = NNS(NS1L) + if (IDENS /= 1) then + ENPQ = (One-THET(INDA,INDB)*Half)*(ENP(INDA)+ENP(INDB)-One)+THET(INDA,INDB)*Half + FACS = sqrt(ENP(INDA))*sqrt(ENP(INDB))/ENPQ + FACW = FACS*(Two-THET(INDA,INDB))/ENPQ + FACWA = FACW*ENP(INDA)-FACS + FACWB = FACW*ENP(INDB)-FACS + S(NA+1:NA+INUM) = S(NA+1:NA+INUM)+COPI*FACS*C(NB+1:NB+INUM) + S(NB+1:NB+INUM) = S(NB+1:NB+INUM)+COPI*FACS*C(NA+1:NA+INUM) + W(NA+1:NA+INUM) = W(NA+1:NA+INUM)+COPI*FACWA*C(NB+1:NB+INUM) + W(NB+1:NB+INUM) = W(NB+1:NB+INUM)+COPI*FACWB*C(NA+1:NA+INUM) + else + TERM = DDOT_(INUM,C(NA+1),1,C(NB+1),1) + ENPQ = (One-THET(INDA,INDB)*Half)*(ENP(INDA)+ENP(INDB)-One)+THET(INDA,INDB)*Half + FC(IK) = FC(IK)+COP(IIN)*TERM/ENPQ + end if + end if + else + ICHK = 1 + end if + else + ICHK = 0 + INDI = IND + NI = ibits(INDI,0,10) + NK = ibits(INDI,10,10) + IK = IROW(NK)+NI + end if + end do + end do +end if +!if (DENS == 1) write(u6,876) (FC(I),I=1,NOB2) +call MAI(JSY,INDX,C,S,FC,C,A,B,FK,DBK,W,THET,ENP,EPP,NII,0) +if (ITER /= 1) call MAB(ICASE,JSY,INDX,C,S,FC,A,B,FK,W,THET,ENP,NII) + +return + +!876 format(1X,'FIJ',5F12.6) + +end subroutine MFIJ diff -Nru openmolcas-22.02/src/cpf/mijkl.f openmolcas-22.10/src/cpf/mijkl.f --- openmolcas-22.02/src/cpf/mijkl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/mijkl.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,129 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ -cpgi$g opt=1 - SUBROUTINE MIJKL(JSY,INDEX,C,S,FIJKL,BUFIN,IBUFIN,W,THET, - & ENP,EPP,NII) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" - DIMENSION JSY(*),INDEX(*),C(*),S(*),FIJKL(*),BUFIN(*) - DIMENSION IBUFIN(*),W(*),THET(NII,NII),ENP(*),EPP(*) - PARAMETER (IPOW8=2**8, IPOW16=2**16, IPOW24=2**24) - PARAMETER (IPOW6=2**6, IPOW13=2**13, IPOW19=2**19) -* - JSYM(L)=JSUNP_CPF(JSY,L) -* - FINI = D0 ! dummy initialize - NCONF=JSC(4) - ICHK=0 - NIJ=IROW(LN+1) - NIJKL=NIJ*(NIJ+1)/2 - DO 5 I=1,NIJKL - FIJKL(I)=D0 -5 CONTINUE - KKBUF0=(RTOI*(KBUFF1+2)-2)/(RTOI+1) - KKBUF1=RTOI*KKBUF0+KKBUF0+1 - KKBUF2=KKBUF1+1 - IADR=LASTAD(1) -201 CALL iDAFILE(Lu_TiABCI,2,IBUFIN,KKBUF2,IADR) - LENGTH=IBUFIN(KKBUF1) - IADR=IBUFIN(KKBUF2) - IF(LENGTH.EQ.0)GO TO 209 - CALL SCATTER(LENGTH,FIJKL,IBUFIN(RTOI*KKBUF0+1),BUFIN) -209 IF(IADR.NE.-1) GO TO 201 - IADD10=IAD10(5) -100 CALL dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) - CALL iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.EQ.0)GO TO 100 - IF(LEN.LT.0)GO TO 200 - DO 10 IN=1,LEN - IND=ICOP1(IN) - IF(ICHK.NE.0)GO TO 460 - IF(IND.NE.0)GO TO 22 - ICHK=1 - GO TO 10 -460 ICHK=0 - INDI=IND -* IP=MOD(INDI,IPOW8) -* JP=MOD(INDI/IPOW8,IPOW8) -* KP=MOD(INDI/IPOW16,IPOW8) -* LP=MOD(INDI/IPOW24,IPOW8) - IP=IBITS(INDI,0,8) - JP=IBITS(INDI,8,8) - KP=IBITS(INDI,16,8) - LP=IBITS(INDI,24,8) - NIJ=IROW(IP)+JP - NKL=IROW(KP)+LP - IND=NIJ*(NIJ-1)/2+NKL - FINI=FIJKL(IND) - GO TO 10 -22 IF(ABS(FINI).LT.1.d-06)GO TO 10 -CPAM97 IVL=IAND(IND,63) -CPAM97 IC2=IAND(ISHFT(IND,-6),8191) -CPAM97 IC1=IAND(ISHFT(IND,-19),8191) -* IVL=MOD(IND,IPOW6) -* IC2=MOD(IND/IPOW6,IPOW13) -* IC1=MOD(IND/IPOW19,IPOW13) - IVL=IBITS(IND, 0,6) - IC2=IBITS(IND,6,13) - IC1=IBITS(IND,19,13) - COPI=COP(IN)*FINI - IF(IVL.NE.0)GO TO 13 - IF(IC1.NE.IREF0)GO TO 16 - COPI=COPI/SQRT(ENP(IC2)) - S(IC2)=S(IC2)+COPI - IF(ITER.EQ.1)GO TO 10 - EPP(IC2)=EPP(IC2)+COPI*C(IC2) - GO TO 10 -16 IF(IC2.NE.IREF0)GO TO 17 - COPI=COPI/SQRT(ENP(IC1)) - S(IC1)=S(IC1)+COPI - IF(ITER.EQ.1)GO TO 10 - EPP(IC1)=EPP(IC1)+COPI*C(IC1) - GO TO 10 -17 ENPQ=(D1-THET(IC1,IC2)/D2)*(ENP(IC1)+ENP(IC2)-D1)+ - *THET(IC1,IC2)/D2 - FACS=SQRT(ENP(IC1))*SQRT(ENP(IC2))/ENPQ - FACW=FACS*(D2-THET(IC1,IC2))/ENPQ - FACWA=FACW*ENP(IC1)-FACS - FACWB=FACW*ENP(IC2)-FACS - S(IC1)=S(IC1)+FACS*COPI*C(IC2) - S(IC2)=S(IC2)+FACS*COPI*C(IC1) - W(IC1)=W(IC1)+FACWA*COPI*C(IC2) - W(IC2)=W(IC2)+FACWB*COPI*C(IC1) - GO TO 10 -13 INDA=IRC(IVL)+IC1 - INDB=IRC(IVL)+IC2 - ENPQ=(D1-THET(INDA,INDB)/D2)*(ENP(INDA)+ENP(INDB)-D1)+ - *THET(INDA,INDB)/D2 - FACS=SQRT(ENP(INDA))*SQRT(ENP(INDB))/ENPQ - FACW=FACS*(D2-THET(INDA,INDB))/ENPQ - FACWA=FACW*ENP(INDA)-FACS - FACWB=FACW*ENP(INDB)-FACS - NA=INDEX(INDA) - NB=INDEX(INDB) - NS1=JSYM(INDA) - NS1L=MUL(NS1,LSYM) - INUM=NVIR(NS1L) - IF(IVL.GE.2)INUM=NNS(NS1L) - CALL DAXPY_(INUM,COPI*FACS,C(NB+1),1,S(NA+1),1) - CALL DAXPY_(INUM,COPI*FACS,C(NA+1),1,S(NB+1),1) - CALL DAXPY_(INUM,COPI*FACWA,C(NB+1),1,W(NA+1),1) - CALL DAXPY_(INUM,COPI*FACWB,C(NA+1),1,W(NB+1),1) -10 CONTINUE - GO TO 100 -200 RETURN - END diff -Nru openmolcas-22.02/src/cpf/mijkl.F90 openmolcas-22.10/src/cpf/mijkl.F90 --- openmolcas-22.02/src/cpf/mijkl.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/mijkl.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,145 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine MIJKL(JSY,INDX,C,S,FIJKL,BUFIN,W,THET,ENP,EPP,NII) + +use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc +use cpf_global, only: IRC, IREF0, IROW, ITER, JSC, KBUFF1, LASTAD, LN, LSYM, Lu_CIGuga, Lu_TiABCI, NCONF, NNS, NVIR +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Constants, only: Zero, One, Two, Half +use Definitions, only: wp, iwp, RtoI + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: JSY(*), INDX(*), NII +real(kind=wp), intent(in) :: C(*), THET(NII,NII), ENP(*) +real(kind=wp), intent(inout) :: S(*), W(*), EPP(*) +real(kind=wp), intent(_OUT_) :: FIJKL(*), BUFIN(*) +integer(kind=iwp) :: IADD10, IADR, IC1, IC2, ICHK, ILEN, IND, INDA, INDB, INDI, INUM, IP, IVL, JP, KKBUF0, KKBUF1, KKBUF2, KP, & + LENGTH, LP, NA, NB, NIJ, NIJKL, NKL, NS1, NS1L +real(kind=wp) :: COPI, ENPQ, FACS, FACW, FACWA, FACWB, FINI +integer(kind=iwp), external :: JSUNP + +call MIJKL_INTERNAL(BUFIN) + +! This is to allow type punning without an explicit interface +contains + +subroutine MIJKL_INTERNAL(BUFIN) + + real(kind=wp), target, intent(_OUT_) :: BUFIN(*) + integer(kind=iwp), pointer :: IBUFIN(:) + integer(kind=iwp) :: IIN + + call c_f_pointer(c_loc(BUFIN),iBUFIN,[1]) + + FINI = Zero ! dummy initialize + NCONF = JSC(4) + ICHK = 0 + NIJ = IROW(LN+1) + NIJKL = NIJ*(NIJ+1)/2 + FIJKL(1:NIJKL) = Zero + KKBUF0 = (RTOI*(KBUFF1+2)-2)/(RTOI+1) + KKBUF1 = RTOI*KKBUF0+KKBUF0+1 + KKBUF2 = KKBUF1+1 + IADR = LASTAD(1) + do + call iDAFILE(Lu_TiABCI,2,IBUFIN,KKBUF2,IADR) + LENGTH = IBUFIN(KKBUF1) + IADR = IBUFIN(KKBUF2) + if (LENGTH /= 0) call SCATTER(LENGTH,FIJKL,IBUFIN(RTOI*KKBUF0+1:RTOI*KKBUF0+LENGTH),BUFIN) + if (IADR == -1) exit + end do + IADD10 = IAD10(5) + do + call dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) + call iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN == 0) cycle + if (ILEN < 0) exit + do IIN=1,ILEN + IND = ICOP1(IIN) + if (ICHK == 0) then + if (IND /= 0) then + if (abs(FINI) < 1.0e-6_wp) cycle + IVL = ibits(IND,0,6) + IC2 = ibits(IND,6,13) + IC1 = ibits(IND,19,13) + COPI = COP(IIN)*FINI + if (IVL == 0) then + if (IC1 == IREF0) then + COPI = COPI/sqrt(ENP(IC2)) + S(IC2) = S(IC2)+COPI + if (ITER /= 1) EPP(IC2) = EPP(IC2)+COPI*C(IC2) + else if (IC2 == IREF0) then + COPI = COPI/sqrt(ENP(IC1)) + S(IC1) = S(IC1)+COPI + if (ITER /= 1) EPP(IC1) = EPP(IC1)+COPI*C(IC1) + else + ENPQ = (One-THET(IC1,IC2)*Half)*(ENP(IC1)+ENP(IC2)-One)+THET(IC1,IC2)*Half + FACS = sqrt(ENP(IC1))*sqrt(ENP(IC2))/ENPQ + FACW = FACS*(Two-THET(IC1,IC2))/ENPQ + FACWA = FACW*ENP(IC1)-FACS + FACWB = FACW*ENP(IC2)-FACS + S(IC1) = S(IC1)+FACS*COPI*C(IC2) + S(IC2) = S(IC2)+FACS*COPI*C(IC1) + W(IC1) = W(IC1)+FACWA*COPI*C(IC2) + W(IC2) = W(IC2)+FACWB*COPI*C(IC1) + end if + else + INDA = IRC(IVL)+IC1 + INDB = IRC(IVL)+IC2 + ENPQ = (One-THET(INDA,INDB)*Half)*(ENP(INDA)+ENP(INDB)-One)+THET(INDA,INDB)*Half + FACS = sqrt(ENP(INDA))*sqrt(ENP(INDB))/ENPQ + FACW = FACS*(Two-THET(INDA,INDB))/ENPQ + FACWA = FACW*ENP(INDA)-FACS + FACWB = FACW*ENP(INDB)-FACS + NA = INDX(INDA) + NB = INDX(INDB) + NS1 = JSUNP(JSY,INDA) + NS1L = MUL(NS1,LSYM) + INUM = NVIR(NS1L) + if (IVL >= 2) INUM = NNS(NS1L) + S(NA+1:NA+INUM) = S(NA+1:NA+INUM)+COPI*FACS*C(NB+1:NB+INUM) + S(NB+1:NB+INUM) = S(NB+1:NB+INUM)+COPI*FACS*C(NA+1:NA+INUM) + W(NA+1:NA+INUM) = W(NA+1:NA+INUM)+COPI*FACWA*C(NB+1:NB+INUM) + W(NB+1:NB+INUM) = W(NB+1:NB+INUM)+COPI*FACWB*C(NA+1:NA+INUM) + end if + else + ICHK = 1 + end if + else + ICHK = 0 + INDI = IND + IP = ibits(INDI,0,8) + JP = ibits(INDI,8,8) + KP = ibits(INDI,16,8) + LP = ibits(INDI,24,8) + NIJ = IROW(IP)+JP + NKL = IROW(KP)+LP + IND = NIJ*(NIJ-1)/2+NKL + FINI = FIJKL(IND) + end if + end do + end do + + nullify(IBUFIN) + + return + +end subroutine MIJKL_INTERNAL + +end subroutine MIJKL diff -Nru openmolcas-22.02/src/cpf/mpsq2.f openmolcas-22.10/src/cpf/mpsq2.f --- openmolcas-22.02/src/cpf/mpsq2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/mpsq2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE MPSQ2(C,S,W,MUL,INDEX,JSY,NDIAG,INUM,IRC3,LSYM, - *NVIRT,SQ2) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION C(*),S(*),W(*),MUL(8,8),INDEX(*),JSY(*),NDIAG(*) -CPAM97 INTEGER UNPACK -CPAM97 EXTERNAL UNPACK -CRL JSYM(L)=IAND(ISHFT(JSY((L+19)/20),-3*((L+19)/20*20-L)),7)+1 -CPAM96 JSYM(L)=UNPACK(JSY((L+9)/10),3*MOD(L-1,10)+1,3)+1 - JSYM(L)=JSUNP_CPF(JSY,L) - DO 10 I=1,INUM - II1=IRC3+I - NS1=JSYM(II1) - NS1L=MUL(NS1,LSYM) - IF(NS1L.NE.1)GO TO 10 - NA=INDEX(II1) - DO 20 MA=1,NVIRT - C(NA+NDIAG(MA))=SQ2*C(NA+NDIAG(MA)) - S(NA+NDIAG(MA))=S(NA+NDIAG(MA))/SQ2 - W(NA+NDIAG(MA))=W(NA+NDIAG(MA))/SQ2 -20 CONTINUE -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/mpsq2.F90 openmolcas-22.10/src/cpf/mpsq2.F90 --- openmolcas-22.02/src/cpf/mpsq2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/mpsq2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,42 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine MPSQ2(C,S,W,MUL,INDX,JSY,NDIAG,INUM,IRC3,LSYM,NVIRT,SQ2) + +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(inout) :: C(*), S(*), W(*) +integer(kind=iwp), intent(in) :: MUL(8,8), INDX(*), JSY(*), NDIAG(*), INUM, IRC3, LSYM, NVIRT +real(kind=wp), intent(in) :: SQ2 +integer(kind=iwp) :: I, II1, MA, NA, NS1, NS1L +integer(kind=iwp), external :: JSUNP + +do I=1,INUM + II1 = IRC3+I + NS1 = JSUNP(JSY,II1) + NS1L = MUL(NS1,LSYM) + if (NS1L == 1) then + NA = INDX(II1) + do MA=1,NVIRT + C(NA+NDIAG(MA)) = SQ2*C(NA+NDIAG(MA)) + S(NA+NDIAG(MA)) = S(NA+NDIAG(MA))/SQ2 + W(NA+NDIAG(MA)) = W(NA+NDIAG(MA))/SQ2 + end do + end if +end do + +return + +end subroutine MPSQ2 diff -Nru openmolcas-22.02/src/cpf/mtrans.f openmolcas-22.10/src/cpf/mtrans.f --- openmolcas-22.02/src/cpf/mtrans.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/mtrans.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE MTRANS_CPF(A,B,N,M) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(M,N),B(N,M) - DO 10 I=1,N - DO 20 J=1,M - B(I,J)=A(J,I) -20 CONTINUE -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/natct.f openmolcas-22.10/src/cpf/natct.f --- openmolcas-22.02/src/cpf/natct.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/natct.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,144 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE NATCT(H,LIC0) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" - DIMENSION H(LIC0) - Character*72 Header - Dimension Dummy(1),iDummy(7,8) -* - NSUM =0 - N2SUM=0 - n2Tri = 0 - nbMax = 0 - DO 9 ISYM=1,NSYM - nbMax = Max(nbMax,nBas(iSym)) - NSUM =NSUM +NBAS(ISYM) - N2SUM=N2SUM+NBAS(ISYM)**2 - n2Tri = n2Tri + nBas(iSym)*(nBas(iSym)+1)/2 -9 CONTINUE - -* Read MO coefficients - IDISK=ITOC17(1) - CALL dDAFILE(Lu_TraOne,2,H(LW(87)),N2SUM,IDISK) - IF (LW(87)+N2SUM-1.ge.LW(88)) THEN - WRITE(6,*) - WRITE(6,'(6X,A)')'*** ERROR IN SUBROUTINE NATCT ***' - WRITE(6,'(6X,A)')'NO SPACE LEFT TO GENERATE FINAL ORBITALS' - WRITE(6,*) - CALL XFLUSH(6) - Call Abend - ENDIF -* -* Loop over irreps and compute natural orbitals -* - IOCC=LW(90) - ICMO=LW(87) - DO 10 M=1,NSYM -* set occupation number of orbitals prefrozen in MOTRA - CALL DCOPY_(NBAS(M),[0.0D0],0,H(IOCC),1) -* skip orbitals prefrozen in MOTRA - CALL DCOPY_(NPFRO(M),[2.0D0],0,H(IOCC),1) - CALL NATORB_CPF(H(LW(62)),H(ICMO+NBAS(M)*NPFRO(M)),H(LW(88)), - & H(LW(89)),H(LW(89)),H(IOCC+NPFRO(M)),M) - CALL DCOPY_(NORB(M)*NBAS(M),H(LW(89)),1, - & H(ICMO+NBAS(M)*NPFRO(M)),1) - ICMO=ICMO+NBAS(M)**2 - IOCC=IOCC+NBAS(M) -10 CONTINUE - - LW91A = LW(91) - LW91B = LW91A + n2Sum - If (LW91B+n2Tri-1.gt.Lic) Then - WRITE(6,*) ' Not enough core in NATCT' - CALL XFLUSH(6) - Call ErrTra - Call Abend - End If - Call RelEne(ErelMV,ErelDC,nSym,nBas,H(LW(87)), - * H(LW(90)),H(LW91A),H(LW91B)) - - EREL=ERELMV+ERELDC - WRITE(6,'(/,5X,A)') 'FIRST ORDER RELATIVISTIC CORRECTIONS' - WRITE(6,'(5X,A,F17.8)') - * 'MASS-VELOCITY ', ErelMV - WRITE(6,'(5X,A,F17.8)') - * '1-EL DARWIN CONTACT ', ErelDC - WRITE(6,'(5X,A,F17.8)') - * 'TOTAL REL. CORRECTION', Erel - IF (ISDCI.EQ.1) THEN - WRITE(6,'(5X,A,F17.8)') - * 'REL. CI ENERGY ', ETOT+Erel - WRITE(6,'(5X,A,F17.8)') - * 'REL. CI+Q ENERGY ',DETOT+Erel - ELSE - WRITE(6,'(5X,A,F17.8)') - * 'TOTAL REL. ENERGY ', ETOT+Erel - END IF - CALL XFLUSH(6) - CALL dPRWF(H) - If (iCPF.eq.1) Then - Header=' CPF natural orbitals' - Else If (iSDCI.eq.1) Then - Header=' SDCI natural orbitals' - Else If (iNCPF.eq.1) Then - Header=' ACPF natural orbitals' - Else - Header=' MCPF natural orbitals' - End If - Call Primo(Header,.True.,.False.,1.0D-4,dum,nSym,nBas,nBas, - * Name,Dummy,H(LW(90)),H(LW(87)),-1) -* -* Read the overlap matrix in ao basis - iiRC=-1 - iOpt = 6 - Call RdOne(iiRC,iOpt,'MLTPL 0',1,H(LW(91)),iDum) - If (iiRC.ne.0) Then - Write (6,*) 'Natct: Error reading overlap matrix!' - Call Abend - End If - Call Charge(nSym,nBas,Name,H(LW(87)),H(LW(90)),H(LW(91)),2,.True., - & .True.) - Call Prpt_old(nSym,nBas,nSum,n2Sum,H(LW(87)),H(LW(90))) -* - If (iCPF.eq.1) Then - Header='* CPF NO COEFS' - Else If (iSDCI.eq.1) Then - Header='* SDCI NO COEFS' - Else If (iNCPF.eq.1) Then - Header='* ACPF NO COEFS' - Else - Header='* MCPF NO COEFS' - End If - Call WrVec('CPFORB',Lu_CPFORB,'CO',nSym,nBas,nBas, - & H(LW(87)), H(LW(90)), Dummy, iDummy, Header) -* - RETURN -* -* This is to allow type punning without an explicit interface - CONTAINS - SUBROUTINE dPRWF(H) - USE ISO_C_BINDING - REAL*8, TARGET :: H(*) - INTEGER, POINTER :: iH1(:),iH2(:),iH3(:) - CALL C_F_POINTER(C_LOC(H(LW(1))),iH1,[1]) - CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL C_F_POINTER(C_LOC(H(LW(3))),iH3,[1]) - CALL PRWF_CPF(iH1,iH2,iH3,H(LW(26))) - NULLIFY(iH1,iH2,iH3) - END SUBROUTINE dPRWF -* - END diff -Nru openmolcas-22.02/src/cpf/natct.F90 openmolcas-22.10/src/cpf/natct.F90 --- openmolcas-22.02/src/cpf/natct.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/natct.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,126 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine NATCT(C,FC) + +use cpf_global, only: BNAME, DETOT, ETOT, ICASE, ICPF, INCPF, INDX, ISDCI, ITOC17, JSY, Lu_CPFORB, Lu_TraOne, NBAS, NORB, NPFRO, & + NSYM +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, Two +use Definitions, only: wp, iwp, u6 + +implicit none +real(kind=wp), intent(inout) :: C(*) +real(kind=wp), intent(in) :: FC(*) +integer(kind=iwp) :: ICMO, IDISK, iDum, iDummy(7,8), iiRC, IOCC, iOpt, iSYM, M, N2SUM, n2Tri, nbMax, NSUM +real(kind=wp) :: dum, Dummy(1), EREL, ErelDC, ErelMV +character(len=72) :: Header +real(kind=wp), allocatable :: CAO(:), CMO(:), CMO2(:), D(:), DSYM(:), OCC(:), OP(:), S(:) + +NSUM = 0 +N2SUM = 0 +n2Tri = 0 +nbMax = 0 +do ISYM=1,NSYM + nbMax = max(nbMax,nBas(iSym)) + NSUM = NSUM+NBAS(ISYM) + N2SUM = N2SUM+NBAS(ISYM)**2 + n2Tri = n2Tri+nBas(iSym)*(nBas(iSym)+1)/2 +end do + +! Read MO coefficients +IDISK = ITOC17(1) +call mma_allocate(CMO,N2SUM,label='CMO') +call dDAFILE(Lu_TraOne,2,CMO,N2SUM,IDISK) + +! Loop over irreps and compute natural orbitals + +call mma_allocate(OCC,NSUM,label='OCC') +call mma_allocate(CMO2,nbMax**2,label='CMO2') +call mma_allocate(DSYM,nbMax**2,label='DSYM') +call mma_allocate(CAO,nbMax**2,label='CAO') +IOCC = 1 +ICMO = 1 +do M=1,NSYM + ! set occupation number of orbitals prefrozen in MOTRA + OCC(IOCC:IOCC+NBAS(M)-1) = Zero + ! skip orbitals prefrozen in MOTRA + OCC(IOCC:IOCC+NPFRO(M)-1) = Two + call NATORB_CPF(FC,CMO(ICMO+NBAS(M)*NPFRO(M)),CMO2,DSYM,CAO,OCC(IOCC+NPFRO(M)),M) + call DCOPY_(NORB(M)*NBAS(M),CAO,1,CMO(ICMO+NBAS(M)*NPFRO(M)),1) + ICMO = ICMO+NBAS(M)**2 + IOCC = IOCC+NBAS(M) +end do +call mma_deallocate(CMO2) +call mma_deallocate(DSYM) +call mma_deallocate(CAO) + +call mma_allocate(D,n2Sum,label='D') +call mma_allocate(OP,n2Tri,label='OP') +call RelEne(ErelMV,ErelDC,nSym,nBas,CMO,OCC,D,OP) +call mma_deallocate(D) +call mma_deallocate(OP) + +EREL = ERELMV+ERELDC +write(u6,'(/,5X,A)') 'FIRST ORDER RELATIVISTIC CORRECTIONS' +write(u6,'(5X,A,F17.8)') 'MASS-VELOCITY ',ErelMV +write(u6,'(5X,A,F17.8)') '1-EL DARWIN CONTACT ',ErelDC +write(u6,'(5X,A,F17.8)') 'TOTAL REL. CORRECTION',Erel +if (ISDCI == 1) then + write(u6,'(5X,A,F17.8)') 'REL. CI ENERGY ',ETOT+Erel + write(u6,'(5X,A,F17.8)') 'REL. CI+Q ENERGY ',DETOT+Erel +else + write(u6,'(5X,A,F17.8)') 'TOTAL REL. ENERGY ',ETOT+Erel +end if +call PRWF_CPF(ICASE,JSY,INDX,C) +if (iCPF == 1) then + Header = ' CPF natural orbitals' +else if (iSDCI == 1) then + Header = ' SDCI natural orbitals' +else if (iNCPF == 1) then + Header = ' ACPF natural orbitals' +else + Header = ' MCPF natural orbitals' +end if +call Primo(Header,.true.,.false.,1.0e-4_wp,dum,nSym,nBas,nBas,BName,Dummy,OCC,CMO,-1) + +! Read the overlap matrix in ao basis +iiRC = -1 +iOpt = 6 +call mma_allocate(S,n2Tri,label='S') +call RdOne(iiRC,iOpt,'MLTPL 0',1,S,iDum) +if (iiRC /= 0) then + write(u6,*) 'Natct: Error reading overlap matrix!' + call Abend() +end if +call Charge(nSym,nBas,BName,CMO,OCC,S,2,.true.,.true.) +call Prpt_old(nSym,nBas,nSum,n2Sum,CMO,OCC) +call mma_deallocate(S) + +if (iCPF == 1) then + Header = '* CPF NO COEFS' +else if (iSDCI == 1) then + Header = '* SDCI NO COEFS' +else if (iNCPF == 1) then + Header = '* ACPF NO COEFS' +else + Header = '* MCPF NO COEFS' +end if +call WrVec('CPFORB',Lu_CPFORB,'CO',nSym,nBas,nBas,CMO,OCC,Dummy,iDummy,Header) +call mma_deallocate(CMO) +call mma_deallocate(OCC) + +return + +end subroutine NATCT diff -Nru openmolcas-22.02/src/cpf/natorb_cpf.F90 openmolcas-22.10/src/cpf/natorb_cpf.F90 --- openmolcas-22.02/src/cpf/natorb_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/natorb_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,106 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine NATORB_CPF(D,CM,CMO,DSYM,CAO,OCC,M) + +use cpf_global, only: ICH, IPRINT, IROW, NASH, NBAS, NFRO, NISH, NORB, NVIR +use Constants, only: Zero, Two +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +real(kind=wp), intent(in) :: D(*), CM(*) +real(kind=wp), intent(_OUT_) :: CMO(*), DSYM(*), CAO(*), OCC(*) +integer(kind=iwp), intent(in) :: M +integer(kind=iwp) :: I, II, IJ, IJ0, ILAS, IP, ISTA, J, JP, kp, M1, NBM, NBP, NFR, NI, NIJ, NJ, NORBM, NORBM2 +real(kind=wp) :: TERM + +! FORM DENSITY MATRIX BY SYMMETRY +NBM = NBAS(M) +if (NBM == 0) return +if (NORB(M) == 0) return +if (IPRINT >= 15) write(u6,1) M +NBP = 0 +M1 = M-1 +do I=1,M1 + NBP = NBP+NORB(I) +end do +NFR = NFRO(M) +NORBM = NFR+NISH(M)+NASH(M)+NVIR(M) +if (NORBM == 0) return +NORBM2 = IROW(NORBM+1) +DSYM(1:NORBM2) = Zero +II = 0 +do I=1,NFR + II = II+I + DSYM(II) = Two +end do +! REST OF DENSITY MATRIX +IJ = 0 +do I=1,NORBM + do J=1,I + IJ = IJ+1 + NI = ICH(NBP+I) + if (NI < 0) cycle + NJ = ICH(NBP+J) + if (NJ < 0) cycle + NIJ = IROW(NI)+NJ + if (NJ > NI) NIJ = IROW(NJ)+NI + DSYM(IJ) = D(NIJ) + end do +end do +! DIAGONALIZE +call JACSCF(DSYM,CMO,OCC,NORBM,-1,1.0e-11_wp) +OCC(1:NORBM) = -OCC(1:NORBM) +call ORDER(CMO,OCC,NORBM) +if (IPRINT >= 15) write(u6,30) +ILAS = 0 +OCC(1:NORBM) = -OCC(1:NORBM) +do I=1,NORBM + ISTA = ILAS+1 + ILAS = ILAS+NORBM + if (IPRINT >= 15) write(u6,40) I,OCC(I),(CMO(J),J=ISTA,ILAS) +end do +! TRANSFORM TO AO-BASIS +if (IPRINT >= 15) write(u6,45) +IJ0 = -NORBM +kp = 1 +do I=1,NORBM + IJ0 = IJ0+NORBM + + do IP=1,NBM + TERM = Zero + IJ = IJ0 + JP = IP-NBM + do J=1,NORBM + IJ = IJ+1 + JP = JP+NBM + TERM = TERM+CMO(IJ)*CM(JP) + end do + CAO(kp+IP-1) = TERM + end do + + if (IPRINT >= 15) write(u6,40) I,OCC(I),(CAO(IP),IP=kp,kp+nbm-1) + kp = kp+NBM +end do + +return + +1 format(///,5X,'SYMMETRY NUMBER',I3) +30 format(//,5X,'NATURAL ORBITALS IN MO-BASIS',//,7X,'OCCUPATION NUMBER',5X,'COEFFICIENTS') +40 format(/,5X,I4,F10.6,5F10.6,/(19X,5F10.6)) +45 format(//,5X,'NATURAL ORBITALS IN AO-BASIS',//,11X,'OCCUPATION NUMBER',5X,'COEFFICIENTS') + +end subroutine NATORB_CPF diff -Nru openmolcas-22.02/src/cpf/natorb.f openmolcas-22.10/src/cpf/natorb.f --- openmolcas-22.02/src/cpf/natorb.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/natorb.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,101 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE NATORB_CPF(D,CM,CMO,DSYM,CAO,OCC,M) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION D(*),CM(*),CMO(*),DSYM(*),CAO(*),OCC(*) - -#include "SysDef.fh" - -#include "cpfmcpf.fh" -C FORM DENSITY MATRIX BY SYMMETRY - NBM=NBAS(M) - IF(NBM.EQ.0)RETURN - IF(NORB(M).EQ.0)RETURN - IF(IPRINT.GE.15)WRITE(6,1)M -1 FORMAT(///,5X,'SYMMETRY NUMBER',I3) - NBP=0 - M1=M-1 - DO 7 I=1,M1 - NBP=NBP+NORB(I) -7 CONTINUE - NFR=NFRO(M) - NORBM=NFR+NISH(M)+NASH(M)+NVIR(M) - IF(NORBM.EQ.0) Return - NORBM2=IROW(NORBM+1) - DO 5 I=1,NORBM2 - DSYM(I)=0.0D0 -5 CONTINUE - IF(NFR.EQ.0)GO TO 10 - II=0 - DO 11 I=1,NFR - II=II+I - DSYM(II)=2.0D0 -11 CONTINUE -C REST OF DENSITY MATRIX -10 IJ=0 - DO 15 I=1,NORBM - DO 20 J=1,I - IJ=IJ+1 - NI=ICH(NBP+I) - IF(NI.LT.0)GO TO 20 - NJ=ICH(NBP+J) - IF(NJ.LT.0)GO TO 20 - NIJ=IROW(NI)+NJ - IF(NJ.GT.NI)NIJ=IROW(NJ)+NI - DSYM(IJ)=D(NIJ) -20 CONTINUE -15 CONTINUE -C DIAGONALIZE - CALL JACSCF(DSYM,CMO,OCC,NORBM,-1,1.D-11) - DO 80 I=1,NORBM - OCC(I)=-OCC(I) -80 CONTINUE - CALL ORDER_CPF(CMO,OCC,NORBM) - IF(IPRINT.GE.15)WRITE(6,30) -30 FORMAT(//,5X,'NATURAL ORBITALS IN MO-BASIS',//, - *7X,'OCCUPATION NUMBER',5X,'COEFFICIENTS') - ILAS=0 - DO 35 I=1,NORBM - ISTA=ILAS+1 - ILAS=ILAS+NORBM - OCC(I)=-OCC(I) - IF(IPRINT.GE.15)WRITE(6,40)I,OCC(I),(CMO(J),J=ISTA,ILAS) -40 FORMAT(/,5X,I4,F10.6,5F10.6,/(19X,5F10.6)) -35 CONTINUE -C TRANSFORM TO AO-BASIS - IF(IPRINT.GE.15)WRITE(6,45) -45 FORMAT(//,5X,'NATURAL ORBITALS IN AO-BASIS',//, - *11X,'OCCUPATION NUMBER',5X,'COEFFICIENTS') - IJ0=-NORBM - kp = 1 - DO 50 I=1,NORBM - IJ0=IJ0+NORBM -* - DO 60 IP=1,NBM - TERM=D0 - IJ=IJ0 - JP=IP-NBM - DO 70 J=1,NORBM - IJ=IJ+1 - JP=JP+NBM - TERM=TERM+CMO(IJ)*CM(JP) -70 CONTINUE - CAO(kp+IP-1)=TERM -60 CONTINUE -* - IF(IPRINT.GE.15)WRITE(6,40)I,OCC(I),(CAO(IP),IP=kp,kp+nbm-1) - kp = kp + NBM -50 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/next.f openmolcas-22.10/src/cpf/next.f --- openmolcas-22.02/src/cpf/next.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/next.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE NEXT(P,DPS,CN) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION P(*),DPS(*),CN(*) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" -C - IAD=IADDP(1) - CALL dDAFILE(Lu_CI,2,P,NCONF,IAD) - ITM=ITPUL-1 - DO 5 I=1,ITM - IN=I+1 - CTOT=0.0D00 - DO 6 J=IN,ITPUL - CTOT=CTOT+CN(J) -6 CONTINUE - IAD=IADDP(I+1) - CALL dDAFILE(Lu_CI,2,DPS,NCONF,IAD) - CALL VSMA(DPS,1,CTOT,P,1,P,1,NCONF) -5 CONTINUE - IF(IPRINT.GE.15)WRITE(6,19)(P(I),I=1,NCONF) -19 FORMAT(6X,'C(NEXT)',5F10.6) -C - IADC(ITPUL+2)=IAD - RETURN - END diff -Nru openmolcas-22.02/src/cpf/next.F90 openmolcas-22.10/src/cpf/next.F90 --- openmolcas-22.02/src/cpf/next.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/next.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,48 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine NEXT(P,DPS,CN) + +use cpf_global, only: IADDP, IPRINT, ITPUL, Lu_CI, NCONF +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +real(kind=wp), intent(_OUT_) :: P(*), DPS(*) +real(kind=wp), intent(in) :: CN(*) +integer(kind=iwp) :: I, IAD, IIN, ITM, J +real(kind=wp) :: CTOT + +IAD = IADDP(1) +call dDAFILE(Lu_CI,2,P,NCONF,IAD) +ITM = ITPUL-1 +do I=1,ITM + IIN = I+1 + CTOT = Zero + do J=IIN,ITPUL + CTOT = CTOT+CN(J) + end do + IAD = IADDP(I+1) + call dDAFILE(Lu_CI,2,DPS,NCONF,IAD) + P(1:NCONF) = P(1:NCONF)+CTOT*DPS(1:NCONF) +end do +if (IPRINT >= 15) write(u6,19) (P(I),I=1,NCONF) + +return + +19 format(6X,'C(NEXT)',5F10.6) + +end subroutine NEXT diff -Nru openmolcas-22.02/src/cpf/npset.f openmolcas-22.10/src/cpf/npset.f --- openmolcas-22.02/src/cpf/npset.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/npset.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,118 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE NPSET(JSY,INDEX,C,TPQ,ENP,T,S,W,EPP,ICASE) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION JSY(*),INDEX(*),C(*),TPQ(*),ENP(*),T(*),S(*) - DIMENSION W(*),EPP(*),ICASE(*) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" -* - JSYM(L)=JSUNP_CPF(JSY,L) -C - IF(IDENS.EQ.1)GO TO 65 - IF(ITPUL.NE.1)GO TO 60 - IAD=0 - IADDP(1)=0 - CALL dDAFILE(Lu_CI,1,C,NCONF,IAD) - IADDP(2)=IAD -C -C VALENCE -C -60 IQ=IRC(1) - DO 30 I=1,IQ - T(I)=C(I)*C(I) -30 CONTINUE -C -C SINGLES -C - IQ=IRC(2)-IRC(1) - IND=IRC(1) - IN=IRC(1) - DO 5 I=1,IQ - IND=IND+1 - NS1=JSYM(IN+I) - NSIL=MUL(NS1,LSYM) - INUM=NVIR(NSIL) - IST=INDEX(IN+I)+1 - T(IND)=DDOT_(INUM,C(IST),1,C(IST),1) -5 CONTINUE -C -C DOUBLES -C - IQ=IRC(4)-IRC(2) - IN=IRC(2) - DO 10 I=1,IQ - IND=IND+1 - NS1=JSYM(IN+I) - NSIL=MUL(NS1,LSYM) - INUM=NNS(NSIL) - IST=INDEX(IN+I)+1 - T(IND)=DDOT_(INUM,C(IST),1,C(IST),1) -10 CONTINUE - IP=IRC(4) - DO 15 I=1,IP - CALL TPQSET(ICASE,TPQ,I) - ENP(I)=DDOT_(IP,TPQ,1,T,1) - ENP(I)=ENP(I)+D1 -15 CONTINUE - IP=IRC(4) - IF(IPRINT.GT.5)WRITE(6,12)(ENP(I),I=1,IP) -12 FORMAT(6X,'ENP ',5F14.8) -C -C VALENCE -C -65 IQ=IRC(1) - DO 6 I=1,IQ - IF(IDENS.EQ.0)EMPI=D1/SQRT(ENP(I)) - IF(IDENS.EQ.1)EMPI=SQRT(ENP(I)) - C(I)=C(I)*EMPI -6 CONTINUE -C -C SINGLES -C - IQ=IRC(2)-IRC(1) - IN=IRC(1) - DO 16 I=1,IQ - NS1=JSYM(IN+I) - NSIL=MUL(NS1,LSYM) - INUM=NVIR(NSIL) - IST=INDEX(IN+I)+1 - IF(IDENS.EQ.0)EMPI=D1/SQRT(ENP(IN+I)) - IF(IDENS.EQ.1)EMPI=SQRT(ENP(IN+I)) - CALL VSMUL(C(IST),1,EMPI,C(IST),1,INUM) -16 CONTINUE -C -C DOUBLES -C - IQ=IRC(4)-IRC(2) - IN=IRC(2) - DO 11 I=1,IQ - NS1=JSYM(IN+I) - NSIL=MUL(NS1,LSYM) - INUM=NNS(NSIL) - IST=INDEX(IN+I)+1 - IF(IDENS.EQ.0)EMPI=D1/SQRT(ENP(IN+I)) - IF(IDENS.EQ.1)EMPI=SQRT(ENP(IN+I)) - CALL VSMUL(C(IST),1,EMPI,C(IST),1,INUM) -11 CONTINUE - IF(IPRINT.GE.15)WRITE(6,13)(C(I),I=1,NCONF) -13 FORMAT(6X,'C(NP)',5F10.6) - IF(IDENS.EQ.1)RETURN -C - CALL SETZ(EPP,IRC(4)) - CALL SETZ(S,JSC(4)) - IF(ICPF.NE.1.AND.ISDCI.NE.1.AND.INCPF.NE.1)CALL SETZ(W,JSC(4)) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/npset.F90 openmolcas-22.10/src/cpf/npset.F90 --- openmolcas-22.02/src/cpf/npset.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/npset.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,141 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine NPSET(JSY,INDX,C,TPQ,ENP,T,S,W,EPP,ICASE) + +use cpf_global, only: IADDP, ICPF, IDENS, INCPF, IPRINT, IRC, ISDCI, ITPUL, JSC, LSYM, Lu_CI, NCONF, NNS, NVIR +use Symmetry_Info, only: Mul +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: JSY(*), INDX(*), ICASE(*) +real(kind=wp), intent(inout) :: C(*), ENP(*) +real(kind=wp), intent(_OUT_) :: TPQ(*), T(*), S(*), W(*), EPP(*) +integer(kind=iwp) :: I, IAD, IIN, IND, INUM, IP, IQ, IST, NS1, NSIL +real(kind=wp) :: EMPI +integer(kind=iwp), external :: JSUNP +real(kind=r8), external :: DDOT_ + +if (IDENS /= 1) then + + if (ITPUL == 1) then + IAD = 0 + IADDP(1) = 0 + call dDAFILE(Lu_CI,1,C,NCONF,IAD) + IADDP(2) = IAD + end if + + ! VALENCE + + IQ = IRC(1) + T(1:IQ) = C(1:IQ)**2 + + ! SINGLES + + IQ = IRC(2)-IRC(1) + IND = IRC(1) + IIN = IRC(1) + do I=1,IQ + IND = IND+1 + NS1 = JSUNP(JSY,IIN+I) + NSIL = MUL(NS1,LSYM) + INUM = NVIR(NSIL) + IST = INDX(IIN+I)+1 + T(IND) = DDOT_(INUM,C(IST),1,C(IST),1) + end do + + ! DOUBLES + + IQ = IRC(4)-IRC(2) + IIN = IRC(2) + do I=1,IQ + IND = IND+1 + NS1 = JSUNP(JSY,IIN+I) + NSIL = MUL(NS1,LSYM) + INUM = NNS(NSIL) + IST = INDX(IIN+I)+1 + T(IND) = DDOT_(INUM,C(IST),1,C(IST),1) + end do + IP = IRC(4) + do I=1,IP + call TPQSET(ICASE,TPQ,I) + ENP(I) = DDOT_(IP,TPQ,1,T,1)+One + end do + IP = IRC(4) + if (IPRINT > 5) write(u6,12) (ENP(I),I=1,IP) + +end if + +! VALENCE + +IQ = IRC(1) +do I=1,IQ + if (IDENS == 0) then + EMPI = One/sqrt(ENP(I)) + else + EMPI = sqrt(ENP(I)) + end if + C(I) = C(I)*EMPI +end do + +! SINGLES + +IQ = IRC(2)-IRC(1) +IIN = IRC(1) +do I=1,IQ + NS1 = JSUNP(JSY,IIN+I) + NSIL = MUL(NS1,LSYM) + INUM = NVIR(NSIL) + IST = INDX(IIN+I)+1 + if (IDENS == 0) then + EMPI = One/sqrt(ENP(IIN+I)) + else + EMPI = sqrt(ENP(IIN+I)) + end if + C(IST:IST+INUM-1) = EMPI*C(IST:IST+INUM-1) +end do + +! DOUBLES + +IQ = IRC(4)-IRC(2) +IIN = IRC(2) +do I=1,IQ + NS1 = JSUNP(JSY,IIN+I) + NSIL = MUL(NS1,LSYM) + INUM = NNS(NSIL) + IST = INDX(IIN+I)+1 + if (IDENS == 0) then + EMPI = One/sqrt(ENP(IIN+I)) + else + EMPI = sqrt(ENP(IIN+I)) + end if + C(IST:IST+INUM-1) = EMPI*C(IST:IST+INUM-1) +end do +if (IPRINT >= 15) write(u6,13) (C(I),I=1,NCONF) + +if (IDENS /= 1) then + EPP(1:IRC(4)) = Zero + S(1:JSC(4)) = Zero + if ((ICPF /= 1) .and. (ISDCI /= 1) .and. (INCPF /= 1)) W(1:JSC(4)) = Zero +end if + +return + +12 format(6X,'ENP ',5F14.8) +13 format(6X,'C(NP)',5F10.6) + +end subroutine NPSET diff -Nru openmolcas-22.02/src/cpf/onect.f openmolcas-22.10/src/cpf/onect.f --- openmolcas-22.02/src/cpf/onect.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/onect.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,71 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE ONECT(H) - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "cpfmcpf.fh" - DIMENSION H(*) - CALL ONECT_INTERNAL(H) -* -* This is to allow type punning without an explicit interface - CONTAINS - SUBROUTINE ONECT_INTERNAL(H) - USE ISO_C_BINDING - REAL*8, TARGET :: H(*) - INTEGER, POINTER :: iH1(:),iH2(:),iH3(:),iH63(:) - ILIM=4 - IF(IFIRST.NE.0)ILIM=2 - IF(ICPF.EQ.0.AND.ISDCI.EQ.0.AND.INCPF.EQ.0)GO TO 15 -C CPF AND SDCI - IF(IDENS.EQ.1)GO TO 10 -C (AI/JK) INTEGRALS - CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL C_F_POINTER(C_LOC(H(LW(3))),iH3,[1]) - CALL C_F_POINTER(C_LOC(H(LW(63))),iH63,[1]) - CALL AI_CPF(iH2,iH3,H(LW(26)),H(LW(27)),H(LW(62)), - *H(LW(63)),iH63,H(LW(64)),H(LW(65)),H(LW(66)),H(LW(67)), - *H(LW(31)),H(LW(32)),1) - NULLIFY(iH2,iH3,iH63) -10 CALL C_F_POINTER(C_LOC(H(LW(1))),iH1,[1]) - CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL C_F_POINTER(C_LOC(H(LW(3))),iH3,[1]) - CALL FIJ(iH1,iH2,iH3,H(LW(26)),H(LW(27)), - *H(LW(62)),H(LW(64)),H(LW(65)),H(LW(66)),H(LW(67)), - *H(LW(31)),H(LW(32))) - NULLIFY(iH1,iH2,iH3) - GO TO 20 -C MCPF -15 IF(IDENS.EQ.1)GO TO 5 -C (AI/JK) INTEGRALS - CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL C_F_POINTER(C_LOC(H(LW(3))),iH3,[1]) - CALL C_F_POINTER(C_LOC(H(LW(63))),iH63,[1]) - CALL MAI(iH2,iH3,H(LW(26)),H(LW(27)),H(LW(62)), - *H(LW(63)),iH63,H(LW(64)),H(LW(65)),H(LW(66)),H(LW(67)), - *H(LW(28)),H(LW(29)),H(LW(31)),H(LW(32)),IRC(ILIM),1) - NULLIFY(iH2,iH3,iH63) -5 CALL C_F_POINTER(C_LOC(H(LW(1))),iH1,[1]) - CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL C_F_POINTER(C_LOC(H(LW(3))),iH3,[1]) - CALL MFIJ(iH1,iH2,iH3,H(LW(26)),H(LW(27)), - *H(LW(62)),H(LW(64)),H(LW(65)),H(LW(66)),H(LW(67)),H(LW(28)), - *H(LW(29)),H(LW(31)),H(LW(32)),IRC(ILIM)) - NULLIFY(iH1,iH2,iH3) -20 Continue - RETURN - END SUBROUTINE ONECT_INTERNAL -* - END diff -Nru openmolcas-22.02/src/cpf/onect.F90 openmolcas-22.10/src/cpf/onect.F90 --- openmolcas-22.02/src/cpf/onect.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/onect.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,45 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine ONECT(C,S,W,THET,ENP,EPP,FC,BUFIN,A,B,FK,DBK) + +use cpf_global, only: ICASE, ICPF, IDENS, ILIM, INCPF, INDX, IRC, ISDCI, JSY +use Definitions, only: wp + +#include "intent.fh" + +implicit none +real(kind=wp), intent(inout) :: C(*), S(*), W(*), EPP(*), FC(*), FK(*) +real(kind=wp), intent(in) :: THET(*), ENP(*) +real(kind=wp), intent(_OUT_) :: BUFIN(*), A(*), B(*), DBK(*) + +if ((ICPF /= 0) .or. (ISDCI /= 0) .or. (INCPF /= 0)) then + ! CPF AND SDCI + if (IDENS /= 1) then + ! (AI/JK) INTEGRALS + call AI_CPF(JSY,INDX,C,S,FC,BUFIN,A,B,FK,DBK,ENP,EPP,1) + end if + call FIJ_CPF(ICASE,JSY,INDX,C,S,FC,A,B,FK,DBK,ENP,EPP) +else + ! MCPF + if (IDENS /= 1) then + ! (AI/JK) INTEGRALS + call MAI(JSY,INDX,C,S,FC,BUFIN,A,B,FK,DBK,W,THET,ENP,EPP,IRC(ILIM),1) + end if + call MFIJ(ICASE,JSY,INDX,C,S,FC,A,B,FK,DBK,W,THET,ENP,EPP,IRC(ILIM)) +end if + +return + +end subroutine ONECT diff -Nru openmolcas-22.02/src/cpf/order.f openmolcas-22.10/src/cpf/order.f --- openmolcas-22.02/src/cpf/order.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/order.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE ORDER_CPF(C,D,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION C(*),D(*) - IF(N.EQ.1)RETURN - N1=N-1 - DO 10 I=1,N1 - I1=I+1 - DO 20 J=I1,N - IF(D(I).LE.D(J))GO TO 20 - DT=D(I) - D(I)=D(J) - D(J)=DT - IN=(I-1)*N - IOUT=(J-1)*N - DO 30 K=1,N - CT=C(IN+K) - C(IN+K)=C(IOUT+K) - C(IOUT+K)=CT -30 CONTINUE -20 CONTINUE -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/prwf_cpf.F90 openmolcas-22.10/src/cpf/prwf_cpf.F90 --- openmolcas-22.02/src/cpf/prwf_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/prwf_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,162 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine PRWF_CPF(ICASE,JSY,INDX,C) + +use cpf_global, only: CTRSH, ILIM, IRC, IREF0, ISDCI, JSC, LN, LSYM, NCONF, NSM, NSYS, NVIRT, SQ2 +use Symmetry_Info, only: Mul +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: ICASE(*), INDX(*), JSY(*) +real(kind=wp), intent(inout) :: C(*) +integer(kind=iwp) :: I, II, II1, IIN, IJ, ILSYM(57), IOC(57), IORB(57), ISP(57), IX1, J, J1, J2, JCONF, JJ, JMIN, JOJ, JVIR, NA, & + NB, NSI, NSJ +real(kind=wp) :: CI, CNRM, THRC +integer(kind=iwp), external :: ICUNP, JSUNP +real(kind=wp), external :: DNRM2_ + +NA = 0 ! dummy initialized +NB = 0 ! dummy initialized +NCONF = JSC(ILIM) +if (ISDCI == 1) then + CNRM = DNRM2_(NCONF,C,1) + C(1:NCONF) = C(1:NCONF)/CNRM +end if +JCONF = JSC(1) +THRC = CTRSH +write(u6,5) THRC +if (ISDCI == 0) write(u6,6) + +do J=1,LN + IORB(J+2) = J + ILSYM(J+2) = NSM(J) +end do + +do I=1,NCONF + JJ = I + IJ = I + if (I == IREF0) then + write(u6,105) I,C(I),'REFERENCE' + else + CI = C(I) + if (abs(CI) < THRC) cycle + if (I <= JCONF) then + write(u6,105) I,CI,'VALANCE' + else + if (I <= JSC(2)) then + JMIN = IRC(1)+1 + write(u6,105) I,CI,'DOUBLET' + else if (I <= JSC(3)) then + JMIN = IRC(2)+1 + else + JMIN = IRC(3)+1 + end if + IX1 = IRC(ILIM) + do J=JMIN,IX1 + JJ = J-1 + if (INDX(J) >= IJ) exit + end do + end if + end if + NSJ = MUL(JSUNP(JSY,JJ),LSYM) + JVIR = I-INDX(JJ) + if (I > JCONF) JVIR = IJ-INDX(JJ) + II1 = (JJ-1)*LN + do II=1,LN + II1 = II1+1 + ISP(II+2) = ICUNP(ICASE,II1) + JOJ = ISP(II+2) + if (JOJ > 1) JOJ = JOJ-1 + IOC(II+2) = JOJ + end do + if (JJ <= IRC(1)) then + IORB(1) = 0 + IOC(1) = 0 + ISP(1) = 0 + ILSYM(1) = 0 + IORB(2) = 0 + IOC(2) = 0 + ISP(2) = 0 + ILSYM(2) = 0 + else if (JJ <= IRC(2)) then + IORB(2) = JVIR+NSYS(NSJ)+LN + IOC(2) = 1 + ISP(2) = 1 + ILSYM(2) = NSJ + IORB(1) = 0 + IOC(1) = 0 + ISP(1) = 0 + ILSYM(1) = 0 + else + IIN = 0 + outer: do II=1,NVIRT + NA = II + NSI = MUL(NSJ,NSM(LN+II)) + J1 = NSYS(NSI)+1 + J2 = NSYS(NSI+1) + if (J2 > II) J2 = II + do J=J1,J2 + NB = J + IIN = IIN+1 + if (IIN == JVIR) exit outer + end do + end do outer + IORB(1) = LN+NB + IOC(1) = 1 + ISP(1) = 1 + ILSYM(1) = NSM(IORB(1)) + if (NA == NB) then + IORB(2) = IORB(1) + IOC(2) = 2 + ISP(2) = 3 + ILSYM(2) = NSM(IORB(2)) + IORB(1) = 0 + IOC(1) = 0 + ISP(1) = 0 + ILSYM(1) = 0 + CI = CI/SQ2 + if (abs(CI) < THRC) cycle + else + IORB(2) = LN+NA + IOC(2) = 1 + ISP(2) = 2 + ILSYM(2) = NSM(IORB(2)) + end if + if (JJ <= IRC(3)) write(u6,105) I,CI,'TRIPLET' + if (JJ > IRC(3)) write(u6,105) I,CI,'SINGLET' + end if + write(u6,*) + if (LN+2 <= 36) then + write(u6,120) 'ORBITALS ',(IORB(J),J=1,LN+2) + write(u6,120) 'OCCUPATION ',(IOC(J),J=1,LN+2) + write(u6,120) 'SPIN-COUPLING',(ISP(J),J=1,LN+2) + write(u6,120) 'SYMMETRY ',(ILSYM(J),J=1,LN+2) + else + write(u6,121) 'ORBITALS ',(IORB(J),J=1,LN+2) + write(u6,121) 'OCCUPATION ',(IOC(J),J=1,LN+2) + write(u6,121) 'SPIN-COUPLING',(ISP(J),J=1,LN+2) + write(u6,121) 'SYMMETRY ',(ILSYM(J),J=1,LN+2) + end if +end do + +return + +5 format(//6X,'PRINTOUT OF CI-COEFFICIENTS LARGER THAN',F10.2,/) +6 format(/6X,'WAVE FUNCTION NOT NORMALIZED',/) +105 format(/6X,'CONFIGURATION',I7,3X,'COEFFICIENT',F10.6,3X,A) +120 format(6X,A,36I3) +121 format(6X,A,55I2) + +end subroutine PRWF_CPF diff -Nru openmolcas-22.02/src/cpf/prwf.f openmolcas-22.10/src/cpf/prwf.f --- openmolcas-22.02/src/cpf/prwf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/prwf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,178 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE PRWF_CPF(ICASE,JSY,INDEX,C) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION C(*),INDEX(*),JSY(*) - DIMENSION ICASE(*) - -#include "SysDef.fh" - -#include "cpfmcpf.fh" - DIMENSION IOC(57),IORB(57),ISP(57),ILSYM(57) - EXTERNAL DNRM2_ -CPAM97 EXTERNAL UNPACK -CPAM97 INTEGER UNPACK -CPAM97 JO(L)=UNPACK(QOCC((L+29)/30), 2*L-(2*L-1)/60*60, 2) - JO(L)=ICUNP(ICASE,L) -CPAM96 JSYM(L)=UNPACK(JSY((L+9)/10),3*MOD(L-1,10)+1,3)+1 - JSYM(L)=JSUNP_CPF(JSY,L) - NA = 0 ! dummy initialized - NB = 0 ! dummy initialized - ILIM=4 - IF(IFIRST.NE.0)ILIM=2 - NCONF=JSC(ILIM) - IF(ISDCI.EQ.1) CALL DSCAL_(NCONF,1.0D0/DNRM2_(NCONF,C,1),C,1) - JCONF=JSC(1) - THRC=CTRSH - WRITE(6,5)THRC - CALL XFLUSH(6) - IF(ISDCI.EQ.0)WRITE(6,6) -* - DO 4 J=1,LN - IORB(J+2)=J - ILSYM(J+2)=NSM(J) -4 CONTINUE -* - DO 10 I=1,NCONF - JJ=I - IJ=I - IF (I.EQ.IREF0) THEN - WRITE(6,105)I,C(I),'REFERENCE' - CALL XFLUSH(6) - GO TO 26 - END IF - CI=C(I) - IF (ABS(CI).LT.THRC)GO TO 10 - IF (I.LE.JCONF) THEN - WRITE(6,105)I,CI,'VALANCE' - CALL XFLUSH(6) - GO TO 26 - END IF - IF (I.LE.JSC(2)) THEN - JMIN=IRC(1)+1 - WRITE(6,105)I,CI,'DOUBLET' - CALL XFLUSH(6) - ELSE IF (I.LE.JSC(3)) THEN - JMIN=IRC(2)+1 - ELSE - JMIN=IRC(3)+1 - END IF - IX1=IRC(ILIM) - DO 20 J=JMIN,IX1 - JJ=J-1 - IF (INDEX(J).GE.IJ)GO TO 25 -20 CONTINUE -25 CONTINUE -26 CONTINUE - NSJ=MUL(JSYM(JJ),LSYM) - JVIR=I-INDEX(JJ) - IF (I.GT.JCONF)JVIR=IJ-INDEX(JJ) - II1=(JJ-1)*LN - DO 31 II=1,LN - II1=II1+1 - ISP(II+2)=JO(II1) - JOJ=ISP(II+2) - IF (JOJ.GT.1)JOJ=JOJ-1 - IOC(II+2)=JOJ -31 CONTINUE - IF (JJ.LE.IRC(1)) THEN - IORB(1)=0 - IOC(1)=0 - ISP(1)=0 - ILSYM(1)=0 - IORB(2)=0 - IOC(2)=0 - ISP(2)=0 - ILSYM(2)=0 - GO TO 100 - END IF - IF (JJ.LE.IRC(2)) THEN - IORB(2)=JVIR+NSYS(NSJ)+LN - IOC(2)=1 - ISP(2)=1 - ILSYM(2)=NSJ - IORB(1)=0 - IOC(1)=0 - ISP(1)=0 - ILSYM(1)=0 - GO TO 100 - END IF - IN=0 - DO 46 II=1,NVIRT - NA=II - NSI=MUL(NSJ,NSM(LN+II)) - J1=NSYS(NSI)+1 - J2=NSYS(NSI+1) - IF (J2.GT.II)J2=II - IF (J2.LT.J1)GO TO 46 - DO 47 J=J1,J2 - NB=J - IN=IN+1 - IF (IN.EQ.JVIR)GO TO 48 -47 CONTINUE -46 CONTINUE -48 CONTINUE - IORB(1)=LN+NB - IOC(1)=1 - ISP(1)=1 - ILSYM(1)=NSM(IORB(1)) - IF (NA.EQ.NB) THEN - IORB(2)=IORB(1) - IOC(2)=2 - ISP(2)=3 - ILSYM(2)=NSM(IORB(2)) - IORB(1)=0 - IOC(1)=0 - ISP(1)=0 - ILSYM(1)=0 - CI=CI/SQ2 - IF (ABS(CI).LT.THRC)GO TO 10 - ELSE - IORB(2)=LN+NA - IOC(2)=1 - ISP(2)=2 - ILSYM(2)=NSM(IORB(2)) - END IF - IF (JJ.LE.IRC(3))WRITE(6,105)I,CI,'TRIPLET' - IF (JJ.GT.IRC(3))WRITE(6,105)I,CI,'SINGLET' -100 CONTINUE - WRITE(6,*) - CALL XFLUSH(6) - IF(LN+2.LE.36)THEN - WRITE(6,120) 'ORBITALS ',(IORB(J), J=1,LN+2) - CALL XFLUSH(6) - WRITE(6,120) 'OCCUPATION ',(IOC(J), J=1,LN+2) - CALL XFLUSH(6) - WRITE(6,120) 'SPIN-COUPLING',(ISP(J), J=1,LN+2) - CALL XFLUSH(6) - WRITE(6,120) 'SYMMETRY ',(ILSYM(J),J=1,LN+2) - CALL XFLUSH(6) - ELSE - WRITE(6,121) 'ORBITALS ',(IORB(J), J=1,LN+2) - CALL XFLUSH(6) - WRITE(6,121) 'OCCUPATION ',(IOC(J), J=1,LN+2) - CALL XFLUSH(6) - WRITE(6,121) 'SPIN-COUPLING',(ISP(J), J=1,LN+2) - CALL XFLUSH(6) - WRITE(6,121) 'SYMMETRY ',(ILSYM(J),J=1,LN+2) - CALL XFLUSH(6) - END IF -10 CONTINUE - RETURN -5 FORMAT(//6X,'PRINTOUT OF CI-COEFFICIENTS LARGER THAN',F10.2,/) -6 FORMAT(/6X,'WAVE FUNCTION NOT NORMALIZED',/) -105 FORMAT(/6X,'CONFIGURATION',I7,3X,'COEFFICIENT',F10.6,3X,A) -120 FORMAT(6X,A,36I3) -121 FORMAT(6X,A,55I2) - END diff -Nru openmolcas-22.02/src/cpf/psq2.f openmolcas-22.10/src/cpf/psq2.f --- openmolcas-22.02/src/cpf/psq2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/psq2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE PSQ2(C,S,MUL,INDEX,JSY,NDIAG,INUM,IRC3,LSYM, - *NVIRT,SQ2) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION C(*),S(*),MUL(8,8),INDEX(*),JSY(*),NDIAG(*) -CPAM97 EXTERNAL UNPACK -CPAM97 INTEGER UNPACK -CRL JSYM(L)=IAND(ISHFT(JSY((L+19)/20),-3*((L+19)/20*20-L)),7)+1 -CPAM96 JSYM(L)=UNPACK(JSY((L+9)/10),3*MOD(L-1,10)+1,3)+1 - JSYM(L)=JSUNP_CPF(JSY,L) - DO 10 I=1,INUM - II1=IRC3+I - NS1=JSYM(II1) - NS1L=MUL(NS1,LSYM) - IF(NS1L.NE.1)GO TO 10 - NA=INDEX(II1) - DO 20 MA=1,NVIRT - C(NA+NDIAG(MA))=SQ2*C(NA+NDIAG(MA)) - S(NA+NDIAG(MA))=S(NA+NDIAG(MA))/SQ2 -20 CONTINUE -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/psq2.F90 openmolcas-22.10/src/cpf/psq2.F90 --- openmolcas-22.02/src/cpf/psq2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/psq2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,41 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine PSQ2(C,S,MUL,INDX,JSY,NDIAG,INUM,IRC3,LSYM,NVIRT,SQ2) + +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(inout) :: C(*), S(*) +integer(kind=iwp), intent(in) :: MUL(8,8), INDX(*), JSY(*), NDIAG(*), INUM, IRC3, LSYM, NVIRT +real(kind=wp), intent(in) :: SQ2 +integer(kind=iwp) :: I, II1, MA, NA, NS1, NS1L +integer(kind=iwp), external :: JSUNP + +do I=1,INUM + II1 = IRC3+I + NS1 = JSUNP(JSY,II1) + NS1L = MUL(NS1,LSYM) + if (NS1L == 1) then + NA = INDX(II1) + do MA=1,NVIRT + C(NA+NDIAG(MA)) = SQ2*C(NA+NDIAG(MA)) + S(NA+NDIAG(MA)) = S(NA+NDIAG(MA))/SQ2 + end do + end if +end do + +return + +end subroutine PSQ2 diff -Nru openmolcas-22.02/src/cpf/readin_cpf.f openmolcas-22.10/src/cpf/readin_cpf.f --- openmolcas-22.02/src/cpf/readin_cpf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/readin_cpf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,538 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - Subroutine ReadIn_CPF(H,iH) - Implicit Real*8 (A-H,O-Z) -C Read input and allocate memory -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" -#include "niocr.fh" - Dimension IOCR(nIOCR) - Dimension H(*), iH(*) -#include "spin_cpf.fh" - Parameter ( nCmd=18 ) - Parameter ( mxTit=10 ) - Character*4 Command,Cmd(nCmd) - Character*72 Line,Title(mxTit) - Character*88 ModLine - Data Cmd/'TITL','MAXP','LEVS','THRP','PRIN', - * 'FROZ','DELE','MAXI','ECON','ETRS', - * 'REST','MCPF','CPF ','SDCI','ACPF', - * 'LOW ','EXTR','END '/ -* -*---- convert a pointer in H to a pointer for iH - ipointer(i)=(i-1)*RtoI+1 -* -*--- Initialize arrays and variables ---------------------------------* - KBUFF1=2*9600 - D0=0.0D0 - D1=1.0D0 - D2=2.0D0 - LWSP=.FALSE. - SQ2=SQRT(D2) - ETHRE=1.0D-06 - CTRSH=5.0D-02 - IPRINT=5 - MAXIT=20 - IREST=0 -CPAM97 IRHP=0 - ICPF=0 - ISDCI=0 - INCPF=0 - ICONV=0 - MAXITP=6 - WLEV=0.3D0 - ETOT=0.0D0 - DO I=1,8 - NPFRO(I)=0 - NFRO(I)=0 - NDEL(I)=0 - NPDEL(I)=0 - NISH(I)=0 - NASH(I)=0 - NVAL(I)=0 - NVIR(I)=0 - NORB(I)=0 - NBAS(I)=0 - END DO - NPFROT=0 - NFROT=0 - NDELT=0 - NPDELT=0 - NISHT=0 - NASHT=0 - NVALT=0 - NVIRT=0 - NORBT=0 - NBAST=0 - DO I=1,MXORB+1 - IROW(I)=I*(I-1)/2 - END DO - DO I=1,99 - LW(I)=0 - END DO - nTit=0 -* -*--- read the header of TRAONE ---------------------------------------* -C Note: NORB(i)=NBAS(i)-NPFRO(i)-NPDEL(i) - NAMSIZ=LENIN8*MXORB - IDISK=0 - CALL WR_MOTRA_Info(Lu_TraOne,2,iDisk, - & ITOC17,64, POTNUC,NSYM, - * NBAS,NORB,NPFRO,NPDEL,8,NAME,NAMSIZ) -* -*--- Read input from standard input ----------------------------------* - Call RdNLst(5,'CPF') -10 Read(5,'(A)',End=991) Line - Command=Line(1:4) - Call UpCase(Command) - If ( Command(1:1).eq.'*' ) Goto 10 - jCmd=0 - Do iCmd=1,nCmd - If ( Command.eq.Cmd(iCmd) ) jCmd=iCmd - End Do -20 Goto ( 100, 200, 300, 400, 500, 600, 700 ,800, 900,1000, - & 1100,1200,1300,1400,1500,1600,1700,1800 ) jCmd - WRITE(6,*)'READIN Error: Command not recognized.' - WRITE(6,*)'The command is:'//''''//Command//'''' - CALL QUIT_OnUserError() -* -*--- process TITL command --------------------------------------------* -100 Continue - Read(5,'(A)',End=991) Line - Command=Line(1:4) - Call UpCase(Command) - If ( Command(1:1).eq.'*' ) Goto 100 - jCmd=0 - Do iCmd=1,nCmd - If ( Command.eq.Cmd(iCmd) ) jCmd=iCmd - End Do - If ( jCmd.ne.0 ) Goto 20 - nTit=nTit+1 - If ( nTit.le.mxTit ) Title(nTit)=Line - Goto 100 -* -*--- process MAXP command --------------------------------------------* -200 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 200 - Read(Line,*,Err=992) MaxItP - Goto 10 -* -*--- process LEVS command --------------------------------------------* -300 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 300 - Read(Line,*,Err=992) WLev - Goto 10 -* -*--- process THRP command --------------------------------------------* -400 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 400 - Read(Line,*,Err=992) CTrsh - Goto 10 -* -*--- process PRIN command --------------------------------------------* -500 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 500 - Read(Line,*,Err=992) iPrint - Goto 10 -* -*--- process FROZ command --------------------------------------------* -600 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 600 - ModLine=Line//' 0 0 0 0 0 0 0 0' - Read(ModLine,*,Err=992) (nFro(i),i=1,8) - Goto 10 -* -*--- process DELE command --------------------------------------------* -700 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 700 - ModLine=Line//' 0 0 0 0 0 0 0 0' - Read(ModLine,*,Err=992) (NDEL(i),i=1,8) - Goto 10 -* -*--- process MAXI command --------------------------------------------* -800 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 800 - Read(Line,*,Err=992) MaxIt - MaxIt=Min(MaxIt,75) - Goto 10 -* -*--- process ECON command --------------------------------------------* -900 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 900 - Read(Line,*,Err=992) EThre - Goto 10 -* -*--- process ETRS command --------------------------------------------* -1000 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 1000 -CPAM97 Read(Line,*,Err=992) ETrsh - Read(Line,*) - WRITE(6,*)' WARNING: The obsolete ETRS command is ignored.' - Goto 10 -* -*--- process REST command --------------------------------------------* -1100 Continue - iRest=1 - Goto 10 -* -*--- process MCPF command --------------------------------------------* -1200 Continue - iCPF=0 - iSDCI=0 - iNCPF=0 - Goto 10 -* -*--- process CPF command --------------------------------------------* -1300 Continue - iCPF=1 - iSDCI=0 - iNCPF=0 - Goto 10 -* -*--- process SDCI command --------------------------------------------* -1400 Continue - iSDCI=1 - iCPF=0 - iNCPF=0 - Goto 10 -* -*--- process ACPF command --------------------------------------------* -1500 Continue - iNCPF=1 - iCPF=0 - iSDCI=0 - Goto 10 -* -*--- process LOW command --------------------------------------------* -1600 Continue - LWSP=.true. - Goto 10 -* -*--- process EXTR command --------------------------------------------* -1700 WRITE(6,*) 'The EXTRACT option is redundant and is ignored!' - Goto 10 -* -*--- The end of the input is reached, print the title ----------------* -1800 Continue - if(ntit.eq.0) then - ntit=1 - title(1)=' ( No title was given )' - end if - WRITE(6,*) - WRITE(6,'(6X,120A1)') ('*',i=1,120) - WRITE(6,'(6X,120A1)') '*',(' ',i=1,118),'*' - WRITE(6,'(6X,57A1,A6,57A1)') - & '*',(' ',i=1,56),'Title:',(' ',i=1,56),'*' - Do i=1,nTit - Call Center_Text(Title(i)) - WRITE(6,'(6X,24A1,A72,24A1)') - & '*',(' ',j=1,23),Title(i),(' ',j=1,23),'*' - End Do - WRITE(6,'(6X,120A1)') '*',(' ',i=1,118),'*' - WRITE(6,'(6X,120A1)') ('*',i=1,120) - WRITE(6,*) -* -*--- print the coordinates of the system -----------------------------* - Call PrCoor -* -*--- print the method used -------------------------------------------* - WRITE(6,*) - If ( iSDCI.eq.1 ) then - WRITE(6,'(6X,A)') 'This is an S D C I calculation' - Else If ( iCPF.eq.1 ) then - WRITE(6,'(6X,A)') 'This is a C P F calculation' - Else If( INCPF.eq.1 ) then - WRITE(6,'(6X,A)') 'This is an A C P F calculation' - Else - WRITE(6,'(6X,A)') 'This is an M C P F calculation' - End If - If ( LWSP ) WRITE(6,'(6X,A)') 'This is a LOW SPIN calculation' - CALL XFLUSH(6) -* -*--- read the header of CIGUGA ---------------------------------------* - IADD10=0 - CALL iDAFILE(Lu_CIGuga,2,IAD10,9,IADD10) - iOpt=2 - nMUL=64 - nJJS=18 - nIRC=4 - Call WR_GUGA(Lu_CIGuga,iOpt,IADD10, - & NFREF,S,N,LN,NSYM,IR1,IRJ,IFIRST,INTNUM, - & LSYM,NREF,LN1,NRLN1,MUL,nMUL,NASH,NISH,8, - & IRC,nIRC,JJS,nJJS,NVAL,IOCR,nIOCR) - If ( LN.ge.MXORB ) THEN - WRITE(6,*)'READIN Error: Too many orbitals.' - WRITE(6,'(1X,A,2I5)')'LN,MXORB:',LN,MXORB - CALL QUIT_OnUserError() - END IF - LW(1)=1 - CALL iDAFILE(Lu_CIGuga,2,iH(iPointer(LW(1))),IR1,IADD10) - LW(2)=LW(1)+(IR1+(RTOI-1))/RTOI - CALL iDAFILE(Lu_CIGuga,2,iH(iPointer(LW(2))),IRJ,IADD10) -* -*--- update orbital specifications -----------------------------------* - IV0=0 - IV1=1 - IV2=2 - IV3=3 - DO 811 I=1,NSYM - NVIR(I)=NORB(I)-NFRO(I)-NISH(I)-NASH(I) - & -NVAL(I)-NDEL(I) - NPFROT=NPFROT+NPFRO(I) - NFROT=NFROT+NFRO(I) - NISHT=NISHT+NISH(I) - NASHT=NASHT+NASH(I) - NVALT=NVALT+NVAL(I) - NVIRT=NVIRT+NVIR(I) - NDELT=NDELT+NDEL(I) - NPDELT=NPDELT+NPDEL(I) - NORBT=NORBT+NORB(I) - NBAST=NBAST+NBAS(I) -811 CONTINUE - IN=0 - IR=0 - IVA=0 - IU=NISHT+NVALT - IT=NVALT - IV=LN - NVIRT=0 - DO 7 I=1,NSYM - NFROI=NFRO(I) - NISHI=NISH(I) - NASHI=NASH(I) - NVALI=NVAL(I) - NDELI=NDEL(I) -CPAM97 NVIRDI=NORB(I)-NFROI-NASHI-NISHI-NVALI -CPAM97 NVIR(I)=NVIRDI-NDEL(I) - NVIRI=NVIR(I) - NVIRT=NVIRT+NVIRI - DO J=1,NFROI - IN=IN+1 - IR=IR-1 - ICH(IN)=IR - END DO - DO J=1,NISHI - IN=IN+1 - IT=IT+1 - ICH(IN)=IT - NSM(IT)=I - END DO - DO J=1,NASHI - IN=IN+1 - IU=IU+1 - ICH(IN)=IU - NSM(IU)=I - END DO - DO J=1,NVALI - IN=IN+1 - IVA=IVA+1 - ICH(IN)=IVA - NSM(IVA)=I - END DO - DO J=1,NVIRI - IN=IN+1 - IV=IV+1 - ICH(IN)=IV - NSM(IV)=I - END DO - DO J=1,NDELI - IN=IN+1 - ICH(IN)=0 - END DO - 7 CONTINUE - NVT=IROW(NVIRT+1) - NVT2=IROW(NVIRT) -* -*--- report input specifications -------------------------------------* - WRITE(6,*) - WRITE(6,'(6X,A)') 'ONE-ELECTRON BASIS:' - WRITE(6,'(6X,A)') '----------------------------' - WRITE(6,*) - WRITE(6,'(6X,A,T47,4X,4X,8I4)') 'Symmetry species', - & (iSym,iSym=1,nSym) - WRITE(6,*) - WRITE(6,'(6X,A,T47,I4,4x,8I4)') 'Orbitals pre-frozen in MOTRA', - & nPFroT,(nPFro(iSym),iSym=1,nSym) - WRITE(6,'(6X,A,T47,I4,4x,8I4)') 'Orbitals used by this program', - & norbT,(nOrb(iSym),iSym=1,nSym) - WRITE(6,'(6X,A,T47,I4,4x,8I4)') 'Pre-deleted in MOTRA', - & nPDelT,(nPDel(iSym),iSym=1,nSym) - WRITE(6,'(6X,A,T47,I4,4x,8I4)') 'Sum: No. of basis functions', - & nBasT,(nBas(iSym),iSym=1,nSym) - CALL XFLUSH(6) - WRITE(6,*) - WRITE(6,'(6X,A)') 'ORBITAL SPECIFICATION:' - WRITE(6,'(6X,A)') '-------------------------------' - WRITE(6,*) - WRITE(6,'(6X,A,T47,I4,4x,8I4)') 'Orbitals frozen here', - & nFroT,(nFro(iSym),iSym=1,nSym) - WRITE(6,'(6X,A,T47,I4,4x,8I4)') 'Inactive orbitals', - & nIShT,(nISh(iSym),iSym=1,nSym) - WRITE(6,'(6X,A,T47,I4,4x,8I4)') 'Active orbitals', - & nAShT,(nASh(iSym),iSym=1,nSym) - WRITE(6,'(6X,A,T47,I4,4x,8I4)') 'Additional valence orbitals', - & nValT,(nVal(iSym),iSym=1,nSym) - WRITE(6,'(6X,A,T47,I4,4x,8I4)') 'Virtual orbitals', - & nVirT,(nVir(iSym),iSym=1,nSym) - WRITE(6,'(6X,A,T47,I4,4x,8I4)') 'Orbitals deleted here', - & nDelT,(nDel(iSym),iSym=1,nSym) - WRITE(6,'(6X,A,T47,I4,4x,8I4)') 'Sum: Total no. of orbitals', - & norbT,(nOrb(iSym),iSym=1,nSym) - WRITE(6,*) - CALL XFLUSH(6) - WRITE(6,*) - WRITE(6,'(6X,A)') 'WAVE FUNCTION SPECIFICATION:' - WRITE(6,'(6X,A)') '----------------------------' - WRITE(6,*) - WRITE(6,'(6X,A,T47,I4)') 'Number of electrons in CI',N - WRITE(6,'(6X,A,T47,I4)') 'Internal orbitals in CI',LN - WRITE(6,'(6X,A,T47,I4)') 'External orbitals in CI',NVIRT - WRITE(6,'(6X,A,T47,I4)') 'Number of irreps',NSYM - WRITE(6,'(6X,A,T47,F4.1)') 'Spin quantum number',S - WRITE(6,'(6X,A,T47,I4)') 'State symmetry',LSYM - CALL XFLUSH(6) - WRITE(6,*) - WRITE(6,'(6X,A)') 'REFERENCE STATE:' - WRITE(6,'(6X,A)') '------------------------------' - WRITE(6,*) - WRITE(6,'(6X,A,T47,I4)') 'Number of reference states',NREF - LN2=MIN(16,LN1) - If ( LN1.eq.0 ) then - WRITE(6,'(6X,A,T47)') 'One closed shell reference state' - Else - WRITE(6,'(6X,A,T47)') 'Occupation of active orbitals in' - & //' the reference state:' - Write(6,'(6X,A,T25,16I4)')'Active orbital nr.',(I,I=1,LN2) - jEnd=0 - Do iRef=1,nRef - jStart=jEnd+1 - jEnd=jEnd+LN1 - Write(6,'(6X,A,I3,T25,16I4)')'Ref nr',IREF, - & (IOCR(j),j=jStart,jEnd) - End Do - End If - WRITE(6,*) - CALL XFLUSH(6) - WRITE(6,'(6X,A)') 'OPTIONS:' - WRITE(6,'(6X,A)') '--------' - WRITE(6,*) - WRITE(6,'(6X,A,T47,I4)') 'Print parameter',iPrint - WRITE(6,'(6X,A,T47)') 'Pulay diagonalization' - If ( INTNUM.ne.0 ) WRITE(6,'(6X,A,T47)') - & 'First order interacting space' -CPAM97 If ( IRHP.ne.0 ) WRITE(6,'(6X,A,T47)') 'Root homing' - IX1=IRC(1) - IX2=IRC(2)-IRC(1) - ISC(1)=IX1 - ISC(2)=ISC(1)+IX2*NVIRT - IY1=ISC(1) - IY2=ISC(2)-ISC(1) - WRITE(6,214) - CALL XFLUSH(6) -214 FORMAT(//,6X,'INTERNAL CONFIGURATIONS') - IF(IFIRST.NE.0)GO TO 205 - IX3=IRC(3)-IRC(2) - IX4=IRC(4)-IRC(3) - ISC(3)=ISC(2)+IX3*NVT2 - ISC(4)=ISC(3)+IX4*NVT - IY3=ISC(3)-ISC(2) - IY4=ISC(4)-ISC(3) - WRITE(6,215)IX1,IX2,IX3,IX4 - CALL XFLUSH(6) -215 FORMAT(/,6X,'NUMBER OF VALENCE STATES',I16, - */,6X,'NUMBER OF DOUBLET COUPLED SINGLES',I7, - */,6X,'NUMBER OF TRIPLET COUPLED DOUBLES',I7, - */,6X,'NUMBER OF SINGLET COUPLED DOUBLES',I7) - WRITE(6,213) - CALL XFLUSH(6) -213 FORMAT(//,6X,'FULL-SPACE CONFIGURATIONS (FORMAL)') - WRITE(6,215)IY1,IY2,IY3,IY4 - CALL XFLUSH(6) - GO TO 206 -205 WRITE(6,216)IX1,IX2 - CALL XFLUSH(6) -216 FORMAT(/,6X,'NUMBER OF VALENCE STATES',I16, - */,6X,'NUMBER OF DOUBLET COUPLED SINGLES',I7) - WRITE(6,213) - CALL XFLUSH(6) - WRITE(6,216)IY1,IY2 - CALL XFLUSH(6) -206 ILIM=4 - IF(IFIRST.NE.0)ILIM=2 -C ERROR CONDITIONS: -C IF(LN.NE.NISHT+NASHT+NVALT) THEN -C WRITE(6,*)' ERROR: Orbital specifications do not match' -C WRITE(6,*)' input to GUGA. The number of internal' -C WRITE(6,*)' orbitals must equal the number of inactive,' -C WRITE(6,*)' active, and additional valence orbitals.' -C CALL QUIT(20) -C END IF -C ALLOCATION FOR INDEX VECTORS -C THESE VECTORS ARE PERMANENTLY IN CORE -C -- INDEX -CPAM97 LW(3)=LW(2)+IRJ - LW(3)=LW(2)+(IRJ+(RTOI-1))/RTOI -C -- ISAB - LW(4)=LW(3)+IRC(ILIM) - NVIR2=NVIRT*NVIRT -C -- JREFX - LW(5)=LW(4)+NVIR2 - IADD10=IAD10(2) - CALL iDAFILE(Lu_CIGuga,2,iH(iPointer(LW(5))),ISC(1),IADD10) -C -- ADDRESSES NOT USED - LW(6)=LW(5)+ISC(1) - LW(7)=LW(6) - LW(8)=LW(7) - LW(9)=LW(8) - LW(10)=LW(9) -C -- LIMIT FOR PERMANENT VECTORS - LPERMA=LW(10) - CALL dINDMAT(H) - CALL ALLOC_CPF(ISMAX,LPERMA) - RETURN -* -991 Continue - WRITE(6,*)'READIN Error: Premature end of file while reading.' - Call Quit_OnUserError() -992 Continue - WRITE(6,*)'READIN Error: I/O error during internal read.' - WRITE(6,*)'The line that could not be read is:' - WRITE(6,*) Line - Call Quit_OnUserError() -* -* This is to allow type punning without an explicit interface - CONTAINS - SUBROUTINE dINDMAT(H) - USE ISO_C_BINDING - REAL*8, TARGET :: H(*) - INTEGER, POINTER :: iH2(:),iH3(:),iH4(:),iH5(:) - CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL C_F_POINTER(C_LOC(H(LW(3))),iH3,[1]) - CALL C_F_POINTER(C_LOC(H(LW(4))),iH4,[1]) - CALL C_F_POINTER(C_LOC(H(LW(5))),iH5,[1]) - CALL INDMAT_CPF(iH2,iH3,iH4,ISMAX,iH5) - NULLIFY(iH2,iH3,iH4,iH5) - END SUBROUTINE dINDMAT -* - END diff -Nru openmolcas-22.02/src/cpf/readin_cpf.F90 openmolcas-22.10/src/cpf/readin_cpf.F90 --- openmolcas-22.02/src/cpf/readin_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/readin_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,502 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine ReadIn_CPF() +! Read input and allocate memory + +use cpf_global, only: BNAME, CTRSH, ETHRE, ETOT, ICASE, ICH, ICONV, ICPF, IFIRST, ILIM, INCPF, INDX, IPRINT, IR1, IRC, IREST, & + IROW, ISAB, ISC, ISDCI, ISMAX, ITOC17, IV0, IV1, JJS, JSY, LN, LSYM, Lu_CIGuga, Lu_TraOne, LWSP, MAXIT, & + MAXITP, N, NASH, NBAS, NFRO, NISH, NORB, NORBT, NPFRO, NREF, NSM, NSYM, NVIR, NVIRT, POTNUC, WLEV +use guga_util_global, only: IAD10, nIOCR +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp, u5, u6 + +implicit none +#include "Molcas.fh" +integer(kind=iwp), parameter :: mxTit = 10 +integer(kind=iwp) :: I, IADD10, iCmd, IDISK, IIN, INTNUM, iOpt, IR, iRef, IRJ, istatus, iSym, IT, IU, IV, IVA, IX1, IX2, IX3, IX4, & + IY1, IY2, IY3, IY4, j, jCmd, jEnd, jStart, LN1, LN2, NAMSIZ, NASHI, NASHT, NBAST, NDEL(8), NDELI, NDELT, & + NFREF, NFROI, NFROT, nIRC, NISHI, NISHT, nJJS, NPDEL(8), NPDELT, NPFROT, NRLN1, nTit, NVAL(8), NVALI, NVALT, & + NVIR2, NVIRI, NVT, NVT2 +real(kind=wp) :: S +logical(kind=iwp) :: Skip +character(len=88) :: ModLine +character(len=72) :: Line, Title(mxTit) +character(len=4) :: Command +integer(kind=iwp), allocatable :: IOCR(:), JREFX(:) +character(len=4), parameter :: Cmd(16) = ['TITL','MAXP','LEVS','THRP','PRIN','FROZ','DELE','MAXI','ECON','REST','MCPF','CPF ', & + 'SDCI','ACPF','LOW ','END '] + +!--- Initialize arrays and variables ---------------------------------* +LWSP = .false. +ETHRE = 1.0e-6_wp +CTRSH = 5.0e-2_wp +IPRINT = 5 +MAXIT = 20 +IREST = 0 +ICPF = 0 +ISDCI = 0 +INCPF = 0 +ICONV = 0 +MAXITP = 6 +WLEV = 0.3_wp +ETOT = Zero +NPFRO(:) = 0 +NFRO(:) = 0 +NDEL(:) = 0 +NPDEL(:) = 0 +NISH(:) = 0 +NASH(:) = 0 +NVAL(:) = 0 +NVIR(:) = 0 +NORB(:) = 0 +NBAS(:) = 0 +NPFROT = 0 +NFROT = 0 +NDELT = 0 +NPDELT = 0 +NISHT = 0 +NASHT = 0 +NVALT = 0 +NVIRT = 0 +NORBT = 0 +NBAST = 0 +do I=1,size(IROW) + IROW(I) = I*(I-1)/2 +end do +nTit = 0 + +!--- read the header of TRAONE ---------------------------------------* +! Note: NORB(i)=NBAS(i)-NPFRO(i)-NPDEL(i) +NAMSIZ = LenIn8*MXORB +IDISK = 0 +call WR_MOTRA_Info(Lu_TraOne,2,iDisk,ITOC17,64,POTNUC,NSYM,NBAS,NORB,NPFRO,NPDEL,8,BNAME,NAMSIZ) + +!--- Read input from standard input ----------------------------------* +call RdNLst(u5,'CPF') +Skip = .false. +jCmd = 0 +do + if (Skip) then + Skip = .false. + else + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + Command = Line(1:4) + call UpCase(Command) + if (Command(1:1) == '*') cycle + jCmd = 0 + do iCmd=1,size(Cmd) + if (Command == Cmd(iCmd)) jCmd = iCmd + end do + end if + select case (jCmd) + + case default + write(u6,*) 'READIN Error: Command not recognized.' + write(u6,*) 'The command is:'//''''//Command//'''' + call QUIT_OnUserError() + + case (1) !TITL + !--- process TITL command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + Command = Line(1:4) + call UpCase(Command) + if (Command(1:1) == '*') cycle + jCmd = 0 + do iCmd=1,size(Cmd) + if (Command == Cmd(iCmd)) jCmd = iCmd + end do + if (jCmd /= 0) exit + nTit = nTit+1 + if (nTit <= mxTit) Title(nTit) = Line + end do + Skip = .true. + + case (2) !MAXP + !--- process MAXP command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if (Line(1:1) /= '*') exit + end do + read(Line,*,iostat=istatus) MaxItP + if (istatus > 0) call Error(2) + + case (3) !LEVS + !--- process LEVS command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if (Line(1:1) /= '*') exit + end do + read(Line,*,iostat=istatus) WLev + if (istatus > 0) call Error(2) + + case (4) !THRP + !--- process THRP command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if (Line(1:1) /= '*') exit + end do + read(Line,*,iostat=istatus) CTrsh + if (istatus > 0) call Error(2) + + case (5) !PRIN + !--- process PRIN command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if (Line(1:1) /= '*') exit + end do + read(Line,*,iostat=istatus) iPrint + if (istatus > 0) call Error(2) + + case (6) !FROZ + !--- process FROZ command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if (Line(1:1) /= '*') exit + end do + ModLine = Line//' 0 0 0 0 0 0 0 0' + read(ModLine,*,iostat=istatus) (nFro(i),i=1,8) + if (istatus > 0) call Error(2) + + case (7) !DELE + !--- process DELE command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if (Line(1:1) /= '*') exit + end do + ModLine = Line//' 0 0 0 0 0 0 0 0' + read(ModLine,*,iostat=istatus) (NDEL(i),i=1,8) + if (istatus > 0) call Error(2) + + case (8) !MAXI + !--- process MAXI command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if (Line(1:1) /= '*') exit + end do + read(Line,*,iostat=istatus) MaxIt + if (istatus > 0) call Error(2) + MaxIt = min(MaxIt,75) + + case (9) !ECON + !--- process ECON command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if (Line(1:1) /= '*') exit + end do + read(Line,*,iostat=istatus) EThre + if (istatus > 0) call Error(2) + + case (10) !REST + !--- process REST command --------------------------------------* + iRest = 1 + + case (11) !MCPF + !--- process MCPF command --------------------------------------* + iCPF = 0 + iSDCI = 0 + iNCPF = 0 + + case (12) !CPF + !--- process CPF command --------------------------------------* + iCPF = 1 + iSDCI = 0 + iNCPF = 0 + + case (13) !SDCI + !--- process SDCI command --------------------------------------* + iSDCI = 1 + iCPF = 0 + iNCPF = 0 + + case (14) !ACPF + !--- process ACPF command --------------------------------------* + iNCPF = 1 + iCPF = 0 + iSDCI = 0 + + case (15) !LOW + !--- process LOW command --------------------------------------* + LWSP = .true. + + case (16) !END + exit + + end select +end do +!--- The end of the input is reached, print the title ----------------* +if (ntit == 0) then + ntit = 1 + title(1) = ' ( No title was given )' +end if +write(u6,*) +write(u6,'(6X,120A1)') ('*',i=1,120) +write(u6,'(6X,120A1)') '*',(' ',i=1,118),'*' +write(u6,'(6X,57A1,A6,57A1)') '*',(' ',i=1,56),'Title:',(' ',i=1,56),'*' +do i=1,nTit + call Center_Text(Title(i)) + write(u6,'(6X,24A1,A72,24A1)') '*',(' ',j=1,23),Title(i),(' ',j=1,23),'*' +end do +write(u6,'(6X,120A1)') '*',(' ',i=1,118),'*' +write(u6,'(6X,120A1)') ('*',i=1,120) +write(u6,*) + +!--- print the coordinates of the system -----------------------------* +call PrCoor() + +!--- print the method used -------------------------------------------* +write(u6,*) +if (iSDCI == 1) then + write(u6,'(6X,A)') 'This is an S D C I calculation' +else if (iCPF == 1) then + write(u6,'(6X,A)') 'This is a C P F calculation' +else if (INCPF == 1) then + write(u6,'(6X,A)') 'This is an A C P F calculation' +else + write(u6,'(6X,A)') 'This is an M C P F calculation' +end if +if (LWSP) write(u6,'(6X,A)') 'This is a LOW SPIN calculation' + +!--- read the header of CIGUGA ---------------------------------------* +IADD10 = 0 +call iDAFILE(Lu_CIGuga,2,IAD10,9,IADD10) +iOpt = 2 +nJJS = 18 +nIRC = 4 +call mma_allocate(IOCR,nIOCR,label='IOCR') +call WR_GUGA(Lu_CIGuga,iOpt,IADD10,NFREF,S,N,LN,NSYM,IR1,IRJ,IFIRST,INTNUM,LSYM,NREF,LN1,NRLN1,NASH,NISH,8,IRC,nIRC,JJS,nJJS,NVAL, & + IOCR,nIOCR) +if (LN >= MXORB) then + write(u6,*) 'READIN Error: Too many orbitals.' + write(u6,'(1X,A,2I5)') 'LN,MXORB:',LN,MXORB + call QUIT_OnUserError() +end if +call mma_allocate(ICASE,IR1,label='ICASE') +call iDAFILE(Lu_CIGuga,2,ICASE,IR1,IADD10) +call mma_allocate(JSY,IRJ,label='JSY') +call iDAFILE(Lu_CIGuga,2,JSY,IRJ,IADD10) + +!--- update orbital specifications -----------------------------------* +IV0 = 0 +IV1 = 1 +do I=1,NSYM + NVIR(I) = NORB(I)-NFRO(I)-NISH(I)-NASH(I)-NVAL(I)-NDEL(I) + NPFROT = NPFROT+NPFRO(I) + NFROT = NFROT+NFRO(I) + NISHT = NISHT+NISH(I) + NASHT = NASHT+NASH(I) + NVALT = NVALT+NVAL(I) + NVIRT = NVIRT+NVIR(I) + NDELT = NDELT+NDEL(I) + NPDELT = NPDELT+NPDEL(I) + NORBT = NORBT+NORB(I) + NBAST = NBAST+NBAS(I) +end do +IIN = 0 +IR = 0 +IVA = 0 +IU = NISHT+NVALT +IT = NVALT +IV = LN +NVIRT = 0 +do I=1,NSYM + NFROI = NFRO(I) + NISHI = NISH(I) + NASHI = NASH(I) + NVALI = NVAL(I) + NDELI = NDEL(I) + !PAM97 NVIRDI = NORB(I)-NFROI-NASHI-NISHI-NVALI + !PAM97 NVIR(I) = NVIRDI-NDEL(I) + NVIRI = NVIR(I) + NVIRT = NVIRT+NVIRI + do J=1,NFROI + IIN = IIN+1 + IR = IR-1 + ICH(IIN) = IR + end do + do J=1,NISHI + IIN = IIN+1 + IT = IT+1 + ICH(IIN) = IT + NSM(IT) = I + end do + do J=1,NASHI + IIN = IIN+1 + IU = IU+1 + ICH(IIN) = IU + NSM(IU) = I + end do + do J=1,NVALI + IIN = IIN+1 + IVA = IVA+1 + ICH(IIN) = IVA + NSM(IVA) = I + end do + do J=1,NVIRI + IIN = IIN+1 + IV = IV+1 + ICH(IIN) = IV + NSM(IV) = I + end do + do J=1,NDELI + IIN = IIN+1 + ICH(IIN) = 0 + end do +end do +NVT = IROW(NVIRT+1) +NVT2 = IROW(NVIRT) + +!--- report input specifications -------------------------------------* +write(u6,*) +write(u6,'(6X,A)') 'ONE-ELECTRON BASIS:' +write(u6,'(6X,A)') '----------------------------' +write(u6,*) +write(u6,'(6X,A,T47,4X,4X,8I4)') 'Symmetry species',(iSym,iSym=1,nSym) +write(u6,*) +write(u6,'(6X,A,T47,I4,4x,8I4)') 'Orbitals pre-frozen in MOTRA',nPFroT,(nPFro(iSym),iSym=1,nSym) +write(u6,'(6X,A,T47,I4,4x,8I4)') 'Orbitals used by this program',norbT,(nOrb(iSym),iSym=1,nSym) +write(u6,'(6X,A,T47,I4,4x,8I4)') 'Pre-deleted in MOTRA',nPDelT,(nPDel(iSym),iSym=1,nSym) +write(u6,'(6X,A,T47,I4,4x,8I4)') 'Sum: No. of basis functions',nBasT,(nBas(iSym),iSym=1,nSym) +write(u6,*) +write(u6,'(6X,A)') 'ORBITAL SPECIFICATION:' +write(u6,'(6X,A)') '-------------------------------' +write(u6,*) +write(u6,'(6X,A,T47,I4,4x,8I4)') 'Orbitals frozen here',nFroT,(nFro(iSym),iSym=1,nSym) +write(u6,'(6X,A,T47,I4,4x,8I4)') 'Inactive orbitals',nIShT,(nISh(iSym),iSym=1,nSym) +write(u6,'(6X,A,T47,I4,4x,8I4)') 'Active orbitals',nAShT,(nASh(iSym),iSym=1,nSym) +write(u6,'(6X,A,T47,I4,4x,8I4)') 'Additional valence orbitals',nValT,(nVal(iSym),iSym=1,nSym) +write(u6,'(6X,A,T47,I4,4x,8I4)') 'Virtual orbitals',nVirT,(nVir(iSym),iSym=1,nSym) +write(u6,'(6X,A,T47,I4,4x,8I4)') 'Orbitals deleted here',nDelT,(nDel(iSym),iSym=1,nSym) +write(u6,'(6X,A,T47,I4,4x,8I4)') 'Sum: Total no. of orbitals',norbT,(nOrb(iSym),iSym=1,nSym) +write(u6,*) +write(u6,*) +write(u6,'(6X,A)') 'WAVE FUNCTION SPECIFICATION:' +write(u6,'(6X,A)') '----------------------------' +write(u6,*) +write(u6,'(6X,A,T47,I4)') 'Number of electrons in CI',N +write(u6,'(6X,A,T47,I4)') 'Internal orbitals in CI',LN +write(u6,'(6X,A,T47,I4)') 'External orbitals in CI',NVIRT +write(u6,'(6X,A,T47,I4)') 'Number of irreps',NSYM +write(u6,'(6X,A,T47,F4.1)') 'Spin quantum number',S +write(u6,'(6X,A,T47,I4)') 'State symmetry',LSYM +write(u6,*) +write(u6,'(6X,A)') 'REFERENCE STATE:' +write(u6,'(6X,A)') '------------------------------' +write(u6,*) +write(u6,'(6X,A,T47,I4)') 'Number of reference states',NREF +LN2 = min(16,LN1) +if (LN1 == 0) then + write(u6,'(6X,A,T47)') 'One closed shell reference state' +else + write(u6,'(6X,A,T47)') 'Occupation of active orbitals in the reference state:' + write(u6,'(6X,A,T25,16I4)') 'Active orbital nr.',(I,I=1,LN2) + jEnd = 0 + do iRef=1,nRef + jStart = jEnd+1 + jEnd = jEnd+LN1 + write(u6,'(6X,A,I3,T25,16I4)') 'Ref nr',IREF,(IOCR(j),j=jStart,jEnd) + end do +end if +call mma_deallocate(IOCR) +write(u6,*) +write(u6,'(6X,A)') 'OPTIONS:' +write(u6,'(6X,A)') '--------' +write(u6,*) +write(u6,'(6X,A,T47,I4)') 'Print parameter',iPrint +write(u6,'(6X,A,T47)') 'Pulay diagonalization' +if (INTNUM /= 0) write(u6,'(6X,A,T47)') 'First order interacting space' +IX1 = IRC(1) +IX2 = IRC(2)-IRC(1) +ISC(1) = IX1 +ISC(2) = ISC(1)+IX2*NVIRT +IY1 = ISC(1) +IY2 = ISC(2)-ISC(1) +write(u6,214) +if (IFIRST == 0) then + IX3 = IRC(3)-IRC(2) + IX4 = IRC(4)-IRC(3) + ISC(3) = ISC(2)+IX3*NVT2 + ISC(4) = ISC(3)+IX4*NVT + IY3 = ISC(3)-ISC(2) + IY4 = ISC(4)-ISC(3) + write(u6,215) IX1,IX2,IX3,IX4 + write(u6,213) + write(u6,215) IY1,IY2,IY3,IY4 +else + write(u6,216) IX1,IX2 + write(u6,213) + write(u6,216) IY1,IY2 +end if +ILIM = 4 +if (IFIRST /= 0) ILIM = 2 +! ERROR CONDITIONS: +!if (LN /= NISHT+NASHT+NVALT) then +! write(u6,*) ' ERROR: Orbital specifications do not match' +! write(u6,*) ' input to GUGA. The number of internal' +! write(u6,*) ' orbitals must equal the number of inactive,' +! write(u6,*) ' active, and additional valence orbitals.' +! call QUIT(20) +!end if +! ALLOCATION FOR INDEX VECTORS +! THESE VECTORS ARE PERMANENTLY IN CORE +! -- INDEX +call mma_allocate(INDX,IRC(ILIM),label='INDX') +NVIR2 = NVIRT*NVIRT +call mma_allocate(ISAB,NVIR2,label='ISAB') +call mma_allocate(JREFX,ISC(1),label='JREFX') +IADD10 = IAD10(2) +call iDAFILE(Lu_CIGuga,2,JREFX,ISC(1),IADD10) +call INDMAT_CPF(JSY,INDX,ISAB,ISMAX,JREFX) +call mma_deallocate(JREFX) +call ALLOC_CPF() + +return + +214 format(//,6X,'INTERNAL CONFIGURATIONS') +215 format(/,6X,'NUMBER OF VALENCE STATES',I16,/,6X,'NUMBER OF DOUBLET COUPLED SINGLES',I7, & + /,6X,'NUMBER OF TRIPLET COUPLED DOUBLES',I7,/,6X,'NUMBER OF SINGLET COUPLED DOUBLES',I7) +213 format(//,6X,'FULL-SPACE CONFIGURATIONS (FORMAL)') +216 format(/,6X,'NUMBER OF VALENCE STATES',I16,/,6X,'NUMBER OF DOUBLET COUPLED SINGLES',I7) + +contains + +subroutine Error(code) + + integer(kind=iwp), intent(in) :: code + + select case (code) + case (1) + write(u6,*) 'READIN Error: Premature end of file while reading.' + case (2) + write(u6,*) 'READIN Error: I/O error during internal read.' + write(u6,*) 'The line that could not be read is:' + write(u6,*) Line + end select + call Quit_OnUserError() + +end subroutine Error + +end subroutine ReadIn_CPF diff -Nru openmolcas-22.02/src/cpf/restart_cpfmcpf.F90 openmolcas-22.10/src/cpf/restart_cpfmcpf.F90 --- openmolcas-22.02/src/cpf/restart_cpfmcpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/restart_cpfmcpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,32 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine RESTART_CPFMCPF(C,NCONF) + +use cpf_global, only: Lu_CI +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: NCONF +real(kind=wp), intent(_OUT_) :: C(*) +integer(kind=iwp) :: IAD + +IAD = 0 +call dDAFILE(Lu_CI,2,C,NCONF,IAD) + +return + +end subroutine RESTART_CPFMCPF diff -Nru openmolcas-22.02/src/cpf/restart.f openmolcas-22.10/src/cpf/restart.f --- openmolcas-22.02/src/cpf/restart.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/restart.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE RESTART_CPFMCPF(C,NCONF) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "files_cpf.fh" - DIMENSION C(*) - IAD=0 - CALL dDAFILE(Lu_CI,2,C,NCONF,IAD) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/scatter.F90 openmolcas-22.10/src/cpf/scatter.F90 --- openmolcas-22.02/src/cpf/scatter.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/scatter.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,30 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine SCATTER(N,A,IND,B) + +#include "intent.fh" + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: N, IND(N) +real(kind=wp), intent(_OUT_) :: A(*) +real(kind=wp), intent(in) :: B(N) +integer(kind=iwp) :: I + +do I=1,N + A(IND(I)) = B(I) +end do + +return + +end subroutine SCATTER diff -Nru openmolcas-22.02/src/cpf/sdci_cpf.f openmolcas-22.10/src/cpf/sdci_cpf.f --- openmolcas-22.02/src/cpf/sdci_cpf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/sdci_cpf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,72 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE SDCI_CPF(H,iH,LIC0) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "cpfmcpf.fh" -c DIMENSION H(LIC0), iH(RtoI*LIC0) - DIMENSION H(*), iH(*) - CALL SDCI_CPF_INTERNAL(H) -* -* This is to allow type punning without an explicit interface - CONTAINS - SUBROUTINE SDCI_CPF_INTERNAL(H) - USE ISO_C_BINDING - REAL*8, TARGET :: H(*) - INTEGER, POINTER :: iH1(:),iH2(:),iH3(:) - LIC=LIC0 - IPRINT=5 - IDENS=0 -C INPUT, SORTING AND DIAGONAL ELEMENTS - CALL READIN_CPF(H,iH) - CALL DIAGCT_CPF(H) - ITER=1 - IF(IREST.EQ.1)ITER=ITER+1 - ITPUL=1 - IF(IREST.EQ.0)CALL START_CPF(H(LW(26)),JSC(4),IREF0) - IF(IREST.EQ.1)CALL RESTART_CPFMCPF(H(LW(26)),JSC(4)) - IF(ICPF.EQ.0.AND.INCPF.EQ.0.AND.ISDCI.EQ.0) THEN - CALL C_F_POINTER(C_LOC(H(LW(1))),iH1,[1]) - CALL THETSET(iH1,H(LW(29)),IRC(4)) - NULLIFY(iH1) - END IF -100 CALL C_F_POINTER(C_LOC(H(LW(1))),iH1,[1]) - CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL C_F_POINTER(C_LOC(H(LW(3))),iH3,[1]) - CALL NPSET(iH2,iH3,H(LW(26)),H(LW(30)),H(LW(31)), - *H(LW(72)),H(LW(27)),H(LW(28)),H(LW(32)),iH1) - NULLIFY(iH1,iH2,iH3) - CALL TWOCT(H) - CALL ONECT(H) - CALL CPFCTL(H) - ITER=ITER+1 - ITPUL=ITPUL+1 - IF(ITER.GT.MAXIT.OR.ICONV.EQ.1)GO TO 395 - GO TO 100 -C FIRST ORDER DENSITY MATRIX -395 IDENS=1 -* - CALL DENSCT_CPF(H,LIC0) -* - IF(NREF.GT.1) THEN - WRITE(6,*) ' This is a single reference program, but more than' - WRITE(6,*) ' one reference state has been specified in the' - WRITE(6,*) ' GUGA program. Change input to GUGA and run again.' - CALL XFLUSH(6) - RETURN - END IF - RETURN - END SUBROUTINE SDCI_CPF_INTERNAL -* - END diff -Nru openmolcas-22.02/src/cpf/sdci_cpf.F90 openmolcas-22.10/src/cpf/sdci_cpf.F90 --- openmolcas-22.02/src/cpf/sdci_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/sdci_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,133 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine SDCI_CPF(MEMORY) + +use cpf_global, only: ICASE, ICONV, ICPF, IDENS, ILIM, INCPF, INDX, IPRINT, IR1, IRC, IREF0, IREST, IROW, ISDCI, ISMAX, ITER, & + ITPUL, JMAX, JSC, JSY, KBUFF1, LBUF, LIC, LN, MAXIT, MX1, MX2, NORBT, NREF, NTMAX, NVMAX +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp, u6, RtoI + +implicit none +integer(kind=iwp), intent(in) :: MEMORY +integer(kind=iwp), allocatable :: IBMN(:), ICASE_(:) +real(kind=wp), allocatable :: A(:), ABIJ(:), AC1(:), AC2(:), AIBJ(:), AJBI(:), AP(:), B(:), BIJ(:), BMN(:), BST(:), BUFAC(:), & + BUFIJ(:), BUFIN(:), C(:), CN(:), DBK(:), ENP(:), EPB(:), EPP(:), F(:), FC(:), FIJKL(:), FK(:), & + FSEC(:), S(:), TEMP(:), TEMP2(:), THET(:), TPQ(:), W(:) + +LIC = MEMORY +IPRINT = 5 +IDENS = 0 +! INPUT, SORTING AND DIAGONAL ELEMENTS +call READIN_CPF() +call DIAGCT_CPF() +ITER = 1 +if (IREST == 1) ITER = ITER+1 +ITPUL = 1 +call mma_allocate(C,JSC(ILIM),label='C') +if (IREST == 0) call START_CPF(C,JSC(4),IREF0) +if (IREST == 1) call RESTART_CPFMCPF(C,JSC(4)) +call mma_allocate(THET,IRC(ILIM)**2,label='THET') +if ((ICPF == 0) .and. (INCPF == 0) .and. (ISDCI == 0)) then + call THETSET(ICASE,THET,IRC(4)) + call mma_allocate(W,JSC(ILIM),label='W') +else + call mma_allocate(W,0,label='W') +end if +call mma_allocate(FC,IROW(NORBT+1),label='FC') +call mma_allocate(BUFIN,LBUF+(LBUF+2+(RtoI-1))/RtoI,label='BUFIN') ! LBUF reals + LBUF+2 integers +call mma_allocate(A,MX2,label='A') +call mma_allocate(B,MX2,label='B') +call mma_allocate(FK,max(NVMAX,MX1),label='FK') +call mma_allocate(DBK,NVMAX,label='DBK') +call mma_allocate(TEMP,IRC(ILIM),label='TEMP') +call mma_allocate(S,JSC(ILIM),label='S') +call mma_allocate(TPQ,IRC(ILIM),label='TPQ') +call mma_allocate(ENP,IRC(ILIM),label='ENP') +call mma_allocate(EPP,IRC(ILIM),label='EPP') +call mma_allocate(BST,(MAXIT+1)**2,label='BST') +call mma_allocate(ABIJ,MX1,label='ABIJ') +call mma_allocate(AIBJ,MX1,label='AIBJ') +call mma_allocate(AJBI,MX1,label='AJBI') +call mma_allocate(F,MX1,label='F') +call mma_allocate(FSEC,2*MX1,label='FSEC') ! it was MX1, but that's not enough +call mma_allocate(FIJKL,(IROW(LN+1)*(IROW(LN+1)+1))/2,label='FIJKL') +call mma_allocate(BUFIJ,KBUFF1+2,label='BUFIJ') +call mma_allocate(BMN,JMAX,label='BMN') +call mma_allocate(IBMN,JMAX,label='IBMN') +call mma_allocate(AC1,ISMAX,label='AC1') +call mma_allocate(AC2,ISMAX,label='AC2') +call mma_allocate(BUFAC,KBUFF1,label='BUFAC') +call mma_allocate(EPB,IRC(ILIM),label='EPB') +call mma_allocate(AP,IRC(ILIM),label='AP') +call mma_allocate(BIJ,(MAXIT+1)**2,label='BIJ') +call mma_allocate(CN,MAXIT+1,label='CN') +call mma_allocate(TEMP2,NTMAX,label='TEMP2') +do + call NPSET(JSY,INDX,C,TPQ,ENP,TEMP,S,W,EPP,ICASE) + call TWOCT(C,S,W,THET,ENP,EPP,ABIJ,AIBJ,AJBI,BUFIN,A,B,F,FSEC,FIJKL,BUFIJ,BMN,IBMN,AC1,AC2,BUFAC) + call ONECT(C,S,W,THET,ENP,EPP,FC,BUFIN,A,B,FK,DBK) + call CPFCTL(C,S,W,TPQ,ENP,EPP,BST,EPB,AP,BIJ,CN,TEMP2) + ITER = ITER+1 + ITPUL = ITPUL+1 + if ((ITER > MAXIT) .or. (ICONV == 1)) exit +end do +call mma_deallocate(BST) +call mma_deallocate(ABIJ) +call mma_deallocate(AIBJ) +call mma_deallocate(AJBI) +call mma_deallocate(F) +call mma_deallocate(FSEC) +call mma_deallocate(FIJKL) +call mma_deallocate(BUFIJ) +call mma_deallocate(BMN) +call mma_deallocate(IBMN) +call mma_deallocate(AC1) +call mma_deallocate(AC2) +call mma_deallocate(BUFAC) +call mma_deallocate(EPB) +call mma_deallocate(AP) +call mma_deallocate(BIJ) +call mma_deallocate(CN) +call mma_deallocate(TEMP2) +! FIRST ORDER DENSITY MATRIX +IDENS = 1 + +call mma_allocate(ICASE_,IR1,label='ICASE') +call DENSCT_CPF(C,S,W,THET,TPQ,ENP,EPP,ICASE_,FC,BUFIN,A,B,FK,DBK,TEMP) +call mma_deallocate(C) +call mma_deallocate(S) +call mma_deallocate(W) +call mma_deallocate(THET) +call mma_deallocate(TPQ) +call mma_deallocate(ENP) +call mma_deallocate(EPP) +call mma_deallocate(ICASE_) +call mma_deallocate(FC) +call mma_deallocate(BUFIN) +call mma_deallocate(A) +call mma_deallocate(B) +call mma_deallocate(FK) +call mma_deallocate(DBK) +call mma_deallocate(TEMP) + +if (NREF > 1) then + write(u6,*) ' This is a single reference program, but more than' + write(u6,*) ' one reference state has been specified in the' + write(u6,*) ' GUGA program. Change input to GUGA and run again.' +end if + +return + +end subroutine SDCI_CPF diff -Nru openmolcas-22.02/src/cpf/secord.f openmolcas-22.10/src/cpf/secord.f --- openmolcas-22.02/src/cpf/secord.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/secord.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,37 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ -C - SUBROUTINE SECORD(A,B,C,FAC,NAL,NBL,NSIJ,IFT) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(*),B(*),C(*) - IAB=0 - NAA=0 - DO 10 NA=1,NAL - NBB=0 - NA1=NBL - IF(NSIJ.EQ.1)NA1=NA-1 - IF(NA1.EQ.0)GO TO 15 - DO 20 NB=1,NA1 - IAB=IAB+1 - IF(IFT.EQ.0)C(IAB)=B(NAA+NB)+A(NBB+NA) - IF(IFT.EQ.1)C(IAB)=B(NAA+NB)-A(NBB+NA) - NBB=NBB+NAL -20 CONTINUE -15 IF(NSIJ.NE.1)GO TO 35 - IAB=IAB+1 - C(IAB)=FAC*A(NAA+NA) -35 NAA=NAA+NBL -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/secord.F90 openmolcas-22.10/src/cpf/secord.F90 --- openmolcas-22.02/src/cpf/secord.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/secord.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,48 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine SECORD(A,B,C,FAC,NAL,NBL,NSIJ,IFT) + +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +real(kind=wp), intent(in) :: A(*), B(*), FAC +real(kind=wp), intent(_OUT_) :: C(*) +integer(kind=iwp), intent(in) :: NAL, NBL, NSIJ, IFT +integer(kind=iwp) :: IAB, NA, NA1, NAA, NB, NBB + +IAB = 0 +NAA = 0 +do NA=1,NAL + NBB = 0 + NA1 = NBL + if (NSIJ == 1) NA1 = NA-1 + do NB=1,NA1 + IAB = IAB+1 + if (IFT == 0) C(IAB) = B(NAA+NB)+A(NBB+NA) + if (IFT == 1) C(IAB) = B(NAA+NB)-A(NBB+NA) + NBB = NBB+NAL + end do + if (NSIJ == 1) then + IAB = IAB+1 + C(IAB) = FAC*A(NAA+NA) + end if + NAA = NAA+NBL +end do + +return + +end subroutine SECORD diff -Nru openmolcas-22.02/src/cpf/setz.f openmolcas-22.10/src/cpf/setz.f --- openmolcas-22.02/src/cpf/setz.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/setz.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE SETZ(A,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(N) - DO 10 I=1,N - A(I)=0.0D0 -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/setzz.f openmolcas-22.10/src/cpf/setzz.f --- openmolcas-22.02/src/cpf/setzz.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/setzz.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE SETZZ_CPF(A,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(N,N) - DO 10 I=1,N - A(I,I)=0.0D0 -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/siadd.f openmolcas-22.10/src/cpf/siadd.f --- openmolcas-22.02/src/cpf/siadd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/siadd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,27 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ -C - SUBROUTINE SIADD_CPF(A,B,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(N,N),B(*) - IN=0 - DO 10 I=1,N - DO 20 J=1,I - IN=IN+1 - B(IN)=B(IN)+A(I,J)+A(J,I) -20 CONTINUE - B(IN)=B(IN)-A(I,I) -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/sing.f openmolcas-22.10/src/cpf/sing.f --- openmolcas-22.02/src/cpf/sing.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/sing.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ -C - SUBROUTINE SING(IWHY) - IMPLICIT REAL*8 (A-H,O-Z) -11 FORMAT(54H MATRIX WITH ZERO ROW IN DECOMPOSE. ) -12 FORMAT(54H SINGULAR MATRIX IN DECOMPOSE. ZERO DIVIDE IN SOLVE. ) -13 FORMAT(54H NO CONVERGENCE IN IMPROVE. MATRIX IS NEARLY SINGULAR.) - NOUT=6 -C**** NOUTE=STANDARD OUTPUT UNIT - GOTO (1,2,3),IWHY -1 WRITE(NOUT,11) - CALL XFLUSH(6) - GOTO 10 -2 WRITE(NOUT,12) - CALL XFLUSH(6) - GOTO 10 -3 WRITE(NOUT,13) - CALL XFLUSH(6) -10 RETURN - END diff -Nru openmolcas-22.02/src/cpf/sing.F90 openmolcas-22.10/src/cpf/sing.F90 --- openmolcas-22.02/src/cpf/sing.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/sing.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,37 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine SING(IWHY) + +use Definitions, only: iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: IWHY + +select case (IWHY) + case default !(1) + write(u6,11) + case (2) + write(u6,12) + case (3) + write(u6,13) +end select + +return + +11 format(' MATRIX WITH ZERO ROW IN DECOMPOSE.') +12 format(' SINGULAR MATRIX IN DECOMPOSE.ZERO DIVIDE IN SOLVE.') +13 format(' NO CONVERGENCE IN IMPROVE.MATRIX IS NEARLY SINGULAR.') + +end subroutine SING diff -Nru openmolcas-22.02/src/cpf/solve.f openmolcas-22.10/src/cpf/solve.f --- openmolcas-22.02/src/cpf/solve.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/solve.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,47 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ -C - SUBROUTINE SOLVE(NN,UL,B,X) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION UL(NN,NN),B(*),X(*) -#include "ips.fh" - N=NN - NP1=N+1 -C - IP=IPS(1) - X(1)=B(IP) - DO 2 I=2,N - IP=IPS(I) - IM1=I-1 - SUM=0.0D00 - DO 1 J=1,IM1 - SUM=SUM+UL(IP,J)*X(J) -1 CONTINUE - X(I)=B(IP)-SUM -2 CONTINUE - IP=IPS(N) - X(N)=X(N)/UL(IP,N) - DO 4 IBACK=2,N - I=NP1-IBACK -C**** I GOES (N-1),...,1 - IP=IPS(I) - IP1=I+1 - SUM=0.0D00 - DO 3 J=IP1,N - SUM=SUM+UL(IP,J)*X(J) -3 CONTINUE - X(I)=(X(I)-SUM)/UL(IP,I) -4 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/solve.F90 openmolcas-22.10/src/cpf/solve.F90 --- openmolcas-22.02/src/cpf/solve.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/solve.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,60 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine SOLVE(NN,UL,B,X) + +use cpf_global, only: IPS +use Constants, only: Zero +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: NN +real(kind=wp), intent(in) :: UL(NN,NN), B(*) +real(kind=wp), intent(_OUT_) :: X(*) +integer(kind=iwp) :: I, IBACK, IM1, IP, IP1, J, N, NP1 +real(kind=wp) :: RSUM + +N = NN +NP1 = N+1 + +IP = IPS(1) +X(1) = B(IP) +do I=2,N + IP = IPS(I) + IM1 = I-1 + RSUM = Zero + do J=1,IM1 + RSUM = RSUM+UL(IP,J)*X(J) + end do + X(I) = B(IP)-RSUM +end do +IP = IPS(N) +X(N) = X(N)/UL(IP,N) +do IBACK=2,N + I = NP1-IBACK + ! I GOES (N-1),...,1 + IP = IPS(I) + IP1 = I+1 + RSUM = Zero + do J=IP1,N + RSUM = RSUM+UL(IP,J)*X(J) + end do + X(I) = (X(I)-RSUM)/UL(IP,I) +end do + +return + +end subroutine SOLVE diff -Nru openmolcas-22.02/src/cpf/sorta_cpf.F90 openmolcas-22.10/src/cpf/sorta_cpf.F90 --- openmolcas-22.02/src/cpf/sorta_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/sorta_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,346 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine SORTA_CPF(BUFOUT,INDOUT,ICAD,IBUFL,TIBUF,ISAB,BUFBI,INDBI,BIAC,BICA,NINTGR) +! SORTS INTEGRALS (AB/CI) +! FOR FIXED B,I ALL A,C +! FIRST CHAIN FOR IJKL + +use cpf_global, only: IADABCI, ICH, IFIRST, IPRINT, IROW, KBUF, KBUFF1, LASTAD, LN, Lu_CIGuga, Lu_TiABCI, Lu_TiABIJ, Lu_TraInt, & + MADR, NNS, NORB, NSM, NSYM, NTIBUF, NVIRT +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Constants, only: Zero +use Definitions, only: wp, iwp, u6, RtoI + +#include "intent.fh" + +implicit none +real(kind=wp), intent(_OUT_) :: BUFOUT(*), TIBUF(NTIBUF), BUFBI(*), BIAC(*), BICA(*) +integer(kind=iwp), intent(_OUT_) :: INDOUT(*), ICAD(*), IBUFL(*), INDBI(*), NINTGR +integer(kind=iwp), intent(in) :: ISAB(*) +#include "tratoc.fh" +integer(kind=iwp) :: I, IACS, IAD15, IAD50, IADD10, IADR, IBUFIJ, ICHK, ICP, ICPP, ICQ, ID, IDISK, IDIV, IIJ, IIN, IJ, IJKL, ILEN, & + ILOOP, INND, INS, INSOUT, IOUT, IREC, ITURN, JDISK, KBUF0, KBUF1, KBUF2, KK, KKBUF0, KKBUF1, KKBUF2, KL, & + LENGTH, M1, M2, M3, M4, N1, N2, N3, N4, NA, NAC, NAT, NB, NC, NI, NIB, NJ, NK, NL, NOP, NOQ, NOR, NORB0(9), & + NORBP, NOS, NOV, NOVST, NSAVE, NSIB, NSP, NSPQ, NSPQR, NSQ, NSR, NSS, NSSM, NT, NTM, NU, NUMAX, NUMIN, NV, & + NX, NXM +real(kind=wp) :: FINI +logical(kind=iwp) :: Skip + +call COUNT_CPF(NINTGR,NSYM,NORB,MUL) +if (IPRINT >= 2) then + write(6,*) ' NUMBER OF TWO-ELECTRON INTEGRALS:',NINTGR +end if +IAD50 = 0 +call iDAFILE(Lu_TraInt,2,iTraToc,nTraToc,IAD50) +KKBUF0 = (RTOI*(KBUFF1+2)-2)/(RTOI+1) +KKBUF1 = RTOI*KKBUF0+KKBUF0+1 +KKBUF2 = KKBUF1+1 +NOV = LN*NVIRT+1 +if (IFIRST /= 0) NOV = 1 +IDISK = 0 +KBUF0 = RTOI*KBUF +KBUF1 = KBUF0+KBUF+1 +KBUF2 = KBUF1+1 +IDIV = RTOI +ID = 0 +do IREC=1,NOV + IBUFL(IREC) = 0 + ICAD(IREC) = ID + INDOUT(ID+KBUF2) = -1 + ID = ID+KBUF2 +end do +NORB0(1) = 0 +do I=1,NSYM + NORB0(I+1) = NORB0(I)+NORB(I) +end do + +! TWO-ELECTRON INTEGRALS + +do NSP=1,NSYM + NOP = NORB(NSP) + do NSQ=1,NSP + NSPQ = MUL(NSP,NSQ) + NOQ = NORB(NSQ) + do NSR=1,NSP + NSPQR = MUL(NSPQ,NSR) + NOR = NORB(NSR) + NSSM = NSR + if (NSR == NSP) NSSM = NSQ + do NSS=1,NSSM + if (NSS /= NSPQR) cycle + NOS = NORB(NSS) + NORBP = NOP*NOQ*NOR*NOS + if (NORBP == 0) cycle + call dDAFILE(Lu_TraInt,2,TIBUF,NTIBUF,IAD50) + IOUT = 0 + do NV=1,NOR + NXM = NOS + if (NSR == NSS) NXM = NV + do NX=1,NXM + NTM = 1 + if (NSP == NSR) NTM = NV + do NT=NTM,NOP + NUMIN = 1 + if ((NSP == NSR) .and. (NT == NV)) NUMIN = NX + NUMAX = NOQ + if (NSP == NSQ) NUMAX = NT + loop1: do NU=NUMIN,NUMAX + IOUT = IOUT+1 + if (IOUT > NTIBUF) then + call dDAFILE(Lu_TraInt,2,TIBUF,NTIBUF,IAD50) + IOUT = 1 + end if + M1 = ICH(NORB0(NSP)+NT) + M2 = ICH(NORB0(NSQ)+NU) + M3 = ICH(NORB0(NSR)+NV) + M4 = ICH(NORB0(NSS)+NX) + if ((M1 <= 0) .or. (M2 <= 0) .or. (M3 <= 0) .or. (M4 <= 0)) cycle loop1 + ! ORDER THESE INDICES CANONICALLY + N1 = max(M1,M2) + N2 = min(M1,M2) + N3 = max(M3,M4) + N4 = min(M3,M4) + NI = N1 + NJ = N2 + NK = N3 + NL = N4 + if (NI <= NK) then + if (NI /= NK) then + NI = N3 + NJ = N4 + NK = N1 + NL = N2 + else if (NJ <= NL) then + NL = N2 + NJ = N4 + end if + end if + FINI = TIBUF(IOUT) + if (abs(FINI) < 1.0e-9_wp) cycle loop1 + if (NI > LN) then + if (NK <= LN) cycle loop1 + if (NJ > LN) then + if (NL > LN) cycle loop1 + if (IFIRST /= 0) cycle loop1 + + ! ABCI + + NA = NI-LN + NB = NJ-LN + NC = NK-LN + NI = NL + Skip = .false. + else + Skip = .true. + end if + do + if (Skip) then + Skip = .false. + else + ITURN = 0 + do + NIB = (NI-1)*NVIRT+NB+1 + IBUFL(NIB) = IBUFL(NIB)+1 + ICQ = ICAD(NIB) + ICP = ICQ/IDIV+IBUFL(NIB) + BUFOUT(ICP) = FINI + ICPP = ICQ+KBUF0+IBUFL(NIB) + INDOUT(ICPP) = (NA-1)*NVIRT+NC + if (IBUFL(NIB) >= KBUF) then + INDOUT(ICQ+KBUF1) = KBUF + JDISK = IDISK + call iDAFILE(Lu_TiABIJ,1,INDOUT(ICQ+1),KBUF2,IDISK) + INDOUT(ICQ+KBUF2) = JDISK + IBUFL(NIB) = 0 + end if + if ((ITURN == 1) .or. (NA == NB)) cycle loop1 + ITURN = 1 + NAT = NA + NA = NB + NB = NAT + end do + end if + if ((NJ <= 0) .or. (NL <= LN)) cycle loop1 + + ! CIAB + + if (IFIRST /= 0) cycle loop1 + NA = NK-LN + NB = NL-LN + NC = NI-LN + NI = NJ + end do + end if + + ! IJKL + + IIJ = IROW(NI)+NJ + KL = IROW(NK)+NL + IJKL = IIJ*(IIJ-1)/2+KL + IJ = 1 + IBUFL(IJ) = IBUFL(IJ)+1 + ICQ = ICAD(IJ) + ICP = ICQ/IDIV+IBUFL(IJ) + BUFOUT(ICP) = FINI + ICPP = ICQ+KBUF0+IBUFL(IJ) + INDOUT(ICPP) = IJKL + if (IBUFL(IJ) >= KBUF) then + INDOUT(ICQ+KBUF1) = KBUF + JDISK = IDISK + call iDAFILE(Lu_TiABIJ,1,INDOUT(ICQ+1),KBUF2,IDISK) + INDOUT(ICQ+KBUF2) = JDISK + IBUFL(IJ) = 0 + end if + end do loop1 + end do + end do + end do + end do + end do + end do +end do +! EMPTY LAST BUFFERS +!FUE Start of insertion +if (NOV > MADR) then + write(u6,*) 'SORTA_CPF Error: NOV > MADR (See code).' + call Abend() +end if +!FUE End of insertion +do I=1,NOV + ICQ = ICAD(I) + INDOUT(ICQ+KBUF1) = IBUFL(I) + JDISK = IDISK + call iDAFILE(Lu_TiABIJ,1,INDOUT(ICQ+1),KBUF2,IDISK) + LASTAD(I) = JDISK +end do + +! IJKL + +IDISK = 0 +IBUFIJ = 0 +INDBI(KKBUF2) = -1 +IADR = LASTAD(1) +do + call iDAFILE(Lu_TiABIJ,2,INDOUT,KBUF2,IADR) + LENGTH = INDOUT(KBUF1) + IADR = INDOUT(KBUF2) + do I=1,LENGTH + IBUFIJ = IBUFIJ+1 + BUFBI(IBUFIJ) = BUFOUT(I) + INDBI(RTOI*KKBUF0+IBUFIJ) = INDOUT(KBUF0+I) + if (IBUFIJ >= KKBUF0) then + INDBI(KKBUF1) = KKBUF0 + JDISK = IDISK + call iDAFILE(Lu_TiABCI,1,INDBI,KKBUF2,IDISK) + INDBI(KKBUF2) = JDISK + IBUFIJ = 0 + end if + end do + if (IADR == -1) exit +end do +! EMPTY LAST BUFFER +INDBI(KKBUF1) = IBUFIJ +JDISK = IDISK +call iDAFILE(Lu_TiABCI,1,INDBI,KKBUF2,IDISK) +LASTAD(1) = JDISK + +! ABCI + +ICHK = 0 +IAD15 = IDISK +IADABCI = IAD15 +INSOUT = 0 +NOVST = 1 +IADD10 = IAD10(4) +call dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) +call iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) +ILEN = ICOP1(nCOP+1) +IIN = 2 +NSAVE = ICOP1(IIN) +do + NI = NSAVE + IOUT = 0 + Skip = .false. + do + IIN = IIN+1 + if (IIN > ILEN) then + call dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) + call iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN <= 0) then + Skip = .true. + exit + end if + IIN = 1 + end if + if (ICHK /= 0) exit + if (ICOP1(IIN) /= 0) then + IOUT = IOUT+1 + else + ICHK = 1 + end if + end do + if (.not. Skip) then + ICHK = 0 + NSAVE = ICOP1(IIN) + end if + NIB = (NI-1)*NVIRT+NOVST + do NB=1,NVIRT + NSIB = MUL(NSM(LN+NB),NSM(NI)) + INS = NNS(NSIB) + BIAC(1:INS) = Zero + BICA(1:INS) = Zero + NIB = NIB+1 + IADR = LASTAD(NIB) + do + call iDAFILE(Lu_TiABIJ,2,INDOUT,KBUF2,IADR) + LENGTH = INDOUT(KBUF1) + IADR = INDOUT(KBUF2) + do KK=1,LENGTH + INND = INDOUT(KBUF0+KK) + NA = (INND-1)/NVIRT+1 + NC = INND-(NA-1)*NVIRT + NAC = (NA-1)*NVIRT+NC + IACS = ISAB(NAC) + BIAC(IACS) = BIAC(IACS)+BUFOUT(KK) + if (NA > NC) BICA(IACS) = BICA(IACS)-BUFOUT(KK) + if (NA < NC) BICA(IACS) = BICA(IACS)+BUFOUT(KK) + end do + if (IADR == -1) exit + end do + ILOOP = 0 + do + do I=1,INS + INSOUT = INSOUT+1 + if (ILOOP == 0) BUFBI(INSOUT) = BIAC(I) + if (ILOOP == 1) BUFBI(INSOUT) = BICA(I) + if (INSOUT >= KBUFF1) then + call dDAFILE(Lu_TiABCI,1,BUFBI,KBUFF1,IAD15) + INSOUT = 0 + end if + end do + ILOOP = ILOOP+1 + if (ILOOP /= 1) exit + end do + end do + if (ILEN < 0) exit +end do +! EMPTY LAST BUFFER +if (INSOUT /= 0) call dDAFILE(Lu_TiABCI,1,BUFBI,KBUFF1,IAD15) + +return + +end subroutine SORTA_CPF diff -Nru openmolcas-22.02/src/cpf/sorta.f openmolcas-22.10/src/cpf/sorta.f --- openmolcas-22.02/src/cpf/sorta.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/sorta.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,316 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE SORTA_CPF(BUFOUT,INDOUT,ICAD,IBUFL,TIBUF,ISAB,BUFBI, - *INDBI,BIAC,BICA,NINTGR) - IMPLICIT REAL*8 (A-H,O-Z) - EXTERNAL COUNT_CPF -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" - DIMENSION BUFOUT(*),INDOUT(*) - DIMENSION ICAD(*),IBUFL(*),TIBUF(NTIBUF),ISAB(*) - DIMENSION BUFBI(*),INDBI(*),BIAC(*),BICA(*) -C SORTS INTEGRALS (AB/CI) -C FOR FIXED B,I ALL A,C -C FIRST CHAIN FOR IJKL - DIMENSION NORB0(9) -* - CALL COUNT_CPF(NINTGR,NSYM,NORB,MUL) - IF (IPRINT.GE.2) THEN - WRITE(6,*)' NUMBER OF TWO-ELECTRON INTEGRALS:',NINTGR - END IF - IAD50=0 - CALL iDAFILE(Lu_TraInt,2,iTraToc,nTraToc,IAD50) - KKBUF0=(RTOI*(KBUFF1+2)-2)/(RTOI+1) - KKBUF1=RTOI*KKBUF0+KKBUF0+1 - KKBUF2=KKBUF1+1 - NOV=LN*NVIRT+1 - IF(IFIRST.NE.0)NOV=1 - IDISK=0 - KBUF0=RTOI*KBUF - KBUF1=KBUF0+KBUF+1 - KBUF2=KBUF1+1 - IDIV=RTOI - ID=0 - DO 5 IREC=1,NOV - IBUFL(IREC)=0 - ICAD(IREC)=ID - INDOUT(ID+KBUF2)=-1 - ID=ID+KBUF2 -5 CONTINUE - NORB0(1)=0 - DO 4 I=1,NSYM - NORB0(I+1)=NORB0(I)+NORB(I) -4 CONTINUE -C -C TWO-ELECTRON INTEGRALS -C - DO 313 NSP=1,NSYM - NOP=NORB(NSP) - DO 312 NSQ=1,NSP - NSPQ=MUL(NSP,NSQ) - NOQ=NORB(NSQ) - DO 311 NSR=1,NSP - NSPQR=MUL(NSPQ,NSR) - NOR=NORB(NSR) - NSSM=NSR - IF(NSR.EQ.NSP)NSSM=NSQ - DO 310 NSS=1,NSSM - IF(NSS.NE.NSPQR)GO TO 310 - NOS=NORB(NSS) - NORBP=NOP*NOQ*NOR*NOS - IF(NORBP.EQ.0)GO TO 310 - CALL dDAFILE(Lu_TraInt,2,TIBUF,NTIBUF,IAD50) - IOUT=0 - DO 309 NV=1,NOR - NXM=NOS - IF(NSR.EQ.NSS)NXM=NV - DO 308 NX=1,NXM - NTM=1 - IF(NSP.EQ.NSR)NTM=NV - DO 307 NT=NTM,NOP - NUMIN=1 - IF(NSP.EQ.NSR.AND.NT.EQ.NV)NUMIN=NX - NUMAX=NOQ - IF(NSP.EQ.NSQ)NUMAX=NT - DO 306 NU=NUMIN,NUMAX - IOUT=IOUT+1 - IF(IOUT.GT.NTIBUF) THEN - CALL dDAFILE(Lu_TraInt,2,TIBUF,NTIBUF,IAD50) - IOUT=1 - END IF - M1=ICH(NORB0(NSP)+NT) - M2=ICH(NORB0(NSQ)+NU) - M3=ICH(NORB0(NSR)+NV) - M4=ICH(NORB0(NSS)+NX) - IF(M1.LE.0.OR.M2.LE.0)GO TO 306 - IF(M3.LE.0.OR.M4.LE.0)GO TO 306 -C ORDER THESE INDICES CANONICALLY - N1=M1 - N2=M2 - IF(M1.GT.M2)GO TO 11 - N1=M2 - N2=M1 -11 N3=M3 - N4=M4 - IF(M3.GT.M4)GO TO 12 - N3=M4 - N4=M3 -12 NI=N1 - NJ=N2 - NK=N3 - NL=N4 - IF(NI.GT.NK)GO TO 502 - IF(NI.EQ.NK)GO TO 14 - NI=N3 - NJ=N4 - NK=N1 - NL=N2 - GO TO 502 -14 IF(NJ.GT.NL)GO TO 502 - NL=N2 - NJ=N4 -502 FINI=TIBUF(IOUT) - IF(ABS(FINI).LT.1.D-09)GO TO 306 - IF(NI.LE.LN)GO TO 109 - IF(NK.LE.LN)GO TO 306 - IF(NJ.LE.LN)GO TO 42 - IF(NL.GT.LN)GO TO 306 - IF(IFIRST.NE.0)GO TO 306 -C -C ABCI -C - NA=NI-LN - NB=NJ-LN - NC=NK-LN - NI=NL -108 ITURN=0 -107 NIB=(NI-1)*NVIRT+NB+1 - IBUFL(NIB)=IBUFL(NIB)+1 - ICQ=ICAD(NIB) - ICP=ICQ/IDIV+IBUFL(NIB) - BUFOUT(ICP)=FINI - ICPP=ICQ+KBUF0+IBUFL(NIB) - INDOUT(ICPP)=(NA-1)*NVIRT+NC - IF(IBUFL(NIB).LT.KBUF)GO TO 106 - INDOUT(ICQ+KBUF1)=KBUF - JDISK=IDISK - CALL iDAFILE(Lu_TiABIJ,1,INDOUT(ICQ+1),KBUF2, - & IDISK) - INDOUT(ICQ+KBUF2)=JDISK - IBUFL(NIB)=0 -106 IF(ITURN.EQ.1.OR.NA.EQ.NB)GO TO 306 - ITURN=1 - NAT=NA - NA=NB - NB=NAT - GO TO 107 -42 IF(NJ.LE.0.OR.NL.LE.LN)GO TO 306 -C -C CIAB -C - IF(IFIRST.NE.0)GO TO 306 - NA=NK-LN - NB=NL-LN - NC=NI-LN - NI=NJ - GO TO 108 -C -C IJKL -C -109 IIJ=IROW(NI)+NJ - KL=IROW(NK)+NL - IJKL=IIJ*(IIJ-1)/2+KL - IJ=1 - IBUFL(IJ)=IBUFL(IJ)+1 - ICQ=ICAD(IJ) - ICP=ICQ/IDIV+IBUFL(IJ) - BUFOUT(ICP)=FINI - ICPP=ICQ+KBUF0+IBUFL(IJ) - INDOUT(ICPP)=IJKL - IF(IBUFL(IJ).LT.KBUF)GO TO 306 - INDOUT(ICQ+KBUF1)=KBUF - JDISK=IDISK - CALL iDAFILE(Lu_TiABIJ,1,INDOUT(ICQ+1),KBUF2, - & IDISK) - INDOUT(ICQ+KBUF2)=JDISK - IBUFL(IJ)=0 -306 CONTINUE -307 CONTINUE -308 CONTINUE -309 CONTINUE -310 CONTINUE -311 CONTINUE -312 CONTINUE -313 CONTINUE -C EMPTY LAST BUFFERS -CFUE Start of insertion - If ( NOV.gt.mAdr ) then - WRITE(6,*)'SORTA_CPF Error: NOV > MADR (See code).' - CALL Abend - End If -CFUE End of insertion - DO 150 I=1,NOV - ICQ=ICAD(I) - INDOUT(ICQ+KBUF1)=IBUFL(I) - JDISK=IDISK - CALL iDAFILE(Lu_TiABIJ,1,INDOUT(ICQ+1),KBUF2,IDISK) - LASTAD(I)=JDISK -150 CONTINUE -C -C IJKL -C - IDISK=0 - IBUFIJ=0 - INDBI(KKBUF2)=-1 - IADR=LASTAD(1) -201 CALL iDAFILE(Lu_TiABIJ,2,INDOUT,KBUF2,IADR) - LENGTH=INDOUT(KBUF1) - IADR=INDOUT(KBUF2) - IF(LENGTH.EQ.0)GO TO 209 - DO 202 I=1,LENGTH - IBUFIJ=IBUFIJ+1 - BUFBI(IBUFIJ)=BUFOUT(I) - INDBI(RTOI*KKBUF0+IBUFIJ)=INDOUT(KBUF0+I) - IF(IBUFIJ.LT.KKBUF0)GO TO 202 - INDBI(KKBUF1)=KKBUF0 - JDISK=IDISK - CALL iDAFILE(Lu_TiABCI,1,INDBI,KKBUF2,IDISK) - INDBI(KKBUF2)=JDISK - IBUFIJ=0 -202 CONTINUE -209 IF(IADR.NE.-1) GO TO 201 -C EMPTY LAST BUFFER - INDBI(KKBUF1)=IBUFIJ - JDISK=IDISK - CALL iDAFILE(Lu_TiABCI,1,INDBI,KKBUF2,IDISK) - LASTAD(1)=JDISK -C -C ABCI -C - ICHK=0 - IAD15=IDISK - IADABCI=IAD15 - INSOUT=0 - NOVST=1 - IADD10=IAD10(4) - CALL dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) - CALL iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IN=2 - NSAVE=ICOP1(IN) -100 NI=NSAVE - IOUT=0 -110 IN=IN+1 - IF(IN.LE.LEN)GO TO 15 - CALL dDAFILE(Lu_CIGuga,2,COP,nCOP,IADD10) - CALL iDAFILE(Lu_CIGuga,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.LE.0)GO TO 6 - IN=1 -15 IF(ICHK.NE.0)GO TO 460 - IF(ICOP1(IN).EQ.0)GO TO 10 - IOUT=IOUT+1 - GO TO 110 -10 ICHK=1 - GO TO 110 -460 ICHK=0 - NSAVE=ICOP1(IN) -6 CONTINUE - NIB=(NI-1)*NVIRT+NOVST - DO 20 NB=1,NVIRT - NSIB=MUL(NSM(LN+NB),NSM(NI)) - INS=NNS(NSIB) - IF(INS.EQ.0)GO TO 18 - DO 21 I=1,INS - BIAC(I)=0.0D0 - BICA(I)=0.0D0 -21 CONTINUE -18 NIB=NIB+1 - IADR=LASTAD(NIB) -203 CALL iDAFILE(Lu_TiABIJ,2,INDOUT,KBUF2,IADR) - LENGTH=INDOUT(KBUF1) - IADR=INDOUT(KBUF2) - IF(LENGTH.EQ.0)GO TO 210 - DO 204 KK=1,LENGTH - INND=INDOUT(KBUF0+KK) - NA=(INND-1)/NVIRT+1 - NC=INND-(NA-1)*NVIRT - NAC=(NA-1)*NVIRT+NC - IACS=ISAB(NAC) - BIAC(IACS)=BIAC(IACS)+BUFOUT(KK) - IF(NA.GT.NC)BICA(IACS)=BICA(IACS)-BUFOUT(KK) - IF(NA.LT.NC)BICA(IACS)=BICA(IACS)+BUFOUT(KK) -204 CONTINUE -210 IF(IADR.NE.-1) GO TO 203 - ILOOP=0 -72 DO 75 I=1,INS - INSOUT=INSOUT+1 - IF(ILOOP.EQ.0)BUFBI(INSOUT)=BIAC(I) - IF(ILOOP.EQ.1)BUFBI(INSOUT)=BICA(I) - IF(INSOUT.LT.KBUFF1)GO TO 75 - CALL dDAFILE(Lu_TiABCI,1,BUFBI,KBUFF1,IAD15) - INSOUT=0 -75 CONTINUE - ILOOP=ILOOP+1 - IF(ILOOP.EQ.1)GO TO 72 -20 CONTINUE - IF(LEN.GE.0)GO TO 100 -C EMPTY LAST BUFFER - IF ( INSOUT.EQ.0 ) THEN - RETURN - END IF - CALL dDAFILE(Lu_TiABCI,1,BUFBI,KBUFF1,IAD15) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/sortb_cpf.F90 openmolcas-22.10/src/cpf/sortb_cpf.F90 --- openmolcas-22.02/src/cpf/sortb_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/sortb_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,251 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine SORTB_CPF(BUFOUT,INDOUT,ICAD,IBUFL,TIBUF,ACBDS,ACBDT,ISAB,BUFACBD) +! SORTS INTEGRALS (AB/CD) FOR FIXED A,C ALL B,D + +use cpf_global, only: ICH, IPASS, IRC, IROW, JBUF, JJS, KBUFF1, LASTAD, LN, LSYM, Lu_TiABCD, Lu_TiABIJ, Lu_TraInt, MADR, NORB, & + NSM, NSYM, NSYS, NTIBUF, NVIRT +use Symmetry_Info, only: Mul +use Constants, only: Zero, Half +use Definitions, only: wp, iwp, u6, RtoI + +#include "intent.fh" + +implicit none +real(kind=wp), intent(_OUT_) :: BUFOUT(*), TIBUF(NTIBUF), ACBDS(*), ACBDT(*), BUFACBD(*) +integer(kind=iwp), intent(_OUT_) :: INDOUT(*), ICAD(*), IBUFL(*) +integer(kind=iwp), intent(in) :: ISAB(*) +#include "tratoc.fh" +integer(kind=iwp) :: I, IAC, IACMAX, IACMIN, IAD16, IAD50, IADR, IBDS, ICP, ICPP, ICQ, ID, IDISK, IDIV, IFIN1, IFIN2, ILOOP, IN1, & + INND, INPS, INPT, INS, INSOUT, IOUT, IREC, IST1, IST2, ISTEP, ISYM, ITAIL, ITURN, JBUF0, JBUF1, JBUF2, JDISK, & + KK, LENGTH, M1, M2, M3, M4, N1, N2, N3, N4, NA, NAC, NB, NBD, NC, ND, NDMAX, NI, NJ, NK, NL, NOP, NOQ, NOR, & + NORB0(9), NORBP, NOS, NOV, NOVM, NOVST, NSAC, NSACL, NSP, NSPQ, NSPQR, NSQ, NSR, NSS, NSSM, NT, NTM, NU, & + NUMAX, NUMIN, NV, NVT, NX, NXM +real(kind=wp) :: FINI + +NVT = IROW(NVIRT+1) +NOV = (NVT-1)/IPASS+1 +NOVST = LN*NVIRT+1 +IAD16 = 0 +JBUF0 = RTOI*JBUF +JBUF1 = JBUF0+JBUF+1 +JBUF2 = JBUF1+1 +IDIV = RTOI +NORB0(1) = 0 +do I=1,NSYM + NORB0(I+1) = NORB0(I)+NORB(I) +end do +INSOUT = 0 +IACMAX = 0 +do ISTEP=1,IPASS + IAD50 = 0 + call iDAFILE(Lu_TraInt,2,iTraToc,nTraToc,IAD50) + IDISK = 0 + IACMIN = IACMAX+1 + IACMAX = IACMAX+NOV + if (IACMAX > NVT) IACMAX = NVT + if (IACMIN > IACMAX) cycle + ID = 0 + do IREC=1,NOV + IBUFL(IREC) = 0 + ICAD(IREC) = ID + INDOUT(ID+JBUF2) = -1 + ID = ID+JBUF2 + end do + + ! TWO-ELECTRON INTEGRALS + + do NSP=1,NSYM + NOP = NORB(NSP) + do NSQ=1,NSP + NSPQ = MUL(NSP,NSQ) + NOQ = NORB(NSQ) + do NSR=1,NSP + NSPQR = MUL(NSPQ,NSR) + NOR = NORB(NSR) + NSSM = NSR + if (NSR == NSP) NSSM = NSQ + do NSS=1,NSSM + if (NSS /= NSPQR) cycle + NOS = NORB(NSS) + NORBP = NOP*NOQ*NOR*NOS + if (NORBP == 0) cycle + call dDAFILE(Lu_TraInt,2,TIBUF,NTIBUF,IAD50) + IOUT = 0 + do NV=1,NOR + NXM = NOS + if (NSR == NSS) NXM = NV + do NX=1,NXM + NTM = 1 + if (NSP == NSR) NTM = NV + do NT=NTM,NOP + NUMIN = 1 + if ((NSP == NSR) .and. (NT == NV)) NUMIN = NX + NUMAX = NOQ + if (NSP == NSQ) NUMAX = NT + do NU=NUMIN,NUMAX + IOUT = IOUT+1 + if (IOUT > NTIBUF) then + call dDAFILE(Lu_TraInt,2,TIBUF,NTIBUF,IAD50) + IOUT = 1 + end if + M1 = ICH(NORB0(NSP)+NT) + M2 = ICH(NORB0(NSQ)+NU) + M3 = ICH(NORB0(NSR)+NV) + M4 = ICH(NORB0(NSS)+NX) + if ((M1 <= LN) .or. (M2 <= LN) .or. (M3 <= LN) .or. (M4 <= LN)) cycle + ! ORDER THESE INDICES CANONICALLY + N1 = max(M1,M2) + N2 = min(M1,M2) + N3 = max(M3,M4) + N4 = min(M3,M4) + NI = N1 + NJ = N2 + NK = N3 + NL = N4 + if (NI <= NK) then + if (NI /= NK) then + NI = N3 + NJ = N4 + NK = N1 + NL = N2 + else if (NJ <= NL) then + NL = N2 + NJ = N4 + end if + end if + FINI = TIBUF(IOUT) + if (abs(FINI) < 1.0e-9_wp) cycle + NA = NI-LN + NB = NJ-LN + NC = NK-LN + ND = NL-LN + ITURN = 0 + if ((NA == NB) .and. (NC == ND)) cycle + do + IAC = IROW(NA)+NC + if ((IAC >= IACMIN) .and. (IAC <= IACMAX)) then + if ((NA == NC) .and. (NB == ND)) FINI = FINI*Half + NAC = IAC-IACMIN+1 + IBUFL(NAC) = IBUFL(NAC)+1 + ICQ = ICAD(NAC) + ICP = ICQ/IDIV+IBUFL(NAC) + BUFOUT(ICP) = FINI + ICPP = ICQ+JBUF0+IBUFL(NAC) + !PAM97 INDOUT(ICPP) = ior(NB,ishft(ND,8)) + INDOUT(ICPP) = NB+ND*2**8 + if (IBUFL(NAC) >= JBUF) then + INDOUT(ICQ+JBUF1) = JBUF + JDISK = IDISK + call iDAFILE(Lu_TiABIJ,1,INDOUT(ICQ+1),JBUF2,IDISK) + INDOUT(ICQ+JBUF2) = JDISK + IBUFL(NAC) = 0 + end if + end if + if (ITURN == 1) exit + if ((NA == NC) .and. (NB == ND)) exit + if ((NA == NB) .or. (NC == ND)) exit + ITURN = 1 + NC = NL-LN + ND = NK-LN + end do + end do + end do + end do + end do + end do + end do + end do + end do + ! EMPTY LAST BUFFERS + NOVM = IACMAX-IACMIN+1 + if ((NOVST+IACMIN-1+NOVM) > MADR) then + write(u6,*) 'SORTB_CPF Error: NOVST+IACMIN-1+NOVM > MADR' + write(u6,*) ' (See code).' + call Abend() + end if + do I=1,NOVM + ICQ = ICAD(I) + INDOUT(ICQ+JBUF1) = IBUFL(I) + JDISK = IDISK + call iDAFILE(Lu_TiABIJ,1,INDOUT(ICQ+1),JBUF2,IDISK) + LASTAD(NOVST+IACMIN-1+I) = JDISK + end do + do ISYM=1,NSYM + IST1 = IRC(3)+JJS(ISYM+9)+1 + IFIN1 = IRC(3)+JJS(ISYM+10) + INPS = IFIN1-IST1+1 + IST2 = IRC(2)+JJS(ISYM)+1 + IFIN2 = IRC(2)+JJS(ISYM+1) + INPT = IFIN2-IST2+1 + ITAIL = INPS+INPT + if (ITAIL == 0) cycle + IN1 = -NVIRT + do NA=1,NVIRT + IN1 = IN1+NVIRT + do NC=1,NA + IAC = IROW(NA)+NC + if (IAC < IACMIN) cycle + if (IAC > IACMAX) cycle + if (NA == 1) cycle + NSAC = MUL(NSM(LN+NA),NSM(LN+NC)) + NSACL = MUL(NSAC,LSYM) + if (NSACL /= ISYM) cycle + NDMAX = NSYS(NSM(LN+NC)+1) + if (NDMAX > NA) NDMAX = NA + INS = ISAB(IN1+NDMAX) + ACBDS(1:INS) = Zero + ACBDT(1:INS) = Zero + IADR = LASTAD(NOVST+IAC) + do + call iDAFILE(Lu_TiABIJ,2,INDOUT,JBUF2,IADR) + LENGTH = INDOUT(JBUF1) + IADR = INDOUT(JBUF2) + do KK=1,LENGTH + INND = INDOUT(JBUF0+KK) + NB = ibits(INND,0,8) + ND = ibits(INND,8,8) + NBD = (NB-1)*NVIRT+ND + IBDS = ISAB(NBD) + ACBDS(IBDS) = ACBDS(IBDS)+BUFOUT(KK) + if (NB > ND) ACBDT(IBDS) = ACBDT(IBDS)+BUFOUT(KK) + if (NB < ND) ACBDT(IBDS) = ACBDT(IBDS)-BUFOUT(KK) + end do + if (IADR == -1) exit + end do + ILOOP = 0 + do + do I=1,INS + INSOUT = INSOUT+1 + if (ILOOP == 0) BUFACBD(INSOUT) = ACBDS(I) + if (ILOOP == 1) BUFACBD(INSOUT) = ACBDT(I) + if (INSOUT >= KBUFF1) then + call dDAFILE(Lu_TiABCD,1,BUFACBD,KBUFF1,IAD16) + INSOUT = 0 + end if + end do + ILOOP = ILOOP+1 + if (ILOOP /= 1) exit + end do + end do + end do + end do +end do +! EMPTY LAST BUFFER +if (INSOUT /= 0) call dDAFILE(Lu_TiABCD,1,BUFACBD,KBUFF1,IAD16) + +return + +end subroutine SORTB_CPF diff -Nru openmolcas-22.02/src/cpf/sortb.f openmolcas-22.10/src/cpf/sortb.f --- openmolcas-22.02/src/cpf/sortb.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/sortb.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,246 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE SORTB_CPF(BUFOUT,INDOUT,ICAD,IBUFL,TIBUF,ACBDS,ACBDT, - *ISAB,BUFACBD) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" - DIMENSION BUFOUT(*),INDOUT(*) - DIMENSION ICAD(*),IBUFL(*),TIBUF(NTIBUF),ACBDS(*),ACBDT(*) - DIMENSION ISAB(*),BUFACBD(*) - DIMENSION NORB0(9) - PARAMETER (IPOW8=2**8) -C SORTS INTEGRALS (AB/CD) FOR FIXED A,C ALL B,D -* - KBUFF1=2*9600 - NVT=IROW(NVIRT+1) - NOV=(NVT-1)/IPASS+1 - NOVST=LN*NVIRT+1 - IAD16=0 - JBUF0=RTOI*JBUF - JBUF1=JBUF0+JBUF+1 - JBUF2=JBUF1+1 - IDIV=RTOI - NORB0(1)=0 - DO 4 I=1,NSYM - NORB0(I+1)=NORB0(I)+NORB(I) -4 CONTINUE - INSOUT=0 - IACMAX=0 - DO 50 ISTEP=1,IPASS - IAD50=0 - CALL iDAFILE(Lu_TraInt,2,iTraToc,nTraToc,IAD50) - IDISK=0 - IACMIN=IACMAX+1 - IACMAX=IACMAX+NOV - IF(IACMAX.GT.NVT)IACMAX=NVT - IF(IACMIN.GT.IACMAX)GO TO 50 - ID=0 - DO 5 IREC=1,NOV - IBUFL(IREC)=0 - ICAD(IREC)=ID - INDOUT(ID+JBUF2)=-1 - ID=ID+JBUF2 -5 CONTINUE -C -C TWO-ELECTRON INTEGRALS -C - DO 313 NSP=1,NSYM - NOP=NORB(NSP) - DO 312 NSQ=1,NSP - NSPQ=MUL(NSP,NSQ) - NOQ=NORB(NSQ) - DO 311 NSR=1,NSP - NSPQR=MUL(NSPQ,NSR) - NOR=NORB(NSR) - NSSM=NSR - IF(NSR.EQ.NSP)NSSM=NSQ - DO 310 NSS=1,NSSM - IF(NSS.NE.NSPQR)GO TO 310 - NOS=NORB(NSS) - NORBP=NOP*NOQ*NOR*NOS - IF(NORBP.EQ.0)GO TO 310 - CALL dDAFILE(Lu_TraInt,2,TIBUF,NTIBUF,IAD50) - IOUT=0 - DO 309 NV=1,NOR - NXM=NOS - IF(NSR.EQ.NSS)NXM=NV - DO 308 NX=1,NXM - NTM=1 - IF(NSP.EQ.NSR)NTM=NV - DO 307 NT=NTM,NOP - NUMIN=1 - IF(NSP.EQ.NSR.AND.NT.EQ.NV)NUMIN=NX - NUMAX=NOQ - IF(NSP.EQ.NSQ)NUMAX=NT - DO 306 NU=NUMIN,NUMAX - IOUT=IOUT+1 - IF(IOUT.GT.NTIBUF) THEN - CALL dDAFILE(Lu_TraInt,2,TIBUF,NTIBUF,IAD50) - IOUT=1 - END IF - M1=ICH(NORB0(NSP)+NT) - M2=ICH(NORB0(NSQ)+NU) - M3=ICH(NORB0(NSR)+NV) - M4=ICH(NORB0(NSS)+NX) - IF(M1.LE.LN.OR.M2.LE.LN)GO TO 306 - IF(M3.LE.LN.OR.M4.LE.LN)GO TO 306 -C ORDER THESE INDICES CANONICALLY - N1=M1 - N2=M2 - IF(M1.GT.M2)GO TO 11 - N1=M2 - N2=M1 -11 N3=M3 - N4=M4 - IF(M3.GT.M4)GO TO 12 - N3=M4 - N4=M3 -12 NI=N1 - NJ=N2 - NK=N3 - NL=N4 - IF(NI.GT.NK)GO TO 502 - IF(NI.EQ.NK)GO TO 14 - NI=N3 - NJ=N4 - NK=N1 - NL=N2 - GO TO 502 -14 IF(NJ.GT.NL)GO TO 502 - NL=N2 - NJ=N4 -502 FINI=TIBUF(IOUT) - IF(ABS(FINI).LT.1.D-09)GO TO 306 - NA=NI-LN - NB=NJ-LN - NC=NK-LN - ND=NL-LN - ITURN=0 - IF(NA.EQ.NB.AND.NC.EQ.ND)GO TO 306 -107 IAC=IROW(NA)+NC - IF(IAC.LT.IACMIN)GO TO 106 - IF(IAC.GT.IACMAX)GO TO 106 - IF(NA.EQ.NC.AND.NB.EQ.ND)FINI=FINI/D2 - NAC=IAC-IACMIN+1 - IBUFL(NAC)=IBUFL(NAC)+1 - ICQ=ICAD(NAC) - ICP=ICQ/IDIV+IBUFL(NAC) - BUFOUT(ICP)=FINI - ICPP=ICQ+JBUF0+IBUFL(NAC) -CPAM97 INDOUT(ICPP)=IOR(NB,ISHFT(ND,8)) - INDOUT(ICPP)=NB+ND*IPOW8 - IF(IBUFL(NAC).LT.JBUF)GO TO 106 - INDOUT(ICQ+JBUF1)=JBUF - JDISK=IDISK - CALL iDAFILE(Lu_TiABIJ,1,INDOUT(ICQ+1),JBUF2,IDISK) - INDOUT(ICQ+JBUF2)=JDISK - IBUFL(NAC)=0 -106 IF(ITURN.EQ.1)GO TO 306 - IF(NA.EQ.NC.AND.NB.EQ.ND)GO TO 306 - IF(NA.EQ.NB.OR.NC.EQ.ND)GO TO 306 - ITURN=1 - NC=NL-LN - ND=NK-LN - GO TO 107 -306 CONTINUE -307 CONTINUE -308 CONTINUE -309 CONTINUE -310 CONTINUE -311 CONTINUE -312 CONTINUE -313 CONTINUE -C EMPTY LAST BUFFERS - NOVM=IACMAX-IACMIN+1 - If ( (NOVST+IACMIN-1+NOVM).gt.mAdr ) then - WRITE(6,*)'SORTB_CPF Error: NOVST+IACMIN-1+NOVM > MADR' - WRITE(6,*)' (See code).' - CALL Abend - End If - DO 150 I=1,NOVM - ICQ=ICAD(I) - INDOUT(ICQ+JBUF1)=IBUFL(I) - JDISK=IDISK - CALL iDAFILE(Lu_TiABIJ,1,INDOUT(ICQ+1),JBUF2,IDISK) - LASTAD(NOVST+IACMIN-1+I)=JDISK -150 CONTINUE - DO 40 ISYM=1,NSYM - IST1=IRC(3)+JJS(ISYM+9)+1 - IFIN1=IRC(3)+JJS(ISYM+10) - INPS=IFIN1-IST1+1 - IST2=IRC(2)+JJS(ISYM)+1 - IFIN2=IRC(2)+JJS(ISYM+1) - INPT=IFIN2-IST2+1 - ITAIL=INPS+INPT - IF(ITAIL.EQ.0)GO TO 40 - IN1=-NVIRT - DO 55 NA=1,NVIRT - IN1=IN1+NVIRT - DO 60 NC=1,NA - IAC=IROW(NA)+NC - IF(IAC.LT.IACMIN)GO TO 60 - IF(IAC.GT.IACMAX)GO TO 60 - IF(NA.EQ.1)GO TO 60 - NSAC=MUL(NSM(LN+NA),NSM(LN+NC)) - NSACL=MUL(NSAC,LSYM) - IF(NSACL.NE.ISYM)GO TO 60 - NDMAX=NSYS(NSM(LN+NC)+1) - IF(NDMAX.GT.NA)NDMAX=NA - INS=ISAB(IN1+NDMAX) - DO 65 I=1,INS - ACBDS(I)=D0 - ACBDT(I)=D0 -65 CONTINUE - IADR=LASTAD(NOVST+IAC) -201 CALL iDAFILE(Lu_TiABIJ,2,INDOUT,JBUF2,IADR) - LENGTH=INDOUT(JBUF1) - IADR=INDOUT(JBUF2) - IF(LENGTH.EQ.0)GO TO 209 - DO 202 KK=1,LENGTH - INND=INDOUT(JBUF0+KK) -* NB=MOD(INND,IPOW8) -* ND=MOD(INND/IPOW8,IPOW8) - NB=IBITS(INND,0,8) - ND=IBITS(INND,8,8) - NBD=(NB-1)*NVIRT+ND - IBDS=ISAB(NBD) - ACBDS(IBDS)=ACBDS(IBDS)+BUFOUT(KK) - IF(NB.GT.ND)ACBDT(IBDS)=ACBDT(IBDS)+BUFOUT(KK) - IF(NB.LT.ND)ACBDT(IBDS)=ACBDT(IBDS)-BUFOUT(KK) -202 CONTINUE -209 IF(IADR.NE.-1) GO TO 201 - ILOOP=0 -72 DO 75 I=1,INS - INSOUT=INSOUT+1 - IF(ILOOP.EQ.0)BUFACBD(INSOUT)=ACBDS(I) - IF(ILOOP.EQ.1)BUFACBD(INSOUT)=ACBDT(I) - IF(INSOUT.LT.KBUFF1)GO TO 75 - CALL dDAFILE(Lu_TiABCD,1,BUFACBD,KBUFF1,IAD16) - INSOUT=0 -75 CONTINUE - ILOOP=ILOOP+1 - IF(ILOOP.EQ.1)GO TO 72 -60 CONTINUE -55 CONTINUE -40 CONTINUE -50 CONTINUE -C EMPTY LAST BUFFER - IF(INSOUT.EQ.0) THEN - RETURN - END IF - CALL dDAFILE(Lu_TiABCD,1,BUFACBD,KBUFF1,IAD16) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/sort_cpf.F90 openmolcas-22.10/src/cpf/sort_cpf.F90 --- openmolcas-22.02/src/cpf/sort_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/sort_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,346 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine SORT_CPF(BUFOUT,INDOUT,ICAD,IBUFL,FC,FIJ,FJI,TIBUF) + +use cpf_global, only: IAD25S, ICH, IPRINT, IROW, ITOC17, LASTAD, LBUF, LN, Lu_25, Lu_TiABIJ, Lu_TraInt, Lu_TraOne, MADR, N, NORB, & + NORBT, NSM, NSYM, NSYS, NTIBUF, NVIR, NVIRT, POTNUC +use Symmetry_Info, only: Mul +use Constants, only: Zero, Two +use Definitions, only: wp, iwp, u6, RtoI + +#include "intent.fh" + +implicit none +real(kind=wp), intent(_OUT_) :: BUFOUT(*), FC(*), FIJ(*), FJI(*), TIBUF(NTIBUF) +integer(kind=iwp), intent(_OUT_) :: INDOUT(*), ICAD(*), IBUFL(*) +#include "tratoc.fh" +integer(kind=iwp) :: I, IAD50, IADD17, IADD25, IBUF, ICP, ICPP, ICQ, ID, IDISK, IDIV, IEXP, II, IIJ, IIN, IJ, IJT, INAV, IND, & + IORBI, IOUT, IPOF(65), IREC, ISYM, IVEC(20), J, JDISK, JK, JNAV, JORBI, KORBI, LBUF0, LBUF1, LBUF2, M1, M2, & + M3, M4, N1, N2, N3, N4, NAV, NBV, NI, NJ, NK, NL, NOB2, NOP, NOQ, NOR, NORB0(9), NORBP, NORBTT, NOS, NOT2, & + NOTT, NOV, NOVST, NSA, NSB, NSIJT, NSP, NSPQ, NSPQR, NSQ, NSR, NSS, NSSM, NT, NTM, NTMP, NU, NUMAX, NUMIN, & + NV, NVT, NX, NXM +real(kind=wp) :: DFINI, EMY, FINI, ONEHAM + +IAD50 = 0 +call iDAFILE(Lu_TraInt,2,iTraToc,nTraToc,IAD50) +NVT = IROW(NVIRT+1) +do I=1,20 + IVEC(I) = 0 +end do +IIN = 1 +do I=1,NSYM + call IPO_CPF(IPOF(IIN),NVIR,MUL,NSYM,I,-1) + IIN = IIN+NSYM +end do +! ORDER OF RECORD-CHAINS IS +! 1. NOT2 CHAINS (AB/IJ) +! 2. NOT2 CHAINS (AI/BJ) +! 3. NOT2 CHAINS (AI/JK) +! RECORD STRUCTURE IS +! 1. LBUF INTEGRALS +! 2. LBUF INDICES +! 3. NUMBER OF INTEGRALS IN THIS RECORD +! 4. ADDRESS OF LAST RECORD +NOT2 = IROW(LN+1) +NOV = 3*NOT2 +NOTT = 2*NOT2 +NOVST = LN*NVIRT+1+NVT +IDISK = 0 +LBUF0 = RTOI*LBUF +LBUF1 = LBUF0+LBUF+1 +LBUF2 = LBUF1+1 +IDIV = RTOI +ID = 0 +do IREC=1,NOV + IBUFL(IREC) = 0 + ICAD(IREC) = ID + INDOUT(ID+LBUF2) = -1 + ID = ID+LBUF2 +end do +NORB0(1) = 0 +do I=1,NSYM + NORB0(I+1) = NORB0(I)+NORB(I) +end do + +! ONE-ELECTRON INTEGRALS + +NORBTT = 0 +do ISYM=1,nsym + NORBTT = NORBTT+(NORB(ISYM)*(NORB(ISYM)+1))/2 +end do +EMY = POTNUC +NOB2 = IROW(NORBT+1) +IADD17 = ITOC17(2) +call dDAFILE(Lu_TraOne,2,FIJ,NORBTT,IADD17) +FC(1:NOB2) = Zero +IBUF = 0 +KORBI = 0 +do ISYM=1,NSYM + do JORBI=KORBI+1,KORBI+NORB(ISYM) + do IORBI=KORBI+1,JORBI + IBUF = IBUF+1 + ONEHAM = FIJ(IBUF) + NI = ICH(IORBI) + NJ = ICH(JORBI) + if ((NI == 0) .or. (NJ == 0)) cycle + if (NI < NJ) then + NTMP = NI + NI = NJ + NJ = NTMP + end if + if (NJ > 0) then + IJT = IROW(NI)+NJ + FC(IJT) = FC(IJT)+ONEHAM + else if (NI == NJ) then + EMY = EMY+Two*ONEHAM + end if + end do + end do + KORBI = KORBI+NORB(ISYM) +end do +FIJ(1:NOB2) = Zero +FJI(1:NOB2) = Zero +if (IPRINT >= 20) then + call TRIPRT('FC IN SORT BEFORE TWOEL',' ',FC,NORBT) + write(u6,'(A,F20.8)') ' EMY:',EMY +end if + +! TWO-ELECTRON INTEGRALS + +do NSP=1,NSYM + NOP = NORB(NSP) + do NSQ=1,NSP + NSPQ = MUL(NSP,NSQ) + NOQ = NORB(NSQ) + do NSR=1,NSP + NSPQR = MUL(NSPQ,NSR) + NOR = NORB(NSR) + NSSM = NSR + if (NSR == NSP) NSSM = NSQ + do NSS=1,NSSM + if (NSS /= NSPQR) cycle + NOS = NORB(NSS) + NORBP = NOP*NOQ*NOR*NOS + if (NORBP == 0) cycle + call dDAFILE(Lu_TraInt,2,TIBUF,NTIBUF,IAD50) + IOUT = 0 + do NV=1,NOR + NXM = NOS + if (NSR == NSS) NXM = NV + do NX=1,NXM + NTM = 1 + if (NSP == NSR) NTM = NV + do NT=NTM,NOP + NUMIN = 1 + if ((NSP == NSR) .and. (NT == NV)) NUMIN = NX + NUMAX = NOQ + if (NSP == NSQ) NUMAX = NT + do NU=NUMIN,NUMAX + IOUT = IOUT+1 + if (IOUT > NTIBUF) then + call dDAFILE(Lu_TraInt,2,TIBUF,NTIBUF,IAD50) + IOUT = 1 + end if + M1 = ICH(NORB0(NSP)+NT) + M2 = ICH(NORB0(NSQ)+NU) + M3 = ICH(NORB0(NSR)+NV) + M4 = ICH(NORB0(NSS)+NX) + if ((M1 == 0) .or. (M2 == 0) .or. (M3 == 0) .or. (M4 == 0)) cycle + ! ORDER THESE INDICES CANONICALLY + N1 = max(M1,M2) + N2 = min(M1,M2) + N3 = max(M3,M4) + N4 = min(M3,M4) + NI = N1 + NJ = N2 + NK = N3 + NL = N4 + if (NI <= NK) then + if (NI /= NK) then + NI = N3 + NJ = N4 + NK = N1 + NL = N2 + else if (NJ <= NL) then + NL = N2 + NJ = N4 + end if + end if + FINI = TIBUF(IOUT) + if (abs(FINI) < 1.0e-9_wp) cycle + if ((NI > 0) .and. (NJ > 0) .and. (NK > 0) .and. (NL > 0)) then + DFINI = abs(FINI) + IEXP = int(-log10(DFINI+1.0e-20_wp)+5) + if (IEXP > 20) IEXP = 20 + if (IEXP < 1) IEXP = 1 + IVEC(IEXP) = IVEC(IEXP)+1 + if ((NI == NJ) .and. (NK == NL)) then + IJ = IROW(NI)+NK + FIJ(IJ) = FINI + ! SKIP (AA/II) INTEGRALS + else + if ((NI == NK) .and. (NJ == NL)) then + IJ = IROW(NI)+NJ + FJI(IJ) = FINI + end if + if (NI >= LN) then + if (NJ <= LN) then + if (NK <= LN) then + ! AIJK + JK = NOTT+IROW(NK)+NL + IBUFL(JK) = IBUFL(JK)+1 + ICQ = ICAD(JK) + ICP = ICQ/IDIV+IBUFL(JK) + BUFOUT(ICP) = FINI + ICPP = ICQ+LBUF0+IBUFL(JK) + INDOUT(ICPP) = IROW(NI)+NJ + if (IBUFL(JK) >= LBUF) then + INDOUT(ICQ+LBUF1) = LBUF + JDISK = IDISK + call iDAFILE(Lu_TiABIJ,1,INDOUT(ICQ+1),LBUF2,IDISK) + INDOUT(ICQ+LBUF2) = JDISK + IBUFL(JK) = 0 + end if + else if (NL <= LN) then + ! AIBJ + IIJ = NOT2+IROW(NJ)+NL + if (NL > NJ) IIJ = NOT2+IROW(NL)+NJ + IBUFL(IIJ) = IBUFL(IIJ)+1 + ICQ = ICAD(IIJ) + ICP = ICQ/IDIV+IBUFL(IIJ) + BUFOUT(ICP) = FINI + NSA = NSM(NI) + NAV = NI-LN-NSYS(NSA) + NSB = NSM(NK) + NBV = NK-LN-NSYS(NSB) + NSIJT = (MUL(NSM(NJ),NSM(NL))-1)*NSYM + if (NL <= NJ) then + INAV = IPOF(NSIJT+NSA)+(NBV-1)*NVIR(NSA)+NAV + else + INAV = IPOF(NSIJT+NSB)+(NAV-1)*NVIR(NSB)+NBV + end if + ICPP = ICQ+LBUF0+IBUFL(IIJ) + INDOUT(ICPP) = INAV + if (IBUFL(IIJ) >= LBUF) then + INDOUT(ICQ+LBUF1) = LBUF + JDISK = IDISK + call iDAFILE(Lu_TiABIJ,1,INDOUT(ICQ+1),LBUF2,IDISK) + INDOUT(ICQ+LBUF2) = JDISK + IBUFL(IIJ) = 0 + end if + if ((NJ == NL) .and. (NI /= NK)) then + JNAV = IROW(NI)+NK + FC(JNAV) = FC(JNAV)-FINI + end if + end if + else if (NK <= LN) then + ! ABIJ + IIJ = IROW(NK)+NL + IBUFL(IIJ) = IBUFL(IIJ)+1 + ICQ = ICAD(IIJ) + ICP = ICQ/IDIV+IBUFL(IIJ) + BUFOUT(ICP) = FINI + NSA = NSM(NI) + NAV = NI-LN-NSYS(NSA) + NSB = NSM(NJ) + NBV = NJ-LN-NSYS(NSB) + NSIJT = (MUL(NSM(NK),NSM(NL))-1)*NSYM + INAV = IPOF(NSIJT+NSA)+(NBV-1)*NVIR(NSA)+NAV + ICPP = ICQ+LBUF0+IBUFL(IIJ) + INDOUT(ICPP) = INAV + if (IBUFL(IIJ) >= LBUF) then + INDOUT(ICQ+LBUF1) = LBUF + JDISK = IDISK + call iDAFILE(Lu_TiABIJ,1,INDOUT(ICQ+1),LBUF2,IDISK) + INDOUT(ICQ+LBUF2) = JDISK + IBUFL(IIJ) = 0 + end if + if ((NK == NL) .and. (NI /= NJ)) then + JNAV = IROW(NI)+NJ + FC(JNAV) = FC(JNAV)+Two*FINI + end if + end if + end if + end if + else + ! CHECK FOR FOCK-MATRIX CONTRIBUTION + if (NI == NJ) then + II = 1 + call IFOCK(FC,NI,NK,NL,FINI,II) + if (NK == NL) then + if ((NI <= 0) .and. (NK <= 0)) then + EMY = EMY+Two*FINI + if (NI /= NK) EMY = EMY+Two*FINI + end if + if (NI /= NK) call IFOCK(FC,NK,NI,NJ,FINI,II) + end if + else if (NK == NL) then + II = 1 + call IFOCK(FC,NK,NI,NJ,FINI,II) + end if + II = 0 + if (NI == NK) then + call IFOCK(FC,NI,NJ,NL,FINI,II) + if (NJ == NL) then + if ((NI <= 0) .and. (NJ <= 0)) then + EMY = EMY-FINI + if (NI /= NJ) EMY = EMY-FINI + end if + if (NI /= NJ) call IFOCK(FC,NJ,NI,NK,FINI,II) + end if + else if (NI == NL) then + call IFOCK(FC,NI,NJ,NK,FINI,II) + else if (NJ == NK) then + call IFOCK(FC,NJ,NI,NL,FINI,II) + else if (NJ == NL) then + call IFOCK(FC,NJ,NI,NK,FINI,II) + end if + end if + end do + end do + end do + end do + end do + end do + end do +end do +! EMPTY LAST BUFFERS +if ((NOVST+NOV) > MADR) then + write(u6,*) 'SORT Error: NOVST+NOV>MADR (See code).' + call Abend() +end if +do I=1,NOV + ICQ = ICAD(I) + INDOUT(ICQ+LBUF1) = IBUFL(I) + JDISK = IDISK + call iDAFILE(Lu_TiABIJ,1,INDOUT(ICQ+1),LBUF2,IDISK) + LASTAD(NOVST+I) = JDISK +end do +do J=1,NORBT + IND = IROW(J+1) + FC(IND) = FC(IND)+EMY/N +end do +IADD25 = 0 +call dDAFILE(Lu_25,1,FC,NOB2,IADD25) +IAD25S = IADD25 +write(u6,154) +write(u6,155) (IVEC(I),I=1,20) + +return + +154 format(//6X,'STATISTICS FOR INTEGRALS, FIRST ENTRY 10**3-10**4',/) +155 format(6X,5I10) + +end subroutine SORT_CPF diff -Nru openmolcas-22.02/src/cpf/sort.f openmolcas-22.10/src/cpf/sort.f --- openmolcas-22.02/src/cpf/sort.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/sort.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,334 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE SORT_CPF(BUFOUT,INDOUT,ICAD,IBUFL,FC,FIJ,FJI,TIBUF) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "cpfmcpf.fh" -#include "files_cpf.fh" - DIMENSION BUFOUT(*),INDOUT(*) - DIMENSION ICAD(*),FC(*),IBUFL(*),FIJ(*),FJI(*),TIBUF(*) - DIMENSION IVEC(20),IPOF(65) - DIMENSION NORB0(9) -* - IAD50=0 - CALL iDAFILE(Lu_TraInt,2,iTraToc,nTraToc,IAD50) - NVT=IROW(NVIRT+1) - DO 50 I=1,20 - IVEC(I)=0 -50 CONTINUE - IN=1 - DO 3 I=1,NSYM - CALL IPO_CPF(IPOF(IN),NVIR,MUL,NSYM,I,-1) - IN=IN+NSYM -3 CONTINUE -C ORDER OF RECORD-CHAINS IS -C 1. NOT2 CHAINS (AB/IJ) -C 2. NOT2 CHAINS (AI/BJ) -C 3. NOT2 CHAINS (AI/JK) -C RECORD STRUCTURE IS -C 1. LBUF INTEGRALS -C 2. LBUF INDICES -C 3. NUMBER OF INTEGRALS IN THIS RECORD -C 4. ADDRESS OF LAST RECORD - NOT2=IROW(LN+1) - NOV=3*NOT2 - NOTT=2*NOT2 - NOVST=LN*NVIRT+1+NVT - IDISK=0 - LBUF0=RTOI*LBUF - LBUF1=LBUF0+LBUF+1 - LBUF2=LBUF1+1 - IDIV=RTOI - ID=0 - DO 5 IREC=1,NOV - IBUFL(IREC)=0 - ICAD(IREC)=ID - INDOUT(ID+LBUF2)=-1 - ID=ID+LBUF2 -5 CONTINUE - NORB0(1)=0 - DO 2 I=1,NSYM - NORB0(I+1)=NORB0(I)+NORB(I) -2 CONTINUE -C -C ONE ELECTRON INTEGRALS -C - NORBTT=0 - DO 7654 ISYM=1,nsym - NORBTT=NORBTT+(NORB(ISYM)*(NORB(ISYM)+1))/2 - 7654 CONTINUE - EMY=POTNUC - NOB2=IROW(NORBT+1) - IADD17=ITOC17(2) - CALL dDAFILE(Lu_TraOne,2,FIJ,NORBTT,IADD17) - CALL DCOPY_(NOB2,[0.0D0],0,FC,1) - IBUF=0 - KORBI=0 - DO 200 ISYM=1,NSYM - DO 198 JORBI=KORBI+1,KORBI+NORB(ISYM) - DO 199 IORBI=KORBI+1,JORBI - IBUF=IBUF+1 - ONEHAM=FIJ(IBUF) - NI=ICH(IORBI) - NJ=ICH(JORBI) - IF(NI.EQ.0.OR.NJ.EQ.0)GO TO 199 - IF(NI.LT.NJ) THEN - NTMP=NI - NI=NJ - NJ=NTMP - END IF - IF(NJ.GT.0) THEN - IJT=IROW(NI)+NJ - FC(IJT)=FC(IJT)+ONEHAM - ELSE IF(NI.EQ.NJ) THEN - EMY=EMY+2.0D0*ONEHAM - END IF -199 CONTINUE -198 CONTINUE - KORBI=KORBI+NORB(ISYM) -200 CONTINUE - CALL DCOPY_(NOB2,[0.0D0],0,FIJ,1) - CALL DCOPY_(NOB2,[0.0D0],0,FJI,1) - IF( IPRINT.GE.20 ) THEN - CALL TRIPRT('FC IN SORT BEFORE TWOEL',' ',FC,NORBT) - WRITE(6,'(A,F20.8)') ' EMY:',EMY - CALL XFLUSH(6) - END IF -C -C TWO-ELECTRON INTEGRALS -C - DO 313 NSP=1,NSYM - NOP=NORB(NSP) - DO 312 NSQ=1,NSP - NSPQ=MUL(NSP,NSQ) - NOQ=NORB(NSQ) - DO 311 NSR=1,NSP - NSPQR=MUL(NSPQ,NSR) - NOR=NORB(NSR) - NSSM=NSR - IF(NSR.EQ.NSP)NSSM=NSQ - DO 310 NSS=1,NSSM - IF(NSS.NE.NSPQR)GO TO 310 - NOS=NORB(NSS) - NORBP=NOP*NOQ*NOR*NOS - IF(NORBP.EQ.0)GO TO 310 - CALL dDAFILE(Lu_TraInt,2,TIBUF,NTIBUF,IAD50) - IOUT=0 - DO 309 NV=1,NOR - NXM=NOS - IF(NSR.EQ.NSS)NXM=NV - DO 308 NX=1,NXM - NTM=1 - IF(NSP.EQ.NSR)NTM=NV - DO 307 NT=NTM,NOP - NUMIN=1 - IF(NSP.EQ.NSR.AND.NT.EQ.NV)NUMIN=NX - NUMAX=NOQ - IF(NSP.EQ.NSQ)NUMAX=NT - DO 306 NU=NUMIN,NUMAX - IOUT=IOUT+1 - IF(IOUT.GT.NTIBUF) THEN - CALL dDAFILE(Lu_TraInt,2,TIBUF,NTIBUF,IAD50) - IOUT=1 - END IF - M1=ICH(NORB0(NSP)+NT) - M2=ICH(NORB0(NSQ)+NU) - M3=ICH(NORB0(NSR)+NV) - M4=ICH(NORB0(NSS)+NX) - IF(M1.EQ.0.OR.M2.EQ.0)GO TO 306 - IF(M3.EQ.0.OR.M4.EQ.0)GO TO 306 -C ORDER THESE INDICES CANONICALLY - N1=M1 - N2=M2 - IF(M1.GT.M2)GO TO 11 - N1=M2 - N2=M1 -11 N3=M3 - N4=M4 - IF(M3.GT.M4)GO TO 12 - N3=M4 - N4=M3 -12 NI=N1 - NJ=N2 - NK=N3 - NL=N4 - IF(NI.GT.NK)GO TO 502 - IF(NI.EQ.NK)GO TO 14 - NI=N3 - NJ=N4 - NK=N1 - NL=N2 - GO TO 502 -14 IF(NJ.GT.NL)GO TO 502 - NL=N2 - NJ=N4 -502 FINI=TIBUF(IOUT) - IF(ABS(FINI).LT.1.D-09)GO TO 306 - IF(NI.LE.0 .OR. NJ.LE.0)GO TO 41 - IF(NK.LE.0 .OR. NL.LE.0)GO TO 41 - DFINI=ABS(FINI) - IEXP=INT(-LOG10(DFINI+1.0D-20)+5) - IF(IEXP.GT.20) IEXP=20 - IF(IEXP.LT.1) IEXP=1 - IVEC(IEXP)=IVEC(IEXP)+1 - IF(NI.NE.NJ.OR.NK.NE.NL)GO TO 42 - IJ=IROW(NI)+NK - FIJ(IJ)=FINI -C SKIP (AA/II) INTEGRALS - GO TO 306 -42 IF(NI.NE.NK.OR.NJ.NE.NL)GO TO 43 - IJ=IROW(NI)+NJ - FJI(IJ)=FINI -43 IF(NI.LE.LN)GO TO 306 - IF(NJ.GT.LN)GO TO 102 - IF(NK.GT.LN)GO TO 103 -C AIJK - JK=NOTT+IROW(NK)+NL - IBUFL(JK)=IBUFL(JK)+1 - ICQ=ICAD(JK) - ICP=ICQ/IDIV+IBUFL(JK) - BUFOUT(ICP)=FINI - ICPP=ICQ+LBUF0+IBUFL(JK) - INDOUT(ICPP)=IROW(NI)+NJ - IF(IBUFL(JK).LT.LBUF)GO TO 306 - INDOUT(ICQ+LBUF1)=LBUF - JDISK=IDISK - CALL iDAFILE(Lu_TiABIJ,1,INDOUT(ICQ+1),LBUF2,IDISK) - INDOUT(ICQ+LBUF2)=JDISK - IBUFL(JK)=0 - GO TO 306 -103 IF(NL.GT.LN)GO TO 306 -C AIBJ - IIJ=NOT2+IROW(NJ)+NL - IF(NL.GT.NJ)IIJ=NOT2+IROW(NL)+NJ - IBUFL(IIJ)=IBUFL(IIJ)+1 - ICQ=ICAD(IIJ) - ICP=ICQ/IDIV+IBUFL(IIJ) - BUFOUT(ICP)=FINI - NSA=NSM(NI) - NAV=NI-LN-NSYS(NSA) - NSB=NSM(NK) - NBV=NK-LN-NSYS(NSB) - NSIJT=(MUL(NSM(NJ),NSM(NL))-1)*NSYM - IF(NL.GT.NJ)GO TO 105 - INAV=IPOF(NSIJT+NSA)+(NBV-1)*NVIR(NSA)+NAV - GO TO 104 -105 INAV=IPOF(NSIJT+NSB)+(NAV-1)*NVIR(NSB)+NBV -104 ICPP=ICQ+LBUF0+IBUFL(IIJ) - INDOUT(ICPP)=INAV - IF(IBUFL(IIJ).LT.LBUF)GO TO 108 - INDOUT(ICQ+LBUF1)=LBUF - JDISK=IDISK - CALL iDAFILE(Lu_TiABIJ,1,INDOUT(ICQ+1),LBUF2,IDISK) - INDOUT(ICQ+LBUF2)=JDISK - IBUFL(IIJ)=0 -108 IF(NJ.NE.NL)GO TO 306 - IF(NI.EQ.NK)GO TO 306 - JNAV=IROW(NI)+NK - FC(JNAV)=FC(JNAV)-FINI - GO TO 306 -102 IF(NK.GT.LN)GO TO 306 -C ABIJ - IIJ=IROW(NK)+NL - IBUFL(IIJ)=IBUFL(IIJ)+1 - ICQ=ICAD(IIJ) - ICP=ICQ/IDIV+IBUFL(IIJ) - BUFOUT(ICP)=FINI - NSA=NSM(NI) - NAV=NI-LN-NSYS(NSA) - NSB=NSM(NJ) - NBV=NJ-LN-NSYS(NSB) - NSIJT=(MUL(NSM(NK),NSM(NL))-1)*NSYM - INAV=IPOF(NSIJT+NSA)+(NBV-1)*NVIR(NSA)+NAV - ICPP=ICQ+LBUF0+IBUFL(IIJ) - INDOUT(ICPP)=INAV - IF(IBUFL(IIJ).LT.LBUF)GO TO 106 - INDOUT(ICQ+LBUF1)=LBUF - JDISK=IDISK - CALL iDAFILE(Lu_TiABIJ,1,INDOUT(ICQ+1),LBUF2,IDISK) - INDOUT(ICQ+LBUF2)=JDISK - IBUFL(IIJ)=0 -106 IF(NK.NE.NL)GO TO 306 - IF(NI.EQ.NJ)GO TO 306 - JNAV=IROW(NI)+NJ - FC(JNAV)=FC(JNAV)+D2*FINI - GO TO 306 -C CHECK FOR FOCK-MATRIX CONTRIBUTION -41 IF(NI.NE.NJ)GO TO 51 - II=1 - CALL IFOCK(FC,NI,NK,NL,FINI,II) - IF(NK.NE.NL)GO TO 52 - IF(NI.GT.0.OR.NK.GT.0)GO TO 57 - EMY=EMY+D2*FINI - IF(NI.NE.NK)EMY=EMY+D2*FINI -57 IF(NI.EQ.NK)GO TO 52 - CALL IFOCK(FC,NK,NI,NJ,FINI,II) - GO TO 52 -51 IF(NK.NE.NL)GO TO 52 - II=1 - CALL IFOCK(FC,NK,NI,NJ,FINI,II) -52 II=0 - IF(NI.NE.NK)GO TO 53 - CALL IFOCK(FC,NI,NJ,NL,FINI,II) - IF(NJ.NE.NL)GO TO 306 - IF(NI.GT.0.OR.NJ.GT.0)GO TO 58 - EMY=EMY-FINI - IF(NI.NE.NJ)EMY=EMY-FINI -58 IF(NI.EQ.NJ)GO TO 306 - CALL IFOCK(FC,NJ,NI,NK,FINI,II) - GO TO 306 -53 IF(NI.NE.NL)GO TO 54 - CALL IFOCK(FC,NI,NJ,NK,FINI,II) - GO TO 306 -54 IF(NJ.NE.NK)GO TO 55 - CALL IFOCK(FC,NJ,NI,NL,FINI,II) - GO TO 306 -55 IF(NJ.NE.NL)GO TO 306 - CALL IFOCK(FC,NJ,NI,NK,FINI,II) -306 CONTINUE -307 CONTINUE -308 CONTINUE -309 CONTINUE -310 CONTINUE -311 CONTINUE -312 CONTINUE -313 CONTINUE -C EMPTY LAST BUFFERS - If ( (NOVST+NOV).gt.mAdr ) then - WRITE(6,*)'SORT Error: NOVST+NOV>MADR (See code).' - CALL Abend - End If - DO 150 I=1,NOV - ICQ=ICAD(I) - INDOUT(ICQ+LBUF1)=IBUFL(I) - JDISK=IDISK - CALL iDAFILE(Lu_TiABIJ,1,INDOUT(ICQ+1),LBUF2,IDISK) - LASTAD(NOVST+I)=JDISK -150 CONTINUE - DO 95 J=1,NORBT - IND=IROW(J+1) - FC(IND)=FC(IND)+EMY/N -95 CONTINUE - IADD25=0 - CALL dDAFILE(Lu_25,1,FC,NOB2,IADD25) - IAD25S=IADD25 - WRITE(6,154) - CALL XFLUSH(6) -154 FORMAT(//6X,'STATISTICS FOR INTEGRALS, FIRST ENTRY 10**3-10**4', - */) - WRITE(6,155)(IVEC(I),I=1,20) - CALL XFLUSH(6) -155 FORMAT(6X,5I10) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/spin_cpf.fh openmolcas-22.10/src/cpf/spin_cpf.fh --- openmolcas-22.02/src/cpf/spin_cpf.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/spin_cpf.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,12 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Logical LWSP - Common /SPINBLOCK/ LWSP diff -Nru openmolcas-22.02/src/cpf/squar2.f openmolcas-22.10/src/cpf/squar2.f --- openmolcas-22.02/src/cpf/squar2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/squar2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE SQUAR2_CPF(A,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(N,N) - DO 10 I=1,N - NI=N-I+1 - CALL DCOPY_(NI,A(I,I),1,A(I,I),N) -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/squar.f openmolcas-22.10/src/cpf/squar.f --- openmolcas-22.02/src/cpf/squar.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/squar.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ -cpgi$g opt=1 - SUBROUTINE SQUAR_CPF(A,B,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(*),B(N,N) - IN=1 - DO 10 I=1,N - CALL DCOPY_(I,A(IN),1,B(I,1),N) - CALL DCOPY_(I,A(IN),1,B(1,I),1) - IN=IN+I -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/squarm.f openmolcas-22.10/src/cpf/squarm.f --- openmolcas-22.02/src/cpf/squarm.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/squarm.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,24 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE SQUARM_CPF(A,B,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(*),B(N,N) - IN=1 - DO 10 I=1,N - CALL DCOPY_(I,A(IN),1,B(I,1),N) - CALL VNEG_CPF(A(IN),1,B(1,I),1,I) - IN=IN+I -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/squarn.f openmolcas-22.10/src/cpf/squarn.f --- openmolcas-22.02/src/cpf/squarn.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/squarn.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,24 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE SQUARN_CPF(A,B,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(*),B(N,N) - IN=1 - DO 10 I=1,N - CALL VNEG_CPF(A(IN),1,B(I,1),N,I) - CALL DCOPY_(I,A(IN),1,B(1,I),1) - IN=IN+I -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/start_cpf.f openmolcas-22.10/src/cpf/start_cpf.f --- openmolcas-22.02/src/cpf/start_cpf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/start_cpf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE START_CPF(C,NCONF,IREF0) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION C(*) - DO 10 I=1,NCONF - C(I)=0.0D0 -10 CONTINUE - C(IREF0)=1.0D0 - RETURN - END diff -Nru openmolcas-22.02/src/cpf/start_cpf.F90 openmolcas-22.10/src/cpf/start_cpf.F90 --- openmolcas-22.02/src/cpf/start_cpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/start_cpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,31 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine START_CPF(C,NCONF,IREF0) + +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +real(kind=wp), intent(_OUT_) :: C(*) +integer(kind=iwp), intent(in) :: NCONF, IREF0 + +C(1:NCONF) = Zero +C(IREF0) = One + +return + +end subroutine START_CPF diff -Nru openmolcas-22.02/src/cpf/thetset.f openmolcas-22.10/src/cpf/thetset.f --- openmolcas-22.02/src/cpf/thetset.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/thetset.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,84 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE THETSET(ICASE,THE,NII) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION THE(NII,NII),IOCR(100) - DIMENSION ICASE(*) - -#include "SysDef.fh" - -#include "cpfmcpf.fh" -#include "spin_cpf.fh" - JO(L)=ICUNP(ICASE,L) -CPAM97 EXTERNAL UNPACK -CPAM97 INTEGER UNPACK -CPAM97 JO(L)=UNPACK(QOCC((L+29)/30), 2*L-(2*L-1)/60*60, 2) -*PAM06 This routine is called from SDCI if this is an MCPF calculation -C - IOR=0 - II1=(IREF0-1)*LN - DO 35 I=1,LN - JOJ=JO(II1+I) - IOR=IOR+1 - IOCR(IOR)=JOJ -35 CONTINUE - IF(IPRINT.GT.5)WRITE(6,888)IREF0,(IOCR(I),I=1,LN) -888 FORMAT(5X,'IREF0=',I3/5X,'IOCR=',10I5) -C - IINT=IRC(4) - DO 8 IP=1,IINT - DO 7 IQ=1,IINT - THE(IQ,IP)=D1 -7 CONTINUE -8 CONTINUE -C - DO 6 IP=1,IINT - DO 5 IQ=1,IINT - THE(IQ,IP)=0.0D0 -5 CONTINUE -6 CONTINUE - DO 10 IP=1,IINT - II=0 - IJ=0 - DO 15 I=1,LN - JJ=(IP-1)*LN+I - IF(JO(JJ).EQ.IOCR(I).OR.JO(JJ).EQ.3)GO TO 15 - IF(LWSP.AND.JO(JJ)*IOCR(I).EQ.2) GO TO 15 - IF(II.NE.0)GO TO 16 - II=I -16 IJ=I -15 CONTINUE -*PAM06 BUG: What if we come down here with II.eq.0 still?? -* the IOCR will be accessed below first element. Provisional fix: - IF(II.EQ.0) GOTO 10 - NI=IOCR(II) - IF(NI.GT.1)NI=NI-1 - NJ=IOCR(IJ) - IF(NJ.GT.1)NJ=NJ-1 - DO 20 IQ=1,IINT - IK=0 - IL=0 - DO 25 I=1,LN - JJ=(IQ-1)*LN+I - IF(JO(JJ).EQ.IOCR(I).OR.JO(JJ).EQ.3)GO TO 25 - IF(LWSP.AND.JO(JJ)*IOCR(I).EQ.2) GO TO 25 - IF(IK.NE.0)GO TO 26 - IK=I -26 IL=I -25 CONTINUE - IF(II.EQ.IK.AND.IJ.EQ.IL)THE(IQ,IP)=1.0D0 -20 CONTINUE -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/thetset.F90 openmolcas-22.10/src/cpf/thetset.F90 --- openmolcas-22.02/src/cpf/thetset.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/thetset.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,75 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine THETSET(ICASE,THE,NII) +!PAM06 This routine is called from SDCI if this is an MCPF calculation + +use cpf_global, only: IPRINT, IRC, IREF0, LN, LWSP +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: ICASE(*), NII +real(kind=wp), intent(out) :: THE(NII,NII) +integer(kind=iwp) :: I, II, II1, IINT, IIOR, IJ, IK, IL, IOCR(100), IP, IQ, JJ, JOJ, NI, NJ +integer(kind=iwp), external :: ICUNP + +IIOR = 0 +II1 = (IREF0-1)*LN +do I=1,LN + JOJ = ICUNP(ICASE,II1+I) + IIOR = IIOR+1 + IOCR(IIOR) = JOJ +end do +if (IPRINT > 5) write(u6,888) IREF0,(IOCR(I),I=1,LN) + +IINT = IRC(4) +THE(1:IINT,1:IINT) = Zero +do IP=1,IINT + II = 0 + IJ = 0 + do I=1,LN + JJ = (IP-1)*LN+I + if ((ICUNP(ICASE,JJ) == IOCR(I)) .or. (ICUNP(ICASE,JJ) == 3)) cycle + if (LWSP .and. (ICUNP(ICASE,JJ)*IOCR(I) == 2)) cycle + if (II == 0) II = I + IJ = I + end do + !PAM06 BUG: What if we come down here with II == 0 still?? + ! the IOCR will be accessed below first element. Provisional fix: + if (II /= 0) then + NI = IOCR(II) + if (NI > 1) NI = NI-1 + NJ = IOCR(IJ) + if (NJ > 1) NJ = NJ-1 + do IQ=1,IINT + IK = 0 + IL = 0 + do I=1,LN + JJ = (IQ-1)*LN+I + if ((ICUNP(ICASE,JJ) == IOCR(I)) .or. (ICUNP(ICASE,JJ) == 3)) cycle + if (LWSP .and. (ICUNP(ICASE,JJ)*IOCR(I) == 2)) cycle + if (IK == 0) IK = I + IL = I + end do + if ((II == IK) .and. (IJ == IL)) THE(IQ,IP) = One + end do + end if +end do + +return + +888 format(5X,'IREF0=',I3/5X,'IOCR=',10I5) + +end subroutine THETSET diff -Nru openmolcas-22.02/src/cpf/tpqset.f openmolcas-22.10/src/cpf/tpqset.f --- openmolcas-22.02/src/cpf/tpqset.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/tpqset.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,89 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE TPQSET(ICASE,TPQ,IP) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION TPQ(*),IOCR(100) - DIMENSION ICASE(*) - -#include "SysDef.fh" - -#include "cpfmcpf.fh" -#include "spin_cpf.fh" -CPAM97 EXTERNAL UNPACK -CPAM97 INTEGER UNPACK -CRL JO(L)=IAND(ISHFT(QOCC((L+29)/30),-2*((L+29)/30*30-L)),3) -CPAM97 JO(L)=UNPACK(QOCC((L+29)/30), 2*L-(2*L-1)/60*60, 2) - JO(L)=ICUNP(ICASE,L) -C - D0=0.0D0 - D1=1.0D0 - D2=2.0D0 -C - IOR=0 - II1=(IREF0-1)*LN - DO 35 I=1,LN - JOJ=JO(II1+I) - IOR=IOR+1 - IOCR(IOR)=JOJ -35 CONTINUE -C - IINT=IRC(4) - DO 7 IQ=1,IINT - TPQ(IQ)=D1 - IF(INCPF.EQ.1)TPQ(IQ)=D2/N - IF(IQ.EQ.IREF0.OR.IP.EQ.IREF0)TPQ(IQ)=D0 -7 CONTINUE - IF(ISDCI.EQ.1.OR.INCPF.EQ.1.OR.IP.EQ.IREF0)RETURN -C - II=0 - IJ=0 - DO 15 I=1,LN - JJ=(IP-1)*LN+I - IF(JO(JJ).EQ.IOCR(I).OR.JO(JJ).EQ.3)GO TO 15 - IF(LWSP.AND.JO(JJ)*IOCR(I).EQ.2) GO TO 15 - IF(II.NE.0)GO TO 16 - II=I -16 IJ=I -15 CONTINUE - NI=IOCR(II) - IF(NI.GT.1)NI=NI-1 - NJ=IOCR(IJ) - IF(NJ.GT.1)NJ=NJ-1 - DO 20 IQ=1,IINT - IK=0 - IL=0 - DO 25 I=1,LN - JJ=(IQ-1)*LN+I - IF(JO(JJ).EQ.IOCR(I).OR.JO(JJ).EQ.3)GO TO 25 - IF(LWSP.AND.JO(JJ)*IOCR(I).EQ.2) GO TO 25 - IF(IK.NE.0)GO TO 26 - IK=I -26 IL=I -25 CONTINUE - DIK=D0 - DIL=D0 - DJK=D0 - DJL=D0 - IF(II.EQ.IK)DIK=D1 - IF(II.EQ.IL)DIL=D1 - IF(IJ.EQ.IK)DJK=D1 - IF(IJ.EQ.IL)DJL=D1 - TPQ(IQ)=(DIK+DIL)/(D2*NI)+(DJK+DJL)/(D2*NJ) - IF(IQ.EQ.IREF0)TPQ(IQ)=D0 -20 CONTINUE - IF(IPRINT.LT.15)RETURN - IF(IPRINT.GT.5)WRITE(6,11)(TPQ(IQ),IQ=1,IINT) -11 FORMAT(5X,'TPQ',10F5.2) - RETURN - END diff -Nru openmolcas-22.02/src/cpf/tpqset.F90 openmolcas-22.10/src/cpf/tpqset.F90 --- openmolcas-22.02/src/cpf/tpqset.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/tpqset.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,86 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine TPQSET(ICASE,TPQ,IP) + +use cpf_global, only: INCPF, IPRINT, IRC, IREF0, ISDCI, LN, LWSP, N +use Constants, only: Zero, One, Two +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: ICASE(*), IP +real(kind=wp), intent(_OUT_) :: TPQ(*) +integer(kind=iwp) :: I, II, II1, IINT, IIOR, IJ, IK, IL, IOCR(100), IQ, JJ, JOJ, NI, NJ +real(kind=wp) :: DIK, DIL, DJK, DJL +integer(kind=iwp), external :: ICUNP + +IIOR = 0 +II1 = (IREF0-1)*LN +do I=1,LN + JOJ = ICUNP(ICASE,II1+I) + IIOR = IIOR+1 + IOCR(IIOR) = JOJ +end do + +IINT = IRC(4) +do IQ=1,IINT + TPQ(IQ) = One + if (INCPF == 1) TPQ(IQ) = Two/N + if ((IQ == IREF0) .or. (IP == IREF0)) TPQ(IQ) = Zero +end do +if ((ISDCI == 1) .or. (INCPF == 1) .or. (IP == IREF0)) return + +II = 0 +IJ = 0 +do I=1,LN + JJ = (IP-1)*LN+I + if ((ICUNP(ICASE,JJ) == IOCR(I)) .or. (ICUNP(ICASE,JJ) == 3)) cycle + if (LWSP .and. (ICUNP(ICASE,JJ)*IOCR(I) == 2)) cycle + if (II == 0) II = I + IJ = I +end do +NI = IOCR(II) +if (NI > 1) NI = NI-1 +NJ = IOCR(IJ) +if (NJ > 1) NJ = NJ-1 +do IQ=1,IINT + IK = 0 + IL = 0 + do I=1,LN + JJ = (IQ-1)*LN+I + if ((ICUNP(ICASE,JJ) == IOCR(I)) .or. (ICUNP(ICASE,JJ) == 3)) cycle + if (LWSP .and. (ICUNP(ICASE,JJ)*IOCR(I) == 2)) cycle + if (IK == 0) IK = I + IL = I + end do + DIK = Zero + DIL = Zero + DJK = Zero + DJL = Zero + if (II == IK) DIK = One + if (II == IL) DIL = One + if (IJ == IK) DJK = One + if (IJ == IL) DJL = One + TPQ(IQ) = (DIK+DIL)/(Two*NI)+(DJK+DJL)/(Two*NJ) + if (IQ == IREF0) TPQ(IQ) = Zero +end do +if (IPRINT > 15) write(u6,11) (TPQ(IQ),IQ=1,IINT) + +return + +11 format(5X,'TPQ',10F5.2) + +end subroutine TPQSET diff -Nru openmolcas-22.02/src/cpf/tradd.f openmolcas-22.10/src/cpf/tradd.f --- openmolcas-22.02/src/cpf/tradd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/tradd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,26 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ -C - SUBROUTINE TRADD_CPF(A,B,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(N,N),B(*) - IN=0 - DO 10 I=1,N - DO 20 J=1,I - IN=IN+1 - B(IN)=B(IN)+A(I,J)-A(J,I) -20 CONTINUE -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/twoct.f openmolcas-22.10/src/cpf/twoct.f --- openmolcas-22.02/src/cpf/twoct.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/twoct.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,106 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE TWOCT(H) - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "cpfmcpf.fh" - DIMENSION H(*) - CALL TWOCT_INTERNAL(H) -* -* This is to allow type punning without an explicit interface - CONTAINS - SUBROUTINE TWOCT_INTERNAL(H) - USE ISO_C_BINDING - REAL*8, TARGET :: H(*) - INTEGER, POINTER :: iH2(:),iH3(:),iH4(:),iH39(:),iH47(:),iH51(:) - ILIM=4 - IF(IFIRST.NE.0)ILIM=2 - IF(ISDCI.EQ.0.AND.ICPF.EQ.0.AND.INCPF.EQ.0)GO TO 30 -C CPF, ACPF AND SDCI - IF(ITER.EQ.1)GO TO 25 - CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL DIAGC_CPF(iH2,H(LW(26)),H(LW(27))) - NULLIFY(iH2) - IF(IFIRST.NE.0)GO TO 15 - CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL C_F_POINTER(C_LOC(H(LW(3))),iH3,[1]) - CALL C_F_POINTER(C_LOC(H(LW(51))),iH51,[1]) - CALL ABCI(iH2,iH3,H(LW(26)),H(LW(27)), - *H(LW(50)),iH51,H(LW(52)),H(LW(53)),H(LW(54))) - NULLIFY(iH2,iH3,iH51) -15 CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL C_F_POINTER(C_LOC(H(LW(3))),iH3,[1]) - CALL C_F_POINTER(C_LOC(H(LW(47))),iH47,[1]) - CALL IJKL_CPF(iH2,iH3,H(LW(26)),H(LW(27)), - *H(LW(46)),H(LW(47)),iH47,H(LW(31)),H(LW(32))) - NULLIFY(iH2,iH3,iH47) - IF(IFIRST.NE.0)GO TO 25 - CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL C_F_POINTER(C_LOC(H(LW(3))),iH3,[1]) - CALL C_F_POINTER(C_LOC(H(LW(4))),iH4,[1]) - CALL ABCD(iH2,iH3,iH4,H(LW(26)),H(LW(27)), - *H(LW(57)),H(LW(58)),H(LW(59))) - NULLIFY(iH2,iH3,iH4) -25 CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL C_F_POINTER(C_LOC(H(LW(3))),iH3,[1]) - CALL C_F_POINTER(C_LOC(H(LW(39))),iH39,[1]) - CALL FAIBJ_CPF(iH2,iH3,H(LW(26)),H(LW(27)),H(LW(36)), - *H(LW(37)),H(LW(38)),H(LW(39)),iH39,H(LW(40)),H(LW(41)), - *H(LW(42)),H(LW(43)),H(LW(31)),H(LW(32))) - NULLIFY(iH2,iH3,iH39) - GO TO 50 -C MCPF -30 IF(ITER.EQ.1)GO TO 45 - CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL MDIAGC(iH2,H(LW(26)),H(LW(27)),H(LW(28)),H(LW(29)), - *H(LW(31)),IRC(ILIM)) - NULLIFY(iH2) - IF(IFIRST.NE.0)GO TO 35 - CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL C_F_POINTER(C_LOC(H(LW(3))),iH3,[1]) - CALL C_F_POINTER(C_LOC(H(LW(51))),iH51,[1]) - CALL MABCI(iH2,iH3,H(LW(26)),H(LW(27)), - *H(LW(50)),iH51,H(LW(52)),H(LW(53)),H(LW(54)), - *H(LW(28)),H(LW(29)),H(LW(31)),IRC(ILIM)) - NULLIFY(iH2,iH3,iH51) -35 CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL C_F_POINTER(C_LOC(H(LW(3))),iH3,[1]) - CALL C_F_POINTER(C_LOC(H(LW(47))),iH47,[1]) - CALL MIJKL(iH2,iH3,H(LW(26)),H(LW(27)), - *H(LW(46)),H(LW(47)),iH47,H(LW(28)),H(LW(29)),H(LW(31)), - *H(LW(32)),IRC(ILIM)) - NULLIFY(iH2,iH3,iH47) - IF(IFIRST.NE.0)GO TO 45 - CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL C_F_POINTER(C_LOC(H(LW(3))),iH3,[1]) - CALL C_F_POINTER(C_LOC(H(LW(4))),iH4,[1]) - CALL MABCD(iH2,iH3,iH4,H(LW(26)),H(LW(27)), - *H(LW(57)),H(LW(58)),H(LW(59)),H(LW(28)),H(LW(29)), - *H(LW(31)),IRC(ILIM)) - NULLIFY(iH2,iH3,iH4) -45 CALL C_F_POINTER(C_LOC(H(LW(2))),iH2,[1]) - CALL C_F_POINTER(C_LOC(H(LW(3))),iH3,[1]) - CALL C_F_POINTER(C_LOC(H(LW(39))),iH39,[1]) - CALL MFAIBJ(iH2,iH3,H(LW(26)),H(LW(27)),H(LW(36)), - *H(LW(37)),H(LW(38)),H(LW(39)),iH39,H(LW(40)),H(LW(41)), - *H(LW(42)),H(LW(43)),H(LW(28)),H(LW(29)),H(LW(31)),H(LW(32)), - *IRC(ILIM)) - NULLIFY(iH2,iH3,iH39) -50 Continue - RETURN - END SUBROUTINE TWOCT_INTERNAL -* - END diff -Nru openmolcas-22.02/src/cpf/twoct.F90 openmolcas-22.10/src/cpf/twoct.F90 --- openmolcas-22.02/src/cpf/twoct.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/twoct.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,50 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine TWOCT(C,S,W,THET,ENP,EPP,ABIJ,AIBJ,AJBI,BUFAB,A,B,F,FSEC,FIJKL,BUFIJ,BMN,IBMN,AC1,AC2,BUFAC) + +use cpf_global, only: ICPF, IFIRST, ILIM, INCPF, INDX, IRC, ISAB, ITER, ISDCI, JSY +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +real(kind=wp), intent(inout) :: C(*), S(*), W(*), EPP(*), ABIJ(*), AIBJ(*), AJBI(*), FSEC(*) +real(kind=wp), intent(_OUT_) :: BUFAB(*), A(*), B(*), F(*), FIJKL(*), BUFIJ(*), BMN(*), AC1(*), AC2(*), BUFAC(*) +real(kind=wp), intent(in) :: THET(*), ENP(*) +integer(kind=iwp), intent(_OUT_) :: IBMN(*) + +if ((ISDCI /= 0) .or. (ICPF /= 0) .or. (INCPF /= 0)) then + ! CPF, ACPF AND SDCI + if (ITER /= 1) then + call DIAGC_CPF(JSY,C,S) + if (IFIRST == 0) call ABCI_CPF(JSY,INDX,C,S,BMN,IBMN,AC1,AC2,BUFAC) + call IJKL_CPF(JSY,INDX,C,S,FIJKL,BUFIJ,ENP,EPP) + if (IFIRST == 0) call ABCD_CPF(JSY,INDX,ISAB,C,S,AC1,AC2,BUFAC) + end if + call FAIBJ_CPF(JSY,INDX,C,S,ABIJ,AIBJ,AJBI,BUFAB,A,B,F,FSEC,ENP,EPP) +else + ! MCPF + if (ITER /= 1) then + call MDIAGC(JSY,C,S,W,THET,ENP,IRC(ILIM)) + if (IFIRST == 0) call MABCI(JSY,INDX,C,S,BMN,IBMN,AC1,AC2,BUFAC,W,THET,ENP,IRC(ILIM)) + call MIJKL(JSY,INDX,C,S,FIJKL,BUFIJ,W,THET,ENP,EPP,IRC(ILIM)) + if (IFIRST == 0) call MABCD(JSY,INDX,ISAB,C,S,AC1,AC2,BUFAC,W,THET,ENP,IRC(ILIM)) + end if + call MFAIBJ(JSY,INDX,C,S,ABIJ,AIBJ,AJBI,BUFAB,A,B,F,FSEC,W,THET,ENP,EPP,IRC(ILIM)) +end if + +return + +end subroutine TWOCT diff -Nru openmolcas-22.02/src/cpf/vam.f openmolcas-22.10/src/cpf/vam.f --- openmolcas-22.02/src/cpf/vam.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/vam.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE VAM(A,LA,B,LB,C,LC,D,LD,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(*),B(*),C(*),D(*) - DO 100 I=0,N-1 - D(1+I*LD)=(A(1+I*LA)+B(1+I*LB))*C(1+I*LC) -100 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/vecsum_cpfmcpf.F90 openmolcas-22.10/src/cpf/vecsum_cpfmcpf.F90 --- openmolcas-22.02/src/cpf/vecsum_cpfmcpf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/cpf/vecsum_cpfmcpf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,33 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1986, Per E. M. Siegbahn * +! 1986, Margareta R. A. Blomberg * +!*********************************************************************** + +subroutine VECSUM_CPFMCPF(A,RSUM,N) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: N +real(kind=wp), intent(in) :: A(N) +real(kind=wp), intent(out) :: RSUM +integer(kind=iwp) :: I + +RSUM = Zero +do I=1,N + RSUM = RSUM+A(I) +end do + +return + +end subroutine VECSUM_CPFMCPF diff -Nru openmolcas-22.02/src/cpf/vecsum.f openmolcas-22.10/src/cpf/vecsum.f --- openmolcas-22.02/src/cpf/vecsum.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/vecsum.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE VECSUM_CPFMCPF(A,SUM,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(*) - SUM=0.0D0 - DO 100 I=1,N - SUM=SUM+A(I) -100 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/vneg.f openmolcas-22.10/src/cpf/vneg.f --- openmolcas-22.02/src/cpf/vneg.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/vneg.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE VNEG_CPF(A,IA,B,IB,IAB) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(*),B(*) - DO 10 I=0,IAB-1 - B(1+I*IB)=-A(1+I*IA) -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/vsadd.f openmolcas-22.10/src/cpf/vsadd.f --- openmolcas-22.02/src/cpf/vsadd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/vsadd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE VSADD(A,LA,S,C,LC,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(*),C(*) - DO 10 I=0,N-1 - C(1+LC*I)=A(1+LA*I)+S -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/cpf/vsmsb.f openmolcas-22.10/src/cpf/vsmsb.f --- openmolcas-22.02/src/cpf/vsmsb.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/cpf/vsmsb.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1986, Per E. M. Siegbahn * -* 1986, Margareta R. A. Blomberg * -************************************************************************ - SUBROUTINE VSMSB(A,LA,S,B,LB,C,LC,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(*),B(*),C(*) - DO 100 I=0,N-1 - C(1+I*LC)=A(1+I*LA)*S-B(1+I*LB) -100 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/dft_util/check_Fthaw.f openmolcas-22.10/src/dft_util/check_Fthaw.f --- openmolcas-22.02/src/dft_util/check_Fthaw.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/dft_util/check_Fthaw.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,102 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine check_Fthaw(iRC) - - use OFembed, only: ThrFThaw - Implicit Real*8 (a-h,o-z) -#include "warnings.h" - Character*16 NamRfil - Logical ok - Real*8 Ene(1000,4) -* - If (ThrFThaw.le.0.0d0) Return -* - Call f_inquire('AUXRFIL',ok) - If ( .not.ok ) Return -* - Call Get_NameRun(NamRfil) - Call NameRun('AUXRFIL') - Call Get_dScalar('Last energy',EneB) - Call NameRun(NamRfil) - Call Get_dScalar('Last energy',EneA) -* - iSeed=7 - Lu=IsFreeUnit(iSeed) - Call f_inquire('FRETHAW',ok) - If ( .not.ok ) Then - call molcas_open(Lu,'FRETHAW') -* open(Lu,file='FRETHAW') - write(Lu,'(I4,2F18.10)') 1, EneA, EneB - Go To 99 - Else - call molcas_open(Lu,'FRETHAW') -* open(Lu,file='FRETHAW',status='old') - EndIf -* - read(Lu,'(I4,2F18.10)') iter0, Ene(1,1), Ene(1,3) - If (iter0.eq.1000) Then - write(6,*) ' Error! check_Fthaw: maxIter reached! ' - Call Abend - EndIf - Do i=2,iter0 - read(Lu,'(I4,4F18.10)') iter, Ene(i,1), Ene(i,2), Ene(i,3), - & Ene(i,4) - End Do -* - iter=iter0+1 - DEneA=EneA-Ene(iter0,1) - DEneB=EneB-Ene(iter0,3) -* - Rewind Lu - write(Lu,'(I4,2F18.10)') iter, Ene(1,1), Ene(1,3) - Do i=2,iter0 - write(Lu,'(I4,4F18.10)') iter, Ene(i,1), Ene(i,2), Ene(i,3), - & Ene(i,4) - End Do - write(Lu,'(I4,4F18.10)') iter, EneA, DEneA, EneB, DEneB -* - write(6,*) - write(6,*) '**************************************************'// - & '*****************************' - write(6,*) '*************** Energy Statistics for Freeze-n-Thaw'// - & ' ***************************' - write(6,*) '**************************************************'// - & '*****************************' - write(6,*) ' Energy_A Delta(Energy_A) '// - & 'Energy_B Delta(Energy_B)' - write(6,'(I3,1X,F18.10,18X,F18.10)') 1, Ene(1,1), Ene(1,3) - Do i=2,iter0 - write(6,'(I3,1X,4F18.10)') i, Ene(i,1), Ene(i,2), Ene(i,3), - & Ene(i,4) - End Do - write(6,'(I3,1X,4F18.10)') iter, EneA, DEneA, EneB, DEneB - write(6,*) '**************************************************'// - & '*****************************' -* - If ( abs(DEneA).lt.ThrFThaw .and. - & abs(DEneB).lt.ThrFThaw ) Then - write(6,'(A,E9.2,A)')' Convergence reached ! (Thr = ',ThrFThaw, - & ')' - write(6,*) - iRC=_RC_ALL_IS_WELL_ - Close(Lu,status='delete') - Return - Else - write(6,'(A,E9.2,A)')' Convergence NOT reached yet ! (Thr = ', - & ThrFThaw,')' - write(6,*) - EndIf -* -99 Continue - Close(Lu,status='keep') -* - Return - End diff -Nru openmolcas-22.02/src/dft_util/check_fthaw.F90 openmolcas-22.10/src/dft_util/check_fthaw.F90 --- openmolcas-22.02/src/dft_util/check_fthaw.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dft_util/check_fthaw.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,102 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine check_Fthaw(iRC) + +use OFembed, only: ThrFThaw +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(inout) :: iRC +#include "warnings.h" +integer(kind=iwp) :: i, iSeed, iter, iter0, Lu +real(kind=wp) :: DEneA, DEneB, E1, E3, EneA, EneB +logical(kind=iwp) :: ok +character(len=16) :: NamRfil +real(kind=wp), allocatable :: Ene(:,:) +integer(kind=iwp), external :: IsFreeUnit + +if (ThrFThaw <= Zero) return + +call f_inquire('AUXRFIL',ok) +if (.not. ok) return + +call Get_NameRun(NamRfil) +call NameRun('AUXRFIL') +call Get_dScalar('Last energy',EneB) +call NameRun(NamRfil) +call Get_dScalar('Last energy',EneA) + +iSeed = 7 +Lu = IsFreeUnit(iSeed) +call f_inquire('FRETHAW',ok) +if (.not. ok) then + call molcas_open(Lu,'FRETHAW') + !open(Lu,file='FRETHAW') + write(Lu,'(I4,2F18.10)') 1,EneA,EneB + close(Lu,status='keep') +else + call molcas_open(Lu,'FRETHAW') + !open(Lu,file='FRETHAW',status='old') + + read(Lu,'(I4,2F18.10)') iter0,E1,E3 + if (iter0 == 1000) then + write(u6,*) ' Error! check_Fthaw: maxIter reached! ' + call Abend() + end if + call mma_allocate(Ene,iter0,4,label='Ene') + Ene(1,1) = E1 + Ene(1,3) = E3 + do i=2,iter0 + read(Lu,'(I4,4F18.10)') iter,Ene(i,1),Ene(i,2),Ene(i,3),Ene(i,4) + end do + + iter = iter0+1 + DEneA = EneA-Ene(iter0,1) + DEneB = EneB-Ene(iter0,3) + + rewind Lu + write(Lu,'(I4,2F18.10)') iter,Ene(1,1),Ene(1,3) + do i=2,iter0 + write(Lu,'(I4,4F18.10)') iter,Ene(i,1),Ene(i,2),Ene(i,3),Ene(i,4) + end do + write(Lu,'(I4,4F18.10)') iter,EneA,DEneA,EneB,DEneB + + write(u6,*) + write(u6,*) '*******************************************************************************' + write(u6,*) '*************** Energy Statistics for Freeze-n-Thaw ***************************' + write(u6,*) '*******************************************************************************' + write(u6,*) ' Energy_A Delta(Energy_A) Energy_B Delta(Energy_B)' + write(u6,'(I3,1X,F18.10,18X,F18.10)') 1,Ene(1,1),Ene(1,3) + do i=2,iter0 + write(u6,'(I3,1X,4F18.10)') i,Ene(i,1),Ene(i,2),Ene(i,3),Ene(i,4) + end do + write(u6,'(I3,1X,4F18.10)') iter,EneA,DEneA,EneB,DEneB + write(u6,*) '*******************************************************************************' + + if ((abs(DEneA) < ThrFThaw) .and. (abs(DEneB) < ThrFThaw)) then + write(u6,'(A,E9.2,A)') ' Convergence reached ! (Thr = ',ThrFThaw,')' + write(u6,*) + iRC = _RC_ALL_IS_WELL_ + close(Lu,status='delete') + else + write(u6,'(A,E9.2,A)') ' Convergence NOT reached yet ! (Thr = ',ThrFThaw,')' + write(u6,*) + close(Lu,status='keep') + end if + call mma_deallocate(Ene) +end if + +return + +end subroutine check_Fthaw diff -Nru openmolcas-22.02/src/dft_util/CMakeLists.txt openmolcas-22.10/src/dft_util/CMakeLists.txt --- openmolcas-22.02/src/dft_util/CMakeLists.txt 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/dft_util/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -9,4 +9,33 @@ # LICENSE or in . * #*********************************************************************** +set (sources + check_fthaw.F90 + cwrap_drvnq.F90 + driver.F90 + drvdft.F90 + drvemb.F90 + fexp.F90 + functionals.F90 + get_denergy.F90 + get_exfac.F90 + ksdft_info.F90 + libxc_parameters.F90 + ndsd_ts.F90 + nucatt.F90 + ofembed.F90 + ofe_print.F90 + overlap.F90 + vemb_exc_states.F90 + vt_lim.F90 + wrap_drvnq.F90 + xlambda.F90 +) + +# Source files defining modules that should be available to other *_util directories +set (modfile_list + ksdft_info.F90 + ofembed.F90 +) + include (${PROJECT_SOURCE_DIR}/cmake/util_template.cmake) diff -Nru openmolcas-22.02/src/dft_util/cwrap_drvnq.F90 openmolcas-22.10/src/dft_util/cwrap_drvnq.F90 --- openmolcas-22.02/src/dft_util/cwrap_drvnq.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dft_util/cwrap_drvnq.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,64 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2010,2012,2017, Francesco Aquilante * +! 2015,2017, Alexander Zech * +!*********************************************************************** + +subroutine cWrap_DrvNQ(KSDFT,nFckDim,Func,D_DS,nh1,nD_DS,Do_Grad,Grad,nGrad,DFTFOCK,F_corr) + +use OFembed, only: Do_Core +use nq_Info, only: Dens_I, Grad_I, mBas, mIrrep, nAsh, nFro, nIsh, Tau_I +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +character(len=*), intent(in) :: KSDFT +integer(kind=iwp), intent(in) :: nFckDim, nh1, nD_DS, nGrad +real(kind=wp), intent(out) :: Func +real(kind=wp), intent(in) :: D_DS(nh1,nD_DS) +logical(kind=iwp), intent(in) :: Do_Grad +real(kind=wp), intent(inout) :: Grad(nGrad), F_corr(nh1,nFckDim) +character(len=4), intent(in) :: DFTFOCK +integer(kind=iwp) :: nOrbA +logical(kind=iwp) :: Do_MO, Do_TwoEl, F_nAsh + +! * +!*********************************************************************** +! * +Func = Zero +Dens_I = Zero +Grad_I = Zero +Tau_I = Zero +Do_MO = .false. +Do_TwoEl = .false. + +call Get_iScalar('nSym',mIrrep) +call Get_iArray('nBas',mBas(0),mIrrep) +call Get_iArray('nFro',nFro(0),mIrrep) +call Get_iArray('nIsh',nIsh(0),mIrrep) +call qpg_dArray('nAsh',F_nAsh,nOrbA) +if ((.not. F_nAsh) .or. (nOrbA == 0)) then + nAsh(0:mIrrep-1) = 0 +else + call Get_iArray('nAsh',nAsh(0),mIrrep) +end if +! * +!*********************************************************************** +! * +Do_Core = .true. +call Driver(KSDFT,Do_Grad,Func,Grad,nGrad,Do_MO,Do_TwoEl,D_DS,F_corr,nh1,nFckDim,DFTFOCK) +Do_Core = .false. +! * +!*********************************************************************** +! * +return + +end subroutine cWrap_DrvNQ diff -Nru openmolcas-22.02/src/dft_util/driver.f90 openmolcas-22.10/src/dft_util/driver.f90 --- openmolcas-22.02/src/dft_util/driver.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/dft_util/driver.f90 1970-01-01 00:00:00.000000000 +0000 @@ -1,233 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -! * -! Copyright (C) 2022, Roland Lindh * -!*********************************************************************** -Subroutine Driver(KSDFA,Do_Grad,Func,Grad,nGrad,Do_MO,Do_TwoEl,D_DS,F_DFT,nh1,nD,DFTFOCK) - -use libxc_parameters -use xc_f03_lib_m -use Functionals, only: Get_Funcs -use OFembed, only: KEOnly, dFMD, Do_Core -use libxc, only: Only_exc -use nq_Grid, only: l_casdft -use nq_pdft, only: lft -use Definitions, only: LibxcInt -use nq_Info -Implicit None -#include "real.fh" -#include "ksdft.fh" -Character*(*) KSDFA -Logical Do_Grad -Integer :: i, j, nGrad, nh1, nD -Real*8 :: Func, Grad(nGrad) -Logical Do_MO, Do_TwoEl -Real*8 :: D_DS(nh1,nD), F_DFT(nh1,nD) -Character*4 DFTFOCK -logical :: LDTF, NDSD -character(LEN=12) :: FLabel -type(xc_f03_func_t) :: func_ -type(xc_f03_func_info_t) :: info_ - -abstract interface - Subroutine DFT_FUNCTIONAL(mGrid,nD) - Integer mGrid, nD - end subroutine -end interface - -!*********************************************************************** -! Define external functions not defined in LibXC. These are either -! accessed through the procedure pointer sub or External_sub. - -procedure(DFT_FUNCTIONAL) :: Overlap, NucAtt, ndsd_ts -!*********************************************************************** -procedure(DFT_FUNCTIONAL), pointer :: sub => null() -! Sometime we need an external routine which covers something which -! Libxc doesn't support. -procedure(DFT_FUNCTIONAL), pointer :: External_sub => null() -! * -!*********************************************************************** -! Global variable for MCPDFT functionals * -FLabel=KSDFA ! The user could be passing an explicit string! Hence, the local copy. - -! -! Set some flags and clean up the label to be just the label of the -! underlaying DFT functional. -! -l_casdft = FLabel(1:2).eq.'T:' .or. FLabel(1:3).eq.'FT:' - -lft = FLabel(1:3).eq.'FT:' - -If (l_casdft) Then - FLabel=FLabel(Index(FLabel,'T:')+2:) - Do_MO=.true. - Do_TwoEl=.true. - If (.NOT.Do_PDFTPOT .and. .Not.DO_Grad) Only_exc=.True. -End If - -If (FLabel(1:5)=='LDTF/')Then - LDTF=.true. - FLabel=FLabel(6:) -Else - LDTF=.false. -End If -If (FLabel(1:5)=='NDSD/')Then - NDSD=.true. - FLabel=FLabel(6:) -Else - NDSD=.false. -End If -! * -!*********************************************************************** -!*********************************************************************** -! * -! Default is to use the libxc interface -! Coefficient for the individual contibutions are defaulted to 1.0D0 - -Sub => libxc_functionals ! Default -Coeffs(:)=1.0D0 ! Default -! * -!*********************************************************************** -! * - Select Case(FLabel) -! * -!*********************************************************************** -! * -! Overlap * -! * - Case('Overlap') - Functional_type=LDA_type - Sub => Overlap -! * -!*********************************************************************** -! * -! NucAtt * -! * - Case('NucAtt') - Functional_type=LDA_type - Sub => NucAtt -! * -!*********************************************************************** -! * -! The names TF_only and HUNTER are hardcoded in some parts of the code,* -! so we define them explicitly instead of relying on the external file * -! * -!*********************************************************************** -! * -! Kinetic only (Thomas-Fermi) * -! * - Case('TF_only') - Functional_type=LDA_type - - nFuncs=1 - func_id(1:nFuncs)=[XC_LDA_K_TF] -! * -!*********************************************************************** -! * -! HUNTER (von Weizsacker KE, no calc of potential) * -! * - Case('HUNTER') - Functional_type=GGA_type - - nFuncs=1 - func_id(1:nFuncs)=[XC_GGA_K_TFVW] - Only_exc=.True. -! * -!*********************************************************************** -! * - Case default - Call Get_Funcs(FLabel) - - End Select -! * -!*********************************************************************** -! * - If (Functional_type/=LDA_type.and.Functional_type/=GGA_type.and.l_CasDFT) Then - Write (6,*) ' MC-PDFT combined with invalid functional class' - Call Abend() - End If -! * -!*********************************************************************** -! * - If (Do_Core) Then - ! Keep only correlation - Do i=1,nFuncs - Call xc_f03_func_init(func_,func_id(i),0_LibxcInt) - info_ = xc_f03_func_get_info(func_) - If (xc_f03_func_info_get_kind(info_) == XC_CORRELATION) Then - Coeffs(i) = Coeffs(i)*dFMD - Else - Coeffs(i) = Zero - End If - Call xc_f03_func_end(func_) - End Do - Else If (LDTF) Then - ! Add TF kinetic with same coeff as exchange - ! and optionally kill everything else - Do i=1,nFuncs - Call xc_f03_func_init(func_,func_id(i),0_LibxcInt) - info_ = xc_f03_func_get_info(func_) - If (xc_f03_func_info_get_kind(info_) == XC_EXCHANGE) Then - If (nFuncs == nFuncs_max) Then - Write (6,*) ' Too many functionals for LDTF' - Call Abend() - End If - func_id(nFuncs+1) = XC_LDA_K_TF - Coeffs(nFuncs+1) = Coeffs(i) - nFuncs = nFuncs+1 - End If - If (KEOnly) Coeffs(i) = Zero - Call xc_f03_func_end(func_) - End Do - Else If (NDSD) Then - ! Add ndsd_ts, and optionally kill everything else - If (KEOnly) Then - Coeffs(:) = Zero - Sub => ndsd_ts - Else - Only_exc=.True. - External_Sub => ndsd_ts - End If - End If - ! Reduce list - j = 0 - Do i=1,nFuncs - If (Coeffs(i) == Zero) Cycle - j = j+1 - If (j == i) Cycle - Coeffs(j) = Coeffs(i) - func_id(j) = func_id(i) - End Do - nFuncs = j -! * -!*********************************************************************** -! * -! Now let's do some integration! -! If the libxc interface is used do the proper initialization and closure. - - If (Associated(Sub,libxc_functionals)) Call Initiate_libxc_functionals(nD) - - Call DrvNQ(Sub,F_DFT,nD,Func,D_DS,nh1,nD, & - & Do_Grad,Grad,nGrad,Do_MO,Do_TwoEl,DFTFOCK) - - If (Associated(Sub,libxc_functionals)) Call Remove_libxc_functionals() - - If (Associated(External_Sub)) Call DrvNQ(External_Sub,F_DFT,nD,Func,D_DS,nh1,nD, & - & Do_Grad,Grad,nGrad,Do_MO,Do_TwoEl,DFTFOCK) - - Sub => Null() - External_Sub => Null() - Only_exc=.False. - LDTF=.False. - NDSD=.False. -! * -!*********************************************************************** -! * - End Subroutine Driver diff -Nru openmolcas-22.02/src/dft_util/driver.F90 openmolcas-22.10/src/dft_util/driver.F90 --- openmolcas-22.02/src/dft_util/driver.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dft_util/driver.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,230 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2022, Roland Lindh * +!*********************************************************************** + +subroutine Driver(KSDFA,Do_Grad,Func,Grad,nGrad,Do_MO,Do_TwoEl,D_DS,F_DFT,nh1,nD,DFTFOCK) + +use libxc_parameters, only: Coeffs, func_id, initiate_libxc_functionals, libxc_functionals, nFuncs, nFuncs_max, & + remove_libxc_functionals +use xc_f03_lib_m, only: XC_CORRELATION, XC_EXCHANGE, xc_f03_func_end, xc_f03_func_get_info, xc_f03_func_info_get_kind, & + xc_f03_func_init, xc_f03_func_t, xc_f03_func_info_t, XC_GGA_K_TFVW, XC_LDA_K_TF, XC_UNPOLARIZED +use Functionals, only: Get_Funcs +use KSDFT_Info, only: Do_PDFTPOT +use OFembed, only: dFMD, Do_Core, KEOnly +use libxc, only: Only_exc +use nq_Grid, only: l_casdft +use nq_Info, only: Functional_type, GGA_Type, LDA_Type +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +character(len=*), intent(in) :: KSDFA +logical(kind=iwp), intent(in) :: Do_Grad +integer(kind=iwp), intent(in) :: nGrad, nh1, nD +real(kind=wp), intent(inout) :: Func, Grad(nGrad), F_DFT(nh1,nD) +logical(kind=iwp), intent(inout) :: Do_MO, Do_TwoEl +real(kind=wp), intent(in) :: D_DS(nh1,nD) +character(len=4), intent(in) :: DFTFOCK +integer(kind=iwp) :: i, j +logical(kind=iwp) :: IsFT, LDTF, NDSD +character(len=80) :: FLabel +type(xc_f03_func_t) :: func_ +type(xc_f03_func_info_t) :: info_ +!*********************************************************************** +! Define external functions not defined in LibXC. These are either +! accessed through the procedure pointer Sub or External_sub. +abstract interface + subroutine DFT_FUNCTIONAL(mGrid,nD) + import :: iwp + integer(kind=iwp), intent(in) :: mGrid, nD + end subroutine +end interface +procedure(DFT_FUNCTIONAL) :: Overlap, NucAtt, ndsd_ts +procedure(DFT_FUNCTIONAL), pointer :: Sub, External_sub +!*********************************************************************** + +! * +!*********************************************************************** +! Global variable for MCPDFT functionals * +FLabel = KSDFA ! The user could be passing an explicit string! Hence, the local copy. + +! Set some flags and clean up the label to be just the label of the +! underlaying DFT functional. + +l_casdft = (FLabel(1:2) == 'T:') .or. (FLabel(1:3) == 'FT:') + +IsFT = FLabel(1:3) == 'FT:' + +if (l_casdft) then + FLabel = FLabel(index(FLabel,'T:')+2:) + Do_MO = .true. + Do_TwoEl = .true. + if ((.not. Do_PDFTPOT) .and. (.not. DO_Grad)) Only_exc = .true. +end if + +if (FLabel(1:5) == 'LDTF/') then + LDTF = .true. + FLabel = FLabel(6:) +else + LDTF = .false. +end if +if (FLabel(1:5) == 'NDSD/') then + NDSD = .true. + FLabel = FLabel(6:) +else + NDSD = .false. +end if +! * +!*********************************************************************** +!*********************************************************************** +! * +! Default is to use the libxc interface +! Coefficient for the individual contibutions are defaulted to 1.0 + +Sub => libxc_functionals ! Default +External_Sub => null() ! Default +Coeffs(:) = One ! Default +! * +!*********************************************************************** +! * +select case (FLabel) +! * +!*********************************************************************** +! * +! Overlap + + case ('Overlap') + Functional_type = LDA_type + Sub => Overlap +! * +!*********************************************************************** +! * +! NucAtt + + case ('NucAtt') + Functional_type = LDA_type + Sub => NucAtt +! * +!*********************************************************************** +! * +! The names TF_only and HUNTER are hardcoded in some parts of the code,* +! so we define them explicitly instead of relying on the external file * +! * +!*********************************************************************** +! * +! Kinetic only (Thomas-Fermi) + + case ('TF_only') + Functional_type = LDA_type + + nFuncs = 1 + func_id(1:nFuncs) = [XC_LDA_K_TF] +! * +!*********************************************************************** +! * +! HUNTER (von Weizsacker KE, no calc of potential) + + case ('HUNTER') + Functional_type = GGA_type + + nFuncs = 1 + func_id(1:nFuncs) = [XC_GGA_K_TFVW] + Only_exc = .true. +! * +!*********************************************************************** +! * + case default + call Get_Funcs(FLabel) + +end select +! * +!*********************************************************************** +! * +if ((Functional_type /= LDA_type) .and. (Functional_type /= GGA_type) .and. l_CasDFT) then + write(u6,*) ' MC-PDFT combined with invalid functional class' + call Abend() +end if +! * +!*********************************************************************** +! * +if (Do_Core) then + ! Keep only correlation + do i=1,nFuncs + call xc_f03_func_init(func_,func_id(i),XC_UNPOLARIZED) + info_ = xc_f03_func_get_info(func_) + if (xc_f03_func_info_get_kind(info_) == XC_CORRELATION) then + Coeffs(i) = Coeffs(i)*dFMD + else + Coeffs(i) = Zero + end if + call xc_f03_func_end(func_) + end do +else if (LDTF) then + ! Add TF kinetic with same coeff as exchange + ! and optionally kill everything else + do i=1,nFuncs + call xc_f03_func_init(func_,func_id(i),XC_UNPOLARIZED) + info_ = xc_f03_func_get_info(func_) + if (xc_f03_func_info_get_kind(info_) == XC_EXCHANGE) then + if (nFuncs == nFuncs_max) then + write(u6,*) ' Too many functionals for LDTF' + call Abend() + end if + func_id(nFuncs+1) = XC_LDA_K_TF + Coeffs(nFuncs+1) = Coeffs(i) + nFuncs = nFuncs+1 + end if + if (KEOnly) Coeffs(i) = Zero + call xc_f03_func_end(func_) + end do +else if (NDSD) then + ! Add ndsd_ts, and optionally kill everything else + if (KEOnly) then + Coeffs(:) = Zero + Sub => ndsd_ts + else + Only_exc = .true. + External_Sub => ndsd_ts + end if +end if +! Reduce list +j = 0 +do i=1,nFuncs + if (Coeffs(i) == Zero) cycle + j = j+1 + if (j == i) cycle + Coeffs(j) = Coeffs(i) + func_id(j) = func_id(i) +end do +nFuncs = j +! * +!*********************************************************************** +! * +! Now let's do some integration! +! If the libxc interface is used do the proper initialization and closure. + +if (associated(Sub,libxc_functionals)) call Initiate_libxc_functionals(nD) + +call DrvNQ(Sub,F_DFT,nD,Func,D_DS,nh1,nD,Do_Grad,Grad,nGrad,Do_MO,Do_TwoEl,DFTFOCK,IsFT) + +if (associated(Sub,libxc_functionals)) call Remove_libxc_functionals() + +if (associated(External_Sub)) call DrvNQ(External_Sub,F_DFT,nD,Func,D_DS,nh1,nD,Do_Grad,Grad,nGrad,Do_MO,Do_TwoEl,DFTFOCK,IsFT) + +Only_exc = .false. +LDTF = .false. +NDSD = .false. +! * +!*********************************************************************** +! * + +end subroutine Driver diff -Nru openmolcas-22.02/src/dft_util/drvdft.f openmolcas-22.10/src/dft_util/drvdft.f --- openmolcas-22.02/src/dft_util/drvdft.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/dft_util/drvdft.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,208 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2022, Roland Lindh * -************************************************************************ - Subroutine DrvDFT(h1,TwoHam,D,RepNuc,nh1,First,Dff, - & lRF,KSDFT,ExFac,Do_Grad,Grad,nGrad,iSpin, - & D1I,D1A,nD1,DFTFOCK) - use KSDFT_Info, only: KSDFA, funcaa, funcbb, funccc - use nq_Info - Implicit Real*8 (a-h,o-z) -#include "real.fh" -#include "stdalloc.fh" -#include "debug.fh" -#include "pamint.fh" -#include "ksdft.fh" - Real*8 h1(nh1), TwoHam(nh1), D(nh1,2), Grad(nGrad), Vxc_ref(2) - Real*8 D1I(nD1),D1A(nD1) - Logical First, Dff, lRF, Do_Grad - Logical Do_MO,Do_TwoEl - Character*(*) KSDFT - Character*4 DFTFOCK - Real*8, Allocatable:: D_DS(:,:), F_DFT(:,:) -* * -************************************************************************ -* * - KSDFA = KSDFT ! Store a local copy - Debug=.False. -* * -************************************************************************ -* * - Call Put_iScalar('Multiplicity',iSpin) - Call Get_iScalar('nSym',mIrrep) - Call Get_iArray('nBas',mBas,mIrrep) -* - Call Set_Basis_Mode('Valence') - Call Setup_iSD() -* * - Call Get_dScalar('DFT exch coeff',CoefX) - Call Get_dScalar('DFT corr coeff',CoefR) -* -************************************************************************ -* * - If (Do_Grad) Call FZero(Grad,nGrad) -* * -************************************************************************ -* * - If (iSpin.eq.1) Then - nD=1 - Else - nD=2 - End If -* -* What is this? -* - If (DFTFOCK.eq.'ROKS') nD=2 - Call mma_allocate(D_DS,nh1,nD,Label='D_DS') -* -*---- Get the total density -* - Call Get_D1ao(D_DS,nh1) -* Call RecPrt('D1ao',' ',D_DS(:,1),nh1,1) -* -* -*---- Get the spin density -* - If (nD.ne.1) Then - Call Get_D1Sao(D_DS(:,2),nh1) -* Call RecPrt('D1Sao',' ',D_DS(:,2),nh1,1) - End If -* -*---- Compute alpha and beta densities -* -* Call RecPrt('DTot',' ',D_DS(:,1),nh1,1) -* Call RecPrt('DSpn',' ',D_DS(:,2),nh1,1) - If (nD.eq.1) Then - D_DS(:,1)=Half*D_DS(:,1) - Else - Do i = 1, nh1 - DTot=D_DS(i,1) - DSpn=D_DS(i,2) - d_Alpha=Half*(DTot+DSpn) - d_Beta =Half*(DTot-DSpn) - D_DS(i,1)=d_Alpha - D_DS(i,2)=d_Beta - End Do - End If -* Call RecPrt('Da',' ',D_DS(:,1),nh1,1) -* Call RecPrt('Db',' ',D_DS(:,2),nh1,1) -* - If(KSDFT(1:3).ne.'SCF') Then - Call Get_iArray('nIsh',nIsh,mIrrep) - Call Get_iArray('nFro',nFro,mIrrep) - End If -* * -************************************************************************ -* * -* DFT functionals, compute integrals over the potential -* - Func =Zero - Funcaa =Zero - Funcbb =Zero - Funccc =Zero - Dens_I =Zero - Dens_a1 =Zero - Dens_b1 =Zero - Dens_a2 =Zero - Dens_b2 =Zero - Dens_t1 =Zero - Dens_t2 =Zero - Grad_I =Zero - Tau_I =Zero - Do_MO =.False. - Do_TwoEl =.False. -* -* nFckDim: number of different types of Fock matrices. Normally for -* conventional functionals we have one Fock matrix for closed shell -* calculations and two (F_alpha and F_beta) for open shell systems. -* For CASDFT we have always two (F_inactive and F_active) -* - nFckDim = nD - Call mma_allocate(F_DFT,nh1,nFckDim,Label='F_DFT') - F_DFT(:,:)=Zero -* * -************************************************************************ -* * - Call Driver(KSDFA,Do_Grad,Func,Grad,nGrad, - & Do_MO,Do_TwoEl,D_DS,F_DFT,nh1,nD,DFTFOCK) -* * -************************************************************************ -* * - ExFac=Get_ExFac(KSDFT) -* * -************************************************************************ -* * - Energy_integrated=Func -* * -************************************************************************ -* * - If (KSDFT.eq.'Overlap'.or.KSDFT.eq.'NucAtt') Then - call dcopy_(nh1,F_DFT,1,h1,1) - If (KSDFT.eq.'NucAtt') Energy_integrated=Func - Else -* -* Put out the integrated DFT energy and the DFT Fock matrices -* on the RUNFILE -* -* Call Put_DFT_Energy(Energy_integrated) - Call Poke_dScalar('KSDFT energy',Energy_integrated) - Call Put_dScalar('CASDFT energy',Energy_integrated) - Call Put_dExcdRa(F_DFT,nFckDim*nh1) -* Write(6,'(a,f22.16)') " Energy in drvdft ",Energy_integrated -#ifdef _DEBUGPRINT_ - Write(6,'(a,f22.16)') " Energy ",Energy_integrated - If (nFckDim.eq.1) Then - Do i=1,nh1 - Write(6,'(i4,f22.16)') i,F_DFT(i,1) - End Do - Else - Do i=1,nh1 - Write(6,'(i4,3f22.16)') i,F_DFT(i,1), - & F_DFT(i,2), - & F_DFT(i,1)+F_DFT(i,2)/2.0d0 - End Do - End If -#endif - -* -* In the SCF program (traclc.f) the program computes the trace -* of the one-electron hamiltonian over a set of densities. The -* DFT contribution is not linear with respect to variations of -* the density. However, with the following term we can include -* the linear component in that code. -* - Fact = Two - If (nD.ne.1) Fact=One - Vxc_ref(1)=Fact*DDot_(nh1,F_DFT(:,1),1,D_DS,1) - If (nD.ne.1) Then - Vxc_ref(2)=DDot_(nh1,F_DFT(:,2),1,D_DS(:,2),1) - Else - Vxc_ref(2)=Zero - End If - Call Put_Temp('Vxc_ref ',Vxc_ref,2) - End If -* - Call mma_deallocate(F_DFT) - Call mma_deallocate(D_DS) - Call Free_iSD() - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(TwoHam) - Call Unused_real_array(D) - Call Unused_real(RepNuc) - Call Unused_logical(First) - Call Unused_logical(Dff) - Call Unused_logical(lRF) - Call Unused_real_array(D1I) - Call Unused_real_array(D1A) - End If - End diff -Nru openmolcas-22.02/src/dft_util/drvdft.F90 openmolcas-22.10/src/dft_util/drvdft.F90 --- openmolcas-22.02/src/dft_util/drvdft.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dft_util/drvdft.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,214 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2022, Roland Lindh * +!*********************************************************************** + +subroutine DrvDFT(h1,nh1,KSDFT,ExFac,Do_Grad,Grad,nGrad,iSpin,DFTFOCK) + +use KSDFT_Info, only: CoefR, CoefX, Funcaa, Funcbb, Funccc, KSDFA +use nq_Info, only: Dens_a1, Dens_a2, Dens_b1, Dens_b2, Dens_I, Dens_t1, Dens_t2, Energy_integrated, Grad_I, mBas, mIrrep, nFro, & + nIsh, Tau_I +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Half +use Definitions, only: wp, iwp, u6, r8 + +implicit none +integer(kind=iwp), intent(in) :: nh1, nGrad, iSpin +real(kind=wp), intent(inout) :: h1(nh1), Grad(nGrad) +character(len=*), intent(in) :: KSDFT +real(kind=wp), intent(out) :: ExFac +logical(kind=iwp), intent(in) :: Do_Grad +character(len=4), intent(in) :: DFTFOCK +#include "debug.fh" +integer(kind=iwp) :: i, nD, nFckDim +real(kind=wp) :: d_Alpha, d_Beta, DSpn, DTot, Fact, Func, PDFT_Ratio, Vxc_ref(2), WF_Ratio +logical(kind=iwp) :: Do_HPDFT, Do_MO, Do_TwoEl +real(kind=wp), allocatable :: D_DS(:,:), F_DFT(:,:) +real(kind=wp), external :: Get_ExFac +real(kind=r8), external :: DDot_ + +! * +!*********************************************************************** +! * +KSDFA = KSDFT ! Store a local copy +Debug = .false. +! * +!*********************************************************************** +! * +call Put_iScalar('Multiplicity',iSpin) +call Get_iScalar('nSym',mIrrep) +call Get_iArray('nBas',mBas,mIrrep) + +call Set_Basis_Mode('Valence') +call Setup_iSD() + +call Get_dScalar('DFT exch coeff',CoefX) +call Get_dScalar('DFT corr coeff',CoefR) +! * +!*********************************************************************** +! * +if (Do_Grad) Grad(:) = Zero +! * +!*********************************************************************** +! * +if (iSpin == 1) then + nD = 1 +else + nD = 2 +end if + +! What is this? + +if (DFTFOCK == 'ROKS') nD = 2 +call mma_allocate(D_DS,nh1,nD,Label='D_DS') + +! Get the total density + +call Get_D1ao(D_DS,nh1) +!call RecPrt('D1ao',' ',D_DS(:,1),nh1,1) + +! Get the spin density + +if (nD /= 1) then + call Get_D1Sao(D_DS(:,2),nh1) + !call RecPrt('D1Sao',' ',D_DS(:,2),nh1,1) +end if + +! Compute alpha and beta densities + +!call RecPrt('DTot',' ',D_DS(:,1),nh1,1) +!call RecPrt('DSpn',' ',D_DS(:,2),nh1,1) +if (nD == 1) then + D_DS(:,1) = Half*D_DS(:,1) +else + do i=1,nh1 + DTot = D_DS(i,1) + DSpn = D_DS(i,2) + d_Alpha = Half*(DTot+DSpn) + d_Beta = Half*(DTot-DSpn) + D_DS(i,1) = d_Alpha + D_DS(i,2) = d_Beta + end do +end if +!call RecPrt('Da',' ',D_DS(:,1),nh1,1) +!call RecPrt('Db',' ',D_DS(:,2),nh1,1) + +if (KSDFT(1:3) /= 'SCF') then + call Get_iArray('nIsh',nIsh,mIrrep) + call Get_iArray('nFro',nFro,mIrrep) +end if +! * +!*********************************************************************** +! * +! DFT functionals, compute integrals over the potential + +Func = Zero +Funcaa = Zero +Funcbb = Zero +Funccc = Zero +Dens_I = Zero +Dens_a1 = Zero +Dens_b1 = Zero +Dens_a2 = Zero +Dens_b2 = Zero +Dens_t1 = Zero +Dens_t2 = Zero +Grad_I = Zero +Tau_I = Zero +Do_MO = .false. +Do_TwoEl = .false. + +! nFckDim: number of different types of Fock matrices. Normally for +! conventional functionals we have one Fock matrix for closed shell +! calculations and two (F_alpha and F_beta) for open shell systems. +! For CASDFT we have always two (F_inactive and F_active) + +nFckDim = nD +call mma_allocate(F_DFT,nh1,nFckDim,Label='F_DFT') +F_DFT(:,:) = Zero +! * +!*********************************************************************** +! * +call Driver(KSDFA,Do_Grad,Func,Grad,nGrad,Do_MO,Do_TwoEl,D_DS,F_DFT,nh1,nD,DFTFOCK) +! * +!*********************************************************************** +! * +if (Do_Grad) then + Do_HPDFT = .false. + call qpg_DScalar('R_WF_HMC',Do_HPDFT) + if (Do_HPDFT) then + write(u6,*) 'DFT gradient is scaled in a hybrid formalism.' + call Get_DScalar('R_WF_HMC',WF_Ratio) + PDFT_Ratio = One-WF_Ratio + Grad(:) = PDFT_Ratio*Grad + end if +end if + +! * +!*********************************************************************** +! * +ExFac = Get_ExFac(KSDFT) +! * +!*********************************************************************** +! * +Energy_integrated = Func +! * +!*********************************************************************** +! * +if ((KSDFT == 'Overlap') .or. (KSDFT == 'NucAtt')) then + h1(:) = F_DFT(:,1) + if (KSDFT == 'NucAtt') Energy_integrated = Func +else + + ! Put out the integrated DFT energy and the DFT Fock matrices on the RUNFILE + + !call Put_DFT_Energy(Energy_integrated) + call Poke_dScalar('KSDFT energy',Energy_integrated) + call Put_dScalar('CASDFT energy',Energy_integrated) + call Put_dExcdRa(F_DFT,nFckDim*nh1) + !write(u6,'(a,f22.16)') ' Energy in drvdft ',Energy_integrated +# ifdef _DEBUGPRINT_ + write(u6,'(a,f22.16)') ' Energy ',Energy_integrated + if (nFckDim == 1) then + do i=1,nh1 + write(u6,'(i4,f22.16)') i,F_DFT(i,1) + end do + else + do i=1,nh1 + write(u6,'(i4,3f22.16)') i,F_DFT(i,1),F_DFT(i,2),Half*(F_DFT(i,1)+F_DFT(i,2)) + end do + end if +# endif + + ! In the SCF program (traclc.f) the program computes the trace + ! of the one-electron hamiltonian over a set of densities. The + ! DFT contribution is not linear with respect to variations of + ! the density. However, with the following term we can include + ! the linear component in that code. + + Fact = Two + if (nD /= 1) Fact = One + Vxc_ref(1) = Fact*DDot_(nh1,F_DFT(:,1),1,D_DS,1) + if (nD /= 1) then + Vxc_ref(2) = DDot_(nh1,F_DFT(:,2),1,D_DS(:,2),1) + else + Vxc_ref(2) = Zero + end if + call Put_Temp('Vxc_ref ',Vxc_ref,2) +end if + +call mma_deallocate(F_DFT) +call mma_deallocate(D_DS) +call Free_iSD() + +return + +end subroutine DrvDFT diff -Nru openmolcas-22.02/src/dft_util/drvemb.f openmolcas-22.10/src/dft_util/drvemb.f --- openmolcas-22.02/src/dft_util/drvemb.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/dft_util/drvemb.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,658 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2010,2012,2017, Francesco Aquilante * -* 2015,2017, Alexander Zech * -************************************************************************ - Subroutine DrvEMB(h1,D,RepNuc,nh1, - & KSDFT,ExFac,Do_Grad,Grad,nGrad, - & D1I,D1A,nD1,DFTFOCK) -************************************************************************ -************************************************************************ -*** Orbital-Free Embedding calculation *** -*** *** -*** Method: *** -*** T. A. Wesolowski, A. Warshel, J. Phys. Chem. 97 (1993) 8050. *** -*** *** -*** NDSD potential: *** -*** J.-M. Garcia Lastra, J. W. Kaminski, T. A. Wesolowski, *** -*** J. Chem. Phys. 129 (2008) 074107. *** -*** *** -*** Embedding multi-determinantal wfs: *** -*** T. A. Wesolowski, Phys. Rev.A. 77 (2008) 012504. *** -*** *** -*** *** -*** Embedding Hartree-Fock wf: *** -*** F. Aquilante, T. A. Wesolowski *** -*** J. Chem. Phys. 135 (2011) 084120. *** -*** *** -*** *** -*** Author: F. Aquilante, Geneva July 2010 *** -*** *** -*** (last update: Feb 2012) *** -*** *** -************************************************************************ -************************************************************************ - use OFembed, only: OFE_first, Xsigma, dFMD - use OFembed, only: Func_AB,Func_A,Func_B,Energy_NAD, - & V_Nuc_AB,V_Nuc_BA,V_emb - Implicit Real*8 (a-h,o-z) - External LSDA_emb -#include "real.fh" -#include "stdalloc.fh" -#include "debug.fh" - Real*8 h1(nh1), D(nh1,2), Grad(nGrad) - Real*8 D1I(nD1),D1A(nD1) - Logical Do_Grad - Character*(*) KSDFT - Character*4 DFTFOCK - Character*16 NamRfil - Real*8 Vxc_ref(2) -* -* Real*8 Func_A_TF, Func_B_TF, Func_AB_TF, TF_NAD - Real*8 Func_A_TF, Func_B_TF - Logical is_rhoA_on_file - Real*8 Xlambda - External Xlambda -* - Real*8, Allocatable:: D_DS(:,:), F_DFT(:,:), Fcorr(:,:), TmpA(:) -#ifdef _NOT_USED_ - Real*8, Allocatable:: Vemb(:), D1ao_x(:) -#endif -* - Debug=.False. - is_rhoA_on_file = .False. -* * -************************************************************************ -* * - Call Setup_iSD() - If (Do_Grad) Call FZero(Grad,nGrad) -* * -************************************************************************ -* * -#ifdef _NOT_USED_ -* --- Section to calculate Nonelectr. V_emb with current density -* Temporarily turned off (clean output) - If (.not.OFE_first) then - Call mma_allocate(D1ao_y,nh1) - Call Get_NameRun(NamRfil) ! save the old RUNFILE name - Call NameRun('AUXRFIL') ! switch RUNFILE name - Call mma_allocate(Vemb,nh1,label='Vemb') - Call Get_dArray('dExcdRa', Vemb, nh1) - Call mma_allocate(TmpA,nh1,Label='TmpA') - Call Get_dArray('Nuc Potential',TmpA,nh1) -* Substract V_nuc_B - Call daxpy_(nh1,-One,TmpA,1,Vemb,1) -* Calculate nonelectr. V_emb with current Density - Ynorm=dDot_(nh1,WD1ao_y,1,D1ao_y,1) - V_emb_x=dDot_(nh1,Vemb,1,D1ao_y,1) - Write (6,'(A,F19.10,4X,A,F10.5)') - & 'Nonelectr. Vemb w. current density: ', V_emb_x, - & 'Y_Norm = ', Ynorm - Call mma_deallocate(D1ao_y) -* Get rho_A_ref - Call NameRun('PRERFIL') - Call mma_allocate(D1ao_x,nDens,Label='D1ao_x') - Call get_dArray('D1ao',ipD1ao_x,nDens) - Xnorm=dDot_(nh1,D1ao_x,1,D1ao_x,1) - V_emb_x_ref=dDot_(nh1,Vemb,1,pD1ao_x,1) - Write (6,'(A,F19.10,4X,A,F10.5)') - & 'Nonelectr. Vemb w. ref. density: ', V_emb_x_ref, - & 'X_Norm = ', Xnorm - Call VEMB_Exc_states(Vemb,nh1,KSDFT,Func_B) - Call mma_deallocate(TmpA) - Call mma_deallocate(D1ao_x) - Call mma_dealloacte(Vemb) - Call NameRun(NamRfil) ! switch back to RUNFILE - End If -* --- Section End -#endif - Call f_Inquire('PRERFIL',is_rhoA_on_file) ! rho_A from file - If (is_rhoA_on_file .and. .not.OFE_first) Return ! Vemb on disk - - - -************************************************************************ -* * -* Setup of density matrices for subsys B (environment) * -* * -************************************************************************ - Call Get_NameRun(NamRfil) ! save the old RUNFILE name - Call NameRun('AUXRFIL') ! switch RUNFILE name -* * -************************************************************************ -* * - nD=4 - Call mma_allocate(F_DFT,nh1,nD,Label='F_DFT') - Call mma_allocate(D_DS,nh1,nD,Label='D_DS') - Vxc_ref(1)=Zero - Vxc_ref(2)=Zero -* -*---- Get the density matrix of the environment (rho_B) -* - Call Get_iScalar('Multiplicity',kSpin) - Call Get_D1ao(D_DS(:,1),nh1) -* Call RecPrt('D1ao',' ',D_DS(:,1),nh1,1) -* -*---- Get the spin density matrix of the environment -* - If (kSpin.ne.1) Then - Call Get_D1Sao(D_DS(:,2),nh1) -* Call RecPrt('D1Sao',' ',D_DS(:,2),nh1,1) - End If -* -*---- Compute alpha and beta density matrices of the environment -* - nFckDim=2 - If (kSpin.eq.1) Then - call dscal_(nh1,Half,D_DS(:,1),1) - call dcopy_(nh1,D_DS(:,1),1,D_DS(:,2),1) - nFckDim=1 - Else - Do i = 1, nh1 - DTot=D_DS(i,1) - DSpn=D_DS(i,2) - d_Alpha=Half*(DTot+DSpn) - d_Beta =Half*(DTot-DSpn) - D_DS(i,1)=d_Alpha - D_DS(i,2)=d_Beta - End Do -* Call RecPrt('Da',' ',D_DS(:,1),nh1,1) -* Call RecPrt('Db',' ',D_DS(:,2),nh1,1) - End If -* -* If (OFE_first) Then -*---AZECH 10/2015 -* kinetic part of E_xct, Subsys B - Func_B_TF = 0.0d0 - Call wrap_DrvNQ('TF_only',F_DFT(:,1:nFckDim),nFckDim,Func_B_TF, - & D_DS(:,1:nFckDim),nh1,nFckDim, - & Do_Grad, - & Grad,nGrad,DFTFOCK) -*--- - If (OFE_first) Then - - Call wrap_DrvNQ(KSDFT,F_DFT(:,1:nFckDim),nFckDim,Func_B, - & D_DS(:,1:nFckDim),nh1,nFckDim, - & Do_Grad, - & Grad,nGrad,DFTFOCK) - -#ifdef _NOT_USED_ - If (KSDFT(1:4).eq.'NDSD') Then - l_NDSD=nFckDim*nh1 - Call GetMem('NDSD','Allo','Real',ip_NDSD,l_NDSD) - call dcopy_(l_NDSD,F_DFT(:,1:nFckDim),1,Work(ip_NDSD),1) - KSDFT(1:4)='LDTF' !set to Thomas-Fermi for subsequent calls - EndIf -#endif - - EndIf -* * -************************************************************************ -* * -* Setup of density matrices for subsys A * -* * -************************************************************************ - Call NameRun(NamRfil) ! switch back RUNFILE name -* - If (is_rhoA_on_file) Call NameRun('PRERFIL') -*---- Get the density matrix for rho_A -* - Call Get_D1ao(D_DS(:,3),nh1) -* Call RecPrt('D1ao',' ',D_DS(:,3),nh1,1) -* - Call Get_iScalar('Multiplicity',iSpin) - If (iSpin.eq.1 .and. kSpin.ne.1 .and. OFE_first) Then - Call WarningMessage(0, - & ' Non-singlet environment perturbation on singlet state!'// - & ' Spin-components of the OFE potential will be averaged. ' ) - EndIf -* -*---- Get the spin density matrix of A -* - If (iSpin.ne.1) Then - Call Get_D1Sao(D_DS(:,4),nh1) -* Call RecPrt('D1Sao',' ',D_DS(:,4),nh1,1) - End If -* -*---- Compute alpha and beta density matrices of subsystem A -* - nFckDim=2 - If (iSpin.eq.1) Then - call dscal_(nh1,Half,D_DS(:,3),1) - call dcopy_(nh1,D_DS(:,3),1,D_DS(:,4),1) - If (kSpin.eq.1) nFckDim=1 - Else - Do i = 1, nh1 - DTot=D_DS(i,3) - DSpn=D_DS(i,4) - d_Alpha=Half*(DTot+DSpn) - d_Beta =Half*(DTot-DSpn) - D_DS(i,3)=d_Alpha - D_DS(i,4)=d_Beta - End Do -* Call RecPrt('Da',' ',D_DS(:,3),nh1,1) -* Call RecPrt('Db',' ',D_DS(:,4),nh1,1) - End If -* -*---AZECH 10/2015 -* kinetic part of E_xct, Subsys A - Call wrap_DrvNQ('TF_only',F_DFT(:,3:nFckDim+2),nFckDim,Func_A_TF, - & D_DS(:,3:nFckDim+2),nh1,nFckDim, - & Do_Grad, - & Grad,nGrad,DFTFOCK) -*--- - Call wrap_DrvNQ(KSDFT,F_DFT(:,3:nFckDim+2),nFckDim,Func_A, - & D_DS(:,3:nFckDim+2),nh1,nFckDim, - & Do_Grad, - & Grad,nGrad,DFTFOCK) -* -* Fraction of correlation potential from A (cases: HF or Trunc. CI) -* - If (dFMD.gt.0.0d0) Then -* - Call mma_Allocate(Fcorr,nh1,nFckDim,Label='Fcorr') -* - Call cwrap_DrvNQ(KSDFT,F_DFT(:,3:nFckDim+2),nFckDim,Ec_A, - & D_DS(:,3:nFckDim+2),nh1,nFckDim, - & Do_Grad, - & Grad,nGrad,DFTFOCK,Fcorr(:,1:nFckDim)) - End If -* -* -************************************************************************ -* * -* Calculation on the supermolecule * -* * -************************************************************************ - nFckDim=2 - If (iSpin.eq.1 .and. kSpin.eq.1) Then - nFckDim=1 - Call daxpy_(nh1,One,D_DS(:,3),1,D_DS(:,1),1) - Else - Call daxpy_(nh1,One,D_DS(:,3),1,D_DS(:,1),1) - Call daxpy_(nh1,One,D_DS(:,4),1,D_DS(:,2),1) - EndIf -#ifdef _NOT_USED_ -*---AZECH 10/2015 -* kinetic part of E_xct, Subsys A+B -* temporarily turned off to clean output - If (.False.) Then - Func_AB_TF = 0.0d0 - Call wrap_DrvNQ('TF_only',F_DFT(:,1:nFckDim),nFckDim,Func_AB_TF, - & D_DS(:,1:nFckDim),nh1,nFckDim, - & Do_Grad, - & Grad,nGrad,DFTFOCK) - TF_NAD = Func_AB_TF - Func_A_TF - Func_B_TF - Write(6,*) 'kinetic part of E_xc,T (Thomas-Fermi ONLY)' - Write(6,'(A,F19.10)') 'Ts(A+B): ', Func_AB_TF - Write(6,'(A,F19.10)') 'Ts(A): ', Func_A_TF - Write(6,'(A,F19.10)') 'Ts(B): ', Func_B_TF - Write(6,'(A,F19.10)') '-------------------' - Write(6,'(A,F19.10)') 'Ts_NAD: ', TF_NAD -* calculate v_T, Subsys A+B - Xint_Ts_AB=dDot_(nh1,F_DFT(:,1),1,D_DS(:,3),1) - Xint_Ts_NAD = Xint_Ts_AB - Xint_Ts_A -* scale by 2 because wrapper only handles spin-densities - Xint_Ts_NAD = Two*Xint_Ts_NAD - Write(6,*) 'integrated v_Ts_NAD (Thomas-Fermi) with rhoA current' - Write(6,'(A,F19.10)') 'Ts(A+B)_integral: ', Xint_Ts_AB - Write(6,'(A,F19.10)') 'Ts(A)_integral: ', Xint_Ts_A - Write(6,'(A,F19.10)') '-------------------' - Write(6,'(A,F19.10)') 'Ts_NAD_integral: ', Xint_Ts_NAD - EndIf -#endif -*--- - Call wrap_DrvNQ(KSDFT,F_DFT(:,1:nFckDim),nFckDim,Func_AB, - & D_DS(:,1:nFckDim),nh1,nFckDim, - & Do_Grad, - & Grad,nGrad,DFTFOCK) - - Energy_NAD = Func_AB - Func_A - Func_B -* -*---AZECH 10/2015 -* exchange-correlation part of E_xct, Subsys A+B -* temporarily turned off to clean output -c Write(6,*) 'E_xc_NAD (determined with Thomas-Fermi)' -c Func_xc_NAD = Energy_NAD - TF_NAD -c Write(6,'(A,F19.10)') 'E_xc_NAD: ', Func_xc_NAD -*--- - If (dFMD.gt.0.0d0) Then - Call Get_electrons(xElAB) - Fakt_ = -1.0d0*Xlambda(abs(Energy_NAD)/xElAB,Xsigma) - Call daxpy_(nh1*nFckDim,Fakt_,Fcorr(:,1:nFckDim),1, - & F_DFT(:,3:nFckDim+2),1) - Call mma_deallocate(Fcorr) -#ifdef _DEBUGPRINT_ - write(6,*) ' lambda(E_nad) = ',dFMD*Fakt_ -#endif - EndIf - -* * -************************************************************************ -* * -* Non Additive (NAD) potential: F(AB)-F(A) - Do i=1,nFckDim - Call daxpy_(nh1,-One,F_DFT(:,2+i),1,F_DFT(:,i),1) - End Do -#ifdef _NOT_USED_ -* -* NDSD potential for T_nad: add the (B)-dependent term - iFickB=ip_NDSD - Do i=1,nFckDim*Min(1,l_NDSD) - Call daxpy_(nh1,One,Work(iFickB),1,F_DFT(:,i),1) - If (kSpin.ne.1) iFickB=iFickB+nh1 - End Do -#endif -* -* Add the Nuc Attr potential (from subsystem B) and then -* put out the DFT Fock matrices from the (NAD) embedding potential -* on the runfile (AUXRFIL). Note that the classical Coulomb -* interaction potential from subsystem B is computed in the std -* Fock matrix builders -* - Call NameRun('AUXRFIL') ! switch RUNFILE name -* - Call mma_allocate(TmpA,nh1,Label='TmpA') - Call Get_dArray('Nuc Potential',TmpA,nh1) -* - Fact = Two ! because Dmat has been scaled by half - If (kSpin.ne.1) Fact=One - Fact_=Fact -* - V_emb=Fact*dDot_(nh1,F_DFT(:,1),1,D_DS(:,3),1) - V_Nuc_AB=Fact*dDot_(nh1,TmpA,1,D_DS(:,3),1) - If (kSpin.ne.1) Then - V_emb=V_emb+Fact*dDot_(nh1,F_DFT(:,2),1,D_DS(:,4),1) - V_Nuc_AB=V_Nuc_AB+Fact*dDot_(nh1,TmpA,1,D_DS(:,4),1) - EndIf -* -* Averaging the spin-components of F(AB) iff non-spol(A)//spol(B) - If (iSpin.eq.1 .and. kSpin.ne.1) Then - Do i=1,nh1 - tmp=Half*(F_DFT(i,1)+F_DFT(i,2)) - F_DFT(i,1)=tmp - End Do - nFckDim=1 ! reset stuff as if A+B had been spin compensated - Fact=Two - EndIf -* - Do i=1,nFckDim - Call daxpy_(nh1,1.0d0,TmpA,1,F_DFT(:,i),1) - Vxc_ref(i)=Fact*dDot_(nh1,F_DFT(:,i),1,D_DS(:,i+2),1) - End Do -* - If(dFMD.gt.0.0d0) Call Put_dScalar('KSDFT energy',Ec_A) - Call Put_dArray('Vxc_ref ',Vxc_ref,2) -* - Call Put_dArray('dExcdRa',F_DFT(:,1:nFckDim),nh1*nFckDim) - Call NameRun(NamRfil) ! switch back RUNFILE name - - Call Get_dArray('Nuc Potential',TmpA,nh1) - V_Nuc_BA= Fact_*( dDot_(nh1,TmpA,1,D_DS(:,1),1) - & -dDot_(nh1,TmpA,1,D_DS(:,3),1)) - If (kSpin.ne.1) Then - V_Nuc_BA=V_Nuc_BA+Fact_*( dDot_(nh1,TmpA,1,D_DS(:,2),1) - & -dDot_(nh1,TmpA,1,D_DS(:,4),1) ) - EndIf -* - Call mma_deallocate(TmpA) -* -#ifdef _DEBUGPRINT_ - If (nFckDim.eq.1) Then - Do i=1,nh1 - Write(6,'(i4,f22.16)') i,F_DFT(i,1) - End Do - Else - Do i=1,nh1 - Write(6,'(i4,3f22.16)') i,F_DFT(i,1), - & F_DFT(i,2), - & (F_DFT(i,1)+F_DFT(i,2))/2.0d0 - End Do - End If - Write(6,'(a,f22.16)') ' NAD DFT Energy :',Energy_NAD -#endif -* - Call mma_deallocate(F_DFT) - Call mma_deallocate(D_DS) - Call Free_iSD() - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(H1) - Call Unused_real_array(D) - Call Unused_real(RepNuc) - Call Unused_real(ExFac) - Call Unused_real_array(D1I) - Call Unused_real_array(D1A) - End If - End -************************************************************************ -* * -************************************************************************ -* * -************************************************************************ - Subroutine Wrap_DrvNQ(KSDFT,F_DFT,nFckDim,Func, - & D_DS,nh1,nD_DS, - & Do_Grad, - & Grad,nGrad,DFTFOCK) - use nq_Info - Implicit Real*8 (a-h,o-z) - Character*(*) KSDFT - Integer nh1, nFckDim, nD_DS - Real*8 F_DFT(nh1,nFckDim), D_DS(nh1,nD_DS), Func - Logical Do_Grad - Real*8 Grad(nGrad) - Character*4 DFTFOCK -#include "real.fh" -#include "debug.fh" - Logical Do_MO,Do_TwoEl,F_nAsh -* * -************************************************************************ -* * -* DFT functionals, compute integrals over the potential -* - Func =Zero - Dens_I =Zero - Grad_I =Zero - Tau_I =Zero - Do_MO =.False. - Do_TwoEl =.False. -* - Call Get_iScalar('nSym',mIrrep) - Call Get_iArray('nBas',mBas(0),mIrrep) - Call Get_iArray('nFro',nFro(0),mIrrep) - Call Get_iArray('nIsh',nIsh(0),mIrrep) - Call qpg_iArray('nAsh',F_nAsh,nOrbA) - If(.not.F_nAsh .or. nOrbA.eq.0) Then - Call Izero(nAsh(0),mIrrep) - Else - Call Get_iArray('nAsh',nAsh(0),mIrrep) - End If -* * -************************************************************************ -* * - Call Driver(KSDFT,Do_Grad,Func,Grad,nGrad, - & Do_MO,Do_TwoEl,D_DS,F_DFT,nh1,nFckDim,DFTFOCK) -* * -************************************************************************ -* * - Return - End -************************************************************************ -* * -************************************************************************ - Subroutine cWrap_DrvNQ(KSDFT,F_DFT,nFckDim,Func, - & D_DS,nh1,nD_DS, - & Do_Grad, - & Grad,nGrad,DFTFOCK,F_corr) - use OFembed, only: Do_Core - use nq_Info - Implicit Real*8 (a-h,o-z) - Character*(*) KSDFT - Integer nh1, nFckDim, nD_DS - Real*8 F_DFT(nh1,nFckDim), D_DS(nh1,nD_DS), Func - Real*8 F_corr(nh1,nFckDim) - Logical Do_Grad - Real*8 Grad(nGrad) - Character*4 DFTFOCK -#include "real.fh" -#include "debug.fh" - Logical Do_MO,Do_TwoEl,F_nAsh -* * -************************************************************************ -* * - Func =Zero - Dens_I =Zero - Grad_I =Zero - Tau_I =Zero - Do_MO =.False. - Do_TwoEl =.False. -* - Call Get_iScalar('nSym',mIrrep) - Call Get_iArray('nBas',mBas(0),mIrrep) - Call Get_iArray('nFro',nFro(0),mIrrep) - Call Get_iArray('nIsh',nIsh(0),mIrrep) - Call qpg_dArray('nAsh',F_nAsh,nOrbA) - If(.not.F_nAsh .or. nOrbA.eq.0) Then - Call Izero(nAsh(0),mIrrep) - Else - Call Get_iArray('nAsh',nAsh(0),mIrrep) - End If -* * -************************************************************************ -* * - Do_Core=.True. - Call Driver(KSDFT,Do_Grad,Func,Grad,nGrad, - & Do_MO,Do_TwoEl,D_DS,F_corr,nh1,nFckDim,DFTFOCK) - Do_Core=.False. -* * -************************************************************************ -* * -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_real_array(F_DFT) - End -************************************************************************ -* * -************************************************************************ -* * -************************************************************************ - Real*8 Function Xlambda(omega,sigma) - Implicit Real*8 (a-h,o-z) - Real*8 omega, sigma - - If (sigma*omega.gt.42d0) Then - Xlambda = 1.0d0 - Else - Xlambda = 1.0d0 - exp(-sigma*omega) - EndIf - - End -************************************************************************ -* * -************************************************************************ - Subroutine Get_electrons(xnElect) - use nq_Info - Implicit Real*8 (a-h,o-z) - Real*8 xnElect -#include "real.fh" - - xnElect = Dens_I - - Return - End -************************************************************************ -* * -************************************************************************ - Subroutine VEMB_Exc_states(Vemb,nVemb,xKSDFT,Func_Bx) - Implicit Real*8 (a-h,o-z) - Real*8 Vemb(nVemb) - Real*8 Func_Bx - Character*(*) xKSDFT - Character*16 MyNamRfil -#include "rasdim.fh" -#include "rasscf.fh" -#include "general.fh" -#include "gas.fh" -#include "ciinfo.fh" -#include "rctfld.fh" -#include "stdalloc.fh" -#include "SysDef.fh" - Real*8, Allocatable:: D1ao_b(:), F_DFT(:) - Real*8, Allocatable:: xxCMO(:), xxOCCN(:), DState(:) - Real*8 :: Dummy(1)=[0.0D0] - Integer :: nDummy=1 - - - IAD12=IADR15(12) - - Call mma_allocate(xxCMO,NTOT2,Label='xxCMO') - Call mma_allocate(xxOCCN,NTOT,Label='xxOCCN') - Call mma_allocate(DState,NTOT1,Label='DState') - Call mma_allocate(F_DFT,nVemb,Label='F_DFT') - Call mma_allocate(D1ao_b,nVemb,Label='D1ao_b') - - DO KROOT=1,LROOTS -* -* Read natural orbitals - If ( NAC.GT.0 ) then - CALL DDAFILE(JOBIPH,2,xxCMO,NTOT2,IAD12) - CALL DDAFILE(JOBIPH,2,xxOCCN,NTOT,IAD12) - End If -* Get GS and excited state densities: -* Fill allocated mem with zeroes. - DSTATE(:)=0.0D0 - - Call DONE_RASSCF(xxCMO,xxOCCN,DState) ! computes D=CnC' -* Nonelectr. Vemb with GS and excited state density - Vemb_Xstate=ddot_(nVemb,Vemb,1,DState,1) -* Write(6,*) 'Kroot, Vemb_K ', KROOT, Vemb_Xstate - Write(6,'(A,F19.10,3X,A,I3)') 'Nonelectr. Vemb w. rhoA_emb =', - & Vemb_Xstate,'root = ', KROOT -* E_xc,T[rhoA] - Func_A=0.0d0 - F_DFT(:)=0.0D0 - Call dscal_(nVemb,0.5d0,DState,1) - Call wrap_DrvNQ(xKSDFT,F_DFT,1,Func_A, - & DState,nVemb,1, - & .false., - & Dummy,nDummy,'SCF ') -* Write(6,*) 'Kroot, Func_A ', KROOT, Func_A -* E_xc,T[rhoA+rhoB] - Call Get_NameRun(MyNamRfil) ! save current Runfile name - Call NameRun('AUXRFIL') ! switch RUNFILE name - Call Get_D1ao(D1ao_b,nVemb) - Call daxpy_(nVemb,0.5d0,D1ao_b,1,DState,1) -* - Func_AB=0.0d0 - F_DFT(:)=0.0D0 - Call wrap_DrvNQ(xKSDFT,F_DFT,1,Func_AB, - & DState,nVemb,1, - & .false., - & Dummy,nDummy,'SCF ') -* Write(6,*) 'Kroot, Func_AB', KROOT, Func_AB -* Write(6,*) 'Kroot, Func_Bx', KROOT, Func_Bx -* Calculate DFT NAD for all densities: - DFT_NAD = Func_AB - Func_A - Func_Bx - Write(6,'(A,F19.10,3X,A,I3)') 'DFT energy (NAD) = ', - & DFT_NAD, 'root = ', KROOT - Call NameRun(MyNamRfil) ! go back to MyNamRfil - End Do - Call mma_deallocate(D1ao_b) - Call mma_deallocate(F_DFT) - Call mma_deallocate(DState) - Call mma_deallocate(xxCMO) - Call mma_deallocate(xxOCCN) - - Return - End - diff -Nru openmolcas-22.02/src/dft_util/drvemb.F90 openmolcas-22.10/src/dft_util/drvemb.F90 --- openmolcas-22.02/src/dft_util/drvemb.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dft_util/drvemb.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,391 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2010,2012,2017, Francesco Aquilante * +! 2015,2017, Alexander Zech * +!*********************************************************************** + +subroutine DrvEMB(nh1,KSDFT,Do_Grad,Grad,nGrad,DFTFOCK) +!*********************************************************************** +!*********************************************************************** +!** Orbital-Free Embedding calculation *** +!** *** +!** Method: *** +!** T. A. Wesolowski, A. Warshel, J. Phys. Chem. 97 (1993) 8050. *** +!** *** +!** NDSD potential: *** +!** J.-M. Garcia Lastra, J. W. Kaminski, T. A. Wesolowski, *** +!** J. Chem. Phys. 129 (2008) 074107. *** +!** *** +!** Embedding multi-determinantal wfs: *** +!** T. A. Wesolowski, Phys. Rev.A. 77 (2008) 012504. *** +!** *** +!** *** +!** Embedding Hartree-Fock wf: *** +!** F. Aquilante, T. A. Wesolowski *** +!** J. Chem. Phys. 135 (2011) 084120. *** +!** *** +!** *** +!** Author: F. Aquilante, Geneva July 2010 *** +!** *** +!** (last update: Feb 2012) *** +!** *** +!*********************************************************************** +!*********************************************************************** + +use OFembed, only: dFMD, Energy_NAD, Func_A, Func_AB, Func_B, NDSD, OFE_first, V_emb, V_Nuc_AB, V_Nuc_BA, Xsigma +use nq_Info, only: Dens_I +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Half +use Definitions, only: wp, iwp, r8 + +implicit none +integer(kind=iwp), intent(in) :: nh1, nGrad +character(len=*), intent(inout) :: KSDFT +logical(kind=iwp), intent(in) :: Do_Grad +real(kind=wp), intent(inout) :: Grad(nGrad) +character(len=4), intent(in) :: DFTFOCK +#include "debug.fh" +integer(kind=iwp) :: i, iSpin, j, kSpin, nD, nFckDim +real(kind=wp) :: d_Alpha, d_Beta, DSpn, DTot, Ec_A, Fact, Fact_, Fakt_, Func_A_TF, Func_B_TF, tmp, xElAB, Vxc_ref(2) +logical(kind=iwp) :: is_rhoA_on_file +character(len=16) :: NamRfil +real(kind=wp), allocatable :: D_DS(:,:), F_DFT(:,:), Fcorr(:,:), TmpA(:) +real(kind=wp), external :: Xlambda +real(kind=r8), external :: dDot_ +#ifdef _NOT_USED_ +integer(kind=iwp) :: nDens +real(kind=wp) :: Func_AB_TF, TF_NAD, V_emb_x, V_emb_x_ref, Xint_Ts_A, Xint_Ts_AB, Xint_Ts_NAD, Xnorm, Ynorm +real(kind=wp), allocatable :: D1ao_x(:), D1ao_y(:), Vemb(:) +#endif + +Debug = .false. +is_rhoA_on_file = .false. +! * +!*********************************************************************** +! * +call Setup_iSD() +if (Do_Grad) Grad(:) = Zero +! * +!*********************************************************************** +! * +#ifdef _NOT_USED_ +! Section to calculate Nonelectr. V_emb with current density +! Temporarily turned off (clean output) +if (.not. OFE_first) then + call mma_allocate(D1ao_y,nh1) + call Get_NameRun(NamRfil) ! save the old RUNFILE name + call NameRun('AUXRFIL') ! switch RUNFILE name + call mma_allocate(Vemb,nh1,label='Vemb') + call Get_dArray('dExcdRa',Vemb,nh1) + call mma_allocate(TmpA,nh1,Label='TmpA') + call Get_dArray('Nuc Potential',TmpA,nh1) + ! Subtract V_nuc_B + Vemb(:) = Vemb-TmpA + ! Calculate nonelectr. V_emb with current Density + Ynorm = dDot_(nh1,D1ao_y,1,D1ao_y,1) + V_emb_x = dDot_(nh1,Vemb,1,D1ao_y,1) + write(u6,'(A,F19.10,4X,A,F10.5)') 'Nonelectr. Vemb w. current density: ',V_emb_x,'Y_Norm = ',Ynorm + call mma_deallocate(D1ao_y) + ! Get rho_A_ref + call NameRun('PRERFIL') + call mma_allocate(D1ao_x,nDens,Label='D1ao_x') + call get_dArray('D1ao',D1ao_x,nDens) + Xnorm = dDot_(nh1,D1ao_x,1,D1ao_x,1) + V_emb_x_ref = dDot_(nh1,Vemb,1,D1ao_x,1) + write(u6,'(A,F19.10,4X,A,F10.5)') 'Nonelectr. Vemb w. ref. density: ',V_emb_x_ref,'X_Norm = ',Xnorm + call VEMB_Exc_states(Vemb,nh1,KSDFT,Func_B) + call mma_deallocate(TmpA) + call mma_deallocate(D1ao_x) + call mma_dealloacte(Vemb) + call NameRun(NamRfil) ! switch back to RUNFILE +end if +! Section End +#endif +call f_Inquire('PRERFIL',is_rhoA_on_file) ! rho_A from file +if (is_rhoA_on_file .and. (.not. OFE_first)) return ! Vemb on disk + +!*********************************************************************** +! * +! Setup of density matrices for subsys B (environment) * +! * +!*********************************************************************** +call Get_NameRun(NamRfil) ! save the old RUNFILE name +call NameRun('AUXRFIL') ! switch RUNFILE name +! * +!*********************************************************************** +! * +nD = 4 +call mma_allocate(F_DFT,nh1,nD,Label='F_DFT') +call mma_allocate(D_DS,nh1,nD,Label='D_DS') +Vxc_ref(1) = Zero +Vxc_ref(2) = Zero + +! Get the density matrix of the environment (rho_B) + +call Get_iScalar('Multiplicity',kSpin) +call Get_D1ao(D_DS(:,1),nh1) +!call RecPrt('D1ao',' ',D_DS(:,1),nh1,1) + +! Get the spin density matrix of the environment + +if (kSpin /= 1) then + call Get_D1Sao(D_DS(:,2),nh1) + !call RecPrt('D1Sao',' ',D_DS(:,2),nh1,1) +end if + +! Compute alpha and beta density matrices of the environment + +nFckDim = 2 +if (kSpin == 1) then + D_DS(:,1) = Half*D_DS(:,1) + D_DS(:,2) = D_DS(:,1) + nFckDim = 1 +else + do i=1,nh1 + DTot = D_DS(i,1) + DSpn = D_DS(i,2) + d_Alpha = Half*(DTot+DSpn) + d_Beta = Half*(DTot-DSpn) + D_DS(i,1) = d_Alpha + D_DS(i,2) = d_Beta + end do + !call RecPrt('Da',' ',D_DS(:,1),nh1,1) + !call RecPrt('Db',' ',D_DS(:,2),nh1,1) +end if + +!if (OFE_first) then +!---AZECH 10/2015 +! kinetic part of E_xct, Subsys B +Func_B_TF = Zero +call wrap_DrvNQ('TF_only',F_DFT(:,1:nFckDim),nFckDim,Func_B_TF,D_DS(:,1:nFckDim),nh1,nFckDim,Do_Grad,Grad,nGrad,DFTFOCK) + +if (OFE_first) then + + call wrap_DrvNQ(KSDFT,F_DFT(:,1:nFckDim),nFckDim,Func_B,D_DS(:,1:nFckDim),nh1,nFckDim,Do_Grad,Grad,nGrad,DFTFOCK) + + if (KSDFT(1:4) == 'NDSD') then + call mma_allocate(NDSD,nh1,nFckDim,label='NDSD') + NDSD(:,:) = F_DFT(:,1:nFckDim) + KSDFT(1:4) = 'LDTF' !set to Thomas-Fermi for subsequent calls + end if + +end if + +!*********************************************************************** +! * +! Setup of density matrices for subsys A * +! * +!*********************************************************************** +call NameRun(NamRfil) ! switch back RUNFILE name + +if (is_rhoA_on_file) call NameRun('PRERFIL') +! Get the density matrix for rho_A + +call Get_D1ao(D_DS(:,3),nh1) +!call RecPrt('D1ao',' ',D_DS(:,3),nh1,1) + +call Get_iScalar('Multiplicity',iSpin) +if ((iSpin == 1) .and. (kSpin /= 1) .and. OFE_first) then + call WarningMessage(0,'Non-singlet environment perturbation on singlet state!;'// & + 'Spin-components of the OFE potential will be averaged.') +end if + +! Get the spin density matrix of A + +if (iSpin /= 1) then + call Get_D1Sao(D_DS(:,4),nh1) + !call RecPrt('D1Sao',' ',D_DS(:,4),nh1,1) +end if + +! Compute alpha and beta density matrices of subsystem A + +nFckDim = 2 +if (iSpin == 1) then + D_DS(:,3) = Half*D_DS(:,3) + D_DS(:,4) = D_DS(:,3) + if (kSpin == 1) nFckDim = 1 +else + do i=1,nh1 + DTot = D_DS(i,3) + DSpn = D_DS(i,4) + d_Alpha = Half*(DTot+DSpn) + d_Beta = Half*(DTot-DSpn) + D_DS(i,3) = d_Alpha + D_DS(i,4) = d_Beta + end do + !call RecPrt('Da',' ',D_DS(:,3),nh1,1) + !call RecPrt('Db',' ',D_DS(:,4),nh1,1) +end if + +!---AZECH 10/2015 +! kinetic part of E_xct, Subsys A +call wrap_DrvNQ('TF_only',F_DFT(:,3:nFckDim+2),nFckDim,Func_A_TF,D_DS(:,3:nFckDim+2),nh1,nFckDim,Do_Grad,Grad,nGrad,DFTFOCK) + +call wrap_DrvNQ(KSDFT,F_DFT(:,3:nFckDim+2),nFckDim,Func_A,D_DS(:,3:nFckDim+2),nh1,nFckDim,Do_Grad,Grad,nGrad,DFTFOCK) + +! Fraction of correlation potential from A (cases: HF or Trunc. CI) + +if (dFMD > Zero) then + + call mma_allocate(Fcorr,nh1,nFckDim,Label='Fcorr') + + call cwrap_DrvNQ(KSDFT,nFckDim,Ec_A,D_DS(:,3:nFckDim+2),nh1,nFckDim,Do_Grad,Grad,nGrad,DFTFOCK,Fcorr(:,1:nFckDim)) +end if + +!*********************************************************************** +! * +! Calculation on the supermolecule * +! * +!*********************************************************************** +nFckDim = 2 +if ((iSpin == 1) .and. (kSpin == 1)) then + nFckDim = 1 + D_DS(:,1) = D_DS(:,1)+D_DS(:,3) +else + D_DS(:,1) = D_DS(:,1)+D_DS(:,3) + D_DS(:,2) = D_DS(:,2)+D_DS(:,4) +end if +#ifdef _NOT_USED_ +!---AZECH 10/2015 +! kinetic part of E_xct, Subsys A+B +! temporarily turned off to clean output +if (.false.) then + Func_AB_TF = Zero + call wrap_DrvNQ('TF_only',F_DFT(:,1:nFckDim),nFckDim,Func_AB_TF,D_DS(:,1:nFckDim),nh1,nFckDim,Do_Grad,Grad,nGrad,DFTFOCK) + TF_NAD = Func_AB_TF-Func_A_TF-Func_B_TF + write(u6,*) 'kinetic part of E_xc,T (Thomas-Fermi ONLY)' + write(u6,'(A,F19.10)') 'Ts(A+B): ',Func_AB_TF + write(u6,'(A,F19.10)') 'Ts(A): ',Func_A_TF + write(u6,'(A,F19.10)') 'Ts(B): ',Func_B_TF + write(u6,'(A,F19.10)') '-------------------' + write(u6,'(A,F19.10)') 'Ts_NAD: ',TF_NAD + ! calculate v_T, Subsys A+B + Xint_Ts_AB = dDot_(nh1,F_DFT(:,1),1,D_DS(:,3),1) + Xint_Ts_NAD = Xint_Ts_AB-Xint_Ts_A + ! scale by 2 because wrapper only handles spin-densities + Xint_Ts_NAD = Two*Xint_Ts_NAD + write(u6,*) 'integrated v_Ts_NAD (Thomas-Fermi) with rhoA current' + write(u6,'(A,F19.10)') 'Ts(A+B)_integral: ',Xint_Ts_AB + write(u6,'(A,F19.10)') 'Ts(A)_integral: ',Xint_Ts_A + write(u6,'(A,F19.10)') '-------------------' + write(u6,'(A,F19.10)') 'Ts_NAD_integral: ',Xint_Ts_NAD +end if +#endif + +call wrap_DrvNQ(KSDFT,F_DFT(:,1:nFckDim),nFckDim,Func_AB,D_DS(:,1:nFckDim),nh1,nFckDim,Do_Grad,Grad,nGrad,DFTFOCK) + +Energy_NAD = Func_AB-Func_A-Func_B + +!---AZECH 10/2015 +! exchange-correlation part of E_xct, Subsys A+B +! temporarily turned off to clean output +!write(u6,*) 'E_xc_NAD (determined with Thomas-Fermi)' +!Func_xc_NAD = Energy_NAD-TF_NAD +!write(u6,'(A,F19.10)') 'E_xc_NAD: ',Func_xc_NAD + +if (dFMD > Zero) then + xElAB = Dens_I + Fakt_ = -Xlambda(abs(Energy_NAD)/xElAB,Xsigma) + F_DFT(:,3:nFckDim+2) = F_DFT(:,3:nFckDim+2)+Fakt_*Fcorr(:,:) + call mma_deallocate(Fcorr) +# ifdef _DEBUGPRINT_ + write(u6,*) ' lambda(E_nad) = ',dFMD*Fakt_ +# endif +end if + +! * +!*********************************************************************** +! * +! Non Additive (NAD) potential: F(AB)-F(A) +do i=1,nFckDim + F_DFT(:,i) = F_DFT(:,i)-F_DFT(:,2+i) +end do + +! NDSD potential for T_nad: add the (B)-dependent term +if (allocated(NDSD)) then + j = 1 + do i=1,nFckDim + F_DFT(:,i) = F_DFT(:,i)+NDSD(:,j) + if (kSpin /= 1) j = j+1 + end do +end if + +! Add the Nuc Attr potential (from subsystem B) and then +! put out the DFT Fock matrices from the (NAD) embedding potential +! on the runfile (AUXRFIL). Note that the classical Coulomb +! interaction potential from subsystem B is computed in the std +! Fock matrix builders + +call NameRun('AUXRFIL') ! switch RUNFILE name + +call mma_allocate(TmpA,nh1,Label='TmpA') +call Get_dArray('Nuc Potential',TmpA,nh1) + +Fact = Two ! because Dmat has been scaled by half +if (kSpin /= 1) Fact = One +Fact_ = Fact + +V_emb = Fact*dDot_(nh1,F_DFT(:,1),1,D_DS(:,3),1) +V_Nuc_AB = Fact*dDot_(nh1,TmpA,1,D_DS(:,3),1) +if (kSpin /= 1) then + V_emb = V_emb+Fact*dDot_(nh1,F_DFT(:,2),1,D_DS(:,4),1) + V_Nuc_AB = V_Nuc_AB+Fact*dDot_(nh1,TmpA,1,D_DS(:,4),1) +end if + +! Averaging the spin-components of F(AB) iff non-spol(A)//spol(B) +if ((iSpin == 1) .and. (kSpin /= 1)) then + do i=1,nh1 + tmp = Half*(F_DFT(i,1)+F_DFT(i,2)) + F_DFT(i,1) = tmp + end do + nFckDim = 1 ! reset stuff as if A+B had been spin compensated + Fact = Two +end if + +do i=1,nFckDim + F_DFT(:,i) = F_DFT(:,i)+TmpA + Vxc_ref(i) = Fact*dDot_(nh1,F_DFT(:,i),1,D_DS(:,i+2),1) +end do + +if (dFMD > Zero) call Put_dScalar('KSDFT energy',Ec_A) +call Put_dArray('Vxc_ref ',Vxc_ref,2) + +call Put_dArray('dExcdRa',F_DFT(:,1:nFckDim),nh1*nFckDim) +call NameRun(NamRfil) ! switch back RUNFILE name + +call Get_dArray('Nuc Potential',TmpA,nh1) +V_Nuc_BA = Fact_*(dDot_(nh1,TmpA,1,D_DS(:,1),1)-dDot_(nh1,TmpA,1,D_DS(:,3),1)) +if (kSpin /= 1) then + V_Nuc_BA = V_Nuc_BA+Fact_*(dDot_(nh1,TmpA,1,D_DS(:,2),1)-dDot_(nh1,TmpA,1,D_DS(:,4),1)) +end if + +call mma_deallocate(TmpA) + +#ifdef _DEBUGPRINT_ +if (nFckDim == 1) then + do i=1,nh1 + write(u6,'(i4,f22.16)') i,F_DFT(i,1) + end do +else + do i=1,nh1 + write(u6,'(i4,3f22.16)') i,F_DFT(i,1),F_DFT(i,2),Half*(F_DFT(i,1)+F_DFT(i,2)) + end do +end if +write(u6,'(a,f22.16)') ' NAD DFT Energy :',Energy_NAD +#endif + +call mma_deallocate(F_DFT) +call mma_deallocate(D_DS) +call Free_iSD() + +return + +end subroutine DrvEMB diff -Nru openmolcas-22.02/src/dft_util/fexp.F90 openmolcas-22.10/src/dft_util/fexp.F90 --- openmolcas-22.02/src/dft_util/fexp.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dft_util/fexp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,54 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2010, Francesco Aquilante * +!*********************************************************************** + +function Fexp(rho,drho) +!*********************************************************************** +!*********************************************************************** +!** *** +!** Switching function of the NDSD potential: *** +!** J.-M. Garcia Lastra, J. W. Kaminski, T. A. Wesolowski, *** +!** J. Chem. Phys. 129 (2008) 074107. *** +!** *** +!** Author: F. Aquilante, Geneva July 2010 *** +!** *** +!*********************************************************************** +!*********************************************************************** + +use Constants, only: One, Three, Two, Pi +use Definitions, only: wp + +implicit none +real(kind=wp) :: Fexp +real(kind=wp), intent(in) :: rho, drho(3) +real(kind=wp) :: eir_rBmin, eis_sBmax, eis_sBmin, er_rBmin, es_sBmax, es_sBmin, fact, factinv, rhoinv, rhoinv13, sB, xnorm, xnorm_ +real(kind=wp), parameter :: lambda = 5.0e2_wp, One3 = One/Three, rBmin = 0.7_wp, sBmin = 0.3_wp, sBmax = 0.9_wp + +rhoinv = One/rho +rhoinv13 = rhoinv**One3 +fact = Two*(Three*Pi**2)**One3 +factinv = One/fact +xnorm = drho(1)**2+drho(2)**2+drho(3)**2 +xnorm_ = sqrt(xnorm) +sB = factinv*rhoinv*rhoinv13*xnorm_ + +es_sBmin = exp(lambda*(sBmin-sB)) +es_sBmax = exp(lambda*(sBmax-sB)) +er_rBmin = exp(lambda*(rBmin-rho)) + +eis_sBmin = One/(es_sBmin+One) +eis_sBmax = One/(es_sBmax+One) +eir_rBmin = One/(er_rBmin+One) + +Fexp = eis_sBmin*(One-eis_sBmax)*eir_rBmin + +end function Fexp diff -Nru openmolcas-22.02/src/dft_util/func_emb.f openmolcas-22.10/src/dft_util/func_emb.f --- openmolcas-22.02/src/dft_util/func_emb.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/dft_util/func_emb.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,75 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2010, Francesco Aquilante * -************************************************************************ - Real*8 Function Fexp(rho,drho) -************************************************************************ -************************************************************************ -*** *** -*** Switching function of the NDSD potential: *** -*** J.-M. Garcia Lastra, J. W. Kaminski, T. A. Wesolowski, *** -*** J. Chem. Phys. 129 (2008) 074107. *** -*** *** -*** Author: F. Aquilante, Geneva July 2010 *** -*** *** -************************************************************************ -************************************************************************ - Implicit Real*8 (a-h,o-z) - Real*8 lambda, rho, drho(3) -#include "real.fh" - Parameter ( One3 = One/Three ) - Parameter ( sBmin = 0.3d0 ) - Parameter ( sBmax = 0.9d0 ) - Parameter ( rBmin = 0.7d0 ) - Parameter ( lambda= 5.0d2 ) - - - rhoinv= One/rho - rhoinv13= rhoinv**One3 - fact= Two*(Three*Pi**2)**One3 - factinv= One/fact - xnorm = drho(1)**2 + drho(2)**2 + drho(3)**2 - xnorm_= sqrt(xnorm) - sB = factinv*rhoinv*rhoinv13*xnorm_ - - es_sBmin = exp(lambda*(sBmin-sB)) - es_sBmax = exp(lambda*(sBmax-sB)) - er_rBmin = exp(lambda*(rBmin-rho)) - - eis_sBmin= One/(es_sBmin+One) - eis_sBmax= One/(es_sBmax+One) - eir_rBmin= One/(er_rBmin+One) - - Fexp = eis_sBmin*(One-eis_sBmax)*eir_rBmin - - End -* * -************************************************************************ -* * - Real*8 Function Vt_lim(rho,drho,ddrho) - - Implicit Real*8 (a-h,o-z) - Real*8 rho, drho(3), ddrho -#include "real.fh" - Parameter ( One8 = One/Eight ) - Parameter ( One4 = One/Four ) - - - rhoinv= One/rho - rhoinv2= rhoinv**Two - xnorm = drho(1)**2 + drho(2)**2 + drho(3)**2 - - Vt_lim = One8*xnorm*rhoinv2 - One4*ddrho*rhoinv - - End -* * -************************************************************************ -* * diff -Nru openmolcas-22.02/src/dft_util/functionals.f90 openmolcas-22.10/src/dft_util/functionals.f90 --- openmolcas-22.02/src/dft_util/functionals.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/dft_util/functionals.f90 1970-01-01 00:00:00.000000000 +0000 @@ -1,283 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -! * -! Copyright (C) 2022, Ignacio Fdez. Galvan * -!*********************************************************************** - -module Functionals - -use libxc_parameters, only: nFuncs_max -use Constants, only: Zero -use Definitions, only: wp, iwp, LibxcInt - -implicit none -private - -! Def_* variables are a cache of last read values, so the database file -! does not need to be re-read over and over - -#include "functional_types.fh" -integer(kind=iwp) :: Def_Functional_Type = Other_Type, Def_nFuncs = 0 -integer(kind=LibxcInt) :: Def_func_id(nFuncs_max) = -1_LibxcInt -real(kind=wp) :: Def_Coeffs(nFuncs_max) = Zero, Def_ExFac = Zero -character(len=80) :: Def_Label = '' - -public :: Get_Func_ExFac, Get_Funcs, Init_Funcs, Print_Info - -contains - -subroutine Init_Funcs(Label) - - use fortran_strings, only: to_upper - - character(len=*), intent(in) :: Label - character(len=len(Label)) :: UpLabel - - UpLabel = to_upper(Label) - if (UpLabel /= Def_Label) call Find_Functional(UpLabel) - -end subroutine Init_Funcs - -function Get_Func_ExFac(Label) - - real(kind=wp) :: Get_Func_Exfac - character(len=*), intent(in) :: Label - - call Init_Funcs(Label) - Get_Func_ExFac = Def_ExFac - -end function Get_Func_ExFac - -subroutine Get_Funcs(Label) - - use libxc_parameters, only: Coeffs, func_id, nFuncs - use nq_Info - - character(len=*), intent(in) :: Label - - call Init_Funcs(Label) - nFuncs = Def_nFuncs - Coeffs(1:Def_nFuncs) = Def_Coeffs(1:Def_nFuncs) - func_id(1:Def_nFuncs) = Def_func_id(1:Def_nFuncs) - Functional_Type = Def_Functional_Type - -end subroutine Get_Funcs - -subroutine Print_Info() - - use xc_f03_lib_m, only: xc_f03_func_end, xc_f03_func_get_info, xc_f03_func_info_get_name, xc_f03_func_info_get_references, & - xc_f03_func_info_t, xc_f03_func_init, xc_f03_func_reference_get_doi, xc_f03_func_reference_get_ref, & - xc_f03_func_reference_t, xc_f03_func_t - use Definitions, only: u6 - - integer(kind=iwp) :: i, old_j - integer(kind=LibxcInt) :: j - type(xc_f03_func_t) :: func - type(xc_f03_func_info_t) :: info - type(xc_f03_func_reference_t) :: ref - - if (Def_nFuncs < 1) return - - write(u6,*) - do i=1,Def_nFuncs - call xc_f03_func_init(func,Def_func_id(i),0_LibxcInt) - info = xc_f03_func_get_info(func) - write(u6,100) trim(xc_f03_func_info_get_name(info)) - ! old_j is a workaround for a bug in Libxc 5.2.0 - old_j = -1 - j = 0 - do while ((j >= 0) .and. (j /= old_j)) - old_j = j - ref = xc_f03_func_info_get_references(info,j) - write(u6,101) trim(xc_f03_func_reference_get_ref(ref)),trim(xc_f03_func_reference_get_doi(ref)) - end do - call xc_f03_func_end(func) - end do - -100 format(6x,'* ',a) -101 format(8x,'- ',a,' doi:',a) - -end subroutine Print_Info - -! Read functional database file and assign DFT parameters according to the chosen functional -subroutine Find_Functional(Label) - - use xc_f03_lib_m, only: xc_f03_func_end, xc_f03_func_get_info, xc_f03_func_info_get_family, xc_f03_func_info_get_flags, & - xc_f03_func_info_t, xc_f03_func_init, xc_f03_func_t, xc_f03_hyb_exx_coef, XC_FAMILY_GGA, & - XC_FAMILY_HYB_GGA, XC_FAMILY_HYB_LDA, XC_FAMILY_HYB_MGGA, XC_FAMILY_LDA, XC_FAMILY_MGGA, & - XC_FLAGS_NEEDS_LAPLACIAN - use fortran_strings, only: to_upper - use Constants, only: One - use Definitions, only: u6 - - character(len=*), intent(in) :: Label - integer(kind=iwp) :: i, istatus, Lu, nComp - integer(kind=LibxcInt) :: flags(nFuncs_max) - real(kind=wp) :: Coeff - character(len=256) :: Line - character(len=80) :: Labels(nFuncs_max), Word1, Word2 - integer(kind=iwp), external :: IsFreeUnit - type(xc_f03_func_t) :: func(nFuncs_max) - type(xc_f03_func_info_t) :: info(nFuncs_max) - - Def_ExFac = Zero - Def_nFuncs = 0 - - Lu = IsFreeUnit(11) - call molcas_open(Lu,'FUNCDATA') - - ! First find the line that starts with the keyword name - do - read(Lu,'(A)',iostat=istatus) Line - if (istatus /= 0) then - call WarningMessage(2,' Find_Functional: Undefined functional type!') - write(u6,*) ' Functional=',trim(Label) - call Quit_OnUserError() - end if - Line = adjustl(Line) - if ((Line == '') .or. (Line(1:1) == '#')) cycle - read(Line,*) Word1,Word2 - if (to_upper(Word1) == Label) exit - end do - - ! Once found, read the second word - read(Word2,*,iostat=istatus) nComp - if (istatus == 0) then - ! If it's a number, read the component functionals and factors - if (Def_nFuncs > nFuncs_max) then - call WarningMessage(2,' Find_Functional: Too many components!') - write(u6,*) ' nFuncs=',Def_nFuncs - call Quit_OnUserError() - end if - i = 0 - do while (i < nComp) - read(Lu,'(A)',iostat=istatus) Line - if (istatus /= 0) then - call WarningMessage(2,' Find_Functional: Error in functional definition!') - write(u6,*) ' Functional=',trim(Label) - call Quit_OnUserError() - end if - Line = adjustl(Line) - if ((Line == '') .or. (Line(1:1) == '#')) cycle - i = i+1 - read(Line,*,iostat=istatus) Coeff,Word2 - if (istatus /= 0) then - call WarningMessage(2,' Find_Functional: Error in functional definition!') - write(u6,*) ' Functional=',trim(Label) - call Quit_OnUserError() - end if - ! HF_X means exact exchange - if (to_upper(Word2) == 'HF_X') then - Def_ExFac = Def_ExFac+Coeff - else - Def_nFuncs = Def_nFuncs+1 - Def_Coeffs(Def_nFuncs) = Coeff - Def_func_id(Def_nFuncs) = get_func(Word2) - Labels(Def_nFuncs) = Word2 - end if - end do - else - ! Otherwise, this is just an alias for a Libxc functional - Def_nFuncs = 1 - Def_Coeffs(1) = One - Def_func_id(1) = get_func(Word2) - Labels(1) = Word2 - end if - - close(Lu) - - ! Now the file is read, process the functional(s) - - do i=1,Def_nFuncs - call xc_f03_func_init(func(i),Def_func_id(i),0_LibxcInt) - info(i) = xc_f03_func_get_info(func(i)) - flags(i) = xc_f03_func_info_get_flags(info(i)) - end do - - Def_Functional_Type = -1 - do i=1,Def_nFuncs - ! Check whether the functional uses some unsupported feature - call check_supported(Labels(i),flags(i)) - ! Add exact exchange from components - Def_ExFac = Def_ExFac+Def_Coeffs(i)*xc_f03_hyb_exx_coef(func(i)) - ! Assign functional type ("maximum" of its components) - select case (xc_f03_func_info_get_family(info(i))) - case (XC_FAMILY_LDA,XC_FAMILY_HYB_LDA) - Def_Functional_type = max(Def_Functional_type,LDA_type) - case (XC_FAMILY_GGA,XC_FAMILY_HYB_GGA) - Def_Functional_type = max(Def_Functional_type,GGA_type) - case (XC_FAMILY_MGGA,XC_FAMILY_HYB_MGGA) - if (iand(flags(i),XC_FLAGS_NEEDS_LAPLACIAN) > 0) then - Def_Functional_type = max(Def_Functional_type,meta_GGA_type2) - else - Def_Functional_type = max(Def_Functional_type,meta_GGA_type1) - end if - end select - end do - - do i=1,Def_nFuncs - call xc_f03_func_end(func(i)) - end do - - Def_Label = Label - -end subroutine Find_Functional - -function get_func(xcLabel) - - use xc_f03_lib_m, only: xc_f03_functional_get_number - use Definitions, only: u6 - - integer(kind=LibxcInt) :: get_func - character(len=*), intent(in) :: xcLabel - - get_func = xc_f03_functional_get_number(xcLabel) - if (get_func < 0) then - call WarningMessage(2,' Find_Functional: Undefined functional in Libxc!') - write(u6,*) ' Functional=',trim(xcLabel) - call Quit_OnUserError() - end if - -end function get_func - -subroutine check_supported(Label,flags) - - use xc_f03_lib_m, only: XC_FLAGS_HYB_CAM, XC_FLAGS_HYB_CAMY, XC_FLAGS_HYB_LC, XC_FLAGS_HYB_LCY, XC_FLAGS_VV10 - use Definitions, only: u6 - - character(len=*), intent(in) :: Label - integer(kind=LibxcInt), intent(in) :: flags - integer(kind=iwp) :: lev, lt, maxlev - - maxlev = 0 - lt = len_trim(Label) - - if ((iand(flags,XC_FLAGS_HYB_CAM) > 0) .or. (iand(flags,XC_FLAGS_HYB_CAMY) > 0) .or. (iand(flags,XC_FLAGS_HYB_LC) > 0) .or. & - (iand(flags,XC_FLAGS_HYB_LCY) > 0)) then - lev = 2 - maxlev = max(lev,maxlev) - call WarningMessage(lev,' Find_Functional: Range separation is not supported!') - end if - if ((iand(flags,XC_FLAGS_VV10) > 0)) then - lev = 2 - maxlev = max(lev,maxlev) - call WarningMessage(lev,' Find_Functional: Non-local correlation is not supported!') - end if - if ((Label(lt-1:lt) == '_D') .or. (Label(lt-2:lt) == '_D3')) then - lev = 1 ! make it just a warning for now - maxlev = max(lev,maxlev) - call WarningMessage(lev,' Find_Functional: Dispersion corrections are not implemented!') - end if - if (maxlev > 0) write(u6,*) ' Functional=',trim(Label) - if (maxlev > 1) call Quit_OnUserError() - -end subroutine check_supported - -end module Functionals diff -Nru openmolcas-22.02/src/dft_util/functionals.F90 openmolcas-22.10/src/dft_util/functionals.F90 --- openmolcas-22.02/src/dft_util/functionals.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dft_util/functionals.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,308 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2022, Ignacio Fdez. Galvan * +!*********************************************************************** + +module Functionals + +use libxc_parameters, only: nFuncs_max +use nq_Info, only: Functional_Type, GGA_Type, LDA_Type, meta_GGA_Type1, meta_GGA_Type2, Other_Type +use Constants, only: Zero +use Definitions, only: wp, iwp, LibxcInt + +implicit none +private + +! Def_* variables are a cache of last read values, so the database file +! does not need to be re-read over and over + +integer(kind=iwp) :: Def_Functional_Type = Other_Type, Def_nFuncs = 0 +integer(kind=LibxcInt) :: Def_func_id(nFuncs_max) = -1_LibxcInt +real(kind=wp) :: Def_Coeffs(nFuncs_max) = Zero, Def_ExFac = Zero +character(len=80) :: Def_Label = '' +character(len=*), parameter :: Custom_File = 'CUSTFUNC', Custom_Func = '-999_CUSTOM_FUNCTIONAL' + +public :: Custom_File, Custom_Func, Get_Func_ExFac, Get_Funcs, Init_Funcs, Print_Info + +contains + +subroutine Init_Funcs(Label) + + use fortran_strings, only: to_upper + + character(len=*), intent(in) :: Label + character(len=len(Label)) :: UpLabel + + UpLabel = to_upper(Label) + if (UpLabel /= Def_Label) call Find_Functional(UpLabel) + +end subroutine Init_Funcs + +function Get_Func_ExFac(Label) + + real(kind=wp) :: Get_Func_Exfac + character(len=*), intent(in) :: Label + + call Init_Funcs(Label) + Get_Func_ExFac = Def_ExFac + +end function Get_Func_ExFac + +subroutine Get_Funcs(Label) + + use libxc_parameters, only: Coeffs, func_id, nFuncs + + character(len=*), intent(in) :: Label + + call Init_Funcs(Label) + nFuncs = Def_nFuncs + Coeffs(1:Def_nFuncs) = Def_Coeffs(1:Def_nFuncs) + func_id(1:Def_nFuncs) = Def_func_id(1:Def_nFuncs) + Functional_Type = Def_Functional_Type + +end subroutine Get_Funcs + +subroutine Print_Info() + + use xc_f03_lib_m, only: xc_f03_func_end, xc_f03_func_get_info, xc_f03_func_info_get_name, xc_f03_func_info_get_references, & + xc_f03_func_info_t, xc_f03_func_init, xc_f03_func_reference_get_doi, xc_f03_func_reference_get_ref, & + xc_f03_func_reference_t, xc_f03_func_t, XC_UNPOLARIZED + use Definitions, only: u6 + + integer(kind=iwp) :: i, old_j + integer(kind=LibxcInt) :: j + type(xc_f03_func_t) :: func + type(xc_f03_func_info_t) :: info + type(xc_f03_func_reference_t) :: ref + + if (Def_nFuncs < 1) return + + write(u6,*) + do i=1,Def_nFuncs + call xc_f03_func_init(func,Def_func_id(i),xc_unpolarized) + info = xc_f03_func_get_info(func) + write(u6,100) trim(xc_f03_func_info_get_name(info)) + ! old_j is a workaround for a bug in Libxc 5.2.0 + old_j = -1 + j = 0 + do while ((j >= 0) .and. (j /= old_j)) + old_j = j + ref = xc_f03_func_info_get_references(info,j) + write(u6,101) trim(xc_f03_func_reference_get_ref(ref)),trim(xc_f03_func_reference_get_doi(ref)) + end do + call xc_f03_func_end(func) + end do + +100 format(6x,'* ',a) +101 format(8x,'- ',a,' doi:',a) + +end subroutine Print_Info + +! Read functional database file and assign DFT parameters according to the chosen functional +subroutine Find_Functional(Label) + + use xc_f03_lib_m, only: xc_f03_func_end, xc_f03_func_get_info, xc_f03_func_info_get_family, xc_f03_func_info_get_flags, & + xc_f03_func_info_t, xc_f03_func_init, xc_f03_func_t, xc_f03_hyb_exx_coef, XC_FAMILY_GGA, & + XC_FAMILY_HYB_GGA, XC_FAMILY_HYB_LDA, XC_FAMILY_HYB_MGGA, XC_FAMILY_LDA, XC_FAMILY_MGGA, & + XC_FLAGS_NEEDS_LAPLACIAN, XC_UNPOLARIZED + use fortran_strings, only: to_upper + use Constants, only: One + use Definitions, only: u6 + + character(len=*), intent(in) :: Label + integer(kind=iwp) :: i, istatus, Lu, nComp + integer(kind=LibxcInt) :: flags(nFuncs_max) + real(kind=wp) :: Coeff + character(len=256) :: Line + character(len=80) :: Labels(nFuncs_max), Word1, Word2 + integer(kind=iwp), external :: IsFreeUnit + type(xc_f03_func_t) :: func(nFuncs_max) + type(xc_f03_func_info_t) :: info(nFuncs_max) + + Def_ExFac = Zero + Def_nFuncs = 0 + + ! First test if this is already a Libxc functional + Def_func_id(1) = get_func(Label,test=.true.) + if (Def_func_id(1) >= 0) then + + Def_nFuncs = 1 + Def_Coeffs(1) = One + Labels(1) = Label + + else + + ! If not, we have to read the database file, or the custom functional file + Lu = IsFreeUnit(11) + if (Label == Custom_Func) then + call molcas_open(Lu,Custom_File) + else + call molcas_open(Lu,'FUNCDATA') + end if + + ! Find the line that starts with the keyword name + do + read(Lu,'(A)',iostat=istatus) Line + if (istatus /= 0) then + call WarningMessage(2,' Find_Functional: Undefined functional type!') + write(u6,*) ' Functional=',trim(Label) + call Quit_OnUserError() + end if + Line = adjustl(Line) + if ((Line == '') .or. (Line(1:1) == '#')) cycle + read(Line,*) Word1,Word2 + if (to_upper(Word1) == Label) exit + end do + + ! Once found, read the second word + read(Word2,*,iostat=istatus) nComp + if (istatus == 0) then + ! If it's a number, read the component functionals and factors + if (Def_nFuncs > nFuncs_max) then + call WarningMessage(2,' Find_Functional: Too many components!') + write(u6,*) ' nFuncs=',Def_nFuncs + call Quit_OnUserError() + end if + i = 0 + do while (i < nComp) + read(Lu,'(A)',iostat=istatus) Line + if (istatus /= 0) then + call WarningMessage(2,' Find_Functional: Error in functional definition!') + write(u6,*) ' Functional=',trim(Label) + call Quit_OnUserError() + end if + Line = adjustl(Line) + if ((Line == '') .or. (Line(1:1) == '#')) cycle + i = i+1 + read(Line,*,iostat=istatus) Coeff,Word2 + if (istatus /= 0) then + call WarningMessage(2,' Find_Functional: Error in functional definition!') + write(u6,*) ' Functional=',trim(Label) + call Quit_OnUserError() + end if + ! HF_X means exact exchange + if (to_upper(Word2) == 'HF_X') then + Def_ExFac = Def_ExFac+Coeff + else + Def_nFuncs = Def_nFuncs+1 + Def_Coeffs(Def_nFuncs) = Coeff + Def_func_id(Def_nFuncs) = get_func(Word2) + Labels(Def_nFuncs) = Word2 + end if + end do + else + ! Otherwise, this is just an alias for a Libxc functional + Def_nFuncs = 1 + Def_Coeffs(1) = One + Def_func_id(1) = get_func(Word2) + Labels(1) = Word2 + end if + + close(Lu) + + end if + + ! Now process the functional(s) + + do i=1,Def_nFuncs + call xc_f03_func_init(func(i),Def_func_id(i),XC_UNPOLARIZED) + info(i) = xc_f03_func_get_info(func(i)) + flags(i) = xc_f03_func_info_get_flags(info(i)) + end do + + Def_Functional_Type = Other_Type + do i=1,Def_nFuncs + ! Check whether the functional uses some unsupported feature + call check_supported(Labels(i),flags(i)) + ! Add exact exchange from components + Def_ExFac = Def_ExFac+Def_Coeffs(i)*xc_f03_hyb_exx_coef(func(i)) + ! Assign functional type ("maximum" of its components) + select case (xc_f03_func_info_get_family(info(i))) + case (XC_FAMILY_LDA,XC_FAMILY_HYB_LDA) + Def_Functional_type = max(Def_Functional_type,LDA_type) + case (XC_FAMILY_GGA,XC_FAMILY_HYB_GGA) + Def_Functional_type = max(Def_Functional_type,GGA_type) + case (XC_FAMILY_MGGA,XC_FAMILY_HYB_MGGA) + if (iand(flags(i),XC_FLAGS_NEEDS_LAPLACIAN) > 0) then + Def_Functional_type = max(Def_Functional_type,meta_GGA_type2) + else + Def_Functional_type = max(Def_Functional_type,meta_GGA_type1) + end if + end select + end do + + do i=1,Def_nFuncs + call xc_f03_func_end(func(i)) + end do + + Def_Label = Label + +end subroutine Find_Functional + +function get_func(xcLabel,test) + + use xc_f03_lib_m, only: xc_f03_functional_get_number + use Definitions, only: u6 + + integer(kind=LibxcInt) :: get_func + character(len=*), intent(in) :: xcLabel + logical(kind=iwp), intent(in), optional :: test + logical(kind=iwp) :: do_test + + if (present(test)) then + do_test = test + else + do_test = .false. + end if + + get_func = xc_f03_functional_get_number(xcLabel) + if ((get_func < 0) .and. (.not. do_test)) then + call WarningMessage(2,' Find_Functional: Undefined functional in Libxc!') + write(u6,*) ' Functional=',trim(xcLabel) + call Quit_OnUserError() + end if + +end function get_func + +subroutine check_supported(Label,flags) + + use xc_f03_lib_m, only: XC_FLAGS_HYB_CAM, XC_FLAGS_HYB_CAMY, XC_FLAGS_HYB_LC, XC_FLAGS_HYB_LCY, XC_FLAGS_VV10 + use Definitions, only: u6 + + character(len=*), intent(in) :: Label + integer(kind=LibxcInt), intent(in) :: flags + integer(kind=iwp) :: lev, lt, maxlev + + maxlev = 0 + lt = len_trim(Label) + + if ((iand(flags,XC_FLAGS_HYB_CAM) > 0) .or. (iand(flags,XC_FLAGS_HYB_CAMY) > 0) .or. (iand(flags,XC_FLAGS_HYB_LC) > 0) .or. & + (iand(flags,XC_FLAGS_HYB_LCY) > 0)) then + lev = 2 + maxlev = max(lev,maxlev) + call WarningMessage(lev,' Find_Functional: Range separation is not supported!') + end if + if ((iand(flags,XC_FLAGS_VV10) > 0)) then + lev = 2 + maxlev = max(lev,maxlev) + call WarningMessage(lev,' Find_Functional: Non-local correlation is not supported!') + end if + if ((Label(lt-1:lt) == '_D') .or. (Label(lt-2:lt) == '_D3')) then + lev = 1 ! make it just a warning for now + maxlev = max(lev,maxlev) + call WarningMessage(lev,' Find_Functional: Dispersion corrections are not implemented!') + end if + if (maxlev > 0) write(u6,*) ' Functional=',trim(Label) + if (maxlev > 1) call Quit_OnUserError() + +end subroutine check_supported + +end module Functionals diff -Nru openmolcas-22.02/src/dft_util/get_denergy.F90 openmolcas-22.10/src/dft_util/get_denergy.F90 --- openmolcas-22.02/src/dft_util/get_denergy.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dft_util/get_denergy.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,31 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Get_dEnergy(Energy) + +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(out) :: Energy +logical(kind=iwp) :: Found_EAV + +Found_EAV = .false. +call Qpg_dScalar('Average energy',Found_EAV) + +if (Found_EAV) then + call Get_dScalar('Average energy',Energy) +else + call Get_dScalar('Last energy',Energy) +end if + +return + +end subroutine Get_dEnergy diff -Nru openmolcas-22.02/src/dft_util/get_exfac.f openmolcas-22.10/src/dft_util/get_exfac.f --- openmolcas-22.02/src/dft_util/get_exfac.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/dft_util/get_exfac.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,76 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Function Get_ExFac(KSDFT) -************************************************************************ -* Return the factor which determines how much "exact exchange" that* -* should be included. * -************************************************************************ - Use Functionals, Only: Get_Func_ExFac - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 Get_ExFac - Character*(*) KSDFT - Character*16 cTmp -* * -************************************************************************ -* * -* Write functional to run file. -* - If (KSDFT.ne.'Overlap') Then - cTmp=KSDFT - Call Put_cArray('DFT functional',cTmp,16) - End If -* * -************************************************************************ -* * - If (KSDFT(1:2).eq.'T:' .or. KSDFT(1:3).eq.'FT:') Then - Get_ExFac=Zero - Return - End If -* * -************************************************************************ -* * -* We bring in only cases where it is different from zero. - Select Case(KSDFT) -* * -************************************************************************ -* * -* CASDFT * -* * - Case ('CASDFT') - Get_ExFac=One -* * -************************************************************************ -* * -* SCF * -* * - Case ('SCF') - Get_ExFac=One -* * -************************************************************************ -* * -* CS * -* * - Case ('CS') - Get_ExFac=One -* * -************************************************************************ -* * - Case Default - Get_ExFac = Get_Func_ExFac(KSDFT) -* * -************************************************************************ -* * - End Select -* * -************************************************************************ -* * - End diff -Nru openmolcas-22.02/src/dft_util/get_exfac.F90 openmolcas-22.10/src/dft_util/get_exfac.F90 --- openmolcas-22.02/src/dft_util/get_exfac.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dft_util/get_exfac.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,76 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +function Get_ExFac(KSDFT) +!*********************************************************************** +! Return the factor which determines how much "exact exchange" that * +! should be included. * +!*********************************************************************** + +use Functionals, only: Get_Func_ExFac +use Constants, only: Zero, One +use Definitions, only: wp + +implicit none +real(kind=wp) :: Get_ExFac +character(len=*), intent(in) :: KSDFT +character(len=80) :: cTmp + +! * +!*********************************************************************** +! * +! Write functional to run file. + +if (KSDFT /= 'Overlap') then + cTmp = KSDFT + call Put_cArray('DFT functional',cTmp,80) +end if +! * +!*********************************************************************** +! * +if ((KSDFT(1:2) == 'T:') .or. (KSDFT(1:3) == 'FT:')) then + Get_ExFac = Zero + return +end if +! * +!*********************************************************************** +! * +! We bring in only cases where it is different from zero. +select case (KSDFT) + ! * + !********************************************************************* + ! * + case ('CASDFT') + Get_ExFac = One + ! * + !********************************************************************* + ! * + case ('SCF') + Get_ExFac = One + ! * + !********************************************************************* + ! * + case ('CS') + Get_ExFac = One + ! * + !********************************************************************* + ! * + case default + Get_ExFac = Get_Func_ExFac(KSDFT) +! * +!*********************************************************************** +! * +end select +! * +!*********************************************************************** +! * + +end function Get_ExFac diff -Nru openmolcas-22.02/src/dft_util/ksdft_info.F90 openmolcas-22.10/src/dft_util/ksdft_info.F90 --- openmolcas-22.02/src/dft_util/ksdft_info.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dft_util/ksdft_info.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,28 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +module KSDFT_Info + +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +private + +integer(kind=iwp) :: ifav, ifav_n, ifiv, ifiv_n, LuMC, LuMT +real(kind=wp) :: CoefR = One, CoefX = One, FA_time, FI_time, Funcaa = Zero, Funcbb = Zero, Funccc = Zero, PUVX_time, sp_time +logical(kind=iwp) :: do_pdftpot +character(len=80) :: KSDFA + +public :: ifav, ifav_n, ifiv, ifiv_n, CoefR, CoefX, FA_time, FI_time, Funcaa, Funcbb, Funccc, KSDFA, LuMC, LuMT, PUVX_time, & + sp_time, do_pdftpot + +end module KSDFT_Info diff -Nru openmolcas-22.02/src/dft_util/KSDFT_Info.f90 openmolcas-22.10/src/dft_util/KSDFT_Info.f90 --- openmolcas-22.02/src/dft_util/KSDFT_Info.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/dft_util/KSDFT_Info.f90 1970-01-01 00:00:00.000000000 +0000 @@ -1,15 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** -Module KSDFT_Info -Character(LEN=16) KSDFA -Real*8 :: funcaa=0.0D0, funcbb=0.0D0 ,funccc=0.0D0 -Integer :: LuMC,LuMT -End Module KSDFT_Info diff -Nru openmolcas-22.02/src/dft_util/libxc_parameters.F90 openmolcas-22.10/src/dft_util/libxc_parameters.F90 --- openmolcas-22.02/src/dft_util/libxc_parameters.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dft_util/libxc_parameters.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,136 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2000,2022, Roland Lindh * +! 2022, Susi Lehtola * +!*********************************************************************** + +module libxc_parameters + +use xc_f03_lib_m, only: XC_CORRELATION, XC_EXCHANGE, xc_f03_aux_func_ids, xc_f03_aux_func_weights, xc_f03_func_end, & + xc_f03_func_get_info, xc_f03_func_info_get_kind, xc_f03_func_info_t, xc_f03_func_init, xc_f03_func_t, & + xc_f03_num_aux_funcs +use Constants, only: Zero +use Definitions, only: wp, iwp, LibxcInt + +implicit none +private + +integer(kind=iwp), parameter :: nFuncs_max = 4 +integer(kind=iwp) :: nFuncs = 0 +integer(kind=LibxcInt) :: func_id(nFuncs_Max) = 0_LibxcInt +real(kind=wp) :: Coeffs(nFuncs_Max) = Zero +type(xc_f03_func_t) :: xc_func(nFuncs_Max) ! xc functional +type(xc_f03_func_info_t) :: xc_info(nFuncs_Max) ! xc functional info + +public :: Coeffs, func_id, Initiate_Libxc_Functionals, libxc_functionals, nFuncs, nFuncs_max, Remove_Libxc_Functionals + +! * +!*********************************************************************** +! * +contains +! * +!*********************************************************************** +! * +subroutine Initiate_Libxc_functionals(nD) + + use nq_Grid, only: l_casdft + use KSDFT_Info, only: CoefR, CoefX + + integer(kind=iwp), intent(in) :: nD + integer(kind=iwp) :: iFunc + real(kind=wp) :: Coeff + + ! if it is a mixed functional and we do MC-PDFT split it up in the components for + ! further analysis. + if ((nFuncs == 1) .and. l_casdft) then + call xc_f03_func_init(xc_func(1),func_id(1),int(nD,kind=LibxcInt)) + nFuncs = max(1,int(xc_f03_num_aux_funcs(xc_func(1)))) + + if (nFuncs /= 1) then + call xc_f03_aux_func_ids(xc_func(1),func_id) + call xc_f03_aux_func_weights(xc_func(1),Coeffs) + end if + call xc_f03_func_end(xc_func(1)) + + end if + do iFunc=1,nFuncs + ! Initialize libxc functional: nD = 2 means spin-polarized + call xc_f03_func_init(xc_func(iFunc),func_id(iFunc),int(nD,kind=LibxcInt)) + ! Get the functional's information + xc_info(iFunc) = xc_f03_func_get_info(xc_func(iFunc)) + + ! Reset coefficients according to input + + Coeff = Coeffs(iFunc) + select case (xc_f03_func_info_get_kind(xc_info(iFunc))) + case (XC_EXCHANGE) + Coeff = Coeff*CoefX + case (XC_CORRELATION) + Coeff = Coeff*CoefR + end select + Coeffs(iFunc) = Coeff + + end do + +end subroutine Initiate_Libxc_functionals +! * +!*********************************************************************** +! * +subroutine Remove_Libxc_functionals() + + integer(kind=iwp) :: iFunc + + do iFunc=1,nFuncs + call xc_f03_func_end(xc_func(iFunc)) + end do + Coeffs(:) = Zero + func_id(:) = 0 + +end subroutine Remove_Libxc_functionals +! * +!*********************************************************************** +! * +subroutine libxc_functionals(mGrid,nD) + + use nq_Grid, only: F_xc, F_xca, F_xcb, l_casdft, vLapl, vRho, vSigma, vTau + + integer(kind=iwp), intent(in) :: mGrid, nD + integer(kind=iwp) :: iFunc + real(kind=wp) :: Coeff + + ! * + !********************************************************************* + ! * + vRho(:,1:mGrid) = Zero + if (allocated(vSigma)) vSigma(:,1:mGrid) = Zero + if (allocated(vTau)) vTau(:,1:mGrid) = Zero + if (allocated(vLapl)) vLapl(:,1:mGrid) = Zero + F_xc(1:mGrid) = Zero + if (l_casdft) then + F_xca(1:mGrid) = Zero + F_xcb(1:mGrid) = Zero + end if + ! * + !********************************************************************* + ! * + + do iFunc=1,nFuncs + Coeff = Coeffs(iFunc) + call libxc_interface(xc_func(iFunc),xc_info(iFunc),mGrid,nD,F_xc,Coeff) + end do + + return + +end subroutine libxc_functionals +! * +!*********************************************************************** +! * +end module libxc_parameters diff -Nru openmolcas-22.02/src/dft_util/ndsd_ts.f90 openmolcas-22.10/src/dft_util/ndsd_ts.f90 --- openmolcas-22.02/src/dft_util/ndsd_ts.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/dft_util/ndsd_ts.f90 1970-01-01 00:00:00.000000000 +0000 @@ -1,112 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** - Subroutine NDSD_Ts(mGrid,nDmat) -!*********************************************************************** -! * -! Object: compute Func for Thomas-Fermi KE functional * -! compute non-TF part (rho_B dependent) of NDSD potential * -! * -! (see J.-M. Garcia Lastra, J. W. Kaminski, T. A. Wesolowski, * -! J. Chem. Phys. 129 (2008) 074107.)* -! * -! Note: for a spin-polarized rho_B (environment density), the * -! NDSD potential is computed using the alpha+beta * -! density, gradient and laplacian. * -! * -!*********************************************************************** - use nq_Grid, only: Rho, GradRho, Lapl - use nq_Grid, only: vRho - use nq_Grid, only: F_xc - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - Real*8 Fexp, Vt_lim - External Fexp, Vt_lim - Real*8 wGradRho(1:3) - Real*8, Parameter:: T_X=1.0D-20 - Real*8, Parameter:: Coeff=1.0D0 -! * -!*********************************************************************** -! * - vRho(:,:)=Zero - Two3=Two/Three - Five3=Five/Three - Cf=(Three/Ten)*(three*Pi**Two)**Two3 - Rho_min=T_X*1.0D-2 -! * -!*********************************************************************** -! * -!---- Compute value of energy and integrand on the grid -! * -!*********************************************************************** -! * - If (nDmat.eq.1) Then - Do iGrid = 1, mGrid - d_sys=Two*Rho(1,iGrid) - If (d_sys.lt.T_X) Go To 100 -! -!------- Kinetic energy contributions -! - functional = Cf*d_sys**Five3 - F_xc(iGrid)=F_xc(iGrid)+Coeff*functional -! -!------- Contributions to the potential -! - Do k=1,3 - wGradRho(k)=Two*GradRho(k,iGrid) - End Do - wLaplRho=Two*Lapl(1,iGrid) -! - dfunc_NDSD = Fexp(d_sys,wGradRho(1))* Vt_lim(d_sys,wGradRho(1),wLaplRho) - vRho(1,iGrid) = vRho(1,iGrid)+ Coeff*dfunc_NDSD -! - 100 Continue -! - End Do -! - ElseIf (nDmat.eq.2) Then - - Cf = Cf*(Two**Two3) - - Do iGrid = 1, mGrid - da_sys =Max(Rho_Min,Rho(1,iGrid)) - db_sys =Max(Rho_Min,Rho(2,iGrid)) - DTot=da_sys+db_sys - If (DTot.lt.T_X) Go To 200 -! -!------- Kinetic energy contributions -! - functional=Cf*(da_sys**Five3+db_sys**Five3) - F_xc(iGrid)=F_xc(iGrid)+Coeff*functional -! -!------- Contributions to the potential -! - Do k=1,3 - wGradRho(k)=Rho(k,iGrid)+Rho(k+3,iGrid) - End Do - wLaplRho=Lapl(1,iGrid)+Lapl(2,iGrid) -! - dfunc_NDSD_alpha = Fexp(DTot,wGradRho(1))* Vt_lim(DTot,wGradRho(1),wLaplRho) - dfunc_NDSD_beta = dfunc_NDSD_alpha -! - vRho(1,iGrid) = vRho(1,iGrid)+ Coeff*dfunc_NDSD_alpha - vRho(2,iGrid) = vRho(2,iGrid)+ Coeff*dfunc_NDSD_beta -! - 200 Continue -! - End Do - - Else - write(6,*) 'In NDSD_Ts: invalid # of densities. nDmat= ',nDmat - Call Abend() - End If -! - Return - End diff -Nru openmolcas-22.02/src/dft_util/ndsd_ts.F90 openmolcas-22.10/src/dft_util/ndsd_ts.F90 --- openmolcas-22.02/src/dft_util/ndsd_ts.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dft_util/ndsd_ts.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,111 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine NDSD_Ts(mGrid,nDmat) +!*********************************************************************** +! * +! Object: compute Func for Thomas-Fermi KE functional * +! compute non-TF part (rho_B dependent) of NDSD potential * +! * +! (see J.-M. Garcia Lastra, J. W. Kaminski, T. A. Wesolowski, * +! J. Chem. Phys. 129 (2008) 074107.)* +! * +! Note: for a spin-polarized rho_B (environment density), the * +! NDSD potential is computed using the alpha+beta * +! density, gradient and laplacian. * +! * +!*********************************************************************** + +use nq_Grid, only: F_xc, GradRho, Lapl, Rho, vRho +use Constants, only: Zero, One, Two, Three, Five, Ten, Pi +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: mGrid, nDmat +integer(kind=iwp) :: iGrid, k +real(kind=wp) :: Cf, d_sys, da_sys, db_sys, dfunc_NDSD, dfunc_NDSD_alpha, dfunc_NDSD_beta, DTot, functional, Rho_min, & + wGradRho(1:3), wLaplRho +real(kind=wp), parameter :: Coeff = One, Five3 = Five/Three, T_X = 1.0e-20_wp, Two3 = Two/Three +real(kind=wp), external :: Fexp, Vt_lim + +! * +!*********************************************************************** +! * +vRho(:,:) = Zero +Cf = (Three/Ten)*(three*Pi**Two)**Two3 +Rho_min = T_X*1.0e-2_wp +! * +!*********************************************************************** +! * +! Compute value of energy and integrand on the grid +! * +!*********************************************************************** +! * +if (nDmat == 1) then + do iGrid=1,mGrid + d_sys = Two*Rho(1,iGrid) + if (d_sys < T_X) cycle + + ! Kinetic energy contributions + + functional = Cf*d_sys**Five3 + F_xc(iGrid) = F_xc(iGrid)+Coeff*functional + + ! Contributions to the potential + + do k=1,3 + wGradRho(k) = Two*GradRho(k,iGrid) + end do + wLaplRho = Two*Lapl(1,iGrid) + + dfunc_NDSD = Fexp(d_sys,wGradRho(1))*Vt_lim(d_sys,wGradRho(1),wLaplRho) + vRho(1,iGrid) = vRho(1,iGrid)+Coeff*dfunc_NDSD + + end do + +else if (nDmat == 2) then + + Cf = Cf*(Two**Two3) + + do iGrid=1,mGrid + da_sys = max(Rho_Min,Rho(1,iGrid)) + db_sys = max(Rho_Min,Rho(2,iGrid)) + DTot = da_sys+db_sys + if (DTot < T_X) cycle + + ! Kinetic energy contributions + + functional = Cf*(da_sys**Five3+db_sys**Five3) + F_xc(iGrid) = F_xc(iGrid)+Coeff*functional + + ! Contributions to the potential + + do k=1,3 + wGradRho(k) = Rho(k,iGrid)+Rho(k+3,iGrid) + end do + wLaplRho = Lapl(1,iGrid)+Lapl(2,iGrid) + + dfunc_NDSD_alpha = Fexp(DTot,wGradRho(1))*Vt_lim(DTot,wGradRho(1),wLaplRho) + dfunc_NDSD_beta = dfunc_NDSD_alpha + + vRho(1,iGrid) = vRho(1,iGrid)+Coeff*dfunc_NDSD_alpha + vRho(2,iGrid) = vRho(2,iGrid)+Coeff*dfunc_NDSD_beta + + end do + +else + write(u6,*) 'In NDSD_Ts: invalid # of densities. nDmat= ',nDmat + call Abend() +end if + +return + +end subroutine NDSD_Ts diff -Nru openmolcas-22.02/src/dft_util/nucatt.f openmolcas-22.10/src/dft_util/nucatt.f --- openmolcas-22.02/src/dft_util/nucatt.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/dft_util/nucatt.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,146 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2000, Roland Lindh * -************************************************************************ - Subroutine NucAtt(mGrid,iSpin) -************************************************************************ -* Author:Roland Lindh, Department of Chemical Physics, University * -* of Lund, SWEDEN. November 2000 * -************************************************************************ - use nq_Grid, only: Grid - use nq_Info - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "stdalloc.fh" -#include "print.fh" -#include "debug.fh" -#include "nsd.fh" -#include "setup.fh" - Real*8, Allocatable:: RA(:,:), ZA(:), Eff(:) - Integer, Allocatable:: nStab(:) -* - Call Get_nAtoms_All(mCenter) - Call mma_allocate(RA,3,mCenter,Label='RA') - Call Get_Coord_All(RA,mCenter) -* - Call mma_allocate(ZA,mCenter,Label='ZA') - Call Get_iScalar('Unique atoms',nCenter) -* - Call mma_allocate(nStab,nCenter,Label='nStab') - Call Get_iArray('nStab',nStab,nCenter) - Call mma_allocate(Eff,nCenter,Label='Eff') - Call Get_dArray('Effective Nuclear Charge',Eff,nCenter) - Call Get_iScalar('nSym',nSym) -* - iOff = 1 - Do i = 1, nCenter - n=nSym/nStab(i) - call dcopy_(n,[Eff(i)],0,ZA(iOff),1) - iOff = iOff + n - End Do -* - Call mma_deallocate(Eff) - Call mma_deallocate(nStab) -* - Call Do_NucAtt_(mGrid, - & iSpin, - & Grid, - & RA,ZA,mCenter) -* - Call mma_deallocate(ZA) - Call mma_deallocate(RA) -* - Return - End - Subroutine Do_NucAtt_(mGrid,iSpin,Grid,RA,ZA,mCenter) -************************************************************************ -* Author:Roland Lindh, Department of Chemical Physics, University * -* of Lund, SWEDEN. November 2000 * -************************************************************************ - use nq_Grid, only: F_xc - use nq_Grid, only: Rho, vRho - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - Real*8 Grid(3,mGrid),RA(3,mCenter),ZA(mCenter) -* * -************************************************************************ -* * -* * -************************************************************************ -* * -* iSpin=1 -* - vRho(:,:)=Zero - If (iSpin.eq.1) Then -* * -************************************************************************ -* * - Do iGrid = 1, mGrid -* - d_alpha=Rho(1,iGrid) - DTot=Two*d_alpha -* -*------- Accumulate contributions to the nuclear attraction energy -* - Attr=Zero - Do i = 1, mCenter - x=Grid(1,iGrid)-RA(1,i) - y=Grid(2,iGrid)-RA(2,i) - z=Grid(3,iGrid)-RA(3,i) - Fact=ZA(i)/Sqrt(x**2+y**2+z**2) - Attr=Attr+Fact - End Do - F_xc(iGrid)=F_xc(iGrid)-Attr*DTot -* - vRho(1,iGrid)=-Attr -* - End Do -* * -************************************************************************ -* * -* iSpin=/=1 -* - Else -* * -************************************************************************ -* * - Do iGrid = 1, mGrid -* - d_alpha=Rho(1,iGrid) - d_beta =Rho(2,iGrid) - DTot=d_alpha+d_beta -* -*------- Accumulate contributions to the nuclear attraction energy -* - Attr=Zero - Do i = 1, mCenter - x=Grid(1,iGrid)-RA(1,i) - y=Grid(2,iGrid)-RA(2,i) - z=Grid(3,iGrid)-RA(3,i) - Fact=ZA(i)/Sqrt(x**2+y**2+z**2) - Attr=Attr+Fact - End Do - F_xc(iGrid)=F_xc(iGrid)-Attr*DTot -* - vRho(1,iGrid)=-Attr - vRho(2,iGrid)=-Attr -* - End Do -* * -************************************************************************ -* * - End If -* * -************************************************************************ -* * -* - Return - End diff -Nru openmolcas-22.02/src/dft_util/nucatt.F90 openmolcas-22.10/src/dft_util/nucatt.F90 --- openmolcas-22.02/src/dft_util/nucatt.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dft_util/nucatt.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,128 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2000, Roland Lindh * +!*********************************************************************** + +subroutine NucAtt(mGrid,iSpin) +!*********************************************************************** +! Author:Roland Lindh, Department of Chemical Physics, University * +! of Lund, SWEDEN. November 2000 * +!*********************************************************************** + +use nq_Grid, only: F_xc, Grid, Rho, vRho +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, Two +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: mGrid, iSpin +integer(kind=iwp) :: i, iGrid, iOff, mCenter, n, nCenter, nSym +real(kind=wp) :: Attr, d_alpha, d_beta, DTot, Fact, x, y, z +integer(kind=iwp), allocatable :: nStab(:) +real(kind=wp), allocatable :: Eff(:), RA(:,:), ZA(:) + +call Get_nAtoms_All(mCenter) +call mma_allocate(RA,3,mCenter,Label='RA') +call Get_Coord_All(RA,mCenter) + +call Get_iScalar('Unique atoms',nCenter) +call mma_allocate(nStab,nCenter,Label='nStab') +call Get_iArray('nStab',nStab,nCenter) +call mma_allocate(Eff,nCenter,Label='Eff') +call Get_dArray('Effective Nuclear Charge',Eff,nCenter) + +call Get_iScalar('nSym',nSym) + +call mma_allocate(ZA,mCenter,Label='ZA') +iOff = 0 +do i=1,nCenter + n = nSym/nStab(i) + ZA(iOff+1:iOff+n) = Eff(i) + iOff = iOff+n +end do + +call mma_deallocate(Eff) +call mma_deallocate(nStab) + +! * +!*********************************************************************** +! * + +vRho(:,:) = Zero +if (iSpin == 1) then + ! iSpin=1 + ! * + !********************************************************************* + ! * + do iGrid=1,mGrid + + d_alpha = Rho(1,iGrid) + DTot = Two*d_alpha + + ! Accumulate contributions to the nuclear attraction energy + + Attr = Zero + do i=1,mCenter + x = Grid(1,iGrid)-RA(1,i) + y = Grid(2,iGrid)-RA(2,i) + z = Grid(3,iGrid)-RA(3,i) + Fact = ZA(i)/sqrt(x**2+y**2+z**2) + Attr = Attr+Fact + end do + F_xc(iGrid) = F_xc(iGrid)-Attr*DTot + + vRho(1,iGrid) = -Attr + + end do + ! * + !********************************************************************* + ! * +else + ! iSpin=/=1 + ! * + !********************************************************************* + ! * + do iGrid=1,mGrid + + d_alpha = Rho(1,iGrid) + d_beta = Rho(2,iGrid) + DTot = d_alpha+d_beta + + ! Accumulate contributions to the nuclear attraction energy + + Attr = Zero + do i=1,mCenter + x = Grid(1,iGrid)-RA(1,i) + y = Grid(2,iGrid)-RA(2,i) + z = Grid(3,iGrid)-RA(3,i) + Fact = ZA(i)/sqrt(x**2+y**2+z**2) + Attr = Attr+Fact + end do + F_xc(iGrid) = F_xc(iGrid)-Attr*DTot + + vRho(1,iGrid) = -Attr + vRho(2,iGrid) = -Attr + + end do + ! * + !********************************************************************* + ! * +end if +! * +!*********************************************************************** +! * + +call mma_deallocate(ZA) +call mma_deallocate(RA) + +return + +end subroutine NucAtt diff -Nru openmolcas-22.02/src/dft_util/ofembed.f90 openmolcas-22.10/src/dft_util/ofembed.f90 --- openmolcas-22.02/src/dft_util/ofembed.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/dft_util/ofembed.f90 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -! * -! Copyright (C) 2021, Roland Lindh * -!*********************************************************************** -Module OFembed -Private -Public:: Do_OFemb, KEonly, OFE_first, OFE_KSDFT, ThrFThaw, Xsigma, dFMD, FMaux -Public::Rep_EN,Func_AB,Func_A,Func_B,Energy_NAD,V_Nuc_AB,V_Nuc_BA,V_emb -Public::Do_Core - -Logical:: Do_OFemb=.False., KEonly=.False., OFE_first=.True. -Logical:: Do_Core=.False. -Character(LEN=16):: OFE_KSDFT='' -#ifdef _NOT_USED_ -Integer:: ip_NDSD=-696696, l_NDSD=0 -#endif -Real*8:: ThrFThaw=0.0D0, Xsigma=1.0d4, dFMD=0.0D0 -Real*8, Allocatable:: FMaux(:) -Real*8::Rep_EN,Func_AB,Func_A,Func_B,Energy_NAD,V_Nuc_AB,V_Nuc_BA,V_emb - -End Module OFembed diff -Nru openmolcas-22.02/src/dft_util/ofembed.F90 openmolcas-22.10/src/dft_util/ofembed.F90 --- openmolcas-22.02/src/dft_util/ofembed.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dft_util/ofembed.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,31 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Roland Lindh * +!*********************************************************************** + +module OFembed + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +private + +logical(kind=iwp) :: Do_Core = .false., Do_OFemb = .false., KEonly = .false., OFE_first = .true. +character(len=80) :: OFE_KSDFT = '' +real(kind=wp) :: dFMD = Zero, Energy_NAD, Func_A, Func_AB, Func_B, Rep_EN, ThrFThaw = Zero, V_emb, V_Nuc_AB, V_Nuc_BA, & + Xsigma = 1.0e4_wp +real(kind=wp), allocatable :: FMaux(:), NDSD(:,:) + +public :: dFMD, Do_Core, Do_OFemb, Energy_NAD, FMaux, Func_A, Func_AB, Func_B, KEonly, NDSD, OFE_first, OFE_KSDFT, Rep_EN, & + ThrFThaw, V_emb, V_Nuc_AB, V_Nuc_BA, Xsigma + +end module OFembed diff -Nru openmolcas-22.02/src/dft_util/ofe_print.f openmolcas-22.10/src/dft_util/ofe_print.f --- openmolcas-22.02/src/dft_util/ofe_print.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/dft_util/ofe_print.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,94 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine OFE_print(Energy_A) - - use OFembed, only: dFMD - use OFembed, only: Rep_EN,Func_AB,Func_A,Func_B,Energy_NAD, - & V_Nuc_AB,V_Nuc_BA,V_emb - Implicit Real*8 (a-h,o-z) -#include "Molcas.fh" - Real*8 ReCharge(MxAtom) - Character*16 NamRfil - Character*10 Fmt - Integer Cho_X_GetTol - External Cho_X_GetTol -* - Call Get_iScalar('nSym',nSym) - Call Get_iScalar('Unique atoms',nAtoms) - Call Get_dArray('Effective nuclear Charge',ReCharge,nAtoms) -* - Call Get_NameRun(NamRfil) - Call NameRun('AUXRFIL') - Call PotNuc_nad(nSym,nAtoms,ReCharge,ZRE_nad) -* - Call Get_dEnergy(Energy_B) - If (dFMD.gt.0.0) Call Get_dScalar('KSDFT energy',Ec_A) -* - Call NameRun(NamRfil) -* - iTol = Cho_X_GetTol(8) - Call Add_Info('V_OFE',[V_emb],1,iTol) - Call Add_Info('V_NUC',[V_Nuc_AB],1,iTol) - Call Add_Info('E_NAD',[Energy_NAD],1,iTol) - Call Add_Info('RP_EN',[Rep_EN],1,iTol) -* - Fmt='(A,F19.10)' - write(6,*) - write(6,*) ' -----------------------------------------------' - write(6,*) ' Orbital-Free Embedding Calculation : Results ' - write(6,*) ' -----------------------------------------------' - write(6,Fmt)' DFT energy (A) : ', Func_A - write(6,Fmt)' DFT energy (B) : ', Func_B - write(6,Fmt)' DFT energy (A+B) : ', Func_AB - write(6,*) - write(6,Fmt)' Nonelectr. Vemb : ', V_emb ! for - write(6,*) - write(6,Fmt)' Energy (A) : ', Energy_A - write(6,Fmt)' Energy (B) : ', Energy_B - write(6,Fmt)' DFT energy (NAD) : ', Energy_NAD - write(6,Fmt)' Vnuc(B)*rhoA : ', V_Nuc_AB - write(6,Fmt)' Vnuc(A)*rhoB : ', V_Nuc_BA - write(6,Fmt)' Electr. repulsion : ', Rep_EN - write(6,*) ' -----------------------------------------------' - write(6,Fmt)' Nuclear rep. (A--B) : ', ZRE_nad - write(6,Fmt)' Energy (A+B) : ', Energy_B+Energy_A - & +Energy_NAD - & +V_Nuc_AB - & +V_Nuc_BA - & +Rep_EN - & +ZRE_nad - If(dFMD.gt.0.0) write(6,Fmt)' SCF restoring Ec(A) : ', Ec_A - write(6,*) ' -----------------------------------------------' - write(6,*) - write(6,*) -* - Call Put_dScalar('NAD dft energy',Energy_NAD) - Return - End -************************************************************************ -* -************************************************************************ - Subroutine Get_dEnergy(Energy) - Implicit Real*8 (a-h,o-z) - Real*8 Energy - Logical Found_EAV - - Found_EAV=.false. - Call Qpg_dScalar('Average energy',Found_EAV) - - If (Found_EAV) Then - Call Get_dScalar('Average energy',Energy) - Else - Call Get_dScalar('Last energy',Energy) - EndIf - - Return - End diff -Nru openmolcas-22.02/src/dft_util/ofe_print.F90 openmolcas-22.10/src/dft_util/ofe_print.F90 --- openmolcas-22.02/src/dft_util/ofe_print.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dft_util/ofe_print.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,78 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine OFE_print(Energy_A) + +use OFembed, only: dFMD, Energy_NAD, Func_A, Func_AB, Func_B, Rep_EN, V_emb, V_Nuc_AB, V_Nuc_BA +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +real(kind=wp), intent(in) :: Energy_A +integer(kind=iwp) :: iTol, nAtoms, nSym +real(kind=wp) :: Ec_A, Energy_B, ZRE_nad +character(len=16) :: NamRfil +real(kind=wp), allocatable :: ReCharge(:) +integer(kind=iwp), external :: Cho_X_GetTol + +call Get_iScalar('nSym',nSym) +call Get_iScalar('Unique atoms',nAtoms) +call mma_allocate(ReCharge,nAtoms,label='ReCharge') +call Get_dArray('Effective nuclear Charge',ReCharge,nAtoms) + +call Get_NameRun(NamRfil) +call NameRun('AUXRFIL') +call PotNuc_nad(nSym,nAtoms,ReCharge,ZRE_nad) +call mma_deallocate(ReCharge) + +call Get_dEnergy(Energy_B) +if (dFMD > Zero) call Get_dScalar('KSDFT energy',Ec_A) + +call NameRun(NamRfil) + +iTol = Cho_X_GetTol(8) +call Add_Info('V_OFE',[V_emb],1,iTol) +call Add_Info('V_NUC',[V_Nuc_AB],1,iTol) +call Add_Info('E_NAD',[Energy_NAD],1,iTol) +call Add_Info('RP_EN',[Rep_EN],1,iTol) + +write(u6,*) +write(u6,*) ' -----------------------------------------------' +write(u6,*) ' Orbital-Free Embedding Calculation : Results ' +write(u6,*) ' -----------------------------------------------' +write(u6,100) ' DFT energy (A) : ',Func_A +write(u6,100) ' DFT energy (B) : ',Func_B +write(u6,100) ' DFT energy (A+B) : ',Func_AB +write(u6,*) +write(u6,100) ' Nonelectr. Vemb : ',V_emb ! for +write(u6,*) +write(u6,100) ' Energy (A) : ',Energy_A +write(u6,100) ' Energy (B) : ',Energy_B +write(u6,100) ' DFT energy (NAD) : ',Energy_NAD +write(u6,100) ' Vnuc(B)*rhoA : ',V_Nuc_AB +write(u6,100) ' Vnuc(A)*rhoB : ',V_Nuc_BA +write(u6,100) ' Electr. repulsion : ',Rep_EN +write(u6,*) ' -----------------------------------------------' +write(u6,100) ' Nuclear rep. (A--B) : ',ZRE_nad +write(u6,100) ' Energy (A+B) : ',Energy_B+Energy_A+Energy_NAD+V_Nuc_AB+V_Nuc_BA+Rep_EN+ZRE_nad +if (dFMD > Zero) write(u6,100) ' SCF restoring Ec(A) : ',Ec_A +write(u6,*) ' -----------------------------------------------' +write(u6,*) +write(u6,*) + +call Put_dScalar('NAD dft energy',Energy_NAD) + +return + +100 format(A,F19.10) + +end subroutine OFE_print diff -Nru openmolcas-22.02/src/dft_util/overlap.f openmolcas-22.10/src/dft_util/overlap.f --- openmolcas-22.02/src/dft_util/overlap.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/dft_util/overlap.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,87 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2000, Roland Lindh * -************************************************************************ - Subroutine Overlap(mGrid,iSpin) -************************************************************************ -* Author:Roland Lindh, Department of Chemical Physics, University * -* of Lund, SWEDEN. November 2000 * -************************************************************************ - use nq_Grid, only: F_xc - use nq_Grid, only: Rho, vRho - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - Real*8, Parameter:: T_x=1.0D-20 -* * -************************************************************************ -* * -* * -************************************************************************ -* * -* iSpin=1 -* - vRho(:,:)=Zero - Rho_Min=T_X*1.0D-2 - If (iSpin.eq.1) Then -* * -************************************************************************ -* * - Do iGrid = 1, mGrid -* - d_alpha=Rho(1,iGrid) - DTot=Two*d_alpha - If (DTot.lt.T_X) Go To 199 -* -*------- Accumulate contributions to the integrated density -* - F_xc(iGrid)=F_xc(iGrid)+Dtot -* - vRho(1,iGrid)=One -* - 199 Continue -* - End Do -* * -************************************************************************ -* * -* iSpin=/=1 -* - Else -* * -************************************************************************ -* * - Do iGrid = 1, mGrid -* - d_alpha=Max(Rho_min,Rho(1,iGrid)) - d_beta =Max(Rho_min,Rho(2,iGrid)) - DTot=d_alpha+d_beta - If (DTot.lt.T_X) Go To 299 -* -*------- Accumulate contributions to the integrated density -* - F_xc(iGrid)=F_xc(iGrid)+Dtot -* - vRho(1,iGrid)=One - vRho(2,iGrid)=One -* - 299 Continue -* - End Do -* * -************************************************************************ -* * - End If -* * -************************************************************************ -* * -* - Return - End diff -Nru openmolcas-22.02/src/dft_util/overlap.F90 openmolcas-22.10/src/dft_util/overlap.F90 --- openmolcas-22.02/src/dft_util/overlap.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dft_util/overlap.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,87 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2000, Roland Lindh * +!*********************************************************************** + +subroutine Overlap(mGrid,iSpin) +!*********************************************************************** +! Author:Roland Lindh, Department of Chemical Physics, University * +! of Lund, SWEDEN. November 2000 * +!*********************************************************************** + +use nq_Grid, only: F_xc, Rho, vRho +use Constants, only: Zero, One, Two +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: mGrid, iSpin +integer(kind=iwp) :: iGrid +real(kind=wp) :: d_alpha, d_beta, DTot, Rho_Min +real(kind=wp), parameter :: T_x = 1.0e-20_wp + +! * +!*********************************************************************** +! * + +vRho(:,:) = Zero +Rho_Min = T_X*1.0e-2_wp +if (iSpin == 1) then + ! iSpin=1 + ! * + !********************************************************************* + ! * + do iGrid=1,mGrid + + d_alpha = Rho(1,iGrid) + DTot = Two*d_alpha + if (DTot < T_X) cycle + + ! Accumulate contributions to the integrated density + + F_xc(iGrid) = F_xc(iGrid)+Dtot + + vRho(1,iGrid) = One + + end do + ! * + !********************************************************************* + ! * +else + ! iSpin=/=1 + ! * + !********************************************************************* + ! * + do iGrid=1,mGrid + + d_alpha = max(Rho_min,Rho(1,iGrid)) + d_beta = max(Rho_min,Rho(2,iGrid)) + DTot = d_alpha+d_beta + if (DTot < T_X) cycle + + ! Accumulate contributions to the integrated density + + F_xc(iGrid) = F_xc(iGrid)+Dtot + + vRho(1,iGrid) = One + vRho(2,iGrid) = One + + end do + ! * + !********************************************************************* + ! * +end if +! * +!*********************************************************************** +! * + +return + +end subroutine Overlap diff -Nru openmolcas-22.02/src/dft_util/vemb_exc_states.F90 openmolcas-22.10/src/dft_util/vemb_exc_states.F90 --- openmolcas-22.02/src/dft_util/vemb_exc_states.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dft_util/vemb_exc_states.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,92 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2010,2012,2017, Francesco Aquilante * +! 2015,2017, Alexander Zech * +!*********************************************************************** + +subroutine VEMB_Exc_states(Vemb,nVemb,xKSDFT,Func_Bx) + +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, Half +use Definitions, only: wp, iwp, u6, r8 + +implicit none +integer(kind=iwp), intent(in) :: nVemb +real(kind=wp), intent(inout) :: Vemb(nVemb) +character(len=*), intent(in) :: xKSDFT +real(kind=wp), intent(in) :: Func_Bx +#include "rasdim.fh" +#include "rasscf.fh" +#include "general.fh" +integer(kind=iwp) :: IAD12, KROOT, nDummy +real(kind=wp) :: DFT_NAD, Dummy(1), Func_A, Func_AB, Vemb_Xstate +character(len=16) :: MyNamRfil +real(kind=wp), allocatable :: D1ao_b(:), DState(:), F_DFT(:), xxCMO(:), xxOCCN(:) +real(kind=r8), external :: ddot_ + +nDummy = 1 +Dummy(1) = Zero + +IAD12 = IADR15(12) + +call mma_allocate(xxCMO,NTOT2,Label='xxCMO') +call mma_allocate(xxOCCN,NTOT,Label='xxOCCN') +call mma_allocate(DState,NTOT1,Label='DState') +call mma_allocate(F_DFT,nVemb,Label='F_DFT') +call mma_allocate(D1ao_b,nVemb,Label='D1ao_b') + +do KROOT=1,LROOTS + + ! Read natural orbitals + if (NAC > 0) then + call DDAFILE(JOBIPH,2,xxCMO,NTOT2,IAD12) + call DDAFILE(JOBIPH,2,xxOCCN,NTOT,IAD12) + end if + ! Get GS and excited state densities: + ! Fill allocated mem with zeroes. + DSTATE(:) = Zero + + call DONE_RASSCF(xxCMO,xxOCCN,DState) ! computes D=CnC' + ! Nonelectr. Vemb with GS and excited state density + Vemb_Xstate = ddot_(nVemb,Vemb,1,DState,1) + !write(u6,*) 'Kroot, Vemb_K ',KROOT,Vemb_Xstate + write(u6,'(A,F19.10,3X,A,I3)') 'Nonelectr. Vemb w. rhoA_emb =',Vemb_Xstate,'root = ',KROOT + ! E_xc,T[rhoA] + Func_A = Zero + F_DFT(:) = Zero + DState(1:nVemb) = Half*DState(1:nVemb) + call wrap_DrvNQ(xKSDFT,F_DFT,1,Func_A,DState,nVemb,1,.false.,Dummy,nDummy,'SCF ') + !write(u6,*) 'Kroot, Func_A ',KROOT,Func_A + ! E_xc,T[rhoA+rhoB] + call Get_NameRun(MyNamRfil) ! save current Runfile name + call NameRun('AUXRFIL') ! switch RUNFILE name + call Get_D1ao(D1ao_b,nVemb) + DState(1:nVemb) = DState(1:nVemb)+Half*D1ao_b(:) + + Func_AB = Zero + F_DFT(:) = Zero + call wrap_DrvNQ(xKSDFT,F_DFT,1,Func_AB,DState,nVemb,1,.false.,Dummy,nDummy,'SCF ') + !write(u6,*) 'Kroot, Func_AB',KROOT,Func_AB + !write(u6,*) 'Kroot, Func_Bx',KROOT,Func_Bx + ! Calculate DFT NAD for all densities: + DFT_NAD = Func_AB-Func_A-Func_Bx + write(u6,'(A,F19.10,3X,A,I3)') 'DFT energy (NAD) = ',DFT_NAD,'root = ',KROOT + call NameRun(MyNamRfil) ! go back to MyNamRfil +end do +call mma_deallocate(D1ao_b) +call mma_deallocate(F_DFT) +call mma_deallocate(DState) +call mma_deallocate(xxCMO) +call mma_deallocate(xxOCCN) + +return + +end subroutine VEMB_Exc_states diff -Nru openmolcas-22.02/src/dft_util/vt_lim.F90 openmolcas-22.10/src/dft_util/vt_lim.F90 --- openmolcas-22.02/src/dft_util/vt_lim.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dft_util/vt_lim.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,30 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2010, Francesco Aquilante * +!*********************************************************************** + +function Vt_lim(rho,drho,ddrho) + +use Constants, only: One, Two, Quart +use Definitions, only: wp + +implicit none +real(kind=wp) :: Vt_lim +real(kind=wp), intent(in) :: rho, drho(3), ddrho +real(kind=wp) :: rhoinv, rhoinv2, xnorm + +rhoinv = One/rho +rhoinv2 = rhoinv**Two +xnorm = drho(1)**2+drho(2)**2+drho(3)**2 + +Vt_lim = 0.125_wp*xnorm*rhoinv2-Quart*ddrho*rhoinv + +end function Vt_lim diff -Nru openmolcas-22.02/src/dft_util/wrap_drvnq.F90 openmolcas-22.10/src/dft_util/wrap_drvnq.F90 --- openmolcas-22.02/src/dft_util/wrap_drvnq.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dft_util/wrap_drvnq.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,63 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2010,2012,2017, Francesco Aquilante * +! 2015,2017, Alexander Zech * +!*********************************************************************** + +subroutine Wrap_DrvNQ(KSDFT,F_DFT,nFckDim,Func,D_DS,nh1,nD_DS,Do_Grad,Grad,nGrad,DFTFOCK) + +use nq_Info, only: Dens_I, Grad_I, mBas, mIrrep, nAsh, nFro, nIsh, Tau_I +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +character(len=*), intent(in) :: KSDFT +integer(kind=iwp), intent(in) :: nFckDim, nh1, nD_DS, nGrad +real(kind=wp), intent(inout) :: F_DFT(nh1,nFckDim), Grad(nGrad) +real(kind=wp), intent(out) :: Func +real(kind=wp), intent(in) :: D_DS(nh1,nD_DS) +logical(kind=iwp), intent(in) :: Do_Grad +character(len=4), intent(in) :: DFTFOCK +integer(kind=iwp) :: nOrbA +logical(kind=iwp) :: Do_MO, Do_TwoEl, F_nAsh + +! * +!*********************************************************************** +! * +! DFT functionals, compute integrals over the potential + +Func = Zero +Dens_I = Zero +Grad_I = Zero +Tau_I = Zero +Do_MO = .false. +Do_TwoEl = .false. + +call Get_iScalar('nSym',mIrrep) +call Get_iArray('nBas',mBas(0),mIrrep) +call Get_iArray('nFro',nFro(0),mIrrep) +call Get_iArray('nIsh',nIsh(0),mIrrep) +call qpg_iArray('nAsh',F_nAsh,nOrbA) +if ((.not. F_nAsh) .or. (nOrbA == 0)) then + nAsh(0:mIrrep-1) = 0 +else + call Get_iArray('nAsh',nAsh(0),mIrrep) +end if +! * +!*********************************************************************** +! * +call Driver(KSDFT,Do_Grad,Func,Grad,nGrad,Do_MO,Do_TwoEl,D_DS,F_DFT,nh1,nFckDim,DFTFOCK) +! * +!*********************************************************************** +! * +return + +end subroutine Wrap_DrvNQ diff -Nru openmolcas-22.02/src/dft_util/xlambda.F90 openmolcas-22.10/src/dft_util/xlambda.F90 --- openmolcas-22.02/src/dft_util/xlambda.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dft_util/xlambda.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,30 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2010,2012,2017, Francesco Aquilante * +! 2015,2017, Alexander Zech * +!*********************************************************************** + +function Xlambda(omega,sigma) + +use Constants, only: One +use Definitions, only: wp + +implicit none +real(kind=wp) :: Xlambda +real(kind=wp), intent(in) :: omega, sigma + +if (sigma*omega > 42.0_wp) then + Xlambda = One +else + Xlambda = One-exp(-sigma*omega) +end if + +end function Xlambda diff -Nru openmolcas-22.02/src/dice_util/CMakeLists.txt openmolcas-22.10/src/dice_util/CMakeLists.txt --- openmolcas-22.02/src/dice_util/CMakeLists.txt 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dice_util/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,22 @@ +#*********************************************************************** +# This file is part of OpenMolcas. * +# * +# OpenMolcas is free software; you can redistribute it and/or modify * +# it under the terms of the GNU Lesser General Public License, v. 2.1. * +# OpenMolcas is distributed in the hope that it will be useful, but it * +# is provided "as is" and without any express or implied warranties. * +# For more details see the full text of the license in the file * +# LICENSE or in . * +#*********************************************************************** + +set (sources + molcas2dice.F90 + dicectl.F90 + dice_densi_rasscf.F90 + dice_load2pdm.F90 +) + +# Source files defining modules that should be available to other *_util directories +set (modfile_list "") + +include (${PROJECT_SOURCE_DIR}/cmake/util_template.cmake) diff -Nru openmolcas-22.02/src/dice_util/dicectl.F90 openmolcas-22.10/src/dice_util/dicectl.F90 --- openmolcas-22.02/src/dice_util/dicectl.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dice_util/dicectl.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,208 @@ +!********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2022, Quan Phung * +!*********************************************************************** +! Main control file for DICE. Template from CheMPS2 interface. + +subroutine DiceCtl(W1,TUVX,IFINAL,IRST) + +#ifdef _MOLCAS_MPP_ +use MPI, only: MPI_COMM_WORLD +use Para_Info, only: Is_Real_Par, King +use Definitions, only: MPIInt +#endif +use Index_Functions, only: nTri_Elem +use rasscf_data, only: dice_eps1, dice_eps2, dice_iter, dice_restart, dice_sampleN, dice_stoc, diceocc, ENER, ITER, lroots, mxSym, & + NAC, nref_dice +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, Ten +use Definitions, only: wp, iwp, u6 + +implicit none +real(kind=wp), intent(in) :: W1(*), TUVX(*) +integer(kind=iwp), intent(in) :: IFINAL, IRST +#include "general.fh" +integer(kind=iwp) :: chemroot, iChMolpro(8), iErr, iOper(0:7), iOrb, iref_dice, iSigma, iSym, jOrb, LINSIZE, lSymMolpro, LUDICEIN, & + LUTOTE, nIrrep, NUM_TEI +integer(kind=iwp), allocatable :: OrbSym(:) +#ifdef _MOLCAS_MPP_ +integer(kind=MPIInt) :: IERROR +#endif +real(kind=wp) :: pt2ener +logical(kind=iwp) :: Found +character(len=3) :: dice_nprocs, Label +character(len=10) :: rootindex +character(len=150) :: imp1, imp2 +integer(kind=iwp), external :: isFreeUnit + +#include "macros.fh" +unused_var(IFINAL) + +! Quan: FIXME: Do we need this? +! Load symmetry info from RunFile +iOper = 0 +call Get_iScalar('NSYM',nIrrep) +call Get_iArray('Symmetry operations',iOper,nIrrep) +call Get_iScalar('Rotational Symmetry Number',iSigma) + +! Get character table to convert MOLPRO symmetry format +call MOLPRO_ChTab(nSym,Label,iChMolpro) + +! Convert orbital symmetry into MOLPRO format +call mma_allocate(OrbSym,NAC,label='OrbSym') +iOrb = 1 +do iSym=1,nSym + do jOrb=1,NASH(iSym) + OrbSym(iOrb) = iChMolpro(iSym) + iOrb = iOrb+1 + end do +end do +lSymMolpro = iChMolpro(stSym) + +!********************* +! WRITEOUT FCIDUMP * +!********************* + +LINSIZE = nTri_Elem(NAC) +NUM_TEI = nTri_Elem(LINSIZE) +call FCIDUMP_OUTPUT(NAC,NACTEL,ISPIN-1,lSymMolpro,OrbSym,Zero,W1,TUVX,LINSIZE,NUM_TEI) + +call mma_deallocate(OrbSym) +! Dice only reads FCIDUMP file +call systemf('ln -sf FCIDUMP_CHEMPS2 FCIDUMP',iErr) + +!************************ +! WRITEOUT INPUT FILE * +!************************ +#ifdef _MOLCAS_MPP_ +if (KING() .or. (.not. Is_Real_Par())) then +#endif + if (IRST == 0) then + ! Cleanup dice.out.total + imp1 = 'dice.out.total' + call f_inquire(imp1,Found) + if (Found) call aixrm(imp1) + end if +#ifdef _MOLCAS_MPP_ +end if +#endif + +write(u6,*) 'DICE> INTERATION : ',ITER +LUDICEIN = isFreeUnit(30) +call molcas_open(LUDICEIN,'input.dat') + +write(LUDICEIN,'(a4,i4)') 'nocc',NACTEL +do iref_dice=1,nref_dice + write(LUDICEIN,'(a)') trim(diceocc(iref_dice)) +end do +write(LUDICEIN,'(a3)') 'end' +write(LUDICEIN,'(a6,i3)') 'nroots',lroots +write(LUDICEIN,*) +write(LUDICEIN,'(a8)') 'schedule' +write(LUDICEIN,'(a1,e12.5)') '0',dice_eps1*Ten +write(LUDICEIN,'(a1,e12.5)') '3',dice_eps1*Ten +write(LUDICEIN,'(a1,e12.5)') '6',dice_eps1 +write(LUDICEIN,'(a3)') 'end' +write(LUDICEIN,'(a7,i6)') 'maxiter',dice_iter +write(LUDICEIN,'(a5)') 'DoRDM' +write(LUDICEIN,'(a8)') 'dE 1.e-8' +write(LUDICEIN,*) +write(LUDICEIN,'(a7,i6)') 'SampleN',dice_sampleN +write(LUDICEIN,'(a8,e12.5)') 'epsilon2',dice_eps2 +write(LUDICEIN,'(a18)') 'targetError 8.0e-5' +if (IRST > 0 .or. dice_restart) then + write(LUDICEIN,'(a11)') 'fullrestart' +end if + +if (.not. dice_stoc) then + write(LUDICEIN,'(a13)') 'deterministic' +else + write(LUDICEIN,'(a13,e12.5)') 'epsilon2Large',dice_eps2*Ten +end if + +close(LUDICEIN) + +!***************************** +! RUN DICE * +!***************************** + +#ifdef _MOLCAS_MPP_ +if (KING() .or. (.not. Is_Real_Par())) then +#endif + call get_environment_variable("MOLCAS_DICE",dice_nprocs,status=ierr) + if (ierr == 0) then + imp2 = 'mpirun -np '//trim(adjustl(dice_nprocs))//' Dice >dice.out 2>dice.err' + else + imp2 = 'Dice >dice.out 2>dice.err' + end if + + call systemf(imp2,iErr) + if (iErr /= 0) then + write(u6,*) 'DICE> DICE ends abnormally, check calculation' + end if + call systemf('cat dice.out >> dice.out.total',iErr) +#ifdef _MOLCAS_MPP_ +end if + +if (Is_Real_Par()) then + call MPI_Barrier(MPI_COMM_WORLD,IERROR) +end if + +if (Is_Real_Par() .and. (.not. KING())) then + do chemroot=1,lroots + write(rootindex,'(i2)') chemroot-1 + imp1 = 'ln -sf ../spatialRDM.'//trim(adjustl(rootindex))//'.'//trim(adjustl(rootindex))//'.txt .' + call systemf(imp1,iErr) + end do + call systemf("ln -sf ../dice.out .",iErr) +end if +#endif + +!***************************** +! EXTRACT ENERGY * +!***************************** + +if (.not. dice_stoc) then + imp1 = 'grep PTEnergy dice.out | cut -c 10- > dice.energy' + call systemf(imp1,iErr) +else + do chemroot=1,lroots + write(rootindex,'(i2)') chemroot+2 + imp1 = 'grep -A '//trim(adjustl(rootindex))// & + ' "VARIATIONAL CALCULATION RESULT" dice.out | tail -n 1 | cut -c 6-30 >> dice.energy' + call systemf(imp1,iErr) + end do + imp2 = 'grep +/- dice.out | cut -c 10- > PT2.energy' + call systemf(imp2,iErr) +end if + +LUTOTE = isFreeUnit(30) +call molcas_open(LUTOTE,'dice.energy') + +do chemroot=1,lroots + read(LUTOTE,*) ENER(chemroot,ITER) + write(u6,*) 'DICE> Deterministic PT2 Energy: ',ENER(chemroot,ITER) +end do +close(LUTOTE) + +if (dice_stoc) then + call molcas_open(LUTOTE,'PT2.energy') + + do chemroot=1,lroots + read(LUTOTE,*) pt2ener + write(u6,*) 'DICE> Stochastic PT2 Energy: ',pt2ener + end do + close(LUTOTE) +end if + +return + +end subroutine DiceCtl diff -Nru openmolcas-22.02/src/dice_util/dice_densi_rasscf.F90 openmolcas-22.10/src/dice_util/dice_densi_rasscf.F90 --- openmolcas-22.02/src/dice_util/dice_densi_rasscf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dice_util/dice_densi_rasscf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,71 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2017, Quan Phung * +!*********************************************************************** + +subroutine DICE_DENSI_RASSCF(jRoot,D,DS,PS,PA,PT) + +use rasscf_data, only: mxSym, NAC, NACPAR, NACPR2 +use Constants, only: Zero, Half +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: jRoot +real(kind=wp), intent(out) :: D(NACPAR), DS(NACPAR), PS(NACPR2), PA(NACPR2), PT(NAC,NAC,NAC,NAC) +#include "general.fh" +integer(kind=iwp) :: I, IJ_pack, IJKL_pack, J, K, L, LLIM +real(kind=wp) :: D1sum + +D(:) = Zero +DS(:) = Zero +PS(:) = Zero +PA(:) = Zero + +if (NACTEL <= 1) then + write(u6,*) 'Dice does not allow 1 electron.' + return +end if + +call dice_load2pdm(NAC,PT,jRoot) +IJ_pack = 1 +do J=1,NAC + do I=1,J + D1sum = Zero + do K=1,NAC + D1sum = D1sum+PT(K,K,I,J) + end do + D(IJ_pack) = D1sum/(NACTEL-1) + IJ_pack = IJ_pack+1 + end do +end do + +IJKL_pack = 0 +do I=1,NAC + do J=1,I + do K=1,I + LLIM = K + if (K == I) LLIM = J + do L=1,LLIM + IJKL_pack = IJKL_pack+1 + if (K == L) then + PS(IJKL_pack) = Half*PT(L,K,J,I) + else + PS(IJKL_pack) = Half*(PT(L,K,J,I)+PT(K,L,J,I)) + PA(IJKL_pack) = Half*(PT(L,K,J,I)-PT(K,L,J,I)) + end if + end do + end do + end do +end do + +return + +end subroutine DICE_DENSI_RASSCF diff -Nru openmolcas-22.02/src/dice_util/dice_load2pdm.F90 openmolcas-22.10/src/dice_util/dice_load2pdm.F90 --- openmolcas-22.02/src/dice_util/dice_load2pdm.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dice_util/dice_load2pdm.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,62 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2017, Quan Phung * +!*********************************************************************** +! Load text file 2RDM generated by DICE +! Written by Quan Phung, Leuven, 2017 +! Nagoya, 2022 + +subroutine dice_load2pdm(NAC,PT,CHEMROOT) + +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: NAC, CHEMROOT +real(kind=wp), intent(out) :: PT(NAC,NAC,NAC,NAC) +integer(kind=iwp) :: idx1, idx2, idx3, idx4, ierr, nact, lu +real(kind=wp) :: PTtemp +character(len=30) :: file_2rdm +character(len=10) :: rootindex +logical(kind=iwp) :: irdm +integer(kind=iwp), external :: isFreeUnit + +! Check 2RDM file +write(rootindex,'(i2)') chemroot-1 +file_2rdm = 'spatialRDM.'//trim(adjustl(rootindex))//'.'//trim(adjustl(rootindex))//'.txt' +file_2rdm = trim(adjustl(file_2rdm)) +call f_inquire(file_2rdm,irdm) +if (.not. irdm) then + write(u6,'(1x,a15,i3,a16)') 'DICE> Root: ',CHEMROOT,' :: No 2RDM file' + call abend() +end if + +LU = isFreeUnit(40) +call molcas_open(LU,file_2rdm) + +read(LU,*) nact +if (nact /= NAC) then + write(u6,*) 'DICE: DB> Wrong number of active orbitals' + call abend() +end if + +! Dice ignores all elements smaller than 1.0e-15 +! Read until EOF +PT(:,:,:,:) = Zero +do + read(LU,*,IOSTAT=ierr) idx1,idx2,idx3,idx4,PTtemp + if (ierr /= 0) exit + PT(idx1+1,idx3+1,idx4+1,idx2+1) = PTtemp +end do + +close(LU) + +end subroutine diff -Nru openmolcas-22.02/src/dice_util/molcas2dice.F90 openmolcas-22.10/src/dice_util/molcas2dice.F90 --- openmolcas-22.02/src/dice_util/molcas2dice.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/dice_util/molcas2dice.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,55 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2022, Quan Phung * +!*********************************************************************** +! Subroutine to convert HFOC to Dice format +! Written by Quan Phung, Leuven, Apr 2018 +! Nagoya, Oct 2022 + +subroutine molcas2dice(str) + +use Definitions, only: iwp + +implicit none +! This supports up to about 100 active orbitals +character(len=500), intent(inout) :: str +character(len=500) :: str2 +character(len=8) :: TempStr +integer(kind=iwp) :: i, idxOrb + +idxOrb = 0 + +! Convert DIOC to Dice format +str2 = ' ' +do i=1,len(str) + select case (str(i:i)) + case ('2') + write(TempStr,'(2I4)') idxOrb,idxOrb+1 + str2 = adjustl(trim(str2))//' '//adjustl(trim(TempStr)) + idxOrb = idxOrb+2 + case ('u','a') + write(TempStr,'(I4)') idxOrb + str2 = adjustl(trim(str2))//' '//adjustl(trim(TempStr)) + idxOrb = idxOrb+2 + case ('d','b') + write(TempStr,'(I4)') idxOrb + str2 = adjustl(trim(str2))//' '//adjustl(trim(TempStr)) + idxOrb = idxOrb+2 + case (' ') + ! do nothing + case default + idxOrb = idxOrb+2 + end select +end do + +str = str2 + +end subroutine diff -Nru openmolcas-22.02/src/dkh_old_util/at34r.F90 openmolcas-22.10/src/dkh_old_util/at34r.F90 --- openmolcas-22.02/src/dkh_old_util/at34r.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/dkh_old_util/at34r.F90 2022-10-10 14:22:40.000000000 +0000 @@ -15,7 +15,7 @@ ! H RELATIVISTIC KINETIC ENERGY ! EV2 PVP INTEGRALS -use DKH_Info, only: CLightAU, IRELMP +use DKH_Info, only: cLightAU, IRELMP use Constants, only: Zero, One, Two, Half use Definitions, only: wp, iwp, u6 @@ -32,7 +32,7 @@ real(kind=wp) :: CON, CON2, CR, PREA, RATIO, TV1, TV2, TV3, TV4, VELIT !call PRMAT(u6,SMAT,N,0,'SMAT ') -VELIT = CLightAU +VELIT = cLightAU ISIZE = N*(N+1)/2 PREA = 1/(VELIT*VELIT) CON2 = PREA+PREA diff -Nru openmolcas-22.02/src/dkh_old_util/bssint.F90 openmolcas-22.10/src/dkh_old_util/bssint.F90 --- openmolcas-22.02/src/dkh_old_util/bssint.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/dkh_old_util/bssint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -13,7 +13,7 @@ use Basis_Info, only: dbsc, nBas, nCnttp use Symmetry_Info, only: Mul, nIrrep -use DKH_Info, only: CLightAU +use DKH_Info, only: cLightAU use Data_Structures, only: Allocate_DT, Deallocate_DT, DSBA_Type use stdalloc, only: mma_allocate, mma_deallocate use Constants, only: Zero, One, Two, OneHalf @@ -145,7 +145,7 @@ nBasMax = max(nBasMax,n) end do -VELIT = CLightAU +VELIT = cLightAU call Allocate_DT(Kin,nBas,nBas,nSym,aCase='TRI',label='Kin') call Allocate_DT(SS,nBas,nBas,nSym,aCase='TRI',label='SS') diff -Nru openmolcas-22.02/src/dkh_util/dkrelint_dp.F90 openmolcas-22.10/src/dkh_util/dkrelint_dp.F90 --- openmolcas-22.02/src/dkh_util/dkrelint_dp.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/dkh_util/dkrelint_dp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -21,7 +21,7 @@ ! exact decoupling BSS method. use Basis_Info, only: dbsc, nBas, ncnttp -use DKH_Info, only: CLightAU, iRelae, LDKroll, radiLD +use DKH_Info, only: cLightAU, iRelae, LDKroll, radiLD use Symmetry_Info, only: nIrrep use Gateway_Info, only: lMXTC use stdalloc, only: mma_allocate, mma_deallocate @@ -132,7 +132,7 @@ end do end if -call iCopy(8,nBas,1,nBas_Cont,1) +nBas_Cont(:) = nBas nSym = nIrrep ! * !*********************************************************************** @@ -164,7 +164,7 @@ !*********************************************************************** ! * call Get_iArray('nBas_Prim',nBas,nSym) -call iCopy(8,nBas,1,nBas_prim,1) +nBas_prim(:) = nBas if (iPrint >= 10) then write(u6,'(a,8i5)') ' Symmetries ',nSym write(u6,'(a,8i5)') ' Primitive basis fcns',(nBas(i),i=0,nSym-1) @@ -172,7 +172,7 @@ ! Allocate memory for relativistic part -VELIT = CLightAU +VELIT = cLightAU iSizep = 0 iSizes = 0 iSizec = 0 @@ -331,11 +331,11 @@ call xdr_info_local(n,indx(kz),nbl,Loc,Map) !DP write(u6,'(a,i1,i5,a,99i4)') ' Sym: ',L+1,n,' = Local ',(Loc(i),i=1,nbl) call XDR_Local_Ham(n,isize,n*n,relmethod,dkhparam,dkhorder,xorder,SS(k),iK(k),V(k),pVp(k),U_L(ks),U_S(ks),nbl,Loc,Map, & - DoFullLT,clightau) + DoFullLT,cLightAU) call mma_deallocate(Loc) call mma_deallocate(Map) else - call XDR_Ham(n,isize,n*n,relmethod,dkhparam,dkhorder,xorder,SS(k),iK(k),V(k),pVp(k),U_L(ks),U_S(ks),clightau) + call XDR_Ham(n,isize,n*n,relmethod,dkhparam,dkhorder,xorder,SS(k),iK(k),V(k),pVp(k),U_L(ks),U_S(ks),cLightAU) end if ! * !******************************************************************* @@ -466,7 +466,7 @@ ! * !*********************************************************** ! * - call XDR_Prop(n,isize,n*n,relmethod,dkhparam,xorder,SS(k),iK(k),V(k),pVp(k),X(k),pXp(k),U_L(ks),U_S(ks),clightau, & + call XDR_Prop(n,isize,n*n,relmethod,dkhparam,xorder,SS(k),iK(k),V(k),pVp(k),X(k),pXp(k),U_L(ks),U_S(ks),cLightAU, & Label,iComp,iSizec) ks = ks+n*n end if @@ -660,7 +660,7 @@ call daxpy_(iSizec,-One,SS,1,H,1) call writem(H,iSizec+2,1,1410,0,'POT') ! reset contracted basis size -call iCopy(8,nBas_Cont,1,nBas,1) +nBas(:) = nBas_Cont call mma_deallocate(iK) call mma_deallocate(SS) call mma_deallocate(V) diff -Nru openmolcas-22.02/src/Driver/orbitals.inc openmolcas-22.10/src/Driver/orbitals.inc --- openmolcas-22.02/src/Driver/orbitals.inc 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Driver/orbitals.inc 2022-10-10 14:22:40.000000000 +0000 @@ -18,6 +18,7 @@ (file) UNAORB "$WorkDir/$Project$SubProject."UnaOrb rwst (file) MP2ORB "$WorkDir/$Project$SubProject."MP2Orb rwst (file) RASORB "$WorkDir/$Project$SubProject."RasOrb rw*st + (file) ITERORB "$WorkDir/$Project$SubProject."IterOrb rw*st (file) DYSORB "$WorkDir/$Project$SubProject."DysOrb rw*st (file) PT2ORB "$WorkDir/$Project$SubProject."Pt2Orb rw*st (file) CPFORB "$WorkDir/$Project$SubProject."CpfOrb rwst diff -Nru openmolcas-22.02/src/Driver/wfnfiles.inc openmolcas-22.10/src/Driver/wfnfiles.inc --- openmolcas-22.02/src/Driver/wfnfiles.inc 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Driver/wfnfiles.inc 2022-10-10 14:22:40.000000000 +0000 @@ -11,7 +11,7 @@ #ifndef _WFNFILES_ (file) GSSWFN "$WorkDir/$Project$SubProject."guessorb.h5 rws (file) POLYWFN "$WorkDir/$Project$SubProject."poly.h5 rws - (file) RASWFN "$WorkDir/$Project$SubProject."rasscf.h5 rws + (file) RASWFN "$WorkDir/$Project$SubProject."rasscf.h5 rw*s (file) PT2WFN "$WorkDir/$Project$SubProject."caspt2.h5 rws (file) NEVPT2WFN "$WorkDir/$Project$SubProject."nevpt2.h5 rws (file) RASSIWFN "$WorkDir/$Project$SubProject."rassi.h5 rws diff -Nru openmolcas-22.02/src/dynamix/cre_dyn.F90 openmolcas-22.10/src/dynamix/cre_dyn.F90 --- openmolcas-22.02/src/dynamix/cre_dyn.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/dynamix/cre_dyn.F90 2022-10-10 14:22:40.000000000 +0000 @@ -22,7 +22,8 @@ implicit none integer(kind=iwp) :: natoms, nsym, nstates, nconfs, dyn_dsetid, surf_dsetid, wfn_fileid, ii -real(kind=wp), allocatable :: coord(:,:), ener(:), ciarray(:) +character(len=8) :: method +real(kind=wp), allocatable :: coord(:,:), ener(:), ciarray(:), overlap_save(:) #include "Molcas.fh" character(len=LenIn), allocatable :: atomlbl(:) logical(kind=iwp) :: found @@ -146,82 +147,102 @@ call mh5_close_dset(surf_dsetid) end if -! Relax CASSCF root -call qpg_iscalar('Relax CASSCF root',Found) -if (Found) then - surf_dsetid = mh5_create_dset_int(dyn_fileid,'RELAX CAS ROOT') - call mh5_init_attr(surf_dsetid,'DESCRIPTION','Relax CASSCF root') - call get_iscalar('Relax CASSCF root',ii) - call mh5_put_dset(surf_dsetid,ii) - call mh5_close_dset(surf_dsetid) -end if +call get_carray('Relax Method',method,8) +! This is only read if using the RASSCF program +! Note that there is no implication all of these will actually work, +! the point here is simply to skip this block if using e.g. SCF +if ((method(1:3) == 'CAS') .or. (method(1:3) == 'RAS') .or. (method(1:3) == 'GAS') .or. (method(1:4) == 'DMRG')) then -! Read number of states and configurations from rasscf.h5 file -wfn_fileid = mh5_open_file_r('RASWFN') -if (mh5_exists_attr(wfn_fileid,'NSTATES') .and. mh5_exists_attr(wfn_fileid,'NCONF')) then - call mh5_fetch_attr(wfn_fileid,'NSTATES',nstates) - call mh5_fetch_attr(wfn_fileid,'NCONF',nconfs) - call mh5_init_attr(dyn_fileid,'NSTATES',nstates) - call mh5_init_attr(dyn_fileid,'NCONFS',nconfs) - - ! Energies at the previous step - call qpg_darray('VenergyP',Found,nstates) + ! Relax CASSCF root + call qpg_iscalar('Relax CASSCF root',Found) if (Found) then - surf_dsetid = mh5_create_dset_real(dyn_fileid,'ENERG PREV',1,[nstates]) - call mh5_init_attr(surf_dsetid,'DESCRIPTION','Potential energies at the previous time step') - call mma_allocate(ener,nstates) - call get_darray('VenergyP',ener,nstates) - call mh5_put_dset(surf_dsetid,ener) - call mma_deallocate(ener) + surf_dsetid = mh5_create_dset_int(dyn_fileid,'RELAX CAS ROOT') + call mh5_init_attr(surf_dsetid,'DESCRIPTION','Relax CASSCF root') + call get_iscalar('Relax CASSCF root',ii) + call mh5_put_dset(surf_dsetid,ii) call mh5_close_dset(surf_dsetid) end if - ! CI coeffs at the previous step - call qpg_darray('AllCIP',Found,nstates*nconfs) - if (Found) then - surf_dsetid = mh5_create_dset_real(dyn_fileid,'CI PREV',1,[nstates*nconfs]) - call mh5_init_attr(surf_dsetid,'DESCRIPTION','CI coeffs at the previous time step') - call mma_allocate(ciarray,nstates*nconfs) - call get_darray('AllCIP',ciarray,nstates*nconfs) - call mh5_put_dset(surf_dsetid,ciarray) - call mma_deallocate(ciarray) - call mh5_close_dset(surf_dsetid) + ! Read number of states and configurations from rasscf.h5 file + wfn_fileid = mh5_open_file_r('RASWFN') + if (mh5_exists_attr(wfn_fileid,'NSTATES') .and. mh5_exists_attr(wfn_fileid,'NCONF')) then + call mh5_fetch_attr(wfn_fileid,'NSTATES',nstates) + call mh5_fetch_attr(wfn_fileid,'NCONF',nconfs) + call mh5_init_attr(dyn_fileid,'NSTATES',nstates) + call mh5_init_attr(dyn_fileid,'NCONFS',nconfs) + + ! Energies at the previous step + call qpg_darray('VenergyP',Found,nstates) + if (Found) then + surf_dsetid = mh5_create_dset_real(dyn_fileid,'ENERG PREV',1,[nstates]) + call mh5_init_attr(surf_dsetid,'DESCRIPTION','Potential energies at the previous time step') + call mma_allocate(ener,nstates) + call get_darray('VenergyP',ener,nstates) + call mh5_put_dset(surf_dsetid,ener) + call mma_deallocate(ener) + call mh5_close_dset(surf_dsetid) + end if + + ! CI coeffs at the previous step + call qpg_darray('AllCIP',Found,nstates*nconfs) + if (Found) then + surf_dsetid = mh5_create_dset_real(dyn_fileid,'CI PREV',1,[nstates*nconfs]) + call mh5_init_attr(surf_dsetid,'DESCRIPTION','CI coeffs at the previous time step') + call mma_allocate(ciarray,nstates*nconfs) + call get_darray('AllCIP',ciarray,nstates*nconfs) + call mh5_put_dset(surf_dsetid,ciarray) + call mma_deallocate(ciarray) + call mh5_close_dset(surf_dsetid) + end if + + ! CI coeffs at the step before the previous step + call qpg_darray('AllCIPP',Found,nstates*nconfs) + if (Found) then + surf_dsetid = mh5_create_dset_real(dyn_fileid,'CI PPREV',1,[nstates*nconfs]) + call mh5_init_attr(surf_dsetid,'DESCRIPTION','CI coeffs at the step before the previous time step') + call mma_allocate(ciarray,nstates*nconfs) + call get_darray('AllCIPP',ciarray,nstates*nconfs) + call mh5_put_dset(surf_dsetid,ciarray) + call mma_deallocate(ciarray) + call mh5_close_dset(surf_dsetid) + end if + + ! A matrix V + call Qpg_zArray('AmatrixV',Found,nstates*nstates) + if (Found) then + call mma_allocate(Amatrix,nstates*nstates) + call get_zarray('AmatrixV',Amatrix,NSTATES*NSTATES) + ! HDF5 format does not deal with complex numbers so split manually into + ! real and imaginary parts and save 2 datasets + ! Real part + surf_dsetid = mh5_create_dset_real(dyn_fileid,'AMATRIXV-R',1,[nstates*nstates]) + call mh5_init_attr(surf_dsetid,'DESCRIPTION','real part of AmatrixV') + call mh5_put_dset(surf_dsetid,real(Amatrix)) + call mh5_close_dset(surf_dsetid) + ! Imaginary part + surf_dsetid = mh5_create_dset_real(dyn_fileid,'AMATRIXV-I',1,[nstates*nstates]) + call mh5_init_attr(surf_dsetid,'DESCRIPTION','imaginary part of AmatrixV') + call mh5_put_dset(surf_dsetid,aimag(Amatrix)) + call mh5_close_dset(surf_dsetid) + call mma_deallocate(Amatrix) + end if + + ! RASSI overlap + call qpg_darray('SH_Ovlp_Save',Found,nstates*nstates) + if (Found) then + surf_dsetid = mh5_create_dset_real(dyn_fileid,'RASSI_SAVE_OVLP',1,[nstates*nstates]) + call mh5_init_attr(surf_dsetid,'DESCRIPTION','RASSI overlap between t-2dt and t-dt') + call mma_allocate(overlap_save,nstates*nstates) + call get_darray('SH_Ovlp_Save',overlap_save,nstates*nstates) + call mh5_put_dset(surf_dsetid,overlap_save) + call mma_deallocate(overlap_save) + call mh5_close_dset(surf_dsetid) + end if end if - ! CI coeffs at the step before the previous step - call qpg_darray('AllCIPP',Found,nstates*nconfs) - if (Found) then - surf_dsetid = mh5_create_dset_real(dyn_fileid,'CI PPREV',1,[nstates*nconfs]) - call mh5_init_attr(surf_dsetid,'DESCRIPTION','CI coeffs at the step before the previous time step') - call mma_allocate(ciarray,nstates*nconfs) - call get_darray('AllCIPP',ciarray,nstates*nconfs) - call mh5_put_dset(surf_dsetid,ciarray) - call mma_deallocate(ciarray) - call mh5_close_dset(surf_dsetid) - end if - - ! A matrix V - call Qpg_zArray('AmatrixV',Found,nstates*nstates) - if (Found) then - call mma_allocate(Amatrix,nstates*nstates) - call get_zarray('AmatrixV',Amatrix,NSTATES*NSTATES) - ! HDF5 format does not deal with complex numbers so split manually into - ! real and imaginary parts and save 2 datasets - ! Real part - surf_dsetid = mh5_create_dset_real(dyn_fileid,'AMATRIXV-R',1,[nstates*nstates]) - call mh5_init_attr(surf_dsetid,'DESCRIPTION','real part of AmatrixV') - call mh5_put_dset(surf_dsetid,real(Amatrix)) - call mh5_close_dset(surf_dsetid) - ! Imaginary part - surf_dsetid = mh5_create_dset_real(dyn_fileid,'AMATRIXV-I',1,[nstates*nstates]) - call mh5_init_attr(surf_dsetid,'DESCRIPTION','imaginary part of AmatrixV') - call mh5_put_dset(surf_dsetid,aimag(Amatrix)) - call mh5_close_dset(surf_dsetid) - call mma_deallocate(Amatrix) - end if + call mh5_close_file(wfn_fileid) end if -call mh5_close_file(wfn_fileid) #endif end subroutine cre_dyn diff -Nru openmolcas-22.02/src/dynamix/dynamix.F90 openmolcas-22.10/src/dynamix/dynamix.F90 --- openmolcas-22.02/src/dynamix/dynamix.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/dynamix/dynamix.F90 2022-10-10 14:22:40.000000000 +0000 @@ -48,7 +48,7 @@ write(u6,*) ' Dynamix back from Init_Dynamix.' #endif -! Read the input +! Read the input #ifdef _HDF5_ call cre_dyn() diff -Nru openmolcas-22.02/src/embedding_util/embpotene.F90 openmolcas-22.10/src/embedding_util/embpotene.F90 --- openmolcas-22.02/src/embedding_util/embpotene.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/embedding_util/embpotene.F90 2022-10-10 14:22:40.000000000 +0000 @@ -197,13 +197,9 @@ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !call Square(inMatrix,unpackedMatrix,1,nBasFunc,nBasFunc) !! stefan: check T (transpose) whether it is correct... -!call DGEMM_('T','N',nBasFunc,nBasFunc,nBasFunc, & -! One,unpackedMatrix,nBasFunc, & -! coefficientMatrix(nFrozenOrbs*nBasFunc),nBasFunc, & -! Zero,halfTrafoMat,nBasFunc) -!call DGEMM_Tri('T','N',nBasFunc,nBasFunc,nBasFunc, & -! One,halfTrafoMat,nBasFunc, & -! coefficientMatrix(nFrozenOrbs*nBasFunc),nBasFunc, & +!call DGEMM_('T','N',nBasFunc,nBasFunc,nBasFunc,One,unpackedMatrix,nBasFunc,coefficientMatrix(nFrozenOrbs*nBasFunc),nBasFunc,Zero, & +! halfTrafoMat,nBasFunc) +!call DGEMM_Tri('T','N',nBasFunc,nBasFunc,nBasFunc,One,halfTrafoMat,nBasFunc,coefficientMatrix(nFrozenOrbs*nBasFunc),nBasFunc, & ! Zero,outMatrix,nBasFunc) ! !call mma_deallocate(unpackedMatrix) diff -Nru openmolcas-22.02/src/embedding_util/embpotkernel.F90 openmolcas-22.10/src/embedding_util/embpotkernel.F90 --- openmolcas-22.02/src/embedding_util/embpotkernel.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/embedding_util/embpotkernel.F90 2022-10-10 14:22:40.000000000 +0000 @@ -12,9 +12,9 @@ !*********************************************************************** subroutine EmbPotKernel( & -#define _CALLING_ -#include "int_interface.fh" -) +# define _CALLING_ +# include "int_interface.fh" + ) !*********************************************************************** ! * ! Object: kernel routine to calculate integrals over an embedding * @@ -26,28 +26,21 @@ ! * !*********************************************************************** -#include "macros.fh" - use Embedding_Global, only: embDebug, nEmbGridPoints, embGridCoord, embPotVal, embWeight +use Index_Functions, only: nTri_Elem1 use stdalloc, only: mma_allocate, mma_deallocate use Constants, only: Zero use Definitions, only: wp, iwp, u6 implicit none #include "int_interface.fh" - -!***** Local Variables - -! Index integer(kind=iwp) :: i, j, ia, ib, m, ix, iy, iz, nShellA, nShellB -! distance of the current grid point to A/B -real(kind=wp) :: dRA(3), dRB(3) -real(kind=wp) :: prefactor -! Arrays +! dRA, dRB: distance of the current grid point to A/B +real(kind=wp) :: dRA(3), dRB(3), prefactor real(kind=wp), allocatable :: radA(:), radB(:), sphA(:), sphB(:) -! Function return value real(kind=wp), external :: gaussRad +#include "macros.fh" unused_var(Zeta) unused_var(ZInv) unused_var(rKappa) @@ -64,7 +57,7 @@ unused_var(nGrid) unused_var(iAddPot) -!***** Initialization *************************************************** +!***** Initialization ************************************************** nShellA = (la+1)*(la+2)/2 nShellB = (lb+1)*(lb+2)/2 @@ -75,10 +68,10 @@ call mma_allocate(sphA,nShellA,label='sphA') call mma_allocate(sphB,nShellB,label='sphB') -!***** Calculation ****************************************************** +!***** Calculation ***************************************************** ! Init result var -Final(:,:,:,:) = Zero +rFinal(:,:,:,:) = Zero ! Now loop over grid points first do m=1,nEmbGridPoints @@ -124,7 +117,7 @@ do ib=1,nBeta do i=1,nShellA do j=1,nShellB - Final(ia,ib,i,j) = Final(ia,ib,i,j)+(prefactor*radA(ia)*radB(ib)*sphA(i)*sphB(j)) + rFinal(ia,ib,i,j) = rFinal(ia,ib,i,j)+(prefactor*radA(ia)*radB(ib)*sphA(i)*sphB(j)) end do end do end do @@ -153,17 +146,17 @@ do ib=1,nBeta do i=1,nShellA do j=1,nShellB - write(u6,*) Final(ia,ib,i,j) + write(u6,*) rFinal(ia,ib,i,j) end do end do end do end do - !write(u6,*) 'Final(1,1,1,1)=',Final(1,1,1,1),'; Final(1,2,1,2)=',Final(1,2,1,2) + !write(u6,*) 'rFinal(1,1,1,1)=',rFinal(1,1,1,1),'; rFinal(1,2,1,2)=',rFinal(1,2,1,2) write(u6,*) '-------------------------------------------------' write(u6,*) '-------------------------------------------------' end if -!***** Done. Tidy up. **************************************************** +!***** Done. Tidy up. ************************************************** call mma_deallocate(radA) call mma_deallocate(radB) @@ -174,20 +167,20 @@ end subroutine EmbPotKernel -!********************************************************************* -! Returns the radial part of the value of a GTO with given exponent, * -! centered at the origin. * -!********************************************************************* -real(kind=wp) function gaussRad(alpha,r) +!*********************************************************************** +! Returns the radial part of the value of a GTO with given exponent, * +! centered at the origin. * +!*********************************************************************** +function gaussRad(alpha,r) use Constants, only: Zero use Definitions, only: wp, iwp implicit none +real(kind=wp) :: gaussRad real(kind=wp), intent(in) :: alpha, r(3) - -real(kind=wp) :: rSquare integer(kind=iwp) :: i +real(kind=wp) :: rSquare rSquare = Zero do i=1,3 diff -Nru openmolcas-22.02/src/embedding_util/embpotmem.F90 openmolcas-22.10/src/embedding_util/embpotmem.F90 --- openmolcas-22.02/src/embedding_util/embpotmem.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/embedding_util/embpotmem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -10,16 +10,16 @@ !*********************************************************************** subroutine embPotMem( & -#define _CALLING_ -#include "mem_interface.fh" -) - -#include "macros.fh" +# define _CALLING_ +# include "mem_interface.fh" + ) use Definitions, only: iwp implicit none #include "mem_interface.fh" + +#include "macros.fh" unused_var(la) unused_var(lb) unused_var(lr) diff -Nru openmolcas-22.02/src/espf_util/bdvgrd.f openmolcas-22.10/src/espf_util/bdvgrd.f --- openmolcas-22.02/src/espf_util/bdvgrd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/espf_util/bdvgrd.f 2022-10-10 14:22:40.000000000 +0000 @@ -8,26 +8,22 @@ * For more details see the full text of the license in the file * * LICENSE or in . * ************************************************************************ - SubRoutine BdVGrd(Alpha,nAlpha,Beta, nBeta,Zeta,ZInv,rKappa,P, - & Final,nZeta,la,lb,A,RB,nRys, - & Array,nArr,Ccoor,nOrdOp,Grad,nGrad, - & IfGrad,IndGrd,DAO,mdc,ndc,kOp,lOper,nComp, - & iStabM,nStabM) + SubRoutine BdVGrd( & +#define _FIXED_FORMAT_ +#define _CALLING_ +#include "grd_interface.fh" + & ) + use Index_Functions, only: nTri_Elem1 use Center_Info Implicit Real*8 (A-H,O-Z) +#include "grd_interface.fh" #include "espf.fh" * External TNAI1, Fake, XCff2D #include "print.fh" #include "disp.fh" - Integer IndGrd(3,2), kOp(2), lOper(nComp), iStabM(0:nStabM-1), - & iDCRT(0:7) - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,6), - & Zeta(nZeta), ZInv(nZeta), Alpha(nAlpha), Beta(nBeta), - & rKappa(nZeta), P(nZeta,3), A(3), RB(3), CCoor(4,*), - & Array(nZeta*nArr), Grad(nGrad), - & DAO(nZeta,(la+1)*(la+2)/2*(lb+1)*(lb+2)/2) - Logical IfGrad(3,2),ESPFexist + Integer iDCRT(0:7) + Logical ESPFexist Character*180 Key,Get_Ln External Get_Ln * @@ -131,17 +127,17 @@ * iDum=0 Do iPnt = 1, nGrdPt - ZFd(1)=CCoor(4,iPnt) + ZFd(1)=CCoor((iPnt-1)*4+4) NoLoop = ZFd(1).eq.Zero If (NoLoop) Go To 111 *------- Pick up the center coordinates - C(1)=CCoor(1,iPnt) - C(2)=CCoor(2,iPnt) - C(3)=CCoor(3,iPnt) + C(1)=CCoor((iPnt-1)*4+1) + C(2)=CCoor((iPnt-1)*4+2) + C(3)=CCoor((iPnt-1)*4+3) If (iPrint.ge.99) Call RecPrt('C',' ',C,1,3) * -*------- Generate stabilizor of C +*------- Generate stabilizer of C * iChxyz=iChAtm(C) Call Stblz(iChxyz,nStb,iStb,iDum,jCoSet) @@ -243,9 +239,9 @@ Return c Avoid unused argument warnings If (.False.) Then - Call Unused_real_array(Final) - Call Unused_integer(nRys) + Call Unused_real_array(rFinal) + Call Unused_integer(nHer) Call Unused_integer(nOrdOp) - Call Unused_integer_array(lOper) + Call Unused_integer(nComp) End If End diff -Nru openmolcas-22.02/src/espf_util/drvespf.f openmolcas-22.10/src/espf_util/drvespf.f --- openmolcas-22.02/src/espf_util/drvespf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/espf_util/drvespf.f 2022-10-10 14:22:40.000000000 +0000 @@ -26,7 +26,6 @@ #include "nsd.fh" #include "setup.fh" #include "wldata.fh" -#include "iavec.fh" #include "stdalloc.fh" Character Label*80 Real*8 Grad(nGrad), Temp(nGrad) @@ -43,22 +42,6 @@ *... Prologue iPrint = 1 * -* Set up the angular index vector -* - i = 0 - Do 1000 iR = 0, iTabMx - Do 2000 ix = iR, 0, -1 - Do 3000 iy = iR-ix, 0, -1 - iz = iR-ix-iy - i = i + 1 - ixyz(1,i) = ix - ixyz(2,i) = iy - ixyz(3,i) = iz - 3000 Continue - 2000 Continue - 1000 Continue - -* *---- Allocate memory for density matrix * nDens = 0 diff -Nru openmolcas-22.02/src/espf_util/drvpot.f openmolcas-22.10/src/espf_util/drvpot.f --- openmolcas-22.02/src/espf_util/drvpot.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/espf_util/drvpot.f 2022-10-10 14:22:40.000000000 +0000 @@ -98,6 +98,7 @@ End If Else iWork(ip2) = 2**nirrep-1 + iWork(ip3) = 0 Call OneEl(PotInt,NAMem,Label,iWork(ip1),iWork(ip2),ncmp, & Ccoor,nOrdOp,work(ipnuc),rHrmt,iWork(ip3), & dummy,1,opnuc,iopadr,1,1, diff -Nru openmolcas-22.02/src/faiemp_util/drvg_faiemp.F90 openmolcas-22.10/src/faiemp_util/drvg_faiemp.F90 --- openmolcas-22.02/src/faiemp_util/drvg_faiemp.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/faiemp_util/drvg_faiemp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -181,6 +181,7 @@ !*********************************************************************** ! * call mma_MaxDBLE(MemMax) +if (MemMax > 1000) MemMax=MemMax-1000 call mma_allocate(Sew_Scr,MemMax,Label='Sew_Scr') ipMem1 = 1 ! * diff -Nru openmolcas-22.02/src/faiemp_util/fragpcont.F90 openmolcas-22.10/src/faiemp_util/fragpcont.F90 --- openmolcas-22.02/src/faiemp_util/fragpcont.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/faiemp_util/fragpcont.F90 2022-10-10 14:22:40.000000000 +0000 @@ -12,7 +12,7 @@ ! 2016, Liviu Ungur * !*********************************************************************** -subroutine FragpCont(F1,mi,mK,ma,mC,F2,mL,mj,mD,mb,W,Fin,Factor) +subroutine FragpCont(F1,mi,mK,ma,mC,F2,mL,mj,mD,mb,W,rFinal,Factor) !*********************************************************************** ! * ! Object: Specialized contraction of 3 4D matrices. * @@ -30,7 +30,7 @@ implicit none integer(kind=iwp), intent(in) :: mi, mK, ma, mC, mL, mj, mD, mb real(kind=wp), intent(in) :: F1(mi,mK,ma,mC), F2(mL,mj,mD,mb), W(mK,mC,mL,mD), Factor -real(kind=wp), intent(inout) :: Fin(mi,mj,ma,mb) +real(kind=wp), intent(inout) :: rFinal(mi,mj,ma,mb) ! local variables integer(kind=iwp) :: ib, ia, ij, ii, iC, iK, iD, iL, j1, j2, j12 real(kind=wp) :: xt, xt2, WW1(mK*mC*mL*mD), F12(mK*mC*mL*mD) @@ -86,11 +86,11 @@ end do end if !DBG -!write(u6,*) 'norm of FINAL in fragpcont',dnrm2_(mi*mj*ma*mb,Fin(1:mi,1:mj,1:ma,1:mb),1) +!write(u6,*) 'norm of FINAL in fragpcont',dnrm2_(mi*mj*ma*mb,rFinal(1:mi,1:mj,1:ma,1:mb),1) !T = F1*W !call DGEMM_('T','N',iBas*nElem(la)*nAlpha,iSize,nElem(iAng),One,Array(ipTmp),nElem(iAng),RSph(ipSph(iAng)),nElem(iAng),Zero, & ! Array(ipF1),nAlpha*iBas*nElem(la)) -!Fin = T*F2 +!rFinal = T*F2 !call DGEMM_('T','N',iBas*nElem(la)*nAlpha,iSize,nElem(iAng),One,Array(ipTmp),nElem(iAng),RSph(ipSph(iAng)),nElem(iAng),Zero, & ! Array(ipF1),nAlpha*iBas*nElem(la)) !write(u6,*) 'factor=',factor @@ -133,7 +133,7 @@ ! !call daxpy_(n,a,x,incx,y,incy) - Fin(ii,ij,ia,ib) = Fin(ii,ij,ia,ib)+Factor*xt + rFinal(ii,ij,ia,ib) = rFinal(ii,ij,ia,ib)+Factor*xt end do !ii end do !ij diff -Nru openmolcas-22.02/src/faiemp_util/fragpgrd.F90 openmolcas-22.10/src/faiemp_util/fragpgrd.F90 --- openmolcas-22.02/src/faiemp_util/fragpgrd.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/faiemp_util/fragpgrd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -20,30 +20,6 @@ ! Object: kernel routine for the computation of FAIEMP Projection * ! operator integrals. * ! * -! Alpha : exponents of bra gaussians * -! nAlpha: number of primitives (exponents) of bra gaussians * -! Beta : as Alpha but for ket gaussians * -! nBeta : as nAlpha but for the ket gaussians * -! Zeta : sum of exponents (nAlpha x nBeta) * -! ZInv : inverse of Zeta * -! rKappa: gaussian prefactor for the products of bra and ket * -! gaussians. * -! P : center of new gaussian from the products of bra and ket * -! gaussians. * -! rFinal: array for computed integrals * -! nZeta : nAlpha x nBeta * -! nComp : number of components in the operator (e.g. dipole moment* -! operator has three components) * -! la : total angular momentum of bra gaussian * -! lb : total angular momentum of ket gaussian * -! A : center of bra gaussian * -! B : center of ket gaussian * -! nHer : order of Rys- or Hermite-Gauss polynomial * -! Array : Auxiliary memory as requested by FragMMG * -! nArr : length of Array * -! Ccoor : coordinates of the operator, zero for symmetric oper. * -! NOrdOp: Order of the operator * -! * ! Author: Ben Swerts * ! * ! based on PrjGrd * @@ -55,7 +31,7 @@ use Basis_Info, only: dbsc, nCnttp, Shells use Center_Info, only: dc use Symmetry_Info, only: iOper -use Index_util, only: iTri, nTri0Elem +use Index_Functions, only: iTri, nTri_Elem1 use Constants, only: Zero, One, Two, Half use Definitions, only: wp, iwp, u6, r8 @@ -63,12 +39,12 @@ #include "grd_interface.fh" #include "print.fh" real(kind=wp) :: C(3), TC(3), B(3), TB(3), Fact -integer(kind=iwp) :: iDCRT(0:7), iuvwx(4), lOp(4), JndGrd(3,4), i, j, ia, ib, iAng, iBas, iRout, iPrint, nSkal, iCar, iCent, & - iCnttp, iCurCenter, iCurCnttp, iCurMdc, iGamma, iLoc, ip, ipA, ipAxyz, ipB, ipBxyz, ipCxyz, ipF1, ipF2, & - ipF1a, ipF2a, ipIJ, ipK1, ipK2, ipP1, ipP2, ipQ1, iPrim, ipRxyz, ipTmp, ipZ1, ipZ2, ipZI1, ipZI2, iS, & - iSbasis, iSEnd, iShll, iSize, iSlocal, iSstart, iStemp, iStrt, iVec, jAng, jBas, jCnttp, jPrim, jS, jSbasis, & - jShll, jSize, jSlocal, ld, lDCRT, LmbdT, mdci, mGrad, mVec, mVecAC, mVecCB, nac, ncb, nDAO, nDCRT, n_Her, & - maxDensSize, nVecAC, nVecCB, iCnt, jCnt +integer(kind=iwp) :: i, ia, iAng, ib, iBas, iCar, iCent, iCnt, iCnttp, iCurCenter, iCurCnttp, iCurMdc, iDCRT(0:7), iGamma, iLoc, & + ip, ipA, ipAxyz, ipB, ipBxyz, ipCxyz, ipF1, ipF1a, ipF2, ipF2a, ipIJ, ipK1, ipK2, ipP1, ipP2, ipQ1, iPrim, & + iPrint, ipRxyz, ipTmp, ipZ1, ipZ2, ipZI1, ipZI2, iRout, iS, iSbasis, iSEnd, iShll, iSize, iSlocal, iSstart, & + iStemp, iStrt, iuvwx(4), iVec, jAng, jBas, jCnt, jCnttp, JndGrd(3,4), jPrim, jS, jSbasis, jShll, jSize, & + jSlocal, ld, lDCRT, LmbdT, lOp(4), maxDensSize, mdci, mGrad, mVec, mVecAC, mVecCB, n_Her, nac, ncb, nDAO, & + nDCRT, nSkal, nVecAC, nVecCB logical(kind=iwp) :: JfGrad(3,4), ABeq(3), EQ, EnergyWeight character(len=80) :: Label real(kind=r8), external :: DNrm2_ @@ -77,7 +53,6 @@ unused_var(ZInv) unused_var(rKappa) unused_var(nHer) -unused_var(lOper) iRout = 202 iPrint = nPrint(iRout) @@ -117,7 +92,7 @@ !*********************************************************************** ! * ! Loop over all shells belonging to the fragments -nDAO = nTri0Elem(la)*nTri0Elem(lb) +nDAO = nTri_Elem1(la)*nTri_Elem1(lb) iuvwx(1) = dc(mdc)%nStab iuvwx(2) = dc(ndc)%nStab lOp(1) = iOper(kOp(1)) @@ -139,7 +114,7 @@ iCnt = iSD(14,iS) C(1:3) = dbsc(iCnttp)%Coor(1:3,iCnt) - iSize = nTri0Elem(iAng) + iSize = nTri_Elem1(iAng) if (Shells(iShll)%Transf .and. Shells(iShll)%Prjct) iSize = 2*iAng+1 if (abs(dbsc(iCnttp)%nFragCoor) /= iCurMdc) then ! update fragment related quantities @@ -178,22 +153,12 @@ ! extra derivative stuff iuvwx(3) = dc(mdci)%nStab iuvwx(4) = dc(mdci)%nStab - call ICopy(6,IndGrd,1,JndGrd,1) - do i=1,3 - do j=1,2 - JfGrad(i,j) = IfGrad(i,j) - end do - end do + JndGrd(:,1:2) = IndGrd + JfGrad(:,1:2) = IfGrad - do iCar=0,2 - JfGrad(iCar+1,3) = .false. - ! always equivalent of pChrg's - JndGrd(iCar+1,3) = 0 - end do - call ICopy(3,[0],0,JndGrd(1,4),1) - JfGrad(1,4) = .false. - JfGrad(2,4) = .false. - JfGrad(3,4) = .false. + JfGrad(:,3:4) = .false. + ! always equivalent of pChrg's + JndGrd(:,3:4) = 0 mGrad = 0 do iCar=1,3 do i=1,2 @@ -214,7 +179,7 @@ jPrim = iSD(5,jS) jCnttp = iSD(13,jS) jCnt = iSD(14,jS) - jSize = nTri0Elem(jAng) + jSize = nTri_Elem1(jAng) if (Shells(jShll)%Transf .and. Shells(jShll)%Prjct) jSize = 2*jAng+1 B(1:3) = dbsc(jCnttp)%Coor(1:3,jCnt) !write(u6,*) ' jShll,jAng,jCnttp =',jShll,jAng,jCnttp @@ -222,10 +187,10 @@ ! * !******************************************************************* ! * - ! Create a rectangular matrix sized (iBas*nTri0Elem(iAng),jBas*nTri0Elem(jAng)) + ! Create a rectangular matrix sized (iBas*nTri_Elem1(iAng),jBas*nTri_Elem1(jAng)) ! from the energy weighted density matrix (desymmetrized) - ! contains values from iSbasis to iSbasis + iBas*nTri0Elem(iAng) - 1 - ! and from jSbasis to jSbasis + jBas*nTri0Elem(jAng) - 1 + ! contains values from iSbasis to iSbasis + iBas*nTri_Elem1(iAng) - 1 + ! and from jSbasis to jSbasis + jBas*nTri_Elem1(jAng) - 1 ipIJ = 1+maxDensSize !write(u6,*) ' extracting values from',iSbasis,' to',iSbasis+iBas*iSize-1,', and from',jSbasis,' to',jSbasis+jBas*jSize-1 do iSlocal=iSbasis,iSbasis+iBas*iSize-1 @@ -264,7 +229,7 @@ ip = ipIJ+maxDensSize ipF1 = ip - nac = nTri0Elem(la)*nTri0Elem(iAng)*4 + nac = nTri_Elem1(la)*nTri_Elem1(iAng)*4 ip = ip+nAlpha*nac*iPrim ipP1 = ip ip = ip+3*nAlpha*iPrim @@ -338,7 +303,7 @@ !*** Storage ipF2 = ip - ncb = nTri0Elem(jAng)*nTri0Elem(lb)*4 + ncb = nTri_Elem1(jAng)*nTri_Elem1(lb)*4 ip = ip+jPrim*nBeta*ncb ipP2 = ip ip = ip+3*jPrim*nBeta @@ -404,16 +369,16 @@ write(u6,*) ' Array(ipB)=',DNrm2_(JPrim*nBeta,Array(ipB),1) end if ip = ip-nBeta*jPrim*(6+3*n_Her*(lb+2)+3*n_Her*(jAng+1)+3*n_Her*(nOrdOp+1)+3*(lb+2)*(jAng+1)*(nOrdOp+1)+1) - nac = nTri0Elem(la)*nTri0Elem(iAng)*nVecAC - ncb = nTri0Elem(jAng)*nTri0Elem(lb)*nVecCB + nac = nTri_Elem1(la)*nTri_Elem1(iAng)*nVecAC + ncb = nTri_Elem1(jAng)*nTri_Elem1(lb)*nVecCB ipTmp = ip ip = ip+max(nAlpha*max(iPrim,jBas)*nac,nBeta*ncb*jBas) if (ip-1 > nArr*nZeta) then write(u6,*) ' ip-1 > nArr*nZeta(3) in FragPGrd' call Abend() end if - nac = nTri0Elem(la)*nTri0Elem(iAng) - ncb = nTri0Elem(jAng)*nTri0Elem(lb) + nac = nTri_Elem1(la)*nTri_Elem1(iAng) + ncb = nTri_Elem1(jAng)*nTri_Elem1(lb) ! * !***************************************************************** ! * @@ -428,10 +393,10 @@ ! to the spherical harmonics has to be for normalized ! spherical harmonics. ! - ! nAlpha = i nTri0Elem(la) = a - ! nBeta = j nTri0Elem(lb) = b - ! iPrim = k (iBas = K) nTri0Elem(iAng) = c (iSize = C) - ! jPrim = l (jBas = L) nTri0Elem(jAng) = d (jSize = D) + ! nAlpha = i nTri_Elem1(la) = a + ! nBeta = j nTri_Elem1(lb) = b + ! iPrim = k (iBas = K) nTri_Elem1(iAng) = c (iSize = C) + ! jPrim = l (jBas = L) nTri_Elem1(jAng) = d (jSize = D) ! !---From the lefthandside overlap, form iKaC from ikac by ! 1) i,kac -> k,aci @@ -445,21 +410,21 @@ !---3) a,ciK -> ciKa - call DgeTMo(Array(ipF1),nTri0Elem(la),nTri0Elem(la),nTri0Elem(iAng)*nVecAC*nAlpha*iBas,Array(ipTmp), & - nTri0Elem(iAng)*nVecAC*nAlpha*iBas) + call DgeTMo(Array(ipF1),nTri_Elem1(la),nTri_Elem1(la),nTri_Elem1(iAng)*nVecAC*nAlpha*iBas,Array(ipTmp), & + nTri_Elem1(iAng)*nVecAC*nAlpha*iBas) !---4) iKa,C = c,iKa * c,C if (Shells(iShll)%Transf .and. Shells(iShll)%Prjct) then - call DGEMM_('T','N',nVecAC*nAlpha*iBas*nTri0Elem(la),iSize,nTri0Elem(iAng),One,Array(ipTmp),nTri0Elem(iAng), & - RSph(ipSph(iAng)),nTri0Elem(iAng),Zero,Array(ipF1),nVecAC*nAlpha*iBas*nTri0Elem(la)) + call DGEMM_('T','N',nVecAC*nAlpha*iBas*nTri_Elem1(la),iSize,nTri_Elem1(iAng),One,Array(ipTmp),nTri_Elem1(iAng), & + RSph(ipSph(iAng)),nTri_Elem1(iAng),Zero,Array(ipF1),nVecAC*nAlpha*iBas*nTri_Elem1(la)) else - call DgeTMo(Array(ipTmp),nTri0Elem(iAng),nTri0Elem(iAng),nVecAC*iBas*nTri0Elem(la)*nAlpha,Array(ipF1), & - nVecAC*iBas*nTri0Elem(la)*nAlpha) + call DgeTMo(Array(ipTmp),nTri_Elem1(iAng),nTri_Elem1(iAng),nVecAC*iBas*nTri_Elem1(la)*nAlpha,Array(ipF1), & + nVecAC*iBas*nTri_Elem1(la)*nAlpha) end if ! what does this do and is it needed? (from PrjGrd) - call DgeTMo(Array(ipF1),nVecAC,nVecAC,nAlpha*iBas*nTri0Elem(la)*iSize,Array(ipTmp),nAlpha*iBas*nTri0Elem(la)*iSize) - call dcopy_(nVecAC*nAlpha*iBas*nTri0Elem(la)*iSize,Array(ipTmp),1,Array(ipF1),1) + call DgeTMo(Array(ipF1),nVecAC,nVecAC,nAlpha*iBas*nTri_Elem1(la)*iSize,Array(ipTmp),nAlpha*iBas*nTri_Elem1(la)*iSize) + call dcopy_(nVecAC*nAlpha*iBas*nTri_Elem1(la)*iSize,Array(ipTmp),1,Array(ipF1),1) !---And (almost) the same thing for the righthand side, form ! LjDb from ljdb @@ -475,20 +440,20 @@ !---3) bLj,D = d,bLj * d,D if (Shells(jShll)%Transf .and. Shells(jShll)%Prjct) then - call DGEMM_('T','N',nTri0Elem(lb)*nVecCB*jBas*nBeta,jSize,nTri0Elem(jAng),One,Array(ipF2),nTri0Elem(jAng), & - RSph(ipSph(jAng)),nTri0Elem(jAng),Zero,Array(ipTmp),nTri0Elem(lb)*nVecCB*jBas*nBeta) + call DGEMM_('T','N',nTri_Elem1(lb)*nVecCB*jBas*nBeta,jSize,nTri_Elem1(jAng),One,Array(ipF2),nTri_Elem1(jAng), & + RSph(ipSph(jAng)),nTri_Elem1(jAng),Zero,Array(ipTmp),nTri_Elem1(lb)*nVecCB*jBas*nBeta) else - call DgeTMo(Array(ipF2),nTri0Elem(jAng),nTri0Elem(jAng),nVecCB*jBas*nTri0Elem(lb)*nBeta,Array(ipTmp), & - nVecCB*jBas*nTri0Elem(lb)*nBeta) + call DgeTMo(Array(ipF2),nTri_Elem1(jAng),nTri_Elem1(jAng),nVecCB*jBas*nTri_Elem1(lb)*nBeta,Array(ipTmp), & + nVecCB*jBas*nTri_Elem1(lb)*nBeta) end if !---4) b,LjD -> LjD,b - call DgeTMo(Array(ipTmp),nTri0Elem(lb)*nVecCB,nTri0Elem(lb)*nVecCB,jBas*nBeta*jSize,Array(ipF2),jBas*nBeta*jSize) + call DgeTMo(Array(ipTmp),nTri_Elem1(lb)*nVecCB,nTri_Elem1(lb)*nVecCB,jBas*nBeta*jSize,Array(ipF2),jBas*nBeta*jSize) !---Next Contract (iKaC)*W(KLCD)*(LjDb) producing ijab - rFinal(:,:,:,:) = Zero + rFinal(:,:,:,1,:) = Zero if (iPrint >= 99) then call RecPrt('ipF1 (nVecAC x X)',' ',Array(ipF1),nVecAC,iBas*nAlpha*iSize) @@ -505,37 +470,37 @@ mVec = mVec+1 if (iCent == 1) then mVecAC = mVecAC+1 - ipF1a = ipF1+(mVecAC-1)*nAlpha*jBas*nTri0Elem(la)*iSize + ipF1a = ipF1+(mVecAC-1)*nAlpha*jBas*nTri_Elem1(la)*iSize ipF2a = ipF2 else ipF1a = ipF1 mVecCB = mVecCB+1 - ipF2a = ipF2+(mVecCB-1)*jBas*nBeta*jSize*nTri0Elem(lb) + ipF2a = ipF2+(mVecCB-1)*jBas*nBeta*jSize*nTri_Elem1(lb) end if if (iPrint >= 99) then write(u6,*) 'mVecAC, mVecCB = ',mVecAC,mVecCB - call RecPrt('ipF1a (nAlpha*aAng x iBas*iSize)',' ',Array(ipF1a),nAlpha*nTri0Elem(la),iBas*iSize) - call RecPrt('ipF2a (nBeta*bAng x jBas*jSize)',' ',Array(ipF2a),nBeta*nTri0Elem(lb),jBas*jSize) + call RecPrt('ipF1a (nAlpha*aAng x iBas*iSize)',' ',Array(ipF1a),nAlpha*nTri_Elem1(la),iBas*iSize) + call RecPrt('ipF2a (nBeta*bAng x jBas*jSize)',' ',Array(ipF2a),nBeta*nTri_Elem1(lb),jBas*jSize) end if - call FragPCont(Array(ipF1a),nAlpha,iBas,nTri0Elem(la),iSize,Array(ipF2a),jBas,nBeta,jSize,nTri0Elem(lb),Array(ipIJ), & - rFinal(:,:,:,mVec),Fact*Half) + call FragPCont(Array(ipF1a),nAlpha,iBas,nTri_Elem1(la),iSize,Array(ipF2a),jBas,nBeta,jSize,nTri_Elem1(lb),Array(ipIJ), & + rFinal(:,:,:,1,mVec),Fact*Half) end if end do !iCent end do !iCar if (iPrint >= 49) then do iVec=1,mVec - write(u6,*) iVec,sqrt(DNrm2_(nZeta*nTri0Elem(la)*nTri0Elem(lb),rFinal(1,1,1,iVec),1)) + write(u6,*) iVec,sqrt(DNrm2_(nZeta*nTri_Elem1(la)*nTri_Elem1(lb),rFinal(:,:,:,1,iVec),1)) end do end if if (iPrint >= 99) then write(u6,*) ' Result in FragPGrd' - do ia=1,nTri0Elem(la) - do ib=1,nTri0Elem(lb) + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb) do iVec=1,mVec write(Label,'(A,I2,A,I2,A,I2,A)') ' rFinal(',ia,',',ib,',',iVec,')' - call RecPrt(Label,' ',rFinal(1,ia,ib,iVec),nAlpha,nBeta) + call RecPrt(Label,' ',rFinal(:,ia,ib,1,iVec),nAlpha,nBeta) end do end do end do diff -Nru openmolcas-22.02/src/faiemp_util/fragpint.F90 openmolcas-22.10/src/faiemp_util/fragpint.F90 --- openmolcas-22.02/src/faiemp_util/fragpint.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/faiemp_util/fragpint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -21,30 +21,6 @@ ! Object: kernel routine for the computation of Fragment AIEMP * ! projection integrals * ! * -! Alpha : exponents of bra gaussians * -! nAlpha: number of primitives (exponents) of bra gaussians * -! Beta : as Alpha but for ket gaussians * -! nBeta : as nAlpha but for the ket gaussians * -! Zeta : sum of exponents (nAlpha x nBeta) * -! ZInv : inverse of Zeta * -! rKappa: gaussian prefactor for the products of bra and ket * -! gaussians. * -! P : center of new gaussian from the products of bra and ket * -! gaussians. * -! Final : array for computed integrals * -! nZeta : nAlpha x nBeta * -! nComp : number of components in the operator (e.g. dipolemoment * -! operator has three components) * -! la : total angular momentum of bra gaussian * -! lb : total angular momentum of ket gaussian * -! A : center of bra gaussian * -! B : center of ket gaussian * -! nRys : order of Rys- or Hermite-Gauss polynomial * -! Array : Auxiliary memory as requested by PrjMem * -! nArr : length of Array * -! Ccoor : coordinates of the operator, zero for symmetric oper. * -! NOrdOp: Order of the operator * -! * ! Author: Ben Swerts * ! based on seward/prjint.f * ! Modified: Liviu Ungur * @@ -67,12 +43,11 @@ use Basis_Info, only: dbsc, nCnttp, Shells use Center_Info, only: dc use Symmetry_Info, only: nIrrep, iChTbl -use Index_util, only: iTri, nTri0Elem +use Index_Functions, only: iTri, nTri_Elem1 use Constants, only: Zero, One, Two, Half use Definitions, only: wp, iwp, u6 implicit none -#define _USE_WP_ #include "int_interface.fh" ! Local variables integer(kind=iwp) :: iAng, iBas, iCnttp, iComp, iCurCenter, iCurCnttp, iCurMdc, iIC, iIrrep, iLoc, iPrim, ip, ipF1, ipF2, ipIJ, & @@ -117,8 +92,8 @@ write(u6,*) ' In FragPInt: nArr=',' ',nArr write(u6,*) ' In FragPInt: nIC=',' ',nIC write(u6,*) ' In FragPInt: la,lb=',' ',la,lb -write(u6,*) ' In FragPInt: nTri0Elem(la)=',' ',nTri0Elem(la) -write(u6,*) ' In FragPInt: nTri0Elem(lb)=',' ',nTri0Elem(lb) +write(u6,*) ' In FragPInt: nTri_Elem1(la)=',' ',nTri_Elem1(la) +write(u6,*) ' In FragPInt: nTri_Elem1(lb)=',' ',nTri_Elem1(lb) call RecPrt(' In FragPInt: A ',' ',A,1,3) call RecPrt(' In FragPInt: RB ',' ',RB,1,3) call RecPrt(' In FragPInt: Ccoor ',' ',Ccoor,1,3) @@ -127,7 +102,7 @@ call TrcPrt(' In FragPInt: Array ',' ',Array,nZeta,nArr) #endif -Final(:,:,:,:) = Zero +rFinal(:,:,:,:) = Zero ! * !*********************************************************************** ! * @@ -175,7 +150,7 @@ mdci = iSD(10,iS) iCnttp = iSD(13,iS) iCnt = iSD(14,iS) - iSize = nTri0Elem(iAng) + iSize = nTri_Elem1(iAng) C(1:3) = dbsc(iCnttp)%Coor(1:3,iCnt) ! some printouts: # ifdef _DEBUGPRINT_ @@ -253,7 +228,7 @@ jPrim = iSD(5,jS) jCnttp = iSD(13,jS) jCnt = iSD(14,jS) - jSize = nTri0Elem(jAng) + jSize = nTri_Elem1(jAng) B(1:3) = dbsc(jCnttp)%Coor(1:3,jCnt) # ifdef _DEBUGPRINT_ write(u6,'(A,i6,A,i16)') 'In FragPInt: jS=',jS,' jShll =',jShll @@ -272,10 +247,10 @@ ! * !******************************************************************* ! * - ! Create a rectangular matrix sized (iBas*nTri0Elem(iAng),jBas*nTri0Elem(jAng)) + ! Create a rectangular matrix sized (iBas*nTri_Elem1(iAng),jBas*nTri_Elem1(jAng)) ! from the energy weighted density matrix (desymmetrized) - ! contains values from iSbasis to iSbasis + iBas*nTri0Elem(iAng) - 1 - ! and from jSbasis to jSbasis + jBas*nTri0Elem(jAng) - 1 + ! contains values from iSbasis to iSbasis + iBas*nTri_Elem1(iAng) - 1 + ! and from jSbasis to jSbasis + jBas*nTri_Elem1(jAng) - 1 ipIJ = 1+maxDensSize # ifdef _DEBUGPRINT_ write(u6,*) ' ipIJ=',ipIJ @@ -319,7 +294,7 @@ ip = ipIJ+maxDensSize ipF1 = ip - nac = nTri0Elem(la)*nTri0Elem(iAng) + nac = nTri_Elem1(la)*nTri_Elem1(iAng) ip = ip+nAlpha*nac*iPrim ipP1 = ip ip = ip+3*nAlpha*iPrim @@ -351,7 +326,7 @@ ip = ip-6*nAlpha*iPrim ipF2 = ip - ncb = nTri0Elem(jAng)*nTri0Elem(lb) + ncb = nTri_Elem1(jAng)*nTri_Elem1(lb) ip = ip+jPrim*nBeta*ncb ipP2 = ip ip = ip+3*jPrim*nBeta @@ -398,10 +373,10 @@ ! to the spherical harmonics has to be for normalized ! spherical harmonics. ! - ! nAlpha = i nTri0Elem(la) = a - ! nBeta = j nTri0Elem(lb) = b - ! iPrim = k (iBas = K) nTri0Elem(iAng) = c (iSize = C) - ! jPrim = l (jBas = L) nTri0Elem(jAng) = d (jSize = D) + ! nAlpha = i nTri_Elem1(la) = a + ! nBeta = j nTri_Elem1(lb) = b + ! iPrim = k (iBas = K) nTri_Elem1(iAng) = c (iSize = C) + ! jPrim = l (jBas = L) nTri_Elem1(jAng) = d (jSize = D) ! !---From the lefthandside overlap, form iKaC from ikac by ! 1) i,kac -> k,aci @@ -424,29 +399,29 @@ !---4) a,ciK -> ciKa - call DgeTMo(Array(ipF1),nTri0Elem(la),nTri0Elem(la),nTri0Elem(iAng)*nAlpha*iBas,Array(ipTmp),nTri0Elem(iAng)*nAlpha*iBas) + call DgeTMo(Array(ipF1),nTri_Elem1(la),nTri_Elem1(la),nTri_Elem1(iAng)*nAlpha*iBas,Array(ipTmp),nTri_Elem1(iAng)*nAlpha*iBas) # ifdef _DEBUGPRINT_ - call RecPrt('result (regrouped, nTri0Elem(la) x X)',' ',Array(ipF1),nTri0Elem(la),nTri0Elem(iAng)*nAlpha*iBas) - call RecPrt('transpose of result (X x nTri0Elem(la))',' ',Array(ipTmp),nTri0Elem(iAng)*nAlpha*iBas,nTri0Elem(la)) + call RecPrt('result (regrouped, nTri_Elem1(la) x X)',' ',Array(ipF1),nTri_Elem1(la),nTri_Elem1(iAng)*nAlpha*iBas) + call RecPrt('transpose of result (X x nTri_Elem1(la))',' ',Array(ipTmp),nTri_Elem1(iAng)*nAlpha*iBas,nTri_Elem1(la)) # endif - if ((ip-ipTmp) < nAlpha*iBas*nTri0Elem(iAng)*nTri0Elem(la)) stop 'sizetest 6' + if ((ip-ipTmp) < nAlpha*iBas*nTri_Elem1(iAng)*nTri_Elem1(la)) stop 'sizetest 6' !---5) iKa,C = c,iKa * c,C if (Shells(iShll)%Transf .and. Shells(iShll)%Prjct) then - call DGEMM_('T','N',iBas*nTri0Elem(la)*nAlpha,iSize,nTri0Elem(iAng),One,Array(ipTmp),nTri0Elem(iAng),RSph(ipSph(iAng)), & - nTri0Elem(iAng),Zero,Array(ipF1),nAlpha*iBas*nTri0Elem(la)) + call DGEMM_('T','N',iBas*nTri_Elem1(la)*nAlpha,iSize,nTri_Elem1(iAng),One,Array(ipTmp),nTri_Elem1(iAng),RSph(ipSph(iAng)), & + nTri_Elem1(iAng),Zero,Array(ipF1),nAlpha*iBas*nTri_Elem1(la)) # ifdef _DEBUGPRINT_ - call RecPrt('result (regrouped, X x nTri0Elem(iAng))',' ',Array(ipTmp),nTri0Elem(la)*nAlpha*iBas,nTri0Elem(iAng)) - call RecPrt('Spher of iS (nTri0Elem(iAng) x (2*iAng+1))',' ',RSph(ipSph(iAng)),nTri0Elem(iAng),(2*iAng+1)) - call RecPrt('result in spherical gaussians (X x iSize',' ',Array(ipF1),nAlpha*iBas*nTri0Elem(la),iSize) + call RecPrt('result (regrouped, X x nTri_Elem1(iAng))',' ',Array(ipTmp),nTri_Elem1(la)*nAlpha*iBas,nTri_Elem1(iAng)) + call RecPrt('Spher of iS (nTri_Elem1(iAng) x (2*iAng+1))',' ',RSph(ipSph(iAng)),nTri_Elem1(iAng),(2*iAng+1)) + call RecPrt('result in spherical gaussians (X x iSize',' ',Array(ipF1),nAlpha*iBas*nTri_Elem1(la),iSize) # endif else - ! in this case nTri0Elem(iAng) = iSize - call DgeTMo(Array(ipTmp),nTri0Elem(iAng),nTri0Elem(iAng),iBas*nTri0Elem(la)*nAlpha,Array(ipF1), & - iBas*nTri0Elem(la)*nAlpha) + ! in this case nTri_Elem1(iAng) = iSize + call DgeTMo(Array(ipTmp),nTri_Elem1(iAng),nTri_Elem1(iAng),iBas*nTri_Elem1(la)*nAlpha,Array(ipF1), & + iBas*nTri_Elem1(la)*nAlpha) end if - if ((ipF2-ipF1) < nAlpha*iBas*nTri0Elem(la)*iSize) stop 'sizetest 7' + if ((ipF2-ipF1) < nAlpha*iBas*nTri_Elem1(la)*iSize) stop 'sizetest 7' !---And (almost) the same thing for the righthand side, form ! LjDb from ljdb @@ -470,25 +445,25 @@ !---3) bLj,D = d,bLj * d,D if (Shells(jShll)%Transf .and. Shells(jShll)%Prjct) then - call DGEMM_('T','N',nTri0Elem(lb)*jBas*nBeta,jSize,nTri0Elem(jAng),One,Array(ipF2),nTri0Elem(jAng),RSph(ipSph(jAng)), & - nTri0Elem(jAng),Zero,Array(ipTmp),nTri0Elem(lb)*jBas*nBeta) + call DGEMM_('T','N',nTri_Elem1(lb)*jBas*nBeta,jSize,nTri_Elem1(jAng),One,Array(ipF2),nTri_Elem1(jAng),RSph(ipSph(jAng)), & + nTri_Elem1(jAng),Zero,Array(ipTmp),nTri_Elem1(lb)*jBas*nBeta) # ifdef _DEBUGPRINT_ - call RecPrt('multiply right 2 (Y x jSize)',' ',Array(ipTmp),nBeta*jBas*nTri0Elem(lb),jSize) + call RecPrt('multiply right 2 (Y x jSize)',' ',Array(ipTmp),nBeta*jBas*nTri_Elem1(lb),jSize) # endif else - ! in this case nTri0Elem(jAng) = jSize - call DgeTMo(Array(ipF2),nTri0Elem(jAng),nTri0Elem(jAng),jBas*nTri0Elem(lb)*nBeta,Array(ipTmp),jBas*nTri0Elem(lb)*nBeta) + ! in this case nTri_Elem1(jAng) = jSize + call DgeTMo(Array(ipF2),nTri_Elem1(jAng),nTri_Elem1(jAng),jBas*nTri_Elem1(lb)*nBeta,Array(ipTmp),jBas*nTri_Elem1(lb)*nBeta) end if - if ((ip-ipTmp) < nBeta*jBas*nTri0Elem(lb)*jSize) stop 'sizetest 10' + if ((ip-ipTmp) < nBeta*jBas*nTri_Elem1(lb)*jSize) stop 'sizetest 10' !---4) b,LjD -> LjD,b - call DgeTMo(Array(ipTmp),nTri0Elem(lb),nTri0Elem(lb),jBas*nBeta*jSize,Array(ipF2),jBas*nBeta*jSize) + call DgeTMo(Array(ipTmp),nTri_Elem1(lb),nTri_Elem1(lb),jBas*nBeta*jSize,Array(ipF2),jBas*nBeta*jSize) # ifdef _DEBUGPRINT_ - call RecPrt('transposed right 2 (Y x nTri0Elem(lb)',' ',Array(ipF2),jBas*nBeta*jSize,nTri0Elem(lb)) + call RecPrt('transposed right 2 (Y x nTri_Elem1(lb)',' ',Array(ipF2),jBas*nBeta*jSize,nTri_Elem1(lb)) # endif - if ((ipTmp-ipF2) < nBeta*jBas*nTri0Elem(lb)*jSize) stop 'sizetest 11' + if ((ipTmp-ipF2) < nBeta*jBas*nTri_Elem1(lb)*jSize) stop 'sizetest 11' !---Next Contract (iKaC)*W(KLCD)*(LjDb) producing ijab, ! by the following procedure: @@ -499,16 +474,16 @@ ! End loop C ! End Loop b and a ! - ! Total size of ipF1 = nAlpha*nTri0Elem(la) * iBas*iSize -> ordered as (nAlpha, iBas, nTri0Elem(la), iSize) - ! ipF2 = nBeta*nTri0Elem(lb) * jBas*jSize (jBas, nBeta, jSize, nTri0Elem(lb)) - ! W = iBas*iSize * jBas*jSize (iBas, iSize, jBas, jSize) + ! Total size of ipF1 = nAlpha*nTri_Elem1(la) * iBas*iSize -> ordered as (nAlpha, iBas, nTri_Elem1(la), iSize) + ! ipF2 = nBeta*nTri_Elem1(lb) * jBas*jSize (jBas, nBeta, jSize, nTri_Elem1(lb)) + ! W = iBas*iSize * jBas*jSize (iBas, iSize, jBas, jSize) # ifdef _DEBUGPRINT_ - write(u6,*) ' Current contents of Final():' - do ia=1,nTri0Elem(la) - do ib=1,nTri0Elem(lb) - write(Label,'(A,I2,A,I2,A)') ' Final(',ia,',',ib,')' - call RecPrt(Label,' ',Final(:,ia,ib,:),nAlpha,nBeta) + write(u6,*) ' Current contents of rFinal():' + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb) + write(Label,'(A,I2,A,I2,A)') ' rFinal(',ia,',',ib,')' + call RecPrt(Label,' ',rFinal(:,ia,ib,:),nAlpha,nBeta) end do end do # endif @@ -525,18 +500,18 @@ !print(u6,*) 'CALL FragPCont' call xFlush(u6) - call FragPCont(Array(ipF1),nAlpha,iBas,nTri0Elem(la),iSize,Array(ipF2),jBas,nBeta,jSize,nTri0Elem(lb),Array(ipIJ), & - Final(:,:,:,iIC),Factor) + call FragPCont(Array(ipF1),nAlpha,iBas,nTri_Elem1(la),iSize,Array(ipF2),jBas,nBeta,jSize,nTri_Elem1(lb),Array(ipIJ), & + rFinal(:,:,:,iIC),Factor) end if end do if (iIC /= nIC) stop 'iIC /= nIC' # ifdef _DEBUGPRINT_ write(u6,*) ' After contraction:' - do ia=1,nTri0Elem(la) - do ib=1,nTri0Elem(lb) - write(Label,'(A,I2,A,I2,A)') ' Final(',ia,',',ib,')' - call RecPrt(Label,' ',Final(:,ia,ib,:),nAlpha,nBeta) + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb) + write(Label,'(A,I2,A,I2,A)') ' rFinal(',ia,',',ib,')' + call RecPrt(Label,' ',rFinal(:,ia,ib,:),nAlpha,nBeta) end do end do # endif @@ -553,10 +528,10 @@ #ifdef _DEBUGPRINT_ write(u6,*) ' Result in FragPInt' -do ia=1,nTri0Elem(la) - do ib=1,nTri0Elem(lb) - write(Label,'(A,I2,A,I2,A)') ' Final(',ia,',',ib,')' - call RecPrt(Label,' ',Final(:,ia,ib,:),nAlpha,nBeta) +do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb) + write(Label,'(A,I2,A,I2,A)') ' rFinal(',ia,',',ib,')' + call RecPrt(Label,' ',rFinal(:,ia,ib,:),nAlpha,nBeta) end do end do #endif @@ -568,10 +543,10 @@ ! Normally, the Add_Info must be called after the parallelization is finalized, ! i.e. in the OneEl function. !if (MyRank == 0) then -! do ia=1,nTri0Elem(la) -! do ib=1,nTri0Elem(lb) +! do ia=1,nTri_Elem1(la) +! do ib=1,nTri_Elem1(lb) ! dA = Zero -! dA = dnrm2_(nAlpha*nBeta,Final(1,ia,ib,1),1) +! dA = dnrm2_(nAlpha*nBeta,rFinal(1,ia,ib,1),1) ! if (dA > 1.0e-6_wp) then ! write(label,'(A,i2,A,i2)') 'Fragpint: ',ia,' ib ',ib ! call Add_Info(label,dA,1,6) diff -Nru openmolcas-22.02/src/faiemp_util/fragpmem.F90 openmolcas-22.10/src/faiemp_util/fragpmem.F90 --- openmolcas-22.02/src/faiemp_util/fragpmem.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/faiemp_util/fragpmem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -32,7 +32,6 @@ use Definitions, only: iwp implicit none -#define _USE_WP_ #include "mem_interface.fh" integer(kind=iwp) :: nExpi, nExpj, maxDensSize, iCnttp, jCnttp, iAng, jAng, iShll, jShll, ip, nac, ncb, MemMlt, nH, nBasisi, nBasisj diff -Nru openmolcas-22.02/src/faiemp_util/fragpmmg.F90 openmolcas-22.10/src/faiemp_util/fragpmmg.F90 --- openmolcas-22.02/src/faiemp_util/fragpmmg.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/faiemp_util/fragpmmg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -36,7 +36,6 @@ use Definitions, only: iwp implicit none -#define _USE_WP_ #include "mem_interface.fh" integer(kind=iwp) :: nOrder, maxDensSize, iCnttp, jCnttp, iAng, jAng, iShll, jShll, ip, nac, ncb, nExpi, nExpj, nBasisi, nBasisj diff -Nru openmolcas-22.02/src/faiemp_util/prepp_faiemp.F90 openmolcas-22.10/src/faiemp_util/prepp_faiemp.F90 --- openmolcas-22.02/src/faiemp_util/prepp_faiemp.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/faiemp_util/prepp_faiemp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -40,7 +40,7 @@ logical(kind=iwp) :: lPrint real(kind=wp) :: CoefX, CoefR character(len=8) :: RlxLbl, Method -character(len=16) :: KSDFT +character(len=80) :: KSDFT real(kind=wp), allocatable :: D1AV(:), Tmp(:) real(kind=wp), external :: Get_ExFac @@ -64,7 +64,7 @@ mCMo = S%n2Tot if (Method == 'KS-DFT ' .or. Method == 'CASDFT ') then call Get_iScalar('Multiplicity',iSpin) - call Get_cArray('DFT functional',KSDFT,16) + call Get_cArray('DFT functional',KSDFT,80) call Get_dScalar('DFT exch coeff',CoefX) call Get_dScalar('DFT corr coeff',CoefR) ExFac = Get_ExFac(KSDFT) @@ -116,7 +116,7 @@ nDSO = nDens mIrrep = nIrrep - call ICopy(nIrrep,nBas,1,mBas,1) + mBas(0:nIrrep-1) = nBas(0:nIrrep-1) if (lPrint) then write(u6,*) write(u6,'(2A)') ' Wavefunction type: ',Method @@ -137,7 +137,7 @@ call Get_iScalar('SA ready',iGo) if (iGO == 1) lSA = .true. mIrrep = nIrrep - call ICopy(nIrrep,nBas,1,mBas,1) + mBas(0:nIrrep-1) = nBas(0:nIrrep-1) if (lPrint .and. lSA) then write(u6,*) write(u6,'(2A)') ' Wavefunction type: State average ',Method(1:6) @@ -291,9 +291,9 @@ end if ! P are stored as - ! _ _ - ! P1= + sum_i + - ! P2=sum_i + ! _ _ + ! P1 = + sum_i + + ! P2 = sum_i call Get_PLMO(G2(:,2),nG2) call Daxpy_(nG2,One,G2(:,2),1,G2(:,1),1) diff -Nru openmolcas-22.02/src/ffpt/ptokt1.F90 openmolcas-22.10/src/ffpt/ptokt1.F90 --- openmolcas-22.02/src/ffpt/ptokt1.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ffpt/ptokt1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -13,7 +13,7 @@ !*********************************************************************** ! * ! Objective: Construct the perturbation operator of the form * -! =++ * +! = ++ * ! * !*********************************************************************** diff -Nru openmolcas-22.02/src/fock_util/cho_eval_waxy.F90 openmolcas-22.10/src/fock_util/cho_eval_waxy.F90 --- openmolcas-22.02/src/fock_util/cho_eval_waxy.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/cho_eval_waxy.F90 2022-10-10 14:22:40.000000000 +0000 @@ -11,7 +11,7 @@ subroutine CHO_eval_waxy(irc,Scr,ChoV1,ChoV2,W_PWXY,nAorb,JSYM,NUMV,DoTraInt,CMO) -use Symmetry_Info, only: MulD2h => Mul +use Symmetry_Info, only: Mul use Data_structures, only: DSBA_Type, SBA_Type, twxy_Type use Constants, only: Zero, One use Definitions, only: wp, iwp @@ -42,7 +42,7 @@ do iSymy=1,nSym - iSymx = MulD2h(iSymy,JSYM) + iSymx = Mul(iSymy,JSYM) Nxy = size(ChoV2%SB(iSymx)%A2,1) @@ -50,7 +50,7 @@ do iSyma=1,nSym - iSymw = MulD2h(iSyma,JSYM) + iSymw = Mul(iSyma,JSYM) Nwa = size(ChoV1%SB(iSymw)%A3,1)*size(ChoV1%SB(iSymw)%A3,2) @@ -85,10 +85,10 @@ iOrb = nOrb(iSymp) do iSymw=1,nSym jAsh = nAorb(iSymw) - ijSym = MulD2h(iSymp,iSymw) + ijSym = Mul(iSymp,iSymw) do iSymy=1,nSym kAsh = nAorb(iSymy) - iSymx = MulD2h(ijSym,iSymy) + iSymx = Mul(ijSym,iSymy) if (iSymx <= iSymy) then lAsh = nAorb(iSymx) kl_Orb_pairs = kAsh*lAsh+min(0,ijSym-2)*kAsh*(lAsh-1)/2 @@ -104,7 +104,7 @@ do iSymy=1,nSym - iSymx = MulD2h(iSymy,JSYM) + iSymx = Mul(iSymy,JSYM) if (iSymx <= iSymy) then @@ -112,7 +112,7 @@ do iSymw=1,nSym - iSyma = MulD2h(iSymw,JSYM) ! =iSymp + iSyma = Mul(iSymw,JSYM) ! =iSymp Nwa = nAorb(iSymw)*nBas(iSyma) Npw = nOrb(iSyma)*nAorb(iSymw) diff -Nru openmolcas-22.02/src/fock_util/cho_fmcscf.F90 openmolcas-22.10/src/fock_util/cho_fmcscf.F90 --- openmolcas-22.02/src/fock_util/cho_fmcscf.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/cho_fmcscf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -40,7 +40,7 @@ use ChoArr, only: nDimRS use ChoSwp, only: InfVec -use Symmetry_Info, only: MulD2h => Mul +use Symmetry_Info, only: Mul use Data_structures, only: Allocate_DT, Deallocate_DT, DSBA_Type, SBA_Type, twxy_Type use stdalloc, only: mma_allocate, mma_deallocate use Constants, only: Zero, One, Half @@ -128,7 +128,7 @@ ! --- Set up the skipping flags -------- ! ------------------------------------------------------------- do i=1,nSym - k = Muld2h(i,JSYM) + k = Mul(i,JSYM) iSkip(i) = min(1,nBas(i)*nBas(k)) ! skip Lik vector iSkip(i) = iSkip(i)*(nPorb(i)+nChM(i)) end do @@ -146,7 +146,7 @@ nAux(:) = nForb(:)+nIorb(:) do l=1,nSym - k = Muld2h(l,JSYM) + k = Mul(l,JSYM) mTvec1 = mTvec1+nBas(k)*nAux(l) mTvec2 = mTvec2+nBas(k)*nChM(l) mTvec3 = mTvec3+nBas(k)*nAorb(l) @@ -321,7 +321,7 @@ do iSyma=1,nSym - iSymk = MulD2h(JSYM,iSyma) + iSymk = Mul(JSYM,iSyma) ! --------------------------------------------------------------------- ! *** Compute only the LT part of the InActive exchange matrix ******** @@ -382,7 +382,7 @@ ! --------------------------------------------------------------------- do iSyma=1,nSym - iSymw = MulD2h(JSYM,iSyma) + iSymw = Mul(JSYM,iSyma) NAch = nChM(iSymw) @@ -458,7 +458,7 @@ ! ---------------------------------------------------------------- do iSymb=1,nSym - iSymv = MulD2h(JSYM,iSymb) + iSymv = Mul(JSYM,iSymb) NAv = nAorb(iSymv) NAw = nAorb(iSymb) ! iSymb=iSymw diff -Nru openmolcas-22.02/src/fock_util/cho_fmo_red.F90 openmolcas-22.10/src/fock_util/cho_fmo_red.F90 --- openmolcas-22.02/src/fock_util/cho_fmo_red.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/cho_fmo_red.F90 2022-10-10 14:22:40.000000000 +0000 @@ -65,7 +65,7 @@ ! !*********************************************************************** -use Symmetry_Info, only: MulD2h => Mul +use Symmetry_Info, only: Mul use Index_Functions, only: iTri use Fock_util_global, only: Deco, DensityCheck use Data_structures, only: Deallocate_DT, DSBA_Type, Integer_Pointer, Map_to_SBA, SBA_Type @@ -232,7 +232,7 @@ ! setup the skipping flags according to # of Occupied do k=1,nSym iSkip(k) = 0 - l = Muld2h(k,jsym) ! L(kl) returned if nOcc(k or l) /= 0 + l = Mul(k,jsym) ! L(kl) returned if nOcc(k or l) /= 0 if (k == l) then iSkip(k) = 666 ! always contribute to Coulomb else @@ -246,7 +246,7 @@ ! vectors in core (full storage) iE = 0 do iSymq=1,nSym - iSymp = muld2h(jSym,iSymq) + iSymp = Mul(jSym,iSymq) nq = nBas(iSymq) np = nBas(iSymp) @@ -478,7 +478,7 @@ do ISYMG=1,NSYM - ISYMB = MULD2H(ISYMG,JSYM) + ISYMB = Mul(ISYMG,JSYM) if (nBas(iSymb)*nBas(iSymg) /= 0) then diff -Nru openmolcas-22.02/src/fock_util/cho_fock_rassi.F90 openmolcas-22.10/src/fock_util/cho_fock_rassi.F90 --- openmolcas-22.02/src/fock_util/cho_fock_rassi.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/cho_fock_rassi.F90 2022-10-10 14:22:40.000000000 +0000 @@ -37,7 +37,7 @@ use ChoArr, only: nDimRS use ChoSwp, only: InfVec -use Symmetry_Info, only: MulD2h => Mul +use Symmetry_Info, only: Mul use Fock_util_global, only: Fake_CMO2 use Data_Structures, only: Allocate_DT, Deallocate_DT, DSBA_Type, SBA_Type, twxy_Type use stdalloc, only: mma_allocate, mma_deallocate @@ -111,7 +111,7 @@ mTvec = 0 ! mem for storing the half-transformed vec mTTvec = 0 ! mem for Lvb,J and Lvw,J do l=1,nSym - k = Muld2h(l,JSYM) + k = Mul(l,JSYM) mTvec = mTvec+nDen*nBas(l)*nIsh(k) mTTvec = mTTvec+(nBas(l)+nAsh(l))*nAsh(k) end do @@ -252,7 +252,7 @@ ! --------------------------------------------------------- do i=1,nSym - k = Muld2h(i,JSYM) + k = Mul(i,JSYM) iSkip(k) = min(1,NBAS(i)*nIsh(k)) end do @@ -276,7 +276,7 @@ do iSyma=1,nSym - iSymk = MulD2h(JSYM,iSyma) + iSymk = Mul(JSYM,iSyma) ! --------------------------------------------------------------------- ! *** Compute the InActive exchange matrix @@ -318,7 +318,7 @@ ! --------------------------------------------------------- do i=1,nSym - k = Muld2h(i,JSYM) + k = Mul(i,JSYM) iSkip(k) = min(1,NBAS(i)*nAsh(k)) end do @@ -338,7 +338,7 @@ ! ---------------------------------------------------------------- do iSymb=1,nSym - iSymv = MulD2h(JSYM,iSymb) + iSymv = Mul(JSYM,iSymb) NAv = nAsh(iSymv) NAw = nAsh(iSymb) ! iSymb=iSymw diff -Nru openmolcas-22.02/src/fock_util/cho_fock_rassi_x.F90 openmolcas-22.10/src/fock_util/cho_fock_rassi_x.F90 --- openmolcas-22.02/src/fock_util/cho_fock_rassi_x.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/cho_fock_rassi_x.F90 2022-10-10 14:22:40.000000000 +0000 @@ -33,7 +33,7 @@ use ChoArr, only: nDimRS use ChoSwp, only: InfVec -use Symmetry_Info, only: MulD2h => Mul +use Symmetry_Info, only: Mul use Fock_util_global, only: Fake_CMO2 use Data_Structures, only: Allocate_DT, Deallocate_DT, DSBA_Type, SBA_Type, twxy_Type use stdalloc, only: mma_allocate, mma_deallocate @@ -106,7 +106,7 @@ mTvec = 0 ! mem for storing the half-transformed vec mTTvec = 0 ! mem for Lvb,J and Lvw,J do l=1,nSym - k = Muld2h(l,JSYM) + k = Mul(l,JSYM) mTvec = mTvec+nDen*nBas(l)*nIsh(k) mTTvec = mTTvec+(nBas(l)+nAsh(l))*nAsh(k) end do @@ -246,7 +246,7 @@ ! --------------------------------------------------------- do i=1,nSym - k = Muld2h(i,JSYM) + k = Mul(i,JSYM) iSkip(k) = min(1,nIsh(k)*NBAS(i)) end do @@ -270,7 +270,7 @@ do iSyma=1,nSym - iSymk = MulD2h(JSYM,iSyma) + iSymk = Mul(JSYM,iSyma) ! --------------------------------------------------------------------- ! *** Compute the InActive exchange matrix @@ -313,7 +313,7 @@ ! --------------------------------------------------------- do i=1,nSym - k = Muld2h(i,JSYM) + k = Mul(i,JSYM) iSkip(k) = min(1,NBAS(i)*nAsh(k)) end do @@ -333,7 +333,7 @@ ! ---------------------------------------------------------------- do iSymb=1,nSym - iSymv = MulD2h(JSYM,iSymb) + iSymv = Mul(JSYM,iSymb) NAv = nAsh(iSymv) NAw = nAsh(iSymb) ! iSymb=iSymw diff -Nru openmolcas-22.02/src/fock_util/cho_focktwo.F90 openmolcas-22.10/src/fock_util/cho_focktwo.F90 --- openmolcas-22.02/src/fock_util/cho_focktwo.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/cho_focktwo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -59,7 +59,7 @@ ! !*********************************************************************** -use Symmetry_Info, only: MulD2h => Mul +use Symmetry_Info, only: Mul use Index_Functions, only: iTri use Fock_util_global, only: Lunit use Data_Structures, only: Deallocate_DT, DSBA_Type, Integer_Pointer, SBA_Type @@ -142,7 +142,7 @@ LUnit(:) = -1 do ksym=1,nSym if (nBas(ksym) /= 0) then - iSymp = MulD2h(ksym,jSym) + iSymp = Mul(ksym,jSym) if (iSymp >= ksym) then lu = 7 lu = isfreeunit(lu) @@ -207,7 +207,7 @@ ! setup the skipping flags according to # of Occupied do k=1,nSym iSkip(k) = 0 - l = Muld2h(k,jsym) ! L(kl) returned if nOcc(k or l) /= 0 + l = Mul(k,jsym) ! L(kl) returned if nOcc(k or l) /= 0 if (k == l) then iSkip(k) = 666 ! always contribute to Coulomb else @@ -230,7 +230,7 @@ iE = 0 do ksym=1,nSym - iSymp = MulD2h(ksym,jSym) + iSymp = Mul(ksym,jSym) iS = iE+1 @@ -260,7 +260,7 @@ end do ! ends the loop over symmetries do kSym=1,nSym - iSymp = MulD2h(ksym,jSym) + iSymp = Mul(ksym,jSym) if (.not. associated(Wab%SB(iSymp)%A2)) cycle NumB = size(Wab%SB(iSymp)%A2,1) call RdChoVec(Wab%SB(iSymp)%A2,NumB,NumV,iVec,Lunit(iSymp)) @@ -439,7 +439,7 @@ jE = iE do ISYMS=1,NSYM - ISYMQ = MULD2H(ISYMS,JSYM) + ISYMQ = Mul(ISYMS,JSYM) if (nBas(iSyms)*nBas(iSymq) <= 0) cycle @@ -478,7 +478,7 @@ do ISYMG=1,NSYM - ISYMB = MULD2H(ISYMG,JSYM) + ISYMB = Mul(ISYMG,JSYM) if (nBas(iSymb)*nBas(iSymg) /= 0) then diff -Nru openmolcas-22.02/src/fock_util/cho_focktwo_red.F90 openmolcas-22.10/src/fock_util/cho_focktwo_red.F90 --- openmolcas-22.02/src/fock_util/cho_focktwo_red.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/cho_focktwo_red.F90 2022-10-10 14:22:40.000000000 +0000 @@ -62,7 +62,7 @@ ! !*********************************************************************** -use Symmetry_Info, only: MulD2h => Mul +use Symmetry_Info, only: Mul use Index_Functions, only: iTri use Data_Structures, only: Deallocate_DT, DSBA_type, Integer_Pointer, Map_to_SBA, SBA_type use stdalloc, only: mma_allocate @@ -196,7 +196,7 @@ ! setup the skipping flags according to # Occupied do k=1,nSym iSkip(k) = 0 - l = Muld2h(k,jsym) ! L(kl) returned if nOcc(k or l) /= 0 + l = Mul(k,jsym) ! L(kl) returned if nOcc(k or l) /= 0 if (k == l) then iSkip(k) = 666 ! always contribute to Coulomb else @@ -218,7 +218,7 @@ ! vectors in core (full storage) iE = 0 do iSymq=1,nSym - iSymp = muld2h(jSym,iSymq) + iSymp = Mul(jSym,iSymq) nq = nBas(iSymq) np = nBas(iSymp) if (nq*np <= 0) cycle @@ -431,7 +431,7 @@ do ISYMG=1,NSYM - ISYMB = MULD2H(ISYMG,JSYM) + ISYMB = Mul(ISYMG,JSYM) if (nBas(iSymb)*nBas(iSymg) <= 0) cycle diff -Nru openmolcas-22.02/src/fock_util/cho_fscf.F90 openmolcas-22.10/src/fock_util/cho_fscf.F90 --- openmolcas-22.02/src/fock_util/cho_fscf.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/cho_fscf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -30,7 +30,7 @@ use ChoArr, only: nDimRS use ChoSwp, only: InfVec -use Symmetry_Info, only: MulD2h => Mul +use Symmetry_Info, only: Mul use Data_structures, only: Allocate_DT, Deallocate_DT, DSBA_Type, SBA_Type use stdalloc, only: mma_allocate, mma_deallocate use Constants, only: Zero, One @@ -99,7 +99,7 @@ mTvec = 0 ! mem for storing the half-transformed vec do l=1,nSym - k = Muld2h(l,JSYM) + k = Mul(l,JSYM) Mmax = 0 do jDen=1,nDen Mmax = max(Mmax,nForb(k,jDen)+nIorb(k,jDen)) @@ -242,7 +242,7 @@ ! ------------------------------------------------------------- do i=1,nSym - k = Muld2h(i,JSYM) + k = Mul(i,JSYM) iSkip(k) = min(1,nBas(i)*(nForb(k,jDen)+nIorb(k,jDen))) end do @@ -265,7 +265,7 @@ do iSyma=1,nSym - iSymk = MulD2h(JSYM,iSyma) + iSymk = Mul(JSYM,iSyma) ! --------------------------------------------------------------------- ! *** Compute only the LT part of the InActive exchange matrix ******** diff -Nru openmolcas-22.02/src/fock_util/cho_ftwo_mo.F90 openmolcas-22.10/src/fock_util/cho_ftwo_mo.F90 --- openmolcas-22.02/src/fock_util/cho_ftwo_mo.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/cho_ftwo_mo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -56,7 +56,7 @@ ! !*********************************************************************** -use Symmetry_Info, only: MulD2h => Mul +use Symmetry_Info, only: Mul use Index_Functions, only: iTri use Fock_util_global, only: Deco, DensityCheck, Lunit use Data_Structures, only: Deallocate_DT, DSBA_Type, Integer_Pointer, SBA_Type @@ -166,7 +166,7 @@ ! Open Files do ksym=1,nSym if (nBas(ksym) /= 0) then - iSymp = MulD2h(ksym,jSym) + iSymp = Mul(ksym,jSym) if (iSymp >= ksym) then Lunit(iSymp) = 7 write(Fname,'(A4,I1,I1)') BaseNm,iSymp,ksym @@ -230,7 +230,7 @@ !setup the skipping flags according to # of Occupied do k=1,nSym iSkip(k) = 0 - l = Muld2h(k,jsym) ! L(kl) returned if nOcc(k or l) /= 0 + l = Mul(k,jsym) ! L(kl) returned if nOcc(k or l) /= 0 if (k == l) then iSkip(k) = 666 ! always contribute to Coulomb else @@ -253,7 +253,7 @@ iE = 0 do ksym=1,nSym - iSymp = MulD2h(ksym,jSym) + iSymp = Mul(ksym,jSym) nk = nBas(kSym) np = nBas(iSymp) @@ -282,7 +282,7 @@ end do ! ends the loop over symmetries do kSym=1,nSym - iSymp = MulD2h(ksym,jSym) + iSymp = Mul(ksym,jSym) if (.not. associated(Wab%SB(iSymp)%A2)) cycle NumB = size(Wab%SB(iSymp)%A2,1) call RdChoVec(Wab%SB(iSymp)%A2,NumB,NumV,iVec,Lunit(iSymp)) @@ -469,7 +469,7 @@ jE = iE do ISYMS=1,NSYM - ISYMQ = MULD2H(ISYMS,JSYM) + ISYMQ = Mul(ISYMS,JSYM) ns = nBas(iSyms) nq = nBas(iSymq) @@ -515,7 +515,7 @@ do ISYMG=1,NSYM - ISYMB = MULD2H(ISYMG,JSYM) + ISYMB = Mul(ISYMG,JSYM) nb = nBas(iSymb) ng = nBas(iSymg) diff -Nru openmolcas-22.02/src/fock_util/cho_getshfull.F90 openmolcas-22.10/src/fock_util/cho_getshfull.F90 --- openmolcas-22.02/src/fock_util/cho_getshfull.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/cho_getshfull.F90 2022-10-10 14:22:40.000000000 +0000 @@ -16,7 +16,7 @@ use ChoArr, only: iBasSh, iRS2F, iShlSO, iSOShl, nDimRS use ChoSwp, only: IndRed, IndRSh -use Symmetry_Info, only: MulD2h => Mul +use Symmetry_Info, only: Mul use Data_Structures, only: L_Full_Type use Constants, only: Zero use Definitions, only: wp, iwp @@ -125,7 +125,7 @@ ibSg = iShlSO(ibg) iSyma = cho_isao(iag) ! symmetry block - iSymb = muld2h(jSym,iSyma) ! iSyma >= iSymb + iSymb = Mul(jSym,iSyma) ! iSyma >= iSymb i1 = 1 if (iaSh < ibSh) i1 = 2 diff -Nru openmolcas-22.02/src/fock_util/cho_lk_casscf.F90 openmolcas-22.10/src/fock_util/cho_lk_casscf.F90 --- openmolcas-22.02/src/fock_util/cho_lk_casscf.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/cho_lk_casscf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -44,7 +44,7 @@ use ChoArr, only: nBasSh, nDimRS use ChoSwp, only: IndRed, InfVec, nnBstRSh -use Symmetry_Info, only: MulD2h => Mul +use Symmetry_Info, only: Mul use Index_Functions, only: iTri use Fock_util_global, only: Estimate, Update use Data_Structures, only: Allocate_DT, Deallocate_DT, DSBA_Type, L_Full_Type, Lab_Type, NDSBA_Type, SBA_Type, twxy_Type @@ -70,9 +70,9 @@ integer(kind=iwp) :: i, ia, iab, iag, iaSh, iaSkip, ib, iBatch, ibcount, ibg, ibs, ibSh, ibSkip, iCase, iE, ik, iLoc, iml, Inc, & ioffa, iOffAB, ioffb, iOffShb, irc, ired1, IREDC, iS, ish, iShp, iSwap, ISYM, iSyma, iSymb, iSymv, iTmp, & IVEC2, iVrs, jDen, jK, jK_a, jml, jmlmax, JNUM, JRED, JRED1, JRED2, jrs, jSym, jvc, JVEC, k, kMOs, kOff(8,2), & - krs, kscreen, kSym, l, l1, LFMAX, LFULL, LKsh, LKshp, LREAD, lSh, lSym, LWORK, MaxB, MaxRedT, MaxVecPerBatch, & - mDen, mrs, mSh, mTvec, mTvec1, mTvec2, MUSED, MxB, MxBasSh, myJRED2, n1, n2, nAt, NAv, NAw, nBatch, nBs, & - nBsa, nBsb, nDen, nIt, nkOrb, nMOs, nnA(8,8), nnO, nRS, NumCV, numSh, NUMV, NumVT, nVec, nVrs + krs, kscreen, kSym, l, l1, LFMAX, LFULL(2), LKsh, LKshp, LREAD, lSh, lSym, LWORK, MaxB, MaxRedT, & + MaxVecPerBatch, mDen, mrs, mSh, mTvec, mTvec1, mTvec2, MUSED, MxB, MxBasSh, myJRED2, n1, n2, nAt, NAv, NAw, & + nBatch, nBs, nBsa, nBsb, nDen, nIt, nkOrb, nMOs, nnA(8,8), nnO, nRS, NumCV, numSh, NUMV, NumVT, nVec, nVrs real(kind=wp) :: Fact, FactC(2), FactX(2), fcorr, LKThr, SKsh, tau(2), TCC1, TCC2, TCINT1, TCINT2, tcoul(2), TCR1, TCR2, TCS1, & TCS2, TCT1, TCT2, TCX1, TCX2, texch(2), thrv(2), tintg(2), tmotr(2), Tmp, tread(2), TOTCPU, TOTCPU1, TOTCPU2, & TOTWALL, TOTWALL1, TOTWALL2, tscrn(2), TWC1, TWC2, TWINT1, TWINT2, TWR1, TWR2, TWS1, TWS2, TWT1, TWT2, TWX1, & @@ -373,14 +373,14 @@ mTvec2 = 0 MxB = 0 do l=1,nSym - k = Muld2h(l,JSYM) + k = Mul(l,JSYM) if ((nFIorb(k)+nChM(k)) > 0) MxB = max(MxB,nBas(l)) mTvec1 = mTvec1+nAorb(k)*nBas(l) if (k <= l) mTvec2 = mTvec2+nnA(k,l) end do mTvec = mTvec1+mTvec2 - LFMAX = max(mTvec,LFULL) ! re-use memory for the active vec + LFMAX = max(mTvec,LFULL(1)) ! re-use memory for the active vec mTvec = max(MxB,1) ! mem for storing half-transformed vec ! ------------------------------------------------------------------ @@ -434,7 +434,7 @@ call mma_maxDBLE(LWORK) - nVec = min(LWORK/(nRS+mTvec+LFMAX),min(nVrs,MaxVecPerBatch)) + nVec = min((LWORK-LFULL(2))/(nRS+mTvec+LFMAX),min(nVrs,MaxVecPerBatch)) if (nVec < 1) then write(u6,*) SECNAM//': Insufficient memory for batch' @@ -592,7 +592,7 @@ do kSym=1,nSym - lSym = MulD2h(JSYM,kSym) + lSym = Mul(JSYM,kSym) nkOrb = nFIorb(kSym)*(2-jDen)+nChM(kSym)*(jDen-1) @@ -1037,7 +1037,7 @@ ! ---------------------------------------------------------------- do iSymb=1,nSym - iSymv = MulD2h(JSYM,iSymb) + iSymv = Mul(JSYM,iSymb) NAv = nAorb(iSymv) NAw = nAorb(iSymb) ! iSymb=iSymw diff -Nru openmolcas-22.02/src/fock_util/cho_lk_mclr.F90 openmolcas-22.10/src/fock_util/cho_lk_mclr.F90 --- openmolcas-22.02/src/fock_util/cho_lk_mclr.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/cho_lk_mclr.F90 2022-10-10 14:22:40.000000000 +0000 @@ -34,7 +34,7 @@ use ChoArr, only: nBasSh, nDimRS use ChoSwp, only: IndRed, InfVec, nnBstRSh -use Symmetry_Info, only: MulD2h => Mul +use Symmetry_Info, only: Mul use Index_Functions, only: iTri use Fock_util_global, only: Deco, dmpk, Estimate, Nscreen, Update use Data_Structures, only: Allocate_DT, Deallocate_DT, DSBA_Type, G2_Type, L_Full_Type, Lab_Type, NDSBA_Type, SBA_Type @@ -62,7 +62,7 @@ iCase, iE, iij, ijS, ijsym, ik, ikl, iLoc, iml, Inc, ioff, ioffa, iOffAB, ioffb, iOffShb, ipG, irc, ired1, & IREDC, iS, ish, iShp, iSwap, ISYM, iSyma, iSymb, iSymv, isymx, iSymy, iTmp, IVEC2, iVrs, jab, jAsh, jaSkip, & jDen, jK, jK_a, jml, jmlmax, JNUM, jOffAB, JRED, JRED1, JRED2, jrs, jS, jsym, jvc, JVEC, k, kaOff(8), kAsh, & - kDen, kMOs, kOff(8), krs, kS, kscreen, kSym, l, l1, lAsh, LFMAX, LFULL, LKsh, LKshp, LREAD, ls, lSh, lSym, & + kDen, kMOs, kOff(8), krs, kS, kscreen, kSym, l, l1, lAsh, LFMAX, LFULL(2), LKsh, LKshp, LREAD, ls, lSh, lSym, & lvec, LWORK, MaxAct, MaxB, MaxRedT, MaxVecPerBatch, Mmax, mrs, mSh, mTvec, mTvec1, MUSED, MxB, MxBasSh, & n1, n2, nA2, NAv, NAw, Nax, Nay, nBatch, nBsa, nChMo(8), nDen, nMat, nMOs, nnA, nnO, nnShl_2, nRS, NumCV, & numSh1, numSh2, NUMV, NumVT, nVec, nVrs @@ -402,7 +402,7 @@ mTvec1 = 0 MxB = 0 do l=1,nSym - k = Muld2h(l,JSYM) + k = Mul(l,JSYM) Mmax = max(0,nOrb(k)) if (Mmax > 0) MxB = max(MxB,nBas(l)) if (DoAct) then @@ -410,7 +410,7 @@ end if end do - LFMAX = max(3*mTvec1,LFULL) ! re-use memory for the active vec + LFMAX = max(3*mTvec1,LFULL(1)) ! re-use memory for the active vec mTvec = nDen*max(MxB,1) ! mem for storing half-transformed vec ! ------------------------------------------------------------------ @@ -467,7 +467,7 @@ call mma_maxDBLE(LWORK) - nVec = min(LWORK/(nRS+mTvec+LFMAX),min(nVrs,MaxVecPerBatch)) + nVec = min((LWORK-LFULL(2))/(nRS+mTvec+LFMAX),min(nVrs,MaxVecPerBatch)) ! Store nVec to make sure the routine always uses the same if (iAChoVec == 1) nVec_ = nVec @@ -623,7 +623,7 @@ do kSym=1,nSym - lSym = MulD2h(JSYM,kSym) + lSym = Mul(JSYM,kSym) do jK=1,nOrb(kSym) @@ -1127,7 +1127,7 @@ if (iAChoVec == 2) then ioff = 0 do i=1,nSym - k = Muld2h(i,JSYM) + k = Mul(i,JSYM) lvec = nAsh(k)*nBas(i)*JNUM iAdr2 = (JVEC-1)*nAsh(k)*nBas(i)+ioff call DDAFILE(LuAChoVec(Jsym),2,Lpq(1)%SB(k)%A3,lvec,iAdr2) @@ -1145,7 +1145,7 @@ ioff = 0 if (iAChoVec == 1) then do i=1,nSym - k = Muld2h(i,JSYM) + k = Mul(i,JSYM) lvec = nAsh(k)*nBas(i)*JNUM iAdr2 = (JVEC-1)*nAsh(k)*nBas(i)+ioff call DDAFILE(LuAChoVec(Jsym),1,Lpq(1)%SB(k)%A3,lvec,iAdr2) @@ -1161,7 +1161,7 @@ ! ---------------------------------------------------------------- do iSymb=1,nSym - iSymv = MulD2h(JSYM,iSymb) + iSymv = Mul(JSYM,iSymb) NAv = nAsh(iSymv) NAw = nAsh(iSymb) @@ -1206,7 +1206,7 @@ ! *************** EVALUATION OF THE (TW|XY) INTEGRALS *********** if (iSymv > iSymb) cycle do isymx=1,iSymb - iSymy = MulD2h(JSYM,iSymx) + iSymy = Mul(JSYM,iSymx) if ((iSymy > iSymx) .or. ((iSymb == isymx) .and. (iSymy > iSymv))) cycle Nax = nAsh(iSymx) Nay = nAsh(iSymy) @@ -1235,7 +1235,7 @@ do iSymb=1,nSym - iSymv = MulD2h(JSYM,iSymb) + iSymv = Mul(JSYM,iSymb) NAv = nAsh(iSymv) NAw = nAsh(iSymb) @@ -1260,7 +1260,7 @@ ! ---------------------------------------------------------------- do iSymb=1,nSym - iSymv = MulD2h(JSYM,iSymb) + iSymv = Mul(JSYM,iSymb) NAv = nAsh(iSymv) NAw = nAsh(iSymb) @@ -1269,7 +1269,7 @@ Lpq(3)%SB(iSymv)%A3(:,:,:) = Zero do iSymx=1,nSym - iSymy = MulD2h(JSYM,iSymx) + iSymy = Mul(JSYM,iSymx) Nax = nAsh(iSymx) Nay = nAsh(iSymy) @@ -1302,7 +1302,7 @@ ! Exchange term do iSymb=1,nSym - iSymv = MulD2h(JSYM,iSymb) + iSymv = Mul(JSYM,iSymb) NAv = nAsh(iSymv) NAw = nAsh(iSymb) @@ -1345,7 +1345,7 @@ !MGD what if Naw=0 but not NBas(b)? do iSymb=1,nSym - iSymv = MulD2h(JSYM,iSymb) + iSymv = Mul(JSYM,iSymb) NAv = nAsh(iSymv) NAw = nAsh(iSymb) diff -Nru openmolcas-22.02/src/fock_util/cho_lk_rassi.F90 openmolcas-22.10/src/fock_util/cho_lk_rassi.F90 --- openmolcas-22.02/src/fock_util/cho_lk_rassi.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/cho_lk_rassi.F90 2022-10-10 14:22:40.000000000 +0000 @@ -37,7 +37,7 @@ use ChoArr, only: nBasSh, nDimRS use ChoSwp, only: IndRed, InfVec, nnBstRSh -use Symmetry_Info, only: MulD2h => Mul +use Symmetry_Info, only: Mul use Index_Functions, only: iTri use Fock_util_interface, only: cho_lr_MOs use Fock_util_global, only: Deco, Estimate, Fake_CMO2, PseudoChoMOs, Update @@ -65,9 +65,10 @@ integer(kind=iwp) :: ia, iab, iabg, iag, iaSh, iaSkip, ib, iBatch, ibcount, ibg, ibs, ibSh, ibSkip, iCase, iE, ik, iLoc, iml, Inc, & ioffa, iOffAB, ioffb, iOffShb, iOK, irc, ired1, IREDC, iS, ish, iShp, iSwap, ISYM, iSyma, iSymb, iSymv, iTmp, & IVEC2, iVrs, jaSkip, jden, jK, jK_a, jml, jmlmax, JNUM, JRED, JRED1, JRED2, jrs, jSym, jvc, JVEC, k, kDen, & - kMOs, kOff(8), krs, kscreen, kSym, l, l1, LFMAX, LFULL, LKsh, LKshp, LREAD, lSh, lSym, LWORK, MaxB, MaxRedT, & - MaxVecPerBatch, Mmax, mrs, mSh, mTvec, mTvec1, mTvec2, MUSED, MxB, MxBasSh, myJRED2, n1, n2, nAux(8), NAv, & - NAw, nBatch, nBs, nBsa, nDen, nMat, nMOs, nnO, nRS, NumCV, numSh1, numSh2, NUMV, NumVT, nVec, nVrs + kMOs, kOff(8), krs, kscreen, kSym, l, l1, LFMAX, LFULL(2), LKsh, LKshp, LREAD, lSh, lSym, LWORK, MaxB, & + MaxRedT, MaxVecPerBatch, Mmax, mrs, mSh, mTvec, mTvec1, mTvec2, MUSED, MxB, MxBasSh, myJRED2, n1, n2, & + nAux(8), NAv, NAw, nBatch, nBs, nBsa, nDen, nMat, nMOs, nnO, nRS, NumCV, numSh1, numSh2, NUMV, NumVT, nVec, & + nVrs real(kind=wp) :: Fact, LKThr, SKsh, tau, TCC1, TCC2, TCINT1, TCINT2, tcoul(2), TCR1, TCR2, TCS1, TCS2, TCT1, TCT2, TCX1, TCX2, & texch(2), THRSX, thrv, tintg(2), tmotr(2), Tmp, TOTCPU, TOTCPU1, TOTCPU2, TOTWALL, TOTWALL1, TOTWALL2, tread(2), & tscrn(2), TWC1, TWC2, TWINT1, TWINT2, TWR1, TWR2, TWS1, TWS2, TWT1, TWT2, TWX1, TWX2, xFab, xtau, xTmp, YMax, & @@ -345,7 +346,7 @@ mTvec2 = 0 MxB = 0 do l=1,nSym - k = Muld2h(l,JSYM) + k = Mul(l,JSYM) Mmax = max(0,nIsh(k)) if (Mmax > 0) MxB = max(MxB,nBas(l)) mTvec1 = mTvec1+nAsh(k)*nBas(l) @@ -353,7 +354,7 @@ end do mTvec = mTvec1+mTvec2 - LFMAX = max(mTvec,LFULL) ! re-use memory for the active vec + LFMAX = max(mTvec,LFULL(1)) ! re-use memory for the active vec mTvec = nDen*max(MxB,1) ! mem for storing half-transformed vec ! ------------------------------------------------------------------ @@ -405,7 +406,7 @@ call mma_maxDBLE(LWORK) - nVec = min(LWORK/(nRS+mTvec+LFMAX),min(nVrs,MaxVecPerBatch)) + nVec = min((LWORK-LFULL(2))/(nRS+mTvec+LFMAX),min(nVrs,MaxVecPerBatch)) if (nVec < 1) then write(u6,*) SECNAM//': Insufficient memory for batch' @@ -555,7 +556,7 @@ do kSym=1,nSym - lSym = MulD2h(JSYM,kSym) + lSym = Mul(JSYM,kSym) do jK=1,nIsh(kSym) @@ -1044,7 +1045,7 @@ ! ---------------------------------------------------------------- do iSymb=1,nSym - iSymv = MulD2h(JSYM,iSymb) + iSymv = Mul(JSYM,iSymb) NAv = nAsh(iSymv) NAw = nAsh(iSymb) ! iSymb=iSymw diff -Nru openmolcas-22.02/src/fock_util/cho_lk_rassi_x.F90 openmolcas-22.10/src/fock_util/cho_lk_rassi_x.F90 --- openmolcas-22.02/src/fock_util/cho_lk_rassi_x.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/cho_lk_rassi_x.F90 2022-10-10 14:22:40.000000000 +0000 @@ -35,7 +35,7 @@ use ChoSwp, only: IndRed, InfVec, nnBstRSh use Fock_util_interface, only: cho_lr_MOs use Fock_util_global, only: Deco, Estimate, Fake_CMO2, PseudoChoMOs, Update -use Symmetry_Info, only: MulD2h => Mul +use Symmetry_Info, only: Mul use Index_Functions, only: iTri use Data_Structures, only: Allocate_DT, Deallocate_DT, DSBA_Type, L_Full_Type, Lab_Type, NDSBA_Type, SBA_Type, twxy_Type #ifdef _MOLCAS_MPP_ @@ -62,9 +62,10 @@ integer(kind=iwp) :: ia, iab, iabg, iag, iaSh, iaSkip, ib, iBatch, ibcount, ibg, ibs, ibSh, ibSkip, iCase, iE, ik, iLoc, iml, Inc, & ioffa, iOffAB, ioffb, iOffShb, iOK, irc, ired1, IREDC, iS, ish, iShp, iSwap, ISYM, iSyma, iSymb, iSymv, iTmp, & IVEC2, iVrs, jaSkip, jden, jK, jK_a, jml, jmlmax, JNUM, JRED, JRED1, JRED2, jrs, jSym, jvc, JVEC, k, kDen, & - kMOs, kOff(8), krs, kscreen, kSym, l, l1, LFMAX, LFULL, LKsh, LKshp, LREAD, lSh, lSym, LWORK, MaxB, MaxRedT, & - MaxVecPerBatch, Mmax, mrs, mSh, mTVec, mTvec1, mTvec2, MUSED, MxB, MxBasSh, myJRED2, n1, n2, nAux(8), NAv, & - NAw, nBatch, nBsa, nDen, nMat, nMOs, nnO, nnShl_2, nRS, NumCV, numSh1, numSh2, NUMV, NumVT, nVec, nVrs + kMOs, kOff(8), krs, kscreen, kSym, l, l1, LFMAX, LFULL(2), LKsh, LKshp, LREAD, lSh, lSym, LWORK, MaxB, & + MaxRedT, MaxVecPerBatch, Mmax, mrs, mSh, mTVec, mTvec1, mTvec2, MUSED, MxB, MxBasSh, myJRED2, n1, n2, & + nAux(8), NAv, NAw, nBatch, nBsa, nDen, nMat, nMOs, nnO, nnShl_2, nRS, NumCV, numSh1, numSh2, NUMV, NumVT, & + nVec, nVrs real(kind=wp) :: Fact, LKThr, SKsh, tau, TCC1, TCC2, TCINT1, TCINT2, tcoul(2), TCR1, TCR2, TCS1, TCS2, TCT1, TCT2, TCX1, TCX2, & texch(2), THRSX, thrv, tintg(2), tmotr(2), Tmp, TOTCPU, TOTCPU1, TOTCPU2, TOTWALL, TOTWALL1, TOTWALL2, tread(2), & tscrn(2), TWC1, TWC2, TWINT1, TWINT2, TWR1, TWR2, TWS1, TWS2, TWT1, TWT2, TWX1, TWX2, xFab, xtau, xTmp, YMax, & @@ -336,7 +337,7 @@ mTvec2 = 0 MxB = 0 do l=1,nSym - k = Muld2h(l,JSYM) + k = Mul(l,JSYM) Mmax = max(0,nIsh(k)) if (Mmax > 0) MxB = max(MxB,nBas(l)) mTvec1 = mTvec1+nAsh(k)*nBas(l) @@ -344,7 +345,7 @@ end do mTVec = mTVec1+mTVec2 - LFMAX = max(mTvec,LFULL) ! re-use memory for the active vec + LFMAX = max(mTvec,LFULL(1)) ! re-use memory for the active vec mTvec = nDen*max(MxB,1) ! mem for storing half-transformed vec ! ------------------------------------------------------------------ @@ -396,7 +397,7 @@ call mma_maxDBLE(LWORK) - nVec = min(LWORK/(nRS+mTvec+LFMAX),min(nVrs,MaxVecPerBatch)) + nVec = min((LWORK-LFULL(2))/(nRS+mTvec+LFMAX),min(nVrs,MaxVecPerBatch)) if (nVec < 1) then write(u6,*) SECNAM//': Insufficient memory for batch' @@ -547,7 +548,7 @@ do kSym=1,nSym - lSym = MulD2h(JSYM,kSym) + lSym = Mul(JSYM,kSym) do jK=1,nIsh(kSym) @@ -1010,7 +1011,7 @@ ! ---------------------------------------------------------------- do iSymb=1,nSym - iSymv = MulD2h(JSYM,iSymb) + iSymv = Mul(JSYM,iSymb) NAv = nAsh(iSymv) NAw = nAsh(iSymb) ! iSymb=iSymw diff -Nru openmolcas-22.02/src/fock_util/cho_lk_scf.F90 openmolcas-22.10/src/fock_util/cho_lk_scf.F90 --- openmolcas-22.02/src/fock_util/cho_lk_scf.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/cho_lk_scf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -32,7 +32,7 @@ use ChoArr, only: nBasSh, nDimRS use ChoSwp, only: IndRed, InfVec, nnBstRSh -use Symmetry_Info, only: MulD2h => Mul +use Symmetry_Info, only: Mul use Index_Functions, only: iTri use Fock_util_global, only: Estimate, Update use Data_Structures, only: Allocate_DT, Deallocate_DT, DSBA_Type, L_Full_Type, Lab_Type, NDSBA_Type @@ -56,7 +56,7 @@ integer(kind=iwp) :: i, i1, ia, iab, iabg, iag, iaSh, iaSkip, ib, iBatch, ibcount, ibg, ibs, ibSh, ibSkip, iE, ik, iLoc, iml, Inc, & ioffa, iOffAB, ioffb, iOffShb, irc, ired1, IREDC, iS, ish, iShp, ISYM, iSyma, iTmp, IVEC2, iVrs, jDen, jK, & jK_a, jml, jmlmax, JNUM, JRED, JRED1, JRED2, jrs, jSym, jvc, JVEC, k, kOff(8,2), krs, kscreen, kSym, l, & - LFULL, LKsh, LKshp, LREAD, lSh, lSym, LWORK, MaxB, MaxRedT, MaxVecPerBatch, mDen, Mmax, mrs, mSh, mTvec, & + LFULL(2), LKsh, LKshp, LREAD, lSh, lSym, LWORK, MaxB, MaxRedT, MaxVecPerBatch, mDen, Mmax, mrs, mSh, mTvec, & MUSED, MxBasSh, n1, n2, nBatch, nBs, nMat, nnO, nRS, nT1, nT2, NumCV, numSh, NUMV, NumVT, nVec, nVrs, nOrb(8,2) real(kind=wp) :: Fact, fcorr, LKThr, SKsh, tau(2), TCC1, TCC2, tcoul(2), TCR1, TCR2, TCS1, TCS2, TCT1, TCT2, TCX1, TCX2, texch(2), & thrv(2), tmotr(2), Tmp, TOTCPU, TOTCPU1, TOTCPU2, TOTWALL, TOTWALL1, TOTWALL2, tread(2), tscrn(2), TWC1, TWC2, & @@ -315,7 +315,7 @@ mTvec = 0 ! mem for storing the half-transformed vec do l=1,nSym - k = Muld2h(l,JSYM) + k = Mul(l,JSYM) Mmax = 0 do jDen=1,nDen Mmax = max(Mmax,nForb(k,jDen)+nIorb(k,jDen)) @@ -376,13 +376,13 @@ call mma_maxDBLE(LWORK) - nVec = min(LWORK/(nRS+mTvec+LFULL),min(nVrs,MaxVecPerBatch)) + nVec = min((LWORK-LFULL(2))/(nRS+mTvec+LFULL(1)),min(nVrs,MaxVecPerBatch)) if (nVec < 1) then write(u6,*) SECNAM//': Insufficient memory for batch' write(u6,*) ' LWORK= ',LWORK write(u6,*) ' jsym= ',jsym - write(u6,*) ' min. mem. need= ',nRS+mTvec+LFULL + write(u6,*) ' min. mem. need= ',nRS+mTvec+LFULL(1) write(u6,*) ' nRS = ',nRS write(u6,*) ' mTvec = ',mTvec write(u6,*) ' LFULL = ',LFULL @@ -533,7 +533,7 @@ do kSym=1,nSym - lSym = MulD2h(JSYM,kSym) + lSym = Mul(JSYM,kSym) do jK=1,nOrb(kSym,jDen) jK_a = jK+kOff(kSym,jDen) diff -Nru openmolcas-22.02/src/fock_util/choras_drv.F90 openmolcas-22.10/src/fock_util/choras_drv.F90 --- openmolcas-22.02/src/fock_util/choras_drv.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/choras_drv.F90 2022-10-10 14:22:40.000000000 +0000 @@ -24,7 +24,7 @@ real(kind=wp), intent(inout) :: W_FLT(*) type(DSBA_Type), intent(inout) :: FSQ(1) integer(kind=iwp), parameter :: MaxDs = 1 -integer(kind=iwp) :: i, iUHF, ja, loff1, MinMem(8), nDen, NumV, rc +integer(kind=iwp) :: i, nD, ja, loff1, MinMem(8), nDen, NumV, rc real(kind=wp) :: FactC(MaxDs), FactX(MaxDs), Thr, Ymax logical(kind=iwp) :: DoCoulomb(MaxDs), DoExchange(MaxDs) type(DSBA_Type) :: DDec, DLT(1), DSQ(1), FLT(1), MSQ(MaxDs), Vec @@ -49,7 +49,7 @@ call Allocate_DT(DSQ(1),nBas,nBas,nSym,Ref=W_DSQ) -iUHF = 0 +nD = 1 if (DECO) then ! use decomposed density ! ============== Alternative A: Use decomposed density matrix ===== @@ -101,7 +101,7 @@ end if -call CHOSCF_MEM(nSym,nBas,iUHF,DoExchange,pNocc,ALGO,REORD,MinMem,loff1) +call CHOSCF_MEM(nSym,nBas,nD,DoExchange,pNocc,ALGO,REORD,MinMem,loff1) ! Here follows a long if nest with six combinations: ! ALGO is 1, REORD is .true. or .false., or @@ -153,7 +153,7 @@ call QUIT(rc) end if -call CHO_SUM(rc,nSym,nBas,iUHF,DoExchange,FLT,FSQ) +call CHO_SUM(rc,nSym,nBas,nD,DoExchange,FLT,FSQ) if (rc /= 0) call Error(rc) diff -Nru openmolcas-22.02/src/fock_util/cho_rassi_twxy.F90 openmolcas-22.10/src/fock_util/cho_rassi_twxy.F90 --- openmolcas-22.02/src/fock_util/cho_rassi_twxy.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/cho_rassi_twxy.F90 2022-10-10 14:22:40.000000000 +0000 @@ -11,7 +11,7 @@ subroutine CHO_rassi_twxy(irc,Scr,ChoV,TUVX,nAorb,JSYM,NUMV,DoReord) -use Symmetry_Info, only: MulD2h => Mul +use Symmetry_Info, only: Mul use Index_Functions, only: iTri use Data_Structures, only: SBA_Type, twxy_type use Constants, only: One @@ -40,7 +40,7 @@ do iSymy=1,nSym - iSymx = MulD2h(iSymy,JSYM) + iSymx = Mul(iSymy,JSYM) Nxy = nAorb(iSymx)*nAorb(iSymy) @@ -48,7 +48,7 @@ do iSymw=iSymy,nSym ! iSymw >= iSymy (particle symmetry) - iSymt = MulD2h(iSymw,JSYM) + iSymt = Mul(iSymw,JSYM) Ntw = nAorb(iSymt)*nAorb(iSymw) @@ -80,7 +80,7 @@ do iSymy=1,nSym - iSymx = MulD2h(iSymy,JSYM) + iSymx = Mul(iSymy,JSYM) Nxy = nAorb(iSymx)*nAorb(iSymy) @@ -88,7 +88,7 @@ do iSymw=iSymy,nSym - iSymt = MulD2h(iSymw,JSYM) + iSymt = Mul(iSymw,JSYM) Ntw = nAorb(iSymt)*nAorb(iSymw) diff -Nru openmolcas-22.02/src/fock_util/choscf_mem.F90 openmolcas-22.10/src/fock_util/choscf_mem.F90 --- openmolcas-22.02/src/fock_util/choscf_mem.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/choscf_mem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -11,7 +11,7 @@ ! Copyright (C) Francesco Aquilante * !*********************************************************************** -subroutine CHOSCF_MEM(nSym,nBas,iUHF,DoExchange,pNocc,ALGO,REORD,MinMem,lOff1) +subroutine CHOSCF_MEM(nSym,nBas,nD,DoExchange,pNocc,ALGO,REORD,MinMem,lOff1) !**************************************************************** ! Author : F. Aquilante ! @@ -32,12 +32,12 @@ !***************************************************************** use ChoArr, only: nDimRS -use Symmetry_Info, only: MulD2h => Mul +use Symmetry_Info, only: Mul use Data_Structures, only: Integer_Pointer use Definitions, only: iwp implicit none -integer(kind=iwp), intent(in) :: nSym, nBas(nSym), iUHF, ALGO +integer(kind=iwp), intent(in) :: nSym, nBas(nSym), nD, ALGO logical(kind=iwp), intent(in) :: DoExchange(*), REORD type(Integer_Pointer), intent(in) :: pNocc(*) integer(kind=iwp), intent(out) :: MinMem(nSym), lOff1 @@ -45,13 +45,8 @@ logical(kind=iwp) :: xToDo !************************************************* -if (iUHF == 0) then - nDen = 1 - xToDo = DoExChange(1) -else - nDen = 3 - xToDo = DoExChange(2) -end if +nDen = nD*(nD+1)/2 +xToDo = DoExChange(nD) !============================ lOff1 = 0 @@ -87,7 +82,7 @@ Nab = 0 NSab = 0 do ksym=1,nSym - iSymp = MulD2h(ksym,jSym) + iSymp = Mul(ksym,jSym) if ((iSymp > ksym) .and. ((Moccmx(iSymp) /= 0) .or. (Moccmx(ksym) /= 0))) then Nab = Nab+nBas(ksym)*nBas(iSymp) Mabmx(jSym) = max(Mabmx(jSym),max(nBas(ksym)*Moccmx(iSymp),nBas(iSymp)*Moccmx(ksym))) diff -Nru openmolcas-22.02/src/fock_util/cho_sum.F90 openmolcas-22.10/src/fock_util/cho_sum.F90 --- openmolcas-22.02/src/fock_util/cho_sum.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/cho_sum.F90 2022-10-10 14:22:40.000000000 +0000 @@ -11,7 +11,7 @@ ! Copyright (C) Francesco Aquilante * !*********************************************************************** -subroutine CHO_SUM(rc,nSym,nBas,iUHF,DoExchange,FLT,FSQ) +subroutine CHO_SUM(rc,nSym,nBas,nD,DoExchange,FLT,FSQ) !**************************************************************** ! Author : F. Aquilante ! @@ -30,17 +30,13 @@ implicit none integer(kind=iwp), intent(out) :: rc -integer(kind=iwp), intent(in) :: nSym, nBas(8), iUHF +integer(kind=iwp), intent(in) :: nSym, nBas(8), nD logical(kind=iwp), intent(in) :: DoExchange(*) type(DSBA_Type), intent(inout) :: FLT(*), FSQ(*) integer(kind=iwp) :: IB, IJB, ISYM, JB, NB, nDen !************************************************* -if (iUHF == 1) then - nDen = 3 -else - nDen = 1 -end if +nDen = nD*(nD+1)/2 ! Accumulate the contributions and Square the final matrix ! FLT is in lower triangular storage diff -Nru openmolcas-22.02/src/fock_util/swap_tosqrt.F90 openmolcas-22.10/src/fock_util/swap_tosqrt.F90 --- openmolcas-22.02/src/fock_util/swap_tosqrt.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/swap_tosqrt.F90 2022-10-10 14:22:40.000000000 +0000 @@ -15,7 +15,7 @@ subroutine swap_tosqrt(irc,iLoc,nRS,JSYM,XLT,Xab) use ChoArr, only: iRS2F -use Symmetry_Info, only: MulD2h => Mul +use Symmetry_Info, only: Mul use Data_Structures, only: NDSBA_Type use Definitions, only: wp, iwp @@ -43,7 +43,7 @@ ibg = iRS2F(2,kRab) iSyma = cho_isao(iag) ! symmetry block - iSymb = MulD2h(jSym,iSyma) ! sym(a) > sym(b) + iSymb = Mul(jSym,iSyma) ! sym(a) > sym(b) ias = iag-ibas(iSyma) ibs = ibg-ibas(iSymb) diff -Nru openmolcas-22.02/src/fock_util/tra_ctl2.F90 openmolcas-22.10/src/fock_util/tra_ctl2.F90 --- openmolcas-22.02/src/fock_util/tra_ctl2.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/fock_util/tra_ctl2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -30,7 +30,7 @@ ! * !*********************************************************************** -use Symmetry_Info, only: MulD2h => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp, u6 @@ -77,10 +77,10 @@ iOrb = nOrb(iSym) do jSym=1,nSym jAsh = nAsh(jSym) - ijSym = MulD2h(iSym,jSym) + ijSym = Mul(iSym,jSym) do kSym=1,nSym kAsh = nAsh(kSym) - lSym = MulD2h(ijSym,kSym) + lSym = Mul(ijSym,kSym) if (lSym <= kSym) then lAsh = nAsh(lSym) kl_Orb_pairs = kAsh*lAsh @@ -115,7 +115,7 @@ jFro = nFro(jSym) jIsh = nIsh(jSym) jAsh = nAsh(jSym) - ijSym = MulD2h(iSym,jSym) + ijSym = Mul(iSym,jSym) kSymMax = nSym if (.not. lSquare) kSymMax = iSym do kSym=1,kSymMax @@ -124,7 +124,7 @@ kFro = nFro(kSym) kIsh = nIsh(kSym) kAsh = nAsh(kSym) - lSym = MulD2h(ijSym,kSym) + lSym = Mul(ijSym,kSym) if (lSym <= kSym) then lBas = nBas(lSym) lOrb = nOrb(lSym) diff -Nru openmolcas-22.02/src/gateway_util/basis_info.F90 openmolcas-22.10/src/gateway_util/basis_info.F90 --- openmolcas-22.02/src/gateway_util/basis_info.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gateway_util/basis_info.F90 2022-10-10 14:22:40.000000000 +0000 @@ -931,8 +931,8 @@ ! Define dbsc_cptr2loff, dbsc_mma_allo_1D, dbsc_mma_allo_1D_lim, dbsc_mma_free_1D ! (using _NO_GARBLE_ because all members are initialized) #define _TYPE_ type(Distinct_Basis_set_centers) -# define _FUNC_NAME_ dbsc_cptr2loff # define _NO_GARBLE_ +# define _FUNC_NAME_ dbsc_cptr2loff # include "cptr2loff_template.fh" # undef _FUNC_NAME_ # define _SUBR_NAME_ dbsc_mma @@ -948,8 +948,8 @@ ! Define shell_cptr2loff, shell_mma_allo_1D, shell_mma_allo_1D_lim, shell_mma_free_1D ! (using _NO_GARBLE_ because all members are initialized) #define _TYPE_ type(Shell_Info) -# define _FUNC_NAME_ shell_cptr2loff # define _NO_GARBLE_ +# define _FUNC_NAME_ shell_cptr2loff # include "cptr2loff_template.fh" # undef _FUNC_NAME_ # define _SUBR_NAME_ shell_mma diff -Nru openmolcas-22.02/src/gateway_util/center_info.F90 openmolcas-22.10/src/gateway_util/center_info.F90 --- openmolcas-22.02/src/gateway_util/center_info.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gateway_util/center_info.F90 2022-10-10 14:22:40.000000000 +0000 @@ -268,8 +268,8 @@ ! Define dc_cptr2loff, dc_mma_allo_1D, dc_mma_allo_1D_lim, dc_mma_free_1D ! (using _NO_GARBLE_ because all members are initialized) #define _TYPE_ type(Distinct_centers) -# define _FUNC_NAME_ dc_cptr2loff # define _NO_GARBLE_ +# define _FUNC_NAME_ dc_cptr2loff # include "cptr2loff_template.fh" # undef _FUNC_NAME_ # define _SUBR_NAME_ dc_mma diff -Nru openmolcas-22.02/src/gateway_util/dmpinf.F90 openmolcas-22.10/src/gateway_util/dmpinf.F90 --- openmolcas-22.02/src/gateway_util/dmpinf.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gateway_util/dmpinf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -43,7 +43,7 @@ use DKH_Info, only: DKH_Info_Dmp use Gateway_Info, only: Gateway_Info_Dmp use RICD_Info, only: RICD_Info_Dmp -use nq_Info, only: cQEnd, cQStrt, iQEnd, iQStrt, rQEnd, rQStrt +use nq_Info, only: NQ_Info_Dmp use Gateway_Info, only: Gateway_Info_Dmp use Definitions, only: wp, iwp @@ -52,17 +52,17 @@ integer(kind=iwp) :: Length integer(kind=iwp), external :: ip_of_iWork, ip_of_Work -call DmpInf_Internal(cRFStrt,iRFStrt,lRFStrt,rRFStrt,cQStrt,iQStrt,rQStrt) +call DmpInf_Internal(cRFStrt,iRFStrt,lRFStrt,rRFStrt) ! This is to allow type punning without an explicit interface contains -subroutine DmpInf_Internal(cRFStrt,iRFStrt,lRFStrt,rRFStrt,cQStrt,iQStrt,rQStrt) +subroutine DmpInf_Internal(cRFStrt,iRFStrt,lRFStrt,rRFStrt) - integer(kind=iwp), target, intent(inout) :: cRFStrt, iRFStrt, lRFStrt, cQStrt, iQStrt - real(kind=wp), target, intent(inout) :: rRFStrt, rQStrt - integer(kind=iwp), pointer :: p_cQ(:), p_cRF(:), p_iQ(:), p_iRF(:), p_lRF(:) - real(kind=wp), pointer :: p_rQ(:), p_rRF(:) + integer(kind=iwp), target, intent(inout) :: cRFStrt, iRFStrt, lRFStrt + real(kind=wp), target, intent(inout) :: rRFStrt + integer(kind=iwp), pointer :: p_cRF(:), p_iRF(:), p_lRF(:) + real(kind=wp), pointer :: p_rRF(:) ! * !********************************************************************* @@ -100,21 +100,7 @@ ! * !********************************************************************* ! * - ! Numerical integration information and parameters - - Length = ip_of_Work(rQEnd)-ip_of_Work(rQStrt)+1 - call c_f_pointer(c_loc(rQStrt),p_rQ,[Length]) - call Put_dArray('Quad_r',p_rQ,Length) - - Length = ip_of_iWork(iQEnd)-ip_of_iWork(iQStrt)+1 - call c_f_pointer(c_loc(iQStrt),p_iQ,[Length]) - call Put_iArray('Quad_i',p_iQ,Length) - - Length = ip_of_iWork(cQEnd)-ip_of_iWork(cQStrt)+1 - call c_f_pointer(c_loc(cQStrt),p_cQ,[Length]) - call Put_iArray('Quad_c',p_cQ,Length) - - nullify(p_rQ,p_iQ,p_cQ) + call NQ_Info_Dmp() ! * !********************************************************************* ! * diff -Nru openmolcas-22.02/src/gateway_util/fetch_qmmm.F90 openmolcas-22.10/src/gateway_util/fetch_qmmm.F90 --- openmolcas-22.02/src/gateway_util/fetch_qmmm.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gateway_util/fetch_qmmm.F90 2022-10-10 14:22:40.000000000 +0000 @@ -206,7 +206,7 @@ end function mmslave_copyx_wrapper -end +end subroutine Fetch_QMMM #elif !defined (EMPTY_FILES) diff -Nru openmolcas-22.02/src/gateway_util/fix_fockop.F90 openmolcas-22.10/src/gateway_util/fix_fockop.F90 --- openmolcas-22.02/src/gateway_util/fix_fockop.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gateway_util/fix_fockop.F90 2022-10-10 14:22:40.000000000 +0000 @@ -434,7 +434,7 @@ ! the shells of iCnttp (mCnttp might be larger!) Try_Again = .true. - call ICopy(1+iTabMx,[0],0,List_Add,1) + List_Add(:) = 0 Do_Cycle = .true. do while (Do_Cycle) diff -Nru openmolcas-22.02/src/gateway_util/gateway_global.F90 openmolcas-22.10/src/gateway_util/gateway_global.F90 --- openmolcas-22.02/src/gateway_util/gateway_global.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gateway_util/gateway_global.F90 2022-10-10 14:22:40.000000000 +0000 @@ -18,13 +18,16 @@ integer(kind=iwp), parameter :: G_Mode = 1, S_Mode = 2, GS_Mode = 3 integer(kind=iwp) :: iPack = 0, IsChi = 0, iWRopt = 0, Run_Mode -logical(kind=iwp) :: DirInt = .false., & +logical(kind=iwp) :: asymptotic_Rys = .false., & + DirInt = .false., & Expert = .true., & Fake_ERIs = .false., & + FMM_shortrange = .false., & force_out_of_core = .false., & force_part_c = .false., & force_part_p = .false., & IfAllOrb = .false., & + NoTab = .false., & Onenly = .false., & Primitive_Pass = .true., & PrPrt = .false., & @@ -32,7 +35,7 @@ Test = .false. character(len=512) :: SW_FileOrb = 'INPORB' -public :: DirInt, Expert, Fake_ERIs, force_out_of_core, force_part_c, force_part_p, G_Mode, GS_Mode, IfAllOrb, iPack, IsChi, & - iWRopt, Onenly, Primitive_Pass, PrPrt, Run_Mode, S_Mode, Short, SW_FileOrb, Test +public :: asymptotic_Rys, DirInt, Expert, Fake_ERIs, FMM_shortrange, force_out_of_core, force_part_c, force_part_p, G_Mode, & + GS_Mode, IfAllOrb, iPack, IsChi, iWRopt, NoTab, Onenly, Primitive_Pass, PrPrt, Run_Mode, S_Mode, Short, SW_FileOrb, Test end module Gateway_global diff -Nru openmolcas-22.02/src/gateway_util/info2runfile.F90 openmolcas-22.10/src/gateway_util/info2runfile.F90 --- openmolcas-22.02/src/gateway_util/info2runfile.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gateway_util/info2runfile.F90 2022-10-10 14:22:40.000000000 +0000 @@ -49,7 +49,7 @@ ! * !*********************************************************************** ! * -call ICopy(8,[0],0,nDel,1) +nDel(:) = 0 call Put_iArray('nFro',nDel,nIrrep) ! put to 0 call qpg_iArray('nDel',Found,nData) if (.not. Found) then diff -Nru openmolcas-22.02/src/gateway_util/rdctl_seward.F90 openmolcas-22.10/src/gateway_util/rdctl_seward.F90 --- openmolcas-22.02/src/gateway_util/rdctl_seward.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gateway_util/rdctl_seward.F90 2022-10-10 14:22:40.000000000 +0000 @@ -27,10 +27,10 @@ use Gateway_Info, only: Align_Only, CoM, CutInt, Do_Align, Do_FckInt, Do_GuessOrb, DoFMM, E1, E2, EMFR, FNMC, GIAO, kVector, & lAMFI, lDOWNONLY, lMXTC, lRel, lRP, lSchw, lUPONLY, NEMO, PkAcc, RPQMin, Rtrnc, SadStep, Shake, ThrInt, & Thrs, UnNorm, Vlct -use DKH_Info, only: iCtrLD, BSS, CLightAU, DKroll, IRELAE, LDKRoll, nCtrlD, radiLD -use RICD_Info, only: Cholesky, DiagCheck, Do_acCD_Basis, Do_nacCD_Basis, Do_RI, iRI_Type, LDF, LocalDF, Skip_High_AC, Thrshld_CD +use DKH_Info, only: iCtrLD, BSS, cLightAU, DKroll, IRELAE, LDKRoll, nCtrlD, radiLD +use RICD_Info, only: Cholesky, DiagCheck, Do_acCD_Basis, Do_RI, iRI_Type, LDF, LocalDF, Skip_High_AC, Thrshld_CD use Gateway_global, only: DirInt, Expert, Fake_ERIs, Force_Out_of_Core, force_part_c, force_part_p, G_Mode, ifallorb, iPack, & - iWRopt, Onenly, Prprt, Run_Mode, S_Mode, Short, SW_FileOrb, Test + iWRopt, NoTab, Onenly, Prprt, Run_Mode, S_Mode, Short, SW_FileOrb, Test #ifdef _FDE_ use Embedding_Global, only: embOutDensPath, embOutEspPath, embOutGradPath, embOutHessPath, embPot, embPotInBasis, embPotPath, & embWriteDens, embWriteEsp, embWriteGrad, embWriteHess, outGridPath, outGridPathGiven @@ -52,7 +52,6 @@ logical(kind=iwp), intent(out) :: Do_OneEl #include "Molcas.fh" #include "angtp.fh" -#include "notab.fh" #include "rctfld.fh" #include "rmat.fh" #include "print.fh" @@ -98,6 +97,7 @@ logical(kind=iwp) :: geoInput, oldZmat, zConstraints #endif #ifdef _GROMACS_ +integer(kind=iwp) :: iCastMM, iLA, LuXYZ, nCastMM, nLA integer(kind=iwp), allocatable :: CastMM(:), DefLA(:,:) real(kind=wp), allocatable :: FactLA(:) #endif @@ -125,7 +125,7 @@ 'RMER','RMQC','RMDI','RMEQ','RMBP','GIAO','NOCH','CHOL','FCD ','THRC','1CCD','1C-C', & 'CHOI','RP-C','SADD','CELL','SPAN','SPRE','LOW ','MEDI','HIGH','DIAG','RIC ','RIJ ', & 'RIJK','RICD','XRIC','NOGU','RELA','RLOC','FOOC','CDTH','SHAC','KHAC','ACD ','FAT-', & - 'ACCD','SLIM','NACC','DOFM','NOAM','RPQM','CONS','NGEX','LOCA','LDF ','LDF1','LDF2', & + 'ACCD','SLIM',' ','DOFM','NOAM','RPQM','CONS','NGEX','LOCA','LDF ','LDF1','LDF2', & 'TARG','THRL','APTH','CHEC','VERI','OVER','CLDF','UNCO','WRUC','UNIQ','NOUN','RLDF', & 'NOAL','WEIG','ALIG','TINK','ORIG','HYPE','ZCON','SCAL','DOAN','GEOE','OLDZ','OPTH', & 'NOON','GEO ','MXTC','FRGM','TRAN','ROT ','ZONL','BASL','NUME','VART','VARR','SHAK', & @@ -133,12 +133,6 @@ integer(kind=iwp), external :: iCFrst, iChAtm, IsFreeUnit real(kind=wp), external :: NucExp, rMass, rMassx character(len=180), external :: Get_Ln -interface - subroutine datimx(TimeStamp) bind(C,name='datimx_') - use, intrinsic :: iso_c_binding, only: c_char - character(kind=c_char) :: TimeStamp(*) - end subroutine -end interface ! * !*********************************************************************** @@ -296,7 +290,7 @@ ! period lthCell = 0 Cell_l = .false. -call izero(ispread,3) +ispread(:) = 0 VCell(:,:) = Zero ! Set local DF variables (dummy) call LDF_SetInc() @@ -1582,9 +1576,9 @@ ! Speed of light (in au) KWord = Get_Ln(LuRd) - call Get_F1(1,CLightAU) - CLightAU = abs(CLightAU) - write(u6,*) 'The speed of light in this calculation =',CLightAU + call Get_F1(1,cLightAU) + cLightAU = abs(cLightAU) + write(u6,*) 'The speed of light in this calculation =',cLightAU case (KeyW(94)) ! * @@ -2211,16 +2205,6 @@ Do_acCD_Basis = .true. GWInput = .true. - case (KeyW(135)) - ! * - !**** NACC ***************************************************** - ! * - ! Generate a nacCD basis. - - Do_acCD_Basis = .false. - Do_nacCD_Basis = .true. - GWInput = .true. - case (KeyW(136)) ! * !**** DOFM ***************************************************** @@ -2827,7 +2811,7 @@ call mma_allocate(CastMM,nCastMM) case ('CAST') KWord = Get_Ln(LuRd) - call Get_I(1,nCastMM,1) + call Get_I1(1,nCastMM) if (nCastMM <= 0) then Message = 'nCastMM is zero or negative' call WarningMessage(2,Message) @@ -2900,7 +2884,7 @@ # ifdef _GROMACS_ GWInput = .true. KWord = Get_Ln(LuRd) - call Get_I(1,nLA,1) + call Get_I1(1,nLA) if (nLA <= 0) then Message = 'LA definition: nLA is zero or negative' call WarningMessage(2,Message) @@ -3911,7 +3895,7 @@ call UpCase(BSLbl) iDummy_basis = 0 - call ICopy(4,BasisTypes,1,BasisTypes_save,1) + BasisTypes_save(:) = BasisTypes if ((BSLbl(1:2) == 'X.') .and. (index(BSLbl,'INLINE') == 0) .and. (index(BSLbl,'RYDBERG') == 0)) then BSLbl = 'X.ANO-RCC.' do i=11,80 @@ -3962,7 +3946,7 @@ Do_GuessOrb = Do_GuessOrb .and. (dbsc(nCnttp)%AtmNr <= 96) # endif - if (iDummy_Basis == 1) call ICopy(4,BasisTypes_Save,1,BasisTypes,1) + if (iDummy_Basis == 1) BasisTypes(:) = BasisTypes_save if (itype == 0) then if ((BasisTypes(3) == 1) .or. (BasisTypes(3) == 2) .or. (BasisTypes(3) == 14)) iType = BasisTypes(3) else diff -Nru openmolcas-22.02/src/gateway_util/ricd_info.F90 openmolcas-22.10/src/gateway_util/ricd_info.F90 --- openmolcas-22.02/src/gateway_util/ricd_info.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gateway_util/ricd_info.F90 2022-10-10 14:22:40.000000000 +0000 @@ -16,21 +16,20 @@ implicit none private -integer(kind=iwp), parameter :: nLen = 11 ! number of elements +integer(kind=iwp), parameter :: nLen = 10 ! number of elements integer(kind=iwp) :: iRI_Type = -1 real(kind=wp) :: Thrshld_CD = 1.0e-4_wp logical(kind=iwp) :: Cho_OneCenter = .false., & Cholesky = .false., & DiagCheck = .false., & Do_acCD_Basis = .true., & - Do_nacCD_Basis = .false., & Do_RI = .false., & LDF = .false., & LocalDF = .false., & Skip_High_AC = .false. -public :: Cho_OneCenter, Cholesky, DiagCheck, Do_acCD_Basis, Do_nacCD_Basis, Do_RI, iRI_Type, LDF, LocalDF, RICD_Info_Dmp, & - RICD_Info_Get, Skip_High_AC, Thrshld_CD +public :: Cho_OneCenter, Cholesky, DiagCheck, Do_acCD_Basis, Do_RI, iRI_Type, LDF, LocalDF, RICD_Info_Dmp, RICD_Info_Get, & + Skip_High_AC, Thrshld_CD contains @@ -52,8 +51,7 @@ rDmp(07) = merge(One,Zero,Cho_OneCenter) rDmp(08) = merge(One,Zero,DiagCheck) rDmp(09) = merge(One,Zero,LocalDF) - rDmp(10) = merge(One,Zero,Do_nacCD_Basis) - rDmp(11) = Thrshld_CD + rDmp(10) = Thrshld_CD call Put_dArray('RICD_Info',rDmp,nLen) call mma_deallocate(rDmp) @@ -79,8 +77,7 @@ Cho_OneCenter = rDmp(7) > Zero DiagCheck = rDmp(8) > Zero LocalDF = rDmp(9) > Zero - Do_nacCD_Basis = rDmp(10) > Zero - Thrshld_CD = rDmp(11) + Thrshld_CD = rDmp(10) call mma_deallocate(rDmp) diff -Nru openmolcas-22.02/src/gateway_util/soctl_seward.F90 openmolcas-22.10/src/gateway_util/soctl_seward.F90 --- openmolcas-22.02/src/gateway_util/soctl_seward.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gateway_util/soctl_seward.F90 2022-10-10 14:22:40.000000000 +0000 @@ -106,8 +106,8 @@ mval(2) = 1 mval(3) = -1 mval(4) = 0 -call ICopy(MxAO,[-99],0,iCent,1) -call ICopy(MxAO,[-99],0,lnAng,1) +iCent(:) = -99 +lnAng(:) = -99 !write(u6,'(20i4)') (lval(i),i=1,k) !write(u6,*) ' lval',k !write(u6,'(20i4)') (mval(i),i=1,k) @@ -115,8 +115,8 @@ call mma_allocate(nCore_Sh,[0,iTabMx],label='nCore_Sh') call mma_allocate(List,[0,iTabMx],label='List') call mma_allocate(List_AE,[0,iTabMx],label='List_AE') -call ICopy(1+iTabMx,[0],0,List,1) -call ICopy(1+iTabMx,[0],0,List_AE,1) +List(:) = 0 +List_AE(:) = 0 isymunit = isfreeunit(58) call molcas_open(isymunit,'SYMINFO') @@ -139,7 +139,7 @@ iAO = 0 lSkip = .false. -call ICopy(8,[0],0,nFCore,1) +nFCore(:) = 0 call mma_Allocate(iCI,iBas,label='iCI') ! Stuff for LoProp call mma_Allocate(jCI,iBas,label='jCI') ! Stuff for LocalDKH/X2C/BSS @@ -177,8 +177,8 @@ call mma_allocate(Index1,5*iBas,label='Index1') call mma_allocate(Index2,5*iBas,label='Index2') - call ICopy(5*iBas,[0],0,Index1,1) - call ICopy(5*iBas,[0],0,Index2,1) + Index1(:) = 0 + Index2(:) = 0 iCounter = 0 jCounter = 0 call mma_Allocate(SM,iBas,iBas,label='SM') @@ -241,14 +241,14 @@ ! No core to freeze! - call ICopy(lMax+1,[0],0,nCore_Sh,1) + nCore_Sh(0:lMax) = 0 else ! Non-ECP case ! Pick up the number of occupied orbitals in each shell type. - call ICopy(1+iTabMx,List_AE,1,List,1) + List(:) = List_AE ! Pick up which orbitals should be frozen as default. @@ -569,9 +569,9 @@ call OrbType(dbsc(iCnttp)%AtmNr,List_AE,31) if (kECP) then call ECP_Shells(dbsc(iCnttp)%AtmNr,list) - call ICopy(lmax+1,[0],0,nCore_Sh,1) + nCore_Sh(0:lmax) = 0 else - call ICopy(1+iTabMx,List_AE,1,List,1) + List(:) = List_AE if (dbsc(iCnttp)%Charge /= Zero) then call Freeze_Default(dbsc(iCnttp)%AtmNr,nCore_Sh,lMax) else diff -Nru openmolcas-22.02/src/gateway_util/symmetry_info.F90 openmolcas-22.10/src/gateway_util/symmetry_info.F90 --- openmolcas-22.02/src/gateway_util/symmetry_info.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gateway_util/symmetry_info.F90 2022-10-10 14:22:40.000000000 +0000 @@ -30,9 +30,17 @@ 5,6,7,8,1,2,3,4, & 6,5,8,7,2,1,4,3, & 7,8,5,6,3,4,1,2, & - 8,7,6,5,4,3,2,1],[8,8]) + 8,7,6,5,4,3,2,1],[8,8]), & + Prmt(0:7,0:7) = reshape([1, 1, 1, 1, 1, 1, 1, 1, & + 1,-1, 1,-1, 1,-1, 1,-1, & + 1, 1,-1,-1, 1, 1,-1,-1, & + 1,-1,-1, 1, 1,-1,-1, 1, & + 1, 1, 1, 1,-1,-1,-1,-1, & + 1,-1, 1,-1,-1, 1,-1, 1, & + 1, 1,-1,-1,-1,-1, 1, 1, & + 1,-1,-1, 1,-1, 1, 1,-1],[8,8]) -public :: iChBas, iChCar, iChTbl, iOper, iSkip, lBsFnc, lIrrep, Mul, nIrrep, SymLab, Symmetry_Info_Dmp, Symmetry_Info_Free, & +public :: iChBas, iChCar, iChTbl, iOper, iSkip, lBsFnc, lIrrep, Mul, nIrrep, Prmt, SymLab, Symmetry_Info_Dmp, Symmetry_Info_Free, & Symmetry_Info_Get, Symmetry_Info_Set, Symmetry_Info_Setup, VarR, VarT !*********************************************************************** @@ -363,7 +371,7 @@ !*********************************************************************** !*********************************************************************** -subroutine ChTab(iOper,nIrrep,iChTbl) +subroutine ChTab(iOper,nIrrep,outChTbl) !********************************************************************* ! * ! Object: to generate the character table of a point group within * @@ -377,7 +385,7 @@ use Definitions, only: u6 integer(kind=iwp), intent(in) :: nIrrep, iOper(nIrrep) - integer(kind=iwp), intent(out) :: iChTbl(1:8,1:8) ! ugly dimensions change to 0:7! + integer(kind=iwp), intent(out) :: outChTbl(1:8,1:8) ! ugly dimensions change to 0:7! integer(kind=iwp) :: i, i1, ia, ib, iCh, iFnc, iIrrep, iRot, iSigma = 1, iSub, iTest(8), ix, iy, iz, j, jIrrep, jx, jy, jz logical(kind=iwp) :: Inv, Rot, SymX, SymY, SymZ character(len=80) :: Tmp @@ -432,7 +440,7 @@ write(u6,*) 'nIrrep=',nIrrep call Abend() end if - ichTbl(:,:) = 0 + outChTbl(:,:) = 0 ! Go through the functions x, y, and z, and the dyadic functions. @@ -486,7 +494,7 @@ end if if (lBsFnc(jIrrep-1)(1:1) == ' ') then lBsFnc(jIrrep-1) = Tmp - call ICopy(nIrrep,iTest,1,iChTbl(jIrrep,1),8) + outChTbl(jIrrep,1:nIrrep) = iTest(1:nIrrep) else lBsFnc(jIrrep-1) = trim(lBsFnc(jIrrep-1))//', '//trim(Tmp) end if @@ -501,7 +509,7 @@ ! If the character of an rotation in an irreps is -1 then ! the irreps is assigned the character B, otherwise A. - if (((iOper(i) == 3) .or. (iOper(i) == 5) .or. (iOper(i) == 6)) .and. (iChTbl(iIrrep,i) == -1)) lIrrep(iIrrep-1) = 'b' + if (((iOper(i) == 3) .or. (iOper(i) == 5) .or. (iOper(i) == 6)) .and. (outChTbl(iIrrep,i) == -1)) lIrrep(iIrrep-1) = 'b' end do end do @@ -542,12 +550,12 @@ write(Tmp,'(I1)') iRot if (ia > 1) then do j=1,nIrrep - if ((lIrrep(j-1)(1:1) == 'a') .and. (iChTbl(j,i) == 1)) lIrrep(j-1) = lIrrep(j-1)(1:1)//Tmp(1:1) + if ((lIrrep(j-1)(1:1) == 'a') .and. (outChTbl(j,i) == 1)) lIrrep(j-1) = lIrrep(j-1)(1:1)//Tmp(1:1) end do end if if (ib > 1) then do j=1,nIrrep - if ((lIrrep(j-1)(1:1) == 'b') .and. (iChTbl(j,i) == 1)) lIrrep(j-1) = lIrrep(j-1)(1:1)//Tmp(1:1) + if ((lIrrep(j-1)(1:1) == 'b') .and. (outChTbl(j,i) == 1)) lIrrep(j-1) = lIrrep(j-1)(1:1)//Tmp(1:1) end do end if end if @@ -568,7 +576,7 @@ iRot = i end do do i=1,nIrrep - if (iChTbl(i,iRot) == 1) then + if (outChTbl(i,iRot) == 1) then j = 1 else j = 2 @@ -600,9 +608,9 @@ ! see https://gcc.gnu.org/bugzilla/show_bug.cgi?id=101827 i1 = min(i1,len(lIrrep)) # endif - if (iChTbl(iIrrep,i) == 1) then + if (outChTbl(iIrrep,i) == 1) then lIrrep(iIrrep-1)(i1:i1) = 'g' - else if (iChTbl(iIrrep,i) == -1) then + else if (outChTbl(iIrrep,i) == -1) then lIrrep(iIrrep-1)(i1:i1) = 'u' end if end if diff -Nru openmolcas-22.02/src/grid_it/printtitles.F90 openmolcas-22.10/src/grid_it/printtitles.F90 --- openmolcas-22.02/src/grid_it/printtitles.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/grid_it/printtitles.F90 2022-10-10 14:22:40.000000000 +0000 @@ -15,7 +15,7 @@ ! Adapted from SAGIT to work with OpenMolcas (October 2020) * !*********************************************************************** -use Definitions, only: iwp, wp +use Definitions, only: wp, iwp implicit none integer(kind=iwp), intent(in) :: LuVal, nShowMOs, nMOs, GRef(*), iType(*), NZ(*), nCoor, nBlocks, nInc diff -Nru openmolcas-22.02/src/guessorb/fckbyint.F90 openmolcas-22.10/src/guessorb/fckbyint.F90 --- openmolcas-22.02/src/guessorb/fckbyint.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/guessorb/fckbyint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -285,7 +285,7 @@ tmp1 = Zero do kBas=1,nB ik = ijS+(iBas-1)*nB+kBas-1 - tmp1 = tmp1+abs(CMO(ik)*dble(kBas)) + tmp1 = tmp1+abs(CMO(ik)*real(kBas,kind=wp)) end do do jBas=iBas+1,nB-nD ej = Eps(ijL+jBas-1) @@ -293,7 +293,7 @@ tmp2 = Zero do kBas=1,nB jk = ijS+(jBas-1)*nB+kBas-1 - tmp2 = tmp2+abs(CMO(jk)*dble(kBas)) + tmp2 = tmp2+abs(CMO(jk)*real(kBas,kind=wp)) end do if (tmp2 > tmp1) then tmp = tmp2 diff -Nru openmolcas-22.02/src/guessorb/fmod1n.F90 openmolcas-22.10/src/guessorb/fmod1n.F90 --- openmolcas-22.02/src/guessorb/fmod1n.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/guessorb/fmod1n.F90 2022-10-10 14:22:40.000000000 +0000 @@ -194,10 +194,7 @@ if (nBas(iSym) > 0) then call Square(Fock(ipFock(iSym)),SFk,1,nBas(iSym),nBas(iSym)) call DGEMM_('N','N',nBas(iSym),nBas(iSym),nBas(iSym),One,SFk,nBas(iSym),CMO(ipCMO(iSym)),nBas(iSym),Zero,Hlf,nBas(iSym)) - call DGEMM_Tri('T','N',nBas(iSym),nBas(iSym),nBas(iSym), & - One,CMO(ipCMO(iSym)),nBas(iSym), & - Hlf,nBas(iSym), & - Zero,TFk,nBas(iSym)) + call DGEMM_Tri('T','N',nBas(iSym),nBas(iSym),nBas(iSym),One,CMO(ipCMO(iSym)),nBas(iSym),Hlf,nBas(iSym),Zero,TFk,nBas(iSym)) if (Debug) then call TriPrt('Transformed Fock matrix','(12f12.6)',TFk,nBas(iSym)) end if diff -Nru openmolcas-22.02/src/guessorb/fmod1s.F90 openmolcas-22.10/src/guessorb/fmod1s.F90 --- openmolcas-22.02/src/guessorb/fmod1s.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/guessorb/fmod1s.F90 2022-10-10 14:22:40.000000000 +0000 @@ -230,10 +230,7 @@ if (nBas(iSym) > 0) then call Square(Fock(ipTmp1),Aux1,1,nBas(iSym),nBas(iSym)) call DGEMM_('N','N',nBas(iSym),nBas(iSym),nbas(iSym),One,Aux1,nBas(iSym),CMOs(ipTmp2),nBas(iSym),Zero,Aux2,nBas(iSym)) - call DGEMM_Tri('T','N',nBas(iSym),nBas(iSym),nBas(iSym), & - One,CMOs(ipTmp2),nBas(iSym), & - Aux2,nBas(iSym), & - Zero,Fmo(ipTmp3),nBas(iSym)) + call DGEMM_Tri('T','N',nBas(iSym),nBas(iSym),nBas(iSym),One,CMOs(ipTmp2),nBas(iSym),Aux2,nBas(iSym),Zero,Fmo(ipTmp3),nBas(iSym)) if (Debug) then write(Line,'(a,i2)') 'MO Fock matrix, symmetry ',iSym call TriPrt(Line,'(10f12.6)',Fmo(ipTmp3),nBas(iSym)) diff -Nru openmolcas-22.02/src/guga/aibj.F90 openmolcas-22.10/src/guga/aibj.F90 --- openmolcas-22.02/src/guga/aibj.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/guga/aibj.F90 2022-10-10 14:22:40.000000000 +0000 @@ -15,8 +15,9 @@ subroutine AIBJ(L0,L1,L2,L3,ITAI) -use guga_global, only: BS3, BS4, COUP, COUP1, IA, IB, ICASE, ICH, ICOUP, ICOUP1, IJ, IOUT, IRC, IVF0, IWAY, IX, J1, J2, JM, JM1, & - JNDX, JRC, LN, Lu_10, MXVERT, NBUF, NMAT +use guga_global, only: IADD10, BS3, BS4, COUP, COUP1, IA, IB, ICASE, ICH, ICOUP, ICOUP1, IJ, IOUT, IRC, IVF0, IWAY, IX, J1, J2, & + JM, JM1, JNDX, JRC, LN, Lu_10, MXVERT, NBUF, NMAT +use guga_util_global, only: COP, ICOP1, nCOP use Constants, only: Zero use Definitions, only: wp, iwp, u6 @@ -25,7 +26,6 @@ implicit none integer(kind=iwp), intent(in) :: L0(*), L1(*), L2(*), L3(*) integer(kind=iwp), intent(_OUT_) :: ITAI(*) -#include "cop.fh" integer(kind=iwp) :: I, IABIJ, IC1, IC11, IC2, IC22, ICP1, ICP2, IDIF, IFAB, IFAI, II, IID, IJJ, IJM, IJS, IN_, IN2, IND1, IND2, & IND3, ISTOP, IT1, IT2, ITAIL, ITT1, ITT2, ITURN, ITYP, J, JJ, JJ1, JJD, JND1, JND2, JOJ, JTURN, KM, KM1, & LTYP, NI, NJ, NUMM(7) diff -Nru openmolcas-22.02/src/guga/ai.F90 openmolcas-22.10/src/guga/ai.F90 --- openmolcas-22.02/src/guga/ai.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/guga/ai.F90 2022-10-10 14:22:40.000000000 +0000 @@ -15,7 +15,8 @@ subroutine AI(JTYP,ITAI,L0,L1,L2,L3) -use guga_global, only: COUP, ICOUP, ICOUP1, ICH, IJ, IOUT, IRC, IWAY, IX, J1, J2, JNDX, JRC, LN, Lu_10, MXVERT, NBUF, NMAT +use guga_global, only: COUP, IADD10, ICOUP, ICOUP1, ICH, IJ, IOUT, IRC, IWAY, IX, J1, J2, JNDX, JRC, LN, Lu_10, MXVERT, NBUF, NMAT +use guga_util_global, only: COP, IAD10, ICOP1, nCOP use Constants, only: Zero use Definitions, only: wp, iwp, u6 @@ -24,7 +25,6 @@ implicit none integer(kind=iwp), intent(in) :: JTYP, L0(*), L1(*), L2(*), L3(*) integer(kind=iwp), intent(_OUT_) :: ITAI(*) -#include "cop.fh" integer(kind=iwp) :: I, ICP1, ICP2, II, IID, IJJ, IJM, IJS, IN_, IN2, IND, ISTOP, IT1, IT2, ITAIL, ITT1, ITT2, ITURN, ITYP, JJ, & JJD, JMAX, JND1, JND2, JOUT, KM, NI real(kind=wp) :: CHKSUM diff -Nru openmolcas-22.02/src/guga/aijk.F90 openmolcas-22.10/src/guga/aijk.F90 --- openmolcas-22.02/src/guga/aijk.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/guga/aijk.F90 2022-10-10 14:22:40.000000000 +0000 @@ -15,7 +15,8 @@ subroutine AIJK(ITAI,L0,L1,L2,L3) -use guga_global, only: ICH, IOUT, IRC, JRC, LN, Lu_10, MXVERT, NBUF, NMAT +use guga_global, only: IADD10, ICH, IOUT, IRC, JRC, LN, Lu_10, MXVERT, NBUF, NMAT +use guga_util_global, only: COP, ICOP1, nCOP use Definitions, only: iwp, u6 #include "intent.fh" @@ -23,7 +24,6 @@ implicit none integer(kind=iwp), intent(_OUT_) :: ITAI(*) integer(kind=iwp), intent(in) :: L0(*), L1(*), L2(*), L3(*) -#include "cop.fh" integer(kind=iwp) :: I, II, IID, IND, IT1, IT2, ITT1, ITT2, ITURN, J, JJ, JJD, K, L, NI, NJ, NK IOUT = 0 diff -Nru openmolcas-22.02/src/guga/ci_select.F90 openmolcas-22.10/src/guga/ci_select.F90 --- openmolcas-22.02/src/guga/ci_select.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/guga/ci_select.F90 2022-10-10 14:22:40.000000000 +0000 @@ -14,14 +14,14 @@ subroutine CI_SELECT(L0,L1,L2,L3,KBUF,NTPB,NBINS,LW1) use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc -use guga_global, only: IADD11, ICH, IFIRST, ILIM, IOUT, LN, Lu_10, MXVERT, NBUF, NMAT, NSM +use guga_global, only: IADD10, IADD11, ICH, IFIRST, ILIM, IOUT, LN, Lu_10, MXVERT, NBUF, NMAT, NSM +use guga_util_global, only: COP, IAD10, ICOP1, nCOP use stdalloc, only: mma_allocate, mma_deallocate use Symmetry_Info, only: Mul use Definitions, only: wp, iwp, u6, RtoI implicit none integer(kind=iwp), intent(in) :: L0(4*MXVERT), L1(4*MXVERT), L2(4*MXVERT), L3(4*MXVERT), KBUF, NTPB, NBINS, LW1 -#include "cop.fh" integer(kind=iwp) :: ID, IDIAG, IFIN, II, IID, IND1, IND2, IREC, IST, IT1, IT2, ITIM, ITT, JJ, JJD, JTYP, KBUF2, M1, M2, M2MIN, & M3, M4, NA, NB, NC, ND, NSA, NSABC, NSAV1, NSAV2, NSAVE, NSB, NSC, NSCD, NSD integer(kind=iwp), allocatable :: ICAD(:), IBUFL(:) diff -Nru openmolcas-22.02/src/guga/comp1.F90 openmolcas-22.10/src/guga/comp1.F90 --- openmolcas-22.02/src/guga/comp1.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/guga/comp1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -13,13 +13,13 @@ subroutine COMP1(LJ,ITYP,L,IT2,II,IID,JJ,JJD,JTYP,ITAI) -use guga_global, only: COUP, ICASE, ICOUP, ICOUP1, IOUT, IX, JNDX, LN, Lu_10, NBUF, NMAT +use guga_global, only: COUP, IADD10, ICASE, ICOUP, ICOUP1, IOUT, IX, JNDX, LN, Lu_10, NBUF, NMAT +use guga_util_global, only: COP, ICOP1, nCOP use Constants, only: One use Definitions, only: wp, iwp implicit none integer(kind=iwp), intent(in) :: LJ, ITYP, L, IT2, II, IID, JJ, JJD, JTYP, ITAI(*) -#include "cop.fh" integer(kind=iwp) :: IC1, IC2, ICT, IN_, IN2, IND, ITAIL, JND1, JND2, JOJ, KK1, KTYP real(kind=wp) :: FAC integer(kind=iwp), external :: ICUNP diff -Nru openmolcas-22.02/src/guga/comp.F90 openmolcas-22.10/src/guga/comp.F90 --- openmolcas-22.02/src/guga/comp.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/guga/comp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -15,13 +15,13 @@ subroutine COMP(I,LJ,ITYP,L,IT1,IT2) -use guga_global, only: COUP, ICASE, ICOUP, ICOUP1, IOUT, IRC, IV0, IWAY, IX, J2, JNDX, JRC, LN, Lu_10, NBUF, NMAT +use guga_global, only: COUP, IADD10, ICASE, ICOUP, ICOUP1, IOUT, IRC, IV0, IWAY, IX, J2, JNDX, JRC, LN, Lu_10, NBUF, NMAT +use guga_util_global, only: COP, ICOP1, nCOP use Constants, only: One use Definitions, only: wp, iwp, u6 implicit none integer(kind=iwp), intent(in) :: I, LJ, ITYP, L, IT1, IT2 -#include "cop.fh" integer(kind=iwp) :: IC1, IC2, II1, IN_, IND, ISTOP, ITAIL, IVL, IVL0, IVV, JJ, JJD, JND1, JND2, JOJ, KM real(kind=wp) :: FAC logical(kind=iwp) :: first diff -Nru openmolcas-22.02/src/guga/empty.F90 openmolcas-22.10/src/guga/empty.F90 --- openmolcas-22.02/src/guga/empty.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/guga/empty.F90 2022-10-10 14:22:40.000000000 +0000 @@ -13,7 +13,8 @@ subroutine EMPTY(BUF,IBUF,LASTAD,SO,KBUF,NTPB) -use guga_global, only: ICASE, ILIM, IOUT, IV0, JRC, LN, Lu_10, Lu_11, NBUF, NMAT +use guga_global, only: IADD10, ICASE, ILIM, IOUT, IV0, JRC, LN, Lu_10, Lu_11, NBUF, NMAT +use guga_util_global, only: COP, ICOP1, nCOP use Constants, only: Zero use Definitions, only: wp, iwp @@ -24,7 +25,6 @@ real(kind=wp), intent(out) :: BUF(KBUF) integer(kind=iwp), intent(out) :: IBUF(KBUF+2) real(kind=wp), intent(_OUT_) :: SO(*) -#include "cop.fh" integer(kind=iwp) :: I, IADR, ICLR, II, IIQQ, IJJ, IKK, IN_, IND, IOFF, IQ, ISUM, ITYP, IVL, IVL0, J, JJ, JJ1, JJ2, KK, LENGTH, NBX integer(kind=iwp), external :: ICUNP diff -Nru openmolcas-22.02/src/guga/guga.F90 openmolcas-22.10/src/guga/guga.F90 --- openmolcas-22.02/src/guga/guga.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/guga/guga.F90 2022-10-10 14:22:40.000000000 +0000 @@ -22,26 +22,22 @@ subroutine GUGA(IRETURN) -use guga_global, only: free_all, IPRINT, Lu_10, Lu_11, MXVERT, NBUF +use guga_global, only: free_all, IADD10, IPRINT, Lu_10, Lu_11, MXVERT, NBUF +use guga_util_global, only: IAD10 use stdalloc, only: mma_allocate, mma_deallocate use Constants, only: Two, Four use Definitions, only: wp, iwp, u6, RtoI implicit none integer(kind=iwp), intent(out) :: IRETURN -#include "cop.fh" -integer(kind=iwp) :: I, ISPAC, IST, KB, KBUF, KBUF2, LSTO, LW1, MCOP, NBINS, NCOR, NCORX, NTPB +integer(kind=iwp) :: ISPAC, IST, KB, KBUF, KBUF2, LSTO, LW1, MCOP, NBINS, NCOR, NCORX, NTPB real(kind=wp) :: A, B, C integer(kind=iwp), allocatable :: L0(:), L1(:), L2(:), L3(:) integer(kind=iwp), external :: isFreeUnit ! Prologue -! Allocate workspace through GETMEM: -! PAM Aug -06: Get rid of fixed upper limit of workspace -! PAM NCOR = 1000000 -! PAM call GETMEM('SOArr','Allo','Real',LSOArr,NCOR) -! Replace by: Find max possible allocatable +! Find max possible allocatable call mma_maxINT(NCOR) ! Grab almost all of it, but leave a little to be safe: NCOR = NCOR-100000 @@ -60,9 +56,7 @@ call DANAME_wa(Lu_11,'TEMP01') Lu_10 = isFreeUnit(10) call DANAME(Lu_10,'CIGUGA') -do I=1,9 - IAD10(I) = 0 -end do +IAD10(:) = 0 IADD10 = 0 call iDAFILE(Lu_10,1,IAD10,9,IADD10) diff -Nru openmolcas-22.02/src/guga/guga_global.F90 openmolcas-22.10/src/guga/guga_global.F90 --- openmolcas-22.02/src/guga/guga_global.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/guga/guga_global.F90 2022-10-10 14:22:40.000000000 +0000 @@ -18,18 +18,18 @@ integer(kind=iwp), parameter :: MXVERT = 1000 -integer(kind=iwp) :: IA(MXVERT), IADD11, IAF(MXVERT), IB(MXVERT), IBF(MXVERT), ICH(55), ICOUP(55), ICOUP1(55), IFIRST, IJ(55), & - IJF(55), ILIM, IOUT, IPO(0:MXVERT), IPRINT, IRC(4), ISPIN, IV0, IVF0, IWAY(55), IX(4*MXVERT), IY(4*MXVERT,3), & - J1(55), J2(55), JM(55), JM1(55), JRC(4), K0(4*MXVERT), K0F(0:MXVERT), K1(4*MXVERT), K1F(0:MXVERT), & - K2(4*MXVERT), K2F(0:MXVERT), K3(4*MXVERT), K3F(0:MXVERT), LN, LNP, Lu_10, Lu_11, N, NBUF, NIORB, NMAT, & - NSM(55), NSYM +integer(kind=iwp) :: IA(MXVERT), IADD10, IADD11, IAF(MXVERT), IB(MXVERT), IBF(MXVERT), ICH(55), ICOUP(55), ICOUP1(55), IFIRST, & + IJ(55), IJF(55), ILIM, IOUT, IPO(0:MXVERT), IPRINT, IRC(4), ISPIN, IV0, IVF0, IWAY(55), IX(4*MXVERT), & + IY(4*MXVERT,3), J1(55), J2(55), JM(55), JM1(55), JRC(4), K0(4*MXVERT), K0F(0:MXVERT), K1(4*MXVERT), & + K1F(0:MXVERT), K2(4*MXVERT), K2F(0:MXVERT), K3(4*MXVERT), K3F(0:MXVERT), LN, LNP, Lu_10, Lu_11, N, NBUF, & + NIORB, NMAT, NSM(55), NSYM real(kind=wp) :: COUP(55), COUP1(55), S integer(kind=iwp), allocatable :: ICASE(:), JNDX(:) real(kind=wp), allocatable :: BL1(:), BL2(:), BS1(:), BS2(:), BS3(:), BS4(:) -public :: BL1, BL2, BS1, BS2, BS3, BS4, COUP, COUP1, free_all, IA, IADD11, IAF, IB, IBF, ICASE, ICH, ICOUP, ICOUP1, IFIRST, IJ, & - IJF, ILIM, IOUT, IPO, IPRINT, IRC, ISPIN, IV0, IVF0, IWAY, IX, IY, J1, J2, JM, JM1, JNDX, JRC, K0, K0F, K1, K1F, K2, & - K2F, K3, K3F, LN, LNP, Lu_10, Lu_11, MXVERT, N, NBUF, NIORB, NMAT, NSM, NSYM, S +public :: BL1, BL2, BS1, BS2, BS3, BS4, COUP, COUP1, free_all, IA, IADD10, IADD11, IAF, IB, IBF, ICASE, ICH, ICOUP, ICOUP1, & + IFIRST, IJ, IJF, ILIM, IOUT, IPO, IPRINT, IRC, ISPIN, IV0, IVF0, IWAY, IX, IY, J1, J2, JM, JM1, JNDX, JRC, K0, K0F, K1, & + K1F, K2, K2F, K3, K3F, LN, LNP, Lu_10, Lu_11, MXVERT, N, NBUF, NIORB, NMAT, NSM, NSYM, S contains diff -Nru openmolcas-22.02/src/guga/input_guga.F90 openmolcas-22.10/src/guga/input_guga.F90 --- openmolcas-22.02/src/guga/input_guga.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/guga/input_guga.F90 2022-10-10 14:22:40.000000000 +0000 @@ -13,16 +13,14 @@ subroutine INPUT_GUGA(L0,L1,L2,L3,ISPAC) -use guga_global, only: ICASE, ICH, IFIRST, ILIM, IPRINT, ISPIN, JRC, LN, LNP, Lu_10, MXVERT, N, NIORB, NSM, NSYM, S -use Symmetry_Info, only: Mul +use guga_global, only: IADD10, ICASE, ICH, IFIRST, ILIM, IPRINT, ISPIN, JRC, LN, LNP, Lu_10, MXVERT, N, NIORB, NSM, NSYM, S +use guga_util_global, only: IAD10, nIOCR use stdalloc, only: mma_allocate, mma_deallocate use Constants, only: Half use Definitions, only: iwp, u5, u6 implicit none integer(kind=iwp), intent(out) :: L0(4*MXVERT), L1(4*MXVERT), L2(4*MXVERT), L3(4*MXVERT), ISPAC -#include "niocr.fh" -#include "cop.fh" #include "warnings.h" integer(kind=iwp), parameter :: mxTit = 10, nCmd = 18 integer(kind=iwp) :: I, ICIALL, iCmd, ICOR(55), IFCORE, IN_, IN1, IN2, IN3, INTNUM, IOM, IONE(8), iOpt, IR, IR1, IR2, iRef, & @@ -415,8 +413,8 @@ iOpt = 1 nJJS = size(JJS) nJRC = size(JRC) -call WR_GUGA(Lu_10,iOpt,IADD10,NFREF,S,N,LN,NSYM,IR1,IR2,IFIRST,INTNUM,LSYM,NREF,LN1,NRLN1,Mul,size(Mul),NSH,NISH,8,JRC,nJRC,JJS, & - nJJS,NVAL,IOCR,nIOCR) +call WR_GUGA(Lu_10,iOpt,IADD10,NFREF,S,N,LN,NSYM,IR1,IR2,IFIRST,INTNUM,LSYM,NREF,LN1,NRLN1,NSH,NISH,8,JRC,nJRC,JJS,nJJS,NVAL,IOCR, & + nIOCR) call iDAFILE(Lu_10,1,ICASE,IR1,IADD10) call iDAFILE(Lu_10,1,JSY,IR2,IADD10) IAD10(2) = IADD10 diff -Nru openmolcas-22.02/src/guga/oneel_guga.F90 openmolcas-22.10/src/guga/oneel_guga.F90 --- openmolcas-22.02/src/guga/oneel_guga.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/guga/oneel_guga.F90 2022-10-10 14:22:40.000000000 +0000 @@ -15,11 +15,11 @@ subroutine ONEEL_GUGA() -use guga_global, only: ICH, IJ, ILIM, IOUT, IWAY, J1, J2, LN, Lu_10, MXVERT, NBUF, NMAT, NSM +use guga_global, only: IADD10, ICH, IJ, ILIM, IOUT, IWAY, J1, J2, LN, Lu_10, MXVERT, NBUF, NMAT, NSM +use guga_util_global, only: COP, ICOP1, nCOP use Definitions, only: iwp, u6 implicit none -#include "cop.fh" integer(kind=iwp) :: I, ISTOP, IT1, IT2, ITT, ITYP, J, K, KJL, KJS, KM, NI, NK, NSI, NSK logical(kind=iwp) :: first diff -Nru openmolcas-22.02/src/gugaci/actploop.F90 openmolcas-22.10/src/gugaci/actploop.F90 --- openmolcas-22.02/src/gugaci/actploop.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/actploop.F90 2022-10-10 14:22:40.000000000 +0000 @@ -492,13 +492,13 @@ use gugaci_global, only: iml, imr, intind_ijka, linelp, log_prod, logic_br, lpblock, lsm_inn, mhlp, ngw2, ngw3, nlg1, nlg2, & norb_dz, norb_frz, norb_inn -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none integer(kind=iwp) :: ijk, imlr, intpos, lma, lmai, lmk, lra, lrai, lraj, lrak, lsmi, lsmij, lsmj, lsmk, mh -imlr = mul_tab(iml,imr) +imlr = Mul(iml,imr) do lra=norb_dz+1,norb_inn lma = lsm_inn(lra) if (lma /= imlr) cycle @@ -523,8 +523,8 @@ lsmi = lsm_inn(lrai) do lraj=lrai+1,norb_inn lsmj = lsm_inn(lraj) - lsmij = mul_tab(lsmi,lsmj) - lmk = mul_tab(lsmij,imlr) + lsmij = Mul(lsmi,lsmj) + lmk = Mul(lsmij,imlr) do lrak=lraj+1,norb_inn lsmk = lsm_inn(lrak) if (lmk /= lsmk) cycle @@ -625,13 +625,13 @@ use gugaci_global, only: iml, imr, intind_ijka, linelp, log_prod, logic_br, lpblock, lsm_inn, mhlp, ngw2, ngw3, nlg1, nlg2, & norb_dz, norb_frz, norb_inn -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none integer(kind=iwp) :: ijk, imlr, intpos, lma, lmai, lmk, lra, lrai, lraj, lrak, lrd, lsmi, lsmij, lsmj, lsmk, mh -imlr = mul_tab(iml,imr) +imlr = Mul(iml,imr) do lra=norb_dz+1,norb_inn lma = lsm_inn(lra) @@ -667,8 +667,8 @@ lsmi = lsm_inn(lrai) do lraj=lrai+1,norb_inn lsmj = lsm_inn(lraj) - lsmij = mul_tab(lsmi,lsmj) - lmk = mul_tab(lsmij,imlr) + lsmij = Mul(lsmi,lsmj) + lmk = Mul(lsmij,imlr) do lrak=lraj+1,norb_inn lsmk = lsm_inn(lrak) if (lmk /= lsmk) cycle @@ -731,14 +731,14 @@ subroutine lp_head_in_act_3(ide) !for ide=0:dd,tt,ide=1:ss,id use gugaci_global, only: iml, imr, logic_br, lpblock, lsm_inn, norb_dz, norb_inn -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none integer(kind=iwp), intent(in) :: ide integer(kind=iwp) :: imlr, lra, lrai, lraj, lsmi, lsmij, lsmj, mh -imlr = mul_tab(iml,imr) +imlr = Mul(iml,imr) do lra=norb_dz+1,norb_inn ! line=9 d&r&l- @@ -753,7 +753,7 @@ lsmi = lsm_inn(lrai) do lraj=lrai+1,norb_inn lsmj = lsm_inn(lraj) - lsmij = mul_tab(lsmi,lsmj) + lsmij = Mul(lsmi,lsmj) if (lsmij /= imlr) cycle ! line=5 a&r-b&l- call head_ar_at_given_orb(mh,lrai) @@ -782,13 +782,13 @@ subroutine lp_head_in_act_4() use gugaci_global, only: iml, imr, linelp, log_prod, logic_br, lpblock, lsm_inn, mhlp, nlg1, nlg2, norb_dz, norb_inn -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none integer(kind=iwp) :: imlr, lra, lrai, lraj, lsmi, lsmij, lsmj, mh -imlr = mul_tab(iml,imr) +imlr = Mul(iml,imr) do lra=norb_dz+1,norb_inn ! line=8 d&rr- @@ -812,7 +812,7 @@ lsmi = lsm_inn(lrai) do lraj=lrai+1,norb_inn lsmj = lsm_inn(lraj) - lsmij = mul_tab(lsmi,lsmj) + lsmij = Mul(lsmi,lsmj) if (lsmij /= imlr) cycle call head_ar_at_given_orb(mh,lrai) call link_c1_to_given_orb(mh,lrai+1,lraj-1) @@ -841,15 +841,15 @@ subroutine lp_head_in_dbl_1() !for dv,sd,td use gugaci_global, only: iml, imr, jml, jmr, logic_br, lpblock, lsm_inn, ngw2, ngw3, norb_dz, norb_frz, norb_inn -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none integer(kind=iwp) :: imlr, jk, jmlr, lend, lra, lrai, lraj, lsma, lsmact, lsmi, lsmij, lsmj, lsta, mh -imlr = mul_tab(iml,imr) -jmlr = mul_tab(jml,jmr) -lsmact = mul_tab(imlr,jmlr) +imlr = Mul(iml,imr) +jmlr = Mul(jml,jmr) +lsmact = Mul(imlr,jmlr) lsta = norb_dz+1 lend = norb_inn @@ -920,7 +920,7 @@ lsmi = lsm_inn(lrai) do lraj=lrai+1,norb_inn lsmj = lsm_inn(lraj) - lsmij = mul_tab(lsmi,lsmj) + lsmij = Mul(lsmi,lsmj) if (lsmij /= lsmact) cycle jk = ngw2(lrai-norb_frz)+ngw3(lraj-norb_frz) @@ -957,16 +957,16 @@ ! !use gugaci_global, only: iml, imr, jml, jmr, jpadlr, jpadlrel, linelp, logic_br, lsm_inn, mhlp, ngw2, ngw3, nlg1, nlg2, norb_dz, & ! norb_frz, norb_inn -!use Symmetry_Info, only: mul_tab => Mul +!use Symmetry_Info, only: Mul !use Definitions, only: iwp ! !implicit none !integer(kind=iwp) :: imlr, jk, jmlr, lend, lra, lrai, lraj, lsma, lsmact, lsmi, lsmij, lsmj, lsta, mh !logical(kind=iwp) :: do_15, do_16 ! -!imlr = mul_tab(iml,imr) -!jmlr = mul_tab(jml,jmr) -!lsmact = mul_tab(imlr,jmlr) +!imlr = Mul(iml,imr) +!jmlr = Mul(jml,jmr) +!lsmact = Mul(imlr,jmlr) !lsta = norb_dz+1 !lend = norb_inn ! @@ -995,7 +995,7 @@ ! lsmi = lsm_inn(lrai) ! do lraj=lrai+1,norb_inn ! lsmj = lsm_inn(lraj) -! lsmij = mul_tab(lsmi,lsmj) +! lsmij = Mul(lsmi,lsmj) ! if (lsmij /= lsmact) cycle ! jk = ngw2(lrai-norb_frz)+ngw3(lraj-norb_frz) ! @@ -1125,15 +1125,15 @@ use gugaci_global, only: iml, imr, jml, jmr, linelp, log_prod, logic_br, lpblock, lsm_inn, mhlp, ngw2, ngw3, nlg1, nlg2, norb_dz, & norb_frz, norb_inn -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none integer(kind=iwp) :: imlr, jk, jmlr, lend, lra, lrai, lraj, lsma, lsmact, lsmi, lsmij, lsmj, lsta, mh -imlr = mul_tab(iml,imr) -jmlr = mul_tab(jml,jmr) -lsmact = mul_tab(imlr,jmlr) +imlr = Mul(iml,imr) +jmlr = Mul(jml,jmr) +lsmact = Mul(imlr,jmlr) lsta = norb_dz+1 lend = norb_inn @@ -1225,7 +1225,7 @@ lsmi = lsm_inn(lrai) do lraj=lrai+1,norb_inn lsmj = lsm_inn(lraj) - lsmij = mul_tab(lsmi,lsmj) + lsmij = Mul(lsmi,lsmj) if (lsmij /= lsmact) cycle jk = ngw2(lrai-norb_frz)+ngw3(lraj-norb_frz) @@ -1259,16 +1259,16 @@ ! !use gugaci_global, only: iml, imr, jml, jmr, jpadlr, jpadlrel, linelp, logic_br, lsm_inn, mhlp, ngw2, ngw3, nlg1, nlg2, norb_dz, & ! norb_frz, norb_inn -!use Symmetry_Info, only: mul_tab => Mul +!use Symmetry_Info, only: Mul !use Definitions, only: iwp ! !implicit none !integer(kind=iwp) :: imlr, jk, jmlr, lend, lra, lrai, lraj, lsma, lsmact, lsmi, lsmij, lsmj, lsta, mh !logical(kind=iwp) :: do_16 ! -!imlr = mul_tab(iml,imr) -!jmlr = mul_tab(jml,jmr) -!lsmact = mul_tab(imlr,jmlr) +!imlr = Mul(iml,imr) +!jmlr = Mul(jml,jmr) +!lsmact = Mul(imlr,jmlr) !lsta = norb_dz+1 !lend = norb_inn ! @@ -1295,7 +1295,7 @@ ! lsmi = lsm_inn(lrai) ! do lraj=lrai+1,norb_inn ! lsmj = lsm_inn(lraj) -! lsmij = mul_tab(lsmi,lsmj) +! lsmij = Mul(lsmi,lsmj) ! if (lsmij /= lsmact) cycle ! jk = ngw2(lrai-norb_frz)+ngw3(lraj-norb_frz) ! @@ -1387,16 +1387,16 @@ subroutine lp_head_in_dbl_3(ide) !for ide=0:dd,tt,ide=1:ss,id use gugaci_global, only: iml, imr, jml, jmr, logic_br, lpblock, lsm_inn, norb_dz, norb_inn -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none integer(kind=iwp), intent(in) :: ide integer(kind=iwp) :: imlr, jmlr, lend, lra, lsma, lsmact, lsta, mh -imlr = mul_tab(iml,imr) -jmlr = mul_tab(jml,jmr) -lsmact = mul_tab(imlr,jmlr) +imlr = Mul(iml,imr) +jmlr = Mul(jml,jmr) +lsmact = Mul(imlr,jmlr) lsta = norb_dz+1 lend = norb_inn @@ -1453,15 +1453,15 @@ subroutine lp_head_in_dbl_4() use gugaci_global, only: iml, imr, jml, jmr, logic_br, lpblock, lsm_inn, norb_dz, norb_inn -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none integer(kind=iwp) :: imlr, jmlr, lend, lra, lsma, lsmact, lsta, mh -imlr = mul_tab(iml,imr) -jmlr = mul_tab(jml,jmr) -lsmact = mul_tab(imlr,jmlr) +imlr = Mul(iml,imr) +jmlr = Mul(jml,jmr) +lsmact = Mul(imlr,jmlr) lsta = norb_dz+1 lend = norb_inn @@ -1510,16 +1510,16 @@ !subroutine lp_head_in_dbl_4_mrpt2() ! !use gugaci_global, only: iml, imr, jml, jmr, jpadlr, jpadlrel, linelp, logic_br, lsm_inn, mhlp, nlg1, nlg2, norb_dz, norb_inn -!use Symmetry_Info, only: mul_tab => Mul +!use Symmetry_Info, only: Mul !use Definitions, only: iwp ! !implicit none !integer(kind=iwp) :: imlr, jmlr, lend, lra, lsma, lsmact, lsta, mh !logical(kind=iwp) :: do_15 ! -!imlr = mul_tab(iml,imr) -!jmlr = mul_tab(jml,jmr) -!lsmact = mul_tab(imlr,jmlr) +!imlr = Mul(iml,imr) +!jmlr = Mul(jml,jmr) +!lsmact = Mul(imlr,jmlr) !lsta = norb_dz+1 !lend = norb_inn ! @@ -1595,7 +1595,7 @@ !use gugaci_global, only: ihy, ihyl, iml, imr, jml, jmr, jpadlr, jphy, jphyl, linelp, lp_count, lpnew_coe, lpnew_head, lpnew_lwei, & ! lpnew_rwei, mhlp, mhsum, mtype, nlg1, nlg2, norb_dz, norb_inn, ns_sm, nstaval, nvalue, vplpnew_w0, & ! vplpnew_w1 -!use Symmetry_Info, only: mul_tab => Mul +!use Symmetry_Info, only: Mul !use Definitions, only: iwp ! !implicit none @@ -1613,8 +1613,8 @@ ! lp_count(line) = lp_count(line)-1 !end if !!======================================================================= -!jpml = mul_tab(jml,ns_sm) -!jpmr = mul_tab(jmr,ns_sm) +!jpml = Mul(jml,ns_sm) +!jpmr = Mul(jmr,ns_sm) !write(20,'(2x,10i8)') line,iml,imr,jpml,jpmr,jpadlr,mtype,mh,lg1,lg2 !write(20,'(7f12.6)') vplpnew_w0(1:mtype) !write(20,'(7f12.6)') vplpnew_w1(1:mtype) @@ -1646,7 +1646,7 @@ use gugaci_global, only: idisk_lp, ihy, ihyl, iml, imr, jml, jmr, jpadlr, jphy, jphyl, lp_count, lpnew_coe, lpnew_head, & lpnew_lwei, lpnew_rwei, LuLoop, mhlpmax, mhsum, mtype, norb_dz, norb_inn, ns_sm, nstaval, nvalue, & vplpnew_w0, vplpnew_w1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -1662,8 +1662,8 @@ end if info = 0 !======================================================================= -!jpml = mul_tab(jml,ns_sm) -!jpmr = mul_tab(jmr,ns_sm) +!jpml = Mul(jml,ns_sm) +!jpmr = Mul(jmr,ns_sm) !write(200,'(2x,10i8)') line,iml,imr,jpml,jpmr,jpadlr,mtype,mh,lg1,lg2 !write(200,*) vplpnew_w0(1:mtype) !write(200,*) vplpnew_w1(1:mtype) @@ -1672,8 +1672,8 @@ !write(200,*) lpnew_lwei(1:mh) !write(200,*) lpnew_rwei(1:mh) !======================================================================= -jpml = mul_tab(jml,ns_sm) -jpmr = mul_tab(jmr,ns_sm) +jpml = Mul(jml,ns_sm) +jpmr = Mul(jmr,ns_sm) info(1) = line info(2) = iml info(3) = imr @@ -1857,13 +1857,13 @@ subroutine ext_head_in_act() use gugaci_global, only: ipaety, jml, jmr, logic_dh, ns_sm -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul implicit none logic_dh = .false. -jml = mul_tab(jml,ns_sm) -jmr = mul_tab(jmr,ns_sm) +jml = Mul(jml,ns_sm) +jmr = Mul(jmr,ns_sm) select case (ipaety) case default ! (10) call sv_ext_head_in_act() @@ -1875,8 +1875,8 @@ call vd_ext_head_in_act() case (1:9,11:16,18:22,24:25) end select -jml = mul_tab(jml,ns_sm) -jmr = mul_tab(jmr,ns_sm) +jml = Mul(jml,ns_sm) +jmr = Mul(jmr,ns_sm) return @@ -1885,13 +1885,13 @@ subroutine ext_head_in_dbl() use gugaci_global, only: ipaety, jml, jmr, logic_dh, ns_sm -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul implicit none logic_dh = .true. -jml = mul_tab(jml,ns_sm) -jmr = mul_tab(jmr,ns_sm) +jml = Mul(jml,ns_sm) +jmr = Mul(jmr,ns_sm) select case (ipaety) case default ! (10) call sv_ext_head_in_dbl() @@ -1903,8 +1903,8 @@ call vd_ext_head_in_dbl() case (1:9,11:16,18:22,24:25) end select -jml = mul_tab(jml,ns_sm) -jmr = mul_tab(jmr,ns_sm) +jml = Mul(jml,ns_sm) +jmr = Mul(jmr,ns_sm) return diff -Nru openmolcas-22.02/src/gugaci/cidiagelm.F90 openmolcas-22.10/src/gugaci/cidiagelm.F90 --- openmolcas-22.02/src/gugaci/cidiagelm.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/cidiagelm.F90 2022-10-10 14:22:40.000000000 +0000 @@ -414,7 +414,7 @@ use gugaci_global, only: ibsm_ext, iesm_ext, ipae, jph, jwh, kk, lsm, ng_sm, nlsm_ext, norb_all, norb_ext, th, thh, v_onevsqtwo, & v_sqthreevsqtwo, v_sqtwo, vdint, voint -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Two use Definitions, only: wp, iwp @@ -442,7 +442,7 @@ !wl5 = (vlop0-vlop1)*vo(lr0,lr)-Two*vlop0*vmd(lr0,lr) !wl8 = vlop0*(vo(lr0,lr0)+(vlop0-1)*Half*vmd(lr0,lr0)) ! two-index,one-loop 520 - ! 0=:13,14(ss=3),38(tt=2),50(dd=1) + ! 0 = :13,14(ss=3),38(tt=2),50(dd=1) !link arc_d select case (ityae) case default ! (1) @@ -464,7 +464,7 @@ wg38 = -vlop0*v_onevsqtwo wwg38 = vlop1 do ima=1,ng_sm - imb = mul_tab(ima,imae) + imb = Mul(ima,imae) if (imb > ima) cycle do la=ibsm_ext(ima),iesm_ext(ima) lra = norb_all-la+1 @@ -486,7 +486,7 @@ !zz = ' g14,15 ' wg14 = -vlop0*v_onevsqtwo do ima=1,ng_sm - imb = mul_tab(ima,imae) + imb = Mul(ima,imae) if (imb > ima) cycle if (nlsm_ext(ima) == 0) cycle if (nlsm_ext(imb) == 0) cycle @@ -526,7 +526,7 @@ use gugaci_global, only: fg, jb_sys, jpad, jud, just, kk, lsm_inn, norb_dz, norb_frz, ns_sm, pd, pdd, ps1, ps2, ps3, ps4, pt, ptt, & v_onevsqtwo, v_sqtwo, vdint, voint -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero, Two use Definitions, only: wp, iwp @@ -561,7 +561,7 @@ !jpad = jd(im) fqi = -fg do lri=norb_frz+1,norb_dz - imd = mul_tab(lsm_inn(lri),ns_sm) + imd = Mul(lsm_inn(lri),ns_sm) if (imd /= imad) cycle iwd = jud(lri) @@ -587,10 +587,10 @@ fqi = fg iwt = 0 do lri=norb_frz+1,norb_dz - imi = mul_tab(lsm_inn(lri),ns_sm) + imi = Mul(lsm_inn(lri),ns_sm) do lrj=lri+1,norb_dz imj = lsm_inn(lrj) - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= imad) cycle iwt = just(lri,lrj) @@ -635,11 +635,11 @@ call prodel(4,wls,mpe,iws,iwa) end if - imi = mul_tab(lsm_inn(lri),ns_sm) + imi = Mul(lsm_inn(lri),ns_sm) lrjsta = lri+1 do lrj=lrjsta,norb_dz imj = lsm_inn(lrj) - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= imad) cycle iws = just(lri,lrj) ! s1: d&r&l(1) @@ -671,10 +671,10 @@ if (jb_sys == 0) return !any difference when jb_sys=1 and jb_sy fqi = fg do lri=norb_frz+1,norb_dz - imi = mul_tab(lsm_inn(lri),ns_sm) + imi = Mul(lsm_inn(lri),ns_sm) do lrj=lri+1,norb_dz imj = lsm_inn(lrj) - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= imad) cycle !iws = iws+1 iws = just(lrj,lri) @@ -710,7 +710,7 @@ iwd = 0 do lri=norb_frz+1,norb_dz - imd = mul_tab(lsm_inn(lri),ns_sm) + imd = Mul(lsm_inn(lri),ns_sm) if (imd /= imad) cycle iwd = jud(lri) @@ -743,10 +743,10 @@ fqi = fg iwt = 0 do lri=norb_frz+1,norb_dz - imi = mul_tab(lsm_inn(lri),ns_sm) + imi = Mul(lsm_inn(lri),ns_sm) do lrj=lri+1,norb_dz imj = lsm_inn(lrj) - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= imad) cycle iwt = just(lri,lrj) @@ -783,7 +783,7 @@ use gugaci_global, only: fg, jb_sys, jpad, jud, just, jwh, lsm_inn, norb_dz, norb_frz, ns_sm, pd, pdd, ps1, ps2, ps3, ps4, pt, & ptt, th, thh, v_onevsqtwo, v_sqtwo -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -824,7 +824,7 @@ fqi = -fg lrj = 0 do lri=norb_frz+1,norb_dz - imd = mul_tab(lsm_inn(lri),ns_sm) + imd = Mul(lsm_inn(lri),ns_sm) if (imd /= imad) cycle iwd = jud(lri) @@ -845,10 +845,10 @@ fqi = fg iwt = 0 do lri=norb_frz+1,norb_dz - imi = mul_tab(lsm_inn(lri),ns_sm) + imi = Mul(lsm_inn(lri),ns_sm) do lrj=lri+1,norb_dz imj = lsm_inn(lrj) - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= imad) cycle iwt = just(lri,lrj) @@ -881,11 +881,11 @@ vl0 = fqi*v_sqtwo*vlop0 call diagonal_call_dae(lri,lrj,iws,iwa,vij0,vij1,vij2,vl0) end if - imi = mul_tab(lsm_inn(lri),ns_sm) + imi = Mul(lsm_inn(lri),ns_sm) lrjsta = lri+1 do lrj=lrjsta,norb_dz imj = lsm_inn(lrj) - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= imad) cycle iws = just(lri,lrj) ! s2: d&r&l(2) @@ -903,11 +903,11 @@ if (jb_sys == 0) cycle fqi = fg do lri=norb_frz+1,norb_dz - imi = mul_tab(lsm_inn(lri),ns_sm) + imi = Mul(lsm_inn(lri),ns_sm) if (imad == ns_sm) lrjsta = lri do lrj=lri+1,norb_dz imj = lsm_inn(lrj) - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= imad) cycle iws = just(lrj,lri) ! s1: d&r&l(1) @@ -927,7 +927,7 @@ fqi = -fg lrj = 0 do lri=norb_frz+1,norb_dz - imd = mul_tab(lsm_inn(lri),ns_sm) + imd = Mul(lsm_inn(lri),ns_sm) if (imd /= imad) cycle iwd = jud(lri) @@ -947,10 +947,10 @@ fqi = fg !aa iwt = 0 do lri=norb_frz+1,norb_dz - imi = mul_tab(lsm_inn(lri),ns_sm) + imi = Mul(lsm_inn(lri),ns_sm) do lrj=lri+1,norb_dz imj = lsm_inn(lrj) - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= imad) cycle iwt = just(lri,lrj) @@ -978,7 +978,7 @@ use gugaci_global, only: ibsm_ext, iesm_ext, ipae, jpad, ng_sm, norb_all, norb_dz, norb_ext, v_onevsqtwo, v_sqthreevsqtwo, & v_sqtwo, vdint, voint -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero, Two use Definitions, only: wp, iwp @@ -997,7 +997,7 @@ imae = 8 end if iwe = 0 -! 520=:13,14(ss=3),38(tt=2),50(dd=1) +! 520 = :13,14(ss=3),38(tt=2),50(dd=1) ! link arc_d select case (ityae) case default ! (1) @@ -1032,7 +1032,7 @@ case (2) !zz = ' g38,39 ' do ima=1,ng_sm - imb = mul_tab(ima,imae) + imb = Mul(ima,imae) if (imb > ima) cycle do la=ibsm_ext(ima),iesm_ext(ima) lra = norb_all-la+1 @@ -1076,7 +1076,7 @@ case (3) !zz = ' g14,15 ' do ima=1,ng_sm - imb = mul_tab(ima,imae) + imb = Mul(ima,imae) if (imb > ima) cycle do la=ibsm_ext(ima),iesm_ext(ima) lra = norb_all-la+1 @@ -1138,7 +1138,7 @@ subroutine diagonal_dbl() use gugaci_global, only: ipae, iw_downwei, jb_sys, jpad, jud, just, lsm_inn, norb_dz, norb_frz, ns_sm, nu_ae, vdint, voint -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero, Two, Three, OneHalf use Definitions, only: wp, iwp @@ -1165,7 +1165,7 @@ end do !jps = js(1) do lr0=norb_frz+1,norb_dz - mr0 = mul_tab(lsm_inn(lr0),ns_sm) + mr0 = Mul(lsm_inn(lr0),ns_sm) iwd = jud(lr0) ! d_800 jpad = 1+mr0 @@ -1210,7 +1210,7 @@ wld0 = wld do lr=lr0+1,norb_dz - mr = mul_tab(mr0,lsm_inn(lr)) + mr = Mul(mr0,lsm_inn(lr)) jpat = 9+mr jpas = 17+mr jpat1 = jpat+24 @@ -1269,7 +1269,7 @@ end do end do do lrm=norb_frz+1,norb_dz - mrm = mul_tab(lsm_inn(lrm),ns_sm) + mrm = Mul(lsm_inn(lrm),ns_sm) iws = just(lrm,lrm) iwd = jud(lrm) jpad = 1+mrm @@ -1315,9 +1315,9 @@ end do ! 520 do lr0=norb_frz+1,norb_dz-1 - mr0 = mul_tab(lsm_inn(lr0),ns_sm) + mr0 = Mul(lsm_inn(lr0),ns_sm) do lr=lr0+1,norb_dz - mr = mul_tab(mr0,lsm_inn(lr)) + mr = Mul(mr0,lsm_inn(lr)) jpat = 9+mr jpas = 17+mr jpat1 = jpat+24 @@ -1421,7 +1421,7 @@ subroutine diagonal_ext() use gugaci_global, only: ibsm_ext, iesm_ext, ipae, lsm, norb_all, norb_ext, vdint, voint -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Two use Definitions, only: wp, iwp @@ -1471,7 +1471,7 @@ do lb=1,la-1 lrb = norb_all-lb+1 imb = lsm(lb) - mr = mul_tab(ima,imb) + mr = Mul(ima,imb) if (mr /= im) cycle !jps = js(mr) !jpt = jt(mr) @@ -1785,7 +1785,7 @@ subroutine get_jp(ity,nms,jp,id) use gugaci_global, only: ns_sm -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -1794,7 +1794,7 @@ integer(kind=iwp) :: ms ms = nms -if (id == 1) ms = mul_tab(nms,ns_sm) +if (id == 1) ms = Mul(nms,ns_sm) select case (ity) case default ! (1) jp = 1 diff -Nru openmolcas-22.02/src/gugaci/cidiagelm_g.F90 openmolcas-22.10/src/gugaci/cidiagelm_g.F90 --- openmolcas-22.02/src/gugaci/cidiagelm_g.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/cidiagelm_g.F90 2022-10-10 14:22:40.000000000 +0000 @@ -413,7 +413,7 @@ use gugaci_global, only: ibsm_ext, iesm_ext, ipae, jph, jwh, kk, lsm, ng_sm, nlsm_ext, norb_all, norb_ext, th, thh, v_onevsqtwo, & v_sqthreevsqtwo, v_sqtwo -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Two use Definitions, only: wp, iwp @@ -441,7 +441,7 @@ !wl5 = (vlop0-vlop1)*vo(lr0,lr)-Two*vlop0*vmd(lr0,lr) !wl8 = vlop0*(vo(lr0,lr0)+(vlop0-1)*Half*vmd(lr0,lr0)) ! two-index,one-loop 520 - ! 520=:13,14(ss=3),38(tt=2),50(dd=1) + ! 520 = :13,14(ss=3),38(tt=2),50(dd=1) !write(nf2,*) 'ityae',ityae !link arc_d @@ -471,7 +471,7 @@ wg38 = -vlop0*v_onevsqtwo wwg38 = vlop1 do ima=1,ng_sm - imb = mul_tab(ima,imae) + imb = Mul(ima,imae) if (imb > ima) cycle do la=ibsm_ext(ima),iesm_ext(ima) lra = norb_all-la+1 @@ -502,7 +502,7 @@ !zz = ' g14,15 ' wg14 = -vlop0*v_onevsqtwo do ima=1,ng_sm - imb = mul_tab(ima,imae) + imb = Mul(ima,imae) if (imb > ima) cycle if (nlsm_ext(ima) == 0) cycle if (nlsm_ext(imb) == 0) cycle @@ -558,7 +558,7 @@ use gugaci_global, only: fg, jb_sys, jpad, jud, just, kk, lsm_inn, norb_dz, norb_frz, ns_sm, pd, pdd, ps1, ps2, ps3, ps4, pt, ptt, & v_onevsqtwo, v_sqtwo -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero, Two use Definitions, only: wp, iwp @@ -600,7 +600,7 @@ !jpad = jd(im) fqi = -fg do lri=norb_frz+1,norb_dz - imd = mul_tab(lsm_inn(lri),ns_sm) + imd = Mul(lsm_inn(lri),ns_sm) if (imd /= imad) cycle iwd = jud(lri) @@ -645,10 +645,10 @@ fqi = fg iwt = 0 do lri=norb_frz+1,norb_dz - imi = mul_tab(lsm_inn(lri),ns_sm) + imi = Mul(lsm_inn(lri),ns_sm) do lrj=lri+1,norb_dz imj = lsm_inn(lrj) - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= imad) cycle iwt = just(lri,lrj) @@ -731,11 +731,11 @@ !call prodel(4,wls,mpe,iws,iwa) end if - imi = mul_tab(lsm_inn(lri),ns_sm) + imi = Mul(lsm_inn(lri),ns_sm) lrjsta = lri+1 do lrj=lrjsta,norb_dz imj = lsm_inn(lrj) - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= imad) cycle iws = just(lri,lrj) ! s1: d&r&l(1) @@ -798,10 +798,10 @@ if (jb_sys == 0) return !any diffrence when jb_sys=1 and jb_sy fqi = fg do lri=norb_frz+1,norb_dz - imi = mul_tab(lsm_inn(lri),ns_sm) + imi = Mul(lsm_inn(lri),ns_sm) do lrj=lri+1,norb_dz imj = lsm_inn(lrj) - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= imad) cycle !iws = iws+1 iws = just(lrj,lri) @@ -866,7 +866,7 @@ fqi = -fg iwd = 0 do lri=norb_frz+1,norb_dz - imd = mul_tab(lsm_inn(lri),ns_sm) + imd = Mul(lsm_inn(lri),ns_sm) if (imd /= imad) cycle iwd = jud(lri) @@ -910,10 +910,10 @@ fqi = fg iwt = 0 do lri=norb_frz+1,norb_dz - imi = mul_tab(lsm_inn(lri),ns_sm) + imi = Mul(lsm_inn(lri),ns_sm) do lrj=lri+1,norb_dz imj = lsm_inn(lrj) - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= imad) cycle iwt = just(lri,lrj) @@ -982,7 +982,7 @@ use gugaci_global, only: fg, jb_sys, jpad, jud, just, jwh, lsm_inn, norb_dz, norb_frz, ns_sm, pd, pdd, ps1, ps2, ps3, ps4, pt, & ptt, th, thh, v_onevsqtwo, v_sqtwo -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1023,7 +1023,7 @@ fqi = -fg lrj = 0 do lri=norb_frz+1,norb_dz - imd = mul_tab(lsm_inn(lri),ns_sm) + imd = Mul(lsm_inn(lri),ns_sm) if (imd /= imad) cycle iwd = jud(lri) @@ -1044,10 +1044,10 @@ fqi = fg iwt = 0 do lri=norb_frz+1,norb_dz - imi = mul_tab(lsm_inn(lri),ns_sm) + imi = Mul(lsm_inn(lri),ns_sm) do lrj=lri+1,norb_dz imj = lsm_inn(lrj) - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= imad) cycle iwt = just(lri,lrj) @@ -1081,11 +1081,11 @@ call diagonal_call_dae_g(lri,lrj,iws,iwa,vij0,vij1,vij2,vl0) end if - imi = mul_tab(lsm_inn(lri),ns_sm) + imi = Mul(lsm_inn(lri),ns_sm) lrjsta = lri+1 do lrj=lrjsta,norb_dz imj = lsm_inn(lrj) - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= imad) cycle iws = just(lri,lrj) ! s2: d&r&l(2) @@ -1103,11 +1103,11 @@ if (jb_sys == 0) cycle fqi = fg do lri=norb_frz+1,norb_dz - imi = mul_tab(lsm_inn(lri),ns_sm) + imi = Mul(lsm_inn(lri),ns_sm) if (imad == ns_sm) lrjsta = lri do lrj=lri+1,norb_dz imj = lsm_inn(lrj) - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= imad) cycle iws = just(lrj,lri) ! s1: d&r&l(1) @@ -1129,7 +1129,7 @@ fqi = -fg lrj = 0 do lri=norb_frz+1,norb_dz - imd = mul_tab(lsm_inn(lri),ns_sm) + imd = Mul(lsm_inn(lri),ns_sm) if (imd /= imad) cycle iwd = jud(lri) @@ -1149,10 +1149,10 @@ fqi = fg !aa iwt = 0 do lri=norb_frz+1,norb_dz - imi = mul_tab(lsm_inn(lri),ns_sm) + imi = Mul(lsm_inn(lri),ns_sm) do lrj=lri+1,norb_dz imj = lsm_inn(lrj) - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= imad) cycle iwt = just(lri,lrj) @@ -1179,7 +1179,7 @@ subroutine diagonal_call_dae_g(lri,lrj,iwd,iwa,vij0,vij1,vij2,vl0) use gugaci_global, only: ibsm_ext, iesm_ext, ipae, jpad, ng_sm, norb_all, norb_dz, norb_ext, v_onevsqtwo, v_sqthreevsqtwo, v_sqtwo -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Two use Definitions, only: wp, iwp @@ -1198,7 +1198,7 @@ imae = 8 end if iwe = 0 -! 520=:13,14(ss=3),38(tt=2),50(dd=1) +! 520 = :13,14(ss=3),38(tt=2),50(dd=1) !link arc_d select case (ityae) case default ! (1) @@ -1271,7 +1271,7 @@ case (2) !zz = ' g38,39 ' do ima=1,ng_sm - imb = mul_tab(ima,imae) + imb = Mul(ima,imae) if (imb > ima) cycle do la=ibsm_ext(ima),iesm_ext(ima) lra = norb_all-la+1 @@ -1376,7 +1376,7 @@ !do ima=1,8 ! the 8 should be changed to ng_sm do ima=1,ng_sm - imb = mul_tab(ima,imae) + imb = Mul(ima,imae) if (imb > ima) cycle do la=ibsm_ext(ima),iesm_ext(ima) lra = norb_all-la+1 @@ -1496,7 +1496,7 @@ subroutine diagonal_dbl_g() use gugaci_global, only: ipae, iw_downwei, jb_sys, jpad, jud, just, lsm_inn, norb_dz, norb_frz, ns_sm, nu_ae -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero, One, Two, Four, Half use Definitions, only: wp, iwp @@ -1533,7 +1533,7 @@ mr0 = 1 do lr0=norb_frz+1,norb_dz do lrd=1,norb_dz - mr0 = mul_tab(lsm_inn(lr0),ns_sm) + mr0 = Mul(lsm_inn(lr0),ns_sm) iwd = jud(lr0) jpad = 1+mr0 jpad1 = jpad+24 @@ -1620,7 +1620,7 @@ !wld0 = wld ! ........800... do lr=lr0+1,norb_dz - mr = mul_tab(mr0,lsm_inn(lr)) + mr = Mul(mr0,lsm_inn(lr)) jpat = 9+mr jpas = 17+mr jpat1 = jpat+24 @@ -1761,7 +1761,7 @@ end do end do do lrm=norb_frz+1,norb_dz - mrm = mul_tab(lsm_inn(lrm),ns_sm) + mrm = Mul(lsm_inn(lrm),ns_sm) iws = just(lrm,lrm) iwd = jud(lrm) jpad = 1+mrm @@ -1890,9 +1890,9 @@ ! ........520. do lr0=norb_frz+1,norb_dz-1 - mr0 = mul_tab(lsm_inn(lr0),ns_sm) + mr0 = Mul(lsm_inn(lr0),ns_sm) do lr=lr0+1,norb_dz - mr = mul_tab(mr0,lsm_inn(lr)) + mr = Mul(mr0,lsm_inn(lr)) jpat = 9+mr jpas = 17+mr @@ -2347,7 +2347,7 @@ subroutine diagonal_ext_g() use gugaci_global, only: ibsm_ext, iesm_ext, ipae, lsm, ng_sm, norb_all, norb_ext -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: One, Two use Definitions, only: wp, iwp @@ -2404,7 +2404,7 @@ do lb=1,la-1 lrb = norb_all-lb+1 imb = lsm(lb) - mr = mul_tab(ima,imb) + mr = Mul(ima,imb) if (mr /= im) cycle !jps = js(mr) !jpt = jt(mr) diff -Nru openmolcas-22.02/src/gugaci/dblcloop.F90 openmolcas-22.10/src/gugaci/dblcloop.F90 --- openmolcas-22.02/src/gugaci/dblcloop.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/dblcloop.F90 2022-10-10 14:22:40.000000000 +0000 @@ -28,7 +28,7 @@ subroutine dbl_space_loop_ijkk_sgezero() use gugaci_global, only: jb_sys, jud, just, lsm_inn, norb_dz, norb_frz, ns_sm, vint_ci, voint -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero, One, Half use Definitions, only: wp, iwp @@ -62,8 +62,8 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) - jpds = 17+mul_tab(lmij,ns_sm) + lmij = Mul(lmi,lmj) + jpds = 17+Mul(lmij,ns_sm) iwdl = just(lrj,lri) iwdr = just(lri,lrj) wl = -vlp_1*voint(lrj,lri) @@ -77,7 +77,7 @@ imi = lsm_inn(lri) !n2 = ngw2(lri-2) do lrj=lri+1,norb_dz - mij = mul_tab(imi,lsm_inn(lrj)) + mij = Mul(imi,lsm_inn(lrj)) if (mij /= 1) cycle ni = mod(lrj-lri,2) !=========== down comm for 2 4 ===================================== @@ -147,8 +147,8 @@ !=========== start comm for 2 4 ==================================== do lrm=norb_frz+1,norb_dz !ic=1,norb_act !frz imm = lsm_inn(lrm) - im = mul_tab(imm,imi) - im = mul_tab(im,ns_sm) + im = Mul(imm,imi) + im = Mul(im,ns_sm) kij = 0 if (lrm == lrj) kij = 2 if (lrm == lri) kij = 4 @@ -409,7 +409,7 @@ list = list3(lri,lrj,lri) wl0 = wl0-vl0_2*(voint(lri,lrj)+vint_ci(list)) - im = mul_tab(lsm_inn(lri),ns_sm) + im = Mul(lsm_inn(lri),ns_sm) jpdd = 1+im iwld = jud(lri) iwrd = jud(lrj) @@ -423,8 +423,8 @@ wls = wl0+(vls0-vl0_2)*(vint_ci(list)-2*vint_ci(list+1))-vls1*vint_ci(list) ! ar(23)-bl(32)-drl(22) ar(13)-bl(31)-drl(11) wlt = wl0+(vlt0-vl0_2)*(vint_ci(list)-2*vint_ci(list+1))-vlt1*vint_ci(list) - im = mul_tab(lsm_inn(lri),lsm_inn(lr)) - im = mul_tab(im,ns_sm) + im = Mul(lsm_inn(lri),lsm_inn(lr)) + im = Mul(im,ns_sm) jpds = 17+im jpdt = 9+im iwls = just(lri,lr) @@ -458,8 +458,8 @@ wls = wl0+(vls0-vl0_2)*(vint_ci(list)-2*vint_ci(list+1))-vls1*vint_ci(list) ! drl(22)-bl(23)-ar(32) drl(11)-bl(13)-ar(31) wlt = wl0+(vlt0-vl0_2)*(vint_ci(list)-2*vint_ci(list+1))-vlt1*vint_ci(list) - im = mul_tab(lsm_inn(lri),lsm_inn(lr)) - im = mul_tab(im,ns_sm) + im = Mul(lsm_inn(lri),lsm_inn(lr)) + im = Mul(im,ns_sm) jpds = 17+im !bbs_tmp jpdt = 9+im iwls = just(lr,lri) @@ -499,7 +499,7 @@ subroutine dbl_space_loop_ijkl_sgezero() use gugaci_global, only: jb_sys, just, lsm_inn, norb_dz, norb_frz, ns_sm, vint_ci -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero, Half use Definitions, only: wp, iwp @@ -525,9 +525,9 @@ !list = list4(lri,lrj,lrk,lrl) list = list4(lrl,lrk,lrj,lri) ni = mod(lrk-lrl+lri-lrj,2) - imik = mul_tab(imi,imk) - if (imik == mul_tab(imj,iml)) then - im = mul_tab(imik,ns_sm) + imik = Mul(imi,imk) + if (imik == Mul(imj,iml)) then + im = Mul(imik,ns_sm) jpds = 17+im jpdt = 9+im jpdt1 = jpdt+24 @@ -583,9 +583,9 @@ call prodab(1,0,jpdt1,iwlt,iwrt,0,wlt,0) end if end if - imil = mul_tab(imi,iml) - if (imil == mul_tab(imj,imk)) then - im = mul_tab(imil,ns_sm) + imil = Mul(imi,iml) + if (imil == Mul(imj,imk)) then + im = Mul(imil,ns_sm) jpds = 17+im jpdt = 9+im jpdt1 = jpdt+24 @@ -638,9 +638,9 @@ call prodab(1,0,jpdt1,iwlt,iwrt,0,wlt,0) end if end if - imij = mul_tab(imi,imj) - if (imij == mul_tab(imk,iml)) then - im = mul_tab(imij,ns_sm) + imij = Mul(imi,imj) + if (imij == Mul(imk,iml)) then + im = Mul(imij,ns_sm) jpds = 17+im jpdt = 9+im jpdt1 = 24+jpdt diff -Nru openmolcas-22.02/src/gugaci/dblcloop_g.F90 openmolcas-22.10/src/gugaci/dblcloop_g.F90 --- openmolcas-22.02/src/gugaci/dblcloop_g.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/dblcloop_g.F90 2022-10-10 14:22:40.000000000 +0000 @@ -26,7 +26,7 @@ subroutine dbl_space_loop_ijkk_sgezero_g() use gugaci_global, only: jb_sys, jud, just, lsm_inn, norb_dz, norb_frz, ns_sm -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: One, Two, Half use Definitions, only: wp, iwp @@ -65,8 +65,8 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) - jpds = 17+mul_tab(lmij,ns_sm) + lmij = Mul(lmi,lmj) + jpds = 17+Mul(lmij,ns_sm) iwdl = just(lrj,lri) iwdr = just(lri,lrj) !wl = -vlp_1*voint(lrj,lri) @@ -82,7 +82,7 @@ imi = lsm_inn(lri) !n2 = ngw2(lri-2) do lrj=lri+1,norb_dz - mij = mul_tab(imi,lsm_inn(lrj)) + mij = Mul(imi,lsm_inn(lrj)) if (mij /= 1) cycle ni = mod(lrj-lri,2) !=========== down comm for 2 4 ===================================== @@ -298,8 +298,8 @@ !=========== start comm for 2 4 ==================================== do lrm=norb_frz+1,norb_dz !ic=1,norb_act !frz imm = lsm_inn(lrm) - im = mul_tab(imm,imi) - im = mul_tab(im,ns_sm) + im = Mul(imm,imi) + im = Mul(im,ns_sm) kij = 0 if (lrm == lrj) kij = 2 if (lrm == lri) kij = 4 @@ -818,7 +818,7 @@ call trans_ijkl_intpos(lrj,lrm,lri,lrm,nxo) nxo_2 = nxo - im = mul_tab(lsm_inn(lri),ns_sm) + im = Mul(lsm_inn(lri),ns_sm) jpdd = 1+im iwld = jud(lri) iwrd = jud(lrj) @@ -831,8 +831,8 @@ call prodab_2(1,0,jpdd,iwld,iwrd,0,wl0_2,0,nxo_2) end if do lr=lrj+1,norb_dz - im = mul_tab(lsm_inn(lri),lsm_inn(lr)) - im = mul_tab(im,ns_sm) + im = Mul(lsm_inn(lri),lsm_inn(lr)) + im = Mul(im,ns_sm) jpds = 17+im jpdt = 9+im iwls = just(lri,lr) @@ -857,8 +857,8 @@ end do do lr=norb_frz+1,lri-1 - im = mul_tab(lsm_inn(lri),lsm_inn(lr)) - im = mul_tab(im,ns_sm) + im = Mul(lsm_inn(lri),lsm_inn(lr)) + im = Mul(im,ns_sm) jpds = 17+im jpdt = 9+im iwls = just(lr,lri) @@ -897,7 +897,7 @@ call trans_ijkl_intpos(lrj,lrm,lri,lrm,nxo) nxo_2 = nxo - im = mul_tab(lsm_inn(lri),ns_sm) + im = Mul(lsm_inn(lri),ns_sm) jpdd = 1+im iwld = jud(lri) iwrd = jud(lrj) @@ -910,8 +910,8 @@ call prodab_2(1,0,jpdd,iwld,iwrd,0,wl0_2,0,nxo_2) end if do lr=lrj+1,norb_dz - im = mul_tab(lsm_inn(lri),lsm_inn(lr)) - im = mul_tab(im,ns_sm) + im = Mul(lsm_inn(lri),lsm_inn(lr)) + im = Mul(im,ns_sm) jpds = 17+im jpdt = 9+im iwls = just(lri,lr) @@ -936,8 +936,8 @@ end do do lr=norb_frz+1,lri-1 - im = mul_tab(lsm_inn(lri),lsm_inn(lr)) - im = mul_tab(im,ns_sm) + im = Mul(lsm_inn(lri),lsm_inn(lr)) + im = Mul(im,ns_sm) jpds = 17+im jpdt = 9+im iwls = just(lr,lri) @@ -977,7 +977,7 @@ call trans_ijkl_intpos(lrj,lrm,lri,lrm,nxo) nxo_2 = nxo - im = mul_tab(lsm_inn(lri),ns_sm) + im = Mul(lsm_inn(lri),ns_sm) jpdd = 1+im iwld = jud(lri) iwrd = jud(lrj) @@ -990,8 +990,8 @@ call prodab_2(1,0,jpdd,iwld,iwrd,0,wl0_2,0,nxo_2) end if do lr=lrj+1,norb_dz - im = mul_tab(lsm_inn(lri),lsm_inn(lr)) - im = mul_tab(im,ns_sm) + im = Mul(lsm_inn(lri),lsm_inn(lr)) + im = Mul(im,ns_sm) jpds = 17+im jpdt = 9+im iwls = just(lri,lr) @@ -1016,8 +1016,8 @@ end do do lr=norb_frz+1,lri-1 - im = mul_tab(lsm_inn(lri),lsm_inn(lr)) - im = mul_tab(im,ns_sm) + im = Mul(lsm_inn(lri),lsm_inn(lr)) + im = Mul(im,ns_sm) jpds = 17+im jpdt = 9+im iwls = just(lr,lri) @@ -1049,7 +1049,7 @@ !wl0 = wl0-vl0_2*vint_ci(list) wl0 = -vl0_2 call trans_ijkl_intpos(lrj,lrj,lri,lrj,nxo) - im = mul_tab(lsm_inn(lri),ns_sm) + im = Mul(lsm_inn(lri),ns_sm) jpdd = 1+im iwld = jud(lri) iwrd = jud(lrj) @@ -1059,8 +1059,8 @@ call prodab_2(1,0,jpdd,iwld,iwrd,0,wl0,0,nxo) end if do lr=lrj+1,norb_dz - im = mul_tab(lsm_inn(lri),lsm_inn(lr)) - im = mul_tab(im,ns_sm) + im = Mul(lsm_inn(lri),lsm_inn(lr)) + im = Mul(im,ns_sm) jpds = 17+im jpdt = 9+im iwls = just(lri,lr) @@ -1081,8 +1081,8 @@ end do do lr=norb_frz+1,lri-1 - im = mul_tab(lsm_inn(lri),lsm_inn(lr)) - im = mul_tab(im,ns_sm) + im = Mul(lsm_inn(lri),lsm_inn(lr)) + im = Mul(im,ns_sm) jpds = 17+im jpdt = 9+im iwls = just(lr,lri) @@ -1107,7 +1107,7 @@ wl0 = -vl0_2 call trans_ijkl_intpos(lrj,lri,lri,lri,nxo) - im = mul_tab(lsm_inn(lri),ns_sm) + im = Mul(lsm_inn(lri),ns_sm) jpdd = 1+im iwld = jud(lri) iwrd = jud(lrj) @@ -1119,8 +1119,8 @@ call prodab_2(1,0,jpdd,iwld,iwrd,0,wl0,0,nxo) end if do lr=lrj+1,norb_dz - im = mul_tab(lsm_inn(lri),lsm_inn(lr)) - im = mul_tab(im,ns_sm) + im = Mul(lsm_inn(lri),lsm_inn(lr)) + im = Mul(im,ns_sm) jpds = 17+im jpdt = 9+im iwls = just(lri,lr) @@ -1145,8 +1145,8 @@ end do do lr=norb_frz+1,lri-1 - im = mul_tab(lsm_inn(lri),lsm_inn(lr)) - im = mul_tab(im,ns_sm) + im = Mul(lsm_inn(lri),lsm_inn(lr)) + im = Mul(im,ns_sm) jpds = 17+im jpdt = 9+im iwls = just(lr,lri) @@ -1185,8 +1185,8 @@ nxo_1 = nxo call trans_ijkl_intpos(lrj,lri,lr,lr,nxo) nxo_2 = nxo - im = mul_tab(lsm_inn(lri),lsm_inn(lr)) - im = mul_tab(im,ns_sm) + im = Mul(lsm_inn(lri),lsm_inn(lr)) + im = Mul(im,ns_sm) jpds = 17+im jpdt = 9+im iwls = just(lri,lr) @@ -1237,8 +1237,8 @@ call trans_ijkl_intpos(lrj,lri,lr,lr,nxo) nxo_2 = nxo - im = mul_tab(lsm_inn(lri),lsm_inn(lr)) - im = mul_tab(im,ns_sm) + im = Mul(lsm_inn(lri),lsm_inn(lr)) + im = Mul(im,ns_sm) jpds = 17+im jpdt = 9+im iwls = just(lr,lri) @@ -1286,7 +1286,7 @@ subroutine dbl_space_loop_ijkl_sgezero_g() use gugaci_global, only: jb_sys, just, lsm_inn, norb_dz, norb_frz, ns_sm -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero, One, Half use Definitions, only: wp, iwp @@ -1315,9 +1315,9 @@ !list = list4(lrl,lrk,lrj,lri) ni = mod(lrk-lrl+lri-lrj,2) - imik = mul_tab(imi,imk) - if (imik == mul_tab(imj,iml)) then - im = mul_tab(imik,ns_sm) + imik = Mul(imi,imk) + if (imik == Mul(imj,iml)) then + im = Mul(imik,ns_sm) jpds = 17+im jpdt = 9+im jpdt1 = jpdt+24 @@ -1397,9 +1397,9 @@ end if end if - imil = mul_tab(imi,iml) - if (imil == mul_tab(imj,imk)) then - im = mul_tab(imil,ns_sm) + imil = Mul(imi,iml) + if (imil == Mul(imj,imk)) then + im = Mul(imil,ns_sm) jpds = 17+im jpdt = 9+im jpdt1 = jpdt+24 @@ -1475,9 +1475,9 @@ end if end if - imij = mul_tab(imi,imj) - if (imij == mul_tab(imk,iml)) then - im = mul_tab(imij,ns_sm) + imij = Mul(imi,imj) + if (imij == Mul(imk,iml)) then + im = Mul(imij,ns_sm) jpds = 17+im jpdt = 9+im jpdt1 = 24+jpdt diff -Nru openmolcas-22.02/src/gugaci/dblextloop.F90 openmolcas-22.10/src/gugaci/dblextloop.F90 --- openmolcas-22.02/src/gugaci/dblextloop.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/dblextloop.F90 2022-10-10 14:22:40.000000000 +0000 @@ -876,7 +876,7 @@ jphy, logic_dh, logic_g13, logic_g1415, logic_g2g4b, logic_g34b, logic_g35b, logic_g36b, logic_grad, & lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, mtype, ndim, nstaval, nvalue, value_lpext, value_lpext1, & vplp_w0, vplpnew_w0, w0_plp, w1_plp -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -891,7 +891,7 @@ iwuplwei = jpad_upwei(jpadl) ilsegdownwei = iseg_downwei(ipael) irsegdownwei = iseg_downwei(ipae) -imlr = mul_tab(iml,imr) +imlr = Mul(iml,imr) if (imlr == 1) then logic_g1415 = .true. if (iml == 1) logic_g13 = .true. @@ -1210,7 +1210,7 @@ jphy, logic_dh, logic_g1415, logic_g34b, logic_g35b, logic_g36b, logic_grad, lp_lwei, lp_rwei, & lpnew_lwei, lpnew_rwei, mtype, ndim, nstaval, nvalue, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_plp, & w1_plp -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -1221,7 +1221,7 @@ iwuplwei = jpad_upwei(jpadl) ilsegdownwei = iseg_downwei(ipael) irsegdownwei = iseg_downwei(ipae) -imlr = mul_tab(iml,imr) +imlr = Mul(iml,imr) if (imlr == 1) then logic_g1415 = .true. logic_g36b = .true. diff -Nru openmolcas-22.02/src/gugaci/dblploop1.F90 openmolcas-22.10/src/gugaci/dblploop1.F90 --- openmolcas-22.02/src/gugaci/dblploop1.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/dblploop1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -13,7 +13,7 @@ use gugaci_global, only: jb_sys, jml, jmr, jpad, jpadl, jpel, jper, just, jwl, jwr, line, lrs, lsm_inn, norb_dz, norb_frz, w0, & w0_ss, w1, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -90,8 +90,8 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) - jmlr = mul_tab(jml,jmr) + lmij = Mul(lmi,lmj) + jmlr = Mul(jml,jmr) if (lmij /= jmlr) cycle w0ss2 = w0_ss(2) w1ss2 = w1_ss(2) @@ -251,8 +251,8 @@ end if do lrk=norb_frz+1,lri-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then ! ss(1-5) (22)-ar(13)-bl(31)- iwdl = just(lrk,lri) @@ -316,8 +316,8 @@ do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then if (jb_sys > 0) then ! ss(1-7) ar(13)-c'(21)-bl(32)- @@ -390,8 +390,8 @@ do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then if (jb_sys > 0) then ! ss(1-11) ar(13)-bl(31)-c"(22)- @@ -425,7 +425,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if ((lmij /= jml) .or. (jml /= jmr)) cycle iwdl = just(lrj,lri) iwdr = just(lri,lrj) @@ -491,7 +491,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if ((lmij /= jml) .or. (jml /= jmr)) cycle if ((jwl >= jwr) .and. (jb_sys == 0)) cycle wl = Zero @@ -611,7 +611,7 @@ subroutine st_head_dbl_tail_act(lra) use gugaci_global, only: jb_sys, jml, jmr, jpel, jper, just, jwl, jwr, line, lrs, lsm_inn, norb_dz, norb_frz, w1, w1_st -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -630,8 +630,8 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) - lmij = mul_tab(lmij,1) + lmij = Mul(lmi,lmj) + lmij = Mul(lmij,1) if ((jml == jmr) .and. (lmij == jml)) then iwds = just(lri,lrj) iwdt = iwds @@ -684,7 +684,7 @@ end if end if - jmlr = mul_tab(jml,jmr) + jmlr = Mul(jml,jmr) if (lmij /= jmlr) cycle w1st1 = w1_st(1) w1st2 = w1_st(2) @@ -732,8 +732,8 @@ end if do lrk=norb_frz+1,lri-1 lmk = lsm_inn(lrk) - if (mul_tab(lmk,lmi) /= jml) cycle - if (mul_tab(lmk,lmj) /= jmr) cycle + if (Mul(lmk,lmi) /= jml) cycle + if (Mul(lmk,lmj) /= jmr) cycle iwds = just(lrk,lri) iwdt = just(lrk,lrj) call prodab(3,jpel,iwds,iwdt,jwl,jwr,wl,jper) @@ -768,8 +768,8 @@ !wl1 = -vlop1*vint_ci(list) do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - if (mul_tab(lmk,lmi) /= jml) cycle - if (mul_tab(lmk,lmj) /= jmr) cycle + if (Mul(lmk,lmi) /= jml) cycle + if (Mul(lmk,lmj) /= jmr) cycle iwds = just(lri,lrk) iwdt = just(lrj,lrk) call prodab(3,jpel,iwds,iwdt,jwl,jwr,wl,jper) @@ -781,8 +781,8 @@ ! st(2-4) ar(23)-c'(12)-bl(32)- do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - if (mul_tab(lmk,lmi) /= jml) cycle - if (mul_tab(lmk,lmj) /= jmr) cycle + if (Mul(lmk,lmi) /= jml) cycle + if (Mul(lmk,lmj) /= jmr) cycle iwds = just(lri,lrk) iwdt = just(lrk,lrj) call prodab(3,jpel,iwds,iwdt,jwl,jwr,-wl,jper) @@ -802,7 +802,7 @@ subroutine ts_head_dbl_tail_act(lra) use gugaci_global, only: jb_sys, jml, jmr, jpel, jper, just, jwl, jwr, line, lrs, lsm_inn, norb_dz, norb_frz, w1, w1_ts -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -816,12 +816,12 @@ ! ts(3-2) ar(23)-c'(22)-bl(31)- ! ts(3-3) ar(23)-bl(31)-c"(22)- ! ts(3-4) ar(23)-bl(32)-c"(21)- -lmas = mul_tab(lsm_inn(lra),lsm_inn(lrs)) +lmas = Mul(lsm_inn(lra),lsm_inn(lrs)) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmas /= lmij) cycle w1ts1 = w1_ts(1) w1ts2 = w1_ts(2) @@ -870,7 +870,7 @@ ! ts(3-2) (22)ar(23)-bl(31)- do lrk=norb_frz+1,lri-1 lmk = lsm_inn(lrk) - if ((mul_tab(lmk,lmi) /= jml) .or. (mul_tab(lmk,lmj) /= jmr)) cycle + if ((Mul(lmk,lmi) /= jml) .or. (Mul(lmk,lmj) /= jmr)) cycle iwdt = just(lrk,lri) iwds = just(lrk,lrj) call prodab(3,jpel,iwdt,iwds,jwl,jwr,wl,jper) @@ -878,7 +878,7 @@ ! ts(3-2) ar(23)-c'(22)-bl(31)- do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - if ((mul_tab(lmk,lmi) /= jml) .or. (mul_tab(lmk,lmj) /= jmr)) cycle + if ((Mul(lmk,lmi) /= jml) .or. (Mul(lmk,lmj) /= jmr)) cycle iwdt = just(lri,lrk) iwds = just(lrk,lrj) call prodab(3,jpel,iwdt,iwds,jwl,jwr,-wl,jper) @@ -898,7 +898,7 @@ end if do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - if ((mul_tab(lmk,lmi) /= jml) .or. (mul_tab(lmk,lmj) /= jmr)) cycle + if ((Mul(lmk,lmi) /= jml) .or. (Mul(lmk,lmj) /= jmr)) cycle iwdt = just(lri,lrk) iwds = just(lrj,lrk) call prodab(3,jpel,iwdt,iwds,jwl,jwr,wl,jper) @@ -920,7 +920,7 @@ !wl = -vlop1*vint_ci(list) !2.2 vlop0=0 do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - if ((mul_tab(lmk,lmi) /= jml) .or. (mul_tab(lmk,lmj) /= jmr)) cycle + if ((Mul(lmk,lmi) /= jml) .or. (Mul(lmk,lmj) /= jmr)) cycle iwdt = just(lri,lrk) iwds = just(lrk,lrj) call prodab(3,jpel,iwdt,iwds,jwl,jwr,wl,jper) @@ -936,7 +936,7 @@ subroutine stt_head_dbl_tail_act(lra) use gugaci_global, only: jml, jmr, jpel, jper, just, jwl, jwr, line, lrs, lsm_inn, norb_dz, norb_frz, w1, w1_st1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -955,7 +955,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) w1st1 = w1_st1(1) w1st2 = w1_st1(2) w1st3 = w1_st1(3) @@ -1000,7 +1000,7 @@ end if do lrk=norb_frz+1,lri-1 lmk = lsm_inn(lrk) - if ((mul_tab(lmk,lmi) /= jml) .or. (mul_tab(lmk,lmj) /= jmr)) cycle + if ((Mul(lmk,lmi) /= jml) .or. (Mul(lmk,lmj) /= jmr)) cycle !wl = -vlop1*vint_ci(list) iwdl = just(lri,lrk) iwdr = just(lrk,lrj) @@ -1020,7 +1020,7 @@ ! st1(4-4) ar(23)-c'(11)-bl(31)- do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - if ((mul_tab(lmi,lmk) /= jml) .or. (mul_tab(lmk,lmj) /= jmr)) cycle + if ((Mul(lmi,lmk) /= jml) .or. (Mul(lmk,lmj) /= jmr)) cycle iwdl = just(lri,lrk) iwdr = just(lrk,lrj) call prodab(3,jpel,iwdl,iwdr,jwl,jwr,-wl,jper) @@ -1028,7 +1028,7 @@ ! st1(4-4) ar(23)-bl(31)-c"(11)- do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - if ((mul_tab(lmi,lmk) /= jml) .or. (mul_tab(lmj,lmk) /= jmr)) cycle + if ((Mul(lmi,lmk) /= jml) .or. (Mul(lmj,lmk) /= jmr)) cycle iwdl = just(lri,lrk) iwdr = just(lrj,lrk) call prodab(3,jpel,iwdl,iwdr,jwl,jwr,wl,jper) @@ -1048,7 +1048,7 @@ ! st1(4-3) ar(13)-c'(21)-bl(31)- do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - if ((mul_tab(lmi,lmk) /= jml) .or. (mul_tab(lmk,lmj) /= jmr)) cycle + if ((Mul(lmi,lmk) /= jml) .or. (Mul(lmk,lmj) /= jmr)) cycle iwdl = just(lrk,lri) iwdr = just(lrk,lrj) call prodab(3,jpel,iwdl,iwdr,jwl,jwr,-wl,jper) @@ -1056,7 +1056,7 @@ ! st1(4-3) ar(13)-bl(31)-c"(21)- do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - if ((mul_tab(lmi,lmk) /= jml) .or. (mul_tab(lmj,lmk) /= jmr)) cycle + if ((Mul(lmi,lmk) /= jml) .or. (Mul(lmj,lmk) /= jmr)) cycle iwdl = just(lrk,lri) iwdr = just(lrj,lrk) call prodab(3,jpel,iwdl,iwdr,jwl,jwr,wl,jper) @@ -1071,7 +1071,7 @@ subroutine tts_head_dbl_tail_act(lra) use gugaci_global, only: jml, jmr, jpel, jper, just, jwl, jwr, line, lrs, lsm_inn, norb_dz, norb_frz, w1, w1_t1s -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1092,7 +1092,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) w1t1s1 = w1_t1s(1) w1t1s2 = w1_t1s(2) w1t1s3 = w1_t1s(3) @@ -1144,7 +1144,7 @@ do lrk=norb_frz+1,lri-1 lmk = lsm_inn(lrk) ! t1s(5-2) (11)ar(13)-bl(32)- - if ((jml /= mul_tab(lmk,lmi)) .or. (jmr /= mul_tab(lmk,lmj))) cycle + if ((jml /= Mul(lmk,lmi)) .or. (jmr /= Mul(lmk,lmj))) cycle !vlop1 = w1*w1t1s2 !wl = -vlop1*vint_ci(list) iwdl = just(lrk,lri) @@ -1154,7 +1154,7 @@ do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) ! t1s(5-2) ar(13)-c'(11)-bl(32)- - if ((jml /= mul_tab(lmi,lmk)) .or. (jmr /= mul_tab(lmk,lmj))) cycle + if ((jml /= Mul(lmi,lmk)) .or. (jmr /= Mul(lmk,lmj))) cycle !vlop1 = w1*w1t1s2 !wl = -vlop1*vint_ci(list) iwdl = just(lri,lrk) @@ -1175,7 +1175,7 @@ do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) ! t1s(5-3) ar(13)-bl(31)-c"(12)- - if ((jml /= mul_tab(lmi,lmk)) .or. (jmr /= mul_tab(lmj,lmk))) cycle + if ((jml /= Mul(lmi,lmk)) .or. (jmr /= Mul(lmj,lmk))) cycle !vlop1 = w1*w1t1s3 !wl = -vlop1*vint_ci(list) iwdl = just(lri,lrk) @@ -1197,7 +1197,7 @@ do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) ! t1s(5-4) ar(13)-bl(32)-c"(11)- - if ((jml /= mul_tab(lmi,lmk)) .or. (jmr /= mul_tab(lmj,lmk))) cycle + if ((jml /= Mul(lmi,lmk)) .or. (jmr /= Mul(lmj,lmk))) cycle iwdl = just(lri,lrk) iwdr = just(lrj,lrk) call prodab(3,jpel,iwdl,iwdr,jwl,jwr,wl,jper) @@ -1263,7 +1263,7 @@ use gugaci_global, only: jml, jmr, jpad, jpadl, jpel, jper, just, jwl, jwr, line, lrs, lsm_inn, norb_dz, norb_frz, w0, w0_tt, w1, & w1_tt -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1284,8 +1284,8 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) - jmlr = mul_tab(jml,jmr) + lmij = Mul(lmi,lmj) + jmlr = Mul(jml,jmr) if (lmij /= jmlr) cycle w0tt1 = w0_tt(1) w1tt1 = w1_tt(1) @@ -1310,8 +1310,8 @@ ! tt(11-1) (22)ar(23)-bl(32)- do lrk=norb_frz+1,lri-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lrk,lri) iwdr = just(lrk,lrj) @@ -1321,8 +1321,8 @@ ! tt(11-1) ar(23)-bl(32)-c"(22)- act -c"- do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lri,lrk) iwdr = just(lrj,lrk) @@ -1332,8 +1332,8 @@ ! tt(11-1) ar(23)-c'(22)-bl(32)- act -c"- do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lri,lrk) iwdr = just(lrk,lrj) @@ -1354,7 +1354,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if ((lmij /= jml) .or. (lmij /= jmr)) cycle if (jwl >= jwr) cycle ! tt(11-2) (22)drl(22)- @@ -1414,7 +1414,7 @@ use gugaci_global, only: jml, jmr, jpad, jpadl, jpel, jper, just, jwl, jwr, line, lrs, lsm_inn, norb_dz, norb_frz, w0, w0_t1t1, & w1, w1_t1t1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1453,7 +1453,7 @@ ! t1t1(12-1) (11)ar(13)-bl(31)- do lrm=norb_frz+1,lri-1 lmm = lsm_inn(lrm) - if ((jml /= mul_tab(lmi,lmm)) .or. (jmr /= mul_tab(lmm,lmj))) cycle + if ((jml /= Mul(lmi,lmm)) .or. (jmr /= Mul(lmm,lmj))) cycle iwdl = just(lrm,lri) iwdr = just(lrm,lrj) call prodab(3,jpel,iwdl,iwdr,jwl,jwr,wl,jper) @@ -1461,7 +1461,7 @@ ! t1t1(12-1) ar(13)-bl(31)-c"(11)- do lrm=lrj+1,norb_dz lmm = lsm_inn(lrm) - if ((jml /= mul_tab(lmi,lmm)) .or. (jmr /= mul_tab(lmm,lmj))) cycle + if ((jml /= Mul(lmi,lmm)) .or. (jmr /= Mul(lmm,lmj))) cycle iwdl = just(lri,lrm) iwdr = just(lrj,lrm) call prodab(3,jpel,iwdl,iwdr,jwl,jwr,wl,jper) @@ -1469,7 +1469,7 @@ ! t1t1(12-1) ar(13)-c'(11)-bl(31)- do lrm=lri+1,lrj-1 lmm = lsm_inn(lrm) - if ((jml /= mul_tab(lmi,lmm)) .or. (jmr /= mul_tab(lmm,lmj))) cycle + if ((jml /= Mul(lmi,lmm)) .or. (jmr /= Mul(lmm,lmj))) cycle iwdl = just(lri,lrm) iwdr = just(lrm,lrj) call prodab(3,jpel,iwdl,iwdr,jwl,jwr,-wl,jper) @@ -1484,7 +1484,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz !bbs_tmp lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (jml /= lmij) cycle vlop0 = w0*w0_t1t1(2) vlop1 = w1*w1_t1t1(2) @@ -1828,7 +1828,7 @@ subroutine sv_head_dbl_tail_act(lra) use gugaci_global, only: jb_sys, jml, jpel, jper, just, jwl, jwr, line, lrs, lsm_inn, norb_dz, norb_frz, w0, w0_sv, w1, w1_sv -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1845,7 +1845,7 @@ lmi = lsm_inn(lri) do lrj=lri,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle w0sv1 = w0_sv(1) w1sv1 = w1_sv(1) @@ -1910,7 +1910,7 @@ use gugaci_global, only: jb_sys, jml, jmr, jpel, jper, jud, just, jwl, jwr, lsm_inn, norb_dz, norb_frz, norb_inn, vint_ci, voint, & w0, w0_sd, w1, w1_sd -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1920,7 +1920,7 @@ w0sd8, w0sd9, w1sd10, w1sd11, w1sd2, w1sd5, w1sd6, w1sd7, w1sd8, wl integer(kind=iwp), external :: list3, list4 -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) ! sd(6-1) a&r(02)- ! sd(6-2) c(22)a&r(13)- ! sd(6-4) a&r(23)c'(12)- @@ -1997,7 +1997,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle w0sd2 = w0_sd(2) w1sd2 = w1_sd(2) @@ -2210,7 +2210,7 @@ use gugaci_global, only: jb_sys, jml, jmr, jpel, jper, jud, just, jwl, jwr, lsm_inn, norb_dz, norb_frz, norb_inn, vint_ci, voint, & w0, w0_sd1, w1, w1_sd1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2220,7 +2220,7 @@ w0sd9, w1sd10, w1sd2, w1sd3, w1sd4, w1sd5, w1sd6, w1sd7, w1sd8, wl integer(kind=iwp), external :: list3, list4 -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) ! sd1(8-1) a&r(01)- ! sd1(8-2) c(11)a&r(23)- ! sd1(8-3) a&r(13)c'(21)- @@ -2292,7 +2292,7 @@ do lrj=lri+1,norb_dz if (lri == lrj) cycle lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle w0sd2 = w0_sd1(2) w1sd2 = w1_sd1(2) @@ -2485,7 +2485,7 @@ ! !use gugaci_global, only: jml, jmr, jpel, jper, jud, just, jwl, jwr, lsm_inn, norb_dz, norb_frz, norb_inn, vint_ci, voint, w0, & ! w0_td, w1, w1_td -!use Symmetry_Info, only: mul_tab => Mul +!use Symmetry_Info, only: Mul !use Definitions, only: wp, iwp ! !implicit none @@ -2494,7 +2494,7 @@ !real(kind=wp) :: tcoe, vlop0, vlop1, w0td1, w0td2, w0td3, w0td4, w0td5, w1td2, w1td3, wl !integer(kind=iwp), external :: list3, list4 ! -!jmlr = mul_tab(jml,jmr) +!jmlr = Mul(jml,jmr) !! td(13-1) (22)a&(23) !! td(13-1) a&(23)c'(22) !! td(13-5) (22)d&&l(33)b^l(23) @@ -2580,7 +2580,7 @@ ! lmi = lsm_inn(lri) ! do lrj=lri+1,norb_dz ! lmj = lsm_inn(lrj) -! lmij = mul_tab(lmi,lmj) +! lmij = Mul(lmi,lmj) ! if (lmij /= jml) cycle ! iwdl = just(lri,lrj) ! @@ -2628,7 +2628,7 @@ use gugaci_global, only: jml, jmr, jpel, jper, jud, just, jwl, jwr, lsm_inn, norb_dz, norb_frz, norb_inn, vint_ci, voint, w0, & w0_t1d1, w1, w1_t1d1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2637,7 +2637,7 @@ real(kind=wp) :: tcoe, vlop0, vlop1, w0td1, w0td2, w0td3, w0td4, w0td5, w1td2, w1td3, wl integer(kind=iwp), external :: list3, list4 -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) ! t1d1(15-1) (11)a&(13) ! t1d1(15-1) a&(13)c'(11) ! t1d1(15-5) (11)d&&l(33)b^l(13) @@ -2724,7 +2724,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle iwdl = just(lri,lrj) @@ -2772,7 +2772,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sv, w1_sv -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2782,12 +2782,12 @@ integer(kind=iwp), external :: iwalk_ad ! sv(10-1) ar(13)br(23) act -c"- tv_ext -br-ar -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmlr) cycle !------------------------------------------------------------------- w0sv1 = w0_sv(1) diff -Nru openmolcas-22.02/src/gugaci/dblploop1_g.F90 openmolcas-22.10/src/gugaci/dblploop1_g.F90 --- openmolcas-22.02/src/gugaci/dblploop1_g.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/dblploop1_g.F90 2022-10-10 14:22:40.000000000 +0000 @@ -13,7 +13,7 @@ use gugaci_global, only: jb_sys, jml, jmr, jpad, jpadl, jpel, jper, just, jwl, jwr, line, lrs, lsm_inn, norb_dz, norb_frz, w0, & w0_ss, w1, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -93,8 +93,8 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) - JMLR = MUL_TAB(JML,JMR) + LMIJ = Mul(LMI,LMJ) + JMLR = Mul(JML,JMR) if (LMIJ /= JMLR) cycle W0SS2 = W0_SS(2) W1SS2 = W1_SS(2) @@ -262,8 +262,8 @@ end if do LRK=NORB_FRZ+1,LRI-1 LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) - LMKJ = MUL_TAB(LMK,LMJ) + LMKI = Mul(LMK,LMI) + LMKJ = Mul(LMK,LMJ) if ((LMKI == JML) .and. (LMKJ == JMR)) then ! SS(1-5) (22)-Ar(13)-Bl(31)- IWDL = JUST(LRK,LRI) @@ -331,8 +331,8 @@ do LRK=LRI+1,LRJ-1 LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) - LMKJ = MUL_TAB(LMK,LMJ) + LMKI = Mul(LMK,LMI) + LMKJ = Mul(LMK,LMJ) if ((LMKI == JML) .and. (LMKJ == JMR)) then if (JB_SYS > 0) then ! SS(1-7) Ar(13)-C'(21)-Bl(32)- @@ -417,8 +417,8 @@ do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) - LMKJ = MUL_TAB(LMK,LMJ) + LMKI = Mul(LMK,LMI) + LMKJ = Mul(LMK,LMJ) if ((LMKI == JML) .and. (LMKJ == JMR)) then if (JB_SYS > 0) then ! SS(1-11) Ar(13)-Bl(31)-C"(22)- @@ -464,7 +464,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((LMIJ /= JML) .or. (JML /= JMR)) cycle IWDL = JUST(LRJ,LRI) IWDR = JUST(LRI,LRJ) @@ -534,7 +534,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((LMIJ /= JML) .or. (JML /= JMR)) cycle if ((JWL >= JWR) .and. (JB_SYS == 0)) cycle !WL = Zero @@ -672,7 +672,7 @@ subroutine ST_HEAD_DBL_TAIL_ACT_G(LRA) use gugaci_global, only: jb_sys, jml, jmr, jpel, jper, just, jwl, jwr, line, lrs, lsm_inn, norb_dz, norb_frz, w1, w1_st -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -691,8 +691,8 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) - LMIJ = MUL_TAB(LMIJ,1) + LMIJ = Mul(LMI,LMJ) + LMIJ = Mul(LMIJ,1) if ((JML == JMR) .and. (LMIJ == JML)) then IWDS = JUST(LRI,LRJ) IWDT = IWDS @@ -758,7 +758,7 @@ end if end if - JMLR = MUL_TAB(JML,JMR) + JMLR = Mul(JML,JMR) if (LMIJ /= JMLR) cycle W1ST1 = W1_ST(1) W1ST2 = W1_ST(2) @@ -810,8 +810,8 @@ end if do LRK=NORB_FRZ+1,LRI-1 LMK = LSM_INN(LRK) - if (MUL_TAB(LMK,LMI) /= JML) cycle - if (MUL_TAB(LMK,LMJ) /= JMR) cycle + if (Mul(LMK,LMI) /= JML) cycle + if (Mul(LMK,LMJ) /= JMR) cycle IWDS = JUST(LRK,LRI) IWDT = JUST(LRK,LRJ) !call PRODAB(3,JPEL,IWDS,IWDT,JWL,JWR,WL,JPER) @@ -849,8 +849,8 @@ !WL1 = -VLOP1*vint_ci(LIST) do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - if (MUL_TAB(LMK,LMI) /= JML) cycle - if (MUL_TAB(LMK,LMJ) /= JMR) cycle + if (Mul(LMK,LMI) /= JML) cycle + if (Mul(LMK,LMJ) /= JMR) cycle IWDS = JUST(LRI,LRK) IWDT = JUST(LRJ,LRK) !call PRODAB(3,JPEL,IWDS,IWDT,JWL,JWR,WL,JPER) @@ -870,8 +870,8 @@ ! ST(2-4) Ar(23)-C'(12)-Bl(32)- do LRK=LRI+1,LRJ-1 LMK = LSM_INN(LRK) - if (MUL_TAB(LMK,LMI) /= JML) cycle - if (MUL_TAB(LMK,LMJ) /= JMR) cycle + if (Mul(LMK,LMI) /= JML) cycle + if (Mul(LMK,LMJ) /= JMR) cycle IWDS = JUST(LRI,LRK) IWDT = JUST(LRK,LRJ) !call PRODAB(3,JPEL,IWDS,IWDT,JWL,JWR,-WL,JPER) @@ -899,7 +899,7 @@ subroutine TS_HEAD_DBL_TAIL_ACT_G(LRA) use gugaci_global, only: jb_sys, jml, jmr, jpel, jper, just, jwl, jwr, line, lrs, lsm_inn, norb_dz, norb_frz, w1, w1_ts -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -917,7 +917,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) W1TS1 = W1_TS(1) W1TS2 = W1_TS(2) W1TS3 = W1_TS(3) @@ -968,7 +968,7 @@ ! TS(3-2) (22)Ar(23)-Bl(31)- do LRK=NORB_FRZ+1,LRI-1 LMK = LSM_INN(LRK) - if ((MUL_TAB(LMK,LMI) /= JML) .or. (MUL_TAB(LMK,LMJ) /= JMR)) cycle + if ((Mul(LMK,LMI) /= JML) .or. (Mul(LMK,LMJ) /= JMR)) cycle IWDT = JUST(LRK,LRI) IWDS = JUST(LRK,LRJ) !call PRODAB(3,JPEL,IWDT,IWDS,JWL,JWR,WL,JPER) @@ -980,7 +980,7 @@ ! TS(3-2) Ar(23)-C'(22)-Bl(31)- do LRK=LRI+1,LRJ-1 LMK = LSM_INN(LRK) - if ((MUL_TAB(LMK,LMI) /= JML) .or. (MUL_TAB(LMK,LMJ) /= JMR)) cycle + if ((Mul(LMK,LMI) /= JML) .or. (Mul(LMK,LMJ) /= JMR)) cycle IWDT = JUST(LRI,LRK) IWDS = JUST(LRK,LRJ) !call PRODAB(3,JPEL,IWDT,IWDS,JWL,JWR,-WL,JPER) @@ -1004,7 +1004,7 @@ end if do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - if ((MUL_TAB(LMK,LMI) /= JML) .or. (MUL_TAB(LMK,LMJ) /= JMR)) cycle + if ((Mul(LMK,LMI) /= JML) .or. (Mul(LMK,LMJ) /= JMR)) cycle IWDT = JUST(LRI,LRK) IWDS = JUST(LRJ,LRK) !call PRODAB(3,JPEL,IWDT,IWDS,JWL,JWR,WL,JPER) @@ -1031,7 +1031,7 @@ !WL = -VLOP1*VINT_CI(LIST) !2.2 vlop0=0 do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - if ((MUL_TAB(LMK,LMI) /= JML) .or. (MUL_TAB(LMK,LMJ) /= JMR)) cycle + if ((Mul(LMK,LMI) /= JML) .or. (Mul(LMK,LMJ) /= JMR)) cycle IWDT = JUST(LRI,LRK) IWDS = JUST(LRK,LRJ) !call PRODAB(3,JPEL,IWDT,IWDS,JWL,JWR,WL,JPER) @@ -1051,7 +1051,7 @@ subroutine STT_HEAD_DBL_TAIL_ACT_G(LRA) use gugaci_global, only: jml, jmr, jpel, jper, just, jwl, jwr, line, lrs, lsm_inn, norb_dz, norb_frz, w1, w1_st1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1070,7 +1070,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) W1ST1 = W1_ST1(1) W1ST2 = W1_ST1(2) W1ST3 = W1_ST1(3) @@ -1118,7 +1118,7 @@ end if do LRK=NORB_FRZ+1,LRI-1 LMK = LSM_INN(LRK) - if ((MUL_TAB(LMK,LMI) /= JML) .or. (MUL_TAB(LMK,LMJ) /= JMR)) cycle + if ((Mul(LMK,LMI) /= JML) .or. (Mul(LMK,LMJ) /= JMR)) cycle !WL = -VLOP1*VINT_CI(LIST) IWDL = JUST(LRI,LRK) IWDR = JUST(LRK,LRJ) @@ -1141,7 +1141,7 @@ ! ST1(4-4) Ar(23)-C'(11)-Bl(31)- do LRK=LRI+1,LRJ-1 LMK = LSM_INN(LRK) - if ((MUL_TAB(LMI,LMK) /= JML) .or. (MUL_TAB(LMK,LMJ) /= JMR)) cycle + if ((Mul(LMI,LMK) /= JML) .or. (Mul(LMK,LMJ) /= JMR)) cycle IWDL = JUST(LRI,LRK) IWDR = JUST(LRK,LRJ) !call PRODAB(3,JPEL,IWDL,IWDR,JWL,JWR,-WL,JPER) @@ -1152,7 +1152,7 @@ ! ST1(4-4) Ar(23)-Bl(31)-C"(11)- do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - if ((MUL_TAB(LMI,LMK) /= JML) .or. (MUL_TAB(LMJ,LMK) /= JMR)) cycle + if ((Mul(LMI,LMK) /= JML) .or. (Mul(LMJ,LMK) /= JMR)) cycle IWDL = JUST(LRI,LRK) IWDR = JUST(LRJ,LRK) !call PRODAB(3,JPEL,IWDL,IWDR,JWL,JWR,WL,JPER) @@ -1175,7 +1175,7 @@ ! ST1(4-3) Ar(13)-C'(21)-Bl(31)- do LRK=LRI+1,LRJ-1 LMK = LSM_INN(LRK) - if ((MUL_TAB(LMI,LMK) /= JML) .or. (MUL_TAB(LMK,LMJ) /= JMR)) cycle + if ((Mul(LMI,LMK) /= JML) .or. (Mul(LMK,LMJ) /= JMR)) cycle IWDL = JUST(LRK,LRI) IWDR = JUST(LRK,LRJ) !call PRODAB(3,JPEL,IWDL,IWDR,JWL,JWR,-WL,JPER) @@ -1186,7 +1186,7 @@ ! ST1(4-3) Ar(13)-Bl(31)-C"(21)- do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - if ((MUL_TAB(LMI,LMK) /= JML) .or. (MUL_TAB(LMJ,LMK) /= JMR)) cycle + if ((Mul(LMI,LMK) /= JML) .or. (Mul(LMJ,LMK) /= JMR)) cycle IWDL = JUST(LRK,LRI) IWDR = JUST(LRJ,LRK) !call PRODAB(3,JPEL,IWDL,IWDR,JWL,JWR,WL,JPER) @@ -1204,7 +1204,7 @@ subroutine TTS_HEAD_DBL_TAIL_ACT_G(LRA) use gugaci_global, only: jml, jmr, jpel, jper, just, jwl, jwr, line, lrs, lsm_inn, norb_dz, norb_frz, w1, w1_t1s -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1225,7 +1225,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) W1T1S1 = W1_T1S(1) W1T1S2 = W1_T1S(2) W1T1S3 = W1_T1S(3) @@ -1280,7 +1280,7 @@ do LRK=NORB_FRZ+1,LRI-1 LMK = LSM_INN(LRK) ! T1S(5-2) (11)Ar(13)-Bl(32)- - if ((JML /= MUL_TAB(LMK,LMI)) .or. (JMR /= MUL_TAB(LMK,LMJ))) cycle + if ((JML /= Mul(LMK,LMI)) .or. (JMR /= Mul(LMK,LMJ))) cycle !VLOP1 = W1*W1T1S2 !WL = -VLOP1*VINT_CI(LIST) IWDL = JUST(LRK,LRI) @@ -1294,7 +1294,7 @@ do LRK=LRI+1,LRJ-1 LMK = LSM_INN(LRK) ! T1S(5-2) Ar(13)-C'(11)-Bl(32)- - if ((JML /= MUL_TAB(LMI,LMK)) .or. (JMR /= MUL_TAB(LMK,LMJ))) cycle + if ((JML /= Mul(LMI,LMK)) .or. (JMR /= Mul(LMK,LMJ))) cycle !VLOP1 = W1*W1T1S2 !WL = -VLOP1*VINT_CI(LIST) IWDL = JUST(LRI,LRK) @@ -1319,7 +1319,7 @@ do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) ! T1S(5-3) Ar(13)-Bl(31)-C"(12)- - if ((JML /= MUL_TAB(LMI,LMK)) .or. (JMR /= MUL_TAB(LMJ,LMK))) cycle + if ((JML /= Mul(LMI,LMK)) .or. (JMR /= Mul(LMJ,LMK))) cycle !VLOP1 = W1*W1T1S3 !WL = -VLOP1*VINT_CI(LIST) IWDL = JUST(LRI,LRK) @@ -1345,7 +1345,7 @@ do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) ! T1S(5-4) Ar(13)-Bl(32)-C"(11)- - if ((JML /= MUL_TAB(LMI,LMK)) .or. (JMR /= MUL_TAB(LMJ,LMK))) cycle + if ((JML /= Mul(LMI,LMK)) .or. (JMR /= Mul(LMJ,LMK))) cycle IWDL = JUST(LRI,LRK) IWDR = JUST(LRJ,LRK) !call PRODAB(3,JPEL,IWDL,IWDR,JWL,JWR,WL,JPER) @@ -1426,7 +1426,7 @@ use gugaci_global, only: jml, jmr, jpad, jpadl, jpel, jper, just, jwl, jwr, line, lrs, lsm_inn, norb_dz, norb_frz, w0, w0_tt, w1, & w1_tt -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1447,8 +1447,8 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) - JMLR = MUL_TAB(JML,JMR) + LMIJ = Mul(LMI,LMJ) + JMLR = Mul(JML,JMR) if (LMIJ /= JMLR) cycle W0TT1 = W0_TT(1) W1TT1 = W1_TT(1) @@ -1473,8 +1473,8 @@ ! TT(11-1) (22)Ar(23)-Bl(32)- do LRK=NORB_FRZ+1,LRI-1 LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) - LMKJ = MUL_TAB(LMK,LMJ) + LMKI = Mul(LMK,LMI) + LMKJ = Mul(LMK,LMJ) if ((LMKI == JML) .and. (LMKJ == JMR)) then IWDL = JUST(LRK,LRI) IWDR = JUST(LRK,LRJ) @@ -1488,8 +1488,8 @@ ! TT(11-1) Ar(23)-Bl(32)-C"(22)- ACT -C"- do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) - LMKJ = MUL_TAB(LMK,LMJ) + LMKI = Mul(LMK,LMI) + LMKJ = Mul(LMK,LMJ) if ((LMKI == JML) .and. (LMKJ == JMR)) then IWDL = JUST(LRI,LRK) IWDR = JUST(LRJ,LRK) @@ -1503,8 +1503,8 @@ ! TT(11-1) Ar(23)-C'(22)-Bl(32)- ACT -C"- do LRK=LRI+1,LRJ-1 LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) - LMKJ = MUL_TAB(LMK,LMJ) + LMKI = Mul(LMK,LMI) + LMKJ = Mul(LMK,LMJ) if ((LMKI == JML) .and. (LMKJ == JMR)) then IWDL = JUST(LRI,LRK) IWDR = JUST(LRK,LRJ) @@ -1529,7 +1529,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((LMIJ /= JML) .or. (LMIJ /= JMR)) cycle if (JWL >= JWR) cycle ! TT(11-2) (22)Drl(22)- @@ -1602,7 +1602,7 @@ use gugaci_global, only: jml, jmr, jpad, jpadl, jpel, jper, just, jwl, jwr, line, lrs, lsm_inn, norb_dz, norb_frz, w0, w0_t1t1, & w1, w1_t1t1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1641,7 +1641,7 @@ ! T1T1(12-1) (11)Ar(13)-Bl(31)- do LRM=NORB_FRZ+1,LRI-1 LMM = LSM_INN(LRM) - if ((JML /= MUL_TAB(LMI,LMM)) .or. (JMR /= MUL_TAB(LMM,LMJ))) cycle + if ((JML /= Mul(LMI,LMM)) .or. (JMR /= Mul(LMM,LMJ))) cycle IWDL = JUST(LRM,LRI) IWDR = JUST(LRM,LRJ) !call PRODAB(3,JPEL,IWDL,IWDR,JWL,JWR,WL,JPER) @@ -1653,7 +1653,7 @@ ! T1T1(12-1) Ar(13)-Bl(31)-C"(11)- do LRM=LRJ+1,NORB_DZ LMM = LSM_INN(LRM) - if ((JML /= MUL_TAB(LMI,LMM)) .or. (JMR /= MUL_TAB(LMM,LMJ))) cycle + if ((JML /= Mul(LMI,LMM)) .or. (JMR /= Mul(LMM,LMJ))) cycle IWDL = JUST(LRI,LRM) IWDR = JUST(LRJ,LRM) !call PRODAB(3,JPEL,IWDL,IWDR,JWL,JWR,WL,JPER) @@ -1665,7 +1665,7 @@ ! T1T1(12-1) Ar(13)-C'(11)-Bl(31)- do LRM=LRI+1,LRJ-1 LMM = LSM_INN(LRM) - if ((JML /= MUL_TAB(LMI,LMM)) .or. (JMR /= MUL_TAB(LMM,LMJ))) cycle + if ((JML /= Mul(LMI,LMM)) .or. (JMR /= Mul(LMM,LMJ))) cycle IWDL = JUST(LRI,LRM) IWDR = JUST(LRM,LRJ) !call PRODAB(3,JPEL,IWDL,IWDR,JWL,JWR,-WL,JPER) @@ -1684,7 +1684,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ !BBS_TMP LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (JML /= LMIJ) cycle VLOP0 = W0*W0_T1T1(2) VLOP1 = W1*W1_T1T1(2) @@ -2080,7 +2080,7 @@ subroutine SV_HEAD_DBL_TAIL_ACT_G(LRA) use gugaci_global, only: jb_sys, jml, jpel, jper, just, jwl, jwr, line, lrs, lsm_inn, norb_dz, norb_frz, w0, w0_sv, w1, w1_sv -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -2097,7 +2097,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (LMIJ /= JML) cycle W0SV1 = W0_SV(1) W1SV1 = W1_SV(1) @@ -2177,7 +2177,7 @@ use gugaci_global, only: jb_sys, jml, jmr, jpel, jper, jud, just, jwl, jwr, lsm_inn, norb_dz, norb_frz, norb_inn, w0, w0_sd, w1, & w1_sd -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2186,7 +2186,7 @@ real(kind=wp) :: tcoe, vlop0, vlop1, w0sd1, w0sd11, w0sd12, w0sd14, w0sd15, w0sd16, w0sd2, w0sd3, w0sd4, w0sd5, w0sd6, w0sd7, & w0sd8, w0sd9, w1sd10, w1sd11, w1sd2, w1sd5, w1sd6, w1sd7, w1sd8, wl -JMLR = MUL_TAB(JML,JMR) +JMLR = Mul(JML,JMR) ! SD(6-1) A&r(02)- ! SD(6-2) C(22)A&r(13)- ! SD(6-4) A&r(23)C'(12)- @@ -2288,7 +2288,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (LMIJ /= JML) cycle W0SD2 = W0_SD(2) W1SD2 = W1_SD(2) @@ -2631,7 +2631,7 @@ use gugaci_global, only: jb_sys, jml, jmr, jpel, jper, jud, just, jwl, jwr, lsm_inn, norb_dz, norb_frz, norb_inn, w0, w0_sd1, w1, & w1_sd1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2640,7 +2640,7 @@ real(kind=wp) :: tcoe, vlop0, vlop1, w0sd1, w0sd10, w0sd11, w0sd12, w0sd13, w0sd2, w0sd3, w0sd4, w0sd5, w0sd6, w0sd7, w0sd8, & w0sd9, w1sd10, w1sd2, w1sd3, w1sd4, w1sd5, w1sd6, w1sd7, w1sd8, wl -JMLR = MUL_TAB(JML,JMR) +JMLR = Mul(JML,JMR) ! SD1(8-1) A&r(01)- ! SD1(8-2) C(11)A&r(23)- ! SD1(8-3) A&r(13)C'(21)- @@ -2741,7 +2741,7 @@ do LRJ=LRI+1,NORB_DZ if (LRI == LRJ) cycle LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (LMIJ /= JML) cycle W0SD2 = W0_SD1(2) W1SD2 = W1_SD1(2) @@ -3071,7 +3071,7 @@ !!********************************************** ! !use gugaci_global, only: jml, jmr, jpel, jper, jud, just, jwl, jwr, lsm_inn, norb_dz, norb_frz, norb_inn, w0, w0_td, w1, w1_td -!use Symmetry_Info, only: mul_tab => Mul +!use Symmetry_Info, only: Mul !use Definitions, only: wp, iwp ! !implicit none @@ -3079,7 +3079,7 @@ !integer(kind=iwp) :: iwdl, iwdr, jmlr, kcoe, lmd, lmi, lmij, lmj, lr, lrd, lri, lrj, lrk, ni, nocc, nxo !real(kind=wp) :: tcoe, vlop0, vlop1, w0td1, w0td2, w0td3, w0td4, w0td5, w1td2, w1td3, wl ! -!JMLR = MUL_TAB(JML,JMR) +!JMLR = Mul(JML,JMR) !! TD(13-1) (22)A&(23) !! TD(13-1) A&(23)C'(22) !! TD(13-5) (22)D&&l(33)B^l(23) @@ -3226,7 +3226,7 @@ ! LMI = LSM_INN(LRI) ! do LRJ=LRI+1,NORB_DZ ! LMJ = LSM_INN(LRJ) -! LMIJ = MUL_TAB(LMI,LMJ) +! LMIJ = Mul(LMI,LMJ) ! if (LMIJ /= JML) cycle ! IWDL = JUST(LRI,LRJ) ! @@ -3290,7 +3290,7 @@ !********************************************** use gugaci_global, only: jml, jmr, jpel, jper, jud, just, jwl, jwr, lsm_inn, norb_dz, norb_frz, norb_inn, w0, w0_t1d1, w1, w1_t1d1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -3298,7 +3298,7 @@ integer(kind=iwp) :: iwdl, iwdr, jmlr, kcoe, lmd, lmi, lmij, lmj, lr, lrd, lri, lrj, lrk, ni, nocc, nxo real(kind=wp) :: tcoe, vlop0, vlop1, w0td1, w0td2, w0td3, w0td4, w0td5, w1td2, w1td3, wl -JMLR = MUL_TAB(JML,JMR) +JMLR = Mul(JML,JMR) ! T1D1(15-1) (11)A&(13) ! T1D1(15-1) A&(13)C'(11) ! T1D1(15-5) (11)D&&l(33)B^l(13) @@ -3448,7 +3448,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (LMIJ /= JML) cycle IWDL = JUST(LRI,LRJ) diff -Nru openmolcas-22.02/src/gugaci/dblploop2.F90 openmolcas-22.10/src/gugaci/dblploop2.F90 --- openmolcas-22.02/src/gugaci/dblploop2.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/dblploop2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -19,7 +19,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_ss, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: iwp @@ -33,7 +33,7 @@ do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) ! SS(1-16) (11)-Drl(22)- - if ((JML /= MUL_TAB(LMI,LMJ)) .or. (JMR /= MUL_TAB(LMI,LMJ))) cycle + if ((JML /= Mul(LMI,LMJ)) .or. (JMR /= Mul(LMI,LMJ))) cycle IWDL = JUST(LRJ,LRI) IWDR = IWDL do MPL=1,MHLP @@ -105,7 +105,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, & vplpnew_w1, w0_ss, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -115,13 +115,13 @@ w1ss7, w1ss8, w1ss9 integer(kind=iwp), external :: iwalk_ad -JMLR = MUL_TAB(JML,JMR) -ISMA = MUL_TAB(IML,IMR) +JMLR = Mul(JML,JMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (LMIJ /= JMLR) cycle IJK = LRI-NORB_FRZ+NGW2(LRJ-NORB_FRZ)+NGW3(LRA-NORB_FRZ) intpos = INTIND_IJKA(IJK) @@ -201,7 +201,7 @@ ! SS(1-6) (11)-Ar(23)-Bl(32)- do LRK=NORB_FRZ+1,LRI-1 LMK = LSM_INN(LRK) - if (MUL_TAB(LMK,LMI) /= JML) cycle + if (Mul(LMK,LMI) /= JML) cycle IWDL = JUST(LRI,LRK) IWDR = JUST(LRJ,LRK) do MPL=1,MTYPE @@ -220,7 +220,7 @@ ! SS(1-7) Ar(13)-C'(21)-Bl(32)- do LRK=LRI+1,LRJ-1 LMK = LSM_INN(LRK) - if (MUL_TAB(LMK,LMI) /= JML) cycle + if (Mul(LMK,LMI) /= JML) cycle IWDL = JUST(LRK,LRI) IWDR = JUST(LRJ,LRK) do MPL=1,MTYPE @@ -267,7 +267,7 @@ ! SS(1-11) Ar(13)-Bl(31)-C"(22)- do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - if (MUL_TAB(LMK,LMI) /= JML) cycle + if (Mul(LMK,LMI) /= JML) cycle IWDL = JUST(LRK,LRI) IWDR = JUST(LRK,LRJ) do MPL=1,MTYPE @@ -326,7 +326,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_st -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -336,13 +336,13 @@ real(kind=wp) :: w1st3 integer(kind=iwp), external :: iwalk_ad -JMLR = MUL_TAB(JML,JMR) -ISMA = MUL_TAB(IML,IMR) +JMLR = Mul(JML,JMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (LMIJ /= JMLR) cycle W1ST3 = W1_ST(3) @@ -355,7 +355,7 @@ ! ST(2-3) Ar(13)-C'(22)-Bl(32)- do LRK=LRI+1,LRJ-1 LMK = LSM_INN(LRK) - if (MUL_TAB(LMK,LMI) /= JML) cycle + if (Mul(LMK,LMI) /= JML) cycle IWDL = JUST(LRK,LRI) IWDR = JUST(LRK,LRJ) do MPL=1,MTYPE @@ -373,7 +373,7 @@ ! ST(2-3) Ar(13)-Bl(32)-C'(22)- do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - if (MUL_TAB(LMK,LMI) /= JML) cycle + if (Mul(LMK,LMI) /= JML) cycle IWDL = JUST(LRK,LRI) IWDR = JUST(LRJ,LRK) do MPL=1,MTYPE @@ -400,7 +400,7 @@ use gugaci_global, only: ipae, ipael, jml, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_st -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: iwp @@ -413,7 +413,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (LMIJ /= JML) cycle !------------------------------------------------------------------- ! ST(2-7) Drl(12)-C"(22)- @@ -444,7 +444,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_ts -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -454,13 +454,13 @@ real(kind=wp) :: w1ts3 integer(kind=iwp), external :: iwalk_ad -JMLR = MUL_TAB(JML,JMR) -ISMA = MUL_TAB(IML,IMR) +JMLR = Mul(JML,JMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (LMIJ /= JMLR) cycle IJK = LRI-NORB_FRZ+NGW2(LRJ-NORB_FRZ)+NGW3(LRA-NORB_FRZ) intpos = INTIND_IJKA(IJK) @@ -477,7 +477,7 @@ end do do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - if (MUL_TAB(LMK,LMI) /= JML) cycle + if (Mul(LMK,LMI) /= JML) cycle IWDL = JUST(LRI,LRK) IWDR = JUST(LRK,LRJ) do MPL=1,MHLP @@ -507,7 +507,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_st1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -517,12 +517,12 @@ real(kind=wp) :: w1st1, w1st2, w1st3, w1st4 integer(kind=iwp), external :: iwalk_ad -ISMA = MUL_TAB(IML,IMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) W1ST1 = W1_ST1(1) W1ST2 = W1_ST1(2) W1ST3 = W1_ST1(3) @@ -555,7 +555,7 @@ ! ST1(4-2) (11)Ar(23)-Bl(31)- do LRK=NORB_FRZ+1,LRI-1 LMK = LSM_INN(LRK) - if ((JML == MUL_TAB(LMK,LMI)) .and. (JMR == MUL_TAB(LMK,LMJ))) then + if ((JML == Mul(LMK,LMI)) .and. (JMR == Mul(LMK,LMJ))) then IWDL = JUST(LRI,LRK) IWDR = JUST(LRK,LRJ) do MPL=1,MHLP @@ -574,7 +574,7 @@ ! ST1(4-3) Ar(13)-C'(21)-Bl(31)- do LRK=LRI+1,LRJ-1 LMK = LSM_INN(LRK) - if ((JML == MUL_TAB(LMI,LMK)) .and. (JMR == MUL_TAB(LMK,LMJ))) then + if ((JML == Mul(LMI,LMK)) .and. (JMR == Mul(LMK,LMJ))) then IWDL = JUST(LRK,LRI) IWDR = JUST(LRK,LRJ) do MPL=1,MHLP @@ -607,7 +607,7 @@ ! ST1(4-3) Ar(13)-Bl(31)-C"(21)- do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - if ((JML == MUL_TAB(LMI,LMK)) .and. (JMR == MUL_TAB(LMJ,LMK))) then + if ((JML == Mul(LMI,LMK)) .and. (JMR == Mul(LMJ,LMK))) then IWDL = JUST(LRK,LRI) IWDR = JUST(LRJ,LRK) do MPL=1,MHLP @@ -655,7 +655,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_t1s -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -665,12 +665,12 @@ real(kind=wp) :: w1ts1, w1ts2, w1ts3, w1ts4 integer(kind=iwp), external :: iwalk_ad -ISMA = MUL_TAB(IML,IMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) W1TS1 = W1_T1S(1) W1TS2 = W1_T1S(2) W1TS3 = W1_T1S(3) @@ -702,7 +702,7 @@ ! T1S(5-2) (11)Ar(13)-Bl(32)- do LRK=NORB_FRZ+1,LRI-1 LMK = LSM_INN(LRK) - if ((JML == MUL_TAB(LMK,LMI)) .and. (JMR == MUL_TAB(LMK,LMJ))) then + if ((JML == Mul(LMK,LMI)) .and. (JMR == Mul(LMK,LMJ))) then IWDL = JUST(LRK,LRI) IWDR = JUST(LRJ,LRK) do MPL=1,MHLP @@ -721,7 +721,7 @@ ! T1S(5-2) Ar(13)-C'(11)-Bl(32)- do LRK=LRI+1,LRJ-1 LMK = LSM_INN(LRK) - if ((JML == MUL_TAB(LMI,LMK)) .and. (JMR == MUL_TAB(LMK,LMJ))) then + if ((JML == Mul(LMI,LMK)) .and. (JMR == Mul(LMK,LMJ))) then IWDL = JUST(LRI,LRK) IWDR = JUST(LRJ,LRK) do MPL=1,MHLP @@ -740,7 +740,7 @@ ! T1S(5-3) Ar(13)-Bl(31)-C"(12)- do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - if ((JML == MUL_TAB(LMI,LMK)) .and. (JMR == MUL_TAB(LMJ,LMK))) then + if ((JML == Mul(LMI,LMK)) .and. (JMR == Mul(LMJ,LMK))) then IWDL = JUST(LRI,LRK) IWDR = JUST(LRK,LRJ) do MPL=1,MHLP @@ -784,7 +784,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_t1s -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: iwp @@ -797,7 +797,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - if ((JML /= MUL_TAB(LMI,LMJ)) .or. (JMR /= MUL_TAB(LMI,LMJ))) cycle + if ((JML /= Mul(LMI,LMJ)) .or. (JMR /= Mul(LMI,LMJ))) cycle ! T1S(5-5) (11)Drl(12)- IWDL = JUST(LRI,LRJ) IWDR = JUST(LRJ,LRI) @@ -854,7 +854,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, & vplpnew_w1, w0_sd1, w1_sd1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -863,12 +863,12 @@ real(kind=wp) :: w0sd5, w0sd6, w0sd7, w0sd8, w1sd5, w1sd6, w1sd7, w1sd8 integer(kind=iwp), external :: iwalk_ad -ISMA = MUL_TAB(IML,IMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) W0SD5 = W0_SD1(5) @@ -924,7 +924,7 @@ call Ar_Br_Br_EXT_AR_NEW(LIN,INTPOS,ISMA) end if ! SD1(8-7) Ar(13)-Bl(31)-BL(23)- - if ((JML == MUL_TAB(LMI,LMK)) .and. (JMR == LMJ)) then + if ((JML == Mul(LMI,LMK)) .and. (JMR == LMJ)) then IWDL = JUST(LRK,LRI) IWDR = JUD(LRJ) do MPL=1,MHLP @@ -971,7 +971,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, & mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sd1, w1_sd1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1031,7 +1031,7 @@ W1SD13 = -W1SD13 end if ! SD1(8-10) Drl(11)-BL(23)- - if ((JML == MUL_TAB(LMI,LMJ)) .and. (JMR == LMI)) then + if ((JML == Mul(LMI,LMJ)) .and. (JMR == LMI)) then IWDL = JUST(LRJ,LRI) IWDR = JUD(LRI) do MPL=1,MHLP @@ -1049,7 +1049,7 @@ do LRK=1,LRI-1 LMK = LSM_INN(LRK) ! SD1(8-12) Drl(33)-BL(13)-C'(21)- - if ((JML == MUL_TAB(LMI,LMJ)) .and. (JMR == LMJ)) then + if ((JML == Mul(LMI,LMJ)) .and. (JMR == LMJ)) then IWDL = JUST(LRJ,LRI) IWDR = JUD(LRJ) do MPL=1,MHLP @@ -1078,7 +1078,7 @@ end do call Drl_BL_EXT_AR_NEW(LIN,LRK,LRI) end if - if ((JML == MUL_TAB(LMI,LMJ)) .and. (JMR == LMI)) then + if ((JML == Mul(LMI,LMJ)) .and. (JMR == LMI)) then ! SD1(8-11) Drl(33)-C"(11)-BL(23)- do MPL=1,MTYPE VPLP_W0(MPL) = VPLPNEW_W0(MPL)*W0SD11 @@ -1098,7 +1098,7 @@ do LRK=NORB_FRZ+1,LRI-1 LMK = LSM_INN(LRK) ! SD1(8-11) (11)Drl(33)-BL(23)- - if ((JML == MUL_TAB(LMK,LMJ)) .and. (JMR == LMK)) then + if ((JML == Mul(LMK,LMJ)) .and. (JMR == LMK)) then IWDL = JUST(LRJ,LRK) IWDR = JUD(LRK) do MPL=1,MHLP @@ -1170,7 +1170,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sd1, & w1_sd1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1179,7 +1179,7 @@ real(kind=wp) :: w0sd1, w0sd2, w0sd3, w0sd4, w1sd1, w1sd2, w1sd3, w1sd4 integer(kind=iwp), external :: iwalk_ad -ISMA = MUL_TAB(IML,IMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) W0SD1 = W0_SD1(1) @@ -1221,7 +1221,7 @@ end if do LRJ=NORB_FRZ+1,LRI-1 LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (JML /= LMIJ) cycle if (JMR == LMJ) then ! SD1(8-2) (11)Ar(23)- @@ -1245,7 +1245,7 @@ ! SD1(8-3) Ar(13)-C'(21)- do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (JML /= LMIJ) cycle if (JMR == LMJ) then IWDL = JUST(LRJ,LRI) @@ -1296,7 +1296,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sd1, & w1_sd1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1305,7 +1305,7 @@ real(kind=wp) :: w0sd1, w0sd2, w0sd3, w0sd4, w1sd1, w1sd2, w1sd3, w1sd4 integer(kind=iwp), external :: iwalk_ad -ISMA = MUL_TAB(IML,IMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) W0SD1 = W0_SD1(1) @@ -1347,7 +1347,7 @@ end if do LRJ=NORB_FRZ+1,LRI-1 LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (JML /= LMIJ) cycle if (JMR == LMJ) then ! SD1(8-2) (11)Ar(23)- @@ -1371,7 +1371,7 @@ ! SD1(8-3) Ar(13)-C'(21)- do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (JML /= LMIJ) cycle if (JMR == LMJ) then IWDL = JUST(LRJ,LRI) @@ -1419,7 +1419,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_d1s -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1429,7 +1429,7 @@ real(kind=wp) :: w1ds2, w1ds3 integer(kind=iwp), external :: iwalk_ad -ISMA = MUL_TAB(IML,IMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ @@ -1446,7 +1446,7 @@ IJK = LRI-NORB_FRZ+NGW2(LRJ-NORB_FRZ)+NGW3(LRK-NORB_FRZ) INTPOS = INTIND_IJKA(IJK) ! D1S(9-2) Ar(13)-Bl(31)-BR(32)- - if ((JML == LMI) .and. (JMR == MUL_TAB(LMJ,LMK))) then + if ((JML == LMI) .and. (JMR == Mul(LMJ,LMK))) then IWDL = JUD(LRI) IWDR = JUST(LRK,LRJ) do MPL=1,MHLP @@ -1492,7 +1492,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_t1t1, w1_t1t1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -1505,7 +1505,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (JML /= LMIJ) cycle ! T1T1(12-2) (11)Drl(11)- ! T1T1(12-2) Drl(11)-C"(11)- @@ -1554,7 +1554,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, & vplpnew_w1, w0_t1t1, w1_t1t1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1563,7 +1563,7 @@ real(kind=wp) :: w0tt1, w1tt1 integer(kind=iwp), external :: iwalk_ad -ISMA = MUL_TAB(IML,IMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ @@ -1577,7 +1577,7 @@ do LRK=NORB_FRZ+1,LRI-1 LMK = LSM_INN(LRK) ! T1T1(12-1) (11)Ar(13)-Bl(31)- - if ((JML == MUL_TAB(LMK,LMI)) .and. (JMR == MUL_TAB(LMK,LMJ))) then + if ((JML == Mul(LMK,LMI)) .and. (JMR == Mul(LMK,LMJ))) then IWDL = JUST(LRK,LRI) IWDR = JUST(LRK,LRJ) IJK = LRI-NORB_FRZ+NGW2(LRJ-NORB_FRZ)+NGW3(LRA-NORB_FRZ) @@ -1597,7 +1597,7 @@ end do do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - if ((JML == MUL_TAB(LMI,LMk)) .and. (JMR == MUL_TAB(LMJ,LMK))) then + if ((JML == Mul(LMI,LMk)) .and. (JMR == Mul(LMJ,LMK))) then ! T1T1(12-1) Ar(13)-Bl(31)-C"(11)- IWDL = JUST(LRI,LRK) IWDR = JUST(LRJ,LRK) @@ -1618,7 +1618,7 @@ end do do LRK=LRI+1,LRJ-1 LMK = LSM_INN(LRK) - if ((JML == MUL_TAB(LMI,LMK)) .and. (JMR == MUL_TAB(LMK,LMJ))) then + if ((JML == Mul(LMI,LMK)) .and. (JMR == Mul(LMK,LMJ))) then ! T1T1(12-1) Ar(13)-C'(11)-Bl(31)- IJK = LRI-NORB_FRZ+NGW2(LRJ-NORB_FRZ)+NGW3(LRA-NORB_FRZ) INTPOS = INTIND_IJKA(IJK) @@ -1652,7 +1652,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, & mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_t1d1, w1_t1d1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1665,7 +1665,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - if ((JML == MUL_TAB(LMI,LMJ)) .and. (JMR == LMI)) then + if ((JML == Mul(LMI,LMJ)) .and. (JMR == LMI)) then IWDL = JUST(LRI,LRJ) IWDR = JUD(LRI) W0TD4 = W0_T1D1(4) @@ -1723,7 +1723,7 @@ W0TD5 = -W0TD5 W1TD5 = -W1TD5 end if - if ((JML == MUL_TAB(LMI,LMJ)) .and. (JMR == LMJ)) then + if ((JML == Mul(LMI,LMJ)) .and. (JMR == LMJ)) then do MPL=1,MTYPE VPLP_W0(MPL) = VPLPNEW_W0(MPL)*W0TD5 VPLP_W1(MPL) = VPLPNEW_W1(MPL)*W1TD5 @@ -1755,7 +1755,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, & vplpnew_w1, w0_t1d1, w1_t1d1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1765,7 +1765,7 @@ real(kind=wp) :: w0td3, w1td2, w1td3 integer(kind=iwp), external :: iwalk_ad -ISMA = MUL_TAB(IML,IMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ @@ -1783,7 +1783,7 @@ end if IJK = LRI-NORB_FRZ+NGW2(LRJ-NORB_FRZ)+NGW3(LRK-NORB_FRZ) INTPOS = INTIND_IJKA(IJK) - if ((JML == MUL_TAB(LMI,LMJ)) .and. (JMR == LMK)) then + if ((JML == Mul(LMI,LMJ)) .and. (JMR == LMK)) then ! T1D1(15-2) Ar(13)-Br(13)-BR(31)- IWDL = JUST(LRI,LRJ) IWDR = JUD(LRK) @@ -1799,7 +1799,7 @@ end do call Ar_Br_BR_EXT_AR_NEW(LIN,INTPOS,ISMA) end if - if ((JML == MUL_TAB(LMI,LMK)) .and. (JMR == LMJ)) then + if ((JML == Mul(LMI,LMK)) .and. (JMR == LMJ)) then ! T1D1(15-3) Ar(13)-Bl(31)-Bl(13)- IWDL = JUST(LRI,LRK) IWDR = JUD(LRJ) @@ -1830,7 +1830,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_t1d1, & w1_t1d1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1839,7 +1839,7 @@ real(kind=wp) :: w0td1, w1td1 integer(kind=iwp), external :: iwalk_ad -ISMA = MUL_TAB(IML,IMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) W0TD1 = W0_T1D1(1) @@ -1851,7 +1851,7 @@ do LRJ=NORB_FRZ+1,LRI-1 ! T1D1(15-1) (11)Ar(13)- LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((JML == LMIJ) .and. (JMR == LMJ)) then IWDL = JUST(LRJ,LRI) IWDR = JUD(LRJ) @@ -1872,7 +1872,7 @@ end do do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) ! T1D1(15-1) Ar(13)-C'(11)- if ((JML == LMIJ) .and. (JMR == LMJ)) then IWDL = JUST(LRI,LRJ) @@ -1905,7 +1905,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_t1d1, & w1_t1d1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1914,7 +1914,7 @@ real(kind=wp) :: w0td1, w1td1 integer(kind=iwp), external :: iwalk_ad -ISMA = MUL_TAB(IML,IMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) W0TD1 = W0_T1D1(1) @@ -1926,7 +1926,7 @@ do LRJ=NORB_FRZ+1,LRI-1 ! T1D1(15-1) (11)Ar(13)- LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((JML == LMIJ) .and. (JMR == LMJ)) then IWDL = JUST(LRJ,LRI) IWDR = JUD(LRJ) @@ -1948,7 +1948,7 @@ do LRJ=LRI+1,NORB_DZ ! T1D1(15-1) Ar(13)-C'(11)- LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((JML == LMIJ) .and. (JMR == LMJ)) then IWDL = JUST(LRI,LRJ) IWDR = JUD(LRJ) @@ -1978,7 +1978,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_t1v -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1988,12 +1988,12 @@ real(kind=wp) :: w1tv1 integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((JML /= LMIJ) .or. (JMR /= 1)) cycle W1TV1 = W1_T1V if (mod(LRJ-LRI,2) == 0) W1TV1 = -W1TV1 @@ -2025,7 +2025,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, & lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_d1d1, & w1_d1d1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2034,7 +2034,7 @@ real(kind=wp) :: w0dd1, w1dd1 integer(kind=iwp), external :: iwalk_ad -ISMA = MUL_TAB(IML,IMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ @@ -2121,7 +2121,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, & lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_dd1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -2131,7 +2131,7 @@ real(kind=wp) :: w1dd1 integer(kind=iwp), external :: iwalk_ad -ISMA = MUL_TAB(IML,IMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ @@ -2168,7 +2168,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, & lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_d1d -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -2178,7 +2178,7 @@ real(kind=wp) :: w1dd1 integer(kind=iwp), external :: iwalk_ad -ISMA = MUL_TAB(IML,IMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ @@ -2253,7 +2253,7 @@ use gugaci_global, only: iml, imr, ipae, ipael, jml, jmr, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, & mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_d1v -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -2263,7 +2263,7 @@ real(kind=wp) :: w0 integer(kind=iwp), external :: iwalk_ad -ISMA = MUL_TAB(IML,IMR) +ISMA = Mul(IML,IMR) if (JMR /= 1) return do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) @@ -2306,7 +2306,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, & lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_d1v, w1_d1v -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2315,7 +2315,7 @@ real(kind=wp) :: w0dv1, w1dv1 integer(kind=iwp), external :: iwalk_ad -ISMA = MUL_TAB(IML,IMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) if ((JML /= LMI) .or. (JMR /= 1)) cycle @@ -2351,7 +2351,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, & lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_d1v, w1_d1v -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2360,7 +2360,7 @@ real(kind=wp) :: w0dv1, w1dv1 integer(kind=iwp), external :: iwalk_ad -ISMA = MUL_TAB(IML,IMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) if ((JML /= LMI) .or. (JMR /= 1)) cycle @@ -2404,7 +2404,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_ss, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -2417,7 +2417,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (LMIJ /= JML) cycle ! SS(1-16) (11)-Drl(22)- IWDL = JUST(LRJ,LRI) @@ -2467,7 +2467,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_ss, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -2480,7 +2480,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (LMIJ /= JML) cycle ! SS(1-19) Drl(12)-C"(21)- IWDL = JUST(LRJ,LRI) @@ -2508,7 +2508,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_ss, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -2521,7 +2521,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (LMIJ /= JML) cycle ! SS(1-19) Drl(12)-C"(21)- IWDL = JUST(LRJ,LRI) @@ -2560,7 +2560,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, & vplpnew_w1, w0_ss, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2570,13 +2570,13 @@ w1ss7, w1ss8, w1ss9 integer(kind=iwp), external :: iwalk_ad -JMLR = MUL_TAB(JML,JMR) -ISMA = MUL_TAB(IML,IMR) +JMLR = Mul(JML,JMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (LMIJ /= JMLR) cycle IJK = LRI-NORB_FRZ+NGW2(LRJ-NORB_FRZ)+NGW3(LRA-NORB_FRZ) intpos = INTIND_IJKA(IJK) @@ -2657,7 +2657,7 @@ ! SS(1-6) (11)-Ar(23)-Bl(32)- do LRK=NORB_FRZ+1,LRI-1 LMK = LSM_INN(LRK) - if (MUL_TAB(LMK,LMI) /= JML) cycle + if (Mul(LMK,LMI) /= JML) cycle IWDL = JUST(LRI,LRK) IWDR = JUST(LRJ,LRK) do MPL=1,MTYPE @@ -2675,7 +2675,7 @@ !------------------------------------------------------------------- do LRK=LRI+1,LRJ-1 LMK = LSM_INN(LRK) - if (MUL_TAB(LMK,LMI) /= JML) cycle + if (Mul(LMK,LMI) /= JML) cycle ! SS(1-7) Ar(13)-C'(21)-Bl(32)- IWDL = JUST(LRK,LRI) IWDR = JUST(LRJ,LRK) @@ -2722,7 +2722,7 @@ !------------------------------------------------------------------- do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - if (MUL_TAB(LMK,LMI) /= JML) cycle + if (Mul(LMK,LMI) /= JML) cycle ! SS(1-11) Ar(13)-Bl(31)-C"(22)- IWDL = JUST(LRK,LRI) IWDR = JUST(LRK,LRJ) @@ -2780,7 +2780,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_st -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -2790,13 +2790,13 @@ real(kind=wp) :: w1st3 integer(kind=iwp), external :: iwalk_ad -JMLR = MUL_TAB(JML,JMR) -ISMA = MUL_TAB(IML,IMR) +JMLR = Mul(JML,JMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (LMIJ /= JMLR) cycle W1ST3 = W1_ST(3) @@ -2810,7 +2810,7 @@ ! ST(2-3) Ar(13)-C'(22)-Bl(32)- do LRK=LRI+1,LRJ-1 LMK = LSM_INN(LRK) - if (MUL_TAB(LMK,LMI) /= JML) cycle + if (Mul(LMK,LMI) /= JML) cycle IWDL = JUST(LRK,LRI) IWDR = JUST(LRK,LRJ) do MPL=1,MTYPE @@ -2829,7 +2829,7 @@ ! ST(2-3) Ar(13)-Bl(32)-C'(22)- do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - if (MUL_TAB(LMK,LMI) /= JML) cycle + if (Mul(LMK,LMI) /= JML) cycle IWDL = JUST(LRK,LRI) IWDR = JUST(LRJ,LRK) do MPL=1,MTYPE @@ -2856,7 +2856,7 @@ use gugaci_global, only: ipae, ipael, jml, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_st -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: iwp @@ -2869,7 +2869,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (LMIJ /= JML) cycle !------------------------------------------------------------------- ! ST(2-7) Drl(12)-C"(22)- @@ -2900,7 +2900,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_ts -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -2910,7 +2910,7 @@ real(kind=wp) :: w1ts3 integer(kind=iwp), external :: iwalk_ad -ISMA = MUL_TAB(IML,IMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ @@ -2931,8 +2931,8 @@ end do do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - LMIK = MUL_TAB(LMI,LMK) - LMJK = MUL_TAB(LMJ,LMK) + LMIK = Mul(LMI,LMK) + LMJK = Mul(LMJ,LMK) if ((LMIK /= JML) .or. (LMJK /= JMR)) cycle IWDL = JUST(LRI,LRK) IWDR = JUST(LRK,LRJ) @@ -2964,7 +2964,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_st1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -2974,12 +2974,12 @@ real(kind=wp) :: w1st1, w1st2, w1st3, w1st4 integer(kind=iwp), external :: iwalk_ad -ISMA = MUL_TAB(IML,IMR) +ISMA = Mul(IML,IMR) do LRI=NORB_FRZ+1,NORB_DZ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) W1ST1 = W1_ST1(1) W1ST2 = W1_ST1(2) W1ST3 = W1_ST1(3) @@ -3012,7 +3012,7 @@ ! ST1(4-2) (11)Ar(23)-Bl(31)- do LRK=NORB_FRZ+1,LRI-1 LMK = LSM_INN(LRK) - if ((JML == MUL_TAB(LMK,LMI)) .and. (JMR == MUL_TAB(LMK,LMJ))) then + if ((JML == Mul(LMK,LMI)) .and. (JMR == Mul(LMK,LMJ))) then IWDL = JUST(LRI,LRK) IWDR = JUST(LRK,LRJ) do MPL=1,MHLP @@ -3031,7 +3031,7 @@ ! ST1(4-3) Ar(13)-C'(21)-Bl(31)- do LRK=LRI+1,LRJ-1 LMK = LSM_INN(LRK) - if ((JML == MUL_TAB(LMI,LMK)) .and. (JMR == MUL_TAB(LMK,LMJ))) then + if ((JML == Mul(LMI,LMK)) .and. (JMR == Mul(LMK,LMJ))) then IWDL = JUST(LRK,LRI) IWDR = JUST(LRK,LRJ) do MPL=1,MHLP @@ -3064,7 +3064,7 @@ ! ST1(4-3) Ar(13)-Bl(31)-C"(21)- do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - if ((JML == MUL_TAB(LMI,LMK)) .and. (JMR == MUL_TAB(LMJ,LMK))) then + if ((JML == Mul(LMI,LMK)) .and. (JMR == Mul(LMJ,LMK))) then IWDL = JUST(LRK,LRI) IWDR = JUST(LRJ,LRK) do MPL=1,MHLP @@ -3108,7 +3108,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_t1s -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: iwp @@ -3121,7 +3121,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - if ((JML /= MUL_TAB(LMI,LMJ)) .or. (JMR /= MUL_TAB(LMI,LMJ))) cycle + if ((JML /= Mul(LMI,LMJ)) .or. (JMR /= Mul(LMI,LMJ))) cycle ! T1S(5-5) (11)Drl(12)- IWDL = JUST(LRI,LRJ) IWDR = JUST(LRJ,LRI) diff -Nru openmolcas-22.02/src/gugaci/dblploop3.F90 openmolcas-22.10/src/gugaci/dblploop3.F90 --- openmolcas-22.02/src/gugaci/dblploop3.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/dblploop3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -75,7 +75,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, & mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sd -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -84,7 +84,7 @@ real(kind=wp) :: w0sd3 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -141,7 +141,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_ss, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -156,7 +156,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) w0ss1 = w0_ss(1) w1ss1 = w1_ss(1) w0ss3 = w0_ss(3) @@ -235,8 +235,8 @@ end do do lrk=norb_frz+1,lri-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmi,lmk) - lmkj = mul_tab(lmj,lmk) + lmki = Mul(lmi,lmk) + lmkj = Mul(lmj,lmk) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lri,lrk) iwdr = just(lrj,lrk) @@ -256,8 +256,8 @@ end do do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmj,lmk) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmj,lmk) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lrk,lri) iwdr = just(lrj,lrk) @@ -277,8 +277,8 @@ end do do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lrk,lri) iwdr = just(lrk,lrj) @@ -298,8 +298,8 @@ end do do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lri,lrk) iwdr = just(lrj,lrk) @@ -319,8 +319,8 @@ end do do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lrk,lri) iwdr = just(lrk,lrj) @@ -340,8 +340,8 @@ end do do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmj,lmk) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmj,lmk) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lrk,lri) iwdr = just(lrj,lrk) @@ -361,8 +361,8 @@ end do do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - lmki = mul_tab(lmi,lmk) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmi,lmk) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lri,lrk) iwdr = just(lrk,lrj) @@ -397,7 +397,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_ss, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: iwp @@ -410,7 +410,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if ((lmij /= jml) .or. (lmij /= jmr)) cycle iwdl = just(lrj,lri) iwdr = iwdl @@ -461,7 +461,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_st -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: iwp @@ -475,7 +475,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (jml /= lmij) cycle iwdl = just(lrj,lri) iwdr = just(lri,lrj) @@ -509,7 +509,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_st -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -530,8 +530,8 @@ end if do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then ! st(2-3) ar(13)-c'(22)-bl(32)- iwdl = just(lrk,lri) @@ -552,8 +552,8 @@ do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then ! st(2-3) ar(13)-bl(32)-c'(22)- iwdl = just(lrk,lri) @@ -588,7 +588,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_st1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -613,7 +613,7 @@ w1st4 = -w1st4 end if ! st1(4-1) ar(01)-bl(31)- - if ((jml == 1) .and. (jmr == mul_tab(lmi,lmj))) then + if ((jml == 1) .and. (jmr == Mul(lmi,lmj))) then iwdl = just(lri,lri) iwdr = just(lri,lrj) do mpl=1,mhlp @@ -631,7 +631,7 @@ ! st1(4-2) (11)ar(23)-bl(31)- do lrk=norb_frz+1,lri-1 lmk = lsm_inn(lrk) - if ((jml /= mul_tab(lmk,lmi)) .or. (jmr /= mul_tab(lmk,lmj))) cycle + if ((jml /= Mul(lmk,lmi)) .or. (jmr /= Mul(lmk,lmj))) cycle iwdl = just(lri,lrk) iwdr = just(lrk,lrj) do mpl=1,mhlp @@ -649,7 +649,7 @@ ! st1(4-3) ar(13)-c'(21)-bl(31)- do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - if ((jml == mul_tab(lmi,lmk)) .and. (jmr == mul_tab(lmk,lmj))) then + if ((jml == Mul(lmi,lmk)) .and. (jmr == Mul(lmk,lmj))) then iwdl = just(lrk,lri) iwdr = just(lrk,lrj) do mpl=1,mhlp @@ -682,7 +682,7 @@ do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) ! st1(4-4) ar(23)-bl(31)-c"(11)- - if ((jml == mul_tab(lmi,lmk)) .and. (jmr == mul_tab(lmj,lmk))) then + if ((jml == Mul(lmi,lmk)) .and. (jmr == Mul(lmj,lmk))) then iwdl = just(lri,lrk) iwdr = just(lrj,lrk) do mpl=1,mhlp @@ -728,7 +728,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_t1s -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -753,7 +753,7 @@ w1ts4 = -w1ts4 end if ! t1s(5-1) ar(13)-bl(10)- - if ((jml == mul_tab(lmi,lmj)) .and. (jmr == 1)) then + if ((jml == Mul(lmi,lmj)) .and. (jmr == 1)) then iwdl = just(lri,lrj) iwdr = just(lrj,lrj) do mpl=1,mhlp @@ -775,7 +775,7 @@ end do do lrk=norb_frz+1,lri-1 lmk = lsm_inn(lrk) - if ((jml /= mul_tab(lmk,lmi)) .or. (jmr /= mul_tab(lmk,lmj))) cycle + if ((jml /= Mul(lmk,lmi)) .or. (jmr /= Mul(lmk,lmj))) cycle iwdl = just(lrk,lri) iwdr = just(lrj,lrk) do mpl=1,mhlp @@ -793,7 +793,7 @@ end do do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - if ((jml /= mul_tab(lmi,lmk)) .or. (jmr /= mul_tab(lmk,lmj))) cycle + if ((jml /= Mul(lmi,lmk)) .or. (jmr /= Mul(lmk,lmj))) cycle iwdl = just(lri,lrk) iwdr = just(lrj,lrk) do mpl=1,mhlp @@ -811,7 +811,7 @@ end do do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - if ((jml /= mul_tab(lmi,lmk)) .or. (jmr /= mul_tab(lmj,lmk))) cycle + if ((jml /= Mul(lmi,lmk)) .or. (jmr /= Mul(lmj,lmk))) cycle iwdl = just(lri,lrk) iwdr = just(lrk,lrj) do mpl=1,mhlp @@ -829,7 +829,7 @@ end do do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - if ((jml /= mul_tab(lmi,lmk)) .or. (jmr /= mul_tab(lmj,lmk))) cycle + if ((jml /= Mul(lmi,lmk)) .or. (jmr /= Mul(lmj,lmk))) cycle iwdl = just(lri,lrk) iwdr = just(lrj,lrk) do mpl=1,mhlp @@ -854,7 +854,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_t1s -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: iwp @@ -868,7 +868,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (jml /= lmij) cycle ! t1s(5-5) (11)drl(12)- iwdl = just(lri,lrj) @@ -927,7 +927,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, & mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sd1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -936,7 +936,7 @@ real(kind=wp) :: w0sd1, w0sd2, w0sd3, w0sd4 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -1047,7 +1047,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_t1t1, w1_t1t1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1074,8 +1074,8 @@ ! t1t1(12-1) (11)ar(13)-bl(31)- do lrk=norb_frz+1,lri-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lrk,lri) iwdr = just(lrk,lrj) @@ -1091,8 +1091,8 @@ ! t1t1(12-1) ar(13)-bl(31)-c"(11)- do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lri,lrk) iwdr = just(lrj,lrk) @@ -1112,8 +1112,8 @@ ! t1t1(12-1) ar(13)-c'(11)-bl(31)- do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lri,lrk) iwdr = just(lrk,lrj) @@ -1142,7 +1142,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_t1t1, w1_t1t1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1159,7 +1159,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if ((lmij /= jml) .or. (lmij /= jmr)) cycle ! t1t1(12-2) drl(11)- ! t1t1(12-2) drl(11)-c"(11)- @@ -1203,7 +1203,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, & mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_t1d1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1212,7 +1212,7 @@ real(kind=wp) :: w0td1 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -1376,7 +1376,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_dd1, w1_dd1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1385,12 +1385,12 @@ real(kind=wp) :: w0dd1, w1dd1 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmlr) cycle w0dd1 = w0_dd1 w1dd1 = w1_dd1 @@ -1428,7 +1428,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_d1d, w1_d1d -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1437,12 +1437,12 @@ real(kind=wp) :: w0dd1, w1dd1 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz-1 lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmlr) cycle w0dd1 = w0_d1d(1) w1dd1 = w1_d1d(1) @@ -1514,7 +1514,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_d1v -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1523,7 +1523,7 @@ real(kind=wp) :: w0dv1 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -1567,7 +1567,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, & mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sd -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1576,7 +1576,7 @@ real(kind=wp) :: w0sd3 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -1616,7 +1616,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, & mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sd1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1625,7 +1625,7 @@ real(kind=wp) :: w0sd1, w0sd2, w0sd3, w0sd4 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -1722,7 +1722,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, & mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_t1d1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1731,7 +1731,7 @@ real(kind=wp) :: w0td1 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -1787,7 +1787,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_t1v -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1797,12 +1797,12 @@ real(kind=wp) :: w1 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz-1 lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmlr) cycle !------------------------------------------------------------------- iwdl = just(lri,lrj) @@ -1833,7 +1833,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_ss, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -1846,7 +1846,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle ! ss(1-19) drl(12)-c"(21)- act -c"- iwdl = just(lrj,lri) @@ -1876,7 +1876,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_ds -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1886,12 +1886,12 @@ real(kind=wp) :: w1ds integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmr) cycle ! ds(7-2) ar(23)-bl(31)-br(32)- do lrd=norb_frz+1,lri-1 @@ -1932,7 +1932,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, & mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sd1, w1_sd1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1984,7 +1984,7 @@ end do do lrj=norb_frz+1,lri-1 lmj = lsm_inn(lrj) - if ((jml /= mul_tab(lmi,lmj)) .or. (jmr /= lmj)) cycle + if ((jml /= Mul(lmi,lmj)) .or. (jmr /= lmj)) cycle iwdl = just(lri,lrj) iwdr = jud(lrj) do mpl=1,mhlp @@ -1998,7 +1998,7 @@ ! sd1(8-3) ar(13)-c'(21)- do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - if ((jml /= mul_tab(lmi,lmj)) .or. (jmr /= lmj)) cycle + if ((jml /= Mul(lmi,lmj)) .or. (jmr /= lmj)) cycle iwdl = just(lrj,lri) iwdr = jud(lrj) do mpl=1,mtype @@ -2044,7 +2044,7 @@ ! !use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, & ! lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_t1s -!use Symmetry_Info, only: mul_tab => Mul +!use Symmetry_Info, only: Mul !use Constants, only: Zero !use Definitions, only: wp, iwp ! @@ -2054,12 +2054,12 @@ !real(kind=wp) :: w1ts1, w1ts2, w1ts3, w1ts4 !integer(kind=iwp), external :: iwalk_ad ! -!isma = mul_tab(iml,imr) +!isma = Mul(iml,imr) !do lri=norb_frz+1,norb_dz ! lmi = lsm_inn(lri) ! do lrj=lri+1,norb_dz ! lmj = lsm_inn(lrj) -! lmij = mul_tab(lmi,lmj) +! lmij = Mul(lmi,lmj) ! w1ts1 = w1_t1s(1) ! w1ts2 = w1_t1s(2) ! w1ts3 = w1_t1s(3) @@ -2091,7 +2091,7 @@ ! ! t1s(5-2) (11)ar(13)-bl(32)- ! do lrk=norb_frz+1,lri-1 ! lmk = lsm_inn(lrk) -! if ((jmr == mul_tab(lmk,lmi)) .and. (jml == mul_tab(lmk,lmj))) then +! if ((jmr == Mul(lmk,lmi)) .and. (jml == Mul(lmk,lmj))) then ! iwdl = just(lrk,lri) ! iwdr = just(lrj,lrk) ! do mpl=1,mhlp @@ -2110,7 +2110,7 @@ ! ! t1s(5-2) ar(13)-c'(11)-bl(32)- ! do lrk=lri+1,lrj-1 ! lmk = lsm_inn(lrk) -! if ((jmr == mul_tab(lmi,lmk)) .and. (jml == mul_tab(lmk,lmj))) then +! if ((jmr == Mul(lmi,lmk)) .and. (jml == Mul(lmk,lmj))) then ! iwdl = just(lri,lrk) ! iwdr = just(lrj,lrk) ! do mpl=1,mhlp @@ -2129,7 +2129,7 @@ ! ! t1s(5-3) ar(13)-bl(31)-c"(12)- ! do lrk=lrj+1,norb_dz ! lmk = lsm_inn(lrk) -! if ((jmr == mul_tab(lmi,lmk)) .and. (jml == mul_tab(lmj,lmk))) then +! if ((jmr == Mul(lmi,lmk)) .and. (jml == Mul(lmj,lmk))) then ! iwdl = just(lri,lrk) ! iwdr = just(lrk,lrj) ! do mpl=1,mhlp @@ -2177,7 +2177,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_t1s -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -2187,12 +2187,12 @@ real(kind=wp) :: w1ts1, w1ts2, w1ts3, w1ts4 integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) w1ts1 = w1_t1s(1) w1ts2 = w1_t1s(2) w1ts3 = w1_t1s(3) @@ -2224,7 +2224,7 @@ ! t1s(5-2) (11)ar(13)-bl(32)- do lrk=norb_frz+1,lri-1 lmk = lsm_inn(lrk) - if ((jml == mul_tab(lmk,lmi)) .and. (jmr == mul_tab(lmk,lmj))) then + if ((jml == Mul(lmk,lmi)) .and. (jmr == Mul(lmk,lmj))) then iwdl = just(lrk,lri) iwdr = just(lrj,lrk) do mpl=1,mhlp @@ -2243,7 +2243,7 @@ ! t1s(5-2) ar(13)-c'(11)-bl(32)- do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - if ((jml == mul_tab(lmi,lmk)) .and. (jmr == mul_tab(lmk,lmj))) then + if ((jml == Mul(lmi,lmk)) .and. (jmr == Mul(lmk,lmj))) then iwdl = just(lri,lrk) iwdr = just(lrj,lrk) do mpl=1,mhlp @@ -2262,7 +2262,7 @@ ! t1s(5-3) ar(13)-bl(31)-c"(12)- do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - if ((jml == mul_tab(lmi,lmk)) .and. (jmr == mul_tab(lmj,lmk))) then + if ((jml == Mul(lmi,lmk)) .and. (jmr == Mul(lmj,lmk))) then iwdl = just(lri,lrk) iwdr = just(lrk,lrj) do mpl=1,mhlp @@ -2304,7 +2304,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, & mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sd -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2313,7 +2313,7 @@ real(kind=wp) :: w0sd3 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -2356,7 +2356,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sd1, & w1_sd1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2365,7 +2365,7 @@ real(kind=wp) :: w0sd1, w0sd2, w0sd3, w0sd4, w1sd1, w1sd2, w1sd3, w1sd4 integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) w0sd1 = w0_sd1(1) @@ -2412,7 +2412,7 @@ end do do lrk=norb_frz+1,lri-1 lmk = lsm_inn(lrk) - if ((lmk /= jmr) .or. (jml /= mul_tab(lmk,lmi))) cycle + if ((lmk /= jmr) .or. (jml /= Mul(lmk,lmi))) cycle iwdl = just(lri,lrk) iwdr = jud(lrk) do mpl=1,mhlp @@ -2427,7 +2427,7 @@ ! sdd(8-3) a&r(13)c'(21)- do lrk=lri+1,norb_dz lmk = lsm_inn(lrk) - if ((lmk /= jmr) .or. (jml /= mul_tab(lmi,lmk))) cycle + if ((lmk /= jmr) .or. (jml /= Mul(lmi,lmk))) cycle iwdl = just(lrk,lri) iwdr = jud(lrk) do mpl=1,mhlp @@ -2467,7 +2467,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sd -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2476,8 +2476,8 @@ real(kind=wp) :: w0sd3 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) -isma = mul_tab(iml,imr) +jmlr = Mul(jml,jmr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -2521,7 +2521,7 @@ use gugaci_global, only: iml, imr, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, & lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sd1, w1_sd1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2530,7 +2530,7 @@ real(kind=wp) :: w0sd1, w0sd2, w0sd3, w0sd4, w1sd1, w1sd3, w1sd4 integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if ((jml /= 1) .or. (jmr /= lmi)) cycle @@ -2569,7 +2569,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle if (lmi == jmr) then @@ -2680,7 +2680,7 @@ use gugaci_global, only: iml, imr, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, & lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_t1d1, w1_t1d1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2689,12 +2689,12 @@ real(kind=wp) :: w0td1, w1td1 integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) do lrj=norb_frz+1,lri-1 lmj = lsm_inn(lrj) - if ((jml /= mul_tab(lmi,lmj)) .or. (jmr /= lmj)) cycle + if ((jml /= Mul(lmi,lmj)) .or. (jmr /= lmj)) cycle w0td1 = w0_t1d1(1) w1td1 = w1_t1d1(1) if (mod(norb_dz-lri,2) == 1) then @@ -2729,7 +2729,7 @@ ! t1d1(15-1) ar(13)-c'(11)- do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - if ((jml /= mul_tab(lmi,lmj)) .or. (jmr /= lmj)) cycle + if ((jml /= Mul(lmi,lmj)) .or. (jmr /= lmj)) cycle w0td1 = w0_t1d1(1) w1td1 = w1_t1d1(1) if (mod(norb_dz-lri,2) == 1) then diff -Nru openmolcas-22.02/src/gugaci/dblploop4.F90 openmolcas-22.10/src/gugaci/dblploop4.F90 --- openmolcas-22.02/src/gugaci/dblploop4.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/dblploop4.F90 2022-10-10 14:22:40.000000000 +0000 @@ -16,7 +16,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, & mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, w1_d1s -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -30,7 +30,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if ((lmij /= jmr) .or. (lmi /= jml)) cycle iwdr = just(lri,lrj) iwdl = jud(lri) @@ -107,7 +107,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, & vplpnew_w1, w0_d1s, w1_d1s -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -116,12 +116,12 @@ real(kind=wp) :: w0ds2, w0ds3, w1ds2, w1ds3 integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmr) cycle do lrd=norb_frz+1,lri-1 lmd = lsm_inn(lrd) @@ -189,7 +189,7 @@ use gugaci_global, only: ipae, ipael, jml, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_t1t1, w1_t1t1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: iwp @@ -202,7 +202,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle do mpl=1,mtype vplp_w0(mpl) = vplpnew_w0(mpl)*w0_t1t1(2) @@ -253,7 +253,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, & vplpnew_w1, w0_t1t1, w1_t1t1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -262,13 +262,13 @@ real(kind=wp) :: w0tt1, w1tt1 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) -isma = mul_tab(iml,imr) +jmlr = Mul(jml,jmr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmlr) cycle ijk = lri-norb_frz+ngw2(lrj-norb_frz)+ngw3(lra-norb_frz) intpos = intind_ijka(ijk) @@ -287,7 +287,7 @@ ! t1t1(12-1) (22)ar(13)-bl(31)- do lrk=norb_frz+1,lri-1 lmk = lsm_inn(lrk) - if (mul_tab(lmk,lmi) /= jml) cycle + if (Mul(lmk,lmi) /= jml) cycle iwdl = just(lrk,lri) iwdr = just(lrk,lrj) do mpl=1,mhlp @@ -301,7 +301,7 @@ ! t1t1(12-1) ar(13)-bl(31)-c"(11)- do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - if (mul_tab(lmk,lmi) /= jml) cycle + if (Mul(lmk,lmi) /= jml) cycle iwdl = just(lri,lrk) iwdr = just(lrj,lrk) do mpl=1,mhlp @@ -319,7 +319,7 @@ end do do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - if (mul_tab(lmk,lmi) /= jml) cycle + if (Mul(lmk,lmi) /= jml) cycle iwdl = just(lri,lrk) iwdr = just(lrk,lrj) do mpl=1,mhlp @@ -343,7 +343,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, & mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_t1d1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -352,7 +352,7 @@ real(kind=wp) :: w0td1 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -363,7 +363,7 @@ ! t1d1(15-1) (11)a(13) do lrk=norb_frz+1,lri-1 lmk = lsm_inn(lrk) - if ((lmk /= jmr) .and. (mul_tab(lmk,lmi) /= jml)) cycle + if ((lmk /= jmr) .and. (Mul(lmk,lmi) /= jml)) cycle iwdl = just(lrk,lri) iwdr = jud(lrk) do mpl=1,mtype @@ -382,7 +382,7 @@ ! t1d1(15-1) a(13)c'(11) do lrk=lri+1,norb_dz lmk = lsm_inn(lrk) - if ((lmk /= jmr) .and. (mul_tab(lmk,lmi) /= jml)) cycle + if ((lmk /= jmr) .and. (Mul(lmk,lmi) /= jml)) cycle iwdl = just(lri,lrk) iwdr = jud(lrk) do mpl=1,mtype @@ -409,7 +409,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_t1d1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -418,8 +418,8 @@ real(kind=wp) :: w0td1 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) -isma = mul_tab(iml,imr) +jmlr = Mul(jml,jmr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -480,7 +480,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, & vplpnew_w1, w0_d1t1, w1_d1t1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -489,12 +489,12 @@ real(kind=wp) :: w0dt, w1dt integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmr) cycle ! d1t1(16) ar(13)-bl(31)-br(31)- do lrd=norb_frz+1,lri-1 @@ -587,7 +587,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, & lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_d1d1, & w1_d1d1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -596,7 +596,7 @@ real(kind=wp) :: w0dd1, w1dd1 integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lrl=norb_frz+1,norb_dz-1 lml = lsm_inn(lrl) if (lml /= jml) cycle @@ -639,7 +639,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, & lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_d1v -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -648,7 +648,7 @@ real(kind=wp) :: w0dv1 integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jml) cycle @@ -723,7 +723,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, & lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_dd1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -733,7 +733,7 @@ real(kind=wp) :: w1dd1 integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lrl=norb_frz+1,norb_dz-1 lml = lsm_inn(lrl) if (lml /= jml) cycle @@ -773,7 +773,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, & lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_d1d -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -783,7 +783,7 @@ real(kind=wp) :: w1dd1 integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lrl=norb_frz+1,norb_dz-1 lml = lsm_inn(lrl) if (lml /= jml) cycle @@ -873,7 +873,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_ss, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -886,7 +886,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) w0ss1 = w0_ss(1) w1ss1 = w1_ss(1) w0ss3 = w0_ss(3) @@ -965,8 +965,8 @@ end do do lrk=norb_frz+1,lri-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lri,lrk) iwdr = just(lrj,lrk) @@ -986,8 +986,8 @@ end do do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lrk,lri) iwdr = just(lrj,lrk) @@ -1007,8 +1007,8 @@ end do do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lrk,lri) iwdr = just(lrk,lrj) @@ -1028,8 +1028,8 @@ end do do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lri,lrk) iwdr = just(lrj,lrk) @@ -1049,8 +1049,8 @@ end do do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lrk,lri) iwdr = just(lrk,lrj) @@ -1070,8 +1070,8 @@ end do do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lrk,lri) iwdr = just(lrj,lrk) @@ -1091,8 +1091,8 @@ end do do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lri,lrk) iwdr = just(lrk,lrj) @@ -1116,7 +1116,7 @@ ! !use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & ! norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_ss, w1_ss -!use Symmetry_Info, only: mul_tab => Mul +!use Symmetry_Info, only: Mul !use Definitions, only: wp, iwp ! !implicit none @@ -1128,7 +1128,7 @@ ! lmi = lsm_inn(lri) ! do lrj=lri+1,norb_dz ! lmj = lsm_inn(lrj) -! lmij = mul_tab(lmi,lmj) +! lmij = Mul(lmi,lmj) ! w0ss2 = w0_ss(2) ! w1ss2 = w1_ss(2) ! w0ss4 = w0_ss(4) @@ -1191,8 +1191,8 @@ ! end do ! do lrk=norb_frz+1,lri-1 ! lmk = lsm_inn(lrk) -! lmki = mul_tab(lmk,lmi) -! lmkj = mul_tab(lmk,lmj) +! lmki = Mul(lmk,lmi) +! lmkj = Mul(lmk,lmj) ! if ((lmki == jml) .and. (lmkj == jmr)) then ! iwdl = just(lrk,lri) ! iwdr = just(lrk,lrj) @@ -1212,8 +1212,8 @@ ! end do ! do lrk=lri+1,lrj-1 ! lmk = lsm_inn(lrk) -! lmki = mul_tab(lmk,lmi) -! lmkj = mul_tab(lmk,lmj) +! lmki = Mul(lmk,lmi) +! lmkj = Mul(lmk,lmj) ! if ((lmki == jml) .and. (lmkj == jmr)) then ! iwdl = just(lri,lrk) ! iwdr = just(lrk,lrj) @@ -1233,8 +1233,8 @@ ! end do ! do lrk=lrj+1,norb_dz ! lmk = lsm_inn(lrk) -! lmki = mul_tab(lmk,lmi) -! lmkj = mul_tab(lmk,lmj) +! lmki = Mul(lmk,lmi) +! lmkj = Mul(lmk,lmj) ! if ((lmki == jml) .and. (lmkj == jmr)) then ! iwdl = just(lri,lrk) ! iwdr = just(lrj,lrk) @@ -1262,7 +1262,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_ss, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: iwp @@ -1275,7 +1275,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle iwdl = just(lrj,lri) iwdr = iwdl @@ -1321,7 +1321,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: iwp @@ -1334,7 +1334,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle ! ss(1-19) drl(12)-c"(21)- act -c"- iwdl = just(lrj,lri) @@ -1361,7 +1361,7 @@ ! !use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & ! norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_ss, w1_ss -!use Symmetry_Info, only: mul_tab => Mul +!use Symmetry_Info, only: Mul !use Constants, only: Zero !use Definitions, only: wp, iwp ! @@ -1400,7 +1400,7 @@ ! lmi = lsm_inn(lri) ! do lrj=lri+1,norb_dz ! lmj = lsm_inn(lrj) -! lmij = mul_tab(lmi,lmj) +! lmij = Mul(lmi,lmj) ! if ((lmij /= jml) .or. (lmij /= jmr)) cycle ! iwdl = just(lri,lrj) ! iwdr = iwdl @@ -1447,7 +1447,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_st -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1467,8 +1467,8 @@ end if do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then ! st(2-3) ar(13)-c'(22)-bl(32)- act -c"- iwdl = just(lrk,lri) @@ -1488,8 +1488,8 @@ end do do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then ! st(2-3) ar(13)-bl(32)-c'(22)- act -c"- iwdl = just(lrk,lri) @@ -1518,7 +1518,7 @@ ! !use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & ! norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_st -!use Symmetry_Info, only: mul_tab => Mul +!use Symmetry_Info, only: Mul !use Constants, only: Zero !use Definitions, only: wp, iwp ! @@ -1531,7 +1531,7 @@ ! lmi = lsm_inn(lri) ! do lrj=lri+1,norb_dz ! lmj = lsm_inn(lrj) -! lmij = mul_tab(lmi,lmj) +! lmij = Mul(lmi,lmj) ! w1st1 = w1_st(1) ! w1st2 = w1_st(2) ! w1st4 = w1_st(4) @@ -1559,8 +1559,8 @@ ! end if ! do lrk=norb_frz+1,lri-1 ! lmk = lsm_inn(lrk) -! lmki = mul_tab(lmk,lmi) -! lmkj = mul_tab(lmk,lmj) +! lmki = Mul(lmk,lmi) +! lmkj = Mul(lmk,lmj) ! if ((lmki == jml) .and. (lmkj == jmr)) then ! ! st(2-2) (22)ar(13)-bl(32)- act -c"- ! iwdl = just(lrk,lri) @@ -1580,8 +1580,8 @@ ! end do ! do lrk=lri+1,lrj-1 ! lmk = lsm_inn(lrk) -! lmki = mul_tab(lmk,lmi) -! lmkj = mul_tab(lmk,lmj) +! lmki = Mul(lmk,lmi) +! lmkj = Mul(lmk,lmj) ! if ((lmki == jml) .and. (lmkj == jmr)) then ! ! st(2-4) ar(23)-c'(12)-bl(32)- act -c"- ! iwdl = just(lri,lrk) @@ -1601,8 +1601,8 @@ ! end do ! do lrk=lrj+1,norb_dz ! lmk = lsm_inn(lrk) -! lmki = mul_tab(lmk,lmi) -! lmkj = mul_tab(lmk,lmj) +! lmki = Mul(lmk,lmi) +! lmkj = Mul(lmk,lmj) ! if ((lmki == jml) .and. (lmkj == jmr)) then ! ! st(2-4) ar(23)-bl(32)-c'(12)- act -c"- ! iwdl = just(lri,lrk) @@ -1634,7 +1634,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_st -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: iwp @@ -1646,7 +1646,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) ! st(2-7) drl(12)-c"(22)- act -c"- if ((lmij /= jml) .or. (lmij /= jmr)) cycle iwdl = just(lrj,lri) @@ -1673,7 +1673,7 @@ ! !use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & ! norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_st -!use Symmetry_Info, only: mul_tab => Mul +!use Symmetry_Info, only: Mul !use Constants, only: Zero !use Definitions, only: iwp ! @@ -1685,7 +1685,7 @@ ! lmi = lsm_inn(lri) ! do lrj=lri+1,norb_dz ! lmj = lsm_inn(lrj) -! lmij = mul_tab(lmi,lmj) +! lmij = Mul(lmi,lmj) ! if ((lmij /= jml) .or. (lmij /= jmr)) cycle ! ! st(2-5) (22)drl(12)- act -c"- ! iwdl = just(lri,lrj) @@ -1718,7 +1718,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_ts -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1743,8 +1743,8 @@ end do do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lri,lrk) iwdr = just(lrk,lrj) @@ -1774,7 +1774,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_st1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1787,7 +1787,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) w1ts1 = w1_st1(1) w1ts2 = w1_st1(2) w1ts3 = w1_st1(3) @@ -1817,8 +1817,8 @@ end if do lrk=norb_frz+1,lri-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then ! st1(4-2) (11)ar(23)-bl(31)- iwdl = just(lri,lrk) @@ -1838,8 +1838,8 @@ end do do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then ! st1(4-3) ar(13)-c'(21)-bl(31)- ! st1(4-4) ar(23)-c'(11)-bl(31)- @@ -1875,8 +1875,8 @@ ! st1(4-4) ar(23)-bl(31)-c"(11)- do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lrk,lri) iwdr = just(lrj,lrk) @@ -1925,7 +1925,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_t1s -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1938,7 +1938,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) w1ts1 = w1_t1s(1) w1ts2 = w1_t1s(2) w1ts3 = w1_t1s(3) @@ -1968,8 +1968,8 @@ end if do lrk=norb_frz+1,lri-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then ! t1s(5-2) (11)ar(13)-bl(32)- iwdl = just(lrk,lri) @@ -1989,8 +1989,8 @@ end do do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then ! t1s(5-2) ar(13)-c'(11)-bl(32)- iwdl = just(lri,lrk) @@ -2015,8 +2015,8 @@ end do do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lri,lrk) iwdr = just(lrk,lrj) @@ -2036,8 +2036,8 @@ end do do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lri,lrk) iwdr = just(lrj,lrk) @@ -2064,7 +2064,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_t1s -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: iwp @@ -2077,7 +2077,7 @@ lmi = lsm_inn(lri) do lrj=norb_frz+1,lri-1 lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (jml /= lmij) cycle ! t1s(5-5) (11)drl(12)- ! t1s(5-6) drl(11)-c"(12)- @@ -2125,7 +2125,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, & mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sd -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2134,7 +2134,7 @@ real(kind=wp) :: w0sd3 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -2144,7 +2144,7 @@ ! sd(6-3) a&r(13)-c'(22)- do lrk=lri+1,norb_dz lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) + lmki = Mul(lmk,lmi) if ((lmki == jml) .and. (lmk == jmr)) then iwdl = just(lrk,lri) iwdr = jud(lrk) @@ -2175,7 +2175,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, & mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sd1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2184,7 +2184,7 @@ real(kind=wp) :: w0sd1, w0sd2, w0sd3, w0sd4 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -2216,7 +2216,7 @@ ! sd1(8-2) (11)ar(23)- do lrk=norb_frz+1,lri-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) + lmki = Mul(lmk,lmi) if ((lmki == jml) .and. (lmk == jmr)) then iwdl = just(lri,lrk) iwdr = jud(lrk) @@ -2240,7 +2240,7 @@ end do do lrk=lri+1,norb_dz lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) + lmki = Mul(lmk,lmi) if ((lmki == jml) .and. (lmk == jmr)) then iwdl = just(lrk,lri) iwdr = jud(lrk) @@ -2260,7 +2260,7 @@ end do do lrk=lri+1,norb_dz lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) + lmki = Mul(lmk,lmi) if ((lmki == jml) .and. (lmk == jmr)) then iwdl = just(lri,lrk) iwdr = jud(lrk) @@ -2286,7 +2286,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_t1t1, w1_t1t1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2312,8 +2312,8 @@ ! t1t1(12-1) (11)ar(13)-bl(31)- do lrk=norb_frz+1,lri-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lrk,lri) iwdr = just(lrk,lrj) @@ -2329,8 +2329,8 @@ ! t1t1(12-1) ar(13)-bl(31)-c"(11)- do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lri,lrk) iwdr = just(lrj,lrk) @@ -2350,8 +2350,8 @@ ! t1t1(12-1) ar(13)-c'(11)-bl(31)- do lrk=lri+1,lrj-1 lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then iwdl = just(lri,lrk) iwdr = just(lrk,lrj) @@ -2380,7 +2380,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_t1t1, w1_t1t1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: iwp @@ -2392,7 +2392,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if ((lmij /= jml) .or. (lmij /= jmr)) cycle ! t1t1(12-2) drl(11)- ! t1t1(12-2) drl(11)-c"(11)- @@ -2435,7 +2435,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, & mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_t1d1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2444,7 +2444,7 @@ real(kind=wp) :: w0td1 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -2501,7 +2501,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_d1d1, w1_d1d1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2509,12 +2509,12 @@ real(kind=wp) :: w0dd1, w1dd1 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz-1 lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmlr) cycle w0dd1 = w0_d1d1(1) w1dd1 = w1_d1d1(1) @@ -2599,7 +2599,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_dd1, w1_dd1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2607,12 +2607,12 @@ real(kind=wp) :: w0dd1, w1dd1 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz-1 lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmlr) cycle w0dd1 = w0_dd1 w1dd1 = w1_dd1 @@ -2649,7 +2649,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_d1d, w1_d1d -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2657,12 +2657,12 @@ real(kind=wp) :: w0dd1, w1dd1 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz-1 lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmlr) cycle w0dd1 = w0_d1d(1) w1dd1 = w1_d1d(1) @@ -2735,7 +2735,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_d1v -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2744,7 +2744,7 @@ real(kind=wp) :: w0dv1 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -2779,7 +2779,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, & vplpnew_w1, w0_sd, w1_sd -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -2789,12 +2789,12 @@ real(kind=wp) :: w0sd10, w0sd15, w0sd3, w0sd6, w0sd7, w1sd10, w1sd15, w1sd3, w1sd6, w1sd7 integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle if (lmi == jmr) then iwdl = just(lrj,lri) @@ -2932,7 +2932,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jb_sys, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, & lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, & vplpnew_w1, w0_sd -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2941,8 +2941,8 @@ real(kind=wp) :: w0sd3 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) -isma = mul_tab(iml,imr) +jmlr = Mul(jml,jmr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -2985,7 +2985,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sd -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2994,8 +2994,8 @@ real(kind=wp) :: w0sd3 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) -isma = mul_tab(iml,imr) +jmlr = Mul(jml,jmr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -3035,7 +3035,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jb_sys, jml, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, & vplpnew_w1, w0_sv, w1_sv -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -3044,12 +3044,12 @@ real(kind=wp) :: w0sv1, w1sv1 integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) do lrj=lri,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle w0sv1 = w0_sv(1) w1sv1 = w1_sv(1) @@ -3092,7 +3092,7 @@ use gugaci_global, only: iml, imr, ipae, ipael, jml, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, & mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, w0_d1v -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -3102,7 +3102,7 @@ real(kind=wp) :: w0 integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lrd=norb_frz+1,norb_dz lmd = lsm_inn(lrd) if (lmd /= jml) cycle @@ -3152,7 +3152,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, & lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_d1v -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -3161,7 +3161,7 @@ real(kind=wp) :: w0 integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lrd=norb_frz+1,norb_dz lmd = lsm_inn(lrd) if (lmd /= jml) cycle @@ -3197,7 +3197,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, & lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_d1v -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -3206,7 +3206,7 @@ real(kind=wp) :: w0 integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lrd=norb_frz+1,norb_dz lmd = lsm_inn(lrd) if (lmd /= jml) cycle @@ -3240,7 +3240,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_ts -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -3261,8 +3261,8 @@ end if do lrk=lrj+1,norb_dz lmk = lsm_inn(lrk) - lmki = mul_tab(lmk,lmi) - lmkj = mul_tab(lmk,lmj) + lmki = Mul(lmk,lmi) + lmkj = Mul(lmk,lmj) if ((lmki == jml) .and. (lmkj == jmr)) then ! ts(3-3) ar(23)-bl(31)-c"(22)- iwdl = just(lri,lrk) diff -Nru openmolcas-22.02/src/gugaci/dblploop5.F90 openmolcas-22.10/src/gugaci/dblploop5.F90 --- openmolcas-22.02/src/gugaci/dblploop5.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/dblploop5.F90 2022-10-10 14:22:40.000000000 +0000 @@ -60,7 +60,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, & vplpnew_w1, w0_ds, w1_ds -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -69,12 +69,12 @@ real(kind=wp) :: w0ds, w1ds integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmr) cycle ! ds(7-3) ar(23)-bl(32)-br(31)- do lrd=norb_frz+1,lri-1 @@ -117,7 +117,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, & vplpnew_w1, w0_dt, w1_dt -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -126,12 +126,12 @@ real(kind=wp) :: w0dt, w1dt integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmr) cycle ! dt(14) ar(23)-bl(32)-br(32)- do lrd=norb_frz+1,lri-1 @@ -173,7 +173,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, & lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_dv -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -182,7 +182,7 @@ real(kind=wp) :: w0dv1 integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jml) cycle @@ -218,7 +218,7 @@ ! !use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, & ! lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_dv -!use Symmetry_Info, only: mul_tab => Mul +!use Symmetry_Info, only: Mul !use Definitions, only: wp, iwp ! !implicit none @@ -227,7 +227,7 @@ !real(kind=wp) :: w0dv1 !integer(kind=iwp), external :: iwalk_ad ! -!isma = mul_tab(iml,imr) +!isma = Mul(iml,imr) !do lri=norb_frz+1,norb_dz ! lmi = lsm_inn(lri) ! if (lmi /= jml) cycle @@ -305,20 +305,20 @@ !======================================================================= use gugaci_global, only: iml, imr, intind_ijka, jml, jmr, lsm_inn, ngw2, ngw3, norb_dz, norb_frz -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none integer(kind=iwp), intent(in) :: lin, lra integer(kind=iwp) :: ijk, intpos, isma, jmlr, lmi, lmij, lmj, lri, lrj, nk -jmlr = mul_tab(jml,jmr) -isma = mul_tab(iml,imr) +jmlr = Mul(jml,jmr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmlr) cycle ijk = lri-norb_frz+ngw2(lrj-norb_frz)+ngw3(lra-norb_frz) intpos = intind_ijka(ijk) @@ -342,7 +342,7 @@ use gugaci_global, only: ipae, ipael, jml, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_tt, w1_tt -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: iwp @@ -355,7 +355,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle do mpl=1,mtype vplp_w0(mpl) = vplpnew_w0(mpl)*w0_tt(2) @@ -409,20 +409,20 @@ !======================================================================= use gugaci_global, only: iml, imr, intind_ijka, jml, jmr, lsm_inn, ngw2, ngw3, norb_dz, norb_frz -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none integer(kind=iwp), intent(in) :: lin, lra integer(kind=iwp) :: ijk, intpos, isma, jmlr, lmi, lmij, lmj, lri, lrj, nk -jmlr = mul_tab(jml,jmr) -isma = mul_tab(iml,imr) +jmlr = Mul(jml,jmr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmlr) cycle ijk = lri-norb_frz+ngw2(lrj-norb_frz)+ngw3(lra-norb_frz) intpos = intind_ijka(ijk) @@ -446,7 +446,7 @@ use gugaci_global, only: ipae, ipael, jml, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_tt, w1_tt -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: iwp @@ -459,7 +459,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle do mpl=1,mtype vplp_w0(mpl) = vplpnew_w0(mpl)*w0_tt(2) @@ -512,7 +512,7 @@ use gugaci_global, only: ipae, ipael, jml, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_st -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: iwp @@ -525,7 +525,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle !------------------------------------------------------------------- ! st(2-5) (22)drl(12)- @@ -558,14 +558,14 @@ subroutine st_arbl_act_bl(lin,lra) use gugaci_global, only: iml, imr, intind_ijka, ngw2, ngw3, norb_dz, norb_frz -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none integer(kind=iwp), intent(in) :: lin, lra integer(kind=iwp) :: ijk, intpos, isma, lri, lrj, nk -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz-1 do lrj=lri+1,norb_dz ijk = lri-norb_frz+ngw2(lrj-norb_frz)+ngw3(lra-norb_frz) @@ -592,7 +592,7 @@ use gugaci_global, only: ipae, ipael, jml, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_st -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: iwp @@ -605,7 +605,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle !------------------------------------------------------------------- ! st(2-5) (22)drl(12)- @@ -638,14 +638,14 @@ subroutine st_arbl_act_br(lin,lra) use gugaci_global, only: iml, imr, intind_ijka, ngw2, ngw3, norb_dz, norb_frz -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none integer(kind=iwp), intent(in) :: lin, lra integer(kind=iwp) :: ijk, intpos, isma, lri, lrj, nk -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz-1 do lrj=lri+1,norb_dz ijk = lri-norb_frz+ngw2(lrj-norb_frz)+ngw3(lra-norb_frz) @@ -678,14 +678,14 @@ !======================================================================= use gugaci_global, only: iml, imr, intind_ijka, ngw2, ngw3, norb_dz, norb_frz -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none integer(kind=iwp), intent(in) :: lin, lra integer(kind=iwp) :: ijk, intpos, isma, lri, lrj, nk -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz do lrj=lri+1,norb_dz ijk = lri-norb_frz+ngw2(lrj-norb_frz)+ngw3(lra-norb_frz) @@ -713,7 +713,7 @@ use gugaci_global, only: ipae, ipael, jml, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_ss, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: iwp @@ -749,7 +749,7 @@ end if do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle ! ss(1-15) (22)-drl(11)- iwdl = just(lri,lrj) @@ -807,14 +807,14 @@ ! ts(3) a&r-b^l- act -b&l ............................................ use gugaci_global, only: iml, imr, intind_ijka, ngw2, ngw3, norb_dz, norb_frz -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none integer(kind=iwp), intent(in) :: lin, lra integer(kind=iwp) :: ijk, intpos, isma, lri, lrj, nk -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz do lrj=lri+1,norb_dz ijk = lri-norb_frz+ngw2(lrj-norb_frz)+ngw3(lra-norb_frz) @@ -839,14 +839,14 @@ ! ts(3) a&r-b^l- act -b&l ............................................ use gugaci_global, only: iml, imr, intind_ijka, ngw2, ngw3, norb_dz, norb_frz -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none integer(kind=iwp), intent(in) :: lin, lra integer(kind=iwp) :: ijk, intpos, isma, lri, lrj, nk -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz do lrj=lri+1,norb_dz ijk = lri-norb_frz+ngw2(lrj-norb_frz)+ngw3(lra-norb_frz) @@ -880,7 +880,7 @@ use gugaci_global, only: ipae, ipael, jml, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_ss, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: iwp @@ -920,7 +920,7 @@ end if do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle iwdl = just(lri,lrj) iwdr = iwdl @@ -984,14 +984,14 @@ !======================================================================= use gugaci_global, only: iml, imr, intind_ijka, ngw2, ngw3, norb_dz, norb_frz -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none integer(kind=iwp), intent(in) :: lin, lra integer(kind=iwp) :: ijk, intpos, isma, lri, lrj, nk -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz do lrj=lri+1,norb_dz ijk = lri-norb_frz+ngw2(lrj-norb_frz)+ngw3(lra-norb_frz) @@ -1021,7 +1021,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, & mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sd -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1030,7 +1030,7 @@ real(kind=wp) :: w0sd1, w0sd2, w0sd4 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -1118,7 +1118,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sd -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1127,8 +1127,8 @@ real(kind=wp) :: w0sd1, w0sd2, w0sd4 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) -isma = mul_tab(iml,imr) +jmlr = Mul(jml,jmr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -1211,7 +1211,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sd -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1220,8 +1220,8 @@ real(kind=wp) :: w0sd1, w0sd2, w0sd4 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) -isma = mul_tab(iml,imr) +jmlr = Mul(jml,jmr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -1304,7 +1304,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sd -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1313,8 +1313,8 @@ real(kind=wp) :: w0sd1, w0sd2, w0sd4 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) -isma = mul_tab(iml,imr) +jmlr = Mul(jml,jmr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -1397,7 +1397,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, & mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_sd -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1406,7 +1406,7 @@ real(kind=wp) :: w0sd1, w0sd2, w0sd4 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -1485,7 +1485,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, & mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_td -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1494,7 +1494,7 @@ real(kind=wp) :: w0td1 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -1557,7 +1557,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_td -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1566,8 +1566,8 @@ real(kind=wp) :: w0td1 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) -isma = mul_tab(iml,imr) +jmlr = Mul(jml,jmr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -1626,7 +1626,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_td -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1635,8 +1635,8 @@ real(kind=wp) :: w0td1 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) -isma = mul_tab(iml,imr) +jmlr = Mul(jml,jmr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -1695,7 +1695,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, & lpnew_rwei, lsm_inn, mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_td -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1704,8 +1704,8 @@ real(kind=wp) :: w0td1 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) -isma = mul_tab(iml,imr) +jmlr = Mul(jml,jmr) +isma = Mul(iml,imr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -1764,7 +1764,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, jud, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, & mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_td -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1773,7 +1773,7 @@ real(kind=wp) :: w0td1 integer(kind=iwp), external :: iwalk_ad -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -1942,7 +1942,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, & lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_dd, & w1_dd -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1951,7 +1951,7 @@ real(kind=wp) :: w0dd1, w1dd1 integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lrl=norb_frz+1,norb_dz-1 lml = lsm_inn(lrl) if (lml /= jml) cycle @@ -1992,7 +1992,7 @@ use gugaci_global, only: iml, imr, intind_ijka, ipae, ipael, jml, jmr, jpad, jpadl, jud, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, & lsm_inn, mhlp, mtype, ngw2, ngw3, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_dd, w1_dd -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -2001,7 +2001,7 @@ real(kind=wp) :: w0dd1, w1dd1 integer(kind=iwp), external :: iwalk_ad -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) do lrl=norb_frz+1,norb_dz-1 lml = lsm_inn(lrl) if (lml /= jml) cycle diff -Nru openmolcas-22.02/src/gugaci/dblplpval.F90 openmolcas-22.10/src/gugaci/dblplpval.F90 --- openmolcas-22.02/src/gugaci/dblplpval.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/dblplpval.F90 2022-10-10 14:22:40.000000000 +0000 @@ -442,7 +442,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_ss, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -454,7 +454,7 @@ LMI = LSM_INN(LRI) LMJ = LSM_INN(LRJ) -LMIJ = MUL_TAB(LMI,LMJ) +LMIJ = Mul(LMI,LMJ) NK = 0 if ((JML /= 1) .or. (LMIJ /= JMR)) return ! SS(1-2) Ar(02)-Bl(31)- @@ -524,7 +524,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_ss, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -536,7 +536,7 @@ LMI = LSM_INN(LRI) LMJ = LSM_INN(LRJ) -LMIJ = MUL_TAB(LMI,LMJ) +LMIJ = Mul(LMI,LMJ) NK = 0 if ((JMR /= 1) .or. (LMIJ /= JML)) return NK = 1 @@ -570,7 +570,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, max_innorb, & mhlp, mtype, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_ss, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use stdalloc, only: mma_allocate, mma_deallocate use Definitions, only: wp, iwp @@ -589,8 +589,8 @@ call mma_allocate(iwdr,max_innorb,label='iwdr') do LRK=NORB_FRZ+1,LRI-1 LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) - LMKJ = MUL_TAB(LMK,LMJ) + LMKI = Mul(LMK,LMI) + LMKJ = Mul(LMK,LMJ) if ((LMKI /= JML) .or. (LMKJ /= JMR)) cycle NK = NK+1 IWDL(NK) = JUST(LRK,LRI) @@ -632,7 +632,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, max_innorb, & mhlp, mtype, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_ss, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use stdalloc, only: mma_allocate, mma_deallocate use Definitions, only: wp, iwp @@ -651,8 +651,8 @@ call mma_allocate(iwdr,max_innorb,label='iwdr') do LRK=LRI+1,LRJ-1 LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) - LMKJ = MUL_TAB(LMK,LMJ) + LMKI = Mul(LMK,LMI) + LMKJ = Mul(LMK,LMJ) if ((LMKI /= JML) .or. (LMKJ /= JMR)) cycle NK = NK+1 IWDL(NK) = JUST(LRI,LRK) @@ -694,7 +694,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, max_innorb, & mhlp, mtype, norb_dz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_ss, w1_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use stdalloc, only: mma_allocate, mma_deallocate use Definitions, only: wp, iwp @@ -713,8 +713,8 @@ call mma_allocate(iwdr,max_innorb,label='iwdr') do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) - LMKJ = MUL_TAB(LMK,LMJ) + LMKI = Mul(LMK,LMI) + LMKJ = Mul(LMK,LMJ) if ((LMKI /= JML) .or. (LMKJ /= JMR)) cycle NK = NK+1 IWDL(NK) = JUST(LRI,LRK) @@ -756,7 +756,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, max_innorb, & mhlp, mtype, norb_dz, norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_tt, w1_tt -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use stdalloc, only: mma_allocate, mma_deallocate use Definitions, only: wp, iwp @@ -777,8 +777,8 @@ ! TT(11-1) Ar(23)-C'(22)-Bl(32)- do LRK=LRI+1,LRJ-1 LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) - LMKJ = MUL_TAB(LMK,LMJ) + LMKI = Mul(LMK,LMI) + LMKJ = Mul(LMK,LMJ) if ((LMKI /= JML) .or. (LMKJ /= JMR)) cycle NK = NK+1 IWDL(NK) = JUST(LRI,LRK) @@ -790,8 +790,8 @@ ! TT(11-1) (22)Ar(23)-Bl(32)- do LRK=NORB_FRZ+1,LRI-1 LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) - LMKJ = MUL_TAB(LMK,LMJ) + LMKI = Mul(LMK,LMI) + LMKJ = Mul(LMK,LMJ) if ((LMKI /= JML) .or. (LMKJ /= JMR)) cycle NK = NK+1 IWDL(NK) = JUST(LRK,LRI) @@ -800,8 +800,8 @@ ! TT(11-1) Ar(23)-Bl(32)-C"(22)- ACT -C"- do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) - LMKJ = MUL_TAB(LMK,LMJ) + LMKI = Mul(LMK,LMI) + LMKJ = Mul(LMK,LMJ) if ((LMKI /= JML) .or. (LMKJ /= JMR)) cycle NK = NK+1 IWDL(NK) = JUST(LRI,LRK) @@ -843,7 +843,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & vplp_w0, vplp_w1, vplpnew_w1, w1_ts -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -856,7 +856,7 @@ LMI = LSM_INN(LRI) LMJ = LSM_INN(LRJ) -LMIJ = MUL_TAB(LMI,LMJ) +LMIJ = Mul(LMI,LMJ) NK = 0 if ((JMR /= 1) .or. (LMIJ /= JML)) return NK = 1 @@ -885,7 +885,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, max_innorb, & mhlp, mtype, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_ts -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use stdalloc, only: mma_allocate, mma_deallocate use Constants, only: Zero use Definitions, only: wp, iwp @@ -907,8 +907,8 @@ ! TS(3-2) Ar(23)-C'(22)-Bl(31)- ACT -C"- do LRK=LRI+1,LRJ-1 LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) - LMKJ = MUL_TAB(LMK,LMJ) + LMKI = Mul(LMK,LMI) + LMKJ = Mul(LMK,LMJ) if ((LMKI /= JML) .or. (LMKJ /= JMR)) cycle NK = NK+1 IWDL(NK) = JUST(LRI,LRK) @@ -919,8 +919,8 @@ ! TS(3-2) (22)Ar(23)-Bl(31)- do LRK=NORB_FRZ+1,LRI-1 LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) - LMKJ = MUL_TAB(LMK,LMJ) + LMKI = Mul(LMK,LMI) + LMKJ = Mul(LMK,LMJ) if ((LMKI /= JML) .or. (LMKJ /= JMR)) cycle NK = NK+1 IWDL(NK) = JUST(LRK,LRI) @@ -959,7 +959,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, max_innorb, & mhlp, mtype, norb_dz, vplp_w0, vplp_w1, vplpnew_w1, w1_ts -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use stdalloc, only: mma_allocate, mma_deallocate use Constants, only: Zero use Definitions, only: wp, iwp @@ -980,8 +980,8 @@ call mma_allocate(iwdr,max_innorb,label='iwdr') do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) - LMKJ = MUL_TAB(LMK,LMJ) + LMKI = Mul(LMK,LMI) + LMKJ = Mul(LMK,LMJ) if ((LMKI /= JML) .or. (LMKJ /= JMR)) cycle NK = NK+1 IWDL(NK) = JUST(LRI,LRK) @@ -1019,7 +1019,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, & vplp_w0, vplp_w1, vplpnew_w1, w1_st -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1032,7 +1032,7 @@ LMI = LSM_INN(LRI) LMJ = LSM_INN(LRJ) -LMIJ = MUL_TAB(LMI,LMJ) +LMIJ = Mul(LMI,LMJ) NK = 0 if ((JML /= 1) .or. (LMIJ /= JMR)) return NK = 1 @@ -1061,7 +1061,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, max_innorb, & mhlp, mtype, norb_frz, vplp_w0, vplp_w1, vplpnew_w1, w1_st -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use stdalloc, only: mma_allocate, mma_deallocate use Constants, only: Zero use Definitions, only: wp, iwp @@ -1082,8 +1082,8 @@ call mma_allocate(iwdr,max_innorb,label='iwdr') do LRK=NORB_FRZ+1,LRI-1 LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) - LMKJ = MUL_TAB(LMK,LMJ) + LMKI = Mul(LMK,LMI) + LMKJ = Mul(LMK,LMJ) if ((LMKI /= JML) .or. (LMKJ /= JMR)) cycle NK = NK+1 IWDL(NK) = JUST(LRK,LRI) @@ -1122,7 +1122,7 @@ use gugaci_global, only: ipae, ipael, jml, jmr, jpad, jpadl, just, lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, max_innorb, & mhlp, mtype, norb_dz, vplp_w0, vplp_w1, vplpnew_w1, w1_st -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use stdalloc, only: mma_allocate, mma_deallocate use Constants, only: Zero use Definitions, only: wp, iwp @@ -1144,8 +1144,8 @@ ! ST(2-4) Ar(23)-C'(12)-Bl(32)- do LRK=LRI+1,LRJ-1 LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) - LMKJ = MUL_TAB(LMK,LMJ) + LMKI = Mul(LMK,LMI) + LMKJ = Mul(LMK,LMJ) if ((LMKI /= JML) .or. (LMKJ /= JMR)) cycle NK = NK+1 IWDL(NK) = JUST(LRI,LRK) @@ -1156,8 +1156,8 @@ ! ST(2-4) Ar(23)-Bl(32)-C'(12)- do LRK=LRJ+1,NORB_DZ LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) - LMKJ = MUL_TAB(LMK,LMJ) + LMKI = Mul(LMK,LMI) + LMKJ = Mul(LMK,LMJ) if ((LMKI /= JML) .or. (LMKJ /= JMR)) cycle NK = NK+1 IWDL(NK) = JUST(LRI,LRK) diff -Nru openmolcas-22.02/src/gugaci/dbl_upwalk.F90 openmolcas-22.10/src/gugaci/dbl_upwalk.F90 --- openmolcas-22.02/src/gugaci/dbl_upwalk.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/dbl_upwalk.F90 2022-10-10 14:22:40.000000000 +0000 @@ -12,7 +12,7 @@ subroutine dbl_upwalk() use gugaci_global, only: jpad_upwei, jroute_sys, lsm_inn, mxnode, ng_sm, norb_dbl, norb_dz, norb_frz, ns_sm, nu_ad -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -29,7 +29,7 @@ mxnode = 17+ng_sm lri = norb_frz+1 lsmi = lsm_inn(lri) - lsmid = mul_tab(lsmi,ns_sm) + lsmid = Mul(lsmi,ns_sm) ! for node_v nu_ad(1) = 1 jpad_upwei(1) = 1 @@ -56,13 +56,13 @@ end if do lri=norb_frz+1,norb_dz lsmi = lsm_inn(lri) - lsmid = mul_tab(lsmi,ns_sm) + lsmid = Mul(lsmi,ns_sm) no_d = lsmid+1 jpad_upwei(no_d) = jpad_upwei(no_d)+1 do lrj=lri+1,norb_dz lsmj = lsm_inn(lrj) - lsmij = mul_tab(lsmi,lsmj) - lsmit = mul_tab(lsmij,ns_sm) + lsmij = Mul(lsmi,lsmj) + lsmit = Mul(lsmij,ns_sm) no_t = lsmit+9 jpad_upwei(no_t) = jpad_upwei(no_t)+1 end do @@ -101,7 +101,7 @@ subroutine ext_downwalk() use gugaci_global, only: iseg_downwei, ng_sm, nlsm_ext, norb_ext, nu_ae -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -120,7 +120,7 @@ do imi=1,ng_sm iseg_downwei(nu_ae(1+imi)) = nlsm_ext(imi) do imj=imi,ng_sm - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= 1) then iwmij(imij) = iwmij(imij)+nlsm_ext(imi)*nlsm_ext(imj) cycle @@ -180,7 +180,7 @@ subroutine dbl_downwalk() use gugaci_global, only: iseg_downwei, iseg_sta, jud, just, lsm_inn, ng_sm, norb_dbl, norb_dz, norb_frz, ns_sm -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -202,7 +202,7 @@ ismj = lsm_inn(lrj) do lri=lrj,1,-1 ismi = lsm_inn(lri) - ismij = mul_tab(ismi,ismj) + ismij = Mul(ismi,ismj) if (ismij /= im) cycle just(lri,lrj) = nns nns = nns+iseg_downwei(17+im) @@ -219,16 +219,16 @@ nnd = 0 nns = 0 do lri=norb_frz+1,norb_dz - ismi = mul_tab(lsm_inn(lri),ns_sm) + ismi = Mul(lsm_inn(lri),ns_sm) if (ismi /= im) cycle jud(lri) = nnd nnd = nnd+1 end do do lri=norb_frz+1,norb_dz-1 - ismi = mul_tab(lsm_inn(lri),ns_sm) + ismi = Mul(lsm_inn(lri),ns_sm) do lrj=lri+1,norb_dz !tmp ismj = lsm_inn(lrj) - ismij = mul_tab(ismi,ismj) + ismij = Mul(ismi,ismj) if (ismij /= im) cycle just(lri,lrj) = nns nns = nns+1 @@ -241,10 +241,10 @@ end do end if do lri=norb_frz+1,norb_dz-1 - ismi = mul_tab(lsm_inn(lri),ns_sm) + ismi = Mul(lsm_inn(lri),ns_sm) do lrj=lri+1,norb_dz !tmp ismj = lsm_inn(lrj) - ismij = mul_tab(ismi,ismj) + ismij = Mul(ismi,ismj) if (ismij /= im) cycle just(lrj,lri) = nns nns = nns+1 @@ -257,7 +257,7 @@ ! lmi = lsm_inn(i) !to del ! do j=norb_frz+1,norb_dz !to del ! lmj = lsm_inn(j) !to del -! lsml(i,j) = mul_tab(lmi,lmj) !to del +! lsml(i,j) = Mul(lmi,lmj) !to del ! end do !to del !end do !to del !write(nf2,*) ' jud ...' !to del diff -Nru openmolcas-22.02/src/gugaci/ddsstt.F90 openmolcas-22.10/src/gugaci/ddsstt.F90 --- openmolcas-22.02/src/gugaci/ddsstt.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/ddsstt.F90 2022-10-10 14:22:40.000000000 +0000 @@ -32,7 +32,7 @@ call get_jpty(jpadlr,jptyl,jptyr) call get_jp(jptyl,jml,jpadl,1) call get_jp(jptyr,jmr,jpad,1) - !JMLR = MUL_TAB(JML,JMR) + !JMLR = Mul(JML,JMR) if (linelp <= 12) then call dd_ext_head_in_act() else @@ -49,7 +49,7 @@ use gugaci_global, only: ipae, ipael, jb_sys, jml, jmr, jpad, jpadl, jpadlr, jud, just, linelp, logic_dh, lp_lwei, lp_rwei, & lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, nlg1, nlg2, norb_dz, norb_frz, vplp_w0, vplp_w1, & vplpnew_w0, vplpnew_w1, w0_dd, w0_dv, w0_sd, w0_ss, w0_td, w0_tt, w0_vv, w1_dd, w1_ss, w1_st, w1_tt -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -60,7 +60,7 @@ integer(kind=iwp), external :: iwalk_ad LOGIC_DH = .true. -JMLR = MUL_TAB(JML,JMR) +JMLR = Mul(JML,JMR) LPOK = JPADLR select case (LPOK) case (1) @@ -114,7 +114,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((LMIJ /= JML) .or. (LMIJ /= JMR)) cycle IWDL = JUST(LRI,LRJ) IWDR = IWDL @@ -203,7 +203,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((LMIJ /= JML) .or. (LMIJ /= JMR)) cycle ! ST(2-5) (22)Drl(12)- ACT -C"- IWDL = JUST(LRI,LRJ) @@ -306,7 +306,7 @@ ! SD(6-2) C(22)-A&r(13)- do LRK=NORB_FRZ+1,LRI-1 LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) + LMKI = Mul(LMK,LMI) if ((LMKI == JML) .and. (LMK == JMR)) then IWDL = JUST(LRK,LRI) IWDR = JUD(LRK) @@ -326,7 +326,7 @@ ! SD(6-4) A&r(23)-C'(12)- do LRK=LRI+1,NORB_DZ LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) + LMKI = Mul(LMK,LMI) if ((LMKI /= JML) .or. (LMK /= JMR)) cycle !......................03_01.................................... !if (jroute_sys > 1) then @@ -383,7 +383,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((LMIJ /= JML) .or. (LMIJ /= JMR)) cycle ! TT(11-2) (22)Drl(22)- ! TT(11-2) Drl(22)-C"(22)- @@ -409,7 +409,7 @@ if (LRK == LRI) cycle if (LRK == LRJ) cycle LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) + LMKI = Mul(LMK,LMI) ! TT(11-3) Drl(33)-C"(22)-C"(22)- ! TT(11-3) (22)Drl(33)-C"(22)- ! TT(11-3) (22)(22)Drl(33)- @@ -531,7 +531,7 @@ do LRK=1,NORB_DZ if (LRK == LRI) cycle LMK = LSM_INN(LRK) - LMKI = MUL_TAB(LMK,LMI) + LMKI = Mul(LMK,LMI) call Drl_DD_EXT(LRK) end do end do @@ -540,7 +540,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (LMIJ /= JMLR) cycle W0DD1 = W0_DD(1) W1DD1 = W1_DD(1) @@ -685,7 +685,7 @@ use gugaci_global, only: idisk_array, idisk_lp, idownwei_g131415, iml, imr, ipae, ipael, iseg_downwei, jml, jmr, jpad, jpadl, & jpadlr, linelp, lpblock_ss, nvalue_space_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -698,7 +698,7 @@ call read_lp() IpaeL = iml+17 Ipae = imr+17 - imlr = mul_tab(iml,imr) + imlr = Mul(iml,imr) nvalue_space_ss = iseg_downwei(9+imlr) idownwei_g131415 = iseg_downwei(17+iml) !if (imlr == 1) imspace= i ml @@ -706,7 +706,7 @@ call get_jpty(jpadlr,jptyl,jptyr) call get_jp(jptyl,jml,jpadl,1) call get_jp(jptyr,jmr,jpad,1) - !JMLR = MUL_TAB(JML,JMR) + !JMLR = Mul(JML,JMR) if (linelp <= 12) then call ss_ext_head_in_act() else @@ -723,7 +723,7 @@ use gugaci_global, only: ipae, ipael, jb_sys, jml, jmr, jpad, jpadl, jpadlr, jud, just, linelp, logic_dh, lp_lwei, lp_rwei, & lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, nlg1, nlg2, norb_dz, norb_frz, vplp_w0, vplp_w1, & vplpnew_w0, vplpnew_w1, w0_dd, w0_dv, w0_ss, w0_tt, w0_vv, w1_dd, w1_ss, w1_st, w1_tt -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -733,7 +733,7 @@ integer(kind=iwp), external :: iwalk_ad LOGIC_DH = .true. -JMLR = MUL_TAB(JML,JMR) +JMLR = Mul(JML,JMR) LPOK = JPADLR select case (LPOK) case (1) @@ -786,7 +786,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((LMIJ /= JML) .or. (LMIJ /= JMR)) cycle IWDL = JUST(LRI,LRJ) IWDR = IWDL @@ -848,7 +848,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((LMIJ /= JML) .or. (LMIJ /= JMR)) cycle ! ST(2-5) (22)Drl(12)- ACT -C"- IWDL = JUST(LRI,LRJ) @@ -920,7 +920,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((LMIJ /= JML) .or. (LMIJ /= JMR)) cycle ! TT(11-2) (22)Drl(22)- ! TT(11-2) Drl(22)-C"(22)- @@ -1021,7 +1021,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (LMIJ /= JMLR) cycle W0DD1 = W0_DD(1) W1DD1 = W1_DD(1) @@ -1162,7 +1162,7 @@ use gugaci_global, only: idisk_array, idisk_lp, idownwei_g131415, iml, imr, ipae, ipael, iseg_downwei, jml, jmr, jpad, jpadl, & jpadlr, linelp, lpblock_st, nvalue_space_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -1175,14 +1175,14 @@ call read_lp() IpaeL = iml+17 Ipae = imr+9 - imlr = mul_tab(iml,imr) + imlr = Mul(iml,imr) idownwei_g131415 = iseg_downwei(9+iml) !(17+iml)??? nvalue_space_ss = iseg_downwei(9+imlr) call logicg_st(iml,imr,4,3) ! irtype=4(S),3(T) call get_jpty(jpadlr,jptyl,jptyr) call get_jp(jptyl,jml,jpadl,1) call get_jp(jptyr,jmr,jpad,1) - !JMLR = MUL_TAB(JML,JMR) + !JMLR = Mul(JML,JMR) if (linelp <= 12) then call st_ext_head_in_act() else @@ -1199,7 +1199,7 @@ use gugaci_global, only: ipae, ipael, jb_sys, jml, jmr, jpad, jpadl, jpadlr, jud, just, linelp, logic_dh, lp_lwei, lp_rwei, & lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, nlg1, nlg2, norb_dz, norb_frz, vplp_w0, vplp_w1, & vplpnew_w0, vplpnew_w1, w0_dd, w0_dv, w0_ss, w0_tt, w1_dd, w1_ss, w1_st, w1_tt -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1209,7 +1209,7 @@ integer(kind=iwp), external :: iwalk_ad LOGIC_DH = .true. -JMLR = MUL_TAB(JML,JMR) +JMLR = Mul(JML,JMR) LPOK = JPADLR select case (LPOK) case (1) @@ -1244,7 +1244,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((LMIJ /= JML) .or. (LMIJ /= JMR)) cycle IWDL = JUST(LRI,LRJ) IWDR = IWDL @@ -1324,7 +1324,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((LMIJ /= JML) .or. (LMIJ /= JMR)) cycle ! ST(2-5) (22)Drl(12)- ACT -C"- IWDL = JUST(LRI,LRJ) @@ -1413,7 +1413,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((LMIJ /= JML) .or. (LMIJ /= JMR)) cycle ! TT(11-2) (22)Drl(22)- ! TT(11-2) Drl(22)-C"(22)- @@ -1498,7 +1498,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (LMIJ /= JMLR) cycle W0DD1 = W0_DD(1) W1DD1 = W1_DD(1) @@ -1621,7 +1621,7 @@ use gugaci_global, only: idisk_array, idisk_lp, idownwei_g131415, iml, imr, ipae, ipael, iseg_downwei, jml, jmr, jpad, jpadl, & jpadlr, linelp, lpblock_ts, nvalue_space_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -1633,14 +1633,14 @@ call read_lp() IpaeL = iml+9 Ipae = imr+17 - imlr = mul_tab(iml,imr) + imlr = Mul(iml,imr) idownwei_g131415 = iseg_downwei(9+iml) !(17+iml)??? nvalue_space_ss = iseg_downwei(9+imlr) call logicg_st(iml,imr,3,4) ! irtype=4(S),3(T) call get_jpty(jpadlr,jptyl,jptyr) call get_jp(jptyl,jml,jpadl,1) call get_jp(jptyr,jmr,jpad,1) - !JMLR = MUL_TAB(JML,JMR) + !JMLR = Mul(JML,JMR) if (linelp <= 12) then call ts_ext_head_in_act() else @@ -1657,7 +1657,7 @@ use gugaci_global, only: ipae, ipael, jb_sys, jml, jmr, jpad, jpadl, jpadlr, jud, just, linelp, logic_dh, lp_lwei, lp_rwei, & lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, nlg1, nlg2, norb_dz, norb_frz, vplp_w0, vplp_w1, & vplpnew_w0, vplpnew_w1, w0_dd, w0_dv, w0_ss, w0_tt, w1_dd, w1_ss, w1_st, w1_tt -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -1667,7 +1667,7 @@ integer(kind=iwp), external :: iwalk_ad LOGIC_DH = .true. -JMLR = MUL_TAB(JML,JMR) +JMLR = Mul(JML,JMR) LPOK = JPADLR select case (LPOK) case (1) @@ -1702,7 +1702,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((LMIJ /= JML) .or. (LMIJ /= JMR)) cycle IWDL = JUST(LRI,LRJ) IWDR = IWDL @@ -1781,7 +1781,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((LMIJ /= JML) .or. (LMIJ /= JMR)) cycle ! ST(2-5) (22)Drl(12)- ACT -C"- IWDL = JUST(LRI,LRJ) @@ -1870,7 +1870,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((LMIJ /= JML) .or. (LMIJ /= JMR)) cycle ! TT(11-2) (22)Drl(22)- ! TT(11-2) Drl(22)-C"(22)- @@ -1955,7 +1955,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (LMIJ /= JMLR) cycle W0DD1 = W0_DD(1) W1DD1 = W1_DD(1) @@ -2078,7 +2078,7 @@ use gugaci_global, only: idisk_array, idisk_lp, idownwei_g131415, iml, imr, ipae, ipael, iseg_downwei, jml, jmr, jpad, jpadl, & jpadlr, linelp, lpblock_tt, nvalue_space_ss -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -2092,14 +2092,14 @@ IpaeL = iml+9 Ipae = imr+9 call logicg_st(iml,imr,3,3) ! irtype=3(T),lptype=5:ArBl- - imlr = mul_tab(iml,imr) + imlr = Mul(iml,imr) !if (imlr == 1) imspace = iml nvalue_space_ss = iseg_downwei(9+imlr) idownwei_g131415 = iseg_downwei(9+iml) call get_jpty(jpadlr,jptyl,jptyr) call get_jp(jptyl,jml,jpadl,1) call get_jp(jptyr,jmr,jpad,1) - !JMLR = MUL_TAB(JML,JMR) + !JMLR = Mul(JML,JMR) if (linelp <= 12) then call tt_ext_head_in_act() else @@ -2116,7 +2116,7 @@ use gugaci_global, only: ipae, ipael, jb_sys, jml, jmr, jpad, jpadl, jpadlr, jud, just, linelp, logic_dh, lp_lwei, lp_rwei, & lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, nlg1, nlg2, norb_dz, norb_frz, vplp_w0, vplp_w1, & vplpnew_w0, vplpnew_w1, w0_dd, w0_dv, w0_ss, w0_tt, w0_vv, w1_dd, w1_ss, w1_st, w1_tt -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -2126,7 +2126,7 @@ integer(kind=iwp), external :: iwalk_ad LOGIC_DH = .true. -JMLR = MUL_TAB(JML,JMR) +JMLR = Mul(JML,JMR) LPOK = JPADLR select case (LPOK) case (1) @@ -2183,7 +2183,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((LMIJ /= JML) .or. (LMIJ /= JMR)) cycle IWDL = JUST(LRI,LRJ) IWDR = IWDL @@ -2259,7 +2259,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((LMIJ /= JML) .or. (LMIJ /= JMR)) cycle ! ST(2-5) (22)Drl(12)- ACT -C"- IWDL = JUST(LRI,LRJ) @@ -2349,7 +2349,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if ((LMIJ /= JML) .or. (LMIJ /= JMR)) cycle ! TT(11-2) (22)Drl(22)- ! TT(11-2) Drl(22)-C"(22)- @@ -2459,7 +2459,7 @@ LMI = LSM_INN(LRI) do LRJ=LRI+1,NORB_DZ LMJ = LSM_INN(LRJ) - LMIJ = MUL_TAB(LMI,LMJ) + LMIJ = Mul(LMI,LMJ) if (LMIJ /= JMLR) cycle W0DD1 = W0_DD(1) W1DD1 = W1_DD(1) @@ -2603,14 +2603,14 @@ use gugaci_global, only: ism_g1415, ism_g2g4, logic_g13, logic_g1415, logic_g2g4a, logic_g2g4b, logic_g34a, logic_g34b, & logic_g35a, logic_g35b, logic_g36a, logic_g36b, lpend34a, lpend34b, lpend35a, lpend35b, lpend36a, & lpend36b, lpsta34a, lpsta34b, lpsta35a, lpsta35b, lpsta36a, lpsta36b -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none integer(kind=iwp), intent(in) :: ilnodesm, irnodesm, iltype, irtype integer(kind=iwp) :: iii, ilrsm -ilrsm = mul_tab(ilnodesm,irnodesm) +ilrsm = Mul(ilnodesm,irnodesm) iii = 1 !index to determine lwei rwei iposint and nlinkorb ! G2G4a G2G4b G1415 G13 logic_g36a = .false. diff -Nru openmolcas-22.02/src/gugaci/denmat.F90 openmolcas-22.10/src/gugaci/denmat.F90 --- openmolcas-22.02/src/gugaci/denmat.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/denmat.F90 2022-10-10 14:22:40.000000000 +0000 @@ -74,7 +74,7 @@ ! !use gugaci_global, only: denm1, denm2, FnOneMO, FnTwoMO, lenintegral, LuCiDen, LuOneMO, LuTwoMO, max_root, ng_sm, nlsm_all, & ! nlsm_bas, ntrabuf, ntratoc -!use Symmetry_Info, only: mul_tab => Mul +!use Symmetry_Info, only: Mul !use stdalloc, only: mma_allocate, mma_deallocate !use Constants, only: Zero, Two, Half !use Definitions, only: wp, iwp, u6 @@ -166,10 +166,10 @@ ! nop = norb(nsp) ! do nsq=1,nsp ! noq = norb(nsq) -! nspq = mul_tab(nsp,nsq) +! nspq = Mul(nsp,nsq) ! do nsr=1,nsp ! nor = norb(nsr) -! nspqr = mul_tab(nspq,nsr) +! nspqr = Mul(nspq,nsr) ! nssm = nsr ! if (nsr == nsp) nssm = nsq ! do nss=1,nssm @@ -404,7 +404,7 @@ subroutine ci_density_label_sm(iroot) use gugaci_global, only: denm1, denm2, dm1tmp, LuCiDen, map_orb_order, max_root, ng_sm, nlsm_all, vector2 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use stdalloc, only: mma_allocate, mma_deallocate use Constants, only: Zero, Two, Half use Definitions, only: wp, iwp @@ -461,14 +461,14 @@ if (nlsm_all(im) == 0) cycle do jm=1,im if (nlsm_all(jm) == 0) cycle - ijm = mul_tab(im,jm) + ijm = Mul(im,jm) do km=1,im if (nlsm_all(km) == 0) cycle le = km if (km == im) le = jm do lm=1,le if (nlsm_all(lm) == 0) cycle - klm = mul_tab(km,lm) + klm = Mul(km,lm) if (ijm /= klm) cycle ! ityp 1 (ii|jj) 2 (ii|jj) 3 (ij|ij) 4 (ij|kl) diff -Nru openmolcas-22.02/src/gugaci/drtrel.F90 openmolcas-22.10/src/gugaci/drtrel.F90 --- openmolcas-22.02/src/gugaci/drtrel.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/drtrel.F90 2022-10-10 14:22:40.000000000 +0000 @@ -226,7 +226,7 @@ !subroutine ref_gfs(nel,ndj,locu,nm) ! !use gugaci_global, only: lsm_inn, max_ref, norb_dz, norb_inn, nstart_act, spin -!use Symmetry_Info, only: mul_tab => Mul +!use Symmetry_Info, only: Mul !use stdalloc, only: mma_allocate, mma_deallocate !use Definitions, only: iwp, u6 ! @@ -260,14 +260,14 @@ ! lpsum = l1+l2+l3+l4+l5+l6+l7+l8 ! if (lpsum /= nes) cycle ! mys = 1 -! if (mod(l1,2) == 1) mys = mul_tab(mys,1) -! if (mod(l2,2) == 1) mys = mul_tab(mys,2) -! if (mod(l3,2) == 1) mys = mul_tab(mys,3) -! if (mod(l4,2) == 1) mys = mul_tab(mys,4) -! if (mod(l5,2) == 1) mys = mul_tab(mys,5) -! if (mod(l6,2) == 1) mys = mul_tab(mys,6) -! if (mod(l7,2) == 1) mys = mul_tab(mys,7) -! if (mod(l8,2) == 1) mys = mul_tab(mys,8) +! if (mod(l1,2) == 1) mys = Mul(mys,1) +! if (mod(l2,2) == 1) mys = Mul(mys,2) +! if (mod(l3,2) == 1) mys = Mul(mys,3) +! if (mod(l4,2) == 1) mys = Mul(mys,4) +! if (mod(l5,2) == 1) mys = Mul(mys,5) +! if (mod(l6,2) == 1) mys = Mul(mys,6) +! if (mod(l7,2) == 1) mys = Mul(mys,7) +! if (mod(l8,2) == 1) mys = Mul(mys,8) ! if (mys /= nm) cycle ! mdj = mdj+1 ! lscu(0,mdj) = lpsum diff -Nru openmolcas-22.02/src/gugaci/dvsdtd.F90 openmolcas-22.10/src/gugaci/dvsdtd.F90 --- openmolcas-22.02/src/gugaci/dvsdtd.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/dvsdtd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -27,7 +27,7 @@ call get_jpty(jpadlr,jptyl,jptyr) call get_jp(jptyl,jml,jpadl,1) call get_jp(jptyr,jmr,jpad,1) - !jmlr = mul_tab(jml,jmr) + !jmlr = Mul(jml,jmr) call gsd_determine_extarmode_paras(iml,imr,.false.) if (linelp <= 12) then call dv_ext_head_in_act() @@ -46,7 +46,7 @@ lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, nlg1, nlg2, norb_dz, & norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_dv, w0_sd, w0_sv, w0_td, w0_vv, w1_sd, w1_sv, & w1_td, w1_tv -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -60,7 +60,7 @@ logic_dh = .true. isma = iml lpok = jpadlr -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) select case (lpok) case (1) !=================================================================== @@ -199,7 +199,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle if (lmi == jmr) then @@ -384,7 +384,7 @@ lmi = lsm_inn(lri) do lrj=lri,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle w0sv2 = w0_sv(2) w1sv2 = w1_sv(2) @@ -460,7 +460,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle w0td1 = w0_td(1) w0td4 = w0_td(4) @@ -630,7 +630,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle w1tv = w1_tv @@ -903,7 +903,7 @@ call get_jpty(jpadlr,jptyl,jptyr) call get_jp(jptyl,jml,jpadl,1) call get_jp(jptyr,jmr,jpad,1) - !jmlr = mul_tab(jml,jmr) + !jmlr = Mul(jml,jmr) call gsd_determine_extarmode_paras(iml,imr,.true.) if (linelp <= 12) then call sd_ext_head_in_act() @@ -938,7 +938,7 @@ call get_jpty(jpadlr,jptyl,jptyr) call get_jp(jptyl,jml,jpadl,1) call get_jp(jptyr,jmr,jpad,1) - !jmlr = mul_tab(jml,jmr) + !jmlr = Mul(jml,jmr) call gsd_determine_extarmode_paras(iml,imr,.true.) if (linelp <= 12) then call sd_ext_head_in_act() @@ -957,7 +957,7 @@ lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, nlg1, nlg2, norb_dz, & norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_dv, w0_sd, w0_sv, w0_td, w0_vv, w1_sd, w1_sv, & w1_td, w1_tv -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -969,8 +969,8 @@ integer(kind=iwp), external :: iwalk_ad logic_dh = .true. -isma = mul_tab(iml,imr) -jmlr = mul_tab(jml,jmr) +isma = Mul(iml,imr) +jmlr = Mul(jml,jmr) lpok = jpadlr select case (lpok) case (1) @@ -1115,7 +1115,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle if (lmi == jmr) then @@ -1302,7 +1302,7 @@ lmi = lsm_inn(lri) do lrj=lri,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle w0sv2 = w0_sv(2) w1sv2 = w1_sv(2) @@ -1378,7 +1378,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle w0td1 = w0_td(1) w0td4 = w0_td(4) @@ -1552,7 +1552,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle w1tv = w1_tv @@ -1773,7 +1773,7 @@ subroutine sd_ext_head_in_act() use gugaci_global, only: iml, imr, linelp, logic_dh, nlg1, nlg2 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -1783,7 +1783,7 @@ lri = nlg1 lrj = nlg2 intpos = nlg1 -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) select case (linelp) case default ! (1) @@ -2093,7 +2093,7 @@ call get_jpty(jpadlr,jptyl,jptyr) call get_jp(jptyl,jml,jpadl,1) call get_jp(jptyr,jmr,jpad,1) - !jmlr = mul_tab(jml,jmr) + !jmlr = Mul(jml,jmr) call gsd_determine_extarmode_paras(iml,imr,.false.) if (linelp <= 12) then call td_ext_head_in_act() @@ -2112,7 +2112,7 @@ lp_lwei, lp_rwei, lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, ngw2, ngw3, nlg1, nlg2, norb_dz, & norb_frz, vplp_w0, vplp_w1, vplpnew_w0, vplpnew_w1, w0_dv, w0_sd, w0_sv, w0_td, w0_vv, w1_sd, w1_sv, & w1_td, w1_tv -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -2124,8 +2124,8 @@ integer(kind=iwp), external :: iwalk_ad logic_dh = .true. -isma = mul_tab(iml,imr) -jmlr = mul_tab(jml,jmr) +isma = Mul(iml,imr) +jmlr = Mul(jml,jmr) lpok = jpadlr select case (lpok) case (1) @@ -2268,7 +2268,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle if (lmi == jmr) then @@ -2456,7 +2456,7 @@ lmi = lsm_inn(lri) do lrj=lri,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle w0sv2 = w0_sv(2) w1sv2 = w1_sv(2) @@ -2532,7 +2532,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle w0td1 = w0_td(1) w0td4 = w0_td(4) @@ -2706,7 +2706,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle w1tv = w1_tv @@ -2926,7 +2926,7 @@ subroutine td_ext_head_in_act() use gugaci_global, only: iml, imr, linelp, logic_dh, nlg1, nlg2 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -2936,7 +2936,7 @@ lri = nlg1 lrj = nlg2 intpos = nlg1 -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) select case (linelp) case default ! (1) @@ -2965,7 +2965,7 @@ subroutine gsd_ext_sequence(iltype,ilsm,irsm,lri) use gugaci_global, only: ibsm_ext, icano_nnend, icano_nnsta, icnt_base, iesm_ext, iseg_downwei, isegdownwei, m_jc, m_jd, ng_sm -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -2992,13 +2992,13 @@ icano_nn = m_jc icano_nnend = icano_nn do ismb=1,ismnoded-1 - isma = mul_tab(ismnodes,ismb) + isma = Mul(ismnodes,ismb) if (isma > ismb) cycle call g31_diffsym(lri,isma,ismb) end do ismb = ismnoded - isma = mul_tab(ismnodes,ismb) + isma = Mul(ismnodes,ismb) if (isma == ismb) then call gsd_samesym_aaa(lri,isma) else if (isma < ismb) then @@ -3006,7 +3006,7 @@ end if do ismb=ismnoded+1,ng_sm - isma = mul_tab(ismnodes,ismb) + isma = Mul(ismnodes,ismb) if (isma > ismb) cycle if (ismnoded > isma) then call g32a_diffsym(lri,isma,ismb) diff -Nru openmolcas-22.02/src/gugaci/extloop1.F90 openmolcas-22.10/src/gugaci/extloop1.F90 --- openmolcas-22.02/src/gugaci/extloop1.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/extloop1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -358,7 +358,7 @@ use gugaci_global, only: ibsm_ext, ivaluesta_g26, iweista_g25, iweista_g26, iweista_g28, iwt_orb_ext, iwt_sm_s_ext, logic_g25a, & logic_g25b, logic_g26, logic_g28a, nint_g25, nint_g28, nlsm_ext, nwei_g25, nwei_g26, nwei_g28 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -366,7 +366,7 @@ logical(kind=iwp), intent(in) :: logic_sd integer(kind=iwp) :: iorbid, iorbisd, ismnodesd, numsmd, numsmsd -ismnodesd = mul_tab(ismnodes,ismnoded) +ismnodesd = Mul(ismnodes,ismnoded) numsmd = nlsm_ext(ismnoded) numsmsd = nlsm_ext(ismnodesd) iorbid = ibsm_ext(ismnoded) @@ -436,7 +436,7 @@ use gugaci_global, only: ibsm_ext, icano_nnend, icano_nnsta, icnt_base, iesm_ext, iwt_orb_ext, iwt_sm_s_ext, m_jc, m_jd, & max_tmpvalue, ng_sm, norb_ext -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -446,7 +446,7 @@ icano_nnsta = 2 icnt_base = 0 do ismd=1,ng_sm - ismc = mul_tab(ism,ismd) + ismc = Mul(ism,ismd) if (ismc > ismd) cycle id_sta = ibsm_ext(ismd) idsta = id_sta @@ -466,7 +466,7 @@ end if icano_nnend = icano_nn do ismb=1,ismd-1 - isma = mul_tab(ism,ismb) + isma = Mul(ism,ismb) if (isma > ismb) cycle if (ismc > ismb) then call g12_diffsym(isma,ismb,ismc) @@ -480,7 +480,7 @@ isma = ismd call g1112_symaaaa(isma,ic,id) else - isma = mul_tab(ism,ismd) + isma = Mul(ism,ismd) call g11a11b_symaacc(isma,ismd,ic,id) end if call g10_ext(ismc,ic,id) @@ -1223,14 +1223,14 @@ ! logic_g2g4b, logic_g34a, logic_g34b, logic_g35a, logic_g35b, logic_g36a, logic_g36b, lpend34a, lpend34b, & ! lpend35a, lpend35b, lpend36a, lpend36b, lpsta34a, lpsta34b, lpsta35a, lpsta35b, lpsta36a, lpsta36b, & ! nvalue_space_ss -!use Symmetry_Info, only: mul_tab => Mul +!use Symmetry_Info, only: Mul !use Definitions, only: iwp ! !implicit none !integer(kind=iwp), intent(in) :: ilnodesm, irnodesm, iltype, irtype, lptype !integer(kind=iwp) :: iii, ilrsm ! -!ilrsm = mul_tab(ilnodesm,irnodesm) +!ilrsm = Mul(ilnodesm,irnodesm) !iii = 1 !index to determine lwei rwei iposint and nlinkorb !! G2G4a G2G4b G1415 G13 !logic_g36a = .false. @@ -1316,7 +1316,7 @@ subroutine do_g36mode(ilrsm,ilnodesm,iii) use gugaci_global, only: ng_sm -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -1325,9 +1325,9 @@ integer(kind=iwp) :: isma, ismb, ismlink do ismb=1,ng_sm - isma = mul_tab(ismb,ilrsm) + isma = Mul(ismb,ilrsm) if (isma > ismb) cycle - ismlink = mul_tab(isma,ilnodesm) + ismlink = Mul(isma,ilnodesm) if (ismlink > isma) cycle call g36_form(isma,ismb,ismlink,iii) end do @@ -1337,7 +1337,7 @@ subroutine do_g34mode(ilrsm,ilnodesm,iii) use gugaci_global, only: ng_sm -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -1346,9 +1346,9 @@ integer(kind=iwp) :: isma, ismb, ismlink do ismb=1,ng_sm - isma = mul_tab(ismb,ilrsm) + isma = Mul(ismb,ilrsm) if (isma > ismb) cycle - ismlink = mul_tab(isma,ilnodesm) + ismlink = Mul(isma,ilnodesm) if (ismlink < ismb) cycle call g34_form(isma,ismb,ismlink,iii) end do @@ -1358,7 +1358,7 @@ subroutine do_g35mode(ilrsm,ilnodesm,iii) use gugaci_global, only: ng_sm -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -1367,9 +1367,9 @@ integer(kind=iwp) :: isma, ismb, ismlink do ismb=1,ng_sm - isma = mul_tab(ismb,ilrsm) + isma = Mul(ismb,ilrsm) if (isma > ismb) cycle - ismlink = mul_tab(isma,ilnodesm) + ismlink = Mul(isma,ilnodesm) if ((ismlink > ismb) .or. (ismlink < isma)) cycle call g35_form(isma,ismb,ismlink,iii) end do @@ -1504,7 +1504,7 @@ subroutine determine_para_array_for_int1ind() use gugaci_global, only: ng_sm, ngw2, ngw3, nlsm_ext, norb_ext -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -1513,10 +1513,10 @@ do ismabc=1,ng_sm nintcount = 0 do ismc=1,ng_sm - ismab = mul_tab(ismabc,ismc) + ismab = Mul(ismabc,ismc) numc = nlsm_ext(ismc) do ismb=1,ismc - isma = mul_tab(ismab,ismb) + isma = Mul(ismab,ismb) if (isma > ismb) cycle numb = nlsm_ext(ismb) numa = nlsm_ext(isma) @@ -1593,7 +1593,7 @@ subroutine g_tt_ext_sequence_G(ism) use gugaci_global, only: ibsm_ext, icano_nnend, icano_nnsta, icnt_base, iesm_ext, iwt_orb_ext, m_jc, m_jd, max_tmpvalue, ng_sm -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -1603,7 +1603,7 @@ icano_nnsta = 2 icnt_base = 0 do ismd=1,ng_sm - ismc = mul_tab(ism,ismd) + ismc = Mul(ism,ismd) if (ismc > ismd) cycle id_sta = ibsm_ext(ismd) idsta = id_sta @@ -1623,7 +1623,7 @@ end if icano_nnend = icano_nn do ismb=1,ismd-1 - isma = mul_tab(ism,ismb) + isma = Mul(ism,ismb) if (isma > ismb) cycle if (ismc > ismb) then call g12_t_diffsym_G(isma,ismb,ic,id) @@ -1637,7 +1637,7 @@ isma = ismd call g1112_t_symaaaa_G(isma,ic,id) else - isma = mul_tab(ism,ismd) + isma = Mul(ism,ismd) call g11a11b_t_symaacc_G(isma,ismd,ic,id) end if call g36_t_ext_G(ismc,ic,id) @@ -1655,7 +1655,7 @@ use gugaci_global, only: ibsm_ext, icano_nnend, icano_nnsta, icnt_base, iesm_ext, iwt_orb_ext, iwt_sm_s_ext, m_jc, m_jd, & max_tmpvalue, ng_sm, norb_ext -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -1665,7 +1665,7 @@ icano_nnsta = 2 icnt_base = 0 do ismd=1,ng_sm - ismc = mul_tab(ism,ismd) + ismc = Mul(ism,ismd) if (ismc > ismd) cycle id_sta = ibsm_ext(ismd) idsta = id_sta @@ -1685,7 +1685,7 @@ end if icano_nnend = icano_nn do ismb=1,ismd-1 - isma = mul_tab(ism,ismb) + isma = Mul(ism,ismb) if (isma > ismb) cycle if (ismc > ismb) then call g12_diffsym_G(isma,ismb,ic,id) @@ -1699,7 +1699,7 @@ isma = ismd call g1112_symaaaa_G(isma,ic,id) else - isma = mul_tab(ism,ismd) + isma = Mul(ism,ismd) call g11a11b_symaacc_G(isma,ismd,ic,id) end if call g10_ext_G(ismc,ic,id) diff -Nru openmolcas-22.02/src/gugaci/extploop.F90 openmolcas-22.10/src/gugaci/extploop.F90 --- openmolcas-22.02/src/gugaci/extploop.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/extploop.F90 2022-10-10 14:22:40.000000000 +0000 @@ -31,7 +31,7 @@ use gugaci_global, only: ibsm_ext, iesm_ext, intind_abkk, intspace_abkk, ism_g1415, logic_g1415, logic_g2g4a, ng_sm, norb_number, & value_lpext, vint_ci, voint, w0_plp, w0g2a, w0g36a, w1_plp, w1g14a, w1g2a, w1g36a -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -49,7 +49,7 @@ w1lp = w1_plp*w1g14a do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g1415) + isma = Mul(ismb,ism_g1415) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -916,7 +916,7 @@ use gugaci_global, only: ibsm_ext, iesm_ext, intind_abkk, intspace_abkk, ism_g1415, logic_g1415, logic_g2g4b, ng_sm, norb_number, & value_lpext, vint_ci, voint, w1_plp, w1g14a, w1g36a, w1g4b -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -932,7 +932,7 @@ w1lp = w1_plp*w1g14a do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g1415) + isma = Mul(ismb,ism_g1415) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -984,7 +984,7 @@ use gugaci_global, only: ibsm_ext, iesm_ext, intind_abkk, intspace_abkk, ism_g1415, logic_g1415, ng_sm, norb_number, value_lpext, & vint_ci, voint, w0_plp, w0g14a, w0g15a, w0g36a, w1_plp, w1g14a, w1g15a, w1g36a -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1006,7 +1006,7 @@ w15lp = w015-w115 do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g1415) + isma = Mul(ismb,ism_g1415) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -1045,7 +1045,7 @@ use gugaci_global, only: ibsm_ext, iesm_ext, intind_abkk, intspace_abkk, ism_g1415, logic_g1415, ng_sm, norb_dz, norb_number, & value_lpext, vijkk_0sum, vijkk_1sum, vint_ci, voint, w0_plp, w0g14a, w0g15a, w0g36a use stdalloc, only: mma_allocate, mma_deallocate -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1092,7 +1092,7 @@ w15lp = w015 do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g1415) + isma = Mul(ismb,ism_g1415) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -1216,7 +1216,7 @@ logic_g1415, logic_g2g4a, logic_g2g4b, ng_sm, ngw2, norb_ext, norb_frz, value_lpext, vint_ci, w0_plp, & w0g13a, w0g14a, w0g15a, w0g2a, w0g2b, w0g36a, w0g36b, w0g4a, w0g4b, w1_plp, w1g14a, w1g15a, w1g2a, w1g2b, & w1g36a, w1g36b, w1g4a, w1g4b -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Two use Definitions, only: wp, iwp @@ -1230,7 +1230,7 @@ ij = lri-norb_frz+ngw2(lrj-norb_frz) intpos = intind_ijcc(ij) intspace = intspace_ijcc(ij) -!lmij = mul_tab(lsm_inn(lri),lsm_inn(lrj)) +!lmij = Mul(lsm_inn(lri),lsm_inn(lrj)) ! G1415 if (logic_g1415) then @@ -1247,9 +1247,9 @@ ww1lp = -valuelptmp1*Two do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g1415) + isma = Mul(ismb,ism_g1415) if (isma > ismb) cycle - !lmab = mul_tab(isma,ismb) + !lmab = Mul(isma,ismb) !if (lmab /= lmij) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) diff -Nru openmolcas-22.02/src/gugaci/extploop_g.F90 openmolcas-22.10/src/gugaci/extploop_g.F90 --- openmolcas-22.02/src/gugaci/extploop_g.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/extploop_g.F90 2022-10-10 14:22:40.000000000 +0000 @@ -111,7 +111,7 @@ use gugaci_global, only: ibsm_ext, iesm_ext, index_lpext, index_lpext1, ism_g1415, logic_g1415, logic_g2g4b, ng_sm, norb_number, & value_lpext, value_lpext1, w1_plp, w1g14a, w1g36a, w1g4b -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Two use Definitions, only: wp, iwp @@ -133,7 +133,7 @@ w1lp = w1lp*Two do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g1415) + isma = Mul(ismb,ism_g1415) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -208,7 +208,7 @@ use gugaci_global, only: ibsm_ext, iesm_ext, index_lpext, index_lpext1, ism_g1415, logic_g1415, ng_sm, norb_number, value_lpext, & value_lpext1, w0_plp, w0g14a, w0g15a, w0g36a, w1_plp, w1g14a, w1g15a, w1g36a -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Two use Definitions, only: wp, iwp @@ -237,7 +237,7 @@ w15lp = w15lp*Two do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g1415) + isma = Mul(ismb,ism_g1415) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -293,7 +293,7 @@ use gugaci_global, only: ibsm_ext, iesm_ext, index_lpext, index_lpext1, ism_g1415, logic_g1415, ng_sm, norb_number, value_lpext, & value_lpext1, w0_plp, w0g14a, w0g15a, w0g36a, w1_plp, w1g14a, w1g15a -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Two use Definitions, only: wp, iwp @@ -321,7 +321,7 @@ w14lp = w14lp*Two w15lp = w15lp*Two do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g1415) + isma = Mul(ismb,ism_g1415) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -373,7 +373,7 @@ use gugaci_global, only: ibsm_ext, iesm_ext, index_lpext, index_lpext1, ism_g1415, logic_g1415, logic_g2g4a, ng_sm, norb_number, & value_lpext, value_lpext1, w1_plp, w1g14a, w1g2a, w1g36a -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Two use Definitions, only: wp, iwp @@ -394,7 +394,7 @@ w1lp = w1lp*Two do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g1415) + isma = Mul(ismb,ism_g1415) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -476,7 +476,7 @@ logic_g2g4b, lsm_inn, ng_sm, norb_ext, norb_number, value_lpext, value_lpext1, w0_plp, w0g13a, w0g14a, & w0g15a, w0g2a, w0g2b, w0g36a, w0g36b, w0g4a, w0g4b, w1_plp, w1g14a, w1g15a, w1g2a, w1g2b, w1g36a, w1g36b, & w1g4a, w1g4b -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Two use Definitions, only: wp, iwp @@ -503,7 +503,7 @@ ww1lp = -valuelptmp1*Two do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g1415) + isma = Mul(ismb,ism_g1415) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -557,7 +557,7 @@ lsmi = lsm_inn(lri) lsmj = lsm_inn(lrj) -lsmij = mul_tab(lsmi,lsmj) +lsmij = Mul(lsmi,lsmj) ! G2G4a if (logic_g2g4a) then @@ -575,7 +575,7 @@ ww1lp = -valuelptmp1*Two do lsmb=1,ng_sm - lsma = mul_tab(lsmij,lsmb) + lsma = Mul(lsmij,lsmb) if (lsma > lsmb) cycle ibsta = ibsm_ext(lsmb) ibend = iesm_ext(lsmb) @@ -623,7 +623,7 @@ ww1lp = -valuelptmp1*Two do lsmb=1,ng_sm - lsma = mul_tab(lsmij,lsmb) + lsma = Mul(lsmij,lsmb) if (lsma > lsmb) cycle ibsta = ibsm_ext(lsmb) ibend = iesm_ext(lsmb) @@ -665,7 +665,7 @@ w0lp = w0lp-w1lp w1lp = -valuelptmp1*Two do lsmb=1,ng_sm - lsma = mul_tab(lsmij,lsmb) + lsma = Mul(lsmij,lsmb) if (lsma > lsmb) cycle ibsta = ibsm_ext(lsmb) ibend = iesm_ext(lsmb) @@ -695,7 +695,7 @@ w0lp = w0lp-w1lp w1lp = -valuelptmp1*Two do lsmb=1,ng_sm - lsma = mul_tab(lsmij,lsmb) + lsma = Mul(lsmij,lsmb) if (lsma > lsmb) cycle ibsta = ibsm_ext(lsmb) ibend = iesm_ext(lsmb) @@ -725,7 +725,7 @@ use gugaci_global, only: ibsm_ext, index_lpext, index_lpext1, intind_ijka, lsm_inn, ngw2, ngw3, nlsm_ext, norb_frz, norb_inn, & norb_number, value_lpext, value_lpext1, w0_sdplp, w0_sdplp25, w0g25, w1_sdplp, w1_sdplp25 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -740,10 +740,10 @@ lsmi = lsm_inn(LRITMP) do LRJTMP=LRITMP+1,norb_inn-1 lsmj = lsm_inn(LRJTMP) - lsmij = mul_tab(lsmi,lsmj) + lsmij = Mul(lsmi,lsmj) do LRKTMP=LRJTMP+1,norb_inn lsmk = lsm_inn(LRKTMP) - if (mul_tab(lsmij,lsmk) /= isma) cycle + if (Mul(lsmij,lsmk) /= isma) cycle IJK = LRITMP-NORB_FRZ+NGW2(LRJTMP-NORB_FRZ)+NGW3(LRKTMP-NORB_FRZ) if (INTIND_IJKA(IJK) == intentry) then LRI = LRITMP @@ -777,7 +777,7 @@ use gugaci_global, only: ibsm_ext, index_lpext, index_lpext1, intind_ijka, lsm_inn, ngw2, ngw3, nlsm_ext, norb_frz, norb_inn, & norb_number, value_lpext, value_lpext1, w0_sdplp, w0_sdplp25, w0g25, w1_sdplp, w1_sdplp25 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Two use Definitions, only: iwp @@ -793,10 +793,10 @@ lsmi = lsm_inn(LRITMP) do LRJTMP=LRITMP+1,norb_inn-1 lsmj = lsm_inn(LRJTMP) - lsmij = mul_tab(lsmi,lsmj) + lsmij = Mul(lsmi,lsmj) do LRKTMP=LRJTMP+1,norb_inn lsmk = lsm_inn(LRKTMP) - if (mul_tab(lsmij,lsmk) /= isma) cycle + if (Mul(lsmij,lsmk) /= isma) cycle IJK = LRITMP-NORB_FRZ+NGW2(LRJTMP-NORB_FRZ)+NGW3(LRKTMP-NORB_FRZ) if (INTIND_IJKA(IJK) == intentry) then LRI = LRITMP @@ -829,7 +829,7 @@ use gugaci_global, only: ibsm_ext, index_lpext, index_lpext1, intind_ijka, lsm_inn, ngw2, ngw3, nlsm_ext, norb_frz, norb_inn, & norb_number, value_lpext, value_lpext1, w0_sdplp, w0_sdplp25, w0g25, w1_sdplp, w1_sdplp25 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Two use Definitions, only: iwp @@ -845,10 +845,10 @@ lsmi = lsm_inn(LRITMP) do LRJTMP=LRITMP+1,norb_inn-1 lsmj = lsm_inn(LRJTMP) - lsmij = mul_tab(lsmi,lsmj) + lsmij = Mul(lsmi,lsmj) do LRKTMP=LRJTMP+1,norb_inn lsmk = lsm_inn(LRKTMP) - if (mul_tab(lsmij,lsmk) /= isma) cycle + if (Mul(lsmij,lsmk) /= isma) cycle IJK = LRITMP-NORB_FRZ+NGW2(LRJTMP-NORB_FRZ)+NGW3(LRKTMP-NORB_FRZ) if (INTIND_IJKA(IJK) == intentry) then LRI = LRITMP @@ -976,7 +976,7 @@ subroutine gsd_ext_sequence_G(iltype,ilsm,irsm,lri) use gugaci_global, only: ibsm_ext, icano_nnend, icano_nnsta, icnt_base, iesm_ext, iseg_downwei, isegdownwei, m_jc, m_jd, ng_sm -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -1003,13 +1003,13 @@ icano_nn = m_jc icano_nnend = icano_nn do ismb=1,ismnoded-1 - isma = mul_tab(ismnodes,ismb) + isma = Mul(ismnodes,ismb) if (isma > ismb) cycle call g31_diffsym_G(lri,isma,ismb) end do ismb = ismnoded - isma = mul_tab(ismnodes,ismb) + isma = Mul(ismnodes,ismb) if (isma == ismb) then call gsd_samesym_aaa_G(lri,isma) else if (isma < ismb) then @@ -1017,7 +1017,7 @@ end if do ismb=ismnoded+1,ng_sm - isma = mul_tab(ismnodes,ismb) + isma = Mul(ismnodes,ismb) if (isma > ismb) cycle if (ismnoded > isma) then call g32a_diffsym_G(lri,isma,ismb) @@ -1470,7 +1470,7 @@ do ira=nlbf,irb-1 lra = norb_number(ira) !lsma = lsm(ira) - !lsmba = mul_tab(lsmb,lsma) + !lsmba = Mul(lsmb,lsma) ivalue = ivalue+1 call TRANS_IJKL_INTPOS(lra,lri,lrj,lrb,NXO) index_lpext(ivalue) = NXO @@ -1486,7 +1486,7 @@ do ira=nlbf,irb-1 lra = norb_number(ira) !lsma = lsm(ira) - !lsmba = mul_tab(lsmb,lsma) + !lsmba = Mul(lsmb,lsma) ivalue = ivalue+1 call TRANS_IJKL_INTPOS(lra,lrj,lrb,lri,NXO) index_lpext(ivalue) = NXO @@ -1598,7 +1598,7 @@ use gugaci_global, only: ibsm_ext, iesm_ext, index_lpext, index_lpext1, logic_g13, lsm_inn, ng_sm, norb_ext, norb_number, & value_lpext, value_lpext1, w0_plp, w0g13a, w0g36a, w1_plp, w1g36a -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1610,7 +1610,7 @@ ivalue = 0 lsmi = lsm_inn(lri) lsmj = lsm_inn(lrj) -lsmij = mul_tab(lsmi,lsmj) +lsmij = Mul(lsmi,lsmj) ! G36a w0lp = w0_plp*w0g36a w1lp = w1_plp*w1g36a @@ -1619,7 +1619,7 @@ w1lp = valuelptmp1+w1lp ! ArBr -- B^rA^r =10 do lsmc=1,ng_sm - lsmd = mul_tab(lsmij,lsmc) + lsmd = Mul(lsmij,lsmc) if (lsmd > lsmc) cycle icsta = ibsm_ext(lsmc) icend = iesm_ext(lsmc) diff -Nru openmolcas-22.02/src/gugaci/gpcsf.F90 openmolcas-22.10/src/gugaci/gpcsf.F90 --- openmolcas-22.02/src/gugaci/gpcsf.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/gpcsf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -233,7 +233,7 @@ subroutine config_dbl() use gugaci_global, only: ipae, iw_downwei, jb_sys, jpad, jud, just, lsm_inn, norb_dbl, norb_dz, norb_frz, ns_sm, nu_ae -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -254,7 +254,7 @@ end do !jps = js(1) do lr0=norb_frz+1,norb_dz - mr0 = mul_tab(lsm_inn(lr0),ns_sm) + mr0 = Mul(lsm_inn(lr0),ns_sm) iwd = jud(lr0) jpad = 1+mr0 jpad1 = jpad+24 @@ -300,7 +300,7 @@ !wld0 = wld do lr=lr0+1,norb_dz - mr = mul_tab(mr0,lsm_inn(lr)) + mr = Mul(mr0,lsm_inn(lr)) jpat = 9+mr jpas = 17+mr jpat1 = jpat+24 @@ -349,7 +349,7 @@ subroutine config_ext() use gugaci_global, only: ibsm_ext, iesm_ext, ipae, lsm, norb_ext -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -397,7 +397,7 @@ do lb=1,la-1 !lrbi = norb_all-lb+1 imb = lsm(lb) - mr = mul_tab(ima,imb) + mr = Mul(ima,imb) if (mr /= im) cycle !jps = js(mr) !jpt = jt(mr) diff -Nru openmolcas-22.02/src/gugaci/innloop.F90 openmolcas-22.10/src/gugaci/innloop.F90 --- openmolcas-22.02/src/gugaci/innloop.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/innloop.F90 2022-10-10 14:22:40.000000000 +0000 @@ -100,7 +100,7 @@ subroutine cloop_in_act() use gugaci_global, only: logic_br, lsm_inn, norb_dz, norb_inn -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -110,7 +110,7 @@ lmi = lsm_inn(lrai) do lraj=lrai+1,norb_inn lmj = lsm_inn(lraj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) !------------------------------------------------------------------- ! line=8 d&r&r--d^r^r call head_drr_at_given_orb(mh,lrai) @@ -126,7 +126,7 @@ call tail_drl_at_given_orb(mh) !write(u6,'(6i6)') 9,mh,lrai,lraj,0,0 if (mh /= 0) call act_cloop(9,mh,lrai,lraj,0,0) - lsmij = mul_tab(lmi,lmj) + lsmij = Mul(lmi,lmj) !------------------------------------------------------------------- if (lsmij == 1) then !----------------------------------------------------------------- @@ -204,10 +204,10 @@ if (lraj > norb_inn-2) cycle do lrak=lraj+1,norb_inn lmk = lsm_inn(lrak) - lmk = mul_tab(lmij,lmk) + lmk = Mul(lmij,lmk) do lral=lrak+1,norb_inn lml = lsm_inn(lral) - lml = mul_tab(lmk,lml) + lml = Mul(lmk,lml) if (lml /= 1) cycle ! line=4 a&r--b&r--b^r--a^r call head_ar_at_given_orb(mh,lrai) @@ -596,7 +596,7 @@ !use gugaci_global, only: jb_sys, jml, jmr, jpad, jpadl, jpel, jper, jud, just, jwl, jwr, kk, line, lrg, lrs, lsm_inn, map_jplr, & ! norb_dz, norb_frz, norb_inn, ns_sm, vint_ci, voint, w0, w0_d1s, w0_d1t1, w0_d1v, w0_ds, w0_dt, w0_dv, & ! w0_td, w0_vv, w1, w1_d1s, w1_d1t1, w1_ds, w1_dt, w1_t1v, w1_td, w1_tv -!use Symmetry_Info, only: mul_tab => Mul +!use Symmetry_Info, only: Mul !use Constants, only: Zero, Two, Half !use Definitions, only: wp, iwp ! @@ -625,9 +625,9 @@ !if (jpad == 1) itypadr = 1 !if (jpadl == 1) jml = ns_sm !if (jpad == 1) jmr = ns_sm -!jml = mul_tab(jml,ns_sm) -!jmr = mul_tab(jmr,ns_sm) -!jmlr = mul_tab(jml,jmr) +!jml = Mul(jml,ns_sm) +!jmr = Mul(jmr,ns_sm) +!jmlr = Mul(jml,jmr) !lpok = map_jplr(itypadl,itypadr) !if (lpok == 0) return !select case (line) @@ -656,7 +656,7 @@ ! do lrj=lri+1,norb_dz ! ! ds(7-3) ar(23)-bl(32)-br(31)- ! lmj = lsm_inn(lrj) -! lmij = mul_tab(lmi,lmj) +! lmij = Mul(lmi,lmj) ! if (lmij /= jmr) cycle ! do lrd=norb_frz+1,lri-1 ! iwdr = just(lri,lrj) @@ -709,7 +709,7 @@ ! call prodab(3,jpel,iwdl,iwdr,jwl,jwr,wl,jper) ! end if ! ! d1s(9-4) drl(12)-br(31)- -! if ((jml == lmd) .and. (jmr == mul_tab(lmd,lmi))) then +! if ((jml == lmd) .and. (jmr == Mul(lmd,lmi))) then ! iwdr = just(lrd,lri) ! iwdl = jud(lrd) ! w1ds = w1_d1s(4) @@ -726,7 +726,7 @@ ! do lrj=lri+1,norb_dz ! ! d1s(9-3) ar(13)-bl(32)-br(31)- ! lmj = lsm_inn(lrj) -! lmij = mul_tab(lmi,lmj) +! lmij = Mul(lmi,lmj) ! if (lmij /= jmr) cycle ! do lrd=norb_frz+1,lri-1 ! iwdr = just(lri,lrj) @@ -767,12 +767,12 @@ ! lmi = lsm_inn(lri) ! do lrj=lri+1,norb_dz ! lmj = lsm_inn(lrj) -! lmij = mul_tab(lmi,lmj) +! lmij = Mul(lmi,lmj) ! if (lmij /= jmr) cycle ! iwdr = just(lri,lrj) ! do lrd=norb_frz+1,lri-1 ! lmd = lsm_inn(lrd) -! lmd = mul_tab(lmd,1) +! lmd = Mul(lmd,1) ! if (lmd /= jml) cycle ! iwdl = jud(lrd) ! vlop0 = w0*w0_dt @@ -795,12 +795,12 @@ ! lmi = lsm_inn(lri) ! do lrj=lri+1,norb_dz ! lmj = lsm_inn(lrj) -! lmij = mul_tab(lmi,lmj) +! lmij = Mul(lmi,lmj) ! if (lmij /= jmr) cycle ! iwdr = just(lri,lrj) ! do lrd=norb_frz+1,lri-1 ! lmd = lsm_inn(lrd) -! lmd = mul_tab(lmd,1) +! lmd = Mul(lmd,1) ! if (lmd /= jml) cycle ! iwdl = jud(lrd) ! vlop0 = w0*w0_d1t1 @@ -916,7 +916,7 @@ ! lmi = lsm_inn(lri) ! do lrj=lri+1,norb_dz ! lmj = lsm_inn(lrj) -! lmij = mul_tab(lmi,lmj) +! lmij = Mul(lmi,lmj) ! if (lmij /= jml) cycle ! iwdl = just(lri,lrj) ! @@ -1063,7 +1063,7 @@ ! imi = lsm_inn(lri) ! do lrj=lri,norb_dz ! imj = lsm_inn(lrj) -! imij = mul_tab(imi,imj) +! imij = Mul(imi,imj) ! if (imij /= jml) cycle ! iwdl = just(lri,lrj) ! vlop1 = w1*w1_tv !d17 vlop0=0 @@ -1080,7 +1080,7 @@ ! imi = lsm_inn(lri) ! do lrj=lri,norb_dz ! imj = lsm_inn(lrj) -! imij = mul_tab(imi,imj) +! imij = Mul(imi,imj) ! if (imij /= jml) cycle ! iwdl = just(lri,lrj) ! vlop1 = w1*w1_t1v !d18 vlop0=0 @@ -1159,7 +1159,7 @@ ! lmi = lsm_inn(lri) ! do lrj=lri+1,norb_dz ! lmj = lsm_inn(lrj) -! lmij = mul_tab(lmi,lmj) +! lmij = Mul(lmi,lmj) ! if (lmij /= jml) cycle ! w1tv = w1_tv ! if (mod(lrj-lri,2) == 0) w1tv = -w1tv @@ -1178,7 +1178,7 @@ ! lmi = lsm_inn(lri) ! do lrj=lri+1,norb_dz ! lmj = lsm_inn(lrj) -! lmij = mul_tab(lmi,lmj) +! lmij = Mul(lmi,lmj) ! if (lmij /= jml) cycle ! w1tv = w1_t1v ! if (mod(lrj-lri,2) == 0) w1tv = -w1tv @@ -1623,7 +1623,7 @@ subroutine dbl_td_act_comp(lin,lra) use gugaci_global, only: jml, jmr, jpel, jper, jud, just, jwl, jwr, lrg, lrs, lsm_inn, norb_dz, norb_frz, w0, w0_td, w1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1640,7 +1640,7 @@ ! td(13-5) d&rl(33)c"(22)b^l(23) ! td(13-5) d&rl(33)b^l(23)c'(22) -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -1682,7 +1682,7 @@ subroutine dbl_ttdd_act_comp(lin,lra) use gugaci_global, only: jml, jmr, jpel, jper, jud, just, jwl, jwr, lrg, lrs, lsm_inn, norb_dz, norb_frz, w0, w0_t1d1, w1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1693,7 +1693,7 @@ ! t1d1(15-1) ar(13)- ! t1d1(15-1) ar(13)-c'(11)- -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -1814,7 +1814,7 @@ ! sd(6-4) a&r(23)c'(12)- use gugaci_global, only: jb_sys, jml, jmr, jpel, jper, jud, just, jwl, jwr, lrg, lrs, lsm_inn, norb_dz, norb_frz, w0, w0_sd, w1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1822,7 +1822,7 @@ integer(kind=iwp) :: iwdl, iwdr, jmlr, lmi, lmk, lri, lrk, ni real(kind=wp) :: vlop0, vlop1, w0sd1, w0sd2, w0sd3, w0sd4, wl -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -1894,7 +1894,7 @@ !sd1(8-4) ar(23)-c'(11)- use gugaci_global, only: jb_sys, jml, jmr, jpel, jper, jud, just, jwl, jwr, lrg, lrs, lsm_inn, norb_dz, norb_frz, w0, w0_sd1, w1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1902,7 +1902,7 @@ integer(kind=iwp) :: iwdl, iwdr, jmlr, lmi, lmk, lri, lrk, ni real(kind=wp) :: vlop0, vlop1, w0sd1, w0sd2, w0sd3, w0sd4, wl -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -2010,7 +2010,7 @@ subroutine g_tt_ext_sequence(ism) use gugaci_global, only: ibsm_ext, icano_nnend, icano_nnsta, icnt_base, iesm_ext, iwt_orb_ext, m_jc, m_jd, max_tmpvalue, ng_sm -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -2020,7 +2020,7 @@ icano_nnsta = 2 icnt_base = 0 do ismd=1,ng_sm - ismc = mul_tab(ism,ismd) + ismc = Mul(ism,ismd) if (ismc > ismd) cycle id_sta = ibsm_ext(ismd) idsta = id_sta @@ -2040,7 +2040,7 @@ end if icano_nnend = icano_nn do ismb=1,ismd-1 - isma = mul_tab(ism,ismb) + isma = Mul(ism,ismb) if (isma > ismb) cycle if (ismc > ismb) then call g12_t_diffsym(isma,ismb,ismc) @@ -2054,7 +2054,7 @@ isma = ismd call g1112_t_symaaaa(isma,ic,id) else - isma = mul_tab(ism,ismd) + isma = Mul(ism,ismd) call g11a11b_t_symaacc(isma,ismd,ic,id) end if call g36_t_ext(ismc,ic,id) @@ -2076,7 +2076,7 @@ use gugaci_global, only: jb_sys, jml, jmr, jpad, jpadl, jpel, jper, jud, just, jwl, jwr, kk, line, lrg, lrs, lsm_inn, map_jplr, & norb_dz, norb_frz, norb_inn, ns_sm, vint_ci, voint, w0, w0_d1s, w0_d1t1, w0_d1v, w0_ds, w0_dt, w0_dv, & w0_td, w0_vv, w1, w1_d1s, w1_d1t1, w1_ds, w1_dt, w1_t1v, w1_td, w1_tv -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero, Two, Half use Definitions, only: wp, iwp @@ -2105,9 +2105,9 @@ if (jpad == 1) itypadr = 1 if (jpadl == 1) jml = ns_sm if (jpad == 1) jmr = ns_sm -jml = mul_tab(jml,ns_sm) -jmr = mul_tab(jmr,ns_sm) -jmlr = mul_tab(jml,jmr) +jml = Mul(jml,ns_sm) +jmr = Mul(jmr,ns_sm) +jmlr = Mul(jml,jmr) lpok = map_jplr(itypadl,itypadr) if (lpok == 0) return select case (line) @@ -2137,7 +2137,7 @@ end if do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmr) cycle do lrd=norb_frz+1,lri-1 lmd = lsm_inn(lrd) @@ -2191,7 +2191,7 @@ call prodab(3,jpel,iwdl,iwdr,jwl,jwr,wl,jper) end if ! d1s(9-4) drl(12)-br(31)- - if ((jml == lmd) .and. (jmr == mul_tab(lmd,lmi))) then + if ((jml == lmd) .and. (jmr == Mul(lmd,lmi))) then iwdr = just(lrd,lri) iwdl = jud(lrd) w1ds = w1_d1s(4) @@ -2208,7 +2208,7 @@ do lrj=lri+1,norb_dz ! d1s(9-3) ar(13)-bl(32)-br(31)- lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmr) cycle do lrd=norb_frz+1,lri-1 iwdr = just(lri,lrj) @@ -2249,7 +2249,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmr) cycle iwdr = just(lri,lrj) do lrd=norb_frz+1,lri-1 @@ -2276,12 +2276,12 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmr) cycle iwdr = just(lri,lrj) do lrd=norb_frz+1,lri-1 lmd = lsm_inn(lrd) - lmd = mul_tab(lmd,1) + lmd = Mul(lmd,1) if (lmd /= jml) cycle iwdl = jud(lrd) vlop0 = w0*w0_d1t1 @@ -2413,7 +2413,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle iwdl = just(lri,lrj) @@ -2560,7 +2560,7 @@ imi = lsm_inn(lri) do lrj=lri,norb_dz imj = lsm_inn(lrj) - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= jml) cycle iwdl = just(lri,lrj) vlop1 = w1*w1_tv !d17 vlop0=0 @@ -2577,7 +2577,7 @@ imi = lsm_inn(lri) do lrj=lri,norb_dz imj = lsm_inn(lrj) - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= jml) cycle iwdl = just(lri,lrj) vlop1 = w1*w1_t1v !d18 vlop0=0 @@ -2654,7 +2654,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle w1tv = w1_tv if (mod(lrj-lri,2) == 0) w1tv = -w1tv @@ -2673,7 +2673,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle w1tv = w1_t1v if (mod(lrj-lri,2) == 0) w1tv = -w1tv diff -Nru openmolcas-22.02/src/gugaci/innloop_g.F90 openmolcas-22.10/src/gugaci/innloop_g.F90 --- openmolcas-22.02/src/gugaci/innloop_g.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/innloop_g.F90 2022-10-10 14:22:40.000000000 +0000 @@ -98,7 +98,7 @@ subroutine cloop_in_act_g() use gugaci_global, only: logic_br, lsm_inn, norb_dz, norb_inn -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -108,7 +108,7 @@ lmi = lsm_inn(lrai) do lraj=lrai+1,norb_inn lmj = lsm_inn(lraj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) !------------------------------------------------------------------- ! line=8 d&r&r--d^r^r call head_drr_at_given_orb(mh,lrai) @@ -124,7 +124,7 @@ call tail_drl_at_given_orb(mh) !write(u6,'(6i6)') 9,mh,lrai,lraj,0,0 if (mh /= 0) call act_cloop_g(9,mh,lrai,lraj,0,0) - lsmij = mul_tab(lmi,lmj) + lsmij = Mul(lmi,lmj) !------------------------------------------------------------------- if (lsmij == 1) then !----------------------------------------------------------------- @@ -202,10 +202,10 @@ if (lraj > norb_inn-2) cycle do lrak=lraj+1,norb_inn lmk = lsm_inn(lrak) - lmk = mul_tab(lmij,lmk) + lmk = Mul(lmij,lmk) do lral=lrak+1,norb_inn lml = lsm_inn(lral) - lml = mul_tab(lmk,lml) + lml = Mul(lmk,lml) if (lml /= 1) cycle ! line=4 a&r--b&r--b^r--a^r call head_ar_at_given_orb(mh,lrai) @@ -605,7 +605,7 @@ subroutine dbl_td_act_comp_g(lin,lra) use gugaci_global, only: jml, jmr, jpel, jper, jud, just, jwl, jwr, lrg, lrs, lsm_inn, norb_dz, norb_frz, w0, w0_td, w1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -622,7 +622,7 @@ ! td(13-5) d&rl(33)c"(22)b^l(23) ! td(13-5) d&rl(33)b^l(23)c'(22) -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -670,7 +670,7 @@ subroutine dbl_ttdd_act_comp_g(lin,lra) use gugaci_global, only: jml, jmr, jpel, jper, jud, just, jwl, jwr, lrg, lrs, lsm_inn, norb_dz, norb_frz, w0, w0_t1d1, w1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -681,7 +681,7 @@ ! t1d1(15-1) ar(13)- ! t1d1(15-1) ar(13)-c'(11)- -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -886,7 +886,7 @@ !sd(6-4) a&r(23)c'(12)- use gugaci_global, only: jb_sys, jml, jmr, jpel, jper, jud, just, jwl, jwr, lrg, lrs, lsm_inn, norb_dz, norb_frz, w0, w0_sd, w1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -894,7 +894,7 @@ integer(kind=iwp) :: iwdl, iwdr, jmlr, list0, list1, lmi, lmk, lri, lrk, ni real(kind=wp) :: vlop0, vlop1, w0sd1, w0sd2, w0sd3, w0sd4, wl0, wl1 -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -978,7 +978,7 @@ ! sd1(8-4) ar(23)-c'(11)- use gugaci_global, only: jb_sys, jml, jmr, jpel, jper, jud, just, jwl, jwr, lrg, lrs, lsm_inn, norb_dz, norb_frz, w0, w0_sd1, w1 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -986,7 +986,7 @@ integer(kind=iwp) :: iwdl, iwdr, jmlr, list0, list1, lmi, lmk, lri, lrk, ni real(kind=wp) :: vlop0, vlop1, w0sd1, w0sd2, w0sd3, w0sd4, wl0, wl1 -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) do lri=norb_frz+1,norb_dz lmi = lsm_inn(lri) if (lmi /= jmlr) cycle @@ -1108,7 +1108,7 @@ use gugaci_global, only: jb_sys, jml, jmr, jpad, jpadl, jpel, jper, jud, just, jwl, jwr, kk, line, lrg, lrs, lsm_inn, map_jplr, & norb_dz, norb_frz, norb_inn, ns_sm, w0, w0_d1s, w0_d1t1, w0_d1v, w0_ds, w0_dt, w0_dv, w0_td, w0_vv, w1, & w1_d1s, w1_d1t1, w1_ds, w1_dt, w1_t1v, w1_td, w1_tv -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero, Two, Half use Definitions, only: wp, iwp @@ -1136,9 +1136,9 @@ if (jpad == 1) itypadr = 1 if (jpadl == 1) jml = ns_sm if (jpad == 1) jmr = ns_sm -jml = mul_tab(jml,ns_sm) -jmr = mul_tab(jmr,ns_sm) -jmlr = mul_tab(jml,jmr) +jml = Mul(jml,ns_sm) +jmr = Mul(jmr,ns_sm) +jmlr = Mul(jml,jmr) lpok = map_jplr(itypadl,itypadr) if (lpok == 0) return @@ -1172,7 +1172,7 @@ end if do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmr) cycle do lrd=norb_frz+1,lri-1 lmd = lsm_inn(lrd) @@ -1244,7 +1244,7 @@ call prodab_2(3,jpel,iwdl,iwdr,jwl,jwr,wl,jper,nxo) end if ! d1s(9-4) drl(12)-br(31)- - if ((jml == lmd) .and. (jmr == mul_tab(lmd,lmi))) then + if ((jml == lmd) .and. (jmr == Mul(lmd,lmi))) then iwdr = just(lrd,lri) iwdl = jud(lrd) w1ds = w1_d1s(4) @@ -1264,7 +1264,7 @@ do lrj=lri+1,norb_dz ! d1s(9-3) ar(13)-bl(32)-br(31)- lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmr) cycle do lrd=norb_frz+1,lri-1 iwdr = just(lri,lrj) @@ -1317,7 +1317,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmr) cycle iwdr = just(lri,lrj) do lrd=norb_frz+1,lri-1 @@ -1350,12 +1350,12 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmr) cycle iwdr = just(lri,lrj) do lrd=norb_frz+1,lri-1 lmd = lsm_inn(lrd) - lmd = mul_tab(lmd,1) + lmd = Mul(lmd,1) if (lmd /= jml) cycle iwdl = jud(lrd) vlop0 = w0*w0_d1t1 @@ -1557,7 +1557,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle iwdl = just(lri,lrj) @@ -1769,7 +1769,7 @@ imi = lsm_inn(lri) do lrj=lri,norb_dz imj = lsm_inn(lrj) - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= jml) cycle iwdl = just(lri,lrj) vlop1 = w1*w1_tv !d17 vlop0=0 @@ -1788,7 +1788,7 @@ imi = lsm_inn(lri) do lrj=lri,norb_dz imj = lsm_inn(lrj) - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= jml) cycle iwdl = just(lri,lrj) vlop1 = w1*w1_t1v !d18 vlop0=0 @@ -1870,7 +1870,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle w1tv = w1_tv if (mod(lrj-lri,2) == 0) w1tv = -w1tv @@ -1896,7 +1896,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jml) cycle w1tv = w1_t1v if (mod(lrj-lri,2) == 0) w1tv = -w1tv diff -Nru openmolcas-22.02/src/gugaci/intsort.F90 openmolcas-22.10/src/gugaci/intsort.F90 --- openmolcas-22.02/src/gugaci/intsort.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/intsort.F90 2022-10-10 14:22:40.000000000 +0000 @@ -160,7 +160,7 @@ !subroutine blocks() ! !use gugaci_global, only: ng_sm, nlsm_all -!use Symmetry_Info, only: mul_tab => Mul +!use Symmetry_Info, only: Mul !use Definitions, only: iwp, u6 ! !implicit none @@ -221,11 +221,11 @@ ! do iq=1,iqm-1 ! if (nlsm_all(iq) == 0) cycle ! npq = nlsm_all(ip)*nlsm_all(iq) -! ispq = mul_tab(ip,iq) +! ispq = Mul(ip,iq) ! irm = ip ! do ir=1,irm-1 ! if (nlsm_all(ir) == 0) cycle -! ispqr = mul_tab(ispq,ir) +! ispqr = Mul(ispq,ir) ! ism = ir ! if (ip == ir) ism = iq ! do is=1,ism-1 @@ -288,7 +288,7 @@ use gugaci_global, only: ibsm_ext, iesm_ext, ip2_aa_ext_base, ip2_dd_ext_base, ip3_abd_ext_base, ip4_abcd_ext_base, jp2, jp3, & ng_sm, nlsm_ext, norb_ext, norb_number, np3_abd_ext, vint_ci, voint -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -369,9 +369,9 @@ icsta = ibsm_ext(lsmc) icend = iesm_ext(lsmc) if (lsmc == lsmd) idsta = idsta+1 - lsmcd = mul_tab(lsmc,lsmd) + lsmcd = Mul(lsmc,lsmd) do lsmb=1,lsmc - lsma = mul_tab(lsmb,lsmcd) + lsma = Mul(lsmb,lsmcd) if (lsma > lsmb) cycle ibsta = ibsm_ext(lsmb) ibend = iesm_ext(lsmb) @@ -413,7 +413,7 @@ subroutine int_sort_inn_2(ii) use gugaci_global, only: ibsm_ext, iesm_ext, intind_abkk, intspace_abkk, lsm_inn, ng_sm, norb_frz, norb_inn, norb_number, vint_ci -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -428,7 +428,7 @@ lsmi = lsm_inn(lri) do lrj=lri+1,norb_inn lsmj = lsm_inn(lrj) - lsmij = mul_tab(lsmi,lsmj) + lsmij = Mul(lsmi,lsmj) if (ismab /= lsmij) cycle call int_ext_2_1(lri,lrj,lsmij,ii) end do @@ -464,7 +464,7 @@ use gugaci_global, only: ibsm_ext, iesm_ext, intind_ijab, intind_ijcc, intspace_ijab, intspace_ijcc, ng_sm, ngw2, norb_ext, & norb_frz, norb_number, vint_ci -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -491,7 +491,7 @@ intind_ijab(ij) = ii intspace_ijab(ij) = 0 do lsmc=1,ng_sm - lsmd = mul_tab(lsmij,lsmc) + lsmd = Mul(lsmij,lsmc) if (lsmd > lsmc) cycle icsta = ibsm_ext(lsmc) icend = iesm_ext(lsmc) @@ -514,7 +514,7 @@ return -end +end subroutine int_ext_2_1 !===================== ext_2_1 end ===================================== @@ -523,7 +523,7 @@ subroutine int_sort_inn_3(ii) use gugaci_global, only: ibsm_ext, iesm_ext, intind_ijka, lsm_inn, ngw2, ngw3, norb_frz, norb_inn, norb_number, vint_ci -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -537,10 +537,10 @@ lsmi = lsm_inn(lri) do lrj=lri+1,norb_inn-1 lsmj = lsm_inn(lrj) - lsmij = mul_tab(lsmi,lsmj) + lsmij = Mul(lsmi,lsmj) do lrk=lrj+1,norb_inn lsmk = lsm_inn(lrk) - lsmd = mul_tab(lsmij,lsmk) + lsmd = Mul(lsmij,lsmk) ijk = lri-norb_frz+ngw2(lrj-norb_frz)+ngw3(lrk-norb_frz) intind_ijka(ijk) = ii iasta = ibsm_ext(lsmd) @@ -565,7 +565,7 @@ use gugaci_global, only: ibsm_ext, iesm_ext, intind_iabc, intind_iaqq, nabc, ng_sm, ngw2, ngw3, norb_ext, norb_inn, norb_number, & vint_ci -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -579,9 +579,9 @@ iabc0 = (lri-1)*nabc !write(10,*) ' start intind_iabc',ii do lsmd=1,ng_sm - lsmbc = mul_tab(lsmi,lsmd) + lsmbc = Mul(lsmi,lsmd) do lsmc=1,lsmd - lsmb = mul_tab(lsmbc,lsmc) + lsmb = Mul(lsmbc,lsmc) if (lsmb > lsmc) cycle idsta = ibsm_ext(lsmd) idend = iesm_ext(lsmd) @@ -696,7 +696,7 @@ subroutine int_sort_inn(numb) use gugaci_global, only: loij, loijk, lsm_inn, ncibl, ngw2, ngw3, norb_inn, vint_ci -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -738,10 +738,10 @@ do lc=ld+1,norb_inn-2 msd = lsm_inn(ld) msc = lsm_inn(lc) - mscd = mul_tab(msd,msc) + mscd = Mul(msd,msc) do lb=lc+1,norb_inn-1 msb = lsm_inn(lb) - msa = mul_tab(mscd,msb) + msa = Mul(mscd,msb) njkl = ld+ngw2(lc)+ngw3(lb) loijk(njkl) = numb diff -Nru openmolcas-22.02/src/gugaci/molinf.F90 openmolcas-22.10/src/gugaci/molinf.F90 --- openmolcas-22.02/src/gugaci/molinf.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/molinf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -203,7 +203,7 @@ use gugaci_global, only: ibsm_ext, iesm_ext, int_dd_offset, iref_occ, logic_assign_actorb, logic_mr, lsm, lsm_inn, lsmorb, LuDrt, & n_ref, nabc, ng_sm, ngw2, ngw3, ngw4, nlsm_all, nlsm_bas, nlsm_dbl, nlsm_ext, nlsm_frz, noidx, norb_act, & norb_all, norb_dbl, norb_dz, norb_ext, norb_frz, norb_inn, ns_sm, nstart_act, spin !, logic_mrelcas -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Half use Definitions, only: iwp, u6 @@ -340,7 +340,7 @@ do im=1,ng_sm im_lr_sta = 0 do iml=1,ng_sm - imr = mul_tab(im,iml) + imr = Mul(im,iml) if (imr > iml) cycle int_dd_offset(iml,imr) = im_lr_sta int_dd_offset(imr,iml) = im_lr_sta diff -Nru openmolcas-22.02/src/gugaci/paras_calculate.F90 openmolcas-22.10/src/gugaci/paras_calculate.F90 --- openmolcas-22.02/src/gugaci/paras_calculate.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/paras_calculate.F90 2022-10-10 14:22:40.000000000 +0000 @@ -13,7 +13,7 @@ use gugaci_global, only: ibsm_ext, iesm_ext, iwt_orb_ext, iwt_sm_s_ext, jb_sys, jroute_sys, ng_sm, nlsm_dbl, nlsm_ext, spin !, n_electron, norb_all, norb_dbl, norb_dz, norb_ext -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -100,7 +100,7 @@ ! else ! nij = ni*nj ! end if -! ijsm = mul_tab(i,j) +! ijsm = Mul(i,j) ! iwt_ext(ijsm,3) = iwt_ext(ijsm,3)+nij ! iwt_ext(ijsm,4) = iwt_ext(ijsm,4)+nij ! end do @@ -109,9 +109,9 @@ ! !do i=1,ng_sm ! iwt_dbl(i,1) = 0 -! iwt_dbl(i,2) = nlsm_dbl(mul_tab(i,jsm_sys)) +! iwt_dbl(i,2) = nlsm_dbl(Mul(i,jsm_sys)) ! if (jroute_sys > 1) then -! iwt_dbl(i,3) = nlsm_dbl(mul_tab(i,jsm_sys)) +! iwt_dbl(i,3) = nlsm_dbl(Mul(i,jsm_sys)) ! end if !end do !iwt_dbl(ns_sm,1) = 1 @@ -125,7 +125,7 @@ ! else ! nij = ni*nj ! end if -! ijsm = mul_tab(mul_tab(i,j),ns_sm) +! ijsm = Mul(Mul(i,j),ns_sm) ! iwt_dbl(ijsm,4) = iwt_dbl(ijsm,4)+nij ! if (jroute_sys > 2) then ! iwt_dbl(ijsm,5) = iwt_dbl(ijsm,5)+nij @@ -152,7 +152,7 @@ else nij = ni*nj end if - ijsm = mul_tab(isma,ismb) + ijsm = Mul(isma,ismb) !iwt_sm_sab(ijsm) = iwt_sm_sab(ijsm)+nij ! iwt_sm_sab function as a tmp array !iwt_sm_ext(isma,ismb) = iwt_sm_sab(ijsm) @@ -192,7 +192,7 @@ ! iaend = iesm_ext(isma) ! if (isma == ismb) iaend = iaend-1 ! -! ismab = mul_tab(isma,ismb) +! ismab = Mul(isma,ismb) ! iwttmp = iwt_sm_ext(isma,ismb)+iwt_sm_sab(ismab) ! do iaorb=iasta,iaend ! do iborb=max(iaorb+1,ibsta),ibend @@ -218,7 +218,7 @@ else nij = ni*nj end if - ijsm = mul_tab(isma,ismb) + ijsm = Mul(isma,ismb) !iwt_sm_dbl(isma,ismb) = iwt_sm_sab(ijsm) !iasta = ibsm_dbl(isma) @@ -252,7 +252,7 @@ ! iasta = ibsm_dbl(isma) ! iaend = iesm_dbl(isma) ! if (isma == ismb) iaend = iaend-1 -! ismab = mul_tab(isma,ismb) +! ismab = Mul(isma,ismb) ! iwttmp = iwt_sm_dbl(isma,ismb)+iwtsmsabtmp(ismab) ! do iaorb=iasta,iaend ! do iborb=max(iaorb+1,ibsta),ibend @@ -265,7 +265,7 @@ !end do !do ism=1,ng_sm -! jsm = mul_tab(ism,ns_sm) +! jsm = Mul(ism,ns_sm) ! if (ism < jsm) then ! itmp = iwt_sm_sab(jsm) ! iwt_sm_sab(jsm) = iwt_sm_sab(ism) diff -Nru openmolcas-22.02/src/gugaci/prod.F90 openmolcas-22.10/src/gugaci/prod.F90 --- openmolcas-22.02/src/gugaci/prod.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/prod.F90 2022-10-10 14:22:40.000000000 +0000 @@ -177,7 +177,7 @@ logic_g2g4b, logic_g34a, logic_g34b, logic_g35a, logic_g35b, logic_g36a, logic_g36b, lpend34a, lpend34b, & lpend35a, lpend35b, lpend36a, lpend36b, lpext_wei, lpsta34a, lpsta34b, lpsta35a, lpsta35b, lpsta36a, & lpsta36b, mcroot, ng_sm, nvalue_space_ss, value_lpext, vector1, vector2 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -213,7 +213,7 @@ nn0 = iplprwei+iwt_sm_s_ext mm = mm0 do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -246,7 +246,7 @@ nn0 = iplplwei+iwt_sm_s_ext mm = mm0 do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -382,7 +382,7 @@ logic_g2g4b, logic_g34a, logic_g34b, logic_g35a, logic_g35b, logic_g36a, logic_g36b, lpend34a, lpend34b, & lpend35a, lpend35b, lpend36a, lpend36b, lpext_wei, lpsta34a, lpsta34b, lpsta35a, lpsta35b, lpsta36a, & lpsta36b, mcroot, ng_sm, value_lpext, vector1, vector2 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -418,7 +418,7 @@ nn0 = iplprwei+iwt_sm_s_ext mm = mm0 do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -452,7 +452,7 @@ nn0 = iplplwei+iwt_sm_s_ext mm = mm0 do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -779,7 +779,7 @@ logic_g2g4b, logic_g34a, logic_g34b, logic_g35a, logic_g35b, logic_g36a, logic_g36b, lpend34a, lpend34b, & lpend35a, lpend35b, lpend36a, lpend36b, lpext_wei, lpsta34a, lpsta34b, lpsta35a, lpsta35b, lpsta36a, & lpsta36b, mcroot, ng_sm, nvalue_space_ss, value_lpext, vector1, vector2 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -816,7 +816,7 @@ nn0 = iplprwei+iwt_sm_s_ext mm = mm0 !severe_error do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -850,7 +850,7 @@ nn0 = iplplwei+iwt_sm_s_ext mm = mm0 !severe_error do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -992,7 +992,7 @@ logic_g2g4b, logic_g34a, logic_g34b, logic_g35a, logic_g35b, logic_g36a, logic_g36b, lpend34a, lpend34b, & lpend35a, lpend35b, lpend36a, lpend36b, lpext_wei, lpsta34a, lpsta34b, lpsta35a, lpsta35b, lpsta36a, & lpsta36b, mcroot, ng_sm, value_lpext, vector1, vector2 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1029,7 +1029,7 @@ nn0 = iplprwei+iwt_sm_s_ext mm = mm0 !severe_error do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -1063,7 +1063,7 @@ nn0 = iplplwei+iwt_sm_s_ext mm = mm0 !severe_error do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -1206,7 +1206,7 @@ logic_g2g4b, logic_g34a, logic_g34b, logic_g35a, logic_g35b, logic_g36a, logic_g36b, lpend34a, lpend34b, & lpend35a, lpend35b, lpend36a, lpend36b, lpext_wei, lpsta34a, lpsta34b, lpsta35a, lpsta35b, lpsta36a, & lpsta36b, mcroot, ng_sm, nvalue_space_ss, value_lpext, vector1, vector2 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1244,7 +1244,7 @@ nn0 = iplprwei+iwt_sm_s_ext mm = mm0 !severe_error do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -1278,7 +1278,7 @@ nn0 = iplplwei+iwt_sm_s_ext mm = mm0 !severe_error do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -1425,7 +1425,7 @@ logic_g2g4b, logic_g34a, logic_g34b, logic_g35a, logic_g35b, logic_g36a, logic_g36b, lpend34a, lpend34b, & lpend35a, lpend35b, lpend36a, lpend36b, lpext_wei, lpsta34a, lpsta34b, lpsta35a, lpsta35b, lpsta36a, & lpsta36b, mcroot, ng_sm, value_lpext, vector1, vector2 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1462,7 +1462,7 @@ nn0 = iplprwei+iwt_sm_s_ext mm = mm0 !severe_error do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -1495,7 +1495,7 @@ nn0 = iplplwei+iwt_sm_s_ext mm = mm0 !severe_error do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) diff -Nru openmolcas-22.02/src/gugaci/prod_g.F90 openmolcas-22.10/src/gugaci/prod_g.F90 --- openmolcas-22.02/src/gugaci/prod_g.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/prod_g.F90 2022-10-10 14:22:40.000000000 +0000 @@ -15,7 +15,7 @@ logic_g34a, logic_g34b, logic_g35a, logic_g35b, logic_g36a, logic_g36b, lpend34a, lpend34b, lpend35a, & lpend35b, lpend36a, lpend36b, lpext_wei, lpsta34a, lpsta34b, lpsta35a, lpsta35b, lpsta36a, lpsta36b, & ng_sm, value_lpext, value_lpext1, vector1, vector2 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -33,7 +33,7 @@ nn0 = iplprwei+iwt_sm_s_ext mm = mm0 do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -70,7 +70,7 @@ nn0 = iplplwei+iwt_sm_s_ext mm = mm0 do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -218,7 +218,7 @@ logic_g2g4a, logic_g2g4b, logic_g34a, logic_g34b, logic_g35a, logic_g35b, logic_g36a, logic_g36b, & lpend34a, lpend34b, lpend35a, lpend35b, lpend36a, lpend36b, lpext_wei, lpsta34a, lpsta34b, lpsta35a, & lpsta35b, lpsta36a, lpsta36b, ng_sm, value_lpext, value_lpext1, vector1, vector2 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -257,7 +257,7 @@ nn0 = iplprwei+iwt_sm_s_ext mm = mm0 !severe_error do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -296,7 +296,7 @@ nn0 = iplplwei+iwt_sm_s_ext mm = mm0 !severe_error do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -605,7 +605,7 @@ logic_g2g4a, logic_g2g4b, logic_g34a, logic_g34b, logic_g35a, logic_g35b, logic_g36a, logic_g36b, & lpend34a, lpend34b, lpend35a, lpend35b, lpend36a, lpend36b, lpext_wei, lpsta34a, lpsta34b, lpsta35a, & lpsta35b, lpsta36a, lpsta36b, ng_sm, value_lpext, value_lpext1, vector1, vector2 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -651,7 +651,7 @@ nn0 = iplprwei+iwt_sm_s_ext mm = mm0 !severe_error do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -687,7 +687,7 @@ nn0 = iplplwei+iwt_sm_s_ext mm = mm0 !severe_error do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -833,7 +833,7 @@ logic_g2g4a, logic_g2g4b, logic_g34a, logic_g34b, logic_g35a, logic_g35b, logic_g36a, logic_g36b, & lpend34a, lpend34b, lpend35a, lpend35b, lpend36a, lpend36b, lpext_wei, lpsta34a, lpsta34b, lpsta35a, & lpsta35b, lpsta36a, lpsta36b, ng_sm, nvalue_space_ss, value_lpext, value_lpext1, vector1, vector2 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -884,7 +884,7 @@ nn0 = iplprwei+iwt_sm_s_ext mm = mm0 do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -931,7 +931,7 @@ nn0 = iplplwei+iwt_sm_s_ext mm = mm0 do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -1090,7 +1090,7 @@ logic_g2g4a, logic_g2g4b, logic_g34a, logic_g34b, logic_g35a, logic_g35b, logic_g36a, logic_g36b, & lpend34a, lpend34b, lpend35a, lpend35b, lpend36a, lpend36b, lpext_wei, lpsta34a, lpsta34b, lpsta35a, & lpsta35b, lpsta36a, lpsta36b, ng_sm, nvalue_space_ss, value_lpext, value_lpext1, vector1, vector2 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1140,7 +1140,7 @@ nn0 = iplprwei+iwt_sm_s_ext mm = mm0 !severe_error do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -1188,7 +1188,7 @@ nn0 = iplplwei+iwt_sm_s_ext mm = mm0 do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -1366,7 +1366,7 @@ logic_g2g4a, logic_g2g4b, logic_g34a, logic_g34b, logic_g35a, logic_g35b, logic_g36a, logic_g36b, & lpend34a, lpend34b, lpend35a, lpend35b, lpend36a, lpend36b, lpext_wei, lpsta34a, lpsta34b, lpsta35a, & lpsta35b, lpsta36a, lpsta36b, ng_sm, nvalue_space_ss, value_lpext, value_lpext1, vector1, vector2 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: wp, iwp implicit none @@ -1416,7 +1416,7 @@ nn0 = iplprwei+iwt_sm_s_ext mm = mm0 !severe_error do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) @@ -1464,7 +1464,7 @@ nn0 = iplplwei+iwt_sm_s_ext mm = mm0 !severe_error do ismb=1,ng_sm - isma = mul_tab(ismb,ism_g2g4) + isma = Mul(ismb,ism_g2g4) if (isma > ismb) cycle ibsta = ibsm_ext(ismb) ibend = iesm_ext(ismb) diff -Nru openmolcas-22.02/src/gugaci/readint.F90 openmolcas-22.10/src/gugaci/readint.F90 --- openmolcas-22.02/src/gugaci/readint.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/readint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -18,7 +18,7 @@ use gugaci_global, only: lsmorb, LuTwoMO, map_orb_order, nlsm_all, nlsm_bas, ng_sm, noidx, voint, vpotnuc use file_qininit, only: maxrecord -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use stdalloc, only: mma_allocate, mma_deallocate use Definitions, only: wp, iwp, u6 @@ -81,7 +81,7 @@ end do nidx = nidx+nsmint end do -call readtwoeint_molpro(lutwomo,maxrecord,noffset,nlsm_all,ng_sm,mul_tab,map_orb_order,noidx) +call readtwoeint_molpro(lutwomo,maxrecord,noffset,nlsm_all,ng_sm,Mul,map_orb_order,noidx) call mma_deallocate(noffset) call mma_deallocate(xfock) @@ -217,7 +217,7 @@ subroutine intrd_molcas() use gugaci_global, only: FnOneMO, FnTwoMO, lsmorb, LuOneMO, LuTwoMO, map_orb_order, ng_sm, nlsm_all, nlsm_bas, noidx, voint, vpotnuc -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use stdalloc, only: mma_allocate, mma_deallocate use Definitions, only: wp, iwp, u6 @@ -283,7 +283,7 @@ call mma_deallocate(xfock) call daname(lutwomo,fntwomo) -call readtwoeint(lutwomo,nlsm_all,ng_sm,mul_tab,map_orb_order,noidx) +call readtwoeint(lutwomo,nlsm_all,ng_sm,Mul,map_orb_order,noidx) call daclos(lutwomo) write(u6,*) call mma_deallocate(x) @@ -623,7 +623,7 @@ subroutine int_index(numb) use gugaci_global, only: loij_all, loijk_all, lsm, ncibl_all, ngw2, ngw3, norb_all, norb_number -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -673,11 +673,11 @@ lrc = norb_all-lc+1 msd = lsm(lrd) msc = lsm(lrc) - mscd = mul_tab(msd,msc) + mscd = Mul(msd,msc) do lb=lc+1,norb_all-1 lrb = norb_all-lb+1 msb = lsm(lrb) - msa = mul_tab(mscd,msb) + msa = Mul(mscd,msb) njkl = ld+ngw2(lc)+ngw3(lb) loijk_all(njkl) = numb diff -Nru openmolcas-22.02/src/gugaci/tvsv.F90 openmolcas-22.10/src/gugaci/tvsv.F90 --- openmolcas-22.02/src/gugaci/tvsv.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/tvsv.F90 2022-10-10 14:22:40.000000000 +0000 @@ -31,7 +31,7 @@ call get_jpty(jpadlr,jptyl,jptyr) call get_jp(jptyl,jml,jpadl,1) call get_jp(jptyr,jmr,jpad,1) - !jmlr = mul_tab(jml,jmr) + !jmlr = Mul(jml,jmr) if (linelp <= 12) then call tv_ext_head_in_act() else @@ -48,7 +48,7 @@ use gugaci_global, only: ipae, ipael, jb_sys, jml, jmr, jpad, jpadl, jpadlr, jud, just, linelp, logic_dh, lp_lwei, lp_rwei, & lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, nlg1, nlg2, norb_dz, norb_frz, vplp_w0, vplp_w1, & vplpnew_w0, vplpnew_w1, w0_dv, w0_sd, w0_sv, w0_td, w1_sv, w1_tv -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -59,7 +59,7 @@ logic_dh = .true. lpok = jpadlr -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) select case (lpok) case (6) !=================================================================== @@ -155,7 +155,7 @@ lmi = lsm_inn(lri) do lrj=lri,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmlr) cycle !--------------------------------------------------------------- w0sv2 = w0_sv(2) @@ -255,7 +255,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmlr) cycle !--------------------------------------------------------------- iwdl = just(lri,lrj) @@ -378,7 +378,7 @@ call get_jpty(jpadlr,jptyl,jptyr) call get_jp(jptyl,jml,jpadl,1) call get_jp(jptyr,jmr,jpad,1) - !jmlr = mul_tab(jml,jmr) + !jmlr = Mul(jml,jmr) if (linelp <= 12) then call sv_ext_head_in_act() else @@ -395,7 +395,7 @@ use gugaci_global, only: ipae, ipael, jb_sys, jml, jmr, jpad, jpadl, jpadlr, jud, just, linelp, logic_dh, lp_lwei, lp_rwei, & lpnew_lwei, lpnew_rwei, lsm_inn, mhlp, mtype, nlg1, nlg2, norb_dz, norb_frz, vplp_w0, vplp_w1, & vplpnew_w0, vplpnew_w1, w0_dv, w0_sd, w0_sv, w0_td, w1_sv, w1_tv -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero use Definitions, only: wp, iwp @@ -406,7 +406,7 @@ logic_dh = .true. lpok = jpadlr -jmlr = mul_tab(jml,jmr) +jmlr = Mul(jml,jmr) select case (lpok) case (6) !=================================================================== @@ -502,7 +502,7 @@ lmi = lsm_inn(lri) do lrj=lri,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmlr) cycle !--------------------------------------------------------------- w0sv2 = w0_sv(2) @@ -602,7 +602,7 @@ lmi = lsm_inn(lri) do lrj=lri+1,norb_dz lmj = lsm_inn(lrj) - lmij = mul_tab(lmi,lmj) + lmij = Mul(lmi,lmj) if (lmij /= jmlr) cycle !--------------------------------------------------------------- iwdl = just(lri,lrj) diff -Nru openmolcas-22.02/src/gugaci/vddsdt.F90 openmolcas-22.10/src/gugaci/vddsdt.F90 --- openmolcas-22.02/src/gugaci/vddsdt.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugaci/vddsdt.F90 2022-10-10 14:22:40.000000000 +0000 @@ -52,7 +52,7 @@ logic_dh = .true. lpok = jpadlr -!jmlr = mul_tab(jml,jmr) +!jmlr = Mul(jml,jmr) select case (lpok) case default ! (1) !=================================================================== @@ -356,7 +356,7 @@ call get_jpty(jpadlr,jptyl,jptyr) call get_jp(jptyl,jml,jpadl,1) call get_jp(jptyr,jmr,jpad,1) - !jmlr = mul_tab(jml,jmr) + !jmlr = Mul(jml,jmr) call gsd_determine_extarmode_paras(imr,iml,.true.) if (linelp <= 12) then call ds_ext_head_in_act() @@ -381,7 +381,7 @@ integer(kind=iwp), external :: iwalk_ad logic_dh = .true. -!jmlr = mul_tab(jml,jmr) +!jmlr = Mul(jml,jmr) lpok = jpadlr select case (lpok) case default ! (1) @@ -640,7 +640,7 @@ subroutine ds_ext_head_in_act() use gugaci_global, only: iml, imr, linelp, logic_dh, nlg1, nlg2 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -650,7 +650,7 @@ lri = nlg1 lrj = nlg2 intpos = nlg1 -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) select case (linelp) case default ! (2) ! linelp=2 a&r--d&l^r<-->a^l @@ -687,7 +687,7 @@ call get_jpty(jpadlr,jptyl,jptyr) call get_jp(jptyl,jml,jpadl,1) call get_jp(jptyr,jmr,jpad,1) - !jmlr = mul_tab(jml,jmr) + !jmlr = Mul(jml,jmr) call gsd_determine_extarmode_paras(imr,iml,.false.) if (linelp <= 12) then call dt_ext_head_in_act() @@ -712,7 +712,7 @@ integer(kind=iwp), external :: iwalk_ad logic_dh = .true. -!jmlr = mul_tab(jml,jmr) +!jmlr = Mul(jml,jmr) lpok = jpadlr select case (lpok) case default ! (1) @@ -971,7 +971,7 @@ subroutine dt_ext_head_in_act() use gugaci_global, only: iml, imr, linelp, logic_dh, nlg1, nlg2 -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -981,7 +981,7 @@ lri = nlg1 lrj = nlg2 intpos = nlg1 -isma = mul_tab(iml,imr) +isma = Mul(iml,imr) select case (linelp) case default ! (2) ! linelp=2 a&r--d&l^r<-->a^l diff -Nru openmolcas-22.02/src/gugadrt/gugadrt_check_rcas3.F90 openmolcas-22.10/src/gugadrt/gugadrt_check_rcas3.F90 --- openmolcas-22.02/src/gugadrt/gugadrt_check_rcas3.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugadrt/gugadrt_check_rcas3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -34,11 +34,7 @@ end if end do end do -inb = iexcit(1) -do i=2,ndj - inb = min(inb,iexcit(i)) -end do -inb = inb+ja(jk)*2+jb(jk) +inb = minval(iexcit)+ja(jk)*2+jb(jk) return diff -Nru openmolcas-22.02/src/gugadrt/gugadrt_dbl_downwalk.F90 openmolcas-22.10/src/gugadrt/gugadrt_dbl_downwalk.F90 --- openmolcas-22.02/src/gugadrt/gugadrt_dbl_downwalk.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugadrt/gugadrt_dbl_downwalk.F90 2022-10-10 14:22:40.000000000 +0000 @@ -19,7 +19,7 @@ ! | 2 1 \ | use gugadrt_global, only: iseg_sta, iseg_downwei, lsm_inn, max_innorb, ng_sm, norb_dbl, norb_dz, norb_frz, ns_sm -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use stdalloc, only: mma_allocate, mma_deallocate use Definitions, only: iwp @@ -46,7 +46,7 @@ ismj = lsm_inn(lrj) do lri=lrj,1,-1 ismi = lsm_inn(lri) - ismij = mul_tab(ismi,ismj) + ismij = Mul(ismi,ismj) if (ismij /= im) cycle just(lri,lrj) = nns nns = nns+iseg_downwei(17+im) @@ -62,16 +62,16 @@ nnd = 0 nns = 0 do lri=norb_frz+1,norb_dz - ismi = mul_tab(lsm_inn(lri),ns_sm) + ismi = Mul(lsm_inn(lri),ns_sm) if (ismi /= im) cycle jud(lri) = nnd nnd = nnd+1 end do do lri=norb_frz+1,norb_dz-1 - ismi = mul_tab(lsm_inn(lri),ns_sm) + ismi = Mul(lsm_inn(lri),ns_sm) do lrj=lri+1,norb_dz !tmp ismj = lsm_inn(lrj) - ismij = mul_tab(ismi,ismj) + ismij = Mul(ismi,ismj) if (ismij /= im) cycle just(lri,lrj) = nns nns = nns+1 @@ -84,10 +84,10 @@ end do end if do lri=norb_frz+1,norb_dz-1 - ismi = mul_tab(lsm_inn(lri),ns_sm) + ismi = Mul(lsm_inn(lri),ns_sm) do lrj=lri+1,norb_dz !tmp ismj = lsm_inn(lrj) - ismij = mul_tab(ismi,ismj) + ismij = Mul(ismi,ismj) if (ismij /= im) cycle just(lrj,lri) = nns nns = nns+1 diff -Nru openmolcas-22.02/src/gugadrt/gugadrt_dbl_upwalk.F90 openmolcas-22.10/src/gugadrt/gugadrt_dbl_upwalk.F90 --- openmolcas-22.02/src/gugadrt/gugadrt_dbl_upwalk.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugadrt/gugadrt_dbl_upwalk.F90 2022-10-10 14:22:40.000000000 +0000 @@ -12,7 +12,7 @@ subroutine gugadrt_dbl_upwalk() use gugadrt_global, only: jpad_upwei, jroute_sys, lsm_inn, mxnode, ng_sm, norb_dbl, norb_dz, norb_frz, nu_ad, ns_sm -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -25,7 +25,7 @@ mxnode = 17+ng_sm lri = norb_frz+1 lsmi = lsm_inn(lri) - lsmid = mul_tab(lsmi,ns_sm) + lsmid = Mul(lsmi,ns_sm) ! for node_v nu_ad(1) = 1 jpad_upwei(1) = 1 @@ -54,13 +54,13 @@ end if do lri=norb_frz+1,norb_dz lsmi = lsm_inn(lri) - lsmid = mul_tab(lsmi,ns_sm) + lsmid = Mul(lsmi,ns_sm) no_d = lsmid+1 jpad_upwei(no_d) = jpad_upwei(no_d)+1 do lrj=lri+1,norb_dz lsmj = lsm_inn(lrj) - lsmij = mul_tab(lsmi,lsmj) - lsmit = mul_tab(lsmij,ns_sm) + lsmij = Mul(lsmi,lsmj) + lsmit = Mul(lsmij,ns_sm) no_t = lsmit+9 jpad_upwei(no_t) = jpad_upwei(no_t)+1 end do diff -Nru openmolcas-22.02/src/gugadrt/gugadrt_ext_downwalk.F90 openmolcas-22.10/src/gugadrt/gugadrt_ext_downwalk.F90 --- openmolcas-22.02/src/gugadrt/gugadrt_ext_downwalk.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugadrt/gugadrt_ext_downwalk.F90 2022-10-10 14:22:40.000000000 +0000 @@ -12,7 +12,7 @@ subroutine gugadrt_ext_downwalk() use gugadrt_global, only: iseg_downwei, ng_sm, nlsm_ext, norb_ext, nu_ae -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Definitions, only: iwp implicit none @@ -30,7 +30,7 @@ do imi=1,ng_sm iseg_downwei(nu_ae(1+imi)) = nlsm_ext(imi) do imj=imi,ng_sm - imij = mul_tab(imi,imj) + imij = Mul(imi,imj) if (imij /= 1) then iwmij(imij) = iwmij(imij)+nlsm_ext(imi)*nlsm_ext(imj) cycle diff -Nru openmolcas-22.02/src/gugadrt/gugadrt.F90 openmolcas-22.10/src/gugadrt/gugadrt.F90 --- openmolcas-22.02/src/gugadrt/gugadrt.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugadrt/gugadrt.F90 2022-10-10 14:22:40.000000000 +0000 @@ -43,7 +43,7 @@ call gugadrt_ext_downwalk() ! add by wyb 01.9.5 call gugadrt_active_drt() ! add by wyb 01.9.5 -call add_info('CI_DIM',[dble(nci_dim)],1,1) +call add_info('CI_DIM',[real(nci_dim,kind=wp)],1,1) call gugadrt_gugafinalize() ireturn = 0 diff -Nru openmolcas-22.02/src/gugadrt/gugadrt_mole_inf.F90 openmolcas-22.10/src/gugadrt/gugadrt_mole_inf.F90 --- openmolcas-22.02/src/gugadrt/gugadrt_mole_inf.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugadrt/gugadrt_mole_inf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -14,12 +14,12 @@ use gugadrt_global, only: iprint, iref_occ, logic_mr, logic_mrelcas, lsm_inn, ludrt, max_ref, n_electron, n_ref, ng_sm, nlsm_all, & nlsm_bas, nlsm_ext, nlsmddel, nlsmedel, norb_act, norb_all, norb_dbl, norb_dz, norb_ext, norb_frz, & norb_inn, ns_sm, nstart_act, spin -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use Constants, only: Zero, Two use Definitions, only: iwp, u6 implicit none -integer(kind=iwp) :: err, i, icmd, idisk, idum(1), im, iorb, ispin, itmpstr(72), j, jcmd, ln1, lsm, lsmtmp(8), ms_ref, mul, & +integer(kind=iwp) :: err, i, icmd, idisk, idum(1), im, iorb, ispin, itmpstr(72), j, jcmd, ln1, lsm, lsmtmp(8), ms_ref, mult, & nact_sm, nactel, nde, ndisk, ne_act, neact, ngsm, nlsm_act(8), nlsm_dbl(8), nlsm_frz(8), nlsm_inn(8), & noidx(8), norb1, norb2, norb_all_tmp, ntit logical(kind=iwp) :: log_debug, skip @@ -382,7 +382,7 @@ ms_ref = 1 neact = 0 do j=norb_dz+1,norb_inn - if (iref_occ(j,i) == 1) ms_ref = mul_tab(ms_ref,lsm_inn(j)) + if (iref_occ(j,i) == 1) ms_ref = Mul(ms_ref,lsm_inn(j)) if (iref_occ(j,i) == 1) neact = neact+1 if (iref_occ(j,i) == 2) neact = neact+2 end do @@ -462,7 +462,7 @@ do i=1,ng_sm noidx(i) = i end do -mul = nint(2*spin)+1 +mult = nint(2*spin)+1 write(u6,*) '-----------------------------------------------' write(u6,*) ' ci orbitals information' ndisk = 0 @@ -473,7 +473,7 @@ write(u6,*) ' num. of orbitals: ',norb_all write(u6,*) ' num. of active-orbitals:',norb_act write(u6,*) ' num. of electrons: ',n_electron -write(u6,*) ' multiplicity: ',mul +write(u6,*) ' multiplicity: ',mult write(u6,*) ' symmetry: ',ns_sm write(u6,*) write(u6,*) ' oribtials per-symmtry' diff -Nru openmolcas-22.02/src/gugadrt/gugadrt_njexcit.F90 openmolcas-22.10/src/gugadrt/gugadrt_njexcit.F90 --- openmolcas-22.02/src/gugadrt/gugadrt_njexcit.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugadrt/gugadrt_njexcit.F90 2022-10-10 14:22:40.000000000 +0000 @@ -33,10 +33,7 @@ if (ival > 2) ival = 3 itexcit(idxref) = ival end do -inm = itexcit(1) -do idxref=2,n_ref - inm = min(inm,itexcit(idxref)) -end do +inm = minval(itexcit) if (inm > 2) then ivalid = 0 diff -Nru openmolcas-22.02/src/gugadrt/gugadrt_rcas.F90 openmolcas-22.10/src/gugadrt/gugadrt_rcas.F90 --- openmolcas-22.02/src/gugadrt/gugadrt_rcas.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugadrt/gugadrt_rcas.F90 2022-10-10 14:22:40.000000000 +0000 @@ -13,7 +13,7 @@ use gugadrt_global, only: iseg_downwei, iprint, ja, ja_sys, jb, jb_sys, jc_sys, jd, jj, jm, jroute_sys, js, jt, jv, kk, lsm_inn, & max_innorb, max_node, max_ref, mxnode, n_electron, ng_sm, no, norb_dz, norb_inn, ns_sm, nu_ad -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use stdalloc, only: mma_allocate, mma_deallocate use Definitions, only: iwp, u6 @@ -195,7 +195,7 @@ ja(jk) = ja(j) jb(jk) = jb(j)-1 jc(jk) = jc(j) - jm(jk) = mul_tab(lsm_inn(kk(j)+1),jm(j)) + jm(jk) = Mul(lsm_inn(kk(j)+1),jm(j)) do i=1,8 ind(i,jk) = ind(i,j) end do @@ -244,7 +244,7 @@ jb(jk) = jb(j)+1 jc(jk) = jc(j)-1 !----------------------------------------------------------------------- - jm(jk) = mul_tab(lsm_inn(kk(j)+1),jm(j)) + jm(jk) = Mul(lsm_inn(kk(j)+1),jm(j)) do i=1,8 ind(i,jk) = ind(i,j) end do diff -Nru openmolcas-22.02/src/gugadrt/gugadrt_ref_gfs.F90 openmolcas-22.10/src/gugadrt/gugadrt_ref_gfs.F90 --- openmolcas-22.02/src/gugadrt/gugadrt_ref_gfs.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugadrt/gugadrt_ref_gfs.F90 2022-10-10 14:22:40.000000000 +0000 @@ -12,7 +12,7 @@ subroutine gugadrt_ref_gfs(nel,ndj,locu,nm) use gugadrt_global, only: lsm_inn, max_ref, norb_dz, norb_inn, nstart_act, spin -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use stdalloc, only: mma_allocate, mma_deallocate use Definitions, only: iwp, u6 @@ -47,14 +47,14 @@ lpsum = l1+l2+l3+l4+l5+l6+l7+l8 if (lpsum /= nes) cycle mys = 1 - if (mod(l1,2) == 1) mys = mul_tab(mys,1) - if (mod(l2,2) == 1) mys = mul_tab(mys,2) - if (mod(l3,2) == 1) mys = mul_tab(mys,3) - if (mod(l4,2) == 1) mys = mul_tab(mys,4) - if (mod(l5,2) == 1) mys = mul_tab(mys,5) - if (mod(l6,2) == 1) mys = mul_tab(mys,6) - if (mod(l7,2) == 1) mys = mul_tab(mys,7) - if (mod(l8,2) == 1) mys = mul_tab(mys,8) + if (mod(l1,2) == 1) mys = Mul(mys,1) + if (mod(l2,2) == 1) mys = Mul(mys,2) + if (mod(l3,2) == 1) mys = Mul(mys,3) + if (mod(l4,2) == 1) mys = Mul(mys,4) + if (mod(l5,2) == 1) mys = Mul(mys,5) + if (mod(l6,2) == 1) mys = Mul(mys,6) + if (mod(l7,2) == 1) mys = Mul(mys,7) + if (mod(l8,2) == 1) mys = Mul(mys,8) if (mys /= nm) cycle mdj = mdj+1 lscu(0,mdj) = lpsum diff -Nru openmolcas-22.02/src/gugadrt/gugadrt_rst.F90 openmolcas-22.10/src/gugadrt/gugadrt_rst.F90 --- openmolcas-22.02/src/gugadrt/gugadrt_rst.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/gugadrt/gugadrt_rst.F90 2022-10-10 14:22:40.000000000 +0000 @@ -16,7 +16,7 @@ use gugadrt_global, only: iseg_downwei, iprint, iintbit, ja, ja_sys, jb, jb_sys, jc_sys, jd, jj, jm, jroute_sys, js, jt, jv, kk, & lsm_inn, max_innorb, max_node, mxnode, n_ref, n16int, n32int, ng_sm, no, norb_act, norb_all, norb_dz, & norb_inn, ns_sm, nu_ad -use Symmetry_Info, only: mul_tab => Mul +use Symmetry_Info, only: Mul use stdalloc, only: mma_allocate, mma_deallocate use Definitions, only: iwp, u6 @@ -289,7 +289,7 @@ ! *********** jatmp = jaj jbtmp = jbj-1 - jmtmp = mul_tab(lsm_inn(k0+1),jmj) + jmtmp = Mul(lsm_inn(k0+1),jmj) kktmp = kkj+1 iextjj(1:nrefbit) = ind(1:nrefbit,j) @@ -350,7 +350,7 @@ ! ************* jatmp = jaj-1 jbtmp = jbj+1 - jmtmp = mul_tab(lsm_inn(k0+1),jmj) + jmtmp = Mul(lsm_inn(k0+1),jmj) kktmp = kkj+1 iextjj(1:nrefbit) = ind(1:nrefbit,j) diff -Nru openmolcas-22.02/src/guga_util/CMakeLists.txt openmolcas-22.10/src/guga_util/CMakeLists.txt --- openmolcas-22.02/src/guga_util/CMakeLists.txt 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/guga_util/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,34 @@ +#*********************************************************************** +# This file is part of OpenMolcas. * +# * +# OpenMolcas is free software; you can redistribute it and/or modify * +# it under the terms of the GNU Lesser General Public License, v. 2.1. * +# OpenMolcas is distributed in the hope that it will be useful, but it * +# is provided "as is" and without any express or implied warranties. * +# For more details see the full text of the license in the file * +# LICENSE or in . * +#*********************************************************************** + +set (sources + fmmm.F90 + fmul2.F90 + guga_util_global.F90 + icunp.F90 + jacscf.F90 + jsunp.F90 + mtrans.F90 + order.F90 + siadd.F90 + squar2.F90 + squar.F90 + squarm.F90 + squarn.F90 + tradd.F90 + vneg.F90 + wr_guga_info.F90 +) + +# Source files defining modules that should be available to other *_util directories +set (modfile_list "") + +include (${PROJECT_SOURCE_DIR}/cmake/util_template.cmake) diff -Nru openmolcas-22.02/src/guga_util/fmmm.F90 openmolcas-22.10/src/guga_util/fmmm.F90 --- openmolcas-22.02/src/guga_util/fmmm.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/guga_util/fmmm.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,41 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine FMMM(A,B,C,NROW,NCOL,NSUM) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: NROW, NCOL, NSUM +real(kind=wp), intent(in) :: A(NROW,NSUM), B(NSUM,NCOL) +real(kind=wp), intent(out) :: C(NROW,NCOL) +integer(kind=iwp) :: I, J, K, KK +real(kind=wp) :: T +integer(kind=iwp), parameter :: KS = 48 + +C(:,:) = Zero + +do KK=1,NSUM,KS + do I=1,NROW + do J=1,NCOL + T = C(I,J) + do K=KK,min(KK+KS-1,NSUM) + T = T+B(K,J)*A(I,K) + end do + C(I,J) = T + end do + end do +end do + +return + +end subroutine FMMM diff -Nru openmolcas-22.02/src/guga_util/fmul2.F90 openmolcas-22.10/src/guga_util/fmul2.F90 --- openmolcas-22.02/src/guga_util/fmul2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/guga_util/fmul2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,46 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine FMUL2(A,B,C,NROW,NCOL,N) + +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: NROW, NCOL, N +real(kind=wp), intent(in) :: A(NROW,N), B(NCOL,N) +real(kind=wp), intent(out) :: C(NROW,NCOL) +integer(kind=iwp) :: J, J1, K +real(kind=wp) :: CJ(1000), FAC + +if (NROW > size(CJ)) then + write(u6,*) + write(u6,*) ' *** Error in Subroutine FMUL2 ***' + write(u6,*) ' row dimension exceeds local buffer size' + write(u6,*) + call Abend() +end if + +do J=1,NCOL + CJ(1:NROW) = Zero + if (J /= NCOL) then + J1 = J+1 + do K=1,N + FAC = B(J,K) + if (FAC /= Zero) CJ(J1:NROW) = CJ(J1:NROW)+FAC*A(J1:NROW,K) + end do + end if + C(:,J) = CJ(1:NROW) +end do + +return + +end subroutine FMUL2 diff -Nru openmolcas-22.02/src/guga_util/guga_util_global.F90 openmolcas-22.10/src/guga_util/guga_util_global.F90 --- openmolcas-22.02/src/guga_util/guga_util_global.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/guga_util/guga_util_global.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,26 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +module guga_util_global + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +private + +integer(kind=iwp), parameter :: nCOP = 600, nIOCR = 20000 +integer(kind=iwp) :: IAD10(9), ICOP1(nCOP+1) = 0 +real(kind=wp) :: COP(nCOP) = Zero + +public :: COP, IAD10, ICOP1, nCOP, nIOCR + +end module guga_util_global diff -Nru openmolcas-22.02/src/guga_util/icunp.F90 openmolcas-22.10/src/guga_util/icunp.F90 --- openmolcas-22.02/src/guga_util/icunp.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/guga_util/icunp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,27 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +function ICUNP(ICSPCK,L) + +use Definitions, only: iwp + +implicit none +integer(kind=iwp) :: ICUNP +integer(kind=iwp), intent(in) :: ICSPCK(*), L +integer(kind=iwp) :: INTW, IPOW + +INTW = ICSPCK((L+14)/15) +IPOW = 2**(28-2*mod(L-1,15)) +ICUNP = mod(INTW/IPOW,4) + +return + +end function ICUNP diff -Nru openmolcas-22.02/src/guga_util/jacscf.F90 openmolcas-22.10/src/guga_util/jacscf.F90 --- openmolcas-22.02/src/guga_util/jacscf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/guga_util/jacscf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,168 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine JACSCF(A,B,C,NAA,NQQ,EPSLON) +! VERSION 4 AUGUST 1971 +! SUBROUTINE TO FIND ALL THE EIGENVALUES AND EIGENVECTORS OF A +! BY THE JACOBI METHOD +! THIS PROGRAM TREATS THE ORTHOGONAL CASE (S=1) +! NAA=DIMENSION OF A,B,C +! A TRIANGULAR, B MATRIX OF VECTORS, C EIGENVALUES +! B CLEARED TO UNIT MATRIX IF NQ=-1, NOT CLEARED IF NQ= NO. ROWS B +! NQ MUST NOT BE LESS THAN NAA +! EPSLON IS THE CONVERGENCE CRITERIA FOR OFF DIAGONAL ELEMENTS + +use Constants, only: Zero, One, Two, Three +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +real(kind=wp), intent(inout) :: A(*) +real(kind=wp), intent(_OUT_) :: B(*), C(*) +integer(kind=iwp), intent(in) :: NAA, NQQ +real(kind=wp), intent(in) :: EPSLON +integer(kind=iwp) :: I, ID, J, JD, JJ, K, KA, KB, KC, KD, KDX, L, LL, LOOPC, N, NA, NN, NQ +real(kind=wp) :: ALPHA, AMAX, BETA, CC, CSQ, ROOT, RSUM, S, SSQ, TEMPA, TERM, THRESH, THRSHG, TWOSC + +! POW: Unnecessary but warning stopping initialization +TERM = huge(TERM) + +NQ = NQQ +LOOPC = 0 +NA = NAA +NN = (NA*(NA+1))/2 +if (NQ <= 0) then + K = 1 + NQ = NA + do I=1,NA + do J=1,NA + if (I /= J) then + B(K) = Zero + else + B(K) = One + end if + K = K+1 + end do + end do +end if +RSUM = Zero +if (NA < 1) return +if (NA > 1) then + K = 1 + AMAX = Zero + do I=1,NA + do J=1,I + if ((I /= J) .and. (abs(A(K)) > AMAX)) AMAX = abs(A(K)) + TERM = A(K)*A(K) + RSUM = RSUM+TERM+TERM + K = K+1 + end do + RSUM = RSUM-TERM + end do + RSUM = sqrt(RSUM) + THRESH = RSUM/sqrt(real(NA,kind=wp)) + THRSHG = THRESH*EPSLON + if (THRSHG < AMAX) then + THRESH = AMAX/Three + if (THRESH < THRSHG) THRESH = THRSHG + do + K = 2 + N = 0 + JD = 1 + KDX = 0 + do J=2,NA + ID = 0 + JD = JD+J + JJ = J-1 + KC = 0 + KDX = KDX+NQ + do I=1,JJ + ID = ID+I + if (abs(A(K)) <= THRESH) then + KC = KC+NQ + else + N = N+1 + ALPHA = (A(JD)-A(ID))/(Two*A(K)) + BETA = One/(One+ALPHA*ALPHA) + ROOT = One+abs(ALPHA)*sqrt(BETA) + SSQ = BETA/(2*ROOT) + CSQ = ROOT/2 + CC = sqrt(CSQ) + S = -sqrt(SSQ)*sign(One,ALPHA) + TWOSC = 2*CC*S + TEMPA = CSQ*A(ID)+TWOSC*A(K)+SSQ*A(JD) + A(JD) = CSQ*A(JD)-TWOSC*A(K)+SSQ*A(ID) + A(ID) = TEMPA + A(K) = Zero + KA = JD-J + KB = ID-I + KD = KDX + do L=1,NQ + KC = KC+1 + KD = KD+1 + TEMPA = CC*B(KC)+S*B(KD) + B(KD) = -S*B(KC)+CC*B(KD) + B(KC) = TEMPA + if (L <= NA) then + if (I == L) then + KB = KB+1 + KA = KA+1 + else if (I < L) then + KB = KB+L-1 + if (J == L) then + KA = KA+1 + else + if (J > L) then + KA = KA+1 + else + KA = KA+L-1 + end if + TEMPA = CC*A(KB)+S*A(KA) + A(KA) = -S*A(KB)+CC*A(KA) + A(KB) = TEMPA + end if + else + KB = KB+1 + KA = KA+1 + TEMPA = CC*A(KB)+S*A(KA) + A(KA) = -S*A(KB)+CC*A(KA) + A(KB) = TEMPA + end if + end if + end do + end if + K = K+1 + end do + K = K+1 + end do + LOOPC = LOOPC+1 + if (LOOPC >= 50) return + if (N <= NN/8) then + if (THRESH /= THRSHG) then + THRESH = THRESH/Three + if (THRESH < THRSHG) THRESH = THRSHG + else if (N == 0) then + exit + end if + end if + end do + end if +end if +LL = 0 +do L=1,NA + LL = LL+L + C(L) = A(LL) +end do + +return + +end subroutine JACSCF diff -Nru openmolcas-22.02/src/guga_util/jsunp.F90 openmolcas-22.10/src/guga_util/jsunp.F90 --- openmolcas-22.02/src/guga_util/jsunp.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/guga_util/jsunp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,28 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +function JSUNP(INTSYM,L) + +use Definitions, only: iwp + +implicit none +integer(kind=iwp) :: JSUNP +integer(kind=iwp), intent(in) :: INTSYM(*), L +integer(kind=iwp) :: I, J + +! L = (I-1)*10 + J+1 [ J = 0-9 ] +I = (L+9)/10 +J = mod(L-1,10) +JSUNP = 1+ibits(INTSYM(I),27-3*J,3) + +return + +end function JSUNP diff -Nru openmolcas-22.02/src/guga_util/mtrans.F90 openmolcas-22.10/src/guga_util/mtrans.F90 --- openmolcas-22.02/src/guga_util/mtrans.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/guga_util/mtrans.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,30 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine MTRANS(A,B,N,M) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: N, M +real(kind=wp), intent(in) :: A(M,N) +real(kind=wp), intent(out) :: B(N,M) +integer(kind=iwp) :: I, J + +do I=1,N + do J=1,M + B(I,J) = A(J,I) + end do +end do + +return + +end subroutine MTRANS diff -Nru openmolcas-22.02/src/guga_util/order.F90 openmolcas-22.10/src/guga_util/order.F90 --- openmolcas-22.02/src/guga_util/order.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/guga_util/order.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,43 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ORDER(C,D,N) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: N +real(kind=wp), intent(inout) :: C(N,N), D(N) +integer(kind=iwp) :: I, IMIN, J, K +real(kind=wp) :: DMIN, TMP + +do I=1,N-1 + IMIN = I + DMIN = D(I) + do J=I+1,N + if (D(J) < DMIN) then + DMIN = D(J) + IMIN = J + end if + end do + if (I == IMIN) cycle + D(IMIN) = D(I) + D(I) = DMIN + do K=1,N + TMP = C(K,I) + C(K,I) = C(K,IMIN) + C(K,IMIN) = TMP + end do +end do + +return + +end subroutine ORDER diff -Nru openmolcas-22.02/src/guga_util/siadd.F90 openmolcas-22.10/src/guga_util/siadd.F90 --- openmolcas-22.02/src/guga_util/siadd.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/guga_util/siadd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,34 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine SIADD(A,B,N) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: N +real(kind=wp), intent(in) :: A(N,N) +real(kind=wp), intent(inout) :: B(*) +integer(kind=iwp) :: I, IIN, J + +IIN = 0 +do I=1,N + do J=1,I-1 + IIN = IIN+1 + B(IIN) = B(IIN)+A(I,J)+A(J,I) + end do + IIN = IIN+1 + B(IIN) = B(IIN)+A(I,I) +end do + +return + +end subroutine SIADD diff -Nru openmolcas-22.02/src/guga_util/squar2.F90 openmolcas-22.10/src/guga_util/squar2.F90 --- openmolcas-22.02/src/guga_util/squar2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/guga_util/squar2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,27 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine SQUAR2(A,N) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: N +real(kind=wp), intent(inout) :: A(N,N) +integer(kind=iwp) :: I + +do I=1,N-1 + A(I,I+1:N) = A(I+1:N,I) +end do + +return + +end subroutine SQUAR2 diff -Nru openmolcas-22.02/src/guga_util/squar.F90 openmolcas-22.10/src/guga_util/squar.F90 --- openmolcas-22.02/src/guga_util/squar.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/guga_util/squar.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,31 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine SQUAR(A,B,N) + +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(in) :: A(*) +integer(kind=iwp), intent(in) :: N +real(kind=wp), intent(out) :: B(N,N) +integer(kind=iwp) :: I, IIN + +IIN = 1 +do I=1,N + B(I,1:I-1) = A(IIN:IIN+I-2) + B(1:I,I) = A(IIN:IIN+I-1) + IIN = IIN+I +end do + +return + +end subroutine SQUAR diff -Nru openmolcas-22.02/src/guga_util/squarm.F90 openmolcas-22.10/src/guga_util/squarm.F90 --- openmolcas-22.02/src/guga_util/squarm.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/guga_util/squarm.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,33 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine SQUARM(A,B,N) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(in) :: A(*) +integer(kind=iwp), intent(in) :: N +real(kind=wp), intent(out) :: B(N,N) +integer(kind=iwp) :: I, IIN + +IIN = 2 +do I=2,N + B(1:I-1,I) = -A(IIN:IIN+I-2) + B(I,1:I-1) = A(IIN:IIN+I-2) + IIN = IIN+I +end do +call DCOPY_(N,[Zero],0,B,N+1) + +return + +end subroutine SQUARM diff -Nru openmolcas-22.02/src/guga_util/squarn.F90 openmolcas-22.10/src/guga_util/squarn.F90 --- openmolcas-22.02/src/guga_util/squarn.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/guga_util/squarn.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,33 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine SQUARN(A,B,N) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(in) :: A(*) +integer(kind=iwp), intent(in) :: N +real(kind=wp), intent(out) :: B(N,N) +integer(kind=iwp) :: I, IIN + +IIN = 2 +do I=2,N + B(I,1:I-1) = -A(IIN:IIN+I-2) + B(1:I-1,I) = A(IIN:IIN+I-2) + IIN = IIN+I +end do +call DCOPY_(N,[Zero],0,B,N+1) + +return + +end subroutine SQUARN diff -Nru openmolcas-22.02/src/guga_util/tradd.F90 openmolcas-22.10/src/guga_util/tradd.F90 --- openmolcas-22.02/src/guga_util/tradd.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/guga_util/tradd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,32 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine TRADD(A,B,N) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: N +real(kind=wp), intent(in) :: A(N,N) +real(kind=wp), intent(inout) :: B(*) +integer(kind=iwp) :: I, IIN, J + +IIN = 0 +do I=1,N + do J=1,I + IIN = IIN+1 + B(IIN) = B(IIN)+A(I,J)-A(J,I) + end do +end do + +return + +end subroutine TRADD diff -Nru openmolcas-22.02/src/guga_util/vneg.F90 openmolcas-22.10/src/guga_util/vneg.F90 --- openmolcas-22.02/src/guga_util/vneg.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/guga_util/vneg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,30 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine VNEG(IAB,A,IA,B,IB) + +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: IAB, IA, IB +real(kind=wp), intent(in) :: A(*) +real(kind=wp), intent(_OUT_) :: B(*) +integer(kind=iwp) :: I + +do I=0,IAB-1 + B(1+I*IB) = -A(1+I*IA) +end do + +return + +end subroutine VNEG diff -Nru openmolcas-22.02/src/guga_util/wr_guga_info.F90 openmolcas-22.10/src/guga_util/wr_guga_info.F90 --- openmolcas-22.02/src/guga_util/wr_guga_info.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/guga_util/wr_guga_info.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,78 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine WR_GUGA(Lu,iOpt,iDisk,NFREF,S,N,LN,NSYM,IR1,IR2,IFIRST,INTNUM,LSYM,NREF,LN1,NRLN1,NSH,NISH,MxSym,JRC,nJRC,JJS,nJJS, & + NVAL,IOCR,nIOCR) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: Lu, iOpt, MxSym, nJRC, nJJS, nIOCR +integer(kind=iwp), intent(inout) :: iDisk, NFREF, N, LN, NSYM, IR1, IR2, IFIRST, INTNUM, LSYM, NREF, LN1, NRLN1, NSH(MxSym), & + NISH(MxSym), JRC(nJRC), JJS(nJJS), NVAL(MxSym), IOCR(nIOCR) +real(kind=wp), intent(inout) :: S +integer(kind=iwp) :: NFREF_(1), N_(1), LN_(1), NSYM_(1), IR1_(1), IR2_(1), IFIRST_(1), INTNUM_(1), LSYM_(1), NREF_(1), LN1_(1), & + NRLN1_(1) +real(kind=wp) :: S_(1) + +if (iOpt == 1) then + NFREF_(1) = NFREF + S_(1) = S + N_(1) = N + LN_(1) = LN + NSYM_(1) = NSYM + IR1_(1) = IR1 + IR2_(1) = IR2 + IFIRST_(1) = IFIRST + INTNUM_(1) = INTNUM + LSYM_(1) = LSYM + NREF_(1) = NREF + LN1_(1) = LN1 + NRLN1_(1) = NRLN1 +end if +call iDaFile(Lu,iOpt,NFREF_,1,iDisk) +call dDaFile(Lu,iOpt,S_,1,iDisk) +call iDaFile(Lu,iOpt,N_,1,iDisk) +call iDaFile(Lu,iOpt,LN_,1,iDisk) +call iDaFile(Lu,iOpt,NSYM_,1,iDisk) +call iDaFile(Lu,iOpt,IR1_,1,iDisk) +call iDaFile(Lu,iOpt,IR2_,1,iDisk) +call iDaFile(Lu,iOpt,IFIRST_,1,iDisk) +call iDaFile(Lu,iOpt,INTNUM_,1,iDisk) +call iDaFile(Lu,iOpt,LSYM_,1,iDisk) +call iDaFile(Lu,iOpt,NREF_,1,iDisk) +call iDaFile(Lu,iOpt,LN1_,1,iDisk) +call iDaFile(Lu,iOpt,NRLN1_,1,iDisk) +if (iOpt == 2) then + NFREF = NFREF_(1) + S = S_(1) + N = N_(1) + LN = LN_(1) + NSYM = NSYM_(1) + IR1 = IR1_(1) + IR2 = IR2_(1) + IFIRST = IFIRST_(1) + INTNUM = INTNUM_(1) + LSYM = LSYM_(1) + NREF = NREF_(1) + LN1 = LN1_(1) + NRLN1 = NRLN1_(1) +end if +call iDaFile(Lu,iOpt,NSH,MxSym,iDisk) +call iDaFile(Lu,iOpt,NISH,MxSym,iDisk) +call iDaFile(Lu,iOpt,JRC,nJRC,iDisk) +call iDaFile(Lu,iOpt,JJS,nJJS,iDisk) +call iDaFile(Lu,iOpt,NVAL,MxSym,iDisk) +call iDaFile(Lu,iOpt,IOCR,nIOCR,iDisk) + +return + +end subroutine WR_GUGA diff -Nru openmolcas-22.02/src/hdf5_util/mh5.F90 openmolcas-22.10/src/hdf5_util/mh5.F90 --- openmolcas-22.02/src/hdf5_util/mh5.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/hdf5_util/mh5.F90 2022-10-10 14:22:40.000000000 +0000 @@ -139,6 +139,7 @@ mh5_fetch_dset_scalar_real, & mh5_fetch_dset_scalar_str, & mh5_fetch_dset_array_int, & + mh5_fetch_dset_array_int_2d, & mh5_fetch_dset_array_real, & mh5_fetch_dset_array_real_2d, & mh5_fetch_dset_array_real_3d, & @@ -1509,6 +1510,23 @@ if (rc < 0) call abend() end subroutine mh5_put_dset_array_real_3d +subroutine mh5_fetch_dset_array_int_2d(lu,dsetname,buffer,exts,offs) + integer(kind=iwp), intent(in) :: lu + character(len=*), intent(in) :: dsetname + integer(kind=iwp), intent(_OUT_) :: buffer(:,:) + integer(kind=iwp), intent(in), optional :: exts(*), offs(*) + integer(kind=iwp) :: dsetid + dsetid = mh5_open_dset(lu,dsetname) + if (present(exts) .and. present(offs)) then + call mh5_get_dset_array_int(dsetid,buffer,exts,offs) + else if (present(exts) .or. present(offs)) then + call abend() + else + call mh5_get_dset_array_int(dsetid,buffer) + end if + call mh5_close_dset(dsetid) +end subroutine mh5_fetch_dset_array_int_2d + subroutine mh5_fetch_dset_array_real_2d(lu,dsetname,buffer,exts,offs) integer(kind=iwp), intent(in) :: lu character(len=*), intent(in) :: dsetname diff -Nru openmolcas-22.02/src/Include/choglob.fh openmolcas-22.10/src/Include/choglob.fh --- openmolcas-22.02/src/Include/choglob.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/choglob.fh 2022-10-10 14:22:40.000000000 +0000 @@ -1,16 +1,16 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -C -C Global stuff for parallel Cholesky -C +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** +! +! Global stuff for parallel Cholesky +! Integer nnShl_G, mmBstRT_G, NumChT_G Integer iiBstR_G, nnBstR_G, nnBstRT_G, NumCho_G @@ -22,6 +22,6 @@ Parameter (nLoc_G = 3) Common / CHOPIS / nnShl_G, mmBstRT_G, NumChT_G - Common / CHOPIA / iiBstR_G(8,nLoc_G), nnBstR_G(8,nLoc_G), + Common / CHOPIA / iiBstR_G(8,nLoc_G), nnBstR_G(8,nLoc_G), & & nnBstRT_G(nLoc_G), NumCho_G(8), myNumCho(8) Common / CHOPLU / LuCho_G(8), LuRed_G, LuRst_G diff -Nru openmolcas-22.02/src/Include/choprint.fh openmolcas-22.10/src/Include/choprint.fh --- openmolcas-22.02/src/Include/choprint.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/choprint.fh 2022-10-10 14:22:40.000000000 +0000 @@ -1,14 +1,14 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -C Information for printing during decomposition: +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** +! Information for printing during decomposition: INTEGER IPRINT ! print level (from input) INTEGER INF_TIMING ! timing info (cho_prtim) INTEGER INF_INIT ! initialization info @@ -20,14 +20,14 @@ INTEGER INF_PROGRESS ! decom. tables for each pass INTEGER INF_SUBTR1 ! timing info in cho_subtr1 (debug) - PARAMETER (INF_TIMING = 2, - & INF_INIT = 3, - & INF_DIAG = 6, - & INF_PASS = 3, - & INF_VECBUF = 3, - & INF_IN2 = 5, - & INF_INT = 6, - & INF_PROGRESS = 4, + PARAMETER (INF_TIMING = 2, & + & INF_INIT = 3, & + & INF_DIAG = 6, & + & INF_PASS = 3, & + & INF_VECBUF = 3, & + & INF_IN2 = 5, & + & INF_INT = 6, & + & INF_PROGRESS = 4, & & INF_SUBTR1 = 6) COMMON / CHOPRT / IPRINT diff -Nru openmolcas-22.02/src/Include/constants2.fh openmolcas-22.10/src/Include/constants2.fh --- openmolcas-22.02/src/Include/constants2.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/constants2.fh 2022-10-10 14:22:40.000000000 +0000 @@ -12,7 +12,7 @@ Real*8 diel,rPi,UTOAU,elmass,ATOKG,elcharge,rNAVO,cLight,auTocm, & & rPlanck,rBohr,cm_s,Debye,Angstrom,RF,auToHz,auTofs,auToN, & & auToeV,auTokJ,auTokcalmol,kBoltzmann,c_in_au,cal_to_J, & - & Rgas,deg2rad,mu2elmass + & Rgas,deg2rad,mu2elmass,atmToau Parameter (diel= CONST_DIELECTRIC_IN_SI_) Parameter (rPi = CONST_PI_) Parameter (deg2rad = CONST_PI_/180.0d0) @@ -44,3 +44,5 @@ Parameter (c_in_au = CONST_C_IN_AU_) Parameter (cal_to_J = CONV_CAL_TO_J_) Parameter (Rgas = CONST_MOLAR_GAS_) + Parameter (atmToau = & + &CONV_ATM_TO_AU_) diff -Nru openmolcas-22.02/src/Include/constants.fh openmolcas-22.10/src/Include/constants.fh --- openmolcas-22.02/src/Include/constants.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/constants.fh 2022-10-10 14:22:40.000000000 +0000 @@ -97,7 +97,7 @@ # define CONST_AMU_IN_SI_ 1.66053906660d-27 # define CONST_AU_TIME_IN_SI_ 2.4188843265857d-17 # define CONST_AU_VELOCITY_IN_SI_ 2.18769126364d6 -# define CONST_AVOGADRO_ 6.02214076e23 +# define CONST_AVOGADRO_ 6.02214076d23 # define CONST_BOHR_RADIUS_IN_SI_ 0.529177210903d-10 # define CONST_ELECTRON_MASS_IN_SI_ 9.1093837015d-31 # define CONST_MUON_MASS_IN_SI_ 1.883531627d-28 @@ -137,6 +137,7 @@ # define CONST_BOHR_MAGNETON_IN_SI_ 9.27400968d-24 #endif #define CONST_C_IN_SI_ 2.99792458d8 +#define CONST_ATM_IN_SI_ 101325.0d0 #define CONST_PI_ 3.141592653589793d0 ! ! Derived constants @@ -178,6 +179,7 @@ ! #define CONV_AMU_TO_AU_ (CONST_AMU_IN_SI_/CONST_ELECTRON_MASS_IN_SI_) #define CONV_AU_TO_KJ_PER_MOLE_ (CONST_AVOGADRO_*CONV_AU_TO_KJ_) +#define CONV_ATM_TO_AU_ (CONST_ATM_IN_SI_*CONST_BOHR_RADIUS_IN_SI_**3/CONV_AU_TO_KJ_*1.0d-3) ! ! Done ! diff -Nru openmolcas-22.02/src/Include/cop.fh openmolcas-22.10/src/Include/cop.fh --- openmolcas-22.02/src/Include/cop.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/cop.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,14 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** - INTEGER nCOP,IADD10,IAD10,ICOP1 - REAL*8 COP - Parameter (nCOP=600) - COMMON/COP/IADD10,IAD10(9),COP(nCOP),ICOP1(nCOP+1) diff -Nru openmolcas-22.02/src/Include/csfbas.fh openmolcas-22.10/src/Include/csfbas.fh --- openmolcas-22.02/src/Include/csfbas.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/csfbas.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,16 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** - INTEGER MXCNSM - PARAMETER(MXCNSM = 8 ) - INTEGER KDFTP,KCFTP,KDTOC,MAXOP_LUCIA, & - & KICONF,KICTS - COMMON/CSFBAS/ KDFTP,KCFTP,KDTOC,MAXOP_LUCIA, & - & KICONF(MXCNSM),KICTS(MXCNSM) diff -Nru openmolcas-22.02/src/Include/digit.h openmolcas-22.10/src/Include/digit.h --- openmolcas-22.02/src/Include/digit.h 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/digit.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,13 +0,0 @@ -/*********************************************************************** -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -***********************************************************************/ - ! digit from 0 to 9 - character, parameter :: DIGIT(0:9) = (/"0", "1", "2", "3", "4", & - "5", "6", "7", "8", "9"/) diff -Nru openmolcas-22.02/src/Include/disp2.fh openmolcas-22.10/src/Include/disp2.fh --- openmolcas-22.02/src/Include/disp2.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/disp2.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** - Integer mxpert,nmethod,nmem - Parameter(mxpert=100) - Logical PreScr,sirrep,lPert(mxpert),lGrd,lHss,Nona - integer nfck(0:7),icntrl, SCF, RASSCF - Parameter (SCF=1, RASSCF=2) - Common /Input_mck_l/ PreScr,sirrep,lPert,lGrd,lHss,Nona - Common /Input_mck_i/icntrl,nfck,nmethod - Common /Parallel/ nmem diff -Nru openmolcas-22.02/src/Include/err_info.h openmolcas-22.10/src/Include/err_info.h --- openmolcas-22.02/src/Include/err_info.h 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/err_info.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,11 +0,0 @@ -/*********************************************************************** -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -***********************************************************************/ -#define ERR_INFO -1 diff -Nru openmolcas-22.02/src/Include/exterm.fh openmolcas-22.10/src/Include/exterm.fh --- openmolcas-22.02/src/Include/exterm.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/exterm.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** - - Integer nChOrb(0:7,5) - Integer nIJ1(8,8,2),nIJR(8,8,2) - Integer iAdrCVec(8,8,2),LuCVector(8,2) - Integer NumAuxVec(8) - Integer MxChVInShl,ljkvec,nScreen - - Common /ExTe1/ nChOrb,nIJ1,nIJR, & - & iAdrCVec, LuCVector, NumAuxVec, & - & MxChVInShl, ljkvec, nScreen - - Logical DoCholExch, Timings_default - Common /ExTe2/ DoCholExch, Timings_default - - Real*8 dmpK, tbvec(2), tavec(2) - Common /ExTe3/ dmpK, tbvec, tavec - - Integer nDM, nJdens, nKdens, nKvec, nAdens, nAvec - Common /DensMat/ nDM, nJdens, nKdens, nKvec, nAdens, nAvec diff -Nru openmolcas-22.02/src/Include/FMM.fh openmolcas-22.10/src/Include/FMM.fh --- openmolcas-22.02/src/Include/FMM.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/FMM.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,12 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Logical FMM_shortrange, asymptotic_Rys - Common /FMM/ FMM_shortrange, asymptotic_Rys diff -Nru openmolcas-22.02/src/Include/functional_types.fh openmolcas-22.10/src/Include/functional_types.fh --- openmolcas-22.02/src/Include/functional_types.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/functional_types.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,16 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** - Integer, Parameter :: & - & Other_Type =0, & - & LDA_Type =1, & - & GGA_Type =2, & - & meta_GGA_Type1=3, & - & meta_GGA_Type2=4 diff -Nru openmolcas-22.02/src/Include/gam.fh openmolcas-22.10/src/Include/gam.fh --- openmolcas-22.02/src/Include/gam.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/gam.fh 2022-10-10 14:22:40.000000000 +0000 @@ -1,20 +1,21 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -c K.P. -c Dieses File enthaelt Feld fuer die theta/phi Integration der -c Ein-Elektronen-Integrale fuer die R-Matrix. +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** +! K.P. +! Dieses File enthaelt Feld fuer die theta/phi Integration der +! Ein-Elektronen-Integrale fuer die R-Matrix. + Integer lgammax,lgamma,n_gam,m_gam Parameter(lgammax=15) - Real*8 gammath(-2:2*lgammax+3,-2:2*lgammax+4), + Real*8 gammath(-2:2*lgammax+3,-2:2*lgammax+4), & & gammaph(-2:2*lgammax+3,-2:2*lgammax+4) Common /rgam/ gammath,gammaph Common /igam/ lgamma Common /igam1/ n_gam,m_gam -************************************************************************ +!*********************************************************************** diff -Nru openmolcas-22.02/src/Include/general.fh openmolcas-22.10/src/Include/general.fh --- openmolcas-22.02/src/Include/general.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/general.fh 2022-10-10 14:22:40.000000000 +0000 @@ -11,7 +11,7 @@ REAL*8 SXDAMP INTEGER MAXALTER PARAMETER (MAXALTER=16) - INTEGER NSYM,MUL(mxSym,mxSym), & + INTEGER NSYM, & & NBAS(mxSym),NFRO(mxSym),NORB(mxSym),NDEL(mxSym), & & NISH(mxSym),NASH(mxSym),NSSH(mxSym), & & NRS1(mxSym),NRS2(mxSym),NRS3(mxSym),nSkipX(MxSym),& @@ -19,7 +19,7 @@ & NACTEL,ISPIN,STSYM,NCONF,NHOLE1,NELEC3,NSEL, & & NTOTSP,INVEC,NALTER,MALTER(MAXALTER,3), & & NCRVEC,LCRVEC,NCRPROJ,LCRPROJ - COMMON/GENERAL/ SXDAMP,NSYM,MUL, & + COMMON/GENERAL/ SXDAMP,NSYM, & & NBAS,NFRO,NORB,NDEL, & & NISH,NASH,NSSH, & & NRS1,NRS2,NRS3,nSkipX, & diff -Nru openmolcas-22.02/src/Include/general_mul.fh openmolcas-22.10/src/Include/general_mul.fh --- openmolcas-22.02/src/Include/general_mul.fh 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/Include/general_mul.fh 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,13 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** +#include "general.fh" + INTEGER MUL(mxSym,mxSym) + COMMON/GENERAL_MUL/ MUL diff -Nru openmolcas-22.02/src/Include/grd_interface.fh openmolcas-22.10/src/Include/grd_interface.fh --- openmolcas-22.02/src/Include/grd_interface.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/grd_interface.fh 2022-10-10 14:22:40.000000000 +0000 @@ -11,16 +11,59 @@ ! Copyright (C) 2020, Roland Lindh * !*********************************************************************** +!*********************************************************************** +! Alpha : exponents of bra gaussians * +! nAlpha: number of primitives (exponents) of bra gaussians * +! Beta : as Alpha but for ket gaussians * +! nBeta : as nAlpha but for the ket gaussians * +! Zeta : sum of exponents (nAlpha x nBeta) * +! ZInv : inverse of Zeta * +! rKappa: gaussian prefactor for the products of bra and ket gaussians * +! P : center of new gaussian from the products of bra and ket * +! gaussians * +! rFinal: array for computed integrals * +! nZeta : nAlpha x nBeta * +! nComp : number of components in the operator (e.g. dipole moment * +! operator has three components) * +! la : total angular momentum of bra gaussian * +! lb : total angular momentum of ket gaussian * +! A : center of bra gaussian * +! B : center of ket gaussian * +! nHer : order of Rys- or Hermite-Gauss polynomial * +! Array : Auxiliary memory as requested by ECPMem * +! nArr : length of Array * +! Ccoor : coordinates of the operator, zero for symmetric oper. * +! nOrdOp: Order of the operator * +!*********************************************************************** + #ifdef _CALLING_ +#ifdef _FIXED_FORMAT_ + &Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,rFinal,nZeta,la,lb,A, & + &RB,nHer,Array,nArr,Ccoor,nOrdOp,Grad,nGrad,IfGrad,IndGrd,DAO,mdc, & + &ndc,kOp,nComp,iStabM,nStabM & +#else Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,rFinal,nZeta,la,lb,A,RB,nHer,Array,nArr,Ccoor,nOrdOp,Grad,nGrad,IfGrad,IndGrd,DAO,mdc, & -ndc,kOp,lOper,nComp,iStabM,nStabM & +ndc,kOp,nComp,iStabM,nStabM & +#endif +#else +#ifdef _FIXED_FORMAT_ + Integer nAlpha, nBeta, nZeta, la, lb, nHer, nArr, nOrdOp, nGrad, & + & IndGrd(3,2), mdc, ndc, kOp(2), nComp, nStabM, & + & iStabM(0:nStabM-1) + Real*8 Alpha(nAlpha), Beta(nBeta), Zeta(nZeta), ZInv(nZeta), & + & rKappa(nZeta), P(nZeta,3), & + & rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),nComp,6), A(3), & + & RB(3), Array(nZeta*nArr), Ccoor(*), Grad(nGrad), & + & DAO(nZeta,nTri_Elem1(la)*nTri_Elem1(lb)) + Logical IfGrad(3,2) #else -! TODO: unknown intents, probably all "in", except rFinal, Grad -integer(kind=iwp) :: nAlpha, nBeta, nZeta, la, lb, nHer, nArr, nOrdOp, nGrad, IndGrd(3,2), mdc, ndc, kOp(2), nComp, nStabM, & - lOper(nComp), iStabM(0:nStabM-1) -real(kind=wp) :: Alpha(nAlpha), Beta(nBeta), Zeta(nZeta), ZInv(nZeta), rKappa(nZeta), P(nZeta,3), & - rFinal(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,6), A(3), RB(3), Array(nZeta*nArr), Ccoor(3), Grad(nGrad), & - DAO(nZeta,(la+1)*(la+2)/2*(lb+1)*(lb+2)/2) -logical(kind=iwp) :: IfGrad(3,2) +integer(kind=iwp), intent(in) :: nAlpha, nBeta, nZeta, la, lb, nHer, nArr, nOrdOp, nGrad, IndGrd(3,2), mdc, ndc, kOp(2), nComp, & + nStabM, iStabM(0:nStabM-1) +real(kind=wp), intent(in) :: Alpha(nAlpha), Beta(nBeta), Zeta(nZeta), ZInv(nZeta), P(nZeta,3), A(3), RB(3), Ccoor(*) +real(kind=wp), intent(inout) :: rKappa(nZeta), rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),nComp,6), Grad(nGrad), & + DAO(nZeta,nTri_Elem1(la)*nTri_Elem1(lb)) +real(kind=wp), intent(out) :: Array(nZeta*nArr) +logical(kind=iwp), intent(in) :: IfGrad(3,2) +#endif #endif #undef _CALLING_ diff -Nru openmolcas-22.02/src/Include/hss_interface.fh openmolcas-22.10/src/Include/hss_interface.fh --- openmolcas-22.02/src/Include/hss_interface.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/hss_interface.fh 2022-10-10 14:22:40.000000000 +0000 @@ -10,42 +10,42 @@ ! * ! Copyright (C) 2020, Roland Lindh * !*********************************************************************** + +!*********************************************************************** +! Alpha : exponents of bra gaussians * +! nAlpha: number of primitives (exponents) of bra gaussians * +! Beta : as Alpha but for ket gaussians * +! nBeta : as nAlpha but for the ket gaussians * +! Zeta : sum of exponents (nAlpha x nBeta) * +! ZInv : inverse of Zeta * +! rKappa: gaussian prefactor for the products of bra and ket gaussians * +! P : center of new gaussian from the products of bra and ket * +! gaussians * +! rFinal: array for computed integrals * +! nZeta : nAlpha x nBeta * +! nComp : number of components in the operator (e.g. dipole moment * +! operator has three components) * +! la : total angular momentum of bra gaussian * +! lb : total angular momentum of ket gaussian * +! A : center of bra gaussian * +! B : center of ket gaussian * +! nHer : order of Rys- or Hermite-Gauss polynomial * +! Array : Auxiliary memory as requested by ECPMem * +! nArr : length of Array * +! Ccoor : coordinates of the operator, zero for symmetric oper. * +! nOrdOp: Order of the operator * +!*********************************************************************** + #ifdef _CALLING_ - & Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P, & - & Final,nZeta,la,lb,A,RB,nHer, & - & Array,nArr,Ccoor,nOrdOp,Hess,nHess, & - & IfHss,IndHss,IfGrd,IndGrd,DAO,mdc,ndc,nOp,lOper,nComp, & - & iStabM,nStabM,nSym & -#elif defined (_USE_WP_) -! TODO: unknown intents, probably all "in", except Final, Hess -integer(kind=iwp), intent(inout) :: nAlpha, nBeta, nZeta, la, lb, nHer, nArr, nOrdOp, nHess, nSym, & - IndHss(0:1,0:2,0:1,0:2,0:nSym-1), IndGrd(0:2,0:1,0:nSym-1), mdc, ndc, nOp(2), nComp, nStabM, & - lOper(nComp), iStabM(0:nStabM-1) -real(kind=wp), intent(inout) :: Alpha(nAlpha), Beta(nBeta), Zeta(nZeta), ZInv(nZeta), rKappa(nZeta), P(nZeta,3), & - Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,6), A(3), RB(3), Array(nArr), Ccoor(3), & - Hess(nHess), DAO(nZeta,(la+1)*(la+2)/2*(lb+1)*(lb+2)/2) -logical(kind=iwp), intent(inout) :: IfHss(0:1,0:2,0:1,0:2),IfGrd(0:2,0:1) +Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,rFinal,nZeta,la,lb,A,RB,nHer,Array,nArr,Ccoor,nOrdOp,Hess,nHess,IfHss,IndHss,IfGrd, & +IndGrd,DAO,mdc,ndc,nOp,lOper,nComp,iStabM,nStabM,nSym & #else - Real*8 Alpha(nAlpha), Beta(nBeta) - Integer nAlpha, nBeta - Real*8 Zeta(nZeta), ZInv(nZeta) - Real*8 rKappa(nZeta), P(nZeta,3) - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,6) - Integer la, lb, nHer - Real*8 A(3), RB(3) - Real*8 Array(nArr) - Integer nArr - Real*8 Ccoor(3) - Real*8 Hess(nHess) - Integer nHess - Logical IfHss(0:1,0:2,0:1,0:2) - Integer IndHss(0:1,0:2,0:1,0:2,0:nSym-1) - Integer nSym - Logical Ifgrd(0:2,0:1) - Integer indgrd(0:2,0:1,0:nSym-1) - Real*8 DAO(nZeta,(la+1)*(la+2)/2*(lb+1)*(lb+2)/2) - Integer mdc, ndc, nOp(2), lOper(nComp) - Integer nComp - Integer iStabM(0:nStabM-1) +integer(kind=iwp), intent(in) :: nAlpha, nBeta, nZeta, la, lb, nHer, nArr, nOrdOp, nHess, nSym, IndHss(0:1,0:2,0:1,0:2,0:nSym-1), & + IndGrd(0:2,0:1,0:nSym-1), mdc, ndc, nOp(2), nComp, nStabM, lOper(nComp), iStabM(0:nStabM-1) +real(kind=wp), intent(in) :: Alpha(nAlpha), Beta(nBeta), Zeta(nZeta), ZInv(nZeta), P(nZeta,3), A(3), RB(3), Ccoor(3) +real(kind=wp), intent(inout) :: rKappa(nZeta), rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),6), Hess(nHess), & + DAO(nZeta,nTri_Elem1(la)*nTri_Elem1(lb)) +real(kind=wp), intent(out) :: Array(nArr) +logical(kind=iwp), intent(in) :: IfHss(0:1,0:2,0:1,0:2), IfGrd(0:2,0:1) #endif #undef _CALLING_ diff -Nru openmolcas-22.02/src/Include/iavec.fh openmolcas-22.10/src/Include/iavec.fh --- openmolcas-22.02/src/Include/iavec.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/iavec.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,14 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** - Integer nFnc - Parameter(nFnc = (iTabMx+1)*(iTabMx+2)*(iTabMx+3)/6) - Integer ixyz(3,nFnc) - Common /iaVec/ ixyz diff -Nru openmolcas-22.02/src/Include/ibas_ricd.fh openmolcas-22.10/src/Include/ibas_ricd.fh --- openmolcas-22.02/src/Include/ibas_ricd.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/ibas_ricd.fh 2022-10-10 14:22:40.000000000 +0000 @@ -1,11 +1,12 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + Integer jbas_, lbas_ Common /ibas_ricd/ jbas_, lbas_ diff -Nru openmolcas-22.02/src/Include/int_interface.fh openmolcas-22.10/src/Include/int_interface.fh --- openmolcas-22.02/src/Include/int_interface.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/int_interface.fh 2022-10-10 14:22:40.000000000 +0000 @@ -12,62 +12,38 @@ !*********************************************************************** !*********************************************************************** -! Alpha : exponents of bra gaussians * -! nAlpha: number of primitives (exponents) of bra gaussians * -! Beta : as Alpha but for ket gaussians * -! nBeta : as nAlpha but for the ket gaussians * -! Zeta : sum of exponents (nAlpha x nBeta) * -! ZInv : inverse of Zeta * -! rKappa: gaussian prefactor for the products of bra and ket * -! gaussians. * -! P : center of new gaussian from the products of bra and ket * -! gaussians. * -! Final : array for computed integrals * -! nZeta : nAlpha x nBeta * -! nComp : number of components in the operator (e.g. dipolmoment * -! operator has three components) * -! la : total angular momentum of bra gaussian * -! lb : total angular momentum of ket gaussian * -! A : center of bra gaussian * -! B : center of ket gaussian * -! nRys/nHer: order of Rys- or Hermite-Gauss polynomial * -! Array : Auxiliary memory as requested by ECPMem * -! nArr : length of Array * -! Ccoor : coordinates of the operator, zero for symmetric oper. * -! NOrdOp: Order of the operator * +! Alpha : exponents of bra gaussians * +! nAlpha: number of primitives (exponents) of bra gaussians * +! Beta : as Alpha but for ket gaussians * +! nBeta : as nAlpha but for the ket gaussians * +! Zeta : sum of exponents (nAlpha x nBeta) * +! ZInv : inverse of Zeta * +! rKappa: gaussian prefactor for the products of bra and ket gaussians * +! P : center of new gaussian from the products of bra and ket * +! gaussians * +! rFinal: array for computed integrals * +! nZeta : nAlpha x nBeta * +! nComp : number of components in the operator (e.g. dipole moment * +! operator has three components) * +! la : total angular momentum of bra gaussian * +! lb : total angular momentum of ket gaussian * +! A : center of bra gaussian * +! B : center of ket gaussian * +! nHer : order of Rys- or Hermite-Gauss polynomial * +! Array : Auxiliary memory as requested by ECPMem * +! nArr : length of Array * +! Ccoor : coordinates of the operator, zero for symmetric oper. * +! nOrdOp: Order of the operator * !*********************************************************************** #ifdef _CALLING_ - & Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P, & - & Final,nZeta,nIC,nComp,la,lb,A,RB,nHer, & - & Array,nArr,Ccoor,nOrdOp,lOper,iChO, & - & iStabM,nStabM, & - & PtChrg,nGrid,iAddPot & -#elif defined (_USE_WP_) -! TODO: unknown intents, probably all "in" except Final +Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,rFinal,nZeta,nIC,nComp,la,lb,A,RB,nHer,Array,nArr,Ccoor,nOrdOp,lOper,iChO,iStabM, & +nStabM,PtChrg,nGrid,iAddPot & +#else +! TODO: unknown intents, probably all "in" except rFinal integer(kind=iwp) :: nAlpha, nBeta, nZeta, la, lb, nIC, nHer, nArr, nComp, nOrdOp, lOper(nComp), iChO(nComp), nStabM, & iStabM(0:nStabM-1), nGrid, iAddPot real(kind=wp) :: Alpha(nAlpha), Beta(nBeta), Zeta(nZeta), ZInv(nZeta), rKappa(nZeta), P(nZeta,3), & - Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nIC), A(3), RB(3), Array(nZeta*nArr), Ccoor(3,nComp), PtChrg(nGrid) -#else - Integer nAlpha, nBeta - Real*8 Alpha(nAlpha), Beta(nBeta) - Integer nZeta, la, lb, nIC - Real*8 Zeta(nZeta), ZInv(nZeta), rKappa(nZeta), P(nZeta,3) - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nIC) - Integer nHer - Real*8 A(3), RB(3) - Integer nArr - Real*8 Array(nZeta*nArr) - Integer nComp - Real*8 Ccoor(3,nComp) - Integer nOrdOp - Integer lOper(nComp), iChO(nComp) - Integer nStabM - Integer iStabM(0:nStabM-1) - Integer nGrid - Real*8 PtChrg(nGrid) - Integer iAddPot + rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),nIC), A(3), RB(3), Array(nZeta*nArr), Ccoor(3,nComp), PtChrg(nGrid) #endif -#undef _USE_WP_ #undef _CALLING_ diff -Nru openmolcas-22.02/src/Include/int_wrout_interface.fh openmolcas-22.10/src/Include/int_wrout_interface.fh --- openmolcas-22.02/src/Include/int_wrout_interface.fh 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/Include/int_wrout_interface.fh 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,36 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +#ifdef _CALLING_ +#ifdef _FIXED_FORMAT_ + &iCmp,iShell,MapOrg,iBas,jBas,kBas,lBas,kOp,Shijij,IJeqKL,iAO, & + &iAOst,ijkl,AOInt,SOInt,nSOint,iSOSym,nSkal,nSOs,TInt,nTInt,itOffs,& + &mSym & +#else +iCmp,iShell,MapOrg,iBas,jBas,kBas,lBas,kOp,Shijij,IJeqKL,iAO,iAOst,ijkl,AOInt,SOInt,nSOint,iSOSym,nSkal,nSOs,TInt,nTInt,itOffs, & +mSym & +#endif +#else +! TODO: unknown intents +#ifdef _FIXED_FORMAT_ + integer iCmp(4),iShell(4),MapOrg(4),iBas,jBas,kBas,lBas,kOp(4), & + &iAO(4),iAOst(4),ijkl,nSOint,nSOs,iSOSym(2,nSOs),nSkal,nTInt,mSym, & + &itOffs(0:mSym-1,0:mSym-1,0:7) + logical Shijij,IJeqKL + real*8 AOInt(*),SOInt(*),TInt(nTInt) +#else +integer(kind=iwp) :: iCmp(4), iShell(4), MapOrg(4), iBas, jBas, kBas, lBas, kOp(4), iAO(4), iAOst(4), ijkl, nSOint, nSOs, & + iSOSym(2,nSOs), nSkal, nTInt, mSym, itOffs(0:mSym-1,0:mSym-1,0:7) +logical(kind=iwp) :: Shijij, IJeqKL +real(kind=wp) :: AOInt(*), SOInt(*), TInt(nTInt) +#endif +#endif +#undef _CALLING_ diff -Nru openmolcas-22.02/src/Include/iTOffs.fh openmolcas-22.10/src/Include/iTOffs.fh --- openmolcas-22.02/src/Include/iTOffs.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/iTOffs.fh 2022-10-10 14:22:40.000000000 +0000 @@ -1,12 +1,12 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** Integer iTOffs(8**3) Common /iTOff_Data/ iTOffs diff -Nru openmolcas-22.02/src/Include/kind_matrix.h openmolcas-22.10/src/Include/kind_matrix.h --- openmolcas-22.02/src/Include/kind_matrix.h 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/kind_matrix.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,13 +0,0 @@ -/*********************************************************************** -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -***********************************************************************/ -#define SYMMETRIC_MATRIX 1 -#define ANTI_SYM_MATRIX -1 -#define SQUARE_MATRIX 0 diff -Nru openmolcas-22.02/src/Include/ksdft.fh openmolcas-22.10/src/Include/ksdft.fh --- openmolcas-22.02/src/Include/ksdft.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/ksdft.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** - Logical do_pdftpot - Integer ifiv,ifav,ifiv_n,ifav_n - Real*8 CoefR,CoefX - Common/KSDFT_GLM/ CoefR,CoefX - Common/KSDFT_AMS/ do_pdftpot,ifiv,ifav,ifiv_n,ifav_n - Real*8 PUVX_time, FA_time, FI_time,sp_time -! - Common /PD_TIME /PUVX_time, FA_time, FI_time,sp_time diff -Nru openmolcas-22.02/src/Include/lRI.fh openmolcas-22.10/src/Include/lRI.fh --- openmolcas-22.02/src/Include/lRI.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/lRI.fh 2022-10-10 14:22:40.000000000 +0000 @@ -1,12 +1,12 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Integer nAB, ipLocal_A, ISO2LO(2,MaxBfn+MaxBfn_Aux) +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + Integer nAB, ipLocal_A, nSO_Aux, ISO2LO(2,MaxBfn+MaxBfn_Aux) Common /lRI/ nAB, ipLocal_A, nSO_Aux, ISO2LO diff -Nru openmolcas-22.02/src/Include/max_idx_non.h openmolcas-22.10/src/Include/max_idx_non.h --- openmolcas-22.02/src/Include/max_idx_non.h 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/max_idx_non.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,11 +0,0 @@ -/*********************************************************************** -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -***********************************************************************/ -#define MAX_IDX_NON 0 diff -Nru openmolcas-22.02/src/Include/max_len_str.h openmolcas-22.10/src/Include/max_len_str.h --- openmolcas-22.02/src/Include/max_len_str.h 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/max_len_str.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,11 +0,0 @@ -/*********************************************************************** -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -***********************************************************************/ -#define MAX_LEN_STR 80 diff -Nru openmolcas-22.02/src/Include/mem_interface.fh openmolcas-22.10/src/Include/mem_interface.fh --- openmolcas-22.02/src/Include/mem_interface.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/mem_interface.fh 2022-10-10 14:22:40.000000000 +0000 @@ -10,12 +10,9 @@ !*********************************************************************** #ifdef _CALLING_ - & nHer,Mem,la,lb,lr & -#elif defined (_USE_WP_) +nHer,Mem,la,lb,lr & +#else integer(kind=iwp), intent(out) :: nHer, Mem integer(kind=iwp), intent(in) :: la, lb, lr -#else - Integer nHer,Mem,la,lb,lr #endif -#undef _USE_WP_ #undef _CALLING_ diff -Nru openmolcas-22.02/src/Include/mma_allo_template.fh openmolcas-22.10/src/Include/mma_allo_template.fh --- openmolcas-22.02/src/Include/mma_allo_template.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/mma_allo_template.fh 2022-10-10 14:22:40.000000000 +0000 @@ -110,14 +110,15 @@ #endif #if _DIMENSIONS_==0 ! we can't use storage_size(buffer) for an unallocated character(len=:) - bufsize = storage_size('a') * ntot / 8 + bufsize = (storage_size('a') * ntot - 1) / 8 + 1 #else - bufsize = storage_size(buffer) * ntot / 8 + bufsize = (storage_size(buffer) * ntot - 1) / 8 + 1 #endif if (bufsize .gt. mma_avail) then call mma_oom(label,bufsize,mma_avail) else #if _DIMENSIONS_==0 + if (n0 .eq. 0) call abend() allocate(character(len=n0) :: buffer) #elif _DIMENSIONS_==1 allocate(buffer(n1)) @@ -220,7 +221,7 @@ & (l4(2)-l4(1)+1) * (l5(2)-l5(1)+1) * (l6(2)-l6(1)+1) * & & (l7(2)-l7(1)+1) #endif - bufsize = storage_size(buffer) * ntot / 8 + bufsize = (storage_size(buffer) * ntot - 1) / 8 + 1 if (bufsize .gt. mma_avail) then call mma_oom(label,bufsize,mma_avail) else @@ -299,7 +300,7 @@ ntot = size(buffer) #endif #ifndef _DATA_NAME_ - bufsize = storage_size(buffer) * ntot / 8 + bufsize = (storage_size(buffer) * ntot - 1) / 8 + 1 #endif if (_MMA_FUNC_(buffer)) then if (ntot.gt.0) then @@ -349,6 +350,7 @@ #undef _DN_ #undef _MMA_ATTR_ #undef _MMA_FUNC_ +#undef _KEY_ #undef _ALLO_NAME_ #undef _ALLO_NAME_LIM_ #undef _FREE_NAME_ diff -Nru openmolcas-22.02/src/Include/niocr.fh openmolcas-22.10/src/Include/niocr.fh --- openmolcas-22.02/src/Include/niocr.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/niocr.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,14 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** -! This file is used by GUGA, MRCI and CPFMCPF -! Value 20000 works. Upper limit is not known now. - INTEGER nIOCR - Parameter (nIOCR=20000) diff -Nru openmolcas-22.02/src/Include/notab.fh openmolcas-22.10/src/Include/notab.fh --- openmolcas-22.02/src/Include/notab.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/notab.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,12 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** - Logical NoTab - Common /Tab/ NoTab diff -Nru openmolcas-22.02/src/Include/nrmf.fh openmolcas-22.10/src/Include/nrmf.fh --- openmolcas-22.02/src/Include/nrmf.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/nrmf.fh 2022-10-10 14:22:40.000000000 +0000 @@ -1,16 +1,18 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -c K.P. -c Dieses File enthaelt Inputdaten fuer die Modifikation der -c Ein-Elektronen-Integrale fuer die R-Matrix. +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** +! K.P. +! Dieses File enthaelt Inputdaten fuer die Modifikation der +! Ein-Elektronen-Integrale fuer die R-Matrix. + Real*8 expsum + Integer l,lcost,lsint,lcosf,lsinf Common /local1/ expsum Common /local2/ l Common /local3/ lcost,lsint,lcosf,lsinf diff -Nru openmolcas-22.02/src/Include/pamint.fh openmolcas-22.10/src/Include/pamint.fh --- openmolcas-22.02/src/Include/pamint.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/pamint.fh 2022-10-10 14:22:40.000000000 +0000 @@ -1,16 +1,16 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -* -* Data for rasscf potencial calculations -* +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** +! +! Data for rasscf potencial calculations +! integer, parameter :: nPAMintg = 1000 logical :: PamGen, PamGen1 real(kind=8) :: CPAM(nPAMintg) diff -Nru openmolcas-22.02/src/Include/points.fh openmolcas-22.10/src/Include/points.fh --- openmolcas-22.02/src/Include/points.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/points.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,12 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Common /points/ GGrid(3,6000) - Common /ipoints/ iiGrid diff -Nru openmolcas-22.02/src/Include/priunit.h openmolcas-22.10/src/Include/priunit.h --- openmolcas-22.02/src/Include/priunit.h 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/priunit.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,26 +0,0 @@ -/*********************************************************************** -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -***********************************************************************/ -#if defined(__CVERSION__) -struct common_priunit { - int lucmd, lupri, luerr, lustat, luw4, lupot, ninfo, nwarn, iprstatr; -}; -extern struct common_priunit priunit_; -#else -! FILE: priunit.h - CHARACTER*80 SEPARATOR - PARAMETER (SEPARATOR = '----------------------------------------' & - & //'----------------------------------------') - INTEGER LUCMD - INTEGER LUPRI, LUERR, LUSTAT, LUW4, LUPOT, NINFO, NWARN, IPRSTAT - COMMON /PRIUNIT/ LUCMD, & - & LUPRI, LUERR, LUSTAT, LUW4, LUPOT, NINFO, NWARN, IPRSTAT -! --- end of priunit.h --- -#endif diff -Nru openmolcas-22.02/src/Include/rasscf.fh openmolcas-22.10/src/Include/rasscf.fh --- openmolcas-22.02/src/Include/rasscf.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/rasscf.fh 2022-10-10 14:22:40.000000000 +0000 @@ -23,7 +23,7 @@ CHARACTER(2) HEADER(72) CHARACTER(2) QNSTEP CHARACTER(3) QNUPDT - Character(16) KSDFT, KSDFT_TEMP + Character(80) KSDFT, KSDFT_TEMP Character(4) DFTFOCK COMMON/INTAUX/ IODUMMY,IW,IPR,IPRINT,IPRDIA,ITERCI,ITERSX, & & ITER,MAXIT,NROOTS,IROOT,NAC, & @@ -92,8 +92,9 @@ INTEGER IRotPsi,IMSPDFT,IXMSP,ICMSP,ICMSIterMax, & & ICMSIterMin Real*8 CMSThreshold + CHARACTER(256) CMSStartMat COMMON/ROTST/ IRotPsi,IMSPDFT,IXMSP,ICMSP,ICMSIterMax, & - & ICMSIterMin,CMSThreshold + & ICMSIterMin,CMSThreshold,CMSStartMat ! REAL*8 EMY,S COMMON/RELCI/ EMY,S @@ -143,3 +144,12 @@ LOGICAL Do3RDM Common /B_OR_C/ Do3RDM #endif +#ifdef _ENABLE_DICE_SHCI_ + REAL*8 dice_eps1,dice_eps2 + INTEGER nref_dice,dice_sampleN,dice_iter + LOGICAL dice_stoc,dice_restart + CHARACTER(500) diceocc(20) + Common /DICE/ dice_eps1,dice_eps2, & + & nref_dice,dice_sampleN,dice_iter, & + & dice_stoc,dice_restart,diceocc +#endif diff -Nru openmolcas-22.02/src/Include/rctfld.fh openmolcas-22.10/src/Include/rctfld.fh --- openmolcas-22.02/src/Include/rctfld.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/rctfld.fh 2022-10-10 14:22:40.000000000 +0000 @@ -48,7 +48,7 @@ ! RadInp: radius of spheres explicitly given in the input * ! * !*********************************************************************** - integer, parameter :: MxPar=100,MxA=100 + integer, parameter :: MxPar=100,MxA=1000 integer lRFStrt, lRFEnd logical lRF, lLangevin, RF_Basis, PCM, Conductor, NonEq_ref, & & DoDeriv,lRFCav,LSparse,LGridAverage,lDamping,lAmberPol, & diff -Nru openmolcas-22.02/src/Include/real.fh openmolcas-22.10/src/Include/real.fh --- openmolcas-22.02/src/Include/real.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/real.fh 2022-10-10 14:22:40.000000000 +0000 @@ -20,4 +20,3 @@ Real*8, Parameter:: SqrtP2=0.8862269254527579D0 Real*8, Parameter:: TwoP34=0.2519794355383808D0 Real*8, Parameter:: TwoP54=5.914967172795612D0 - Real*8, Parameter:: One2C2=0.2662567690426443D-04 diff -Nru openmolcas-22.02/src/Include/spave.fh openmolcas-22.10/src/Include/spave.fh --- openmolcas-22.02/src/Include/spave.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/spave.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,14 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** - Integer ip_DSc - Logical Do_SpinAV - COMMON / SPAVE_L / Do_SpinAV - COMMON / SPAVE_I / ip_DSc diff -Nru openmolcas-22.02/src/Include/srint.fh openmolcas-22.10/src/Include/srint.fh --- openmolcas-22.02/src/Include/srint.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/srint.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -cgh - shortrange: triggers calculation of integrals for attenuated -cgh coulomb operator (erfc(omega*r)/r instead of 1/r) -cgh these integrals will be called "short range integrals" -cgh - decay_int: the value of omega in the formula for the attenuated -cgh coulomb operator (i. e. erfc(omega*r)/r) -cgh - isr_simulate: in combination with shortrange=.true. enables -cgh processing of the shortrange code while producing -cgh the conventional full range integrals -cgh (e.g., to compare timings) -cgh =0 means no simulation, really make shortrange integr. -cgh =1 means the full shortrange code is run through, but -cgh the conventional integrals are produced -cgh =2 only disables the special cases -#ifdef MOLPRO - real *8 decay_int,thratten - common/srintr/ thratten,decay_int -#endif - Logical shortrange - Integer isr_simulate - Common /srintl/ shortrange - Common /srinti/ isr_simulate diff -Nru openmolcas-22.02/src/Include/stdalloc.fh openmolcas-22.10/src/Include/stdalloc.fh --- openmolcas-22.02/src/Include/stdalloc.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/stdalloc.fh 2022-10-10 14:22:40.000000000 +0000 @@ -243,6 +243,16 @@ integer, intent(in) :: l1(2), l2(2), l3(2), l4(2), l5(2) character(len=*), optional, intent(in) :: label end subroutine + subroutine imma_allo_5D(buffer,n1,n2,n3,n4,n5,label) + integer, allocatable, intent(inout) :: buffer(:,:,:,:,:) + integer, intent(in) :: n1, n2, n3, n4, n5 + character(len=*), optional, intent(in) :: label + end subroutine + subroutine imma_allo_5D_lim(buffer,l1,l2,l3,l4,l5,label) + integer, allocatable, intent(inout) :: buffer(:,:,:,:,:) + integer, intent(in) :: l1(2), l2(2), l3(2), l4(2), l5(2) + character(len=*), optional, intent(in) :: label + end subroutine ! 7D allocate subroutine dmma_allo_7D(buffer,n1,n2,n3,n4,n5,n6,n7,label) @@ -346,6 +356,9 @@ subroutine zmma_free_5D(buffer) complex*16, allocatable, intent(inout) :: buffer(:,:,:,:,:) end subroutine + subroutine imma_free_5D(buffer) + integer, allocatable, intent(inout) :: buffer(:,:,:,:,:) + end subroutine ! 7D deallocate subroutine dmma_free_7D(buffer) diff -Nru openmolcas-22.02/src/Include/stdout.h openmolcas-22.10/src/Include/stdout.h --- openmolcas-22.02/src/Include/stdout.h 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/stdout.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,11 +0,0 @@ -/*********************************************************************** -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -***********************************************************************/ -#define STDOUT 6 diff -Nru openmolcas-22.02/src/Include/t3int.fh openmolcas-22.10/src/Include/t3int.fh --- openmolcas-22.02/src/Include/t3int.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/t3int.fh 2022-10-10 14:22:40.000000000 +0000 @@ -1,17 +1,24 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -c3 array for storing possitions of (ab|ci) blocks for given i - integer T3IntPoss(1:mxt3pos) -c -c4 array for disk address offsets in t3nam file +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** +!2 name for joined T3 integral file + character*6 t3nam + parameter (t3nam='T3VVVO') +! + integer mxt3pos + parameter (mxt3pos=1024) ! = mbas = maxorb +! +!3 array for storing positions of (ab|ci) blocks for given i + integer T3IntPos(1:mxt3pos) +! +!4 array for disk address offsets in t3nam file integer T3Off(1:512,1:8) -c - common /cmmt31/ T3IntPoss,T3Off +! + common /cmmt31/ T3IntPos,T3Off diff -Nru openmolcas-22.02/src/Include/temperatures.fh openmolcas-22.10/src/Include/temperatures.fh --- openmolcas-22.02/src/Include/temperatures.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/temperatures.fh 2022-10-10 14:22:40.000000000 +0000 @@ -1,17 +1,17 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -* Default temperatures for thermochemistry (MCLR, SLAPAF) +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** +! Default temperatures for thermochemistry (MCLR, SLAPAF) Integer NDefTemp Parameter(NDefTemp=7) Real*8 DefTemp Dimension DefTemp(NDefTemp) - Data DefTemp /0.0d0,100.0d0, + Data DefTemp /0.0d0,100.0d0, & & 273.15d0,298.15d0,323.15d0,373.15d0,473.15d0/ diff -Nru openmolcas-22.02/src/Include/TriInd.fh openmolcas-22.10/src/Include/TriInd.fh --- openmolcas-22.02/src/Include/TriInd.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/TriInd.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,13 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Parameter (I_Max=50,IJ_Max=(I_Max*(I_Max+1))/2) - Integer iTriInd(2,IJ_Max) - Common /C_TriInd/ iTriInd diff -Nru openmolcas-22.02/src/Include/wrk.fh openmolcas-22.10/src/Include/wrk.fh --- openmolcas-22.02/src/Include/wrk.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/wrk.fh 2022-10-10 14:22:40.000000000 +0000 @@ -1,16 +1,16 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -c -c declaration of work-space -c +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** +! +! declaration of work-space +! integer wrksize real*8 wrk(1:wrksize) -c +! diff -Nru openmolcas-22.02/src/Include/xkind.h openmolcas-22.10/src/Include/xkind.h --- openmolcas-22.02/src/Include/xkind.h 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/Include/xkind.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,12 +0,0 @@ -/*********************************************************************** -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -***********************************************************************/ -#define REALK 8 -#define _REALK _8 diff -Nru openmolcas-22.02/src/input_util/zmatrixconverter.F90 openmolcas-22.10/src/input_util/zmatrixconverter.F90 --- openmolcas-22.02/src/input_util/zmatrixconverter.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/input_util/zmatrixconverter.F90 2022-10-10 14:22:40.000000000 +0000 @@ -23,12 +23,16 @@ !> This new code is in the ::StdSewInput routine. !> Only the standard basis present in the ``$MOLCAS/basis_library`` are allowed. !> -!> @param[in] LuRd Input file unit number -!> @param[in] LuWr Output file unit number -!> @param[in] mxAtom Parameter -!> @param[out] STDINP String vector of seward standard input -!> @param[out] lSTDINP Length of String vector \p STDINP -!> @param[out] iErr Error flag +!> @param[in] LuRd Input file unit number +!> @param[in] LuWr Output file unit number +!> @param[in] mxAtom Parameter +!> @param[out] STDINP String vector of seward standard input +!> @param[out] lSTDINP Length of String vector \p STDINP +!> @param[in] iglobal +!> @param[in,out] nxbas +!> @param[in] xb_label +!> @param[in] xb_bas +!> @param[out] iErr Error flag !*********************************************************************** subroutine ZMatrixConverter(LuRd,LuWr,mxAtom,STDINP,lSTDINP,iglobal,nxbas,xb_label,xb_bas,iErr) diff -Nru openmolcas-22.02/src/integral_util/auxil.f openmolcas-22.10/src/integral_util/auxil.f --- openmolcas-22.02/src/integral_util/auxil.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/auxil.f 2022-10-10 14:22:40.000000000 +0000 @@ -27,7 +27,7 @@ * Call HighFm(Fm(1,mHigh),T,mHigh,nT) * -* Now use recusion formula for Fm, 0<=m0) Then @@ -107,7 +101,7 @@ Do 200 i2 = 1, jCmp jChBs = iChBas(jj+i2) If (Shells(iShll(2))%Transf) jChBs = iChBas(iSphCr(jj+i2)) - pb = xPrmt(iOper(kOp(2)),jChBs) + pb = Prmt(iOper(kOp(2)),jChBs) njSym=0 Do 201 j = 0, nIrrep-1 If (iAOtSO(iAO(2)+i2,j)>0) Then @@ -119,7 +113,7 @@ kChBs = iChBas(kk+i3) If (Shells(iShll(3))%Transf) & kChBs = iChBas(iSphCr(kk+i3)) - pc = xPrmt(iOper(kOp(3)),kChBs) + pc = Prmt(iOper(kOp(3)),kChBs) nkSym=0 Do 301 j = 0, nIrrep-1 If (iAOtSO(iAO(3)+i3,j)>0) Then @@ -133,7 +127,7 @@ & lChBs = iChBas(iSphCr(ll+i4)) *-----------------Parity factor due to symmetry operations applied to the * angular part of the basis functions. - FactNs = pa*pb*pc * xPrmt(iOper(kOp(4)),lChBs) + FactNs = pa*pb*pc * Prmt(iOper(kOp(4)),lChBs) nlSym=0 Do 401 j = 0, nIrrep-1 If (iAOtSO(iAO(4)+i4,j)>0) Then diff -Nru openmolcas-22.02/src/integral_util/drvk2.f openmolcas-22.10/src/integral_util/drvk2.f --- openmolcas-22.02/src/integral_util/drvk2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/drvk2.f 2022-10-10 14:22:40.000000000 +0000 @@ -136,6 +136,7 @@ Else Rls=.True. Call mma_maxDBLE(MemMax) + If (MemMax.gt.1000) MemMax=MemMax-1000 Call mma_allocate(Sew_Scr,MemMax,Label='Sew_Scr') C Write (*,*) 'Drvk2: Memory allocated:',MemMax End If diff -Nru openmolcas-22.02/src/integral_util/drvxv.f openmolcas-22.10/src/integral_util/drvxv.f --- openmolcas-22.02/src/integral_util/drvxv.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/drvxv.f 2022-10-10 14:22:40.000000000 +0000 @@ -15,7 +15,6 @@ use EFP_Module #endif use OFembed, only: Do_OFemb, OFE_KSDFT - use nq_Info Implicit Real*8 (a-h,o-z) #include "real.fh" #include "debug.fh" @@ -96,8 +95,8 @@ Grad=Zero nGrad=1 If (KSDFT.ne.'SCF'.and.Do_DFT) - & Call DrvDFT(h1,TwoHam,D,RepNuc,nh1,First,Dff,lRF,KSDFT,ExFac, - & Do_Grad,Grad,nGrad,iSpin,D1I,D1A,nD1,DFTFOCK) + & Call DrvDFT(h1,nh1,KSDFT,ExFac, + & Do_Grad,Grad,nGrad,iSpin,DFTFOCK) * ************************************************************************ * * @@ -106,8 +105,7 @@ ************************************************************************ * * If (Do_OFemb) - & Call DrvEMB(h1,D,RepNuc,nh1,OFE_KSDFT,ExFac, - & Do_Grad,Grad,nGrad,D1I,D1A,nD1,DFTFOCK) + & Call DrvEMB(nh1,OFE_KSDFT,Do_Grad,Grad,nGrad,DFTFOCK) * * ************************************************************************ * * @@ -119,4 +117,9 @@ ************************************************************************ * * Return +* Avoid unused argument warnings + If (.False.) then + Call Unused_real_array(D1I) + Call Unused_real_array(D1A) + End If End diff -Nru openmolcas-22.02/src/integral_util/eval_ijkl.f openmolcas-22.10/src/integral_util/eval_ijkl.f --- openmolcas-22.02/src/integral_util/eval_ijkl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/eval_ijkl.f 2022-10-10 14:22:40.000000000 +0000 @@ -148,6 +148,7 @@ If (.Not.Allocated(Sew_Scr)) Then C Write (*,*) 'Eval_ints: Allocate memory' Call mma_MaxDBLE(MemMax) + If (MemMax.gt.1000) MemMax=MemMax-1000 Call mma_allocate(Sew_Scr,MemMax,Label='Sew_Scr') Else C Write (*,*) 'Eval_ints: Memory already allocated' diff -Nru openmolcas-22.02/src/integral_util/eval_ints_new_inner.f openmolcas-22.10/src/integral_util/eval_ints_new_inner.f --- openmolcas-22.02/src/integral_util/eval_ints_new_inner.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/eval_ints_new_inner.f 2022-10-10 14:22:40.000000000 +0000 @@ -157,6 +157,7 @@ * * If (.NOT.Allocated(Sew_Scr)) Then Call mma_MaxDBLE(MemMax) + If (MemMax.gt.1000) MemMax=MemMax-1000 Call mma_allocate(Sew_Scr,MemMax,Label='Sew_Scr') Else MemMax=SIZE(Sew_Scr) diff -Nru openmolcas-22.02/src/integral_util/fckacc.f openmolcas-22.10/src/integral_util/fckacc.f --- openmolcas-22.02/src/integral_util/fckacc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/fckacc.f 2022-10-10 14:22:40.000000000 +0000 @@ -50,7 +50,7 @@ use Basis_Info use SOAO_Info, only: iAOtSO use Real_Spherical, only: iSphCr - use Symmetry_Info, only: nIrrep, iOper, iChBas + use Symmetry_Info, only: iChBas, iOper, nIrrep, Prmt use Gateway_Info, only: ThrInt, CutInt Implicit Real*8 (A-H,O-Z) #include "real.fh" @@ -79,16 +79,13 @@ & iAO(4), iAOst(4), iCmpa(4) * Local Arrays Integer iSym(4) - Real*8 Prmt(0:7) c Character*72 Label - Data Prmt/1.d0,-1.d0,-1.d0,1.d0,-1.d0,1.d0,1.d0,-1.d0/ * * ************************************************************************ * * * Statement Function * iOff(ixyz) = ixyz*(ixyz+1)*(ixyz+2)/6 - xPrmt(i,j) = Prmt(iAnd(i,j)) c iTri(i,j) = Max(i,j)*(Max(i,j)-1)/2 + Min(i,j) * * ************************************************************************ @@ -192,7 +189,7 @@ If (iShij) jCmpMx = i1 iChBs = iChBas(ii+i1) If (Shells(iShll(1))%Transf) iChBs = iChBas(iSphCr(ii+i1)) - pEa = xPrmt(iOper(kOp(1)),iChBs) + pEa = Prmt(iOper(kOp(1)),iChBs) Do 200 i2 = 1, jCmpMx ix = 0 Do j = 0, nIrrep-1 @@ -201,7 +198,7 @@ iSym(2)=ix jChBs = iChBas(jj+i2) If (Shells(iShll(2))%Transf) jChBs = iChBas(iSphCr(jj+i2)) - pRb = xPrmt(iOper(kOp(2)),jChBs) + pRb = Prmt(iOper(kOp(2)),jChBs) If (iShell(2).gt.iShell(1)) Then i12 = jCmp*(i1-1) + i2 Else @@ -218,7 +215,7 @@ kChBs = iChBas(kk+i3) If (Shells(iShll(3))%Transf) & kChBs = iChBas(iSphCr(kk+i3)) - pTc = xPrmt(iOper(kOp(3)),kChBs) + pTc = Prmt(iOper(kOp(3)),kChBs) Do 400 i4 = 1, lCmpMx ix = 0 Do j = 0, nIrrep-1 @@ -228,7 +225,7 @@ lChBs = iChBas(ll+i4) If (Shells(iShll(4))%Transf) & lChBs = iChBas(iSphCr(ll+i4)) - pTSd= xPrmt(iOper(kOp(4)),lChBs) + pTSd= Prmt(iOper(kOp(4)),lChBs) If (iShell(4).gt.iShell(3)) Then i34 = lCmp*(i3-1) + i4 Else diff -Nru openmolcas-22.02/src/integral_util/free_herRW.f openmolcas-22.10/src/integral_util/free_herRW.f --- openmolcas-22.02/src/integral_util/free_herRW.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/free_herRW.f 2022-10-10 14:22:40.000000000 +0000 @@ -9,7 +9,7 @@ * LICENSE or in . * ************************************************************************ SubRoutine Free_HerRW() - use Her_RW + use Her_RW, only: HerR, HerW, iHerR, iHerw Implicit Real*8 (A-H,O-Z) #include "stdalloc.fh" If (Allocated(iHerR)) Call mma_deallocate(iHerR) diff -Nru openmolcas-22.02/src/integral_util/getinf.f openmolcas-22.10/src/integral_util/getinf.f --- openmolcas-22.02/src/integral_util/getinf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/getinf.f 2022-10-10 14:22:40.000000000 +0000 @@ -21,12 +21,11 @@ ************************************************************************ Use Iso_C_Binding use Real_Spherical - use Her_RW + use Her_RW, only: nPrp use External_Centers use Gateway_global, only: Test use DKH_Info, only: DKroll use Sizes_of_Seward, only: S - use nq_Info Implicit Real*8 (A-H,O-Z) #include "stdalloc.fh" #include "print.fh" @@ -36,17 +35,15 @@ Logical DoRys #include "SysDef.fh" * - Call GetInf_Internal(cRFStrt,iRFStrt,lRFStrt,rRFStrt, - & cQStrt,iQStrt,rQStrt) + Call GetInf_Internal(cRFStrt,iRFStrt,lRFStrt,rRFStrt) * * This is to allow type punning without an explicit interface Contains - SubRoutine GetInf_Internal(cRFStrt,iRFStrt,lRFStrt,rRFStrt, - & cQStrt,iQStrt,rQStrt) - Integer, Target :: cRFStrt,iRFStrt,lRFStrt,cQStrt,iQStrt - Real*8, Target :: rRFStrt,rQStrt - Integer, Pointer :: p_cRF(:),p_iRF(:),p_lRF(:),p_cQ(:),p_iQ(:) - Real*8, Pointer :: p_rRF(:),p_rQ(:) + SubRoutine GetInf_Internal(cRFStrt,iRFStrt,lRFStrt,rRFStrt) + Integer, Target :: cRFStrt,iRFStrt,lRFStrt + Real*8, Target :: rRFStrt + Integer, Pointer :: p_cRF(:),p_iRF(:),p_lRF(:) + Real*8, Pointer :: p_rRF(:) * * Load the dynamic input area. * @@ -82,24 +79,6 @@ * * ************************************************************************ * * -* Numerical integration information and parameters -* - Len = ip_of_Work(rQEnd)-ip_of_Work(rQStrt)+1 - Call C_F_Pointer(C_Loc(rQStrt),p_rQ,[Len]) - Call Get_dArray('Quad_r',p_rQ,Len) -* - Len = ip_of_iWork(iQEnd)-ip_of_iWork(iQStrt)+1 - Call C_F_Pointer(C_Loc(iQStrt),p_iQ,[Len]) - Call Get_iArray('Quad_i',p_iQ,Len) -* - Len = ip_of_iWork(cQEnd)-ip_of_iWork(cQStrt)+1 - Call C_F_Pointer(C_Loc(cQStrt),p_cQ,[Len]) - Call Get_iArray('Quad_c',p_cQ,Len) -* - Nullify(p_rQ,p_iQ,p_cQ) -* * -************************************************************************ -* * * Generate the transformation matrices * If (S%iAngMx-1.ge.lMax) Then diff -Nru openmolcas-22.02/src/integral_util/get_info_static.f openmolcas-22.10/src/integral_util/get_info_static.f --- openmolcas-22.02/src/integral_util/get_info_static.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/get_info_static.f 2022-10-10 14:22:40.000000000 +0000 @@ -20,14 +20,16 @@ use Symmetry_Info, only: Symmetry_Info_Get use Sizes_of_Seward, only: Size_Get use DKH_Info, only: DKH_Info_Get - use RICD_Info, only: RICD_Info_Get use Gateway_Info, only: Gateway_Info_Get + use RICD_Info, only: RICD_Info_Get + use NQ_Info, only: NQ_Info_Get Call Symmetry_Info_Get() Call Size_Get() Call DKH_Info_Get() Call Gateway_Info_Get() Call RICD_Info_Get() + Call NQ_Info_Get() Return End diff -Nru openmolcas-22.02/src/integral_util/int_setup.f openmolcas-22.10/src/integral_util/int_setup.f --- openmolcas-22.02/src/integral_util/int_setup.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/int_setup.f 2022-10-10 14:22:40.000000000 +0000 @@ -12,10 +12,10 @@ & iAngV,iCmpV,iShelV,iShllV,iAOV,iStabs) Use Basis_Info use Gateway_Info, only: DoFMM, RPQMin + use Gateway_global, only: FMM_shortrange Implicit Real*8 (a-h,o-z) * #include "nsd.fh" -#include "FMM.fh" Integer iSD(0:nSD,nSkal) * Real*8 Coor(3,4) diff -Nru openmolcas-22.02/src/integral_util/k2loop.f openmolcas-22.10/src/integral_util/k2loop.f --- openmolcas-22.02/src/integral_util/k2loop.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/k2loop.f 2022-10-10 14:22:40.000000000 +0000 @@ -78,21 +78,27 @@ & nDCRR) Integer, Pointer :: iData(:) Logical, External :: TF +#ifdef _WARNING_WORKAROUND_ Interface - SubRoutine Rys(iAnga,nT,Zeta,ZInv,nZeta, - & Eta,EInv,nEta, - & P,lP,Q,lQ,rKapab,rKapcd,Coori,Coora,CoorAC, - & mabMin,mabMax,mcdMin,mcdMax,Array,nArray, - & Tvalue,ModU2,Cff2D,Rys2D,NoSpecial) - Integer iAnga(4), nT, nZeta, nEta, lP, lQ, mabMin, mabMax, - & mcdMin, mcdMax, nArray - External Tvalue, ModU2, Cff2D, Rys2D - Real*8 Zeta(nZeta), ZInv(nZeta), P(lP,3), rKapab(nZeta), - & Eta(nEta), EInv(nEta), Q(lQ,3), rKapcd(nEta), - & CoorAC(3,2), Coora(3,4), Coori(3,4), Array(nArray) - Logical NoSpecial + SubRoutine Rys(iAnga,nT,Zeta,ZInv,nZeta,Eta,EInv,nEta,P,lP,Q,lQ, + & rKapab,rKapcd,Coori,Coora,CoorAC,mabMin,mabMax, + & mcdMin,mcdMax,Array,nArray,Tvalue,ModU2,Cff2D, + & Rys2D,NoSpecial) + use Definitions, only: wp, iwp + integer(kind=iwp), intent(in) :: iAnga(4), nT, nZeta, nEta, lP, + & lQ, mabMin, mabMax, mcdMin, + & mcdMax, nArray + real(kind=wp), intent(in) :: Zeta(nZeta), ZInv(nZeta), + & Eta(nEta), EInv(nEta), P(lP,3), + & Q(lQ,3), rKapab(nZeta), + & rKapcd(nEta), Coori(3,4), + & Coora(3,4), CoorAC(3,2) + real(kind=wp), intent(inout) :: Array(nArray) + external :: Tvalue, ModU2, Cff2D, Rys2D + logical(kind=iwp), intent(in) :: NoSpecial End Subroutine Rys End Interface +#endif * * ************************************************************************ * * @@ -186,7 +192,7 @@ mabcd=(mabMax-mabMin+1)*(mcdMax-mcdMin+1) * * Find the proper centers to start of with the angular -* momentum on. If la.eq.lb there will excist an +* momentum on. If la.eq.lb there will exist an * ambiguity to which center that angular momentum should * be accumulated on. In that case we will use A and C of * the order as defined by the basis functions types. diff -Nru openmolcas-22.02/src/integral_util/kneprm.f openmolcas-22.10/src/integral_util/kneprm.f --- openmolcas-22.02/src/integral_util/kneprm.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/kneprm.f 2022-10-10 14:22:40.000000000 +0000 @@ -23,7 +23,7 @@ * November '90 * * Modified to multipole moments November '90 * ************************************************************************ - use Her_RW + use Her_RW, only: HerR, HerW, iHerR, iHerW Implicit Real*8 (A-H,O-Z) #include "real.fh" Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nComp), diff -Nru openmolcas-22.02/src/integral_util/mk_triind.f openmolcas-22.10/src/integral_util/mk_triind.f --- openmolcas-22.02/src/integral_util/mk_triind.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/mk_triind.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,26 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Mk_TriInd() -* -#include "TriInd.fh" -* - ij = 0 - Do k = 0, I_Max-1 - Do i = 0, k - j = k - i - ij = ij + 1 - iTriInd(1,ij)=i - iTriInd(2,ij)=j - End Do - End Do -* - Return - End diff -Nru openmolcas-22.02/src/integral_util/mltprm.f openmolcas-22.10/src/integral_util/mltprm.f --- openmolcas-22.02/src/integral_util/mltprm.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/mltprm.f 2022-10-10 14:22:40.000000000 +0000 @@ -23,7 +23,7 @@ * November '90 * * Modified to multipole moments November '90 * ************************************************************************ - use Her_RW + use Her_RW, only: HerR, HerW, iHerR, iHerw Implicit Real*8 (A-H,O-Z) #include "real.fh" Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nComp), diff -Nru openmolcas-22.02/src/integral_util/oneel_ij.f openmolcas-22.10/src/integral_util/oneel_ij.f --- openmolcas-22.02/src/integral_util/oneel_ij.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/oneel_ij.f 2022-10-10 14:22:40.000000000 +0000 @@ -63,17 +63,6 @@ * * ************************************************************************ * * - Interface - Subroutine Kernel( -#define _CALLING_ -#include "int_interface.fh" - & ) -#include "int_interface.fh" - End Subroutine Kernel - End Interface -* * -************************************************************************ -* * If (Label(1:3).eq.'MAG') Then iCmp = iSD( 2,iS) iBas = iSD( 3,iS) diff -Nru openmolcas-22.02/src/integral_util/pget0.f openmolcas-22.10/src/integral_util/pget0.f --- openmolcas-22.02/src/integral_util/pget0.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/pget0.f 2022-10-10 14:22:40.000000000 +0000 @@ -87,8 +87,8 @@ If (Case_2C) Then If (Do_RI) Then Call PGet1_RI2(PSO,ijkl,nPSO,iCmp, - & iAO,iAOst,Shijij, - & iBas,jBas,kBas,lBas,kOp, + & iAO,iAOst, + & jBas,lBas,kOp, & ExFac,CoulFac,PMax, & V_K,U_K,nV_K, & Z_p_k,nSA) @@ -100,9 +100,9 @@ Else If (Case_3C) Then If (Do_RI) Then Call PGet1_RI3(PSO,ijkl,nPSO,iCmp, - & iAO,iAOst,Shijij, - & iBas,jBas,kBas,lBas,kOp,D0, - & DS,DVar,nDens, + & iAO,iAOst, + & jBas,kBas,lBas,kOp,D0, + & DVar,nDens, & ExFac,CoulFac,PMax, & V_K,U_K,nV_K, & Z_p_k,nnP(0),nSA,nAsh) @@ -124,8 +124,8 @@ If (Case_2C) Then If (Do_RI) Then Call PGet2_RI2(iCmp, - & iBas,jBas,kBas,lBas, - & Shijij, iAO, iAOst, ijkl, PSO, nPSO, + & jBas,lBas, + & iAO, iAOst, ijkl, PSO, nPSO, & ExFac,CoulFac, & PMax,V_K,nV_K, & Z_p_k,nSA,nZ_p_k) @@ -137,9 +137,9 @@ Else If (Case_3C) Then If (Do_RI) Then Call PGet2_RI3(iCmp, - & iBas,jBas,kBas,lBas, - & Shijij, iAO, iAOst, ijkl, PSO, nPSO, - & D0,DS,nDens,ExFac, + & jBas,kBas,lBas, + & iAO, iAOst, ijkl, PSO, nPSO, + & D0,nDens,ExFac, & CoulFac,PMax,V_K,nV_K, & Z_p_k,nSA,nAsh) @@ -212,14 +212,14 @@ If (Case_2C) Then If (Do_RI) Then Call PGet1_RI2(PSO,ijkl,nPSO,iCmp, - & iAO,iAOst,Shijij, - & iBas,jBas,kBas,lBas,kOp, + & iAO,iAOst, + & jBas,lBas,kOp, & ExFac,CoulFac,PMax, & V_K,U_K,nV_K, & Z_p_k, nSA) Else Call PGet1_CD2(PSO,ijkl,nPSO,iCmp, - & iAO,iAOst,Shijij, + & iAO,iAOst, & iBas,jBas,kBas,lBas,kOp, & ExFac,CoulFac,PMax, & V_K,U_K,nV_K, @@ -228,17 +228,17 @@ Else If (Case_3C) Then If (Do_RI) Then Call PGet1_RI3(PSO,ijkl,nPSO,iCmp, - & iAO,iAOst,Shijij, - & iBas,jBas,kBas,lBas,kOp,D0, - & DS,DVar,nDens, + & iAO,iAOst, + & jBas,kBas,lBas,kOp,D0, + & DVar,nDens, & ExFac,CoulFac,PMax, & V_K,U_K,nV_K, & Z_p_k,nnP(0),nSA,nAsh) Else Call PGet1_CD3(PSO,ijkl,nPSO,iCmp, - & iAO,iAOst,Shijij, + & iAO,iAOst, & iBas,jBas,kBas,lBas,kOp,D0, - & DS,DVar,nDens, + & DVar,nDens, & ExFac,CoulFac,PMax, & V_K,U_K,nV_K) End If @@ -275,31 +275,31 @@ If (Do_RI) Then Call PGet2_RI2(iCmp, - & iBas,jBas,kBas,lBas, - & Shijij, iAO, iAOst, ijkl, PSO, nPSO, + & jBas,lBas, + & iAO, iAOst, ijkl, PSO, nPSO, & ExFac,CoulFac, & PMax,V_K,nV_K, & Z_p_k, nSA,nZ_p_k) Else Call PGet2_CD2(iCmp, & iBas,jBas,kBas,lBas, - & Shijij, iAO, iAOst, ijkl, PSO, nPSO, - & ExFac,CoulFac, + & iAO, iAOst, ijkl, PSO, nPSO, + & CoulFac, & PMax,V_K,nV_K) End If Else If (Case_3C) Then If (Do_RI) Then Call PGet2_RI3(iCmp, - & iBas,jBas,kBas,lBas, - & Shijij, iAO, iAOst, ijkl, PSO, nPSO, - & D0,DS,nDens,ExFac, + & jBas,kBas,lBas, + & iAO, iAOst, ijkl, PSO, nPSO, + & D0,nDens,ExFac, & CoulFac,PMax,V_K,nV_K, & Z_p_k,nSA,nAsh) Else Call PGet2_CD3(iCmp, & iBas,jBas,kBas,lBas, - & Shijij, iAO, iAOst, ijkl, PSO, nPSO, - & D0,DS,nDens,ExFac, + & iAO, iAOst, ijkl, PSO, nPSO, + & D0,nDens, & CoulFac,PMax,V_K,nV_K) End If * diff -Nru openmolcas-22.02/src/integral_util/prepp.f openmolcas-22.10/src/integral_util/prepp.f --- openmolcas-22.02/src/integral_util/prepp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/prepp.f 2022-10-10 14:22:40.000000000 +0000 @@ -46,12 +46,15 @@ ************************************************************************ Integer nFro(0:7) Integer Columbus - Character*8 RlxLbl,Method, KSDFT*16 + Character*8 RlxLbl,Method, KSDFT*80 Logical lPrint Logical DoCholesky Real*8 CoefX,CoefR Character Fmt*60 Real*8, Allocatable:: D1ao(:), D1AV(:), Tmp(:,:) +* hybrid MC-PDFT things + Logical Do_Hybrid + Real*8 WF_Ratio,PDFT_Ratio * *... Prologue @@ -91,7 +94,7 @@ & Method.eq. 'MSPDFT ' .or. & Method.eq. 'CASDFT ' ) Then Call Get_iScalar('Multiplicity',iSpin) - Call Get_cArray('DFT functional',KSDFT,16) + Call Get_cArray('DFT functional',KSDFT,80) Call Get_dScalar('DFT exch coeff',CoefX) Call Get_dScalar('DFT corr coeff',CoefR) ExFac=Get_ExFac(KSDFT) @@ -499,8 +502,14 @@ * Call Get_DLAO(D0(:,4),nDens) +* Getting conditions for hybrid MC-PDFT + Do_Hybrid=.false. + CALL qpg_DScalar('R_WF_HMC',Do_Hybrid) + If(Do_Hybrid) Then + CALL Get_DScalar('R_WF_HMC',WF_Ratio) + PDFT_Ratio=1.0d0-WF_Ratio + End If !ANDREW - modify D2: should contain only the correction pieces - If ( Method.eq.'MCPDFT ') then !Get the D_theta piece Call mma_allocate(D1ao,nDens) @@ -527,6 +536,15 @@ D0(:,5)=Zero call daxpy_(ndens,0.5d0,D0(1,1),1,D0(1,5),1) call daxpy_(ndens,1.0d0,D1ao,1,D0(1,5),1) + + if(do_hybrid) then +* add back the wave function parts that are subtracted +* this might be inefficient, but should have a clear logic + call daxpy_(ndens,Half*WF_Ratio,D0(1,1),1,D0(1,2),1) + call daxpy_(ndens,WF_Ratio,D1ao,1,D0(1,2),1) +* scale the pdft part + call dscal_(ndens,PDFT_Ratio,D0(1,5),1) + end if Call mma_deallocate(D1ao) else If (Method.eq.'MSPDFT ') Then Call Get_DArray('MSPDFTD5 ',D0(1,5),nDens) diff -Nru openmolcas-22.02/src/integral_util/real_spherical.f openmolcas-22.10/src/integral_util/real_spherical.f --- openmolcas-22.02/src/integral_util/real_spherical.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/real_spherical.f 2022-10-10 14:22:40.000000000 +0000 @@ -24,11 +24,11 @@ Logical :: Condon_Shortley_phase_factor=.False. Character(LEN=8), Allocatable :: LblCBs(:), LblSBs(:) * -*********************************************************************** +************************************************************************ * Contains * -*********************************************************************** +************************************************************************ * SubRoutine Sphere_Free() If (Allocated(RSph)) Call mma_deallocate(RSph) @@ -39,7 +39,7 @@ lmax_internal=-1 End SubRoutine Sphere_Free * -*********************************************************************** +************************************************************************ * SubRoutine Sphere(lMax) ************************************************************************ @@ -213,13 +213,13 @@ Return End Subroutine Real_Sphere Subroutine Recurse(P0,P1,P2,n2) -*********************************************************************** -* * -* The Legendre polynomial is identical to Y(l,0). * -* Note that it is real and that there is no Condon-Shortley phase * -* factor to consider. * -* * -*********************************************************************** +************************************************************************ +* * +* The Legendre polynomial is identical to Y(l,0). * +* Note that it is real and that there is no Condon-Shortley phase * +* factor to consider. * +* * +************************************************************************ Implicit Real*8 (a-h,o-z) #include "real.fh" Real*8 P0((n2-1)*n2/2), P1(n2*(n2+1)/2),P2((n2+1)*(n2+2)/2) @@ -428,6 +428,6 @@ Return End Subroutine NrmSph * -*********************************************************************** +************************************************************************ * End Module Real_Spherical diff -Nru openmolcas-22.02/src/integral_util/rfint.f openmolcas-22.10/src/integral_util/rfint.f --- openmolcas-22.02/src/integral_util/rfint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/rfint.f 2022-10-10 14:22:40.000000000 +0000 @@ -23,11 +23,11 @@ * November '90 * * Modified to multipole moments November '90 * * * -* Roland Lindh, Dept. of Theoratical Chemistry, University * +* Roland Lindh, Dept. of Theoretical Chemistry, University * * of Lund, SWEDEN. * * Modified to reaction field calculations July '92 * ************************************************************************ - use Her_RW + use Her_RW, only: HerR, HerW, iHerR, iHerw Implicit Real*8 (A-H,O-Z) #include "real.fh" Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nComp), diff -Nru openmolcas-22.02/src/integral_util/screen.f openmolcas-22.10/src/integral_util/screen.f --- openmolcas-22.02/src/integral_util/screen.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/screen.f 2022-10-10 14:22:40.000000000 +0000 @@ -23,9 +23,9 @@ * * * Object: to prescreen the integrals for Direct SCF * * * -* nZeta, nEta : unpartioned length of primitives. * +* nZeta, nEta : unpartitioned length of primitives. * * * -* mZeta, mEta : section length due to partioning. These are usually * +* mZeta, mEta : section length due to partitioning. These are usually* * equal to nZeta and nEta. * * * * lZeta, lEta : section length after prescreening. * @@ -42,14 +42,16 @@ ************************************************************************ Implicit Real*8 (A-H,O-Z) #include "ndarray.fh" - Real*8 Zeta(mZeta), ZInv(mZeta), KappAB(mZeta), P(nZeta,3), - & Eta(mEta), EInv(mEta), KappCD(mEta), Q(nEta, 3), - & Data1(nZeta*(nDArray-1)), Data2(nEta*(nDArray-1)), + Real*8, Intent(out) :: Zeta(mZeta), ZInv(mZeta), KappAB(mZeta), + & P(nZeta,3), Eta(mEta), EInv(mEta), + & KappCD(mEta), Q(nEta,3) + Real*8 Data1(nZeta*(nDArray-1)), Data2(nEta*(nDArray-1)), & Dij(nZeta), Dkl(nEta) Real*8 ZtMax,EtMax,abMax,cdMax,ZtMaxD,EtMaxD,abMaxD,cdMaxD - Integer IndZet(nZeta), IndEta(nEta), - & IndZ(nZeta), IndE(nEta) + Integer, Intent(out) :: lZeta, lEta, IndZet(nZeta), IndEta(nEta) + Integer IndZ(nZeta), IndE(nEta) Logical Prescreen_On_Int_Only + ![all the others are intent(in)] * #include "print.fh" #include "real.fh" diff -Nru openmolcas-22.02/src/integral_util/setup_ints.f openmolcas-22.10/src/integral_util/setup_ints.f --- openmolcas-22.02/src/integral_util/setup_ints.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/setup_ints.f 2022-10-10 14:22:40.000000000 +0000 @@ -23,8 +23,6 @@ * Author: Roland Lindh, Chemical Physics, University of Lund, * * Sweden. January '98. * ************************************************************************ - use Her_RW - use vRys_RW use iSD_data use k2_arrays use LundIO diff -Nru openmolcas-22.02/src/integral_util/seward_init.f openmolcas-22.10/src/integral_util/seward_init.f --- openmolcas-22.02/src/integral_util/seward_init.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/seward_init.f 2022-10-10 14:22:40.000000000 +0000 @@ -11,7 +11,7 @@ * Copyright (C) 1990,2020, Roland Lindh * * 1990, IBM * ************************************************************************ - Subroutine Seward_Init + Subroutine Seward_Init() ************************************************************************ * * * Object: to set data which is stored in common blocks * @@ -28,32 +28,16 @@ Logical Reduce_Prt #include "pstat.fh" #include "print.fh" -#include "notab.fh" #include "status.fh" #include "twoswi.fh" #include "rmat.fh" #include "gam.fh" #include "real.fh" -#include "FMM.fh" #include "nac.fh" -#include "srint.fh" Character(LEN=180) Env * * ************************************************************************ * * -C -C... Parameters for srint -C - shortrange=.False. - isr_simulate=0 -* -* Initialize FMM.fh -* - FMM_shortrange = .False. - asymptotic_Rys = .False. -* * -************************************************************************ -* * * *-----Info * @@ -104,10 +88,6 @@ Show=.True. End If * -*-----NoTab -* - NoTab=.false. -* NDDO=.False. * k2_Status=InActive @@ -149,8 +129,6 @@ * Call Set_Basis_Mode('Valence') * - Call Mk_TriInd() -* Call CovRadT_Init() * * nac.fh diff -Nru openmolcas-22.02/src/integral_util/symad1.f openmolcas-22.10/src/integral_util/symad1.f --- openmolcas-22.02/src/integral_util/symad1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/symad1.f 2022-10-10 14:22:40.000000000 +0000 @@ -24,7 +24,7 @@ * January '91 * ************************************************************************ use Basis_Info - use Symmetry_Info, only: nIrrep, iChTbl, iOper, iChBas + use Symmetry_Info, only: iChBas, iChTbl, iOper, nIrrep, Prmt use SOAO_Info, only: iAOtSO use Real_Spherical, only: iSphCr Implicit Real*8 (A-H,O-Z) @@ -32,14 +32,8 @@ #include "real.fh" Real*8 AOInt(iBas*jBas,iCmp,jCmp,nIC), SOInt(iBas*jBas,nSOInt) Integer nOp(2) - Real*8 Prmt(0:7) Integer iTwoj(0:7), jIC(0:7) Data iTwoj/1,2,4,8,16,32,64,128/ - Data Prmt/1.d0,-1.d0,-1.d0,1.d0,-1.d0,1.d0,1.d0,-1.d0/ -* -* Statement functions -* - xPrmt(i,j) = Prmt(iAnd(i,j)) * iRout = 133 iPrint = nPrint(iRout) @@ -68,7 +62,7 @@ If (iAOtSO(iAO+i1,j1)<0) Cycle iChBs = iChBas(ii+i1) If (Shells(iShll)%Transf) iChBs = iChBas(iSphCr(ii+i1)) - pae = xPrmt(iOper(nOp(1)),iChBs) + pae = Prmt(iOper(nOp(1)),iChBs) * Do 300 j2 = 0, nIrrep-1 j12 = iEor(j1,j2) @@ -85,7 +79,7 @@ jChBs = iChBas(jj+i2) If (Shells(jShll)%Transf) & jChBs = iChBas(iSphCr(jj+i2)) - pbr = xPrmt(iOper(nOp(2)),jChBs) + pbr = Prmt(iOper(nOp(2)),jChBs) Call DaXpY_(iBas*jBas,xa*pae*xb*pbr, & AOInt(1,i1,i2,kIC),1, & SOInt(1,lSO),1) diff -Nru openmolcas-22.02/src/integral_util/symado.f openmolcas-22.10/src/integral_util/symado.f --- openmolcas-22.02/src/integral_util/symado.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/symado.f 2022-10-10 14:22:40.000000000 +0000 @@ -10,20 +10,17 @@ ************************************************************************ SubRoutine SymAdO(ArrIn,nZeta,la,lb,nComp,ArrOut,nIC,iDCRT, & lOper,iChO,Factor) - use Symmetry_Info, only: nIrrep, iChTbl, iOper + use Symmetry_Info, only: iChTbl, iOper, nIrrep, Prmt Implicit Real*8 (A-H,O-Z) #include "real.fh" Real*8 ArrIn (nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nComp), - & ArrOut(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nIC), - & Prmt(0:7) + & ArrOut(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nIC) Integer iDCRT ,iTwoj(0:7), lOper(nComp), iChO(nComp) Data iTwoj/1,2,4,8,16,32,64,128/ - Data Prmt/1.d0,-1.d0,-1.d0,1.d0,-1.d0,1.d0,1.d0,-1.d0/ * * Statement function for Cartesian index * nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - xPrmt(i,j) = Prmt(iAnd(i,j)) * C nA = (la+1)*(la+2)/2 C nB = (lb+1)*(lb+2)/2 @@ -33,7 +30,7 @@ * iIC = 0 Do 103 iComp = 1, nComp - pO = xPrmt(iOper(iDCRT),iChO(iComp)) + pO = Prmt(iOper(iDCRT),iChO(iComp)) Do 104 iIrrep = 0, nIrrep-1 If (iAnd(lOper(iComp),iTwoj(iIrrep)).eq.0) Go To 104 iIC = iIC + 1 diff -Nru openmolcas-22.02/src/integral_util/symadp.f openmolcas-22.10/src/integral_util/symadp.f --- openmolcas-22.02/src/integral_util/symadp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/symadp.f 2022-10-10 14:22:40.000000000 +0000 @@ -36,7 +36,7 @@ * March '90 * ************************************************************************ use Basis_Info - use Symmetry_Info, only: nIrrep, iChTbl, iOper, iChBas + use Symmetry_Info, only: iChBas, iChTbl, iOper, nIrrep, Prmt use SOAO_Info, only: iAOtSO use Real_Spherical, only: iSphCr Implicit Real*8 (A-H,O-Z) @@ -47,13 +47,10 @@ Integer iAng(4), iShell(4), iShll(4), kOp(4), iAO(4) * Local Array Integer iSym(0:7), jSym(0:7), kSym(0:7), lSym(0:7) - Real*8 Prmt(0:7) - Data Prmt/1.d0,-1.d0,-1.d0,1.d0,-1.d0,1.d0,1.d0,-1.d0/ * * Statement Function * iOff(ixyz) = ixyz*(ixyz+1)*(ixyz+2)/6 - xPrmt(i,j) = Prmt(iAnd(i,j)) * iRout = 38 iPrint = nPrint(iRout) @@ -87,7 +84,7 @@ If (Shij) jCmpMx = i1 iChBs = iChBas(ii+i1) If (Shells(iShll(1))%Transf) iChBs = iChBas(iSphCr(ii+i1)) - pEa = xPrmt(iOper(kOp(1)),iChBs) + pEa = Prmt(iOper(kOp(1)),iChBs) Do 200 i2 = 1, jCmpMx Do 201 j = 0, nIrrep-1 ix = 0 @@ -96,7 +93,7 @@ 201 Continue jChBs = iChBas(jj+i2) If (Shells(iShll(2))%Transf) jChBs = iChBas(iSphCr(jj+i2)) - pRb = xPrmt(iOper(kOp(2)),jChBs) * pEa + pRb = Prmt(iOper(kOp(2)),jChBs) * pEa Qij = i1.eq.i2 If (iShell(2).gt.iShell(1)) Then i12 = jCmp*(i1-1) + i2 @@ -114,7 +111,7 @@ kChBs = iChBas(kk+i3) If (Shells(iShll(3))%Transf) & kChBs = iChBas(iSphCr(kk+i3)) - pTc = xPrmt(iOper(kOp(3)),kChBs) * pRb + pTc = Prmt(iOper(kOp(3)),kChBs) * pRb Do 400 i4 = 1, lCmpMx Do 401 j = 0, nIrrep-1 ix = 0 @@ -125,7 +122,7 @@ lChBs = iChBas(ll+i4) If (Shells(iShll(4))%Transf) & lChBs = iChBas(iSphCr(ll+i4)) - pTSd= xPrmt(iOper(kOp(4)),lChBs) * pTc + pTSd= Prmt(iOper(kOp(4)),lChBs) * pTc If (iShell(4).gt.iShell(3)) Then i34 = lCmp*(i3-1) + i4 Else diff -Nru openmolcas-22.02/src/integral_util/tnsctl.f openmolcas-22.10/src/integral_util/tnsctl.f --- openmolcas-22.02/src/integral_util/tnsctl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/tnsctl.f 2022-10-10 14:22:40.000000000 +0000 @@ -34,7 +34,10 @@ #include "real.fh" Parameter(lab=iTabMx*2+1,npMax=lab*(lab+1)*(lab+2)/6) Real*8 HMtrxAB(*),HMtrxCD(*) - Real*8 Wrk(nWrk), Coora(3,4) + Real*8, Intent(inout) :: Wrk(nWrk) + Real*8 Coora(3,4) + Integer, Intent(out) :: i_out + ![all others are intent(in)] * *---- Integral are stored as e,f,IJKL in Wrk * diff -Nru openmolcas-22.02/src/integral_util/xsetmem_ints.f openmolcas-22.10/src/integral_util/xsetmem_ints.f --- openmolcas-22.02/src/integral_util/xsetmem_ints.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/integral_util/xsetmem_ints.f 2022-10-10 14:22:40.000000000 +0000 @@ -19,8 +19,14 @@ & 'External handling of scratch already active!') Call Abend() End If -C Write (6,*) 'xsetmem_ints: External allocate:',Mem - Call mma_allocate(Sew_Scr,Mem,Label='Sew_Scr') + Mem_ = Mem +C Avoid using up all available memory + Call mma_maxDBLE(MemMax) + If (MemMax-Mem_.lt.1000) Then + If (Mem_.gt.1000) Mem_=Mem_-1000 + End If +C Write (6,*) 'xsetmem_ints: External allocate:',Mem_ + Call mma_allocate(Sew_Scr,Mem_,Label='Sew_Scr') XMem_Status=Active C Call mma_MaxDBLE(nu) C Write (6,*) 'xsetmem_ints: External allocate left to allocate:',nu diff -Nru openmolcas-22.02/src/io_util/CMakeLists.txt openmolcas-22.10/src/io_util/CMakeLists.txt --- openmolcas-22.02/src/io_util/CMakeLists.txt 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/io_util/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -58,18 +58,19 @@ molcas_open_ext2.F90 molcas_open.F90 mpdafile.F90 - next_non_comment.F90 prgm.F90 prgminit.F90 prgmtranslatec.F90 prgmtranslate.F90 prgmtranslate_master.F90 + text_file.F90 zip.c ) # Source files defining modules that should be available to other *_util directories set (modfile_list prgm.F90 + text_file.F90 ) include (${PROJECT_SOURCE_DIR}/cmake/util_template.cmake) diff -Nru openmolcas-22.02/src/io_util/daname_main.F90 openmolcas-22.10/src/io_util/daname_main.F90 --- openmolcas-22.02/src/io_util/daname_main.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/io_util/daname_main.F90 2022-10-10 14:22:40.000000000 +0000 @@ -51,7 +51,7 @@ use Fast_IO, only: Addr, FSCB, isOpen, LuName, LuNameProf, MBL, MBl_nwa, MBl_wa, MPUnit, Multi_File, MxFile, NProfFiles, Trace use Definitions, only: iwp, u6 #ifndef NO_SPLITTING -use Fast_IO, only: Max_File_Length +use Fast_IO, only: Max_File_Length, MaxFileSize, MaxSplitFile use Definitions, only: wp #endif @@ -66,8 +66,7 @@ integer(kind=iwp), external :: AixErr, AixOpn, isFreeUnit #ifndef NO_SPLITTING integer(kind=iwp) :: lName, MFMB -integer(kind=iwp), external :: StrnLn -!FIXME AllocDisk is undefined +integer(kind=iwp), external :: AllocDisk, StrnLn #endif if (Trace) then diff -Nru openmolcas-22.02/src/io_util/filesystem_wrapper.c openmolcas-22.10/src/io_util/filesystem_wrapper.c --- openmolcas-22.02/src/io_util/filesystem_wrapper.c 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/io_util/filesystem_wrapper.c 2022-10-10 14:22:40.000000000 +0000 @@ -13,12 +13,14 @@ #define _XOPEN_SOURCE 500 #include +#include #include #include #include #include #include #include +#include #include "molcastype.h" /* C_SIZE_T (or in general unsigned ints) is not supported by FORTRAN */ @@ -95,3 +97,28 @@ { *err = (INT) nftw(path, unlink_cb, 64, FTW_DEPTH | FTW_PHYS); } + +void copy(const char *src, const char *dst, INT *err) +{ + char buf[BUFSIZ]; + size_t size; + + *err = 0; + FILE* source = fopen(src, "rb"); + + if (! source) { + *err = 1; + return; + } + + FILE* dest = fopen(dst, "wb"); + + // feof(FILE* stream) returns non-zero if the end of file indicator for stream is set + + while ((size = fread(buf, 1, BUFSIZ, source))) { + fwrite(buf, 1, size, dest); + } + + fclose(source); + fclose(dest); +} diff -Nru openmolcas-22.02/src/io_util/fscb2unit.F90 openmolcas-22.10/src/io_util/fscb2unit.F90 --- openmolcas-22.02/src/io_util/fscb2unit.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/io_util/fscb2unit.F90 2022-10-10 14:22:40.000000000 +0000 @@ -19,7 +19,8 @@ !> @details !> Translate system (C)file descriptor into internal Molcas's one !> -!> @param[in,out] cunit System (C)file descriptor +!> @param[in] cunit System (C)file descriptor +!> @param[out] LuP !*********************************************************************** subroutine FSCB2UNIT(cunit,LuP) diff -Nru openmolcas-22.02/src/io_util/molcas_open.F90 openmolcas-22.10/src/io_util/molcas_open.F90 --- openmolcas-22.02/src/io_util/molcas_open.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/io_util/molcas_open.F90 2022-10-10 14:22:40.000000000 +0000 @@ -17,7 +17,7 @@ implicit none integer(kind=iwp), intent(in) :: Lu -character(len=*) :: FileName +character(len=*), intent(in) :: FileName integer(kind=iwp) :: f_recl, f_iostat character(len=10) :: f_access, f_form, f_status logical(kind=iwp) :: is_recl, is_error diff -Nru openmolcas-22.02/src/io_util/next_non_comment.F90 openmolcas-22.10/src/io_util/next_non_comment.F90 --- openmolcas-22.02/src/io_util/next_non_comment.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/io_util/next_non_comment.F90 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** - -function next_non_comment(lu,line) - -use Definitions, only: iwp - -implicit none -logical(kind=iwp) :: next_non_comment -integer(kind=iwp), intent(in) :: lu -character(len=*), intent(out) :: line -integer(kind=iwp) :: stat - -next_non_comment = .false. -do - read(lu,'(A)',iostat=stat) line - if (stat < 0) return - if (stat > 0) call abend() - line = adjustl(line) - if ((line(1:1) /= '*') .and. (line /= ' ')) exit -end do -next_non_comment = .true. - -return - -end function next_non_comment diff -Nru openmolcas-22.02/src/io_util/text_file.F90 openmolcas-22.10/src/io_util/text_file.F90 --- openmolcas-22.02/src/io_util/text_file.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/io_util/text_file.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,128 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2022, Ignacio Fdez. Galvan * +!*********************************************************************** + +module text_file + +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: iwp + +implicit none +private + +public :: extend_line, next_non_comment + +contains + +!======================================================================= +! Read the next non-comment line, no matter its length. +! Return .false. if the file ends. +function next_non_comment(lu,line) + +logical(kind=iwp) :: next_non_comment +integer(kind=iwp), intent(in) :: lu +character(len=:), allocatable, intent(inout) :: line +integer(kind=iwp) :: stat + +next_non_comment = .false. +do + call next_line(lu,line,stat) + if (is_iostat_end(stat)) then + ! if file ended, return false + exit + else if (stat == 0) then + ! if line is not empty or comment, return true + ! if it is empty or comment, read another line + line(:) = adjustl(line) + if ((line(1:1) /= '*') .and. (line /= '')) then + next_non_comment = .true. + exit + end if + else + ! any other error, abort + call abend() + end if +end do + +return + +end function next_non_comment + +!======================================================================= +! Read the next line, no matter its length. +subroutine next_line(lu,line,stat) + +integer(kind=iwp), intent(in) :: lu +character(len=:), allocatable, intent(inout) :: line +integer(kind=iwp), intent(out) :: stat +integer(kind=iwp) :: readl +character(len=128) :: buf + +if (allocated(line)) call mma_deallocate(line) +do + read(lu,'(A)',iostat=stat,advance='no',size=readl) buf + if (is_iostat_eor(stat)) then + ! if line ended, add the chunk and return success + call extend_line(line,buf(:readl),chop=.true.) + stat = 0 + exit + else if (stat == 0) then + ! if line didn't end, add the chunk and read next + call extend_line(line,buf,chop=.true.) + else + ! any other error, return + exit + end if +end do + +end subroutine next_line + +!======================================================================= +! Concatenate two strings into a longer one +! (if chop, the last character of the first string is removed) +subroutine extend_line(dynline,line,chop) + +character(len=:), allocatable, intent(inout) :: dynline +character(len=*), intent(in) :: line +logical(kind=iwp), optional, intent(in) :: chop +logical(kind=iwp) :: chop_ +character(len=:), allocatable :: aux + +chop_ = .false. +if (present(chop)) chop_ = chop + +! adding always a space to avoid 0-length strings +if (allocated(dynline)) then + if (chop_) then + call mma_allocate(aux,len(dynline)+len(line),label='AuxLine') + aux(:) = dynline(:len(dynline)-1)//line//' ' + else + call mma_allocate(aux,len(dynline)+len(line)+1,label='AuxLine') + aux(:) = dynline//line//' ' + end if + call mma_deallocate(dynline) + ! move_alloc does not work properly in all compilers +# ifdef _USE_MOVE_ALLOC_ + call move_alloc(aux,dynline) +# else + call mma_allocate(dynline,len(aux),label='ExtLine') + dynline(:) = aux + call mma_deallocate(aux) +# endif +else + call mma_allocate(dynline,len(line)+1,label='Ext2Line') + dynline(:) = line//' ' +end if + +end subroutine extend_line + +end module text_file diff -Nru openmolcas-22.02/src/kriging_util/start_kriging.F90 openmolcas-22.10/src/kriging_util/start_kriging.F90 --- openmolcas-22.02/src/kriging_util/start_kriging.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/kriging_util/start_kriging.F90 2022-10-10 14:22:40.000000000 +0000 @@ -70,7 +70,7 @@ call mma_Allocate(x0,nInter,label='nx') -! rl and dl are temporary matrices for the contruction of Psi which is inside of +! rl and dl are temporary matrices for the construction of Psi which is inside of ! Grad-Psi (eq.(2) ref.) dl=rl^2=Sum[i] [(x_i-x0_i)/l)^2] ! more inoformation is given in subsequen files. ! Mat is the final matrix after the distance (between source data rl and dl) has diff -Nru openmolcas-22.02/src/ldf_fock_util/ldf_computecoulombintermediates.F90 openmolcas-22.10/src/ldf_fock_util/ldf_computecoulombintermediates.F90 --- openmolcas-22.02/src/ldf_fock_util/ldf_computecoulombintermediates.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_fock_util/ldf_computecoulombintermediates.F90 2022-10-10 14:22:40.000000000 +0000 @@ -76,9 +76,7 @@ #ifdef _MOLCAS_MPP_ ! Init norm array if ((nProcs > 1) .and. Is_Real_Par()) then - if (doNorm) then - call Cho_dZero(CNorm,4*NumberOfAtomPairs) - end if + if (doNorm) CNorm(:) = Zero end if #endif diff -Nru openmolcas-22.02/src/ldf_fock_util/ldf_fock_coulombonly0.F90 openmolcas-22.10/src/ldf_fock_util/ldf_fock_coulombonly0.F90 --- openmolcas-22.02/src/ldf_fock_util/ldf_fock_coulombonly0.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_fock_util/ldf_fock_coulombonly0.F90 2022-10-10 14:22:40.000000000 +0000 @@ -207,9 +207,7 @@ l = nBas**2 end if if (.not. Add) then - do iD=1,nD - call Cho_dZero(F((iD-1)*l+1),l) - end do + F(1:nD*l) = Zero end if ! Allocate and set blocked density matrices (atom pair blocks) diff -Nru openmolcas-22.02/src/ldf_fock_util/ldf_fock_coulombonly_.F90 openmolcas-22.10/src/ldf_fock_util/ldf_fock_coulombonly_.F90 --- openmolcas-22.02/src/ldf_fock_util/ldf_fock_coulombonly_.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_fock_util/ldf_fock_coulombonly_.F90 2022-10-10 14:22:40.000000000 +0000 @@ -50,7 +50,7 @@ ! Set up prescreening info l_VNrm = nAtom+NumberOfAtomPairs call mma_allocate(VNrm,l_VNrm,label='VNrm') -call Cho_dZero(VNrm,l_VNrm) +VNrm(:) = Zero do iD=1,nD ip = (nAtom+NumberOfAtomPairs)*(iD-1) do AB=1,nAtom+NumberOfAtomPairs @@ -59,7 +59,7 @@ end do l_DNrm = NumberOfAtomPairs call mma_allocate(DNrm,l_DNrm,label='DNrm') -call Cho_dZero(DNrm,l_DNrm) +DNrm(:) = Zero do iD=1,nD ip = NumberOfAtomPairs*(iD-1) do AB=1,NumberOfAtomPairs @@ -105,7 +105,7 @@ end if end do else - call Cho_dZero(tauW,l_tauW) + tauW(:) = Zero end if ! Allocate and initialize W intermediates diff -Nru openmolcas-22.02/src/ldf_fock_util/ldf_fock_coulombonly.F90 openmolcas-22.10/src/ldf_fock_util/ldf_fock_coulombonly.F90 --- openmolcas-22.02/src/ldf_fock_util/ldf_fock_coulombonly.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_fock_util/ldf_fock_coulombonly.F90 2022-10-10 14:22:40.000000000 +0000 @@ -332,9 +332,7 @@ l = nBas**2 end if if (.not. Add) then - do iD=1,nD - call Cho_dZero(F((iD-1)*l+1),l) - end do + F(1:nD*l) = Zero end if ! Allocate and set blocked density matrices (atom pair blocks) diff -Nru openmolcas-22.02/src/ldf_fock_util/ldf_fock_coulombupperbound_full.F90 openmolcas-22.10/src/ldf_fock_util/ldf_fock_coulombupperbound_full.F90 --- openmolcas-22.02/src/ldf_fock_util/ldf_fock_coulombupperbound_full.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_fock_util/ldf_fock_coulombupperbound_full.F90 2022-10-10 14:22:40.000000000 +0000 @@ -22,7 +22,7 @@ ! U = sum_uv sqrt[(Delta(uv)|Delta(uv))]*|D(uv)| use stdalloc, only: mma_allocate, mma_deallocate -use Constants, only: Two +use Constants, only: Zero, Two use Definitions, only: wp, iwp implicit none @@ -56,9 +56,7 @@ l = nBas_Valence**2 end if if (.not. Add) then - do iD=1,nD - call Cho_dZero(F((iD-1)*l+1),l) - end do + F(1:nD*l) = Zero end if ! Allocate and extract Fock matrix blocks diff -Nru openmolcas-22.02/src/ldf_ri_util/integral_wrout_ldf_diag.f openmolcas-22.10/src/ldf_ri_util/integral_wrout_ldf_diag.f --- openmolcas-22.02/src/ldf_ri_util/integral_wrout_ldf_diag.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/integral_wrout_ldf_diag.f 2022-10-10 14:22:40.000000000 +0000 @@ -9,26 +9,20 @@ * LICENSE or in . * ************************************************************************ SubRoutine Integral_WrOut_LDF_Diag( - & iCmp,iShell,MapOrg, - & iBas,jBas,kBas,lBas,kOp, - & Shijij,IJeqKL,iAO,iAOst,ijkl, - & AOInt,SOInt,nSOint, - & iSOSym,nSkal,nSOs, - & TInt,nTInt,itOffs,nSym) +#define _FIXED_FORMAT_ +#define _CALLING_ +#include "int_wrout_interface.fh" + & ) * calls the proper routines IndSft/PLF * if IntOrd_jikl==.TRUE. integral order within symblk: jikl * else integral order within symblk: ijkl Implicit Real*8 (a-h,o-z) * - Real*8 AOInt(*), SOInt(*), TInt(nTInt) - Integer iCmp(4), iShell(4), iAO(4), - & iAOst(4), kOp(4), iSOSym(2,nSOs), - & itOffs(0:nSym-1,0:nSym-1,0:nSym-1), MapOrg(4) - Logical Shijij,IJeqKL +#include "int_wrout_interface.fh" * * call sorting routine * - If (nSym==1) Then + If (mSym==1) Then Call PLF_LDF_Diag(TInt,nTInt, & AOInt,ijkl,iCmp(1),iCmp(2),iCmp(3),iCmp(4), & iShell,iAO,iAOst,Shijij.and.IJeqKL, diff -Nru openmolcas-22.02/src/ldf_ri_util/integral_wrout_ldf_g.f openmolcas-22.10/src/ldf_ri_util/integral_wrout_ldf_g.f --- openmolcas-22.02/src/ldf_ri_util/integral_wrout_ldf_g.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/integral_wrout_ldf_g.f 2022-10-10 14:22:40.000000000 +0000 @@ -9,12 +9,10 @@ * LICENSE or in . * ************************************************************************ SubRoutine Integral_WrOut_LDF_G( - & iCmp,iShell,MapOrg, - & iBas,jBas,kBas,lBas,kOp, - & Shijij,IJeqKL,iAO,iAOst,ijkl, - & AOInt,SOInt,nSOint, - & iSOSym,nSkal,nSOs, - & TInt,nTInt,itOffs,nSym) +#define _FIXED_FORMAT_ +#define _CALLING_ +#include "int_wrout_interface.fh" + & ) * calls the proper routines IndSft/PLF * if IntOrd_jikl==.TRUE. integral order within symblk: jikl * else integral order within symblk: ijkl @@ -22,11 +20,7 @@ * #include "localdf_int.fh" * - Real*8 AOInt(*), SOInt(*), TInt(nTInt) - Integer iCmp(4), iShell(4), iAO(4), - & iAOst(4), kOp(4), iSOSym(2,nSOs), - & itOffs(0:nSym-1,0:nSym-1,0:nSym-1), MapOrg(4) - Logical Shijij,IJeqKL +#include "int_wrout_interface.fh" * External LDF_nShell, LDF_nAuxShell * @@ -54,7 +48,7 @@ * * call sorting routine * - If (nSym==1) Then + If (mSym==1) Then nS_Val=LDF_nShell() nS_Aux=LDF_nAuxShell() iS_Dum=nS_Val+nS_Aux+1 diff -Nru openmolcas-22.02/src/ldf_ri_util/int_ldf_2indx_11.f openmolcas-22.10/src/ldf_ri_util/int_ldf_2indx_11.f --- openmolcas-22.02/src/ldf_ri_util/int_ldf_2indx_11.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/int_ldf_2indx_11.f 2022-10-10 14:22:40.000000000 +0000 @@ -9,12 +9,10 @@ * LICENSE or in . * ************************************************************************ SubRoutine Int_LDF_2Indx_11( - & iCmp,iShell,MapOrg, - & iBas,jBas,kBas,lBas,kOp, - & Shijij,IJeqKL,iAO,iAOst,ijkl, - & AOInt,SOInt,nSOint, - & iSOSym,nSkal,nSOs, - & TInt,nTInt,itOffs,nSym) +#define _FIXED_FORMAT_ +#define _CALLING_ +#include "int_wrout_interface.fh" + & ) * calls the proper routines IndSft/PLF * if IntOrd_jikl==.TRUE. integral order within symblk: jikl * else integral order within symblk: ijkl @@ -25,11 +23,7 @@ Character*16 SecNam Parameter (SecNam='Int_LDF_2Indx_11') * - Real*8 AOInt(*), SOInt(*), TInt(nTInt) - Integer iCmp(4), iShell(4), iAO(4), - & iAOst(4), kOp(4), iSOSym(2,nSOs), - & itOffs(0:nSym-1,0:nSym-1,0:nSym-1), MapOrg(4) - Logical Shijij,IJeqKL +#include "int_wrout_interface.fh" * External LDF_nShell, LDF_nAuxShell * @@ -37,7 +31,7 @@ * * call sorting routine * - If (nSym==1) Then + If (mSym==1) Then nS_Val=LDF_nShell() nS_Aux=LDF_nAuxShell() iS_Dum=nS_Val+nS_Aux+1 diff -Nru openmolcas-22.02/src/ldf_ri_util/int_ldf_2indx_12.f openmolcas-22.10/src/ldf_ri_util/int_ldf_2indx_12.f --- openmolcas-22.02/src/ldf_ri_util/int_ldf_2indx_12.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/int_ldf_2indx_12.f 2022-10-10 14:22:40.000000000 +0000 @@ -9,12 +9,10 @@ * LICENSE or in . * ************************************************************************ SubRoutine Int_LDF_2Indx_12( - & iCmp,iShell,MapOrg, - & iBas,jBas,kBas,lBas,kOp, - & Shijij,IJeqKL,iAO,iAOst,ijkl, - & AOInt,SOInt,nSOint, - & iSOSym,nSkal,nSOs, - & TInt,nTInt,itOffs,nSym) +#define _FIXED_FORMAT_ +#define _CALLING_ +#include "int_wrout_interface.fh" + & ) * calls the proper routines IndSft/PLF * if IntOrd_jikl==.TRUE. integral order within symblk: jikl * else integral order within symblk: ijkl @@ -25,11 +23,7 @@ Character*16 SecNam Parameter (SecNam='Int_LDF_2Indx_12') * - Real*8 AOInt(*), SOInt(*), TInt(nTInt) - Integer iCmp(4), iShell(4), iAO(4), - & iAOst(4), kOp(4), iSOSym(2,nSOs), - & itOffs(0:nSym-1,0:nSym-1,0:nSym-1), MapOrg(4) - Logical Shijij,IJeqKL +#include "int_wrout_interface.fh" * External LDF_nShell, LDF_nAuxShell * @@ -37,7 +31,7 @@ * * call sorting routine * - If (nSym==1) Then + If (mSym==1) Then nS_Val=LDF_nShell() nS_Aux=LDF_nAuxShell() iS_Dum=nS_Val+nS_Aux+1 diff -Nru openmolcas-22.02/src/ldf_ri_util/int_ldf_3indx_1.f openmolcas-22.10/src/ldf_ri_util/int_ldf_3indx_1.f --- openmolcas-22.02/src/ldf_ri_util/int_ldf_3indx_1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/int_ldf_3indx_1.f 2022-10-10 14:22:40.000000000 +0000 @@ -9,12 +9,10 @@ * LICENSE or in . * ************************************************************************ SubRoutine Int_LDF_3Indx_1( - & iCmp,iShell,MapOrg, - & iBas,jBas,kBas,lBas,kOp, - & Shijij,IJeqKL,iAO,iAOst,ijkl, - & AOInt,SOInt,nSOint, - & iSOSym,nSkal,nSOs, - & TInt,nTInt,itOffs,nSym) +#define _FIXED_FORMAT_ +#define _CALLING_ +#include "int_wrout_interface.fh" + & ) * calls the proper routines IndSft/PLF * if IntOrd_jikl==.TRUE. integral order within symblk: jikl * else integral order within symblk: ijkl @@ -25,11 +23,7 @@ Character*15 SecNam Parameter (SecNam='Int_LDF_3Indx_1') * - Real*8 AOInt(*), SOInt(*), TInt(nTInt) - Integer iCmp(4), iShell(4), iAO(4), - & iAOst(4), kOp(4), iSOSym(2,nSOs), - & itOffs(0:nSym-1,0:nSym-1,0:nSym-1), MapOrg(4) - Logical Shijij,IJeqKL +#include "int_wrout_interface.fh" * External LDF_nShell, LDF_nAuxShell * @@ -37,7 +31,7 @@ * * call sorting routine * - If (nSym==1) Then + If (mSym==1) Then nS_Val=LDF_nShell() nS_Aux=LDF_nAuxShell() iS_Dum=nS_Val+nS_Aux+1 diff -Nru openmolcas-22.02/src/ldf_ri_util/int_ldf_gmax_s.f openmolcas-22.10/src/ldf_ri_util/int_ldf_gmax_s.f --- openmolcas-22.02/src/ldf_ri_util/int_ldf_gmax_s.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/int_ldf_gmax_s.f 2022-10-10 14:22:40.000000000 +0000 @@ -9,12 +9,10 @@ * LICENSE or in . * ************************************************************************ SubRoutine Int_LDF_Gmax_S( - & iCmp,iShell,MapOrg, - & iBas,jBas,kBas,lBas,kOp, - & Shijij,IJeqKL,iAO,iAOst,ijkl, - & AOInt,SOInt,nSOint, - & iSOSym,nSkal,nSOs, - & TInt,nTInt,itOffs,nSym) +#define _FIXED_FORMAT_ +#define _CALLING_ +#include "int_wrout_interface.fh" + & ) * calls the proper routines IndSft/PLF * if IntOrd_jikl==.TRUE. integral order within symblk: jikl * else integral order within symblk: ijkl @@ -25,11 +23,7 @@ Character*14 SecNam Parameter (SecNam='Int_LDF_Gmax_S') * - Real*8 AOInt(*), SOInt(*), TInt(nTInt) - Integer iCmp(4), iShell(4), iAO(4), - & iAOst(4), kOp(4), iSOSym(2,nSOs), - & itOffs(0:nSym-1,0:nSym-1,0:nSym-1), MapOrg(4) - Logical Shijij,IJeqKL +#include "int_wrout_interface.fh" * External LDF_nShell, LDF_nAuxShell * @@ -37,7 +31,7 @@ * * call sorting routine * - If (nSym==1) Then + If (mSym==1) Then nS_Val=LDF_nShell() nS_Aux=LDF_nAuxShell() iS_Dum=nS_Val+nS_Aux+1 diff -Nru openmolcas-22.02/src/ldf_ri_util/int_ldf_jk_2p.f openmolcas-22.10/src/ldf_ri_util/int_ldf_jk_2p.f --- openmolcas-22.02/src/ldf_ri_util/int_ldf_jk_2p.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/int_ldf_jk_2p.f 2022-10-10 14:22:40.000000000 +0000 @@ -8,29 +8,24 @@ * For more details see the full text of the license in the file * * LICENSE or in . * ************************************************************************ - SubRoutine Int_LDF_JK_2P(iCmp,iShell,MapOrg, - & iBas,jBas,kBas,lBas,kOp, - & Shijij,IJeqKL,iAO,iAOst,ijkl, - & AOInt,SOInt,nSOint, - & iSOSym,nSkal,nSOs, - & TInt,nTInt,itOffs,nSym) + SubRoutine Int_LDF_JK_2P( +#define _FIXED_FORMAT_ +#define _CALLING_ +#include "int_wrout_interface.fh" + & ) * if IntOrd_jikl==.TRUE. integral order within symblk: jikl * else integral order within symblk: ijkl Implicit Real*8 (a-h,o-z) * #include "localdf_int2.fh" * - Real*8 AOInt(*), SOInt(*), TInt(nTInt) - Integer iCmp(4), iShell(4), iAO(4), - & iAOst(4), kOp(4), iSOSym(2,nSOs), - & itOffs(0:nSym-1,0:nSym-1,0:nSym-1), MapOrg(4) - Logical Shijij,IJeqKL +#include "int_wrout_interface.fh" * External LDF_nShell, LDF_nAuxShell * * call sorting routine * - If (nSym==1) Then + If (mSym==1) Then nS_Val=LDF_nShell() nS_Aux=LDF_nAuxShell() iS_Dum=nS_Val+nS_Aux+1 diff -Nru openmolcas-22.02/src/ldf_ri_util/int_ldf_sq.f openmolcas-22.10/src/ldf_ri_util/int_ldf_sq.f --- openmolcas-22.02/src/ldf_ri_util/int_ldf_sq.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/int_ldf_sq.f 2022-10-10 14:22:40.000000000 +0000 @@ -9,12 +9,10 @@ * LICENSE or in . * ************************************************************************ SubRoutine Int_LDF_SQ( - & iCmp,iShell,MapOrg, - & iBas,jBas,kBas,lBas,kOp, - & Shijij,IJeqKL,iAO,iAOst,ijkl, - & AOInt,SOInt,nSOint, - & iSOSym,nSkal,nSOs, - & TInt,nTInt,itOffs,nSym) +#define _FIXED_FORMAT_ +#define _CALLING_ +#include "int_wrout_interface.fh" + & ) * calls the proper routines IndSft/PLF * if IntOrd_jikl==.TRUE. integral order within symblk: jikl * else integral order within symblk: ijkl @@ -22,11 +20,7 @@ * #include "localdf_int.fh" * - Real*8 AOInt(*), SOInt(*), TInt(nTInt) - Integer iCmp(4), iShell(4), iAO(4), - & iAOst(4), kOp(4), iSOSym(2,nSOs), - & itOffs(0:nSym-1,0:nSym-1,0:nSym-1), MapOrg(4) - Logical Shijij,IJeqKL +#include "int_wrout_interface.fh" * External LDF_nShell, LDF_nAuxShell * @@ -52,7 +46,7 @@ * * call sorting routine * - If (nSym==1) Then + If (mSym==1) Then nS_Val=LDF_nShell() If (SHA.le.nS_Val .and. & SHB.le.nS_Val .and. diff -Nru openmolcas-22.02/src/ldf_ri_util/int_ldf_uvj.f openmolcas-22.10/src/ldf_ri_util/int_ldf_uvj.f --- openmolcas-22.02/src/ldf_ri_util/int_ldf_uvj.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/int_ldf_uvj.f 2022-10-10 14:22:40.000000000 +0000 @@ -9,12 +9,10 @@ * LICENSE or in . * ************************************************************************ SubRoutine Int_LDF_uvJ( - & iCmp,iShell,MapOrg, - & iBas,jBas,kBas,lBas,kOp, - & Shijij,IJeqKL,iAO,iAOst,ijkl, - & AOInt,SOInt,nSOint, - & iSOSym,nSkal,nSOs, - & TInt,nTInt,itOffs,nSym) +#define _FIXED_FORMAT_ +#define _CALLING_ +#include "int_wrout_interface.fh" + & ) * calls the proper routines IndSft/PLF * if IntOrd_jikl==.TRUE. integral order within symblk: jikl * else integral order within symblk: ijkl @@ -22,11 +20,7 @@ * #include "localdf_int.fh" * - Real*8 AOInt(*), SOInt(*), TInt(nTInt) - Integer iCmp(4), iShell(4), iAO(4), - & iAOst(4), kOp(4), iSOSym(2,nSOs), - & itOffs(0:nSym-1,0:nSym-1,0:nSym-1), MapOrg(4) - Logical Shijij,IJeqKL +#include "int_wrout_interface.fh" * External LDF_nShell, LDF_nAuxShell * @@ -34,7 +28,7 @@ * * call sorting routine * - If (nSym==1) Then + If (mSym==1) Then nS_Val=LDF_nShell() nS_Aux=LDF_nAuxShell() iS_Dum=nS_Val+nS_Aux+1 diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_atomiclabels.fh openmolcas-22.10/src/ldf_ri_util/ldf_atomiclabels.fh --- openmolcas-22.02/src/ldf_ri_util/ldf_atomiclabels.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_atomiclabels.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,15 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -C Atomic labels - Logical AtomicLabelsSet - Integer ip_AtomicLabels, l_AtomicLabels - Common / LDFALL / AtomicLabelsSet - Common / LDFALI / ip_AtomicLabels, l_AtomicLabels diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_checkalloverlapintegrals.f openmolcas-22.10/src/ldf_ri_util/ldf_checkalloverlapintegrals.f --- openmolcas-22.02/src/ldf_ri_util/ldf_checkalloverlapintegrals.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_checkalloverlapintegrals.f 2022-10-10 14:22:40.000000000 +0000 @@ -122,7 +122,7 @@ End If End If If (nAB.lt.1) Then - Call Cho_dZero(Work(ip_Stat),l_Stat) + Call FZero(Work(ip_Stat),l_Stat) Nrm=0.0d0 RMS=0.0d0 Sm=0.0d0 diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_checkcharge.f openmolcas-22.10/src/ldf_ri_util/ldf_checkcharge.f --- openmolcas-22.02/src/ldf_ri_util/ldf_checkcharge.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_checkcharge.f 2022-10-10 14:22:40.000000000 +0000 @@ -83,7 +83,7 @@ If (doPrint) Then l_dQ=NumberOfAtomPairs Call GetMem('dQ','Allo','Real',ip_dQ,l_dQ) - Call Cho_dZero(Work(ip_dQ),l_dQ) + Call FZero(Work(ip_dQ),l_dQ) End If Call GetMem('Coeff','Allo','Real',ip_C,l_Cmax) Call LDF_AllocateBlockMatrix('Den',ip_DBlocks) diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_checkpairintegrals.f openmolcas-22.10/src/ldf_ri_util/ldf_checkpairintegrals.f --- openmolcas-22.02/src/ldf_ri_util/ldf_checkpairintegrals.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_checkpairintegrals.f 2022-10-10 14:22:40.000000000 +0000 @@ -322,6 +322,7 @@ Integer irc #include "WrkSpc.fh" #include "localdf.fh" +#include "localdf_mem.fh" #include "localdf_int.fh" #include "localdf_bas.fh" #include "localdf_print.fh" @@ -504,6 +505,7 @@ ! Allocate memory for seward Call GetMem('MaxMem','Max ','Real',ip_SewWrk,l_SewWrk) + l_SewWrk = min(l_SewWrk,MaxLDFSew) Call xSetMem_Ints(l_SewWrk) ! Compare integrals one shell quadruple at a time @@ -556,7 +558,7 @@ SHB=jShell SHC=kShell SHD=lShell - Call Cho_dZero(Work(ip_Int),nij*nkl) + Call FZero(Work(ip_Int),nij*nkl) Call Eval_IJKL(iShell,jShell,kShell,lShell, & Work(ip_Int),l_Int, & Int_LDF_SQ) diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_checkpsd_full.f openmolcas-22.10/src/ldf_ri_util/ldf_checkpsd_full.f --- openmolcas-22.02/src/ldf_ri_util/ldf_checkpsd_full.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_checkpsd_full.f 2022-10-10 14:22:40.000000000 +0000 @@ -124,7 +124,7 @@ End Do ! Compute integrals - Call Cho_dZero(Work(ip_Int),l_Int) + Call FZero(Work(ip_Int),l_Int) If (Mode.eq.0) Then ! exact integrals Do AB=1,NumberOfAtomPairs nAB=LDF_nBas_Atom(AP_Atoms(1,AB)) diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_cio_readc_withlindep.f openmolcas-22.10/src/ldf_ri_util/ldf_cio_readc_withlindep.f --- openmolcas-22.02/src/ldf_ri_util/ldf_cio_readc_withlindep.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_cio_readc_withlindep.f 2022-10-10 14:22:40.000000000 +0000 @@ -114,7 +114,7 @@ Do iS=1,LDF_nAuxShell_Atom(iAtom) Do ii=1,nBasSh(iWork(ipi+iS)) If (LDF_isLinDep(ii,iS,iAtom,iAtomPair)) Then - Call Cho_dZero(C(ipC),l) + Call FZero(C(ipC),l) Else Call dCopy_(l,Work(iAddr),1,C(ipC),1) iAddr=iAddr+l @@ -127,7 +127,7 @@ Do jS=1,LDF_nAuxShell_Atom(jAtom) Do jj=1,nBasSh(iWork(ipj+jS)) If (LDF_isLinDep(jj,jS,jAtom,iAtomPair)) Then - Call Cho_dZero(C(ipC),l) + Call FZero(C(ipC),l) Else Call dCopy_(l,Work(iAddr),1,C(ipC),1) iAddr=iAddr+l @@ -155,7 +155,7 @@ Do iS=1,LDF_nAuxShell_Atom(iAtom) Do ii=1,nBasSh(iWork(ipi+iS)) If (LDF_isLinDep(ii,iS,iAtom,iAtomPair)) Then - Call Cho_dZero(C(ipC),l) + Call FZero(C(ipC),l) Else Call dDAFile(Lu_LDFC,2,Work(ip_Scr),l,iAddr) Call dCopy_(l,Work(ip_Scr),1,C(ipC),1) @@ -168,7 +168,7 @@ Do jS=1,LDF_nAuxShell_Atom(jAtom) Do jj=1,nBasSh(iWork(ipj+jS)) If (LDF_isLinDep(jj,jS,jAtom,iAtomPair)) Then - Call Cho_dZero(C(ipC),l) + Call FZero(C(ipC),l) Else Call dDAFile(Lu_LDFC,2,Work(ip_Scr),l,iAddr) Call dCopy_(l,Work(ip_Scr),1,C(ipC),1) @@ -191,7 +191,7 @@ Do iS=1,LDF_nAuxShell_Atom(iAtom) Do ii=1,nBasSh(iWork(ipi+iS)) If (LDF_isLinDep(ii,iS,iAtom,iAtomPair)) Then - Call Cho_dZero(C(ipC),l) + Call FZero(C(ipC),l) Else Call dCopy_(l,Work(iAddr),1,C(ipC),1) iAddr=iAddr+l @@ -204,7 +204,7 @@ Do jS=1,LDF_nAuxShell_Atom(jAtom) Do jj=1,nBasSh(iWork(ipj+jS)) If (LDF_isLinDep(jj,jS,jAtom,iAtomPair)) Then - Call Cho_dZero(C(ipC),l) + Call FZero(C(ipC),l) Else Call dCopy_(l,Work(iAddr),1,C(ipC),1) iAddr=iAddr+l diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_comparefullandblocked.f openmolcas-22.10/src/ldf_ri_util/ldf_comparefullandblocked.f --- openmolcas-22.02/src/ldf_ri_util/ldf_comparefullandblocked.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_comparefullandblocked.f 2022-10-10 14:22:40.000000000 +0000 @@ -59,7 +59,7 @@ l=nBas_Valence**2 End IF Call GetMem('F__','Allo','Real',ip,l) - Call Cho_dZero(Work(ip),l) + Call FZero(Work(ip),l) Call LDF_Blocked2Full(ip_FBlocks,PackedF,Work(ip)) iCount=0 Do i=1,l diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_compute2indexintegrals.f openmolcas-22.10/src/ldf_ri_util/ldf_compute2indexintegrals.f --- openmolcas-22.02/src/ldf_ri_util/ldf_compute2indexintegrals.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_compute2indexintegrals.f 2022-10-10 14:22:40.000000000 +0000 @@ -28,6 +28,7 @@ Integer l_xInt_ Real*8 xInt(l_xInt_) #include "WrkSpc.fh" +#include "localdf_mem.fh" #include "localdf_bas.fh" #include "localdf_int3.fh" #include "ldf_integral_prescreening_info.fh" @@ -131,10 +132,11 @@ ! Allocate Seward memory Call GetMem('GetMax','Max ','Real',ip_SewWrk,l_SewWrk) + l_SewWrk = min(l_SewWrk,MaxLDFSew) Call xSetMem_Ints(l_SewWrk) ! Compute integrals - Call Cho_dZero(xInt,l_xInt) + Call FZero(xInt,l_xInt) SHA=dShell SHC=dShell If (A.eq.B) Then @@ -224,6 +226,7 @@ Integer l_xInt_ Real*8 xInt(l_xInt_) #include "WrkSpc.fh" +#include "localdf_mem.fh" #include "localdf_bas.fh" #include "localdf_int.fh" #include "ldf_atom_pair_info.fh" @@ -333,10 +336,11 @@ ! Allocate Seward memory Call GetMem('GetMax','Max ','Real',ip_SewWrk,l_SewWrk) + l_SewWrk = min(l_SewWrk,MaxLDFSew) Call xSetMem_Ints(l_SewWrk) ! Compute integrals - Call Cho_dZero(xInt,l_xInt) + Call FZero(xInt,l_xInt) SHA=dShell Do klS=1,l_2CList_2 kShell=i2CList(1,klS) @@ -395,6 +399,7 @@ Integer l_xInt_ Real*8 xInt(l_xInt_) #include "WrkSpc.fh" +#include "localdf_mem.fh" #include "localdf_bas.fh" #include "localdf_int2.fh" #include "ldf_atom_pair_info.fh" @@ -488,10 +493,11 @@ ! Allocate memory for Seward Call GetMem('GetMax','Max ','Real',ip_SewWrk,l_SewWrk) + l_SewWrk = min(l_SewWrk,MaxLDFSew) Call xSetMem_Ints(l_SewWrk) ! Compute integrals - Call Cho_dZero(xInt,l_xInt) + Call FZero(xInt,l_xInt) If (AB.eq.CD) Then Do klS=0,l_CD_2CList_2-1 kShell=iWork(ip_CD_2CList+3*klS) diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_compute3indexintegrals.f openmolcas-22.10/src/ldf_ri_util/ldf_compute3indexintegrals.f --- openmolcas-22.02/src/ldf_ri_util/ldf_compute3indexintegrals.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_compute3indexintegrals.f 2022-10-10 14:22:40.000000000 +0000 @@ -32,8 +32,9 @@ Real*8 xInt(l_xInt_) #include "WrkSpc.fh" #include "ldf_atom_pair_info.fh" -#include "localdf_int3.fh" +#include "localdf_mem.fh" #include "localdf_bas.fh" +#include "localdf_int3.fh" #include "ldf_integral_prescreening_info.fh" Character*28 SecNam @@ -191,10 +192,11 @@ ! Allocate memory for Seward Call GetMem('GetMax','Max ','Real',ip_SewWrk,l_SewWrk) + l_SewWrk = min(l_SewWrk,MaxLDFSew) Call xSetMem_Ints(l_SewWrk) ! Compute integrals - Call Cho_dZero(xInt,l_xInt) + Call FZero(xInt,l_xInt) kShell=nShell_Valence+nShell_Auxiliary+1 SHC=kShell If (A.eq.B) Then @@ -297,6 +299,7 @@ #include "WrkSpc.fh" #include "ldf_atom_pair_info.fh" #include "localdf_int.fh" +#include "localdf_mem.fh" #include "localdf_bas.fh" #include "ldf_integral_prescreening_info.fh" @@ -419,10 +422,11 @@ ! Allocate memory for Seward Call GetMem('GetMax','Max ','Real',ip_SewWrk,l_SewWrk) + l_SewWrk = min(l_SewWrk,MaxLDFSew) Call xSetMem_Ints(l_SewWrk) ! Compute integrals - Call Cho_dZero(xInt,l_xInt) + Call FZero(xInt,l_xInt) Do klS=1,l_2CList_2 kShell=i2CList(1,klS) lShell=i2CList(2,klS) diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_computeapproximateintegrals.f openmolcas-22.10/src/ldf_ri_util/ldf_computeapproximateintegrals.f --- openmolcas-22.02/src/ldf_ri_util/ldf_computeapproximateintegrals.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_computeapproximateintegrals.f 2022-10-10 14:22:40.000000000 +0000 @@ -129,7 +129,7 @@ End If ! If integrals are not to be updated, initialize - If (.not.Add) Call Cho_dZero(xInt,l_xInt) + If (.not.Add) Call FZero(xInt,l_xInt) ! Separate codes for different integral representations If (Mode.eq.1 .or. Mode.eq.3) Then diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_computeauxint.f openmolcas-22.10/src/ldf_ri_util/ldf_computeauxint.f --- openmolcas-22.02/src/ldf_ri_util/ldf_computeauxint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_computeauxint.f 2022-10-10 14:22:40.000000000 +0000 @@ -218,11 +218,11 @@ * * ! Compute integrals - Call Cho_dZero(xInt,l_xInt) + Call FZero(xInt,l_xInt) ipInt=1 Do jS=1,LDF_nAuxShell_Atom(A) jShell=iWork(ipS+jS) - Call Cho_dZero(Work(ip_SOInt),nBasSh(jShell)) + Call FZero(Work(ip_SOInt),nBasSh(jShell)) Call OneEl_IJ(iShell,jShell,iPrint,Do_PGamma, & Work(ip_xZeta),Work(ip_xZI),Work(ip_xKappa), & Work(ip_xPCoor), @@ -464,7 +464,7 @@ * * ! Compute integrals - Call Cho_dZero(xInt,l_xInt) + Call FZero(xInt,l_xInt) iCount=0 Do ijS=1,l_2CList_2 iShell=AP_2CList(1,ijS) @@ -472,7 +472,7 @@ SPAB=AP_2CList(3,ijS) SHA=iShell SHB=jShell - Call Cho_dZero(Work(ip_SOInt),nBasSh(iShell)*nBasSh(jShell)) + Call FZero(Work(ip_SOInt),nBasSh(iShell)*nBasSh(jShell)) Call OneEl_IJ(iShell,jShell,iPrint,Do_PGamma, & Work(ip_xZeta),Work(ip_xZI),Work(ip_xKappa), & Work(ip_xPCoor), diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_computec.f openmolcas-22.10/src/ldf_ri_util/ldf_computec.f --- openmolcas-22.02/src/ldf_ri_util/ldf_computec.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_computec.f 2022-10-10 14:22:40.000000000 +0000 @@ -234,7 +234,7 @@ Call dCopy_(nuv,C(1,I),1,C(1,J),1) End If End Do - !Call Cho_dZero(C(1,MM+1),nuv*(M-MM)) + !Call FZero(C(1,MM+1),nuv*(M-MM)) Call LDF_SetIndxG(iAtomPair) iAtom=AP_Atoms(1,iAtomPair) jAtom=AP_Atoms(2,iAtomPair) diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_computefittingcoefficients.f openmolcas-22.10/src/ldf_ri_util/ldf_computefittingcoefficients.f --- openmolcas-22.02/src/ldf_ri_util/ldf_computefittingcoefficients.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_computefittingcoefficients.f 2022-10-10 14:22:40.000000000 +0000 @@ -88,7 +88,7 @@ If (Timing) Then l_T=2*nTask*NumberOfAtomPairs Call GetMem('LDFCFCT','Allo','Real',ip_T,l_T) - Call Cho_dZero(Work(ip_T),l_T) + Call FZero(Work(ip_T),l_T) Else ip_T=0 l_T=0 diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_computegmat.f openmolcas-22.10/src/ldf_ri_util/ldf_computegmat.f --- openmolcas-22.02/src/ldf_ri_util/ldf_computegmat.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_computegmat.f 2022-10-10 14:22:40.000000000 +0000 @@ -30,6 +30,7 @@ Integer M Real*8 G(M,M) #include "ldf_atom_pair_info.fh" +#include "localdf_mem.fh" #include "localdf_bas.fh" #include "localdf_int.fh" #include "WrkSpc.fh" @@ -77,6 +78,7 @@ ! Allocate memory for Seward Call GetMem('GetMax','Max ','Real',ip_SewWrk,l_SewWrk) + l_SewWrk = min(l_SewWrk,MaxLDFSew) Call xSetMem_Ints(l_SewWrk) ! Get atoms of pair @@ -86,7 +88,7 @@ ! Compute G matrix nRow_G=M l_G=M*M - Call Cho_dZero(G,l_G) + Call FZero(G,l_G) dShell=nShell_Valence+nShell_Auxiliary+1 SHA=dShell SHC=dShell diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_computeintegrals_jk_2p.f openmolcas-22.10/src/ldf_ri_util/ldf_computeintegrals_jk_2p.f --- openmolcas-22.02/src/ldf_ri_util/ldf_computeintegrals_jk_2p.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_computeintegrals_jk_2p.f 2022-10-10 14:22:40.000000000 +0000 @@ -21,6 +21,7 @@ Integer l_xInt_ Real*8 xInt(l_xInt_) #include "WrkSpc.fh" +#include "localdf_mem.fh" #include "localdf_bas.fh" #include "localdf_int2.fh" #include "ldf_atom_pair_info.fh" @@ -79,11 +80,12 @@ Call LDF_Quit(1) End If ! Init integral array - Call Cho_dZero(xInt,l_xInt) + Call FZero(xInt,l_xInt) ! Set indices Call LDF_SetIndx_JK_2P(AB,CD) ! Allocate Seward memory Call GetMem('GetMax','Max ','Real',ip_SewWrk,l_SewWrk) + l_SewWrk = min(l_SewWrk,MaxLDFSew) Call xSetMem_Ints(l_SewWrk) ! Compute integrals dShell=nShell_Valence+nShell_Auxiliary+1 diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_computeintegrals_uvj_2p.f openmolcas-22.10/src/ldf_ri_util/ldf_computeintegrals_uvj_2p.f --- openmolcas-22.02/src/ldf_ri_util/ldf_computeintegrals_uvj_2p.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_computeintegrals_uvj_2p.f 2022-10-10 14:22:40.000000000 +0000 @@ -22,6 +22,7 @@ Integer l_xInt_ Real*8 xInt(l_xInt_) #include "WrkSpc.fh" +#include "localdf_mem.fh" #include "localdf_bas.fh" #include "localdf_int.fh" #include "ldf_atom_pair_info.fh" @@ -89,7 +90,7 @@ Call LDF_Quit(1) End If ! Init integral array - Call Cho_dZero(xInt,l_xInt) + Call FZero(xInt,l_xInt) ! Set number of shells on atoms A and B nShell_A=LDF_nShell_Atom(A) @@ -121,6 +122,7 @@ ! Allocate memory for Seward Call GetMem('GetMax','Max ','Real',ip_SewWrk,l_SewWrk) + l_SewWrk = min(l_SewWrk,MaxLDFSew) Call xSetMem_Ints(l_SewWrk) ! Compute integrals (uv|J) diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_computeintegrals_uvj.f openmolcas-22.10/src/ldf_ri_util/ldf_computeintegrals_uvj.f --- openmolcas-22.02/src/ldf_ri_util/ldf_computeintegrals_uvj.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_computeintegrals_uvj.f 2022-10-10 14:22:40.000000000 +0000 @@ -21,6 +21,7 @@ Integer l_xInt Real*8 xInt(l_xInt) #include "WrkSpc.fh" +#include "localdf_mem.fh" #include "localdf_bas.fh" #include "localdf_int.fh" #include "ldf_atom_pair_info.fh" @@ -58,7 +59,7 @@ i2CList(i,j)=iWork(ip_2CList-1+l_2CList_1*(j-1)+i) ! Init integral array - Call Cho_dZero(xInt,l_xInt) + Call FZero(xInt,l_xInt) ! Set dummy shell dShell=nShell_Valence+nShell_Auxiliary+1 @@ -113,6 +114,7 @@ ! Allocate memory for Seward Call GetMem('GetMax','Max ','Real',ip_SewWrk,l_SewWrk) + l_SewWrk = min(l_SewWrk,MaxLDFSew) Call xSetMem_Ints(l_SewWrk) ! Compute integrals (uv|J) diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_computeoverlapblock.f openmolcas-22.10/src/ldf_ri_util/ldf_computeoverlapblock.f --- openmolcas-22.02/src/ldf_ri_util/ldf_computeoverlapblock.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_computeoverlapblock.f 2022-10-10 14:22:40.000000000 +0000 @@ -167,14 +167,14 @@ ************************************************************************ * * ! Compute integrals - Call Cho_dZero(S,lS) + Call FZero(S,lS) ip=1 Do iSB=1,nSB iShellB=iWork(ipB+iSB) Do iSA=1,nSA iShellA=iWork(ipA+iSA) l=nBasSh(iShellA)*nBasSh(iShellB) - Call Cho_dZero(Work(ip_SOInt),l) + Call FZero(Work(ip_SOInt),l) Call OneEl_IJ(iShellA,iShellB,iPrint,Do_PGamma, & Work(ip_xZeta),Work(ip_xZI),Work(ip_xKappa), & Work(ip_xPCoor), diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_computevalenceintegrals.f openmolcas-22.10/src/ldf_ri_util/ldf_computevalenceintegrals.f --- openmolcas-22.02/src/ldf_ri_util/ldf_computevalenceintegrals.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_computevalenceintegrals.f 2022-10-10 14:22:40.000000000 +0000 @@ -23,6 +23,7 @@ Integer l_xInt_ Real*8 xInt(l_xInt_) #include "WrkSpc.fh" +#include "localdf_mem.fh" #include "localdf_bas.fh" #include "localdf_int.fh" #include "ldf_atom_pair_info.fh" @@ -94,7 +95,7 @@ End If ! Initialize integral array - Call Cho_dZero(xInt,l_xInt) + Call FZero(xInt,l_xInt) ! Allocate and set index array to shell rows and cols of integrals l_iAB=nShell_A*nShell_B @@ -150,6 +151,7 @@ ! Allocate memory for Seward Call GetMem('Max','Max ','Real',ip_SewWrk,l_SewWrk) + l_SewWrk = min(l_SewWrk,MaxLDFSew) Call xSetMem_Ints(l_SewWrk) ! Compute integrals @@ -174,7 +176,7 @@ iShell=iWork(ipA+iS) nij=nBasSh(iShell)*nBasSh(jShell) nijkl=nij*nkl - Call Cho_dZero(Work(ip_SQ),nijkl) + Call FZero(Work(ip_SQ),nijkl) SHA=iShell SHB=jShell SHC=kShell diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_computevalenceintegralsfromc.f openmolcas-22.10/src/ldf_ri_util/ldf_computevalenceintegralsfromc.f --- openmolcas-22.02/src/ldf_ri_util/ldf_computevalenceintegralsfromc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_computevalenceintegralsfromc.f 2022-10-10 14:22:40.000000000 +0000 @@ -106,7 +106,7 @@ End If ! Init integral array - Call Cho_dZero(xInt,l_xInt) + Call FZero(xInt,l_xInt) ! Get number of auxiliary basis functions on each pair MAB=LDF_nBasAux_Pair_wLD(AB) @@ -384,7 +384,7 @@ Call WarningMessage(2,SecNam//': Insufficient X dimension') Call LDF_Quit(1) End If - Call Cho_dZero(X,l_X) + Call FZero(X,l_X) If (LDF_nBasAux_Pair_wLD(CD).lt.1) Return @@ -495,7 +495,7 @@ Call WarningMessage(2,SecNam//': Insufficient X dimension') Call LDF_Quit(1) End If - Call Cho_dZero(X,l_X) + Call FZero(X,l_X) If (LDF_nBasAux_Pair_wLD(CD).lt.1) Return diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_findsignificantatompairs.f openmolcas-22.10/src/ldf_ri_util/ldf_findsignificantatompairs.f --- openmolcas-22.02/src/ldf_ri_util/ldf_findsignificantatompairs.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_findsignificantatompairs.f 2022-10-10 14:22:40.000000000 +0000 @@ -133,7 +133,7 @@ Call Shell_MxSchwz(nShell,Work(ip_Tmax)) ! Find max for each atom pair - Call Cho_dZero(Work(ip_Dmax),l_Dmax) + Call FZero(Work(ip_Dmax),l_Dmax) Do jAtom=1,nAtom nShell_j=LDF_nShell_Atom(jAtom) ip_j=LDF_lShell_Atom(jAtom) @@ -277,6 +277,7 @@ Integer l_Diag Real*8 Diag(l_Diag) #include "WrkSpc.fh" +#include "localdf_mem.fh" Integer ip_iOff, l_iOff Integer ip_SewWrk, l_SewWrk @@ -323,8 +324,9 @@ ! Compute diagonal integrals (parallelzation over atom pairs) Call Init_Tsk(ID,nRSAP) Call GetMem('GetMax','Max ','Real',ip_SewWrk,l_SewWrk) + l_SewWrk = min(l_SewWrk,MaxLDFSew) Call xSetMem_Ints(l_SewWrk) - Call Cho_dZero(Diag,iOff(nRSAP+1)-1) + Call FZero(Diag,iOff(nRSAP+1)-1) Do While (Rsv_Tsk(ID,iRSAP)) l=iOff(iRSAP+1)-iOff(iRSAP) Call LDF_ComputeAPDiagonal(ID_RSAP(1,iRSAP), diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_init.f openmolcas-22.10/src/ldf_ri_util/ldf_init.f --- openmolcas-22.02/src/ldf_ri_util/ldf_init.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_init.f 2022-10-10 14:22:40.000000000 +0000 @@ -68,7 +68,7 @@ If (Timing) Then l_T=2*nTask Call GetMem('LDFINIT','Allo','Real',ip_T,l_T) - Call Cho_dZero(Work(ip_T),l_T) + Call FZero(Work(ip_T),l_T) Else l_T=0 ip_T=0 diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_integralerrorstat.f openmolcas-22.10/src/ldf_ri_util/ldf_integralerrorstat.f --- openmolcas-22.02/src/ldf_ri_util/ldf_integralerrorstat.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_integralerrorstat.f 2022-10-10 14:22:40.000000000 +0000 @@ -63,7 +63,7 @@ AP_Atoms(i,j)=iWork(ip_AP_Atoms-1+2*(j-1)+i) ! Init Stat - Call Cho_dZero(Stat,9) + Call FZero(Stat,9) ! Get atoms A=AP_Atoms(1,AB) diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_replicatedata.f openmolcas-22.10/src/ldf_ri_util/ldf_replicatedata.f --- openmolcas-22.02/src/ldf_ri_util/ldf_replicatedata.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_replicatedata.f 2022-10-10 14:22:40.000000000 +0000 @@ -174,7 +174,7 @@ l=LDF_AtomPair_DiagDim(iAtomPair) ip=ip_D(iAtomPair) If (LDF_DiskAddressOfC(iAtomPair).lt.0) Then - Call Cho_dZero(Work(ip),l) + Call FZero(Work(ip),l) End If Call GAdGOp(Work(ip),l,'+') End If @@ -222,7 +222,7 @@ tCIO=tCIO+(tC3-tC2) tWIO=tWIO+(tW3-tW2) Else - Call Cho_dZero(Work(ip_C),l) + Call FZero(Work(ip_C),l) End If Call GAdGOp(Work(ip_C),l,'+') iWork(ip_AP_DiskC-1+iAtomPair)=iAddr diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_residualcd.f openmolcas-22.10/src/ldf_ri_util/ldf_residualcd.f --- openmolcas-22.02/src/ldf_ri_util/ldf_residualcd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_residualcd.f 2022-10-10 14:22:40.000000000 +0000 @@ -42,6 +42,7 @@ #include "WrkSpc.fh" #include "ldf_atom_pair_info.fh" #include "localdf.fh" +#include "localdf_mem.fh" #include "localdf_bas.fh" #include "localdf_int.fh" @@ -119,8 +120,9 @@ Call GetMem('ResidG','Allo','Real',ip_Int,l_Int) ! Compute integrals Call GetMem('GetMax','Max ','Real',ip_SewWrk,l_SewWrk) + l_SewWrk = min(l_SewWrk,MaxLDFSew) Call xSetMem_Ints(l_SewWrk) - Call Cho_dZero(Work(ip_Int),l_Int) + Call FZero(Work(ip_Int),l_Int) Do klS=1,l_2CList_2 SHC=L2C(1,klS) SHD=L2C(2,klS) diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_setinc.f openmolcas-22.10/src/ldf_ri_util/ldf_setinc.f --- openmolcas-22.02/src/ldf_ri_util/ldf_setinc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_setinc.f 2022-10-10 14:22:40.000000000 +0000 @@ -30,7 +30,6 @@ C ldf_qdiag.fh C ldf_oneel.fh C ldf_charge_constraint_info.fh -C ldf_atomiclabels.fh C Implicit None #include "localdf.fh" diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_setintegralprescreeninginfo.f openmolcas-22.10/src/ldf_ri_util/ldf_setintegralprescreeninginfo.f --- openmolcas-22.02/src/ldf_ri_util/ldf_setintegralprescreeninginfo.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_setintegralprescreeninginfo.f 2022-10-10 14:22:40.000000000 +0000 @@ -22,6 +22,7 @@ Implicit None #include "WrkSpc.fh" #include "localdf.fh" +#include "localdf_mem.fh" #include "localdf_int.fh" #include "localdf_bas.fh" #include "ldf_integral_prescreening_info.fh" @@ -99,6 +100,7 @@ CutInt=1.0d-99 Call LDF_SetCutInt(CutInt) Call GetMem('GetMax','Max ','Real',ip,l) + l = min(l,MaxLDFSew) Call xSetMem_Ints(l) Do A=1,nAtom l=iWork(ip_GDiag_1C+2*(A-1)) diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_zeroauxbasvector.f openmolcas-22.10/src/ldf_ri_util/ldf_zeroauxbasvector.f --- openmolcas-22.02/src/ldf_ri_util/ldf_zeroauxbasvector.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_zeroauxbasvector.f 2022-10-10 14:22:40.000000000 +0000 @@ -36,13 +36,13 @@ Do iAtom=1,nAtom l=LDF_nBasAux_Atom(iAtom) ip=iWork(ip0+iAtom) - Call Cho_dZero(Work(ip),l) + Call FZero(Work(ip),l) End Do ip0=ip0+nAtom Do iAtomPair=1,NumberOfAtomPairs l=AP_2CFunctions(1,iAtomPair) ip=iWork(ip0+iAtomPair) - Call Cho_dZero(Work(ip),l) + Call FZero(Work(ip),l) End Do End diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_zeroblockmatrix.f openmolcas-22.10/src/ldf_ri_util/ldf_zeroblockmatrix.f --- openmolcas-22.02/src/ldf_ri_util/ldf_zeroblockmatrix.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_zeroblockmatrix.f 2022-10-10 14:22:40.000000000 +0000 @@ -37,7 +37,7 @@ jAtom=AP_Atoms(2,iAtomPair) l=LDF_nBas_Atom(iAtom)*LDF_nBas_Atom(jAtom) ip=iWork(ip_Blocks-1+iAtomPair) - Call Cho_dZero(Work(ip),l) + Call FZero(Work(ip),l) End Do End diff -Nru openmolcas-22.02/src/ldf_ri_util/ldf_zeroblockvector.f openmolcas-22.10/src/ldf_ri_util/ldf_zeroblockvector.f --- openmolcas-22.02/src/ldf_ri_util/ldf_zeroblockvector.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/ldf_zeroblockvector.f 2022-10-10 14:22:40.000000000 +0000 @@ -30,7 +30,7 @@ Do iAtomPair=1,NumberOfAtomPairs l=LDF_nBasAux_Pair(iAtomPair) ip=iWork(ip_Blocks-1+iAtomPair) - Call Cho_dZero(Work(ip),l) + Call FZero(Work(ip),l) End Do End diff -Nru openmolcas-22.02/src/ldf_ri_util/localdf_mem.fh openmolcas-22.10/src/ldf_ri_util/localdf_mem.fh --- openmolcas-22.02/src/ldf_ri_util/localdf_mem.fh 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/localdf_mem.fh 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,12 @@ +************************************************************************ +* This file is part of OpenMolcas. * +* * +* OpenMolcas is free software; you can redistribute it and/or modify * +* it under the terms of the GNU Lesser General Public License, v. 2.1. * +* OpenMolcas is distributed in the hope that it will be useful, but it * +* is provided "as is" and without any express or implied warranties. * +* For more details see the full text of the license in the file * +* LICENSE or in . * +************************************************************************ + Integer MaxLDFSew + Parameter (MaxLDFSew=1024**2) diff -Nru openmolcas-22.02/src/ldf_ri_util/post_2center_ldf.f openmolcas-22.10/src/ldf_ri_util/post_2center_ldf.f --- openmolcas-22.02/src/ldf_ri_util/post_2center_ldf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ldf_ri_util/post_2center_ldf.f 2022-10-10 14:22:40.000000000 +0000 @@ -29,7 +29,7 @@ * Modified to 2-center ERIs for RI June 2005 * ************************************************************************ use Basis_Info, only: nBas_Aux - use Wrj12 + use RI_glob, only: iOffA, Lu_A, Lu_Q, nChV use Gateway_global, only: force_out_of_core use RICD_Info, only: Thrshld_CD use Symmetry_Info, only: nIrrep @@ -41,7 +41,8 @@ #include "nsd.fh" Character Name_Q*6 Integer nQvec(0:7) - Real*8, Allocatable :: A_Diag(:), Local_A(:,:) + Real*8 :: A_Diag(*) + Real*8, Allocatable :: Local_A(:,:) Integer, Allocatable :: SO2C(:), AB(:,:) Real*8, Allocatable :: Scr(:) @@ -272,7 +273,6 @@ * * Call mma_deallocate(Scr) Call mma_deallocate(iDiag) - Call mma_deallocate(A_Diag) Call mma_deallocate(SO2lO) * * ************************************************************************ diff -Nru openmolcas-22.02/src/linalg_util/CMakeLists.txt openmolcas-22.10/src/linalg_util/CMakeLists.txt --- openmolcas-22.02/src/linalg_util/CMakeLists.txt 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/linalg_util/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -25,14 +25,12 @@ fzero.F90 idmin.F90 ilasrt.F90 - index_util.F90 izero.F90 linalg_mod.F90 matinvert.F90 nidiag.F90 nidiag_new.F90 not_dgeev.F90 - scatter.F90 schur_skew.F90 vecphase.F90 xeigen.F90 @@ -41,7 +39,6 @@ # Source files defining modules that should be available to other *_util directories set (modfile_list blockdiagonal_matrices.F90 - index_util.F90 linalg_mod.F90 ) diff -Nru openmolcas-22.02/src/linalg_util/exp_schur.F90 openmolcas-22.10/src/linalg_util/exp_schur.F90 --- openmolcas-22.02/src/linalg_util/exp_schur.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/linalg_util/exp_schur.F90 2022-10-10 14:22:40.000000000 +0000 @@ -18,7 +18,7 @@ !> @details !> Computes the exponential of an antisymmetric real matrix \f$ X \f$ through its Schur decomposition. !> The exponential of \f$ X \f$ is an orthogonal matrix. -!> The Schur form of \f$ X \f$ is antisymmetric real, block-diagonal, with \f$ 2\times 2\$ or \f$ 1\times 1\f$ diagonal blocks. +!> The Schur form of \f$ X \f$ is antisymmetric real, block-diagonal, with \f$ 2\times 2\f$ or \f$ 1\times 1\f$ diagonal blocks. !> If \f$ X = Z T Z^T \f$, then \f$ \exp(X) = Z \exp(T) Z^T \f$, and \f$ exp(T) \f$ is trivial to compute since each block can !> be treated separately: \f$ (0, \lambda) \to (\cos(\lambda), \pm\sin(\lambda) \f$. !> diff -Nru openmolcas-22.02/src/linalg_util/index_util.F90 openmolcas-22.10/src/linalg_util/index_util.F90 --- openmolcas-22.02/src/linalg_util/index_util.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/linalg_util/index_util.F90 1970-01-01 00:00:00.000000000 +0000 @@ -1,49 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** - -module Index_util - -use Definitions, only: iwp - -implicit none -private -public :: iTri, iTri0, nTriElem, nTri0Elem - -! iTri, nTriElem: Index and number of elements in a triangular storage -! iTri0, nTri0Elem: idem for 0-based indices (e.g. angular momentum) - -contains - -pure function iTri(i,j) - integer(kind=iwp) :: iTri - integer(kind=iwp), intent(in) :: i,j - iTri = max(i,j)*(max(i,j)-1)/2+min(i,j) -end function iTri - -pure function iTri0(i,j) - integer(kind=iwp) :: iTri0 - integer(kind=iwp), intent(in) :: i,j - iTri0 = max(i,j)*(max(i,j)+1)/2+min(i,j)+1 -end function iTri0 - -pure function nTriElem(n) - integer(kind=iwp) :: nTriElem - integer(kind=iwp), intent(in) :: n - nTriElem = n*(n+1)/2 -end function nTriElem - -pure function nTri0Elem(n) - integer(kind=iwp) :: nTri0Elem - integer(kind=iwp), intent(in) :: n - nTri0Elem = (n+1)*(n+2)/2 -end function nTri0Elem - -end module Index_util diff -Nru openmolcas-22.02/src/linalg_util/izero.F90 openmolcas-22.10/src/linalg_util/izero.F90 --- openmolcas-22.02/src/linalg_util/izero.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/linalg_util/izero.F90 2022-10-10 14:22:40.000000000 +0000 @@ -17,7 +17,7 @@ integer(kind=iwp), intent(in) :: N integer(kind=iwp), intent(out) :: B(N) -call ICOPY(N,[0],0,B,1) +B(:) = 0 return diff -Nru openmolcas-22.02/src/linalg_util/linalg_mod.F90 openmolcas-22.10/src/linalg_util/linalg_mod.F90 --- openmolcas-22.02/src/linalg_util/linalg_mod.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/linalg_util/linalg_mod.F90 2022-10-10 14:22:40.000000000 +0000 @@ -19,7 +19,10 @@ use stdalloc, only: mma_allocate, mma_deallocate use constants, only: Zero, One -use definitions, only: wp, iwp, r8 +use definitions, only: wp, iwp +#ifdef _ADDITIONAL_RUNTIME_CHECK_ +use definitions, only: r8 +#endif use sorting, only: sort, argsort use sorting_funcs, only: leq_i, leq_r, geq_r @@ -92,9 +95,9 @@ !> 3. Stable-sort the $p_i$ by their norm. !> 4. Take the first $d$ projections and normalize them. These are your canonical Eigenvectors. !> -!> @param[inout] V 2D matrix which contains the Eigenvectors. +!> @param[in,out] V 2D matrix which contains the Eigenvectors. !> The j-th column corresponds to the j-th Eigenvalue. -!> @param[inout] lambda 1D vector of Eigenvalues. +!> @param[in,out] lambda 1D vector of Eigenvalues. !> @param[in] proj_B Optional and overloaded argument. !> If it is ommited, the canonical unit vector basis is assumed. !> Otherwise it can be 2D orthogonal matrix that represents the reference basis for @@ -119,21 +122,24 @@ !> !> @details !> -!> @paramin[in] A -!> @paramin[in] B -!> @paramin[out] C The shape of the output array is usually +!> @param[in] A +!> @param[in] B +!> @param[out] C The shape of the output array is usually !> [size(A, 1), size(B, 2)] which changes of course, if !> A or B are transposed. -!> @paramin[in] transpA, Optional argument to specify that A +!> @param[in] transpA Optional argument to specify that A !> should be transposed. -!> @paramin[in] transpB, Optional argument to specify that B +!> @param[in] transpB Optional argument to specify that B !> should be transposed. subroutine mult_2D(A,B,C,transpA,transpB) real(kind=wp), intent(in) :: A(:,:), B(:,:) real(kind=wp), intent(out) :: C(:,:) logical(kind=iwp), intent(in), optional :: transpA, transpB logical(kind=iwp) :: transpA_, transpB_ - integer(kind=iwp) :: M, N, K_1, K_2, K + integer(kind=iwp) :: M, N, K_1, K +# ifdef _ADDITIONAL_RUNTIME_CHECK_ + integer(kind=iwp) :: K_2 +# endif debug_function_name('mult_2D') if (present(transpA)) then @@ -152,7 +158,9 @@ N = size(B,merge(2,1,.not. transpB_)) ASSERT(N == size(C,2)) K_1 = size(A,merge(2,1,.not. transpA_)) +# ifdef _ADDITIONAL_RUNTIME_CHECK_ K_2 = size(B,merge(1,2,.not. transpB_)) +# endif ASSERT(K_1 == K_2) K = K_1 @@ -167,10 +175,10 @@ !> !> @details !> -!> @paramin[in] A -!> @paramin[in] x -!> @paramin[out] y The shape of the output array is size(x) -!> @paramin[in] transpA, Optional argument to specify that A +!> @param[in] A +!> @param[in] x +!> @param[out] y The shape of the output array is size(x) +!> @param[in] transpA Optional argument to specify that A !> should be transposed. subroutine mult_2D_1D(A,x,y,transpA) real(kind=wp), intent(in) :: A(:,:), x(:) @@ -206,17 +214,16 @@ !> So if `A_ptr` is the pointer to A in the work array !> it is necessary to call it with `Work(A_ptr : )`. !> -!> @paramin[in] A -!> @paramin[in] shapeA The shape of A. -!> @paramin[in] B -!> @paramin[in] shapeB The shape of B. -!> @paramin[in] C -!> @paramin[out] C The shape of the output array is usually +!> @param[in] A +!> @param[in] shapeA The shape of A. +!> @param[in] B +!> @param[in] shapeB The shape of B. +!> @param[out] C The shape of the output array is usually !> (shapeA(1) * shapeB(2)) which changes of course, if !> A or B are transposed. -!> @paramin[in] transpA, Optional argument to specify that A +!> @param[in] transpA Optional argument to specify that A !> should be transposed. -!> @paramin[in] transpB, Optional argument to specify that B +!> @param[in] transpB Optional argument to specify that B !> should be transposed. subroutine mult_2D_raw(A,shapeA,B,shapeB,C,transpA,transpB) real(kind=wp), intent(in), target :: A(*) @@ -321,7 +328,7 @@ !> For this reason all Eigenvalues of the same Eigenspace are replaced !> with their mean. !> -!> @param[inout] lambda Eigenvalues are sorted ascendingly and +!> @param[in,out] lambda Eigenvalues are sorted ascendingly and !> Eigenvalues of the same Eigenspace (up to floating point error) !> are replaced with their mean. !> @param[out] dimensions The dimension of each Eigenspace. diff -Nru openmolcas-22.02/src/linalg_util/scatter.F90 openmolcas-22.10/src/linalg_util/scatter.F90 --- openmolcas-22.02/src/linalg_util/scatter.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/linalg_util/scatter.F90 1970-01-01 00:00:00.000000000 +0000 @@ -1,30 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** - -subroutine SCATTER(N,A,IND,B) - -#include "intent.fh" - -use Definitions, only: wp, iwp - -implicit none -integer(kind=iwp), intent(in) :: N, IND(N) -real(kind=wp), intent(_OUT_) :: A(*) -real(kind=wp), intent(in) :: B(N) -integer(kind=iwp) :: I - -do I=1,N - A(IND(I)) = B(I) -end do - -return - -end subroutine SCATTER diff -Nru openmolcas-22.02/src/linalg_util/schur_skew.F90 openmolcas-22.10/src/linalg_util/schur_skew.F90 --- openmolcas-22.02/src/linalg_util/schur_skew.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/linalg_util/schur_skew.F90 2022-10-10 14:22:40.000000000 +0000 @@ -18,12 +18,12 @@ !> @details !> Computes the real Schur decomposition of an antisymmetric real matrix \f$ A \f$. !> The real Schur decomposition satisfies \f$ A = Z E Z^T \f$ with \f$ Z \f$ a real orthogonal matrix -!> and \f$ E \f$ an antisymmetric real, block-diagonal matrix, with \f$ 2\times 2 \$ or \f$ 1\times 1 \f$ +!> and \f$ E \f$ an antisymmetric real, block-diagonal matrix, with \f$ 2\times 2 \f$ or \f$ 1\times 1 \f$ !> diagonal blocks. !> !> Only the lower triangle of \f$ A \f$ is referenced. On output, \p A contains the \f$ Z \f$ matrix, !> and \p E contains the essential elements of \f$ E \f$, which are pairs of opposite sign -!> for the \f$ 2\times 2 \$, or zero for the \f$ 1\times 1 \f$ blocks. +!> for the \f$ 2\times 2 \f$, or zero for the \f$ 1\times 1 \f$ blocks. !> !> @param[in] N Size of the square matrix !> @param[in,out] A Antisymmetric real matrix, it is replaced by its real Schur vectors diff -Nru openmolcas-22.02/src/localisation/get_etwo_act.F90 openmolcas-22.10/src/localisation/get_etwo_act.F90 --- openmolcas-22.02/src/localisation/get_etwo_act.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/localisation/get_etwo_act.F90 2022-10-10 14:22:40.000000000 +0000 @@ -24,7 +24,7 @@ #include "chotime.fh" integer(kind=iwp) :: i, iOff, irc, nBB, nForb(8,2), nIorb(8,2), NSCREEN real(kind=wp) :: ChFracMem, dFmat, dmpk, FactXI -!character(len=16) :: KSDFT +!character(len=80) :: KSDFT real(kind=wp), allocatable :: Dm1(:), Dm2(:) real(kind=r8), external :: ddot_ !, Get_ExFac type (DSBA_Type) :: FLT(2), KLT(2), POrb(2), PLT(2) @@ -41,7 +41,7 @@ do i=1,nSym nBB = nBB+nBas(i)**2 end do -!call Get_cArray('DFT functional',KSDFT,16) +!call Get_cArray('DFT functional',KSDFT,80) !ExFac = Get_ExFac(KSDFT) !FactXI = ExFac FactXI = One ! always HF energy diff -Nru openmolcas-22.02/src/localisation/rdvec_localisation.F90 openmolcas-22.10/src/localisation/rdvec_localisation.F90 --- openmolcas-22.02/src/localisation/rdvec_localisation.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/localisation/rdvec_localisation.F90 2022-10-10 14:22:40.000000000 +0000 @@ -84,7 +84,7 @@ k2 = 1 do iSym=1,nSym call dCopy_(nBas(iSym)*nOrb(iSym),CMO_(k1),1,CMO(k2),1) - call Cho_dZero(CMO(k2+nBas(iSym)*nOrb(iSym)),nBas(iSym)*(nBas(iSym)-nOrb(iSym))) + call FZero(CMO(k2+nBas(iSym)*nOrb(iSym)),nBas(iSym)*(nBas(iSym)-nOrb(iSym))) k1 = k1+nBas(iSym)*nOrb(iSym) k2 = k2+nBas(iSym)*nBas(iSym) end do @@ -93,7 +93,7 @@ k2 = 1 do iSym=1,nSym call dCopy_(nOrb(iSym),Occ_(k1),1,Occ(k2),1) - call Cho_dZero(Occ(k2+nOrb(iSym)),nBas(iSym)-nOrb(iSym)) + call FZero(Occ(k2+nOrb(iSym)),nBas(iSym)-nOrb(iSym)) k1 = k1+nOrb(iSym) k2 = k2+nBas(iSym) end do @@ -111,7 +111,7 @@ k1 = 1 k2 = 1 do iSym=1,nSym - call iCopy(nOrb(iSym),Ind_(k1),1,IndT(k2),1) + IndT(k2:k2+nOrb(iSym)-1) = Ind_(k1:k1+nOrb(iSym)-1) do i=nOrb(iSym),nBas(iSym)-1 IndT(k2+i) = 7 end do diff -Nru openmolcas-22.02/src/localisation/wrvec_localisation.F90 openmolcas-22.10/src/localisation/wrvec_localisation.F90 --- openmolcas-22.02/src/localisation/wrvec_localisation.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/localisation/wrvec_localisation.F90 2022-10-10 14:22:40.000000000 +0000 @@ -94,7 +94,7 @@ if (Write_Ind) then l_Ind = 7*8 call mma_allocate(Ind_,l_Ind,label='Ind_') - call iCopy(l_Ind,IndT,1,Ind_,1) + Ind_(:) = IndT(1:l_Ind) else call mma_allocate(Ind_,1,label='Ind_') Ind_(1) = 0 diff -Nru openmolcas-22.02/src/localisation_util/cho_ov_loc.F90 openmolcas-22.10/src/localisation_util/cho_ov_loc.F90 --- openmolcas-22.02/src/localisation_util/cho_ov_loc.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/localisation_util/cho_ov_loc.F90 2022-10-10 14:22:40.000000000 +0000 @@ -50,7 +50,7 @@ exit end if end if - call izero(iD_vir(jD),nBas(iSym)) + iD_vir(jD:jD+nBas(iSym)-1) = 0 if (nSsh(iSym) > 0) then nOcc = nFro(iSym)+nIsh(iSym)+nAsh(iSym) call GetDens_Localisation(Dens,C%SB(iSym)%A2,nBas(iSym),nOcc) diff -Nru openmolcas-22.02/src/loprop_util/read_h0.F90 openmolcas-22.10/src/loprop_util/read_h0.F90 --- openmolcas-22.02/src/loprop_util/read_h0.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/loprop_util/read_h0.F90 2022-10-10 14:22:40.000000000 +0000 @@ -11,7 +11,7 @@ subroutine Read_h0(nSize,h0,Restart) -use Definitions, only: iwp, wp, u6 +use Definitions, only: wp, iwp, u6 implicit none integer(kind=iwp), intent(in) :: nSize diff -Nru openmolcas-22.02/src/lucia_util/densi2_lucia.f openmolcas-22.10/src/lucia_util/densi2_lucia.f --- openmolcas-22.02/src/lucia_util/densi2_lucia.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/lucia_util/densi2_lucia.f 2022-10-10 14:22:40.000000000 +0000 @@ -197,7 +197,7 @@ IF(IPRDEN.GE.2) &WRITE(6,*) ' ICISTR,LSCR1 ',ICISTR,LSCR1 *.SCRATCH space for block of two-electron density matrix -* A 4 index block with four indeces belonging OS class +* A 4 index block with four indices belonging OS class INTSCR = MXTSOB ** 4 IF(IPRDEN.GE.2) &WRITE(6,*) ' Density scratch space ',INTSCR diff -Nru openmolcas-22.02/src/lucia_util/freestr_gas.f openmolcas-22.10/src/lucia_util/freestr_gas.f --- openmolcas-22.02/src/lucia_util/freestr_gas.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/lucia_util/freestr_gas.f 2022-10-10 14:22:40.000000000 +0000 @@ -51,7 +51,7 @@ & KISTSO(ITP),NSPGPFTP(ITP)*NSMST) END DO * -**. Lexical adressing of arrays : use array indeces for complete active space +**. Lexical adressing of arrays : use array indices for complete active space * *. Not in use so DO IGRP = 1, NGRP diff -Nru openmolcas-22.02/src/lucia_util/gtjk.f openmolcas-22.10/src/lucia_util/gtjk.f --- openmolcas-22.02/src/lucia_util/gtjk.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/lucia_util/gtjk.f 2022-10-10 14:22:40.000000000 +0000 @@ -14,7 +14,7 @@ * Interface routine for obtaining Coulomb (RJ) and * Exchange integrals (RK) * -* Ordering of intgrals is in the internal order +* Ordering of integrals is in the internal order IMPLICIT REAL*8(A-H,O-Z) * #include "mxpdim.fh" diff -Nru openmolcas-22.02/src/lucia_util/intim.f openmolcas-22.10/src/lucia_util/intim.f --- openmolcas-22.02/src/lucia_util/intim.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/lucia_util/intim.f 2022-10-10 14:22:40.000000000 +0000 @@ -37,7 +37,7 @@ CALL INTPNT(iWORK(KPINT1),iWORK(KLSM1), & iWORK(KPINT2),iWORK(KLSM2)) * -*. Pointer for orbital indeces for symmetry blocked matrices +*. Pointer for orbital indices for symmetry blocked matrices CALL ORBINH1(iWORK(KINH1),iWORK(KINH1_NOCCSYM),NTOOBS,NTOOB,NSMOB) * *. Change one-electron integrals to inactive fock matrix diff -Nru openmolcas-22.02/src/lucia_util/lucia_ini.f openmolcas-22.10/src/lucia_util/lucia_ini.f --- openmolcas-22.02/src/lucia_util/lucia_ini.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/lucia_util/lucia_ini.f 2022-10-10 14:22:40.000000000 +0000 @@ -267,12 +267,12 @@ C Set defaults C ============== * -********************************************************************** -* * -* Part 2 : Insert defaults for missing optional keywords * -* and print error messages for missing mandatory keywords * -* * -********************************************************************** +************************************************************************ +* * +* Part 2 : Insert defaults for missing optional keywords * +* and print error messages for missing mandatory keywords * +* * +************************************************************************ * NMISS = 0 * diff -Nru openmolcas-22.02/src/lucia_util/max_open_orb.f openmolcas-22.10/src/lucia_util/max_open_orb.f --- openmolcas-22.02/src/lucia_util/max_open_orb.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/lucia_util/max_open_orb.f 2022-10-10 14:22:40.000000000 +0000 @@ -16,8 +16,8 @@ * * Jeppe Olsen, November 2001 * + USE csfbas, only: maxop_lucia #include "implicit.fh" -#include "csfbas.fh" *. Input INTEGER IOCLS(NGAS,NOCLS) INTEGER NOBPT(NGAS) diff -Nru openmolcas-22.02/src/lucia_util/memstr_gas.f openmolcas-22.10/src/lucia_util/memstr_gas.f --- openmolcas-22.02/src/lucia_util/memstr_gas.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/lucia_util/memstr_gas.f 2022-10-10 14:22:40.000000000 +0000 @@ -70,7 +70,7 @@ & KISTSO(ITP),NSPGPFTP(ITP)*NSMST) END DO * -**. Lexical adressing of arrays : use array indeces for complete active space +**. Lexical adressing of arrays : use array indices for complete active space * *. Not in use so DO IGRP = 1, NGRP diff -Nru openmolcas-22.02/src/lucia_util/natorb_lucia.f openmolcas-22.10/src/lucia_util/natorb_lucia.f --- openmolcas-22.02/src/lucia_util/natorb_lucia.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/lucia_util/natorb_lucia.f 2022-10-10 14:22:40.000000000 +0000 @@ -53,7 +53,7 @@ * DO IOB = IOBOFF,IOBOFF + LOB-1 DO JOB = IOBOFF,IOBOFF + LOB-1 -*. Corresponding type indeces +*. Corresponding type indices IOBP = ISTOB(IOB) JOBP = ISTOB(JOB) RHO1SM(IMTOFF-1+(JOB-IOBOFF)*LOB+IOB-IOBOFF+1) diff -Nru openmolcas-22.02/src/lucia_util/ngasdt.f openmolcas-22.10/src/lucia_util/ngasdt.f --- openmolcas-22.02/src/lucia_util/ngasdt.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/lucia_util/ngasdt.f 2022-10-10 14:22:40.000000000 +0000 @@ -15,11 +15,11 @@ & IOCOC,MXSOOB_AS) * * -* Number of combimations with symmetry ITOTSM and +* Number of combinations with symmetry ITOTSM and * occupation between IOCCMN and IOCCMX * * In view of the limited range of I*4, the number of dets -* is returned as integer and real*8 +* is returned as integer and real*8 * * MXSB is largest UNPACKED symmetry block * MXSOOB is largest UNPACKED symmetry-type-type block diff -Nru openmolcas-22.02/src/lucia_util/orbinh1.f openmolcas-22.10/src/lucia_util/orbinh1.f --- openmolcas-22.02/src/lucia_util/orbinh1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/lucia_util/orbinh1.f 2022-10-10 14:22:40.000000000 +0000 @@ -12,14 +12,14 @@ ************************************************************************ SUBROUTINE ORBINH1(IORBINH1,IORBINH1_NOCCSYM,NTOOBS,NTOOB,NSMOB) * -* Obtain array of 2 orbital indeces, +* Obtain array of 2 orbital indices, * for symmetry packed matrices * * IORBINH1 : Lower half packed * IORBINH1_NOCCSYM : Complete blocks * -* resulting indeces are with respect to start of given symmetry block -* while input orbital indeces are absolute and in symmetry order +* resulting indices are with respect to start of given symmetry block +* while input orbital indices are absolute and in symmetry order * * Jeppe Olsen, March 1995 * ORBINH1_NOCCSYM added August 2000 @@ -75,7 +75,7 @@ IORBINH1_NOCCSYM(IABS,JABS) = INDEX_NOCCSYM END DO END DO -*. End of loops over orbital indeces +*. End of loops over orbital indices END DO END DO *. End of loop over orbital symmetries diff -Nru openmolcas-22.02/src/lucia_util/pnt4dm.f openmolcas-22.10/src/lucia_util/pnt4dm.f --- openmolcas-22.02/src/lucia_util/pnt4dm.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/lucia_util/pnt4dm.f 2022-10-10 14:22:40.000000000 +0000 @@ -15,12 +15,12 @@ * * Pointer for 4 dimensionl array with total symmetry IDXSM * Pointer is given as 3 dimensional array corresponding -* to the first 3 indeces +* to the first 3 indices * Symmetry of last index is give by ISM4 * -* IS12 (0,1,-1) : Permutational symmetry between indeces 1 and 2 -* IS34 (0,1,-1) : Permutational symmetry between indeces 3 and 3 -* IS1234 (0,1,-1) : permutational symmetry between indeces 12 and 34 +* IS12 (0,1,-1) : Permutational symmetry between indices 1 and 2 +* IS34 (0,1,-1) : Permutational symmetry between indices 3 and 3 +* IS1234 (0,1,-1) : permutational symmetry between indices 12 and 34 * *. General input INTEGER ADSXA(MXPOBS,2*MXPOBS),SXDXSX(2*MXPOBS,4*MXPOBS) diff -Nru openmolcas-22.02/src/lucia_util/prmblk.f openmolcas-22.10/src/lucia_util/prmblk.f --- openmolcas-22.02/src/lucia_util/prmblk.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/lucia_util/prmblk.f 2022-10-10 14:22:40.000000000 +0000 @@ -24,7 +24,7 @@ * ===== * Output * ===== -* JATP(I),JASM(I),JBTP(I),JBSM(I) Indeces for Block I +* JATP(I),JASM(I),JBTP(I),JBSM(I) indices for Block I * NPERM : Number of blocks that can be obtained * ITRP(I) = 1 => block should be transposed * = 0 => block should not be transposed diff -Nru openmolcas-22.02/src/lucia_util/rssbcb2.f openmolcas-22.10/src/lucia_util/rssbcb2.f --- openmolcas-22.02/src/lucia_util/rssbcb2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/lucia_util/rssbcb2.f 2022-10-10 14:22:40.000000000 +0000 @@ -77,7 +77,7 @@ * IHFORM * NNSEL2E : Only selected 2e terms will be included * ISEL2E : orbital spaces in which 2e terms are included -* (Currently : all indeces identical ) +* (Currently : all indices identical ) * * ====== * Output diff -Nru openmolcas-22.02/src/lucia_util/sblock.f openmolcas-22.10/src/lucia_util/sblock.f --- openmolcas-22.02/src/lucia_util/sblock.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/lucia_util/sblock.f 2022-10-10 14:22:40.000000000 +0000 @@ -164,7 +164,7 @@ IF(IPRCIX.GE.3) &WRITE(6,*) ' ICISTR,LSCR1 ',ICISTR,LSCR1 *.SCRATCH space for integrals -* A 4 index integral block with four indeces belonging OS class +* A 4 index integral block with four indices belonging OS class INTSCR = MAX(MXTSOB ** 4, NTOOB**2) IF(IPRCIX.GE.3) &WRITE(6,*) ' Integral scratch space ',INTSCR diff -Nru openmolcas-22.02/src/mbpt2/cho_sosmp2_col.F90 openmolcas-22.10/src/mbpt2/cho_sosmp2_col.F90 --- openmolcas-22.02/src/mbpt2/cho_sosmp2_col.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mbpt2/cho_sosmp2_col.F90 2022-10-10 14:22:40.000000000 +0000 @@ -44,7 +44,7 @@ end if if (NumCho(iSym) < 1) then - call Cho_dZero(Col,nDim*nCol) + Col(:,:) = Zero return end if diff -Nru openmolcas-22.02/src/mbpt2/cho_sosmp2_drv.F90 openmolcas-22.10/src/mbpt2/cho_sosmp2_drv.F90 --- openmolcas-22.02/src/mbpt2/cho_sosmp2_drv.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mbpt2/cho_sosmp2_drv.F90 2022-10-10 14:22:40.000000000 +0000 @@ -130,7 +130,7 @@ ! -------------------------------------------------- nSym_Sav = nSym -call iCopy(nSym,NumCho,1,nMP2Vec,1) +nMP2Vec(1:nSym) = NumCho(1:nSym) call Cho_X_Final(irc) if (irc /= 0) then @@ -141,7 +141,7 @@ LuPri = u6 nSym = nSym_Sav -call iCopy(nSym,nMP2Vec,1,NumCho,1) +NumCho(1:nSym) = nMP2Vec(1:nSym) ! Decompose M(ai,bj) = (ai|bj)^2 . ! Set number of vectors to be used in energy calculation. diff -Nru openmolcas-22.02/src/mbpt2/cho_sosmp2_energy.F90 openmolcas-22.10/src/mbpt2/cho_sosmp2_energy.F90 --- openmolcas-22.02/src/mbpt2/cho_sosmp2_energy.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mbpt2/cho_sosmp2_energy.F90 2022-10-10 14:22:40.000000000 +0000 @@ -41,7 +41,7 @@ irc = 0 iTyp = 2 -call iCopy(nSym,nMP2Vec,1,nEnrVec,1) +nEnrVec(:) = nMP2Vec ! Initialize SOS-MP2 energy correction. ! ------------------------------------- diff -Nru openmolcas-22.02/src/mbpt2/cho_sosmp2_setup.F90 openmolcas-22.10/src/mbpt2/cho_sosmp2_setup.F90 --- openmolcas-22.02/src/mbpt2/cho_sosmp2_setup.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mbpt2/cho_sosmp2_setup.F90 2022-10-10 14:22:40.000000000 +0000 @@ -86,8 +86,8 @@ end do end do else - call Cho_iZero(nMatab,8) - call Cho_iZero(iMatab,64) + call iZero(nMatab,8) + call iZero(iMatab,64) end if ! If batching over occuped orbitals is forced by user, then turn it Off! diff -Nru openmolcas-22.02/src/mbpt2/freezer.F90 openmolcas-22.10/src/mbpt2/freezer.F90 --- openmolcas-22.02/src/mbpt2/freezer.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mbpt2/freezer.F90 2022-10-10 14:22:40.000000000 +0000 @@ -37,7 +37,7 @@ nFro1(1) = nFre return else - call Cho_iZero(nFro1,nSym) + call iZero(nFro1,nSym) end if ! Set up array of active occupied orbital energies. diff -Nru openmolcas-22.02/src/mbpt2/mp2_driver.F90 openmolcas-22.10/src/mbpt2/mp2_driver.F90 --- openmolcas-22.02/src/mbpt2/mp2_driver.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mbpt2/mp2_driver.F90 2022-10-10 14:22:40.000000000 +0000 @@ -49,8 +49,7 @@ implicit none integer(kind=iwp), intent(out) :: ireturn -integer(kind=iwp) :: i, iOpt, iPrc, irc, iSym, itmp, iTol, iTst, iType, lthCMO, lthEOr, nAsh(8), nDel_tra(8), nFro_tra(8), & - nIsh(8), nOccT +integer(kind=iwp) :: i, iOpt, iPrc, irc, iSym, iTol, iTst, iType, lthCMO, lthEOr, nAsh(8), nDel_tra(8), nFro_tra(8), nIsh(8), nOccT real(kind=wp) :: E0, E2BJAI, ESCF, ESSMP2, Etot, REFC, Shanks1_E, t1dg, t1nrm, TCPE(4), TCPT, TIOE(4), TIOT logical(kind=iwp) :: Conventional, IsDirect, Exists, Ready character(len=8) :: Method, Method1 @@ -277,15 +276,13 @@ do i=1,8 nIsh(i) = nOrb(i)+nDel(i) end do - itmp = 0 - call ICopy(8,[itmp],0,nFro_tra,1) - call ICopy(8,[itmp],0,nDel_tra,1) + nFro_tra(:) = 0 + nDel_tra(:) = 0 else - call ICopy(8,nOcc,1,nIsh,1) + nIsh(:) = nOcc end if - itmp = 0 - call ICopy(8,[itmp],0,nAsh,1) + nAsh(:) = 0 if (.not. DoDens) then ! PAM Jan 2013: Set correct nOrb: do i=1,8 diff -Nru openmolcas-22.02/src/mckinley/1eldot_mck_interface.fh openmolcas-22.10/src/mckinley/1eldot_mck_interface.fh --- openmolcas-22.02/src/mckinley/1eldot_mck_interface.fh 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/1eldot_mck_interface.fh 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,20 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +#ifdef _CALLING_ +Alpha,nAlpha,Beta,nBeta,Zeta,rKappa,P,nZeta,la,lb,A,B,nHer,Array,nArr,Ccoor,nOrdOp,rout,IndGrd,DAO,mdc,ndc,nOp & +#else +! TODO: unknown intents +integer (kind=iwp) :: nAlpha, nBeta, nZeta, la, lb, nHer, nArr, nOrdOp, IndGrd(2,3,3,0:7), mdc, ndc, nOp(2) +real(kind=wp) :: Alpha(nAlpha), Beta(nBeta), Zeta(nZeta), rKappa(nZeta), P(nZeta,3), A(3), B(3), Array(nZeta*nArr), Ccoor(3), & + rout(*), DAO(nZeta,nTri_Elem1(la),nTri_Elem1(lb)) +#endif +#undef _CALLING_ diff -Nru openmolcas-22.02/src/mckinley/1el_mck_interface.fh openmolcas-22.10/src/mckinley/1el_mck_interface.fh --- openmolcas-22.02/src/mckinley/1el_mck_interface.fh 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/1el_mck_interface.fh 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,22 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +#ifdef _CALLING_ +Alpha,nAlpha,Beta,nBeta,Zeta,rKappa,P,rFinal,nZeta,la,lb,A,B,nHer,Array,nArr,Ccoor,nOrdOp,ifgrad,IndGrd,nOp,iu,iv,nrOp,iDcar, & +trans,kcar,ksym & +#else +! TODO: unknown intents +integer(kind=iwp) :: nAlpha, nBeta, nZeta, la, lb, nHer, nArr, nOrdOp, IndGrd(0:7), nOp(2), iu, iv, nrOp, iDcar, kcar, ksym +real(kind=wp) :: Alpha(nAlpha), Beta(nBeta), Zeta(nZeta), rKappa(nZeta), P(nZeta,3), rFinal(*), A(3), B(3), & + Array(nZeta*nArr), Ccoor(3) +logical(kind=iwp) :: ifgrad(3,2), trans(2) +#endif +#undef _CALLING_ diff -Nru openmolcas-22.02/src/mckinley/acore.f openmolcas-22.10/src/mckinley/acore.f --- openmolcas-22.02/src/mckinley/acore.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/acore.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,171 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Acore(iang,la,ishll,nordop,TC,A,Array,narr, - & Alpha,nalpha,fa1,fa2,jfgrad,jfhess, - & ld,debug) -* -* -* Calculates and -* -* @parameter iang Angular momenta for core -* @parameter la Angular momenta for bra -* @parameter ishll identification for core shell -* @parameter nordop order for operator -* @parameter TC Cartesian coordinates for core -* @parameter A Cartesian coordinates for bra -* @parameter Array Scratch -* @parameter narr size for scratch -* @parameter Alpha Bra exponents -* @parameter nalpha number of exponents -* @parameter FA1 First derivatives (out) -* @parameter FA2 2nd derivatives (out) -* @parameter jfgrad true for all 1-deriavtives that are needed -* @parameter jfhess true for all 2-deriavtives that are needed -* @parameter ld Order of derivatives -* @parameter debug guess - Use Basis_Info - use Her_RW - use Real_Spherical - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "real.fh" -#include "print.fh" -#include "disp.fh" - Logical ABeq(3),jfgrad(3),jfhess(4,3,4,3), - & debug - Real*8 TC(3),A(3),Array(*),fa1(*),fa2(*),alpha(*) - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - nExpi=Shells(iShll)%nExp - ip = 1 - ipP1 = ip - ip = ip + 3 * nAlpha*nExpi - ipZ1 = ip - ip = ip + nAlpha*nExpi - ipK1 = ip - ip = ip + nAlpha*nExpi - ipZI1 = ip - ip = ip + nAlpha*nExpi - If (ip-1.gt.nArr) Then - Write (6,*) ' ip-1.gt.nArr in acore (',ip, - & ',',narr,')' - Call Abend - End If - -C------Calculate Effective center and exponent for - - Call ZXia(Array(ipZ1),Array(ipZI1),nAlpha,nExpi, - & Alpha,Shells(iShll)%Exp) - Call SetUp1(Alpha,nAlpha,Shells(iShll)%Exp,nExpi, - & A,TC,Array(ipK1),Array(ipP1),Array(ipZI1)) -* -*--------------Calculate Overlap and derivative -* - nHer = (la+1+iAng+1+ld)/2 - ipAxyz = ip - ip = ip + nAlpha*nExpi*3*nHer*(la+1+ld) - ipCxyz = ip - ip = ip + nAlpha*nExpi*3*nHer*(iAng+1) - ipRxyz = ip - ip = ip + nAlpha*nExpi*3*nHer*(nOrdOp+1) - ipQ1 = ip - ip = ip + - & nAlpha*nExpi*3*(la+1+ld)*(iAng+1)*(nOrdOp+1) - ipA = ip - ip = ip + nAlpha*nExpi - If (ip-1.gt.nArr) Then - Write (6,*) ' ip-1.gt.nArr (1b) in acore (', - & ip,',',narr,')','Order',ld,Shells(ishll)%nExp,nalpha - Call Abend - End If - ABeq(1) = A(1).eq.TC(1) - ABeq(2) = A(2).eq.TC(2) - ABeq(3) = A(3).eq.TC(3) - Call CrtCmp(Array(ipZ1),Array(ipP1),nAlpha*nExpi, - & A,Array(ipAxyz),la+ld,HerR(iHerR(nHer)), - & nHer,ABeq) - Call CrtCmp(Array(ipZ1),Array(ipP1),nAlpha*nExpi, - & TC,Array(ipCxyz),iAng,HerR(iHerR(nHer)), - & nHer,ABeq) - ABeq(1) = .False. - ABeq(2) = .False. - ABeq(3) = .False. - Call CrtCmp(Array(ipZ1),Array(ipP1),nAlpha*nExpi, - & A,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)), - & nHer,ABeq) - If (debug) Then - Write (6,*) ' nAlpha = ',nAlpha,' nExp(',ishll,')=', - & nExpi,' nHer=',nHer,' la=',la,' iAng=', - & iAng,' nOrdOp=',nOrdOp - - Write (6,*) ' Array(ipAxyz)=', - & DNrm2_(nAlpha*nExpi*3*nHer*(la+ld+1), - & Array(ipAxyz),1) - Write (6,*) ' Array(ipCxyz)=', - & DNrm2_(nAlpha*nExpi*3*nHer*(iAng+1), - & Array(ipCxyz),1) - Write (6,*) ' Array(ipRxyz)=', - & DNrm2_(nAlpha*nExpi*3*nHer*(nOrdOp+1), - & Array(ipRxyz),1) - End If - - Call Assmbl(Array(ipQ1), - & Array(ipAxyz),la+ld, - & Array(ipRxyz),nOrdOp, - & Array(ipCxyz),iAng, - & nAlpha*nExpi,HerW(iHerW(nHer)),nHer) - iStrt = ipA - Do 20 iGamma = 1, nExpi - call dcopy_(nAlpha,Alpha,1,Array(iStrt),1) - iStrt = iStrt + nAlpha - 20 Continue - If (debug) Then - Write (6,*) ' Array(ipA)=', - & DNrm2_(nAlpha*nExpi,Array(ipA),1) - End If - - Call rKappa_Zeta(Array(ipK1),Array(ipZ1),nExpi*nAlpha) - Call CmbnAC(Array(ipQ1),nAlpha*nExpi,la,iAng, - & Array(ipK1),FA1, - & Array(ipA),JfGrad,ld,nVecAC) - If (debug) Then - write(6,*) 'nVecAC',nvecac - Write (6,*) ' Array(ipQ1)=', - & DNrm2_( - & nAlpha*nExpi*3*(la+ld+1)*(iAng+1)*(nOrdOp+1), - & Array(ipQ1),1) - Write (6,*) ' Array(ipA)=', - & DNrm2_(nAlpha*nExpi,Array(ipA),1) - Do i=1,nvecac - ipV=1 - n=nAlpha*nExpi*nElem(la)*nElem(iAng) - Write(6,*) 'Cmbn(',i,')=',DNrm2_(n,FA1(ipV),1) - ipV=ipV+n - End do - End If - - If (ld.ge.2) Then - Call CmbnS2a(Array(ipQ1),nAlpha*nExpi,la,iAng, - & Array(ipK1),FA2, - & Array(ipA),jfHess,ld) - If (debug) Then - Do i=1,6 - ipV=1 - n=nAlpha*nExpi*nElem(la)*nElem(iAng) - Write(6,*) 'Cmbn2(',i,')=',DNrm2_(n,FA2(ipV),1) - ipV=ipV+n - End do - End If - End If - - - Return - End diff -Nru openmolcas-22.02/src/mckinley/acore.F90 openmolcas-22.10/src/mckinley/acore.F90 --- openmolcas-22.02/src/mckinley/acore.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/acore.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,141 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Acore(iang,la,ishll,nordop,TC,A,Array,narr,Alpha,nalpha,fa1,fa2,jfgrad,jfhess,ld,debug) +! Calculates and +! +! @parameter iang Angular momenta for core +! @parameter la Angular momenta for bra +! @parameter ishll identification for core shell +! @parameter nordop order for operator +! @parameter TC Cartesian coordinates for core +! @parameter A Cartesian coordinates for bra +! @parameter Array Scratch +! @parameter narr size for scratch +! @parameter Alpha Bra exponents +! @parameter nalpha number of exponents +! @parameter FA1 First derivatives (out) +! @parameter FA2 2nd derivatives (out) +! @parameter jfgrad true for all 1-derivatives that are needed +! @parameter jfhess true for all 2-derivatives that are needed +! @parameter ld Order of derivatives +! @parameter debug guess + +use Index_Functions, only: nTri_Elem1 +use Basis_Info, only: Shells +use Her_RW, only: HerR, HerW, iHerR, iHerW +use Definitions, only: wp, iwp, u6, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: iang, la, ishll, nordop, narr, nalpha, ld +real(kind=wp), intent(in) :: TC(3), A(3), Alpha(nAlpha) +real(kind=wp), intent(_OUT_) :: Array(*), fa1(*) +real(kind=wp), intent(inout) :: fa2(*) +logical(kind=iwp), intent(in) :: jfgrad(3), jfhess(4,3,4,3), debug +integer(kind=iwp) :: i, iGamma, ip, ipA, ipAxyz, ipCxyz, ipK1, ipP1, ipQ1, ipRxyz, ipV, ipZ1, ipZI1, iStrt, n, nExpi, nHer, nVecAC +logical(kind=iwp) :: ABeq(3) +real(kind=r8), external :: DNrm2_ + +nExpi = Shells(iShll)%nExp +ip = 1 +ipP1 = ip +ip = ip+3*nAlpha*nExpi +ipZ1 = ip +ip = ip+nAlpha*nExpi +ipK1 = ip +ip = ip+nAlpha*nExpi +ipZI1 = ip +ip = ip+nAlpha*nExpi +if (ip-1 > nArr) then + write(u6,*) ' ip-1 > nArr in acore (',ip,',',narr,')' + call Abend() +end if + +! Calculate Effective center and exponent for + +call ZXia(Array(ipZ1),Array(ipZI1),nAlpha,nExpi,Alpha,Shells(iShll)%Exp) +call SetUp1(Alpha,nAlpha,Shells(iShll)%Exp,nExpi,A,TC,Array(ipK1),Array(ipP1),Array(ipZI1)) + +! Calculate Overlap and derivative + +nHer = (la+1+iAng+1+ld)/2 +ipAxyz = ip +ip = ip+nAlpha*nExpi*3*nHer*(la+1+ld) +ipCxyz = ip +ip = ip+nAlpha*nExpi*3*nHer*(iAng+1) +ipRxyz = ip +ip = ip+nAlpha*nExpi*3*nHer*(nOrdOp+1) +ipQ1 = ip +ip = ip+nAlpha*nExpi*3*(la+1+ld)*(iAng+1)*(nOrdOp+1) +ipA = ip +ip = ip+nAlpha*nExpi +if (ip-1 > nArr) then + write(u6,*) ' ip-1 > nArr (1b) in acore (',ip,',',narr,')','Order',ld,Shells(ishll)%nExp,nalpha + call Abend() +end if +ABeq(1) = A(1) == TC(1) +ABeq(2) = A(2) == TC(2) +ABeq(3) = A(3) == TC(3) +call CrtCmp(Array(ipZ1),Array(ipP1),nAlpha*nExpi,A,Array(ipAxyz),la+ld,HerR(iHerR(nHer)),nHer,ABeq) +call CrtCmp(Array(ipZ1),Array(ipP1),nAlpha*nExpi,TC,Array(ipCxyz),iAng,HerR(iHerR(nHer)),nHer,ABeq) +ABeq(1) = .false. +ABeq(2) = .false. +ABeq(3) = .false. +call CrtCmp(Array(ipZ1),Array(ipP1),nAlpha*nExpi,A,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) +if (debug) then + write(u6,*) ' nAlpha = ',nAlpha,' nExp(',ishll,')=',nExpi,' nHer=',nHer,' la=',la,' iAng=',iAng,' nOrdOp=',nOrdOp + + write(u6,*) ' Array(ipAxyz)=',DNrm2_(nAlpha*nExpi*3*nHer*(la+ld+1),Array(ipAxyz),1) + write(u6,*) ' Array(ipCxyz)=',DNrm2_(nAlpha*nExpi*3*nHer*(iAng+1),Array(ipCxyz),1) + write(u6,*) ' Array(ipRxyz)=',DNrm2_(nAlpha*nExpi*3*nHer*(nOrdOp+1),Array(ipRxyz),1) +end if + +call Assmbl(Array(ipQ1),Array(ipAxyz),la+ld,Array(ipRxyz),nOrdOp,Array(ipCxyz),iAng,nAlpha*nExpi,HerW(iHerW(nHer)),nHer) +iStrt = ipA +do iGamma=1,nExpi + Array(iStrt:iStrt+nAlpha-1) = Alpha + iStrt = iStrt+nAlpha +end do +if (debug) then + write(u6,*) ' Array(ipA)=',DNrm2_(nAlpha*nExpi,Array(ipA),1) +end if + +call rKappa_Zeta(Array(ipK1),Array(ipZ1),nExpi*nAlpha) +call CmbnAC(Array(ipQ1),nAlpha*nExpi,la,iAng,Array(ipK1),FA1,Array(ipA),JfGrad,ld,nVecAC) +if (debug) then + write(u6,*) 'nVecAC',nvecac + write(u6,*) ' Array(ipQ1)=',DNrm2_(nAlpha*nExpi*3*(la+ld+1)*(iAng+1)*(nOrdOp+1),Array(ipQ1),1) + write(u6,*) ' Array(ipA)=',DNrm2_(nAlpha*nExpi,Array(ipA),1) + do i=1,nvecac + ipV = 1 + n = nAlpha*nExpi*nTri_Elem1(la)*nTri_Elem1(iAng) + write(u6,*) 'Cmbn(',i,')=',DNrm2_(n,FA1(ipV),1) + ipV = ipV+n + end do +end if + +if (ld >= 2) then + call CmbnS2a(Array(ipQ1),nAlpha*nExpi,la,iAng,Array(ipK1),FA2,Array(ipA),jfHess,ld) + if (debug) then + do i=1,6 + ipV = 1 + n = nAlpha*nExpi*nTri_Elem1(la)*nTri_Elem1(iAng) + write(u6,*) 'Cmbn2(',i,')=',DNrm2_(n,FA2(ipV),1) + ipV = ipV+n + end do + end if +end if + +return + +end subroutine Acore diff -Nru openmolcas-22.02/src/mckinley/buffer.fh openmolcas-22.10/src/mckinley/buffer.fh --- openmolcas-22.02/src/mckinley/buffer.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/buffer.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -* -* nFinMax: Maximum number of AO's in buffer -* -* mGr : Maximum number of derivatives that -* should be calculated in each batch, -* excluding translation invariance. -* For geometrical derivatives mGr=9 -* -* Mem_Fock_MO: Space needed to load in Fock matrix (MO's) -* -* Direct : The integrals are not buffered, the Fock matrixes -* and MO are in memory. This will will need a hell -* of a lot of memory, but will result in a fast calculation. -* True if it exist enough of memory. -* -* - Parameter ( nFinMax = 3*MxAtom ) - Integer mGr,Mem_Fock_MO, - & ipdisp2(nFinMAx),ipDisp(nFinMax),ipMO(nFinMax,2), - & ipDisp3(nFInMax) - Logical Int_Direct - Common /Buffer2/ mGr,Mem_Fock_MO,ipdisp, - & ipdisp2,Int_Direct,ipMO,ipDisp3 diff -Nru openmolcas-22.02/src/mckinley/clr2.f openmolcas-22.10/src/mckinley/clr2.f --- openmolcas-22.02/src/mckinley/clr2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/clr2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,224 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) Anders Bernhardsson * -************************************************************************ - SubRoutine Clr2(rIn,rOut,ibas,icmp,jbas,jcmp, - & iaoi,iaoj,naco,ishell, - & temp1,temp2,temp3,temp4,temp5,temp6) -* - use pso_stuff - use SOAO_Info, only: iAOtSO - use Symmetry_Info, only: nIrrep, iOper - use Basis_Info, only: nBas - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "real.fh" -#include "etwas.fh" -#include "buffer.fh" -#include "disp.fh" -#include "disp2.fh" -* - Real*8 rIn(ibas*icmp*jbas*jcmp,0:nIrrep-1, - & nAco*(1+naco)/2,*) - real*8 rout(*) - Real*8 Temp1(ibas,icmp,*) - Real*8 Temp2(*) - Real*8 Temp4(ibas,icmp,nACO) - Real*8 Temp5(jbas,jcmp,nACO) - Real*8 Temp3(jbas,jcmp,*),Temp6(*) - integer ishell(4),na(0:7),ipp(0:7) - iTri(i,j) = Max(i,j)*(Max(i,j)-1)/2 + Min(i,j) - - call dcopy_(Naco**4,[0.0d0],0,Temp2,1) - call dcopy_(nACO*ICMP*IBAS,[0.0d0],0,Temp4,1) - call dcopy_(nACO*JCMP*JBAS,[0.0d0],0,Temp5,1) - nnA=0 - Do iS=0,nIrrep-1 - nA(iS)=nNA - nna=nna+nAsh(is) - End Do - n=0 - Do i=1,nirrep - n=n+ldisp(i-1) - end do - n=ibas*icmp*jbas*jcmp*nIrrep*nAco*(1+naco)/2*n -* - ni=iCmp*iBas - nj=jCmp*jBas - ipi=1 - - - ipj=ipi+naco*ibas*icmp - - Call PckMo2(temp6(ipi),nAcO,icmp,iBas,jcmp,jBas,iaoi,iaoj) - id=0 - Do mIrr=0,nIrrep-1 - iiii=0 - Do iS=0,nIrrep-1 - js=nrOpr(ieor(ioper(is),iOper(mIrr))) - ipp(is)=iiii - iiii=nbas(is)*nash(js)+iiii - End Do - Do iDisp=1,lDisp(mIrr) - iD=id+1 - ia=1 - Do iIrr=0,nIrrep-1 - kl=0 - k=0 - Do kIrr=0,nIrrep-1 - Do kAsh=1,nAsh(kIrr) - k=k+1 - l=0 - Do lIrr=0,kIrr - kls=iEOR(iOper(kIrr),iOper(lIrr)) - jIrr=nropr(ieor(iEOR(iOper(iIrr),iOper(mIrr)),kls)) - ja=1 - Do j=0,jirr-1 - ja=ja+nAsh(j) - End Do -* -* Symmetry of Q matrix -* - jis=nropr(ieor(iOper(iIrr),ioper(mIrr))) -* - lMax=nAsh(lIrr) - If (lIrr.eq.kirr) lmax=kash - Do lAsh=1,lMax - l=lash+nA(lIrr) - kl=itri(k,l) -* -* id,iirr,jirr,kA,lA -* - If (nash(jirr).ne.0) - & Call DGEMM_('N','N', - & ni,nAsh(jIrr),nj, - & 1.0d0,rin(1,iIrr,kl,id),ni, - & Temp6(ipj+(ja-1)*jcmp*jBas),nj, - & 0.0d0,Temp1,ni) - If (nash(iirr).ne.0) - & Call DGEMM_('T','N', - & nash(iIrr),nAsh(jIrr),ni, - & 1.0d0,Temp6(ipi+(ia-1)*icmp*ibas),ni, - & Temp1,ni, - & 0.0d0,Temp2,nash(iirr)) -* -* - Do iC=1,iCmp - Do iB=1,iBas - Do i=1,nAsh(jis) - ih=i+na(jis) - Temp4(iB,ic,i)=0.0d0 - Do iAsh=1,nAsh(jirr) - jh=iash+na(jirr) - fact=1.0d00 - iij=itri(ih,jh) - if(iij.ge.kl .and. k.eq.l) fact=2.0d00 - if(iij.lt.kl .and. ih.eq.jh) fact=2.0d00 - If (k.ne.l) FacT=fact*2.0d0 - rd=G2(itri(iij,kl),1)*fact - Temp4(iB,ic,i)=Temp4(ib,ic,i)+ - & Temp1(ib,ic,iash)*rd - End Do - End Do - End Do - End Do -* - ipF=ipDisp3(id)-1+ipp(iirr) - Do jAsh=1,nAsh(jis) - Do iC=1,iCmp - lSO=iAOtSO(iAOi+iC,iIrr) - If (lso.gt.0) Then - Do iB=1,iBas - lsl=lSO+ib-1 - ipFKL=ipF+(jAsh-1)*nBas(iIrr)+lsl - rout(ipFKL)=rout(ipFKL)+Temp4(ib,ic,jash) - End Do - End If - End Do - End DO -* - If (iShell(1).ne.ishell(2)) Then - If (nash(jirr).ne.0) - & Call DGEMM_('T','N', - & nj,nAsh(jIrr),ni, - & 1.0d0,rin(1,jIrr,kl,id),ni, - & Temp6(ipi+(ja-1)*icmp*ibas),ni, - & 0.0d0,Temp3,nj) - If (nash(iirr).ne.0) - - & Call DGEMM_('T','N',nAsh(iirr),nAsh(jirr),nj, - & One,Temp6(ipj+(ia-1)*jcmp*jBas),nj, - & Temp3,nj, - & one,Temp2,nAsh(iirr)) -* - Do jC=1,jCmp - Do jB=1,jBas - Do i=1,nAsh(jis) - ih=i+na(jis) - Temp5(jB,jc,i)=0.0d0 - Do iAsh=1,nAsh(jirr) - jh=iash+na(jirr) - fact=1.0d00 - iij=itri(ih,jh) - if(iij.ge.kl .and. k.eq.l) fact=2.0d00 - if(iij.lt.kl .and. ih.eq.jh) fact=2.0d00 - If (k.ne.l) FacT=fact*2.0d0 - rd=G2(itri(iij,kl),1)*fact - Temp5(jB,jc,i)=Temp5(jb,jc,i)+Temp3(jb,jc,iash)*rd - End Do - End Do - End Do - End Do -* - ipf=ipDisp3(id)-1+ipp(iirr) - Do iAsh=1,nAsh(jis) - Do jC=1,jCmp - iSO=iAOtSO(iAOj+jC,iIrr) - If (iso.gt.0) Then - Do jB=1,jBas - i=iSO+jb-1 - ipFKL=ipF+(iAsh-1)*nBas(iIrr)+i - rout(ipFKL)=rout(ipFKL)+Temp5(jb,jc,iash) - End Do - End If - End Do - End DO - End If -* -* Distribute integrals -* - if (iirr.ge.jirr) then - klt=itri(k,l) - Do iAsh=1,nash(iirr) - ij1=iAsh+na(iirr) - Do jAsh=1,nash(jirr) - ij2=jAsh+na(jirr) - If (ij1.ge.ij2) Then - ij12=itri(ij1,ij2) - If (ij12.le.klt) Then - ipM=ipMO(iD,1)+iTri(ij12,klt)-1 - ipm2=iash+(jash-1)*nash(iirr) - rOut(ipm)=rout(ipm)+Temp2(ipm2) - End If - End If - End Do - End Do - end if - End DO ! lash - End DO ! lirr - End DO ! kash - End DO ! kirr - ia=ia+nAsh(iIrr) - End DO ! iirr - End DO ! ndisp - End DO ! msym - Return - End diff -Nru openmolcas-22.02/src/mckinley/clr2.F90 openmolcas-22.10/src/mckinley/clr2.F90 --- openmolcas-22.02/src/mckinley/clr2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/clr2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,209 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) Anders Bernhardsson * +!*********************************************************************** + +subroutine Clr2(rIn,rOut,ibas,icmp,jbas,jcmp,iaoi,iaoj,naco,ishell,temp1,temp2,temp3,temp4,temp5,temp6) + +use McKinley_global, only: ipDisp3, ipMO +use Index_Functions, only: iTri, nTri_Elem +use pso_stuff, only: G2 +use SOAO_Info, only: iAOtSO +use Symmetry_Info, only: iOper, nIrrep +use Basis_Info, only: nBas +use Constants, only: Zero, One, Two +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: ibas, icmp, jbas, jcmp, iaoi, iaoj, naco, ishell(4) +real(kind=wp), intent(in) :: rIn(ibas*icmp*jbas*jcmp,0:nIrrep-1,nTri_Elem(naco),*) +real(kind=wp), intent(inout) :: rOut(*) +real(kind=wp), intent(_OUT_) :: Temp1(ibas,icmp,*), Temp2(*), Temp3(jbas,jcmp,*), Temp6(*) +real(kind=wp), intent(out) :: Temp4(ibas,icmp,nACO), Temp5(jbas,jcmp,nACO) +#include "Molcas.fh" +#include "etwas.fh" +#include "disp.fh" +integer(kind=iwp) :: i, ia, iAsh, iB, iC, id, iDisp, ih, iiii, iij, iIrr, ij1, ij12, ij2, ipF, ipFKL, ipi, ipj, ipM, ipm2, & + ipp(0:7), iS, iSO, j, ja, jAsh, jB, jC, jh, jIrr, jis, js, k, kAsh, kIrr, kl, kls, klt, l, lAsh, lIrr, lMax, & + lsl, lSO, mIrr, n, na(0:7), ni, nj, nnA +real(kind=wp) :: fact, rd +integer(kind=iwp), external :: NrOpr + +Temp2(1:Naco**4) = Zero +Temp4(:,:,:) = Zero +Temp5(:,:,:) = Zero +nnA = 0 +do iS=0,nIrrep-1 + nA(iS) = nNA + nnA = nnA+nAsh(is) +end do +n = 0 +do i=0,nIrrep-1 + n = n+ldisp(i) +end do +n = ibas*icmp*jbas*jcmp*nIrrep*nTri_Elem(nAco)*n + +ni = iCmp*iBas +nj = jCmp*jBas +ipi = 1 + +ipj = ipi+naco*ibas*icmp + +call PckMo2(temp6(ipi),icmp,iBas,jcmp,jBas,iaoi,iaoj) +id = 0 +do mIrr=0,nIrrep-1 + iiii = 0 + do iS=0,nIrrep-1 + js = nrOpr(ieor(ioper(is),iOper(mIrr))) + ipp(is) = iiii + iiii = nbas(is)*nash(js)+iiii + end do + do iDisp=1,lDisp(mIrr) + iD = id+1 + ia = 1 + do iIrr=0,nIrrep-1 + kl = 0 + k = 0 + do kIrr=0,nIrrep-1 + do kAsh=1,nAsh(kIrr) + k = k+1 + l = 0 + do lIrr=0,kIrr + kls = ieor(iOper(kIrr),iOper(lIrr)) + jIrr = nropr(ieor(ieor(iOper(iIrr),iOper(mIrr)),kls)) + ja = 1 + do j=0,jIrr-1 + ja = ja+nAsh(j) + end do + + ! Symmetry of Q matrix + + jis = nropr(ieor(iOper(iIrr),ioper(mIrr))) + + lMax = nAsh(lIrr) + if (lIrr == kirr) lmax = kash + do lAsh=1,lMax + l = lash+nA(lIrr) + kl = itri(k,l) + + ! id,iirr,jirr,kA,lA + + if (nash(jirr) /= 0) & + call DGEMM_('N','N',ni,nAsh(jIrr),nj,One,rIn(:,iIrr,kl,id),ni,Temp6(ipj+(ja-1)*jcmp*jBas),nj,Zero,Temp1,ni) + if (nash(iirr) /= 0) & + call DGEMM_('T','N',nash(iIrr),nAsh(jIrr),ni,One,Temp6(ipi+(ia-1)*icmp*ibas),ni,Temp1,ni,Zero,Temp2,nash(iirr)) + + do iC=1,iCmp + do iB=1,iBas + do i=1,nAsh(jis) + ih = i+na(jis) + Temp4(iB,ic,i) = Zero + do iAsh=1,nAsh(jirr) + jh = iash+na(jirr) + fact = One + iij = itri(ih,jh) + if ((iij >= kl) .and. (k == l)) fact = Two + if ((iij < kl) .and. (ih == jh)) fact = Two + if (k /= l) FacT = fact*Two + rd = G2(itri(iij,kl),1)*fact + Temp4(iB,ic,i) = Temp4(ib,ic,i)+Temp1(ib,ic,iash)*rd + end do + end do + end do + end do + + ipF = ipDisp3(id)-1+ipp(iirr) + do jAsh=1,nAsh(jis) + do iC=1,iCmp + lSO = iAOtSO(iAOi+iC,iIrr) + if (lso > 0) then + do iB=1,iBas + lsl = lSO+ib-1 + ipFKL = ipF+(jAsh-1)*nBas(iIrr)+lsl + rOut(ipFKL) = rOut(ipFKL)+Temp4(ib,ic,jash) + end do + end if + end do + end do + + if (iShell(1) /= iShell(2)) then + if (nash(jirr) /= 0) & + call DGEMM_('T','N',nj,nAsh(jIrr),ni,One,rIn(:,jIrr,kl,id),ni,Temp6(ipi+(ja-1)*icmp*ibas),ni,Zero,Temp3,nj) + if (nash(iirr) /= 0) & + call DGEMM_('T','N',nAsh(iirr),nAsh(jirr),nj,One,Temp6(ipj+(ia-1)*jcmp*jBas),nj,Temp3,nj,One,Temp2,nAsh(iirr)) + + do jC=1,jCmp + do jB=1,jBas + do i=1,nAsh(jis) + ih = i+na(jis) + Temp5(jB,jc,i) = Zero + do iAsh=1,nAsh(jirr) + jh = iash+na(jirr) + fact = One + iij = itri(ih,jh) + if ((iij >= kl) .and. (k == l)) fact = Two + if ((iij < kl) .and. (ih == jh)) fact = Two + if (k /= l) FacT = fact*Two + rd = G2(itri(iij,kl),1)*fact + Temp5(jB,jc,i) = Temp5(jb,jc,i)+Temp3(jb,jc,iash)*rd + end do + end do + end do + end do + + ipf = ipDisp3(id)-1+ipp(iirr) + do iAsh=1,nAsh(jis) + do jC=1,jCmp + iSO = iAOtSO(iAOj+jC,iIrr) + if (iso > 0) then + do jB=1,jBas + i = iSO+jb-1 + ipFKL = ipF+(iAsh-1)*nBas(iIrr)+i + rOut(ipFKL) = rOut(ipFKL)+Temp5(jb,jc,iash) + end do + end if + end do + end do + end if + + ! Distribute integrals + + if (iirr >= jirr) then + klt = itri(k,l) + do iAsh=1,nash(iirr) + ij1 = iAsh+na(iirr) + do jAsh=1,nash(jirr) + ij2 = jAsh+na(jirr) + if (ij1 >= ij2) then + ij12 = itri(ij1,ij2) + if (ij12 <= klt) then + ipM = ipMO(iD)+iTri(ij12,klt)-1 + ipm2 = iash+(jash-1)*nash(iirr) + rOut(ipm) = rOut(ipm)+Temp2(ipm2) + end if + end if + end do + end do + end if + end do ! lash + end do ! lirr + end do ! kash + end do ! kirr + ia = ia+nAsh(iIrr) + end do ! iirr + end do ! ndisp +end do ! msym + +return + +end subroutine Clr2 diff -Nru openmolcas-22.02/src/mckinley/clrbuf.f openmolcas-22.10/src/mckinley/clrbuf.f --- openmolcas-22.02/src/mckinley/clrbuf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/clrbuf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,325 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine ClrBuf(idcrr,idcrs,idcrt,ngr, - & istb,jstb,kstb,lstb, - & Shijij,iAnga,iCmp,iCmpa, - & iShll,iShell,jShell, - & iBasi,jBasj,kBask,lBasl, - & Dij1,Dij2,mDij,nDij, - & Dkl1,Dkl2,mDkl,nDkl, - & Dik1,Dik2,mDik,nDik, - & Dil1,Dil2,mDil,nDil, - & Djk1,Djk2,mDjk,nDjk, - & Djl1,Djl2,mDjl,nDjl, - & Final,nFinal, - & FckTmp,nFT,Scrtch1,nS1,Scrtch2,nS2, - & Temp,nTemp, - & TwoHam,nTwo,IndGrd,Index,iAO,iAOst, - & iuvwx,IfG,n8,ltri,moip,nAcO, - & rmoin,nmoin,ntemptot,Buffer,c,nop,din,dan, - & new_fock) -************************************************************************ -* * -* Called from: Twoel * -* takes care of the integrals * -* integrals -> fckmatrix,MO * -* in the near feature a disk based version * -* * -* Calling: CntrDens : Gets the indexes for d1 * -* MkFck : Add up the integrals on the Fock Matrix * -* * -* Author: Anders Bernhardsson, Theoretical Chemistry, * -* University of Lund, Sweden, June '95 * -************************************************************************ - use Real_Spherical - use pso_stuff - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "real.fh" -#include "disp.fh" -#include "disp2.fh" -#include "buffer.fh" -#include "cputime.fh" -* - Integer iAnga(4), iShll(4),iShell(4),jShell(4), - & jOp(6), iCmp(4),icmpa(4), - & nop(4),Index(3,4),iuvwx(4), - & moip(0:7), - & IndGrd(3,4,0:7),iAO(4),iAOst(4) - Real*8 Dij1(mDij,nDij),Dkl1(mDkl,nDkl), - & Dik1(mDik,nDik),Dil1(mDil,nDil), - & Djk1(mDjk,nDjk),Djl1(mDjl,nDjl), - & Dij2(mDij,nDij),Dkl2(mDkl,nDkl), - & Dik2(mDik,nDik),Dil2(mDil,nDil), - & Djk2(mDjk,nDjk),Djl2(mDjl,nDjl), - & FckTmp(nFT),Scrtch1(nS1),Temp(nTemp), - & Scrtch2(nS2),TwoHam(nTwo),Final(nFinal), - & rmoin(nMOIN),c(12),buffer(*),din(*),dan(*) - Logical Shijij,n8,IfG(4),pert(0:7),ltri,new_fock -* - nijkl=iBasi*jBasj*kBask*lBasl - nabcd=iCmp(1)*iCmp(2)*iCmp(3)*iCmp(4) - Call Timing(dum1,Time,dum2,dum3) -* - ExFac=One -* - If (ltri) Then - if (.not.new_fock) then -*----------------------------------------------------------------* -* -* Get the size of the work area that should be contracted -* -*----------------------------------------------------------------* - If (jShell(1).ge.jShell(2)) Then - ij1 = iBasi - ij2 = jBasj - ij3 = iCmp(1) - ij4 = iCmp(2) - Else - ij1 = jBasj - ij2 = iBasi - ij3 = iCmp(2) - ij4 = iCmp(1) - End If - If (jShell(3).ge.jShell(4)) Then - kl1 = kBask - kl2 = lBasl - kl3 = iCmp(3) - kl4 = iCmp(4) - Else - kl1 = lBasl - kl2 = kBask - kl3 = iCmp(4) - kl4 = iCmp(3) - End If - If (jShell(1).ge.jShell(3)) Then - ik1 = iBasi - ik2 = kBask - ik3 = iCmp(1) - ik4 = iCmp(3) - Else - ik1 = kBask - ik2 = iBasi - ik3 = iCmp(3) - ik4 = iCmp(1) - End If - If (jShell(1).ge.jShell(4)) Then - il1 = iBasi - il2 = lBasl - il3 = iCmp(1) - il4 = iCmp(4) - Else - il1 = lBasl - il2 = iBasi - il3 = iCmp(4) - il4 = iCmp(1) - End If - If (jShell(2).ge.jShell(3)) Then - jk1 = jBasj - jk2 = kBask - jk3 = iCmp(2) - jk4 = iCmp(3) - Else - jk1 = kBask - jk2 = jBasj - jk3 = iCmp(3) - jk4 = iCmp(2) - End If - If (jShell(2).ge.jShell(4)) Then - jl1 = jBasj - jl2 = lBasl - jl3 = iCmp(2) - jl4 = iCmp(4) - Else - jl1 = lBasl - jl2 = jBasj - jl3 = iCmp(4) - jl4 = iCmp(2) - End If -* -* Here we go -* - nao=iBasi*jBasj*kBask*lBasl* - & iCmp(1)*iCmp(2)*iCmp(3)*iCmp(4) - Call CtlDns(iDCRR,iDCRS,iDCRT,jOp) - end if -* -* Add this contribution to the (Inactive) Fock Matrix -* -* Out from CD : jOp -* - Do iCent=1,4 - Do iCar=1,3 - Call lCopy(8,[.false.],0,pert,1) -* -* Too which irreps does this derivative contribute ? -* - Do iIrrep=0,nIrrep-1 - If (indgrd(iCar,iCent,iirrep).ne.0) - & pert(iIrrep)=.true. - End Do -* - If (Index(iCar,iCent).gt.0) Then - iGr=Index(iCar,iCent)-1 - ipFin=1+iGr*nijkl*nabcd - If (.not.new_fock) Then - Call MkFck(iAnga,iCmpa,iCmp, - & Shijij, - & iShll,iShell, - & iBasi,jBasj,kBask,lBasl, - & iAO,iAOst,nop,jop, - & Dij1,mDij,nDij,ij1,ij2,ij3,ij4, - & Dkl1,mDkl,nDkl,kl1,kl2,kl3,kl4, - & Dik1,mDik,nDik,ik1,ik2,ik3,ik4, - & Dil1,mDil,nDil,il1,il2,il3,il4, - & Djk1,mDjk,nDjk,jk1,jk2,jk3,jk4, - & Djl1,mDjl,nDjl,jl1,jl2,jl3,jl4, - & Final(ipFin), - & nAO,TwoHam,nTwo, - & Scrtch1,nS1,Scrtch2,nS2, - & iDCRR,iDCRS,iDCRT, - & FckTmp,nFT,pert,iuvwx(iCent), - & iCent,iCar,indgrd,ipdisp) - If (nMethod.eq.RASSCF) - & Call MkFck(iAnga,iCmpa,iCmp, - & Shijij, - & iShll,iShell, - & iBasi,jBasj,kBask,lBasl, - & iAO,iAOst,nop,jop, - & Dij2,mDij,nDij,ij1,ij2,ij3,ij4, - & Dkl2,mDkl,nDkl,kl1,kl2,kl3,kl4, - & Dik2,mDik,nDik,ik1,ik2,ik3,ik4, - & Dil2,mDil,nDil,il1,il2,il3,il4, - & Djk2,mDjk,nDjk,jk1,jk2,jk3,jk4, - & Djl2,mDjl,nDjl,jl1,jl2,jl3,jl4, - & Final(ipFin), - & nAO,TwoHam,nTwo, - & Scrtch1,nS1,Scrtch2,nS2, - & iDCRR,iDCRS,iDCRT, - & FckTmp,nFT,pert,iuvwx(iCent), - & iCent,iCar,indgrd,ipdisp2) - else - ip=ipDisp(abs(indgrd(iCar,iCent,0))) - Call FckAcc_NoSym(iAnga, - & iCmpa(1),iCmpa(2),iCmpa(3),iCmpa(4), Shijij, - & iShll, iShell, nijkl, - & Final(ipFin),TwoHam(ip),dan,ndens, - & iAO,iAOst,iBasi,jBasj,kBask,lBasl,ExFac) - If (nMethod.eq.RASSCF) Then - ip=ipDisp2(abs(indgrd(iCar,iCent,0))) - Call FckAcc_NoSym(iAnga, - & iCmpa(1),iCmpa(2),iCmpa(3),iCmpa(4), Shijij, - & iShll, iShell, nijkl, - & Final(ipFin),TwoHam(ip),din,nDens, - & iAO,iAOst,iBasi,jBasj,kBask,lBasl,ExFac) - end if - end if -* -* - Else If (Index(iCar,iCent).lt.0) Then - call dcopy_(nabcd*nijkl,[Zero],0,Temp,1) - Do iCnt=1,4 - iGr=Index(iCar,iCnt) - If (iGr.gt.0)Then - ipFin=1+(iGr-1)*nijkl*nabcd - Do ii=1,nabcd*nijkl - Temp(ii)=Temp(ii)-Final(ipFin-1+ii) - End Do - End If - End Do -* - if (.not.new_fock) Then - Call MkFck(iAnga,iCmpa,iCmp, - & Shijij, - & iShll,iShell, - & iBasi,jBasj,kBask,lBasl, - & iAO,iAOst,nop,jop, - & Dij1,mDij,nDij,ij1,ij2,ij3,ij4, - & Dkl1,mDkl,nDkl,kl1,kl2,kl3,kl4, - & Dik1,mDik,nDik,ik1,ik2,ik3,ik4, - & Dil1,mDil,nDil,il1,il2,il3,il4, - & Djk1,mDjk,nDjk,jk1,jk2,jk3,jk4, - & Djl1,mDjl,nDjl,jl1,jl2,jl3,jl4, - & Temp, - & nAO,TwoHam,nTwo, - & Scrtch1,nS1,Scrtch2,nS2, - & iDCRR,iDCRS,iDCRT, - & FckTmp,nFT,pert,iuvwx(iCent), - & icent,iCar,indgrd,ipdisp) - If (nMethod.eq.RASSCF) - & Call MkFck(iAnga,iCmpa,iCmp, - & Shijij, - & iShll,iShell, - & iBasi,jBasj,kBask,lBasl, - & iAO,iAOst,nop,jop, - & Dij2,mDij,nDij,ij1,ij2,ij3,ij4, - & Dkl2,mDkl,nDkl,kl1,kl2,kl3,kl4, - & Dik2,mDik,nDik,ik1,ik2,ik3,ik4, - & Dil2,mDil,nDil,il1,il2,il3,il4, - & Djk2,mDjk,nDjk,jk1,jk2,jk3,jk4, - & Djl2,mDjl,nDjl,jl1,jl2,jl3,jl4, - & Temp, - & nAO,TwoHam,nTwo, - & Scrtch1,nS1,Scrtch2,nS2, - & iDCRR,iDCRS,iDCRT, - & FckTmp,nFT,pert,iuvwx(iCent), - & icent,iCar,indgrd,ipdisp2) -* - else - ip=ipDisp(abs(indgrd(iCar,iCent,0))) - Call FckAcc_NoSym(iAnga, - & iCmpa(1),iCmpa(2),iCmpa(3),iCmpa(4), Shijij, - & iShll, iShell, nijkl, - & Temp,TwoHam(ip),dan,nDens, - & iAO,iAOst,iBasi,jBasj,kBask,lBasl,ExFac) - If (nMethod.eq.RASSCF) Then - ip=ipDisp2(abs(indgrd(iCar,iCent,0))) - Call FckAcc_NoSym(iAnga, - & iCmpa(1),iCmpa(2),iCmpa(3),iCmpa(4), Shijij, - & iShll, iShell, nijkl, - & Temp,TwoHam(ip),din,nDens, - & iAO,iAOst,iBasi,jBasj,kBask,lBasl,ExFac) - end if - end if -* - End If - End Do - End Do - Call Timing(dum1,Time,dum2,dum3) - CPUStat(nFckAck)=CPUStat(nFckAck)+Time - End If -* - If (n8.and.nmethod.eq.RASSCF) - &Call MakeMO(Final,Scrtch1,nTempTot,nFinal, - & TwoHam,nTwo, - & iCmp,iCmpa, - & iBasi,jbasj,kbask,lbasl, - & nGr,index, - & moip,naco,nop,indgrd, - & ishll,ishell,rmoin,nMOIN, - & iuvwx,iao,iaost,Buffer,ianga,c) -* -* - Call Timing(dum1,Time,dum2,dum3) - CPUStat(nMOTrans)=CPUStat(nMOTrans)+Time - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(istb) - Call Unused_integer(jstb) - Call Unused_integer(kstb) - Call Unused_integer(lstb) - Call Unused_logical_array(IfG) - End If - End diff -Nru openmolcas-22.02/src/mckinley/clrbuf.F90 openmolcas-22.10/src/mckinley/clrbuf.F90 --- openmolcas-22.02/src/mckinley/clrbuf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/clrbuf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,228 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine ClrBuf(idcrr,idcrs,idcrt,ngr,Shijij,iAnga,iCmp,iCmpa,iShll,iShell,jShell,iBasi,jBasj,kBask,lBasl,Dij1,Dij2,mDij,nDij, & + Dkl1,Dkl2,mDkl,nDkl,Dik1,Dik2,mDik,nDik,Dil1,Dil2,mDil,nDil,Djk1,Djk2,mDjk,nDjk,Djl1,Djl2,mDjl,nDjl,rFinal, & + nFinal,FckTmp,nFT,Scrtch1,nS1,Scrtch2,nS2,Temp,nTemp,TwoHam,nTwo,IndGrd,Indx,iAO,iAOst,iuvwx,n8,ltri,moip,nAcO, & + rmoin,nmoin,ntemptot,Buffer,nop,din,dan,new_fock) +!*********************************************************************** +! * +! Called from: Twoel * +! takes care of the integrals * +! integrals -> fckmatrix,MO * +! in the near feature a disk based version * +! * +! Calling: CntrDens : Gets the indexes for d1 * +! MkFck : Add up the integrals on the Fock Matrix * +! * +! Author: Anders Bernhardsson, Theoretical Chemistry, * +! University of Lund, Sweden, June '95 * +!*********************************************************************** + +use McKinley_global, only: CPUStat, ipDisp, ipDisp2, nFckAcc, nMethod, nMOTrans, RASSCF +use pso_stuff, only: ndens +use Symmetry_Info, only: nIrrep +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: idcrr, idcrs, idcrt, ngr, iAnga(4), iCmp(4), icmpa(4), iShll(4), iShell(4), jShell(4), iBasi, & + jBasj, kBask, lBasl, mDij, nDij, mDkl, nDkl, mDik, nDik, mDil, nDil, mDjk, nDjk, mDjl, nDjl, & + nFinal, nFT, nS1, nS2, nTemp, nTwo, IndGrd(3,4,0:7), Indx(3,4), iAO(4), iAOst(4), iuvwx(4), & + moip(0:7), nAcO, nmoin, ntemptot, nop(4) +logical(kind=iwp), intent(in) :: Shijij, n8, ltri, new_fock +real(kind=wp), intent(in) :: Dij1(mDij,nDij), Dij2(mDij,nDij), Dkl1(mDkl,nDkl), Dkl2(mDkl,nDkl), Dik1(mDik,nDik), Dik2(mDik,nDik), & + Dil1(mDil,nDil), Dil2(mDil,nDil), Djk1(mDjk,nDjk), Djk2(mDjk,nDjk), Djl1(mDjl,nDjl), Djl2(mDjl,nDjl), & + rFinal(nFinal), din(*), dan(*) +real(kind=wp), intent(out) :: FckTmp(nFT), Scrtch1(nS1), Scrtch2(nS2), Temp(nTemp) +real(kind=wp), intent(inout) :: TwoHam(nTwo), rmoin(nMOIN), buffer(*) +integer(kind=iwp) :: iCar, iCent, iCnt, iGr, ii, iIrrep, ij1, ij2, ij3, ij4, ik1, ik2, ik3, ik4, il1, il2, il3, il4, ip, ipFin, & + jk1, jk2, jk3, jk4, jl1, jl2, jl3, jl4, jOp(6), kl1, kl2, kl3, kl4, nabcd, nao, nijkl +logical(kind=iwp) :: pert(0:7) +real(kind=wp) :: dum1, dum2, dum3, ExFac, Time + +nijkl = iBasi*jBasj*kBask*lBasl +nabcd = iCmp(1)*iCmp(2)*iCmp(3)*iCmp(4) +call Timing(dum1,Time,dum2,dum3) + +ExFac = One + +if (ltri) then + if (.not. new_fock) then + !------------------------------------------------------------* + ! + ! Get the size of the work area that should be contracted + ! + !------------------------------------------------------------* + if (jShell(1) >= jShell(2)) then + ij1 = iBasi + ij2 = jBasj + ij3 = iCmp(1) + ij4 = iCmp(2) + else + ij1 = jBasj + ij2 = iBasi + ij3 = iCmp(2) + ij4 = iCmp(1) + end if + if (jShell(3) >= jShell(4)) then + kl1 = kBask + kl2 = lBasl + kl3 = iCmp(3) + kl4 = iCmp(4) + else + kl1 = lBasl + kl2 = kBask + kl3 = iCmp(4) + kl4 = iCmp(3) + end if + if (jShell(1) >= jShell(3)) then + ik1 = iBasi + ik2 = kBask + ik3 = iCmp(1) + ik4 = iCmp(3) + else + ik1 = kBask + ik2 = iBasi + ik3 = iCmp(3) + ik4 = iCmp(1) + end if + if (jShell(1) >= jShell(4)) then + il1 = iBasi + il2 = lBasl + il3 = iCmp(1) + il4 = iCmp(4) + else + il1 = lBasl + il2 = iBasi + il3 = iCmp(4) + il4 = iCmp(1) + end if + if (jShell(2) >= jShell(3)) then + jk1 = jBasj + jk2 = kBask + jk3 = iCmp(2) + jk4 = iCmp(3) + else + jk1 = kBask + jk2 = jBasj + jk3 = iCmp(3) + jk4 = iCmp(2) + end if + if (jShell(2) >= jShell(4)) then + jl1 = jBasj + jl2 = lBasl + jl3 = iCmp(2) + jl4 = iCmp(4) + else + jl1 = lBasl + jl2 = jBasj + jl3 = iCmp(4) + jl4 = iCmp(2) + end if + + ! Here we go + + nao = iBasi*jBasj*kBask*lBasl*iCmp(1)*iCmp(2)*iCmp(3)*iCmp(4) + call CtlDns(iDCRR,iDCRS,iDCRT,jOp) + end if + + ! Add this contribution to the (Inactive) Fock Matrix + + ! Out from CD : jOp + + do iCent=1,4 + do iCar=1,3 + pert(:) = .false. + + ! To which irreps does this derivative contribute? + + do iIrrep=0,nIrrep-1 + if (indgrd(iCar,iCent,iIrrep) /= 0) pert(iIrrep) = .true. + end do + + if (Indx(iCar,iCent) > 0) then + iGr = Indx(iCar,iCent)-1 + ipFin = 1+iGr*nijkl*nabcd + if (.not. new_fock) then + call MkFck(iAnga,iCmp,Shijij,iShll,iShell,iBasi,jBasj,kBask,lBasl,iAO,iAOst,nop,jop,Dij1,mDij,nDij,ij1,ij2,ij3,ij4,Dkl1, & + mDkl,nDkl,kl1,kl2,kl3,kl4,Dik1,mDik,nDik,ik1,ik2,ik3,ik4,Dil1,mDil,nDil,il1,il2,il3,il4,Djk1,mDjk,nDjk,jk1, & + jk2,jk3,jk4,Djl1,mDjl,nDjl,jl1,jl2,jl3,jl4,rFinal(ipFin),nAO,TwoHam,nTwo,Scrtch2,nS2,FckTmp,nFT,pert, & + iuvwx(iCent),iCent,iCar,indgrd,ipDisp) + if (nMethod == RASSCF) call MkFck(iAnga,iCmp,Shijij,iShll,iShell,iBasi,jBasj,kBask,lBasl,iAO,iAOst,nop,jop,Dij2,mDij, & + nDij,ij1,ij2,ij3,ij4,Dkl2,mDkl,nDkl,kl1,kl2,kl3,kl4,Dik2,mDik,nDik,ik1,ik2,ik3,ik4, & + Dil2,mDil,nDil,il1,il2,il3,il4,Djk2,mDjk,nDjk,jk1,jk2,jk3,jk4,Djl2,mDjl,nDjl,jl1,jl2, & + jl3,jl4,rFinal(ipFin),nAO,TwoHam,nTwo,Scrtch2,nS2,FckTmp,nFT,pert,iuvwx(iCent),iCent, & + iCar,indgrd,ipDisp2) + + else + ip = ipDisp(abs(indgrd(iCar,iCent,0))) + call FckAcc_NoSym(iAnga,iCmpa(1),iCmpa(2),iCmpa(3),iCmpa(4),Shijij,iShll,iShell,nijkl,rFinal(ipFin),TwoHam(ip),dan, & + ndens,iAO,iAOst,iBasi,jBasj,kBask,lBasl,ExFac) + if (nMethod == RASSCF) then + ip = ipDisp2(abs(indgrd(iCar,iCent,0))) + call FckAcc_NoSym(iAnga,iCmpa(1),iCmpa(2),iCmpa(3),iCmpa(4),Shijij,iShll,iShell,nijkl,rFinal(ipFin),TwoHam(ip),din, & + nDens,iAO,iAOst,iBasi,jBasj,kBask,lBasl,ExFac) + end if + end if + + else if (Indx(iCar,iCent) < 0) then + Temp(1:nabcd*nijkl) = Zero + do iCnt=1,4 + iGr = Indx(iCar,iCnt) + if (iGr > 0) then + ipFin = 1+(iGr-1)*nijkl*nabcd + do ii=1,nabcd*nijkl + Temp(ii) = Temp(ii)-rFinal(ipFin-1+ii) + end do + end if + end do + + if (.not. new_fock) then + call MkFck(iAnga,iCmp,Shijij,iShll,iShell,iBasi,jBasj,kBask,lBasl,iAO,iAOst,nop,jop,Dij1,mDij,nDij,ij1,ij2,ij3,ij4,Dkl1, & + mDkl,nDkl,kl1,kl2,kl3,kl4,Dik1,mDik,nDik,ik1,ik2,ik3,ik4,Dil1,mDil,nDil,il1,il2,il3,il4,Djk1,mDjk,nDjk,jk1, & + jk2,jk3,jk4,Djl1,mDjl,nDjl,jl1,jl2,jl3,jl4,Temp,nAO,TwoHam,nTwo,Scrtch2,nS2,FckTmp,nFT,pert,iuvwx(iCent), & + icent,iCar,indgrd,ipDisp) + if (nMethod == RASSCF) call MkFck(iAnga,iCmp,Shijij,iShll,iShell,iBasi,jBasj,kBask,lBasl,iAO,iAOst,nop,jop,Dij2,mDij, & + nDij,ij1,ij2,ij3,ij4,Dkl2,mDkl,nDkl,kl1,kl2,kl3,kl4,Dik2,mDik,nDik,ik1,ik2,ik3,ik4, & + Dil2,mDil,nDil,il1,il2,il3,il4,Djk2,mDjk,nDjk,jk1,jk2,jk3,jk4,Djl2,mDjl,nDjl,jl1,jl2, & + jl3,jl4,Temp,nAO,TwoHam,nTwo,Scrtch2,nS2,FckTmp,nFT,pert,iuvwx(iCent),icent,iCar, & + indgrd,ipDisp2) + + else + ip = ipDisp(abs(indgrd(iCar,iCent,0))) + call FckAcc_NoSym(iAnga,iCmpa(1),iCmpa(2),iCmpa(3),iCmpa(4),Shijij,iShll,iShell,nijkl,Temp,TwoHam(ip),dan,nDens,iAO, & + iAOst,iBasi,jBasj,kBask,lBasl,ExFac) + if (nMethod == RASSCF) then + ip = ipDisp2(abs(indgrd(iCar,iCent,0))) + call FckAcc_NoSym(iAnga,iCmpa(1),iCmpa(2),iCmpa(3),iCmpa(4),Shijij,iShll,iShell,nijkl,Temp,TwoHam(ip),din,nDens,iAO, & + iAOst,iBasi,jBasj,kBask,lBasl,ExFac) + end if + end if + + end if + end do + end do + call Timing(dum1,Time,dum2,dum3) + CPUStat(nFckAcc) = CPUStat(nFckAcc)+Time +end if + +if (n8 .and. (nmethod == RASSCF)) call MakeMO(rFinal,Scrtch1,nTempTot,nFinal,iCmp,iCmpa,iBasi,jBasj,kBask,lBasl,nGr,Indx,moip, & + naco,nop,indgrd,ishll,ishell,rmoin,nMOIN,iuvwx,iaost,Buffer,ianga) + +call Timing(dum1,Time,dum2,dum3) +CPUStat(nMOTrans) = CPUStat(nMOTrans)+Time + +return + +end subroutine ClrBuf diff -Nru openmolcas-22.02/src/mckinley/CMakeLists.txt openmolcas-22.10/src/mckinley/CMakeLists.txt --- openmolcas-22.02/src/mckinley/CMakeLists.txt 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -9,4 +9,114 @@ # LICENSE or in . * #*********************************************************************** +set (sources + acore.F90 + clr2.F90 + clrbuf.F90 + cmbn2dc.F90 + cmbnacb1.F90 + cmbnacb2.F90 + cmbneldot.F90 + cmbnel.F90 + cmbns1_mck.F90 + cmbns2a.F90 + cmbns2b.F90 + cmbns2.F90 + cmbnt1_mck.F90 + cmbnt2.F90 + cnt1el2.F90 + cnt1el.F90 + cnthlf_mck.F90 + cntrct_mck.F90 + coreb.F90 + crsph_mck.F90 + ctldns.F90 + ctrlmo.F90 + dan.F90 + dede_mck.F90 + derctr.F90 + din.F90 + dot1el2.F90 + dot1el.F90 + drvel1.F90 + drvetc.F90 + drvg2.F90 + drvh1_mck.F90 + drvh2.F90 + drvk2_mck.F90 + drvn1_mck.F90 + drvn2.F90 + elgrddot.F90 + elgrd.F90 + elmem.F90 + fckacc_mck.F90 + hssprt.F90 + inputh.F90 + k2loop_mck.F90 + knegrd_mck.F90 + knehss.F90 + knemem_mck.F90 + knemmh.F90 + ltocore.F90 + ltosph.F90 + lu2lu.F90 + m1grd_mck.F90 + m1hss.F90 + m1kernel.F90 + m1mm1.F90 + m1mmh.F90 + main.F90 + makemo.F90 + mckinley_banner.F90 + mckinley.F90 + mckinley_global.F90 + mck_interface.F90 + mkfck.F90 + moacc.F90 + mult_sro.F90 + na2mem.F90 + nagrd_mck.F90 + nahss.F90 + namem_mck.F90 + nammh.F90 + nonatwo.F90 + nucind.F90 + opnfls_mckinley.F90 + ovrgrd_mck.F90 + ovrhss.F90 + ovrmem_mck.F90 + ovrmmh.F90 + pckint_mck.F90 + pckmo2.F90 + pickmo.F90 + prjgrd_mck.F90 + prjhss.F90 + prjmm1.F90 + prjmmh.F90 + psoao0_h.F90 + psoao2.F90 + request_mclr_run.F90 + rtocore.F90 + rtosph.F90 + schint_mck.F90 + screen_mck.F90 + smadna.F90 + sort_mck.F90 + srogrd_mck.F90 + srohss.F90 + sromm1.F90 + srommh.F90 + sttstc.F90 + supermac.F90 + symado_mck2.F90 + symado_mck.F90 + tcrtnc_h.F90 + tnchlf_h.F90 + translation.F90 + twodns.F90 + twoel_mck.F90 + wrdisk.F90 + wrhdsk.F90 +) + include (${PROJECT_SOURCE_DIR}/cmake/prog_template.cmake) diff -Nru openmolcas-22.02/src/mckinley/cmbn2dc.f openmolcas-22.10/src/mckinley/cmbn2dc.f --- openmolcas-22.02/src/mckinley/cmbn2dc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbn2dc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,121 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2000, Per Ake Malmqvist * -************************************************************************ - SUBROUTINE CMBN2DC(RNXYZ,NZETA,LA,LB,ZETA,RKAPPA, - & FINAL,ALPHA,BETA,IFGRAD) -************************************************************************ -* -* OBJECT: COMPUTE THE SECOND DERIVATIVE NON-ADIABATIC COUPLING -* MATRIX ELEMENTS, OF TYPE < D/DX CHI_1 | D/DX CHI_2 > -* WITH DIFFERENTIATION WRT NUCLEAR COORDINATES -* -* AUTHOR: PER AKE MALMQVIST NOV 2000 -* DEPT. OF THEORETICAL CHEMISTRY, -* UNIVERSITY OF LUND, SWEDEN -* FOLLOWING THE PATTERN OF R. LINDH, -* SAME PLACE. -* -************************************************************************ - IMPLICIT REAL*8 (A-H,O-Z) - REAL*8 FINAL(NZETA,(LA+1)*(LA+2)/2,(LB+1)*(LB+2)/2,1), - & ZETA(NZETA), RKAPPA(NZETA), BETA(NZETA), - & RNXYZ(NZETA,3,0:LA+1,0:LB+1), ALPHA(NZETA) - LOGICAL IFGRAD(3) -* STATEMENT FUNCTION FOR CARTESIAN INDEX - IND(IXYZ,IX,IZ) = (IXYZ-IX)*(IXYZ-IX+1)/2 + IZ + 1 -* -C PREFACTOR FOR THE PRIMITIVE OVERLAP MATRIX - DO IZETA=1,NZETA - RKAPPA(IZETA)=RKAPPA(IZETA)*(ZETA(IZETA)**(-1.5D0)) - END DO - -C LOOP STRUCTURE FOR THE CARTESIAN ANGULAR PARTS - DO 10 IXA = 0, LA - IYAMAX=LA-IXA - DO 11 IXB = 0, LB - IYBMAX=LB-IXB - DO 20 IYA = 0, IYAMAX - IZA = LA-IXA-IYA - IPA= IND(LA,IXA,IZA) - DO 21 IYB = 0, IYBMAX - IZB = LB-IXB-IYB - IPB= IND(LB,IXB,IZB) - -* COMBINE 1-DIM PRIMITIVE OVERLAP INTEGRALS - IF (IFGRAD(1)) THEN -C COMPUTE INTEGRALS TYPE - DO IZETA=1,NZETA - DIFFX=4D0*ALPHA(IZETA)*BETA(IZETA)*RNXYZ(IZETA,1,IXA+1,IXB+1) - IF(IXB.GT.0) THEN - DIFFX=DIFFX-2D0*ALPHA(IZETA)*DBLE(IXB)* - > RNXYZ(IZETA,1,IXA+1,IXB-1) - IF(IXA.GT.0) THEN - DIFFX=DIFFX+DBLE(IXA*IXB)*RNXYZ(IZETA,1,IXA-1,IXB-1) - END IF - END IF - IF(IXA.GT.0) THEN - DIFFX=DIFFX-DBLE(2*IXA)*BETA(IZETA)* - > RNXYZ(IZETA,1,IXA-1,IXB+1) - END IF - OVLY=RNXYZ(IZETA,2,IYA,IYB) - OVLZ=RNXYZ(IZETA,3,IZA,IZB) - FINAL(IZETA,IPA,IPB,1)=RKAPPA(IZETA)*DIFFX*OVLY*OVLZ - END DO - END IF - IF (IFGRAD(2)) THEN -C COMPUTE INTEGRALS TYPE - DO IZETA=1,NZETA - DIFFY=4D0*ALPHA(IZETA)*BETA(IZETA)*RNXYZ(IZETA,2,IYA+1,IYB+1) - IF(IYB.GT.0) THEN - DIFFY=DIFFY-2D0*ALPHA(IZETA)*DBLE(IYB)* - > RNXYZ(IZETA,2,IYA+1,IYB-1) - IF(IYA.GT.0) THEN - DIFFY=DIFFY+DBLE(IYA*IYB)*RNXYZ(IZETA,2,IYA-1,IYB-1) - END IF - END IF - IF(IYA.GT.0) THEN - DIFFY=DIFFY-DBLE(2*IYA)*BETA(IZETA)* - > RNXYZ(IZETA,1,IYA-1,IYB+1) - END IF - OVLX=RNXYZ(IZETA,1,IXA,IXB) - OVLZ=RNXYZ(IZETA,3,IZA,IZB) - FINAL(IZETA,IPA,IPB,1)=RKAPPA(IZETA)*OVLX*DIFFY*OVLZ - END DO - END IF - IF (IFGRAD(1)) THEN -C COMPUTE INTEGRALS TYPE - DO IZETA=1,NZETA - DIFFZ=4D0*ALPHA(IZETA)*BETA(IZETA)*RNXYZ(IZETA,1,IZA+1,IZB+1) - IF(IZB.GT.0) THEN - DIFFZ=DIFFZ-2D0*ALPHA(IZETA)*DBLE(IZB)* - > RNXYZ(IZETA,1,IZA+1,IZB-1) - IF(IZA.GT.0) THEN - DIFFZ=DIFFZ+DBLE(IZA*IZB)*RNXYZ(IZETA,1,IZA-1,IZB-1) - END IF - END IF - IF(IZA.GT.0) THEN - DIFFZ=DIFFZ-DBLE(2*IZA)*BETA(IZETA)* - > RNXYZ(IZETA,1,IZA-1,IZB+1) - END IF - OVLX=RNXYZ(IZETA,1,IXA,IXB) - OVLY=RNXYZ(IZETA,2,IYA,IYB) - FINAL(IZETA,IPA,IPB,1)=RKAPPA(IZETA)*OVLX*OVLY*DIFFZ - END DO - END IF - -C END OF LOOP NEST OVER CARTESIAN ANGULAR COMPONENT - 21 CONTINUE - 20 CONTINUE - 11 CONTINUE - 10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mckinley/cmbn2dc.F90 openmolcas-22.10/src/mckinley/cmbn2dc.F90 --- openmolcas-22.02/src/mckinley/cmbn2dc.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbn2dc.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,109 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2000, Per Ake Malmqvist * +!*********************************************************************** + +subroutine CMBN2DC(RNXYZ,NZETA,LA,LB,ZETA,RKAPPA,RFINAL,ALPHA,BETA,IFGRAD) +!*********************************************************************** +! +! OBJECT: COMPUTE THE SECOND DERIVATIVE NON-ADIABATIC COUPLING +! MATRIX ELEMENTS, OF TYPE < D/DX CHI_1 | D/DX CHI_2 > +! WITH DIFFERENTIATION WRT NUCLEAR COORDINATES +! +! AUTHOR: PER AKE MALMQVIST NOV 2000 +! DEPT. OF THEORETICAL CHEMISTRY, +! UNIVERSITY OF LUND, SWEDEN +! FOLLOWING THE PATTERN OF R. LINDH, +! SAME PLACE. +! +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: Two, Four, OneHalf +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: NZETA, LA, LB +real(kind=wp), intent(in) :: RNXYZ(NZETA,3,0:LA+1,0:LB+1), ZETA(NZETA), ALPHA(NZETA), BETA(NZETA) +real(kind=wp), intent(inout) :: RKAPPA(NZETA) +real(kind=wp), intent(out) :: RFINAL(NZETA,nTri_Elem1(LA),nTri_Elem1(LB),1) +logical(kind=iwp), intent(in) :: IFGRAD(3) +integer(kind=iwp) :: IPA, IPB, IXA, IXB, IYA, IYAMAX, IYB, IYBMAX, IZA, IZB, IZETA +real(kind=wp) :: DIFFX, DIFFY, DIFFZ, OVLX, OVLY, OVLZ + +! PREFACTOR FOR THE PRIMITIVE OVERLAP MATRIX +RKAPPA(:) = RKAPPA*(ZETA**(-OneHalf)) + +! LOOP STRUCTURE FOR THE CARTESIAN ANGULAR PARTS +do IXA=0,LA + IYAMAX = LA-IXA + do IXB=0,LB + IYBMAX = LB-IXB + do IYA=0,IYAMAX + IZA = LA-IXA-IYA + IPA = C_Ind(LA,IXA,IZA) + do IYB=0,IYBMAX + IZB = LB-IXB-IYB + IPB = C_Ind(LB,IXB,IZB) + + ! COMBINE 1-DIM PRIMITIVE OVERLAP INTEGRALS + if (IFGRAD(1)) then + ! COMPUTE INTEGRALS TYPE + do IZETA=1,NZETA + DIFFX = Four*ALPHA(IZETA)*BETA(IZETA)*RNXYZ(IZETA,1,IXA+1,IXB+1) + if (IXB > 0) then + DIFFX = DIFFX-Two*ALPHA(IZETA)*real(IXB,kind=wp)*RNXYZ(IZETA,1,IXA+1,IXB-1) + if (IXA > 0) DIFFX = DIFFX+real(IXA*IXB,kind=wp)*RNXYZ(IZETA,1,IXA-1,IXB-1) + end if + if (IXA > 0) DIFFX = DIFFX-real(2*IXA,kind=wp)*BETA(IZETA)*RNXYZ(IZETA,1,IXA-1,IXB+1) + OVLY = RNXYZ(IZETA,2,IYA,IYB) + OVLZ = RNXYZ(IZETA,3,IZA,IZB) + RFINAL(IZETA,IPA,IPB,1) = RKAPPA(IZETA)*DIFFX*OVLY*OVLZ + end do + end if + if (IFGRAD(2)) then + ! COMPUTE INTEGRALS TYPE + do IZETA=1,NZETA + DIFFY = Four*ALPHA(IZETA)*BETA(IZETA)*RNXYZ(IZETA,2,IYA+1,IYB+1) + if (IYB > 0) then + DIFFY = DIFFY-Two*ALPHA(IZETA)*real(IYB,kind=wp)*RNXYZ(IZETA,2,IYA+1,IYB-1) + if (IYA > 0) DIFFY = DIFFY+real(IYA*IYB,kind=wp)*RNXYZ(IZETA,2,IYA-1,IYB-1) + end if + if (IYA > 0) DIFFY = DIFFY-real(2*IYA,kind=wp)*BETA(IZETA)*RNXYZ(IZETA,1,IYA-1,IYB+1) + OVLX = RNXYZ(IZETA,1,IXA,IXB) + OVLZ = RNXYZ(IZETA,3,IZA,IZB) + RFINAL(IZETA,IPA,IPB,1) = RKAPPA(IZETA)*OVLX*DIFFY*OVLZ + end do + end if + if (IFGRAD(3)) then + ! COMPUTE INTEGRALS TYPE + do IZETA=1,NZETA + DIFFZ = Four*ALPHA(IZETA)*BETA(IZETA)*RNXYZ(IZETA,1,IZA+1,IZB+1) + if (IZB > 0) then + DIFFZ = DIFFZ-Two*ALPHA(IZETA)*real(IZB,kind=wp)*RNXYZ(IZETA,1,IZA+1,IZB-1) + if (IZA > 0) DIFFZ = DIFFZ+real(IZA*IZB,kind=wp)*RNXYZ(IZETA,1,IZA-1,IZB-1) + end if + if (IZA > 0) DIFFZ = DIFFZ-real(2*IZA,kind=wp)*BETA(IZETA)*RNXYZ(IZETA,1,IZA-1,IZB+1) + OVLX = RNXYZ(IZETA,1,IXA,IXB) + OVLY = RNXYZ(IZETA,2,IYA,IYB) + RFINAL(IZETA,IPA,IPB,1) = RKAPPA(IZETA)*OVLX*OVLY*DIFFZ + end do + end if + + ! END OF LOOP NEST OVER CARTESIAN ANGULAR COMPONENT + end do + end do + end do +end do + +return + +end subroutine CMBN2DC diff -Nru openmolcas-22.02/src/mckinley/cmbnacb1.f openmolcas-22.10/src/mckinley/cmbnacb1.f --- openmolcas-22.02/src/mckinley/cmbnacb1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbnacb1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,111 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2004, Anders Bernhardsson * -************************************************************************ - Subroutine CmbnACB1(FA1,FB1,Final,Fact,nAlpha,nBeta,C,nC, - & la,lb,iang,ifgrad,tmp,lsro, - & index,mvec,idcar) -******************************************************************************* -* -* Merges the first derivatives of ECP projection/SRO integrals -* for derivatives of components -* -******************************************************************************* -* -* @parameter FA1 The first derivative of Left side , Includes no deriavtive (input) -* @parameter FB1 The first derivative of Right side . Includes no derivative (input) -* @parameter Final Result added up to (out) -* @parameter Fact Factor the reult is multiplied with bef. added up (input) -* @parameter C Coefficients for SRO (input) -* @parameter nAlpha Number of exponents LS (input) -* @parameter nBeta Number of exponents RS (input) -* @parameter nC Number of exponents in SRO (input) -* @parameter la Angular monenta LS (input) -* @parameter lb Angular monenta RS (input) -* @parameter iAng Angular monenta SRO (input) -* @parameter Tmp Working Area nAlpha*nC (SRO case) (scratch) -* @parameter lSRO true for SRO false projection operator (input) -* @paramaeter index array storing index for derivatives in final (out) -* @parameter mvec Number of derivatives calculated (out) -* @parameter idcar cartesiam index for current derivative (input) -* -******************************************************************************* - use Real_Spherical - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "real.fh" -#include "print.fh" -#include "disp.fh" - - Logical ifgrad(3,4),lsro - Real*8 FA1(nAlpha,nC,(la+1)*(la+2)/2,(2*iang+1),*), - & FB1(nC,nBeta,(2*iang+1),(lb+1)*(lb+2)/2,*), - & Final(nAlpha*nbeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,21) - - Real*8 C(*),Tmp(*) - Integer Index(3,4) - - nelem(ixyz) = (ixyz+1)*(ixyz+2)/2 - - nZeta = nAlpha*nBeta - call dcopy_(nZeta*nElem(la)*nElem(lb)*6, - & [Zero],0,Final,1) - Call iCopy(12,[0],0,Index,1) - - mVec = 0 - Do iCent = 1, 2 - If (ifGrad(iDCar,iCent)) Then - mVec = mVec + 1 - Index(iDcar,icent)=mvec -* - If (iCent.eq.1) Then - iFa = 2 - iFb = 1 - Else - iFa = 1 - iFb = 2 - End If -* - Do ib = 1, nElem(lb) - Do ia = 1, nElem(la) - - Do iC = 1, (2*iAng+1) - if (lsro) Then - Call DGEMM_('N','N', - & nAlpha,nC,nC, - & One,FA1(1,1,ia,ic,iFa),nAlpha, - & C,nC, - & Zero,Tmp,nAlpha) - Call DGEMM_('N','N', - & nAlpha,nBeta,nC, - & Fact,Tmp,nAlpha, - & FB1(1,1,ic,ib,iFb),nC, - & One,Final(1,ia,ib,mvec),nAlpha) - else - Call DGEMM_('N','N', - & nAlpha,nBeta,nC, - & Fact,Fa1(1,1,ia,ic,iFa),nAlpha, - & Fb1(1,1,ic,ib,iFb),nC, - & One,Final(1,ia,ib,mvec), - & nAlpha) - Endif - - - - End DO ! iC - End DO ! iA - End DO ! ib - - End If - End Do ! icent - - Return - End diff -Nru openmolcas-22.02/src/mckinley/cmbnacb1.F90 openmolcas-22.10/src/mckinley/cmbnacb1.F90 --- openmolcas-22.02/src/mckinley/cmbnacb1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbnacb1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,91 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2004, Anders Bernhardsson * +!*********************************************************************** + +subroutine CmbnACB1(FA1,FB1,rFinal,Fact,nAlpha,nBeta,C,nC,la,lb,iang,ifgrad,tmp,lsro,indx,mvec,idcar) +!*********************************************************************** +! +! Merges the first derivatives of ECP projection/SRO integrals +! for derivatives of components +! +!*********************************************************************** +! +! @parameter FA1 The first derivative of Left side. Includes no deriavtive (input) +! @parameter FB1 The first derivative of Right side. Includes no derivative (input) +! @parameter rFinal Result added up to (out) +! @parameter Fact Factor the reult is multiplied with bef. added up (input) +! @parameter C Coefficients for SRO (input) +! @parameter nAlpha Number of exponents LS (input) +! @parameter nBeta Number of exponents RS (input) +! @parameter nC Number of exponents in SRO (input) +! @parameter la Angular monenta LS (input) +! @parameter lb Angular monenta RS (input) +! @parameter iAng Angular monenta SRO (input) +! @parameter Tmp Working Area nAlpha*nC (SRO case) (scratch) +! @parameter lSRO true for SRO false projection operator (input) +! @parameter indx Array storing index for derivatives in rFinal (out) +! @parameter mvec Number of derivatives calculated (out) +! @parameter idcar Cartesiam index for current derivative (input) +! +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nAlpha, nBeta, nC, la, lb, iang, idcar +logical(kind=iwp), intent(in) :: ifgrad(3,4), lsro +real(kind=wp), intent(in) :: FA1(nAlpha,nC,nTri_Elem1(la),2*iang+1,2), FB1(nC,nBeta,2*iang+1,nTri_Elem1(lb),2), Fact, & + C(nC,merge(nC,0,lsro)) +real(kind=wp), intent(out) :: rFinal(nAlpha*nBeta,nTri_Elem1(la),nTri_Elem1(lb),6), Tmp(nAlpha,merge(nC,0,lsro)) +integer(kind=iwp), intent(out) :: indx(3,4), mvec +integer(kind=iwp) :: ia, ib, iC, iCent, iFa, iFb + +rFinal(:,:,:,1:6) = Zero +indx(:,:) = 0 + +mVec = 0 +do iCent=1,2 + if (ifGrad(iDCar,iCent)) then + mVec = mVec+1 + indx(iDcar,icent) = mvec + + if (iCent == 1) then + iFa = 2 + iFb = 1 + else + iFa = 1 + iFb = 2 + end if + + do ib=1,nTri_Elem1(lb) + do ia=1,nTri_Elem1(la) + + do iC=1,2*iAng+1 + if (lsro) then + call mult_sro(FA1(:,:,ia,ic,iFa),nAlpha,C,nC,FB1(:,:,ic,ib,iFb),nBeta,Fact,rFinal(:,ia,ib,mvec),Tmp) + else + call DGEMM_('N','N',nAlpha,nBeta,nC,Fact,FA1(:,:,ia,ic,iFa),nAlpha,FB1(:,:,ic,ib,iFb),nC,One,rFinal(:,ia,ib,mvec), & + nAlpha) + end if + + end do ! iC + end do ! iA + end do ! ib + + end if +end do ! icent + +return + +end subroutine CmbnACB1 diff -Nru openmolcas-22.02/src/mckinley/cmbnacb2.f openmolcas-22.10/src/mckinley/cmbnacb2.f --- openmolcas-22.02/src/mckinley/cmbnacb2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbnacb2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,156 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2004, Anders Bernhardsson * -************************************************************************ - Subroutine CmbnACB2(Fa1,Fa2,Fb1,Fb2,Final,Fact,nalpha,nbeta, - & C,nC,la,lb,iang,jfhess,Tmp,lsro) -******************************************************************************* -* -* Merges the second derivatives of ECP projection/SRO integrals -* for derivatives of components -* -******************************************************************************* -* -* @parameter FA1 The first derivative of Left side , Includes no deriavtive -* @parameter FA2 The second derivative of Left side -* @parameter FB1 The first derivative of Right side . Includes no derivative -* @parameter FB2 The second derivative of Right side -* @parameter Final Result added up to (out) -* @parameter Fact Factor the reult is multiplied with bef. added up -* @parameter C Coefficients for SRO -* @parameter nAlpha Number of exponents LS -* @parameter nBeta Number of exponents RS -* @parameter nC Number of exponents in SRO -* @parameter la Angular monenta LS -* @parameter lb Angular monenta RS -* @parameter iAng Angular monenta SRO -* @parameter nBeta Number of exponents RS -* @parameter nC Number of exponents in SRO -* @parameter Tmp Working Area nAlpha*nC (SRO case) -* @parameter lSRO true for SRO false projection operator -* -******************************************************************************* - Implicit Real*8(a-h,o-z) -#include "real.fh" - - Logical jfhess(4,3,4,3),lsro - - Real*8 FA1(nAlpha,nC,(la+1)*(la+2)/2,(2*iang+1),*), - & FA2(nAlpha,nC,(la+1)*(la+2)/2,(2*iang+1),*), - & FB1(nC,nBeta,(2*iang+1),(lb+1)*(lb+2)/2,*), - & FB2(nC,nBeta,(2*iang+1),(lb+1)*(lb+2)/2,*), - & Tmp(*),c(*), - & Final(nAlpha*nbeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,21) -* * -************************************************************************ -* * - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - iTri(i,j) = Max(i,j)*(Max(i,j)-1)/2 + Min(i,j) -* * -************************************************************************ -* * -* Merge integrals with one deriavtive on each center - - Do iCar = 1, 3 - Do jCar = 1, 3 - mvec=itri(iCar+3,jcar) - If (jfHess(2,iCar,1,jcar)) Then - Do ib = 1, nElem(lb) - Do ia = 1, nElem(la) - Do iC = 1, (2*iAng+1) - - if (lsro) then - call mult_sro(FA1(1,1,ia,ic,icar+1),nAlpha, - & C,nC, - & FB1(1,1,ic,ib,jcar+1),nBeta, - & Fact,Final(1,ia,ib,mVec), - & Tmp) - else - Call DGEMM_('N','N', - & nAlpha,nBeta,nC, - & Fact,FA1(1,1,ia,ic,icar+1),nAlpha, - & FB1(1,1,ic,ib,jcar+1),nC, - & One,Final(1,ia,ib,mVec),nAlpha) - endif - End do - End do - End do - End If - End do - End do -* * -************************************************************************ -* * -* Merge integrals with both derivative on center A - Do iCar = 1, 3 - Do jCar = 1, icar - mvec=itri(iCar,jcar) - If (jfHess(1,iCar,1,jcar)) Then - Do ib = 1, nElem(lb) - Do ia = 1, nElem(la) - Do iC = 1, (2*iAng+1) - if (lsro) then - call mult_sro(FA2(1,1,ia,ic,mvec),nAlpha, - & C,nC, - & FB1(1,1,ic,ib,1),nBeta, - & Fact,Final(1,ia,ib,mVec), - & Tmp) - else - Call DGEMM_('N','N', - & nAlpha,nBeta,nC, - & Fact,FA2(1,1,ia,ic,mvec),nAlpha, - & FB1(1,1,ic,ib,1),nC, - & One,Final(1,ia,ib,mVec),nAlpha) - endif - End do - End do - End do - End If - End do - End do -* * -************************************************************************ -* * -* Merge integrals with both derivative on center B - Do iCar = 1, 3 - Do jCar = 1, icar - mvec=itri(3+icar,3+jcar) - mvecB=itri(icar,jcar) - If (jfHess(2,iCar,2,jcar)) Then - - Do ib = 1, nElem(lb) - Do ia = 1, nElem(la) -* - Do iC = 1, (2*iAng+1) - if (lsro) then - call mult_sro(FA1(1,1,ia,ic,1),nAlpha, - & C,nC, - & FB2(1,1,ic,ib,mvecb),nBeta, - & Fact,Final(1,ia,ib,mVec), - & Tmp) - else - Call DGEMM_('N','N', - & nAlpha,nBeta,nC, - & Fact,FA1(1,1,ia,ic,1),nAlpha, - & FB2(1,1,ic,ib,mvecb),nC, - & One,Final(1,ia,ib,mVec),nAlpha) - endif - End do - End do - End do - End If - End do - End do -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/mckinley/cmbnacb2.F90 openmolcas-22.10/src/mckinley/cmbnacb2.F90 --- openmolcas-22.02/src/mckinley/cmbnacb2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbnacb2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,136 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2004, Anders Bernhardsson * +!*********************************************************************** + +subroutine CmbnACB2(FA1,FA2,FB1,FB2,rFinal,Fact,nAlpha,nBeta,C,nC,la,lb,iang,jfhess,Tmp,lsro) +!****************************************************************************** +! +! Merges the second derivatives of ECP projection/SRO integrals +! for derivatives of components +! +!****************************************************************************** +! +! @parameter FA1 The first derivative of Left side. Includes no derivative +! @parameter FA2 The second derivative of Left side +! @parameter FB1 The first derivative of Right side. Includes no derivative +! @parameter FB2 The second derivative of Right side +! @parameter rFinal Result added up to (out) +! @parameter Fact Factor the result is multiplied with before added up +! @parameter C Coefficients for SRO +! @parameter nAlpha Number of exponents LS +! @parameter nBeta Number of exponents RS +! @parameter nC Number of exponents in SRO +! @parameter la Angular monenta LS +! @parameter lb Angular monenta RS +! @parameter iAng Angular monenta SRO +! @parameter nBeta Number of exponents RS +! @parameter nC Number of exponents in SRO +! @parameter Tmp Working Area nAlpha*nC (SRO case) +! @parameter lSRO true for SRO false projection operator +! +!****************************************************************************** + +use Index_Functions, only: iTri, nTri_Elem1 +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nAlpha, nBeta, nC, la, lb, iang +logical(kind=iwp), intent(in) :: jfHess(4,3,4,3), lsro +real(kind=wp), intent(in) :: FA1(nAlpha,nC,nTri_Elem1(la),2*iang+1,4), FA2(nAlpha,nC,nTri_Elem1(la),2*iang+1,6), & + FB1(nC,nBeta,2*iang+1,nTri_Elem1(lb),4), FB2(nC,nBeta,2*iang+1,nTri_Elem1(lb),6), Fact, & + C(nC,merge(nC,0,lsro)) +real(kind=wp), intent(inout) :: rFinal(nAlpha*nBeta,nTri_Elem1(la),nTri_Elem1(lb),21) +real(kind=wp), intent(out) :: Tmp(nAlpha,merge(nC,0,lsro)) +integer(kind=iwp) :: ia, ib, iC, iCar, jCar, mVec, mVecB + +! * +!*********************************************************************** +! * +! Merge integrals with one derivative on each center + +do iCar=1,3 + do jCar=1,3 + mVec = itri(iCar+3,jCar) + if (jfHess(2,iCar,1,jCar)) then + do ib=1,nTri_Elem1(lb) + do ia=1,nTri_Elem1(la) + do iC=1,2*iAng+1 + + if (lsro) then + call mult_sro(FA1(:,:,ia,ic,iCar+1),nAlpha,C,nC,FB1(:,:,ic,ib,jCar+1),nBeta,Fact,rFinal(:,ia,ib,mVec),Tmp) + else + call DGEMM_('N','N',nAlpha,nBeta,nC,Fact,FA1(:,:,ia,ic,iCar+1),nAlpha,FB1(:,:,ic,ib,jCar+1),nC,One, & + rFinal(:,ia,ib,mVec),nAlpha) + end if + end do + end do + end do + end if + end do +end do +! * +!*********************************************************************** +! * +! Merge integrals with both derivative on center A +do iCar=1,3 + do jCar=1,iCar + mVec = itri(iCar,jCar) + if (jfHess(1,iCar,1,jCar)) then + do ib=1,nTri_Elem1(lb) + do ia=1,nTri_Elem1(la) + do iC=1,2*iAng+1 + if (lsro) then + call mult_sro(FA2(:,:,ia,ic,mVec),nAlpha,C,nC,FB1(:,:,ic,ib,1),nBeta,Fact,rFinal(:,ia,ib,mVec),Tmp) + else + call DGEMM_('N','N',nAlpha,nBeta,nC,Fact,FA2(:,:,ia,ic,mVec),nAlpha,FB1(:,:,ic,ib,1),nC,One,rFinal(:,ia,ib,mVec), & + nAlpha) + end if + end do + end do + end do + end if + end do +end do +! * +!*********************************************************************** +! * +! Merge integrals with both derivative on center B +do iCar=1,3 + do jCar=1,iCar + mVec = itri(3+iCar,3+jCar) + mVecB = itri(iCar,jCar) + if (jfHess(2,iCar,2,jCar)) then + + do ib=1,nTri_Elem1(lb) + do ia=1,nTri_Elem1(la) + + do iC=1,2*iAng+1 + if (lsro) then + call mult_sro(FA1(:,:,ia,ic,1),nAlpha,C,nC,FB2(:,:,ic,ib,mVecB),nBeta,Fact,rFinal(:,ia,ib,mVec),Tmp) + else + call DGEMM_('N','N',nAlpha,nBeta,nC,Fact,FA1(:,:,ia,ic,1),nAlpha,FB2(:,:,ic,ib,mVecB),nC,One,rFinal(:,ia,ib,mVec), & + nAlpha) + end if + end do + end do + end do + end if + end do +end do +! * +!*********************************************************************** +! * + +return + +end subroutine CmbnACB2 diff -Nru openmolcas-22.02/src/mckinley/cmbneldot.f openmolcas-22.10/src/mckinley/cmbneldot.f --- openmolcas-22.02/src/mckinley/cmbneldot.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbneldot.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,280 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991,1992,1995, Roland Lindh * -* 1997, Anders Bernhardsson * -************************************************************************ - SubRoutine CmbnEldot - & (Rnxyz,nZeta,la,lb,lr,Zeta,rKappa,Final,nComp, - & Fact,Temp,Alpha,Beta,DAO, - & iStb,jStb,nOp,rout,indgrd) -************************************************************************ -* * -* Object: to compute gradient integrals for SC Reaction Fields * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* Modified for reaction field calculations July '92 * -* Modified for gradient calculations May '95 * -* Modified for trans. prob. calculations Oct '97 * -* by Anders Bernhardsson * -************************************************************************ - use Symmetry_Info, only: nIrrep, iChTbl, iChBas - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Integer nOp(2),indgrd(2,3,3,0:7) - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nComp,6), - & Zeta(nZeta), rKappa(nZeta), Fact(nZeta), Temp(nZeta), - & Rnxyz(nZeta,3,0:la+1,0:lb+1,0:lr), - & DAO(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2), - & Alpha(nZeta), Beta(nZeta),rout(*) -* -* Statement function for Cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 - iOff(ixyz) = ixyz*(ixyz+1)*(ixyz+2)/6 -* -* - tTwo=Two -* - Do 130 iZeta = 1, nZeta - Fact(iZeta) = rKappa(iZeta) * Zeta(iZeta)**(-Three/Two) -130 Continue -* -*---- Loop over angular components of the basis set -* - Do 10 ixa = 0, la - iyaMax=la-ixa - Do 11 ixb = 0, lb - iybMax=lb-ixb - Do 20 iya = 0, iyaMax - iza = la-ixa-iya - ipa= Ind(la,ixa,iza) - Do 21 iyb = 0, iybMax - izb = lb-ixb-iyb - ipb= Ind(lb,ixb,izb) -* -* Combine multipole moment integrals -* - Do ix = 0, lr - Do iy = 0, lr-ix - If (ixa.gt.0) Then - xa = -ixa - Do iZeta = 1, nZeta - Temp(iZeta) = Fact(iZeta) * - & (tTwo*Alpha(iZeta) * - & Rnxyz(iZeta,1,ixa+1,ixb,ix) + - & xa*Rnxyz(iZeta,1,ixa-1,ixb,ix)) * - & Rnxyz(iZeta,2,iya,iyb,iy) - End Do - Else - Do iZeta = 1, nZeta - Temp(iZeta) = Fact(iZeta) * - & tTwo*Alpha(iZeta) * - & Rnxyz(iZeta,1,ixa+1,ixb,ix) * - & Rnxyz(iZeta,2,iya,iyb,iy) - End Do - End If -* - Do ir = ix+iy, lr - iz = ir-ix-iy - iComp=Ind(ir,ix,iz)+iOff(ir) - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,iComp,1) = Temp(iZeta)* - & Rnxyz(iZeta,3,iza,izb,iz) - End Do - End Do - End Do - End Do - Do ix = 0, lr - Do iy = 0, lr-ix - If (ixb.gt.0) Then - xb = -ixb - Do iZeta = 1, nZeta - Temp(iZeta) = Fact(iZeta) * - & (tTwo*Beta(iZeta) * - & Rnxyz(iZeta,1,ixa,ixb+1,ix) + - & xb*Rnxyz(iZeta,1,ixa,ixb-1,ix)) * - & Rnxyz(iZeta,2,iya,iyb,iy) - End Do - Else - Do iZeta = 1, nZeta - Temp(iZeta) = Fact(iZeta) * - & tTwo*Beta(iZeta) * - & Rnxyz(iZeta,1,ixa,ixb+1,ix) * - & Rnxyz(iZeta,2,iya,iyb,iy) - End Do - End If -* - Do ir = ix+iy, lr - iz = ir-ix-iy - iComp=Ind(ir,ix,iz)+iOff(ir) - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,iComp,4) = Temp(iZeta)* - & Rnxyz(iZeta,3,iza,izb,iz) - End Do - End Do - End Do - End Do - Do ix = 0, lr - Do iy = 0, lr-ix - If (iya.gt.0) Then - ya = -iya - Do iZeta = 1, nZeta - Temp(iZeta) = Fact(iZeta) * - & Rnxyz(iZeta,1,ixa,ixb,ix) * - & (tTwo*Alpha(iZeta) * - & Rnxyz(iZeta,2,iya+1,iyb,iy) + - & ya*Rnxyz(iZeta,2,iya-1,iyb,iy)) - End Do - Else - Do iZeta = 1, nZeta - Temp(iZeta) = Fact(iZeta) * - & Rnxyz(iZeta,1,ixa,ixb,ix) * - & tTwo*Alpha(iZeta) * - & Rnxyz(iZeta,2,iya+1,iyb,iy) - End Do - End If -* - Do ir = ix+iy, lr - iz = ir-ix-iy - iComp=Ind(ir,ix,iz)+iOff(ir) - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,iComp,2) = Temp(iZeta)* - & Rnxyz(iZeta,3,iza,izb,iz) - End Do - End Do - End Do - End Do - Do ix = 0, lr - Do iy = 0, lr-ix - If (iyb.gt.0) Then - yb = -iyb - Do iZeta = 1, nZeta - Temp(iZeta) = Fact(iZeta) * - & Rnxyz(iZeta,1,ixa,ixb,ix) * - & (tTwo*Beta(iZeta) * - & Rnxyz(iZeta,2,iya,iyb+1,iy) + - & yb*Rnxyz(iZeta,2,iya,iyb-1,iy)) - End Do - Else - Do iZeta = 1, nZeta - Temp(iZeta) = Fact(iZeta) * - & Rnxyz(iZeta,1,ixa,ixb,ix) * - & tTwo*Beta(iZeta) * - & Rnxyz(iZeta,2,iya,iyb+1,iy) - End Do - End If -* - Do ir = ix+iy, lr - iz = ir-ix-iy - iComp=Ind(ir,ix,iz)+iOff(ir) - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,iComp,5) = Temp(iZeta)* - & Rnxyz(iZeta,3,iza,izb,iz) - End Do - End Do - End Do - End Do - Do ix = 0, lr - Do iy = 0, lr-ix - Do iZeta = 1, nZeta - Temp(iZeta) = Fact(iZeta) * - & Rnxyz(iZeta,1,ixa,ixb,ix)* - & Rnxyz(iZeta,2,iya,iyb,iy) - End Do -* - Do ir = ix+iy, lr - iz = ir-ix-iy - iComp=Ind(ir,ix,iz)+iOff(ir) - If (iza.gt.0) Then - za = -iza - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,iComp,3)= Temp(iZeta)* - & (tTwo*Alpha(iZeta) * - & Rnxyz(iZeta,3,iza+1,izb,iz) + - & za*Rnxyz(iZeta,3,iza-1,izb,iz)) - End Do - Else - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,iComp,3)= Temp(iZeta)* - & tTwo*Alpha(iZeta) * - & Rnxyz(iZeta,3,iza+1,izb,iz) - End Do - End If - End Do - End Do - End Do - Do ix = 0, lr - Do iy = 0, lr-ix - Do iZeta = 1, nZeta - Temp(iZeta) = Fact(iZeta) * - & Rnxyz(iZeta,1,ixa,ixb,ix)* - & Rnxyz(iZeta,2,iya,iyb,iy) - End Do -* - Do ir = ix+iy, lr - iz = ir-ix-iy - iComp=Ind(ir,ix,iz)+iOff(ir) - If (izb.gt.0) Then - zb = -izb - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,iComp,6)= Temp(iZeta)* - & (tTwo* Beta(iZeta) * - & Rnxyz(iZeta,3,iza,izb+1,iz) + - & zb*Rnxyz(iZeta,3,iza,izb-1,iz)) - End Do - Else - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,iComp,6)= Temp(iZeta)* - & tTwo* Beta(iZeta) * - & Rnxyz(iZeta,3,iza,izb+1,iz) - End Do - End If - End Do - End Do - End Do -* - 21 Continue - 20 Continue - 11 Continue - 10 Continue -* - nDAO = nZeta * (la+1)*(la+2)/2 * (lb+1)*(lb+2)/2 - Do iIrrep=0,nIrrep-1 - Do iCnt=1,2 - Do iCar=1,3 - Do jCar=1,3 - icomp=jcar+1 - If (iCnt.eq.1) Then - i1 = iCar - ps=DBLE(iChTbl(iIrrep,nOp(1))) - ps=ps*DBLE(iPrmt( nOp(1),iChBas(1+iCar))) - Fct = DBLE(iStb)/DBLE(nIrrep) - Else - i1 = iCar + 3 - ps=DBLE(iChTbl(iIrrep,nOp(2))) - ps = ps*DBLE( iPrmt( nOp(2), iChBas(1+iCar) ) ) - Fct = ps * DBLE(jStb)/DBLE(nIrrep) - End If - - If (IndGrd(iCnt,iCar,jCar,iIrrep).ne.0) Then - ihess=indgrd(icnt,icar,jcar,iirrep) - rtemp=DDot_(nDAO,DAO,1,Final(1,1,1,icomp,i1),1) - rout(iHess) = rOut(iHess) + Fct*rtemp - End If - - End Do - End Do - End Do - End Do - Return - End diff -Nru openmolcas-22.02/src/mckinley/cmbneldot.F90 openmolcas-22.10/src/mckinley/cmbneldot.F90 --- openmolcas-22.02/src/mckinley/cmbneldot.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbneldot.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,195 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991,1992,1995, Roland Lindh * +! 1997, Anders Bernhardsson * +!*********************************************************************** + +subroutine CmbnEldot(Rnxyz,nZeta,la,lb,lr,Zeta,rKappa,rFinal,nComp,Fact,Temp,Alpha,Beta,DAO,iStb,jStb,nOp,rOut,indgrd) +!*********************************************************************** +! * +! Object: to compute gradient integrals for SC Reaction Fields * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! Modified for reaction field calculations July '92 * +! Modified for gradient calculations May '95 * +! Modified for trans. prob. calculations Oct '97 * +! by Anders Bernhardsson * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri3_Elem, nTri_Elem1 +use Symmetry_Info, only: iChBas, iChTbl, nIrrep +use Constants, only: Two, OneHalf +use Definitions, only: wp, iwp, r8 + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb, lr, nComp, iStb, jStb, nOp(2), indgrd(2,3,3,0:7) +real(kind=wp), intent(in) :: Rnxyz(nZeta,3,0:la+1,0:lb+1,0:lr), Zeta(nZeta), rKappa(nZeta), Alpha(nZeta), Beta(nZeta), & + DAO(nZeta,nTri_Elem1(la),nTri_Elem1(lb)) +real(kind=wp), intent(out) :: rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),nComp,6), Fact(nZeta), Temp(nZeta) +real(kind=wp), intent(inout) :: rOut(*) +integer(kind=iwp) :: i1, iCar, iCnt, iComp, ihess, iIrrep, ipa, ipb, ir, ix, ixa, ixb, iy, iya, iyaMax, iyb, iybMax, iz, iza, izb, & + jCar, nDAO +real(kind=wp) :: Fct, ps, rtemp, xa, xb, ya, yb, za, zb +integer(kind=iwp), external :: iPrmt +real(kind=r8), external :: DDot_ + +Fact(:) = rKappa*Zeta**(-OneHalf) + +! Loop over angular components of the basis set + +do ixa=0,la + iyaMax = la-ixa + do ixb=0,lb + iybMax = lb-ixb + do iya=0,iyaMax + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + do iyb=0,iybMax + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + + ! Combine multipole moment integrals + + do ix=0,lr + do iy=0,lr-ix + if (ixa > 0) then + xa = -real(ixa,kind=wp) + Temp(:) = Fact(:)*(Two*Alpha(:)*Rnxyz(:,1,ixa+1,ixb,ix)+xa*Rnxyz(:,1,ixa-1,ixb,ix))*Rnxyz(:,2,iya,iyb,iy) + else + Temp(:) = Fact(:)*Two*Alpha(:)*Rnxyz(:,1,ixa+1,ixb,ix)*Rnxyz(:,2,iya,iyb,iy) + end if + + do ir=ix+iy,lr + iz = ir-ix-iy + iComp = C_Ind(ir,ix,iz)+nTri3_Elem(ir) + rFinal(:,ipa,ipb,iComp,1) = Temp(:)*Rnxyz(:,3,iza,izb,iz) + end do + end do + end do + do ix=0,lr + do iy=0,lr-ix + if (ixb > 0) then + xb = -real(ixb,kind=wp) + Temp(:) = Fact(:)*(Two*Beta(:)*Rnxyz(:,1,ixa,ixb+1,ix)+xb*Rnxyz(:,1,ixa,ixb-1,ix))*Rnxyz(:,2,iya,iyb,iy) + else + Temp(:) = Fact(:)*Two*Beta(:)*Rnxyz(:,1,ixa,ixb+1,ix)*Rnxyz(:,2,iya,iyb,iy) + end if + + do ir=ix+iy,lr + iz = ir-ix-iy + iComp = C_Ind(ir,ix,iz)+nTri3_Elem(ir) + rFinal(:,ipa,ipb,iComp,4) = Temp(:)*Rnxyz(:,3,iza,izb,iz) + end do + end do + end do + do ix=0,lr + do iy=0,lr-ix + if (iya > 0) then + ya = -real(iya,kind=wp) + Temp(:) = Fact(:)*Rnxyz(:,1,ixa,ixb,ix)*(Two*Alpha(:)*Rnxyz(:,2,iya+1,iyb,iy)+ya*Rnxyz(:,2,iya-1,iyb,iy)) + else + Temp(:) = Fact(:)*Rnxyz(:,1,ixa,ixb,ix)*Two*Alpha(:)*Rnxyz(:,2,iya+1,iyb,iy) + end if + + do ir=ix+iy,lr + iz = ir-ix-iy + iComp = C_Ind(ir,ix,iz)+nTri3_Elem(ir) + rFinal(:,ipa,ipb,iComp,2) = Temp(:)*Rnxyz(:,3,iza,izb,iz) + end do + end do + end do + do ix=0,lr + do iy=0,lr-ix + if (iyb > 0) then + yb = -real(iyb,kind=wp) + Temp(:) = Fact(:)*Rnxyz(:,1,ixa,ixb,ix)*(Two*Beta(:)*Rnxyz(:,2,iya,iyb+1,iy)+yb*Rnxyz(:,2,iya,iyb-1,iy)) + else + Temp(:) = Fact(:)*Rnxyz(:,1,ixa,ixb,ix)*Two*Beta(:)*Rnxyz(:,2,iya,iyb+1,iy) + end if + + do ir=ix+iy,lr + iz = ir-ix-iy + iComp = C_Ind(ir,ix,iz)+nTri3_Elem(ir) + rFinal(:,ipa,ipb,iComp,5) = Temp(:)*Rnxyz(:,3,iza,izb,iz) + end do + end do + end do + do ix=0,lr + do iy=0,lr-ix + Temp(:) = Fact(:)*Rnxyz(:,1,ixa,ixb,ix)*Rnxyz(:,2,iya,iyb,iy) + + do ir=ix+iy,lr + iz = ir-ix-iy + iComp = C_Ind(ir,ix,iz)+nTri3_Elem(ir) + if (iza > 0) then + za = -real(iza,kind=wp) + rFinal(:,ipa,ipb,iComp,3) = Temp(:)*(Two*Alpha(:)*Rnxyz(:,3,iza+1,izb,iz)+za*Rnxyz(:,3,iza-1,izb,iz)) + else + rFinal(:,ipa,ipb,iComp,3) = Temp(:)*Two*Alpha(:)*Rnxyz(:,3,iza+1,izb,iz) + end if + end do + end do + end do + do ix=0,lr + do iy=0,lr-ix + Temp(:) = Fact(:)*Rnxyz(:,1,ixa,ixb,ix)*Rnxyz(:,2,iya,iyb,iy) + + do ir=ix+iy,lr + iz = ir-ix-iy + iComp = C_Ind(ir,ix,iz)+nTri3_Elem(ir) + if (izb > 0) then + zb = -real(izb,kind=wp) + rFinal(:,ipa,ipb,iComp,6) = Temp(:)*(Two*Beta(:)*Rnxyz(:,3,iza,izb+1,iz)+zb*Rnxyz(:,3,iza,izb-1,iz)) + else + rFinal(:,ipa,ipb,iComp,6) = Temp(:)*Two*Beta(:)*Rnxyz(:,3,iza,izb+1,iz) + end if + end do + end do + end do + + end do + end do + end do +end do + +nDAO = nZeta*nTri_Elem1(la)*nTri_Elem1(lb) +do iIrrep=0,nIrrep-1 + do iCnt=1,2 + do iCar=1,3 + do jCar=1,3 + icomp = jcar+1 + if (iCnt == 1) then + i1 = iCar + ps = real(iChTbl(iIrrep,nOp(1)),kind=wp) + ps = ps*real(iPrmt(nOp(1),iChBas(1+iCar)),kind=wp) + Fct = real(iStb,kind=wp)/real(nIrrep,kind=wp) + else + i1 = iCar+3 + ps = real(iChTbl(iIrrep,nOp(2)),kind=wp) + ps = ps*real(iPrmt(nOp(2),iChBas(1+iCar)),kind=wp) + Fct = ps*real(jStb,kind=wp)/real(nIrrep,kind=wp) + end if + + if (IndGrd(iCnt,iCar,jCar,iIrrep) /= 0) then + ihess = indgrd(icnt,icar,jcar,iirrep) + rtemp = DDot_(nDAO,DAO,1,rFinal(:,:,:,icomp,i1),1) + rOut(iHess) = rOut(iHess)+Fct*rtemp + end if + + end do + end do + end do +end do + +return + +end subroutine CmbnEldot diff -Nru openmolcas-22.02/src/mckinley/cmbnel.f openmolcas-22.10/src/mckinley/cmbnel.f --- openmolcas-22.02/src/mckinley/cmbnel.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbnel.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,281 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991,1992,1995, Roland Lindh * -* 1997, Anders Bernhardsson * -************************************************************************ - SubRoutine CmbnEl(Rnxyz,nZeta,la,lb,lr,Zeta,rKappa,Final,nComp, - & Fact,Temp,Alpha,Beta, - & iStb,jStb,nOp,ifgrad,kcar) -************************************************************************ -* * -* Object: to compute gradient integrals for SC Reaction Fields * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* Modified for reaction field calculations July '92 * -* Modified for gradient calculations May '95 * -* Modified for trans. prob. calculations Oct '97 * -* by Anders Bernhardsson * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Integer nOp(2) - Logical Ifgrad(3,2) - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,2), - & Zeta(nZeta), rKappa(nZeta), Fact(nZeta), Temp(nZeta), - & Rnxyz(nZeta,3,0:la+1,0:lb+1,0:lr), - & Alpha(nZeta), Beta(nZeta) -* -* Statement function for Cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 - iOff(ixyz) = ixyz*(ixyz+1)*(ixyz+2)/6 -* -* - tTwo=Two -* - Do 130 iZeta = 1, nZeta - Fact(iZeta) = rKappa(iZeta) * Zeta(iZeta)**(-Three/Two) -130 Continue -* -*---- Loop over angular components of the basis set -* - Do 10 ixa = 0, la - iyaMax=la-ixa - Do 11 ixb = 0, lb - iybMax=lb-ixb - Do 20 iya = 0, iyaMax - iza = la-ixa-iya - ipa= Ind(la,ixa,iza) - Do 21 iyb = 0, iybMax - izb = lb-ixb-iyb - ipb= Ind(lb,ixb,izb) -* -* Combine multipole moment integrals -* - If (ifgrad(1,1)) Then - Do ix = 0, lr - Do iy = 0, lr-ix - If (ixa.gt.0) Then - xa = -ixa - Do iZeta = 1, nZeta - Temp(iZeta) = Fact(iZeta) * - & (tTwo*Alpha(iZeta) * - & Rnxyz(iZeta,1,ixa+1,ixb,ix) + - & xa*Rnxyz(iZeta,1,ixa-1,ixb,ix)) * - & Rnxyz(iZeta,2,iya,iyb,iy) - End Do - Else - Do iZeta = 1, nZeta - Temp(iZeta) = Fact(iZeta) * - & tTwo*Alpha(iZeta) * - & Rnxyz(iZeta,1,ixa+1,ixb,ix) * - & Rnxyz(iZeta,2,iya,iyb,iy) - End Do - End If -* - Do ir = ix+iy, lr - iz = ir-ix-iy - iComp=Ind(ir,ix,iz)+iOff(ir)-1 - If (iComp.eq.kcar) Then - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = Temp(iZeta)* - & Rnxyz(iZeta,3,iza,izb,iz) - End Do - End If - End Do - End Do - End Do - End If - If (ifgrad(1,2)) Then - Do ix = 0, lr - Do iy = 0, lr-ix - If (ixb.gt.0) Then - xb = -ixb - Do iZeta = 1, nZeta - Temp(iZeta) = Fact(iZeta) * - & (tTwo*Beta(iZeta) * - & Rnxyz(iZeta,1,ixa,ixb+1,ix) + - & xb*Rnxyz(iZeta,1,ixa,ixb-1,ix)) * - & Rnxyz(iZeta,2,iya,iyb,iy) - End Do - Else - Do iZeta = 1, nZeta - Temp(iZeta) = Fact(iZeta) * - & tTwo*Beta(iZeta) * - & Rnxyz(iZeta,1,ixa,ixb+1,ix) * - & Rnxyz(iZeta,2,iya,iyb,iy) - End Do - End If -* - Do ir = ix+iy, lr - iz = ir-ix-iy - iComp=Ind(ir,ix,iz)+iOff(ir)-1 - If (iComp.eq.kcar) Then - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,2) = Temp(iZeta)* - & Rnxyz(iZeta,3,iza,izb,iz) - End Do - End If - End Do - End Do - End Do - End If - If (ifgrad(2,1)) Then - Do ix = 0, lr - Do iy = 0, lr-ix - If (iya.gt.0) Then - ya = -iya - Do iZeta = 1, nZeta - Temp(iZeta) = Fact(iZeta) * - & Rnxyz(iZeta,1,ixa,ixb,ix) * - & (tTwo*Alpha(iZeta) * - & Rnxyz(iZeta,2,iya+1,iyb,iy) + - & ya*Rnxyz(iZeta,2,iya-1,iyb,iy)) - End Do - Else - Do iZeta = 1, nZeta - Temp(iZeta) = Fact(iZeta) * - & Rnxyz(iZeta,1,ixa,ixb,ix) * - & tTwo*Alpha(iZeta) * - & Rnxyz(iZeta,2,iya+1,iyb,iy) - End Do - End If -* - Do ir = ix+iy, lr - iz = ir-ix-iy - iComp=Ind(ir,ix,iz)+iOff(ir)-1 - If (iComp.eq.kcar) Then - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = Temp(iZeta)* - & Rnxyz(iZeta,3,iza,izb,iz) - End Do - End If - End Do - End Do - End Do - end if - If (ifgrad(2,2)) Then - Do ix = 0, lr - Do iy = 0, lr-ix - If (iyb.gt.0) Then - yb = -iyb - Do iZeta = 1, nZeta - Temp(iZeta) = Fact(iZeta) * - & Rnxyz(iZeta,1,ixa,ixb,ix) * - & (tTwo*Beta(iZeta) * - & Rnxyz(iZeta,2,iya,iyb+1,iy) + - & yb*Rnxyz(iZeta,2,iya,iyb-1,iy)) - End Do - Else - Do iZeta = 1, nZeta - Temp(iZeta) = Fact(iZeta) * - & Rnxyz(iZeta,1,ixa,ixb,ix) * - & tTwo*Beta(iZeta) * - & Rnxyz(iZeta,2,iya,iyb+1,iy) - End Do - End If -* - Do ir = ix+iy, lr - iz = ir-ix-iy - iComp=Ind(ir,ix,iz)+iOff(ir)-1 - If (iComp.eq.kcar) Then - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,2) = Temp(iZeta)* - & Rnxyz(iZeta,3,iza,izb,iz) - End Do - End If - End Do - End Do - End Do - end if - If (ifgrad(3,1)) Then - Do ix = 0, lr - Do iy = 0, lr-ix - Do iZeta = 1, nZeta - Temp(iZeta) = Fact(iZeta) * - & Rnxyz(iZeta,1,ixa,ixb,ix)* - & Rnxyz(iZeta,2,iya,iyb,iy) - End Do -* - Do ir = ix+iy, lr - iz = ir-ix-iy - iComp=Ind(ir,ix,iz)+iOff(ir)-1 - If (iComp.eq.kcar) Then - If (iza.gt.0) Then - za = -iza - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1)= Temp(iZeta)* - & (tTwo*Alpha(iZeta) * - & Rnxyz(iZeta,3,iza+1,izb,iz) + - & za*Rnxyz(iZeta,3,iza-1,izb,iz)) - End Do - Else - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1)= Temp(iZeta)* - & tTwo*Alpha(iZeta) * - & Rnxyz(iZeta,3,iza+1,izb,iz) - End Do - End If - End If - End Do - End Do - End Do - end if - If (ifgrad(3,2)) Then - Do ix = 0, lr - Do iy = 0, lr-ix - Do iZeta = 1, nZeta - Temp(iZeta) = Fact(iZeta) * - & Rnxyz(iZeta,1,ixa,ixb,ix)* - & Rnxyz(iZeta,2,iya,iyb,iy) - End Do -* - Do ir = ix+iy, lr - iz = ir-ix-iy - iComp=Ind(ir,ix,iz)+iOff(ir)-1 - If (iComp.eq.kcar) Then - If (izb.gt.0) Then - zb = -izb - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,2)= Temp(iZeta)* - & (tTwo* Beta(iZeta) * - & Rnxyz(iZeta,3,iza,izb+1,iz) + - & zb*Rnxyz(iZeta,3,iza,izb-1,iz)) - End Do - Else - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,2)= Temp(iZeta)* - & tTwo* Beta(iZeta) * - & Rnxyz(iZeta,3,iza,izb+1,iz) - End Do - End If - End If - End Do - End Do - End Do - End If -* - 21 Continue - 20 Continue - 11 Continue - 10 Continue -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(nComp) - Call Unused_integer(iStb) - Call Unused_integer(jStb) - Call Unused_integer_array(nOp) - End If - End diff -Nru openmolcas-22.02/src/mckinley/cmbnel.F90 openmolcas-22.10/src/mckinley/cmbnel.F90 --- openmolcas-22.02/src/mckinley/cmbnel.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbnel.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,177 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991,1992,1995, Roland Lindh * +! 1997, Anders Bernhardsson * +!*********************************************************************** + +subroutine CmbnEl(Rnxyz,nZeta,la,lb,lr,Zeta,rKappa,rFinal,Fact,Temp,Alpha,Beta,IfGrad,kcar) +!*********************************************************************** +! * +! Object: to compute gradient integrals for SC Reaction Fields * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! Modified for reaction field calculations July '92 * +! Modified for gradient calculations May '95 * +! Modified for trans. prob. calculations Oct '97 * +! by Anders Bernhardsson * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri3_Elem, nTri_Elem1 +use Constants, only: Two, OneHalf +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb, lr, kcar +real(kind=wp), intent(in) :: Rnxyz(nZeta,3,0:la+1,0:lb+1,0:lr), Zeta(nZeta), rKappa(nZeta), Alpha(nZeta), Beta(nZeta) +real(kind=wp), intent(out) :: rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),2), Fact(nZeta), Temp(nZeta) +logical(kind=iwp), intent(in) :: IfGrad(3,2) +integer(kind=iwp) :: iComp, ipa, ipb, ir, ix, ixa, ixb, iy, iya, iyaMax, iyb, iybMax, iz, iza, izb +real(kind=wp) :: xa, xb, ya, yb, za, zb + +Fact(:) = rKappa*Zeta**(-OneHalf) + +! Loop over angular components of the basis set + +do ixa=0,la + iyaMax = la-ixa + do ixb=0,lb + iybMax = lb-ixb + do iya=0,iyaMax + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + do iyb=0,iybMax + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + + ! Combine multipole moment integrals + + if (IfGrad(1,1)) then + do ix=0,lr + do iy=0,lr-ix + if (ixa > 0) then + xa = -real(ixa,kind=wp) + Temp(:) = Fact(:)*(Two*Alpha(:)*Rnxyz(:,1,ixa+1,ixb,ix)+xa*Rnxyz(:,1,ixa-1,ixb,ix))*Rnxyz(:,2,iya,iyb,iy) + else + Temp(:) = Fact(:)*Two*Alpha(:)*Rnxyz(:,1,ixa+1,ixb,ix)*Rnxyz(:,2,iya,iyb,iy) + end if + + do ir=ix+iy,lr + iz = ir-ix-iy + iComp = C_Ind(ir,ix,iz)+nTri3_Elem(ir)-1 + if (iComp == kcar) rFinal(:,ipa,ipb,1) = Temp(:)*Rnxyz(:,3,iza,izb,iz) + end do + end do + end do + end if + if (IfGrad(1,2)) then + do ix=0,lr + do iy=0,lr-ix + if (ixb > 0) then + xb = -real(ixb,kind=wp) + Temp(:) = Fact(:)*(Two*Beta(:)*Rnxyz(:,1,ixa,ixb+1,ix)+xb*Rnxyz(:,1,ixa,ixb-1,ix))*Rnxyz(:,2,iya,iyb,iy) + else + Temp(:) = Fact(:)*Two*Beta(:)*Rnxyz(:,1,ixa,ixb+1,ix)*Rnxyz(:,2,iya,iyb,iy) + end if + + do ir=ix+iy,lr + iz = ir-ix-iy + iComp = C_Ind(ir,ix,iz)+nTri3_Elem(ir)-1 + if (iComp == kcar) rFinal(:,ipa,ipb,2) = Temp(:)*Rnxyz(:,3,iza,izb,iz) + end do + end do + end do + end if + if (IfGrad(2,1)) then + do ix=0,lr + do iy=0,lr-ix + if (iya > 0) then + ya = -real(iya,kind=wp) + Temp(:) = Fact(:)*Rnxyz(:,1,ixa,ixb,ix)*(Two*Alpha(:)*Rnxyz(:,2,iya+1,iyb,iy)+ya*Rnxyz(:,2,iya-1,iyb,iy)) + else + Temp(:) = Fact(:)*Rnxyz(:,1,ixa,ixb,ix)*Two*Alpha(:)*Rnxyz(:,2,iya+1,iyb,iy) + end if + + do ir=ix+iy,lr + iz = ir-ix-iy + iComp = C_Ind(ir,ix,iz)+nTri3_Elem(ir)-1 + if (iComp == kcar) rFinal(:,ipa,ipb,1) = Temp(:)*Rnxyz(:,3,iza,izb,iz) + end do + end do + end do + end if + if (IfGrad(2,2)) then + do ix=0,lr + do iy=0,lr-ix + if (iyb > 0) then + yb = -real(iyb,kind=wp) + Temp(:) = Fact(:)*Rnxyz(:,1,ixa,ixb,ix)*(Two*Beta(:)*Rnxyz(:,2,iya,iyb+1,iy)+yb*Rnxyz(:,2,iya,iyb-1,iy)) + else + Temp(:) = Fact(:)*Rnxyz(:,1,ixa,ixb,ix)*Two*Beta(:)*Rnxyz(:,2,iya,iyb+1,iy) + end if + + do ir=ix+iy,lr + iz = ir-ix-iy + iComp = C_Ind(ir,ix,iz)+nTri3_Elem(ir)-1 + if (iComp == kcar) rFinal(:,ipa,ipb,2) = Temp(:)*Rnxyz(:,3,iza,izb,iz) + end do + end do + end do + end if + if (IfGrad(3,1)) then + do ix=0,lr + do iy=0,lr-ix + Temp(:) = Fact(:)*Rnxyz(:,1,ixa,ixb,ix)*Rnxyz(:,2,iya,iyb,iy) + + do ir=ix+iy,lr + iz = ir-ix-iy + iComp = C_Ind(ir,ix,iz)+nTri3_Elem(ir)-1 + if (iComp == kcar) then + if (iza > 0) then + za = -real(iza,kind=wp) + rFinal(:,ipa,ipb,1) = Temp(:)*(Two*Alpha(:)*Rnxyz(:,3,iza+1,izb,iz)+za*Rnxyz(:,3,iza-1,izb,iz)) + else + rFinal(:,ipa,ipb,1) = Temp(:)*Two*Alpha(:)*Rnxyz(:,3,iza+1,izb,iz) + end if + end if + end do + end do + end do + end if + if (IfGrad(3,2)) then + do ix=0,lr + do iy=0,lr-ix + Temp(:) = Fact(:)*Rnxyz(:,1,ixa,ixb,ix)*Rnxyz(:,2,iya,iyb,iy) + + do ir=ix+iy,lr + iz = ir-ix-iy + iComp = C_Ind(ir,ix,iz)+nTri3_Elem(ir)-1 + if (iComp == kcar) then + if (izb > 0) then + zb = -real(izb,kind=wp) + rFinal(:,ipa,ipb,2) = Temp(:)*(Two*Beta(:)*Rnxyz(:,3,iza,izb+1,iz)+zb*Rnxyz(:,3,iza,izb-1,iz)) + else + rFinal(:,ipa,ipb,2) = Temp(:)*Two*Beta(:)*Rnxyz(:,3,iza,izb+1,iz) + end if + end if + end do + end do + end do + end if + + end do + end do + end do +end do + +return + +end subroutine CmbnEl diff -Nru openmolcas-22.02/src/mckinley/cmbns1_mck.f openmolcas-22.10/src/mckinley/cmbns1_mck.f --- openmolcas-22.02/src/mckinley/cmbns1_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbns1_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,211 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -* 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine CmbnS1_mck(Rnxyz,nZeta,la,lb,Zeta,rKappa, - & Final,Alpha,Beta,IfGrad,nOp) -************************************************************************ -* * -* Object: compute the gradient of the overlap matrix. * -* * -* Author: Roland Lindh, * -* Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* October '91. * -* Anders Bernhardsson * -* Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* 95. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -c#include "print.fh" -#include "real.fh" - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,1), - & Zeta(nZeta), rKappa(nZeta), Beta(nZeta), - & Rnxyz(nZeta,3,0:la+1,0:lb+1), Alpha(nZeta) - Logical IfGrad(3,2) - Integer nOp(2) -* -* Statement function for Cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 -* -c iRout = 134 -c iPrint = nPrint(iRout) -* Call GetMem(' Enter CmbnS1_mck','LIST','REAL',iDum,iDum) -* -* ii = la*(la+1)*(la+2)/6 -* jj = lb*(lb+1)*(lb+2)/6 - exp32 = -Three/Two - Do 25 iZeta = 1, nZeta - rKappa(iZeta) = rKappa(iZeta) * Zeta(iZeta)**exp32 - 25 Continue -c If (iPrint.ge.99) Then -c Call RecPrt(' In CmbnS1_mck: Zeta ',' ',Zeta ,1,nZeta) -c Call RecPrt(' In CmbnS1_mck: rKappa',' ',rKappa,1,nZeta) -c Call RecPrt(' In CmbnS1_mck: Alpha ',' ',Alpha ,1,nZeta) -c Call RecPrt(' In CmbnS1_mck: Beta ',' ',Beta ,1,nZeta) -c End If - Do 10 ixa = 0, la - iyaMax=la-ixa - Do 11 ixb = 0, lb - iybMax=lb-ixb - Do 20 iya = 0, iyaMax - iza = la-ixa-iya - ipa= Ind(la,ixa,iza) - Do 21 iyb = 0, iybMax - izb = lb-ixb-iyb - ipb= Ind(lb,ixb,izb) -* -* Combine overlap integrals -* - tTwo = Two -* write (*,*) ' papb=', papb - If (IfGrad(1,1)) Then - If (ixa.gt.0) Then - xa = Dble(-ixa) - Do 30 iZeta = 1, nZeta -* Final(iZeta,ipa,ipb,1) = papb * rKappa(iZeta)* - Final(iZeta,ipa,ipb,1) = rKappa(iZeta)* - & (tTwo*Alpha(iZeta)*Rnxyz(iZeta,1,ixa+1,ixb) + - & xa*Rnxyz(iZeta,1,ixa-1,ixb))* - & Rnxyz(iZeta,2,iya,iyb)* - & Rnxyz(iZeta,3,iza,izb) - 30 Continue - Else - Do 31 iZeta = 1, nZeta -* Final(iZeta,ipa,ipb,1) = papb * rKappa(iZeta)* - Final(iZeta,ipa,ipb,1) = rKappa(iZeta)* - & tTwo*Alpha(iZeta)*Rnxyz(iZeta,1,ixa+1,ixb)* - & Rnxyz(iZeta,2,iya,iyb)* - & Rnxyz(iZeta,3,iza,izb) - 31 Continue - End If - End If - If (IfGrad(1,2)) Then - If (ixb.gt.0) Then - xb = Dble(-ixb) - Do 35 iZeta = 1, nZeta -* Final(iZeta,ipa,ipb,1) = papb * rKappa(iZeta)* - Final(iZeta,ipa,ipb,1) = rKappa(iZeta)* - & (tTwo*Beta(iZeta)*Rnxyz(iZeta,1,ixa,ixb+1) + - & xb*Rnxyz(iZeta,1,ixa,ixb-1))* - & Rnxyz(iZeta,2,iya,iyb)* - & Rnxyz(iZeta,3,iza,izb) - 35 Continue - Else - Do 36 iZeta = 1, nZeta -* Final(iZeta,ipa,ipb,1) = papb * rKappa(iZeta)* - Final(iZeta,ipa,ipb,1) = rKappa(iZeta)* - & tTwo*Beta(iZeta)*Rnxyz(iZeta,1,ixa,ixb+1)* - & Rnxyz(iZeta,2,iya,iyb)* - & Rnxyz(iZeta,3,iza,izb) - 36 Continue - End If - End If - If (IfGrad(2,1)) Then - If (iya.gt.0) Then - ya = Dble(-iya) - Do 40 iZeta = 1, nZeta -* Final(iZeta,ipa,ipb,1) = papb * rKappa(iZeta)* - Final(iZeta,ipa,ipb,1) = rKappa(iZeta)* - & Rnxyz(iZeta,1,ixa,ixb)* - & (tTwo*Alpha(iZeta)*Rnxyz(iZeta,2,iya+1,iyb) + - & ya*Rnxyz(iZeta,2,iya-1,iyb))* - & Rnxyz(iZeta,3,iza,izb) - 40 Continue - Else - Do 41 iZeta = 1, nZeta -* Final(iZeta,ipa,ipb,1) = papb * rKappa(iZeta)* - Final(iZeta,ipa,ipb,1) = rKappa(iZeta)* - & Rnxyz(iZeta,1,ixa,ixb)* - & tTwo*Alpha(iZeta)*Rnxyz(iZeta,2,iya+1,iyb)* - & Rnxyz(iZeta,3,iza,izb) - 41 Continue - End If - End If - If (IfGrad(2,2)) Then - If (iyb.gt.0) Then - yb = Dble(-iyb) - Do 45 iZeta = 1, nZeta -* Final(iZeta,ipa,ipb,1) = papb * rKappa(iZeta)* - Final(iZeta,ipa,ipb,1) = rKappa(iZeta)* - & Rnxyz(iZeta,1,ixa,ixb)* - & (tTwo*Beta(iZeta)*Rnxyz(iZeta,2,iya,iyb+1) + - & yb*Rnxyz(iZeta,2,iya,iyb-1))* - & Rnxyz(iZeta,3,iza,izb) - 45 Continue - Else - Do 46 iZeta = 1, nZeta -* Final(iZeta,ipa,ipb,1) = papb * rKappa(iZeta)* - Final(iZeta,ipa,ipb,1) = rKappa(iZeta)* - & Rnxyz(iZeta,1,ixa,ixb)* - & tTwo*Beta(iZeta)*Rnxyz(iZeta,2,iya,iyb+1)* - & Rnxyz(iZeta,3,iza,izb) - 46 Continue - End If - End If - If (IfGrad(3,1)) Then - If (iza.gt.0) Then - za = Dble(-iza) - Do 50 iZeta = 1, nZeta -* Final(iZeta,ipa,ipb,1) = papb * rKappa(iZeta)* - Final(iZeta,ipa,ipb,1) = rKappa(iZeta)* - & Rnxyz(iZeta,1,ixa,ixb)* - & Rnxyz(iZeta,2,iya,iyb)* - & (tTwo*Alpha(iZeta)*Rnxyz(iZeta,3,iza+1,izb) + - & za*Rnxyz(iZeta,3,iza-1,izb)) - 50 Continue - Else - Do 51 iZeta = 1, nZeta -* Final(iZeta,ipa,ipb,1) = papb * rKappa(iZeta)* - Final(iZeta,ipa,ipb,1) = rKappa(iZeta)* - & Rnxyz(iZeta,1,ixa,ixb)* - & Rnxyz(iZeta,2,iya,iyb)* - & tTwo*Alpha(iZeta)*Rnxyz(iZeta,3,iza+1,izb) - 51 Continue - End If - End If - If (IfGrad(3,2)) Then - If (izb.gt.0) Then - zb = Dble(-izb) - Do 55 iZeta = 1, nZeta -* Final(iZeta,ipa,ipb,1) = papb * rKappa(iZeta)* - Final(iZeta,ipa,ipb,1) = rKappa(iZeta)* - & Rnxyz(iZeta,1,ixa,ixb)* - & Rnxyz(iZeta,2,iya,iyb)* - & (tTwo*Beta(iZeta)*Rnxyz(iZeta,3,iza,izb+1) + - & zb*Rnxyz(iZeta,3,iza,izb-1)) - 55 Continue - Else - Do 56 iZeta = 1, nZeta -* Final(iZeta,ipa,ipb,1) = papb * rKappa(iZeta)* - Final(iZeta,ipa,ipb,1) = rKappa(iZeta)* - & Rnxyz(iZeta,1,ixa,ixb)* - & Rnxyz(iZeta,2,iya,iyb)* - & tTwo*Beta(iZeta)*Rnxyz(iZeta,3,iza,izb+1) - 56 Continue - End If - End If -* - 21 Continue - 20 Continue - 11 Continue - 10 Continue -* -* Call GetMem(' Exit CmbnS1_mck','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer_array(nOp) - End If - End diff -Nru openmolcas-22.02/src/mckinley/cmbns1_mck.F90 openmolcas-22.10/src/mckinley/cmbns1_mck.F90 --- openmolcas-22.02/src/mckinley/cmbns1_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbns1_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,143 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine CmbnS1_mck(Rnxyz,nZeta,la,lb,Zeta,rKappa,rFinal,Alpha,Beta,IfGrad) +!*********************************************************************** +! * +! Object: compute the gradient of the overlap matrix. * +! * +! Author: Roland Lindh, * +! Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! October '91. * +! Anders Bernhardsson * +! Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! 95. * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: Two, OneHalf +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb +real(kind=wp), intent(in) :: Rnxyz(nZeta,3,0:la+1,0:lb+1), Zeta(nZeta), Alpha(nZeta), Beta(nZeta) +real(kind=wp), intent(inout) :: rKappa(nZeta) +real(kind=wp), intent(out) :: rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),1) +logical(kind=iwp), intent(in) :: IfGrad(3,2) +integer(kind=iwp) :: ipa, ipb, ixa, ixb, iya, iyaMax, iyb, iybMax, iza, izb +real(kind=wp) :: xa, xb, ya, yb, za, zb + +!iRout = 134 +!iPrint = nPrint(iRout) + +!ii = nTri3_Elem(la) +!jj = nTri3_Elem(lb) +rKappa(:) = rKappa*Zeta**(-OneHalf) +!if (iPrint >= 99) then +! call RecPrt(' In CmbnS1_mck: Zeta ',' ',Zeta,1,nZeta) +! call RecPrt(' In CmbnS1_mck: rKappa',' ',rKappa,1,nZeta) +! call RecPrt(' In CmbnS1_mck: Alpha ',' ',Alpha,1,nZeta) +! call RecPrt(' In CmbnS1_mck: Beta ',' ',Beta,1,nZeta) +!end if +do ixa=0,la + iyaMax = la-ixa + do ixb=0,lb + iybMax = lb-ixb + do iya=0,iyaMax + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + do iyb=0,iybMax + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + + ! Combine overlap integrals + + !write(u6,*) ' papb=', papb + if (IfGrad(1,1)) then + if (ixa > 0) then + xa = real(-ixa,kind=wp) + !rFinal(:,ipa,ipb,1) = papb*rKappa(:)* & + rFinal(:,ipa,ipb,1) = rKappa(:)* & + (Two*Alpha(:)*Rnxyz(:,1,ixa+1,ixb)+xa*Rnxyz(:,1,ixa-1,ixb))*Rnxyz(:,2,iya,iyb)*Rnxyz(:,3,iza,izb) + else + !rFinal(:,ipa,ipb,1) = papb*rKappa(:)*Two*Alpha(:)*Rnxyz(:,1,ixa+1,ixb)*Rnxyz(:,2,iya,iyb)*Rnxyz(:,3,iza,izb) + rFinal(:,ipa,ipb,1) = rKappa(:)*Two*Alpha(:)*Rnxyz(:,1,ixa+1,ixb)*Rnxyz(:,2,iya,iyb)*Rnxyz(:,3,iza,izb) + end if + end if + if (IfGrad(1,2)) then + if (ixb > 0) then + xb = real(-ixb,kind=wp) + !rFinal(:,ipa,ipb,1) = papb*rKappa(:)* & + rFinal(:,ipa,ipb,1) = rKappa(:)* & + (Two*Beta(:)*Rnxyz(:,1,ixa,ixb+1)+xb*Rnxyz(:,1,ixa,ixb-1))*Rnxyz(:,2,iya,iyb)*Rnxyz(:,3,iza,izb) + else + !rFinal(:,ipa,ipb,1) = papb*rKappa(:)*Two*Beta(:)*Rnxyz(:,1,ixa,ixb+1)*Rnxyz(:,2,iya,iyb)*Rnxyz(:,3,iza,izb) + rFinal(:,ipa,ipb,1) = rKappa(:)*Two*Beta(:)*Rnxyz(:,1,ixa,ixb+1)*Rnxyz(:,2,iya,iyb)*Rnxyz(:,3,iza,izb) + end if + end if + if (IfGrad(2,1)) then + if (iya > 0) then + ya = real(-iya,kind=wp) + !rFinal(:,ipa,ipb,1) = papb*rKappa(:)* & + rFinal(:,ipa,ipb,1) = rKappa(:)* & + Rnxyz(:,1,ixa,ixb)*(Two*Alpha(:)*Rnxyz(:,2,iya+1,iyb)+ya*Rnxyz(:,2,iya-1,iyb))*Rnxyz(:,3,iza,izb) + else + !rFinal(:,ipa,ipb,1) = papb*rKappa(:)*Rnxyz(:,1,ixa,ixb)*Two*Alpha(:)*Rnxyz(:,2,iya+1,iyb)*Rnxyz(:,3,iza,izb) + rFinal(:,ipa,ipb,1) = rKappa(:)*Rnxyz(:,1,ixa,ixb)*Two*Alpha(:)*Rnxyz(:,2,iya+1,iyb)*Rnxyz(:,3,iza,izb) + end if + end if + if (IfGrad(2,2)) then + if (iyb > 0) then + yb = real(-iyb,kind=wp) + !rFinal(:,ipa,ipb,1) = papb*rKappa(:)* & + rFinal(:,ipa,ipb,1) = rKappa(:)* & + Rnxyz(:,1,ixa,ixb)*(Two*Beta(:)*Rnxyz(:,2,iya,iyb+1)+yb*Rnxyz(:,2,iya,iyb-1))*Rnxyz(:,3,iza,izb) + else + !rFinal(:,ipa,ipb,1) = papb*rKappa(:)*Rnxyz(:,1,ixa,ixb)*Two*Beta(:)*Rnxyz(:,2,iya,iyb+1)*Rnxyz(:,3,iza,izb) + rFinal(:,ipa,ipb,1) = rKappa(:)*Rnxyz(:,1,ixa,ixb)*Two*Beta(:)*Rnxyz(:,2,iya,iyb+1)*Rnxyz(:,3,iza,izb) + end if + end if + if (IfGrad(3,1)) then + if (iza > 0) then + za = real(-iza,kind=wp) + !rFinal(:,ipa,ipb,1) = papb*rKappa(:)* & + rFinal(:,ipa,ipb,1) = rKappa(:)* & + Rnxyz(:,1,ixa,ixb)*Rnxyz(:,2,iya,iyb)*(Two*Alpha(:)*Rnxyz(:,3,iza+1,izb)+za*Rnxyz(:,3,iza-1,izb)) + else + !rFinal(:,ipa,ipb,1) = papb*rKappa(:)*Rnxyz(:,1,ixa,ixb)*Rnxyz(:,2,iya,iyb)*Two*Alpha(:)*Rnxyz(:,3,iza+1,izb) + rFinal(:,ipa,ipb,1) = rKappa(:)*Rnxyz(:,1,ixa,ixb)*Rnxyz(:,2,iya,iyb)*Two*Alpha(:)*Rnxyz(:,3,iza+1,izb) + end if + end if + if (IfGrad(3,2)) then + if (izb > 0) then + zb = real(-izb,kind=wp) + !rFinal(:,ipa,ipb,1) = papb*rKappa(:)* & + rFinal(:,ipa,ipb,1) = rKappa(:)* & + Rnxyz(:,1,ixa,ixb)*Rnxyz(:,2,iya,iyb)*(Two*Beta(:)*Rnxyz(:,3,iza,izb+1)+zb*Rnxyz(:,3,iza,izb-1)) + else + !rFinal(:,ipa,ipb,1) = papb*rKappa(:)**Rnxyz(:,1,ixa,ixb)*Rnxyz(:,2,iya,iyb)*Two*Beta(:)*Rnxyz(:,3,iza,izb+1) + rFinal(:,ipa,ipb,1) = rKappa(:)*Rnxyz(:,1,ixa,ixb)*Rnxyz(:,2,iya,iyb)*Two*Beta(:)*Rnxyz(:,3,iza,izb+1) + end if + end if + + end do + end do + end do +end do + +return + +end subroutine CmbnS1_mck diff -Nru openmolcas-22.02/src/mckinley/cmbns2a.f openmolcas-22.10/src/mckinley/cmbns2a.f --- openmolcas-22.02/src/mckinley/cmbns2a.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbns2a.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,138 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1994, Anders Bernhardsson * -* 1994, Roland Lindh * -************************************************************************ - SubRoutine CmbnS2a(Rnxyz,nZeta,la,lb,rKappa,Final,Alpha, - & IfHss,ld) -************************************************************************ -* * -* Object: compute the 2nd derivative of the overlap matrix. * -* * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -c#include "print.fh" -#include "real.fh" - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,6), - & rKappa(nZeta), - & Rnxyz(nZeta,3,0:la+ld,0:lb), Alpha(nZeta) - Logical IfHss(4,3,4,3) - Integer ia(3),ib(3) -* -* Statement function for Cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 -* -* Index in the triang. local hessian -* - iTri(i,j) = Max(i,j)*(Max(i,j)-1)/2 + Min(i,j) -* - Do 10 iax = 0, la - ia(1)=iax - iyaMax=la-ia(1) - Do 11 ibx = 0, lb - ib(1)=ibx - iybMax=lb-ib(1) - Do 20 iay = 0, iyaMax - ia(2)=iay - ia(3) = la-ia(2)-ia(1) - ipa= Ind(la,ia(1),ia(3)) - Do 21 iby = 0, iybMax - ib(2)=iby - ib(3) = lb-ib(2)-ib(1) - ipb= Ind(lb,ib(1),ib(3)) -* -* -* Combine overlap integrals -* -* Integrals like dI/dx1dx1 -* - Do 5 iCoor=1,3 - jCoor=Mod(iCoor,3)+1 - kCoor=Mod(jCoor,3)+1 - If (IfHss(1,iCoor,1,iCoor)) Then - Do 30 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,itri(iCoor,iCoor))=rKappa(iZeta)* - & ((Two*Alpha(iZeta))**2 * - & Rnxyz(iZeta,iCoor,ia(iCoor)+2,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor), ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor))- - & Two * Alpha(iZeta) * - & Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor))) - If (ia(iCoor).gt.0) Then - Final(iZeta,ipa,ipb,itri(iCoor,iCoor)) = - & Final(iZeta,ipa,ipb,itri(iCoor,iCoor)) - & - rKappa(iZeta)* - & (Four * Alpha(iZeta)* Dble(ia(iCoor)) * - & Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor))) - End If - If (ia(iCoor).gt.1) Then - Final(iZeta,ipa,ipb,itri(iCoor,iCoor)) = - & Final(iZeta,ipa,ipb,itri(iCoor,iCoor)) - & + rKappa(iZeta)* - & (Dble(ia(iCoor)*(ia(iCoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor)-2,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor), ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor))) - End If - 30 Continue - End If - 5 Continue -* - -* -* Integrals like dI/dxdz -* - Do 56 iCoor=2,3 - Do 52 jCoor=1,iCoor-1 - If (IfHss(1,iCoor,1,jCoor)) Then - Do 51 kCoor=1,3 - Do 50 iZeta = 1, nZeta - If (kCoor.eq.1) Then - Final(iZeta,ipa,ipb, - & itri(iCoor,jCoor))= rKappa(iZeta) - End If - If ((kCoor.eq.iCoor).or.(kCoor.eq.jCoor)) Then - rIc=Two*Alpha(iZeta)* - & Rnxyz(iZeta,kCoor,ia(kCoor)+1,ib(kCoor)) -* - If (ia(kCoor).gt.0) - & rIc=rIc-Dble(ia(kCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor)-1,ib(kCoor)) -* - Final(iZeta,ipa,ipb, - & itri(iCoor,jCoor))= - & Final(iZeta,ipa,ipb, - & itri(iCoor,jCoor))* - & rIc - Else - Final(iZeta,ipa,ipb, - & itri(iCoor,jCoor))= - & Final(iZeta,ipa,ipb, - & itri(iCoor,jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), - & ib(kCoor)) - End If - 50 Continue - 51 Continue - End If - 52 Continue - 56 Continue - 21 Continue - 20 Continue - 11 Continue - 10 Continue - Return - End diff -Nru openmolcas-22.02/src/mckinley/cmbns2a.F90 openmolcas-22.10/src/mckinley/cmbns2a.F90 --- openmolcas-22.02/src/mckinley/cmbns2a.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbns2a.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,103 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1994, Anders Bernhardsson * +! 1994, Roland Lindh * +!*********************************************************************** + +subroutine CmbnS2a(Rnxyz,nZeta,la,lb,rKappa,rFinal,Alpha,IfHss,ld) +!*********************************************************************** +! * +! Object: compute the 2nd derivative of the overlap matrix. * +! * +!*********************************************************************** + +use Index_Functions, only: C_Ind, iTri, nTri_Elem1 +use Constants, only: Two, Four +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb, ld +real(kind=wp), intent(in) :: Rnxyz(nZeta,3,0:la+ld,0:lb), rKappa(nZeta), Alpha(nZeta) +real(kind=wp), intent(inout) :: rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),6) +logical(kind=iwp), intent(in) :: IfHss(4,3,4,3) +integer(kind=iwp) :: ia(3), iax, iay, ib(3), ibx, iby, iCoor, ii, ij, ipa, ipb, iyaMax, iybMax, jCoor, kCoor + +do iax=0,la + ia(1) = iax + iyaMax = la-ia(1) + do ibx=0,lb + ib(1) = ibx + iybMax = lb-ib(1) + do iay=0,iyaMax + ia(2) = iay + ia(3) = la-ia(2)-ia(1) + ipa = C_Ind(la,ia(1),ia(3)) + do iby=0,iybMax + ib(2) = iby + ib(3) = lb-ib(2)-ib(1) + ipb = C_Ind(lb,ib(1),ib(3)) + + ! Combine overlap integrals + + ! Integrals like dI/dx1dx1 + + do iCoor=1,3 + jCoor = mod(iCoor,3)+1 + kCoor = mod(jCoor,3)+1 + if (IfHss(1,iCoor,1,iCoor)) then + ii = iTri(iCoor,iCoor) + rFinal(:,ipa,ipb,ii) = rKappa(:)*((Two*Alpha(:))**2*Rnxyz(:,iCoor,ia(iCoor)+2,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))- & + Two*Alpha(:)*Rnxyz(:,iCoor,ia(iCoor),ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))) + if (ia(iCoor) > 0) rFinal(:,ipa,ipb,ii) = rFinal(:,ipa,ipb,ii)-rKappa(:)*Four*Alpha(:)*real(ia(iCoor),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor),ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ia(iCoor) > 1) rFinal(:,ipa,ipb,ii) = rFinal(:,ipa,ipb,ii)+rKappa(:)*real(ia(iCoor)*(ia(iCoor)-1),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)-2,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + end if + end do + + ! Integrals like dI/dxdz + + do iCoor=2,3 + do jCoor=1,iCoor-1 + if (IfHss(1,iCoor,1,jCoor)) then + ij = iTri(iCoor,jCoor) + rFinal(:,ipa,ipb,ij) = rKappa + do kCoor=1,3 + if ((kCoor == iCoor) .or. (kCoor == jCoor)) then + if (ia(kCoor) > 0) then + rFinal(:,ipa,ipb,ij) = rFinal(:,ipa,ipb,ij)*(Two*Alpha(:)*Rnxyz(:,kCoor,ia(kCoor)+1,ib(kCoor))- & + real(ia(kCoor),kind=wp)*Rnxyz(:,kCoor,ia(kCoor)-1,ib(kCoor))) + else + rFinal(:,ipa,ipb,ij) = rFinal(:,ipa,ipb,ij)*Two*Alpha(:)*Rnxyz(:,kCoor,ia(kCoor)+1,ib(kCoor)) + end if + else + rFinal(:,ipa,ipb,ij) = rFinal(:,ipa,ipb,ij)*Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + end if + end do + end if + end do + end do + end do + end do + end do +end do + +return + +end subroutine CmbnS2a diff -Nru openmolcas-22.02/src/mckinley/cmbns2b.f openmolcas-22.10/src/mckinley/cmbns2b.f --- openmolcas-22.02/src/mckinley/cmbns2b.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbns2b.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,138 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1994, Anders Bernhardsson * -* 1994, Roland Lindh * -************************************************************************ - SubRoutine CmbnS2b(Rnxyz,nZeta,la,lb,rKappa,Final,Beta, - & IfHss,ld) -************************************************************************ -* * -* Object: compute the 2nd derivative of the overlap matrix. * -* * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -c#include "print.fh" -#include "real.fh" - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,6), - & rKappa(nZeta), Beta(nZeta), - & Rnxyz(nZeta,3,0:la,0:lb+ld) - Logical IfHss(4,3,4,3) - Integer ia(3),ib(3) -* -* Statement function for Cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 -* -* Index in the triang. local hessian -* - iTri(i,j) = Max(i,j)*(Max(i,j)-1)/2 + Min(i,j) -* - Do 10 iax = 0, la - ia(1)=iax - iyaMax=la-ia(1) - Do 11 ibx = 0, lb - ib(1)=ibx - iybMax=lb-ib(1) - Do 20 iay = 0, iyaMax - ia(2)=iay - ia(3) = la-ia(2)-ia(1) - ipa= Ind(la,ia(1),ia(3)) - Do 21 iby = 0, iybMax - ib(2)=iby - ib(3) = lb-ib(2)-ib(1) - ipb= Ind(lb,ib(1),ib(3)) -* -* -* Combine overlap integrals -* -* Integrals like dI/dx1dx1 -* - Do 5 iCoor=1,3 - jCoor=Mod(iCoor,3)+1 - kCoor=Mod(jCoor,3)+1 - If (IfHss(2,iCoor,2,iCoor)) Then - Do 30 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,itri(iCoor,iCoor))=rKappa(iZeta)* - & ((Two*Beta(iZeta))**2 * - & Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor)+2)* - & Rnxyz(iZeta,jCoor,ia(jCoor), ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor))- - & Two * Beta(iZeta) * - & Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor))) - If (ib(iCoor).gt.0) Then - Final(iZeta,ipa,ipb,itri(iCoor,iCoor)) = - & Final(iZeta,ipa,ipb,itri(iCoor,iCoor)) - & - rKappa(iZeta)* - & (Four * Beta(iZeta)* Dble(ib(iCoor)) * - & Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor))) - End If - If (ib(iCoor).gt.1) Then - Final(iZeta,ipa,ipb,itri(iCoor,iCoor)) = - & Final(iZeta,ipa,ipb,itri(iCoor,iCoor)) - & +rKappa(iZeta)* - & (Dble(ib(iCoor)*(ib(iCoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor)-2)* - & Rnxyz(iZeta,jCoor,ia(jCoor), ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor))) - End If - 30 Continue - End If - 5 Continue -* - -* -* Integrals like dI/dxdz -* - Do 56 iCoor=2,3 - Do 52 jCoor=1,iCoor-1 - If (IfHss(2,iCoor,2,jCoor)) Then - Do 51 kCoor=1,3 - Do 50 iZeta = 1, nZeta - If (kCoor.eq.1) Then - Final(iZeta,ipa,ipb, - & itri(iCoor,jCoor))= rKappa(iZeta) - End If - If ((kCoor.eq.iCoor).or.(kCoor.eq.jCoor)) Then - rIc=Two*Beta(iZeta)* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor)+1) -* - If (ib(kCoor).gt.0) - & rIc=rIc-Dble(ib(kCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor)-1) -* - Final(iZeta,ipa,ipb, - & itri(iCoor,jCoor))= - & Final(iZeta,ipa,ipb, - & itri(iCoor,jCoor))* - & rIc - Else - Final(iZeta,ipa,ipb, - & itri(iCoor,jCoor))= - & Final(iZeta,ipa,ipb, - & itri(iCoor,jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), - & ib(kCoor)) - End If - 50 Continue - 51 Continue - End If - 52 Continue - 56 Continue - 21 Continue - 20 Continue - 11 Continue - 10 Continue - Return - End diff -Nru openmolcas-22.02/src/mckinley/cmbns2b.F90 openmolcas-22.10/src/mckinley/cmbns2b.F90 --- openmolcas-22.02/src/mckinley/cmbns2b.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbns2b.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,103 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1994, Anders Bernhardsson * +! 1994, Roland Lindh * +!*********************************************************************** + +subroutine CmbnS2b(Rnxyz,nZeta,la,lb,rKappa,rFinal,Beta,IfHss,ld) +!*********************************************************************** +! * +! Object: compute the 2nd derivative of the overlap matrix. * +! * +!*********************************************************************** + +use Index_Functions, only: C_Ind, iTri, nTri_Elem1 +use Constants, only: Two, Four +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb, ld +real(kind=wp), intent(in) :: Rnxyz(nZeta,3,0:la,0:lb+ld), rKappa(nZeta), Beta(nZeta) +real(kind=wp), intent(inout) :: rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),6) +logical(kind=iwp), intent(in) :: IfHss(4,3,4,3) +integer(kind=iwp) :: ia(3), iax, iay, ib(3), ibx, iby, iCoor, ii, ij, ipa, ipb, iyaMax, iybMax, jCoor, kCoor + +do iax=0,la + ia(1) = iax + iyaMax = la-ia(1) + do ibx=0,lb + ib(1) = ibx + iybMax = lb-ib(1) + do iay=0,iyaMax + ia(2) = iay + ia(3) = la-ia(2)-ia(1) + ipa = C_Ind(la,ia(1),ia(3)) + do iby=0,iybMax + ib(2) = iby + ib(3) = lb-ib(2)-ib(1) + ipb = C_Ind(lb,ib(1),ib(3)) + + ! Combine overlap integrals + + ! Integrals like dI/dx1dx1 + + do iCoor=1,3 + jCoor = mod(iCoor,3)+1 + kCoor = mod(jCoor,3)+1 + if (IfHss(2,iCoor,2,iCoor)) then + ii = iTri(iCoor,iCoor) + rFinal(:,ipa,ipb,ii) = rKappa(:)*((Two*Beta(:))**2*Rnxyz(:,iCoor,ia(iCoor),ib(iCoor)+2)* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))- & + Two*Beta(:)*Rnxyz(:,iCoor,ia(iCoor),ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))) + if (ib(iCoor) > 0) rFinal(:,ipa,ipb,ii) = rFinal(:,ipa,ipb,ii)-rKappa(:)*Four*Beta(:)*real(ib(iCoor),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor),ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ib(iCoor) > 1) rFinal(:,ipa,ipb,ii) = rFinal(:,ipa,ipb,ii)+rKappa(:)*real(ib(iCoor)*(ib(iCoor)-1),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor),ib(iCoor)-2)* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + end if + end do + + ! Integrals like dI/dxdz + + do iCoor=2,3 + do jCoor=1,iCoor-1 + if (IfHss(2,iCoor,2,jCoor)) then + ij = iTri(iCoor,jCoor) + rFinal(:,ipa,ipb,ij) = rKappa + do kCoor=1,3 + if ((kCoor == iCoor) .or. (kCoor == jCoor)) then + if (ib(kCoor) > 0) then + rFinal(:,ipa,ipb,ij) = rFinal(:,ipa,ipb,ij)*(Two*Beta(:)*Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)+1)- & + real(ib(kCoor),kind=wp)*Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)-1)) + else + rFinal(:,ipa,ipb,ij) = rFinal(:,ipa,ipb,ij)*Two*Beta(:)*Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)+1) + end if + else + rFinal(:,ipa,ipb,ij) = rFinal(:,ipa,ipb,ij)*Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + end if + end do + end if + end do + end do + end do + end do + end do +end do + +return + +end subroutine CmbnS2b diff -Nru openmolcas-22.02/src/mckinley/cmbns2.f openmolcas-22.10/src/mckinley/cmbns2.f --- openmolcas-22.02/src/mckinley/cmbns2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbns2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,229 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1994, Anders Bernhardsson * -* 1994, Roland Lindh * -************************************************************************ - SubRoutine CmbnS2(Rnxyz,nZeta,la,lb,Zeta,rKappa,Final,Alpha,Beta, - & Hess,nHess,DAO,IfHss,IndHss,indgrd,iu,iv,nOp) -************************************************************************ -* * -* Object: compute the 2nd derivative of the overlap matrix. * -* * -************************************************************************ - use Symmetry_Info, only: nIrrep, iChTbl - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,6), - & Zeta(nZeta), rKappa(nZeta), Beta(nZeta), - & Rnxyz(nZeta,3,0:la+2,0:lb+2), Alpha(nZeta), - & Hess(nHess), - & DAO(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2) - Logical IfHss(0:1,0:2,0:1,0:2) - Integer IndHss(0:1,0:2,0:1,0:2,0:nIrrep-1),istb(0:1), - & nOp(2), ia(3), - & ib(3),indgrd(0:2,0:1,0:nirrep-1) -* -* Statement function for Cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 -* -* Index in the triang. local hessian -* - I(i1,i2)=i1*(i1-1)/2+i2 -* -*EAW 970912 ixyz=ixLoc(DAO(1,1,1)) -c iRout = 134 -c iPrint = nPrint(iRout) - iStb(0)=iu - iStb(1)=iv -* Call GetMem(' Enter CmbnS2','LIST','REAL',iDum,iDum) -* - exp32 = -Three/Two - Do 25 iZeta = 1, nZeta - rKappa(iZeta) = rKappa(iZeta) * Zeta(iZeta)**exp32 - 25 Continue -c If (iPrint.ge.99) Then -c Call RecPrt(' In CmbnS2: Zeta ',' ',Zeta ,1,nZeta) -c Call RecPrt(' In CmbnS2: rKappa',' ',rKappa,1,nZeta) -c Call RecPrt(' In CmbnS2: Alpha ',' ',Alpha ,1,nZeta) -c Call RecPrt(' In CmbnS2: Beta ',' ',Beta ,1,nZeta) -c End If - Do 10 iax = 0, la - ia(1)=iax - iyaMax=la-ia(1) - Do 11 ibx = 0, lb - ib(1)=ibx - iybMax=lb-ib(1) - Do 20 iay = 0, iyaMax - ia(2)=iay - ia(3) = la-ia(2)-ia(1) - ipa= Ind(la,ia(1),ia(3)) - Do 21 iby = 0, iybMax - ib(2)=iby - ib(3) = lb-ib(2)-ib(1) - ipb= Ind(lb,ib(1),ib(3)) -* -* -* Combine overlap integrals -* -* Integrals like dI/dx1dx1 -* - Do 5 iCoor=1,3 - jCoor=Mod(iCoor,3)+1 - kCoor=Mod(jCoor,3)+1 - If (IfHss(0,iCoor-1,0,iCoor-1)) Then - Do 30 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,I(iCoor,iCoor))=rKappa(iZeta)* - & ((Two*Alpha(iZeta))**2 * - & Rnxyz(iZeta,iCoor,ia(iCoor)+2,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor), ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor))- - & Two * Alpha(iZeta) * - & Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor))) - If (ia(iCoor).gt.0) Then - Final(iZeta,ipa,ipb,I(iCoor,iCoor)) = - & Final(iZeta,ipa,ipb,I(iCoor,iCoor)) - & - rKappa(iZeta)* - & (Four * Alpha(iZeta)* Dble(ia(iCoor)) * - & Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor))) - End If - If (ia(iCoor).gt.1) Then - Final(iZeta,ipa,ipb,I(iCoor,iCoor)) = - & Final(iZeta,ipa,ipb,I(iCoor,iCoor)) - & + rKappa(iZeta)* - & (Dble(ia(iCoor)*(ia(iCoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor)-2,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor), ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor))) - End If - 30 Continue - End If - 5 Continue -* - -* -* Integrals like dI/dxdz -* - Do 56 iCoor=2,3 - Do 52 jCoor=1,iCoor-1 - If (IfHss(0,iCoor-1,0,jCoor-1)) Then - Do 51 kCoor=1,3 - Do 50 iZeta = 1, nZeta - If (kCoor.eq.1) Then - Final(iZeta,ipa,ipb, - & I(iCoor,jCoor))= rKappa(iZeta) - End If - If ((kCoor.eq.iCoor).or.(kCoor.eq.jCoor)) Then - rIc=Two*Alpha(iZeta)* - & Rnxyz(iZeta,kCoor,ia(kCoor)+1,ib(kCoor)) -* - If (ia(kCoor).gt.0) - & rIc=rIc-Dble(ia(kCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor)-1,ib(kCoor)) -* - Final(iZeta,ipa,ipb, - & I(iCoor,jCoor))= - & Final(iZeta,ipa,ipb, - & I(iCoor,jCoor))* - & rIc - Else - Final(iZeta,ipa,ipb, - & I(iCoor,jCoor))= - & Final(iZeta,ipa,ipb, - & I(iCoor,jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), - & ib(kCoor)) - End If - 50 Continue - 51 Continue - End If - 52 Continue - 56 Continue - 21 Continue - 20 Continue - 11 Continue - 10 Continue - -* -* Trace the Hessian integrals -* - nDAO = nZeta * (la+1)*(la+2)/2 * (lb+1)*(lb+2)/2 -c If (iPrint.ge.99) Then -c Call RecPrt(' S(1)',' ',Final,nDAO,21) -c Call RecPrt(' D ','(6f12.6)',DAO(1,1,1),nDAO,1) -c End If - Do 90 iIrrep=0,nIrrep-1 - Do 100 iCnt=0,1 - Do 105 iCar=1,3 - Do 110 jCnt=0,1 - if (iCnt.eq.jCnt) Then - iStop=iCar - Else - iStop=3 - End If - Do 115 jCar=1,iStop - If (IndHss(iCnt,iCar-1,jCnt,jCar-1,iIrrep).ne.0) Then -* -* Accumulate contribution to the Hessian -* -* -* Get the characteristics of the diff operator -* - iCh=iEOr(2**(iCar-1)*iCnt,2**(jCar-1)*jCnt) -* -* Get the character of the operator in the present irrep -* - ps=DBLE(iChTbl(iIrrep,nOp(2))** - & (iCnt+jCnt)) -* -* Get the transf. character of the diff. operator -* - ps = ps*DBLE(iPrmt(nOp(2),iCh)) -* -* If the over triangular diff. are needed multiply by two instead -* Because of that x2x1 y2y1 z2z1 just appear ones in the (1,2) -* "subhessian". -* - if (((iCnt.ne.jCnt).and.(iCar.eq.jCar)).and. - & (Abs(indgrd(iCar-1,iCnt,iIrrep)).eq. - & Abs(indgrd(jCar-1,jCnt,iIrrep))) ) Then - ps=ps*Two - End If - iHess = Abs(IndHss(iCnt,iCar-1,jCnt,jCar-1,iIrrep)) - Fact = DBLE(iStb(iCnt)*iStb(jCnt))/DBLE(nIrrep**2) - Fact = Fact * ps - if (IndHss(iCnt,iCar-1,jCnt,jCar-1,iIrrep).gt.0) Then - rtemp=DDot_(nDAO,DAO,1,Final(1,1,1,I(Max(iCar,jCar), - & Min(iCar,jCar))),1) - Hess(iHess) = Hess(iHess) + Fact*rtemp - Else - Fact=Fact*DBLE((-1)**(icnt+jcnt)) - rtemp=DDot_(nDAO,DAO,1,Final(1,1,1,I(Max(iCar,jCar), - & Min(iCar,jCar))),1) - Hess(iHess) = Hess(iHess) + Fact*rtemp - End If - End If - 115 Continue - 110 Continue - 105 Continue - 100 Continue - 90 Continue -* -* Call GetMem(' Exit CmbnS2','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Call Unused_real_array(Beta) - End diff -Nru openmolcas-22.02/src/mckinley/cmbns2.F90 openmolcas-22.10/src/mckinley/cmbns2.F90 --- openmolcas-22.02/src/mckinley/cmbns2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbns2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,179 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1994, Anders Bernhardsson * +! 1994, Roland Lindh * +!*********************************************************************** + +subroutine CmbnS2(Rnxyz,nZeta,la,lb,Zeta,rKappa,rFinal,Alpha,Hess,nHess,DAO,IfHss,IndHss,indgrd,iu,iv,nOp) +!*********************************************************************** +! * +! Object: compute the 2nd derivative of the overlap matrix. * +! * +!*********************************************************************** + +use Index_Functions, only: C_Ind, iTri, nTri_Elem1 +use Symmetry_Info, only: iChTbl, nIrrep +use Constants, only: One, Two, Four, OneHalf +use Definitions, only: wp, iwp, r8 + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb, nHess, IndHss(0:1,0:2,0:1,0:2,0:nIrrep-1), indgrd(0:2,0:1,0:nirrep-1), iu, iv, & + nOp(2) +real(kind=wp), intent(in) :: Rnxyz(nZeta,3,0:la+2,0:lb+2), Zeta(nZeta), Alpha(nZeta), DAO(nZeta,nTri_Elem1(la),nTri_Elem1(lb)) +real(kind=wp), intent(inout) :: rKappa(nZeta), Hess(nHess) +real(kind=wp), intent(out) :: rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),6) +logical(kind=iwp), intent(in) :: IfHss(0:1,0:2,0:1,0:2) +integer(kind=iwp) :: i, ia(3), iax, iay, ib(3), ibx, iby, iCar, iCh, iCnt, iCoor, iHess, iIrrep, ipa, ipb, istb(0:1), iStop, & + iyaMax, iybMax, jCar, jCnt, jCoor, kCoor, nDAO +real(kind=wp) :: Fact, ps, rtemp +integer(kind=iwp), external :: iPrmt +real(kind=r8), external :: DDot_ + +!EAW 970912 ixyz = ixLoc(DAO(1,1,1)) +!iRout = 134 +!iPrint = nPrint(iRout) +iStb(0) = iu +iStb(1) = iv + +rKappa(:) = rKappa*Zeta**(-OneHalf) +!if (iPrint >= 99) then +! call RecPrt(' In CmbnS2: Zeta ',' ',Zeta,1,nZeta) +! call RecPrt(' In CmbnS2: rKappa',' ',rKappa,1,nZeta) +! call RecPrt(' In CmbnS2: Alpha ',' ',Alpha,1,nZeta) +!end if +do iax=0,la + ia(1) = iax + iyaMax = la-ia(1) + do ibx=0,lb + ib(1) = ibx + iybMax = lb-ib(1) + do iay=0,iyaMax + ia(2) = iay + ia(3) = la-ia(2)-ia(1) + ipa = C_Ind(la,ia(1),ia(3)) + do iby=0,iybMax + ib(2) = iby + ib(3) = lb-ib(2)-ib(1) + ipb = C_Ind(lb,ib(1),ib(3)) + + ! Combine overlap integrals + + ! Integrals like dI/dx1dx1 + + do iCoor=1,3 + jCoor = mod(iCoor,3)+1 + kCoor = mod(jCoor,3)+1 + i = iTri(iCoor,iCoor) + if (IfHss(0,iCoor-1,0,iCoor-1)) then + rFinal(:,ipa,ipb,i) = rKappa(:)*((Two*Alpha(:))**2*Rnxyz(:,iCoor,ia(iCoor)+2,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))- & + Two*Alpha(:)*Rnxyz(:,iCoor,ia(iCoor),ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))) + if (ia(iCoor) > 0) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)-rKappa(:)*Four*Alpha(:)*real(ia(iCoor),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor),ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ia(iCoor) > 1) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)+rKappa(:)*real(ia(iCoor)*(ia(iCoor)-1),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)-2,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + end if + end do + + ! Integrals like dI/dxdz + + do iCoor=2,3 + do jCoor=1,iCoor-1 + i = iTri(iCoor,jCoor) + if (IfHss(0,iCoor-1,0,jCoor-1)) then + rFinal(:,ipa,ipb,i) = rKappa + do kCoor=1,3 + if ((kCoor == iCoor) .or. (kCoor == jCoor)) then + if (ia(kCoor) > 0) then + rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)*(Two*Alpha(:)*Rnxyz(:,kCoor,ia(kCoor)+1,ib(kCoor))- & + real(ia(kCoor),kind=wp)*Rnxyz(:,kCoor,ia(kCoor)-1,ib(kCoor))) + else + rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)*Two*Alpha(:)*Rnxyz(:,kCoor,ia(kCoor)+1,ib(kCoor)) + end if + else + rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)*Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + end if + end do + end if + end do + end do + end do + end do + end do +end do + +! Trace the Hessian integrals +nDAO = nZeta*nTri_Elem1(la)*nTri_Elem1(lb) +!if (iPrint >= 99) then +! call RecPrt(' S(1)',' ',rFinal,nDAO,21) +! call RecPrt(' D ','(6f12.6)',DAO(1,1,1),nDAO,1) +!end if +do iIrrep=0,nIrrep-1 + do iCnt=0,1 + do iCar=1,3 + do jCnt=0,1 + if (iCnt == jCnt) then + iStop = iCar + else + iStop = 3 + end if + do jCar=1,iStop + i = iTri(iCar,jCar) + if (IndHss(iCnt,iCar-1,jCnt,jCar-1,iIrrep) /= 0) then + + ! Accumulate contribution to the Hessian + + ! Get the characteristics of the diff operator + + iCh = ieor(2**(iCar-1)*iCnt,2**(jCar-1)*jCnt) + + ! Get the character of the operator in the present irrep + + ps = real(iChTbl(iIrrep,nOp(2))**(iCnt+jCnt),kind=wp) + + ! Get the transf. character of the diff. operator + + ps = ps*real(iPrmt(nOp(2),iCh),kind=wp) + + ! If the over triangular diff. are needed multiply by two instead + ! Because of that x2x1 y2y1 z2z1 just appear ones in the (1,2) + ! "subhessian". + + if ((iCnt /= jCnt) .and. (iCar == jCar) .and. & + (abs(indgrd(iCar-1,iCnt,iIrrep)) == abs(indgrd(jCar-1,jCnt,iIrrep)))) ps = ps*Two + iHess = abs(IndHss(iCnt,iCar-1,jCnt,jCar-1,iIrrep)) + Fact = real(iStb(iCnt)*iStb(jCnt),kind=wp)/real(nIrrep**2,kind=wp) + Fact = Fact*ps + if (IndHss(iCnt,iCar-1,jCnt,jCar-1,iIrrep) > 0) then + rtemp = DDot_(nDAO,DAO,1,rFinal(:,:,:,i),1) + Hess(iHess) = Hess(iHess)+Fact*rtemp + else + Fact = Fact*(-One)**(iCnt+jCnt) + rtemp = DDot_(nDAO,DAO,1,rFinal(:,:,:,i),1) + Hess(iHess) = Hess(iHess)+Fact*rtemp + end if + end if + end do + end do + end do + end do +end do + +return + +end subroutine CmbnS2 diff -Nru openmolcas-22.02/src/mckinley/cmbnt1_mck.f openmolcas-22.10/src/mckinley/cmbnt1_mck.f --- openmolcas-22.02/src/mckinley/cmbnt1_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbnt1_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,278 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -* 1991, Anders Bernhardsson * -************************************************************************ - SubRoutine CmbnT1_mck(Rnxyz,nZeta,la,lb,Zeta,rKappa, - & Final,Txyz,Alpha,Beta,IfGrad) -************************************************************************ -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* October '91 * -* Anders Bernhardsson, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* October '91 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -c#include "print.fh" -#include "real.fh" - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,1), - & Zeta(nZeta), rKappa(nZeta), Alpha(nZeta), Beta(nZeta), - & Rnxyz(nZeta,3,0:la+2,0:lb+2), - & Txyz(nZeta,3,0:la+1,0:lb+1) - Logical IfGrad(3,2) -* -* Statement function for Cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 -* -c iRout = 134 -c iPrint = nPrint(iRout) -* -* ii = la*(la+1)*(la+2)/6 -* jj = lb*(lb+1)*(lb+2)/6 - exp32 = -Three/Two - Do 25 iZeta = 1, nZeta - rKappa(iZeta) = rKappa(iZeta) * Zeta(iZeta)**exp32 - 25 Continue - Do 10 ixa = 0, la - iyaMax=la-ixa - Do 11 ixb = 0, lb - iybMax=lb-ixb - Do 20 iya = 0, iyaMax - iza = la-ixa-iya - ipa= Ind(la,ixa,iza) - Do 21 iyb = 0, iybMax - izb = lb-ixb-iyb - ipb= Ind(lb,ixb,izb) -* -* Combine integrals -* - tTwo = Two - If (IfGrad(1,1)) Then - If (ixa.gt.0) Then - xa = Dble(-ixa) - Do 30 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = - & rKappa(iZeta) * ( - & (tTwo*Txyz(iZeta,1,ixa+1,ixb)*Alpha(iZeta) + - & xa*Txyz(iZeta,1,ixa-1,ixb) )* - & Rnxyz(iZeta,2,iya,iyb)* - & Rnxyz(iZeta,3,iza,izb) + - & (tTwo*Rnxyz(iZeta,1,ixa+1,ixb)*Alpha(iZeta) + - & xa*Rnxyz(iZeta,1,ixa-1,ixb) )* - & Txyz(iZeta,2,iya,iyb)* - & Rnxyz(iZeta,3,iza,izb) + - & (tTwo*Rnxyz(iZeta,1,ixa+1,ixb)*Alpha(iZeta) + - & xa*Rnxyz(iZeta,1,ixa-1,ixb) )* - & Rnxyz(iZeta,2,iya,iyb)* - & Txyz(iZeta,3,iza,izb) ) - 30 Continue - Else - Do 31 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = - & rKappa(iZeta) * Alpha(iZeta) * ( - & tTwo*Txyz(iZeta,1,ixa+1,ixb) * - & Rnxyz(iZeta,2,iya,iyb)* - & Rnxyz(iZeta,3,iza,izb) + - & tTwo*Rnxyz(iZeta,1,ixa+1,ixb) * - & Txyz(iZeta,2,iya,iyb)* - & Rnxyz(iZeta,3,iza,izb) + - & tTwo*Rnxyz(iZeta,1,ixa+1,ixb) * - & Rnxyz(iZeta,2,iya,iyb)* - & Txyz(iZeta,3,iza,izb) ) - 31 Continue - End If - End If - If (IfGrad(1,2)) Then - If (ixb.gt.0) Then - xb = Dble(-ixb) - Do 35 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = - & rKappa(iZeta) * ( - & (tTwo*Txyz(iZeta,1,ixa,ixb+1)*Beta(iZeta) + - & xb*Txyz(iZeta,1,ixa,ixb-1) )* - & Rnxyz(iZeta,2,iya,iyb)* - & Rnxyz(iZeta,3,iza,izb) + - & (tTwo*Rnxyz(iZeta,1,ixa,ixb+1)*Beta(iZeta) + - & xb*Rnxyz(iZeta,1,ixa,ixb-1) )* - & Txyz(iZeta,2,iya,iyb)* - & Rnxyz(iZeta,3,iza,izb) + - & (tTwo*Rnxyz(iZeta,1,ixa,ixb+1)*Beta(iZeta) + - & xb*Rnxyz(iZeta,1,ixa,ixb-1) )* - & Rnxyz(iZeta,2,iya,iyb)* - & Txyz(iZeta,3,iza,izb) ) - 35 Continue - Else - Do 36 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = - & rKappa(iZeta) * Beta(iZeta) * ( - & tTwo*Txyz(iZeta,1,ixa,ixb+1) * - & Rnxyz(iZeta,2,iya,iyb)* - & Rnxyz(iZeta,3,iza,izb) + - & tTwo*Rnxyz(iZeta,1,ixa,ixb+1) * - & Txyz(iZeta,2,iya,iyb)* - & Rnxyz(iZeta,3,iza,izb) + - & tTwo*Rnxyz(iZeta,1,ixa,ixb+1) * - & Rnxyz(iZeta,2,iya,iyb)* - & Txyz(iZeta,3,iza,izb) ) - 36 Continue - End If - End If - If (IfGrad(2,1)) Then - If (iya.gt.0) Then - ya = Dble(-iya) - Do 40 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = - & rKappa(iZeta) * ( - & Txyz(iZeta,1,ixa,ixb)* - & (tTwo*Rnxyz(iZeta,2,iya+1,iyb)*Alpha(iZeta) + - & ya*Rnxyz(iZeta,2,iya-1,iyb) )* - & Rnxyz(iZeta,3,iza,izb) + - & Rnxyz(iZeta,1,ixa,ixb)* - & (tTwo*Txyz(iZeta,2,iya+1,iyb)*Alpha(iZeta) + - & ya*Txyz(iZeta,2,iya-1,iyb) )* - & Rnxyz(iZeta,3,iza,izb) + - & Rnxyz(iZeta,1,ixa,ixb) * - & (tTwo*Rnxyz(iZeta,2,iya+1,iyb)*Alpha(iZeta) + - & ya*Rnxyz(iZeta,2,iya-1,iyb) )* - & Txyz(iZeta,3,iza,izb) ) - 40 Continue - Else - Do 41 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = - & rKappa(iZeta) * Alpha(iZeta) * ( - & Txyz(iZeta,1,ixa,ixb)* - & tTwo*Rnxyz(iZeta,2,iya+1,iyb) * - & Rnxyz(iZeta,3,iza,izb) + - & Rnxyz(iZeta,1,ixa,ixb)* - & tTwo*Txyz(iZeta,2,iya+1,iyb) * - & Rnxyz(iZeta,3,iza,izb) + - & Rnxyz(iZeta,1,ixa,ixb) * - & tTwo*Rnxyz(iZeta,2,iya+1,iyb) * - & Txyz(iZeta,3,iza,izb) ) - 41 Continue - End If - End If - If (IfGrad(2,2)) Then - If (iyb.gt.0) Then - yb = Dble(-iyb) - Do 45 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = - & rKappa(iZeta) * ( - & Txyz(iZeta,1,ixa,ixb)* - & (tTwo*Rnxyz(iZeta,2,iya,iyb+1)*Beta(iZeta) + - & yb*Rnxyz(iZeta,2,iya,iyb-1) )* - & Rnxyz(iZeta,3,iza,izb) + - & Rnxyz(iZeta,1,ixa,ixb)* - & (tTwo*Txyz(iZeta,2,iya,iyb+1)*Beta(iZeta) + - & yb*Txyz(iZeta,2,iya,iyb-1) )* - & Rnxyz(iZeta,3,iza,izb) + - & Rnxyz(iZeta,1,ixa,ixb) * - & (tTwo*Rnxyz(iZeta,2,iya,iyb+1)*Beta(iZeta) + - & yb*Rnxyz(iZeta,2,iya,iyb-1) )* - & Txyz(iZeta,3,iza,izb) ) - 45 Continue - Else - Do 46 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = - & rKappa(iZeta) * Beta(iZeta) * ( - & Txyz(iZeta,1,ixa,ixb)* - & tTwo*Rnxyz(iZeta,2,iya,iyb+1) * - & Rnxyz(iZeta,3,iza,izb) + - & Rnxyz(iZeta,1,ixa,ixb)* - & tTwo*Txyz(iZeta,2,iya,iyb+1) * - & Rnxyz(iZeta,3,iza,izb) + - & Rnxyz(iZeta,1,ixa,ixb) * - & tTwo*Rnxyz(iZeta,2,iya,iyb+1) * - & Txyz(iZeta,3,iza,izb) ) - 46 Continue - End If - End If - If (IfGrad(3,1)) Then - If (iza.gt.0) Then - za = Dble(-iza) - Do 50 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = - & rKappa(iZeta) * ( - & Txyz(iZeta,1,ixa,ixb)* - & Rnxyz(iZeta,2,iya,iyb)* - & (tTwo*Rnxyz(iZeta,3,iza+1,izb)*Alpha(iZeta) + - & za*Rnxyz(iZeta,3,iza-1,izb) ) + - & Rnxyz(iZeta,1,ixa,ixb)* - & Txyz(iZeta,2,iya,iyb)* - & (tTwo*Rnxyz(iZeta,3,iza+1,izb)*Alpha(iZeta) + - & za*Rnxyz(iZeta,3,iza-1,izb) ) + - & Rnxyz(iZeta,1,ixa,ixb) * - & Rnxyz(iZeta,2,iya,iyb)* - & (tTwo*Txyz(iZeta,3,iza+1,izb)*Alpha(iZeta) + - & za*Txyz(iZeta,3,iza-1,izb) ) ) - 50 Continue - Else - Do 51 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = - & rKappa(iZeta) * Alpha(iZeta) * ( - & Txyz(iZeta,1,ixa,ixb)* - & Rnxyz(iZeta,2,iya,iyb)* - & tTwo*Rnxyz(iZeta,3,iza+1,izb) + - & Rnxyz(iZeta,1,ixa,ixb)* - & Txyz(iZeta,2,iya,iyb)* - & tTwo*Rnxyz(iZeta,3,iza+1,izb) + - & Rnxyz(iZeta,1,ixa,ixb) * - & Rnxyz(iZeta,2,iya,iyb)* - & tTwo*Txyz(iZeta,3,iza+1,izb) ) - 51 Continue - End If - End If - If (IfGrad(3,2)) Then - If (izb.gt.0) Then - zb = Dble(-izb) - Do 55 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = - & rKappa(iZeta) * ( - & Txyz(iZeta,1,ixa,ixb)* - & Rnxyz(iZeta,2,iya,iyb)* - & (tTwo*Rnxyz(iZeta,3,iza,izb+1)*Beta(iZeta) + - & zb*Rnxyz(iZeta,3,iza,izb-1) ) + - & Rnxyz(iZeta,1,ixa,ixb)* - & Txyz(iZeta,2,iya,iyb)* - & (tTwo*Rnxyz(iZeta,3,iza,izb+1)*Beta(iZeta) + - & zb*Rnxyz(iZeta,3,iza,izb-1) ) + - & Rnxyz(iZeta,1,ixa,ixb) * - & Rnxyz(iZeta,2,iya,iyb)* - & (tTwo*Txyz(iZeta,3,iza,izb+1)*Beta(iZeta) + - & zb*Txyz(iZeta,3,iza,izb-1) ) ) - 55 Continue - Else - Do 56 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = - & rKappa(iZeta) * Beta(iZeta) * ( - & Txyz(iZeta,1,ixa,ixb)* - & Rnxyz(iZeta,2,iya,iyb)* - & tTwo*Rnxyz(iZeta,3,iza,izb+1) + - & Rnxyz(iZeta,1,ixa,ixb)* - & Txyz(iZeta,2,iya,iyb)* - & tTwo*Rnxyz(iZeta,3,iza,izb+1) + - & Rnxyz(iZeta,1,ixa,ixb) * - & Rnxyz(iZeta,2,iya,iyb)* - & tTwo*Txyz(iZeta,3,iza,izb+1) ) - 56 Continue - End If - End If -* - 21 Continue - 20 Continue - 11 Continue - 10 Continue -* -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/cmbnt1_mck.F90 openmolcas-22.10/src/mckinley/cmbnt1_mck.F90 --- openmolcas-22.02/src/mckinley/cmbnt1_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbnt1_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,154 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +! 1991, Anders Bernhardsson * +!*********************************************************************** + +subroutine CmbnT1_mck(Rnxyz,nZeta,la,lb,Zeta,rKappa,rFinal,Txyz,Alpha,Beta,IfGrad) +!*********************************************************************** +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! October '91 * +! Anders Bernhardsson, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! October '91 * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: Two, OneHalf +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb +real(kind=wp), intent(in) :: Rnxyz(nZeta,3,0:la+2,0:lb+2), Zeta(nZeta), Txyz(nZeta,3,0:la+1,0:lb+1), Alpha(nZeta), Beta(nZeta) +real(kind=wp), intent(inout) :: rKappa(nZeta), rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),1) +logical(kind=iwp), intent(in) :: IfGrad(3,2) +integer(kind=iwp) :: ipa, ipb, ixa, ixb, iya, iyaMax, iyb, iybMax, iza, izb +real(kind=wp) :: xa, xb, ya, yb, za, zb + +!iRout = 134 +!iPrint = nPrint(iRout) + +!ii = nTri3_Elem(la) +!jj = nTri3_Elem(lb) +rKappa(:) = rKappa*Zeta**(-OneHalf) +do ixa=0,la + iyaMax = la-ixa + do ixb=0,lb + iybMax = lb-ixb + do iya=0,iyaMax + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + do iyb=0,iybMax + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + + ! Combine integrals + + if (IfGrad(1,1)) then + if (ixa > 0) then + xa = real(-ixa,kind=wp) + rFinal(:,ipa,ipb,1) = rKappa(:)*((Two*Txyz(:,1,ixa+1,ixb)*Alpha(:)+xa*Txyz(:,1,ixa-1,ixb))* & + Rnxyz(:,2,iya,iyb)*Rnxyz(:,3,iza,izb)+ & + (Two*Rnxyz(:,1,ixa+1,ixb)*Alpha(:)+xa*Rnxyz(:,1,ixa-1,ixb))* & + Txyz(:,2,iya,iyb)*Rnxyz(:,3,iza,izb)+ & + (Two*Rnxyz(:,1,ixa+1,ixb)*Alpha(:)+xa*Rnxyz(:,1,ixa-1,ixb))* & + Rnxyz(:,2,iya,iyb)*Txyz(:,3,iza,izb)) + else + rFinal(:,ipa,ipb,1) = rKappa(:)*Two*Alpha(:)*(Txyz(:,1,ixa+1,ixb)*Rnxyz(:,2,iya,iyb)*Rnxyz(:,3,iza,izb)+ & + Rnxyz(:,1,ixa+1,ixb)*Txyz(:,2,iya,iyb)*Rnxyz(:,3,iza,izb)+ & + Rnxyz(:,1,ixa+1,ixb)*Rnxyz(:,2,iya,iyb)*Txyz(:,3,iza,izb)) + end if + end if + if (IfGrad(1,2)) then + if (ixb > 0) then + xb = real(-ixb,kind=wp) + rFinal(:,ipa,ipb,1) = rKappa(:)*((Two*Txyz(:,1,ixa,ixb+1)*Beta(:)+xb*Txyz(:,1,ixa,ixb-1))* & + Rnxyz(:,2,iya,iyb)*Rnxyz(:,3,iza,izb)+ & + (Two*Rnxyz(:,1,ixa,ixb+1)*Beta(:)+xb*Rnxyz(:,1,ixa,ixb-1))* & + Txyz(:,2,iya,iyb)*Rnxyz(:,3,iza,izb)+ & + (Two*Rnxyz(:,1,ixa,ixb+1)*Beta(:)+xb*Rnxyz(:,1,ixa,ixb-1))* & + Rnxyz(:,2,iya,iyb)*Txyz(:,3,iza,izb)) + else + rFinal(:,ipa,ipb,1) = rKappa(:)*Two*Beta(:)*(Txyz(:,1,ixa,ixb+1)*Rnxyz(:,2,iya,iyb)*Rnxyz(:,3,iza,izb)+ & + Rnxyz(:,1,ixa,ixb+1)*Txyz(:,2,iya,iyb)*Rnxyz(:,3,iza,izb)+ & + Rnxyz(:,1,ixa,ixb+1)*Rnxyz(:,2,iya,iyb)*Txyz(:,3,iza,izb)) + end if + end if + if (IfGrad(2,1)) then + if (iya > 0) then + ya = real(-iya,kind=wp) + rFinal(:,ipa,ipb,1) = rKappa(:)*(Txyz(:,1,ixa,ixb)*(Two*Rnxyz(:,2,iya+1,iyb)*Alpha(:)+ya*Rnxyz(:,2,iya-1,iyb))* & + Rnxyz(:,3,iza,izb)+ & + Rnxyz(:,1,ixa,ixb)*(Two*Txyz(:,2,iya+1,iyb)*Alpha(:)+ya*Txyz(:,2,iya-1,iyb))* & + Rnxyz(:,3,iza,izb)+ & + Rnxyz(:,1,ixa,ixb)*(Two*Rnxyz(:,2,iya+1,iyb)*Alpha(:)+ya*Rnxyz(:,2,iya-1,iyb))* & + Txyz(:,3,iza,izb)) + else + rFinal(:,ipa,ipb,1) = rKappa(:)*Two*Alpha(:)*(Txyz(:,1,ixa,ixb)*Rnxyz(:,2,iya+1,iyb)*Rnxyz(:,3,iza,izb)+ & + Rnxyz(:,1,ixa,ixb)*Txyz(:,2,iya+1,iyb)*Rnxyz(:,3,iza,izb)+ & + Rnxyz(:,1,ixa,ixb)*Rnxyz(:,2,iya+1,iyb)*Txyz(:,3,iza,izb)) + end if + end if + if (IfGrad(2,2)) then + if (iyb > 0) then + yb = real(-iyb,kind=wp) + rFinal(:,ipa,ipb,1) = rKappa(:)*(Txyz(:,1,ixa,ixb)*(Two*Rnxyz(:,2,iya,iyb+1)*Beta(:)+yb*Rnxyz(:,2,iya,iyb-1))* & + Rnxyz(:,3,iza,izb)+ & + Rnxyz(:,1,ixa,ixb)*(Two*Txyz(:,2,iya,iyb+1)*Beta(:)+yb*Txyz(:,2,iya,iyb-1))* & + Rnxyz(:,3,iza,izb)+ & + Rnxyz(:,1,ixa,ixb)*(Two*Rnxyz(:,2,iya,iyb+1)*Beta(:)+yb*Rnxyz(:,2,iya,iyb-1))* & + Txyz(:,3,iza,izb)) + else + rFinal(:,ipa,ipb,1) = rKappa(:)*Two*Beta(:)*(Txyz(:,1,ixa,ixb)*Rnxyz(:,2,iya,iyb+1)*Rnxyz(:,3,iza,izb)+ & + Rnxyz(:,1,ixa,ixb)*Txyz(:,2,iya,iyb+1)*Rnxyz(:,3,iza,izb)+ & + Rnxyz(:,1,ixa,ixb)*Rnxyz(:,2,iya,iyb+1)*Txyz(:,3,iza,izb)) + end if + end if + if (IfGrad(3,1)) then + if (iza > 0) then + za = real(-iza,kind=wp) + rFinal(:,ipa,ipb,1) = rKappa(:)*(Txyz(:,1,ixa,ixb)*Rnxyz(:,2,iya,iyb)* & + (Two*Rnxyz(:,3,iza+1,izb)*Alpha(:)+za*Rnxyz(:,3,iza-1,izb))+ & + Rnxyz(:,1,ixa,ixb)*Txyz(:,2,iya,iyb)* & + (Two*Rnxyz(:,3,iza+1,izb)*Alpha(:)+za*Rnxyz(:,3,iza-1,izb))+ & + Rnxyz(:,1,ixa,ixb)*Rnxyz(:,2,iya,iyb)* & + (Two*Txyz(:,3,iza+1,izb)*Alpha(:)+za*Txyz(:,3,iza-1,izb))) + else + rFinal(:,ipa,ipb,1) = rKappa(:)*Two*Alpha(:)*(Txyz(:,1,ixa,ixb)*Rnxyz(:,2,iya,iyb)*Rnxyz(:,3,iza+1,izb)+ & + Rnxyz(:,1,ixa,ixb)*Txyz(:,2,iya,iyb)*Rnxyz(:,3,iza+1,izb)+ & + Rnxyz(:,1,ixa,ixb)*Rnxyz(:,2,iya,iyb)*Txyz(:,3,iza+1,izb)) + end if + end if + if (IfGrad(3,2)) then + if (izb > 0) then + zb = real(-izb,kind=wp) + rFinal(:,ipa,ipb,1) = rKappa(:)*(Txyz(:,1,ixa,ixb)*Rnxyz(:,2,iya,iyb)* & + (Two*Rnxyz(:,3,iza,izb+1)*Beta(:)+zb*Rnxyz(:,3,iza,izb-1))+ & + Rnxyz(:,1,ixa,ixb)*Txyz(:,2,iya,iyb)* & + (Two*Rnxyz(:,3,iza,izb+1)*Beta(:)+zb*Rnxyz(:,3,iza,izb-1))+ & + Rnxyz(:,1,ixa,ixb)*Rnxyz(:,2,iya,iyb)* & + (Two*Txyz(:,3,iza,izb+1)*Beta(:)+zb*Txyz(:,3,iza,izb-1))) + else + rFinal(:,ipa,ipb,1) = rKappa(:)*Two*Beta(:)*(Txyz(:,1,ixa,ixb)*Rnxyz(:,2,iya,iyb)*Rnxyz(:,3,iza,izb+1)+ & + Rnxyz(:,1,ixa,ixb)*Txyz(:,2,iya,iyb)*Rnxyz(:,3,iza,izb+1)+ & + Rnxyz(:,1,ixa,ixb)*Rnxyz(:,2,iya,iyb)*Txyz(:,3,iza,izb+1)) + end if + end if + + end do + end do + end do +end do + +return + +end subroutine CmbnT1_mck diff -Nru openmolcas-22.02/src/mckinley/cmbnt2.f openmolcas-22.10/src/mckinley/cmbnt2.f --- openmolcas-22.02/src/mckinley/cmbnt2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbnt2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,606 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1994, Anders Bernhardsson * -* 1994, Roland Lindh * -************************************************************************ - SubRoutine CmbnT2(Rnxyz,nZeta,la,lb,Zeta,rKappa,Final,Alpha,Beta, - & Hess,nHess,DAO,IfHss,IndHss,indgrd,iu,iv,nOp) -************************************************************************ -* * -* Object: compute the 2nd derivative of the overlap matrix. * -* * -************************************************************************ - use Symmetry_Info, only: nIrrep, iChTbl - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,6), - & Zeta(nZeta), rKappa(nZeta), Beta(nZeta), - & Rnxyz(nZeta,3,0:la+2,0:lb+2), Alpha(nZeta), - & Hess(nHess), - & DAO(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2) - Logical IfHss(0:1,0:2,0:1,0:2) - Integer IndHss(0:1,0:2,0:1,0:2,0:nIrrep-1),istab(0:1), - & nOp(2), ia(3), - & ib(3),indgrd(0:2,0:1,0:nirrep-1) -* -* Statement function for Cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 -* -* Index in the lower triang. local hessian i1 row i2 column -* -* itot*0 added to avoid compiler warning - I(itot,i1,i2)=itot*0+i1*(i1-1)/2+i2 -* -c iRout = 134 - iStab(0)=iu - iStab(1)=iv -c iPrint = nPrint(iRout) -* Call GetMem(' Enter CmbnT2','LIST','REAL',iDum,iDum) -* - exp32 = -Three/Two - Do 25 iZeta = 1, nZeta - rKappa(iZeta) = half*rKappa(iZeta) * Zeta(iZeta)**exp32 - 25 Continue -c If (iPrint.ge.99) Then -c Call RecPrt(' In CmbnT2: Zeta ',' ',Zeta ,1,nZeta) -c Call RecPrt(' In CmbnT2: rKappa',' ',rKappa,1,nZeta) -c Call RecPrt(' In CmbnT2: Alpha ',' ',Alpha ,1,nZeta) -c Call RecPrt(' In CmbnT2: Beta ',' ',Beta ,1,nZeta) -c End If - Do 10 iax = 0, la - ia(1)=iax - iyaMax=la-ia(1) - Do 11 ibx = 0, lb - ib(1)=ibx - iybMax=lb-ib(1) - Do 20 iay = 0, iyaMax - ia(2)=iay - ia(3) = la-ia(2)-ia(1) - ipa= Ind(la,ia(1),ia(3)) - Do 21 iby = 0, iybMax - ib(2)=iby - ib(3) = lb-ib(2)-ib(1) - ipb= Ind(lb,ib(1),ib(3)) -* -* -* Combine overlap integrals -* -* Integrals like dI/dx1dx1 -* - Do 5 iCoor=1,3 - jCoor=Mod(iCoor,3)+1 - kCoor=Mod(jCoor,3)+1 - If (IfHss(0,iCoor-1,0,iCoor-1)) Then - Do 30 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,I(6,iCoor,iCoor))=rKappa(iZeta)* - & ((Two*Alpha(iZeta))**2 * - & ((Two*Beta(iZeta))**2* - & (Rnxyz(iZeta,iCoor,ia(iCoor)+2,ib(iCoor)+2)* - & Rnxyz(iZeta,jCoor,ia(jCoor), ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor) )+ - & Rnxyz(iZeta,iCoor,ia(iCoor)+2,ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor), ib(jCoor)+2)* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor) )+ - & Rnxyz(iZeta,iCoor,ia(iCoor)+2,ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor), ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)+2)) - & -Three*Two*Beta(iZeta)* - & Rnxyz(iZeta,iCoor,ia(iCoor)+2,ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor), ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor) ))- - & Two*Alpha(iZeta)* - & ((Two*Beta(iZeta))**2* - & (Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor)+2)* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor) )+ - & Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor)+2)* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor) )+ - & Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor)+2)) - & -Three*Two*Beta(iZeta)* - & Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor) ))) - if (lb.gt.0) Then - Final(iZeta,ipa,ipb,I(6,iCoor,iCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,iCoor))- - & rKappa(iZeta)* - & ((Two*Alpha(iZeta))**2 * - & Four*Beta(iZeta)*Dble(lb)* - & Rnxyz(iZeta,iCoor,ia(iCoor)+2,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor), ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)) - & -Two*Alpha(iZeta)*(Four*Beta(iZeta))*Dble(lb)* - & Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor) )) - End If - if (ib(icoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,iCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,iCoor))+ - & rKappa(iZeta)* - & ((Two*Alpha(iZeta))**2 * - & Dble(ib(icoor)*(ib(icoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor)+2,ib(iCoor)-2)* - & Rnxyz(iZeta,jCoor,ia(jCoor), ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)) - & -Two*Alpha(iZeta)* - & Dble(ib(icoor)*(ib(icoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor)-2)* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor) )) - End If - if (ib(jcoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,iCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,iCoor))+ - & rKappa(iZeta)* - & ((Two*Alpha(iZeta))**2 * - & Dble(ib(jcoor)*(ib(jcoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor)+2,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor), ib(jCoor)-2)* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)) - & -Two*Alpha(iZeta)* - & Dble(ib(jcoor)*(ib(jcoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor)-2)* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor) )) - End If - if (ib(kcoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,iCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,iCoor))+ - & rKappa(iZeta)* - & ((Two*Alpha(iZeta))**2 * - & Dble(ib(kcoor)*(ib(kcoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor)+2,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor), ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)-2) - & -Two*Alpha(iZeta)* - & Dble(ib(kcoor)*(ib(kcoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor)-2)) - End If - If (ia(iCoor).gt.0) Then - Final(iZeta,ipa,ipb,I(6,iCoor,iCoor)) = - & Final(iZeta,ipa,ipb,I(6,iCoor,iCoor)) - & - rKappa(iZeta)* - & Four * Alpha(iZeta)* Dble(ia(iCoor)) * - & ((Two*Beta(iZeta))**2* - & (Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor)+2)* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor) )+ - & Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor)+2)* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor) )+ - & Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor)+2))- - & (Three*Two*Beta(iZeta)* - & Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor) ))) - If (lb.gt.0) Then - Final(iZeta,ipa,ipb,I(6,iCoor,iCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,iCoor))+ - & rKappa(iZeta)* - & Four*Beta(iZeta)*Dble(lb)* - & Four * Alpha(iZeta)* Dble(ia(iCoor)) * - & (Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor))) - End If - If (ib(iCoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,iCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,iCoor))- - & rKappa(iZeta)* - & Dble(ib(icoor)*(ib(icoor)-1))* - & Four * Alpha(iZeta)* Dble(ia(iCoor)) * - & (Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor)-2)* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor))) - End If - If (ib(jCoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,iCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,iCoor))- - & rKappa(iZeta)* - & Dble(ib(jcoor)*(ib(jcoor)-1))* - & Four * Alpha(iZeta)* Dble(ia(iCoor)) * - & (Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor)-2)* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor))) - End If - If (ib(kCoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,iCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,iCoor))- - & rKappa(iZeta)* - & Dble(ib(kcoor)*(ib(kcoor)-1))* - & Four * Alpha(iZeta)* Dble(ia(iCoor)) * - & (Rnxyz(iZeta,iCoor,ia(iCoor),ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor)-2)) - End If - End If - If (ia(iCoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,iCoor)) = - & Final(iZeta,ipa,ipb,I(6,iCoor,iCoor)) - & +rKappa(iZeta)*Dble(ia(iCoor)*(ia(iCoor)-1))* - & ((Two*Beta(iZeta))**2* - & (Rnxyz(iZeta,iCoor,ia(iCoor)-2,ib(iCoor)+2)* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor) )+ - & Rnxyz(iZeta,iCoor,ia(iCoor)-2,ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor)+2)* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor) )+ - & Rnxyz(iZeta,iCoor,ia(iCoor)-2,ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor)+2))- - & (Three*Two*Beta(iZeta)* - & Rnxyz(iZeta,iCoor,ia(iCoor)-2,ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor) ))) - If (lb.gt.0) Then - Final(iZeta,ipa,ipb,I(6,iCoor,iCoor)) = - & Final(iZeta,ipa,ipb,I(6,iCoor,iCoor)) - & -rKappa(iZeta)*Dble(ia(iCoor)*(ia(iCoor)-1))* - & Four*Beta(iZeta)*Dble(lb)* - & (Rnxyz(iZeta,iCoor,ia(iCoor)-2,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor) )) - End If - If (ib(iCoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,iCoor)) = - & Final(iZeta,ipa,ipb,I(6,iCoor,iCoor)) - & +rKappa(iZeta)*Dble(ia(iCoor)*(ia(iCoor)-1)* - & ib(iCoor)*(ib(iCoor)-1))* - & (Rnxyz(iZeta,iCoor,ia(iCoor)-2,ib(iCoor)-2)* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor) )) - End If - If (ib(jCoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,iCoor)) = - & Final(iZeta,ipa,ipb,I(6,iCoor,iCoor)) - & +rKappa(iZeta)*Dble(ia(iCoor)*(ia(iCoor)-1)* - & ib(jCoor)*(ib(jCoor)-1))* - & (Rnxyz(iZeta,iCoor,ia(iCoor)-2,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor)-2)* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor) )) - End If - If (ib(kCoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,iCoor)) = - & Final(iZeta,ipa,ipb,I(6,iCoor,iCoor)) - & +rKappa(iZeta)*Dble(ia(iCoor)*(ia(iCoor)-1)* - & ib(kCoor)*(ib(kCoor)-1))* - & (Rnxyz(iZeta,iCoor,ia(iCoor)-2,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor),ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor),ib(kCoor)-2)) - End If - End If - 30 Continue - End If - 5 Continue -* -* -* Integrals like dI/dxdz -* - Do 57 kCoor=1,3 - iCoor=Mod(kCoor,3)+1 - jCoor=Mod(iCoor,3)+1 - iMax=Max(iCoor,jCoor) - jCoor=Min(iCoor,jCoor) - iCoor=iMax - If (IfHss(0,iCoor-1,0,jCoor-1)) Then - Do 35 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))=rKappa(iZeta)* - & ((Two*Alpha(iZeta))**2 * - & ((Two*Beta(iZeta))**2* - & (Rnxyz(iZeta,iCoor,ia(iCoor)+1,ib(iCoor)+2)* - & Rnxyz(iZeta,jCoor,ia(jCoor)+1,ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor) )+ - & Rnxyz(iZeta,iCoor,ia(iCoor)+1,ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor)+1,ib(jCoor)+2)* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor) )+ - & Rnxyz(iZeta,iCoor,ia(iCoor)+1,ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor)+1,ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)+2)) - & -Three*Two*Beta(iZeta)* - & Rnxyz(iZeta,iCoor,ia(iCoor)+1,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor)+1,ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)))) - if (lb.gt.0) Then - Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))- - & rKappa(iZeta)* - & (Two*Alpha(iZeta))**2 * - & Four*Beta(iZeta)*Dble(lb)* - & Rnxyz(iZeta,iCoor,ia(iCoor)+1,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor)+1,ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)) - End If - if (ib(icoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))+ - & rKappa(iZeta)* - & (Two*Alpha(iZeta))**2 * - & Dble(ib(icoor)*(ib(icoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor)+1,ib(iCoor)-2)* - & Rnxyz(iZeta,jCoor,ia(jCoor)+1,ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)) - End If - if (ib(jcoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))+ - & rKappa(iZeta)* - & (Two*Alpha(iZeta))**2 * - & Dble(ib(jcoor)*(ib(jcoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor)+1,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor)+1,ib(jCoor)-2)* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)) - End If - if (ib(kcoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))+ - & rKappa(iZeta)* - & (Two*Alpha(iZeta))**2 * - & Dble(ib(kcoor)*(ib(kcoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor)+1,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor)+1,ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)-2) - End If - if (ia(icoor).gt.0) Then - Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))- - & rKappa(iZeta)* - & Dble(ia(icoor))*Two*Alpha(iZeta)* - & ((Two*Beta(iZeta))**2* - & (Rnxyz(iZeta,iCoor,ia(iCoor)-1,ib(iCoor)+2)* - & Rnxyz(iZeta,jCoor,ia(jCoor)+1, ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor) )+ - & Rnxyz(iZeta,iCoor,ia(iCoor)-1,ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor)+1,ib(jCoor)+2)* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor) )+ - & Rnxyz(iZeta,iCoor,ia(iCoor)-1,ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor)+1, ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)+2)) - & -Three*Two*Beta(iZeta)* - & Rnxyz(iZeta,iCoor,ia(iCoor)-1,ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor)+1, ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor) )) - if (lb.gt.0) Then - Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))+ - & rKappa(iZeta)* - & Two*Alpha(iZeta)*Dble(ia(iCoor)) * - & Four*Beta(iZeta)*Dble(lb)* - & Rnxyz(iZeta,iCoor,ia(iCoor)-1,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor)+1,ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)) - End If - if (ib(icoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))- - & rKappa(iZeta)* - & Two*Alpha(iZeta)*Dble(ia(iCoor) * - & ib(icoor)*(ib(icoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor)-1,ib(iCoor)-2)* - & Rnxyz(iZeta,jCoor,ia(jCoor)+1,ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)) - End If - if (ib(jcoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))- - & rKappa(iZeta)* - & Two*Alpha(iZeta)*Dble(ia(iCoor) * - & ib(jcoor)*(ib(jcoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor)-1,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor)+1,ib(jCoor)-2)* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)) - End If - if (ib(kcoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))- - & rKappa(iZeta)* - & Two*Alpha(iZeta) *Dble(ia(iCoor)* - & ib(kcoor)*(ib(kcoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor)-1,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor)+1,ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)-2) - End If - End If - if (ia(jcoor).gt.0) Then - Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))- - & rKappa(iZeta)* - & Dble(ia(jcoor))*Two*Alpha(iZeta)* - & ((Two*Beta(iZeta))**2* - & (Rnxyz(iZeta,iCoor,ia(iCoor)+1,ib(iCoor)+2)* - & Rnxyz(iZeta,jCoor,ia(jCoor)-1, ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor) )+ - & Rnxyz(iZeta,iCoor,ia(iCoor)+1,ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor)-1,ib(jCoor)+2)* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor) )+ - & Rnxyz(iZeta,iCoor,ia(iCoor)+1,ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor)-1, ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)+2)) - & -Three*Two*Beta(iZeta)* - & Rnxyz(iZeta,iCoor,ia(iCoor)+1,ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor)-1, ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor) )) - if (lb.gt.0) Then - Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))+ - & rKappa(iZeta)* - & Two*Alpha(iZeta)*Dble(ia(jCoor)) * - & Four*Beta(iZeta)*Dble(lb)* - & Rnxyz(iZeta,iCoor,ia(iCoor)+1,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor)-1,ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)) - End If - if (ib(icoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))- - & rKappa(iZeta)* - & Two*Alpha(iZeta)*Dble(ia(jCoor)* - & ib(icoor)*(ib(icoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor)+1,ib(iCoor)-2)* - & Rnxyz(iZeta,jCoor,ia(jCoor)-1,ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)) - End If - if (ib(jcoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))- - & rKappa(iZeta)* - & Two*Alpha(iZeta)*Dble(ia(jCoor)* - & ib(jcoor)*(ib(jcoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor)+1,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor)-1,ib(jCoor)-2)* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)) - End If - if (ib(kcoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))- - & rKappa(iZeta)* - & Two*Alpha(iZeta)*Dble(ia(jCoor)) * - & Dble(ib(kcoor)*(ib(kcoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor)+1,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor)-1,ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)-2) - End If - End If - if ((ia(iCoor).gt.0).and.(ia(jCoor).gt.0)) Then - Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))+ - & rKappa(iZeta)* - & Dble(ia(iCoor)*ia(jCoor))* - & ((Two*Beta(iZeta))**2* - & (Rnxyz(iZeta,iCoor,ia(iCoor)-1,ib(iCoor)+2)* - & Rnxyz(iZeta,jCoor,ia(jCoor)-1,ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor) )+ - & Rnxyz(iZeta,iCoor,ia(iCoor)-1,ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor)-1,ib(jCoor)+2)* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor) )+ - & Rnxyz(iZeta,iCoor,ia(iCoor)-1,ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor)-1,ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)+2)) - & -Three*Two*Beta(iZeta)* - & Rnxyz(iZeta,iCoor,ia(iCoor)-1,ib(iCoor) )* - & Rnxyz(iZeta,jCoor,ia(jCoor)-1,ib(jCoor) )* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor) )) - if (lb.gt.0) Then - Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))- - & rKappa(iZeta)* - & Dble(ia(iCoor)*ia(jCoor)) * - & Four*Beta(iZeta)*Dble(lb)* - & Rnxyz(iZeta,iCoor,ia(iCoor)-1,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor)-1,ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)) - End If - if (ib(icoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))+ - & rKappa(iZeta)* - & Dble(ia(iCoor)*ia(jCoor)* - & ib(icoor)*(ib(icoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor)-1,ib(iCoor)-2)* - & Rnxyz(iZeta,jCoor,ia(jCoor)-1,ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)) - End If - if (ib(jcoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))+ - & rKappa(iZeta)* - & Dble(ia(iCoor)*ia(jCoor)* - & ib(jcoor)*(ib(jcoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor)-1,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor)-1,ib(jCoor)-2)* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)) - End If - if (ib(kcoor).gt.1) Then - Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))= - & Final(iZeta,ipa,ipb,I(6,iCoor,jCoor))+ - & rKappa(iZeta)* - & Dble(ia(iCoor)*ia(jCoor)* - & ib(kcoor)*(ib(kcoor)-1))* - & Rnxyz(iZeta,iCoor,ia(iCoor)-1,ib(iCoor))* - & Rnxyz(iZeta,jCoor,ia(jCoor)-1,ib(jCoor))* - & Rnxyz(iZeta,kCoor,ia(kCoor), ib(kCoor)-2) - End If - End If - - 35 Continue - End If - 57 Continue - 21 Continue - 20 Continue - 11 Continue - 10 Continue -* -* Trace the Hessian integrals -* - nDAO = nZeta * (la+1)*(la+2)/2 * (lb+1)*(lb+2)/2 -c If (iPrint.ge.99) Then -c Call RecPrt(' S(1)',' ',Final,nDAO,21) -c Call RecPrt(' D ',' ',DAO,nDAO,1) -c End If - Do 90 iIrrep=0,nIrrep-1 - Do 100 iCnt=0,1 - Do 105 iCar=1,3 - Do 110 jCnt=0,1 - Do 115 jCar=1,3 - If (IndHss(iCnt,iCar-1,jCnt,jCar-1,iIrrep).ne.0) Then -* -* Accumulate contribution to the Hessian -* -* -* Get the characteristics of the diff operator -* - iCh=iEOr(2**(iCar-1)*iCnt,2**(jCar-1)*jCnt) -* -* Get the character of the operator in the present irrep -* - ps=DBLE(iChTbl(iIrrep,nOp(2))** - & (iCnt+jCnt)) -* -* Get the transf. character of the diff. operator -* - ps = ps*DBLE(iPrmt(nOp(2),iCh)) -* -* If the over triangular diff. are needed multiply by two instead -* - if ((iCnt.ne.jCnt).and.(iCar.eq.jCar).and. - & (Abs(indgrd(iCar-1,iCnt,iIrrep)).eq. - & iAbs(indgrd(jCar-1,jCnt,iIrrep)))) Then - ps=ps*Two - End If - iHess = Abs(IndHss(iCnt,iCar-1,jCnt,jCar-1,iIrrep)) - Fact = DBLE(iStab(iCnt)*iStab(jCnt))/DBLE(nIrrep**2) - Fact = Fact * ps - if (IndHss(iCnt,iCar-1,jCnt,jCar-1,iIrrep).gt.0) Then - oj=DDot_(nDAO,DAO,1,Final(1,1,1,I(6,iCar,jCar)),1) - Hess(iHess) = Hess(iHess) + Fact*oj - Else - Fact=Fact*DBLE((-1)**(icnt+jcnt)) - oj=DDot_(nDAO,DAO,1,Final(1,1,1,I(6,Max(iCar,jCar), - & Min(iCar,jCar))),1) - Hess(iHess) = Hess(iHess) + Fact*oj - End If - End If - 115 Continue - 110 Continue - 105 Continue - 100 Continue - 90 Continue -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/cmbnt2.F90 openmolcas-22.10/src/mckinley/cmbnt2.F90 --- openmolcas-22.02/src/mckinley/cmbnt2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cmbnt2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,404 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1994, Anders Bernhardsson * +! 1994, Roland Lindh * +!*********************************************************************** + +subroutine CmbnT2(Rnxyz,nZeta,la,lb,Zeta,rKappa,rFinal,Alpha,Beta,Hess,nHess,DAO,IfHss,IndHss,indgrd,iu,iv,nOp) +!*********************************************************************** +! * +! Object: compute the 2nd derivative of the overlap matrix. * +! * +!*********************************************************************** + +use Index_Functions, only: C_Ind, iTri, nTri_Elem1 +use Symmetry_Info, only: nIrrep, iChTbl +use Constants, only: One, Two, Four, Six, Half, OneHalf +use Definitions, only: wp, iwp, r8 + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb, nHess, IndHss(0:1,0:2,0:1,0:2,0:nIrrep-1), indgrd(0:2,0:1,0:nirrep-1), iu, iv, & + nOp(2) +real(kind=wp), intent(in) :: Rnxyz(nZeta,3,0:la+2,0:lb+2), Zeta(nZeta), Alpha(nZeta), Beta(nZeta), & + DAO(nZeta,nTri_Elem1(la),nTri_Elem1(lb)) +real(kind=wp), intent(inout) :: rKappa(nZeta), rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),6), Hess(nHess) +logical(kind=iwp), intent(in) :: IfHss(0:1,0:2,0:1,0:2) +integer(kind=iwp) :: i, ia(3), iax, iay, ib(3), ibx, iby, iCar, ich, iCnt, iCoor, iHess, iIrrep, iMax, ipa, ipb, istab(0:1), & + iyaMax, iybMax, jCar, jCnt, jCoor, kCoor, nDAO +real(kind=wp) :: Fact, oj, ps +integer(kind=iwp), external :: iPrmt +real(kind=r8), external :: DDot_ + +!iRout = 134 +iStab(0) = iu +iStab(1) = iv +!iPrint = nPrint(iRout) + +rKappa(:) = Half*rKappa*Zeta**(-OneHalf) +!if (iPrint >= 99) then +! call RecPrt(' In CmbnT2: Zeta ',' ',Zeta,1,nZeta) +! call RecPrt(' In CmbnT2: rKappa',' ',rKappa,1,nZeta) +! call RecPrt(' In CmbnT2: Alpha ',' ',Alpha,1,nZeta) +! call RecPrt(' In CmbnT2: Beta ',' ',Beta,1,nZeta) +!end if +do iax=0,la + ia(1) = iax + iyaMax = la-ia(1) + do ibx=0,lb + ib(1) = ibx + iybMax = lb-ib(1) + do iay=0,iyaMax + ia(2) = iay + ia(3) = la-ia(2)-ia(1) + ipa = C_Ind(la,ia(1),ia(3)) + do iby=0,iybMax + ib(2) = iby + ib(3) = lb-ib(2)-ib(1) + ipb = C_Ind(lb,ib(1),ib(3)) + + ! Combine overlap integrals + + ! Integrals like dI/dx1dx1 + + do iCoor=1,3 + jCoor = mod(iCoor,3)+1 + kCoor = mod(jCoor,3)+1 + i = iTri(iCoor,iCoor) + if (.not. IfHss(0,iCoor-1,0,iCoor-1)) cycle + rFinal(:,ipa,ipb,i) = rKappa(:)*((Two*Alpha(:))**2*((Two*Beta(:))**2*(Rnxyz(:,iCoor,ia(iCoor)+2,ib(iCoor)+2)* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))+ & + Rnxyz(:,iCoor,ia(iCoor)+2,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor)+2)* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))+ & + Rnxyz(:,iCoor,ia(iCoor)+2,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)+2))- & + Six*Beta(:)*Rnxyz(:,iCoor,ia(iCoor)+2,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)))- & + Two*Alpha(:)*((Two*Beta(:))**2*(Rnxyz(:,iCoor,ia(iCoor),ib(iCoor)+2)* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))+ & + Rnxyz(:,iCoor,ia(iCoor),ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor)+2)* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))+ & + Rnxyz(:,iCoor,ia(iCoor),ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)+2))- & + Six*Beta(:)*Rnxyz(:,iCoor,ia(iCoor),ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)))) + if (lb > 0) & + rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)-rKappa(:)* & + ((Two*Alpha(:))**2*Four*Beta(:)*real(lb,kind=wp)*Rnxyz(:,iCoor,ia(iCoor)+2,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))- & + Two*Alpha(:)*(Four*Beta(:))*real(lb,kind=wp)*Rnxyz(:,iCoor,ia(iCoor),ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))) + if (ib(icoor) > 1) & + rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)+rKappa(:)* & + ((Two*Alpha(:))**2*real(ib(icoor)*(ib(icoor)-1),kind=wp)*Rnxyz(:,iCoor,ia(iCoor)+2,ib(iCoor)-2)* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))- & + Two*Alpha(:)*real(ib(icoor)*(ib(icoor)-1),kind=wp)*Rnxyz(:,iCoor,ia(iCoor),ib(iCoor)-2)* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))) + if (ib(jcoor) > 1) & + rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)+rKappa(:)* & + ((Two*Alpha(:))**2*real(ib(jcoor)*(ib(jcoor)-1),kind=wp)*Rnxyz(:,iCoor,ia(iCoor)+2,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor)-2)* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))- & + Two*Alpha(:)*real(ib(jcoor)*(ib(jcoor)-1),kind=wp)*Rnxyz(:,iCoor,ia(iCoor),ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor)-2)* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))) + if (ib(kcoor) > 1) & + rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)+rKappa(:)* & + ((Two*Alpha(:))**2*real(ib(kcoor)*(ib(kcoor)-1),kind=wp)*Rnxyz(:,iCoor,ia(iCoor)+2,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)-2)- & + Two*Alpha(:)*real(ib(kcoor)*(ib(kcoor)-1),kind=wp)*Rnxyz(:,iCoor,ia(iCoor),ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)-2)) + if (ia(iCoor) > 0) then + rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)-rKappa(:)*Four*Alpha(:)*real(ia(iCoor),kind=wp)* & + ((Two*Beta(:))**2*(Rnxyz(:,iCoor,ia(iCoor),ib(iCoor)+2)* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))+ & + Rnxyz(:,iCoor,ia(iCoor),ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor)+2)* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))+ & + Rnxyz(:,iCoor,ia(iCoor),ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)+2))- & + Six*Beta(:)*Rnxyz(:,iCoor,ia(iCoor),ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))) + if (lb > 0) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)+rKappa(:)* & + Four*Beta(:)*real(lb,kind=wp)*Four*Alpha(:)*real(ia(iCoor),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor),ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ib(iCoor) > 1) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)-rKappa(:)* & + real(ib(icoor)*(ib(icoor)-1),kind=wp)*Four*Alpha(:)*real(ia(iCoor),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor),ib(iCoor)-2)* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ib(jCoor) > 1) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)-rKappa(:)* & + real(ib(jcoor)*(ib(jcoor)-1),kind=wp)*Four*Alpha(:)*real(ia(iCoor),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor),ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor)-2)* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ib(kCoor) > 1) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)-rKappa(:)* & + real(ib(kcoor)*(ib(kcoor)-1),kind=wp)*Four*Alpha(:)*real(ia(iCoor),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor),ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)-2) + end if + if (ia(iCoor) > 1) then + rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)+rKappa(:)*real(ia(iCoor)*(ia(iCoor)-1),kind=wp)* & + ((Two*Beta(:))**2*(Rnxyz(:,iCoor,ia(iCoor)-2,ib(iCoor)+2)* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))+ & + Rnxyz(:,iCoor,ia(iCoor)-2,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor)+2)* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))+ & + Rnxyz(:,iCoor,ia(iCoor)-2,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)+2))- & + Six*Beta(:)*Rnxyz(:,iCoor,ia(iCoor)-2,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))) + if (lb > 0) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)-rKappa(:)* & + real(ia(iCoor)*(ia(iCoor)-1),kind=wp)*Four*Beta(:)*real(lb,kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)-2,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ib(iCoor) > 1) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)+rKappa(:)* & + real(ia(iCoor)*(ia(iCoor)-1)*ib(iCoor)*(ib(iCoor)-1),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)-2,ib(iCoor)-2)* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ib(jCoor) > 1) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)+rKappa(:)* & + real(ia(iCoor)*(ia(iCoor)-1)*ib(jCoor)*(ib(jCoor)-1),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)-2,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor)-2)* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ib(kCoor) > 1) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)+rKappa(:)* & + real(ia(iCoor)*(ia(iCoor)-1)*ib(kCoor)*(ib(kCoor)-1),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)-2,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor),ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)-2) + end if + end do + + ! Integrals like dI/dxdz + + do kCoor=1,3 + iCoor = mod(kCoor,3)+1 + jCoor = mod(iCoor,3)+1 + iMax = max(iCoor,jCoor) + jCoor = min(iCoor,jCoor) + iCoor = iMax + i = iTri(iCoor,jCoor) + if (.not. IfHss(0,iCoor-1,0,jCoor-1)) cycle + rFinal(:,ipa,ipb,i) = rKappa(:)*(Two*Alpha(:))**2*((Two*Beta(:))**2*(Rnxyz(:,iCoor,ia(iCoor)+1,ib(iCoor)+2)* & + Rnxyz(:,jCoor,ia(jCoor)+1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))+ & + Rnxyz(:,iCoor,ia(iCoor)+1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)+1,ib(jCoor)+2)* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))+ & + Rnxyz(:,iCoor,ia(iCoor)+1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)+1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)+2))- & + Six*Beta(:)*Rnxyz(:,iCoor,ia(iCoor)+1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)+1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))) + if (lb > 0) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)-rKappa(:)*(Two*Alpha(:))**2*Four*Beta(:)*real(lb,kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)+1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)+1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ib(icoor) > 1) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)+rKappa(:)* & + (Two*Alpha(:))**2*real(ib(icoor)*(ib(icoor)-1),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)+1,ib(iCoor)-2)* & + Rnxyz(:,jCoor,ia(jCoor)+1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ib(jcoor) > 1) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)+rKappa(:)* & + (Two*Alpha(:))**2*real(ib(jcoor)*(ib(jcoor)-1),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)+1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)+1,ib(jCoor)-2)* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ib(kcoor) > 1) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)+rKappa(:)* & + (Two*Alpha(:))**2*real(ib(kcoor)*(ib(kcoor)-1),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)+1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)+1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)-2) + if (ia(icoor) > 0) then + rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)-rKappa(:)*real(ia(icoor),kind=wp)*Two*Alpha(:)* & + ((Two*Beta(:))**2*(Rnxyz(:,iCoor,ia(iCoor)-1,ib(iCoor)+2)* & + Rnxyz(:,jCoor,ia(jCoor)+1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))+ & + Rnxyz(:,iCoor,ia(iCoor)-1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)+1,ib(jCoor)+2)* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))+ & + Rnxyz(:,iCoor,ia(iCoor)-1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)+1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)+2))- & + Six*Beta(:)*Rnxyz(:,iCoor,ia(iCoor)-1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)+1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))) + if (lb > 0) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)+rKappa(:)* & + Two*Alpha(:)*real(ia(iCoor))*Four*Beta(:)*real(lb,kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)-1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)+1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ib(icoor) > 1) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)-rKappa(:)* & + Two*Alpha(:)*real(ia(iCoor)*ib(icoor)*(ib(icoor)-1),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)-1,ib(iCoor)-2)* & + Rnxyz(:,jCoor,ia(jCoor)+1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ib(jcoor) > 1) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)-rKappa(:)* & + Two*Alpha(:)*real(ia(iCoor)*ib(jcoor)*(ib(jcoor)-1),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)-1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)+1,ib(jCoor)-2)* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ib(kcoor) > 1) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)-rKappa(:)* & + Two*Alpha(:)*real(ia(iCoor)*ib(kcoor)*(ib(kcoor)-1),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)-1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)+1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)-2) + end if + if (ia(jcoor) > 0) then + rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)-rKappa(:)*real(ia(jcoor),kind=wp)*Two*Alpha(:)* & + ((Two*Beta(:))**2*(Rnxyz(:,iCoor,ia(iCoor)+1,ib(iCoor)+2)* & + Rnxyz(:,jCoor,ia(jCoor)-1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))+ & + Rnxyz(:,iCoor,ia(iCoor)+1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)-1,ib(jCoor)+2)* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))+ & + Rnxyz(:,iCoor,ia(iCoor)+1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)-1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)+2))- & + Six*Beta(:)*Rnxyz(:,iCoor,ia(iCoor)+1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)-1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))) + if (lb > 0) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)+rKappa(:)* & + Two*Alpha(:)*real(ia(jCoor))*Four*Beta(:)*real(lb,kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)+1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)-1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ib(icoor) > 1) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)-rKappa(:)* & + Two*Alpha(:)*real(ia(jCoor)*ib(icoor)*(ib(icoor)-1),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)+1,ib(iCoor)-2)* & + Rnxyz(:,jCoor,ia(jCoor)-1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ib(jcoor) > 1) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)-rKappa(:)* & + Two*Alpha(:)*real(ia(jCoor)*ib(jcoor)*(ib(jcoor)-1),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)+1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)-1,ib(jCoor)-2)* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ib(kcoor) > 1) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)-rKappa(:)* & + Two*Alpha(:)*real(ia(jCoor),kind=wp)*real(ib(kcoor)*(ib(kcoor)-1),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)+1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)-1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)-2) + end if + if ((ia(iCoor) > 0) .and. (ia(jCoor) > 0)) then + rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)+rKappa(:)*real(ia(iCoor)*ia(jCoor),kind=wp)* & + ((Two*Beta(:))**2*(Rnxyz(:,iCoor,ia(iCoor)-1,ib(iCoor)+2)* & + Rnxyz(:,jCoor,ia(jCoor)-1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))+ & + Rnxyz(:,iCoor,ia(iCoor)-1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)-1,ib(jCoor)+2)* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))+ & + Rnxyz(:,iCoor,ia(iCoor)-1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)-1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)+2))- & + Six*Beta(:)*Rnxyz(:,iCoor,ia(iCoor)-1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)-1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor))) + if (lb > 0) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)-rKappa(:)* & + real(ia(iCoor)*ia(jCoor),kind=wp)*Four*Beta(:)*real(lb,kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)-1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)-1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ib(icoor) > 1) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)+rKappa(:)* & + real(ia(iCoor)*ia(jCoor)*ib(icoor)*(ib(icoor)-1),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)-1,ib(iCoor)-2)* & + Rnxyz(:,jCoor,ia(jCoor)-1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ib(jcoor) > 1) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)+rKappa(:)* & + real(ia(iCoor)*ia(jCoor)*ib(jcoor)*(ib(jcoor)-1),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)-1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)-1,ib(jCoor)-2)* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)) + if (ib(kcoor) > 1) rFinal(:,ipa,ipb,i) = rFinal(:,ipa,ipb,i)+rKappa(:)* & + real(ia(iCoor)*ia(jCoor)*ib(kcoor)*(ib(kcoor)-1),kind=wp)* & + Rnxyz(:,iCoor,ia(iCoor)-1,ib(iCoor))* & + Rnxyz(:,jCoor,ia(jCoor)-1,ib(jCoor))* & + Rnxyz(:,kCoor,ia(kCoor),ib(kCoor)-2) + end if + end do + end do + end do + end do +end do + +! Trace the Hessian integrals + +nDAO = nZeta*nTri_Elem1(la)*nTri_Elem1(lb) +!if (iPrint >= 99) then +! call RecPrt(' S(1)',' ',rFinal,nDAO,21) +! call RecPrt(' D ',' ',DAO,nDAO,1) +!end if +do iIrrep=0,nIrrep-1 + do iCnt=0,1 + do iCar=1,3 + do jCnt=0,1 + do jCar=1,3 + i = iTri(iCar,jCar) + if (IndHss(iCnt,iCar-1,jCnt,jCar-1,iIrrep) /= 0) then + + ! Accumulate contribution to the Hessian + + ! Get the characteristics of the diff operator + + iCh = ieor(2**(iCar-1)*iCnt,2**(jCar-1)*jCnt) + + ! Get the character of the operator in the present irrep + + ps = real(iChTbl(iIrrep,nOp(2))**(iCnt+jCnt),kind=wp) + + ! Get the transf. character of the diff. operator + + ps = ps*real(iPrmt(nOp(2),iCh),kind=wp) + + ! If the over triangular diff. are needed multiply by two instead + + if ((iCnt /= jCnt) .and. (iCar == jCar) .and. & + (abs(indgrd(iCar-1,iCnt,iIrrep)) == abs(indgrd(jCar-1,jCnt,iIrrep)))) ps = ps*Two + iHess = abs(IndHss(iCnt,iCar-1,jCnt,jCar-1,iIrrep)) + Fact = real(iStab(iCnt)*iStab(jCnt),kind=wp)/real(nIrrep**2,kind=wp) + Fact = Fact*ps + if (IndHss(iCnt,iCar-1,jCnt,jCar-1,iIrrep) <= 0) Fact = Fact*(-One)**(iCnt+jCnt) + oj = DDot_(nDAO,DAO,1,rFinal(:,:,:,i),1) + Hess(iHess) = Hess(iHess)+Fact*oj + end if + end do + end do + end do + end do +end do + +return + +end subroutine CmbnT2 diff -Nru openmolcas-22.02/src/mckinley/cnt1el2.f openmolcas-22.10/src/mckinley/cnt1el2.f --- openmolcas-22.02/src/mckinley/cnt1el2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cnt1el2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,443 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine Cnt1El2(Kernel,KrnlMm,Label, - & iDCnt,iDCar,loper,rHrmt,DiffOp, - & Lab_Dsk,iadd,isym,kcar,nordop) -************************************************************************ -* * -* Object: to compute the one-electron integrals. The method employed at* -* this point is not necessarily the fastest. However, the total* -* time for the computation of integrals will depend on the time* -* spent in computing the two-electron integrals. * -* The memory at this point is assumed to be large enough to do * -* the computation in core. * -* The data is structured with respect to four indices, two (my * -* ny or i j) refer to primitives or basis functions and two (a * -* b) refer to the components of the cartesian or spherical * -* harmonic gaussians. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* January '90 * -* Rewritten for gradients needed in hessian calculations * -* and general operator treatment * -* May '95 By: * -* Anders Bernhardsson , Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN. * -************************************************************************ - use Real_Spherical - use iSD_data - use Basis_Info - use Center_Info - use Symmetry_Info, only: nIrrep, iOper - use Sizes_of_Seward, only:S - Implicit Real*8 (A-H,O-Z) - External Kernel, KrnlMm -#include "Molcas.fh" -#include "real.fh" -#include "stdalloc.fh" -#include "disp.fh" -#include "disp2.fh" -#include "nsd.fh" -#include "setup.fh" -* log trans integer dcent - Real*8 A(3), B(3), RB(3),CCoor(3) - Character Label*8 - Integer nOp(2), ip(8), - & iDCRR(0:7), iDCRT(0:7), iStabM(0:7), iStabO(0:7), - & IndGrd(0:7) - Logical IfGrd(3,2),EQ,DiffOP,DiffCnt,Trans(2) - Integer, Parameter:: iTwoj(0:7)=[1,2,4,8,16,32,64,128] - Character(LEN=8) Lab_dsk - Real*8, Allocatable:: Zeta(:), ZI(:), PCoor(:,:), Kappa(:), - & Kern(:), Fnl(:), ScrSph(:), SO(:), - & Integrals(:), Scr(:) - Logical, External :: TF -* -* Statement function -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* -*-----Compute the number of blocks from each component of the operator -* and the irreps it will span. -* -* - Call FZero(CCoor,3) - Call iCopy(nIrrep,[0],0,IndGrd,1) - loper=0 - nnIrrep=nIrrep - If (sIrrep) nnIrrep=1 - Do iIrrep=0,nnIrrep-1 - jIrrep=nropr(ieor(ioper(iIrrep), ioper(isym))) - nDisp = IndDsp(iDcnt,iIrrep) - Do iCar=1,3 - iComp = 2**(iCar-1) - If ( TF(iDCnt,iIrrep,iComp)) Then - ndisp=ndisp+1 - If (iDCar.eq.icar) Then - loper=loper+2**jIrrep - IndGrd(jIrrep) = nDisp - End If - End If - End Do - End Do - nIC=0 - If (loper.eq.0) Return - - Call ICopy(nIrrep,[0],0,ip,1) - - iStart=1 - Do iIrrep =0,nIrrep-1 - If (iAnd(2**iIrrep,loper).ne.0) Then - LenInt=nFck(iIrrep) - nIc=nIC+1 - ip(NIC)=iStart - iStart=iStart+LenInt - End If - End Do - LenInt_Tot=iStart - 1 - Call mma_allocate(Integrals,LenInt_Tot,Label='Integrals') - Integrals(:)=Zero - - - Call SOS(iStabO,nStabO,1) -* -*-----Auxiliary memory allocation. -* -* * -************************************************************************ -* * - Call Set_Basis_Mode('Valence') - Call Nr_Shells(nSkal) - Call Setup_iSD() -* * -************************************************************************ -* * -* -*-----Double loop over shells. -* - Do iS = 1, nSkal - iShll = iSD( 0,iS) - iAng = iSD( 1,iS) - iCmp = iSD( 2,iS) - iBas = iSD( 3,iS) - iPrim = iSD( 5,iS) - iAO = iSD( 7,iS) - mdci = iSD(10,iS) - iShell = iSD(11,iS) - iCnttp = iSD(13,iS) - iCnt = iSD(14,iS) - A(1:3)=dbsc(iCnttp)%Coor(1:3,iCnt) -* - Do jS = 1, iS - jShll = iSD( 0,jS) - jAng = iSD( 1,jS) - jCmp = iSD( 2,jS) - jBas = iSD( 3,jS) - jPrim = iSD( 5,jS) - jAO = iSD( 7,jS) - mdcj = iSD(10,jS) - jShell = iSD(11,jS) - jCnttp = iSD(13,jS) - jCnt = iSD(14,jS) - B(1:3)=dbsc(jCnttp)%Coor(1:3,jCnt) -* -*-------Call kernel routine to get memory requirement. Observe, however -* that kernels which will use the HRR will allocate that -* memory internally. -* - maxi=S%maxPrm(iAng)*S%maxprm(jang) - Call mma_allocate(Zeta,maxi,Label='Zeta') - Call mma_allocate(ZI,maxi,Label='ZI') - Call mma_allocate(Kappa,maxi,Label='Kappa') - Call mma_allocate(PCoor,maxi,3,Label='PCoor') - Call KrnlMm(nOrder,MemKer,iAng,jAng,nOrdOp) -* -* Memory requirements for contraction and Symmetry -* adoption of derivatives. -* - lFinal = S%MaxPrm(iAng) * S%MaxPrm(jAng) * - & nElem(iAng)*nElem(jAng)*nIrrep -* - MemKrn=Max(MemKer*Maxi,lFinal) - Call mma_allocate(Kern,MemKrn,Label='Kern') -* -* Save some memory and use Scrt area for -* transformation -* -* Allocate memory for the final integrals all in the -* primitive basis. -* - Call mma_allocate(Fnl,lFinal,Label='Fnl') -* -* Scratch area for the transformation to spherical gaussians -* - nScr1=S%MaxBas(iAng)*S%MaxBas(jAng)*nElem(iAng)*nElem(jAng)*nIC - Call mma_allocate(ScrSph,nScr1,Label='ScfSph') -* -* At this point we can compute Zeta. -* This is now computed in the ij or ji order. -* - Call ZXia(Zeta,ZI, - & iPrim,jPrim,Shells(iShll)%Exp, - & Shells(jShll)%Exp) -* - DiffCnt=(mdci.eq.iDCnt).or.(mdcj.eq.iDCnt) - If ((.not.DiffCnt).and.(.not.DiffOp)) Goto 131 - Call lCopy(6,[.false.],0,IfGrd,1) - Call lCopy(2,[.false.],0,trans,1) - If (mdci.eq.iDCnt) Then - IfGrd(idCar,1)=.true. - End If - If (mdcj.eq.iDCnt) Then - IfGrd(idCar,2)=.true. - End If -* - If (IfGrd(iDCar,1).and.IfGrd(iDCar,2).and. - & (.not.DiffOp)) Then - IfGrd(iDCar,2)=.false. - Trans(2)=.true. - End If - If (Label.eq.'CONNECTI') Trans(2)=.false. -* -* Allocate memory for SO integrals that will be generated by -* this batch of AO integrals. -* - nSO=0 - Do iIrrep=0,nIrrep-1 - If (iAnd(loper,2**iIrrep).ne.0) Then - iSmLbl=2**iIrrep - nSO=nSO+MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO) - End If - End Do -c If (iPrint.ge.29) Write (*,*) ' nSO=',nSO - If (nSO.eq.0) Go To 131 - Call mma_allocate(SO,iBas*jBas*nSO,Label='SO') - SO(:)=Zero -* -* Find the DCR for A and B -* - Call DCR(LmbdR,dc(mdci)%iStab,dc(mdci)%nStab, - & dc(mdcj)%iStab,dc(mdcj)%nStab,iDCRR,nDCRR) -* -* Find the stabilizer for A and B -* - Call Inter(dc(mdci)%iStab,dc(mdci)%nStab, - & dc(mdcj)%iStab,dc(mdcj)%nStab, - & iStabM,nStabM) -* - Call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) -* -* Compute normalization factor -* - iuv = dc(mdci)%nStab*dc(mdcj)%nStab - Fact = DBLE(iuv*nStabO) / DBLE(nIrrep**2 * LmbdT) - If (MolWgh.eq.1) Then - Fact = Fact * DBLE(nIrrep)**2 / DBLE(iuv) - Else If (MolWgh.eq.2) Then - Fact = sqrt(DBLE(iuv))*DBLE(nStabO)/DBLE(nIrrep*LmbdT) - End If -* -* Loops over symmetry operations acting on the basis. -* - nOp(1) = NrOpr(0) - if(jBas.lt.-999999) write(6,*) 'gcc overoptimization',nDCRR - Do 140 lDCRR = 0, nDCRR-1 - Call OA(iDCRR(lDCRR),B,RB) - nOp(2) = NrOpr(iDCRR(lDCRR)) - If (Label.ne.'CONNECTI' - & .and.EQ(A,RB).and. (.Not.DiffOp)) Go To 140 -* -* Compute kappa and P. -* - Call Setup1(Shells(iShll)%Exp,iPrim, - & Shells(jShll)%Exp,jPrim, - & A,RB,Kappa,PCoor,ZI) -* -* Compute AO integrals. -* for easy implementation of NA integrals. -* - Call Kernel(Shells(iShll)%Exp,iPrim, - & Shells(jShll)%Exp,jPrim, - & Zeta,ZI, - & Kappa,PCoor, - & Fnl,iPrim*jPrim, - & iAng,jAng,A,RB,nOrder,Kern, - & MemKrn,Ccoor,nOrdOp,IfGrd,IndGrd,nop, - & dc(mdci)%nStab, - & dc(mdcj)%nStab,nic,idcar,idcnt, - & iStabM,nStabM,trans,kcar,isym) -* -* -* Transform from primitive to contracted basis functions. -* Order of transformation is fixed. It has been shown through -* testing that the index order ij,ab will give a performance -* that is up to 20% faster than the ab,ij index order. -* -* -* Transform i,jabx to jabx,I - kk=nElem(iAng)*nElem(jAng)*nIC - Call DGEMM_('T','N', - & jPrim*kk,iBas,iPrim, - & 1.0d0,Fnl,iPrim, - & Shells(iShll)%pCff,iPrim, - & 0.0d0,Kern,jPrim*kk) -* -* Transform j,abxI to abxI,J -* - Call DGEMM_('T','N', - & kk*iBas,jBas,jPrim, - & 1.0d0,Kern,jPrim, - & Shells(jShll)%pCff,jPrim, - & 0.0d0,Fnl,kk*iBas) -* -* Transform to spherical gaussians if needed. -* - kk=nElem(iAng)*nElem(jAng) -* - If (Shells(iShll)%Transf.or.Shells(jShll)%Transf) Then -* -* Result comes back as IJAB or IJAb -* - Call CarSph(Fnl,kk,iBas*jBas*nIC, - & Kern,nScr1, - & RSph(ipSph(iAng)),iAng, - & Shells(iShll)%Transf, - & Shells(iShll)%Prjct, - & RSph(ipSph(jAng)),jAng, - & Shells(jShll)%Transf, - & Shells(jShll)%Prjct,ScrSph,iCmp*jCmp) -* - Call DGeTmO(ScrSph,nIC,nIC, - & iBas*jBas*iCmp*jCmp, - & Kern,iBas*jBas*iCmp*jCmp) - -* - Else -* -* Transpose abx,IJ back to IJ,abx -* - Call DGeTmO(Fnl,kk*nIC,kk*nIC, - & iBas*jBas,Kern,iBas*jBas) - End If -* -* At this point accumulate the batch of integrals onto the -* final symmetry adapted integrals. -* -* If (iPrint.ge.99) Then -* Call RecPrt (' Accumulated SO integrals, so far...', -* & ' ',SO,iBas*jBas,nSO) -* End If -* -*------------Symmetry adapt component by component -* - iSOBlk = 1 - iIC=1 - Do iIrrep = 0, nIrrep-1 - iSmLbl=iAnd(lOper,iTwoj(iIrrep)) - mSO=MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO) - If (mSO.eq.0) Then - Do jIrrep = 0, nIrrep-1 - If (iAnd(iSmLbl,iTwoj(jIrrep)).ne.0) iIC = iIC + 1 - End Do - Else - Call SymAd1(iSmLbl,iAng,jAng,iCmp,jCmp, - & iShell,jShell,iShll,jShll,iAO,jAO, - & Kern,iBas,jBas,nIC,iIC, - & SO(iSOBlk),mSO,nOp) - iSOBlk = iSOBlk + mSO*iBas*jBas - End If - End Do -* - 140 Continue -* -* Multiply with factors due to projection operators -* - If (Fact.ne.One) Call DScal_(nSO*iBas*jBas,Fact,SO,1) -* -* Scatter the SO's on to the non-zero blocks of the -* lower triangle. -* - iSOBlk=1 - iIC=0 - Do iIrrep = 0, nIrrep-1 - If (iAnd(lOper,2**iIrrep).ne.0) Then - iSmlbl=2**iIrrep - iiC=iiC+1 - mSO=MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO) - If (nfck(iirrep).ne.0.and.mSO.ne.0) - & Call SOSctt(SO(iSOBlk),iBas,jBas,mSO, - & Integrals(ip(iIC)),nFck(iIrrep),iSmLbl, - & iCmp,jCmp,iShell,jShell, - & iAO,jAO,nIC,Label,2**iIrrep,rHrmt) - iSOBlk = iSOBlk + mSO*iBas*jBas - End If - End Do -* - Call mma_deallocate(SO) - 131 Continue - Call mma_deallocate(pCoor) - Call mma_deallocate(Kappa) - Call mma_deallocate(ZI) - Call mma_deallocate(Zeta) - Call mma_deallocate(ScrSph) - Call mma_deallocate(Fnl) - Call mma_deallocate(Kern) - - End Do - End Do - - Call Free_iSD() -* -* Compute properties or write integrals to disc and -* deallocate core. -* - nDens=0 - ndenssq=0 - Do iI=0,nIrrep-1 - ndenssq=ndenssq+nbas(ii)**2 - nDens=nDens+nBas(iI)*(nBas(iI)+1)/2 - End Do - nrOp=0 - - Call mma_allocate(Scr,ndenssq,Label='Scr') - Do 16 iIrrep = 0, nIrrep-1 - iSmLbl = 2**iIrrep - If (iAnd(ismLbl,loper).ne.0) Then - nrOp=nrOp+1 - jdisp=indgrd(iirrep) - kOper=2**iIrrep -* Write(*,*) koper,isym,jdisp,iirrep - If (iadd.ne.0) Then - irc=-1 - iopt=0 - call drdmck(irc,iOpt,Lab_dsk,jdisp,Scr,koper) - If (irc.ne.0) Call SysAbendMsg('cnt1el2', - & 'error during read in rdmck',' ') - call daxpy_(nfck(iirrep),one,scr,1,Integrals(ip(nrop)),1) - End If - irc=-1 - iopt=0 -* Write(*,*) Lab_dsk,jdisp,koper - call dwrmck(irc,iOpt,Lab_dsk,jdisp,Integrals(ip(nrop)), - & koper) - If (irc.ne.0) Call SysAbendMsg('cnt1el2', - & 'error during write in dwrmck',' ') - End If - 16 Continue -* - Call mma_deallocate(Scr) - Call mma_deallocate(Integrals) -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/cnt1el2.F90 openmolcas-22.10/src/mckinley/cnt1el2.F90 --- openmolcas-22.02/src/mckinley/cnt1el2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cnt1el2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,394 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Roland Lindh * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine Cnt1El2(Kernel,KrnlMm,Label,iDCnt,iDCar,loper,rHrmt,DiffOp,Lab_Dsk,iadd,isym,kcar,nordop) +!*********************************************************************** +! * +! Object: to compute the one-electron integrals. The method employed at* +! this point is not necessarily the fastest. However, the total* +! time for the computation of integrals will depend on the time* +! spent in computing the two-electron integrals. * +! The memory at this point is assumed to be large enough to do * +! the computation in core. * +! The data is structured with respect to four indices, two (my * +! ny or i j) refer to primitives or basis functions and two (a * +! b) refer to the components of the cartesian or spherical * +! harmonic gaussians. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! January '90 * +! Rewritten for gradients needed in hessian calculations * +! and general operator treatment * +! May '95 By: * +! Anders Bernhardsson , Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN. * +!*********************************************************************** + +use McKinley_global, only: nFck, sIrrep +use mck_interface, only: mck_mem, oneel_mck_kernel +use Index_Functions, only: nTri_Elem, nTri_Elem1 +use Real_Spherical, only: ipSph, RSph +use iSD_data, only: iSD +use Basis_Info, only: dbsc, MolWgh, nBas, Shells +use Center_Info, only: dc +use Symmetry_Info, only: iOper, nIrrep +use Sizes_of_Seward, only: S +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +procedure(oneel_mck_kernel) :: Kernel +procedure(mck_mem) :: KrnlMm +character(len=8), intent(in) :: Label, Lab_Dsk +integer(kind=iwp), intent(in) :: iDCnt, iDCar, iadd, isym, kcar, nordop +integer(kind=iwp), intent(out) :: loper +real(kind=wp), intent(in) :: rHrmt +logical(kind=iwp), intent(in) :: DiffOp +#include "Molcas.fh" +#include "disp.fh" +integer(kind=iwp) :: iAng, iAO, iBas, iCar, iCmp, iCnt, iCnttp, iComp, iDCRR(0:7), iDCRT(0:7), iI, iIC, iIrrep, IndGrd(0:7), iopt, & + ip(8), iPrim, irc, iS, iShell, iShll, iSmLbl, iSOBlk, iStabM(0:7), iStabO(0:7), iStart, iuv, jAng, jAO, jBas, & + jCmp, jCnt, jCnttp, jdisp, jIrrep, jPrim, jS, jShell, jShll, kk, kOper, lDCRR, LenInt, LenInt_Tot, lFinal, & + LmbdR, LmbdT, maxi, mdci, mdcj, MemKer, MemKrn, mSO, nDCRR, NDCRT, nDens, ndenssq, nDisp, nIC, nnIrrep, & + nOp(2), nOrder, nrOp, nScr1, nSkal, nSO, nStabM, nStabO +real(kind=wp) :: A(3), B(3), CCoor(3), Fact, RB(3) +logical(kind=iwp) :: DiffCnt, IfGrd(3,2), Trans(2) +character(len=8) :: LabDsk +real(kind=wp), allocatable :: Fnl(:), Integrals(:), Kappa(:), Kern(:), PCoor(:,:), Scr(:), ScrSph(:), SO(:), Zeta(:), ZI(:) +integer(kind=iwp), external :: MemSO1, NrOpr +logical(kind=iwp), external :: EQ, TF + +! Compute the number of blocks from each component of the operator +! and the irreps it will span. + +LabDsk = Lab_Dsk +CCoor(:) = Zero +IndGrd(0:nIrrep-1) = 0 +loper = 0 +nnIrrep = nIrrep +if (sIrrep) nnIrrep = 1 +do iIrrep=0,nnIrrep-1 + jIrrep = nropr(ieor(ioper(iIrrep),ioper(isym))) + nDisp = IndDsp(iDcnt,iIrrep) + do iCar=1,3 + iComp = 2**(iCar-1) + if (TF(iDCnt,iIrrep,iComp)) then + ndisp = ndisp+1 + if (iDCar == icar) then + loper = loper+2**jIrrep + IndGrd(jIrrep) = nDisp + end if + end if + end do +end do +nIC = 0 +if (loper == 0) return + +ip(1:nIrrep) = 0 + +iStart = 1 +do iIrrep=0,nIrrep-1 + if (btest(loper,iIrrep)) then + LenInt = nFck(iIrrep) + nIc = nIC+1 + ip(NIC) = iStart + iStart = iStart+LenInt + end if +end do +LenInt_Tot = iStart-1 +call mma_allocate(Integrals,LenInt_Tot,Label='Integrals') +Integrals(:) = Zero + +call SOS(iStabO,nStabO,1) + +! Auxiliary memory allocation. + +! * +!*********************************************************************** +! * +call Set_Basis_Mode('Valence') +call Nr_Shells(nSkal) +call Setup_iSD() +! * +!*********************************************************************** +! * + +! Double loop over shells. + +do iS=1,nSkal + iShll = iSD(0,iS) + iAng = iSD(1,iS) + iCmp = iSD(2,iS) + iBas = iSD(3,iS) + iPrim = iSD(5,iS) + iAO = iSD(7,iS) + mdci = iSD(10,iS) + iShell = iSD(11,iS) + iCnttp = iSD(13,iS) + iCnt = iSD(14,iS) + A(1:3) = dbsc(iCnttp)%Coor(1:3,iCnt) + + do jS=1,iS + jShll = iSD(0,jS) + jAng = iSD(1,jS) + jCmp = iSD(2,jS) + jBas = iSD(3,jS) + jPrim = iSD(5,jS) + jAO = iSD(7,jS) + mdcj = iSD(10,jS) + jShell = iSD(11,jS) + jCnttp = iSD(13,jS) + jCnt = iSD(14,jS) + B(1:3) = dbsc(jCnttp)%Coor(1:3,jCnt) + + ! Call kernel routine to get memory requirement. Observe, however + ! that kernels which will use the HRR will allocate that + ! memory internally. + + maxi = S%maxPrm(iAng)*S%maxprm(jang) + call mma_allocate(Zeta,maxi,Label='Zeta') + call mma_allocate(ZI,maxi,Label='ZI') + call mma_allocate(Kappa,maxi,Label='Kappa') + call mma_allocate(PCoor,maxi,3,Label='PCoor') + call KrnlMm(nOrder,MemKer,iAng,jAng,nOrdOp) + + ! Memory requirements for contraction and Symmetry + ! adaption of derivatives. + + lFinal = S%MaxPrm(iAng)*S%MaxPrm(jAng)*nTri_Elem1(iAng)*nTri_Elem1(jAng)*nIrrep + + MemKrn = max(MemKer*Maxi,lFinal) + call mma_allocate(Kern,MemKrn,Label='Kern') + + ! Save some memory and use Scrt area for transformation + + ! Allocate memory for the final integrals all in the primitive basis. + + call mma_allocate(Fnl,lFinal,Label='Fnl') + + ! Scratch area for the transformation to spherical gaussians + + nScr1 = S%MaxBas(iAng)*S%MaxBas(jAng)*nTri_Elem1(iAng)*nTri_Elem1(jAng)*nIC + call mma_allocate(ScrSph,nScr1,Label='ScfSph') + + ! At this point we can compute Zeta. + ! This is now computed in the ij or ji order. + + call ZXia(Zeta,ZI,iPrim,jPrim,Shells(iShll)%Exp,Shells(jShll)%Exp) + + DiffCnt = (mdci == iDCnt) .or. (mdcj == iDCnt) + if (DiffCnt .or. DiffOp) then + IfGrd(:,:) = .false. + trans(:) = .false. + if (mdci == iDCnt) then + IfGrd(idCar,1) = .true. + end if + if (mdcj == iDCnt) then + IfGrd(idCar,2) = .true. + end if + + if (IfGrd(iDCar,1) .and. IfGrd(iDCar,2) .and. (.not. DiffOp)) then + IfGrd(iDCar,2) = .false. + Trans(2) = .true. + end if + if (Label == 'CONNECTI') Trans(2) = .false. + + ! Allocate memory for SO integrals that will be generated by + ! this batch of AO integrals. + + nSO = 0 + do iIrrep=0,nIrrep-1 + if (btest(loper,iIrrep)) then + iSmLbl = 2**iIrrep + nSO = nSO+MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO) + end if + end do + !if (iPrint >= 29) write(u6,*) ' nSO=',nSO + if (nSO /= 0) then + call mma_allocate(SO,iBas*jBas*nSO,Label='SO') + SO(:) = Zero + + ! Find the DCR for A and B + + call DCR(LmbdR,dc(mdci)%iStab,dc(mdci)%nStab,dc(mdcj)%iStab,dc(mdcj)%nStab,iDCRR,nDCRR) + + ! Find the stabilizer for A and B + + call Inter(dc(mdci)%iStab,dc(mdci)%nStab,dc(mdcj)%iStab,dc(mdcj)%nStab,iStabM,nStabM) + + call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) + + ! Compute normalization factor + + iuv = dc(mdci)%nStab*dc(mdcj)%nStab + Fact = real(iuv*nStabO,kind=wp)/real(nIrrep**2*LmbdT,kind=wp) + if (MolWgh == 1) then + Fact = Fact*real(nIrrep,kind=wp)**2/real(iuv,kind=wp) + else if (MolWgh == 2) then + Fact = sqrt(real(iuv,kind=wp))*real(nStabO,kind=wp)/real(nIrrep*LmbdT,kind=wp) + end if + + ! Loops over symmetry operations acting on the basis. + + nOp(1) = NrOpr(0) + if (jBas < -999999) write(u6,*) 'gcc overoptimization',nDCRR + do lDCRR=0,nDCRR-1 + call OA(iDCRR(lDCRR),B,RB) + nOp(2) = NrOpr(iDCRR(lDCRR)) + if ((Label /= 'CONNECTI') .and. EQ(A,RB) .and. (.not. DiffOp)) cycle + + ! Compute kappa and P. + + call Setup1(Shells(iShll)%Exp,iPrim,Shells(jShll)%Exp,jPrim,A,RB,Kappa,PCoor,ZI) + + ! Compute AO integrals. + ! for easy implementation of NA integrals. + + call Kernel(Shells(iShll)%Exp,iPrim,Shells(jShll)%Exp,jPrim,Zeta,Kappa,PCoor,Fnl,iPrim*jPrim,iAng,jAng,A,RB,nOrder,Kern, & + MemKrn,Ccoor,nOrdOp,IfGrd,IndGrd,nop,dc(mdci)%nStab,dc(mdcj)%nStab,nic,idcar,trans,kcar,isym) + + ! Transform from primitive to contracted basis functions. + ! Order of transformation is fixed. It has been shown through + ! testing that the index order ij,ab will give a performance + ! that is up to 20% faster than the ab,ij index order. + + ! Transform i,jabx to jabx,I + + kk = nTri_Elem1(iAng)*nTri_Elem1(jAng)*nIC + call DGEMM_('T','N',jPrim*kk,iBas,iPrim,One,Fnl,iPrim,Shells(iShll)%pCff,iPrim,Zero,Kern,jPrim*kk) + + ! Transform j,abxI to abxI,J + + call DGEMM_('T','N',kk*iBas,jBas,jPrim,One,Kern,jPrim,Shells(jShll)%pCff,jPrim,Zero,Fnl,kk*iBas) + + ! Transform to spherical gaussians if needed. + + kk = nTri_Elem1(iAng)*nTri_Elem1(jAng) + + if (Shells(iShll)%Transf .or. Shells(jShll)%Transf) then + + ! Result comes back as IJAB or IJAb + + call CarSph(Fnl,kk,iBas*jBas*nIC,Kern,nScr1,RSph(ipSph(iAng)),iAng,Shells(iShll)%Transf, & + Shells(iShll)%Prjct,RSph(ipSph(jAng)),jAng,Shells(jShll)%Transf,Shells(jShll)%Prjct,ScrSph,iCmp*jCmp) + + call DGeTmO(ScrSph,nIC,nIC,iBas*jBas*iCmp*jCmp,Kern,iBas*jBas*iCmp*jCmp) + + else + + ! Transpose abx,IJ back to IJ,abx + + call DGeTmO(Fnl,kk*nIC,kk*nIC,iBas*jBas,Kern,iBas*jBas) + end if + + ! At this point accumulate the batch of integrals onto the + ! final symmetry adapted integrals. + + !if (iPrint >= 99) then + ! call RecPrt (' Accumulated SO integrals, so far...',' ',SO,iBas*jBas,nSO) + !end if + + ! Symmetry adapt component by component + + iSOBlk = 1 + iIC = 1 + do iIrrep=0,nIrrep-1 + iSmLbl = iand(lOper,2**iIrrep) + mSO = MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO) + if (mSO == 0) then + do jIrrep=0,nIrrep-1 + if (btest(iSmLbl,jIrrep)) iIC = iIC+1 + end do + else + call SymAd1(iSmLbl,iAng,jAng,iCmp,jCmp,iShell,jShell,iShll,jShll,iAO,jAO,Kern,iBas,jBas,nIC,iIC,SO(iSOBlk),mSO,nOp) + iSOBlk = iSOBlk+mSO*iBas*jBas + end if + end do + + end do + + ! Multiply with factors due to projection operators + + if (Fact /= One) SO(:) = Fact*SO + + ! Scatter the SO's on to the non-zero blocks of the lower triangle. + + iSOBlk = 1 + iIC = 0 + do iIrrep=0,nIrrep-1 + if (btest(lOper,iIrrep)) then + iSmlbl = 2**iIrrep + iiC = iiC+1 + mSO = MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO) + if ((nfck(iirrep) /= 0) .and. (mSO /= 0)) call SOSctt(SO(iSOBlk),iBas,jBas,mSO,Integrals(ip(iIC)),nFck(iIrrep),iSmLbl, & + iCmp,jCmp,iShell,jShell,iAO,jAO,nIC,Label,2**iIrrep,rHrmt) + iSOBlk = iSOBlk+mSO*iBas*jBas + end if + end do + + call mma_deallocate(SO) + end if + end if + call mma_deallocate(pCoor) + call mma_deallocate(Kappa) + call mma_deallocate(ZI) + call mma_deallocate(Zeta) + call mma_deallocate(ScrSph) + call mma_deallocate(Fnl) + call mma_deallocate(Kern) + + end do +end do + +call Free_iSD() + +! Compute properties or write integrals to disc and deallocate core. + +nDens = 0 +ndenssq = 0 +do iI=0,nIrrep-1 + ndenssq = ndenssq+nbas(ii)**2 + nDens = nDens+nTri_Elem(nBas(iI)) +end do +nrOp = 0 + +call mma_allocate(Scr,ndenssq,Label='Scr') +do iIrrep=0,nIrrep-1 + if (btest(loper,iIrrep)) then + nrOp = nrOp+1 + jdisp = indgrd(iirrep) + kOper = 2**iIrrep + !write(u6,*) koper,isym,jdisp,iirrep + if (iadd /= 0) then + irc = -1 + iopt = 0 + call drdmck(irc,iOpt,LabDsk,jdisp,Scr,koper) + if (irc /= 0) call SysAbendMsg('cnt1el2','error during read in rdmck',' ') + Integrals(ip(nrop):ip(nrop)+nfck(iIrrep)-1) = Integrals(ip(nrop):ip(nrop)+nfck(iIrrep)-1)+Scr(1:nfck(iIrrep)) + end if + irc = -1 + iopt = 0 + !write(u6,*) LabDsk,jdisp,koper + call dwrmck(irc,iOpt,LabDsk,jdisp,Integrals(ip(nrop)),koper) + if (irc /= 0) call SysAbendMsg('cnt1el2','error during write in dwrmck',' ') + end if +end do + +call mma_deallocate(Scr) +call mma_deallocate(Integrals) + +return + +end subroutine Cnt1El2 diff -Nru openmolcas-22.02/src/mckinley/cnt1el.f openmolcas-22.10/src/mckinley/cnt1el.f --- openmolcas-22.02/src/mckinley/cnt1el.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cnt1el.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,511 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine Cnt1El(Kernel,KrnlMm,Label, - & iDCnt,iDCar,loper,rHrmt,DiffOp,dens, - & Lab_Dsk,iadd) -************************************************************************ -* * -* Object: to compute the one-electron integrals. The method employed at* -* this point is not necessarily the fastest. However, the total* -* time for the computation of integrals will depend on the time* -* spent in computing the two-electron integrals. * -* The memory at this point is assumed to be large enough to do * -* the computation in core. * -* The data is structured with respect to four indices, two (my * -* ny or i j) refer to primitives or basis functions and two (a * -* b) refer to the components of the cartesian or spherical * -* harmonic gaussians. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* January '90 * -* Rewritten for gradients needed in hessian calculations * -* and general operator treatment * -* May '95 By: * -* Anders Bernhardsson , Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN. * -************************************************************************ - use Real_Spherical - use iSD_data - use Basis_Info - use Center_Info - use Sizes_of_Seward, only:S - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) -* External Kernel, KrnlMm - External KrnlMm -#include "Molcas.fh" -#include "print.fh" -#include "real.fh" -#include "stdalloc.fh" -#include "disp.fh" -#include "disp2.fh" -#include "nsd.fh" -#include "setup.fh" -* log trans integer dcent - Real*8 A(3), B(3), RB(3),CCoor(3),dens(*) - Character Label*8 - Integer nOp(2), ip(8), iDCRR(0:7), iDCRT(0:7), - & iStabM(0:7), iStabO(0:7), IndGrd(0:7) - Logical IfGrd(3,2),EQ,DiffOP,DiffCnt,Trans(2) - Integer, Parameter:: iTwoj(0:7)=[1,2,4,8,16,32,64,128] - Character(LEN=8) Lab_dsk - Real*8, Allocatable:: Integrals(:), Zeta(:), ZI(:), Kappa(:), - & PCoor(:,:), Fnl(:), Kern(:), ScrSph(:), - & SO(:), Scr(:) - Logical, External :: TF -* * -************************************************************************ -* * - Interface - Subroutine Kernel( -#define _CALLING_ -#include "grd_mck_interface.fh" - & ) -#include "grd_mck_interface.fh" - End Subroutine Kernel - End Interface -* * -************************************************************************ -* * -* Statement function -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* * -************************************************************************ -* * -*define _DEBUGPRINT_ -* * -************************************************************************ -* * -*-----Compute the number of blocks from each component of the operator -* and the irreps it will span. -* -* -C Differentiated symmetry-unique center IDCNT -C Derivative wrt component IDCAR=1,2,3 (d/dx,d/dy,d/dz) -C INDDSP(IDCNT,IIRREP) is the number of displacements in -C earlier center/irrep. Thus it is an offset. -* - nOrdOp=0 - Call iCopy(nIrrep,[0],0,IndGrd,1) - loper=0 -#ifdef _DEBUGPRINT_ - iprint=99 -#endif - nnIrrep=nIrrep - If (sIrrep) nnIrrep=1 - Do iIrrep=0,nnIrrep-1 - nDisp = IndDsp(iDcnt,iIrrep) -C First set NDISP=ordering number of this displacement. -C Then loop over directions d/dx,d/dy,d/dz - Do iCar=1,3 - iComp = 2**(iCar-1) - If ( TF(iDCnt,iIrrep,iComp)) Then - ndisp=ndisp+1 -C NDISP is now the ordering number of this displacement. - If (iDCar.eq.icar) Then - loper=loper+2**iIrrep - IndGrd(iIrrep) = nDisp - End If - End If - End Do - End Do - nIC=0 - If (loper.eq.0) Return -C For the displacement represented by this symmetry-unique -C center IDCNT and this component IDCAR, the differentiation -C operator has components with irreps that have been marked -C with '1' in LOPER, regarded as a flag array. -C INDGRD(IIRREP) will be zero, except for those irreps, and -C will then contain the ordering number of the displacement. - -C Allocate one integral array for each of these irreps. -C The address is kept in array IP(). - nIC=0 - Call ICopy(nIrrep,[0],0,ip,1) - - iStart=1 - Do iIrrep =0,nIrrep-1 - If (iAnd(2**iIrrep,loper).ne.0) Then - LenInt=nFck(iIrrep) - nIc=nIC+1 - ip(NIC)=iStart - iStart=iStart+LenInt - End If - End Do - LenInt_Tot=iStart-1 - Call mma_allocate(Integrals,LenInt_Tot,Label='Integrals') - Integrals(:)=Zero - -C Obtain ISTABO, the stabilizer of the totally symmetric irrep(!) -C Note: 3rd parameter is bit-packed set of irreps -C so '1' contains only irrep nr 0. -C But then ISTABO will be the whole group!? and NSTABO=NIRREP?! - Call SOS(iStabO,nStabO,1) -* -*-----Auxiliary memory allocation. -* -* * -************************************************************************ -* * - Call Set_Basis_Mode('Valence') - Call Nr_Shells(nSkal) - Call Setup_iSD() -* * -************************************************************************ -* * -*-----Double loop over shells. -* - Do iS = 1, nSkal - iShll = iSD( 0,iS) - iAng = iSD( 1,iS) - iCmp = iSD( 2,iS) - iBas = iSD( 3,iS) - iPrim = iSD( 5,iS) - iAO = iSD( 7,iS) - mdci = iSD(10,iS) - iShell = iSD(11,iS) - iCnttp = iSD(13,iS) - iCnt = iSD(14,iS) - A(1:3)=dbsc(iCnttp)%Coor(1:3,iCnt) -* - Do jS = 1, iS - jShll = iSD( 0,jS) - jAng = iSD( 1,jS) - jCmp = iSD( 2,jS) - jBas = iSD( 3,jS) - jPrim = iSD( 5,jS) - jAO = iSD( 7,jS) - mdcj = iSD(10,jS) - jShell = iSD(11,jS) - jCnttp = iSD(13,jS) - jCnt = iSD(14,jS) - B(1:3)=dbsc(jCnttp)%Coor(1:3,jCnt) -* -*-------Call kernel routine to get memory requirement. Observe, however -* that kernels which will use the HRR will allocate that -* memory internally. -* - maxi=S%maxPrm(iAng)*S%maxprm(jang) - Call mma_allocate(Zeta,maxi,Label='Zeta') - Call mma_allocate(ZI,maxi,Label='ZI') - Call mma_allocate(Kappa,maxi,Label='Kappa') - Call mma_allocate(PCoor,maxi,3,Label='PCoor') - Call KrnlMm(nOrder,MemKer,iAng,jAng,nOrdOp) -* -* Memory requirements for contraction and Symmetry -* adoption of derivatives. -* - lFinal = S%MaxPrm(iAng) * S%MaxPrm(jAng) * - & nElem(iAng)*nElem(jAng)*nIrrep -* - MemKrn=Max(MemKer*Maxi,lFinal) - Call mma_Allocate(Kern,MemKrn,Label='Kern') -* -* Save some memory and use Scrt area for -* transformation -* -* Allocate memory for the final integrals all in the -* primitive basis. -* - Call mma_allocate(Fnl,lFinal,Label='Fnl') -* -* Scratch area for the transformation to spherical gaussians -* - nScr1=S%MaxBas(iAng)*S%MaxBas(jAng)*nElem(iAng)*nElem(jAng)*nIC - Call mma_allocate(ScrSph,nScr1,Label='ScrSph') -* -* At this point we can compute Zeta. -* This is now computed in the ij or ji order. -* - Call ZXia(Zeta,ZI, - & iPrim,jPrim,Shells(iShll)%Exp, - & Shells(jShll)%Exp) -* -* - DiffCnt=((mdci.eq.iDCnt).or.(mdcj.eq.iDCnt)) - If ((.not.DiffCnt).and.(.not.DiffOp)) Goto 131 - Call lCopy(6,[.false.],0,IfGrd,1) -C Logical trans(2) -C trans(iCnt) is true means there will be a sign shift in the SYMADO -C routine for the contribution to the integral from the -C differentiation wrt center iCnt - Call lCopy(2,[.false.],0,trans,1) - If (mdci.eq.iDCnt) Then - IfGrd(idCar,1)=.true. - End If - If (mdcj.eq.iDCnt) Then - IfGrd(idCar,2)=.true. - End If -* - If (IfGrd(iDCar,1).and.IfGrd(iDCar,2).and. - & (.not.DiffOp)) Then - IfGrd(iDCar,2)=.false. - Trans(2)=.true. - End If - If (Label.eq.'CONNECTI') Trans(2)=.false. - If (Label.eq.'OVRGRDA') Trans(2)=.false. -* -* Allocate memory for SO integrals that will be generated by -* this batch of AO integrals. -* - nSO=0 - Do iIrrep=0,nIrrep-1 - If (iAnd(loper,2**iIrrep).ne.0) Then - iSmLbl=2**iIrrep - nSO=nSO+MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO) - End If - End Do -#ifdef _DEBUGPRINT_ - If (iPrint.ge.29) Write (6,*) ' nSO=',nSO -#endif - If (nSO.eq.0) Go To 131 - Call mma_Allocate(SO,nSO*iBas*jBas,Label='SO') - SO(:)=Zero -* -* Find the DCR for A and B -* - Call DCR(LmbdR,dc(mdci)%iStab,dc(mdci)%nStab, - & dc(mdcj)%iStab,dc(mdcj)%nStab,iDCRR,nDCRR) -* -* Find the stabilizer for A and B -* - Call Inter(dc(mdci)%iStab,dc(mdci)%nStab, - & dc(mdcj)%iStab,dc(mdcj)%nStab, - & iStabM,nStabM) -* - Call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) -* -* Compute normalization factor -* - iuv = dc(mdci)%nStab*dc(mdcj)%nStab - Fact = DBLE(iuv*nStabO) / DBLE(nIrrep**2 * LmbdT) - If (MolWgh.eq.1) Then - Fact = Fact * DBLE(nIrrep)**2 / DBLE(iuv) - Else If (MolWgh.eq.2) Then - Fact = sqrt(DBLE(iuv))*DBLE(nStabO)/DBLE(nIrrep*LmbdT) - End If -* -* Loops over symmetry operations acting on the basis. -* - nOp(1) = NrOpr(0) - if(jBas.lt.-999999) write(6,*) 'gcc overoptimization',nDCRR - Do 140 lDCRR = 0, nDCRR-1 - Call OA(iDCRR(lDCRR),B,RB) - nOp(2) = NrOpr(iDCRR(lDCRR)) - If (Label.ne.'CONNECTI' - & .and.EQ(A,RB).and. (.Not.DiffOp)) Go To 140 -* -* Compute kappa and P. -* - Call Setup1(Shells(iShll)%Exp,iPrim, - & Shells(jShll)%Exp,jPrim, - & A,RB,Kappa,PCoor,ZI) -* -* Compute AO integrals. -* for easy implementation of NA integrals. -* - call dcopy_(lFinal,[0.0d0],0,Fnl,1) - Call Kernel(Shells(iShll)%Exp,iPrim, - & Shells(jShll)%Exp,jPrim, - & Zeta,ZI, - & Kappa,PCoor, - & Fnl,iPrim*jPrim, - & iAng,jAng,A,RB,nOrder,Kern, - & MemKrn,Ccoor,nOrdOp,IfGrd,IndGrd,nop, - & loper,dc(mdci)%nStab, - & dc(mdcj)%nStab,nic,idcar,idcnt, - & iStabM,nStabM,trans,nIrrep) -* -* -* Transform from primitive to contracted basis functions. -* Order of transformation is fixed. It has been shown through -* testing that the index order ij,ab will give a performance -* that is up to 20% faster than the ab,ij index order. -* -* -* Transform i,jabx to jabx,I - kk=nElem(iAng)*nElem(jAng)*nIC - Call DGEMM_('T','N', - & jPrim*kk,iBas,iPrim, - & 1.0d0,Fnl,iPrim, - & Shells(iShll)%pCff,iPrim, - & 0.0d0,Kern,jPrim*kk) -* -* Transform j,abxI to abxI,J -* - Call DGEMM_('T','N', - & kk*iBas,jBas,jPrim, - & 1.0d0,Kern,jPrim, - & Shells(jShll)%pCff,jPrim, - & 0.0d0,Fnl,kk*iBas) -* -* Transform to spherical gaussians if needed. -* - kk=nElem(iAng)*nElem(jAng) -* - If (Shells(iShll)%Transf.or.Shells(jShll)%Transf) Then -* -* Result comes back as IJAB or IJAb -* - Call CarSph(Fnl,kk,iBas*jBas*nIC, - & Kern,nScr1, - & RSph(ipSph(iAng)),iAng, - & Shells(iShll)%Transf, - & Shells(iShll)%Prjct, - & RSph(ipSph(jAng)),jAng, - & Shells(jShll)%Transf, - & Shells(jShll)%Prjct, - & ScrSph,iCmp*jCmp) -* - Call DGeTmO(ScrSph,nIC,nIC, - & iBas*jBas*iCmp*jCmp, - & Kern,iBas*jBas*iCmp*jCmp) -* - Else -* -* Transpose abx,IJ back to IJ,abx -* - Call DGeTmO(Fnl,kk*nIC,kk*nIC, - & iBas*jBas,Kern,iBas*jBas) - End If -* -* At this point accumulate the batch of integrals onto the -* final symmetry adapted integrals. -* -#ifdef _DEBUGPRINT_ - If (iPrint.ge.99) Then - Call RecPrt (' Accumulated SO integrals, so far...', - & ' ',SO,iBas*jBas,nSO) - End If -#endif -* -*------------Symmetry adapt component by component -* - iSOBlk = 1 - iIC=1 - Do iIrrep = 0, nIrrep-1 - iSmLbl=iAnd(lOper,iTwoj(iIrrep)) - mSO=MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO) - If (mSO.eq.0) Then - Do jIrrep = 0, nIrrep-1 - If (iAnd(iSmLbl,iTwoj(jIrrep)).ne.0) iIC = iIC + 1 - End Do - Else - Call SymAd1(iSmLbl,iAng,jAng,iCmp,jCmp, - & iShell,jShell,iShll,jShll,iAO,jAO, - & Kern,iBas,jBas,nIC,iIC, - & SO(iSOBlk),mSO,nOp) - iSOBlk = iSOBlk + mSO*iBas*jBas - End If - End Do -* - 140 Continue -* -* Multiply with factors due to projection operators -* - If (Fact.ne.One) - & Call DScal_(nSO*iBas*jBas,Fact,SO,1) -* -* Scatter the SO's on to the non-zero blocks of the -* lower triangle. -* - iSOBlk=1 - iiC=0 - Do iIrrep = 0, nIrrep-1 - If (iAnd(lOper,2**iIrrep).ne.0) Then - iSmlbl=2**iIrrep - iiC=iiC+1 - mSO=MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO) - If (nfck(iIrrep).ne.0.and.mSO.ne.0) - & Call SOSctt(SO(iSOBlk),iBas,jBas,mSO, - & Integrals(ip(iIC)),nFck(iIrrep),iSmLbl, - & iCmp,jCmp,iShell,jShell, - & iAO,jAO, - & nIC,Label,2**iIrrep,rHrmt) - iSOBlk = iSOBlk + mSO*iBas*jBas - End If - End Do -* - Call mma_deallocate(SO) - 131 Continue - Call mma_deallocate(ScrSph) - Call mma_deallocate(Kern) - Call mma_deallocate(Fnl) - Call mma_deallocate(PCoor) - Call mma_deallocate(Kappa) - Call mma_deallocate(ZI) - Call mma_deallocate(Zeta) - End Do - End Do - Call Free_iSD() -* -* Compute properties or write integrals to disc and -* deallocate core. -* - nDens=0 - nDenssq=0 - Do iI=0,nIrrep-1 - nDenssq = nDenssq + nBas(ii)**2+nBas(ii) - nDens = nDens + nBas(iI)*(nBas(iI)+1)/2 - End Do - nrOp=0 - - Call mma_allocate(Scr,2*nDenssq,Label='Scr') - Do 16 iIrrep = 0, nIrrep-1 - iSmLbl = 2**iIrrep - If (iAnd(2**iIrrep,loper).ne.0) Then - nrOp=nrOp+1 - jdisp=indgrd(iIrrep) - kOper=2**iIrrep - If (show.and.iIrrep.eq.0) Then - Write(6,*) Label,': ', - & ddot_(nDens,Dens,1,Integrals(ip(nrop)),1) - Write(6,*) 'oper: ', - & ddot_(nDens,Integrals(ip(nrop)),1, - & Integrals(ip(nrop)),1) - Write(6,*) 'Dens: ',ddot_(nDens,Dens,1,Dens,1) - Else If (show) Then - mDens=nFck(iIrrep) - Write(6,*) Label - Write(6,'(A,G20.10)') 'oper: ', - & ddot_(mDens,Integrals(ip(nrop)),1, - & Integrals(ip(nrop)),1) - End if -* - If (iadd.ne.0) Then - irc=-1 - iopt=0 - call dRdMck(irc,iOpt,Lab_dsk,jdisp,Scr,koper) - If (irc.ne.0) Call SysAbendMsg('cnt1el', - & 'error during read in rdmck',' ') - Call DaXpY_(nfck(iIrrep),one,Scr,1, - & Integrals(ip(nrop)),1) - End If - irc=-1 - iopt=0 -#ifdef _DEBUGPRINT_ - Write(6,'(2A,2I8)')'Lab_dsk,jdisp,koper',Lab_dsk,jdisp,koper -#endif - Call dWrMck(irc,iOpt,Lab_dsk,jdisp,Integrals(ip(nrop)), - & koper) - If (irc.ne.0) Call SysAbendMsg('cnt1el', - & 'error during write in dwrmck',' ') - End If - 16 Continue - Call mma_deallocate(Scr) - Call mma_deallocate(Integrals) -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/cnt1el.F90 openmolcas-22.10/src/mckinley/cnt1el.F90 --- openmolcas-22.02/src/mckinley/cnt1el.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cnt1el.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,442 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Roland Lindh * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine Cnt1El(Kernel,KrnlMm,Label,iDCnt,iDCar,loper,rHrmt,DiffOp,dens,Lab_Dsk,iadd) +!*********************************************************************** +! * +! Object: to compute the one-electron integrals. The method employed at* +! this point is not necessarily the fastest. However, the total* +! time for the computation of integrals will depend on the time* +! spent in computing the two-electron integrals. * +! The memory at this point is assumed to be large enough to do * +! the computation in core. * +! The data is structured with respect to four indices, two (my * +! ny or i j) refer to primitives or basis functions and two (a * +! b) refer to the components of the cartesian or spherical * +! harmonic gaussians. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! January '90 * +! Rewritten for gradients needed in hessian calculations * +! and general operator treatment * +! May '95 By: * +! Anders Bernhardsson , Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN. * +!*********************************************************************** + +use McKinley_global, only: nFck, sIrrep +use mck_interface, only: grd_mck_kernel, mck_mem +use Index_Functions, only: nTri_Elem, nTri_Elem1 +use Real_Spherical, only: ipSph, RSph +use iSD_data, only: iSD +use Basis_Info, only: dbsc, MolWgh, nBas, Shells +use Center_Info, only: dc +use Sizes_of_Seward, only: S +use Symmetry_Info, only: nIrrep +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6, r8 + +implicit none +procedure(grd_mck_kernel) :: Kernel +procedure(mck_mem) :: KrnlMm +character(len=8), intent(in) :: Label, Lab_Dsk +integer(kind=iwp), intent(in) :: iDCnt, iDCar, iadd +integer(kind=iwp), intent(out) :: loper +real(kind=wp), intent(in) :: rHrmt, dens(*) +logical(kind=iwp), intent(in) :: DiffOp +#include "Molcas.fh" +#include "print.fh" +#include "disp.fh" +integer(kind=iwp) :: iAng, iAO, iBas, iCar, iCmp, iCnt, iCnttp, iComp, iDCRR(0:7), iDCRT(0:7), iI, iIC, iIrrep, IndGrd(0:7), iopt, & + ip(8), iPrim, irc, iS, iShell, iShll, iSmLbl, iSOBlk, iStabM(0:7), iStabO(0:7), iStart, iuv, jAng, jAO, jBas, & + jCmp, jCnt, jCnttp, jdisp, jIrrep, jPrim, jS, jShell, jShll, kk, kOper, lDCRR, LenInt, LenInt_Tot, lFinal, & + LmbdR, LmbdT, maxi, mdci, mdcj, mDens, MemKer, MemKrn, mSO, nDCRR, nDCRT, nDens, nDenssq, nDisp, nIC, & + nnIrrep, nOp(2), nOrder, nOrdOp, nrOp, nScr1, nSkal, nSO, nStabM, nStabO +real(kind=wp) :: A(3), B(3), CCoor(3), Fact, RB(3) +logical(kind=iwp) :: IfGrd(3,2), DiffCnt, Trans(2) +character(len=8) :: LabDsk +real(kind=wp), allocatable :: Fnl(:), Integrals(:), Kappa(:), Kern(:), PCoor(:,:), Scr(:), ScrSph(:), SO(:), Zeta(:), ZI(:) +integer(kind=iwp), external :: MemSO1, NrOpr +real(kind=r8), external :: DDot_ +logical(kind=iwp), external :: EQ, TF + +! * +!*********************************************************************** +! * +!define _DEBUGPRINT_ +! * +!*********************************************************************** +! * +! Compute the number of blocks from each component of the operator +! and the irreps it will span. + +! Differentiated symmetry-unique center IDCNT +! Derivative wrt component IDCAR=1,2,3 (d/dx,d/dy,d/dz) +! INDDSP(IDCNT,IIRREP) is the number of displacements in +! earlier center/irrep. Thus it is an offset. + +LabDsk = Lab_Dsk +nOrdOp = 0 +IndGrd(0:nIrrep-1) = 0 +loper = 0 +#ifdef _DEBUGPRINT_ +iprint = 99 +#endif +nnIrrep = nIrrep +if (sIrrep) nnIrrep = 1 +do iIrrep=0,nnIrrep-1 + nDisp = IndDsp(iDcnt,iIrrep) + ! First set NDISP=ordering number of this displacement. + ! Then loop over directions d/dx,d/dy,d/dz + do iCar=1,3 + iComp = 2**(iCar-1) + if (TF(iDCnt,iIrrep,iComp)) then + ndisp = ndisp+1 + ! NDISP is now the ordering number of this displacement. + if (iDCar == icar) then + loper = loper+2**iIrrep + IndGrd(iIrrep) = nDisp + end if + end if + end do +end do +nIC = 0 +if (loper == 0) return +! For the displacement represented by this symmetry-unique +! center IDCNT and this component IDCAR, the differentiation +! operator has components with irreps that have been marked +! with '1' in LOPER, regarded as a flag array. +! INDGRD(IIRREP) will be zero, except for those irreps, and +! will then contain the ordering number of the displacement. + +! Allocate one integral array for each of these irreps. +! The address is kept in array IP(). +nIC = 0 +ip(1:nIrrep) = 0 + +iStart = 1 +do iIrrep=0,nIrrep-1 + if (btest(loper,iIrrep)) then + LenInt = nFck(iIrrep) + nIc = nIC+1 + ip(NIC) = iStart + iStart = iStart+LenInt + end if +end do +LenInt_Tot = iStart-1 +call mma_allocate(Integrals,LenInt_Tot,Label='Integrals') +Integrals(:) = Zero + +! Obtain ISTABO, the stabilizer of the totally symmetric irrep(!) +! Note: 3rd parameter is bit-packed set of irreps +! so '1' contains only irrep nr 0. +! But then ISTABO will be the whole group!? and NSTABO=NIRREP?! +call SOS(iStabO,nStabO,1) + +! Auxiliary memory allocation. + +! * +!*********************************************************************** +! * +call Set_Basis_Mode('Valence') +call Nr_Shells(nSkal) +call Setup_iSD() +! * +!*********************************************************************** +! * +! Double loop over shells. + +do iS=1,nSkal + iShll = iSD(0,iS) + iAng = iSD(1,iS) + iCmp = iSD(2,iS) + iBas = iSD(3,iS) + iPrim = iSD(5,iS) + iAO = iSD(7,iS) + mdci = iSD(10,iS) + iShell = iSD(11,iS) + iCnttp = iSD(13,iS) + iCnt = iSD(14,iS) + A(1:3) = dbsc(iCnttp)%Coor(1:3,iCnt) + + do jS=1,iS + jShll = iSD(0,jS) + jAng = iSD(1,jS) + jCmp = iSD(2,jS) + jBas = iSD(3,jS) + jPrim = iSD(5,jS) + jAO = iSD(7,jS) + mdcj = iSD(10,jS) + jShell = iSD(11,jS) + jCnttp = iSD(13,jS) + jCnt = iSD(14,jS) + B(1:3) = dbsc(jCnttp)%Coor(1:3,jCnt) + + ! Call kernel routine to get memory requirement. Observe, however + ! that kernels which will use the HRR will allocate that + ! memory internally. + + maxi = S%maxPrm(iAng)*S%maxprm(jang) + call mma_allocate(Zeta,maxi,Label='Zeta') + call mma_allocate(ZI,maxi,Label='ZI') + call mma_allocate(Kappa,maxi,Label='Kappa') + call mma_allocate(PCoor,maxi,3,Label='PCoor') + call KrnlMm(nOrder,MemKer,iAng,jAng,nOrdOp) + + ! Memory requirements for contraction and Symmetry + ! adaption of derivatives. + + lFinal = S%MaxPrm(iAng)*S%MaxPrm(jAng)*nTri_Elem1(iAng)*nTri_Elem1(jAng)*nIrrep + + MemKrn = max(MemKer*Maxi,lFinal) + call mma_Allocate(Kern,MemKrn,Label='Kern') + + ! Save some memory and use Scrt area for transformation + + ! Allocate memory for the final integrals all in the primitive basis. + + call mma_allocate(Fnl,lFinal,Label='Fnl') + + ! Scratch area for the transformation to spherical gaussians + + nScr1 = S%MaxBas(iAng)*S%MaxBas(jAng)*nTri_Elem1(iAng)*nTri_Elem1(jAng)*nIC + call mma_allocate(ScrSph,nScr1,Label='ScrSph') + + ! At this point we can compute Zeta. + ! This is now computed in the ij or ji order. + + call ZXia(Zeta,ZI,iPrim,jPrim,Shells(iShll)%Exp,Shells(jShll)%Exp) + + DiffCnt = (mdci == iDCnt) .or. (mdcj == iDCnt) + if (DiffCnt .or. DiffOp) then + IfGrd(:,:) = .false. + ! trans(iCnt) is true means there will be a sign shift in the SYMADO + ! routine for the contribution to the integral from the + ! differentiation wrt center iCnt + trans(:) = .false. + if (mdci == iDCnt) then + IfGrd(idCar,1) = .true. + end if + if (mdcj == iDCnt) then + IfGrd(idCar,2) = .true. + end if + + if (IfGrd(iDCar,1) .and. IfGrd(iDCar,2) .and. (.not. DiffOp)) then + IfGrd(iDCar,2) = .false. + Trans(2) = .true. + end if + if (Label == 'CONNECTI') Trans(2) = .false. + if (Label == 'OVRGRDA') Trans(2) = .false. + + ! Allocate memory for SO integrals that will be generated by + ! this batch of AO integrals. + + nSO = 0 + do iIrrep=0,nIrrep-1 + if (btest(loper,iIrrep)) then + iSmLbl = 2**iIrrep + nSO = nSO+MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO) + end if + end do +# ifdef _DEBUGPRINT_ + if (iPrint >= 29) write(u6,*) ' nSO=',nSO +# endif + if (nSO /= 0) then + call mma_Allocate(SO,nSO*iBas*jBas,Label='SO') + SO(:) = Zero + + ! Find the DCR for A and B + + call DCR(LmbdR,dc(mdci)%iStab,dc(mdci)%nStab,dc(mdcj)%iStab,dc(mdcj)%nStab,iDCRR,nDCRR) + + ! Find the stabilizer for A and B + + call Inter(dc(mdci)%iStab,dc(mdci)%nStab,dc(mdcj)%iStab,dc(mdcj)%nStab,iStabM,nStabM) + + call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) + + ! Compute normalization factor + + iuv = dc(mdci)%nStab*dc(mdcj)%nStab + Fact = real(iuv*nStabO,kind=wp)/real(nIrrep**2*LmbdT,kind=wp) + if (MolWgh == 1) then + Fact = Fact*real(nIrrep,kind=wp)**2/real(iuv,kind=wp) + else if (MolWgh == 2) then + Fact = sqrt(real(iuv,kind=wp))*real(nStabO,kind=wp)/real(nIrrep*LmbdT,kind=wp) + end if + + ! Loops over symmetry operations acting on the basis. + + nOp(1) = NrOpr(0) + if (jBas < -999999) write(u6,*) 'gcc overoptimization',nDCRR + do lDCRR=0,nDCRR-1 + call OA(iDCRR(lDCRR),B,RB) + nOp(2) = NrOpr(iDCRR(lDCRR)) + if ((Label /= 'CONNECTI') .and. EQ(A,RB) .and. (.not. DiffOp)) cycle + + ! Compute kappa and P. + + call Setup1(Shells(iShll)%Exp,iPrim,Shells(jShll)%Exp,jPrim,A,RB,Kappa,PCoor,ZI) + + ! Compute AO integrals. + ! for easy implementation of NA integrals. + + Fnl(:) = Zero + call Kernel(Shells(iShll)%Exp,iPrim,Shells(jShll)%Exp,jPrim,Zeta,ZI,Kappa,PCoor,Fnl,iPrim*jPrim,iAng,jAng,A,RB,nOrder, & + Kern,MemKrn,Ccoor,nOrdOp,IfGrd,IndGrd,nop,loper,dc(mdci)%nStab,dc(mdcj)%nStab,nic,idcar,idcnt,iStabM,nStabM, & + trans,nIrrep) + + ! Transform from primitive to contracted basis functions. + ! Order of transformation is fixed. It has been shown through + ! testing that the index order ij,ab will give a performance + ! that is up to 20% faster than the ab,ij index order. + + ! Transform i,jabx to jabx,I + kk = nTri_Elem1(iAng)*nTri_Elem1(jAng)*nIC + call DGEMM_('T','N',jPrim*kk,iBas,iPrim,One,Fnl,iPrim,Shells(iShll)%pCff,iPrim,Zero,Kern,jPrim*kk) + + ! Transform j,abxI to abxI,J + + call DGEMM_('T','N',kk*iBas,jBas,jPrim,One,Kern,jPrim,Shells(jShll)%pCff,jPrim,Zero,Fnl,kk*iBas) + + ! Transform to spherical gaussians if needed. + + kk = nTri_Elem1(iAng)*nTri_Elem1(jAng) + + if (Shells(iShll)%Transf .or. Shells(jShll)%Transf) then + + ! Result comes back as IJAB or IJAb + + call CarSph(Fnl,kk,iBas*jBas*nIC,Kern,nScr1,RSph(ipSph(iAng)),iAng,Shells(iShll)%Transf,Shells(iShll)%Prjct, & + RSph(ipSph(jAng)),jAng,Shells(jShll)%Transf,Shells(jShll)%Prjct,ScrSph,iCmp*jCmp) + + call DGeTmO(ScrSph,nIC,nIC,iBas*jBas*iCmp*jCmp,Kern,iBas*jBas*iCmp*jCmp) + + else + + ! Transpose abx,IJ back to IJ,abx + + call DGeTmO(Fnl,kk*nIC,kk*nIC,iBas*jBas,Kern,iBas*jBas) + end if + + ! At this point accumulate the batch of integrals onto the + ! final symmetry adapted integrals. + +# ifdef _DEBUGPRINT_ + if (iPrint >= 99) then + call RecPrt(' Accumulated SO integrals, so far...',' ',SO,iBas*jBas,nSO) + end if +# endif + + ! Symmetry adapt component by component + + iSOBlk = 1 + iIC = 1 + do iIrrep=0,nIrrep-1 + iSmLbl = iand(lOper,2**iIrrep) + mSO = MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO) + if (mSO == 0) then + do jIrrep=0,nIrrep-1 + if (btest(iSmLbl,jIrrep)) iIC = iIC+1 + end do + else + call SymAd1(iSmLbl,iAng,jAng,iCmp,jCmp,iShell,jShell,iShll,jShll,iAO,jAO,Kern,iBas,jBas,nIC,iIC,SO(iSOBlk),mSO,nOp) + iSOBlk = iSOBlk+mSO*iBas*jBas + end if + end do + + end do + + ! Multiply with factors due to projection operators + + if (Fact /= One) SO(:) = Fact*SO + + ! Scatter the SO's on to the non-zero blocks of the lower triangle. + + iSOBlk = 1 + iiC = 0 + do iIrrep=0,nIrrep-1 + if (btest(lOper,iIrrep)) then + iSmlbl = 2**iIrrep + iiC = iiC+1 + mSO = MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO) + if ((nfck(iIrrep) /= 0) .and. (mSO /= 0)) call SOSctt(SO(iSOBlk),iBas,jBas,mSO,Integrals(ip(iIC)),nFck(iIrrep),iSmLbl, & + iCmp,jCmp,iShell,jShell,iAO,jAO,nIC,Label,2**iIrrep,rHrmt) + iSOBlk = iSOBlk+mSO*iBas*jBas + end if + end do + + call mma_deallocate(SO) + end if + end if + call mma_deallocate(ScrSph) + call mma_deallocate(Kern) + call mma_deallocate(Fnl) + call mma_deallocate(PCoor) + call mma_deallocate(Kappa) + call mma_deallocate(ZI) + call mma_deallocate(Zeta) + end do +end do +call Free_iSD() + +! Compute properties or write integrals to disc and deallocate core. + +nDens = 0 +nDenssq = 0 +do iI=0,nIrrep-1 + nDenssq = nDenssq+nBas(ii)**2+nBas(ii) + nDens = nDens+nTri_Elem(nBas(iI)) +end do +nrOp = 0 + +call mma_allocate(Scr,2*nDenssq,Label='Scr') +do iIrrep=0,nIrrep-1 + if (btest(loper,iIrrep)) then + nrOp = nrOp+1 + jdisp = indgrd(iIrrep) + kOper = 2**iIrrep + if (show .and. (iIrrep == 0)) then + write(u6,*) Label,': ',ddot_(nDens,Dens,1,Integrals(ip(nrop)),1) + write(u6,*) 'oper: ',ddot_(nDens,Integrals(ip(nrop)),1,Integrals(ip(nrop)),1) + write(u6,*) 'Dens: ',ddot_(nDens,Dens,1,Dens,1) + else if (show) then + mDens = nFck(iIrrep) + write(u6,*) Label + write(u6,'(A,G20.10)') 'oper: ',ddot_(mDens,Integrals(ip(nrop)),1,Integrals(ip(nrop)),1) + end if + + if (iadd /= 0) then + irc = -1 + iopt = 0 + call dRdMck(irc,iOpt,LabDsk,jdisp,Scr,koper) + if (irc /= 0) call SysAbendMsg('cnt1el','error during read in rdmck',' ') + Integrals(ip(nrop):ip(nrop)+nfck(iIrrep)-1) = Integrals(ip(nrop):ip(nrop)+nfck(iIrrep)-1)+Scr(1:nfck(iIrrep)) + end if + irc = -1 + iopt = 0 +# ifdef _DEBUGPRINT_ + write(u6,'(2A,2I8)') 'LabDsk,jdisp,koper',LabDsk,jdisp,koper +# endif + call dWrMck(irc,iOpt,LabDsk,jdisp,Integrals(ip(nrop)),koper) + if (irc /= 0) call SysAbendMsg('cnt1el','error during write in dwrmck',' ') + end if +end do +call mma_deallocate(Scr) +call mma_deallocate(Integrals) + +return + +end subroutine Cnt1El diff -Nru openmolcas-22.02/src/mckinley/cnthlf_mck.f openmolcas-22.10/src/mckinley/cnthlf_mck.f --- openmolcas-22.02/src/mckinley/cnthlf_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cnthlf_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,160 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1994, Roland Lindh * -************************************************************************ - Subroutine Cnthlf_mck(Coeff1,nCntr1,nPrm1, - & Coeff2,nCntr2,nPrm2, - & nZeta,lZeta,nVec,First,IncVec,A1,A2,A3, - & Indij) -************************************************************************ -* * -* Object: to do a half transformation. The loop over the two matrix- * -* matrix multiplications is segmented such that the end of the * -* intermediate matrix will not push the start of the same out * -* from the cache. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" -c#include "print.fh" - Real*8 Coeff1(nPrm1,nCntr1), Coeff2(nPrm2,nCntr2), - & A1(lZeta,nVec), A2(nPrm2,IncVec*nCntr1), - & A3(nVec,nCntr1,nCntr2) - Integer Indij(nZeta) - Logical First, Seg1, Seg2 -* -*-----Check if the basis set is segmented -* - Seg1=.False. - Do iPrm1 = nPrm1, 1, -1 - Do iCntr1 = nCntr1, 1, -1 - If (Coeff1(iPrm1,iCntr1).eq.Zero) Then - Seg1=.True. - Go To 10 - End If - End Do - End Do - 10 Continue -* - Seg2=.False. - Do iPrm2 = nPrm2, 1, -1 - Do iCntr2 = nCntr2, 1, -1 - If (Coeff2(iPrm2,iCntr2).eq.Zero) Then - Seg2=.True. - Go To 20 - End If - End Do - End Do - 20 Continue -* -*-----Set output matrix to zero -* - If (First) call dcopy_(nVec*nCntr1*nCntr2,[Zero],0,A3,1) -* -*-----Loop sectioning -* - Do iiVec = 1, nVec, IncVec - mVec = Min(IncVec,nVec-iiVec+1) -*--------Set intermediate matrix to zero - call dcopy_(nPrm2*nCntr1*mVec,[Zero],0,A2,1) -* - If (Seg1) Then -* -*-----First quarter transformation -* - Do iPrm1 = 1, nPrm1 - Do iCntr1 = 1, nCntr1 -*-----------Check for zero due to segmented basis - If (Abs(Coeff1(iPrm1,iCntr1)).gt.Zero) Then - Do iPrm2 = 1, nPrm2 - iZeta = (iPrm2-1)*nPrm1 + iPrm1 - jZeta = Indij(iZeta) -*-----------------Skip due to screening - If (jZeta.gt.0) Then - Do iVec = iiVec, iiVec+mVec-1 - ijVec = mVec*(iCntr1-1) + (iVec-iiVec+1) - A2(iPrm2,ijVec) = A2(iPrm2,ijVec) + - & Coeff1(iPrm1,iCntr1)*A1(jZeta,iVec) - End Do - End If - End Do - End If - End Do - End Do -* - Else -* -*-----First quarter transformation -* - Do iPrm1 = 1, nPrm1 - Do iCntr1 = 1, nCntr1 - Do iPrm2 = 1, nPrm2 - iZeta = (iPrm2-1)*nPrm1 + iPrm1 - jZeta = Indij(iZeta) -*--------------Skip due to screening - If (jZeta.gt.0) Then - Do iVec = iiVec, iiVec+mVec-1 - ijVec = mVec*(iCntr1-1) + (iVec-iiVec+1) - A2(iPrm2,ijVec) = A2(iPrm2,ijVec) + - & Coeff1(iPrm1,iCntr1)*A1(jZeta,iVec) - End Do - End If - End Do - End Do - End Do -* - End If -* - If (Seg2) Then -* -*-----Second quarter transformation -* - Do iPrm2 = 1, nPrm2 - Do iCntr2 = 1, nCntr2 -*-----------Check for zero due to segmented basis - If (Abs(Coeff2(iPrm2,iCntr2)).gt.Zero) Then - Do iCntr1 = 1, nCntr1 - Do iVec = iiVec, iiVec+mVec-1 - ijVec = mVec*(iCntr1-1) + (iVec-iiVec+1) - A3(iVec,iCntr1,iCntr2) = A3(iVec,iCntr1,iCntr2) + - & Coeff2(iPrm2,iCntr2)*A2(iPrm2,ijVec) - End Do - End Do - End If - End Do - End Do -* - Else -* -*-----Second quarter transformation -* - Do iPrm2 = 1, nPrm2 - Do iCntr2 = 1, nCntr2 - Do iCntr1 = 1, nCntr1 - Do iVec = iiVec, iiVec+mVec-1 - ijVec = mVec*(iCntr1-1) + (iVec-iiVec+1) - A3(iVec,iCntr1,iCntr2) = A3(iVec,iCntr1,iCntr2) + - & Coeff2(iPrm2,iCntr2)*A2(iPrm2,ijVec) - End Do - End Do - End Do - End Do -* - End If -* -*-----End of loop sectioning -* - End Do -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/cnthlf_mck.F90 openmolcas-22.10/src/mckinley/cnthlf_mck.F90 --- openmolcas-22.02/src/mckinley/cnthlf_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cnthlf_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,151 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1994, Roland Lindh * +!*********************************************************************** + +subroutine Cnthlf_mck(Coeff1,nCntr1,nPrm1,Coeff2,nCntr2,nPrm2,nZeta,lZeta,nVec,First,IncVec,A1,A2,A3,Indij) +!*********************************************************************** +! * +! Object: to do a half transformation. The loop over the two matrix- * +! matrix multiplications is segmented such that the end of the * +! intermediate matrix will not push the start of the same out * +! from the cache. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +!*********************************************************************** + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nCntr1, nPrm1, nCntr2, nPrm2, nZeta, lZeta, nVec, IncVec, Indij(nZeta) +real(kind=wp), intent(in) :: Coeff1(nPrm1,nCntr1), Coeff2(nPrm2,nCntr2), A1(lZeta,nVec) +logical(kind=iwp), intent(in) :: First +real(kind=wp), intent(out) :: A2(nPrm2,IncVec*nCntr1) +real(kind=wp), intent(inout) :: A3(nVec,nCntr1,nCntr2) +integer(kind=iwp) :: iCntr1, iCntr2, iiVec, ijVec, iPrm1, iPrm2, iZeta, jZeta, mVec +logical(kind=iwp) :: Seg1, Seg2 + +! Check if the basis set is segmented + +Seg1 = .false. +loop1: do iPrm1=nPrm1,1,-1 + do iCntr1=nCntr1,1,-1 + if (Coeff1(iPrm1,iCntr1) == Zero) then + Seg1 = .true. + exit loop1 + end if + end do +end do loop1 + +Seg2 = .false. +loop2: do iPrm2=nPrm2,1,-1 + do iCntr2=nCntr2,1,-1 + if (Coeff2(iPrm2,iCntr2) == Zero) then + Seg2 = .true. + exit loop2 + end if + end do +end do loop2 + +! Set output matrix to zero + +if (First) A3(:,:,:) = Zero + +! Loop sectioning + +do iiVec=1,nVec,IncVec + mVec = min(IncVec,nVec-iiVec+1) + ! Set intermediate matrix to zero + A2(:,1:nCntr1*mVec) = Zero + + if (Seg1) then + + ! First quarter transformation + + do iPrm1=1,nPrm1 + do iCntr1=1,nCntr1 + ijVec = mVec*(iCntr1-1)+1 + ! Check for zero due to segmented basis + if (abs(Coeff1(iPrm1,iCntr1)) > Zero) then + do iPrm2=1,nPrm2 + iZeta = (iPrm2-1)*nPrm1+iPrm1 + jZeta = Indij(iZeta) + ! Skip due to screening + if (jZeta > 0) then + A2(iPrm2,ijVec:ijVec+mVec-1) = A2(iPrm2,ijVec:ijVec+mVec-1)+Coeff1(iPrm1,iCntr1)*A1(jZeta,iiVec:iiVec+mVec-1) + end if + end do + end if + end do + end do + + else + + ! First quarter transformation + + do iPrm1=1,nPrm1 + do iCntr1=1,nCntr1 + ijVec = mVec*(iCntr1-1)+1 + do iPrm2=1,nPrm2 + iZeta = (iPrm2-1)*nPrm1+iPrm1 + jZeta = Indij(iZeta) + ! Skip due to screening + if (jZeta > 0) then + A2(iPrm2,ijVec:ijVec+mVec-1) = A2(iPrm2,ijVec:ijVec+mVec-1)+Coeff1(iPrm1,iCntr1)*A1(jZeta,iiVec:iiVec+mVec-1) + end if + end do + end do + end do + + end if + + if (Seg2) then + + ! Second quarter transformation + + do iPrm2=1,nPrm2 + do iCntr2=1,nCntr2 + ! Check for zero due to segmented basis + if (abs(Coeff2(iPrm2,iCntr2)) > Zero) then + do iCntr1=1,nCntr1 + ijVec = mVec*(iCntr1-1)+1 + A3(iiVec:iiVec+mVec-1,iCntr1,iCntr2) = A3(iiVec:iiVec+mVec-1,iCntr1,iCntr2)+ & + Coeff2(iPrm2,iCntr2)*A2(iPrm2,ijVec:ijVec+mVec-1) + end do + end if + end do + end do + + else + + ! Second quarter transformation + + do iPrm2=1,nPrm2 + do iCntr2=1,nCntr2 + do iCntr1=1,nCntr1 + ijVec = mVec*(iCntr1-1)+1 + A3(iiVec:iiVec+mVec-1,iCntr1,iCntr2) = A3(iiVec:iiVec+mVec-1,iCntr1,iCntr2)+ & + Coeff2(iPrm2,iCntr2)*A2(iPrm2,ijVec:ijVec+mVec-1) + end do + end do + end do + + end if + + ! End of loop sectioning + +end do + +return + +end subroutine Cnthlf_mck diff -Nru openmolcas-22.02/src/mckinley/cntrct_mck.f openmolcas-22.10/src/mckinley/cntrct_mck.f --- openmolcas-22.02/src/mckinley/cntrct_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cntrct_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,91 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1994, Roland Lindh * -* 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine Cntrct_mck(First, - & Coef1,n1,m1,Coef2,n2,m2, - & Coef3,n3,m3,Coef4,n4,m4, - & g1In,nGr,Array,nArr, - & xpre,G1Out,ngr1,nt, - & IndZet,nZeta,lZeta,IndEta,nEta,lEta) -************************************************************************ -* * -* Object: to transform the integrals from primitives to contracted * -* basis functions. The subroutine will do both complete and * -* incomplete transformations. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University* -* of Lund, SWEDEN. * -* * -* Modified by: Anders Bernhardsson for direct implementation of the * -* calculation of first order derivatives needed for * -* response calculation. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -c#include "print.fh" -#include "lCache.fh" - Real*8 Coef1(n1,m1),Coef2(n2,m2),Coef3(n3,m3),Coef4(n4,m4), - & g1In(nT,nGr), - & Array(nArr), - & g1Out(nGr1),xpre(nt) - Logical First - Integer IndZet(nZeta), IndEta(nEta) -* -c iRout = 18 -c iPrint = nPrint(iRout) -* -c If (iPrint.ge.99) -c & Call RecPrt(' In Cntrct: ',' ',G1In,nt,nGr) -c If (iPrint.ge.59 .and. .not.First) -c & Call RecPrt(' In Cntrct: Partial (a0|c0)',' ', -c & G1Out,nGr,m1*m2*m3*m4) - -*-----Cache size is 32 k word (real*8) -* - Do iabcdg=1,ngr - Do it=1,nt - G1In(it,iabcdg)=G1In(it,iabcdg)*xpre(it) - End Do - End Do -* -*-----Reduce for contraction matrix - nCache = (3*lCache)/4 - n1*m1 - n2*m2 - lsize = n1*n2 + n2*m1 - nVec = lEta*nGr - IncVec = Min(Max(1,nCache/lsize),nVec) - ipA3 = 1 - ipA2 = ipA3 + nVec*m1*m2 - ip=ipA2 + n2*IncVec*m1 - If (ip.gt.nArr) Call Abend -* - Call CntHlf_mck(Coef1,m1,n1,Coef2,m2,n2,nZeta,lZeta,nVec, - & .True.,IncVec,G1In,Array(ipA2),Array(ipA3),IndZet) -* - nCache = (3*lCache)/4 - n3*m3 - n4*m4 - lsize = n3*n4 + n4*m3 - nVec = nGr*m1*m2 - IncVec = Min(Max(1,nCache/lsize),nVec) - ip=ipA2 + n4*IncVec*m3 - If (ip.gt.nArr) Call Abend -* - Call CntHlf_mck(Coef3,m3,n3,Coef4,m4,n4,nEta,lEta,nVec, - & First,IncVec,Array(ipA3),Array(ipA2),G1Out,IndEta) - First = .False. -* -c If (iPrint.ge.59) -c & Call RecPrt(' In Cntrct: ',' ', -c & ACOut,labcdG,m1*m2*m3*m4) -* -* Call GetMem('Cntrct','Check','Real',iDum,iDum) - Return - End diff -Nru openmolcas-22.02/src/mckinley/cntrct_mck.F90 openmolcas-22.10/src/mckinley/cntrct_mck.F90 --- openmolcas-22.02/src/mckinley/cntrct_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cntrct_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,80 @@ + +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1994, Roland Lindh * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine Cntrct_mck(First,Coef1,n1,m1,Coef2,n2,m2,Coef3,n3,m3,Coef4,n4,m4,g1In,nGr,Array,nArr,xpre,g1Out,ngr1,nt,IndZet,nZeta, & + lZeta,IndEta,nEta,lEta) +!*********************************************************************** +! * +! Object: to transform the integrals from primitives to contracted * +! basis functions. The subroutine will do both complete and * +! incomplete transformations. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University* +! of Lund, SWEDEN. * +! * +! Modified by: Anders Bernhardsson for direct implementation of the * +! calculation of first order derivatives needed for * +! response calculation. * +!*********************************************************************** + +use Definitions, only: wp, iwp + +implicit none +logical(kind=iwp), intent(inout) :: First +integer(kind=iwp), intent(in) :: n1, m1, n2, m2, n3, m3, n4, m4, nGr, nArr, ngr1, nt, nZeta, IndZet(nZeta), lZeta, nEta, & + IndEta(nEta), lEta +real(kind=wp), intent(in) :: Coef1(n1,m1), Coef2(n2,m2), Coef3(n3,m3), Coef4(n4,m4), xpre(nt) +real(kind=wp), intent(inout) :: g1In(nT,nGr), Array(nArr), g1Out(nGr1) +#include "lCache.fh" +integer(kind=iwp) :: iabcdg, IncVec, ip, ipA2, ipA3, lsize, nCache, nVec + +!iRout = 18 +!iPrint = nPrint(iRout) + +!if (iPrint >= 99) call RecPrt(' In Cntrct: ',' ',G1In,nt,nGr) +!if ((iPrint >= 59) .and. (.not. First)) call RecPrt(' In Cntrct: Partial (a0|c0)',' ',G1Out,nGr,m1*m2*m3*m4) + +! Cache size is 32 k word (real*8) + +do iabcdg=1,ngr + G1In(:,iabcdg) = G1In(:,iabcdg)*xpre(:) +end do + +! Reduce for contraction matrix +nCache = (3*lCache)/4-n1*m1-n2*m2 +lsize = n1*n2+n2*m1 +nVec = lEta*nGr +IncVec = min(max(1,nCache/lsize),nVec) +ipA3 = 1 +ipA2 = ipA3+nVec*m1*m2 +ip = ipA2+n2*IncVec*m1 +if (ip > nArr) call Abend() + +call CntHlf_mck(Coef1,m1,n1,Coef2,m2,n2,nZeta,lZeta,nVec,.true.,IncVec,G1In,Array(ipA2),Array(ipA3),IndZet) + +nCache = (3*lCache)/4-n3*m3-n4*m4 +lsize = n3*n4+n4*m3 +nVec = nGr*m1*m2 +IncVec = min(max(1,nCache/lsize),nVec) +ip = ipA2+n4*IncVec*m3 +if (ip > nArr) call Abend() + +call CntHlf_mck(Coef3,m3,n3,Coef4,m4,n4,nEta,lEta,nVec,First,IncVec,Array(ipA3),Array(ipA2),G1Out,IndEta) +First = .false. + +!if (iPrint >= 59) call RecPrt(' In Cntrct: ',' ',ACOut,labcdG,m1*m2*m3*m4) + +return + +end subroutine Cntrct_mck diff -Nru openmolcas-22.02/src/mckinley/coreb.f openmolcas-22.10/src/mckinley/coreb.f --- openmolcas-22.02/src/mckinley/coreb.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/coreb.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,172 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine coreB(iang,lb,ishll,nordop,TC,RB,Array,narr, - & Beta,nbeta,fb1,fb2,jfgrad,jfhess, - & ld,debug) -* -* -* Calculates and -* -* @parameter iang Angular momenta for core -* @parameter lb Angular momenta for ket -* @parameter ishll identification for core shell -* @parameter nordop order for operator -* @parameter TC Cartesian coordinates for core -* @parameter RB Cartesian coordinates for ket -* @parameter Array Scratch -* @parameter narr size for scratch -* @parameter Beta Ket exponents -* @parameter nbeta number of exponents -* @parameter FB1 First derivatives (out) -* @parameter FB2 2nd derivatives (out) -* @parameter jfgrad true for all 1-deriavtives that are needed -* @parameter jfhess true for all 2-deriavtives that are needed -* @parameter ld Order of derivatives -* @parameter debug guess -* - Use Basis_Info - use Her_RW - use Real_Spherical - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "real.fh" -#include "disp.fh" - Logical ABeq(3),jfgrad(3),jfhess(4,3,4,3),debug - Real*8 TC(3),RB(3),Array(*),fb1(*),fb2(*),beta(*) - - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - nExpi=Shells(iShll)%nExp - if (debug) then - Write(6,*) 'Shell: ',ishll,' nBeta:',nbeta,' nExp:',nExpi, - & 'Angular',lb,iang - Endif -* -* - ip=1 - ipP2 = ip - ip = ip + 3 * nExpi*nBeta - ipZ2 = ip - ip = ip + nExpi*nBeta - ipK2 = ip - ip = ip + nExpi*nBeta - ipZI2 = ip - ip = ip + nExpi*nBeta - If (ip-1.gt.nArr) Then - Write (6,*) ' ip-1.gt.nArr*nZeta(2) in bcore (',ip,',', - & narr,')' - Call Abend - End If -* -*--------------Calculate Effective center and exponent for -* - Call ZXia(Array(ipZ2),Array(ipZI2),nExpi,nBeta, - & Shells(iShll)%Exp,Beta) - Call SetUp1(Shells(iShll)%Exp,nExpi,Beta,nBeta, - & TC,RB,Array(ipK2),Array(ipP2),Array(ipZI2)) -* -*--------------Calculate Overlap and -* - nHer = (lb+1+iAng+1+ld)/2 - ipCxyz = ip - ip = ip + nBeta*nExpi*3*nHer*(iAng+1) - ipBxyz = ip - ip = ip + nBeta*nExpi*3*nHer*(lb+1+ld) - ipRxyz = ip - ip = ip + nBeta*nExpi*3*nHer*(nOrdOp+1) - ipQ1 = ip - ip = ip + - & nBeta*nExpi*3*(iAng+1)*(lb+1+ld)*(nOrdOp+1) - ipB = ip - ip = ip + nBeta*nExpi - If (ip-1.gt.nArr) Then - Write (6,*) ' ip-1.gt.nArr*nZeta(2b) in PrjGrd' - Call Abend - End If - ABeq(1) = TC(1).eq.RB(1) - ABeq(2) = TC(2).eq.RB(2) - ABeq(3) = TC(3).eq.RB(3) - if (debug) - &write(6,*) 'shll=',ishll,' nExp=',nExpi, - & ' nBeta=',nBeta - Call CrtCmp(Array(ipZ2),Array(ipP2),nExpi*nBeta, - & TC,Array(ipCxyz),iAng,HerR(iHerR(nHer)), - & nHer,ABeq) - Call CrtCmp(Array(ipZ2),Array(ipP2),nExpi*nBeta, - & RB,Array(ipBxyz),lb+ld,HerR(iHerR(nHer)), - & nHer,ABeq) - ABeq(1) = .False. - ABeq(2) = .False. - ABeq(3) = .False. - Call CrtCmp(Array(ipZ2),Array(ipP2),nExpi*nBeta, - & TC,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)), - & nHer,ABeq) - If (debug) Then - Write (6,*) ' nbeta = ',nbeta ,' nExp(',ishll,')=', - & nExpi,' nHer=',nHer,' lb=',lb,' iAng=', - & iAng,' nOrdOp=',nOrdOp - - Write (6,*) ' Array(ipCxyz)=', - & DNrm2_(nBeta*nExpi*3*nHer*(iAng+1), - & Array(ipCxyz),1) - Write (6,*) ' Array(ipBxyz)=', - & DNrm2_(nBeta*nExpi*3*nHer*(lb+2), - & Array(ipBxyz),1) - Write (6,*) ' Array(ipRxyz)=', - & DNrm2_(nBeta*nExpi*3*nHer*(nOrdOp+1), - & Array(ipRxyz),1) - End If - - Call Assmbl(Array(ipQ1), - & Array(ipCxyz),iAng, - & Array(ipRxyz),nOrdOp, - & Array(ipBxyz),lb+ld, - & nExpi*nBeta,HerW(iHerW(nHer)),nHer) - iStrt = ipB - Do iGamma = 1, nExpi - call dcopy_(nBeta,Beta,1,Array(iStrt),nExpi) - iStrt = iStrt + 1 - Enddo - If (debug) Then - Write (6,*) ' Array(ipB)=', - & DNrm2_(nExpi*nBeta,Array(ipB),1) - End If - - Call rKappa_Zeta(Array(ipK2),Array(ipZ2), - & nExpi*nBeta) - Call CmbnCB(Array(ipQ1),nExpi*nBeta,iAng,lb, - & Array(ipK2),FB1, - & Array(ipB),JfGrad,ld,nVecCB) - If (debug) Then - Write (6,*) ' Array(ipQ1)=', - & DNrm2_( - & nExpi*nBeta*3*(lb+1+ld+2)*(iAng+1)*(nOrdOp+1), - & Array(ipQ1),1) - Write (6,*) ' Array(ipB)=', - & DNrm2_(nExpi*nBeta,Array(ipB),1) - End If - If (ld.ge.2) Then - Call CmbnS2b(Array(ipQ1),nBeta *nExpi,iang,lb, - & Array(ipK2),FB2, - & Array(ipB),jfHess,ld) - If (debug) Then - Do i=1,6 - ipV=1 - n=nBeta*nExpi*nElem(lb)*nElem(iAng) - Write(6,*)n,nBeta,nExpi,nElem(lb),nElem(iAng) - - Write(6,*) 'CmbnB2(',n,')=',DNrm2_(n,FB2(ipV),1) - ipV=ipV+n - End do - End If - End If - - Return - End diff -Nru openmolcas-22.02/src/mckinley/coreb.F90 openmolcas-22.10/src/mckinley/coreb.F90 --- openmolcas-22.02/src/mckinley/coreb.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/coreb.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,138 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine coreB(iang,lb,ishll,nordop,TC,RB,Array,narr,Beta,nBeta,fb1,fb2,jfgrad,jfhess,ld,debug) +! Calculates and +! +! @parameter iang Angular momenta for core +! @parameter lb Angular momenta for ket +! @parameter ishll identification for core shell +! @parameter nordop order for operator +! @parameter TC Cartesian coordinates for core +! @parameter RB Cartesian coordinates for ket +! @parameter Array Scratch +! @parameter narr size for scratch +! @parameter Beta Ket exponents +! @parameter nBeta number of exponents +! @parameter FB1 First derivatives (out) +! @parameter FB2 2nd derivatives (out) +! @parameter jfgrad true for all 1-derivatives that are needed +! @parameter jfhess true for all 2-derivatives that are needed +! @parameter ld Order of derivatives +! @parameter debug guess + +use Index_Functions, only: nTri_Elem1 +use Basis_Info, only: Shells +use Her_RW, only: HerR, HerW, iHerR, iHerW +use Definitions, only: wp, iwp, u6, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: iang, lb, ishll, nordop, narr, nBeta, ld +real(kind=wp), intent(in) :: TC(3), RB(3), Beta(nBeta) +real(kind=wp), intent(inout) :: Array(*), fb2(*) +real(kind=wp), intent(_OUT_) :: fb1(*) +logical(kind=iwp), intent(in) :: jfgrad(3), jfhess(4,3,4,3), debug +integer(kind=iwp) :: i, iBeta, ip, ipB, ipBxyz, ipCxyz, ipK2, ipP2, ipQ1, ipRxyz, ipV, ipZ2, ipZI2, iStrt, n, nExpi, nHer, nVecCB +logical(kind=iwp) :: ABeq(3) +real(kind=r8), external :: DNrm2_ + +nExpi = Shells(iShll)%nExp +if (debug) write(u6,*) 'Shell: ',ishll,' nBeta:',nBeta,' nExp:',nExpi,'Angular',lb,iang + +ip = 1 +ipP2 = ip +ip = ip+3*nExpi*nBeta +ipZ2 = ip +ip = ip+nExpi*nBeta +ipK2 = ip +ip = ip+nExpi*nBeta +ipZI2 = ip +ip = ip+nExpi*nBeta +if (ip-1 > nArr) then + write(u6,*) ' ip-1 > nArr*nZeta(2) in bcore (',ip,',',narr,')' + call Abend() +end if + +! Calculate Effective center and exponent for + +call ZXia(Array(ipZ2),Array(ipZI2),nExpi,nBeta,Shells(iShll)%Exp,Beta) +call SetUp1(Shells(iShll)%Exp,nExpi,Beta,nBeta,TC,RB,Array(ipK2),Array(ipP2),Array(ipZI2)) + +! Calculate Overlap and + +nHer = (lb+1+iAng+1+ld)/2 +ipCxyz = ip +ip = ip+nBeta*nExpi*3*nHer*(iAng+1) +ipBxyz = ip +ip = ip+nBeta*nExpi*3*nHer*(lb+1+ld) +ipRxyz = ip +ip = ip+nBeta*nExpi*3*nHer*(nOrdOp+1) +ipQ1 = ip +ip = ip+nBeta*nExpi*3*(iAng+1)*(lb+1+ld)*(nOrdOp+1) +ipB = ip +ip = ip+nBeta*nExpi +if (ip-1 > nArr) then + write(u6,*) ' ip-1 > nArr*nZeta(2b) in coreB' + call Abend() +end if +ABeq(1) = TC(1) == RB(1) +ABeq(2) = TC(2) == RB(2) +ABeq(3) = TC(3) == RB(3) +if (debug) write(u6,*) 'shll=',ishll,' nExp=',nExpi,' nBeta=',nBeta +call CrtCmp(Array(ipZ2),Array(ipP2),nExpi*nBeta,TC,Array(ipCxyz),iAng,HerR(iHerR(nHer)),nHer,ABeq) +call CrtCmp(Array(ipZ2),Array(ipP2),nExpi*nBeta,RB,Array(ipBxyz),lb+ld,HerR(iHerR(nHer)),nHer,ABeq) +ABeq(1) = .false. +ABeq(2) = .false. +ABeq(3) = .false. +call CrtCmp(Array(ipZ2),Array(ipP2),nExpi*nBeta,TC,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) +if (debug) then + write(u6,*) ' nBeta = ',nBeta,' nExp(',ishll,')=',nExpi,' nHer=',nHer,' lb=',lb,' iAng=',iAng,' nOrdOp=',nOrdOp + + write(u6,*) ' Array(ipCxyz)=',DNrm2_(nBeta*nExpi*3*nHer*(iAng+1),Array(ipCxyz),1) + write(u6,*) ' Array(ipBxyz)=',DNrm2_(nBeta*nExpi*3*nHer*(lb+2),Array(ipBxyz),1) + write(u6,*) ' Array(ipRxyz)=',DNrm2_(nBeta*nExpi*3*nHer*(nOrdOp+1),Array(ipRxyz),1) +end if + +call Assmbl(Array(ipQ1),Array(ipCxyz),iAng,Array(ipRxyz),nOrdOp,Array(ipBxyz),lb+ld,nExpi*nBeta,HerW(iHerW(nHer)),nHer) +iStrt = ipB +do iBeta=1,nBeta + Array(iStrt:iStrt+nExpi-1) = Beta(iBeta) + iStrt = iStrt+nExpi +end do +if (debug) then + write(u6,*) ' Array(ipB)=',DNrm2_(nExpi*nBeta,Array(ipB),1) +end if + +call rKappa_Zeta(Array(ipK2),Array(ipZ2),nExpi*nBeta) +call CmbnCB(Array(ipQ1),nExpi*nBeta,iAng,lb,Array(ipK2),FB1,Array(ipB),JfGrad,ld,nVecCB) +if (debug) then + write(u6,*) ' Array(ipQ1)=',DNrm2_(nExpi*nBeta*3*(lb+1+ld+2)*(iAng+1)*(nOrdOp+1),Array(ipQ1),1) + write(u6,*) ' Array(ipB)=',DNrm2_(nExpi*nBeta,Array(ipB),1) +end if +if (ld >= 2) then + call CmbnS2b(Array(ipQ1),nBeta*nExpi,iang,lb,Array(ipK2),FB2,Array(ipB),jfHess,ld) + if (debug) then + do i=1,6 + ipV = 1 + n = nBeta*nExpi*nTri_Elem1(lb)*nTri_Elem1(iAng) + write(u6,*) n,nBeta,nExpi,nTri_Elem1(lb),nTri_Elem1(iAng) + + write(u6,*) 'CmbnB2(',n,')=',DNrm2_(n,FB2(ipV),1) + ipV = ipV+n + end do + end if +end if + +return + +end subroutine coreB diff -Nru openmolcas-22.02/src/mckinley/cputime.fh openmolcas-22.10/src/mckinley/cputime.fh --- openmolcas-22.02/src/mckinley/cputime.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/cputime.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Parameter ( nOneel = 1 ) - Parameter ( nTwoel = 2 ) - Parameter ( nTwoDens = 3 ) - Parameter ( nIntegrals= 4 ) - Parameter ( nScreen = 5 ) - Parameter ( nTrans = 6 ) - Parameter ( nFckack = 7 ) - Parameter ( nMOTrans = 8 ) - Parameter ( nTotal = 9 ) - Real*8 cpustat(nTotal) - Common /ccputime/cpustat diff -Nru openmolcas-22.02/src/mckinley/crsph_mck.f openmolcas-22.10/src/mckinley/crsph_mck.f --- openmolcas-22.02/src/mckinley/crsph_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/crsph_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,65 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine CrSph_mck(Win,nijx,nab,Coeff1,n1,Tr1,Pr1, - & Wout,mab) -************************************************************************ -* * -* Object: to transform the one electron integrals from cartesian * -* basis to spherical basis. * -* * -* Called from: OneEl * -* * -* Calling : RecPrt * -* DGEMM_ (ESSL) * -* DGeTMO (ESSL) * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* February '90 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -c#include "print.fh" - Real*8 Win(nab*nijx), - & Coeff1((n1+1)*(n1+2)/2,(n1+1)*(n1+2)/2), - & Wout(mab*nijx) - Logical Tr1, Pr1 -* -c iRout = 26 -c iPrint = nPrint(iRout) - l1=(n1+1)*(n1+2)/2 - k1=l1 - If (Pr1) k1 = 2*n1 + 1 -* - If (Tr1) Then -* -* Starting with a,bIJx transforming to bIJx,A -* - Call DGEMM_('T','N', - & nijx,k1,l1, - & 1.0d0,Win,l1, - & Coeff1,l1, - & 0.0d0,Wout,nijx) -* - Else -* -* Transpose from ab,IJ,x to b,IJ,x,a -* - Call DGeTmO(Win,l1,l1,nijx,Wout,nijx) -* -* Start transforming b,IJ,x,a to IJ,x,aB -* - End If -* -* Call GetMem('CarSph','CHEC','REAL',iDum,iDum) - Return - End diff -Nru openmolcas-22.02/src/mckinley/crsph_mck.F90 openmolcas-22.10/src/mckinley/crsph_mck.F90 --- openmolcas-22.02/src/mckinley/crsph_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/crsph_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,68 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine CrSph_mck(Win,nijx,nab,Coeff1,n1,Tr1,Pr1,Wout,mab) +!*********************************************************************** +! * +! Object: to transform the one electron integrals from cartesian * +! basis to spherical basis. * +! * +! Called from: OneEl * +! * +! Calling : RecPrt * +! DGEMM_ (ESSL) * +! DGeTMO (ESSL) * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! February '90 * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: nijx, nab, n1, mab +real(kind=wp), intent(in) :: Win(nab*nijx), Coeff1(nTri_Elem1(n1),nTri_Elem1(n1)) +real(kind=wp), intent(_OUT_) :: Wout(mab*nijx) +logical(kind=iwp), intent(in) :: Tr1, Pr1 +integer(kind=iwp) :: k1, l1 + +!iRout = 26 +!iPrint = nPrint(iRout) +l1 = nTri_Elem1(n1) +k1 = l1 +if (Pr1) k1 = 2*n1+1 + +if (Tr1) then + + ! Starting with a,bIJx transforming to bIJx,A + + call DGEMM_('T','N',nijx,k1,l1,One,Win,l1,Coeff1,l1,Zero,Wout,nijx) + +else + + ! Transpose from ab,IJ,x to b,IJ,x,a + + call DGeTmO(Win,l1,l1,nijx,Wout,nijx) + + ! Start transforming b,IJ,x,a to IJ,x,aB + +end if + +return + +end subroutine CrSph_mck diff -Nru openmolcas-22.02/src/mckinley/ctldns.f openmolcas-22.10/src/mckinley/ctldns.f --- openmolcas-22.02/src/mckinley/ctldns.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/ctldns.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,41 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SubRoutine CtlDns(iDCRR,iDCRS,iDCRT,jOp) - - Integer jop(6) - -* Djl. Some care has to be taken here. Assume that there -* are two operators, T and S which generates the center -* pairs A,T(B) and A,S(B). If these pairs are symmetry -* related we will only -* -*--------------Dij - iR = iDCRR - jOp(1) = NrOpr(iR) + 1 -*--------------Dkl - iS = iDCRS - jOp(2) = NrOpr(iS) + 1 -*--------------Dik - iT = iDCRT - jOp(3) = NrOpr(iT) + 1 -*--------------Dil - iTS = iEor(iT,iS) - jOp(4) = NrOpr(iTS) + 1 -*--------------Djk - iRT = iEor(iR,iT) - jOp(5) = NrOpr(iRT) + 1 -*--------------Djl - iRTS= iEor(iRT,iS) - jOp(6) = NrOpr(iRTS) + 1 -* - Return - End -* diff -Nru openmolcas-22.02/src/mckinley/ctldns.F90 openmolcas-22.10/src/mckinley/ctldns.F90 --- openmolcas-22.02/src/mckinley/ctldns.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/ctldns.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,48 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine CtlDns(iDCRR,iDCRS,iDCRT,jOp) + +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: iDCRR, iDCRS, iDCRT +integer(kind=iwp), intent(out) :: jOp(6) +integer(kind=iwp) :: iR, iRT, iRTS, iS, iT, iTS +integer(kind=iwp), external :: NrOpr + +! Djl. Some care has to be taken here. Assume that there +! are two operators, T and S which generates the center +! pairs A,T(B) and A,S(B). If these pairs are symmetry +! related we will only + +! Dij +iR = iDCRR +jOp(1) = NrOpr(iR)+1 +! Dkl +iS = iDCRS +jOp(2) = NrOpr(iS)+1 +! Dik +iT = iDCRT +jOp(3) = NrOpr(iT)+1 +! Dil +iTS = ieor(iT,iS) +jOp(4) = NrOpr(iTS)+1 +! Djk +iRT = ieor(iR,iT) +jOp(5) = NrOpr(iRT)+1 +! Djl +iRTS = ieor(iRT,iS) +jOp(6) = NrOpr(iRTS)+1 + +return + +end subroutine CtlDns diff -Nru openmolcas-22.02/src/mckinley/ctrlmo.f openmolcas-22.10/src/mckinley/ctrlmo.f --- openmolcas-22.02/src/mckinley/ctrlmo.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/ctrlmo.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,27 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine CtrlMO(moip,nAcO) -* - use Symmetry_Info, only: nIrrep - Implicit Real*8 (a-h,o-z) -#include "etwas.fh" - Integer moip(0:nIrrep-1) -* - iTot=0 - Do iIrrep=0,nIrrep-1 - moip(iIrrep)=iTot - iTot=iTot+nAsh(iIrrep) - End Do - nACO=iTot - Return - End diff -Nru openmolcas-22.02/src/mckinley/ctrlmo.F90 openmolcas-22.10/src/mckinley/ctrlmo.F90 --- openmolcas-22.02/src/mckinley/ctrlmo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/ctrlmo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,33 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine CtrlMO(moip,nAcO) + +use Symmetry_Info, only: nIrrep +use Definitions, only: Iwp + +implicit none +#include "etwas.fh" +integer(kind=iwp), intent(out) :: moip(0:nIrrep-1), nAcO +integer(kind=iwp) :: iIrrep, iTot + +iTot = 0 +do iIrrep=0,nIrrep-1 + moip(iIrrep) = iTot + iTot = iTot+nAsh(iIrrep) +end do +nACO = iTot + +return + +end subroutine CtrlMO diff -Nru openmolcas-22.02/src/mckinley/dan.f openmolcas-22.10/src/mckinley/dan.f --- openmolcas-22.02/src/mckinley/dan.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/dan.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,86 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine DAN(Dens) -* - use Basis_Info, only: nBas - use pso_stuff - use Symmetry_Info, only: nIrrep - Implicit Real*8 (a-h,o-z) -#include "etwas.fh" -#include "real.fh" -#include "stdalloc.fh" - Real*8 Dens(nDens) - Integer na(0:7),ipcm(0:7) - Real*8, Allocatable:: Temp1(:), Temp2(:), Temp3(:) -* - itri(i,j)=Max(i,j)*(Max(i,j)-1)/2+Min(i,j) -* - ipD=0 - nnA=0 - ndenssq=0 - ipCC=1 - Do i=0,nIrrep-1 - nDenssq=ndenssq+nBas(i)**2 - nA(i)=nnA - ipcm(i)=ipCC - nnA=nnA+nAsh(i) - ipCC=ipCC+nBas(i)**2 - End Do -* - Call mma_allocate(Temp1,nDensSQ,Label='Temp1') - Call mma_allocate(Temp2,nDensSQ,Label='Temp2') - Call mma_allocate(Temp3,nDensSQ,Label='Temp3') -* - Do iS=0,nIrrep-1 - Temp1(:)=Zero - If (nBas(is).gt.0) Then - Do iB=1,nAsh(iS) - iiB=nA(iS)+iB - Do jB=1,nAsh(iS) - jjB=nA(iS)+jB - ijB=iTri(iiB,jjB) - ip1= nBas(iS)*(nISh(iS)+iB-1)+nIsh(is)+jb - Temp1(ip1)=G1(ijB,1) - End Do - End Do -* - Call DGEMM_('N','N', - & nBas(is),nBas(is),nBas(is), - & 1.0d0,CMO(ipCM(iS),1),nBas(is), - & Temp1,nBas(is), - & 0.0d0,Temp3,nBas(is)) - Call DGEMM_('N','T', - & nBas(is),nBas(is),nBas(is), - & 1.0d0,Temp3,nBas(is), - & CMO(ipCM(is),1),nBas(is), - & 0.0d0,Temp2,nBas(is)) -* - Do iBas=1,nBas(iS) - Do jBas=1,iBas - ip1=(iBas-1)*nBas(iS)+jBas - ip2=iTri(iBas,jBas) - Fact=2.0d0 - If (iBas.eq.jBas) Fact=1.0d0 - Dens(ipD+ip2)=Temp2(ip1)*Fact - End Do - End Do - ipD=ipD+nBas(is)*(nBas(is)+1)/2 - End If - End Do - - Call mma_deallocate(Temp3) - Call mma_deallocate(Temp2) - Call mma_deallocate(Temp1) -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/dan.F90 openmolcas-22.10/src/mckinley/dan.F90 --- openmolcas-22.02/src/mckinley/dan.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/dan.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,80 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine DAN(Dens) + +use Index_Functions, only: iTri, nTri_Elem +use Basis_Info, only: nBas +use pso_stuff, only: CMO, G1, nDens +use Symmetry_Info, only: nIrrep +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(out) :: Dens(nDens) +#include "etwas.fh" +integer(kind=iwp) :: i, iB, iBas, iiB, ijB, ip1, ip2, ipCC, ipcm(0:7), ipD, iS, jB, jjB, na(0:7), ndenssq, nnA +real(kind=wp), allocatable :: Temp1(:), Temp2(:), Temp3(:) + +ipD = 0 +nnA = 0 +ndenssq = 0 +ipCC = 1 +do i=0,nIrrep-1 + nDenssq = ndenssq+nBas(i)**2 + nA(i) = nnA + ipcm(i) = ipCC + nnA = nnA+nAsh(i) + ipCC = ipCC+nBas(i)**2 +end do + +call mma_allocate(Temp1,nDensSQ,Label='Temp1') +call mma_allocate(Temp2,nDensSQ,Label='Temp2') +call mma_allocate(Temp3,nDensSQ,Label='Temp3') + +do iS=0,nIrrep-1 + Temp1(:) = Zero + if (nBas(is) > 0) then + do iB=1,nAsh(iS) + iiB = nA(iS)+iB + do jB=1,nAsh(iS) + jjB = nA(iS)+jB + ijB = iTri(iiB,jjB) + ip1 = nBas(iS)*(nISh(iS)+iB-1)+nIsh(is)+jb + Temp1(ip1) = G1(ijB,1) + end do + end do + + call DGEMM_('N','N',nBas(is),nBas(is),nBas(is),One,CMO(ipCM(iS),1),nBas(is),Temp1,nBas(is),Zero,Temp3,nBas(is)) + call DGEMM_('N','T',nBas(is),nBas(is),nBas(is),One,Temp3,nBas(is),CMO(ipCM(is),1),nBas(is),Zero,Temp2,nBas(is)) + + ip1 = 0 + ip2 = ipD + do iBas=1,nBas(iS) + Dens(ip2+1:ip2+iBas-1) = Two*Temp2(ip1+1:ip1+iBas-1) + Dens(ip2+iBas) = Temp2(ip1+iBas) + ip2 = ip2+iBas + ip1 = ip1+nBas(iS) + end do + ipD = ipD+nTri_Elem(nBas(is)) + end if +end do + +call mma_deallocate(Temp3) +call mma_deallocate(Temp2) +call mma_deallocate(Temp1) + +return + +end subroutine DAN diff -Nru openmolcas-22.02/src/mckinley/dede_mck.f openmolcas-22.10/src/mckinley/dede_mck.f --- openmolcas-22.02/src/mckinley/dede_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/dede_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine DeDe_Mck(FD,nFD,ipOffD,nOffD,DDen,lDDen,mDeDe,mIndij) - use k2_arrays, only: MaxDe - Real*8 FD(nFD), DDen(lDDen) - Integer ipOffD(nOffD) - Logical Special_NoSym, DFT_Storage -* - Special_NoSym=.False. - DFT_Storage=.False. - nr_of_Densities=1 -* - ipDeDe=1 - ipD00=1 -! ipDijS is controlled in the calling routine - Call mk_DeDe(FD,nFD,nr_of_Densities,ipOffD,nOffD,ipDeDe,ipD00, - & MaxDe,mDeDe,mIndij,Special_NoSym,DFT_Storage, - & DDen,lDDen) -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/dede_mck.F90 openmolcas-22.10/src/mckinley/dede_mck.F90 --- openmolcas-22.02/src/mckinley/dede_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/dede_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,36 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine DeDe_Mck(FD,nFD,ipOffD,nOffD,DDen,lDDen,mDeDe,mIndij) + +use k2_arrays, only: MaxDe +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nFD, nOffD, lDDen +real(kind=wp), intent(in) :: FD(nFD) +integer(kind=iwp), intent(out) :: ipOffD(3,nOffD), mDeDe, mIndij +real(kind=wp), intent(out) :: DDen(lDDen) +integer(kind=iwp) :: ipD00, ipDeDe, nr_of_Densities +logical(kind=iwp) :: DFT_Storage, Special_NoSym + +Special_NoSym = .false. +DFT_Storage = .false. +nr_of_Densities = 1 + +ipDeDe = 1 +ipD00 = 1 +! ipDijS is controlled in the calling routine +call mk_DeDe(FD,nFD,nr_of_Densities,ipOffD,nOffD,ipDeDe,ipD00,MaxDe,mDeDe,mIndij,Special_NoSym,DFT_Storage,DDen,lDDen) + +return + +end subroutine DeDe_Mck diff -Nru openmolcas-22.02/src/mckinley/derctr.f openmolcas-22.10/src/mckinley/derctr.f --- openmolcas-22.02/src/mckinley/derctr.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/derctr.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,260 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine DerCtr(mdci,mdcj,mdck,mdcl,ldot, - & JfGrd,IndGrd,JfHss,IndHss,JfG,mbatch) -* * -************************************************************************ -* * - use Center_Info - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "disp.fh" -#include "disp2.fh" - Logical JfHss(4,3,4,3),IfHss(4,3,4,3),JfGrd(3,4),IfGrd(3,4), - & IfG(4),JfG(4),ldot - Integer IndHss(4,3,4,3,0:7),JndHss(4,3,4,3,0:7), - & IndGrd(3,4,0:7),JndGrd(3,4,0:7) - Logical, External :: TF -*define _OLD_CODE_ -#ifdef _OLD_CODE_ - Integer iCo(4), iCom(0:7,0:7),iStabM(0:7), idcrr(0:7) - Logical chck - Logical, External :: TstFnc -#endif -* - Ind(i1,i2)=i1*(i1-1)/2+i2 -* - nnIrrep=nIrrep - Call lCopy(12,[.false.],0,ifgrd,1) - If (sIrrep) nnIrrep=1 -* - Do 3000 iIrrep=0,nnIrrep-1 - nDisp = IndDsp(mdci,iIrrep) - Do 3001 iCar = 0, 2 - iComp = 2**iCar - If (TF(mdci,iIrrep,iComp)) Then - nDisp = nDisp + 1 - IndGrd(iCar+1,1,iIrrep) = nDisp - IfGrd(iCar+1,1) = .True. - Else - IndGrd(iCar+1,1,iIrrep) = 0 - End If - 3001 Continue - 3000 Continue - Do 3100 iIrrep=0,nnIrrep-1 - nDisp = IndDsp(mdcj,iIrrep) - Do 3101 iCar = 0, 2 - iComp = 2**iCar - If (TF(mdcj,iIrrep,iComp)) Then - nDisp = nDisp + 1 - IndGrd(iCar+1,2,iIrrep) = nDisp - IfGrd(iCar+1,2) = .True. - Else - IndGrd(iCar+1,2,iIrrep) = 0 - End If - 3101 Continue - 3100 Continue - Do 3200 iIrrep=0,nnIrrep-1 - nDisp = IndDsp(mdck,iIrrep) - Do 3201 iCar = 0, 2 - iComp = 2**iCar - If (TF(mdck,iIrrep,iComp)) Then - nDisp = nDisp + 1 - IndGrd(iCar+1,3,iIrrep) = nDisp - IfGrd(iCar+1,3) = .True. - Else - IndGrd(iCar+1,3,iIrrep) = 0 - End If - 3201 Continue - 3200 Continue - Do 3300 iIrrep=0,nnIrrep-1 - nDisp = IndDsp(mdcl,iIrrep) - Do 3301 iCar = 0, 2 - iComp = 2**iCar - If (TF(mdcl,iIrrep,iComp)) Then - nDisp = nDisp + 1 - IndGrd(iCar+1,4,iIrrep) = nDisp - IfGrd(iCar+1,4) = .True. - Else - IndGrd(iCar+1,4,iIrrep) = 0 - End If - 3301 Continue - 3300 Continue - Do iIrrep=0,nnIrrep-1 - Do 3333 iCar = 1, 3 - Do 4444 iSh = 1, 4 - JndGrd(iCar,iSh,iIrrep) = - & IndGrd(iCar,iSh,iIrrep) - JfGrd(iCar,iSh) = - & IfGrd(iCar,iSh) - 4444 Continue - 3333 Continue - End Do -#ifdef _OLD_CODE_ - iCo(1)=mdci - iCo(2)=mdcj - iCo(3)=mdck - iCo(4)=mdcl -#endif - Call iCopy(144*nirrep,[0],0,IndHss,1) - Call iCopy(144*nirrep,[0],0,jndHss,1) - Call lCopy(144,[.false.],0,IfHss,1) - Call lCopy(144,[.false.],0,JfHss,1) - if (.not.ldot) Return -* - Do iAtom=1,4 - Do jAtom=1,iAtom -* -* This segment of the code is not really needed. -* If turned on it should not do much of a difference. -* -#ifdef _OLD_CODE_ - Call DCR(LmbdR,dc(iCo(iAtom))%iStab,dc(iCo(iAtom))%nStab, - & dc(iCo(jAtom))%iStab,dc(iCo(jAtom))%nStab, - & iDCRR,nDCRR) -* -*-----------Find the stabilizer for A and B -* - Call Inter(dc(iCo(iAtom))%iStab,dc(iCo(iAtom))%nStab, - & dc(iCo(jAtom))%iStab,dc(iCo(jAtom))%nStab, - & iStabM,nStabM) -* -* Generate all possible (left) CoSet -* To the stabil. of A and B -* - Do iIrrep = 0, nIrrep-1 - Do jOper = 0, nStabM-1 - iCoM(iIrrep,jOper) = - & iEor(iOper(iIrrep),iStabM(jOper)) - End Do - End Do -* -* Order the Coset so we will have the unique ones first -* Check uniqueness -* - nMax = 1 - Do 435 j = 1, nIrrep-1 - Do 436 i = 0, nMax - 1 - Do 437 ielem = 0, nStabM-1 - If (iCoM(i,1).eq.iCoM(j,ielem)) - & Go To 435 - 437 Continue - 436 Continue -* -*----------Move unique CoSet -* - nMax = nMax + 1 - Do 438 ielem = 0, nStabM-1 - iTmp = iCoM(nMax-1,ielem) - iCoM(nMax-1,ielem) = iCoM(j,ielem) - iCoM(j,ielem) = iTmp - 438 Continue - If (nMax.eq.nIrrep/nStabM) Go To 439 - 435 Continue - 439 Continue -* -* Check if the derivative is needed in the present symmetry -* - nCoM=nIrrep/nStabM -* - Do iCar=1,3 - if (iAtom.eq.jAtom) Then - istop=iCar - Else - iStop=3 - End If - Do jCar=1,istop - iComp=iEOr(2**(iCar-1),2**(jCar-1)) - Chck=TstFnc(iCoM,0,iComp,nStabM) - If (Chck) - & IfHss(iAtom,iCar,jAtom,jCar)=.true. - End Do - End Do -#endif -* -* Calculate the index for the derivative -* - Do iIrrep=0,nnIrrep-1 - Do iCar=1,3 - if (iAtom.eq.jAtom) Then - istop=iCar - Else - iStop=3 - End If - Do jCar=1,istop - IfHss(iAtom,iCar,jAtom,jCar)=.true. - If ((jndGrd(iCar,iAtom,iIrrep).gt.0).and. - & (jndGrd(jCar,jAtom,iIrrep).gt.0)) - & Then - IndHss(iAtom,iCar,jAtom,jCar,iIrrep)= - & Ind(Max(JndGrd(iCar,iAtom,iIrrep), - & jndGrd(jCar,jAtom,iIrrep)), - & Min(jndGrd(iCar,iAtom,iIrrep), - & jndGrd(jCar,jAtom,iIrrep))) - Else - IndHss(iAtom,iCar,jAtom,jCar,iIrrep)=0 - End If - End Do - End Do - End Do - End Do - End Do -* -* Scramble the control array for the hessian -* - Call LCopy(4,[.true.],0,Ifg,1) - Do iAtom=1,4 - JfG(iAtom)=IfG(iAtom) - Do jAtom=1,iAtom - Do iCar=1,3 - If (iAtom.eq.jAtom) Then - iStop=iCar - Else - iStop=3 - End If - Do jCar=1,iStop - If (iAtom.ge.jAtom) Then - JfHss(iAtom,iCar,jAtom,jCar)= - & IfHss(iAtom,iCar,jAtom,jCar) - Else If (iAtom.lt.jAtom) Then - JfHss(iAtom,iCar,jAtom,jCar)= - & IfHss(jAtom,jCar,iAtom,iCar) - End If - End Do - End Do - End Do - End Do - If (sIrrep) Then - Do ii=1,4 - Do ic1=1,3 - If (indgrd(ic1,ii,0).eq.0) - & jfgrd(ic1,ii)=.false. - Do ij=1,4 - Do ic2=1,3 - If (Indhss(ii,ic1,ij,ic2,0).eq.0) - & JfHss(ii,ic1,ij,ic2)=.false. - End Do - End Do - End Do - End Do - End If -*---------------------------------------------------------------- -* -* End Hess -* -*----------------------------------------------------------------------* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(mbatch) - End diff -Nru openmolcas-22.02/src/mckinley/derctr.F90 openmolcas-22.10/src/mckinley/derctr.F90 --- openmolcas-22.02/src/mckinley/derctr.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/derctr.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,231 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine DerCtr(mdci,mdcj,mdck,mdcl,ldot,JfGrd,IndGrd,JfHss,IndHss,JfG) + +!#define _OLD_CODE_ +use McKinley_global, only: sIrrep +use Index_Functions, only: iTri +use Symmetry_Info, only: nIrrep +#ifdef _OLD_CODE_ +use Center_Info, only: dc +use Symmetry_Info, only: iOper +#endif +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: mdci, mdcj, mdck, mdcl +logical(kind=iwp), intent(in) :: ldot +logical(kind=iwp), intent(out) :: JfGrd(3,4), JfHss(4,3,4,3), JfG(4) +integer(kind=iwp), intent(out) :: IndGrd(3,4,0:7), IndHss(4,3,4,3,0:7) +#include "Molcas.fh" +#include "disp.fh" +integer(kind=iwp) :: iAtom, ic1, ic2, iCar, iComp, ii, iIrrep, ij, istop, jAtom, jCar, JndGrd(3,4,0:7), nDisp, nnIrrep +logical(kind=iwp) :: IfG(4), IfGrd(3,4), IfHss(4,3,4,3) +logical(kind=iwp), external :: TF +#ifdef _OLD_CODE_ +integer(kind=iwp) :: i, iCo(4), iCom(0:7,0:7), idcrr(0:7), ielem, iStabM(0:7), iTmp(0:7), j, jOper, LmbdR, nDCRR, nCoM, nMax, nStabM +logical(kind=iwp) :: chck +logical(kind=iwp), external :: TstFnc +#endif + +nnIrrep = nIrrep +IfGrd(:,:) = .false. +if (sIrrep) nnIrrep = 1 + +do iIrrep=0,nnIrrep-1 + nDisp = IndDsp(mdci,iIrrep) + do iCar=0,2 + iComp = 2**iCar + if (TF(mdci,iIrrep,iComp)) then + nDisp = nDisp+1 + IndGrd(iCar+1,1,iIrrep) = nDisp + IfGrd(iCar+1,1) = .true. + else + IndGrd(iCar+1,1,iIrrep) = 0 + end if + end do +end do +do iIrrep=0,nnIrrep-1 + nDisp = IndDsp(mdcj,iIrrep) + do iCar=0,2 + iComp = 2**iCar + if (TF(mdcj,iIrrep,iComp)) then + nDisp = nDisp+1 + IndGrd(iCar+1,2,iIrrep) = nDisp + IfGrd(iCar+1,2) = .true. + else + IndGrd(iCar+1,2,iIrrep) = 0 + end if + end do +end do +do iIrrep=0,nnIrrep-1 + nDisp = IndDsp(mdck,iIrrep) + do iCar=0,2 + iComp = 2**iCar + if (TF(mdck,iIrrep,iComp)) then + nDisp = nDisp+1 + IndGrd(iCar+1,3,iIrrep) = nDisp + IfGrd(iCar+1,3) = .true. + else + IndGrd(iCar+1,3,iIrrep) = 0 + end if + end do +end do +do iIrrep=0,nnIrrep-1 + nDisp = IndDsp(mdcl,iIrrep) + do iCar=0,2 + iComp = 2**iCar + if (TF(mdcl,iIrrep,iComp)) then + nDisp = nDisp+1 + IndGrd(iCar+1,4,iIrrep) = nDisp + IfGrd(iCar+1,4) = .true. + else + IndGrd(iCar+1,4,iIrrep) = 0 + end if + end do +end do +JndGrd(:,:,0:nnIrrep-1) = IndGrd(:,:,0:nnIrrep-1) +JfGrd(:,:) = IfGrd(:,:) +#ifdef _OLD_CODE_ +iCo(1) = mdci +iCo(2) = mdcj +iCo(3) = mdck +iCo(4) = mdcl +#endif +IndHss(:,:,:,:,0:nirrep-1) = 0 +IfHss(:,:,:,:) = .false. +JfHss(:,:,:,:) = .false. +if (.not. ldot) return + +do iAtom=1,4 + do jAtom=1,iAtom + + ! This segment of the code is not really needed. + ! If turned on it should not do much of a difference. + +# ifdef _OLD_CODE_ + call DCR(LmbdR,dc(iCo(iAtom))%iStab,dc(iCo(iAtom))%nStab,dc(iCo(jAtom))%iStab,dc(iCo(jAtom))%nStab,iDCRR,nDCRR) + + ! Find the stabilizer for A and B + + call Inter(dc(iCo(iAtom))%iStab,dc(iCo(iAtom))%nStab,dc(iCo(jAtom))%iStab,dc(iCo(jAtom))%nStab,iStabM,nStabM) + + ! Generate all possible (left) CoSet + ! To the stabilizer of A and B + + do jOper=0,nStabM-1 + iCoM(0:nIrrep-1,jOper) = ieor(iOper(0:nIrrep-1),iStabM(jOper)) + end do + + ! Order the Coset so we will have the unique ones first + ! Check uniqueness + + nMax = 1 + outer: do j=1,nIrrep-1 + do i=0,nMax-1 + do ielem=0,nStabM-1 + if (iCoM(i,1) == iCoM(j,ielem)) cycle outer + end do + end do + + ! Move unique CoSet + + nMax = nMax+1 + iTmp(0:nStabM-1) = iCoM(nMax-1,0:nStabM-1) + iCoM(nMax-1,0:nStabM-1) = iCoM(j,0:nStabM-1) + iCoM(j,0:nStabM-1) = iTmp(0:nStabM-1) + if (nMax == nIrrep/nStabM) exit outer + end do outer + + ! Check if the derivative is needed in the present symmetry + + nCoM = nIrrep/nStabM + + do iCar=1,3 + if (iAtom == jAtom) then + istop = iCar + else + iStop = 3 + end if + do jCar=1,istop + iComp = ieor(2**(iCar-1),2**(jCar-1)) + Chck = TstFnc(iCoM,0,iComp,nStabM) + if (Chck) IfHss(iAtom,iCar,jAtom,jCar) = .true. + end do + end do +# endif + + ! Calculate the index for the derivative + + do iIrrep=0,nnIrrep-1 + do iCar=1,3 + if (iAtom == jAtom) then + iStop = iCar + else + iStop = 3 + end if + do jCar=1,iStop + IfHss(iAtom,iCar,jAtom,jCar) = .true. + if ((jndGrd(iCar,iAtom,iIrrep) > 0) .and. (jndGrd(jCar,jAtom,iIrrep) > 0)) then + IndHss(iAtom,iCar,jAtom,jCar,iIrrep) = iTri(JndGrd(iCar,iAtom,iIrrep),JndGrd(jCar,jAtom,iIrrep)) + else + IndHss(iAtom,iCar,jAtom,jCar,iIrrep) = 0 + end if + end do + end do + end do + end do +end do + +! Scramble the control array for the hessian + +IfG(:) = .true. +do iAtom=1,4 + JfG(iAtom) = IfG(iAtom) + do jAtom=1,iAtom + do iCar=1,3 + if (iAtom == jAtom) then + iStop = iCar + else + iStop = 3 + end if + if (iAtom >= jAtom) then + JfHss(iAtom,iCar,jAtom,1:iStop) = IfHss(iAtom,iCar,jAtom,1:iStop) + else if (iAtom < jAtom) then + JfHss(iAtom,iCar,jAtom,1:iStop) = IfHss(jAtom,1:iStop,iAtom,iCar) + end if + end do + end do +end do +if (sIrrep) then + do ii=1,4 + do ic1=1,3 + if (IndGrd(ic1,ii,0) == 0) JfGrd(ic1,ii) = .false. + do ij=1,4 + do ic2=1,3 + if (IndHss(ii,ic1,ij,ic2,0) == 0) JfHss(ii,ic1,ij,ic2) = .false. + end do + end do + end do + end do +end if +!----------------------------------------------------------------------* +! +! End Hess +! +!----------------------------------------------------------------------* + +return + +end subroutine DerCtr diff -Nru openmolcas-22.02/src/mckinley/din.f openmolcas-22.10/src/mckinley/din.f --- openmolcas-22.02/src/mckinley/din.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/din.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine DIN(Dens) -* - use Basis_Info, only: nBas - use pso_stuff - use Symmetry_Info, only: nIrrep - Implicit Real*8 (a-h,o-z) -#include "real.fh" -#include "etwas.fh" -#include "stdalloc.fh" - Real*8 Dens(nDens) - Real*8, Allocatable:: Temp2(:) -* * -************************************************************************ -* * - nTemp2=0 - Do iIrr=0,nIrrep-1 - nTemp2=Max(nTemp2,nBas(iIrr)) - End Do - - Call mma_allocate(Temp2,nTemp2**2,Label='Temp2') - - ip=1 - ipD=0 - Do iIrr=0,nIrrep-1 - - If (nBas(iIrr)==0) Cycle - - Call DGEMM_('N','T', - & nBas(iIrr),nBas(iIrr),nIsh(iIrr), - & One,CMO(ip,1),nBas(iIrr), - & CMO(ip,1),nBas(iIrr), - & Zero,Temp2,nBas(iIrr)) - Do iBas=1,nBas(iIrr) - Do jBas=1,iBas-1 - ip1=(iBas-1)*nBas(iIrr)+jBas - ip2=iBas*(iBas-1)/2+jBas - Dens(ipD+ip2)=Temp2(ip1)*Four - End Do - ip1=(iBas-1)*nBas(iIrr)+iBas - ip2=iBas*(iBas+1)/2 - Dens(ipD+ip2)=Temp2(ip1)*Two - End Do - ip=ip+nBas(iIrr)**2 - ipd=ipD+nBas(iIrr)*(nBas(iIrr)+1)/2 - - End Do - - Call mma_deallocate(Temp2) - - Return - End diff -Nru openmolcas-22.02/src/mckinley/din.F90 openmolcas-22.10/src/mckinley/din.F90 --- openmolcas-22.02/src/mckinley/din.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/din.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,64 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine DIN(Dens) + +use Index_Functions, only: nTri_Elem +use Basis_Info, only: nBas +use pso_stuff, only: CMO, nDens +use Symmetry_Info, only: nIrrep +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Four +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(out) :: Dens(nDens) +#include "etwas.fh" +integer(kind=iwp) :: iBas, iIrr, ip, ip1, ip2, ipD, nTemp2 +real(kind=wp), allocatable :: Temp2(:) + +! * +!*********************************************************************** +! * +nTemp2 = 0 +do iIrr=0,nIrrep-1 + nTemp2 = max(nTemp2,nBas(iIrr)) +end do + +call mma_allocate(Temp2,nTemp2**2,Label='Temp2') + +ip = 1 +ipD = 0 +do iIrr=0,nIrrep-1 + + if (nBas(iIrr) == 0) cycle + + call DGEMM_('N','T',nBas(iIrr),nBas(iIrr),nIsh(iIrr),One,CMO(ip,1),nBas(iIrr),CMO(ip,1),nBas(iIrr),Zero,Temp2,nBas(iIrr)) + ip1 = 0 + ip2 = ipD + do iBas=1,nBas(iIrr) + Dens(ip2+1:ip2+iBas-1) = Four*Temp2(ip1+1:ip1+iBas-1) + Dens(ip2+iBas) = Two*Temp2(ip1+iBas) + ip1 = ip1+nBas(iIrr) + ip2 = ip2+iBas + end do + ip = ip+nBas(iIrr)**2 + ipD = ipD+nTri_Elem(nBas(iIrr)) + +end do + +call mma_deallocate(Temp2) + +return + +end subroutine DIN diff -Nru openmolcas-22.02/src/mckinley/dot1el2.f openmolcas-22.10/src/mckinley/dot1el2.f --- openmolcas-22.02/src/mckinley/dot1el2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/dot1el2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,381 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990,1991, Roland Lindh * -* 1990, IBM * -* 1994, Anders Bernhardsson * -************************************************************************ - SubRoutine Dot1El2(Kernel,KrnlMm,Hess,nGrad,DiffOp,CCoor, - & FD,nordop) -************************************************************************ -* * -* Object: to compute gradients of the one electron integrals. * -* The memory at this point is assumed to be large enough to do * -* the computation in core. * -* The data is structured with respect to four indices, two (my * -* ny or i j) refer to primitives or basis functions and two (a * -* b) refer to the components of the cartesian or spherical * -* harmonic gaussians. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* January '90 * -* Modified for Hermite-Gauss quadrature November '90 * -* Modified for Rys quadrature November '90 * -* Modified for multipole moments November '90 * -* * -* Modified for general kernel routines January '91 * -* Modified for nonsymmetrical operators February '91 * -* Modified for gradients October '91 * -* Modified for Hessians by AB Dec '94 * -************************************************************************ - use Real_Spherical - use iSD_data - use Basis_Info - use Center_Info - use Symmetry_Info, only: nIrrep, iOper - use Sizes_of_Seward, only: S - Implicit Real*8 (A-H,O-Z) - External Kernel, KrnlMm -#include "Molcas.fh" -#include "real.fh" -#include "stdalloc.fh" -#include "disp.fh" -#include "nsd.fh" -#include "setup.fh" - Real*8 A(3), B(3), Ccoor(3), FD(*), - & RB(3), Hess(nGrad) - Integer iDCRR(0:7), iDCRT(0:7), iStabM(0:7),iCoM(0:7,0:7), - & nOp(2), - & iStabO(0:7),IndGrd(2,3,3,0:7) - Logical AeqB, EQ, DiffOp - Real*8, Allocatable:: Zeta(:), ZI(:), Kappa(:), PCoor(:,:), - & Kern(:), Scrt1(:), Scrt2(:), DAO(:), - & DSOpr(:), DSO(:) - Logical, External :: TF -* -* Statement function -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - call dcopy_(nGrad,[Zero],0,Hess,1) -* -* Auxiliary memory allocation. -* - Call mma_allocate(Zeta,S%m2Max,Label='Zeta') - Call mma_allocate(ZI,S%m2Max,Label='ZI') - Call mma_allocate(Kappa,S%m2Max,Label='Kappa') - Call mma_allocate(PCoor,S%m2Max,3,Label='PCoor') -* * -************************************************************************ -* * - Call Set_Basis_Mode('Valence') - Call Nr_Shells(nSkal) - Call Setup_iSD() -* * -************************************************************************ -* * -* Double loop over shells. -* - nTasks = nSkal*(nSkal+1)/2 - iS = 0 - jS = 0 - Do ijS = 1, nTasks - jS = jS + 1 - If (jS.gt.iS) Then - iS = jS - jS = 1 - End If -C Do iS = 1, nSkal - iShll = iSD( 0,iS) - iAng = iSD( 1,iS) - iCmp = iSD( 2,iS) - iBas = iSD( 3,iS) - iPrim = iSD( 5,iS) - iAO = iSD( 7,iS) - mdci = iSD(10,iS) - iShell = iSD(11,iS) - iCnttp = iSD(13,iS) - iCnt = iSD(14,iS) - A(1:3)=dbsc(iCnttp)%Coor(1:3,iCnt) -* -C Do jS = 1, iS - jShll = iSD( 0,jS) - jAng = iSD( 1,jS) - jCmp = iSD( 2,jS) - jBas = iSD( 3,jS) - jPrim = iSD( 5,jS) - jAO = iSD( 7,jS) - mdcj = iSD(10,jS) - jShell = iSD(11,jS) - jCnttp = iSD(13,jS) - jCnt = iSD(14,jS) - B(1:3)=dbsc(jCnttp)%Coor(1:3,jCnt) -* -* Call kernel routine to get memory requirement. -* - Call KrnlMm(nOrder,MemKer,iAng,jAng,nOrdOp) - MemKrn=MemKer*S%m2Max - Call mma_allocate(Kern,MemKrn,Label='Kern') -* -* Allocate memory for the final integrals, all in the -* primitive basis. -* -* -* Scratch area for contraction step -* - nScrt1 = S%MaxPrm(iAng)*S%MaxPrm(jAng) * - & nElem(iAng)*nElem(jAng) - Call mma_allocate(Scrt1,nScrt1,Label='Scrt1') -* -* Scratch area for the transformation to spherical gaussians -* - nScrt2=S%MaxPrm(iAng)*S%MaxPrm(jAng)*nElem(iAng)*nElem(jAng) - Call mma_allocate(Scrt2,nScrt2,Label='Scrt2') -* - nDAO=iPrim*jPrim*nElem(iAng)*nElem(jAng) - Call mma_allocate(DAO,nDAO,Label='DAO') -* -* At this point we can compute Zeta. -* - Call ZXia(Zeta,ZI, - & iPrim,jPrim,Shells(iShll)%Exp, - & Shells(jShll)%Exp) -* - AeqB = iS.eq.jS -* -* Find the DCR for A and B -* - Call DCR(LmbdR,dc(mdci)%iStab,dc(mdci)%nStab, - & dc(mdcj)%iStab,dc(mdcj)%nStab,iDCRR,nDCRR) - If (.Not.DiffOp .and. nDCRR.eq.1 .and. EQ(A,B)) Go To 131 -* -*-----------Find the stabilizer for A and B -* - Call Inter(dc(mdci)%iStab,dc(mdci)%nStab, - & dc(mdcj)%iStab,dc(mdcj)%nStab, - & iStabM,nStabM) -* -* Generate all possible (left) CoSet -* To the stabil. of A and B -* - Do 433 i = 0, nIrrep-1 - Do 434 j = 0, nStabM-1 - iCoM(i,j) = iEor(iOper(i),iStabM(j)) - 434 Continue - 433 Continue -* Order the Coset so we will have the unique ones first - nMax = 1 - Do 435 j = 1, nIrrep-1 -* Check uniqueness - Do 436 i = 0, nMax - 1 - Do 437 ielem = 0, nStabM-1 - If (iCoM(i,1).eq.iCoM(j,ielem)) - & Go To 435 - 437 Continue - 436 Continue -* Move unique CoSet - nMax = nMax + 1 - Do 438 ielem = 0, nStabM-1 - iTmp = iCoM(nMax-1,ielem) - iCoM(nMax-1,ielem) = iCoM(j,ielem) - iCoM(j,ielem) = iTmp - 438 Continue - If (nMax.eq.nIrrep/nStabM) Go To 439 - 435 Continue - 439 Continue -* -* Allocate memory for the elements of the Fock or 1st order -* denisty matrix which are associated with the current shell -* pair. -* - iSmLbl = 1 - nSO = MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO) - If (nSO.eq.0) Go To 131 - Call mma_allocate(DSOpr,nSO*iPrim*jPrim,Label='DSOpr') - DSOpr(:)=Zero - Call mma_allocate(DSO,nSO*iPrim*jPrim,Label='DSO') - DSO(:)=Zero -* -* Gather the elements from 1st order density / Fock matrix. -* - Call SOGthr(DSO,iBas,jBas,nSO,FD, - & n2Tri(iSmLbl),iSmLbl, - & iCmp,jCmp,iShell,jShell, - & AeqB,iAO,jAO) -* -* Project the Fock/1st order density matrix in AO -* basis on to the primitive basis. -* -* -* Transform IJ,AB to J,ABi - Call DGEMM_('T','T', - & jBas*nSO,iPrim,iBas, - & 1.0d0,DSO,iBas, - & Shells(iShll)%pCff,iPrim, - & 0.0d0,DSOpr,jBas*nSO) -* Transform J,ABi to AB,ij - Call DGEMM_('T','T', - & nSO*iPrim,jPrim,jBas, - & 1.0d0,DSOpr,jBas, - & Shells(jShll)%pCff,jPrim, - & 0.0d0,DSO,nSO*iPrim) -* Transpose to ij,AB - Call DGeTmO(DSO,nSO,nSO,iPrim*jPrim,DSOpr, - & iPrim*jPrim) - Call mma_deallocate(DSO) -* -* -* Loops over symmetry operations. -* - nOp(1) = NrOpr(0) - if(jBas.lt.-999999) write(6,*) 'gcc overoptimization',nDCRR - Do 140 lDCRR = 0, nDCRR-1 - Call OA(iDCRR(lDCRR),B,RB) - nOp(2) = NrOpr(iDCRR(lDCRR)) - If (EQ(A,RB).and. (.Not.DiffOp)) Go To 140 -* -* - lloper=1 - Call SOS(iStabO,nStabO,llOper) - Call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) -* -*--------------Compute normalization factor due the DCR symmetrization -* of the two basis functions and the operator. -* - iuv = dc(mdci)%nStab*dc(mdcj)%nStab - FactNd = DBLE(iuv*nStabO) / DBLE(nIrrep**2 * LmbdT) - If (MolWgh.eq.1) Then - FactNd = FactNd * DBLE(nIrrep)**2 / DBLE(iuv) - Else If (MolWgh.eq.2) Then - FactNd = sqrt(DBLE(iuv))*nStabO/DBLE(nIrrep*LmbdT) - End If -* -* -*--------------Desymmetrize the matrix with which we will -* contracte the trace. -* - Call DesymD(iSmLbl,iAng,jAng,iCmp,jCmp, - & iShell,jShell,iShll,jShll, - & iAO,jAO,DAO,iPrim,jPrim, - & DSOpr,nSO,nOp,FactNd) -* -*--------------Project the spherical harmonic space onto the -* cartesian space. -* - kk = nElem(iAng)*nElem(jAng) - If (Shells(iShll)%Transf.or.Shells(jShll)%Transf) Then -* -*-----------------ij,AB --> AB,ij - Call DGeTmO(DAO,iPrim*jPrim,iPrim*jPrim, - & iCmp*jCmp,Scrt1,iCmp*jCmp) -*-----------------AB,ij --> ij,ab - Call SphCar(Scrt1,iCmp*jCmp,iPrim*jPrim, - & Scrt2,nScr2, - & RSph(ipSph(iAng)),iAng, - & Shells(iShll)%Transf, - & Shells(iShll)%Prjct, - & RSph(ipSph(jAng)),jAng, - & Shells(jShll)%Transf, - & Shells(jShll)%Prjct, - & DAO,kk) - End If -* -*--------------Compute kappa and P. -* - Call Setup1(Shells(iShll)%Exp,iPrim, - & Shells(jShll)%Exp,jPrim, - & A,RB,Kappa,PCoor,ZI) -* -* - Call Icopy(18*nirrep,[0],0,IndGrd,1) - kk=0 - Do jIrrep=0,nirrep-1 - Do Jcar=1,3 - iirrep=irrfnc(2**(jcar-1)) - If (iirrep.eq.jirrep) Then - jj=0 - Do i=0,jirrep-1 - jj=ldisp(i)+jj - End do - nDisp = IndDsp(mdci,jIrrep)-jj - Do iCar=1,3 - iComp = 2**(iCar-1) - If ( TF(mdci,jIrrep,iComp)) Then - ndisp=ndisp+1 - IndGrd(1,icar,jcar,jIrrep) = kk+nDisp - End If - end do - kk=kk+ldisp(jirrep) - End If - End Do - End Do -* - kk=0 - Do jIrrep=0,nirrep-1 - Do Jcar=1,3 - iirrep=irrfnc(2**(jcar-1)) - If (iirrep.eq.jirrep) then - jj=0 - Do i=0,jirrep-1 - jj=ldisp(i)+jj - End do - nDisp = IndDsp(mdcj,jIrrep)-jj - Do iCar=1,3 - iComp = 2**(iCar-1) - If ( TF(mdcj,jIrrep,iComp)) Then - ndisp=ndisp+1 - IndGrd(2,icar,jcar,jIrrep) = kk+nDisp - End If - end do - kk=kk+ldisp(jirrep) - End If - End Do - End Do - -* -*--------------Compute gradients of the primitive integrals and -* trace the result. -* - - - Call Kernel(Shells(iShll)%Exp,iPrim, - & Shells(jShll)%Exp,jPrim, - & Zeta,ZI, - & Kappa,Pcoor, - & iPrim*jPrim, - & iAng,jAng,A,RB,nOrder,Kern, - & MemKer,Ccoor, - & nOrdOp,Hess, - & indgrd,DAO, - & mdci,mdcj,nOp, - & iStabM,nStabM) -* - 140 Continue -* - Call mma_deallocate(DSOpr) - 131 Continue - Call mma_deallocate(DAO) - Call mma_deallocate(Scrt2) - Call mma_deallocate(Scrt1) - Call mma_deallocate(Kern) -* -C End Do -C End Do - End Do -* - Call Free_iSD() -* - Call mma_deallocate(PCoor) - Call mma_deallocate(Kappa) - Call mma_deallocate(ZI) - Call mma_deallocate(Zeta) -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/dot1el2.F90 openmolcas-22.10/src/mckinley/dot1el2.F90 --- openmolcas-22.02/src/mckinley/dot1el2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/dot1el2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,327 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990,1991, Roland Lindh * +! 1990, IBM * +! 1994, Anders Bernhardsson * +!*********************************************************************** + +subroutine Dot1El2(Kernel,KrnlMm,Hess,nGrad,DiffOp,CCoor,FD,nordop) +!*********************************************************************** +! * +! Object: to compute gradients of the one electron integrals. * +! The memory at this point is assumed to be large enough to do * +! the computation in core. * +! The data is structured with respect to four indices, two (my * +! ny or i j) refer to primitives or basis functions and two (a * +! b) refer to the components of the cartesian or spherical * +! harmonic gaussians. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! January '90 * +! Modified for Hermite-Gauss quadrature November '90 * +! Modified for Rys quadrature November '90 * +! Modified for multipole moments November '90 * +! * +! Modified for general kernel routines January '91 * +! Modified for nonsymmetrical operators February '91 * +! Modified for gradients October '91 * +! Modified for Hessians by AB Dec '94 * +!*********************************************************************** + +use mck_interface, only: mck_mem, oneeldot_mck_kernel +use Index_Functions, only: nTri_Elem, nTri_Elem1 +use Real_Spherical, only: ipSph, RSph +use iSD_data, only: iSD +use Basis_Info, only: dbsc, MolWgh, Shells +use Center_Info, only: dc +use Symmetry_Info, only: iOper, nIrrep +use Sizes_of_Seward, only: S +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +procedure(oneeldot_mck_kernel) :: Kernel +procedure(mck_mem) :: KrnlMm +integer(kind=iwp), intent(in) :: nGrad, nordop +real(kind=wp), intent(out) :: Hess(nGrad) +logical(kind=iwp), intent(in) :: DiffOp +real(kind=wp), intent(in) :: CCoor(3), FD(*) +#include "Molcas.fh" +#include "disp.fh" +integer(kind=iwp) :: i, iAng, iAO, iBas, iCar, iCmp, iCnt, iCnttp, iCoM(0:7,0:7), iComp, iDCRR(0:7), iDCRT(0:7), ielem, iirrep, & + ijS, IndGrd(2,3,3,0:7), iPrim, iS, iShell, iShll, iSmLbl, iStabM(0:7), iStabO(0:7), iTmp(0:7), iuv, j, jAng, & + jAO, jBas, jCar, jCmp, jCnt, jCnttp, jIrrep, jj, jPrim, jS, jShell, jShll, kk, lDCRR, lloper, LmbdR, LmbdT, & + mdci, mdcj, MemKer, MemKrn, nDAO, nDCRR, nDCRT, nDisp, nMax, nOp(2), nOrder, nScrt1, nScrt2, nSkal, nSO, & + nStabM, nStabO, nTasks +real(kind=wp) :: A(3), B(3), FactNd, RB(3) +logical(kind=iwp) :: AeqB +real(kind=wp), allocatable :: DAO(:), DSO(:), DSOpr(:), Kappa(:), Kern(:), PCoor(:,:), Scrt1(:), Scrt2(:), Zeta(:), ZI(:) +integer(kind=iwp), external :: irrfnc, MemSO1, n2Tri, NrOpr +logical(kind=iwp), external :: EQ, TF + +Hess(:) = Zero + +! Auxiliary memory allocation. + +call mma_allocate(Zeta,S%m2Max,Label='Zeta') +call mma_allocate(ZI,S%m2Max,Label='ZI') +call mma_allocate(Kappa,S%m2Max,Label='Kappa') +call mma_allocate(PCoor,S%m2Max,3,Label='PCoor') +! * +!*********************************************************************** +! * +call Set_Basis_Mode('Valence') +call Nr_Shells(nSkal) +call Setup_iSD() +! * +!*********************************************************************** +! * +! Double loop over shells. + +nTasks = nTri_Elem(nSkal) +iS = 0 +jS = 0 +do ijS=1,nTasks + jS = jS+1 + if (jS > iS) then + iS = jS + jS = 1 + end if + !do iS=1,nSkal + iShll = iSD(0,iS) + iAng = iSD(1,iS) + iCmp = iSD(2,iS) + iBas = iSD(3,iS) + iPrim = iSD(5,iS) + iAO = iSD(7,iS) + mdci = iSD(10,iS) + iShell = iSD(11,iS) + iCnttp = iSD(13,iS) + iCnt = iSD(14,iS) + A(1:3) = dbsc(iCnttp)%Coor(1:3,iCnt) + + ! do jS=1,iS + jShll = iSD(0,jS) + jAng = iSD(1,jS) + jCmp = iSD(2,jS) + jBas = iSD(3,jS) + jPrim = iSD(5,jS) + jAO = iSD(7,jS) + mdcj = iSD(10,jS) + jShell = iSD(11,jS) + jCnttp = iSD(13,jS) + jCnt = iSD(14,jS) + B(1:3) = dbsc(jCnttp)%Coor(1:3,jCnt) + + ! Call kernel routine to get memory requirement. + + call KrnlMm(nOrder,MemKer,iAng,jAng,nOrdOp) + MemKrn = MemKer*S%m2Max + call mma_allocate(Kern,MemKrn,Label='Kern') + + ! Allocate memory for the final integrals, all in the primitive basis. + + ! Scratch area for contraction step + + nScrt1 = S%MaxPrm(iAng)*S%MaxPrm(jAng)*nTri_Elem1(iAng)*nTri_Elem1(jAng) + call mma_allocate(Scrt1,nScrt1,Label='Scrt1') + + ! Scratch area for the transformation to spherical gaussians + + nScrt2 = S%MaxPrm(iAng)*S%MaxPrm(jAng)*nTri_Elem1(iAng)*nTri_Elem1(jAng) + call mma_allocate(Scrt2,nScrt2,Label='Scrt2') + + nDAO = iPrim*jPrim*nTri_Elem1(iAng)*nTri_Elem1(jAng) + call mma_allocate(DAO,nDAO,Label='DAO') + + ! At this point we can compute Zeta. + + call ZXia(Zeta,ZI,iPrim,jPrim,Shells(iShll)%Exp,Shells(jShll)%Exp) + + AeqB = iS == jS + + ! Find the DCR for A and B + + call DCR(LmbdR,dc(mdci)%iStab,dc(mdci)%nStab,dc(mdcj)%iStab,dc(mdcj)%nStab,iDCRR,nDCRR) + if (DiffOp .or. (nDCRR /= 1) .or. (.not. EQ(A,B))) then + + ! Find the stabilizer for A and B + + call Inter(dc(mdci)%iStab,dc(mdci)%nStab,dc(mdcj)%iStab,dc(mdcj)%nStab,iStabM,nStabM) + + ! Generate all possible (left) CoSet + ! To the stabilizer of A and B + + do j=0,nStabM-1 + iCoM(0:nIrrep-1,j) = ieor(iOper(0:nIrrep-1),iStabM(j)) + end do + ! Order the Coset so we will have the unique ones first + nMax = 1 + loop1: do j=1,nIrrep-1 + ! Check uniqueness + do i=0,nMax-1 + do ielem=0,nStabM-1 + if (iCoM(i,1) == iCoM(j,ielem)) cycle loop1 + end do + end do + ! Move unique CoSet + nMax = nMax+1 + iTmp(0:nStabM-1) = iCoM(nMax-1,0:nStabM-1) + iCoM(nMax-1,0:nStabM-1) = iCoM(j,0:nStabM-1) + iCoM(j,0:nStabM-1) = iTmp(0:nStabM-1) + if (nMax == nIrrep/nStabM) exit loop1 + end do loop1 + + ! Allocate memory for the elements of the Fock or 1st order + ! denisty matrix which are associated with the current shell pair. + + iSmLbl = 1 + nSO = MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO) + if (nSO /= 0) then + call mma_allocate(DSOpr,nSO*iPrim*jPrim,Label='DSOpr') + DSOpr(:) = Zero + call mma_allocate(DSO,nSO*iPrim*jPrim,Label='DSO') + DSO(:) = Zero + + ! Gather the elements from 1st order density / Fock matrix. + + call SOGthr(DSO,iBas,jBas,nSO,FD,n2Tri(iSmLbl),iSmLbl,iCmp,jCmp,iShell,jShell,AeqB,iAO,jAO) + + ! Project the Fock/1st order density matrix in AO + ! basis on to the primitive basis. + + ! Transform IJ,AB to J,ABi + call DGEMM_('T','T',jBas*nSO,iPrim,iBas,One,DSO,iBas,Shells(iShll)%pCff,iPrim,Zero,DSOpr,jBas*nSO) + ! Transform J,ABi to AB,ij + call DGEMM_('T','T',nSO*iPrim,jPrim,jBas,One,DSOpr,jBas,Shells(jShll)%pCff,jPrim,Zero,DSO,nSO*iPrim) + ! Transpose to ij,AB + call DGeTmO(DSO,nSO,nSO,iPrim*jPrim,DSOpr,iPrim*jPrim) + call mma_deallocate(DSO) + + ! Loops over symmetry operations. + + nOp(1) = NrOpr(0) + if (jBas < -999999) write(u6,*) 'gcc overoptimization',nDCRR + do lDCRR=0,nDCRR-1 + call OA(iDCRR(lDCRR),B,RB) + nOp(2) = NrOpr(iDCRR(lDCRR)) + if (EQ(A,RB) .and. (.not. DiffOp)) cycle + + lloper = 1 + call SOS(iStabO,nStabO,llOper) + call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) + + ! Compute normalization factor due the DCR symmetrization + ! of the two basis functions and the operator. + + iuv = dc(mdci)%nStab*dc(mdcj)%nStab + FactNd = real(iuv*nStabO,kind=wp)/real(nIrrep**2*LmbdT,kind=wp) + if (MolWgh == 1) then + FactNd = FactNd*real(nIrrep,kind=wp)**2/real(iuv,kind=wp) + else if (MolWgh == 2) then + FactNd = sqrt(real(iuv,kind=wp))*nStabO/real(nIrrep*LmbdT,kind=wp) + end if + + ! Desymmetrize the matrix with which we will contract the trace. + + call DesymD(iSmLbl,iAng,jAng,iCmp,jCmp,iShell,jShell,iShll,jShll,iAO,jAO,DAO,iPrim,jPrim,DSOpr,nSO,nOp,FactNd) + + ! Project the spherical harmonic space onto the cartesian space. + + kk = nTri_Elem1(iAng)*nTri_Elem1(jAng) + if (Shells(iShll)%Transf .or. Shells(jShll)%Transf) then + + ! ij,AB --> AB,ij + call DGeTmO(DAO,iPrim*jPrim,iPrim*jPrim,iCmp*jCmp,Scrt1,iCmp*jCmp) + ! AB,ij --> ij,ab + call SphCar(Scrt1,iCmp*jCmp,iPrim*jPrim,Scrt2,nScrt2,RSph(ipSph(iAng)),iAng,Shells(iShll)%Transf,Shells(iShll)%Prjct, & + RSph(ipSph(jAng)),jAng,Shells(jShll)%Transf,Shells(jShll)%Prjct,DAO,kk) + end if + + ! Compute kappa and P. + + call Setup1(Shells(iShll)%Exp,iPrim,Shells(jShll)%Exp,jPrim,A,RB,Kappa,PCoor,ZI) + + IndGrd(:,:,:,0:nirrep-1) = 0 + kk = 0 + do jIrrep=0,nirrep-1 + do jCar=1,3 + iirrep = irrfnc(2**(jcar-1)) + if (iirrep == jirrep) then + jj = 0 + do i=0,jirrep-1 + jj = ldisp(i)+jj + end do + nDisp = IndDsp(mdci,jIrrep)-jj + do iCar=1,3 + iComp = 2**(iCar-1) + if (TF(mdci,jIrrep,iComp)) then + ndisp = ndisp+1 + IndGrd(1,icar,jcar,jIrrep) = kk+nDisp + end if + end do + kk = kk+ldisp(jirrep) + end if + end do + end do + + kk = 0 + do jIrrep=0,nirrep-1 + do jCar=1,3 + iirrep = irrfnc(2**(jcar-1)) + if (iirrep == jirrep) then + jj = 0 + do i=0,jirrep-1 + jj = ldisp(i)+jj + end do + nDisp = IndDsp(mdcj,jIrrep)-jj + do iCar=1,3 + iComp = 2**(iCar-1) + if (TF(mdcj,jIrrep,iComp)) then + ndisp = ndisp+1 + IndGrd(2,icar,jcar,jIrrep) = kk+nDisp + end if + end do + kk = kk+ldisp(jirrep) + end if + end do + end do + + ! Compute gradients of the primitive integrals and trace the result. + + call Kernel(Shells(iShll)%Exp,iPrim,Shells(jShll)%Exp,jPrim,Zeta,Kappa,Pcoor,iPrim*jPrim,iAng,jAng,A,RB,nOrder,Kern, & + MemKer,Ccoor,nOrdOp,Hess,indgrd,DAO,mdci,mdcj,nOp) + + end do + + call mma_deallocate(DSOpr) + end if + end if + call mma_deallocate(DAO) + call mma_deallocate(Scrt2) + call mma_deallocate(Scrt1) + call mma_deallocate(Kern) + + ! end do + !end do +end do + +call Free_iSD() + +call mma_deallocate(PCoor) +call mma_deallocate(Kappa) +call mma_deallocate(ZI) +call mma_deallocate(Zeta) + +return + +end subroutine Dot1El2 diff -Nru openmolcas-22.02/src/mckinley/dot1el.f openmolcas-22.10/src/mckinley/dot1el.f --- openmolcas-22.02/src/mckinley/dot1el.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/dot1el.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,505 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990,1991, Roland Lindh * -* 1990, IBM * -* 1994, Anders Bernhardsson * -************************************************************************ - SubRoutine Dot1El(Kernel,KrnlMm,Hess,nHess,DiffOp,CCoor, - & FD,nFD,lOper,nComp,Label) -************************************************************************ -* * -* Object: to compute gradients of the one electron integrals. * -* The memory at this point is assumed to be large enough to do * -* the computation in core. * -* The data is structured with respect to four indices, two (my * -* ny or i j) refer to primitives or basis functions and two (a * -* b) refer to the components of the cartesian or spherical * -* harmonic gaussians. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* January '90 * -* Anders Bernhardsson Dec '94 * -* * -* Modified for general kernel routines January '91 * -* Modified for nonsymmetrical operators February '91 * -* Modified for gradients October '91 * -* Modified for Hermite-Gauss quadrature November '90 * -* Modified for Rys quadrature November '90 * -* Modified for multipole moments November '90 * -************************************************************************ - use Real_Spherical - use iSD_data - use Basis_Info - use Center_Info - use Symmetry_Info, only: nIrrep, iOper - use Sizes_of_Seward, only: S - Implicit Real*8 (A-H,O-Z) -* External Kernel, KrnlMm - External KrnlMm -#include "Molcas.fh" -#include "real.fh" -#include "stdalloc.fh" -#include "disp.fh" -#include "disp2.fh" -#include "nsd.fh" -#include "setup.fh" - Real*8 A(3), B(3), Ccoor(3,nComp), FD(nFD), - & RB(3), Hess(nHess) - Character Label*80 -c Character ChOper(0:7)*3 - Integer iDCRR(0:7), iDCRT(0:7), iStabM(0:7),iCoM(0:7,0:7), - & IndHss(0:1,0:2,0:1,0:2,0:7), nOp(2), - & iStabO(0:7),lOper(nComp),IndGrd(0:2,0:1,0:7) - Logical AeqB, EQ, DiffOp, IfHss(0:1,0:2,0:1,0:2), - & Chck,ifgrd(0:2,0:1) - Real*8, Allocatable:: Zeta(:), ZI(:), Kappa(:), PCoor(:,:), - & Kern(:), Fnl(:), Scrt1(:), Scrt2(:), - & DAO(:), DSOpr(:), DSO(:) - Logical, External :: TF, TstFnc -* * -************************************************************************ -* * - Interface - Subroutine Kernel( -#define _CALLING_ -#include "hss_interface.fh" - & ) -#include "hss_interface.fh" - End Subroutine Kernel - End Interface -* * -************************************************************************ -* * -* -* Statement functions -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - itri(i1,i2)=MAX(i1,i2)*(MAX(i1,i2)-1)/2+MIN(i1,i2) -* - call dcopy_(nHess,[Zero],0,Hess,1) -* -* Auxiliary memory allocation. -* - Call mma_allocate(Zeta,S%m2Max,Label='Zeta') - Call mma_allocate(ZI,S%m2Max,Label='ZI') - Call mma_allocate(Kappa,S%m2Max,Label='Kappa') - Call mma_allocate(PCoor,S%m2Max,3,Label='PCoor') -* * -************************************************************************ -* * - Call Set_Basis_Mode('Valence') - Call Nr_Shells(nSkal) - Call Setup_iSD() -* * -************************************************************************ -* * -* Double loop over shells. -* - nTasks = nSkal*(nSkal+1)/2 - iS = 0 - jS = 0 - Do ijS = 1, nTasks - jS = jS + 1 - If (jS.gt.iS) Then - iS = jS - jS = 1 - End If -* -C Do iS = 1, nSkal - iShll = iSD( 0,iS) - iAng = iSD( 1,iS) - iCmp = iSD( 2,iS) - iBas = iSD( 3,iS) - iPrim = iSD( 5,iS) - iAO = iSD( 7,iS) - mdci = iSD(10,iS) - iShell = iSD(11,iS) - iCnttp = iSD(13,iS) - iCnt = iSD(14,iS) - A(1:3)=dbsc(iCnttp)%Coor(1:3,iCnt) -* -C Do jS = 1, iS - jShll = iSD( 0,jS) - jAng = iSD( 1,jS) - jCmp = iSD( 2,jS) - jBas = iSD( 3,jS) - jPrim = iSD( 5,jS) - jAO = iSD( 7,jS) - mdcj = iSD(10,jS) - jShell = iSD(11,jS) - jCnttp = iSD(13,jS) - jCnt = iSD(14,jS) - B(1:3)=dbsc(jCnttp)%Coor(1:3,jCnt) -C write(6,*) -C & 'iShll,iAng,iCmp,iBas,iPrim,iAO,ixyz,mdci,iShell' -C write(6,*) (iSD(i,iS),i=0,11) -C write(6,*) -C & 'jShll,jAng,jCmp,jBas,jPrim,jAO,jxyz,mdcj,jShell' -C write(6,*) (iSD(i,jS),i=0,11) -* -* Call kernel routine to get memory requirement. -* - nOrdOp = 0 ! not used in this implementation - Call KrnlMm(nOrder,MemKer,iAng,jAng,nOrdOp) - MemKrn=MemKer*S%m2Max - Call mma_allocate(Kern,MemKrn,Label='Kern') -* -* Allocate memory for the final integrals, all in the -* primitive basis. -* - lFinal = 21 * S%MaxPrm(iAng) * S%MaxPrm(jAng) * - & nElem(iAng)*nElem(jAng) - Call mma_allocate(Fnl,lFinal,Label='Fnl') -* -* Scratch area for contraction step -* - nScrt1 = S%MaxPrm(iAng)*S%MaxPrm(jAng) * - & nElem(iAng)*nElem(jAng) - Call mma_allocate(Scrt1,nScrt1,Label='Scrt1') -* -* Scratch area for the transformation to spherical gaussians -* - nScrt2=S%MaxPrm(iAng)*S%MaxPrm(jAng)*nElem(iAng)*nElem(jAng) - Call mma_allocate(Scrt2,nScrt2,Label='Scrt2') -* - nDAO=iPrim*jPrim*nElem(iAng)*nElem(jAng) - Call mma_allocate(DAO,nDAO,Label='DAO') -* -* At this point we can compute Zeta. -* - Call ZXia(Zeta,ZI, - & iPrim,jPrim,Shells(iShll)%Exp, - & Shells(jShll)%Exp) -* - AeqB = iS.eq.jS - -* -* Find the DCR for A and B -* - Call DCR(LmbdR,dc(mdci)%iStab,dc(mdci)%nStab, - & dc(mdcj)%iStab,dc(mdcj)%nStab,iDCRR,nDCRR) - If (.Not.DiffOp .and. nDCRR.eq.1 .and. EQ(A,B)) Go To 131 -c If (iPrint.ge.49) Write (6,'(10A)') -c & ' {R}=(',(ChOper(iDCRR(i)),i=0,nDCRR-1),')' -* -*-----------Find the stabilizer for A and B -* - Call Inter(dc(mdci)%iStab,dc(mdci)%nStab, - & dc(mdcj)%iStab,dc(mdcj)%nStab, - & iStabM,nStabM) -* -* Generate all possible (left) CoSet -* To the stabil. of A and B -* - Do 433 i = 0, nIrrep-1 - Do 434 j = 0, nStabM-1 - iCoM(i,j) = iEor(iOper(i),iStabM(j)) - 434 Continue - 433 Continue -* Order the Coset so we will have the unique ones first - nMax = 1 - Do 435 j = 1, nIrrep-1 -* Check uniqueness - Do 436 i = 0, nMax - 1 - Do 437 ielem = 0, nStabM-1 - If (iCoM(i,1).eq.iCoM(j,ielem)) - & Go To 435 - 437 Continue - 436 Continue -* Move unique CoSet - nMax = nMax + 1 - Do 438 ielem = 0, nStabM-1 - iTmp = iCoM(nMax-1,ielem) - iCoM(nMax-1,ielem) = iCoM(j,ielem) - iCoM(j,ielem) = iTmp - 438 Continue - If (nMax.eq.nIrrep/nStabM) Go To 439 - 435 Continue - 439 Continue - Call LCopy(36,[.false.],0,IfHss,1) - Do 400 iAtom=0,1 - Do 410 iCar=0,2 - Do 420 jAtom=0,iAtom - if (iAtom.eq.jAtom) Then - iStop=iCar - Else - iStop=2 - End If - Do 430 jCar=0,iStop - iComp1=2**iCar - iComp2=2**jCar - iComp=iEOr(iComp1,iComp2) - Chck=TstFnc(iCoM,0,iComp,nStabM) - If (Chck) - & IfHss(iAtom,iCar,jAtom,jCar)=.true. - 430 Continue - 420 Continue - 410 Continue - 400 Continue - Call ICopy(nirrep*36,[0],0,Indhss(0,0,0,0,0),1) - Call ICopy(nirrep*6,[0],0,indgrd,1) -* -* Determine which displacement in all IR''s, each center is -* associated with. -* - nnIrrep=nIrrep - If (sIrrep) nnIrrep=1 - - Do 200 iIrrep=0,nnIrrep-1 - nDisp1 = IndDsp(mdci,iIrrep) - nDisp2 = IndDsp(mdcj,iIrrep) - Do 201 iCar = 0,2 - iComp = 2**iCar - If ( TF(mdci,iIrrep,iComp)) Then - nDisp1 = nDisp1 + 1 - IndGrd(iCar,0,iIrrep) = nDisp1 - if (iIrrep.eq.0) IfGrd(iCar,0) = .True. - Else - if (iIrrep.eq.0) IfGrd(iCar,0) = .False. - IndGrd(iCar,0,iIrrep)=0 - End If - iComp = 2**iCar - If ( TF(mdcj,iIrrep,iComp)) Then - nDisp2 = nDisp2 + 1 - IndGrd(iCar,1,iIrrep) = nDisp2 - if (iIrrep.eq.0) IfGrd(iCar,1) = .True. - Else - IndGrd(iCar,1,iIrrep)=0 - if (iIrrep.eq.0) IfGrd(iCar,1) = .True. - End If - 201 Continue - 200 Continue -* -* Determine index for each 2'nd derivative -* -* - Do iIrrep=0,nIrrep-1 - Do iAtom=0,1 - Do iCar=0,2 - Do jAtom=0,iAtom - if (iAtom.eq.jAtom) Then - istop=iCar - Else - iStop=2 - End If - Do jCar=0,istop - If ((IndGrd(iCar,iAtom,iIrrep).gt.0).and. - & (IndGrd(jCar,jAtom,iIrrep).gt.0)) - & Then - IndHss(iAtom,iCar,jAtom,jCar,iIrrep)= - & itri(IndGrd(iCar,iAtom,iIrrep), - & IndGrd(jCar,jAtom,iIrrep)) - Else - IndHss(iAtom,iCar,jAtom,jCar,iIrrep)=0 - End If - End Do - End Do - End Do - End Do - End Do - If (.not.DiffOp) Then - iAtom=1 - Do 440 iCar=0,2 - Do 441 jAtom=0,1 - If (iAtom.eq.jAtom) Then - iStop=iCar - Else - iStop=2 - End If - Do 460 jCar=0,iStop - If (IfHss(0,iCar,0,jCar).or. - & IfHss(0,jCar,0,iCar)) Then - IfHss(iAtom,iCar,jAtom,jCar)=.false. - Do 445 iIrrep=0,nIrrep-1 - IndHss(iAtom,iCar,jAtom,jCar,iIrrep)= - & -IndHss(iAtom,iCar,jAtom,jCar,iIrrep) - 445 Continue - End If - 460 Continue - 441 Continue - 440 Continue -* - End If -* Allocate memory for the elements of the Fock or 1st order -* denisty matrix which are associated with the current shell -* pair. -* - iSmLbl = 1 - nSO = MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO) - If (nSO.eq.0) Go To 131 - Call mma_allocate(DSOpr,nSO*iPrim*jPrim,Label='DSOpr') - DSOpr(:)=Zero - Call mma_allocate(DSO,nSO*iPrim*jPrim,Label='DSO') - DSO(:)=Zero -* -* Gather the elements from 1st order density / Fock matrix. -* - Call SOGthr(DSO,iBas,jBas,nSO,FD, - & n2Tri(iSmLbl),iSmLbl, - & iCmp,jCmp,iShell,jShell, - & AeqB,iAO,jAO) -* -* Project the Fock/1st order density matrix in AO -* basis on to the primitive basis. -* -c If (iPrint.ge.99) Then -c Call RecPrt(' Left side contraction',' ', -c & Shells(iShll)%pCff,iPrim,iBas) -c Call RecPrt(' Right side contraction',' ', -c & Shells(jShll)%pCff,jPrim,jBas) -c End If -* -* Transform IJ,AB to J,ABi - Call DGEMM_('T','T', - & jBas*nSO,iPrim,iBas, - & One,DSO,iBas, - & Shells(iShll)%pCff,iPrim, - & Zero,DSOpr,jBas*nSO) -* Transform J,ABi to AB,ij - Call DGEMM_('T','T', - & nSO*iPrim,jPrim,jBas, - & One,DSOpr,jBas, - & Shells(jShll)%pCff,jPrim, - & Zero,DSO,nSO*iPrim) -* Transpose to ij,AB - Call DGeTmO(DSO,nSO,nSO,iPrim*jPrim,DSOpr, - & iPrim*jPrim) - Call mma_deallocate(DSO) -* -c If (iPrint.ge.99) Call -c & RecPrt(' Decontracted 1st order density/Fock matrix', -c & ' ',DSOpr,iPrim*jPrim,nSO) -* -* Loops over symmetry operations. -* - nOp(1) = NrOpr(0) - if(jBas.lt.-999999) write(6,*) 'gcc overoptimization',nDCRR - Do 140 lDCRR = 0, nDCRR-1 - Call OA(iDCRR(lDCRR),B,RB) - nOp(2) = NrOpr(iDCRR(lDCRR)) - If (EQ(A,RB).and. (.Not.DiffOp)) Go To 140 -* -c If (iPrint.ge.49) Then -c Write (6,'(10A)') ' {M}=(',(ChOper(iStabM(i)), -c & i=0,nStabM-1),')' -c End If -* - llOper = lOper(1) - Do 5000 iComp = 2, nComp - llOper = iOr(llOper,lOper(iComp)) - 5000 Continue - Call SOS(iStabO,nStabO,llOper) - Call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) -* -*--------------Compute normalization factor due the DCR symmetrization -* of the two basis functions and the operator. -* - iuv = dc(mdci)%nStab*dc(mdcj)%nStab - FactNd = DBLE(iuv*nStabO) / DBLE(nIrrep**2 * LmbdT) - If (MolWgh.eq.1) Then - FactNd = FactNd * DBLE(nIrrep)**2 / DBLE(iuv) - Else If (MolWgh.eq.2) Then - FactNd = sqrt(DBLE(iuv))*DBLE(nStabO) - & / DBLE(nIrrep*LmbdT) - End If -* -c If (iPrint.ge.49) Then -c Write (6,'(A,/,2(3F6.2,2X))') -c & ' *** Centers A, RB ***', -c & ( A(i),i=1,3), (RB(i),i=1,3) -c End If -* -*--------------Desymmetrize the matrix with which we will -* contracte the trace. -* - Call DesymD(iSmLbl,iAng,jAng,iCmp,jCmp, - & iShell,jShell,iShll,jShll, - & iAO,jAO,DAO,iPrim,jPrim, - & DSOpr,nSO,nOp,FactNd) -* -*--------------Project the spherical harmonic space onto the -* cartesian space. -* - kk = nElem(iAng)*nElem(jAng) - If (Shells(iShll)%Transf.or.Shells(jShll)%Transf) Then -* -*-----------------ij,AB --> AB,ij - Call DGeTmO(DAO,iPrim*jPrim,iPrim*jPrim, - & iCmp*jCmp,Scrt1,iCmp*jCmp) -*-----------------AB,ij --> ij,ab - Call SphCar(Scrt1,iCmp*jCmp,iPrim*jPrim, - & Scrt2,nScr2, - & RSph(ipSph(iAng)),iAng, - & Shells(iShll)%Transf, - & Shells(iShll)%Prjct, - & RSph(ipSph(jAng)),jAng, - & Shells(jShll)%Transf, - & Shells(jShll)%Prjct, - & DAO,kk) - End If -c If (iPrint.ge.99) Call RecPrt( -c & ' Decontracted FD in the cartesian space', -c & ' ',DAO,iPrim*jPrim,kk) -* -*--------------Compute kappa and P. -* - Call Setup1(Shells(iShll)%Exp,iPrim, - & Shells(jShll)%Exp,jPrim, - & A,RB,Kappa,PCoor,ZI) -* -*--------------Compute gradients of the primitive integrals and -* trace the result. -* -* -CBS write(6,*) 'Call the Kernel' -* - Call Kernel(Shells(iShll)%Exp,iPrim, - & Shells(jShll)%Exp,jPrim, - & Zeta,ZI, - & Kappa,Pcoor, - & Fnl,iPrim*jPrim, - & iAng,jAng,A,RB,nOrder,Kern, - & MemKer*iPrim*jPrim,Ccoor, - & nOrdOp,Hess,nHess, - & IfHss,IndHss,ifgrd,indgrd,DAO, - & mdci,mdcj,nOp,lOper,nComp, - & iStabM,nStabM,nIrrep) - -#ifdef _DEBUGPRINT_ - write(6,*) 'Hess after Kernel call in dot1el ' - Call HssPrt(Hess,nHess) -#endif -* - 140 Continue -* - Call mma_deallocate(DSOpr) - 131 Continue - Call mma_deallocate(DAO) - Call mma_deallocate(Scrt2) - Call mma_deallocate(Scrt1) - Call mma_deallocate(Fnl) - Call mma_deallocate(Kern) -* -C End Do -C End Do - End Do -* - Call Free_iSD() -* - Call mma_deallocate(PCoor) - Call mma_deallocate(Kappa) - Call mma_deallocate(ZI) - Call mma_deallocate(Zeta) -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_character(Label) - End diff -Nru openmolcas-22.02/src/mckinley/dot1el.F90 openmolcas-22.10/src/mckinley/dot1el.F90 --- openmolcas-22.02/src/mckinley/dot1el.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/dot1el.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,413 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990,1991, Roland Lindh * +! 1990, IBM * +! 1994, Anders Bernhardsson * +!*********************************************************************** + +subroutine Dot1El(Kernel,KrnlMm,Hess,nHess,DiffOp,CCoor,FD,nFD,lOper,nComp) +!*********************************************************************** +! * +! Object: to compute gradients of the one electron integrals. * +! The memory at this point is assumed to be large enough to do * +! the computation in core. * +! The data is structured with respect to four indices, two (my * +! ny or i j) refer to primitives or basis functions and two (a * +! b) refer to the components of the cartesian or spherical * +! harmonic gaussians. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! January '90 * +! Anders Bernhardsson Dec '94 * +! * +! Modified for general kernel routines January '91 * +! Modified for nonsymmetrical operators February '91 * +! Modified for gradients October '91 * +! Modified for Hermite-Gauss quadrature November '90 * +! Modified for Rys quadrature November '90 * +! Modified for multipole moments November '90 * +!*********************************************************************** + +use McKinley_global, only: sIrrep +use mck_interface, only: hss_kernel, mck_mem +use Index_Functions, only: iTri, nTri_Elem, nTri_Elem1 +use Real_Spherical, only: ipSph, RSph +use iSD_data, only: iSD +use Basis_Info, only: dbsc, MolWgh, Shells +use Center_Info, only: dc +use Symmetry_Info, only: iOper, nIrrep +use Sizes_of_Seward, only: S +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +procedure(hss_kernel) :: Kernel +procedure(mck_mem) :: KrnlMm +integer(kind=iwp), intent(in) :: nHess, nFD, nComp, lOper(nComp) +real(kind=wp), intent(out) :: Hess(nHess) +logical(kind=iwp), intent(in) :: DiffOp +real(kind=wp), intent(in) :: CCoor(3,nComp), FD(nFD) +#include "Molcas.fh" +#include "disp.fh" +integer(kind=iwp) :: i, iAng, iAO, iAtom, iBas, iCar, iCmp, iCnt, iCnttp, iCoM(0:7,0:7), iComp, iComp1, iComp2, iDCRR(0:7), & + iDCRT(0:7), ielem, iIrrep, ijS, IndGrd(0:2,0:1,0:7), IndHss(0:1,0:2,0:1,0:2,0:7), iPrim, iS, iShell, iShll, & + iSmLbl, iStabM(0:7), iStabO(0:7), iStop, iTmp(0:7), iuv, j, jAng, jAO, jAtom, jBas, jCar, jCmp, jCnt, jCnttp, & + jPrim, jS, jShell, jShll, kk, lDCRR, lFinal, llOper, LmbdR, LmbdT, mdci, mdcj, MemKer, MemKrn, nDAO, nDCRR, & + nDCRT, nDisp1, nDisp2, nMax, nnIrrep, nOp(2), nOrder, nOrdOp, nScrt1, nScrt2, nSkal, nSO, nStabM, nStabO, & + nTasks +real(kind=wp) :: A(3), B(3), FactNd, RB(3) +logical(kind=iwp) :: AeqB, Chck, ifgrd(0:2,0:1), IfHss(0:1,0:2,0:1,0:2) +!character(len=3) :: ChOper(0:7) +real(kind=wp), allocatable :: DAO(:), DSO(:), DSOpr(:), Fnl(:), Kappa(:), Kern(:), PCoor(:,:), Scrt1(:), Scrt2(:), Zeta(:), ZI(:) +integer(kind=iwp), external :: MemSO1, n2Tri, NrOpr +logical(kind=iwp), external :: EQ, TF, TstFnc + +Hess(:) = Zero + +! Auxiliary memory allocation. + +call mma_allocate(Zeta,S%m2Max,Label='Zeta') +call mma_allocate(ZI,S%m2Max,Label='ZI') +call mma_allocate(Kappa,S%m2Max,Label='Kappa') +call mma_allocate(PCoor,S%m2Max,3,Label='PCoor') +! * +!*********************************************************************** +! * +call Set_Basis_Mode('Valence') +call Nr_Shells(nSkal) +call Setup_iSD() +! * +!*********************************************************************** +! * +! Double loop over shells. + +nTasks = nTri_Elem(nSkal) +iS = 0 +jS = 0 +do ijS=1,nTasks + jS = jS+1 + if (jS > iS) then + iS = jS + jS = 1 + end if + + !do iS=1,nSkal + iShll = iSD(0,iS) + iAng = iSD(1,iS) + iCmp = iSD(2,iS) + iBas = iSD(3,iS) + iPrim = iSD(5,iS) + iAO = iSD(7,iS) + mdci = iSD(10,iS) + iShell = iSD(11,iS) + iCnttp = iSD(13,iS) + iCnt = iSD(14,iS) + A(1:3) = dbsc(iCnttp)%Coor(1:3,iCnt) + + ! do jS=1,iS + jShll = iSD(0,jS) + jAng = iSD(1,jS) + jCmp = iSD(2,jS) + jBas = iSD(3,jS) + jPrim = iSD(5,jS) + jAO = iSD(7,jS) + mdcj = iSD(10,jS) + jShell = iSD(11,jS) + jCnttp = iSD(13,jS) + jCnt = iSD(14,jS) + B(1:3) = dbsc(jCnttp)%Coor(1:3,jCnt) + !write(u6,*) 'iShll,iAng,iCmp,iBas,iPrim,iAO,ixyz,mdci,iShell' + !write(u6,*) (iSD(i,iS),i=0,11) + !write(u6,*) 'jShll,jAng,jCmp,jBas,jPrim,jAO,jxyz,mdcj,jShell' + !write(u6,*) (iSD(i,jS),i=0,11) + + ! Call kernel routine to get memory requirement. + + nOrdOp = 0 ! not used in this implementation + call KrnlMm(nOrder,MemKer,iAng,jAng,nOrdOp) + MemKrn = MemKer*S%m2Max + call mma_allocate(Kern,MemKrn,Label='Kern') + + ! Allocate memory for the final integrals, all in the primitive basis. + + lFinal = 21*S%MaxPrm(iAng)*S%MaxPrm(jAng)*nTri_Elem1(iAng)*nTri_Elem1(jAng) + call mma_allocate(Fnl,lFinal,Label='Fnl') + + ! Scratch area for contraction step + + nScrt1 = S%MaxPrm(iAng)*S%MaxPrm(jAng)*nTri_Elem1(iAng)*nTri_Elem1(jAng) + call mma_allocate(Scrt1,nScrt1,Label='Scrt1') + + ! Scratch area for the transformation to spherical gaussians + + nScrt2 = S%MaxPrm(iAng)*S%MaxPrm(jAng)*nTri_Elem1(iAng)*nTri_Elem1(jAng) + call mma_allocate(Scrt2,nScrt2,Label='Scrt2') + + nDAO = iPrim*jPrim*nTri_Elem1(iAng)*nTri_Elem1(jAng) + call mma_allocate(DAO,nDAO,Label='DAO') + + ! At this point we can compute Zeta. + + call ZXia(Zeta,ZI,iPrim,jPrim,Shells(iShll)%Exp,Shells(jShll)%Exp) + + AeqB = iS == jS + + ! Find the DCR for A and B + + call DCR(LmbdR,dc(mdci)%iStab,dc(mdci)%nStab,dc(mdcj)%iStab,dc(mdcj)%nStab,iDCRR,nDCRR) + if (DiffOp .or. (nDCRR /= 1) .or. (.not. EQ(A,B))) then + !if (iPrint >= 49) write(u6,'(10A)') ' {R}=(',(ChOper(iDCRR(i)),i=0,nDCRR-1),')' + + ! Find the stabilizer for A and B + + call Inter(dc(mdci)%iStab,dc(mdci)%nStab,dc(mdcj)%iStab,dc(mdcj)%nStab,iStabM,nStabM) + + ! Generate all possible (left) CoSet + ! To the stabilizer of A and B + + do j=0,nStabM-1 + iCoM(0:nIrrep-1,j) = ieor(iOper(0:nIrrep-1),iStabM(j)) + end do + ! Order the Coset so we will have the unique ones first + nMax = 1 + loop1: do j=1,nIrrep-1 + ! Check uniqueness + do i=0,nMax-1 + do ielem=0,nStabM-1 + if (iCoM(i,1) == iCoM(j,ielem)) cycle loop1 + end do + end do + ! Move unique CoSet + nMax = nMax+1 + iTmp(0:nStabM-1) = iCoM(nMax-1,0:nStabM-1) + iCoM(nMax-1,0:nStabM-1) = iCoM(j,0:nStabM-1) + iCoM(j,0:nStabM-1) = iTmp(0:nStabM-1) + if (nMax == nIrrep/nStabM) exit loop1 + end do loop1 + IfHss(:,:,:,:) = .false. + do iAtom=0,1 + do iCar=0,2 + do jAtom=0,iAtom + if (iAtom == jAtom) then + iStop = iCar + else + iStop = 2 + end if + do jCar=0,iStop + iComp1 = 2**iCar + iComp2 = 2**jCar + iComp = ieor(iComp1,iComp2) + Chck = TstFnc(iCoM,0,iComp,nStabM) + if (Chck) IfHss(iAtom,iCar,jAtom,jCar) = .true. + end do + end do + end do + end do + IndHss(:,:,:,:,0:nirrep-1) = 0 + IndGrd(:,:,0:nirrep-1) = 0 + + ! Determine which displacement in all IR's, each center is associated with. + + nnIrrep = nIrrep + if (sIrrep) nnIrrep = 1 + + do iIrrep=0,nnIrrep-1 + nDisp1 = IndDsp(mdci,iIrrep) + nDisp2 = IndDsp(mdcj,iIrrep) + do iCar=0,2 + iComp = 2**iCar + if (TF(mdci,iIrrep,iComp)) then + nDisp1 = nDisp1+1 + IndGrd(iCar,0,iIrrep) = nDisp1 + if (iIrrep == 0) IfGrd(iCar,0) = .true. + else + if (iIrrep == 0) IfGrd(iCar,0) = .false. + IndGrd(iCar,0,iIrrep) = 0 + end if + iComp = 2**iCar + if (TF(mdcj,iIrrep,iComp)) then + nDisp2 = nDisp2+1 + IndGrd(iCar,1,iIrrep) = nDisp2 + if (iIrrep == 0) IfGrd(iCar,1) = .true. + else + IndGrd(iCar,1,iIrrep) = 0 + if (iIrrep == 0) IfGrd(iCar,1) = .true. + end if + end do + end do + + ! Determine index for each 2nd derivative + + do iIrrep=0,nIrrep-1 + do iAtom=0,1 + do iCar=0,2 + do jAtom=0,iAtom + if (iAtom == jAtom) then + istop = iCar + else + iStop = 2 + end if + do jCar=0,istop + if ((IndGrd(iCar,iAtom,iIrrep) > 0) .and. (IndGrd(jCar,jAtom,iIrrep) > 0)) then + IndHss(iAtom,iCar,jAtom,jCar,iIrrep) = itri(IndGrd(iCar,iAtom,iIrrep),IndGrd(jCar,jAtom,iIrrep)) + else + IndHss(iAtom,iCar,jAtom,jCar,iIrrep) = 0 + end if + end do + end do + end do + end do + end do + if (.not. DiffOp) then + iAtom = 1 + do iCar=0,2 + do jAtom=0,1 + if (iAtom == jAtom) then + iStop = iCar + else + iStop = 2 + end if + do jCar=0,iStop + if (IfHss(0,iCar,0,jCar) .or. IfHss(0,jCar,0,iCar)) then + IfHss(iAtom,iCar,jAtom,jCar) = .false. + IndHss(iAtom,iCar,jAtom,jCar,0:nIrrep-1) = -IndHss(iAtom,iCar,jAtom,jCar,0:nIrrep-1) + end if + end do + end do + end do + + end if + + ! Allocate memory for the elements of the Fock or 1st order + ! denisty matrix which are associated with the current shell pair. + + iSmLbl = 1 + nSO = MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO) + if (nSO /= 0) then + call mma_allocate(DSOpr,nSO*iPrim*jPrim,Label='DSOpr') + DSOpr(:) = Zero + call mma_allocate(DSO,nSO*iPrim*jPrim,Label='DSO') + DSO(:) = Zero + + ! Gather the elements from 1st order density / Fock matrix. + + call SOGthr(DSO,iBas,jBas,nSO,FD,n2Tri(iSmLbl),iSmLbl,iCmp,jCmp,iShell,jShell,AeqB,iAO,jAO) + + ! Project the Fock/1st order density matrix in AO + ! basis on to the primitive basis. + + !if (iPrint >= 99) then + ! call RecPrt(' Left side contraction',' ',Shells(iShll)%pCff,iPrim,iBas) + ! call RecPrt(' Right side contraction',' ',Shells(jShll)%pCff,jPrim,jBas) + !end if + + ! Transform IJ,AB to J,ABi + call DGEMM_('T','T',jBas*nSO,iPrim,iBas,One,DSO,iBas,Shells(iShll)%pCff,iPrim,Zero,DSOpr,jBas*nSO) + ! Transform J,ABi to AB,ij + call DGEMM_('T','T',nSO*iPrim,jPrim,jBas,One,DSOpr,jBas,Shells(jShll)%pCff,jPrim,Zero,DSO,nSO*iPrim) + ! Transpose to ij,AB + call DGeTmO(DSO,nSO,nSO,iPrim*jPrim,DSOpr,iPrim*jPrim) + call mma_deallocate(DSO) + + !if (iPrint >= 99) call RecPrt(' Decontracted 1st order density/Fock matrix',' ',DSOpr,iPrim*jPrim,nSO) + + ! Loops over symmetry operations. + + nOp(1) = NrOpr(0) + if (jBas < -999999) write(u6,*) 'gcc overoptimization',nDCRR + do lDCRR=0,nDCRR-1 + call OA(iDCRR(lDCRR),B,RB) + nOp(2) = NrOpr(iDCRR(lDCRR)) + if (EQ(A,RB) .and. (.not. DiffOp)) cycle + + !if (iPrint >= 49) write(u6,'(10A)') ' {M}=(',(ChOper(iStabM(i)),i=0,nStabM-1),')' + !end if + + llOper = lOper(1) + do iComp=2,nComp + llOper = ior(llOper,lOper(iComp)) + end do + call SOS(iStabO,nStabO,llOper) + call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) + + ! Compute normalization factor due the DCR symmetrization + ! of the two basis functions and the operator. + + iuv = dc(mdci)%nStab*dc(mdcj)%nStab + FactNd = real(iuv*nStabO,kind=wp)/real(nIrrep**2*LmbdT,kind=wp) + if (MolWgh == 1) then + FactNd = FactNd*real(nIrrep,kind=wp)**2/real(iuv,kind=wp) + else if (MolWgh == 2) then + FactNd = sqrt(real(iuv,kind=wp))*real(nStabO,kind=wp)/real(nIrrep*LmbdT,kind=wp) + end if + + !if (iPrint >= 49) write(u6,'(A,/,2(3F6.2,2X))') ' *** Centers A, RB ***',(A(i),i=1,3),(RB(i),i=1,3) + + ! Desymmetrize the matrix with which we will contract the trace. + + call DesymD(iSmLbl,iAng,jAng,iCmp,jCmp,iShell,jShell,iShll,jShll,iAO,jAO,DAO,iPrim,jPrim,DSOpr,nSO,nOp,FactNd) + + ! Project the spherical harmonic space onto the cartesian space. + + kk = nTri_Elem1(iAng)*nTri_Elem1(jAng) + if (Shells(iShll)%Transf .or. Shells(jShll)%Transf) then + + ! ij,AB --> AB,ij + call DGeTmO(DAO,iPrim*jPrim,iPrim*jPrim,iCmp*jCmp,Scrt1,iCmp*jCmp) + ! AB,ij --> ij,ab + call SphCar(Scrt1,iCmp*jCmp,iPrim*jPrim,Scrt2,nScrt2,RSph(ipSph(iAng)),iAng,Shells(iShll)%Transf,Shells(iShll)%Prjct, & + RSph(ipSph(jAng)),jAng,Shells(jShll)%Transf,Shells(jShll)%Prjct,DAO,kk) + end if + !if (iPrint >= 99) call RecPrt(' Decontracted FD in the cartesian space',' ',DAO,iPrim*jPrim,kk) + + ! Compute kappa and P. + + call Setup1(Shells(iShll)%Exp,iPrim,Shells(jShll)%Exp,jPrim,A,RB,Kappa,PCoor,ZI) + + ! Compute gradients of the primitive integrals and trace the result. + + !BS write(u6,*) 'Call the Kernel' + + call Kernel(Shells(iShll)%Exp,iPrim,Shells(jShll)%Exp,jPrim,Zeta,ZI,Kappa,Pcoor,Fnl,iPrim*jPrim,iAng,jAng,A,RB,nOrder, & + Kern,MemKer*iPrim*jPrim,Ccoor,nOrdOp,Hess,nHess,IfHss,IndHss,ifgrd,indgrd,DAO,mdci,mdcj,nOp,lOper,nComp, & + iStabM,nStabM,nIrrep) + +# ifdef _DEBUGPRINT_ + write(u6,*) 'Hess after Kernel call in dot1el ' + call HssPrt(Hess,nHess) +# endif + + end do + + call mma_deallocate(DSOpr) + end if + end if + call mma_deallocate(DAO) + call mma_deallocate(Scrt2) + call mma_deallocate(Scrt1) + call mma_deallocate(Fnl) + call mma_deallocate(Kern) + + ! end do + !end do +end do + +call Free_iSD() + +call mma_deallocate(PCoor) +call mma_deallocate(Kappa) +call mma_deallocate(ZI) +call mma_deallocate(Zeta) + +return + +end subroutine Dot1El diff -Nru openmolcas-22.02/src/mckinley/drvel1.f openmolcas-22.10/src/mckinley/drvel1.f --- openmolcas-22.02/src/mckinley/drvel1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/drvel1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,41 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SubRoutine Drvel1(Grad) - use Basis_Info - use Center_Info - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) - Logical, External :: TF - Real*8 Grad(*) - idisp=0 - do jIrrep=0,nirrep-1 - Do Jcar=1,3 - iirrep=irrfnc(2**(jcar-1)) - If (jirrep.eq.iirrep) Then - mdc=0 - Do iCnttp = 1, nCnttp - ZA = dbsc(iCnttp)%Charge - Do iCnt = 1, dbsc(iCnttp)%nCntr - mdc=mdc+1 - Do iCar=1,3 - iComp = 2**(iCar-1) - If ( TF(mdc,jIrrep,iComp)) Then - idisp=idisp+1 - If (icar.eq.jcar) Grad(idisp)=ZA - End If - End Do - End Do - End Do - End If - End Do - End Do - Return - End diff -Nru openmolcas-22.02/src/mckinley/drvel1.F90 openmolcas-22.10/src/mckinley/drvel1.F90 --- openmolcas-22.02/src/mckinley/drvel1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/drvel1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,53 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Drvel1(Grad) + +use Basis_Info +use Center_Info +use Symmetry_Info, only: nIrrep +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +real(kind=wp), intent(_OUT_) :: Grad(*) +integer(kind=iwp) :: iCar, iCnt, iCnttp, iComp, idisp, iirrep, jCar, jIrrep, mdc +real(kind=wp) :: ZA +integer(kind=iwp), external :: irrfnc +logical(kind=iwp), external :: TF + +idisp = 0 +do jIrrep=0,nirrep-1 + do jCar=1,3 + iirrep = irrfnc(2**(jcar-1)) + if (jirrep == iirrep) then + mdc = 0 + do iCnttp=1,nCnttp + ZA = dbsc(iCnttp)%Charge + do iCnt=1,dbsc(iCnttp)%nCntr + mdc = mdc+1 + do iCar=1,3 + iComp = 2**(iCar-1) + if (TF(mdc,jIrrep,iComp)) then + idisp = idisp+1 + if (icar == jcar) Grad(idisp) = ZA + end if + end do + end do + end do + end if + end do +end do + +return + +end subroutine Drvel1 diff -Nru openmolcas-22.02/src/mckinley/drvetc.f openmolcas-22.10/src/mckinley/drvetc.f --- openmolcas-22.02/src/mckinley/drvetc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/drvetc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,96 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1997, Anders Bernhardsson * -************************************************************************ - SubRoutine Drvetc(ngrad) -************************************************************************ -* * -* Object: driver for computation of gradients of one-electron matrices.* -* * -* Written by Anders Bernhardsson for electric field * -* Gradients * -* October 97 * -************************************************************************ - use Basis_Info - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) - External ElGrd,elgrddot - External ElMem -#include "Molcas.fh" -#include "real.fh" -#include "stdalloc.fh" -#include "disp.fh" - Character*8 Lbl - Real*8 Ccoor(3) - Real*8, Allocatable:: D0(:), EG(:), Temp(:) - - Ccoor(:)=Zero - - nDens = 0 - Do iIrrep = 0, nIrrep - 1 - nDens = nDens + nBas(iIrrep)*(nBas(iIrrep)+1)/2 - End Do - - Call mma_Allocate(D0,nDens,Label='D0') - Call Get_D1ao_Var(D0,nDens) - - Call mma_allocate(EG,3*nGrad,Label='EG') - Call Dot1El2(ElGrddot,ElMem,EG,3*nGrad,.true.,CCoor,D0,1) - Call mma_deallocate(D0) - - EG(:) = -EG(:) - - Call mma_allocate(Temp,3*nGrad,Label='Temp') - Temp(:)=Zero - - Call Drvel1(Temp) - - EG(:) = EG(:) + Temp(:) - - Lbl='NUCELGR' - idum=1 - iopt=128 - irc=3*ngrad - Call dWrMCk(irc,iopt,LBL,idum,Temp,idum) - If(irc.ne.0) Call SysAbendMsg('drvect', - & 'error during write in dwrmck',' ') - - idum=1 - iopt=128 - irc=3*ngrad - Lbl='DOTELGR' - Call dWrMCk(irc,iopt,LBL,idum,EG,idum) - If (irc.ne.0) Call SysAbendMsg('drvect', - & 'error during write in dwrmck',' ') - Call mma_deallocate(EG) - Call mma_deallocate(Temp) - -* needed in RASSI - loper=0 - Do iCar=1,3 - - isym=irrfnc(2**(icar-1)) ! nropr(ichbas(1+iCar)) - Write(Lbl,'(a,i2)') 'ELEC ',iCar - idcnt=0 - Do iCnttp=1,nCnttp - Do iCnt=1,dbsc(iCnttp)%nCntr - idcnt=idcnt+1 - Do idCar=1,3 - Call Cnt1El2(ELGRD,ELMEM,Lbl,idcnt,idcar,loper, - & One,.true.,lbl,0,isym,icar,1) - End Do - End Do - End Do - - End Do - - Return - End diff -Nru openmolcas-22.02/src/mckinley/drvetc.F90 openmolcas-22.10/src/mckinley/drvetc.F90 --- openmolcas-22.02/src/mckinley/drvetc.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/drvetc.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,99 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1997, Anders Bernhardsson * +!*********************************************************************** + +subroutine Drvetc(nGrad) +!*********************************************************************** +! * +! Object: driver for computation of gradients of one-electron matrices.* +! * +! Written by Anders Bernhardsson for electric field * +! Gradients * +! October 97 * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem +use Basis_Info, only: dbsc, nBas, nCnttp +use Symmetry_Info, only: nIrrep +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nGrad +integer(kind=iwp) :: iCar, iCnt, iCnttp, idCar, idcnt, idum, iIrrep, iopt, irc, isym, loper, nDens +real(kind=wp) :: Ccoor(3) +character(len=8) :: Lbl +real(kind=wp), allocatable :: D0(:), EG(:), Temp(:) +integer(kind=iwp), external :: irrfnc +external :: ElGrd, ElGrddot, ElMem + +Ccoor(:) = Zero + +nDens = 0 +do iIrrep=0,nIrrep-1 + nDens = nDens+nTri_Elem(nBas(iIrrep)) +end do + +call mma_Allocate(D0,nDens,Label='D0') +call Get_D1ao_Var(D0,nDens) + +call mma_allocate(EG,3*nGrad,Label='EG') +call Dot1El2(ElGrddot,ElMem,EG,3*nGrad,.true.,CCoor,D0,1) +call mma_deallocate(D0) + +EG(:) = -EG(:) + +call mma_allocate(Temp,3*nGrad,Label='Temp') +Temp(:) = Zero + +call Drvel1(Temp) + +EG(:) = EG(:)+Temp(:) + +Lbl = 'NUCELGR' +idum = 1 +iopt = 128 +irc = 3*nGrad +call dWrMCk(irc,iopt,LBL,idum,Temp,idum) +if (irc /= 0) call SysAbendMsg('drvect','error during write in dwrmck',' ') + +idum = 1 +iopt = 128 +irc = 3*nGrad +Lbl = 'DOTELGR' +call dWrMCk(irc,iopt,LBL,idum,EG,idum) +if (irc /= 0) call SysAbendMsg('drvect','error during write in dwrmck',' ') +call mma_deallocate(EG) +call mma_deallocate(Temp) + +! needed in RASSI +loper = 0 +do iCar=1,3 + + isym = irrfnc(2**(icar-1)) ! nropr(ichbas(1+iCar)) + write(Lbl,'(a,i2)') 'ELEC ',iCar + idcnt = 0 + do iCnttp=1,nCnttp + do iCnt=1,dbsc(iCnttp)%nCntr + idcnt = idcnt+1 + do idCar=1,3 + call Cnt1El2(ELGRD,ELMEM,Lbl,idcnt,idcar,loper,One,.true.,lbl,0,isym,icar,1) + end do + end do + end do + +end do + +return + +end subroutine Drvetc diff -Nru openmolcas-22.02/src/mckinley/drvg2.f openmolcas-22.10/src/mckinley/drvg2.f --- openmolcas-22.02/src/mckinley/drvg2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/drvg2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1103 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1995,1996, Anders Bernhardsson * -************************************************************************ - SubRoutine Drvg2(Hess,nhess,l_Grd,l_Hss) -************************************************************************ -* * -* Object: driver for two-electron integrals. The four outermost loops * -* will controll the type of the two-electron integral, eg. * -* (ss|ss), (sd|pp), etc. The next four loops will generate * -* list of symmetry distinct centers that do have basis func- * -* tions of the requested type. * -* * -* Input: * -* nHess : Size of gradient and hessian * -* l_Grd,l_Hss : Boolean on/off for gradient/hessian * -* generation * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March 1990 * -* Anders Bernhardsson 1995-1996 * -************************************************************************ - use Real_Spherical - use k2_setup - use iSD_data - use k2_arrays - use pso_stuff - use Basis_Info - use Symmetry_Info, only: nIrrep, iOper - use Sizes_of_Seward, only:S - use Gateway_Info, only: CutInt - Implicit Real*8 (A-H,O-Z) - External Rsv_Tsk -#include "Molcas.fh" -#include "real.fh" -#include "stdalloc.fh" -#include "disp.fh" -#include "disp2.fh" -#include "buffer.fh" -#include "etwas.fh" -#include "cputime.fh" -#include "nsd.fh" -#include "setup.fh" -* Local arrays - Real*8, Allocatable :: DeDe2(:) - Integer, Allocatable:: ipOffDA(:,:) - Real*8 Coor(3,4), Hess(*) - Integer iAngV(4), iCmpV(4), iShelV(4), iShllV(4), - & iAOV(4), iAOst(4), JndGrd(3,4,0:7), iFnc(4), - & JndHss(4,3,4,3,0:7) - Logical Shik, Shjl, Shijij, JfGrd(3,4),lpick, - & JfHss(4,3,4,3), JfG(4),ltri,ldot, Rsv_Tsk, - & l_Hss,l_Grd,lGrad,n8,ldot2,new_fock, - & Post_Process - Integer moip(0:7) -#ifdef _DEBUGPRINT_ - Character*40 format -#endif - Real*8, Allocatable:: TMax(:,:), Int(:), DTemp(:), DInAc(:) - Integer, Allocatable:: Ind_ij(:,:) -* * -************************************************************************ -* * -* Statement functions -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - iTri(i,j) = Max(i,j)*(Max(i,j)-1)/2 + Min(i,j) -* * -************************************************************************ -* * -* - - - - - - P R O L O G -* - Call StatusLine(' McKinley:', - & ' Computing 2-electron 2nd order derivatives') -* - ipDij = 0 - ipDij2 = 0 - ipDDij = 0 - ipDDij2 = 0 - ipDkl = 0 - ipDkl2 = 0 - ipDDkl = 0 - ipDDkl2 = 0 - ipDik = 0 - ipDik2 = 0 - ipDDik = 0 - ipDDik2 = 0 - ipDil = 0 - ipDil2 = 0 - ipDDil = 0 - ipDDil2 = 0 - ipDjk = 0 - ipDjk2 = 0 - ipDDjk = 0 - ipDDjk2 = 0 - ipDjl = 0 - ipDjl2 = 0 - ipDDjl = 0 - ipDDjl2 = 0 - ipBuffer= 0 - ipMOC = 0 - iFnc(1) = -99 - iFnc(2) = -99 - iFnc(3) = -99 - iFnc(4) = -99 - nDij=0 - nDkl=0 - nDik=0 - nDjl=0 - nDil=0 - nDjk=0 - mDCRij=0 - mDCRkl=0 - mDCRik=0 - mDCRjl=0 - mDCRil=0 - mDCRjk=0 - ipDijS =0 - ipDijS2=0 -* - Call CtrlMO(moip,nAco) -* - ndisp=0 - naco=0 - New_Fock=nirrep.eq.1 - Do iS=0,nIrrep-1 - nDisp=nDisp+ldisp(is) - naco=naco+nAsh(is) - End do - n8=.true. - Int_Direct=.true. -* - call dcopy_(nHess,[Zero],0,Hess,1) -* * -************************************************************************ -* * - Call Set_Basis_Mode('Valence') - Call Setup_iSD() -* * -************************************************************************ -* * -*-----Precompute k2 entities. -* - lgrad=l_Grd - lpick=lgrad.and.(.not.New_Fock) - Pren = Zero - Prem = Zero - nIndK2 = S%nShlls*(S%nShlls+1)/2 - Call mma_allocate(IndK2,2,nIndk2) - Call Drvk2_mck(ndede,new_Fock) -* - Call StatP(0) -* * -************************************************************************ -* * -* -*-----Allocate auxiliary array for symmetry transformation -* - nAux = nIrrep**3 - If (nIrrep==1) nAux = 1 - Call mma_allocate(Aux,nAux,Label='Aux') -* * -************************************************************************ -* * -* Allocate working area -* - MxPrm = 0 - MxDij = 0 - MxBsC = 0 - Do iAng = 0, S%iAngMx - MxPrm = Max(MxPrm,S%MaxPrm(iAng)) - Do 2900 iCnttp = 1,nCnttp - iShll = dbsc(iCnttp)%iVal + iAng - iPrim = Shells(iShll)%nExp - If (iPrim.eq.0) Go To 2900 - If (Shells(iShll)%nBasis.eq.0) Go To 2900 - iBas = Shells(iShll)%nBasis - iCmp = (iAng+1)*(iAng+2)/2 - MxBsC=Max(MxBsC,iBas*iCmp) - MxDij= Max(MxDij,(iBas**2+1)*iCmp**2+iPrim**2+1) - 2900 Continue - End Do - MxDij = 6 * nIrrep * MxDij - nZeta = MxPrm * MxPrm - nEta = MxPrm * MxPrm - iii=nDens*10+10 - MemR=9*nZeta + 9*nEta +nZeta*nEta - Call mma_allocate(Mem_INT,nZeta+nEta,Label='Mem_INT') - ipIndZet=1 - ipIndEta=ipIndZet+nZeta - Call mma_allocate(Mem_DBLE,MemR,Label='Mem_DBLE') - ipZeta=1 -* * -************************************************************************ -* * - If (lGrad) Then -* -*-----Calculate the size of memory needed for storing fock matrixes and -* MO integrals and allocate it. -* - nIndij=S%nShlls*(S%nShlls+1)/2 - nInt=0 - jDisp=0 - Do iIrrep=0,nIrrep-1 - Do iDisp=1,lDisp(iIrrep) - jDisp=jDisp+1 - ipDisp(jDisp)=nInt+1 - Do jIrr=0,nIrrep-1 - kIrr=nrOpr(iEOr(iOper(iIrrep),iOper(jIrr))) - If (jIrr.eq.kIrr) Then - nInt=nInt+nBas(jIrr)*(nBas(jIrr)+1)/2 - Else If (kIrr.lt.jIrr) Then - nInt=nInt+nBas(jIrr)*nBas(kIrr) - End If - End Do -* - If (nMethod.eq.RASSCF) Then - ipMO(jDisp,1)=nInt+1 - nInt=nInt+nMO(iIrrep) - ipdisp2(jdisp)=nInt+1 - Do jIrr=0,nIrrep-1 - kIrr=nrOpr(iEOr(iOper(iIrrep),iOper(jIrr))) - If (jIrr.eq.jIrr) Then - nInt=nInt+nBas(jIrr)*(nBas(jIrr)+1)/2 - Else If (kIrr.lt.jIrr) Then - nInt=nInt+nBas(jIrr)*nBas(kIrr) - End If - End Do - ipMO(jDisp,2)=nInt+1-ipMO(jDisp,1) - End If -* - End Do - End Do - If (nMethod.eq.RASSCF) Then - jDisp=0 - Do iIrrep=0,nIrrep-1 - Do iDisp=1,lDisp(iIrrep) - jDisp=jDisp+1 - ipdisp3(jdisp)=nInt+1 - Do iS=0,nirrep-1 - js=nrOpr(iEOr(iOper(is),iOper(iIrrep))) - nInt=nInt+nBas(iS)*nAsh(jS) - End Do - End Do - End Do - End If - Call mma_allocate(Int,nInt,Label='Int') - nTwo=0 - Do iIrrep=0,nIrrep-1 - nTwo=Max(nTwo,nFck(iIrrep)) - End Do - If (Int_Direct) Then - nTwo2=nInt - Else - nTwo2=nTwo - End If -* * -************************************************************************ -* * -*-----Desymmetrize densities. -* Observe that the desymmetrized 1st order density matrices are -* canonical, i.e. the relative order of the indices are canonically -* ordered. -* - Int(:)=Zero - Call mma_allocate(DTemp,nDens,Label='DTemp') - DTemp(:)=Zero - Call mma_allocate(DInAc,nDens,Label='DInAc') - DInAc(:)=Zero - If (New_Fock) Then - If (nmethod.ne.RASSCF) Then - Call Get_D1ao_Var(DTemp,nDens) - Call DScal_(nDens,Half,DTemp,1) - ij=0 - Do i = 1, nBas(0) - ij = ij + i - DTemp(ij)=Two*DTemp(ij) - End Do - Else - Call Din(DInAc) - Call DScal_(nDens,Half,DInAc,1) - ij=0 - Do i = 1, nBas(0) - ij = ij + i - DInAc(ij)=Two*DInAc(ij) - End Do - Call Dan(DTemp) - Call DScal_(nDens,Half,DTemp,1) - ij=0 - Do i = 1, nBas(0) - ij = ij + i - DTemp(ij)=Two*DTemp(ij) - End Do - End if - Else - mmdede=ndede - Call mma_allocate(ipOffD,3,nIndij,label='ipOffD') - Call mma_allocate(DeDe,mmDeDe+MxDij,label='DeDe') - ipDijS = 1 + mmDeDe - If (nMethod.ne.RASSCF) Then - Call Get_D1ao_Var(DTemp,nDens) - Call DeDe_mck(DTemp,nFck(0),ipOffD,nIndij, - & Dede,mmDeDe,mDeDe,mIndij) - Else - Call mma_allocate(ipOffDA,3,nIndij,Label='ipOffDA') - Call mma_allocate(DeDe2,mmDeDe+MxDij,label='DeDe2') - ipDijS2 = 1 + mmDeDe -* - Call Dan(DTemp) - Call DeDe_mck(DTemp,nFck(0),ipOffD,nIndij, - & DeDe,mmDeDe,mDeDe,mIndij) - - Call Din(DInAc) - Call DeDe_mck(DInAc,nFck(0),ipOffDA,nIndij, - & DeDe2,mmDeDe,mDeDe,mIndij) - - If (mDeDe.ne.nDeDe) Then - Write (6,*) 'DrvG2: mDeDe.ne.nDeDe' - Write (6,*) 'mDeDe,nDeDe=',mDeDe,nDeDe - Call Abend - End If - End If - End If -* - nb=0 - Do is=0,nIrrep-1 - nb=nb+nBas(iS) - End Do -* - End If ! lGrad -* * -************************************************************************ -* * - Call Free_iSD() - Call Set_Basis_Mode('Valence') - Call Nr_Shells(nSkal) - Call Setup_iSD() -* - nPairs=nSkal*(nSkal+1)/2 - nQuad=nPairs*(nPairs+1)/2 -* * -************************************************************************ -* * -*--- Compute entities for prescreening at shell level -* - Call mma_allocate(TMax,nSkal,nSkal,Label='TMax') - Call Shell_MxSchwz(nSkal,TMax) - TMax_all=Zero - Do iS = 1, nSkal - Do jS = 1, iS - TMax_all=Max(TMax_all,TMax(iS,jS)) - End Do - End Do -* * -************************************************************************ -* * -* Create list of non-vanishing pairs -* - Call mma_allocate(Ind_ij,2,nSkal*(nSkal+1)/2,Label='Ind_ij') - nijS=0 - Do iS = 1, nSkal - Do jS = 1, iS - If (TMax_All*TMax(iS,jS).ge.CutInt) Then - nijS = nijS + 1 - Ind_ij(1,nijS)=iS - Ind_ij(2,nijS)=jS - End If - End Do - End Do - Call Init_Tsk(id_Tsk,nijS) -* * -************************************************************************ -* * - Call mma_MaxDBLE(MemMax) - Call mma_allocate(Sew_Scr,MemMax-iii,Label='Sew_Scr') - ipMem=1 - memmax=memmax-iii -* * -************************************************************************ -* * -* big loop over individual tasks, distributed over individual nodes - 10 Continue -* make reservation of a task on global task list and get task range -* in return. Function will be false if no more tasks to execute. - If (.Not.Rsv_Tsk(id_Tsk,ijSh)) Go To 11 - iS = Ind_ij(1,ijSh) - jS = Ind_ij(2,ijSh) - Call CWTime(TCpu1,TWall1) -* * -************************************************************************ -* * -* Outer loops (ij) over angular momenta and centers -* -C Do iS = 1, nSkal - iShll = iSD( 0,iS) - iAng = iSD( 1,iS) - iCmp = iSD( 2,iS) - iBas = iSD( 3,iS) - iPrim = iSD( 5,iS) - iAO = iSD( 7,iS) - mdci = iSD(10,iS) - iShell = iSD(11,iS) - iCnttp = iSD(13,iS) - iCnt = iSD(14,iS) - Coor(1:3,1)=dbsc(iCnttp)%Coor(1:3,iCnt) -* - iAngV(1) = iAng - iShllV(1) = iShll - iCmpV(1) = iCmp - iShelV(1) = iShell - iAOV(1) = iAO -* -C Do jS = 1, iS - jShll = iSD( 0,jS) - jAng = iSD( 1,jS) - jCmp = iSD( 2,jS) - jBas = iSD( 3,jS) - jAO = iSD( 7,jS) - mdcj = iSD(10,jS) - jShell = iSD(11,jS) - jCnttp = iSD(13,jS) - jCnt = iSD(14,jS) - Coor(1:3,2)=dbsc(jCnttp)%Coor(1:3,jCnt) -* - iAngV(2) = jAng - iShllV(2) = jShll - iCmpV(2) = jCmp - iShelV(2) = jShell - iAOV(2) = jAO -* - nHrrab=0 - Do i=0,iAng+1 - Do j=0,jAng+1 - If (i+j.le.iAng+jAng+1) Then - ijMax=Min(iAng,jAng)+1 - nHrrab=nHrrab+ijMax*2+1 - End If - End Do - End Do -* * -************************************************************************ -* * -* Cltrls for MO transformation -* * -************************************************************************ -* * - If (nMethod.eq.RASSCF.and.l_Grd) Then - iMemB=nACO**2*iCmp*iBas*jCmp*jBas*nDisp*nirrep - If (iMemB.gt.MemMax) Then - Write (6,*) 'DrvG2: iMemB.gt.MemMax' - Write (6,*) 'iMemB=',iMemB - Write (6,*) 'MemMax=',MemMax - Write (6,*) 'Increase MOLCAS_MEM!' - Call Abend() - End If - Sew_Scr(1:iMemb)=Zero - Else - iMemb=0 - End If -* * -************************************************************************ -* * - Post_Process=.False. - Do klSh = 1, nijS - ks = Ind_ij(1,klSh) - ls = Ind_ij(2,klSh) -* - Aint=TMax(iS,jS)*TMax(kS,lS) -C Write (*,*) 'is,js,ks,ls=',is,js,ks,ls - If (AInt.lt.CutInt) Go To 400 -* -C Do kS = 1, nSkal - kShll = iSD( 0,kS) - kAng = iSD( 1,kS) - kCmp = iSD( 2,kS) - kAO = iSD( 7,kS) - mdck = iSD(10,kS) - kShell = iSD(11,kS) - kCnttp = iSD(13,kS) - kCnt = iSD(14,kS) - Coor(1:3,3)=dbsc(kCnttp)%Coor(1:3,kCnt) -* - iAngV(3) = kAng - iShllV(3) = kShll - iCmpV(3) = kCmp - iShelV(3) = kShell - iAOV(3) = kAO -* - Shik = iShell.eq.kShell -* -C Do lS = 1, kS - lShll = iSD( 0,lS) - lAng = iSD( 1,lS) - lCmp = iSD( 2,lS) - lAO = iSD( 7,lS) - mdcl = iSD(10,lS) - lShell = iSD(11,lS) - lCnttp = iSD(13,lS) - lCnt = iSD(14,lS) - Coor(1:3,4)=dbsc(lCnttp)%Coor(1:3,lCnt) -* - iAngV(4) = lAng - iShllV(4) = lShll - iCmpV(4) = lCmp - iShelV(4) = lShell - iAOV(4) = lAO -* -* - nHrrcd=0 - Do i=0,kAng+1 - Do j=0,lAng+1 - If (i+j.le.kAng+lAng+1) Then - ijMax=Min(kAng,lAng)+1 - nHrrcd=nHrrcd+ijMax*2+1 - End If - End Do - End Do -* * -************************************************************************ -* * -*-----------------The code is working in such away that the MO needs -* upper and lower triangular parts of ij kl but hessian -* needs only lower, check if the integralbatch is lower -* or upper!! -* - lTri=iTri(iS,jS).ge.iTri(kS,lS) - If (.not.lTri.and.nMethod.ne.RASSCF) Goto 400 - lDot=(lTri.and.l_Hss) -* - Shjl = jShell.eq.lShell - Shijij = Shik.and.Shjl -* * -************************************************************************ -* * - iCmpV(1)=icmp - iCmpV(2)=jcmp - iCmpV(3)=kcmp - iCmpV(4)=lcmp - iPrimi = Shells(iShllV(1))%nExp - jPrimj = Shells(iShllV(2))%nExp - kPrimk = Shells(iShllV(3))%nExp - lPriml = Shells(iShllV(4))%nExp - iBasi = Shells(iShllV(1))%nBasis - jBasj = Shells(iShllV(2))%nBasis - kBask = Shells(iShllV(3))%nBasis - lBasl = Shells(iShllV(4))%nBasis -* * -************************************************************************ -* * -*-------------Allocate memory for zeta, eta, kappa, P and Q. -* Allocate also for Alpha, Beta , Gamma and Delta -* in expanded form. -* - nZeta = iPrimi * jPrimj - nEta = kPrimk * lPriml - MemR=9*nZeta + 9*nEta +nEta*nZeta - ipZI = ipZeta + nZeta - ipKAB = ipZi + nZeta - ipP = ipKAB + nZeta - ipxA = ipP + nZeta*3 - ipxB = ipxA + nZeta - ipEta = ipxB + nZeta - ipEI = ipEta + nEta - ipKCD = ipEI + nEta - ipQ = ipKCD + nEta - ipxG = ipQ + nEta*3 - ipxD = ipxG + nEta - ipxPre= ipxD + nEta -* * -************************************************************************ -* * - nab = nElem(iAng)*nElem(jAng) - ncd = nElem(kAng)*nElem(lAng) - - ijS = iTri(iShell,jShell) - klS = iTri(kShell,lShell) - ikS = iTri(iShell,kShell) - ilS = iTri(iShell,lShell) - jkS = iTri(jShell,kShell) - jlS = iTri(jShell,lShell) -* If (.Not.l2DI) Then -* nab = 0 -* ncd = 0 -* End If - k2ij = Indk2(1,ijS) - nDCRR = Indk2(2,ijS) - k2kl = Indk2(1,klS) - nDCRS = Indk2(2,klS) -* - If (ltri) Then -* -*-------------------------------------------------------------------* -* -* Fix the 1st order density matrix -* -*-----------------Pick up pointers to desymmetrized 1st order density -* matrices. Observe that the desymmetrized 1st order -* density matrices follows the contraction index. -* - ipTmp =0 - ipTmp2=0 - If (lpick) Then -* - ipDij = ipOffD(1,ijS) - mDCRij= ipOffD(2,ijS) - nDij = ipOffD(3,ijS) -* - ipTmp = ipDijs - If (nMethod.eq.RASSCF) Then - ipDij2 = ipOffDA(1,ijS) - ipTmp2= ipDijs2 - End If -* - If (mDCRij.ne.0) Then - ipDDij = ipTmp - ipTmp = ipTmp + nDij*mDCRij - If (nMethod.eq.RASSCF) Then - ipDDij2=ipTmp2 - ipTmp2= ipTmp2+ nDij*mDCRij - End If - Else - ipDDij = 0 - End If -* - ipDkl = ipOffD(1,klS) - If (nMethod.eq.RASSCF) ipDkl2 = ipOffDA(1,klS) - mDCRkl= ipOffD(2,klS) - nDkl = ipOffD(3,klS) - If (mDCRkl.ne.0) Then - ipDDkl = ipTmp - ipTmp = ipTmp + nDkl*mDCRkl - If (nMethod.eq.RASSCF) Then - ipDDkl2=ipTmp2 - ipTmp2= ipTmp2+ nDkl*mDCRkl - End If - Else - ipDDkl = 0 - End If -* - ipDik = ipOffD(1,ikS) - If (nMethod.eq.RASSCF) ipDik2 = ipOffDA(1,ikS) - mDCRik= ipOffD(2,ikS) - nDik = ipOffD(3,ikS) - If (mDCRik.ne.0) Then - ipDDik = ipTmp - ipTmp = ipTmp + nDik*mDCRik - If (nMethod.eq.RASSCF) Then - ipDDik2=ipTmp2 - ipTmp2= ipTmp2+ nDik*mDCRik - End If - Else - ipDDik = 0 - End If -* - ipDil = ipOffD(1,ilS) - If (nMethod.eq.RASSCF) ipDil2 = ipOffDA(1,ilS) - mDCRil= ipOffD(2,ilS) - nDil = ipOffD(3,ilS) - If (mDCRil.ne.0) Then - ipDDil = ipTmp - ipTmp = ipTmp + nDil*mDCRil - If (nMethod.eq.RASSCF) Then - ipDDil2=ipTmp2 - ipTmp2= ipTmp2+ nDil*mDCRil - End If - Else - ipDDil = 0 - End If -* - ipDjk = ipOffD(1,jkS) - If (nMethod.eq.RASSCF) ipDjk2 = ipOffDA(1,jkS) - mDCRjk= ipOffD(2,jkS) - nDjk = ipOffD(3,jkS) - If (mDCRjk.ne.0) Then - ipDDjk = ipTmp - ipTmp = ipTmp + nDjk*mDCRjk - If (nMethod.eq.RASSCF) Then - ipDDjk2=ipTmp2 - ipTmp2= ipTmp2 + nDjk*mDCRjk - End If - Else - ipDDjk = 0 - End If -* - ipDjl = ipOffD(1,jlS) - If (nMethod.eq.RASSCF) ipDjl2 = ipOffDA(1,jlS) - mDCRjl= ipOffD(2,jlS) - nDjl = ipOffD(3,jlS) - If (mDCRjl.ne.0) Then - ipDDjl = ipTmp - ipTmp = ipTmp + nDjl*mDCRjl - If (nMethod.eq.RASSCF) Then - ipDDjl2=ipTmp2 - ipTmp2= ipTmp2+ nDjl*mDCRjl - End If - Else - ipDDjl = 0 - End If -* - End If ! If (lpick) Then - End If ! If (ltri) Then -* * -************************************************************************ -* * -*-----------------Compute total size of the second order density -* matrix in SO basis. -* -*----------------------------------------------------------------------* - nSO = MemSO2_P(iCmp,jCmp,kCmp,lCmp, - & iAOV(1),iAOV(2),iAOV(3),iAOV(4)) - ldot2=ldot - If (nSO.eq.0) ldot2=.false. -* -*-----------------Compute memory request for the primitives. -* - ider=2 - if (.not.ldot2) iDer=1 - Call MemRg2(iAngV,nRys,MemPrm,ider) -* -*----------------------------------------------------------------------* -* -* Calculate which derivatives that should be made. -* -*----------------------------------------------------------------------* -* - Call DerCtr(mdci,mdcj,mdck,mdcl,ldot2,JfGrd, - & JndGrd,JfHss,JndHss,JfG,mBatch) -* - -*----------------------------------------------------------------------* -* -*-----------------Decide on the partioning of the shells based on the -* available memory and the requested memory. -* - Call PSOAO2(nSO,MemPrm, MemMax, - & iAngV, iCmpV, iAOV,iFnc, - & iBasi,iBsInc, jBasj,jBsInc, - & kBask,kBsInc, lBasl,lBsInc, - & iPrimi,iPrInc,jPrimj,jPrInc, - & kPrimk,kPrInc,lPriml,lPrInc, - & nAco, - & Mem1,Mem2,Mem3,Mem4, - & MemX,MemPSO, - & MemFck,nFT,memCMO2,MemFin,MemBuffer, - & iMemB) - -* -*----------------------------------------------------------------------* -* -* Loop over basis function if we do not have enough of memory to -* calculate them in one step. -* -*----------------------------------------------------------------------* - Do 500 iBasAO = 1, iBasi, iBsInc - iBasn=Min(iBsInc,iBasi-iBasAO+1) - iAOst(1) = iBasAO-1 -*----------------------------------------------------------------------* -* -*----------------- Move appropiate portions of the desymmetrized 1st -* order density matrix. -* -* -*----------------------------------------------------------------------* - Do 510 jBasAO = 1, jBasj, jBsInc - jBasn=Min(jBsInc,jBasj-jBasAO+1) - iAOst(2) = jBasAO-1 - If (lpick.and.nDij*mDCRij.ne.0) Then - Call Picky(DeDe(ipDij),iBasi,jBasj, - & iPrimi*jPrimj, - & iCmpV(1)*iCmpV(2),mDCRij, - & iBasAO,iBasAO+iBasn-1, - & jBasAO,jBasAO+jBasn-1,DeDe(ipDDij)) - If (nMethod.eq.RASSCF) - & Call Picky(DeDe2(ipDij2),iBasi,jBasj, - & iPrimi*jPrimj, - & iCmpV(1)*iCmpV(2),mDCRij, - & iBasAO,iBasAO+iBasn-1, - & jBasAO,jBasAO+jBasn-1,DeDe2(ipDDij2)) - End If - mDij = (iBasn*jBasn+1)*iCmpV(1)*iCmpV(2) + - & iPrimi*jPrimj + 1 - mDij = Min(nDij,mDij) -* - Do 520 kBasAO = 1, kBask, kBsInc - kBasn=Min(kBsInc,kBask-kBasAO+1) - iAOst(3) = kBasAO-1 - If (lpick.and.nDik*mDCRik.ne.0) Then - Call Picky(DeDe(ipDik),iBasi,kBask, - & iPrimi*kPrimk, - & iCmpV(1)*iCmpV(3),mDCRik, - & iBasAO,iBasAO+iBasn-1, - & kBasAO,kBasAO+kBasn-1,DeDe(ipDDik)) - If (nMethod.eq.RASSCF) - & Call Picky(DeDe2(ipDik2),iBasi,kBask, - & iPrimi*kPrimk, - & iCmpV(1)*iCmpV(3),mDCRik, - & iBasAO,iBasAO+iBasn-1, - & kBasAO,kBasAO+kBasn-1,DeDe2(ipDDik2)) - End If - mDik = (iBasn*kBasn+1)*iCmpV(1)*iCmpV(3) + - & iPrimi*kPrimk + 1 - mDik = Min(nDik,mDik) - If (lpick.and.nDjk*mDCRjk.ne.0) Then - Call Picky(DeDe(ipDjk),jBasj,kBask, - & jPrimj*kPrimk, - & iCmpV(2)*iCmpV(3),mDCRjk, - & jBasAO,jBasAO+jBasn-1, - & kBasAO,kBasAO+kBasn-1,DeDe(ipDDjk)) - If (nMethod.eq.RASSCF) - & Call Picky(DeDe2(ipDjk2),jBasj,kBask, - & jPrimj*kPrimk, - & iCmpV(2)*iCmpV(3),mDCRjk, - & jBasAO,jBasAO+jBasn-1, - & kBasAO,kBasAO+kBasn-1,DeDe2(ipDDjk2)) - End If - mDjk = (jBasn*kBasn+1)*iCmpV(2)*iCmpV(3) + - & jPrimj*kPrimk + 1 - mDjk = Min(nDjk,mDjk) - - Do 530 lBasAO = 1, lBasl, lBsInc - lBasn=Min(lBsInc,lBasl-lBasAO+1) - iAOst(4) = lBasAO-1 - If (lpick.and.nDkl*mDCRkl.ne.0) Then - Call Picky(DeDe(ipDkl),kBask,lBasl, - & kPrimk*lPriml, - & iCmpV(3)*iCmpV(4),mDCRkl, - & kBasAO,kBasAO+kBasn-1, - & lBasAO,lBasAO+lBasn-1,DeDe(ipDDkl)) - If (nMethod.eq.RASSCF) - & Call Picky(DeDe2(ipDkl2),kBask,lBasl, - & kPrimk*lPriml, - & iCmpV(3)*iCmpV(4),mDCRkl, - & kBasAO,kBasAO+kBasn-1, - & lBasAO,lBasAO+lBasn-1,DeDe2(ipDDkl2)) - End If - mDkl = (kBasn*lBasn+1)*iCmpV(3)*iCmpV(4) + - & kPrimk*lPriml + 1 - mDkl = Min(nDkl,mDkl) - If (lpick.and.nDil*mDCRil.ne.0) Then - Call Picky(DeDe(ipDil),iBasi,lBasl, - & iPrimi*lPriml, - & iCmpV(1)*iCmpV(4),mDCRil, - & iBasAO,iBasAO+iBasn-1, - & lBasAO,lBasAO+lBasn-1,DeDe(ipDDil)) - If (nMethod.eq.RASSCF) - & Call Picky(DeDe2(ipDil2),iBasi,lBasl, - & iPrimi*lPriml, - & iCmpV(1)*iCmpV(4),mDCRil, - & iBasAO,iBasAO+iBasn-1, - & lBasAO,lBasAO+lBasn-1,DeDe2(ipDDil2)) - End If - mDil = (iBasn*lBasn+1)*iCmpV(1)*iCmpV(4) + - & iPrimi*lPriml + 1 - mDil = Min(nDil,mDil) - If (lpick.and.nDjl*mDCRjl.ne.0) Then - Call Picky(DeDe(ipDjl),jBasj,lBasl, - & jPrimj*lPriml, - & iCmpV(2)*iCmpV(4),mDCRjl, - & jBasAO,jBasAO+jBasn-1, - & lBasAO,lBasAO+lBasn-1,DeDe(ipDDjl)) - If (nMethod.eq.RASSCF) - & Call Picky(DeDe2(ipDjl2),jBasj,lBasl, - & jPrimj*lPriml, - & iCmpV(2)*iCmpV(4),mDCRjl, - & jBasAO,jBasAO+jBasn-1, - & lBasAO,lBasAO+lBasn-1,DeDe2(ipDDjl2)) - End If - mDjl = (jBasn*lBasn+1)*iCmpV(2)*iCmpV(4) + - & jPrimj*lPriml + 1 - mDjl = Min(nDjl,mDjl) - If (.not.lpick) Then - ipddjl2=0 - ipddil2=0 - ipddkl2=0 - ipddij2=0 - ipddik2=0 - ipddjk2=0 - End If -* -*----------------------------------------------------------------------* -* - MEMCMO=nACO*(kCmp*kBasn+lCmp*lBasn) -*.................. MO tranformation buffer - ipBuffer = ipMem - ipMOC = ipBuffer + MEMBUFFER -*.................. Area for the AO integrals - ipFin = ipMOC + MemCMO -*.................. Area for 2el density - ip_PP = ipFin + MemFin - ipMem2 = ip_PP + Mem1 ! Work - ipMem3 = ipMem2 + Mem2 ! Work - ipMemX = ipMem3 + Mem3 ! Work -* -*-------------------If MO transformation is performed in the standard way -* reserve memory for partial transfromed integrals -* -* -*-------------------Multilayer -* - ipMem4 = ipMem2 + Mem2 - Mem4 - -* -*----------------------------------------------------------------------* -* -*-------------------Get the 2nd order density matrix in SO basis. -* -*----------------------------------------------------------------------* -* - - nijkl = iBasn*jBasn*kBasn*lBasn - Call Timing(dum,Time,Dum,Dum) - If (n8) - & Call PickMO(Sew_Scr(ipMOC),MemCMO,nAcO,iCmpV, - & iBasAO,iBasn,jBasAO,jBasn, - & kBasAO,kBasn,lBasAO,lBasn,iAOV) - If (ldot2) - & Call PGet0(iCmpV, - & iBasn,jBasn,kBasn,lBasn,Shijij, - & iAOV,iAOst,nijkl,Sew_Scr(ip_PP),nSO, - & iFnc(1)*iBasn,iFnc(2)*jBasn, - & iFnc(3)*kBasn,iFnc(4)*lBasn,MemPSO, - & Sew_Scr(ipMem2),Mem2, - & iS,jS,kS,lS,nQuad,PMax) - Call Timing(dum,Time,Dum,Dum) - CPUStat(nTwoDens)=CPUStat(nTwoDens)+Time -* -*-------------------Compute gradients of shell quadruplet -* - ipD0=ip_of_Work(D0(1,1)) - Call TwoEl_mck(Coor,iAngV,iCmpV,iShelV,iShllV,iAOV, - & iAOst,mdci,mdcj,mdck,mdcl,nRys, - & Data_k2(k2ij),nab,nDCRR, - & Data_k2(k2kl),ncd,nDCRS,Pren,Prem, - & Shells(iShllV(1))%Exp,iPrimi,iPrInc, - & Shells(iShllV(2))%Exp,jPrimj,jPrInc, - & Shells(iShllV(3))%Exp,kPrimk,kPrInc, - & Shells(iShllV(4))%Exp,lPriml,lPrInc, - & Shells(iShllV(1))%pCff(1,iBasAO),iBasn, - & Shells(iShllV(2))%pCff(1,jBasAO),jBasn, - & Shells(iShllV(3))%pCff(1,kBasAO),kBasn, - & Shells(iShllV(4))%pCff(1,lBasAO),lBasn, - & Mem_DBLE(ipZeta),Mem_DBLE(ipZI), - & Mem_DBLE(ipP),Mem_DBLE(ipKab),nZeta, - & Mem_DBLE(ipEta), Mem_DBLE(ipEI), - & Mem_DBLE(ipQ),Mem_DBLE(ipKcd),nEta, - & Mem_DBLE(ipxA),Mem_DBLE(ipxB), - & Mem_DBLE(ipxG),Mem_DBLE(ipxD), - & Mem_DBLE(ipxPre), - & Hess, nhess,JfGrd,JndGrd,JfHss,JndHss,JfG, - & Sew_Scr(ip_PP), nSO,Sew_Scr(ipMem2),Mem2, - & Sew_Scr(ipMem3),Mem3,Sew_Scr(ipMem4),Mem4, - & Aux,nAux,Sew_Scr(ipMemX),MemX,Shijij, - & DeDe(ipDDij),DeDe2(ipDDij2),mDij,mDCRij, - & DeDe(ipDDkl),DeDe2(ipDDkl2),mDkl,mDCRkl, - & DeDe(ipDDik),DeDe2(ipDDik2),mDik,mDCRik, - & DeDe(ipDDil),DeDe2(ipDDil2),mDil,mDCRil, - & DeDe(ipDDjk),DeDe2(ipDDjk2),mDjk,mDCRjk, - & DeDe(ipDDjl),DeDe2(ipDDjl2),mDjl,mDCRjl, - & iCmpV,Sew_Scr(ipFin),MemFin, - & Sew_Scr(ipMem2),Mem2+Mem3+MemX,nTwo2,nFT, - & Mem_INT(ipIndEta),Mem_INT(ipIndZet), - & Int,ipd0,Sew_Scr(ipBuffer),MemBuffer, - & lgrad,ldot2,n8,ltri,DTemp,DInAc, - & moip,nAco,Sew_Scr(ipMOC),MemCMO,new_fock) - Post_Process=.True. - -*----------------------------------------------------------------------* -* - 530 Continue - 520 Continue - 510 Continue - 500 Continue -* - 400 Continue -C End Do ! lS -C End Do ! kS - End Do ! klS -* - If (nMethod.eq.RASSCF.and.Post_Process) Then - ip1=ipMOC - ip2=ip1+iCmp*iBas*naco - ip3=ip2+nAco**2 - ip4=ip3+jcmp*jBas*naco - ip5=ip4+iCmp*naco*iBas - ip6=ip5+jcmp*jbas*naco - Call CLR2(Sew_Scr(ipBuffer),Int, - & ibas,icmp,jbas,jcmp,iAOV(1),iAOV(2), - & naco,ishelV, - & Sew_Scr(ip1),Sew_Scr(ip2),Sew_Scr(ip3), - & Sew_Scr(ip4),Sew_Scr(ip5),Sew_Scr(ip6)) - End If -* -C End Do ! jS -C End Do ! iS -* - Call CWTime(TCpu2,TWall2) - Call SavTim(4,TCpu2-TCpu1,TWall2-Twall1) - Call SavStat(1,One,'+') - Call SavStat(2,DBLE(nijs),'+') - Go To 10 - 11 Continue -* End of big task loop -* * -************************************************************************ -* * -* - - - - - - - E P I L O G -* * -************************************************************************ -* * - If (New_Fock) Then - idd=0 - Do iS=0,nirrep-1 - Do iD=1,ldisp(is) - idd=idd+1 - ip=ipDisp(idd) - Call DScal_(nDens,Half,Int(ip),1) - ij =ip-1 - Do i = 1, nBas(0) - ij=ij+i - Int(ij)=Two*Int(ij) - End Do - End Do - End Do - If (nmethod.eq.RASSCF) Then - idd=0 - Do iS=0,nirrep-1 - Do iD=1,ldisp(is) - idd=idd+1 - ip=ipDisp2(idd) - Call DScal_(nDens,Half,Int(ip),1) - ij =ip-1 - Do i = 1, nBas(0) - ij=ij+i - Int(ij)=Two*Int(ij) - End Do - End Do - End Do - - End If - End If -#ifdef _DEBUGPRINT_ - Call GADSum_SCAL(Pren) - Call GADSum_SCAL(Prem) - Write (Format,'(A,I2,A,I2,A)') '(A,F', - & 3+Int(Log10(Pren)), - & '.0,A,F', - & 3+Int(Log10(Prem)), - & '.0,A)' - Write (6,Format) - & ' A total of', Pren,' entities were prescreened and', - & Prem,' were kept.' -#endif - Call mma_deallocate(Sew_Scr) - Call Free_Tsk(id_Tsk) -* -* YIPPIEEEE Finished OK fill it UP!! -* - Call GADSum(Int,nInt) - jDisp=0 - Do iIrr=0,nIrrep-1 - Do iDisk=1,lDisp(iIrr) - jDisp=jDisp+1 - Call WrDisk(Int,nInt,jdisp,iIrr) - End Do - End Do -* - Call mma_deallocate(Ind_ij) - Call mma_deallocate(TMax) - Call Free_iSD() -* - If (.not.New_Fock) Then - Call mma_deallocate(ipOffD) - Call mma_deallocate(DeDe) - If (nMethod.eq.RASSCF) Then - Call mma_deallocate(DeDe2) - Call mma_deallocate(ipOffDA) - End If - End If -* - Call mma_deallocate(Mem_DBLE) - Call mma_deallocate(Mem_INT) -* - Call mma_deallocate(DInAc) - Call mma_deallocate(DTemp) - Call mma_deallocate(Int) -* - Call mma_deallocate(Aux) -* -*-----Generate statistic of partioning -* - Call mma_deallocate(IndK2) - Call mma_deallocate(Data_k2) -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/drvg2.F90 openmolcas-22.10/src/mckinley/drvg2.F90 --- openmolcas-22.02/src/mckinley/drvg2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/drvg2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,997 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Roland Lindh * +! 1995,1996, Anders Bernhardsson * +!*********************************************************************** + +subroutine Drvg2(Hess,nHess,l_Grd,l_Hss) +!*********************************************************************** +! * +! Object: driver for two-electron integrals. The four outermost loops * +! will controll the type of the two-electron integral, eg. * +! (ss|ss), (sd|pp), etc. The next four loops will generate * +! list of symmetry distinct centers that do have basis func- * +! tions of the requested type. * +! * +! Input: * +! nHess : Size of gradient and hessian * +! l_Grd,l_Hss : Boolean on/off for gradient/hessian * +! generation * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March 1990 * +! Anders Bernhardsson 1995-1996 * +!*********************************************************************** + +use McKinley_global, only: CPUStat, ipDisp, ipDisp2, ipDisp3, ipMO, nFck, nMethod, nTwoDens, RASSCF +use Index_Functions, only: iTri, nTri_Elem, nTri_Elem1 +use iSD_data, only: iSD +use k2_setup, only: Data_k2, Indk2, nIndk2 +use k2_arrays, only: Aux, DeDe, ipDijS, ipOffD, ipZeta, MemR, MxDij, Mem_INT, Mem_DBLE, ndede, nFT, Sew_Scr +use pso_stuff, only: nDens +use Basis_Info, only: dbsc, nBas, nCnttp, Shells +use Symmetry_Info, only: iOper, nIrrep +use Sizes_of_Seward, only: S +use Gateway_Info, only: CutInt +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Half +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nHess +real(kind=wp), intent(out) :: Hess(nHess) +logical(kind=iwp), intent(in) :: l_Grd, l_Hss +#include "Molcas.fh" +#include "disp.fh" +#include "etwas.fh" +#include "setup.fh" +integer(kind=iwp) :: i, iAng, iAngV(4), iAO, iAOst(4), iAOV(4), iBas, iBasAO, ibasI, iBasn, iBsInc, iCmp, iCmpV(4), iCnt, iCnttp, & + id, id_Tsk, idd, ider, iDisk, iDisp, iFnc(4), iii, iIrr, iIrrep, ij, ijMax, ijS, ijSh, ikS, ilS, iMemB, ip, & + ip1, ip2, ip3, ip4, ip5, ip6, ip_PP, ipBuffer, ipDDij, ipDDij2, ipDDik, ipDDik2, ipDDil, ipDDil2, ipDDjk, & + ipDDjk2, ipDDjl, ipDDjl2, ipDDkl, ipDDkl2, ipDij, ipDij2, ipDijS2, ipDik, ipDik2, ipDil, ipDil2, ipDjk, & + ipDjk2, ipDjl, ipDjl2, ipDkl, ipDkl2, ipEI, ipEta, ipFin, ipIndEta, ipIndZet, ipKAB, ipKCD, ipMem, ipMem2, & + ipMem3, ipMem4, ipMemX, ipMOC, ipP, ipQ, iPrim, iPrimi, iPrInc, ipTmp, ipTmp2, ipxA, ipxB, ipxD, ipxG, & + ipxPre, ipZI, iS, iShell, iShelV(4), iShll, iShllV(4), j, jAng, jAO, jBas, jBasAO, jBasj, jBasn, jBsInc, & + jCmp, jCnt, jCnttp, jDisp, jIrr, jkS, jlS, JndGrd(3,4,0:7), JndHss(4,3,4,3,0:7), jPrimj, jPrInc, js, jShell, & + jShll, k2ij, k2kl, kAng, kAO, kBasAO, kBask, kBasn, kBsInc, kCmp, kCnt, kCnttp, kIrr, klS, klSh, kPrimk, & + kPrInc, ks, kShell, kShll, lAng, lAO, lBasAO, lBasl, lBasn, lBsInc, lCmp, lCnt, lCnttp, lPriml, lPrInc, ls, & + lShell, lShll, mdci, mdcj, mdck, mdcl, mDCRij, mDCRik, mDCRil, mDCRjk, mDCRjl, mDCRkl, mDeDe, mDij, mDik, & + mDil, mDjk, mDjl, mDkl, Mem1, Mem2, Mem3, Mem4, MemBuffer, MEMCMO, memCMO2, MemFck, MemFin, MemMax, MemPrm, & + MemPSO, MemX, mIndij, mmdede, moip(0:7), MxBsC, n_Int, nAco, nb, nDCRR, nDCRS, nDij, nDik, nDil, ndisp, nDjk, & + nDjl, nDkl, nEta, nHrrab, nHrrcd, nijkl, nijS, nIndij, nMO, nPairs, nQuad, nRys, nSkal, nSO, nTwo, nTwo2, nZeta +real(kind=wp) :: A_int, dum, Coor(3,4), PMax, Prem, Pren, TCpu1, TCpu2, Time, TMax_all, TWall1, TWall2 +logical(kind=iwp) :: JfG(4), JfGrd(3,4), JfHss(4,3,4,3), ldot, ldot2, lGrad, lpick, ltri, n8, new_fock, Post_Process, Shijij, & + Shik, Shjl +#ifdef _DEBUGPRINT_ +character(len=40) :: frmt +#endif +logical(kind=iwp), parameter :: Int_Direct = .true. +integer(kind=iwp), allocatable :: Ind_ij(:,:), ipOffDA(:,:) +real(kind=wp), allocatable :: DeDe2(:), DInAc(:), DTemp(:), iInt(:), TMax(:,:) +integer(kind=iwp), external :: MemSO2_P, NrOpr +logical(kind=iwp), external :: Rsv_Tsk + +! * +!*********************************************************************** +! * +! PROLOGUE + +call StatusLine(' McKinley:',' Computing 2-electron 2nd order derivatives') + +ipDij = 0 +ipDij2 = 0 +ipDDij = 0 +ipDDij2 = 0 +ipDkl = 0 +ipDkl2 = 0 +ipDDkl = 0 +ipDDkl2 = 0 +ipDik = 0 +ipDik2 = 0 +ipDDik = 0 +ipDDik2 = 0 +ipDil = 0 +ipDil2 = 0 +ipDDil = 0 +ipDDil2 = 0 +ipDjk = 0 +ipDjk2 = 0 +ipDDjk = 0 +ipDDjk2 = 0 +ipDjl = 0 +ipDjl2 = 0 +ipDDjl = 0 +ipDDjl2 = 0 +ipBuffer = 0 +ipMOC = 0 +iFnc(1) = -99 +iFnc(2) = -99 +iFnc(3) = -99 +iFnc(4) = -99 +nDij = 0 +nDkl = 0 +nDik = 0 +nDjl = 0 +nDil = 0 +nDjk = 0 +mDCRij = 0 +mDCRkl = 0 +mDCRik = 0 +mDCRjl = 0 +mDCRil = 0 +mDCRjk = 0 +ipDijS = 0 +ipDijS2 = 0 + +call CtrlMO(moip,nAco) + +ndisp = 0 +naco = 0 +New_Fock = nirrep == 1 +do iS=0,nIrrep-1 + nDisp = nDisp+ldisp(is) + naco = naco+nAsh(is) +end do +n8 = .true. + +Hess(:) = Zero +! * +!*********************************************************************** +! * +call Set_Basis_Mode('Valence') +call Setup_iSD() +! * +!*********************************************************************** +! * +! Precompute k2 entities. + +lgrad = l_Grd +lpick = lgrad .and. (.not. New_Fock) +Pren = Zero +Prem = Zero +nIndK2 = nTri_Elem(S%nShlls) +call mma_allocate(IndK2,2,nIndk2) +call Drvk2_mck(ndede,new_Fock) + +call StatP(0) +! * +!*********************************************************************** +! * +! Allocate auxiliary array for symmetry transformation + +nAux = nIrrep**3 +if (nIrrep == 1) nAux = 1 +call mma_allocate(Aux,nAux,Label='Aux') +! * +!*********************************************************************** +! * +! Allocate working area + +MxPrm = 0 +MxDij = 0 +MxBsC = 0 +do iAng=0,S%iAngMx + MxPrm = max(MxPrm,S%MaxPrm(iAng)) + do iCnttp=1,nCnttp + iShll = dbsc(iCnttp)%iVal+iAng + iPrim = Shells(iShll)%nExp + if (iPrim == 0) cycle + if (Shells(iShll)%nBasis == 0) cycle + iBas = Shells(iShll)%nBasis + iCmp = nTri_Elem1(iAng) + MxBsC = max(MxBsC,iBas*iCmp) + MxDij = max(MxDij,(iBas**2+1)*iCmp**2+iPrim**2+1) + end do +end do +MxDij = 6*nIrrep*MxDij +nZeta = MxPrm*MxPrm +nEta = MxPrm*MxPrm +iii = nDens*10+10 +MemR = 9*nZeta+9*nEta+nZeta*nEta +call mma_allocate(Mem_INT,nZeta+nEta,Label='Mem_INT') +ipIndZet = 1 +ipIndEta = ipIndZet+nZeta +call mma_allocate(Mem_DBLE,MemR,Label='Mem_DBLE') +ipZeta = 1 +! * +!*********************************************************************** +! * +if (lGrad) then + + ! Calculate the size of memory needed for storing fock matrices and + ! MO integrals and allocate it. + + nMO = nTri_Elem(nTri_Elem(naco)) + + call mma_allocate(ipDisp,nDisp,label='ipDisp') + if (nMethod == RASSCF) then + call mma_allocate(ipMO,nDisp,label='ipMO') + call mma_allocate(ipDisp2,nDisp,label='ipDisp2') + call mma_allocate(ipDisp3,nDisp,label='ipDisp3') + end if + + nIndij = nTri_Elem(S%nShlls) + n_Int = 0 + jDisp = 0 + do iIrrep=0,nIrrep-1 + do iDisp=1,lDisp(iIrrep) + jDisp = jDisp+1 + ipDisp(jDisp) = n_Int+1 + do jIrr=0,nIrrep-1 + kIrr = nrOpr(ieor(iOper(iIrrep),iOper(jIrr))) + if (jIrr == kIrr) then + n_Int = n_Int+nTri_Elem(nBas(jIrr)) + else if (kIrr < jIrr) then + n_Int = n_Int+nBas(jIrr)*nBas(kIrr) + end if + end do + + if (nMethod == RASSCF) then + ipMO(jDisp) = n_Int+1 + n_Int = n_Int+nMO + ipDisp2(jDisp) = n_Int+1 + do jIrr=0,nIrrep-1 + kIrr = nrOpr(ieor(iOper(iIrrep),iOper(jIrr))) + if (jIrr == jIrr) then + n_Int = n_Int+nTri_Elem(nBas(jIrr)) + else if (kIrr < jIrr) then + n_Int = n_Int+nBas(jIrr)*nBas(kIrr) + end if + end do + end if + + end do + end do + if (nMethod == RASSCF) then + jDisp = 0 + do iIrrep=0,nIrrep-1 + do iDisp=1,lDisp(iIrrep) + jDisp = jDisp+1 + ipDisp3(jDisp) = n_Int+1 + do iS=0,nirrep-1 + js = nrOpr(ieor(iOper(is),iOper(iIrrep))) + n_Int = n_Int+nBas(iS)*nAsh(jS) + end do + end do + end do + end if + call mma_allocate(iInt,n_Int,Label='iInt') + nTwo = 0 + do iIrrep=0,nIrrep-1 + nTwo = max(nTwo,nFck(iIrrep)) + end do + if (Int_Direct) then + nTwo2 = n_Int + else + nTwo2 = nTwo + end if + ! * + !********************************************************************* + ! * + ! Desymmetrize densities. + ! Observe that the desymmetrized 1st order density matrices are canonical, + ! i.e. the relative order of the indices are canonically ordered. + + iInt(:) = Zero + call mma_allocate(DTemp,nDens,Label='DTemp') + DTemp(:) = Zero + call mma_allocate(DInAc,nDens,Label='DInAc') + DInAc(:) = Zero + if (New_Fock) then + if (nmethod /= RASSCF) then + call Get_D1ao_Var(DTemp,nDens) + DTemp(:) = Half*DTemp + ij = 0 + do i=1,nBas(0) + ij = ij+i + DTemp(ij) = Two*DTemp(ij) + end do + else + call Din(DInAc) + DInAc(:) = Half*DInAc + ij = 0 + do i=1,nBas(0) + ij = ij+i + DInAc(ij) = Two*DInAc(ij) + end do + call Dan(DTemp) + DTemp(:) = Half*DTemp + ij = 0 + do i=1,nBas(0) + ij = ij+i + DTemp(ij) = Two*DTemp(ij) + end do + end if + else + mmdede = ndede + call mma_allocate(ipOffD,3,nIndij,label='ipOffD') + call mma_allocate(DeDe,mmDeDe+MxDij,label='DeDe') + ipDijS = 1+mmDeDe + if (nMethod /= RASSCF) then + call Get_D1ao_Var(DTemp,nDens) + call DeDe_mck(DTemp,nFck(0),ipOffD,nIndij,Dede,mmDeDe,mDeDe,mIndij) + else + call mma_allocate(ipOffDA,3,nIndij,Label='ipOffDA') + call mma_allocate(DeDe2,mmDeDe+MxDij,label='DeDe2') + ipDijS2 = 1+mmDeDe + + call Dan(DTemp) + call DeDe_mck(DTemp,nFck(0),ipOffD,nIndij,DeDe,mmDeDe,mDeDe,mIndij) + + call Din(DInAc) + call DeDe_mck(DInAc,nFck(0),ipOffDA,nIndij,DeDe2,mmDeDe,mDeDe,mIndij) + + if (mDeDe /= nDeDe) then + write(u6,*) 'DrvG2: mDeDe /= nDeDe' + write(u6,*) 'mDeDe,nDeDe=',mDeDe,nDeDe + call Abend() + end if + end if + end if + + nb = 0 + do is=0,nIrrep-1 + nb = nb+nBas(iS) + end do + +end if ! lGrad +! * +!*********************************************************************** +! * +call Free_iSD() +call Set_Basis_Mode('Valence') +call Nr_Shells(nSkal) +call Setup_iSD() + +nPairs = nTri_Elem(nSkal) +nQuad = nTri_Elem(nPairs) +! * +!*********************************************************************** +! * +! Compute entities for prescreening at shell level + +call mma_allocate(TMax,nSkal,nSkal,Label='TMax') +call Shell_MxSchwz(nSkal,TMax) +TMax_all = Zero +do iS=1,nSkal + do jS=1,iS + TMax_all = max(TMax_all,TMax(iS,jS)) + end do +end do +! * +!*********************************************************************** +! * +! Create list of non-vanishing pairs + +call mma_allocate(Ind_ij,2,nPairs,Label='Ind_ij') +nijS = 0 +do iS=1,nSkal + do jS=1,iS + if (TMax_All*TMax(iS,jS) >= CutInt) then + nijS = nijS+1 + Ind_ij(1,nijS) = iS + Ind_ij(2,nijS) = jS + end if + end do +end do +call Init_Tsk(id_Tsk,nijS) +! * +!*********************************************************************** +! * +call mma_MaxDBLE(MemMax) +if (MemMax > 1000) MemMax = MemMax-1000 +call mma_allocate(Sew_Scr,MemMax-iii,Label='Sew_Scr') +ipMem = 1 +memmax = memmax-iii +! * +!*********************************************************************** +! * +! big loop over individual tasks, distributed over individual nodes + +! make reservation of a task on global task list and get task range +! in return. Function will be false if no more tasks to execute. +do while (Rsv_Tsk(id_Tsk,ijSh)) + iS = Ind_ij(1,ijSh) + jS = Ind_ij(2,ijSh) + call CWTime(TCpu1,TWall1) + ! * + !********************************************************************* + ! * + ! Outer loops (ij) over angular momenta and centers + ! + !do iS=1,nSkal + iShll = iSD(0,iS) + iAng = iSD(1,iS) + iCmp = iSD(2,iS) + iBas = iSD(3,iS) + iPrim = iSD(5,iS) + iAO = iSD(7,iS) + mdci = iSD(10,iS) + iShell = iSD(11,iS) + iCnttp = iSD(13,iS) + iCnt = iSD(14,iS) + Coor(1:3,1) = dbsc(iCnttp)%Coor(1:3,iCnt) + + iAngV(1) = iAng + iShllV(1) = iShll + iCmpV(1) = iCmp + iShelV(1) = iShell + iAOV(1) = iAO + + ! do jS=1,iS + jShll = iSD(0,jS) + jAng = iSD(1,jS) + jCmp = iSD(2,jS) + jBas = iSD(3,jS) + jAO = iSD(7,jS) + mdcj = iSD(10,jS) + jShell = iSD(11,jS) + jCnttp = iSD(13,jS) + jCnt = iSD(14,jS) + Coor(1:3,2) = dbsc(jCnttp)%Coor(1:3,jCnt) + + iAngV(2) = jAng + iShllV(2) = jShll + iCmpV(2) = jCmp + iShelV(2) = jShell + iAOV(2) = jAO + + nHrrab = 0 + do i=0,iAng+1 + do j=0,jAng+1 + if (i+j <= iAng+jAng+1) then + ijMax = min(iAng,jAng)+1 + nHrrab = nHrrab+ijMax*2+1 + end if + end do + end do + ! * + !********************************************************************* + ! * + ! Cltrls for MO transformation + ! * + !********************************************************************* + ! * + if ((nMethod == RASSCF) .and. l_Grd) then + iMemB = nACO**2*iCmp*iBas*jCmp*jBas*nDisp*nirrep + if (iMemB > MemMax) then + write(u6,*) 'DrvG2: iMemB > MemMax' + write(u6,*) 'iMemB=',iMemB + write(u6,*) 'MemMax=',MemMax + write(u6,*) 'Increase MOLCAS_MEM!' + call Abend() + end if + Sew_Scr(1:iMemb) = Zero + else + iMemb = 0 + end if + ! * + !********************************************************************* + ! * + Post_Process = .false. + do klSh=1,nijS + ks = Ind_ij(1,klSh) + ls = Ind_ij(2,klSh) + + A_int = TMax(iS,jS)*TMax(kS,lS) + !write(u6,*) 'is,js,ks,ls=',is,js,ks,ls + if (A_Int < CutInt) cycle + + !do kS=1,nSkal + kShll = iSD(0,kS) + kAng = iSD(1,kS) + kCmp = iSD(2,kS) + kAO = iSD(7,kS) + mdck = iSD(10,kS) + kShell = iSD(11,kS) + kCnttp = iSD(13,kS) + kCnt = iSD(14,kS) + Coor(1:3,3) = dbsc(kCnttp)%Coor(1:3,kCnt) + + iAngV(3) = kAng + iShllV(3) = kShll + iCmpV(3) = kCmp + iShelV(3) = kShell + iAOV(3) = kAO + + Shik = iShell == kShell + + ! do lS=1,kS + lShll = iSD(0,lS) + lAng = iSD(1,lS) + lCmp = iSD(2,lS) + lAO = iSD(7,lS) + mdcl = iSD(10,lS) + lShell = iSD(11,lS) + lCnttp = iSD(13,lS) + lCnt = iSD(14,lS) + Coor(1:3,4) = dbsc(lCnttp)%Coor(1:3,lCnt) + + iAngV(4) = lAng + iShllV(4) = lShll + iCmpV(4) = lCmp + iShelV(4) = lShell + iAOV(4) = lAO + + nHrrcd = 0 + do i=0,kAng+1 + do j=0,lAng+1 + if (i+j <= kAng+lAng+1) then + ijMax = min(kAng,lAng)+1 + nHrrcd = nHrrcd+ijMax*2+1 + end if + end do + end do + ! * + !******************************************************************* + ! * + ! The code is working in such away that the MO needs upper and lower + ! triangular parts of ij kl but hessian needs only lower, check if the + ! integralbatch is lower or upper!! + + lTri = iTri(iS,jS) >= iTri(kS,lS) + if ((.not. lTri) .and. (nMethod /= RASSCF)) cycle + lDot = (lTri .and. l_Hss) + + Shjl = jShell == lShell + Shijij = Shik .and. Shjl + ! * + !******************************************************************* + ! * + iCmpV(1) = icmp + iCmpV(2) = jcmp + iCmpV(3) = kcmp + iCmpV(4) = lcmp + iPrimi = Shells(iShllV(1))%nExp + jPrimj = Shells(iShllV(2))%nExp + kPrimk = Shells(iShllV(3))%nExp + lPriml = Shells(iShllV(4))%nExp + iBasi = Shells(iShllV(1))%nBasis + jBasj = Shells(iShllV(2))%nBasis + kBask = Shells(iShllV(3))%nBasis + lBasl = Shells(iShllV(4))%nBasis + ! * + !******************************************************************* + ! * + ! Allocate memory for zeta, eta, kappa, P and Q. + ! Allocate also for Alpha, Beta , Gamma and Delta in expanded form. + + nZeta = iPrimi*jPrimj + nEta = kPrimk*lPriml + MemR = 9*nZeta+9*nEta+nEta*nZeta + ipZI = ipZeta+nZeta + ipKAB = ipZi+nZeta + ipP = ipKAB+nZeta + ipxA = ipP+nZeta*3 + ipxB = ipxA+nZeta + ipEta = ipxB+nZeta + ipEI = ipEta+nEta + ipKCD = ipEI+nEta + ipQ = ipKCD+nEta + ipxG = ipQ+nEta*3 + ipxD = ipxG+nEta + ipxPre = ipxD+nEta + ! * + !******************************************************************* + ! * + ijS = iTri(iShell,jShell) + klS = iTri(kShell,lShell) + ikS = iTri(iShell,kShell) + ilS = iTri(iShell,lShell) + jkS = iTri(jShell,kShell) + jlS = iTri(jShell,lShell) + k2ij = Indk2(1,ijS) + nDCRR = Indk2(2,ijS) + k2kl = Indk2(1,klS) + nDCRS = Indk2(2,klS) + + if (ltri) then + + !----------------------------------------------------------------* + + ! Fix the 1st order density matrix + + ! Pick up pointers to desymmetrized 1st order density matrices. + ! Observe that the desymmetrized 1st order density matrices + ! follow the contraction index. + + ipTmp = 0 + ipTmp2 = 0 + if (lpick) then + + ipDij = ipOffD(1,ijS) + mDCRij = ipOffD(2,ijS) + nDij = ipOffD(3,ijS) + + ipTmp = ipDijs + if (nMethod == RASSCF) then + ipDij2 = ipOffDA(1,ijS) + ipTmp2 = ipDijs2 + end if + + if (mDCRij /= 0) then + ipDDij = ipTmp + ipTmp = ipTmp+nDij*mDCRij + if (nMethod == RASSCF) then + ipDDij2 = ipTmp2 + ipTmp2 = ipTmp2+nDij*mDCRij + end if + else + ipDDij = 0 + end if + + ipDkl = ipOffD(1,klS) + if (nMethod == RASSCF) ipDkl2 = ipOffDA(1,klS) + mDCRkl = ipOffD(2,klS) + nDkl = ipOffD(3,klS) + if (mDCRkl /= 0) then + ipDDkl = ipTmp + ipTmp = ipTmp+nDkl*mDCRkl + if (nMethod == RASSCF) then + ipDDkl2 = ipTmp2 + ipTmp2 = ipTmp2+nDkl*mDCRkl + end if + else + ipDDkl = 0 + end if + + ipDik = ipOffD(1,ikS) + if (nMethod == RASSCF) ipDik2 = ipOffDA(1,ikS) + mDCRik = ipOffD(2,ikS) + nDik = ipOffD(3,ikS) + if (mDCRik /= 0) then + ipDDik = ipTmp + ipTmp = ipTmp+nDik*mDCRik + if (nMethod == RASSCF) then + ipDDik2 = ipTmp2 + ipTmp2 = ipTmp2+nDik*mDCRik + end if + else + ipDDik = 0 + end if + + ipDil = ipOffD(1,ilS) + if (nMethod == RASSCF) ipDil2 = ipOffDA(1,ilS) + mDCRil = ipOffD(2,ilS) + nDil = ipOffD(3,ilS) + if (mDCRil /= 0) then + ipDDil = ipTmp + ipTmp = ipTmp+nDil*mDCRil + if (nMethod == RASSCF) then + ipDDil2 = ipTmp2 + ipTmp2 = ipTmp2+nDil*mDCRil + end if + else + ipDDil = 0 + end if + + ipDjk = ipOffD(1,jkS) + if (nMethod == RASSCF) ipDjk2 = ipOffDA(1,jkS) + mDCRjk = ipOffD(2,jkS) + nDjk = ipOffD(3,jkS) + if (mDCRjk /= 0) then + ipDDjk = ipTmp + ipTmp = ipTmp+nDjk*mDCRjk + if (nMethod == RASSCF) then + ipDDjk2 = ipTmp2 + ipTmp2 = ipTmp2+nDjk*mDCRjk + end if + else + ipDDjk = 0 + end if + + ipDjl = ipOffD(1,jlS) + if (nMethod == RASSCF) ipDjl2 = ipOffDA(1,jlS) + mDCRjl = ipOffD(2,jlS) + nDjl = ipOffD(3,jlS) + if (mDCRjl /= 0) then + ipDDjl = ipTmp + ipTmp = ipTmp+nDjl*mDCRjl + if (nMethod == RASSCF) then + ipDDjl2 = ipTmp2 + ipTmp2 = ipTmp2+nDjl*mDCRjl + end if + else + ipDDjl = 0 + end if + + end if ! if (lpick) then + end if ! if (ltri) then + ! * + !******************************************************************* + ! * + ! Compute total size of the second order density matrix in SO basis. + ! + !------------------------------------------------------------------* + nSO = MemSO2_P(iCmp,jCmp,kCmp,lCmp,iAOV(1),iAOV(2),iAOV(3),iAOV(4)) + ldot2 = ldot + if (nSO == 0) ldot2 = .false. + + ! Compute memory request for the primitives. + + ider = 2 + if (.not. ldot2) iDer = 1 + call MemRg2(iAngV,nRys,MemPrm,ider) + + !------------------------------------------------------------------* + ! + ! Calculate which derivatives should be made. + ! + !------------------------------------------------------------------* + + call DerCtr(mdci,mdcj,mdck,mdcl,ldot2,JfGrd,JndGrd,JfHss,JndHss,JfG) + + !------------------------------------------------------------------* + ! + ! Decide on the partioning of the shells based on the + ! available memory and the requested memory. + ! + !------------------------------------------------------------------* + + call PSOAO2(nSO,MemPrm,MemMax,iAngV,iCmpV,iAOV,iFnc,iBasi,iBsInc,jBasj,jBsInc,kBask,kBsInc,lBasl,lBsInc,iPrimi,iPrInc,jPrimj, & + jPrInc,kPrimk,kPrInc,lPriml,lPrInc,nAco,Mem1,Mem2,Mem3,Mem4,MemX,MemPSO,MemFck,nFT,memCMO2,MemFin,MemBuffer,iMemB) + + !------------------------------------------------------------------* + ! + ! Loop over basis function if we do not have enough of memory to + ! calculate them in one step. + ! + !------------------------------------------------------------------* + do iBasAO=1,iBasi,iBsInc + iBasn = min(iBsInc,iBasi-iBasAO+1) + iAOst(1) = iBasAO-1 + !----------------------------------------------------------------* + ! + ! Move appropriate portions of the desymmetrized 1st order density matrix. + ! + !----------------------------------------------------------------* + do jBasAO=1,jBasj,jBsInc + jBasn = min(jBsInc,jBasj-jBasAO+1) + iAOst(2) = jBasAO-1 + if (lpick .and. (nDij*mDCRij /= 0)) then + call Picky(DeDe(ipDij),iBasi,jBasj,iPrimi*jPrimj,iCmpV(1)*iCmpV(2),mDCRij,iBasAO,iBasAO+iBasn-1,jBasAO,jBasAO+jBasn-1, & + DeDe(ipDDij)) + if (nMethod == RASSCF) call Picky(DeDe2(ipDij2),iBasi,jBasj,iPrimi*jPrimj,iCmpV(1)*iCmpV(2),mDCRij,iBasAO, & + iBasAO+iBasn-1,jBasAO,jBasAO+jBasn-1,DeDe2(ipDDij2)) + end if + mDij = (iBasn*jBasn+1)*iCmpV(1)*iCmpV(2)+iPrimi*jPrimj+1 + mDij = min(nDij,mDij) + + do kBasAO=1,kBask,kBsInc + kBasn = min(kBsInc,kBask-kBasAO+1) + iAOst(3) = kBasAO-1 + if (lpick .and. (nDik*mDCRik /= 0)) then + call Picky(DeDe(ipDik),iBasi,kBask,iPrimi*kPrimk,iCmpV(1)*iCmpV(3),mDCRik,iBasAO,iBasAO+iBasn-1,kBasAO,kBasAO+kBasn-1, & + DeDe(ipDDik)) + if (nMethod == RASSCF) call Picky(DeDe2(ipDik2),iBasi,kBask,iPrimi*kPrimk,iCmpV(1)*iCmpV(3),mDCRik,iBasAO, & + iBasAO+iBasn-1,kBasAO,kBasAO+kBasn-1,DeDe2(ipDDik2)) + end if + mDik = (iBasn*kBasn+1)*iCmpV(1)*iCmpV(3)+iPrimi*kPrimk+1 + mDik = min(nDik,mDik) + if (lpick .and. (nDjk*mDCRjk /= 0)) then + call Picky(DeDe(ipDjk),jBasj,kBask,jPrimj*kPrimk,iCmpV(2)*iCmpV(3),mDCRjk,jBasAO,jBasAO+jBasn-1,kBasAO,kBasAO+kBasn-1, & + DeDe(ipDDjk)) + if (nMethod == RASSCF) call Picky(DeDe2(ipDjk2),jBasj,kBask,jPrimj*kPrimk,iCmpV(2)*iCmpV(3),mDCRjk,jBasAO, & + jBasAO+jBasn-1,kBasAO,kBasAO+kBasn-1,DeDe2(ipDDjk2)) + end if + mDjk = (jBasn*kBasn+1)*iCmpV(2)*iCmpV(3)+jPrimj*kPrimk+1 + mDjk = min(nDjk,mDjk) + + do lBasAO=1,lBasl,lBsInc + lBasn = min(lBsInc,lBasl-lBasAO+1) + iAOst(4) = lBasAO-1 + if (lpick .and. (nDkl*mDCRkl /= 0)) then + call Picky(DeDe(ipDkl),kBask,lBasl,kPrimk*lPriml,iCmpV(3)*iCmpV(4),mDCRkl,kBasAO,kBasAO+kBasn-1,lBasAO, & + lBasAO+lBasn-1,DeDe(ipDDkl)) + if (nMethod == RASSCF) call Picky(DeDe2(ipDkl2),kBask,lBasl,kPrimk*lPriml,iCmpV(3)*iCmpV(4),mDCRkl,kBasAO, & + kBasAO+kBasn-1,lBasAO,lBasAO+lBasn-1,DeDe2(ipDDkl2)) + end if + mDkl = (kBasn*lBasn+1)*iCmpV(3)*iCmpV(4)+kPrimk*lPriml+1 + mDkl = min(nDkl,mDkl) + if (lpick .and. (nDil*mDCRil /= 0)) then + call Picky(DeDe(ipDil),iBasi,lBasl,iPrimi*lPriml,iCmpV(1)*iCmpV(4),mDCRil,iBasAO,iBasAO+iBasn-1,lBasAO, & + lBasAO+lBasn-1,DeDe(ipDDil)) + if (nMethod == RASSCF) call Picky(DeDe2(ipDil2),iBasi,lBasl,iPrimi*lPriml,iCmpV(1)*iCmpV(4),mDCRil,iBasAO, & + iBasAO+iBasn-1,lBasAO,lBasAO+lBasn-1,DeDe2(ipDDil2)) + end if + mDil = (iBasn*lBasn+1)*iCmpV(1)*iCmpV(4)+iPrimi*lPriml+1 + mDil = min(nDil,mDil) + if (lpick .and. (nDjl*mDCRjl /= 0)) then + call Picky(DeDe(ipDjl),jBasj,lBasl,jPrimj*lPriml,iCmpV(2)*iCmpV(4),mDCRjl,jBasAO,jBasAO+jBasn-1,lBasAO, & + lBasAO+lBasn-1,DeDe(ipDDjl)) + if (nMethod == RASSCF) call Picky(DeDe2(ipDjl2),jBasj,lBasl,jPrimj*lPriml,iCmpV(2)*iCmpV(4),mDCRjl,jBasAO, & + jBasAO+jBasn-1,lBasAO,lBasAO+lBasn-1,DeDe2(ipDDjl2)) + end if + mDjl = (jBasn*lBasn+1)*iCmpV(2)*iCmpV(4)+jPrimj*lPriml+1 + mDjl = min(nDjl,mDjl) + if (.not. lpick) then + ipddjl2 = 0 + ipddil2 = 0 + ipddkl2 = 0 + ipddij2 = 0 + ipddik2 = 0 + ipddjk2 = 0 + end if + + !----------------------------------------------------------* + + MEMCMO = nACO*(kCmp*kBasn+lCmp*lBasn) + ! MO tranformation buffer + ipBuffer = ipMem + ipMOC = ipBuffer+MEMBUFFER + ! Area for the AO integrals + ipFin = ipMOC+MemCMO + ! Area for 2el density + ip_PP = ipFin+MemFin + ipMem2 = ip_PP+Mem1 ! Work + ipMem3 = ipMem2+Mem2 ! Work + ipMemX = ipMem3+Mem3 ! Work + + ! If MO transformation is performed in the standard way + ! reserve memory for partial transfromed integrals + + ! Multilayer + + ipMem4 = ipMem2+Mem2-Mem4 + + !----------------------------------------------------------* + ! + ! Get the 2nd order density matrix in SO basis. + ! + !----------------------------------------------------------* + + nijkl = iBasn*jBasn*kBasn*lBasn + call Timing(dum,Time,Dum,Dum) + if (n8) call PickMO(Sew_Scr(ipMOC),MemCMO,iCmpV,iBasAO,iBasn,jBasAO,jBasn,kBasAO,kBasn,lBasAO,lBasn,iAOV) + if (ldot2) call PGet0(iCmpV,iBasn,jBasn,kBasn,lBasn,Shijij,iAOV,iAOst,nijkl,Sew_Scr(ip_PP),nSO,iFnc(1)*iBasn, & + iFnc(2)*jBasn,iFnc(3)*kBasn,iFnc(4)*lBasn,MemPSO,Sew_Scr(ipMem2),Mem2,iS,jS,kS,lS,nQuad,PMax) + call Timing(dum,Time,Dum,Dum) + CPUStat(nTwoDens) = CPUStat(nTwoDens)+Time + + ! Compute gradients of shell quadruplet + + call TwoEl_mck(Coor,iAngV,iCmpV,iShelV,iShllV,iAOV,iAOst,mdci,mdcj,mdck,mdcl,nRys,Data_k2(k2ij),nDCRR,Data_k2(k2kl), & + nDCRS,Pren,Prem,iPrimi,jPrimj,jPrInc,kPrimk,lPriml,lPrInc,Shells(iShllV(1))%pCff(1,iBasAO),iBasn, & + Shells(iShllV(2))%pCff(1,jBasAO),jBasn,Shells(iShllV(3))%pCff(1,kBasAO),kBasn, & + Shells(iShllV(4))%pCff(1,lBasAO),lBasn,Mem_DBLE(ipZeta),Mem_DBLE(ipZI),Mem_DBLE(ipP),Mem_DBLE(ipKab), & + nZeta,Mem_DBLE(ipEta),Mem_DBLE(ipEI),Mem_DBLE(ipQ),Mem_DBLE(ipKcd),nEta,Mem_DBLE(ipxA),Mem_DBLE(ipxB), & + Mem_DBLE(ipxG),Mem_DBLE(ipxD),Mem_DBLE(ipxPre),Hess,nHess,JfGrd,JndGrd,JfHss,JndHss,JfG,Sew_Scr(ip_PP), & + nSO,Sew_Scr(ipMem2),Mem2,Sew_Scr(ipMem3),Mem3,Sew_Scr(ipMem4),Mem4,Aux,nAux,Sew_Scr(ipMemX),MemX, & + Shijij,DeDe(ipDDij),DeDe2(ipDDij2),mDij,mDCRij,DeDe(ipDDkl),DeDe2(ipDDkl2),mDkl,mDCRkl,DeDe(ipDDik), & + DeDe2(ipDDik2),mDik,mDCRik,DeDe(ipDDil),DeDe2(ipDDil2),mDil,mDCRil,DeDe(ipDDjk),DeDe2(ipDDjk2),mDjk, & + mDCRjk,DeDe(ipDDjl),DeDe2(ipDDjl2),mDjl,mDCRjl,iCmpV,Sew_Scr(ipFin),MemFin,Sew_Scr(ipMem2), & + Mem2+Mem3+MemX,nTwo2,nFT,Mem_INT(ipIndEta),Mem_INT(ipIndZet),iInt,Sew_Scr(ipBuffer),MemBuffer,lgrad, & + ldot2,n8,ltri,DTemp,DInAc,moip,nAco,Sew_Scr(ipMOC),MemCMO,new_fock) + Post_Process = .true. + + !----------------------------------------------------------* + + end do + end do + end do + end do + + ! end do ! lS + !end do ! kS + end do ! klS + + if ((nMethod == RASSCF) .and. Post_Process) then + ip1 = ipMOC + ip2 = ip1+iCmp*iBas*naco + ip3 = ip2+nAco**2 + ip4 = ip3+jcmp*jBas*naco + ip5 = ip4+iCmp*naco*iBas + ip6 = ip5+jcmp*jbas*naco + call CLR2(Sew_Scr(ipBuffer),iInt,ibas,icmp,jbas,jcmp,iAOV(1),iAOV(2),naco,ishelV,Sew_Scr(ip1),Sew_Scr(ip2),Sew_Scr(ip3), & + Sew_Scr(ip4),Sew_Scr(ip5),Sew_Scr(ip6)) + end if + + ! end do ! jS + !end do ! iS + + call CWTime(TCpu2,TWall2) + call SavTim(4,TCpu2-TCpu1,TWall2-Twall1) + call SavStat(1,One,'+') + call SavStat(2,real(nijs,kind=wp),'+') +end do +! End of big task loop +! * +!*********************************************************************** +! * +! EPILOGUE +! * +!*********************************************************************** +! * +if (New_Fock) then + idd = 0 + do iS=0,nirrep-1 + do iD=1,ldisp(is) + idd = idd+1 + ip = ipDisp(idd) + iInt(ip:ip+nDens-1) = Half*iInt(ip:ip+nDens-1) + ij = ip-1 + do i=1,nBas(0) + ij = ij+i + iInt(ij) = Two*iInt(ij) + end do + end do + end do + if (nmethod == RASSCF) then + idd = 0 + do iS=0,nirrep-1 + do iD=1,ldisp(is) + idd = idd+1 + ip = ipDisp2(idd) + iInt(ip:ip+nDens-1) = Half*iInt(ip:ip+nDens-1) + ij = ip-1 + do i=1,nBas(0) + ij = ij+i + iInt(ij) = Two*iInt(ij) + end do + end do + end do + + end if +end if +#ifdef _DEBUGPRINT_ +call GADSum_SCAL(Pren) +call GADSum_SCAL(Prem) +write(frmt,'(A,I2,A,I2,A)') '(A,F',3+iInt(log10(Pren)),'.0,A,F',3+iInt(log10(Prem)),'.0,A)' +write(u6,frmt) ' A total of',Pren,' entities were prescreened and',Prem,' were kept.' +#endif +call mma_deallocate(Sew_Scr) +call Free_Tsk(id_Tsk) + +! YIPPIEEEE Finished OK fill it UP!! + +call GADSum(iInt,n_Int) +jDisp = 0 +do iIrr=0,nIrrep-1 + do iDisk=1,lDisp(iIrr) + jDisp = jDisp+1 + call WrDisk(iInt,n_Int,jDisp,iIrr) + end do +end do + +call mma_deallocate(Ind_ij) +call mma_deallocate(TMax) +call Free_iSD() + +if (.not. New_Fock) then + call mma_deallocate(ipOffD) + call mma_deallocate(DeDe) + if (nMethod == RASSCF) then + call mma_deallocate(DeDe2) + call mma_deallocate(ipOffDA) + end if +end if + +call mma_deallocate(Mem_DBLE) +call mma_deallocate(Mem_INT) + +call mma_deallocate(DInAc) +call mma_deallocate(DTemp) +call mma_deallocate(iInt) + +call mma_deallocate(Aux) + +! Generate statistic of partioning + +call mma_deallocate(IndK2) +call mma_deallocate(Data_k2) + +if (allocated(ipDisp)) call mma_deallocate(ipDisp) +if (allocated(ipDisp2)) call mma_deallocate(ipDisp2) +if (allocated(ipDisp3)) call mma_deallocate(ipDisp3) +if (allocated(ipMO)) call mma_deallocate(ipMO) + +return + +end subroutine Drvg2 diff -Nru openmolcas-22.02/src/mckinley/drvh1_mck.f openmolcas-22.10/src/mckinley/drvh1_mck.f --- openmolcas-22.02/src/mckinley/drvh1_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/drvh1_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,199 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -* 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine Drvh1_mck(nGrad,Nona) -************************************************************************ -* * -* Object: driver for computation of gradients of one-electron matrices.* -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* January '91 * -* Modified by Anders Bernhardsson for Gradients * -* May 95 * -************************************************************************ - Use Basis_Info - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) - External OvrGrd_mck,KneGrd_mck,nagrd_mck,prjgrd_mck,m1grd_mck , - & srogrd_mck, nona2 - External OvrMem_mck,KneMem_mck,namem_mck,prjmm1,m1mm1, na2mem, - & sromm1 -#include "real.fh" -#include "stdalloc.fh" -#include "print.fh" - Character*8 Label - Logical Nona, lECP - Real*8, Allocatable:: Fock(:), D0(:) -* - If (show) Then - nFock = 0 - nDens = 0 - Do 1 iIrrep = 0, nIrrep - 1 - nFock = nFock + nBas(iIrrep)*(nBas(iIrrep)+1)/2 - nDens = nDens + nBas(iIrrep)*(nBas(iIrrep)+1)/2 - 1 Continue -* -*... Read the variational 1st order density matrix -*... density matrix in AO/SO basis - Call mma_allocate(D0,nDens,Label='D0') - Call Get_D1ao_Var(D0,nDens) -*... Read the generalized Fock matrix -*... Fock matrix in AO/SO basis - Call mma_allocate(Fock,nFock,Label='Fock') - Call Get_Fock_Occ(Fock,nFock) - Else - nFock = 1 - nDens = 1 - Call mma_allocate(Fock,nFock,Label='Fock') - Call mma_allocate(D0,nDens,Label='D0') - Fock(1)=Zero - D0(1)=Zero - End If - If (Nona) Then -************************************************************************ -*0a) * -* * -* Antisymmetric gradient of Overlap matrix * -* * -************************************************************************ - Label='OVRGRDA ' - idcnt=0 - Do iCnttp=1,nCnttp - Do iCnt=1,dbsc(iCnttp)%nCntr - idcnt=idcnt+1 - Do idCar=1,3 - Call Cnt1El(OvrGrd_mck,OvrMem_mck,Label,idcnt,idcar,loper, - & -One,.false.,Fock,'OVRGRDA ',0) - End Do - End Do - End Do -************************************************************************ -*0b) * -* * -* Non-adiabatic second derivative integrals * -* * -************************************************************************ - Label='NONA2 ' - idcnt=0 - Do iCnttp=1,nCnttp - Do iCnt=1,dbsc(iCnttp)%nCntr - idcnt=idcnt+1 - Do idCar=1,3 - Call Cnt1El(NONA2,NA2Mem,Label,idcnt,idcar,loper, - & One,.false.,Fock,'NONA2 ',0) - End Do - End Do - End Do -* - End If -* -************************************************************************ -*1) * -* * -* Gradient of Overlap matrix * -* * -************************************************************************ - Label='OVRGRD ' - idcnt=0 - Do iCnttp=1,nCnttp - Do iCnt=1,dbsc(iCnttp)%nCntr - idcnt=idcnt+1 - Do idCar=1,3 - Call Cnt1El(OvrGrd_mck,OvrMem_mck,Label,idcnt,idcar,loper, - & One,.false.,Fock,'OVRGRD ',0) - End Do - End Do - End Do -* -************************************************************************ -*2) * -* * -* Gradient of Kinetic operator * -* * -* * -************************************************************************ - Label='KNEGRD ' - idcnt=0 - Do iCnttp=1,nCnttp - Do iCnt=1,dbsc(iCnttp)%nCntr - idcnt=idcnt+1 - Do idCar=1,3 - Call Cnt1El(KneGrd_mck,KneMem_mck,Label,idcnt,idcar,loper, - & One,.false.,D0,'ONEGRD ',0) - End Do - End Do - End Do -* -************************************************************************ -*3) * -* * -* Gradient of Nuclear attraction Operator * -* * -* * -************************************************************************ - Label='NAGRD ' - idcnt=0 - Do iCnttp=1,nCnttp - Do iCnt=1,dbsc(iCnttp)%nCntr - idcnt=idcnt+1 - Do idCar=1,3 - Call Cnt1El(NaGrd_mck,NaMem_mck,Label,idcnt,idcar,loper, - & One,.true.,D0,'ONEGRD ',1) - End Do - End Do - End Do -* -* -************************************************************************ -*3) * -* * -* Gradient of Nuclear attraction Operator ECP-part * -* * -* * -************************************************************************ - lECP = .False. - DO i = 1, nCnttp - lECP = lECP .or. dbsc(i)%ECP - End Do - If (lecp) Then - idcnt=0 - Do iCnttp=1,nCnttp - Do iCnt=1,dbsc(iCnttp)%nCntr - idcnt=idcnt+1 - Do idCar=1,3 - Label='PRJGRD ' - Call Cnt1El(Prjgrd_mck,PrjMm1,Label,idcnt,idcar,loper, - & One,.true.,D0,'ONEGRD ',1) - Label='M1GRD ' - Call Cnt1El(m1grd_mck,m1Mm1,Label,idcnt,idcar,loper, - & One,.true.,D0,'ONEGRD ',1) - Label='SROGRD ' - Call Cnt1El(Srogrd_mck,sroMm1,Label,idcnt,idcar,loper, - & One,.true.,D0,'ONEGRD ',1) - End Do - End Do - End Do - End if -* * -************************************************************************ -* * - Call mma_deallocate(D0) - Call mma_deallocate(Fock) -* * -************************************************************************ -* * - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(nGrad) - End diff -Nru openmolcas-22.02/src/mckinley/drvh1_mck.F90 openmolcas-22.10/src/mckinley/drvh1_mck.F90 --- openmolcas-22.02/src/mckinley/drvh1_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/drvh1_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,188 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine Drvh1_mck(Nona) +!*********************************************************************** +! * +! Object: driver for computation of gradients of one-electron matrices.* +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! January '91 * +! Modified by Anders Bernhardsson for Gradients * +! May 95 * +!*********************************************************************** + +use mck_interface, only: grd_mck_kernel, mck_mem +use Index_Functions, only: nTri_Elem +use Basis_Info, only: dbsc, nBas, nCnttp +use Symmetry_Info, only: nIrrep +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +logical(kind=iwp), intent(in) :: Nona +#include "print.fh" +integer(kind=iwp) :: i, iCnt, iCnttp, idCar, idcnt, iIrrep, loper, nDens, nFock +character(len=8) :: Label +logical(kind=iwp) :: lECP +real(kind=wp), allocatable :: D0(:), Fock(:) +procedure(grd_mck_kernel) :: KneGrd_mck, m1grd_mck, nagrd_mck, nonatwo, OvrGrd_mck, prjgrd_mck, srogrd_mck +procedure(mck_mem) :: KneMem_mck, m1mm1, na2mem, namem_mck, OvrMem_mck, prjmm1, sromm1 + +if (show) then + nFock = 0 + nDens = 0 + do iIrrep=0,nIrrep-1 + nFock = nFock+nTri_Elem(nBas(iIrrep)) + nDens = nDens+nTri_Elem(nBas(iIrrep)) + end do + + ! Read the variational 1st order density matrix + ! density matrix in AO/SO basis + call mma_allocate(D0,nDens,Label='D0') + call Get_D1ao_Var(D0,nDens) + ! Read the generalized Fock matrix + ! Fock matrix in AO/SO basis + call mma_allocate(Fock,nFock,Label='Fock') + call Get_Fock_Occ(Fock,nFock) +else + nFock = 1 + nDens = 1 + call mma_allocate(Fock,nFock,Label='Fock') + call mma_allocate(D0,nDens,Label='D0') + Fock(1) = Zero + D0(1) = Zero +end if +if (Nona) then + !********************************************************************* + !0a) * + ! Antisymmetric gradient of Overlap matrix * + ! * + !********************************************************************* + Label = 'OVRGRDA' + idcnt = 0 + do iCnttp=1,nCnttp + do iCnt=1,dbsc(iCnttp)%nCntr + idcnt = idcnt+1 + do idCar=1,3 + call Cnt1El(OvrGrd_mck,OvrMem_mck,Label,idcnt,idcar,loper,-One,.false.,Fock,'OVRGRDA ',0) + end do + end do + end do + !********************************************************************* + !0b) * + ! Non-adiabatic second derivative integrals * + ! * + !********************************************************************* + Label = 'NONA2' + idcnt = 0 + do iCnttp=1,nCnttp + do iCnt=1,dbsc(iCnttp)%nCntr + idcnt = idcnt+1 + do idCar=1,3 + call Cnt1El(NONATWO,NA2Mem,Label,idcnt,idcar,loper,One,.false.,Fock,'NONA2 ',0) + end do + end do + end do + +end if + +!*********************************************************************** +!1) * +! Gradient of Overlap matrix * +! * +!*********************************************************************** +Label = 'OVRGRD' +idcnt = 0 +do iCnttp=1,nCnttp + do iCnt=1,dbsc(iCnttp)%nCntr + idcnt = idcnt+1 + do idCar=1,3 + call Cnt1El(OvrGrd_mck,OvrMem_mck,Label,idcnt,idcar,loper,One,.false.,Fock,'OVRGRD ',0) + end do + end do +end do +! +!*********************************************************************** +!2) * +! Gradient of Kinetic operator * +! * +!*********************************************************************** +Label = 'KNEGRD' +idcnt = 0 +do iCnttp=1,nCnttp + do iCnt=1,dbsc(iCnttp)%nCntr + idcnt = idcnt+1 + do idCar=1,3 + call Cnt1El(KneGrd_mck,KneMem_mck,Label,idcnt,idcar,loper,One,.false.,D0,'ONEGRD ',0) + end do + end do +end do +! +!*********************************************************************** +!3) * +! Gradient of Nuclear attraction Operator * +! * +!*********************************************************************** +Label = 'NAGRD' +idcnt = 0 +do iCnttp=1,nCnttp + do iCnt=1,dbsc(iCnttp)%nCntr + idcnt = idcnt+1 + do idCar=1,3 + call Cnt1El(NaGrd_mck,NaMem_mck,Label,idcnt,idcar,loper,One,.true.,D0,'ONEGRD ',1) + end do + end do +end do +! +! +!*********************************************************************** +!3) * +! Gradient of Nuclear attraction Operator ECP-part * +! * +!*********************************************************************** +lECP = .false. +do i=1,nCnttp + lECP = lECP .or. dbsc(i)%ECP +end do +if (lecp) then + idcnt = 0 + do iCnttp=1,nCnttp + do iCnt=1,dbsc(iCnttp)%nCntr + idcnt = idcnt+1 + do idCar=1,3 + Label = 'PRJGRD' + call Cnt1El(Prjgrd_mck,PrjMm1,Label,idcnt,idcar,loper,One,.true.,D0,'ONEGRD ',1) + Label = 'M1GRD' + call Cnt1El(m1grd_mck,m1Mm1,Label,idcnt,idcar,loper,One,.true.,D0,'ONEGRD ',1) + Label = 'SROGRD' + call Cnt1El(Srogrd_mck,sroMm1,Label,idcnt,idcar,loper,One,.true.,D0,'ONEGRD ',1) + end do + end do + end do +end if +! * +!*********************************************************************** +! * +call mma_deallocate(D0) +call mma_deallocate(Fock) +! * +!*********************************************************************** +! * + +return + +end subroutine Drvh1_mck diff -Nru openmolcas-22.02/src/mckinley/drvh2.f openmolcas-22.10/src/mckinley/drvh2.f --- openmolcas-22.02/src/mckinley/drvh2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/drvh2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,201 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -* 1991, Anders Bernhardsson * -************************************************************************ - SubRoutine Drvh2(Hess,Temp,nHess,show) -************************************************************************ -* * -* Object: driver for computation of gradient with respect to the one- * -* electron hamiltonian and the overlap matrix. The former will * -* be contracted with the "variational" first order density * -* matrix and the latter will be contracted with the generalized* -* Fock matrix. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* October '91 * -* Anders Bernhardsson Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* October '91 * -************************************************************************ - use Basis_Info, only: nCnttp, dbsc, nBas - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) - External NaHss,OvrHss, KneHss,PrjHss,SROHss,M1Hss,PCMHss - External NaMmH,OvrMmH, KneMmH,PrjMMH,sroMMH,M1MMH,PCMMMH -#include "real.fh" -#include "stdalloc.fh" -#include "rctfld.fh" - Character Label*80 - Real*8 Hess(nHess), Temp(nHess) - Logical DiffOp,show, lECP - Real*8, Allocatable:: Fock(:), D0(:), Coor(:,:) - Integer, Allocatable:: lOper(:) -* * -************************************************************************ -* * - Call CWTime(TCpu1,TWall1) - Call StatusLine(' McKinley:', - & ' Computing 1-electron 2rd order derivatives') -* * -************************************************************************ -* * -* Get the variational density matrix and the occupied Fock matrix. -* - nFock = 0 - nDens = 0 - Do iIrrep = 0, nIrrep - 1 - nFock = nFock + nBas(iIrrep)*(nBas(iIrrep)+1)/2 - nDens = nDens + nBas(iIrrep)*(nBas(iIrrep)+1)/2 - End Do -* -* Read the variational 1st order density matrix -* density matrix in AO/SO basis - Call mma_allocate(D0,nDens,Label='D0') - Call Get_D1ao_Var(D0,nDens) -* Read the generalized Fock matrix -* Fock matrix in AO/SO basis - Call mma_allocate(Fock,nFock,Label='Fock') - Call Get_Fock_Occ(Fock,nFock) -* * -************************************************************************ -* * -*... Prologue - nComp = 1 - Call mma_allocate(Coor,3,nComp,Label='Coor') - Coor(:,:)=Zero - Call mma_allocate(lOper,nComp,Label='lOper') - lOper(:) = 1 -************************************************************************ -*1) * -* Trace the generalized Fock matrix with the gradient of the * -* overlap matrix. * -* * -************************************************************************ -* - DiffOp = .False. - Temp(:)=Zero - Label = ' The Renormalization Contribution' - Call Dot1El(OvrHss,OvrMmH,Temp,nHess,DiffOp,Coor, - & Fock,nFock,lOper,nComp,Label) - If (show) write(6,*) label - If (show) Call HssPrt(Hess,nHess) - Hess(:) = Hess(:) - Temp(:) -* -************************************************************************ -*2) * -* Trace the "variational" zero order density matrix with the * -* gradient of the kinetic energy integrals. * -* * -************************************************************************ -* - DiffOp = .False. - Temp(:)=Zero - Label = ' The Kinetic Energy Contribution' - Call Dot1El(KneHss,KneMmH,Temp,nHess,DiffOp,Coor, - & D0,nFock,lOper,nComp,Label) - If (show) write(6,*) label - If (show) Call HssPrt(Temp,nHess) - Hess(:) = Hess(:) - Temp(:) -* -************************************************************************ -*3) * -* Trace the "variational" zero order density matrix with the * -* gradient of the nuclear attraction integrals. * -* * -************************************************************************ -* - DiffOp = .True. - Label = ' The Nuclear Attraction Contribution' - Temp(:)=Zero - Call Dot1El(NAHss,NAMmH,Temp,nHess,DiffOp,Coor, - & D0,nFock,lOper,nComp,Label) - If (show) write(6,*) label - if (show) Call HssPrt(Temp,nHess) - Hess(:) = Hess(:) + Temp(:) -* -************************************************************************ -*3) * -* Trace the "variational" zero order density matrix with the * -* gradient of the ECP integrals. * -* * -************************************************************************ -* - lECP = .False. - DO i = 1, nCnttp - lECP = lECP .or. dbsc(i)%ECP - End Do - If (lECP) Then - DiffOp = .True. - Label = ' The Projection (ECP) Contribution' - Temp(:)=Zero - Call Dot1El(PrjHss,PRJMMH,Temp,nHess,DiffOp,Coor, - & D0,nFock,lOper,nComp,Label) - If (show) write(6,*) label - if (show) Call HssPrt(Temp,nHess) - Hess(:) = Hess(:) + Temp(:) -* - DiffOp = .True. - Label = ' The Spec. Res. (ECP) Contribution' - Temp(:)=Zero - Call Dot1El(SROHss,SROMMH,Temp,nHess,DiffOp,Coor, - & D0,nFock,lOper,nComp,Label) - if (show) Write(6,*) Label,'first part ' - if (show) Call HssPrt(Temp,nHess) - Hess(:) = Hess(:) + Temp(:) -* - DiffOp = .True. - Label = ' The M1 (ECP) Contribution' - Temp(:)=Zero - Call Dot1El(m1Hss,m1MMH,Temp,nHess,DiffOp,Coor, - & D0,nFock,lOper,nComp,Label) - if (show) Write(6,*) Label,'second part ' - if (show) Call HssPrt(Temp,nHess) - Hess(:) = Hess(:) + Temp(:) - End If -* -************************************************************************ -*4) * -* Trace the "variational" zero order density matrix with the * -* gradient of the PCM integrals. * -* * -************************************************************************ -* - If (PCM) Then - DiffOp = .True. - Label = ' The PCM Contribution' - Temp(:)=Zero - Call Dot1El(PCMHss,PCMMMH,Temp,nHess,DiffOp,Coor, - & D0,nFock,lOper,nComp,Label) - If (show) write(6,*) label - if (show) Call HssPrt(Temp,nHess) - Hess(:) = Hess(:) + Temp(:) - End If -* * -************************************************************************ -* * -* Epilogue, end -* * -************************************************************************ -* * - Call mma_deallocate(lOper) - Call mma_deallocate(Coor) - Call mma_deallocate(Fock) - Call mma_deallocate(D0) - If (Show) Call HssPrt(Hess,nHess) -* * -************************************************************************ -* * - Call CWTime(TCpu2,TWall2) - Call SavTim(3,TCpu2-TCpu1,TWall2-TWall1) - Return - End diff -Nru openmolcas-22.02/src/mckinley/drvh2.F90 openmolcas-22.10/src/mckinley/drvh2.F90 --- openmolcas-22.02/src/mckinley/drvh2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/drvh2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,205 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +! 1991, Anders Bernhardsson * +!*********************************************************************** + +subroutine Drvh2(Hess,Temp,nHess,show) +!*********************************************************************** +! * +! Object: driver for computation of gradient with respect to the one- * +! electron hamiltonian and the overlap matrix. The former will * +! be contracted with the "variational" first order density * +! matrix and the latter will be contracted with the generalized* +! Fock matrix. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! October '91 * +! Anders Bernhardsson Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! October '91 * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem +use Basis_Info, only: dbsc, nCnttp, nBas +use Symmetry_Info, only: nIrrep +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nHess +real(kind=wp), intent(inout) :: Hess(nHess) +real(kind=wp), intent(out) :: Temp(nHess) +logical(kind=iwp), intent(in) :: show +#include "rctfld.fh" +integer(kind=iwp) :: i, iIrrep, nComp, nDens, nFock +real(kind=wp) :: TCpu1, TCpu2, TWall1, TWall2 +character(len=80) :: Label +logical(kind=iwp) :: DiffOp, lECP +integer(kind=iwp), allocatable :: lOper(:) +real(kind=wp), allocatable :: Coor(:,:), D0(:), Fock(:) +external :: KneHss, KneMmH, M1Hss, m1MMH, NaHss, NaMmH, OvrHss, OvrMmH, PCMHss, PCMMMH, PrjHss, PrjMMH, SROHss, sroMMH + +! * +!*********************************************************************** +! * +call CWTime(TCpu1,TWall1) +call StatusLine(' McKinley:',' Computing 1-electron 2rd order derivatives') +! * +!*********************************************************************** +! * +! Get the variational density matrix and the occupied Fock matrix. + +nFock = 0 +nDens = 0 +do iIrrep=0,nIrrep-1 + nFock = nFock+nTri_Elem(nBas(iIrrep)) + nDens = nDens+nTri_Elem(nBas(iIrrep)) +end do + +! Read the variational 1st order density matrix +! density matrix in AO/SO basis +call mma_allocate(D0,nDens,Label='D0') +call Get_D1ao_Var(D0,nDens) +! Read the generalized Fock matrix +! Fock matrix in AO/SO basis +call mma_allocate(Fock,nFock,Label='Fock') +call Get_Fock_Occ(Fock,nFock) +! * +!*********************************************************************** +! * +! Prologue +nComp = 1 +call mma_allocate(Coor,3,nComp,Label='Coor') +Coor(:,:) = Zero +call mma_allocate(lOper,nComp,Label='lOper') +lOper(:) = 1 +!*********************************************************************** +!1) * +! Trace the generalized Fock matrix with the gradient of the * +! overlap matrix. * +! * +!*********************************************************************** + +DiffOp = .false. +Temp(:) = Zero +Label = ' The Renormalization Contribution' +call Dot1El(OvrHss,OvrMmH,Temp,nHess,DiffOp,Coor,Fock,nFock,lOper,nComp) +if (show) write(u6,*) label +if (show) call HssPrt(Temp,nHess) +Hess(:) = Hess(:)-Temp(:) + +!*********************************************************************** +!2) * +! Trace the "variational" zero order density matrix with the * +! gradient of the kinetic energy integrals. * +! * +!*********************************************************************** + +DiffOp = .false. +Temp(:) = Zero +Label = ' The Kinetic Energy Contribution' +call Dot1El(KneHss,KneMmH,Temp,nHess,DiffOp,Coor,D0,nFock,lOper,nComp) +if (show) write(u6,*) label +if (show) call HssPrt(Temp,nHess) +Hess(:) = Hess(:)-Temp(:) + +!*********************************************************************** +!3) * +! Trace the "variational" zero order density matrix with the * +! gradient of the nuclear attraction integrals. * +! * +!*********************************************************************** + +DiffOp = .true. +Label = ' The Nuclear Attraction Contribution' +Temp(:) = Zero +call Dot1El(NAHss,NAMmH,Temp,nHess,DiffOp,Coor,D0,nFock,lOper,nComp) +if (show) write(u6,*) label +if (show) call HssPrt(Temp,nHess) +Hess(:) = Hess(:)+Temp(:) + +!*********************************************************************** +!3) * +! Trace the "variational" zero order density matrix with the * +! gradient of the ECP integrals. * +! * +!*********************************************************************** + +lECP = .false. +do i=1,nCnttp + lECP = lECP .or. dbsc(i)%ECP +end do +if (lECP) then + DiffOp = .true. + Label = ' The Projection (ECP) Contribution' + Temp(:) = Zero + call Dot1El(PrjHss,PRJMMH,Temp,nHess,DiffOp,Coor,D0,nFock,lOper,nComp) + if (show) write(u6,*) label + if (show) call HssPrt(Temp,nHess) + Hess(:) = Hess(:)+Temp(:) + + DiffOp = .true. + Label = ' The Spec. Res. (ECP) Contribution' + Temp(:) = Zero + call Dot1El(SROHss,SROMMH,Temp,nHess,DiffOp,Coor,D0,nFock,lOper,nComp) + if (show) write(u6,*) Label,'first part ' + if (show) call HssPrt(Temp,nHess) + Hess(:) = Hess(:)+Temp(:) + + DiffOp = .true. + Label = ' The M1 (ECP) Contribution' + Temp(:) = Zero + call Dot1El(m1Hss,m1MMH,Temp,nHess,DiffOp,Coor,D0,nFock,lOper,nComp) + if (show) write(u6,*) Label,'second part ' + if (show) call HssPrt(Temp,nHess) + Hess(:) = Hess(:)+Temp(:) +end if + +!*********************************************************************** +!4) * +! Trace the "variational" zero order density matrix with the * +! gradient of the PCM integrals. * +! * +!*********************************************************************** + +if (PCM) then + DiffOp = .true. + Label = ' The PCM Contribution' + Temp(:) = Zero + call Dot1El(PCMHss,PCMMMH,Temp,nHess,DiffOp,Coor,D0,nFock,lOper,nComp) + if (show) write(u6,*) label + if (show) call HssPrt(Temp,nHess) + Hess(:) = Hess(:)+Temp(:) +end if +! * +!*********************************************************************** +! * +! Epilogue, end +! * +!*********************************************************************** +! * +call mma_deallocate(lOper) +call mma_deallocate(Coor) +call mma_deallocate(Fock) +call mma_deallocate(D0) +if (Show) call HssPrt(Hess,nHess) +! * +!*********************************************************************** +! * +call CWTime(TCpu2,TWall2) +call SavTim(3,TCpu2-TCpu1,TWall2-TWall1) + +return + +end subroutine Drvh2 diff -Nru openmolcas-22.02/src/mckinley/drvk2_mck.f openmolcas-22.10/src/mckinley/drvk2_mck.f --- openmolcas-22.02/src/mckinley/drvk2_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/drvk2_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,259 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990-1992, Roland Lindh * -* 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine Drvk2_mck(mdede,New_Fock) -************************************************************************ -* * -* Object: to precompute all pair entites as zeta, kappa, P. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* June '91, modified for k2 loop. * -* January '92, modified to gradient calculations. * -* April '92, modified to use the Cauchy-Schwarz inequality * -* to estimate the integral derivatives. * -* Modified 1995 for 2nd derivatives by AB * -************************************************************************ - use k2_setup - use k2_arrays - use iSD_data - use Basis_Info - use Symmetry_Info, only: nIrrep, iOper - use Sizes_of_Seward, only: S - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "ndarray.fh" -#include "real.fh" -#include "disp.fh" -#include "disp2.fh" -#include "stdalloc.fh" -#include "nsd.fh" -#include "setup.fh" - Real*8 Coor(3,2) - Integer iDCRR(0:7), iShllV(2), iAngV(4), iCmpV(4) - Logical New_fock - Real*8, Allocatable :: Data_k2_local(:), Con(:), Wrk(:) -* * -************************************************************************ -* * -*-----Statement functions -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* * -************************************************************************ -* * - Call CWTime(TCpu1,TWall1) - Call mma_MaxDBLE(Maxk2) - maxk2 = maxk2 / 2 - Call mma_allocate(Data_k2_local,Maxk2) - jpk2 = 1 - nk2 = 0 - mdede=0 - mk2 = 0 -* - DoGrad_=.False. - DoHess_=.True. -* * -************************************************************************ -* * - Call Nr_Shells(nSkal) -* * -************************************************************************ -* * - Call mma_allocate(Con,S%m2Max,Label='Con') -* * -************************************************************************ -* * - MemTmp=0 - Do iAng = 0, S%iAngMx - MemTmp=Max(MemTmp,(S%MaxPrm(iAng)*nElem(iAng))**2) - End Do -* * -************************************************************************ -* * - Call mma_MaxDBLE(MaxMem) - Call mma_allocate(Wrk,MaxMem,Label='Wrk') - ipM001=1 -* * -************************************************************************ -* * - Do iS = 1, nSkal - iShll = iSD( 0,iS) - iAng = iSD( 1,iS) - iCmp = iSD( 2,iS) - iBas = iSD( 3,iS) - iPrim = iSD( 5,iS) - iAO = iSD( 7,iS) - mdci = iSD(10,iS) - iShell = iSD(11,iS) - iCnttp = iSD(13,iS) - iCnt = iSD(14,iS) - Coor(1:3,1)=dbsc(iCnttp)%Coor(1:3,iCnt) -* - iAngV(1) = iAng - iShllV(1) = iShll - iCmpV(1) = (iAng+1)*(iAng+2)/2 -* - Do jS = 1, iS - jShll = iSD( 0,jS) - jAng = iSD( 1,jS) - jCmp = iSD( 2,jS) - jBas = iSD( 3,jS) - jPrim = iSD( 5,jS) - jAO = iSD( 7,jS) - mdcj = iSD(10,jS) - jShell = iSD(11,jS) - jCnttp = iSD(13,jS) - jCnt = iSD(14,jS) - Coor(1:3,2)=dbsc(jCnttp)%Coor(1:3,jCnt) -* - iAngV(2) = jAng - iShllV(2) = jShll - iCmpV(2) = (jAng+1)*(jAng+2)/2 -* -*-------Compute FLOP's for the transfer equation. -* - Call mHrr(iAng ,jAng ,nHrrab,nMemab) - ijCmp = nElem(iAng)*nElem(jAng) -* - iPrimi = iPrim - jPrimj = jPrim - nBasi = Shells(iShllV(1))%nBasis - nBasj = Shells(iShllV(2))%nBasis -* - kPrimk = 1 - lPriml = 1 - iBasi = iPrimi - jBasj = jPrimj - kBask = 1 - lBasl = 1 -* - nZeta = iPrimi * jPrimj -* - Call ConMax(Con,iPrimi,jPrimj, - & Shells(iShll)%pCff,nBasi, - & Shells(jShll)%pCff,nBasj) -* - Call ICopy(2,iAngV,1,iAngV(3),1) - Call ICopy(2,iCmpV,1,iCmpV(3),1) -* - If (iShell.ge.jShell) Then - ijShll = iShell*(iShell-1)/2 + jShell - Else - ijShll = jShell*(jShell-1)/2 + iShell - End If -* - nSO = 1 -* -*-----------Compute memory request for the primitives, i.e. -* how much memory is needed up to the transfer -* equation. -* - Call MemRys(iAngV,MemPrm) -* -*-----------Decide on the partioning of the shells based on -* the available memory and the requested memory. -* - Call PSOAO0_h(nSO,nMemab,nMemab,MemPrm, - & MaxMem,iAngV,iCmpV, - & iBasi,iBsInc,jBasj,jBsInc, - & kBask,kBsInc,lBasl,lBsInc, - & iPrimi,iPrInc,jPrimj,jPrInc, - & kPrimk,kPrInc,lPriml,lPrInc, - & ipM001,ipM002,ipM003,ipM004, ipM00d, - & M001, M002, M003, M004, M00d) - If (iBasi.ne.iBsInc .or.jBasj.ne.jBsInc) Then - Write (6,*) - & 'Drvk2: iBasi.ne.iBsInc .or.jBasj.ne.jBsInc' - Write (6,*) 'iBasi,iBsInc=',iBasi,iBsInc - Write (6,*) 'jBasj,jBsInc=',jBasj,jBsInc - Call Abend() - End If -* -*-----------Find the Double Coset Representatives -* for center A and B. -* - iDCRR(0:nIrrep-1)=iOper(0:nIrrep-1) - nDCRR=nIrrep -* -*---------- Compute all pair entities (zeta, kappa, Px, Py, -* Pz, ZInv, alpha, beta, [nm|nm] and derivative -* entity, a total of ten different entities) for -* all possible unique pairs of centers generated -* for the symmetry unique centers A and B. -* - Call k2Loop_mck(Coor, - & iAngV,iCmpV, - & iDCRR,nDCRR,Data_k2_local(jpk2), - & ijCmp, - & Shells(iShllV(1))%Exp,iPrimi, - & Shells(iShllV(2))%Exp,jPrimj, - & Shells(iShllV(1))%pCff,iBas, - & Shells(iShllV(2))%pCff,jBas, - & nMemab,Con, - & Wrk(ipM002),M002,Wrk(ipM003),M003, - & Wrk(ipM004),M004, - & mdci,mdcj) -* - Indk2(1,ijShll) = jpk2 - Indk2(2,ijShll) = nDCRR - nk2 = nk2 + (nZeta*nDArray+nDScalar)*nDCRR - mk2 = mk2 + nDCRR -* - If (New_Fock) Then - iDeSiz = 1 + iPrim*jPrim + iCmp*jCmp - Else - iDeSiz = 1 + iPrim*jPrim - & + (iBas*jBas+1)*iCmp*jCmp - End If - iSmLbl = 1 - nSO = MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO) - If (nSO.gt.0) mDeDe = mDeDe + iDeSiz*nDCRR - - jpk2 = 1 + nk2 -* - End Do - End Do -* * -************************************************************************ -* * - Call mma_deallocate(Wrk) - Call mma_deallocate(Con) -* * -************************************************************************ -* * -* Resize the memory to the actual size -* - Call mma_allocate(Data_k2,nk2) - Call dCopy_(nk2,Data_k2_local,1,Data_k2,1) - Call mma_deallocate(Data_k2_local) -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - Write (6,*) - Write (6,'(20X,A)') - & ' *** The k2 entities has been precomputed ***' - Write (6,'(I7,A,I7,A)') - & mk2,' blocks of k2 data were computed and', - & nk2,' Word(*8) of memory is used for storage.' - Write (6,'(A,A)') - & ' The presceening is based on the ', - & ' integral estimates.' -#endif -* - Call CWTime(TCpu2,TWall2) - Call SavTim(2,TCpu2-TCpu1,TWall2-TWall1) - Return - End diff -Nru openmolcas-22.02/src/mckinley/drvk2_mck.F90 openmolcas-22.10/src/mckinley/drvk2_mck.F90 --- openmolcas-22.02/src/mckinley/drvk2_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/drvk2_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,228 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990-1992, Roland Lindh * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine Drvk2_mck(mdede,New_Fock) +!*********************************************************************** +! * +! Object: to precompute all pair entites as zeta, kappa, P. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! June '91, modified for k2 loop. * +! January '92, modified to gradient calculations. * +! April '92, modified to use the Cauchy-Schwarz inequality * +! to estimate the integral derivatives. * +! Modified 1995 for 2nd derivatives by AB * +!*********************************************************************** + +use Index_Functions, only: iTri, nTri_Elem1 +use k2_setup, only: Data_k2, Indk2, nk2 +use k2_arrays, only: DoGrad_, DoHess_ +use iSD_data, only: iSD +use Basis_Info, only: dbsc, Shells +use Symmetry_Info, only: iOper, nIrrep +use Sizes_of_Seward, only: S +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(out) :: mdede +logical(kind=iwp), intent(in) :: New_Fock +#include "ndarray.fh" +integer(kind=iwp) :: iAng, iAngV(4), iAO, iBas, iBasi, iBsInc, iCmp, iCmpV(4), iCnt, iCnttp, iDCRR(0:7), iDeSiz, ijCmp, ijShll, & + iShllV(2), ipM001, ipM002, ipM003, ipM004, iPrim, iPrimi, iPrInc, iS, iShell, iShll, iSmLbl, jAng, jAO, jBas, & + jBasj, jBsInc, jCmp, jCnt, jCnttp, jpk2, jPrim, jPrimj, jPrInc, jS, jShell, jShll, kBask, kBsInc, kPrimk, & + kPrInc, lBasl, lBsInc, lPriml, lPrInc, M001, M002, M003, M004, M00d, Maxk2, MaxMem, mdci, mdcj, MemPrm, & + MemTmp, mk2, nBasi, nBasj, nDCRR, nHrrab, nMemab, nSkal, nSO, nZeta +real(kind=wp) :: Coor(3,2), TCpu1, TCpu2, TWall1, TWall2 +real(kind=wp), allocatable :: Con(:), Data_k2_local(:), Wrk(:) +integer(kind=iwp), external :: MemSO1 + +! * +!*********************************************************************** +! * +call CWTime(TCpu1,TWall1) +call mma_MaxDBLE(Maxk2) +maxk2 = maxk2/2 +call mma_allocate(Data_k2_local,Maxk2) +jpk2 = 1 +nk2 = 0 +mdede = 0 +mk2 = 0 + +DoGrad_ = .false. +DoHess_ = .true. +! * +!*********************************************************************** +! * +call Nr_Shells(nSkal) +! * +!*********************************************************************** +! * +call mma_allocate(Con,S%m2Max,Label='Con') +! * +!*********************************************************************** +! * +MemTmp = 0 +do iAng=0,S%iAngMx + MemTmp = max(MemTmp,(S%MaxPrm(iAng)*nTri_Elem1(iAng))**2) +end do +! * +!*********************************************************************** +! * +call mma_MaxDBLE(MaxMem) +call mma_allocate(Wrk,MaxMem,Label='Wrk') +ipM001 = 1 +! * +!*********************************************************************** +! * +do iS=1,nSkal + iShll = iSD(0,iS) + iAng = iSD(1,iS) + iCmp = iSD(2,iS) + iBas = iSD(3,iS) + iPrim = iSD(5,iS) + iAO = iSD(7,iS) + mdci = iSD(10,iS) + iShell = iSD(11,iS) + iCnttp = iSD(13,iS) + iCnt = iSD(14,iS) + Coor(1:3,1) = dbsc(iCnttp)%Coor(1:3,iCnt) + + iAngV(1) = iAng + iShllV(1) = iShll + iCmpV(1) = nTri_Elem1(iAng) + + do jS=1,iS + jShll = iSD(0,jS) + jAng = iSD(1,jS) + jCmp = iSD(2,jS) + jBas = iSD(3,jS) + jPrim = iSD(5,jS) + jAO = iSD(7,jS) + mdcj = iSD(10,jS) + jShell = iSD(11,jS) + jCnttp = iSD(13,jS) + jCnt = iSD(14,jS) + Coor(1:3,2) = dbsc(jCnttp)%Coor(1:3,jCnt) + + iAngV(2) = jAng + iShllV(2) = jShll + iCmpV(2) = nTri_Elem1(jAng) + + ! Compute FLOP's for the transfer equation. + + call mHrr(iAng,jAng,nHrrab,nMemab) + ijCmp = nTri_Elem1(iAng)*nTri_Elem1(jAng) + + iPrimi = iPrim + jPrimj = jPrim + nBasi = Shells(iShllV(1))%nBasis + nBasj = Shells(iShllV(2))%nBasis + + kPrimk = 1 + lPriml = 1 + iBasi = iPrimi + jBasj = jPrimj + kBask = 1 + lBasl = 1 + + nZeta = iPrimi*jPrimj + + call ConMax(Con,iPrimi,jPrimj,Shells(iShll)%pCff,nBasi,Shells(jShll)%pCff,nBasj) + + iAngV(3:4) = iAngV(1:2) + iCmpV(3:4) = iCmpV(1:2) + + ijShll = iTri(iShell,jShell) + + nSO = 1 + + ! Compute memory request for the primitives, i.e. how much memory + ! is needed up to the transfer equation. + + call MemRys(iAngV,MemPrm) + + ! Decide on the partioning of the shells based on + ! the available memory and the requested memory. + + call PSOAO0_h(nSO,nMemab,nMemab,MemPrm,MaxMem,iAngV,iCmpV,iBasi,iBsInc,jBasj,jBsInc,kBask,kBsInc,lBasl,lBsInc,iPrimi,iPrInc, & + jPrimj,jPrInc,kPrimk,kPrInc,lPriml,lPrInc,ipM001,ipM002,ipM003,ipM004,M001,M002,M003,M004,M00d) + if ((iBasi /= iBsInc) .or. (jBasj /= jBsInc)) then + write(u6,*) 'Drvk2: (iBasi /= iBsInc) .or. (jBasj /= jBsInc)' + write(u6,*) 'iBasi,iBsInc=',iBasi,iBsInc + write(u6,*) 'jBasj,jBsInc=',jBasj,jBsInc + call Abend() + end if + + ! Find the Double Coset Representatives for center A and B. + + iDCRR(0:nIrrep-1) = iOper(0:nIrrep-1) + nDCRR = nIrrep + + ! Compute all pair entities (zeta, kappa, Px, Py, Pz, ZInv, alpha, + ! beta, [nm|nm] and derivative entity, a total of ten different + ! entities) for all possible unique pairs of centers generated + ! for the symmetry unique centers A and B. + + call k2Loop_mck(Coor,iAngV,iCmpV,iDCRR,nDCRR,Data_k2_local(jpk2),ijCmp,Shells(iShllV(1))%Exp,iPrimi,Shells(iShllV(2))%Exp, & + jPrimj,Shells(iShllV(1))%pCff,iBas,Shells(iShllV(2))%pCff,jBas,nMemab,Wrk(ipM002),M002,Wrk(ipM003),M003,mdci, & + mdcj) + + Indk2(1,ijShll) = jpk2 + Indk2(2,ijShll) = nDCRR + nk2 = nk2+(nZeta*nDArray+nDScalar)*nDCRR + mk2 = mk2+nDCRR + + if (New_Fock) then + iDeSiz = 1+iPrim*jPrim+iCmp*jCmp + else + iDeSiz = 1+iPrim*jPrim+(iBas*jBas+1)*iCmp*jCmp + end if + iSmLbl = 1 + nSO = MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO) + if (nSO > 0) mDeDe = mDeDe+iDeSiz*nDCRR + + jpk2 = 1+nk2 + + end do +end do +! * +!*********************************************************************** +! * +call mma_deallocate(Wrk) +call mma_deallocate(Con) +! * +!*********************************************************************** +! * +! Resize the memory to the actual size + +call move_alloc(Data_k2_local,Data_k2) +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +write(u6,*) +write(u6,'(20X,A)') ' *** The k2 entities have been precomputed ***' +write(u6,'(I7,A,I7,A)') mk2,' blocks of k2 data were computed and',nk2,' Word(*8) of memory is used for storage.' +write(u6,'(A)') ' The prescreening is based on the integral estimates.' +#endif + +call CWTime(TCpu2,TWall2) +call SavTim(2,TCpu2-TCpu1,TWall2-TWall1) + +return + +end subroutine Drvk2_mck diff -Nru openmolcas-22.02/src/mckinley/drvn1_mck.f openmolcas-22.10/src/mckinley/drvn1_mck.f --- openmolcas-22.02/src/mckinley/drvn1_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/drvn1_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,120 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine DrvN1_mck(Grad,nGrad) -************************************************************************ -* * -* Object: to compute the molecular gradient contribution due to the * -* nuclear repulsion energy. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* October 1991 * -************************************************************************ - use Basis_Info - use Center_Info - use Symmetry_Info, only: nIrrep, iChBas - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "print.fh" -#include "real.fh" -#include "disp.fh" -#include "disp2.fh" - Real*8 A(3), B(3), RB(3), Grad(nGrad) - Integer iDCRR(0:7) - Logical EQ, TstFnc -* - iIrrep = 0 - mdc = 0 -*-----Loop over centers with the same change - Do 100 iCnttp = 1, nCnttp - ZA = dbsc(iCnttp)%Charge - If (ZA.eq.Zero) Go To 101 -*--------Loop over all unique centers of this group - Do 110 iCnt = 1, dbsc(iCnttp)%nCntr - A(1:3)=dbsc(iCnttp)%Coor(1:3,iCnt) -* - ndc = 0 - Do 200 jCnttp = 1, iCnttp - ZAZB = ZA * dbsc(jCnttp)%Charge - If (ZAZB.eq.Zero) Go To 201 - jCntMx = dbsc(jCnttp)%nCntr - If (iCnttp.eq.jCnttp) jCntMx = iCnt - Do 210 jCnt = 1, jCntMx - B(1:3)=dbsc(jCnttp)%Coor(1:3,jCnt) -* - Fact = One -* Factor due to resticted summation - If (EQ(A,B)) Fact = Half -* -* Find the DCR for the two centers -* - Call DCR(LmbdR,dc(mdc+iCnt)%iStab,dc(mdc+iCnt)%nStab, - & dc(ndc+jCnt)%iStab,dc(ndc+jCnt)%nStab, - & iDCRR,nDCRR) -* - PreFct = Fact*ZAZB*DBLE(nIrrep)/DBLE(LmbdR) - Do 300 iR = 0, nDCRR-1 - Call OA(iDCRR(iR),B,RB) - nOp = NrOpr(iDCRR(iR)) - If (EQ(A,RB)) Go To 300 - r12 = Sqrt((A(1)-RB(1))**2 + - & (A(2)-RB(2))**2 + - & (A(3)-RB(3))**2 ) -* -* The factor u/g will ensure that the value of the -* gradient in symmetry adapted and no symmetry basis -* will have the same value. -* - nDisp = IndDsp(mdc+iCnt,iIrrep) - igu=nIrrep/dc(mdc+iCnt)%nStab - Do 400 iCar = 0, 2 - iComp = 2**iCar - If ( TstFnc(dc(mdc+iCnt)%iCoSet, - & iIrrep,iComp,dc(mdc+iCnt)%nStab) - & ) Then - nDisp = nDisp + 1 - If (.true.) Grad(nDisp) = - & Grad(nDisp) - One/DBLE(igu) * - & PreFct*(A(iCar+1)-RB(iCar+1))/(r12**3) - End If - 400 Continue -* - nDisp = IndDsp(ndc+jCnt,iIrrep) - igv=nIrrep/dc(ndc+jCnt)%nStab - Do 450 iCar = 0, 2 - iComp = 2**iCar - If ( TstFnc(dc(ndc+jCnt)%iCoSet, - & iIrrep,iComp,dc(ndc+jCnt)%nStab) - & ) Then - nDisp = nDisp + 1 - If (.true.) Then - ps = DBLE(iPrmt(nOp,iChBas(2+iCar))) - Grad(nDisp) = Grad(nDisp) + ps * - & One/DBLE(igv) * - & PreFct*(A(iCar+1)-RB(iCar+1))/(r12**3) - End If - End If - 450 Continue - 300 Continue -* - 210 Continue - 201 Continue - ndc = ndc + dbsc(jCnttp)%nCntr - 200 Continue - 110 Continue - 101 Continue - mdc = mdc + dbsc(iCnttp)%nCntr - 100 Continue -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/drvn1_mck.F90 openmolcas-22.10/src/mckinley/drvn1_mck.F90 --- openmolcas-22.02/src/mckinley/drvn1_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/drvn1_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,111 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine DrvN1_mck(Grad,nGrad) +!*********************************************************************** +! * +! Object: to compute the molecular gradient contribution due to the * +! nuclear repulsion energy. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! October 1991 * +!*********************************************************************** + +use Basis_Info, only: dbsc, nCnttp +use Center_Info, only: dc +use Symmetry_Info, only: nIrrep, iChBas +use Constants, only: Zero, One, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nGrad +real(kind=wp), intent(inout) :: Grad(nGrad) +#include "Molcas.fh" +#include "disp.fh" +integer(kind=iwp) :: iCar, iCnt, iCnttp, iComp, iDCRR(0:7), igu, igv, iIrrep, iR, jCnt, jCntMx, jCnttp, LmbdR, mdc, ndc, nDCRR, & + nDisp, nOp +real(kind=wp) :: A(3), B(3), Fact, PreFct, ps, r12, RB(3), ZA, ZAZB +integer(kind=iwp), external :: iPrmt, NrOpr +logical(kind=iwp), external :: EQ, TstFnc + +iIrrep = 0 +mdc = 0 +! Loop over centers with the same change +do iCnttp=1,nCnttp + if (iCnttp > 1) mdc = mdc+dbsc(iCnttp-1)%nCntr + ZA = dbsc(iCnttp)%Charge + if (ZA == Zero) cycle + ! Loop over all unique centers of this group + do iCnt=1,dbsc(iCnttp)%nCntr + A(1:3) = dbsc(iCnttp)%Coor(1:3,iCnt) + + ndc = 0 + do jCnttp=1,iCnttp + if (jCnttp > 1) ndc = ndc+dbsc(jCnttp-1)%nCntr + ZAZB = ZA*dbsc(jCnttp)%Charge + if (ZAZB == Zero) cycle + jCntMx = dbsc(jCnttp)%nCntr + if (iCnttp == jCnttp) jCntMx = iCnt + do jCnt=1,jCntMx + B(1:3) = dbsc(jCnttp)%Coor(1:3,jCnt) + + Fact = One + ! Factor due to resticted summation + if (EQ(A,B)) Fact = Half + + ! Find the DCR for the two centers + + call DCR(LmbdR,dc(mdc+iCnt)%iStab,dc(mdc+iCnt)%nStab,dc(ndc+jCnt)%iStab,dc(ndc+jCnt)%nStab,iDCRR,nDCRR) + + PreFct = Fact*ZAZB*real(nIrrep,kind=wp)/real(LmbdR,kind=wp) + do iR=0,nDCRR-1 + call OA(iDCRR(iR),B,RB) + nOp = NrOpr(iDCRR(iR)) + if (EQ(A,RB)) cycle + r12 = sqrt((A(1)-RB(1))**2+(A(2)-RB(2))**2+(A(3)-RB(3))**2) + + ! The factor u/g will ensure that the value of the + ! gradient in symmetry adapted and no symmetry basis + ! will have the same value. + + nDisp = IndDsp(mdc+iCnt,iIrrep) + igu = nIrrep/dc(mdc+iCnt)%nStab + do iCar=0,2 + iComp = 2**iCar + if (TstFnc(dc(mdc+iCnt)%iCoSet,iIrrep,iComp,dc(mdc+iCnt)%nStab)) then + nDisp = nDisp+1 + Grad(nDisp) = Grad(nDisp)-One/real(igu,kind=wp)*PreFct*(A(iCar+1)-RB(iCar+1))/(r12**3) + end if + end do + + nDisp = IndDsp(ndc+jCnt,iIrrep) + igv = nIrrep/dc(ndc+jCnt)%nStab + do iCar=0,2 + iComp = 2**iCar + if (TstFnc(dc(ndc+jCnt)%iCoSet,iIrrep,iComp,dc(ndc+jCnt)%nStab)) then + nDisp = nDisp+1 + ps = real(iPrmt(nOp,iChBas(2+iCar)),kind=wp) + Grad(nDisp) = Grad(nDisp)+ps*One/real(igv,kind=wp)*PreFct*(A(iCar+1)-RB(iCar+1))/(r12**3) + end if + end do + end do + + end do + end do + end do +end do + +return + +end subroutine DrvN1_mck diff -Nru openmolcas-22.02/src/mckinley/drvn2.f openmolcas-22.10/src/mckinley/drvn2.f --- openmolcas-22.02/src/mckinley/drvn2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/drvn2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,783 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -* 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine DrvN2(Hess,nGrad) -************************************************************************ -* * -* Object: to compute the molecular gradient contribution due to the * -* nuclear repulsion energy. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* October 1991 * -* Anders Bernhardsson, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* September 1995 * -************************************************************************ - use Basis_Info - use Center_Info - use PCM_arrays - use Symmetry_Info, only: nIrrep, iChTbl - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "real.fh" -#include "disp.fh" -#include "disp2.fh" -#include "stdalloc.fh" -#include "rctfld.fh" - Real*8 A(3), B(3), RB(3), Hess(nGrad*(nGrad+1)/2),prmt(0:7), - & C(3), D(3), SD(3) - Integer iDCRR(0:7),IndGrd(3,2,0:7),ii(2), iStb(0:7), - & iDCRS(0:7),IndHss(2,3,2,3,0:7),nop(2),kop(2) - Logical EQ, NoLoop - Data Prmt/1.d0,-1.d0,-1.d0,1.d0,-1.d0,1.d0,1.d0,-1.d0/ - Real*8, Allocatable:: Pcmhss(:), Der1(:), DerDM(:), Temp(:) - Logical, External :: TF -* * -************************************************************************ -* * -* Statement Function -* - xPrmt(i,j) = Prmt(iAnd(i,j)) - iTri(i1,i2)=Max(i1,i2)*(Max(i1,i2)-1)/2+Min(i1,i2) -* * -************************************************************************ -* * -* -c iRout = 33 -c iPrint = nPrint(iRout) -* * -************************************************************************ -* * -* Compute the nuclear repulsion contributions * -* * -************************************************************************ -* * - nHess = nGrad*(nGrad+1)/2 - call dcopy_(nHess,[Zero],0,Hess,1) -* - mdc = 0 -*-----Loop over centers with the same change - Do iCnttp = 1, nCnttp - ZA = dbsc(iCnttp)%Charge - If (ZA.eq.Zero) Go To 101 -*--------Loop over all unique centers of this group - Do 110 iCnt = 1, dbsc(iCnttp)%nCntr - A(1:3) = dbsc(iCnttp)%Coor(1:3,iCnt) -* - ndc = 0 - Do jCnttp = 1, iCnttp - ZB=dbsc(jCnttp)%Charge - If (ZB.eq.Zero) Go To 201 - ZAZB = ZA * ZB - jCntMx = dbsc(jCnttp)%nCntr - If (iCnttp.eq.jCnttp) jCntMx = iCnt - Do jCnt = 1, jCntMx - B(1:3) = dbsc(jCnttp)%Coor(1:3,jCnt) -* - Fact = One -* Factor due to resticted summation - If (EQ(A,B)) Fact = Half -* -* Find the DCR for the two centers -* - Call DCR(LmbdR,dc(mdc+iCnt)%iStab,dc(mdc+iCnt)%nStab, - & dc(ndc+jCnt)%iStab,dc(ndc+jCnt)%nStab, - & iDCRR,nDCRR) -* - PreFct = Fact*ZAZB*DBLE(nIrrep)/DBLE(LmbdR) - Do iR = 0, nDCRR-1 - Call OA(iDCRR(iR),B,RB) - nOp(1) = NrOpr(0) - nOp(2) = NrOpr(iDCRR(iR)) - kop(1)=0 - kop(2)=iDCRR(iR) - If (EQ(A,RB)) Go To 301 - r12 = Sqrt((A(1)-RB(1))**2 + - & (A(2)-RB(2))**2 + - & (A(3)-RB(3))**2 ) -* -* The factor u/g will ensure that the value of the -* gradient in symmetry adapted and no symmetry basis -* will have the same value. -* - fab = One - dfab=Zero - ddfab=Zero -* - If (dbsc(iCnttp)%ECP) Then -*-----------------Add contribution from M1 operator - Cnt0M1=Zero - Cnt1M1=Zero - Cnt2M1=Zero - Do iM1xp = 1, dbsc(iCnttp)%nM1 - Gamma =dbsc(iCnttp)%M1xp(iM1xp) - CffM1 =dbsc(iCnttp)%M1cf(iM1xp) - Cnt0M1=Cnt0M1+(CffM1*Exp(-Gamma*r12**2)) - Cnt1M1=Cnt1M1+Gamma*(CffM1*Exp(-Gamma*r12**2)) - Cnt2M1=Cnt2M1+Gamma**2*(CffM1*Exp(-Gamma*r12**2)) - End Do - fab=fab+Cnt0M1 - dfab=dfab-Two*r12*Cnt1M1 - ddfab=-Two*Cnt1M1+Four*r12**2*Cnt2M1 -*-----------------Add contribution from M2 operator - Cnt0M2=Zero - Cnt1M2=Zero - Cnt2M2=Zero - Do iM2xp = 1, dbsc(iCnttp)%nM2 - Gamma =dbsc(iCnttp)%M2xp(iM2xp) - CffM2 =dbsc(iCnttp)%M2cf(iM2xp) - Cnt0M2=Cnt0M2+(CffM2*Exp(-Gamma*r12**2)) - Cnt1M2=Cnt1M2+Gamma*(CffM2*Exp(-Gamma*r12**2)) - Cnt2M2=Cnt2M2+Gamma**2*(CffM2*Exp(-Gamma*r12**2)) - End Do - fab=fab+r12*Cnt0M2 - dfab=dfab+Cnt0M2-Two*r12**2*Cnt1M2 - ddfab=ddfab-Six**r12*Cnt1M2+Four*r12*Three*Cnt2M2 - End If - If (dbsc(jCnttp)%ECP) Then -*-----------------Add contribution from M1 operator - Cnt0M1=Zero - Cnt1M1=Zero - Cnt2M1=Zero - Do iM1xp = 1, dbsc(jCnttp)%nM1 - Gamma =dbsc(jCnttp)%M1xp(iM1xp) - CffM1 =dbsc(jCnttp)%M1cf(iM1xp) - Cnt0M1=Cnt0M1+(CffM1*Exp(-Gamma*r12**2)) - Cnt1M1=Cnt1M1+Gamma*(CffM1*Exp(-Gamma*r12**2)) - Cnt2M1=Cnt2M1+Gamma**2*(CffM1*Exp(-Gamma*r12**2)) - End Do - fab=fab+Cnt0M1 - dfab=dfab-Two*r12*Cnt1M1 - ddfab=-Two*Cnt1M1+Four*r12**2*Cnt2M1 -*-----------------Add contribution from M2 operator - Cnt0M2=Zero - Cnt1M2=Zero - Cnt2M2=Zero - Do iM2xp = 1, dbsc(jCnttp)%nM2 - Gamma =dbsc(jCnttp)%M2xp(iM2xp) - CffM2 =dbsc(jCnttp)%M2cf(iM2xp) - Cnt0M2=Cnt0M2+(CffM2*Exp(-Gamma*r12**2)) - Cnt1M2=Cnt1M2+Gamma*(CffM2*Exp(-Gamma*r12**2)) - Cnt2M2=Cnt2M2+Gamma**2*(CffM2*Exp(-Gamma*r12**2)) - End Do - fab=fab+r12*Cnt0M2 - dfab=dfab+Cnt0M2-Two*r12**2*Cnt1M2 - ddfab=ddfab-Six**r12*Cnt1M2+Four*r12*Three*Cnt2M2 - End If -* - df_dr=(dfab*r12-fab)/r12**2 - d2f_dr2= ( (ddfab*r12) * r12**2 - & - (dfab*r12-fab)* Two*r12 ) / r12**4 -* - Call ICopy(nirrep*36,[0],0,Indhss,1) - Call ICopy(nirrep*6,[0],0,indgrd,1) -* -* Determine which displacement in all IR's, each center is * -* associated with -* - nnIrrep=nIrrep - If (sIrrep) nnIrrep=1 - - Do iIrrep=0,nnIrrep-1 - nDisp1 = IndDsp(mdc+iCnt,iIrrep) - nDisp2 = IndDsp(ndc+jCnt,iIrrep) - Do iCar = 0,2 - iComp = 2**iCar - If ( TF(mdc+iCnt,iIrrep,iComp)) Then - nDisp1 = nDisp1 + 1 - IndGrd(iCar+1,1,iIrrep) = nDisp1 - Else - IndGrd(iCar+1,1,iIrrep)=0 - End If - iComp = 2**iCar - If ( TF(ndc+jCnt,iIrrep,iComp)) Then - nDisp2 = nDisp2 + 1 - IndGrd(iCar+1,2,iIrrep) = nDisp2 - Else - IndGrd(iCar+1,2,iIrrep)=0 - End If - End Do ! iCar - End Do ! iIrrep -* -* Determine index for each 2'nd derivative -* -* - Do iIrrep=0,nnIrrep-1 - Do iAtom=1,2 - Do iCar=1,3 - Do jAtom=1,iAtom - jCar_Max=3 - if (iAtom.eq.jAtom) jCar_Max=iCar - Do jCar=1,jCar_Max - If ((IndGrd(iCar,iAtom,iIrrep).gt.0) .and. - & (IndGrd(jCar,jAtom,iIrrep).gt.0)) Then -* - IndHss(iAtom,iCar,jAtom,jCar,iIrrep)= - & iTri(IndGrd(iCar,iAtom,iIrrep), - & IndGrd(jCar,jAtom,iIrrep)) -* - Else -* - IndHss(iAtom,iCar,jAtom,jCar,iIrrep)=0 -* - End If - End Do ! jCar - End Do ! jAtom - End Do ! iCar - End Do ! iAtom - End Do ! iIrrep -* - ii(1)=dc(mdc+icnt)%nStab - ii(2)=dc(ndc+jcnt)%nStab -* - Do iIrrep=0,nnIrrep-1 - Do iCent=1,2 - Do jCent=1,iCent - Do iCar = 1, 3 - jCar_Max=3 - If (iCent.eq.jCent) jCar_Max=iCar - Do jCar=1,jCar_Max - iCh1=2**(iCar-1) - iCh2=2**(jCar-1) - g=DBLE(iChTbl(iIrrep,nOp(icent)))* - & xPrmt(kOp(icent),iCh1)* - & DBLE(ii(icent))/ - & DBLE(nIrrep) - g=g*DBLE(iChTbl(iIrrep,nOp(jcent)))* - & xPrmt(kOp(jcent),iCh2)* - & DBLE(ii(jcent))/ - & DBLE(nIrrep) - g=g*(-One)**(icent+jcent) - if ((iCent.ne.jCent).and.(iCar.eq.jCar).and. - & (Abs(indgrd(iCar,iCent,iIrrep)).eq. - & Abs(indgrd(jCar,jCent,iIrrep)))) Then - ps=Two - Else - ps=One - End if - - Index=indHss(iCent,iCar,jCent,jCar,iIrrep) - If (index.ne.0) Then - dr_dAi=(A(iCar)-RB(iCar))/r12 - dr_dAj=(A(jCar)-RB(jCar))/r12 - d2r_dAidAj=-(A(iCar)-RB(iCar))*dr_dAj - If (iCar.eq.jCar) d2r_dAidAj=d2r_dAidAj+r12 - d2r_dAidAj=d2r_dAidAj/r12**2 - Hess(Index) = Hess(index)+ g*PreFct*ps - & *(d2r_dAidAj*df_dr + - & dr_dAi*dr_dAj*d2f_dr2) - End If - End Do ! jCar - End Do ! iCar - End Do ! jCent - End Do ! iCent - End Do ! iIrrep -* -* call triprt(' ',' ',Hess,ldisp(0)) - 301 Continue - End Do -* - End Do - 201 Continue - ndc = ndc + dbsc(jCnttp)%nCntr - End Do - 110 Continue - 101 Continue - mdc = mdc + dbsc(iCnttp)%nCntr - End Do -* * -************************************************************************ -* * -* PCM contributions -* * -************************************************************************ -* * - If (PCM) Then -* -* We will have three contributions here. -* * -************************************************************************ -* * -* -* 1) Process the contribution -* -* Sum(i) q_i V_in^xy -* -*---- Loop over tiles -* -* - Do iTs = 1, nTs - ZA = PCM_SQ(1,iTs)+PCM_SQ(2,iTs) - NoLoop = ZA.eq.Zero - If (NoLoop) Go To 112 - ZA = ZA / DBLE(nIrrep) - A(1:3) = PCMTess(1:3,iTs) -* -*------- Tile only stabilized by the unit operator -* - nStb=1 - iStb(0)=0 -* - ndc = 0 - Do jCnttp = 1, nCnttp - ZB = dbsc(jCnttp)%Charge - If (ZB.eq.Zero) Go To 212 - If (dbsc(jCnttp)%pChrg) Go To 212 - If (dbsc(jCnttp)%Frag) Go To 212 - ZAZB = ZA * ZB - Do jCnt = 1, dbsc(jCnttp)%nCntr - B(1:3) = dbsc(jCnttp)%Coor(1:3,jCnt) -* -* Find the DCR for the two centers -* - Call DCR(LmbdR,iStb,nStb, - & dc(ndc+jCnt)%iStab,dc(ndc+jCnt)%nStab, - & iDCRR,nDCRR) -* - PreFct = ZAZB * DBLE(nIrrep)/DBLE(LmbdR) - Do iR = 0, nDCRR-1 - Call OA(iDCRR(iR),B,RB) - nOp(1) = NrOpr(0) - nOp(2) = NrOpr(iDCRR(iR)) - r12 = Sqrt((A(1)-RB(1))**2 + - & (A(2)-RB(2))**2 + - & (A(3)-RB(3))**2 ) -* -* The factor u/g will ensure that the value of the -* gradient in symmetry adapted and no symmetry basis -* will have the same value. -* - fab =One - dfab =Zero - ddfab=Zero - If (dbsc(jCnttp)%ECP) Then -*--------------------Add contribution from M1 operator - Cnt0M1=Zero - Cnt1M1=Zero - Cnt2M1=Zero - Do iM1xp = 1, dbsc(jCnttp)%nM1 - Gamma =dbsc(jCnttp)%M1xp(iM1xp) - CffM1 =dbsc(jCnttp)%M1cf(iM1xp) - Cnt0M1=Cnt0M1+(CffM1*Exp(-Gamma*r12**2)) - Cnt1M1=Cnt1M1+Gamma*(CffM1*Exp(-Gamma*r12**2)) - Cnt2M1=Cnt2M1 - & +Gamma**2*(CffM1*Exp(-Gamma*r12**2)) - End Do - fab=fab+Cnt0M1 - dfab=dfab-Two*r12*Cnt1M1 - ddfab=-Two*Cnt1M1+Four*r12**2*Cnt2M1 -*--------------------Add contribution from M2 operator - Cnt0M2=Zero - Cnt1M2=Zero - Cnt2M2=Zero - Do iM2xp = 1, dbsc(jCnttp)%nM2 - Gamma =dbsc(jCnttp)%M2xp(iM2xp) - CffM2 =dbsc(jCnttp)%M2cf(iM2xp) - Cnt0M2=Cnt0M2+(CffM2*Exp(-Gamma*r12**2)) - Cnt1M2=Cnt1M2+Gamma*(CffM2*Exp(-Gamma*r12**2)) - Cnt2M2=Cnt2M2 - & +Gamma**2*(CffM2*Exp(-Gamma*r12**2)) - End Do - fab=fab+r12*Cnt0M2 - dfab=dfab+Cnt0M2-Two*r12**2*Cnt1M2 - ddfab=ddfab-Six**r12*Cnt1M2+Four*r12*Three*Cnt2M2 - End If -* - df_dr=(dfab*r12-fab)/r12**2 - d2f_dr2= ( (ddfab*r12) * r12**2 - & - (dfab*r12-fab)* Two*r12) / r12**4 -* - Call ICopy(nirrep*36,[0],0,Indhss,1) - Call ICopy(nirrep*6,[0],0,indgrd,1) -* -* Determine which displacement in all IRs, each center is * -* associated with -* - nnIrrep=nIrrep - If (sIrrep) nnIrrep=1 - - Do iIrrep=0,nnIrrep-1 - nDisp1 = IndDsp(ndc+jCnt,iIrrep) - Do iCar = 0,2 - iComp = 2**iCar - If ( TF(ndc+jCnt,iIrrep,iComp)) Then - nDisp1 = nDisp1 + 1 - IndGrd(iCar+1,1,iIrrep) = nDisp1 - Else - IndGrd(iCar+1,1,iIrrep)=0 - End If - End Do ! iCar - End Do ! iIrrep -* -* Determine index for each 2nd derivative -* -* Note that each term is only associated with one basis -* set center. -* -* - iAtom=1 - jAtom=1 - Do iIrrep=0,nnIrrep-1 - Do iCar=1,3 - jCar_Max=iCar - Do jCar=1,jCar_Max - If ((IndGrd(iCar,iAtom,iIrrep).gt.0) .and. - & (IndGrd(jCar,jAtom,iIrrep).gt.0)) Then -* - IndHss(iAtom,iCar,jAtom,jCar,iIrrep)= - & iTri(IndGrd(iCar,iAtom,iIrrep), - & IndGrd(jCar,jAtom,iIrrep)) -* - Else -* - IndHss(iAtom,iCar,jAtom,jCar,iIrrep)=0 -* - End If - End Do ! jCar - End Do ! iCar - End Do ! iIrrep -* - ii(1)=dc(ndc+jcnt)%nStab -* - iCent=1 - jCent=1 - Do iIrrep=0,nnIrrep-1 - Do iCar = 1, 3 - jCar_Max=iCar - Do jCar=1,jCar_Max - iCh1=2**(iCar-1) - iCh2=2**(jCar-1) - g=DBLE(iChTbl(iIrrep,nOp(icent)))* - & xPrmt(kOp(icent),iCh1)* - & DBLE(ii(icent))/ - & DBLE(nIrrep) - g=g*DBLE(iChTbl(iIrrep,nOp(jcent)))* - & xPrmt(kOp(jcent),iCh2)* - & DBLE(ii(jcent))/ - & DBLE(nIrrep) - g=g*(-One)**(icent+jcent) -* - Index=indHss(iCent,iCar,jCent,jCar,iIrrep) - If (Index.ne.0) Then - dr_dAi=(A(iCar)-RB(iCar))/r12 - dr_dAj=(A(jCar)-RB(jCar))/r12 - d2r_dAidAj=-(A(iCar)-RB(iCar))*dr_dAj - If (iCar.eq.jCar) d2r_dAidAj=d2r_dAidAj+r12 - d2r_dAidAj=d2r_dAidAj/r12**2 - Hess(Index) = Hess(Index)+ g*PreFct - & *(d2r_dAidAj*df_dr + - & dr_dAi*dr_dAj*d2f_dr2) - End If - End Do ! jCar - End Do ! iCar - End Do ! iIrrep -* -* Call TriPrt(' ',' ',Hess,ldisp(0)) -* - End Do ! End loop over DCR operators, iR -* - End Do ! End over centers, jCnt - 212 Continue - ndc = ndc + dbsc(jCnttp)%nCntr - End Do ! End over basis set types, jCnttp - 112 Continue - End Do ! End of tiles -* * -************************************************************************ -* * -* 2) Process the contribution -* -* Sum(i,j) V_i,n^x Q_ij V_j,n^y -* - Do iTs = 1, nTs - A(1:3) = PCMTess(1:3,iTs) -* -*------- Tile only stabilized by the unit operator -* - nStb=1 - iStb(0)=0 -* - Do jTs = 1, iTs - Fact=Two - If (jTs.eq.iTs) Fact=One - Q_ij = PCMDM(iTs,jTs) - NoLoop = Q_ij.eq.Zero - If (NoLoop) Go To 122 - C(1:3) = PCMTess(1:3,jTs) -* -* Loop over the basis functions -* - mdc = 0 - Do iCnttp = 1, nCnttp - ZA = dbsc(iCnttp)%Charge - If (ZA.eq.Zero) Go To 222 - If (dbsc(iCnttp)%pChrg) Go To 222 - If (dbsc(iCnttp)%Frag) Go To 222 -* - Do iCnt = 1, dbsc(iCnttp)%nCntr - B(1:3) = dbsc(iCnttp)%Coor(1:3,iCnt) -* -* Find the DCR for the two centers ( -* - Call DCR(LmbdR,iStb,nStb, - & dc(mdc+iCnt)%iStab,dc(mdc+iCnt)%nStab, - & iDCRR,nDCRR) -* - PreFct_AB = DBLE(nIrrep)/DBLE(LmbdR) - Do iR = 0, nDCRR-1 - Call OA(iDCRR(iR),B,RB) - nOp(1) = NrOpr(iDCRR(iR)) - r12_AB = Sqrt((A(1)-RB(1))**2 + - & (A(2)-RB(2))**2 + - & (A(3)-RB(3))**2 ) - fab =One - dfab =Zero - If (dbsc(iCnttp)%ECP) Then -*--------------------Add contribution from M1 operator - Cnt0M1=Zero - Cnt1M1=Zero - Do iM1xp = 1, dbsc(iCnttp)%nM1 - Gamma =dbsc(iCnttp)%M1xp(iM1xp) - CffM1 =dbsc(iCnttp)%M1cf(iM1xp) - Cnt0M1=Cnt0M1+(CffM1*Exp(-Gamma*r12_AB**2)) - Cnt1M1=Cnt1M1 - & +Gamma*(CffM1*Exp(-Gamma*r12_AB**2)) - End Do - fab=fab+Cnt0M1 - dfab=dfab-Two*r12_AB*Cnt1M1 -*--------------------Add contribution from M2 operator - Cnt0M2=Zero - Cnt1M2=Zero - Do iM2xp = 1, dbsc(iCnttp)%nM2 - Gamma =dbsc(iCnttp)%M2xp(iM2xp) - CffM2 =dbsc(iCnttp)%M2cf(iM2xp) - Cnt0M2=Cnt0M2+(CffM2*Exp(-Gamma*r12_AB**2)) - Cnt1M2=Cnt1M2 - & +Gamma*(CffM2*Exp(-Gamma*r12_AB**2)) - End Do - fab=fab+r12_AB*Cnt0M2 - dfab=dfab+Cnt0M2-Two*r12_AB**2*Cnt1M2 - End If - df_dr_AB=(dfab*r12_AB-fab)/r12_AB**2 -* - ndc = 0 - Do jCnttp = 1, nCnttp - ZB = dbsc(jCnttp)%Charge - If (ZB.eq.Zero) Go To 232 - If (dbsc(jCnttp)%pChrg) Go To 232 - If (dbsc(jCnttp)%Frag) Go To 232 -* - Do jCnt = 1, dbsc(jCnttp)%nCntr - D(1:3) = dbsc(jCnttp)%Coor(1:3,jCnt) -* -* Find the DCR for the two centers ( -* - Call DCR(LmbdS,iStb,nStb, - & dc(ndc+jCnt)%iStab,dc(ndc+jCnt)%nStab, - & iDCRS,nDCRS) -* - PreFct_CD = DBLE(nIrrep)/DBLE(LmbdS) - Do iS = 0, nDCRS-1 - Call OA(iDCRS(iS),D,SD) - nOp(2) = NrOpr(iDCRS(iS)) - r12_CD = Sqrt((C(1)-SD(1))**2 + - & (C(2)-SD(2))**2 + - & (C(3)-SD(3))**2 ) -* - fcd =One - dfcd =Zero - If (dbsc(jCnttp)%ECP) Then -*--------------------Add contribution from M1 operator - Cnt0M1=Zero - Cnt1M1=Zero - Do iM1xp = 1, dbsc(jCnttp)%nM1 - Gamma =dbsc(jCnttp)%M1xp(iM1xp) - CffM1 =dbsc(jCnttp)%M1cf(iM1xp) - Cnt0M1=Cnt0M1+(CffM1*Exp(-Gamma*r12_CD**2)) - Cnt1M1=Cnt1M1 - & +Gamma*(CffM1*Exp(-Gamma*r12_CD**2)) - End Do - fcd=fcd+Cnt0M1 - dfcd=dfcd-Two*r12_CD*Cnt1M1 -*--------------------Add contribution from M2 operator - Cnt0M2=Zero - Cnt1M2=Zero - Do iM2xp = 1, dbsc(jCnttp)%nM2 - Gamma =dbsc(jCnttp)%M2xp(iM2xp) - CffM2 =dbsc(jCnttp)%M2cf(iM2xp) - Cnt0M2=Cnt0M2+(CffM2*Exp(-Gamma*r12_CD**2)) - Cnt1M2=Cnt1M2 - & +Gamma*(CffM2*Exp(-Gamma*r12_CD**2)) - End Do - fcd=fcd+r12_CD*Cnt0M2 - dfcd=dfcd+Cnt0M2-Two*r12_CD**2*Cnt1M2 - End If - df_dr_CD=(dfcd*r12_CD-fcd)/r12_CD**2 -* - Call ICopy(nirrep*36,[0],0,Indhss,1) - Call ICopy(nirrep*6,[0],0,indgrd,1) -* -* Determine which displacement in all IR's, each center is * -* associated with -* - nnIrrep=nIrrep - If (sIrrep) nnIrrep=1 - - Do iIrrep=0,nnIrrep-1 - nDisp1 = IndDsp(mdc+iCnt,iIrrep) - nDisp2 = IndDsp(ndc+jCnt,iIrrep) - Do iCar = 0,2 - iComp = 2**iCar -* - If ( TF(mdc+iCnt,iIrrep,iComp)) Then - nDisp1 = nDisp1 + 1 - IndGrd(iCar+1,1,iIrrep) = nDisp1 - Else - IndGrd(iCar+1,1,iIrrep)=0 - End If -* - If ( TF(ndc+jCnt,iIrrep,iComp)) Then - nDisp2 = nDisp2 + 1 - IndGrd(iCar+1,2,iIrrep) = nDisp2 - Else - IndGrd(iCar+1,2,iIrrep)=0 - End If - End Do ! iCar - End Do ! iIrrep -* -* Determine index for each 2'nd derivative -* -* - Do iIrrep=0,nnIrrep-1 - Do iAtom=1,2 - Do iCar=1,3 - Do jAtom=1,iAtom - jCar_Max=3 - if (iAtom.eq.jAtom) jCar_Max=iCar - Do jCar=1,jCar_Max - If ((IndGrd(iCar,iAtom,iIrrep).gt.0) .and. - & (IndGrd(jCar,jAtom,iIrrep).gt.0)) Then -* - IndHss(iAtom,iCar,jAtom,jCar,iIrrep)= - & iTri(IndGrd(iCar,iAtom,iIrrep), - & IndGrd(jCar,jAtom,iIrrep)) -* - Else -* - IndHss(iAtom,iCar,jAtom,jCar,iIrrep)=0 -* - End If - End Do ! jCar - End Do ! jAtom - End Do ! iCar - End Do ! iAtom - End Do ! iIrrep -* - ii(1)=dc(mdc+icnt)%nStab - ii(2)=dc(ndc+jcnt)%nStab -* -* Note that we have two different cases here, depending on if -* iTs=jTs or not! -* For iTs=jTs and iCent.eq.jCent we do -* dV_i/dx*dV_i/dy only and exclude dV_i/dy*dV_i/dx since they -* are the same. For iTs=/=jTs we need both dV_i/dx*dV_j/dy and -* dV_i/dy*dV_j/dx. -* - Do iIrrep=0,nnIrrep-1 - Do iCent=1,2 - Do jCent=1,iCent - Do iCar = 1, 3 - jCar_Max=3 - If (iCent.eq.jCent.and.iTs.eq.jTs) jCar_Max=iCar - Do jCar=1,jCar_Max - iCh1=2**(iCar-1) - iCh2=2**(jCar-1) - g=DBLE(iChTbl(iIrrep,nOp(icent)))* - & xPrmt(kOp(icent),iCh1)* - & DBLE(ii(icent))/ - & DBLE(nIrrep) - g=g*DBLE(iChTbl(iIrrep,nOp(jcent)))* - & xPrmt(kOp(jcent),iCh2)* - & DBLE(ii(jcent))/ - & DBLE(nIrrep) - g=g*(-One)**(icent+jcent) -* - If ((iCent.ne.jCent).and.(iCar.eq.jCar).and. - & (Abs(IndGrd(iCar,iCent,iIrrep)).eq. - & Abs(IndGrd(jCar,jCent,iIrrep)))) Then - ps=Two - Else - ps=One - End if - - Index=IndHss(iCent,iCar,jCent,jCar,iIrrep) - If (Index.ne.0) Then - dr_dB=-(A(iCar)-RB(iCar))/r12_AB - dr_dD=-(C(jCar)-SD(jCar))/r12_CD - Hess(Index) = Hess(Index) - & + Fact*g*ps - & * ZA * ZA * Q_ij - & * PreFct_AB * dr_dB * df_dr_AB - & * PreFct_CD * dr_dD * df_dr_CD - End If - End Do ! jCar - End Do ! iCar - End Do ! jCent - End Do ! iCent - End Do ! iIrrep -* -* Call TriPrt(' ',' ',Hess,ldisp(0)) -* - End Do ! iS -* - End Do ! jCnt - 232 Continue - ndc = ndc + dbsc(jCnttp)%nCntr - End Do ! jCnttp -* - End Do ! iR -* - End Do ! iCnt - 222 Continue - mdc = mdc + dbsc(iCnttp)%nCntr - End Do ! jCnttp - 122 Continue - End Do ! jTs - End Do ! iTs -* * -************************************************************************ -* * -* Add additional contributions -* - nPCMHss = nGrad * nGrad - Call Get_nAtoms_All(nAtoms) - Call mma_allocate(pcmhss,nPCMHss,Label='pcmhss') - Call mma_allocate(Der1,nTs,Label='Der1') - Call mma_allocate(DerDM,nTs*nTs,Label='DerDM') - Call mma_allocate(Temp,nTs*nTs,Label='Temp') - Call Cav_Hss(nAtoms,nGrad,nTs,nS,Eps,PCMSph, - & PCMiSph,PCM_N,PCMTess,PCM_SQ, - & PCMDM,Der1,DerDM,Temp, - & dTes,DPnt,dRad,dCntr,pcmhss) - Call mma_deallocate(pcmhss) - Call mma_deallocate(Der1) - Call mma_deallocate(DerDM) - Call mma_deallocate(Temp) -* - End If -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/mckinley/drvn2.F90 openmolcas-22.10/src/mckinley/drvn2.F90 --- openmolcas-22.02/src/mckinley/drvn2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/drvn2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,709 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine DrvN2(Hess,nGrad) +!*********************************************************************** +! * +! Object: to compute the molecular gradient contribution due to the * +! nuclear repulsion energy. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! October 1991 * +! Anders Bernhardsson, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! September 1995 * +!*********************************************************************** + +use McKinley_global, only: sIrrep +use Index_Functions, only: iTri, nTri_Elem +use Basis_Info, only: dbsc, nCnttp +use Center_Info, only: dc +use PCM_arrays, only: dCntr, dPnt, dRad, dTes, PCM_N, PCM_SQ, PCMDM, PCMiSph, PCMSph, PCMTess +use Symmetry_Info, only: iChTbl, nIrrep, Prmt +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Three, Four, Six, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nGrad +real(kind=wp), intent(out) :: Hess(nTri_Elem(nGrad)) +#include "Molcas.fh" +#include "disp.fh" +#include "rctfld.fh" +integer(kind=iwp) :: iAtom, iCar, iCent, iCh1, iCh2, iCnt, iCnttp, iComp, iDCRR(0:7), iDCRS(0:7), ii(2), iIrrep, iM1xp, iM2xp, & + Indx, IndGrd(3,2,0:7), IndHss(2,3,2,3,0:7), iR, iS, iStb(0:7), iTs, jAtom, jCar, jCar_Max, jCent, jCnt, & + jCntMx, jCnttp, jTs, kop(2), LmbdR, LmbdS, mdc, nAtoms, ndc, nDCRR, nDCRS, nDisp1, nDisp2, nnIrrep, nop(2), & + nPCMHss, nStb +real(kind=wp) :: A(3), B(3), C(3), CffM1, CffM2, Cnt0M1, Cnt0M2, Cnt1M1, Cnt1M2, Cnt2M1, Cnt2M2, D(3), d2f_dr2, d2r_dAidAj, ddfab, & + df_dr, df_dr_AB, df_dr_CD, dfab, dfcd, dr_dAi, dr_dAj, dr_dB, dr_dD, fab, Fact, fcd, g, Gmma, PreFct, PreFct_AB, & + PreFct_CD, ps, Q_ij, r12, r12_AB, r12_CD, RB(3), SD(3), ZA, ZB, ZAZB +logical(kind=iwp) :: NoLoop +real(kind=wp), allocatable :: Der1(:), DerDM(:), Pcmhss(:), Temp(:) +integer(kind=iwp), external :: NrOpr +logical(kind=iwp), external :: EQ, TF + +! * +!*********************************************************************** +! * +!iRout = 33 +!iPrint = nPrint(iRout) +! * +!*********************************************************************** +! * +! Compute the nuclear repulsion contributions +! * +!*********************************************************************** +! * +Hess(:) = Zero + +mdc = 0 +! Loop over centers with the same change +do iCnttp=1,nCnttp + if (iCnttp > 1) mdc = mdc+dbsc(iCnttp-1)%nCntr + ZA = dbsc(iCnttp)%Charge + if (ZA == Zero) cycle + ! Loop over all unique centers of this group + do iCnt=1,dbsc(iCnttp)%nCntr + A(1:3) = dbsc(iCnttp)%Coor(1:3,iCnt) + + ndc = 0 + do jCnttp=1,iCnttp + if (jCnttp > 1) ndc = ndc+dbsc(jCnttp-1)%nCntr + ZB = dbsc(jCnttp)%Charge + if (ZB == Zero) cycle + ZAZB = ZA*ZB + jCntMx = dbsc(jCnttp)%nCntr + if (iCnttp == jCnttp) jCntMx = iCnt + do jCnt=1,jCntMx + B(1:3) = dbsc(jCnttp)%Coor(1:3,jCnt) + + Fact = One + ! Factor due to resticted summation + if (EQ(A,B)) Fact = Half + + ! Find the DCR for the two centers + + call DCR(LmbdR,dc(mdc+iCnt)%iStab,dc(mdc+iCnt)%nStab,dc(ndc+jCnt)%iStab,dc(ndc+jCnt)%nStab,iDCRR,nDCRR) + + PreFct = Fact*ZAZB*real(nIrrep,kind=wp)/real(LmbdR,kind=wp) + do iR=0,nDCRR-1 + call OA(iDCRR(iR),B,RB) + nOp(1) = NrOpr(0) + nOp(2) = NrOpr(iDCRR(iR)) + kop(1) = 0 + kop(2) = iDCRR(iR) + if (EQ(A,RB)) cycle + r12 = sqrt((A(1)-RB(1))**2+(A(2)-RB(2))**2+(A(3)-RB(3))**2) + + ! The factor u/g will ensure that the value of the + ! gradient in symmetry adapted and no symmetry basis + ! will have the same value. + + fab = One + dfab = Zero + ddfab = Zero + + if (dbsc(iCnttp)%ECP) then + ! Add contribution from M1 operator + Cnt0M1 = Zero + Cnt1M1 = Zero + Cnt2M1 = Zero + do iM1xp=1,dbsc(iCnttp)%nM1 + Gmma = dbsc(iCnttp)%M1xp(iM1xp) + CffM1 = dbsc(iCnttp)%M1cf(iM1xp) + Cnt0M1 = Cnt0M1+(CffM1*exp(-Gmma*r12**2)) + Cnt1M1 = Cnt1M1+Gmma*(CffM1*exp(-Gmma*r12**2)) + Cnt2M1 = Cnt2M1+Gmma**2*(CffM1*exp(-Gmma*r12**2)) + end do + fab = fab+Cnt0M1 + dfab = dfab-Two*r12*Cnt1M1 + ddfab = -Two*Cnt1M1+Four*r12**2*Cnt2M1 + ! Add contribution from M2 operator + Cnt0M2 = Zero + Cnt1M2 = Zero + Cnt2M2 = Zero + do iM2xp=1,dbsc(iCnttp)%nM2 + Gmma = dbsc(iCnttp)%M2xp(iM2xp) + CffM2 = dbsc(iCnttp)%M2cf(iM2xp) + Cnt0M2 = Cnt0M2+(CffM2*exp(-Gmma*r12**2)) + Cnt1M2 = Cnt1M2+Gmma*(CffM2*exp(-Gmma*r12**2)) + Cnt2M2 = Cnt2M2+Gmma**2*(CffM2*exp(-Gmma*r12**2)) + end do + fab = fab+r12*Cnt0M2 + dfab = dfab+Cnt0M2-Two*r12**2*Cnt1M2 + ddfab = ddfab-Six**r12*Cnt1M2+Four*r12*Three*Cnt2M2 + end if + if (dbsc(jCnttp)%ECP) then + ! Add contribution from M1 operator + Cnt0M1 = Zero + Cnt1M1 = Zero + Cnt2M1 = Zero + do iM1xp=1,dbsc(jCnttp)%nM1 + Gmma = dbsc(jCnttp)%M1xp(iM1xp) + CffM1 = dbsc(jCnttp)%M1cf(iM1xp) + Cnt0M1 = Cnt0M1+(CffM1*exp(-Gmma*r12**2)) + Cnt1M1 = Cnt1M1+Gmma*(CffM1*exp(-Gmma*r12**2)) + Cnt2M1 = Cnt2M1+Gmma**2*(CffM1*exp(-Gmma*r12**2)) + end do + fab = fab+Cnt0M1 + dfab = dfab-Two*r12*Cnt1M1 + ddfab = -Two*Cnt1M1+Four*r12**2*Cnt2M1 + ! Add contribution from M2 operator + Cnt0M2 = Zero + Cnt1M2 = Zero + Cnt2M2 = Zero + do iM2xp=1,dbsc(jCnttp)%nM2 + Gmma = dbsc(jCnttp)%M2xp(iM2xp) + CffM2 = dbsc(jCnttp)%M2cf(iM2xp) + Cnt0M2 = Cnt0M2+(CffM2*exp(-Gmma*r12**2)) + Cnt1M2 = Cnt1M2+Gmma*(CffM2*exp(-Gmma*r12**2)) + Cnt2M2 = Cnt2M2+Gmma**2*(CffM2*exp(-Gmma*r12**2)) + end do + fab = fab+r12*Cnt0M2 + dfab = dfab+Cnt0M2-Two*r12**2*Cnt1M2 + ddfab = ddfab-Six**r12*Cnt1M2+Four*r12*Three*Cnt2M2 + end if + + df_dr = (dfab*r12-fab)/r12**2 + d2f_dr2 = ((ddfab*r12)*r12**2-(dfab*r12-fab)*Two*r12)/r12**4 + + IndHss(:,:,:,:,0:nirrep-1) = 0 + IndGrd(:,:,0:nirrep-1) = 0 + + ! Determine which displacement in all IR's, each center is associated with + + nnIrrep = nIrrep + if (sIrrep) nnIrrep = 1 + + do iIrrep=0,nnIrrep-1 + nDisp1 = IndDsp(mdc+iCnt,iIrrep) + nDisp2 = IndDsp(ndc+jCnt,iIrrep) + do iCar=0,2 + iComp = 2**iCar + if (TF(mdc+iCnt,iIrrep,iComp)) then + nDisp1 = nDisp1+1 + IndGrd(iCar+1,1,iIrrep) = nDisp1 + else + IndGrd(iCar+1,1,iIrrep) = 0 + end if + iComp = 2**iCar + if (TF(ndc+jCnt,iIrrep,iComp)) then + nDisp2 = nDisp2+1 + IndGrd(iCar+1,2,iIrrep) = nDisp2 + else + IndGrd(iCar+1,2,iIrrep) = 0 + end if + end do ! iCar + end do ! iIrrep + + ! Determine index for each 2nd derivative + + do iIrrep=0,nnIrrep-1 + do iAtom=1,2 + do iCar=1,3 + do jAtom=1,iAtom + jCar_Max = 3 + if (iAtom == jAtom) jCar_Max = iCar + do jCar=1,jCar_Max + if ((IndGrd(iCar,iAtom,iIrrep) > 0) .and. (IndGrd(jCar,jAtom,iIrrep) > 0)) then + + IndHss(iAtom,iCar,jAtom,jCar,iIrrep) = iTri(IndGrd(iCar,iAtom,iIrrep),IndGrd(jCar,jAtom,iIrrep)) + + else + + IndHss(iAtom,iCar,jAtom,jCar,iIrrep) = 0 + + end if + end do ! jCar + end do ! jAtom + end do ! iCar + end do ! iAtom + end do ! iIrrep + + ii(1) = dc(mdc+icnt)%nStab + ii(2) = dc(ndc+jcnt)%nStab + + do iIrrep=0,nnIrrep-1 + do iCent=1,2 + do jCent=1,iCent + do iCar=1,3 + jCar_Max = 3 + if (iCent == jCent) jCar_Max = iCar + do jCar=1,jCar_Max + iCh1 = 2**(iCar-1) + iCh2 = 2**(jCar-1) + g = real(iChTbl(iIrrep,nOp(icent)),kind=wp)*Prmt(kOp(icent),iCh1)*real(ii(icent),kind=wp)/real(nIrrep,kind=wp) + g = g*real(iChTbl(iIrrep,nOp(jcent)),kind=wp)*Prmt(kOp(jcent),iCh2)*real(ii(jcent),kind=wp)/ & + real(nIrrep,kind=wp) + g = g*(-One)**(icent+jcent) + if ((iCent /= jCent) .and. (iCar == jCar) .and. & + (abs(indgrd(iCar,iCent,iIrrep)) == abs(indgrd(jCar,jCent,iIrrep)))) then + ps = Two + else + ps = One + end if + + Indx = indHss(iCent,iCar,jCent,jCar,iIrrep) + if (Indx /= 0) then + dr_dAi = (A(iCar)-RB(iCar))/r12 + dr_dAj = (A(jCar)-RB(jCar))/r12 + d2r_dAidAj = -(A(iCar)-RB(iCar))*dr_dAj + if (iCar == jCar) d2r_dAidAj = d2r_dAidAj+r12 + d2r_dAidAj = d2r_dAidAj/r12**2 + Hess(Indx) = Hess(Indx)+g*PreFct*ps*(d2r_dAidAj*df_dr+dr_dAi*dr_dAj*d2f_dr2) + end if + end do ! jCar + end do ! iCar + end do ! jCent + end do ! iCent + end do ! iIrrep + + !call triprt(' ',' ',Hess,ldisp(0)) + end do + + end do + end do + end do +end do +! * +!*********************************************************************** +! * +! PCM contributions +! * +!*********************************************************************** +! * +if (PCM) then + + ! We will have three contributions here. + ! * + !********************************************************************* + ! * + ! 1) Process the contribution + ! + ! Sum(i) q_i V_in^xy + + ! Loop over tiles + + do iTs=1,nTs + ZA = PCM_SQ(1,iTs)+PCM_SQ(2,iTs) + NoLoop = ZA == Zero + if (NoLoop) cycle + ZA = ZA/real(nIrrep,kind=wp) + A(1:3) = PCMTess(1:3,iTs) + + ! Tile only stabilized by the unit operator + + nStb = 1 + iStb(0) = 0 + + ndc = 0 + do jCnttp=1,nCnttp + if (jCnttp > 1) ndc = ndc+dbsc(jCnttp-1)%nCntr + ZB = dbsc(jCnttp)%Charge + if (ZB == Zero) cycle + if (dbsc(jCnttp)%pChrg) cycle + if (dbsc(jCnttp)%Frag) cycle + ZAZB = ZA*ZB + do jCnt=1,dbsc(jCnttp)%nCntr + B(1:3) = dbsc(jCnttp)%Coor(1:3,jCnt) + + ! Find the DCR for the two centers + + call DCR(LmbdR,iStb,nStb,dc(ndc+jCnt)%iStab,dc(ndc+jCnt)%nStab,iDCRR,nDCRR) + + PreFct = ZAZB*real(nIrrep,kind=wp)/real(LmbdR,kind=wp) + do iR=0,nDCRR-1 + call OA(iDCRR(iR),B,RB) + nOp(1) = NrOpr(0) + nOp(2) = NrOpr(iDCRR(iR)) + r12 = sqrt((A(1)-RB(1))**2+(A(2)-RB(2))**2+(A(3)-RB(3))**2) + + ! The factor u/g will ensure that the value of the + ! gradient in symmetry adapted and no symmetry basis + ! will have the same value. + + fab = One + dfab = Zero + ddfab = Zero + if (dbsc(jCnttp)%ECP) then + ! Add contribution from M1 operator + Cnt0M1 = Zero + Cnt1M1 = Zero + Cnt2M1 = Zero + do iM1xp=1,dbsc(jCnttp)%nM1 + Gmma = dbsc(jCnttp)%M1xp(iM1xp) + CffM1 = dbsc(jCnttp)%M1cf(iM1xp) + Cnt0M1 = Cnt0M1+(CffM1*exp(-Gmma*r12**2)) + Cnt1M1 = Cnt1M1+Gmma*(CffM1*exp(-Gmma*r12**2)) + Cnt2M1 = Cnt2M1+Gmma**2*(CffM1*exp(-Gmma*r12**2)) + end do + fab = fab+Cnt0M1 + dfab = dfab-Two*r12*Cnt1M1 + ddfab = -Two*Cnt1M1+Four*r12**2*Cnt2M1 + ! Add contribution from M2 operator + Cnt0M2 = Zero + Cnt1M2 = Zero + Cnt2M2 = Zero + do iM2xp=1,dbsc(jCnttp)%nM2 + Gmma = dbsc(jCnttp)%M2xp(iM2xp) + CffM2 = dbsc(jCnttp)%M2cf(iM2xp) + Cnt0M2 = Cnt0M2+(CffM2*exp(-Gmma*r12**2)) + Cnt1M2 = Cnt1M2+Gmma*(CffM2*exp(-Gmma*r12**2)) + Cnt2M2 = Cnt2M2+Gmma**2*(CffM2*exp(-Gmma*r12**2)) + end do + fab = fab+r12*Cnt0M2 + dfab = dfab+Cnt0M2-Two*r12**2*Cnt1M2 + ddfab = ddfab-Six**r12*Cnt1M2+Four*r12*Three*Cnt2M2 + end if + + df_dr = (dfab*r12-fab)/r12**2 + d2f_dr2 = ((ddfab*r12)*r12**2-(dfab*r12-fab)*Two*r12)/r12**4 + + IndHss(:,:,:,:,0:nirrep-1) = 0 + IndGrd(:,:,0:nirrep-1) = 0 + + ! Determine which displacement in all IRs, each center is associated with + + nnIrrep = nIrrep + if (sIrrep) nnIrrep = 1 + + do iIrrep=0,nnIrrep-1 + nDisp1 = IndDsp(ndc+jCnt,iIrrep) + do iCar=0,2 + iComp = 2**iCar + if (TF(ndc+jCnt,iIrrep,iComp)) then + nDisp1 = nDisp1+1 + IndGrd(iCar+1,1,iIrrep) = nDisp1 + else + IndGrd(iCar+1,1,iIrrep) = 0 + end if + end do ! iCar + end do ! iIrrep + + ! Determine index for each 2nd derivative + + ! Note that each term is only associated with one basis set center. + + iAtom = 1 + jAtom = 1 + do iIrrep=0,nnIrrep-1 + do iCar=1,3 + jCar_Max = iCar + do jCar=1,jCar_Max + if ((IndGrd(iCar,iAtom,iIrrep) > 0) .and. (IndGrd(jCar,jAtom,iIrrep) > 0)) then + + IndHss(iAtom,iCar,jAtom,jCar,iIrrep) = iTri(IndGrd(iCar,iAtom,iIrrep),IndGrd(jCar,jAtom,iIrrep)) + + else + + IndHss(iAtom,iCar,jAtom,jCar,iIrrep) = 0 + + end if + end do ! jCar + end do ! iCar + end do ! iIrrep + + ii(1) = dc(ndc+jcnt)%nStab + + iCent = 1 + jCent = 1 + do iIrrep=0,nnIrrep-1 + do iCar=1,3 + jCar_Max = iCar + do jCar=1,jCar_Max + iCh1 = 2**(iCar-1) + iCh2 = 2**(jCar-1) + g = real(iChTbl(iIrrep,nOp(icent)),kind=wp)*Prmt(kOp(icent),iCh1)*real(ii(icent),kind=wp)/real(nIrrep,kind=wp) + g = g*real(iChTbl(iIrrep,nOp(jcent)),kind=wp)*Prmt(kOp(jcent),iCh2)*real(ii(jcent),kind=wp)/real(nIrrep,kind=wp) + g = g*(-One)**(icent+jcent) + + Indx = indHss(iCent,iCar,jCent,jCar,iIrrep) + if (Indx /= 0) then + dr_dAi = (A(iCar)-RB(iCar))/r12 + dr_dAj = (A(jCar)-RB(jCar))/r12 + d2r_dAidAj = -(A(iCar)-RB(iCar))*dr_dAj + if (iCar == jCar) d2r_dAidAj = d2r_dAidAj+r12 + d2r_dAidAj = d2r_dAidAj/r12**2 + Hess(Indx) = Hess(Indx)+g*PreFct*(d2r_dAidAj*df_dr+dr_dAi*dr_dAj*d2f_dr2) + end if + end do ! jCar + end do ! iCar + end do ! iIrrep + + !call TriPrt(' ',' ',Hess,ldisp(0)) + + end do ! End loop over DCR operators, iR + + end do ! End over centers, jCnt + end do ! End over basis set types, jCnttp + end do ! End of tiles + ! * + !********************************************************************* + ! * + ! 2) Process the contribution + ! + ! Sum(i,j) V_i,n^x Q_ij V_j,n^y + + do iTs=1,nTs + A(1:3) = PCMTess(1:3,iTs) + + ! Tile only stabilized by the unit operator + + nStb = 1 + iStb(0) = 0 + + do jTs=1,iTs + Fact = Two + if (jTs == iTs) Fact = One + Q_ij = PCMDM(iTs,jTs) + NoLoop = Q_ij == Zero + if (NoLoop) cycle + C(1:3) = PCMTess(1:3,jTs) + + ! Loop over the basis functions + + mdc = 0 + do iCnttp=1,nCnttp + if (iCnttp > 1) mdc = mdc+dbsc(iCnttp-1)%nCntr + ZA = dbsc(iCnttp)%Charge + if (ZA == Zero) cycle + if (dbsc(iCnttp)%pChrg) cycle + if (dbsc(iCnttp)%Frag) cycle + + do iCnt=1,dbsc(iCnttp)%nCntr + B(1:3) = dbsc(iCnttp)%Coor(1:3,iCnt) + + ! Find the DCR for the two centers ( + + call DCR(LmbdR,iStb,nStb,dc(mdc+iCnt)%iStab,dc(mdc+iCnt)%nStab,iDCRR,nDCRR) + + PreFct_AB = real(nIrrep,kind=wp)/real(LmbdR,kind=wp) + do iR=0,nDCRR-1 + call OA(iDCRR(iR),B,RB) + nOp(1) = NrOpr(iDCRR(iR)) + r12_AB = sqrt((A(1)-RB(1))**2+(A(2)-RB(2))**2+(A(3)-RB(3))**2) + fab = One + dfab = Zero + if (dbsc(iCnttp)%ECP) then + ! Add contribution from M1 operator + Cnt0M1 = Zero + Cnt1M1 = Zero + do iM1xp=1,dbsc(iCnttp)%nM1 + Gmma = dbsc(iCnttp)%M1xp(iM1xp) + CffM1 = dbsc(iCnttp)%M1cf(iM1xp) + Cnt0M1 = Cnt0M1+(CffM1*exp(-Gmma*r12_AB**2)) + Cnt1M1 = Cnt1M1+Gmma*(CffM1*exp(-Gmma*r12_AB**2)) + end do + fab = fab+Cnt0M1 + dfab = dfab-Two*r12_AB*Cnt1M1 + ! Add contribution from M2 operator + Cnt0M2 = Zero + Cnt1M2 = Zero + do iM2xp=1,dbsc(iCnttp)%nM2 + Gmma = dbsc(iCnttp)%M2xp(iM2xp) + CffM2 = dbsc(iCnttp)%M2cf(iM2xp) + Cnt0M2 = Cnt0M2+(CffM2*exp(-Gmma*r12_AB**2)) + Cnt1M2 = Cnt1M2+Gmma*(CffM2*exp(-Gmma*r12_AB**2)) + end do + fab = fab+r12_AB*Cnt0M2 + dfab = dfab+Cnt0M2-Two*r12_AB**2*Cnt1M2 + end if + df_dr_AB = (dfab*r12_AB-fab)/r12_AB**2 + + ndc = 0 + do jCnttp=1,nCnttp + if (jCnttp > 1) ndc = ndc+dbsc(jCnttp-1)%nCntr + ZB = dbsc(jCnttp)%Charge + if (ZB == Zero) cycle + if (dbsc(jCnttp)%pChrg) cycle + if (dbsc(jCnttp)%Frag) cycle + + do jCnt=1,dbsc(jCnttp)%nCntr + D(1:3) = dbsc(jCnttp)%Coor(1:3,jCnt) + + ! Find the DCR for the two centers + + call DCR(LmbdS,iStb,nStb,dc(ndc+jCnt)%iStab,dc(ndc+jCnt)%nStab,iDCRS,nDCRS) + + PreFct_CD = real(nIrrep,kind=wp)/real(LmbdS,kind=wp) + do iS=0,nDCRS-1 + call OA(iDCRS(iS),D,SD) + nOp(2) = NrOpr(iDCRS(iS)) + r12_CD = sqrt((C(1)-SD(1))**2+(C(2)-SD(2))**2+(C(3)-SD(3))**2) + + fcd = One + dfcd = Zero + if (dbsc(jCnttp)%ECP) then + ! Add contribution from M1 operator + Cnt0M1 = Zero + Cnt1M1 = Zero + do iM1xp=1,dbsc(jCnttp)%nM1 + Gmma = dbsc(jCnttp)%M1xp(iM1xp) + CffM1 = dbsc(jCnttp)%M1cf(iM1xp) + Cnt0M1 = Cnt0M1+(CffM1*exp(-Gmma*r12_CD**2)) + Cnt1M1 = Cnt1M1+Gmma*(CffM1*exp(-Gmma*r12_CD**2)) + end do + fcd = fcd+Cnt0M1 + dfcd = dfcd-Two*r12_CD*Cnt1M1 + ! Add contribution from M2 operator + Cnt0M2 = Zero + Cnt1M2 = Zero + do iM2xp=1,dbsc(jCnttp)%nM2 + Gmma = dbsc(jCnttp)%M2xp(iM2xp) + CffM2 = dbsc(jCnttp)%M2cf(iM2xp) + Cnt0M2 = Cnt0M2+(CffM2*exp(-Gmma*r12_CD**2)) + Cnt1M2 = Cnt1M2+Gmma*(CffM2*exp(-Gmma*r12_CD**2)) + end do + fcd = fcd+r12_CD*Cnt0M2 + dfcd = dfcd+Cnt0M2-Two*r12_CD**2*Cnt1M2 + end if + df_dr_CD = (dfcd*r12_CD-fcd)/r12_CD**2 + + IndHss(:,:,:,:,0:nirrep-1) = 0 + IndGrd(:,:,0:nirrep-1) = 0 + + ! Determine which displacement in all IR's, each center is associated with + + nnIrrep = nIrrep + if (sIrrep) nnIrrep = 1 + + do iIrrep=0,nnIrrep-1 + nDisp1 = IndDsp(mdc+iCnt,iIrrep) + nDisp2 = IndDsp(ndc+jCnt,iIrrep) + do iCar=0,2 + iComp = 2**iCar + + if (TF(mdc+iCnt,iIrrep,iComp)) then + nDisp1 = nDisp1+1 + IndGrd(iCar+1,1,iIrrep) = nDisp1 + else + IndGrd(iCar+1,1,iIrrep) = 0 + end if + + if (TF(ndc+jCnt,iIrrep,iComp)) then + nDisp2 = nDisp2+1 + IndGrd(iCar+1,2,iIrrep) = nDisp2 + else + IndGrd(iCar+1,2,iIrrep) = 0 + end if + end do ! iCar + end do ! iIrrep + + ! Determine index for each 2nd derivative + + do iIrrep=0,nnIrrep-1 + do iAtom=1,2 + do iCar=1,3 + do jAtom=1,iAtom + jCar_Max = 3 + if (iAtom == jAtom) jCar_Max = iCar + do jCar=1,jCar_Max + if ((IndGrd(iCar,iAtom,iIrrep) > 0) .and. (IndGrd(jCar,jAtom,iIrrep) > 0)) then + + IndHss(iAtom,iCar,jAtom,jCar,iIrrep) = iTri(IndGrd(iCar,iAtom,iIrrep),IndGrd(jCar,jAtom,iIrrep)) + + else + + IndHss(iAtom,iCar,jAtom,jCar,iIrrep) = 0 + + end if + end do ! jCar + end do ! jAtom + end do ! iCar + end do ! iAtom + end do ! iIrrep + + ii(1) = dc(mdc+icnt)%nStab + ii(2) = dc(ndc+jcnt)%nStab + + ! Note that we have two different cases here, depending on if + ! iTs=jTs or not! + ! For iTs=jTs and iCent == jCent we do + ! dV_i/dx*dV_i/dy only and exclude dV_i/dy*dV_i/dx since they + ! are the same. For iTs /= jTs we need both dV_i/dx*dV_j/dy and + ! dV_i/dy*dV_j/dx. + + do iIrrep=0,nnIrrep-1 + do iCent=1,2 + do jCent=1,iCent + do iCar=1,3 + jCar_Max = 3 + if ((iCent == jCent) .and. (iTs == jTs)) jCar_Max = iCar + do jCar=1,jCar_Max + iCh1 = 2**(iCar-1) + iCh2 = 2**(jCar-1) + g = real(iChTbl(iIrrep,nOp(icent)),kind=wp)*Prmt(kOp(icent),iCh1)*real(ii(icent),kind=wp)/ & + real(nIrrep,kind=wp) + g = g*real(iChTbl(iIrrep,nOp(jcent)),kind=wp)*Prmt(kOp(jcent),iCh2)*real(ii(jcent),kind=wp)/ & + real(nIrrep,kind=wp) + g = g*(-One)**(icent+jcent) + + if ((iCent /= jCent) .and. (iCar == jCar) .and. & + (abs(IndGrd(iCar,iCent,iIrrep)) == abs(IndGrd(jCar,jCent,iIrrep)))) then + ps = Two + else + ps = One + end if + + Indx = IndHss(iCent,iCar,jCent,jCar,iIrrep) + if (Indx /= 0) then + dr_dB = -(A(iCar)-RB(iCar))/r12_AB + dr_dD = -(C(jCar)-SD(jCar))/r12_CD + Hess(Indx) = Hess(Indx)+Fact*g*ps*ZA*ZA*Q_ij*PreFct_AB*dr_dB*df_dr_AB*PreFct_CD*dr_dD*df_dr_CD + end if + end do ! jCar + end do ! iCar + end do ! jCent + end do ! iCent + end do ! iIrrep + + !call TriPrt(' ',' ',Hess,ldisp(0)) + + end do ! iS + + end do ! jCnt + end do ! jCnttp + + end do ! iR + + end do ! iCnt + end do ! jCnttp + end do ! jTs + end do ! iTs + ! * + !********************************************************************* + ! * + ! Add additional contributions + + nPCMHss = nGrad*nGrad + call Get_nAtoms_All(nAtoms) + call mma_allocate(pcmhss,nPCMHss,Label='pcmhss') + call mma_allocate(Der1,nTs,Label='Der1') + call mma_allocate(DerDM,nTs*nTs,Label='DerDM') + call mma_allocate(Temp,nTs*nTs,Label='Temp') + call Cav_Hss(nAtoms,nGrad,nTs,nS,Eps,PCMSph,PCMiSph,PCM_N,PCMTess,PCM_SQ,PCMDM,Der1,DerDM,Temp,dTes,DPnt,dRad,dCntr,pcmhss) + call mma_deallocate(pcmhss) + call mma_deallocate(Der1) + call mma_deallocate(DerDM) + call mma_deallocate(Temp) + +end if +! * +!*********************************************************************** +! * + +return + +end subroutine DrvN2 diff -Nru openmolcas-22.02/src/mckinley/elgrddot.f openmolcas-22.10/src/mckinley/elgrddot.f --- openmolcas-22.02/src/mckinley/elgrddot.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/elgrddot.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,135 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990,1992,1995, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine ElGrddot - & (Alpha,nAlpha,Beta, nBeta,Zeta,ZInv,rKappa,P, - & nZeta,la,lb,A,B,nHer, - & Array,nArr,Ccoor,nOrdOp,rout, - & IndGrd,DAO,mdc,ndc,nOp, - & iStabM,nStabM) -************************************************************************ -* * -* Object: to compute the multipole moments integrals with the * -* Gauss-Hermite quadrature. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* November '90 * -* Modified to multipole moments November '90 * -* * -* Modified to reaction field calculations July '92 * -* Modified to gradient calculations May '95 * -************************************************************************ - use Her_RW - use Center_Info - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - Integer IndGrd(2,3,3,0:7), nOp(2), iStabM(0:nStabM-1) - Real*8 - & Zeta(nZeta), ZInv(nZeta), Alpha(nAlpha), Beta(nBeta), - & rKappa(nZeta), P(nZeta,3), A(3), B(3), - & Array(nZeta*nArr), Ccoor(3), rout(*), - & DAO(nZeta,(la+1)*(la+1)/2,(lb+1)*(lb+2)/2) - Logical ABeq(3) -* -* Statement function for Cartesian index -* - nElem(i) = (i+1)*(i+2)/2 -* - ABeq(1) = A(1).eq.B(1) - ABeq(2) = A(2).eq.B(2) - ABeq(3) = A(3).eq.B(3) -* - nip = 1 - ipAxyz = nip - nip = nip + nZeta*3*nHer*(la+2) - ipBxyz = nip - nip = nip + nZeta*3*nHer*(lb+2) - ipRxyz = nip - nip = nip + nZeta*3*nHer*(nOrdOp+1) - ipRnxyz = nip - nip = nip + nZeta*3*(la+2)*(lb+2)*(nOrdOp+1) - ipTemp1 = nip - nip = nip + nZeta - ipTemp2 = nip - nip = nip + nZeta - ipTemp3 = nip - nip = nip + 3*nZeta*nHer - ipAlph = nip - nip = nip + nZeta - ipBeta = nip - nip = nip + nZeta - ipFinal=nip - nip=nip+nzeta*nElem(la)*nElem(lb)*4*6 - If (nip-1.gt.nArr*nZeta) Then - Write (6,*) ' nArr is Wrong! ', nip-1,' > ',nArr*nZeta - Call ErrTra - Write (6,*) ' Abend in RFGrd' - Call Abend - End If -* -* Compute the cartesian values of the basis functions angular part -* - Do 10 iZeta = 1, nZeta - Array(ipTemp1-1+iZeta) = Zeta(iZeta)**(-Half) - 10 Continue -* - Call vCrtCmp(Array(ipTemp1),P,nZeta,A,Array(ipAxyz), - & la+1,HerR(iHerR(nHer)),nHer,ABeq) - Call vCrtCmp(Array(ipTemp1),P,nZeta,B,Array(ipBxyz), - & lb+1,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the contribution from the multipole moment operator -* - ABeq(1) = .False. - ABeq(2) = .False. - ABeq(3) = .False. - Call vCrtCmp(Array(ipTemp1),P,nZeta,Ccoor,Array(ipRxyz), - & nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the cartesian components for the multipole moment -* integrals. The integrals are factorized into components. -* - Call vAssmbl(Array(ipRnxyz), - & Array(ipAxyz),la+1, - & Array(ipRxyz),nOrdOp, - & Array(ipBxyz),lb+1, - & nZeta,HerW(iHerW(nHer)),nHer,Array(ipTemp3)) -* -* Combine the cartesian components to the full one electron -* integral. -* - ip = ipAlph - Do iBeta = 1, nBeta - call dcopy_(nAlpha,Alpha,1,Array(ip),1) - ip = ip + nAlpha - End Do - ip = ipBeta - Do iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ip),nAlpha) - ip = ip + 1 - End Do - ncomp=4 - Call Cmbneldot(Array(ipRnxyz),nZeta,la,lb,nOrdOp,Zeta, - & rKappa,Array(ipFinal), - & ncomp,Array(ipTemp1),Array(ipTemp2), - & Array(ipAlph),Array(ipBeta),DAO, - & dc(mdc)%nStab,dc(ndc)%nStab,nOp,rout,indgrd) -*o -* Call GetMem(' Exit RFGrd','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(ZInv) - Call Unused_integer_array(iStabM) - End If - End diff -Nru openmolcas-22.02/src/mckinley/elgrddot.F90 openmolcas-22.10/src/mckinley/elgrddot.F90 --- openmolcas-22.02/src/mckinley/elgrddot.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/elgrddot.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,112 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990,1992,1995, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine ElGrddot( & +# define _CALLING_ +# include "1eldot_mck_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the multipole moments integrals with the * +! Gauss-Hermite quadrature. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! November '90 * +! Modified to multipole moments November '90 * +! * +! Modified to reaction field calculations July '92 * +! Modified to gradient calculations May '95 * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Her_RW, only: HerR, HerW, iHerR, iHerW +use Center_Info, only: dc +use Constants, only: Half +use Definitions, only: wp, iwp, u6 + +implicit none +#include "1eldot_mck_interface.fh" +integer(kind=iwp) :: iBeta, ip, ipAlph, ipAxyz, ipBeta, ipBxyz, ipFinal, ipRnxyz, ipRxyz, ipTemp1, ipTemp2, ipTemp3, ncomp, nip +logical(kind=iwp) :: ABeq(3) + +ABeq(1) = A(1) == B(1) +ABeq(2) = A(2) == B(2) +ABeq(3) = A(3) == B(3) + +nip = 1 +ipAxyz = nip +nip = nip+nZeta*3*nHer*(la+2) +ipBxyz = nip +nip = nip+nZeta*3*nHer*(lb+2) +ipRxyz = nip +nip = nip+nZeta*3*nHer*(nOrdOp+1) +ipRnxyz = nip +nip = nip+nZeta*3*(la+2)*(lb+2)*(nOrdOp+1) +ipTemp1 = nip +nip = nip+nZeta +ipTemp2 = nip +nip = nip+nZeta +ipTemp3 = nip +nip = nip+3*nZeta*nHer +ipAlph = nip +nip = nip+nZeta +ipBeta = nip +nip = nip+nZeta +ipFinal = nip +nip = nip+nzeta*nTri_Elem1(la)*nTri_Elem1(lb)*4*6 +if (nip-1 > nArr*nZeta) then + write(u6,*) ' nArr is Wrong! ',nip-1,' > ',nArr*nZeta + call ErrTra() + write(u6,*) ' Abend in ElGrddot' + call Abend() +end if + +! Compute the cartesian values of the basis functions angular part + +Array(ipTemp1:ipTemp1+nZeta-1) = Zeta**(-Half) + +call vCrtCmp(Array(ipTemp1),P,nZeta,A,Array(ipAxyz),la+1,HerR(iHerR(nHer)),nHer,ABeq) +call vCrtCmp(Array(ipTemp1),P,nZeta,B,Array(ipBxyz),lb+1,HerR(iHerR(nHer)),nHer,ABeq) + +! Compute the contribution from the multipole moment operator + +ABeq(1) = .false. +ABeq(2) = .false. +ABeq(3) = .false. +call vCrtCmp(Array(ipTemp1),P,nZeta,Ccoor,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) + +! Compute the cartesian components for the multipole moment +! integrals. The integrals are factorized into components. + +call vAssmbl(Array(ipRnxyz),Array(ipAxyz),la+1,Array(ipRxyz),nOrdOp,Array(ipBxyz),lb+1,nZeta,HerW(iHerW(nHer)),nHer,Array(ipTemp3)) + +! Combine the cartesian components to the full one electron integral. + +ip = ipAlph +do iBeta=1,nBeta + Array(ip:ip+nAlpha-1) = Alpha + ip = ip+nAlpha +end do +ip = ipBeta +do iBeta=1,nBeta + Array(ip:ip+nAlpha-1) = Beta(iBeta) + ip = ip+nAlpha +end do +ncomp = 4 +call Cmbneldot(Array(ipRnxyz),nZeta,la,lb,nOrdOp,Zeta,rKappa,Array(ipFinal),ncomp,Array(ipTemp1),Array(ipTemp2),Array(ipAlph), & + Array(ipBeta),DAO,dc(mdc)%nStab,dc(ndc)%nStab,nOp,rout,indgrd) + +return + +end subroutine ElGrddot diff -Nru openmolcas-22.02/src/mckinley/elgrd.f openmolcas-22.10/src/mckinley/elgrd.f --- openmolcas-22.02/src/mckinley/elgrd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/elgrd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,150 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990,1992,1995, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine ElGrd(Alpha,nAlpha,Beta, nBeta,Zeta,ZInv,rKappa,P, - & Final,nZeta,la,lb,A,B,nHer, - & Array,nArr,Ccoor,nOrdOp,ifgrad, - & IndGrd,nop, - & iu,iv,nrOp,iDcar,iDCnt,iStabM,nStabM,trans, - & kcar,ksym) -************************************************************************ -* * -* Object: to compute the multipole moments integrals with the * -* Gauss-Hermite quadrature. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* November '90 * -* Modified to multipole moments November '90 * -* * -* Modified to reaction field calculations July '92 * -* Modified to gradient calculations May '95 * -************************************************************************ - use Her_RW - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - Integer IndGrd(2,3,3,0:7), nOp(2), iStabM(0:nStabM-1) - Real*8 - & Zeta(nZeta), ZInv(nZeta), Alpha(nAlpha), Beta(nBeta), - & rKappa(nZeta), P(nZeta,3), A(3), B(3), - & Array(nZeta*nArr), Ccoor(3),final(*)! , rout(*) -* & ,DAO(nZeta,(la+1)*(la+1)/2,(lb+1)*(lb+2)/2) - Logical ABeq(3),ifgrad(3,2),trans(3,2) -* -* Statement function for Cartesian index -* - nElem(i) = (i+1)*(i+2)/2 -* - iprint=0 - ABeq(1) = A(1).eq.B(1) - ABeq(2) = A(2).eq.B(2) - ABeq(3) = A(3).eq.B(3) -* - nip = 1 - ipAxyz = nip - nip = nip + nZeta*3*nHer*(la+2) - ipBxyz = nip - nip = nip + nZeta*3*nHer*(lb+2) - ipRxyz = nip - nip = nip + nZeta*3*nHer*(nOrdOp+1) - ipRnxyz = nip - nip = nip + nZeta*3*(la+2)*(lb+2)*(nOrdOp+1) - ipTemp1 = nip - nip = nip + nZeta - ipTemp2 = nip - nip = nip + nZeta - ipTemp3 = nip - nip = nip + 3*nZeta*nHer - ipAlph = nip - nip = nip + nZeta - ipBeta = nip - nip = nip + nZeta - ipFinal=nip - nip=nip+nzeta*nElem(la)*nElem(lb)*4*6 - If (nip-1.gt.nArr*nZeta) Then - Write (6,*) ' nArr is Wrong! ', nip-1,' > ',nArr*nZeta - Call ErrTra - Write (6,*) ' Abend in RFGrd' - Call Abend - End If -* -* Compute the cartesian values of the basis functions angular part -* - Do 10 iZeta = 1, nZeta - Array(ipTemp1-1+iZeta) = Zeta(iZeta)**(-Half) - 10 Continue -* - Call vCrtCmp(Array(ipTemp1),P,nZeta,A,Array(ipAxyz), - & la+1,HerR(iHerR(nHer)),nHer,ABeq) - Call vCrtCmp(Array(ipTemp1),P,nZeta,B,Array(ipBxyz), - & lb+1,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the contribution from the multipole moment operator -* - ABeq(1) = .False. - ABeq(2) = .False. - ABeq(3) = .False. - Call vCrtCmp(Array(ipTemp1),P,nZeta,Ccoor,Array(ipRxyz), - & nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the cartesian components for the multipole moment -* integrals. The integrals are factorized into components. -* - Call vAssmbl(Array(ipRnxyz), - & Array(ipAxyz),la+1, - & Array(ipRxyz),nOrdOp, - & Array(ipBxyz),lb+1, - & nZeta,HerW(iHerW(nHer)),nHer,Array(ipTemp3)) -* -* Combine the cartesian components to the full one electron -* integral. -* - ip = ipAlph - Do iBeta = 1, nBeta - call dcopy_(nAlpha,Alpha,1,Array(ip),1) - ip = ip + nAlpha - End Do - ip = ipBeta - Do iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ip),nAlpha) - ip = ip + 1 - End Do - ncomp=4 - Call Cmbnel(Array(ipRnxyz),nZeta,la,lb,nOrdOp,Zeta,rKappa, - & Array(ipFinal), - & ncomp,Array(ipTemp1),Array(ipTemp2), - & Array(ipAlph),Array(ipBeta), - & iu,iv,nOp,ifgrad,kcar) -* -*? - call dcopy_(nElem(la)*nElem(lb)*nZeta*NrOp,[Zero],0,Final,1) -* -* -* Symmetry adopt the gradient operator -* - Call SymAdO_mck2(Array(ipFinal),nZeta*nElem(la)*nElem(lb), - & Final,nrOp, - & nop,IndGrd,ksym,iu,iv,ifgrad,idcar,trans) - If (iPrint.ge.49) - & Call RecPrt(' Primitive Integrals SO',' ', - & Final,nZeta, - & nElem(la)*nElem(lb)*nrOp) - -c Call Getmem('EXOG','CHECK','REAL',ipdum,ipdum) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(ZInv) - Call Unused_integer(iDCnt) - Call Unused_integer_array(iStabM) - End If - End diff -Nru openmolcas-22.02/src/mckinley/elgrd.F90 openmolcas-22.10/src/mckinley/elgrd.F90 --- openmolcas-22.02/src/mckinley/elgrd.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/elgrd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,119 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990,1992,1995, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine ElGrd( & +# define _CALLING_ +# include "1el_mck_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the multipole moments integrals with the * +! Gauss-Hermite quadrature. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! November '90 * +! Modified to multipole moments November '90 * +! * +! Modified to reaction field calculations July '92 * +! Modified to gradient calculations May '95 * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Her_RW, only: HerR, HerW, iHerR, iHerW +use Constants, only: Zero, Half +use Definitions, only: wp, iwp, u6 + +implicit none +#include "1el_mck_interface.fh" +integer(kind=iwp) :: iBeta, ip, ipAlph, ipAxyz, ipBeta, ipBxyz, ipFinal, iprint, ipRnxyz, ipRxyz, ipTemp1, ipTemp2, ipTemp3, nip +logical(kind=iwp) :: ABeq(3) + +iprint = 0 +ABeq(1) = A(1) == B(1) +ABeq(2) = A(2) == B(2) +ABeq(3) = A(3) == B(3) + +nip = 1 +ipAxyz = nip +nip = nip+nZeta*3*nHer*(la+2) +ipBxyz = nip +nip = nip+nZeta*3*nHer*(lb+2) +ipRxyz = nip +nip = nip+nZeta*3*nHer*(nOrdOp+1) +ipRnxyz = nip +nip = nip+nZeta*3*(la+2)*(lb+2)*(nOrdOp+1) +ipTemp1 = nip +nip = nip+nZeta +ipTemp2 = nip +nip = nip+nZeta +ipTemp3 = nip +nip = nip+3*nZeta*nHer +ipAlph = nip +nip = nip+nZeta +ipBeta = nip +nip = nip+nZeta +ipFinal = nip +nip = nip+nzeta*nTri_Elem1(la)*nTri_Elem1(lb)*4*6 +if (nip-1 > nArr*nZeta) then + write(u6,*) ' nArr is Wrong! ',nip-1,' > ',nArr*nZeta + call ErrTra() + write(u6,*) ' Abend in ElGrd' + call Abend() +end if + +! Compute the cartesian values of the basis functions angular part + +Array(ipTemp1:ipTemp1+nZeta-1) = Zeta**(-Half) + +call vCrtCmp(Array(ipTemp1),P,nZeta,A,Array(ipAxyz),la+1,HerR(iHerR(nHer)),nHer,ABeq) +call vCrtCmp(Array(ipTemp1),P,nZeta,B,Array(ipBxyz),lb+1,HerR(iHerR(nHer)),nHer,ABeq) + +! Compute the contribution from the multipole moment operator + +ABeq(1) = .false. +ABeq(2) = .false. +ABeq(3) = .false. +call vCrtCmp(Array(ipTemp1),P,nZeta,Ccoor,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) + +! Compute the cartesian components for the multipole moment +! integrals. The integrals are factorized into components. + +call vAssmbl(Array(ipRnxyz),Array(ipAxyz),la+1,Array(ipRxyz),nOrdOp,Array(ipBxyz),lb+1,nZeta,HerW(iHerW(nHer)),nHer,Array(ipTemp3)) + +! Combine the cartesian components to the full one electron integral. + +ip = ipAlph +do iBeta=1,nBeta + Array(ip:ip+nAlpha-1) = Alpha + ip = ip+nAlpha +end do +ip = ipBeta +do iBeta=1,nBeta + Array(ip:ip+nAlpha-1) = Beta(iBeta) + ip = ip+nAlpha +end do +call Cmbnel(Array(ipRnxyz),nZeta,la,lb,nOrdOp,Zeta,rKappa,Array(ipFinal),Array(ipTemp1),Array(ipTemp2),Array(ipAlph), & + Array(ipBeta),ifgrad,kcar) + +!? +rFinal(1:nTri_Elem1(la)*nTri_Elem1(lb)*nZeta*NrOp) = Zero + +! Symmetry adapt the gradient operator + +call SymAdO_mck2(Array(ipFinal),nZeta*nTri_Elem1(la)*nTri_Elem1(lb),rFinal,nrOp,nop,IndGrd,ksym,iu,iv,ifgrad,idcar,trans) +if (iPrint >= 49) call RecPrt(' Primitive Integrals SO',' ',rFinal,nZeta,nTri_Elem1(la)*nTri_Elem1(lb)*nrOp) + +return + +end subroutine ElGrd diff -Nru openmolcas-22.02/src/mckinley/elmem.f openmolcas-22.10/src/mckinley/elmem.f --- openmolcas-22.02/src/mckinley/elmem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/elmem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine elmem(nHer,MmOvrG,la,lb,lr) - nElem(i) = (i+1)*(i+2)/2 - -* - nHer=(la+lb+lr+3)/2 - MmOvrg = 3*nHer*(la+2) + - & 3*nHer*(lb+2) + - & 3*nHer*(lr+1) + - & 3*(la+2)*(lb+2)*(lr+1)+2 + - & nelem(la)*nelem(lb)*4*6+2+3*nHer -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/elmem.F90 openmolcas-22.10/src/mckinley/elmem.F90 --- openmolcas-22.02/src/mckinley/elmem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/elmem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,28 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine elmem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" + +nHer = (la+lb+lr+3)/2 +Mem = 3*nHer*(la+2)+3*nHer*(lb+2)+3*nHer*(lr+1)+3*(la+2)*(lb+2)*(lr+1)+2+nTri_Elem1(la)*nTri_Elem1(lb)*4*6+2+3*nHer + +return + +end subroutine elmem diff -Nru openmolcas-22.02/src/mckinley/fckacc_mck.f openmolcas-22.10/src/mckinley/fckacc_mck.f --- openmolcas-22.02/src/mckinley/fckacc_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/fckacc_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1180 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1993,1998, Roland Lindh * -************************************************************************ -#define _USE_OLD_CODE_ -#ifdef _USE_OLD_CODE_ - Subroutine FckAcc_mck(iAng, iCmp,jCmp,kCmp,lCmp,Shijij, - & iShll, iShell, kOp, nijkl, - & AOInt,TwoHam,nDens,Scrt,nScrt, - & iAO,iAOst,iBas,jBas,kBas,lBas, - & Dij,ij1,ij2,ij3,ij4, - & Dkl,kl1,kl2,kl3,kl4, - & Dik,ik1,ik2,ik3,ik4, - & Dil,il1,il2,il3,il4, - & Djk,jk1,jk2,jk3,jk4, - & Djl,jl1,jl2,jl3,jl4, - & FT,nFT, - & tfact,iCar,iCent,pert,indgrd,ipdisp) -************************************************************************ -* * -* Object: to accumulate contributions from the AO integrals directly * -* to the symmatry adapted Fock matrix. * -* * -* The indices has been scrambled before calling this routine. * -* Hence we must take special care in order to regain the can- * -* onical order. * -* * -* In addition to this complication we have that the order of * -* indicies in the integrals are not ordered canonically but * -* rather in an order such that the contraction step will be * -* optimal. Hence, special care has to be taken when tracing * -* the density with the integrals so that both entities have * -* the same order. * -* * -* The Fock matrix is computed in lower triangular form. * -* * -* The density matrix is not folded if the shell indices and * -* the angular indices are identical. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, Sweden. February '93 * -************************************************************************ - use Basis_Info - use Symmetry_Info, only: nIrrep, iChTbl, iOper, iChBas - use SOAO_Info, only: iAOtSO - use Real_Spherical, only: iSphCr - use Gateway_Info, only: CutInt - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "disp2.fh" - Real*8 AOInt(nijkl,iCmp,jCmp,kCmp,lCmp), TwoHam(nDens), - & Scrt(nScrt), FT(nFT), - & Dij(ij1*ij2+1,ij3,ij4), - & Dkl(kl1*kl2+1,kl3,kl4), - & Dik(ik1*ik2+1,ik3,ik4), - & Dil(il1*il2+1,il3,il4), - & Djk(jk1*jk2+1,jk3,jk4), - & Djl(jl1*jl2+1,jl3,jl4) -c Logical Qij, Qkl - Logical Shij, Shkl, Shijij, Qijij, - & iShij, iShkl, iQij, iQkl, - & iQik, iShik, iQil, iShil, iQjk, iShjk, iQjl, iShjl, - & lFij, lFkl, lFik, lFjl, lFil, lFjk - Integer iAng(4), iShell(4), iShll(4), kOp(4), kOp2(4), - & iAO(4), iAOst(4), iCmpa(4) - Logical Pert(0:nIrrep-1) - integer indgrd(3,4,0:nirrep-1),ipdisp(*) - -* Local Arrays - Integer iSym(4,0:7), iTwoj(0:7) - Real*8 Prmt(0:7) - Data iTwoj/1,2,4,8,16,32,64,128/ - Data Prmt/1.d0,-1.d0,-1.d0,1.d0,-1.d0,1.d0,1.d0,-1.d0/ -* -* Statement Function -* - iOff(ixyz) = ixyz*(ixyz+1)*(ixyz+2)/6 - xPrmt(i,j) = Prmt(iAnd(i,j)) -* -* iprint=0 -* -* Write (*,*) DDot_(nijkl*iCmp*jCmp*kCmp*lCmp,AOInt,1,AOInt,1), -* & DDot_(nijkl*iCmp*jCmp*kCmp*lCmp,AOInt,1,One ,0) -* If (DDot_(nijkl*iCmp*jCmp*kCmp*lCmp,AOInt,1,AOInt,1).gt.Zero -* & .or. -* & DDot_(nijkl*iCmp*jCmp*kCmp*lCmp,AOInt,1,One,0).gt.Zero) Then -* If (iPrint.ge.49) Then -* Call RecPrt('Dik','(5G20.10)',Dik,ik1*ik2+1,ik3*ik4) -* Write (*,'(A,2G20.10)') -* & ' FckAcc:AOIn',DDot_(nijkl*iCmp*jCmp*kCmp*lCmp, -* & AOInt,1,AOInt,1), DDot_(nijkl*iCmp*jCmp*kCmp*lCmp, -* & AOInt,1,One,0) -* End If -* End If -* If (iPrint.ge.99) Then -* Call RecPrt('FckAcc:AOInt','(5G20.10)', -* & AOInt,nijkl,iCmp*jCmp*kCmp*lCmp) -* Write (*,'(A,G20.10)')'Dij=',XDot(Dij,ij1,ij2,ij3,ij4) -* Write (*,'(A,G20.10)')'Dkl=',XDot(Dkl,kl1,kl2,kl3,kl4) -* Write (*,'(A,G20.10)')'Dik=',XDot(Dik,ik1,ik2,ik3,ik4) -* Write (*,'(A,G20.10)')'Dil=',XDot(Dil,il1,il2,il3,il4) -* Write (*,'(A,G20.10)')'Djk=',XDot(Djk,jk1,jk2,jk3,jk4) -* Write (*,'(A,G20.10)')'Djl=',XDot(Djl,jl1,jl2,jl3,jl4) -* End If -* -* Write (*,'(A,8L1)') 'Pert=',Pert - If (iBas*jBas*kBas*lBas.gt.nScrt) Then - Write (6,*) 'FckAcc_McK: iBas*jBas*kBas*lBas.gt.nScrt' - Write (6,*) 'iBas,jBas,kBas,lBas,nScrt=', - & iBas,jBas,kBas,lBas,nScrt - Call Abend() - End If - ii = iOff(iAng(1)) - jj = iOff(iAng(2)) - kk = iOff(iAng(3)) - ll = iOff(iAng(4)) - kOp2(1) = iOper(kOp(1)) - kOp2(2) = iOper(kOp(2)) - kOp2(3) = iOper(kOp(3)) - kOp2(4) = iOper(kOp(4)) - iCmpa(1) = iCmp - iCmpa(2) = jCmp - iCmpa(3) = kCmp - iCmpa(4) = lCmp - lFij = .False. - lFkl = .False. - lFik = .False. - lFjl = .False. - lFil = .False. - lFjk = .False. -* - ipFij = 1 - nFij = iBas*jBas*iCmpa(1)*iCmpa(2) -* - ipFkl = ipFij + nFij - nFkl = kBas*lBas*iCmpa(3)*iCmpa(4) -* - ipFik = ipFkl + nFkl - nFik = iBas*kBas*iCmpa(1)*iCmpa(3) -* - ipFjl = ipFik + nFik - nFjl = jBas*lBas*iCmpa(2)*iCmpa(4) -* - ipFil = ipFjl + nFjl - nFil = iBas*lBas*iCmpa(1)*iCmpa(4) -* - ipFjk = ipFil + nFil - nFjk = jBas*kBas*iCmpa(2)*iCmpa(3) -* - call dcopy_(nFij+nFkl+nFik+nFjl+nFil+nFjk,[Zero],0,FT(ipFij),1) -* -* Quadruple loop over elements of the basis functions angular -* description. Loops are reduced to just produce unique SO integrals -* Observe that we will walk through the memory in AOInt in a -* sequential way. -* - Shij = iShell(1).eq.iShell(2) - Shkl = iShell(3).eq.iShell(4) - iShij = iShell(1).eq.iShell(2) - iShkl = iShell(3).eq.iShell(4) - iShik = iShell(1).eq.iShell(3) - iShil = iShell(1).eq.iShell(4) - iShjk = iShell(2).eq.iShell(3) - iShjl = iShell(2).eq.iShell(4) - Do 100 i1 = 1, iCmp - Do 101 j = 0, nIrrep-1 - iSym(1,j) = 0 - If (iAOtSO(iAO(1)+i1,j)>0) iSym(1,j) = iTwoj(j) -101 Continue - jCmpMx = jCmp - If (Shij) jCmpMx = i1 - iChBs = iChBas(ii+i1) - If (Shells(iShll(1))%Transf) iChBs = iChBas(iSphCr(ii+i1)) - pEa = xPrmt(iOper(kOp(1)),iChBs) - Do 200 i2 = 1, jCmpMx - Do 201 j = 0, nIrrep-1 - iSym(2,j) = 0 - If (iAOtSO(iAO(2)+i2,j)>0) iSym(2,j) = iTwoj(j) -201 Continue - jChBs = iChBas(jj+i2) - If (Shells(iShll(2))%Transf) jChBs = iChBas(iSphCr(jj+i2)) - pRb = xPrmt(iOper(kOp(2)),jChBs) -* Qij = i1.eq.i2 - If (iShell(2).gt.iShell(1)) Then - i12 = jCmp*(i1-1) + i2 - Else - i12 = iCmp*(i2-1) + i1 - End If - Do 300 i3 = 1, kCmp - Do 301 j = 0, nIrrep-1 - iSym(3,j) = 0 - If (iAOtSO(iAO(3)+i3,j)>0) iSym(3,j) = iTwoj(j) -301 Continue - lCmpMx = lCmp - If (Shkl) lCmpMx = i3 - kChBs = iChBas(kk+i3) - If (Shells(iShll(3))%Transf) - & kChBs = iChBas(iSphCr(kk+i3)) - pTc = xPrmt(iOper(kOp(3)),kChBs) - Do 400 i4 = 1, lCmpMx - Do 401 j = 0, nIrrep-1 - iSym(4,j) = 0 - If (iAOtSO(iAO(4)+i4,j)>0) iSym(4,j) = iTwoj(j) -401 Continue -* Qkl = i3.eq.i4 - lChBs = iChBas(ll+i4) - If (Shells(iShll(4))%Transf) - & lChBs = iChBas(iSphCr(ll+i4)) - pTSd= xPrmt(iOper(kOp(4)),lChBs) - If (iShell(4).gt.iShell(3)) Then - i34 = lCmp*(i3-1) + i4 - Else - i34 = kCmp*(i4-1) + i3 - End If - If (Shijij .and. i34.gt.i12) Go To 400 - Qijij = Shijij .and. i12.eq.i34 - iQij = iShij.and.i1.eq.i2 - iQkl = iShkl.and.i3.eq.i4 - iQik = iShik.and.i1.eq.i3 - iQil = iShil.and.i1.eq.i4 - iQjk = iShjk.and.i2.eq.i3 - iQjl = iShjl.and.i2.eq.i4 - pFctr=pEa*pRb*pTc*pTSd -* - mFij = 0 - mFkl = 0 - mFik = 0 - mFjl = 0 - mFil = 0 - mFjk = 0 - Do 1000 iIrrep = 0, nIrrep-1 - If (iSym(1,iIrrep).ne.0 .and. - & iSym(2,iIrrep).ne.0) mFkl=mFkl+1 - If (iSym(3,iIrrep).ne.0 .and. - & iSym(4,iIrrep).ne.0) mFij=mFij+1 - If (iSym(1,iIrrep).ne.0 .and. - & iSym(3,iIrrep).ne.0) mFjl=mFjl+1 - If (iSym(2,iIrrep).ne.0 .and. - & iSym(4,iIrrep).ne.0) mFik=mFik+1 - If (iSym(1,iIrrep).ne.0 .and. - & iSym(4,iIrrep).ne.0) mFjk=mFjk+1 - If (iSym(2,iIrrep).ne.0 .and. - & iSym(3,iIrrep).ne.0) mFil=mFil+1 - 1000 Continue - If (mFij+mFkl+mFik+mFjl+mFil+mFjk.eq.0) Go To 400 -* - vijkl = DNrm2_(iBas*jBas*kBas*lBas, - & AOInt(1,i1,i2,i3,i4),1) - If (vijkl.lt.CutInt) Go To 400 -************************************************************************ -* * -*-----------------Fij = hij + Sum(kl) Dkl {(ij|kl)-1/2(ik|jl)} * -* * -*-----------------or * -* * -*-----------------Fij = hij + Sum(k=>l) Dkl {(2-d(kl)} P(ij|kl) * -* * -*-----------------where P(ij|kl)=(ij|kl)-1/4(ik|jl)-1/4(il|jk) * -* * -*-----------------or in the case of no sum restriction * -* * -*-----------------P(ij|kl) = (ij|kl) - 1/2(ik|jl) * -* * -*-----------------C o l o u m b C o n t r i b u t i o n s * -* * -*---------------- Fij = Dkl * (ij|kl) * -* * -*-----------------Order density matrix in accordance with the integrals* -* * -************************************************************************ - If (mFij.eq.0) Go To 3203 - If (iShell(3).lt.iShell(4)) Then - vkl = Dkl(kBas*lBas+1,i4,i3) - Else - vkl = Dkl(kBas*lBas+1,i3,i4) - End If -* -*-----------------Pickup the right column of the density matrix and -* change order if not canonical. -* - qFctr = One - ipFij1 = ((i2-1)*iCmpa(1)+i1-1)*iBas*jBas+ipFij - Fac = One - If (iQij) Fac = Half - D_kl=Two - If (iQkl) D_kl=One - Fac=Fac*D_kl - If (vkl*vijkl*Abs(Fac*qFctr*pFctr).lt.CutInt) - & Go To 3203 - If (iShell(3).lt.iShell(4)) Then - Call DGetMO(Dkl(1,i4,i3),kl1,kl1, - & kl2,Scrt,kl2) - Call dGeMV_('N',iBas*jBas,kBas*lBas, - & Fac * qFctr*pFctr,AOInt(1,i1,i2,i3,i4),iBas*jBas, - & Scrt,1, - & One,FT(ipFij1),1) - Else - Call dGeMV_('N',iBas*jBas,kBas*lBas, - & Fac * qFctr*pFctr,AOInt(1,i1,i2,i3,i4),iBas*jBas, - & Dkl(1,i3,i4),1, - & One,FT(ipFij1),1) - End If -C Call RecPrt('Fij',' ',FT(ipFij1),iBas,jBas) - lFij = .True. - 3203 Continue - If (Qijij) Go To 1200 -*---------------- Fkl = Dij * (ij|kl) - If (mFkl.eq.0) Go To 1200 - If (iShell(1).lt.iShell(2)) Then - vij = Dij(iBas*jBas+1,i2,i1) - Else - vij = Dij(iBas*jBas+1,i1,i2) - End If - qFctr = One - ipFkl1 = ((i4-1)*iCmpa(3)+i3-1)*kBas*lBas+ipFkl - Fac = One - If (iQkl) Fac = Half - D_ij=Two - If (iQij) D_ij=One - Fac=Fac*D_ij - If (vij*vijkl*Abs(Fac*qFctr*pFctr).lt.CutInt) - & Go To 1200 - If (iShell(1).lt.iShell(2)) Then - Call DGeTMO(Dij(1,i2,i1),ij1,ij1, - & ij2,Scrt,ij2) - Call dGeMV_('T',iBas*jBas,kBas*lBas, - & Fac* qFctr*pFctr,AOInt(1,i1,i2,i3,i4),iBas*jBas, - & Scrt,1, - & One,FT(ipFkl1),1) - Else - Call dGeMV_('T',iBas*jBas,kBas*lBas, - & Fac* qFctr*pFctr,AOInt(1,i1,i2,i3,i4),iBas*jBas, - & Dij(1,i1,i2),1, - & One,FT(ipFkl1),1) - End If -C Call RecPrt('Fkl',' ',FT(ipFkl1),kBas,lBas) - lFkl = .True. - 1200 Continue -* -*-----------------E x c h a n g e c o n t r i b u t i o n s -* -*-----------------Change the order ijkl to ikjl. Make sure also that -* the index pairs are canonical. -* - ipD = 1 + iBas*jBas*kBas*lBas - np = ipD-1 + Max(iBas*lBas,jBas*lBas, - & iBas*kBas,jBas*kBas) - If (np.gt.nScrt) Then - Write (6,*) 'FckAcc_McK: np.gt.nScrt' - Write (6,*) 'np,nScrt=',np,nScrt - Call Abend() - End If - If (mFik+mFjl.eq.0) Go To 1210 - If (mFik.ne.0.and.iShell(2).lt.iShell(4)) Then - vjl=Djl(jBas*lBas+1,i4,i2) - Else If (mFik.ne.0) Then - vjl=Djl(jBas*lBas+1,i2,i4) - Else - vjl=Zero - End If - If (mFjl.ne.0.and.iShell(1).lt.iShell(3)) Then - vik=Dik(iBas*kBas+1,i3,i1) - Else If (mFjl.ne.0) Then - vik=Dik(iBas*kBas+1,i1,i3) - Else - vik=Zero - End If - If (vik*vijkl/Four .lt. CutInt .and. - & vjl*vijkl/Four .lt. CutInt) Go To 1210 - Do 600 j = 1, jBas - nij = (j-1)*iBas + 1 - Do 601 k = 1, kBas - nik = (k-1)*iBas + 1 - Do 602 l = 1, lBas - nkl = (l-1)*kBas + k - njl = (l-1)*jBas + j - iOut = (nkl-1)*iBas*jBas + nij - iIn = (njl-1)*iBas*kBas + nik - call dcopy_(iBas,AOInt(iOut,i1,i2,i3,i4),1, - & Scrt(iIn),1) - 602 Continue - 601 Continue - 600 Continue -************************************************************************ -* * -*-----------------Fik = - 1/4 * Djl * P(jl|ik) * -* * -* P(jl|ik) = (jl|ik) - 1/4(ji|lk) - 1/4(jk|il) * -* * -* P(jl|ik) = (jl|ik) - 1/2(ji|lk) * -* * -*-----------------Change factor if * -* a) asymmetrical P matrix is implied * -* b) if the two exchange integrals in the symmetrical * -* P matrix are identical. * -* * -************************************************************************ - If (mFik.eq.0) Go To 2213 - qFctr = One - ipFik1 = ((i3-1)*iCmpa(1)+i1-1)*iBas*kBas+ipFik - Fac = -Quart - If (iQjl.and. .Not.iQik) Fac = -Half - D_jl=Two - If (iQjl) D_jl=One - Fac=Fac*D_jl - If (vjl*vijkl*Abs(Fac*qFctr*pFctr).lt.CutInt) - & Go To 2213 - If (iShell(2).lt.iShell(4)) Then - Call DGeTMO(Djl(1,i4,i2),jl1,jl1, - & jl2,Scrt(ipD),jl2) - Call dGeMV_('N',iBas*kBas,jBas*lBas, - & Fac*qFctr*pFctr,Scrt,iBas*kBas, - & Scrt(ipD),1, - & One,FT(ipFik1),1) - Else - Call dGeMV_('N',iBas*kBas,jBas*lBas, - & Fac*qFctr*pFctr,Scrt,iBas*kBas, - & Djl(1,i2,i4),1, - & One,FT(ipFik1),1) - End If -C Call RecPrt('Fik',' ',FT(ipFik1),iBas,kBas) - lFik = .True. - 2213 Continue - If (iQij.and.iQkl) Go To 2220 -************************************************************************ -* * -*-----------------Fjl = - 1/4 * Dik * P(jl|ik) * -* * -* P(jl|ik) = (jl|ik) - 1/4(ji|lk) - 1/4(jk|il) * -* * -* P(jl|ik) = (jl|ik) - 1/2(ji|lk) * -* * -************************************************************************ - If (mFjl.eq.0) Go To 1210 - qFctr = One - ipFjl1 = ((i4-1)*iCmpa(2)+i2-1)*jBas*lBas+ipFjl - Fac = -Quart - If (iQik.and. .Not.iQjl) Fac = -Half - D_ik=Two - If (iQik) D_ik=One - Fac=Fac*D_ik - If (vik*vijkl*Abs(Fac*qFctr*pFctr).lt.CutInt) - & Go To 1210 - If (iShell(1).lt.iShell(3)) Then - Call DGeTMO(Dik(1,i3,i1),ik1,ik1, - & ik2,Scrt(ipD),ik2) - Call dGeMV_('T',iBas*kBas,jBas*lBas, - & Fac*qFctr*pFctr,Scrt,iBas*kBas, - & Scrt(ipD),1, - & One,FT(ipFjl1),1) - Else - Call dGeMV_('T',iBas*kBas,jBas*lBas, - & Fac*qFctr*pFctr,Scrt,iBas*kBas, - & Dik(1,i1,i3),1, - & One,FT(ipFjl1),1) - End If -C Call RecPrt('Fjl',' ',FT(ipFjl1),jBas,lBas) - lFjl = .True. - 1210 Continue -* -*-----------------Change order ijkl to iljk -* - If (iQij.or.iQkl) Go To 2220 - If (mFil+mFjk.eq.0) Go To 2220 - If (mFil.ne.0.and.iShell(2).lt.iShell(3)) Then - vjk = Djk(jBas*kBas+1,i3,i2) - Else If (mFil.ne.0) Then - vjk = Djk(jBas*kBas+1,i2,i3) - Else - vjk=Zero - End If - If (mFjk.ne.0.and.iShell(1).lt.iShell(4)) Then - vil = Dil(iBas*lBas+1,i4,i1) - Else If (mFjk.ne.0) Then - vil = Dil(iBas*lBas+1,i1,i4) - Else - vil=Zero - End If - If (vil*vijkl/Four .lt. CutInt .and. - & vjk*vijkl/Four .lt. CutInt) Go To 2220 - i = 1 - Do 610 j = 1, jBas - nij = (j-1)*iBas + i - Do 611 k = 1, kBas - njk = (k-1)*jBas + j - Do 612 l = 1, lBas - nkl = (l-1)*kBas + k - nil = (l-1)*iBas + i - ijkl = (nkl-1)*iBas*jBas + nij - iljk = (njk-1)*iBas*lBas + nil - call dcopy_(iBas,AOInt(ijkl,i1,i2,i3,i4),1, - & Scrt(iljk),1) - 612 Continue - 611 Continue - 610 Continue -*-----------------Fil = - 1/4 * Djk * (ij|kl) - If (mFil.eq.0) Go To 1220 - qFctr = One - ipFil1 = ((i4-1)*iCmpa(1)+i1-1)*iBas*lBas+ipFil - Fac = -Quart - If (iQjk.and. .Not.iQil) Fac = -Half - D_jk=Two - If (iQjk) D_jk=One - Fac=Fac*D_jk - If (vjk*vijkl*Abs(Fac*qFctr*pFctr).lt.CutInt) - & Go To 1220 - If (iShell(2).lt.iShell(3)) Then - Call DGeTMO(Djk(1,i3,i2),jk1,jk1, - & jk2,Scrt(ipD),jk2) - Call dGeMV_('N',iBas*lBas,jBas*kBas, - & Fac*qFctr*pFctr,Scrt,iBas*lBas, - & Scrt(ipD),1, - & One,FT(ipFil1),1) - Else - Call dGeMV_('N',iBas*lBas,jBas*kBas, - & Fac*qFctr*pFctr,Scrt,iBas*lBas, - & Djk(1,i2,i3),1, - & One,FT(ipFil1),1) - End If -C Call RecPrt('Fil',' ',FT(ipFil1),iBas,lBas) - lFil = .True. - 1220 Continue - If (Qijij) Go To 2220 -*-----------------Fjk = - 1/4 * Dil * (ij|kl) - If (mFjk.eq.0) Go To 2220 - qFctr = One - ipFjk1 = ((i3-1)*iCmpa(2)+i2-1)*jBas*kBas+ipFjk - Fac = -Quart - If (iQil.and. .Not.iQjk) Fac = -Half - D_il=Two - If (iQil) D_il=One - Fac=Fac*D_il - If (vil*vijkl*Abs(Fac*qFctr*pFctr).lt.CutInt) - & Go To 2220 - If (iShell(1).lt.iShell(4)) Then - Call DGeTMO(Dil(1,i4,i1),il1,il1, - & il2,Scrt(ipD),il2) - Call dGeMV_('T',iBas*lBas,jBas*kBas, - & Fac*qFctr*pFctr,Scrt,iBas*lBas, - & Scrt(ipD),1, - & One,FT(ipFjk1),1) - Else - Call dGeMV_('T',iBas*lBas,jBas*kBas, - & Fac*qFctr*pFctr,Scrt,iBas*lBas, - & Dil(1,i1,i4),1, - & One,FT(ipFjk1),1) - End If -C Call RecPrt('Fjk',' ',FT(ipFjk1),jBas,kBas) - lFjk = .True. - 2220 Continue -* - 400 Continue - 300 Continue - 200 Continue - 100 Continue -* -* Write (*,*) ' Fij' - nnIrrep=nIrrep - If (sIrrep) nnIrrep=1 - Do iIrrep=0,nnIrrep-1 -* Write (*,'(I2,L1)') iIrrep, pert(iIrrep) - If (pert(iIrrep)) Then - ip=ipDisp(abs(indgrd(iCar,iCent,iIrrep))) - rCh=xPrmt(iOper(kOp(iCent)),iChBas(1+iCar))* - & DBLE(iChTbl(iIrrep,kOp(iCent))) - Fact=tfact*rCh -* Write (*,*) 'Level ij' - If (lFij) Call FckDst(TwoHam(ip),ndens,FT(ipFij), - & iBas,jBas,iCmpa(1),iCmpa(2), - & kOp2(1),kOp2(2), - & iIrrep, - & iShij, - & iAO(1),iAO(2),iAOst(1),iAOst(2), - & fact) -* Write (*,*) 'Level kl' - If (lFkl) Call FckDst(TwoHam(ip),ndens,FT(ipFkl), - & kBas,lBas,iCmpa(3),iCmpa(4), - & kOp2(3),kOp2(4), - & iIrrep, - & iShkl, - & iAO(3),iAO(4),iAOst(3),iAOst(4), - & fact) -* Write (*,*) 'Level ik' - If (lFik) Call FckDst(TwoHam(ip),ndens,FT(ipFik), - & iBas,kBas,iCmpa(1),iCmpa(3), - & kOp2(1),kOp2(3), - & iIrrep, - & iShik, - & iAO(1),iAO(3),iAOst(1),iAOst(3), - & fact) -* Write (*,*) 'Level jl' - If (lFjl) Call FckDst(TwoHam(ip),ndens,FT(ipFjl), - & jBas,lBas,iCmpa(2),iCmpa(4), - & kOp2(2),kOp2(4), - & iIrrep, - & iShjl, - & iAO(2),iAO(4),iAOst(2),iAOst(4), - & fact) -* Write (*,*) 'Level il' - If (lFil) Call FckDst(TwoHam(ip),ndens,FT(ipFil), - & iBas,lBas,iCmpa(1),iCmpa(4), - & kOp2(1),kOp2(4), - & iIrrep, - & iShil, - & iAO(1),iAO(4),iAOst(1),iAOst(4), - & fact) -* Write (*,*) 'Level jk' - If (lFjk) Call FckDst(TwoHam(ip),ndens,FT(ipFjk), - & jBas,kBas,iCmpa(2),iCmpa(3), - & kOp2(2),kOp2(3), - & iIrrep, - & iShjk, - & iAO(2),iAO(3),iAOst(2),iAOst(3), - & fact) -* If (DDot_(3468,TwoHam,1,TwoHam,1).gt.Zero) Then -* If (Abs(DDot_(3468,TwoHam,1,One,0)).gt.1.0D-16) Then -* Write (*,'(A,G20.6,G20.7)') 'TwoHam=', -* & DDot_(3468,TwoHam,1,TwoHam,1), -* & DDot_(3468,TwoHam,1,One,0) -* Else -* Write (*,'(A,G20.6)') 'TwoHam=', -* & DDot_(3468,TwoHam,1,TwoHam,1) -* End If -* Call FZero(TwoHam,3468) -* End If - End If - End Do - Return - End -#else - Subroutine FckAcc_Mck(iAng, iCmp, jCmp, kCmp, lCmp, Shijij, - & iShll, iShell, kOp, nijkl, - & AOInt,TwoHam,nDens,Scrt,nScrt, - & iAO,iAOst,iBas,jBas,kBas,lBas, - & Dij,ij1,ij2,ij3,ij4, - & Dkl,kl1,kl2,kl3,kl4, - & Dik,ik1,ik2,ik3,ik4, - & Dil,il1,il2,il3,il4, - & Djk,jk1,jk2,jk3,jk4, - & Djl,jl1,jl2,jl3,jl4, - & FT,nFT, - & tfact,iCar,iCent,pert,indgrd,ipdisp) -************************************************************************ -* * -* Object: to accumulate contributions from the AO integrals directly * -* to the symmatry adapted Fock matrix. * -* * -* The indices has been scrambled before calling this routine. * -* Hence we must take special care in order to regain the can- * -* onical order. * -* * -* In addition to this complication we have that the order of * -* indicies in the integrals are not ordered canonically but * -* rather in an order such that the contraction step will be * -* optimal. Hence, special care has to be taken when tracing * -* the density with the integrals so that both entities have * -* the same order. * -* * -* The Fock matrix is computed in lower triangular form. * -* * -* The density matrix is not folded if the shell indices and * -* the angular indices are identical. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, Sweden. February '93 * -* * -* Modified July '98 in Tokyo by R. Lindh * -************************************************************************ - use Basis_Info - use Symmetry_Info, only: nIrrep, iChTbl, iChBas - use SOAO_Info, only: iAOtSO - use Real_Spherical, only: iSphCr - use Gateway_Info, only: ThrInt, CutInt - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "disp2.fh" -#include "print.fh" - Real*8 AOInt(nijkl,iCmp,jCmp,kCmp,lCmp), TwoHam(nDens), - & Scrt(nScrt), FT(nFT), - & Dij(ij1*ij2+1,ij3,ij4), - & Dkl(kl1*kl2+1,kl3,kl4), - & Dik(ik1*ik2+1,ik3,ik4), - & Dil(il1*il2+1,il3,il4), - & Djk(jk1*jk2+1,jk3,jk4), - & Djl(jl1*jl2+1,jl3,jl4) - Logical Shijij, Qijij, - & iShij, iShkl, iQij, iQkl, - & iQik, iShik, iQil, iShil, iQjk, iShjk, iQjl, iShjl, - & lFij, lFkl, lFik, lFjl, lFil, lFjk - Integer iAng(4), iShell(4), iShll(4), kOp(4), kOp2(4), - & iAO(4), iAOst(4), iCmpa(4) - Logical Pert(0:nIrrep-1) - integer indgrd(3,4,0:nirrep-1),ipdisp(*) -* Local Arrays - Integer iSym(4) - Real*8 Prmt(0:7) -c Character*72 Label - Data Prmt/1.d0,-1.d0,-1.d0,1.d0,-1.d0,1.d0,1.d0,-1.d0/ -* -* Statement Function -* - iOff(ixyz) = ixyz*(ixyz+1)*(ixyz+2)/6 - xPrmt(i,j) = Prmt(iAnd(i,j)) -c iTri(i,j) = Max(i,j)*(Max(i,j)-1)/2 + Min(i,j) -* -* iRout = 38 -* iPrint = nPrint(iRout) -* -* If (iPrint.ge.49) Then -* Write (*,*) ' FckAcc:AOIn',DDot_(nijkl*iCmp*jCmp*kCmp*lCmp, -* & AOInt,1,AOInt,1), DDot_(nijkl*iCmp*jCmp*kCmp*lCmp, -* & AOInt,1,One,0) -* End If -* If (iPrint.ge.99) Then -* Call RecPrt('FckAcc:AOInt',' ',AOInt,nijkl,iCmp*jCmp*kCmp*lCmp) -* Write (*,*)'Dij=',XDot(Dij,ij1,ij2,ij3,ij4) -* Write (*,*)'Dkl=',XDot(Dkl,kl1,kl2,kl3,kl4) -* Write (*,*)'Dik=',XDot(Dik,ik1,ik2,ik3,ik4) -* Write (*,*)'Dil=',XDot(Dil,il1,il2,il3,il4) -* Write (*,*)'Djk=',XDot(Djk,jk1,jk2,jk3,jk4) -* Write (*,*)'Djl=',XDot(Djl,jl1,jl2,jl3,jl4) -* End If -* - ExFac=One - ThrInt=0.0D0 - If (iBas*jBas*kBas*lBas.gt.nScrt) Then - Write (6,*) 'FckAcc: nScrt too small!' - Call Abend - End If - ii = iOff(iAng(1)) - jj = iOff(iAng(2)) - kk = iOff(iAng(3)) - ll = iOff(iAng(4)) - - kOp2(1) = iOper(kOp(1)) - kOp2(2) = iOper(kOp(2)) - kOp2(3) = iOper(kOp(3)) - kOp2(4) = iOper(kOp(4)) - iCmpa(1) = iCmp - iCmpa(2) = jCmp - iCmpa(3) = kCmp - iCmpa(4) = lCmp - lFij = .False. - lFkl = .False. - lFik = .False. - lFjl = .False. - lFil = .False. - lFjk = .False. -* - ipFij = 1 - nFij = iBas*jBas*iCmpa(1)*iCmpa(2) -* - ipFkl = ipFij + nFij - nFkl = kBas*lBas*iCmpa(3)*iCmpa(4) -* - ipFik = ipFkl + nFkl - nFik = iBas*kBas*iCmpa(1)*iCmpa(3) -* - ipFjl = ipFik + nFik - nFjl = jBas*lBas*iCmpa(2)*iCmpa(4) -* - ipFil = ipFjl + nFjl - nFil = iBas*lBas*iCmpa(1)*iCmpa(4) -* - ipFjk = ipFil + nFil - nFjk = jBas*kBas*iCmpa(2)*iCmpa(3) -* - call dcopy_(nFij+nFkl+nFik+nFjl+nFil+nFjk,Zero,0,FT(ipFij),1) -* - ipDij = 1 - ipDkl = 1 - ipDik = 1 - ipDil = 1 - ipDjk = 1 - ipDjl = 1 - ipFij1= 1 - ipFkl1= 1 - ipFik1= 1 - ipFil1= 1 - ipFjk1= 1 - ipFjl1= 1 -* -* Quadruple loop over elements of the basis functions angular -* description. Loops are reduced to just produce unique SO integrals -* Observe that we will walk through the memory in AOInt in a -* sequential way. -* - iShij = iShell(1).eq.iShell(2) - iShkl = iShell(3).eq.iShell(4) - iShik = iShell(1).eq.iShell(3) - iShil = iShell(1).eq.iShell(4) - iShjk = iShell(2).eq.iShell(3) - iShjl = iShell(2).eq.iShell(4) - mijkl=iBas*jBas*kBas*lBas - Do 100 i1 = 1, iCmp - ix = 0 - Do j = 0, nIrrep-1 - If (iAOtSO(iAO(1)+i1,j)>0) ix = iOr(ix,2**j) - End Do - iSym(1)=ix - jCmpMx = jCmp - If (iShij) jCmpMx = i1 - iChBs = iChBas(ii+i1) - If (Shells(iShll(1))%Transf) iChBs = iChBas(iSphCr(ii+i1)) - pEa = xPrmt(iOper(kOp(1)),iChBs) - Do 200 i2 = 1, jCmpMx - ix = 0 - Do j = 0, nIrrep-1 - If (iAOtSO(iAO(2)+i2,j)>0) ix = iOr(ix,2**j) - End Do - iSym(2)=ix - jChBs = iChBas(jj+i2) - If (Shells(iShll(2))%Transf) jChBs = iChBas(iSphCr(jj+i2)) - pRb = xPrmt(iOper(kOp(2)),jChBs) - If (iShell(2).gt.iShell(1)) Then - i12 = jCmp*(i1-1) + i2 - Else - i12 = iCmp*(i2-1) + i1 - End If - Do 300 i3 = 1, kCmp - ix = 0 - Do j = 0, nIrrep-1 - If (iAOtSO(iAO(3)+i3,j)>0) ix = iOr(ix,2**j) - End Do - iSym(3)=ix - lCmpMx = lCmp - If (iShkl) lCmpMx = i3 - kChBs = iChBas(kk+i3) - If (Shells(iShll(3))%Transf) - & kChBs = iChBas(iSphCr(kk+i3)) - pTc = xPrmt(iOper(kOp(3)),kChBs) - Do 400 i4 = 1, lCmpMx - ix = 0 - Do j = 0, nIrrep-1 - If (iAOtSO(iAO(4)+i4,j)>0) ix = iOr(ix,2**j) - End Do - iSym(4)=ix - lChBs = iChBas(ll+i4) - If (Shells(iShll(4))%Transf) - & lChBs = iChBas(iSphCr(ll+i4)) - pTSd= xPrmt(iOper(kOp(4)),lChBs) - If (iShell(4).gt.iShell(3)) Then - i34 = lCmp*(i3-1) + i4 - Else - i34 = kCmp*(i4-1) + i3 - End If - If (Shijij .and. i34.gt.i12) Go To 400 - vijkl=0 - do ijkl=1,mijkl - vijkl=max(vijkl,abs(AOInt(ijkl,i1,i2,i3,i4))) - end do -c vijkl = DNrm2_(iBas*jBas*kBas*lBas, -c & AOInt(1,i1,i2,i3,i4),1) -C If (vijkl.lt.CutInt) Go To 400 -* - Qijij = Shijij .and. i12.eq.i34 - iQij = iShij.and.i1.eq.i2 - iQkl = iShkl.and.i3.eq.i4 - iQik = iShik.and.i1.eq.i3 - iQil = iShil.and.i1.eq.i4 - iQjk = iShjk.and.i2.eq.i3 - iQjl = iShjl.and.i2.eq.i4 - pFctr=pEa*pRb*pTc*pTSd -************************************************************************ -* - Fac_ij = pFctr - Fac_kl = pFctr - Fac_ik =-Quart * pFctr - Fac_jl =-Quart * pFctr - Fac_il =-Quart * pFctr - Fac_jk =-Quart * pFctr - If (iQij) Fac_ij = Fac_ij * Half - If (iQkl) Fac_kl = Fac_kl * Half - If (iQjl.and. .Not.iQik) Fac_ik = Fac_ik * Two - If (iQik.and. .Not.iQjl) Fac_jl = Fac_jl * Two - If (iQjk.and. .Not.iQil) Fac_il = Fac_il * Two - If (iQil.and. .Not.iQjk) Fac_jk = Fac_jk * Two -* - D_ij=Two - If (iQij) D_ij=One - D_kl=Two - If (iQkl) D_kl=One - D_ik=Two - If (iQik) D_ik=One - D_jl=Two - If (iQjl) D_jl=One - D_il=Two - If (iQil) D_il=One - D_jk=Two - If (iQjk) D_jk=One -* - Fac_ij=Fac_ij*D_kl - Fac_kl=Fac_kl*D_ij - Fac_jl=Fac_jl*D_ik - Fac_ik=Fac_ik*D_jl - Fac_jk=Fac_jk*D_il - Fac_il=Fac_il*D_jk -* -C Write (*,*) -C Write (*,*) 'iShell(1),iShell(2),i1,i2=', -C & iShell(1),iShell(2),i1,i2 -C Write (*,*) 'Dij=',Dij(1,i1,i2) -C Write (*,*) 'Fac_ij,iQij=',Fac_ij,iQij -C Write (*,*) -C Write (*,*) 'iShell(3),iShell(4),i3,i4=', -C & iShell(3),iShell(4),i3,i4 -C Write (*,*) 'Dkl=',Dkl(1,i3,i4) -C Write (*,*) 'Fac_kl,iQkl=',Fac_kl,iQkl -C Write (*,*) - If (Qijij) Then - Fac_kl = Zero - Fac_jk = Zero - End If - If (iQij.and.iQkl) Then - Fac_jl = Zero - Fac_il = Zero - Fac_jk = Zero - End If - If (iQij.or.iQkl) Then - Fac_il = Zero - Fac_jk = Zero - End If -************************************************************************ -* - iOpt=0 - ip = 1 - If (iAnd(iSym(1),iSym(2)).ne.0 .or. - & iAnd(iSym(3),iSym(4)).ne.0) Then - iOpt = iOpt + 1 -* - If (iShell(3).lt.iShell(4)) Then - vkl = Dkl(kBas*lBas+1,i4,i3) - ipDkl=ip - ip = ip + kBas*lBas - Call DGetMO(Dkl(1,i4,i3),kl1,kl1, - & kl2,Scrt(ipDkl),kl2) - Else - vkl = Dkl(kBas*lBas+1,i3,i4) - loc1=(ixLoc(Dkl(1,i3,i4))-ixLoc(Scrt)) - loc2=(ixLoc(Scrt(2))-ixLoc(Scrt(1))) - ipDkl = 1 + loc1/loc2 - End If - ipFij1 = ((i2-1)*iCmpa(1)+i1-1)*iBas*jBas - & + ipFij - If (iShell(1).lt.iShell(2)) Then - vij = Dij(iBas*jBas+1,i2,i1) - ipDij=ip - ip = ip + iBas*jBas - Call DGeTMO(Dij(1,i2,i1),ij1,ij1, - & ij2,Scrt(ipDij),ij2) - Else - vij = Dij(iBas*jBas+1,i1,i2) - loc1=(ixLoc(Dij(1,i1,i2))-ixLoc(Scrt)) - loc2=(ixLoc(Scrt(2))-ixLoc(Scrt(1))) - ipDij = 1 + loc1/loc2 - End If - ipFkl1 = ((i4-1)*iCmpa(3)+i3-1)*kBas*lBas - & + ipFkl - If (vkl*vijkl*Abs(Fac_ij).lt.ThrInt .and. - & vij*vijkl*Abs(Fac_kl).lt.ThrInt) Then - iOpt = iOpt -1 - Else - lFij=.True. - lFkl=.True. - End If - End If -* - If (iAnd(iSym(1),iSym(3)).ne.0 .or. - & iAnd(iSym(2),iSym(4)).ne.0) Then - iOpt = iOpt + 2 -* - If (iShell(2).lt.iShell(4)) Then - vjl=Djl(jBas*lBas+1,i4,i2) - ipDjl=ip - ip = ip + jBas*lBas - Call DGeTMO(Djl(1,i4,i2),jl1,jl1, - & jl2,Scrt(ipDjl),jl2) - Else - vjl=Djl(jBas*lBas+1,i2,i4) - loc1= (ixLoc(Djl(1,i2,i4))-ixLoc(Scrt)) - loc2=(ixLoc(Scrt(2))-ixLoc(Scrt(1))) - ipDjl = 1 + loc1/loc2 - End If - ipFik1 = ((i3-1)*iCmpa(1)+i1-1)*iBas*kBas - & + ipFik - If (iShell(1).lt.iShell(3)) Then - vik=Dik(iBas*kBas+1,i3,i1) - ipDik = ip - ip = ip + iBas*kBas - Call DGeTMO(Dik(1,i3,i1),ik1,ik1, - & ik2,Scrt(ipDik),ik2) - Else - vik=Dik(iBas*kBas+1,i1,i3) - loc1=(ixLoc(Dik(1,i1,i3))-ixLoc(Scrt)) - loc2=(ixLoc(Scrt(2))-ixLoc(Scrt(1))) - ipDik = 1 + loc1/loc2 - End If - ipFjl1 = ((i4-1)*iCmpa(2)+i2-1)*jBas*lBas - & + ipFjl - If (vik*vijkl*Abs(Fac_jl) .lt. ThrInt .and. - & vjl*vijkl*Abs(Fac_ik) .lt. ThrInt) Then - iOpt = iOpt - 2 - Else - lFik = .True. - lFjl = .True. - End If - End If -* - If (iAnd(iSym(1),iSym(4)).ne.0 .or. - & iAnd(iSym(2),iSym(3)).ne.0) Then - iOpt = iOpt + 4 -* - If (iShell(2).lt.iShell(3)) Then - vjk = Djk(jBas*kBas+1,i3,i2) - ipDjk = ip - ip = ip + jBas*kBas - Call DGeTMO(Djk(1,i3,i2),jk1,jk1, - & jk2,Scrt(ipDjk),jk2) - Else - vjk = Djk(jBas*kBas+1,i2,i3) - loc1=(ixLoc(Djk(1,i2,i3))-ixLoc(Scrt)) - loc2= (ixLoc(Scrt(2))-ixLoc(Scrt(1))) - ipDjk = 1 + loc1/loc2 - End If - ipFil1 = ((i4-1)*iCmpa(1)+i1-1)*iBas*lBas - & + ipFil - If (iShell(1).lt.iShell(4)) Then - vil = Dil(iBas*lBas+1,i4,i1) - ipDil = ip - ip = ip + iBas*lBas - Call DGeTMO(Dil(1,i4,i1),il1,il1, - & il2,Scrt(ipDil),il2) - Else - vil = Dil(iBas*lBas+1,i1,i4) - loc1= (ixLoc(Dil(1,i1,i4))-ixLoc(Scrt)) - loc2= (ixLoc(Scrt(2))-ixLoc(Scrt(1))) - ipDil = 1 + loc1/loc2 - End If - ipFjk1 = ((i3-1)*iCmpa(2)+i2-1)*jBas*kBas - & + ipFjk - If (vil*vijkl*Abs(Fac_jk) .lt. ThrInt .and. - & vjk*vijkl*Abs(Fac_il) .lt. ThrInt) Then - iOpt = iOpt -4 - Else - lFil = .True. - lFjk = .True. - End If - End If - If (ip-1.gt.nScrt) Then - Write (6,*) 'FckAcc: nScrt too small!' - Call Abend - End If - Go To ( 1, 2, 3, 4, 5, 6, 7) iOpt - Go To 400 -* * -************************************************************************ -* * - 1 Continue - Call Fck1(AOInt(1,i1,i2,i3,i4),iBas,jBas,kBas,lBas, - & Scrt(ipDij),FT(ipFij1),Fac_ij, - & Scrt(ipDkl),FT(ipFkl1),Fac_kl,ExFac) - Go To 400 - 2 Continue - Call Fck2(AOInt(1,i1,i2,i3,i4),iBas,jBas,kBas,lBas, - & Scrt(ipDik),FT(ipFik1),Fac_ik, - & Scrt(ipDjl),FT(ipFjl1),Fac_jl,ExFac) - Go To 400 - 3 Continue - Call Fck3(AOInt(1,i1,i2,i3,i4),iBas,jBas,kBas,lBas, - & Scrt(ipDij),FT(ipFij1),Fac_ij, - & Scrt(ipDkl),FT(ipFkl1),Fac_kl, - & Scrt(ipDik),FT(ipFik1),Fac_ik, - & Scrt(ipDjl),FT(ipFjl1),Fac_jl,ExFac) - Go To 400 - 4 Continue - Call Fck4(AOInt(1,i1,i2,i3,i4),iBas,jBas,kBas,lBas, - & Scrt(ipDil),FT(ipFil1),Fac_il, - & Scrt(ipDjk),FT(ipFjk1),Fac_jk,ExFac) - Go To 400 - 5 Continue - Call Fck5(AOInt(1,i1,i2,i3,i4),iBas,jBas,kBas,lBas, - & Scrt(ipDij),FT(ipFij1),Fac_ij, - & Scrt(ipDkl),FT(ipFkl1),Fac_kl, - & Scrt(ipDil),FT(ipFil1),Fac_il, - & Scrt(ipDjk),FT(ipFjk1),Fac_jk,ExFac) - Go To 400 - 6 Continue - Call Fck6(AOInt(1,i1,i2,i3,i4),iBas,jBas,kBas,lBas, - & Scrt(ipDik),FT(ipFik1),Fac_ik, - & Scrt(ipDjl),FT(ipFjl1),Fac_jl, - & Scrt(ipDil),FT(ipFil1),Fac_il, - & Scrt(ipDjk),FT(ipFjk1),Fac_jk,ExFac) - Go To 400 - 7 Continue - Call Fck7(AOInt(1,i1,i2,i3,i4),iBas,jBas,kBas,lBas, - & Scrt(ipDij),FT(ipFij1),Fac_ij, - & Scrt(ipDkl),FT(ipFkl1),Fac_kl, - & Scrt(ipDik),FT(ipFik1),Fac_ik, - & Scrt(ipDjl),FT(ipFjl1),Fac_jl, - & Scrt(ipDil),FT(ipFil1),Fac_il, - & Scrt(ipDjk),FT(ipFjk1),Fac_jk,ExFac) - Go To 400 -************************************************************************ -* - 400 Continue - 300 Continue - 200 Continue - 100 Continue -* - nnIrrep=nIrrep - If (sIrrep) nnIrrep=1 - Do iIrrep=0,nnIrrep-1 -* - If (pert(iIrrep)) Then - ip=ipDisp(abs(indgrd(iCar,iCent,iIrrep))) - rCh=xPrmt(iOper(kOp(iCent)),iChBas(1+iCar))* - & DBLE(iChTbl(iIrrep,kOp(iCent))) - Fact=tfact*rCh -* Write (*,*) 'Level ij' - If (lFij) Call FckDst(TwoHam(ip),ndens,FT(ipFij), - & iBas,jBas,iCmpa(1),iCmpa(2), - & kOp2(1),kOp2(2), - & iIrrep, - & iShij, - & iAO(1),iAO(2),iAOst(1),iAOst(2), - & fact) -* Write (*,*) 'Level kl' - If (lFkl) Call FckDst(TwoHam(ip),ndens,FT(ipFkl), - & kBas,lBas,iCmpa(3),iCmpa(4), - & kOp2(3),kOp2(4), - & iIrrep, - & iShkl, - & iAO(3),iAO(4),iAOst(3),iAOst(4), - & fact) -* Write (*,*) 'Level ik' - If (lFik) Call FckDst(TwoHam(ip),ndens,FT(ipFik), - & iBas,kBas,iCmpa(1),iCmpa(3), - & kOp2(1),kOp2(3), - & iIrrep, - & iShik, - & iAO(1),iAO(3),iAOst(1),iAOst(3), - & fact) -* Write (*,*) 'Level jl' - If (lFjl) Call FckDst(TwoHam(ip),ndens,FT(ipFjl), - & jBas,lBas,iCmpa(2),iCmpa(4), - & kOp2(2),kOp2(4), - & iIrrep, - & iShjl, - & iAO(2),iAO(4),iAOst(2),iAOst(4), - & fact) -* Write (*,*) 'Level il' - If (lFil) Call FckDst(TwoHam(ip),ndens,FT(ipFil), - & iBas,lBas,iCmpa(1),iCmpa(4), - & kOp2(1),kOp2(4), - & iIrrep, - & iShil, - & iAO(1),iAO(4),iAOst(1),iAOst(4), - & fact) -* Write (*,*) 'Level jk' - If (lFjk) Call FckDst(TwoHam(ip),ndens,FT(ipFjk), - & jBas,kBas,iCmpa(2),iCmpa(3), - & kOp2(2),kOp2(3), - & iIrrep, - & iShjk, - & iAO(2),iAO(3),iAOst(2),iAOst(3), - & fact) - End If - End Do -* - Return - End -#endif diff -Nru openmolcas-22.02/src/mckinley/fckacc_mck.F90 openmolcas-22.10/src/mckinley/fckacc_mck.F90 --- openmolcas-22.02/src/mckinley/fckacc_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/fckacc_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,978 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993,1998, Roland Lindh * +!*********************************************************************** + +subroutine FckAcc_Mck(iAng,iCmp,jCmp,kCmp,lCmp,Shijij,iShll,iShell,kOp,nijkl,AOInt,TwoHam,nDens,Scrt,nScrt,iAO,iAOst,iBas,jBas, & + kBas,lBas,Dij,ij1,ij2,ij3,ij4,Dkl,kl1,kl2,kl3,kl4,Dik,ik1,ik2,ik3,ik4,Dil,il1,il2,il3,il4,Djk,jk1,jk2,jk3, & + jk4,Djl,jl1,jl2,jl3,jl4,FT,nFT,tfact,iCar,iCent,pert,indgrd,ipdisp) + +#define _USE_OLD_CODE_ +#ifdef _USE_OLD_CODE_ + +!*********************************************************************** +! * +! Object: to accumulate contributions from the AO integrals directly * +! to the symmatry adapted Fock matrix. * +! * +! The indices has been scrambled before calling this routine. * +! Hence we must take special care in order to regain the can- * +! onical order. * +! * +! In addition to this complication we have that the order of * +! indicies in the integrals are not ordered canonically but * +! rather in an order such that the contraction step will be * +! optimal. Hence, special care has to be taken when tracing * +! the density with the integrals so that both entities have * +! the same order. * +! * +! The Fock matrix is computed in lower triangular form. * +! * +! The density matrix is not folded if the shell indices and * +! the angular indices are identical. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, Sweden. February '93 * +!*********************************************************************** + +use McKinley_global, only: sIrrep +use Index_Functions, only: nTri3_Elem +use Basis_Info, only: Shells +use Symmetry_Info, only: iChBas, iChTbl, iOper, nIrrep, Prmt +use SOAO_Info, only: iAOtSO +use Real_Spherical, only: iSphCr +use Gateway_Info, only: CutInt +use Constants, only: Zero, One, Two, Four, Half, Quart +use Definitions, only: wp, iwp, u6, r8 + +implicit none +integer(kind=iwp), intent(in) :: iAng(4), iCmp, jCmp, kCmp, lCmp, iShll(4), iShell(4), kOp(4), nijkl, nDens, nScrt, iAO(4), & + iAOst(4), iBas, jBas, kBas, lBas, ij1, ij2, ij3, ij4, kl1, kl2, kl3, kl4, ik1, ik2, ik3, ik4, & + il1, il2, il3, il4, jk1, jk2, jk3, jk4, jl1, jl2, jl3, jl4, nFT, iCar, iCent, & + indgrd(3,4,0:nirrep-1), ipdisp(*) +logical(kind=iwp), intent(in) :: Shijij, Pert(0:nIrrep-1) +real(kind=wp), intent(in) :: AOInt(nijkl,iCmp,jCmp,kCmp,lCmp), Dij(ij1*ij2+1,ij3,ij4), Dkl(kl1*kl2+1,kl3,kl4), & + Dik(ik1*ik2+1,ik3,ik4), Dil(il1*il2+1,il3,il4), Djk(jk1*jk2+1,jk3,jk4), Djl(jl1*jl2+1,jl3,jl4), tfact +real(kind=wp), intent(inout) :: TwoHam(nDens) +real(kind=wp), intent(out) :: Scrt(nScrt), FT(nFT) +integer(kind=iwp) :: i, i1, i12, i2, i3, i34, i4, iChBs, iCmpa(4), ii, iIn, iIrrep, ijkl, iljk, iOut, ip, ipD, ipFij, ipFij1, & + ipFik, ipFik1, ipFil, ipFil1, ipFjk, ipFjk1, ipFjl, ipFjl1, ipFkl, ipFkl1, iSym(4,0:7), j, jChBs, jCmpMx, jj, & + k, kChBs, kk, kOp2(4), l, lChBs, lCmpMx, ll, mFij, mFik, mFil, mFjk, mFjl, mFkl, nFij, nFik, nFil, nFjk, & + nFjl, nFkl, nij, nik, nil, njk, njl, nkl, nnIrrep, np +real(kind=wp) :: D_ij, D_ik, D_il, D_jk, D_jl, D_kl, Fac, Fact, pEa, pFctr, pRb, pTc, pTSd, qFctr, rCh, vij, vijkl, vik, vil, vjk, & + vjl, vkl +logical(kind=iwp) :: iQij, iQik, iQil, iQjk, iQjl, iQkl, iShij, iShik, iShil, iShjk, iShjl, iShkl, lFij, lFik, lFil, lFjk, lFjl, & + lFkl, Qijij, Shij, Shkl +real(kind=r8), external :: DNrm2_ + +!iprint = 0 + +!write(u6,*) DDot_(nijkl*iCmp*jCmp*kCmp*lCmp,AOInt,1,AOInt,1),DDot_(nijkl*iCmp*jCmp*kCmp*lCmp,AOInt,1,One,0) +!if (iPrint >= 49) then +! if ((DDot_(nijkl*iCmp*jCmp*kCmp*lCmp,AOInt,1,AOInt,1) > Zero) .or. (DDot_(nijkl*iCmp*jCmp*kCmp*lCmp,AOInt,1,One,0) > Zero)) then +! call RecPrt('Dik','(5G20.10)',Dik,ik1*ik2+1,ik3*ik4) +! write(u6,'(A,2G20.10)') & +! ' FckAcc:AOIn',DDot_(nijkl*iCmp*jCmp*kCmp*lCmp,AOInt,1,AOInt,1), DDot_(nijkl*iCmp*jCmp*kCmp*lCmp,AOInt,1,One,0) +! end if +!end if +!if (iPrint >= 99) then +! call RecPrt('FckAcc:AOInt','(5G20.10)',AOInt,nijkl,iCmp*jCmp*kCmp*lCmp) +! write(u6,'(A,G20.10)') 'Dij=',XDot(Dij,ij1,ij2,ij3,ij4) +! write(u6,'(A,G20.10)') 'Dkl=',XDot(Dkl,kl1,kl2,kl3,kl4) +! write(u6,'(A,G20.10)') 'Dik=',XDot(Dik,ik1,ik2,ik3,ik4) +! write(u6,'(A,G20.10)') 'Dil=',XDot(Dil,il1,il2,il3,il4) +! write(u6,'(A,G20.10)') 'Djk=',XDot(Djk,jk1,jk2,jk3,jk4) +! write(u6,'(A,G20.10)') 'Djl=',XDot(Djl,jl1,jl2,jl3,jl4) +!end if + +!write(u6,'(A,8L1)') 'Pert=',Pert +if (iBas*jBas*kBas*lBas > nScrt) then + write(u6,*) 'FckAcc_McK: iBas*jBas*kBas*lBas > nScrt' + write(u6,*) 'iBas,jBas,kBas,lBas,nScrt=',iBas,jBas,kBas,lBas,nScrt + call Abend() +end if +ii = nTri3_Elem(iAng(1)) +jj = nTri3_Elem(iAng(2)) +kk = nTri3_Elem(iAng(3)) +ll = nTri3_Elem(iAng(4)) +kOp2(1) = iOper(kOp(1)) +kOp2(2) = iOper(kOp(2)) +kOp2(3) = iOper(kOp(3)) +kOp2(4) = iOper(kOp(4)) +iCmpa(1) = iCmp +iCmpa(2) = jCmp +iCmpa(3) = kCmp +iCmpa(4) = lCmp +lFij = .false. +lFkl = .false. +lFik = .false. +lFjl = .false. +lFil = .false. +lFjk = .false. + +ipFij = 1 +nFij = iBas*jBas*iCmpa(1)*iCmpa(2) + +ipFkl = ipFij+nFij +nFkl = kBas*lBas*iCmpa(3)*iCmpa(4) + +ipFik = ipFkl+nFkl +nFik = iBas*kBas*iCmpa(1)*iCmpa(3) + +ipFjl = ipFik+nFik +nFjl = jBas*lBas*iCmpa(2)*iCmpa(4) + +ipFil = ipFjl+nFjl +nFil = iBas*lBas*iCmpa(1)*iCmpa(4) + +ipFjk = ipFil+nFil +nFjk = jBas*kBas*iCmpa(2)*iCmpa(3) + +FT(ipFij:ipFjk+nFjk-1) = Zero + +! Quadruple loop over elements of the basis functions angular +! description. Loops are reduced to just produce unique SO integrals +! Observe that we will walk through the memory in AOInt in a +! sequential way. + +Shij = iShell(1) == iShell(2) +Shkl = iShell(3) == iShell(4) +iShij = iShell(1) == iShell(2) +iShkl = iShell(3) == iShell(4) +iShik = iShell(1) == iShell(3) +iShil = iShell(1) == iShell(4) +iShjk = iShell(2) == iShell(3) +iShjl = iShell(2) == iShell(4) +do i1=1,iCmp + do j=0,nIrrep-1 + iSym(1,j) = 0 + if (iAOtSO(iAO(1)+i1,j) > 0) iSym(1,j) = 2**j + end do + jCmpMx = jCmp + if (Shij) jCmpMx = i1 + iChBs = iChBas(ii+i1) + if (Shells(iShll(1))%Transf) iChBs = iChBas(iSphCr(ii+i1)) + pEa = Prmt(iOper(kOp(1)),iChBs) + do i2=1,jCmpMx + do j=0,nIrrep-1 + iSym(2,j) = 0 + if (iAOtSO(iAO(2)+i2,j) > 0) iSym(2,j) = 2**j + end do + jChBs = iChBas(jj+i2) + if (Shells(iShll(2))%Transf) jChBs = iChBas(iSphCr(jj+i2)) + pRb = Prmt(iOper(kOp(2)),jChBs) + !Qij = i1 == i2 + if (iShell(2) > iShell(1)) then + i12 = jCmp*(i1-1)+i2 + else + i12 = iCmp*(i2-1)+i1 + end if + do i3=1,kCmp + do j=0,nIrrep-1 + iSym(3,j) = 0 + if (iAOtSO(iAO(3)+i3,j) > 0) iSym(3,j) = 2**j + end do + lCmpMx = lCmp + if (Shkl) lCmpMx = i3 + kChBs = iChBas(kk+i3) + if (Shells(iShll(3))%Transf) kChBs = iChBas(iSphCr(kk+i3)) + pTc = Prmt(iOper(kOp(3)),kChBs) + do i4=1,lCmpMx + do j=0,nIrrep-1 + iSym(4,j) = 0 + if (iAOtSO(iAO(4)+i4,j) > 0) iSym(4,j) = 2**j + end do + !Qkl = i3 == i4 + lChBs = iChBas(ll+i4) + if (Shells(iShll(4))%Transf) lChBs = iChBas(iSphCr(ll+i4)) + pTSd = Prmt(iOper(kOp(4)),lChBs) + if (iShell(4) > iShell(3)) then + i34 = lCmp*(i3-1)+i4 + else + i34 = kCmp*(i4-1)+i3 + end if + if (Shijij .and. (i34 > i12)) cycle + Qijij = Shijij .and. (i12 == i34) + iQij = iShij .and. (i1 == i2) + iQkl = iShkl .and. (i3 == i4) + iQik = iShik .and. (i1 == i3) + iQil = iShil .and. (i1 == i4) + iQjk = iShjk .and. (i2 == i3) + iQjl = iShjl .and. (i2 == i4) + pFctr = pEa*pRb*pTc*pTSd + + mFij = 0 + mFkl = 0 + mFik = 0 + mFjl = 0 + mFil = 0 + mFjk = 0 + do iIrrep=0,nIrrep-1 + if ((iSym(1,iIrrep) /= 0) .and. (iSym(2,iIrrep) /= 0)) mFkl = mFkl+1 + if ((iSym(3,iIrrep) /= 0) .and. (iSym(4,iIrrep) /= 0)) mFij = mFij+1 + if ((iSym(1,iIrrep) /= 0) .and. (iSym(3,iIrrep) /= 0)) mFjl = mFjl+1 + if ((iSym(2,iIrrep) /= 0) .and. (iSym(4,iIrrep) /= 0)) mFik = mFik+1 + if ((iSym(1,iIrrep) /= 0) .and. (iSym(4,iIrrep) /= 0)) mFjk = mFjk+1 + if ((iSym(2,iIrrep) /= 0) .and. (iSym(3,iIrrep) /= 0)) mFil = mFil+1 + end do + if (mFij+mFkl+mFik+mFjl+mFil+mFjk == 0) cycle + + vijkl = DNrm2_(iBas*jBas*kBas*lBas,AOInt(:,i1,i2,i3,i4),1) + if (vijkl < CutInt) cycle + !*************************************************************** + ! * + ! Fij = hij + Sum(kl) Dkl {(ij|kl)-1/2(ik|jl)} * + ! * + ! or * + ! * + ! Fij = hij + Sum(k=>l) Dkl {(2-d(kl)} P(ij|kl) * + ! * + ! where P(ij|kl)=(ij|kl)-1/4(ik|jl)-1/4(il|jk) * + ! * + ! or in the case of no sum restriction * + ! * + ! P(ij|kl) = (ij|kl) - 1/2(ik|jl) * + ! * + ! Coloumb Contributions * + ! * + ! Fij = Dkl * (ij|kl) * + ! * + ! Order density matrix in accordance with the integrals * + ! * + !*************************************************************** + if (mFij /= 0) then + if (iShell(3) < iShell(4)) then + vkl = Dkl(kBas*lBas+1,i4,i3) + else + vkl = Dkl(kBas*lBas+1,i3,i4) + end if + + ! Pickup the right column of the density matrix and + ! change order if not canonical. + + qFctr = One + ipFij1 = ((i2-1)*iCmpa(1)+i1-1)*iBas*jBas+ipFij + Fac = One + if (iQij) Fac = Half + D_kl = Two + if (iQkl) D_kl = One + Fac = Fac*D_kl + if (vkl*vijkl*abs(Fac*qFctr*pFctr) >= CutInt) then + if (iShell(3) < iShell(4)) then + call DGetMO(Dkl(:,i4,i3),kl1,kl1,kl2,Scrt,kl2) + call dGeMV_('N',iBas*jBas,kBas*lBas,Fac*qFctr*pFctr,AOInt(:,i1,i2,i3,i4),iBas*jBas,Scrt,1,One,FT(ipFij1),1) + else + call dGeMV_('N',iBas*jBas,kBas*lBas,Fac*qFctr*pFctr,AOInt(:,i1,i2,i3,i4),iBas*jBas,Dkl(:,i3,i4),1,One,FT(ipFij1),1) + end if + !call RecPrt('Fij',' ',FT(ipFij1),iBas,jBas) + lFij = .true. + end if + end if + ! Fkl = Dij * (ij|kl) + if ((.not. Qijij) .and. (mFkl /= 0)) then + if (iShell(1) < iShell(2)) then + vij = Dij(iBas*jBas+1,i2,i1) + else + vij = Dij(iBas*jBas+1,i1,i2) + end if + qFctr = One + ipFkl1 = ((i4-1)*iCmpa(3)+i3-1)*kBas*lBas+ipFkl + Fac = One + if (iQkl) Fac = Half + D_ij = Two + if (iQij) D_ij = One + Fac = Fac*D_ij + if (vij*vijkl*abs(Fac*qFctr*pFctr) >= CutInt) then + if (iShell(1) < iShell(2)) then + call DGeTMO(Dij(:,i2,i1),ij1,ij1,ij2,Scrt,ij2) + call dGeMV_('T',iBas*jBas,kBas*lBas,Fac*qFctr*pFctr,AOInt(:,i1,i2,i3,i4),iBas*jBas,Scrt,1,One,FT(ipFkl1),1) + else + call dGeMV_('T',iBas*jBas,kBas*lBas,Fac*qFctr*pFctr,AOInt(:,i1,i2,i3,i4),iBas*jBas,Dij(:,i1,i2),1,One,FT(ipFkl1),1) + end if + !call RecPrt('Fkl',' ',FT(ipFkl1),kBas,lBas) + lFkl = .true. + end if + end if + + ! Exchange contributions + + ! Change the order ijkl to ikjl. Make sure also that + ! the index pairs are canonical. + + ipD = 1+iBas*jBas*kBas*lBas + np = ipD-1+max(iBas*lBas,jBas*lBas,iBas*kBas,jBas*kBas) + if (np > nScrt) then + write(u6,*) 'FckAcc_McK: np > nScrt' + write(u6,*) 'np,nScrt=',np,nScrt + call Abend() + end if + if (mFik+mFjl /= 0) then + if ((mFik /= 0) .and. (iShell(2) < iShell(4))) then + vjl = Djl(jBas*lBas+1,i4,i2) + else if (mFik /= 0) then + vjl = Djl(jBas*lBas+1,i2,i4) + else + vjl = Zero + end if + if ((mFjl /= 0) .and. (iShell(1) < iShell(3))) then + vik = Dik(iBas*kBas+1,i3,i1) + else if (mFjl /= 0) then + vik = Dik(iBas*kBas+1,i1,i3) + else + vik = Zero + end if + if ((vik*vijkl/Four >= CutInt) .or. (vjl*vijkl/Four >= CutInt)) then + do j=1,jBas + nij = (j-1)*iBas+1 + do k=1,kBas + nik = (k-1)*iBas+1 + do l=1,lBas + nkl = (l-1)*kBas+k + njl = (l-1)*jBas+j + iOut = (nkl-1)*iBas*jBas+nij + iIn = (njl-1)*iBas*kBas+nik + Scrt(iIn:iIn+iBas-1) = AOInt(iOut:iOut+iBas-1,i1,i2,i3,i4) + end do + end do + end do + !*********************************************************** + ! * + ! Fik = - 1/4 * Djl * P(jl|ik) * + ! * + ! P(jl|ik) = (jl|ik) - 1/4(ji|lk) - 1/4(jk|il) * + ! * + ! P(jl|ik) = (jl|ik) - 1/2(ji|lk) * + ! * + ! Change factor if * + ! a) asymmetrical P matrix is implied * + ! b) if the two exchange integrals in the symmetrical * + ! P matrix are identical. * + ! * + !*********************************************************** + if (mFik /= 0) then + qFctr = One + ipFik1 = ((i3-1)*iCmpa(1)+i1-1)*iBas*kBas+ipFik + Fac = -Quart + if (iQjl .and. (.not. iQik)) Fac = -Half + D_jl = Two + if (iQjl) D_jl = One + Fac = Fac*D_jl + if (vjl*vijkl*abs(Fac*qFctr*pFctr) >= CutInt) then + if (iShell(2) < iShell(4)) then + call DGeTMO(Djl(:,i4,i2),jl1,jl1,jl2,Scrt(ipD),jl2) + call dGeMV_('N',iBas*kBas,jBas*lBas,Fac*qFctr*pFctr,Scrt,iBas*kBas,Scrt(ipD),1,One,FT(ipFik1),1) + else + call dGeMV_('N',iBas*kBas,jBas*lBas,Fac*qFctr*pFctr,Scrt,iBas*kBas,Djl(:,i2,i4),1,One,FT(ipFik1),1) + end if + !call RecPrt('Fik',' ',FT(ipFik1),iBas,kBas) + lFik = .true. + end if + end if + if ((.not. iQij) .or. (.not. iQkl)) then + !********************************************************* + ! * + ! Fjl = - 1/4 * Dik * P(jl|ik) * + ! * + ! P(jl|ik) = (jl|ik) - 1/4(ji|lk) - 1/4(jk|il) * + ! * + ! P(jl|ik) = (jl|ik) - 1/2(ji|lk) * + ! * + !********************************************************* + if (mFjl /= 0) then + qFctr = One + ipFjl1 = ((i4-1)*iCmpa(2)+i2-1)*jBas*lBas+ipFjl + Fac = -Quart + if (iQik .and. (.not. iQjl)) Fac = -Half + D_ik = Two + if (iQik) D_ik = One + Fac = Fac*D_ik + if (vik*vijkl*abs(Fac*qFctr*pFctr) >= CutInt) then + if (iShell(1) < iShell(3)) then + call DGeTMO(Dik(:,i3,i1),ik1,ik1,ik2,Scrt(ipD),ik2) + call dGeMV_('T',iBas*kBas,jBas*lBas,Fac*qFctr*pFctr,Scrt,iBas*kBas,Scrt(ipD),1,One,FT(ipFjl1),1) + else + call dGeMV_('T',iBas*kBas,jBas*lBas,Fac*qFctr*pFctr,Scrt,iBas*kBas,Dik(:,i1,i3),1,One,FT(ipFjl1),1) + end if + !call RecPrt('Fjl',' ',FT(ipFjl1),jBas,lBas) + lFjl = .true. + end if + end if + end if + end if + end if + + ! Change order ijkl to iljk + + if ((.not. iQij) .and. (.not. iQkl) .and. (mFil+mFjk /= 0)) then + if ((mFil /= 0) .and. (iShell(2) < iShell(3))) then + vjk = Djk(jBas*kBas+1,i3,i2) + else if (mFil /= 0) then + vjk = Djk(jBas*kBas+1,i2,i3) + else + vjk = Zero + end if + if ((mFjk /= 0) .and. (iShell(1) < iShell(4))) then + vil = Dil(iBas*lBas+1,i4,i1) + else if (mFjk /= 0) then + vil = Dil(iBas*lBas+1,i1,i4) + else + vil = Zero + end if + if ((vil*vijkl/Four >= CutInt) .or. (vjk*vijkl/Four >= CutInt)) then + i = 1 + do j=1,jBas + nij = (j-1)*iBas+i + do k=1,kBas + njk = (k-1)*jBas+j + do l=1,lBas + nkl = (l-1)*kBas+k + nil = (l-1)*iBas+i + ijkl = (nkl-1)*iBas*jBas+nij + iljk = (njk-1)*iBas*lBas+nil + Scrt(iljk:iljk+iBas-1) = AOInt(ijkl:ijkl+iBas-1,i1,i2,i3,i4) + end do + end do + end do + ! Fil = - 1/4 * Djk * (ij|kl) + if (mFil /= 0) then + qFctr = One + ipFil1 = ((i4-1)*iCmpa(1)+i1-1)*iBas*lBas+ipFil + Fac = -Quart + if (iQjk .and. (.not. iQil)) Fac = -Half + D_jk = Two + if (iQjk) D_jk = One + Fac = Fac*D_jk + if (vjk*vijkl*abs(Fac*qFctr*pFctr) >= CutInt) then + if (iShell(2) < iShell(3)) then + call DGeTMO(Djk(:,i3,i2),jk1,jk1,jk2,Scrt(ipD),jk2) + call dGeMV_('N',iBas*lBas,jBas*kBas,Fac*qFctr*pFctr,Scrt,iBas*lBas,Scrt(ipD),1,One,FT(ipFil1),1) + else + call dGeMV_('N',iBas*lBas,jBas*kBas,Fac*qFctr*pFctr,Scrt,iBas*lBas,Djk(:,i2,i3),1,One,FT(ipFil1),1) + end if + !call RecPrt('Fil',' ',FT(ipFil1),iBas,lBas) + lFil = .true. + end if + end if + ! Fjk = - 1/4 * Dil * (ij|kl) + if ((.not. Qijij) .and. (mFjk /= 0)) then + qFctr = One + ipFjk1 = ((i3-1)*iCmpa(2)+i2-1)*jBas*kBas+ipFjk + Fac = -Quart + if (iQil .and. (.not. iQjk)) Fac = -Half + D_il = Two + if (iQil) D_il = One + Fac = Fac*D_il + if (vil*vijkl*abs(Fac*qFctr*pFctr) >= CutInt) then + if (iShell(1) < iShell(4)) then + call DGeTMO(Dil(:,i4,i1),il1,il1,il2,Scrt(ipD),il2) + call dGeMV_('T',iBas*lBas,jBas*kBas,Fac*qFctr*pFctr,Scrt,iBas*lBas,Scrt(ipD),1,One,FT(ipFjk1),1) + else + call dGeMV_('T',iBas*lBas,jBas*kBas,Fac*qFctr*pFctr,Scrt,iBas*lBas,Dil(:,i1,i4),1,One,FT(ipFjk1),1) + end if + !call RecPrt('Fjk',' ',FT(ipFjk1),jBas,kBas) + lFjk = .true. + end if + end if + end if + end if + + end do + end do + end do +end do + +!write(u6,*) ' Fij' +nnIrrep = nIrrep +if (sIrrep) nnIrrep = 1 +do iIrrep=0,nnIrrep-1 + !write(u6,'(I2,L1)') iIrrep,pert(iIrrep) + if (pert(iIrrep)) then + ip = ipDisp(abs(indgrd(iCar,iCent,iIrrep))) + rCh = Prmt(iOper(kOp(iCent)),iChBas(1+iCar))*real(iChTbl(iIrrep,kOp(iCent)),kind=wp) + Fact = tfact*rCh + !write(u6,*) 'Level ij' + if (lFij) call FckDst(TwoHam(ip),ndens,FT(ipFij),iBas,jBas,iCmpa(1),iCmpa(2),kOp2(1),kOp2(2),iIrrep,iShij,iAO(1),iAO(2), & + iAOst(1),iAOst(2),fact) + !write(u6,*) 'Level kl' + if (lFkl) call FckDst(TwoHam(ip),ndens,FT(ipFkl),kBas,lBas,iCmpa(3),iCmpa(4),kOp2(3),kOp2(4),iIrrep,iShkl,iAO(3),iAO(4), & + iAOst(3),iAOst(4),fact) + !write(u6,*) 'Level ik' + if (lFik) call FckDst(TwoHam(ip),ndens,FT(ipFik),iBas,kBas,iCmpa(1),iCmpa(3),kOp2(1),kOp2(3),iIrrep,iShik,iAO(1),iAO(3), & + iAOst(1),iAOst(3),fact) + !write(u6,*) 'Level jl' + if (lFjl) call FckDst(TwoHam(ip),ndens,FT(ipFjl),jBas,lBas,iCmpa(2),iCmpa(4),kOp2(2),kOp2(4),iIrrep,iShjl,iAO(2),iAO(4), & + iAOst(2),iAOst(4),fact) + !write(u6,*) 'Level il' + if (lFil) call FckDst(TwoHam(ip),ndens,FT(ipFil),iBas,lBas,iCmpa(1),iCmpa(4),kOp2(1),kOp2(4),iIrrep,iShil,iAO(1),iAO(4), & + iAOst(1),iAOst(4),fact) + !write(u6,*) 'Level jk' + if (lFjk) call FckDst(TwoHam(ip),ndens,FT(ipFjk),jBas,kBas,iCmpa(2),iCmpa(3),kOp2(2),kOp2(3),iIrrep,iShjk,iAO(2),iAO(3), & + iAOst(2),iAOst(3),fact) + !if (DDot_(3468,TwoHam,1,TwoHam,1) > Zero) then + ! if (Abs(DDot_(3468,TwoHam,1,One,0)) > 1.0e-16_wp) then + ! write(u6,'(A,G20.6,G20.7)') 'TwoHam=',DDot_(3468,TwoHam,1,TwoHam,1),DDot_(3468,TwoHam,1,One,0) + ! else + ! write(u6,'(A,G20.6)') 'TwoHam=',DDot_(3468,TwoHam,1,TwoHam,1) + ! end if + ! TwoHam(1:3468) = Zero + !end if + end if +end do + +return + +#else + +!*********************************************************************** +! * +! Object: to accumulate contributions from the AO integrals directly * +! to the symmatry adapted Fock matrix. * +! * +! The indices has been scrambled before calling this routine. * +! Hence we must take special care in order to regain the can- * +! onical order. * +! * +! In addition to this complication we have that the order of * +! indicies in the integrals are not ordered canonically but * +! rather in an order such that the contraction step will be * +! optimal. Hence, special care has to be taken when tracing * +! the density with the integrals so that both entities have * +! the same order. * +! * +! The Fock matrix is computed in lower triangular form. * +! * +! The density matrix is not folded if the shell indices and * +! the angular indices are identical. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, Sweden. February '93 * +! * +! Modified July '98 in Tokyo by R. Lindh * +!*********************************************************************** + +use McKinley_global, only: sIrrep +use Index_Functions, only: nTri3_Elem +use Basis_Info, only: Shells +use Symmetry_Info, only: iChBas, iChTbl, iOper, nIrrep, Prmt +use SOAO_Info, only: iAOtSO +use Real_Spherical, only: iSphCr +use Gateway_Info, only: ThrInt !, CutInt +use Constants, only: Zero, One, Two, Half, Quart +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iAng(4), iCmp, jCmp, kCmp, lCmp, iShll(4), iShell(4), kOp(4), nijkl, nDens, nScrt, iAO(4), & + iAOst(4), iBas, jBas, kBas, lBas, ij1, ij2, ij3, ij4, kl1, kl2, kl3, kl4, ik1, ik2, ik3, ik4, & + il1, il2, il3, il4, jk1, jk2, jk3, jk4, jl1, jl2, jl3, jl4, nFT, iCar, iCent, & + indgrd(3,4,0:nirrep-1), ipdisp(*) +logical(kind=iwp), intent(in) :: Shijij, Pert(0:nIrrep-1) +real(kind=wp), intent(in) :: AOInt(nijkl,iCmp,jCmp,kCmp,lCmp), Dij(ij1*ij2+1,ij3,ij4), Dkl(kl1*kl2+1,kl3,kl4), & + Dik(ik1*ik2+1,ik3,ik4), Dil(il1*il2+1,il3,il4), Djk(jk1*jk2+1,jk3,jk4), Djl(jl1*jl2+1,jl3,jl4), tfact +real(kind=wp), intent(inout) :: TwoHam(nDens) +real(kind=wp), intent(out) :: Scrt(nScrt), FT(nFT) +integer(kind=iwp) :: i1, i12, i2, i3, i34, i4, iChBs, iCmpa(4), ii, iIrrep, ijkl, iOpt, ip, ipDij, ipDik, ipDil, ipDjk, ipDjl, & + ipDkl, ipFij, ipFij1, ipFik, ipFik1, ipFil, ipFil1, ipFjk, ipFjk1, ipFjl, ipFjl1, ipFkl, ipFkl1, iSym(4), ix, & + j, jChBs, jCmpMx, jj, kChBs, kk, kOp2(4), lChBs, lCmpMx, ll, loc1, loc2, mijkl, nFij, nFik, nFil, nFjk, nFjl, & + nFkl, nnIrrep +real(kind=wp) :: D_ij, D_ik, D_il, D_jk, D_jl, D_kl, ExFac, Fac_ij, Fac_ik, Fac_il, Fac_jk, Fac_jl, Fac_kl, Fact, pEa, pFctr, pRb, & + pTc, pTSd, rCh, vij, vijkl, vik, vil, vjk, vjl, vkl +logical(kind=iwp) :: iQij, iQik, iQil, iQjk, iQjl, iQkl, iShij, iShik, iShil, iShjk, iShjl, iShkl, lFij, lFik, lFil, lFjk, lFjl, & + lFkl, Qijij + +!iRout = 38 +!iPrint = nPrint(iRout) +! +!if (iPrint >= 49) then +! write(u6,*) ' FckAcc:AOIn',DDot_(nijkl*iCmp*jCmp*kCmp*lCmp,AOInt,1,AOInt,1), DDot_(nijkl*iCmp*jCmp*kCmp*lCmp,AOInt,1,One,0) +!end if +!if (iPrint >= 99) then +! call RecPrt('FckAcc:AOInt',' ',AOInt,nijkl,iCmp*jCmp*kCmp*lCmp) +! write(u6,*) 'Dij=',XDot(Dij,ij1,ij2,ij3,ij4) +! write(u6,*) 'Dkl=',XDot(Dkl,kl1,kl2,kl3,kl4) +! write(u6,*) 'Dik=',XDot(Dik,ik1,ik2,ik3,ik4) +! write(u6,*) 'Dil=',XDot(Dil,il1,il2,il3,il4) +! write(u6,*) 'Djk=',XDot(Djk,jk1,jk2,jk3,jk4) +! write(u6,*) 'Djl=',XDot(Djl,jl1,jl2,jl3,jl4) +!end if + +ExFac = One +ThrInt = Zero +if (iBas*jBas*kBas*lBas > nScrt) then + write(u6,*) 'FckAcc: nScrt too small!' + call Abend() +end if +ii = nTri3_Elem(iAng(1)) +jj = nTri3_Elem(iAng(2)) +kk = nTri3_Elem(iAng(3)) +ll = nTri3_Elem(iAng(4)) + +kOp2(1) = iOper(kOp(1)) +kOp2(2) = iOper(kOp(2)) +kOp2(3) = iOper(kOp(3)) +kOp2(4) = iOper(kOp(4)) +iCmpa(1) = iCmp +iCmpa(2) = jCmp +iCmpa(3) = kCmp +iCmpa(4) = lCmp +lFij = .false. +lFkl = .false. +lFik = .false. +lFjl = .false. +lFil = .false. +lFjk = .false. + +ipFij = 1 +nFij = iBas*jBas*iCmpa(1)*iCmpa(2) + +ipFkl = ipFij+nFij +nFkl = kBas*lBas*iCmpa(3)*iCmpa(4) + +ipFik = ipFkl+nFkl +nFik = iBas*kBas*iCmpa(1)*iCmpa(3) + +ipFjl = ipFik+nFik +nFjl = jBas*lBas*iCmpa(2)*iCmpa(4) + +ipFil = ipFjl+nFjl +nFil = iBas*lBas*iCmpa(1)*iCmpa(4) + +ipFjk = ipFil+nFil +nFjk = jBas*kBas*iCmpa(2)*iCmpa(3) + +FT(ipFij:ipFjk+nFjk-1) = Zero + +ipDij = 1 +ipDkl = 1 +ipDik = 1 +ipDil = 1 +ipDjk = 1 +ipDjl = 1 +ipFij1 = 1 +ipFkl1 = 1 +ipFik1 = 1 +ipFil1 = 1 +ipFjk1 = 1 +ipFjl1 = 1 + +! Quadruple loop over elements of the basis functions angular +! description. Loops are reduced to just produce unique SO integrals +! Observe that we will walk through the memory in AOInt in a +! sequential way. + +iShij = iShell(1) == iShell(2) +iShkl = iShell(3) == iShell(4) +iShik = iShell(1) == iShell(3) +iShil = iShell(1) == iShell(4) +iShjk = iShell(2) == iShell(3) +iShjl = iShell(2) == iShell(4) +mijkl = iBas*jBas*kBas*lBas +do i1=1,iCmp + ix = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(1)+i1,j) > 0) ix = ibset(ix,j) + end do + iSym(1) = ix + jCmpMx = jCmp + if (iShij) jCmpMx = i1 + iChBs = iChBas(ii+i1) + if (Shells(iShll(1))%Transf) iChBs = iChBas(iSphCr(ii+i1)) + pEa = Prmt(iOper(kOp(1)),iChBs) + do i2=1,jCmpMx + ix = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(2)+i2,j) > 0) ix = ibset(ix,j) + end do + iSym(2) = ix + jChBs = iChBas(jj+i2) + if (Shells(iShll(2))%Transf) jChBs = iChBas(iSphCr(jj+i2)) + pRb = Prmt(iOper(kOp(2)),jChBs) + if (iShell(2) > iShell(1)) then + i12 = jCmp*(i1-1)+i2 + else + i12 = iCmp*(i2-1)+i1 + end if + do i3=1,kCmp + ix = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(3)+i3,j) > 0) ix = ibset(ix,j) + end do + iSym(3) = ix + lCmpMx = lCmp + if (iShkl) lCmpMx = i3 + kChBs = iChBas(kk+i3) + if (Shells(iShll(3))%Transf) kChBs = iChBas(iSphCr(kk+i3)) + pTc = Prmt(iOper(kOp(3)),kChBs) + do i4=1,lCmpMx + ix = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(4)+i4,j) > 0) ix = ibset(ix,j) + end do + iSym(4) = ix + lChBs = iChBas(ll+i4) + if (Shells(iShll(4))%Transf) lChBs = iChBas(iSphCr(ll+i4)) + pTSd = Prmt(iOper(kOp(4)),lChBs) + if (iShell(4) > iShell(3)) then + i34 = lCmp*(i3-1)+i4 + else + i34 = kCmp*(i4-1)+i3 + end if + if (Shijij .and. (i34 > i12)) cycle + vijkl = 0 + do ijkl=1,mijkl + vijkl = max(vijkl,abs(AOInt(ijkl,i1,i2,i3,i4))) + end do + !vijkl = DNrm2_(iBas*jBas*kBas*lBas,AOInt(1,i1,i2,i3,i4),1) + !if (vijkl < CutInt) cycle + + Qijij = Shijij .and. (i12 == i34) + iQij = iShij .and. (i1 == i2) + iQkl = iShkl .and. (i3 == i4) + iQik = iShik .and. (i1 == i3) + iQil = iShil .and. (i1 == i4) + iQjk = iShjk .and. (i2 == i3) + iQjl = iShjl .and. (i2 == i4) + pFctr = pEa*pRb*pTc*pTSd + !*************************************************************** + + Fac_ij = pFctr + Fac_kl = pFctr + Fac_ik = -Quart*pFctr + Fac_jl = -Quart*pFctr + Fac_il = -Quart*pFctr + Fac_jk = -Quart*pFctr + if (iQij) Fac_ij = Fac_ij*Half + if (iQkl) Fac_kl = Fac_kl*Half + if (iQjl .and. (.not. iQik)) Fac_ik = Fac_ik*Two + if (iQik .and. (.not. iQjl)) Fac_jl = Fac_jl*Two + if (iQjk .and. (.not. iQil)) Fac_il = Fac_il*Two + if (iQil .and. (.not. iQjk)) Fac_jk = Fac_jk*Two + + D_ij = Two + if (iQij) D_ij = One + D_kl = Two + if (iQkl) D_kl = One + D_ik = Two + if (iQik) D_ik = One + D_jl = Two + if (iQjl) D_jl = One + D_il = Two + if (iQil) D_il = One + D_jk = Two + if (iQjk) D_jk = One + + Fac_ij = Fac_ij*D_kl + Fac_kl = Fac_kl*D_ij + Fac_jl = Fac_jl*D_ik + Fac_ik = Fac_ik*D_jl + Fac_jk = Fac_jk*D_il + Fac_il = Fac_il*D_jk + + !write(u6,*) + !write(u6,*) 'iShell(1),iShell(2),i1,i2=',iShell(1),iShell(2),i1,i2 + !write(u6,*) 'Dij=',Dij(1,i1,i2) + !write(u6,*) 'Fac_ij,iQij=',Fac_ij,iQij + !write(u6,*) + !write(u6,*) 'iShell(3),iShell(4),i3,i4=',iShell(3),iShell(4),i3,i4 + !write(u6,*) 'Dkl=',Dkl(1,i3,i4) + !write(u6,*) 'Fac_kl,iQkl=',Fac_kl,iQkl + !write(u6,*) + if (Qijij) then + Fac_kl = Zero + Fac_jk = Zero + end if + if (iQij .and. iQkl) then + Fac_jl = Zero + Fac_il = Zero + Fac_jk = Zero + end if + if (iQij .or. iQkl) then + Fac_il = Zero + Fac_jk = Zero + end if + !*************************************************************** + + iOpt = 0 + ip = 1 + if ((iand(iSym(1),iSym(2)) /= 0) .or. (iand(iSym(3),iSym(4)) /= 0)) then + iOpt = iOpt+1 + + if (iShell(3) < iShell(4)) then + vkl = Dkl(kBas*lBas+1,i4,i3) + ipDkl = ip + ip = ip+kBas*lBas + call DGetMO(Dkl(1,i4,i3),kl1,kl1,kl2,Scrt(ipDkl),kl2) + else + vkl = Dkl(kBas*lBas+1,i3,i4) + loc1 = (ixLoc(Dkl(1,i3,i4))-ixLoc(Scrt(1))) + loc2 = (ixLoc(Scrt(2))-ixLoc(Scrt(1))) + ipDkl = 1+loc1/loc2 + end if + ipFij1 = ((i2-1)*iCmpa(1)+i1-1)*iBas*jBas+ipFij + if (iShell(1) < iShell(2)) then + vij = Dij(iBas*jBas+1,i2,i1) + ipDij = ip + ip = ip+iBas*jBas + call DGeTMO(Dij(1,i2,i1),ij1,ij1,ij2,Scrt(ipDij),ij2) + else + vij = Dij(iBas*jBas+1,i1,i2) + loc1 = (ixLoc(Dij(1,i1,i2))-ixLoc(Scrt(1))) + loc2 = (ixLoc(Scrt(2))-ixLoc(Scrt(1))) + ipDij = 1+loc1/loc2 + end if + ipFkl1 = ((i4-1)*iCmpa(3)+i3-1)*kBas*lBas+ipFkl + if ((vkl*vijkl*abs(Fac_ij) < ThrInt) .and. (vij*vijkl*abs(Fac_kl) < ThrInt)) then + iOpt = iOpt-1 + else + lFij = .true. + lFkl = .true. + end if + end if + + if ((iand(iSym(1),iSym(3)) /= 0) .or. (iand(iSym(2),iSym(4)) /= 0)) then + iOpt = iOpt+2 + + if (iShell(2) < iShell(4)) then + vjl = Djl(jBas*lBas+1,i4,i2) + ipDjl = ip + ip = ip+jBas*lBas + call DGeTMO(Djl(1,i4,i2),jl1,jl1,jl2,Scrt(ipDjl),jl2) + else + vjl = Djl(jBas*lBas+1,i2,i4) + loc1 = (ixLoc(Djl(1,i2,i4))-ixLoc(Scrt(1))) + loc2 = (ixLoc(Scrt(2))-ixLoc(Scrt(1))) + ipDjl = 1+loc1/loc2 + end if + ipFik1 = ((i3-1)*iCmpa(1)+i1-1)*iBas*kBas+ipFik + if (iShell(1) < iShell(3)) then + vik = Dik(iBas*kBas+1,i3,i1) + ipDik = ip + ip = ip+iBas*kBas + call DGeTMO(Dik(1,i3,i1),ik1,ik1,ik2,Scrt(ipDik),ik2) + else + vik = Dik(iBas*kBas+1,i1,i3) + loc1 = (ixLoc(Dik(1,i1,i3))-ixLoc(Scrt(1))) + loc2 = (ixLoc(Scrt(2))-ixLoc(Scrt(1))) + ipDik = 1+loc1/loc2 + end if + ipFjl1 = ((i4-1)*iCmpa(2)+i2-1)*jBas*lBas+ipFjl + if ((vik*vijkl*abs(Fac_jl) < ThrInt) .and. (vjl*vijkl*abs(Fac_ik) < ThrInt)) then + iOpt = iOpt-2 + else + lFik = .true. + lFjl = .true. + end if + end if + + if ((iand(iSym(1),iSym(4)) /= 0) .or. (iand(iSym(2),iSym(3)) /= 0)) then + iOpt = iOpt+4 + + if (iShell(2) < iShell(3)) then + vjk = Djk(jBas*kBas+1,i3,i2) + ipDjk = ip + ip = ip+jBas*kBas + call DGeTMO(Djk(1,i3,i2),jk1,jk1,jk2,Scrt(ipDjk),jk2) + else + vjk = Djk(jBas*kBas+1,i2,i3) + loc1 = (ixLoc(Djk(1,i2,i3))-ixLoc(Scrt(1))) + loc2 = (ixLoc(Scrt(2))-ixLoc(Scrt(1))) + ipDjk = 1+loc1/loc2 + end if + ipFil1 = ((i4-1)*iCmpa(1)+i1-1)*iBas*lBas+ipFil + if (iShell(1) < iShell(4)) then + vil = Dil(iBas*lBas+1,i4,i1) + ipDil = ip + ip = ip+iBas*lBas + call DGeTMO(Dil(1,i4,i1),il1,il1,il2,Scrt(ipDil),il2) + else + vil = Dil(iBas*lBas+1,i1,i4) + loc1 = (ixLoc(Dil(1,i1,i4))-ixLoc(Scrt(1))) + loc2 = (ixLoc(Scrt(2))-ixLoc(Scrt(1))) + ipDil = 1+loc1/loc2 + end if + ipFjk1 = ((i3-1)*iCmpa(2)+i2-1)*jBas*kBas+ipFjk + if ((vil*vijkl*abs(Fac_jk) < ThrInt) .and. (vjk*vijkl*abs(Fac_il) < ThrInt)) then + iOpt = iOpt-4 + else + lFil = .true. + lFjk = .true. + end if + end if + if (ip-1 > nScrt) then + write(u6,*) 'FckAcc: nScrt too small!' + call Abend() + end if + ! * + !*************************************************************** + ! * + select case (iOpt) + case (1) + call Fck1(AOInt(1,i1,i2,i3,i4),iBas,jBas,kBas,lBas,Scrt(ipDij),FT(ipFij1),Fac_ij,Scrt(ipDkl),FT(ipFkl1),Fac_kl,ExFac) + case (2) + call Fck2(AOInt(1,i1,i2,i3,i4),iBas,jBas,kBas,lBas,Scrt(ipDik),FT(ipFik1),Fac_ik,Scrt(ipDjl),FT(ipFjl1),Fac_jl,ExFac) + case (3) + call Fck3(AOInt(1,i1,i2,i3,i4),iBas,jBas,kBas,lBas,Scrt(ipDij),FT(ipFij1),Fac_ij,Scrt(ipDkl),FT(ipFkl1),Fac_kl, & + Scrt(ipDik),FT(ipFik1),Fac_ik,Scrt(ipDjl),FT(ipFjl1),Fac_jl,ExFac) + case (4) + call Fck4(AOInt(1,i1,i2,i3,i4),iBas,jBas,kBas,lBas,Scrt(ipDil),FT(ipFil1),Fac_il,Scrt(ipDjk),FT(ipFjk1),Fac_jk,ExFac) + case (5) + call Fck5(AOInt(1,i1,i2,i3,i4),iBas,jBas,kBas,lBas,Scrt(ipDij),FT(ipFij1),Fac_ij,Scrt(ipDkl),FT(ipFkl1),Fac_kl, & + Scrt(ipDil),FT(ipFil1),Fac_il,Scrt(ipDjk),FT(ipFjk1),Fac_jk,ExFac) + case (6) + call Fck6(AOInt(1,i1,i2,i3,i4),iBas,jBas,kBas,lBas,Scrt(ipDik),FT(ipFik1),Fac_ik,Scrt(ipDjl),FT(ipFjl1),Fac_jl, & + Scrt(ipDil),FT(ipFil1),Fac_il,Scrt(ipDjk),FT(ipFjk1),Fac_jk,ExFac) + case (7) + call Fck7(AOInt(1,i1,i2,i3,i4),iBas,jBas,kBas,lBas,Scrt(ipDij),FT(ipFij1),Fac_ij,Scrt(ipDkl),FT(ipFkl1),Fac_kl, & + Scrt(ipDik),FT(ipFik1),Fac_ik,Scrt(ipDjl),FT(ipFjl1),Fac_jl,Scrt(ipDil),FT(ipFil1),Fac_il,Scrt(ipDjk), & + FT(ipFjk1),Fac_jk,ExFac) + case default + ! nothing + end select + !*************************************************************** + + end do + end do + end do +end do + +nnIrrep = nIrrep +if (sIrrep) nnIrrep = 1 +do iIrrep=0,nnIrrep-1 + + if (pert(iIrrep)) then + ip = ipDisp(abs(indgrd(iCar,iCent,iIrrep))) + rCh = Prmt(iOper(kOp(iCent)),iChBas(1+iCar))*real(iChTbl(iIrrep,kOp(iCent)),kind=wp) + Fact = tfact*rCh + !write(u6,*) 'Level ij' + if (lFij) call FckDst(TwoHam(ip),ndens,FT(ipFij),iBas,jBas,iCmpa(1),iCmpa(2),kOp2(1),kOp2(2),iIrrep,iShij,iAO(1),iAO(2), & + iAOst(1),iAOst(2),fact) + !write(u6,*) 'Level kl' + if (lFkl) call FckDst(TwoHam(ip),ndens,FT(ipFkl),kBas,lBas,iCmpa(3),iCmpa(4),kOp2(3),kOp2(4),iIrrep,iShkl,iAO(3),iAO(4), & + iAOst(3),iAOst(4),fact) + !write(u6,*) 'Level ik' + if (lFik) call FckDst(TwoHam(ip),ndens,FT(ipFik),iBas,kBas,iCmpa(1),iCmpa(3),kOp2(1),kOp2(3),iIrrep,iShik,iAO(1),iAO(3), & + iAOst(1),iAOst(3),fact) + !write(u6,*) 'Level jl' + if (lFjl) call FckDst(TwoHam(ip),ndens,FT(ipFjl),jBas,lBas,iCmpa(2),iCmpa(4),kOp2(2),kOp2(4),iIrrep,iShjl,iAO(2),iAO(4), & + iAOst(2),iAOst(4),fact) + !write(u6,*) 'Level il' + if (lFil) call FckDst(TwoHam(ip),ndens,FT(ipFil),iBas,lBas,iCmpa(1),iCmpa(4),kOp2(1),kOp2(4),iIrrep,iShil,iAO(1),iAO(4), & + iAOst(1),iAOst(4),fact) + !write(u6,*) 'Level jk' + if (lFjk) call FckDst(TwoHam(ip),ndens,FT(ipFjk),jBas,kBas,iCmpa(2),iCmpa(3),kOp2(2),kOp2(3),iIrrep,iShjk,iAO(2),iAO(3), & + iAOst(2),iAOst(3),fact) + end if +end do + +return + +#endif + +end subroutine FckAcc_Mck diff -Nru openmolcas-22.02/src/mckinley/fix_2nder.f openmolcas-22.10/src/mckinley/fix_2nder.f --- openmolcas-22.02/src/mckinley/fix_2nder.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/fix_2nder.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,145 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Fix_2nder(Fa1,Fa2,Fb1,Fb2,Final,nalpha,nbeta, - & ishll,la,lb,iang,jfhess,nfun,fact) -*----------------------------------------------------------------------* -C -C Fa1 includes ( grad < a | c > , < a | c > ) -C Fb1 includes ( grad < c | b > , < c | b > ) -C -C -C -* - Implicit Real*8(a-h,o-z) -#include "real.fh" -CBS Logical jfhess(3,3,2,2) ! now same dimensions as in prjhss.f - Logical jfhess(3,3,4,4) - Real*8 FA1((2*iAng+1)*((la+1)*(la+2)/2)*nAlpha*nFun*4), - & FA2((2*iAng+1)*((la+1)*(la+2)/2)*nAlpha*nFun*6), - & FB1((2*iAng+1)*((lb+1)*(lb+2)/2)*nBeta*nFun*4), - & FB2((2*iAng+1)*((lb+1)*(lb+2)/2)*nBeta*nFun*6), -CBS &Final(nAlpha*nbeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,6) - &Final(nAlpha*nbeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,21) - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - iTri(i,j) = Max(i,j)*(Max(i,j)-1)/2 + Min(i,j) - - -* OK NOW EVERYTHING SHOULD BE MERGED TOGETHER -* -* -CBS write(*,*) 'nFun ',nfun -CBS write(*,*) 'FA1 ',FA1 -CBS write(*,*) 'FA2 ',FA2 -CBS write(*,*) 'FB1 ',FB1 -CBS write(*,*) 'FB2 ',FB2 - Do iCar = 1, 3 - Do jCar = 1, 3 - mvec=itri(iCar+3,jcar) - If (jfHess(iCar,jcar,2,1)) Then - ipFA1a = 1+ iCar * - & nAlpha*nFun*nElem(la)*(2*iAng+1) - ipFB1a = 1 + jcar * - & nFun*nBeta*(2*iAng+1)*nElem(lb) - - Do ib = 1, nElem(lb) - Do ia = 1, nElem(la) -* - Do iC = 1, (2*iAng+1) - iaC = (iC-1)*nElem(la) + ia - ipaC = (iaC-1)*nAlpha*nFun + ipFA1a - iCb = (ib-1)*(2*iAng+1) + iC - ipCb = (iCb-1)*nFun*nBeta + ipFB1a - - Call DGEMM_('N','N', - & nAlpha,nBeta,nFun, - & Fact,FA1(ipaC),nAlpha, - & FB1(ipCb),nFun, - & One,Final(1,ia,ib,mVec),nAlpha) -* -* - End do - End do - End do - End If - End do - End do - -CBS goto 4711 - Do iCar = 1, 3 - Do jCar = 1, icar - mvec=itri(iCar,jcar) - If (jfHess(iCar,jcar,1,1)) Then - ipFA1a = 1 + (itri(iCar,jCar)-1) * - & nAlpha*nFun*nElem(la)*(2*iAng+1) -* - Do ib = 1, nElem(lb) - Do ia = 1, nElem(la) - - Do iC = 1, (2*iAng+1) - iaC = (iC-1)*nElem(la) + ia - ipaC = (iaC-1)*nAlpha*nFun + ipFA1a - iCb = (ib-1)*(2*iAng+1) + iC - ipCb = (iCb-1)*nFun*nBeta + 1 - - Call DGEMM_('N','N', - & nAlpha,nBeta,nFun, - & Fact,FA2(ipaC),nAlpha, - & FB1(ipCb),nFun, - & One,Final(1,ia,ib,mVec),nAlpha) -* -* - End do - End do - End do - End If - End do - End do -*4711 continue - -CBS goto 4712 ! for testing the different contributions - Do iCar = 1, 3 - Do jCar = 1, icar - mvec=itri(3+icar,3+jcar) - If (jfHess(iCar,jcar,2,2)) Then - ipFB1a = 1 + (itri(icar,jcar)-1) * -CBS & nAlpha*nFun*nElem(la)*(2*iAng+1) -CBS looks much better .... (Oh Anders ...) - - & nBeta*nFun*nElem(lb)*(2*iAng+1) - - Do ib = 1, nElem(lb) - Do ia = 1, nElem(la) -* - Do iC = 1, (2*iAng+1) - iaC = (iC-1)*nElem(la) + ia - ipaC = (iaC-1)*nAlpha*nFun + 1 - iCb = (ib-1)*(2*iAng+1) + iC - ipCb = (iCb-1)*nFun*nBeta + ipFB1a - - Call DGEMM_('N','N', - & nAlpha,nBeta,nFun, - & Fact,FA1(ipaC),nAlpha, - & FB2(ipCb),nFun, - & One,Final(1,ia,ib,mVec),nAlpha) - -* - End do - End do - End do - End If - End do - End do -*4712 continue - - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(ishll) - End diff -Nru openmolcas-22.02/src/mckinley/grd_mck_interface.fh openmolcas-22.10/src/mckinley/grd_mck_interface.fh --- openmolcas-22.02/src/mckinley/grd_mck_interface.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/grd_mck_interface.fh 2022-10-10 14:22:40.000000000 +0000 @@ -1,40 +1,23 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2020, Roland Lindh * -************************************************************************ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + #ifdef _CALLING_ - & Alpha,nAlpha,Beta, nBeta, - & Zeta,ZInv,rKappa,P, - & Final,nZeta,la,lb,A,RB,nHer, - & Array,nArr,Ccoor,nOrdOp, - & IfGrad,IndGrd,nOp, - & lOper,iu,iv,nrOp,iDCar,iDCnt,iStabM,nStabM, - & Trans,nSym +Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,rFinal,nZeta,la,lb,A,RB,nHer,Array,nArr,Ccoor,nOrdOp,IfGrad,IndGrd,nOp,lOper,iu,iv, & +nrOp,iDCar,iDCnt,iStabM,nStabM,Trans,nSym & #else - Real*8 Alpha(nAlpha), Beta(nBeta) - Integer nAlpha, nBeta - Real*8 Zeta(nZeta), ZInv(nZeta) - Real*8 rKappa(nZeta), P(nZeta,3) - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nrOp) - Integer nZeta, la, lb - Real*8 A(3), RB(3) - Real*8 Array(nArr) - Integer nArr - Real*8 Ccoor(3) - Integer nOrdOp - Logical IfGrad(3,2) - Integer IndGrd(0:nSym-1), nOp(2) - Integer nSym, lOper, iu, iv, iDCar, iDCnt - Integer iStabM(0:nStabM-1) - Logical Trans(2) +integer(kind=iwp), intent(in) :: nAlpha, nBeta, nZeta, la, lb, nHer, nArr, nOrdOp, nSym, IndGrd(0:nSym-1), nOp(2), lOper, iu, iv, & + nrOp, iDCar, iDCnt, nStabM, iStabM(0:nStabM-1) +real(kind=wp), intent(in) :: Alpha(nAlpha), Beta(nBeta), Zeta(nZeta), ZInv(nZeta), P(nZeta,3), A(3), RB(3), Ccoor(3) +real(kind=wp), intent(inout) :: rKappa(nZeta), rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),nrOp) +real(kind=wp), intent(out) :: Array(nArr) +logical(kind=iwp), intent(in) :: IfGrad(3,2), Trans(2) #endif #undef _CALLING_ - diff -Nru openmolcas-22.02/src/mckinley/hssprt.f openmolcas-22.10/src/mckinley/hssprt.f --- openmolcas-22.02/src/mckinley/hssprt.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/hssprt.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,61 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SubRoutine HssPrt(Hess,nHess) - use Symmetry_Info, only: nIrrep, lIrrep - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "stdalloc.fh" -#include "disp.fh" -#include "disp2.fh" -#include "real.fh" - Integer nDisp(0:7) - Character Label*39 - Real*8 Hess(nHess) - Real*8, Allocatable:: Temp(:) -* * -************************************************************************ -* * -* Statement function -* - Ind(idisp,jdisp)=idisp*(idisp-1)/2+jdisp -* * -************************************************************************ -* * - 100 Format (A,A) - iDisp=0 - Do iIrrep=0,nIrrep-1 - nDisp(iIrrep)=iDisp - iDisp=iDisp+lDisp(iIrrep) - End Do -* - If (nirrep.eq.1) Then - Write(Label,100) 'Hessian in Irrep ',lIrrep(0) - Call TriPrt(Label,' ',Hess,ldisp(0)) - Else - Call mma_allocate(Temp,nHess,Label='Temp') - Do iIrrep=0,nIrrep-1 - Write(Label,100) 'Hessian in Irrep ',lIrrep(iIrrep) - Do i=1,lDisp(iirrep) - Do j=1,i - ii=ind(i,j) - jj=ind(ndisp(iirrep)+i,ndisp(iirrep)+j) - Temp(ii)=Hess(jj) - End Do - End Do - Call TriPrt(Label,' ',Temp,ldisp(iirrep)) - End Do - Call mma_deallocate(Temp) - End If -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/mckinley/hssprt.F90 openmolcas-22.10/src/mckinley/hssprt.F90 --- openmolcas-22.02/src/mckinley/hssprt.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/hssprt.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,63 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine HssPrt(Hess,nHess) + +use Index_Functions, only: iTri +use Symmetry_Info, only: lIrrep, nIrrep +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nHess +real(kind=wp), intent(in) :: Hess(nHess) +#include "Molcas.fh" +#include "disp.fh" +integer(kind=iwp) :: i, iDisp, ii, iIrrep, j, jj, nDisp(0:7) +character(len=39) :: Label +real(kind=wp), allocatable :: Temp(:) + +! * +!*********************************************************************** +! * +iDisp = 0 +do iIrrep=0,nIrrep-1 + nDisp(iIrrep) = iDisp + iDisp = iDisp+lDisp(iIrrep) +end do + +if (nirrep == 1) then + write(Label,100) 'Hessian in Irrep ',lIrrep(0) + call TriPrt(Label,' ',Hess,ldisp(0)) +else + call mma_allocate(Temp,nHess,Label='Temp') + do iIrrep=0,nIrrep-1 + write(Label,100) 'Hessian in Irrep ',lIrrep(iIrrep) + do i=1,lDisp(iirrep) + do j=1,i + ii = iTri(i,j) + jj = iTri(ndisp(iirrep)+i,ndisp(iirrep)+j) + Temp(ii) = Hess(jj) + end do + end do + call TriPrt(Label,' ',Temp,ldisp(iirrep)) + end do + call mma_deallocate(Temp) +end if +! * +!*********************************************************************** +! * + +return + +100 format(A,A) + +end subroutine HssPrt diff -Nru openmolcas-22.02/src/mckinley/inputh.f openmolcas-22.10/src/mckinley/inputh.f --- openmolcas-22.02/src/mckinley/inputh.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/inputh.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,795 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991,1992, Roland Lindh * -* 1996, Anders Bernhardsson * -************************************************************************ - SubRoutine Inputh(Run_MCLR) -************************************************************************ -* * -* Object: input module for the gradient code * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* September 1991 * -* * -* Modified to complement GetInf, January 1992 * -************************************************************************ - use Basis_Info - use Center_Info - use Symmetry_Info, only: nIrrep, iChTbl, iOper, lIrrep, lBsFnc - use Gateway_global, only: Onenly, Test - use Gateway_Info, only: CutInt - Implicit Real*8 (A-H,O-Z) -#include "itmax.fh" -#include "Molcas.fh" -#include "real.fh" -#include "disp.fh" -#include "disp2.fh" -#include "iavec.fh" -#include "stdalloc.fh" -#include "print.fh" -#include "SysDef.fh" - Logical TstFnc, Type, Slct -c Logical DoCholesky - Character*1 xyz(0:2) - Character*8 Label,labelop - Character*32 Label2 - Logical Run_MCLR - Character*80 KWord, Key - Integer iSym(3), iTemp(3*MxAtom) - Integer, Allocatable:: ATDisp(:), DEGDisp(:), TDisp(:), Car(:) - Real*8, Allocatable:: AM(:,:), Tmp(:,:), C(:,:), Scr(:,:) - Data xyz/'x','y','z'/ - Interface - Subroutine datimx(TimeStamp) Bind(C,name='datimx_') - Use, Intrinsic :: iso_c_binding, Only: c_char - Character(kind=c_char) :: TimeStamp(*) - End Subroutine - End Interface -* -c Call DecideOnCholesky(DoCholesky) -c If (DoCholesky) Then -c write(6,*)'** Cholesky or RI/DF not yet implemented in McKinley ' -c call abend() -c EndIf - - iRout=99 - Do i = 1, nRout - nPrint(i) = 5 - End Do - show=.false. - Onenly = .False. - nmem=0 - Test = .False. - TRSymm = .false. - lEq = .False. - Slct = .False. - PreScr = .true. - lGrd=.True. - lHss=.True. - Nona=.false. - Run_MCLR=.True. - CutInt = 1.0D-07 - ipert=2 - iCntrl=1 - Call lCopy(mxpert,[.true.],0,lPert,1) - sIrrep=.false. - iprint=0 - Do 109 i = 1, 3*MxAtom - IndxEq(i) = i - 109 Continue -* -* KeyWord directed input -* - LuRd=5 - Call RdNLst(LuRd,'MCKINLEY') - 998 Read(5,'(A72)',END=977,ERR=988) Key - KWord = Key - Call UpCase(KWord) - If (KWord(1:1).eq.'*') Go To 998 - If (KWord.eq.'') Go To 998 -* If (KWord(1:4).eq.'EQUI') Go To 935 -* If (KWord(1:4).eq.'NOTR') Go To 952 -* If (KWord(1:4).eq.'NOIN') Go To 953 - If (KWord(1:4).eq.'SHOW') Go To 992 - If (KWord(1:4).eq.'MEM ') Go To 697 -* - If (KWord(1:4).eq.'CUTO') Go To 942 - If (KWord(1:4).eq.'VERB') Go To 912 - If (KWord(1:4).eq.'NOSC') Go To 965 - If (KWord(1:4).eq.'ONEO') Go To 990 - If (KWord(1:4).eq.'SELE') Go To 960 - If (KWord(1:4).eq.'REMO') Go To 260 - If (KWord(1:4).eq.'PERT') Go To 975 - If (KWord(1:4).eq.'TEST') Go To 991 - If (KWord(1:4).eq.'EXTR') Go To 971 - If (KWord(1:4).eq.'NONA') Go To 972 - If (KWord(1:4).eq.'NOMC') Go To 973 - If (KWord(1:4).eq.'END ') Go To 997 - Write (6,*) 'InputH: Illegal keyword' - Write (6,'(A,A)') 'KWord=',KWord - Call Abend() - 977 Write (6,*) 'InputH: end of input file.' - Write (6,'(A,A)') 'Last command=',KWord - Call Abend() - 988 Write (6,*) 'InputH: error reading input file.' - Write (6,'(A,A)') 'Last command=',KWord - Call Abend() -* * -****** MEM ************************************************************ -* * - 697 Read(5,*) nmem - nmem=nmem*1048576/rtob - goto 998 -* * -****** PERT ************************************************************ -* * -* Select which part of the Hessian will be compiuted. -* -975 Read(5,'(A)',Err=988) KWord - If (KWord(1:1).eq.'*') Go To 975 - If (KWord.eq.'') Go To 975 - Call UpCase(KWord) - If (KWORD(1:4).eq.'HESS') Then - ipert=2 - Else If (KWORD(1:4).eq.'GEOM') Then - ipert=1 - Else - Write (6,*) 'InputH: Illegal perturbation keyword' - Write (6,'(A,A)') 'KWord=',KWord - Call Abend() - End If - - Goto 998 -* * -****** EQUI ************************************************************ -* * -* Equivalence option -* -*935 Continue -* lEq=.True. -*936 Read(5,'(A)',Err=988) KWord -* If (KWord(1:1).eq.'*') Go To 936 -* If (KWord.eq.'') Go To 936 -* Read(KWord,*) nGroup -* Do 937 iGroup = 1, nGroup -*938 Read(5,'(A)',Err=988) KWord -* If (KWord(1:1).eq.'*') Go To 938 -* If (KWord.eq.'') Go To 938 -* Read(KWord,*) nElem,(iTemp(iElem),iElem=1,nElem) -* Do 939 iElem=2,nElem -* IndxEq(iTemp(iElem)) = iTemp(1) -* Direct(iTemp(iElem)) = .False. -*939 Continue -*937 Continue -* Go To 998 -* * -****** CUTO ************************************************************ -* * -* Cuttoff for computing primitive gradients -* - 942 Read(5,*) Cutint -* If (KWord(1:1).eq.'*') Go To 942 -* If (KWord.eq.'') Go To 942 -* Read(KWord,*,Err=988) CutInt - CutInt = Abs(CutInt) - Go To 998 -* * -****** NOIN ************************************************************ -* * -* Disable the utilization of translational and -* rotational invariance of the energy in the -* computation of the molecular gradient. -* -*953 TRSymm=.False. -* Go To 998 -* * -****** SELE ************************************************************ -* * -* selection option -* - 960 Continue - slct=.true. - Call lCopy(mxpert,[.false.],0,lPert,1) -*962 Continue - Read(5,*) nslct -* If (KWord(1:1).eq.'*') Go To 962 -* If (KWord.eq.'') Go To 962 -* Read(KWord,*) nSlct -* - Read(5,*) (iTemp(iElem),iElem=1,nSlct) - Do 964 iElem=1,nSlct - lpert(iTemp(iElem)) = .True. -964 Continue - Go To 998 -* * -****** REMO ************************************************************ -* * - 260 Continue - Slct=.true. - Read(5,*) nslct -* - Read(5,*) (iTemp(iElem),iElem=1,nSlct) - Do 264 iElem=1,nSlct - lpert(iTemp(iElem)) = .false. -264 Continue - Go To 998 -* * -****** NOSC ************************************************************ -* * -* Change default for the prescreening. -* - 965 PreScr = .False. - Go To 998 -* * -****** ONEO ************************************************************ -* * -* Do not compute two electron integrals. -* - 990 Onenly = .TRUE. - Go To 998 -* * -****** TEST ************************************************************ -* * -* Process only the input. -* - 991 Test = .TRUE. - Go To 998 -* * -****** SHOW ************************************************************ -* * -*-----Raise the printlevel to show gradient contributions -* - 992 Continue - Show=.true. - Go To 998 -* * -****** EXTR ************************************************************ -* * -* Put the program name and the time stamp onto the extract file -* -971 Write (6,*) 'InputH: EXTRACT option is redundant and is ignored!' - Go To 998 -* * -****** VERB ************************************************************ -* * -* Verbose output -* - 912 nPrint( 1)=6 - nPrint(99)=6 - Go To 998 -* * -****** NONA ************************************************************ -* * -* Compute the anti-symmetric overlap gradient only. -* -972 Nona=.true. - Run_MCLR=.False. - Go To 998 -* * -****** NOMC ************************************************************ -* * -* Request no automatic run of MCLR -* -973 Run_MCLR=.False. - Go To 998 -************************************************************************ -* * -* End of input section. * -* * -************************************************************************ - 997 Continue -* - iPrint=nPrint(iRout) -* - iOpt = 1 - if (onenly) iopt=0 - iRC = -1 - Lu_Mck=35 - Call OpnMck(irc,iOpt,'MCKINT',Lu_Mck) - If (iRC.ne.0) Then - Write (6,*) 'InputH: Error opening MCKINT' - Call Abend() - End If - If (ipert.eq.1) Then - Label2='Geometry' - LabelOp='PERT ' - irc=-1 - iopt=0 - Call cWrMck(iRC,iOpt,LabelOp,1,Label2,iDummer) - sIrrep=.true. - iCntrl=1 - Else If (ipert.eq.2) Then - Label2='Hessian' - LabelOp='PERT ' - Call cWrMck(iRC,iOpt,LabelOp,1,Label2,iDummer) - iCntrl=1 - Else If (ipert.eq.3) Then - LabelOp='PERT ' - Label2='Magnetic' - Call cWrMck(iRC,iOpt,LabelOp,1,Label2,iDummer) - Write (6,*) 'InputH: Illegal perturbation option' - Write (6,*) 'iPert=',iPert - Call Abend() - Else If (ipert.eq.4) Then - LabelOp='PERT ' - Label2='Relativistic' - Call cWrMck(iRC,iOpt,LabelOp,1,Label2,iDummer) - Write (6,*) 'InputH: Illegal perturbation option' - Write (6,*) 'iPert=',iPert - Call Abend() - Else - Write (6,*) 'InputH: Illegal perturbation option' - Write (6,*) 'iPert=',iPert - Call Abend() - End If - -* If (lEq) TRSymm=.False. -* If (Slct) TRSymm=.False. -* - mDisp = 0 - mdc = 0 - Do 10 iCnttp = 1, nCnttp - Do 20 iCnt = 1, dbsc(iCnttp)%nCntr - mdc = mdc + 1 - mDisp = mDisp + 3*(nIrrep/dc(mdc)%nStab) - 20 Continue - 10 Continue -* - Write (6,*) - Write (6,'(20X,A,E10.3)') - & ' Threshold for contributions to the gradient or Hessian:', - & CutInt - Write (6,*) -* - If (Nona) Then - Write (6,*) - Write (6,'(20X,A)') - & ' McKinley only is computing the antisymmetric gradient '// - & ' of the overlap integrals for the NonAdiabatic Coupling.' - Write (6,*) - End If -* - If (iCntrl.eq.1) Then -* -* -* Generate symmetry adapted cartesian displacements -* - If (iPrint.ge.6) Then - Write (6,*) - Write (6,'(20X,A)') - & '********************************************' - Write (6,'(20X,A)') - & '* Symmetry Adapted Cartesian Displacements *' - Write (6,'(20X,A)') - & '********************************************' - Write (6,*) - End If - Call ICopy(MxAtom*8,[0],0,IndDsp,1) - Call ICopy(MxAtom*3,[0],0,InxDsp,1) - Call mma_allocate(ATDisp,mDisp,Label='ATDisp') - Call mma_allocate(DEGDisp,mDisp,Label='DEGDisp') - nDisp = 0 - Do 100 iIrrep = 0, nIrrep-1 - lDisp(iIrrep) = 0 - Type = .True. -* Loop over basis function definitions - mdc = 0 - mc = 1 - Do 110 iCnttp = 1, nCnttp -* Loop over unique centers associated with this basis set. - Do 120 iCnt = 1, dbsc(iCnttp)%nCntr - mdc = mdc + 1 - IndDsp(mdc,iIrrep) = nDisp -* Loop over the cartesian components - Do 130 iCar = 0, 2 - iComp = 2**iCar - If ( TstFnc(dc(mdc)%iCoSet, - & iIrrep,iComp,dc(mdc)%nStab) ) Then - nDisp = nDisp + 1 - If (nDisp.gt.mDisp) Then - Write (6,*) 'nDisp.gt.mDisp' - Call Abend - End If - If (iIrrep.eq.0) InxDsp(mdc,iCar+1) = nDisp - lDisp(iIrrep) = lDisp(iIrrep) + 1 - If (Type) Then - If (iPrint.ge.6) Then - Write (6,*) - Write (6,'(10X,A,A)') - & ' Irreducible representation : ', - & lIrrep(iIrrep) - Write (6,'(10X,2A)') - & ' Basis function(s) of irrep: ', - & lBsFnc(iIrrep) - Write (6,*) - Write (6,'(A)') - & ' Basis Label Type Center Phase' - End If - Type = .False. - End If - If (iPrint.ge.6) - & Write (6,'(I4,3X,A8,5X,A1,7X,8(I3,4X,I2,4X))') - & nDisp,dc(mdc)%LblCnt,xyz(iCar), - & (mc+iCo,iPrmt( - & NrOpr(dc(mdc)%iCoSet(iCo,0)),iComp)* - & iChTbl(iIrrep,NrOpr(dc(mdc)%iCoSet(iCo,0))), - & iCo=0,nIrrep/dc(mdc)%nStab-1 ) - Write (ChDisp(nDisp),'(A,1X,A1)') - & dc(mdc)%LblCnt,xyz(iCar) - ATDisp(ndisp)=icnttp - DEGDisp(ndisp)=nIrrep/dc(mdc)%nStab - End If -* - 130 Continue - mc = mc + nIrrep/dc(mdc)%nStab - 120 Continue - 110 Continue -* - 100 Continue -* - If (nDisp.ne.mDisp) Then - Write (6,*) 'InputH: nDisp.ne.mDisp' - Write (6,*) 'nDisp,mDisp=',nDisp,mDisp - Call Abend() - End If - If (sIrrep) Then - ndisp=ldisp(0) - Do i= 1,nIrrep-1 - lDisp(i)=0 - End Do - End If - Call mma_allocate(TDisp,nDisp,Label='TDisp') - TDisp(:)=30 - iOpt = 0 - iRC = -1 - labelOp='ndisp ' - Call iWrMck(iRC,iOpt,labelop,1,[ndisp],iDummer) - If (iRC.ne.0) Then - Write (6,*) 'InputH: Error writing to MCKINT' - Write (6,'(A,A)') 'labelOp=',labelOp - Call Abend() - End If - LABEL='DEGDISP' - iRc=-1 - iOpt=0 - Call iWrMck(iRC,iOpt,Label,idum,DEGDISP,idum) - If (iRC.ne.0) Then - Write (6,*) 'InputH: Error writing to MCKINT' - Write (6,'(A,A)') 'LABEL=',LABEL - Call Abend() - End If - Call mma_deallocate(DEGDisp) - LABEL='NRCTDISP' - iRc=-1 - iOpt=0 - Call iWrMck(iRC,iOpt,Label,idum,ATDisp,idum) - If (iRC.ne.0) Then - Write (6,*) 'InputH: Error writing to MCKINT' - Write (6,'(A,A)') 'LABEL=',LABEL - Call Abend() - End If - Call mma_deallocate(ATDisp) - LABEL='TDISP' - iRc=-1 - iOpt=0 - Call iWrMck(iRC,iOpt,Label,idum,TDisp,idum) - If (iRC.ne.0) Then - Write (6,*) 'InputH: Error writing to MCKINT' - Write (6,'(A,A)') 'LABEL=',LABEL - Call Abend() - End If - Call mma_deallocate(TDisp) -* - Else If (iCntrl.eq.2) Then - Write(6,*) 'Svaret aer 48 ' - Else If (iCntrl.eq.3) Then - Write(6,*) 'Svaret aer 48' - End If -* -* Set up the angular index vector -* - i = 0 - Do 1000 iR = 0, iTabMx - Do 2000 ix = iR, 0, -1 - Do 3000 iy = iR-ix, 0, -1 - iz = iR-ix-iy - i = i + 1 - ixyz(1,i) = ix - ixyz(2,i) = iy - ixyz(3,i) = iz - 3000 Continue - 2000 Continue - 1000 Continue -* -* Set up data for the utilization of the translational -* and rotational invariance of the energy. -* - If (TRSymm) Then - Call Abend() - iSym(1) = 0 - iSym(2) = 0 - iSym(3) = 0 - Do 15 i = 1, Min(nIrrep-1,5) - j = i - If (i.eq.3) j = 4 - Do 16 k = 1, 3 - If (iAnd(iOper(j),2**(k-1)).ne.0) iSym(k) = 2**(k-1) - 16 Continue - 15 Continue - nTR = 0 -*--------Translational equations - Do 150 i = 1, 3 - If (iSym(i).eq.0) nTR = nTR + 1 - 150 Continue - If (iPrint.ge.99) Write (6,*) ' nTR=',nTR -*--------Rotational equations - Do 160 i = 1,3 - j = i+1 - If (j.gt.3) j = j-3 - k = i+2 - If (k.gt.3) k = k-3 - ijSym = iEor(iSym(j),iSym(k)) - If (ijSym.eq.0) nTR = nTR + 1 - 160 Continue - If (nTR.eq.0) Then - TRSymm = .False. - Go To 9876 - End If - If (iPrint.ge.99) Write (6,*) ' nTR=',nTR - Call mma_allocate(AM,nTR,lDisp(0),Label='AM') - Call mma_allocate(Tmp,nTR,nTR,Label='Tmp') - Call mma_allocate(C,4,lDisp(0),Label='C') - Call mma_allocate(Car,lDisp(0),Label='Car') -* - AM(:,:)=Zero - C(:,:)=Zero -* -* Generate temporary information of the symmetrical -* displacements. -* - ldsp = 0 - mdc = 0 - iIrrep = 0 - Do 2100 iCnttp = 1, nCnttp - Do 2200 iCnt = 1, dbsc(iCnttp)%nCntr - mdc = mdc + 1 -* Call RecPrt(' Coordinates',' ', -* & dbsc(iCnttp)%Coor(1,iCnt),1,3) - Fact = Zero - iComp = 0 - If (dbsc(iCnttp)%Coor(1,iCnt).ne.Zero) - & iComp = iOr(iComp,1) - If (dbsc(iCnttp)%Coor(2,iCnt).ne.Zero) - & iComp = iOr(iComp,2) - If (dbsc(iCnttp)%Coor(3,iCnt).ne.Zero) - & iComp = iOr(iComp,4) - Do 2250 jIrrep = 0, nIrrep-1 - If ( TstFnc(dc(mdc)%iCoSet, - & jIrrep,iComp,dc(mdc)%nStab) ) Then - Fact = Fact + One - End If - 2250 Continue - Do 2300 iCar = 0, 2 - iComp = 2**iCar - If ( TstFnc(dc(mdc)%iCoSet, - & iIrrep,iComp,dc(mdc)%nStab) ) Then - ldsp = ldsp + 1 -*--------------------Transfer the coordinates - call dcopy_(3,dbsc(iCnttp)%Coor(:,iCnt),1, - & C(1:3,ldsp),1) -*--------------------Transfer the multiplicity factor - C(4,ldsp) = Fact - Car(ldsp) = iCar + 1 - End If - 2300 Continue - 2200 Continue - 2100 Continue - If (iPrint.ge.99) Then - Call RecPrt(' Information',' ',C,4,lDisp(0)) - Write (6,*) (Car(i),i=1,lDisp(0)) - End If -* -*--------Set up coefficient for the translational equations -* - iTR = 0 - Do 1110 i = 1,3 - If (iSym(i).ne.0) Go To 1110 - iTR = iTR + 1 - Do 1120 ldsp = 1, lDisp(0) - If (Car(ldsp).eq.i) Then - AM(iTR,ldsp) = C(4,ldsp) - End If - 1120 Continue - 1110 Continue -* -*--------Set up coefficient for the rotational invariance -* - Do 1210 i = 1, 3 - j = i + 1 - If (j.gt.3) j = j - 3 - k = i + 2 - If (k.gt.3) k = k - 3 - ijSym = iEor(iSym(j),iSym(k)) - If (ijSym.ne.0) Go To 1210 - iTR = iTR + 1 - Do 1220 ldsp = 1, lDisp(0) - If (Car(ldsp).eq.j) Then - Fact = C(4,ldsp) * C(k,ldsp) - Else If (Car(ldsp).eq.k) Then - Fact =-C(4,ldsp) * C(j,ldsp) - Else - Fact=Zero - Write (6,*) 'Inputh: Error' - Call Abend() - End If - AM(iTR,ldsp) = Fact - 1220 Continue - 1210 Continue - If (iPrint.ge.99) - & Call RecPrt(' The A matrix',' ',AM,nTR,lDisp(0)) -* -*--------Now, transfer the coefficient of those gradients which will -* not be computed directly. -* The matrix to compute the inverse of is determined via -* a Gram-Schmidt procedure. -* -*--------Pick up the other vectors - Do 1230 iTR = 1, nTR -* Write (*,*) ' Looking for vector #',iTR - ovlp = Zero - kTR = 0 -*-----------Check all the remaining vectors - Do 1231 ldsp = 1, lDisp(0) - Do 1235 jTR = 1, iTR-1 - If (iTemp(jTR).eq.ldsp) Go To 1231 - 1235 Continue -* Write (*,*) ' Checking vector #', ldsp - call dcopy_(nTR,AM(:,ldsp),1,Tmp(:,iTR),1) -* Call RecPrt(' Vector',' ',Tmp(:,iTR),nTR,1) -*--------------Gram-Schmidt orthonormalize against accepted vectors - Do 1232 lTR = 1, iTR-1 - alpha = DDot_(nTR,Tmp(:,iTR),1,Tmp(:,lTR),1) -* Write (*,*) ' =', alpha - Call DaXpY_(nTR,-alpha,Tmp(:,lTR),1,Tmp(:,iTR),1) - 1232 Continue -* Call RecPrt(' Remainings',' ',Tmp(:,iTR),nTR,1) - alpha = DDot_(nTR,Tmp(:,iTR),1,Tmp(:,iTR),1) -* Write (*,*) ' Remaining overlap =', alpha -*--------------Check the remaining magnitude of vector after Gram-Schmidt - If (alpha.gt.ovlp) Then - kTR = ldsp - ovlp = alpha - End If - 1231 Continue - If (kTR.eq.0) Then - Write (6,*) ' No Vector found!' - Call Abend - End If -* Write (*,*) ' Selecting vector #', kTR -*-----------Pick up the "best" vector - call dcopy_(nTR,AM(:,kTR),1,Tmp(:,iTR),1) - Do 1233 lTR = 1, iTR-1 - alpha = DDot_(nTR,Tmp(:,iTR),1,Tmp(:,lTR),1) - Call DaXpY_(nTR,-alpha,Tmp(:,lTR),1,Tmp(:,iTR),1) - 1233 Continue - alpha = DDot_(nTR,Tmp(:,iTR),1,Tmp(:,iTR),1) - Call DScal_(nTR,One/Sqrt(alpha),Tmp(:,iTR),1) - iTemp(iTR) = kTR - 1230 Continue - Do 1234 iTR = 1, nTR - call dcopy_(nTR,AM(:,iTemp(iTR)),1,Tmp(:,iTR),1) - AM(:,iTemp(iTR))=Zero - 1234 Continue - If (iPrint.ge.99) Then - Call RecPrt(' The A matrix',' ',AM,nTR,lDisp(0)) - Call RecPrt(' The T matrix',' ',Tmp,nTR,nTR) - Write (6,*) (iTemp(iTR),iTR=1,nTR) - End If -* -* Compute the inverse of the T matrix -* - Call MatInvert(Tmp,nTR) - If (IPrint.ge.99) - & Call RecPrt(' The T-1 matrix',' ',Tmp,nTR,nTR) - Call DScal_(nTR**2,-One,Tmp,1) -* -* Generate the complete matrix -* - Call mma_allocate(Scr,nTR,lDisp(0),Label='Scr') - Call DGEMM_('N','N', - & nTR,lDisp(0),nTR, - & 1.0d0,Tmp,nTR, - & AM,nTR, - & 0.0d0,Scr,nTR) - If (IPrint.ge.99) - & Call RecPrt(' A-1*A',' ',Scr,nTR,lDisp(0)) - Call mma_deallocate(AM) - Call mma_allocate(AM,lDisp(0),lDisp(0),Label='AM') - AM(:,:)=Zero - Do i = 1, lDisp(0) - AM(i,i)=One - End Do - Do 1250 iTR = 1, nTR - ldsp = iTemp(iTR) - call dcopy_(lDisp(0),Scr(iTR,1),nTR,AM(ldsp,1),lDisp(0)) - 1250 Continue - If (iPrint.ge.99) - & Call RecPrt('Final A matrix',' ',AM,lDisp(0),lDisp(0)) -* -* - Call mma_deallocate(Scr) - Call mma_deallocate(Car) - Call mma_deallocate(C) - Call mma_deallocate(Tmp) - Do 1501 iTR = 1, nTR - ldsp = iTemp(iTR) - LPert(ldsp)=.False. - 1501 Continue -* - Write (6,*) - Write (6,'(20X,A,A)') - & ' Automatic utilization of translational and', - & ' rotational invariance of the energy is employed.' - Write (6,*) - Do 7000 i = 1, lDisp(0) - If (lpert(i)) Then - Write (6,'(25X,A,A)') Chdisp(i), ' is independent' - Else - Write (6,'(25X,A,A)') Chdisp(i), ' is dependent' - End If - 7000 Continue - Write (6,*) -* - Else - nTR = 0 - If (iPrint.ge.6) Then - Write (6,*) - Write (6,'(20X,A,A)') - & ' No automatic utilization of translational and', - & ' rotational invariance of the energy is employed.' - Write (6,*) - End If - End If -* - If (Slct) Then - Write (6,*) - Write (6,'(20X,A)') ' The Selection option is used' - Write (6,*) - Do 7100 i = 1, lDisp(0) - If (lpert(i)) Then - Write (6,'(25X,A,A)') Chdisp(i), ' is computed' - Else - Write (6,'(25X,A,A)') Chdisp(i), ' is set to zero' - End If - 7100 Continue - Write (6,*) - End If -* - 9876 Continue - Call Datimx(KWord) - Call ICopy(nIrrep,[0],0,nFck,1) - Do iIrrep=0,nIrrep-1 - If (iIrrep.ne.0) Then - Do jIrrep=0,nIrrep-1 - kIrrep=NrOpr(iEOR(ioper(jIrrep),ioper(iIrrep))) - If (kIrrep.lt.jIrrep) - & nFck(iIrrep)=nFck(iIrrep)+nBas(jIrrep)*nBas(kIrrep) - End Do - Else - Do jIrrep=0,nIrrep-1 - nFck(0)=nFck(0)+nBas(jIrrep)*(nBas(jIrrep)+1)/2 - End Do - End If - End Do -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/inputh.F90 openmolcas-22.10/src/mckinley/inputh.F90 --- openmolcas-22.02/src/mckinley/inputh.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/inputh.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,775 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991,1992, Roland Lindh * +! 1996, Anders Bernhardsson * +!*********************************************************************** + +subroutine Inputh(Run_MCLR) +!*********************************************************************** +! * +! Object: input module for the gradient code * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! September 1991 * +! * +! Modified to complement GetInf, January 1992 * +!*********************************************************************** + +use McKinley_global, only: lGrd, lHss, nFck, Nona, PreScr, sIrrep +use Index_Functions, only: nTri_Elem +use Basis_Info, only: dbsc, nBas, nCnttp +use Center_Info, only: dc +use Symmetry_Info, only: iChTbl, iOper, lBsFnc, lIrrep, nIrrep +use Gateway_global, only: Onenly, Test +use Gateway_Info, only: CutInt +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u5, u6, r8 + +implicit none +logical(kind=iwp), intent(out) :: Run_MCLR +#include "Molcas.fh" +#include "disp.fh" +#include "print.fh" +integer(kind=iwp) :: i, iCar, iCnt, iCnttp, iCo, iComp, idum, iDummer, iElem, iIrrep, ijSym, iOpt, ipert, iprint, iRC, iRout, & + istatus, iSym(3), iTR, j, jIrrep, jTR, k, kIrrep, kTR, ldsp, lTR, Lu_Mck, LuRd, mc, mdc, mDisp, nDisp, nSlct +real(kind=wp) :: alpha, Fact, ovlp +logical(kind=iwp) :: defPert, ltype, Slct !, DoCholesky +character(len=80) :: Key, KWord +character(len=32) :: Label2 +character(len=8) :: Label, labelop +integer(kind=iwp), allocatable :: ATDisp(:), Car(:), DEGDisp(:), iTemp(:), TDisp(:) +logical(kind=iwp), allocatable :: lPert(:) +real(kind=wp), allocatable :: AM(:,:), C(:,:), Scr(:,:), Tmp(:,:) +character, parameter :: xyz(0:2) = ['x','y','z'] +integer(kind=iwp), external :: iPrmt, NrOpr +real(kind=r8), external :: DDot_ +logical(kind=iwp), external :: TstFnc + +!call DecideOnCholesky(DoCholesky) +!if (DoCholesky) then +! write(u6,*)'** Cholesky or RI/DF not yet implemented in McKinley ' +! call abend() +!end if + +iRout = 99 +nPrint(:) = 5 +show = .false. +Onenly = .false. +Test = .false. +TRSymm = .false. +lEq = .false. +Slct = .false. +PreScr = .true. +lGrd = .true. +lHss = .true. +Nona = .false. +Run_MCLR = .true. +CutInt = 1.0e-7_wp +ipert = 2 +defPert = .true. +call mma_allocate(lPert,0,label='lPert') +lPert(:) = defPert +sIrrep = .false. +iprint = 0 +do i=1,3*MxAtom + IndxEq(i) = i +end do + +! KeyWord directed input + +LuRd = u5 +call RdNLst(LuRd,'MCKINLEY') +do + read(u5,'(A72)',iostat=istatus) Key + if (istatus < 0) call Error(1) + if (istatus > 0) call Error(2) + KWord = Key + call UpCase(KWord) + if (KWord(1:1) == '*') cycle + if (KWord == '') cycle + select case (KWord(1:4)) + !case ('EQUI') + ! ! * + ! !***** EQUI ****************************************************** + ! ! * + ! ! Equivalence option + ! + ! lEq = .true. + ! do + ! read(u5,'(A)',iostat=istatus) KWord + ! if (istatus > 0) call Error(2) + ! if ((KWord(1:1) /= '*') .and. (KWord /= '')) exit + ! end do + ! read(KWord,*) nGroup + ! do iGroup=1,nGroup + ! do + ! read(u5,'(A)',iostat=istatus) KWord + ! if (istatus > 0) call Error(2) + ! if ((KWord(1:1) /= '*') .and. (KWord /= '')) exit + ! end do + ! read(KWord,*) nElem,(iTemp(iElem),iElem=1,nElem) + ! do iElem=2,nElem + ! IndxEq(iTemp(iElem)) = iTemp(1) + ! Direct(iTemp(iElem)) = .false. + ! end do + ! end do + + !case ('NOIN') + ! ! * + ! !***** NOIN ****************************************************** + ! ! * + ! ! Disable the utilization of translational and + ! ! rotational invariance of the energy in the + ! ! computation of the molecular gradient. + ! + ! TRSymm = .false. + + case ('SHOW') + ! * + !***** SHOW ****************************************************** + ! * + ! Raise the printlevel to show gradient contributions + + Show = .true. + + case ('CUTO') + ! * + !***** CUTO ****************************************************** + ! * + ! Cutoff for computing primitive gradients + + !do + ! read(u5,'(A)',iostat=istatus) KWord + ! if (istatus > 0) call Error(2) + ! if ((KWord(1:1) /= '*') .and. (KWord /= '')) exit + !end do + !read(KWord,*,iostat=istatus) CutInt + !if (istatus > 0) call Error(2) + read(u5,*) Cutint + CutInt = abs(CutInt) + + case ('VERB') + ! * + !***** VERB ****************************************************** + ! * + ! Verbose output + + nPrint(1) = 6 + nPrint(99) = 6 + + case ('NOSC') + ! * + !***** NOSC ****************************************************** + ! * + ! Change default for the prescreening. + + PreScr = .false. + + case ('ONEO') + ! * + !***** ONEO ****************************************************** + ! * + ! Do not compute two electron integrals. + + Onenly = .true. + + case ('SELE') + ! * + !***** SELE ****************************************************** + ! * + ! selection option + + Slct = .true. + defPert = .false. + lPert(:) = defPert + !do + ! read(u5,'(A)',iostat=istatus) KWord + ! if (istatus > 0) call Error(2) + ! if ((KWord(1:1) /= '*') .and. (KWord /= '')) exit + !end do + !read(KWord,*) nSlct + read(u5,*) nSlct + + call mma_allocate(iTemp,nSlct,label='iTemp') + read(u5,*) (iTemp(iElem),iElem=1,nSlct) + do iElem=1,nSlct + call extend_lPert(iTemp(iElem)) + lPert(iTemp(iElem)) = .true. + end do + call mma_deallocate(iTemp) + + case ('REMO') + ! * + !***** REMO ****************************************************** + ! * + Slct = .true. + read(u5,*) nSlct + + call mma_allocate(iTemp,nSlct,label='iTemp') + read(u5,*) (iTemp(iElem),iElem=1,nSlct) + do iElem=1,nSlct + call extend_lPert(iTemp(iElem)) + lPert(iTemp(iElem)) = .false. + end do + call mma_deallocate(iTemp) + + case ('PERT') + ! * + !***** PERT ****************************************************** + ! * + ! Select which part of the Hessian will be computed. + + do + read(u5,'(A)',iostat=istatus) KWord + if (istatus > 0) call Error(2) + if ((KWord(1:1) /= '*') .and. (KWord /= '')) exit + end do + call UpCase(KWord) + if (KWORD(1:4) == 'HESS') then + ipert = 2 + else if (KWORD(1:4) == 'GEOM') then + ipert = 1 + else + write(u6,*) 'InputH: Illegal perturbation keyword' + write(u6,'(A,A)') 'KWord=',KWord + call Abend() + end if + + case ('TEST') + ! * + !***** TEST ****************************************************** + ! * + ! Process only the input. + + Test = .true. + + case ('EXTR') + ! * + !***** EXTR ****************************************************** + ! * + ! Put the program name and the time stamp onto the extract file + + write(u6,*) 'InputH: EXTRACT option is redundant and is ignored!' + + case ('NONA') + ! * + !***** NONA ****************************************************** + ! * + ! Compute the anti-symmetric overlap gradient only. + + Nona = .true. + Run_MCLR = .false. + + case ('NOMC') + ! * + !***** NOMC ****************************************************** + ! * + ! Request no automatic run of MCLR + + Run_MCLR = .false. + + case ('END ') + ! * + !***** END ****************************************************** + ! * + exit + + case default + write(u6,*) 'InputH: Illegal keyword' + write(u6,'(A,A)') 'KWord=',KWord + call Abend() + end select +end do +!*********************************************************************** +! * +! End of input section. * +! * +!*********************************************************************** + +iPrint = nPrint(iRout) + +iOpt = 1 +if (onenly) iopt = 0 +iRC = -1 +Lu_Mck = 35 +call OpnMck(irc,iOpt,'MCKINT',Lu_Mck) +if (iRC /= 0) then + write(u6,*) 'InputH: Error opening MCKINT' + call Abend() +end if +if (ipert == 1) then + Label2 = 'Geometry' + LabelOp = 'PERT ' + irc = -1 + iopt = 0 + call cWrMck(iRC,iOpt,LabelOp,1,Label2,iDummer) + sIrrep = .true. +else if (ipert == 2) then + Label2 = 'Hessian' + LabelOp = 'PERT ' + call cWrMck(iRC,iOpt,LabelOp,1,Label2,iDummer) +else if (ipert == 3) then + LabelOp = 'PERT ' + Label2 = 'Magnetic' + call cWrMck(iRC,iOpt,LabelOp,1,Label2,iDummer) + write(u6,*) 'InputH: Illegal perturbation option' + write(u6,*) 'iPert=',iPert + call Abend() +else if (ipert == 4) then + LabelOp = 'PERT ' + Label2 = 'Relativistic' + call cWrMck(iRC,iOpt,LabelOp,1,Label2,iDummer) + write(u6,*) 'InputH: Illegal perturbation option' + write(u6,*) 'iPert=',iPert + call Abend() +else + write(u6,*) 'InputH: Illegal perturbation option' + write(u6,*) 'iPert=',iPert + call Abend() +end if + +!if (lEq) TRSymm = .false. +!if (Slct) TRSymm = .false. + +mDisp = 0 +mdc = 0 +do iCnttp=1,nCnttp + do iCnt=1,dbsc(iCnttp)%nCntr + mdc = mdc+1 + mDisp = mDisp+3*(nIrrep/dc(mdc)%nStab) + end do +end do + +write(u6,*) +write(u6,'(20X,A,E10.3)') ' Threshold for contributions to the gradient or Hessian:',CutInt +write(u6,*) + +if (Nona) then + write(u6,*) + write(u6,'(20X,A)') ' McKinley only is computing the antisymmetric gradient of the overlap integrals for the NonAdiabatic '// & + 'Coupling.' + write(u6,*) +end if + +! Generate symmetry adapted cartesian displacements + +if (iPrint >= 6) then + write(u6,*) + write(u6,'(20X,A)') '********************************************' + write(u6,'(20X,A)') '* Symmetry Adapted Cartesian Displacements *' + write(u6,'(20X,A)') '********************************************' + write(u6,*) +end if +IndDsp(:,:) = 0 +InxDsp(:,:) = 0 +call mma_allocate(ATDisp,mDisp,Label='ATDisp') +call mma_allocate(DEGDisp,mDisp,Label='DEGDisp') +nDisp = 0 +do iIrrep=0,nIrrep-1 + lDisp(iIrrep) = 0 + ltype = .true. + ! Loop over basis function definitions + mdc = 0 + mc = 1 + do iCnttp=1,nCnttp + ! Loop over unique centers associated with this basis set. + do iCnt=1,dbsc(iCnttp)%nCntr + mdc = mdc+1 + IndDsp(mdc,iIrrep) = nDisp + ! Loop over the cartesian components + do iCar=0,2 + iComp = 2**iCar + if (TstFnc(dc(mdc)%iCoSet,iIrrep,iComp,dc(mdc)%nStab)) then + nDisp = nDisp+1 + if (nDisp > mDisp) then + write(u6,*) 'nDisp > mDisp' + call Abend() + end if + if (iIrrep == 0) InxDsp(mdc,iCar+1) = nDisp + lDisp(iIrrep) = lDisp(iIrrep)+1 + if (ltype) then + if (iPrint >= 6) then + write(u6,*) + write(u6,'(10X,A,A)') ' Irreducible representation : ',lIrrep(iIrrep) + write(u6,'(10X,2A)') ' Basis function(s) of irrep: ',lBsFnc(iIrrep) + write(u6,*) + write(u6,'(A)') ' Basis Label Type Center Phase' + end if + ltype = .false. + end if + if (iPrint >= 6) & + write(u6,'(I4,3X,A8,5X,A1,7X,8(I3,4X,I2,4X))') nDisp,dc(mdc)%LblCnt,xyz(iCar), & + (mc+iCo,iPrmt(NrOpr(dc(mdc)%iCoSet(iCo,0)),iComp)* & + iChTbl(iIrrep,NrOpr(dc(mdc)%iCoSet(iCo,0))), & + iCo=0,nIrrep/dc(mdc)%nStab-1) + write(ChDisp(nDisp),'(A,1X,A1)') dc(mdc)%LblCnt,xyz(iCar) + ATDisp(ndisp) = icnttp + DEGDisp(ndisp) = nIrrep/dc(mdc)%nStab + end if + + end do + mc = mc+nIrrep/dc(mdc)%nStab + end do + end do + +end do + +if (nDisp /= mDisp) then + write(u6,*) 'InputH: nDisp /= mDisp' + write(u6,*) 'nDisp,mDisp=',nDisp,mDisp + call Abend() +end if +if (sIrrep) then + ndisp = ldisp(0) + lDisp(1:nIrrep-1) = 0 +end if +call mma_allocate(TDisp,nDisp,Label='TDisp') +TDisp(:) = 30 +iOpt = 0 +iRC = -1 +labelOp = 'ndisp ' +call iWrMck(iRC,iOpt,labelop,1,[ndisp],iDummer) +if (iRC /= 0) then + write(u6,*) 'InputH: Error writing to MCKINT' + write(u6,'(A,A)') 'labelOp=',labelOp + call Abend() +end if +LABEL = 'DEGDISP' +iRc = -1 +iOpt = 0 +call iWrMck(iRC,iOpt,Label,idum,DEGDISP,idum) +if (iRC /= 0) then + write(u6,*) 'InputH: Error writing to MCKINT' + write(u6,'(A,A)') 'LABEL=',LABEL + call Abend() +end if +call mma_deallocate(DEGDisp) +LABEL = 'NRCTDISP' +iRc = -1 +iOpt = 0 +call iWrMck(iRC,iOpt,Label,idum,ATDisp,idum) +if (iRC /= 0) then + write(u6,*) 'InputH: Error writing to MCKINT' + write(u6,'(A,A)') 'LABEL=',LABEL + call Abend() +end if +call mma_deallocate(ATDisp) +LABEL = 'TDISP' +iRc = -1 +iOpt = 0 +call iWrMck(iRC,iOpt,Label,idum,TDisp,idum) +if (iRC /= 0) then + write(u6,*) 'InputH: Error writing to MCKINT' + write(u6,'(A,A)') 'LABEL=',LABEL + call Abend() +end if +call mma_deallocate(TDisp) + +! Set up data for the utilization of the translational +! and rotational invariance of the energy. + +if (TRSymm) then + call Abend() + iSym(1) = 0 + iSym(2) = 0 + iSym(3) = 0 + do i=1,min(nIrrep-1,5) + j = i + if (i == 3) j = 4 + do k=1,3 + if (btest(iOper(j),k-1)) iSym(k) = 2**(k-1) + end do + end do + nTR = 0 + ! Translational equations + do i=1,3 + if (iSym(i) == 0) nTR = nTR+1 + end do + if (iPrint >= 99) write(u6,*) ' nTR=',nTR + ! Rotational equations + do i=1,3 + j = i+1 + if (j > 3) j = j-3 + k = i+2 + if (k > 3) k = k-3 + ijSym = ieor(iSym(j),iSym(k)) + if (ijSym == 0) nTR = nTR+1 + end do + if (nTR == 0) then + TRSymm = .false. + else + if (iPrint >= 99) write(u6,*) ' nTR=',nTR + call mma_allocate(AM,nTR,lDisp(0),Label='AM') + call mma_allocate(Tmp,nTR,nTR,Label='Tmp') + call mma_allocate(C,4,lDisp(0),Label='C') + call mma_allocate(Car,lDisp(0),Label='Car') + + AM(:,:) = Zero + C(:,:) = Zero + + ! Generate temporary information of the symmetrical displacements. + + ldsp = 0 + mdc = 0 + iIrrep = 0 + do iCnttp=1,nCnttp + do iCnt=1,dbsc(iCnttp)%nCntr + mdc = mdc+1 + !call RecPrt(' Coordinates',' ',dbsc(iCnttp)%Coor(1,iCnt),1,3) + Fact = Zero + iComp = 0 + if (dbsc(iCnttp)%Coor(1,iCnt) /= Zero) iComp = ibset(iComp,0) + if (dbsc(iCnttp)%Coor(2,iCnt) /= Zero) iComp = ibset(iComp,1) + if (dbsc(iCnttp)%Coor(3,iCnt) /= Zero) iComp = ibset(iComp,2) + do jIrrep=0,nIrrep-1 + if (TstFnc(dc(mdc)%iCoSet,jIrrep,iComp,dc(mdc)%nStab)) then + Fact = Fact+One + end if + end do + do iCar=0,2 + iComp = 2**iCar + if (TstFnc(dc(mdc)%iCoSet,iIrrep,iComp,dc(mdc)%nStab)) then + ldsp = ldsp+1 + ! Transfer the coordinates + C(1:3,ldsp) = dbsc(iCnttp)%Coor(:,iCnt) + ! Transfer the multiplicity factor + C(4,ldsp) = Fact + Car(ldsp) = iCar+1 + end if + end do + end do + end do + if (iPrint >= 99) then + call RecPrt(' Information',' ',C,4,lDisp(0)) + write(u6,*) (Car(i),i=1,lDisp(0)) + end if + + ! Set up coefficient for the translational equations + + iTR = 0 + do i=1,3 + if (iSym(i) /= 0) cycle + iTR = iTR+1 + do ldsp=1,lDisp(0) + if (Car(ldsp) == i) AM(iTR,ldsp) = C(4,ldsp) + end do + end do + + ! Set up coefficient for the rotational invariance + + do i=1,3 + j = i+1 + if (j > 3) j = j-3 + k = i+2 + if (k > 3) k = k-3 + ijSym = ieor(iSym(j),iSym(k)) + if (ijSym /= 0) cycle + iTR = iTR+1 + do ldsp=1,lDisp(0) + if (Car(ldsp) == j) then + Fact = C(4,ldsp)*C(k,ldsp) + else if (Car(ldsp) == k) then + Fact = -C(4,ldsp)*C(j,ldsp) + else + Fact = Zero + write(u6,*) 'Inputh: Error' + call Abend() + end if + AM(iTR,ldsp) = Fact + end do + end do + if (iPrint >= 99) call RecPrt(' The A matrix',' ',AM,nTR,lDisp(0)) + + ! Now, transfer the coefficient of those gradients which will + ! not be computed directly. + ! The matrix to compute the inverse of is determined via + ! a Gram-Schmidt procedure. + + ! Pick up the other vectors + do iTR=1,nTR + !write(u6,*) ' Looking for vector #',iTR + ovlp = Zero + kTR = 0 + ! Check all the remaining vectors + loop1: do ldsp=1,lDisp(0) + do jTR=1,iTR-1 + if (iTemp(jTR) == ldsp) cycle loop1 + end do + !write(u6,*) ' Checking vector #', ldsp + Tmp(:,iTR) = AM(:,ldsp) + !call RecPrt(' Vector',' ',Tmp(:,iTR),nTR,1) + ! Gram-Schmidt orthonormalize against accepted vectors + do lTR=1,iTR-1 + alpha = DDot_(nTR,Tmp(:,iTR),1,Tmp(:,lTR),1) + !write(u6,*) ' =', alpha + Tmp(:,iTR) = Tmp(:,iTR)-alpha*Tmp(:,lTR) + end do + !call RecPrt(' Remainings',' ',Tmp(:,iTR),nTR,1) + alpha = DDot_(nTR,Tmp(:,iTR),1,Tmp(:,iTR),1) + !write(u6,*) ' Remaining overlap =', alpha + ! Check the remaining magnitude of vector after Gram-Schmidt + if (alpha > ovlp) then + kTR = ldsp + ovlp = alpha + end if + end do loop1 + if (kTR == 0) then + write(u6,*) ' No Vector found!' + call Abend() + end if + !write(u6,*) ' Selecting vector #', kTR + ! Pick up the "best" vector + Tmp(:,iTR) = AM(:,kTR) + do lTR=1,iTR-1 + alpha = DDot_(nTR,Tmp(:,iTR),1,Tmp(:,lTR),1) + Tmp(:,iTR) = Tmp(:,iTR)-alpha*Tmp(:,lTR) + end do + alpha = DDot_(nTR,Tmp(:,iTR),1,Tmp(:,iTR),1) + Tmp(:,iTR) = Tmp(:,iTR)/sqrt(alpha) + iTemp(iTR) = kTR + end do + do iTR=1,nTR + Tmp(:,iTR) = AM(:,iTemp(iTR)) + AM(:,iTemp(iTR)) = Zero + end do + if (iPrint >= 99) then + call RecPrt(' The A matrix',' ',AM,nTR,lDisp(0)) + call RecPrt(' The T matrix',' ',Tmp,nTR,nTR) + write(u6,*) (iTemp(iTR),iTR=1,nTR) + end if + + ! Compute the inverse of the T matrix + + call MatInvert(Tmp,nTR) + if (IPrint >= 99) call RecPrt(' The T-1 matrix',' ',Tmp,nTR,nTR) + Tmp(:,:) = -Tmp + + ! Generate the complete matrix + + call mma_allocate(Scr,nTR,lDisp(0),Label='Scr') + call DGEMM_('N','N',nTR,lDisp(0),nTR,One,Tmp,nTR,AM,nTR,Zero,Scr,nTR) + if (IPrint >= 99) call RecPrt(' A-1*A',' ',Scr,nTR,lDisp(0)) + call mma_deallocate(AM) + call mma_allocate(AM,lDisp(0),lDisp(0),Label='AM') + AM(:,:) = Zero + do i=1,lDisp(0) + AM(i,i) = One + end do + do iTR=1,nTR + ldsp = iTemp(iTR) + AM(ldsp,:) = Scr(iTR,1:lDisp(0)) + end do + if (iPrint >= 99) call RecPrt('Final A matrix',' ',AM,lDisp(0),lDisp(0)) + + call mma_deallocate(Scr) + call mma_deallocate(Car) + call mma_deallocate(C) + call mma_deallocate(Tmp) + do iTR=1,nTR + ldsp = iTemp(iTR) + call extend_lPert(ldsp) + lPert(ldsp) = .false. + end do + + write(u6,*) + write(u6,'(20X,A)') ' Automatic utilization of translational and rotational invariance of the energy is employed.' + write(u6,*) + call extend_lPert(lDisp(0)) + do i=1,lDisp(0) + if (lPert(i)) then + write(u6,'(25X,A,A)') Chdisp(i),' is independent' + else + write(u6,'(25X,A,A)') Chdisp(i),' is dependent' + end if + end do + write(u6,*) + end if + +else + nTR = 0 + if (iPrint >= 6) then + write(u6,*) + write(u6,'(20X,A)') ' No automatic utilization of translational and rotational invariance of the energy is employed.' + write(u6,*) + end if +end if + +if (Slct) then + write(u6,*) + write(u6,'(20X,A)') ' The Selection option is used' + write(u6,*) + call extend_lPert(lDisp(0)) + do i=1,lDisp(0) + if (lPert(i)) then + write(u6,'(25X,A,A)') Chdisp(i),' is computed' + else + write(u6,'(25X,A,A)') Chdisp(i),' is set to zero' + end if + end do + write(u6,*) +end if + +call Datimx(KWord) +nFck(0:nIrrep-1) = 0 +do iIrrep=0,nIrrep-1 + if (iIrrep /= 0) then + do jIrrep=0,nIrrep-1 + kIrrep = NrOpr(ieor(ioper(jIrrep),ioper(iIrrep))) + if (kIrrep < jIrrep) nFck(iIrrep) = nFck(iIrrep)+nBas(jIrrep)*nBas(kIrrep) + end do + else + do jIrrep=0,nIrrep-1 + nFck(0) = nFck(0)+nTri_Elem(nBas(jIrrep)) + end do + end if +end do + +call mma_deallocate(lPert) + +return + +contains + +subroutine Extend_lPert(n) + + integer(kind=iwp), intent(in) :: n + integer(kind=iwp) :: m + logical(kind=iwp), allocatable :: Temp(:) + + m = size(lPert) + if (n > m) then + call mma_allocate(Temp,n,label='lPert') + Temp(:m) = lPert + Temp(m+1:) = defPert + call mma_deallocate(lPert) + call move_alloc(Temp,lPert) + end if + +end subroutine Extend_lPert + +subroutine Error(code) + + integer(kind=iwp), intent(in) :: code + + select case (code) + case (1) + write(u6,*) 'InputH: end of input file.' + case (2) + write(u6,*) 'InputH: error reading input file.' + end select + write(u6,'(A,A)') 'Last command=',KWord + call Abend() + +end subroutine Error + +end subroutine Inputh diff -Nru openmolcas-22.02/src/mckinley/k2loop_mck.f openmolcas-22.10/src/mckinley/k2loop_mck.f --- openmolcas-22.02/src/mckinley/k2loop_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/k2loop_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,149 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990-1992, Roland Lindh * -* 1990, IBM * -* 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine k2Loop_mck(Coor, - & iAnga,iCmpa, - & iDCRR,nDCRR,Data, ijCmp, - & Alpha,nAlpha,Beta,nBeta, - & Coeff1,iBasn,Coeff2,jBasn, - & nMemab,Con, - & Wk002,m002,Wk003,m003,Wk004,m004, - & iStb,jStb) -************************************************************************ -* * -* Object: to compute zeta, kappa, and P. * -* This is done for all unique pairs of centers * -* generated from the symmetry unique centers A and B. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* June '91, modified to compute zeta, P, kappa and inte- * -* grals for Schwartz inequality in a k2 loop. * -* January '92 modified to gradient calculations. * -* April '92, modified to use the Cauchy-Schwarz inequality * -* to estimate the integral derivatives. * -* * -* May '95 modified (simplified) for hessian calculation * -* By Anders Bernhardsson * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "ndarray.fh" -#include "real.fh" -#include "disp.fh" -#include "disp2.fh" - Real*8 Coor(3,2), CoorM(3,4), Alpha(nAlpha), Beta(nBeta), - & Data(nAlpha*nBeta*nDArray+nDScalar,nDCRR), - & Coeff1(nAlpha,iBasn), Coeff2(nBeta,jBasn), - & Wk002(m002),Wk003(m003),Wk004(m004), Con(nAlpha*nBeta) - Integer iDCRR(0:7), iAnga(4), iCmpa(4), mStb(2) -* - Call k2Loop_mck_internal(Data) -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Con) - Call Unused_real_array(Wk004) - End If -* -* This is to allow type punning without an explicit interface - Contains - SubRoutine k2Loop_mck_internal(Data) - Use Iso_C_Binding - Real*8, Target :: Data(nAlpha*nBeta*nDArray+nDScalar,nDCRR) - Integer, Pointer :: iData(:) - nZeta = nAlpha*nBeta - mStb(1) = iStb - mStb(2) = jStb -* - CoorM(1,1) = Coor(1,1) - CoorM(2,1) = Coor(2,1) - CoorM(3,1) = Coor(3,1) -* - Do 100 lDCRR = 0, nDCRR-1 -* - Call OA(iDCRR(lDCRR),Coor(1:3,2),CoorM(1:3,2)) - call dcopy_(6,CoorM(1,1),1,CoorM(1,3),1) -* -*--------Compute Zeta, P and kappa. -* - Call C_F_Pointer(C_Loc(Data(ip_IndZ(1,nZeta),lDCRR+1)), - & iData,[nAlpha*nBeta+1]) - Call DoZeta(Alpha,nAlpha,Beta,nBeta, - & CoorM(1,1),CoorM(1,2), - & Data(ip_PCoor(1,nZeta),lDCRR+1), - & Data(ip_Z (1,nZeta),lDCRR+1), - & Data(ip_Kappa(1,nZeta),lDCRR+1), - & Data(ip_ZInv (1,nZeta),lDCRR+1), - & Data(ip_Alpha(1,nZeta,1),lDCRR+1), - & Data(ip_Beta (1,nZeta,2),lDCRR+1), - & iData) - Nullify(iData) -* - Call SchInt_mck(CoorM,iAnga,iCmpa,nAlpha,nBeta,nMemab, - & Data(ip_Z(1,nZeta),lDCRR+1), - & Data(ip_ZInv(1,nZeta),lDCRR+1), - & Data(ip_Kappa(1,nZeta),lDCRR+1), - & Data(ip_PCoor(1,nZeta),lDCRR+1), - & nZeta,Wk002,m002,Wk003,m003) -* - Call PckInt_mck(Wk002,nZeta,ijCmp, - & Data(ip_ab(1,nZeta),lDCRR+1), - & Data(ip_Z(1,nZeta),lDCRR+1)) -* * -************************************************************************ -* * -* Estimate the largest contracted integral. -* - Call C_F_Pointer(C_Loc(Data(ip_IndZ(1,nZeta),lDCRR+1)), - & iData,[nAlpha*nBeta+1]) - Data(ip_EstI(nZeta),lDCRR+1) = - & EstI(Data(ip_Z(1,nZeta),lDCRR+1), - & Data(ip_Kappa(1,nZeta),lDCRR+1), - & nAlpha,nBeta, - & Coeff1,iBasn,Coeff2,jBasn, - & Data(ip_ab (1,nZeta),lDCRR+1), - & iCmpa(1)*iCmpa(2), - & Wk002,m002, - & iData) -* * -************************************************************************ -* * -*------- Find the largest integral estimate (AO Basis). -* - Tst = -One - Do iZeta = 0, nZeta-1 - Tst=Max(Data(ip_Z(iZeta+1,nZeta),lDCRR+1),Tst) - End Do - Data(ip_ZetaM(nZeta),lDCRR+1) = tst -* - Tst = -One - ZtMax=Zero - abMax=Zero - Do iZeta = 1, nZeta - tmp = Data(ip_ab(iZeta,nZeta),lDCRR+1) - If (Tst.lt.tmp) Then - Tst = tmp - ZtMax = Data(ip_Z (iZeta,nZeta),lDCRR+1) - abMax = Data(ip_ab(iZeta,nZeta),lDCRR+1) - End If - End Do - Data(ip_ZtMax(nZeta),lDCRR+1) = ZtMax - Data(ip_abMax(nZeta),lDCRR+1) = abMax - 100 Continue -* - Return - End SubRoutine k2Loop_mck_internal -* - End diff -Nru openmolcas-22.02/src/mckinley/k2loop_mck.F90 openmolcas-22.10/src/mckinley/k2loop_mck.F90 --- openmolcas-22.02/src/mckinley/k2loop_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/k2loop_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,128 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990-1992, Roland Lindh * +! 1990, IBM * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine k2Loop_mck(Coor,iAnga,iCmpa,iDCRR,nDCRR,rData,ijCmp,Alpha,nAlpha,Beta,nBeta,Coeff1,iBasn,Coeff2,jBasn,nMemab,Wk002, & + m002,Wk003,m003,iStb,jStb) +!*********************************************************************** +! * +! Object: to compute zeta, kappa, and P. * +! This is done for all unique pairs of centers * +! generated from the symmetry unique centers A and B. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! June '91, modified to compute zeta, P, kappa and inte- * +! grals for Schwartz inequality in a k2 loop. * +! January '92 modified to gradient calculations. * +! April '92, modified to use the Cauchy-Schwarz inequality * +! to estimate the integral derivatives. * +! * +! May '95 modified (simplified) for hessian calculation * +! By Anders Bernhardsson * +!*********************************************************************** + +use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +#include "ndarray.fh" +integer(kind=iwp), intent(in) :: iAnga(4), iCmpa(4), iDCRR(0:7), nDCRR, ijCmp, nAlpha, nBeta, iBasn, jBasn, nMemab, m002, m003, & + iStb, jStb +real(kind=wp), intent(in) :: Coor(3,2), Alpha(nAlpha), Beta(nBeta), Coeff1(nAlpha,iBasn), Coeff2(nBeta,jBasn) +real(kind=wp), intent(out) :: rData(nAlpha*nBeta*nDArray+nDScalar,nDCRR), Wk002(m002) +real(kind=wp), intent(inout) :: Wk003(m003) +integer(kind=iwp) :: mStb(2), nZeta +real(kind=wp) :: abMax, CoorM(3,4), tmp, Tst, ZtMax +integer(kind=iwp), external :: ip_ab, ip_abMax, ip_Alpha, ip_Beta, ip_EstI, ip_IndZ, ip_Kappa, ip_PCoor, ip_Z, ip_ZetaM, ip_ZInv, & + ip_ZtMax +real(kind=wp), external :: EstI + +call k2Loop_mck_internal(rData) + +! This is to allow type punning without an explicit interface +contains + +subroutine k2Loop_mck_internal(rData) + + real(kind=wp), target :: rData(nAlpha*nBeta*nDArray+nDScalar,nDCRR) + integer(kind=iwp), pointer :: iData(:) + integer(kind=iwp) :: iZeta, lDCRR + + nZeta = nAlpha*nBeta + mStb(1) = iStb + mStb(2) = jStb + + CoorM(1,1) = Coor(1,1) + CoorM(2,1) = Coor(2,1) + CoorM(3,1) = Coor(3,1) + + do lDCRR=0,nDCRR-1 + + call OA(iDCRR(lDCRR),Coor(1:3,2),CoorM(1:3,2)) + CoorM(:,3:4) = CoorM(:,1:2) + + ! Compute Zeta, P and kappa. + + call c_f_pointer(c_loc(rData(ip_IndZ(1,nZeta),lDCRR+1)),iData,[nAlpha*nBeta+1]) + call DoZeta(Alpha,nAlpha,Beta,nBeta,CoorM(1,1),CoorM(1,2),rData(ip_PCoor(1,nZeta),lDCRR+1),rData(ip_Z(1,nZeta),lDCRR+1), & + rData(ip_Kappa(1,nZeta),lDCRR+1),rData(ip_ZInv(1,nZeta),lDCRR+1),rData(ip_Alpha(1,nZeta,1),lDCRR+1), & + rData(ip_Beta(1,nZeta,2),lDCRR+1),iData) + nullify(iData) + + call SchInt_mck(CoorM,iAnga,nAlpha,nBeta,nMemab,rData(ip_Z(1,nZeta),lDCRR+1),rData(ip_ZInv(1,nZeta),lDCRR+1), & + rData(ip_Kappa(1,nZeta),lDCRR+1),rData(ip_PCoor(1,nZeta),lDCRR+1),nZeta,Wk002,m002,Wk003,m003) + + call PckInt_mck(Wk002,nZeta,ijCmp,rData(ip_ab(1,nZeta),lDCRR+1)) + ! * + !******************************************************************* + ! * + ! Estimate the largest contracted integral. + + call c_f_pointer(c_loc(rData(ip_IndZ(1,nZeta),lDCRR+1)),iData,[nAlpha*nBeta+1]) + rData(ip_EstI(nZeta),lDCRR+1) = EstI(rData(ip_Z(1,nZeta),lDCRR+1),rData(ip_Kappa(1,nZeta),lDCRR+1),nAlpha,nBeta,Coeff1,iBasn, & + Coeff2,jBasn,rData(ip_ab(1,nZeta),lDCRR+1),iCmpa(1)*iCmpa(2),Wk002,m002,iData) + ! * + !******************************************************************* + ! * + ! Find the largest integral estimate (AO Basis). + + Tst = -One + do iZeta=0,nZeta-1 + Tst = max(rData(ip_Z(iZeta+1,nZeta),lDCRR+1),Tst) + end do + rData(ip_ZetaM(nZeta),lDCRR+1) = tst + + Tst = -One + ZtMax = Zero + abMax = Zero + do iZeta=1,nZeta + tmp = rData(ip_ab(iZeta,nZeta),lDCRR+1) + if (Tst < tmp) then + Tst = tmp + ZtMax = rData(ip_Z(iZeta,nZeta),lDCRR+1) + abMax = rData(ip_ab(iZeta,nZeta),lDCRR+1) + end if + end do + rData(ip_ZtMax(nZeta),lDCRR+1) = ZtMax + rData(ip_abMax(nZeta),lDCRR+1) = abMax + end do + + return + +end subroutine k2Loop_mck_internal + +end subroutine k2Loop_mck diff -Nru openmolcas-22.02/src/mckinley/knegrd_mck.f openmolcas-22.10/src/mckinley/knegrd_mck.f --- openmolcas-22.02/src/mckinley/knegrd_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/knegrd_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,143 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine KnEGrd_mck( -#define _CALLING_ -#include "grd_mck_interface.fh" - & ) -************************************************************************ -* * -* Object: to compute the gradient of the kinetic energy integrals * -* with the Gauss-Hermite quadrature * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* November '90 * -* Anders Bernhardsson,1995 * -************************************************************************ - use Her_RW - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - -#include "grd_mck_interface.fh" - -* Local variables - Logical ABeq(3) -* -* Statement function for Cartesian index -* - nElem(li)=(li+1)*(li+2)/2 -* - ABeq(1) = A(1).eq.RB(1) - ABeq(2) = A(2).eq.RB(2) - ABeq(3) = A(3).eq.RB(3) -* - nip = 1 - ipAxyz = nip - nip = nip + nZeta*3*nHer*(la+3) - ipBxyz = nip - nip = nip + nZeta*3*nHer*(lb+3) - ipRxyz = nip - nip = nip + nZeta*3*nHer*(nOrdOp+1) - ipRnxyz = nip - nip = nip + nZeta*3*(la+3)*(lb+3)*(nOrdOp+1) - ipTxyz = nip - nip = nip + nZeta*3*(la+2)*(lb+2) - ipA = nip - nip = nip + nZeta - ipB = nip - nip = nip + nZeta - ipSc=nip - nip=nip+nElem(la)*nElem(lb)*nZeta - If (nip-1.gt.nArr) Then - Write (6,*) 'KneGrd_Mck: nip-1.gt.nArr' - Write (6,*) 'nip,nArr=',nip,nArr - Call Abend() - End If -* -#ifdef _DEBUGPRINT_ - Call RecPrt(' In KnEGrd: A',' ',A,1,3) - Call RecPrt(' In KnEGrd: B',' ',B,1,3) - Call RecPrt(' In KnEGrd: Ccoor',' ',Ccoor,1,3) - Call RecPrt(' In KnEGrd: P',' ',P,nZeta,3) - Write (6,*) ' In KnEGrd: la,lb=',la,lb -#endif -* -* Compute the cartesian values of the basis functions angular part -* - Call CrtCmp(Zeta,P,nZeta,A,Array(ipAxyz), - & la+2,HerR(iHerR(nHer)),nHer,ABeq) - Call CrtCmp(Zeta,P,nZeta,RB,Array(ipBxyz), - & lb+2,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the contribution from the multipole moment operator -* - ABeq(1) = .False. - ABeq(2) = .False. - ABeq(3) = .False. - Call CrtCmp(Zeta,P,nZeta,Ccoor,Array(ipRxyz), - & nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the cartesian components for the multipole moment -* integrals. The integrals are factorized into components. -* - Call Assmbl(Array(ipRnxyz), - & Array(ipAxyz),la+2, - & Array(ipRxyz),nOrdOp, - & Array(ipBxyz),lb+2, - & nZeta,HerW(iHerW(nHer)),nHer) -* -* Compute the cartesian components for the kinetic energy integrals. -* The kinetic energy components are linear combinations of overlap -* components. -* - ipAOff = ipA - Do 200 iBeta = 1, nBeta - call dcopy_(nAlpha,Alpha,1,Array(ipAOff),1) - ipAOff = ipAOff + nAlpha - 200 Continue -* - ipBOff = ipB - Do 210 iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ipBOff),nAlpha) - ipBOff = ipBOff + 1 - 210 Continue -* - Call Kntc(Array(ipTxyz),Array(ipRnxyz),la+1,lb+1, - & Array(ipA),Array(ipB),nZeta) -* -* Combine the cartesian components to the gradient of the kinetic -* energy integral and trace with the variational density matrix. -* - - Call CmbnT1_mck(Array(ipRnxyz),nZeta,la,lb,Zeta,rKappa, - & Array(ipSc),Array(ipTxyz), - & Array(ipA),Array(ipB),IfGrad) -* - Final(:,:,:,:)=Zero -* -* Symmetry adopt the gradient operator -* - Call SymAdO_mck(Array(ipSc),nZeta*nElem(la)*nElem(lb), - & Final,nrOp, - & nop,loper,IndGrd,iu,iv,ifgrad,idCar,trans) - -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(ZInv) - Call Unused_integer(iDCnt) - Call Unused_integer_array(iStabM) - Call Unused_integer(nStabM) - End If - End diff -Nru openmolcas-22.02/src/mckinley/knegrd_mck.F90 openmolcas-22.10/src/mckinley/knegrd_mck.F90 --- openmolcas-22.02/src/mckinley/knegrd_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/knegrd_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,128 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Roland Lindh * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine KnEGrd_mck( & +# define _CALLING_ +# include "grd_mck_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the gradient of the kinetic energy integrals * +! with the Gauss-Hermite quadrature * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! November '90 * +! Anders Bernhardsson,1995 * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Her_RW, only: HerR, HerW, iHerR, iHerW +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +#include "grd_mck_interface.fh" +integer(kind=iwp) :: iBeta, ipA, ipAOff, ipAxyz, ipB, ipBOff, ipBxyz, ipRnxyz, ipRxyz, ipSc, ipTxyz, nip +logical(kind=iwp) :: ABeq(3) + +#include "macros.fh" +unused_var(ZInv) +unused_var(lOper) +unused_var(iDCnt) +unused_var(iStabM) +unused_var(nStabM) + +ABeq(1) = A(1) == RB(1) +ABeq(2) = A(2) == RB(2) +ABeq(3) = A(3) == RB(3) + +nip = 1 +ipAxyz = nip +nip = nip+nZeta*3*nHer*(la+3) +ipBxyz = nip +nip = nip+nZeta*3*nHer*(lb+3) +ipRxyz = nip +nip = nip+nZeta*3*nHer*(nOrdOp+1) +ipRnxyz = nip +nip = nip+nZeta*3*(la+3)*(lb+3)*(nOrdOp+1) +ipTxyz = nip +nip = nip+nZeta*3*(la+2)*(lb+2) +ipA = nip +nip = nip+nZeta +ipB = nip +nip = nip+nZeta +ipSc = nip +nip = nip+nTri_Elem1(la)*nTri_Elem1(lb)*nZeta +if (nip-1 > nArr) then + write(u6,*) 'KneGrd_Mck: nip-1 > nArr' + write(u6,*) 'nip,nArr=',nip,nArr + call Abend() +end if + +#ifdef _DEBUGPRINT_ +call RecPrt(' In KnEGrd_McK: A',' ',A,1,3) +call RecPrt(' In KnEGrd_McK: B',' ',B,1,3) +call RecPrt(' In KnEGrd_McK: Ccoor',' ',Ccoor,1,3) +call RecPrt(' In KnEGrd_McK: P',' ',P,nZeta,3) +write(u6,*) ' In KnEGrd_McK: la,lb=',la,lb +#endif + +! Compute the cartesian values of the basis functions angular part + +call CrtCmp(Zeta,P,nZeta,A,Array(ipAxyz),la+2,HerR(iHerR(nHer)),nHer,ABeq) +call CrtCmp(Zeta,P,nZeta,RB,Array(ipBxyz),lb+2,HerR(iHerR(nHer)),nHer,ABeq) + +! Compute the contribution from the multipole moment operator + +ABeq(1) = .false. +ABeq(2) = .false. +ABeq(3) = .false. +call CrtCmp(Zeta,P,nZeta,Ccoor,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) + +! Compute the cartesian components for the multipole moment +! integrals. The integrals are factorized into components. + +call Assmbl(Array(ipRnxyz),Array(ipAxyz),la+2,Array(ipRxyz),nOrdOp,Array(ipBxyz),lb+2,nZeta,HerW(iHerW(nHer)),nHer) + +! Compute the cartesian components for the kinetic energy integrals. +! The kinetic energy components are linear combinations of overlap components. + +ipAOff = ipA +do iBeta=1,nBeta + Array(ipAOff:ipAOff+nAlpha-1) = Alpha + ipAOff = ipAOff+nAlpha +end do + +ipBOff = ipB +do iBeta=1,nBeta + Array(ipBOff:ipBOff+nAlpha-1) = Beta(iBeta) + ipBOff = ipBOff+nAlpha +end do + +call Kntc(Array(ipTxyz),Array(ipRnxyz),la+1,lb+1,Array(ipA),Array(ipB),nZeta) + +! Combine the cartesian components to the gradient of the kinetic +! energy integral and trace with the variational density matrix. + +call CmbnT1_mck(Array(ipRnxyz),nZeta,la,lb,Zeta,rKappa,Array(ipSc),Array(ipTxyz),Array(ipA),Array(ipB),IfGrad) + +rFinal(:,:,:,:) = Zero + +! Symmetry adapt the gradient operator + +call SymAdO_mck(Array(ipSc),nZeta*nTri_Elem1(la)*nTri_Elem1(lb),rFinal,nrOp,nop,IndGrd,iu,iv,ifgrad,idCar,trans) + +return + +end subroutine KnEGrd_mck diff -Nru openmolcas-22.02/src/mckinley/knehss.f openmolcas-22.10/src/mckinley/knehss.f --- openmolcas-22.02/src/mckinley/knehss.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/knehss.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,127 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine Knehss( -#define _CALLING_ -#include "hss_interface.fh" - & ) -************************************************************************ -* * -* Object: to compute the gradients of the overlap matrix * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* November '90 * -* Author: Anders Bernhardsson, 1995 * -************************************************************************ - use Her_RW - use Center_Info - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - -#include "hss_interface.fh" - -* Local variables - Logical ABeq(3) -* - ABeq(1) = A(1).eq.RB(1) - ABeq(2) = A(2).eq.RB(2) - ABeq(3) = A(3).eq.RB(3) -* - nip = 1 - ipAxyz = nip - nip = nip + nZeta*3*nHer*(la+3) - ipBxyz = nip - nip = nip + nZeta*3*nHer*(lb+3) - ipRxyz = nip - nip = nip + nZeta*3*nHer*(nOrdOp+1) -* ipTxyz = nip -* nip = nip + nZeta*3*(la+3)*(lb+3)*(nOrdOp+1) - ipRnxyz = nip - nip = nip + nZeta*3*(la+3)*(lb+3)*(nOrdOp+1) - ipAlph = nip - nip = nip + nZeta - ipBeta = nip - nip = nip + nZeta - If (nip-1.gt.nArr) Then - Write (6,*) 'KneHss: nip-1.gt.nArr' - Write (6,*) 'nip,nArr=',nip,nArr - Call Abend() - End If -* -#ifdef _DEBUGPRINT_ - Write (6,*) ' IfHss=',IfHss - Write (6,*) ' IndHss=',IndHss - Call RecPrt(' In KneHss: A',' ',A,1,3) - Call RecPrt(' In KneHss: RB',' ',RB,1,3) - Call RecPrt(' In KneHss: Ccoor',' ',Ccoor,1,3) - Call RecPrt(' In KneHss: P',' ',P,nZeta,3) -#endif -* -* Compute the cartesian values of the basis functions angular part -* - Call CrtCmp(Zeta,P,nZeta,A,Array(ipAxyz), - & la+2,HerR(iHerR(nHer)),nHer,ABeq) - Call CrtCmp(Zeta,P,nZeta,RB,Array(ipBxyz), - & lb+2,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the contribution from the multipole moment operator -* - ABeq(1) = .False. - ABeq(2) = .False. - ABeq(3) = .False. - Call CrtCmp(Zeta,P,nZeta,Ccoor,Array(ipRxyz), - & nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the cartesian components for the multipole moment -* integrals. The integrals are factorized into components. -* - Call Assmbl(Array(ipRnxyz), - & Array(ipAxyz),la+2, - & Array(ipRxyz),nOrdOp, - & Array(ipBxyz),lb+2, - & nZeta,HerW(iHerW(nHer)),nHer) -* -* Call Kntc(Array(ipTxyz),Array(ipRnxyz),la+2,lb, -* & Array(ipA),Array(ipB),nZeta) - -* -* Combine the cartesian components to the gradient of the one -* electron integral and contract with the Fock matrix. -* - ip = ipAlph - Do 20 iBeta = 1, nBeta - call dcopy_(nAlpha,Alpha,1,Array(ip),1) - ip = ip + nAlpha - 20 Continue - ip = ipBeta - Do 21 iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ip),nAlpha) - ip = ip + 1 - 21 Continue -* - Call CmbnT2(Array(ipRnxyz),nZeta,la,lb,Zeta, - & rKappa,Final, - & Array(ipAlph),Array(ipBeta),Hess,nHess,DAO, - & IfHss,IndHss,indgrd,dc(mdc)%nStab,dc(ndc)%nStab,nOp) - -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(ZInv) - Call Unused_integer_array(lOper) - Call Unused_logical_array(ifgrd) - Call Unused_integer_array(iStabM) - Call Unused_integer(nStabM) - End If - End diff -Nru openmolcas-22.02/src/mckinley/knehss.F90 openmolcas-22.10/src/mckinley/knehss.F90 --- openmolcas-22.02/src/mckinley/knehss.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/knehss.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,117 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Roland Lindh * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine Knehss( & +# define _CALLING_ +# include "hss_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the gradients of the overlap matrix * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! November '90 * +! Author: Anders Bernhardsson, 1995 * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Her_RW, only: HerR, HerW, iHerR, iHerW +use Center_Info, only: dc +use Definitions, only: wp, iwp, u6 + +implicit none +#include "hss_interface.fh" +integer(kind=iwp) :: iBeta, ip, ipAlph, ipAxyz, ipBeta, ipBxyz, ipRnxyz, ipRxyz, nip +logical(kind=iwp) :: ABeq(3) + +#include "macros.fh" +unused_var(ZInv) +unused_var(ifgrd) +unused_var(lOper) +unused_var(iStabM) +unused_var(nStabM) + +ABeq(1) = A(1) == RB(1) +ABeq(2) = A(2) == RB(2) +ABeq(3) = A(3) == RB(3) + +nip = 1 +ipAxyz = nip +nip = nip+nZeta*3*nHer*(la+3) +ipBxyz = nip +nip = nip+nZeta*3*nHer*(lb+3) +ipRxyz = nip +nip = nip+nZeta*3*nHer*(nOrdOp+1) +!ipTxyz = nip +!nip = nip+nZeta*3*(la+3)*(lb+3)*(nOrdOp+1) +ipRnxyz = nip +nip = nip+nZeta*3*(la+3)*(lb+3)*(nOrdOp+1) +ipAlph = nip +nip = nip+nZeta +ipBeta = nip +nip = nip+nZeta +if (nip-1 > nArr) then + write(u6,*) 'KneHss: nip-1 > nArr' + write(u6,*) 'nip,nArr=',nip,nArr + call Abend() +end if + +#ifdef _DEBUGPRINT_ +write(u6,*) ' IfHss=',IfHss +write(u6,*) ' IndHss=',IndHss +call RecPrt(' In KneHss: A',' ',A,1,3) +call RecPrt(' In KneHss: RB',' ',RB,1,3) +call RecPrt(' In KneHss: Ccoor',' ',Ccoor,1,3) +call RecPrt(' In KneHss: P',' ',P,nZeta,3) +#endif + +! Compute the cartesian values of the basis functions angular part + +call CrtCmp(Zeta,P,nZeta,A,Array(ipAxyz),la+2,HerR(iHerR(nHer)),nHer,ABeq) +call CrtCmp(Zeta,P,nZeta,RB,Array(ipBxyz),lb+2,HerR(iHerR(nHer)),nHer,ABeq) + +! Compute the contribution from the multipole moment operator + +ABeq(1) = .false. +ABeq(2) = .false. +ABeq(3) = .false. +call CrtCmp(Zeta,P,nZeta,Ccoor,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) + +! Compute the cartesian components for the multipole moment +! integrals. The integrals are factorized into components. + +call Assmbl(Array(ipRnxyz),Array(ipAxyz),la+2,Array(ipRxyz),nOrdOp,Array(ipBxyz),lb+2,nZeta,HerW(iHerW(nHer)),nHer) + +!call Kntc(Array(ipTxyz),Array(ipRnxyz),la+2,lb,Array(ipA),Array(ipB),nZeta) + +! Combine the cartesian components to the gradient of the one +! electron integral and contract with the Fock matrix. + +ip = ipAlph +do iBeta=1,nBeta + Array(ip:ip+nAlpha-1) = Alpha + ip = ip+nAlpha +end do +ip = ipBeta +do iBeta=1,nBeta + Array(ip:ip+nAlpha-1) = Beta(iBeta) + ip = ip+nAlpha +end do + +call CmbnT2(Array(ipRnxyz),nZeta,la,lb,Zeta,rKappa,rFinal,Array(ipAlph),Array(ipBeta),Hess,nHess,DAO,IfHss,IndHss,indgrd, & + dc(mdc)%nStab,dc(ndc)%nStab,nOp) + +return + +end subroutine Knehss diff -Nru openmolcas-22.02/src/mckinley/knemem_mck.f openmolcas-22.10/src/mckinley/knemem_mck.f --- openmolcas-22.02/src/mckinley/knemem_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/knemem_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Knemem_mck(nHer,MmKnEG,la,lb,lr) -* - nElem(i) = (i+1)*(i+2)/2 - nHer=((la+1)+(lb+1)+2+1)/2 - MmKnEG = 3*nHer*(la+3) + - & 3*nHer*(lb+3) + - & 3*nHer + - & 3*(la+3)*(lb+3) + - & 3*(la+2)*(lb+2) + 1 + 1 + - & nElem(la)*nElem(lb)*3 -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(lr) - End diff -Nru openmolcas-22.02/src/mckinley/knemem_mck.F90 openmolcas-22.10/src/mckinley/knemem_mck.F90 --- openmolcas-22.02/src/mckinley/knemem_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/knemem_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,31 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Knemem_mck( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" + +#include "macros.fh" +unused_var(lr) + +nHer = ((la+1)+(lb+1)+2+1)/2 +Mem = 3*nHer*(la+3)+3*nHer*(lb+3)+3*nHer+3*(la+3)*(lb+3)+3*(la+2)*(lb+2)+1+1+nTri_Elem1(la)*nTri_Elem1(lb)*3 + +return + +end subroutine Knemem_mck diff -Nru openmolcas-22.02/src/mckinley/knemmh.f openmolcas-22.10/src/mckinley/knemmh.f --- openmolcas-22.02/src/mckinley/knemmh.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/knemmh.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,24 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine KnEMmH(nHer,MmKnEH,la,lb,lr) -* - nHer=(la+1+lb+1+6)/2 - MmKnEH = 3*nHer*(la+3) + - & 3*nHer*(lb+3) + - & 3*nHer + - & 3*(la+3)*(lb+3) + - & 3*(la+3)*(la+3) + - & 3*(la+3)*(lb+3) + 1 + 1 -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(lr) - End diff -Nru openmolcas-22.02/src/mckinley/knemmh.F90 openmolcas-22.10/src/mckinley/knemmh.F90 --- openmolcas-22.02/src/mckinley/knemmh.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/knemmh.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,30 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine KnEMmH( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" + +#include "macros.fh" +unused_var(lr) + +nHer = (la+1+lb+1+6)/2 +Mem = 3*nHer*(la+3)+3*nHer*(lb+3)+3*nHer+3*(la+3)*(lb+3)+3*(la+3)*(la+3)+3*(la+3)*(lb+3)+1+1 + +return + +end subroutine KnEMmH diff -Nru openmolcas-22.02/src/mckinley/ltocore.f openmolcas-22.10/src/mckinley/ltocore.f --- openmolcas-22.02/src/mckinley/ltocore.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/ltocore.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,87 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine LToCore(F,nalpha,ishll,la,iAng,nvecac) -******************************************************************************* -* -* Transformation kernel to atomic orbials in normailized spherical harmonics -* -******************************************************************************* -* @parameter F The cartesian components of -* @parameter nAlpha Number of exponents -* @parameter ishll Shell number for ECP -* @parameter la angular momenta LS -* @parameter iAng angular momenta core -* @parameter Number of derivatives -* - use Real_Spherical - use Basis_Info - Implicit Real*8 (a-h,o-z) -#include "real.fh" -#include "stdalloc.fh" - Real*8 F(*) - Real*8, Allocatable:: Tmp1(:), Tmp2(:) - - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - nac=nelem(la)*nelem(iang) - nExpi=Shells(iShll)%nExp - nBasisi=Shells(iShll)%nBasis - Call mma_allocate(Tmp1,nExpi*nac*nVecAC*nalpha,Label='Tmp1') - Call mma_allocate(Tmp2,nExpi*nac*nVecAC*nalpha,Label='Tmp2') -*--------------From the lefthandside overlap, form iKaC from ikac by -* 1) i,kac -> k,aci -* - n = nExpi*nac*nVecAC - Call DgeTMo(F,nAlpha, - & nAlpha, n, - & Tmp1,n) -* -*--------------2) aciK = k,aci * k,K (Contract over core orbital) -* - Call DGEMM_('T','N', - & nac*nVecAC*nAlpha,nBasisi,nExpi, - & One,Tmp1,nExpi, - & Shells(iShll)%pCff,nExpi, - & Zero,Tmp2,nac*nVecAC*nAlpha) -* -*--------------3) Mult by shiftoperators aci,K -> Bk(K) * aci,K -* - Do iBk = 1, nBasisi - Call DYaX(nac*nVecAC*nAlpha,Shells(iShll)%Bk(iBk), - & Tmp2((iBk-1)*nac*nVecAC*nAlpha+1),1, - & Tmp1((iBk-1)*nac*nVecAC*nAlpha+1),1) - End Do -* -*--------------4) a,ciK -> ciKa -* - Call DgeTMo(Tmp1,nElem(la),nElem(la), - & nElem(iAng)*nVecAC*nAlpha*nBasisi, - & Tmp2, - & nElem(iAng)*nVecAC*nAlpha*nBasisi) -* -*--------------5) iKa,C = c,iKa * c,C -* - Call DGEMM_('T','N', - & nVecAC*nAlpha*nBasisi*nElem(la), - & (2*iAng+1),nElem(iAng), - & One,Tmp2,nElem(iAng), - & RSph(ipSph(iAng)),nElem(iAng), - & Zero,Tmp1,nVecAC*nAlpha*nBasisi*nElem(la)) -* - Call DgeTMo(Tmp1,nVecAC,nVecAC, - & nAlpha*nBasisi*nElem(la)*(2*iAng+1), - & F, - & nAlpha*nBasisi*nElem(la)*(2*iAng+1)) - - Call mma_deallocate(Tmp2) - Call mma_deallocate(Tmp1) - - Return - End diff -Nru openmolcas-22.02/src/mckinley/ltocore.F90 openmolcas-22.10/src/mckinley/ltocore.F90 --- openmolcas-22.02/src/mckinley/ltocore.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/ltocore.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,76 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine LToCore(F,nAlpha,iShll,la,iAng,nvecac) +!****************************************************************************** +! +! Transformation kernel to atomic orbials in normalized spherical harmonics +! +!****************************************************************************** +! @parameter F The cartesian components of +! @parameter nAlpha Number of exponents +! @parameter ishll Shell number for ECP +! @parameter la angular momenta LS +! @parameter iAng angular momenta core +! @parameter nVecAC Number of derivatives + +use Index_Functions, only: nTri_Elem1 +use Real_Spherical, only: ipSph, RSph +use Basis_Info, only: Shells +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(inout) :: F(*) +integer(kind=iwp), intent(in) :: nAlpha, iShll, la, iAng, nVecAC +integer(kind=iwp) :: iBk, n, nac, nBasisi, nExpi +real(kind=wp), allocatable :: Tmp1(:), Tmp2(:) + +nac = nTri_Elem1(la)*nTri_Elem1(iang) +nExpi = Shells(iShll)%nExp +nBasisi = Shells(iShll)%nBasis +call mma_allocate(Tmp1,nExpi*nac*nVecAC*nalpha,Label='Tmp1') +call mma_allocate(Tmp2,nExpi*nac*nVecAC*nalpha,Label='Tmp2') +! From the lefthandside overlap, form iKaC from ikac by +! 1) i,kac -> k,aci + +n = nExpi*nac*nVecAC +call DgeTMo(F,nAlpha,nAlpha,n,Tmp1,n) + +! 2) aciK = k,aci * k,K (Contract over core orbital) + +n = nac*nVecAC*nAlpha +call DGEMM_('T','N',n,nBasisi,nExpi,One,Tmp1,nExpi,Shells(iShll)%pCff,nExpi,Zero,Tmp2,n) + +! 3) Mult by shiftoperators aci,K -> Bk(K) * aci,K + +do iBk=1,nBasisi + Tmp1((iBk-1)*n+1:iBk*n) = Shells(iShll)%Bk(iBk)*Tmp2((iBk-1)*n+1:iBk*n) +end do + +! 4) a,ciK -> ciKa + +call DgeTMo(Tmp1,nTri_Elem1(la),nTri_Elem1(la),nTri_Elem1(iAng)*nVecAC*nAlpha*nBasisi,Tmp2,nTri_Elem1(iAng)*nVecAC*nAlpha*nBasisi) + +! 5) iKa,C = c,iKa * c,C + +call DGEMM_('T','N',nVecAC*nAlpha*nBasisi*nTri_Elem1(la),(2*iAng+1),nTri_Elem1(iAng),One,Tmp2,nTri_Elem1(iAng),RSph(ipSph(iAng)), & + nTri_Elem1(iAng),Zero,Tmp1,nVecAC*nAlpha*nBasisi*nTri_Elem1(la)) + +call DgeTMo(Tmp1,nVecAC,nVecAC,nAlpha*nBasisi*nTri_Elem1(la)*(2*iAng+1),F,nAlpha*nBasisi*nTri_Elem1(la)*(2*iAng+1)) + +call mma_deallocate(Tmp2) +call mma_deallocate(Tmp1) + +return + +end subroutine LToCore diff -Nru openmolcas-22.02/src/mckinley/ltosph.f openmolcas-22.10/src/mckinley/ltosph.f --- openmolcas-22.02/src/mckinley/ltosph.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/ltosph.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,75 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine LToSph(F,nalpha,ishll,la,iAng,nvecac) -******************************************************************************* -* -* Transform from Cartesian components to Sperical harmonics -* -* Observe that as opposed to the projection operator that this -* contraction is done in the primitive basis. -* -******************************************************************************* -* @parameter F The cartesian components of (in) -* The spherical components of (out) - -* @parameter nAlpha Number of exponents -* @parameter ishll Shell number for ECP -* @parameter la angular momenta LS -* @parameter iAng angular momenta core -* @parameter Number of derivatives -******************************************************************************* -* - use Basis_Info - use Real_Spherical - Implicit Real*8 (a-h,o-z) -#include "real.fh" -#include "stdalloc.fh" - Real*8 F(*) - Real*8, Allocatable:: Tmp1(:), Tmp2(:) - - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -******************************************************************************* -* - nExpi=Shells(iShll)%nExp - nac=nelem(la)*nelem(iang) - Call mma_allocate(Tmp1,nExpi*nac*nVecAC*nalpha,Label='Tmp1') - Call mma_allocate(Tmp2,nExpi*nac*nVecAC*nalpha,Label='Tmp2') - - - Call DgeTMo(F,nAlpha*nExpi*nElem(la), - & nAlpha*nExpi*nElem(la), - & nElem(iAng)*nVecAC,Tmp1, - & nElem(iAng)*nVecAC) -* -*--------------2) xika,C = c,xika * c,C -* - Call DGEMM_('T','N', - & nVecAC*nAlpha*nExpi*nElem(la), - & (2*iAng+1),nElem(iAng), - & One,Tmp1,nElem(iAng), - & RSph(ipSph(iAng)),nElem(iAng), - & Zero,Tmp2, - & nVecAC*nAlpha*nExpi*nElem(la)) -* -*--------------3) x,ikaC -> ikaC,x -* - Call DGetMo(Tmp2,nVecAC,nVecAC, - & nAlpha*nExpi*nElem(la)*(2*iAng+1), - & Tmp1, - & nAlpha*nExpi*nElem(la)*(2*iAng+1)) - call dcopy_(nVecAC* - & nAlpha*nExpi*nElem(la)*(2*iAng+1), - & Tmp1,1,F,1) -* - Call mma_deallocate(Tmp2) - Call mma_deallocate(Tmp1) - Return - End diff -Nru openmolcas-22.02/src/mckinley/ltosph.F90 openmolcas-22.10/src/mckinley/ltosph.F90 --- openmolcas-22.02/src/mckinley/ltosph.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/ltosph.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,66 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine LToSph(F,nAlpha,iShll,la,iAng,nVecAC) +!*********************************************************************** +! +! Transform from Cartesian components to Sperical harmonics +! +! Observe that as opposed to the projection operator that this +! contraction is done in the primitive basis. +! +!*********************************************************************** +! @parameter F The cartesian components of (in) +! The spherical components of (out) +! @parameter nAlpha Number of exponents +! @parameter iShll Shell number for ECP +! @parameter la angular momenta LS +! @parameter iAng angular momenta core +! @parameter nVecAC Number of derivatives +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Real_Spherical, only: ipSph, RSph +use Basis_Info, only: Shells +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(inout) :: F(*) +integer(kind=iwp), intent(in) :: nAlpha, iShll, la, iAng, nVecAC +integer(kind=iwp) :: nac, nExpi +real(kind=wp), allocatable :: Tmp1(:), Tmp2(:) + +!*********************************************************************** + +nExpi = Shells(iShll)%nExp +nac = nTri_Elem1(la)*nTri_Elem1(iang) +call mma_allocate(Tmp1,nExpi*nac*nVecAC*nalpha,Label='Tmp1') +call mma_allocate(Tmp2,nExpi*nac*nVecAC*nalpha,Label='Tmp2') + +call DgeTMo(F,nAlpha*nExpi*nTri_Elem1(la),nAlpha*nExpi*nTri_Elem1(la),nTri_Elem1(iAng)*nVecAC,Tmp1,nTri_Elem1(iAng)*nVecAC) + +! 2) xika,C = c,xika * c,C + +call DGEMM_('T','N',nVecAC*nAlpha*nExpi*nTri_Elem1(la),(2*iAng+1),nTri_Elem1(iAng),One,Tmp1,nTri_Elem1(iAng),RSph(ipSph(iAng)), & + nTri_Elem1(iAng),Zero,Tmp2,nVecAC*nAlpha*nExpi*nTri_Elem1(la)) + +! 3) x,ikaC -> ikaC,x + +call DGetMo(Tmp2,nVecAC,nVecAC,nAlpha*nExpi*nTri_Elem1(la)*(2*iAng+1),F,nAlpha*nExpi*nTri_Elem1(la)*(2*iAng+1)) + +call mma_deallocate(Tmp2) +call mma_deallocate(Tmp1) + +return + +end subroutine LToSph diff -Nru openmolcas-22.02/src/mckinley/lu2lu.F90 openmolcas-22.10/src/mckinley/lu2lu.F90 --- openmolcas-22.02/src/mckinley/lu2lu.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/lu2lu.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,45 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Lu2Lu(Filename,LuInput) + +use Definitions, only: iwp, u6 + +implicit none +character(len=*), intent(in) :: FileName +integer(kind=iwp), intent(in) :: LuInput +#include "warnings.h" +integer(kind=iwp) :: istatus, LuSpool2 +character(len=180) :: Line +logical(kind=iwp) :: Exists +integer(kind=iwp), external :: IsFreeUnit + +call f_inquire(Filename,Exists) +if (.not. Exists) then + write(u6,*) 'SuperMac: Missing ',Filename + call Finish(_RC_INTERNAL_ERROR_) +end if + +LuSpool2 = 77 +LuSpool2 = IsFreeUnit(LuSpool2) +call Molcas_Open(LuSpool2,Filename) + +do + read(LuSpool2,'(A)',iostat=istatus) Line + if (istatus < 0) exit + write(LuInput,'(A)') Line +end do + +close(LuSpool2) + +return + +end subroutine Lu2Lu diff -Nru openmolcas-22.02/src/mckinley/m1grd_mck.f openmolcas-22.10/src/mckinley/m1grd_mck.f --- openmolcas-22.02/src/mckinley/m1grd_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/m1grd_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,207 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -* 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine m1Grd_mck( -#define _CALLING_ -#include "grd_mck_interface.fh" - & ) -************************************************************************ -* * -* Object: to compute the gradient of the nuclear attraction integrals. * -* Something is wrong here * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -* October 1991 * -* Anders Bernhardsson 1995 * -************************************************************************ - use Basis_Info - use Center_Info - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) - External TNAI1, Fake, Cff2D -#include "Molcas.fh" -#include "real.fh" -#include "disp.fh" -#include "disp2.fh" - -#include "grd_mck_interface.fh" - -* Local variables - Integer iDCRT(0:7),inddum(144*8) - Real*8 C(3), TC(3) - Logical DiffCnt, EQ, Tr(4), ifdum(144) - Real*8 Coori(3,4), CoorAC(3,2) - Integer iAng(4), JndGrd(3,4,0:7), mOp(4), iuvwx(4), - & kndgrd(3,4,0:7) - Logical JfGrd(3,4), kfgrd(3,4), jfg(4) - Dimension Dum(1) -* -c If (iPrint.ge.99) Then -c Write (*,*) ' In NAGrd: nArr=',nArr -c End If - call icopy(144*nirrep,[0],0,inddum,1) - call lcopy(144,[.false.],0,ifdum,1) -* - nRys=nHer -* - nip = 1 - ipA = nip - nip = nip + nAlpha*nBeta - ipB = nip - nip = nip + nAlpha*nBeta - If (nip-1.gt.nArr) - & Write (6,*) ' nip-1.gt.nArr' -* - iIrrep = 0 - iAng(1) = la - iAng(2) = lb - iAng(3) = 0 - iAng(4) = 0 -* Dummies -* - call dcopy_(3,A,1,Coori(1,1),1) - call dcopy_(3,RB,1,Coori(1,2),1) - If (la.ge.lb) Then - call dcopy_(3,A,1,CoorAC(1,1),1) - Else - call dcopy_(3,RB,1,CoorAC(1,1),1) - End If - iuvwx(1) = iu - iuvwx(2) = iv - mOp(1) = nOp(1) - mOp(2) = nOp(2) -* - ipAOff = ipA - Do 200 iBeta = 1, nBeta - call dcopy_(nAlpha,Alpha,1,Array(ipAOff),1) - ipAOff = ipAOff + nAlpha - 200 Continue -* - ipBOff = ipB - Do 210 iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ipBOff),nAlpha) - ipBOff = ipBOff + 1 - 210 Continue -* -*-----Loop over nuclear centers -* - kdc = 0 - Do 100 kCnttp = 1, nCnttp - If (.Not.dbsc(kCnttp)%ECP) Go To 111 - If (dbsc(kCnttp)%nM1.eq.0) Go To 111 - - Do 101 kCnt = 1, dbsc(kCnttp)%nCntr - C(1:3)=dbsc(kCnttp)%Coor(1:3,kCnt) - DiffCnt=(IfGrad(iDCar,1).or.IfGrad(iDCar,2)) - If ((.not.DiffCnt).and.((kdc+kCnt).ne.iDCnt)) Goto 101 -* - Call DCR(LmbdT,iStabM,nStabM, - & dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) -* Fact = -dbsc(kCnttp)%Charge*DBLE(nStabM*nIrrep) / -* & DBLE(LmbdT*dc(kdc+kCnt)%nStab) - Fact = -dbsc(kCnttp)%Charge*DBLE(nStabM) / - & DBLE(LmbdT) -c If (iPrint.ge.99) Then -c Write (*,*) ' Charge=',dbsc(kCnttp)%Charge -c write(*,*) 'NZeta=',nzeta -c Write(*,*) 'NrOp=',nrop -c Write (*,*) ' Fact=',Fact -c End If - iuvwx(3) = dc(kdc+kCnt)%nStab - iuvwx(4) = dc(kdc+kCnt)%nStab - Call LCopy(12,[.false.],0,JFgrd,1) - Call ICopy(12*nIrrep,[0],0,jndGrd,1) - Do iCnt = 1, 2 - JfGrd(iDCar,iCnt) = IfGrad(iDCar,iCnt) - End Do - Do ICnt=1,2 - If (IfGrad(idcar,iCnt)) Then - Do iIrrep=0,nIrrep-1 - jndGrd(iDCar,iCnt,iIrrep)=IndGrd(iIrrep) - End Do - End IF - End Do -* - Tr(1)=.false. - Tr(2)=.false. - Tr(3)=.false. - Tr(4)=.false. - If ((kdc+kCnt).eq.iDCnt) Then - Tr(3)=.true. - JfGrd(iDCar,1) = .true. - JfGrd(iDCar,2) = .true. - Do iIrrep=0,nIrrep-1 - jndGrd(iDCar,3,iIrrep) = - IndGrd(iIrrep) - End Do - End If -* - Do 102 lDCRT = 0, nDCRT-1 - Call lCopy(12,JfGrd,1,kfGrd,1) - Call iCopy(12*nIrrep,JndGrd,1,kndgrd,1) - mOp(3) = NrOpr(iDCRT(lDCRT)) - mOp(4) = mOp(3) - Call OA(iDCRT(lDCRT),C,TC) - call dcopy_(3,TC,1,CoorAC(1,2),1) - call dcopy_(3,TC,1,Coori(1,3),1) - call dcopy_(3,TC,1,Coori(1,4),1) - If (Eq(A,RB).and.EQ(A,TC)) goto 102 - If (EQ(A,TC)) Then - kfGrd(iDCar,1) = .false. - Do iIrrep=0,nIrrep-1 - kndGrd(iDCar,1,iirrep)=0 - End Do - End If - If (EQ(RB,TC)) Then - kfGrd(iDCar,2) = .false. - Do iIrrep=0,nIrrep-1 - kndgrd(iDCar,2,iIrrep)=0 - End Do - End If -* - If (kfGrd(idcar,1)) Then - JFG(1)=.true. - Else - JFG(1)=.false. - End If - If (kfGrd(idcar,2)) Then - JFG(2)=.true. - Else - JFG(2)=.false. - End If - JFG(3)=.false. - JFG(4)=.false. - - - call M1Kernel(Final,Dum,0,Dum,0, - & iAng,nRys,nZeta, - & Array(ipA),Array(ipB),Zeta,ZInv, - & rKappa,P,TC,Coori,Coorac, - & Array(nip),nArr-nip+1, - & kfgrd,kndgrd,ifdum,inddum, - & jfg,tr,mop,iuvwx, - & kCnttp,fact,loper,idcar) - - 102 Continue - 101 Continue - 111 kdc = kdc + dbsc(kCnttp)%nCntr - 100 Continue -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Ccoor) - Call Unused_integer(nOrdOp) - Call Unused_logical_array(Trans) - End If - End diff -Nru openmolcas-22.02/src/mckinley/m1grd_mck.F90 openmolcas-22.10/src/mckinley/m1grd_mck.F90 --- openmolcas-22.02/src/mckinley/m1grd_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/m1grd_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,178 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine m1Grd_mck( & +# define _CALLING_ +# include "grd_mck_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the gradient of the nuclear attraction integrals. * +! Something is wrong here * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +! October 1991 * +! Anders Bernhardsson 1995 * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Basis_Info, only: dbsc, nCnttp +use Center_Info, only: dc +use Symmetry_Info, only: nIrrep +use Definitions, only: wp, iwp, u6 + +implicit none +#include "grd_mck_interface.fh" +integer(kind=iwp) :: iAng(4), iBeta, iCnt, iDCRT(0:7), inddum(3,4,3,4,8), ipA, ipAOff, ipB, ipBOff, iuvwx(4), JndGrd(3,4,0:7), & + mOp(4), kCnt, kCnttp, kdc, kndgrd(3,4,0:7), lDCRT, LmbdT, nDCRT, nip, nRys +logical(kind=iwp) :: DiffCnt, ifdum(3,4,3,4), jfg(4), JfGrd(3,4), kfgrd(3,4), Tr(4) +real(kind=wp) :: C(3), CoorAC(3,2), Coori(3,4), Dum(1), Fact, TC(3) +integer(kind=iwp), external :: NrOpr +logical(kind=iwp), external :: EQ + +#include "macros.fh" +unused_var(ZInv) +unused_var(Ccoor) +unused_var(nOrdOp) +unused_var(Trans) + +!if (iPrint >= 99) then +! write(u6,*) ' In NAGrd: nArr=',nArr +!end if +inddum(:,:,:,:,:) = 0 +ifdum(:,:,:,:) = .false. + +nRys = nHer + +nip = 1 +ipA = nip +nip = nip+nAlpha*nBeta +ipB = nip +nip = nip+nAlpha*nBeta +if (nip-1 > nArr) write(u6,*) ' nip-1 > nArr' + +iAng(1) = la +iAng(2) = lb +iAng(3) = 0 +iAng(4) = 0 +! Dummies + +Coori(:,1) = A +Coori(:,2) = RB +if (la >= lb) then + CoorAC(:,1) = A +else + CoorAC(:,1) = RB +end if +iuvwx(1) = iu +iuvwx(2) = iv +mOp(1) = nOp(1) +mOp(2) = nOp(2) + +ipAOff = ipA +do iBeta=1,nBeta + Array(ipAOff:ipAOff+nAlpha-1) = Alpha + ipAOff = ipAOff+nAlpha +end do + +ipBOff = ipB +do iBeta=1,nBeta + Array(ipBOff:ipBOff+nAlpha-1) = Beta(iBeta) + ipBOff = ipBOff+nAlpha +end do + +! Loop over nuclear centers + +kdc = 0 +do kCnttp=1,nCnttp + if (kCnttp > 1) kdc = kdc+dbsc(kCnttp-1)%nCntr + if (.not. dbsc(kCnttp)%ECP) cycle + if (dbsc(kCnttp)%nM1 == 0) cycle + + do kCnt=1,dbsc(kCnttp)%nCntr + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + DiffCnt = (IfGrad(iDCar,1) .or. IfGrad(iDCar,2)) + if ((.not. DiffCnt) .and. (kdc+kCnt /= iDCnt)) cycle + + call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) + !Fact = -dbsc(kCnttp)%Charge*real(nStabM*nIrrep,kind=wp)/real(LmbdT*dc(kdc+kCnt)%nStab,kind=wp) + Fact = -dbsc(kCnttp)%Charge*real(nStabM,kind=wp)/real(LmbdT,kind=wp) + !if (iPrint >= 99) then + ! write(u6,*) ' Charge=',dbsc(kCnttp)%Charge + ! write(u6,*) 'NZeta=',nzeta + ! write(u6,*) 'NrOp=',nrop + ! write(u6,*) ' Fact=',Fact + !end if + iuvwx(3) = dc(kdc+kCnt)%nStab + iuvwx(4) = dc(kdc+kCnt)%nStab + JfGrd(:,:) = .false. + JndGrd(:,:,0:nIrrep-1) = 0 + JfGrd(iDCar,1:2) = IfGrad(iDCar,1:2) + do ICnt=1,2 + if (IfGrad(iDCar,iCnt)) JndGrd(iDCar,iCnt,0:nIrrep-1) = IndGrd(0:nIrrep-1) + end do + + Tr(1) = .false. + Tr(2) = .false. + Tr(3) = .false. + Tr(4) = .false. + if ((kdc+kCnt) == iDCnt) then + Tr(3) = .true. + JfGrd(iDCar,1:2) = .true. + JndGrd(iDCar,3,0:nIrrep-1) = -IndGrd(0:nIrrep-1) + end if + + do lDCRT=0,nDCRT-1 + kfGrd(:,:) = JfGrd + kndgrd(:,:,0:nIrrep-1) = JndGrd(:,:,0:nIrrep-1) + mOp(3) = NrOpr(iDCRT(lDCRT)) + mOp(4) = mOp(3) + call OA(iDCRT(lDCRT),C,TC) + CoorAC(:,2) = TC + Coori(:,3) = TC + Coori(:,4) = TC + if (Eq(A,RB) .and. EQ(A,TC)) cycle + if (EQ(A,TC)) then + kfGrd(iDCar,1) = .false. + kndGrd(iDCar,1,0:nIrrep-1) = 0 + end if + if (EQ(RB,TC)) then + kfGrd(iDCar,2) = .false. + kndGrd(iDCar,2,0:nIrrep-1) = 0 + end if + + if (kfGrd(idcar,1)) then + JFG(1) = .true. + else + JFG(1) = .false. + end if + if (kfGrd(idcar,2)) then + JFG(2) = .true. + else + JFG(2) = .false. + end if + JFG(3) = .false. + JFG(4) = .false. + + call M1Kernel(rFinal,Dum,0,Dum,0,iAng,nRys,nZeta,Array(ipA),Array(ipB),Zeta,rKappa,P,TC,Coori,Coorac,Array(nip),nArr-nip+1, & + kfgrd,kndgrd,ifdum,inddum,jfg,tr,mop,iuvwx,kCnttp,fact,loper,idcar) + + end do + end do +end do + +return + +end subroutine m1Grd_mck diff -Nru openmolcas-22.02/src/mckinley/m1hss.f openmolcas-22.10/src/mckinley/m1hss.f --- openmolcas-22.02/src/mckinley/m1hss.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/m1hss.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,285 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Anders Bernhardsson * -* 1991, Roland Lindh * -************************************************************************ - SubRoutine M1Hss( -#define _CALLING_ -#include "hss_interface.fh" - & ) -************************************************************************ -* * -* Object: to compute the gradient of the nuclear attraction integrals. * -* * -* Author: Anders Bernhardsson & Roland Lindh, * -* Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -* October 1991 * -************************************************************************ - use Basis_Info - use Center_Info - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "real.fh" -#include "disp.fh" -#include "disp2.fh" - -#include "hss_interface.fh" - -* Local variables - Integer iDCRT(0:7) - Real*8 C(3), TC(3) - Logical EQ, IfG(0:3),Tr(0:3) - Real*8 Coora(3,4), Coori(3,4), CoorAC(3,2) - Integer iAnga(4), JndGrd(0:2,0:3,0:7), - & JndHss(0:3,0:2,0:3,0:2,0:7), - & mOp(4), iuvwx(4) - Logical JfHss(0:3,0:2,0:3,0:2),JfGrd(0:2,0:3) - Logical, External :: TF -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - IX(i1,i2)=i1*(i1-1)/2+i2 -* -c If (iPrint.ge.99) Then -c Write (6,*) ' In M1Hss: nArr=',nArr -c End If -* - nRys=nHer -* - nip = 1 - ipA = nip - nip = nip + nAlpha*nBeta - ipB = nip - nip = nip + nAlpha*nBeta - ipArr = nip - nArray = nArr - nip +1 -* - iIrrep = 0 - iAnga(1) = la - iAnga(2) = lb - iAnga(3) = 0 - iAnga(4) = 0 - call dcopy_(3,A,1,Coora(1,1),1) - call dcopy_(3,RB,1,Coora(1,2),1) - call dcopy_(3,A,1,Coori(1,1),1) - call dcopy_(3,RB,1,Coori(1,2),1) - If (la.ge.lb) Then - call dcopy_(3,A,1,CoorAC(1,1),1) - Else - call dcopy_(3,RB,1,CoorAC(1,1),1) - End If - iuvwx(1) = dc(mdc)%nStab - iuvwx(2) = dc(ndc)%nStab - mOp(1) = nOp(1) - mOp(2) = nOp(2) -* - ipAOff = ipA - Do 200 iBeta = 1, nBeta - call dcopy_(nAlpha,Alpha,1,Array(ipAOff),1) - ipAOff = ipAOff + nAlpha - 200 Continue -* - ipBOff = ipB - Do 210 iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ipBOff),nAlpha) - ipBOff = ipBOff + 1 - 210 Continue -* -* Modify the density matrix with the prefactor -* - nDAO = nElem(la) * nElem(lb) -* Do 300 iDAO = 1, nDAO -* Do 310 iZeta = 1, nZeta -* Fact = Two*rkappa(iZeta)*Pi*ZInv(iZeta) -* DAO(iZeta,iDAO) = Fact * DAO(iZeta,iDAO) -*310 Continue -*300 Continue -c If (iPrint.ge.99) Call RecPrt('DAO',' ',DAO,nZeta,nDAO) -* - - -* Here we go -* -*-----Loop over nuclear centers -* - kdc = 0 - Do 100 kCnttp = 1, nCnttp - If (dbsc(kCnttp)%Charge.eq.Zero) Go To 111 - Do 101 kCnt = 1, dbsc(kCnttp)%nCntr - C(1:3)=dbsc(kCnttp)%Coor(1:3,kCnt) - Call DCR(LmbdT,iStabM,nStabM, - & dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) - Do 102 lDCRT = 0, nDCRT-1 - Call ICopy(nSym*16*9,[0],0,JndHss,1) - Call iCopy(nSym*4*3,[0],0,JndGrd,1) - Call LCopy(144,[.False.],0,jfHss,1) - Call LCopy(4,[.False.],0,Tr,1) - Call LCopy(12,[.False.],0,jfGrd,1) - mOp(3) = NrOpr(iDCRT(lDCRT)) - mOp(4) = mOp(3) - Call OA(iDCRT(lDCRT),C,TC) - call dcopy_(3,TC,1,CoorAC(1,2),1) - call dcopy_(3,TC,1,Coora(1,3),1) - call dcopy_(3,TC,1,Coora(1,4),1) - call dcopy_(3,TC,1,Coori(1,3),1) - call dcopy_(3,TC,1,Coori(1,4),1) - If (EQ(A,TC).and.EQ(A,RB)) Goto 102 -* -* COPY CNTLR MATRIXES -* - Do iAtom = 0, 1 - Do iCar = 0, 2 - JfGrd(iCar,iAtom) = Ifgrd(iCar,iAtom) - Do iIrrep=0,nSym-1 - JndGrd(iCar,iAtom,iIrrep)= - & IndGrd(iCar,iAtom,iIrrep) - End Do - Do jAtom = 0, 1 - Do jCar = 0, 2 - JfHss(iAtom,iCar,jAtom,jCar) = - & IfHss(iAtom,iCar,jAtom,jCar) - Do iIrrep=0,nSym-1 - JndHss(iAtom,iCar,jAtom,jCar,iIrrep) = - & IndHss(iAtom,iCar,jAtom,jCar,iIrrep) - End Do - End Do - End Do - End Do - End Do - -* - Fact = -dbsc(kCnttp)%Charge*DBLE(nStabM) / - & DBLE(LmbdT) -* Call DYaX(nZeta*nDAO,Fact,DAO,1,Array(ipDAO),1) - iuvwx(3) = dc(kdc+kCnt)%nStab - iuvwx(4) = dc(kdc+kCnt)%nStab -* -*-----------Derivatives with respect to the operator is computed via the -* translational invariance. -* - nnIrrep=nSym - If (sIrrep) nnIrrep=1 - Do 230 iIrrep=0,nnIrrep-1 - nDisp = IndDsp(kdc+kCnt,iIrrep) - Do 220 iCar = 0, 2 - iComp = 2**iCar - If (TF(kdc+kCnt,iIrrep,iComp)) Then - nDisp = nDisp + 1 -* -*--------------------Reset flags for the basis set centers so that we -* will explicitly compute the derivatives with -* respect to those centers. Activate flag for the -* third center so that its derivative will be comp- -* uted by the translational invariance. -* - JndGrd(iCar,0,iIrrep) = Abs(JndGrd(iCar,0,iIrrep)) - JndGrd(iCar,1,iIrrep) = Abs(JndGrd(iCar,1,iIrrep)) - JndGrd(iCar,2,iIrrep) = -nDisp - JfGrd(iCar,0) = .True. - JfGrd(iCar,1) = .True. - JfGrd(iCar,2) = .False. - Else - JndGrd(iCar,2,iIrrep) = 0 - End If - 220 Continue - 230 Continue -* -* The third center is claculated by translation invarians -* This requires the 2nd derivatives on the other centers. -* - - Do iCar=0,2 - Do jAtom=0,2 - if (jAtom.eq.2) Then - iStop=iCar - Else - iStop=2 - End If - Do jCar=0,iStop - Do iIrrep=0,nSym-1 - If ((JndGrd(iCar,2,iIrrep).ne.0).and. - & (JndGrd(jCar,jAtom,iIrrep).ne.0)) Then - JndHss(2,iCar,jAtom,jCar,iIrrep)= - & -IX(Max(Abs(JndGrd(iCar,2,iIrrep)), - & Abs(JndGrd(jCar,jAtom,iIrrep))), - & Min(Abs(JndGrd(iCar,2,iIrrep)), - & Abs(JndGrd(jCar,jAtom,iIrrep)))) - - Tr(2)=.true. - If (jAtom.eq.2) Then - Maxi=Max(iCar,jCar) - Mini=Min(iCar,jCar) - jfHss(0,Maxi,0,Mini)=.true. - jfHss(1,Maxi,1,Mini)=.true. - jfHss(1,iCar,0,jCar)=.true. - jfHss(1,jCar,0,iCar)=.true. - Else - Maxi=Max(iCar,jCar) - Mini=Min(iCar,jCar) - jfHss(jAtom,Maxi,jAtom,Mini)=.true. - jfHss(1,iCar,0,jCar)=.true. - jfHss(1,jCar,0,iCar)=.true. - End If - End If - End Do - End Do - End Do - End Do -* - IfG(0)=.true. - IfG(1)=.true. - IfG(2)=.false. - IfG(3)=.false. - Do iCent=0,1 - If (EQ(Coori(1,iCent+1),Coori(1,3) ) ) Then - IfG(iCent)=.false. - Do iCar=0,2 - jfGrd(iCar,iCent)=.false. - Do kCar=0,2 - Do KCent=0,3 - jfHss(iCent,iCar,kCent,kCar)=.false. - jfHss(kCent,kCar,iCent,iCar)=.false. - Do iIrrep=0,nSym-1 - jndHss(iCent,iCar,kCent,kCar,iIrrep)=0 - jndHss(kCent,kCar,iCent,iCar,iIrrep)=0 - End Do - End Do - End Do - Do iIrrep=0,nSym-1 - jndGrd(iCar,iCent,iIrrep)=0 - End Do - End Do - End If - End Do - Call lCopy(12,[.false.],0,jfgrd,1) -* - call M1Kernel(Final,Hess,nHess,DAO,nDAO, - & iAnga,nRys,nZeta, - & Array(ipA),Array(ipB),Zeta,ZInv, - & rKappa,P,TC,Coori,Coorac, - & Array(ipArr),nArray, - & jfgrd,jndgrd,jfhss,jndhss, - & ifg,tr,mop,iuvwx, - & kCnttp,Fact,loper(1),0) - -* - 102 Continue - 101 Continue - 111 kdc = kdc + dbsc(kCnttp)%nCntr - 100 Continue -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Ccoor) - Call Unused_integer(nOrdOp) - End If - End diff -Nru openmolcas-22.02/src/mckinley/m1hss.F90 openmolcas-22.10/src/mckinley/m1hss.F90 --- openmolcas-22.02/src/mckinley/m1hss.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/m1hss.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,231 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Anders Bernhardsson * +! 1991, Roland Lindh * +!*********************************************************************** + +subroutine M1Hss( & +# define _CALLING_ +# include "hss_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the gradient of the nuclear attraction integrals. * +! * +! Author: Anders Bernhardsson & Roland Lindh, * +! Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +! October 1991 * +!*********************************************************************** + +use McKinley_global, only: sIrrep +use Index_Functions, only: iTri, nTri_Elem1 +use Basis_Info, only: dbsc, nCnttp +use Center_Info, only: dc +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +#include "hss_interface.fh" +#include "Molcas.fh" +#include "disp.fh" +integer(kind=iwp) :: iAnga(4), iBeta, iCar, iCent, iComp, iDCRT(0:7), iIrrep, ipA, ipAOff, ipArr, ipB, ipBOff, iStop, iuvwx(4), & + jAtom, jCar, JndGrd(0:2,0:3,0:7), JndHss(0:3,0:2,0:3,0:2,0:7), kCnt, kCnttp, kdc, lDCRT, LmbdT, Maxi, Mini, & + mOp(4), nArray, nDAO, nDCRT, nDisp, nip, nnIrrep, nRys +real(kind=wp) :: C(3), CoorAC(3,2), Coori(3,4), Fact, TC(3) +logical(kind=iwp) :: IfG(0:3), JfGrd(0:2,0:3), JfHss(0:3,0:2,0:3,0:2), Tr(0:3) +integer(kind=iwp), external :: NrOpr +logical(kind=iwp), external :: EQ, TF + +#include "macros.fh" +unused_var(ZInv) +unused_var(Ccoor) +unused_var(nOrdOp) + +!if (iPrint >= 99) then +! write(u6,*) ' In M1Hss: nArr=',nArr +!end if + +nRys = nHer + +nip = 1 +ipA = nip +nip = nip+nAlpha*nBeta +ipB = nip +nip = nip+nAlpha*nBeta +ipArr = nip +nArray = nArr-nip+1 + +iIrrep = 0 +iAnga(1) = la +iAnga(2) = lb +iAnga(3) = 0 +iAnga(4) = 0 +Coori(:,1) = A +Coori(:,2) = RB +if (la >= lb) then + CoorAC(:,1) = A +else + CoorAC(:,1) = RB +end if +iuvwx(1) = dc(mdc)%nStab +iuvwx(2) = dc(ndc)%nStab +mOp(1) = nOp(1) +mOp(2) = nOp(2) + +ipAOff = ipA +do iBeta=1,nBeta + Array(ipAOff:ipAOff+nAlpha) = Alpha + ipAOff = ipAOff+nAlpha +end do + +ipBOff = ipB +do iBeta=1,nBeta + Array(ipBOff:ipBOff+nAlpha) = Beta(iBeta) + ipBOff = ipBOff+nAlpha +end do + +! Modify the density matrix with the prefactor + +nDAO = nTri_Elem1(la)*nTri_Elem1(lb) +!do iDAO=1,nDAO +! DAO(:,iDAO) = Two*rKappa(:)*Pi*ZInv(:)*DAO(:,iDAO) +!end do +!if (iPrint >= 99) Call RecPrt('DAO',' ',DAO,nZeta,nDAO) + +! Here we go + +! Loop over nuclear centers + +kdc = 0 +do kCnttp=1,nCnttp + if (kCnttp > 1) kdc = kdc+dbsc(kCnttp-1)%nCntr + if (dbsc(kCnttp)%Charge == Zero) cycle + do kCnt=1,dbsc(kCnttp)%nCntr + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) + do lDCRT=0,nDCRT-1 + JndHss(:,:,:,:,0:nSym-1) = 0 + JndGrd(:,:,0:nSym-1) = 0 + JfHss(:,:,:,:) = .false. + JfGrd(:,:) = .false. + Tr(:) = .false. + mOp(3) = NrOpr(iDCRT(lDCRT)) + mOp(4) = mOp(3) + call OA(iDCRT(lDCRT),C,TC) + CoorAC(:,2) = TC + Coori(:,3) = TC + Coori(:,4) = TC + if (EQ(A,TC) .and. EQ(A,RB)) cycle + + ! COPY CNTLR MATRICES + + JfGrd(0:2,0:1) = Ifgrd(0:2,0:1) + JndGrd(0:2,0:1,0:nSym-1) = IndGrd(0:2,0:1,0:nSym-1) + JfHss(0:1,0:2,0:1,0:2) = IfHss(0:1,0:2,0:1,0:2) + JndHss(0:1,0:2,0:1,0:2,0:nSym-1) = IndHss(0:1,0:2,0:1,0:2,0:nSym-1) + + Fact = -dbsc(kCnttp)%Charge*real(nStabM,kind=wp)/real(LmbdT,kind=wp) + !Array(ipDAO:ipDAO+nZeta*nDAO-1) = Fact*reshape(DAO(:,1:nDAO),[nZeta*nDAO]) + iuvwx(3) = dc(kdc+kCnt)%nStab + iuvwx(4) = dc(kdc+kCnt)%nStab + + ! Derivatives with respect to the operator are computed via the + ! translational invariance. + + nnIrrep = nSym + if (sIrrep) nnIrrep = 1 + do iIrrep=0,nnIrrep-1 + nDisp = IndDsp(kdc+kCnt,iIrrep) + do iCar=0,2 + iComp = 2**iCar + if (TF(kdc+kCnt,iIrrep,iComp)) then + nDisp = nDisp+1 + + ! Reset flags for the basis set centers so that we + ! will explicitly compute the derivatives with + ! respect to those centers. Activate flag for the + ! third center so that its derivative will be computed + ! by the translational invariance. + + JndGrd(iCar,0:1,iIrrep) = abs(JndGrd(iCar,0:1,iIrrep)) + JndGrd(iCar,2,iIrrep) = -nDisp + JfGrd(iCar,0:1) = .true. + JfGrd(iCar,2) = .false. + else + JndGrd(iCar,2,iIrrep) = 0 + end if + end do + end do + + ! The third center is claculated by translation invarians + ! This requires the 2nd derivatives on the other centers. + + do iCar=0,2 + do jAtom=0,2 + if (jAtom == 2) then + iStop = iCar + else + iStop = 2 + end if + do jCar=0,iStop + do iIrrep=0,nSym-1 + if ((JndGrd(iCar,2,iIrrep) /= 0) .and. (JndGrd(jCar,jAtom,iIrrep) /= 0)) then + JndHss(2,iCar,jAtom,jCar,iIrrep) = -iTri(abs(JndGrd(iCar,2,iIrrep)),abs(JndGrd(jCar,jAtom,iIrrep))) + + Tr(2) = .true. + if (jAtom == 2) then + Maxi = max(iCar,jCar) + Mini = min(iCar,jCar) + jfHss(0,Maxi,0,Mini) = .true. + jfHss(1,Maxi,1,Mini) = .true. + jfHss(1,iCar,0,jCar) = .true. + jfHss(1,jCar,0,iCar) = .true. + else + Maxi = max(iCar,jCar) + Mini = min(iCar,jCar) + jfHss(jAtom,Maxi,jAtom,Mini) = .true. + jfHss(1,iCar,0,jCar) = .true. + jfHss(1,jCar,0,iCar) = .true. + end if + end if + end do + end do + end do + end do + + IfG(0) = .true. + IfG(1) = .true. + IfG(2) = .false. + IfG(3) = .false. + do iCent=0,1 + if (EQ(Coori(1,iCent+1),Coori(1,3))) then + IfG(iCent) = .false. + JfGrd(:,iCent) = .false. + JfHss(iCent,:,:,:) = .false. + JfHss(:,:,iCent,:) = .false. + JndHss(iCent,:,:,:,0:nSym-1) = 0 + JndHss(:,:,iCent,:,0:nSym-1) = 0 + JndGrd(:,iCent,0:nSym-1) = 0 + end if + end do + JfGrd(:,:) = .false. + + call M1Kernel(rFinal,Hess,nHess,DAO,nDAO,iAnga,nRys,nZeta,Array(ipA),Array(ipB),Zeta,rKappa,P,TC,Coori,CoorAC,Array(ipArr), & + nArray,jfgrd,jndgrd,jfhss,jndhss,ifg,tr,mop,iuvwx,kCnttp,Fact,loper(1),0) + + end do + end do +end do + +return + +end subroutine M1Hss diff -Nru openmolcas-22.02/src/mckinley/m1kernel.f openmolcas-22.10/src/mckinley/m1kernel.f --- openmolcas-22.02/src/mckinley/m1kernel.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/m1kernel.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,156 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine m1kernel(Final,Hess,nHess,DAO,nDAO, - & iAng,nRys,nZeta, - & Alpha,Beta,Zeta,ZInv, - & rKappa,P,TC,Coor,CoorAc, - & Array,nArray, - & ifgrd,indgrd,ifhss,indhss, - & ifg,tr,nop,iuvwx, - & kCnttp,fact,loper,idcar) - - use Real_Spherical - use Basis_Info - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) - External TNAI1, Fake, Cff2D -#include "Molcas.fh" -#include "real.fh" -#include "disp.fh" - - Integer iAng(4),nop(4),iuvwx(4) - Real*8 Alpha(nZeta),Beta(nZeta),Zeta(nZeta), - & ZInv(nZeta),rKappa(nZeta),P(nZeta,*), - & TC(3),Coor(3,4),Array(nArray),Final(*), - & CoorAC(3,2), coori(3,4),Hess(*),DAO(nzeta,*) - Logical ifg(4),tr(4),ifgrd(3,4),ifhss(3,4,3,4),eq, - & jfgrd(3,4),jfg(4),lGrad,lHess,jfhss(3,4,3,4) - Integer indgrd(3,4,0:7),index(3,4),indhss(3,4,3,4,8), - & jndgrd(3,4,0:7),jndhss(3,4,3,4,8) - - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - - lGrad = idcar.ne.0 - lHess = nHess.ne.0 - call dcopy_(12,coor,1,coori,1) - If (.Not.EQ(coor(1,1),coor(1,2)) .or. - & .Not.EQ(coor(1,1),coor(1,3))) Then - Coori(1,1) = Coori(1,1)+One - End If - - ip=1 - ipK = ip - ip = ip + nZeta - ipZ = ip - ip = ip + nZeta - ipZI = ip - ip = ip + nZeta - ipPx = ip - ip = ip + nZeta - ipPy = ip - ip = ip + nZeta - ipPz = ip - ip = ip + nZeta - ipDAO = ip - ip = ip + nDAO*nZeta - if (ip.ge.narray) then - write(6,*) 'Out of memory in m1kernel (',narray,',',ip,')' - Call Abend() - endif - - - -#ifdef _DEBUGPRINT_ - Write(6,*)'nM1=',dbsc(kCnttp)%nM1,'kCnttp=',kCnttp -#endif - - Do 1011 iM1xp=1, dbsc(kCnttp)%nM1 - Gamma = dbsc(kCnttp)%M1xp(iM1xp) - FactECP = dbsc(kCnttp)%M1cf(iM1xp)* Fact - - -#ifdef _DEBUGPRINT_ - write(6,*) 'Fact=',FactECP,Fact - write(6,*) 'im1xp=',iM1xp - write(6,*) 'Gamma=',Gamma -#endif -* -*-----------Modify the original basis. Observe that -* simplification due to A=B are not valid for the -* exponent index, eq. P-A=/=0. -* - Do 1012 iZeta = 1, nZeta - PTC2 = (P(iZeta,1)-TC(1))**2 - & + (P(iZeta,2)-TC(2))**2 - & + (P(iZeta,3)-TC(3))**2 - Tmp0 = Zeta(iZeta)+Gamma - Tmp1 = Exp(-Zeta(iZeta)*Gamma*PTC2/Tmp0) - Array(ipK +iZeta-1) = rKappa(iZeta) * Tmp1 - Array(ipZ +iZeta-1) = Tmp0 - Array(ipZI+iZeta-1) = One/Tmp0 - Array(ipPx+iZeta-1) = - & (Zeta(iZeta)*P(iZeta,1)+Gamma*TC(1))/Tmp0 - Array(ipPy+iZeta-1) = - & (Zeta(iZeta)*P(iZeta,2)+Gamma*TC(2))/Tmp0 - Array(ipPz+iZeta-1) = - & (Zeta(iZeta)*P(iZeta,3)+Gamma*TC(3))/Tmp0 - 1012 Continue - - Do iDAO = 1, nDAO - Do iZeta = 1, nZeta - Fac = FactECP * Array(ipK+iZeta-1) * - & Array(ipZI+iZeta-1)* Two * Pi - ipDAOt = nZeta*(iDAO-1) + iZeta-1 + ipDAO - Array(ipDAOt)= Fac * DAO(iZeta,iDAO) - End Do - End Do - -* -*-----------Compute integrals with the Rys quadrature. -* - call lcopy(4,ifg,1,jfg,1) - - call lcopy(12,ifgrd,1,jfgrd,1) - call lcopy(12*12,ifhss,1,jfhss,1) - - call icopy(12*nirrep,indgrd,1,jndgrd,1) - call icopy(12*12*nirrep,indhss,1,jndhss,1) - - Call Rysg2(iAng,nRys,nZeta, - & Alpha,Beta,[One],[One], - & Array(ipZ),Array(ipZI),nZeta,[One],[One],1, - & Array(ipPx),nZeta,TC,1,Coori,Coor,CoorAC, - & Array(ip),nArray-ip+1, - & TNAI1,Fake,Cff2D, - & Array(ipDAO),nDAO,Hess,nhess,jfGrd,jndGrd, - & jfHss,jndHss,nOp,iuvwx,jfg, - & nGr,Index,lgrad,lhess,tr) - if (lGrad) Then - nb = nzeta*nElem(iAng(1))*nElem(iAng(2)) - Do iElem = 1, nElem(iAng(1))*nElem(iAng(2))*ngr - Do iZeta = 1, nZeta - tfac = Two*PI*Array(ipK+iZeta-1)*Array(ipZI-1+iZeta) - indi=(iElem-1)*nZeta+iZeta - Array(ip+indi-1) = FactECP*tfac * Array(ip+indi-1) - End Do - End Do - - - Call SmAdNa(Array(ip),nb,Final, - & nop(1:3),loper,jndGrd,iuvwx(1:3),jfGrd,Index, - & idcar,One,jFG,tr) - End if - - 1011 Continue - return -c Avoid unused argument warnings - If (.False.) Call Unused_real_array(ZInv) - end diff -Nru openmolcas-22.02/src/mckinley/m1kernel.F90 openmolcas-22.10/src/mckinley/m1kernel.F90 --- openmolcas-22.02/src/mckinley/m1kernel.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/m1kernel.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,126 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine m1kernel(rFinal,Hess,nHess,DAO,nDAO,iAng,nRys,nZeta,Alpha,Beta,Zeta,rKappa,P,TC,Coor,CoorAc,Array,nArray,ifgrd,indgrd, & + ifhss,indhss,ifg,tr,nop,iuvwx,kCnttp,fact,loper,idcar) + +use Index_Functions, only: nTri_Elem1 +use Basis_Info, only: dbsc +use Symmetry_Info, only: nIrrep +use Constants, only: One, Two, Pi +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nHess, nDAO, iAng(4), nRys, nZeta, nArray, indgrd(3,4,0:7), indhss(3,4,3,4,0:7), nop(4), & + iuvwx(4), kCnttp, loper, idcar +real(kind=wp), intent(inout) :: rFinal(*), Hess(nHess) +real(kind=wp), intent(in) :: DAO(nZeta,nDAO), Alpha(nZeta), Beta(nZeta), Zeta(nZeta), rKappa(nZeta), P(nZeta,3), TC(3), Coor(3,4), & + CoorAC(3,2), fact +real(kind=wp), intent(out) :: Array(nArray) +logical(kind=iwp), intent(in) :: ifgrd(3,4), ifhss(3,4,3,4), ifg(4) +logical(kind=iwp), intent(inout) :: tr(4) +integer(kind=iwp) :: iDAO, iElem, iM1xp, indi, Indx(3,4), ip, ipDAO, ipDAOt, ipK, ipPx, ipPy, ipPz, ipZ, ipZI, iZeta, & + jndgrd(3,4,0:7), jndhss(3,4,3,4,0:7), nb, nGr +real(kind=wp) :: coori(3,4), FactECP, Gmma, PTC2, Tmp0, Tmp1 +logical(kind=iwp) :: jfg(4), jfgrd(3,4), jfhss(3,4,3,4), lGrad, lHess +logical(kind=iwp), external :: EQ +external :: Cff2D, Fake, TNAI1 + +lGrad = idcar /= 0 +lHess = nHess /= 0 +coori(:,:) = coor +if ((.not. EQ(coor(1,1),coor(1,2))) .or. (.not. EQ(coor(1,1),coor(1,3)))) then + Coori(1,1) = Coori(1,1)+One +end if + +ip = 1 +ipK = ip +ip = ip+nZeta +ipZ = ip +ip = ip+nZeta +ipZI = ip +ip = ip+nZeta +ipPx = ip +ip = ip+nZeta +ipPy = ip +ip = ip+nZeta +ipPz = ip +ip = ip+nZeta +ipDAO = ip +ip = ip+nDAO*nZeta +if (ip >= narray) then + write(u6,*) 'Out of memory in m1kernel (',narray,',',ip,')' + call Abend() +end if + +#ifdef _DEBUGPRINT_ +write(u6,*) 'nM1=',dbsc(kCnttp)%nM1,'kCnttp=',kCnttp +#endif + +do iM1xp=1,dbsc(kCnttp)%nM1 + Gmma = dbsc(kCnttp)%M1xp(iM1xp) + FactECP = dbsc(kCnttp)%M1cf(iM1xp)*Fact + +# ifdef _DEBUGPRINT_ + write(u6,*) 'Fact=',FactECP,Fact + write(u6,*) 'im1xp=',iM1xp + write(u6,*) 'Gamma=',Gmma +# endif + + ! Modify the original basis. Observe that + ! simplification due to A=B are not valid for the + ! exponent index, eq. P-A=/=0. + + do iZeta=1,nZeta + PTC2 = (P(iZeta,1)-TC(1))**2+(P(iZeta,2)-TC(2))**2+(P(iZeta,3)-TC(3))**2 + Tmp0 = Zeta(iZeta)+Gmma + Tmp1 = exp(-Zeta(iZeta)*Gmma*PTC2/Tmp0) + Array(ipK+iZeta-1) = rKappa(iZeta)*Tmp1 + Array(ipZ+iZeta-1) = Tmp0 + Array(ipZI+iZeta-1) = One/Tmp0 + Array(ipPx+iZeta-1) = (Zeta(iZeta)*P(iZeta,1)+Gmma*TC(1))/Tmp0 + Array(ipPy+iZeta-1) = (Zeta(iZeta)*P(iZeta,2)+Gmma*TC(2))/Tmp0 + Array(ipPz+iZeta-1) = (Zeta(iZeta)*P(iZeta,3)+Gmma*TC(3))/Tmp0 + end do + + do iDAO=1,nDAO + ipDAOt = ipDAO+nZeta*(iDAO-1) + Array(ipDAOt:ipDAOt+nZeta-1) = FactECP*Array(ipK:ipK+nZeta-1)*Array(ipZI:ipZI+nZeta-1)*Two*Pi*DAO(:,iDAO) + end do + + ! Compute integrals with the Rys quadrature. + + jfg(:) = ifg + + jfgrd(:,:) = ifgrd + jfhss(:,:,:,:) = ifhss + + jndgrd(:,:,0:nirrep-1) = indgrd(:,:,0:nirrep-1) + jndhss(:,:,:,:,0:nirrep-1) = indhss(:,:,:,:,0:nirrep-1) + + call Rysg2(iAng,nRys,nZeta,Alpha,Beta,[One],[One],Array(ipZ),Array(ipZI),nZeta,[One],[One],1,Array(ipPx),nZeta,TC,1,Coori,Coor, & + CoorAC,Array(ip),nArray-ip+1,TNAI1,Fake,Cff2D,Array(ipDAO),nDAO,Hess,nHess,jfGrd,jndGrd,jfHss,jndHss,nOp,iuvwx,jfg, & + nGr,Indx,lgrad,lhess,tr) + if (lGrad) then + nb = nzeta*nTri_Elem1(iAng(1))*nTri_Elem1(iAng(2)) + do iElem=1,nTri_Elem1(iAng(1))*nTri_Elem1(iAng(2))*ngr + indi = ip+(iElem-1)*nZeta + Array(indi:indi+nZeta-1) = FactECP*Two*PI*Array(ipK:ipK+nZeta-1)*Array(ipZI:ipZI+nZeta-1)*Array(indi:indi+nZeta-1) + end do + + call SmAdNa(Array(ip),nb,rFinal,nop(1:3),loper,jndGrd,iuvwx(1:3),Indx,idcar,One,tr) + end if + +end do + +return + +end subroutine m1kernel diff -Nru openmolcas-22.02/src/mckinley/m1mm1.f openmolcas-22.10/src/mckinley/m1mm1.f --- openmolcas-22.02/src/mckinley/m1mm1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/m1mm1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,27 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine m1mm1(nRys,MmNAG,la,lb,lr) -* - Integer iAng(4) -* - iAng(1) = la - iAng(2) = lb - iAng(3) = 0 - iAng(4) = 0 - Call MemRg2(iAng,nRys,MmNAG,1) - MmNAG = MmNAG + 10 -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(lr) - End diff -Nru openmolcas-22.02/src/mckinley/m1mm1.F90 openmolcas-22.10/src/mckinley/m1mm1.F90 --- openmolcas-22.02/src/mckinley/m1mm1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/m1mm1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,37 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine m1mm1( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: iAng(4) + +#include "macros.fh" +unused_var(lr) + +iAng(1) = la +iAng(2) = lb +iAng(3) = 0 +iAng(4) = 0 +call MemRg2(iAng,nHer,Mem,1) +Mem = Mem+10 + +return + +end subroutine m1mm1 diff -Nru openmolcas-22.02/src/mckinley/m1mmh.f openmolcas-22.10/src/mckinley/m1mmh.f --- openmolcas-22.02/src/mckinley/m1mmh.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/m1mmh.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine M1MmH(nRys,MmM1H,la,lb,lr) -* - Integer iAng(4) -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - iAng(1) = la - iAng(2) = lb - iAng(3) = 0 - iAng(4) = 0 - Call MemRg2(iAng,nRys,MmM1H,2) - MmM1H = MmM1H + 12 + nElem(la)*nElem(lb) -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(lr) - End diff -Nru openmolcas-22.02/src/mckinley/m1mmh.F90 openmolcas-22.10/src/mckinley/m1mmh.F90 --- openmolcas-22.02/src/mckinley/m1mmh.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/m1mmh.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,38 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine M1MmH( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: iAng(4) + +#include "macros.fh" +unused_var(lr) + +iAng(1) = la +iAng(2) = lb +iAng(3) = 0 +iAng(4) = 0 +call MemRg2(iAng,nHer,Mem,2) +Mem = Mem+12+nTri_Elem1(la)*nTri_Elem1(lb) + +return + +end subroutine M1MmH diff -Nru openmolcas-22.02/src/mckinley/main.f openmolcas-22.10/src/mckinley/main.f --- openmolcas-22.02/src/mckinley/main.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/main.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - program main -#ifdef _FPE_TRAP_ - Use, Intrinsic :: IEEE_Exceptions -#endif - implicit real*8 (a-h,o-z) - Character*20 Module_Name - Parameter (Module_Name = 'mckinley') -#ifdef _FPE_TRAP_ - Call IEEE_Set_Halting_Mode(IEEE_Usual,.True._4) -#endif - - Call Start(Module_Name) - Call mckinley(ireturn) - Call Finish(ireturn) - end diff -Nru openmolcas-22.02/src/mckinley/main.F90 openmolcas-22.10/src/mckinley/main.F90 --- openmolcas-22.02/src/mckinley/main.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/main.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,31 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +program Main + +#ifdef _FPE_TRAP_ +use, intrinsic :: IEEE_Exceptions, only: IEEE_Set_Halting_Mode, IEEE_Usual +use Definitions, only: DefInt +#endif +use Definitions, only: iwp + +implicit none +integer(kind=iwp) :: rc + +#ifdef _FPE_TRAP_ +call IEEE_Set_Halting_Mode(IEEE_Usual,.true._DefInt) +#endif + +call Start('mckinley') +call mckinley(rc) +call Finish(rc) + +end program Main diff -Nru openmolcas-22.02/src/mckinley/makemo.f openmolcas-22.10/src/mckinley/makemo.f --- openmolcas-22.02/src/mckinley/makemo.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/makemo.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,189 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) Anders Bernhardsson * -************************************************************************ - SubRoutine MakeMO(AOInt,Temp,nTemp,nInt, - & MOInt,nMOInt, - & iCmp,iCmpa, - & ibasi,jbasj,kbask,lbasl, - & nGr,index, - & moip,naco,nop,indgrd, - & ishll,ishell,rmoin,nmoin,iuvwx,iao,iaost, - & buffer,ianga,c) -* -* this is the driver for the two index transformation -* it is not very efficent, but on the other hand it -* usually to take more than a few percent of the total -* CPU time, if someone notice something else I will -* rewrite it, in the mean time, dont worry. -* - - Use Basis_Info, only: Shells - use Symmetry_Info, only: nIrrep - Implicit Real*8 (a-h,o-z) -#include "Molcas.fh" -#include "real.fh" -#include "buffer.fh" -* -* - Logical pert(0:7),lc - Integer iCmpa(4), - & index(3,4),ipPert(0:7),icmp(4),ibas(4), - & indgrd2(3,4,0:7),indgrd(3,4,0:nirrep-1), - & moip(0:7),nop(4),ishell(4),iuvwx(4), - & iao(4),iAOST(4),ianga(4),ishll(4) - Real*8 Temp(nTemp),AOInt(nInt),rmoin(nmoin),MOInt(nMOInt), - & C(12),buffer(*) -* - iMax=0 - mSum=0 - nabcd=iBasi*jBasj*kBask*lBasl - nijkl=icmp(1)*icmp(2)*icmp(3)*icmp(4) - iBas(1)=iBasi - iBas(2)=jBasj - iBas(3)=kBask - iBas(4)=lBasl - Do ii=1,4 - imax=Max(iBas(ii)*iCmp(ii),imax) - mSum=mSum+iBas(ii)*iCmp(ii) - End Do - imax=Max(iMax,nAco) -* - nInt2=nabcd*nijkl - - ip=1 - ip0=ip - ip=ip+nGr*nijkl*nabcd - ip1=ip - nScrtch=imax**4 - ip=ip+nScrtch - ip2=ip - ip=ip+nScrtch - ip3=ip - ip=ip+nScrtch - ip5=ip - ip=ip+iCmp(1)*iCmp(2)*iCmp(3)*iCmp(4)* - & iBas(1)*iBas(2)*iBas(3)*iBas(4) - If (ip-1.gt.nTemp) Then - Write (6,*) 'MakeMO: ip-1.gt.nTemp' - Write (6,*) 'ip,nTemp=',ip,nTemp - Call Abend() - End If -* ip=2 -* Temp(ip-1)=0.0d0 -* ip0=ip -* ip=ip+nGr*nijkl*nabcd+1 -* Temp(ip-1)=0.0d0 -* ip1=ip -* nScrtch=imax**4+1 -* ip=ip+nScrtch -* Temp(ip-1)=0.0d0 -* ip2=ip -* ip=ip+nScrtch -* Temp(ip-1)=0.0d0 -* ip3=ip -* ip=ip+nScrtch -* Temp(ip-1)=0.0d0 -* ip5=ip -* ip=ip+iCmp(1)*iCmp(2)*iCmp(3)*iCmp(4)* -* & iBas(1)*iBas(2)*iBas(3)*iBas(4)+1 -* Temp(ip-1)=0.0d0 -* - ipc=1 - ipD=ipc -* nD=nACO**4 -* ipC=ipC+nd - ipci=ipc -* nCi=iBas(1)*iCmp(1)*nACO - ipcj=ipc -* nCj=iBas(2)*iCmp(2)*nACO - ipck=ipc - nCk=iBas(3)*iCmp(3)*nACO - ipc=ipc+nCk - ipcl=ipc - nCl=iBas(4)*iCmp(4)*nAcO - ipc=ipc+nCl - nij=iCmp(1)*iBas(1)*iBas(2)*iCmp(2) - nkl=iCmp(3)*iBas(3)*iBas(4)*iCmp(4) - If (ipc-1.ne.nMoIn) Then - Write (6,*) 'MakeMO: ipc-1.ne.nMoIn' - Write (6,*) 'ipc,nMoIn=',ipc,nMoIn - Call Abend() - End If - -* - Call Sort_mck(AOInt,Temp(ip0), - & iBas(1),iBas(2),iBas(3),iBas(4), - & iCmp(1),iCmp(2),iCmp(3),iCmp(4), - & iBas(1),iBas(2),iBas(3),iBas(4), - & iCmpa(1),iCmpa(2),iCmpa(3),iCmpa(4), - & nGr,nop,ianga, - & indgrd,indgrd2,ishll,C) -* - Do iCent=1,4 - lc=.false. - Do iCar=1,3 - Call ICopy(nIrrep,[0],0,ipPert,1) - Call lCopy(nIrrep,[.false.],0,pert,1) - lc=.false. - Do iIrrep=0,nIrrep-1 - If (indgrd(icar,icent,iIrrep).ne.0) Then - ipPert(iIrrep)=ipMO(abs(indgrd(iCar,iCent,iIrrep)),1) - pert(iIrrep)=.true. - End If - If (IndGrd(iCar,icent,iirrep).ne.0) lC=.true. - End Do - If (lc) Then - If (Index(iCar,iCent).gt.0) Then - -* - iGr=index(icar,icent) - Call MOAcc(Temp(ip0+(iGr-1)*nijkl*nabcd),nINT2, - & Temp(ip1),Temp(ip2),Temp(ip3),nScrtch, - & MOInt,nMOINt,ishell, - & rmoin(ipCi),nCi,rmoin(ipCj),nCj, - & rmoin(ipCk),nCk,rmoin(ipCl),nCl, - & Moip,nACO,pert,nOp,ibas,icmpa, - & iCar,icent,indgrd,rmoin(ipD), - & DBLE(iuvwx(iCent))/DBLE(nIrrep),iao,iaost, - & buffer,Temp(ip2),nij,nkl, - & Shells(ishll(1))%nBasis,Shells(ishll(2))%nBasis, - & icmpa(1),icmpa(2)) -* - Else If (Index(iCar,iCent).lt.0) Then - call dcopy_(nabcd*nijkl,[Zero],0,Temp(ip5),1) - Do iCnt=1,4 - iGr=Index(iCar,iCnt) - If (iGr.gt.0)Then - ipFin=(iGr-1)*nijkl*nabcd+ip0 - Do ii=1,nabcd*nijkl - Temp(ip5+ii-1)=Temp(ip5+ii-1)-Temp(ipFin-1+ii) - End Do - End If - End Do - Call MOAcc(Temp(ip5),nInt2, - & Temp(ip1),Temp(ip2),Temp(ip3),nScrtch, - & MOInt,nMOINt,ishell, - & rmoin(ipCi),nCi,rmoin(ipCj),nCj, - & rmoin(ipCk),nCk,rmoin(ipCl),nCl, - & moip,nACO,pert,nOp,ibas,icmpa, - & iCar,icent,indgrd,rMoin(ipD), - & DBLE(iuvwx(iCent))/DBLE(nIrrep),iao,iaost, - & buffer,Temp(ip2),nij,nkl, - & Shells(ishll(1))%nBasis,Shells(ishll(2))%nBasis, - & icmpa(1),icmpa(2)) -* - End If - End If - End Do - End Do - Return - End diff -Nru openmolcas-22.02/src/mckinley/makemo.F90 openmolcas-22.10/src/mckinley/makemo.F90 --- openmolcas-22.02/src/mckinley/makemo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/makemo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,149 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) Anders Bernhardsson * +!*********************************************************************** + +subroutine MakeMO(AOInt,Temp,nTemp,n_Int,iCmp,iCmpa,ibasi,jbasj,kbask,lbasl,nGr,Indx,moip,naco,nop,indgrd,ishll, & + ishell,rmoin,nmoin,iuvwx,iaost,buffer,ianga) +! this is the driver for the two index transformation +! it is not very efficent, but on the other hand it +! usually to take more than a few percent of the total +! CPU time, if someone notice something else I will +! rewrite it, in the mean time, dont worry. + +use Basis_Info, only: Shells +use Symmetry_Info, only: nIrrep +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nTemp, n_Int, icmp(4), iCmpa(4), ibasi, jbasj, kbask, lbasl, nGr, Indx(3,4), moip(0:7), naco, & + nop(4), indgrd(3,4,0:nirrep-1), ishll(4), ishell(4), nmoin, iuvwx(4), iAOST(4), ianga(4) +real(kind=wp), intent(in) :: AOInt(n_Int) +real(kind=wp), intent(out) :: Temp(nTemp) +real(kind=wp), intent(inout) :: rmoin(nmoin), buffer(*) +integer(kind=iwp) :: ibas(4), iCar, iCent, iCnt, iGr, ii, iIrrep, iMax, ip, ip0, ip1, ip2, ip5, ipc, ipck, ipcl, ipFin, mSum, & + nabcd, nCk, nCl, nij, nijkl, nkl, nScrtch, ntot +logical(kind=iwp) :: lc, pert(0:7) + +iMax = 0 +mSum = 0 +nabcd = iBasi*jBasj*kBask*lBasl +nijkl = icmp(1)*icmp(2)*icmp(3)*icmp(4) +ntot = nabcd*nijkl +iBas(1) = iBasi +iBas(2) = jBasj +iBas(3) = kBask +iBas(4) = lBasl +do ii=1,4 + imax = max(iBas(ii)*iCmp(ii),imax) + mSum = mSum+iBas(ii)*iCmp(ii) +end do +imax = max(iMax,nAco) + +ip = 1 +ip0 = ip +ip = ip+nGr*ntot +ip1 = ip +nScrtch = imax**4 +ip = ip+nScrtch +ip2 = ip +ip = ip+nScrtch +ip = ip+nScrtch ! some unused memory here? +ip5 = ip +ip = ip+iCmp(1)*iCmp(2)*iCmp(3)*iCmp(4)*iBas(1)*iBas(2)*iBas(3)*iBas(4) +if (ip-1 > nTemp) then + write(u6,*) 'MakeMO: ip-1 > nTemp' + write(u6,*) 'ip,nTemp=',ip,nTemp + call Abend() +end if +!ip = 2 +!Temp(ip-1) = Zero +!ip0 = ip +!ip = ip+nGr*ntot+1 +!Temp(ip-1) = Zero +!ip1 = ip +!nScrtch = imax**4+1 +!ip = ip+nScrtch +!Temp(ip-1) = Zero +!ip2 = ip +!ip = ip+nScrtch +!Temp(ip-1) = Zero +!ip3 = ip +!ip = ip+nScrtch +!Temp(ip-1) = Zero +!ip5 = ip +!ip = ip+iCmp(1)*iCmp(2)*iCmp(3)*iCmp(4)*iBas(1)*iBas(2)*iBas(3)*iBas(4)+1 +!Temp(ip-1) = Zero + +ipc = 1 +!ipD = ipc +!nD = nACO**4 +!ipC = ipC+nd +!ipci = ipc +!nCi = iBas(1)*iCmp(1)*nACO +!ipcj = ipc +!nCj = iBas(2)*iCmp(2)*nACO +ipck = ipc +nCk = iBas(3)*iCmp(3)*nACO +ipc = ipc+nCk +ipcl = ipc +nCl = iBas(4)*iCmp(4)*nAcO +ipc = ipc+nCl +nij = iCmp(1)*iBas(1)*iBas(2)*iCmp(2) +nkl = iCmp(3)*iBas(3)*iBas(4)*iCmp(4) +if (ipc-1 /= nMoIn) then + write(u6,*) 'MakeMO: ipc-1 /= nMoIn' + write(u6,*) 'ipc,nMoIn=',ipc,nMoIn + call Abend() +end if + +call Sort_mck(AOInt,Temp(ip0),iBas(1),iBas(2),iBas(3),iBas(4),iCmp(1),iCmp(2),iCmp(3),iCmp(4),iBas(1),iBas(2),iBas(3),iBas(4), & + iCmpa(1),iCmpa(2),iCmpa(3),iCmpa(4),nGr,nop,ianga,ishll) + +do iCent=1,4 + lc = .false. + do iCar=1,3 + pert(0:nIrrep-1) = .false. + lC = .false. + do iIrrep=0,nIrrep-1 + if (IndGrd(iCar,iCent,iIrrep) /= 0) pert(iIrrep) = .true. + if (IndGrd(iCar,iCent,iIrrep) /= 0) lC = .true. + end do + if (lc) then + if (Indx(iCar,iCent) > 0) then + + iGr = Indx(icar,icent) + call MOAcc(Temp(ip0+(iGr-1)*ntot),Temp(ip1),Temp(ip2),nScrtch,ishell,rmoin(ipCk),nCk,rmoin(ipCl),nCl,Moip,nACO,pert,nOp, & + ibas,icmpa,iCar,icent,indgrd,real(iuvwx(iCent),kind=wp)/real(nIrrep,kind=wp),iaost,buffer,nij,nkl, & + Shells(ishll(1))%nBasis,Shells(ishll(2))%nBasis,icmpa(1),icmpa(2)) + + else if (Indx(iCar,iCent) < 0) then + Temp(ip5:ip5+ntot-1) = Zero + do iCnt=1,4 + iGr = Indx(iCar,iCnt) + if (iGr > 0) then + ipFin = (iGr-1)*ntot+ip0 + Temp(ip5:ip5+ntot-1) = Temp(ip5:ip5+ntot-1)-Temp(ipFin:ipFin+ntot-1) + end if + end do + call MOAcc(Temp(ip5),Temp(ip1),Temp(ip2),nScrtch,ishell,rmoin(ipCk),nCk,rmoin(ipCl),nCl,moip,nACO,pert,nOp,ibas,icmpa, & + iCar,icent,indgrd,real(iuvwx(iCent),kind=wp)/real(nIrrep,kind=wp),iaost,buffer,nij,nkl,Shells(ishll(1))%nBasis, & + Shells(ishll(2))%nBasis,icmpa(1),icmpa(2)) + + end if + end if + end do +end do + +return + +end subroutine MakeMO diff -Nru openmolcas-22.02/src/mckinley/mckinley_banner.f90 openmolcas-22.10/src/mckinley/mckinley_banner.f90 --- openmolcas-22.02/src/mckinley/mckinley_banner.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/mckinley_banner.f90 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -! * -! Copyright (C) 2020, Roland Lindh * -!*********************************************************************** -Subroutine McKinley_banner() -Write (6,'(25X,A)') -Write (6,'(25X,A)')" __ __ ___ " -Write (6,'(25X,A)')" /'\_/`\ /\ \/\ \ __ /\_ \ " -Write (6,'(25X,A)')"/\ \ ___\ \ \/'/'/\_\ ___ \//\ \ __ __ __ " -Write (6,'(25X,A)')"\ \ \__\ \ /'___\ \ , < \/\ \ /' _ `\ \ \ \ /'__`\/\ \/\ \ " -Write (6,'(25X,A)')" \ \ \_/\ \/\ \__/\ \ \\`\\ \ \/\ \/\ \ \_\ \_/\ __/\ \ \_\ \ " -Write (6,'(25X,A)')" \ \_\\ \_\ \____\\ \_\ \_\ \_\ \_\ \_\/\____\ \____\\/`____ \ " -Write (6,'(25X,A)')" \/_/ \/_/\/____/ \/_/\/_/\/_/\/_/\/_/\/____/\/____/ `/___/> \" -Write (6,'(25X,A)')" /\___/" -Write (6,'(25X,A)')" \/__/ " -Write (6,'(25X,A)') -End Subroutine McKinley_banner diff -Nru openmolcas-22.02/src/mckinley/mckinley_banner.F90 openmolcas-22.10/src/mckinley/mckinley_banner.F90 --- openmolcas-22.02/src/mckinley/mckinley_banner.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/mckinley_banner.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,33 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2020, Roland Lindh * +!*********************************************************************** + +subroutine McKinley_banner() + +use Definitions, only: u6 + +implicit none + +! figlet -f larry3d.flf McKinley +write(u6,100) " __ __ ___" +write(u6,100) " /'\_/`\ /\ \/\ \ __ /\_ \" +write(u6,100) "/\ \ ___\ \ \/'/'/\_\ ___ \//\ \ __ __ __" +write(u6,100) "\ \ \__\ \ /'___\ \ , < \/\ \ /' _ `\ \ \ \ /'__`\/\ \/\ \" +write(u6,100) " \ \ \_/\ \/\ \__/\ \ \\`\\ \ \/\ \/\ \ \_\ \_/\ __/\ \ \_\ \" +write(u6,100) " \ \_\\ \_\ \____\\ \_\ \_\ \_\ \_\ \_\/\____\ \____\\/`____ \" +write(u6,100) " \/_/ \/_/\/____/ \/_/\/_/\/_/\/_/\/_/\/____/\/____/ `/___/> \" +write(u6,100) " /\___/" +write(u6,100) " \/__/" + +100 format(25x,a) + +end subroutine McKinley_banner diff -Nru openmolcas-22.02/src/mckinley/mckinley.f openmolcas-22.10/src/mckinley/mckinley.f --- openmolcas-22.02/src/mckinley/mckinley.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/mckinley.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,333 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1989-1992, Roland Lindh * -* 1990, IBM * -* 1995, Anders Bernhardsson * -************************************************************************ - subroutine McKinley(ireturn) -************************************************************************ -* * -* Object: Driver for the one and two electron integral second order * -* derivative program McKinley. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* July '89 - May '90 * -* * -* Roland Lindh, Dept. of Theoretical Chemistry, University of * -* Lund, SWEDEN. Modified to gradient calculations September * -* 1991 - February 1992. * -* * -* Anders Bernhardsson, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN. * -* Modified to second order derivatives October '94 - * -* '95 * -************************************************************************ - use Real_Spherical - use Basis_Info - use Gateway_global, only: Onenly, Test - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "real.fh" -#include "stdalloc.fh" -#include "disp.fh" -#include "disp2.fh" -#include "cputime.fh" -#include "print.fh" -#include "etwas.fh" -cpcm_solvent -#include "rctfld.fh" -cpcm_solvent end -c Parameter (nLines=12) - Character*120 Lines - Logical DoRys, Run_MCLR - Real*8, Allocatable:: Hess(:), Temp(:), GradN(:) -#include "warnings.h" -* * -************************************************************************ -* * -* Call McKinley_banner() - Call CWTime(TCpu1,TWall1) - iRout=1 - call dcopy_(9,[0.0d0],0,CpuStat,1) -* * -************************************************************************ -* * -* Print program header -* * -************************************************************************ -* * -c Lines(1)=_MOLCAS_VERSION_ -c#ifdef _DEMO_ -c Lines(2)='DEMO VERSION' -c#else -c Lines(2)=' ' -c#endif -c Lines(3)=' ' -c Lines(4)=Vrsn -c Lines(5)='A Vectorized Direct Integral Program for derivatives' -c Lines(6)='of Cartesian and Spherical Harmonic Gaussians' -c Lines(7)='Written by Anders Bernhardsson and Roland Lindh ' -c Lines(8)='Backtransformation of the 2nd order density matrix '// -c & 'from MO to SO by Per-AAke Malmqvist' -c Lines(9)='Dept. of Theoretical Chemistry, '// -c & 'Chemical Centre, Lund (Sweden)' -c Lines(10)=' ' -c Lines(11)=' ' -c Lines(12)='Compiled at '// -c & _BUILD_DATE_ -c lLine=Len(Lines(1)) -C Call Banner(Lines,nLines,lLine) -* * -************************************************************************ -* * -* Set error conditions -* - !Call XuFlow() - !Call ErrSet(209,1,1,2,1,209) -* * -************************************************************************ -* * -* Check if a numerical procedure will be used -* - Call SuperMac() -* * -************************************************************************ -* * -* -* Get the input information as Seward dumped on INFO. -* Set up some info -* Read input -* - nDiff=2 - DoRys=.True. - Call IniSew(DoRys,nDiff) -cpcm_solvent -c check if there is a reaction field -c write(6,*)'In mckinley PCM',pcm - Call Init_RctFld(.False.,iCharge_ref) -cpcm_solvent end - nsAtom=0 - Do iCnttp = 1, nCnttp - nsAtom=nsAtom+dbsc(iCnttp)%nCntr - End Do - Call Inputh(Run_MCLR) - iPrint=nPrint(iRout) - nGrad=0 - Do i=0,nIrrep-1 - nGrad=nGrad+lDisp(i) - End Do - Call OpnFls_Mckinley() -* * -************************************************************************ -* * -* Allocate area for hessian etc -* - nHess=nGrad*(nGrad+1)/2 -* - Call mma_allocate(Hess,nHess,Label='Hess') - Hess(:)=Zero - Call mma_allocate(Temp,nHess,Label='Temp') - Temp(:)=Zero -* * -************************************************************************ -* * -* Calculate the second order derivatives of the one electron * -* integrals and contract with D. * -* * -************************************************************************ -* * - If (lHss) Then - If (iPrint.ge.6) Then - Write(6,*) - Write(6,'(A,A,A)') - & 'The 2nd order derivatives of the one-electron', - & ' integrals are calculated and contracted with', - & ' the one-electron density matrix. ' - Write(6,*) - End If - Call Timing(dum1,Time,dum2,dum3) - Call Drvh2(Hess,Temp,nHess,show) - Call DrvEtc(nGrad) - End If -* * -************************************************************************ -* * -* Compute contribution from the nuclear repulsion. * -* * -************************************************************************ -* * - If (lHss) Then - Call DrvN2(Temp,nGrad) - If (SHOW) Call HssPrt(Temp,nHess) - Call DaXpY_(nHess,One,Temp,1,Hess,1) - If (Show) Call HssPrt(Hess,nHess) - End If - If (lGrd) Then - Call mma_allocate(GradN,nGrad,Label='GradN') - Call DrvN1_mck(GradN,nGrad) - iopt=0 - irc=-1 - Call dWrMCK(iRC,iOpt,'NUCGRAD',1,GradN,1) - If (irc.ne.0) Call SysAbendMsg('mckinley','Error in writing', - & 'Option=NUCGRAD') - Call mma_deallocate(GradN) - End If -* * -************************************************************************ -* * -* Calculate the first order derivatives of the one electron * -* integrals and store on disc in file MCKINT * -* * -************************************************************************ -* * - If (iPrint.ge.6) Then - Write(6,*) - Write(6,'(A,A)') - & 'The 1st order derivatives of the one-electron ', - & 'integrals are calculated and stored on disk' - Write(6,*) - End If - Call Drvh1_mck(nGrad,Nona) -* -************************************************************************ -* * -* Calculate two electron integrals. First order is contracted * -* to Fock matrixes and MO (IJKl) on the fly. Second order * -* derivatives are contracted with P. * -* Derivatives are stored in MCKINT. * -* * -************************************************************************ -* * - nhess=ngrad*(ngrad+1)/2 - Call Timing(dum1,Time,dum2,dum3) - CPUStat(nOneel)=CPUStat(nOneel)+Time - If (.Not.Onenly) Then -* - nIsh(:)=0 - nAsh(:)=0 -* - Call PrepP() -* - iOpt = 0 - iRC = -1 - Call iWrMck(iRC,iOpt,'NISH',1,nIsh,iDummer) - If (iRC.ne.0) Then - Write (6,*) 'Mckinley: Error writing to MckInt!' - Call Abend() - End If - iOpt = 0 - iRC = -1 - Call iWrMck(iRC,iOpt,'NASH',1,nAsh,iDummer) - If (iRC.ne.0) Then - Write (6,*) 'Mckinley: Error writing to MckInt!' - Call Abend() - End If -* -* - - Call Drvg2(Temp,nhess, lGrd,lHss) -* - Call CloseP -* - If (lHss) Then - Call GADSum(Temp,nHess) - Call DScal_(nHess,Half,Temp,1) - If (Show) Call HssPrt(Temp,nHess) -* -*----------- Accumulate contribution to the hessian! -* - Call DaXpY_(nhess,One,Temp,1,Hess,1) -* - If (Show) Then - Call Banner('Complete static Hessian',1,23) - Call HssPrt(Hess,nHess) - End If - Call WrHDsk(Hess,ngrad) - End If -* - End If -* * -************************************************************************ -* * -*... Close 'MCKINT' file - iRc=-1 - iOpt=0 - Call ClsMck(iRC,iOpt) - If ( iRc.ne.0 ) Then - Write (6,*) 'McKinley: Error closing MCKINT!' - Call Abend() - End If - Call mma_deallocate(Temp) - Call mma_deallocate(Hess) -* - Call ClsSew -* * -************************************************************************ -* * -* Epilogue -* - Lines='All data is written to disk, and could be accessed '// - & 'through the MCLR or RASSI program.' - lLine=Len(Lines) - Call Banner(Lines,1,lLine) -* - Call CWTime(TCpu2,TWall2) - Call SavTim(5,TCpu2-TCpu1,TWall2-TWall1) -* - Call Timing(Time,dum,dum,dum) - CPUStat(nTotal)=Time - If (iPrint.ge.6) Call Sttstc - If (Test) Then - ireturn=_RC_INPUT_ERROR_ - Else - Call Request_MCLR_Run(Run_MCLR,ireturn,iPrint) - End If -* - Return - End - Subroutine Request_MCLR_Run(Run_MCLR,ireturn,iPrint) - Logical Run_MCLR - Character*16 StdIn -#include "warnings.h" -* - If (Run_MCLR) Then -* -* McKinley will automatically generate the input for MCLR -* and signal to AUTO (iRC=2) to run the input file Stdin.x. -* - If (iPrint.ge.6) Then - Write (6,*) - Write (6,*) - & ' McKinley requests the MCLR module to be executed!' - Write (6,*) - End If -* - LuInput=11 - LuInput=IsFreeUnit(LuInput) - Call StdIn_Name(StdIn) - Call Molcas_Open(LuInput,StdIn) - Write (LuInput,'(A)') ' &MCLR &End' - Write (LuInput,'(A)') 'End of Input' - Close(LuInput) - ireturn=_RC_INVOKED_OTHER_MODULE_ - Else - ireturn=_RC_ALL_IS_WELL_ - End if -* - Return -* - Write (6,*) - Write (6,*) ' Error opening Stdin.x' - Write (6,*) - Call Quit(_RC_INPUT_EMIL_ERROR_) -* - End diff -Nru openmolcas-22.02/src/mckinley/mckinley.F90 openmolcas-22.10/src/mckinley/mckinley.F90 --- openmolcas-22.02/src/mckinley/mckinley.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/mckinley.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,290 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1989-1992, Roland Lindh * +! 1990, IBM * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine McKinley(ireturn) +!*********************************************************************** +! * +! Object: Driver for the one and two electron integral second order * +! derivative program McKinley. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! July '89 - May '90 * +! * +! Roland Lindh, Dept. of Theoretical Chemistry, University of * +! Lund, SWEDEN. Modified to gradient calculations September * +! 1991 - February 1992. * +! * +! Anders Bernhardsson, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN. * +! Modified to second order derivatives October '94 - * +! '95 * +!*********************************************************************** + +use McKinley_global, only: CPUStat, lGrd, lHss, Nona, nOneel, nTotal +use Index_Functions, only: nTri_Elem +use Basis_Info, only: dbsc, nCnttp +use Gateway_global, only: Onenly, Test +use Symmetry_Info, only: nIrrep +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, Half +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(out) :: ireturn +#include "Molcas.fh" +#include "disp.fh" +#include "print.fh" +#include "etwas.fh" +#include "rctfld.fh" +#include "warnings.h" +integer(kind=iwp) :: i, iCnttp, iDummer, iopt, iPrint, irc, iRout, lLine, nDiff, nGrad, nHess, nsAtom +real(kind=wp) :: dum1, dum2, dum3, TCpu1, TCpu2, Time, TWall1, TWall2 +character(len=120) :: Lines +logical(kind=iwp) :: DoRys, Run_MCLR +real(kind=wp), allocatable :: GradN(:), Hess(:), Temp(:) +!integer(kind=iwp), parameter :: nLines = 12 + +! * +!*********************************************************************** +! * +!call McKinley_banner() +call CWTime(TCpu1,TWall1) +iRout = 1 +CpuStat(:) = Zero +! * +!*********************************************************************** +! * +! Print program header +! * +!*********************************************************************** +! * +!Lines(1) = _MOLCAS_VERSION_ +!#ifdef _DEMO_ +!Lines(2) = 'DEMO VERSION' +!#else +!Lines(2) = ' ' +!#endif +!Lines(3) = ' ' +!Lines(4) = Vrsn +!Lines(5) = 'A Vectorized Direct Integral Program for derivatives' +!Lines(6) = 'of Cartesian and Spherical Harmonic Gaussians' +!Lines(7) = 'Written by Anders Bernhardsson and Roland Lindh ' +!Lines(8) = 'Backtransformation of the 2nd order density matrix from MO to SO by Per-AAke Malmqvist' +!Lines(9) = 'Dept. of Theoretical Chemistry, Chemical Centre, Lund (Sweden)' +!Lines(10) = ' ' +!Lines(11) = ' ' +!Lines(12) = 'Compiled at '//_BUILD_DATE_ +!lLine = Len(Lines(1)) +!call Banner(Lines,nLines,lLine) +! * +!*********************************************************************** +! * +! Set error conditions +! +!call XuFlow() +!Call ErrSet(209,1,1,2,1,209) +! * +!*********************************************************************** +! * +! Check if a numerical procedure will be used +! +call SuperMac() +! * +!*********************************************************************** +! * +! Get the input information as Seward dumped on INFO. +! Set up some info +! Read input + +nDiff = 2 +DoRys = .true. +call IniSew(DoRys,nDiff) +! pcm_solvent +! check if there is a reaction field +!write(u6,*) 'In mckinley PCM',pcm +call Init_RctFld(.false.,iCharge_ref) +! pcm_solvent end +nsAtom = 0 +do iCnttp=1,nCnttp + nsAtom = nsAtom+dbsc(iCnttp)%nCntr +end do +call Inputh(Run_MCLR) +iPrint = nPrint(iRout) +nGrad = 0 +do i=0,nIrrep-1 + nGrad = nGrad+lDisp(i) +end do +call OpnFls_Mckinley() +! * +!*********************************************************************** +! * +! Allocate area for hessian etc + +nHess = nTri_Elem(nGrad) + +call mma_allocate(Hess,nHess,Label='Hess') +Hess(:) = Zero +call mma_allocate(Temp,nHess,Label='Temp') +Temp(:) = Zero +! * +!*********************************************************************** +! * +! Calculate the second order derivatives of the one electron * +! integrals and contract with D. * +! * +!*********************************************************************** +! * +if (lHss) then + if (iPrint >= 6) then + write(u6,*) + write(u6,'(A)') 'The 2nd order derivatives of the one-electron integrals are calculated and contracted with the '// & + 'one-electron density matrix. ' + write(u6,*) + end if + call Timing(dum1,Time,dum2,dum3) + call Drvh2(Hess,Temp,nHess,show) + call DrvEtc(nGrad) +end if +! * +!*********************************************************************** +! * +! Compute contribution from the nuclear repulsion. * +! * +!*********************************************************************** +! * +if (lHss) then + call DrvN2(Temp,nGrad) + if (SHOW) call HssPrt(Temp,nHess) + Hess(:) = Hess+Temp + if (Show) call HssPrt(Hess,nHess) +end if +if (lGrd) then + call mma_allocate(GradN,nGrad,Label='GradN') + call DrvN1_mck(GradN,nGrad) + iopt = 0 + irc = -1 + call dWrMCK(iRC,iOpt,'NUCGRAD',1,GradN,1) + if (irc /= 0) call SysAbendMsg('mckinley','Error in writing','Option=NUCGRAD') + call mma_deallocate(GradN) +end if +! * +!*********************************************************************** +! * +! Calculate the first order derivatives of the one electron * +! integrals and store on disc in file MCKINT * +! * +!*********************************************************************** +! * +if (iPrint >= 6) then + write(u6,*) + write(u6,'(A)') 'The 1st order derivatives of the one-electron integrals are calculated and stored on disk' + write(u6,*) +end if +call Drvh1_mck(Nona) +! * +!*********************************************************************** +! * +! Calculate two electron integrals. First order is contracted * +! to Fock matrixes and MO (IJKl) on the fly. Second order * +! derivatives are contracted with P. * +! Derivatives are stored in MCKINT. * +! * +!*********************************************************************** +! * +nhess = nTri_Elem(ngrad) +call Timing(dum1,Time,dum2,dum3) +CPUStat(nOneel) = CPUStat(nOneel)+Time +if (.not. Onenly) then + + nIsh(:) = 0 + nAsh(:) = 0 + + call PrepP() + + iOpt = 0 + iRC = -1 + call iWrMck(iRC,iOpt,'NISH',1,nIsh,iDummer) + if (iRC /= 0) then + write(u6,*) 'Mckinley: Error writing to MckInt!' + call Abend() + end if + iOpt = 0 + iRC = -1 + call iWrMck(iRC,iOpt,'NASH',1,nAsh,iDummer) + if (iRC /= 0) then + write(u6,*) 'Mckinley: Error writing to MckInt!' + call Abend() + end if + + call Drvg2(Temp,nhess,lGrd,lHss) + + call CloseP() + + if (lHss) then + call GADSum(Temp,nHess) + Temp(:) = Half*Temp + if (Show) call HssPrt(Temp,nHess) + + ! Accumulate contribution to the hessian! + + Hess(:) = Hess+Temp + + if (Show) then + call Banner('Complete static Hessian',1,23) + call HssPrt(Hess,nHess) + end if + call WrHDsk(Hess,ngrad) + end if + +end if +! * +!*********************************************************************** +! * +! Close 'MCKINT' file +iRc = -1 +iOpt = 0 +call ClsMck(iRC,iOpt) +if (iRc /= 0) then + write(u6,*) 'McKinley: Error closing MCKINT!' + call Abend() +end if +call mma_deallocate(Temp) +call mma_deallocate(Hess) + +call ClsSew() +! * +!*********************************************************************** +! * +! Epilogue + +Lines = 'All data is written to disk, and could be accessed through the MCLR or RASSI program.' +lLine = len(Lines) +call Banner(Lines,1,lLine) + +call CWTime(TCpu2,TWall2) +call SavTim(5,TCpu2-TCpu1,TWall2-TWall1) + +call Timing(Time,dum1,dum2,dum3) +CPUStat(nTotal) = Time +if (iPrint >= 6) call Sttstc() +if (Test) then + ireturn = _RC_INPUT_ERROR_ +else + call Request_MCLR_Run(Run_MCLR,ireturn,iPrint) +end if + +return + +end subroutine McKinley diff -Nru openmolcas-22.02/src/mckinley/mckinley_global.F90 openmolcas-22.10/src/mckinley/mckinley_global.F90 --- openmolcas-22.02/src/mckinley/mckinley_global.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/mckinley_global.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,30 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +module McKinley_global + +use Definitions, only: wp, iwp + +implicit none +private + +integer(kind=iwp), parameter :: SCF = 1, RASSCF = 2, & + nOneel = 1, nTwoel = 2, nTwoDens = 3, nIntegrals = 4, nScreen = 5, nTrans = 6, nFckAcc = 7, & + nMOTrans = 8, nTotal = 9 +integer(kind=iwp) :: nFck(0:7), nMethod +real(kind=wp) :: CPUStat(nTotal) +logical(kind=iwp) :: lGrd, lHss, Nona, PreScr, sIrrep +integer(kind=iwp), allocatable :: ipDisp(:), ipDisp2(:), ipDisp3(:), ipMO(:) + +public :: CPUStat, ipDisp, ipDisp2, ipDisp3, ipMO, lGrd, lHss, nFck, nFckAcc, nIntegrals, nMethod, nMOTrans, Nona, nOneel, & + nScreen, nTotal, nTrans, nTwoDens, nTwoel, PreScr, RASSCF, SCF, sIrrep + +end module McKinley_global diff -Nru openmolcas-22.02/src/mckinley/mck_interface.F90 openmolcas-22.10/src/mckinley/mck_interface.F90 --- openmolcas-22.02/src/mckinley/mck_interface.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/mck_interface.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,66 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2020, Roland Lindh * +!*********************************************************************** + +module mck_interface + +implicit none +private + +abstract interface + subroutine grd_mck_kernel( & +# define _CALLING_ +# include "grd_mck_interface.fh" + ) + use Index_Functions, only: nTri_Elem1 + use Definitions, only: wp, iwp +# include "grd_mck_interface.fh" + end subroutine grd_mck_kernel + + subroutine hss_kernel( & +# define _CALLING_ +# include "hss_interface.fh" + ) + use Index_Functions, only: nTri_Elem1 + use Definitions, only: wp, iwp +# include "hss_interface.fh" + end subroutine hss_kernel + + subroutine oneel_mck_kernel( & +# define _CALLING_ +# include "1el_mck_interface.fh" + ) + use Definitions, only: wp, iwp +# include "1el_mck_interface.fh" + end subroutine oneel_mck_kernel + + subroutine oneeldot_mck_kernel( & +# define _CALLING_ +# include "1eldot_mck_interface.fh" + ) + use Index_Functions, only: nTri_Elem1 + use Definitions, only: wp, iwp +# include "1eldot_mck_interface.fh" + end subroutine oneeldot_mck_kernel + + subroutine mck_mem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + use Definitions, only: iwp +# include "mem_interface.fh" + end subroutine mck_mem +end interface + +public :: grd_mck_kernel, hss_kernel, mck_mem, oneel_mck_kernel, oneeldot_mck_kernel + +end module mck_interface diff -Nru openmolcas-22.02/src/mckinley/mkfck.f openmolcas-22.10/src/mckinley/mkfck.f --- openmolcas-22.02/src/mckinley/mkfck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/mkfck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,86 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine MkFck(iAnga,iCmpa,iCmp, - & Shijij, - & iShll,iShell, - & iBasi,jBasj,kBask,lBasl, - & iAO,iAOst,nOp,jOp, - & Dij,mDij,nDij,ij1,ij2,ij3,ij4, - & Dkl,mDkl,nDkl,kl1,kl2,kl3,kl4, - & Dik,mDik,nDik,ik1,ik2,ik3,ik4, - & Dil,mDil,nDil,il1,il2,il3,il4, - & Djk,mDjk,nDjk,jk1,jk2,jk3,jk4, - & Djl,mDjl,nDjl,jl1,jl2,jl3,jl4, - & AOInt,nAO,TwoHam,nFock, - & Scrtch1,nS1,Scrtch2,nS2, - & iDCRR,iDCRS,iDCRT,FckTmp,nFT, - & pert,iuvwx,iCent,iCar,indgrd,ipDisp) -* -************************************************************************ -* * -* Object: Driver for the generation of the two electron contribution * -* to the Fock Matrix directly from the two electron integrals. * -* * -* Author: Anders Bernhardsson 1995 * -************************************************************************ - use Real_Spherical - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "real.fh" -#include "disp.fh" -#include "disp2.fh" -* - Real*8 Dij(mDij,nDij),Dkl(mDkl,nDkl),Dik(mDik,nDik), - & Dil(mDil,nDil),Djk(mDjk,nDjk),Djl(mDjl,nDjl), - & FckTmp(nFT),AOInt(nAO),TwoHam(nFock), - & Scrtch1(nS1),Scrtch2(nS2) - Integer iCmp(4), nOp(4),iAnga(4), iShll(4),iShell(4), - & jOp(6),iCmpa(4) , iAO(4), iAOst(4), - & indgrd(3,4,0:7),ipdisp(*) - Logical Shijij,pert(0:7) -* -* Just the make a nice interface -* -c iRout = 12 -c iPrint = nPrint(iRout) - nijkl=iBasi*jBasj*kBask*lBasl -* -*--------------Accumulate contributions directly to the symmetry -* adapted Fock matrix. -* - Fact=DBLE(iuvwx)/DBLE(nIrrep) -* - Call FckAcc_mck(iAnga,iCmp(1),iCmp(2),iCmp(3),iCmp(4), - & Shijij,iShll,iShell,nOp,nijkl, - & AOInt,TwoHam,nFock,Scrtch2,nS2, - & iAO,iAOst, - & iBasi,jBasj,kBask,lBasl, - & Dij(1,jOp(1)),ij1,ij2,ij3,ij4, - & Dkl(1,jOp(2)),kl1,kl2,kl3,kl4, - & Dik(1,jOp(3)),ik1,ik2,ik3,ik4, - & Dil(1,jOp(4)),il1,il2,il3,il4, - & Djk(1,jOp(5)),jk1,jk2,jk3,jk4, - & Djl(1,jOp(6)),jl1,jl2,jl3,jl4, - & FckTmp,nFT,fact,iCar,iCent,pert,indgrd,ipdisp) -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer_array(iCmpa) - Call Unused_real_array(Scrtch1) - Call Unused_integer(iDCRR) - Call Unused_integer(iDCRS) - Call Unused_integer(iDCRT) - End If - End diff -Nru openmolcas-22.02/src/mckinley/mkfck.F90 openmolcas-22.10/src/mckinley/mkfck.F90 --- openmolcas-22.02/src/mckinley/mkfck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/mkfck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,58 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine MkFck(iAnga,iCmp,Shijij,iShll,iShell,iBasi,jBasj,kBask,lBasl,iAO,iAOst,nOp,jOp,Dij,mDij,nDij,ij1,ij2,ij3,ij4,Dkl,mDkl, & + nDkl,kl1,kl2,kl3,kl4,Dik,mDik,nDik,ik1,ik2,ik3,ik4,Dil,mDil,nDil,il1,il2,il3,il4,Djk,mDjk,nDjk,jk1,jk2,jk3,jk4, & + Djl,mDjl,nDjl,jl1,jl2,jl3,jl4,AOInt,nAO,TwoHam,nFock,Scrtch2,nS2,FckTmp,nFT,pert,iuvwx,iCent,iCar,indgrd,ipDisp) +!*********************************************************************** +! * +! Object: Driver for the generation of the two electron contribution * +! to the Fock Matrix directly from the two electron integrals. * +! * +! Author: Anders Bernhardsson 1995 * +!*********************************************************************** + +use Symmetry_Info, only: nIrrep +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iAnga(4), iCmp(4), iShll(4), iShell(4), iBasi, jBasj, kBask, lBasl, iAO(4), iAOst(4), nOp(4), & + jOp(6), mDij, nDij, ij1, ij2, ij3, ij4, mDkl, nDkl, kl1, kl2, kl3, kl4, mDik, nDik, ik1, ik2, & + ik3, ik4, mDil, nDil, il1, il2, il3, il4, mDjk, nDjk, jk1, jk2, jk3, jk4, mDjl, nDjl, jl1, jl2, & + jl3, jl4, nAO, nFock, nS2, nFT, iuvwx, iCent, iCar, indgrd(3,4,0:7), ipdisp(*) +logical(kind=iwp), intent(in) :: Shijij, pert(0:7) +real(kind=wp), intent(in) :: Dij(mDij,nDij), Dkl(mDkl,nDkl), Dik(mDik,nDik), Dil(mDil,nDil), Djk(mDjk,nDjk), Djl(mDjl,nDjl), & + AOInt(nAO) +real(kind=wp), intent(inout) :: TwoHam(nFock) +real(kind=wp), intent(out) :: Scrtch2(nS2), FckTmp(nFT) +integer(kind=iwp) :: nijkl +real(kind=wp) :: Fact + +! Just to make a nice interface + +!iRout = 12 +!iPrint = nPrint(iRout) +nijkl = iBasi*jBasj*kBask*lBasl + +! Accumulate contributions directly to the symmetry adapted Fock matrix. + +Fact = real(iuvwx,kind=wp)/real(nIrrep,kind=wp) + +call FckAcc_mck(iAnga,iCmp(1),iCmp(2),iCmp(3),iCmp(4),Shijij,iShll,iShell,nOp,nijkl,AOInt,TwoHam,nFock,Scrtch2,nS2,iAO,iAOst, & + iBasi,jBasj,kBask,lBasl,Dij(1,jOp(1)),ij1,ij2,ij3,ij4,Dkl(1,jOp(2)),kl1,kl2,kl3,kl4,Dik(1,jOp(3)),ik1,ik2,ik3,ik4, & + Dil(1,jOp(4)),il1,il2,il3,il4,Djk(1,jOp(5)),jk1,jk2,jk3,jk4,Djl(1,jOp(6)),jl1,jl2,jl3,jl4,FckTmp,nFT,fact,iCar, & + iCent,pert,indgrd,ipdisp) + +return + +end subroutine MkFck diff -Nru openmolcas-22.02/src/mckinley/moacc.f openmolcas-22.10/src/mckinley/moacc.f --- openmolcas-22.02/src/mckinley/moacc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/moacc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,226 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1996, Anders Bernhardsson * -************************************************************************ - SubRoutine MOAcc(AOInt,nint,Temp1,Temp2,Temp3,nTemp, - & MOInt,nMO,ishell, - & Ci,nCi,Cj,nCj,Ck,nCk,Cl,nCl,moip,nACO,pert,nOp, - & iBasa,iCmpa,icar,icnt,indgrd,D,fact,iao,iaost, - & Buffer,Tempi,nij,nkl,nbasi,nbasj,icmp,jcmp) -************************************************************************ -* * -* Transforms a batch of unsymmetrized integrals to * -* active integral batches and FM * -* All MO combinations are constructed * -* They will be needed with unsymmetric perurbations * -* * -* Author: Anders Bernhardsson, Dept. of Theoretical Chemistry, * -* University of Lund, Sweden. Januar '96 * -************************************************************************ - use Symmetry_Info, only: nIrrep, iChTbl, iOper - use Gateway_Info, only: CutInt - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "etwas.fh" -c#include "print.fh" - Real*8 AOInt(nkl,nij),MOint(nMO), - & Temp1(nTemp),Temp2(naco,naco), - & Ck(nCk),Cl(nCl),D(*), - & Buffer(nbasi,icmp,nbasj,jcmp,0:nirrep-1, - & nAco*(naco+1)/2,*) - Integer moip(0:7),nOp(4), - & ishell(4),iao(4),iAOST(4), - & ibasa(4),icmpa(4),indgrd(3,4,0:7) - Logical pert(0:7) - Real*8 Prmt(0:7) - - Data Prmt/1.d0,-1.d0,-1.d0,1.d0,-1.d0,1.d0,1.d0,-1.d0/ - -* -* Statement Function -* - xPrmt(i,j) = Prmt(iAnd(i,j)) -* - iCB=2**(icar-1) - rFact=xPrmt(ioper(nOp(icnt)),icb)*fact -* - iBas=iBasa(1) - jBas=iBasa(2) - kBas=iBasa(3) - lBas=iBasa(4) -* - kCmp=iCmpa(3) - lCmp=iCmpa(4) - kk=0 - Do kIrrep=0,nIrrep-1 - sfact=DBLE(ichtbl(kirrep,nop(3))) - Do kAsh=1,nAsh(kIrrep) - Do k=1,kcmp*kbas - kk=kk+1 - Ck(kk)=Ck(kk)*sFact - End Do - End Do - End Do - kk=0 - Do kIrrep=0,nIrrep-1 - sfact=DBLE(ichtbl(kirrep,nop(4))) - Do kAsh=1,nAsh(kIrrep) - Do k=1,lcmp*lbas - kk=kk+1 - Cl(kk)=Cl(kk)*sFact - End Do - End Do - End Do - rk = DNrm2_(nck,ck,1) - rl = DNrm2_(ncl,cl,1) - ij=0 - nt=lBas*lCmp*kcmp*kbas - Do jc=1,jcmp - Do jb=1+iaost(2),iaost(2)+jbas - Do ic=1,icmp - Do ib=1+iaost(1),iaost(1)+ibas -* - ij=ij+1 - vij = DNrm2_(nt,AOInt(1,ij),1) - If (Abs(vij*rk*rl).lt.cutint) goto 1000 - ipC=0 - Do kAsh=1,nAco - ipM=(kAsh-1)*lbas*lcmp - il=0 - Do i=1,lbas*lcmp - Temp1(i+ipM)=0.0d0 - Do k=1,kCmp*kBas - il=il+1 - Temp1(i+ipM)=Temp1(ipm+i)+Ck(k+ipc)*AOINT(il,ij) - End Do - End Do - ipC=ipC+kBas*kCmp - End Do - ipC=0 - Do lAsh=1,naco - il=0 - Do kash=1,naco - Temp2(kash,lash)=0.0d0 - Do l=1,lbas*lcmp - il=il+1 - Temp2(kash,lash)=Temp2(kash,lash)+ - & Cl(ipc+l)*Temp1(il) - End Do - End Do - ipC=ipC+lBas*lCmp - End Do -* - If (iShell(3).ne.ishell(4)) Then - - do iSPert=0,nIrrep-1 - If (pert(isPert)) Then - rFact2=rFact*DBLE(iChtbl(ispert,nop(icnt))) - k=abs(indgrd(icar,icnt,ispert)) - j=0 - Do lIrr=0,nIrrep-1 - Do lAsh=1,nAsh(lIrr) - Do kIrr=0,lIrr - irest=iEOR(iEOR(ioper(ispert),ioper(kirr)),ioper(lirr)) - kMax=nAsh(kIrr) - If (kIrr.eq.lIrr) kMax=lAsh - Do kAsh=1,kMax - kk=kash+moip(kirr) - ll=lash+moip(lirr) - j=j+1 - Do jIrr=0,nIrrep-1 - rPj=DBLE(iChTbl(jIrr,nop(2))) - iirr=nropr(ieor(iOPER(jirr),irest)) - rPij=rPj*DBLE(iChTbl(iIrr,nop(1)))*rfact2 - buffer(ib,ic,jb,jc,iirr,j,k)= - & buffer(ib,ic,jb,jc,iirr,j,k)+ - & rpij*Temp2(kk,ll)+ - & rpij*Temp2(ll,kk) - End Do - End Do - End Do - End Do - End Do - End If - End Do - Else -* - do iSPert=0,nIrrep-1 - If (pert(isPert)) Then - rFact2=rFact*DBLE(iChtbl(ispert,nop(icnt))) - k=abs(indgrd(icar,icnt,ispert)) - j=0 - Do lIrr=0,nIrrep-1 - Do lAsh=1,nAsh(lIrr) - Do kIrr=0,lIrr - irest=iEOR(iEOR(ioper(ispert),ioper(kirr)),ioper(lirr)) - kMax=nAsh(kIrr) - If (kIrr.eq.lIrr) kMax=lAsh - Do kAsh=1,kMax - kk=kash+moip(kirr) - ll=lash+moip(lirr) - j=j+1 - Do jIrr=0,nIrrep-1 - rPj=DBLE(iChTbl(jIrr,nop(2))) - iirr=nropr(ieor(iOPER(jirr),irest)) - rPij=rPj*DBLE(iChTbl(iIrr,nop(1)))*rfact2 - buffer(ib,ic,jb,jc,iirr,j,k)= - & buffer(ib,ic,jb,jc,iirr,j,k)+ - & rpij*Temp2(kk,ll) - End Do - End Do - End Do - End Do - End Do - End If - End Do - End if - 1000 Continue - End Do - End Do - End Do - End Do -* - kk=0 - Do kIrrep=0,nIrrep-1 - sfact=DBLE(ichtbl(kirrep,nop(3))) - Do kAsh=1,nAsh(kIrrep) - Do k=1,kcmp*kbas - kk=kk+1 - Ck(kk)=Ck(kk)*sFact - End Do - End Do - End Do - kk=0 - Do kIrrep=0,nIrrep-1 - sfact=DBLE(ichtbl(kirrep,nop(4))) - Do kAsh=1,nAsh(kIrrep) - Do k=1,lcmp*lbas - kk=kk+1 - Cl(kk)=Cl(kk)*sFact - End Do - End Do - End Do - - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(nint) - Call Unused_real(Temp3) - Call Unused_real_array(MOInt) - Call Unused_real(Ci) - Call Unused_integer(nCi) - Call Unused_real(Cj) - Call Unused_integer(nCj) - Call Unused_real_array(D) - Call Unused_integer_array(iao) - Call Unused_real(Tempi) - End If - End diff -Nru openmolcas-22.02/src/mckinley/moacc.F90 openmolcas-22.10/src/mckinley/moacc.F90 --- openmolcas-22.02/src/mckinley/moacc.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/moacc.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,186 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1996, Anders Bernhardsson * +!*********************************************************************** + +subroutine MOAcc(AOInt,Temp1,Temp2,nTemp,ishell,Ck,nCk,Cl,nCl,moip,nACO,pert,nOp,iBasa,iCmpa,icar,icnt,indgrd,fact,iaost,Buffer, & + nij,nkl,nbasi,nbasj,icmp,jcmp) +!*********************************************************************** +! * +! Transforms a batch of unsymmetrized integrals to * +! active integral batches and FM * +! All MO combinations are constructed * +! They will be needed with unsymmetric perurbations * +! * +! Author: Anders Bernhardsson, Dept. of Theoretical Chemistry, * +! University of Lund, Sweden. Januar '96 * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem +use Symmetry_Info, only: iChTbl, iOper, nIrrep, Prmt +use Gateway_Info, only: CutInt +use Constants, only: Zero +use Definitions, only: wp, iwp, r8 + +implicit none +integer(kind=iwp), intent(in) :: nTemp, ishell(4), nCk, nCl, moip(0:7), nACO, nOp(4), ibasa(4), icmpa(4), icar, icnt, & + indgrd(3,4,0:7), iAOST(4), nij, nkl, nbasi, nbasj, icmp, jcmp +real(kind=wp), intent(in) :: AOInt(nkl,nij), fact +real(kind=wp), intent(out) :: Temp1(nTemp), Temp2(naco,naco) +real(kind=wp), intent(inout) :: Ck(nCk), Cl(nCl), Buffer(nbasi,icmp,nbasj,jcmp,0:nirrep-1,nTri_Elem(naco),*) +logical(kind=iwp), intent(in) :: pert(0:7) +#include "etwas.fh" +integer(kind=iwp) :: i, ib, iBas, ic, iCB, iirr, ij, il, ipC, ipM, irest, iSPert, j, jb, jBas, jc, jIrr, k, kAsh, kBas, kCmp, & + kIrr, kIrrep, kk, kMax, l, lAsh, lBas, lCmp, lIrr, ll, nt +real(kind=wp) :: rFact, rFact2, rk, rl, rPij, rPj, sfact, vij +integer(kind=iwp), external :: NrOpr +real(kind=r8), external :: DNrm2_ + +iCB = 2**(icar-1) +rFact = Prmt(ioper(nOp(icnt)),icb)*fact + +iBas = iBasa(1) +jBas = iBasa(2) +kBas = iBasa(3) +lBas = iBasa(4) + +kCmp = iCmpa(3) +lCmp = iCmpa(4) +kk = 0 +do kIrrep=0,nIrrep-1 + sfact = real(ichtbl(kirrep,nop(3)),kind=wp) + Ck(kk+1:kk+nAsh(kIrrep)*kcmp*kbas) = Ck(kk+1:kk+nAsh(kIrrep)*kcmp*kbas)*sFact + kk = kk+nAsh(kIrrep)*kcmp*kbas +end do +kk = 0 +do kIrrep=0,nIrrep-1 + sfact = real(ichtbl(kirrep,nop(4)),kind=wp) + Cl(kk+1:kk+nAsh(kIrrep)*lcmp*lbas) = Cl(kk+1:kk+nAsh(kIrrep)*lcmp*lbas)*sFact + kk = kk+nAsh(kIrrep)*lcmp*lbas +end do +rk = DNrm2_(nck,ck,1) +rl = DNrm2_(ncl,cl,1) +ij = 0 +nt = lBas*lCmp*kcmp*kbas +do jc=1,jcmp + do jb=1+iaost(2),iaost(2)+jbas + do ic=1,icmp + do ib=1+iaost(1),iaost(1)+ibas + + ij = ij+1 + vij = DNrm2_(nt,AOInt(1,ij),1) + if (abs(vij*rk*rl) < cutint) cycle + ipC = 0 + Temp1(1:nAco*lbas*lcmp) = Zero + do kAsh=1,nAco + ipM = (kAsh-1)*lbas*lcmp + il = 0 + do i=1,lbas*lcmp + do k=1,kCmp*kBas + il = il+1 + Temp1(ipM+i) = Temp1(ipM+i)+Ck(ipC+k)*AOINT(il,ij) + end do + end do + ipC = ipC+kBas*kCmp + end do + ipC = 0 + Temp2(:,:) = Zero + do lAsh=1,naco + il = 0 + do kash=1,naco + do l=1,lbas*lcmp + il = il+1 + Temp2(kash,lash) = Temp2(kash,lash)+Cl(ipC+l)*Temp1(il) + end do + end do + ipC = ipC+lBas*lCmp + end do + + if (iShell(3) /= ishell(4)) then + + do iSPert=0,nIrrep-1 + if (pert(isPert)) then + rFact2 = rFact*real(iChtbl(ispert,nop(icnt)),kind=wp) + k = abs(indgrd(icar,icnt,ispert)) + j = 0 + do lIrr=0,nIrrep-1 + do lAsh=1,nAsh(lIrr) + do kIrr=0,lIrr + irest = ieor(ieor(ioper(ispert),ioper(kirr)),ioper(lirr)) + kMax = nAsh(kIrr) + if (kIrr == lIrr) kMax = lAsh + do kAsh=1,kMax + kk = kash+moip(kirr) + ll = lash+moip(lirr) + j = j+1 + do jIrr=0,nIrrep-1 + rPj = real(iChTbl(jIrr,nop(2)),kind=wp) + iirr = nropr(ieor(iOPER(jirr),irest)) + rPij = rPj*real(iChTbl(iIrr,nop(1)),kind=wp)*rfact2 + buffer(ib,ic,jb,jc,iirr,j,k) = buffer(ib,ic,jb,jc,iirr,j,k)+rpij*Temp2(kk,ll)+rpij*Temp2(ll,kk) + end do + end do + end do + end do + end do + end if + end do + else + + do iSPert=0,nIrrep-1 + if (pert(isPert)) then + rFact2 = rFact*real(iChtbl(ispert,nop(icnt)),kind=wp) + k = abs(indgrd(icar,icnt,ispert)) + j = 0 + do lIrr=0,nIrrep-1 + do lAsh=1,nAsh(lIrr) + do kIrr=0,lIrr + irest = ieor(ieor(ioper(ispert),ioper(kirr)),ioper(lirr)) + kMax = nAsh(kIrr) + if (kIrr == lIrr) kMax = lAsh + do kAsh=1,kMax + kk = kash+moip(kirr) + ll = lash+moip(lirr) + j = j+1 + do jIrr=0,nIrrep-1 + rPj = real(iChTbl(jIrr,nop(2)),kind=wp) + iirr = nropr(ieor(iOPER(jirr),irest)) + rPij = rPj*real(iChTbl(iIrr,nop(1)),kind=wp)*rfact2 + buffer(ib,ic,jb,jc,iirr,j,k) = buffer(ib,ic,jb,jc,iirr,j,k)+rpij*Temp2(kk,ll) + end do + end do + end do + end do + end do + end if + end do + end if + end do + end do + end do +end do + +kk = 0 +do kIrrep=0,nIrrep-1 + sfact = real(ichtbl(kirrep,nop(3)),kind=wp) + Ck(kk+1:kk+nAsh(kIrrep)*kcmp*kbas) = Ck(kk+1:kk+nAsh(kIrrep)*kcmp*kbas)*sFact + kk = kk+nAsh(kIrrep)*kcmp*kbas +end do +kk = 0 +do kIrrep=0,nIrrep-1 + sfact = real(ichtbl(kirrep,nop(4)),kind=wp) + Cl(kk+1:kk+nAsh(kIrrep)*lcmp*lbas) = Cl(kk+1:kk+nAsh(kIrrep)*lcmp*lbas)*sFact + kk = kk+nAsh(kIrrep)*lcmp*lbas +end do + +return + +end subroutine MOAcc diff -Nru openmolcas-22.02/src/mckinley/mult_sro.f openmolcas-22.10/src/mckinley/mult_sro.f --- openmolcas-22.02/src/mckinley/mult_sro.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/mult_sro.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine mult_sro(A,nA,C,nC,B,nB,Fact,Res,Tmp) - Implicit Real*8(a-h,o-z) - Real*8 A(*),B(*),C(*),Res(*),Tmp(*) - - Call DGEMM_('N','N', nA,nC,nC, - & 1.0d0,A,nA, C,nC, - & 0.0d0,Tmp,nA) - Call DGEMM_('N','N', nA,nB,nC, - & Fact,Tmp,nA, B,nC, - & 1.0d0,Res,nA) - return - end diff -Nru openmolcas-22.02/src/mckinley/mult_sro.F90 openmolcas-22.10/src/mckinley/mult_sro.F90 --- openmolcas-22.02/src/mckinley/mult_sro.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/mult_sro.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,28 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine mult_sro(A,nA,C,nC,B,nB,Fact,Res,Tmp) + +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nA, nC, nB +real(kind=wp), intent(in) :: A(nA,nC), C(nC,nC), B(nC,nB), Fact +real(kind=wp), intent(inout) :: Res(nA,nB) +real(kind=wp), intent(out) :: Tmp(nA,nC) + +call DGEMM_('N','N',nA,nC,nC,One,A,nA,C,nC,Zero,Tmp,nA) +call DGEMM_('N','N',nA,nB,nC,Fact,Tmp,nA,B,nC,One,Res,nA) + +return + +end subroutine mult_sro diff -Nru openmolcas-22.02/src/mckinley/na2mem.f openmolcas-22.10/src/mckinley/na2mem.f --- openmolcas-22.02/src/mckinley/na2mem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/na2mem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine NA2Mem(nHer,MmMltP,la,lb,lr) -* - nElem(i) = (i+1)*(i+2)/2 - -* - lr=0 - nHer=(la+lb+lr+3)/2 - MmMltP = 3*nHer*(la+2) + - & 3*nHer*(lb+2) + - & 3*nHer*(lr+2) + - & 3*(la+2)*(lb+2)*(lr+1)+2 + - & nelem(la)*nelem(lb)*2 -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/na2mem.F90 openmolcas-22.10/src/mckinley/na2mem.F90 --- openmolcas-22.02/src/mckinley/na2mem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/na2mem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,33 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine NA2Mem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: lr_ + +#include "macros.fh" +unused_var(lr) + +lr_ = 0 +nHer = (la+lb+lr_+3)/2 +Mem = 3*nHer*(la+2)+3*nHer*(lb+2)+3*nHer*(lr_+2)+3*(la+2)*(lb+2)*(lr_+1)+2+nTri_Elem1(la)*nTri_Elem1(lb)*2 + +return + +end subroutine NA2Mem diff -Nru openmolcas-22.02/src/mckinley/nagrd_mck.f openmolcas-22.10/src/mckinley/nagrd_mck.f --- openmolcas-22.02/src/mckinley/nagrd_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/nagrd_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,236 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -* 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine NAGrd_mck( -#define _CALLING_ -#include "grd_mck_interface.fh" - & ) -************************************************************************ -* * -* Object: to compute the gradient of the nuclear attraction integrals. * -* Something is wrong here * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -* October 1991 * -* Anders Bernhardsson 1995 * -************************************************************************ - use Basis_Info - use Center_Info - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) - External TNAI1, Fake, Cff2D -#include "Molcas.fh" -#include "real.fh" -#include "disp.fh" -#include "disp2.fh" - -#include "grd_mck_interface.fh" - -* Local variables - Integer iDCRT(0:7),Index(3,4) - Real*8 C(3), TC(3) - Logical DiffCnt, EQ, Tr(4) - Real*8 Coora(3,4), Coori(3,4), CoorAC(3,2) - Integer iAnga(4), JndGrd(3,4,0:7), mOp(4), iuvwx(4), - & JndHss(4,3,4,3,0:7), kndgrd(3,4,0:7) - Logical JfGrd(3,4),kfgrd(3,4),jfg(4), JfHss(4,3,4,3) - Integer, Parameter:: nPAO=1 - Real*8 :: PAO(nPAO) ! Dummy array - Integer, Parameter:: nHess=1 - Real*8 :: Hess(nHess) ! Dummy array -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* -c iRout = 150 -c iPrint = nPrint(iRout) -* -c If (iPrint.ge.99) Then -c Write (*,*) ' In NAGrd: nArr=',nArr -c End If -* - nRys=nHer -* - nip = 1 - ipA = nip - nip = nip + nAlpha*nBeta - ipB = nip - nip = nip + nAlpha*nBeta - If (nip-1.gt.nArr) - & Write (6,*) ' nip-1.gt.nArr' - nArray = nArr - nip +1 -* - iIrrep = 0 - iAnga(1) = la - iAnga(2) = lb - iAnga(3) = 0 - iAnga(4) = 0 -* Dummies - Call ICopy(144*nIrrep,[0],0,JndHss,1) - Call LCopy(144,[.false.],0,jfHss,1) -* - call dcopy_(3,A,1,Coora(1,1),1) - call dcopy_(3,RB,1,Coora(1,2),1) - call dcopy_(3,A,1,Coori(1,1),1) - call dcopy_(3,RB,1,Coori(1,2),1) - If (la.ge.lb) Then - call dcopy_(3,A,1,CoorAC(1,1),1) - Else - call dcopy_(3,RB,1,CoorAC(1,1),1) - End If - iuvwx(1) = iu - iuvwx(2) = iv - mOp(1) = nOp(1) - mOp(2) = nOp(2) -* - ipAOff = ipA - Do 200 iBeta = 1, nBeta - call dcopy_(nAlpha,Alpha,1,Array(ipAOff),1) - ipAOff = ipAOff + nAlpha - 200 Continue -* - ipBOff = ipB - Do 210 iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ipBOff),nAlpha) - ipBOff = ipBOff + 1 - 210 Continue -* -*-----Loop over nuclear centers -* - nb=nZeta*nElem(la)*nElem(lb) - kdc = 0 - Do 100 kCnttp = 1, nCnttp - If (kCnttp==iCnttp_Dummy) Go To 111 - If (dbsc(kCnttp)%Charge.eq.Zero) Go To 111 - Do 101 kCnt = 1, dbsc(kCnttp)%nCntr - C(1:3)=dbsc(kCnttp)%Coor(1:3,kCnt) - DiffCnt=(IfGrad(iDCar,1).or.IfGrad(iDCar,2)) - If ((.not.DiffCnt).and.((kdc+kCnt).ne.iDCnt)) Goto 101 -* - Call DCR(LmbdT,iStabM,nStabM, - & dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) -* Fact = -dbsc(kCnttp)%Charge*DBLE(nStabM*nIrrep) / -* & DBLE(LmbdT*dc(kdc+kCnt)%nStab) - Fact = -dbsc(kCnttp)%Charge*DBLE(nStabM) / - & DBLE(LmbdT) -c If (iPrint.ge.99) Then -c Write (*,*) ' Charge=',dbsc(kCnttp)%Charge -c write(*,*) 'NZeta=',nzeta -c Write(*,*) 'NrOp=',nrop -c Write (*,*) ' Fact=',Fact -c End If - iuvwx(3) = dc(kdc+kCnt)%nStab - iuvwx(4) = dc(kdc+kCnt)%nStab - Call LCopy(12,[.false.],0,JFgrd,1) - Call ICopy(12*nIrrep,[0],0,jndGrd,1) - Do iCnt = 1, 2 - JfGrd(iDCar,iCnt) = IfGrad(iDCar,iCnt) - End Do - Do ICnt=1,2 - If (IfGrad(idcar,iCnt)) Then - Do iIrrep=0,nIrrep-1 - jndGrd(iDCar,iCnt,iIrrep)=IndGrd(iIrrep) - End Do - End IF - End Do -* - Tr(1)=.false. - Tr(2)=.false. - Tr(3)=.false. - Tr(4)=.false. - If ((kdc+kCnt).eq.iDCnt) Then - Tr(3)=.true. - JfGrd(iDCar,1) = .true. - JfGrd(iDCar,2) = .true. - Do iIrrep=0,nIrrep-1 - jndGrd(iDCar,3,iIrrep) = - IndGrd(iIrrep) - End Do - End If -* - Do 102 lDCRT = 0, nDCRT-1 - Call lCopy(12,JfGrd,1,kfGrd,1) - Call iCopy(12*nIrrep,JndGrd,1,kndgrd,1) - mOp(3) = NrOpr(iDCRT(lDCRT)) - mOp(4) = mOp(3) - Call OA(iDCRT(lDCRT),C,TC) - call dcopy_(3,TC,1,CoorAC(1,2),1) - call dcopy_(3,TC,1,Coora(1,3),1) - call dcopy_(3,TC,1,Coora(1,4),1) - call dcopy_(3,TC,1,Coori(1,3),1) - call dcopy_(3,TC,1,Coori(1,4),1) - If (Eq(A,RB).and.EQ(A,TC)) goto 102 - If (EQ(A,TC)) Then - kfGrd(iDCar,1) = .false. - Do iIrrep=0,nIrrep-1 - kndGrd(iDCar,1,iirrep)=0 - End Do - End If - If (EQ(RB,TC)) Then - kfGrd(iDCar,2) = .false. - Do iIrrep=0,nIrrep-1 - kndgrd(iDCar,2,iIrrep)=0 - End Do - End If -* - If (kfGrd(idcar,1)) Then - JFG(1)=.true. - Else - JFG(1)=.false. - End If - If (kfGrd(idcar,2)) Then - JFG(2)=.true. - Else - JFG(2)=.false. - End If - JFG(3)=.false. - JFG(4)=.false. - Call Rysg2(iAnga,nRys,nZeta, - & Array(ipA),Array(ipB),[One],[One], - & Zeta,ZInv,nZeta,[One],[One],1, - & P,nZeta,TC,1,Coori,Coora,CoorAC, - & Array(nip),nArray, - & TNAI1,Fake,Cff2D, - & PAO,nPAO,Hess,nHess,kfGrd,kndGrd, - & JfHss,JndHss,mOp,iuvwx,Jfg, - & nGr,Index,.true.,.false.,tr) -* - Do iElem = 1, nElem(la)*nElem(lb)*ngr - Do iZeta = 1, nZeta - tfac = Two*rKappa(iZeta)*Pi*ZInv(iZeta) - indi=(iElem-1)*nZeta+iZeta - Array(nip+indi-1) = tfac * Array(nip+indi-1) - End Do - End Do -* -#ifdef _DEBUGPRINT_ - Call RecPrt('In NaGrd PI',' ',Array(nip),nb,3) - Call RecPrt('In NaGrd PI',' ',Final,nb,nrOp) -#endif - Call SmAdNa(Array(nip),nb,Final, - & mop,loper,KndGrd,iuvwx,kfGrd,Index, - & idcar,Fact,JFG,tr) -c IF (iPrint.gt.23) -c & Call RecPrt('In NaGrd FI',' ',Final,nb,nrOp) - 102 Continue - 101 Continue - 111 kdc = kdc + dbsc(kCnttp)%nCntr - 100 Continue -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Ccoor) - Call Unused_integer(nOrdOp) - Call Unused_logical_array(Trans) - End If - End diff -Nru openmolcas-22.02/src/mckinley/nagrd_mck.F90 openmolcas-22.10/src/mckinley/nagrd_mck.F90 --- openmolcas-22.02/src/mckinley/nagrd_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/nagrd_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,200 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine NAGrd_mck( & +# define _CALLING_ +# include "grd_mck_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the gradient of the nuclear attraction integrals. * +! Something is wrong here * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +! October 1991 * +! Anders Bernhardsson 1995 * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Basis_Info, only: dbsc, iCnttp_Dummy, nCnttp +use Center_Info, only: dc +use Symmetry_Info, only: nIrrep +use Constants, only: Zero, One, Two, Pi +use Definitions, only: wp, iwp, u6 + +implicit none +#include "grd_mck_interface.fh" +integer(kind=iwp), parameter :: nHess = 1, nPAO = 1 ! Hess, PAO: Dummy arrays +integer(kind=iwp) :: iAnga(4), iBeta, iCnt, iDCRT(0:7), iElem, indi, Indx(3,4), ipA, ipAOff, ipB, ipBOff, iuvwx(4), & + JndGrd(3,4,0:7), JndHss(4,3,4,3,0:7), kCnt, kCnttp, kdc, kndgrd(3,4,0:7), lDCRT, LmbdT, mOp(4), nArray, nb, & + nDCRT, nGr, nip, nRys +real(kind=wp) :: C(3), Coora(3,4), CoorAC(3,2), Coori(3,4), Fact, Hess(nHess), PAO(nPAO), TC(3) +logical(kind=iwp) :: DiffCnt, jfg(4), JfGrd(3,4), JfHss(4,3,4,3), kfgrd(3,4), Tr(4) +integer(kind=iwp), external :: NrOpr +logical(kind=iwp), external :: EQ +external :: Cff2D, Fake, TNAI1 + +#include "macros.fh" +unused_var(Ccoor) +unused_var(nOrdOp) +unused_var(Trans) + +!iRout = 150 +!iPrint = nPrint(iRout) + +!if (iPrint >= 99) then +! write(u6,*) ' In NAGrd_McK: nArr=',nArr +!end if + +nRys = nHer + +nip = 1 +ipA = nip +nip = nip+nAlpha*nBeta +ipB = nip +nip = nip+nAlpha*nBeta +if (nip-1 > nArr) write(u6,*) ' nip-1 > nArr' +nArray = nArr-nip+1 + +iAnga(1) = la +iAnga(2) = lb +iAnga(3) = 0 +iAnga(4) = 0 +! Dummies +JndHss(:,:,:,:,0:nIrrep-1) = 0 +JfHss(:,:,:,:) = .false. + +Coora(:,1) = A +Coora(:,2) = RB +Coori(:,1) = A +Coori(:,2) = RB +if (la >= lb) then + CoorAC(:,1) = A +else + CoorAC(:,1) = RB +end if +iuvwx(1) = iu +iuvwx(2) = iv +mOp(1) = nOp(1) +mOp(2) = nOp(2) + +ipAOff = ipA +do iBeta=1,nBeta + Array(ipAOff:ipAOff+nAlpha-1) = Alpha + ipAOff = ipAOff+nAlpha +end do + +ipBOff = ipB +do iBeta=1,nBeta + Array(ipBOff:ipBOff+nAlpha-1) = Beta(iBeta) + ipBOff = ipBOff+nAlpha +end do + +! Loop over nuclear centers + +nb = nZeta*nTri_Elem1(la)*nTri_Elem1(lb) +kdc = 0 +do kCnttp=1,nCnttp + if (kCnttp > 1) kdc = kdc+dbsc(kCnttp-1)%nCntr + if (kCnttp == iCnttp_Dummy) cycle + if (dbsc(kCnttp)%Charge == Zero) cycle + do kCnt=1,dbsc(kCnttp)%nCntr + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + DiffCnt = (IfGrad(iDCar,1) .or. IfGrad(iDCar,2)) + if ((.not. DiffCnt) .and. (kdc+kCnt /= iDCnt)) cycle + + call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) + !Fact = -dbsc(kCnttp)%Charge*real(nStabM*nIrrep,kind=wp)/real(LmbdT*dc(kdc+kCnt)%nStab,kind=wp) + Fact = -dbsc(kCnttp)%Charge*real(nStabM,kind=wp)/real(LmbdT,kind=wp) + !if (iPrint >= 99) then + ! write(u6,*) ' Charge=',dbsc(kCnttp)%Charge + ! Write(u6,*) 'NZeta=',nzeta + ! write(u6,*) 'NrOp=',nrop + ! write(u6,*) ' Fact=',Fact + !end if + iuvwx(3) = dc(kdc+kCnt)%nStab + iuvwx(4) = dc(kdc+kCnt)%nStab + JndGrd(:,:,0:nIrrep-1) = 0 + JfGrd(:,:) = .false. + JfGrd(iDCar,1:2) = IfGrad(iDCar,1:2) + do ICnt=1,2 + if (IfGrad(idcar,iCnt)) JndGrd(iDCar,iCnt,0:nIrrep-1) = IndGrd(0:nIrrep-1) + end do + + Tr(1) = .false. + Tr(2) = .false. + Tr(3) = .false. + Tr(4) = .false. + if ((kdc+kCnt) == iDCnt) then + Tr(3) = .true. + JfGrd(iDCar,1:2) = .true. + JndGrd(iDCar,3,0:nIrrep-1) = -IndGrd(0:nIrrep-1) + end if + + do lDCRT=0,nDCRT-1 + kndgrd(:,:,0:nIrrep-1) = JndGrd(:,:,0:nIrrep-1) + kfgrd(:,:) = JfGrd(:,:) + mOp(3) = NrOpr(iDCRT(lDCRT)) + mOp(4) = mOp(3) + call OA(iDCRT(lDCRT),C,TC) + CoorAC(:,2) = TC + Coora(:,3) = TC + Coora(:,4) = TC + Coori(:,3) = TC + Coori(:,4) = TC + if (Eq(A,RB) .and. EQ(A,TC)) cycle + if (EQ(A,TC)) then + kfGrd(iDCar,1) = .false. + kndGrd(iDCar,1,0:nIrrep-1) = 0 + end if + if (EQ(RB,TC)) then + kfGrd(iDCar,2) = .false. + kndgrd(iDCar,2,0:nIrrep-1) = 0 + end if + + if (kfGrd(idcar,1)) then + JFG(1) = .true. + else + JFG(1) = .false. + end if + if (kfGrd(idcar,2)) then + JFG(2) = .true. + else + JFG(2) = .false. + end if + JFG(3) = .false. + JFG(4) = .false. + call Rysg2(iAnga,nRys,nZeta,Array(ipA),Array(ipB),[One],[One],Zeta,ZInv,nZeta,[One],[One],1,P,nZeta,TC,1,Coori,Coora,CoorAC, & + Array(nip),nArray,TNAI1,Fake,Cff2D,PAO,nPAO,Hess,nHess,kfGrd,kndGrd,JfHss,JndHss,mOp,iuvwx,Jfg,nGr,Indx,.true., & + .false.,tr) + + do iElem=1,nTri_Elem1(la)*nTri_Elem1(lb)*ngr + indi = nip+(iElem-1)*nZeta + Array(indi:indi+nZeta-1) = Two*rKappa(:)*Pi*ZInv(:)*Array(indi:indi+nZeta-1) + end do + +# ifdef _DEBUGPRINT_ + call RecPrt('In NaGrd_McK PI',' ',Array(nip),nb,3) + call RecPrt('In NaGrd_McK PI',' ',rFinal,nb,nrOp) +# endif + call SmAdNa(Array(nip),nb,rFinal,mop,loper,KndGrd,iuvwx,Indx,idcar,Fact,tr) + !if (iPrint > 23) call RecPrt('In NaGrd_McK FI',' ',rFinal,nb,nrOp) + end do + end do +end do + +return + +end subroutine NAGrd_mck diff -Nru openmolcas-22.02/src/mckinley/nahss.f openmolcas-22.10/src/mckinley/nahss.f --- openmolcas-22.02/src/mckinley/nahss.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/nahss.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,297 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Anders Bernhardsson * -* 1991, Roland Lindh * -************************************************************************ - SubRoutine NAHss( -#define _CALLING_ -#include "hss_interface.fh" - & ) -************************************************************************ -* * -* Object: to compute the gradient of the nuclear attraction integrals. * -* * -* Author: Anders Bernhardsson & Roland Lindh, * -* Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -* October 1991 * -************************************************************************ - use Basis_Info - use Center_Info - Implicit Real*8 (A-H,O-Z) - External TNAI1, Fake, Cff2D -#include "Molcas.fh" -#include "real.fh" -#include "disp.fh" -#include "disp2.fh" - -#include "hss_interface.fh" - -* Local variables - Integer iDCRT(0:7), Index(3,4) - Logical EQ,IfG(0:3),Tr(0:3) -* -* Local arrrays -* - Real*8 Coori(3,4), CoorAC(3,2), C(3), TC(3) - Integer iAnga(4), JndGrd(0:2,0:3,0:7), - & JndHss(0:3,0:2,0:3,0:2,0:7), - & mOp(4), iuvwx(4) - Logical JfHss(0:3,0:2,0:3,0:2),JfGrd(0:2,0:3) - Logical, External :: TF -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - itri(i1,i2)=MAX(i1,i2)*(MAX(i1,i2)-1)/2+MIN(i1,i2) -* -#ifdef _DEBUGPRINT_ - Write (6,*) ' In NAHss: nArr=',nArr -#endif -* - nRys=nHer -* - nip = 1 - ipA = nip - nip = nip + nAlpha*nBeta - ipB = nip - nip = nip + nAlpha*nBeta - ipDAO = nip - nip = nip + nAlpha*nBeta*nElem(la)*nElem(lb) - If (nip-1.gt.nArr) Then - Write (6,*) 'NAHss: nip-1.gt.nArr' - Write (6,*) 'nip,nArr=',nip,nArr - Call Abend() - End If - ipArr = nip - nArray = nArr - nip +1 -* - iIrrep = 0 - iAnga(1) = la - iAnga(2) = lb - iAnga(3) = 0 - iAnga(4) = 0 - call dcopy_(3,A,1,Coori(1,1),1) - call dcopy_(3,RB,1,Coori(1,2),1) - If (la.ge.lb) Then - call dcopy_(3,A,1,CoorAC(1,1),1) - Else - call dcopy_(3,RB,1,CoorAC(1,1),1) - End If - iuvwx(1) = dc(mdc)%nStab - iuvwx(2) = dc(ndc)%nStab - mOp(1) = nOp(1) - mOp(2) = nOp(2) -* - ipAOff = ipA - Do iBeta = 1, nBeta - call dcopy_(nAlpha,Alpha,1,Array(ipAOff),1) - ipAOff = ipAOff + nAlpha - End Do -* - ipBOff = ipB - Do iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ipBOff),nAlpha) - ipBOff = ipBOff + 1 - End Do -* -* Modify the density matrix with the prefactor -* - nDAO = nElem(la) * nElem(lb) - Do iDAO = 1, nDAO - Do iZeta = 1, nZeta - Fact = Two*rkappa(iZeta)*Pi/Zeta(iZeta) - DAO(iZeta,iDAO) = Fact * DAO(iZeta,iDAO) - End Do - End Do -#ifdef _DEBUGPRINT_ - Call RecPrt('DAO',' ',DAO,nZeta,nDAO) -#endif -* -*-----Loop over nuclear centers -* - kdc = 0 - Do kCnttp = 1, nCnttp - If (kCnttp==iCnttp_Dummy) Go To 111 - If (dbsc(kCnttp)%Charge.eq.Zero) Go To 111 - Do kCnt = 1, dbsc(kCnttp)%nCntr - C(1:3)=dbsc(kCnttp)%Coor(1:3,kCnt) - - Call DCR(LmbdT,iStabM,nStabM, - & dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) - Fact = -dbsc(kCnttp)%Charge*DBLE(nStabM) / DBLE(LmbdT) -* - Call DYaX(nZeta*nDAO,Fact,DAO,1,Array(ipDAO),1) -* - iuvwx(3) = dc(kdc+kCnt)%nStab - iuvwx(4) = dc(kdc+kCnt)%nStab -* - Do 102 lDCRT = 0, nDCRT-1 -* - mOp(3) = NrOpr(iDCRT(lDCRT)) - mOp(4) = mOp(3) - Call OA(iDCRT(lDCRT),C,TC) - call dcopy_(3,TC,1,CoorAC(1,2),1) - call dcopy_(3,TC,1,Coori(1,3),1) - call dcopy_(3,TC,1,Coori(1,4),1) - If (EQ(A,TC).and.EQ(A,RB)) Goto 102 -* -* Initialize JfGrd, JndGrd, JfHss, and JndHss. -* - Call LCopy(12,[.False.],0,JfGrd,1) - Call ICopy(nSym*4*3,[0],0,JndGrd,1) - Call LCopy(144,[.False.],0,JfHss,1) - Call ICopy(nSym*16*9,[0],0,JndHss,1) -* -* Overwrite with information in IfGrd, IndGrd, IfHss, -* and IndHss. - - Do iAtom = 0, 1 - Do iCar = 0, 2 - JfGrd(iCar,iAtom) = Ifgrd(iCar,iAtom) - Do iIrrep=0,nSym-1 - JndGrd(iCar,iAtom,iIrrep)= - & IndGrd(iCar,iAtom,iIrrep) - End Do - Do jAtom = 0, 1 - Do jCar = 0, 2 - JfHss(iAtom,iCar,jAtom,jCar) = - & IfHss(iAtom,iCar,jAtom,jCar) - Do iIrrep=0,nSym-1 - JndHss(iAtom,iCar,jAtom,jCar,iIrrep) = - & IndHss(iAtom,iCar,jAtom,jCar,iIrrep) - End Do - End Do - End Do - End Do - End Do -* -*--------------Derivatives with respect to the operator is computed via -* the translational invariance. -* - nnIrrep=nSym - If (sIrrep) nnIrrep=1 - Do iIrrep=0,nnIrrep-1 - nDisp = IndDsp(kdc+kCnt,iIrrep) - Do iCar = 0, 2 - iComp = 2**iCar - If (TF(kdc+kCnt,iIrrep,iComp)) Then - nDisp = nDisp + 1 -* -*-----------------------Reset flags for the basis set centers so that we -* will explicitly compute the derivatives with -* respect to those centers. Activate flag for the -* third center so that its derivative will be comp- -* uted by the translational invariance. -* - JndGrd(iCar,0,iIrrep)=Abs(JndGrd(iCar,0,iIrrep)) - JndGrd(iCar,1,iIrrep)=Abs(JndGrd(iCar,1,iIrrep)) - JndGrd(iCar,2,iIrrep)=-nDisp - JfGrd(iCar,0) = .True. - JfGrd(iCar,1) = .True. - JfGrd(iCar,2) = .False. - Else - JndGrd(iCar,2,iIrrep) = 0 - End If - End Do - End Do -* -* The third center is calculated by translational invariance. -* This requires the 2nd derivatives on the other centers. -* - Call LCopy(4,[.False.],0,Tr,1) - Do iCar=0,2 - Do jAtom=0,2 - If (jAtom.eq.2) Then - iStop=iCar - Else - iStop=2 - End If - Do jCar=0,iStop - Do iIrrep=0,nSym-1 - If ((JndGrd(iCar,2,iIrrep).ne.0) .and. - & (JndGrd(jCar,jAtom,iIrrep).ne.0)) Then - JndHss(2,iCar,jAtom,jCar,iIrrep)= - & -itri(Abs(JndGrd(iCar,2, iIrrep)), - & Abs(JndGrd(jCar,jAtom,iIrrep))) - - Tr(2)=.True. - If (jAtom.eq.2) Then - Maxi=Max(iCar,jCar) - Mini=Min(iCar,jCar) - JfHss(0,Maxi,0,Mini)=.True. - JfHss(1,Maxi,1,Mini)=.True. - JfHss(1,iCar,0,jCar)=.True. - JfHss(1,jCar,0,iCar)=.True. - Else - Maxi=Max(iCar,jCar) - Mini=Min(iCar,jCar) - JfHss(jAtom,Maxi,jAtom,Mini)=.True. - JfHss(1,iCar,0,jCar)=.True. - JfHss(1,jCar,0,iCar)=.True. - End If - End If - End Do - End Do - End Do - End Do -* - IfG(0)=.True. - IfG(1)=.True. - IfG(2)=.False. - IfG(3)=.False. - Do iCent=0,1 - If (EQ(Coori(1,iCent+1),Coori(1,3) ) ) Then - IfG(iCent)=.False. - Do iCar=0,2 - jfGrd(iCar,iCent)=.False. - Do kCar=0,2 - Do KCent=0,3 - jfHss(iCent,iCar,kCent,kCar)=.False. - jfHss(kCent,kCar,iCent,iCar)=.False. - Do iIrrep=0,nSym-1 - jndHss(iCent,iCar,kCent,kCar,iIrrep)=0 - jndHss(kCent,kCar,iCent,iCar,iIrrep)=0 - End Do - End Do - End Do - Do iIrrep=0,nSym-1 - jndGrd(iCar,iCent,iIrrep)=0 - End Do - End Do - End If - End Do - Call lCopy(12,[.False.],0,jfgrd,1) -* - nFinal = 0 - Call Rysg2(iAnga,nRys,nZeta, - & Array(ipA),Array(ipB),[One],[One], - & Zeta,ZInv,nZeta,[One],[One],1, - & P,nZeta,TC,1,Coori,Coori,CoorAC, - & Array(ipArr),nArray, - & TNAI1,Fake,Cff2D, - & Array(ipDAO),nDAO,Hess,nHess, - & JfGrd,JndGrd, - & JfHss,JndHss,mOp,iuvwx,ifg, - & nFinal,index,.false.,.true.,tr) -* - 102 Continue - End Do - 111 kdc = kdc + dbsc(kCnttp)%nCntr - End Do -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Final) - Call Unused_real_array(Ccoor) - Call Unused_integer(nOrdOp) - Call Unused_integer_array(lOper) - End If - End diff -Nru openmolcas-22.02/src/mckinley/nahss.F90 openmolcas-22.10/src/mckinley/nahss.F90 --- openmolcas-22.02/src/mckinley/nahss.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/nahss.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,250 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Anders Bernhardsson * +! 1991, Roland Lindh * +!*********************************************************************** + +subroutine NAHss( & +# define _CALLING_ +# include "hss_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the gradient of the nuclear attraction integrals. * +! * +! Author: Anders Bernhardsson & Roland Lindh, * +! Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +! October 1991 * +!*********************************************************************** + +use McKinley_global, only: sIrrep +use Index_Functions, only: iTri, nTri_Elem1 +use Basis_Info, only: dbsc, iCnttp_Dummy, nCnttp +use Center_Info, only: dc +use Constants, only: Zero, One, Two, Pi +use Definitions, only: wp, iwp, u6 + +implicit none +#include "hss_interface.fh" +#include "Molcas.fh" +#include "disp.fh" +integer(kind=iwp) :: iAnga(4), iBeta, iCar, iCent, iComp, iDAO, iDCRT(0:7), iIrrep, Indx(3,4), ipA, ipAOff, ipArr, ipB, ipBOff, & + ipDAO, iStop, iuvwx(4), jAtom, jCar, JndGrd(0:2,0:3,0:7), JndHss(0:3,0:2,0:3,0:2,0:7), kCnt, kCnttp, kdc, & + lDCRT, LmbdT, Maxi, Mini, mOp(4), nArray, nDAO, nDCRT, nDisp, nFinal, nip, nnIrrep, nRys +real(kind=wp) :: C(3), CoorAC(3,2), Coori(3,4), Fact, TC(3) +logical(kind=iwp) :: IfG(0:3), JfGrd(0:2,0:3), JfHss(0:3,0:2,0:3,0:2), Tr(0:3) +integer(kind=iwp), external :: NrOpr +logical(kind=iwp), external :: EQ, TF +external :: TNAI1, Fake, Cff2D + +#include "macros.fh" +unused_var(rFinal) +unused_var(Ccoor) +unused_var(nOrdOp) +unused_var(lOper) + +#ifdef _DEBUGPRINT_ +write(u6,*) ' In NAHss: nArr=',nArr +#endif + +nRys = nHer + +nip = 1 +ipA = nip +nip = nip+nAlpha*nBeta +ipB = nip +nip = nip+nAlpha*nBeta +ipDAO = nip +nip = nip+nAlpha*nBeta*nTri_Elem1(la)*nTri_Elem1(lb) +if (nip-1 > nArr) then + write(u6,*) 'NAHss: nip-1 > nArr' + write(u6,*) 'nip,nArr=',nip,nArr + call Abend() +end if +ipArr = nip +nArray = nArr-nip+1 + +iIrrep = 0 +iAnga(1) = la +iAnga(2) = lb +iAnga(3) = 0 +iAnga(4) = 0 +Coori(:,1) = A +Coori(:,2) = RB +if (la >= lb) then + CoorAC(:,1) = A +else + CoorAC(:,1) = RB +end if +iuvwx(1) = dc(mdc)%nStab +iuvwx(2) = dc(ndc)%nStab +mOp(1) = nOp(1) +mOp(2) = nOp(2) + +ipAOff = ipA +do iBeta=1,nBeta + Array(ipAOff:ipAOff+nAlpha-1) = Alpha + ipAOff = ipAOff+nAlpha +end do + +ipBOff = ipB +do iBeta=1,nBeta + Array(ipBOff:ipBOff+nAlpha-1) = Beta(iBeta) + ipBOff = ipBOff+nAlpha +end do + +! Modify the density matrix with the prefactor + +nDAO = nTri_Elem1(la)*nTri_Elem1(lb) +do iDAO=1,nDAO + DAO(:,iDAO) = Two*rKappa(:)*Pi/Zeta(:)*DAO(:,iDAO) +end do +#ifdef _DEBUGPRINT_ +call RecPrt('DAO',' ',DAO,nZeta,nDAO) +#endif + +! Loop over nuclear centers + +kdc = 0 +do kCnttp=1,nCnttp + if (kCnttp > 1) kdc = kdc+dbsc(kCnttp-1)%nCntr + if (kCnttp == iCnttp_Dummy) cycle + if (dbsc(kCnttp)%Charge == Zero) cycle + do kCnt=1,dbsc(kCnttp)%nCntr + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + + call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) + Fact = -dbsc(kCnttp)%Charge*real(nStabM,kind=wp)/real(LmbdT,kind=wp) + + Array(ipDAO:ipDAO+nZeta*nDAO-1) = Fact*reshape(DAO(:,1:nDAO),[nZeta*nDAO]) + + iuvwx(3) = dc(kdc+kCnt)%nStab + iuvwx(4) = dc(kdc+kCnt)%nStab + + do lDCRT=0,nDCRT-1 + + mOp(3) = NrOpr(iDCRT(lDCRT)) + mOp(4) = mOp(3) + call OA(iDCRT(lDCRT),C,TC) + CoorAC(:,2) = TC + Coori(:,3) = TC + Coori(:,4) = TC + if (EQ(A,TC) .and. EQ(A,RB)) cycle + + ! Initialize JfGrd, JndGrd, JfHss, and JndHss. + + JfGrd(:,:) = .false. + JndGrd(:,:,0:nSym-1) = 0 + JfHss(:,:,:,:) = .false. + JndHss(:,:,:,:,0:nSym-1) = 0 + + ! Overwrite with information in IfGrd, IndGrd, IfHss, and IndHss. + + JfGrd(0:2,0:1) = Ifgrd(0:2,0:1) + JndGrd(0:2,0:1,0:nSym-1) = IndGrd(0:2,0:1,0:nSym-1) + JfHss(0:1,0:2,0:1,0:2) = IfHss(0:1,0:2,0:1,0:2) + JndHss(0:1,0:2,0:1,0:2,0:nSym-1) = IndHss(0:1,0:2,0:1,0:2,0:nSym-1) + + ! Derivatives with respect to the operator is computed via + ! the translational invariance. + + nnIrrep = nSym + if (sIrrep) nnIrrep = 1 + do iIrrep=0,nnIrrep-1 + nDisp = IndDsp(kdc+kCnt,iIrrep) + do iCar=0,2 + iComp = 2**iCar + if (TF(kdc+kCnt,iIrrep,iComp)) then + nDisp = nDisp+1 + + ! Reset flags for the basis set centers so that we + ! will explicitly compute the derivatives with + ! respect to those centers. Activate flag for the + ! third center so that its derivative will be computed + ! by the translational invariance. + + JndGrd(iCar,0:1,iIrrep) = abs(JndGrd(iCar,0:1,iIrrep)) + JndGrd(iCar,2,iIrrep) = -nDisp + JfGrd(iCar,0:1) = .true. + JfGrd(iCar,2) = .false. + else + JndGrd(iCar,2,iIrrep) = 0 + end if + end do + end do + + ! The third center is calculated by translational invariance. + ! This requires the 2nd derivatives on the other centers. + + Tr(:) = .false. + do iCar=0,2 + do jAtom=0,2 + if (jAtom == 2) then + iStop = iCar + else + iStop = 2 + end if + do jCar=0,iStop + do iIrrep=0,nSym-1 + if ((JndGrd(iCar,2,iIrrep) /= 0) .and. (JndGrd(jCar,jAtom,iIrrep) /= 0)) then + JndHss(2,iCar,jAtom,jCar,iIrrep) = -itri(abs(JndGrd(iCar,2,iIrrep)),abs(JndGrd(jCar,jAtom,iIrrep))) + + Tr(2) = .true. + if (jAtom == 2) then + Maxi = max(iCar,jCar) + Mini = min(iCar,jCar) + JfHss(0,Maxi,0,Mini) = .true. + JfHss(1,Maxi,1,Mini) = .true. + JfHss(1,iCar,0,jCar) = .true. + JfHss(1,jCar,0,iCar) = .true. + else + Maxi = max(iCar,jCar) + Mini = min(iCar,jCar) + JfHss(jAtom,Maxi,jAtom,Mini) = .true. + JfHss(1,iCar,0,jCar) = .true. + JfHss(1,jCar,0,iCar) = .true. + end if + end if + end do + end do + end do + end do + + IfG(0) = .true. + IfG(1) = .true. + IfG(2) = .false. + IfG(3) = .false. + do iCent=0,1 + if (EQ(Coori(1,iCent+1),Coori(1,3))) then + IfG(iCent) = .false. + JfGrd(:,iCent) = .false. + JfHss(iCent,:,:,:) = .false. + JfHss(:,:,iCent,:) = .false. + JndGrd(:,iCent,0:nSym-1) = 0 + JndHss(iCent,:,:,:,0:nSym-1) = 0 + JndHss(:,:,iCent,:,0:nSym-1) = 0 + end if + end do + JfGrd(:,:) = .false. + + nFinal = 0 + call Rysg2(iAnga,nRys,nZeta,Array(ipA),Array(ipB),[One],[One],Zeta,ZInv,nZeta,[One],[One],1,P,nZeta,TC,1,Coori,Coori,CoorAC, & + Array(ipArr),nArray,TNAI1,Fake,Cff2D,Array(ipDAO),nDAO,Hess,nHess,JfGrd,JndGrd,JfHss,JndHss,mOp,iuvwx,ifg,nFinal, & + Indx,.false.,.true.,tr) + + end do + end do +end do + +return + +end subroutine NAHss diff -Nru openmolcas-22.02/src/mckinley/namem_mck.f openmolcas-22.10/src/mckinley/namem_mck.f --- openmolcas-22.02/src/mckinley/namem_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/namem_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,27 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine NAMem_mck(nRys,MmNAG,la,lb,lr) -* - Integer iAng(4) -* - iAng(1) = la - iAng(2) = lb - iAng(3) = 0 - iAng(4) = 0 - Call MemRg2(iAng,nRys,MmNAG,1) - MmNAG = MmNAG + 2 -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(lr) - End diff -Nru openmolcas-22.02/src/mckinley/namem_mck.F90 openmolcas-22.10/src/mckinley/namem_mck.F90 --- openmolcas-22.02/src/mckinley/namem_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/namem_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,37 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine NAMem_mck( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: iAng(4) + +#include "macros.fh" +unused_var(lr) + +iAng(1) = la +iAng(2) = lb +iAng(3) = 0 +iAng(4) = 0 +call MemRg2(iAng,nHer,Mem,1) +Mem = Mem+2 + +return + +end subroutine NAMem_mck diff -Nru openmolcas-22.02/src/mckinley/nammh.f openmolcas-22.10/src/mckinley/nammh.f --- openmolcas-22.02/src/mckinley/nammh.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/nammh.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine NAMmh(nRys,MmNAG,la,lb,lr) -* - Integer iAng(4) -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - iAng(1) = la - iAng(2) = lb - iAng(3) = 0 - iAng(4) = 0 - Call MemRg2(iAng,nRys,MmNAG,2) - MmNAG = MmNAG + 2 + nElem(la)*nElem(lb) ! Alpha beta & DAO -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(lr) - End diff -Nru openmolcas-22.02/src/mckinley/nammh.F90 openmolcas-22.10/src/mckinley/nammh.F90 --- openmolcas-22.02/src/mckinley/nammh.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/nammh.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,38 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine NAMmh( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer iAng(4) + +#include "macros.fh" +unused_var(lr) + +iAng(1) = la +iAng(2) = lb +iAng(3) = 0 +iAng(4) = 0 +call MemRg2(iAng,nHer,Mem,2) +Mem = Mem+2+nTri_Elem1(la)*nTri_Elem1(lb) ! Alpha beta & DAO + +return + +end subroutine NAMmh diff -Nru openmolcas-22.02/src/mckinley/nmo.f openmolcas-22.10/src/mckinley/nmo.f --- openmolcas-22.02/src/mckinley/nmo.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/nmo.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,26 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Integer Function nMo(mIrr) - use Symmetry_Info, only: nIrrep - Implicit Integer (a-h,o-z) -#include "etwas.fh" - nInt=0 - nA=0 - Do iS=0,nIrrep-1 - nA=nA+nAsh(is) - End Do - NMM=nA*(nA+1)/2 - nInt=nMM*(nMM+1)/2 - nMo=nInt - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(mIrr) - End diff -Nru openmolcas-22.02/src/mckinley/nona2.f openmolcas-22.10/src/mckinley/nona2.f --- openmolcas-22.02/src/mckinley/nona2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/nona2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,120 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2000, Per Ake Malmqvist * -************************************************************************ - SUBROUTINE NONA2( -#define _CALLING_ -#include "grd_mck_interface.fh" - & ) -************************************************************************ -* OBJECT: TO COMPUTE THE 2ND DERIVATIVE NONADIABATIC COUPLING -* INTEGRALS, OF TYPE -* < D/DX CHI_1 | D/DX CHI_2 > -* -* AUTHOR: PER AKE MALMQVIST, MAX PLANCK INSTITUT F ASTROPHYSIK -* GARCHING, MUENCHEN NOV 2000 -* AFTER PROGRAMMING PATTERN ESTABLISHED BY ROLAND LINDH -* -************************************************************************ - use Her_RW - use Center_Info - IMPLICIT REAL*8 (A-H,O-Z) -#include "real.fh" - -#include "grd_mck_interface.fh" - -* Local variables - - LOGICAL ABEQ(3) -C The following call parameters are not used: -C IDCNT,ISTABM,NSTABM,ZINV -C They must still be present, because the call parameter list must - - NELEM(LA)=(LA+2)*(LA+1)/2 - ABEQ(1) = A(1).EQ.RB(1) - ABEQ(2) = A(2).EQ.RB(2) - ABEQ(3) = A(3).EQ.RB(3) - - NIP = 1 - IPAXYZ = NIP - NIP = NIP + NZETA*3*NHER*(LA+2) - IPBXYZ = NIP - NIP = NIP + NZETA*3*NHER*(LB+2) - IPRXYZ = NIP - NIP = NIP + NZETA*3*NHER*(NORDOP+1) - IPRNXYZ = NIP - NIP = NIP + NZETA*3*(LA+2)*(LB+2)*(NORDOP+1) - IPALPH = NIP - NIP = NIP + NZETA - IPBETA = NIP - NIP = NIP + NZETA - IPSCRT=NIP - NIP=NIP+NELEM(LA)*NELEM(LB)*NZETA*2 - - - IF (NIP-1.GT.NARR) THEN - WRITE(6,*)' NONA2: Too small array.' - WRITE(6,*)' Submitted array size NARR=',NARR - WRITE(6,*)' Needed size at least NIP =',NIP - CALL Abend - END IF - -* COMPUTE THE CARTESIAN VALUES OF THE BASIS FUNCTIONS ANGULAR PART - CALL CRTCMP(ZETA,P,NZETA,A,ARRAY(IPAXYZ), - & LA+1,HerR(iHerR(NHER)),NHER,ABEQ) - CALL CRTCMP(ZETA,P,NZETA,RB,ARRAY(IPBXYZ), - & LB+1,HerR(iHerR(NHER)),NHER,ABEQ) - -CPAM: WILL WE NEED THIS?? -* COMPUTE THE CONTRIBUTION FROM THE MULTIPOLE MOMENT OPERATOR - ABEQ(1) = .FALSE. - ABEQ(2) = .FALSE. - ABEQ(3) = .FALSE. - CALL CRTCMP(ZETA,P,NZETA,CCOOR,ARRAY(IPRXYZ), - & NORDOP,HerR(iHerR(NHER)),NHER,ABEQ) - -* COMPUTE THE PRIMITIVE 1-DIMENSIONAL OVERLAP INTEGRALS. - CALL ASSMBL(ARRAY(IPRNXYZ), - & ARRAY(IPAXYZ),LA+1, - & ARRAY(IPRXYZ),NORDOP, - & ARRAY(IPBXYZ),LB+1, - & NZETA,HerR(iHerW(NHER)),NHER) - -* COMBINE THE CARTESIAN COMPONENTS OF THE 2DC MATRIX ELEMENTS - IP = IPALPH - DO IBETA = 1, NBETA - CALL DCOPY_(NALPHA,ALPHA,1,ARRAY(IP),1) - IP = IP + NALPHA - END DO - IP = IPBETA - DO IALPHA = 1, NALPHA - CALL DCOPY_(NBETA,BETA,1,ARRAY(IP),NALPHA) - IP = IP + 1 - END DO - CALL CMBN2DC(ARRAY(IPRNXYZ),NZETA,LA,LB,ZETA, - & RKAPPA,ARRAY(IPSCRT), - & ARRAY(IPALPH),ARRAY(IPBETA), - & IFGRAD) - -* SYMMETRY ADAPT THE 2ND DERIVATIVE COUPLING INTEGRALS - CALL SYMADO_MCK(ARRAY(IPSCRT),NZETA*NELEM(LA)*NELEM(LB), - & FINAL,NROP, - & nOP,LOPER,INDGRD,IU,IV,IFGRAD,IDCAR,TRANS) - - RETURN -c Avoid unused argument warnings - IF (.FALSE.) THEN - CALL Unused_real_array(ZINV) - CALL Unused_integer(IDCNT) - CALL Unused_integer_array(ISTABM) - CALL Unused_integer(NSTABM) - END IF - END diff -Nru openmolcas-22.02/src/mckinley/nonatwo.F90 openmolcas-22.10/src/mckinley/nonatwo.F90 --- openmolcas-22.02/src/mckinley/nonatwo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/nonatwo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,104 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2000, Per Ake Malmqvist * +!*********************************************************************** + +subroutine NONATWO( & +# define _CALLING_ +# include "grd_mck_interface.fh" + ) +!*********************************************************************** +! OBJECT: TO COMPUTE THE 2ND DERIVATIVE NONADIABATIC COUPLING +! INTEGRALS, OF TYPE +! < D/DX CHI_1 | D/DX CHI_2 > +! +! AUTHOR: PER AKE MALMQVIST, MAX PLANCK INSTITUT F ASTROPHYSIK +! GARCHING, MUENCHEN NOV 2000 +! AFTER PROGRAMMING PATTERN ESTABLISHED BY ROLAND LINDH +! +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Her_RW, only: HerR, HerW, iHerR, iHerW +use Definitions, only: wp, iwp, u6 + +implicit none +#include "grd_mck_interface.fh" +integer(kind=iwp) :: IBETA, IP, IPALPH, IPAXYZ, IPBETA, IPBXYZ, IPRNXYZ, IPRXYZ, IPSCRT, NIP +logical(kind=iwp) :: ABEQ(3) + +#include "macros.fh" +unused_var(ZInv) +unused_var(lOper) +unused_var(iDCnt) +unused_var(iStabM) +unused_var(nStabM) + +ABEQ(1) = A(1) == RB(1) +ABEQ(2) = A(2) == RB(2) +ABEQ(3) = A(3) == RB(3) + +NIP = 1 +IPAXYZ = NIP +NIP = NIP+NZETA*3*NHER*(LA+2) +IPBXYZ = NIP +NIP = NIP+NZETA*3*NHER*(LB+2) +IPRXYZ = NIP +NIP = NIP+NZETA*3*NHER*(NORDOP+1) +IPRNXYZ = NIP +NIP = NIP+NZETA*3*(LA+2)*(LB+2)*(NORDOP+1) +IPALPH = NIP +NIP = NIP+NZETA +IPBETA = NIP +NIP = NIP+NZETA +IPSCRT = NIP +NIP = NIP+nTri_Elem1(LA)*nTri_Elem1(LB)*NZETA*2 + +if (NIP-1 > NARR) then + write(u6,*) ' NONATWO: Too small array.' + write(u6,*) ' Submitted array size NARR=',NARR + write(u6,*) ' Needed size at least NIP =',NIP + call Abend() +end if + +! COMPUTE THE CARTESIAN VALUES OF THE BASIS FUNCTIONS ANGULAR PART +call CRTCMP(ZETA,P,NZETA,A,ARRAY(IPAXYZ),LA+1,HerR(iHerR(NHER)),NHER,ABEQ) +call CRTCMP(ZETA,P,NZETA,RB,ARRAY(IPBXYZ),LB+1,HerR(iHerR(NHER)),NHER,ABEQ) + +!PAM: WILL WE NEED THIS?? +! COMPUTE THE CONTRIBUTION FROM THE MULTIPOLE MOMENT OPERATOR +ABEQ(1) = .false. +ABEQ(2) = .false. +ABEQ(3) = .false. +call CRTCMP(ZETA,P,NZETA,CCOOR,ARRAY(IPRXYZ),NORDOP,HerR(iHerR(NHER)),NHER,ABEQ) + +! COMPUTE THE PRIMITIVE 1-DIMENSIONAL OVERLAP INTEGRALS. +call ASSMBL(ARRAY(IPRNXYZ),ARRAY(IPAXYZ),LA+1,ARRAY(IPRXYZ),NORDOP,ARRAY(IPBXYZ),LB+1,NZETA,HerW(iHerW(NHER)),NHER) + +! COMBINE THE CARTESIAN COMPONENTS OF THE 2DC MATRIX ELEMENTS +IP = IPALPH +do IBETA=1,NBETA + ARRAY(IP:IP+NALPHA-1) = ALPHA + IP = IP+NALPHA +end do +IP = IPBETA +do IBETA=1,NBETA + ARRAY(IP:IP+NALPHA-1) = BETA(IBETA) + IP = IP+NALPHA +end do +call CMBN2DC(ARRAY(IPRNXYZ),NZETA,LA,LB,ZETA,RKAPPA,ARRAY(IPSCRT),ARRAY(IPALPH),ARRAY(IPBETA),IFGRAD) + +! SYMMETRY ADAPT THE 2ND DERIVATIVE COUPLING INTEGRALS +call SYMADO_MCK(ARRAY(IPSCRT),NZETA*nTri_Elem1(LA)*nTri_Elem1(LB),rFinal,NROP,nOP,INDGRD,IU,IV,IFGRAD,IDCAR,TRANS) + +return + +end subroutine NONATWO diff -Nru openmolcas-22.02/src/mckinley/nucind.f openmolcas-22.10/src/mckinley/nucind.f --- openmolcas-22.02/src/mckinley/nucind.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/nucind.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,170 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine NucInd(coor,kdc,ifgrd,ifhss,indgrd,indhss, - & jfgrd,jfhss,jndgrd,jndhss,tr,ifg) - use Real_Spherical - use Center_Info - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "real.fh" -#include "disp.fh" -#include "disp2.fh" - - Real*8 Coor(3,4) - Integer IndGrd(0:2,0:1,0:(nIrrep-1)), - & IndHss(0:1,0:2,0:1,0:2,0:(nIrrep-1)) - Logical IfHss(0:1,0:2,0:1,0:2),IfGrd(0:2,0:1), - & IfG(0:3),Tr(0:3) - Integer JndGrd(0:2,0:3,0:(nIrrep-1)), - & JndHss(0:3,0:2,0:3,0:2,0:(nIrrep-1)) -* - Logical JfHss(0:3,0:2,0:3,0:2),JfGrd(0:2,0:3),EQ - Logical, External :: TF -* * -************************************************************************ -* * -* Statement functions -* - IX(i1,i2)=i1*(i1-1)/2+i2 -* * -************************************************************************ -* * - Call ICopy(nIrrep*16*9,[0],0,JndHss,1) - Call iCopy(nIrrep*4*3,[0],0,JndGrd,1) - Call LCopy(144,[.False.],0,jfHss,1) - Call LCopy(4,[.False.],0,Tr,1) - Call LCopy(12,[.False.],0,jfGrd,1) -* -* COPY CNTLR MATRIXES -* - Do iAtom = 0, 1 - Do iCar = 0, 2 - JfGrd(iCar,iAtom) = Ifgrd(iCar,iAtom) - Do iIrrep=0,nIrrep-1 - JndGrd(iCar,iAtom,iIrrep)= - & IndGrd(iCar,iAtom,iIrrep) - End Do - Do jAtom = 0, 1 - Do jCar = 0, 2 - JfHss(iAtom,iCar,jAtom,jCar) = - & IfHss(iAtom,iCar,jAtom,jCar) - Do iIrrep=0,nIrrep-1 - JndHss(iAtom,iCar,jAtom,jCar,iIrrep) = - & IndHss(iAtom,iCar,jAtom,jCar,iIrrep) - End Do ! iirrep - End Do !jCar - End Do ! jAtom - End Do !iCar - End Do !iAtom - -* -* -*-----------Derivatives with respect to the operator is computed via the -* translational invariance. -* - nnIrrep=nIrrep - If (sIrrep) nnIrrep=1 - Do iIrrep=0,nnIrrep-1 - nDisp = IndDsp(kdc,iIrrep) - Do iCar = 0, 2 - iComp = 2**iCar - If (TF(kdc,iIrrep,iComp)) Then - nDisp = nDisp + 1 -* -*--------------------Reset flags for the basis set centers so that we -* will explicitly compute the derivatives with -* respect to those centers. Activate flag for the -* third center so that its derivative will be comp- -* uted by the translational invariance. -* - JndGrd(iCar,0,iIrrep) = Abs(JndGrd(iCar,0,iIrrep)) - JndGrd(iCar,1,iIrrep) = Abs(JndGrd(iCar,1,iIrrep)) - JndGrd(iCar,2,iIrrep) = -nDisp - JfGrd(iCar,0) = .True. - JfGrd(iCar,1) = .True. - JfGrd(iCar,2) = .False. - Else - JndGrd(iCar,2,iIrrep) = 0 - End If - End DO - End DO -* -* The third center is calculated by translation invariance -* This requires the 2nd derivatives on the other centers. -* - - Do iCar=0,2 - Do jAtom=0,2 - if (jAtom.eq.2) Then - iStop=iCar - Else - iStop=2 - End If - Do jCar=0,iStop - Do iIrrep=0,nIrrep-1 - If ((JndGrd(iCar, 2,iIrrep).ne.0).and. - & (JndGrd(jCar,jAtom,iIrrep).ne.0)) Then - JndHss(2,iCar,jAtom,jCar,iIrrep)= - & -IX(Max(Abs(JndGrd(iCar,2,iIrrep)), - & Abs(JndGrd(jCar,jAtom,iIrrep))), - & Min(Abs(JndGrd(iCar,2,iIrrep)), - & Abs(JndGrd(jCar,jAtom,iIrrep)))) - - Tr(2)=.true. - If (jAtom.eq.2) Then - Maxi=Max(iCar,jCar) - Mini=Min(iCar,jCar) - jfHss(0,Maxi,0,Mini)=.true. - jfHss(1,Maxi,1,Mini)=.true. - jfHss(1,iCar,0,jCar)=.true. - jfHss(1,jCar,0,iCar)=.true. - Else - Maxi=Max(iCar,jCar) - Mini=Min(iCar,jCar) - jfHss(jAtom,Maxi,jAtom,Mini)=.true. - jfHss(1,iCar,0,jCar)=.true. - jfHss(1,jCar,0,iCar)=.true. - End If ! jAtom == 2 - End If ! if indgrd - End Do ! iirrep - End Do ! jCar - End Do ! jAtom - End Do ! iCar -* - IfG(0)=.true. - IfG(1)=.true. - IfG(2)=.false. - IfG(3)=.false. - Do iCent=0,1 - If (EQ(Coor(1,iCent+1),Coor(1,3) ) ) Then - IfG(iCent)=.false. - Do iCar=0,2 - jfGrd(iCar,iCent)=.false. - Do kCar=0,2 - Do KCent=0,3 - jfHss(iCent,iCar,kCent,kCar)=.false. - jfHss(kCent,kCar,iCent,iCar)=.false. - Do iIrrep=0,nIrrep-1 - jndHss(iCent,iCar,kCent,kCar,iIrrep)=0 - jndHss(kCent,kCar,iCent,iCar,iIrrep)=0 - End Do !iIrrep - End Do ! kcent - End Do !kCar - Do iIrrep=0,nIrrep-1 - jndGrd(iCar,iCent,iIrrep)=0 - End Do !iIrrep - End Do !ICat - End If ! uf eq - End Do !icent -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/nucind.F90 openmolcas-22.10/src/mckinley/nucind.F90 --- openmolcas-22.02/src/mckinley/nucind.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/nucind.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,125 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine NucInd(coor,kdc,ifgrd,ifhss,indgrd,indhss,jfgrd,jfhss,jndgrd,jndhss,tr,ifg) + +use McKinley_global, only: sIrrep +use Index_Functions, only: iTri +use Symmetry_Info, only: nIrrep +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(in) :: Coor(3,4) +integer(kind=iwp), intent(in) :: kdc, IndGrd(0:2,0:1,0:nIrrep-1), IndHss(0:1,0:2,0:1,0:2,0:nIrrep-1) +logical(kind=iwp), intent(in) :: IfGrd(0:2,0:1), IfHss(0:1,0:2,0:1,0:2) +logical(kind=iwp), intent(out) :: JfGrd(0:2,0:3), JfHss(0:3,0:2,0:3,0:2), Tr(0:3), IfG(0:3) +integer(kind=iwp), intent(out) :: JndGrd(0:2,0:3,0:nIrrep-1), JndHss(0:3,0:2,0:3,0:2,0:nIrrep-1) +#include "Molcas.fh" +#include "disp.fh" +integer(kind=iwp) :: iCar, iCent, iComp, iIrrep, iStop, jAtom, jCar, Maxi, Mini, nDisp, nnIrrep +logical(kind=iwp), external :: EQ, TF + +! * +!*********************************************************************** +! * +JndHss(:,:,:,:,:) = 0 +JndGrd(:,:,:) = 0 +JfHss(:,:,:,:) = .false. +JfGrd(:,:) = .false. +Tr(:) = .false. + +! COPY CNTLR MATRIXES + +JfGrd(:,0:1) = Ifgrd(:,0:1) +JndGrd(:,0:1,0:nIrrep-1) = IndGrd(:,0:1,0:nIrrep-1) +JfHss(0:1,:,0:1,:) = IfHss(0:1,:,0:1,:) +JndHss(0:1,:,0:1,:,0:nIrrep-1) = IndHss(0:1,:,0:1,:,0:nIrrep-1) + +! Derivatives with respect to the operator is computed via the translational invariance. + +nnIrrep = nIrrep +if (sIrrep) nnIrrep = 1 +do iIrrep=0,nnIrrep-1 + nDisp = IndDsp(kdc,iIrrep) + do iCar=0,2 + iComp = 2**iCar + if (TF(kdc,iIrrep,iComp)) then + nDisp = nDisp+1 + + ! Reset flags for the basis set centers so that we + ! will explicitly compute the derivatives with + ! respect to those centers. Activate flag for the + ! third center so that its derivative will be computed + ! by the translational invariance. + + JndGrd(iCar,0:1,iIrrep) = abs(JndGrd(iCar,0:1,iIrrep)) + JndGrd(iCar,2,iIrrep) = -nDisp + JfGrd(iCar,0:1) = .true. + JfGrd(iCar,2) = .false. + else + JndGrd(iCar,2,iIrrep) = 0 + end if + end do +end do + +! The third center is calculated by translation invariance +! This requires the 2nd derivatives on the other centers. + +do iCar=0,2 + do jAtom=0,2 + if (jAtom == 2) then + iStop = iCar + else + iStop = 2 + end if + do jCar=0,iStop + do iIrrep=0,nIrrep-1 + if ((JndGrd(iCar,2,iIrrep) /= 0) .and. (JndGrd(jCar,jAtom,iIrrep) /= 0)) then + JndHss(2,iCar,jAtom,jCar,iIrrep) = -iTri(abs(JndGrd(iCar,2,iIrrep)),abs(JndGrd(jCar,jAtom,iIrrep))) + + Tr(2) = .true. + if (jAtom == 2) then + Maxi = max(iCar,jCar) + Mini = min(iCar,jCar) + jfHss(0,Maxi,0,Mini) = .true. + jfHss(1,Maxi,1,Mini) = .true. + jfHss(1,iCar,0,jCar) = .true. + jfHss(1,jCar,0,iCar) = .true. + else + Maxi = max(iCar,jCar) + Mini = min(iCar,jCar) + jfHss(jAtom,Maxi,jAtom,Mini) = .true. + jfHss(1,iCar,0,jCar) = .true. + jfHss(1,jCar,0,iCar) = .true. + end if ! jAtom == 2 + end if ! if indgrd + end do ! iirrep + end do ! jCar + end do ! jAtom +end do ! iCar + +IfG(0:1) = .true. +IfG(2:3) = .false. +do iCent=0,1 + if (EQ(Coor(1,iCent+1),Coor(1,3))) then + IfG(iCent) = .false. + JfGrd(:,iCent) = .false. + JfHss(iCent,:,:,:) = .false. + JfHss(:,:,iCent,:) = .false. + JndGrd(:,iCent,0:nIrrep-1) = 0 + JndHss(iCent,:,:,:,0:nIrrep-1) = 0 + JndHss(:,:,iCent,:,0:nIrrep-1) = 0 + end if ! uf eq +end do !icent + +return + +end subroutine NucInd diff -Nru openmolcas-22.02/src/mckinley/opnfls_mckinley.f openmolcas-22.10/src/mckinley/opnfls_mckinley.f --- openmolcas-22.02/src/mckinley/opnfls_mckinley.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/opnfls_mckinley.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,109 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SubRoutine OpnFls_McKinley() - use Basis_Info, only: nBas - use Symmetry_Info, only: nIrrep, lIrrep - Implicit Real*8(a-h,o-z) -#include "Molcas.fh" -#include "disp.fh" -#include "disp2.fh" -#include "etwas.fh" - Character*8 Method, MckLbl - Character*288 Header - iOpt = 1 - iRC = -1 - MckLbl='Title' - Call cWrMck(iRC,iOpt,MckLbl,1,Header,iDummer) - If (iRC.ne.0) Then - Write (6,*) 'OpnFls: Error writing to MCKINT' - Write (6,'(A,A)') 'MckLbl=',MckLbl - Call Abend() - End If - iOpt = 1 - iRC = -1 - MckLbl='nSym' - Call iWrMck(iRC,iOpt,MckLbl,1,[nIrrep],iDummer) - If (iRC.ne.0) Then - Write (6,*) 'OpnFls: Error writing to MCKINT' - Write (6,'(A,A)') 'MckLbl=',MckLbl - Call Abend() - End If - iOpt = 0 - iRC = -1 - MckLbl='nBas' - Call iWrMck(iRC,iOpt,MckLbl,1,nBas,iDummer) - If (iRC.ne.0) Then - Write (6,*) 'OpnFls: Error writing to MCKINT' - Write (6,'(A,A)') 'MckLbl=',MckLbl - Call Abend() - End If - iOpt = 0 - iRC = -1 - MckLbl='SymOp' - Call cWrMck(iRC,iOpt,MckLbl,1,lirrep(0),iDummer) - If (iRC.ne.0) Then - Write (6,*) 'OpnFls: Error writing to MCKINT' - Write (6,'(A,A)') 'MckLbl=',MckLbl - Call Abend() - End If - iOpt = 0 - iRC = -1 - MckLbl='ldisp' - Call iWrMck(iRC,iOpt,MckLbl,1,ldisp,iDummer) - If (iRC.ne.0) Then - Write (6,*) 'OpnFls: Error writing to MCKINT' - Write (6,'(A,A)') 'MckLbl=',MckLbl - Call Abend() - End If - ngrad=0 - Do i=0,nIrrep-1 - nGrad=nGrad+ldisp(i) - End Do - iOpt = 0 - iRC = -1 - MckLbl='chdisp' - Call cWrMck(iRC,iOpt,MckLbl,1,chdisp(1),iDummer) - If (iRC.ne.0) Then - Write (6,*) 'OpnFls: Error writing to MCKINT' - Write (6,'(A,A)') 'MckLbl=',MckLbl - Call Abend() - End If -* * -************************************************************************ -* * -*... Get the method label -* - Call Get_cArray('Relax Method',Method,8) - If ( Method.eq.'RHF-SCF ' ) then - nMethod=SCF - Else if ( Method.eq.'CASSCF ' ) then - nMethod=RASSCF - Else if ( Method.eq.'CASSCFSA' ) then - nMethod=RASSCF - Call Get_iScalar('SA ready',iGo) - If (lHss.and.iGo.ne.2) Then - Write (6,*) - Write (6,*) ' Wavefunction type: RASSCF-SA' - Write (6,*) - Write (6,*) ' This option is not allowed when computing'// - & ' the Hessian. Use the RHS option!' - Call Quit_OnUserError() - End If - Else - Write (6,*) ' OpnFls: Wavefunction type:',Method - Write (6,*) ' Illegal type of wave function!' - Write (6,*) ' McKinley can not continue' - Write (6,*) - Call Quit_OnUserError() - End If -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/opnfls_mckinley.F90 openmolcas-22.10/src/mckinley/opnfls_mckinley.F90 --- openmolcas-22.02/src/mckinley/opnfls_mckinley.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/opnfls_mckinley.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,114 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine OpnFls_McKinley() + +use McKinley_global, only: lHss, nMethod, RASSCF, SCF +use Basis_Info, only: nBas +use Symmetry_Info, only: lIrrep, nIrrep +use Definitions, only: iwp, u6 + +implicit none +#include "Molcas.fh" +#include "disp.fh" +integer(kind=iwp) :: i, iDummer, iGo, iOpt, iRC, ngrad +character(len=288) :: Header +character(len=8) :: MckLbl, Method + +iOpt = 1 +iRC = -1 +MckLbl = 'Title' +call cWrMck(iRC,iOpt,MckLbl,1,Header,iDummer) +if (iRC /= 0) then + write(u6,*) 'OpnFls: Error writing to MCKINT' + write(u6,'(A,A)') 'MckLbl=',MckLbl + call Abend() +end if +iOpt = 1 +iRC = -1 +MckLbl = 'nSym' +call iWrMck(iRC,iOpt,MckLbl,1,[nIrrep],iDummer) +if (iRC /= 0) then + write(u6,*) 'OpnFls: Error writing to MCKINT' + write(u6,'(A,A)') 'MckLbl=',MckLbl + call Abend() +end if +iOpt = 0 +iRC = -1 +MckLbl = 'nBas' +call iWrMck(iRC,iOpt,MckLbl,1,nBas,iDummer) +if (iRC /= 0) then + write(u6,*) 'OpnFls: Error writing to MCKINT' + write(u6,'(A,A)') 'MckLbl=',MckLbl + call Abend() +end if +iOpt = 0 +iRC = -1 +MckLbl = 'SymOp' +call cWrMck(iRC,iOpt,MckLbl,1,lirrep(0),iDummer) +if (iRC /= 0) then + write(u6,*) 'OpnFls: Error writing to MCKINT' + write(u6,'(A,A)') 'MckLbl=',MckLbl + call Abend() +end if +iOpt = 0 +iRC = -1 +MckLbl = 'ldisp' +call iWrMck(iRC,iOpt,MckLbl,1,ldisp,iDummer) +if (iRC /= 0) then + write(u6,*) 'OpnFls: Error writing to MCKINT' + write(u6,'(A,A)') 'MckLbl=',MckLbl + call Abend() +end if +ngrad = 0 +do i=0,nIrrep-1 + nGrad = nGrad+ldisp(i) +end do +iOpt = 0 +iRC = -1 +MckLbl = 'chdisp' +call cWrMck(iRC,iOpt,MckLbl,1,chdisp(1),iDummer) +if (iRC /= 0) then + write(u6,*) 'OpnFls: Error writing to MCKINT' + write(u6,'(A,A)') 'MckLbl=',MckLbl + call Abend() +end if +! * +!*********************************************************************** +! * +! Get the method label + +call Get_cArray('Relax Method',Method,8) +if (Method == 'RHF-SCF ') then + nMethod = SCF +else if (Method == 'CASSCF ') then + nMethod = RASSCF +else if (Method == 'CASSCFSA') then + nMethod = RASSCF + call Get_iScalar('SA ready',iGo) + if (lHss .and. (iGo /= 2)) then + write(u6,*) + write(u6,*) ' Wavefunction type: RASSCF-SA' + write(u6,*) + write(u6,*) ' This option is not allowed when computing the Hessian. Use the RHS option!' + call Quit_OnUserError() + end if +else + write(u6,*) ' OpnFls: Wavefunction type:',Method + write(u6,*) ' Illegal type of wave function!' + write(u6,*) ' McKinley can not continue' + write(u6,*) + call Quit_OnUserError() +end if + +return + +end subroutine OpnFls_McKinley diff -Nru openmolcas-22.02/src/mckinley/ovrgrd_mck.f openmolcas-22.10/src/mckinley/ovrgrd_mck.f --- openmolcas-22.02/src/mckinley/ovrgrd_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/ovrgrd_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,151 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990,1991, Roland Lindh * -* 1990, IBM * -* 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine OvrGrd_mck( -#define _CALLING_ -#include "grd_mck_interface.fh" - & ) -************************************************************************ -* * -* Object: to compute the gradients of the overlap matrix * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* November '90 * -* Modified to multipole moments November '90 * -* Author: Anders Bernhardsson * -* November '90 * -* * -* Modified to gradients of the overlap matrix. October * -* '91. * -* Modified for respons calculation in May '95 By * -* Anders Bernhardsson * -************************************************************************ - use Her_RW - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - -#include "grd_mck_interface.fh" - -* Local variables - Logical ABeq(3) -* -* Statement function for Cartesian index -* - nElem(la)=(la+2)*(la+1)/2 -* - ABeq(1) = A(1).eq.RB(1) - ABeq(2) = A(2).eq.RB(2) - ABeq(3) = A(3).eq.RB(3) -* - - nip = 1 - ipAxyz = nip - nip = nip + nZeta*3*nHer*(la+2) - ipBxyz = nip - nip = nip + nZeta*3*nHer*(lb+2) - ipRxyz = nip - nip = nip + nZeta*3*nHer*(nOrdOp+1) - ipRnxyz = nip - nip = nip + nZeta*3*(la+2)*(lb+2)*(nOrdOp+1) - ipAlph = nip - nip = nip + nZeta - ipBeta = nip - nip = nip + nZeta - ipScrt=nip - nip=nip+nElem(la)*nElem(lb)*nZeta*2 - - - If (nip-1.gt.nArr) Then - Write (6,*) 'OvrGrd_Mck: nip-1.gt.nArr' - Write (6,*) 'nip,nArr=',nip,nArr - Call Abend() - End If -* -#ifdef _DEBUGPRINT_ - Write (6,*) ' IfGrad=',IfGrad - Write (6,*) ' IndGrd=',IndGrd - Call RecPrt(' In OvrGrd: A',' ',A,1,3) - Call RecPrt(' In OvrGrd: RB',' ',RB,1,3) - Call RecPrt(' In OvrGrd: Ccoor',' ',Ccoor,1,3) - Call RecPrt(' In OvrGrd: P',' ',P,nZeta,3) - Write (6,*) ' In OvrGrd: la,lb=',la,lb -#endif -* -* Compute the cartesian values of the basis functions angular part -* - Call CrtCmp(Zeta,P,nZeta,A,Array(ipAxyz), - & la+1,HerR(iHerR(nHer)),nHer,ABeq) - Call CrtCmp(Zeta,P,nZeta,RB,Array(ipBxyz), - & lb+1,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the contribution from the multipole moment operator -* - ABeq(1) = .False. - ABeq(2) = .False. - ABeq(3) = .False. - Call CrtCmp(Zeta,P,nZeta,Ccoor,Array(ipRxyz), - & nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the cartesian components for the multipole moment -* integrals. The integrals are factorized into components. -* - Call Assmbl(Array(ipRnxyz), - & Array(ipAxyz),la+1, - & Array(ipRxyz),nOrdOp, - & Array(ipBxyz),lb+1, - & nZeta,HerW(iHerW(nHer)),nHer) -* -* Combine the cartesian components to the gradient of the one -* electron integral and contract with the Fock matrix. -* - ip = ipAlph - Do 20 iBeta = 1, nBeta - call dcopy_(nAlpha,Alpha,1,Array(ip),1) - ip = ip + nAlpha - 20 Continue - ip = ipBeta - Do 21 iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ip),nAlpha) - ip = ip + 1 - 21 Continue - Call CmbnS1_mck(Array(ipRnxyz),nZeta,la,lb,Zeta, - & rKappa,Array(ipScrt), - & Array(ipAlph),Array(ipBeta),IfGrad,nOp) -* -#ifdef _DEBUGPRINT_ - Call RecPrt(' Primitive Integrals',' ', - & Array(ipScrt),nZeta,nElem(la)*nElem(lb)) -#endif -* -* -* Symmetry adopt the gradient operator -* - - Call SymAdO_mck(Array(ipScrt),nZeta*nElem(la)*nElem(lb), - & Final,nrOp, - & nop,loper,IndGrd,iu,iv,ifgrad,idcar,trans) -#ifdef _DEBUGPRINT_ - Call RecPrt(' Primitive Integrals SO',' ', - & Final,nZeta,nElem(la)*nElem(lb)*nrOp) -#endif - - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(ZInv) - Call Unused_integer(iDCnt) - Call Unused_integer_array(iStabM) - Call Unused_integer(nStabM) - End If - End diff -Nru openmolcas-22.02/src/mckinley/ovrgrd_mck.F90 openmolcas-22.10/src/mckinley/ovrgrd_mck.F90 --- openmolcas-22.02/src/mckinley/ovrgrd_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/ovrgrd_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,133 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990,1991, Roland Lindh * +! 1990, IBM * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine OvrGrd_mck( & +# define _CALLING_ +# include "grd_mck_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the gradients of the overlap matrix * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! November '90 * +! Modified to multipole moments November '90 * +! Author: Anders Bernhardsson * +! November '90 * +! * +! Modified to gradients of the overlap matrix. October * +! '91. * +! Modified for respons calculation in May '95 By * +! Anders Bernhardsson * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Her_RW, only: HerR, HerW, iHerR, iHerW +use Definitions, only: wp, iwp, u6 + +implicit none +#include "grd_mck_interface.fh" +integer(kind=iwp) :: iBeta, ip, ipAlph, ipAxyz, ipBeta, ipBxyz, ipRnxyz, ipRxyz, ipScrt, nip +logical(kind=iwp) :: ABeq(3) + +#include "macros.fh" +unused_var(ZInv) +unused_var(lOper) +unused_var(iDCnt) +unused_var(iStabM) +unused_var(nStabM) + +ABeq(1) = A(1) == RB(1) +ABeq(2) = A(2) == RB(2) +ABeq(3) = A(3) == RB(3) + +nip = 1 +ipAxyz = nip +nip = nip+nZeta*3*nHer*(la+2) +ipBxyz = nip +nip = nip+nZeta*3*nHer*(lb+2) +ipRxyz = nip +nip = nip+nZeta*3*nHer*(nOrdOp+1) +ipRnxyz = nip +nip = nip+nZeta*3*(la+2)*(lb+2)*(nOrdOp+1) +ipAlph = nip +nip = nip+nZeta +ipBeta = nip +nip = nip+nZeta +ipScrt = nip +nip = nip+nTri_Elem1(la)*nTri_Elem1(lb)*nZeta*2 + +if (nip-1 > nArr) then + write(u6,*) 'OvrGrd_Mck: nip-1 > nArr' + write(u6,*) 'nip,nArr=',nip,nArr + call Abend() +end if + +#ifdef _DEBUGPRINT_ +write(u6,*) ' IfGrad=',IfGrad +write(u6,*) ' IndGrd=',IndGrd +call RecPrt(' In OvrGrd_McK: A',' ',A,1,3) +call RecPrt(' In OvrGrd_McK: RB',' ',RB,1,3) +call RecPrt(' In OvrGrd_McK: Ccoor',' ',Ccoor,1,3) +call RecPrt(' In OvrGrd_McK: P',' ',P,nZeta,3) +write(u6,*) ' In OvrGrd_McK: la,lb=',la,lb +#endif + +! Compute the cartesian values of the basis functions angular part + +call CrtCmp(Zeta,P,nZeta,A,Array(ipAxyz),la+1,HerR(iHerR(nHer)),nHer,ABeq) +call CrtCmp(Zeta,P,nZeta,RB,Array(ipBxyz),lb+1,HerR(iHerR(nHer)),nHer,ABeq) + +! Compute the contribution from the multipole moment operator + +ABeq(1) = .false. +ABeq(2) = .false. +ABeq(3) = .false. +call CrtCmp(Zeta,P,nZeta,Ccoor,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) + +! Compute the cartesian components for the multipole moment +! integrals. The integrals are factorized into components. + +call Assmbl(Array(ipRnxyz),Array(ipAxyz),la+1,Array(ipRxyz),nOrdOp,Array(ipBxyz),lb+1,nZeta,HerW(iHerW(nHer)),nHer) + +! Combine the cartesian components to the gradient of the one +! electron integral and contract with the Fock matrix. + +ip = ipAlph +do iBeta=1,nBeta + Array(ip:ip+nAlpha-1) = Alpha + ip = ip+nAlpha +end do +ip = ipBeta +do iBeta=1,nBeta + Array(ip:ip+nAlpha-1) = Beta(iBeta) + ip = ip+nAlpha +end do +call CmbnS1_mck(Array(ipRnxyz),nZeta,la,lb,Zeta,rKappa,Array(ipScrt),Array(ipAlph),Array(ipBeta),IfGrad) + +#ifdef _DEBUGPRINT_ +call RecPrt(' Primitive Integrals',' ',Array(ipScrt),nZeta,nTri_Elem1(la)*nTri_Elem1(lb)) +#endif + +! Symmetry adapt the gradient operator + +call SymAdO_mck(Array(ipScrt),nZeta*nTri_Elem1(la)*nTri_Elem1(lb),rFinal,nrOp,nop,IndGrd,iu,iv,ifgrad,idcar,trans) +#ifdef _DEBUGPRINT_ +call RecPrt(' Primitive Integrals SO',' ',rFinal,nZeta,nTri_Elem1(la)*nTri_Elem1(lb)*nrOp) +#endif + +return + +end subroutine OvrGrd_mck diff -Nru openmolcas-22.02/src/mckinley/ovrhss.f openmolcas-22.10/src/mckinley/ovrhss.f --- openmolcas-22.02/src/mckinley/ovrhss.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/ovrhss.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,120 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine Ovrhss( -#define _CALLING_ -#include "hss_interface.fh" - & ) -************************************************************************ -* * -* Object: to compute the gradients of the overlap matrix * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* November '90 * -* Anders Bernhardsson 1995 * -************************************************************************ - use Her_RW - use Center_Info - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - -#include "hss_interface.fh" - -* Local variables - Logical ABeq(3) -* - ABeq(1) = A(1).eq.RB(1) - ABeq(2) = A(2).eq.RB(2) - ABeq(3) = A(3).eq.RB(3) -* - nip = 1 - ipAxyz = nip - nip = nip + nZeta*3*nHer*(la+3) - ipBxyz = nip - nip = nip + nZeta*3*nHer*(lb+3) - ipRxyz = nip - nip = nip + nZeta*3*nHer*(nOrdOp+1) - ipRnxyz = nip - nip = nip + nZeta*3*(la+3)*(lb+3)*(nOrdOp+1) - ipAlph = nip - nip = nip + nZeta - ipBeta = nip - nip = nip + nZeta - If (nip-1.gt.nArr) Then - Write (6,*) 'OvrHss: nip-1.gt.nArr' - Write (6,*) 'nip,nArr=',nip,nArr - Call Abend() - End If -* -#ifdef _DEBUGPRINT_ - Write (6,*) ' IfHss=',IfHss - Write (6,*) ' IndHss=',IndHss - Call RecPrt(' In OvrHss: A',' ',A,1,3) - Call RecPrt(' In OvrHss: RB',' ',RB,1,3) - Call RecPrt(' In OvrHss: Ccoor',' ',Ccoor,1,3) - Call RecPrt(' In OvrHss: P',' ',P,nZeta,3) - Write (6,*) ' In OvrHss: la,lb=',la,lb -#endif -* -* Compute the cartesian values of the basis functions angular part -* - Call CrtCmp(Zeta,P,nZeta,A,Array(ipAxyz), - & la+2,HerR(iHerR(nHer)),nHer,ABeq) - Call CrtCmp(Zeta,P,nZeta,RB,Array(ipBxyz), - & lb+2,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the contribution from the multipole moment operator -* - ABeq(1) = .False. - ABeq(2) = .False. - ABeq(3) = .False. - Call CrtCmp(Zeta,P,nZeta,Ccoor,Array(ipRxyz), - & nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the cartesian components for the multipole moment -* integrals. The integrals are factorized into components. -* - Call Assmbl(Array(ipRnxyz), - & Array(ipAxyz),la+2, - & Array(ipRxyz),nOrdOp, - & Array(ipBxyz),lb+2, - & nZeta,HerW(iHerW(nHer)),nHer) -* -* Combine the cartesian components to the gradient of the one -* electron integral and contract with the Fock matrix. -* - ip = ipAlph - Do 20 iBeta = 1, nBeta - call dcopy_(nAlpha,Alpha,1,Array(ip),1) - ip = ip + nAlpha - 20 Continue - ip = ipBeta - Do 21 iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ip),nAlpha) - ip = ip + 1 - 21 Continue -* - Call CmbnS2(Array(ipRnxyz),nZeta,la,lb,Zeta,rKappa,Final, - & Array(ipAlph),Array(ipBeta),Hess,nHess,DAO, - & IfHss,IndHss,indgrd,dc(mdc)%nStab,dc(ndc)%nStab,nOp) -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(ZInv) - Call Unused_logical_array(ifgrd) - Call Unused_integer_array(lOper) - Call Unused_integer_array(iStabM) - Call Unused_integer(nStabM) - End If - End diff -Nru openmolcas-22.02/src/mckinley/ovrhss.F90 openmolcas-22.10/src/mckinley/ovrhss.F90 --- openmolcas-22.02/src/mckinley/ovrhss.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/ovrhss.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,114 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Roland Lindh * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine Ovrhss( & +# define _CALLING_ +# include "hss_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the gradients of the overlap matrix * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! November '90 * +! Anders Bernhardsson 1995 * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Her_RW, only: HerR, HerW, iHerR, iHerW +use Center_Info, only: dc +use Definitions, only: wp, iwp, u6 + +implicit none +#include "hss_interface.fh" +integer(kind=iwp) :: iBeta, ip, ipAlph, ipAxyz, ipBeta, ipBxyz, ipRnxyz, ipRxyz, nip +logical(kind=iwp) :: ABeq(3) + +#include "macros.fh" +unused_var(ZInv) +unused_var(ifgrd) +unused_var(lOper) +unused_var(iStabM) +unused_var(nStabM) + +ABeq(1) = A(1) == RB(1) +ABeq(2) = A(2) == RB(2) +ABeq(3) = A(3) == RB(3) + +nip = 1 +ipAxyz = nip +nip = nip+nZeta*3*nHer*(la+3) +ipBxyz = nip +nip = nip+nZeta*3*nHer*(lb+3) +ipRxyz = nip +nip = nip+nZeta*3*nHer*(nOrdOp+1) +ipRnxyz = nip +nip = nip+nZeta*3*(la+3)*(lb+3)*(nOrdOp+1) +ipAlph = nip +nip = nip+nZeta +ipBeta = nip +nip = nip+nZeta +if (nip-1 > nArr) then + write(u6,*) 'OvrHss: nip-1 > nArr' + write(u6,*) 'nip,nArr=',nip,nArr + call Abend() +end if + +#ifdef _DEBUGPRINT_ +write(u6,*) ' IfHss=',IfHss +write(u6,*) ' IndHss=',IndHss +call RecPrt(' In OvrHss: A',' ',A,1,3) +call RecPrt(' In OvrHss: RB',' ',RB,1,3) +call RecPrt(' In OvrHss: Ccoor',' ',Ccoor,1,3) +call RecPrt(' In OvrHss: P',' ',P,nZeta,3) +write(u6,*) ' In OvrHss: la,lb=',la,lb +#endif + +! Compute the cartesian values of the basis functions angular part + +call CrtCmp(Zeta,P,nZeta,A,Array(ipAxyz),la+2,HerR(iHerR(nHer)),nHer,ABeq) +call CrtCmp(Zeta,P,nZeta,RB,Array(ipBxyz),lb+2,HerR(iHerR(nHer)),nHer,ABeq) + +! Compute the contribution from the multipole moment operator + +ABeq(1) = .false. +ABeq(2) = .false. +ABeq(3) = .false. +call CrtCmp(Zeta,P,nZeta,Ccoor,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) + +! Compute the cartesian components for the multipole moment +! integrals. The integrals are factorized into components. + +call Assmbl(Array(ipRnxyz),Array(ipAxyz),la+2,Array(ipRxyz),nOrdOp,Array(ipBxyz),lb+2,nZeta,HerW(iHerW(nHer)),nHer) + +! Combine the cartesian components to the gradient of the one +! electron integral and contract with the Fock matrix. + +ip = ipAlph +do iBeta=1,nBeta + Array(ip:ip+nAlpha-1) = Alpha + ip = ip+nAlpha +end do +ip = ipBeta +do iBeta=1,nBeta + Array(ip:ip+nAlpha-1) = Beta(iBeta) + ip = ip+nAlpha +end do + +call CmbnS2(Array(ipRnxyz),nZeta,la,lb,Zeta,rKappa,rFinal,Array(ipAlph),Hess,nHess,DAO,IfHss,IndHss,indgrd,dc(mdc)%nStab, & + dc(ndc)%nStab,nOp) + +return + +end subroutine Ovrhss diff -Nru openmolcas-22.02/src/mckinley/ovrmem_mck.f openmolcas-22.10/src/mckinley/ovrmem_mck.f --- openmolcas-22.02/src/mckinley/ovrmem_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/ovrmem_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine OvrMem_mck(nHer,MmMltP,la,lb,lr) -* - nElem(i) = (i+1)*(i+2)/2 - -* - lr=0 - nHer=(la+lb+lr+3)/2 - MmMltP = 3*nHer*(la+2) + - & 3*nHer*(lb+2) + - & 3*nHer*(lr+2) + - & 3*(la+2)*(lb+2)*(lr+1)+2 + - & nelem(la)*nelem(lb)*2 -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/ovrmem_mck.F90 openmolcas-22.10/src/mckinley/ovrmem_mck.F90 --- openmolcas-22.02/src/mckinley/ovrmem_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/ovrmem_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,33 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine OvrMem_mck( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: lr_ + +#include "macros.fh" +unused_var(lr) + +lr_ = 0 +nHer = (la+lb+lr_+3)/2 +Mem = 3*nHer*(la+2)+3*nHer*(lb+2)+3*nHer*(lr_+2)+3*(la+2)*(lb+2)*(lr_+1)+2+nTri_Elem1(la)*nTri_Elem1(lb)*2 + +return + +end subroutine OvrMem_mck diff -Nru openmolcas-22.02/src/mckinley/ovrmmh.f openmolcas-22.10/src/mckinley/ovrmmh.f --- openmolcas-22.02/src/mckinley/ovrmmh.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/ovrmmh.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine OvrMmH(nHer,MmOvrH,la,lb,lr) -* - nHer=(la+lb+1+4)/2 - MmOvrH = 3*nHer*(la+3) + - & 3*nHer*(lb+3) + - & 3*nHer + - & 3*(la+3)*(lb+3) + 2 -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(lr) - End diff -Nru openmolcas-22.02/src/mckinley/ovrmmh.F90 openmolcas-22.10/src/mckinley/ovrmmh.F90 --- openmolcas-22.02/src/mckinley/ovrmmh.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/ovrmmh.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,30 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine OvrMmH( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" + +#include "macros.fh" +unused_var(lr) + +nHer = (la+lb+1+4)/2 +Mem = 3*nHer*(la+3)+3*nHer*(lb+3)+3*nHer+3*(la+3)*(lb+3)+2 + +return + +end subroutine OvrMmH diff -Nru openmolcas-22.02/src/mckinley/pckint_mck.f openmolcas-22.10/src/mckinley/pckint_mck.f --- openmolcas-22.02/src/mckinley/pckint_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/pckint_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SubRoutine PckInt_mck(abab,nZeta,nab,ab,Zeta) - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - Real*8 abab(nZeta,nab,nab), ab(nZeta), Zeta(nZeta) -* -*--------Integrals -* -* -* - Do iZeta=1,nZeta - xMax=0.0d0 - Do iab = 1, nab - xTest = Abs(abab(iZeta,iab,iab)) - If (xTest.gt.xMax) Then - xMax = xTest - End If - End Do - ab(iZeta) = Sqrt(xMax) - End Do -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_real_array(Zeta) - End diff -Nru openmolcas-22.02/src/mckinley/pckint_mck.F90 openmolcas-22.10/src/mckinley/pckint_mck.F90 --- openmolcas-22.02/src/mckinley/pckint_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/pckint_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,37 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine PckInt_mck(abab,nZeta,nab,ab) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, nab +real(kind=wp), intent(in) :: abab(nZeta,nab,nab) +real(kind=wp), intent(out) :: ab(nZeta) +integer(kind=iwp) :: iab, iZeta +real(kind=wp) :: xMax, xTest + +! Integrals + +do iZeta=1,nZeta + xMax = Zero + do iab=1,nab + xTest = abs(abab(iZeta,iab,iab)) + if (xTest > xMax) xMax = xTest + end do + ab(iZeta) = sqrt(xMax) +end do + +return + +end subroutine PckInt_mck diff -Nru openmolcas-22.02/src/mckinley/pckmo2.f openmolcas-22.10/src/mckinley/pckmo2.f --- openmolcas-22.02/src/mckinley/pckmo2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/pckmo2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SubRoutine PckMO2(COUT,nAcO,icmpi,iBasi,jcmpj,jBasj,iAOi,jAOj) - use Basis_Info, only: nBas - use SOAO_Info, only: iAOtSO - use pso_stuff - use Symmetry_Info, only: nIrrep - Implicit Real*8 (a-h,o-z) -#include "etwas.fh" -#include "real.fh" - Real*8 COUT(*) - Integer iCmp(4),nBs(4) - Integer iaoii(4) -* - nBs(1)=iBasi - nBs(2)=jBasj - iAOii(1)=iAOi - iAOii(2)=jAOj - icmp(1)=icmpi - icmp(2)=jcmpj - ip2=1 - - Do iCnt=1,2 - ipC=0 - Do iIrrep=0,nIrrep-1 - iOrb=nIsh(iIrrep) - Do iAsh=1,nAsh(iIrrep) - jj=iCmp(iCnt) - Do i1=1,jj - iSO=iAOtSO(iAOii(iCnt)+i1,iIrrep) - If (iSO>0) Then - ip1=ipC+(iOrb+iAsh-1)*nBas(iIrrep)+iso - call dcopy_(nBs(iCnt),CMO(ip1,1),1,COUT(ip2),1) - Else - call dcopy_(nBs(iCnt),[0.0d0],0,COUT(ip2),1) - End If - ip2=ip2+nBs(iCnt) - End Do - End Do - ipc=ipc+nBas(iIrrep)**2 - End Do - End Do -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(nAcO) - End diff -Nru openmolcas-22.02/src/mckinley/pckmo2.F90 openmolcas-22.10/src/mckinley/pckmo2.F90 --- openmolcas-22.02/src/mckinley/pckmo2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/pckmo2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,60 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine PckMO2(COUT,icmpi,iBasi,jcmpj,jBasj,iAOi,jAOj) + +use Basis_Info, only: nBas +use SOAO_Info, only: iAOtSO +use pso_stuff, only: CMO +use Symmetry_Info, only: nIrrep +use Constants, only: Zero +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +real(kind=wp), intent(_OUT_) :: COUT(*) +integer(kind=iwp), intent(in) :: icmpi, iBasi, jcmpj, jBasj, iAOi, jAOj +#include "etwas.fh" +integer(kind=iwp) :: i1, iaoii(4), iAsh, iCmp(4), iCnt, iIrrep, iOrb, ip1, ip2, ipC, iSO, jj, nBs(4) + +nBs(1) = iBasi +nBs(2) = jBasj +iAOii(1) = iAOi +iAOii(2) = jAOj +icmp(1) = icmpi +icmp(2) = jcmpj +ip2 = 1 + +do iCnt=1,2 + ipC = 0 + do iIrrep=0,nIrrep-1 + iOrb = nIsh(iIrrep) + do iAsh=1,nAsh(iIrrep) + jj = iCmp(iCnt) + do i1=1,jj + iSO = iAOtSO(iAOii(iCnt)+i1,iIrrep) + if (iSO > 0) then + ip1 = ipC+(iOrb+iAsh-1)*nBas(iIrrep)+iso + COUT(ip2:ip2+nBs(iCnt)-1) = CMO(ip1:ip1+nBs(iCnt)-1,1) + else + COUT(ip2:ip2+nBs(iCnt)-1) = Zero + end if + ip2 = ip2+nBs(iCnt) + end do + end do + ipc = ipc+nBas(iIrrep)**2 + end do +end do + +return + +end subroutine PckMO2 diff -Nru openmolcas-22.02/src/mckinley/pickmo.f openmolcas-22.10/src/mckinley/pickmo.f --- openmolcas-22.02/src/mckinley/pickmo.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/pickmo.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,58 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SubRoutine PickMO(COUT,nOut,nAcO,icmp,iBasi,iBasn,jBasj,jBasn, - & kBask,kBasn,lBasl,lBasn,iaoii) - use Basis_Info, only: nBas - use SOAO_Info, only: iAOtSO - use pso_stuff - use Symmetry_Info, only: nIrrep - Implicit Real*8 (a-h,o-z) -#include "etwas.fh" -#include "real.fh" - Real*8 COUT(nOut) - Integer iCmp(4),iBas(4),nBs(4) - Integer iAOii(4) -* - iBas(1)=iBasi - iBas(2)=jBasj - iBas(3)=kBask - iBas(4)=lBasl - nBs(1)=iBasn - nBs(2)=jBasn - nBs(3)=kBasn - nBs(4)=lBasn - ip2=1 - - Do iCnt=3,4 - ipC=0 - Do iIrrep=0,nIrrep-1 - iOrb=nIsh(iIrrep) - Do iAsh=1,nAsh(iIrrep) - jj=iCmp(iCnt) - Do i1=1,jj - iSO=iAOtSO(iAOii(iCnt)+i1,iIrrep)+iBas(iCnt)-1 - If (iSO>0) Then - ip1=ipC+(iOrb+iAsh-1)*nBas(iIrrep)+iSO - call dcopy_(nBs(iCnt),CMO(ip1,1),1,COUT(ip2),1) - Else - call dcopy_(nBs(iCnt),[0.0d0],0,COUT(ip2),1) - End If - ip2=ip2+nBs(iCnt) - End Do - End Do - ipc=ipc+nBas(iIrrep)**2 - End Do - End Do -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(nAcO) - End diff -Nru openmolcas-22.02/src/mckinley/pickmo.F90 openmolcas-22.10/src/mckinley/pickmo.F90 --- openmolcas-22.02/src/mckinley/pickmo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/pickmo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,62 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine PickMO(COUT,nOut,icmp,iBasi,iBasn,jBasj,jBasn,kBask,kBasn,lBasl,lBasn,iaoii) + +use Basis_Info, only: nBas +use SOAO_Info, only: iAOtSO +use pso_stuff, only: CMO +use Symmetry_Info, only: nIrrep +use Constants, only: Zero +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: nOut, iCmp(4), iBasi, iBasn, jBasj, jBasn, kBask, kBasn, lBasl, lBasn, iAOii(4) +real(kind=wp), intent(_OUT_) :: COUT(nOut) +#include "etwas.fh" +integer(kind=iwp) :: i1, iAsh, iBas(4), iCnt, iIrrep, iOrb, ip1, ip2, ipC, iSO, jj, nBs(4) + +iBas(1) = iBasi +iBas(2) = jBasj +iBas(3) = kBask +iBas(4) = lBasl +nBs(1) = iBasn +nBs(2) = jBasn +nBs(3) = kBasn +nBs(4) = lBasn +ip2 = 1 + +do iCnt=3,4 + ipC = 0 + do iIrrep=0,nIrrep-1 + iOrb = nIsh(iIrrep) + do iAsh=1,nAsh(iIrrep) + jj = iCmp(iCnt) + do i1=1,jj + iSO = iAOtSO(iAOii(iCnt)+i1,iIrrep)+iBas(iCnt)-1 + if (iSO > 0) then + ip1 = ipC+(iOrb+iAsh-1)*nBas(iIrrep)+iSO + COUT(ip2:ip2+nBs(iCnt)-1) = CMO(ip1:ip1+nBs(iCnt)-1,1) + else + COUT(ip2:ip2+nBs(iCnt)-1) = Zero + end if + ip2 = ip2+nBs(iCnt) + end do + end do + ipc = ipc+nBas(iIrrep)**2 + end do +end do + +return + +end subroutine PickMO diff -Nru openmolcas-22.02/src/mckinley/prjgrd_mck.f openmolcas-22.10/src/mckinley/prjgrd_mck.f --- openmolcas-22.02/src/mckinley/prjgrd_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/prjgrd_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,239 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1993, Roland Lindh * -************************************************************************ - SubRoutine PrjGrd_mck( -#define _CALLING_ -#include "grd_mck_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of ECP integrals. * -* * -* Alpha : exponents of bra gaussians * -* nAlpha: number of primitives (exponents) of bra gaussians * -* Beta : as Alpha but for ket gaussians * -* nBeta : as nAlpha but for the ket gaussians * -* Zeta : sum of exponents (nAlpha x nBeta) * -* ZInv : inverse of Zeta * -* rKappa: gaussian prefactor for the products of bra and ket * -* gaussians. * -* P : center of new gaussian from the products of bra and ket * -* gaussians. * -* Final : array for computed integrals * -* nZeta : nAlpha x nBeta * -* nComp : number of components in the operator (e.g. dipolmoment * -* operator has three components) * -* la : total angular momentum of bra gaussian * -* lb : total angular momentum of ket gaussian * -* A : center of bra gaussian * -* B : center of ket gaussian * -* nRys : order of Rys- or Hermite-Gauss polynomial * -* Array : Auxiliary memory as requested by ECPMem * -* nArr : length of Array * -* Ccoor : coordinates of the operator, zero for symmetric oper. * -* NOrdOp: Order of the operator * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, Sweden, and Per Boussard, Dept. of Theoretical * -* Physics, University of Stockholm, Sweden, October 1993. * -************************************************************************ - use Basis_Info - use Center_Info - use Real_Spherical - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "real.fh" -#include "disp.fh" - -#include "grd_mck_interface.fh" - -* Local variables - Real*8 C(3), TC(3) - Integer iDCRT(0:7), iuvwx(4), mOp(4), index(3,4), JndGrd(3,4,0:7) - Logical JfGrad(3,4), EQ, DiffCnt,tr(4),ifg(4),ifhess_dum(3,4,3,4) - Real*8 Dum(1) -* * -************************************************************************ -* * -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* * -************************************************************************ -* * - iuvwx(1) = iu - iuvwx(2) = iv - mop(1) = nOp(1) - mop(2) = nOp(2) - DiffCnt=(IfGrad(iDCar,1).or.IfGrad(iDCar,2)) - -#ifdef _DEBUGPRINT_ - Call RecPrt(' In PrjGrd: A',' ',A,1,3) - Call RecPrt(' In PrjGrd: RB',' ',RB,1,3) - Call RecPrt(' In PrjGrd: P',' ',P,nZeta,3) - Call RecPrt(' In PrjGrd: Alpha',' ',Alpha,nAlpha,1) - Call RecPrt(' In PrjGrd: Beta',' ',Beta,nBeta,1) - Write (6,*) ' In PrjGrd: la,lb=',' ',la,lb - Write (6,*) ' In PrjGrd: Diffs=',' ', - & IfGrad(iDCar,1),IfGrad(iDCar,2) - Write (6,*) ' In PrjGrd: Center=',' ',iDCNT -#endif - - kdc = 0 - Do 1960 kCnttp = 1, nCnttp - If (.Not.dbsc(kCnttp)%ECP) Go To 1961 - If (dbsc(kCnttp)%nSRO.le.0) Go To 1961 - - Do 1965 kCnt = 1,dbsc(kCnttp)%nCntr - If ((.not.DiffCnt).and.((kdc+kCnt).ne.iDCnt)) Goto 1965 - - C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) -* - Call DCR(LmbdT,iStabM,nStabM, - & dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) - Fact = DBLE(nStabM) / DBLE(LmbdT) - iuvwx(3) = dc(kdc+kCnt)%nStab - iuvwx(4) = dc(kdc+kCnt)%nStab - - Call LCopy(12,[.false.],0,JFgrad,1) - Call LCopy(4 ,[.false.],0,iFg,1) - Call LCopy(4 ,[.false.],0,tr,1) - Call ICopy(12*nIrrep,[0],0,jndGrd,1) - Do iCnt = 1, 2 - JfGrad(iDCar,iCnt) = IfGrad(iDCar,iCnt) - End Do - Do ICnt=1,2 - If (ifgrad(idcar,iCnt)) Then - ifg(icnt)=.true. - Do iIrrep=0,nIrrep-1 - jndGrd(iDCar,iCnt,iIrrep)=IndGrd(iIrrep) - End Do - End IF - End Do - -* - If ((kdc+kCnt).eq.iDCnt) Then - ifg(1)=.true. - ifg(2)=.true. - Tr(3)=.true. - JfGrad(iDCar,1) = .true. - JfGrad(iDCar,2) = .true. - Do iIrrep=0,nIrrep-1 - jndGrd(iDCar,3,iIrrep) = - IndGrd(iIrrep) - End Do - End If - -* - Do 1967 lDCRT = 0, nDCRT-1 - - mop(3)=nropr(iDCRT(lDCRT)) - mop(4)=mop(3) - Call OA(iDCRT(lDCRT),C,TC) - - If (EQ(A,RB).and.EQ(A,TC)) Go To 1967 - - Do 1966 iAng = 0, dbsc(kCnttp)%nPrj-1 - iShll = dbsc(kCnttp)%iPrj + iAng - nExpi=Shells(iShll)%nExp - nBasisi=Shells(iShll)%nBasis -#ifdef _DEBUGPRINT_ - Write (6,*) 'nExp(iShll)=',nExpi - Write (6,*) 'nBasisi=',nBasisi - Write (6,*) ' iAng=',iAng - Call RecPrt('TC',' ',TC,1,3) -#endif - - If (nExpi.eq.0 .or. nBasisi.eq.0) Go To 1966 -* - ip=1 - - ipFin= ip - ip=ip+nZeta*(la+1)*(la+2)/2*(lb+1)*(lb+2)/2*6 - - ipFA1 = ip - ip = ip + nAlpha*nExpi*nElem(la)*nElem(iAng)*4 - - ipFB1 = ip - ip = ip + nExpi*nBeta*nElem(iAng)*nElem(lb)*4 - - ipFB2 = ip - ipFA2 = ip - if (ip.ge.narr) then - write(6,*) 'No mem in prjgrd',ip,narr - call abend() - endif - - call dcopy_(nArr,[0.0d0],0,Array,1) - -* -#ifdef _DEBUGPRINT_ - Call Acore(iang,la,ishll,nordop,TC,A,Array(ip), - & narr-ip+1,Alpha,nalpha,Array(ipFA1), - & array(ipFA2),jfgrad(1,1),ifhess_dum, - & 1,.TRUE.) -#else - Call Acore(iang,la,ishll,nordop,TC,A,Array(ip), - & narr-ip+1,Alpha,nalpha,Array(ipFA1), - & array(ipFA2),jfgrad(1,1),ifhess_dum, - & 1,.FALSE.) -#endif - call LToCore(Array(ipFA1),nalpha,ishll,la,iAng, 4) - - - -#ifdef _DEBUGPRINT_ - Call coreB(iang,lb,ishll,nordop,TC,RB,Array(ip), - & narr-ip+1,Beta,nbeta,Array(ipFB1), - & array(ipFB2),jfgrad(1,2),ifhess_dum,1, - & .TRUE.) -#else - Call coreB(iang,lb,ishll,nordop,TC,RB,Array(ip), - & narr-ip+1,Beta,nbeta,Array(ipFB1), - & array(ipFB2),jfgrad(1,2),ifhess_dum,1, - & .FALSE.) -#endif - call RToCore(Array(ipFB1),nBeta,ishll,lb,iAng,4) - - - - call CmbnACB1(Array(ipFA1),Array(ipFB1),Array(ipFin), - & Fact,nAlpha,nBeta,Dum,nBasisi, - & la,lb,iang,jfgrad,Dum,.false., - & index,mvec,idcar) - - - nt=nAlpha*nBeta*nElem(lb)*nElem(la) - Call SmAdNa(Array(ipFin),nt,Final, - & mop,loper,JndGrd,iuvwx,JfGrad,index, - & idcar,1.0d0,iFG,tr) - - - 1966 Continue - 1967 Continue - 1965 Continue - 1961 Continue - kdc = kdc + dbsc(kCnttp)%nCntr - 1960 Continue -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Zeta) - Call Unused_real_array(ZInv) - Call Unused_real_array(rKappa) - Call Unused_real_array(P) - Call Unused_integer(nHer) - Call Unused_real_array(Ccoor) - Call Unused_logical_array(Trans) - End If - End diff -Nru openmolcas-22.02/src/mckinley/prjgrd_mck.F90 openmolcas-22.10/src/mckinley/prjgrd_mck.F90 --- openmolcas-22.02/src/mckinley/prjgrd_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/prjgrd_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,174 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993, Roland Lindh * +! 1993, Per Boussard * +!*********************************************************************** + +subroutine PrjGrd_mck( & +# define _CALLING_ +# include "grd_mck_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of ECP integrals. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, Sweden, and Per Boussard, Dept. of Theoretical * +! Physics, University of Stockholm, Sweden, October 1993. * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Basis_Info, only: dbsc, nCnttp, Shells +use Center_Info, only: dc +use Symmetry_Info, only: nIrrep +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +#include "grd_mck_interface.fh" +integer(kind=iwp) :: iAng, iCnt, iDCRT(0:7), Indx(3,4), ip, ipFA1, ipFA2, ipFB1, ipFB2, ipFin, iShll, iuvwx(4), JndGrd(3,4,0:7), & + kCnt, kCnttp, kdc, lDCRT, LmbdT, mOp(4), mvec, nBasisi, nDCRT, nExpi, nt +real(kind=wp) C(3), Dum(1), Fact, TC(3) +logical(kind=iwp) :: DiffCnt, ifhess_dum(3,4,3,4), JfGrad(3,4), tr(4) +integer(kind=iwp), external :: NrOpr +logical(kind=iwp), external :: EQ + +#include "macros.fh" +unused_var(Zeta) +unused_var(ZInv) +unused_var(rKappa) +unused_var(P) +unused_var(nHer) +unused_var(Ccoor) +unused_var(Trans) +! * +!*********************************************************************** +! * +iuvwx(1) = iu +iuvwx(2) = iv +mop(1) = nOp(1) +mop(2) = nOp(2) +DiffCnt = IfGrad(iDCar,1) .or. IfGrad(iDCar,2) + +#ifdef _DEBUGPRINT_ +call RecPrt(' In PrjGrd_McK: A',' ',A,1,3) +call RecPrt(' In PrjGrd_McK: RB',' ',RB,1,3) +!call RecPrt(' In PrjGrd_McK: P',' ',P,nZeta,3) +call RecPrt(' In PrjGrd_McK: Alpha',' ',Alpha,nAlpha,1) +call RecPrt(' In PrjGrd_McK: Beta',' ',Beta,nBeta,1) +write(u6,*) ' In PrjGrd_McK: la,lb=',' ',la,lb +write(u6,*) ' In PrjGrd_McK: Diffs=',' ',IfGrad(iDCar,1),IfGrad(iDCar,2) +write(u6,*) ' In PrjGrd_McK: Center=',' ',iDCNT +#endif + +kdc = 0 +do kCnttp=1,nCnttp + if (kCnttp > 1) kdc = kdc+dbsc(kCnttp-1)%nCntr + if (.not. dbsc(kCnttp)%ECP) cycle + if (dbsc(kCnttp)%nSRO <= 0) cycle + + do kCnt=1,dbsc(kCnttp)%nCntr + if ((.not. DiffCnt) .and. (kdc+kCnt /= iDCnt)) cycle + + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + + call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) + Fact = real(nStabM,kind=wp)/real(LmbdT,kind=wp) + iuvwx(3) = dc(kdc+kCnt)%nStab + iuvwx(4) = dc(kdc+kCnt)%nStab + + JfGrad(:,:) = .false. + tr(:) = .false. + JndGrd(:,:,0:nIrrep-1) = 0 + JfGrad(iDCar,1:2) = IfGrad(iDCar,1:2) + do ICnt=1,2 + if (IfGrad(idcar,iCnt)) JndGrd(iDCar,iCnt,0:nIrrep-1) = IndGrd(0:nIrrep-1) + end do + + if ((kdc+kCnt) == iDCnt) then + Tr(3) = .true. + JfGrad(iDCar,1:2) = .true. + JndGrd(iDCar,3,0:nIrrep-1) = -IndGrd(0:nIrrep-1) + end if + + do lDCRT=0,nDCRT-1 + + mop(3) = nropr(iDCRT(lDCRT)) + mop(4) = mop(3) + call OA(iDCRT(lDCRT),C,TC) + + if (EQ(A,RB) .and. EQ(A,TC)) cycle + + do iAng=0,dbsc(kCnttp)%nPrj-1 + iShll = dbsc(kCnttp)%iPrj+iAng + nExpi = Shells(iShll)%nExp + nBasisi = Shells(iShll)%nBasis +# ifdef _DEBUGPRINT_ + write(u6,*) 'nExp(iShll)=',nExpi + write(u6,*) 'nBasisi=',nBasisi + write(u6,*) ' iAng=',iAng + call RecPrt('TC',' ',TC,1,3) +# endif + + if ((nExpi == 0) .or. (nBasisi == 0)) cycle + + ip = 1 + + ipFin = ip + ip = ip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb)*6 + + ipFA1 = ip + ip = ip+nAlpha*nExpi*nTri_Elem1(la)*nTri_Elem1(iAng)*4 + + ipFB1 = ip + ip = ip+nExpi*nBeta*nTri_Elem1(iAng)*nTri_Elem1(lb)*4 + + ipFB2 = ip + ipFA2 = ip + if (ip >= narr) then + write(u6,*) 'No mem in PrjGrd_McK',ip,narr + call abend() + end if + + Array(:) = Zero + +# ifdef _DEBUGPRINT_ + call Acore(iang,la,ishll,nordop,TC,A,Array(ip),narr-ip+1,Alpha,nalpha,Array(ipFA1),array(ipFA2),jfgrad(1,1),ifhess_dum,1, & + .true.) +# else + call Acore(iang,la,ishll,nordop,TC,A,Array(ip),narr-ip+1,Alpha,nalpha,Array(ipFA1),array(ipFA2),jfgrad(1,1),ifhess_dum,1, & + .false.) +# endif + call LToCore(Array(ipFA1),nalpha,ishll,la,iAng,4) + +# ifdef _DEBUGPRINT_ + call coreB(iang,lb,ishll,nordop,TC,RB,Array(ip),narr-ip+1,Beta,nbeta,Array(ipFB1),array(ipFB2),jfgrad(1,2),ifhess_dum,1, & + .true.) +# else + call coreB(iang,lb,ishll,nordop,TC,RB,Array(ip),narr-ip+1,Beta,nbeta,Array(ipFB1),array(ipFB2),jfgrad(1,2),ifhess_dum,1, & + .false.) +# endif + call RToCore(Array(ipFB1),nBeta,ishll,lb,iAng,4) + + call CmbnACB1(Array(ipFA1),Array(ipFB1),Array(ipFin),Fact,nAlpha,nBeta,Dum,nBasisi,la,lb,iang,jfgrad,Dum,.false.,Indx, & + mvec,idcar) + + nt = nAlpha*nBeta*nTri_Elem1(lb)*nTri_Elem1(la) + call SmAdNa(Array(ipFin),nt,rFinal,mop,loper,JndGrd,iuvwx,Indx,idcar,One,tr) + + end do + end do + end do +end do + +return + +end subroutine PrjGrd_mck diff -Nru openmolcas-22.02/src/mckinley/prjhss.f openmolcas-22.10/src/mckinley/prjhss.f --- openmolcas-22.02/src/mckinley/prjhss.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/prjhss.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,188 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1993, Roland Lindh * -************************************************************************ - SubRoutine PrjHss( -#define _CALLING_ -#include "hss_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of ECP integrals. * -* * -* Alpha : exponents of bra gaussians * -* nAlpha: number of primitives (exponents) of bra gaussians * -* Beta : as Alpha but for ket gaussians * -* nBeta : as nAlpha but for the ket gaussians * -* Zeta : sum of exponents (nAlpha x nBeta) * -* ZInv : inverse of Zeta * -* rKappa: gaussian prefactor for the products of bra and ket * -* gaussians. * -* P : center of new gaussian from the products of bra and ket * -* gaussians. * -* Final : array for computed integrals * -* nZeta : nAlpha x nBeta * -* nComp : number of components in the operator (e.g. dipolmoment * -* operator has three components) * -* la : total angular momentum of bra gaussian * -* lb : total angular momentum of ket gaussian * -* A : center of bra gaussian * -* B : center of ket gaussian * -* nRys : order of Rys- or Hermite-Gauss polynomial * -* Array : Auxiliary memory as requested by ECPMem * -* nArr : length of Array * -* Ccoor : coordinates of the operator, zero for symmetric oper. * -* NOrdOp: Order of the operator * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, Sweden, and Per Boussard, Dept. of Theoretical * -* Physics, University of Stockholm, Sweden, October 1993. * -************************************************************************ - use Basis_Info - use Center_Info - use Real_Spherical - use Symmetry_Info, only: iOper - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "real.fh" -#include "disp.fh" -#include "disp2.fh" - -#include "hss_interface.fh" - -* Local variables - Real*8 C(3), TC(3), Coor(3,4), g2(78) - Integer iDCRT(0:7), iuvwx(4), kOp(4), mOp(4), - & JndGrd(3,4,0:7), jndhss(4,3,4,3,0:7) - Logical JfGrd(3,4), EQ, jfhss(4,3,4,3),ifg(4),tr(4) - Dimension Dum(1) - - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - -* - nRys=nHer -* - iuvwx(1) = dc(mdc)%nStab - iuvwx(2) = dc(ndc)%nStab - call icopy(2,nop,1,mop,1) - kOp(1) = iOper(nOp(1)) - kOp(2) = iOper(nOp(2)) - -* - call dcopy_(3,A,1,Coor(1,1),1) - call dcopy_(3,RB,1,Coor(1,2),1) - - kdc = 0 - Do 1960 kCnttp = 1, nCnttp - If (.Not.dbsc(kCnttp)%ECP) Go To 1961 - Do 1965 kCnt = 1,dbsc(kCnttp)%nCntr - C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) -* - Call DCR(LmbdT,iStabM,nStabM, - & dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) - Fact = DBLE(nStabM) / DBLE(LmbdT) -* - iuvwx(3) = dc(kdc+kCnt)%nStab - iuvwx(4) = dc(kdc+kCnt)%nStab - - -* - Do 1967 lDCRT = 0, nDCRT-1 - kOp(3) = iDCRT(lDCRT) - kOp(4) = kOp(3) - mop(3) = nropr(kop(3)) - mop(4) = mop(3) - Call OA(iDCRT(lDCRT),C,TC) - call dcopy_(3,TC,1,Coor(1,3),1) - - If (EQ(A,RB).and.EQ(A,TC)) Go To 1967 - Call NucInd(coor,kdc+kCnt,ifgrd,ifhss,indgrd,indhss, - & jfgrd,jfhss,jndgrd,jndhss,tr,ifg) - Do 1966 iAng = 0, dbsc(kCnttp)%nPrj-1 - iShll = dbsc(kCnttp)%iPrj + iAng - nExpi=Shells(iShll)%nExp - nBasisi=Shells(iShll)%nBasis - If (nExpi.eq.0 .or. nBasisi.eq.0) Go To 1966 -* - ip = 1 - - ipFin = ip - ip = ip + nZeta*nElem(la)*nElem(lb)*21 - - ipFA1 = ip - ip = ip + nAlpha*nExpi*nElem(la)*nElem(iAng)*4 - - ipFA2 = ip - ip = ip + nAlpha*nExpi*nElem(la)*nElem(iAng)*6 - - ipFB1 = ip - ip = ip + nExpi*nBeta*nElem(iAng)*nElem(lb)*4 - - ipFB2 = ip - ip = ip + nExpi*nBeta*nElem(iAng)*nElem(lb)*6 - - call dcopy_(nArr,[0.0d0],0,Array,1) -* ,, - Call Acore(iang,la,ishll,nordop,TC,A,Array(ip), - & narr-ip+1,Alpha,nalpha,Array(ipFA1), - & array(ipfa2),jfgrd(1,1),jfhss, - & 2,.false.) -* Transform to core orbital - call LToCore(Array(ipFA1),nalpha,ishll,la,iAng, 4) - call LToCore(Array(ipFA2),nalpha,ishll,la,iAng, 6) -* ,, - Call coreB(iang,lb,ishll,nordop,TC,RB,Array(ip), - & narr-ip+1,Beta,nbeta,Array(ipFB1), - & array(ipfb2),jfgrd(1,2),jfhss, - & 2,.false.) -* Transform to core orbital - call RToCore(Array(ipFB1),nbeta,ishll,lb,iAng, 4) - call RToCore(Array(ipFB2),nbeta,ishll,lb,iAng, 6) -* Construct complete derivative (contract core) - Call CmbnACB2(Array(ipFa1),Array(ipFa2),Array(ipFb1), - & Array(ipFb2),Array(ipFin),Fact, - & nalpha,nbeta, - & Dum,nBasisi, - & la,lb,iang,jfhss,dum,.false.) - -* contract density - nt=nZeta*(la+1)*(la+2)/2*(lb+1)*(lb+2)/2 - call dcopy_(78,[0.0d0],0,g2,1) - Call dGeMV_('T',nT,21, - & One,Array(ipFin),nT, - & DAO,1, - & Zero,g2,1) - -* distribute in hessian - Call Distg2(g2,Hess,nHess,JndGrd, - & JfHss,JndHss,iuvwx,kOp,mop, - & Tr,IfG) - -* - 1966 Continue !iang - 1967 Continue !DCR - 1965 Continue !cnt - 1961 Continue !cont - kdc = kdc + dbsc(kCnttp)%nCntr - 1960 Continue !cnttp - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Zeta) - Call Unused_real_array(ZInv) - Call Unused_real_array(rKappa) - Call Unused_real_array(P) - Call Unused_real_array(Final) - Call Unused_integer(nRys) - Call Unused_real_array(Ccoor) - Call Unused_integer_array(lOper) - End If - End diff -Nru openmolcas-22.02/src/mckinley/prjhss.F90 openmolcas-22.10/src/mckinley/prjhss.F90 --- openmolcas-22.02/src/mckinley/prjhss.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/prjhss.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,139 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993, Roland Lindh * +! 1993, Per Boussard * +!*********************************************************************** + +subroutine PrjHss( & +# define _CALLING_ +# include "hss_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of ECP integrals. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, Sweden, and Per Boussard, Dept. of Theoretical * +! Physics, University of Stockholm, Sweden, October 1993. * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Basis_Info, only: dbsc, nCnttp, Shells +use Center_Info, only: dc +use Symmetry_Info, only: iOper +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +#include "hss_interface.fh" +integer(kind=iwp) :: iAng, iDCRT(0:7), ip, ipFA1, ipFA2, ipFB1, ipFB2, ipFin, iShll, iuvwx(4), JndGrd(3,4,0:7), & + jndhss(4,3,4,3,0:7), kCnt, kCnttp, kdc, kOp(4), lDCRT, LmbdT, mOp(4), nBasisi, nDCRT, nExpi, nt +real(kind=wp) :: C(3), Coor(3,4), Dum(1), Fact, g2(78), TC(3) +logical(kind=iwp) :: ifg(4), JfGrd(3,4), jfhss(4,3,4,3), tr(4) +integer(kind=iwp), external :: NrOpr +logical(kind=iwp), external :: EQ + +#include "macros.fh" +unused_var(Zeta) +unused_var(ZInv) +unused_var(rKappa) +unused_var(P) +unused_var(rFinal) +unused_var(nHer) +unused_var(Ccoor) +unused_var(lOper) + +iuvwx(1) = dc(mdc)%nStab +iuvwx(2) = dc(ndc)%nStab +mop(1:2) = nOp +kOp(1) = iOper(nOp(1)) +kOp(2) = iOper(nOp(2)) + +Coor(:,1) = A +Coor(:,2) = RB + +kdc = 0 +do kCnttp=1,nCnttp + if (kCnttp > 1) kdc = kdc+dbsc(kCnttp-1)%nCntr + if (.not. dbsc(kCnttp)%ECP) cycle + do kCnt=1,dbsc(kCnttp)%nCntr + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + + call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) + Fact = real(nStabM,kind=wp)/real(LmbdT,kind=wp) + + iuvwx(3) = dc(kdc+kCnt)%nStab + iuvwx(4) = dc(kdc+kCnt)%nStab + + do lDCRT=0,nDCRT-1 + kOp(3) = iDCRT(lDCRT) + kOp(4) = kOp(3) + mop(3) = nropr(kop(3)) + mop(4) = mop(3) + call OA(iDCRT(lDCRT),C,TC) + Coor(:,3) = TC + + if (EQ(A,RB) .and. EQ(A,TC)) cycle + call NucInd(coor,kdc+kCnt,ifgrd,ifhss,indgrd,indhss,jfgrd,jfhss,jndgrd,jndhss,tr,ifg) + do iAng=0,dbsc(kCnttp)%nPrj-1 + iShll = dbsc(kCnttp)%iPrj+iAng + nExpi = Shells(iShll)%nExp + nBasisi = Shells(iShll)%nBasis + if ((nExpi == 0) .or. (nBasisi == 0)) cycle + + ip = 1 + + ipFin = ip + ip = ip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb)*21 + + ipFA1 = ip + ip = ip+nAlpha*nExpi*nTri_Elem1(la)*nTri_Elem1(iAng)*4 + + ipFA2 = ip + ip = ip+nAlpha*nExpi*nTri_Elem1(la)*nTri_Elem1(iAng)*6 + + ipFB1 = ip + ip = ip+nExpi*nBeta*nTri_Elem1(iAng)*nTri_Elem1(lb)*4 + + ipFB2 = ip + ip = ip+nExpi*nBeta*nTri_Elem1(iAng)*nTri_Elem1(lb)*6 + + Array(:) = Zero + ! ,, + call Acore(iang,la,ishll,nordop,TC,A,Array(ip),narr-ip+1,Alpha,nalpha,Array(ipFA1),array(ipfa2),jfgrd(1,1),jfhss,2,.false.) + ! Transform to core orbital + call LToCore(Array(ipFA1),nalpha,ishll,la,iAng,4) + call LToCore(Array(ipFA2),nalpha,ishll,la,iAng,6) + ! ,, + call coreB(iang,lb,ishll,nordop,TC,RB,Array(ip),narr-ip+1,Beta,nbeta,Array(ipFB1),array(ipfb2),jfgrd(1,2),jfhss,2,.false.) + ! Transform to core orbital + call RToCore(Array(ipFB1),nbeta,ishll,lb,iAng,4) + call RToCore(Array(ipFB2),nbeta,ishll,lb,iAng,6) + ! Construct complete derivative (contract core) + call CmbnACB2(Array(ipFa1),Array(ipFa2),Array(ipFb1),Array(ipFb2),Array(ipFin),Fact,nalpha,nbeta,Dum,nBasisi,la,lb,iang, & + jfhss,dum,.false.) + + ! contract density + nt = nZeta*nTri_Elem1(la)*nTri_Elem1(lb) + g2(:) = Zero + call dGeMV_('T',nT,21,One,Array(ipFin),nT,DAO,1,Zero,g2,1) + + ! distribute in hessian + call Distg2(g2,Hess,nHess,JndGrd,JfHss,JndHss,iuvwx,kOp,mop,Tr,IfG) + + end do !iang + end do !DCR + end do !cnt +end do !cnttp + +return + +end subroutine PrjHss diff -Nru openmolcas-22.02/src/mckinley/prjmm1.f openmolcas-22.10/src/mckinley/prjmm1.f --- openmolcas-22.02/src/mckinley/prjmm1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/prjmm1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,72 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1993, Roland Lindh * -************************************************************************ - Subroutine PrjMm1(nHer,MmPrjG,la,lb,lr) -************************************************************************ -* * -* Object: to compute the number of real*8 the kernel routine will * -* need for the computation of a matrix element between two * -* cartesian Gaussian functions with the total angular momentum* -* of la and lb (la=0 s-function, la=1 p-function, etc.) * -* lr is the order of the operator (this is only used when the * -* integrals are computed with the Hermite-Gauss quadrature). * -* * -* Called from: OneEl * -* * -************************************************************************ -* - Use Basis_Info, only: dbsc, nCnttp, Shells -* - nElem(i) = (i+1)*(i+2)/2 -* - nOrder = 0 - ld=1 - MmPrjG = 0 - Do 1960 iCnttp = 1, nCnttp - If (.Not.dbsc(iCnttp)%ECP) Go To 1960 - Do 1966 iAng = 0, dbsc(iCnttp)%nPrj-1 - iShll = dbsc(iCnttp)%iPrj + iAng - nExpi=Shells(iShll)%nExp - nBasisi=Shells(iShll)%nBasis - If (nExpi.eq.0 .or. nBasisi.eq.0) Go To 1966 -* - ip = 0 - - nac = nElem(la)*nElem(iAng) - ncb = nElem(iAng)*nElem(lb) - - ip=ip+6*nelem(la)*nelem(lb) ! final - ip=ip+4*nac*nExpi ! FA1 - ip=ip+4*ncb*nExpi !FB1 - ip=ip+nExpi* nExpi !Tmp - - nHer = (la+1+iAng+1+ld)/2 - nOrder = Max(nHer,nOrder) - iacore=6+3*nHer*(la+1+ld)+3*nHer*(iAng+1)+ - & 3*nHer*(lr+1)+3*(la+1+ld)*(iAng+1)*(lr+1)+1 - - nHer = (lb+1+iAng+1+ld)/2 - nOrder = Max(nHer,nOrder) - icoreb=6+3*nHer*(lb+1+ld)+3*nHer*(iAng+1)+ - & 3*nHer*(lr+1)+3*(lb+1+ld)*(iAng+1)*(lr+1)+1 - - icores = MAX(icoreb,iacore)*nExpi - - MmPrjG = Max(MmPrjG,ip+icores) -* - 1966 Continue - 1960 Continue - nHer = nOrder -c !write(*,*) 'mem',MmPrjG -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/prjmm1.F90 openmolcas-22.10/src/mckinley/prjmm1.F90 --- openmolcas-22.02/src/mckinley/prjmm1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/prjmm1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,79 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993, Roland Lindh * +!*********************************************************************** + +subroutine PrjMm1( & +# define _CALLING_ +# include "mem_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the number of real*8 the kernel routine will * +! need for the computation of a matrix element between two * +! cartesian Gaussian functions with the total angular momentum* +! of la and lb (la=0 s-function, la=1 p-function, etc.) * +! lr is the order of the operator (this is only used when the * +! integrals are computed with the Hermite-Gauss quadrature). * +! * +! Called from: OneEl * +! * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Basis_Info, only: dbsc, nCnttp, Shells +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: iacore, iAng, iCnttp, icoreb, icores, ip, iShll, ld, nac, nBasisi, ncb, nExpi, nOrder + +nOrder = 0 +ld = 1 +Mem = 0 +do iCnttp=1,nCnttp + if (.not. dbsc(iCnttp)%ECP) cycle + do iAng=0,dbsc(iCnttp)%nPrj-1 + iShll = dbsc(iCnttp)%iPrj+iAng + nExpi = Shells(iShll)%nExp + nBasisi = Shells(iShll)%nBasis + if ((nExpi == 0) .or. (nBasisi == 0)) cycle + + ip = 0 + + nac = nTri_Elem1(la)*nTri_Elem1(iAng) + ncb = nTri_Elem1(iAng)*nTri_Elem1(lb) + + ip = ip+6*nTri_Elem1(la)*nTri_Elem1(lb) ! final + ip = ip+4*nac*nExpi ! FA1 + ip = ip+4*ncb*nExpi !FB1 + ip = ip+nExpi*nExpi !Tmp + + nHer = (la+1+iAng+1+ld)/2 + nOrder = max(nHer,nOrder) + iacore = 6+3*nHer*(la+1+ld)+3*nHer*(iAng+1)+3*nHer*(lr+1)+3*(la+1+ld)*(iAng+1)*(lr+1)+1 + + nHer = (lb+1+iAng+1+ld)/2 + nOrder = max(nHer,nOrder) + icoreb = 6+3*nHer*(lb+1+ld)+3*nHer*(iAng+1)+3*nHer*(lr+1)+3*(lb+1+ld)*(iAng+1)*(lr+1)+1 + + icores = max(icoreb,iacore)*nExpi + + Mem = max(Mem,ip+icores) + + end do +end do +nHer = nOrder +!write(u6,*) 'mem',Mem + +return + +end subroutine PrjMm1 diff -Nru openmolcas-22.02/src/mckinley/prjmmh.f openmolcas-22.10/src/mckinley/prjmmh.f --- openmolcas-22.02/src/mckinley/prjmmh.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/prjmmh.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,70 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1993, Roland Lindh * -************************************************************************ - Subroutine prjMmH(nHer,MmprjH,la,lb,lr) -************************************************************************ -* * -* Object: to compute the number of real*8 the kernel routine will * -* need for the computation of a matrix element between two * -* cartesian Gaussian functions with the total angular momentum* -* of la and lb (la=0 s-function, la=1 p-function, etc.) * -* lr is the order of the operator (this is only used when the * -* integrals are computed with the Hermite-Gauss quadrature). * -* * -* Called from: OneEl * -* * -************************************************************************ - use Basis_Info, only: dbsc, nCnttp, Shells -* - nElem(i) = (i+1)*(i+2)/2 -* - nOrder = 0 - nordop=lr - ld=2 - MmprjH = 0 - Do 1960 iCnttp = 1, nCnttp - If (.Not.dbsc(iCnttp)%ECP) Cycle - Do 1966 iAng = 0, dbsc(iCnttp)%nPrj-1 - iShll = dbsc(iCnttp)%iPrj + iAng - nExpi=Shells(iShll)%nExp - nBasisi=Shells(iShll)%nBasis - If (nExpi.eq.0 .or. nBasisi.eq.0) Cycle -* - ip = 0 - nac = nElem(la)*nElem(iAng) - ncb = nElem(iAng)*nElem(lb) - ip = ip + nElem(la)*nElem(lb)*21 ! Final - - ip = ip + nExpi*nExpi ! tmp - - ip=ip+10*nac*nExpi ! FA1 & FA2 - ip=ip+10*ncb*nExpi ! FB1 & FB2 - - nHer = (la+1+iAng+1+ld)/2 - nOrder = Max(nHer,nOrder) - iacore=6+3*nHer*(la+1+ld)+3*nHer*(iAng+1)+ - & 3*nHer*(nOrdOp+1)+3*(la+1+ld)*(iAng+1)*(nOrdOp+1)+1 - - nHer = (lb+1+iAng+1+ld)/2 - nOrder = Max(nHer,nOrder) - icoreb=6+3*nHer*(lb+1+ld)+3*nHer*(iAng+1)+ - & 3*nHer*(nOrdOp+1)+3*(lb+1+ld)*(iAng+1)*(nOrdOp+1)+1 - - icores = MAX(icoreb,iacore)*nExpi - MmprjH = Max(MmprjH,ip+icores) -* - 1966 Continue - 1960 Continue - nHer = nOrder -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/prjmmh.F90 openmolcas-22.10/src/mckinley/prjmmh.F90 --- openmolcas-22.02/src/mckinley/prjmmh.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/prjmmh.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,78 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993, Roland Lindh * +!*********************************************************************** + +subroutine prjMmH( & +# define _CALLING_ +# include "mem_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the number of real*8 the kernel routine will * +! need for the computation of a matrix element between two * +! cartesian Gaussian functions with the total angular momentum* +! of la and lb (la=0 s-function, la=1 p-function, etc.) * +! lr is the order of the operator (this is only used when the * +! integrals are computed with the Hermite-Gauss quadrature). * +! * +! Called from: OneEl * +! * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Basis_Info, only: dbsc, nCnttp, Shells +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: iacore, iAng, iCnttp, icoreb, icores, ip, iShll, ld, nac, nBasisi, ncb, nExpi, nOrder, nordop + +nOrder = 0 +nordop = lr +ld = 2 +Mem = 0 +do iCnttp=1,nCnttp + if (.not. dbsc(iCnttp)%ECP) cycle + do iAng=0,dbsc(iCnttp)%nPrj-1 + iShll = dbsc(iCnttp)%iPrj+iAng + nExpi = Shells(iShll)%nExp + nBasisi = Shells(iShll)%nBasis + if ((nExpi == 0) .or. (nBasisi == 0)) cycle + + ip = 0 + nac = nTri_Elem1(la)*nTri_Elem1(iAng) + ncb = nTri_Elem1(iAng)*nTri_Elem1(lb) + ip = ip+nTri_Elem1(la)*nTri_Elem1(lb)*21 ! Final + + ip = ip+nExpi*nExpi ! tmp + + ip = ip+10*nac*nExpi ! FA1 & FA2 + ip = ip+10*ncb*nExpi ! FB1 & FB2 + + nHer = (la+1+iAng+1+ld)/2 + nOrder = max(nHer,nOrder) + iacore = 6+3*nHer*(la+1+ld)+3*nHer*(iAng+1)+3*nHer*(nOrdOp+1)+3*(la+1+ld)*(iAng+1)*(nOrdOp+1)+1 + + nHer = (lb+1+iAng+1+ld)/2 + nOrder = max(nHer,nOrder) + icoreb = 6+3*nHer*(lb+1+ld)+3*nHer*(iAng+1)+3*nHer*(nOrdOp+1)+3*(lb+1+ld)*(iAng+1)*(nOrdOp+1)+1 + + icores = max(icoreb,iacore)*nExpi + Mem = max(Mem,ip+icores) + + end do +end do +nHer = nOrder + +return + +end subroutine prjMmH diff -Nru openmolcas-22.02/src/mckinley/prmx2.f openmolcas-22.10/src/mckinley/prmx2.f --- openmolcas-22.02/src/mckinley/prmx2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/prmx2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,64 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -* 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine PrMx2(Label,iComp,lOper,Result,Mem) -************************************************************************ -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, Sweden, January '91 * -* * -* Modified by AB 950620 * -************************************************************************ - use Basis_Info, only: nBas - use Symmetry_Info, only: nIrrep, iOper - Implicit Real*8 (A-H,O-Z) -* Local arrays - Real*8 Result(Mem) - Character Label*(*), Line*80 - Integer lOper - Logical Type -* - ip1=1 - Type = .True. - Do 30 iIrrep = 0, nIrrep - 1 - If (nBas(iIrrep).le.0) Go To 30 - Do 40 jIrrep=0,iIrrep - lop=iEor(iOper(iIrrep),iOper(jIrrep)) - if (lop.ne.loper) Go To 40 - If (nBas(jIrrep).le.0) Go To 40 - If (Type) Then - Type = .False. - Write (6,*) - Write (6,*) - Write (6,'(A,A,A,I2)') - & ' SO Integral gradients of the ', Label,' Component ', - & iComp - End If - Line='' - If (iIrrep.eq.jIrrep) Then - Write (Line,'(1X,A,I1)') - & ' Diagonal Symmetry Block ', iIrrep+1 -* Call TriPrt(Line,' ',Result(ip1),nBas(iIrrep)) - ip1 = ip1 + nBas(iIrrep)*(nBas(iIrrep)+1)/2 - Else - Write (Line,'(1X,A,I1,A,I1)') - & ' Off-diagonal Symmetry Block ', - & iIrrep+1, ',' , jIrrep+1 - Call RecPrt(Line,' ', - & Result(ip1),nBas(iIrrep),nBas(jIrrep)) - ip1 = ip1 + nBas(iIrrep)*nBas(jIrrep) - End If - 40 Continue - 30 Continue -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/psoao0_h.f openmolcas-22.10/src/mckinley/psoao0_h.f --- openmolcas-22.02/src/mckinley/psoao0_h.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/psoao0_h.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,255 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine PSOAO0_h(nSO,nMemab,nMemcd,MemPrm,MemMax, - & iAnga, iCmpa, - & iBas, iBsInc, jBas, jBsInc, - & kBas, kBsInc, lBas, lBsInc, - & iPrim, iPrInc, jPrim, jPrInc, - & kPrim, kPrInc, lPrim, lPrInc, - & ipMem1,ipMem2,ipMem3,ipMem4, ipMend, - & Mem1, Mem2, Mem3, Mem4, Mend) -************************************************************************ -* * -* Object: to partion the SO and AO block. It will go to some length * -* before it will start and break up the SO block. This will * -* reduce the total flop count. However, as we are breaking up * -* the AO block this will affect the vectorization. Hence, at * -* some point it will actually be better to recompute the * -* primitives. * -* Current stratergy: * -* 1. Start reducing the length of the primitives in the order * -* lPrim,jPrim. * -* 2. Reduce the size of the SO block by reducing the number of* -* basis functions in the order lBas, jBas. * -* 3. Terminate run telling job max and min of additional * -* memory needed to perform the calculation. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -************************************************************************ - use Gateway_global, only: iWROpt - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" -#include "lCache.fh" -#include "pstat.fh" -#include "warnings.h" - Integer iAnga(4), iCmpa(4) - Logical QiBas, QjBas, QkBas, QlBas, QjPrim, QlPrim, Fail -#include "SysDef.fh" -* -* Statement function to compute canonical index -* - nabSz(ixyz) = (ixyz+1)*(ixyz+2)*(ixyz+3)/6 - 1 -* -* iQ = 1 - la = iAnga(1) - lb = iAnga(2) - lc = iAnga(3) - ld = iAnga(4) - iCmp = iCmpa(1) - jCmp = iCmpa(2) - kCmp = iCmpa(3) - lCmp = iCmpa(4) - iTotal = iTotal + 1 - mabMin=nabSz(Max(la,lb)-1)+1 - mabMax=nabSz(la+lb) - mcdMin=nabSz(Max(lc,ld)-1)+1 - mcdMax=nabSz(lc+ld) - mabcd=(mabMax-mabMin+1)*(mcdMax-mcdMin+1) -* - iBsInc = iBas - jBsInc = jBas - kBsInc = kBas - lBsInc = lBas - iPrInc = iPrim - jPrInc = jPrim - kPrInc = kPrim - lPrInc = lPrim - iFact = 1 - If (iWropt.eq.0) iFact = 4/RtoI+3 -* - 999 Continue - QjPrim = .False. - QlPrim = .True. - QiBas = .False. - QjBas = .False. - QkBas = .False. - QlBas = .False. - Mem0 = MemMax -* -*-----Work1 -* Memory for SO block. If petite list format is used there -* will be no SO block. -* - kSOInt = nSO*iBsInc*jBsInc*kBsInc*lBsInc - Mem1 = iFact*kSOInt - If (Mem1.eq.0) Mem1 = 1 - If (nIrrep==1) Mem1 = 1 + (iFact-1) * - & iCmp* jCmp* kCmp* lCmp* - & iBsInc*jBsInc*kBsInc*lBsInc - If (Mem1+1.gt.Mem0) Then - MaxReq=Max(MaxReq,Mem1+1-Mem0) - QjPrim = .False. - QlPrim = .False. - QiBas = .False. - QjBas = .False. - QkBas = .False. - QlBas = .True. - Call Change(iBas, iBsInc,QiBas, kBas, kBsInc,QkBas, - & jBas, jBsInc,QjBas, lBas, lBsInc,QlBas, - & jPrim,jPrInc,QjPrim,lPrim,lPrInc,QlPrim,MaxReq, - & Fail) - If (Fail) Then - Write (6,*) ' Allocation failed for Work1' - Write (6,*) Mem0,Mem1 - Write (6,*) iPrInc,iBsInc,kPrInc,kBsInc, - & jPrInc,jBsInc,lPrInc,lBsInc - Call Quit(_RC_MEMORY_ERROR_) - End If - Go To 999 - End If -* Write (*,*) ' After Mem1', iPrInc,iBsInc,kPrInc,kBsInc, -* & jPrInc,jBsInc,lPrInc,lBsInc - Mem0 = Mem0 - Mem1 - 1 -* -*-----Work2 -* MemPr : Scratch for Rys -* MemCon : Scratch for the contraction step -* MemTr1 : Scratch for the 1st application of the transfer eqn. -* MemTr2 : Scratch for the 2nd application of the transfer eqn. -*-----Work4 (this is overlayed with Work2 and is placed at the top) -* MemAux : Auxiliary memory for partial contraction. -*-----Work5 (this is overlayed with Work2 and is placed at the top) -* - MemPr = MemPrm*iPrInc*jPrInc*kPrInc*lPrInc - MemCon= mabcd*Max(iPrInc*jPrInc*kPrInc*lPrInc, - & iBsInc*jBsInc*kBsInc*lBsInc) - If (jPrInc.ne.jPrim.or.lPrInc.ne.lPrim) Then - MemAux = mabcd*iBsInc*jBsInc*kBsInc*lBsInc - Else - MemAux = 0 - End If - MemTr1= (mabMax-mabMin+1)*nMemcd*iBsInc*jBsInc*kBsInc*lBsInc - MemTr2= kCmp*lCmp*nMemab*iBsInc*jBsInc*kBsInc*lBsInc - Mem2 = Max(MemPr+MemAux,MemCon+MemAux,MemTr1,MemTr2) - If (Mem2+1.gt.Mem0) Then - MaxReq=Max(MaxReq,Mem2+1-Mem0) - Call Change(iBas, iBsInc,QiBas, kBas, kBsInc,QkBas, - & jBas, jBsInc,QjBas, lBas, lBsInc,QlBas, - & jPrim,jPrInc,QjPrim,lPrim,lPrInc,QlPrim,MaxReq, - & Fail) - If (Fail) Then - Write (6,*) ' Allocation failed for Work2' - Write (6,*) Mem0,Mem2,MemPr+MemAux,MemCon+MemAux, - & MemTr1,MemTr2 - Write (6,*) iPrInc,iBsInc,kPrInc,kBsInc, - & jPrInc,jBsInc,lPrInc,lBsInc - Call Quit(_RC_MEMORY_ERROR_) - End If - Go To 999 - End If - If (jPrInc.ne.jPrim.or.lPrInc.ne.lPrim) Then - Mem4 = MemAux - Else - Mem4 = Mem2 - End If -* Write (*,*) ' After Mem2', jPrInc,jBsInc,lPrInc,lBsInc - Mem0 = Mem0 - Mem2 - 1 -* -*-----Work3 -* MemCon : Scratch for the contraction step, and transpose after the -* contraction step -* MemSp1 : Scratch for the 1st transformation from cartesian to -* spherical harmonics. -* MemSp2 : Scratch for the 2nd transformation from cartesian to -* spherical harmonics. -* MemTr3 : Scratch for transpose in tnsctl -* - nCache_ = (3*lCache)/4 - iPrim*iBas - jPrim*jBas - lSize = iPrInc*jPrInc + Max(jPrInc*iBsInc,iPrInc*jBsInc) - nVec1 = kPrInc*lPrInc * mabcd - IncVec = Min(Max(1,nCache_/lSize),nVec1) - nA2 = Max(jPrInc*iBsInc,iPrInc*jBsInc)*IncVec - nA3 = iBsInc*jBsInc*nVec1 - MemCon = Max(mabcd*iBsInc*jBsInc*kBsInc*lBsInc,nA2+nA3) -* - nCache_ = (3*lCache)/4 - kPrim*kBas - lPrim*lBas - lSize = kPrInc*lPrInc + Max(lPrInc*kBsInc,kPrInc*lBsInc) - nVec2 = iBsInc*jBsInc * mabcd - IncVec = Min(Max(1,nCache_/lSize),nVec2) - nA2 = Max(lPrInc*kBsInc,kPrInc*lBsInc)*IncVec -* nA3 = kBsInc*lBsInc*nVec2 - MemCon = Max(MemCon,nA3+nA2) -* -************************************************************************ -* - nCache_ = (3*lCache)/4 - kPrim*kBas - lPrim*lBas - lSize = kPrInc*lPrInc + Max(lPrInc*kBsInc,kPrInc*lBsInc) - nVec1 = iPrInc*jPrInc * mabcd - IncVec = Min(Max(1,nCache_/lSize),nVec1) - nA2 = IncVec*Max(lPrInc*kBsInc,kPrInc*lBsInc) - nA3 = kBsInc*lBsInc*nVec1 - MemCon = Max(MemCon,nA3+nA2) -* - nCache_ = (3*lCache)/4 - iPrim*iBas - jPrim*jBas - lSize = iPrInc*jPrInc + Max(jPrInc*iBsInc,iPrInc*jBsInc) - nVec2 = kBsInc*lBsInc * mabcd - IncVec = Min(Max(1,nCache_/lSize),nVec2) - nA2 = IncVec*Max(jPrInc*iBsInc,iPrInc*jBsInc) -* nA3 = iBsInc*jBsInc*nVec2 - MemCon = Max(MemCon,nA3+nA2) -* - MemSp1 = (mabMax-mabMin+1)*lCmp*(lc+1)*(lc+2)/2 * - & iBsInc*jBsInc*kBsInc*lBsInc - MemSp2= lCmp*kCmp*jCmp*(la+1)*(la+2)/2 * - & iBsInc*jBsInc*kBsInc*lBsInc - MemTr3 = mabcd*iBsInc*jBsInc*kBsInc*lBsInc - Mem3 = Max(MemCon,MemSp1,MemSp2,MemTr3) - If (Mem3+1.gt.Mem0) Then - MaxReq=Max(MaxReq,Mem3+1-Mem0) - Call Change(iBas, iBsInc,QiBas, kBas, kBsInc,QkBas, - & jBas, jBsInc,QjBas, lBas, lBsInc,QlBas, - & jPrim,jPrInc,QjPrim,lPrim,lPrInc,QlPrim,MaxReq, - & Fail) - If (Fail) Then - Write (6,*) ' Allocation failed for Work3' - Write (6,*) Mem0,Mem3,MemCon,MemSp1,MemSp2 - Write (6,*) iPrInc,iBsInc,kPrInc,kBsInc, - & jPrInc,jBsInc,lPrInc,lBsInc - Call Quit(_RC_MEMORY_ERROR_) - End If - Go To 999 - End If - Mem0 = Mem0 - Mem3 - 1 - MinXtr = Min(MinXtr,Mem0) -* - ipMem2 = ipMem1 + Mem1 - ipMem3 = ipMem2 + Mem2 - ipMem4 = ipMem2 + Mem2 - Mem4 - Mend=0 -* - r1 = r1 + DBLE(iBsInc)/DBLE(iBas) - r2 = r2 + DBLE(jBsInc)/DBLE(jBas) - r3 = r3 + DBLE(kBsInc)/DBLE(kBas) - r4 = r4 + DBLE(lBsInc)/DBLE(lBas) - q1 = q1 + DBLE(iPrInc)/DBLE(iPrim) - q2 = q2 + DBLE(jPrInc)/DBLE(jPrim) - q3 = q3 + DBLE(kPrInc)/DBLE(kPrim) - q4 = q4 + DBLE(lPrInc)/DBLE(lPrim) - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(ipMend) - End diff -Nru openmolcas-22.02/src/mckinley/psoao0_h.F90 openmolcas-22.10/src/mckinley/psoao0_h.F90 --- openmolcas-22.02/src/mckinley/psoao0_h.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/psoao0_h.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,234 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine PSOAO0_h(nSO,nMemab,nMemcd,MemPrm,MemMax,iAnga,iCmpa,iBas,iBsInc,jBas,jBsInc,kBas,kBsInc,lBas,lBsInc,iPrim,iPrInc, & + jPrim,jPrInc,kPrim,kPrInc,lPrim,lPrInc,ipMem1,ipMem2,ipMem3,ipMem4,Mem1,Mem2,Mem3,Mem4,Mend) +!*********************************************************************** +! * +! Object: to partion the SO and AO block. It will go to some length * +! before it will start and break up the SO block. This will * +! reduce the total flop count. However, as we are breaking up * +! the AO block this will affect the vectorization. Hence, at * +! some point it will actually be better to recompute the * +! primitives. * +! Current stratergy: * +! 1. Start reducing the length of the primitives in the order * +! lPrim,jPrim. * +! 2. Reduce the size of the SO block by reducing the number of* +! basis functions in the order lBas, jBas. * +! 3. Terminate run telling job max and min of additional * +! memory needed to perform the calculation. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +!*********************************************************************** + +use Index_Functions, only: nTri3_Elem1, nTri_Elem1 +use Gateway_global, only: iWROpt +use Symmetry_Info, only: nIrrep +use Definitions, only: wp, iwp, u6, RtoI + +implicit none +integer(kind=iwp), intent(in) :: nSO, nMemab, nMemcd, MemPrm, MemMax, iAnga(4), iCmpa(4), iBas, jBas, kBas, lBas, iPrim, jPrim, & + kPrim, lPrim, ipMem1 +integer(kind=iwp), intent(out) :: iBsInc, jBsInc, kBsInc, lBsInc, iPrInc, jPrInc, kPrInc, lPrInc, ipMem2, ipMem3, ipMem4, Mem1, & + Mem2, Mem3, Mem4, Mend +#include "lCache.fh" +#include "pstat.fh" +#include "warnings.h" +integer(kind=iwp) :: iCmp, iFact, IncVec, jCmp, kCmp, kSOInt, la, lb, lc, lCmp, ld, lSize, mabcd, mabMax, mabMin, mcdMax, mcdMin, & + Mem0, MemAux, MemCon, MemPr, MemSp1, MemSp2, MemTr1, MemTr2, MemTr3, nA2, nA3, nCache_, nVec1, nVec2 +logical(kind=iwp) :: Fail, QiBas, QjBas, QjPrim, QkBas, QlBas, QlPrim + +!iQ = 1 +la = iAnga(1) +lb = iAnga(2) +lc = iAnga(3) +ld = iAnga(4) +iCmp = iCmpa(1) +jCmp = iCmpa(2) +kCmp = iCmpa(3) +lCmp = iCmpa(4) +iTotal = iTotal+1 +mabMin = nTri3_Elem1(max(la,lb)-1) +mabMax = nTri3_Elem1(la+lb)-1 +mcdMin = nTri3_Elem1(max(lc,ld)-1) +mcdMax = nTri3_Elem1(lc+ld)-1 +mabcd = (mabMax-mabMin+1)*(mcdMax-mcdMin+1) + +iBsInc = iBas +jBsInc = jBas +kBsInc = kBas +lBsInc = lBas +iPrInc = iPrim +jPrInc = jPrim +kPrInc = kPrim +lPrInc = lPrim +iFact = 1 +if (iWropt == 0) iFact = 4/RtoI+3 + +do + QjPrim = .false. + QlPrim = .true. + QiBas = .false. + QjBas = .false. + QkBas = .false. + QlBas = .false. + Mem0 = MemMax + + ! Work1 + ! Memory for SO block. If petite list format is used there + ! will be no SO block. + + kSOInt = nSO*iBsInc*jBsInc*kBsInc*lBsInc + Mem1 = iFact*kSOInt + if (Mem1 == 0) Mem1 = 1 + if (nIrrep == 1) Mem1 = 1+(iFact-1)*iCmp*jCmp*kCmp*lCmp*iBsInc*jBsInc*kBsInc*lBsInc + if (Mem1+1 > Mem0) then + MaxReq = max(MaxReq,Mem1+1-Mem0) + QjPrim = .false. + QlPrim = .false. + QiBas = .false. + QjBas = .false. + QkBas = .false. + QlBas = .true. + call Change(iBas,iBsInc,QiBas,kBas,kBsInc,QkBas,jBas,jBsInc,QjBas,lBas,lBsInc,QlBas,jPrim,jPrInc,QjPrim,lPrim,lPrInc,QlPrim, & + MaxReq,Fail) + if (Fail) then + write(u6,*) ' Allocation failed for Work1' + write(u6,*) Mem0,Mem1 + write(u6,*) iPrInc,iBsInc,kPrInc,kBsInc,jPrInc,jBsInc,lPrInc,lBsInc + call Quit(_RC_MEMORY_ERROR_) + end if + cycle + end if + !write(u6,*) ' After Mem1',iPrInc,iBsInc,kPrInc,kBsInc,jPrInc,jBsInc,lPrInc,lBsInc + Mem0 = Mem0-Mem1-1 + + ! Work2 + ! MemPr : Scratch for Rys + ! MemCon : Scratch for the contraction step + ! MemTr1 : Scratch for the 1st application of the transfer eqn. + ! MemTr2 : Scratch for the 2nd application of the transfer eqn. + + ! Work4 (this is overlayed with Work2 and is placed at the top) + ! MemAux : Auxiliary memory for partial contraction. + + ! Work5 (this is overlayed with Work2 and is placed at the top) + + MemPr = MemPrm*iPrInc*jPrInc*kPrInc*lPrInc + MemCon = mabcd*max(iPrInc*jPrInc*kPrInc*lPrInc,iBsInc*jBsInc*kBsInc*lBsInc) + if ((jPrInc /= jPrim) .or. (lPrInc /= lPrim)) then + MemAux = mabcd*iBsInc*jBsInc*kBsInc*lBsInc + else + MemAux = 0 + end if + MemTr1 = (mabMax-mabMin+1)*nMemcd*iBsInc*jBsInc*kBsInc*lBsInc + MemTr2 = kCmp*lCmp*nMemab*iBsInc*jBsInc*kBsInc*lBsInc + Mem2 = max(MemPr+MemAux,MemCon+MemAux,MemTr1,MemTr2) + if (Mem2+1 > Mem0) then + MaxReq = max(MaxReq,Mem2+1-Mem0) + call Change(iBas,iBsInc,QiBas,kBas,kBsInc,QkBas,jBas,jBsInc,QjBas,lBas,lBsInc,QlBas,jPrim,jPrInc,QjPrim,lPrim,lPrInc,QlPrim, & + MaxReq,Fail) + if (Fail) then + write(u6,*) ' Allocation failed for Work2' + write(u6,*) Mem0,Mem2,MemPr+MemAux,MemCon+MemAux,MemTr1,MemTr2 + write(u6,*) iPrInc,iBsInc,kPrInc,kBsInc,jPrInc,jBsInc,lPrInc,lBsInc + call Quit(_RC_MEMORY_ERROR_) + end if + cycle + end if + if ((jPrInc /= jPrim) .or. (lPrInc /= lPrim)) then + Mem4 = MemAux + else + Mem4 = Mem2 + end if + !write(u6,*) ' After Mem2',jPrInc,jBsInc,lPrInc,lBsInc + Mem0 = Mem0-Mem2-1 + + ! Work3 + ! MemCon : Scratch for the contraction step, and transpose after the contraction step + ! MemSp1 : Scratch for the 1st transformation from cartesian to spherical harmonics. + ! MemSp2 : Scratch for the 2nd transformation from cartesian to spherical harmonics. + ! MemTr3 : Scratch for transpose in tnsctl + + nCache_ = (3*lCache)/4-iPrim*iBas-jPrim*jBas + lSize = iPrInc*jPrInc+max(jPrInc*iBsInc,iPrInc*jBsInc) + nVec1 = kPrInc*lPrInc*mabcd + IncVec = min(max(1,nCache_/lSize),nVec1) + nA2 = max(jPrInc*iBsInc,iPrInc*jBsInc)*IncVec + nA3 = iBsInc*jBsInc*nVec1 + MemCon = max(mabcd*iBsInc*jBsInc*kBsInc*lBsInc,nA2+nA3) + + nCache_ = (3*lCache)/4-kPrim*kBas-lPrim*lBas + lSize = kPrInc*lPrInc+max(lPrInc*kBsInc,kPrInc*lBsInc) + nVec2 = iBsInc*jBsInc*mabcd + IncVec = min(max(1,nCache_/lSize),nVec2) + nA2 = max(lPrInc*kBsInc,kPrInc*lBsInc)*IncVec + !nA3 = kBsInc*lBsInc*nVec2 + MemCon = max(MemCon,nA3+nA2) + + !********************************************************************* + + nCache_ = (3*lCache)/4-kPrim*kBas-lPrim*lBas + lSize = kPrInc*lPrInc+max(lPrInc*kBsInc,kPrInc*lBsInc) + nVec1 = iPrInc*jPrInc*mabcd + IncVec = min(max(1,nCache_/lSize),nVec1) + nA2 = IncVec*max(lPrInc*kBsInc,kPrInc*lBsInc) + nA3 = kBsInc*lBsInc*nVec1 + MemCon = max(MemCon,nA3+nA2) + + nCache_ = (3*lCache)/4-iPrim*iBas-jPrim*jBas + lSize = iPrInc*jPrInc+max(jPrInc*iBsInc,iPrInc*jBsInc) + nVec2 = kBsInc*lBsInc*mabcd + IncVec = min(max(1,nCache_/lSize),nVec2) + nA2 = IncVec*max(jPrInc*iBsInc,iPrInc*jBsInc) + !nA3 = iBsInc*jBsInc*nVec2 + MemCon = max(MemCon,nA3+nA2) + + MemSp1 = (mabMax-mabMin+1)*lCmp*nTri_Elem1(lc)*iBsInc*jBsInc*kBsInc*lBsInc + MemSp2 = lCmp*kCmp*jCmp*nTri_Elem1(la)*iBsInc*jBsInc*kBsInc*lBsInc + MemTr3 = mabcd*iBsInc*jBsInc*kBsInc*lBsInc + Mem3 = max(MemCon,MemSp1,MemSp2,MemTr3) + if (Mem3+1 <= Mem0) exit + MaxReq = max(MaxReq,Mem3+1-Mem0) + call Change(iBas,iBsInc,QiBas,kBas,kBsInc,QkBas,jBas,jBsInc,QjBas,lBas,lBsInc,QlBas,jPrim,jPrInc,QjPrim,lPrim,lPrInc,QlPrim, & + MaxReq,Fail) + if (Fail) then + write(u6,*) ' Allocation failed for Work3' + write(u6,*) Mem0,Mem3,MemCon,MemSp1,MemSp2 + write(u6,*) iPrInc,iBsInc,kPrInc,kBsInc,jPrInc,jBsInc,lPrInc,lBsInc + call Quit(_RC_MEMORY_ERROR_) + end if +end do +Mem0 = Mem0-Mem3-1 +MinXtr = min(MinXtr,Mem0) + +ipMem2 = ipMem1+Mem1 +ipMem3 = ipMem2+Mem2 +ipMem4 = ipMem2+Mem2-Mem4 +Mend = 0 + +r1 = r1+real(iBsInc,kind=wp)/real(iBas,kind=wp) +r2 = r2+real(jBsInc,kind=wp)/real(jBas,kind=wp) +r3 = r3+real(kBsInc,kind=wp)/real(kBas,kind=wp) +r4 = r4+real(lBsInc,kind=wp)/real(lBas,kind=wp) +q1 = q1+real(iPrInc,kind=wp)/real(iPrim,kind=wp) +q2 = q2+real(jPrInc,kind=wp)/real(jPrim,kind=wp) +q3 = q3+real(kPrInc,kind=wp)/real(kPrim,kind=wp) +q4 = q4+real(lPrInc,kind=wp)/real(lPrim,kind=wp) + +return + +end subroutine PSOAO0_h diff -Nru openmolcas-22.02/src/mckinley/psoao2.f openmolcas-22.10/src/mckinley/psoao2.f --- openmolcas-22.02/src/mckinley/psoao2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/psoao2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,403 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990,1992, Roland Lindh * -* 1990, IBM * -* 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine PSOAO2(nSO,MemPrm,MemM, - & iAnga, iCmpa, iAO, iFnc, - & iBas, iBsInc, jBas, jBsInc, - & kBas, kBsInc, lBas, lBsInc, - & iPrim, iPrInc, jPrim, jPrInc, - & kPrim, kPrInc, lPrim, lPrInc, - & nAco, - & Mem1,Mem2,Mem3,Mem4, - & MemX,MemPSO, - & MemFck,nFT,nCMO, - & MemFin,MemBuffer, - & iMemB) -************************************************************************ -* * -* Object: to partion the SO and AO block. It will go to some length * -* before it will start and break up the SO block. This will * -* reduce the total flop count. However, as we are breaking up * -* the AO block this will affect the vectorization. Hence, at * -* some point it will actually be better to recompute the * -* primitives. * -* Current stratergy: * -* 1. Reduce the size of the density matrix and buffer so that * -* it fits into memory. * -* * -* 2. Start reducing the length of the primitives in the order * -* lPrim,jPrim. * -* * -* 3. Reduce the size of the SO block by reducing the number of* -* basis functions in the order lBas, jBas. * -* * -* 4. Reduce the size of the Buffer. * -* * -* 5. Reduce kBas,iBas * -* * -* 6. Terminate run telling job max and min of additional * -* memory needed to perform the calculation. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* Modified to first order derivatives. January '92 * -* Anders Bernhardsson Theoretical chemistry, Lund 1995 * -************************************************************************ -* -* Memory map for mckinley -* -*--------------------------------------------------------------------------- -*| | | | | | | -*|REAL | P TRANSF | RYSG2 | Transf | FCK GENERAT |MO Transf | -*| | | | | | | -*--------------------------------------------------------------------------- -*| | | | | |Scratch | -*| MX | | | 9*abcd*ijkl | SS |space | -*| | | | | | | -*--------------------------------------------------------------------------- -*| | | | | | | -*| M3 |Scratch space |Memrys |Scratch space | SS | Scratch | -*| | | | | | space | -*--------------------------------------------------------------------------- -*| |MEM4 (half tr) |*******|***************| | | -*| M2 | | | | | SS | -*| |PSO transf | | |Scratch space | | -*--------------------------------------------------------------------------- -*| | | | | | | -*| M1 | P | * | * | * | * | -*| | | | | | | -*--------------------------------------------------------------------------- -*| | ? | | | | | -*|Buffer|***************|*******|Transformed |***************|**********| -*| | | |integrals | | | -*--------------------------------------------------------------------------- -* -c use Gateway_global, only: force_part_c, force_part_p - use Gateway_global, only: force_part_p - use SOAO_Info, only: iAOtSO - use pso_stuff - use Sizes_of_Seward, only: S - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "real.fh" -#include "pstat.fh" -#include "disp.fh" -#include "disp2.fh" -#include "buffer.fh" - Integer iAnga(4), iCmpa(4), nPam(4,0:7), iiBas(4), iAO(4), - & iFnc(4) - Logical QiBas, QjBas, QkBas, QlBas, QjPrim, QlPrim, Fail - Integer iMemB -* -* Statement function to compute canonical index -* - nElem(i) = (i+1)*(i+2)/2 -* -c iRout = 10 -c iPrint = nPrint(iRout) - la = iAnga(1) - lb = iAnga(2) - lc = iAnga(3) - ld = iAnga(4) - iCmp = iCmpa(1) - jCmp = iCmpa(2) - kCmp = iCmpa(3) - lCmp = iCmpa(4) - iTotal = iTotal + 1 - mabcd=nElem(la)*nElem(lb)*nElem(lc)*nElem(ld) - nabcd=iCmp*jCmp*kCmp*lCmp -* -* If (force_part_c) Then -* iBsInc = (iBas+1)/2 -* jBsInc = (jBas+1)/2 -* kBsInc = (kBas+1)/2 -* lBsInc = (lBas+1)/2 -* Else - iBsInc = iBas - jBsInc = jBas - kBsInc = kBas - lBsInc = lBas -* End If - If (force_part_p) Then - jPrInc = (jPrim+1)/2 -* lPrInc = (lPrim+1)/2 - Else - jPrInc = jPrim -* lPrInc = lPrim - End If - iPrInc = iPrim - kPrInc = kPrim - lPrInc = lPrim - MemBuffer = iMemB - MemMax=MemM-MemBuffer -* - 999 Continue - nijkl=iBsInc*jBsInc*kBsInc*lBsInc - QjPrim = .False. - QlPrim = .True. - QiBas = .False. - QjBas = .False. - QkBas = .False. - QlBas = .False. - Mem0 = MemMax -* -* Picked MO coeff -* - If (nMethod.eq.RASSCF) Then - nCMO=nACO*kCmp*kBas+nACO*lCmp*lBas - Else - nCMO=0 - End If -* -* Area for integral storage before transforming them to FM/MO -* and place for the CMOs -* - MemFin=9*nijkl*nabcd - If (MemFin+ncmo+1.gt.Mem0) Then - MaxReq=Max(MaxReq,nCMO+MemFin+1-Mem0) - QlPrim=.false. - Call Change(iBas, iBsInc,QiBas, kBas, kBsInc,QkBas, - & jBas, jBsInc,QjBas, lBas, lBsInc,QlBas, - & jPrim,jPrInc,QjPrim,lPrim,lPrInc,QlPrim,MaxReq, - & Fail) - If (Fail) Then - Write (6,*) 'PSOAO2: memory partitioning failed!' - Write (6,*) ' Restart with more memory!' - Call Abend() - End If - Go To 999 - End If -*-----Subtract one additional word for getmem's internal error check - Mem0 = Mem0 - MemFin -nCMO - 1 -* -* -*-------------------------------------------------------------------- -* -*-----*** Work1 *** -* -* -*-----Memory for 2nd order density matrix in SO basis. -* - kSOInt = nSO*iBsInc*jBsInc*kBsInc*lBsInc - Mem1 = kSOInt -* -*-----Allocate memory for MO to SO/AO transformation -* of the 2nd order density matrix for this shell quadruplet. -* and area for AO/SO transformation of Fock matrix. -* - If (lPSO) Then - iiBas(1) = iBsInc - iiBas(2) = jBsInc - iiBas(3) = kBsInc - iiBas(4) = lBsInc - Call ICopy(4*8,[0],0,nPam,1) - MemPSO = 1 - nTmp2 = 0 -* Call IecPrt('iiBas',iiBas,1,4) -* - Do 9 jPam = 1, 4 - iTmp1= 0 - nTmp1= 0 - Do 10 j = 0, nIrrep-1 - Do 11 i1 = 1, iCmpa(jPam) - If (iAOtSO(iAO(jPam)+i1,j)>0) Then - nPam(jPam,j) = nPam(jPam,j) + iiBas(jPam) - nTmp1= nTmp1+ iiBas(jPam) - iTmp1= iTmp1+ 1 - End If - 11 Continue - 10 Continue - MemPSO = MemPSO * nTmp1 - nTmp2 = nTmp2 + nTmp1 - iFnc(jPam) = iTmp1 - 9 Continue - MemScr=MemTra(nPam) - nFac = 4 - nTmp2 = nTmp2 + 4 - Else - MemScr=0 - MemPSO=0 - nFac = 0 - nTmp2 = 0 - End If - MemAux = MemPSO + MemScr + nFac*S%nDim + nTmp2 + 4 - If (Mem1+1+MemAux.gt.Mem0) Then - MaxReq=Max(MaxReq,Mem1+1+MemAux-Mem0) - QjPrim = .False. - QlPrim = .False. - QiBas = .False. - QjBas = .False. - QkBas = .False. - QlBas = .True. - Call Change(iBas, iBsInc,QiBas, kBas, kBsInc,QkBas, - & jBas, jBsInc,QjBas, lBas, lBsInc,QlBas, - & jPrim,jPrInc,QjPrim,lPrim,lPrInc,QlPrim,MaxReq, - & Fail) - If (Fail) Then - Write (6,*) 'PSOAO2: memory partitioning failed!' - Write (6,*) ' Restart with more memory!' - Call Abend() - End If - Go To 999 - End If - Mem0 = Mem0 - Mem1 - 1 -*--------------------------------------------------------------- -* -* MemFck: Target for generating the symmetrized Fock Matrix. -* Distributed localy. -* MemMo : Target for generating the MO integrals -* Distributed localy. -* Whole work area is used, if work area is big enough -* work3 is increased -* -*--------------------------------------------------------------- -* - MemDep=nijkl*nabcd -* Temp+S1+S2 - MemFck=2*MemDep+Max(MemDep,nijkl+ - & Max(iBsInc*lBsInc,jBsInc*lBsInc, - & iBsInc*kBsInc,jBsInc*kBsInc)) - nFT=iBsInc*jBsInc*iCmp*jCmp+kBsInc*lBsInc*kCmp*lCmp+ - & iBsInc*kBsInc*iCmp*kCmp+jBsInc*lBsInc*jCmp*lCmp+ - & iBsInc*lBsInc*iCmp*lCmp+jBsInc*kBsInc*jCmp*kCmp - MemFck=MemFck+nFT - If (nmethod.eq.RASSCF) Then -* -* 3 scratch spaces, sorted integrals and translation -* - nMaxC=nACO - MemFck=MemFck+2*nMaxC - nMax=Max(iCmp*iBsInc,jCmp*jBsInc,kCmp*kBsInc,lcmp*lBsInc) - nMax=Max(nMax,nMaxC) - memMO=3*nMax**4+10*nabcd*nijkl - Else - MemMo=0 - End If -* -*--------------------------------------------------------------------- -* -*-----*** Work2 and Work4 *** -* -*-----Memory for 2nd order density matrix in contracted basis (both -* cartesian and spherical harmonic) and in primitive basis. -* MemDeP: Target for desymmetrization -* MemTrn: Scratch and target for decontraction -* MemAux: Contracted 2nd order density matrix (if partial decon.) -* MemSph: transformation spherical harmonics to cartesian, source -* and target. - - MemDeP = nabcd * nijkl - MemTrn = mabcd * Max(iBsInc*jBsInc*kBsInc*lBsInc, - & iPrInc*jPrInc*kBsInc*lBsInc, - & iPrInc*jPrInc*kPrInc*lPrInc) - MemTrn=MemTrn+1 - -*-----If partial decontraction we need to keep the contracted 2nd -* order density matrix. (Work4) - If (jPrInc.ne.jPrim .or. lPrInc.ne.lPrim) Then - MemAux = mabcd*iBsInc*jBsInc*kBsInc*lBsInc - Else - MemAux = 0 - End If - MemSph = mabcd * iBsInc*jBsInc*kBsInc*lBsInc - Mem2 = Max(MemTrn+MemAux,MemDeP,MemSph) - MemFck=MemFck-Mem2 - MemMO=MemMo-Mem2 - If (Mem2+1.gt.Mem0) Then - MaxReq=Max(MaxReq,Mem2+1-Mem0) - Call Change(iBas, iBsInc,QiBas, kBas, kBsInc,QkBas, - & jBas, jBsInc,QjBas, lBas, lBsInc,QlBas, - & jPrim,jPrInc,QjPrim,lPrim,lPrInc,QlPrim,MaxReq, - & Fail) - If (Fail) Then - Write (6,*) 'PSOAO2: memory partitioning failed!' - Write (6,*) ' Restart with more memory!' - Call Abend() - End If - Go To 999 - End If -*-----Subtract one additional word for getmem's internal error check - Mem0 = Mem0 - Mem2 - 1 - MemX = 9*mabcd * iBsInc*jBsInc*kBsInc*lBsInc - MemFck=MemFck-MemX - MemMO=MemMo-MemX - If (MemX+1.gt.Mem0) Then - MaxReq=Max(MaxReq,MemX+1-Mem0) - Call Change(iBas, iBsInc,QiBas, kBas, kBsInc,QkBas, - & jBas, jBsInc,QjBas, lBas, lBsInc,QlBas, - & jPrim,jPrInc,QjPrim,lPrim,lPrInc,QlPrim,MaxReq, - & Fail) - If (Fail) Then - Write (6,*) 'PSOAO2: memory partitioning failed!' - Write (6,*) ' Restart with more memory!' - Call Abend() - End If - Go To 999 - End If - Mem0=Mem0-MemX - -* -*-----*** Work3 and Work5 *** -* -*-----Scratch for decontraction and transformation to spherical gaussian. -* Working array for Rysg2. -* Scratch area for resolving degeneracies due to the double coset -* treatement of the symmetry. -* MemTrn: Scratch for decontraction -* MemRys: Scratch for calualation of primitive integral gradients. -* - iFac = 1 - If (mabcd.ne.1) iFac = 2 - MemF=9*nabcd*nijkl - MemTrn=mabcd * Max(iPrInc*jBsInc*kBsInc*lBsInc, - & iPrInc*jPrInc*kPrInc*lBsInc, - & iPrInc*jPrInc*kPrInc*lPrInc*iFac) - MemRys=MemPrm * iPrInc*jPrInc*kPrInc*lPrInc+80 -* -* Scratch space for contraction of the integrals -* - MemCntrct=9*mabcd*(Max(iBsInc*jBsInc*kBsInc*lPrInc, - & iBsInc*jPrInc*kPrInc*lPrInc)+ - & iBsInc*jBsInc*kPrInc*lPrInc) - - MemFck=Max(0,MemFck) - MemMo=Max(0,MemMo) - Mem3 = Max(MemMO,MemFck,MemTrn, MemRys, 2*MemF, - & MemF+MemCntrct) - If (Mem3+1.gt.Mem0) Then - MaxReq=Max(MaxReq,Mem3+1-Mem0) - Call Change(iBas, iBsInc,QiBas, kBas, kBsInc,QkBas, - & jBas, jBsInc,QjBas, lBas, lBsInc,QlBas, - & jPrim,jPrInc,QjPrim,lPrim,lPrInc,QlPrim,MaxReq, - & Fail) - If (Fail) Then - Write (6,*) 'PSOAO2: memory partitioning failed!' - Write (6,*) ' Restart with more memory!' - Call Abend() - End If - Go To 999 - End If -*-----Subtract one additional word for getmem's internal error check - Mem0 = Mem0 - Mem3 - 1 -* -*-----Work4, if used, is placed at the end of Work2 - If (jPrInc.ne.jPrim .or. lPrInc.ne.lPrim) Then - Mem4 = MemAux - Else - Mem4 = Mem2 - End If -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/psoao2.F90 openmolcas-22.10/src/mckinley/psoao2.F90 --- openmolcas-22.02/src/mckinley/psoao2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/psoao2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,368 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990,1992, Roland Lindh * +! 1990, IBM * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine PSOAO2(nSO,MemPrm,MemM,iAnga,iCmpa,iAO,iFnc,iBas,iBsInc,jBas,jBsInc,kBas,kBsInc,lBas,lBsInc,iPrim,iPrInc,jPrim,jPrInc, & + kPrim,kPrInc,lPrim,lPrInc,nAco,Mem1,Mem2,Mem3,Mem4,MemX,MemPSO,MemFck,nFT,nCMO,MemFin,MemBuffer,iMemB) +!*********************************************************************** +! * +! Object: to partion the SO and AO block. It will go to some length * +! before it will start and break up the SO block. This will * +! reduce the total flop count. However, as we are breaking up * +! the AO block this will affect the vectorization. Hence, at * +! some point it will actually be better to recompute the * +! primitives. * +! Current stratergy: * +! 1. Reduce the size of the density matrix and buffer so that * +! it fits into memory. * +! * +! 2. Start reducing the length of the primitives in the order * +! lPrim,jPrim. * +! * +! 3. Reduce the size of the SO block by reducing the number of* +! basis functions in the order lBas, jBas. * +! * +! 4. Reduce the size of the Buffer. * +! * +! 5. Reduce kBas,iBas * +! * +! 6. Terminate run telling job max and min of additional * +! memory needed to perform the calculation. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! Modified to first order derivatives. January '92 * +! Anders Bernhardsson Theoretical chemistry, Lund 1995 * +!*********************************************************************** + +! Memory map for mckinley +! +!--------------------------------------------------------------------------- +!| | | | | | | +!|REAL | P TRANSF | RYSG2 | Transf | FCK GENERAT |MO Transf | +!| | | | | | | +!--------------------------------------------------------------------------- +!| | | | | |Scratch | +!| MX | | | 9*abcd*ijkl | SS |space | +!| | | | | | | +!--------------------------------------------------------------------------- +!| | | | | | | +!| M3 |Scratch space |Memrys |Scratch space | SS | Scratch | +!| | | | | | space | +!--------------------------------------------------------------------------- +!| |MEM4 (half tr) |*******|***************| | | +!| M2 | | | | | SS | +!| |PSO transf | | |Scratch space | | +!--------------------------------------------------------------------------- +!| | | | | | | +!| M1 | P | * | * | * | * | +!| | | | | | | +!--------------------------------------------------------------------------- +!| | ? | | | | | +!|Buffer|***************|*******|Transformed |***************|**********| +!| | | |integrals | | | +!--------------------------------------------------------------------------- + +use McKinley_global, only: nMethod, RASSCF +use Index_Functions, only: nTri_Elem1 +use Gateway_global, only: force_part_p !, force_part_c +use SOAO_Info, only: iAOtSO +use pso_stuff, only: lPSO +use Sizes_of_Seward, only: S +use Symmetry_Info, only: nIrrep +use Definitions, only: iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nSO, MemPrm, MemM, iAnga(4), iCmpa(4), iAO(4), iBas, jBas, kBas, lBas, iPrim, jPrim, kPrim, & + lPrim, nAco, iMemB +integer(kind=iwp), intent(out) :: iFnc(4), iBsInc, jBsInc, kBsInc, lBsInc, iPrInc, jPrInc, kPrInc, lPrInc, Mem1, Mem2, Mem3, Mem4, & + MemX, MemPSO, MemFck, nFT, nCMO, MemFin, MemBuffer +#include "pstat.fh" +integer(kind=iwp) :: i1, iiBas(4), iCmp, iFac, iTmp1, j, jCmp, jPam, kCmp, kSOInt, la, lb, lc, lCmp, ld, mabcd, Mem0, MemAux, & + MemCntrct, MemDep, MemF, MemMax, MemMO, MemRys, MemScr, MemSph, MemTrn, nabcd, nFac, nijkl, nMax, nMaxC, & + nPam(4,0:7), nTmp1, nTmp2 +logical(kind=iwp) :: Fail, QiBas, QjBas, QjPrim, QkBas, QlBas, QlPrim +integer(kind=iwp), external :: MemTra + +!iRout = 10 +!iPrint = nPrint(iRout) +la = iAnga(1) +lb = iAnga(2) +lc = iAnga(3) +ld = iAnga(4) +iCmp = iCmpa(1) +jCmp = iCmpa(2) +kCmp = iCmpa(3) +lCmp = iCmpa(4) +iTotal = iTotal+1 +mabcd = nTri_Elem1(la)*nTri_Elem1(lb)*nTri_Elem1(lc)*nTri_Elem1(ld) +nabcd = iCmp*jCmp*kCmp*lCmp + +!if (force_part_c) then +! iBsInc = (iBas+1)/2 +! jBsInc = (jBas+1)/2 +! kBsInc = (kBas+1)/2 +! lBsInc = (lBas+1)/2 +!else +iBsInc = iBas +jBsInc = jBas +kBsInc = kBas +lBsInc = lBas +!end if +if (force_part_p) then + jPrInc = (jPrim+1)/2 + !lPrInc = (lPrim+1)/2 +else + jPrInc = jPrim + !lPrInc = lPrim +end if +iPrInc = iPrim +kPrInc = kPrim +lPrInc = lPrim +MemBuffer = iMemB +MemMax = MemM-MemBuffer + +do + nijkl = iBsInc*jBsInc*kBsInc*lBsInc + QjPrim = .false. + QlPrim = .true. + QiBas = .false. + QjBas = .false. + QkBas = .false. + QlBas = .false. + Mem0 = MemMax + + ! Picked MO coeff + + if (nMethod == RASSCF) then + nCMO = nACO*kCmp*kBas+nACO*lCmp*lBas + else + nCMO = 0 + end if + + ! Area for integral storage before transforming them to FM/MO + ! and place for the CMOs + + MemFin = 9*nijkl*nabcd + if (MemFin+ncmo+1 > Mem0) then + MaxReq = max(MaxReq,nCMO+MemFin+1-Mem0) + QlPrim = .false. + call Change(iBas,iBsInc,QiBas,kBas,kBsInc,QkBas,jBas,jBsInc,QjBas,lBas,lBsInc,QlBas,jPrim,jPrInc,QjPrim,lPrim,lPrInc,QlPrim, & + MaxReq,Fail) + if (Fail) then + write(u6,*) 'PSOAO2: memory partitioning failed!' + write(u6,*) ' Restart with more memory!' + call Abend() + end if + cycle + end if + ! Subtract one additional word for getmem's internal error check + Mem0 = Mem0-MemFin-nCMO-1 + + !--------------------------------------------------------------------- + + ! *** Work1 *** + + ! Memory for 2nd order density matrix in SO basis. + + kSOInt = nSO*iBsInc*jBsInc*kBsInc*lBsInc + Mem1 = kSOInt + + ! Allocate memory for MO to SO/AO transformation + ! of the 2nd order density matrix for this shell quadruplet. + ! and area for AO/SO transformation of Fock matrix. + + if (lPSO) then + iiBas(1) = iBsInc + iiBas(2) = jBsInc + iiBas(3) = kBsInc + iiBas(4) = lBsInc + nPam(:,:) = 0 + MemPSO = 1 + nTmp2 = 0 + !call IecPrt('iiBas',iiBas,1,4) + + do jPam=1,4 + iTmp1 = 0 + nTmp1 = 0 + do j=0,nIrrep-1 + do i1=1,iCmpa(jPam) + if (iAOtSO(iAO(jPam)+i1,j) > 0) then + nPam(jPam,j) = nPam(jPam,j)+iiBas(jPam) + nTmp1 = nTmp1+iiBas(jPam) + iTmp1 = iTmp1+1 + end if + end do + end do + MemPSO = MemPSO*nTmp1 + nTmp2 = nTmp2+nTmp1 + iFnc(jPam) = iTmp1 + end do + MemScr = MemTra(nPam) + nFac = 4 + nTmp2 = nTmp2+4 + else + MemScr = 0 + MemPSO = 0 + nFac = 0 + nTmp2 = 0 + end if + MemAux = MemPSO+MemScr+nFac*S%nDim+nTmp2+4 + if (Mem1+1+MemAux > Mem0) then + MaxReq = max(MaxReq,Mem1+1+MemAux-Mem0) + QjPrim = .false. + QlPrim = .false. + QiBas = .false. + QjBas = .false. + QkBas = .false. + QlBas = .true. + call Change(iBas,iBsInc,QiBas,kBas,kBsInc,QkBas,jBas,jBsInc,QjBas,lBas,lBsInc,QlBas,jPrim,jPrInc,QjPrim,lPrim,lPrInc,QlPrim, & + MaxReq,Fail) + if (Fail) then + write(u6,*) 'PSOAO2: memory partitioning failed!' + write(u6,*) ' Restart with more memory!' + call Abend() + end if + cycle + end if + Mem0 = Mem0-Mem1-1 + !--------------------------------------------------------------------- + ! + ! MemFck: Target for generating the symmetrized Fock Matrix. + ! Distributed localy. + ! MemMo : Target for generating the MO integrals + ! Distributed localy. + ! Whole work area is used, if work area is big enough work3 is increased + ! + !---------------------------------------------------------------------- + + MemDep = nijkl*nabcd + ! Temp+S1+S2 + MemFck = 2*MemDep+max(MemDep,nijkl+max(iBsInc*lBsInc,jBsInc*lBsInc,iBsInc*kBsInc,jBsInc*kBsInc)) + nFT = iBsInc*jBsInc*iCmp*jCmp+kBsInc*lBsInc*kCmp*lCmp+iBsInc*kBsInc*iCmp*kCmp+jBsInc*lBsInc*jCmp*lCmp+iBsInc*lBsInc*iCmp*lCmp+ & + jBsInc*kBsInc*jCmp*kCmp + MemFck = MemFck+nFT + if (nmethod == RASSCF) then + + !3 scratch spaces, sorted integrals and translation + + nMaxC = nACO + MemFck = MemFck+2*nMaxC + nMax = max(iCmp*iBsInc,jCmp*jBsInc,kCmp*kBsInc,lcmp*lBsInc) + nMax = max(nMax,nMaxC) + MemMO = 3*nMax**4+10*nabcd*nijkl + else + MemMo = 0 + end if + + !--------------------------------------------------------------------- + + ! *** Work2 and Work4 *** + + ! Memory for 2nd order density matrix in contracted basis + ! (both cartesian and spherical harmonic) and in primitive basis. + ! MemDeP: Target for desymmetrization + ! MemTrn: Scratch and target for decontraction + ! MemAux: Contracted 2nd order density matrix (if partial decon.) + ! MemSph: transformation spherical harmonics to cartesian, source and target. + + MemDeP = nabcd*nijkl + MemTrn = mabcd*max(iBsInc*jBsInc*kBsInc*lBsInc,iPrInc*jPrInc*kBsInc*lBsInc,iPrInc*jPrInc*kPrInc*lPrInc) + MemTrn = MemTrn+1 + + ! If partial decontraction we need to keep the contracted 2nd + ! order density matrix. (Work4) + if ((jPrInc /= jPrim) .or. (lPrInc /= lPrim)) then + MemAux = mabcd*iBsInc*jBsInc*kBsInc*lBsInc + else + MemAux = 0 + end if + MemSph = mabcd*iBsInc*jBsInc*kBsInc*lBsInc + Mem2 = max(MemTrn+MemAux,MemDeP,MemSph) + MemFck = MemFck-Mem2 + MemMO = MemMo-Mem2 + if (Mem2+1 > Mem0) then + MaxReq = max(MaxReq,Mem2+1-Mem0) + call Change(iBas,iBsInc,QiBas,kBas,kBsInc,QkBas,jBas,jBsInc,QjBas,lBas,lBsInc,QlBas,jPrim,jPrInc,QjPrim,lPrim,lPrInc,QlPrim, & + MaxReq,Fail) + if (Fail) then + write(u6,*) 'PSOAO2: memory partitioning failed!' + write(u6,*) ' Restart with more memory!' + call Abend() + end if + cycle + end if + ! Subtract one additional word for getmem's internal error check + Mem0 = Mem0-Mem2-1 + MemX = 9*mabcd*iBsInc*jBsInc*kBsInc*lBsInc + MemFck = MemFck-MemX + MemMO = MemMo-MemX + if (MemX+1 > Mem0) then + MaxReq = max(MaxReq,MemX+1-Mem0) + call Change(iBas,iBsInc,QiBas,kBas,kBsInc,QkBas,jBas,jBsInc,QjBas,lBas,lBsInc,QlBas,jPrim,jPrInc,QjPrim,lPrim,lPrInc,QlPrim, & + MaxReq,Fail) + if (Fail) then + write(u6,*) 'PSOAO2: memory partitioning failed!' + write(u6,*) ' Restart with more memory!' + call Abend() + end if + cycle + end if + Mem0 = Mem0-MemX + + ! *** Work3 and Work5 *** + + ! Scratch for decontraction and transformation to spherical gaussian. + ! Working array for Rysg2. + ! Scratch area for resolving degeneracies due to the double coset + ! treatement of the symmetry. + ! MemTrn: Scratch for decontraction + ! MemRys: Scratch for calualation of primitive integral gradients. + + iFac = 1 + if (mabcd /= 1) iFac = 2 + MemF = 9*nabcd*nijkl + MemTrn = mabcd*max(iPrInc*jBsInc*kBsInc*lBsInc,iPrInc*jPrInc*kPrInc*lBsInc,iPrInc*jPrInc*kPrInc*lPrInc*iFac) + MemRys = MemPrm*iPrInc*jPrInc*kPrInc*lPrInc+80 + + ! Scratch space for contraction of the integrals + + MemCntrct = 9*mabcd*(max(iBsInc*jBsInc*kBsInc*lPrInc,iBsInc*jPrInc*kPrInc*lPrInc)+iBsInc*jBsInc*kPrInc*lPrInc) + + MemFck = max(0,MemFck) + MemMo = max(0,MemMo) + Mem3 = max(MemMO,MemFck,MemTrn,MemRys,2*MemF,MemF+MemCntrct) + if (Mem3+1 <= Mem0) exit + MaxReq = max(MaxReq,Mem3+1-Mem0) + call Change(iBas,iBsInc,QiBas,kBas,kBsInc,QkBas,jBas,jBsInc,QjBas,lBas,lBsInc,QlBas,jPrim,jPrInc,QjPrim,lPrim,lPrInc,QlPrim, & + MaxReq,Fail) + if (Fail) then + write(u6,*) 'PSOAO2: memory partitioning failed!' + write(u6,*) ' Restart with more memory!' + call Abend() + end if +end do +! Subtract one additional word for getmem's internal error check +Mem0 = Mem0-Mem3-1 + +! Work4, if used, is placed at the end of Work2 +if ((jPrInc /= jPrim) .or. (lPrInc /= lPrim)) then + Mem4 = MemAux +else + Mem4 = Mem2 +end if + +return + +end subroutine PSOAO2 diff -Nru openmolcas-22.02/src/mckinley/request_mclr_run.F90 openmolcas-22.10/src/mckinley/request_mclr_run.F90 --- openmolcas-22.02/src/mckinley/request_mclr_run.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/request_mclr_run.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,53 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1989-1992, Roland Lindh * +! 1990, IBM * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine Request_MCLR_Run(Run_MCLR,ireturn,iPrint) + +use Definitions, only: iwp, u6 + +implicit none +logical(kind=iwp), intent(in) :: Run_MCLR +integer(kind=iwp), intent(out) :: ireturn +integer(kind=iwp), intent(in) :: iPrint +#include "warnings.h" +integer(kind=iwp) :: LuInput +character(len=16) :: StdIn +integer(kind=iwp), external :: IsFreeUnit + +if (Run_MCLR) then + + ! McKinley will automatically generate the input for MCLR + ! and signal to AUTO (iRC=2) to run the input file Stdin.x. + + if (iPrint >= 6) then + write(u6,*) + write(u6,*) ' McKinley requests the MCLR module to be executed!' + write(u6,*) + end if + + LuInput = IsFreeUnit(11) + call StdIn_Name(StdIn) + call Molcas_Open(LuInput,StdIn) + write(LuInput,'(A)') ' &MCLR &End' + write(LuInput,'(A)') 'End of Input' + close(LuInput) + ireturn = _RC_INVOKED_OTHER_MODULE_ +else + ireturn = _RC_ALL_IS_WELL_ +end if + +return + +end subroutine Request_MCLR_Run diff -Nru openmolcas-22.02/src/mckinley/rtocore.f openmolcas-22.10/src/mckinley/rtocore.f --- openmolcas-22.02/src/mckinley/rtocore.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/rtocore.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,79 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine RToCore(F,nBeta,ishll,lb,iAng,nveccb) -******************************************************************************* -* -* Transformation kernel to atomic orbials in normailized spherical harmonics -* -******************************************************************************* -* @parameter F The cartesian components of -* @parameter nBeta Number of exponents -* @parameter ishll Shell number for ECP -* @parameter lb angular momenta Ket -* @parameter iAng angular momenta core -* @parameter nveccb Number of derivatives -******************************************************************************* -* - use Real_Spherical - use Basis_Info - Implicit Real*8 (a-h,o-z) - -#include "real.fh" -#include "stdalloc.fh" - Real*8 F(*) - Real*8, Allocatable:: Tmp1(:), Tmp2(:) - - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - -******************************************************************************* - ncb=nelem(lb)*nelem(iang) - nExpi=Shells(iShll)%nExp - nBasisi=Shells(iShll)%nBasis - Call mma_allocate(TMP1,nExpi*ncb*nVecCB*nBeta,Label='Tmp1') - Call mma_allocate(TMP2,nExpi*ncb*nVecCB*nBeta,Label='Tmp2') -* -*--------------And (almost) the same thing for the righthand side, form -* KjCb from kjcb -* 1) jcb,K = k,jcb * k,K -* - Call DGEMM_('T','N', - & nBeta*ncb*nVecCB,nBasisi,nExpi, - & One,F,nExpi, - & Shells(iShll)%pCff,nExpi, - & Zero,Tmp1,nBeta*ncb*nVecCB) -* -*--------------2) j,cbK -> cbK,j -* - Call DgeTMo(Tmp1,nBeta,nBeta, - & ncb*nVecCB*nBasisi,Tmp2, - & ncb*nVecCB*nBasisi) -* -*--------------3) bKj,C = c,bKj * c,C -* - Call DGEMM_('T','N', - & nElem(lb)*nVecCB*nBasisi*nBeta, - & (2*iAng+1),nElem(iAng), - & One,Tmp2,nElem(iAng), - & RSph(ipSph(iAng)),nElem(iAng), - & Zero,Tmp1, - & nElem(lb)*nVecCB*nBasisi*nBeta) -* -*--------------4) b,KjC -> KjC,b -* - Call DgeTMo(Tmp1,nElem(lb)*nVecCB, - & nElem(lb)*nVecCB, - & nBasisi*nBeta*(2*iAng+1),F, - & nBasisi*nBeta*(2*iAng+1)) -* - Call mma_deallocate(Tmp2) - Call mma_deallocate(Tmp1) - Return - End diff -Nru openmolcas-22.02/src/mckinley/rtocore.F90 openmolcas-22.10/src/mckinley/rtocore.F90 --- openmolcas-22.02/src/mckinley/rtocore.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/rtocore.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,71 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine RToCore(F,nBeta,ishll,lb,iAng,nveccb) + +!*********************************************************************** +! +! Transformation kernel to atomic orbitals in normalized spherical harmonics +! +!*********************************************************************** +! @parameter F The cartesian components of +! @parameter nBeta Number of exponents +! @parameter ishll Shell number for ECP +! @parameter lb angular momenta Ket +! @parameter iAng angular momenta core +! @parameter nveccb Number of derivatives +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Real_Spherical, only: ipSph, RSph +use Basis_Info, only: Shells +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(inout) :: F(*) +integer(kind=iwp), intent(in) :: nBeta, ishll, lb, iAng, nveccb +integer(kind=iwp) :: nBasisi, ncb, nExpi +real(kind=wp), allocatable :: Tmp1(:), Tmp2(:) + +!*********************************************************************** +ncb = nTri_Elem1(lb)*nTri_Elem1(iang) +nExpi = Shells(iShll)%nExp +nBasisi = Shells(iShll)%nBasis +call mma_allocate(TMP1,nExpi*ncb*nVecCB*nBeta,Label='Tmp1') +call mma_allocate(TMP2,nExpi*ncb*nVecCB*nBeta,Label='Tmp2') + +! And (almost) the same thing for the righthand side, form +! KjCb from kjcb +! 1) jcb,K = k,jcb * k,K + +call DGEMM_('T','N',nBeta*ncb*nVecCB,nBasisi,nExpi,One,F,nExpi,Shells(iShll)%pCff,nExpi,Zero,Tmp1,nBeta*ncb*nVecCB) + +! 2) j,cbK -> cbK,j + +call DgeTMo(Tmp1,nBeta,nBeta,ncb*nVecCB*nBasisi,Tmp2,ncb*nVecCB*nBasisi) + +! 3) bKj,C = c,bKj * c,C + +call DGEMM_('T','N',nTri_Elem1(lb)*nVecCB*nBasisi*nBeta,(2*iAng+1),nTri_Elem1(iAng),One,Tmp2,nTri_Elem1(iAng),RSph(ipSph(iAng)), & + nTri_Elem1(iAng),Zero,Tmp1,nTri_Elem1(lb)*nVecCB*nBasisi*nBeta) + +! 4) b,KjC -> KjC,b + +call DgeTMo(Tmp1,nTri_Elem1(lb)*nVecCB,nTri_Elem1(lb)*nVecCB,nBasisi*nBeta*(2*iAng+1),F,nBasisi*nBeta*(2*iAng+1)) + +call mma_deallocate(Tmp2) +call mma_deallocate(Tmp1) + +return + +end subroutine RToCore diff -Nru openmolcas-22.02/src/mckinley/rtosph.f openmolcas-22.10/src/mckinley/rtosph.f --- openmolcas-22.02/src/mckinley/rtosph.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/rtosph.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,73 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine RToSph(F,nBeta,ishll,lb,iAng,nveccb) -******************************************************************************* -* -* Transform from Cartesian components to Sperical harmonics -* -******************************************************************************* -* @parameter F The cartesian components of (in) -* The spherical components of (out) -* @parameter nBeta Number of exponents -* @parameter ishll Shell number for ECP -* @parameter lb angular momenta Ket -* @parameter iAng angular momenta core -* @parameter Number of derivatives -******************************************************************************* - use Real_Spherical - use Basis_Info, only: Shells - Implicit Real*8 (a-h,o-z) - -#include "real.fh" -#include "stdalloc.fh" - Dimension F(*) - Real*8, Allocatable:: Tmp1(:), Tmp2(:) - - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - -******************************************************************************* - - ncb=nelem(lb)*nelem(iang) - nExpi=Shells(iShll)%nExp - Call mma_allocate(TMP1,nExpi*ncb*nVecCB*nBeta,Label='Tmp1') - Call mma_allocate(TMP2,nExpi*ncb*nVecCB*nBeta,Label='Tmp2') - - -*-------------1) kj,cbx -> cbx,kj -* - Call DgeTMo(F, - & nBeta*nExpi,nBeta*nExpi, - & ncb*nVecCB,Tmp1,ncb*nVecCB) -* -*--------------2) bxkj,C = c,bxkj * c,C -* - Call DGEMM_('T','N', - & nElem(lb)*nVecCB*nExpi*nBeta, - & (2*iAng+1),nElem(iAng), - & One,Tmp1,nElem(iAng), - & RSph(ipSph(iAng)),nElem(iAng), - & Zero,Tmp2,nElem(lb)*nVecCB*nExpi*nBeta) -* -*--------------3) bx,kjC -> kjC,bx -* - Call DgeTMo(Tmp2,nElem(lb)*nVecCB, - & nElem(lb)*nVecCB, - & nExpi*nBeta*(2*iAng+1),Tmp1, - & nExpi*nBeta*(2*iAng+1)) - - call dcopy_(nExpi* - & nBeta*(2*iAng+1)*nElem(lb)*nVecCB, - & Tmp1,1,F,1) - - Call mma_deallocate(Tmp1) - Call mma_deallocate(Tmp2) - Return - End diff -Nru openmolcas-22.02/src/mckinley/rtosph.F90 openmolcas-22.10/src/mckinley/rtosph.F90 --- openmolcas-22.02/src/mckinley/rtosph.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/rtosph.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,65 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine RToSph(F,nBeta,ishll,lb,iAng,nveccb) +!*********************************************************************** +! +! Transform from Cartesian components to Sperical harmonics +! +!*********************************************************************** +! @parameter F The cartesian components of (in) +! The spherical components of (out) +! @parameter nBeta Number of exponents +! @parameter ishll Shell number for ECP +! @parameter lb angular momenta Ket +! @parameter iAng angular momenta core +! @parameter Number of derivatives +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Real_Spherical, only: ipSph, RSph +use Basis_Info, only: Shells +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(inout) :: F(*) +integer(kind=iwp), intent(in) :: nBeta, ishll, lb, iAng, nveccb +integer(kind=iwp) :: ncb, nExpi +real(kind=wp), allocatable :: Tmp1(:), Tmp2(:) + +!*********************************************************************** + +ncb = nTri_Elem1(lb)*nTri_Elem1(iang) +nExpi = Shells(iShll)%nExp +call mma_allocate(TMP1,nExpi*ncb*nVecCB*nBeta,Label='Tmp1') +call mma_allocate(TMP2,nExpi*ncb*nVecCB*nBeta,Label='Tmp2') + +! ) kj,cbx -> cbx,kj + +call DgeTMo(F,nBeta*nExpi,nBeta*nExpi,ncb*nVecCB,Tmp1,ncb*nVecCB) + +! 2) bxkj,C = c,bxkj * c,C + +call DGEMM_('T','N',nTri_Elem1(lb)*nVecCB*nExpi*nBeta,(2*iAng+1),nTri_Elem1(iAng),One,Tmp1,nTri_Elem1(iAng),RSph(ipSph(iAng)), & + nTri_Elem1(iAng),Zero,Tmp2,nTri_Elem1(lb)*nVecCB*nExpi*nBeta) + +! 3) bx,kjC -> kjC,bx + +call DgeTMo(Tmp2,nTri_Elem1(lb)*nVecCB,nTri_Elem1(lb)*nVecCB,nExpi*nBeta*(2*iAng+1),F,nExpi*nBeta*(2*iAng+1)) + +call mma_deallocate(Tmp1) +call mma_deallocate(Tmp2) + +return + +end subroutine RToSph diff -Nru openmolcas-22.02/src/mckinley/schint_mck.f openmolcas-22.10/src/mckinley/schint_mck.f --- openmolcas-22.02/src/mckinley/schint_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/schint_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,128 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990-1992, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine SchInt_mck(CoorM,iAnga,iCmp, - & nAlpha,nBeta,nMemab, - & Zeta,ZInv,rKapab,P,nZeta, - & Work2,nWork2,Work3,nWork3) -************************************************************************ -* * -* Object: to compute zeta, kappa, P, and the integrals [nm|nm] for * -* prescreening. This is done for all unique pairs of centers * -* generated from the symmetry unique centers A and B. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* June '91, modified to compute zeta, P, kappa and inte- * -* grals for Schwartz inequality in a k2 loop. * -* April '92 modified from k2Loop to a separate subroutine * -* for estimates of the gradient. * -************************************************************************ - use Real_Spherical - Implicit Real*8 (A-H,O-Z) -* External TERISq, ModU2, Cff2Dq - External TERIS, ModU2, Cff2DS,rys2d -#include "real.fh" - Real*8 CoorM(3,4), CoorAC(3,2), - & Zeta(nZeta), ZInv(nZeta), rKapab(nZeta), P(nZeta,3), - & Q(3), Work2(nWork2), Work3(nWork3) - Integer iAnga(4), iCmp(4) - Logical EQ, NoSpecial -* -* Statement function to compute canonical index -* - nabSz(ixyz) = (ixyz+1)*(ixyz+2)*(ixyz+3)/6 - 1 - nElem(i) = (i+1)*(i+2)/2 -* - call dcopy_(3,[One],0,Q,1) - la = iAnga(1) - lb = iAnga(2) -* -* -*-----Compute primitive integrals to be used in the prescreening -* by the Schwartz inequality. -* -* -*-----Compute actual size of [a0|c0] block -* - mabMin=nabSz(Max(la,lb)-1)+1 - If (EQ(CoorM(1,1),CoorM(1,2))) mabMin = nabSz(la+lb-1)+1 - mabMax=nabSz(la+lb) - mcdMin=mabmin - mcdMax=mabMax -* -*-----Find the proper centers to start of with the angular -* momentum on. If la.eq.lb there will excist an -* ambiguity to which center that angular momentum should -* be accumulated on. In that case we will use A and C of -* the order as defined by the basis functions types. -* - If (iAnga(1).ge.iAnga(2)) Then - call dcopy_(3,CoorM(1,1),1,CoorAC(1,1),1) - call dcopy_(3,CoorM(1,3),1,CoorAC(1,2),1) - Else - call dcopy_(3,CoorM(1,2),1,CoorAC(1,1),1) - call dcopy_(3,CoorM(1,4),1,CoorAC(1,2),1) - End If -* - mZeta = nAlpha*nBeta -* -*-----Compute [a0|c0], ijkl,a,c -* - nT = mZeta*1 - NoSpecial=.True. - Call Rys(iAnga,nT, - & Zeta,ZInv, mZeta,[One],[One],1, - & P, nZeta,Q,1,rKapab, [One], - & CoorM,CoorM,CoorAC, - & mabMin,mabMax,mcdMin,mcdMax, - & Work2,nWork2,TERIS,ModU2,Cff2DS, - & Rys2D,NoSpecial) -* -*-----Apply transfer equation to generate [a0|cd], IJKLa,c,d -* - nijkla = (mabMax-mabMin+1)*mZeta - Call HRR(la,lb,CoorM(1,1),CoorM(1,2),Work2,nijkla,nMemab,ipIn) -* -*-----Transform to spherical gaussians [a0|CD], CDIJKL,a. This -* will also put the integrals in the right position for the -* transfer equation. -* - Call CrSph1(Work2(ipIn),nijkla, - & Work3,nWork3, - & RSph(ipSph(la)),nElem(la),nElem(la), - & .False.,.False., - & RSph(ipSph(lb)),nElem(lb),nElem(lb), - & .False.,.False., - & Work2,nElem(la)*nElem(lb)) -* -*-----Apply transfer equation to generate [ab|CD], CDIJKL,a,b -* - ijklcd = nElem(la)*nElem(lb)*mZeta - Call HRR(la,lb,CoorM(1,1),CoorM(1,2),Work2,ijklcd,nMemab,ipIn) -* -*-----Transform to spherical gaussians [AB|CD], IJKL,ABCD -* - Call CrSph2(Work2(ipIn),mZeta, - & nElem(la)*nElem(lb),Work3,nWork3, - & RSph(ipSph(la)),nElem(la),nElem(la), - & .False.,.False., - & RSph(ipSph(lb)),nElem(lb),nElem(lb), - & .False.,.False., - & Work2,nElem(la)*nElem(lb)) -* - Return -* Avoid unused argument warnings - If (.False.) Call Unused_integer_array(iCmp) - End diff -Nru openmolcas-22.02/src/mckinley/schint_mck.F90 openmolcas-22.10/src/mckinley/schint_mck.F90 --- openmolcas-22.02/src/mckinley/schint_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/schint_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,109 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990-1992, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine SchInt_mck(CoorM,iAnga,nAlpha,nBeta,nMemab,Zeta,ZInv,rKapab,P,nZeta,Work2,nWork2,Work3,nWork3) +!*********************************************************************** +! * +! Object: to compute zeta, kappa, P, and the integrals [nm|nm] for * +! prescreening. This is done for all unique pairs of centers * +! generated from the symmetry unique centers A and B. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! June '91, modified to compute zeta, P, kappa and inte- * +! grals for Schwartz inequality in a k2 loop. * +! April '92 modified from k2Loop to a separate subroutine * +! for estimates of the gradient. * +!*********************************************************************** + +use Index_Functions, only: nTri3_Elem1, nTri_Elem1 +use Real_Spherical, only: ipSph, RSph +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iAnga(4), nAlpha, nBeta, nMemab, nZeta, nWork2, nWork3 +real(kind=wp), intent(in) :: CoorM(3,4), Zeta(nZeta), ZInv(nZeta), rKapab(nZeta), P(nZeta,3) +real(kind=wp), intent(inout) :: Work3(nWork3) +real(kind=wp), intent(out) :: Work2(nWork2) +integer(kind=iwp) :: ijklcd, ipIn, la, lb, mabMax, mabMin, mcdMax, mcdMin, mZeta, nijkla, nT +real(kind=wp) :: CoorAC(3,2), Q(3) +logical(kind=iwp) :: NoSpecial +logical(kind=iwp), external :: EQ +external :: TERIS, ModU2, Cff2DS, rys2d + +Q(:) = One +la = iAnga(1) +lb = iAnga(2) + +! Compute primitive integrals to be used in the prescreening +! by the Schwartz inequality. + +! Compute actual size of [a0|c0] block + +mabMin = nTri3_Elem1(max(la,lb)-1) +if (EQ(CoorM(1,1),CoorM(1,2))) mabMin = nTri3_Elem1(la+lb-1) +mabMax = nTri3_Elem1(la+lb)-1 +mcdMin = mabmin +mcdMax = mabMax + +! Find the proper centers to start of with the angular +! momentum on. If la == lb there will exist an +! ambiguity to which center that angular momentum should +! be accumulated on. In that case we will use A and C of +! the order as defined by the basis functions types. + +if (iAnga(1) >= iAnga(2)) then + CoorAC(:,1) = CoorM(:,1) + CoorAC(:,2) = CoorM(:,3) +else + CoorAC(:,1) = CoorM(:,2) + CoorAC(:,2) = CoorM(:,4) +end if + +mZeta = nAlpha*nBeta + +! Compute [a0|c0], ijkl,a,c + +nT = mZeta*1 +NoSpecial = .true. +call Rys(iAnga,nT,Zeta,ZInv,mZeta,[One],[One],1,P,nZeta,Q,1,rKapab,[One],CoorM,CoorM,CoorAC,mabMin,mabMax,mcdMin,mcdMax,Work2, & + nWork2,TERIS,ModU2,Cff2DS,Rys2D,NoSpecial) + +! Apply transfer equation to generate [a0|cd], IJKLa,c,d + +nijkla = (mabMax-mabMin+1)*mZeta +call HRR(la,lb,CoorM(1,1),CoorM(1,2),Work2,nijkla,nMemab,ipIn) + +! Transform to spherical gaussians [a0|CD], CDIJKL,a. This +! will also put the integrals in the right position for the +! transfer equation. + +call CrSph1(Work2(ipIn),nijkla,Work3,nWork3,RSph(ipSph(la)),nTri_Elem1(la),nTri_Elem1(la),.false.,.false.,RSph(ipSph(lb)), & + nTri_Elem1(lb),nTri_Elem1(lb),.false.,.false.,Work2,nTri_Elem1(la)*nTri_Elem1(lb)) + +! Apply transfer equation to generate [ab|CD], CDIJKL,a,b + +ijklcd = nTri_Elem1(la)*nTri_Elem1(lb)*mZeta +call HRR(la,lb,CoorM(1,1),CoorM(1,2),Work2,ijklcd,nMemab,ipIn) + +! Transform to spherical gaussians [AB|CD], IJKL,ABCD + +call CrSph2(Work2(ipIn),mZeta,nTri_Elem1(la)*nTri_Elem1(lb),Work3,nWork3,RSph(ipSph(la)),nTri_Elem1(la),nTri_Elem1(la),.false., & + .false.,RSph(ipSph(lb)),nTri_Elem1(lb),nTri_Elem1(lb),.false.,.false.,Work2,nTri_Elem1(la)*nTri_Elem1(lb)) + +return + +end subroutine SchInt_mck diff -Nru openmolcas-22.02/src/mckinley/screen_mck.f openmolcas-22.10/src/mckinley/screen_mck.f --- openmolcas-22.02/src/mckinley/screen_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/screen_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,451 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1992, Roland Lindh * -* 1995, Anders Bernhardsson * -************************************************************************ -#define _Old_Code_ -#ifdef _Old_Code_ - SubRoutine Screen_mck(PAO,Scrtch,mPAO, - & nZeta,nEta,mZeta,mEta,lZeta,lEta, - & Zeta,ZInv,P,xA,xB,rKA, - & Data1,IndZ,ztmx,abmax,zexpmax, - & nAlpha,nBeta, - & Eta, EInv,Q,xG,xD,rKC,Data2,IndE, - & etmx,cdmax,eexpmax,nGamma,nDelta, - & xpre, - & iphX1,iphY1,iphZ1,iphX2,iphY2,iphZ2,CutInt, - & PreScr,IndZet,IndEta,ldot) -************************************************************************ -* * -* Object: to prescreen the integral derivatives. * -* * -* nZeta, nEta : unpartioned length of primitives. * -* * -* mZeta, mEta : section length due to partioning. These are usually * -* equal to nZeta and nEta. * -* * -* lZeta, lEta : section length after prescreening. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* March '92 * -* * -* April '92 modified for gradient estimate * -* * -* Anders Bernhardsson 1995 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "ndarray.fh" - Real*8 PAO(mZeta*mEta*mPAO),Scrtch(mZeta*mEta*(1+mPAO*2)), - & Zeta(nZeta), ZInv(nZeta), P(nZeta,3), - & Eta(nEta), EInv(nEta), Q(nEta, 3), - & xA(nZeta), xB(nZeta), xG(nEta), xD(nEta), - & Data1(nZeta*nDArray), - & Data2(nEta *nDArray), - & rKA(nZeta),rKC(nEta), - & xpre(mZeta*mEta) - Logical PreScr,ldot - Integer IndEta(nEta),IndZet(nZeta), IndZ(mZeta), IndE(mEta) -#include "real.fh" -#ifdef _DEBUGPRINT_ -#include "print.fh" -#endif -* -#ifdef _DEBUGPRINT_ - iRout = 180 - iPrint = nPrint(iRout) -* - If (iPrint.ge.99) Then - Call RecPrt(' Data1',' ',Data1,nZeta,nDArray) - Call RecPrt(' Data2',' ',Data2,nEta ,nDArray) - Call RecPrt('2nd order density matrix',' ', - & PAO,mZeta*mEta,mPAO) - End If -#endif -* - ip=1 - ipPAO = ip - ip = ip + mZeta*mEta*mPAO -* -*-----Compress all indices except zeta -* - ipOAP = ip - ip = ip + mZeta*mEta*mPAO - If (ldot) Call DGetMO(PAO,mZeta,mZeta,mEta*mPAO, - & Scrtch(ipOAP),mEta*mPAO) -* -*-----Prescreen Zeta -* - lZeta=0 - Call IZero(IndZet,nZeta) - If (PreScr) Then - Do iZeta = 1, mZeta - jZeta = IndZ(iZeta) - IndZet(jZeta) = -lZeta - abcd= Data1(ip_ab(iZeta,nZeta)) * cdMax - If (Abs(abcd).ge.CutInt) Then - lZeta=lZeta+1 - IndZet(jZeta) = lZeta - Zeta(lZeta) = Data1(ip_Z(iZeta,nZeta)) - rKA(lZeta) = Data1(ip_Kappa(iZeta,nZeta)) - P(lZeta,1) = Data1(ip_PCoor(iZeta ,nZeta)) - P(lZeta,2) = Data1(ip_PCoor(iZeta+ nZeta,nZeta)) - P(lZeta,3) = Data1(ip_PCoor(iZeta+2*nZeta,nZeta)) - xA(lZeta) = Data1(ip_Alpha(iZeta,nZeta,1)) - xB(lZeta) = Data1(ip_Beta (iZeta,nZeta,2)) - ZInv(lZeta) = Data1(ip_ZInv (iZeta,nZeta)) - ip1 = ipOAP + mEta*mPAO*(iZeta-1) - ip2 = ipPAO + mEta*mPAO*(lZeta-1) - If (lDot) call dcopy_(mEta*mPAO,Scrtch(ip1),1, - & Scrtch(ip2),1) - End If - End Do - Else - Do iZeta = 1, mZeta - lZeta=lZeta+1 - jZeta = IndZ(iZeta) - IndZet(jZeta) = lZeta - Zeta(lZeta) = Data1(ip_Z(iZeta,nZeta)) - rKA(lZeta) = Data1(ip_Kappa(iZeta,nZeta)) - P(lZeta,1) = Data1(ip_PCoor(iZeta ,nZeta)) - P(lZeta,2) = Data1(ip_PCoor(iZeta+ nZeta,nZeta)) - P(lZeta,3) = Data1(ip_PCoor(iZeta+2*nZeta,nZeta)) - xA(lZeta) = Data1(ip_Alpha(iZeta,nZeta,1)) - xB(lZeta) = Data1(ip_Beta (iZeta,nZeta,2)) - ZInv(lZeta) = Data1(ip_ZInv (iZeta,nZeta)) - ip1 = ipOAP + mEta*mPAO*(iZeta-1) - ip2 = ipPAO + mEta*mPAO*(lZeta-1) - If (lDot) call dcopy_(mEta*mPAO,Scrtch(ip1),1, - & Scrtch(ip2),1) - End Do - End If - If (lZeta.eq.0) Go To 999 -* - If (iphX1.ne.1) Call DScal_(lZeta,-One,P(1,1),1) - If (iphY1.ne.1) Call DScal_(lZeta,-One,P(1,2),1) - If (iphZ1.ne.1) Call DScal_(lZeta,-One,P(1,3),1) -* -*-----Transpose eta,mPAO,zeta to mPAO,zeta,eta -* - If (lDot) Call DGetMO(Scrtch(ipPAO),mEta,mEta,mPAO*lZeta, - & Scrtch(ipOAP),mPAO*lZeta) -* -*-----Prescreen Eta -* - lEta=0 - Call IZero(IndEta,nEta) - If (PreScr) Then - Do iEta = 1, mEta - jEta = IndE(iEta) - IndEta(jEta) = - lEta ! To be removed - abcd= Data2(ip_ab(iEta,nEta)) * abMax - If (Abs(abcd).ge.CutInt) Then - lEta=lEta+1 - IndEta(jEta) = lEta - Eta(lEta) = Data2(ip_Z (iEta,nEta)) - rKC(lEta) = Data2(ip_Kappa(iEta,nEta)) - Q(lEta,1) = Data2(ip_PCoor(iEta ,nEta)) - Q(lEta,2) = Data2(ip_PCoor(iEta+ nEta,nEta)) - Q(lEta,3) = Data2(ip_PCoor(iEta+2*nEta,nEta)) - xG(lEta) = Data2(ip_Alpha(iEta,nEta,1)) - xD(lEta) = Data2(ip_Beta (iEta,nEta,2)) - EInv(lEta) = Data2(ip_ZInv (iEta,nEta)) - ip1 = ipOAP + mPAO*lZeta*(iEta-1) - ip2 = ipPAO + mPAO*lZeta*(lEta-1) - If (ldot) call dcopy_(lZeta*mPAO,Scrtch(ip1),1, - & Scrtch(ip2),1) - End If - End Do - Else - Do iEta = 1, mEta - lEta=lEta+1 - jEta = IndE(iEta) - IndEta(jEta) = lEta - Eta(lEta) = Data2(ip_Z (iEta,nEta)) - rKC(lEta) = Data2(ip_Kappa(iEta,nEta)) - Q(lEta,1) = Data2(ip_PCoor(iEta ,nEta)) - Q(lEta,2) = Data2(ip_PCoor(iEta+ nEta,nEta)) - Q(lEta,3) = Data2(ip_PCoor(iEta+2*nEta,nEta)) - xG(lEta) = Data2(ip_Alpha(iEta,nEta,1)) - xD(lEta) = Data2(ip_Beta (iEta,nEta,2)) - EInv(lEta) = Data2(ip_ZInv (iEta,nEta)) - ip1 = ipOAP + mPAO*lZeta*(iEta-1) - ip2 = ipPAO + mPAO*lZeta*(lEta-1) - if (ldot) call dcopy_(lZeta*mPAO,Scrtch(ip1),1, - & Scrtch(ip2),1) - End Do - End If - If (lEta.eq.0) Go To 999 -* - If (iphX2.ne.1) Call DScal_(lEta,-One,Q(1,1),1) - If (iphY2.ne.1) Call DScal_(lEta,-One,Q(1,2),1) - If (iphZ2.ne.1) Call DScal_(lEta,-One,Q(1,3),1) -* -*-----Transpose mPAO,zeta,eta to zeta,eta,mPAO -* - If (ldot) Call DGeTMO(Scrtch(ipPAO),mPAO,mPAO,lZeta*lEta, - & PAO,lZeta*lEta) -* - 999 Continue -* - ij = 0 - Do iEta = 1,lEta - Et = Eta(iEta) - rKCD = rkC(iEta) - Do iZeta = 1,lZeta - Zt = Zeta(iZeta) - rKAB = rkA(iZeta) - ij = ij + 1 - xpre(ij) = rKAB*rKCD*Sqrt(1.0d0/(Zt+Et)) - End Do - End Do - If (ldot) Then - jPAO = 0 - Do iPAO = 1, mPAO - Do iZE = 0, lZeta*lEta-1 - jPAO=jPAO+1 - PAO(jPAO)=xpre(iZE+1)*PAO(jPAO) - End Do - End Do - End If -#ifdef _DEBUGPRINT_ - If (iPrint.ge.39) Call RecPrt(' PAO',' ', - & PAO,lZeta*lEta,mPAO) -#endif - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real(ztmx) - Call Unused_real(zexpmax) - Call Unused_integer(nAlpha) - Call Unused_integer(nBeta) - Call Unused_real(etmx) - Call Unused_real(eexpmax) - Call Unused_integer(nGamma) - Call Unused_integer(nDelta) - End If - End -#else - SubRoutine Screen_mck(PAO,Scrtch,mPAO, - & nZeta,nEta,mZeta,mEta,lZeta,lEta, - & Zeta,ZInv,P,xA,xB,rKA, - & Data1,IndZ,ztmx,abmax,zexpmax, - & nAlpha,nBeta, - & Eta, EInv,Q,xG,xD,rKC,Data2,IndE, - & etmx,cdmax,eexpmax,nGamma,nDelta, - & xpre, - & iphX1,iphY1,iphZ1,iphX2,iphY2,iphZ2,CutInt, - & PreScr,IndZet,IndEta,ldot) -************************************************************************ -* * -* Object: to prescreen the integral derivatives. * -* * -* nZeta, nEta : unpartioned length of primitives. * -* * -* mZeta, mEta : section length due to partioning. These are usually * -* equal to nZeta and nEta. * -* * -* lZeta, lEta : section length after prescreening. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* March '92 * -* * -* April '92 modified for gradient estimate * -* * -* Anders Bernhardsson 1995 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "ndarray.fh" - Real*8 PAO(mZeta*mEta*mPAO),Scrtch(mZeta*mEta*(1+mPAO*2)), - & Zeta(nZeta), ZInv(nZeta), P(nZeta,3), - & Eta(nEta), EInv(nEta), Q(nEta, 3), - & xA(nZeta), xB(nZeta), xG(nEta), xD(nEta), - & Data1(nZeta*nDArray), - & Data2(nEta *nDArray), - & rKA(nZeta),rKC(nEta), - & xpre(mZeta*mEta) - Logical PreScr,ldot - Integer IndEta(nEta),IndZet(nZeta), IndZ(mZeta), IndE(mEta) -#include "real.fh" -#ifdef _DEBUGPRINT_ -#include "print.fh" -#endif -* -#ifdef _DEBUGPRINT_ - iRout = 180 - iPrint = nPrint(iRout) -* - If (iPrint.ge.99) Then - Call RecPrt(' Data1',' ',Data1,nZeta,nDArray) - Call RecPrt(' Data2',' ',Data2,nEta ,nDArray) - Call RecPrt('2nd order density matrix',' ', - & PAO,mZeta*mEta,mPAO) - End If -#endif -* - ip=1 - ipPAO = ip - ip = ip + mZeta*mEta*mPAO -* -*-----Compress all indices except zeta -* - ipOAP = ip - ip = ip + mZeta*mEta*mPAO - If (ldot) Call DGetMO(PAO,mZeta,mZeta,mEta*mPAO, - & Scrtch(ipOAP),mEta*mPAO) -* -*-----Prescreen Zeta -* - lZeta=0 - If (PreScr) Then - Do iZeta = 1, mZeta - jZeta = IndZ(iZeta) - abcd= Data1(ip_ab(jZeta,nZeta)) * cdMax - If (Abs(abcd).ge.CutInt) Then - lZeta=lZeta+1 - IndZet(lZeta) = IndZ(iZeta) - Zeta(lZeta) = Data1(ip_Z(iZeta,nZeta)) - rKA(lZeta) = Data1(ip_Kappa(iZeta,nZeta)) - P(lZeta,1) = Data1(ip_PCoor(iZeta ,nZeta)) - P(lZeta,2) = Data1(ip_PCoor(iZeta+ nZeta,nZeta)) - P(lZeta,3) = Data1(ip_PCoor(iZeta+2*nZeta,nZeta)) - xA(lZeta) = Data1(ip_Alpha(iZeta,nZeta,1)) - xB(lZeta) = Data1(ip_Beta (iZeta,nZeta,2)) - ZInv(lZeta) = Data1(ip_ZInv (iZeta,nZeta)) - ip1 = ipOAP + mEta*mPAO*(iZeta-1) - ip2 = ipOAP + mEta*mPAO*(lZeta-1) - If (lDot) call dcopy_(mEta*mPAO,Scrtch(ip1),1, - & Scrtch(ip2),1) - End If - End Do - Else - Do iZeta = 1, mZeta - lZeta=lZeta+1 - IndZet(lZeta) = IndZ(iZeta) - Zeta(lZeta) = Data1(ip_Z(iZeta,nZeta)) - rKA(lZeta) = Data1(ip_Kappa(iZeta,nZeta)) - P(lZeta,1) = Data1(ip_PCoor(iZeta ,nZeta)) - P(lZeta,2) = Data1(ip_PCoor(iZeta+ nZeta,nZeta)) - P(lZeta,3) = Data1(ip_PCoor(iZeta+2*nZeta,nZeta)) - xA(lZeta) = Data1(ip_Alpha(iZeta,nZeta,1)) - xB(lZeta) = Data1(ip_Beta (iZeta,nZeta,2)) - ZInv(lZeta) = Data1(ip_ZInv (iZeta,nZeta)) - ip1 = ipOAP + mEta*mPAO*(iZeta-1) - ip2 = ipOAP + mEta*mPAO*(lZeta-1) - If (lDot) call dcopy_(mEta*mPAO,Scrtch(ip1),1, - & Scrtch(ip2),1) - End Do - End If - If (lZeta.eq.0) Go To 999 -* - If (iphX1.ne.1) Call DScal_(lZeta,-One,P(1,1),1) - If (iphY1.ne.1) Call DScal_(lZeta,-One,P(1,2),1) - If (iphZ1.ne.1) Call DScal_(lZeta,-One,P(1,3),1) -* -*-----Transpose eta,mPAO,zeta to mPAO,zeta,eta -* - If (lDot) Call DGetMO(Scrtch(ipOAP),mEta,mEta,mPAO*lZeta, - & Scrtch(ipPAO),mPAO*lZeta) -* -*-----Prescreen Eta -* - lEta=0 - If (PreScr) Then - Do iEta = 1, mEta - jEta = IndE(iEta) - abcd= Data2(ip_ab(jEta,nEta)) * abMax - If (Abs(abcd).ge.CutInt) Then - lEta=lEta+1 - IndEta(lEta) = IndE(iEta) - Eta(lEta) = Data2(ip_Z (iEta,nEta)) - rKC(lEta) = Data2(ip_Kappa(iEta,nEta)) - Q(lEta,1) = Data2(ip_PCoor(iEta ,nEta)) - Q(lEta,2) = Data2(ip_PCoor(iEta+ nEta,nEta)) - Q(lEta,3) = Data2(ip_PCoor(iEta+2*nEta,nEta)) - xG(lEta) = Data2(ip_Alpha(iEta,nEta,1)) - xD(lEta) = Data2(ip_Beta (iEta,nEta,2)) - EInv(lEta) = Data2(ip_ZInv (iEta,nEta)) - ip1 = ipPAO + mPAO*lZeta*(iEta-1) - ip2 = ipPAO + mPAO*lZeta*(lEta-1) - If (ldot) call dcopy_(lZeta*mPAO,Scrtch(ip1),1, - & Scrtch(ip2),1) - End If - End Do - Else - Do iEta = 1, mEta - lEta=lEta+1 - IndEta(lEta) = IndE(iEta) - Eta(lEta) = Data2(ip_Z (iEta,nEta)) - rKC(lEta) = Data2(ip_Kappa(iEta,nEta)) - Q(lEta,1) = Data2(ip_PCoor(iEta ,nEta)) - Q(lEta,2) = Data2(ip_PCoor(iEta+ nEta,nEta)) - Q(lEta,3) = Data2(ip_PCoor(iEta+2*nEta,nEta)) - xG(lEta) = Data2(ip_Alpha(iEta,nEta,1)) - xD(lEta) = Data2(ip_Beta (iEta,nEta,2)) - EInv(lEta) = Data2(ip_ZInv (iEta,nEta)) - ip1 = ipPAO + mPAO*lZeta*(iEta-1) - ip2 = ipPAO + mPAO*lZeta*(lEta-1) - if (ldot) call dcopy_(lZeta*mPAO,Scrtch(ip1),1, - & Scrtch(ip2),1) - End Do - End If - If (lEta.eq.0) Go To 999 -* - If (iphX2.ne.1) Call DScal_(lEta,-One,Q(1,1),1) - If (iphY2.ne.1) Call DScal_(lEta,-One,Q(1,2),1) - If (iphZ2.ne.1) Call DScal_(lEta,-One,Q(1,3),1) -* -*-----Transpose mPAO,zeta,eta to zeta,eta,mPAO -* - If (ldot) Call DGeTMO(Scrtch(ipPAO),mPAO,mPAO,lZeta*lEta, - & PAO,lZeta*lEta) -* - 999 Continue -* - ij = 0 - Do iEta = 1,lEta - Et = Eta(iEta) - rKCD = rkC(iEta) - Do iZeta = 1,lZeta - Zt = Zeta(iZeta) - rKAB = rkA(iZeta) - ij = ij + 1 - xpre(ij) = rKAB*rKCD*Sqrt(1.0d0/(Zt+Et)) - End Do - End Do - If (ldot) Then - jPAO = 0 - Do iPAO = 1, mPAO - Do iZE = 0, lZeta*lEta-1 - jPAO=jPAO+1 - PAO(jPAO)=xpre(iZE+1)*PAO(jPAO) - End Do - End Do - End If -#ifdef _DEBUGPRINT_ - If (iPrint.ge.39) Call RecPrt(' PAO',' ', - & PAO,lZeta*lEta,mPAO) -#endif - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real(ztmx) - Call Unused_real(zexpmax) - Call Unused_integer(nAlpha) - Call Unused_integer(nBeta) - Call Unused_real(etmx) - Call Unused_real(eexpmax) - Call Unused_integer(nGamma) - Call Unused_integer(nDelta) - End If - End -#endif diff -Nru openmolcas-22.02/src/mckinley/screen_mck.F90 openmolcas-22.10/src/mckinley/screen_mck.F90 --- openmolcas-22.02/src/mckinley/screen_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/screen_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,399 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1992, Roland Lindh * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine Screen_mck(PAO,Scrtch,mPAO,nZeta,nEta,mZeta,mEta,lZeta,lEta,Zeta,ZInv,P,xA,xB,rKA,Data1,IndZ,abmax,Eta,EInv,Q,xG,xD, & + rKC,Data2,IndE,cdmax,xpre,iphX1,iphY1,iphZ1,iphX2,iphY2,iphZ2,CutInt,PreScr,IndZet,IndEta,ldot) + +#define _Old_Code_ +#ifdef _Old_Code_ + +!*********************************************************************** +! * +! Object: to prescreen the integral derivatives. * +! * +! nZeta, nEta : unpartitioned length of primitives. * +! * +! mZeta, mEta : section length due to partioning. These are usually * +! equal to nZeta and nEta. * +! * +! lZeta, lEta : section length after prescreening. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! March '92 * +! * +! April '92 modified for gradient estimate * +! * +! Anders Bernhardsson 1995 * +!*********************************************************************** + +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +#include "ndarray.fh" +integer(kind=iwp), intent(in) :: mPAO, nZeta, nEta, mZeta, mEta, IndZ(mZeta), IndE(mEta), iphX1, iphY1, iphZ1, iphX2, iphY2, iphZ2 +real(kind=wp), intent(inout) :: PAO(mZeta*mEta*mPAO) +real(kind=wp), intent(out) :: Scrtch(mZeta*mEta*(1+mPAO*2)), Zeta(nZeta), ZInv(nZeta), P(nZeta,3), xA(nZeta), xB(nZeta), & + rKA(nZeta), Eta(nEta), EInv(nEta), Q(nEta,3), xG(nEta), xD(nEta), rKC(nEta), xpre(mZeta*mEta) +integer(kind=iwp), intent(out) :: lZeta, lEta, IndZet(nZeta), IndEta(nEta) +real(kind=wp), intent(in) :: Data1(nZeta*nDArray), abmax, Data2(nEta*nDArray), cdmax, CutInt +logical(kind=iwp), intent(in) :: PreScr, ldot +#ifdef _DEBUGPRINT_ +#include "print.fh" +#endif +integer(kind=iwp) :: iEta, ij, ip, ip1, ip2, iPAO, ipOAP, ipPAO, iZeta, jEta, jPAO, jZeta +#ifdef _DEBUGPRINT_ +integer(kind=iwp) :: iPrint, iRout +#endif +real(kind=wp) :: abcd +integer(kind=iwp), external :: ip_ab, ip_Alpha, ip_Beta, ip_Kappa, ip_PCoor, ip_Z, ip_ZInv + +#ifdef _DEBUGPRINT_ +iRout = 180 +iPrint = nPrint(iRout) + +if (iPrint >= 99) then + call RecPrt(' Data1',' ',Data1,nZeta,nDArray) + call RecPrt(' Data2',' ',Data2,nEta,nDArray) + call RecPrt('2nd order density matrix',' ',PAO,mZeta*mEta,mPAO) +end if +#endif + +ip = 1 +ipPAO = ip +ip = ip+mZeta*mEta*mPAO + +! Compress all indices except zeta + +ipOAP = ip +ip = ip+mZeta*mEta*mPAO +if (ldot) call DGetMO(PAO,mZeta,mZeta,mEta*mPAO,Scrtch(ipOAP),mEta*mPAO) + +! Prescreen Zeta + +lZeta = 0 +IndZet(:) = 0 +if (PreScr) then + do iZeta=1,mZeta + jZeta = IndZ(iZeta) + IndZet(jZeta) = -lZeta + abcd = Data1(ip_ab(iZeta,nZeta))*cdMax + if (abs(abcd) >= CutInt) then + lZeta = lZeta+1 + IndZet(jZeta) = lZeta + Zeta(lZeta) = Data1(ip_Z(iZeta,nZeta)) + rKA(lZeta) = Data1(ip_Kappa(iZeta,nZeta)) + P(lZeta,1) = Data1(ip_PCoor(iZeta,nZeta)) + P(lZeta,2) = Data1(ip_PCoor(iZeta+nZeta,nZeta)) + P(lZeta,3) = Data1(ip_PCoor(iZeta+2*nZeta,nZeta)) + xA(lZeta) = Data1(ip_Alpha(iZeta,nZeta,1)) + xB(lZeta) = Data1(ip_Beta(iZeta,nZeta,2)) + ZInv(lZeta) = Data1(ip_ZInv(iZeta,nZeta)) + ip1 = ipOAP+mEta*mPAO*(iZeta-1) + ip2 = ipPAO+mEta*mPAO*(lZeta-1) + if (ldot) Scrtch(ip2:ip2+mEta*mPAO-1) = Scrtch(ip1:ip1+mEta*mPAO-1) + end if + end do +else + do iZeta=1,mZeta + lZeta = lZeta+1 + jZeta = IndZ(iZeta) + IndZet(jZeta) = lZeta + Zeta(lZeta) = Data1(ip_Z(iZeta,nZeta)) + rKA(lZeta) = Data1(ip_Kappa(iZeta,nZeta)) + P(lZeta,1) = Data1(ip_PCoor(iZeta,nZeta)) + P(lZeta,2) = Data1(ip_PCoor(iZeta+nZeta,nZeta)) + P(lZeta,3) = Data1(ip_PCoor(iZeta+2*nZeta,nZeta)) + xA(lZeta) = Data1(ip_Alpha(iZeta,nZeta,1)) + xB(lZeta) = Data1(ip_Beta(iZeta,nZeta,2)) + ZInv(lZeta) = Data1(ip_ZInv(iZeta,nZeta)) + ip1 = ipOAP+mEta*mPAO*(iZeta-1) + ip2 = ipPAO+mEta*mPAO*(lZeta-1) + if (ldot) Scrtch(ip2:ip2+mEta*mPAO-1) = Scrtch(ip1:ip1+mEta*mPAO-1) + end do +end if +if (lZeta /= 0) then + + if (iphX1 /= 1) P(1:lZeta,1) = -P(1:lZeta,1) + if (iphY1 /= 1) P(1:lZeta,2) = -P(1:lZeta,2) + if (iphZ1 /= 1) P(1:lZeta,3) = -P(1:lZeta,3) + + ! Transpose eta,mPAO,zeta to mPAO,zeta,eta + + if (ldot) call DGetMO(Scrtch(ipPAO),mEta,mEta,mPAO*lZeta,Scrtch(ipOAP),mPAO*lZeta) + + ! Prescreen Eta + + lEta = 0 + IndEta(:) = 0 + if (PreScr) then + do iEta=1,mEta + jEta = IndE(iEta) + IndEta(jEta) = -lEta ! To be removed + abcd = Data2(ip_ab(iEta,nEta))*abMax + if (abs(abcd) >= CutInt) then + lEta = lEta+1 + IndEta(jEta) = lEta + Eta(lEta) = Data2(ip_Z(iEta,nEta)) + rKC(lEta) = Data2(ip_Kappa(iEta,nEta)) + Q(lEta,1) = Data2(ip_PCoor(iEta,nEta)) + Q(lEta,2) = Data2(ip_PCoor(iEta+nEta,nEta)) + Q(lEta,3) = Data2(ip_PCoor(iEta+2*nEta,nEta)) + xG(lEta) = Data2(ip_Alpha(iEta,nEta,1)) + xD(lEta) = Data2(ip_Beta(iEta,nEta,2)) + EInv(lEta) = Data2(ip_ZInv(iEta,nEta)) + ip1 = ipOAP+mPAO*lZeta*(iEta-1) + ip2 = ipPAO+mPAO*lZeta*(lEta-1) + if (ldot) Scrtch(ip2:ip2+lZeta*mPAO-1) = Scrtch(ip1:ip1+lZeta*mPAO-1) + end if + end do + else + do iEta=1,mEta + lEta = lEta+1 + jEta = IndE(iEta) + IndEta(jEta) = lEta + Eta(lEta) = Data2(ip_Z(iEta,nEta)) + rKC(lEta) = Data2(ip_Kappa(iEta,nEta)) + Q(lEta,1) = Data2(ip_PCoor(iEta,nEta)) + Q(lEta,2) = Data2(ip_PCoor(iEta+nEta,nEta)) + Q(lEta,3) = Data2(ip_PCoor(iEta+2*nEta,nEta)) + xG(lEta) = Data2(ip_Alpha(iEta,nEta,1)) + xD(lEta) = Data2(ip_Beta(iEta,nEta,2)) + EInv(lEta) = Data2(ip_ZInv(iEta,nEta)) + ip1 = ipOAP+mPAO*lZeta*(iEta-1) + ip2 = ipPAO+mPAO*lZeta*(lEta-1) + if (ldot) Scrtch(ip2:ip2+lZeta*mPAO-1) = Scrtch(ip1:ip1+lZeta*mPAO-1) + end do + end if + if (lEta /= 0) then + + if (iphX2 /= 1) Q(1:lEta,1) = -Q(1:lEta,1) + if (iphY2 /= 1) Q(1:lEta,2) = -Q(1:lEta,2) + if (iphZ2 /= 1) Q(1:lEta,3) = -Q(1:lEta,3) + + ! Transpose mPAO,zeta,eta to zeta,eta,mPAO + + if (ldot) call DGeTMO(Scrtch(ipPAO),mPAO,mPAO,lZeta*lEta,PAO,lZeta*lEta) + + end if +end if + +ij = 0 +do iEta=1,lEta + xpre(ij+1:ij+lZeta) = rKA(1:lZeta)*rKC(iEta)*sqrt(One/(Zeta(1:lZeta)+Eta(iEta))) + ij = ij+lZeta +end do +if (ldot) then + jPAO = 0 + do iPAO=1,mPAO + PAO(jPAO+1:jPAO+lZeta*lEta) = xpre(1:lZeta*lEta)*PAO(jPAO+1:jPAO+lZeta*lEta) + jPAO = jPAO+lZeta*lEta + end do +end if +#ifdef _DEBUGPRINT_ +if (iPrint >= 39) call RecPrt(' PAO',' ',PAO,lZeta*lEta,mPAO) +#endif + +return + +#else + +!*********************************************************************** +! * +! Object: to prescreen the integral derivatives. * +! * +! nZeta, nEta : unpartitioned length of primitives. * +! * +! mZeta, mEta : section length due to partioning. These are usually * +! equal to nZeta and nEta. * +! * +! lZeta, lEta : section length after prescreening. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! March '92 * +! * +! April '92 modified for gradient estimate * +! * +! Anders Bernhardsson 1995 * +!*********************************************************************** + +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +#include "ndarray.fh" +integer(kind=iwp), intent(in) :: mPAO, nZeta, nEta, mZeta, mEta, IndZ(mZeta), IndE(mEta), iphX1, iphY1, iphZ1, iphX2, iphY2, iphZ2 +real(kind=wp), intent(inout) :: PAO(mZeta*mEta*mPAO) +real(kind=wp), intent(out) :: Scrtch(mZeta*mEta*(1+mPAO*2)), Zeta(nZeta), ZInv(nZeta), P(nZeta,3), xA(nZeta), xB(nZeta), & + rKA(nZeta), Eta(nEta), EInv(nEta), Q(nEta,3), xG(nEta), xD(nEta), rKC(nEta), xpre(mZeta*mEta) +integer(kind=iwp), intent(out) :: lZeta, lEta, IndZet(nZeta), IndEta(nEta) +real(kind=wp), intent(in) :: Data1(nZeta*nDArray), abmax, Data2(nEta*nDArray), cdmax, CutInt +logical(kind=iwp), intent(in) :: PreScr, ldot +#ifdef _DEBUGPRINT_ +#include "print.fh" +#endif +integer(kind=iwp) :: iEta, ij, ip, ip1, ip2, iPAO, ipOAP, ipPAO, iZeta, jEta, jPAO, jZeta +#ifdef _DEBUGPRINT_ +integer(kind=iwp) :: iPrint, iRout +#endif +real(kind=wp) :: abcd +integer(kind=iwp), external :: ip_ab, ip_Alpha, ip_Beta, ip_Kappa, ip_PCoor, ip_Z, ip_ZInv + +#ifdef _DEBUGPRINT_ +iRout = 180 +iPrint = nPrint(iRout) + +if (iPrint >= 99) then + call RecPrt(' Data1',' ',Data1,nZeta,nDArray) + call RecPrt(' Data2',' ',Data2,nEta,nDArray) + call RecPrt('2nd order density matrix',' ',PAO,mZeta*mEta,mPAO) +end if +#endif + +ip = 1 +ipPAO = ip +ip = ip+mZeta*mEta*mPAO + +! Compress all indices except zeta + +ipOAP = ip +ip = ip+mZeta*mEta*mPAO +if (ldot) call DGetMO(PAO,mZeta,mZeta,mEta*mPAO,Scrtch(ipOAP),mEta*mPAO) + +! Prescreen Zeta + +lZeta = 0 +if (PreScr) then + do iZeta=1,mZeta + jZeta = IndZ(iZeta) + abcd = Data1(ip_ab(jZeta,nZeta))*cdMax + if (abs(abcd) >= CutInt) then + lZeta = lZeta+1 + IndZet(lZeta) = IndZ(iZeta) + Zeta(lZeta) = Data1(ip_Z(iZeta,nZeta)) + rKA(lZeta) = Data1(ip_Kappa(iZeta,nZeta)) + P(lZeta,1) = Data1(ip_PCoor(iZeta,nZeta)) + P(lZeta,2) = Data1(ip_PCoor(iZeta+nZeta,nZeta)) + P(lZeta,3) = Data1(ip_PCoor(iZeta+2*nZeta,nZeta)) + xA(lZeta) = Data1(ip_Alpha(iZeta,nZeta,1)) + xB(lZeta) = Data1(ip_Beta(iZeta,nZeta,2)) + ZInv(lZeta) = Data1(ip_ZInv(iZeta,nZeta)) + ip1 = ipOAP+mEta*mPAO*(iZeta-1) + ip2 = ipOAP+mEta*mPAO*(lZeta-1) + if (lDot) Scrtch(ip2:ip2+mEta*mPAO-1) = Scrtch(ip1:ip1+mEta*mPAO-1) + end if + end do +else + do iZeta=1,mZeta + lZeta = lZeta+1 + IndZet(lZeta) = IndZ(iZeta) + Zeta(lZeta) = Data1(ip_Z(iZeta,nZeta)) + rKA(lZeta) = Data1(ip_Kappa(iZeta,nZeta)) + P(lZeta,1) = Data1(ip_PCoor(iZeta,nZeta)) + P(lZeta,2) = Data1(ip_PCoor(iZeta+nZeta,nZeta)) + P(lZeta,3) = Data1(ip_PCoor(iZeta+2*nZeta,nZeta)) + xA(lZeta) = Data1(ip_Alpha(iZeta,nZeta,1)) + xB(lZeta) = Data1(ip_Beta(iZeta,nZeta,2)) + ZInv(lZeta) = Data1(ip_ZInv(iZeta,nZeta)) + ip1 = ipOAP+mEta*mPAO*(iZeta-1) + ip2 = ipOAP+mEta*mPAO*(lZeta-1) + if (lDot) Scrtch(ip2:ip2+mEta*mPAO-1) = Scrtch(ip1:ip1+mEta*mPAO-1) + end do +end if +if (lZeta /= 0) then + + if (iphX1 /= 1) P(1:lZeta,1) = -P(1:lZeta,1) + if (iphY1 /= 1) P(1:lZeta,2) = -P(1:lZeta,2) + if (iphZ1 /= 1) P(1:lZeta,3) = -P(1:lZeta,3) + + ! Transpose eta,mPAO,zeta to mPAO,zeta,eta + + if (lDot) call DGetMO(Scrtch(ipOAP),mEta,mEta,mPAO*lZeta,Scrtch(ipPAO),mPAO*lZeta) + + ! Prescreen Eta + + lEta = 0 + if (PreScr) then + do iEta=1,mEta + jEta = IndE(iEta) + abcd = Data2(ip_ab(jEta,nEta))*abMax + if (abs(abcd) >= CutInt) then + lEta = lEta+1 + IndEta(lEta) = IndE(iEta) + Eta(lEta) = Data2(ip_Z(iEta,nEta)) + rKC(lEta) = Data2(ip_Kappa(iEta,nEta)) + Q(lEta,1) = Data2(ip_PCoor(iEta,nEta)) + Q(lEta,2) = Data2(ip_PCoor(iEta+nEta,nEta)) + Q(lEta,3) = Data2(ip_PCoor(iEta+2*nEta,nEta)) + xG(lEta) = Data2(ip_Alpha(iEta,nEta,1)) + xD(lEta) = Data2(ip_Beta(iEta,nEta,2)) + EInv(lEta) = Data2(ip_ZInv(iEta,nEta)) + ip1 = ipPAO+mPAO*lZeta*(iEta-1) + ip2 = ipPAO+mPAO*lZeta*(lEta-1) + if (ldot) Scrtch(ip2:ip2+lZeta*mPAO-1) = Scrtch(ip1:ip1+lZeta*mPAO-1) + end if + end do + else + do iEta=1,mEta + lEta = lEta+1 + IndEta(lEta) = IndE(iEta) + Eta(lEta) = Data2(ip_Z(iEta,nEta)) + rKC(lEta) = Data2(ip_Kappa(iEta,nEta)) + Q(lEta,1) = Data2(ip_PCoor(iEta,nEta)) + Q(lEta,2) = Data2(ip_PCoor(iEta+nEta,nEta)) + Q(lEta,3) = Data2(ip_PCoor(iEta+2*nEta,nEta)) + xG(lEta) = Data2(ip_Alpha(iEta,nEta,1)) + xD(lEta) = Data2(ip_Beta(iEta,nEta,2)) + EInv(lEta) = Data2(ip_ZInv(iEta,nEta)) + ip1 = ipPAO+mPAO*lZeta*(iEta-1) + ip2 = ipPAO+mPAO*lZeta*(lEta-1) + if (ldot) Scrtch(ip2:ip2+lZeta*mPAO-1) = Scrtch(ip1:ip1+lZeta*mPAO-1) + end do + end if + if (lEta /= 0) then + + if (iphX2 /= 1) Q(1:lEta,1) = -Q(1:lEta,1) + if (iphY2 /= 1) Q(1:lEta,2) = -Q(1:lEta,2) + if (iphZ2 /= 1) Q(1:lEta,3) = -Q(1:lEta,3) + + ! Transpose mPAO,zeta,eta to zeta,eta,mPAO + + if (ldot) call DGeTMO(Scrtch(ipPAO),mPAO,mPAO,lZeta*lEta,PAO,lZeta*lEta) + + end if +end if + +ij = 0 +do iEta=1,lEta + xpre(ij+1:ij+lZeta) = rKA(1:lZeta)*rKC(iEta)*sqrt(One/(Zeta(1:lZeta)+Eta(iEta))) + ij = ij+lZeta +end do +if (ldot) then + jPAO = 0 + do iPAO=1,mPAO + PAO(jPAO+1:jPAO+lZeta*lEta) = xpre(1:lZeta*lEta)*PAO(jPAO+1:jPAO+lZeta*lEta) + jPAO = jPAO+lZeta*lEta + end do +end if +#ifdef _DEBUGPRINT_ +if (iPrint >= 39) call RecPrt(' PAO',' ',PAO,lZeta*lEta,mPAO) +#endif + +return + +#endif + +end subroutine Screen_mck diff -Nru openmolcas-22.02/src/mckinley/smadna.f openmolcas-22.10/src/mckinley/smadna.f --- openmolcas-22.02/src/mckinley/smadna.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/smadna.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,97 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SubRoutine SmAdNa(ArrIn,nb,ArrOut,nop, - & lOper,IndGrd, - & iuv,IfGrd,Index,iDCar,rf,IFG,tr) - use Symmetry_Info, only: nIrrep, iChTbl, iChBas - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -c#include "print.fh" - Real*8 ArrIn (nb,*), - & ArrOut(nb,*) - Integer lOper, - & IndGrd(3,4,0:nIrrep-1),iuv(3),Index(3,4),nOp(3) - Logical IfGrd(3,4),IFG(4),tr(4) -* -* Statement function for Cartesian index -* -* -c iRout = 200 -c iPrint = nPrint(iRout) -* -*--------Accumulate contributions -* - iComp=0 - Do 102 iIrrep=0,nIrrep-1 - If (iAnd(lOper,2**iIrrep).ne.0) Then - iComp=iComp+1 - Do 103 iCn=1,3 -* If (Index(idCar,iCn).ne.0) Then - If ( (Indgrd(idCar,iCn,iIrrep).ne.0) .and. - & ( (index(idcar,icn).gt.0).or.tr(icn))) - & Then -* Accumulate contribution to the gradient - i1=0 - i2=0 - If (iCn.eq.1) Then - ps = DBLE( iPrmt( nOp(1), iChBas(1+idCar) ) ) - Fact = rf*DBLE(iuv(1))/DBLE(nIrrep) - If (.not.tr(iCn)) Then - i1=Index(idCar,iCn) - Else - If (index(idcar,2).gt.0) i1=Index(idCar,2) - If (index(idCar,3).gt.0) i2=Index(idCar,3) - Fact=-Fact - End If - Else If (iCn.eq.2) Then - ps=DBLE(iChTbl(iIrrep,nOp(2))) - ps = ps*DBLE( iPrmt( nOp(2), iChBas(1+idCar) ) ) - Fact = rf*ps * - & DBLE(iuv(2))/DBLE(nIrrep) - If (.not.tr(iCn)) Then - i1=Index(idCar,iCn) - Else - If (index(idcar,1).gt.0) i1=Index(idCar,1) - If (index(idCar,3).gt.0) i2=Index(idCar,3) - Fact=-Fact - End If - Else - ps=DBLE(iChTbl(iIrrep,nOp(3))) - ps = ps*DBLE( iPrmt( nOp(3), iChBas(1+idCar) ) ) - Fact = rf*ps * - & DBLE(iuv(3))/DBLE(nIrrep) - If (.not.tr(iCn)) Then - i1=Index(idCar,iCn) - Else - If (index(idcar,1).gt.0) i1=Index(idCar,1) - If (index(idCar,2).gt.0) i2=Index(idCar,2) - Fact=-Fact - End If - End if - If (i1.ne.0) - & Call DaXpY_(nb,Fact, - & ArrIn(1,i1),1,ArrOut(1,iComp),1) - If (i2.ne.0) - & Call DaXpY_(nb,Fact, - & ArrIn(1,i2),1,ArrOut(1,iComp),1) - End If - 103 Continue - End If - 102 Continue -* -* Call GetMem(' Exit SymAdO','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_logical_array(IfGrd) - Call Unused_logical_array(IFG) - End If - End diff -Nru openmolcas-22.02/src/mckinley/smadna.F90 openmolcas-22.10/src/mckinley/smadna.F90 --- openmolcas-22.02/src/mckinley/smadna.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/smadna.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,83 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine SmAdNa(ArrIn,nb,ArrOut,nop,lOper,IndGrd,iuv,Indx,iDCar,rf,tr) + +use Symmetry_Info, only: iChBas, iChTbl, nIrrep +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nb, nOp(3), lOper, IndGrd(3,4,0:nIrrep-1), iuv(3), Indx(3,4), iDCar +real(kind=wp), intent(in) :: ArrIn(nb,*), rf +real(kind=wp), intent(inout) :: ArrOut(nb,*) +logical(kind=iwp), intent(in) :: tr(4) +integer(kind=iwp) :: i1, i2, iCn, iComp, iIrrep +real(kind=wp) :: Fact, ps +integer(kind=iwp), external :: iPrmt + +!iRout = 200 +!iPrint = nPrint(iRout) + +! Accumulate contributions + +iComp = 0 +do iIrrep=0,nIrrep-1 + if (btest(lOper,iIrrep)) then + iComp = iComp+1 + do iCn=1,3 + !if (Indx(idCar,iCn) /= 0) then + if ((Indgrd(idCar,iCn,iIrrep) /= 0) .and. ((Indx(idcar,icn) > 0) .or. tr(icn))) then + ! Accumulate contribution to the gradient + i1 = 0 + i2 = 0 + if (iCn == 1) then + ps = real(iPrmt(nOp(1),iChBas(1+idCar)),kind=wp) + Fact = rf*real(iuv(1),kind=wp)/real(nIrrep,kind=wp) + if (.not. tr(iCn)) then + i1 = Indx(idCar,iCn) + else + if (Indx(idcar,2) > 0) i1 = Indx(idCar,2) + if (Indx(idCar,3) > 0) i2 = Indx(idCar,3) + Fact = -Fact + end if + else if (iCn == 2) then + ps = real(iChTbl(iIrrep,nOp(2)),kind=wp) + ps = ps*real(iPrmt(nOp(2),iChBas(1+idCar)),kind=wp) + Fact = rf*ps*real(iuv(2),kind=wp)/real(nIrrep,kind=wp) + if (.not. tr(iCn)) then + i1 = Indx(idCar,iCn) + else + if (Indx(idcar,1) > 0) i1 = Indx(idCar,1) + if (Indx(idCar,3) > 0) i2 = Indx(idCar,3) + Fact = -Fact + end if + else + ps = real(iChTbl(iIrrep,nOp(3)),kind=wp) + ps = ps*real(iPrmt(nOp(3),iChBas(1+idCar)),kind=wp) + Fact = rf*ps*real(iuv(3),kind=wp)/real(nIrrep,kind=wp) + if (.not. tr(iCn)) then + i1 = Indx(idCar,iCn) + else + if (Indx(idcar,1) > 0) i1 = Indx(idCar,1) + if (Indx(idCar,2) > 0) i2 = Indx(idCar,2) + Fact = -Fact + end if + end if + if (i1 /= 0) ArrOut(:,iComp) = ArrOut(:,iComp)+Fact*ArrIn(:,i1) + if (i2 /= 0) ArrOut(:,iComp) = ArrOut(:,iComp)+Fact*ArrIn(:,i2) + end if + end do + end if +end do + +return + +end subroutine SmAdNa diff -Nru openmolcas-22.02/src/mckinley/sort_mck.f openmolcas-22.10/src/mckinley/sort_mck.f --- openmolcas-22.02/src/mckinley/sort_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/sort_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,114 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine Sort_mck(A,B,iBas,jBas,kBas,lBas,iCmp,jCmp,kCmp,lCmp, - & iBasO,jBasO,kBasO,lBasO, - & iCmpO,jCmpO,kCmpO,lCmpO, - & nVec,nop,iAng, - & indgrd,indgrd2,ishll,C) -************************************************************************ -* * -* This subroutine is a stupid solution on a easy problem, but it * -* should work and it doesnt take to much CPU time. * -* eaw * -* * -************************************************************************ - Use Basis_Info - use Real_Spherical, only: iSphCr - use Symmetry_Info, only: nIrrep, iOper, iChBas - Implicit Real*8(a-h,o-z) -#include "real.fh" -c#include "print.fh" -* - Integer nop(4),iAng(4),indgrd(3,4,0:nirrep-1), - & indgrd2(3,4,0:nirrep-1),ishll(4) - Real*8 A(iBas*jBas*kBas*lBas, - & iCmp,jCmp,kCmp,lCmp,nVec) - Real*8 B(kBasO*kcmpO,lBasO,lcmpO, - & iBasO,iCmpO,jBasO,jCmpO*nvec) - - Real*8 prmt(0:7) - Real*8 C(*) -* - Data Prmt/1.d0,-1.d0,-1.d0,1.d0,-1.d0,1.d0,1.d0,-1.d0/ -* -* Statement Function -* - xPrmt(i,j) = Prmt(iAnd(i,j)) - iOff(ixyz) = ixyz*(ixyz+1)*(ixyz+2)/6 -* - ii = iOff(iAng(1)) - jj = iOff(iAng(2)) - kk = iOff(iAng(3)) - ll = iOff(iAng(4)) -* - rp=1.0d0 - Do iVec=1,nVec - Do iC=1,iCmp - ichbs=ichbas(ii+ic) - If (Shells(iShll(1))%Transf) iChBs = iChBas(iSphCr(ii+ic)) - PrA= xPrmt(iOper(nOp(1)),iChBs) - Do jC=1,jCmp - jChBs = iChBas(jj+jc) - If (Shells(iShll(2))%Transf) jChBs = iChBas(iSphCr(jj+jc)) - pRb = xPrmt(iOper(nOp(2)),jChBs) - Do kC=1,kCmp - kChBs = iChBas(kk+kc) - If (Shells(iShll(3))%Transf) kChBs = iChBas(iSphCr(kk+kc)) - pTc = xPrmt(iOper(nOp(3)),kChBs) - Do lC=1,lCmp - lChBs = iChBas(ll+lC) - If (Shells(iShll(4))%Transf) lChBs = iChBas(iSphCr(ll+lc)) - pTSd= xPrmt(iOper(nOp(4)),lChBs) - qFctr=pTSd*pTc*pRb*pRa*rp -**EAW 970930 -* -* Some machines dont support more than 7 indexes, need to fool around -* to make it work -* -* Do iB=1,iBas -* Do jB=1,jBas -* Do kB=1,kBas -* Do lB=1,lBas -* B(kB,kC,lB,lC,iB,iC,jB,jC,iVec)= -* & qfctr*A(iB,jB,kB,lB,iC,jC,kC,lC,iVec) -* End Do -* End Do -* End Do -* End Do - ijkl=0 - Do lB=1,lBas - Do kB=1,kBas - Do jB=1,jBas - Do iB=1,iBas - ijkl=ijkl+1 - B(kB+(kC-1)*kbaso,lB,lC,iB,iC,jB,jC+(iVec-1)*jcmpO)= - & qfctr*A(ijkl,iC,jC,kC,lC,iVec) - End Do - End Do - End Do - End Do - -*EAW 970930 - End Do - End Do - End Do - End Do - End Do - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer_array(indgrd) - Call Unused_integer_array(indgrd2) - Call Unused_real_array(C) - End If - End diff -Nru openmolcas-22.02/src/mckinley/sort_mck.F90 openmolcas-22.10/src/mckinley/sort_mck.F90 --- openmolcas-22.02/src/mckinley/sort_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/sort_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,92 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine Sort_mck(A,B,iBas,jBas,kBas,lBas,iCmp,jCmp,kCmp,lCmp,iBasO,jBasO,kBasO,lBasO,iCmpO,jCmpO,kCmpO,lCmpO,nVec,nop,iAng,ishll) +!*********************************************************************** +! * +! This subroutine is a stupid solution on a easy problem, but it * +! should work and it doesnt take to much CPU time. * +! eaw * +! * +!*********************************************************************** + +use Index_Functions, only: nTri3_Elem +use Basis_Info, only: Shells +use Real_Spherical, only: iSphCr +use Symmetry_Info, only: iChBas, iOper, Prmt +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iBas, jBas, kBas, lBas, iCmp, jCmp, kCmp, lCmp, iBasO, jBasO, kBasO, lBasO, iCmpO, jCmpO, kCmpO, & + lCmpO, nVec, nop(4), iAng(4), ishll(4) +real(kind=wp), intent(in) :: A(iBas*jBas*kBas*lBas,iCmp,jCmp,kCmp,lCmp,nVec) +real(kind=wp), intent(out) :: B(kBasO*kCmpO,lBasO,lCmpO,iBasO,iCmpO,jBasO,jCmpO*nvec) +integer(kind=iwp) :: iC, ichbs, ii, ijkl, iVec, jB, jC, jChBs, jj, kB, kC, kChBs, kk, lB, lC, lChBs, ll +real(kind=wp) :: PrA, pRb, pTc, pTSd, qFctr, rp + +ii = nTri3_Elem(iAng(1)) +jj = nTri3_Elem(iAng(2)) +kk = nTri3_Elem(iAng(3)) +ll = nTri3_Elem(iAng(4)) + +rp = One +do iVec=1,nVec + do iC=1,iCmp + ichbs = ichbas(ii+ic) + if (Shells(iShll(1))%Transf) iChBs = iChBas(iSphCr(ii+ic)) + PrA = Prmt(iOper(nOp(1)),iChBs) + do jC=1,jCmp + jChBs = iChBas(jj+jc) + if (Shells(iShll(2))%Transf) jChBs = iChBas(iSphCr(jj+jc)) + pRb = Prmt(iOper(nOp(2)),jChBs) + do kC=1,kCmp + kChBs = iChBas(kk+kc) + if (Shells(iShll(3))%Transf) kChBs = iChBas(iSphCr(kk+kc)) + pTc = Prmt(iOper(nOp(3)),kChBs) + do lC=1,lCmp + lChBs = iChBas(ll+lC) + if (Shells(iShll(4))%Transf) lChBs = iChBas(iSphCr(ll+lc)) + pTSd = Prmt(iOper(nOp(4)),lChBs) + qFctr = pTSd*pTc*pRb*pRa*rp + !*EAW 970930 + + ! Some machines don't support more than 7 indices, need to fool around to make it work + + !do iB=1,iBas + ! do jB=1,jBas + ! do lB=1,lBas + ! B(1:kBas,kC,lB,lC,iB,iC,jB,jC,iVec) = qfctr*A(iB,jB,1:kBas,lB,iC,jC,kC,lC,iVec) + ! end do + ! end do + !end do + ijkl = 0 + do lB=1,lBas + do kB=1,kBas + do jB=1,jBas + B(kB+(kC-1)*kBasO,lB,lC,1:iBas,iC,jB,jC+(iVec-1)*jCmpO) = qfctr*A(ijkl+1:ijkl+iBas,iC,jC,kC,lC,iVec) + ijkl = ijkl+iBas + end do + end do + end do + + !EAW 970930 + end do + end do + end do + end do +end do + +return + +end subroutine Sort_mck diff -Nru openmolcas-22.02/src/mckinley/srogrd_mck.f openmolcas-22.10/src/mckinley/srogrd_mck.f --- openmolcas-22.02/src/mckinley/srogrd_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/srogrd_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,236 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1993, Roland Lindh * -************************************************************************ - SubRoutine SroGrd_mck( -#define _CALLING_ -#include "grd_mck_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of ECP integrals. * -* * -* Alpha : exponents of bra gaussians * -* nAlpha: number of primitives (exponents) of bra gaussians * -* Beta : as Alpha but for ket gaussians * -* nBeta : as nAlpha but for the ket gaussians * -* Zeta : sum of exponents (nAlpha x nBeta) * -* ZInv : inverse of Zeta * -* rKappa: gaussian prefactor for the products of bra and ket * -* gaussians. * -* P : center of new gaussian from the products of bra and ket * -* gaussians. * -* Final : array for computed integrals * -* nZeta : nAlpha x nBeta * -* nComp : number of components in the operator (e.g. dipolmoment * -* operator has three components) * -* la : total angular momentum of bra gaussian * -* lb : total angular momentum of ket gaussian * -* A : center of bra gaussian * -* B : center of ket gaussian * -* nRys : order of Rys- or Hermite-Gauss polynomial * -* Array : Auxiliary memory as requested by ECPMem * -* nArr : length of Array * -* Ccoor : coordinates of the operator, zero for symmetric oper. * -* NOrdOp: Order of the operator * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, Sweden, and Per Boussard, Dept. of Theoretical * -* Physics, University of Stockholm, Sweden, October '93. * -************************************************************************ - use Basis_Info - use Center_Info - use Real_Spherical - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "real.fh" -#include "disp.fh" - -#include "grd_mck_interface.fh" - -* Local variables - Real*8 C(3), TC(3) - Integer iDCRT(0:7), iuvwx(4), mOp(4),index(3,4), JndGrd(3,4,0:7) - Logical JfGrad(3,4), EQ, DiffCnt,tr(4),ifg(4),ifhess_dum(3,4,3,4) -* * -************************************************************************ -* * -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* * -************************************************************************ -* * - iuvwx(1) = iu - iuvwx(2) = iv - mOp(1) = nOp(1) - mOp(2) = nOp(2) -* - DiffCnt=(IfGrad(iDCar,1).or.IfGrad(iDCar,2)) - -#ifdef _DEBUGPRINT_ - Call RecPrt(' In SROGrd: A',' ',A,1,3) - Call RecPrt(' In SROGrd: RB',' ',RB,1,3) - Call RecPrt(' In SROGrd: P',' ',P,nZeta,3) - Call RecPrt(' In SROGrd: Alpha',' ',Alpha,nAlpha,1) - Call RecPrt(' In SROGrd: Beta',' ',Beta,nBeta,1) - Write (6,*) ' In SROGrd: la,lb=',' ',la,lb - Write (6,*) ' In SROGrd: Diffs=',' ', - & IfGrad(iDCar,1),IfGrad(iDCar,2) - Write (6,*) ' In SROGrd: Center=',' ',iDCNT -#endif - - kdc = 0 - Do 1960 kCnttp = 1, nCnttp - - If (.Not.dbsc(kCnttp)%ECP) Go To 1961 - If (dbsc(kCnttp)%nSRO.le.0) Go To 1961 - Do 1965 kCnt = 1,dbsc(kCnttp)%nCntr - - If ((.not.DiffCnt).and.((kdc+kCnt).ne.iDCnt)) Goto 1965 - - C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) -* - Call DCR(LmbdT,iStabM,nStabM, - & dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) - Fact = DBLE(nStabM) / DBLE(LmbdT) - iuvwx(3) = dc(kdc+kCnt)%nStab - iuvwx(4) = dc(kdc+kCnt)%nStab - - Call LCopy(12,[.false.],0,JFgrad,1) - Call LCopy(4,[.false.],0,tr,1) - Call LCopy(4,[.false.],0,ifg,1) - Call ICopy(12*nIrrep,[0],0,jndGrd,1) - - Do iCnt = 1, 2 - JfGrad(iDCar,iCnt) = IfGrad(iDCar,iCnt) - End Do - - Do ICnt=1,2 - If (ifgrad(idcar,iCnt)) Then - ifg(icnt)=.true. - Do iIrrep=0,nIrrep-1 - jndGrd(iDCar,iCnt,iIrrep)=IndGrd(iIrrep) - End Do - End IF - End Do - -* - If ((kdc+kCnt).eq.iDCnt) Then - Tr(3)=.true. - ifg(1)=.true. - ifg(2)=.true. - JfGrad(iDCar,1) = .true. - JfGrad(iDCar,2) = .true. - Do iIrrep=0,nIrrep-1 - jndGrd(iDCar,3,iIrrep) = - IndGrd(iIrrep) - End Do - End If - -* - Do 1967 lDCRT = 0, nDCRT-1 - - mOp(3) = nropr(iDCRT(lDCRT)) - mOp(4) = mOp(3) - - Call OA(iDCRT(lDCRT),C,TC) - - If (EQ(A,RB).and.EQ(A,TC)) Go To 1967 - - Do 1966 iAng = 0, dbsc(kCnttp)%nSRO-1 - iShll = dbsc(kCnttp)%iSRO + iAng - nExpi=Shells(iShll)%nExp -#ifdef _DEBUGPRINT_ - nBasisi=Shells(iShll)%nBasis - Write (6,*) 'nExpi=',nExpi - Write (6,*) 'nBasis(iShll)=',nBasisi - Write (6,*) ' iAng=',iAng - Call RecPrt('TC',' ',TC,1,3) -#endif - - If (nExpi.eq.0) Go To 1966 -* - ip = 1 - - ipFin= ip - ip=ip+nZeta*(la+1)*(la+2)/2*(lb+1)*(lb+2)/2*6 - - ipTmp = ip - ip = ip + MAX(nBeta,nAlpha)*nExpi - - ipFA1 = ip - ip = ip + nAlpha*nExpi*nElem(la)*nElem(iAng)*2 - ipFA2 = ip ! Not in use for 1st derivative - - ipFB1 = ip - ip = ip + nExpi*nBeta*nElem(iAng)*nElem(lb)*2 - - ipFB2 = ip ! Not in use for 1st derivatives - - call dcopy_(nArr,[Zero],0,Array,1) - - Call Acore(iang,la,ishll,nordop,TC,A,Array(ip), - & narr-ip+1,Alpha,nalpha,Array(ipFA1), - & array(ipFA2),jfgrad(1,1),ifhess_dum, -#ifdef _DEBUGPRINT_ - & 1,.TRUE.) -#else - & 1,.FALSE.) -#endif - call LToSph(Array(ipFA1),nalpha,ishll,la,iAng,2) - - - - call dcopy_(nBeta*nExpi*nElem(lb)*nElem(iAng)*2, - & [Zero],0,Array(ipFB1),1) - Call coreB(iang,lb,ishll,nordop,TC,RB,Array(ip), - & narr-ip+1,Beta,nbeta,Array(ipFB1), - & array(ipFB2),jfgrad(1,2),ifhess_dum,1, -#ifdef _DEBUGPRINT_ - & .TRUE.) -#else - & .FALSE.) -#endif - call RToSph(Array(ipFB1),nBeta,ishll,lb,iAng,2) - - -* - call CmbnACB1(Array(ipFA1),Array(ipFB1),Array(ipFin), - & Fact,nAlpha,nBeta,Shells(iShll)%Akl, - & nExpi,la,lb,iang,jfgrad,Array(ipTmp), - & .true.,index,mvec,idcar) - -* - nt=nAlpha*nBeta*nElem(lb)*nElem(la) - Call SmAdNa(Array(ipFin),nt,Final, - & mop,loper,JndGrd,iuvwx,JfGrad,index, - & idcar,1.0d0,iFG,tr) - - 1966 Continue - 1967 Continue - 1965 Continue - 1961 Continue - kdc = kdc + dbsc(kCnttp)%nCntr - 1960 Continue -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Zeta) - Call Unused_real_array(ZInv) - Call Unused_real_array(rKappa) - Call Unused_real_array(P) - Call Unused_integer(nHer) - Call Unused_real_array(Ccoor) - Call Unused_logical_array(Trans) - End If - End diff -Nru openmolcas-22.02/src/mckinley/srogrd_mck.F90 openmolcas-22.10/src/mckinley/srogrd_mck.F90 --- openmolcas-22.02/src/mckinley/srogrd_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/srogrd_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,183 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993, Roland Lindh * +! 1993, Per Boussard * +!*********************************************************************** + +subroutine SroGrd_mck( & +# define _CALLING_ +# include "grd_mck_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of ECP integrals. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, Sweden, and Per Boussard, Dept. of Theoretical * +! Physics, University of Stockholm, Sweden, October '93. * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Basis_Info, only: dbsc, nCnttp, Shells +use Center_Info, only: dc +use Symmetry_Info, only: nIrrep +use Constants, only: Zero, One +use Definitions, only: wp, iwp +#ifdef _DEBUGPRINT_ +use Definitions, only: u6 +#endif + +implicit none +#include "grd_mck_interface.fh" +integer(kind=iwp) :: iAng, iCnt, iDCRT(0:7), Indx(3,4), ip, ipFA1, ipFA2, ipFB1, ipFB2, ipFin, ipTmp, iShll, iuvwx(4), & + JndGrd(3,4,0:7), kCnt, kCnttp, kdc, lDCRT, LmbdT, mOp(4), mvec, n, nDCRT, nExpi, nt +real(kind=wp) :: C(3), Fact, TC(3) +logical(kind=iwp) :: DiffCnt, ifhess_dum(3,4,3,4), JfGrad(3,4), tr(4) +integer(kind=iwp), external :: NrOpr +logical(kind=iwp), external :: EQ + +#include "macros.fh" +unused_var(Zeta) +unused_var(ZInv) +unused_var(rKappa) +unused_var(P) +unused_var(nHer) +unused_var(Ccoor) +unused_var(Trans) +! * +!*********************************************************************** +! * +iuvwx(1) = iu +iuvwx(2) = iv +mOp(1) = nOp(1) +mOp(2) = nOp(2) + +DiffCnt = IfGrad(iDCar,1) .or. IfGrad(iDCar,2) + +#ifdef _DEBUGPRINT_ +call RecPrt(' In SROGrd_McK: A',' ',A,1,3) +call RecPrt(' In SROGrd_McK: RB',' ',RB,1,3) +!call RecPrt(' In SROGrd_McK: P',' ',P,nZeta,3) +call RecPrt(' In SROGrd_McK: Alpha',' ',Alpha,nAlpha,1) +call RecPrt(' In SROGrd_McK: Beta',' ',Beta,nBeta,1) +write(u6,*) ' In SROGrd_McK: la,lb=',' ',la,lb +write(u6,*) ' In SROGrd_McK: Diffs=',' ',IfGrad(iDCar,1),IfGrad(iDCar,2) +write(u6,*) ' In SROGrd_McK: Center=',' ',iDCNT +#endif + +kdc = 0 +do kCnttp=1,nCnttp + + if (kCnttp > 1) kdc = kdc+dbsc(kCnttp-1)%nCntr + if (.not. dbsc(kCnttp)%ECP) cycle + if (dbsc(kCnttp)%nSRO <= 0) cycle + do kCnt=1,dbsc(kCnttp)%nCntr + + if ((.not. DiffCnt) .and. (kdc+kCnt /= iDCnt)) cycle + + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + + call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) + Fact = real(nStabM,kind=wp)/real(LmbdT,kind=wp) + iuvwx(3) = dc(kdc+kCnt)%nStab + iuvwx(4) = dc(kdc+kCnt)%nStab + + JfGrad(:,:) = .false. + tr(:) = .false. + JndGrd(:,:,0:nIrrep-1) = 0 + + JfGrad(iDCar,1:2) = IfGrad(iDCar,1:2) + + do ICnt=1,2 + if (IfGrad(iDCar,iCnt)) JndGrd(iDCar,iCnt,0:nIrrep-1) = IndGrd(0:nIrrep-1) + end do + + if ((kdc+kCnt) == iDCnt) then + Tr(3) = .true. + JfGrad(iDCar,1:2) = .true. + JndGrd(iDCar,3,0:nIrrep-1) = -IndGrd(0:nIrrep-1) + end if + + do lDCRT=0,nDCRT-1 + + mOp(3) = nropr(iDCRT(lDCRT)) + mOp(4) = mOp(3) + + call OA(iDCRT(lDCRT),C,TC) + + if (EQ(A,RB) .and. EQ(A,TC)) cycle + + do iAng=0,dbsc(kCnttp)%nSRO-1 + iShll = dbsc(kCnttp)%iSRO+iAng + nExpi = Shells(iShll)%nExp +# ifdef _DEBUGPRINT_ + nBasisi = Shells(iShll)%nBasis + write(u6,*) 'nExpi=',nExpi + write(u6,*) 'nBasis(iShll)=',nBasisi + write(u6,*) ' iAng=',iAng + call RecPrt('TC',' ',TC,1,3) +# endif + + if (nExpi == 0) cycle + + ip = 1 + + ipFin = ip + ip = ip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb)*6 + + ipTmp = ip + ip = ip+max(nBeta,nAlpha)*nExpi + + ipFA1 = ip + ip = ip+nAlpha*nExpi*nTri_Elem1(la)*nTri_Elem1(iAng)*2 + ipFA2 = ip ! Not in use for 1st derivative + + ipFB1 = ip + ip = ip+nExpi*nBeta*nTri_Elem1(iAng)*nTri_Elem1(lb)*2 + + ipFB2 = ip ! Not in use for 1st derivatives + + Array(:) = Zero + +#ifdef _DEBUGPRINT_ + call Acore(iang,la,ishll,nordop,TC,A,Array(ip),narr-ip+1,Alpha,nalpha,Array(ipFA1),array(ipFA2),jfgrad(1,1),ifhess_dum,1, & + .true.) +#else + call Acore(iang,la,ishll,nordop,TC,A,Array(ip),narr-ip+1,Alpha,nalpha,Array(ipFA1),array(ipFA2),jfgrad(1,1),ifhess_dum,1, & + .false.) +#endif + call LToSph(Array(ipFA1),nalpha,ishll,la,iAng,2) + + n = nBeta*nExpi*nTri_Elem1(lb)*nTri_Elem1(iAng)*2 + Array(ipFB1:ipFB1+n-1) = Zero +#ifdef _DEBUGPRINT_ + call coreB(iang,lb,ishll,nordop,TC,RB,Array(ip),narr-ip+1,Beta,nbeta,Array(ipFB1),array(ipFB2),jfgrad(1,2),ifhess_dum,1, & + .true.) +#else + call coreB(iang,lb,ishll,nordop,TC,RB,Array(ip),narr-ip+1,Beta,nbeta,Array(ipFB1),array(ipFB2),jfgrad(1,2),ifhess_dum,1, & + .false.) +#endif + call RToSph(Array(ipFB1),nBeta,ishll,lb,iAng,2) + + call CmbnACB1(Array(ipFA1),Array(ipFB1),Array(ipFin),Fact,nAlpha,nBeta,Shells(iShll)%Akl,nExpi,la,lb,iang,jfgrad, & + Array(ipTmp),.true.,Indx,mvec,idcar) + + nt = nAlpha*nBeta*nTri_Elem1(lb)*nTri_Elem1(la) + call SmAdNa(Array(ipFin),nt,rFinal,mop,loper,JndGrd,iuvwx,Indx,idcar,One,tr) + + end do + end do + end do +end do + +return + +end subroutine SroGrd_mck diff -Nru openmolcas-22.02/src/mckinley/srohss.f openmolcas-22.10/src/mckinley/srohss.f --- openmolcas-22.02/src/mckinley/srohss.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/srohss.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,182 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1993, Roland Lindh * -************************************************************************ - SubRoutine SroHss( -#define _CALLING_ -#include "hss_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of ECP integrals. * -* * -* Alpha : exponents of bra gaussians * -* nAlpha: number of primitives (exponents) of bra gaussians * -* Beta : as Alpha but for ket gaussians * -* nBeta : as nAlpha but for the ket gaussians * -* Zeta : sum of exponents (nAlpha x nBeta) * -* ZInv : inverse of Zeta * -* rKappa: gaussian prefactor for the products of bra and ket * -* gaussians. * -* p : center of new gaussian from the products of bra and ket * -* gaussians. * -* final : array for computed integrals * -* nzeta : nalpha x nbeta * -* ncomp : number of components in the operator (e.g. dipolmoment * -* operator has three components) * -* la : total angular momentum of bra gaussian * -* lb : total angular momentum of ket gaussian * -* a : center of bra gaussian * -* b : center of ket gaussian * -* nrys : order of rys- or Hermite-Gauss polynomial * -* array : auxiliary memory as requested by ECPMem * -* narr : length of array * -* ccoor : coordinates of the operator, zero for symmetric oper. * -* nordop: order of the operator * -************************************************************************ - use Basis_Info - use Center_Info - use Real_Spherical - use Symmetry_Info, only: iOper - implicit real*8 (a-h,o-z) -#include "Molcas.fh" -#include "real.fh" -#include "disp.fh" -#include "disp2.fh" - -#include "hss_interface.fh" - -* Local variables - Real*8 C(3), TC(3), Coor(3,4), g2(78) - Integer iDCRT(0:7), iuvwx(4), kOp(4),mop(4), - & JndGrd(3,4,0:7),jndhss(4,3,4,3,0:7) - logical jfgrd(3,4), EQ, jfhss(4,3,4,3), ifg(4),tr(4) -* - nelem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - nRys=nHer -* - iuvwx(1) = dc(mdc)%nStab - iuvwx(2) = dc(ndc)%nStab - call icopy(2,nop,1,mop,1) - kop(1) = ioper(nop(1)) - kop(2) = ioper(nop(2)) - call dcopy_(3,A,1,coor(1,1),1) - call dcopy_(3,RB,1,coor(1,2),1) - -* - kdc = 0 - do 1960 kcnttp = 1, ncnttp - if (.not.dbsc(kcnttp)%ECP) Go To 1961 - if (dbsc(kcnttp)%nSRO.le.0) Go To 1961 - do 1965 kcnt = 1,dbsc(kCnttp)%nCntr - C(1:3)=dbsc(kCnttp)%Coor(1:3,kCnt) -* - call dcr(lmbdt,iStabM,nStabM, - & dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) - fact = dble(nstabm) / DBLE(LmbdT) -* - iuvwx(3) = dc(kdc+kCnt)%nStab - iuvwx(4) = dc(kdc+kCnt)%nStab - -* - do 1967 ldcrt = 0, ndcRT-1 - - - kop(3) = idcrt(ldcrT) - kop(4) = kop(3) - mop(3) = nropr(kop(3)) - mop(4) = mop(3) - - Call OA(iDCRT(lDCRT),C,TC) - call dcopy_(3,TC,1,Coor(1,3),1) - - if (eq(a,rb).and.eq(A,TC)) Go To 1967 - call nucind(coor,kdc+kCnt,ifgrd,ifhss,indgrd,indhss, - & jfgrd,jfhss,jndgrd,jndhss,tr,ifg) - do 1966 iang = 0, dbsc(kCnttp)%nSRO-1 - ishll = dbsc(kcnttp)%iSRO + iAng - nExpi=Shells(iShll)%nExp - if (nExpi.eq.0) Go To 1966 -* - ip = 1 - ipfin = ip - ip = ip + nzeta*nElem(la)*nElem(lb)*21 - ipfa1 = ip - ip = ip + nalpha*nExpi*nElem(la)*nElem(iAng)*4 - iptmp = ip - ip = ip + nalpha*nExpi - ipfa2 = ip - ip = ip + nalpha*nExpi*nElem(la)*nElem(iAng)*6 - ipfb1 = ip - ip = ip + nExpi*nBeta*nElem(iAng)*nElem(lb)*4 - ipfb2 = ip - ip = ip + nExpi*nBeta*nElem(iAng)*nElem(lb)*6 - - call dcopy_(narr,[Zero],0,Array,1) -* , , - Call Acore(iang,la,ishll,nordop,TC,A,Array(ip), - & narr-ip+1,Alpha,nalpha,Array(ipFA1), - & array(ipfa2),jfgrd(1,1),jfhss, - & 2,.false.) -* Transform core orbital to spherical harmonics - call LToSph(Array(ipFA1),nAlpha,ishll,la,iAng,4) - call LToSph(Array(ipFA2),nAlpha,ishll,la,iAng,6) - -* ,, - Call coreB(iang,lb,ishll,nordop,TC,RB,Array(ip), - & narr-ip+1,Beta,nbeta,Array(ipFB1), - & array(ipfb2),jfgrd(1,2),jfhss, - & 2,.false.) -* Transform core orbital to spherical harmonics - call RToSph(Array(ipFB1),nBeta,ishll,lb,iAng,4) - call RToSph(Array(ipFB2),nBeta,ishll,lb,iAng,6) - -* Construct complete derivatives (contracting core) - Call CmbnACB2(Array(ipFa1),Array(ipFa2),Array(ipFb1), - & Array(ipFb2),Array(ipFin),Fact, - & nalpha,nbeta, - & Shells(iShll)%Akl,nExpi, - & la,lb,iang,jfhss,Array(ipTmp),.true.) - - -* contract density - nt=nZeta*(la+1)*(la+2)/2*(lb+1)*(lb+2)/2 - call dcopy_(78,[Zero],0,g2,1) - Call dGeMV_('T',nT,21, - & One,Array(ipFin),nT, - & DAO,1, - & Zero,g2,1) - -* distribute in hessian - Call Distg2(g2,Hess,nHess,JndGrd, - & JfHss,JndHss,iuvwx,kOp,mop,Tr,IfG) - -* - 1966 Continue - 1967 Continue - 1965 Continue - 1961 Continue - kdc = kdc + dbsc(kCnttp)%nCntr - 1960 Continue - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Zeta) - Call Unused_real_array(ZInv) - Call Unused_real_array(rKappa) - Call Unused_real_array(P) - Call Unused_real_array(Final) - Call Unused_integer(nRys) - Call Unused_real_array(Ccoor) - Call Unused_integer_array(lOper) - End If - End diff -Nru openmolcas-22.02/src/mckinley/srohss.F90 openmolcas-22.10/src/mckinley/srohss.F90 --- openmolcas-22.02/src/mckinley/srohss.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/srohss.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,135 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993, Roland Lindh * +!*********************************************************************** + +subroutine SroHss( & +# define _CALLING_ +# include "hss_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of ECP integrals. * +! * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Basis_Info, only: dbsc, nCnttp, Shells +use Center_Info, only: dc +use Symmetry_Info, only: iOper +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +#include "hss_interface.fh" +integer(kind=iwp) :: iang, iDCRT(0:7), ip, ipfa1, ipfa2, ipfb1, ipfb2, ipfin, iptmp, ishll, iuvwx(4), JndGrd(3,4,0:7), & + jndhss(4,3,4,3,0:7), kcnt, kCnttp, kdc, kOp(4), ldcrt, lmbdt, mop(4), nDCRT, nExpi, nt +real(kind=wp) :: C(3), Coor(3,4), fact, g2(78), TC(3) +logical(kind=iwp) :: ifg(4), jfgrd(3,4), jfhss(4,3,4,3), tr(4) +integer(kind=iwp), external :: NrOpr +logical(kind=iwp), external :: EQ + +#include "macros.fh" +unused_var(Zeta) +unused_var(ZInv) +unused_var(rKappa) +unused_var(P) +unused_var(rFinal) +unused_var(nHer) +unused_var(Ccoor) +unused_var(lOper) + +iuvwx(1) = dc(mdc)%nStab +iuvwx(2) = dc(ndc)%nStab +mop(1:2) = nOp +kop(1) = ioper(nop(1)) +kop(2) = ioper(nop(2)) +coor(:,1) = A +coor(:,2) = RB + +kdc = 0 +do kCnttp=1,ncnttp + if (kCnttp > 1) kdc = kdc+dbsc(kCnttp-1)%nCntr + if (.not. dbsc(kcnttp)%ECP) cycle + if (dbsc(kcnttp)%nSRO <= 0) cycle + do kcnt=1,dbsc(kCnttp)%nCntr + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + + call dcr(lmbdt,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) + fact = real(nstabm,kind=wp)/real(LmbdT,kind=wp) + + iuvwx(3) = dc(kdc+kCnt)%nStab + iuvwx(4) = dc(kdc+kCnt)%nStab + + do ldcrt=0,ndcRT-1 + + kop(3) = idcrt(ldcrT) + kop(4) = kop(3) + mop(3) = nropr(kop(3)) + mop(4) = mop(3) + + call OA(iDCRT(lDCRT),C,TC) + Coor(:,3) = TC + + if (eq(a,rb) .and. eq(A,TC)) cycle + call nucind(coor,kdc+kCnt,ifgrd,ifhss,indgrd,indhss,jfgrd,jfhss,jndgrd,jndhss,tr,ifg) + do iang=0,dbsc(kCnttp)%nSRO-1 + ishll = dbsc(kcnttp)%iSRO+iAng + nExpi = Shells(iShll)%nExp + if (nExpi == 0) cycle + + ip = 1 + ipfin = ip + ip = ip+nzeta*nTri_Elem1(la)*nTri_Elem1(lb)*21 + ipfa1 = ip + ip = ip+nalpha*nExpi*nTri_Elem1(la)*nTri_Elem1(iAng)*4 + iptmp = ip + ip = ip+nalpha*nExpi + ipfa2 = ip + ip = ip+nalpha*nExpi*nTri_Elem1(la)*nTri_Elem1(iAng)*6 + ipfb1 = ip + ip = ip+nExpi*nBeta*nTri_Elem1(iAng)*nTri_Elem1(lb)*4 + ipfb2 = ip + ip = ip+nExpi*nBeta*nTri_Elem1(iAng)*nTri_Elem1(lb)*6 + + Array(:) = Zero + ! , , + call Acore(iang,la,ishll,nordop,TC,A,Array(ip),narr-ip+1,Alpha,nalpha,Array(ipFA1),array(ipfa2),jfgrd(1,1),jfhss,2,.false.) + ! Transform core orbital to spherical harmonics + call LToSph(Array(ipFA1),nAlpha,ishll,la,iAng,4) + call LToSph(Array(ipFA2),nAlpha,ishll,la,iAng,6) + + ! ,, + call coreB(iang,lb,ishll,nordop,TC,RB,Array(ip),narr-ip+1,Beta,nbeta,Array(ipFB1),array(ipfb2),jfgrd(1,2),jfhss,2,.false.) + ! Transform core orbital to spherical harmonics + call RToSph(Array(ipFB1),nBeta,ishll,lb,iAng,4) + call RToSph(Array(ipFB2),nBeta,ishll,lb,iAng,6) + + ! Construct complete derivatives (contracting core) + call CmbnACB2(Array(ipFa1),Array(ipFa2),Array(ipFb1),Array(ipFb2),Array(ipFin),Fact,nalpha,nbeta,Shells(iShll)%Akl,nExpi, & + la,lb,iang,jfhss,Array(ipTmp),.true.) + + ! contract density + nt = nZeta*nTri_Elem1(la)*nTri_Elem1(lb) + g2(:) = Zero + call dGeMV_('T',nT,21,One,Array(ipFin),nT,DAO,1,Zero,g2,1) + + ! distribute in hessian + call Distg2(g2,Hess,nHess,JndGrd,JfHss,JndHss,iuvwx,kOp,mop,Tr,IfG) + + end do + end do + end do +end do + +return + +end subroutine SroHss diff -Nru openmolcas-22.02/src/mckinley/sromm1.f openmolcas-22.10/src/mckinley/sromm1.f --- openmolcas-22.02/src/mckinley/sromm1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/sromm1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,71 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1993, Roland Lindh * -************************************************************************ - Subroutine SroMm1(nHer,MmSroG,la,lb,lr) -************************************************************************ -* * -* Object: to compute the number of real*8 the kernel routine will * -* need for the computation of a matrix element between two * -* cartesian Gaussian functions with the total angular momentum* -* of la and lb (la=0 s-function, la=1 p-function, etc.) * -* lr is the order of the operator (this is only used when the * -* integrals are computed with the Hermite-Gauss quadrature). * -* * -* Called from: OneEl * -* * -************************************************************************ -* - use Basis_Info, only: dbsc, nCnttp, Shells -* - nElem(i) = (i+1)*(i+2)/2 -* - nOrder = 0 - ld=1 - MmSroG = 0 - Do 1960 iCnttp = 1, nCnttp - If (.Not.dbsc(iCnttp)%ECP) Go To 1960 - Do 1966 iAng = 0, dbsc(iCnttp)%nSRO-1 - iShll = dbsc(iCnttp)%iSRO + iAng - nExpi=Shells(iShll)%nExp - If (nExpi.eq.0) Go To 1966 -* - ip = 0 - - nac = nElem(la)*nElem(iAng) - ncb = nElem(iAng)*nElem(lb) - - ip=ip+6*nelem(la)*nelem(lb) ! final - ip=ip+4*nac*nExpi ! FA1 - ip=ip+4*ncb*nExpi !FB1 - ip=ip+nExpi* nExpi !Tmp core - ip=ip+nExpi !Tmp in sro - - nHer = (la+1+iAng+1+ld)/2 - nOrder = Max(nHer,nOrder) - iacore=6+3*nHer*(la+1+ld)+3*nHer*(iAng+1)+ - & 3*nHer*(lr+1)+3*(la+1+ld)*(iAng+1)*(lr+1)+1 - - nHer = (lb+1+iAng+1+ld)/2 - nOrder = Max(nHer,nOrder) - icoreb=6+3*nHer*(lb+1+ld)+3*nHer*(iAng+1)+ - & 3*nHer*(lr+1)+3*(lb+1+ld)*(iAng+1)*(lr+1)+1 - - icores = MAX(icoreb,iacore)*nExpi - - MmSroG = Max(MmSroG,ip+icores) -* - 1966 Continue - 1960 Continue - nHer = nOrder -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/sromm1.F90 openmolcas-22.10/src/mckinley/sromm1.F90 --- openmolcas-22.02/src/mckinley/sromm1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/sromm1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,78 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993, Roland Lindh * +!*********************************************************************** + +subroutine SroMm1( & +# define _CALLING_ +# include "mem_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the number of real*8 the kernel routine will * +! need for the computation of a matrix element between two * +! cartesian Gaussian functions with the total angular momentum* +! of la and lb (la=0 s-function, la=1 p-function, etc.) * +! lr is the order of the operator (this is only used when the * +! integrals are computed with the Hermite-Gauss quadrature). * +! * +! Called from: OneEl * +! * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Basis_Info, only: dbsc, nCnttp, Shells +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: iacore, iAng, iCnttp, icoreb, icores, ip, iShll, ld, nac, ncb, nExpi, nOrder + +nOrder = 0 +ld = 1 +Mem = 0 +do iCnttp=1,nCnttp + if (.not. dbsc(iCnttp)%ECP) cycle + do iAng=0,dbsc(iCnttp)%nSRO-1 + iShll = dbsc(iCnttp)%iSRO+iAng + nExpi = Shells(iShll)%nExp + if (nExpi == 0) cycle + + ip = 0 + + nac = nTri_Elem1(la)*nTri_Elem1(iAng) + ncb = nTri_Elem1(iAng)*nTri_Elem1(lb) + + ip = ip+6*nTri_Elem1(la)*nTri_Elem1(lb) ! final + ip = ip+4*nac*nExpi ! FA1 + ip = ip+4*ncb*nExpi !FB1 + ip = ip+nExpi*nExpi !Tmp core + ip = ip+nExpi !Tmp in sro + + nHer = (la+1+iAng+1+ld)/2 + nOrder = max(nHer,nOrder) + iacore = 6+3*nHer*(la+1+ld)+3*nHer*(iAng+1)+3*nHer*(lr+1)+3*(la+1+ld)*(iAng+1)*(lr+1)+1 + + nHer = (lb+1+iAng+1+ld)/2 + nOrder = max(nHer,nOrder) + icoreb = 6+3*nHer*(lb+1+ld)+3*nHer*(iAng+1)+3*nHer*(lr+1)+3*(lb+1+ld)*(iAng+1)*(lr+1)+1 + + icores = max(icoreb,iacore)*nExpi + + Mem = max(Mem,ip+icores) + + end do +end do +nHer = nOrder + +return + +end subroutine SroMm1 diff -Nru openmolcas-22.02/src/mckinley/srommh.f openmolcas-22.10/src/mckinley/srommh.f --- openmolcas-22.02/src/mckinley/srommh.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/srommh.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,70 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1993, Roland Lindh * -************************************************************************ - Subroutine sroMmH(nHer,MmSROH,la,lb,lr) -************************************************************************ -* * -* Object: to compute the number of real*8 the kernel routine will * -* need for the computation of a matrix element between two * -* cartesian Gaussian functions with the total angular momentum* -* of la and lb (la=0 s-function, la=1 p-function, etc.) * -* lr is the order of the operator (this is only used when the * -* integrals are computed with the Hermite-Gauss quadrature). * -* * -* Called from: OneEl * -* * -************************************************************************ -* - use Basis_Info, only: dbsc, nCnttp, Shells -* - nElem(i) = (i+1)*(i+2)/2 -* - nOrder = 0 - nordop=lr - ld=2 - MmSROH = 0 - Do 1960 iCnttp = 1, nCnttp - If (.Not.dbsc(iCnttp)%ECP) Go To 1960 - Do 1966 iAng = 0, dbsc(iCnttp)%nSRO-1 - iShll = dbsc(iCnttp)%iSRO + iAng - nExpi=Shells(iShll)%nExp - If (nExpi.eq.0) Go To 1966 -* - ip = 0 - nac = nElem(la)*nElem(iAng) - ncb = nElem(iAng)*nElem(lb) - ip = ip + nElem(la)*nElem(lb)*21 ! Final - - ip = ip + nExpi*nExpi ! tmp - - ip=ip+10*nac*nExpi ! FA1 & FA2 - ip=ip+10*ncb*nExpi ! FB1 & FB2 - - nHer = (la+1+iAng+1+ld)/2 - nOrder = Max(nHer,nOrder) - iacore=6+3*nHer*(la+1+ld)+3*nHer*(iAng+1)+ - & 3*nHer*(nOrdOp+1)+3*(la+1+ld)*(iAng+1)*(nOrdOp+1)+1 - - nHer = (lb+1+iAng+1+ld)/2 - nOrder = Max(nHer,nOrder) - icoreb=6+3*nHer*(lb+1+ld)+3*nHer*(iAng+1)+ - & 3*nHer*(nOrdOp+1)+3*(lb+1+ld)*(iAng+1)*(nOrdOp+1)+1 - - icores = MAX(icoreb,iacore)*nExpi - MmSROH = Max(MmSROH,ip+icores) -* - 1966 Continue - 1960 Continue - nHer = nOrder -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/srommh.F90 openmolcas-22.10/src/mckinley/srommh.F90 --- openmolcas-22.02/src/mckinley/srommh.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/srommh.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,77 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993, Roland Lindh * +!*********************************************************************** + +subroutine sroMmH( & +# define _CALLING_ +# include "mem_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the number of real*8 the kernel routine will * +! need for the computation of a matrix element between two * +! cartesian Gaussian functions with the total angular momentum* +! of la and lb (la=0 s-function, la=1 p-function, etc.) * +! lr is the order of the operator (this is only used when the * +! integrals are computed with the Hermite-Gauss quadrature). * +! * +! Called from: OneEl * +! * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Basis_Info, only: dbsc, nCnttp, Shells +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: iacore, iAng, iCnttp, icoreb, icores, ip, iShll, ld, nac, ncb, nExpi, nOrder, nordop + +nOrder = 0 +nordop = lr +ld = 2 +Mem = 0 +do iCnttp=1,nCnttp + if (.not. dbsc(iCnttp)%ECP) cycle + do iAng=0,dbsc(iCnttp)%nSRO-1 + iShll = dbsc(iCnttp)%iSRO+iAng + nExpi = Shells(iShll)%nExp + if (nExpi == 0) cycle + + ip = 0 + nac = nTri_Elem1(la)*nTri_Elem1(iAng) + ncb = nTri_Elem1(iAng)*nTri_Elem1(lb) + ip = ip+nTri_Elem1(la)*nTri_Elem1(lb)*21 ! Final + + ip = ip+nExpi*nExpi ! tmp + + ip = ip+10*nac*nExpi ! FA1 & FA2 + ip = ip+10*ncb*nExpi ! FB1 & FB2 + + nHer = (la+1+iAng+1+ld)/2 + nOrder = max(nHer,nOrder) + iacore = 6+3*nHer*(la+1+ld)+3*nHer*(iAng+1)+3*nHer*(nOrdOp+1)+3*(la+1+ld)*(iAng+1)*(nOrdOp+1)+1 + + nHer = (lb+1+iAng+1+ld)/2 + nOrder = max(nHer,nOrder) + icoreb = 6+3*nHer*(lb+1+ld)+3*nHer*(iAng+1)+3*nHer*(nOrdOp+1)+3*(lb+1+ld)*(iAng+1)*(nOrdOp+1)+1 + + icores = max(icoreb,iacore)*nExpi + Mem = max(Mem,ip+icores) + + end do +end do +nHer = nOrder + +return + +end subroutine sroMmH diff -Nru openmolcas-22.02/src/mckinley/sttstc.f openmolcas-22.10/src/mckinley/sttstc.f --- openmolcas-22.02/src/mckinley/sttstc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/sttstc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,64 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SubRoutine Sttstc - Implicit Real*8(a-h,o-z) -#include "cputime.fh" - Character*50 NamFld(nTotal+1) - Character*60 Fmt - Data NamFld - & / '1) Calculation of one electron integrals :', - & '2) Calculation of two electron integrals :', - & ' a) Decontraction of two electron density :', - & ' b) Integral evalution & 2nd derivatives :', - & ' c) Screening :', - & ' d) Transfromation of integrals :', - & ' e) Direct Fock matrix generation :', - & ' f) Direct MO transformation :', - & '3) Control and input :', - & ' T O T A L :' / -*---- Write out timing informations - Fmt='(2x,A)' - Write(6,*) - Call CollapseOutput(1,'Statistics and timing') - Write(6,'(3X,A)') '---------------------' - Write(6,*) - Write(6,Fmt)'- - - - - - - - - - - - - - - - - - - - - - - - -' - & //' - - - - - - - - -' - Write(6,Fmt)' Part of the program ' - & //' CPU fraction' - Write(6,Fmt)'- - - - - - - - - - - - - - - - - - - - - - - - -' - & //' - - - - - - - - -' - If (CPUStat(nTotal).gt.0.01D0) Then - TotCpu=CPUStat(nTotal) - Else - TotCpu=0.01D0 - End If -* TotCpu=max(0.01,CPUStat(nTotal)) - CPUStat(nTwoel)=CPUStat(nIntegrals)+CPUStat(nScreen)+ - & CPUStat(nTrans)+CPUStat(nTwoDens)+ - & CPUStat(nFckAck)+CPUStat(nMOTrans) - Diverse=CPUStat(nTotal)-CPUStat(nTwoEl)-CPUStat(nOneel) - - Do iFld = 1, nTotal - 1 - Write(6,'(2x,A45,2f10.2)')NamFld(iFld),CPUStat(iFld), - & CPUStat(iFld)/TotCpu - End Do - Write(6,'(2x,A45,2f10.2)')NamFld(nTotal),diverse, - & diverse/TotCpu - - Write(6,*) - Write(6,'(2x,A45,2F10.2)')NamFld(nTotal+1),TotCpu - Write(6,Fmt)'- - - - - - - - - - - - - - - - - - - - - - - - -' - & //' - - - - - - - - -' - Call CollapseOutput(0,'Statistics and timing') - Write(6,*) - Return - End diff -Nru openmolcas-22.02/src/mckinley/sttstc.F90 openmolcas-22.10/src/mckinley/sttstc.F90 --- openmolcas-22.02/src/mckinley/sttstc.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/sttstc.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,63 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Sttstc() + +use McKinley_global, only: CPUStat, nFckAcc, nIntegrals, nMOTrans, nOneel, nScreen, nTotal, nTrans, nTwoDens, nTwoel +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp) :: iFld +real(kind=wp) :: Diverse, TotCpu +character(len=*), parameter :: NamFld(nTotal+1) = ['1) Calculation of one electron integrals :', & + '2) Calculation of two electron integrals :', & + ' a) Decontraction of two electron density :', & + ' b) Integral evalution 2nd derivatives :', & + ' c) Screening :', & + ' d) Transformation of integrals :', & + ' e) Direct Fock matrix generation :', & + ' f) Direct MO transformation :', & + '3) Control and input :', & + ' T O T A L :'] + +! Write out timing informations +write(u6,*) +call CollapseOutput(1,'Statistics and timing') +write(u6,'(3X,A)') '---------------------' +write(u6,*) +write(u6,100) '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -' +write(u6,100) ' Part of the program CPU fraction' +write(u6,100) '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -' +if (CPUStat(nTotal) > 0.01_wp) then + TotCpu = CPUStat(nTotal) +else + TotCpu = 0.01_wp +end if +!TotCpu = max(0.01_wp,CPUStat(nTotal)) +CPUStat(nTwoel) = CPUStat(nIntegrals)+CPUStat(nScreen)+CPUStat(nTrans)+CPUStat(nTwoDens)+CPUStat(nFckAcc)+CPUStat(nMOTrans) +Diverse = CPUStat(nTotal)-CPUStat(nTwoEl)-CPUStat(nOneel) + +do iFld=1,nTotal-1 + write(u6,'(2x,A45,2f10.2)') NamFld(iFld),CPUStat(iFld),CPUStat(iFld)/TotCpu +end do +write(u6,'(2x,A45,2f10.2)') NamFld(nTotal),diverse,diverse/TotCpu + +write(u6,*) +write(u6,'(2x,A45,2F10.2)') NamFld(nTotal+1),TotCpu +write(u6,100) '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -' +call CollapseOutput(0,'Statistics and timing') +write(u6,*) + +return + +100 format(2x,a) + +end subroutine Sttstc diff -Nru openmolcas-22.02/src/mckinley/supermac.f openmolcas-22.10/src/mckinley/supermac.f --- openmolcas-22.02/src/mckinley/supermac.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/supermac.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,187 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine SuperMac() - Implicit Real*8 (a-h,o-z) -#include "stdalloc.fh" - Integer, Allocatable:: Scr1(:) - Character(LEN=8) Method - Character(LEN=16) StdIn - Logical Do_Cholesky, Do_ESPF, Numerical, Found -#include "warnings.h" -#include "temperatures.fh" -* - Call Get_cArray('Relax Method',Method,8) -* - Numerical = Method(1:6) .eq. 'RASSCF' .or. - & Method(1:6) .eq. 'GASSCF' .or. - & Method .eq. 'CASSCFSA' .or. - & Method .eq. 'DMRGSCFS' .or. - & Method .eq. 'CASPT2' .or. - & Method .eq. 'UHF-SCF' .or. - & Method .eq. 'MBPT2' .or. - & Method .eq. 'CCSDT' .or. - & Method .eq. 'KS-DFT' .or. - & Method .eq. 'UKS-DFT' -* - If (Method.eq.'CASSCF') Then - Call Get_iScalar('NumGradRoot',irlxroot) - Numerical=irlxroot.ne.1 - End If -* - Call DecideOnCholesky(Do_Cholesky) - If (Do_Cholesky) Numerical=.true. -* - Call Qpg_iScalar('nXF',Found) - If (Found) Then - Call Get_iScalar('nXF',nXF) - Numerical = Numerical .or. (nXF.gt.0) - End If - Call DecideOnESPF(Do_ESPF) - Numerical = Numerical .or. Do_ESPF -* -* Analytical PCM frequencies are currently not implemented -* - Call Qpg_dArray('PCM info',Found,nData) - Numerical = Numerical .or. (Found.and.nData.gt.0) -* - Call Qpg_iScalar('DNG',Found) - If (Found) Then - Call Get_iScalar('DNG',iDNG) - Numerical = Numerical .or. (iDNG.eq.1) - End If -* - If (.Not.Numerical) Return -* * -************************************************************************ -* * -* Create a backup runfile before running the numerical differentiation -* - Call fCopy('RUNFILE','RUNBACK',iErr) - If (iErr.ne.0) Call Abend() -* - Call mma_allocate(Scr1,7,Label='Scr1') - Scr1(1)=0 - Scr1(2)=0 - Scr1(3)=-99 - Scr1(4)=0 - Call Put_iArray('Slapaf Info 1',Scr1,7) - Call mma_deallocate(Scr1) - LuInput=11 - LuInput=IsFreeUnit(LuInput) - Call StdIn_Name(StdIn) - Call Molcas_open(LuInput,StdIn) -* * -************************************************************************ -* * - Write (LuInput,'(A)') '>ECHO OFF' - Write (LuInput,'(A)') '>export MCK_OLD_TRAP=$MOLCAS_TRAP' - Write (LuInput,'(A)') '>export MCK_OLD_MAXITER=$MOLCAS_MAXITER' - Write (LuInput,'(A)') '> export MOLCAS_TRAP=ON' - Write (LuInput,'(A)') '> export MOLCAS_MAXITER=500' -* -* If SA-CASSCF run the MCLR code so that the reference dipole moment -* is variational. -* - If (Method .eq. 'RASSCFSA'.or.Method .eq. 'CASSCFSA') - & Write (LuInput,'(A)') '&MCLR' -* - Write (LuInput,'(A)') '> DO WHILE <' - Write (LuInput,'(A)') '> IF (ITER NE 1) <' -* - Call Lu2Lu('SEWARINP',LuInput) - Write (LuInput,*) -* - If (Do_ESPF) THen - Call Lu2Lu('ESPFINP',LuInput) - End If -* - If (Method .eq. 'RASSCFSA'.or.Method .eq. 'CASSCFSA' .or. - & Method .eq. 'CASSCF') Then - Call Lu2Lu('RASSCINP',LuInput) - Else If (Method .eq. 'CASPT2') Then - Call Lu2Lu('RASSCINP',LuInput) - Write (LuInput,'(A)') - Call Lu2Lu('CASPTINP',LuInput) - Else If (Method .eq. 'MBPT2') Then - Call Lu2Lu('SCFINP',LuInput) - Else If (Method .eq. 'CCSDT') Then - Call Lu2Lu('SCFINP',LuInput) - Write (LuInput,'(A)') - Call Lu2Lu('CCSDTINP',LuInput) - Else If (Method .eq. 'KS-DFT' .or. Method.eq.'RHF-SCF' .or. - & Method .eq. 'UKS-DFT'.or. Method.eq.'UHF-SCF') Then - Call Lu2Lu('SCFINP',LuInput) - End If -* - Write (LuInput,'(A)') '> END IF <' -* -* To make sure MBPT2 is run with the Grdt option, -* run it always (outside the the IF) -* - If (Method .eq. 'MBPT2') Then - Write (LuInput,'(A)') - Call Lu2Lu('MBPT2INP',LuInput) - End If -* - Write (LuInput,'(A)') - Write (LuInput,'(A)') '&Slapaf &End' - Write (LuInput,'(A)') 'Numerical' - Write (LuInput,'(A)') 'Iterations' - Write (LuInput,'(A)') '0' - Write (LUInput,'(A)') 'THERmochemistry' -* - Call Get_iScalar('Rotational Symmetry Number',iSigma) - Write (LUInput,'(I3)') iSigma - Write (LUInput,'(A)') '1.0' - Do i=1,NDefTemp - Write (LUInput,'(F7.2)') DefTemp(i) - End Do - Write (LUInput,'(A)') 'End of PT' - Write (LuInput,'(A)') 'End of Input' - Write (LuInput,'(A)') '> END DO <' - Write (LuInput,'(A)') '> export MOLCAS_TRAP=$MCK_OLD_TRAP' - Write (LuInput,'(A)') '> export MOLCAS_MAXITER=$MCK_OLD_MAXITER' - Write (LuInput,'(A)') '>ECHO ON' - Close(LuInput) -* * -************************************************************************ -* * - Call Finish(_RC_INVOKED_OTHER_MODULE_) -* * -************************************************************************ -* * - Return - End - Subroutine Lu2Lu(Filename,LuInput) - Character FileName*(*), Line*180 - Logical Exist -#include "warnings.h" -* - Call f_inquire(Filename,Exist) - If (.Not.Exist) Then - Write (6,*) 'SuperMac: Missing ',Filename - Call Finish(_RC_INTERNAL_ERROR_) - End If -* - LuSpool2 = 77 - LuSpool2 = IsFreeUnit(LuSpool2) - Call Molcas_Open(LuSpool2, Filename) -* - 100 Continue - Read (LuSpool2,'(A)',End=900) Line - Write(LuInput,'(A)') Line - Go To 100 - 900 Continue -* - Close(LuSpool2) -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/supermac.F90 openmolcas-22.10/src/mckinley/supermac.F90 --- openmolcas-22.02/src/mckinley/supermac.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/supermac.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,157 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine SuperMac() + +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: iwp + +implicit none +#include "warnings.h" +#include "temperatures.fh" +integer(kind=iwp) :: i, iDNG, iErr, irlxroot, iSigma, LuInput, nData, nXF +character(len=16) :: StdIn +character(len=8) :: Method +logical(kind=iwp) :: Do_Cholesky, Do_ESPF, Numerical, Found +integer(kind=iwp), allocatable :: Scr1(:) +integer(kind=iwp), external :: IsFreeUnit + +call Get_cArray('Relax Method',Method,8) + +Numerical = (Method(1:6) == 'RASSCF') .or. (Method(1:6) == 'GASSCF') .or. (Method == 'CASSCFSA') .or. (Method == 'DMRGSCFS') .or. & + (Method == 'CASPT2') .or. (Method == 'UHF-SCF') .or. (Method == 'MBPT2') .or. (Method == 'CCSDT') .or. & + (Method == 'KS-DFT') .or. (Method == 'UKS-DFT') + +if (Method == 'CASSCF') then + call Get_iScalar('NumGradRoot',irlxroot) + Numerical = irlxroot /= 1 +end if + +call DecideOnCholesky(Do_Cholesky) +if (Do_Cholesky) Numerical = .true. + +call Qpg_iScalar('nXF',Found) +if (Found) then + call Get_iScalar('nXF',nXF) + Numerical = Numerical .or. (nXF > 0) +end if +call DecideOnESPF(Do_ESPF) +Numerical = Numerical .or. Do_ESPF + +! Analytical PCM frequencies are currently not implemented + +call Qpg_dArray('PCM info',Found,nData) +Numerical = Numerical .or. (Found .and. (nData > 0)) + +call Qpg_iScalar('DNG',Found) +if (Found) then + call Get_iScalar('DNG',iDNG) + Numerical = Numerical .or. (iDNG == 1) +end if + +if (.not. Numerical) return +! * +!*********************************************************************** +! * +! Create a backup runfile before running the numerical differentiation + +call fCopy('RUNFILE','RUNBACK',iErr) +if (iErr /= 0) call Abend() + +call mma_allocate(Scr1,7,Label='Scr1') +Scr1(1) = 0 +Scr1(2) = 0 +Scr1(3) = -99 +Scr1(4) = 0 +call Put_iArray('Slapaf Info 1',Scr1,7) +call mma_deallocate(Scr1) +LuInput = IsFreeUnit(11) +call StdIn_Name(StdIn) +call Molcas_open(LuInput,StdIn) +! * +!*********************************************************************** +! * +write(LuInput,'(A)') '>ECHO OFF' +write(LuInput,'(A)') '>export MCK_OLD_TRAP=$MOLCAS_TRAP' +write(LuInput,'(A)') '>export MCK_OLD_MAXITER=$MOLCAS_MAXITER' +write(LuInput,'(A)') '> export MOLCAS_TRAP=ON' +write(LuInput,'(A)') '> export MOLCAS_MAXITER=500' + +! If SA-CASSCF run the MCLR code so that the reference dipole moment is variational. + +if ((Method == 'RASSCFSA') .or. (Method == 'CASSCFSA')) write(LuInput,'(A)') '&MCLR' + +write(LuInput,'(A)') '> DO WHILE <' +write(LuInput,'(A)') '> IF (ITER NE 1) <' + +call Lu2Lu('SEWARINP',LuInput) +write(LuInput,*) + +if (Do_ESPF) then + call Lu2Lu('ESPFINP',LuInput) +end if + +if ((Method == 'RASSCFSA') .or. (Method == 'CASSCFSA') .or. (Method == 'CASSCF')) then + call Lu2Lu('RASSCINP',LuInput) +else if (Method == 'CASPT2') then + call Lu2Lu('RASSCINP',LuInput) + write(LuInput,'(A)') + call Lu2Lu('CASPTINP',LuInput) +else if (Method == 'MBPT2') then + call Lu2Lu('SCFINP',LuInput) +else if (Method == 'CCSDT') then + call Lu2Lu('SCFINP',LuInput) + write(LuInput,'(A)') + call Lu2Lu('CCSDTINP',LuInput) +else if ((Method == 'KS-DFT') .or. (Method == 'RHF-SCF') .or. (Method == 'UKS-DFT') .or. (Method == 'UHF-SCF')) then + call Lu2Lu('SCFINP',LuInput) +end if + +write(LuInput,'(A)') '> END IF <' + +! To make sure MBPT2 is run with the Grdt option, run it always (outside the IF) + +if (Method == 'MBPT2') then + write(LuInput,'(A)') + call Lu2Lu('MBPT2INP',LuInput) +end if + +write(LuInput,'(A)') +write(LuInput,'(A)') '&Slapaf &End' +write(LuInput,'(A)') 'Numerical' +write(LuInput,'(A)') 'Iterations' +write(LuInput,'(A)') '0' +write(LUInput,'(A)') 'THERmochemistry' + +call Get_iScalar('Rotational Symmetry Number',iSigma) +write(LUInput,'(I3)') iSigma +write(LUInput,'(A)') '1.0' +do i=1,NDefTemp + write(LUInput,'(F7.2)') DefTemp(i) +end do +write(LUInput,'(A)') 'End of PT' +write(LuInput,'(A)') 'End of Input' +write(LuInput,'(A)') '> END DO <' +write(LuInput,'(A)') '> export MOLCAS_TRAP=$MCK_OLD_TRAP' +write(LuInput,'(A)') '> export MOLCAS_MAXITER=$MCK_OLD_MAXITER' +write(LuInput,'(A)') '>ECHO ON' +close(LuInput) +! * +!*********************************************************************** +! * +call Finish(_RC_INVOKED_OTHER_MODULE_) +! * +!*********************************************************************** +! * + +return + +end subroutine SuperMac diff -Nru openmolcas-22.02/src/mckinley/symado_mck2.f openmolcas-22.10/src/mckinley/symado_mck2.f --- openmolcas-22.02/src/mckinley/symado_mck2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/symado_mck2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,54 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SubRoutine SymAdO_mck2(ArrIn,nB,ArrOut,nrOp,nop, - & IndGrd,ksym,iu,iv,ifgrd,idCar,trans) - use Symmetry_Info, only: nIrrep, iChTbl, iOper, iChBas - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - Real*8 ArrIn (nB,2), ArrOut(nB,nrOp) - Integer IndGrd(0:nIrrep-1),nop(2) - Logical IfGrd(3,2),trans(2) -* -*--------Accumulate contributions -* - n=0 - Do jIrrep=0,nIrrep-1 - iirrep=nropr(ieor(ioper(jirrep),ioper(ksym))) - If (Indgrd(jIrrep).ne.0) Then - n=n+1 - Do iCn=1,2 - If ((Trans(iCn).or.IfGrd(idCar,iCn)).and. - & (IndGrd(jIrrep).ne.0)) Then -* -* Accumulate contribution to the gradient -* - If (iCn.eq.1) Then - ps = DBLE( iPrmt( nOp(1),iChBas(1+idCar) ) ) - Fact = DBLE(iu)/DBLE(nIrrep) - If (trans(1)) Then - Fact=-Fact - End If - Else - ps=DBLE(iChTbl(iIrrep,nOp(2))) - ps = ps*DBLE( iPrmt( nOp(2),iChBas(1+idCar) ) ) - Fact = ps * DBLE(iv)/DBLE(nIrrep) - If (trans(2)) Then - Fact=-Fact - End If - End if - Call DaXpY_(nB,Fact,ArrIn(1,icn),1,ArrOut(1,n),1) - End If - End Do - End If - End Do -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/symado_mck2.F90 openmolcas-22.10/src/mckinley/symado_mck2.F90 --- openmolcas-22.02/src/mckinley/symado_mck2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/symado_mck2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,60 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine SymAdO_mck2(ArrIn,nB,ArrOut,nrOp,nop,IndGrd,ksym,iu,iv,ifgrd,idCar,trans) + +use Symmetry_Info, only: iChBas, iChTbl, iOper, nIrrep +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nB, nrOp, nop(2), IndGrd(0:nIrrep-1), ksym, iu, iv, idCar +real(kind=wp), intent(in) :: ArrIn(nB,2) +real(kind=wp), intent(inout) :: ArrOut(nB,nrOp) +logical(kind=iwp), intent(in) :: IfGrd(3,2), trans(2) +integer(kind=iwp) :: iCn, iirrep, jIrrep, n +real(kind=wp) :: Fact, ps +integer(kind=iwp), external :: iPrmt, NrOpr + +! Accumulate contributions + +n = 0 +do jIrrep=0,nIrrep-1 + iirrep = nropr(ieor(ioper(jirrep),ioper(ksym))) + if (Indgrd(jIrrep) /= 0) then + n = n+1 + do iCn=1,2 + if ((Trans(iCn) .or. IfGrd(idCar,iCn)) .and. (IndGrd(jIrrep) /= 0)) then + + ! Accumulate contribution to the gradient + + if (iCn == 1) then + ps = real(iPrmt(nOp(1),iChBas(1+idCar)),kind=wp) + Fact = real(iu,kind=wp)/real(nIrrep,kind=wp) + if (trans(1)) then + Fact = -Fact + end if + else + ps = real(iChTbl(iIrrep,nOp(2)),kind=wp) + ps = ps*real(iPrmt(nOp(2),iChBas(1+idCar)),kind=wp) + Fact = ps*real(iv,kind=wp)/real(nIrrep,kind=wp) + if (trans(2)) then + Fact = -Fact + end if + end if + ArrOut(:,n) = ArrOut(:,n)+Fact*ArrIn(:,iCn) + end if + end do + end if +end do + +return + +end subroutine SymAdO_mck2 diff -Nru openmolcas-22.02/src/mckinley/symado_mck.f openmolcas-22.10/src/mckinley/symado_mck.f --- openmolcas-22.02/src/mckinley/symado_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/symado_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SubRoutine SymAdO_mck(ArrIn,nB,ArrOut,nrOp,nop, - & lOper,IndGrd,iu,iv,ifgrd,idCar,trans) - use Symmetry_Info, only: nIrrep, iChTbl, iChBas - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - Real*8 ArrIn (nB,2), ArrOut(nB,nrOp) - Integer IndGrd(0:7),nop(2) - Logical IfGrd(3,2),trans(2) -* -*--------Accumulate contributions -* - n=0 - Do iIrrep=0,nIrrep-1 - If (Indgrd(iIrrep).ne.0) Then - n=n+1 - Do iCn=1,2 - If ((Trans(iCn).or.IfGrd(idCar,iCn)).and. - & (IndGrd(iIrrep).ne.0)) Then -* -* Accumulate contribution to the gradient -* - If (iCn.eq.1) Then - ps = DBLE( iPrmt( nOp(1),iChBas(1+idCar) ) ) - Fact = DBLE(iu)/DBLE(nIrrep) - If (trans(1)) Then - Fact=-Fact - End If - Else - ps=DBLE(iChTbl(iIrrep,nOp(2))) - ps = ps*DBLE( iPrmt( nOp(2),iChBas(1+idCar) ) ) - Fact = ps * DBLE(iv)/DBLE(nIrrep) - If (trans(2)) Then - Fact=-Fact - End If - End if - Call DaXpY_(nB,Fact,ArrIn(1,1),1,ArrOut(1,n),1) - End If - End Do - End If - End Do -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(lOper) - End diff -Nru openmolcas-22.02/src/mckinley/symado_mck.F90 openmolcas-22.10/src/mckinley/symado_mck.F90 --- openmolcas-22.02/src/mckinley/symado_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/symado_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,59 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine SymAdO_mck(ArrIn,nB,ArrOut,nrOp,nop,IndGrd,iu,iv,ifgrd,idCar,trans) + +use Symmetry_Info, only: iChBas, iChTbl, nIrrep +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nB, nrOp, nop(2), IndGrd(0:7), iu, iv, idCar +real(kind=wp), intent(in) :: ArrIn(nB,2) +real(kind=wp), intent(inout) :: ArrOut(nB,nrOp) +logical(kind=iwp), intent(in) :: IfGrd(3,2), trans(2) +integer(kind=iwp) :: iCn, iIrrep, n +real(kind=wp) :: Fact, ps +integer(kind=iwp), external :: iPrmt + +! Accumulate contributions + +n = 0 +do iIrrep=0,nIrrep-1 + if (Indgrd(iIrrep) /= 0) then + n = n+1 + do iCn=1,2 + if ((Trans(iCn) .or. IfGrd(idCar,iCn)) .and. (IndGrd(iIrrep) /= 0)) then + + ! Accumulate contribution to the gradient + + if (iCn == 1) then + ps = real(iPrmt(nOp(1),iChBas(1+idCar)),kind=wp) + Fact = real(iu,kind=wp)/real(nIrrep,kind=wp) + if (trans(1)) then + Fact = -Fact + end if + else + ps = real(iChTbl(iIrrep,nOp(2)),kind=wp) + ps = ps*real(iPrmt(nOp(2),iChBas(1+idCar)),kind=wp) + Fact = ps*real(iv,kind=wp)/real(nIrrep,kind=wp) + if (trans(2)) then + Fact = -Fact + end if + end if + ArrOut(:,n) = ArrOut(:,n)+Fact*ArrIn(:,1) + end if + end do + end if +end do + +return + +end subroutine SymAdO_mck diff -Nru openmolcas-22.02/src/mckinley/tcrtnc_h.f openmolcas-22.10/src/mckinley/tcrtnc_h.f --- openmolcas-22.02/src/mckinley/tcrtnc_h.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/tcrtnc_h.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,235 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990,1992,1994,1996, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Tcrtnc_h(Coef1,n1,m1,Coef2,n2,m2, - & Coef3,n3,m3,Coef4,n4,m4, - & ACInt,mabcd,Scrtch,nScr,ACOut, - & IndZet,lZeta,IndEta,lEta) -************************************************************************ -* * -* Object: to transform the integrals from primitives to contracted * -* basis functions. The subroutine will do both complete and * -* incomplete transformations. * -* * -* Observe that ACInt and ACOut may overlap!!!! * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* Modified to back transformation, January '92. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" -* -*---- Cache size -* -#include "lCache.fh" - Real*8 Coef1(n1,m1), Coef2(n2,m2), Coef3(n3,m3), Coef4(n4,m4), - & ACInt(m1*m2*m3*m4,mabcd), Scrtch(nScr), - & ACOut(n1*n2*n3*n4,mabcd) - Integer IndZet(lZeta), IndEta(lEta) -* - iRout = 18 - iPrint = nPrint(iRout) -* iPrint=99 -* - If (iPrint.ge.19) Call WrCheck('Tcrtnc:P(AB|CD)',ACInt, - & m1*m2*m3*m4*mabcd) - If (iPrint.ge.99) Then - Call RecPrt(' In Tcrtnc: P(ab|cd)',' ',ACInt,m1*m2,m3*m4*mabcd) - Call RecPrt(' Coef1',' ',Coef1,n1,m1) - Call RecPrt(' Coef2',' ',Coef2,n2,m2) - Call RecPrt(' Coef3',' ',Coef3,n3,m3) - Call RecPrt(' Coef4',' ',Coef4,n4,m4) - Write (6,*) n1, n2, n3, n4 - End If -* -*---- Reduce for contraction matrix - nCache = (3*lCache)/4 - n1*m1 - n2*m2 - lsize= m1*m2 + m2*n1 - nVec = m3*m4*mabcd - IncVec = Min(Max(1,nCache/lsize),nVec) - ipA3=1 - nA3=nVec*lZeta ! This is the same for the second set! - ipA2=ipA3 + nA3 -* - Call TncHlf_h(Coef1,m1,n1,Coef2,m2,n2,iDum,lZeta,nVec, - & IncVec,ACInt,Scrtch(ipA2),Scrtch(ipA3),IndZet) -* - nCache = (3*lCache)/4 - n3*m3 - n4*m4 - lsize = m3*m4 + m4*n3 - nVec = mabcd*lZeta - IncVec = Min(Max(1,nCache/lsize),nVec) -* - lZE=lZeta*lEta - If (mabcd.ne.1) Then - Call TncHlf_h(Coef3,m3,n3,Coef4,m4,n4,iDum,lEta,nVec, - & IncVec,Scrtch(ipA3),Scrtch(ipA2),ACOut,IndEta) - Call DGeTMO(ACOut,mabcd,mabcd,lZE,Scrtch,lZE) - call dcopy_(mabcd*lZE,Scrtch,1,ACOut,1) - Else - Call TncHlf_h(Coef3,m3,n3,Coef4,m4,n4,iDum,lEta,nVec, - & IncVec,Scrtch(ipA3),Scrtch(ipA2),ACOut,IndEta) - End If -* - If (iPrint.ge.59) - & Call RecPrt(' In Tcrtnc: P(ab|cd) ',' ',ACOut,mabcd,lZE) - If (iPrint.ge.19) Call WrCheck('Tcrtnc:P(ab|cd)',ACOut, - & lZE*mabcd) -* -* Call GetMem('Tcrtnc','CHECK','REAL',iDum,iDum) - Return - End - Subroutine Tnchlf_h(Coeff1,nCntr1,nPrm1,Coeff2,nCntr2, - & nPrm2,mZeta,lZeta,nVec,IncVec,A1,A2,A3,Indij) -************************************************************************ -* * -* Object: to do a half transformation. The loop over the two matrix- * -* matrix multiplications is segmented such that the end of the * -* intermediate matrix will not push the start of the same out * -* from the cache. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -* * -* Modified to decontraction May 1996, by R. Lindh * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" -#include "print.fh" - Real*8 Coeff1(nPrm1,nCntr1), Coeff2(nPrm2,nCntr2), - & A1(nCntr1,nCntr2,nVec), A2(nCntr2,IncVec*nPrm1), - & A3(nVec,lZeta) - Integer Indij(lZeta) - Logical Seg1, Seg2 -* -*-----Check if the basis set is segmented -* - Seg1=.False. - Do iPrm1 = nPrm1, 1, -1 - Do iCntr1 = nCntr1, 1, -1 - If (Coeff1(iPrm1,iCntr1).eq.Zero) Then - Seg1=.True. - Go To 10 - End If - End Do - End Do - 10 Continue -* - Seg2=.False. - Do iPrm2 = nPrm2, 1, -1 - Do iCntr2 = nCntr2, 1, -1 - If (Coeff2(iPrm2,iCntr2).eq.Zero) Then - Seg2=.True. - Go To 20 - End If - End Do - End Do - 20 Continue -* -*-----Set output matrix to zero -* - Call FZero(A3,nVec*lZeta) -* -*-----Loop sectioning -* - Do iiVec = 1, nVec, IncVec - mVec = Min(IncVec,nVec-iiVec+1) -*--------Set intermediate matrix to zero - call dcopy_(nCntr2*mVec*nPrm1,[Zero],0,A2,1) -* - If (Seg1) Then -* -*-----First quarter transformation -* -* - Do iPrm1 = 1, nPrm1 - Do iCntr1 = 1, nCntr1 -*-----------Check for zero due to segmented basis - If (Abs(Coeff1(iPrm1,iCntr1)).gt.Zero) Then - Do iCntr2 = 1, nCntr2 - Do iVec = iiVec, iiVec+mVec-1 - ijVec = mVec*(iPrm1-1) + (iVec-iiVec+1) - A2(iCntr2,ijVec) = A2(iCntr2,ijVec) + - & Coeff1(iPrm1,iCntr1)*A1(iCntr1,iCntr2,iVec) - End Do - End Do - End If - End Do - End Do -* - Else ! Seg1 -* -*-----First quarter transformation -* -* - Do iPrm1 = 1, nPrm1 - Do iCntr1 = 1, nCntr1 - Do iCntr2 = 1, nCntr2 - Do iVec = iiVec, iiVec+mVec-1 - ijVec = mVec*(iPrm1-1) + (iVec-iiVec+1) - A2(iCntr2,ijVec) = A2(iCntr2,ijVec) + - & Coeff1(iPrm1,iCntr1)*A1(iCntr1,iCntr2,iVec) - End Do - End Do - End Do - End Do -* - End If ! Seg1 -* - If (Seg2) Then -* -*-----Second quarter transformation -* - Do iCntr2 = 1, nCntr2 - Do iZeta = 1, lZeta - iPrm2 = (Indij(iZeta)-1)/nPrm1+1 - iPrm1 = Indij(iZeta)-(iPrm2-1)*nPrm1 -*-----------Check for zero due to segmented basis - If (Abs(Coeff2(iPrm2,iCntr2)).gt.Zero) Then - Do iVec = iiVec, iiVec+mVec-1 - ijVec = mVec*(iPrm1-1) + (iVec-iiVec+1) - A3(iVec,iZeta) = A3(iVec,iZeta) + - & Coeff2(iPrm2,iCntr2)*A2(iCntr2,ijVec) - End Do - End If - End Do - End Do -* - Else -* -*-----Second quarter transformation -* - Do iCntr2 = 1, nCntr2 - Do iZeta = 1, lZeta - iPrm2 = (Indij(iZeta)-1)/nPrm1+1 - iPrm1 = Indij(iZeta)-(iPrm2-1)*nPrm1 - Do iVec = iiVec, iiVec+mVec-1 - ijVec = mVec*(iPrm1-1) + (iVec-iiVec+1) - A3(iVec,iZeta) = A3(iVec,iZeta) + - & Coeff2(iPrm2,iCntr2)*A2(iCntr2,ijVec) - End Do - End Do - End Do -* - End If -* -*-----End of loop sectioning -* - End Do -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(mZeta) - End diff -Nru openmolcas-22.02/src/mckinley/tcrtnc_h.F90 openmolcas-22.10/src/mckinley/tcrtnc_h.F90 --- openmolcas-22.02/src/mckinley/tcrtnc_h.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/tcrtnc_h.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,89 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990,1992,1994, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Tcrtnc_h(Coef1,n1,m1,Coef2,n2,m2,Coef3,n3,m3,Coef4,n4,m4,ACInt,mabcd,Scrtch,nScr,ACOut,IndZet,lZeta,IndEta,lEta) +!*********************************************************************** +! * +! Object: to transform the integrals from primitives to contracted * +! basis functions. The subroutine will do both complete and * +! incomplete transformations. * +! * +! Observe that ACInt and ACOut may overlap!!!! * +! (which is against Fortran standard, so this should be fixed) * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! Modified to back transformation, January '92. * +!*********************************************************************** + +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: n1, m1, n2, m2, n3, m3, n4, m4, mabcd, nScr, lZeta, IndZet(lZeta), lEta, IndEta(lEta) +real(kind=wp), intent(in) :: Coef1(n1,m1), Coef2(n2,m2), Coef3(n3,m3), Coef4(n4,m4), ACInt(m1*m2*m3*m4,mabcd) +real(kind=wp), intent(out) :: Scrtch(nScr) +! This should be intent(out), but the aliasing/overlap (see above) prevents it +real(kind=wp), intent(_OUT_) :: ACOut(n1*n2*n3*n4,mabcd) +#include "print.fh" +#include "lCache.fh" +integer(kind=iwp) :: IncVec, ipA2, ipA3, iPrint, iRout, lsize, lZE, nA3, nCache, nVec + +iRout = 18 +iPrint = nPrint(iRout) +!iPrint = 99 + +if (iPrint >= 19) call WrCheck('Tcrtnc:P(AB|CD)',ACInt,m1*m2*m3*m4*mabcd) +if (iPrint >= 99) then + call RecPrt(' In Tcrtnc: P(ab|cd)',' ',ACInt,m1*m2,m3*m4*mabcd) + call RecPrt(' Coef1',' ',Coef1,n1,m1) + call RecPrt(' Coef2',' ',Coef2,n2,m2) + call RecPrt(' Coef3',' ',Coef3,n3,m3) + call RecPrt(' Coef4',' ',Coef4,n4,m4) + write(u6,*) n1,n2,n3,n4 +end if + +! Reduce for contraction matrix +nCache = (3*lCache)/4-n1*m1-n2*m2 +lsize = m1*m2+m2*n1 +nVec = m3*m4*mabcd +IncVec = min(max(1,nCache/lsize),nVec) +ipA3 = 1 +nA3 = nVec*lZeta ! This is the same for the second set! +ipA2 = ipA3+nA3 + +call TncHlf_h(Coef1,m1,n1,Coef2,m2,n2,lZeta,nVec,IncVec,ACInt,Scrtch(ipA2),Scrtch(ipA3),IndZet) + +nCache = (3*lCache)/4-n3*m3-n4*m4 +lsize = m3*m4+m4*n3 +nVec = mabcd*lZeta +IncVec = min(max(1,nCache/lsize),nVec) + +lZE = lZeta*lEta +if (mabcd /= 1) then + call TncHlf_h(Coef3,m3,n3,Coef4,m4,n4,lEta,nVec,IncVec,Scrtch(ipA3),Scrtch(ipA2),ACOut,IndEta) + call DGeTMO(ACOut,mabcd,mabcd,lZE,Scrtch,lZE) + call dcopy_(mabcd*lZE,Scrtch,1,ACOut,1) +else + call TncHlf_h(Coef3,m3,n3,Coef4,m4,n4,lEta,nVec,IncVec,Scrtch(ipA3),Scrtch(ipA2),ACOut,IndEta) +end if + +if (iPrint >= 59) call RecPrt(' In Tcrtnc: P(ab|cd) ',' ',ACOut,mabcd,lZE) +if (iPrint >= 19) call WrCheck('Tcrtnc:P(ab|cd)',ACOut,lZE*mabcd) + +return + +end subroutine Tcrtnc_h diff -Nru openmolcas-22.02/src/mckinley/tnchlf_h.F90 openmolcas-22.10/src/mckinley/tnchlf_h.F90 --- openmolcas-22.02/src/mckinley/tnchlf_h.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/tnchlf_h.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,140 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990,1994,1996, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Tnchlf_h(Coeff1,nCntr1,nPrm1,Coeff2,nCntr2,nPrm2,lZeta,nVec,IncVec,A1,A2,A3,Indij) +!*********************************************************************** +! * +! Object: to do a half transformation. The loop over the two matrix- * +! matrix multiplications is segmented such that the end of the * +! intermediate matrix will not push the start of the same out * +! from the cache. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +! * +! Modified to decontraction May 1996, by R. Lindh * +!*********************************************************************** + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nCntr1, nPrm1, nCntr2, nPrm2, lZeta, nVec, IncVec, Indij(lZeta) +real(kind=wp), intent(in) :: Coeff1(nPrm1,nCntr1), Coeff2(nPrm2,nCntr2), A1(nCntr1,nCntr2,nVec) +real(kind=wp), intent(out) :: A2(nCntr2,IncVec*nPrm1), A3(nVec,lZeta) +integer(kind=iwp) :: iCntr1, iCntr2, iiVec, ijVec, iPrm1, iPrm2, iZeta, mVec +logical(kind=iwp) :: Seg1, Seg2 + +! Check if the basis set is segmented + +Seg1 = .false. +loop1: do iPrm1=nPrm1,1,-1 + do iCntr1=nCntr1,1,-1 + if (Coeff1(iPrm1,iCntr1) == Zero) then + Seg1 = .true. + exit loop1 + end if + end do +end do loop1 + +Seg2 = .false. +loop2: do iPrm2=nPrm2,1,-1 + do iCntr2=nCntr2,1,-1 + if (Coeff2(iPrm2,iCntr2) == Zero) then + Seg2 = .true. + exit loop2 + end if + end do +end do loop2 + +! Set output matrix to zero + +A3(:,:) = Zero + +! Loop sectioning + +do iiVec=1,nVec,IncVec + mVec = min(IncVec,nVec-iiVec+1) + ! Set intermediate matrix to zero + A2(:,1:mVec*nPrm1) = Zero + + if (Seg1) then + + ! First quarter transformation + + do iPrm1=1,nPrm1 + ijVec = mVec*(iPrm1-1)+1 + do iCntr1=1,nCntr1 + ! Check for zero due to segmented basis + if (abs(Coeff1(iPrm1,iCntr1)) > Zero) then + do iCntr2=1,nCntr2 + A2(iCntr2,ijVec:ijVec+mVec-1) = A2(iCntr2,ijVec:ijVec+mVec-1)+Coeff1(iPrm1,iCntr1)*A1(iCntr1,iCntr2,iiVec:iiVec+mVec-1) + end do + end if + end do + end do + + else ! Seg1 + + ! First quarter transformation + + do iPrm1=1,nPrm1 + ijVec = mVec*(iPrm1-1)+1 + do iCntr1=1,nCntr1 + do iCntr2=1,nCntr2 + A2(iCntr2,ijVec:ijVec+mVec-1) = A2(iCntr2,ijVec:ijVec+mVec-1)+Coeff1(iPrm1,iCntr1)*A1(iCntr1,iCntr2,iiVec:iiVec+mVec-1) + end do + end do + end do + + end if ! Seg1 + + if (Seg2) then + + ! Second quarter transformation + + do iCntr2=1,nCntr2 + do iZeta=1,lZeta + iPrm2 = (Indij(iZeta)-1)/nPrm1+1 + iPrm1 = Indij(iZeta)-(iPrm2-1)*nPrm1 + ! Check for zero due to segmented basis + if (abs(Coeff2(iPrm2,iCntr2)) > Zero) then + ijVec = mVec*(iPrm1-1)+1 + A3(iiVec:iiVec+mVec-1,iZeta) = A3(iiVec:iiVec+mVec-1,iZeta)+Coeff2(iPrm2,iCntr2)*A2(iCntr2,ijVec:ijVec+mVec-1) + end if + end do + end do + + else + + ! Second quarter transformation + + do iCntr2=1,nCntr2 + do iZeta=1,lZeta + iPrm2 = (Indij(iZeta)-1)/nPrm1+1 + iPrm1 = Indij(iZeta)-(iPrm2-1)*nPrm1 + ijVec = mVec*(iPrm1-1)+1 + A3(iiVec:iiVec+mVec-1,iZeta) = A3(iiVec:iiVec+mVec-1,iZeta)+Coeff2(iPrm2,iCntr2)*A2(iCntr2,ijVec:ijVec+mVec-1) + end do + end do + + end if + + ! End of loop sectioning + +end do + +return + +end subroutine Tnchlf_h diff -Nru openmolcas-22.02/src/mckinley/translation.f openmolcas-22.10/src/mckinley/translation.f --- openmolcas-22.02/src/mckinley/translation.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/translation.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,158 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Translation(ifg,jfgrd,jfhss,tr,jndgrd,jndhss,coorm, - & nirrep,indgrd,indhss) - Implicit Integer(a-z) - Logical jfhss(4,3,4,3),jfgrd(3,4),tr(4),ifg(4),eq,alike - - Integer jndgrd(3,4,0:nirrep-1),jndhss(4,3,4,3,0:nirrep-1) - Integer indgrd(3,4,0:nirrep-1),indhss(4,3,4,3,0:nirrep-1) - Real*8 Coorm(3,4) - Alike=.false. - If (IfG(1).and.IfG(2).and.IfG(3).and.IfG(4)) Then - Do 3333 iCent=1,3 - If (.not.Alike) Then - Do 3334 jCent=iCent+1,4 - If (EQ(CoorM(1,iCent),CoorM(1,jCent))) Then - Do kCent=1,4 - iMax=Max(jCent,kCent) - iMin=Min(jCent,kCent) - Do kCar=1,3 - Do lCar=1,3 - Do mIrrep=0,nIrrep-1 - JndHss(iMax,kCar,iMin,lCar,mIrrep)=0 - End Do - JfHss(iMax,kCar,iMin,lCar)=.false. - End Do - End Do - End Do - Do jCar=1,3 - Do mIrrep=0,nIrrep-1 - JndGrd(jCar,jCent,mIrrep)=0 - End Do - jfGrd(jCar,jCent)=.false. - End Do - IfG(jCent)=.false. - If (.not.Alike) Then - IfG(iCent)=.false. - Tr(iCent)=.true. - Alike=.true. - Do kCent=1,4 - If ((.not.(EQ(CoorM(1,iCent), - & CoorM(1,kCent)))) .or. - & (kCent.eq.iCent)) - & then - iMax=Max(iCent,kCent) - iMin=Min(iCent,kCent) - Do kCar=1,3 - If (iMax.eq.iMin) Then - iStop=kCar - Else - iStop=3 - End If - Do lCar=1,iStop - Do mIrrep=0,nIrrep-1 - JndHss(iMax,kCar,iMin,lCar,mIrrep)= - & -IndHss(iMax,kCar,iMin,lCar,mIrrep) - End Do - JfHss(iMax,kCar,iMin,lCar)=.false. - -* Set the derivatives that are needed for the translation -* invarians calculations. -* - Do iiCent=1,4 - If (.not.EQ(CoorM(1,iiCent), - & CoorM(1,iCent))) - & Then - Do jjCent=1,iiCent - If (.not.EQ(CoorM(1,jjCent), - & CoorM(1,iCent))) - & Then - Do kkCar=1,3 - if (iiCent.eq.jjCent) Then - iStop=kkCar - Else - iStop=3 - End If - Do llCar=1,iStop - JfHss(iiCent,kkCar, - & jjCent,llCar)=.true. - End Do - End Do - End If - End Do ! icent - Do kkCar=1,3 - JfGrd(kkCar,iiCent)=.true. - End Do - End If - End Do - End Do - End Do - End If - End Do - Do jCar=1,3 - Do mIrrep=0,nIrrep-1 - JndGrd(jCar,iCent,mIrrep)= - & -IndGrd(jCar,iCent,mIrrep) - End Do - JfGrd(jCar,iCent)=.false. - End Do - End If - End If - 3334 Continue - End If - 3333 Continue - End If -* -* If all centers are different delete the fourth center -* - If (.not.Alike) Then - IfG(4)=.false. - Tr(4)=.true. - Call lCopy(12,[.true.],0,JFGRD,1) -* Call lCopy(144,[.true.],0,JFHss,1) - Do iiC=1,4 - Do jjC=1,iiC - Do iiCar=1,3 - iStop=3 - If (iic.eq.jjc) iStop=iiCar - Do jjCar=1,iStop - JfHss(iiC,iiCar,jjc,jjCar)=.true. - End Do - End Do - End Do - End Do - - Do kCar=1,3 - Do lCent=1,4 - iStop=3 - If (lCent.eq.4) iStop=kCar - Do lCar=1,iStop - Do mIrrep=0,nirrep-1 - JndHss(4,kCar,lCent,lCar,mIrrep)= - & -IndHss(4,kCar,lCent,lCar,mIrrep) - End Do - JfHss(4,kCar,lCent,lCar)=.false. - End Do - End Do - End Do -* - Do lCar=1,3 - Do mIrrep=0,nirrep-1 - Jndgrd(lCar,4,mIrrep)= - & -IndGrd(lCar,4,mIrrep) - End Do - jfgrd(lCar,4)=.false. - End Do -* - End If - return - end diff -Nru openmolcas-22.02/src/mckinley/translation.F90 openmolcas-22.10/src/mckinley/translation.F90 --- openmolcas-22.02/src/mckinley/translation.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/translation.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,130 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Translation(ifg,jfgrd,jfhss,tr,jndgrd,jndhss,coorm,nirrep,indgrd,indhss) + +use Definitions, only: wp, iwp + +implicit none +logical(kind=iwp), intent(inout) :: ifg(4), jfgrd(3,4), jfhss(4,3,4,3), tr(4) +integer(kind=iwp), intent(in) :: nirrep, indgrd(3,4,0:nirrep-1), indhss(4,3,4,3,0:nirrep-1) +integer(kind=iwp), intent(inout) :: jndgrd(3,4,0:nirrep-1), jndhss(4,3,4,3,0:nirrep-1) +real(kind=wp), intent(in) :: Coorm(3,4) +integer(kind=iwp) :: iCent, iiC, iiCar, iiCent, iMax, iMin, iStop, jCent, jjC, jjCent, kCar, kCent, kkCar, lCar, lCent +logical(kind=iwp) :: alike +logical(kind=iwp), external :: EQ + +Alike = .false. +if (IfG(1) .and. IfG(2) .and. IfG(3) .and. IfG(4)) then + do iCent=1,3 + if (.not. Alike) then + do jCent=iCent+1,4 + if (EQ(CoorM(1,iCent),CoorM(1,jCent))) then + do kCent=1,4 + iMax = max(jCent,kCent) + iMin = min(jCent,kCent) + JndHss(iMax,:,iMin,:,0:nIrrep-1) = 0 + JfHss(iMax,:,iMin,:) = .false. + end do + JndGrd(:,jCent,0:nIrrep-1) = 0 + JfGrd(:,jCent) = .false. + IfG(jCent) = .false. + if (.not. Alike) then + IfG(iCent) = .false. + Tr(iCent) = .true. + Alike = .true. + do kCent=1,4 + if ((.not. EQ(CoorM(1,iCent),CoorM(1,kCent))) .or. (kCent == iCent)) then + iMax = max(iCent,kCent) + iMin = min(iCent,kCent) + do kCar=1,3 + if (iMax == iMin) then + iStop = kCar + else + iStop = 3 + end if + JndHss(iMax,kCar,iMin,1:iStop,0:nIrrep-1) = -IndHss(iMax,kCar,iMin,1:iStop,0:nIrrep-1) + JfHss(iMax,kCar,iMin,1:iStop) = .false. + do lCar=1,iStop + + ! Set the derivatives that are needed for the translation + ! invariance calculations. + + do iiCent=1,4 + if (.not. EQ(CoorM(1,iiCent),CoorM(1,iCent))) then + do jjCent=1,iiCent + if (.not. EQ(CoorM(1,jjCent),CoorM(1,iCent))) then + do kkCar=1,3 + if (iiCent == jjCent) then + iStop = kkCar + else + iStop = 3 + end if + JfHss(iiCent,kkCar,jjCent,1:iStop) = .true. + end do + end if + end do ! icent + JfGrd(:,iiCent) = .true. + end if + end do + end do + end do + end if + end do + JndGrd(:,iCent,0:nIrrep-1) = -IndGrd(:,iCent,0:nIrrep-1) + JfGrd(:,iCent) = .false. + end if + end if + end do + end if + end do +end if + +! If all centers are different delete the fourth center + +if (.not. Alike) then + IfG(4) = .false. + Tr(4) = .true. + JfGrd(:,:) = .true. + !JfHss(:,:,:,:) = .true. + do iiC=1,4 + do jjC=1,iiC + do iiCar=1,3 + if (iic == jjc) then + iStop = iiCar + else + iStop = 3 + end if + JfHss(iiC,iiCar,jjc,1:iStop) = .true. + end do + end do + end do + + do kCar=1,3 + do lCent=1,4 + if (lCent == 4) then + iStop = kCar + else + iStop = 3 + end if + JndHss(4,kCar,lCent,1:iStop,nIrrep-1) = -IndHss(4,kCar,lCent,1:iStop,nIrrep-1) + JfHss(4,kCar,lCent,1:iStop) = .false. + end do + end do + + Jndgrd(:,4,nIrrep-1) = -IndGrd(:,4,nIrrep-1) + JfGrd(:,4) = .false. + +end if + +return + +end subroutine Translation diff -Nru openmolcas-22.02/src/mckinley/trnab.f openmolcas-22.10/src/mckinley/trnab.f --- openmolcas-22.02/src/mckinley/trnab.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/trnab.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,20 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SubRoutine Trnab(Win,Wout,nvec,na,nb) - Implicit Real*8 (A-H,O-Z) -c#include "print.fh" - Real*8 Win(na,nb,nVec), Wout(na,nb,nvec) -* - Do iVec = 1, nVec - Call DGeTmo(Win(1,1,ivec),na,na,nb,Wout(1,1,ivec),nb) - End Do - Return - End diff -Nru openmolcas-22.02/src/mckinley/trns3.f openmolcas-22.10/src/mckinley/trns3.f --- openmolcas-22.02/src/mckinley/trns3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/trns3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,54 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Trns3(Win,Wout,na,nb,nvec,nc,Temp) -************************************************************************ -* * -* Object: utility routine to transform a AO batch in case of redun- * -* dancy of type aA=bB or cC=dD. * -* * -* Called from: TwoEl * -* * -* Calling : Trns2 * -* DGeTMO (ESSL) * -* DCopy (ESSL) * -* * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* June '90 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -c#include "print.fh" - Real*8 Win(na,nb), Wout(nb,na),Temp(na,nb) -* -c iRout = 71 -c iPrint = nPrint(iRout) -* Write (*,*) ' In Trns1: na, nb, nVec, nc=',na,nb,nvec,nc -* Call RecPrt(' Win',' ',Win,na,nb) - If (nc.eq.1) Then - call dcopy_(nvec,Win,1,Wout,1) - Return - End If - If (na.eq.1 .or. nb.eq.1) Then - Call Trns2(Win,Wout,nvec,nc) - Else - Call DGeTMO(Win,na,na,nb,Wout,nb) -* Call RecPrt(' After first DGeTMO',' ',Wout,nb,na) - Call Trns2(Wout,Temp,nvec,nc) -* Call RecPrt(' After Trns2',' ',Temp,nb,na) - Call DGeTMO(Temp,nb,nb,na,Wout,na) -* Call RecPrt(' After second DGeTMO',' ',Wout,na,nb) - End If -* Call GetMem(' Exit Trns1','CHECK','REAL',iDum,iDum) - Return - End diff -Nru openmolcas-22.02/src/mckinley/twodns.f openmolcas-22.10/src/mckinley/twodns.f --- openmolcas-22.02/src/mckinley/twodns.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/twodns.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,102 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine TwoDns(ianga,iCmp,shijij,ishll,ishell,iAO, - & nop,iBasi,jBasj,kBask,lBasl, - & Aux,nAux,Work2,nWork2,Work3,nWork3,work4, - & nWork4,PSO,nPSO,Fact) -* - use Basis_Info - use Real_Spherical - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "real.fh" -#include "disp.fh" -#include "disp2.fh" - Logical Shijij - Integer nOp(4),iAnga(4),iCmp(4),iShell(4),iShll(4),iAO(4) - Real*8 PSO(nPSO),Aux(nAux),Work2(nWork2),Work3(nWork3), - & Work4(nWork4) -* -* Statement function -* - nElem(i) = (i+1)*(i+2)/2 -* - nijkl=iBasi*jBasj*kBask*lBasl - iShlla = iShll(1) - jShllb = iShll(2) - kShllc = iShll(3) - lShlld = iShll(4) - la=iAnga(1) - lb=iAnga(2) - lc=iAnga(3) - ld=iAnga(4) - iCmpa = iCmp(1) - jCmpb = iCmp(2) - kCmpc = iCmp(3) - lCmpd = iCmp(4) - mab = nElem(la)*nElem(lb) - mcd = nElem(lc)*nElem(ld) - -* -*----------------------------------------------------------------* -* -* Fix the second order density matrix -* -*----------------------------------------------------------------* -* -*--------------Desymmetrize the second order density matrix -* -*--------------(faA fbR(B) | fcT(C) fdTS(D))ijkl -* PSO->Work2 -* - Call DesymP(iAnga,iCmp(1),iCmp(2), - & iCmp(3),iCmp(4), - & Shijij,iShll,iShell,iAO,nOp,nijkl, - & Aux,nAux,Work2,PSO,nPSO) -* -* - If (Fact.ne.One) Call DScal_(nijkl* - & iCmp(1)*iCmp(2)*iCmp(3)*iCmp(4), - & Fact,Work2,1) -* -*--------------Backtransform 2nd order density matrix from spherical -* harmonic gaussians to cartesian gaussians. -* - ijklab = nijkl * iCmp(1)*iCmp(2) -* Work2->Work2 (Work3:Scratch) - Call SphCr1(Work2,ijklab, - & Work3,nWork3, - & RSph(ipSph(lc)),nElem(lc),kCmpc, - & Shells(kShllc)%Transf, - & Shells(kShllc)%Prjct, - & RSph(ipSph(ld)),nElem(ld),lCmpd, - & Shells(lShlld)%Transf, - & Shells(lShlld)%Prjct, - & Work2,mcd) -* Work2->Work4 (Work3:Scratch) - Call SphCr2(Work2,nijkl,mcd, - & Work3,nWork3, - & RSph(ipSph(la)),nElem(la),iCmpa, - & Shells(iShlla)%Transf, - & Shells(iShlla)%Prjct, - & RSph(ipSph(lb)),nElem(lb),jCmpb, - & Shells(jShllb)%Transf, - & Shells(jShllb)%Prjct, - & Work4,mab) -* -*----------------------------------------------------------------* -* -* P is now in cartisan AO base -* - Return - End diff -Nru openmolcas-22.02/src/mckinley/twodns.F90 openmolcas-22.10/src/mckinley/twodns.F90 --- openmolcas-22.02/src/mckinley/twodns.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/twodns.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,82 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine TwoDns(ianga,iCmp,shijij,ishll,ishell,iAO,nop,iBasi,jBasj,kBask,lBasl,Aux,nAux,Work2,nWork2,Work3,nWork3,Work4,nWork4, & + PSO,nPSO,Fact) + +use Index_Functions, only: nTri_Elem1 +use Basis_Info, only: Shells +use Real_Spherical, only: ipSph, RSph +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iAnga(4), iCmp(4), iShll(4), iShell(4), iAO(4), nOp(4), iBasi, jBasj, kBask, lBasl, nAux, nWork2, & + nWork3, nWork4, nPSO +logical(kind=iwp), intent(in) :: Shijij +real(kind=wp), intent(out) :: Aux(nAux), Work2(nWork2), Work3(nWork3), Work4(nWork4) +real(kind=wp), intent(in) :: PSO(nPSO), Fact +integer(kind=iwp) :: iCmpa, ijklab, iShlla, jCmpb, jShllb, kCmpc, kShllc, la, lb, lc, lCmpd, ld, lShlld, mab, mcd, n, nijkl + +nijkl = iBasi*jBasj*kBask*lBasl +iShlla = iShll(1) +jShllb = iShll(2) +kShllc = iShll(3) +lShlld = iShll(4) +la = iAnga(1) +lb = iAnga(2) +lc = iAnga(3) +ld = iAnga(4) +iCmpa = iCmp(1) +jCmpb = iCmp(2) +kCmpc = iCmp(3) +lCmpd = iCmp(4) +mab = nTri_Elem1(la)*nTri_Elem1(lb) +mcd = nTri_Elem1(lc)*nTri_Elem1(ld) + +!----------------------------------------------------------------------* +! +! Fix the second order density matrix +! +!----------------------------------------------------------------------* + +! Desymmetrize the second order density matrix + +! (faA fbR(B) | fcT(C) fdTS(D))ijkl +! PSO->Work2 + +call DesymP(iAnga,iCmp(1),iCmp(2),iCmp(3),iCmp(4),Shijij,iShll,iShell,iAO,nOp,nijkl,Aux,nAux,Work2,PSO,nPSO) + +if (Fact /= One) then + n = nijkl*iCmp(1)*iCmp(2)*iCmp(3)*iCmp(4) + Work2(1:n) = Fact*Work2(1:n) +end if + +! Backtransform 2nd order density matrix from spherical +! harmonic gaussians to cartesian gaussians. + +ijklab = nijkl*iCmp(1)*iCmp(2) +! Work2->Work2 (Work3:Scratch) +call SphCr1(Work2,ijklab,Work3,nWork3,RSph(ipSph(lc)),nTri_Elem1(lc),kCmpc,Shells(kShllc)%Transf,Shells(kShllc)%Prjct, & + RSph(ipSph(ld)),nTri_Elem1(ld),lCmpd,Shells(lShlld)%Transf,Shells(lShlld)%Prjct,Work2,mcd) +! Work2->Work4 (Work3:Scratch) +call SphCr2(Work2,nijkl,mcd,Work3,nWork3,RSph(ipSph(la)),nTri_Elem1(la),iCmpa,Shells(iShlla)%Transf,Shells(iShlla)%Prjct, & + RSph(ipSph(lb)),nTri_Elem1(lb),jCmpb,Shells(jShllb)%Transf,Shells(jShllb)%Prjct,Work4,mab) + +!----------------------------------------------------------------------* + +! P is now in cartesian AO base + +return + +end subroutine TwoDns diff -Nru openmolcas-22.02/src/mckinley/twoel_mck.f openmolcas-22.10/src/mckinley/twoel_mck.f --- openmolcas-22.02/src/mckinley/twoel_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/twoel_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,732 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine TwoEl_mck(Coor, - & iAngV,iCmp,iShell,iShll,iAO,iAOst, - & iStb,jStb,kStb,lStb,nRys, - & Data1,nab,nData1,Data2,ncd,nData2,Pren,Prem, - & Alpha,nAlpha,iPrInc, Beta, nBeta,jPrInc, - & Gamma,nGamma,kPrInc,Delta,nDelta,lPrInc, - & Coeff1,iBasi,Coeff2,jBasj,Coeff3,kBask,Coeff4,lBasl, - & Zeta,ZInv,P,rKab,nZeta,Eta,EInv,Q,rKcd,nEta, - & xA,xB,xG,xD,xPre,Hess,nhess, - & IfGrd,IndGrd,ifHss,IndHss,IfG, - & PSO,nPSO,Work2,nWork2,Work3,nWork3,Work4,nWork4, - & Aux,nAux,WorkX,nWorkX, - & Shijij, - & Dij1,Dij2,mDij,nDij,Dkl1,Dkl2,mDkl,nDkl, - & Dik1,Dik2,mDik,nDik,Dil1,Dil2,mDil,nDil, - & Djk1,Djk2,mDjk,nDjk,Djl1,Djl2,mDjl,nDjl, - & icmpi,Fin,nfin,Temp,nTemp,nTwo2,nFt, - & IndZet,IndEta,TwoHam,ipdens,Buffer,nBuffer, - & lgrad,ldot,n8,ltri,Dan,Din, - & moip,naco,rMOIN,nMOIN,new_fock) -************************************************************************ -* * -* Input: * -* Data1 : * -* Data2 * -* PSO * -* Work2 * -* Work3 * -* Work4 * -* AUX * -* Fin : Area for cntrctd int in sph hmn * -* Temp : Working place for F gen and n8 * -* TwoHam : Final results fock matrix and MO's * -* * -* Object: To construct the first order derivatives of the AO- * -* integrals and add them up to the MO derivatives and * -* the Fock matrix derivatives and contract the second * -* order derivatives of the AO's with the second order * -* density matrix. * -* * -* Authors: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* Anders Bernhardsson Theoretical Chemistry 95 * -************************************************************************ -* * -* When we are calculating the second order derivatives we need * -* the derivatives of the two electron integrals in three ways: * -* * -* (2) * -* 1) To calculate the static term H * -* - * -* 2) To calculate the non-zero part of <0|[E ,H]|0> * -* pq * -* * -* * -* 3) To calculate the derivatives of the MO orbitals with all * -* four indexes in the active space. * -* * -* In this implementation all contributions are calculated at * -* the same time. * -* * -* (2) * -* The H is calculated by contracting the second order * -* derivatives on the flight with the second order density matrix * -* * -* (1) (1) (1) * -* the F - F and MO are calculated by first contracting * -* pq qp * -* * -* the primitives and transform the integrals to spherical * -* harmonics and then construct the Fock matrix as a direct SCF * -* The Fock matrixes is transformed to MO base and then added up to * -* total Fock matrix * -* * -************************************************************************ - use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc - use Real_Spherical - use Basis_Info - use Center_Info - use Phase_Info - use Gateway_Info, only: CutInt - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) - External TERI1, ModU2, Cff2D -#include "Molcas.fh" -#include "ndarray.fh" -#include "real.fh" -#include "disp.fh" -#include "disp2.fh" -#include "buffer.fh" -#include "cputime.fh" -#include "print.fh" -* - Real*8 Coor(3,4), CoorM(3,4), CoorAC(3,2), - & Alpha(nAlpha), Beta(nBeta), Gamma(nGamma), Delta(nDelta), - & xA(nZeta),xB(nZeta), xG(nEta), xD(nEta), - & Data1(nZeta*nDArray+nDScalar,nData1),Hess(*), - & Data2( nEta*nDArray+nDScalar,nData2),rKab(nZeta),rKcd(nEta), - & Zeta(nZeta), ZInv(nZeta), P(nZeta,3), - & Eta(nEta), EInv(nEta), Q(nEta,3), - & Coeff1(nAlpha,iBasi), Coeff2(nBeta,jBasj), - & Coeff3(nGamma,kBask), Coeff4(nDelta,lBasl), - & PSO(iBasi*jBasj*kBask*lBasl,nPSO), Work2(nWork2), - & Work3(nWork3), Work4(nWork4),Aux(nAux), - & xpre(nGamma*nDelta*nAlpha*nBeta),Fin(nfin), - & Dij1(mDij,nDij),Dkl1(mDkl,nDkl),Dik1(mDik,nDik), - & Dil1(mDil,nDil),Djk1(mDjk,nDjk),Djl1(mDjl,nDjl), - & Dij2(mDij,nDij),Dkl2(mDkl,nDkl),Dik2(mDik,nDik), - & Dil2(mDil,nDil),Djk2(mDjk,nDjk),Djl2(mDjl,nDjl), - & WorkX(nWorkX),Temp(nTemp),TwoHam(nTwo2), - & Buffer(nBuffer),rMOIN(nMOIN),Din(*),Dan(* ) -* - Integer iDCRR(0:7), iDCRS(0:7), iDCRT(0:7), iStabN(0:7), - & iStabM(0:7), IndGrd(3,4,0:7), iAO(4), - & iCmp(4), iShell(4), iShll(4), - & nOp(4), iAngV(4), iAOst(4),JndGrd(3,4,0:7),icmpi(4), - & IndZet(nAlpha*nBeta),Indeta(nGamma*nDelta), iuvwx(4), - & IndHss(4,3,4,3,0:7), JndHss(4,3,4,3,0:7), - & Index(3,4), moip(0:7) -* - Logical Shijij, AeqB, CeqD, AeqC, ABeqCD, ABeq, CDeq, IfGrd(3,4), - & JfGrd(3,4), first,IfHss(4,3,4,3),JfHss(4,3,4,3),IfG(4), - & ltri,Tr(4),ldot,ldot2,lgrad,n8,log,no_integrals,new_fock -* * -************************************************************************ -* * -* Statement function to compute canonical index -* - nElem(i) = (i+1)*(i+2)/2 -* * -************************************************************************ -* * - Call TwoEl_mck_Internal(Data1,Data2) - - Contains - Subroutine TwoEl_mck_Internal(Data1,Data2) - Real*8, Target :: Data1(nZeta*nDArray+nDScalar,nData1), - & Data2( nEta*nDArray+nDScalar,nData2) - Integer, Pointer :: iData1(:), iData2(:) - Integer :: lZeta=0, lEta=0 - Logical EQ, lEmpty - External EQ, lEmpty -* * -************************************************************************ -* * -*Bug in gcc 7: https://gcc.gnu.org/bugzilla/show_bug.cgi?id=94270 -#ifdef _WARNING_WORKAROUND_ - Interface - SubRoutine Rysg2(iAnga,nRys,nT, - & Alpha,Beta,Gamma,Delta, - & Zeta,ZInv,nZeta,Eta,EInv,nEta, - & P,lP,Q,lQ,Coori,Coora,CoorAC, - & Array,nArray, - & Tvalue,ModU2,Cff2D, - & PAO,nPAO,Hess,nHess,IfGrd,IndGrd, - & IfHss,IndHss,nOp,iuvwx,IfG, - & mvec,Index_Out,lGrad,lHess,Tr) - Integer iAnga(4), nRys, nT, nZeta, nEta - Real*8 Alpha(nZeta), Beta(nZeta), Gamma(nEta), Delta(nEta), - & Zeta(nZeta), ZInv(nZeta), Eta(nEta), EInv(nEta) - Integer lP, lQ - Real*8 P(lP,3), Q(lQ,3), CoorAC(3,2), Coora(3,4), Coori(3,4) - Integer nArray - Real*8 Array(nArray) - External Tvalue, ModU2, Cff2D - Integer nPAO, nHess - Real*8 PAO(nT,nPAO), Hess(nHess) - Logical IfGrd(3,4), IfHss(4,3,4,3) - Integer IndGrd(3,4,0:7), IndHss(4,3,4,3,0:7), nOp(4), iuvwx(4) - Logical IfG(4), lGrad, lHess, Tr(4) - Integer mVec, Index_Out(3,4) - - End SubRoutine Rysg2 - - End Interface -#endif -* * -************************************************************************ -* * -* P R O L O G -* * -************************************************************************ -* * - nGr=0 - ABeq = EQ(Coor(1,1),Coor(1,2)) - CDeq = EQ(Coor(1,3),Coor(1,4)) - la = iAngV(1) - lb = iAngV(2) - lc = iAngV(3) - ld = iAngV(4) - ldot2=ldot - iCmpa = iCmp(1) - jCmpb = iCmp(2) - kCmpc = iCmp(3) - lCmpd = iCmp(4) - iShlla = iShll(1) - jShllb = iShll(2) - kShllc = iShll(3) - lShlld = iShll(4) - IncZet=nAlpha*jPrInc - IncEta=nGamma*lPrInc - LmbdT=0 - nijkl = iBasi*jBasj*kBask*lBasl - nabcd=iCmp(1)*iCmp(2)*iCmp(3)*iCmp(4) - mab = nElem(la)*nElem(lb) - mcd = nElem(lc)*nElem(ld) -* -* Scratch space for Fock Matrix construction -* - ip=1 - ipS1=ip - nS1=nijkl*nabcd - ip=ip+nS1 - ipS2=ip - nS2=max(nS1,nijkl+max(iBasi*lBasl,jBasj*lBasl, - & iBasi*kBask,jBasj*kBask)) - ip=ip+nS2 - ipFT=ip - ip=ip+nFT - ipTemp=ip - nTe=nijkl*nabcd - ip=ip+nTe - If (ip-1.gt.nTemp) Then - Write (6,*) 'TwoEl_McK: ip-1.gt.nTemp' - Write (6,*) 'ip,nTemp=',ip,nTemp - Call Abend() - End If -* - iuvwx(1) = dc(iStb)%nStab - iuvwx(2) = dc(jStb)%nStab - iuvwx(3) = dc(kStb)%nStab - iuvwx(4) = dc(lStb)%nStab -* * -************************************************************************ -* * -* - - - - - - E N D P R O L O G - - - - - - -* * -************************************************************************ -* * -*-----Find the Double Coset Representatives for center A and B -* - If (nIrrep.eq.1) Then - nDCRR=1 - iDCRR(0)=0 - LmbdR=1 - Else - Call DCR(LmbdR,dc(iStb)%iStab,dc(iStb)%nStab, - & dc(jStb)%iStab,dc(jStb)%nStab, - & iDCRR,nDCRR) - End If - u = DBLE(dc(iStb)%nStab) - v = DBLE(dc(jStb)%nStab) -* -*--------Find stabilizer for center A and B -* - If (nIrrep.eq.1) Then - lStabM=1 - iStabM(0)=0 - Else - Call Inter(dc(iStb)%iStab,dc(iStb)%nStab, - & dc(jStb)%iStab,dc(jStb)%nStab,iStabM,lStabM) - End If -* * -************************************************************************ -* * -*-----Find the Double Coset Representatives for center C and D. -* - If (nIrrep.eq.1) Then - nDCRS=1 - iDCRS(0)=0 - LmbdS=1 - Else - Call DCR(LmbdS,dc(kStb)%iStab,dc(kStb)%nStab, - & dc(lStb)%iStab,dc(lStb)%nStab, - & iDCRS,nDCRS) - End If - w = DBLE(dc(kStb)%nStab) - x = DBLE(dc(lStb)%nStab) -* -*-----------Find stabilizer for center C and D -* - If (nIrrep.eq.1) Then - lStabN=1 - iStabN(0)=0 - Else - Call Inter(dc(kStb)%iStab,dc(kStb)%nStab, - & dc(lStb)%iStab,dc(lStb)%nStab,iStabN,lStabN) - End If -* * -************************************************************************ -* * -* -*-----Find the Double Coset Representatives for the two charge -* distributions. -* - If (nIrrep.eq.1) Then - nDCRT=1 - iDCRT(0)=0 - LmbdT=1 - Else - Call DCR(LmbdT,iStabM,lStabM,iStabN,lStabN,iDCRT,nDCRT) - End If -* * -************************************************************************ -* * -* -*-----Factor due to summation over DCR -* - If (MolWgh.eq.1) Then - Fact = DBLE(nIrrep) / DBLE(LmbdT) - Else If (MolWgh.eq.0) Then - Fact = u*v*w*x / DBLE(nIrrep**3 * LmbdT) - Else - Fact = Sqrt(u*v*w*x)/DBLE(nIrrep*LmbdT) - End If -* * -************************************************************************ -* * - nOp(1)=NrOpr(0) - call dcopy_(3,Coor(1,1),1,CoorM(1,1),1) -* * -************************************************************************ -* * -* - - - - Loop over first set -* * -************************************************************************ -* * - Do 100 lDCRR = 0, nDCRR-1 - nOp(2)=NrOpr(iDCRR(lDCRR)) - Call OA(iDCRR(lDCRR),Coor(1:3,2),CoorM(1:3,2)) - AeqB = EQ(CoorM(1,1),CoorM(1,2)) -* * -************************************************************************ -* * -* - - - - Loop over second set -* * -************************************************************************ -* * - Do 200 lDCRS = 0, nDCRS-1 - call dcopy_(3,Coor(1,3),1,CoorM(1,3),1) - Call OA(iDCRS(lDCRS),Coor(1:3,4),CoorM(1:3,4)) - CeqD = EQ(Coor(1,3),CoorM(1,4)) -* * -************************************************************************ -* * -* - - - - Loop over third set -* * -************************************************************************ -* * - Do 300 lDCRT = nDCRT-1, 0, -1 - - nOp(3) = NrOpr(iDCRT(lDCRT)) - nOp(4) = NrOpr(iEor(iDCRT(lDCRT),iDCRS(lDCRS))) -* - iDCRTS=iEor(iDCRT(lDCRT),iDCRS(lDCRS)) - Call OA(iDCRTS,Coor(1:3,4),CoorM(1:3,4)) - Call OA(iDCRT(lDCRT),Coor(1:3,3),CoorM(1:3,3)) -* - AeqC = EQ(CoorM(1,1),CoorM(1,3)) - ABeqCD = AeqB .and. CeqD .and. AeqC -*--------------No contribution to geometric derivatives from one-center -* integrals - If (ABeqCD) Go To 302 -* -*--------------Find the proper centers to start of with the angular -* momentum on. If la.eq.lb there will excist an -* ambiguity to which center that angular momentum should -* be accumulated on. In that case we will use A and C of -* the order as defined by the basis functions types. -* - If (iAngV(1).ge.iAngV(2)) Then - call dcopy_(3,CoorM(1,1),1,CoorAC(1,1),1) - Else - call dcopy_(3,CoorM(1,2),1,CoorAC(1,1),1) - End If - If (iAngV(3).ge.iAngV(4)) Then - call dcopy_(3,CoorM(1,3),1,CoorAC(1,2),1) - Else - call dcopy_(3,CoorM(1,4),1,CoorAC(1,2),1) - End If -* -* Calculate the desymmetrized two-electron density matrix in -* cartisian AO base. -* - Call Timing(dum1,Time,dum2,dum3) - If (ldot2) - & Call TwoDns(iAngV,iCmp,shijij,ishll,ishell, - & iAO,nOp,iBasi,jBasj,kBask,lBasl, - & Aux,nAux,Work2,nWork2,Work3,nWork3,work4, - & nWork4,PSO,nPSO,Fact) -* - Call Timing(dum1,Time,dum2,dum3) - CpuStat(nTwoDens)=CpuStat(nTwoDens)+Time -* -*----------------------------------------------------------------* -* -* Loops to partion the primitives -* -*----------------------------------------------------------------* - lDCR1=NrOpr(iDCRR(lDCRR))+1 - lDCR2=NrOpr(iDCRS(lDCRS))+1 - ix2 = iPhase(1,iDCRT(lDCRT)) - iy2 = iPhase(2,iDCRT(lDCRT)) - iz2 = iPhase(3,iDCRT(lDCRT)) -* - Call C_F_Pointer(C_Loc(Data1(ip_IndZ(1,nZeta),lDCR1)), - & iData1,[nZeta+1]) - Call C_F_Pointer(C_Loc(Data2(ip_IndZ(1,nEta ),lDCR2)), - & iData2,[nEta +1]) - nZeta_Tot=iData1(nZeta+1) - nEta_Tot =iData2(nEta +1) -* - no_integrals=.true. - first=.true. - nGr=0 - Do 400 iZeta = 1, nZeta_Tot, IncZet - mZeta=Min(IncZet,nZeta_Tot-iZeta+1) -*-----------------Check that subblock of contraction matrix has non-zero -* elements. - If (lEmpty(Coeff2,nBeta,nBeta,jBasj)) - & Go To 401 - Do 410 iEta = 1, nEta_Tot, IncEta - mEta=Min(IncEta,nEta_Tot-iEta+1) -*-----------------Check that subblock of contraction matrix has non-zero -* elements. - If (lEmpty(Coeff4,nDelta,nDelta,lBasl)) - & Go To 411 - Pren = Pren + DBLE(mab*mcd*mZeta*mEta) -*------------------------------------------------------------------------- -* -* Fix the control matrixes for derivatives -* and try to use translation invariance as -* efficient as possible. -* -* OBS DETTA SKALL FLYTTAS UT UR INRE LOOPEN -* -*------------------------------------------------------------------------- - Call LCopy(144,IfHss,1,JfHss,1) - Call LCopy(12,IfGrd,1,JfGrd,1) - Call LCopy(4,[.true.],0,ifg,1) - Call LCopy(4,[.false.],0,Tr,1) - Call ICopy(144*nIrrep,IndHss,1,JndHss,1) - Call ICopy(12*nIrrep,IndGrd,1,JndGrd,1) -* -* Delete one center that should be calculated with -* translation invariance -* - call Translation(ifg,jfgrd,jfhss,tr,jndgrd,jndhss, - & coorm, nirrep,indgrd,indhss) - - if (.not.ldot) Call LCopy(144,[.false.],0,JfHss,1) - if (.not.ldot) Call iCopy(144*8,[0],0,JndHss,1) -*-------------------------------------------------------------* -* PRE PRESCREENING * -*-------------------------------------------------------------* -* - lZeta=mZeta - lEta =mEta -* -*-----------------Decontract the 2nd order density matrix -* -* Work4->Work2 Work3:scratch - Call Timing(dum1,Time,dum2,dum3) - If (ldot2) - & Call Tcrtnc_h( - & Coeff1,nAlpha,iBasi, - & Coeff2,nBeta,jBasj, - & Coeff3,nGamma,kBask, - & Coeff4,nDelta,lBasl, - & Work4,mab*mcd,Work3,nWork3/2,Work2, - & iData1(iZeta:iZeta+mZeta-1),mZeta, - & iData2(iEta :iEta +mEta -1),mEta) - Call Timing(dum1,Time,dum2,dum3) - CPUStat(nTwoDens)=CPUStat(nTwoDens)+Time -* -*-----------------Transfer k2 data and prescreen -* -* Work2:PAO-> Work2 -* Work3 Scratch - Call Timing(dum1,Time,dum2,dum3) - Call Screen_mck(Work2,Work3,mab*mcd,nZeta,nEta, - & mZeta,mEta,lZeta,lEta, - & Zeta,ZInv,P,xA,xB,rKab, - & Data1(ip_Z(iZeta,nZeta),lDCR1), - & iData1(iZeta:iZeta+mZeta-1), - & Data1(ip_ZtMax(nZeta),ldcr1), - & Data1(ip_abMax(nZeta),ldcr1), - & Data1(ip_ZetaM(nZeta),ldcr1), - & nAlpha,nBeta, - & Eta, EInv,Q,xG,xD,rKcd, - & Data2(ip_Z(iEta,nEta),lDCR2), - & iData2(iEta :iEta +mEta -1), - & Data2(ip_ZtMax(nEta),ldcr2), - & Data2(ip_abMax(nEta),ldcr2), - & Data2(ip_ZetaM(nEta),ldcr2), - & nGamma,nDelta, - & xpre, - & 1,1,1,ix2,iy2,iz2, - & CutInt, - & PreScr, - & IndZet,IndEta,ldot2) - Call Timing(dum1,Time,dum2,dum3) - CPUStat(nScreen)=CPUStat(nScreen)+Time -* - Prem = Prem + DBLE(mab*mcd*lZeta*lEta) - If (lzeta*leta.ne.0) no_integrals=.false. - If (lZeta*lEta.eq.0) Go To 411 -* -*-----------------Compute integral derivative and accumulate -* contribution to the molecular gradient. -* -* Work2:PAO -* Work3:Work area The PO integrals are stored in the begining -* of Work3 -* - Call Timing(dum1,Time,dum2,dum3) -* - Call Rysg2(iAngV,nRys,lZeta*lEta, - & xA,xB,xG,xD, - & Zeta,ZInv,lZeta, - & Eta,EInv,lEta, - & P,nZeta,Q,nEta, - & CoorM,CoorM,CoorAC,Work3,nWork3, - & TERI1,ModU2,Cff2D, - & Work2,mab*mcd, - & Hess,nHess,JfGrd,JndGrd, - & JfHss,JndHss,nOp,iuvwx,IfG, - & nGr,Index,lgrad,ldot,Tr) - Call Timing(dum1,Time,dum2,dum3) - CPUStat(nIntegrals)=CPUStat(nIntegrals)+Time - -* Work3 AO -* Work3_3 Scratch -* -> Work3_2 -*--------------------------------------------------------------* -* -*--------------Transform integrals ta AO base -* -*--------------------------------------------------------------* - ip2=nGr*mab*mcd*lZeta*lEta+1 - Call Timing(dum1,Time,dum2,dum3) - Call Cntrct_mck(First, - & Coeff1,nAlpha,iBasi, - & Coeff2,nBeta ,jBasj, - & Coeff3,nGamma,kBask, - & Coeff4,nDelta,lBasl, - & Work3,nGr*mab*mcd, - & Work3(ip2),nwork3-ip2, - & xpre,WorkX,nWorkX, - & lZeta*lEta, - & IndZet,nZeta,lZeta,IndEta,nEta,lEta) - 411 Continue - 410 Continue - 401 Continue - 400 Continue -* -* -* Mark which derivatives that should be calculated with translation -* invarians. -* - If (nGr.eq.0) goto 911 - Do iCNT=1,4 - If (Tr(iCnt)) Then - Do iCar=1,3 - log=.false. - Do iIrr=0,nIrrep-1 - log=(log.or.indgrd(iCar,iCnt,iIrr).ne.0) - End Do - If (log) Index(iCar,iCnt)=-1 - End Do - End If - End Do -* - If (MolWgh.eq.1) Then - FactNd = DBLE(nIrrep) / DBLE(LmbdT) - Else If (MolWgh.eq.0) Then - FactNd = u*v*w*x / DBLE(nIrrep**3 * LmbdT) - Else - factNd = sqrt(u*v*w*x)/DBLE(nirrep*lmbdt) - End If -* - If (FactNd.ne.One) - & Call DScal_(nGr*mab*mcd*nijkl,FactNd,WorkX,1) -* -*-----------------------------------------------------------------* -* -* Transpose abcd,g,IJKL -> bcd,g,IJKL,A Work3 -> Work3_2 -* -*-----------------------------------------------------------------* -* - niag=nijkl*nElem(lb)*mcd*nGr - Call CrSph_mck(WorkX,niag,(la+1)*(la+2)/2, - & RSph(ipSph(la)),la, - & Shells(iShlla)%Transf, - & Shells(iShlla)%Prjct, - & Work3,iCmpa) - nw3=niag*iCmpa - ip2=1+nw3 -*-----------------------------------------------------------------* -* -* Transpose bcd,g,IJKL,A -> cd,g,IJKL,AB Work3_2->Work3 -* -*-----------------------------------------------------------------* - niag=nijkl*mcd*nGr*iCmpa - nw3_2=niag*jCmpb - If (nw3+nw3_2.gt.nWork3) Then - Write (6,*) '1: nw3+nw3_2.gt.nWork3' - Call Abend() - End If - Call CrSph_mck(Work3,niag,(lb+1)*(lb+2)/2, - & RSph(ipSph(lb)),lb, - & Shells(jShllb)%Transf, - & Shells(jShllb)%Prjct, - & Work3(ip2),jCmpb) -*-----------------------------------------------------------------* -* -* Transpose cd,g,IJKL,AB -> d,g,IJKL,ABC Work3->Work3_2 -* -*-----------------------------------------------------------------* -* - niag=nijkl*nGr*nElem(ld)*iCmpa*jCmpb - Call CrSph_mck(Work3(ip2),niag,(lc+1)*(lc+2)/2, - & RSph(ipSph(lc)),lc, - & Shells(kShllc)%Transf, - & Shells(kShllc)%Prjct, - & Work3,kCmpc) - If (niag*kCmpc.gt.nw3) Then - Write (6,*) 'niag*kCmpc.gt.nw3' - Call Abend() - End If - nw3=niag*kCmpc - ip2=nw3+1 -*-----------------------------------------------------------------* -* -* Transpose d,g,IJKL,ABC -> g,IJKL,ABCD Work3_2->Work3 -* -*-----------------------------------------------------------------* - niag=nijkl*nGr*iCmpa*jCmpb*kCmpc - nw3_2=niag*lCmpd - If (nw3+nw3_2.gt.nWork3) Then - Write (6,*) '2: nw3+nw3_2.gt.nWork3' - Call Abend() - End If - Call CrSph_mck(Work3,niag,(ld+1)*(ld+2)/2, - & RSph(ipSph(ld)),ld, - & Shells(lShlld)%Transf, - & Shells(lShlld)%Prjct, - & Work3(ip2),lCmpd) -*-----------------------------------------------------------------* -* -* Transpose g,IJKL,ABCD -> IJKL,ABCD,g Work3->Buffer -* -*-----------------------------------------------------------------* - niag=nijkl*iCmpa*jCmpb*kCmpc*lCmpd - Call DGetMO(Work3(ip2),nGr,nGr,niag,Fin,niag) -* -* D E B U G (calculates gradient from transformed integrals) -* -* - Call Timing(dum1,Time,dum2,dum3) - CPUStat(nTrans)=CPUStat(nTrans)+Time -* -*-----------------------------------------------------------------* -* -* Send the integrals to clrbuffer for construction of -* -*-----------------------------------------------------------------* -* -* - Call ClrBuf(idcrr(ldcrr),idcrs(ldcrs), - & idcrt(ldcrt),nGr, - & iStb, - & jStb, - & kStb, - & lStb, - & Shijij,iAngV,iCmpi,iCmp, - & iShll,iShell,iShell, - & iBasi,jBasj,kBask,lBasl, - & Dij1,Dij2,mDij,nDij, - & Dkl1,Dkl2,mDkl,nDkl, - & Dik1,Dik2,mDik,nDik, - & Dil1,Dil2,mDil,nDil, - & Djk1,Djk2,mDjk,nDjk, - & Djl1,Djl2,mDjl,nDjl, - & fin,nfin, - & Temp(ipFT),nFT, - & Temp(ipS1),nS1,Temp(ipS2),nS2, - & Temp(ipTemp),nTe,TwoHam,nTwo2, - & JndGrd,Index,iao,iaost,iuvwx,ifG,n8,ltri, - & moip,nAcO,rMoin,nmoin,ntemp,Buffer, - & coor,nOp,Din,Dan,new_fock) - 911 Continue -* - 302 Continue -* - 300 Continue -* - 200 Continue -* - 100 Continue - Return -* * -************************************************************************ -* * - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(nab) - Call Unused_integer(ncd) - Call Unused_real_array(Alpha) - Call Unused_integer(iPrInc) - Call Unused_real_array(Beta) - Call Unused_real_array(Gamma) - Call Unused_integer(kPrInc) - Call Unused_real_array(Delta) - Call Unused_integer(ipdens) - End If - End Subroutine Twoel_Mck_Internal - End Subroutine Twoel_Mck diff -Nru openmolcas-22.02/src/mckinley/twoel_mck.F90 openmolcas-22.10/src/mckinley/twoel_mck.F90 --- openmolcas-22.02/src/mckinley/twoel_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/twoel_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,592 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Roland Lindh * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine TwoEl_mck(Coor,iAngV,iCmp,iShell,iShll,iAO,iAOst,iStb,jStb,kStb,lStb,nRys,Data1,nData1,Data2,nData2,Pren,Prem,nAlpha, & + nBeta,jPrInc,nGamma,nDelta,lPrInc,Coeff1,iBasi,Coeff2,jBasj,Coeff3,kBask,Coeff4,lBasl,Zeta,ZInv,P,rKab,nZeta, & + Eta,EInv,Q,rKcd,nEta,xA,xB,xG,xD,xPre,Hess,nHess,IfGrd,IndGrd,IfHss,IndHss,IfG,PSO,nPSO,Work2,nWork2,Work3, & + nWork3,Work4,nWork4,Aux,nAux,WorkX,nWorkX,Shijij,Dij1,Dij2,mDij,nDij,Dkl1,Dkl2,mDkl,nDkl,Dik1,Dik2,mDik,nDik, & + Dil1,Dil2,mDil,nDil,Djk1,Djk2,mDjk,nDjk,Djl1,Djl2,mDjl,nDjl,icmpi,Fin,nfin,Temp,nTemp,nTwo2,nFt,IndZet, & + IndEta,TwoHam,Buffer,nBuffer,lgrad,ldot,n8,ltri,Dan,Din,moip,naco,rMOIN,nMOIN,new_fock) +!*********************************************************************** +! * +! Input: * +! Data1 * +! Data2 * +! PSO * +! Work2 * +! Work3 * +! Work4 * +! AUX * +! Fin : Area for cntrctd int in sph hmn * +! Temp : Working place for F gen and n8 * +! TwoHam : Final results fock matrix and MO's * +! * +! Object: To construct the first order derivatives of the AO- * +! integrals and add them up to the MO derivatives and * +! the Fock matrix derivatives and contract the second * +! order derivatives of the AO's with the second order * +! density matrix. * +! * +! Authors: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! Anders Bernhardsson Theoretical Chemistry 95 * +!*********************************************************************** +! * +! When we are calculating the second order derivatives we need * +! the derivatives of the two electron integrals in three ways: * +! * +! (2) * +! 1) To calculate the static term H * +! - * +! 2) To calculate the non-zero part of <0|[E ,H]|0> * +! pq * +! * +! * +! 3) To calculate the derivatives of the MO orbitals with all * +! four indexes in the active space. * +! * +! In this implementation all contributions are calculated at * +! the same time. * +! * +! (2) * +! The H is calculated by contracting the second order * +! derivatives on the flight with the second order density matrix * +! * +! (1) (1) (1) * +! the F - F and MO are calculated by first contracting * +! pq qp * +! * +! the primitives and transform the integrals to spherical * +! harmonics and then construct the Fock matrix as a direct SCF * +! The Fock matrixes is transformed to MO base and then added up to * +! total Fock matrix * +! * +!*********************************************************************** + +use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc +use McKinley_global, only: CPUStat, nIntegrals, nScreen, nTrans, nTwoDens, PreScr +use Index_Functions, only: nTri_Elem1 +use Real_Spherical, only: ipSph, RSph +use Basis_Info, only: MolWgh, Shells +use Center_Info, only: dc +use Phase_Info, only: iPhase +use Gateway_Info, only: CutInt +use Symmetry_Info, only: nIrrep +use Constants, only: One +use Definitions, only: wp, iwp, u6 + +implicit none +#include "ndarray.fh" +integer(kind=iwp), intent(in) :: iAngV(4), iCmp(4), iShell(4), iShll(4), iAO(4), iAOst(4), iStb, jStb, kStb, lStb, nRys, nData1, & + nData2, nAlpha, nBeta, jPrInc, nGamma, nDelta, lPrInc, iBasi, jBasj, kBask, lBasl, nZeta, nEta, & + nHess, IndGrd(3,4,0:7), IndHss(4,3,4,3,0:7), nPSO, nWork2, nWork3, nWork4, nAux, nWorkX, mDij, & + nDij, mDkl, nDkl, mDik, nDik, mDil, nDil, mDjk, nDjk, mDjl, nDjl, icmpi(4), nfin, nTemp, nTwo2, & + nFt, nBuffer, moip(0:7), naco, nMOIN +real(kind=wp), intent(in) :: Coor(3,4), Data1(nZeta*nDArray+nDScalar,nData1), Data2(nEta*nDArray+nDScalar,nData2), & + Coeff1(nAlpha,iBasi), Coeff2(nBeta,jBasj), Coeff3(nGamma,kBask), Coeff4(nDelta,lBasl), & + PSO(iBasi*jBasj*kBask*lBasl,nPSO), Dij1(mDij,nDij), Dij2(mDij,nDij), Dkl1(mDkl,nDkl), & + Dkl2(mDkl,nDkl), Dik1(mDik,nDik), Dik2(mDik,nDik), Dil1(mDil,nDil), Dil2(mDil,nDil), Djk1(mDjk,nDjk), & + Djk2(mDjk,nDjk), Djl1(mDjl,nDjl), Djl2(mDjl,nDjl), Dan(*), Din(*) +real(kind=wp), intent(inout) :: Pren, Prem, Hess(nHess), WorkX(nWorkX), TwoHam(nTwo2), Buffer(nBuffer), rMOIN(nMOIN) +real(kind=wp), intent(out) :: Zeta(nZeta), ZInv(nZeta), P(nZeta,3), rKab(nZeta), Eta(nEta), EInv(nEta), Q(nEta,3), rKcd(nEta), & + xA(nZeta), xB(nZeta), xG(nEta), xD(nEta), xpre(nGamma*nDelta*nAlpha*nBeta), Work2(nWork2), & + Work3(nWork3), Work4(nWork4), Aux(nAux), Fin(nfin), Temp(nTemp) +logical(kind=iwp), intent(in) :: IfGrd(3,4), IfHss(4,3,4,3), Shijij, lgrad, ldot, n8, ltri, new_fock +logical(kind=iwp), intent(out) :: IfG(4) +integer(kind=iwp), intent(out) :: IndZet(nAlpha*nBeta), IndEta(nGamma*nDelta) +integer(kind=iwp) :: iCmpa, iDCRR(0:7), iDCRS(0:7), iDCRT(0:7), iDCRTS, IncEta, IncZet, Indx(3,4), ip, ip2, ipFT, ipS1, ipS2, & + ipTemp, iShlla, iStabM(0:7), iStabN(0:7), iuvwx(4), ix2, iy2, iz2, jCmpb, JndGrd(3,4,0:7), & + JndHss(4,3,4,3,0:7), jShllb, kCmpc, kShllc, la, lb, lc, lCmpd, ld, lDCR1, lDCR2, lEta, LmbdR, LmbdS, LmbdT, & + lShlld, lStabM, lStabN, lZeta, mab, mcd, mEta, mZeta, n, nabcd, nDCRR, nDCRS, nDCRT, nEta_Tot, nGr, niag, & + nijkl, nOp(4), nS1, nS2, nTe, nw3, nw3_2, nZeta_Tot +real(kind=wp) :: CoorAC(3,2), CoorM(3,4), dum1, dum2, dum3, Fact, FactNd, Time, u, v, w, x +logical(kind=iwp) :: ABeq, ABeqCD, AeqB, AeqC, CDeq, CeqD, first, JfGrd(3,4), JfHss(4,3,4,3), l_og, ldot2, no_integrals, Tr(4) +integer(kind=iwp), external :: ip_abMax, ip_IndZ, ip_Z, NrOpr +logical(kind=iwp), external :: EQ, lEmpty +external :: TERI1, ModU2, Cff2D + +! * +!*********************************************************************** +! * +call TwoEl_mck_Internal(Data1,Data2) + +! This is to allow type punning without an explicit interface +contains + +subroutine TwoEl_mck_Internal(Data1,Data2) + + real(kind=wp), target :: Data1(nZeta*nDArray+nDScalar,nData1), Data2(nEta*nDArray+nDScalar,nData2) + integer(kind=iwp), pointer :: iData1(:), iData2(:) + integer(kind=iwp) :: iCar, iCNT, iEta, iIrr, iZeta, lDCRR, lDCRS, lDCRT + !Bug in gcc 7: https://gcc.gnu.org/bugzilla/show_bug.cgi?id=94270 +# ifdef _WARNING_WORKAROUND_ + interface + subroutine Rysg2(iAnga,nRys,nT,Alpha,Beta,Gmma,Delta,Zeta,ZInv,nZeta,Eta,EInv,nEta,P,lP,Q,lQ,Coori,Coora,CoorAC,Array,nArray, & + Tvalue,ModU2,Cff2D,PAO,nPAO,Hess,nHess,IfGrd,IndGrd,IfHss,IndHss,nOp,iuvwx,IfG,mVec,Index_Out,lGrad,lHess,Tr) + use Definitions, only: wp, iwp + integer(kind=iwp), intent(in) :: iAnga(4), nRys, nT, nZeta, nEta, lP, lQ, nArray, nPAO, nHess, IndGrd(3,4,0:7), nOp(4), & + iuvwx(4) + real(kind=wp), intent(in) :: Alpha(nZeta), Beta(nZeta), Gmma(nEta), Delta(nEta), Zeta(nZeta), ZInv(nZeta), Eta(nEta), & + EInv(nEta), P(lP,3), Q(lQ,3), Coori(3,4), Coora(3,4), CoorAC(3,2), PAO(nT,nPAO) + real(kind=wp), intent(inout) :: Array(nArray), Hess(nHess) + external :: Tvalue, ModU2, Cff2D + logical(kind=iwp), intent(inout) :: IfGrd(3,4), IfHss(4,3,4,3), IfG(4), Tr(4) + integer(kind=iwp), intent(inout) :: IndHss(4,3,4,3,0:7) + integer(kind=iwp), intent(out) :: mVec, Index_Out(3,4) + logical(kind=iwp), intent(in) :: lGrad, lHess + end subroutine Rysg2 + end interface +# endif + + ! * + !********************************************************************* + ! * + ! PROLOGUE + ! * + !********************************************************************* + ! * + nGr = 0 + ABeq = EQ(Coor(1,1),Coor(1,2)) + CDeq = EQ(Coor(1,3),Coor(1,4)) + la = iAngV(1) + lb = iAngV(2) + lc = iAngV(3) + ld = iAngV(4) + ldot2 = ldot + iCmpa = iCmp(1) + jCmpb = iCmp(2) + kCmpc = iCmp(3) + lCmpd = iCmp(4) + iShlla = iShll(1) + jShllb = iShll(2) + kShllc = iShll(3) + lShlld = iShll(4) + IncZet = nAlpha*jPrInc + IncEta = nGamma*lPrInc + LmbdT = 0 + nijkl = iBasi*jBasj*kBask*lBasl + nabcd = iCmp(1)*iCmp(2)*iCmp(3)*iCmp(4) + mab = nTri_Elem1(la)*nTri_Elem1(lb) + mcd = nTri_Elem1(lc)*nTri_Elem1(ld) + + ! Scratch space for Fock Matrix construction + + ip = 1 + ipS1 = ip + nS1 = nijkl*nabcd + ip = ip+nS1 + ipS2 = ip + nS2 = max(nS1,nijkl+max(iBasi*lBasl,jBasj*lBasl,iBasi*kBask,jBasj*kBask)) + ip = ip+nS2 + ipFT = ip + ip = ip+nFT + ipTemp = ip + nTe = nijkl*nabcd + ip = ip+nTe + if (ip-1 > nTemp) then + write(u6,*) 'TwoEl_McK: ip-1 > nTemp' + write(u6,*) 'ip,nTemp=',ip,nTemp + call Abend() + end if +# ifdef _WARNING_WORKAROUND_ + ! Avoid some warnings about unset output arguments + Temp(nTemp) = One +# endif + + iuvwx(1) = dc(iStb)%nStab + iuvwx(2) = dc(jStb)%nStab + iuvwx(3) = dc(kStb)%nStab + iuvwx(4) = dc(lStb)%nStab + ! * + !********************************************************************* + ! * + ! - - - - - - END PROLOGUE - - - - - - + ! * + !********************************************************************* + ! * + ! Find the Double Coset Representatives for center A and B + + if (nIrrep == 1) then + nDCRR = 1 + iDCRR(0) = 0 + LmbdR = 1 + else + call DCR(LmbdR,dc(iStb)%iStab,dc(iStb)%nStab,dc(jStb)%iStab,dc(jStb)%nStab,iDCRR,nDCRR) + end if + u = real(dc(iStb)%nStab,kind=wp) + v = real(dc(jStb)%nStab,kind=wp) + + ! Find stabilizer for center A and B + + if (nIrrep == 1) then + lStabM = 1 + iStabM(0) = 0 + else + call Inter(dc(iStb)%iStab,dc(iStb)%nStab,dc(jStb)%iStab,dc(jStb)%nStab,iStabM,lStabM) + end if + ! * + !********************************************************************* + ! * + ! Find the Double Coset Representatives for center C and D. + + if (nIrrep == 1) then + nDCRS = 1 + iDCRS(0) = 0 + LmbdS = 1 + else + call DCR(LmbdS,dc(kStb)%iStab,dc(kStb)%nStab,dc(lStb)%iStab,dc(lStb)%nStab,iDCRS,nDCRS) + end if + w = real(dc(kStb)%nStab,kind=wp) + x = real(dc(lStb)%nStab,kind=wp) + + ! Find stabilizer for center C and D + + if (nIrrep == 1) then + lStabN = 1 + iStabN(0) = 0 + else + call Inter(dc(kStb)%iStab,dc(kStb)%nStab,dc(lStb)%iStab,dc(lStb)%nStab,iStabN,lStabN) + end if + ! * + !********************************************************************* + ! * + ! Find the Double Coset Representatives for the two charge distributions. + + if (nIrrep == 1) then + nDCRT = 1 + iDCRT(0) = 0 + LmbdT = 1 + else + call DCR(LmbdT,iStabM,lStabM,iStabN,lStabN,iDCRT,nDCRT) + end if + ! * + !********************************************************************* + ! * + ! Factor due to summation over DCR + + if (MolWgh == 1) then + Fact = real(nIrrep,kind=wp)/real(LmbdT,kind=wp) + else if (MolWgh == 0) then + Fact = u*v*w*x/real(nIrrep**3*LmbdT,kind=wp) + else + Fact = sqrt(u*v*w*x)/real(nIrrep*LmbdT,kind=wp) + end if + ! * + !********************************************************************* + ! * + nOp(1) = NrOpr(0) + CoorM(:,1) = Coor(:,1) + ! * + !********************************************************************* + ! * + ! - - - - Loop over first set + ! * + !********************************************************************* + ! * + do lDCRR=0,nDCRR-1 + nOp(2) = NrOpr(iDCRR(lDCRR)) + call OA(iDCRR(lDCRR),Coor(1:3,2),CoorM(1:3,2)) + AeqB = EQ(CoorM(1,1),CoorM(1,2)) + ! * + !******************************************************************* + ! * + ! - - - - Loop over second set + ! * + !******************************************************************* + ! * + do lDCRS=0,nDCRS-1 + Coorm(:,3) = Coor(:,3) + call OA(iDCRS(lDCRS),Coor(1:3,4),CoorM(1:3,4)) + CeqD = EQ(Coor(1,3),CoorM(1,4)) + ! * + !***************************************************************** + ! * + ! - - - - Loop over third set + ! * + !***************************************************************** + ! * + do lDCRT=nDCRT-1,0,-1 + + nOp(3) = NrOpr(iDCRT(lDCRT)) + nOp(4) = NrOpr(ieor(iDCRT(lDCRT),iDCRS(lDCRS))) + + iDCRTS = ieor(iDCRT(lDCRT),iDCRS(lDCRS)) + call OA(iDCRTS,Coor(1:3,4),CoorM(1:3,4)) + call OA(iDCRT(lDCRT),Coor(1:3,3),CoorM(1:3,3)) + + AeqC = EQ(CoorM(1,1),CoorM(1,3)) + ABeqCD = AeqB .and. CeqD .and. AeqC + ! No contribution to geometric derivatives from one-center integrals + if (ABeqCD) cycle + + ! Find the proper centers to start of with the angular + ! momentum on. If la == lb there will exist an + ! ambiguity to which center that angular momentum should + ! be accumulated on. In that case we will use A and C of + ! the order as defined by the basis functions types. + + if (iAngV(1) >= iAngV(2)) then + CoorAC(:,1) = CoorM(:,1) + else + CoorAC(:,1) = CoorM(:,2) + end if + if (iAngV(3) >= iAngV(4)) then + CoorAC(:,2) = CoorM(:,3) + else + CoorAC(:,2) = CoorM(:,4) + end if + + ! Calculate the desymmetrized two-electron density matrix in cartesian AO base. + + call Timing(dum1,Time,dum2,dum3) + if (ldot2) call TwoDns(iAngV,iCmp,shijij,ishll,ishell,iAO,nOp,iBasi,jBasj,kBask,lBasl,Aux,nAux,Work2,nWork2,Work3,nWork3, & + Work4,nWork4,PSO,nPSO,Fact) + + call Timing(dum1,Time,dum2,dum3) + CpuStat(nTwoDens) = CpuStat(nTwoDens)+Time + + !--------------------------------------------------------------* + ! + ! Loops to partition the primitives + ! + !--------------------------------------------------------------* + lDCR1 = NrOpr(iDCRR(lDCRR))+1 + lDCR2 = NrOpr(iDCRS(lDCRS))+1 + ix2 = iPhase(1,iDCRT(lDCRT)) + iy2 = iPhase(2,iDCRT(lDCRT)) + iz2 = iPhase(3,iDCRT(lDCRT)) + + call c_f_pointer(c_loc(Data1(ip_IndZ(1,nZeta),lDCR1)),iData1,[nZeta+1]) + call c_f_pointer(c_loc(Data2(ip_IndZ(1,nEta),lDCR2)),iData2,[nEta+1]) + nZeta_Tot = iData1(nZeta+1) + nEta_Tot = iData2(nEta+1) + + no_integrals = .true. + first = .true. + nGr = 0 + do iZeta=1,nZeta_Tot,IncZet + mZeta = min(IncZet,nZeta_Tot-iZeta+1) + ! Check that subblock of contraction matrix has non-zero elements. + if (lEmpty(Coeff2,nBeta,nBeta,jBasj)) cycle + do iEta=1,nEta_Tot,IncEta + mEta = min(IncEta,nEta_Tot-iEta+1) + ! Check that subblock of contraction matrix has non-zero elements. + if (lEmpty(Coeff4,nDelta,nDelta,lBasl)) cycle + Pren = Pren+real(mab*mcd*mZeta*mEta,kind=wp) + !----------------------------------------------------------* + ! + ! Fix the control matrixes for derivatives + ! and try to use translation invariance as + ! efficient as possible. + ! + ! OBS DETTA SKALL FLYTTAS UT UR INRE LOOPEN + ! + !----------------------------------------------------------* + JfHss(:,:,:,:) = IfHss + JfGrd(:,:) = IfGrd + ifg(:) = .true. + Tr(:) = .false. + JndHss(:,:,:,:,0:nIrrep-1) = IndHss(:,:,:,:,0:nIrrep-1) + JndGrd(:,:,0:nIrrep-1) = IndGrd(:,:,0:nIrrep-1) + + ! Delete one center that should be calculated with translation invariance + + call Translation(ifg,jfgrd,jfhss,tr,jndgrd,jndhss,coorm,nirrep,indgrd,indhss) + + if (.not. ldot) then + JfHss(:,:,:,:) = .false. + JndHss(:,:,:,:,:) = 0 + end if + !----------------------------------------------------------* + ! PRE PRESCREENING * + !----------------------------------------------------------* + + lZeta = mZeta + lEta = mEta + + ! Decontract the 2nd order density matrix + + ! Work4->Work2 Work3:scratch + call Timing(dum1,Time,dum2,dum3) + if (ldot2) call Tcrtnc_h(Coeff1,nAlpha,iBasi,Coeff2,nBeta,jBasj,Coeff3,nGamma,kBask,Coeff4,nDelta,lBasl,Work4,mab*mcd, & + Work3,nWork3/2,Work2,iData1(iZeta:iZeta+mZeta-1),mZeta,iData2(iEta:iEta+mEta-1),mEta) + call Timing(dum1,Time,dum2,dum3) + CPUStat(nTwoDens) = CPUStat(nTwoDens)+Time + + ! Transfer k2 data and prescreen + + ! Work2:PAO-> Work2 + ! Work3 Scratch + call Timing(dum1,Time,dum2,dum3) + call Screen_mck(Work2,Work3,mab*mcd,nZeta,nEta,mZeta,mEta,lZeta,lEta,Zeta,ZInv,P,xA,xB,rKab, & + Data1(ip_Z(iZeta,nZeta),lDCR1),iData1(iZeta:iZeta+mZeta-1),Data1(ip_abMax(nZeta),ldcr1),Eta,EInv,Q,xG, & + xD,rKcd,Data2(ip_Z(iEta,nEta),lDCR2),iData2(iEta:iEta+mEta-1),Data2(ip_abMax(nEta),ldcr2),xpre,1,1,1, & + ix2,iy2,iz2,CutInt,PreScr,IndZet,IndEta,ldot2) + call Timing(dum1,Time,dum2,dum3) + CPUStat(nScreen) = CPUStat(nScreen)+Time + + Prem = Prem+real(mab*mcd*lZeta*lEta,kind=wp) + if (lZeta*lEta /= 0) no_integrals = .false. + if (lZeta*lEta == 0) cycle + + ! Compute integral derivative and accumulate + ! contribution to the molecular gradient. + + ! Work2:PAO + ! Work3:Work area The PO integrals are stored in the begining of Work3 + + call Timing(dum1,Time,dum2,dum3) + + call Rysg2(iAngV,nRys,lZeta*lEta,xA,xB,xG,xD,Zeta,ZInv,lZeta,Eta,EInv,lEta,P,nZeta,Q,nEta,CoorM,CoorM,CoorAC,Work3, & + nWork3,TERI1,ModU2,Cff2D,Work2,mab*mcd,Hess,nHess,JfGrd,JndGrd,JfHss,JndHss,nOp,iuvwx,IfG,nGr,Indx,lgrad, & + ldot,Tr) + call Timing(dum1,Time,dum2,dum3) + CPUStat(nIntegrals) = CPUStat(nIntegrals)+Time + + ! Work3 AO + ! Work3_3 Scratch + ! -> Work3_2 + !----------------------------------------------------------* + ! + ! Transform integrals to AO base + ! + !----------------------------------------------------------* + ip2 = nGr*mab*mcd*lZeta*lEta+1 + call Timing(dum1,Time,dum2,dum3) + call Cntrct_mck(First,Coeff1,nAlpha,iBasi,Coeff2,nBeta,jBasj,Coeff3,nGamma,kBask,Coeff4,nDelta,lBasl,Work3, & + nGr*mab*mcd,Work3(ip2),nwork3-ip2,xpre,WorkX,nWorkX,lZeta*lEta,IndZet,nZeta,lZeta,IndEta,nEta,lEta) + end do + end do + + ! Mark which derivatives should be calculated with translation invariance. + + if (nGr == 0) cycle + do iCNT=1,4 + if (Tr(iCnt)) then + do iCar=1,3 + l_og = .false. + do iIrr=0,nIrrep-1 + l_og = l_og .or. (indgrd(iCar,iCnt,iIrr) /= 0) + end do + if (l_og) Indx(iCar,iCnt) = -1 + end do + end if + end do + + if (MolWgh == 1) then + FactNd = real(nIrrep,kind=wp)/real(LmbdT,kind=wp) + else if (MolWgh == 0) then + FactNd = u*v*w*x/real(nIrrep**3*LmbdT,kind=wp) + else + factNd = sqrt(u*v*w*x)/real(nirrep*lmbdt,kind=wp) + end if + + if (FactNd /= One) then + n = nGr*mab*mcd*nijkl + WorkX(1:n) = FactNd*WorkX(1:n) + end if + + !--------------------------------------------------------------* + ! + ! Transpose abcd,g,IJKL -> bcd,g,IJKL,A Work3 -> Work3_2 + ! + !--------------------------------------------------------------* + + niag = nijkl*nTri_Elem1(lb)*mcd*nGr + call CrSph_mck(WorkX,niag,nTri_Elem1(la),RSph(ipSph(la)),la,Shells(iShlla)%Transf,Shells(iShlla)%Prjct,Work3,iCmpa) + nw3 = niag*iCmpa + ip2 = 1+nw3 + + !--------------------------------------------------------------* + ! + ! Transpose bcd,g,IJKL,A -> cd,g,IJKL,AB Work3_2->Work3 + ! + !--------------------------------------------------------------* + + niag = nijkl*mcd*nGr*iCmpa + nw3_2 = niag*jCmpb + if (nw3+nw3_2 > nWork3) then + write(u6,*) '1: nw3+nw3_2 > nWork3' + call Abend() + end if + call CrSph_mck(Work3,niag,nTri_Elem1(lb),RSph(ipSph(lb)),lb,Shells(jShllb)%Transf,Shells(jShllb)%Prjct,Work3(ip2),jCmpb) + + !--------------------------------------------------------------* + ! + ! Transpose cd,g,IJKL,AB -> d,g,IJKL,ABC Work3->Work3_2 + ! + !--------------------------------------------------------------* + + niag = nijkl*nGr*nTri_Elem1(ld)*iCmpa*jCmpb + call CrSph_mck(Work3(ip2),niag,nTri_Elem1(lc),RSph(ipSph(lc)),lc,Shells(kShllc)%Transf,Shells(kShllc)%Prjct,Work3,kCmpc) + if (niag*kCmpc > nw3) then + write(u6,*) 'niag*kCmpc > nw3' + call Abend() + end if + nw3 = niag*kCmpc + ip2 = nw3+1 + + !--------------------------------------------------------------* + ! + ! Transpose d,g,IJKL,ABC -> g,IJKL,ABCD Work3_2->Work3 + ! + !--------------------------------------------------------------* + + niag = nijkl*nGr*iCmpa*jCmpb*kCmpc + nw3_2 = niag*lCmpd + if (nw3+nw3_2 > nWork3) then + write(u6,*) '2: nw3+nw3_2 > nWork3' + call Abend() + end if + call CrSph_mck(Work3,niag,nTri_Elem1(ld),RSph(ipSph(ld)),ld,Shells(lShlld)%Transf,Shells(lShlld)%Prjct,Work3(ip2),lCmpd) + + !--------------------------------------------------------------* + ! + ! Transpose g,IJKL,ABCD -> IJKL,ABCD,g Work3->Buffer + ! + !--------------------------------------------------------------* + + niag = nijkl*iCmpa*jCmpb*kCmpc*lCmpd + call DGetMO(Work3(ip2),nGr,nGr,niag,Fin,niag) + + ! DEBUG (calculates gradient from transformed integrals) + + call Timing(dum1,Time,dum2,dum3) + CPUStat(nTrans) = CPUStat(nTrans)+Time + + !--------------------------------------------------------------* + ! + ! Send the integrals to clrbuffer for construction of + ! + !--------------------------------------------------------------* + + call ClrBuf(idcrr(ldcrr),idcrs(ldcrs),idcrt(ldcrt),nGr,Shijij,iAngV,iCmpi,iCmp,iShll,iShell,iShell,iBasi,jBasj,kBask, & + lBasl,Dij1,Dij2,mDij,nDij,Dkl1,Dkl2,mDkl,nDkl,Dik1,Dik2,mDik,nDik,Dil1,Dil2,mDil,nDil,Djk1,Djk2,mDjk,nDjk, & + Djl1,Djl2,mDjl,nDjl,fin,nfin,Temp(ipFT),nFT,Temp(ipS1),nS1,Temp(ipS2),nS2,Temp(ipTemp),nTe,TwoHam,nTwo2, & + JndGrd,Indx,iao,iaost,iuvwx,n8,ltri,moip,nAcO,rMoin,nmoin,ntemp,Buffer,nOp,Din,Dan,new_fock) + + end do + + end do + + end do + ! * + !********************************************************************* + ! * + + return + +end subroutine Twoel_Mck_Internal + +end subroutine Twoel_Mck diff -Nru openmolcas-22.02/src/mckinley/wrdisk.f openmolcas-22.10/src/mckinley/wrdisk.f --- openmolcas-22.02/src/mckinley/wrdisk.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/wrdisk.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,348 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SubRoutine WrDisk(rIn,nrIn,jDisp,iIrrep) -* -* Sorry about this litle subroutine -* The reason is just that right now I want to use AO for SCF -* and MO for RASSCF, this will hopefully be changed, but if you -* see this mess before that I apologize -* - use Basis_Info, only: nBas - use pso_stuff - use Symmetry_Info, only: nIrrep, iOper - Implicit Real*8 (a-h,o-z) -#include "Molcas.fh" -#include "buffer.fh" -#include "etwas.fh" -#include "real.fh" -#include "stdalloc.fh" -#include "disp.fh" -#include "disp2.fh" -#include "print.fh" - Real*8 rIn(nrIn) - Character*8 Label - Integer ip(0:7),ip2(0:7),nA(0:7),ipCM(0:7) - Real*8, Allocatable:: Act(:), InAct(:), Out(:), TempX(:), TempY(:) -* * -************************************************************************ -* * - itri(i,j)=Max(i,j)*(Max(i,j)-1)/2+Min(i,j) -* * -************************************************************************ -* * - If (Show) Then - Write (6,*) - Write (6,*) '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<' - Write (6,*) - Write (6,*) 'jDisp=',jDisp - End If - nin=0 - nIn2=0 - nna=0 - ipCC=1 - Do jIrrep=0,nIrrep-1 - kIrrep=NrOpr(iEOr(iOper(jIrrep),iOper(iIrrep))) - If (kIrrep.lt.jIrrep) Then - ip(jIrrep)=nIn - nIn=nIN+nBas(kIrrep)*nBas(jIrrep) - Else If (kIrrep.eq.jIrrep) Then - ip(jIrrep)=nIn - nIn=nIN+nBas(kIrrep)*(1+nBas(jIrrep))/2 - End If - ip2(kIrrep)=nIn2 - nIn2=nIn2+nBas(kIrrep)*nBas(jIrrep) - nA(jIrrep)=nnA - nnA=nnA+nAsh(jIrrep) - ipCM(jIrrep)=ipCC - ipCC=ipCC+nBas(jIrrep)**2 -#ifdef __INTEL_COMPILER -* -* To avoid error in intel optimization -O3 -* - If (.False.) Write (6,*) ip(jIrrep) -#endif - End Do -* * -************************************************************************ -* * - Call mma_allocate(Act,nIn2,Label='Act') - Act(:)=Zero - Call mma_allocate(InAct,nIn2,Label='InAct') - InAct(:)=Zero - Call mma_allocate(Out,nIn2,Label='Out') - Out(:)=Zero - Call mma_allocate(TempX,nIn2,Label='TempX') - Call mma_allocate(TempY,nIn2,Label='TempY') -* * -************************************************************************ -* * -* Fock1 -* - If (Show) Then - Write (6,*) - Write (6,*) 'Fock1' - Write (6,*) - End If - Do jIrrep=0,nIrrep-1 - kIrrep=NrOpr(iEOr(iOper(jIrrep),iOper(iIrrep))) - If (nBAs(jIrrep).gt.0.and.nbas(kIrrep).gt.0) Then - If (kIrrep.lt.jIrrep) Then - Call DGEMM_('N','N', - & nBas(jIrrep),nBas(kIrrep),nBas(kIrrep), - & One,rIn(ipDisp(jDisp)+ip(jIrrep)),nBas(jIrrep), - & CMO(ipCM(kIrrep),1),nBas(kIrrep), - & Zero,TempY,nBas(jIrrep)) - Call DGEMM_('T','N', - & nBas(jIrrep),nBas(kirrep),nBas(jIrrep), - & One,CMO(ipCM(jIrrep),1),nBas(jIrrep), - & TempY,nBas(jIrrep), - & Zero,Act(1+ip2(kIrrep)),nBas(jIrrep)) - If (Show) Then - Write (6,*) - Write (6,*) 'ipDisp(jDisp),ip(jIrrep)=', - & ipDisp(jDisp),ip(jIrrep) - Call RecPrt('ipDisp',' ', - & rIn(ipDisp(jDisp)+ip(jIrrep)), - & nBas(jIrrep),nBas(kIrrep)) - Write (6,'(A,G20.10)') 'ipDisp:', - & DDot_(nBas(jIrrep)*nBas(kIrrep), - & rIn(ipDisp(jDisp)+ip(jIrrep)),1, - & rIn(ipDisp(jDisp)+ip(jIrrep)),1) - Write (6,'(A,G20.10)') 'ipCM(kIrrep):', - & DDot_(nBas(kIrrep)*nBas(kIrrep), - & CMO(ipCM(kIrrep),1),1, - & CMO(ipCM(kIrrep),1),1) - Write (6,'(A,G20.10)') 'ipCM(jIrrep):', - & DDot_(nBas(jIrrep)*nBas(jIrrep), - & CMO(ipCM(jIrrep),1),1, - & CMO(ipCM(jIrrep),1),1) - End If - Call DGetMO(Act(1+ip2(kIrrep)),Nbas(jIrrep), - & nbas(jIrrep),nBas(kIrrep), - & Act(1+ip2(jIrrep)),nBas(kIrrep)) - Else If (kIrrep.eq.jIrrep) Then - Call Square(rIn(ipDisp(jDisp)+ip(jIrrep)),TempX, - & 1,nBas(kirrep),nBas(kirrep)) - Call DGEMM_('N','N', - & nBas(jIrrep),nBas(kIrrep),nBas(kIrrep), - & One,TempX,nBas(jIrrep), - & CMO(ipCM(kIrrep),1),nBas(kIrrep), - & Zero,TempY,nBas(jIrrep)) - Call DGEMM_('T','N', - & nBas(jIrrep),nBas(kirrep),nBas(jIrrep), - & One,CMO(ipCM(jIrrep),1),nBas(jIrrep), - & TempY,nBas(jIrrep), - & Zero,Act(1+ip2(jIrrep)),nBas(jIrrep)) - End If - If (Show) Then - Write (6,*) 'jIrrep,kIrrep=',jIrrep,kIrrep - Write (6,'(A,G20.10)') 'Act:', - & DDot_(nIn2,Act,1,Act,1) - End If - End If - End Do -* * -************************************************************************ -* * -* - If (nMethod.eq.RASSCF) Then -* -* Fock2 -* - If (Show) Then - Write (6,*) - Write (6,*) 'Fock2' - Write (6,*) - End If - Do jIrrep=0,nIrrep-1 - kIrrep=NrOpr(iEOr(iOper(jIrrep),iOper(iIrrep))) - If (nBas(jIrrep).gt.0.and.nBas(kIrrep).gt.0) Then - If (kIrrep.eq.jIrrep) Then - Call Square(rIn(ipDisp2(jDisp)+ip(jIrrep)),TempX, - & 1,nBas(kirrep),nBas(kirrep)) - Call DGEMM_('N','N', - & nBas(jIrrep),nBas(kIrrep),nBas(kIrrep), - & One,TempX,nBas(jIrrep), - & CMO(ipCM(kIrrep),1),nBas(kIrrep), - & Zero,TempY,nBas(jIrrep)) - Call DGEMM_('T','N', - & nBas(jIrrep),nBas(kirrep),nBas(jIrrep), - & One,CMO(ipCM(jIrrep),1),nBas(jIrrep), - & TempY,nBas(jIrrep), - & Zero,InAct(1+ip2(jIrrep)),nBas(jIrrep)) - Else If (kirrep.lt.jirrep) Then - Call DGEMM_('N','N', - & nBas(jIrrep),nBas(kIrrep),nBas(kIrrep), - & One,rin(ipDisp2(jDisp)+ip(jIrrep)),nBas(jIrrep), - & CMO(ipCM(kIrrep),1),nBas(kIrrep), - & Zero,TempY,nBas(jIrrep)) - Call DGEMM_('T','N', - & nBas(jIrrep),nBas(kirrep),nBas(jIrrep), - & One,CMO(ipCM(jIrrep),1),nBas(jIrrep), - & TempY,nBas(jIrrep), - & Zero,InAct(1+ip2(kIrrep)),nBas(jIrrep)) - Call DGetMO(InAct(1+ip2(kIrrep)),Nbas(jIrrep), - & nBas(jIrrep),nBas(kIrrep), - & InAct(1+ip2(jIrrep)),nBas(kIrrep)) - End If - If (Show) Then - Write (6,*) 'jIrrep,kIrrep=',jIrrep,kIrrep - Write (6,'(A,G20.10)') 'InAct:', - & DDot_(nIn2,InAct,1,InAct,1) - End If - End If - End Do -* * -************************************************************************ -* * -* Fock Tot -* - If (Show) Then - Write (6,*) - Write (6,*) 'Fock Tot' - Write (6,*) - End If - iii=0 - Do jIrrep=0,nIrrep-1 - kIrrep=NrOpr(iEOr(iOper(jIrrep),iOper(iIrrep))) -* - If (nBas(jIrrep)*nIsh(kIrrep).gt.0) Then - Call DaXpY_(nIsh(kIrrep)*nBas(jIrrep),2.0d0, - & Act(1+ip2(kIrrep)),1, - & Out(1+ip2(kIrrep)),1) - Call DaXpY_(nIsh(kIrrep)*nBas(jIrrep),2.0d0, - & InAct(1+ip2(kIrrep)),1, - & Out(1+ip2(kIrrep)),1) - End If -* - If (nBas(jIrrep).gt.0) Then - Do jAsh=1,nAsh(kIrrep) - Do kAsh=1,nAsh(kIrrep) - rDe= G1(iTri(nA(kIrrep)+jAsh,nA(kIrrep)+kAsh),1) - ipOut=1+ip2(kIrrep)+nIsh(kIrrep)*nBas(jIrrep)+ - & nBas(jIrrep)*(kAsh-1) - ipIn1=1+ip2(kIrrep) - & +nBas(jIrrep)*(jAsh-1+nIsh(kIrrep)) - Call DaXpY_(nBas(jIrrep),rde,InAct(ipIn1),1, - & Out(ipOut),1) - End Do - End Do - End If -* - If (nBas(jIrrep)*nAsh(kIrrep).gt.0) Then - ipOut=1+ip2(kIrrep)+nIsh(kIrrep)*nBas(jIrrep) - If (Show) Then - Write (6,*) 'jIrrep,kIrrep=',jIrrep,kIrrep - Write (6,'(A,G20.10)') 'ipDisp3:', - & DDot_(nBas(jIrrep)*nAsh(kIrrep), - & rin(ipDisp3(jDisp)+iii),1, - & rin(ipDisp3(jDisp)+iii),1) - End If - Call DGEMM_('T','N', - & nBas(jIrrep),nAsh(kIrrep),nBas(jIrrep), - & One,CMO(ipCM(jIrrep),1),nBas(jIrrep), - & rin(ipDisp3(jDisp)+iii),nBas(jIrrep), - & Zero,TempY,nBas(jIrrep)) - Call DaXpY_(nAsh(kIrrep)*nBas(jIrrep),One, - & TempY,1, - & Out(ipOut),1) - iii=iii+nBas(jIrrep)*nAsh(kIrrep) - End If -#ifdef __INTEL_COMPILER - If (.False.) Write (6,*) kIrrep, iii -#endif - If (Show) Then - Write (6,*) 'jIrrep,kIrrep=',jIrrep,kIrrep - Write (6,'(A,G20.10)') 'Out:', - & DDot_(nIn2,Out,1,Out,1) - End If - End Do - If (Show) Write (6,*) -* * -************************************************************************ -* * - irc=-1 - iopt=0 - Label='TOTAL' - Call dWrMck(irc,iopt,Label,jdisp,Out,2**iIrrep) - If (iRc.ne.0) Then - Write (6,*) 'WrDisk: Error writing to MCKINT' - Write (6,'(A,A)') 'Label=',Label - Call Abend() - End If - If (Show) Then - Write (6,'(A,G20.10)') 'TOTAL:', - & DDot_(nIn2,Out,1,Out,1) - End If -* - irc=-1 - iopt=0 - Label='INACTIVE' - Call dWrMck(irc,iopt,Label,jdisp,InAct,2**iIrrep) - If (iRc.ne.0) Then - Write (6,*) 'WrDisk: Error writing to MCKINT' - Write (6,'(A,A)') 'Label=',Label - Call Abend() - End If - If (Show) Then - Write (6,'(A,G20.10)') 'INACTIVE:', - & DDot_(nIn2,InAct,1,InAct,1) - Write (6,*) - End If -* - irc=-1 - iopt=0 - Label='MOPERT' - nt=nna*(nna+1)/2 - nt=nt*(nt+1)/2 - Call dWrMck(irc,iopt,Label,jdisp,rIn(ipMO(jdisp,1)),2**iIrrep) - If (iRc.ne.0) Then - Write (6,*) 'WrDisk: Error writing to MCKINT' - Write (6,'(A,A)') 'Label=',Label - Call Abend() - End If -* * -************************************************************************ -* * -* SCF case -* - Else -* * -************************************************************************ -* * - irc=-1 - iopt=0 - Label='TOTAL' - Call dWrMck(irc,iopt,Label,jdisp,Act,2**iIrrep) - If (iRc.ne.0) Then - Write (6,*) 'WrDisk: Error writing to MCKINT' - Write (6,'(A,A)') 'Label=',Label - Call Abend() - End If - If (Show) Then - Write (6,'(A,G20.10)') 'TOTAL:', - & DDot_(nIn2,Act,1,Act,1) - End If -* - End If -* * -************************************************************************ -* * - Call mma_deallocate(TempY) - Call mma_deallocate(TempX) - Call mma_deallocate(Out) - Call mma_deallocate(InAct) - Call mma_deallocate(Act) -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/mckinley/wrdisk.F90 openmolcas-22.10/src/mckinley/wrdisk.F90 --- openmolcas-22.02/src/mckinley/wrdisk.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/wrdisk.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,288 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine WrDisk(rIn,nrIn,jDisp,iIrrep) +! Sorry about this litle subroutine +! The reason is just that right now I want to use AO for SCF +! and MO for RASSCF, this will hopefully be changed, but if you +! see this mess before that I apologize + +use McKinley_global, only: ipDisp, ipDisp2, ipDisp3, ipMO, nMethod, RASSCF +use Index_Functions, only: iTri, nTri_Elem +use Basis_Info, only: nBas +use pso_stuff, only: CMO, G1 +use Symmetry_Info, only: iOper, nIrrep +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two +use Definitions, only: wp, iwp, u6, r8 + +implicit none +integer(kind=iwp), intent(in) :: nrIn, jDisp, iIrrep +real(kind=wp), intent(in) :: rIn(nrIn) +#include "etwas.fh" +#include "print.fh" +integer(kind=iwp) :: iii, iopt, ip(0:7), ip2(0:7), ipCC, ipCM(0:7), ipIn1, ipOut, irc, jAsh, jIrrep, kAsh, kIrrep, nA(0:7), nin, & + nIn2, nna +real(kind=wp) :: rDe +integer(kind=iwp) :: n +character(len=8) :: Label +real(kind=wp), allocatable :: Act(:), InAct(:), rOut(:), TempX(:), TempY(:) +integer(kind=iwp), external :: NrOpr +real(kind=r8), external :: DDot_ + +! * +!*********************************************************************** +! * +if (Show) then + write(u6,*) + write(u6,*) '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<' + write(u6,*) + write(u6,*) 'jDisp=',jDisp +end if +nin = 0 +nIn2 = 0 +nna = 0 +ipCC = 1 +do jIrrep=0,nIrrep-1 + kIrrep = NrOpr(ieor(iOper(jIrrep),iOper(iIrrep))) + if (kIrrep < jIrrep) then + ip(jIrrep) = nIn + nIn = nIN+nBas(kIrrep)*nBas(jIrrep) + else if (kIrrep == jIrrep) then + ip(jIrrep) = nIn + nIn = nIN+nTri_Elem(nBas(kIrrep)) + end if + ip2(kIrrep) = nIn2 + nIn2 = nIn2+nBas(kIrrep)*nBas(jIrrep) + nA(jIrrep) = nnA + nnA = nnA+nAsh(jIrrep) + ipCM(jIrrep) = ipCC + ipCC = ipCC+nBas(jIrrep)**2 +# ifdef __INTEL_COMPILER + ! To avoid error in intel optimization -O3 + if (.false.) write(u6,*) ip(jIrrep) +# endif +end do +! * +!*********************************************************************** +! * +call mma_allocate(Act,nIn2,Label='Act') +Act(:) = Zero +call mma_allocate(InAct,nIn2,Label='InAct') +InAct(:) = Zero +call mma_allocate(rOut,nIn2,Label='rOut') +rOut(:) = Zero +call mma_allocate(TempX,nIn2,Label='TempX') +call mma_allocate(TempY,nIn2,Label='TempY') +! * +!*********************************************************************** +! * +! Fock1 + +if (Show) then + write(u6,*) + write(u6,*) 'Fock1' + write(u6,*) +end if +do jIrrep=0,nIrrep-1 + kIrrep = NrOpr(ieor(iOper(jIrrep),iOper(iIrrep))) + if ((nBAs(jIrrep) > 0) .and. (nbas(kIrrep) > 0)) then + if (kIrrep < jIrrep) then + call DGEMM_('N','N',nBas(jIrrep),nBas(kIrrep),nBas(kIrrep),One,rIn(ipDisp(jDisp)+ip(jIrrep)),nBas(jIrrep), & + CMO(ipCM(kIrrep),1),nBas(kIrrep),Zero,TempY,nBas(jIrrep)) + call DGEMM_('T','N',nBas(jIrrep),nBas(kirrep),nBas(jIrrep),One,CMO(ipCM(jIrrep),1),nBas(jIrrep),TempY,nBas(jIrrep),Zero, & + Act(1+ip2(kIrrep)),nBas(jIrrep)) + if (Show) then + write(u6,*) + write(u6,*) 'ipDisp(jDisp),ip(jIrrep)=',ipDisp(jDisp),ip(jIrrep) + call RecPrt('ipDisp',' ',rIn(ipDisp(jDisp)+ip(jIrrep)),nBas(jIrrep),nBas(kIrrep)) + write(u6,'(A,G20.10)') 'ipDisp:', & + DDot_(nBas(jIrrep)*nBas(kIrrep),rIn(ipDisp(jDisp)+ip(jIrrep)),1,rIn(ipDisp(jDisp)+ip(jIrrep)),1) + write(u6,'(A,G20.10)') 'ipCM(kIrrep):',DDot_(nBas(kIrrep)*nBas(kIrrep),CMO(ipCM(kIrrep),1),1,CMO(ipCM(kIrrep),1),1) + write(u6,'(A,G20.10)') 'ipCM(jIrrep):',DDot_(nBas(jIrrep)*nBas(jIrrep),CMO(ipCM(jIrrep),1),1,CMO(ipCM(jIrrep),1),1) + end if + call DGetMO(Act(1+ip2(kIrrep)),Nbas(jIrrep),nbas(jIrrep),nBas(kIrrep),Act(1+ip2(jIrrep)),nBas(kIrrep)) + else if (kIrrep == jIrrep) then + call Square(rIn(ipDisp(jDisp)+ip(jIrrep)),TempX,1,nBas(kirrep),nBas(kirrep)) + call DGEMM_('N','N',nBas(jIrrep),nBas(kIrrep),nBas(kIrrep),One,TempX,nBas(jIrrep),CMO(ipCM(kIrrep),1),nBas(kIrrep),Zero, & + TempY,nBas(jIrrep)) + call DGEMM_('T','N',nBas(jIrrep),nBas(kirrep),nBas(jIrrep),One,CMO(ipCM(jIrrep),1),nBas(jIrrep),TempY,nBas(jIrrep),Zero, & + Act(1+ip2(jIrrep)),nBas(jIrrep)) + end if + if (Show) then + write(u6,*) 'jIrrep,kIrrep=',jIrrep,kIrrep + write(u6,'(A,G20.10)') 'Act:',DDot_(nIn2,Act,1,Act,1) + end if + end if +end do +! * +!*********************************************************************** +! * + +if (nMethod == RASSCF) then + + ! Fock2 + + if (Show) then + write(u6,*) + write(u6,*) 'Fock2' + write(u6,*) + end if + do jIrrep=0,nIrrep-1 + kIrrep = NrOpr(ieor(iOper(jIrrep),iOper(iIrrep))) + if ((nBas(jIrrep) > 0) .and. (nBas(kIrrep) > 0)) then + if (kIrrep == jIrrep) then + call Square(rIn(ipDisp2(jDisp)+ip(jIrrep)),TempX,1,nBas(kirrep),nBas(kirrep)) + call DGEMM_('N','N',nBas(jIrrep),nBas(kIrrep),nBas(kIrrep),One,TempX,nBas(jIrrep),CMO(ipCM(kIrrep),1),nBas(kIrrep),Zero, & + TempY,nBas(jIrrep)) + call DGEMM_('T','N',nBas(jIrrep),nBas(kirrep),nBas(jIrrep),One,CMO(ipCM(jIrrep),1),nBas(jIrrep),TempY,nBas(jIrrep),Zero, & + InAct(1+ip2(jIrrep)),nBas(jIrrep)) + else if (kirrep < jirrep) then + call DGEMM_('N','N',nBas(jIrrep),nBas(kIrrep),nBas(kIrrep),One,rIn(ipDisp2(jDisp)+ip(jIrrep)),nBas(jIrrep), & + CMO(ipCM(kIrrep),1),nBas(kIrrep),Zero,TempY,nBas(jIrrep)) + call DGEMM_('T','N',nBas(jIrrep),nBas(kirrep),nBas(jIrrep),One,CMO(ipCM(jIrrep),1),nBas(jIrrep),TempY,nBas(jIrrep),Zero, & + InAct(1+ip2(kIrrep)),nBas(jIrrep)) + call DGetMO(InAct(1+ip2(kIrrep)),Nbas(jIrrep),nBas(jIrrep),nBas(kIrrep),InAct(1+ip2(jIrrep)),nBas(kIrrep)) + end if + if (Show) then + write(u6,*) 'jIrrep,kIrrep=',jIrrep,kIrrep + write(u6,'(A,G20.10)') 'InAct:',DDot_(nIn2,InAct,1,InAct,1) + end if + end if + end do + ! * + !********************************************************************* + ! * + ! Fock Tot + + if (Show) then + write(u6,*) + write(u6,*) 'Fock Tot' + write(u6,*) + end if + iii = 0 + do jIrrep=0,nIrrep-1 + kIrrep = NrOpr(ieor(iOper(jIrrep),iOper(iIrrep))) + + if (nBas(jIrrep)*nIsh(kIrrep) > 0) then + n = nIsh(kIrrep)*nBas(jIrrep) + rOut(ip2(kIrrep)+1:ip2(kIrrep)+n) = rOut(ip2(kIrrep)+1:ip2(kIrrep)+n)+ & + Two*(Act(ip2(kIrrep)+1:ip2(kIrrep)+n)+InAct(ip2(kIrrep)+1:ip2(kIrrep)+n)) + end if + + if (nBas(jIrrep) > 0) then + do jAsh=1,nAsh(kIrrep) + do kAsh=1,nAsh(kIrrep) + rDe = G1(iTri(nA(kIrrep)+jAsh,nA(kIrrep)+kAsh),1) + ipOut = 1+ip2(kIrrep)+nIsh(kIrrep)*nBas(jIrrep)+nBas(jIrrep)*(kAsh-1) + ipIn1 = 1+ip2(kIrrep)+nBas(jIrrep)*(jAsh-1+nIsh(kIrrep)) + rOut(ipOut:ipOut+nBas(jIrrep)-1) = rOut(ipOut:ipOut+nBas(jIrrep)-1)+rde*InAct(ipIn1:ipIn1+nBas(jIrrep)-1) + end do + end do + end if + + if (nBas(jIrrep)*nAsh(kIrrep) > 0) then + ipOut = 1+ip2(kIrrep)+nIsh(kIrrep)*nBas(jIrrep) + if (Show) then + write(u6,*) 'jIrrep,kIrrep=',jIrrep,kIrrep + write(u6,'(A,G20.10)') 'ipDisp3:',DDot_(nBas(jIrrep)*nAsh(kIrrep),rIn(ipDisp3(jDisp)+iii),1,rIn(ipDisp3(jDisp)+iii),1) + end if + call DGEMM_('T','N',nBas(jIrrep),nAsh(kIrrep),nBas(jIrrep),One,CMO(ipCM(jIrrep),1),nBas(jIrrep),rIn(ipDisp3(jDisp)+iii), & + nBas(jIrrep),Zero,TempY,nBas(jIrrep)) + n = nAsh(kIrrep)*nBas(jIrrep) + rOut(ipOut:ipOut+n-1) = rOut(ipOut:ipOut+n-1)+TempY(1:n) + iii = iii+nBas(jIrrep)*nAsh(kIrrep) + end if +# ifdef __INTEL_COMPILER + if (.false.) write(u6,*) kIrrep,iii +# endif + if (Show) then + write(u6,*) 'jIrrep,kIrrep=',jIrrep,kIrrep + write(u6,'(A,G20.10)') 'rOut:',DDot_(nIn2,rOut,1,rOut,1) + end if + end do + if (Show) write(u6,*) + ! * + !********************************************************************* + ! * + irc = -1 + iopt = 0 + Label = 'TOTAL' + call dWrMck(irc,iopt,Label,jdisp,rOut,2**iIrrep) + if (iRc /= 0) then + write(u6,*) 'WrDisk: Error writing to MCKINT' + write(u6,'(A,A)') 'Label=',Label + call Abend() + end if + if (Show) then + write(u6,'(A,G20.10)') 'TOTAL:',DDot_(nIn2,rOut,1,rOut,1) + end if + + irc = -1 + iopt = 0 + Label = 'INACTIVE' + call dWrMck(irc,iopt,Label,jdisp,InAct,2**iIrrep) + if (iRc /= 0) then + write(u6,*) 'WrDisk: Error writing to MCKINT' + write(u6,'(A,A)') 'Label=',Label + call Abend() + end if + if (Show) then + write(u6,'(A,G20.10)') 'INACTIVE:',DDot_(nIn2,InAct,1,InAct,1) + write(u6,*) + end if + + irc = -1 + iopt = 0 + Label = 'MOPERT' + call dWrMck(irc,iopt,Label,jdisp,rIn(ipMO(jdisp)),2**iIrrep) + if (iRc /= 0) then + write(u6,*) 'WrDisk: Error writing to MCKINT' + write(u6,'(A,A)') 'Label=',Label + call Abend() + end if + ! * + !********************************************************************* + ! * +else + ! * + !********************************************************************* + ! * + ! SCF case + irc = -1 + iopt = 0 + Label = 'TOTAL' + call dWrMck(irc,iopt,Label,jdisp,Act,2**iIrrep) + if (iRc /= 0) then + write(u6,*) 'WrDisk: Error writing to MCKINT' + write(u6,'(A,A)') 'Label=',Label + call Abend() + end if + if (Show) then + write(u6,'(A,G20.10)') 'TOTAL:',DDot_(nIn2,Act,1,Act,1) + end if + +end if +! * +!*********************************************************************** +! * +call mma_deallocate(TempY) +call mma_deallocate(TempX) +call mma_deallocate(rOut) +call mma_deallocate(InAct) +call mma_deallocate(Act) +! * +!*********************************************************************** +! * + +return + +end subroutine WrDisk diff -Nru openmolcas-22.02/src/mckinley/wrhdsk.f openmolcas-22.10/src/mckinley/wrhdsk.f --- openmolcas-22.02/src/mckinley/wrhdsk.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mckinley/wrhdsk.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,92 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SubRoutine WrHDsk(Hess,ngrad) - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "stdalloc.fh" -#include "disp.fh" -#include "disp2.fh" -#include "real.fh" - real*8 Hess(nGrad*(nGrad+1)/2) - Character*8 Label - Real*8, Allocatable:: Temp(:), HStat(:), EVec(:), EVal(:) -* - Call mma_allocate(Temp,nGrad**2,Label='Temp') - nH=0 - Do iIrrep=0,nIrrep-1 - nH=nH+lDisp(iIrrep) - End Do - Call mma_allocate(HStat,nH,Label='HStat') -* -*---- Reorder Hessian to lower triangular form -* - iGrad1=1 - iGrad2=0 - iG=0 - ip_Acc=1 - Do iIrrep=0,nIrrep-1 - iGrad2=iGrad2+lDisp(iIrrep) -* - Do iG1=iGrad1,iGrad2 - Do iG2=iGrad1,iG1 - iG=iG+1 - Temp(iG)=Hess(iG1*(iG1-1)/2+IG2) - End Do - End Do -* * -************************************************************************ -* * -*------- Diagonalize and keep eigen values for check facility -* - mH=lDisp(iIrrep) - Call mma_allocate(EVal,mH*(mH+1)/2,Label='EVal') - Call mma_allocate(EVec,mH*mH,Label='EVec') -* - call dcopy_(mH*(mH+1)/2,Temp,1,EVal,1) - call dcopy_(mH*mH,[Zero],0,EVec,1) - call dcopy_(mH,[One],0,EVec,mH+1) -* -*------- Compute eigenvalues and eigenvectors -* - Call Jacob(EVal,EVec,mH,mH) - Call Jacord(EVal,EVec,mH,mH) -* - Do i = 1, mH - HStat(ip_Acc)=EVal(i*(i+1)/2) - ip_Acc=ip_Acc+1 - End Do -* - Call mma_deallocate(EVec) - Call mma_deallocate(EVal) -* * -************************************************************************ -* * - iGrad1=iGrad1+lDisp(iIrrep) - End Do -* -*---- Write eigen values to the check file. -* - Call Add_Info('HStat',HStat,nH,5) -* - iRc=-1 - iOpt=0 - Label='StatHess' - Call dWrMck(iRC,iOpt,Label,idum,Temp,idum) - If (iRc.ne.0) Then - Write (6,*) 'WrHDsk: Error writing to MCKINT' - Write (6,'(A,A)') 'Label=',Label - Call Abend() - End If - Call mma_deallocate(HStat) - Call mma_deallocate(Temp) - Return - End diff -Nru openmolcas-22.02/src/mckinley/wrhdsk.F90 openmolcas-22.10/src/mckinley/wrhdsk.F90 --- openmolcas-22.02/src/mckinley/wrhdsk.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mckinley/wrhdsk.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,100 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine WrHDsk(Hess,nGrad) + +use Index_Functions, only: iTri, nTri_Elem +use Symmetry_Info, only: nIrrep +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nGrad +real(kind=wp), intent(in) :: Hess(nTri_Elem(nGrad)) +#include "Molcas.fh" +#include "disp.fh" +integer(kind=iwp) :: i, idum, iG, iG1, iG2, iGrad1, iGrad2, iIrrep, iOpt, ip_Acc, iRc, mH, nH +character(len=8) :: Label +real(kind=wp), allocatable :: EVal(:), EVec(:,:), HStat(:), Temp(:) + +call mma_allocate(Temp,nGrad**2,Label='Temp') +nH = 0 +do iIrrep=0,nIrrep-1 + nH = nH+lDisp(iIrrep) +end do +call mma_allocate(HStat,nH,Label='HStat') + +! Reorder Hessian to lower triangular form + +iGrad1 = 1 +iGrad2 = 0 +iG = 0 +ip_Acc = 1 +do iIrrep=0,nIrrep-1 + iGrad2 = iGrad2+lDisp(iIrrep) + + do iG1=iGrad1,iGrad2 + do iG2=iGrad1,iG1 + iG = iG+1 + Temp(iG) = Hess(iTri(iG1,iG2)) + end do + end do + ! * + !********************************************************************* + ! * + ! Diagonalize and keep eigenvalues for check facility + + mH = lDisp(iIrrep) + call mma_allocate(EVal,nTri_Elem(mH),Label='EVal') + call mma_allocate(EVec,mH,mH,Label='EVec') + + EVal(:) = Temp(1:nTri_Elem(mH)) + EVec(:,:) = Zero + call dcopy_(mH,[One],0,EVec,mH+1) + + ! Compute eigenvalues and eigenvectors + + call Jacob(EVal,EVec,mH,mH) + call Jacord(EVal,EVec,mH,mH) + + do i=1,mH + HStat(ip_Acc) = EVal(nTri_Elem(i)) + ip_Acc = ip_Acc+1 + end do + + call mma_deallocate(EVec) + call mma_deallocate(EVal) + ! * + !********************************************************************* + ! * + iGrad1 = iGrad1+lDisp(iIrrep) +end do + +! Write eigenvalues to the check file. + +call Add_Info('HStat',HStat,nH,5) + +iRc = -1 +iOpt = 0 +Label = 'StatHess' +call dWrMck(iRC,iOpt,Label,idum,Temp,idum) +if (iRc /= 0) then + write(u6,*) 'WrHDsk: Error writing to MCKINT' + write(u6,'(A,A)') 'Label=',Label + call Abend() +end if +call mma_deallocate(HStat) +call mma_deallocate(Temp) + +return + +end subroutine WrHDsk diff -Nru openmolcas-22.02/src/mclr/cho_fock_mclr.f openmolcas-22.10/src/mclr/cho_fock_mclr.f --- openmolcas-22.02/src/mclr/cho_fock_mclr.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/cho_fock_mclr.f 2022-10-10 14:22:40.000000000 +0000 @@ -138,11 +138,11 @@ else JNUM = nVec endif -********************************************************************** -* * -* START WORKING * -* * -********************************************************************** +************************************************************************ +* * +* START WORKING * +* * +************************************************************************ * ** Read Cholesky vector * @@ -305,11 +305,11 @@ End Do ! loop over red sets 1000 CONTINUE End Do ! loop over JSYM -********************************************************************** -* * -* POST PROCESSING * -* * -********************************************************************** +************************************************************************ +* * +* POST PROCESSING * +* * +************************************************************************ * ** Accumulate Coulomb and Exchange contributions * @@ -366,11 +366,11 @@ & 0.0d0,FkA%SB(iS)%A1(iOff:),nBas(jS)) EndIf End Do -********************************************************************** -* * -* TERMINATING * -* * -********************************************************************** +************************************************************************ +* * +* TERMINATING * +* * +************************************************************************ Call deallocate_DT(Scr) Call mma_deallocate(kOffSh) Call Deallocate_DT(CMO) diff -Nru openmolcas-22.02/src/mclr/cmsaxp.f openmolcas-22.10/src/mclr/cmsaxp.f --- openmolcas-22.02/src/mclr/cmsaxp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/cmsaxp.f 2022-10-10 14:22:40.000000000 +0000 @@ -104,7 +104,7 @@ * * End of the "essay". * -************************************************************************* +************************************************************************ use ipPage, only: W Implicit Real*8 (a-h,o-z) diff -Nru openmolcas-22.02/src/mclr/cmslag.f90 openmolcas-22.10/src/mclr/cmslag.f90 --- openmolcas-22.02/src/mclr/cmslag.f90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mclr/cmslag.f90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,15 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2022, Jie J. Bao * +!*********************************************************************** +Module CMSLag +Real*8 ResQaaLag2 +End Module CMSLag diff -Nru openmolcas-22.02/src/mclr/cmssolverhs.f openmolcas-22.10/src/mclr/cmssolverhs.f --- openmolcas-22.02/src/mclr/cmssolverhs.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/cmssolverhs.f 2022-10-10 14:22:40.000000000 +0000 @@ -56,6 +56,7 @@ ****************************************************** subroutine SolveforzX(zX,AXX,bX) use stdalloc, only : mma_allocate, mma_deallocate + use cmslag, only : ResQaaLag2 #include "Input.fh" #include "disp_mclr.fh" #include "Pointers.fh" @@ -67,35 +68,69 @@ #include "real.fh" #include "sa.fh" #include "crun_mclr.fh" +#include "warnings.h" ****** Output Real*8,DIMENSION((nRoots-1)*nRoots/2)::zX ****** Input Real*8,DIMENSION((nRoots-1)*nRoots/2)::bX Real*8,DIMENSION(((nRoots-1)*nRoots/2)**2)::AXX ****** Assistants - Real*8,DIMENSION(:),Allocatable::Ainv - INTEGER NElem,NDim + Real*8,DIMENSION(:),Allocatable::EigVal,bxscr,zXscr,Scr + Real*8 TwoPi + INTEGER NDim,nSPair,iPair,nScr,INFO + NDim=((nRoots-1)*nRoots/2) - NElem=NDim**2 - CALL mma_allocate(Ainv,Nelem) - CALL DCopy_(Nelem,AXX,1,Ainv,1) - -C write(6,*) 'AXX matrix' -C CALL RecPrt(' ',' ',AXX,nDim,nDim) - CALL MatInvert(Ainv,nDim) -C write(6,*) 'AXX inverse' -C CALL RecPrt(' ',' ',Ainv,nDim,nDim) -C write(6,*) 'bX' -C CALL RecPrt(' ',' ',bX,1,nDim) + nSPair=nDim + TwoPi=2.0d0*Pi + ResQaaLag2=0.0d0 + CALL mma_allocate(EigVal,nDim) + CALL mma_allocate(bxScr ,nDim) + CALL mma_allocate(zXScr ,nDim) + + CALL GetDiagScr(nScr,AXX,EigVal,nDim) + CALL mma_allocate(Scr ,nScr) + + CALL DSYEV_('V','U',nDim,AXX,nDim,EigVal,Scr,nScr,INFO) + + CALL DGEMM_('n','n',1,nDim,nDim,1.0d0,bx,1,AXX,nDim, + & 0.0d0,bxScr,1) + + + DO iPair=1,nDim + zxScr(iPair)=-bxScr(iPair)/EigVal(iPair) + IF(Abs(zxScr(iPair)).gt.TwoPi) THEN + zxScr(iPair)=0.0d0 + ResQaaLag2=ResQaaLag2+bxScr(iPair)**2 + END IF + END DO - CALL DGEMM_('n','n',nDim,1,nDim,-1.0d0,Ainv,nDim,bX,nDim, - &0.0d0,zX,nDim) + write(6,'(6X,A37,2X,ES17.9)') + & 'Residual in Qaa Lagrange Multipliers:',SQRT(ResQaaLag2) + IF(ResQaaLag2.gt.epsilon**2) THEN + write(6,*) + write(6,'(6X,A)') + & 'ERROR: RESIDUAL(S) FOR INTERMEDIATE STATE TOO BIG!' + write(6,*) + write(6,'(6X,A)') + & 'This may come from a linear molecular or a linear' + write(6,'(6X,A)') + & 'fragment.' + write(6,'(6X,A)') + & 'CMS-PDFT Lagrange multipliers are not solved.' + CALL WarningMessage(2, + & 'Residual in Lagrange Multipliers for Qaa Too Big') + CALL Quit(_RC_EXIT_EXPECTED_) + END IF -C write(6,*) 'zX' -C CALL RecPrt(' ',' ',zX,1,nDim) + CALL DGEMM_('n','t', 1,nSPair,nSPair, + & 1.0d0,zXScr,1,AXX,nSPair, + & 0.0d0,zx ,1) - CALL mma_deallocate(Ainv) + CALL mma_deallocate(EigVal) + CALL mma_deallocate(bxScr ) + CALL mma_deallocate(zXScr ) + CALL mma_deallocate(Scr ) RETURN END SUBROUTINE ****************************************************** diff -Nru openmolcas-22.02/src/mclr/densi2.f openmolcas-22.10/src/mclr/densi2.f --- openmolcas-22.02/src/mclr/densi2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/densi2.f 2022-10-10 14:22:40.000000000 +0000 @@ -146,7 +146,7 @@ END IF *.SCRATCH space for block of two-electron density matrix -* A 4 index block with four indeces belonging OS class +* A 4 index block with four indices belonging OS class INTSCR = MXTSOB ** 4 diff -Nru openmolcas-22.02/src/mclr/intdia.f openmolcas-22.10/src/mclr/intdia.f --- openmolcas-22.02/src/mclr/intdia.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/intdia.f 2022-10-10 14:22:40.000000000 +0000 @@ -86,7 +86,7 @@ NOCTPB = NOCTYP(IBSTFI(ISPC(IISPC))) MXOCOC = MAX(MXOCOC,NOCTPA*NOCTPB) END DO - Call mma_allocate(IOIO,NOCTPA*NOCTPB,Label='IOIO') + Call mma_allocate(IOIO,MXOCOC,Label='IOIO') **. Diagonal of one-body integrals and coulomb and exchange integrals * CALL GT1DIA_MCLR(H1D) diff -Nru openmolcas-22.02/src/mclr/mclr.f openmolcas-22.10/src/mclr/mclr.f --- openmolcas-22.02/src/mclr/mclr.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/mclr.f 2022-10-10 14:22:40.000000000 +0000 @@ -46,6 +46,7 @@ & FIMO, F0SQMO use Str_Info, only: DFTP, CFTP, DTOC, CNSM use negpre, only: SS + use PDFT_Util, only :Do_Hybrid,WF_Ratio,PDFT_Ratio Implicit Real*8 (a-h,o-z) #include "Input.fh" #include "warnings.h" @@ -193,7 +194,20 @@ * Call WfCtl_PCG(ifpK,ifpS,ifpCI,ifpSC,ifpRHS,ifpRHSCI) * Call Abend() Else if(iMCPD) Then!pdft + + Do_Hybrid=.false. + CALL qpg_DScalar('R_WF_HMC',Do_Hybrid) + If(Do_Hybrid) Then + CALL Get_DScalar('R_WF_HMC',WF_Ratio) + PDFT_Ratio=1.0d0-WF_Ratio + End If + if(iMSPD) then + if(Do_Hybrid) then + CALL WarningMessage(2, + & 'Hybrid MS-PDFT gradient not supported yet') + CALL Quit(_RC_EXIT_EXPECTED_) + end if Call WfCtl_MSPD(ifpK,ifpS,ifpCI,ifpSC,ifpRHS,converged,iPL) else Call WfCtl_PDFT(ifpK,ifpS,ifpCI,ifpSC,ifpRHS,converged,iPL) diff -Nru openmolcas-22.02/src/mclr/output_mclr.f openmolcas-22.10/src/mclr/output_mclr.f --- openmolcas-22.02/src/mclr/output_mclr.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/output_mclr.f 2022-10-10 14:22:40.000000000 +0000 @@ -351,7 +351,7 @@ * 120 Continue -********************************************************************** +************************************************************************ * 110 Continue kSym=kSym+lDisp(iSym) diff -Nru openmolcas-22.02/src/mclr/output_td.f openmolcas-22.10/src/mclr/output_td.f --- openmolcas-22.02/src/mclr/output_td.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/output_td.f 2022-10-10 14:22:40.000000000 +0000 @@ -259,7 +259,7 @@ * 120 Continue -********************************************************************** +************************************************************************ * 110 Continue kSym=kSym+lDisp(iSym) diff -Nru openmolcas-22.02/src/mclr/outras.f openmolcas-22.10/src/mclr/outras.f --- openmolcas-22.02/src/mclr/outras.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/outras.f 2022-10-10 14:22:40.000000000 +0000 @@ -122,7 +122,7 @@ if (irc.ne.0) Call SysAbendMsg('outras','Error in wrmck', & ' ') End If -********************************************************************** +************************************************************************ * End Do * diff -Nru openmolcas-22.02/src/mclr/outras_td.f openmolcas-22.10/src/mclr/outras_td.f --- openmolcas-22.02/src/mclr/outras_td.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/outras_td.f 2022-10-10 14:22:40.000000000 +0000 @@ -122,7 +122,7 @@ Call dWrMCk(iRC,iOpt,Label,ipert,CIp1,isyml) if (irc.ne.0) Call Abend() End If -********************************************************************** +************************************************************************ * 110 Continue * diff -Nru openmolcas-22.02/src/mclr/pdft_util.f90 openmolcas-22.10/src/mclr/pdft_util.f90 --- openmolcas-22.02/src/mclr/pdft_util.f90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mclr/pdft_util.f90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,16 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2020, Roland Lindh * +!*********************************************************************** +Module PDFT_UTIL +Logical Do_Hybrid +Real*8 WF_Ratio, PDFT_Ratio +End Module PDFT_UTIL diff -Nru openmolcas-22.02/src/mclr/prinp_mclr.f openmolcas-22.10/src/mclr/prinp_mclr.f --- openmolcas-22.02/src/mclr/prinp_mclr.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/prinp_mclr.f 2022-10-10 14:22:40.000000000 +0000 @@ -151,40 +151,40 @@ Write(6,Fmt2//'A,(T47,10F6.3))') 'Weights ', & (weight(i),i=1,nroots) Write(6,*) - Write(6,Fmt2//'A,T47,8I6)') + Write(6,Fmt2//'A,T47,8I8)') & 'Symmetry species', & (i,i=1,nSym) - Write(6,Fmt2//'A,T47,8I6)') + Write(6,Fmt2//'A,T47,8I8)') & 'Skiped sym. species', & (nSkip(iSym),iSym=1,nSym) - Write(6,Fmt2//'A,T47,8I6)') + Write(6,Fmt2//'A,T47,8I8)') & 'Frozen orbitals', & (nFro(iSym),iSym=1,nSym) - Write(6,Fmt2//'A,T47,8I6)') + Write(6,Fmt2//'A,T47,8I8)') & 'Inactive orbitals', & (nIsh(iSym),iSym=1,nSym) - Write(6,Fmt2//'A,T47,8I6)') + Write(6,Fmt2//'A,T47,8I8)') & 'Active orbitals', & (nAsh(iSym),iSym=1,nSym) - Write(6,Fmt2//'A,T47,8I6)') 'RAS1 orbitals', + Write(6,Fmt2//'A,T47,8I8)') 'RAS1 orbitals', & (nRs1(iSym),iSym=1,nSym) - Write(6,Fmt2//'A,T47,8I6)') 'RAS2 orbitals', + Write(6,Fmt2//'A,T47,8I8)') 'RAS2 orbitals', & (nRs2(iSym),iSym=1,nSym) - Write(6,Fmt2//'A,T47,8I6)') 'RAS3 orbitals', + Write(6,Fmt2//'A,T47,8I8)') 'RAS3 orbitals', & (nRs3(iSym),iSym=1,nSym) - Write(6,Fmt2//'A,T47,8I6)') 'Deleted orbitals', + Write(6,Fmt2//'A,T47,8I8)') 'Deleted orbitals', & (nDel(iSym),iSym=1,nSym) - Write(6,Fmt2//'A,T47,8I6)') + Write(6,Fmt2//'A,T47,8I8)') & 'Number of basis functions', & (nBas(iSym),iSym=1,nSym) - Write(6,Fmt2//'A,T47,8I6)') + Write(6,Fmt2//'A,T47,8I8)') & 'Number of Orbitals', & (nOrb(iSym),iSym=1,nSym) - Write(6,Fmt2//'A,T47,8I6)') + Write(6,Fmt2//'A,T47,8I8)') & 'Number of configurations', & (ncsf(isym),isym=1,nsym) - Write(6,Fmt2//'A,T47,8I6)') + Write(6,Fmt2//'A,T47,8I8)') & 'Number of combinations', & (nint(xispsm(isym,1)),isym=1,nsym) * diff -Nru openmolcas-22.02/src/mclr/rdinp_mclr.f openmolcas-22.10/src/mclr/rdinp_mclr.f --- openmolcas-22.02/src/mclr/rdinp_mclr.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/rdinp_mclr.f 2022-10-10 14:22:40.000000000 +0000 @@ -83,7 +83,7 @@ FANCY_PRECONDITIONER=.true. save=.false. isotop=.true. - Call lCopy(mxAtm*3+3,[.true.],0,lCalc,1) + lCalc(:) = .true. Do i=1,nDisp DspVec(i)=i End Do diff -Nru openmolcas-22.02/src/mclr/read2_2.f openmolcas-22.10/src/mclr/read2_2.f --- openmolcas-22.02/src/mclr/read2_2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/read2_2.f 2022-10-10 14:22:40.000000000 +0000 @@ -293,7 +293,7 @@ * and exchange type integrals * ****************************************************************************** -************************************************************************* +************************************************************************ * * M O !!! * ~ ~ @@ -556,7 +556,7 @@ End If End If * -************************************************************************* +************************************************************************ * * M O !!! * ~ ~ diff -Nru openmolcas-22.02/src/mclr/rhs.f openmolcas-22.10/src/mclr/rhs.f --- openmolcas-22.02/src/mclr/rhs.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/rhs.f 2022-10-10 14:22:40.000000000 +0000 @@ -1,4 +1,4 @@ -*********************************************************************** +************************************************************************ * This file is part of OpenMolcas. * * * * OpenMolcas is free software; you can redistribute it and/or modify * @@ -48,9 +48,9 @@ & Temp6(nDens),temp7(ndens) Real*8 rDum(1) Real*8, Allocatable:: MOX(:), MOT(:), FIX(:), MOT2(:) -* * -*********************************************************************** -* * +* * +************************************************************************ +* * Interface SubRoutine CISigma(iispin,iCsym,iSSym,Int1,nInt1,Int2s,nInt2s, & Int2a,nInt2a,ipCI1,ipCI2, Have_2_el) @@ -61,22 +61,22 @@ Logical Have_2_el End SubRoutine CISigma End Interface -* * -*********************************************************************** -* * +* * +************************************************************************ +* * itri(i,j)=Max(i,j)*(Max(i,j)-1)/2+Min(i,j) -* * -*********************************************************************** -* * +* * +************************************************************************ +* * one=1.0d0 debug=.true. iRC=-1 idsym=loper+1 iOpt=0 iOp=2**loper -* * -*********************************************************************** -* * +* * +************************************************************************ +* * * Read in connection matrix * and transform it to MO basis * diff -Nru openmolcas-22.02/src/mclr/rhs_pt2.f openmolcas-22.10/src/mclr/rhs_pt2.f --- openmolcas-22.02/src/mclr/rhs_pt2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/rhs_pt2.f 2022-10-10 14:22:40.000000000 +0000 @@ -53,9 +53,9 @@ Half=0.5d0 * * Read in a and b part of effective gradient from CASPT2 -* * -*********************************************************************** -* * +* * +************************************************************************ +* * Call mma_allocate(TempK,ndens2,Label='TempK') If (imethod.eq.2)Then i=0 @@ -93,13 +93,13 @@ & State_SYM,1,IPRDIA) #endif Call mma_deallocate(TempCI2) -* * -*********************************************************************** -* * +* * +************************************************************************ +* * Else -* * -*********************************************************************** -* * +* * +************************************************************************ +* * * MP2 * Call mma_allocate(TempCI,1,Label='TempCI') @@ -107,9 +107,9 @@ Call dDaFile(LuPT2,2,TempK,ndens2,i) * Call ThreeP(Kappa) * MP2 -* * -*********************************************************************** -* * +* * +************************************************************************ +* * End if * ---- * diff -Nru openmolcas-22.02/src/mclr/rhs_td.f openmolcas-22.10/src/mclr/rhs_td.f --- openmolcas-22.02/src/mclr/rhs_td.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/rhs_td.f 2022-10-10 14:22:40.000000000 +0000 @@ -48,9 +48,9 @@ & Temp6(nDens),temp7(ndens) Real*8 rDum(1) Real*8, Allocatable:: FiX(:),MOX(:),MOT(:),MOT2(:) -* * -*********************************************************************** -* * +* * +************************************************************************ +* * Interface SubRoutine CISigma_td(iispin,iCsym,iSSym,Int1,nInt1,Int2s,nInt2s, & Int2a,nInt2a,ipCI1,ipCI2,NT,Have_2_el) @@ -62,13 +62,13 @@ Logical Have_2_el End SubRoutine CISigma_td End Interface -* * -*********************************************************************** -* * +* * +************************************************************************ +* * itri(i,j)=Max(i,j)*(Max(i,j)-1)/2+Min(i,j) -* * -*********************************************************************** -* * +* * +************************************************************************ +* * debug=.true. iRC=-1 idsym=loper+1 diff -Nru openmolcas-22.02/src/mclr/sigmavec.f openmolcas-22.10/src/mclr/sigmavec.f --- openmolcas-22.02/src/mclr/sigmavec.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/sigmavec.f 2022-10-10 14:22:40.000000000 +0000 @@ -127,7 +127,7 @@ Call mma_allocate(SB,LSCR1,Label='SB') END IF *.SCRATCH space for integrals -* A 4 index integral block with four indeces belonging OS class +* A 4 index integral block with four indices belonging OS class INTSCR = MXTSOB ** 4 Call mma_allocate(INSCR,INTSCR,Label='INSCR') diff -Nru openmolcas-22.02/src/mclr/start_mclr.f openmolcas-22.10/src/mclr/start_mclr.f --- openmolcas-22.02/src/mclr/start_mclr.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/start_mclr.f 2022-10-10 14:22:40.000000000 +0000 @@ -37,7 +37,7 @@ call setup_MCLR(1) * If ((StepType.ne.'RUN2').and.(iAnd(kPrint,4).eq.4)) - & Write(6,*) 'Transformation of integrals' + & Write(6,'(6X,A)') 'Transformation of integrals' * For the mp2-gradient calculations we want the transformation * routine to produce all integrals of the occupied and virtual * orbitals so we tell it that the whole space is inactive and diff -Nru openmolcas-22.02/src/mclr/wfctl_hess.f openmolcas-22.10/src/mclr/wfctl_hess.f --- openmolcas-22.02/src/mclr/wfctl_hess.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/wfctl_hess.f 2022-10-10 14:22:40.000000000 +0000 @@ -72,9 +72,9 @@ & Sc1(:), Sc2(:), Sc3(:), & Dens(:), Pens(:), rmoaa(:) Integer, Allocatable:: List(:,:) -* * -*********************************************************************** -* * +* * +************************************************************************ +* * Interface SubRoutine CISigma(iispin,iCsym,iSSym,Int1,nInt1,Int2s,nInt2s, & Int2a,nInt2a,ipCI1,ipCI2, Have_2_el) diff -Nru openmolcas-22.02/src/mclr/wfctl_mspd.f openmolcas-22.10/src/mclr/wfctl_mspd.f --- openmolcas-22.02/src/mclr/wfctl_mspd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/wfctl_mspd.f 2022-10-10 14:22:40.000000000 +0000 @@ -21,6 +21,7 @@ ************************************************************************ use Exp, only: Exp_Close use ipPage, only: W + use cmslag, only: ResQaaLag2 Implicit Real*8 (a-h,o-z) * #include "stdalloc.fh" @@ -365,7 +366,7 @@ If (iBreak.eq.1) Then If (abs(delta).lt.abs(Epsilon**2*delta0)) Goto 300 Else If (iBreak.eq.2) Then - res=sqrt(resk**2+resci**2) + res=sqrt(resk**2+resci**2+ResQaaLag2) if (doDMRG) res=sqrt(resk**2) If (res.lt.abs(epsilon)) Goto 300 Else @@ -380,7 +381,7 @@ * Goto 200 * -********************************************************************** +************************************************************************ * 210 Continue Write(6,Fmt2//'A,I4,A)') diff -Nru openmolcas-22.02/src/mclr/wfctl_pdft.f openmolcas-22.10/src/mclr/wfctl_pdft.f --- openmolcas-22.02/src/mclr/wfctl_pdft.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/wfctl_pdft.f 2022-10-10 14:22:40.000000000 +0000 @@ -25,6 +25,7 @@ ************************************************************************ use Exp, Only: Exp_Close use ipPage, only: W + use PDFT_Util, only: Do_Hybrid, WF_Ratio,PDFT_Ratio Implicit Real*8 (a-h,o-z) * #include "stdalloc.fh" @@ -61,6 +62,7 @@ & FT99(:), Temp5(:) Real*8, Allocatable:: lmroots(:), lmroots_new(:), Kap_New(:), & Kap_New_Temp(:) + Real*8, Allocatable:: WFOrb(:),P2WF(:),P2PDFT(:) * * ************************************************************************ * * @@ -295,6 +297,11 @@ Call DSCAL_(nconf1*nroots,-2.0d0,W(ipST)%Vec,1) + IF(Do_Hybrid) THEN +*scaling the CI resp. for PDFT part in HMC-PDFT + CALL DScal_(nconf1*nroots,PDFT_Ratio,W(ipST)%Vec,1) + END IF + if (debug) then write(6,*) 'RHS CI part:' do iS=1,nconf1*nroots @@ -327,25 +334,76 @@ Call mma_deallocate(FT99) Call mma_deallocate(Temp5) + IF(Do_Hybrid) THEN +*scaling the orb resp. for PDFT part in HMC-PDFT + Call DSCAL_(ndens2,PDFT_Ratio,Temp4,1) +*calculating the orb resp. for WF part in HMC-PDFT + CALL mma_allocate(WForb,nDens2+6,Label='WForb') +*saving Fock matrix for PDFT part in HMC-PDFT + Call mma_allocate(FOTr,nTri ,Label='FOTr') + Call Get_Fock_Occ(FOTr,nTri) +* note that the Fock matrix will be overwritten with the wf one +* ini rhs_sa + CALL rhs_sa(WForb) + CALL dAXpY_(nDens2,WF_Ratio,WForb,1,Temp4,1) + call mma_deallocate(WForb) + END IF + if (debug) then write(6,*) 'RHS orb part:' do iS=1,nDens2 write(6,*) Temp4(iS) end do end if + + !Also, along with this RHS stuff, the Fock_occ array already stored on !the runfile needs to be replaced - switch triangular storage to square !storage: ! - Call mma_allocate(FOSq,nDens2,Label='FOSq') - Call mma_allocate(FOTr,nTri ,Label='FOTr') - FOSq(:)=Zero - Call Get_Fock_Occ(FOTr,nTri) - Call dcopy_(nTri,FOtr,1,FOSq,1) - Call Put_Fock_Occ(FOSq,ndens2) - - Call mma_deallocate(FOSq) - Call mma_deallocate(FOTr) + IF(Do_Hybrid) THEN + ng1=(ntash+1)*ntash/2 + ng2=(ng1+1)*ng1/2 + Call mma_allocate(FOSq,nDens2,Label='FOSq') + CALL Get_Fock_Occ(FOsq,nDens2) + +*scaling fock for wf part + CALL DScal_(nTri,WF_Ratio,FOsq,1) + +*adding fock for pdft part + call daxpy_(ntri,pdft_ratio,fotr,1,fosq,1) + + CALL mma_allocate(P2PDFT,nG2 ,Label='P2PDFT') + CALL mma_allocate(P2WF ,nG2 ,Label='P2WF') + + CALL Get_P2MOt(P2PDFT,nG2) +*scaling P2 for pdft part' + CALL DScal_(nG2,PDFT_Ratio,P2PDFT,1) + + CALL Get_P2MO(P2WF,nG2) +*adding P2 for wf part' + call daxpy_(ng2,wf_ratio,P2WF,1,P2PDFT,1) + + CALL Put_P2MOt(P2PDFT,nG2) + + Call Put_Fock_Occ(FOSq,ndens2) + + Call mma_deallocate(FOSq) + Call mma_deallocate(FOTr) + Call mma_deallocate(P2PDFT) + Call mma_deallocate(P2WF) + + ELSE + Call mma_allocate(FOSq,nDens2,Label='FOSq') + Call mma_allocate(FOTr,nTri ,Label='FOTr') + FOSq(:)=Zero + Call Get_Fock_Occ(FOTr,nTri) + Call dcopy_(nTri,FOtr,1,FOSq,1) + Call Put_Fock_Occ(FOSq,ndens2) + + Call mma_deallocate(FOSq) + Call mma_deallocate(FOTr) + END IF !This seems to calculate the RHS, at least for the orbital part. @@ -449,7 +507,7 @@ & 1,Zero,lmroots,1) * if (debug) then - write(6,*) 'lmroots_ips1 thisshould be -lmroots' + write(6,*) 'lmroots_ips1 this should be -lmroots' Call recprt('lmroots',' ',lmroots,1,nroots) end if * Initializing some of the elements of the PCG @@ -651,7 +709,7 @@ * Goto 200 * -********************************************************************** +************************************************************************ * 210 Continue Write(6,Fmt2//'A,I4,A)') diff -Nru openmolcas-22.02/src/mclr/wfctl_sa.f openmolcas-22.10/src/mclr/wfctl_sa.f --- openmolcas-22.02/src/mclr/wfctl_sa.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/wfctl_sa.f 2022-10-10 14:22:40.000000000 +0000 @@ -353,7 +353,7 @@ * Goto 200 * -********************************************************************** +************************************************************************ * 210 Continue Write(6,Fmt2//'A,I4,A)') diff -Nru openmolcas-22.02/src/mclr/wfctl_sp.f openmolcas-22.10/src/mclr/wfctl_sp.f --- openmolcas-22.02/src/mclr/wfctl_sp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/wfctl_sp.f 2022-10-10 14:22:40.000000000 +0000 @@ -287,7 +287,7 @@ End If * -********************************************************************** +************************************************************************ * * Sc1 kappa-> kappa * Sc3 CI -> kappa @@ -301,7 +301,7 @@ * Add together * * -********************************************************************** +************************************************************************ * if (nconf1.gt.1) then Call DZaXpY(nDens,One,Sc2,1,Sc3,1,Temp4,1) @@ -329,7 +329,7 @@ * # ##### ##### * *----------------------------------------------------------------------------- -********************************************************************** +************************************************************************ * * * delta @@ -459,7 +459,7 @@ Goto 200 * -********************************************************************** +************************************************************************ * 210 Continue Write(6,Fmt2//'A,I4,A)') diff -Nru openmolcas-22.02/src/mclr/wfctl_td.f openmolcas-22.10/src/mclr/wfctl_td.f --- openmolcas-22.02/src/mclr/wfctl_td.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mclr/wfctl_td.f 2022-10-10 14:22:40.000000000 +0000 @@ -53,9 +53,9 @@ & Temp1(:), Temp2(:), Temp3(:), Temp4(:), & Sc1(:), Sc2(:), Sc3(:), TempTD(:), & Dens(:), Pens(:), rmoaa(:) -* * -*********************************************************************** -* * +* * +************************************************************************ +* * Interface SubRoutine CISigma_td(iispin,iCsym,iSSym,Int1,nInt1,Int2s,nInt2s, & Int2a,nInt2a,ipCI1,ipCI2,NT,Have_2_el) @@ -334,11 +334,11 @@ 200 Continue * * -********************************************************************** +************************************************************************ * * O R B I T A L P A R T of the trail vector * -********************************************************************** +************************************************************************ * @@ -520,7 +520,7 @@ * End If * -********************************************************************** +************************************************************************ * * Sc1 kappa-> kappa * Sc3 CI -> kappa @@ -530,12 +530,12 @@ * Kap kappaX * CIT CIX * CId present step -********************************************************************** +************************************************************************ * * Add together * * -********************************************************************** +************************************************************************ C irc=ipnout(-1) if (CI) then ! if (.false.) then @@ -566,7 +566,7 @@ * # ##### ##### * *----------------------------------------------------------------------------- -********************************************************************** +************************************************************************ * * * delta @@ -712,7 +712,7 @@ Goto 200 * -********************************************************************** +************************************************************************ * 210 Continue Write(6,Fmt2//'A,I4,A)') diff -Nru openmolcas-22.02/src/mcpdft/hybridpdft.f90 openmolcas-22.10/src/mcpdft/hybridpdft.f90 --- openmolcas-22.02/src/mcpdft/hybridpdft.f90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mcpdft/hybridpdft.f90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,23 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2022, Jie J. Bao * +!*********************************************************************** +! **************************************************************** +! history: * +! Jie J. Bao, on Apr. 24, 2022, created this file. * +! **************************************************************** + +Module hybridpdft +logical Do_Hybrid +Real*8 Ratio_WF +Real*8 E_nohyb ! PDFT energy if it is not hybrid +End Module hybridpdft + diff -Nru openmolcas-22.02/src/mcpdft/inppri.f openmolcas-22.10/src/mcpdft/inppri.f --- openmolcas-22.02/src/mcpdft/inppri.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mcpdft/inppri.f 2022-10-10 14:22:40.000000000 +0000 @@ -28,6 +28,7 @@ ************************************************************************ Use Fock_util_global, only: DoLocK Use Functionals, only: Init_Funcs, Print_Info + Use KSDFT_Info, only: CoefR, CoefX Implicit Real*8 (A-H,O-Z) #include "rasdim.fh" #include "rasscf.fh" @@ -38,12 +39,11 @@ #include "rctfld.fh" #include "WrkSpc.fh" #include "splitcas.fh" -#include "ksdft.fh" #include "mspdft.fh" Character*8 Fmt1,Fmt2, Label Character*120 Line,BlLine,StLine Character*3 lIrrep(8) - Character*16 KSDFT2 + Character*80 KSDFT2 Logical DoCholesky Logical lOPTO diff -Nru openmolcas-22.02/src/mcpdft/input_ras_mcpdft.fh openmolcas-22.10/src/mcpdft/input_ras_mcpdft.fh --- openmolcas-22.02/src/mcpdft/input_ras_mcpdft.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mcpdft/input_ras_mcpdft.fh 2022-10-10 14:22:40.000000000 +0000 @@ -13,7 +13,7 @@ Integer LuInput * Used for input processing Integer NKeys - Parameter (NKeys=109) + Parameter (NKeys=110) *------------------------------------------------------ * Logical flags, to check whether a keyword has been used * in the input: @@ -40,7 +40,7 @@ & keyBLOK, keySOCC, keyRGIN, keyPRSD, KeyFCID, & KeyNOCA, KeySAVE, KeyEXPA, KeyH5OR, KeyH5CI, & KeyHEXS, KeyHEUR, KeyMSPD, KeyGrad, KeyNOGR, - & KeyGSOR, KeyDFCF, KeyZZZZ, KeyWJOB + & KeyGSOR, KeyDFCF, KeyWJOB, KeyLAMB, KeyZZZZ Common /InputFlags_M/ KeyAAAA, & KeyALTE, KeyATOM, KeyAVER, KeyCHAR, KeyCHOI, @@ -64,7 +64,7 @@ & keyBLOK, keySOCC, keyRGIN, keyPRSD, KeyFCID, & KeyNOCA, KeySAVE, KeyEXPA, KeyH5OR, KeyH5CI, & KeyHEXS, KeyHEUR, KeyMSPD, KeyGrad, KeyNOGR, - & KeyGSOR, KeyDFCF, KeyZZZZ, KeyWJOB + & KeyGSOR, KeyDFCF, KeyWJOB, KeyLAMB, KeyZZZZ Equivalence(KeyAAAA,KeyFlags(0)) *------------------------------------------------------ @@ -91,7 +91,7 @@ & 'BLOK','SOCC','RGIN','PRSD','FCID', & 'NOCA','SAVE','EXPA','H5OR','H5CI', & 'HEXS','HEUR','MSPD','GRAD','NOGR', - & 'GSOR','DFCF','ZZZZ','WJOB']) + & 'GSOR','DFCF','WJOB','LAMB','ZZZZ']) *------------------------------------------------------ * Input data sets: Integer iCI_I,IROOT_I,NFRO_I,NISH_I,NRS1_I,NRS2_I,NRS3_I,NDEL_I, diff -Nru openmolcas-22.02/src/mcpdft/mcpdft.f openmolcas-22.10/src/mcpdft/mcpdft.f --- openmolcas-22.02/src/mcpdft/mcpdft.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mcpdft/mcpdft.f 2022-10-10 14:22:40.000000000 +0000 @@ -50,6 +50,8 @@ * Modified AMS Feb 2016 - separate MCPDFT from RASSCF * ************************************************************************ + use csfbas, only: CONF, KCFTP + use hybridpdft, only: do_hybrid use stdalloc, only : mma_allocate, mma_deallocate use Fock_util_global, only: ALGO, DoActive, DoCholesky use OFembed, only: Do_OFemb, FMaux @@ -72,7 +74,6 @@ #include "casvb.fh" #include "rasscf_lucia.fh" #include "lucia_ini.fh" -#include "csfbas.fh" #include "gugx.fh" #include "pamint.fh" #include "qnctl_mcpdft.fh" @@ -84,6 +85,8 @@ #include "wjob.fh" Integer LRState,NRState ! storing info in Do_Rotate.txt Integer LHrot,NHrot ! storing info in H0_Rotate.txt + Real*8 MSPDFTShift + Logical lshiftdiag CHARACTER(Len=18)::MatInfo Integer LXScratch,NXScratch INTEGER LUMS,IsFreeUnit @@ -95,8 +98,8 @@ Character*80 Line Logical IfOpened Logical Found - Character(len=8),DIMENSION(:),Allocatable::VecStat - CHARACTER(Len=8)::StatVec + Character(len=9),DIMENSION(:),Allocatable::VecStat + CHARACTER(Len=9)::StatVec CHARACTER(Len=30)::mspdftfmt Logical RefBas Logical Gradient @@ -113,8 +116,8 @@ External Get_ProgName ! External Get_SuperName Character*100 ProgName, Get_ProgName!, Get_SuperName - External RasScf_Init - External Scan_Inp + External RasScf_Init_m + External Scan_Inp_m ! External Proc_Inp ! real*8 Elec_Ener integer iRef_E,IAD19 @@ -603,7 +606,7 @@ Call DDafile(JOBOLD,1,Work(LW4),nConf,iDisk) call getmem('kcnf','allo','inte',ivkcnf,nactel) Call Reord2(NAC,NACTEL,STSYM,1, - & iWork(KICONF(1)),iWork(KCFTP), + & CONF,iWork(KCFTP), & Work(LW4),Work(LW11),iWork(ivkcnf)) Call dcopy_(nconf,Work(LW11),1,Work(LW4),1) call getmem('kcnf','free','inte',ivkcnf,nactel) @@ -682,9 +685,25 @@ Write(6,*) Write(6,'(6X,80a)') ('*',i=1,80) Write(6,*) - write(6,'(6X,2A)') - & MSPDFTMethod,' Effective Hamiltonian' - Call RecPrt(' ','',Work(LHRot),lroots,lroots) + + lshiftdiag=.false. + CALL shiftdiag(WORK(LHRot),MSPDFTShift,lshiftdiag,lRoots,10) + if(.not.do_hybrid) then + write(6,'(6X,2A)') + & MSPDFTMethod,' Effective Hamiltonian' + else + write(6,'(6X,3A)') + & 'Hybrid ',MSPDFTMethod,' Effective Hamiltonian' + end if + if(lshiftdiag) then + write(6,'(6X,A,F9.2,A)') + & '(diagonal values increased by',-MSPDFTShift,' hartree)' + Do JRoot=1,lRoots + Work(LHRot+Jroot-1+(Jroot-1)*lroots)= + & Work(LHRot+Jroot-1+(Jroot-1)*lroots)-MSPDFTShift + End Do + end if + Call RecPrt(' ','(7X,10(F9.6,1X))',Work(LHRot),lroots,lroots) write (6,*) *MS-PDFT To diagonalize the final MS-PDFT effective H matrix. *MS-PDFT Eigenvectors will be stored in LRState. This notation for the @@ -698,35 +717,50 @@ Call GetMem('XScratch','Allo','Real',LXScratch,NXScratch) Call Dsyev_('V','U',lroots,Work(LHRot),lroots,Work(LRState), & Work(LXScratch),NXScratch,INFO) - write(6,'(6X,2A)')MSPDFTMethod,' Energies:' - Do Jroot=1,lroot s - write(6,'(6X,3 A,1X,I2,5X,A13,F18.8)') - &':: ',MSPDFTMethod,' Root', - & Jroot,'Total energy:',Work(LRState+Jroot-1) - End Do + + if(lshiftdiag) then + Do Jroot=1,lRoots + Work(LRState+Jroot-1)=Work(LRState+Jroot-1)+MSPDFTShift + End Do + end if + + if(.not.do_hybrid) then + write(6,'(6X,2A)')MSPDFTMethod,' Energies:' + Do Jroot=1,lroots + write(6,'(6X,3A,1X,I4,3X,A13,F18.8)') + & ':: ',MSPDFTMethod,' Root', + & Jroot,'Total energy:',Work(LRState+Jroot-1) + End Do + else + write(6,'(6X,3A)')'Hybrid ',MSPDFTMethod,' Energies:' + Do Jroot=1,lroots + write(6,'(6X,4A,1X,I4,3X,A13,F18.8)') + & ':: ','Hybrid ',MSPDFTMethod,' Root', + & Jroot,'Total energy:',Work(LRState+Jroot-1) + End Do + end if Call Put_iScalar('Number of roots',nroots) Call Put_dArray('Last energies',WORK(LRState),nroots) Call Put_dScalar('Last energy',WORK(LRState+iRlxRoot-1)) Write(6,*) CALL mma_allocate(VecStat,lRoots) Do Jroot=1,lRoots - write(StatVec,'(A6,I2)')'Root ',JRoot + write(StatVec,'(A5,I4)')'Root ',JRoot VecStat(JRoot)=StatVec End Do - write(6,'(6X,2A)')MSPDFTMethod,' Eigenvectors:' - write(6,'(7X,A)')'Intermediate-state Basis' - if(lroots.lt.10) then - write(mspdftfmt,'(A5,I1,A9)') - & '(13X,',lRoots,'(A8,16X))' - write(6,mspdftfmt)((VecStat(JRoot)),JRoot=1,lroots) + if(.not.do_hybrid) then + write(6,'(6X,2A)')MSPDFTMethod,' Eigenvectors:' else - write(mspdftfmt,'(A5,I2,A9)') - & '(13X,',lRoots,'(A8,16X))' - write(6,mspdftfmt)((VecStat(JRoot)),JRoot=1,lroots) + write(6,'(6X,3A)')'Hybrid ',MSPDFTMethod,' Eigenvectors:' end if + write(6,'(7X,A)')'Intermediate-state Basis' + write(mspdftfmt,'(A4,I5,A9)') + & '(6X,',lRoots,'(A10,5X))' + write(6,mspdftfmt)((VecStat(JRoot)),JRoot=1,lroots) *Added by Chen to write energies and states of MS-PDFT into JOBIPH If(IWJOB==1) Call writejobms(iadr19,LRState,LHRot) - Call RecPrt(' ','',Work(LHRot),lroots,lroots) + Call RecPrt(' ','(7X,10(F9.6,6X))', + & Work(LHRot),lroots,lroots) if(DoGradMSPD) then Call MSPDFTGrad_Misc(LHRot) Call GetMem('F1MS' ,'Free','Real',iF1MS , nTot1*nRoots) @@ -750,26 +784,17 @@ Call GetMem('XScratch','ALLO','Real',LXScratch,NXScratch) Call FZero(Work(LXScratch),NXScratch) Call FZero(Work(LRState) ,NXScratch) - LUMS=IsFreeUnit(LUMS) - CALL Molcas_Open(LUMS,'ROT_VEC') - Do Jroot=1,lroots - read(LUMS,*) (Work(LRState+kroot-1+(jroot-1)*lroots) - & ,kroot=1,lroots) - End Do + CALL ReadMat2('ROT_VEC',MatInfo,WORK(LRState), + & lRoots,lRoots,7,18,'T') CALL DGEMM_('n','n',lRoots,lRoots,lRoots,1.0d0,Work(LRState), & lRoots,Work(LHRot),lRoots,0.0d0,Work(LXScratch),lRoots) write(6,'(7X,A)')'Reference-state Basis' write(6,mspdftfmt)((VecStat(JRoot)),JRoot=1,lroots) - Call RecPrt(' ',' ',Work(LXScratch),lroots,lroots) - close(LUMS) - CALL Molcas_Open(LUMS,'FIN_VEC') - Do JRoot=1,lRoots - write(LUMS,*)(Work(LXScratch+(JRoot-1)*lRoots+kRoot-1), - & kRoot=1,lRoots) - End Do - write(LUMS,*) MSPDFTMethod + Call RecPrt(' ','(7X,10(F9.6,6X))', + & Work(LXScratch),lroots,lroots) + CALL PrintMat2('FIN_VEC',MatInfo,WORK(LXScratch), + & lRoots,lRoots,7,18,'T') Call GetMem('XScratch','FREE','Real',LXScratch,NXScratch) - Close(LUMS) end if * Gradient part if(DoGradMSPD) then diff -Nru openmolcas-22.02/src/mcpdft/mkclist.f openmolcas-22.10/src/mcpdft/mkclist.f --- openmolcas-22.02/src/mcpdft/mkclist.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mcpdft/mkclist.f 2022-10-10 14:22:40.000000000 +0000 @@ -18,7 +18,7 @@ IMPLICIT REAL*8 (A-H,O-Z) C #include "rasdim.fh" -#include "general.fh" +#include "general_mul.fh" #include "gugx.fh" C DIMENSION ISM(NLEV),IDOWN(NVERT,0:3) diff -Nru openmolcas-22.02/src/mcpdft/mkcot.f openmolcas-22.10/src/mcpdft/mkcot.f --- openmolcas-22.02/src/mcpdft/mkcot.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mcpdft/mkcot.f 2022-10-10 14:22:40.000000000 +0000 @@ -18,7 +18,7 @@ IMPLICIT REAL*8 (A-H,O-Z) C #include "rasdim.fh" -#include "general.fh" +#include "general_mul.fh" #include "output_ras.fh" #include "gugx.fh" C diff -Nru openmolcas-22.02/src/mcpdft/mksgnum.f openmolcas-22.10/src/mcpdft/mksgnum.f --- openmolcas-22.02/src/mcpdft/mksgnum.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mcpdft/mksgnum.f 2022-10-10 14:22:40.000000000 +0000 @@ -17,7 +17,7 @@ C IMPLICIT REAL*8 (A-H,O-Z) #include "rasdim.fh" -#include "general.fh" +#include "general_mul.fh" #include "gugx.fh" #include "WrkSpc.fh" #include "output_ras.fh" diff -Nru openmolcas-22.02/src/mcpdft/msctl.f openmolcas-22.10/src/mcpdft/msctl.f --- openmolcas-22.02/src/mcpdft/msctl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mcpdft/msctl.f 2022-10-10 14:22:40.000000000 +0000 @@ -29,6 +29,8 @@ * AMS, Minneapolis, Feb 2016 * Use Fock_util_global, only: ALGO, DoCholesky + Use KSDFT_Info, only: do_pdftpot, ifav, ifiv + Use hybridpdft, only: Do_Hybrid, E_NoHyb, Ratio_WF Implicit Real*8 (A-H,O-Z) Dimension CMO(*) ,F(*) , FI(*), FA(*), Ref_Ener(*) * @@ -42,12 +44,10 @@ #include "pamint.fh" #include "timers.fh" #include "SysDef.fh" -#include "csfbas.fh" #include "gugx.fh" #include "casvb.fh" #include "wadr.fh" #include "rasscf_lucia.fh" -#include "ksdft.fh" ! Logical TraOnly * @@ -838,6 +838,10 @@ CASDFT_E = ECAS+CASDFT_Funct + IF(Do_Hybrid) THEN + E_NoHyb=CASDFT_E + CASDFT_E=Ratio_WF*Ref_Ener(jRoot)+(1-Ratio_WF)*E_NoHyb + END IF ! Write(6,*) ! '**************************************************' ! write(6,*) 'ENERGY REPORT FOR STATE',jroot @@ -851,7 +855,7 @@ IF(Do_Rotate) Then - Energies(jroot)=CASDFT_Funct + Energies(jroot)=CASDFT_E *JB replacing ref_ener with MC-PDFT energy for MS-PDFT use Ref_Ener(jroot)=CASDFT_E ELSE diff -Nru openmolcas-22.02/src/mcpdft/mspdft_util.f openmolcas-22.10/src/mcpdft/mspdft_util.f --- openmolcas-22.02/src/mcpdft/mspdft_util.f 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mcpdft/mspdft_util.f 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,53 @@ +************************************************************************ +* This file is part of OpenMolcas. * +* * +* OpenMolcas is free software; you can redistribute it and/or modify * +* it under the terms of the GNU Lesser General Public License, v. 2.1. * +* OpenMolcas is distributed in the hope that it will be useful, but it * +* is provided "as is" and without any express or implied warranties. * +* For more details see the full text of the license in the file * +* LICENSE or in . * +* * +* Copyright (C) 2022, Jie J. Bao * +************************************************************************ + +************************************************************************ +* History: * +* Jie J. Bao on May 09, 2022, created this file * +************************************************************************ + + + + Subroutine ShiftDiag(Mat,RShift,lShift,nDim,Digit) + + INTEGER nDim,Digit + Real*8,DIMENSION(nDim**2)::Mat + Real*8 RShift + Logical lShift + + + Real*8,DIMENSION(nDim)::RDiag + Real*8 MaxElem + INTEGER I,iShift + + DO I=1,nDim + RDiag(I)=Mat((I-1)*nDim+I) + END DO + + MaxElem=maxval(RDiag) + +* write(6,*) 'maximum of diagonal elements',MaxElem +* CALL RecPrt(' ',' ',RDiag,1,nDim) + + IF(abs(MaxElem).lt.Real(Digit,8)) THEN + lShift=.false. + RETURN + ELSE + lShift=.true. + IShift=Int(MaxElem,8)/Digit*Digit + RShift=Real(IShift,8) +* write(6,*) lShift,IShift,RShift + END IF + + RETURN + End Subroutine diff -Nru openmolcas-22.02/src/mcpdft/print_mcpdft.f openmolcas-22.10/src/mcpdft/print_mcpdft.f --- openmolcas-22.02/src/mcpdft/print_mcpdft.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mcpdft/print_mcpdft.f 2022-10-10 14:22:40.000000000 +0000 @@ -22,26 +22,26 @@ * G. Li Manni (GLM) * S Dong, 2018 (added print outs related to scaling) ****************************************************************** - use KSDFT_Info, only: Funcaa, Funcbb, Funccc - use nq_Info + use KSDFT_Info, only: CoefR, CoefX, Funcaa, Funcbb, Funccc + use nq_Info, only: Dens_a1, Dens_a2, Dens_b1, Dens_b2, Dens_I + Use hybridpdft, only: Do_Hybrid, E_NoHyb, Ratio_WF Implicit Real*8 (A-H,O-Z) Real*8 CASDFT_E,E_nuc,E_cor,E_cas,E_ot Real*8 CASDFT_E_1,E_ot_1,Funcaa1,Funcbb1,Funccc1 Dimension Ref_Ener(*) integer jroot #include "WrkSpc.fh" -#include "ksdft.fh" #include "mspdft.fh" write(6,'(6X,80A)') write(6,'(6X,80A)') ('*',i=1,80) write(6,'(6X,80A)') ('*',i=1,80) IF(Do_Rotate) Then - write(6,'(6X,2A,1X,I2.2,1X,A)')'** '// + write(6,'(6X,2A,1X,I4.4,1X,A)')'** '// & MSpdftMethod,' INTERMEDIATE STATE', jroot, - & ' ** ' + & ' ** ' ELSE - write(6,'(6X,A,1X,I2.2,1X,A)')'** '// + write(6,'(6X,A,1X,I4.4,1X,A)')'** '// & ' MC-PDFT RESULTS, STATE', jroot, & ' ** ' ENDIF @@ -81,14 +81,23 @@ write(6,'(6X,A,51X,F18.8)') 'Core energy',E_cor write(6,'(6X,A,36X,F18.8)') 'CASSCF contribution energy',E_cas write(6,'(6X,A,49X,F18.8)') 'On-top energy',E_ot - write(6,'(6X,80A)') + IF(Do_Hybrid) Then + write(6,'(6X,A)') 'Information for hybrid PDFT:' + write(6,'(6X,A,37X,F6.2)') + & 'Wave function percentage (Lambda*100)',Ratio_WF*1.0d2 + write(6,'(6X,A,42X,F18.8)') + & 'Wave function energy',Ratio_WF*Ref_Ener(jRoot) + write(6,'(6X,A,51X,F18.8)') + & 'PDFT energy',(1-Ratio_WF)*E_NoHyb + write(6,'(6X,80A)') + END IF IF(Do_Rotate) Then - write(6,'(6X,A,2X,I3,14X,F18.8)') + write(6,'(6X,A,2X,I4,13X,F18.8)') &'Total MC-PDFT energy for intermediate state', jroot,CASDFT_E ELSE - write(6,'(6X,A,2X,I3,27X,F18.8)') + write(6,'(6X,A,2X,I4,26X,F18.8)') &'Total MC-PDFT energy for state',jroot,CASDFT_E END IF if ((CoefX*CoefR.ne.0.0).and.(CoefX.ne.1.0.or.CoefR.ne.1.0)) Then diff -Nru openmolcas-22.02/src/mcpdft/proc_inpX.f openmolcas-22.10/src/mcpdft/proc_inpX.f --- openmolcas-22.02/src/mcpdft/proc_inpX.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mcpdft/proc_inpX.f 2022-10-10 14:22:40.000000000 +0000 @@ -11,6 +11,7 @@ Subroutine Proc_InpX(DSCF,iRc) ! module dependencies + use csfbas, only: CONF, KCFTP #ifdef module_DMRG ! use molcas_dmrg_interface !stknecht: Maquis-DMRG program #endif @@ -20,7 +21,9 @@ & mh5_exists_dset, mh5_fetch_attr, mh5_fetch_dset, & mh5_close_file #endif + use KSDFT_Info, only: CoefR, CoefX use OFembed, only: Do_OFemb + use hybridpdft, only: Ratio_WF, Do_Hybrid Implicit Real*8 (A-H,O-Z) #include "SysDef.fh" #include "rasdim.fh" @@ -34,7 +37,6 @@ #include "general.fh" #include "output_ras.fh" #include "orthonormalize_mcpdft.fh" -#include "ksdft.fh" #include "mspdft.fh" #include "casvb.fh" #include "pamint.fh" @@ -42,7 +44,6 @@ #include "wjob.fh" * Lucia-stuff: #include "ciinfo.fh" -#include "csfbas.fh" #include "spinfo.fh" #include "lucia_ini.fh" #include "stdalloc.fh" @@ -294,7 +295,7 @@ ! If (Line(1:4).eq.'ROKS') DFTFOCK='ROKS' ! If (Line(1:6).eq.'CASDFT') DFTFOCK='DIFF' Read(LUInput,*,End=9910,Err=9920) Line - KSDFT=Line(1:16) + KSDFT=Line(1:80) Call UpCase(KSDFT) ExFac=Get_ExFac(KSDFT) ******* @@ -362,6 +363,25 @@ Call SetPos_m(LUInput,'WJOB',Line,iRc) Call ChkIfKey_m() End If +*--- Process LAMB command --------------------------------------------* + If (KeyLAMB) Then + If (DBG) Write(6,*) 'Check if hybrid PDFT case' + Call SetPos_m(LUInput,'LAMB',Line,iRc) + ReadStatus=' Failure reading data following HPDF keyword.' + Read(LUInput,*,End=9910,Err=9920) Ratio_WF + ReadStatus=' O.K. reading data following HPDF keyword.' + If(iRc.ne._RC_ALL_IS_WELL_) GoTo 9810 + If(Ratio_WF.gt.0.0d0) Then + Do_Hybrid=.true. + CALL Put_DScalar('R_WF_HMC',Ratio_WF) + End If + If (DBG) Write(6,*) 'Wave Funtion Ratio in hybrid PDFT',Ratio_WF + If (dogradmspd.or.dogradpdft) Then + Call WarningMessage(2,'GRAD currently not compatible with HPDF') + GoTo 9810 + End If + Call ChkIfKey_m() + End If *--- Process HDF5 file --------------------------------------------* If (hasHDF5ref) Then @@ -595,6 +615,9 @@ If (KeyGRAD) Then If (DBG) Write(6,*) ' GRADient keyword was used.' DoGradPDFT=.true. +*TRS + call Put_iScalar('agrad',1) +*TRS if(iMSPDFT==1) then dogradmspd=.true. dogradpdft=.false. @@ -826,7 +849,7 @@ IF (ICICH.EQ.1) THEN CALL GETMEM('UG2SG','ALLO','INTE',LUG2SG,NCONF) CALL UG2SG_m(NROOTS,NCONF,NAC,NACTEL,STSYM,IPR, - * IWORK(KICONF(1)),IWORK(KCFTP),IWORK(LUG2SG), + * CONF,IWORK(KCFTP),IWORK(LUG2SG), * ICI,JCJ,CCI,MXROOT) CALL GETMEM('UG2SG','FREE','INTE',LUG2SG,NCONF) END IF diff -Nru openmolcas-22.02/src/mcpdft/rasscf_init.f openmolcas-22.10/src/mcpdft/rasscf_init.f --- openmolcas-22.02/src/mcpdft/rasscf_init.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mcpdft/rasscf_init.f 2022-10-10 14:22:40.000000000 +0000 @@ -24,6 +24,8 @@ Use Fock_util_global, only: ALGO, Deco, DensityCheck, dmpk, & DoLocK, DoCholesky, Estimate, Nscreen, & Update + Use KSDFT_Info, Only: CoefR, CoefX + use hybridpdft, only: Ratio_WF, Do_Hybrid Implicit Real*8 (A-H,O-Z) External Get_SuperName Character*100 ProgName, Get_SuperName @@ -31,13 +33,12 @@ #include "output_ras.fh" #include "rasscf.fh" #include "casvb.fh" -#include "general.fh" +#include "general_mul.fh" #include "gas.fh" #include "timers.fh" #include "lucia_ini.fh" #include "orthonormalize_mcpdft.fh" #include "WrkSpc.fh" -#include "ksdft.fh" Integer IPRGLB_IN, IPRLOC_IN(7) * What to do with Cholesky stuff? Logical, External :: Is_First_Iter @@ -350,6 +351,12 @@ CSVC: lucia timers tsigma = 0.0d0 tdensi = 0.0d0 + +* +C Hybrid-PDFT + Ratio_WF=0.0d0 + Do_Hybrid=.false. + * RETURN END diff -Nru openmolcas-22.02/src/mcpdft/savefock_pdft.f openmolcas-22.10/src/mcpdft/savefock_pdft.f --- openmolcas-22.02/src/mcpdft/savefock_pdft.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mcpdft/savefock_pdft.f 2022-10-10 14:22:40.000000000 +0000 @@ -19,6 +19,8 @@ * Jie J. Bao, on Jan. 04, 2021, created this file. * * **************************************************************** + Use KSDFT_Info, Only: ifav, ifiv + * Notes: Two references will be referred to in the comments. * Ref1: Sand, et al. JCTC, 2018, 14, 126. * Ref2: Scott, et al. JCP, 2020, 153, 014106. @@ -34,12 +36,10 @@ #include "pamint.fh" #include "timers.fh" #include "SysDef.fh" -#include "csfbas.fh" #include "gugx.fh" #include "casvb.fh" #include "wadr.fh" #include "rasscf_lucia.fh" -#include "ksdft.fh" #include "mspdft.fh" ! Logical TraOnly diff -Nru openmolcas-22.02/src/mcpdft/sgprwf.f openmolcas-22.10/src/mcpdft/sgprwf.f --- openmolcas-22.02/src/mcpdft/sgprwf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mcpdft/sgprwf.f 2022-10-10 14:22:40.000000000 +0000 @@ -20,7 +20,7 @@ C #include "rasdim.fh" #include "rasscf.fh" -#include "general.fh" +#include "general_mul.fh" #include "input_ras_mcpdft.fh" #include "output_ras.fh" #include "gugx.fh" diff -Nru openmolcas-22.02/src/misc_util/crecprt.f openmolcas-22.10/src/misc_util/crecprt.f --- openmolcas-22.02/src/misc_util/crecprt.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/misc_util/crecprt.f 2022-10-10 14:22:40.000000000 +0000 @@ -10,7 +10,6 @@ * * * Copyright (C) 1992, Markus P. Fuelscher * ************************************************************************ - Subroutine CRecPrt(Title,FmtIn,A,nRow,nCol,Type) ************************************************************************ * CRecPrt * @@ -29,7 +28,9 @@ *> @param[in] A A matrix *> @param[in] nRow number of rows of \p A *> @param[in] nCol number of columns of \p A +*> @param[in] Type ************************************************************************ + Subroutine CRecPrt(Title,FmtIn,A,nRow,nCol,Type) Implicit Real*8 (A-H,O-Z) #include "standard_iounits.fh" Character*(*) Title diff -Nru openmolcas-22.02/src/misc_util/fcidump_output.F90 openmolcas-22.10/src/misc_util/fcidump_output.F90 --- openmolcas-22.02/src/misc_util/fcidump_output.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/misc_util/fcidump_output.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,70 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2016, Sebastian Wouters * +!*********************************************************************** +! Subroutine to write FCIDUMP file +! Written by Sebastian Wouters, Leuven, Aug 2016 + +subroutine FCIDUMP_OUTPUT(NACT,NELEC,TWOMS,ISYM,ORBSYM,ECONST,OEI,TEI,LINSIZE,NUM_TEI) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: NACT, NELEC, TWOMS, ISYM, ORBSYM(NACT), LINSIZE, NUM_TEI +real(kind=wp), intent(in) :: ECONST, OEI(LINSIZE), TEI(NUM_TEI) +integer(kind=iwp) :: i, j, k, l, ij, kl, ijkl, writeout +integer(kind=iwp), external :: isFreeUnit + +writeout = isfreeunit(28) +!open(unit=writeout,file='FCIDUMP_CHEMPS2',action='write',status='replace') +call molcas_open(writeout,'FCIDUMP_CHEMPS2') +write(writeout,'(a11,i3,a7,i3,a5,i2,a1)') ' &FCI NORB=',NACT,',NELEC=',NELEC,',MS2=',TWOMS,',' +write(writeout,'(a9)',advance='NO') ' ORBSYM=' +do i=1,NACT + write(writeout,'(i1,a1)',advance='NO') ORBSYM(i),',' +end do +write(writeout,*) +write(writeout,'(a7,i1,a1)') ' ISYM=',ISYM,',' +write(writeout,'(a2)') ' /' + +do i=1,NACT + do j=1,i + ij = ((i-1)*i)/2+(j-1) + do k=1,NACT + do l=1,k + kl = ((k-1)*k)/2+(l-1) + if (kl <= ij) then + ijkl = 1+(ij*(ij+1))/2+kl + if (abs(TEI(ijkl)) >= 1.0e-16_wp) then + write(writeout,'(1x,es23.16e2,i4,i4,i4,i4)') TEI(ijkl),i,j,k,l + end if + end if + end do + end do + end do +end do + +do i=1,NACT + do j=1,i + ij = 1+((i-1)*i)/2+(j-1) + if (abs(OEI(ij)) >= 1.0e-16_wp) then + write(writeout,'(1x,es23.16e2,i4,i4,i4,i4)') OEI(ij),i,j,0,0 + end if + end do +end do + +write(writeout,'(1x,es23.16e2,i4,i4,i4,i4)') ECONST,0,0,0,0 + +close(writeout) + +return + +end subroutine FCIDUMP_OUTPUT diff -Nru openmolcas-22.02/src/misc_util/fmmm.f openmolcas-22.10/src/misc_util/fmmm.f --- openmolcas-22.02/src/misc_util/fmmm.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/misc_util/fmmm.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE FMMM(A,B,C,NROW,NCOL,NSUM) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(NROW,NSUM),B(NSUM,NCOL),C(NROW,NCOL) - PARAMETER (KS=48) -C - DO 100 I = 1, NROW - DO 200 J = 1, NCOL - C(I,J) = 0.0D0 - 200 CONTINUE - 100 CONTINUE -C - DO 300 KK = 1, NSUM, KS - DO 400 I = 1, NROW - DO 500 J = 1, NCOL - T = C(I,J) - DO 600 K = KK,MIN(KK+KS-1,NSUM) - T = T + B(K,J) * A(I,K) - 600 CONTINUE - C(I,J) = T - 500 CONTINUE - 400 CONTINUE - 300 CONTINUE -C - RETURN - END diff -Nru openmolcas-22.02/src/misc_util/getdiagscr.f openmolcas-22.10/src/misc_util/getdiagscr.f --- openmolcas-22.02/src/misc_util/getdiagscr.f 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/misc_util/getdiagscr.f 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,30 @@ +************************************************************************ +* This file is part of OpenMolcas. * +* * +* OpenMolcas is free software; you can redistribute it and/or modify * +* it under the terms of the GNU Lesser General Public License, v. 2.1. * +* OpenMolcas is distributed in the hope that it will be useful, but it * +* is provided "as is" and without any express or implied warranties. * +* For more details see the full text of the license in the file * +* LICENSE or in . * +* * +* Copyright (C) 2022, Jie J. Bao * +************************************************************************ +* **************************************************************** +* history: * +* Jie J. Bao, on Jul 01, 2022, created this file. * +* **************************************************************** + + + Subroutine GetDiagScr(nScr,Mat,EigVal,nDim) + INTEGER nScr,nDim,INFO + Real*8 Mat(nDim**2) + Real*8 EigVal(nDim) + Real*8 Scr(2) + + CALL DSYEV_('V','U',nDim,Mat,nDim,EigVal,Scr,-1,INFO) + NScr=INT(Scr(1)) + RETURN + End Subroutine + + diff -Nru openmolcas-22.02/src/misc_util/getseed.f openmolcas-22.10/src/misc_util/getseed.f --- openmolcas-22.02/src/misc_util/getseed.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/misc_util/getseed.f 2022-10-10 14:22:40.000000000 +0000 @@ -15,12 +15,6 @@ Character Line*72 Integer*8 hours,minutes,seconds,days Character*100, External :: Get_ProgName - Interface - Subroutine datimx(TimeStamp) Bind(C,name='datimx_') - Use, Intrinsic :: iso_c_binding, Only: c_char - Character(kind=c_char) :: TimeStamp(*) - End Subroutine - End Interface * * Externally defined seed Call getenvf('MOLCAS_RANDOM_SEED',Line) diff -Nru openmolcas-22.02/src/misc_util/icunp.f openmolcas-22.10/src/misc_util/icunp.f --- openmolcas-22.02/src/misc_util/icunp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/misc_util/icunp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - INTEGER FUNCTION ICUNP(ICSPCK,L) - DIMENSION ICSPCK(*) - - INTW=ICSPCK((L+14)/15) - IPOW=2**(28-2*MOD(L-1,15)) - ICUNP=MOD(INTW/IPOW,4) - RETURN - END diff -Nru openmolcas-22.02/src/misc_util/index_functions.F90 openmolcas-22.10/src/misc_util/index_functions.F90 --- openmolcas-22.02/src/misc_util/index_functions.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/misc_util/index_functions.F90 2022-10-10 14:22:40.000000000 +0000 @@ -16,7 +16,7 @@ implicit none private -public :: C_Ind, C_Ind3, iTri, nTri_Elem, nTri_Elem1, nTri3_Elem, nTri3_Elem1 +public :: C3_Ind, C3_Ind3, C_Ind, C_Ind3, C_Ind3_Rev, iTri, iTri_Rev, nTri3_Elem, nTri3_Elem1, nTri_Elem, nTri_Elem1 #include "macros.fh" @@ -47,6 +47,33 @@ C_Ind3 = (ly+lz)*(ly+lz+1)/2+lz+1 end function C_Ind3 +! Cumulative C_Ind, including all previous l values +pure function C3_Ind(l,lx,lz) + integer(kind=iwp) :: C3_Ind + integer(kind=iwp), intent(in) :: l, lx, lz + C3_Ind = l*(l+1)*(l+2)/6+(l-lx)*(l-lx+1)/2+lz+1 +end function C3_Ind + +! Same as C3_Ind, but from lx, ly, lz directly +pure function C3_Ind3(lx,ly,lz) + integer(kind=iwp) :: C3_Ind3 + integer(kind=iwp), intent(in) :: lx, ly, lz + C3_Ind3 = (lx+ly+lz)*(lx+ly+lz+1)*(lx+ly+lz+2)/6+(ly+lz)*(ly+lz+1)/2+lz+1 +end function C3_Ind3 + +! Inverse of C_Ind3: from the index and l, return lx, ly, lz +pure function C_Ind3_Rev(lxyz,l) + use Constants, only: Seven, Eight + integer(kind=iwp) :: C_Ind3_Rev(3) + integer(kind=iwp), intent(in) :: lxyz, l + integer(kind=iwp) :: lx, ly, lyz, lz + lyz = (int(sqrt(Eight*lxyz-Seven))-1)/2 + lz = lxyz-lyz*(lyz+1)/2-1 + ly = lyz-lz + lx = l-lyz + C_Ind3_Rev(:) = [lx,ly,lz] +end function C_Ind3_Rev + ! Number of elements in a triangular matrix of side n ! ! n nTri_Elem @@ -95,10 +122,22 @@ pure function iTri(i,j) integer(kind=iwp) :: iTri integer(kind=iwp), intent(in) :: i, j - integer(kind=iwp) :: ii, jj - ii = max(i,j) - jj = min(i,j) - iTri = ii*(ii-1)/2+jj + if (j > i) then + iTri = j*(j-1)/2+i + else + iTri = i*(i-1)/2+j + end if end function iTri +! Inverse of iTri: from the index, return i and j +pure function iTri_Rev(ij) + use Constants, only: Seven, Eight + integer(kind=iwp) :: iTri_Rev(2) + integer(kind=iwp), intent(in) :: ij + integer(kind=iwp) :: i, j + i = (int(sqrt(Eight*ij-Seven))+1)/2 + j = ij-i*(i-1)/2 + iTri_Rev(:) = [i,j] +end function iTri_Rev + end module diff -Nru openmolcas-22.02/src/misc_util/jacscf.f openmolcas-22.10/src/misc_util/jacscf.f --- openmolcas-22.02/src/misc_util/jacscf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/misc_util/jacscf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,164 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE JACSCF (A,B,C,NAA,NQQ,EPSLON) - IMPLICIT real*8 (A-H,O-Z) -C VERSION 4 AUGUST 1971 -C SUBROUTINE TO FIND ALL THE EIGENVALUES AND EIGENVECTORS OF A -C BY THE JACOBI METHOD -C THIS PROGRAM TREATS THE ORTHOGONAL CASE (S=1) -C NAA=DIMENSION OF A,B,C -C A TRIANGULAR, B MATRIX OF VECTORS, C EIGENVALUES -C B CLEARED TO UNIT MATRIX IF NQ=-1, NOT CLEARED IF NQ= NO. ROWS B -C NQ MUST NOT BE LESS THAN NAA -C EPSLON IS THE CONVERGENCE CRITERIA FOR OFF DIAGONAL ELEMENTS - DIMENSION A(*),B(*),C(*) -*------ -* POW: Unnecessary but warning stopping initialization - term=1.0d30 -*------ - NQ=NQQ - LOOPC=0 - NA=NAA - NN=(NA*(NA+1))/2 -c IF (NQ) 10,10,50 - IF (NQ.gt.0) goto 50 -c10 CONTINUE - K=1 - NQ=NA - DO 40 I=1,NA - DO 41 J=1,NA -c IF (I-J) 20,30,20 - IF (I.eq.J) goto 30 -c20 CONTINUE - B(K)=0.0D00 - GO TO 42 -30 B(K)=1.0D00 -42 K=K+1 -41 CONTINUE -40 CONTINUE -50 SUM=0.0D00 -c IF (NA-1) 330,310,60 - IF (NA-1.lt.0) goto 330 - IF (NA-1.eq.0) goto 310 -c60 CONTINUE - K=1 - AMAX=0.0D00 - DO 110 I=1,NA - DO 100 J=1,I -c IF (I-J) 70,90,70 - IF (I.eq.J) goto 90 -c70 IF (ABS(A(K))-AMAX) 90,90,80 - IF (ABS(A(K))-AMAX.le.0) goto 90 -c80 CONTINUE - AMAX=ABS(A(K)) -90 TERM=A(K)*A(K) - SUM=SUM+TERM+TERM - K=K+1 -100 CONTINUE - SUM=SUM-TERM -110 CONTINUE - SUM=SQRT(SUM) - THRESH=SUM/SQRT(dble(NA)) - THRSHG=THRESH*EPSLON -c IF (THRSHG-AMAX) 120,310,310 - IF (THRSHG-AMAX.ge.0) goto 310 -c120 CONTINUE - THRESH=AMAX/3. -c IF (THRESH-THRSHG) 130,140,140 - IF (THRESH-THRSHG.ge.0) goto 140 -c130 CONTINUE - THRESH=THRSHG -140 K=2 - N=0 - JD=1 - KDX=0 - DO 250 J=2,NA - ID=0 - JD=JD+J - JJ=J-1 - KC=0 - KDX=KDX+NQ - DO 240 I=1,JJ - ID=ID+I - IF (ABS(A(K)).GT.THRESH) GO TO 150 - KC=KC+NQ - GO TO 241 -150 N=N+1 - ALPHA=(A(JD)-A(ID))/(2.*A(K)) - BETA=1.0D00/(1.0D00+ALPHA*ALPHA) - ROOT=1.0D00+ABS(ALPHA)*SQRT(BETA) - SSQ=BETA/(2*ROOT) - CSQ=ROOT/2 - CC=SQRT(CSQ) - S=-SQRT(SSQ)*SIGN(1.0D00,ALPHA) - TWOSC=2*CC*S - TEMPA=CSQ*A(ID)+TWOSC*A(K)+SSQ*A(JD) - A(JD)=CSQ*A(JD)-TWOSC*A(K)+SSQ*A(ID) - A(ID)=TEMPA - A(K)=0.0D00 - KA=JD-J - KB=ID-I - KD=KDX - DO 230 L=1,NQ - KC=KC+1 - KD=KD+1 - TEMPA=CC*B(KC)+S*B(KD) - B(KD)=-S*B(KC)+CC*B(KD) - B(KC)=TEMPA - IF (L.GT.NA) GO TO 230 -c IF (I-L) 180,160,200 - IF (I-L.lt.0) goto 180 - if (I-L.gt.0) goto 200 -c160 CONTINUE - KB=KB+1 -170 KA=KA+1 - GO TO 230 -180 KB=KB+L-1 -c IF (J-L) 190,170,210 - IF (J-L.eq.0) goto 170 - IF (J-L.gt.0) goto 210 -c190 CONTINUE - KA=KA+L-1 - GO TO 220 -200 KB=KB+1 -210 KA=KA+1 -220 TEMPA=CC*A(KB)+S*A(KA) - A(KA)=-S*A(KB)+CC*A(KA) - A(KB)=TEMPA -230 CONTINUE -241 K=K+1 -240 CONTINUE - K=K+1 -250 CONTINUE - LOOPC=LOOPC+1 -c IF (LOOPC-50) 260,340,340 - IF (LOOPC-50.ge.0) goto 340 -c260 IF (N-NN/8) 270,270,140 - IF (N-NN/8.gt.0) goto 140 -c270 IF (THRESH-THRSHG) 280,300,280 - IF (THRESH-THRSHG.eq.0) goto 300 -c280 CONTINUE - THRESH=THRESH/3. -c IF (THRESH-THRSHG) 290,140,140 - IF (THRESH-THRSHG.ge.0) goto 140 -c290 CONTINUE - THRESH=THRSHG - GO TO 140 -c300 IF (N) 140,310,140 -300 IF (N.ne.0) goto 140 -310 LL=0 - DO 320 L=1,NA - LL=LL+L - C(L)=A(LL) -320 CONTINUE -340 CONTINUE -330 RETURN - END diff -Nru openmolcas-22.02/src/misc_util/lapack_wrappers.f90 openmolcas-22.10/src/misc_util/lapack_wrappers.f90 --- openmolcas-22.02/src/misc_util/lapack_wrappers.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/misc_util/lapack_wrappers.f90 2022-10-10 14:22:40.000000000 +0000 @@ -210,7 +210,6 @@ integer n_, lda_, sdim_, ldvs_, lwork_, info_ real*8 a( lda_, * ), wr( * ), wi( * ), vs( ldvs_, *), work( * ) logical select, bwork( * ) - external sdim #ifdef MOLCAS_TO_LAPACK_INT LAPACKINT n, lda, sdim, ldvs, lwork, info n=n_ diff -Nru openmolcas-22.02/src/misc_util/lcopy.f openmolcas-22.10/src/misc_util/lcopy.f --- openmolcas-22.02/src/misc_util/lcopy.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/misc_util/lcopy.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,80 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1992, Markus P. Fuelscher * -************************************************************************ - Subroutine lCopy(N,X,incX,Y,incY) -************************************************************************ -* * -* purpose: * -* Copy vectors of integers * -* * -* calling arguments: * -* N : Number of elements * -* X : input vector * -* incX : stride for vector X * -* X : output vector * -* incY : stride for vector Y * -* LuCom : FORTRAN unit number * -* * -*----------------------------------------------------------------------* -* * -* written by: * -* M. P. Fuelscher * -* University of Lund, Sweden, 1992 * -* * -*----------------------------------------------------------------------* -* * -* history: none * -* * -************************************************************************ -* - Implicit Integer (A-Z) - Logical X,Y - Dimension X(1+incX*(N-1)),Y(1+incY*(N-1)) -* -*----------------------------------------------------------------------* -* Start procedure * -*----------------------------------------------------------------------* - If ( N.eq.0 ) Return - If ( N.lt.0 ) Then - Write (6,*) 'lcopy: N.lt.0' - Write (6,*) 'N=',N - Call Abend() - End If - If ( incX.eq.1 .and. incY.eq.1 ) then - M=Mod(N,4) - If ( M.gt.0 ) then - Do 10 i=1,M - Y(i)=X(i) -10 Continue - End If - Do 20 i=M+1,N,4 - Y(i )=X(i ) - Y(i+1)=X(i+1) - Y(i+2)=X(i+2) - Y(i+3)=X(i+3) -20 Continue - Else - iX = 1 - iY = 1 - If (incX.lt.0 ) iX=(-N+1)*incX+1 - If (incY.lt.0 ) iY=(-N+1)*incY+1 - Do 30 i=1,N - Y(iY)=X(iX) - iX=iX+incX - iY=iY+incY -30 Continue - End If -*----------------------------------------------------------------------* -* End procedure * -*----------------------------------------------------------------------* - Return - End diff -Nru openmolcas-22.02/src/misc_util/mspdfmat.f openmolcas-22.10/src/misc_util/mspdfmat.f --- openmolcas-22.02/src/misc_util/mspdfmat.f 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/misc_util/mspdfmat.f 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,106 @@ +*********************************************************************** +* This file is part of OpenMolcas. * +* * +* OpenMolcas is free software; you can redistribute it and/or modify * +* it under the terms of the GNU Lesser General Public License, v. 2.1. * +* OpenMolcas is distributed in the hope that it will be useful, but it * +* is provided "as is" and without any express or implied warranties. * +* For more details see the full text of the license in the file * +* LICENSE or in . * +* * +* Copyright (C) 2022, Jie J. Bao * +************************************************************************ +****************************************************************** +* history: * +* Jie J. Bao, on May. 19, 2022, created this file. * +****************************************************************** +************************************************************************ + Subroutine PrintMat2(FileName,MatInfo,Matrix,NRow,NCol, + & LenName,LenInfo,Trans) + + +* This subroutine is to replace PrintMat in the long run. +* Matrix is now a nRow*nCol array. +* Note that the column index is the fast running index in Fortran, +* so when TRANS='T', it prints the matrix by proceeding with the +* fast-running index. + + INTEGER NRow,NCol,LenName + CHARACTER(Len=LenName)::FileName + CHARACTER(Len=LenInfo)::MatInfo + CHARACTER(Len=1)::Trans + CHARACTER(Len=80)::PrtFmt + Real*8,DIMENSION(NRow*NCol)::Matrix + + INTEGER LU,IsFreeUnit,IRow,ICol,iOff + External IsFreeUnit + + IF(LenName.gt.0) THEN + LU=100 + LU=IsFreeUnit(LU) + CALL Molcas_Open(LU,FileName) + ELSE + LU=6 + END IF + IF(Trans.eq.'T') THEN + WRITE(PrtFmt,'(A1,I5,A14)') + & '(',NCol,'(E24.14E4,1X))' + DO IRow=1,NRow + iOff=(IRow-1)*nCol + write(LU,PrtFmt) + & (Matrix(iOff+ICol),ICol=1,NCol) + END DO + ELSE + WRITE(PrtFmt,'(A1,I5,A14)') + & '(',NRow,'(E24.14E4,1X))' + DO ICol=1,NCol + write(LU,PrtFmt) + & (Matrix((iRow-1)*nCol+iCol),IRow=1,NRow) + END DO + END IF + WRITE(LU,*)MatInfo + IF(LenName.gt.0) THEN + Close(LU) + END IF + RETURN + End Subroutine + +****************************************************** + Subroutine ReadMat2(FileName,MatInfo,Matrix,NRow,NCol, + &LenName,LenInfo,Trans) + +* This subroutine is to replace ReadMat in the long run. + INTEGER NRow,NCol,LenName + CHARACTER(Len=LenName)::FileName + CHARACTER(Len=LenInfo)::MatInfo + CHARACTER(Len=1)::Trans + Real*8,DIMENSION(NRow*NCol)::Matrix + + INTEGER LU,IsFreeUnit,IRow,ICol,iOff + External IsFreeUnit + + IF(LenName.gt.0) THEN + LU=100 + LU=IsFreeUnit(LU) + CALL Molcas_Open(LU,FileName) + ELSE + LU=6 + END IF + IF(Trans.eq.'T') THEN + DO IRow=1,NRow + iOff=(IRow-1)*nCol + read(LU,*) (Matrix(iOff+ICol),ICol=1,NCol) + END DO + ELSE + DO ICol=1,NCol + read(LU,*) (Matrix((iRow-1)*nCol+iCol),IRow=1,NRow) + END DO + END IF + Read(LU,*)MatInfo + IF(LenName.gt.0) THEN + Close(LU) + END IF + RETURN + End Subroutine +****************************************************** + diff -Nru openmolcas-22.02/src/misc_util/prcoor.f openmolcas-22.10/src/misc_util/prcoor.f --- openmolcas-22.02/src/misc_util/prcoor.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/misc_util/prcoor.f 2022-10-10 14:22:40.000000000 +0000 @@ -8,7 +8,7 @@ * For more details see the full text of the license in the file * * LICENSE or in . * ************************************************************************ - Subroutine PrCoor + Subroutine PrCoor() ************************************************************************ * * * purpose: Write coordinates. * diff -Nru openmolcas-22.02/src/misc_util/sorting.F90 openmolcas-22.10/src/misc_util/sorting.F90 --- openmolcas-22.02/src/misc_util/sorting.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/misc_util/sorting.F90 2022-10-10 14:22:40.000000000 +0000 @@ -286,9 +286,9 @@ !> Either A or B is allowed to overlap with the second half !> of the output array C. !> -!> @param[inout] A Sorted 1D-array to be merged. -!> @param[inout] B Sorted 1D-array to be merged. -!> @param[inout] C Merged and sorted 1D-array. +!> @param[in,out] A Sorted 1D-array to be merged. +!> @param[in,out] B Sorted 1D-array to be merged. +!> @param[in,out] C Merged and sorted 1D-array. !> @param[in] compare A logical pure function of two integer arguments. subroutine merge_(A,B,C,compare) ! The target attribute is there to prevent the compiler from diff -Nru openmolcas-22.02/src/misc_util/vdiv.f openmolcas-22.10/src/misc_util/vdiv.f --- openmolcas-22.02/src/misc_util/vdiv.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/misc_util/vdiv.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE VDIV(A,LA,B,LB,C,LC,N) - Implicit Real*8 (a-h,o-z) - DIMENSION A(*),B(*),C(*) - DO 10 I=0,N-1 - C(1+LC*I)=B(1+LB*I)/A(1+LA*I) -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/misc_util/vsma.f openmolcas-22.10/src/misc_util/vsma.f --- openmolcas-22.02/src/misc_util/vsma.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/misc_util/vsma.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE VSMA(A,LA,S,B,LB,C,LC,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(*),B(*),C(*) - DO 10 I=0,N-1 - C(1+LC*I)=A(1+LA*I)*S+B(1+LB*I) - 10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/misc_util/vsmul.f openmolcas-22.10/src/misc_util/vsmul.f --- openmolcas-22.02/src/misc_util/vsmul.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/misc_util/vsmul.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE VSMUL(A,LA,S,C,LC,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(*),C(*) - DO 10 I=0,N-1 - C(1+LC*I)=A(1+LA*I)*S -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/misc_util/wr_guga_info.f openmolcas-22.10/src/misc_util/wr_guga_info.f --- openmolcas-22.02/src/misc_util/wr_guga_info.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/misc_util/wr_guga_info.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine WR_GUGA(Lu,iOpt,iDisk, - & NFREF,S,N,LN,NSYM,IR1,IR2,IFIRST,INTNUM, - & LSYM,NREF,LN1,NRLN1,MUL,nMUL,NSH,NISH,MxSym, - & JRC,nJRC,JJS,nJJS,NVAL,IOCR,nIOCR) - Implicit Real*8 (a-h,o-z) - Integer MUL(nMUL), NSH(MxSym), NISH(MxSym), JRC(nJRC), - & JJS(nJJS), NVAL(MxSym), IOCR(nIOCR) -* - Call s_iDaFile_guga(Lu,iOpt,NFREF, 1,iDisk) - Call s_dDaFile_guga(Lu,iOpt,S, 1,iDisk) - Call s_iDaFile_guga(Lu,iOpt,N, 1,iDisk) - Call s_iDaFile_guga(Lu,iOpt,LN, 1,iDisk) - Call s_iDaFile_guga(Lu,iOpt,NSYM, 1,iDisk) - Call s_iDaFile_guga(Lu,iOpt,IR1, 1,iDisk) - Call s_iDaFile_guga(Lu,iOpt,IR2, 1,iDisk) - Call s_iDaFile_guga(Lu,iOpt,IFIRST, 1,iDisk) - Call s_iDaFile_guga(Lu,iOpt,INTNUM, 1,iDisk) - Call s_iDaFile_guga(Lu,iOpt,LSYM, 1,iDisk) - Call s_iDaFile_guga(Lu,iOpt,NREF, 1,iDisk) - Call s_iDaFile_guga(Lu,iOpt,LN1, 1,iDisk) - Call s_iDaFile_guga(Lu,iOpt,NRLN1, 1,iDisk) - Call iDaFile(Lu,iOpt,MUL, nMUL,iDisk) - Call iDaFile(Lu,iOpt,NSH, MxSym,iDisk) - Call iDaFile(Lu,iOpt,NISH, MxSym,iDisk) - Call iDaFile(Lu,iOpt,JRC, nJRC,iDisk) - Call iDaFile(Lu,iOpt,JJS, nJJS,iDisk) - Call iDaFile(Lu,iOpt,NVAL, MxSym,iDisk) - Call iDaFile(Lu,iOpt,IOCR, nIOCR,iDisk) -* - Return -* -* This is to allow type punning without an explicit interface - Contains - Subroutine s_iDaFile_guga(Lu,iOpt,Buf,lBuf_,iDisk_) - Use Iso_C_Binding - Integer Lu, iOpt, lBuf_, iDisk_ - Integer, Target :: Buf - Integer, Pointer :: pBuf(:) - Call C_F_Pointer(C_Loc(Buf),pBuf,[1]) - Call iDaFile(Lu,iOpt,pBuf,lBuf_,iDisk_) - Nullify(pBuf) - End Subroutine s_iDaFile_guga - Subroutine s_dDaFile_guga(Lu,iOpt,Buf,lBuf_,iDisk_) - Use Iso_C_Binding - Integer Lu, iOpt, lBuf_, iDisk_ - Real*8, Target :: Buf - Real*8, Pointer :: pBuf(:) - Call C_F_Pointer(C_Loc(Buf),pBuf,[1]) - Call dDaFile(Lu,iOpt,pBuf,lBuf_,iDisk_) - Nullify(pBuf) - End Subroutine s_dDaFile_guga -* - End diff -Nru openmolcas-22.02/src/mma_util/cgetmem.c openmolcas-22.10/src/mma_util/cgetmem.c --- openmolcas-22.02/src/mma_util/cgetmem.c 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mma_util/cgetmem.c 2022-10-10 14:22:40.000000000 +0000 @@ -23,7 +23,7 @@ /* history: Initial revision */ /* */ /******************************************************************************/ -#ifdef _DEBUGPRINT_MEM_ +#ifdef _DEBUGPRINT_MEM_ #define _MEMORY_TRACE_ #endif #ifdef _CYGWIN_ diff -Nru openmolcas-22.02/src/mma_util/stdalloc.f openmolcas-22.10/src/mma_util/stdalloc.f --- openmolcas-22.02/src/mma_util/stdalloc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mma_util/stdalloc.f 2022-10-10 14:22:40.000000000 +0000 @@ -255,6 +255,12 @@ # undef _DIMENSIONS_ # undef _DEF_LABEL_ +# define _DIMENSIONS_ 5 +# define _DEF_LABEL_ 'imma_5D' +# include "mma_allo_template.fh" +# undef _DIMENSIONS_ +# undef _DEF_LABEL_ + #undef _SUBR_NAME_ #undef _TYPE_ #undef _DATA_NAME_ diff -Nru openmolcas-22.02/src/molcas_ci_util/cidia_ci_util.F90 openmolcas-22.10/src/molcas_ci_util/cidia_ci_util.F90 --- openmolcas-22.02/src/molcas_ci_util/cidia_ci_util.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/molcas_ci_util/cidia_ci_util.F90 2022-10-10 14:22:40.000000000 +0000 @@ -19,6 +19,7 @@ ! IREFSM: REFERENCE SYMMETRY ! CSFDIA: DIAGONAL OF CI MATRIX IN CSF BASIS +use csfbas, only: CTS use stdalloc, only: mma_allocate, mma_deallocate use Definitions, only: wp, iwp, r8 @@ -31,7 +32,6 @@ real(kind=r8), external :: Get_eCore #include "ciinfo.fh" #include "spinfo.fh" -#include "csfbas.fh" #include "WrkSpc.fh" #include "timers.fh" #include "output_ras.fh" @@ -50,7 +50,7 @@ IPRINT = 0 if (IPRLEV == INSANE) IPRINT = 40 -call CSDIAG_CI_UTIL(NCONF,ndet,CSFDIA,DDIA,NCNFTP(1,IREFSM),NTYP,iWork(KICTS(1)),NDTFTP,NCSFTP,IPRINT) +call CSDIAG_CI_UTIL(NCONF,ndet,CSFDIA,DDIA,NCNFTP(1,IREFSM),NTYP,CTS,NDTFTP,NCSFTP,IPRINT) eCore_Hex = Get_eCore() CSFDIA(:) = CSFDIA(:)+eCore_Hex diff -Nru openmolcas-22.02/src/molcas_ci_util/CMakeLists.txt openmolcas-22.10/src/molcas_ci_util/CMakeLists.txt --- openmolcas-22.02/src/molcas_ci_util/CMakeLists.txt 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/molcas_ci_util/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -22,6 +22,7 @@ cnhcn.F90 csdiag_ci_util.F90 csdtvc.F90 + csfbas.F90 cstart_ci_util.F90 davctl.F90 davctl_mod.F90 @@ -87,6 +88,8 @@ ) # Source files defining modules that should be available to other *_util directories -set (modfile_list "") +set (modfile_list + csfbas.F90 +) include (${PROJECT_SOURCE_DIR}/cmake/util_template.cmake) diff -Nru openmolcas-22.02/src/molcas_ci_util/csfbas.F90 openmolcas-22.10/src/molcas_ci_util/csfbas.F90 --- openmolcas-22.02/src/molcas_ci_util/csfbas.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/molcas_ci_util/csfbas.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,24 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +module csfbas + +use Definitions, only: iwp + +implicit none +private + +integer(kind=iwp) :: KCFTP, KDFTP, KDTOC, MAXOP_LUCIA +integer(kind=iwp), allocatable :: CONF(:), CTS(:) + +public :: CONF, CTS, KCFTP, KDFTP, KDTOC, MAXOP_LUCIA + +end module csfbas diff -Nru openmolcas-22.02/src/molcas_ci_util/cstart_ci_util.F90 openmolcas-22.10/src/molcas_ci_util/cstart_ci_util.F90 --- openmolcas-22.02/src/molcas_ci_util/cstart_ci_util.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/molcas_ci_util/cstart_ci_util.F90 2022-10-10 14:22:40.000000000 +0000 @@ -47,6 +47,7 @@ #ifdef _HDF5_ use mh5, only: mh5_is_hdf5, mh5_open_file_r, mh5_fetch_dset,mh5_close_file #endif +use csfbas, only: CONF, KCFTP use stdalloc, only: mma_allocate, mma_deallocate use Constants, only: Zero, One use Definitions, only: wp, iwp, u6 @@ -69,7 +70,6 @@ #include "rasdim.fh" #include "general.fh" #include "rasscf.fh" -#include "csfbas.fh" #include "WrkSpc.fh" #include "output_ras.fh" @@ -129,7 +129,7 @@ call mma_allocate(vkcnf,nactel,label='kcnf') do i=1,lRoots call mh5_fetch_dset(mh5id,'CI_VECTORS',Tmp1,[nconf,1],[0,i-1]) - call Reord2(NAC,NACTEL,STSYM,1,iWork(KICONF(1)),iWork(KCFTP),Tmp1,C,vkcnf) + call Reord2(NAC,NACTEL,STSYM,1,CONF,iWork(KCFTP),Tmp1,C,vkcnf) call Save_CI_vec(i,nConf,C,LuDavid) end do call mma_deallocate(Tmp1) @@ -168,7 +168,7 @@ call mma_allocate(vkcnf,nactel,label='kcnf') do i=1,lRoots call DDafile(JOBOLD,2,Tmp1,nConf,iDisk) - call Reord2(NAC,NACTEL,STSYM,1,iWork(KICONF(1)),iWork(KCFTP),Tmp1,C,vkcnf) + call Reord2(NAC,NACTEL,STSYM,1,CONF,iWork(KCFTP),Tmp1,C,vkcnf) call Save_CI_vec(i,nConf,C,LuDavid) if (IPRLEV >= INSANE) then write(String,'(A,I2)') 'Start vector of root',i diff -Nru openmolcas-22.02/src/molcas_ci_util/david5.F90 openmolcas-22.10/src/molcas_ci_util/david5.F90 --- openmolcas-22.02/src/molcas_ci_util/david5.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/molcas_ci_util/david5.F90 2022-10-10 14:22:40.000000000 +0000 @@ -13,6 +13,7 @@ use citrans, only: citrans_csf2sd, citrans_sd2csf, citrans_sort +use csfbas, only: CONF, CTS, KCFTP, KDTOC use faroald, only: my_norb, ndeta, ndetb, sigma_update use davctl_mod, only: istart, n_Roots, nkeep, nvec use stdalloc, only: mma_allocate, mma_deallocate @@ -24,7 +25,6 @@ #include "rasrc.fh" #include "rasscf.fh" #include "general.fh" -#include "csfbas.fh" #include "WrkSpc.fh" #include "timers.fh" #include "rasscf_lucia.fh" @@ -159,7 +159,7 @@ call mma_allocate(psi,ndeta,ndetb,label='psi') VECSVC(:) = Zero - call REORD2(MY_NORB,NACTEL,1,0,IWORK(KICONF(1)),IWORK(KCFTP),VEC1,VECSVC,VKCNF) + call REORD2(MY_NORB,NACTEL,1,0,CONF,IWORK(KCFTP),VEC1,VECSVC,VKCNF) call CITRANS_SORT('C',VECSVC,VEC2) PSI = Zero call CITRANS_CSF2SD(VEC2,PSI) @@ -167,7 +167,7 @@ call SIGMA_UPDATE(HTU,GTUVX,SGM,PSI) call CITRANS_SD2CSF(SGM,VEC2) call CITRANS_SORT('O',VEC2,VECSVC) - call Reord2(my_norb,NACTEL,1,1,iWork(KICONF(1)),iWork(KCFTP),VECSVC,VEC2,VKCNF) + call Reord2(my_norb,NACTEL,1,1,CONF,iWork(KCFTP),VECSVC,VEC2,VKCNF) if (iprlev >= DEBUG) then FP = DNRM2_(NCONF,VEC2,1) @@ -181,13 +181,13 @@ ! Convert the CI-vector from CSF to Det. basis ctemp(1:nConf) = Vec1(:) sigtemp(:) = Zero - call csdtvc(ctemp,sigtemp,1,work(kdtoc),iwork(kicts(1)),stSym,1) + call csdtvc(ctemp,sigtemp,1,work(kdtoc),cts,stSym,1) c_pointer = ip_of_Work(ctemp(1)) ! Calling Lucia to determine the sigma vector call Lucia_Util('Sigma',iDummy,iDummy,Dummy) ! Set mark so densi_master knows that the Sigma-vector exists on disk. iSigma_on_disk = 1 - call CSDTVC(Tmp,ctemp,2,work(kdtoc),iWork(kicts(1)),stSym,1) + call CSDTVC(Tmp,ctemp,2,work(kdtoc),cts,stSym,1) if (iprlev >= DEBUG) then FP = DNRM2_(NCONF,VEC2,1) diff -Nru openmolcas-22.02/src/molcas_ci_util/explh2.F90 openmolcas-22.10/src/molcas_ci_util/explh2.F90 --- openmolcas-22.02/src/molcas_ci_util/explh2.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/molcas_ci_util/explh2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -47,6 +47,7 @@ ! * !*********************************************************************** +use csfbas, only: CONF, KDFTP, KDTOC use stdalloc, only: mma_allocate, mma_deallocate use Constants, only: Zero, One use Definitions, only: wp, iwp @@ -65,7 +66,6 @@ #include "rasscf.fh" #include "general.fh" #include "ciinfo.fh" -#include "csfbas.fh" #include "strnum.fh" #include "WrkSpc.fh" #include "timers.fh" @@ -100,8 +100,8 @@ call mma_maxDBLE(MXXWS) call mma_allocate(Scr,MXXWS,label='EXHSCR') call GET_IREOTS(IREOTS,NAC) -call PHPCSF(EXHAM,ISEL,CNF,MXXSEL,Work(KDTOC),iWork(KDFTP),iWork(KICONF(1)),STSYM,HONE,ECORE,NAC,Scr,NCNASM(STSYM),NAEL+NBEL,NAEL, & - NBEL,NSEL,NPCNF,DIAG,TUVX,IPRINT,ExFac,IREOTS) +call PHPCSF(EXHAM,ISEL,CNF,MXXSEL,Work(KDTOC),iWork(KDFTP),CONF,STSYM,HONE,ECORE,NAC,Scr,NCNASM(STSYM),NAEL+NBEL,NAEL,NBEL,NSEL, & + NPCNF,DIAG,TUVX,IPRINT,ExFac,IREOTS) if (IPRLEV == INSANE) then call Square(EXHAM,EXPLV,1,NSEL,NSEL) call RECPRT('Square Explicit Hamiltonian',' ',EXPLV,NSEL,NSEL) diff -Nru openmolcas-22.02/src/molcas_ci_util/ini_david.F90 openmolcas-22.10/src/molcas_ci_util/ini_david.F90 --- openmolcas-22.02/src/molcas_ci_util/ini_david.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/molcas_ci_util/ini_david.F90 2022-10-10 14:22:40.000000000 +0000 @@ -148,14 +148,6 @@ save_mode = mixed_mode_2 if (mxMemStk < (nkeep+1)) save_mode = mixed_mode_1 end if -!FUE call GetMem(' ','nFld',' ',nMemStk,nMemStk) -!FUE nMemStk = nMemStk-30 -!FUE if (MxMemStk > nMemStk) then -!FUE MxMemStk = nMemStk -!FUE MxDiskStk = 1+2*mxKeep*nRoots+2*nRoots-mxMemStk -!FUE save_mode = mixed_mode_2 -!FUE If (mxMemStk < (mxKeep*nRoots+1)) save_mode = mixed_mode_1 -!FUE end if nMemStk = 0 nDiskStk = 0 diff -Nru openmolcas-22.02/src/molcas_ci_util/lucia2molcas.F90 openmolcas-22.10/src/molcas_ci_util/lucia2molcas.F90 --- openmolcas-22.02/src/molcas_ci_util/lucia2molcas.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/molcas_ci_util/lucia2molcas.F90 2022-10-10 14:22:40.000000000 +0000 @@ -14,6 +14,8 @@ nCSF_HEXS_LUCIA) ! Transfer arguments to the common blocks used by MOLCAS. +use csfbas, only: CONF, CTS, KCFTP, KDFTP, KDTOC, maxop_lucia +use stdalloc, only: mma_allocate use Definitions, only: iwp, u6 implicit none @@ -22,8 +24,8 @@ NCONF_PER_OPEN(MXPORB+1,MXPCSM), NPDTCNF(MXPORB+1), NPCSCNF(MXPORB+1), MULTS_LUCIA, nCSF_HEXS_LUCIA integer(kind=iwp), intent(out) :: KICTS_POINTER integer(kind=iwp) :: I, ICL, IOPEN, IORB2F, IORB2L, ISYM, ITYP, J, LCONF, LDET, LLCONF, LUCIA_TYPE, NEL1MNA, NEL1MNB, NEL2MN, NEL2MX +integer(kind=iwp), external :: ip_of_iWork #include "rasdim.fh" -#include "csfbas.fh" #include "ciinfo.fh" #include "spinfo.fh" #include "rasscf.fh" @@ -127,17 +129,13 @@ LDET = max(LDET,NDTASM(ISYM)) end do -call GetMem('KICONF','Allo','Integer',KICONF(1),LCONF) -call GetMem('KICTS','Allo','Integer',KICTS(1),LDET) -KICTS_POINTER = KICTS(1) +call mma_allocate(CONF,LCONF,label='CONF') +call mma_allocate(CTS,LDET,label='CTS') +KICTS_POINTER = ip_of_iWork(CTS(1)) -do I=1,LCONF - IWORK(KICONF(1)+I-1) = KICONF_OCC_LUCIA(I) -end do +CONF(:) = KICONF_OCC_LUCIA(1:LCONF) -do I=1,LDET - IWORK(KICTS(1)+I-1) = KSDREO_I(I) -end do +CTS(:) = KSDREO_I(1:LDET) NDET = NDET_LUCIA MULTS = MULTS_LUCIA diff -Nru openmolcas-22.02/src/molcas_ci_util/lucia2molcas_free.F90 openmolcas-22.10/src/molcas_ci_util/lucia2molcas_free.F90 --- openmolcas-22.02/src/molcas_ci_util/lucia2molcas_free.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/molcas_ci_util/lucia2molcas_free.F90 2022-10-10 14:22:40.000000000 +0000 @@ -11,17 +11,12 @@ subroutine LUCIA2MOLCAS_FREE() -use Definitions, only: iwp +use csfbas, only: CONF, CTS +use stdalloc, only: mma_deallocate implicit none -integer(kind=iwp) :: LCONF, LDET -#include "csfbas.fh" -! fake values -LCONF = 1 -LDET = 1 - -call GetMem('KICONF','Free','Integer',KICONF(1),LCONF) -call GetMem('KICTS','Free','Integer',KICTS(1),LDET) +call mma_deallocate(CONF) +call mma_deallocate(CTS) end subroutine LUCIA2MOLCAS_FREE diff -Nru openmolcas-22.02/src/molcas_ci_util/mkclist.F90 openmolcas-22.10/src/molcas_ci_util/mkclist.F90 --- openmolcas-22.02/src/molcas_ci_util/mkclist.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/molcas_ci_util/mkclist.F90 2022-10-10 14:22:40.000000000 +0000 @@ -19,7 +19,7 @@ implicit none #include "rasdim.fh" -#include "general.fh" +#include "general_mul.fh" #include "gugx.fh" integer(kind=iwp), intent(in) :: ISM(NLEV), IDOWN(NVERT,0:3), IOW(2,NSYM,NMIDV) integer(kind=iwp), intent(out) :: NOW(2,NSYM,NMIDV), ICASE(NICASE), ISCR(3,0:NLEV) diff -Nru openmolcas-22.02/src/molcas_ci_util/splitctl.F90 openmolcas-22.10/src/molcas_ci_util/splitctl.F90 --- openmolcas-22.02/src/molcas_ci_util/splitctl.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/molcas_ci_util/splitctl.F90 2022-10-10 14:22:40.000000000 +0000 @@ -31,6 +31,7 @@ ! * !*********************************************************************** +use csfbas, only: CONF, KCFTP, KDFTP, KDTOC use stdalloc, only: mma_allocate, mma_deallocate use Constants, only: Zero, One, auToeV use Definitions, only: wp, iwp, u6, r8 @@ -55,7 +56,6 @@ #include "ciinfo.fh" #include "WrkSpc.fh" #include "output_ras.fh" -#include "csfbas.fh" #include "strnum.fh" #include "timers.fh" @@ -153,8 +153,8 @@ call mma_allocate(Scr,MXXWS,label='EXHSCR') MXSpli = iDimBlockA !nAAblock = MXSpli*(MXSpli+1)/2 - call ipCSFSplit(Diag,IPCSFtot,IPCNFtot,nConf,MXSpli,Work(KDTOC),iWork(KDFTP),iWork(KICONF(1)),STSYM,HONE,ECORE,NAC,Scr, & - NCNASM(STSYM),(NAEL+NBEL),NAEL,NBEL,CIVEC,TUVX,IPRINT,ExFac,IREOTS) + call ipCSFSplit(Diag,IPCSFtot,IPCNFtot,nConf,MXSpli,Work(KDTOC),iWork(KDFTP),CONF,STSYM,HONE,ECORE,NAC,Scr,NCNASM(STSYM), & + NAEL+NBEL,NAEL,NBEL,CIVEC,TUVX,IPRINT,ExFac,IREOTS) !call DVCPRT('Diagonal elements of Hamilt. matrix in CSF',' ',Diag,nConf) call mma_deallocate(Scr) !call mma_deallocate(Diag) @@ -177,8 +177,8 @@ ! 'condition' goes to DiagOrd as a percentage if PerSplit if (EnerSplit) condition = gapSpli/auToeV if (PerSplit) condition = percSpli - call DiagOrd(Diag,DiagCNF,IPCSFtot,IPCNFtot,nConf,condition,ITER,Work(KDTOC),iWork(KDFTP),iWork(KICONF(1)),STSYM,HONE,ECORE, & - NAC,Scr,NCNASM(STSYM),(NAEL+NBEL),NAEL,NBEL,TUVX,IPRINT,ExFac,IREOTS) + call DiagOrd(Diag,DiagCNF,IPCSFtot,IPCNFtot,nConf,condition,ITER,Work(KDTOC),iWork(KDFTP),CONF,STSYM,HONE,ECORE,NAC,Scr, & + NCNASM(STSYM),(NAEL+NBEL),NAEL,NBEL,TUVX,IPRINT,ExFac,IREOTS) if (DBG) then call DVCPRT('Diagonal elements of Hamilt. matrix in CSF',' ',Diag,nConf) call DVCPRT('Diagonal elements of Hamilt. matrix in CNF',' ',DiagCNF,NCNASM(STSYM)) @@ -238,8 +238,8 @@ end if !call Compute_Umn(BVEC,NPCNF,NCNASM(STSYM),EnInSplit,NPCNF+1,1,DHAM) !call SPLITCSF(AABlock,EnInSplit,DHAM, - call get_Umn(AABlock,EnInSplit,DHAM,IPCSFtot,IPCNFtot,nconf,Work(KDTOC),iWork(KDFTP),iWork(KICONF(1)),STSYM,HONE,ECORE,NAC, & - NCNASM(STSYM),(NAEL+NBEL),NAEL,NBEL,iDimBlockA,iDimBlockACNF,TUVX,iterSplit,ITER,IPRINT,ExFac,IREOTS) + call get_Umn(AABlock,EnInSplit,DHAM,IPCSFtot,IPCNFtot,nconf,Work(KDTOC),iWork(KDFTP),CONF,STSYM,HONE,ECORE,NAC, & + NCNASM(STSYM),NAEL+NBEL,NAEL,NBEL,iDimBlockA,iDimBlockACNF,TUVX,iterSplit,ITER,IPRINT,ExFac,IREOTS) call xflush(u6) if (DBG) then call TRIPRT('AA block of the Hamiltonian Matrix',' ',AABlock,iDimBlockA) @@ -304,8 +304,7 @@ !call CmSplit(IPCSFtot,IPCNFtot, call cwtime(C_get_Cm1,W_get_Cm1) call get_Cm(IPCSFtot,IPCNFtot,nConf,NCNASM(STSYM),iDimBlockA,iDimBlockACNF,SplitV(:,lRootSplit),EnFinSplit,Work(KDTOC), & - iWork(KDFTP),iWork(KICONF(1)),STSYM,HONE,ECORE,NAC,(NAEL+NBEL),NAEL,NBEL,TUVX,IPRINT,ExFac,IREOTS,FordSplit, & - TotSplitV) + iWork(KDFTP),CONF,STSYM,HONE,ECORE,NAC,(NAEL+NBEL),NAEL,NBEL,TUVX,IPRINT,ExFac,IREOTS,FordSplit,TotSplitV) call cwtime(C_get_Cm2,W_get_Cm2) C_get_Cm3 = C_get_Cm3+C_get_Cm2-C_get_Cm1 W_get_Cm3 = W_get_Cm3+W_get_Cm2-W_get_Cm1 @@ -393,8 +392,8 @@ call mma_maxDBLE(MXXWS) call mma_allocate(Scr,MXXWS,label='EXHSCR') call GET_IREOTS(IREOTS,NAC) - call PHPCSF(AABlock,iSel,IPCNF,MXSpli,Work(KDTOC),iWork(KDFTP),iWork(KICONF(1)),STSYM,HONE,ECORE,NAC,Scr,NCNASM(STSYM), & - NAEL+NBEL,NAEL,NBEL,iDimBlockA,iDimBlockACNF,CIVEC,TUVX,IPRINT,ExFac,IREOTS) + call PHPCSF(AABlock,iSel,IPCNF,MXSpli,Work(KDTOC),iWork(KDFTP),CONF,STSYM,HONE,ECORE,NAC,Scr,NCNASM(STSYM),NAEL+NBEL,NAEL, & + NBEL,iDimBlockA,iDimBlockACNF,CIVEC,TUVX,IPRINT,ExFac,IREOTS) call mma_deallocate(Scr) if (DBG) then call TRIPRT('AA block of the Hamiltonian Matrix',' ',AABlock,iDimBlockA) @@ -492,7 +491,7 @@ call mma_allocate(vkcnf,nactel,label='kcnf') !do i=1,lRootSplit call DDafile(JOBOLD,2,Tmp1,nConf,iDisk) - call Reord2(NAC,NACTEL,STSYM,1,iWork(KICONF(1)),iWork(KCFTP),Tmp1,Tmp2,vkcnf) + call Reord2(NAC,NACTEL,STSYM,1,CONF,iWork(KCFTP),Tmp1,Tmp2,vkcnf) call Save_CI_vec(1,nConf,Tmp2,LuDavid) !write(u6,'(A,I2)') 'Start vector of root',i !if (DBG) then diff -Nru openmolcas-22.02/src/motra/motra.F90 openmolcas-22.10/src/motra/motra.F90 --- openmolcas-22.02/src/motra/motra.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/motra/motra.F90 2022-10-10 14:22:40.000000000 +0000 @@ -28,7 +28,7 @@ use motra_global, only: CMO, HOne, iCTonly, iDoInt, ihdf5, iOneOnly, iPrint, Kine, nTot2, Ovlp use stdalloc, only: mma_deallocate use Constants, only: Zero -use Definitions, only: iwp, wp, u6 +use Definitions, only: wp, iwp, u6 implicit none integer(kind=iwp), intent(out) :: ireturn diff -Nru openmolcas-22.02/src/motra/tr2ctl.F90 openmolcas-22.10/src/motra/tr2ctl.F90 --- openmolcas-22.02/src/motra/tr2ctl.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/motra/tr2ctl.F90 2022-10-10 14:22:40.000000000 +0000 @@ -41,7 +41,7 @@ call DANAME_MF(LUTWOMO,FNTWOMO) IAD13 = 0 -call iCopy(nTraToc,[0],0,iTraToc,1) +iTraToc(:) = 0 call iDAFILE(LUTWOMO,1,iTraToc,nTraToc,IAD13) ! Initiate unit LUTWOAO (two-electron integrals in AO basis) diff -Nru openmolcas-22.02/src/motra/tramo.F90 openmolcas-22.10/src/motra/tramo.F90 --- openmolcas-22.02/src/motra/tramo.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/motra/tramo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -43,9 +43,9 @@ ! Set some constants -call ICopy(mOVX,[-1],0,iDsk(1,1),3) -call ICopy(mOVX,[0],0,iDsk(2,1),3) -call ICopy(mOVX,[1],0,iDsk(3,1),3) +iDsk(1,:) = -1 +iDsk(2,:) = 0 +iDsk(3,:) = 1 #ifdef _HDF5_QCM_ if (ihdf5 == 1) then diff -Nru openmolcas-22.02/src/motra/traone_motra.F90 openmolcas-22.10/src/motra/traone_motra.F90 --- openmolcas-22.02/src/motra/traone_motra.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/motra/traone_motra.F90 2022-10-10 14:22:40.000000000 +0000 @@ -34,10 +34,8 @@ IOFF = 1+NBAS(ISYM)*NBAS(ISYM) call SQUARE(PAO(IAO),TEMP(1),1,NBAS(ISYM),NBAS(ISYM)) call DGEMM_('T','N',NORB(ISYM),NBAS(ISYM),NBAS(ISYM),One,CMO(ICMO),NBAS(ISYM),TEMP,NBAS(ISYM),Zero,TEMP(IOFF),max(1,NORB(ISYM))) - If (NORB(ISYM)*NBAS(ISYM) > 0) call DGEMM_Tri('N','N',NORB(ISYM),NORB(ISYM),NBAS(ISYM), & - One,TEMP(IOFF),NORB(ISYM), & - CMO(ICMO),NBAS(ISYM), & - Zero,PMO(IMO),NORB(ISYM)) + If (NORB(ISYM)*NBAS(ISYM) > 0) call DGEMM_Tri('N','N',NORB(ISYM),NORB(ISYM),NBAS(ISYM),One,TEMP(IOFF),NORB(ISYM),CMO(ICMO), & + NBAS(ISYM),Zero,PMO(IMO),NORB(ISYM)) ICMO = ICMO+NBAS(ISYM)*(NORB(ISYM)+NDEL(ISYM)) IAO = IAO+NBAS(ISYM)*(NBAS(ISYM)+1)/2 IMO = IMO+NORB(ISYM)*(NORB(ISYM)+1)/2 diff -Nru openmolcas-22.02/src/mrci/abcd.F90 openmolcas-22.10/src/mrci/abcd.F90 --- openmolcas-22.02/src/mrci/abcd.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/abcd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,158 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ABCD(INTSYM,indx,ISAB,C,S,ACBDS,ACBDT,BUFIN) + +use mrci_global, only: IPASS, IRC, IROW, JJS, KBUFF1, LN, LSYM, Lu_80, NSM, NSYM, NVIR, NVIRP, NVIRT, SQ2, SQ2INV +use Symmetry_Info, only: Mul +use Definitions, only: wp, iwp, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: INTSYM(*), indx(*), ISAB(NVIRT,NVIRT) +real(kind=wp), intent(inout) :: C(*), S(*) +real(kind=wp), intent(_OUT_) :: ACBDS(*), ACBDT(*), BUFIN(*) +integer(kind=iwp) :: IAC, IACMAX, IACMIN, IAD16, IFIN1, IFIN2, ILOOP, IN1, INB, INDA, INPS, INPT, INS, INSB, INSIN, INUMB, ISAC, & + IST, IST1, IST2, ISTEP, ISYM, ITAIL, NA, NC, NDMAX, NOV, NSAC, NSACL, NSC, NVT +real(kind=wp) :: TERM +real(kind=r8), external :: DDOT_ + +!vv hand-made loop unrolling to fix a bug in GCC 3.x +IAD16 = 0 +INSIN = KBUFF1 +call CSCALE(indx,INTSYM,C,SQ2) +call CSCALE(indx,INTSYM,S,SQ2INV) +NVT = IROW(NVIRT+1) +NOV = (NVT-1)/IPASS+1 +IACMAX = 0 +!do ISTEP=1,IPASS +ISTEP = 1 +if (IPASS >= 1) then + + do + IACMIN = IACMAX+1 + IACMAX = IACMAX+NOV + if (IACMAX > NVT) IACMAX = NVT + if (IACMIN <= IACMAX) then + !do ISYM=1,NSYM + ISYM = 1 + if (NSYM >= 1) then + do + IST1 = IRC(3)+JJS(ISYM+9)+1 + IFIN1 = IRC(3)+JJS(ISYM+10) + INPS = IFIN1-IST1+1 + IST2 = IRC(2)+JJS(ISYM)+1 + IFIN2 = IRC(2)+JJS(ISYM+1) + INPT = IFIN2-IST2+1 + ITAIL = INPS+INPT + if (ITAIL /= 0) then + IN1 = -NVIRT + !do NA=1,NVIRT + NA = 1 + if (NVIRT >= 1) then + do + IN1 = IN1+NVIRT + do NC=1,NA + IAC = IROW(NA)+NC + if (IAC < IACMIN) cycle + if (IAC > IACMAX) cycle + if (NA == 1) cycle + NSAC = MUL(NSM(LN+NA),NSM(LN+NC)) + NSACL = MUL(NSAC,LSYM) + if (NSACL /= ISYM) cycle + ISAC = ISAB(NA,NC) + NSC = NSM(LN+NC) + NDMAX = NVIRP(NSC)+NVIR(NSC) + if (NDMAX > NA) NDMAX = NA + INS = ISAB(NA,NDMAX) + ! MOVE INS ITEMS FROM FILE, UNIT 16, VIA BUFFER, INTO ACBDS, + ! AND THEN INTO ACBDT: + ILOOP = 0 + do + INSB = INS + do + if (INSIN >= KBUFF1) then + ! INSB ITEMS REMAIN TO MOVE. + ! INSIN ITEMS HAVE ALREADY BEEN MOVED FROM THE BUFFER. + call dDAFILE(Lu_80,2,BUFIN,KBUFF1,IAD16) + INSIN = 0 + end if + INB = KBUFF1-INSIN + ! INB FRESH ITEMS ARE STILL REMAINING IN BUFFER. + INUMB = min(INSB,INB) + ! MOVE INUMB ITEMS. + IST = INS-INSB+1 + if (ILOOP == 0) call DCOPY_(INUMB,BUFIN(INSIN+1),1,ACBDS(IST),1) + if (ILOOP == 1) call DCOPY_(INUMB,BUFIN(INSIN+1),1,ACBDT(IST),1) + INSIN = INSIN+INUMB + INSB = INSB-INUMB + if (INSB <= 0) exit + end do + ILOOP = ILOOP+1 + if (ILOOP /= 1) exit + end do + ! INS ITEMS HAVE BEEN TRANSFERRED TO ACBDS AND TO ACBDT. + if (INPS /= 0) then + INDA = IST1 + if (IFIN1 >= IST1) then + !do INDA=IST1,IFIN1 + do + TERM = DDOT_(INS,C(indx(INDA)+1),1,ACBDS,1) + S(indx(INDA)+ISAC) = S(indx(INDA)+ISAC)+TERM + call DAXPY_(INS,C(indx(INDA)+ISAC),ACBDS,1,S(indx(INDA)+1),1) + !end do + INDA = INDA+1 + if (INDA > IFIN1) exit + end do + end if + end if + if ((INPT == 0) .or. (NA == NC)) cycle + INDA = IST2 + if (IFIN2 >= IST2) then + !do INDA=IST2,IFIN2 + do + TERM = DDOT_(INS,C(indx(INDA)+1),1,ACBDT,1) + S(indx(INDA)+ISAC) = S(indx(INDA)+ISAC)+TERM + call DAXPY_(INS,C(indx(INDA)+ISAC),ACBDT,1,S(indx(INDA)+1),1) + !end do + INDA = INDA+1 + if (INDA > IFIN2) exit + end do + end if + end do + !vv end of unrolling loop + !NC = NC+1 + !if (NC == NA) exit + !end do + NA = NA+1 + if (NA > NVIRT) exit + end do + end if + end if + !end do + ISYM = ISYM+1 + if (ISYM > NSYM) exit + end do + end if + end if + + !end do + ISTEP = ISTEP+1 + if (ISTEP > IPASS) exit + end do +end if +call CSCALE(indx,INTSYM,C,SQ2INV) +call CSCALE(indx,INTSYM,S,SQ2) + +return + +end subroutine ABCD diff -Nru openmolcas-22.02/src/mrci/abcd_mrci.f openmolcas-22.10/src/mrci/abcd_mrci.f --- openmolcas-22.02/src/mrci/abcd_mrci.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/abcd_mrci.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,134 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE ABCD_MRCI(INTSYM,indx,ISAB,C,S,ACBDS,ACBDT,BUFIN) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "mrci.fh" - DIMENSION INTSYM(*),indx(*),ISAB(NVIRT,NVIRT), - * C(*),S(*),ACBDS(*),ACBDT(*), - * BUFIN(*) -* -cvv hand-made loop unrolling to fix a bug in GCC 3.x - IAD16=0 - INSIN=KBUFF1 - CALL CSCALE(indx,INTSYM,C,SQ2) - CALL CSCALE(indx,INTSYM,S,SQ2INV) - NVT=IROW(NVIRT+1) - NOV=(NVT-1)/IPASS+1 - IACMAX=0 -c DO 70 ISTEP=1,IPASS - ISTEP=1 - if(IPASS.lt.1) goto 670 - -770 IACMIN=IACMAX+1 - IACMAX=IACMAX+NOV - IF(IACMAX.GT.NVT)IACMAX=NVT - IF(IACMIN.GT.IACMAX)GO TO 70 -c DO 40 ISYM=1,NSYM - ISYM=1 - if(NSYM.lt.1) goto 640 -740 IST1=IRC(3)+JJS(ISYM+9)+1 - IFIN1=IRC(3)+JJS(ISYM+10) - INPS=IFIN1-IST1+1 - IST2=IRC(2)+JJS(ISYM)+1 - IFIN2=IRC(2)+JJS(ISYM+1) - INPT=IFIN2-IST2+1 - ITAIL=INPS+INPT - IF(ITAIL.EQ.0)GO TO 40 - IN1=-NVIRT -c DO 50 NA=1,NVIRT - NA=1 - if(NVIRT.lt.1) goto 650 -750 IN1=IN1+NVIRT -c DO 60 NC=1,NA - NC=1 - if(NA.lt.1) goto 660 - -760 IAC=IROW(NA)+NC - IF(IAC.LT.IACMIN)GO TO 60 - IF(IAC.GT.IACMAX)GO TO 60 - IF(NA.EQ.1)GO TO 60 - NSAC=MUL(NSM(LN+NA),NSM(LN+NC)) - NSACL=MUL(NSAC,LSYM) - IF(NSACL.NE.ISYM)GO TO 60 - ISAC=ISAB(NA,NC) - NSC=NSM(LN+NC) - NDMAX=NVIRP(NSC)+NVIR(NSC) - IF(NDMAX.GT.NA)NDMAX=NA - INS=ISAB(NA,NDMAX) -C MOVE INS ITEMS FROM FILE, UNIT 16, VIA BUFFER, INTO ACBDS, -C AND THEN INTO ACBDT: - ILOOP=0 -72 INSB=INS -73 IF(INSIN.LT.KBUFF1)GO TO 75 -C INSB ITEMS REMAIN TO MOVE. -C INSIN ITEMS HAVE ALREADY BEEN MOVED FROM THE BUFFER. - CALL dDAFILE(Lu_80,2,BUFIN,KBUFF1,IAD16) - INSIN=0 -75 INB=KBUFF1-INSIN -C INB FRESH ITEMS ARE STILL REMAINING IN BUFFER. - INUMB=MIN(INSB,INB) -C MOVE INUMB ITEMS. - IST=INS-INSB+1 - IF(ILOOP.EQ.0)CALL DCOPY_(INUMB,BUFIN(INSIN+1),1,ACBDS(IST),1) - IF(ILOOP.EQ.1)CALL DCOPY_(INUMB,BUFIN(INSIN+1),1,ACBDT(IST),1) - INSIN=INSIN+INUMB - INSB=INSB-INUMB - IF(INSB.GT.0)GO TO 73 - ILOOP=ILOOP+1 - IF(ILOOP.EQ.1)GO TO 72 -C INS ITEMS HAVE BEEN TRANSFERRED TO ACBDS AND TO ACBDT. - IF(INPS.EQ.0)GO TO 11 - INDA=IST1 - if(IFIN1.lt.IST1) goto 610 -c DO 10 INDA=IST1,IFIN1 -710 TERM=DDOT_(INS,C(indx(INDA)+1),1,ACBDS,1) - S(indx(INDA)+ISAC)=S(indx(INDA)+ISAC)+TERM - CALL DAXPY_(INS,C(indx(INDA)+ISAC),ACBDS,1,S(indx(INDA)+1),1) -c10 CONTINUE - INDA=INDA+1 - if(INDA.le.IFIN1) goto 710 -610 Continue -11 IF(INPT.EQ.0.OR.NA.EQ.NC)GO TO 60 - INDA=IST2 - if(IFIN2.lt.IST2) goto 630 -c DO 30 INDA=IST2,IFIN2 -730 TERM=DDOT_(INS,C(indx(INDA)+1),1,ACBDT,1) - S(indx(INDA)+ISAC)=S(indx(INDA)+ISAC)+TERM - CALL DAXPY_(INS,C(indx(INDA)+ISAC),ACBDT,1,S(indx(INDA)+1),1) -c30 CONTINUE - INDA=INDA+1 - if(INDA.le.IFIN2) goto 730 -630 Continue -60 CONTINUE - NC=NC+1 - if(NC.le.NA) goto 760 -660 Continue -cvv end of unrolling loop -c NC=NC+1 -c if(NC.le.NA) goto 61 -c50 CONTINUE - NA=NA+1 - if(NA.le.NVIRT) goto 750 -650 Continue -40 CONTINUE - ISYM=ISYM+1 - if(ISYM.le.NSYM) goto 740 -640 Continue - -70 CONTINUE - ISTEP=ISTEP+1 - IF(ISTEP.le.IPASS) goto 770 -670 Continue - CALL CSCALE(indx,INTSYM,C,SQ2INV) - CALL CSCALE(indx,INTSYM,S,SQ2) - RETURN - END diff -Nru openmolcas-22.02/src/mrci/abci.F90 openmolcas-22.10/src/mrci/abci.F90 --- openmolcas-22.02/src/mrci/abci.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/abci.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,128 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ABCI(INTSYM,indx,C,S,BMN,IBMN,BIAC,BICA,BUFIN) + +use mrci_global, only: IADABCI, IRC, KBUFF1, LN, LSYM, Lu_70, LUSYMB, NSM, NVIRP, NVIRT, NVPAIR, SQ2, SQ2INV +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Definitions, only: wp, iwp, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: INTSYM(*), indx(*) +real(kind=wp), intent(inout) :: C(*), S(*) +real(kind=wp), intent(_OUT_) :: BMN(*), BIAC(*), BICA(*), BUFIN(*) +integer(kind=iwp), intent(_OUT_) :: IBMN(*) +integer(kind=iwp) :: IAD15, IADD10, ICCB, ICHK, ICP1, ICP2, IIN, ILEN, ILOOP, INB, IND, INDA, INDB, INS, INSB, INSIN, INUMB, IOUT, & + IST, IT, ITYP, LB, MA, NB, NI, NSAVE, NSIB, NSLB +real(kind=wp) :: COPL, TERM +logical(kind=iwp) :: Skip +integer(kind=iwp), external :: JSUNP +real(kind=r8), external :: DDOT_ + +call CSCALE(indx,INTSYM,C,SQ2) +call CSCALE(indx,INTSYM,S,SQ2INV) +ICHK = 0 +INSIN = KBUFF1 +IAD15 = IADABCI +IADD10 = IAD10(4) +call dDAFILE(LUSYMB,2,COP,nCOP,IADD10) +call iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) +ILEN = ICOP1(nCOP+1) +IIN = 2 +NSAVE = ICOP1(IIN) +do + NI = NSAVE + IOUT = 0 + Skip = .false. + do + IIN = IIN+1 + if (IIN > ILEN) then + call dDAFILE(LUSYMB,2,COP,nCOP,IADD10) + call iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN <= 0) then + Skip = .true. + exit + end if + IIN = 1 + end if + if (ICHK /= 0) exit + if (ICOP1(IIN) == 0) then + ICHK = 1 + else + IOUT = IOUT+1 + BMN(IOUT) = COP(IIN) + IBMN(IOUT) = ICOP1(IIN) + end if + end do + if (.not. Skip) then + ICHK = 0 + NSAVE = ICOP1(IIN) + end if + do NB=1,NVIRT + NSIB = MUL(NSM(LN+NB),NSM(NI)) + NSLB = MUL(NSM(LN+NB),LSYM) + LB = NB-NVIRP(NSM(LN+NB)) + INS = NVPAIR(NSIB) + ILOOP = 0 + do + INSB = INS + do + if (INSIN >= KBUFF1) then + call dDAFILE(Lu_70,2,BUFIN,KBUFF1,IAD15) + INSIN = 0 + end if + INB = KBUFF1-INSIN + INUMB = INSB + if (INSB > INB) INUMB = INB + IST = INS-INSB+1 + if (ILOOP == 0) call DCOPY_(INUMB,BUFIN(INSIN+1),1,BIAC(IST),1) + if (ILOOP == 1) call DCOPY_(INUMB,BUFIN(INSIN+1),1,BICA(IST),1) + INSIN = INSIN+INUMB + INSB = INSB-INUMB + if (INSB <= 0) exit + end do + ILOOP = ILOOP+1 + if (ILOOP /= 1) exit + end do + do IT=1,IOUT + IND = IBMN(IT) + ICP1 = ibits(IND,19,13) + INDA = IRC(1)+ICP1 + if (JSUNP(INTSYM,INDA) /= NSLB) cycle + MA = indx(INDA)+LB + ICP2 = ibits(IND,6,13) + ITYP = ibits(IND,0,6) + if (INS == 0) cycle + COPL = BMN(IT)*C(MA) + INDB = IRC(ITYP)+ICP2 + ICCB = indx(INDB)+1 + if (ITYP == 3) then + TERM = DDOT_(INS,C(ICCB),1,BIAC,1) + S(ICCB:ICCB+INS-1) = S(ICCB:ICCB+INS-1)+COPL*BIAC(1:INS) + else + TERM = DDOT_(INS,C(ICCB),1,BICA,1) + S(ICCB:ICCB+INS-1) = S(ICCB:ICCB+INS-1)+COPL*BICA(1:INS) + end if + S(MA) = S(MA)+BMN(IT)*TERM + end do + end do + if (ILEN < 0) exit +end do +call CSCALE(indx,INTSYM,C,SQ2INV) +call CSCALE(indx,INTSYM,S,SQ2) + +return + +end subroutine ABCI diff -Nru openmolcas-22.02/src/mrci/abci_mrci.f openmolcas-22.10/src/mrci/abci_mrci.f --- openmolcas-22.02/src/mrci/abci_mrci.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/abci_mrci.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,100 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE ABCI_MRCI(INTSYM,indx,C,S,BMN,IBMN,BIAC,BICA,BUFIN) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "mrci.fh" - DIMENSION INTSYM(*),indx(*),C(*),S(*),BMN(*),IBMN(*), - *BIAC(*),BICA(*),BUFIN(*) -* - JSYM(L)=JSUNP(INTSYM,L) -* - CALL CSCALE(indx,INTSYM,C,SQ2) - CALL CSCALE(indx,INTSYM,S,SQ2INV) - ICHK=0 - INSIN=KBUFF1 - IAD15=IADABCI - IADD10=IAD10(4) - CALL dDAFILE(LUSYMB,2,COP,nCOP,IADD10) - CALL iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IN=2 - NSAVE=ICOP1(IN) -100 NI=NSAVE - IOUT=0 -110 IN=IN+1 - IF(IN.LE.LEN)GO TO 15 - CALL dDAFILE(LUSYMB,2,COP,nCOP,IADD10) - CALL iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.LE.0)GO TO 5 - IN=1 -15 IF(ICHK.NE.0)GO TO 460 - IF(ICOP1(IN).EQ.0)GO TO 10 - IOUT=IOUT+1 - BMN(IOUT)=COP(IN) - IBMN(IOUT)=ICOP1(IN) - GO TO 110 -10 ICHK=1 - GO TO 110 -460 ICHK=0 - NSAVE=ICOP1(IN) -5 CONTINUE - DO 20 NB=1,NVIRT - NSIB=MUL(NSM(LN+NB),NSM(NI)) - NSLB=MUL(NSM(LN+NB),LSYM) - LB=NB-NVIRP(NSM(LN+NB)) - INS=NVPAIR(NSIB) - ILOOP=0 -72 INSB=INS -73 IF(INSIN.LT.KBUFF1)GO TO 75 - CALL dDAFILE(Lu_70,2,BUFIN,KBUFF1,IAD15) - INSIN=0 -75 INB=KBUFF1-INSIN - INUMB=INSB - IF(INSB.GT.INB)INUMB=INB - IST=INS-INSB+1 - IF(ILOOP.EQ.0)CALL DCOPY_(INUMB,BUFIN(INSIN+1),1,BIAC(IST),1) - IF(ILOOP.EQ.1)CALL DCOPY_(INUMB,BUFIN(INSIN+1),1,BICA(IST),1) - INSIN=INSIN+INUMB - INSB=INSB-INUMB - IF(INSB.GT.0)GO TO 73 - ILOOP=ILOOP+1 - IF(ILOOP.EQ.1)GO TO 72 - DO 25 IT=1,IOUT - IND=IBMN(IT) -* ICP1=MOD(IND/2**19,2**13) - ICP1=IBITS(IND,19,13) - INDA=IRC(1)+ICP1 - IF(JSYM(INDA).NE.NSLB)GO TO 25 - MA=indx(INDA)+LB -* ICP2=MOD(IND/2**6,2**13) -* ITYP=MOD(IND,2**6) - ICP2=IBITS(IND,6,13) - ITYP=IBITS(IND,0,6) - IF(INS.EQ.0)GO TO 25 - COPL=BMN(IT)*C(MA) - INDB=IRC(ITYP)+ICP2 - ICCB=indx(INDB)+1 - IF(ITYP.EQ.3)GO TO 26 - TERM=DDOT_(INS,C(ICCB),1,BICA,1) - CALL DAXPY_(INS,COPL,BICA,1,S(ICCB),1) - GO TO 27 -26 TERM=DDOT_(INS,C(ICCB),1,BIAC,1) - CALL DAXPY_(INS,COPL,BIAC,1,S(ICCB),1) -27 S(MA)=S(MA)+BMN(IT)*TERM -25 CONTINUE -20 CONTINUE - IF(LEN.GE.0)GO TO 100 - CALL CSCALE(indx,INTSYM,C,SQ2INV) - CALL CSCALE(indx,INTSYM,S,SQ2) - RETURN - END diff -Nru openmolcas-22.02/src/mrci/abd.f openmolcas-22.10/src/mrci/abd.f --- openmolcas-22.02/src/mrci/abd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/abd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,153 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE ABD(ICSPCK,INTSYM,INDX,C,DMO,A,B,F,JREFX) - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "mrci.fh" - DIMENSION ICSPCK(*),INTSYM(*),INDX(*), - * C(*),DMO(*),A(*),B(*), - * F(*),JREFX(*) - DIMENSION IPOA(9),IPOF(9) - DIMENSION IOC(55) -CPAM97 EXTERNAL UNPACK -CPAM97 INTEGER UNPACK -CPAM97 JO(L)=UNPACK(CSPCK((L+29)/30), 2*L-(2*L-1)/60*60, 2) - JO(L)=ICUNP(ICSPCK,L) -CPAM96 JSYM(L)=UNPACK(INTSYM((L+9)/10),3*MOD(L-1,10)+1,3)+1 - JSYM(L)=JSUNP(INTSYM,L) -C SCRATCH SPACE: A(),B(),F(). - CALL CSCALE(INDX,INTSYM,C,SQ2) - NCLIM=4 - IF(IFIRST.NE.0)NCLIM=2 - ENPINV=1.0D00/ENP -C MOVE DENSITY MATRIX TO F IN SYMMETRY BLOCKS - CALL IPO(IPOF,NVIR,MUL,NSYM,1,-1) - DO 10 IASYM=1,NSYM - IAB=IPOF(IASYM) - NA1=NVIRP(IASYM)+1 - NA2=NVIRP(IASYM)+NVIR(IASYM) - DO 15 NA=NA1,NA2 - DO 20 NB=NA1,NA2 - IAB=IAB+1 - NAB=IROW(LN+NA)+LN+NB - IF(NB.GT.NA)NAB=IROW(LN+NB)+LN+NA - F(IAB)=DMO(NAB) -20 CONTINUE -15 CONTINUE -10 CONTINUE - II1=0 - ITAIL=IRC(NCLIM) - DO 40 INDA=1,ITAIL - DO 110 I=1,LN - II1=II1+1 - IOC(I)=(1+JO(II1))/2 -110 CONTINUE - IF(INDA.LE.IRC(1)) THEN - TSUM=ENPINV*C(INDA)**2 - GO TO 106 - END IF - MYSYM=JSYM(INDA) - MYL=MUL(MYSYM,LSYM) - INMY=INDX(INDA)+1 - IF(INDA.GT.IRC(2))GO TO 25 -C DOUBLET-DOUBLET INTERACTIONS - IF(NVIR(MYL).EQ.0)GO TO 40 - CALL FMUL2(C(INMY),C(INMY),A,NVIR(MYL),NVIR(MYL),1) - IPF=IPOF(MYL)+1 - IN=IPOF(MYL+1)-IPOF(MYL) - CALL DAXPY_(IN,ENPINV,A,1,F(IPF),1) - NVIRA=NVIR(MYL) - LNA=LN+NVIRP(MYL) - IIA=IROW(LNA+1) - TSUM=0.0D00 - DO 130 I=1,NVIRA - SUM=ENPINV*C(INMY)**2 - INMY=INMY+1 - TSUM=TSUM+SUM - IIA=IIA+LNA+I - DMO(IIA)=DMO(IIA)+SUM -130 CONTINUE - GO TO 106 -C TRIPLET-TRIPLET AND SINGLET-SINGLET INTERACTIONS -25 IFT=1 - IF(INDA.GT.IRC(3))IFT=0 - CALL IPO(IPOA,NVIR,MUL,NSYM,MYL,IFT) - IN=0 - TSUM=0.0D00 - DO 70 IASYM=1,NSYM - IAB=IPOF(IASYM+1)-IPOF(IASYM) - IF(IAB.EQ.0)GO TO 70 - ICSYM=MUL(MYL,IASYM) - IF(NVIR(ICSYM).EQ.0)GO TO 70 - IF(MYL.NE.1) THEN - IF(IASYM.GT.ICSYM) THEN - CALL MTRANS(C(INMY+IPOA(IASYM)),1,A,1,NVIR(IASYM),NVIR(ICSYM)) - ELSE - NAC=NVIR(IASYM)*NVIR(ICSYM) - IF(IFT.EQ.0)CALL DCOPY_(NAC,C(INMY+IPOA(ICSYM)),1,A,1) - IF(IFT.EQ.1)CALL VNEG(C(INMY+IPOA(ICSYM)),1,A,1,NAC) - END IF - ELSE - IF(IFT.EQ.0)CALL SQUAR(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) - IF(IFT.EQ.1)CALL SQUARM(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) - END IF - NVIRA=NVIR(IASYM) - NVIRC=NVIR(ICSYM) - CALL FMUL2(A,A,B,NVIR(IASYM),NVIR(IASYM),NVIR(ICSYM)) - IPF=IPOF(IASYM)+1 - CALL DAXPY_(IAB,ENPINV,B,1,F(IPF),1) - INN=1 - LNC=LN+NVIRP(ICSYM) - IIC=IROW(LNC+1) - DO 105 I=1,NVIRC - SUM=ENPINV*DDOT_(NVIRA,A(INN),1,A(INN),1) - TSUM=TSUM+SUM - IIC=IIC+LNC+I - DMO(IIC)=DMO(IIC)+SUM - INN=INN+NVIRA -105 CONTINUE -70 CONTINUE - TSUM=TSUM/2 -106 CONTINUE - IJ=0 - DO 107 I=1,LN - IJ=IJ+I - DMO(IJ)=DMO(IJ)+IOC(I)*TSUM -107 CONTINUE -40 CONTINUE - DO 410 IASYM=1,NSYM - IAB=IPOF(IASYM) - NA1=NVIRP(IASYM)+1 - NA2=NVIRP(IASYM)+NVIR(IASYM) - DO 415 NA=NA1,NA2 - DO 420 NB=NA1,NA2 - IAB=IAB+1 - IF(NA.GE.NB) GOTO 420 - NAB=IROW(LN+NB)+LN+NA - DMO(NAB)=F(IAB) -420 CONTINUE -415 CONTINUE -410 CONTINUE - TR=0.0D00 - IJ=0 - DO 510 I=1,NCSHT - IJ=IJ+I - TR=TR+DMO(IJ) -510 CONTINUE - IF(ABS(TR-DBLE(NELEC)) .GT. 1.0D-8) WRITE(6,310)TR -310 FORMAT(/,6X,'TRACE OF DENSITY MATRIX',F16.8) - CALL CSCALE(INDX,INTSYM,C,SQ2INV) - RETURN -c Avoid unused argument warnings - IF (.FALSE.) CALL Unused_integer_array(JREFX) - END diff -Nru openmolcas-22.02/src/mrci/abd.F90 openmolcas-22.10/src/mrci/abd.F90 --- openmolcas-22.02/src/mrci/abd.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/abd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,157 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ABD(ICSPCK,INTSYM,INDX,C,DMO,A,B,F) + +use mrci_global, only: ENP, IFIRST, IRC, IROW, LN, LSYM, NCSHT, NELEC, NSYM, NVIR, NVIRP, SQ2, SQ2INV +use Symmetry_Info, only: Mul +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: ICSPCK(*), INTSYM(*), INDX(*) +real(kind=wp), intent(inout) :: C(*) +real(kind=wp), intent(_OUT_) :: DMO(*), A(*), B(*), F(*) +integer(kind=iwp) :: I, IAB, IASYM, ICSYM, IFT, II1, IIA, IIC, IIN, IJ, INDA, INMY, INN, IOC(55), IPF, IPOA(9), IPOF(9), ITAIL, & + LNA, LNC, MYL, MYSYM, NA, NA1, NA2, NAB, NAC, NB, NCLIM, NVIRA, NVIRC +real(kind=wp) :: ENPINV, RSUM, TR, TSUM +integer(kind=iwp), external :: ICUNP, JSUNP +real(kind=r8), external :: DDOT_ + +! SCRATCH SPACE: A(),B(),F(). +call CSCALE(INDX,INTSYM,C,SQ2) +NCLIM = 4 +if (IFIRST /= 0) NCLIM = 2 +ENPINV = One/ENP +! MOVE DENSITY MATRIX TO F IN SYMMETRY BLOCKS +call IPO(IPOF,NVIR,MUL,NSYM,1,-1) +do IASYM=1,NSYM + IAB = IPOF(IASYM) + NA1 = NVIRP(IASYM)+1 + NA2 = NVIRP(IASYM)+NVIR(IASYM) + do NA=NA1,NA2 + do NB=NA1,NA2 + IAB = IAB+1 + NAB = IROW(LN+NA)+LN+NB + if (NB > NA) NAB = IROW(LN+NB)+LN+NA + F(IAB) = DMO(NAB) + end do + end do +end do +II1 = 0 +ITAIL = IRC(NCLIM) +do INDA=1,ITAIL + do I=1,LN + II1 = II1+1 + IOC(I) = (1+ICUNP(ICSPCK,II1))/2 + end do + if (INDA <= IRC(1)) then + TSUM = ENPINV*C(INDA)**2 + else + MYSYM = JSUNP(INTSYM,INDA) + MYL = MUL(MYSYM,LSYM) + INMY = INDX(INDA)+1 + if (INDA <= IRC(2)) then + ! DOUBLET-DOUBLET INTERACTIONS + if (NVIR(MYL) == 0) cycle + call FMUL2(C(INMY),C(INMY),A,NVIR(MYL),NVIR(MYL),1) + IPF = IPOF(MYL)+1 + IIN = IPOF(MYL+1)-IPOF(MYL) + F(IPF:IPF+IIN-1) = F(IPF:IPF+IIN-1)+ENPINV*A(1:IIN) + NVIRA = NVIR(MYL) + LNA = LN+NVIRP(MYL) + IIA = IROW(LNA+1) + TSUM = Zero + do I=1,NVIRA + RSUM = ENPINV*C(INMY)**2 + INMY = INMY+1 + TSUM = TSUM+RSUM + IIA = IIA+LNA+I + DMO(IIA) = DMO(IIA)+RSUM + end do + else + ! TRIPLET-TRIPLET AND SINGLET-SINGLET INTERACTIONS + IFT = 1 + if (INDA > IRC(3)) IFT = 0 + call IPO(IPOA,NVIR,MUL,NSYM,MYL,IFT) + IIN = 0 + TSUM = Zero + do IASYM=1,NSYM + IAB = IPOF(IASYM+1)-IPOF(IASYM) + if (IAB == 0) cycle + ICSYM = MUL(MYL,IASYM) + if (NVIR(ICSYM) == 0) cycle + if (MYL /= 1) then + if (IASYM > ICSYM) then + call MTRANS(C(INMY+IPOA(IASYM)),A,NVIR(IASYM),NVIR(ICSYM)) + else + NAC = NVIR(IASYM)*NVIR(ICSYM) + if (IFT == 0) call DCOPY_(NAC,C(INMY+IPOA(ICSYM)),1,A,1) + if (IFT == 1) call VNEG(NAC,C(INMY+IPOA(ICSYM)),1,A,1) + end if + else + if (IFT == 0) call SQUAR(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + if (IFT == 1) call SQUARM(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + end if + NVIRA = NVIR(IASYM) + NVIRC = NVIR(ICSYM) + call FMUL2(A,A,B,NVIR(IASYM),NVIR(IASYM),NVIR(ICSYM)) + IPF = IPOF(IASYM)+1 + F(IPF:IPF+IAB-1) = F(IPF:IPF+IAB-1)+ENPINV*B(1:IAB) + INN = 1 + LNC = LN+NVIRP(ICSYM) + IIC = IROW(LNC+1) + do I=1,NVIRC + RSUM = ENPINV*DDOT_(NVIRA,A(INN),1,A(INN),1) + TSUM = TSUM+RSUM + IIC = IIC+LNC+I + DMO(IIC) = DMO(IIC)+RSUM + INN = INN+NVIRA + end do + end do + TSUM = TSUM/2 + end if + end if + IJ = 0 + do I=1,LN + IJ = IJ+I + DMO(IJ) = DMO(IJ)+IOC(I)*TSUM + end do +end do +do IASYM=1,NSYM + IAB = IPOF(IASYM) + NA1 = NVIRP(IASYM)+1 + NA2 = NVIRP(IASYM)+NVIR(IASYM) + do NA=NA1,NA2 + do NB=NA1,NA2 + IAB = IAB+1 + if (NA >= NB) cycle + NAB = IROW(LN+NB)+LN+NA + DMO(NAB) = F(IAB) + end do + end do +end do +TR = Zero +IJ = 0 +do I=1,NCSHT + IJ = IJ+I + TR = TR+DMO(IJ) +end do +if (abs(TR-real(NELEC,kind=wp)) > 1.0e-8_wp) write(u6,310) TR +call CSCALE(INDX,INTSYM,C,SQ2INV) + +return + +310 format(/,6X,'TRACE OF DENSITY MATRIX',F16.8) + +end subroutine ABD diff -Nru openmolcas-22.02/src/mrci/ab.F90 openmolcas-22.10/src/mrci/ab.F90 --- openmolcas-22.02/src/mrci/ab.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/ab.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,106 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine AB(INTSYM,INDX,C,S,FC,A,B,FK) + +use mrci_global, only: IFIRST, IRC, IROW, LN, LSYM, NSYM, NVIR, NVIRP, SQ2, SQ2INV +use Symmetry_Info, only: Mul +use Constants, only: Zero +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: INTSYM(*), INDX(*) +real(kind=wp), intent(inout) :: C(*), S(*) +real(kind=wp), intent(_OUT_) :: FC(*), A(*), B(*), FK(*) +integer(kind=iwp) :: IAB, IASYM, ICSYM, IFT, INDA, INMY, IPOA(9), IPOF(9), ITAIL, J, MYL, MYSYM, NA, NA1, NA2, NAA, NAB, NAC, NB, & + NCLIM +integer(kind=iwp), external :: JSUNP + +call CSCALE(INDX,INTSYM,C,SQ2) +call CSCALE(INDX,INTSYM,S,SQ2INV) +NCLIM = 4 +if (IFIRST /= 0) NCLIM = 2 +! MOVE FOCK MATRIX TO FK IN SYMMETRY BLOCKS +call IPO(IPOF,NVIR,MUL,NSYM,1,-1) +do IASYM=1,NSYM + IAB = IPOF(IASYM) + NA1 = NVIRP(IASYM)+1 + NA2 = NVIRP(IASYM)+NVIR(IASYM) + do NA=NA1,NA2 + do NB=NA1,NA2 + IAB = IAB+1 + NAB = IROW(LN+NA)+LN+NB + if (NB > NA) NAB = IROW(LN+NB)+LN+NA + FK(IAB) = FC(NAB) + if (NA == NB) FK(IAB) = Zero + end do + end do +end do +ITAIL = IRC(NCLIM) +do INDA=1,ITAIL + if (INDA <= IRC(1)) cycle + MYSYM = JSUNP(INTSYM,INDA) + MYL = MUL(MYSYM,LSYM) + INMY = INDX(INDA)+1 + if (INDA <= IRC(2)) then + ! DOUBLET-DOUBLET INTERACTIONS + if (NVIR(MYL) /= 0) then + A(1:NVIR(MYL)) = Zero + call FMMM(FK(IPOF(MYL)+1),C(INMY),A,NVIR(MYL),1,NVIR(MYL)) + S(INMY:INMY+NVIR(MYL)-1) = S(INMY:INMY+NVIR(MYL)-1)+A(1:NVIR(MYL)) + end if + else + ! TRIPLET-TRIPLET AND SINGLET-SINGLET INTERACTIONS + IFT = 1 + if (INDA > IRC(3)) IFT = 0 + call IPO(IPOA,NVIR,MUL,NSYM,MYL,IFT) + do IASYM=1,NSYM + IAB = IPOF(IASYM+1)-IPOF(IASYM) + if (IAB == 0) cycle + ICSYM = MUL(MYL,IASYM) + if (NVIR(ICSYM) == 0) cycle + if (MYL == 1) then + if (IFT == 0) call SQUAR(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + if (IFT == 1) call SQUARM(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) + NAA = NVIR(IASYM)*NVIR(IASYM) + B(1:NAA) = Zero + call FMMM(FK(IPOF(IASYM)+1),A,B,NVIR(IASYM),NVIR(IASYM),NVIR(IASYM)) + A(1:NAA) = B(1:NAA) + if (IFT /= 1) then + call SIADD(A,S(INMY+IPOA(IASYM)),NVIR(IASYM)) + else + call TRADD(A,S(INMY+IPOA(IASYM)),NVIR(IASYM)) + end if + A(1:NAA) = Zero + else + NAC = NVIR(IASYM)*NVIR(ICSYM) + A(1:NAC) = Zero + if (IASYM <= ICSYM) then + call FMMM(FK(IPOF(IASYM)+1),C(INMY+IPOA(ICSYM)),A,NVIR(IASYM),NVIR(ICSYM),NVIR(IASYM)) + J = INMY+IPOA(ICSYM) + S(J:J+NAC-1) = S(J:J+NAC-1)+A(1:NAC) + else + call FMMM(C(INMY+IPOA(IASYM)),FK(IPOF(IASYM)+1),A,NVIR(ICSYM),NVIR(IASYM),NVIR(IASYM)) + J = INMY+IPOA(IASYM) + S(J:J+NAC-1) = S(J:J+NAC-1)+A(1:NAC) + end if + end if + end do + end if +end do +call CSCALE(INDX,INTSYM,C,SQ2INV) +call CSCALE(INDX,INTSYM,S,SQ2) + +return + +end subroutine AB diff -Nru openmolcas-22.02/src/mrci/ab_mrci.f openmolcas-22.10/src/mrci/ab_mrci.f --- openmolcas-22.02/src/mrci/ab_mrci.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/ab_mrci.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,104 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE AB_MRCI(ICSPCK,INTSYM,INDX,C,S,FC,A,B,FK) - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "mrci.fh" - DIMENSION ICSPCK(*),INTSYM(*),INDX(*), - * C(*),S(*),FC(*),A(*),B(*), - * FK(*) - DIMENSION IPOA(9),IPOF(9) -CPAM97 EXTERNAL UNPACK -CPAM97 INTEGER UNPACK -CPAM96 JSYM(L)=UNPACK(INTSYM((L+9)/10),3*MOD(L-1,10)+1,3)+1 - JSYM(L)=JSUNP(INTSYM,L) - CALL CSCALE(INDX,INTSYM,C,SQ2) - CALL CSCALE(INDX,INTSYM,S,SQ2INV) - NCLIM=4 - IF(IFIRST.NE.0)NCLIM=2 -C MOVE FOCK MATRIX TO FK IN SYMMETRY BLOCKS - CALL IPO(IPOF,NVIR,MUL,NSYM,1,-1) - DO 10 IASYM=1,NSYM - IAB=IPOF(IASYM) - NA1=NVIRP(IASYM)+1 - NA2=NVIRP(IASYM)+NVIR(IASYM) - DO 15 NA=NA1,NA2 - DO 20 NB=NA1,NA2 - IAB=IAB+1 - NAB=IROW(LN+NA)+LN+NB - IF(NB.GT.NA)NAB=IROW(LN+NB)+LN+NA - FK(IAB)=FC(NAB) - IF(NA.EQ.NB)FK(IAB)=0.0D00 -20 CONTINUE -15 CONTINUE -10 CONTINUE - ITAIL=IRC(NCLIM) - DO 40 INDA=1,ITAIL - IF(INDA.LE.IRC(1))GO TO 40 - MYSYM=JSYM(INDA) - MYL=MUL(MYSYM,LSYM) - INMY=INDX(INDA)+1 - IF(INDA.GT.IRC(2))GO TO 25 -C DOUBLET-DOUBLET INTERACTIONS - IF(NVIR(MYL).NE.0) THEN - CALL FZERO(A,NVIR(MYL)) - CALL FMMM(FK(IPOF(MYL)+1),C(INMY),A,NVIR(MYL),1,NVIR(MYL)) - CALL DAXPY_(NVIR(MYL),1.0D00,A,1,S(INMY),1) - END IF - GO TO 40 -C TRIPLET-TRIPLET AND SINGLET-SINGLET INTERACTIONS -25 IFT=1 - IF(INDA.GT.IRC(3))IFT=0 - CALL IPO(IPOA,NVIR,MUL,NSYM,MYL,IFT) -CPAM97 IN=0 -CPAM97 TSUM=0.0D00 - DO 70 IASYM=1,NSYM - IAB=IPOF(IASYM+1)-IPOF(IASYM) - IF(IAB.EQ.0)GO TO 70 - ICSYM=MUL(MYL,IASYM) - IF(NVIR(ICSYM).EQ.0)GO TO 70 - IF(MYL.NE.1)GO TO 30 - IF(IFT.EQ.0)CALL SQUAR(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) - IF(IFT.EQ.1)CALL SQUARM(C(INMY+IPOA(IASYM)),A,NVIR(IASYM)) - NAA=NVIR(IASYM)*NVIR(IASYM) - CALL FZERO(B,NAA) - CALL FMMM(FK(IPOF(IASYM)+1),A,B,NVIR(IASYM),NVIR(IASYM), - *NVIR(IASYM)) - CALL FZERO(A,NAA) - CALL DAXPY_(NAA,1.0D00,B,1,A,1) - IF(IFT.EQ.1)GO TO 230 - CALL SIADD(A,S(INMY+IPOA(IASYM)),NVIR(IASYM)) - CALL FZERO(A,NAA) - GO TO 70 -230 CALL TRADD(A,S(INMY+IPOA(IASYM)),NVIR(IASYM)) - CALL FZERO(A,NAA) - GO TO 70 -30 NAC=NVIR(IASYM)*NVIR(ICSYM) - CALL FZERO(A,NAC) - IF(IASYM.GT.ICSYM)GO TO 31 - CALL FMMM(FK(IPOF(IASYM)+1),C(INMY+IPOA(ICSYM)),A, - *NVIR(IASYM),NVIR(ICSYM),NVIR(IASYM)) - CALL DAXPY_(NAC,1.0D00,A,1,S(INMY+IPOA(ICSYM)),1) - GO TO 70 -31 CALL FMMM(C(INMY+IPOA(IASYM)),FK(IPOF(IASYM)+1),A, - *NVIR(ICSYM),NVIR(IASYM),NVIR(IASYM)) - CALL DAXPY_(NAC,1.0D00,A,1,S(INMY+IPOA(IASYM)),1) - GO TO 70 -70 CONTINUE -40 CONTINUE - CALL CSCALE(INDX,INTSYM,C,SQ2INV) - CALL CSCALE(INDX,INTSYM,S,SQ2) - RETURN -c Avoid unused argument warnings - IF (.FALSE.) CALL Unused_integer_array(ICSPCK) - END diff -Nru openmolcas-22.02/src/mrci/abtd.f openmolcas-22.10/src/mrci/abtd.f --- openmolcas-22.02/src/mrci/abtd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/abtd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,148 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE ABTD(ICSPCK,INTSYM,INDX,C1,C2,TDMO,A1,A2,F) - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "mrci.fh" - DIMENSION ICSPCK(*),INTSYM(*),INDX(*), - * C1(*),C2(*),TDMO(NBAST,NBAST), - * A1(*),A2(*),F(*) - DIMENSION IPOA(9),IPOF(9) - DIMENSION IOC(55) -CPAM97 EXTERNAL UNPACK -CPAM97 INTEGER UNPACK -CPAM97 JO(L)=UNPACK(CSPCK((L+29)/30), 2*L-(2*L-1)/60*60, 2) - JO(L)=ICUNP(ICSPCK,L) -CPAM96 JSYM(L)=UNPACK(INTSYM((L+9)/10),3*MOD(L-1,10)+1,3)+1 - JSYM(L)=JSUNP(INTSYM,L) -C CALCULATE A) TRANSITION DENSITY ELEMENTS OF TYPE TDMO(A,B) -C B) DIAGONAL ELEMENTS TDMO(I,I) AND TDMO(A,A) -C SCRATCH SPACES: A1(),A2(), SIZE NEEDED IS NVMAX**2 -C ALSO F(), SIZE NEEDED IS NVSQ - CALL CSCALE(INDX,INTSYM,C1,SQ2) - CALL CSCALE(INDX,INTSYM,C2,SQ2) - NCLIM=4 - IF(IFIRST.NE.0)NCLIM=2 -C MOVE TRANSITION DENSITY MATRIX TO F IN SYMMETRY BLOCKS - CALL IPO(IPOF,NVIR,MUL,NSYM,1,-1) - DO 10 IASYM=1,NSYM - IAB=IPOF(IASYM) - NA1=NVIRP(IASYM)+1 - NA2=NVIRP(IASYM)+NVIR(IASYM) - DO 15 NA=NA1,NA2 - DO 20 NB=NA1,NA2 - IAB=IAB+1 - F(IAB)=TDMO(LN+NA,LN+NB) -20 CONTINUE -15 CONTINUE -10 CONTINUE - II1=0 - ITAIL=IRC(NCLIM) - DO 40 INDA=1,ITAIL - DO 110 I=1,LN - II1=II1+1 - IOC(I)=(1+JO(II1))/2 -110 CONTINUE - IF(INDA.LE.IRC(1)) THEN - TSUM=C1(INDA)*C2(INDA) - GO TO 106 - END IF - MYSYM=JSYM(INDA) - MYL=MUL(MYSYM,LSYM) - INMY=INDX(INDA)+1 - IF(INDA.GT.IRC(2))GO TO 25 -C DOUBLET-DOUBLET INTERACTIONS - IF(NVIR(MYL).EQ.0)GO TO 40 - IPF=IPOF(MYL)+1 - NVIRA=NVIR(MYL) - CALL DGER(NVIRA,NVIRA,1.0D00,C1(INMY),1, - * C2(INMY),1,F(IPF),NVIRA) - LNA=LN+NVIRP(MYL) - TSUM=0.0D00 - DO 130 I=1,NVIRA - TERM=C1(INMY-1+I)*C2(INMY-1+I) - IA=LNA+I - TDMO(IA,IA)=TDMO(IA,IA)+TERM - TSUM=TSUM+TERM -130 CONTINUE - GO TO 106 -C TRIPLET-TRIPLET AND SINGLET-SINGLET INTERACTIONS -25 IFT=1 - IF(INDA.GT.IRC(3))IFT=0 - CALL IPO(IPOA,NVIR,MUL,NSYM,MYL,IFT) - TSUM=0.0D00 - DO 70 IASYM=1,NSYM - IAB=IPOF(IASYM+1)-IPOF(IASYM) - IF(IAB.EQ.0)GO TO 70 - ICSYM=MUL(MYL,IASYM) - NVIRA=NVIR(IASYM) - NVIRC=NVIR(ICSYM) - IF(NVIRC.EQ.0)GO TO 70 - IF(MYL.NE.1) THEN - IF(IASYM.GT.ICSYM) THEN - CALL MTRANS(C1(INMY+IPOA(IASYM)),1,A1,1,NVIRA,NVIRC) - CALL MTRANS(C2(INMY+IPOA(IASYM)),1,A2,1,NVIRA,NVIRC) - ELSE - NAC=NVIRA*NVIRC - IF(IFT.EQ.0) THEN - CALL DCOPY_(NAC,C1(INMY+IPOA(ICSYM)),1,A1,1) - CALL DCOPY_(NAC,C2(INMY+IPOA(ICSYM)),1,A2,1) - ELSE - CALL VNEG(C1(INMY+IPOA(ICSYM)),1,A1,1,NAC) - CALL VNEG(C2(INMY+IPOA(ICSYM)),1,A2,1,NAC) - END IF - END IF - ELSE - IF(IFT.EQ.0)THEN - CALL SQUAR(C1(INMY+IPOA(IASYM)),A1,NVIRA) - CALL SQUAR(C2(INMY+IPOA(IASYM)),A2,NVIRA) - ELSE - CALL SQUARM(C1(INMY+IPOA(IASYM)),A1,NVIRA) - CALL SQUARM(C2(INMY+IPOA(IASYM)),A2,NVIRA) - END IF - END IF - IPF=IPOF(IASYM)+1 - CALL DGEMM_('N','T',NVIRA,NVIRA,NVIRC,1.0D00,A1,NVIRA, - * A2,NVIRA,1.0D00,F(IPF),NVIRA) - INN=1 - LNC=LN+NVIRP(ICSYM) - DO 105 I=1,NVIRC - TERM=DDOT_(NVIRA,A1(INN),1,A2(INN),1) - TSUM=TSUM+TERM - IC=LNC+I - TDMO(IC,IC)=TDMO(IC,IC)+TERM - INN=INN+NVIRA -105 CONTINUE -70 CONTINUE - TSUM=TSUM/2 -106 CONTINUE - DO 107 I=1,LN - TDMO(I,I)=TDMO(I,I)+IOC(I)*TSUM -107 CONTINUE -40 CONTINUE - DO 410 IASYM=1,NSYM - IAB=IPOF(IASYM) - NA1=NVIRP(IASYM)+1 - NA2=NVIRP(IASYM)+NVIR(IASYM) - DO 415 NA=NA1,NA2 - DO 420 NB=NA1,NA2 - IAB=IAB+1 - IF(NA.EQ.NB) GOTO 420 - TDMO(LN+NA,LN+NB)=F(IAB) -420 CONTINUE -415 CONTINUE -410 CONTINUE - CALL CSCALE(INDX,INTSYM,C1,SQ2INV) - CALL CSCALE(INDX,INTSYM,C2,SQ2INV) - RETURN - END diff -Nru openmolcas-22.02/src/mrci/abtd.F90 openmolcas-22.10/src/mrci/abtd.F90 --- openmolcas-22.02/src/mrci/abtd.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/abtd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,150 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ABTD(ICSPCK,INTSYM,INDX,C1,C2,TDMO,A1,A2,F) + +use mrci_global, only: IFIRST, IRC, LN, LSYM, NBAST, NSYM, NVIR, NVIRP, SQ2, SQ2INV +use Symmetry_Info, only: Mul +use Constants, only: Zero, One +use Definitions, only: wp, iwp, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: ICSPCK(*), INTSYM(*), INDX(*) +real(kind=wp), intent(inout) :: C1(*), C2(*), TDMO(NBAST,NBAST) +real(kind=wp), intent(_OUT_) :: A1(*), A2(*), F(*) +integer(kind=iwp) :: I, IA, IAB, IASYM, IC, ICSYM, IFT, II1, INDA, INMY, INN, IOC(55), IPF, IPOA(9), IPOF(9), ITAIL, LNA, LNC, & + MYL, MYSYM, NA, NA1, NA2, NAC, NB, NCLIM, NVIRA, NVIRC +real(kind=wp) :: TERM, TSUM +integer(kind=iwp), external :: ICUNP, JSUNP +real(kind=r8), external :: DDOT_ + +! CALCULATE A) TRANSITION DENSITY ELEMENTS OF TYPE TDMO(A,B) +! B) DIAGONAL ELEMENTS TDMO(I,I) AND TDMO(A,A) +! SCRATCH SPACES: A1(),A2(), SIZE NEEDED IS NVMAX**2 +! ALSO F(), SIZE NEEDED IS NVSQ +call CSCALE(INDX,INTSYM,C1,SQ2) +call CSCALE(INDX,INTSYM,C2,SQ2) +NCLIM = 4 +if (IFIRST /= 0) NCLIM = 2 +! MOVE TRANSITION DENSITY MATRIX TO F IN SYMMETRY BLOCKS +call IPO(IPOF,NVIR,MUL,NSYM,1,-1) +do IASYM=1,NSYM + IAB = IPOF(IASYM) + NA1 = NVIRP(IASYM)+1 + NA2 = NVIRP(IASYM)+NVIR(IASYM) + do NA=NA1,NA2 + do NB=NA1,NA2 + IAB = IAB+1 + F(IAB) = TDMO(LN+NA,LN+NB) + end do + end do +end do +II1 = 0 +ITAIL = IRC(NCLIM) +do INDA=1,ITAIL + do I=1,LN + II1 = II1+1 + IOC(I) = (1+ICUNP(ICSPCK,II1))/2 + end do + if (INDA <= IRC(1)) then + TSUM = C1(INDA)*C2(INDA) + else + MYSYM = JSUNP(INTSYM,INDA) + MYL = MUL(MYSYM,LSYM) + INMY = INDX(INDA)+1 + if (INDA <= IRC(2)) then + ! DOUBLET-DOUBLET INTERACTIONS + if (NVIR(MYL) == 0) cycle + IPF = IPOF(MYL)+1 + NVIRA = NVIR(MYL) + call DGER(NVIRA,NVIRA,One,C1(INMY),1,C2(INMY),1,F(IPF),NVIRA) + LNA = LN+NVIRP(MYL) + TSUM = Zero + do I=1,NVIRA + TERM = C1(INMY-1+I)*C2(INMY-1+I) + IA = LNA+I + TDMO(IA,IA) = TDMO(IA,IA)+TERM + TSUM = TSUM+TERM + end do + else + ! TRIPLET-TRIPLET AND SINGLET-SINGLET INTERACTIONS + IFT = 1 + if (INDA > IRC(3)) IFT = 0 + call IPO(IPOA,NVIR,MUL,NSYM,MYL,IFT) + TSUM = Zero + do IASYM=1,NSYM + IAB = IPOF(IASYM+1)-IPOF(IASYM) + if (IAB == 0) cycle + ICSYM = MUL(MYL,IASYM) + NVIRA = NVIR(IASYM) + NVIRC = NVIR(ICSYM) + if (NVIRC == 0) cycle + if (MYL /= 1) then + if (IASYM > ICSYM) then + call MTRANS(C1(INMY+IPOA(IASYM)),A1,NVIRA,NVIRC) + call MTRANS(C2(INMY+IPOA(IASYM)),A2,NVIRA,NVIRC) + else + NAC = NVIRA*NVIRC + if (IFT == 0) then + call DCOPY_(NAC,C1(INMY+IPOA(ICSYM)),1,A1,1) + call DCOPY_(NAC,C2(INMY+IPOA(ICSYM)),1,A2,1) + else + call VNEG(NAC,C1(INMY+IPOA(ICSYM)),1,A1,1) + call VNEG(NAC,C2(INMY+IPOA(ICSYM)),1,A2,1) + end if + end if + else + if (IFT == 0) then + call SQUAR(C1(INMY+IPOA(IASYM)),A1,NVIRA) + call SQUAR(C2(INMY+IPOA(IASYM)),A2,NVIRA) + else + call SQUARM(C1(INMY+IPOA(IASYM)),A1,NVIRA) + call SQUARM(C2(INMY+IPOA(IASYM)),A2,NVIRA) + end if + end if + IPF = IPOF(IASYM)+1 + call DGEMM_('N','T',NVIRA,NVIRA,NVIRC,One,A1,NVIRA,A2,NVIRA,One,F(IPF),NVIRA) + INN = 1 + LNC = LN+NVIRP(ICSYM) + do I=1,NVIRC + TERM = DDOT_(NVIRA,A1(INN),1,A2(INN),1) + TSUM = TSUM+TERM + IC = LNC+I + TDMO(IC,IC) = TDMO(IC,IC)+TERM + INN = INN+NVIRA + end do + end do + TSUM = TSUM/2 + end if + end if + do I=1,LN + TDMO(I,I) = TDMO(I,I)+IOC(I)*TSUM + end do +end do +do IASYM=1,NSYM + IAB = IPOF(IASYM) + NA1 = NVIRP(IASYM)+1 + NA2 = NVIRP(IASYM)+NVIR(IASYM) + do NA=NA1,NA2 + do NB=NA1,NA2 + IAB = IAB+1 + if (NA /= NB) TDMO(LN+NA,LN+NB) = F(IAB) + end do + end do +end do +call CSCALE(INDX,INTSYM,C1,SQ2INV) +call CSCALE(INDX,INTSYM,C2,SQ2INV) + +return + +end subroutine ABTD diff -Nru openmolcas-22.02/src/mrci/aid.f openmolcas-22.10/src/mrci/aid.f --- openmolcas-22.02/src/mrci/aid.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/aid.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,129 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE AID(INTSYM,INDX,C,DMO,A,B,FK) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "mrci.fh" - DIMENSION INTSYM(*),INDX(*),C(*),DMO(*), - * A(*),B(*),FK(*) - DIMENSION IPOB(9) -* - JSYM(L)=JSUNP(INTSYM,L) -* -C SCRATCH AREAS: A(),B() AND FK(). - CALL CSCALE(INDX,INTSYM,C,SQ2) - ICHK=0 - IJOLD=0 - NK=0 - NSK=1 - IADD10=IAD10(9) -C READ A COP BUFFER -100 CONTINUE - CALL dDAFILE(LUSYMB,2,COP,nCOP,IADD10) - CALL iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.EQ.0)GO TO 100 - IF(LEN.LT.0)GO TO 200 -C LOOP THROUGH THE COP BUFFER: - DO 10 II=1,LEN - IND=ICOP1(II) - IF(ICHK.NE.0)GO TO 460 - IF(IND.NE.0)GO TO 11 -C IND=0 INDICATES END OF THIS BLOCK OF COUPLING COEFFS. - ICHK=1 - GO TO 10 -460 CONTINUE -C ICHK=1 INDICATES BEGINNING OF A NEW BLOCK OF COUPLING COEFFS. - ICHK=0 - IF(IJOLD.NE.0) THEN -C PUT AWAY FK INTO DMO - NA1=NVIRP(NSK)+1 - NA2=NVIRP(NSK)+NVIR(NSK) - INK=0 - IF(NA2.LT.NA1)GO TO 10 - DO 113 NA=NA1,NA2 - INK=INK+1 - NAK=IROW(LN+NA)+NK - DMO(NAK)=FK(INK) -113 CONTINUE - END IF - NK=IND - IJOLD=NK - NSK=NSM(NK) -C PICK OUT ELEMENTS FROM DMO AND PUT INTO FK: - NA1=NVIRP(NSK)+1 - NA2=NVIRP(NSK)+NVIR(NSK) - INK=0 - IF(NA2.LT.NA1)GO TO 10 - DO 13 NA=NA1,NA2 - INK=INK+1 - NAK=IROW(LN+NA)+NK - FK(INK)=DMO(NAK) -13 CONTINUE - GO TO 10 -11 IF(INK.EQ.0)GO TO 10 -* ITYP=MOD(IND,2**6) -* ICP2=MOD(IND/2**6,2**13) -* ICP1=MOD(IND/2**19,2**13) - ITYP=IBITS(IND, 0, 6) - ICP2=IBITS(IND, 6,13) - ICP1=IBITS(IND,19,13) - IF(ITYP.GT.1)GO TO 12 - INDA=ICP1 - INDB=IRC(1)+ICP2 - INNY=INDX(INDB)+1 - COPI=C(INDA)*COP(II)/ENP - CALL DAXPY_(INK,COPI,C(INNY),1,FK,1) - GO TO 10 -12 IF(ITER.EQ.1 .AND. IREST.EQ.0)GO TO 10 - INDA=IRC(1)+ICP1 - INDB=IRC(ITYP)+ICP2 - INMY=INDX(INDA)+1 - INNY=INDX(INDB)+1 - MYSYM=JSYM(INDA) - NYSYM=MUL(MYSYM,NSK) - MYL=MUL(MYSYM,LSYM) - NYL=MUL(NYSYM,LSYM) - IFT=0 - IF(ITYP.EQ.2)IFT=1 - CALL IPO(IPOB,NVIR,MUL,NSYM,NYL,IFT) - NVM=NVIR(MYL) - CALL FZERO(B,INK) - COPI=COP(II)/ENP - IF(NYL.NE.1) THEN - IF(NSK.GT.MYL) THEN - CALL FMMM(C(INMY),C(INNY+IPOB(NSK)),B,1,INK,NVM) - CALL VSMA(B,1,COPI,FK,1,FK,1,INK) - ELSE - CALL FMMM(C(INNY+IPOB(MYL)),C(INMY),B,INK,1,NVM) - IF(IFT.EQ.1)COPI=-COPI - CALL VSMA(B,1,COPI,FK,1,FK,1,INK) - END IF - ELSE - IF(IFT.EQ.0)CALL SQUAR(C(INNY+IPOB(MYL)),A,NVM) - IF(IFT.EQ.1)CALL SQUARN(C(INNY+IPOB(MYL)),A,NVM) - CALL FMMM(C(INMY),A,B,1,INK,NVM) - CALL VSMA(B,1,COPI,FK,1,FK,1,INK) - END IF -10 CONTINUE - GO TO 100 -200 CONTINUE - NA1=NVIRP(NSK)+1 - NA2=NVIRP(NSK)+NVIR(NSK) - INK=0 - DO 213 NA=NA1,NA2 - INK=INK+1 - NAK=IROW(LN+NA)+NK - DMO(NAK)=FK(INK) -213 CONTINUE - CALL CSCALE(INDX,INTSYM,C,SQ2INV) - RETURN - END diff -Nru openmolcas-22.02/src/mrci/aid.F90 openmolcas-22.10/src/mrci/aid.F90 --- openmolcas-22.02/src/mrci/aid.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/aid.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,137 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine AID(INTSYM,INDX,C,DMO,A,B,FK) + +use mrci_global, only: ENP, IRC, IREST, IROW, ITER, LN, LSYM, LUSYMB, NSM, NSYM, NVIR, NVIRP, SQ2, SQ2INV +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Constants, only: Zero +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: INTSYM(*), INDX(*) +real(kind=wp), intent(inout) :: C(*), DMO(*), FK(*) +real(kind=wp), intent(_OUT_) :: A(*), B(*) +integer(kind=iwp) :: IADD10, ICHK, ICP1, ICP2, IFT, II, IJOLD, ILEN, IND, INDA, INDB, INK, INMY, INNY, IPOB(9), ITYP, MYL, MYSYM, & + NA, NA1, NA2, NAK, NK, NSK, NVM, NYL, NYSYM +real(kind=wp) :: COPI +integer(kind=iwp), external :: JSUNP + +! SCRATCH AREAS: A(),B() AND FK(). +call CSCALE(INDX,INTSYM,C,SQ2) +ICHK = 0 +IJOLD = 0 +NK = 0 +NSK = 1 +IADD10 = IAD10(9) +! READ A COP BUFFER +do + call dDAFILE(LUSYMB,2,COP,nCOP,IADD10) + call iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN == 0) cycle + if (ILEN < 0) exit + ! LOOP THROUGH THE COP BUFFER: + do II=1,ILEN + IND = ICOP1(II) + if (ICHK == 0) then + if (IND == 0) then + ! IND=0 INDICATES END OF THIS BLOCK OF COUPLING COEFFS. + ICHK = 1 + else + if (INK == 0) cycle + ITYP = ibits(IND,0,6) + ICP2 = ibits(IND,6,13) + ICP1 = ibits(IND,19,13) + if (ITYP > 1) then + if ((ITER == 1) .and. (IREST == 0)) cycle + INDA = IRC(1)+ICP1 + INDB = IRC(ITYP)+ICP2 + INMY = INDX(INDA)+1 + INNY = INDX(INDB)+1 + MYSYM = JSUNP(INTSYM,INDA) + NYSYM = MUL(MYSYM,NSK) + MYL = MUL(MYSYM,LSYM) + NYL = MUL(NYSYM,LSYM) + IFT = 0 + if (ITYP == 2) IFT = 1 + call IPO(IPOB,NVIR,MUL,NSYM,NYL,IFT) + NVM = NVIR(MYL) + B(1:INK) = Zero + COPI = COP(II)/ENP + if (NYL /= 1) then + if (NSK > MYL) then + call FMMM(C(INMY),C(INNY+IPOB(NSK)),B,1,INK,NVM) + else + call FMMM(C(INNY+IPOB(MYL)),C(INMY),B,INK,1,NVM) + if (IFT == 1) COPI = -COPI + end if + else + if (IFT == 0) call SQUAR(C(INNY+IPOB(MYL)),A,NVM) + if (IFT == 1) call SQUARN(C(INNY+IPOB(MYL)),A,NVM) + call FMMM(C(INMY),A,B,1,INK,NVM) + end if + FK(1:INK) = FK(1:INK)+COPI*B(1:INK) + else + INDA = ICP1 + INDB = IRC(1)+ICP2 + INNY = INDX(INDB)+1 + COPI = C(INDA)*COP(II)/ENP + FK(1:INK) = FK(1:INK)+COPI*C(INNY:INNY+INK-1) + end if + end if + else + ! ICHK=1 INDICATES BEGINNING OF A NEW BLOCK OF COUPLING COEFFS. + ICHK = 0 + if (IJOLD /= 0) then + ! PUT AWAY FK INTO DMO + NA1 = NVIRP(NSK)+1 + NA2 = NVIRP(NSK)+NVIR(NSK) + INK = 0 + if (NA2 < NA1) cycle + do NA=NA1,NA2 + INK = INK+1 + NAK = IROW(LN+NA)+NK + DMO(NAK) = FK(INK) + end do + end if + NK = IND + IJOLD = NK + NSK = NSM(NK) + ! PICK OUT ELEMENTS FROM DMO AND PUT INTO FK: + NA1 = NVIRP(NSK)+1 + NA2 = NVIRP(NSK)+NVIR(NSK) + INK = 0 + if (NA2 < NA1) cycle + do NA=NA1,NA2 + INK = INK+1 + NAK = IROW(LN+NA)+NK + FK(INK) = DMO(NAK) + end do + end if + end do +end do +NA1 = NVIRP(NSK)+1 +NA2 = NVIRP(NSK)+NVIR(NSK) +INK = 0 +do NA=NA1,NA2 + INK = INK+1 + NAK = IROW(LN+NA)+NK + DMO(NAK) = FK(INK) +end do +call CSCALE(INDX,INTSYM,C,SQ2INV) + +return + +end subroutine AID diff -Nru openmolcas-22.02/src/mrci/ai_mrci.f openmolcas-22.10/src/mrci/ai_mrci.f --- openmolcas-22.02/src/mrci/ai_mrci.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/ai_mrci.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,205 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -* SUBROUTINE AI(INTSYM,INDX,C,S,FC,BUFIN,IBUFIN,A,B,FK,DBK,KTYP) -* SUBROUTINE AI_MRCI(INTSYM,INDX,C,S,FC,BUF,IBUF,A,B,FK,DBK,KTYP) - SUBROUTINE AI_MRCI(INTSYM,INDX,C,S,FC,A,B,FK,DBK,KTYP) - IMPLICIT REAL*8 (A-H,O-Z) -#include "WrkSpc.fh" -#include "SysDef.fh" -#include "mrci.fh" - DIMENSION INTSYM(*),INDX(*),C(*),S(*), -* * FC(*),BUFIN(*),IBUFIN(*), -* * FC(*),BUF(NBITM3),IBUF(NBITM3+2), - * FC(*), - * A(*),B(*),FK(*),DBK(*) - DIMENSION IPOB(9) - PARAMETER (ONE=1.0D00) -* - JSYM(L)=JSUNP(INTSYM,L) -* -C KTYP=0, (A/I) INTEGRALS -C KTYP=1, (AI/JK) INTEGRALS - - CALL GETMEM('BUF','ALLO','REAL',LBUF,NBITM3) - CALL GETMEM('IBUF','ALLO','INTE',LIBUF,NBITM3+2) - - CALL CSCALE(INDX,INTSYM,C,SQ2) - CALL CSCALE(INDX,INTSYM,S,SQ2INV) - NVT=IROW(NVIRT+1) - ICHK=0 - IJOLD=0 - NK=0 - NSA=1 - NOTT=LN*(LN+1) - NOVST=LN*NVIRT+1+NVT -CPAM97 New portable code: -*PAM04 NBCMX3=(RTOI*NBSIZ3-2)/(RTOI+1) -*PAM04 IBOFF3=RTOI*NBCMX3 -*PAM04 IBBC3=IBOFF3+NBCMX3+1 -*PAM04 IBDA3=IBBC3+1 - - IF(KTYP.EQ.0)IADD10=IAD10(9) - IF(KTYP.EQ.1)IADD10=IAD10(7) -C READ A COP BUFFER -100 CONTINUE - CALL dDAFILE(LUSYMB,2,COP,nCOP,IADD10) - CALL iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.EQ.0)GO TO 100 - IF(LEN.LT.0)GO TO 200 -C LOOP THROUGH THE COP BUFFER: - DO 10 II=1,LEN - IND=ICOP1(II) - IF(ICHK.NE.0) THEN -C BEGIN A RATHER LONG IF-BLOCK. -C ICHK FLAG IS SET. THIS SIGNALS THAT PREVIOUS IND WAS 0, WHICH IS -C USED TO INDICATE CHANGE TO A NEW BLOCK OF COUPLING COEFFICIENTS. -C RESET ICHK FLAG. - ICHK=0 - IF(KTYP.EQ.0) THEN -C AI CASE. SAVE INTERNAL ORBITAL INDEX IN NK: - NK=IND - IJOLD=NK - NSK=NSM(NK) - NSA=NSK - GO TO 20 - END IF -C AIJK CASE. UNPACK INTERNAL ORBITAL INDICES INTO NI,NJ,NK: - INDI=IND -* NI=MOD(INDI,2**10) -* NJ=MOD(INDI/2**10,2**10) -* NK=MOD(INDI/2**20,2**10) - NI=IBITS(INDI, 0,10) - NJ=IBITS(INDI,10,10) - NK=IBITS(INDI,20,10) - NSI=NSM(NI) - NSJ=NSM(NJ) - NSK=NSM(NK) - NSIJ=MUL(NSI,NSJ) - NSA=MUL(NSIJ,NSK) - IJ=IROW(NI)+NJ - IF(IJ.NE.IJOLD) THEN -C NEW INTERNAL PAIR IJ. LOAD A NEW SET OF INTEGRALS INTO FC: - IJOLD=IJ - IADR=LASTAD(NOVST+NOTT+IJ) - CALL FZERO(FC,NBTRI) - -90 CONTINUE -*PAM04 CALL dDAFILE(Lu_60,2,IBUFIN,NBSIZ3,IADR) - CALL iDAFILE(Lu_60,2,iWORK(LIBUF),NBITM3+2,IADR) - CALL dDAFILE(Lu_60,2,WORK(LBUF),NBITM3,IADR) - LENGTH=iWORK(LIBUF+NBITM3) - IADR =iWORK(LIBUF+NBITM3+1) -*PAM04 LENGTH=IBUFIN(IBBC3) -*PAM04 IADR=IBUFIN(IBDA3) - IF(LENGTH.EQ.0)GO TO 91 -* CALL SCATTER(LENGTH,FC,IBUFIN(IBOFF3+1),BUFIN) - do i=0,length-1 -*PAM04 fc(IBUFIN(IBOFF3+i))=bufin(i) - fc(iWORK(LIBUF+i))=WORK(LBUF+i) - end do -91 IF(IADR.NE.-1) GO TO 90 - END IF -20 CONTINUE -C FOR THIS PARTICULAR K, TRANSFER FC(NK,NA) TO ARRAY FK: - NVIRA=NVIR(NSA) - IF(NVIRA.EQ.0) GOTO 10 - DO 13 I=1,NVIRA - NA=NVIRP(NSA)+I - NAK=IROW(LN+NA)+NK - FK(I)=FC(NAK) -13 CONTINUE - GOTO 10 - END IF -C END OF THE LONG IF-BLOCK. - IF(IND.EQ.0) THEN -C IND=0 SIGNALS SWITCH TO A NEW SET OF INTEGRALS. - ICHK=1 - GO TO 10 - END IF -C WE ARE PROCESSING A COUPLING COEFFICIENT AS USUAL. - IF(NVIRA.EQ.0)GO TO 10 -* ITYP=MOD(IND,2**6) -* ICP2=MOD(IND/2**6,2**13) -* ICP1=MOD(IND/2**19,2**13) - ITYP=IBITS(IND, 0, 6) - ICP2=IBITS(IND, 6,13) - ICP1=IBITS(IND,19,13) - IF(ITYP.GT.1)GO TO 12 -C ITYP=1. VALENCE-SINGLES CASE. - INDA=ICP1 - INDB=IRC(1)+ICP2 - INNY=INDX(INDB)+1 - COPI=COP(II)*C(INDA) - CALL DAXPY_(NVIRA,COPI,FK,1,S(INNY),1) - TERM=DDOT_(NVIRA,FK,1,C(INNY),1) - S(INDA)=S(INDA)+COP(II)*TERM - GO TO 10 -12 IF(ITER.EQ.1 .AND. IREST.EQ.0)GO TO 10 - INDA=IRC(1)+ICP1 - INDB=IRC(ITYP)+ICP2 - INMY=INDX(INDA)+1 - INNY=INDX(INDB)+1 - MYINTS=JSYM(INDA) - NYINTS=MUL(MYINTS,NSA) - MYEXTS=MUL(MYINTS,LSYM) - NYEXTS=MUL(NYINTS,LSYM) - IFT=0 - IF(ITYP.EQ.2)IFT=1 - CALL IPO(IPOB,NVIR,MUL,NSYM,NYEXTS,IFT) - NVM=NVIR(MYEXTS) - CALL FZERO(DBK,NVIRA) - CALL DAXPY_(NVIRA,COP(II),FK,1,DBK,1) - IF(NYEXTS.NE.1)GO TO 25 - IF(IFT.EQ.0)CALL SQUAR(C(INNY+IPOB(MYEXTS)),A,NVM) - IF(IFT.EQ.1)CALL SQUARM(C(INNY+IPOB(MYEXTS)),A,NVM) - CALL FZERO(B,NVM) - CALL FMMM(DBK,A,B,1,NVM,NVIRA) - CALL DAXPY_(NVM,ONE,B,1,S(INMY),1) - SIGN=1.0D00 - IF(IFT.EQ.1)SIGN=-1.0D00 - IOUT=INNY+IPOB(MYEXTS)-1 - DO 125 I=1,NVM - DO 130 J=1,I - IOUT=IOUT+1 - TERM=DBK(I)*C(INMY+J-1)+SIGN*DBK(J)*C(INMY+I-1) - S(IOUT)=S(IOUT)+TERM -130 CONTINUE - IF(IFT.EQ.1)GO TO 125 - TERM=DBK(I)*C(INMY+I-1) - S(IOUT)=S(IOUT)-TERM -125 CONTINUE - GO TO 10 -25 NKM=NVIRA*NVM - CALL FZERO(B,NVM) - IF(NSA.GT.MYEXTS)GO TO 26 - IF(IFT.EQ.1)CALL VNEG(DBK,1,DBK,1,NVIRA) - CALL FMMM(DBK,C(INNY+IPOB(MYEXTS)),B,1,NVM,NVIRA) - CALL DAXPY_(NVM,ONE,B,1,S(INMY),1) - CALL FZERO(B,NKM) - CALL FMMM(DBK,C(INMY),B,NVIRA,NVM,1) - CALL DAXPY_(NKM,ONE,B,1,S(INNY+IPOB(MYEXTS)),1) - GO TO 10 -26 CALL FMMM(C(INNY+IPOB(NSA)),DBK,B,NVM,1,NVIRA) - CALL DAXPY_(NVM,ONE,B,1,S(INMY),1) - CALL FZERO(B,NKM) - CALL FMMM(C(INMY),DBK,B,NVM,NVIRA,1) - CALL DAXPY_(NKM,ONE,B,1,S(INNY+IPOB(NSA)),1) - GO TO 10 -10 CONTINUE - GO TO 100 -200 CONTINUE - CALL CSCALE(INDX,INTSYM,C,SQ2INV) - CALL CSCALE(INDX,INTSYM,S,SQ2) - CALL GETMEM('BUF','FREE','REAL',LBUF,NBITM3) - CALL GETMEM('IBUF','FREE','INTE',LIBUF,NBITM3+2) - RETURN - END diff -Nru openmolcas-22.02/src/mrci/ai_mrci.F90 openmolcas-22.10/src/mrci/ai_mrci.F90 --- openmolcas-22.02/src/mrci/ai_mrci.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/ai_mrci.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,196 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine AI_MRCI(INTSYM,INDX,C,S,FC,A,B,FK,DBK,KTYP) + +use mrci_global, only: IRC, IREST, IROW, ITER, LASTAD, LN, LSYM, Lu_60, LUSYMB, NBITM3, NBTRI, NSM, NSYM, NVIR, NVIRP, NVIRT, SQ2, & + SQ2INV +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: INTSYM(*), INDX(*), KTYP +real(kind=wp), intent(inout) :: C(*), S(*), FC(*) +real(kind=wp), intent(_OUT_) :: A(*), B(*), FK(*), DBK(*) +integer(kind=iwp) :: i, IADD10, IADR, ICHK, ICP1, ICP2, IFT, II, IJ, IJOLD, ILEN, IND, INDA, INDB, INDI, INMY, INNY, IOUT, & + IPOB(9), ITYP, J, LENGTH, MYEXTS, MYINTS, NA, NAK, NI, NJ, NK, NKM, NOTT, NOVST, NSA, NSI, NSIJ, NSJ, NSK, & + NVIRA, NVM, NVT, NYEXTS, NYINTS +real(kind=wp) :: COPI, SGN, TERM +integer(kind=iwp), allocatable :: iBuf(:) +real(kind=wp), allocatable :: Buf(:) +integer(kind=iwp), external :: JSUNP +real(kind=r8), external :: DDOT_ + +! KTYP=0, (A/I) INTEGRALS +! KTYP=1, (AI/JK) INTEGRALS + +call mma_allocate(Buf,NBITM3,label='BUF') +call mma_allocate(iBuf,NBITM3+2,label='IBUF') + +call CSCALE(INDX,INTSYM,C,SQ2) +call CSCALE(INDX,INTSYM,S,SQ2INV) +NVT = IROW(NVIRT+1) +ICHK = 0 +IJOLD = 0 +NK = 0 +NSA = 1 +NOTT = LN*(LN+1) +NOVST = LN*NVIRT+1+NVT +!PAM97 New portable code: + +if (KTYP == 0) IADD10 = IAD10(9) +if (KTYP == 1) IADD10 = IAD10(7) +! READ A COP BUFFER +do + call dDAFILE(LUSYMB,2,COP,nCOP,IADD10) + call iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN < 0) exit + ! LOOP THROUGH THE COP BUFFER: + do II=1,ILEN + IND = ICOP1(II) + if (ICHK /= 0) then + ! BEGIN A RATHER LONG IF-BLOCK. + ! ICHK FLAG IS SET. THIS SIGNALS THAT PREVIOUS IND WAS 0, WHICH IS + ! USED TO INDICATE CHANGE TO A NEW BLOCK OF COUPLING COEFFICIENTS. + ! RESET ICHK FLAG. + ICHK = 0 + if (KTYP == 0) then + ! AI CASE. SAVE INTERNAL ORBITAL INDEX IN NK: + NK = IND + IJOLD = NK + NSK = NSM(NK) + NSA = NSK + else + ! AIJK CASE. UNPACK INTERNAL ORBITAL INDICES INTO NI,NJ,NK: + INDI = IND + NI = ibits(INDI,0,10) + NJ = ibits(INDI,10,10) + NK = ibits(INDI,20,10) + NSI = NSM(NI) + NSJ = NSM(NJ) + NSK = NSM(NK) + NSIJ = MUL(NSI,NSJ) + NSA = MUL(NSIJ,NSK) + IJ = IROW(NI)+NJ + if (IJ /= IJOLD) then + ! NEW INTERNAL PAIR IJ. LOAD A NEW SET OF INTEGRALS INTO FC: + IJOLD = IJ + IADR = LASTAD(NOVST+NOTT+IJ) + FC(1:NBTRI) = Zero + + do + call iDAFILE(Lu_60,2,iBuf,NBITM3+2,IADR) + call dDAFILE(Lu_60,2,Buf,NBITM3,IADR) + LENGTH = iBuf(NBITM3+1) + IADR = iBuf(NBITM3+2) + do i=1,length + fc(iBuf(i)) = Buf(i) + end do + if (IADR == -1) exit + end do + end if + end if + ! FOR THIS PARTICULAR K, TRANSFER FC(NK,NA) TO ARRAY FK: + NVIRA = NVIR(NSA) + do I=1,NVIRA + NA = NVIRP(NSA)+I + NAK = IROW(LN+NA)+NK + FK(I) = FC(NAK) + end do + ! END OF THE LONG IF-BLOCK. + else if (IND == 0) then + ! IND=0 SIGNALS SWITCH TO A NEW SET OF INTEGRALS. + ICHK = 1 + else if (NVIRA /= 0) then + ! WE ARE PROCESSING A COUPLING COEFFICIENT AS USUAL. + ITYP = ibits(IND,0,6) + ICP2 = ibits(IND,6,13) + ICP1 = ibits(IND,19,13) + if (ITYP <= 1) then + ! ITYP=1. VALENCE-SINGLES CASE. + INDA = ICP1 + INDB = IRC(1)+ICP2 + INNY = INDX(INDB)+1 + COPI = COP(II)*C(INDA) + S(INNY:INNY+NVIRA-1) = S(INNY:INNY+NVIRA-1)+COPI*FK(1:NVIRA) + TERM = DDOT_(NVIRA,FK,1,C(INNY),1) + S(INDA) = S(INDA)+COP(II)*TERM + else if ((ITER /= 1) .or. (IREST /= 0)) then + INDA = IRC(1)+ICP1 + INDB = IRC(ITYP)+ICP2 + INMY = INDX(INDA)+1 + INNY = INDX(INDB)+1 + MYINTS = JSUNP(INTSYM,INDA) + NYINTS = MUL(MYINTS,NSA) + MYEXTS = MUL(MYINTS,LSYM) + NYEXTS = MUL(NYINTS,LSYM) + IFT = 0 + if (ITYP == 2) IFT = 1 + call IPO(IPOB,NVIR,MUL,NSYM,NYEXTS,IFT) + NVM = NVIR(MYEXTS) + DBK(1:NVIRA) = COP(II)*FK(1:NVIRA) + if (NYEXTS == 1) then + if (IFT == 0) call SQUAR(C(INNY+IPOB(MYEXTS)),A,NVM) + if (IFT == 1) call SQUARM(C(INNY+IPOB(MYEXTS)),A,NVM) + B(1:NVM) = Zero + call FMMM(DBK,A,B,1,NVM,NVIRA) + S(INMY:INMY+NVM-1) = S(INMY:INMY+NVM-1)+B(1:NVM) + SGN = One + if (IFT == 1) SGN = -One + IOUT = INNY+IPOB(MYEXTS)-1 + do I=1,NVM + do J=1,I + IOUT = IOUT+1 + TERM = DBK(I)*C(INMY+J-1)+SGN*DBK(J)*C(INMY+I-1) + S(IOUT) = S(IOUT)+TERM + end do + if (IFT == 1) cycle + TERM = DBK(I)*C(INMY+I-1) + S(IOUT) = S(IOUT)-TERM + end do + else + NKM = NVIRA*NVM + B(1:NVM) = Zero + if (NSA <= MYEXTS) then + if (IFT == 1) DBK(1:NVIRA) = -DBK(1:NVIRA) + call FMMM(DBK,C(INNY+IPOB(MYEXTS)),B,1,NVM,NVIRA) + S(INMY:INMY+NVM-1) = S(INMY:INMY+NVM-1)+B(1:NVM) + B(1:NKM) = Zero + call FMMM(DBK,C(INMY),B,NVIRA,NVM,1) + J = INNY+IPOB(MYEXTS) + S(J:J+NKM-1) = S(J:J+NKM-1)+B(1:NKM) + else + call FMMM(C(INNY+IPOB(NSA)),DBK,B,NVM,1,NVIRA) + S(INMY:INMY+NVM-1) = S(INMY:INMY+NVM-1)+B(1:NVM) + B(1:NKM) = Zero + call FMMM(C(INMY),DBK,B,NVM,NVIRA,1) + J = INNY+IPOB(NSA) + S(J:J+NKM-1) = S(J:J+NKM-1)+B(1:NKM) + end if + end if + end if + end if + end do +end do +call CSCALE(INDX,INTSYM,C,SQ2INV) +call CSCALE(INDX,INTSYM,S,SQ2) +call mma_deallocate(Buf) +call mma_deallocate(iBuf) + +return + +end subroutine AI_MRCI diff -Nru openmolcas-22.02/src/mrci/aitd.f openmolcas-22.10/src/mrci/aitd.f --- openmolcas-22.02/src/mrci/aitd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/aitd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,148 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE AITD(INTSYM,INDX,C1,C2,TDMO,A,FAK,FKA) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "mrci.fh" - DIMENSION INTSYM(*),INDX(*),C1(*),C2(*), - * TDMO(NBAST,NBAST),A(*),FAK(*),FKA(*) - DIMENSION IPOB(9) -* - JSYM(L)=JSUNP(INTSYM,L) -* -C CALCULATE TRANSITION DENSITY ELEMENTS TDMO(K,A) AND TDMO(A,K), -C WHERE K IS INTERNAL, A IS EXTERNAL ORBITAL. -C SCRATCH AREAS ARE: A(), SIZE NEEDED IS NVMAX**2 -C AND FAK(), FKA(), SIZE NEEDED IS NVMAX - CALL CSCALE(INDX,INTSYM,C1,SQ2) - CALL CSCALE(INDX,INTSYM,C2,SQ2) - ICHK=0 - IJOLD=0 - NK=0 - NSK=1 - IADD10=IAD10(9) -C READ A COP BUFFER -100 CONTINUE - CALL dDAFILE(LUSYMB,2,COP,nCOP,IADD10) - CALL iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.EQ.0)GO TO 100 - IF(LEN.LT.0)GO TO 200 -C LOOP THROUGH THE COP BUFFER: - DO 10 II=1,LEN - IND=ICOP1(II) - IF(ICHK.NE.0)GO TO 460 - IF(IND.NE.0)GO TO 11 - ICHK=1 - GO TO 10 -460 ICHK=0 - IF(IJOLD.NE.0) THEN -C PUT FAK,FKA BACK INTO TDMO. - NA1=NVIRP(NSK)+1 - NA2=NVIRP(NSK)+NVIR(NSK) - INK=0 - IF(NA2.LT.NA1)GO TO 10 - DO 113 NA=NA1,NA2 - INK=INK+1 - TDMO(LN+NA,NK)=FAK(INK) - TDMO(NK,LN+NA)=FKA(INK) -113 CONTINUE - END IF - NK=IND - IJOLD=NK - NSK=NSM(NK) -C PUT TDMO ELEMENTS INTO ARRAYS FAK, FKA. - NA1=NVIRP(NSK)+1 - NA2=NVIRP(NSK)+NVIR(NSK) - INK=0 - IF(NA2.LT.NA1)GO TO 10 - DO 13 NA=NA1,NA2 - INK=INK+1 - FAK(INK)=TDMO(LN+NA,NK) - FKA(INK)=TDMO(NK,LN+NA) -13 CONTINUE - GO TO 10 -11 IF(INK.EQ.0)GO TO 10 -* ITYP=MOD(IND,2**6) -* ICP2=MOD(IND/2**6,2**13) -* ICP1=MOD(IND/2**19,2**13) - ITYP=IBITS(IND, 0, 6) - ICP2=IBITS(IND, 6,13) - ICP1=IBITS(IND,19,13) - IF(ITYP.GT.1)GO TO 12 - INDA=ICP1 - INDB=IRC(1)+ICP2 - INNY=INDX(INDB)+1 - COPI=C1(INDA)*COP(II) - CALL DAXPY_(INK,COPI,C2(INNY),1,FAK,1) - COPI=C2(INDA)*COP(II) - CALL DAXPY_(INK,COPI,C1(INNY),1,FKA,1) - GO TO 10 -12 CONTINUE - INDA=IRC(1)+ICP1 - INDB=IRC(ITYP)+ICP2 - INMY=INDX(INDA)+1 - INNY=INDX(INDB)+1 - MYSYM=JSYM(INDA) - NYSYM=MUL(MYSYM,NSK) - MYL=MUL(MYSYM,LSYM) - NYL=MUL(NYSYM,LSYM) - IFT=0 - IF(ITYP.EQ.2)IFT=1 - CALL IPO(IPOB,NVIR,MUL,NSYM,NYL,IFT) - NVM=NVIR(MYL) - COPI=COP(II) - IF(NYL.NE.1) THEN - IF(NSK.GT.MYL) THEN -* CALL DGEMTX (NVM,INK,COPI,C1(INNY+IPOB(NSK)),NVM, -* * C2(INMY),1,FAK,1) - CALL DGEMV_('T',NVM,INK,COPI,C1(INNY+IPOB(NSK)),NVM, - * C2(INMY),1,1.0D0,FAK,1) -* CALL DGEMTX (NVM,INK,COPI,C2(INNY+IPOB(NSK)),NVM, -* * C1(INMY),1,FKA,1) - CALL DGEMV_('T',NVM,INK,COPI,C2(INNY+IPOB(NSK)),NVM, - * C1(INMY),1,1.0D0,FKA,1) - ELSE - IF(IFT.EQ.1)COPI=-COPI -* CALL DGEMX (INK,NVM,COPI,C1(INNY+IPOB(MYL)),INK, -* * C2(INMY),1,FAK,1) - CALL DGEMV_('N',INK,NVM,COPI,C1(INNY+IPOB(MYL)),INK, - * C2(INMY),1,1.0D0,FAK,1) -* CALL DGEMX (INK,NVM,COPI,C2(INNY+IPOB(MYL)),INK, -* * C1(INMY),1,FKA,1) - CALL DGEMV_('N',INK,NVM,COPI,C2(INNY+IPOB(MYL)),INK, - * C1(INMY),1,1.0D0,FKA,1) - END IF - ELSE - IF(IFT.EQ.0)CALL SQUAR(C1(INNY+IPOB(MYL)),A,NVM) - IF(IFT.EQ.1)CALL SQUARN(C1(INNY+IPOB(MYL)),A,NVM) -* CALL DGEMTX (NVM,INK,COPI,A,NVM,C2(INMY),1,FAK,1) - CALL DGEMV_('T',NVM,INK,COPI,A,NVM,C2(INMY),1,1.0D0,FAK,1) - IF(IFT.EQ.0)CALL SQUAR(C2(INNY+IPOB(MYL)),A,NVM) - IF(IFT.EQ.1)CALL SQUARN(C2(INNY+IPOB(MYL)),A,NVM) -* CALL DGEMTX (NVM,INK,COPI,A,NVM,C1(INMY),1,FKA,1) - CALL DGEMV_('T',NVM,INK,COPI,A,NVM,C1(INMY),1,1.0D0,FKA,1) - END IF -10 CONTINUE - GO TO 100 -200 CONTINUE - NA1=NVIRP(NSK)+1 - NA2=NVIRP(NSK)+NVIR(NSK) - INK=0 - DO 213 NA=NA1,NA2 - INK=INK+1 - TDMO(LN+NA,NK)=FAK(INK) - TDMO(NK,LN+NA)=FKA(INK) -213 CONTINUE - CALL CSCALE(INDX,INTSYM,C1,SQ2INV) - CALL CSCALE(INDX,INTSYM,C2,SQ2INV) - RETURN - END diff -Nru openmolcas-22.02/src/mrci/aitd.F90 openmolcas-22.10/src/mrci/aitd.F90 --- openmolcas-22.02/src/mrci/aitd.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/aitd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,141 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine AITD(INTSYM,INDX,C1,C2,TDMO,A,FAK,FKA) + +use mrci_global, only: IRC, LN, LSYM, LUSYMB, NBAST, NSM, NSYM, NVIR, NVIRP, SQ2, SQ2INV +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Constants, only: One +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: INTSYM(*), INDX(*) +real(kind=wp), intent(inout) :: C1(*), C2(*), TDMO(NBAST,NBAST), FAK(*), FKA(*) +real(kind=wp), intent(_OUT_) :: A(*) +integer(kind=iwp) :: IADD10, ICHK, ICP1, ICP2, IFT, II, IJOLD, ILEN, IND, INDA, INDB, INK, INMY, INNY, IPOB(9), ITYP, MYL, MYSYM, & + NA, NA1, NA2, NK, NSK, NVM, NYL, NYSYM +real(kind=wp) :: COPI +integer(kind=iwp), external :: JSUNP + +! CALCULATE TRANSITION DENSITY ELEMENTS TDMO(K,A) AND TDMO(A,K), +! WHERE K IS INTERNAL, A IS EXTERNAL ORBITAL. +! SCRATCH AREAS ARE: A(), SIZE NEEDED IS NVMAX**2 +! AND FAK(), FKA(), SIZE NEEDED IS NVMAX +call CSCALE(INDX,INTSYM,C1,SQ2) +call CSCALE(INDX,INTSYM,C2,SQ2) +ICHK = 0 +IJOLD = 0 +NK = 0 +NSK = 1 +IADD10 = IAD10(9) +! READ A COP BUFFER +do + call dDAFILE(LUSYMB,2,COP,nCOP,IADD10) + call iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN < 0) exit + ! LOOP THROUGH THE COP BUFFER: + do II=1,ILEN + IND = ICOP1(II) + if (ICHK == 0) then + if (IND == 0) then + ICHK = 1 + else if (INK /= 0) then + ITYP = ibits(IND,0,6) + ICP2 = ibits(IND,6,13) + ICP1 = ibits(IND,19,13) + if (ITYP <= 1) then + INDA = ICP1 + INDB = IRC(1)+ICP2 + INNY = INDX(INDB)+1 + COPI = C1(INDA)*COP(II) + FAK(1:INK) = FAK(1:INK)+COPI*C2(INNY:INNY+INK-1) + COPI = C2(INDA)*COP(II) + FKA(1:INK) = FKA(1:INK)+COPI*C1(INNY:INNY+INK-1) + else + INDA = IRC(1)+ICP1 + INDB = IRC(ITYP)+ICP2 + INMY = INDX(INDA)+1 + INNY = INDX(INDB)+1 + MYSYM = JSUNP(INTSYM,INDA) + NYSYM = MUL(MYSYM,NSK) + MYL = MUL(MYSYM,LSYM) + NYL = MUL(NYSYM,LSYM) + IFT = 0 + if (ITYP == 2) IFT = 1 + call IPO(IPOB,NVIR,MUL,NSYM,NYL,IFT) + NVM = NVIR(MYL) + COPI = COP(II) + if (NYL /= 1) then + if (NSK > MYL) then + call DGEMV_('T',NVM,INK,COPI,C1(INNY+IPOB(NSK)),NVM,C2(INMY),1,One,FAK,1) + call DGEMV_('T',NVM,INK,COPI,C2(INNY+IPOB(NSK)),NVM,C1(INMY),1,One,FKA,1) + else + if (IFT == 1) COPI = -COPI + call DGEMV_('N',INK,NVM,COPI,C1(INNY+IPOB(MYL)),INK,C2(INMY),1,One,FAK,1) + call DGEMV_('N',INK,NVM,COPI,C2(INNY+IPOB(MYL)),INK,C1(INMY),1,One,FKA,1) + end if + else + if (IFT == 0) call SQUAR(C1(INNY+IPOB(MYL)),A,NVM) + if (IFT == 1) call SQUARN(C1(INNY+IPOB(MYL)),A,NVM) + call DGEMV_('T',NVM,INK,COPI,A,NVM,C2(INMY),1,One,FAK,1) + if (IFT == 0) call SQUAR(C2(INNY+IPOB(MYL)),A,NVM) + if (IFT == 1) call SQUARN(C2(INNY+IPOB(MYL)),A,NVM) + call DGEMV_('T',NVM,INK,COPI,A,NVM,C1(INMY),1,One,FKA,1) + end if + end if + end if + else + ICHK = 0 + if (IJOLD /= 0) then + ! PUT FAK,FKA BACK INTO TDMO. + NA1 = NVIRP(NSK)+1 + NA2 = NVIRP(NSK)+NVIR(NSK) + INK = 0 + if (NA2 < NA1) cycle + do NA=NA1,NA2 + INK = INK+1 + TDMO(LN+NA,NK) = FAK(INK) + TDMO(NK,LN+NA) = FKA(INK) + end do + end if + NK = IND + IJOLD = NK + NSK = NSM(NK) + ! PUT TDMO ELEMENTS INTO ARRAYS FAK, FKA. + NA1 = NVIRP(NSK)+1 + NA2 = NVIRP(NSK)+NVIR(NSK) + INK = 0 + do NA=NA1,NA2 + INK = INK+1 + FAK(INK) = TDMO(LN+NA,NK) + FKA(INK) = TDMO(NK,LN+NA) + end do + end if + end do +end do +NA1 = NVIRP(NSK)+1 +NA2 = NVIRP(NSK)+NVIR(NSK) +INK = 0 +do NA=NA1,NA2 + INK = INK+1 + TDMO(LN+NA,NK) = FAK(INK) + TDMO(NK,LN+NA) = FKA(INK) +end do +call CSCALE(INDX,INTSYM,C1,SQ2INV) +call CSCALE(INDX,INTSYM,C2,SQ2INV) + +return + +end subroutine AITD diff -Nru openmolcas-22.02/src/mrci/alloc_mrci.f openmolcas-22.10/src/mrci/alloc_mrci.f --- openmolcas-22.02/src/mrci/alloc_mrci.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/alloc_mrci.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,440 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE ALLOC_MRCI - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "warnings.h" -#include "mrci.fh" -*------ -* POW: This array is not used! -* DIMENSION IPOF(9) -*------ - ILIM=4 - IF(IFIRST.NE.0)ILIM=2 - NVSQ=0 - NVMAX=0 - DO 10 I=1,NSYM - NVMAX=MAX(NVMAX,NVIR(I)) - NVSQ=NVSQ+NVIR(I)**2 -10 CONTINUE - NVT=(NVIRT*(NVIRT+1))/2 - if (NVIRT.eq.0) then - Call SysAbendMsg('alloc_mrci.f:', - & 'no virtual orbitals in the basis',' ') - endif -*PAM04 MOVE ALLOCATION OF FOCK MATRIX TO SDCI. -*C FOCK MATRIX IN SORT,IIJJ,IJIJ,FIJ,AI. -* LFOCK=LPERMA -* LPERMX=LFOCK+NBTRI -*----------------------------------------------- -*PAM04 Change systematically: -*PAM04 (1) LPERMA, LPERMB, LPERMX set to 1 -*PAM04 (2) MAXMEM changed to MEMWRK - LPERMA=1 - LPERMB=1 - LPERMX=1 -*----------------------------------------------- -CPAM97 C BUFFER FOR MOTRA INTEGRALS, TIBUF, IN SORT, SORTA, SORTB. -CPAM97 LTIBUF=LPERMX -CPAM97 LPERMX=LTIBUF+NTIBUF -*PAM04 MEMX=MAXMEM-LPERMX+1 -*PAM04 MEMX=MAXMEM -* PAM06: Evidently some miscounting margin needed: - MEMX=INT(0.90D0*DBLE(MEMWRK)) -C ALLOCATION FOR SORTA. - NCHN1=LN*NVIRT+1 - IF(IFIRST.NE.0)NCHN1=1 - NBSIZ1=MEMX/NCHN1 - 1 - NBUFBI=KBUFF1 - NBSIZ1=MIN(NBSIZ1,MEMX-2*ISMAX-NBUFBI-1) - NBSIZ1=MAX(NBSIZ1,256) -CPAM96 NBSIZ1=Size counted in real*8 words. -CPAM96 Must contain NBITM1 real*8 + NBITM1 integ + 2 integ: -CPAM96 NBITM1=2*((NBSIZ1-1)/3) - NBITM1=(RTOI*NBSIZ1-2)/(RTOI+1) - NBITM1=MIN(NBITM1,NVSQ) - NBITM1=((NBITM1+2)/RTOI)*RTOI-2 -CPAM96 NBSIZ1=(3*NBITM1+2)/2 - NBSIZ1=((RTOI+1)*NBITM1+2+(RTOI-1))/RTOI -C SORTING AREA, BUFOUT AND INDOUT -*PAM04 LBIN1=LPERMX -*PAM04 NBIN1=NBSIZ1*NCHN1 -C BIAC -C NOTE: ONE SINGLE BIN IS IN USE TOGETHER WITH BIAC,BICA,BUFBI. -*PAM04 LBIAC1=LBIN1+NBSIZ1 -*PAM04 LBIAC1=LPERMX -*PAM04C BICA -*PAM04 LBICA1=LBIAC1+ISMAX -*PAM04C BUFBI -*PAM04 LBUFBI=LBICA1+ISMAX -*PAM04*PAM04 LTOP1=MAX(LBUFBI+NBUFBI,LBIN1+NBIN1)-1 -*PAM04 LTOP1=LBUFBI+NBUFBI-1 -*PAM04 LTOP=LTOP1 - LTOP=LPERMX -C DYNAMIC ALLOCATION FOR SORTING ABCD - NBITM2=1 -*PAM04 LTOP2=0 - IF(IFIRST.EQ.0) THEN - IPASS=0 -110 IPASS=IPASS+1 - NCHN2=(NVT-1)/IPASS+1 - NBSIZ2=(MEMX-2*ISMAX-KBUFF1)/NCHN2 -CPAM96 IF(2*NBSIZ2.GT.(3*NVSQ+2)) GOTO 120 - IF(RTOI*NBSIZ2.GT.((RTOI+1)*NVSQ+2)) GOTO 120 - IF(IPASS.EQ.5) GOTO 120 - IF(NBSIZ2.LT.1024) GOTO 110 -120 CONTINUE -CPAM96 NBITM2=2*((NBSIZ2-1)/3) - NBITM2=(RTOI*NBSIZ2-2)/(RTOI+1) - NBITM2=MIN(NBITM2,NVSQ) - NBITM2=((NBITM2+2)/RTOI)*RTOI-2 -CPAM96 NBSIZ2=(3*NBITM2+2)/2 - NBSIZ2=((RTOI+1)*NBITM2+2+(RTOI-1))/RTOI -C SORTING BINS, BUFOUT AND INDOUT -*PAM04 LBIN2=LPERMX -*PAM04 NBIN2=NBSIZ2*NCHN2 -C BFACBD, ACBDS, AND ACBDT: -*PAM04 LBACBD=LBIN2+NBIN2 -*PAM04 LACBDS=LBACBD+KBUFF1 -*PAM04 LACBDT=LACBDS+ISMAX -*PAM04 LTOP2=LACBDT+ISMAX-1 -*PAM04 LTOP=MAX(LTOP,LTOP2) - END IF -C DYNAMIC ALLOCATION FOR SORTING AIBJ, AND CREATING HDIAG: - NOT2=IROW(LN+1) - NCHN3=3*NOT2 -*PAM04 LHDIAG=LPERMX -*PAM04 NHDIAG=MAX(NVT,IRC(1)) -*PAM04 LIIJJ=LHDIAG+NHDIAG -*PAM04 LIJIJ=LIIJJ+NBTRI -*PAM04 NBSIZ3=(MAXMEM-LPERMX)/NCHN3 - NBSIZ3=(MEMWRK-LPERMX)/NCHN3 - NBSIZ3=MAX(NBSIZ3,256) -CPAM96 NBITM3=2*((NBSIZ3-1)/3) - NBITM3=(RTOI*NBSIZ3-2)/(RTOI+1) - NBITM3=MIN(NBITM3,NVSQ) - NBITM3=((NBITM3+2)/RTOI)*RTOI-2 -CPAM96 NBSIZ3=(3*NBITM3+2)/2 - NBSIZ3=((RTOI+1)*NBITM3+2+(RTOI-1))/RTOI -*PAM04 NBIN3=NBSIZ3*NCHN3 -*PAM04 LTOP3=LBIN3+NBIN3 -*PAM04 LTOP=MAX(LTOP,LTOP3) -C VECTORS PERMANENTLY IN CORE DURING CI ITERATIONS. -C LFOCK ALREADY ALLOCATED AT LPERMA. ALSO ALLOCATE DMO AND TDMO -C THERE, OVERLAYED, FOR FUTURE USE. -*PAM04 ALLOCATING DMO AND TDMO HAS BEEN MOVED TO SDCI. -* LDMO=LPERMA -* LTDMO=LPERMA -C AREF, EREF: EIGENVECTORS AND ENERGIES OF REFERENCE CI. -*PAM04 NOW AREF CAN START DIRECTLY AT LPERMA -* LAREF=LPERMA+NBTRI -* IF(ITRANS.EQ.1) LAREF=LPERMA+NBAST**2 -*PAM04 LAREF=LPERMA -*PAM04 LEREF=LAREF+NREF**2 -*PAM04 LPERMB=LEREF+NREF -C CALCULATE HOW MUCH SCRATCH WILL BE NEEDED FOR PERS PART: -C FIRST, SET ASIDE WHATS NEEDED FOR SIGMA GENERATION: - NIJ=(LN*(LN+1))/2 - NIJKL=NIJ*(NIJ+1)/2 - NBMN=IAD10(1) - IF(IFIRST.NE.0)NBMN=0 - NPER=5*NVSQ+NBSIZ3+2*NVMAX**2 -CPAM97 NPER=MAX(NPER,NIJKL+1+KBUFF1/2) - NPER=MAX(NPER,NIJKL) - NPER=MAX(NPER,2*NBMN+2*ISMAX+KBUFF1) - NPER=MAX(NPER,NBSIZ3+2*NVMAX**2+2*NVSQ) -C OVERLAY CI,((HREF,PLEN) & (SGM,PERS PART)) - NHREF=(NREF*(NREF+1))/2 - NPLEN=NREF - NOVLY1=JSC(ILIM)+MAX(JSC(ILIM)+NPER,NHREF+NPLEN) -C THIS IS TO BE OVERLAYED WITH (CBUF,...,LSCR) IN MQCT. TWO ALT: - NARR=11*NRROOT**2 -*PAM04 MEMB=MAXMEM-LPERMB+1 - MEMB=MEMWRK-LPERMB+1 - MBUF1=MEMB-NOVLY1-NARR - MBUF2=(MEMB-NARR-(3*NRROOT+2*MXVEC)*NSECT)/(3*MXVEC+2) - MBUF=MIN(MBUF1,MBUF2,20249) - MBUF=MAX(MBUF,1259) -C ICI, ONE BUFFER OF PACKED CI COEFFICIENTS: -*PAM04 LICI=LPERMB -C CI ARRAY: -*PAM04 LCI=LICI+MBUF -C SGM ARRAY: -*PAM04 LSGM=LCI+JSC(ILIM) -*PAM04 LPER=LSGM+JSC(ILIM) -* LPER=LPERMB+JSC(ILIM) -*PAM04 LARR=LPER+NPER -C OVERLAY: -*PAM04 LHREF=LSGM -*PAM04 LPLEN=LHREF+NHREF -*PAM04 LARR=MAX(LARR,LPLEN+NPLEN) -C OVERLAY: -*PAM04 LMQ=LCI -*PAM04 LMQ=LPERMB -*PAM04 NMQ=(3*NRROOT+2*MXVEC)*NSECT+(3*MXVEC+1)*MBUF -*PAM04 LARR=MAX(LARR,LMQ+NMQ) -*PAM04 ltop4=larr+narr-1 -*PAM04 ltop=max(ltop,ltop4) -C MORE DETAILED, PERS PART, FROM HERE ------------------------------- -C DYNAMIC ALLOCATION FOR FAIBJ: -C MATRIX ABIJ -*PAM04 LABIJ=LPER -C MATRIX AIBJ -*PAM04 LAIBJ=LABIJ+NVSQ -C MATRIX AJBI -*PAM04 LAJBI=LAIBJ+NVSQ -C BUFIN, IBUFIN -*PAM04 LBFIN1=LAJBI+NVSQ -C A, SCRATCH AREA -*PAM04 LASCR1=LBFIN1+NBSIZ3 -C B, SCRATCH AREA -*PAM04 LBSCR1=LASCR1+NVMAX**2 -C F, SCRATCH AREA -*PAM04 LFSCR1=LBSCR1+NVMAX**2 -C FSEC, SCRATCH AREA -*PAM04 LFSEC=LFSCR1+NVSQ -*PAM04 LTOP5=LFSEC+NVSQ-1 -*PAM04 LTOP=MAX(LTOP,LTOP5) -C DYNAMIC ALLOCATION FOR IJKL -C FIJKL -CPAM04 LFIJKL=LPER -CPAM97C BUFIN, IBUFIN -CPAM97 LBFIN2=LFIJKL+NIJKL -CPAM97 NBFIN2=1+KBUFF1/2 -CPAM97 LTOP6=LBFIN2+NBFIN2-1 -CPAM97 LTOP=MAX(LTOP,LTOP6) -C DYNAMIC ALLOCATION FOR ABCI -C BMN -*PAM04 LBMN=LPER -C IBMN -*PAM04 LIBMN=LBMN+NBMN -C BIAC -*PAM04 LBIAC2=LIBMN+NBMN -C BICA -*PAM04 LBICA2=LBIAC2+ISMAX -C BUFIN -*PAM04 LBFIN3=LBICA2+ISMAX -*PAM04 NBFIN3=KBUFF1 -*PAM04 LTOP7=LBFIN3+NBFIN3-1 -*PAM04 LTOP=MAX(LTOP,LTOP7) -C DYNAMIC ALLOCATION FOR ABCD -C ACBDS -*PAM04 LAC1=LPER -C ACBDT -*PAM04 LAC2=LAC1+ISMAX -C BUFIN -*PAM04 LBFIN4=LAC2+ISMAX -*PAM04 NBFIN4=KBUFF1 -*PAM04 LTOP8=LBFIN4+NBFIN4-1 -*PAM04 LTOP=MAX(LTOP,LTOP8) -C DYNAMIC ALLOCATION FOR FIJ, AI AND AB -C BUFIN, IBUFIN -*PAM04 LBFIN5=LPER -C A, SCRATCH AREA -*PAM04 LASCR2=LBFIN5+NBSIZ3 -C B, SCRATCH AREA -*PAM04 LBSCR2=LASCR2+NVMAX**2 -C FK IN AI AND AB -*PAM04 LFSCR2=LBSCR2+NVMAX**2 -C DBK -*PAM04 LDBK=LFSCR2+NVSQ -*PAM04 LTOP9=LDBK+NVSQ-1 -*PAM04 LTOP=MAX(LTOP,LTOP9) -C ALLOCATION OF PERS PART ENDS HERE ------------------------------ -C DYNAMIC ALLOCATION FOR NATURAL ORBITALS ETC. -*PAM04 NPRP=2*NCMO+NBAST+NBAST**2+3*NBTRI+MAX(NBTRI,NBMAX**2) -*PAM04 LPRP=LPERMB -*PAM04 LTOP10=LPRP+NPRP-1 -*PAM04 LTOP=MAX(LTOP,LTOP10) -*PAM04 WRITE(6,*) -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' REQUIRED WORKSPACE SIZE:',LTOP -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' AVAILABLE:',MAXMEM -*PAM04 CALL XFLUSH(6) -*PAM04 IF((LTOP.LE.MAXMEM).AND.(IPRINT.LT.5)) RETURN -*PAM04 WRITE(6,*) -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,*)' DYNAMIC ALLOCATION INFORMATION:' -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,*) -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' CSPCK:',LCSPCK -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' INTSYM:',LINTSY -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' INDX:',LINDX -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' ISAB:',LISAB -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' JREFX:',LJREFX -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' CISEL:',LCISEL -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,*) -*PAM04 CALL XFLUSH(6) -CPAM97 WRITE(6,'(A,I9)')' TIBUF:',LTIBUF -CPAM97 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' FOCK:',LFOCK -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' BIN1:',LBIN1 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' NBSIZ1:',NBSIZ1 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' NCHN1:',NCHN1 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' BIAC1:',LBIAC1 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' BICA1:',LBICA1 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' BUFBI:',LBUFBI -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' LTOP1:',LTOP1 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,*) -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' BIN2:',LBIN2 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' NBSIZ2:',NBSIZ2 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' NCHN2:',NCHN2 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' BFACBD:',LBACBD -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' ACBDS:',LACBDS -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' ACBDT:',LACBDT -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' LTOP2:',LTOP2 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,*) -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' HDIAG:',LHDIAG -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' FIIJJ:',LIIJJ -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' FIJIJ:',LIJIJ -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' BIN3:',LBIN3 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' NBSIZ3:',NBSIZ3 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' NCHN3:',NCHN3 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' LTOP3:',LTOP3 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,*) -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' AREF:',LAREF -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' EREF:',LEREF -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' HREF:',LHREF -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' PLEN:',LPLEN -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' ICI:',LICI -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' CI:',LCI -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' SGM:',LSGM -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' LMQ:',LMQ -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' ARR:',LARR -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' LTOP4:',LTOP4 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,*) -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' ABIJ:',LABIJ -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' AIBJ:',LAIBJ -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' AJBI:',LAJBI -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' BUFIN1:',LBFIN1 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' ASCR1:',LASCR1 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' BSCR1:',LBSCR1 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' FSCR1:',LFSCR1 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' FSEC:',LFSEC -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' LTOP5:',LTOP5 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,*) -*PAM04 CALL XFLUSH(6) -CPAM04 WRITE(6,'(A,I9)')' FIJKL:',LFIJKL -CPAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,*) -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' BMN:',LBMN -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' IBMN:',LIBMN -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' BIAC2:',LBIAC2 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' BICA2:',LBICA2 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' BUFIN3:',LBFIN3 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' LTOP7:',LTOP7 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,*) -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' ACBDS2:',LAC1 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' ACBDT2:',LAC2 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' BUFIN4:',LBFIN4 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' LTOP8:',LTOP8 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,*) -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' BUFIN5:',LBFIN5 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' ASCR2:',LASCR2 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' BSCR2:',LBSCR2 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' FSCR2:',LFSCR2 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' DBK:',LDBK -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' LTOP9:',LTOP9 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,*) -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' DMO:',LDMO -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' TDMO:',LTDMO -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' PRP:',LPRP -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' ltop10:',LTOP10 -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,*) -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,'(A,I9)')' LTOP',LTOP -*PAM04 CALL XFLUSH(6) -*PAM04 WRITE(6,*) -*PAM04 CALL XFLUSH(6) -*PAM04 IF(LTOP.LE.MAXMEM) RETURN - IF(LTOP.LE.MEMWRK) RETURN - WRITE(6,*)'ALLOC Error: Too much workspace is needed.' - WRITE(6,'(1X,A,2I10)')' Needed LTOP=',LTOP - WRITE(6,'(1X,A,2I10)')' Available MEMWRK=',MEMWRK - CALL QUIT(_RC_GENERAL_ERROR_) - END diff -Nru openmolcas-22.02/src/mrci/alloc_mrci.F90 openmolcas-22.10/src/mrci/alloc_mrci.F90 --- openmolcas-22.02/src/mrci/alloc_mrci.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/alloc_mrci.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,105 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ALLOC_MRCI() + +use mrci_global, only: IFIRST, IPASS, IROW, ISMAX, JSC, KBUFF1, LN, MBUF, MEMWRK, MXVEC, NBITM1, NBITM2, NBITM3, NBMN, NCHN1, & + NCHN2, NCHN3, NREF, NRROOT, NSECT, NSYM, NVIR, NVIRT, NVMAX, NVSQ +use guga_util_global, only: IAD10 +use Definitions, only: wp, iwp, RtoI + +implicit none +#include "warnings.h" +integer(kind=iwp) :: I, ILIM, MBUF1, MBUF2, MEMB, MEMX, NARR, NBSIZ1, NBSIZ2, NBSIZ3, NBUFBI, NHREF, NIJ, NIJKL, NOT2, NOVLY1, & + NPER, NPLEN, NVT + +ILIM = 4 +if (IFIRST /= 0) ILIM = 2 +NVSQ = 0 +NVMAX = 0 +do I=1,NSYM + NVMAX = max(NVMAX,NVIR(I)) + NVSQ = NVSQ+NVIR(I)**2 +end do +NVT = (NVIRT*(NVIRT+1))/2 +if (NVIRT == 0) then + call SysAbendMsg('alloc_mrci.f:','no virtual orbitals in the basis',' ') +end if +!PAM04 MOVE ALLOCATION OF FOCK MATRIX TO SDCI. +! FOCK MATRIX IN SORT,IIJJ,IJIJ,FIJ,AI. +!----------------------------------------------- +!PAM97 ! BUFFER FOR MOTRA INTEGRALS, TIBUF, IN SORT, SORTA, SORTB. +!PAM06: Evidently some miscounting margin needed: +MEMX = int(0.9_wp*real(MEMWRK,kind=wp)) +! ALLOCATION FOR SORTA. +NCHN1 = LN*NVIRT+1 +if (IFIRST /= 0) NCHN1 = 1 +NBSIZ1 = MEMX/NCHN1-1 +NBUFBI = KBUFF1 +NBSIZ1 = min(NBSIZ1,MEMX-2*ISMAX-NBUFBI-1) +NBSIZ1 = max(NBSIZ1,256) +!PAM96 NBSIZ1=Size counted in real*8 words. +!PAM96 Must contain NBITM1 real*8 + NBITM1 integ + 2 integ: +NBITM1 = (RTOI*NBSIZ1-2)/(RTOI+1) +NBITM1 = min(NBITM1,NVSQ) +NBITM1 = ((NBITM1+2)/RTOI)*RTOI-2 +NBSIZ1 = ((RTOI+1)*NBITM1+2+(RTOI-1))/RTOI +! BIAC +! DYNAMIC ALLOCATION FOR SORTING ABCD +NBITM2 = 1 +if (IFIRST == 0) then + IPASS = 0 + do + IPASS = IPASS+1 + NCHN2 = (NVT-1)/IPASS+1 + NBSIZ2 = (MEMX-2*ISMAX-KBUFF1)/NCHN2 + if (RTOI*NBSIZ2 > ((RTOI+1)*NVSQ+2)) exit + if (IPASS == 5) exit + if (NBSIZ2 >= 1024) exit + end do + NBITM2 = (RTOI*NBSIZ2-2)/(RTOI+1) + NBITM2 = min(NBITM2,NVSQ) + NBITM2 = ((NBITM2+2)/RTOI)*RTOI-2 + NBSIZ2 = ((RTOI+1)*NBITM2+2+(RTOI-1))/RTOI +end if +! DYNAMIC ALLOCATION FOR SORTING AIBJ, AND CREATING HDIAG: +NOT2 = IROW(LN+1) +NCHN3 = 3*NOT2 +NBSIZ3 = (MEMWRK-1)/NCHN3 +NBSIZ3 = max(NBSIZ3,256) +NBITM3 = (RTOI*NBSIZ3-2)/(RTOI+1) +NBITM3 = min(NBITM3,NVSQ) +NBITM3 = ((NBITM3+2)/RTOI)*RTOI-2 +NBSIZ3 = ((RTOI+1)*NBITM3+2+(RTOI-1))/RTOI +! CALCULATE HOW MUCH SCRATCH WILL BE NEEDED FOR PERS PART: +! FIRST, SET ASIDE WHATS NEEDED FOR SIGMA GENERATION: +NIJ = (LN*(LN+1))/2 +NIJKL = NIJ*(NIJ+1)/2 +NBMN = IAD10(1) +if (IFIRST /= 0) NBMN = 0 +NPER = 5*NVSQ+NBSIZ3+2*NVMAX**2 +NPER = max(NPER,NIJKL) +NPER = max(NPER,2*NBMN+2*ISMAX+KBUFF1) +NPER = max(NPER,NBSIZ3+2*NVMAX**2+2*NVSQ) +! OVERLAY CI,((HREF,PLEN) & (SGM,PERS PART)) +NHREF = (NREF*(NREF+1))/2 +NPLEN = NREF +NOVLY1 = JSC(ILIM)+max(JSC(ILIM)+NPER,NHREF+NPLEN) +! THIS IS TO BE OVERLAYED WITH (CBUF,...,LSCR) IN MQCT. TWO ALT: +NARR = 11*NRROOT**2 +MEMB = MEMWRK +MBUF1 = MEMB-NOVLY1-NARR +MBUF2 = (MEMB-NARR-(3*NRROOT+2*MXVEC)*NSECT)/(3*MXVEC+2) +MBUF = min(MBUF1,MBUF2,20249) +MBUF = max(MBUF,1259) +! ALLOCATION OF PERS PART ENDS HERE ------------------------------ + +end subroutine ALLOC_MRCI diff -Nru openmolcas-22.02/src/mrci/ci_select_mrci.F90 openmolcas-22.10/src/mrci/ci_select_mrci.F90 --- openmolcas-22.02/src/mrci/ci_select_mrci.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/ci_select_mrci.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,64 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine CI_SELECT_MRCI(NREF,AREF,PLEN,NSEL,CISEL,NRROOT,IROOT) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: NREF, NSEL, NRROOT +real(kind=wp), intent(in) :: AREF(NREF,NREF), CISEL(NREF,*) +real(kind=wp), intent(out) :: PLEN(NREF) +integer(kind=iwp), intent(out) :: IROOT(NRROOT) +integer(kind=iwp) :: I, IR, ISEL, J, JJ, JMAX +real(kind=wp) :: PL, PMAX, SUM1, SUM2 + +if (NSEL == 0) return +! SELECTION BY PROJECTION ONTO SPACE SPANNED BY CISEL VECTORS. IROOT() +! IS SET TO SELECT THE NRROOT VECTORS WITH MAX PROJECTED LENGTH. +do J=1,NREF + SUM1 = Zero + do ISEL=1,NSEL + SUM2 = Zero + do I=1,NREF + SUM2 = SUM2+AREF(I,J)*CISEL(I,ISEL) + end do + SUM1 = SUM1+SUM2**2 + end do + PLEN(J) = SUM1+J*1.0e-12_wp +end do +! SELECT BY MAGNITUDE OF PLEN: +do J=1,NRROOT + PMAX = PLEN(1) + JMAX = 1 + do JJ=2,NREF + if (PMAX < PLEN(JJ)) then + PMAX = PLEN(JJ) + JMAX = JJ + end if + end do + PLEN(JMAX) = -PMAX +end do +I = 0 +do IR=1,NREF + PL = PLEN(IR) + if (PL < Zero) then + I = I+1 + IROOT(I) = IR + PL = -PL + end if + PLEN(IR) = PL-IR*1.0e-12_wp +end do + +return + +end subroutine CI_SELECT_MRCI diff -Nru openmolcas-22.02/src/mrci/CMakeLists.txt openmolcas-22.10/src/mrci/CMakeLists.txt --- openmolcas-22.02/src/mrci/CMakeLists.txt 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -9,4 +9,65 @@ # LICENSE or in . * #*********************************************************************** +set (sources + main.F90 + abcd.F90 + abci.F90 + abd.F90 + ab.F90 + abtd.F90 + aid.F90 + ai_mrci.F90 + aitd.F90 + alloc_mrci.F90 + ci_select_mrci.F90 + count_mrci.F90 + cscale.F90 + csftra.F90 + cstart.F90 + dcorr.F90 + densct.F90 + diagc.F90 + diagct.F90 + faibj2.F90 + faibj3.F90 + faibj5.F90 + faibj.F90 + fijd.F90 + fij.F90 + fijtd.F90 + hz.F90 + hzlp1.F90 + hzlp2.F90 + iijj.F90 + ijij.F90 + ijkl.F90 + indmat.F90 + ipo.F90 + loop70.F90 + mkdao.F90 + mkhref.F90 + mktdao.F90 + mqct.F90 + mrci.F90 + mrci_global.F90 + natorb_mrci.F90 + pkvec.F90 + pmatel.F90 + propct.F90 + prorb.F90 + prwf_mrci.F90 + readin_mrci.F90 + refci.F90 + sdci_mrci.F90 + seceq.F90 + secne.F90 + secular.F90 + sigma.F90 + sorta.F90 + sortb.F90 + sort_mrci.F90 + upkvec.F90 +) + include (${PROJECT_SOURCE_DIR}/cmake/prog_template.cmake) diff -Nru openmolcas-22.02/src/mrci/count.f openmolcas-22.10/src/mrci/count.f --- openmolcas-22.02/src/mrci/count.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/count.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE COUNT(NINTGR,NSYM,NORB,MUL) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION NORB(*),MUL(8,8) - DIMENSION NDPROD(8) -C COUNT TWO-ELECTRON INTEGRALS -C FIRST, COUNT NUMBER OF DENSITY PRODUCTS IN EACH SYMMETRY: - NDPROD(1)=0 - NORBT=0 - DO 10 IS=1,NSYM - NDPROD(IS)=0 - NORBT=NORBT+NORB(IS) -10 CONTINUE - DO 30 IJS=1,NSYM - ISUM=0 - DO 20 IS=1,NSYM - JS=MUL(IS,IJS) - IF(JS.GT.IS) GOTO 20 - ISUM=ISUM+NORB(IS)*NORB(JS) -20 CONTINUE - NDPROD(IJS)=ISUM -30 CONTINUE - NDPROD(1)=(NDPROD(1)+NORBT)/2 -C THEN COUNT NUMBER OF TOTALLY SYMMETRIC PRODUCTS OF DENS-PRODUCTS: - NINTGR=0 - DO 40 IJS=1,NSYM - NINTGR=NINTGR+NDPROD(IJS)*(1+NDPROD(IJS)) -40 CONTINUE - NINTGR=NINTGR/2 - RETURN - END diff -Nru openmolcas-22.02/src/mrci/count_mrci.F90 openmolcas-22.10/src/mrci/count_mrci.F90 --- openmolcas-22.02/src/mrci/count_mrci.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/count_mrci.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,47 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine COUNT_MRCI(NINTGR,NSYM,NORB,MUL) + +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(out) :: NINTGR +integer(kind=iwp), intent(in) :: NSYM, NORB(*), MUL(8,8) +integer(kind=iwp) :: IJS, IS, ISUM, JS, NDPROD(8), NORBT + +! COUNT TWO-ELECTRON INTEGRALS +! FIRST, COUNT NUMBER OF DENSITY PRODUCTS IN EACH SYMMETRY: +NDPROD(1) = 0 +NORBT = 0 +do IS=1,NSYM + NDPROD(IS) = 0 + NORBT = NORBT+NORB(IS) +end do +do IJS=1,NSYM + ISUM = 0 + do IS=1,NSYM + JS = MUL(IS,IJS) + if (JS <= IS) ISUM = ISUM+NORB(IS)*NORB(JS) + end do + NDPROD(IJS) = ISUM +end do +NDPROD(1) = (NDPROD(1)+NORBT)/2 +! THEN COUNT NUMBER OF TOTALLY SYMMETRIC PRODUCTS OF DENS-PRODUCTS: +NINTGR = 0 +do IJS=1,NSYM + NINTGR = NINTGR+NDPROD(IJS)*(1+NDPROD(IJS)) +end do +NINTGR = NINTGR/2 + +return + +end subroutine COUNT_MRCI diff -Nru openmolcas-22.02/src/mrci/cscale.f openmolcas-22.10/src/mrci/cscale.f --- openmolcas-22.02/src/mrci/cscale.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/cscale.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,41 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE CSCALE(INDX,INTSYM,C,X) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION C(*),INDX(*),INTSYM(*) - -#include "SysDef.fh" - -#include "mrci.fh" -CPAM97 EXTERNAL UNPACK -CPAM97 INTEGER UNPACK -CPAM96 JSYM(L)=UNPACK(INTSYM((L+9)/10),3*MOD(L-1,10)+1,3)+1 -c JSYM(L)=JSUNP(INTSYM,L) - -c DO 10 II1=IRC(3)+1,IRC(4) - II1=IRC(3)+1 -30 if(II1.gt.IRC(4)) goto 10 -c IF(JSYM(II1).NE.LSYM) GOTO 40 - IF(JSUNP(INTSYM,II1).NE.LSYM) GOTO 40 - NA=INDX(II1) - MA=1 - if(NVIRT.lt.1) goto 620 -c DO 20 MA=1,NVIRT -720 C(NA+NDIAG(MA))=X*C(NA+NDIAG(MA)) -c20 CONTINUE - MA=MA+1 - if(MA.le.NVIRT) goto 720 -620 continue -40 II1=II1+1 - GOTO 30 -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/cscale.F90 openmolcas-22.10/src/mrci/cscale.F90 --- openmolcas-22.02/src/mrci/cscale.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/cscale.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,35 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine CSCALE(INDX,INTSYM,C,X) + +use mrci_global, only: IRC, LSYM, NDIAG, NVIRT +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: INDX(*), INTSYM(*) +real(kind=wp), intent(inout) :: C(*) +real(kind=wp), intent(in) :: X +integer(kind=iwp) :: II1, MA, NA +integer(kind=iwp), external :: JSUNP + +do II1=IRC(3)+1,IRC(4) + if (JSUNP(INTSYM,II1) == LSYM) then + NA = INDX(II1) + do MA=1,NVIRT + C(NA+NDIAG(MA)) = X*C(NA+NDIAG(MA)) + end do + end if +end do + +return + +end subroutine CSCALE diff -Nru openmolcas-22.02/src/mrci/csftra.f openmolcas-22.10/src/mrci/csftra.f --- openmolcas-22.02/src/mrci/csftra.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/csftra.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE CSFTRA(KEY,CI,AREF) - IMPLICIT REAL*8 (A-H,O-Z) - CHARACTER*4 KEY - DIMENSION CI(NCONF),AREF(NREF,NREF) - -#include "SysDef.fh" - -#include "mrci.fh" - DIMENSION TMP(MXREF) - IF(NREF.EQ.1) RETURN - IF(KEY.EQ.' CSF') THEN - DO 20 I=1,NREF - SUM=0.0D00 - DO 10 J=1,NREF - SUM=SUM+AREF(I,J)*CI(IREFX(J)) -10 CONTINUE - TMP(I)=SUM -20 CONTINUE - ELSE - DO 50 I=1,NREF - SUM=0.0D00 - DO 40 J=1,NREF - SUM=SUM+AREF(J,I)*CI(IREFX(J)) -40 CONTINUE - TMP(I)=SUM -50 CONTINUE - END IF - DO 60 I=1,NREF - CI(IREFX(I))=TMP(I) -60 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/csftra.F90 openmolcas-22.10/src/mrci/csftra.F90 --- openmolcas-22.02/src/mrci/csftra.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/csftra.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,53 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine CSFTRA(KEY,CI,AREF) + +use mrci_global, only: IREFX, NCONF, NREF +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +character(len=4), intent(in) :: KEY +real(kind=wp), intent(inout) :: CI(NCONF) +real(kind=wp), intent(in) :: AREF(NREF,NREF) +integer(kind=iwp) :: I, J +real(kind=wp) :: RSUM +real(kind=wp), allocatable :: TMP(:) + +if (NREF == 1) return +call mma_allocate(TMP,NREF,label='NREF') +if (KEY == ' CSF') then + do I=1,NREF + RSUM = Zero + do J=1,NREF + RSUM = RSUM+AREF(I,J)*CI(IREFX(J)) + end do + TMP(I) = RSUM + end do +else + do I=1,NREF + RSUM = Zero + do J=1,NREF + RSUM = RSUM+AREF(J,I)*CI(IREFX(J)) + end do + TMP(I) = RSUM + end do +end if +do I=1,NREF + CI(IREFX(I)) = TMP(I) +end do +call mma_deallocate(TMP) + +return + +end subroutine CSFTRA diff -Nru openmolcas-22.02/src/mrci/cstart.f openmolcas-22.10/src/mrci/cstart.f --- openmolcas-22.02/src/mrci/cstart.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/cstart.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,120 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE CSTART(AREF,EREF,CI,ICI) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION AREF(NREF,NREF),EREF(NREF),CI(NCONF),ICI(MBUF) -#include "SysDef.fh" -#include "mrci.fh" - DIMENSION BUF(nCOP),ISTART(MXROOT) -* - DO 5 I=1,MXVEC - IDISKC(I)=-1 - IDISKS(I)=-1 -5 CONTINUE -C FIRST, USE THE CI ARRAY TO STORE THE DIAGONAL ELEMENTS: - IAD25=IAD25S - DO 10 I=1,NCONF,nCOP - CALL dDAFILE(Lu_25,2,BUF,nCOP,IAD25) - NN=MIN(nCOP,NCONF+1-I) - CALL DCOPY_(NN,BUF,1,CI(I),1) -10 CONTINUE -C THESE ARE DIAGONAL ELEMENTS OF THE ELECTRONIC HAMILTONIAN. -C POTNUC SHOULD BE ADDED. IN ADDITION, WE USE AN ENERGY SHIFT. -C NOTE: DISPLACEMENT 1.0d-4 PROTECTS AGAINST DIVIDE ERRORS. -CPAM: Protect all diag elems. Needed in some weird cases. -C ENERGY SHIFT: - ESHIFT=EREF(1) - DO 25 I=1,NCONF - CI(I)=CI(I)+POTNUC-ESHIFT+1.0D-04 -25 CONTINUE - Call Add_Info('CI_DIAG2',CI(2),1,8) -C REPLACE REFERENCE ENERGIES: - DO 20 I=1,NREF - IR=IREFX(I) - CI(IR)=EREF(I)-ESHIFT-1.0D-04 -20 CONTINUE - IF(ICPF.EQ.1) THEN - DO 30 IREF=1,NREF - IR=IREFX(IREF) - CI(IR)=GFAC*CI(IR) -30 CONTINUE - GINV=1.0D00/GFAC - CALL DSCAL_(NCONF,GINV,CI,1) - END IF - IDFREE=0 - IDISKD=0 - DO 31 ISTA=1,NCONF,MBUF - NN=MIN(MBUF,(NCONF+1-ISTA)) - CALL dDAFILE(LUEIG,1,CI(ISTA),NN,IDFREE) -31 CONTINUE -C THEN, SET UP START CI VECTORS IN MCSF BASIS: - CALL DCOPY_(NCONF,[0.0D00],0,CI,1) - IF(IREST.EQ.0) THEN - NNEW=IROOT(NRROOT) - I1=1 - I2=1 - DO 35 I=1,NNEW - IF(I.EQ.IROOT(I1)) THEN - ISTART(NNEW-NRROOT+I1)=I - I1=I1+1 - ELSE - ISTART(I2)=I - I2=I2+1 - END IF -35 CONTINUE - IF(NNEW.GT.1) THEN - WRITE(6,*) - * ' THE FOLLOWING REFERENCE ROOTS ARE USED AS START VECTORS:' - CALL XFLUSH(6) - WRITE(6,'(12(A,I2))') ' ROOTS NR ',ISTART(1), - * (',',ISTART(I),I=2,NNEW-1), - * ', AND ',ISTART(NNEW) - CALL XFLUSH(6) - IF(NNEW.GT.NRROOT) THEN - WRITE(6,*)' (THE FIRST EXTRA ROOT(S) WERE INCLUDED IN'// - * 'ORDER TO IMPROVE CONVERGENCE)' - CALL XFLUSH(6) - END IF - ELSE - WRITE(6,'(A,I2,A)') ' ROOT NR ',ISTART(1), - * ' IS USED AS START VECTOR.' - CALL XFLUSH(6) - END IF - DO 40 I=1,NNEW - ISTA=ISTART(I) - IR=IREFX(ISTA) - CI(IR)=1.0D00 - IDISKC(I)=IDFREE - DO 41 ISTA=1,NCONF,MBUF - NN=MIN(MBUF,(NCONF+1-ISTA)) - CALL PKVEC(NN,CI(ISTA),ICI) - CALL iDAFILE(LUEIG,1,ICI,NN,IDFREE) -41 CONTINUE - CI(IR)=0.0D00 -40 CONTINUE - ELSE - ID=0 - NNEW=NRROOT - DO 50 I=1,NRROOT - CALL dDAFILE(LUREST,2,CI,NCONF,ID) - CALL CSFTRA('MCSF',CI,AREF) - IDISKC(I)=IDFREE - DO 51 ISTA=1,NCONF,MBUF - NN=MIN(MBUF,(NCONF+1-ISTA)) - CALL PKVEC(NN,CI(ISTA),ICI) - CALL iDAFILE(LUEIG,1,ICI,NN,IDFREE) -51 CONTINUE -50 CONTINUE - END IF - NVTOT=NNEW - NSTOT=0 - RETURN - END diff -Nru openmolcas-22.02/src/mrci/cstart.F90 openmolcas-22.10/src/mrci/cstart.F90 --- openmolcas-22.02/src/mrci/cstart.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/cstart.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,130 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine CSTART(AREF,EREF,CI,ICI) + +use mrci_global, only: ESHIFT, GFAC, IAD25S, ICPF, IDFREE, IDISKC, IDISKD, IDISKS, IREFX, IREST, IROOT, Lu_25, LUEIG, LUREST, & + MBUF, MXVEC, NCONF, NNEW, NREF, NRROOT, NSTOT, NVTOT, POTNUC +use guga_util_global, only: nCOP +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +real(kind=wp), intent(in) :: AREF(NREF,NREF), EREF(NREF) +real(kind=wp), intent(out) :: CI(NCONF) +integer(kind=iwp), intent(out) :: ICI(MBUF) +#include "Molcas.fh" +integer(kind=iwp) :: I, I1, I2, IAD25, ID, IR, IREF, ISTA, NN +real(kind=wp) :: GINV +integer(kind=iwp), allocatable :: ISTART(:) +real(kind=wp), allocatable :: Buf(:) + +do I=1,MXVEC + IDISKC(I) = -1 + IDISKS(I) = -1 +end do +! FIRST, USE THE CI ARRAY TO STORE THE DIAGONAL ELEMENTS: +call mma_allocate(Buf,nCOP,label='Buf') +IAD25 = IAD25S +do I=1,NCONF,nCOP + call dDAFILE(Lu_25,2,Buf,nCOP,IAD25) + NN = min(nCOP,NCONF+1-I) + CI(I:I+NN-1) = Buf(1:NN) +end do +call mma_deallocate(Buf) +! THESE ARE DIAGONAL ELEMENTS OF THE ELECTRONIC HAMILTONIAN. +! POTNUC SHOULD BE ADDED. IN ADDITION, WE USE AN ENERGY SHIFT. +! NOTE: DISPLACEMENT 1.0e-4 PROTECTS AGAINST DIVIDE ERRORS. +!PAM: Protect all diag elems. Needed in some weird cases. +! ENERGY SHIFT: +ESHIFT = EREF(1) +do I=1,NCONF + CI(I) = CI(I)+POTNUC-ESHIFT+1.0e-4_wp +end do +call Add_Info('CI_DIAG2',CI(2),1,8) +! REPLACE REFERENCE ENERGIES: +do I=1,NREF + IR = IREFX(I) + CI(IR) = EREF(I)-ESHIFT-1.0e-4_wp +end do +if (ICPF == 1) then + do IREF=1,NREF + IR = IREFX(IREF) + CI(IR) = GFAC*CI(IR) + end do + GINV = One/GFAC + CI(:) = GINV*CI +end if +IDFREE = 0 +IDISKD = 0 +do ISTA=1,NCONF,MBUF + NN = min(MBUF,(NCONF+1-ISTA)) + call dDAFILE(LUEIG,1,CI(ISTA),NN,IDFREE) +end do +! THEN, SET UP START CI VECTORS IN MCSF BASIS: +CI(:) = Zero +if (IREST == 0) then + call mma_allocate(ISTART,MXROOT,label='ISTART') + NNEW = IROOT(NRROOT) + I1 = 1 + I2 = 1 + do I=1,NNEW + if (I == IROOT(I1)) then + ISTART(NNEW-NRROOT+I1) = I + I1 = I1+1 + else + ISTART(I2) = I + I2 = I2+1 + end if + end do + if (NNEW > 1) then + write(u6,*) ' THE FOLLOWING REFERENCE ROOTS ARE USED AS START VECTORS:' + write(u6,'(12(A,I2))') ' ROOTS NR ',ISTART(1),(',',ISTART(I),I=2,NNEW-1),', AND ',ISTART(NNEW) + if (NNEW > NRROOT) then + write(u6,*) ' (THE FIRST EXTRA ROOT(S) WERE INCLUDED IN ORDER TO IMPROVE CONVERGENCE)' + end if + else + write(u6,'(A,I2,A)') ' ROOT NR ',ISTART(1),' IS USED AS START VECTOR.' + end if + do I=1,NNEW + ISTA = ISTART(I) + IR = IREFX(ISTA) + CI(IR) = One + IDISKC(I) = IDFREE + do ISTA=1,NCONF,MBUF + NN = min(MBUF,(NCONF+1-ISTA)) + call PKVEC(NN,CI(ISTA),ICI) + call iDAFILE(LUEIG,1,ICI,NN,IDFREE) + end do + CI(IR) = Zero + end do + call mma_deallocate(ISTART) +else + ID = 0 + NNEW = NRROOT + do I=1,NRROOT + call dDAFILE(LUREST,2,CI,NCONF,ID) + call CSFTRA('MCSF',CI,AREF) + IDISKC(I) = IDFREE + do ISTA=1,NCONF,MBUF + NN = min(MBUF,(NCONF+1-ISTA)) + call PKVEC(NN,CI(ISTA),ICI) + call iDAFILE(LUEIG,1,ICI,NN,IDFREE) + end do + end do +end if +NVTOT = NNEW +NSTOT = 0 + +return + +end subroutine CSTART diff -Nru openmolcas-22.02/src/mrci/dcorr.f openmolcas-22.10/src/mrci/dcorr.f --- openmolcas-22.02/src/mrci/dcorr.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/dcorr.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,45 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE DCORR(JREFX,AREF,ICSPCK,INTSYM,INDX,DMO) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "mrci.fh" - DIMENSION AREF(*),JREFX(*),ICSPCK(*), - * INTSYM(*),INDX(*),DMO(*) -* - JO(L)=ICUNP(ICSPCK,L) -* -C CORRECTION TO DENSITY MATRIX IN ACPF CASE. - IF(IPRINT.GE.7) WRITE(6,*)' ENP IN DENS =',ENP - FAC=1.0D00-(1.0D00/ENP) - IAD27=0 - CALL dDAFILE(Lu_27,2,AREF,NREF,IAD27) - IK=0 - DO 40 INDA=1,IRC(1) - II1=(INDA-1)*LN - IF(JREFX(INDA).NE.0) THEN - IK=IK+1 - TSUM=AREF(IK)*AREF(IK)*FAC - IJ=0 - DO 110 I=1,LN - IOC=(1+JO(II1+I))/2 - IJ=IJ+I - DMO(IJ)=DMO(IJ)+IOC*TSUM -110 CONTINUE - END IF -40 CONTINUE - RETURN -c Avoid unused argument warnings - IF (.FALSE.) THEN - CALL Unused_integer_array(INTSYM) - CALL Unused_integer_array(INDX) - END IF - END diff -Nru openmolcas-22.02/src/mrci/dcorr.F90 openmolcas-22.10/src/mrci/dcorr.F90 --- openmolcas-22.02/src/mrci/dcorr.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/dcorr.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,49 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine DCORR(JREFX,AREF,ICSPCK,DMO) + +use mrci_global, only: ENP, IPRINT, IRC, LN, Lu_27, NREF +use Constants, only: One +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: JREFX(*), ICSPCK(*) +real(kind=wp), intent(_OUT_) :: AREF(*), DMO(*) +integer(kind=iwp) :: I, IAD27, II1, IJ, IK, INDA, IOC +real(kind=wp) :: FAC, TSUM +integer(kind=iwp), external :: ICUNP + +! CORRECTION TO DENSITY MATRIX IN ACPF CASE. +if (IPRINT >= 7) write(u6,*) ' ENP IN DENS =',ENP +FAC = One-(One/ENP) +IAD27 = 0 +call dDAFILE(Lu_27,2,AREF,NREF,IAD27) +IK = 0 +do INDA=1,IRC(1) + II1 = (INDA-1)*LN + if (JREFX(INDA) /= 0) then + IK = IK+1 + TSUM = AREF(IK)*AREF(IK)*FAC + IJ = 0 + do I=1,LN + IOC = (1+ICUNP(ICSPCK,II1+I))/2 + IJ = IJ+I + DMO(IJ) = DMO(IJ)+IOC*TSUM + end do + end if +end do + +return + +end subroutine DCORR diff -Nru openmolcas-22.02/src/mrci/densct.f openmolcas-22.10/src/mrci/densct.f --- openmolcas-22.02/src/mrci/densct.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/densct.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,91 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE DENSCT(AREF) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "mrci.fh" -#include "WrkSpc.fh" - DIMENSION AREF(*) - DIMENSION IDC(MXROOT) -* - IDREST=0 - IDDMO=0 - CALL GETMEM('CI','ALLO','REAL',LCI,NCONF) - CALL GETMEM('SGM','ALLO','REAL',LSGM,NCONF) - CALL GETMEM('ASCR2','ALLO','REAL',LASCR2,NVMAX**2) - CALL GETMEM('BSCR2','ALLO','REAL',LBSCR2,NVMAX**2) - CALL GETMEM('FSCR2','ALLO','REAL',LFSCR2,NVSQ) - DO 10 I=1,NRROOT - IDC(I)=IDREST - CALL dDAFILE(LUREST,2,Work(LCI),NCONF,IDREST) - CALL FZERO(Work(LDMO),NBTRI) -*PAM04 IF(ICPF.NE.0) CALL DCORR(HWork(LJREFX),HWork(LAREF), -*PAM04 * HWork(LCSPCK), -*PAM04 * HWork(LINTSY),HWork(LINDX), -*PAM04 * HWork(LDMO)) - IF(ICPF.NE.0) CALL DCORR(IWork(LJREFX),AREF, - * IWork(LCSPCK), - * IWork(LINTSY),IWork(LINDX), - * Work(LDMO)) -*PAM04 CALL FIJD (HWork(LINTSY),HWork(LINDX),HWork(LCI), -*PAM04 * HWork(LDMO),HWork(LJREFX),HWork(LAREF)) - CALL FIJD (IWork(LINTSY),IWork(LINDX),Work(LCI), - * Work(LDMO),IWork(LJREFX),AREF) -*PAM04 CALL AID *(HWork(LINTSY),HWork(LINDX),HWork(LCI),HWork(LDMO), - CALL AID (IWork(LINTSY),IWork(LINDX),Work(LCI),Work(LDMO), - * Work(LASCR2),Work(LBSCR2),Work(LFSCR2)) -*PAM04 CALL ABD (HWork(LCSPCK),HWork(LINTSY),HWork(LINDX), - CALL ABD (IWork(LCSPCK),IWork(LINTSY),IWork(LINDX), -*PAM04 * HWork(LCI),HWork(LDMO), - * Work(LCI),Work(LDMO), - * Work(LASCR2),Work(LBSCR2),Work(LFSCR2), -*PAM04 * HWork(LJREFX)) - * IWork(LJREFX)) -*PAM04 CALL dDAFILE(LUEIG,1,HWork(LDMO),NBTRI,IDDMO) - CALL dDAFILE(LUEIG,1,Work(LDMO),NBTRI,IDDMO) -10 CONTINUE - IF(ITRANS.EQ.0) GOTO 100 - DO 20 I=2,NRROOT - IDREST=IDC(I) - CALL dDAFILE(LUREST,2,Work(LCI),NCONF,IDREST) - DO 21 J=1,I-1 - IDREST=IDC(J) - CALL dDAFILE(LUREST,2,Work(LSGM),NCONF,IDREST) -*PAM04 CALL FZERO(HWork(LTDMO),NBAST**2) - CALL FZERO(Work(LTDMO),NBAST**2) -*PAM04 CALL FIJTD (HWork(LINTSY),HWork(LINDX),HWork(LCI), -*PAM04 * HWork(LSGM),HWork(LTDMO)) - CALL FIJTD (IWork(LINTSY),IWork(LINDX),Work(LCI), - * Work(LSGM),Work(LTDMO)) -*PAM04 CALL AITD (HWork(LINTSY),HWork(LINDX),HWork(LCI), - CALL AITD (IWork(LINTSY),IWork(LINDX),Work(LCI), - * Work(LSGM), -*PAM04 * HWork(LTDMO),HWork(LASCR2),HWork(LBSCR2), - * Work(LTDMO),Work(LASCR2),Work(LBSCR2), - * Work(LFSCR2)) -*PAM04 CALL ABTD (HWork(LCSPCK),HWork(LINTSY),HWork(LINDX), - CALL ABTD (IWork(LCSPCK),IWork(LINTSY),IWork(LINDX), - * Work(LCI),Work(LSGM), -*PAM04 * HWork(LTDMO),HWork(LASCR2),HWork(LBSCR2), - * Work(LTDMO),Work(LASCR2),Work(LBSCR2), - * Work(LFSCR2)) -*PAM04 CALL dDAFILE(LUEIG,1,HWork(LTDMO),NBAST**2,IDDMO) - CALL dDAFILE(LUEIG,1,Work(LTDMO),NBAST**2,IDDMO) -21 CONTINUE -20 CONTINUE -100 CONTINUE - CALL GETMEM('CI','FREE','REAL',LCI,NCONF) - CALL GETMEM('SGM','FREE','REAL',LSGM,NCONF) - CALL GETMEM('ASCR2','FREE','REAL',LASCR2,NVMAX**2) - CALL GETMEM('BSCR2','FREE','REAL',LBSCR2,NVMAX**2) - CALL GETMEM('FSCR2','FREE','REAL',LFSCR2,NVSQ) - RETURN - END diff -Nru openmolcas-22.02/src/mrci/densct.F90 openmolcas-22.10/src/mrci/densct.F90 --- openmolcas-22.02/src/mrci/densct.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/densct.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,69 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine DENSCT(AREF) + +use mrci_global, only: CSPCK, DMO, ICPF, INDX, INTSY, JREFX, ITRANS, LUEIG, LUREST, NBAST, NBTRI, NCONF, NRROOT, NVMAX, NVSQ, TDMO +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +real(kind=wp), intent(_OUT_) :: AREF(*) +integer(kind=iwp) :: I, IDDMO, IDREST, J +integer(kind=iwp), allocatable :: IDC(:) +real(kind=wp), allocatable :: ASCR2(:), BSCR2(:), CI(:), FSCR2(:), SGM(:) + +IDREST = 0 +IDDMO = 0 +call mma_allocate(CI,NCONF,label='CI') +call mma_allocate(SGM,NCONF,label='SGM') +call mma_allocate(ASCR2,NVMAX**2,label='ASCR2') +call mma_allocate(BSCR2,NVMAX**2,label='BSCR2') +call mma_allocate(FSCR2,NVSQ,label='FSCR2') +call mma_allocate(IDC,NRROOT,label='IDC') +do I=1,NRROOT + IDC(I) = IDREST + call dDAFILE(LUREST,2,CI,NCONF,IDREST) + DMO(:) = Zero + if (ICPF /= 0) call DCORR(JREFX,AREF,CSPCK,DMO) + call FIJD(INTSY,INDX,CI,DMO,JREFX,AREF) + call AID(INTSY,INDX,CI,DMO,ASCR2,BSCR2,FSCR2) + call ABD(CSPCK,INTSY,INDX,CI,DMO,ASCR2,BSCR2,FSCR2) + call dDAFILE(LUEIG,1,DMO,NBTRI,IDDMO) +end do +if (ITRANS /= 0) then + do I=2,NRROOT + IDREST = IDC(I) + call dDAFILE(LUREST,2,CI,NCONF,IDREST) + do J=1,I-1 + IDREST = IDC(J) + call dDAFILE(LUREST,2,SGM,NCONF,IDREST) + TDMO(:,:) = Zero + call FIJTD(INTSY,INDX,CI,SGM,TDMO) + call AITD(INTSY,INDX,CI,SGM,TDMO,ASCR2,BSCR2,FSCR2) + call ABTD(CSPCK,INTSY,INDX,CI,SGM,TDMO,ASCR2,BSCR2,FSCR2) + call dDAFILE(LUEIG,1,TDMO,NBAST**2,IDDMO) + end do + end do +end if +call mma_deallocate(CI) +call mma_deallocate(SGM) +call mma_deallocate(ASCR2) +call mma_deallocate(BSCR2) +call mma_deallocate(FSCR2) +call mma_deallocate(IDC) + +return + +end subroutine DENSCT diff -Nru openmolcas-22.02/src/mrci/diagc.f openmolcas-22.10/src/mrci/diagc.f --- openmolcas-22.02/src/mrci/diagc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/diagc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,66 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE DIAGC(INTSYM,C,S) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "mrci.fh" - DIMENSION INTSYM(*),C(*),S(*) -* - JSYM(L)=JSUNP(INTSYM,L) -* - IADD25=IAD25S - CALL dDAFILE(Lu_25,2,COP,nCOP,IADD25) - IIC=0 - IND=0 - ILIM=4 - IF(IFIRST.NE.0)ILIM=2 - IRL=IRC(ILIM) - DO 100 INDA=1,IRL - NSS=MUL(JSYM(INDA),LSYM) - IF(INDA.GT.IRC(1))GO TO 120 - IIC=IIC+1 - IND=IND+1 - S(IND)=S(IND)+COP(IIC)*C(IND) - IF(IIC.LT.nCOP)GO TO 100 - CALL dDAFILE(Lu_25,2,COP,nCOP,IADD25) - IIC=0 - GO TO 100 -120 IF(INDA.GT.IRC(2))GO TO 130 - NA1=NVIRP(NSS)+1 - NA2=NVIRP(NSS)+NVIR(NSS) - IF(NA2.LT.NA1)GO TO 100 - DO 121 NA=NA1,NA2 - IIC=IIC+1 - IND=IND+1 - S(IND)=S(IND)+COP(IIC)*C(IND) - IF(IIC.LT.nCOP)GO TO 121 - CALL dDAFILE(Lu_25,2,COP,nCOP,IADD25) - IIC=0 -121 CONTINUE - GO TO 100 -130 DO 141 NA=1,NVIRT - NSA=MUL(NSS,NSM(LN+NA)) - NB1=NVIRP(NSA)+1 - NB2=NVIRP(NSA)+NVIR(NSA) - IF(NB2.GT.NA)NB2=NA - IF(NB2.LT.NB1)GO TO 141 - DO 142 NB=NB1,NB2 - IIC=IIC+1 - IND=IND+1 - S(IND)=S(IND)+COP(IIC)*C(IND) - IF(IIC.LT.nCOP)GO TO 142 - CALL dDAFILE(Lu_25,2,COP,nCOP,IADD25) - IIC=0 -142 CONTINUE -141 CONTINUE -100 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/diagc.F90 openmolcas-22.10/src/mrci/diagc.F90 --- openmolcas-22.02/src/mrci/diagc.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/diagc.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,76 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine DIAGC(INTSYM,C,S) + +use mrci_global, only: IAD25S, IFIRST, IRC, LN, LSYM, Lu_25, NSM, NVIR, NVIRP, NVIRT +use guga_util_global, only: COP, nCOP +use Symmetry_Info, only: Mul +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: INTSYM(*) +real(kind=wp), intent(in) :: C(*) +real(kind=wp), intent(inout) :: S(*) +integer(kind=iwp) :: IADD25, IIC, ILIM, IND, INDA, IRL, NA, NA1, NA2, NB, NB1, NB2, NSA, NSS +integer(kind=iwp), external :: JSUNP + +IADD25 = IAD25S +call dDAFILE(Lu_25,2,COP,nCOP,IADD25) +IIC = 0 +IND = 0 +ILIM = 4 +if (IFIRST /= 0) ILIM = 2 +IRL = IRC(ILIM) +do INDA=1,IRL + NSS = MUL(JSUNP(INTSYM,INDA),LSYM) + if (INDA <= IRC(1)) then + IIC = IIC+1 + IND = IND+1 + S(IND) = S(IND)+COP(IIC)*C(IND) + if (IIC >= nCOP) then + call dDAFILE(Lu_25,2,COP,nCOP,IADD25) + IIC = 0 + end if + else if (INDA <= IRC(2)) then + NA1 = NVIRP(NSS)+1 + NA2 = NVIRP(NSS)+NVIR(NSS) + do NA=NA1,NA2 + IIC = IIC+1 + IND = IND+1 + S(IND) = S(IND)+COP(IIC)*C(IND) + if (IIC >= nCOP) then + call dDAFILE(Lu_25,2,COP,nCOP,IADD25) + IIC = 0 + end if + end do + else + do NA=1,NVIRT + NSA = MUL(NSS,NSM(LN+NA)) + NB1 = NVIRP(NSA)+1 + NB2 = NVIRP(NSA)+NVIR(NSA) + if (NB2 > NA) NB2 = NA + do NB=NB1,NB2 + IIC = IIC+1 + IND = IND+1 + S(IND) = S(IND)+COP(IIC)*C(IND) + if (IIC >= nCOP) then + call dDAFILE(Lu_25,2,COP,nCOP,IADD25) + IIC = 0 + end if + end do + end do + end if +end do + +return + +end subroutine DIAGC diff -Nru openmolcas-22.02/src/mrci/diagct.f openmolcas-22.10/src/mrci/diagct.f --- openmolcas-22.02/src/mrci/diagct.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/diagct.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,79 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE DIAGCT() - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "mrci.fh" -#include "WrkSpc.fh" -* ---------------------------------------------------------------------- - NINDS=(NBITM1+2)*NCHN1 - NBUFS=NBITM1*NCHN1 - CALL GETMEM('Bufs','Allo','Real',LBUFS,NBUFS) - CALL GETMEM('Inds','Allo','Inte',LINDS,NINDS) - NBUFBI=KBUFF1 - CALL GETMEM('BUFBI','Allo','Real',LBUFBI,NBUFBI) - CALL GETMEM('BIAC1','Allo','Real',LBIAC1,ISMAX) - CALL GETMEM('BICA1','Allo','Real',LBICA1,ISMAX) - CALL DCOPY_(NBUFS,[0.0D0],0,Work(LBUFS),1) - CALL ICOPY(NINDS,[0],0,IWork(LINDS),1) - CALL SORTA (Work(LBUFS),IWork(LINDS),IWork(LISAB), - * Work(LBUFBI),Work(LBIAC1),Work(LBICA1),NINTGR) - CALL GETMEM('BIAC1','Free','Real',LBIAC1,ISMAX) - CALL GETMEM('BICA1','Free','Real',LBICA1,ISMAX) - CALL GETMEM('BUFBI','Free','Real',LBUFBI,NBUFBI) - CALL GETMEM('Bufs','Free','Real',LBUFS,NBUFS) - CALL GETMEM('Inds','Free','Inte',LINDS,NINDS) -* ---------------------------------------------------------------------- - - IF(IFIRST.EQ.0) THEN - NINDS=(NBITM2+2)*NCHN2 - NBUFS=NBITM2*NCHN2 - CALL GETMEM('Bufs','Allo','Real',LBUFS,NBUFS) - CALL GETMEM('Inds','Allo','Inte',LINDS,NINDS) - CALL GETMEM('BACBD','Allo','Real',LBACBD,KBUFF1) - CALL GETMEM('ACBDT','Allo','Real',LACBDT,ISMAX) - CALL GETMEM('ACBDS','Allo','Real',LACBDS,ISMAX) - CALL DCOPY_(NBUFS,[0.0D0],0,Work(LBUFS),1) - CALL ICOPY(NINDS,[0],0,IWork(LINDS),1) - CALL SORTB (Work(LBUFS),IWork(LINDS), - * Work(LACBDS),Work(LACBDT),IWork(LISAB), - * Work(LBACBD),NINTGR) - CALL GETMEM('BACBD','Free','Real',LBACBD,KBUFF1) - CALL GETMEM('ACBDT','Free','Real',LACBDT,ISMAX) - CALL GETMEM('ACBDS','Free','Real',LACBDS,ISMAX) - CALL GETMEM('Bufs','Free','Real',LBUFS,NBUFS) - CALL GETMEM('Inds','Free','Inte',LINDS,NINDS) - END IF -* ------------------- SORT -------------------------------------------- - NINDS=(NBITM3+2)*NCHN3 - NBUFS=NBITM3*NCHN3 - CALL GETMEM('Bufs','Allo','Real',LBUFS,NBUFS) - CALL GETMEM('Inds','Allo','Inte',LINDS,NINDS) - CALL GETMEM('FIIJJ','Allo','Real',LIIJJ,NBTRI) - CALL GETMEM('FIJIJ','Allo','Real',LIJIJ,NBTRI) - CALL DCOPY_(NBUFS,[0.0D0],0,Work(LBUFS),1) - CALL ICOPY(NINDS,[0],0,IWork(LINDS),1) - CALL SORT_MRCI (Work(LBUFS),IWork(LINDS),Work(LFOCK),Work(LIIJJ), - * Work(LIJIJ),NINTGR) - CALL GETMEM('Bufs','Free','Real',LBUFS,NBUFS) - CALL GETMEM('Inds','Free','Inte',LINDS,NINDS) -* ---------------------------------------------------------------------- - NVT=(NVIRT*(NVIRT+1))/2 - NHDIAG=MAX(NVT,IRC(1)) - CALL GETMEM('HDIAG','Allo','Real',LHDIAG,NHDIAG) - CALL IIJJ (IWork(LCSPCK),IWork(LINTSY),Work(LHDIAG), - * Work(LFOCK),Work(LIIJJ),Work(LIJIJ)) - CALL GETMEM('FIIJJ','Free','Real',LIIJJ,NBTRI) - CALL IJIJ (IWork(LINTSY),Work(LHDIAG),Work(LFOCK),Work(LIJIJ)) - CALL GETMEM('HDIAG','Free','Real',LHDIAG,NHDIAG) - CALL GETMEM('FIJIJ','Free','Real',LIJIJ,NBTRI) - RETURN - END diff -Nru openmolcas-22.02/src/mrci/diagct.F90 openmolcas-22.10/src/mrci/diagct.F90 --- openmolcas-22.02/src/mrci/diagct.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/diagct.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,78 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine DIAGCT() + +use mrci_global, only: CSPCK, FOCK, IFIRST, INTSY, IRC, ISAB, ISMAX, KBUFF1, NBITM1, NBITM2, NBITM3, NBTRI, NCHN1, NCHN2, NCHN3, & + NVIRT +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp) :: NHDIAG, NINTGR, NVT +integer(kind=iwp), allocatable :: Inds(:,:) +real(kind=wp), allocatable :: ACBDS(:), ACBDT(:), BACBD(:), BIAC1(:), BICA1(:), BUFBI(:), Bufs(:,:), FIIJJ(:), FIJIJ(:), HDIAG(:) + +! ---------------------------------------------------------------------- +call mma_allocate(Bufs,NBITM1,NCHN1,label='Bufs') +call mma_allocate(Inds,NBITM1+2,NCHN1,label='Inds') +call mma_allocate(BUFBI,KBUFF1,label='BUFBI') +call mma_allocate(BIAC1,ISMAX,label='BIAC1') +call mma_allocate(BICA1,ISMAX,label='BICA1') +Bufs(:,:) = Zero +Inds(:,:) = 0 +call SORTA(Bufs,Inds,ISAB,BUFBI,BIAC1,BICA1,NINTGR) +call mma_deallocate(Bufs) +call mma_deallocate(Inds) +call mma_deallocate(BUFBI) +call mma_deallocate(BIAC1) +call mma_deallocate(BICA1) +! ---------------------------------------------------------------------- + +if (IFIRST == 0) then + call mma_allocate(Bufs,NBITM2,NCHN2,label='Bufs') + call mma_allocate(Inds,NBITM2+2,NCHN2,label='Bufs') + call mma_allocate(BACBD,KBUFF1,label='BACBD') + call mma_allocate(ACBDT,ISMAX,label='ACBDT') + call mma_allocate(ACBDS,ISMAX,label='ACBDS') + Bufs(:,:) = Zero + Inds(:,:) = 0 + call SORTB(Bufs,Inds,ACBDS,ACBDT,ISAB,BACBD) + call mma_deallocate(Bufs) + call mma_deallocate(Inds) + call mma_deallocate(BACBD) + call mma_deallocate(ACBDT) + call mma_deallocate(ACBDS) +end if +! ------------------- SORT -------------------------------------------- +call mma_allocate(Bufs,NBITM3,NCHN3,label='Bufs') +call mma_allocate(Inds,NBITM3+2,NCHN3,label='Inds') +call mma_allocate(FIIJJ,NBTRI,label='FIIJJ') +call mma_allocate(FIJIJ,NBTRI,label='FIJIJ') +Bufs(:,:) = Zero +Inds(:,:) = 0 +call SORT_MRCI(Bufs,Inds,FOCK,FIIJJ,FIJIJ) +call mma_deallocate(Bufs) +call mma_deallocate(Inds) +! ---------------------------------------------------------------------- +NVT = (NVIRT*(NVIRT+1))/2 +NHDIAG = max(NVT,IRC(1)) +call mma_allocate(HDIAG,NHDIAG,label='HDIAG') +call IIJJ(CSPCK,INTSY,HDIAG,FOCK,FIIJJ,FIJIJ) +call IJIJ(INTSY,HDIAG,FIJIJ) +call mma_deallocate(FIIJJ) +call mma_deallocate(FIJIJ) +call mma_deallocate(HDIAG) + +return + +end subroutine DIAGCT diff -Nru openmolcas-22.02/src/mrci/diagro.f openmolcas-22.10/src/mrci/diagro.f --- openmolcas-22.02/src/mrci/diagro.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/diagro.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,598 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE DIAGRO(CI,SGM,CBUF,SBUF,DBUF,AREF,EREF, - * CSECT,RSECT,XI1,XI2,CNEW,SCR,ICI) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "warnings.h" -#include "mrci.fh" -#include "WrkSpc.fh" - DIMENSION CI(NCONF),SGM(NCONF) - DIMENSION CBUF(MBUF,MXVEC),SBUF(MBUF,MXVEC),DBUF(MBUF) - DIMENSION AREF(NREF,NREF),EREF(NREF) - DIMENSION CSECT(NSECT,MXVEC),RSECT(NSECT,MXVEC) - DIMENSION XI1(NSECT,NRROOT),XI2(NSECT,NRROOT) - DIMENSION CNEW(NSECT,NRROOT),SCR(*) - DIMENSION ICI(MBUF) - DIMENSION IDC(MXVEC),IDS(MXVEC) - DIMENSION HCOPY(MXVEC,MXVEC),SCOPY(MXVEC,MXVEC) - DIMENSION PCOPY(MXVEC,MXVEC) - DIMENSION ELAST(MXROOT),PSEL(MXVEC),RNRM(MXROOT) -C DIMENSION EPERT(MXROOT) -* - WRITE(6,*) - WRITE(6,*)('-',I=1,60) - IF (ICPF.EQ.0) THEN - WRITE(6,*)' MR SDCI CALCULATION.' - ELSE - WRITE(6,*)' MR ACPF CALCULATION.' - END IF - WRITE(6,*)('-',I=1,60) - WRITE(6,*) - WRITE(6,*)' CONVERGENCE STATISTICS:' - WRITE(6,'(1X,A)')'ITER NVEC ENERGIES LOWERING'// - & ' RESIDUAL SEL.WGT CPU(S) CPU TOT' - ITER=0 - CALL SETTIM - CALL TIMING(CPTNOW,DUM,DUM,DUM) - CPTOLD=CPTNOW - CPTSTA=CPTNOW -C LOOP HEAD FOR CI ITERATIONS: -1000 CONTINUE - ITER=ITER+1 -* ------------------------------------------------------------------- -C CALCULATE SIGMA ARRAYS FOR SHIFTED HAMILTONIAN IN MCSF BASIS: - DO 100 I=1,NNEW - IVEC=1+MOD(NVTOT-NNEW+I-1,MXVEC) - IDISK=IDISKC(IVEC) - DO 110 ISTA=1,NCONF,MBUF - NN=MIN(MBUF,NCONF+1-ISTA) - CALL iDAFILE(LUEIG,2,ICI,NN,IDISK) - CALL UPKVEC(NN,ICI,CI(ISTA)) -110 CONTINUE - CALL GETMEM('BMN','ALLO','REAL',LBMN,NBMN) - CALL GETMEM('IBMN','ALLO','INTE',LIBMN,NBMN) - CALL GETMEM('BIAC2','ALLO','REAL',LBIAC2,ISMAX) - CALL GETMEM('BICA2','ALLO','REAL',LBICA2,ISMAX) - CALL GETMEM('BFIN3','ALLO','REAL',LBFIN3,KBUFF1) - CALL GETMEM('AC1','ALLO','REAL',LAC1,ISMAX) - CALL GETMEM('AC2','ALLO','REAL',LAC2,ISMAX) - CALL GETMEM('BFIN4','ALLO','REAL',LBFIN4,KBUFF1) - CALL GETMEM('ABIJ','ALLO','REAL',LABIJ,NVSQ) - CALL GETMEM('AIBJ','ALLO','REAL',LAIBJ,NVSQ) - CALL GETMEM('AJBI','ALLO','REAL',LAJBI,NVSQ) - CALL GETMEM('ASCR1','ALLO','REAL',LASCR1,NVMAX**2) - CALL GETMEM('BSCR1','ALLO','REAL',LBSCR1,NVMAX**2) - CALL GETMEM('FSCR1','ALLO','REAL',LFSCR1,NVSQ) - CALL GETMEM('FSEC','ALLO','REAL',LFSEC,2*NVSQ) - CALL GETMEM('BFIN5','ALLO','REAL',LBFIN5,KBUFF1) - CALL GETMEM('ASCR2','ALLO','REAL',LASCR2,NVMAX**2) - CALL GETMEM('BSCR2','ALLO','REAL',LBSCR2,NVMAX**2) - CALL GETMEM('FSCR2','ALLO','REAL',LFSCR2,NVSQ) - CALL GETMEM('DBK','ALLO','REAL',LDBK,2*NVSQ) -cvv CALL SIGMA(HWORK,CI,SGM) -cpam CALL SIGMA(HWORK) -*PAM04 CALL SIGMA(HWork(LSGM),HWork(LAREF),HWork(LCI),HWork(LINTSY), -*PAM04 & HWork(LINDX),HWork(LBMN),HWork(LIBMN),HWork(LBIAC2), - CALL SIGMA(SGM,AREF,CI,IWork(LINTSY), - & IWork(LINDX),Work(LBMN),IWork(LIBMN),Work(LBIAC2), -*PAM04 & HWork(LBICA2),HWork(LBFIN3),HWork(LFIJKL),HWork(LISAB), - & Work(LBICA2),Work(LBFIN3),IWork(LISAB), -*PAM04 & HWork(LAC1),HWork(LAC2),HWork(LBFIN4),HWork(LABIJ), - & Work(LAC1),Work(LAC2),Work(LBFIN4),Work(LABIJ), -*PAM04 & HWork(LAIBJ),HWork(LAJBI),HWork(LBFIN1),HWork(LASCR1), - & Work(LAIBJ),Work(LAJBI),Work(LASCR1), -*PAM04 & HWork(LBSCR1),HWork(LFSCR1),HWork(LFSEC),HWork(LFOCK), - & Work(LBSCR1),Work(LFSCR1),Work(LFSEC),Work(LFOCK), - & Work(LBFIN5),Work(LASCR2),Work(LBSCR2), -*PAM04 & HWork(LFSCR2),HWork(LDBK),HWork(LCSPCK)) - & Work(LFSCR2),Work(LDBK),IWork(LCSPCK)) - CALL GETMEM('BFIN5','FREE','REAL',LBFIN5,KBUFF1) - CALL GETMEM('ASCR2','FREE','REAL',LASCR2,NVMAX**2) - CALL GETMEM('BSCR2','FREE','REAL',LBSCR2,NVMAX**2) - CALL GETMEM('FSCR2','FREE','REAL',LFSCR2,NVSQ) - CALL GETMEM('DBK','FREE','REAL',LDBK,2*NVSQ) - CALL GETMEM('ABIJ','FREE','REAL',LABIJ,NVSQ) - CALL GETMEM('AIBJ','FREE','REAL',LAIBJ,NVSQ) - CALL GETMEM('AJBI','FREE','REAL',LAJBI,NVSQ) - CALL GETMEM('ASCR1','FREE','REAL',LASCR1,NVMAX**2) - CALL GETMEM('BSCR1','FREE','REAL',LBSCR1,NVMAX**2) - CALL GETMEM('FSCR1','FREE','REAL',LFSCR1,NVSQ) - CALL GETMEM('FSEC','FREE','REAL',LFSEC,2*NVSQ) - CALL GETMEM('BMN','FREE','REAL',LBMN,NBMN) - CALL GETMEM('IBMN','FREE','INTE',LIBMN,NBMN) - CALL GETMEM('BIAC2','FREE','REAL',LBIAC2,ISMAX) - CALL GETMEM('BICA2','FREE','REAL',LBICA2,ISMAX) - CALL GETMEM('BFIN3','FREE','REAL',LBFIN3,KBUFF1) - CALL GETMEM('AC1','FREE','REAL',LAC1,ISMAX) - CALL GETMEM('AC2','FREE','REAL',LAC2,ISMAX) - CALL GETMEM('BFIN4','FREE','REAL',LBFIN4,KBUFF1) - NSTOT=NSTOT+1 -C WRITE IT OUT: - IVEC=1+MOD(NSTOT-1,MXVEC) - IDISK=IDISKS(IVEC) - IF(IDISK.EQ.-1) IDISK=IDFREE - DO 120 ISTA=1,NCONF,MBUF - NN=MIN(MBUF,NCONF+1-ISTA) - CALL dDAFILE(LUEIG,1,SGM(ISTA),NN,IDISK) -120 CONTINUE - IF (IDISK.GT.IDFREE) THEN - IDISKS(IVEC)=IDFREE - IDFREE=IDISK - END IF -100 CONTINUE -* ------------------------------------------------------------------- -C NR OF VECTORS PRESENTLY RETAINED: - NVEC=MIN(MXVEC,NVTOT) -C NR OF OLD VECTORS RETAINED: - NOLD=NVEC-NNEW -* ------------------------------------------------------------------- -C COPY HSMALL, SSMALL AND PSMALL IN REORDERED FORM, BY AGE: - DO 206 L=NNEW+1,NVEC - LL=1+MOD(NVTOT-L,MXVEC) - DO 2060 K=NNEW+1,NVEC - KK=1+MOD(NVTOT-K,MXVEC) - HCOPY(K,L)=HSMALL(KK,LL) - SCOPY(K,L)=SSMALL(KK,LL) - PCOPY(K,L)=PSMALL(KK,LL) -2060 CONTINUE -206 CONTINUE -C CLEAR NEW AREAS TO BE USED: - DO 207 K=1,NVEC - DO 2070 L=1,NNEW - HCOPY(K,L)=0.0D00 - SCOPY(K,L)=0.0D00 - PCOPY(K,L)=0.0D00 -2070 CONTINUE -207 CONTINUE -C THEN LOOP OVER BUFFERS. FIRST GET COPIES OF DISK ADDRESSES: - DO 210 K=1,NVEC - IDC(K)= IDISKC(K) - IDS(K)= IDISKS(K) -210 CONTINUE - DO 200 ISTA=1,NCONF,MBUF - IEND=MIN(NCONF,ISTA+MBUF-1) - IBUF=1+IEND-ISTA - DO 220 K=1,NVEC - KK=1+MOD(NVTOT-K,MXVEC) - CALL iDAFILE(LUEIG,2,ICI,IBUF,IDC(KK)) - CALL UPKVEC(IBUF,ICI,CBUF(1,K)) - IF(K.GT.NNEW) GOTO 220 - CALL dDAFILE(LUEIG,2,SBUF(1,K),IBUF,IDS(KK)) -220 CONTINUE -* ------------------------------------------------------------------- -C NOTE: AT THIS POINT, THE COLUMNS NR 1..NVEC OF CBUF WILL -C CONTAIN THE BUFFERS OF, FIRST, THE NNEW NEWEST PSI ARRAYS, -C THEN, THE NOLD ONES FROM EARLIER ITERATIONS. -C THE COLUMNS 1..NNEW OF SBUF WILL CONTAIN THE NEWEST NNEW -C SIGMA ARRAYS. LEADING DIMENSION OF CBUF AND SBUF IS MBUF. ACTUAL -C BUFFER SIZE IS IBUF, WHICH CAN BE SMALLER. ACCUMULATE: - CALL DGEMM_('T','N', - & NVEC,NNEW,IBUF, - & 1.0d0,CBUF,MBUF, - & CBUF,MBUF, - & 0.0d0,SCR,NVEC) - KL=0 - DO 230 L=1,NNEW - DO 231 K=1,NVEC - KL=KL+1 - SCOPY(K,L)=SCOPY(K,L)+SCR(KL) -231 CONTINUE -230 CONTINUE - CALL DGEMM_('T','N', - & NVEC,NNEW,IBUF, - & 1.0d0,CBUF,MBUF, - & SBUF,MBUF, - & 0.0d0,SCR,NVEC) - KL=0 - DO 240 L=1,NNEW - DO 241 K=1,NVEC - KL=KL+1 - HCOPY(K,L)=HCOPY(K,L)+SCR(KL) -241 CONTINUE -240 CONTINUE -C ALSO, UPDATE PSMALL, WHICH IS USED FOR SELECTION. - IF(ISTA.GT.IREFX(NRROOT)) GOTO 200 - DO 250 I=1,NRROOT - IR=IROOT(I) - IRR=IREFX(IR) - IF(IRR.LT.ISTA) GOTO 250 - IF(IRR.GT.IEND) GOTO 250 - IPOS=IRR+1-ISTA - DO 260 L=1,NNEW - DO 261 K=1,NVEC - PCOPY(K,L)=PCOPY(K,L)+CBUF(IPOS,K)*CBUF(IPOS,L) -261 CONTINUE -260 CONTINUE -250 CONTINUE -200 CONTINUE -C TRANSFER ELEMENTS BACK TO HSMALL, ETC. - DO 256 L=1,NNEW - LL=1+MOD(NVTOT-L,MXVEC) - DO 2560 K=1,NVEC - KK=1+MOD(NVTOT-K,MXVEC) - H=HCOPY(K,L) - S=SCOPY(K,L) - P=PCOPY(K,L) - HCOPY(L,K)=H - SCOPY(L,K)=S - PCOPY(L,K)=P - HSMALL(KK,LL)=H - SSMALL(KK,LL)=S - PSMALL(KK,LL)=P - HSMALL(LL,KK)=H - SSMALL(LL,KK)=S - PSMALL(LL,KK)=P -2560 CONTINUE -256 CONTINUE - IF(IPRINT.GE.10) THEN - WRITE(6,*) - WRITE(6,*)' HSMALL MATRIX:' - DO 251 I=1,NVEC - WRITE(6,'(1X,5F15.6)')(HSMALL(I,J),J=1,NVEC) -251 CONTINUE - WRITE(6,*) - WRITE(6,*)' SSMALL MATRIX:' - DO 252 I=1,NVEC - WRITE(6,'(1X,5F15.6)')(SSMALL(I,J),J=1,NVEC) -252 CONTINUE - WRITE(6,*) - WRITE(6,*)' PSMALL MATRIX:' - DO 253 I=1,NVEC - WRITE(6,'(1X,5F15.6)')(PSMALL(I,J),J=1,NVEC) -253 CONTINUE -C WRITE(6,*) -C WRITE(6,*) -C WRITE(6,*)' HCOPY MATRIX:' -C DO 1251 I=1,NVEC -C WRITE(6,'(1X,5F15.6)')(HCOPY(I,J),J=1,NVEC) -C1251 CONTINUE -C WRITE(6,*) -C WRITE(6,*)' SCOPY MATRIX:' -C DO 1252 I=1,NVEC -C WRITE(6,'(1X,5F15.6)')(SCOPY(I,J),J=1,NVEC) -C1252 CONTINUE -C WRITE(6,*) - END IF -* ------------------------------------------------------------------- -C THE UPPER-LEFT NVEC*NVEC SUBMATRICES OF HSMALL AND SSMALL NOW -C CONTAINS THE CURRENT HAMILTONIAN AND OVERLAP MATRICES, IN THE -C BASIS OF PRESENTLY RETAINED PSI VECTORS. DIAGONALIZE, BUT USE -C THE REORDERED MATRICES IN SCOPY, HCOPY,DCOPY. THERE THE BASIS -C FUNCTIONS ARE ORDERED BY AGE. - THR=1.0D-06 - CALL SECULAR(MXVEC,NVEC,NRON,HCOPY,SCOPY, - & VSMALL,ESMALL,SCR,THR) -C REORDER THE ELEMENTS OF VSMALL TO GET EIGENVECTORS OF HSMALL. NOTE: -C THIS IS NOT THE SAME AS IF WE DIAGONALIZED HSMALL DIRECTLY. -C THE DIFFERENCE OCCURS WHENEVER VECTORS ARE THROWN OUT OF THE -C CALCULATION IN SECULAR BECAUSE OF LINEAR DEPENDENCE. THE RESULT -C WILL DEPEND SLIGHTLY BUT CRITICALLY ON THE ORDER BY WHICH THE -C VECTORS WERE ORTHONORMALIZED. - DO 259 I=1,NRON - DO 257 K=1,NVEC - KK=1+MOD(NVTOT-K,MXVEC) - SCR(KK)=VSMALL(K,I) -257 CONTINUE - DO 258 K=1,NVEC - VSMALL(K,I)=SCR(K) -258 CONTINUE -259 CONTINUE - IF(NRON.LT.NRROOT) THEN - WRITE(6,*)'DIAGRO Error: Linear dependence has reduced' - WRITE(6,*)' the number of solutions to NRON, but you' - WRITE(6,*)' wanted NRROOT soultions.' - WRITE(6,'(1X,A,I3)')' NRON=',NRON - WRITE(6,'(1X,A,I3)')'NRROOT=',NRROOT - CALL QUIT(_RC_INTERNAL_ERROR_) - END IF -C ORDER THE EIGENFUNCTIONS BY DECREASING OVERLAP WITH THE SPACE -C SPANNED BY THE ORIGINALLY SELECTED REFCI ROOTS. - CALL DGEMM_('N','N', - & NVEC,NRON,NVEC, - & 1.0d0,PSMALL,MXVEC, - & VSMALL,MXVEC, - & 0.0d0,SCR,NVEC) - II=1 - DO 350 I=1,NRON - PSEL(I)=DDOT_(NVEC,VSMALL(1,I),1,SCR(II),1) - II=II+NVEC -350 CONTINUE -C PSEL(I) NOW CONTAINS EXPECTATION VALUE OF PMAT FOR I-TH EIGENVECTOR. -C WRITE(6,*)' ARRAY OF SELECTION AMPLITUDES IN SCR:' -C WRITE(6,'(1X,5F15.6)')(PSEL(I),I=1,NRON) - DO 380 I=1,NRON-1 - IMAX=I - PMAX=PSEL(I) - DO 360 J=I+1,NRON - IF(PSEL(J).LT.PMAX) GOTO 360 - PMAX=PSEL(J) - IMAX=J -360 CONTINUE - IF(IMAX.EQ.I) GOTO 380 - PSEL(IMAX)=PSEL(I) - PSEL(I)=PMAX - TMP=ESMALL(IMAX) - ESMALL(IMAX)=ESMALL(I) - ESMALL(I)=TMP - DO 370 K=1,NVEC - TMP=VSMALL(K,IMAX) - VSMALL(K,IMAX)=VSMALL(K,I) - VSMALL(K,I)=TMP -370 CONTINUE -380 CONTINUE -C FINALLY, REORDER THE SELECTED ROOTS BY ENERGY: - DO 1380 I=1,NRROOT-1 - IMIN=I - EMIN=ESMALL(I) - DO 1360 J=I+1,NRROOT - IF(ESMALL(J).GE.EMIN) GOTO 1360 - EMIN=ESMALL(J) - IMIN=J -1360 CONTINUE - IF(IMIN.EQ.I) GOTO 1380 - ESMALL(IMIN)=ESMALL(I) - ESMALL(I)=EMIN - TMP=PSEL(IMIN) - PSEL(IMIN)=PSEL(I) - PSEL(I)=TMP - DO 1370 K=1,NVEC - TMP=VSMALL(K,IMIN) - VSMALL(K,IMIN)=VSMALL(K,I) - VSMALL(K,I)=TMP -1370 CONTINUE -1380 CONTINUE -C WRITE(6,*)' EIGENVALUES OF HSMALL. NRON=',NRON -C WRITE(6,'(1X,5F15.6)')(ESMALL(I),I=1,NRON) -C WRITE(6,*)' SELECTION WEIGHTS:' -C WRITE(6,'(1X,5F15.6)')( PSEL(I),I=1,NRON) -C WRITE(6,*)' SELECTED EIGENVECTORS:' -C DO 381 I=1,NRROOT -C WRITE(6,'(1X,5F15.6)')(VSMALL(K,I),K=1,NVEC) -C381 CONTINUE -C WRITE(6,*) -* ------------------------------------------------------------------- -C CALCULATE RESIDUAL ARRAYS FOR THE NRROOTS EIGENFUNCTIONS OF HSMALL. -C ALSO, USE THE OPPORTUNITY TO FORM MANY OTHER SMALL ARRAYS. - CALL GETMEM('ARR','ALLO','REAL',LARR,11*NRROOT**2) - CALL HZLP1(CBUF,SBUF,DBUF,WORK(LARR),CSECT,RSECT,XI1,XI2,ICI) -C USE THESE SMALLER ARRAYS TO FORM HZERO AND SZERO. THIS IS -C OVERLAP AND HAMILTONIAN IN THE BASIS (PSI,RHO,XI1,XI2), WHERE -C PSI ARE THE EIGENFUNCTIONS OF HSMALL, RHO ARE RESIDUALS, ETC. - CALL HZ(WORK(LARR)) - CALL GETMEM('ARR','FREE','REAL',LARR,11*NRROOT**2) - NZ=4*NRROOT -C WRITE(6,*) -C WRITE(6,*)' AFTER HZ CALL. HZERO HAMILTONIAN:' -C DO 391 I=1,NZ -C WRITE(6,'(1X,5F15.6)')(HZERO(I,J),J=1,NZ) -C 391 CONTINUE -C WRITE(6,*)' SZERO:' -C DO 392 I=1,NZ -C WRITE(6,'(1X,5F15.6)')(SZERO(I,J),J=1,NZ) -C 392 CONTINUE - DO 393 I=1,NRROOT - RNRM(I)=SQRT(SZERO(NRROOT+I,NRROOT+I)) -C EPERT(I)=ESMALL(I)-SZERO(3*NRROOT+I,NRROOT+I) -393 CONTINUE -C WRITE(6,*) -C WRITE(6,*)' PERTURBATION ESTIMATES TO ENERGY:' -C WRITE(6,'(1X,5F15.6)')(ESHIFT+EPERT(I),I=1,NRROOT) -* ------------------------------------------------------------------ - NCONV=0 - CALL TIMING(CPTNOW,DUM,DUM,DUM) - CPTIT=CPTNOW-CPTOLD - CPTOLD=CPTNOW - CPTOT=CPTNOW-CPTSTA - IF(ITER.EQ.1) THEN - EDISP=ESMALL(1)+ESHIFT - WRITE(6,1234) ITER,NVEC,EDISP,RNRM(1),PSEL(1),CPTIT,CPTOT - ELSE - ELOW=ESMALL(1)-ELAST(1) - IF((ELOW.LT.0.0D00).AND.(ABS(ELOW).LE.ETHRE)) NCONV=1 - EDISP=ESMALL(1)+ESHIFT - WRITE(6,1235) ITER,NVEC,EDISP,ELOW,RNRM(1),PSEL(1),CPTIT,CPTOT - END IF - IF(NRROOT.GT.1) THEN - DO 1240 I=2,NRROOT - EDISP=ESMALL(I)+ESHIFT - IF(ITER.EQ.1) THEN - WRITE(6,1236) EDISP,RNRM(I),PSEL(I) - ELSE - ELOW=ESMALL(I)-ELAST(I) - IF((ELOW.LT.0.0D00).AND.(ABS(ELOW).LE.ETHRE)) NCONV=NCONV+1 - WRITE(6,1237) EDISP,ELOW,RNRM(I),PSEL(I) - END IF -1240 CONTINUE - WRITE(6,*) - END IF - DO 1241 I=1,NRROOT - ELAST(I)=ESMALL(I) -1241 CONTINUE -1234 FORMAT(1X,I4,1X,I4,1X,F15.8,9X ,D9.2,1X,F6.3,2(1X,F7.1)) -1235 FORMAT(1X,I4,1X,I4,1X,F15.8,D9.2,D9.2,1X,F6.3,2(1X,F7.1)) -1236 FORMAT(11X, F15.8,9X ,D9.2,1X,F6.3) -1237 FORMAT(11X, F15.8,D9.2,D9.2,1X,F6.3) - IF(NCONV.EQ.NRROOT) THEN - WRITE(6,*)' CONVERGENCE IN ENERGY.' - GOTO 2000 - END IF -* ------------------------------------------------------------------ - THR=1.0D-06 - CALL SECULAR(MXZ,NZ,NRON,HZERO,SZERO,VZERO,EZERO,SCR,THR) -C WRITE(6,*)' AFTER SECULAR CALL. NRON=',NRON -C WRITE(6,*)' EIGENVALUES & -VECTORS:' -C DO 395 I=1,NRON -C WRITE(6,'(1X,5F15.6)') EZERO(I) -C WRITE(6,'(1X,5F15.6)')(VZERO(K,I),K=1,NZ) -C395 CONTINUE -C ORDER THE EIGENFUNCTIONS BY DECREASING SIZE OF PSI PART. - CALL DGEMM_('T','N', - & NRON,NRROOT,NZ, - & 1.0d0,VZERO,MXZ, - & SZERO,MXZ, - & 0.0d0,SCR(1+NRON),NRON) - DO 450 I=1,NRON - II=I - SUM=0.0D00 - DO 440 K=1,NRROOT - II=II+NRON - SUM=SUM+SCR(II)**2 -440 CONTINUE - SCR(I)=SUM -450 CONTINUE -C WRITE(6,*) -C WRITE(6,*)' SELECTION CRITERION VECTOR, BEFORE ORDERING:' -C WRITE(6,'(1X,5F15.6)')(SCR(I),I=1,NRON) - DO 480 I=1,NRON-1 - IMAX=I - PMAX=SCR(I) - DO 460 J=I+1,NRON - IF(SCR(J).LT.PMAX) GOTO 460 - PMAX=SCR(J) - IMAX=J -460 CONTINUE - IF(IMAX.EQ.I) GOTO 480 - SCR(IMAX)=SCR(I) - SCR(I)=PMAX - TMP=EZERO(IMAX) - EZERO(IMAX)=EZERO(I) - EZERO(I)=TMP - DO 470 K=1,NZ - TMP=VZERO(K,IMAX) - VZERO(K,IMAX)=VZERO(K,I) - VZERO(K,I)=TMP -470 CONTINUE -480 CONTINUE -CPAM 94-10-30, must reorder as before (DO 1380 etc): -C REORDER THE SELECTED ROOTS BY ENERGY: - DO 1480 I=1,NRROOT-1 - IMIN=I - EMIN=EZERO(I) - DO 1460 J=I+1,NRROOT - IF(EZERO(J).GE.EMIN) GOTO 1460 - EMIN=EZERO(J) - IMIN=J -1460 CONTINUE - IF(IMIN.EQ.I) GOTO 1480 - EZERO(IMIN)=EZERO(I) - EZERO(I)=EMIN - TMP=SCR(IMIN) - SCR(IMIN)=SCR(I) - SCR(I)=TMP - DO 1470 K=1,NZ - TMP=VZERO(K,IMIN) - VZERO(K,IMIN)=VZERO(K,I) - VZERO(K,I)=TMP -1470 CONTINUE -1480 CONTINUE -CPAM 94-10-30, end of update. -C NOTE: IF THE UPDATE PART IS SMALL ENOUGH FOR ALL THE FIRST NRROOT -C ARRAY, THE CALCULATION HAS CONVERGED. - NNEW=0 -C WRITE(6,*)' CONVERGENCE CRITERION: SIZE OF UPDATE PART.' - DO 490 I=1,NRROOT - SQNRM=1.0D00-SCR(I) -C WRITE(6,*)' ROOT NR, SQNRM:',I,SQNRM - IF(SQNRM.LT.SQNLIM) GOTO 490 - NNEW=NNEW+1 -490 CONTINUE -C WRITE(6,*) -C WRITE(6,*)' EIGENVALUES OF THE HZERO HAMILTONIAN:' -C WRITE(6,'(1X,5F15.6)')(EZERO(I),I=1,NRON) -C WRITE(6,*)' SELECTION WEIGHTS:' -C WRITE(6,'(1X,5F15.6)')( SCR(I),I=1,NRON) -C WRITE(6,*)' EIGENVECTORS:' -C DO 394 I=1,NRON -C WRITE(6,'(1X,5F15.6)')(VZERO(K,I),K=1,NZ) -C 394 CONTINUE -C WRITE(6,*)' NR OF NEW VECTORS SELECTED, NNEW:',NNEW - IF(NNEW.EQ.0) THEN - WRITE(6,*)' CONVERGENCE IN NORM.' - GOTO 2000 - END IF -C NOTE: A CHANGE HERE. ALWAYS USE ALL THE NRROOT UPDATED VECTORS TO -C AVOID OVERWRITING AN EARLY CONVERGED VECTOR (WHICH HAS NEVER BEEN -C OUTDATED BY A LATER) BY A VECTOR BELONGING TO ANOTHER ROOT. - NNEW=NRROOT -* ------------------------------------------------------------------- -C FORM NEW UPDATED VECTORS: SKIP THE FIRST NRROOT-NNEW VECTORS, -C WHICH MAKE NO ESSENTIAL IMPROVEMENT. -C WRITE(6,*)' RESET VZERO TO (0,0,0,1) FOR CONVENTIONAL DAVIDSON.' -C CALL DCOPY_(NRROOT*MXZ,[0.0D00],0,VZERO,1) -C CALL DCOPY_(NRROOT,[1.0D00],0,VZERO(3*NRROOT+1,1),MXZ+1) - CALL HZLP2(CBUF,SBUF,DBUF,CSECT,RSECT,XI1,XI2,CNEW,ICI) - IF(ITER.LT.MAXIT) GOTO 1000 - WRITE(6,*)' UNCONVERGED.' -2000 CONTINUE - WRITE(6,*)' ',('*',III=1,70) -C WRITE CI VECTORS TO LUREST -- CI RESTART FILE. - IDREST=0 - DO 2220 I=1,NRROOT - IVEC=1+MOD(NVTOT-NRROOT+I-1,MXVEC) - IDISK=IDISKC(IVEC) - DO 2210 ISTA=1,NCONF,MBUF - NN=MIN(MBUF,NCONF+1-ISTA) - CALL iDAFILE(LUEIG,2,ICI,NN,IDISK) - CALL UPKVEC(NN,ICI,CI(ISTA)) -2210 CONTINUE - CALL CSFTRA(' CSF',CI,AREF) - C2REF=0.0D00 - DO 2215 IR=1,NREF - ICSF=IREFX(IR) - C=CI(ICSF) - C2REF=C2REF+C**2 -2215 CONTINUE - IR=IROOT(I) - ECI=ESMALL(I)+ESHIFT - ENREF=ECI-EREF(IR) - C2NREF=1.0D00-C2REF -C WRITE ENERGIES TO PRINTED OUTPUT, AND SAVE TOTAL ENERGIES TO ENGY -C FOR LATER PRINTOUT WITH PROPERTIES: - WRITE(6,'(A,I3)')' FINAL RESULTS FOR STATE NR ',I - WRITE(6,'(A,I3)')' CORRESPONDING ROOT OF REFERENCE CI IS NR:',IR - WRITE(6,'(A,F15.8)')' REFERENCE CI ENERGY:',EREF(IR) - WRITE(6,'(A,F15.8)')' EXTRA-REFERENCE WEIGHT:',C2NREF - IF(ICPF.EQ.1) THEN - WRITE(6,'(A,F15.8)')' ACPF CORRELATION ENERGY:',ENREF - WRITE(6,'(A,F15.8)')' ACPF ENERGY:',ECI - ENGY(I,1)=ECI - ENGY(I,2)=0.0D00 - ENGY(I,3)=0.0D00 - Call Add_Info('E_MRACPF',[ECI],1,8) - ELSE - WRITE(6,'(A,F15.8)')' CI CORRELATION ENERGY:',ENREF - WRITE(6,'(A,F15.8)')' CI ENERGY:',ECI -C APPROXIMATE CORRECTIONS FOR UNLINKED QUADRUPLES: - QDAV=ENREF*C2NREF/C2REF - EDAV=ECI+QDAV - QACPF=ENREF*(C2NREF*(1.0D00-GFAC))/(C2REF+GFAC*C2NREF) - EACPF=ECI+QACPF - WRITE(6,'(A,F15.8)')' DAVIDSON CORRECTION:',QDAV - WRITE(6,'(A,F15.8)')' CORRECTED ENERGY:',EDAV - WRITE(6,'(A,F15.8)')' ACPF CORRECTION:',QACPF - WRITE(6,'(A,F15.8)')' CORRECTED ENERGY:',EACPF - ENGY(I,1)=ECI - ENGY(I,2)=QDAV - ENGY(I,3)=QACPF - Call Add_Info('E_MRSDCI',[ECI],1,8) - END IF - WRITE(6,*) -*PAM04 CALL PRWF_MRCI (HWORK(LCSPCK),HWORK(LINTSY),HWORK(LINDX), -*PAM04 & CI,HWORK(LJREFX) ) - CALL PRWF_MRCI (IWORK(LCSPCK),IWORK(LINTSY),IWORK(LINDX), - & CI,IWORK(LJREFX) ) - WRITE(6,*)' ',('*',III=1,70) - CALL dDAFILE(LUREST,1,CI,NCONF,IDREST) -2220 CONTINUE - Call XFlush(6) - RETURN - END diff -Nru openmolcas-22.02/src/mrci/faibj1.f openmolcas-22.10/src/mrci/faibj1.f --- openmolcas-22.02/src/mrci/faibj1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/faibj1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,229 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE LOOP70(INTSYM,INDX,C,S,ABIJ,AIBJ,AJBI,BUF, - * IBUF,A,B,F,FSEC,IPOF,IPOA,IPOB, - * MYL,NYL,INDA,INDB,INMY,INNY,IFTB,IFTA,FACS, - * IAB,CPL,CPLA, NVIRA,NVIRC,NVIRB) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "mrci.fh" -#include "WrkSpc.fh" - DIMENSION INTSYM(*),INDX(*),C(*),S(*), - * ABIJ(*),AIBJ(*),AJBI(*), - * BUF(NBITM3),IBUF(NBITM3+2), - * A(*),B(*),F(*),FSEC(*) - DIMENSION IPOF(9),IPOA(9),IPOB(9) - - - DO 70 IASYM=1,NSYM - IAB=IPOF(IASYM+1)-IPOF(IASYM) - IF(IAB.EQ.0)GO TO 70 - ICSYM=MUL(MYL,IASYM) - IBSYM=MUL(NYL,ICSYM) - IF(INDA.EQ.INDB.AND.IBSYM.GT.IASYM)GO TO 70 - NVIRC=NVIR(ICSYM) - IF(NVIRC.EQ.0)GO TO 70 - NVIRA=NVIR(IASYM) - NVIRB=NVIR(IBSYM) - IF(ICSYM.GE.IASYM)GO TO 31 - IF(ICSYM.GE.IBSYM)GO TO 32 -C CASE 1, IASYM > ICSYM AND IBSYM > ICSYM - IPF=IPOF(IASYM)+1 - CALL DYAX(IAB,CPL,AIBJ(IPF),1,F,1) - CALL DAXPY_(IAB,CPLA,ABIJ(IPF),1,F,1) - IF(INDA.EQ.INDB)CALL SETZZ(F,NVIRA) -C CALL FZERO(A,NBC) -C CALL FMMM(C(INMY+IPOA(IASYM)),F,A,NVIRC,NVIRB,NVIRA) -C CALL DAXPY_(NBC,FACS,A,1,S(INNY+IPOB(IBSYM)),1) - CALL DGEMM_('N','N',NVIRC,NVIRB,NVIRA, - * FACS,C(INMY+IPOA(IASYM)),NVIRC, - * F,NVIRA,1.0D00,S(INNY+IPOB(IBSYM)),NVIRC) - IF(INDA.EQ.INDB)GO TO 70 - IPF=IPOF(IBSYM)+1 - CALL FZERO(F,IAB) - CALL DYAX(IAB,CPL,AJBI(IPF),1,F,1) - CALL DAXPY_(IAB,CPLA,ABIJ(IPF),1,F,1) - CALL DGEMM_('N','N',NVIRC,NVIRA,NVIRB, - * FACS,C(INNY+IPOB(IBSYM)),NVIRC, - * F,NVIRB,1.0D00,S(INMY+IPOA(IASYM)),NVIRC) - GO TO 70 -C CASE 2, IASYM > ICSYM AND ICSYM > OR = IBSYM -32 IPF=IPOF(IBSYM)+1 - CALL DYAX(IAB,CPL,AJBI(IPF),1,F,1) - CALL DAXPY_(IAB,CPLA,ABIJ(IPF),1,F,1) -C - IF(NYL.EQ.1) THEN - CALL DGEMM_('N','T',NVIRB,NVIRC,NVIRA, - * FACS,F,NVIRB,C(INMY+IPOA(IASYM)),NVIRC, - * 0.D0,A,NVIRB) - IF(IFTB.EQ.1) THEN - CALL TRADD(A,S(INNY+IPOB(ICSYM)),NVIRB) - CALL SQUARN(C(INNY+IPOB(IBSYM)),A,NVIRB) - ELSE - CALL SIADD(A,S(INNY+IPOB(ICSYM)),NVIRB) - CALL SQUAR(C(INNY+IPOB(IBSYM)),A,NVIRB) - ENDIF - CALL DGEMM_('N','N',NVIRC,NVIRA,NVIRB, - * FACS,A,NVIRC,F,NVIRB, - * 1.D0,S(INMY+IPOA(IASYM)),NVIRC) - ELSE - FACSX=FACS - IF(IFTB.EQ.1) FACSX=-FACS - CALL DGEMM_('N','T',NVIRB,NVIRC,NVIRA, - * FACSX,F,NVIRB,C(INMY+IPOA(IASYM)),NVIRC, - * 1.D0,S(INNY+IPOB(ICSYM)),NVIRB) - CALL DGEMM_('T','N',NVIRC,NVIRA,NVIRB, - * FACSX,C(INNY+IPOB(ICSYM)),NVIRB,F,NVIRB, - * 1.D0,S(INMY+IPOA(IASYM)),NVIRC) - ENDIF - GO TO 70 -C UPDATED UNTIL HERE -31 IF(ICSYM.GE.IBSYM)GO TO 33 -C CASE 3, ICSYM > OR = IASYM AND IBSYM > ICSYM - IPF=IPOF(IASYM)+1 - CALL DYAX(IAB,CPL,AIBJ(IPF),1,F,1) - CALL DAXPY_(IAB,CPLA,ABIJ(IPF),1,F,1) - IF(MYL.EQ.1) THEN - IF(IFTA.EQ.0)CALL SQUAR(C(INMY+IPOA(IASYM)),A,NVIRA) - IF(IFTA.EQ.1)CALL SQUARN(C(INMY+IPOA(IASYM)),A,NVIRA) - CALL DGEMM_('N','N',NVIRC,NVIRB,NVIRA, - * FACS,A,NVIRC,F,NVIRA, - * 1.D0,S(INNY+IPOB(IBSYM)),NVIRC) - CALL DGEMM_('N','T',NVIRA,NVIRC,NVIRB, - * FACS,F,NVIRA,C(INNY+IPOB(IBSYM)),NVIRC, - * 0.D0,A,NVIRA) - IF(IFTA.EQ.0) CALL SIADD(A,S(INMY+IPOA(IASYM)),NVIRA) - IF(IFTA.EQ.1) CALL TRADD(A,S(INMY+IPOA(IASYM)),NVIRA) - ELSE - FACSX=FACS - IF(IFTA.EQ.1) FACSX=-FACS - CALL DGEMM_('T','N',NVIRC,NVIRB,NVIRA, - * FACSX,C(INMY+IPOA(ICSYM)),NVIRA,F,NVIRA, - * 1.D0,S(INNY+IPOB(IBSYM)),NVIRC) - CALL DGEMM_('N','T',NVIRA,NVIRC,NVIRB, - * FACSX,F,NVIRA,C(INNY+IPOB(IBSYM)),NVIRC, - * 1.D0,S(INMY+IPOA(ICSYM)),NVIRA) - ENDIF - GO TO 70 -C CASE 4, ICSYM > OR = IASYM AND ICSYM > OR = IBSYM -33 IPF=IPOF(IBSYM)+1 - CALL DYAX(IAB,CPL,AJBI(IPF),1,F,1) - CALL DAXPY_(IAB,CPLA,ABIJ(IPF),1,F,1) - IF(INDA.EQ.INDB)CALL SETZZ(F,NVIRA) - IF(MYL.EQ.1.AND.NYL.EQ.1) THEN -C - IF(IFTA.EQ.0) CALL SQUAR(C(INMY+IPOA(IASYM)),A,NVIRA) - IF(IFTA.EQ.1) CALL SQUARM(C(INMY+IPOA(IASYM)),A,NVIRA) - CALL DGEMM_('N','N',NVIRB,NVIRC,NVIRA, - * FACS,F,NVIRB,A,NVIRA, - * 0.D0,B,NVIRB) - IF(IFTB.EQ.0) CALL SIADD(B,S(INNY+IPOB(ICSYM)),NVIRB) - IF(IFTB.EQ.1) CALL TRADD(B,S(INNY+IPOB(ICSYM)),NVIRB) -C - ELSE IF (MYL.EQ.1.AND.NYL.NE.1) THEN - IF(IFTA.EQ.0) CALL SQUAR(C(INMY+IPOA(IASYM)),A,NVIRA) - IF(IFTA.EQ.1) CALL SQUARM(C(INMY+IPOA(IASYM)),A,NVIRA) - FACSX=FACS - IF(IFTB.EQ.1) FACSX=-FACS - CALL DGEMM_('N','N',NVIRB,NVIRC,NVIRA, - * FACSX,F,NVIRB,A,NVIRA, - * 1.D0,S(INNY+IPOB(ICSYM)),NVIRB) -C - ELSE IF (MYL.NE.1.AND.NYL.EQ.1) THEN -C - FACSX=FACS - IF(IFTA.EQ.1) FACSX=-FACS - CALL DGEMM_('N','N',NVIRB,NVIRC,NVIRA, - * FACSX,F,NVIRB,C(INMY+IPOA(ICSYM)),NVIRA, - * 0.D0,B,NVIRB) - IF(IFTB.EQ.0) CALL SIADD(B,S(INNY+IPOB(ICSYM)),NVIRB) - IF(IFTB.EQ.1) CALL TRADD(B,S(INNY+IPOB(ICSYM)),NVIRB) - ELSE IF (MYL.NE.1.AND.NYL.NE.1) THEN - FACSX=FACS - IF(IFTA+IFTB.EQ.1) FACSX=-FACS - CALL DGEMM_('N','N',NVIRB,NVIRC,NVIRA, - * FACSX,F,NVIRB,C(INMY+IPOA(ICSYM)),NVIRA, - * 1.D0,S(INNY+IPOB(ICSYM)),NVIRB) - ENDIF - IF(INDA.EQ.INDB)GO TO 70 - IPF=IPOF(IASYM)+1 - CALL DYAX(IAB,CPL,AIBJ(IPF),1,F,1) - CALL DAXPY_(IAB,CPLA,ABIJ(IPF),1,F,1) -C - IF(NYL.EQ.1.AND.MYL.EQ.1) THEN -C - IF(IFTB.EQ.0) CALL SQUAR(C(INNY+IPOB(IBSYM)),A,NVIRB) - IF(IFTB.EQ.1) CALL SQUARM(C(INNY+IPOB(IBSYM)),A,NVIRB) - CALL DGEMM_('N','N',NVIRA,NVIRC,NVIRB, - * FACS,F,NVIRA,A,NVIRB, - * 0.D0,B,NVIRA) - IF(IFTA.EQ.0) CALL SIADD(B,S(INMY+IPOA(ICSYM)),NVIRA) - IF(IFTA.EQ.1) CALL TRADD(B,S(INMY+IPOA(ICSYM)),NVIRA) -C - ELSE IF (NYL.EQ.1.AND.MYL.NE.1) THEN - IF(IFTB.EQ.0) CALL SQUAR(C(INNY+IPOB(ICSYM)),A,NVIRB) - IF(IFTB.EQ.1) CALL SQUARM(C(INNY+IPOB(ICSYM)),A,NVIRB) - FACSX=FACS - IF(IFTA.EQ.1) FACSX=-FACS - CALL DGEMM_('N','N',NVIRA,NVIRC,NVIRB, - * FACSX,F,NVIRA,A,NVIRB, - * 1.D0,S(INMY+IPOA(ICSYM)),NVIRA) -C - ELSE IF (NYL.NE.1.AND.MYL.EQ.1) THEN -C - FACSX=FACS - IF(IFTB.EQ.1) FACSX=-FACS - CALL DGEMM_('N','N',NVIRA,NVIRC,NVIRB, - * FACSX,F,NVIRA,C(INNY+IPOB(ICSYM)),NVIRB, - * 0.D0,B,NVIRA) - IF(IFTA.EQ.0) CALL SIADD(B,S(INMY+IPOA(ICSYM)),NVIRA) - IF(IFTA.EQ.1) CALL TRADD(B,S(INMY+IPOA(ICSYM)),NVIRA) -C - ELSE IF (NYL.NE.1.AND.MYL.NE.1) THEN -C - FACSX=FACS - IF(IFTA+IFTB.EQ.1) FACSX=-FACS - CALL DGEMM_('N','N',NVIRA,NVIRC,NVIRB, - * FACSX,F,NVIRA,C(INNY+IPOB(ICSYM)),NVIRB, - * 1.D0,S(INMY+IPOA(ICSYM)),NVIRA) - ENDIF -C -70 CONTINUE - RETURN -c Avoid unused argument warnings - IF (.FALSE.) THEN - CALL Unused_integer_array(INTSYM) - CALL Unused_integer_array(INDX) - CALL Unused_integer_array(IBUF) - CALL Unused_real_array(FSEC) - CALL Unused_real_array(BUF) - END IF - END - subroutine faibj5(LENBUF,JTURN,IBUF,BUF, AIBJ,ABIJ) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "mrci.fh" -#include "WrkSpc.fh" - DIMENSION ABIJ(NVSQ),AIBJ(NVSQ), - * BUF(NBITM3),IBUF(NBITM3+2) - IF(LENBUF.GT.0) THEN - IF(JTURN.EQ.1) THEN - do i=1,LENBUF - aibj(IBUF(i))=buf(i) - enddo - ELSE - do i=1,LENBUF - abij(IBUF(i))=buf(i) - enddo - END IF - END IF - return - end diff -Nru openmolcas-22.02/src/mrci/faibj2.f openmolcas-22.10/src/mrci/faibj2.f --- openmolcas-22.02/src/mrci/faibj2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/faibj2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine faibj2(IFTA,IFTB,ICOUP1,ICOUP, - & INDA,INDB,MYSYM,INTSYM, - & NYSYM,NSIJ,MYL,NYL,FACS,IPOA,IPOB, - & INMY,INNY,INDX,iTYP) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "mrci.fh" - DIMENSION INTSYM(*),INDX(*) - DIMENSION IPOA(9),IPOB(9) - - IFTA=0 - IFTB=0 -c GO TO (109,110,111,112,113),ITYP - IF(ITYP.eq.1) then - INDA=IRC(2)+ICOUP1 - INDB=IRC(2)+ICOUP - IFTA=1 - IFTB=1 - endif - if(ITYP.eq.2) then - INDA=IRC(3)+ICOUP1 - INDB=IRC(3)+ICOUP - endif - if(ITYP.eq.3) then - INDA=IRC(2)+ICOUP1 - INDB=IRC(3)+ICOUP - IFTA=1 - endif - if(ITYP.eq.4) then - INDA=IRC(3)+ICOUP1 - INDB=IRC(2)+ICOUP - IFTB=1 - endif - if(ITYP.eq.5) then - INDA=IRC(1)+ICOUP1 - INDB=IRC(1)+ICOUP - endif -cvv : unroll inline function to make GCC compiler works proper.. - MYSYM=JSUNP(INTSYM,INDA) - NYSYM=MUL(MYSYM,NSIJ) - MYL=MUL(MYSYM,LSYM) - NYL=MUL(NYSYM,LSYM) - FACS=1.0D00 - CALL IPO(IPOA,NVIR,MUL,NSYM,MYL,IFTA) - CALL IPO(IPOB,NVIR,MUL,NSYM,NYL,IFTB) - INMY=INDX(INDA)+1 - INNY=INDX(INDB)+1 - return - end diff -Nru openmolcas-22.02/src/mrci/faibj2.F90 openmolcas-22.10/src/mrci/faibj2.F90 --- openmolcas-22.02/src/mrci/faibj2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/faibj2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,61 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine faibj2(IFTA,IFTB,ICOUP1,ICOUP,INDA,INDB,MYSYM,INTSYM,NYSYM,NSIJ,MYL,NYL,FACS,IPOA,IPOB,INMY,INNY,INDX,iTYP) + +use mrci_global, only: IRC, LSYM, NSYM, NVIR +use Symmetry_Info, only: Mul +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(out) :: IFTA, IFTB, INDA, INDB, MYSYM, NYSYM, MYL, NYL, IPOA(9), IPOB(9), INMY, INNY +integer(kind=iwp), intent(in) :: ICOUP1, ICOUP, INTSYM(*), NSIJ, INDX(*), iTYP +real(kind=wp) :: FACS +integer(kind=iwp), external :: JSUNP + +IFTA = 0 +IFTB = 0 +select case (ITYP) + case (1) + INDA = IRC(2)+ICOUP1 + INDB = IRC(2)+ICOUP + IFTA = 1 + IFTB = 1 + case (2) + INDA = IRC(3)+ICOUP1 + INDB = IRC(3)+ICOUP + case (3) + INDA = IRC(2)+ICOUP1 + INDB = IRC(3)+ICOUP + IFTA = 1 + case (4) + INDA = IRC(3)+ICOUP1 + INDB = IRC(2)+ICOUP + IFTB = 1 + case (5) + INDA = IRC(1)+ICOUP1 + INDB = IRC(1)+ICOUP +end select +!vv : unroll inline function to make GCC compiler works proper.. +MYSYM = JSUNP(INTSYM,INDA) +NYSYM = MUL(MYSYM,NSIJ) +MYL = MUL(MYSYM,LSYM) +NYL = MUL(NYSYM,LSYM) +FACS = One +call IPO(IPOA,NVIR,MUL,NSYM,MYL,IFTA) +call IPO(IPOB,NVIR,MUL,NSYM,NYL,IFTB) +INMY = INDX(INDA)+1 +INNY = INDX(INDB)+1 + +return + +end subroutine faibj2 diff -Nru openmolcas-22.02/src/mrci/faibj3.f openmolcas-22.10/src/mrci/faibj3.f --- openmolcas-22.02/src/mrci/faibj3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/faibj3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,52 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - subroutine faibj3(NSIJ,IFT, - & AIBJ,FSEC,FAC,IN,INS,IPOA,IPOF) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "mrci.fh" - DIMENSION IPOF(9),IPOA(9), - & AIBJ(*),FSEC(*) - CALL IPO(IPOA,NVIR,MUL,NSYM,NSIJ,IFT) -C INTEGRAL COMBINATION APPROPRIATE FOR SINGLET-COUPLING: - DO 170 IASYM=1,NSYM - IBSYM=MUL(NSIJ,IASYM) - IF(IBSYM.GT.IASYM)GO TO 170 - IAB=IPOA(IASYM+1)-IPOA(IASYM) - IF(IAB.EQ.0)GO TO 170 - IF(NSIJ.EQ.1) THEN - CALL SECEQ(AIBJ(IPOF(IASYM)+1),AIBJ(IPOF(IBSYM)+1), - * FSEC(IN+1),NVIR(IASYM),0,FAC) - ELSE - CALL SECNE(AIBJ(IPOF(IASYM)+1),AIBJ(IPOF(IBSYM)+1), - * FSEC(IN+1),NVIR(IASYM),NVIR(IBSYM),NSIJ,0) - END IF - IN=IN+IAB -170 CONTINUE - INS=IN -C INTEGRAL COMBINATION APPROPRIATE FOR TRIPLET-COUPLING: - DO 180 IASYM=1,NSYM - IBSYM=MUL(NSIJ,IASYM) - IF(IBSYM.GT.IASYM)GO TO 180 - IAB=IPOA(IASYM+1)-IPOA(IASYM) - IF(IAB.EQ.0)GO TO 180 - IF(NSIJ.EQ.1) THEN - - CALL SECEQ(AIBJ(IPOF(IASYM)+1),AIBJ(IPOF(IBSYM)+1), - * FSEC(IN+1),NVIR(IASYM),1,DUMMY) - ELSE - CALL SECNE(AIBJ(IPOF(IASYM)+1),AIBJ(IPOF(IBSYM)+1), - * FSEC(IN+1),NVIR(IASYM),NVIR(IBSYM),NSIJ,1) - END IF - IN=IN+IAB -180 CONTINUE - return - end diff -Nru openmolcas-22.02/src/mrci/faibj3.F90 openmolcas-22.10/src/mrci/faibj3.F90 --- openmolcas-22.02/src/mrci/faibj3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/faibj3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,59 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine faibj3(NSIJ,IFT,AIBJ,FSEC,FAC,IIN,INS,IPOA,IPOF) + +use mrci_global, only: NSYM, NVIR +use Symmetry_Info, only: Mul +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: NSIJ, IFT, IPOF(9) +real(kind=wp), intent(in) :: AIBJ(*), FAC +real(kind=wp), intent(_OUT_) :: FSEC(*) +integer(kind=iwp), intent(inout) :: IIN +integer(kind=iwp), intent(out) :: INS, IPOA(9) +integer(kind=iwp) :: IAB, IASYM, IBSYM + +call IPO(IPOA,NVIR,MUL,NSYM,NSIJ,IFT) +! INTEGRAL COMBINATION APPROPRIATE FOR SINGLET-COUPLING: +do IASYM=1,NSYM + IBSYM = MUL(NSIJ,IASYM) + if (IBSYM > IASYM) cycle + IAB = IPOA(IASYM+1)-IPOA(IASYM) + if (IAB == 0) cycle + if (NSIJ == 1) then + call SECEQ(AIBJ(IPOF(IASYM)+1),AIBJ(IPOF(IBSYM)+1),FSEC(IIN+1),NVIR(IASYM),0,FAC) + else + call SECNE(AIBJ(IPOF(IASYM)+1),AIBJ(IPOF(IBSYM)+1),FSEC(IIN+1),NVIR(IASYM),NVIR(IBSYM),0) + end if + IIN = IIN+IAB +end do +INS = IIN +! INTEGRAL COMBINATION APPROPRIATE FOR TRIPLET-COUPLING: +do IASYM=1,NSYM + IBSYM = MUL(NSIJ,IASYM) + if (IBSYM > IASYM) cycle + IAB = IPOA(IASYM+1)-IPOA(IASYM) + if (IAB == 0) cycle + if (NSIJ == 1) then + call SECEQ(AIBJ(IPOF(IASYM)+1),AIBJ(IPOF(IBSYM)+1),FSEC(IIN+1),NVIR(IASYM),1,FAC) + else + call SECNE(AIBJ(IPOF(IASYM)+1),AIBJ(IPOF(IBSYM)+1),FSEC(IIN+1),NVIR(IASYM),NVIR(IBSYM),1) + end if + IIN = IIN+IAB +end do + +return + +end subroutine faibj3 diff -Nru openmolcas-22.02/src/mrci/faibj5.F90 openmolcas-22.10/src/mrci/faibj5.F90 --- openmolcas-22.02/src/mrci/faibj5.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/faibj5.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,37 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine faibj5(LENBUF,JTURN,IBUF,BUF,AIBJ,ABIJ) + +use mrci_global, only: NBITM3, NVSQ +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: LENBUF, JTURN, IBUF(NBITM3+2) +real(kind=wp), intent(in) :: BUF(NBITM3) +real(kind=wp), intent(inout) :: ABIJ(NVSQ), AIBJ(NVSQ) +integer(kind=iwp) :: i + +if (LENBUF > 0) then + if (JTURN == 1) then + do i=1,LENBUF + aibj(IBUF(i)) = buf(i) + end do + else + do i=1,LENBUF + abij(IBUF(i)) = buf(i) + end do + end if +end if + +return + +end subroutine faibj5 diff -Nru openmolcas-22.02/src/mrci/faibj.f openmolcas-22.10/src/mrci/faibj.f --- openmolcas-22.02/src/mrci/faibj.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/faibj.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,219 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE FAIBJ(INTSYM,INDX,C,S,ABIJ,AIBJ,AJBI,A,B,F,FSEC) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "mrci.fh" -#include "WrkSpc.fh" - DIMENSION INTSYM(*),INDX(*),C(*),S(*), - * ABIJ(*),AIBJ(*),AJBI(*), - * A(*),B(*),F(*),FSEC(*) - DIMENSION IPOF(9),IPOA(9),IPOB(9) - External JSUNP -*------ - CALL GETMEM('BUF','ALLO','REAL',LBUF,NBITM3) - CALL GETMEM('IBUF','ALLO','INTE',LIBUF,NBITM3+2) -c -cvv this code is a real compiler killer! -c -* POW: Unnecessary but warningstopping initializations - iTyp=-1234567 - iCoup=-1234567 - iCoup1=-1234567 -c call getmem('test','chec','real',ldum,ndum) -*------ - CALL CSCALE(INDX,INTSYM,C,SQ2) - CALL CSCALE(INDX,INTSYM,S,SQ2INV) - ICHK=0 - IFAB=0 - NOVST=LN*NVIRT+1+(NVIRT*(NVIRT+1))/2 - NOT2=IROW(LN+1) -* - IADD10=IAD10(6) - -* Long loop, reading buffers until end of buffers is signalled -* by length field holding a negative number. - 300 CONTINUE - CALL dDAFILE(LUSYMB,2,COP,nCOP,IADD10) - CALL iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) - LENCOP=ICOP1(nCOP+1) - IF(LENCOP.EQ.0)GO TO 300 - IF(LENCOP.LT.0)GO TO 350 - -* Loop over the elements of this buffer - DO 260 II=1,LENCOP - INDCOP=ICOP1(II) - IF(ICHK.NE.0)GO TO 460 - IF(INDCOP.NE.0)GO TO 371 - ICHK=1 - GO TO 260 - -460 ICHK=0 - -* Unpack indices NI and NJ from INDCOP - INDI=INDCOP -* NI=MOD(INDI,2**10) -* NJ=MOD(INDI/2**10,2**10) - NI=IBITS(INDI, 0,10) - NJ=IBITS(INDI,10,10) - - NSIJ=MUL(NSM(NI),NSM(NJ)) - CALL IPO(IPOF,NVIR,MUL,NSYM,NSIJ,-1) - IJ1=IROW(NI)+NJ - ILIM=IPOF(NSYM+1) -* Clear matrices ABIJ, AIBJ, and AJBI. - CALL FZERO(ABIJ,ILIM) - CALL FZERO(AIBJ,ILIM) - CALL FZERO(AJBI,ILIM) - IF(ITER.EQ.1 .AND. IREST.EQ.0)GO TO 207 -* -* READ (AB/IJ) INTEGRALS -* - IADR=LASTAD(NOVST+IJ1) - JTURN=0 - 201 CONTINUE - - CALL iDAFILE(Lu_60,2,iWORK(LIBUF),NBITM3+2,IADR) - CALL dDAFILE(Lu_60,2,WORK(LBUF),NBITM3,IADR) - LENBUF=iWORK(LIBUF+NBITM3) - IADR=iWORK(LIBUF+NBITM3+1) - call faibj5(LENBUF,JTURN,iWORK(LIBUF),WORK(LBUF), AIBJ,ABIJ) - - IF(IADR.NE.-1) GO TO 201 - IF(JTURN.EQ.1)GO TO 360 -* -* READ (AI/BJ) INTEGRALS -* -207 IADR=LASTAD(NOVST+NOT2+IJ1) - JTURN=1 - GO TO 201 -* -* CONSTRUCT FIRST ORDER MATRICES -* -360 FAC=1.0D00 - IF(NI.EQ.NJ)FAC=0.5D00 - IN=0 -c VV: these calls to getmem are needed to cheat some compilers. - - if (FAC.lt.0) call getmem('CHECK','CHEC','real',0,0) - - IFT=0 - call faibj3(NSIJ,IFT,AIBJ,FSEC,FAC,IN,INS,IPOA,IPOF) - - - IF(ITER.EQ.1 .AND. IREST.EQ.0)GO TO 260 - DO 370 IASYM=1,NSYM - NVIRA=NVIR(IASYM) - IF(NVIRA.EQ.0)GO TO 370 - IBSYM=MUL(NSIJ,IASYM) - NVIRB=NVIR(IBSYM) - IF(NVIRB.EQ.0)GO TO 370 - IPF=IPOF(IASYM)+1 - IPF1=IPOF(IBSYM)+1 - IF(IASYM.GT.IBSYM) THEN - CALL MTRANS(AIBJ(IPF1),1,AJBI(IPF),1,NVIRA,NVIRB) - GOTO 370 - END IF - IF(NSIJ.NE.1) THEN - CALL MTRANS(ABIJ(IPF1),1,ABIJ(IPF),1,NVIRA,NVIRB) - CALL MTRANS(AIBJ(IPF1),1,AJBI(IPF),1,NVIRA,NVIRB) - ELSE - CALL SQUAR2(ABIJ(IPF),NVIRA) - IF(NI.EQ.NJ) CALL SQUAR2(AIBJ(IPF),NVIRA) - CALL MTRANS(AIBJ(IPF),1,AJBI(IPF),1,NVIRA,NVIRB) - END IF -370 CONTINUE - GO TO 260 -371 CONTINUE - IF(IFAB.EQ.1) THEN - CPLA=COP(II) - IFAB=0 - GO TO 100 - END IF -* IFAB=MOD(INDCOP,2) -* ITURN=MOD(INDCOP/2,2) -* ITYP=MOD(INDCOP/2**2,2**3) -* ICOUP=MOD(INDCOP/2**5,2**13) -* ICOUP1=MOD(INDCOP/2**18,2**13) - IFAB=IBITS(INDCOP, 0, 1) - ITURN=IBITS(INDCOP, 1, 1) - ITYP=IBITS(INDCOP, 2, 3) - ICOUP=IBITS(INDCOP, 5,13) - ICOUP1=IBITS(INDCOP,18,13) - CPL=COP(II) - CPLA=0.0D00 - IF(IFAB.NE.0)GO TO 260 - IF(ITURN.NE.0) GOTO 100 -C FIRST ORDER INTERACTION - INDA=ICOUP - INDB=IRC(ITYP+1)+ICOUP1 - ISTAR=1 - IF(ITYP.EQ.1)ISTAR=INS+1 - IF(INS.NE.0) THEN - COPI=CPL*C(INDA) - CALL DAXPY_(INS,COPI,FSEC(ISTAR),1,S(INDX(INDB)+1),1) - TERM=DDOT_(INS,FSEC(ISTAR),1,C(INDX(INDB)+1),1) - S(INDA)=S(INDA)+CPL*TERM - END IF - GO TO 260 - -C INTERACTIONS BETWEEN DOUBLES AND -C INTERACTIONS BETWEEN SINGLES -100 IF((ITER.EQ.1).AND.(IREST.EQ.0))GO TO 260 - - Call faibj2(IFTA,IFTB,ICOUP1,ICOUP, - & INDA,INDB,MYSYM,INTSYM, - & NYSYM,NSIJ,MYL,NYL,FACS,IPOA,IPOB, - & INMY,INNY,INDX,iTYP) - - - - - IF(ITYP.NE.5)GO TO 71 -C DOUBLET-DOUBLET INTERACTIONS - IN=IPOF(MYL+1)-IPOF(MYL) - IF(IN.EQ.0)GO TO 260 - IPF=IPOF(MYL)+1 - CALL DYAX(IN,CPL,AIBJ(IPF),1,F,1) - CALL DAXPY_(IN,CPLA,ABIJ(IPF),1,F,1) - IF(INDA.EQ.INDB)CALL SETZZ(F,NVIR(MYL)) -* CALL DGEMTX (NVIR(MYL),NVIR(NYL),FACS,F,NVIR(MYL), -* * C(INMY),1,S(INNY),1) - CALL DGEMV_('T',NVIR(MYL),NVIR(NYL),FACS,F,NVIR(MYL), - * C(INMY),1,1.0D0,S(INNY),1) - IF(INDA.NE.INDB) THEN -* CALL DGEMX (NVIR(MYL),NVIR(NYL),FACS,F,NVIR(MYL), -* * C(INNY),1,S(INMY),1) - CALL DGEMV_('N',NVIR(MYL),NVIR(NYL),FACS,F,NVIR(MYL), - * C(INNY),1,1.0D0,S(INMY),1) - END IF - GO TO 260 -C TRIPLET-SINGLET, SINGLET-TRIPLET, -C TRIPLET-TRIPLET AND SINGLET-SINGLET INTERACTIONS -71 CONTINUE - - call loop70(INTSYM,INDX,C,S,ABIJ,AIBJ,AJBI,WORK(LBUF), - * iWORK(LIBUF),A,B,F,FSEC,IPOF,IPOA,IPOB, - * MYL,NYL,INDA,INDB,INMY,INNY,IFTB,IFTA,FACS, - * IAB,CPL,CPLA, NVIRA,NVIRC,NVIRB) - - -260 CONTINUE - GO TO 300 - -350 CONTINUE - CALL CSCALE(INDX,INTSYM,C,SQ2INV) - CALL CSCALE(INDX,INTSYM,S,SQ2) - CALL GETMEM('BUF','FREE','REAL',LBUF,NBITM3) - CALL GETMEM('IBUF','FREE','INTE',LIBUF,NBITM3+2) - - RETURN - END diff -Nru openmolcas-22.02/src/mrci/faibj.F90 openmolcas-22.10/src/mrci/faibj.F90 --- openmolcas-22.02/src/mrci/faibj.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/faibj.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,212 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine FAIBJ(INTSYM,INDX,C,S,ABIJ,AIBJ,AJBI,A,B,F,FSEC) + +use mrci_global, only: IRC, IREST, IROW, ITER, LASTAD, LN, Lu_60, LUSYMB, NBITM3, NSM, NSYM, NVIR, NVIRT, SQ2, SQ2INV +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Half +use Definitions, only: wp, iwp, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: INTSYM(*), INDX(*) +real(kind=wp), intent(inout) :: C(*), S(*), ABIJ(*), AIBJ(*), AJBI(*), FSEC(*) +real(kind=wp), intent(_OUT_) :: A(*), B(*), F(*) +integer(kind=iwp) :: IAB, IADD10, IADR, IASYM, IBSYM, ICHK, iCoup, iCoup1, IFAB, IFT, IFTA, IFTB, II, IIN, IJ1, ILIM, INDA, INDB, & + INDCOP, INDI, INMY, INNY, INS, IPF, IPF1, IPOA(9), IPOB(9), IPOF(9), ISTAR, ITURN, iTyp, JTURN, LENBUF, & + LENCOP, MYL, MYSYM, NI, NJ, NOT2, NOVST, NSIJ, NVIRA, NVIRB, NVIRC, NYL, NYSYM +real(kind=wp) :: COPI, CPL, CPLA, FAC, FACS, TERM +integer(kind=iwp), allocatable :: iBuf(:) +real(kind=wp), allocatable :: Buf(:) +logical(kind=iwp) :: Skip +real(kind=r8), external :: DDOT_ + +call mma_allocate(Buf,NBITM3,label='Buf') +call mma_allocate(iBuf,NBITM3+2,label='iBuf') + +!vv this code is a real compiler killer! + +! POW: Unnecessary but warningstopping initializations +iTyp = -1234567 +iCoup = -1234567 +iCoup1 = -1234567 + +call CSCALE(INDX,INTSYM,C,SQ2) +call CSCALE(INDX,INTSYM,S,SQ2INV) +ICHK = 0 +IFAB = 0 +NOVST = LN*NVIRT+1+(NVIRT*(NVIRT+1))/2 +NOT2 = IROW(LN+1) + +IADD10 = IAD10(6) + +! Long loop, reading buffers until end of buffers is signalled +! by length field holding a negative number. +do + call dDAFILE(LUSYMB,2,COP,nCOP,IADD10) + call iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) + LENCOP = ICOP1(nCOP+1) + if (LENCOP < 0) exit + + ! Loop over the elements of this buffer + do II=1,LENCOP + INDCOP = ICOP1(II) + if (ICHK == 0) then + if (INDCOP == 0) then + ICHK = 1 + else + if (IFAB == 1) then + CPLA = COP(II) + IFAB = 0 + else + IFAB = ibits(INDCOP,0,1) + ITURN = ibits(INDCOP,1,1) + ITYP = ibits(INDCOP,2,3) + ICOUP = ibits(INDCOP,5,13) + ICOUP1 = ibits(INDCOP,18,13) + CPL = COP(II) + CPLA = Zero + if (IFAB /= 0) cycle + if (ITURN == 0) then + ! FIRST ORDER INTERACTION + INDA = ICOUP + INDB = IRC(ITYP+1)+ICOUP1 + ISTAR = 1 + if (ITYP == 1) ISTAR = INS+1 + if (INS /= 0) then + COPI = CPL*C(INDA) + S(INDX(INDB)+1:INDX(INDB)+INS) = S(INDX(INDB)+1:INDX(INDB)+INS)+COPI*FSEC(ISTAR:ISTAR+INS-1) + TERM = DDOT_(INS,FSEC(ISTAR),1,C(INDX(INDB)+1),1) + S(INDA) = S(INDA)+CPL*TERM + end if + cycle + end if + end if + + ! INTERACTIONS BETWEEN DOUBLES AND + ! INTERACTIONS BETWEEN SINGLES + if ((ITER /= 1) .or. (IREST /= 0)) then + + call faibj2(IFTA,IFTB,ICOUP1,ICOUP,INDA,INDB,MYSYM,INTSYM,NYSYM,NSIJ,MYL,NYL,FACS,IPOA,IPOB,INMY,INNY,INDX,iTYP) + + if (ITYP == 5) then + ! DOUBLET-DOUBLET INTERACTIONS + IIN = IPOF(MYL+1)-IPOF(MYL) + if (IIN /= 0) then + IPF = IPOF(MYL)+1 + F(1:IIN) = CPL*AIBJ(IPF:IPF+IIN-1)+CPLA*ABIJ(IPF:IPF+IIN-1) + if (INDA == INDB) call DCOPY_(NVIR(MYL),[Zero],0,F,NVIR(MYL)+1) + call DGEMV_('T',NVIR(MYL),NVIR(NYL),FACS,F,NVIR(MYL),C(INMY),1,One,S(INNY),1) + if (INDA /= INDB) then + call DGEMV_('N',NVIR(MYL),NVIR(NYL),FACS,F,NVIR(MYL),C(INNY),1,One,S(INMY),1) + end if + end if + else + ! TRIPLET-SINGLET, SINGLET-TRIPLET, + ! TRIPLET-TRIPLET AND SINGLET-SINGLET INTERACTIONS + + call loop70(C,S,ABIJ,AIBJ,AJBI,A,B,F,IPOF,IPOA,IPOB,MYL,NYL,INDA,INDB,INMY,INNY,IFTB,IFTA,FACS,IAB,CPL,CPLA,NVIRA, & + NVIRC,NVIRB) + + end if + end if + end if + else + ICHK = 0 + + ! Unpack indices NI and NJ from INDCOP + INDI = INDCOP + NI = ibits(INDI,0,10) + NJ = ibits(INDI,10,10) + + NSIJ = MUL(NSM(NI),NSM(NJ)) + call IPO(IPOF,NVIR,MUL,NSYM,NSIJ,-1) + IJ1 = IROW(NI)+NJ + ILIM = IPOF(NSYM+1) + ! Clear matrices ABIJ, AIBJ, and AJBI. + ABIJ(1:ILIM) = Zero + AIBJ(1:ILIM) = Zero + AJBI(1:ILIM) = Zero + if ((ITER == 1) .and. (IREST == 0)) then + Skip = .true. + else + ! READ (AB/IJ) INTEGRALS + + IADR = LASTAD(NOVST+IJ1) + JTURN = 0 + Skip = .false. + end if + do + if (Skip) then + Skip = .false. + else + call iDAFILE(Lu_60,2,iBuf,NBITM3+2,IADR) + call dDAFILE(Lu_60,2,Buf,NBITM3,IADR) + LENBUF = iBuf(NBITM3+1) + IADR = iBuf(NBITM3+2) + call faibj5(LENBUF,JTURN,iBuf,Buf,AIBJ,ABIJ) + + if (IADR /= -1) cycle + if (JTURN == 1) exit + end if + + ! READ (AI/BJ) INTEGRALS + + IADR = LASTAD(NOVST+NOT2+IJ1) + JTURN = 1 + end do + + ! CONSTRUCT FIRST ORDER MATRICES + + FAC = One + if (NI == NJ) FAC = Half + IIN = 0 + + IFT = 0 + call faibj3(NSIJ,IFT,AIBJ,FSEC,FAC,IIN,INS,IPOA,IPOF) + + if ((ITER /= 1) .or. (IREST /= 0)) then + do IASYM=1,NSYM + NVIRA = NVIR(IASYM) + if (NVIRA == 0) cycle + IBSYM = MUL(NSIJ,IASYM) + NVIRB = NVIR(IBSYM) + if (NVIRB == 0) cycle + IPF = IPOF(IASYM)+1 + IPF1 = IPOF(IBSYM)+1 + if (IASYM > IBSYM) then + call MTRANS(AIBJ(IPF1),AJBI(IPF),NVIRA,NVIRB) + else if (NSIJ /= 1) then + call MTRANS(ABIJ(IPF1),ABIJ(IPF),NVIRA,NVIRB) + call MTRANS(AIBJ(IPF1),AJBI(IPF),NVIRA,NVIRB) + else + call SQUAR2(ABIJ(IPF),NVIRA) + if (NI == NJ) call SQUAR2(AIBJ(IPF),NVIRA) + call MTRANS(AIBJ(IPF),AJBI(IPF),NVIRA,NVIRB) + end if + end do + end if + end if + end do +end do + +call CSCALE(INDX,INTSYM,C,SQ2INV) +call CSCALE(INDX,INTSYM,S,SQ2) +call mma_deallocate(Buf) +call mma_deallocate(iBuf) + +return + +end subroutine FAIBJ diff -Nru openmolcas-22.02/src/mrci/fijd.f openmolcas-22.10/src/mrci/fijd.f --- openmolcas-22.02/src/mrci/fijd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/fijd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,72 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE FIJD(INTSYM,INDX,C,DMO,JREFX,AREF) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "mrci.fh" - DIMENSION INTSYM(*),INDX(*), - * C(*),DMO(*),JREFX(*),AREF(*) -* - JSYM(L)=JSUNP(INTSYM,L) -* - ICHK=0 - IK=0 - ENPINV=1.0D00/ENP - IADD10=IAD10(8) -100 CALL dDAFILE(LUSYMB,2,COP,nCOP,IADD10) - CALL iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.EQ.0)GO TO 100 - IF(LEN.LT.0) RETURN - DO 10 IN=1,LEN - IND=ICOP1(IN) - IF(ICHK.NE.0) THEN - ICHK=0 - INDI=IND -* NI=MOD(INDI,2**10) -* NK=MOD(INDI/2**10,2**10) - NI=IBITS(INDI, 0,10) - NK=IBITS(INDI,10,10) - IK=IROW(NK)+NI - GO TO 10 - END IF - IF(IND.EQ.0) THEN - ICHK=1 - GO TO 10 - END IF -* IVL=MOD(IND,2**6) -* IC2=MOD(IND/2**6,2**13) -* IC1=MOD(IND/2**19,2**13) - IVL=IBITS(IND, 0, 6) - IC2=IBITS(IND, 6,13) - IC1=IBITS(IND,19,13) - IF(IVL.NE.IVVER)GO TO 13 - DMO(IK)=DMO(IK)+COP(IN)*C(IC1)*C(IC2)*ENPINV - IF(ICPF.EQ.0)GO TO 10 - IRC1=JREFX(IC1) - IF(IRC1.EQ.0)GO TO 10 - IRC2=JREFX(IC2) - IF(IRC2.EQ.0)GO TO 10 - DMO(IK)=DMO(IK)+COP(IN)*AREF(IRC1)*AREF(IRC2)*(1.0D00-ENPINV) - GO TO 10 -13 INDA=IRC(IVL)+IC1 - INDB=IRC(IVL)+IC2 - NA=INDX(INDA) - NB=INDX(INDB) - NS1=JSYM(INDA) - NS1L=MUL(NS1,LSYM) - INUM=NVIR(NS1L) - IF(IVL.GE.2)INUM=NVPAIR(NS1L) - TERM=DDOT_(INUM,C(NA+1),1,C(NB+1),1) - DMO(IK)=DMO(IK)+COP(IN)*TERM*ENPINV -10 CONTINUE - GO TO 100 - END diff -Nru openmolcas-22.02/src/mrci/fijd.F90 openmolcas-22.10/src/mrci/fijd.F90 --- openmolcas-22.02/src/mrci/fijd.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/fijd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,79 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine FIJD(INTSYM,INDX,C,DMO,JREFX,AREF) + +use mrci_global, only: ENP, ICPF, IRC, IROW, IVVER, LSYM, LUSYMB, NVIR, NVPAIR +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Constants, only: One +use Definitions, only: wp, iwp, r8 + +implicit none +integer(kind=iwp), intent(in) :: INTSYM(*), INDX(*), JREFX(*) +real(kind=wp), intent(in) :: C(*), AREF(*) +real(kind=wp), intent(inout) :: DMO(*) +integer(kind=iwp) :: IADD10, IC1, IC2, ICHK, IIN, IK, ILEN, IND, INDA, INDB, INDI, INUM, IRC1, IRC2, IVL, NA, NB, NI, NK, NS1, NS1L +real(kind=wp) :: ENPINV, TERM +integer(kind=iwp), external :: JSUNP +real(kind=r8), external :: DDOT_ + +ICHK = 0 +IK = 0 +ENPINV = One/ENP +IADD10 = IAD10(8) +do + call dDAFILE(LUSYMB,2,COP,nCOP,IADD10) + call iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN < 0) exit + do IIN=1,ILEN + IND = ICOP1(IIN) + if (ICHK /= 0) then + ICHK = 0 + INDI = IND + NI = ibits(INDI,0,10) + NK = ibits(INDI,10,10) + IK = IROW(NK)+NI + else if (IND == 0) then + ICHK = 1 + else + IVL = ibits(IND,0,6) + IC2 = ibits(IND,6,13) + IC1 = ibits(IND,19,13) + if (IVL == IVVER) then + DMO(IK) = DMO(IK)+COP(IIN)*C(IC1)*C(IC2)*ENPINV + if (ICPF /= 0) then + IRC1 = JREFX(IC1) + if (IRC1 /= 0) then + IRC2 = JREFX(IC2) + if (IRC2 /= 0) DMO(IK) = DMO(IK)+COP(IIN)*AREF(IRC1)*AREF(IRC2)*(One-ENPINV) + end if + end if + else + INDA = IRC(IVL)+IC1 + INDB = IRC(IVL)+IC2 + NA = INDX(INDA) + NB = INDX(INDB) + NS1 = JSUNP(INTSYM,INDA) + NS1L = MUL(NS1,LSYM) + INUM = NVIR(NS1L) + if (IVL >= 2) INUM = NVPAIR(NS1L) + TERM = DDOT_(INUM,C(NA+1),1,C(NB+1),1) + DMO(IK) = DMO(IK)+COP(IIN)*TERM*ENPINV + end if + end if + end do +end do + +return + +end subroutine FIJD diff -Nru openmolcas-22.02/src/mrci/fij.F90 openmolcas-22.10/src/mrci/fij.F90 --- openmolcas-22.02/src/mrci/fij.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/fij.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,79 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine FIJ(INTSYM,INDX,C,S,FC,A,B,FK,DBK) + +use mrci_global, only: IRC, IREST, IROW, ITER, IVVER, LSYM, Lu_25, LUSYMB, NBTRI, NVIR, NVPAIR +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: INTSYM(*), INDX(*) +real(kind=wp), intent(inout) :: C(*), S(*), FC(*) +real(kind=wp), intent(_OUT_) :: A(*), B(*), FK(*), DBK(*) +integer(kind=iwp) :: IADD10, IADD25, IC1, IC2, ICHK, IIN, IK, ILEN, IND, INDA, INDB, INDI, INUM, IVL, NA, NB, NI, NK, NS1, NS1L +real(kind=wp) :: COPI +integer(kind=iwp), external :: JSUNP + +ICHK = 0 +IK = 0 +IADD25 = 0 +call dDAFILE(Lu_25,2,FC,NBTRI,IADD25) +IADD10 = IAD10(8) +do + call dDAFILE(LUSYMB,2,COP,nCOP,IADD10) + call iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN < 0) exit + do IIN=1,ILEN + IND = ICOP1(IIN) + if (ICHK /= 0) then + ICHK = 0 + INDI = IND + NI = ibits(INDI,0,10) + NK = ibits(INDI,10,10) + IK = IROW(NK)+NI + else if (IND == 0) then + ICHK = 1 + else + IVL = ibits(IND,0,6) + IC2 = ibits(IND,6,13) + IC1 = ibits(IND,19,13) + COPI = COP(IIN)*FC(IK) + if (IVL == IVVER) then + S(IC1) = S(IC1)+COPI*C(IC2) + S(IC2) = S(IC2)+COPI*C(IC1) + else + INDA = IRC(IVL)+IC1 + INDB = IRC(IVL)+IC2 + NA = INDX(INDA) + NB = INDX(INDB) + NS1 = JSUNP(INTSYM,INDA) + NS1L = MUL(NS1,LSYM) + INUM = NVIR(NS1L) + if (IVL >= 2) INUM = NVPAIR(NS1L) + S(NA+1:NA+INUM) = S(NA+1:NA+INUM)+COPI*C(NB+1:NB+INUM) + S(NB+1:NB+INUM) = S(NB+1:NB+INUM)+COPI*C(NA+1:NA+INUM) + end if + end if + end do +end do +if (ITER /= 0) then + call AI_MRCI(INTSYM,INDX,C,S,FC,A,B,FK,DBK,0) + if ((ITER /= 1) .or. (IREST /= 0)) call AB(INTSYM,INDX,C,S,FC,A,B,FK) +end if + +return + +end subroutine FIJ diff -Nru openmolcas-22.02/src/mrci/fij_mrci.f openmolcas-22.10/src/mrci/fij_mrci.f --- openmolcas-22.02/src/mrci/fij_mrci.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/fij_mrci.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,77 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE FIJ_MRCI(ICSPCK,INTSYM,INDX,C,S,FC,A,B,FK,DBK) - IMPLICIT REAL*8 (A-H,O-Z) -#include "WrkSpc.fh" -#include "SysDef.fh" -#include "mrci.fh" - DIMENSION ICSPCK(*),INTSYM(*),INDX(*), - * C(*),S(*),FC(*),A(*),B(*), - * FK(*),DBK(*) -* - JSYM(L)=JSUNP(INTSYM,L) -* - ICHK=0 - IK=0 - IADD25=0 - CALL dDAFILE(Lu_25,2,FC,NBTRI,IADD25) - IADD10=IAD10(8) -100 CALL dDAFILE(LUSYMB,2,COP,nCOP,IADD10) - CALL iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.EQ.0)GO TO 100 - IF(LEN.LT.0)GO TO 200 - DO 10 IN=1,LEN - IND=ICOP1(IN) - IF(ICHK.NE.0) THEN - ICHK=0 - INDI=IND -* NI=MOD(INDI,2**10) -* NK=MOD(INDI/2**10,2**10) - NI=IBITS(INDI, 0,10) - NK=IBITS(INDI,10,10) - IK=IROW(NK)+NI - GO TO 10 - END IF - IF(IND.EQ.0) THEN - ICHK=1 - GO TO 10 - END IF -* IVL=MOD(IND,2**6) -* IC2=MOD(IND/2**6,2**13) -* IC1=MOD(IND/2**19,2**13) - IVL=IBITS(IND, 0, 6) - IC2=IBITS(IND, 6,13) - IC1=IBITS(IND,19,13) - COPI=COP(IN)*FC(IK) - IF(IVL.EQ.IVVER) THEN - S(IC1)=S(IC1)+COPI*C(IC2) - S(IC2)=S(IC2)+COPI*C(IC1) - GO TO 10 - END IF - INDA=IRC(IVL)+IC1 - INDB=IRC(IVL)+IC2 - NA=INDX(INDA) - NB=INDX(INDB) - NS1=JSYM(INDA) - NS1L=MUL(NS1,LSYM) - INUM=NVIR(NS1L) - IF(IVL.GE.2)INUM=NVPAIR(NS1L) - CALL DAXPY_(INUM,COPI,C(NB+1),1,S(NA+1),1) - CALL DAXPY_(INUM,COPI,C(NA+1),1,S(NB+1),1) -10 CONTINUE - GO TO 100 -200 IF(ITER.EQ.0)RETURN - CALL AI_MRCI(INTSYM,INDX,C,S,FC,A,B,FK,DBK,0) - IF(ITER.EQ.1 .AND. IREST.EQ.0)RETURN - CALL AB_MRCI(ICSPCK,INTSYM,INDX,C,S,FC,A,B,FK) - RETURN - END diff -Nru openmolcas-22.02/src/mrci/fijtd.f openmolcas-22.10/src/mrci/fijtd.f --- openmolcas-22.02/src/mrci/fijtd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/fijtd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,71 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE FIJTD(INTSYM,INDX,C1,C2,TDMO) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "mrci.fh" - DIMENSION INTSYM(*),INDX(*), - * C1(*),C2(*),TDMO(NBAST,NBAST) -* - JSYM(L)=JSUNP(INTSYM,L) -*------ -* POW: Unnecessary but warning stopping initializations - ni=-1234567 - nk=-1234567 -*------ - ICHK=0 - IADD10=IAD10(8) -100 CALL dDAFILE(LUSYMB,2,COP,nCOP,IADD10) - CALL iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.EQ.0)GO TO 100 - IF(LEN.LT.0) RETURN - DO 10 IN=1,LEN - IND=ICOP1(IN) - IF(ICHK.NE.0) THEN - ICHK=0 - INDI=IND -* NI=MOD(INDI,2**10) -* NK=MOD(INDI/2**10,2**10) - NI=IBITS(INDI, 0,10) - NK=IBITS(INDI,10,10) - GO TO 10 - END IF - IF(IND.EQ.0) THEN - ICHK=1 - GO TO 10 - END IF -* IVL=MOD(IND,2**6) -* IC2=MOD(IND/2**6,2**13) -* IC1=MOD(IND/2**19,2**13) - IVL=IBITS(IND, 0, 6) - IC2=IBITS(IND, 6,13) - IC1=IBITS(IND,19,13) - IF(IVL.NE.IVVER)GO TO 13 - TDMO(NI,NK)=TDMO(NI,NK)+COP(IN)*C1(IC1)*C2(IC2) - IF(NI.NE.NK) TDMO(NK,NI)=TDMO(NK,NI)+COP(IN)*C2(IC1)*C1(IC2) - GO TO 10 -13 INDA=IRC(IVL)+IC1 - INDB=IRC(IVL)+IC2 - NA=INDX(INDA) - NB=INDX(INDB) - NS1=JSYM(INDA) - NS1L=MUL(NS1,LSYM) - INUM=NVIR(NS1L) - IF(IVL.GE.2)INUM=NVPAIR(NS1L) - TERM=DDOT_(INUM,C1(NA+1),1,C2(NB+1),1) - TDMO(NI,NK)=TDMO(NI,NK)+COP(IN)*TERM - IF(NI.EQ.NK) GOTO 10 - TERM=DDOT_(INUM,C2(NA+1),1,C1(NB+1),1) - TDMO(NK,NI)=TDMO(NK,NI)+COP(IN)*TERM -10 CONTINUE - GO TO 100 - END diff -Nru openmolcas-22.02/src/mrci/fijtd.F90 openmolcas-22.10/src/mrci/fijtd.F90 --- openmolcas-22.02/src/mrci/fijtd.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/fijtd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,78 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine FIJTD(INTSYM,INDX,C1,C2,TDMO) + +use mrci_global, only: IRC, IVVER, LSYM, LUSYMB, NBAST, NVIR, NVPAIR +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Definitions, only: wp, iwp, r8 + +implicit none +integer(kind=iwp), intent(in) :: INTSYM(*), INDX(*) +real(kind=wp), intent(in) :: C1(*), C2(*) +real(kind=wp), intent(inout) :: TDMO(NBAST,NBAST) +integer(kind=iwp) :: IADD10, IC1, IC2, ICHK, IIN, ILEN, IND, INDA, INDB, INDI, INUM, IVL, NA, NB, NI, NK, NS1, NS1L +real(kind=wp) :: TERM +integer(kind=iwp), external :: JSUNP +real(kind=r8), external :: DDOT_ + +!------ +! POW: Unnecessary but warning stopping initializations +NI = -1234567 +NK = -1234567 +!------ +ICHK = 0 +IADD10 = IAD10(8) +do + call dDAFILE(LUSYMB,2,COP,nCOP,IADD10) + call iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN < 0) exit + do IIN=1,ILEN + IND = ICOP1(IIN) + if (ICHK /= 0) then + ICHK = 0 + INDI = IND + NI = ibits(INDI,0,10) + NK = ibits(INDI,10,10) + else if (IND == 0) then + ICHK = 1 + else + IVL = ibits(IND,0,6) + IC2 = ibits(IND,6,13) + IC1 = ibits(IND,19,13) + if (IVL == IVVER) then + TDMO(NI,NK) = TDMO(NI,NK)+COP(IIN)*C1(IC1)*C2(IC2) + if (NI /= NK) TDMO(NK,NI) = TDMO(NK,NI)+COP(IIN)*C2(IC1)*C1(IC2) + else + INDA = IRC(IVL)+IC1 + INDB = IRC(IVL)+IC2 + NA = INDX(INDA) + NB = INDX(INDB) + NS1 = JSUNP(INTSYM,INDA) + NS1L = MUL(NS1,LSYM) + INUM = NVIR(NS1L) + if (IVL >= 2) INUM = NVPAIR(NS1L) + TERM = DDOT_(INUM,C1(NA+1),1,C2(NB+1),1) + TDMO(NI,NK) = TDMO(NI,NK)+COP(IIN)*TERM + if (NI /= NK) then + TERM = DDOT_(INUM,C2(NA+1),1,C1(NB+1),1) + TDMO(NK,NI) = TDMO(NK,NI)+COP(IIN)*TERM + end if + end if + end if + end do +end do + +return + +end subroutine FIJTD diff -Nru openmolcas-22.02/src/mrci/fmul2.f openmolcas-22.10/src/mrci/fmul2.f --- openmolcas-22.02/src/mrci/fmul2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/fmul2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,47 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE FMUL2(A,B,C,NROW,NCOL,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(NROW,N),B(NCOL,N),CJ(1000) - DIMENSION C(NROW,NCOL) -#include "warnings.h" - - If ( nRow.gt.1000 ) then - WRITE(6,*) - CALL XFLUSH(6) - WRITE(6,*) ' *** Error in Subroutine FMUL2 ***' - CALL XFLUSH(6) - WRITE(6,*) ' row dimension exceeds local buffer size' - CALL XFLUSH(6) - WRITE(6,*) - CALL XFLUSH(6) - Call Quit(_RC_INTERNAL_ERROR_) - End If - - DO 10 J=1,NCOL - DO 15 I=1,NROW - CJ(I)=0.0 -15 CONTINUE - IF(J.EQ.NCOL)GO TO 16 - J1=J+1 - DO 20 K=1,N - FAC=B(J,K) - IF(FAC.EQ.0.0)GO TO 20 - DO 25 I=J1,NROW - CJ(I)=CJ(I)+FAC*A(I,K) -25 CONTINUE -20 CONTINUE -16 DO 30 I=1,NROW - C(I,J)=CJ(I) -30 CONTINUE -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/hz.f openmolcas-22.10/src/mrci/hz.f --- openmolcas-22.02/src/mrci/hz.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/hz.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,242 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE HZ(ARR) - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "mrci.fh" - PARAMETER (IX1F=1,IX2F=2,IRR=3,IX1R=4,IX2R=5,IX1X1=6,IX2X1=7, - * IX2X2=8,IFDF=9,IFDR=10,IRDR=11) - DIMENSION TMP(MXVEC,MXVEC) - DIMENSION ARR(NRROOT,NRROOT,11) -* -* THIS SUBROUTINE FORMS THE OVERLAP AND H-ZERO MATRIX ELEMENTS -* IN THE BASIS OF PSI, RHO, XI1, AND XI2 FUNCTIONS. -* -C WRITE(6,*) -C WRITE(6,*)' CHECK PRINTS IN HZ.' -C WRITE(6,*)' X1F ARRAY:' -C DO 1001 I=1,NRROOT -C WRITE(6,'(1X,5F15.6)')(ARR(I,J,IX1F),J=1,NRROOT) -C1001 CONTINUE -C WRITE(6,*)' X2F ARRAY:' -C DO 1002 I=1,NRROOT -C WRITE(6,'(1X,5F15.6)')(ARR(I,J,IX2F),J=1,NRROOT) -C1002 CONTINUE -C WRITE(6,*)' RR ARRAY:' -C DO 1003 I=1,NRROOT -C WRITE(6,'(1X,5F15.6)')(ARR(I,J,IRR ),J=1,NRROOT) -C1003 CONTINUE -C WRITE(6,*)' X1R ARRAY:' -C DO 1004 I=1,NRROOT -C WRITE(6,'(1X,5F15.6)')(ARR(I,J,IX1R),J=1,NRROOT) -C1004 CONTINUE -C WRITE(6,*)' X2R ARRAY:' -C DO 1005 I=1,NRROOT -C WRITE(6,'(1X,5F15.6)')(ARR(I,J,IX2R),J=1,NRROOT) -C1005 CONTINUE -C WRITE(6,*)' X1X1 ARRAY:' -C DO 1006 I=1,NRROOT -C WRITE(6,'(1X,5F15.6)')(ARR(I,J,IX1X1),J=1,NRROOT) -C1006 CONTINUE -C WRITE(6,*)' X2X1 ARRAY:' -C DO 1007 I=1,NRROOT -C WRITE(6,'(1X,5F15.6)')(ARR(I,J,IX2X1),J=1,NRROOT) -C1007 CONTINUE -C WRITE(6,*)' X2X2 ARRAY:' -C DO 1008 I=1,NRROOT -C WRITE(6,'(1X,5F15.6)')(ARR(I,J,IX2X2),J=1,NRROOT) -C1008 CONTINUE -C WRITE(6,*)' FDF ARRAY:' -C DO 1009 I=1,NRROOT -C WRITE(6,'(1X,5F15.6)')(ARR(I,J,IFDF),J=1,NRROOT) -C1009 CONTINUE -C WRITE(6,*)' FDR ARRAY:' -C DO 1010 I=1,NRROOT -C WRITE(6,'(1X,5F15.6)')(ARR(I,J,IFDR),J=1,NRROOT) -C1010 CONTINUE -C WRITE(6,*)' RDR ARRAY:' -C DO 1011 I=1,NRROOT -C WRITE(6,'(1X,5F15.6)')(ARR(I,J,IRDR),J=1,NRROOT) -C1011 CONTINUE -C FIRST, CREATE OVERLAP MATRIX, AND INITIALIZE HZERO MATRIX WITH ALL -C TERMS THAT DO NOT REQUIRE MATRIX MULTIPLIES: - DO 10 I1=1,NRROOT - I2=I1+NRROOT - I3=I1+2*NRROOT - I4=I1+3*NRROOT - DO 11 J1=1,NRROOT - J2=J1+NRROOT - J3=J1+2*NRROOT - J4=J1+3*NRROOT - SZERO(I1,J1)=0.0D00 - SZERO(I2,J1)=0.0D00 - SZERO(I3,J1)=ARR(I1,J1,IX1F) - SZERO(I4,J1)=ARR(I1,J1,IX2F) - SZERO(I2,J2)=ARR(I1,J1,IRR) - SZERO(I3,J2)=ARR(I1,J1,IX1R) - SZERO(I4,J2)=ARR(I1,J1,IX2R) - SZERO(I3,J3)=ARR(I1,J1,IX1X1) - SZERO(I4,J3)=ARR(I1,J1,IX2X1) - SZERO(I4,J4)=ARR(I1,J1,IX2X2) - HZERO(I1,J1)=0.0D00 - IF(I1.EQ.J1) THEN - SZERO(I1,J1)=1.0D00 - HZERO(I1,J1)=ESMALL(I1) - END IF - HZERO(I2,J1)=ARR(I1,J1,IRR) - HZERO(I3,J1)=ARR(I1,J1,IX1F)*ESMALL(J1)+ARR(I1,J1,IX1R) - HZERO(I4,J1)=ARR(I1,J1,IX2F)*ESMALL(J1)+ARR(I1,J1,IX2R) - HZERO(I2,J2)=ARR(I1,J1,IRDR) - HZERO(I3,J2)=ESMALL(I1)*ARR(I1,J1,IX1R) - HZERO(I4,J2)=ESMALL(I1)*ARR(I1,J1,IX2R)+ARR(I1,J1,IRR) - HZERO(I3,J3)=ARR(I1,J1,IX1X1)*ESMALL(J1)-ARR(J1,I1,IX1F) - HZERO(I4,J3)=ARR(I1,J1,IX2X1)*ESMALL(J1) - HZERO(I4,J4)=ARR(I1,J1,IX2X2)*ESMALL(J1)+ARR(I1,J1,IX2R) -11 CONTINUE -10 CONTINUE - IO2=NRROOT - IO3=2*NRROOT - IO4=3*NRROOT - DO 20 I=1,NRROOT - DO 22 J=1,NRROOT - SUM1=HZERO(IO3+I,IO2+J) - SUM2=HZERO(IO4+I,IO2+J) - DO 21 K=1,NRROOT - SUM1=SUM1+ARR(I,K,IX1F)*(ARR(K,J,IRR)-ARR(K,J,IFDR)) - SUM2=SUM2+ARR(I,K,IX2F)*(ARR(K,J,IRR)-ARR(K,J,IFDR)) -21 CONTINUE - HZERO(IO3+I,IO2+J)=SUM1 - HZERO(IO4+I,IO2+J)=SUM2 -22 CONTINUE -20 CONTINUE - DO 30 I=1,NRROOT - DO 32 J=1,NRROOT - SUM1=0.0D00 - SUM2=0.0D00 - DO 31 K=1,NRROOT - SUM1=SUM1+ARR(I,K,IX1F)*ARR(J,K,IX1F) - SUM2=SUM2+ARR(I,K,IX2F)*ARR(J,K,IX1F) -31 CONTINUE - HZERO(IO3+I,IO3+J)=HZERO(IO3+I,IO3+J)-SUM1*ESMALL(J) - HZERO(IO3+J,IO3+I)=HZERO(IO3+J,IO3+I)-SUM1*ESMALL(J) - HZERO(IO4+I,IO3+J)=HZERO(IO4+I,IO3+J)-SUM2*ESMALL(J) -32 CONTINUE -30 CONTINUE - DO 40 I=1,NRROOT - DO 42 J=1,NRROOT - SUM1=0.0D00 - SUM2=0.0D00 - DO 41 K=1,NRROOT - SUM1=SUM1+ARR(I,K,IX2F)*ARR(J,K,IX1F) - SUM2=SUM2+ARR(I,K,IX2F)*ARR(J,K,IX2F) -41 CONTINUE - HZERO(IO4+I,IO3+J)=HZERO(IO4+I,IO3+J)-SUM1*ESMALL(I) - HZERO(IO4+I,IO4+J)=HZERO(IO4+I,IO4+J)-SUM2*ESMALL(I) - HZERO(IO4+J,IO4+I)=HZERO(IO4+J,IO4+I)-SUM2*ESMALL(I) -42 CONTINUE -40 CONTINUE - DO 50 I=1,NRROOT - DO 52 J=1,NRROOT - SUM=0.0D00 - DO 51 K=1,NRROOT - SUM=SUM+ARR(I,K,IFDF)*ARR(J,K,IX1F) -51 CONTINUE - TMP(I,J)=SUM -52 CONTINUE -50 CONTINUE - DO 60 I=1,NRROOT - DO 62 J=1,NRROOT - SUM1=HZERO(IO3+I,IO3+J) - SUM2=HZERO(IO4+I,IO3+J) - DO 61 K=1,NRROOT - SUM1=SUM1+ARR(I,K,IX1F)*TMP(K,J) - SUM2=SUM2+ARR(I,K,IX2F)*TMP(K,J) -61 CONTINUE - HZERO(IO3+I,IO3+J)=SUM1 - HZERO(IO4+I,IO3+J)=SUM2 -62 CONTINUE -60 CONTINUE - DO 70 I=1,NRROOT - DO 72 J=1,NRROOT - SUM=0.0D00 - DO 71 K=1,NRROOT - SUM=SUM+ARR(I,K,IFDF)*ARR(J,K,IX2F) -71 CONTINUE - TMP(I,J)=SUM -72 CONTINUE -70 CONTINUE - DO 80 I=1,NRROOT - DO 82 J=1,NRROOT - SUM2=HZERO(IO4+I,IO4+J) - DO 81 K=1,NRROOT - SUM2=SUM2+ARR(I,K,IX2F)*TMP(K,J) -81 CONTINUE - HZERO(IO4+I,IO4+J)=SUM2 -82 CONTINUE -80 CONTINUE - DO 90 I=1,NRROOT - DO 92 J=1,NRROOT - TMP(I,J)=ESMALL(I)*ARR(J,I,IX1F)+ARR(J,I,IX1R) -92 CONTINUE -90 CONTINUE - DO 100 I=1,NRROOT - DO 102 J=1,NRROOT - SUM1=HZERO(IO3+I,IO3+J) - SUM2=HZERO(IO4+I,IO3+J) - DO 101 K=1,NRROOT - SUM1=SUM1+ARR(I,K,IX1F)*TMP(K,J)+ARR(I,K,IX1R)*ARR(J,K,IX1F) - SUM2=SUM2+ARR(I,K,IX2F)*TMP(K,J)+ARR(I,K,IX2R)*ARR(J,K,IX1F) -101 CONTINUE - HZERO(IO3+I,IO3+J)=SUM1 - HZERO(IO4+I,IO3+J)=SUM2 -102 CONTINUE -100 CONTINUE - DO 110 I=1,NRROOT - DO 111 J=1,NRROOT - TMP(I,J)=ESMALL(I)*ARR(J,I,IX2F)+ARR(J,I,IX2R) -111 CONTINUE -110 CONTINUE - DO 120 I=1,NRROOT - DO 122 J=1,NRROOT - SUM2=HZERO(IO4+I,IO4+J) - DO 121 K=1,NRROOT - SUM2=SUM2+ARR(I,K,IX2F)*TMP(K,J)+ - * ARR(I,K,IX2R)*ARR(J,K,IX2F) -121 CONTINUE - HZERO(IO4+I,IO4+J)=SUM2 -122 CONTINUE -120 CONTINUE - DO 200 I1=1,NRROOT - I2=I1+NRROOT - I3=I1+2*NRROOT - I4=I1+3*NRROOT - DO 201 J1=1,NRROOT - J2=J1+NRROOT - J3=J1+2*NRROOT - J4=J1+3*NRROOT - HZERO(I1,J2)=HZERO(J2,I1) - HZERO(I1,J3)=HZERO(J3,I1) - HZERO(I1,J4)=HZERO(J4,I1) - HZERO(I2,J3)=HZERO(J3,I2) - HZERO(I2,J4)=HZERO(J4,I2) - HZERO(I3,J4)=HZERO(J4,I3) - SZERO(I1,J2)=SZERO(J2,I1) - SZERO(I1,J3)=SZERO(J3,I1) - SZERO(I1,J4)=SZERO(J4,I1) - SZERO(I2,J3)=SZERO(J3,I2) - SZERO(I2,J4)=SZERO(J4,I2) - SZERO(I3,J4)=SZERO(J4,I3) -201 CONTINUE -200 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/hz.F90 openmolcas-22.10/src/mrci/hz.F90 --- openmolcas-22.02/src/mrci/hz.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/hz.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,250 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine HZ(ARR) + +use mrci_global, only: ESMALL, HZERO, NRROOT, SZERO +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(in) :: ARR(NRROOT,NRROOT,11) +integer(kind=iwp) :: I, I1, I2, I3, I4, IO2, IO3, IO4, J, J1, J2, J3, J4, K +real(kind=wp) :: SUM1, SUM2, SUM3 +integer(kind=iwp), parameter :: IX1F = 1, IX2F = 2, IRR = 3, IX1R = 4, IX2R = 5, IX1X1 = 6, IX2X1 = 7, IX2X2 = 8, IFDF = 9, & + IFDR = 10, IRDR = 11 +real(kind=wp), allocatable :: TMP(:,:) + +! THIS SUBROUTINE FORMS THE OVERLAP AND H-ZERO MATRIX ELEMENTS +! IN THE BASIS OF PSI, RHO, XI1, AND XI2 FUNCTIONS. +! +!write(u6,*) +!write(u6,*)' CHECK PRINTS IN HZ.' +!write(u6,*)' X1F ARRAY:' +!do I=1,NRROOT +! write(u6,'(1X,5F15.6)') (ARR(I,J,IX1F),J=1,NRROOT) +!end do +!write(u6,*)' X2F ARRAY:' +!do I=1,NRROOT +! write(u6,'(1X,5F15.6)') (ARR(I,J,IX2F),J=1,NRROOT) +!end do +!write(u6,*)' RR ARRAY:' +!do I=1,NRROOT +! write(u6,'(1X,5F15.6)') (ARR(I,J,IRR),J=1,NRROOT) +!end do +!write(u6,*)' X1R ARRAY:' +!do I=1,NRROOT +! write(u6,'(1X,5F15.6)') (ARR(I,J,IX1R),J=1,NRROOT) +!end do +!write(u6,*)' X2R ARRAY:' +!do I=1,NRROOT +! write(u6,'(1X,5F15.6)') (ARR(I,J,IX2R),J=1,NRROOT) +!end do +!write(u6,*)' X1X1 ARRAY:' +!do I=1,NRROOT +! write(u6,'(1X,5F15.6)') (ARR(I,J,IX1X1),J=1,NRROOT) +!end do +!write(u6,*)' X2X1 ARRAY:' +!do I=1,NRROOT +! write(u6,'(1X,5F15.6)') (ARR(I,J,IX2X1),J=1,NRROOT) +!end do +!write(u6,*)' X2X2 ARRAY:' +!do I=1,NRROOT +! write(u6,'(1X,5F15.6)') (ARR(I,J,IX2X2),J=1,NRROOT) +!end do +!write(u6,*)' FDF ARRAY:' +!do I=1,NRROOT +! write(u6,'(1X,5F15.6)') (ARR(I,J,IFDF),J=1,NRROOT) +!end do +!write(u6,*)' FDR ARRAY:' +!do I=1,NRROOT +! write(u6,'(1X,5F15.6)') (ARR(I,J,IFDR),J=1,NRROOT) +!end do +!write(u6,*)' RDR ARRAY:' +!do I=1,NRROOT +! write(u6,'(1X,5F15.6)') (ARR(I,J,IRDR),J=1,NRROOT) +!end do +! FIRST, CREATE OVERLAP MATRIX, AND INITIALIZE HZERO MATRIX WITH ALL +! TERMS THAT DO NOT REQUIRE MATRIX MULTIPLIES: +do I1=1,NRROOT + I2 = I1+NRROOT + I3 = I1+2*NRROOT + I4 = I1+3*NRROOT + do J1=1,NRROOT + J2 = J1+NRROOT + J3 = J1+2*NRROOT + J4 = J1+3*NRROOT + SZERO(I1,J1) = Zero + SZERO(I2,J1) = Zero + SZERO(I3,J1) = ARR(I1,J1,IX1F) + SZERO(I4,J1) = ARR(I1,J1,IX2F) + SZERO(I2,J2) = ARR(I1,J1,IRR) + SZERO(I3,J2) = ARR(I1,J1,IX1R) + SZERO(I4,J2) = ARR(I1,J1,IX2R) + SZERO(I3,J3) = ARR(I1,J1,IX1X1) + SZERO(I4,J3) = ARR(I1,J1,IX2X1) + SZERO(I4,J4) = ARR(I1,J1,IX2X2) + HZERO(I1,J1) = Zero + if (I1 == J1) then + SZERO(I1,J1) = One + HZERO(I1,J1) = ESMALL(I1) + end if + HZERO(I2,J1) = ARR(I1,J1,IRR) + HZERO(I3,J1) = ARR(I1,J1,IX1F)*ESMALL(J1)+ARR(I1,J1,IX1R) + HZERO(I4,J1) = ARR(I1,J1,IX2F)*ESMALL(J1)+ARR(I1,J1,IX2R) + HZERO(I2,J2) = ARR(I1,J1,IRDR) + HZERO(I3,J2) = ESMALL(I1)*ARR(I1,J1,IX1R) + HZERO(I4,J2) = ESMALL(I1)*ARR(I1,J1,IX2R)+ARR(I1,J1,IRR) + HZERO(I3,J3) = ARR(I1,J1,IX1X1)*ESMALL(J1)-ARR(J1,I1,IX1F) + HZERO(I4,J3) = ARR(I1,J1,IX2X1)*ESMALL(J1) + HZERO(I4,J4) = ARR(I1,J1,IX2X2)*ESMALL(J1)+ARR(I1,J1,IX2R) + end do +end do +IO2 = NRROOT +IO3 = 2*NRROOT +IO4 = 3*NRROOT +do I=1,NRROOT + do J=1,NRROOT + SUM2 = HZERO(IO3+I,IO2+J) + SUM3 = HZERO(IO4+I,IO2+J) + do K=1,NRROOT + SUM2 = SUM2+ARR(I,K,IX1F)*(ARR(K,J,IRR)-ARR(K,J,IFDR)) + SUM3 = SUM3+ARR(I,K,IX2F)*(ARR(K,J,IRR)-ARR(K,J,IFDR)) + end do + HZERO(IO3+I,IO2+J) = SUM2 + HZERO(IO4+I,IO2+J) = SUM3 + end do +end do +do I=1,NRROOT + do J=1,NRROOT + SUM2 = Zero + SUM3 = Zero + do K=1,NRROOT + SUM2 = SUM2+ARR(I,K,IX1F)*ARR(J,K,IX1F) + SUM3 = SUM3+ARR(I,K,IX2F)*ARR(J,K,IX1F) + end do + HZERO(IO3+I,IO3+J) = HZERO(IO3+I,IO3+J)-SUM2*ESMALL(J) + HZERO(IO3+J,IO3+I) = HZERO(IO3+J,IO3+I)-SUM2*ESMALL(J) + HZERO(IO4+I,IO3+J) = HZERO(IO4+I,IO3+J)-SUM3*ESMALL(J) + end do +end do +do I=1,NRROOT + do J=1,NRROOT + SUM2 = Zero + SUM3 = Zero + do K=1,NRROOT + SUM2 = SUM2+ARR(I,K,IX2F)*ARR(J,K,IX1F) + SUM3 = SUM3+ARR(I,K,IX2F)*ARR(J,K,IX2F) + end do + HZERO(IO4+I,IO3+J) = HZERO(IO4+I,IO3+J)-SUM2*ESMALL(I) + HZERO(IO4+I,IO4+J) = HZERO(IO4+I,IO4+J)-SUM3*ESMALL(I) + HZERO(IO4+J,IO4+I) = HZERO(IO4+J,IO4+I)-SUM3*ESMALL(I) + end do +end do +call mma_allocate(TMP,NRROOT,NRROOT,label='TMP') +do I=1,NRROOT + do J=1,NRROOT + SUM1 = Zero + do K=1,NRROOT + SUM1 = SUM1+ARR(I,K,IFDF)*ARR(J,K,IX1F) + end do + TMP(I,J) = SUM1 + end do +end do +do I=1,NRROOT + do J=1,NRROOT + SUM2 = HZERO(IO3+I,IO3+J) + SUM3 = HZERO(IO4+I,IO3+J) + do K=1,NRROOT + SUM2 = SUM2+ARR(I,K,IX1F)*TMP(K,J) + SUM3 = SUM3+ARR(I,K,IX2F)*TMP(K,J) + end do + HZERO(IO3+I,IO3+J) = SUM2 + HZERO(IO4+I,IO3+J) = SUM3 + end do +end do +do I=1,NRROOT + do J=1,NRROOT + SUM1 = Zero + do K=1,NRROOT + SUM1 = SUM1+ARR(I,K,IFDF)*ARR(J,K,IX2F) + end do + TMP(I,J) = SUM1 + end do +end do +do I=1,NRROOT + do J=1,NRROOT + SUM3 = HZERO(IO4+I,IO4+J) + do K=1,NRROOT + SUM3 = SUM3+ARR(I,K,IX2F)*TMP(K,J) + end do + HZERO(IO4+I,IO4+J) = SUM3 + end do +end do +do I=1,NRROOT + do J=1,NRROOT + TMP(I,J) = ESMALL(I)*ARR(J,I,IX1F)+ARR(J,I,IX1R) + end do +end do +do I=1,NRROOT + do J=1,NRROOT + SUM2 = HZERO(IO3+I,IO3+J) + SUM3 = HZERO(IO4+I,IO3+J) + do K=1,NRROOT + SUM2 = SUM2+ARR(I,K,IX1F)*TMP(K,J)+ARR(I,K,IX1R)*ARR(J,K,IX1F) + SUM3 = SUM3+ARR(I,K,IX2F)*TMP(K,J)+ARR(I,K,IX2R)*ARR(J,K,IX1F) + end do + HZERO(IO3+I,IO3+J) = SUM2 + HZERO(IO4+I,IO3+J) = SUM3 + end do +end do +do I=1,NRROOT + do J=1,NRROOT + TMP(I,J) = ESMALL(I)*ARR(J,I,IX2F)+ARR(J,I,IX2R) + end do +end do +do I=1,NRROOT + do J=1,NRROOT + SUM3 = HZERO(IO4+I,IO4+J) + do K=1,NRROOT + SUM3 = SUM3+ARR(I,K,IX2F)*TMP(K,J)+ARR(I,K,IX2R)*ARR(J,K,IX2F) + end do + HZERO(IO4+I,IO4+J) = SUM3 + end do +end do +call mma_deallocate(TMP) +do I1=1,NRROOT + I2 = I1+NRROOT + I3 = I1+2*NRROOT + I4 = I1+3*NRROOT + do J1=1,NRROOT + J2 = J1+NRROOT + J3 = J1+2*NRROOT + J4 = J1+3*NRROOT + HZERO(I1,J2) = HZERO(J2,I1) + HZERO(I1,J3) = HZERO(J3,I1) + HZERO(I1,J4) = HZERO(J4,I1) + HZERO(I2,J3) = HZERO(J3,I2) + HZERO(I2,J4) = HZERO(J4,I2) + HZERO(I3,J4) = HZERO(J4,I3) + SZERO(I1,J2) = SZERO(J2,I1) + SZERO(I1,J3) = SZERO(J3,I1) + SZERO(I1,J4) = SZERO(J4,I1) + SZERO(I2,J3) = SZERO(J3,I2) + SZERO(I2,J4) = SZERO(J4,I2) + SZERO(I3,J4) = SZERO(J4,I3) + end do +end do + +return + +end subroutine HZ diff -Nru openmolcas-22.02/src/mrci/hzlp1.f openmolcas-22.10/src/mrci/hzlp1.f --- openmolcas-22.02/src/mrci/hzlp1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/hzlp1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,107 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE HZLP1(CBUF,SBUF,DBUF,ARR,CSECT,RSECT,XI1,XI2,ICI) - IMPLICIT REAL*8 (A-H,O-Z) - PARAMETER (ONE=1.0D00) - PARAMETER (IX1F=1,IX2F=2,IRR=3,IX1R=4,IX2R=5,IX1X1=6,IX2X1=7, - * IX2X2=8,IFDF=9,IFDR=10,IRDR=11) - -#include "SysDef.fh" - -#include "mrci.fh" - DIMENSION CBUF(MBUF,MXVEC),SBUF(MBUF,MXVEC),DBUF(MBUF),ICI(MBUF) - DIMENSION CSECT(NSECT,MXVEC),RSECT(NSECT,MXVEC) - DIMENSION XI1(NSECT,NRROOT),XI2(NSECT,NRROOT) - DIMENSION ARR(NRROOT,NRROOT,11) - DIMENSION IDC(MXVEC),IDS(MXVEC) -C THIS SUBROUTINE LOOPS OVER SECTIONS OF PSI AND SIGMA ARRAYS -C ON DISK, AND ACCUMULATES OVERLAP MATRICES AND A COUPLE OF -C HAMILTONIAN MATRICES IN THE BASIS SET PSI, RHO, XI1 AND XI2. -C THE 11 MATRICES X1F,..,RDR ARE STORED CONSECUTIVELY IN THE -C SINGLE ARRAY ARR. - NRR2=NRROOT**2 - CALL DCOPY_(11*NRR2,[0.0D00],0,ARR,1) - DO 10 K=1,NVEC - IDC(K)= IDISKC(K) - IDS(K)= IDISKS(K) -10 CONTINUE - IDD= IDISKD -C LOOP OVER BUFFERS FOR READING PSI, SIGMA AND DBUF: - DO 2000 ISTA=1,NCONF,MBUF - IEND=MIN(NCONF,ISTA+MBUF-1) - IBUF=1+IEND-ISTA - CALL dDAFILE(LUEIG,2,DBUF,IBUF,IDD) - DO 20 K=1,NVEC - CALL iDAFILE(LUEIG,2,ICI,IBUF,IDC(K)) - CALL UPKVEC(IBUF,ICI,CBUF(1,K)) - CALL dDAFILE(LUEIG,2,SBUF(1,K),IBUF,IDS(K)) -20 CONTINUE -C LOOP OVER VECTOR SECTIONS, LENGTH AT MOST NSECT: - DO 1000 JSTA=1,IBUF,NSECT - JEND=MIN(IBUF,JSTA+NSECT-1) - ISECT=1+JEND-JSTA -C TRANSFORM TO EIGENFUNCTIONS OF HSMALL: FIRST, CI SECTION. - CALL DGEMM_('N','N', - & ISECT,NRROOT,NVEC, - & 1.0d0,CBUF(JSTA,1),MBUF, - & VSMALL,MXVEC, - & 0.0d0,CSECT,NSECT) -C THEN, SIGMA SECTION INTO RSECT. - CALL DGEMM_('N','N', - & ISECT,NRROOT,NVEC, - & 1.0d0,SBUF(JSTA,1),MBUF, - & VSMALL,MXVEC, - & 0.0d0,RSECT,NSECT) -C AND THEN FORM RSECT=SECTION OF RESIDUAL ARRAY, AND XI1 AND XI2: - DO 30 I=1,ISECT - DO 31 K=1,NRROOT - RSECT(I,K)=RSECT(I,K)-ESMALL(K)*CSECT(I,K) - XI1(I,K)=CSECT(I,K)/(DBUF(I+JSTA-1)-ESMALL(K)) - XI2(I,K)=RSECT(I,K)/(DBUF(I+JSTA-1)-ESMALL(K)) -31 CONTINUE -30 CONTINUE -C ACCUMULATE OVERLAP MATRICES: - CALL DGEMM_('T','N',NRROOT,NRROOT,ISECT,ONE,XI1,NSECT, - * CSECT,NSECT,ONE,ARR(1,1,IX1F),NRROOT) - CALL DGEMM_('T','N',NRROOT,NRROOT,ISECT,ONE,XI2,NSECT, - * CSECT,NSECT,ONE,ARR(1,1,IX2F),NRROOT) - CALL DGEMM_('T','N',NRROOT,NRROOT,ISECT,ONE,RSECT,NSECT, - * RSECT,NSECT,ONE,ARR(1,1,IRR),NRROOT) - CALL DGEMM_('T','N',NRROOT,NRROOT,ISECT,ONE,XI1,NSECT, - * RSECT,NSECT,ONE,ARR(1,1,IX1R),NRROOT) - CALL DGEMM_('T','N',NRROOT,NRROOT,ISECT,ONE,XI2,NSECT, - * RSECT,NSECT,ONE,ARR(1,1,IX2R),NRROOT) - CALL DGEMM_('T','N',NRROOT,NRROOT,ISECT,ONE,XI1,NSECT, - * XI1 ,NSECT,ONE,ARR(1,1,IX1X1),NRROOT) - CALL DGEMM_('T','N',NRROOT,NRROOT,ISECT,ONE,XI2,NSECT, - * XI1 ,NSECT,ONE,ARR(1,1,IX2X1),NRROOT) - CALL DGEMM_('T','N',NRROOT,NRROOT,ISECT,ONE,XI2,NSECT, - * XI2 ,NSECT,ONE,ARR(1,1,IX2X2),NRROOT) -C PUT D*CSECT INTO XI1, AND D*RSECT INTO XI2: - DO 40 I=1,ISECT - DO 41 K=1,NRROOT - XI1(I,K)=DBUF(I+JSTA-1)*CSECT(I,K) - XI2(I,K)=DBUF(I+JSTA-1)*RSECT(I,K) -41 CONTINUE -40 CONTINUE -C ACCUMULATE ARRAYS FDF, FDR, AND RDR: - CALL DGEMM_('T','N',NRROOT,NRROOT,ISECT,ONE,XI1,NSECT, - * CSECT,NSECT,ONE,ARR(1,1,IFDF),NRROOT) - CALL DGEMM_('T','N',NRROOT,NRROOT,ISECT,ONE,XI1,NSECT, - * RSECT,NSECT,ONE,ARR(1,1,IFDR),NRROOT) - CALL DGEMM_('T','N',NRROOT,NRROOT,ISECT,ONE,XI2,NSECT, - * RSECT,NSECT,ONE,ARR(1,1,IRDR),NRROOT) -C CONTINUE, NEXT SECTION. -1000 CONTINUE -C CONTINUE, NEXT BUFFER. -2000 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/hzlp1.F90 openmolcas-22.10/src/mrci/hzlp1.F90 --- openmolcas-22.02/src/mrci/hzlp1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/hzlp1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,96 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine HZLP1(CBUF,SBUF,DBUF,ARR,CSECT,RSECT,XI1,XI2,ICI) + +use mrci_global, only: ESMALL, IDISKC, IDISKD, IDISKS, LUEIG, MBUF, MXVEC, NCONF, NRROOT, NSECT, NVEC, VSMALL +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(out) :: CBUF(MBUF,MXVEC), SBUF(MBUF,MXVEC), DBUF(MBUF), ARR(NRROOT,NRROOT,11), CSECT(NSECT,MXVEC), & + RSECT(NSECT,MXVEC), XI1(NSECT,NRROOT), XI2(NSECT,NRROOT) +integer(kind=iwp), intent(out) :: ICI(MBUF) +integer(kind=iwp) :: I, IBUF, IDD, IEND, ISECT, ISTA, JEND, JSTA, K +integer(kind=iwp), parameter :: IX1F = 1, IX2F = 2, IRR = 3, IX1R = 4, IX2R = 5, IX1X1 = 6, IX2X1 = 7, IX2X2 = 8, IFDF = 9, & + IFDR = 10, IRDR = 11 +integer(kind=iwp), allocatable :: IDC(:), IDS(:) + +! THIS SUBROUTINE LOOPS OVER SECTIONS OF PSI AND SIGMA ARRAYS +! ON DISK, AND ACCUMULATES OVERLAP MATRICES AND A COUPLE OF +! HAMILTONIAN MATRICES IN THE BASIS SET PSI, RHO, XI1 AND XI2. +! THE 11 MATRICES X1F,..,RDR ARE STORED CONSECUTIVELY IN THE +! SINGLE ARRAY ARR. +ARR(:,:,:) = Zero +call mma_allocate(IDC,NVEC,label='IDC') +call mma_allocate(IDS,NVEC,label='IDS') +do K=1,NVEC + IDC(K) = IDISKC(K) + IDS(K) = IDISKS(K) +end do +IDD = IDISKD +! LOOP OVER BUFFERS FOR READING PSI, SIGMA AND DBUF: +do ISTA=1,NCONF,MBUF + IEND = min(NCONF,ISTA+MBUF-1) + IBUF = 1+IEND-ISTA + call dDAFILE(LUEIG,2,DBUF,IBUF,IDD) + do K=1,NVEC + call iDAFILE(LUEIG,2,ICI,IBUF,IDC(K)) + call UPKVEC(IBUF,ICI,CBUF(1,K)) + call dDAFILE(LUEIG,2,SBUF(1,K),IBUF,IDS(K)) + end do + ! LOOP OVER VECTOR SECTIONS, LENGTH AT MOST NSECT: + do JSTA=1,IBUF,NSECT + JEND = min(IBUF,JSTA+NSECT-1) + ISECT = 1+JEND-JSTA + ! TRANSFORM TO EIGENFUNCTIONS OF HSMALL: FIRST, CI SECTION. + call DGEMM_('N','N',ISECT,NRROOT,NVEC,One,CBUF(JSTA,1),MBUF,VSMALL,MXVEC,Zero,CSECT,NSECT) + ! THEN, SIGMA SECTION INTO RSECT. + call DGEMM_('N','N',ISECT,NRROOT,NVEC,One,SBUF(JSTA,1),MBUF,VSMALL,MXVEC,Zero,RSECT,NSECT) + ! AND THEN FORM RSECT=SECTION OF RESIDUAL ARRAY, AND XI1 AND XI2: + do I=1,ISECT + do K=1,NRROOT + RSECT(I,K) = RSECT(I,K)-ESMALL(K)*CSECT(I,K) + XI1(I,K) = CSECT(I,K)/(DBUF(I+JSTA-1)-ESMALL(K)) + XI2(I,K) = RSECT(I,K)/(DBUF(I+JSTA-1)-ESMALL(K)) + end do + end do + ! ACCUMULATE OVERLAP MATRICES: + call DGEMM_('T','N',NRROOT,NRROOT,ISECT,One,XI1,NSECT,CSECT,NSECT,One,ARR(1,1,IX1F),NRROOT) + call DGEMM_('T','N',NRROOT,NRROOT,ISECT,One,XI2,NSECT,CSECT,NSECT,One,ARR(1,1,IX2F),NRROOT) + call DGEMM_('T','N',NRROOT,NRROOT,ISECT,One,RSECT,NSECT,RSECT,NSECT,One,ARR(1,1,IRR),NRROOT) + call DGEMM_('T','N',NRROOT,NRROOT,ISECT,One,XI1,NSECT,RSECT,NSECT,One,ARR(1,1,IX1R),NRROOT) + call DGEMM_('T','N',NRROOT,NRROOT,ISECT,One,XI2,NSECT,RSECT,NSECT,One,ARR(1,1,IX2R),NRROOT) + call DGEMM_('T','N',NRROOT,NRROOT,ISECT,One,XI1,NSECT,XI1,NSECT,One,ARR(1,1,IX1X1),NRROOT) + call DGEMM_('T','N',NRROOT,NRROOT,ISECT,One,XI2,NSECT,XI1,NSECT,One,ARR(1,1,IX2X1),NRROOT) + call DGEMM_('T','N',NRROOT,NRROOT,ISECT,One,XI2,NSECT,XI2,NSECT,One,ARR(1,1,IX2X2),NRROOT) + ! PUT D*CSECT INTO XI1, AND D*RSECT INTO XI2: + do I=1,ISECT + do K=1,NRROOT + XI1(I,K) = DBUF(I+JSTA-1)*CSECT(I,K) + XI2(I,K) = DBUF(I+JSTA-1)*RSECT(I,K) + end do + end do + ! ACCUMULATE ARRAYS FDF, FDR, AND RDR: + call DGEMM_('T','N',NRROOT,NRROOT,ISECT,One,XI1,NSECT,CSECT,NSECT,One,ARR(1,1,IFDF),NRROOT) + call DGEMM_('T','N',NRROOT,NRROOT,ISECT,One,XI1,NSECT,RSECT,NSECT,One,ARR(1,1,IFDR),NRROOT) + call DGEMM_('T','N',NRROOT,NRROOT,ISECT,One,XI2,NSECT,RSECT,NSECT,One,ARR(1,1,IRDR),NRROOT) + ! CONTINUE, NEXT SECTION. + end do + ! CONTINUE, NEXT BUFFER. +end do +call mma_deallocate(IDC) +call mma_deallocate(IDS) + +return + +end subroutine HZLP1 diff -Nru openmolcas-22.02/src/mrci/hzlp2.f openmolcas-22.10/src/mrci/hzlp2.f --- openmolcas-22.02/src/mrci/hzlp2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/hzlp2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,145 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE HZLP2(CBUF,SBUF,DBUF,CSECT,RSECT,XI1,XI2,CNEW,ICI) - IMPLICIT REAL*8 (A-H,O-Z) - PARAMETER (ONE=1.0D00) - -#include "SysDef.fh" - -#include "mrci.fh" - DIMENSION CBUF(MBUF,MXVEC),SBUF(MBUF,MXVEC),DBUF(MBUF),ICI(MBUF) - DIMENSION CSECT(NSECT,MXVEC),RSECT(NSECT,MXVEC) - DIMENSION CNEW(NSECT,MXVEC) - DIMENSION XI1(NSECT,MXVEC),XI2(NSECT,MXVEC) - DIMENSION IDCR(MXVEC),IDCW(MXVEC),IDS(MXVEC) -C THIS SUBROUTINE LOOPS OVER SECTIONS OF PSI AND SIGMA ARRAYS -C ON DISK, AND FORMS A NEW SET OF PSI ARRAYS AS A LINEAR COMBINATION -C OF THE BASIS SET PSI, RHO, XI1 AND XI2. TO FORM THE NEW PSI -C ARRAY, THE FIRST (NRROOT-NNEW) COLUMNS ARE SKIPPED, SINCE THEY -C GIVE NO ESSENTIAL IMPROVEMENT. - IVZSTA=1+NRROOT-NNEW - IVZ1=1 - IVZ2=1+NRROOT - IVZ3=1+2*NRROOT - IVZ4=1+3*NRROOT -C WRITE(6,*) -C WRITE(6,*)' IN HZLP2. NNEW=',NNEW -C IF(NVEC.LT.MXVEC) WRITE(6,*)' DUMMY WRITES OF NEW FUNCTIONS.' -C WE MAY NEED DUMMY WRITES TO PROVIDE DISK ADDRESSES: - NNVEC=MIN(NVEC+NNEW,MXVEC) - DO 16 K=NVEC+1,NNVEC - IDISKC(K)=IDFREE -C WRITE(6,'(A,I2,A,I8)')' IDISKC(',K,')=',IDFREE - DO 15 ISTA=1,NCONF,MBUF - IEND=MIN(NCONF,ISTA+MBUF-1) - IBUF=1+IEND-ISTA - CALL iDAFILE(LUEIG,0,ICI,IBUF,IDFREE) -15 CONTINUE -16 CONTINUE -C WE NEED COPIES OF THE DISK ADDRESSES. TWO COPIES FOR PSI BUFFERS. - DO 10 K=1,NNVEC - IDCR(K)= IDISKC(K) - IDCW(K)= IDISKC(K) - IDS(K)= IDISKS(K) -10 CONTINUE - IDD=IDISKD -C LOOP OVER BUFFERS FOR READING PSI, SIGMA AND DBUF: - DO 2000 ISTA=1,NCONF,MBUF - IEND=MIN(NCONF,ISTA+MBUF-1) - IBUF=1+IEND-ISTA - CALL dDAFILE(LUEIG,2,DBUF,IBUF,IDD) - DO 20 K=1,NVEC - CALL iDAFILE(LUEIG,2,ICI,IBUF,IDCR(K)) - CALL UPKVEC(IBUF,ICI,CBUF(1,K)) - CALL dDAFILE(LUEIG,2,SBUF(1,K),IBUF,IDS(K)) -20 CONTINUE -C LOOP OVER VECTOR SECTIONS, LENGTH AT MOST NSECT: - DO 1000 JSTA=1,IBUF,NSECT - JEND=MIN(IBUF,JSTA+NSECT-1) - ISECT=1+JEND-JSTA -C TRANSFORM TO EIGENFUNCTIONS OF HSMALL: FIRST, CI SECTION. - CALL DGEMM_('N','N', - & ISECT,NRROOT,NVEC, - & 1.0d0,CBUF(JSTA,1),MBUF, - & VSMALL,MXVEC, - & 0.0d0,CSECT,NSECT) -C THEN, SIGMA SECTION INTO RSECT. - CALL DGEMM_('N','N', - & ISECT,NRROOT,NVEC, - & 1.0d0,SBUF(JSTA,1),MBUF, - & VSMALL,MXVEC, - & 0.0d0,RSECT,NSECT) -C AND THEN FORM RSECT=SECTION OF RESIDUAL ARRAY, AND XI1 AND XI2: - DO 30 I=1,ISECT - DO 31 K=1,NRROOT - RSECT(I,K)=RSECT(I,K)-ESMALL(K)*CSECT(I,K) - XI1(I,K)=CSECT(I,K)/(DBUF(I+JSTA-1)-ESMALL(K)) - XI2(I,K)=RSECT(I,K)/(DBUF(I+JSTA-1)-ESMALL(K)) -31 CONTINUE -30 CONTINUE -C FORM NEW PSI ARRAYS IN CNEW SECTION: - CALL DGEMM_('N','N', - & ISECT,NNEW,NRROOT, - & 1.0d0,CSECT,NSECT, - & VZERO(IVZ1,IVZSTA),MXZ, - & 0.0d0,CNEW,NSECT) - CALL DGEMM_('N','N',ISECT,NNEW,NRROOT,ONE,RSECT,NSECT, - * VZERO(IVZ2,IVZSTA),MXZ,ONE,CNEW,NSECT) - CALL DGEMM_('N','N',ISECT,NNEW,NRROOT,ONE,XI1 ,NSECT, - * VZERO(IVZ3,IVZSTA),MXZ,ONE,CNEW,NSECT) - CALL DGEMM_('N','N',ISECT,NNEW,NRROOT,ONE,XI2 ,NSECT, - * VZERO(IVZ4,IVZSTA),MXZ,ONE,CNEW,NSECT) -C IF(ISTA+JSTA.EQ.2) THEN -C WRITE(6,*)' CONSTRUCTION OF NEW VECTOR IN HZLP2.' -C WRITE(6,*)' CSECT:' -C WRITE(6,'(1X,5F15.6)')((CSECT(I,J),I=1,5),J=1,NNEW) -C WRITE(6,*)' RSECT:' -C WRITE(6,'(1X,5F15.6)')((RSECT(I,J),I=1,5),J=1,NNEW) -C WRITE(6,*)' XI1:' -C WRITE(6,'(1X,5F15.6)')((XI1(I,J),I=1,5),J=1,NNEW) -C WRITE(6,*)' XI2:' -C WRITE(6,'(1X,5F15.6)')((XI2(I,J),I=1,5),J=1,NNEW) -C WRITE(6,*)' VZERO:' -C IIII=IVZSTA-1 -C WRITE(6,'(1X,4F15.6)')((VZERO(I,IIII+J),I=1,4*NNEW),J=1,NNEW) -C WRITE(6,*)' CNEW:' -C WRITE(6,'(1X,5F15.6)')((CNEW(I,J),I=1,5),J=1,NNEW) -C END IF -C INSERT THE NEW PSI SECTIONS IN BUFFER. THIS MAY IMPLY OVERWRITING -C OLD ENTRIES, BUT CAN ALSO LEAD TO AN INCREASED NUMBER OF VECTORS: - DO 50 KK=1,NNEW - NN=NVTOT+KK - K=1+MOD(NN-1,MXVEC) -C IF(ISTA+JSTA.EQ.2) THEN -C WRITE(6,'(A,I2,A,I6)')' CNEW NR.',KK,' COPIED TO BUFFER ',K -C WRITE(6,*)' IT CONTAINS:' -C WRITE(6,'(1X,5F15.6)')(CNEW(I,KK),I=1,15) -C END IF - CALL DCOPY_(ISECT,CNEW(1,KK),1,CBUF(JSTA,K),1) -50 CONTINUE -C CONTINUE, NEXT SECTION. -1000 CONTINUE - DO 60 KK=1,NNEW - NN=NVTOT+KK - K=1+MOD(NN-1,MXVEC) -C IF(ISTA.EQ.1) THEN -C WRITE(6,'(A,I2,A,I6)')' BUFFER NR.',K,' WRITTEN AT ',IDCW(K) -C WRITE(6,*)' IT CONTAINS:' -C WRITE(6,'(1X,5F15.6)')(CBUF(I,K),I=1,15) -C END IF - CALL PKVEC(IBUF,CBUF(1,K),ICI) - CALL iDAFILE(LUEIG,1,ICI,IBUF,IDCW(K)) -60 CONTINUE -C CONTINUE, NEXT BUFFER. -2000 CONTINUE - NVTOT=NVTOT+NNEW - RETURN - END diff -Nru openmolcas-22.02/src/mrci/hzlp2.F90 openmolcas-22.10/src/mrci/hzlp2.F90 --- openmolcas-22.02/src/mrci/hzlp2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/hzlp2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,142 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine HZLP2(CBUF,SBUF,DBUF,CSECT,RSECT,XI1,XI2,CNEW,ICI) + +use mrci_global, only: ESMALL, IDFREE, IDISKC, IDISKD, IDISKS, LUEIG, MBUF, MXVEC, MXZ, NCONF, NNEW, NRROOT, NSECT, NVEC, NVTOT, & + VSMALL, VZERO +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(out) :: CBUF(MBUF,MXVEC), SBUF(MBUF,MXVEC), DBUF(MBUF), CSECT(NSECT,MXVEC), RSECT(NSECT,MXVEC), & + XI1(NSECT,NRROOT), XI2(NSECT,NRROOT), CNEW(NSECT,NRROOT) +integer(kind=iwp), intent(out) :: ICI(MBUF) +integer(kind=iwp) :: I, IBUF, IDD, IEND, ISECT, ISTA, IVZ1, IVZ2, IVZ3, IVZ4, IVZSTA, JEND, JSTA, K, KK, NN, NNVEC +integer(kind=iwp), allocatable :: IDCR(:), IDCW(:), IDS(:) + +! THIS SUBROUTINE LOOPS OVER SECTIONS OF PSI AND SIGMA ARRAYS +! ON DISK, AND FORMS A NEW SET OF PSI ARRAYS AS A LINEAR COMBINATION +! OF THE BASIS SET PSI, RHO, XI1 AND XI2. TO FORM THE NEW PSI +! ARRAY, THE FIRST (NRROOT-NNEW) COLUMNS ARE SKIPPED, SINCE THEY +! GIVE NO ESSENTIAL IMPROVEMENT. +IVZSTA = 1+NRROOT-NNEW +IVZ1 = 1 +IVZ2 = 1+NRROOT +IVZ3 = 1+2*NRROOT +IVZ4 = 1+3*NRROOT +!write(u6,*) +!write(u6,*) ' IN HZLP2. NNEW=',NNEW +!if (NVEC < MXVEC) write(u6,*) ' DUMMY WRITES OF NEW FUNCTIONS.' +! WE MAY NEED DUMMY WRITES TO PROVIDE DISK ADDRESSES: +NNVEC = min(NVEC+NNEW,MXVEC) +do K=NVEC+1,NNVEC + IDISKC(K) = IDFREE + !write(u6,'(A,I2,A,I8)') ' IDISKC(',K,')=',IDFREE + do ISTA=1,NCONF,MBUF + IEND = min(NCONF,ISTA+MBUF-1) + IBUF = 1+IEND-ISTA + call iDAFILE(LUEIG,0,ICI,IBUF,IDFREE) + end do +end do +! WE NEED COPIES OF THE DISK ADDRESSES. TWO COPIES FOR PSI BUFFERS. +call mma_allocate(IDCR,NNVEC,label='IDCR') +call mma_allocate(IDCW,NNVEC,label='IDCW') +call mma_allocate(IDS,NNVEC,label='IDS') +do K=1,NNVEC + IDCR(K) = IDISKC(K) + IDCW(K) = IDISKC(K) + IDS(K) = IDISKS(K) +end do +IDD = IDISKD +! LOOP OVER BUFFERS FOR READING PSI, SIGMA AND DBUF: +do ISTA=1,NCONF,MBUF + IEND = min(NCONF,ISTA+MBUF-1) + IBUF = 1+IEND-ISTA + call dDAFILE(LUEIG,2,DBUF,IBUF,IDD) + do K=1,NVEC + call iDAFILE(LUEIG,2,ICI,IBUF,IDCR(K)) + call UPKVEC(IBUF,ICI,CBUF(1,K)) + call dDAFILE(LUEIG,2,SBUF(1,K),IBUF,IDS(K)) + end do + ! LOOP OVER VECTOR SECTIONS, LENGTH AT MOST NSECT: + do JSTA=1,IBUF,NSECT + JEND = min(IBUF,JSTA+NSECT-1) + ISECT = 1+JEND-JSTA + ! TRANSFORM TO EIGENFUNCTIONS OF HSMALL: FIRST, CI SECTION. + call DGEMM_('N','N',ISECT,NRROOT,NVEC,One,CBUF(JSTA,1),MBUF,VSMALL,MXVEC,Zero,CSECT,NSECT) + ! THEN, SIGMA SECTION INTO RSECT. + call DGEMM_('N','N',ISECT,NRROOT,NVEC,One,SBUF(JSTA,1),MBUF,VSMALL,MXVEC,Zero,RSECT,NSECT) + ! AND THEN FORM RSECT=SECTION OF RESIDUAL ARRAY, AND XI1 AND XI2: + do I=1,ISECT + do K=1,NRROOT + RSECT(I,K) = RSECT(I,K)-ESMALL(K)*CSECT(I,K) + XI1(I,K) = CSECT(I,K)/(DBUF(I+JSTA-1)-ESMALL(K)) + XI2(I,K) = RSECT(I,K)/(DBUF(I+JSTA-1)-ESMALL(K)) + end do + end do + ! FORM NEW PSI ARRAYS IN CNEW SECTION: + call DGEMM_('N','N',ISECT,NNEW,NRROOT,One,CSECT,NSECT,VZERO(IVZ1,IVZSTA),MXZ,Zero,CNEW,NSECT) + call DGEMM_('N','N',ISECT,NNEW,NRROOT,One,RSECT,NSECT,VZERO(IVZ2,IVZSTA),MXZ,One,CNEW,NSECT) + call DGEMM_('N','N',ISECT,NNEW,NRROOT,One,XI1,NSECT,VZERO(IVZ3,IVZSTA),MXZ,One,CNEW,NSECT) + call DGEMM_('N','N',ISECT,NNEW,NRROOT,One,XI2,NSECT,VZERO(IVZ4,IVZSTA),MXZ,One,CNEW,NSECT) + !if (ISTA+JSTA == 2) then + ! write(u6,*) ' CONSTRUCTION OF NEW VECTOR IN HZLP2.' + ! write(u6,*) ' CSECT:' + ! write(u6,'(1X,5F15.6)') ((CSECT(I,J),I=1,5),J=1,NNEW) + ! write(u6,*) ' RSECT:' + ! write(u6,'(1X,5F15.6)') ((RSECT(I,J),I=1,5),J=1,NNEW) + ! write(u6,*) ' XI1:' + ! write(u6,'(1X,5F15.6)') ((XI1(I,J),I=1,5),J=1,NNEW) + ! write(u6,*) ' XI2:' + ! write(u6,'(1X,5F15.6)') ((XI2(I,J),I=1,5),J=1,NNEW) + ! write(u6,*) ' VZERO:' + ! IIII = IVZSTA-1 + ! write(u6,'(1X,4F15.6)') ((VZERO(I,IIII+J),I=1,4*NNEW),J=1,NNEW) + ! write(u6,*) ' CNEW:' + ! write(u6,'(1X,5F15.6)') ((CNEW(I,J),I=1,5),J=1,NNEW) + !end if + ! INSERT THE NEW PSI SECTIONS IN BUFFER. THIS MAY IMPLY OVERWRITING + ! OLD ENTRIES, BUT CAN ALSO LEAD TO AN INCREASED NUMBER OF VECTORS: + do KK=1,NNEW + NN = NVTOT+KK + K = 1+mod(NN-1,MXVEC) + !if (ISTA+JSTA == 2) then + ! write(u6,'(A,I2,A,I6)') ' CNEW NR.',KK,' COPIED TO BUFFER ',K + ! write(u6,*) ' IT CONTAINS:' + ! write(u6,'(1X,5F15.6)') (CNEW(I,KK),I=1,15) + !end if + CBUF(JSTA:JSTA+ISECT-1,K) = CNEW(1:ISECT,KK) + end do + ! CONTINUE, NEXT SECTION. + end do + do KK=1,NNEW + NN = NVTOT+KK + K = 1+mod(NN-1,MXVEC) + !if (ISTA == 1) then + ! write(u6,'(A,I2,A,I6)') ' BUFFER NR.',K,' WRITTEN AT ',IDCW(K) + ! write(u6,*) ' IT CONTAINS:' + ! write(u6,'(1X,5F15.6)') (CBUF(I,K),I=1,15) + !end if + call PKVEC(IBUF,CBUF(1,K),ICI) + call iDAFILE(LUEIG,1,ICI,IBUF,IDCW(K)) + end do + ! CONTINUE, NEXT BUFFER. +end do +NVTOT = NVTOT+NNEW +call mma_deallocate(IDCR) +call mma_deallocate(IDCW) +call mma_deallocate(IDS) + +return + +end subroutine HZLP2 diff -Nru openmolcas-22.02/src/mrci/iijj.f openmolcas-22.10/src/mrci/iijj.f --- openmolcas-22.02/src/mrci/iijj.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/iijj.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,99 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE IIJJ(ICSPCK,INTSYM,HDIAG,FC,FIIJJ,FIJIJ) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "mrci.fh" - DIMENSION ICSPCK(*),INTSYM(*),HDIAG(*), - * FC(*),FIIJJ(*),FIJIJ(*) - DIMENSION IOC(55) -* - JO(L)=ICUNP(ICSPCK,L) - JSYM(L)=JSUNP(INTSYM,L) -* - IAD27=0 - II1=0 - ILIM=4 - IF(IFIRST.NE.0)ILIM=2 - IRL=IRC(ILIM) - DO 100 IR=1,IRL - DO 110 I=1,LN - II1=II1+1 - JOJ=JO(II1) - IF(JOJ.GT.1)JOJ=JOJ-1 - IOC(I)=JOJ -110 CONTINUE - NSS=MUL(JSYM(IR),LSYM) - SUM=0.0D00 - DO 111 I=1,LN - IJ=IROW(I) - IF(IOC(I).EQ.0)GO TO 111 - DO 113 J=1,I-1 - IJ=IJ+1 - IF(IOC(J).EQ.0)GO TO 113 - SUM=SUM+IOC(I)*(IOC(J)*FIIJJ(IJ)-FIJIJ(IJ)) -113 CONTINUE - IJ=IJ+1 - SUM=SUM+(IOC(I)-1)*FIIJJ(IJ)+IOC(I)*FC(IJ) -111 CONTINUE - IF(IR.GT.IRC(1))GO TO 120 - HDIAG(IR)=SUM - IF(IR.NE.IRC(1))GO TO 100 - CALL dDAFILE(Lu_27,1,HDIAG,IRC(1),IAD27) - GO TO 100 -120 IND=0 - IF(IR.GT.IRC(2)) GOTO 130 - NA1=NVIRP(NSS)+1 - NA2=NVIRP(NSS)+NVIR(NSS) - IF(NA2.LT.NA1)GO TO 100 - DO 121 NA=NA1,NA2 - IND=IND+1 - IA=IROW(LN+NA) - SUM1=SUM+FC(IA+LN+NA) - DO 122 I=1,LN - IF(IOC(I).EQ.0)GO TO 122 - SUM1=SUM1+IOC(I)*FIIJJ(IA+I)-FIJIJ(IA+I) -122 CONTINUE - HDIAG(IND)=SUM1 -121 CONTINUE - CALL dDAFILE(Lu_27,1,HDIAG,IND,IAD27) - GO TO 100 -130 IND=0 - DO 141 NA=1,NVIRT - NSA=MUL(NSS,NSM(LN+NA)) - NB1=NVIRP(NSA)+1 - NB2=NVIRP(NSA)+NVIR(NSA) - IF(NB2.GT.NA)NB2=NA - IF(NB2.LT.NB1)GO TO 141 - IA=IROW(LN+NA) - IAV=IA+LN - DO 142 NB=NB1,NB2 - IND=IND+1 - IB=IROW(LN+NB) - IBV=IB+LN - TERM=SUM+FIIJJ(IAV+NB)+FC(IAV+NA)+FC(IBV+NB) - IF(IR.LE.IRC(3)) THEN - SUM1=TERM-FIJIJ(IAV+NB) - ELSE - SUM1=TERM+FIJIJ(IAV+NB) - END IF - DO 143 I=1,LN - IF(IOC(I).EQ.0)GO TO 143 - TERM=IOC(I)*(FIIJJ(IA+I)+FIIJJ(IB+I))-FIJIJ(IA+I)-FIJIJ(IB+I) - SUM1=SUM1+TERM -143 CONTINUE - HDIAG(IND)=SUM1 -142 CONTINUE -141 CONTINUE - IF(IND.GT.0)CALL dDAFILE(Lu_27,1,HDIAG,IND,IAD27) -100 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/iijj.F90 openmolcas-22.10/src/mrci/iijj.F90 --- openmolcas-22.02/src/mrci/iijj.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/iijj.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,107 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine IIJJ(ICSPCK,INTSYM,HDIAG,FC,FIIJJ,FIJIJ) + +use mrci_global, only: IFIRST, IRC, IROW, LN, LSYM, Lu_27, NSM, NVIR, NVIRP, NVIRT +use Symmetry_Info, only: Mul +use Constants, only: Zero +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: ICSPCK(*), INTSYM(*) +real(kind=wp), intent(_OUT_) :: HDIAG(*) +real(kind=wp), intent(in) :: FC(*), FIIJJ(*), FIJIJ(*) +integer(kind=iwp) :: I, IA, IAD27, IAV, IB, IBV, II1, IJ, ILIM, IND, IOC(55), IR, IRL, J, JOJ, NA, NA1, NA2, NB, NB1, NB2, NSA, NSS +real(kind=wp) :: SUM1, SUM2, TERM +integer(kind=iwp), external :: ICUNP, JSUNP + +IAD27 = 0 +II1 = 0 +ILIM = 4 +if (IFIRST /= 0) ILIM = 2 +IRL = IRC(ILIM) +do IR=1,IRL + do I=1,LN + II1 = II1+1 + JOJ = ICUNP(ICSPCK,II1) + if (JOJ > 1) JOJ = JOJ-1 + IOC(I) = JOJ + end do + NSS = MUL(JSUNP(INTSYM,IR),LSYM) + SUM1 = Zero + do I=1,LN + IJ = IROW(I) + if (IOC(I) == 0) cycle + do J=1,I-1 + IJ = IJ+1 + if (IOC(J) /= 0) SUM1 = SUM1+IOC(I)*(IOC(J)*FIIJJ(IJ)-FIJIJ(IJ)) + end do + IJ = IJ+1 + SUM1 = SUM1+(IOC(I)-1)*FIIJJ(IJ)+IOC(I)*FC(IJ) + end do + if (IR <= IRC(1)) then + HDIAG(IR) = SUM1 + if (IR == IRC(1)) call dDAFILE(Lu_27,1,HDIAG,IRC(1),IAD27) + else + IND = 0 + if (IR <= IRC(2)) then + NA1 = NVIRP(NSS)+1 + NA2 = NVIRP(NSS)+NVIR(NSS) + do NA=NA1,NA2 + IND = IND+1 + IA = IROW(LN+NA) + SUM2 = SUM1+FC(IA+LN+NA) + do I=1,LN + if (IOC(I) /= 0) SUM2 = SUM2+IOC(I)*FIIJJ(IA+I)-FIJIJ(IA+I) + end do + HDIAG(IND) = SUM2 + end do + call dDAFILE(Lu_27,1,HDIAG,IND,IAD27) + else + IND = 0 + do NA=1,NVIRT + NSA = MUL(NSS,NSM(LN+NA)) + NB1 = NVIRP(NSA)+1 + NB2 = NVIRP(NSA)+NVIR(NSA) + if (NB2 > NA) NB2 = NA + if (NB2 < NB1) cycle + IA = IROW(LN+NA) + IAV = IA+LN + do NB=NB1,NB2 + IND = IND+1 + IB = IROW(LN+NB) + IBV = IB+LN + TERM = SUM1+FIIJJ(IAV+NB)+FC(IAV+NA)+FC(IBV+NB) + if (IR <= IRC(3)) then + SUM2 = TERM-FIJIJ(IAV+NB) + else + SUM2 = TERM+FIJIJ(IAV+NB) + end if + do I=1,LN + if (IOC(I) /= 0) then + TERM = IOC(I)*(FIIJJ(IA+I)+FIIJJ(IB+I))-FIJIJ(IA+I)-FIJIJ(IB+I) + SUM2 = SUM2+TERM + end if + end do + HDIAG(IND) = SUM2 + end do + end do + if (IND > 0) call dDAFILE(Lu_27,1,HDIAG,IND,IAD27) + end if + end if +end do + +return + +end subroutine IIJJ diff -Nru openmolcas-22.02/src/mrci/ijij.f openmolcas-22.10/src/mrci/ijij.f --- openmolcas-22.02/src/mrci/ijij.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/ijij.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,167 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE IJIJ(INTSYM,HDIAG,FC,FIJIJ) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "mrci.fh" - DIMENSION INTSYM(*),HDIAG(*),FC(*), - * FIJIJ(*) - DIMENSION HCOUT(nCOP) -* - JSYM(L)=JSUNP(INTSYM,L) -*------ -* POW: Unnecessary but warning stopping initializations - inb=-1234567 -*------ - IADD25=IAD25S - IAD27=0 - IREF0=1 - CALL dDAFILE(Lu_27,2,HDIAG,IRC(1),IAD27) -* -* WRITE(6,*) ' Hdiag' -* WRITE(6,*) ( Hdiag(i),i=1,IRC(1) ) -* - IFS=0 - IVL=0 - IVSAVE=0 - ICOUPS=0 - ICOUP =0 - NSS=1 - IOUT=0 - ICHK=0 - IADD10=IAD10(3) - TERM=0.0D00 -300 CONTINUE -C READ A COP BUFFER: - CALL dDAFILE(LUSYMB,2,COP,nCOP,IADD10) - CALL iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) - LENGTH=ICOP1(nCOP+1) - IF(LENGTH.EQ.0)GO TO 300 - IF(LENGTH.LT.0)GO TO 350 -C LOOP OVER THE COP BUFFER: - DO 360 II=1,LENGTH - IND=ICOP1(II) - IF(ICHK.NE.0)GO TO 460 - IF(IND.NE.0)GO TO 361 - ICHK=1 - GO TO 360 -460 ICHK=0 - INDI=IND -* ICOUP=MOD(INDI,2**16) -* IVL=MOD(INDI/2**16,2**8) - ICOUP=IBITS(INDI, 0,16) - IVL=IBITS(INDI,16,8) - ICHK=0 - INS=1 - IF(IVSAVE.EQ.IVVER) THEN - INS=ICOUPS - INB=ICOUPS - END IF - IF(INB.NE.0) THEN - DO 10 J=INS,INB - IOUT=IOUT+1 - HCOUT(IOUT)=HDIAG(J) - IF(IOUT.LT.nCOP)GO TO 10 - IF(IFS.EQ.0)THEN - POTNUC=HCOUT(IREF0) - IFS=1 - END IF - DO 8831 KK=1,nCOP - HCOUT(KK)=HCOUT(KK)-POTNUC -8831 CONTINUE - CALL dDAFILE(Lu_25,1,HCOUT,nCOP,IADD25) - IOUT=0 -10 CONTINUE - END IF - IF(IVL.NE.IVVER) THEN - JJ=IRC(IVL)+ICOUP - NSS=MUL(JSYM(JJ),LSYM) - IF(IVL.EQ.IDVER)THEN - INB=NVIR(NSS) - ELSE - INB=NVPAIR(NSS) - END IF - IF(INB.GT.0)CALL dDAFILE(Lu_27,2,HDIAG,INB,IAD27) - END IF - IVSAVE=IVL - ICOUPS=ICOUP - GO TO 360 -361 CONTINUE -* ITYP=MOD(IND,2) -* IJJ=MOD(IND/2,2**11) - ITYP=IBITS(IND,0,1) - IJJ=IBITS(IND,1,11) - IF(ITYP.EQ.0)TERM=COP(II)*FIJIJ(IJJ) - IF(IVL.EQ.IVVER) THEN - INB=ICOUP - HDIAG(INB)=HDIAG(INB)+TERM - ELSE IF(IVL.EQ.IDVER) THEN - INB=0 - NA1=NVIRP(NSS)+1 - NA2=NVIRP(NSS)+NVIR(NSS) - IF(NA2.LT.NA1)GO TO 360 - DO 365 NA=NA1,NA2 - INB=INB+1 - IF(ITYP.EQ.1) THEN - IIJ=IROW(LN+NA)+IJJ - TERM=COP(II)*FIJIJ(IIJ) - END IF - HDIAG(INB)=HDIAG(INB)+TERM -365 CONTINUE - ELSE - INB=0 - DO 375 NA=1,NVIRT - NSA=MUL(NSS,NSM(LN+NA)) - NB1=NVIRP(NSA)+1 - NB2=NVIRP(NSA)+NVIR(NSA) - IF(NB2.GT.NA)NB2=NA - IF(NB2.LT.NB1)GO TO 375 - IIJ1=IROW(LN+NA)+IJJ - DO 376 NB=NB1,NB2 - INB=INB+1 - IF(ITYP.EQ.1) THEN - IIJ2=IROW(LN+NB)+IJJ - TERM=COP(II)*(FIJIJ(IIJ1)+FIJIJ(IIJ2)) - END IF - HDIAG(INB)=HDIAG(INB)+TERM -376 CONTINUE -375 CONTINUE - END IF -360 CONTINUE - GO TO 300 -C EMPTY LAST BUFFER -350 CONTINUE - DO 20 J=1,INB - IOUT=IOUT+1 - HCOUT(IOUT)=HDIAG(J) - IF(IOUT.LT.nCOP)GO TO 20 - IF(IFS.EQ.0)THEN - POTNUC=HCOUT(IREF0) - IFS=1 - END IF - DO 8830 KK=1,nCOP - HCOUT(KK)=HCOUT(KK)-POTNUC -8830 CONTINUE - CALL dDAFILE(Lu_25,1,HCOUT,nCOP,IADD25) - IOUT=0 -20 CONTINUE - IF(IFS.EQ.0)THEN - POTNUC=HCOUT(IREF0) - IFS=1 - END IF - DO 8829 KK=1,IOUT - HCOUT(KK)=HCOUT(KK)-POTNUC -8829 CONTINUE - CALL dDAFILE(Lu_25,1,HCOUT,nCOP,IADD25) - RETURN -c Avoid unused argument warnings - IF (.FALSE.) CALL Unused_real_array(FC) - END diff -Nru openmolcas-22.02/src/mrci/ijij.F90 openmolcas-22.10/src/mrci/ijij.F90 --- openmolcas-22.02/src/mrci/ijij.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/ijij.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,176 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine IJIJ(INTSYM,HDIAG,FIJIJ) + +use mrci_global, only: IAD25S, IDVER, IRC, IROW, IVVER, LN, LSYM, Lu_25, Lu_27, LUSYMB, NSM, NVIR, NVIRT, NVPAIR, NVIRP, POTNUC +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Constants, only: Zero +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: INTSYM(*) +real(kind=wp), intent(_OUT_) :: HDIAG(*) +real(kind=wp), intent(in) :: FIJIJ(*) +integer(kind=iwp) :: IAD27, IADD10, IADD25, ICHK, ICOUP, ICOUPS, IFS, II, IIJ, IIJ1, IIJ2, IJJ, INB, IND, INDI, INS, IOUT, IREF0, & + ITYP, IVL, IVSAVE, J, JJ, KK, LENGTH, NA, NA1, NA2, NB, NB1, NB2, NSA, NSS +real(kind=wp) :: HCOUT(nCOP), TERM +integer(kind=iwp), external :: JSUNP + +!------ +! POW: Unnecessary but warning stopping initializations +INB = -1234567 +!------ +IADD25 = IAD25S +IAD27 = 0 +IREF0 = 1 +call dDAFILE(Lu_27,2,HDIAG,IRC(1),IAD27) + +!write(u6,*) ' Hdiag' +!write(u6,*) (Hdiag(i),i=1,IRC(1)) + +IFS = 0 +IVL = 0 +IVSAVE = 0 +ICOUPS = 0 +ICOUP = 0 +NSS = 1 +IOUT = 0 +ICHK = 0 +IADD10 = IAD10(3) +TERM = Zero +do + ! READ A COP BUFFER: + call dDAFILE(LUSYMB,2,COP,nCOP,IADD10) + call iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) + LENGTH = ICOP1(nCOP+1) + if (LENGTH < 0) exit + ! LOOP OVER THE COP BUFFER: + do II=1,LENGTH + IND = ICOP1(II) + if (ICHK == 0) then + if (IND == 0) then + ICHK = 1 + else + !ITYP = mod(IND,2) + !IJJ = mod(IND/2,2**11) + ITYP = ibits(IND,0,1) + IJJ = ibits(IND,1,11) + if (ITYP == 0) TERM = COP(II)*FIJIJ(IJJ) + if (IVL == IVVER) then + INB = ICOUP + HDIAG(INB) = HDIAG(INB)+TERM + else if (IVL == IDVER) then + INB = 0 + NA1 = NVIRP(NSS)+1 + NA2 = NVIRP(NSS)+NVIR(NSS) + do NA=NA1,NA2 + INB = INB+1 + if (ITYP == 1) then + IIJ = IROW(LN+NA)+IJJ + TERM = COP(II)*FIJIJ(IIJ) + end if + HDIAG(INB) = HDIAG(INB)+TERM + end do + else + INB = 0 + do NA=1,NVIRT + NSA = MUL(NSS,NSM(LN+NA)) + NB1 = NVIRP(NSA)+1 + NB2 = NVIRP(NSA)+NVIR(NSA) + if (NB2 > NA) NB2 = NA + if (NB2 < NB1) cycle + IIJ1 = IROW(LN+NA)+IJJ + do NB=NB1,NB2 + INB = INB+1 + if (ITYP == 1) then + IIJ2 = IROW(LN+NB)+IJJ + TERM = COP(II)*(FIJIJ(IIJ1)+FIJIJ(IIJ2)) + end if + HDIAG(INB) = HDIAG(INB)+TERM + end do + end do + end if + end if + else + ICHK = 0 + INDI = IND + !ICOUP = mod(INDI,2**16) + !IVL = mod(INDI/2**16,2**8) + ICOUP = ibits(INDI,0,16) + IVL = ibits(INDI,16,8) + ICHK = 0 + INS = 1 + if (IVSAVE == IVVER) then + INS = ICOUPS + INB = ICOUPS + end if + if (INB /= 0) then + do J=INS,INB + IOUT = IOUT+1 + HCOUT(IOUT) = HDIAG(J) + if (IOUT < nCOP) cycle + if (IFS == 0) then + POTNUC = HCOUT(IREF0) + IFS = 1 + end if + do KK=1,nCOP + HCOUT(KK) = HCOUT(KK)-POTNUC + end do + call dDAFILE(Lu_25,1,HCOUT,nCOP,IADD25) + IOUT = 0 + end do + end if + if (IVL /= IVVER) then + JJ = IRC(IVL)+ICOUP + NSS = MUL(JSUNP(INTSYM,JJ),LSYM) + if (IVL == IDVER) then + INB = NVIR(NSS) + else + INB = NVPAIR(NSS) + end if + if (INB > 0) call dDAFILE(Lu_27,2,HDIAG,INB,IAD27) + end if + IVSAVE = IVL + ICOUPS = ICOUP + end if + end do +end do +! EMPTY LAST BUFFER +do J=1,INB + IOUT = IOUT+1 + HCOUT(IOUT) = HDIAG(J) + if (IOUT < nCOP) cycle + if (IFS == 0) then + POTNUC = HCOUT(IREF0) + IFS = 1 + end if + do KK=1,nCOP + HCOUT(KK) = HCOUT(KK)-POTNUC + end do + call dDAFILE(Lu_25,1,HCOUT,nCOP,IADD25) + IOUT = 0 +end do +if (IFS == 0) then + POTNUC = HCOUT(IREF0) + IFS = 1 +end if +do KK=1,IOUT + HCOUT(KK) = HCOUT(KK)-POTNUC +end do +call dDAFILE(Lu_25,1,HCOUT,nCOP,IADD25) + +return + +end subroutine IJIJ diff -Nru openmolcas-22.02/src/mrci/ijkl.f openmolcas-22.10/src/mrci/ijkl.f --- openmolcas-22.02/src/mrci/ijkl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/ijkl.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,92 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE IJKL(INTSYM,INDX,C,S,FIJKL) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "mrci.fh" - DIMENSION INTSYM(*),INDX(*),C(*),S(*), - * FIJKL(*) -* - JSYM(L)=JSUNP(INTSYM,L) -*------ -* POW: Unnecessary but warning stopping initialization - fini=1.0d30 -*------ - ICHK=0 - NIJ=IROW(LN+1) - NIJKL=NIJ*(NIJ+1)/2 - CALL FZERO(FIJKL,NIJKL) - IADR=LASTAD(1) -201 CALL dDAFILE(Lu_70,2,VALSRT,NSRTMX,IADR) - CALL iDAFILE(Lu_70,2,INDSRT,NSRTMX+2,IADR) - LENGTH=INDSRT(NSRTMX+1) - IADR=INDSRT(NSRTMX+2) -* IF(LENGTH.GT.0) CALL SCATTER(LENGTH,FIJKL,INDSRT,VALSRT) - do i=1,length - FIJKL(INDSRT(i))=VALSRT(i) - end do - IF(IADR.NE.-1) GO TO 201 - IADD10=IAD10(5) -100 CALL dDAFILE(LUSYMB,2,COP,nCOP,IADD10) - CALL iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.EQ.0)GO TO 100 - IF(LEN.LT.0)GO TO 200 - DO 10 IN=1,LEN - IND=ICOP1(IN) - IF(ICHK.NE.0) THEN - ICHK=0 - INDI=IND -* IP=MOD(INDI,2**8) -* JP=MOD(INDI/2**8,2**8) -* KP=MOD(INDI/2**16,2**8) -* LP=MOD(INDI/2**24,2**8) - IP=IBITS(INDI, 0,8) - JP=IBITS(INDI, 8,8) - KP=IBITS(INDI,16,8) - LP=IBITS(INDI,24,8) - NIJ=IROW(IP)+JP - NKL=IROW(KP)+LP - IND=NIJ*(NIJ-1)/2+NKL - FINI=FIJKL(IND) - GOTO 10 - END IF - IF(IND.EQ.0) THEN - ICHK=1 - GOTO 10 - END IF -* IVL=MOD(IND,2**6) -* IC2=MOD(IND/2**6,2**13) -* IC1=MOD(IND/2**19,2**13) - IVL=IBITS(IND, 0, 6) - IC2=IBITS(IND, 6,13) - IC1=IBITS(IND,19,13) - COPI=COP(IN)*FINI - IF(IVL.EQ.0) THEN - S(IC1)=S(IC1)+COPI*C(IC2) - S(IC2)=S(IC2)+COPI*C(IC1) - GO TO 10 - END IF - INDA=IRC(IVL)+IC1 - INDB=IRC(IVL)+IC2 - NA=INDX(INDA) - NB=INDX(INDB) - NS1=JSYM(INDA) - NS1L=MUL(NS1,LSYM) - INUM=NVIR(NS1L) - IF(IVL.GE.2)INUM=NVPAIR(NS1L) - CALL DAXPY_(INUM,COPI,C(NB+1),1,S(NA+1),1) - CALL DAXPY_(INUM,COPI,C(NA+1),1,S(NB+1),1) -10 CONTINUE - GO TO 100 -200 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/ijkl.F90 openmolcas-22.10/src/mrci/ijkl.F90 --- openmolcas-22.02/src/mrci/ijkl.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/ijkl.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,98 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine IJKL(INTSYM,INDX,C,S,FIJKL) + +use mrci_global, only: INDSRT, IRC, IROW, LASTAD, Lu_70, LUSYMB, LN, LSYM, NSRTMX, NVIR, NVPAIR, VALSRT +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Constants, only: Zero +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: INTSYM(*), INDX(*) +real(kind=wp), intent(in) :: C(*) +real(kind=wp), intent(inout) :: S(*) +real(kind=wp), intent(_OUT_) :: FIJKL(*) +integer(kind=iwp) :: i, IADD10, IADR, IC1, IC2, ICHK, IIN, ILEN, IND, INDA, INDB, INDI, INUM, IP, IVL, JP, KP, LENGTH, LP, NA, NB, & + NIJ, NIJKL, NKL, NS1, NS1L +real(kind=wp) :: COPI, FINI +integer(kind=iwp), external :: JSUNP + +!------ +! POW: Unnecessary but warning stopping initialization +FINI = huge(FINI) +!------ +ICHK = 0 +NIJ = IROW(LN+1) +NIJKL = NIJ*(NIJ+1)/2 +FIJKL(1:NIJKL) = Zero +IADR = LASTAD(1) +do + call dDAFILE(Lu_70,2,VALSRT,NSRTMX,IADR) + call iDAFILE(Lu_70,2,INDSRT,NSRTMX+2,IADR) + LENGTH = INDSRT(NSRTMX+1) + IADR = INDSRT(NSRTMX+2) + do i=1,length + FIJKL(INDSRT(i)) = VALSRT(i) + end do + if (IADR == -1) exit +end do +IADD10 = IAD10(5) +do + call dDAFILE(LUSYMB,2,COP,nCOP,IADD10) + call iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN < 0) exit + do IIN=1,ILEN + IND = ICOP1(IIN) + if (ICHK /= 0) then + ICHK = 0 + INDI = IND + IP = ibits(INDI,0,8) + JP = ibits(INDI,8,8) + KP = ibits(INDI,16,8) + LP = ibits(INDI,24,8) + NIJ = IROW(IP)+JP + NKL = IROW(KP)+LP + IND = NIJ*(NIJ-1)/2+NKL + FINI = FIJKL(IND) + else if (IND == 0) then + ICHK = 1 + else + IVL = ibits(IND,0,6) + IC2 = ibits(IND,6,13) + IC1 = ibits(IND,19,13) + COPI = COP(IIN)*FINI + if (IVL == 0) then + S(IC1) = S(IC1)+COPI*C(IC2) + S(IC2) = S(IC2)+COPI*C(IC1) + else + INDA = IRC(IVL)+IC1 + INDB = IRC(IVL)+IC2 + NA = INDX(INDA) + NB = INDX(INDB) + NS1 = JSUNP(INTSYM,INDA) + NS1L = MUL(NS1,LSYM) + INUM = NVIR(NS1L) + if (IVL >= 2) INUM = NVPAIR(NS1L) + S(NA+1:NA+INUM) = S(NA+1:NA+INUM)+COPI*C(NB+1:NB+INUM) + S(NB+1:NB+INUM) = S(NB+1:NB+INUM)+COPI*C(NA+1:NA+INUM) + end if + end if + end do +end do + +return + +end subroutine IJKL diff -Nru openmolcas-22.02/src/mrci/indmat.f openmolcas-22.10/src/mrci/indmat.f --- openmolcas-22.02/src/mrci/indmat.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/indmat.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,149 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE INDMAT(ICSPCK,INTSYM,INDX,ISAB,JREFX,CISEL) - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "mrci.fh" - DIMENSION INDX(*),ICSPCK(*),INTSYM(*) - DIMENSION ISAB(NVIRT,NVIRT),JREFX(*) - DIMENSION CISEL(NREF,NSEL) - CHARACTER*20 STR20 -CPAM97 EXTERNAL UNPACK -CPAM97 INTEGER UNPACK -CPAM97 JCASE(L)=UNPACK(CSPCK((L+29)/30), 2*L-(2*L-1)/60*60, 2) - JCASE(L)=ICUNP(ICSPCK,L) -CPAM96 JSYM(L)=UNPACK(INTSYM((L+9)/10),3*MOD(L-1,10)+1,3)+1 - JSYM(L)=JSUNP(INTSYM,L) -C - ILIM=4 - IF(IFIRST.NE.0)ILIM=2 - DO 5 I=1,NSYM - NVPAIR(I)=0 -5 CONTINUE - ISMAX=0 - DO 15 NA=1,NVIRT - DO 25 NB=1,NA - NSAB=MUL(NSM(LN+NA),NSM(LN+NB)) - NVPAIR(NSAB)=NVPAIR(NSAB)+1 - ISAB(NA,NB)=NVPAIR(NSAB) - ISMAX=MAX(ISMAX,ISAB(NA,NB)) - ISAB(NB,NA)=ISAB(NA,NB) -25 CONTINUE - NDIAG(NA)=ISAB(NA,NA) -15 CONTINUE -C INDX - STARTING POINT IN CI VECTOR OF EACH BLOCK WITH A -C COMMON INTERNAL WALK. -C VALENCE CONFIGURATIONS: - IR=IRC(1) - DO 10 II=1,IR - INDX(II)=II -10 CONTINUE - JSC(1)=IR -C SINGLY EXCITED CONFIGURATIONS: - IR1=IR+1 - IR2=IRC(2) - IND=IR - DO 20 II=IR1,IR2 - INDX(II)=IND - NSS=MUL(JSYM(II),LSYM) - IND=IND+NVIR(NSS) -20 CONTINUE - JSC(2)=IND - NCDOUB=IND-JSC(1) - IF(IFIRST.EQ.0) THEN -C DOUBLY EXCITED CONFIGURATIONS: - IR1=IR2+1 - IR2=IRC(4) - JSC(3)=JSC(2) - DO 30 II=IR1,IR2 - INDX(II)=IND - NSS=MUL(JSYM(II),LSYM) - IND=IND+NVPAIR(NSS) - IF(II.EQ.IRC(3))JSC(3)=IND -30 CONTINUE - JSC(4)=IND - JJM=(JJS(LSYM+1)-JJS(LSYM))*NVIRT - NCTRIP=JSC(3)-JSC(2)-JJM - NCSING=JSC(4)-JSC(3) - ELSE - JJM=0 - NCTRIP=0 - NCSING=0 - END IF - NCONF=JSC(ILIM) -C LIST THE REFERENCE CONFIGURATIONS, AND AT THE SAME TIME, -C IDENTIFY CSFS GIVEN IN SELECTION VECTOR INPUT: - WRITE(6,*) - CALL XFLUSH(6) - WRITE(6,*)' LIST OF REFERENCE CONFIGURATIONS.' - CALL XFLUSH(6) - WRITE(6,*)' CONF NR: GUGA CASE NUMBERS OF ACTIVE ORBITALS:' - CALL XFLUSH(6) - DO 135 I=1,IRC(1) - IREF=JREFX(I) - IF(IREF.EQ.0) GOTO 135 - IREFX(IREF)=I - IOFF=LN*(I-1) - WRITE(6,'(5X,I6,7X,30I1)') I,(JCASE(IOFF+J),J=1,LN) - CALL XFLUSH(6) - JJ=0 - DO 134 ISEL=1,NSEL - CISEL(IREF,ISEL)=0.0D00 - NC=NCOMP(ISEL) - DO 133 IC=1,NC - STR20=SSEL(JJ+IC) - DO 132 ILEV=1,LN - JCAS1=JCASE(IOFF+ILEV) - READ(STR20(ILEV:ILEV),'(I1)') JCAS2 - IF(JCAS1.NE.JCAS2) GOTO 133 -132 CONTINUE - CISEL(IREF,ISEL)=CSEL(JJ+IC) - JJ=JJ+NC - GOTO 134 -133 CONTINUE - JJ=JJ+NC -134 CONTINUE -135 CONTINUE -C ORTHONORMALIZE THE SELECTION VECTORS: - DO 137 ISEL=1,NSEL - DO 136 JSEL=1,ISEL-1 - X=DDOT_(NREF,CISEL(1,JSEL),1,CISEL(1,ISEL),1) - CALL DAXPY_(NREF,-X,CISEL(1,JSEL),1,CISEL(1,ISEL),1) -136 CONTINUE - X=1.0D00/DDOT_(NREF,CISEL(1,ISEL),1,CISEL(1,ISEL),1) - CALL DSCAL_(NREF,X,CISEL(1,ISEL),1) -137 CONTINUE - WRITE(6,*) - CALL XFLUSH(6) - WRITE(6,*)' REAL CONFIGURATIONS:' - CALL XFLUSH(6) - IF(IFIRST.EQ.0) THEN - WRITE(6,215)NREF,NCVAL-NREF,NCDOUB,NCTRIP,NCSING - CALL XFLUSH(6) -215 FORMAT(/,6X,' REFERENCE ',I8, - * /,6X,' OTHER VALENCE ',I8, - * /,6X,' DOUBLET COUPLED SINGLES ',I8, - * /,6X,' TRIPLET COUPLED DOUBLES ',I8, - * /,6X,' SINGLET COUPLED DOUBLES ',I8) - ELSE - WRITE(6,216)NREF,NCVAL-NREF,NCDOUB - CALL XFLUSH(6) -216 FORMAT(/,6X,' REFERENCE ',I8, - * /,6X,' OTHER VALENCE ',I8, - * /,6X,' DOUBLET COUPLED SINGLES ',I8) - END IF - JSCI=JSC(ILIM)-JJM - WRITE(6,'(6X,A,I8)')' TOTAL ',JSCI - CALL XFLUSH(6) - RETURN - END diff -Nru openmolcas-22.02/src/mrci/indmat.F90 openmolcas-22.10/src/mrci/indmat.F90 --- openmolcas-22.02/src/mrci/indmat.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/indmat.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,151 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine INDMAT(ICSPCK,INTSYM,INDX,ISAB,JREFX,CISEL) + +use mrci_global, only: CSEL, IFIRST, IRC, IREFX, ISMAX, JJS, JSC, LN, LSYM, NCOMP, NCONF, NCVAL, NDIAG, NREF, NSEL, NSM, NSYM, & + NVIR, NVIRT, NVPAIR, SSEL +use Symmetry_Info, only: Mul +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: ICSPCK(*), INTSYM(*), JREFX(*) +integer(kind=iwp), intent(_OUT_) :: INDX(*) +integer(kind=iwp), intent(out) :: ISAB(NVIRT,NVIRT) +real(kind=wp), intent(out) :: CISEL(NREF,NSEL) +integer(kind=iwp) :: I, IC, II, ILEV, ILIM, IND, IOFF, IR, IR1, IR2, IREF, ISEL, J, JCAS1, JCAS2, JJ, JJM, JSCI, JSEL, NA, NB, NC, & + NCDOUB, NCSING, NCTRIP, NSAB, NSS +real(kind=wp) :: X +logical(kind=iwp) :: Skip +character(len=20) :: STR20 +integer(kind=iwp), external :: ICUNP, JSUNP +real(kind=r8), external :: DDOT_ + +ILIM = 4 +if (IFIRST /= 0) ILIM = 2 +do I=1,NSYM + NVPAIR(I) = 0 +end do +ISMAX = 0 +do NA=1,NVIRT + do NB=1,NA + NSAB = MUL(NSM(LN+NA),NSM(LN+NB)) + NVPAIR(NSAB) = NVPAIR(NSAB)+1 + ISAB(NA,NB) = NVPAIR(NSAB) + ISMAX = max(ISMAX,ISAB(NA,NB)) + ISAB(NB,NA) = ISAB(NA,NB) + end do + NDIAG(NA) = ISAB(NA,NA) +end do +! INDX - STARTING POINT IN CI VECTOR OF EACH BLOCK WITH A +! COMMON INTERNAL WALK. +! VALENCE CONFIGURATIONS: +IR = IRC(1) +do II=1,IR + INDX(II) = II +end do +JSC(1) = IR +! SINGLY EXCITED CONFIGURATIONS: +IR1 = IR+1 +IR2 = IRC(2) +IND = IR +do II=IR1,IR2 + INDX(II) = IND + NSS = MUL(JSUNP(INTSYM,II),LSYM) + IND = IND+NVIR(NSS) +end do +JSC(2) = IND +NCDOUB = IND-JSC(1) +if (IFIRST == 0) then + ! DOUBLY EXCITED CONFIGURATIONS: + IR1 = IR2+1 + IR2 = IRC(4) + JSC(3) = JSC(2) + do II=IR1,IR2 + INDX(II) = IND + NSS = MUL(JSUNP(INTSYM,II),LSYM) + IND = IND+NVPAIR(NSS) + if (II == IRC(3)) JSC(3) = IND + end do + JSC(4) = IND + JJM = (JJS(LSYM+1)-JJS(LSYM))*NVIRT + NCTRIP = JSC(3)-JSC(2)-JJM + NCSING = JSC(4)-JSC(3) +else + JJM = 0 + NCTRIP = 0 + NCSING = 0 +end if +NCONF = JSC(ILIM) +! LIST THE REFERENCE CONFIGURATIONS, AND AT THE SAME TIME, +! IDENTIFY CSFS GIVEN IN SELECTION VECTOR INPUT: +write(u6,*) +write(u6,*) ' LIST OF REFERENCE CONFIGURATIONS.' +write(u6,*) ' CONF NR: GUGA CASE NUMBERS OF ACTIVE ORBITALS:' +do I=1,IRC(1) + IREF = JREFX(I) + if (IREF == 0) cycle + IREFX(IREF) = I + IOFF = LN*(I-1) + write(u6,'(5X,I6,7X,30I1)') I,(ICUNP(ICSPCK,IOFF+J),J=1,LN) + JJ = 0 + loop1: do ISEL=1,NSEL + CISEL(IREF,ISEL) = Zero + NC = NCOMP(ISEL) + do IC=1,NC + STR20 = SSEL(JJ+IC) + Skip = .false. + do ILEV=1,LN + JCAS1 = ICUNP(ICSPCK,IOFF+ILEV) + read(STR20(ILEV:ILEV),'(I1)') JCAS2 + if (JCAS1 /= JCAS2) then + Skip = .true. + exit + end if + end do + if (.not. Skip) then + CISEL(IREF,ISEL) = CSEL(JJ+IC) + JJ = JJ+NC + cycle loop1 + end if + end do + JJ = JJ+NC + end do loop1 +end do +! ORTHONORMALIZE THE SELECTION VECTORS: +do ISEL=1,NSEL + do JSEL=1,ISEL-1 + X = DDOT_(NREF,CISEL(:,JSEL),1,CISEL(:,ISEL),1) + CISEL(:,ISEL) = CISEL(:,ISEL)-X*CISEL(:,JSEL) + end do + X = One/DDOT_(NREF,CISEL(:,ISEL),1,CISEL(:,ISEL),1) + CISEL(:,ISEL) = X*CISEL(:,ISEL) +end do +write(u6,*) +write(u6,*) ' REAL CONFIGURATIONS:' +if (IFIRST == 0) then + write(u6,215) NREF,NCVAL-NREF,NCDOUB,NCTRIP,NCSING +else + write(u6,216) NREF,NCVAL-NREF,NCDOUB +end if +JSCI = JSC(ILIM)-JJM +write(u6,'(6X,A,I8)') ' TOTAL ',JSCI + +return + +215 format(/,6X,' REFERENCE ',I8,/,6X,' OTHER VALENCE ',I8,/,6X,' DOUBLET COUPLED SINGLES ',I8, & + /,6X,' TRIPLET COUPLED DOUBLES ',I8,/,6X,' SINGLET COUPLED DOUBLES ',I8) +216 format(/,6X,' REFERENCE ',I8,/,6X,' OTHER VALENCE ',I8,/,6X,' DOUBLET COUPLED SINGLES ',I8) + +end subroutine INDMAT diff -Nru openmolcas-22.02/src/mrci/ipo.f openmolcas-22.10/src/mrci/ipo.f --- openmolcas-22.02/src/mrci/ipo.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/ipo.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE IPO(IPOA,NVIR,MUL,NSYM,KLS,IFT) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION IPOA(*),NVIR(*),MUL(8,8) - NSUM=0 - IF(IFT.LT.0) THEN - DO 10 N=1,NSYM - IPOA(N)=NSUM - M=MUL(N,KLS) - NSUM=NSUM+NVIR(N)*NVIR(M) -10 CONTINUE - ELSE - IF (KLS.EQ.1) THEN - DO 20 N=1,NSYM - IPOA(N)=NSUM - NSUM=NSUM+(NVIR(N)*(NVIR(N)+1))/2 -20 CONTINUE - ELSE - DO 30 N=1,NSYM - IPOA(N)=NSUM - M=MUL(N,KLS) - IF(N.GT.M) THEN - NSUM=NSUM+NVIR(N)*NVIR(M) - END IF -30 CONTINUE - END IF - END IF - IPOA(NSYM+1)=NSUM - RETURN - END diff -Nru openmolcas-22.02/src/mrci/ipo.F90 openmolcas-22.10/src/mrci/ipo.F90 --- openmolcas-22.02/src/mrci/ipo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/ipo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,48 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine IPO(IPOA,NVIR,MUL,NSYM,KLS,IFT) + +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: NVIR(*), MUL(8,8), NSYM, KLS, IFT +integer(kind=iwp), intent(out) :: IPOA(NSYM+1) +integer(kind=iwp) :: M, N, NSUM + +NSUM = 0 +if (IFT < 0) then + do N=1,NSYM + IPOA(N) = NSUM + M = MUL(N,KLS) + NSUM = NSUM+NVIR(N)*NVIR(M) + end do +else + if (KLS == 1) then + do N=1,NSYM + IPOA(N) = NSUM + NSUM = NSUM+(NVIR(N)*(NVIR(N)+1))/2 + end do + else + do N=1,NSYM + IPOA(N) = NSUM + M = MUL(N,KLS) + if (N > M) then + NSUM = NSUM+NVIR(N)*NVIR(M) + end if + end do + end if +end if +IPOA(NSYM+1) = NSUM + +return + +end subroutine IPO diff -Nru openmolcas-22.02/src/mrci/jsunp.f openmolcas-22.10/src/mrci/jsunp.f --- openmolcas-22.02/src/mrci/jsunp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/jsunp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - INTEGER FUNCTION JSUNP(INTSYM,L) - DIMENSION INTSYM(*) - -c INTW=INTSYM((L+9)/10) -c IPOW=2**(27-3*MOD(L-1,10)) -c JSUNP=1+MOD(INTW/IPOW,8) - JSUNP=1+MOD(INTSYM((L+9)/10)/(2**(27-3*MOD(L-1,10))),8) - RETURN - END diff -Nru openmolcas-22.02/src/mrci/loop70.F90 openmolcas-22.10/src/mrci/loop70.F90 --- openmolcas-22.02/src/mrci/loop70.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/loop70.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,168 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine LOOP70(C,S,ABIJ,AIBJ,AJBI,A,B,F,IPOF,IPOA,IPOB,MYL,NYL,INDA,INDB,INMY,INNY,IFTB,IFTA,FACS,IAB,CPL,CPLA,NVIRA,NVIRC,NVIRB) + +use mrci_global, only: NSYM, NVIR +use Symmetry_Info, only: Mul +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +real(kind=wp), intent(in) :: C(*), ABIJ(*), AIBJ(*), AJBI(*), FACS, CPL, CPLA +real(kind=wp), intent(inout) :: S(*) +real(kind=wp), intent(_OUT_) :: A(*), B(*), F(*) +integer(kind=iwp), intent(in) :: IPOF(9), IPOA(9), IPOB(9), MYL, NYL, INDA, INDB, INMY, INNY, IFTB, IFTA +integer(kind=iwp), intent(out) :: IAB, NVIRA, NVIRC, NVIRB +integer(kind=iwp) :: IASYM, IBSYM, ICSYM, IPF +real(kind=wp) :: FACSX + +do IASYM=1,NSYM + IAB = IPOF(IASYM+1)-IPOF(IASYM) + if (IAB == 0) cycle + ICSYM = MUL(MYL,IASYM) + IBSYM = MUL(NYL,ICSYM) + if ((INDA == INDB) .and. (IBSYM > IASYM)) cycle + NVIRC = NVIR(ICSYM) + if (NVIRC == 0) cycle + NVIRA = NVIR(IASYM) + NVIRB = NVIR(IBSYM) + if (ICSYM < IASYM) then + if (ICSYM < IBSYM) then + ! CASE 1, IASYM > ICSYM AND IBSYM > ICSYM + IPF = IPOF(IASYM)+1 + F(1:IAB) = CPL*AIBJ(IPF:IPF+IAB-1)+CPLA*ABIJ(IPF:IPF+IAB-1) + if (INDA == INDB) call DCOPY_(NVIRA,[Zero],0,F,NVIRA+1) + call DGEMM_('N','N',NVIRC,NVIRB,NVIRA,FACS,C(INMY+IPOA(IASYM)),NVIRC,F,NVIRA,One,S(INNY+IPOB(IBSYM)),NVIRC) + if (INDA /= INDB) then + IPF = IPOF(IBSYM)+1 + F(1:IAB) = CPL*AJBI(IPF:IPF+IAB-1)+CPLA*ABIJ(IPF:IPF+IAB-1) + call DGEMM_('N','N',NVIRC,NVIRA,NVIRB,FACS,C(INNY+IPOB(IBSYM)),NVIRC,F,NVIRB,One,S(INMY+IPOA(IASYM)),NVIRC) + end if + else + ! CASE 2, IASYM > ICSYM AND ICSYM > OR = IBSYM + IPF = IPOF(IBSYM)+1 + F(1:IAB) = CPL*AJBI(IPF:IPF+IAB-1)+CPLA*ABIJ(IPF:IPF+IAB-1) + + if (NYL == 1) then + call DGEMM_('N','T',NVIRB,NVIRC,NVIRA,FACS,F,NVIRB,C(INMY+IPOA(IASYM)),NVIRC,Zero,A,NVIRB) + if (IFTB == 1) then + call TRADD(A,S(INNY+IPOB(ICSYM)),NVIRB) + call SQUARN(C(INNY+IPOB(IBSYM)),A,NVIRB) + else + call SIADD(A,S(INNY+IPOB(ICSYM)),NVIRB) + call SQUAR(C(INNY+IPOB(IBSYM)),A,NVIRB) + end if + call DGEMM_('N','N',NVIRC,NVIRA,NVIRB,FACS,A,NVIRC,F,NVIRB,One,S(INMY+IPOA(IASYM)),NVIRC) + else + FACSX = FACS + if (IFTB == 1) FACSX = -FACS + call DGEMM_('N','T',NVIRB,NVIRC,NVIRA,FACSX,F,NVIRB,C(INMY+IPOA(IASYM)),NVIRC,One,S(INNY+IPOB(ICSYM)),NVIRB) + call DGEMM_('T','N',NVIRC,NVIRA,NVIRB,FACSX,C(INNY+IPOB(ICSYM)),NVIRB,F,NVIRB,One,S(INMY+IPOA(IASYM)),NVIRC) + end if + end if + else + ! UPDATED UNTIL HERE + if (ICSYM < IBSYM) then + ! CASE 3, ICSYM > OR = IASYM AND IBSYM > ICSYM + IPF = IPOF(IASYM)+1 + F(1:IAB) = CPL*AIBJ(IPF:IPF+IAB-1)+CPLA*ABIJ(IPF:IPF+IAB-1) + if (MYL == 1) then + if (IFTA == 0) call SQUAR(C(INMY+IPOA(IASYM)),A,NVIRA) + if (IFTA == 1) call SQUARN(C(INMY+IPOA(IASYM)),A,NVIRA) + call DGEMM_('N','N',NVIRC,NVIRB,NVIRA,FACS,A,NVIRC,F,NVIRA,One,S(INNY+IPOB(IBSYM)),NVIRC) + call DGEMM_('N','T',NVIRA,NVIRC,NVIRB,FACS,F,NVIRA,C(INNY+IPOB(IBSYM)),NVIRC,Zero,A,NVIRA) + if (IFTA == 0) call SIADD(A,S(INMY+IPOA(IASYM)),NVIRA) + if (IFTA == 1) call TRADD(A,S(INMY+IPOA(IASYM)),NVIRA) + else + FACSX = FACS + if (IFTA == 1) FACSX = -FACS + call DGEMM_('T','N',NVIRC,NVIRB,NVIRA,FACSX,C(INMY+IPOA(ICSYM)),NVIRA,F,NVIRA,One,S(INNY+IPOB(IBSYM)),NVIRC) + call DGEMM_('N','T',NVIRA,NVIRC,NVIRB,FACSX,F,NVIRA,C(INNY+IPOB(IBSYM)),NVIRC,One,S(INMY+IPOA(ICSYM)),NVIRA) + end if + else + ! CASE 4, ICSYM > OR = IASYM AND ICSYM > OR = IBSYM + IPF = IPOF(IBSYM)+1 + F(1:IAB) = CPL*AJBI(IPF:IPF+IAB-1)+CPLA*ABIJ(IPF:IPF+IAB-1) + if (INDA == INDB) call DCOPY_(NVIRA,[Zero],0,F,NVIRA+1) + if ((MYL == 1) .and. (NYL == 1)) then + + if (IFTA == 0) call SQUAR(C(INMY+IPOA(IASYM)),A,NVIRA) + if (IFTA == 1) call SQUARM(C(INMY+IPOA(IASYM)),A,NVIRA) + call DGEMM_('N','N',NVIRB,NVIRC,NVIRA,FACS,F,NVIRB,A,NVIRA,Zero,B,NVIRB) + if (IFTB == 0) call SIADD(B,S(INNY+IPOB(ICSYM)),NVIRB) + if (IFTB == 1) call TRADD(B,S(INNY+IPOB(ICSYM)),NVIRB) + + else if ((MYL == 1) .and. (NYL /= 1)) then + if (IFTA == 0) call SQUAR(C(INMY+IPOA(IASYM)),A,NVIRA) + if (IFTA == 1) call SQUARM(C(INMY+IPOA(IASYM)),A,NVIRA) + FACSX = FACS + if (IFTB == 1) FACSX = -FACS + call DGEMM_('N','N',NVIRB,NVIRC,NVIRA,FACSX,F,NVIRB,A,NVIRA,One,S(INNY+IPOB(ICSYM)),NVIRB) + + else if ((MYL /= 1) .and. (NYL == 1)) then + + FACSX = FACS + if (IFTA == 1) FACSX = -FACS + call DGEMM_('N','N',NVIRB,NVIRC,NVIRA,FACSX,F,NVIRB,C(INMY+IPOA(ICSYM)),NVIRA,Zero,B,NVIRB) + if (IFTB == 0) call SIADD(B,S(INNY+IPOB(ICSYM)),NVIRB) + if (IFTB == 1) call TRADD(B,S(INNY+IPOB(ICSYM)),NVIRB) + else if ((MYL /= 1) .and. (NYL /= 1)) then + FACSX = FACS + if (IFTA+IFTB == 1) FACSX = -FACS + call DGEMM_('N','N',NVIRB,NVIRC,NVIRA,FACSX,F,NVIRB,C(INMY+IPOA(ICSYM)),NVIRA,One,S(INNY+IPOB(ICSYM)),NVIRB) + end if + if (INDA /= INDB) then + IPF = IPOF(IASYM)+1 + F(1:IAB) = CPL*AIBJ(IPF:IPF+IAB-1)+CPLA*ABIJ(IPF:IPF+IAB-1) + + if ((NYL == 1) .and. (MYL == 1)) then + + if (IFTB == 0) call SQUAR(C(INNY+IPOB(IBSYM)),A,NVIRB) + if (IFTB == 1) call SQUARM(C(INNY+IPOB(IBSYM)),A,NVIRB) + call DGEMM_('N','N',NVIRA,NVIRC,NVIRB,FACS,F,NVIRA,A,NVIRB,Zero,B,NVIRA) + if (IFTA == 0) call SIADD(B,S(INMY+IPOA(ICSYM)),NVIRA) + if (IFTA == 1) call TRADD(B,S(INMY+IPOA(ICSYM)),NVIRA) + + else if ((NYL == 1) .and. (MYL /= 1)) then + + if (IFTB == 0) call SQUAR(C(INNY+IPOB(ICSYM)),A,NVIRB) + if (IFTB == 1) call SQUARM(C(INNY+IPOB(ICSYM)),A,NVIRB) + FACSX = FACS + if (IFTA == 1) FACSX = -FACS + call DGEMM_('N','N',NVIRA,NVIRC,NVIRB,FACSX,F,NVIRA,A,NVIRB,One,S(INMY+IPOA(ICSYM)),NVIRA) + + else if ((NYL /= 1) .and. (MYL == 1)) then + + FACSX = FACS + if (IFTB == 1) FACSX = -FACS + call DGEMM_('N','N',NVIRA,NVIRC,NVIRB,FACSX,F,NVIRA,C(INNY+IPOB(ICSYM)),NVIRB,Zero,B,NVIRA) + if (IFTA == 0) call SIADD(B,S(INMY+IPOA(ICSYM)),NVIRA) + if (IFTA == 1) call TRADD(B,S(INMY+IPOA(ICSYM)),NVIRA) + + else if ((NYL /= 1) .and. (MYL /= 1)) then + + FACSX = FACS + if (IFTA+IFTB == 1) FACSX = -FACS + call DGEMM_('N','N',NVIRA,NVIRC,NVIRB,FACSX,F,NVIRA,C(INNY+IPOB(ICSYM)),NVIRB,One,S(INMY+IPOA(ICSYM)),NVIRA) + + end if + end if + end if + end if + +end do + +return + +end subroutine LOOP70 diff -Nru openmolcas-22.02/src/mrci/main.f openmolcas-22.10/src/mrci/main.f --- openmolcas-22.02/src/mrci/main.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/main.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - program main -#ifdef _FPE_TRAP_ - Use, Intrinsic :: IEEE_Exceptions -#endif - implicit real*8 (a-h,o-z) - Character*20 Module_Name - Parameter (Module_Name = 'mrci') -#ifdef _FPE_TRAP_ - Call IEEE_Set_Halting_Mode(IEEE_Usual,.True._4) -#endif - - Call Start(Module_Name) - Call mrci(ireturn) - Call Finish(ireturn) - end diff -Nru openmolcas-22.02/src/mrci/main.F90 openmolcas-22.10/src/mrci/main.F90 --- openmolcas-22.02/src/mrci/main.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/main.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,31 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +program Main + +#ifdef _FPE_TRAP_ +use, intrinsic :: IEEE_Exceptions, only: IEEE_Set_Halting_Mode, IEEE_Usual +use Definitions, only: DefInt +#endif +use Definitions, only: iwp + +implicit none +integer(kind=iwp) :: rc + +#ifdef _FPE_TRAP_ +call IEEE_Set_Halting_Mode(IEEE_Usual,.true._DefInt) +#endif + +call Start('mrci') +call mrci(rc) +call Finish(rc) + +end program Main diff -Nru openmolcas-22.02/src/mrci/mkdao.f openmolcas-22.10/src/mrci/mkdao.f --- openmolcas-22.02/src/mrci/mkdao.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/mkdao.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE MKDAO(CNO,OCC,DAO) - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "mrci.fh" - DIMENSION CNO(NCMO),OCC(NBAST),DAO(NBAST,NBAST) - CALL FZERO(DAO,NBAST**2) - IB=1 - ICNO=1 - DO 100 ISYM=1,NSYM - IB1=IB - NB=NBAS(ISYM) - DO 10 I=1,NB - X=OCC(IB) - CALL DGER(NB,NB,X,CNO(ICNO),1,CNO(ICNO),1,DAO(IB1,IB1),NBAST) - IB=IB+1 - ICNO=ICNO+NB -10 CONTINUE -100 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/mkdao.F90 openmolcas-22.10/src/mrci/mkdao.F90 --- openmolcas-22.02/src/mrci/mkdao.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/mkdao.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,40 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine MKDAO(CNO,OCC,DAO) + +use mrci_global, only: NBAS, NBAST, NCMO, NSYM +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(in) :: CNO(NCMO), OCC(NBAST) +real(kind=wp), intent(out) :: DAO(NBAST,NBAST) +integer(kind=iwp) :: I, IB, IB1, ICNO, ISYM, NB +real(kind=wp) :: X + +DAO(:,:) = Zero +IB = 1 +ICNO = 1 +do ISYM=1,NSYM + IB1 = IB + NB = NBAS(ISYM) + do I=1,NB + X = OCC(IB) + call DGER(NB,NB,X,CNO(ICNO),1,CNO(ICNO),1,DAO(IB1,IB1),NBAST) + IB = IB+1 + ICNO = ICNO+NB + end do +end do + +return + +end subroutine MKDAO diff -Nru openmolcas-22.02/src/mrci/mkhref.f openmolcas-22.10/src/mrci/mkhref.f --- openmolcas-22.02/src/mrci/mkhref.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/mkhref.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,155 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -cpgi$g opt=1 - SUBROUTINE MKHREF(HREF,FC,FIJKL,JREFX) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "mrci.fh" - DIMENSION HREF(*),FC(*),FIJKL(*),JREFX(NCVAL) -* - NHREF=(NREF*(NREF+1))/2 - CALL FZERO(HREF,NHREF) - ICHK=0 - IK=0 - FINI=0.0D00 - IADD25=0 - CALL dDAFILE(Lu_25,2,FC,NBTRI,IADD25) - IADD10=IAD10(8) -100 CALL dDAFILE(LUSYMB,2,COP,nCOP,IADD10) - CALL iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.EQ.0)GO TO 100 - IF(LEN.LT.0) GOTO 200 - DO 10 IN=1,LEN - IND=ICOP1(IN) - IF(ICHK.NE.0) THEN - ICHK=0 - INDI=IND -* NI=MOD(INDI,2**10) -* NK=MOD(INDI/2**10,2**10) - NI=IBITS(INDI, 0,10) - NK=IBITS(INDI,10,10) - IK=IROW(NK)+NI - FINI=FC(IK) - GO TO 10 - END IF - IF(IND.EQ.0) THEN - ICHK=1 - GO TO 10 - END IF -* IVL=MOD(IND,2**6) - IVL=IBITS(IND, 0, 6) - IF(IVL.NE.IVVER)GO TO 10 -* IC2=MOD(IND/2**6,2**13) - IC2=IBITS(IND, 6,13) - NA=JREFX(IC2) - IF(NA.EQ.0)GO TO 10 -* IC1=MOD(IND/2**19,2**13) - IC1=IBITS(IND,19,13) - NB=JREFX(IC1) - IF(NB.EQ.0)GO TO 10 - IF(NA.LT.NB) THEN - NAT=NA - NA=NB - NB=NAT - END IF - IVEC=(NA*(NA-1))/2+NB - HREF(IVEC)=HREF(IVEC)+COP(IN)*FINI -10 CONTINUE - GO TO 100 -200 CONTINUE - ICHK=0 - NIJ=IROW(LN+1) - NIJKL=NIJ*(NIJ+1)/2 - CALL FZERO(FIJKL,NIJKL) - FINI=0.0D00 - IADR=LASTAD(1) -201 CONTINUE - CALL dDAFILE(Lu_70,2,VALSRT,NSRTMX,IADR) - CALL iDAFILE(Lu_70,2,INDSRT,NSRTMX+2,IADR) - LENGTH=INDSRT(NSRTMX+1) - IADR=INDSRT(NSRTMX+2) -* IF(LENGTH.GT.0) CALL SCATTER(LENGTH,FIJKL,INDSRT,VALSRT) - do i=1,length - FIJKL(INDSRT(i))=VALSRT(i) - end do - IF(IADR.NE.-1) GO TO 201 - IADD10=IAD10(5) -300 CONTINUE - CALL dDAFILE(LUSYMB,2,COP,nCOP,IADD10) - CALL iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.EQ.0)GO TO 300 - IF(LEN.LT.0)GOTO 400 - DO 310 IN=1,LEN - IND=ICOP1(IN) - IF(ICHK.NE.0) THEN - ICHK=0 - INDI=IND -CPAM96 IP=IAND(INDI,255) -CPAM96 JP=IAND(ISHFT(INDI,-8),255) -CPAM96 KP=IAND(ISHFT(INDI,-16),255) -CPAM96 LP=IAND(ISHFT(INDI,-24),255) -* IP=MOD(INDI,2**8) -* JP=MOD(INDI/2**8,2**8) -* KP=MOD(INDI/2**16,2**8) -* LP=MOD(INDI/2**24,2**8) - IP=IBITS(INDI, 0,8) - JP=IBITS(INDI, 8,8) - KP=IBITS(INDI,16,8) - LP=IBITS(INDI,24,8) - NIJ=IROW(IP)+JP - NKL=IROW(KP)+LP - IND=NIJ*(NIJ-1)/2+NKL - FINI=FIJKL(IND) - GOTO 310 - END IF - IF(IND.EQ.0) THEN - ICHK=1 - GOTO 310 - END IF -* IVL=MOD(IND,2**6) - IVL=IBITS(IND, 0, 6) - IF(IVL.NE.0)GO TO 310 -* IC2=MOD(IND/2**6,2**13) - IC2=IBITS(IND, 6,13) - NA=JREFX(IC2) - IF(NA.EQ.0)GO TO 310 -* IC1=MOD(IND/2**19,2**13) - IC1=IBITS(IND,19,13) - NB=JREFX(IC1) - IF(NB.EQ.0)GO TO 310 - IF(NA.LT.NB) THEN - NAT=NA - NA=NB - NB=NAT - END IF - IVEC=(NA*(NA-1))/2+NB - HREF(IVEC)=HREF(IVEC)+COP(IN)*FINI -310 CONTINUE - GO TO 300 -400 CONTINUE - IADD25=IAD25S - IBUF=nCOP - DO 410 I=1,IRC(1) - IBUF=IBUF+1 - IF(IBUF.GT.nCOP) THEN - CALL dDAFILE(Lu_25,2,COP,nCOP,IADD25) - IBUF=1 - END IF - IR=JREFX(I) - IF(IR.GT.0) THEN - IIR=(IR*(IR+1))/2 - HREF(IIR)=HREF(IIR)+COP(IBUF)+POTNUC - END IF -410 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/mkhref.F90 openmolcas-22.10/src/mrci/mkhref.F90 --- openmolcas-22.02/src/mrci/mkhref.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/mkhref.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,145 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine MKHREF(HREF,FC,FIJKL,JREFX) + +use mrci_global, only: IAD25S, INDSRT, IRC, IROW, IVVER, LASTAD, LN, Lu_25, Lu_70, LUSYMB, NBTRI, NCVAL, NREF, NSRTMX, POTNUC, & + VALSRT +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Constants, only: Zero +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +real(kind=wp), intent(_OUT_) :: HREF(*), FC(*), FIJKL(*) +integer(kind=iwp), intent(in) :: JREFX(NCVAL) +integer(kind=iwp) :: i, IADD10, IADD25, IADR, IBUF, IC1, IC2, ICHK, IIN, IIR, IK, ILEN, IND, INDI, IP, IR, IVEC, IVL, JP, KP, & + LENGTH, LP, NA, NAT, NB, NHREF, NI, NIJ, NIJKL, NK, NKL +real(kind=wp) :: FINI + +NHREF = (NREF*(NREF+1))/2 +HREF(1:NHREF) = Zero +ICHK = 0 +IK = 0 +FINI = Zero +IADD25 = 0 +call dDAFILE(Lu_25,2,FC,NBTRI,IADD25) +IADD10 = IAD10(8) +do + call dDAFILE(LUSYMB,2,COP,nCOP,IADD10) + call iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN < 0) exit + do IIN=1,ILEN + IND = ICOP1(IIN) + if (ICHK /= 0) then + ICHK = 0 + INDI = IND + NI = ibits(INDI,0,10) + NK = ibits(INDI,10,10) + IK = IROW(NK)+NI + FINI = FC(IK) + else if (IND == 0) then + ICHK = 1 + else + IVL = ibits(IND,0,6) + if (IVL /= IVVER) cycle + IC2 = ibits(IND,6,13) + NA = JREFX(IC2) + if (NA == 0) cycle + IC1 = ibits(IND,19,13) + NB = JREFX(IC1) + if (NB == 0) cycle + if (NA < NB) then + NAT = NA + NA = NB + NB = NAT + end if + IVEC = (NA*(NA-1))/2+NB + HREF(IVEC) = HREF(IVEC)+COP(IIN)*FINI + end if + end do +end do +ICHK = 0 +NIJ = IROW(LN+1) +NIJKL = NIJ*(NIJ+1)/2 +FIJKL(1:NIJKL) = Zero +FINI = Zero +IADR = LASTAD(1) +do + call dDAFILE(Lu_70,2,VALSRT,NSRTMX,IADR) + call iDAFILE(Lu_70,2,INDSRT,NSRTMX+2,IADR) + LENGTH = INDSRT(NSRTMX+1) + IADR = INDSRT(NSRTMX+2) + do i=1,length + FIJKL(INDSRT(i)) = VALSRT(i) + end do + if (IADR == -1) exit +end do +IADD10 = IAD10(5) +do + call dDAFILE(LUSYMB,2,COP,nCOP,IADD10) + call iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN < 0) exit + do IIN=1,ILEN + IND = ICOP1(IIN) + if (ICHK /= 0) then + ICHK = 0 + INDI = IND + IP = ibits(INDI,0,8) + JP = ibits(INDI,8,8) + KP = ibits(INDI,16,8) + LP = ibits(INDI,24,8) + NIJ = IROW(IP)+JP + NKL = IROW(KP)+LP + IND = NIJ*(NIJ-1)/2+NKL + FINI = FIJKL(IND) + else if (IND == 0) then + ICHK = 1 + else + IVL = ibits(IND,0,6) + if (IVL /= 0) cycle + IC2 = ibits(IND,6,13) + NA = JREFX(IC2) + if (NA == 0) cycle + IC1 = ibits(IND,19,13) + NB = JREFX(IC1) + if (NB == 0) cycle + if (NA < NB) then + NAT = NA + NA = NB + NB = NAT + end if + IVEC = (NA*(NA-1))/2+NB + HREF(IVEC) = HREF(IVEC)+COP(IIN)*FINI + end if + end do +end do +IADD25 = IAD25S +IBUF = nCOP +do I=1,IRC(1) + IBUF = IBUF+1 + if (IBUF > nCOP) then + call dDAFILE(Lu_25,2,COP,nCOP,IADD25) + IBUF = 1 + end if + IR = JREFX(I) + if (IR > 0) then + IIR = (IR*(IR+1))/2 + HREF(IIR) = HREF(IIR)+COP(IBUF)+POTNUC + end if +end do + +return + +end subroutine MKHREF diff -Nru openmolcas-22.02/src/mrci/mktdao.f openmolcas-22.10/src/mrci/mktdao.f --- openmolcas-22.02/src/mrci/mktdao.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/mktdao.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,69 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE MKTDAO(CMO,TDMO,TDAO,SCR) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION CMO(NCMO),TDMO(NBAST,NBAST),TDAO(NBAST,NBAST) - DIMENSION SCR(NBMAX,NBMAX) - -#include "SysDef.fh" - -#include "mrci.fh" -C REORDER TDMO (USE TDAO AS TEMPORARY STORAGE): - CALL FZERO(TDAO,NBAST**2) - DO 10 I=1,NORBT - II=ICH(I) - IF(II.LE.0) GOTO 10 - DO 5 J=1,NORBT - JJ=ICH(J) - IF(JJ.LE.0) GOTO 5 - TDAO(I,J)=TDMO(II,JJ) -5 CONTINUE -10 CONTINUE - CALL DCOPY_(NBAST**2,TDAO,1,TDMO,1) - CALL FZERO(TDAO,NBAST**2) - IECMO=0 - IEO=0 - IEB=0 - DO 100 ISYM=1,NSYM - ISO=IEO+1 - ISB=IEB+1 - NO=NORB(ISYM) - NB=NBAS(ISYM) - IEO=IEO+NO - IEB=IEB+NB -C ORBITALS PRE-FROZEN IN MOTRA, OR FROZEN IN MRCI: - NF=NFMO(ISYM)+NFRO(ISYM) - NBF=NB*NF - ISCMO=IECMO+1 - IECMO=IECMO+NBF -C ORBITALS EXPLICITLY USED IN CI: - NCO=NO-NFRO(ISYM)-NDEL(ISYM) - ISCO=ISO+NFRO(ISYM) - NBCO=NB*NCO - ISCMO=IECMO+1 - IECMO=IECMO+NBCO - IF(NCO.GT.0) THEN - CALL DGEMM_('N','N', - & NB,NCO,NCO, - & 1.0d0,CMO(ISCMO),NB, - & TDMO(ISCO,ISCO),NBAST, - & 0.0d0,SCR,NB) - CALL DGEMM_('N','T',NB,NB,NCO,1.0D00,SCR,NB, - * CMO(ISCMO),NB,1.0D00,TDAO(ISB,ISB),NBAST) - END IF -C ORBITALS PRE-DELETED IN MOTRA OR DELETED IN MRCI: - ND=NDMO(ISYM)+NDEL(ISYM) - NBD=NB*ND - ISCMO=IECMO+1 - IECMO=IECMO+NBD -100 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/mktdao.F90 openmolcas-22.10/src/mrci/mktdao.F90 --- openmolcas-22.02/src/mrci/mktdao.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/mktdao.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,69 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine MKTDAO(CMO,TDMO,TDAO,SCR) + +use mrci_global, only: ICH, NBAS, NBAST, NBMAX, NCMO, NDEL, NDMO, NFMO, NFRO, NORB, NORBT, NSYM +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(in) :: CMO(NCMO) +real(kind=wp), intent(out) :: TDMO(NBAST,NBAST), TDAO(NBAST,NBAST), SCR(NBMAX,NBMAX) +integer(kind=iwp) :: I, IEB, IECMO, IEO, II, ISB, ISCMO, ISCO, ISO, ISYM, J, JJ, NB, NBCO, NBD, NBF, NCO, ND, NF, NO + +! REORDER TDMO (USE TDAO AS TEMPORARY STORAGE): +TDAO(:,:) = Zero +do I=1,NORBT + II = ICH(I) + if (II > 0) then + do J=1,NORBT + JJ = ICH(J) + if (JJ > 0) TDAO(I,J) = TDMO(II,JJ) + end do + end if +end do +TDMO(:,:) = TDAO(:,:) +IECMO = 0 +IEO = 0 +IEB = 0 +do ISYM=1,NSYM + ISO = IEO+1 + ISB = IEB+1 + NO = NORB(ISYM) + NB = NBAS(ISYM) + IEO = IEO+NO + IEB = IEB+NB + ! ORBITALS PRE-FROZEN IN MOTRA, OR FROZEN IN MRCI: + NF = NFMO(ISYM)+NFRO(ISYM) + NBF = NB*NF + ISCMO = IECMO+1 + IECMO = IECMO+NBF + ! ORBITALS EXPLICITLY USED IN CI: + NCO = NO-NFRO(ISYM)-NDEL(ISYM) + ISCO = ISO+NFRO(ISYM) + NBCO = NB*NCO + ISCMO = IECMO+1 + IECMO = IECMO+NBCO + if (NCO > 0) then + call DGEMM_('N','N',NB,NCO,NCO,One,CMO(ISCMO),NB,TDMO(ISCO,ISCO),NBAST,Zero,SCR,NB) + call DGEMM_('N','T',NB,NB,NCO,One,SCR,NB,CMO(ISCMO),NB,One,TDAO(ISB,ISB),NBAST) + end if + ! ORBITALS PRE-DELETED IN MOTRA OR DELETED IN MRCI: + ND = NDMO(ISYM)+NDEL(ISYM) + NBD = NB*ND + ISCMO = IECMO+1 + IECMO = IECMO+NBD +end do + +return + +end subroutine MKTDAO diff -Nru openmolcas-22.02/src/mrci/mqct.f openmolcas-22.10/src/mrci/mqct.f --- openmolcas-22.02/src/mrci/mqct.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/mqct.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,54 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE MQCT(AREF,EREF,CI,SGM,ICI) - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "mrci.fh" -#include "WrkSpc.fh" - DIMENSION AREF(NREF,NREF),EREF(NREF) - DIMENSION ICI(MBUF),SGM(NCONF),CI(NCONF) -* LCBUF =LMQ -* LSBUF =LCBUF +MXVEC*MBUF -* LDBUF =LSBUF +MXVEC*MBUF -* LCSECT=LDBUF +MBUF -* LRSECT=LCSECT+NSECT*MXVEC -* LXI1 =LRSECT+NSECT*MXVEC -* LXI2 =LXI1 +NSECT*NRROOT -* LCNEW =LXI2 +NSECT*NRROOT -* LSCR =LCNEW +NSECT*NRROOT - CALL GETMEM('CBUF','ALLO','REAL',LCBUF,MXVEC*MBUF) - CALL GETMEM('SBUF','ALLO','REAL',LSBUF,MXVEC*MBUF) - CALL GETMEM('DBUF','ALLO','REAL',LDBUF,MBUF) - CALL GETMEM('CSECT','ALLO','REAL',LCSECT,NSECT*MXVEC) - CALL GETMEM('RSECT','ALLO','REAL',LRSECT,NSECT*MXVEC) - CALL GETMEM('XI1','ALLO','REAL',LXI1,NSECT*NRROOT) - CALL GETMEM('XI2','ALLO','REAL',LXI2,NSECT*NRROOT) - CALL GETMEM('CNEW','ALLO','REAL',LCNEW,NSECT*NRROOT) - CALL GETMEM('SCR','ALLO','REAL',LSCR,MXVEC*MBUF) - CALL DIAGRO(CI,SGM,Work(LCBUF), - * Work(LSBUF),Work(LDBUF), - * AREF,EREF, - * Work(LCSECT),Work(LRSECT), - * Work(LXI1),Work(LXI2),Work(LCNEW), - * Work(LSCR),ICI) - CALL GETMEM('CBUF','FREE','REAL',LCBUF,MXVEC*MBUF) - CALL GETMEM('SBUF','FREE','REAL',LSBUF,MXVEC*MBUF) - CALL GETMEM('DBUF','FREE','REAL',LDBUF,MBUF) - CALL GETMEM('CSECT','FREE','REAL',LCSECT,NSECT*MXVEC) - CALL GETMEM('RSECT','FREE','REAL',LRSECT,NSECT*MXVEC) - CALL GETMEM('XI1','FREE','REAL',LXI1,NSECT*NRROOT) - CALL GETMEM('XI2','FREE','REAL',LXI2,NSECT*NRROOT) - CALL GETMEM('CNEW','FREE','REAL',LCNEW,NSECT*NRROOT) - CALL GETMEM('SCR','FREE','REAL',LSCR,MXVEC*MBUF) - RETURN - END diff -Nru openmolcas-22.02/src/mrci/mqct.F90 openmolcas-22.10/src/mrci/mqct.F90 --- openmolcas-22.02/src/mrci/mqct.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/mqct.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,612 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine MQCT(AREF,EREF,CI,SGM,ICI) + +use mrci_global, only: CSPCK, ENGY, ESHIFT, ESMALL, ETHRE, FOCK, GFAC, HZERO, ICPF, IDFREE, IDISKC, IDISKS, INDX, INTSY, IPRINT, & + IREFX, IROOT, ISAB, ISMAX, ITER, JREFX, KBUFF1, LUEIG, LUREST, MAXIT, MBUF, MXVEC, MXZ, NBMN, NCONF, NNEW, & + NREF, NRROOT, NSECT, NSTOT, NVEC, NVMAX, NVSQ, NVTOT, SQNLIM, SZERO, VSMALL, VZERO +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6, r8 + +implicit none +real(kind=wp), intent(in) :: AREF(NREF,NREF), EREF(NREF) +real(kind=wp), intent(out) :: CI(NCONF), SGM(NCONF) +integer(kind=iwp), intent(out) :: ICI(MBUF) +#include "warnings.h" +integer(kind=iwp) :: I, IBUF, ICSF, IDISK, IDREST, IEND, II, III, IMAX, IMIN, IPOS, IR, IRR, ISTA, IVEC, J, K, KK, KL, L, LL, & + NCONV, NN, NRON, NZ +real(kind=wp) :: C, C2NREF, C2REF, CPTIT, CPTNOW, CPTOLD, CPTOT, CPTSTA, DUM, EACPF, ECI, EDAV, EDISP, ELOW, EMIN, ENREF, H, P, & + PMAX, QACPF, QDAV, RSUM, S, SQNRM, THR, TMP +integer(kind=iwp), allocatable :: IBMN(:), IDC(:), IDS(:) +real(kind=wp), allocatable :: ABIJ(:), AC1(:), AC2(:), AIBJ(:), AJBI(:), ARR(:,:,:), ASCR1(:), ASCR2(:), BFIN3(:), BFIN4(:), & + BIAC2(:), BICA2(:), BMN(:), BSCR1(:), BSCR2(:), CBUF(:,:), CNEW(:,:), CSECT(:,:), DBK(:), DBUF(:), & + ELAST(:), EZERO(:), FSCR1(:), FSCR2(:), FSEC(:), HCOPY(:,:), HSMALL(:,:), PCOPY(:,:), PSEL(:), & + PSMALL(:,:), RNRM(:), RSECT(:,:), SBUF(:,:), SCOPY(:,:), SCR(:), SSMALL(:,:), XI1(:,:), XI2(:,:) +real(kind=r8), external :: DDOT_ + +call mma_allocate(CBUF,MBUF,MXVEC,label='CBUF') +call mma_allocate(SBUF,MBUF,MXVEC,label='SBUF') +call mma_allocate(DBUF,MBUF,label='DBUF') +call mma_allocate(CSECT,NSECT,MXVEC,label='CSECT') +call mma_allocate(RSECT,NSECT,MXVEC,label='RSECT') +call mma_allocate(XI1,NSECT,NRROOT,label='XI1') +call mma_allocate(XI2,NSECT,NRROOT,label='XI2') +call mma_allocate(CNEW,NSECT,NRROOT,label='CNEW') +call mma_allocate(SCR,MXVEC*MBUF,label='SCR') +call mma_allocate(IDC,MXVEC,label='IDC') +call mma_allocate(IDS,MXVEC,label='IDS') +call mma_allocate(ELAST,NRROOT,label='ELAST') +call mma_allocate(HCOPY,MXVEC,MXVEC,label='HCOPY') +call mma_allocate(PCOPY,MXVEC,MXVEC,label='PCOPY') +call mma_allocate(SCOPY,MXVEC,MXVEC,label='SCOPY') +call mma_allocate(PSEL,MXVEC,label='PSEL') +call mma_allocate(RNRM,NRROOT,label='RNRM') +call mma_allocate(HSMALL,MXVEC,MXVEC,label='HSMALL') +call mma_allocate(SSMALL,MXVEC,MXVEC,label='SSMALL') +call mma_allocate(PSMALL,MXVEC,MXVEC,label='PSMALL') +call mma_allocate(EZERO,MXZ,label='EZERO') +call mma_allocate(HZERO,MXZ,MXZ,label='HZERO') +call mma_allocate(SZERO,MXZ,MXZ,label='SZERO') +call mma_allocate(VZERO,MXZ,MXZ,label='VZERO') + +write(u6,*) +write(u6,*) ('-',I=1,60) +if (ICPF == 0) then + write(u6,*) ' MR SDCI CALCULATION.' +else + write(u6,*) ' MR ACPF CALCULATION.' +end if +write(u6,*) ('-',I=1,60) +write(u6,*) +write(u6,*) ' CONVERGENCE STATISTICS:' +write(u6,'(1X,A)') 'ITER NVEC ENERGIES LOWERING RESIDUAL SEL.WGT CPU(S) CPU TOT' +ITER = 0 +call SETTIM() +call TIMING(CPTNOW,DUM,DUM,DUM) +CPTOLD = CPTNOW +CPTSTA = CPTNOW +HSMALL(1,1) = Zero +! LOOP HEAD FOR CI ITERATIONS: +do + ITER = ITER+1 + ! -------------------------------------------------------------------- + ! CALCULATE SIGMA ARRAYS FOR SHIFTED HAMILTONIAN IN MCSF BASIS: + do I=1,NNEW + IVEC = 1+mod(NVTOT-NNEW+I-1,MXVEC) + IDISK = IDISKC(IVEC) + do ISTA=1,NCONF,MBUF + NN = min(MBUF,NCONF+1-ISTA) + call iDAFILE(LUEIG,2,ICI,NN,IDISK) + call UPKVEC(NN,ICI,CI(ISTA)) + end do + call mma_allocate(BMN,NBMN,label='BMN') + call mma_allocate(IBMN,NBMN,label='IBMN') + call mma_allocate(BIAC2,ISMAX,label='BIAC2') + call mma_allocate(BICA2,ISMAX,label='BICA2') + call mma_allocate(BFIN3,KBUFF1,label='BFIN3') + call mma_allocate(AC1,ISMAX,label='AC1') + call mma_allocate(AC2,ISMAX,label='AC2') + call mma_allocate(BFIN4,KBUFF1,label='BFIN4') + call mma_allocate(ABIJ,NVSQ,label='ABIJ') + call mma_allocate(AIBJ,NVSQ,label='AIBJ') + call mma_allocate(AJBI,NVSQ,label='AJBI') + call mma_allocate(ASCR1,NVMAX**2,label='ASCR1') + call mma_allocate(BSCR1,NVMAX**2,label='BSCR1') + call mma_allocate(FSCR1,NVSQ,label='FSCR1') + call mma_allocate(FSEC,2*NVSQ,label='FSEC') + call mma_allocate(ASCR2,NVMAX**2,label='ASCR2') + call mma_allocate(BSCR2,NVMAX**2,label='BSCR2') + call mma_allocate(FSCR2,NVSQ,label='FSCR2') + call mma_allocate(DBK,2*NVSQ,label='DBK') + call SIGMA(SGM,AREF,CI,INTSY,INDX,BMN,IBMN,BIAC2,BICA2,BFIN3,ISAB,AC1,AC2,BFIN4,ABIJ,AIBJ,AJBI,ASCR1,BSCR1,FSCR1,FSEC,FOCK, & + ASCR2,BSCR2,FSCR2,DBK) + call mma_deallocate(BMN) + call mma_deallocate(IBMN) + call mma_deallocate(BIAC2) + call mma_deallocate(BICA2) + call mma_deallocate(BFIN3) + call mma_deallocate(AC1) + call mma_deallocate(AC2) + call mma_deallocate(BFIN4) + call mma_deallocate(ABIJ) + call mma_deallocate(AIBJ) + call mma_deallocate(AJBI) + call mma_deallocate(ASCR1) + call mma_deallocate(BSCR1) + call mma_deallocate(FSCR1) + call mma_deallocate(FSEC) + call mma_deallocate(ASCR2) + call mma_deallocate(BSCR2) + call mma_deallocate(FSCR2) + call mma_deallocate(DBK) + NSTOT = NSTOT+1 + ! WRITE IT OUT: + IVEC = 1+mod(NSTOT-1,MXVEC) + IDISK = IDISKS(IVEC) + if (IDISK == -1) IDISK = IDFREE + do ISTA=1,NCONF,MBUF + NN = min(MBUF,NCONF+1-ISTA) + call dDAFILE(LUEIG,1,SGM(ISTA),NN,IDISK) + end do + if (IDISK > IDFREE) then + IDISKS(IVEC) = IDFREE + IDFREE = IDISK + end if + end do + ! -------------------------------------------------------------------- + ! NR OF VECTORS PRESENTLY RETAINED: + NVEC = min(MXVEC,NVTOT) + ! -------------------------------------------------------------------- + ! COPY HSMALL, SSMALL AND PSMALL IN REORDERED FORM, BY AGE: + do L=NNEW+1,NVEC + LL = 1+mod(NVTOT-L,MXVEC) + do K=NNEW+1,NVEC + KK = 1+mod(NVTOT-K,MXVEC) + HCOPY(K,L) = HSMALL(KK,LL) + SCOPY(K,L) = SSMALL(KK,LL) + PCOPY(K,L) = PSMALL(KK,LL) + end do + end do + ! CLEAR NEW AREAS TO BE USED: + HCOPY(1:NVEC,1:NNEW) = Zero + SCOPY(1:NVEC,1:NNEW) = Zero + PCOPY(1:NVEC,1:NNEW) = Zero + ! THEN LOOP OVER BUFFERS. FIRST GET COPIES OF DISK ADDRESSES: + IDC(1:NVEC) = IDISKC(1:NVEC) + IDS(1:NVEC) = IDISKS(1:NVEC) + do ISTA=1,NCONF,MBUF + IEND = min(NCONF,ISTA+MBUF-1) + IBUF = 1+IEND-ISTA + do K=1,NVEC + KK = 1+mod(NVTOT-K,MXVEC) + call iDAFILE(LUEIG,2,ICI,IBUF,IDC(KK)) + call UPKVEC(IBUF,ICI,CBUF(1,K)) + if (K <= NNEW) call dDAFILE(LUEIG,2,SBUF(1,K),IBUF,IDS(KK)) + end do + ! ------------------------------------------------------------------ + ! NOTE: AT THIS POINT, THE COLUMNS NR 1..NVEC OF CBUF WILL + ! CONTAIN THE BUFFERS OF, FIRST, THE NNEW NEWEST PSI ARRAYS, + ! THEN, THE NOLD ONES FROM EARLIER ITERATIONS. + ! THE COLUMNS 1..NNEW OF SBUF WILL CONTAIN THE NEWEST NNEW + ! SIGMA ARRAYS. LEADING DIMENSION OF CBUF AND SBUF IS MBUF. ACTUAL + ! BUFFER SIZE IS IBUF, WHICH CAN BE SMALLER. ACCUMULATE: + call DGEMM_('T','N',NVEC,NNEW,IBUF,One,CBUF,MBUF,CBUF,MBUF,Zero,SCR,NVEC) + KL = 0 + do L=1,NNEW + do K=1,NVEC + KL = KL+1 + SCOPY(K,L) = SCOPY(K,L)+SCR(KL) + end do + end do + call DGEMM_('T','N',NVEC,NNEW,IBUF,One,CBUF,MBUF,SBUF,MBUF,Zero,SCR,NVEC) + KL = 0 + do L=1,NNEW + do K=1,NVEC + KL = KL+1 + HCOPY(K,L) = HCOPY(K,L)+SCR(KL) + end do + end do + ! ALSO, UPDATE PSMALL, WHICH IS USED FOR SELECTION. + if (ISTA > IREFX(NRROOT)) cycle + do I=1,NRROOT + IR = IROOT(I) + IRR = IREFX(IR) + if ((IRR < ISTA) .or. (IRR > IEND)) cycle + IPOS = IRR+1-ISTA + do L=1,NNEW + PCOPY(1:NVEC,L) = PCOPY(1:NVEC,L)+CBUF(IPOS,1:NVEC)*CBUF(IPOS,L) + end do + end do + end do + ! TRANSFER ELEMENTS BACK TO HSMALL, ETC. + do L=1,NNEW + LL = 1+mod(NVTOT-L,MXVEC) + do K=1,NVEC + KK = 1+mod(NVTOT-K,MXVEC) + H = HCOPY(K,L) + S = SCOPY(K,L) + P = PCOPY(K,L) + HCOPY(L,K) = H + SCOPY(L,K) = S + PCOPY(L,K) = P + HSMALL(KK,LL) = H + SSMALL(KK,LL) = S + PSMALL(KK,LL) = P + HSMALL(LL,KK) = H + SSMALL(LL,KK) = S + PSMALL(LL,KK) = P + end do + end do + if (IPRINT >= 10) then + write(u6,*) + write(u6,*) ' HSMALL MATRIX:' + do I=1,NVEC + write(u6,'(1X,5F15.6)') (HSMALL(I,J),J=1,NVEC) + end do + write(u6,*) + write(u6,*) ' SSMALL MATRIX:' + do I=1,NVEC + write(u6,'(1X,5F15.6)') (SSMALL(I,J),J=1,NVEC) + end do + write(u6,*) + write(u6,*) ' PSMALL MATRIX:' + do I=1,NVEC + write(u6,'(1X,5F15.6)') (PSMALL(I,J),J=1,NVEC) + end do + !write(u6,*) + !write(u6,*) + !write(u6,*) ' HCOPY MATRIX:' + !do I=1,NVEC + ! write(u6,'(1X,5F15.6)') (HCOPY(I,J),J=1,NVEC) + !end do + !write(u6,*) + !write(u6,*) ' SCOPY MATRIX:' + !do I=1,NVEC + ! write(u6,'(1X,5F15.6)') (SCOPY(I,J),J=1,NVEC) + !end do + !write(u6,*) + end if + ! -------------------------------------------------------------------- + ! THE UPPER-LEFT NVEC*NVEC SUBMATRICES OF HSMALL AND SSMALL NOW + ! CONTAINS THE CURRENT HAMILTONIAN AND OVERLAP MATRICES, IN THE + ! BASIS OF PRESENTLY RETAINED PSI VECTORS. DIAGONALIZE, BUT USE + ! THE REORDERED MATRICES IN SCOPY, HCOPY. THERE THE BASIS + ! FUNCTIONS ARE ORDERED BY AGE. + THR = 1.0e-6_wp + call SECULAR(MXVEC,NVEC,NRON,HCOPY,SCOPY,VSMALL,ESMALL,SCR,THR) + ! REORDER THE ELEMENTS OF VSMALL TO GET EIGENVECTORS OF HSMALL. NOTE: + ! THIS IS NOT THE SAME AS IF WE DIAGONALIZED HSMALL DIRECTLY. + ! THE DIFFERENCE OCCURS WHENEVER VECTORS ARE THROWN OUT OF THE + ! CALCULATION IN SECULAR BECAUSE OF LINEAR DEPENDENCE. THE RESULT + ! WILL DEPEND SLIGHTLY BUT CRITICALLY ON THE ORDER BY WHICH THE + ! VECTORS WERE ORTHONORMALIZED. + do I=1,NRON + do K=1,NVEC + KK = 1+mod(NVTOT-K,MXVEC) + SCR(KK) = VSMALL(K,I) + end do + do K=1,NVEC + VSMALL(K,I) = SCR(K) + end do + end do + if (NRON < NRROOT) then + write(u6,*) 'DIAGRO Error: Linear dependence has reduced' + write(u6,*) ' the number of solutions to NRON, but you' + write(u6,*) ' wanted NRROOT soultions.' + write(u6,'(1X,A,I3)') ' NRON=',NRON + write(u6,'(1X,A,I3)') 'NRROOT=',NRROOT + call QUIT(_RC_INTERNAL_ERROR_) + end if + ! ORDER THE EIGENFUNCTIONS BY DECREASING OVERLAP WITH THE SPACE + ! SPANNED BY THE ORIGINALLY SELECTED REFCI ROOTS. + call DGEMM_('N','N',NVEC,NRON,NVEC,One,PSMALL,MXVEC,VSMALL,MXVEC,Zero,SCR,NVEC) + II = 1 + do I=1,NRON + PSEL(I) = DDOT_(NVEC,VSMALL(1,I),1,SCR(II),1) + II = II+NVEC + end do + ! PSEL(I) NOW CONTAINS EXPECTATION VALUE OF PMAT FOR I-TH EIGENVECTOR. + !write(u6,*) ' ARRAY OF SELECTION AMPLITUDES IN SCR:' + !write(u6,'(1X,5F15.6)') (PSEL(I),I=1,NRON) + do I=1,NRON-1 + IMAX = I + PMAX = PSEL(I) + do J=I+1,NRON + if (PSEL(J) >= PMAX) then + PMAX = PSEL(J) + IMAX = J + end if + end do + if (IMAX == I) cycle + PSEL(IMAX) = PSEL(I) + PSEL(I) = PMAX + TMP = ESMALL(IMAX) + ESMALL(IMAX) = ESMALL(I) + ESMALL(I) = TMP + do K=1,NVEC + TMP = VSMALL(K,IMAX) + VSMALL(K,IMAX) = VSMALL(K,I) + VSMALL(K,I) = TMP + end do + end do + ! FINALLY, REORDER THE SELECTED ROOTS BY ENERGY: + do I=1,NRROOT-1 + IMIN = I + EMIN = ESMALL(I) + do J=I+1,NRROOT + if (ESMALL(J) < EMIN) then + EMIN = ESMALL(J) + IMIN = J + end if + end do + if (IMIN == I) cycle + ESMALL(IMIN) = ESMALL(I) + ESMALL(I) = EMIN + TMP = PSEL(IMIN) + PSEL(IMIN) = PSEL(I) + PSEL(I) = TMP + do K=1,NVEC + TMP = VSMALL(K,IMIN) + VSMALL(K,IMIN) = VSMALL(K,I) + VSMALL(K,I) = TMP + end do + end do + !write(u6,*) ' EIGENVALUES OF HSMALL. NRON=',NRON + !write(u6,'(1X,5F15.6)') (ESMALL(I),I=1,NRON) + !write(u6,*) ' SELECTION WEIGHTS:' + !write(u6,'(1X,5F15.6)') ( PSEL(I),I=1,NRON) + !write(u6,*) ' SELECTED EIGENVECTORS:' + !do I=1,NRROOT + ! write(u6,'(1X,5F15.6)') (VSMALL(K,I),K=1,NVEC) + !end do + !write(u6,*) + ! -------------------------------------------------------------------- + ! CALCULATE RESIDUAL ARRAYS FOR THE NRROOTS EIGENFUNCTIONS OF HSMALL. + ! ALSO, USE THE OPPORTUNITY TO FORM MANY OTHER SMALL ARRAYS. + call mma_allocate(ARR,NRROOT,NRROOT,11,label='ARR') + call HZLP1(CBUF,SBUF,DBUF,ARR,CSECT,RSECT,XI1,XI2,ICI) + ! USE THESE SMALLER ARRAYS TO FORM HZERO AND SZERO. THIS IS + ! OVERLAP AND HAMILTONIAN IN THE BASIS (PSI,RHO,XI1,XI2), WHERE + ! PSI ARE THE EIGENFUNCTIONS OF HSMALL, RHO ARE RESIDUALS, ETC. + call HZ(ARR) + call mma_deallocate(ARR) + NZ = 4*NRROOT + !write(u6,*) + !write(u6,*) ' AFTER HZ CALL. HZERO HAMILTONIAN:' + !do I=1,NZ + ! write(u6,'(1X,5F15.6)') (HZERO(I,J),J=1,NZ) + !end do + !write(u6,*) ' SZERO:' + !do I=1,NZ + ! write(u6,'(1X,5F15.6)') (SZERO(I,J),J=1,NZ) + !end do + do I=1,NRROOT + RNRM(I) = sqrt(SZERO(NRROOT+I,NRROOT+I)) + !EPERT(I) = ESMALL(I)-SZERO(3*NRROOT+I,NRROOT+I) + end do + !write(u6,*) + !write(u6,*) ' PERTURBATION ESTIMATES TO ENERGY:' + !write(u6,'(1X,5F15.6)') (ESHIFT+EPERT(I),I=1,NRROOT) + ! -------------------------------------------------------------------- + NCONV = 0 + call TIMING(CPTNOW,DUM,DUM,DUM) + CPTIT = CPTNOW-CPTOLD + CPTOLD = CPTNOW + CPTOT = CPTNOW-CPTSTA + if (ITER == 1) then + EDISP = ESMALL(1)+ESHIFT + write(u6,1234) ITER,NVEC,EDISP,RNRM(1),PSEL(1),CPTIT,CPTOT + else + ELOW = ESMALL(1)-ELAST(1) + if ((ELOW < Zero) .and. (abs(ELOW) <= ETHRE)) NCONV = 1 + EDISP = ESMALL(1)+ESHIFT + write(u6,1235) ITER,NVEC,EDISP,ELOW,RNRM(1),PSEL(1),CPTIT,CPTOT + end if + if (NRROOT > 1) then + do I=2,NRROOT + EDISP = ESMALL(I)+ESHIFT + if (ITER == 1) then + write(u6,1236) EDISP,RNRM(I),PSEL(I) + else + ELOW = ESMALL(I)-ELAST(I) + if ((ELOW < Zero) .and. (abs(ELOW) <= ETHRE)) NCONV = NCONV+1 + write(u6,1237) EDISP,ELOW,RNRM(I),PSEL(I) + end if + end do + write(u6,*) + end if + do I=1,NRROOT + ELAST(I) = ESMALL(I) + end do + if (NCONV == NRROOT) then + write(u6,*) ' CONVERGENCE IN ENERGY.' + exit + end if + ! -------------------------------------------------------------------- + THR = 1.0e-6_wp + call SECULAR(MXZ,NZ,NRON,HZERO,SZERO,VZERO,EZERO,SCR,THR) + !write(u6,*) ' AFTER SECULAR CALL. NRON=',NRON + !write(u6,*) ' EIGENVALUES & -VECTORS:' + !do I=1,NRON + ! write(u6,'(1X,5F15.6)') EZERO(I) + ! write(u6,'(1X,5F15.6)') (VZERO(K,I),K=1,NZ) + !end do + ! ORDER THE EIGENFUNCTIONS BY DECREASING SIZE OF PSI PART. + call DGEMM_('T','N',NRON,NRROOT,NZ,One,VZERO,MXZ,SZERO,MXZ,Zero,SCR(1+NRON),NRON) + do I=1,NRON + II = I + RSUM = Zero + do K=1,NRROOT + II = II+NRON + RSUM = RSUM+SCR(II)**2 + end do + SCR(I) = RSUM + end do + !write(u6,*) + !write(u6,*) ' SELECTION CRITERION VECTOR, BEFORE ORDERING:' + !write(u6,'(1X,5F15.6)') (SCR(I),I=1,NRON) + do I=1,NRON-1 + IMAX = I + PMAX = SCR(I) + do J=I+1,NRON + if (SCR(J) >= PMAX) then + PMAX = SCR(J) + IMAX = J + end if + end do + if (IMAX == I) cycle + SCR(IMAX) = SCR(I) + SCR(I) = PMAX + TMP = EZERO(IMAX) + EZERO(IMAX) = EZERO(I) + EZERO(I) = TMP + do K=1,NZ + TMP = VZERO(K,IMAX) + VZERO(K,IMAX) = VZERO(K,I) + VZERO(K,I) = TMP + end do + end do + !PAM 94-10-30, must reorder as before: + ! REORDER THE SELECTED ROOTS BY ENERGY: + do I=1,NRROOT-1 + IMIN = I + EMIN = EZERO(I) + do J=I+1,NRROOT + if (EZERO(J) < EMIN) then + EMIN = EZERO(J) + IMIN = J + end if + end do + if (IMIN == I) cycle + EZERO(IMIN) = EZERO(I) + EZERO(I) = EMIN + TMP = SCR(IMIN) + SCR(IMIN) = SCR(I) + SCR(I) = TMP + do K=1,NZ + TMP = VZERO(K,IMIN) + VZERO(K,IMIN) = VZERO(K,I) + VZERO(K,I) = TMP + end do + end do + !PAM 94-10-30, end of update. + ! NOTE: IF THE UPDATE PART IS SMALL ENOUGH FOR ALL THE FIRST NRROOT + ! ARRAY, THE CALCULATION HAS CONVERGED. + NNEW = 0 + !write(u6,*) ' CONVERGENCE CRITERION: SIZE OF UPDATE PART.' + do I=1,NRROOT + SQNRM = One-SCR(I) + !write(u6,*) ' ROOT NR, SQNRM:',I,SQNRM + if (SQNRM >= SQNLIM) NNEW = NNEW+1 + end do + !write(u6,*) + !write(u6,*) ' EIGENVALUES OF THE HZERO HAMILTONIAN:' + !write(u6,'(1X,5F15.6)') (EZERO(I),I=1,NRON) + !write(u6,*) ' SELECTION WEIGHTS:' + !write(u6,'(1X,5F15.6)') (SCR(I),I=1,NRON) + !write(u6,*) ' EIGENVECTORS:' + !do I=1,NRON + ! write(u6,'(1X,5F15.6)') (VZERO(K,I),K=1,NZ) + !end do + !write(u6,*) ' NR OF NEW VECTORS SELECTED, NNEW:',NNEW + if (NNEW == 0) then + write(u6,*) ' CONVERGENCE IN NORM.' + exit + end if + ! NOTE: A CHANGE HERE. ALWAYS USE ALL THE NRROOT UPDATED VECTORS TO + ! AVOID OVERWRITING AN EARLY CONVERGED VECTOR (WHICH HAS NEVER BEEN + ! OUTDATED BY A LATER) BY A VECTOR BELONGING TO ANOTHER ROOT. + NNEW = NRROOT + ! -------------------------------------------------------------------- + ! FORM NEW UPDATED VECTORS: SKIP THE FIRST NRROOT-NNEW VECTORS, + ! WHICH MAKE NO ESSENTIAL IMPROVEMENT. + !write(u6,*) ' RESET VZERO TO (0,0,0,1) FOR CONVENTIONAL DAVIDSON.' + !VZERO(:,1:NRROOT) = Zero + !call DCOPY_(NRROOT,[One],0,VZERO(3*NRROOT+1,1),MXZ+1) + call HZLP2(CBUF,SBUF,DBUF,CSECT,RSECT,XI1,XI2,CNEW,ICI) + if (ITER >= MAXIT) then + write(u6,*) ' UNCONVERGED.' + exit + end if +end do +call mma_deallocate(IDC) +call mma_deallocate(IDS) +call mma_deallocate(ELAST) +call mma_deallocate(HCOPY) +call mma_deallocate(PCOPY) +call mma_deallocate(SCOPY) +call mma_deallocate(PSEL) +call mma_deallocate(RNRM) +call mma_deallocate(HSMALL) +call mma_deallocate(SSMALL) +call mma_deallocate(PSMALL) +call mma_deallocate(EZERO) +call mma_deallocate(HZERO) +call mma_deallocate(SZERO) +call mma_deallocate(VZERO) +write(u6,*) ' ',('*',III=1,70) +! WRITE CI VECTORS TO LUREST -- CI RESTART FILE. +IDREST = 0 +do I=1,NRROOT + IVEC = 1+mod(NVTOT-NRROOT+I-1,MXVEC) + IDISK = IDISKC(IVEC) + do ISTA=1,NCONF,MBUF + NN = min(MBUF,NCONF+1-ISTA) + call iDAFILE(LUEIG,2,ICI,NN,IDISK) + call UPKVEC(NN,ICI,CI(ISTA)) + end do + call CSFTRA(' CSF',CI,AREF) + C2REF = Zero + do IR=1,NREF + ICSF = IREFX(IR) + C = CI(ICSF) + C2REF = C2REF+C**2 + end do + IR = IROOT(I) + ECI = ESMALL(I)+ESHIFT + ENREF = ECI-EREF(IR) + C2NREF = One-C2REF + ! WRITE ENERGIES TO PRINTED OUTPUT, AND SAVE TOTAL ENERGIES TO ENGY + ! FOR LATER PRINTOUT WITH PROPERTIES: + write(u6,'(A,I3)') ' FINAL RESULTS FOR STATE NR ',I + write(u6,'(A,I3)') ' CORRESPONDING ROOT OF REFERENCE CI IS NR:',IR + write(u6,'(A,F15.8)') ' REFERENCE CI ENERGY:',EREF(IR) + write(u6,'(A,F15.8)') ' EXTRA-REFERENCE WEIGHT:',C2NREF + if (ICPF == 1) then + write(u6,'(A,F15.8)') ' ACPF CORRELATION ENERGY:',ENREF + write(u6,'(A,F15.8)') ' ACPF ENERGY:',ECI + ENGY(I,1) = ECI + ENGY(I,2) = Zero + ENGY(I,3) = Zero + call Add_Info('E_MRACPF',[ECI],1,8) + else + write(u6,'(A,F15.8)') ' CI CORRELATION ENERGY:',ENREF + write(u6,'(A,F15.8)') ' CI ENERGY:',ECI + ! APPROXIMATE CORRECTIONS FOR UNLINKED QUADRUPLES: + QDAV = ENREF*C2NREF/C2REF + EDAV = ECI+QDAV + QACPF = ENREF*(C2NREF*(One-GFAC))/(C2REF+GFAC*C2NREF) + EACPF = ECI+QACPF + write(u6,'(A,F15.8)') ' DAVIDSON CORRECTION:',QDAV + write(u6,'(A,F15.8)') ' CORRECTED ENERGY:',EDAV + write(u6,'(A,F15.8)') ' ACPF CORRECTION:',QACPF + write(u6,'(A,F15.8)') ' CORRECTED ENERGY:',EACPF + ENGY(I,1) = ECI + ENGY(I,2) = QDAV + ENGY(I,3) = QACPF + call Add_Info('E_MRSDCI',[ECI],1,8) + end if + write(u6,*) + call PRWF_MRCI(CSPCK,INTSY,INDX,CI,JREFX) + write(u6,*) ' ',('*',III=1,70) + call dDAFILE(LUREST,1,CI,NCONF,IDREST) +end do + +call mma_deallocate(CBUF) +call mma_deallocate(SBUF) +call mma_deallocate(DBUF) +call mma_deallocate(CSECT) +call mma_deallocate(RSECT) +call mma_deallocate(XI1) +call mma_deallocate(XI2) +call mma_deallocate(CNEW) +call mma_deallocate(scr) + +return + +1234 format(1X,I4,1X,I4,1X,F15.8,9X,D9.2,1X,F6.3,2(1X,F7.1)) +1235 format(1X,I4,1X,I4,1X,F15.8,D9.2,D9.2,1X,F6.3,2(1X,F7.1)) +1236 format(11X,F15.8,9X,D9.2,1X,F6.3) +1237 format(11X,F15.8,D9.2,D9.2,1X,F6.3) + +end subroutine MQCT diff -Nru openmolcas-22.02/src/mrci/mrci.f openmolcas-22.10/src/mrci/mrci.f --- openmolcas-22.02/src/mrci/mrci.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/mrci.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,116 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE MRCI(IRETURN) -************************************************************************ -* MULTI REFERENCE SDCI AND AVERAGE CPF PROGRAM. * -************************************************************************ -C UNITS USED IN THE PROGRAM -C UNIT 5, INPUT -C UNIT 6, OUTPUT -C UNIT 2=LUPROP, (DA,ONEINT) FOR PROPERTY CALCULATIONS -C UNIT 10=LUSYMB, (DA,CIGUGA) SYMBOLIC FORMULAS -C UNIT 50=LUTRA, (DA,TRAINT) TRANSFORMED MO 2-EL INTEGRALS -C UNIT 60, (DA) SORTED AIBJ, ABIJ AND AIJK INTEGRALS -C UNIT 70, (DA) SORTED IJKL AND ABCI INTEGRALS -C UNIT 80, (DA) SORTED ABCD INTEGRALS -C UNIT 17=LUONE, (DA,TRAONE) ONE ELECTRON INTEGRALS -C UNIT 18=LUVEC, (Formatted, sequential!) MRCI ORBITALS OUT -C UNIT 23=LUEIG, (DA) WORKSPACE FOR MALMQUIST DIAGONALIZATION. -C UNIT 25, (DA) FOCK MATRIX AND DIAGONAL CSF MATRIX ELEMENTS -C UNIT 27, (DA) SCRATCH IN IIJJ. ALSO, REFERENCE CI VECTOR. -C UNIT 28=LUREST, (DA,MRCIVECT) CI VECTOR -************************************************************************ - IMPLICIT REAL*8 (A-H,O-Z) -* -#include "WrkSpc.fh" - -#include "SysDef.fh" - -#include "mrci.fh" -* -* Prologue, print program header -* -* CALL SETTIM - !CALL XUFLOW -* -* ( Workspace allocated in Start() ) -* -* Call IniMem -*PAM04 Call GetMem('WrkSpc','Max ','Real',MemOff,MaxMem) -*PAM04* PAM July 2004: -*PAM04* Actually allocate only half the memory, minus some spare overhead. -*PAM04* This is a temporary measure. I will systematically change the -*PAM04* present static allocation in order to use GETMEM instead. -*PAM04* Changed statement: -*PAM04* MaxMem=MaxMem-3*1000 -*PAM04 MaxMem=(MaxMem-3*1000)/2 -*PAM04 Call GetMem('WrkSpc','Allo','Real',MemOff,MaxMem) -*PAM04 write(6,*)' Allocated ''WrkSpc''. memoff, maxmem=',memoff,maxmem - -*PAM04 Now try completely without ''WrkSpc'' array: - Call GetMem('HowMuch','Max ','Real',LDummy,MemTot) -* -* Open files -* - LUVEC=18 -* - LUSYMB=10 - CALL DANAME(LUSYMB,'CIGUGA') - LUTRA=50 - CALL DANAME_MF(LUTRA,'TRAINT') - LUONE=17 - CALL DANAME(LUONE,'TRAONE') - LUREST=28 - CALL DANAME(LUREST,'MRCIVECT') -C Temporaries: - Lu_60=60 - CALL DANAME_MF(Lu_60 ,'TIABIJ') - Lu_70=70 - CALL DANAME_MF(Lu_70 ,'TIABCI') - Lu_80=80 - CALL DANAME_MF(Lu_80 ,'TIABCD') - LUEIG=23 - CALL DANAME(LUEIG,'FT23F001') - Lu_25=25 - CALL DANAME(Lu_25 ,'FT25F001') - Lu_27=27 - CALL DANAME(Lu_27 ,'FT27F001') -* -* main body -* -*PAM04 iMemOff=ip_of_iWork(Work(MemOff)) -*PAM04 CALL SDCI(Work(MemOff),iWork(iMemOff)) - CALL SDCI_MRCI() -* -* Epilogue, end -* -* * -************************************************************************ -* * -* Close open dafiles. -* - CALL DACLOS(LUSYMB) - CALL DACLOS(LUTRA ) - CALL DACLOS(LUONE ) - CALL DACLOS(LUREST) - CALL DACLOS(Lu_60 ) - CALL DACLOS(Lu_70 ) - CALL DACLOS(Lu_80 ) - CALL DACLOS(LUEIG ) - CALL DACLOS(Lu_25 ) - CALL DACLOS(Lu_27 ) -* * -************************************************************************ -* * - Call FastIO('STATUS') - IRETURN=0 - RETURN - END diff -Nru openmolcas-22.02/src/mrci/mrci.F90 openmolcas-22.10/src/mrci/mrci.F90 --- openmolcas-22.02/src/mrci/mrci.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/mrci.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,95 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine MRCI(IRETURN) +!*********************************************************************** +! MULTI REFERENCE SDCI AND AVERAGE CPF PROGRAM. * +!*********************************************************************** +! UNITS USED IN THE PROGRAM +! UNIT u5, INPUT +! UNIT u6, OUTPUT +! UNIT 2=LUPROP, (DA,ONEINT) FOR PROPERTY CALCULATIONS +! UNIT 10=LUSYMB, (DA,CIGUGA) SYMBOLIC FORMULAS +! UNIT 50=LUTRA, (DA,TRAINT) TRANSFORMED MO 2-EL INTEGRALS +! UNIT 60, (DA) SORTED AIBJ, ABIJ AND AIJK INTEGRALS +! UNIT 70, (DA) SORTED IJKL AND ABCI INTEGRALS +! UNIT 80, (DA) SORTED ABCD INTEGRALS +! UNIT 17=LUONE, (DA,TRAONE) ONE ELECTRON INTEGRALS +! UNIT 18=LUVEC, (Formatted, sequential!) MRCI ORBITALS OUT +! UNIT 23=LUEIG, (DA) WORKSPACE FOR MALMQUIST DIAGONALIZATION. +! UNIT 25, (DA) FOCK MATRIX AND DIAGONAL CSF MATRIX ELEMENTS +! UNIT 27, (DA) SCRATCH IN IIJJ. ALSO, REFERENCE CI VECTOR. +! UNIT 28=LUREST, (DA,MRCIVECT) CI VECTOR +!*********************************************************************** + +use mrci_global, only: Lu_25, Lu_27, Lu_60, Lu_70, Lu_80, LUEIG, LUONE, LUREST, LUSYMB, LUTRA, LUVEC, MEMTOT +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(out) :: IRETURN + +call mma_maxdble(MemTot) + +! Open files + +LUVEC = 18 + +LUSYMB = 10 +call DANAME(LUSYMB,'CIGUGA') +LUTRA = 50 +call DANAME_MF(LUTRA,'TRAINT') +LUONE = 17 +call DANAME(LUONE,'TRAONE') +LUREST = 28 +call DANAME(LUREST,'MRCIVECT') +! Temporaries: +Lu_60 = 60 +call DANAME_MF(Lu_60,'TIABIJ') +Lu_70 = 70 +call DANAME_MF(Lu_70,'TIABCI') +Lu_80 = 80 +call DANAME_MF(Lu_80,'TIABCD') +LUEIG = 23 +call DANAME(LUEIG,'FT23F001') +Lu_25 = 25 +call DANAME(Lu_25,'FT25F001') +Lu_27 = 27 +call DANAME(Lu_27,'FT27F001') + +! main body + +call SDCI_MRCI() + +! Epilogue, end +! * +!*********************************************************************** +! * +! Close open dafiles. + +call DACLOS(LUSYMB) +call DACLOS(LUTRA) +call DACLOS(LUONE) +call DACLOS(LUREST) +call DACLOS(Lu_60) +call DACLOS(Lu_70) +call DACLOS(Lu_80) +call DACLOS(LUEIG) +call DACLOS(Lu_25) +call DACLOS(Lu_27) +! * +!*********************************************************************** +! * +call FastIO('STATUS') +IRETURN = 0 + +return + +end subroutine MRCI diff -Nru openmolcas-22.02/src/mrci/mrci.fh openmolcas-22.10/src/mrci/mrci.fh --- openmolcas-22.02/src/mrci/mrci.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/mrci.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,76 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -C -#include "Molcas.fh" -C COMMON INFORMATION FOR MRCI/ACPF PROGRAM -C - PARAMETER (MXREF=1000) - PARAMETER (MXPROP=30) -*PAM04 COMMON /ARCMMG/ MAXMEM - COMMON /ARCMMG/ MEMTOT,MEMWRK,MEMPRM - COMMON/REAL_MRCI/SPIN,POTNUC,ETHRE,CTRSH,ETRSH, - & ENP,GFAC,THRORB,CSEL(50), - & PNUC(MXPROP),PORIG(3,MXPROP),ENGY(MXROOT,3) - COMMON/INTEG_MRCI/NELEC,LN,NDIAG(MXORB),LSYM, - & JJS(18),NVPAIR(8),IREST,NCONF,NBMN, - & NCVAL,NCDOUB,NCTRIP,NCSING,IREFX(MXREF),ISMAX,NVMAX,NVSQ, - & IORB(MXORB),ICH(MXORB),IROW(MXORB+1),NSYM,NFMO(8), - & NFRO(8),NISH(8),NASH(8),NVAL(8),NVIR(8),NCSH(8),NDEL(8), - & NDMO(8),NORB(8),NBAS(8),NFMOT,NFROT,NISHT,NASHT,NVIRT,NCSHT, - & NVALT,NDELT,NDMOT,NORBT,NBAST,MUL(8,8),NSM(MXORB),IPRINT, - & IFIRST,IRC(4),ISC(4),JSC(4),ITER, - & NVIRP(8),MAXIT,NREF,ICPF,KBUFF1,IREFCI, - & ITRANS,NRROOT,IROOT(MXROOT),NSEL,NCOMP(MXROOT),NCSPCK,NINTSY, - & NIWLK,NBMAX,NCMO,NBTRI,NPROP,IPCOMP(MXPROP) - Common /files_mrci/ LUVEC, LUSYMB, LUTRA, LUONE, - & LUREST, Lu_60, Lu_70, Lu_80, - & LUEIG, Lu_25, Lu_27, LUPROP -#include "tratoc.fh" - PARAMETER (NTIBUF=nTraBuf) - COMMON/TRABUF/ TIBUF(NTIBUF) -C Integral I/O buffer, for sorting etc. - PARAMETER(NSRTMX=nTraBuf) - COMMON/SORTBUF/VALSRT(NSRTMX),INDSRT(NSRTMX+2) -C Bins for sorting: - COMMON/BINS/ NBITM1,NCHN1,NBSIZ1,NBITM2,NCHN2,NBSIZ2, - & NBITM3,NCHN3,NBSIZ3,IPASS - CHARACTER*(LENIN8) NAME(MXBAS) - CHARACTER*4 PTYPE(MXPROP) - CHARACTER*8 PNAME(MXPROP) - CHARACTER*20 SSEL(50) - COMMON /CHARAC_MRCI/ NAME,SSEL,PTYPE,PNAME -C VERTEX CODES USED FOR VALENCE,DOUBLET,TRIPLET, AND SINGLET CASE: - PARAMETER (IVVER=0, IDVER=1, ITVER=2, ISVER=3) -C SQUARE ROOT OF 2, AND ITS INVERSE, USED IN CSCALE: - PARAMETER (SQ2= 1.41421356237309505D00, SQ2INV=SQ2/2) - PARAMETER(MCHAIN=40000) - COMMON/RA_MRCI/LASTAD(MCHAIN) -C -C SIZE OF BUFFERS WRITTEN BY GUGA PROGRAM. -#include "cop.fh" - COMMON/ADDR_MRCI/IAD25S,IADABCI,ITOC17(64),ITOC2(64) - COMMON/ALLO_MRCI/ LCSPCK,LINTSY,LINDX,LISAB,LJREFX,LCISEL, - * LPERMA,LTIBUF,LFOCK,LBIN1,LBIAC1,LBICA1, - * LBUFBI,LBIN2,LBACBD,LACBDS,LACBDT, - * LHDIAG,LIIJJ,LIJIJ,LBIN3, - * LCI,LSGM,LHREF,LAREF,LEREF,LPLEN, - * LMQ,LARR,LABIJ,LAIBJ,LAJBI, - * LBFIN1,LASCR1,LBSCR1,LFSCR1,LFSEC, - * LFIJKL,LBFIN2,LBMN,LIBMN,LBIAC2,LBICA2, - * LBFIN3,LAC1,LAC2,LBFIN4,LBFIN5,LASCR2,LBSCR2, - * LFSCR2,LDBK,LDMO,LTDMO,LPRP,LICI - PARAMETER (MXVEC=50, NSECT=256, MXZ=4*MXROOT) - COMMON /DAVID/ HSMALL(MXVEC,MXVEC),SSMALL(MXVEC,MXVEC), - * ESMALL(MXVEC),VSMALL(MXVEC,MXVEC),PSMALL(MXVEC,MXVEC), - * HZERO(MXZ,MXZ),SZERO(MXZ,MXZ),VZERO(MXZ,MXZ), - * EZERO(MXZ),ESHIFT,SQNLIM,MBUF, - * NOLD,NVEC,NNEW,NSCR,INSERT(MXVEC),IDISKD,IDISKA, - * IDISKC(MXVEC),IDISKS(MXVEC),IDFREE,NVTOT,NSTOT diff -Nru openmolcas-22.02/src/mrci/mrci_global.F90 openmolcas-22.10/src/mrci/mrci_global.F90 --- openmolcas-22.02/src/mrci/mrci_global.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/mrci_global.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,53 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +module mrci_global + +use Constants, only: Two, Half +use Definitions, only: wp, iwp + +implicit none +private + +#include "Molcas.fh" +#include "tratoc.fh" + +integer(kind=iwp), parameter :: IDVER = 1, IVVER = 0, MCHAIN = 40000, MXPROP = 30, MXREF = 1000, MXVEC = 50, MXZ = 4*MXROOT, & + NSECT = 256, NSRTMX = nTraBuf, NTIBUF = nTraBuf +real(kind=wp), parameter :: SQ2 = sqrt(Two), SQ2INV = sqrt(Half) + +integer(kind=iwp) :: IAD25S, IADABCI, ICH(MXORB), ICPF, IDFREE, IDISKC(MXVEC), IDISKD, IDISKS(MXVEC), IFIRST, INDSRT(NSRTMX+2), & + IORB(MXORB), IPASS, IPCOMP(MXPROP), IPRINT, IRC(4), IREFCI, IREFX(MXREF), IREST, IROOT(MXROOT), & + IROW(MXORB+1), ISMAX, ITER, ITOC17(64), ITRANS, JJS(18), JSC(4), KBUFF1, LASTAD(MCHAIN), LN, LSYM, Lu_25, & + Lu_27, Lu_60, Lu_70, Lu_80, LUEIG, LUONE, LUREST, LUSYMB, LUTRA, LUVEC, MAXIT, MBUF, MEMPRM, MEMTOT, MEMWRK, & + NASH(8), NBAS(8), NBAST, NBITM1, NBITM2, NBITM3, NBMAX, NBMN, NBTRI, NCHN1, NCHN2, NCHN3, NCMO, & + NCOMP(MXROOT), NCONF, NCSHT, NCSPCK, NCVAL, NDEL(8), NDIAG(MXORB), NDMO(8), NELEC, NFMO(8), NFRO(8), NISH(8), & + NNEW, NORB(8), NORBT, NPROP, NREF, NRROOT, NSEL, NSM(MXORB), NSTOT, NSYM, NVEC, NVIR(8), NVIRP(8), NVIRT, & + NVMAX, NVPAIR(8), NVSQ, NVTOT +real(kind=wp) :: CSEL(50), CTRSH, ENGY(MXROOT,3), ENP, ESHIFT, ESMALL(MXVEC), ETHRE, ETRSH, GFAC, PNUC(MXPROP), PORIG(3,MXPROP), & + POTNUC, SQNLIM, THRORB, TIBUF(NTIBUF), VALSRT(NSRTMX), VSMALL(MXVEC,MXVEC) +character(len=LenIn8) :: BNAME(MXBAS) +character(len=20) :: SSEL(50) +character(len=8) :: PNAME(MXPROP) +character(len=4) :: PTYPE(MXPROP) +integer(kind=iwp), allocatable :: CSPCK(:), INDX(:), INTSY(:), ISAB(:,:), JREFX(:) +real(kind=wp), allocatable :: CISEL(:,:), DMO(:), FIJKL(:), FOCK(:), HZERO(:,:), SZERO(:,:), TDMO(:,:), VZERO(:,:) + +public :: BNAME, CISEL, CSEL, CSPCK, CTRSH, DMO, ENGY, ENP, ESHIFT, ESMALL, ETHRE, ETRSH, FIJKL, FOCK, GFAC, HZERO, IAD25S, & + IADABCI, ICH, ICPF, IDFREE, IDISKC, IDISKD, IDISKS, IDVER, IFIRST, INDSRT, INDX, INTSY, IORB, IPASS, IPCOMP, IPRINT, & + IRC, IREFCI, IREFX, IREST, IROOT, IROW, ISAB, ISMAX, ITER, ITOC17, ITRANS, IVVER, JJS, JREFX, JSC, KBUFF1, LASTAD, LN, & + LSYM, Lu_25, Lu_27, Lu_60, Lu_70, Lu_80, LUEIG, LUONE, LUREST, LUSYMB, LUTRA, LUVEC, MAXIT, MBUF, MCHAIN, MEMPRM, & + MEMTOT, MEMWRK, MXREF, MXVEC, MXZ, NASH, NBAS, NBAST, NBITM1, NBITM2, NBITM3, NBMAX, NBMN, NBTRI, NCHN1, NCHN2, NCHN3, & + NCMO, NCOMP, NCONF, NCSHT, NCSPCK, NCVAL, NDEL, NDIAG, NDMO, NELEC, NFMO, NFRO, NISH, NNEW, NORB, NORBT, NPROP, NREF, & + NRROOT, NSECT, NSEL, NSM, NSRTMX, NSTOT, NSYM, NTIBUF, NVEC, NVIR, NVIRP, NVIRT, NVMAX, NVPAIR, NVSQ, NVTOT, PNAME, & + PNUC, PORIG, POTNUC, PTYPE, SQ2, SQ2INV, SQNLIM, SSEL, SZERO, TDMO, THRORB, TIBUF, VALSRT, VSMALL, VZERO + +end module mrci_global diff -Nru openmolcas-22.02/src/mrci/mtrans.f openmolcas-22.10/src/mrci/mtrans.f --- openmolcas-22.02/src/mrci/mtrans.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/mtrans.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE MTRANS(A,IA,B,IB,N,M) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(M,N),B(N,M) - DO 10 I=1,N - DO 20 J=1,M - B(I,J)=A(J,I) -20 CONTINUE -10 CONTINUE - RETURN -c Avoid unused argument warnings - IF (.FALSE.) THEN - CALL Unused_integer(IA) - CALL Unused_integer(IB) - END IF - END diff -Nru openmolcas-22.02/src/mrci/natorb_mrci.f openmolcas-22.10/src/mrci/natorb_mrci.f --- openmolcas-22.02/src/mrci/natorb_mrci.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/natorb_mrci.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,98 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE NATORB_MRCI(CMO,DMO,CNO,OCC,SCR) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION CMO(NCMO),DMO(NBTRI),CNO(NCMO),OCC(NBAST) - DIMENSION SCR( (NBMAX*(NBMAX+1))/2 ) - -#include "SysDef.fh" - -#include "mrci.fh" - CALL DCOPY_(NBAST,[0.0D00],0,OCC,1) - CALL DCOPY_(NCMO,CMO,1,CNO,1) -C LOOP OVER SYMMETRY LABELS -C Present index of end of processed CMO block: - IECMO=0 -C Present end of index to MO-s, to be translated by ICH array: - IEO=0 -C Present end of index to basis functions: - IEB=0 - DO 100 ISYM=1,NSYM - NO=NORB(ISYM) - NIAV=NISH(ISYM)+NASH(ISYM)+NVIR(ISYM) - NB=NBAS(ISYM) - If (NB.eq.0) Go To 100 - ISB=IEB+1 - IEB=IEB+NB -C ORBITALS PRE-FROZEN IN MOTRA, OR FROZEN IN MRCI: - NF=NFMO(ISYM)+NFRO(ISYM) - NBF=NB*NF - ISCMO=IECMO+1 - IECMO=IECMO+NBF -C (DO NOTHING WITH THE FROZEN ORBITALS) - IF(NF.GT.0) CALL DCOPY_(NF,[2.0D00],0,OCC(ISB),1) - IEO=IEO+NFRO(ISYM) -C ORBITALS EXPLICITLY USED IN CI: - NBO=NB*NIAV - ISCMO=IECMO+1 - IECMO=IECMO+NBO - ISO=IEO+1 - IEO=IEO+NIAV -C TRANSFER SYMMETRY BLOCK OF DMO TO TRIANGULAR SCRATCH MATRIX: - I12=0 - DO 10 I=ISO,IEO - IO1=ICH(I) - DO 11 J=ISO,I - IO2=ICH(J) - IO12=(IO1*(IO1-1))/2+IO2 - IF(IO1.LT.IO2) IO12=(IO2*(IO2-1))/2+IO1 - I12=I12+1 - SCR(I12)=DMO(IO12) -11 CONTINUE -10 CONTINUE -C DIAGONALIZE AND TRANSFORM ORBITALS: - CALL JACOB(SCR,CNO(ISCMO),NIAV,NB) -C PICK OCCUP NR FROM DIAGONAL: - II=0 - DO 20 I=1,NIAV - II=II+I - OCC(ISB+NF-1+I)=SCR(II) -20 CONTINUE -C ORDER BY DECREASING NATURAL OCCUPANCY: - NN=NO-NFRO(ISYM) - DO 40 I=1,NN-1 - OMAX=OCC(ISB+NF-1+I) - IMAX=I - DO 30 J=I+1,NN - OC=OCC(ISB+NF-1+J) - IF(OMAX.GE.OC) GOTO 30 - IMAX=J - OMAX=OC -30 CONTINUE - IF(IMAX.EQ.I) GOTO 40 - OCC(ISB+NF-1+IMAX)=OCC(ISB+NF-1+I) - OCC(ISB+NF-1+I)=OMAX - ISTA1=ISCMO+NB*(I-1) - ISTA2=ISCMO+NB*(IMAX-1) - CALL DCOPY_(NB,CNO(ISTA1),1,SCR,1) - CALL DCOPY_(NB,CNO(ISTA2),1,CNO(ISTA1),1) - CALL DCOPY_(NB,SCR,1,CNO(ISTA2),1) -40 CONTINUE -C ORBITALS PRE-DELETED IN MOTRA OR DELETED IN MRCI: - ND=NDMO(ISYM)+NDEL(ISYM) - NBD=NB*ND - ISCMO=IECMO+1 - IECMO=IECMO+NBD - IEO=IEO+NDEL(ISYM) -C (DO NOTHING WITH THE DELETED ORBITALS) -100 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/natorb_mrci.F90 openmolcas-22.10/src/mrci/natorb_mrci.F90 --- openmolcas-22.02/src/mrci/natorb_mrci.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/natorb_mrci.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,108 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine NATORB_MRCI(CMO,DMO,CNO,OCC,SCR) + +use mrci_global, only: ICH, NASH, NBAS, NBAST, NBMAX, NBTRI, NCMO, NDEL, NDMO, NFMO, NFRO, NISH, NORB, NSYM, NVIR +use Constants, only: Zero, Two +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(in) :: CMO(NCMO), DMO(NBTRI) +real(kind=wp), intent(out) :: CNO(NCMO), OCC(NBAST), SCR((NBMAX*(NBMAX+1))/2) +integer(kind=iwp) :: I, I12, IEB, IECMO, IEO, II, IMAX, IO1, IO12, IO2, ISB, ISCMO, ISO, ISTA1, ISTA2, ISYM, J, NB, NBD, NBF, NBO, & + ND, NF, NIAV, NN, NO +real(kind=wp) :: OC, OMAX + +OCC(:) = Zero +CNO(:) = CMO +! LOOP OVER SYMMETRY LABELS +! Present index of end of processed CMO block: +IECMO = 0 +! Present end of index to MO-s, to be translated by ICH array: +IEO = 0 +! Present end of index to basis functions: +IEB = 0 +do ISYM=1,NSYM + NO = NORB(ISYM) + NIAV = NISH(ISYM)+NASH(ISYM)+NVIR(ISYM) + NB = NBAS(ISYM) + if (NB == 0) cycle + ISB = IEB+1 + IEB = IEB+NB + ! ORBITALS PRE-FROZEN IN MOTRA, OR FROZEN IN MRCI: + NF = NFMO(ISYM)+NFRO(ISYM) + NBF = NB*NF + ISCMO = IECMO+1 + IECMO = IECMO+NBF + ! (DO NOTHING WITH THE FROZEN ORBITALS) + if (NF > 0) OCC(ISB:ISB+NF-1) = Two + IEO = IEO+NFRO(ISYM) + ! ORBITALS EXPLICITLY USED IN CI: + NBO = NB*NIAV + ISCMO = IECMO+1 + IECMO = IECMO+NBO + ISO = IEO+1 + IEO = IEO+NIAV + ! TRANSFER SYMMETRY BLOCK OF DMO TO TRIANGULAR SCRATCH MATRIX: + I12 = 0 + do I=ISO,IEO + IO1 = ICH(I) + do J=ISO,I + IO2 = ICH(J) + IO12 = (IO1*(IO1-1))/2+IO2 + if (IO1 < IO2) IO12 = (IO2*(IO2-1))/2+IO1 + I12 = I12+1 + SCR(I12) = DMO(IO12) + end do + end do + ! DIAGONALIZE AND TRANSFORM ORBITALS: + call JACOB(SCR,CNO(ISCMO),NIAV,NB) + ! PICK OCCUP NR FROM DIAGONAL: + II = 0 + do I=1,NIAV + II = II+I + OCC(ISB+NF-1+I) = SCR(II) + end do + ! ORDER BY DECREASING NATURAL OCCUPANCY: + NN = NO-NFRO(ISYM) + do I=1,NN-1 + OMAX = OCC(ISB+NF-1+I) + IMAX = I + do J=I+1,NN + OC = OCC(ISB+NF-1+J) + if (OMAX < OC) then + IMAX = J + OMAX = OC + end if + end do + if (IMAX /= I) then + OCC(ISB+NF-1+IMAX) = OCC(ISB+NF-1+I) + OCC(ISB+NF-1+I) = OMAX + ISTA1 = ISCMO+NB*(I-1) + ISTA2 = ISCMO+NB*(IMAX-1) + SCR(1:NB) = CNO(ISTA1:ISTA1+NB-1) + CNO(ISTA1:ISTA1+NB-1) = CNO(ISTA2:ISTA2+NB-1) + CNO(ISTA2:ISTA2+NB-1) = SCR(1:NB) + end if + end do + ! ORBITALS PRE-DELETED IN MOTRA OR DELETED IN MRCI: + ND = NDMO(ISYM)+NDEL(ISYM) + NBD = NB*ND + ISCMO = IECMO+1 + IECMO = IECMO+NBD + IEO = IEO+NDEL(ISYM) + ! (DO NOTHING WITH THE DELETED ORBITALS) +end do + +return + +end subroutine NATORB_MRCI diff -Nru openmolcas-22.02/src/mrci/order.f openmolcas-22.10/src/mrci/order.f --- openmolcas-22.02/src/mrci/order.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/order.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE ORDER(C,D,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION C(N,N),D(N) - DO 30 I=1,N-1 - IMIN=I - DMIN=D(I) - DO 10 J=I+1,N - IF(D(J).GE.DMIN) GOTO 10 - DMIN=D(J) - IMIN=J -10 CONTINUE - IF(I.EQ.IMIN) GOTO 30 - D(IMIN)=D(I) - D(I)=DMIN - DO 20 K=1,N - TMP=C(K,I) - C(K,I)=C(K,IMIN) - C(K,IMIN)=TMP -20 CONTINUE -30 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/pkvec.f openmolcas-22.10/src/mrci/pkvec.f --- openmolcas-22.02/src/mrci/pkvec.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/pkvec.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,47 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Markus P. Fuelscher * -************************************************************************ - SUBROUTINE PKVEC(NITEM,CVEC,ICVEC) -C*********************************************************************** -C -C PURPOSE: -C ENCODE THE CI-VECTOR BY CHANGING THE NUMBER REPRESENTATION FROM -C REAL*8 ==> INTEGER*4 -C -C NOTE: -C THE INCOMING DATA CVEC SHOULD NOT BE GREATER THAN 1.0. -C THE ACCURACY OF THE UNPACKED VALUES IS APPROX. 1.0E-9. -C -C**** M.P. FUELSCHER, UNIVERSITY OF LUND, SWEDEN, NOV. 1990 ************ -C - IMPLICIT REAL*8 (A-H,O-Z) -* NOTE VERY CAREFULLY!! NINT() (and maybe similar) intrinsics -* are BROKEN in CYGWIN GFORTAN!! -* So the intermediate variable tmp is necessary for it to work! -#ifdef _CYGWIN_ - REAL*4 tmp -#endif - DIMENSION CVEC(NITEM),ICVEC(NITEM) - PARAMETER (SCALE=2147483647.0D0) - INTRINSIC NINT -C - DO 10 ITEM=1,NITEM -#ifdef _CYGWIN_ - tmp=SCALE*CVEC(ITEM) - ICVEC(ITEM)=NINT(tmp) -#else - ICVEC(ITEM)=NINT(SCALE*CVEC(ITEM)) -#endif -10 CONTINUE -C - RETURN - END diff -Nru openmolcas-22.02/src/mrci/pkvec.F90 openmolcas-22.10/src/mrci/pkvec.F90 --- openmolcas-22.02/src/mrci/pkvec.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/pkvec.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,56 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Markus P. Fuelscher * +!*********************************************************************** + +subroutine PKVEC(NITEM,CVEC,ICVEC) +!*********************************************************************** +! +! PURPOSE: +! ENCODE THE CI-VECTOR BY CHANGING THE NUMBER REPRESENTATION FROM +! REAL*8 ==> INTEGER*4 +! +! NOTE: +! THE INCOMING DATA CVEC SHOULD NOT BE GREATER THAN 1.0. +! THE ACCURACY OF THE UNPACKED VALUES IS APPROX. 1.0e-9. +! +!**** M.P. FUELSCHER, UNIVERSITY OF LUND, SWEDEN, NOV. 1990 ************ + +use Definitions, only: wp, iwp +#ifdef _CYGWIN_ +use Definitions, only: r4 +#endif + +implicit none +integer(kind=iwp), intent(in) :: NITEM +real(kind=wp), intent(in) :: CVEC(NITEM) +integer(kind=iwp), intent(out) :: ICVEC(NITEM) +integer(kind=iwp) :: ITEM +real(kind=wp), parameter :: SCL = 2147483647.0_wp +#ifdef _CYGWIN_ +! NOTE VERY CAREFULLY!! NINT() (and maybe similar) intrinsics +! are BROKEN in CYGWIN GFORTAN!! +! So the intermediate variable tmp is necessary for it to work! +real(kind=r4) :: tmp +#endif + +do ITEM=1,NITEM +# ifdef _CYGWIN_ + tmp = SCL*CVEC(ITEM) + ICVEC(ITEM) = nint(tmp) +# else + ICVEC(ITEM) = nint(SCL*CVEC(ITEM)) +# endif +end do + +return + +end subroutine PKVEC diff -Nru openmolcas-22.02/src/mrci/pmatel.f openmolcas-22.10/src/mrci/pmatel.f --- openmolcas-22.02/src/mrci/pmatel.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/pmatel.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,111 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE PMATEL(ISTATE,JSTATE,PROP,PINT,SMAT,CNO,OCC, - * SFOLD,AFOLD,TDAO) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION PINT(NBTRI),SFOLD(NBTRI),AFOLD(NBTRI),CNO(NCMO) - DIMENSION TDAO(NBAST,NBAST),SMAT(*),OCC(NBAST) - DIMENSION IDUM(1) - INTEGER ISYMLB - REAL*8 PROP(NRROOT,NRROOT,NPROP) - -#include "SysDef.fh" -#include "mrci.fh" - SAVE ICALL - DATA ICALL /0/ - IF(ISTATE.EQ.JSTATE) THEN -C READ OVERLAP INTEGRALS FROM TRAONE. - CALL RDONE(IRTC,6,'MLTPL 0',1,SMAT,IDUMMY) -C CALCULATE AND WRITE MULLIKEN CHARGES. - WRITE(6,*) - CALL XFLUSH(6) - WRITE(6,'(A,I2)')' MULLIKEN CHARGES FOR STATE NR ',ISTATE - CALL XFLUSH(6) - CALL CHARGE(NSYM,NBAS,NAME,CNO,OCC,SMAT,2,.True.,.True.) - WRITE(6,*)' ',('*',I=1,70) - CALL XFLUSH(6) - END IF -C FOLD TDAO SYMMETRICALLY (ANTI-SYMM) INTO SFOLD (AFOLD): -C MOLCAS2 UPDATE: SYMMETRY-BLOCKED STORAGE. - CALL DCOPY_(NBTRI,[0.0D00],0,SFOLD,1) - CALL DCOPY_(NBTRI,[0.0D00],0,AFOLD,1) - IJ=0 - IEND=0 - DO ISY=1,NSYM - ISTA=IEND+1 - IEND=IEND+NBAS(ISY) - DO I=ISTA,IEND - DO J=ISTA,I-1 - IJ=IJ+1 - SFOLD(IJ)=TDAO(I,J)+TDAO(J,I) - AFOLD(IJ)=TDAO(I,J)-TDAO(J,I) - END DO - IJ=IJ+1 - SFOLD(IJ)=TDAO(I,I) - AFOLD(IJ)=0.0D00 - END DO - END DO - NSIZ=0 - DO 100 IPROP=1,NPROP -C PICK UP MATRIX ELEMENTS FROM ONE-ELECTRON FILE: - CALL iRDONE(IRTC,1,PNAME(IPROP),IPCOMP(IPROP),IDUM,ISYMLB) - IF(IRTC.EQ.0) NSIZ=IDUM(1) - CALL RDONE(IRTC,0,PNAME(IPROP),IPCOMP(IPROP),PINT,ISYMLB) -C SEPARATE OUT THE OPERATOR GAUGE ORIGIN, AND NUCLEAR CONTRIBUTION: - IF(ICALL.EQ.0) THEN - PORIG(1,IPROP)=PINT(NSIZ+1) - PORIG(2,IPROP)=PINT(NSIZ+2) - PORIG(3,IPROP)=PINT(NSIZ+3) - PNUC(IPROP)=PINT(NSIZ+4) - END IF - IF(ISYMLB.NE.1) THEN -C NON-DIAGONAL SYMMETRY BLOCKS MUST BE COMPRESSED AWAY: - IFROM=1 - ITO=1 - DO 40 ISY1=1,NSYM - NB1=NBAS(ISY1) - IF(NB1.EQ.0) GOTO 40 - DO 30 ISY2=1,ISY1 - NB2=NBAS(ISY2) - IF(NB2.EQ.0) GOTO 30 - ISY12=MUL(ISY1,ISY2) -CPAM96 MASK=2**(ISY12-1) -CPAM96 IF(IAND(ISYMLB,MASK).EQ.0) GOTO 30 - IF(MOD(ISYMLB,2**(ISY12)).EQ.0) GOTO 30 - NB12=NB1*NB2 - IF(ISY12.EQ.1) THEN - NB12=(NB12+NB1)/2 - IF(IFROM.GT.ITO) - * CALL DCOPY_(NB12,PINT(IFROM),1,PINT(ITO),1) - ITO=ITO+NB12 - END IF - IFROM=IFROM+NB12 -30 CONTINUE -40 CONTINUE - NSIZ=ITO - END IF -C PUT DDOT OF TR DENS MATRIX AND INTEGRALS INTO PROPER MATRIX ELEMENT -C FOR MULTIPOLES, USE NEGATIVE SIGN OF ELECTRONIC PART. - SGN=1.0D00 - IF(PNAME(IPROP)(1:5).EQ.'MLTPL') SGN=-SGN - IF(PTYPE(IPROP).EQ.'HERM') THEN - X=SGN*DDOT_(NBTRI,SFOLD,1,PINT,1) - PROP(ISTATE,JSTATE,IPROP)=X - PROP(JSTATE,ISTATE,IPROP)=X - ELSE - X=SGN*DDOT_(NBTRI,AFOLD,1,PINT,1) - PROP(ISTATE,JSTATE,IPROP)=X - PROP(JSTATE,ISTATE,IPROP)=-X - END IF -100 CONTINUE - ICALL=1 - RETURN - END diff -Nru openmolcas-22.02/src/mrci/pmatel.F90 openmolcas-22.10/src/mrci/pmatel.F90 --- openmolcas-22.02/src/mrci/pmatel.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/pmatel.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,112 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine PMATEL(ISTATE,JSTATE,PROP,PINT,SMAT,CNO,OCC,SFOLD,AFOLD,TDAO) + +use mrci_global, only: BNAME, IPCOMP, NBAS, NBAST, NBTRI, NCMO, NPROP, NRROOT, NSYM, PNAME, PNUC, PORIG, PTYPE +use Symmetry_Info, only: Mul +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: ISTATE, JSTATE +real(kind=wp), intent(_OUT_) :: PROP(NRROOT,NRROOT,NPROP), SMAT(*) +real(kind=wp), intent(out) :: PINT(NBTRI+4), SFOLD(NBTRI), AFOLD(NBTRI) +real(kind=wp), intent(in) :: CNO(NCMO), OCC(NBAST), TDAO(NBAST,NBAST) +integer(kind=iwp) :: I, ICALL = 0, IDUM(1), IDUMMY, IEND, IFROM, IJ, IPROP, IRTC, ISTA, ISY, ISY1, ISY12, ISY2, ISYMLB, ITO, J, & + NB1, NB12, NB2, NSIZ +real(kind=wp) :: SGN, X +real(kind=r8), external :: DDOT_ + +if (ISTATE == JSTATE) then + ! READ OVERLAP INTEGRALS FROM TRAONE. + call RDONE(IRTC,6,'MLTPL 0',1,SMAT,IDUMMY) + ! CALCULATE AND WRITE MULLIKEN CHARGES. + write(u6,*) + write(u6,'(A,I2)') ' MULLIKEN CHARGES FOR STATE NR ',ISTATE + call CHARGE(NSYM,NBAS,BNAME,CNO,OCC,SMAT,2,.true.,.true.) + write(u6,*) ' ',('*',I=1,70) +end if +! FOLD TDAO SYMMETRICALLY (ANTI-SYMM) INTO SFOLD (AFOLD): +! MOLCAS2 UPDATE: SYMMETRY-BLOCKED STORAGE. +IJ = 0 +IEND = 0 +do ISY=1,NSYM + ISTA = IEND+1 + IEND = IEND+NBAS(ISY) + do I=ISTA,IEND + do J=ISTA,I-1 + IJ = IJ+1 + SFOLD(IJ) = TDAO(I,J)+TDAO(J,I) + AFOLD(IJ) = TDAO(I,J)-TDAO(J,I) + end do + IJ = IJ+1 + SFOLD(IJ) = TDAO(I,I) + AFOLD(IJ) = Zero + end do +end do +NSIZ = 0 +do IPROP=1,NPROP + ! PICK UP MATRIX ELEMENTS FROM ONE-ELECTRON FILE: + call iRDONE(IRTC,1,PNAME(IPROP),IPCOMP(IPROP),IDUM,ISYMLB) + if (IRTC == 0) NSIZ = IDUM(1) + call RDONE(IRTC,0,PNAME(IPROP),IPCOMP(IPROP),PINT,ISYMLB) + ! SEPARATE OUT THE OPERATOR GAUGE ORIGIN, AND NUCLEAR CONTRIBUTION: + if (ICALL == 0) then + PORIG(1,IPROP) = PINT(NSIZ+1) + PORIG(2,IPROP) = PINT(NSIZ+2) + PORIG(3,IPROP) = PINT(NSIZ+3) + PNUC(IPROP) = PINT(NSIZ+4) + end if + if (ISYMLB /= 1) then + ! NON-DIAGONAL SYMMETRY BLOCKS MUST BE COMPRESSED AWAY: + IFROM = 1 + ITO = 1 + do ISY1=1,NSYM + NB1 = NBAS(ISY1) + if (NB1 == 0) cycle + do ISY2=1,ISY1 + NB2 = NBAS(ISY2) + if (NB2 == 0) cycle + ISY12 = MUL(ISY1,ISY2) + if (mod(ISYMLB,2**(ISY12)) == 0) cycle + NB12 = NB1*NB2 + if (ISY12 == 1) then + NB12 = (NB12+NB1)/2 + if (IFROM > ITO) call DCOPY_(NB12,PINT(IFROM),1,PINT(ITO),1) + ITO = ITO+NB12 + end if + IFROM = IFROM+NB12 + end do + end do + NSIZ = ITO + end if + ! PUT DDOT OF TR DENS MATRIX AND INTEGRALS INTO PROPER MATRIX ELEMENT + ! FOR MULTIPOLES, USE NEGATIVE SIGN OF ELECTRONIC PART. + SGN = One + if (PNAME(IPROP)(1:5) == 'MLTPL') SGN = -SGN + if (PTYPE(IPROP) == 'HERM') then + X = SGN*DDOT_(NSIZ,SFOLD,1,PINT,1) + PROP(ISTATE,JSTATE,IPROP) = X + PROP(JSTATE,ISTATE,IPROP) = X + else + X = SGN*DDOT_(NSIZ,AFOLD,1,PINT,1) + PROP(ISTATE,JSTATE,IPROP) = X + PROP(JSTATE,ISTATE,IPROP) = -X + end if +end do +ICALL = 1 + +return + +end subroutine PMATEL diff -Nru openmolcas-22.02/src/mrci/propct.f openmolcas-22.10/src/mrci/propct.f --- openmolcas-22.02/src/mrci/propct.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/propct.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,223 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE PROPCT() - IMPLICIT REAL*8 (A-H,O-Z) -*PAM04 DIMENSION HWork(*) - CHARACTER*8 FNAME,LABEL -c CHARACTER*8 REMARK - CHARACTER*30 REMARK - CHARACTER*100 REALNAME -#include "SysDef.fh" -#include "mrci.fh" -#include "WrkSpc.fh" -#include "stdalloc.fh" - DIMENSION DUMMY(1),IDUMMY(7,8) - REAL*8, ALLOCATABLE :: PROP(:,:,:) -* -* LCMO=LPRP -* LCNO=LCMO+NCMO -* LOCC=LCNO+NCMO -* LTDAO=LOCC+NBAST -* LDAO=LTDAO -* LAFOLD=LDAO+NBAST**2 -* LSFOLD=LAFOLD+NBTRI -* LPINT =LSFOLD+NBTRI -* LSCR =LPINT+NBTRI+4 -* NSCR=MAX(NBTRI,NBMAX**2) -* LTOP =LSCR+NSCR-1 - CALL GETMEM('CMO','ALLO','REAL',LCMO,NCMO) - CALL GETMEM('CNO','ALLO','REAL',LCNO,NCMO) - CALL GETMEM('OCC','ALLO','REAL',LOCC,NBAST) - CALL GETMEM('DAO','ALLO','REAL',LDAO,NBAST**2) - LTDAO=LDAO - CALL GETMEM('AFOLD','ALLO','REAL',LAFOLD,NBTRI) - CALL GETMEM('SFOLD','ALLO','REAL',LSFOLD,NBTRI) - CALL GETMEM('PINT','ALLO','REAL',LPINT,NBTRI+4) - NSCR=MAX(NBTRI,NBMAX**2) - CALL GETMEM('SCR','ALLO','REAL',LSCR,NSCR) -C LOOP OVER OPERATORS: - IOPT=8 - NPROP=0 - DO 98 I=1,100 -C PICK UP OPERATOR LABELS FROM ONE-ELECTRON FILE: - LABEL='UNDEF' - CALL iRDONE(IRTC,1+IOPT,LABEL,IPC,IDUMMY,ISYMLB) - IF(IRTC.NE.0) GOTO 99 - IOPT=16 -CPAM96 IF(IAND(1,ISYMLB).EQ.0) GOTO 98 - IF(MOD(ISYMLB,2).EQ.0) GOTO 98 - NPROP=NPROP+1 - PNAME(NPROP)=LABEL - IPCOMP(NPROP)=IPC - PTYPE(NPROP)='HERM' - IF(LABEL.EQ.'VELOCITY') PTYPE(NPROP)='ANTI' - IF(LABEL.EQ.'ANGMOM ') PTYPE(NPROP)='ANTI' -98 CONTINUE -99 CONTINUE - CALL MMA_ALLOCATE(PROP,NRROOT,NRROOT,NPROP,'PROP') - CALL DCOPY_(NRROOT*NRROOT*NPROP,[0.0D00],0,PROP,1) - IDDMO=0 - DO 100 ISTATE=1,NRROOT -C PICK UP DMO -*PAM04 CALL dDAFILE(LUEIG,2,HWork(LDMO),NBTRI,IDDMO) - CALL dDAFILE(LUEIG,2,Work(LDMO),NBTRI,IDDMO) -C PICK UP CMO - IDISK=ITOC17(1) - CALL dDAFILE(LUONE,2,Work(LCMO),NCMO,IDISK) -C COMPUTE & WRITE NATURAL ORBITALS -*PAM04 CALL NATORB_MRCI(HWork(LCMO),HWork(LDMO),HWork(LCNO), - CALL NATORB_MRCI(Work(LCMO),Work(LDMO),Work(LCNO), - * Work(LOCC),Work(LSCR)) - WRITE(FNAME,'(A5,I2.2)')'CIORB',ISTATE - REALNAME=FNAME -*PAM04 IF(ISTATE.EQ.1) Call Add_Info('CI_DENS1',HWork(LDMO),1,5) - IF(ISTATE.EQ.1) Call Add_Info('CI_DENS1',Work(LDMO),1,5) - REMARK='* MRCI ' -c** Gusarov , include 1st root acpf energy to CiOrb file: -c IF(ICPF.EQ.1) REMARK='* ACPF ' - IF(ICPF.EQ.1) - & write(REMARK,'(8H* ACPF ,f22.16)') ESMALL(1)+ESHIFT -c - CALL WRVEC(REALNAME,LUVEC,'CO',NSYM,NBAS,NBAS, - & Work(LCNO), Work(LOCC), Dummy, iDummy,REMARK) - WRITE(6,*) - WRITE(6,'(A,I2)')' NATURAL ORBITALS OF STATE NR. ',ISTATE - WRITE(6,*)' FULL SET OF ORBITALS ARE SAVED ON FILE ',REALNAME - CALL PRORB(Work(LCNO),Work(LOCC)) - WRITE(6,*)' ',('*',I=1,70) -C CREATE DAO - CALL MKDAO(Work(LCNO),Work(LOCC),Work(LDAO)) -C CALL PMATEL TO CALCULATE CHARGES AND PROPERTIES. -C PUT PROPERTIES INTO APPROPRIATE MATRICES. - CALL PMATEL (ISTATE,ISTATE,PROP,Work(LPINT),Work(LSCR), - * Work(LCNO),Work(LOCC), - * Work(LSFOLD),Work(LAFOLD),Work(LDAO)) -100 CONTINUE -C ENERGIES SAVED FROM PREVIOUS OUTPUT REPEATED HERE FOR CONVENIENCE: - WRITE(6,*) - WRITE(6,*)' SUMMARY OF ENERGIES:' - DO 987 ISTA=1,NRROOT,4 - IEND=MIN(ISTA+3,NRROOT) - WRITE(6,'(1X,A,I8,3I16)') - * ' ROOT:',(I,I=ISTA,IEND) - WRITE(6,'(1X,A,4F16.8)') - * ' TOTAL ENERGY:',(ENGY(I,1),I=ISTA,IEND) - IF(ICPF.EQ.0) THEN - WRITE(6,'(1X,A,4F16.8)') - * 'DAVIDSON CORRECTION:',(ENGY(I,2),I=ISTA,IEND) - WRITE(6,'(1X,A,4F16.8)') - * ' ACPF CORRECTION:',(ENGY(I,3),I=ISTA,IEND) - END IF - WRITE(6,*) -987 CONTINUE -* --------------------------------------------------- -*PAM Grep-able energy output for convenience: - WRITE(6,*) - WRITE(6,*)' Energies, machine-readable format:' - IF (ICPF.EQ.0) THEN - DO I=1,NRROOT - WRITE(6,'(1X,A,I3,3(5X,A,F16.8))') - & ' CI State ',I,'Total energy:',ENGY(I,1), - & 'QDav:',ENGY(I,2),'QACPF:',ENGY(I,3) - END DO - ELSE - DO I=1,NRROOT - WRITE(6,'(1X,A,I3,5X,A,F16.8)') - & ' ACPF State ',I,'Total energy:',ENGY(I,1) - END DO - END IF - WRITE(6,*) -* --------------------------------------------------- - IF(NPROP.GT.0) THEN -C WRITE EXPECTATION VALUES: - WRITE(6,*) - WRITE(6,*)' EXPECTATION VALUES OF VARIOUS OPERATORS:' - WRITE(6,*) - * '(Note: Electronic multipoles include a negative sign.)' - DO 110 IPROP=1,NPROP - IF(PTYPE(IPROP).EQ.'ANTI') GOTO 110 - DO 105 ISTA=1,NRROOT,4 - IEND=MIN(ISTA+3,NRROOT) - WRITE(6,*) - WRITE(6,'(1X,A,A8,A,I4)') - * ' PROPERTY :',PNAME(IPROP), - * ' COMPONENT:',IPCOMP(IPROP) - WRITE(6,'(1X,A,3F16.8)') - * ' GAUGE ORIGIN:',(PORIG(I,IPROP),I=1,3) - WRITE(6,'(1X,A,I8,3I16)') - * ' ROOT:',(I,I=ISTA,IEND) - WRITE(6,'(1X,A,4F16.8)') - * ' ELECTRONIC:',(PROP(I,I,IPROP),I=ISTA,IEND) - WRITE(6,'(1X,A,4F16.8)') - * ' NUCLEAR:',(PNUC(IPROP),I=ISTA,IEND) - WRITE(6,'(1X,A,4F16.8)') - * ' TOTAL:',(PNUC(IPROP)+PROP(I,I,IPROP),I=ISTA,IEND) -105 CONTINUE -110 CONTINUE - WRITE(6,*) - END IF - IF(ITRANS.EQ.0) GOTO 1000 - DO 200 ISTATE=2,NRROOT - DO 201 JSTATE=1,ISTATE-1 -C PICK UP TDMA -*PAM04 CALL dDAFILE(LUEIG,2,HWork(LTDMO),NBAST**2,IDDMO) - CALL dDAFILE(LUEIG,2,Work(LTDMO),NBAST**2,IDDMO) -C CREATE TDAO -*PAM04 CALL MKTDAO(HWork(LCMO),HWork(LTDMO),HWork(LTDAO),HWork(LSCR)) - CALL MKTDAO(Work(LCMO),Work(LTDMO),Work(LTDAO),Work(LSCR)) -C CALL PMATEL TO CALCULATE TRANSITION PROPERTIES -C PUT PROPERTIES INTO APPROPRIATE MATRICES. - IF(NPROP.EQ.0) GOTO 201 - CALL PMATEL (ISTATE,JSTATE,PROP,Work(LPINT),Work(LSCR), - * Work(LCNO),Work(LOCC), - * Work(LSFOLD),Work(LAFOLD),Work(LTDAO)) -201 CONTINUE -200 CONTINUE - IF(NPROP.EQ.0) GOTO 1000 -C WRITE PROPERTY MATRICES. - WRITE(6,*) - WRITE(6,*)' MATRIX ELEMENTS OF VARIOUS OPERATORS:' - WRITE(6,*)' (INCLUDING ANY NUCLEAR CONTRIBUTIONS)' - DO 298 IPROP=1,NPROP - DO 299 I=1,NRROOT - PROP(I,I,IPROP)=PROP(I,I,IPROP)+PNUC(IPROP) -299 CONTINUE -298 CONTINUE - DO 300 IPROP=1,NPROP - DO 301 ISTA=1,NRROOT,4 - IEND=MIN(ISTA+3,NRROOT) - WRITE(6,*) - WRITE(6,'(1X,A,A8,A,I4)') - * ' PROPERTY :',PNAME(IPROP), - * ' COMPONENT:',IPCOMP(IPROP) - WRITE(6,'(1X,A,3F16.8)') - * ' GAUGE ORIGIN:',(PORIG(I,IPROP),I=1,3) - WRITE(6,'(1X,A,I8,3I16)') - * ' ROOT:',(I,I=ISTA,IEND) - DO 310 J=1,NRROOT - WRITE(6,'(15X,I2,4F16.8)') - * J,(PROP(J,I,IPROP),I=ISTA,IEND) -310 CONTINUE -301 CONTINUE -300 CONTINUE - WRITE(6,*) -1000 CONTINUE - CALL GETMEM('CMO','FREE','REAL',LCMO,NCMO) - CALL GETMEM('CNO','FREE','REAL',LCNO,NCMO) - CALL GETMEM('OCC','FREE','REAL',LOCC,NBAST) - CALL GETMEM('DAO','FREE','REAL',LDAO,NBAST**2) - CALL GETMEM('AFOLD','FREE','REAL',LAFOLD,NBTRI) - CALL GETMEM('SFOLD','FREE','REAL',LSFOLD,NBTRI) - CALL GETMEM('PINT','FREE','REAL',LPINT,NBTRI+4) - CALL GETMEM('SCR','FREE','REAL',LSCR,NSCR) - CALL MMA_DEALLOCATE(PROP) - RETURN - END diff -Nru openmolcas-22.02/src/mrci/propct.F90 openmolcas-22.10/src/mrci/propct.F90 --- openmolcas-22.02/src/mrci/propct.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/propct.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,181 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine PROPCT() + +use mrci_global, only: DMO, ENGY, ESHIFT, ESMALL, ICPF, IPCOMP, ITOC17, ITRANS, LUEIG, LUONE, LUVEC, NBAS, NBAST, NBMAX, NBTRI, & + NCMO, NRROOT, NPROP, NSYM, PNAME, PNUC, PORIG, PTYPE, TDMO +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp) :: I, IDDMO, IDISK, IDUMMY(7,8), IEND, IOPT, IPC, IPROP, IRTC, ISTA, ISTATE, ISYMLB, J, JSTATE, NSCR +real(kind=wp) :: DUMMY(1) +character(len=100) :: REALNAME +character(len=30) :: REMARK +character(len=8) :: FNAME, LABEL +real(kind=wp), allocatable :: AFOLD(:), CMO(:), CNO(:), DAO(:,:), OCC(:), PINT(:), PROP(:,:,:), SCR(:), SFOLD(:) + +call mma_allocate(CMO,NCMO,label='CMO') +call mma_allocate(CNO,NCMO,label='CNO') +call mma_allocate(OCC,NBAST,label='OCC') +call mma_allocate(DAO,NBAST,NBAST,label='DAO') +call mma_allocate(AFOLD,NBTRI,label='AFOLD') +call mma_allocate(SFOLD,NBTRI,label='SFOLD') +call mma_allocate(PINT,NBTRI+4,label='PINT') +NSCR = max(NBTRI,NBMAX**2) +call mma_allocate(SCR,NSCR,label='SCR') +! LOOP OVER OPERATORS: +IOPT = 8 +NPROP = 0 +do I=1,100 + ! PICK UP OPERATOR LABELS FROM ONE-ELECTRON FILE: + LABEL = 'UNDEF' + call iRDONE(IRTC,1+IOPT,LABEL,IPC,IDUMMY,ISYMLB) + if (IRTC /= 0) exit + IOPT = 16 + if (mod(ISYMLB,2) == 0) cycle + NPROP = NPROP+1 + PNAME(NPROP) = LABEL + IPCOMP(NPROP) = IPC + PTYPE(NPROP) = 'HERM' + if (LABEL == 'VELOCITY') PTYPE(NPROP) = 'ANTI' + if (LABEL == 'ANGMOM ') PTYPE(NPROP) = 'ANTI' +end do +call mma_allocate(PROP,NRROOT,NRROOT,NPROP,'PROP') +PROP(:,:,:) = Zero +IDDMO = 0 +do ISTATE=1,NRROOT + ! PICK UP DMO + call dDAFILE(LUEIG,2,DMO,NBTRI,IDDMO) + ! PICK UP CMO + IDISK = ITOC17(1) + call dDAFILE(LUONE,2,CMO,NCMO,IDISK) + ! COMPUTE & WRITE NATURAL ORBITALS + call NATORB_MRCI(CMO,DMO,CNO,OCC,SCR) + write(FNAME,'(A5,I2.2)') 'CIORB',ISTATE + REALNAME = FNAME + if (ISTATE == 1) call Add_Info('CI_DENS1',DMO,1,5) + REMARK = '* MRCI ' + !** Gusarov , include 1st root acpf energy to CiOrb file: + if (ICPF == 1) write(REMARK,'("* ACPF ",f22.16)') ESMALL(1)+ESHIFT + + call WRVEC(REALNAME,LUVEC,'CO',NSYM,NBAS,NBAS,CNO,OCC,Dummy,iDummy,REMARK) + write(u6,*) + write(u6,'(A,I2)') ' NATURAL ORBITALS OF STATE NR. ',ISTATE + write(u6,*) ' FULL SET OF ORBITALS ARE SAVED ON FILE ',REALNAME + call PRORB(CNO,OCC) + write(u6,*) ' ',('*',I=1,70) + ! CREATE DAO + call MKDAO(CNO,OCC,DAO) + ! CALL PMATEL TO CALCULATE CHARGES AND PROPERTIES. + ! PUT PROPERTIES INTO APPROPRIATE MATRICES. + call PMATEL(ISTATE,ISTATE,PROP,PINT,SCR,CNO,OCC,SFOLD,AFOLD,DAO) +end do +! ENERGIES SAVED FROM PREVIOUS OUTPUT REPEATED HERE FOR CONVENIENCE: +write(u6,*) +write(u6,*) ' SUMMARY OF ENERGIES:' +do ISTA=1,NRROOT,4 + IEND = min(ISTA+3,NRROOT) + write(u6,'(1X,A,I8,3I16)') ' ROOT:',(I,I=ISTA,IEND) + write(u6,'(1X,A,4F16.8)') ' TOTAL ENERGY:',(ENGY(I,1),I=ISTA,IEND) + if (ICPF == 0) then + write(u6,'(1X,A,4F16.8)') 'DAVIDSON CORRECTION:',(ENGY(I,2),I=ISTA,IEND) + write(u6,'(1X,A,4F16.8)') ' ACPF CORRECTION:',(ENGY(I,3),I=ISTA,IEND) + end if + write(u6,*) +end do +! --------------------------------------------------- +!PAM Grep-able energy output for convenience: +write(u6,*) +write(u6,*) ' Energies, machine-readable format:' +if (ICPF == 0) then + do I=1,NRROOT + write(u6,'(1X,A,I3,3(5X,A,F16.8))') ' CI State ',I,'Total energy:',ENGY(I,1),'QDav:',ENGY(I,2),'QACPF:',ENGY(I,3) + end do +else + do I=1,NRROOT + write(u6,'(1X,A,I3,5X,A,F16.8)') ' ACPF State ',I,'Total energy:',ENGY(I,1) + end do +end if +write(u6,*) +! --------------------------------------------------- +if (NPROP > 0) then + ! WRITE EXPECTATION VALUES: + write(u6,*) + write(u6,*) ' EXPECTATION VALUES OF VARIOUS OPERATORS:' + write(u6,*) '(Note: Electronic multipoles include a negative sign.)' + do IPROP=1,NPROP + if (PTYPE(IPROP) == 'ANTI') cycle + do ISTA=1,NRROOT,4 + IEND = min(ISTA+3,NRROOT) + write(u6,*) + write(u6,'(1X,A,A8,A,I4)') ' PROPERTY :',PNAME(IPROP),' COMPONENT:',IPCOMP(IPROP) + write(u6,'(1X,A,3F16.8)') ' GAUGE ORIGIN:',(PORIG(I,IPROP),I=1,3) + write(u6,'(1X,A,I8,3I16)') ' ROOT:',(I,I=ISTA,IEND) + write(u6,'(1X,A,4F16.8)') ' ELECTRONIC:',(PROP(I,I,IPROP),I=ISTA,IEND) + write(u6,'(1X,A,4F16.8)') ' NUCLEAR:',(PNUC(IPROP),I=ISTA,IEND) + write(u6,'(1X,A,4F16.8)') ' TOTAL:',(PNUC(IPROP)+PROP(I,I,IPROP),I=ISTA,IEND) + end do + end do + write(u6,*) +end if +if (ITRANS /= 0) then + do ISTATE=2,NRROOT + do JSTATE=1,ISTATE-1 + ! PICK UP TDMA + call dDAFILE(LUEIG,2,TDMO,NBAST**2,IDDMO) + ! CREATE TDAO + call MKTDAO(CMO,TDMO,DAO,SCR) + ! CALL PMATEL TO CALCULATE TRANSITION PROPERTIES + ! PUT PROPERTIES INTO APPROPRIATE MATRICES. + if (NPROP /= 0) call PMATEL(ISTATE,JSTATE,PROP,PINT,SCR,CNO,OCC,SFOLD,AFOLD,DAO) + end do + end do + if (NPROP /= 0) then + ! WRITE PROPERTY MATRICES. + write(u6,*) + write(u6,*) ' MATRIX ELEMENTS OF VARIOUS OPERATORS:' + write(u6,*) ' (INCLUDING ANY NUCLEAR CONTRIBUTIONS)' + do IPROP=1,NPROP + do I=1,NRROOT + PROP(I,I,IPROP) = PROP(I,I,IPROP)+PNUC(IPROP) + end do + end do + do IPROP=1,NPROP + do ISTA=1,NRROOT,4 + IEND = min(ISTA+3,NRROOT) + write(u6,*) + write(u6,'(1X,A,A8,A,I4)') ' PROPERTY :',PNAME(IPROP),' COMPONENT:',IPCOMP(IPROP) + write(u6,'(1X,A,3F16.8)') ' GAUGE ORIGIN:',(PORIG(I,IPROP),I=1,3) + write(u6,'(1X,A,I8,3I16)') ' ROOT:',(I,I=ISTA,IEND) + do J=1,NRROOT + write(u6,'(15X,I2,4F16.8)') J,(PROP(J,I,IPROP),I=ISTA,IEND) + end do + end do + end do + write(u6,*) + end if +end if +call mma_deallocate(CMO) +call mma_deallocate(CNO) +call mma_deallocate(OCC) +call mma_deallocate(DAO) +call mma_deallocate(AFOLD) +call mma_deallocate(SFOLD) +call mma_deallocate(PINT) +call mma_deallocate(SCR) +call MMA_DEALLOCATE(PROP) + +return + +end subroutine PROPCT diff -Nru openmolcas-22.02/src/mrci/prorb.f openmolcas-22.10/src/mrci/prorb.f --- openmolcas-22.02/src/mrci/prorb.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/prorb.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,66 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE PRORB(CNO,OCC) - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "mrci.fh" - DIMENSION CNO(NCMO),OCC(NBAST) - CHARACTER*(LENIN8) CLEAN_BNAME - EXTERNAL CLEAN_BNAME - WRITE(6,*) - CALL XFLUSH(6) - WRITE(6,*)'NATURAL ORBITALS IN AO BASIS. IN EACH SYMMETRY,' - CALL XFLUSH(6) - WRITE(6,*)'THE ORBITALS PRINTED ARE THOSE UP TO AND INCLUDING' - CALL XFLUSH(6) - WRITE(6,*)'THE LAST ORBITAL WITH OCCUPATION NUMBER LARGER' - CALL XFLUSH(6) - WRITE(6,'(A,F10.7)')' THAN THRORB = ',THRORB - CALL XFLUSH(6) - IEB=0 - IEM=0 - NDIV=10 - DO 100 ISYM=1,NSYM - NB=NBAS(ISYM) - IF(NB.EQ.0) GO TO 100 - NPRT=0 - DO 10 I=1,NB - IF(OCC(IEB+I).GE.THRORB) NPRT=I -10 CONTINUE - IF(NPRT.EQ.0) GO TO 40 - WRITE(6,'(/28X,''SYMMETRY LABEL'',I3)') ISYM - CALL XFLUSH(6) - DO 30 IST=1,NPRT,NDIV - IEND=MIN(NPRT,IST-1+NDIV) - WRITE(6,'(/5X,''ORBITAL'',6X,10I8)') (I,I=IST,IEND) - CALL XFLUSH(6) - WRITE(6,'( 5X,''OCC.NO.'',8X,10F8.5)') - * (OCC(IEB+I),I=IST,IEND) - CALL XFLUSH(6) - WRITE(6,*) - CALL XFLUSH(6) - DO 20 I=1,NB - JSMO=IEM+I+NB*(IST-1) - JEMO=IEM+I+NB*(IEND-1) - WRITE(6,'(1X,I3,2X,A,10F8.4)') - * I,CLEAN_BNAME(NAME(IEB+I),LENIN), - * (CNO(J),J=JSMO,JEMO,NB) - CALL XFLUSH(6) -20 CONTINUE -30 CONTINUE -40 CONTINUE - IEB=IEB+NB - IEM=IEM+NB*NB -100 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/prorb.F90 openmolcas-22.10/src/mrci/prorb.F90 --- openmolcas-22.02/src/mrci/prorb.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/prorb.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,58 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine PRORB(CNO,OCC) + +use mrci_global, only: BNAME, NBAS, NBAST, NCMO, NSYM, THRORB +use Definitions, only: wp, iwp, u6 + +implicit none +real(kind=wp), intent(in) :: CNO(NCMO), OCC(NBAST) +#include "Molcas.fh" +integer(kind=iwp) :: I, IEB, IEM, IEND, IST, ISYM, J, JEMO, JSMO, NB, NDIV, NPRT +character(len=LenIn8), external :: CLEAN_BNAME + +write(u6,*) +write(u6,*) 'NATURAL ORBITALS IN AO BASIS. IN EACH SYMMETRY,' +write(u6,*) 'THE ORBITALS PRINTED ARE THOSE UP TO AND INCLUDING' +write(u6,*) 'THE LAST ORBITAL WITH OCCUPATION NUMBER LARGER' +write(u6,'(A,F10.7)') ' THAN THRORB = ',THRORB +IEB = 0 +IEM = 0 +NDIV = 10 +do ISYM=1,NSYM + NB = NBAS(ISYM) + if (NB == 0) cycle + NPRT = 0 + do I=1,NB + if (OCC(IEB+I) >= THRORB) NPRT = I + end do + if (NPRT /= 0) then + write(u6,'(/28X,''SYMMETRY LABEL'',I3)') ISYM + do IST=1,NPRT,NDIV + IEND = min(NPRT,IST-1+NDIV) + write(u6,'(/5X,''ORBITAL'',6X,10I8)') (I,I=IST,IEND) + write(u6,'( 5X,''OCC.NO.'',8X,10F8.5)') (OCC(IEB+I),I=IST,IEND) + write(u6,*) + do I=1,NB + JSMO = IEM+I+NB*(IST-1) + JEMO = IEM+I+NB*(IEND-1) + write(u6,'(1X,I3,2X,A,10F8.4)') I,CLEAN_BNAME(BNAME(IEB+I),LenIn),(CNO(J),J=JSMO,JEMO,NB) + end do + end do + end if + IEB = IEB+NB + IEM = IEM+NB*NB +end do + +return + +end subroutine PRORB diff -Nru openmolcas-22.02/src/mrci/prwf.f openmolcas-22.10/src/mrci/prwf.f --- openmolcas-22.02/src/mrci/prwf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/prwf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,204 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE PRWF_MRCI(ICSPCK,INTSYM,INDX,C,JREFX) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION C(*),INDX(*),ICSPCK(*), - * INTSYM(*),JREFX(*) - CHARACTER*12 CSFTYP - CHARACTER*14 FORM0,FORM1,FORM2,FORM - CHARACTER*14 FORM00,FORM01,FORM02 - -#include "SysDef.fh" - -#include "mrci.fh" - DIMENSION IOC(32),IORBI(32),ISP(32),ILSYM(32) -CPAM97 EXTERNAL UNPACK -CPAM97 INTEGER UNPACK - DATA FORM00 /'(1X,A,6X,53I2)'/ - DATA FORM01 /'(1X,A,3X,54I2)'/ - DATA FORM02 /'(1X,A,55I2) '/ - DATA FORM0 /'(1X,A,6X,34I3)'/ - DATA FORM1 /'(1X,A,3X,35I3)'/ - DATA FORM2 /'(1X,A,36I3) '/ -C STATEMENT FUNCTIONS FOR RETRIEVING GUGA CASE NUMBERS AND INTERNAL -C SYMMETRY LABEL: -CPAM97 JO(L)=UNPACK(CSPCK((L+29)/30), 2*L-(2*L-1)/60*60, 2) - JO(L)=ICUNP(ICSPCK,L) -CPAM96 JSYM(L)=UNPACK(INTSYM((L+9)/10),3*MOD(L-1,10)+1,3)+1 - JSYM(L)=JSUNP(INTSYM,L) - NA=0 - NB=0 - ILIM=4 - LN2=LN+2 - IF(IFIRST.NE.0)ILIM=2 - SCALE=1.0/SQRT(DDOT_(NCONF,C,1,C,1)) - CALL DSCAL_(NCONF,SCALE,C,1) - DO 4 J=1,LN - IORBI(J+2)=IORB(J) - ILSYM(J+2)=NSM(J) -4 CONTINUE - JCONF=JSC(1) - WRITE(6,'(A,F5.3)')' CI-COEFFICIENTS LARGER THAN ',CTRSH - CALL XFLUSH(6) - DO 5 IS=1,NSYM - IF(NFMO(IS).GT.0) THEN - WRITE(6,*)' NOTE: THE FOLLOWING ORBITALS WERE FROZEN' - CALL XFLUSH(6) - WRITE(6,*)' ALREADY AT THE INTEGRAL TRANSFORMATION STEP' - CALL XFLUSH(6) - WRITE(6,*)' AND DO NOT EXPLICITLY APPEAR:' - CALL XFLUSH(6) - WRITE(6,'(6X,A,8I4)')' SYMMETRY:',(I,I=1,NSYM) - CALL XFLUSH(6) - WRITE(6,'(6X,A,8I4)')'PRE-FROZEN:',(NFMO(I),I=1,NSYM) - CALL XFLUSH(6) - GOTO 6 - END IF -5 CONTINUE -6 CONTINUE - WRITE(6,*)' ORDER OF SPIN-COUPLING: (PRE-FROZEN, NOT SHOWN)' - CALL XFLUSH(6) - WRITE(6,*)' (FROZEN, NOT SHOWN)' - CALL XFLUSH(6) - WRITE(6,*)' VIRTUAL' - CALL XFLUSH(6) - WRITE(6,*)' ADDED VALENCE' - CALL XFLUSH(6) - WRITE(6,*)' INACTIVE' - CALL XFLUSH(6) - WRITE(6,*)' ACTIVE' - CALL XFLUSH(6) - WRITE(6,*) - CALL XFLUSH(6) - WRITE(6,*)' ORBITALS ARE NUMBERED WITHIN EACH SEPARATE SYMMETRY.' - CALL XFLUSH(6) - DO 10 I=1,NCONF - CI=C(I) - ACI=ABS(C(I)) - IF(I.LE.JCONF) THEN - JMIN=1 - NREXT=0 - IF(JREFX(I).NE.0) THEN - CSFTYP=' REFERENCE' - CLIM=0.0D00 - ELSE - CSFTYP=' VALENCE' - CLIM=CTRSH - END IF - ELSE IF (I.LE.JSC(2)) THEN - NREXT=1 - JMIN=1+IRC(1) - CSFTYP=' DOUBLET' - CLIM=CTRSH - ELSE IF (I.LE.JSC(3)) THEN - NREXT=2 - JMIN=1+IRC(2) - CSFTYP=' TRIPLET' - CLIM=CTRSH - ELSE - NREXT=2 - JMIN=1+IRC(3) - CSFTYP=' SINGLET' - CLIM=CTRSH - END IF - IF(ACI.LT.CLIM) GOTO 10 - JJ=I - IJ=I - IF(NREXT.GT.0) THEN - JMAX=IRC(ILIM) - DO 20 J=JMIN,JMAX - JJ=J - IF(INDX(J).LT.IJ)GO TO 20 - JJ=JJ-1 - GOTO 25 -20 CONTINUE -25 CONTINUE - END IF - NSJ=MUL(JSYM(JJ),LSYM) - JVIR=IJ-INDX(JJ) - II1=(JJ-1)*LN - DO 31 II=1,LN - II1=II1+1 - ISP(II+2)=JO(II1) - IOC(II+2)=(1+ISP(II+2))/2 -31 CONTINUE - IF(NREXT.EQ.0) THEN - FORM=FORM0 - IF(LN2.GT.36) FORM=FORM00 - LN1=3 - ELSE IF (NREXT.EQ.1) THEN - IO=JVIR+NVIRP(NSJ)+LN - IORBI(2)=IORB(IO) - IOC(2)=1 - ISP(2)=1 - ILSYM(2)=NSJ - FORM=FORM1 - IF(LN2.GT.36) FORM=FORM01 - LN1=2 - ELSE - IN=0 - DO 46 II=1,NVIRT - NA=II - NSI=MUL(NSJ,NSM(LN+II)) - J1=NVIRP(NSI)+1 - J2=NVIRP(NSI)+NVIR(NSI) - IF(J2.GT.II)J2=II - IF(J2.LT.J1)GO TO 46 - DO 47 J=J1,J2 - NB=J - IN=IN+1 - IF(IN.EQ.JVIR)GO TO 48 -47 CONTINUE -46 CONTINUE -48 CONTINUE - IOC(1)=1 - ISP(1)=1 - ILSYM(1)=NSM(LN+NB) - IO=LN+NB - IORBI(1)=IORB(IO) - IF(NA.EQ.NB) THEN - IORBI(2)=IORBI(1) - IOC(2)=2 - ISP(2)=3 - ILSYM(2)=NSM(IO) - CI=CI*SQRT(0.5D00) - IF(ABS(CI).LT.CTRSH)GO TO 10 - FORM=FORM1 - IF(LN2.GT.36) FORM=FORM01 - LN1=2 - ELSE - IOC(2)=1 - ISP(2)=2 - IF(CSFTYP.EQ.' TRIPLET') ISP(2)=1 - IO=LN+NA - IORBI(2)=IORB(IO) - ILSYM(2)=NSM(IO) - FORM=FORM2 - IF(LN2.GT.36) FORM=FORM02 - LN1=1 - END IF - END IF - WRITE(6,*) - CALL XFLUSH(6) - WRITE(6,105) I,C(I),CSFTYP - CALL XFLUSH(6) -105 FORMAT(/6X,'CONFIGURATION',I7,3X,'COEFFICIENT',F10.6,A) - WRITE(6,FORM) 'SYMMETRY ',(ILSYM(J),J=LN1,LN2) - CALL XFLUSH(6) - WRITE(6,FORM) 'ORBITALS ',(IORBI(J), J=LN1,LN2) - CALL XFLUSH(6) - WRITE(6,FORM) 'OCCUPATION ',(IOC(J), J=LN1,LN2) - CALL XFLUSH(6) - WRITE(6,FORM) 'SPIN-COUPLING',(ISP(J), J=LN1,LN2) - CALL XFLUSH(6) -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/prwf_mrci.F90 openmolcas-22.10/src/mrci/prwf_mrci.F90 --- openmolcas-22.02/src/mrci/prwf_mrci.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/prwf_mrci.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,181 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine PRWF_MRCI(ICSPCK,INTSYM,INDX,C,JREFX) + +use mrci_global, only: CTRSH, IFIRST, IORB, IRC, JSC, LN, LSYM, NCONF, NFMO, NSM, NSYM, NVIR, NVIRP, NVIRT +use Symmetry_Info, only: Mul +use Constants, only: Zero, One, Half +use Definitions, only: wp, iwp, u6, r8 + +implicit none +integer(kind=iwp), intent(in) :: ICSPCK(*), INTSYM(*), INDX(*), JREFX(*) +real(kind=wp), intent(inout) :: C(*) +integer(kind=iwp) :: I, II, II1, IIN, IJ, ILIM, ILSYM(32), IO, IOC(32), IORBI(32), IS, ISP(32), J, J1, J2, JCONF, JJ, JMAX, JMIN, & + JVIR, LN1, LN2, NA, NB, NREXT, NSI, NSJ +real(kind=wp) :: ACI, CI, CLIM, SCL +character(len=14) :: FRMT +character(len=12) :: CSFTYP +character(len=*), parameter :: FORM00 = '(1X,A,6X,53I2)', FORM01 = '(1X,A,3X,54I2)', FORM02 = '(1X,A,55I2)', & + FORM0 = '(1X,A,6X,34I3)', FORM1 = '(1X,A,3X,35I3)', FORM2 = '(1X,A,36I3)' +integer(kind=iwp), external :: ICUNP, JSUNP +real(kind=r8), external :: DDOT_ + +NA = 0 +NB = 0 +ILIM = 4 +LN2 = LN+2 +if (IFIRST /= 0) ILIM = 2 +SCL = One/sqrt(DDOT_(NCONF,C,1,C,1)) +C(1:NCONF) = SCL*C(1:NCONF) +do J=1,LN + IORBI(J+2) = IORB(J) + ILSYM(J+2) = NSM(J) +end do +JCONF = JSC(1) +write(u6,'(A,F5.3)') ' CI-COEFFICIENTS LARGER THAN ',CTRSH +do IS=1,NSYM + if (NFMO(IS) > 0) then + write(u6,*) ' NOTE: THE FOLLOWING ORBITALS WERE FROZEN' + write(u6,*) ' ALREADY AT THE INTEGRAL TRANSFORMATION STEP' + write(u6,*) ' AND DO NOT EXPLICITLY APPEAR:' + write(u6,'(6X,A,8I4)') ' SYMMETRY:',(I,I=1,NSYM) + write(u6,'(6X,A,8I4)') 'PRE-FROZEN:',(NFMO(I),I=1,NSYM) + exit + end if +end do +write(u6,*) ' ORDER OF SPIN-COUPLING: (PRE-FROZEN, NOT SHOWN)' +write(u6,*) ' (FROZEN, NOT SHOWN)' +write(u6,*) ' VIRTUAL' +write(u6,*) ' ADDED VALENCE' +write(u6,*) ' INACTIVE' +write(u6,*) ' ACTIVE' +write(u6,*) +write(u6,*) ' ORBITALS ARE NUMBERED WITHIN EACH SEPARATE SYMMETRY.' +do I=1,NCONF + CI = C(I) + ACI = abs(C(I)) + if (I <= JCONF) then + JMIN = 1 + NREXT = 0 + if (JREFX(I) /= 0) then + CSFTYP = ' REFERENCE' + CLIM = Zero + else + CSFTYP = ' VALENCE' + CLIM = CTRSH + end if + else if (I <= JSC(2)) then + NREXT = 1 + JMIN = 1+IRC(1) + CSFTYP = ' DOUBLET' + CLIM = CTRSH + else if (I <= JSC(3)) then + NREXT = 2 + JMIN = 1+IRC(2) + CSFTYP = ' TRIPLET' + CLIM = CTRSH + else + NREXT = 2 + JMIN = 1+IRC(3) + CSFTYP = ' SINGLET' + CLIM = CTRSH + end if + if (ACI < CLIM) exit + JJ = I + IJ = I + if (NREXT > 0) then + JMAX = IRC(ILIM) + do J=JMIN,JMAX + JJ = J + if (INDX(J) >= IJ) then + JJ = JJ-1 + exit + end if + end do + end if + NSJ = MUL(JSUNP(INTSYM,JJ),LSYM) + JVIR = IJ-INDX(JJ) + II1 = (JJ-1)*LN + do II=1,LN + II1 = II1+1 + ISP(II+2) = ICUNP(ICSPCK,II1) + IOC(II+2) = (1+ISP(II+2))/2 + end do + if (NREXT == 0) then + FRMT = FORM0 + if (LN2 > 36) FRMT = FORM00 + LN1 = 3 + else if (NREXT == 1) then + IO = JVIR+NVIRP(NSJ)+LN + IORBI(2) = IORB(IO) + IOC(2) = 1 + ISP(2) = 1 + ILSYM(2) = NSJ + FRMT = FORM1 + if (LN2 > 36) FRMT = FORM01 + LN1 = 2 + else + IIN = 0 + outer: do II=1,NVIRT + NA = II + NSI = MUL(NSJ,NSM(LN+II)) + J1 = NVIRP(NSI)+1 + J2 = NVIRP(NSI)+NVIR(NSI) + if (J2 > II) J2 = II + if (J2 >= J1) then + do J=J1,J2 + NB = J + IIN = IIN+1 + if (IIN == JVIR) exit outer + end do + end if + end do outer + IOC(1) = 1 + ISP(1) = 1 + ILSYM(1) = NSM(LN+NB) + IO = LN+NB + IORBI(1) = IORB(IO) + if (NA == NB) then + IORBI(2) = IORBI(1) + IOC(2) = 2 + ISP(2) = 3 + ILSYM(2) = NSM(IO) + CI = CI*sqrt(Half) + if (abs(CI) < CTRSH) cycle + FRMT = FORM1 + if (LN2 > 36) FRMT = FORM01 + LN1 = 2 + else + IOC(2) = 1 + ISP(2) = 2 + if (CSFTYP == ' TRIPLET') ISP(2) = 1 + IO = LN+NA + IORBI(2) = IORB(IO) + ILSYM(2) = NSM(IO) + FRMT = FORM2 + if (LN2 > 36) FRMT = FORM02 + LN1 = 1 + end if + end if + write(u6,*) + write(u6,105) I,C(I),CSFTYP + write(u6,FRMT) 'SYMMETRY ',(ILSYM(J),J=LN1,LN2) + write(u6,FRMT) 'ORBITALS ',(IORBI(J),J=LN1,LN2) + write(u6,FRMT) 'OCCUPATION ',(IOC(J),J=LN1,LN2) + write(u6,FRMT) 'SPIN-COUPLING',(ISP(J),J=LN1,LN2) +end do + +return + +105 format(/6X,'CONFIGURATION',I7,3X,'COEFFICIENT',F10.6,A) + +end subroutine PRWF_MRCI diff -Nru openmolcas-22.02/src/mrci/readin_mrci.f openmolcas-22.10/src/mrci/readin_mrci.f --- openmolcas-22.02/src/mrci/readin_mrci.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/readin_mrci.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,715 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -*PAM04 SUBROUTINE READIN(HWork,iHWork) - SUBROUTINE READIN_MRCI() - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "warnings.h" -#include "mrci.fh" -#include "WrkSpc.fh" -#include "niocr.fh" - DIMENSION IOCR(nIOCR),NOTOT(8) -*PAM04 DIMENSION HWork(*), iHWork(*) -* - Parameter ( nCmd=20 ) - Parameter ( mxTit=10 ) - Character*4 Command,Cmd(nCmd) - Character*72 Line,Title(mxTit) - Character*88 ModLine - Data Cmd /'TITL','THRP','PRIN','FROZ','DELE', - * 'MAXI','ECON','REST','ROOT','ACPF', - * 'SDCI','GVAL','PROR','REFC','SELE', - * 'NRRO','MXVE','TRAN','EXTR','END '/ -* -*---- convert a pointer in H to a pointer for iH -* ipointer(i)=(i-1)*RtoI+1 -* -* -* Initialize data and set defaults -* - IOM=MXORB - KBUFF1=2*9600 - ETHRE=1.0D-08 - SQNLIM=1.0D-10 - CTRSH=0.05D00 - THRORB=1.0D-05 - ENP=1.0D00 - NRROOT=1 - NSEL=0 - IPRINT=1 - MAXIT=20 - IREST=0 - ICPF=0 - IREFCI=0 - ITRANS=0 - IGFAC=0 - MXVC=0 - DO 1 I=1,8 - NFRO(I)=0 - NDEL(I)=0 - NBAS(I)=0 - NORB(I)=0 -1 CONTINUE - DO 2 I=1,IOM+1 - IROW(I)=I*(I-1)/2 -2 CONTINUE - DO 4 I=1,12 - IROOT(I)=I -4 CONTINUE - nTit=0 -* -* Read the header of the ONEINT file -* - NAMSIZ=LENIN8*MXORB - IDISK=0 - CALL WR_MOTRA_Info(LUONE,2,iDisk, - & ITOC17,64, POTNUC, - & NSYM, NBAS, NORB,NFMO,NDMO,8,NAME,NAMSIZ) -* -*--- Read input from standard input ----------------------------------* - Call RdNLst(5,'MRCI') -10 Read(5,'(A)',End=991) Line - Command=Line(1:4) - Call UpCase(Command) - If ( Command(1:1).eq.'*' ) Goto 10 - if (Command.eq.' ') Goto 10 - jCmd=0 - Do iCmd=1,nCmd - If ( Command.eq.Cmd(iCmd) ) jCmd=iCmd - End Do -20 Goto ( 100, 200, 300, 400, 500, 600, 700 ,800, 900,1000, - & 1100,1200,1300,1400,1500,1600,1700,1800,1900,2000 ) jCmd - WRITE(6,*)'READIN Error: Command not recognized.' - WRITE(6,*)'The command is:'//''''//Command//'''' - CALL QUIT(_RC_INPUT_ERROR_) -* -*--- process TITL command --------------------------------------------* - 100 Continue - Read(5,'(A)',End=991) Line - Command=Line(1:4) - Call UpCase(Command) - If ( Command(1:1).eq.'*' ) Goto 100 - jCmd=0 - Do iCmd=1,nCmd - If ( Command.eq.Cmd(iCmd) ) jCmd=iCmd - End Do - If ( jCmd.ne.0 ) Goto 20 - nTit=nTit+1 - If ( nTit.le.mxTit ) Title(nTit)=Line - Goto 100 -* -*--- process THRP command --------------------------------------------* - 200 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 200 - Read(Line,*,Err=992) CTRSH - Goto 10 -* -*--- process PRIN command --------------------------------------------* - 300 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 300 - Read(Line,*,Err=992) IPRINT - Goto 10 -* -*--- process FROZ command --------------------------------------------* - 400 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 400 - ModLine=Line//' 0 0 0 0 0 0 0 0' - Read(ModLine,*,Err=992) (NFRO(I),I=1,8) - Goto 10 -* -*--- process DELE command --------------------------------------------* - 500 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 500 - ModLine=Line//' 0 0 0 0 0 0 0 0' - Read(ModLine,*,Err=992) (NDEL(I),I=1,8) - Goto 10 -* -*--- process MAXI command --------------------------------------------* - 600 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 600 - Read(Line,*,Err=992) MAXIT - Goto 10 -* -*--- process ECON command --------------------------------------------* - 700 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 700 - Read(Line,*,Err=992) ETHRE - Goto 10 -* -*--- process REST command --------------------------------------------* - 800 Continue - IREST=1 - Goto 10 -* -*--- process ROOT command --------------------------------------------* - 900 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 900 - Read(Line,*,Err=992) (IROOT(I),I=1,NRROOT) - Goto 10 -* -*--- process ACPF command --------------------------------------------* -1000 Continue - ICPF=1 - Goto 10 -* -*--- process SDCI command --------------------------------------------* -1100 Continue - ICPF=0 - Goto 10 -* -*--- process GVAL command --------------------------------------------* -1200 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 1200 - Read(Line,*,Err=992) GFAC - IGFAC=1 - Goto 10 -* -*--- process PROR command --------------------------------------------* -1300 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 1300 - Read(Line,*,Err=992) THRORB - Goto 10 -* -*--- process REFC command --------------------------------------------* -1400 Continue - IREFCI=1 - Goto 10 -* -*--- process SELE command --------------------------------------------* -1500 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 1500 - Read(Line,*,Err=992) NSEL - JJ=0 - Do 1510 I=1,NSEL - Read(5,*,End=991,Err=992) NC,(CSEL(JJ+J),SSEL(JJ+J),J=1,NC) - JJ=JJ+NC - NCOMP(I)=NC -1510 CONTINUE - Goto 10 -* -*--- process NRRO command --------------------------------------------* -1600 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 1600 - Read(Line,*,Err=992) NRROOT - if(nrroot.gt.mxvec) then - write(6,1610) nrroot,mxvec -1610 format('Too many roots,',i3,', max allowed is',i3) - call quit(_RC_INPUT_ERROR_) - endif - DO I=1,NRROOT - IROOT(I)=I - Enddo - Goto 10 -* -*--- process MXVE command --------------------------------------------* -1700 Continue - Read(5,'(A)',End=991) Line - If ( Line(1:1).eq.'*' ) Goto 1700 - Read(Line,*,Err=992) MXVC - if(mxvc.gt.mxvec) then - write(6,1710) mxvc,mxvec -1710 format('Too many vectors,',i3,', max allowed is',i3) - call quit(_RC_INPUT_ERROR_) - endif - Goto 10 -* -*--- process TRAN command --------------------------------------------* -1800 Continue - ITRANS=1 - Goto 10 -* -*--- process EXTR command --------------------------------------------* -1900 WRITE(6,*) 'The EXTRACT option is redundant and is ignored!' - Goto 10 -* -*--- The end of the input is reached, print the title ----------------* -2000 Continue - if(ntit.eq.0) then - ntit=1 - title(1)=' ( No title was given )' - end if - WRITE(6,*) - CALL XFLUSH(6) - WRITE(6,'(6X,120A1)') ('*',i=1,120) - CALL XFLUSH(6) - WRITE(6,'(6X,120A1)') '*',(' ',i=1,118),'*' - CALL XFLUSH(6) - WRITE(6,'(6X,57A1,A6,57A1)') - & '*',(' ',i=1,56),'Title:',(' ',i=1,56),'*' - CALL XFLUSH(6) - Do i=1,nTit - Call Center_Text(Title(i)) - WRITE(6,'(6X,24A1,A72,24A1)') - & '*',(' ',j=1,23),Title(i),(' ',j=1,23),'*' - CALL XFLUSH(6) - End Do - WRITE(6,'(6X,120A1)') '*',(' ',i=1,118),'*' - CALL XFLUSH(6) - WRITE(6,'(6X,120A1)') ('*',i=1,120) - CALL XFLUSH(6) - WRITE(6,*) -* -*--- print the coordinates of the system -----------------------------* - CALL XFLUSH(6) - Call PrCoor -* -*--- read the header of CIGUGA ---------------------------------------* -* -* Read the header of the CIGUGA file -* - IADD10=0 - CALL iDAFILE(LUSYMB,2,IAD10,9,IADD10) - iOpt=2 - nMUL=64 - nJJS=18 - nIRC=4 - Call WR_GUGA(LUSYMB,iOpt,IADD10, - & NREF,SPIN,NELEC,LN,NSYM,NCSPCK,NINTSY,IFIRST,INTNUM, - & LSYM,NRF,LN1,NRLN1,MUL,nMUL,NASH,NISH,8, - & IRC,nIRC,JJS,nJJS,NVAL,IOCR,nIOCR) - IF(ICPF.EQ.1) THEN - WRITE(6,*)' THIS IS AN A C P F CALCULATION' - ELSE - WRITE(6,*)' THIS IS AN S D C I CALCULATION' - WRITE(6,*)' (But an ACPF correction will be computed)' - END IF - IF(IGFAC.EQ.0) THEN - GFAC=2.0D00/NELEC - WRITE(6,*)' USE THE DEFAULT ACPF G-VALUE GFAC=',GFAC - ELSE - WRITE(6,*)' THE ACPF G-VALUE HAS BEEN SET TO GFAC=',GFAC - END IF - WRITE(6,*) - IF(IREST.NE.0) WRITE(6,*)' RESTARTED CALCULATION.' - WRITE(6,*)' A SMALL CI IS PERFORMED INVOLVING ONLY' - & //' THE REFERENCE STATES.' - WRITE(6,*)' THIS REFERENCE CI WILL USE THE FOLLOWING ROOT' - & //' SELECTION CRITERIA:' - WRITE(6,*) - CALL XFLUSH(6) - WRITE(6,*) - IF(MXVC.EQ.0) MXVC=MAX(NRROOT,10) - IF(NSEL.EQ.0) THEN - WRITE(6,*)' ROOT SELECTION BY ENERGY ORDERING.' - IF(NRROOT.EQ.1) THEN - WRITE(6,'(A,I8)')' ONE SINGLE ROOT, NUMBER ',IROOT(1) - ELSE - WRITE(6,*)' THE FOLLOWING ROOTS WILL BE SELECTED:' - WRITE(6,'(1X,/(1x,12I3))') (IROOT(I),I=1,NRROOT) - END IF - ELSE - WRITE(6,*) - & ' ROOT SELECTION BY PROJECTION: THE EIGENVECTORS OF' - WRITE(6,*) - & ' THE REFERENCE CI ARE ORDERED BY DECREASING SIZE OF' - WRITE(6,*) - & ' THEIR PROJECTIONS ONTO A SELECTION SPACE.' - IF(NRROOT.EQ.1) THEN - WRITE(6,*) - & ' SELECT THE EIGENVECTOR WITH LARGEST PROJECTION.' - ELSE - WRITE(6,'(A,I2,A)')' SELECT THE ',NRROOT, - * ' EIGENVECTORS WITH LARGEST PROJECTION.' - END IF - WRITE(6,*) - & ' THE SELECTION SPACE IS SPANNED BY THE FOLLOWING', - * 'VECTORS (NONZERO COMPONENTS ONLY):' - JJ=0 - DO 1234 I=1,NSEL - WRITE(6,'(6X,A,I2)') ' VECTOR NR. ',I - NC=NCOMP(I) - WRITE(6,'(11X,I2,5X,A20,F12.8)') - * (J,SSEL(JJ+J),CSEL(JJ+J),J=1,NC) - JJ=JJ+NC -1234 CONTINUE - END IF - WRITE(6,*) - IF(IREFCI.EQ.0) THEN - IF(IREST.EQ.0) THEN - WRITE(6,*)' THE REFERENCE CI IS FOLLOWED BY THE FULL SPACE' - WRITE(6,*)' CALCULATION, WHERE THE SELECTION CRITERION' - WRITE(6,*)' IS MAXIMUM OVERLAP WITH THE ROOT(S) SELECTED IN' - WRITE(6,*)' THE REFERENCE CI.' - ELSE - WRITE(6,*)' THE REFERENCE CI IS FOLLOWED BY THE FULL SPACE' - WRITE(6,*)' CALCULATION, WITH ITERATIONS RESTARTED FROM' - WRITE(6,*)' CI VECTOR(S) READ FROM FILE. THE ROOT SELECTION' - WRITE(6,*)' CRITERION IS MAXIMUM OVERLAP WITH THE START' - WRITE(6,*)' VECTORS.' - END IF - ELSE - WRITE(6,*)' ONLY THE REFERENCE CI WAS REQUESTED.' - END IF - IF(LN.GT.IOM) THEN - WRITE(6,*)'READIN Error: Too many orbitals.' - WRITE(6,'(1X,A,2I5)')'actual,allowed:',LN,IOM - CALL QUIT(_RC_INPUT_ERROR_) - END IF - NISHT=0 - LV=0 - DO 811 I=1,NSYM - NISHT=NISHT+NISH(I) - LV=LV+NVAL(I) -811 CONTINUE - IN=0 - IR=0 - IVA=0 - IU=NISHT+LV - IT=LV - IV=LN - NBAST=0 - NORBT=0 - NFMOT=0 - NFROT=0 - NASHT=0 - NVALT=0 - NVIRT=0 - NCSHT=0 - NDELT=0 - NDMOT=0 - DO 7 I=1,NSYM - NORBI=NORB(I) - NBASI=NBAS(I) - NFMOI=NFMO(I) - NFROI=NFRO(I) - NISHI=NISH(I) - NASHI=NASH(I) - NVALI=NVAL(I) - NDELI=NDEL(I) - NDMOI=NDMO(I) - NVIR(I)=NORBI-NFROI-NASHI-NISHI-NVALI-NDELI - NVIRI=NVIR(I) - NCSH(I)=NISHI+NASHI+NVALI+NVIRI - NCSHI=NCSH(I) - NBAST=NBAST+NBASI - NORBT=NORBT+NORBI - NFMOT=NFMOT+NFMOI - NFROT=NFROT+NFROI - NASHT=NASHT+NASHI - NVALT=NVALT+NVALI - NVIRT=NVIRT+NVIRI - NCSHT=NCSHT+NCSHI - NDELT=NDELT+NDELI - NDMOT=NDMOT+NDMOI - DO 8 J=1,NFROI - IN=IN+1 - IR=IR-1 - ICH(IN)=IR -8 CONTINUE - DO 9 J=1,NISHI - IN=IN+1 - IT=IT+1 - ICH(IN)=IT - NSM(IT)=I -9 CONTINUE - DO 11 J=1,NASHI - IN=IN+1 - IU=IU+1 - ICH(IN)=IU - NSM(IU)=I -11 CONTINUE - DO 12 J=1,NVALI - IN=IN+1 - IVA=IVA+1 - ICH(IN)=IVA - NSM(IVA)=I -12 CONTINUE - DO 13 J=1,NVIRI - IN=IN+1 - IV=IV+1 - ICH(IN)=IV - NSM(IV)=I -13 CONTINUE - DO 14 J=1,NDELI - IN=IN+1 - ICH(IN)=0 -14 CONTINUE -7 CONTINUE - IORBS=0 - DO 721 ISYM=1,NSYM - NOTOT(ISYM)=0 -721 CONTINUE - DO 723 ISYM=1,NSYM - IO=NOTOT(ISYM) - DO 722 I=1,NFMO(ISYM)+NFRO(ISYM) - IO=IO+1 -722 CONTINUE - NOTOT(ISYM)=IO -723 CONTINUE - DO 725 ISYM=1,NSYM - IO=NOTOT(ISYM) - DO 724 I=1,NISH(ISYM) - IO=IO+1 - IORBS=IORBS+1 - IORB(IORBS)=IO -724 CONTINUE - NOTOT(ISYM)=IO -725 CONTINUE - DO 727 ISYM=1,NSYM - IO=NOTOT(ISYM) - DO 726 I=1,NASH(ISYM) - IO=IO+1 - IORBS=IORBS+1 - IORB(IORBS)=IO -726 CONTINUE - NOTOT(ISYM)=IO -727 CONTINUE - DO 729 ISYM=1,NSYM - IO=NOTOT(ISYM) - DO 728 I=1,NVAL(ISYM) - IO=IO+1 - IORBS=IORBS+1 - IORB(IORBS)=IO -728 CONTINUE - NOTOT(ISYM)=IO -729 CONTINUE - DO 731 ISYM=1,NSYM - IO=NOTOT(ISYM) - DO 730 I=1,NVIR(ISYM) - IO=IO+1 - IORBS=IORBS+1 - IORB(IORBS)=IO -730 CONTINUE - NOTOT(ISYM)=IO -731 CONTINUE -C NR OF VIRTUALS IN PREVIOUS SYMMETRIES: - ISUM=0 - DO 732 I=1,NSYM - NVIRP(I)=ISUM - ISUM=ISUM+NVIR(I) -732 CONTINUE - NCMO=0 - NBMAX=0 - DO 350 I=1,NSYM - IF(NBAS(I).GT.NBMAX)NBMAX=NBAS(I) - NCMO=NCMO+NBAS(I)**2 -350 CONTINUE - NBTRI=(NBAST*(NBAST+1))/2 - NVT=IROW(NVIRT+1) - NVT2=IROW(NVIRT) - WRITE(6,*) - WRITE(6,'(A)')' MALMQVIST DIAGONALIZATION' - WRITE(6,*) - WRITE(6,'(A,I8)') ' PRINT LEVEL ',IPRINT - WRITE(6,'(A,I12)') ' WORKSPACE WORDS, (Re*8) ' ,MEMTOT - WRITE(6,'(A,I8)') ' MAXIMUM NR OF ORBITALS ',IOM - WRITE(6,'(A,I8)') ' MAX NR OF STORED CI/SGM ARR. ',MXVC - WRITE(6,'(A,I8)') ' MAX NR OF ITERATIONS ',MAXIT - WRITE(6,'(A,D9.2)')' ENERGY CONVERGENCE THRESHOLD ' ,ETHRE - WRITE(6,'(A,F8.1)')' SPIN QUANTUM NUMBER ',SPIN - WRITE(6,'(A,I8)') ' CORRELATED ELECTRONS ',NELEC - WRITE(6,'(A,I8)') ' WAVE FUNCTION SYMMETRY LABEL ',LSYM - WRITE(6,'(A,I8)') ' POINT GROUP ORDER ',NSYM - CALL XFLUSH(6) - WRITE(6,*) - WRITE(6,101)'SYMMETRY LABEL:',(I,I=1,NSYM) - WRITE(6,101)'INACTIVE ORBITALS',(NISH(I),I=1,NSYM),NISHT - WRITE(6,101)'ACTIVE ORBITALS',(NASH(I),I=1,NSYM),NASHT - WRITE(6,101)'ADDED VALENCE ORB',(NVAL(I),I=1,NSYM),NVALT - WRITE(6,101)'VIRTUAL ORBITALS',(NVIR(I),I=1,NSYM),NVIRT - WRITE(6,*) - WRITE(6,101)'SUM:CORREL ORBITALS',(NCSH(I),I=1,NSYM),NCSHT - WRITE(6,*) - WRITE(6,101)'FROZEN ORBITALS',(NFRO(I),I=1,NSYM),NFROT - WRITE(6,101)'DELETED ORBITALS',(NDEL(I),I=1,NSYM),NDELT - WRITE(6,*) - WRITE(6,101)'SUM:ORBITALS IN CI',(NORB(I),I=1,NSYM),NORBT - CALL XFLUSH(6) - WRITE(6,*) - WRITE(6,101)'PRE-FROZEN ORBITALS',(NFMO(I),I=1,NSYM),NFMOT - WRITE(6,101)'PRE-DELETED ORBITALS',(NDMO(I),I=1,NSYM),NDMOT - WRITE(6,101)'SUM: TOTAL BASIS',(NBAS(I),I=1,NSYM),NBAST -101 FORMAT(6X,A,T47,9I5) - WRITE(6,*) - CALL XFLUSH(6) - IF(LN1.EQ.0) THEN - WRITE(6,*)' ONE CLOSED SHELL REFERENCE STATE' - CALL XFLUSH(6) - ELSE - WRITE(6,'(6X,I4,A)') NREF,' REFERENCE STATES' - NREFWR=MIN(NREF,1000/LN1) - LN2=MIN(32,LN1) - WRITE(6,'(6X,A,T47)') 'Occupation of the reference states' - IF(NREFWR.LT.NREF) THEN - WRITE(6,'(6X,A,I3,A)')'( Only the ',NREFWR, - & ' first are listed)' - END IF - Write(6,'(6X,A,T25,32I2)')'Active orbital nr.',(I,I=1,LN2) - jEnd=0 - Do iRef=1,NREFWR - jStart=jEnd+1 - jEnd=jEnd+LN1 - Write(6,'(6X,A,I3,T25,32I2)')'Ref nr',IREF, - & (IOCR(j),j=jStart,jStart-1+LN2) - End Do - CALL XFLUSH(6) - END IF - WRITE(6,*) - CALL XFLUSH(6) - IF(INTNUM.NE.0) WRITE(6,*)' FIRST ORDER INTERACTING SPACE.' - CALL XFLUSH(6) - IX1=IRC(1) - IX2=IRC(2)-IRC(1) - ISC(1)=IX1 - ISC(2)=ISC(1)+IX2*NVIRT - IY1=ISC(1) - IY2=ISC(2)-ISC(1) - IF(IFIRST.EQ.0) THEN - ILIM=4 - IX3=IRC(3)-IRC(2) - IX4=IRC(4)-IRC(3) - ISC(3)=ISC(2)+IX3*NVT2 - ISC(4)=ISC(3)+IX4*NVT - IY3=ISC(3)-ISC(2) - IY4=ISC(4)-ISC(3) - IF(IPRINT.GE.10) THEN - WRITE(6,*) - CALL XFLUSH(6) - WRITE(6,*)' INTERNAL WALKS:' - CALL XFLUSH(6) - WRITE(6,215)IX1,IX2,IX3,IX4 - CALL XFLUSH(6) -215 FORMAT(/,6X,' VALENCE',I7, - * /,6X,' DOUBLET COUPLED SINGLES',I7, - * /,6X,' TRIPLET COUPLED DOUBLES',I7, - * /,6X,' SINGLET COUPLED DOUBLES',I7) - WRITE(6,*) - CALL XFLUSH(6) - WRITE(6,*)' FORMAL CONFIGURATIONS:' - CALL XFLUSH(6) - WRITE(6,215)IY1,IY2,IY3,IY4 - CALL XFLUSH(6) - WRITE(6,'(6X,A,I7)')' TOTAL:',ISC(ILIM) - CALL XFLUSH(6) - END IF - ELSE - ILIM=2 - IF(IPRINT.GE.10) THEN - WRITE(6,*) - CALL XFLUSH(6) - WRITE(6,*)' INTERNAL WALKS:' - CALL XFLUSH(6) - WRITE(6,216)IX1,IX2 - CALL XFLUSH(6) -216 FORMAT(/,6X,' VALENCE',I7, - * /,6X,' DOUBLET COUPLED SINGLES',I7) - WRITE(6,*) - CALL XFLUSH(6) - WRITE(6,*)' FORMAL CONFIGURATIONS:' - CALL XFLUSH(6) - WRITE(6,216)IY1,IY2 - CALL XFLUSH(6) - WRITE(6,'(6X,A,I7)')' TOTAL:',ISC(ILIM) - CALL XFLUSH(6) - END IF - END IF - NIWLK=IRC(ILIM) - NCVAL=IRC(1) -C ---------------------------------------------------------------- - IF (NVIRT.GT.255) THEN - Write(6,*) - Write(6,*)' Sorry -- The MRCI code uses internal integer codes' - Write(6,*)' where the index of virtual orbitals is kept in' - Write(6,*)' 8-bit fields. This cannot easily be increased' - Write(6,*)' and limits the number of virtual orbitals to ' - Write(6,*)' 255. Your input asks for more virtuals than this.' - Write(6,*)' The program cannot run.' - Call Quit(_RC_INPUT_ERROR_) - END IF -C ---------------------------------------------------------------- -C ALLOCATION OF DATA PERMANENTLY IN CORE -* -*PAM04 LCSPCK=1 -* -C ICSPCK - ARRAY OF BIT-PACKED GUGA CASE NUMBERS OF INTERNAL WALKS. -C CONSISTS OF NCSPCK INTEGERS. -* -*PAM04 CALL iDAFILE(LUSYMB,2,iHWork(iPointer(LCSPCK)),NCSPCK,IADD10) - CALL GETMEM('CSPCK','ALLO','INTE',LCSPCK,NCSPCK) - CALL iDAFILE(LUSYMB,2,IWORK(LCSPCK),NCSPCK,IADD10) -* -C INTSYM - ARRAY OF BIT-PACKED SYMMETRY LABELS OF INTERNAL WALKS. -C CONSISTS OF NINTSY INTEGERS. -* -*PAM04 LINTSY=LCSPCK+(NCSPCK+(RTOI-1))/RTOI -*PAM04 Changed to following line: - CALL GETMEM('INTSY','ALLO','INTE',LINTSY,NINTSY) -*PAM04 CALL iDAFILE(LUSYMB,2,iHWork(iPointer(LINTSY)),NINTSY,IADD10) - CALL iDAFILE(LUSYMB,2,IWork(LINTSY),NINTSY,IADD10) -* -C INDX - START POSITION IN CI ARRAY OF EACH INTERNAL-WALK-BLOCK -* -*PAM04 LINDX=LINTSY+(NINTSY+(RTOI-1))/RTOI -*PAM04 Changed to following line: - CALL GETMEM('INDX','ALLO','INTE',LINDX,NIWLK) -* -C ISAB - ORDERING NR OF EACH VIRTUAL PAIR WITHIN ITS COMB-SYMM -* -*PAM04 LISAB=LINDX+NIWLK -*PAM04 Changed to following line: - CALL GETMEM('ISAB','ALLO','INTE',LISAB,NVIRT**2) -* -C JREFX - FOR EACH VALENCE CSF, EITHER 0 OR ITS REFERENCE NR. -* -*PAM04 LJREFX=LISAB+(1+NVIRT**2)/RTOI -*PAM04 Changed to following line: - CALL GETMEM('JREFX','ALLO','INTE',LJREFX,NCVAL) - IADD10=IAD10(2) - CALL iDAFILE(LUSYMB,2,iWork(LJREFX),NCVAL,IADD10) -* -C PROJECTION SELECTION VECTORS -* -*PAM04 LCISEL=LJREFX+(1+NCVAL)/RTOI -*PAM04 Changed to following line: - CALL GETMEM('CISEL','ALLO','REAL',LCISEL,NSEL*NREF) -* -C START OF NON-PERMANENT AREA: -* -*PAM04 LPERMA=LCISEL+NSEL*NREF -*PAM04 CALL INDMAT(HWork(LCSPCK),HWork(LINTSY),HWork(LINDX), -*PAM04 * HWork(LISAB),HWork(LJREFX),HWork(LCISEL)) - CALL INDMAT(IWork(LCSPCK),IWork(LINTSY),IWork(LINDX), - * IWork(LISAB),IWork(LJREFX),Work(LCISEL)) - IF(NREF.GT.MXREF) THEN - WRITE(6,*)'READIN Error: Too many references.' - WRITE(6,'(1X,A,2I6)')' actual, allowed:',NREF,MXREF - CALL QUIT(_RC_INPUT_ERROR_) - END IF - -* Total available memory (at start of program) is MEMTOT -* Available now is MEMWRK -* Already (permanently) allocated is MEMPRM - - CALL GETMEM('HowMuch','MAX','REAL',LDUM,MemWrk) - MEMPRM=MEMTOT-MEMWRK - - CALL ALLOC_MRCI - RETURN -991 Continue - WRITE(6,*)'READIN Error: Premature end of file while reading.' - Call Quit(_RC_IO_ERROR_READ_) -992 Continue - WRITE(6,*)'READIN Error: I/O error during internal read.' - WRITE(6,*)'The line that could not be read is:' - WRITE(6,*) Line - Call Quit(_RC_IO_ERROR_READ_) - END diff -Nru openmolcas-22.02/src/mrci/readin_mrci.F90 openmolcas-22.10/src/mrci/readin_mrci.F90 --- openmolcas-22.02/src/mrci/readin_mrci.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/readin_mrci.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,711 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine READIN_MRCI() + +use mrci_global, only: BNAME, CISEL, CSEL, CSPCK, CTRSH, ENP, ETHRE, GFAC, ICH, ICPF, IFIRST, INDX, INTSY, IORB, IPRINT, IRC, & + IREFCI, IREST, IROW, IROOT, ISAB, ITOC17, ITRANS, JJS, JREFX, KBUFF1, LN, LSYM, LUONE, LUSYMB, MAXIT, & + MEMPRM, MEMTOT, MEMWRK, MXREF, MXVEC, NASH, NBAS, NBAST, NBMAX, NBTRI, NCMO, NCSHT, NCSPCK, NCOMP, NCVAL, & + NDEL, NDMO, NELEC, NFMO, NFRO, NISH, NORB, NORBT, NREF, NRROOT, NSEL, NSM, NSYM, NVIR, NVIRP, NVIRT, & + POTNUC, SSEL, SQNLIM, THRORB +use guga_util_global, only: IAD10, nIOCR +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: One, Two +use Definitions, only: wp, iwp, u5, u6 + +implicit none +#include "Molcas.fh" +#include "warnings.h" +integer(kind=iwp) :: I, IADD10, iCmd, IDISK, IGFAC, IIN, ILIM, INTNUM, IO, IOM, iOpt, IORBS, IR, iRef, ISC(4), istatus, ISUM, & + ISYM, IT, IU, IV, IVA, IX1, IX2, IX3, IX4, IY1, IY2, IY3, IY4, J, jCmd, jEnd, JJ, jStart, LN1, LN2, LV, MXVC, & + NAMSIZ, NASHI, NASHT, NBASI, NC, NCSH(8), NCSHI, NDELI, NDELT, NDMOI, NDMOT, NFMOI, NFMOT, NFROI, NFROT, & + NINTSY, nIRC, NISHI, NISHT, NIWLK, nJJS, NORBI, NOTOT(8), NREFWR, NRF, NRLN1, nTit, NVAL(8), NVALI, NVALT, & + NVIRI, NVT, NVT2 +real(kind=wp) :: SPIN +logical(kind=iwp) :: Skip +character(len=88) :: ModLine +character(len=72) :: Line, Title(10) +character(len=4) :: Command +integer(kind=iwp), allocatable :: IOCR(:) +character(len=4), parameter :: Cmd(19) = ['TITL','THRP','PRIN','FROZ','DELE','MAXI','ECON','REST','ROOT','ACPF','SDCI','GVAL', & + 'PROR','REFC','SELE','NRRO','MXVE','TRAN','END '] + +! Initialize data and set defaults + +IOM = MXORB +KBUFF1 = 2*9600 +ETHRE = 1.0e-8_wp +SQNLIM = 1.0e-10_wp +CTRSH = 0.05_wp +THRORB = 1.0e-5_wp +ENP = One +NRROOT = 1 +NSEL = 0 +IPRINT = 1 +MAXIT = 20 +IREST = 0 +ICPF = 0 +IREFCI = 0 +ITRANS = 0 +IGFAC = 0 +MXVC = 0 +do I=1,8 + NFRO(I) = 0 + NDEL(I) = 0 + NBAS(I) = 0 + NORB(I) = 0 +end do +do I=1,IOM+1 + IROW(I) = I*(I-1)/2 +end do +do I=1,12 + IROOT(I) = I +end do +nTit = 0 + +! Read the header of the ONEINT file + +NAMSIZ = LENIN8*MXORB +IDISK = 0 +call WR_MOTRA_Info(LUONE,2,iDisk,ITOC17,64,POTNUC,NSYM,NBAS,NORB,NFMO,NDMO,8,BNAME,NAMSIZ) + +!--- Read input from standard input ----------------------------------* +call RdNLst(u5,'MRCI') +Skip = .false. +jCmd = 0 +do + if (Skip) then + Skip = .false. + else + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + Command = Line(1:4) + call UpCase(Command) + if (Command(1:1) == '*') cycle + if (Command == ' ') cycle + jCmd = 0 + do iCmd=1,size(Cmd) + if (Command == Cmd(iCmd)) jCmd = iCmd + end do + end if + select case (jCmd) + + case default + write(u6,*) 'READIN Error: Command not recognized.' + write(u6,*) 'The command is:'//''''//Command//'''' + call QUIT(_RC_INPUT_ERROR_) + + case (1) !TITL + !--- process TITL command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + Command = Line(1:4) + call UpCase(Command) + if (Command(1:1) == '*') cycle + jCmd = 0 + do iCmd=1,size(Cmd) + if (Command == Cmd(iCmd)) jCmd = iCmd + end do + if (jCmd /= 0) exit + nTit = nTit+1 + if (nTit <= size(Title)) Title(nTit) = Line + end do + Skip = .true. + + case (2) !THRP + !--- process THRP command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if (Line(1:1) /= '*') exit + end do + read(Line,*,iostat=istatus) CTRSH + if (istatus > 0) call Error(2) + + case (3) !PRIN + !--- process PRIN command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if (Line(1:1) /= '*') exit + end do + read(Line,*,iostat=istatus) IPRINT + if (istatus > 0) call Error(2) + + case (4) !FROZ + !--- process FROZ command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if (Line(1:1) /= '*') exit + end do + ModLine = Line//' 0 0 0 0 0 0 0 0' + read(ModLine,*,iostat=istatus) (NFRO(I),I=1,8) + if (istatus > 0) call Error(2) + + case (5) !DELE + !--- process DELE command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if (Line(1:1) /= '*') exit + end do + ModLine = Line//' 0 0 0 0 0 0 0 0' + read(ModLine,*,iostat=istatus) (NDEL(I),I=1,8) + if (istatus > 0) call Error(2) + + case (6) !MAXI + !--- process MAXI command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if (Line(1:1) /= '*') exit + end do + read(Line,*,iostat=istatus) MAXIT + if (istatus > 0) call Error(2) + + case (7) !ECON + !--- process ECON command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if (Line(1:1) /= '*') exit + end do + read(Line,*,iostat=istatus) ETHRE + if (istatus > 0) call Error(2) + + case (8) !REST + !--- process REST command --------------------------------------* + IREST = 1 + + case (9) !ROOT + !--- process ROOT command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if (Line(1:1) /= '*') exit + end do + read(Line,*,iostat=istatus) (IROOT(I),I=1,NRROOT) + if (istatus > 0) call Error(2) + + case (10) !ACPF + !--- process ACPF command --------------------------------------* + ICPF = 1 + + case (11) !SDCI + !--- process SDCI command --------------------------------------* + ICPF = 0 + + case (12) !GVAL + !--- process GVAL command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if (Line(1:1) /= '*') exit + end do + read(Line,*,iostat=istatus) GFAC + if (istatus > 0) call Error(2) + IGFAC = 1 + + case (13) !PROR + !--- process PROR command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if (Line(1:1) /= '*') exit + end do + read(Line,*,iostat=istatus) THRORB + if (istatus > 0) call Error(2) + + case (14) !REFC + !--- process REFC command --------------------------------------* + IREFCI = 1 + + case (15) !SELE + !--- process SELE command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if (Line(1:1) /= '*') exit + end do + read(Line,*,iostat=istatus) NSEL + if (istatus > 0) call Error(2) + JJ = 0 + do I=1,NSEL + read(u5,*,iostat=istatus) NC,(CSEL(JJ+J),SSEL(JJ+J),J=1,NC) + if (istatus < 0) call Error(1) + if (istatus > 0) call Error(2) + JJ = JJ+NC + NCOMP(I) = NC + end do + + case (16) !NRRO + !--- process NRRO command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if (Line(1:1) /= '*') exit + end do + read(Line,*,iostat=istatus) NRROOT + if (istatus > 0) call Error(2) + if (NRROOT > MXVEC) then + write(u6,1610) NRROOT,MXVEC + call quit(_RC_INPUT_ERROR_) + end if + do I=1,NRROOT + IROOT(I) = I + end do + + case (17) !MXVE + !--- process MXVE command --------------------------------------* + do + read(u5,'(A)',iostat=istatus) Line + if (istatus < 0) call Error(1) + if (Line(1:1) /= '*') exit + end do + read(Line,*,iostat=istatus) MXVC + if (istatus > 0) call Error(2) + if (mxvc > mxvec) then + write(u6,1710) mxvc,mxvec + call quit(_RC_INPUT_ERROR_) + end if + + case (18) !TRAN + !--- process TRAN command --------------------------------------* + ITRANS = 1 + + case (19) !END + exit + + end select +end do +!--- The end of the input is reached, print the title ----------------* +if (ntit == 0) then + ntit = 1 + title(1) = ' ( No title was given )' +end if +write(u6,*) +write(u6,'(6X,120A1)') ('*',i=1,120) +write(u6,'(6X,120A1)') '*',(' ',i=1,118),'*' +write(u6,'(6X,57A1,A6,57A1)') '*',(' ',i=1,56),'Title:',(' ',i=1,56),'*' +do i=1,nTit + call Center_Text(Title(i)) + write(u6,'(6X,24A1,A72,24A1)') '*',(' ',j=1,23),Title(i),(' ',j=1,23),'*' +end do +write(u6,'(6X,120A1)') '*',(' ',i=1,118),'*' +write(u6,'(6X,120A1)') ('*',i=1,120) +write(u6,*) + +!--- print the coordinates of the system -----------------------------* +call PrCoor() + +!--- read the header of CIGUGA ---------------------------------------* + +! Read the header of the CIGUGA file + +IADD10 = 0 +call iDAFILE(LUSYMB,2,IAD10,9,IADD10) +iOpt = 2 +nJJS = 18 +nIRC = 4 +call mma_allocate(IOCR,nIOCR,label='IOCR') +call WR_GUGA(LUSYMB,iOpt,IADD10,NREF,SPIN,NELEC,LN,NSYM,NCSPCK,NINTSY,IFIRST,INTNUM,LSYM,NRF,LN1,NRLN1,NASH,NISH,8,IRC,nIRC,JJS, & + nJJS,NVAL,IOCR,nIOCR) +if (ICPF == 1) then + write(u6,*) ' THIS IS AN A C P F CALCULATION' +else + write(u6,*) ' THIS IS AN S D C I CALCULATION' + write(u6,*) ' (But an ACPF correction will be computed)' +end if +if (IGFAC == 0) then + GFAC = Two/NELEC + write(u6,*) ' USE THE DEFAULT ACPF G-VALUE GFAC=',GFAC +else + write(u6,*) ' THE ACPF G-VALUE HAS BEEN SET TO GFAC=',GFAC +end if +write(u6,*) +if (IREST /= 0) write(u6,*) ' RESTARTED CALCULATION.' +write(u6,*) ' A SMALL CI IS PERFORMED INVOLVING ONLY THE REFERENCE STATES.' +write(u6,*) ' THIS REFERENCE CI WILL USE THE FOLLOWING ROOT SELECTION CRITERIA:' +write(u6,*) +write(u6,*) +if (MXVC == 0) MXVC = max(NRROOT,10) +if (NSEL == 0) then + write(u6,*) ' ROOT SELECTION BY ENERGY ORDERING.' + if (NRROOT == 1) then + write(u6,'(A,I8)') ' ONE SINGLE ROOT, NUMBER ',IROOT(1) + else + write(u6,*) ' THE FOLLOWING ROOTS WILL BE SELECTED:' + write(u6,'(1X,/(1x,12I3))') (IROOT(I),I=1,NRROOT) + end if +else + write(u6,*) ' ROOT SELECTION BY PROJECTION: THE EIGENVECTORS OF' + write(u6,*) ' THE REFERENCE CI ARE ORDERED BY DECREASING SIZE OF' + write(u6,*) ' THEIR PROJECTIONS ONTO A SELECTION SPACE.' + if (NRROOT == 1) then + write(u6,*) ' SELECT THE EIGENVECTOR WITH LARGEST PROJECTION.' + else + write(u6,'(A,I2,A)') ' SELECT THE ',NRROOT,' EIGENVECTORS WITH LARGEST PROJECTION.' + end if + write(u6,*) ' THE SELECTION SPACE IS SPANNED BY THE FOLLOWING VECTORS (NONZERO COMPONENTS ONLY):' + JJ = 0 + do I=1,NSEL + write(u6,'(6X,A,I2)') ' VECTOR NR. ',I + NC = NCOMP(I) + write(u6,'(11X,I2,5X,A20,F12.8)') (J,SSEL(JJ+J),CSEL(JJ+J),J=1,NC) + JJ = JJ+NC + end do +end if +write(u6,*) +if (IREFCI == 0) then + if (IREST == 0) then + write(u6,*) ' THE REFERENCE CI IS FOLLOWED BY THE FULL SPACE' + write(u6,*) ' CALCULATION, WHERE THE SELECTION CRITERION' + write(u6,*) ' IS MAXIMUM OVERLAP WITH THE ROOT(S) SELECTED IN' + write(u6,*) ' THE REFERENCE CI.' + else + write(u6,*) ' THE REFERENCE CI IS FOLLOWED BY THE FULL SPACE' + write(u6,*) ' CALCULATION, WITH ITERATIONS RESTARTED FROM' + write(u6,*) ' CI VECTOR(S) READ FROM FILE. THE ROOT SELECTION' + write(u6,*) ' CRITERION IS MAXIMUM OVERLAP WITH THE START' + write(u6,*) ' VECTORS.' + end if +else + write(u6,*) ' ONLY THE REFERENCE CI WAS REQUESTED.' +end if +if (LN > IOM) then + write(u6,*) 'READIN Error: Too many orbitals.' + write(u6,'(1X,A,2I5)') 'actual,allowed:',LN,IOM + call QUIT(_RC_INPUT_ERROR_) +end if +NISHT = 0 +LV = 0 +do I=1,NSYM + NISHT = NISHT+NISH(I) + LV = LV+NVAL(I) +end do +IIN = 0 +IR = 0 +IVA = 0 +IU = NISHT+LV +IT = LV +IV = LN +NBAST = 0 +NORBT = 0 +NFMOT = 0 +NFROT = 0 +NASHT = 0 +NVALT = 0 +NVIRT = 0 +NCSHT = 0 +NDELT = 0 +NDMOT = 0 +do I=1,NSYM + NORBI = NORB(I) + NBASI = NBAS(I) + NFMOI = NFMO(I) + NFROI = NFRO(I) + NISHI = NISH(I) + NASHI = NASH(I) + NVALI = NVAL(I) + NDELI = NDEL(I) + NDMOI = NDMO(I) + NVIR(I) = NORBI-NFROI-NASHI-NISHI-NVALI-NDELI + NVIRI = NVIR(I) + NCSH(I) = NISHI+NASHI+NVALI+NVIRI + NCSHI = NCSH(I) + NBAST = NBAST+NBASI + NORBT = NORBT+NORBI + NFMOT = NFMOT+NFMOI + NFROT = NFROT+NFROI + NASHT = NASHT+NASHI + NVALT = NVALT+NVALI + NVIRT = NVIRT+NVIRI + NCSHT = NCSHT+NCSHI + NDELT = NDELT+NDELI + NDMOT = NDMOT+NDMOI + do J=1,NFROI + IIN = IIN+1 + IR = IR-1 + ICH(IIN) = IR + end do + do J=1,NISHI + IIN = IIN+1 + IT = IT+1 + ICH(IIN) = IT + NSM(IT) = I + end do + do J=1,NASHI + IIN = IIN+1 + IU = IU+1 + ICH(IIN) = IU + NSM(IU) = I + end do + do J=1,NVALI + IIN = IIN+1 + IVA = IVA+1 + ICH(IIN) = IVA + NSM(IVA) = I + end do + do J=1,NVIRI + IIN = IIN+1 + IV = IV+1 + ICH(IIN) = IV + NSM(IV) = I + end do + do J=1,NDELI + IIN = IIN+1 + ICH(IIN) = 0 + end do +end do +IORBS = 0 +do ISYM=1,NSYM + NOTOT(ISYM) = 0 +end do +do ISYM=1,NSYM + IO = NOTOT(ISYM) + do I=1,NFMO(ISYM)+NFRO(ISYM) + IO = IO+1 + end do + NOTOT(ISYM) = IO +end do +do ISYM=1,NSYM + IO = NOTOT(ISYM) + do I=1,NISH(ISYM) + IO = IO+1 + IORBS = IORBS+1 + IORB(IORBS) = IO + end do + NOTOT(ISYM) = IO +end do +do ISYM=1,NSYM + IO = NOTOT(ISYM) + do I=1,NASH(ISYM) + IO = IO+1 + IORBS = IORBS+1 + IORB(IORBS) = IO + end do + NOTOT(ISYM) = IO +end do +do ISYM=1,NSYM + IO = NOTOT(ISYM) + do I=1,NVAL(ISYM) + IO = IO+1 + IORBS = IORBS+1 + IORB(IORBS) = IO + end do + NOTOT(ISYM) = IO +end do +do ISYM=1,NSYM + IO = NOTOT(ISYM) + do I=1,NVIR(ISYM) + IO = IO+1 + IORBS = IORBS+1 + IORB(IORBS) = IO + end do + NOTOT(ISYM) = IO +end do +! NR OF VIRTUALS IN PREVIOUS SYMMETRIES: +ISUM = 0 +do I=1,NSYM + NVIRP(I) = ISUM + ISUM = ISUM+NVIR(I) +end do +NCMO = 0 +NBMAX = 0 +do I=1,NSYM + if (NBAS(I) > NBMAX) NBMAX = NBAS(I) + NCMO = NCMO+NBAS(I)**2 +end do +NBTRI = (NBAST*(NBAST+1))/2 +NVT = IROW(NVIRT+1) +NVT2 = IROW(NVIRT) +write(u6,*) +write(u6,'(A)') ' MALMQVIST DIAGONALIZATION' +write(u6,*) +write(u6,'(A,I8)') ' PRINT LEVEL ',IPRINT +write(u6,'(A,I12)') ' WORKSPACE WORDS, (Re(wp)) ',MEMTOT +write(u6,'(A,I8)') ' MAXIMUM NR OF ORBITALS ',IOM +write(u6,'(A,I8)') ' MAX NR OF STORED CI/SGM ARR. ',MXVC +write(u6,'(A,I8)') ' MAX NR OF ITERATIONS ',MAXIT +write(u6,'(A,D9.2)') ' ENERGY CONVERGENCE THRESHOLD ',ETHRE +write(u6,'(A,F8.1)') ' SPIN QUANTUM NUMBER ',SPIN +write(u6,'(A,I8)') ' CORRELATED ELECTRONS ',NELEC +write(u6,'(A,I8)') ' WAVE FUNCTION SYMMETRY LABEL ',LSYM +write(u6,'(A,I8)') ' POINT GROUP ORDER ',NSYM +write(u6,*) +write(u6,101) 'SYMMETRY LABEL:',(I,I=1,NSYM) +write(u6,101) 'INACTIVE ORBITALS',(NISH(I),I=1,NSYM),NISHT +write(u6,101) 'ACTIVE ORBITALS',(NASH(I),I=1,NSYM),NASHT +write(u6,101) 'ADDED VALENCE ORB',(NVAL(I),I=1,NSYM),NVALT +write(u6,101) 'VIRTUAL ORBITALS',(NVIR(I),I=1,NSYM),NVIRT +write(u6,*) +write(u6,101) 'SUM:CORREL ORBITALS',(NCSH(I),I=1,NSYM),NCSHT +write(u6,*) +write(u6,101) 'FROZEN ORBITALS',(NFRO(I),I=1,NSYM),NFROT +write(u6,101) 'DELETED ORBITALS',(NDEL(I),I=1,NSYM),NDELT +write(u6,*) +write(u6,101) 'SUM:ORBITALS IN CI',(NORB(I),I=1,NSYM),NORBT +write(u6,*) +write(u6,101) 'PRE-FROZEN ORBITALS',(NFMO(I),I=1,NSYM),NFMOT +write(u6,101) 'PRE-DELETED ORBITALS',(NDMO(I),I=1,NSYM),NDMOT +write(u6,101) 'SUM: TOTAL BASIS',(NBAS(I),I=1,NSYM),NBAST +write(u6,*) +if (LN1 == 0) then + write(u6,*) ' ONE CLOSED SHELL REFERENCE STATE' +else + write(u6,'(6X,I4,A)') NREF,' REFERENCE STATES' + NREFWR = min(NREF,1000/LN1) + LN2 = min(32,LN1) + write(u6,'(6X,A,T47)') 'Occupation of the reference states' + if (NREFWR < NREF) then + write(u6,'(6X,A,I3,A)') '( Only the ',NREFWR,' first are listed)' + end if + write(u6,'(6X,A,T25,32I2)') 'Active orbital nr.',(I,I=1,LN2) + jEnd = 0 + do iRef=1,NREFWR + jStart = jEnd+1 + jEnd = jEnd+LN1 + write(u6,'(6X,A,I3,T25,32I2)') 'Ref nr',IREF,(IOCR(j),j=jStart,jStart-1+LN2) + end do +end if +call mma_deallocate(IOCR) +write(u6,*) +if (INTNUM /= 0) write(u6,*) ' FIRST ORDER INTERACTING SPACE.' +IX1 = IRC(1) +IX2 = IRC(2)-IRC(1) +ISC(1) = IX1 +ISC(2) = ISC(1)+IX2*NVIRT +IY1 = ISC(1) +IY2 = ISC(2)-ISC(1) +if (IFIRST == 0) then + ILIM = 4 + IX3 = IRC(3)-IRC(2) + IX4 = IRC(4)-IRC(3) + ISC(3) = ISC(2)+IX3*NVT2 + ISC(4) = ISC(3)+IX4*NVT + IY3 = ISC(3)-ISC(2) + IY4 = ISC(4)-ISC(3) + if (IPRINT >= 10) then + write(u6,*) + write(u6,*) ' INTERNAL WALKS:' + write(u6,215) IX1,IX2,IX3,IX4 + write(u6,*) + write(u6,*) ' FORMAL CONFIGURATIONS:' + write(u6,215) IY1,IY2,IY3,IY4 + write(u6,'(6X,A,I7)') ' TOTAL:',ISC(ILIM) + end if +else + ILIM = 2 + if (IPRINT >= 10) then + write(u6,*) + write(u6,*) ' INTERNAL WALKS:' + write(u6,216) IX1,IX2 + write(u6,*) + write(u6,*) ' FORMAL CONFIGURATIONS:' + write(u6,216) IY1,IY2 + write(u6,'(6X,A,I7)') ' TOTAL:',ISC(ILIM) + end if +end if +NIWLK = IRC(ILIM) +NCVAL = IRC(1) +! ---------------------------------------------------------------------- +if (NVIRT > 255) then + write(u6,*) + write(u6,*) ' Sorry -- The MRCI code uses internal integer codes' + write(u6,*) ' where the index of virtual orbitals is kept in' + write(u6,*) ' 8-bit fields. This cannot easily be increased' + write(u6,*) ' and limits the number of virtual orbitals to ' + write(u6,*) ' 255. Your input asks for more virtuals than this.' + write(u6,*) ' The program cannot run.' + call Quit(_RC_INPUT_ERROR_) +end if +! ---------------------------------------------------------------------- +! ALLOCATION OF DATA PERMANENTLY IN CORE +! + +! CSPCK - ARRAY OF BIT-PACKED GUGA CASE NUMBERS OF INTERNAL WALKS. +! CONSISTS OF NCSPCK INTEGERS. + +call mma_allocate(CSPCK,NCSPCK,label='CSPCK') +call iDAFILE(LUSYMB,2,CSPCK,NCSPCK,IADD10) + +! INTSY - ARRAY OF BIT-PACKED SYMMETRY LABELS OF INTERNAL WALKS. +! CONSISTS OF NINTSY INTEGERS. + +call mma_allocate(INTSY,NINTSY,label='INTSY') +call iDAFILE(LUSYMB,2,INTSY,NINTSY,IADD10) + +! INDX - START POSITION IN CI ARRAY OF EACH INTERNAL-WALK-BLOCK + +call mma_allocate(INDX,NIWLK,label='INDX') + +! ISAB - ORDERING NR OF EACH VIRTUAL PAIR WITHIN ITS COMB-SYMM + +call mma_allocate(ISAB,NVIRT,NVIRT,label='ISAB') + +! JREFX - FOR EACH VALENCE CSF, EITHER 0 OR ITS REFERENCE NR. + +call mma_allocate(JREFX,NCVAL,label='JREFX') +IADD10 = IAD10(2) +call iDAFILE(LUSYMB,2,JREFX,NCVAL,IADD10) + +! PROJECTION SELECTION VECTORS + +call mma_allocate(CISEL,NREF,NSEL,label='CISEL') + +! START OF NON-PERMANENT AREA: + +call INDMAT(CSPCK,INTSY,INDX,ISAB,JREFX,CISEL) +if (NREF > MXREF) then + write(u6,*) 'READIN Error: Too many references.' + write(u6,'(1X,A,2I6)') ' actual, allowed:',NREF,MXREF + call QUIT(_RC_INPUT_ERROR_) +end if + +! Total available memory (at start of program) is MEMTOT +! Available now is MEMWRK +! Already (permanently) allocated is MEMPRM + +call mma_maxdble(MemWrk) +MEMPRM = MEMTOT-MEMWRK + +call ALLOC_MRCI() + +return + +101 format(6X,A,T47,9I5) +215 format(/,6X,' VALENCE',I7,/,6X,' DOUBLET COUPLED SINGLES',I7,/,6X,' TRIPLET COUPLED DOUBLES',I7, & + /,6X,' SINGLET COUPLED DOUBLES',I7) +216 format(/,6X,' VALENCE',I7,/,6X,' DOUBLET COUPLED SINGLES',I7) +1610 format('Too many roots,',i3,', max allowed is',i3) +1710 format('Too many vectors,',i3,', max allowed is',i3) + +contains + +subroutine Error(code) + + integer(kind=iwp), intent(in) :: code + + select case (code) + case (1) + write(u6,*) 'READIN Error: Premature end of file while reading.' + case (2) + write(u6,*) 'READIN Error: I/O error during internal read.' + write(u6,*) 'The line that could not be read is:' + write(u6,*) Line + end select + call Quit(_RC_IO_ERROR_READ_) + +end subroutine Error + +end subroutine READIN_MRCI diff -Nru openmolcas-22.02/src/mrci/refci.f openmolcas-22.10/src/mrci/refci.f --- openmolcas-22.02/src/mrci/refci.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/refci.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,124 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE REFCI(HREF,AREF,EREF,ICSPCK,CISEL,PLEN) - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "mrci.fh" - DIMENSION HREF((NREF*(NREF+1))/2),AREF(NREF,NREF),EREF(NREF) - DIMENSION PLEN(NREF),CISEL(NREF,NSEL),ICSPCK(NCSPCK) - CHARACTER*2 STR - CHARACTER*48 FORM1,FORM2,FORM3,FORM4 -CPAM97 EXTERNAL UNPACK -CPAM97 INTEGER UNPACK -CPAM97 JCASE(L)=UNPACK(CSPCK((L+29)/30), 2*L-(2*L-1)/60*60, 2) - JCASE(L)=ICUNP(ICSPCK,L) - WRITE(6,*) - CALL XFLUSH(6) - WRITE(6,*)('-',I=1,60) - CALL XFLUSH(6) - WRITE(6,*)' REFERENCE CI CALCULATION.' - CALL XFLUSH(6) - WRITE(6,*)('-',I=1,60) - CALL XFLUSH(6) - IF(NSEL.EQ.0) THEN - WRITE(6,*)' ROOT SELECTION BY ENERGY ORDERING.' - CALL XFLUSH(6) - IF(NRROOT.EQ.1) THEN - WRITE(6,'(A,I8)')' ONE SINGLE ROOT, NUMBER.....: ',IROOT(1) - CALL XFLUSH(6) - ELSE - WRITE(6,*)' THE FOLLOWING ROOTS WILL BE SELECTED:' - CALL XFLUSH(6) - WRITE(6,'(12(A,I2))') ' ROOTS NR ',IROOT(1), - * (',',IROOT(I),I=2,NRROOT-1), - * ', AND ',IROOT(NRROOT) - CALL XFLUSH(6) - END IF - ELSE - WRITE(6,*)' ROOT SELECTION BY PROJECTION: THE EIGENVECTORS OF' - CALL XFLUSH(6) - WRITE(6,*)' THE REFERENCE CI ARE ORDERED BY DECREASING SIZE OF' - CALL XFLUSH(6) - WRITE(6,*)' THEIR PROJECTIONS ONTO A SELECTION SPACE.' - CALL XFLUSH(6) - IF(NRROOT.EQ.1) THEN - WRITE(6,*)' SELECT THE EIGENVECTOR WITH LARGEST PROJECTION.' - CALL XFLUSH(6) - ELSE - WRITE(6,'(A,I2,A)')' SELECT THE ',NRROOT, - * ' EIGENVECTORS WITH LARGEST PROJECTION.' - CALL XFLUSH(6) - END IF - WRITE(6,*)' THE SELECTION SPACE IS SPANNED BY THE FOLLOWING', - * ' VECTORS (NONZERO COMPONENTS ONLY):' - CALL XFLUSH(6) - JJ=0 - DO 1234 I=1,NSEL - WRITE(6,'(A,I2)') ' VECTOR NR. ',I - CALL XFLUSH(6) - NC=NCOMP(I) - WRITE(6,'(5X,I2,5X,A20,F12.8)') - * (J,SSEL(JJ+J),CSEL(JJ+J),J=1,NC) - CALL XFLUSH(6) - JJ=JJ+NC -1234 CONTINUE - END IF - WRITE(6,*) - CALL XFLUSH(6) - CALL JACSCF(HREF,AREF,EREF,NREF,-1,1.0D-11) - CALL ORDER(AREF,EREF,NREF) - CALL CI_SELECT_MRCI(NREF,AREF,PLEN,NSEL,CISEL,NRROOT,IROOT) - IF(NSEL.GT.0) THEN - WRITE(6,*)' THE FOLLOWING ROOTS WERE SELECTED:' - CALL XFLUSH(6) - WRITE(6,'(12(A,I2))') ' ROOTS NR ',IROOT(1), - * (',',IROOT(I),I=2,NRROOT-1), - * ', AND ',IROOT(NRROOT) - CALL XFLUSH(6) - END IF - WRITE(STR,'(I2)') LN - CALL XFLUSH(6) - FORM1='(2X,'//STR//'X,A,I7,2(8X,I7))' - FORM2='(2X,'//STR//'X,A,3F15.8)' - FORM3='('' CSF NR'',I5,'' CASE '','//STR//'I1,3(F13.6,2X))' - FORM4='('' '',I5,'' '','//STR//'I1,3(F13.6,2X))' - WRITE(6,*) - CALL XFLUSH(6) - WRITE(6,*)' LOWEST REFERENCE CI ROOTS:' - CALL XFLUSH(6) - NPRT=MIN(NREF,IROOT(NRROOT)+2) - DO 100 K1=1,NPRT,3 - K2=MIN(NPRT,K1+2) - WRITE(6,FORM1)' ROOT',(K,K=K1,K2) - CALL XFLUSH(6) - IF(NSEL.GT.0) WRITE(6,FORM2)'SELECTION WEIGHT',(PLEN(K),K=K1,K2) - WRITE(6,FORM2)' ENERGY',(EREF(K),K=K1,K2) - CALL XFLUSH(6) - DO 50 IREF=1,NREF - IC=IREFX(IREF) - IOFF=LN*(IC-1) - IF(IREF.EQ.1) THEN - WRITE(6,FORM3)IC,(JCASE(IOFF+J),J=1,LN),(AREF(IREF,K),K=K1,K2) - CALL XFLUSH(6) - ELSE - WRITE(6,FORM4)IC,(JCASE(IOFF+J),J=1,LN),(AREF(IREF,K),K=K1,K2) - CALL XFLUSH(6) - END IF -50 CONTINUE - WRITE(6,*) - CALL XFLUSH(6) -100 CONTINUE - WRITE(6,*) - CALL XFLUSH(6) - RETURN - END diff -Nru openmolcas-22.02/src/mrci/refci.F90 openmolcas-22.10/src/mrci/refci.F90 --- openmolcas-22.02/src/mrci/refci.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/refci.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,93 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine REFCI(HREF,AREF,EREF,ICSPCK,CISEL,PLEN) + +use mrci_global, only: CSEL, IREFX, IROOT, LN, NCOMP, NCSPCK, NREF, NRROOT, NSEL, SSEL +use Definitions, only: wp, iwp, u6 + +implicit none +real(kind=wp), intent(inout) :: HREF((NREF*(NREF+1))/2) +real(kind=wp), intent(out) :: AREF(NREF,NREF), EREF(NREF), PLEN(NREF) +integer(kind=iwp), intent(in) :: ICSPCK(NCSPCK) +real(kind=wp), intent(in) :: CISEL(NREF,NSEL) +integer(kind=iwp) :: I, IC, IOFF, IREF, J, JJ, K, K1, K2, NC, NPRT +character(len=48) :: FORM1, FORM2, FORM3, FORM4 +character(len=2) :: STR +integer(kind=iwp), external :: ICUNP + +write(u6,*) +write(u6,*) ('-',I=1,60) +write(u6,*) ' REFERENCE CI CALCULATION.' +write(u6,*) ('-',I=1,60) +if (NSEL == 0) then + write(u6,*) ' ROOT SELECTION BY ENERGY ORDERING.' + if (NRROOT == 1) then + write(u6,'(A,I8)') ' ONE SINGLE ROOT, NUMBER.....: ',IROOT(1) + else + write(u6,*) ' THE FOLLOWING ROOTS WILL BE SELECTED:' + write(u6,'(12(A,I2))') ' ROOTS NR ',IROOT(1),(',',IROOT(I),I=2,NRROOT-1),', AND ',IROOT(NRROOT) + end if +else + write(u6,*) ' ROOT SELECTION BY PROJECTION: THE EIGENVECTORS OF' + write(u6,*) ' THE REFERENCE CI ARE ORDERED BY DECREASING SIZE OF' + write(u6,*) ' THEIR PROJECTIONS ONTO A SELECTION SPACE.' + if (NRROOT == 1) then + write(u6,*) ' SELECT THE EIGENVECTOR WITH LARGEST PROJECTION.' + else + write(u6,'(A,I2,A)') ' SELECT THE ',NRROOT,' EIGENVECTORS WITH LARGEST PROJECTION.' + end if + write(u6,*) ' THE SELECTION SPACE IS SPANNED BY THE FOLLOWING VECTORS (NONZERO COMPONENTS ONLY):' + JJ = 0 + do I=1,NSEL + write(u6,'(A,I2)') ' VECTOR NR. ',I + NC = NCOMP(I) + write(u6,'(5X,I2,5X,A20,F12.8)') (J,SSEL(JJ+J),CSEL(JJ+J),J=1,NC) + JJ = JJ+NC + end do +end if +write(u6,*) +call JACSCF(HREF,AREF,EREF,NREF,-1,1.0e-11_wp) +call ORDER(AREF,EREF,NREF) +call CI_SELECT_MRCI(NREF,AREF,PLEN,NSEL,CISEL,NRROOT,IROOT) +if (NSEL > 0) then + write(u6,*) ' THE FOLLOWING ROOTS WERE SELECTED:' + write(u6,'(12(A,I2))') ' ROOTS NR ',IROOT(1),(',',IROOT(I),I=2,NRROOT-1),', AND ',IROOT(NRROOT) +end if +write(STR,'(I2)') LN +FORM1 = '(2X,'//STR//'X,A,I7,2(8X,I7))' +FORM2 = '(2X,'//STR//'X,A,3F15.8)' +FORM3 = '('' CSF NR'',I5,'' CASE '','//STR//'I1,3(F13.6,2X))' +FORM4 = '('' '',I5,'' '','//STR//'I1,3(F13.6,2X))' +write(u6,*) +write(u6,*) ' LOWEST REFERENCE CI ROOTS:' +NPRT = min(NREF,IROOT(NRROOT)+2) +do K1=1,NPRT,3 + K2 = min(NPRT,K1+2) + write(u6,FORM1) ' ROOT',(K,K=K1,K2) + if (NSEL > 0) write(u6,FORM2) 'SELECTION WEIGHT',(PLEN(K),K=K1,K2) + write(u6,FORM2) ' ENERGY',(EREF(K),K=K1,K2) + do IREF=1,NREF + IC = IREFX(IREF) + IOFF = LN*(IC-1) + if (IREF == 1) then + write(u6,FORM3) IC,(ICUNP(ICSPCK,IOFF+J),J=1,LN),(AREF(IREF,K),K=K1,K2) + else + write(u6,FORM4) IC,(ICUNP(ICSPCK,IOFF+J),J=1,LN),(AREF(IREF,K),K=K1,K2) + end if + end do + write(u6,*) +end do +write(u6,*) + +return + +end subroutine REFCI diff -Nru openmolcas-22.02/src/mrci/sdci_mrci.f openmolcas-22.10/src/mrci/sdci_mrci.f --- openmolcas-22.02/src/mrci/sdci_mrci.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/sdci_mrci.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,96 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE SDCI_MRCI() - IMPLICIT REAL*8 (A-H,O-Z) - -#include "SysDef.fh" - -#include "mrci.fh" -#include "WrkSpc.fh" -c DIMENSION H(MAXMEM), iH(RtoI*MAXMEM) -C PUT THE SUBROUTINE NAME ONTO THE ENTRY NAME STACK -C INPUT AND MEMORY ALLOCATION: -* CALL READIN(HWork,iHWork) - CALL READIN_MRCI() -C INTEGRAL SORTING AND DIAGONAL ELEMENTS: -C USE COUPLING COEFFS FROM UNIT 10, TRANSFORMED INTEGRALS FROM 13 AND 17 -C PRODUCE FILES UNIT 14, 15 AND 16 WITH SORTED INTEGRALS. -C ALSO FOCK MATRIX TO UNIT 25 AND DIAGONAL ELEMENTS TO UNIT 27. -*PAM04 ALLOCATION OF FOCK MATRIX MOVED HERE FROM ALLOC. - CALL GETMEM('FOCK','ALLO','REAL',LFOCK,NBTRI) - CALL DIAGCT() -C CREATE REFERENCE CI HAMILTONIAN: -*PAM04 CALL MKHREF (HWork(LHREF),Hwork(LFOCK),HWork(LFIJKL), -*PAM04 & HWork(LJREFX)) - NHREF=(NREF*(NREF+1))/2 - CALL GETMEM('HREF','ALLO','REAL',LHREF,NHREF) - NIJ=(LN*(LN+1))/2 - NIJKL=(NIJ*(NIJ+1))/2 - CALL GETMEM('FIJKL','ALLO','REAL',LFIJKL,NIJKL) - CALL MKHREF (Work(LHREF),Work(LFOCK),Work(LFIJKL), - & IWork(LJREFX)) -C SOLVE REFERENCE CI EQUATIONS: -*PAM04 CALL REFCI (HWork(LHREF),HWork(LAREF),HWork(LEREF),HWork(LCSPCK), -*PAM04 * HWork(LCISEL),HWork(LPLEN)) - CALL GETMEM('AREF','ALLO','REAL',LAREF,NREF**2) - CALL GETMEM('EREF','ALLO','REAL',LEREF,NREF) - CALL GETMEM('PLEN','ALLO','REAL',LPLEN,NREF) - CALL REFCI (Work(LHREF),Work(LAREF),Work(LEREF),IWork(LCSPCK), - * Work(LCISEL),Work(LPLEN)) - CALL GETMEM('PLEN','FREE','REAL',LPLEN,NREF) - CALL GETMEM('HREF','FREE','REAL',LHREF,NHREF) - IF(IREFCI.EQ.1) THEN - CALL GETMEM('FOCK','FREE','REAL',LFOCK,NBTRI) - CALL GETMEM('FIJKL','FREE','REAL',LFIJKL,NIJKL) - GOTO 900 - END IF -C SOLVE MRCI OR ACPF EQUATIONS: -C FIRST, SET UP START CI ARRAYS, AND ALSO TRANSFORM DIAGONAL ELEMENTS: -*------ -* POW: Initialize HSMALL(1,1) - HSMALL(1,1)=0.0d0 -*------ - CALL GETMEM('ICI','ALLO','INTE',LICI,MBUF) - CALL GETMEM('CI','ALLO','REAL',LCI,NCONF) - CALL GETMEM('SGM','ALLO','REAL',LSGM,NCONF) - CALL CSTART(Work(LAREF),Work(LEREF),Work(LCI),IWork(LICI)) - CALL MQCT(WORK(LAREF),WORK(LEREF),Work(LCI),Work(LSGM), - & IWork(LICI)) - CALL GETMEM('SGM','FREE','REAL',LSGM,NCONF) - CALL GETMEM('CI','FREE','REAL',LCI,NCONF) - CALL GETMEM('ICI','FREE','INTE',LICI,MBUF) -*PAM04 EXPLICIT DEALLOCATION OF FOCK MATRIX - CALL GETMEM('FOCK','FREE','REAL',LFOCK,NBTRI) -C DENSITY (AND MAYBE TRANSITION DENSITY) MATRICES IN AO BASIS: -*PAM04 ALLOCATION OF DMO AND TDMO MOVED HERE FROM ALLOC: - CALL GETMEM('DMO','ALLO','REAL',LDMO,NBTRI) - IF(ITRANS.EQ.1) CALL GETMEM('TDMO','ALLO','REAL',LTDMO,NBAST**2) -*PAM04 End of addition - CALL DENSCT(WORK(LAREF)) - CALL GETMEM('AREF','FREE','REAL',LAREF,NREF**2) - CALL GETMEM('EREF','FREE','REAL',LEREF,NREF) -C NATURAL ORBITALS AND PROPERTIES (AND MAYBE TRANSITION PROPS): - CALL PROPCT() -*PAM04 EXPLICIT DEALLOCATION ADDED: - CALL GETMEM('DMO','FREE','REAL',LDMO,NBTRI) - IF(ITRANS.EQ.1) CALL GETMEM('TDMO','FREE','REAL',LTDMO,NBAST**2) -*PAM04 End of addition - 900 CONTINUE - CALL GETMEM('FIJKL','FREE','REAL',LFIJKL,NIJKL) - CALL GETMEM('CISEL','FREE','REAL',LCISEL,NSEL*NREF) - CALL GETMEM('JREFX','FREE','INTE',LJREFX,NCVAL) - CALL GETMEM('ISAB','FREE','INTE',LISAB,NVIRT**2) - CALL GETMEM('INDX','FREE','INTE',LINDX,NIWLK) - CALL GETMEM('INTSY','FREE','INTE',LINTSY,NINTSY) - CALL GETMEM('CSPCK','FREE','INTE',LCSPCK,NCSPCK) -C POP THE SUBROUTINE NAME FROM THE ENTRY NAME STACK - RETURN - END diff -Nru openmolcas-22.02/src/mrci/sdci_mrci.F90 openmolcas-22.10/src/mrci/sdci_mrci.F90 --- openmolcas-22.02/src/mrci/sdci_mrci.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/sdci_mrci.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,86 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine SDCI_MRCI() + +use mrci_global, only: CISEL, CSPCK, DMO, FIJKL, FOCK, INDX, INTSY, IREFCI, ISAB, ITRANS, JREFX, LN, MBUF, NBAST, NBTRI, NCONF, & + NREF, TDMO +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp) :: NHREF, NIJ, NIJKL +integer(kind=iwp), allocatable :: ICI(:) +real(kind=wp), allocatable :: AREF(:,:), CI(:), EREF(:), HREF(:), PLEN(:), SGM(:) + +! PUT THE SUBROUTINE NAME ONTO THE ENTRY NAME STACK +! INPUT AND MEMORY ALLOCATION: +call READIN_MRCI() +! INTEGRAL SORTING AND DIAGONAL ELEMENTS: +! USE COUPLING COEFFS FROM UNIT 10, TRANSFORMED INTEGRALS FROM 13 AND 17 +! PRODUCE FILES UNIT 14, 15 AND 16 WITH SORTED INTEGRALS. +! ALSO FOCK MATRIX TO UNIT 25 AND DIAGONAL ELEMENTS TO UNIT 27. +!PAM04 ALLOCATION OF FOCK MATRIX MOVED HERE FROM ALLOC. +call mma_allocate(FOCK,NBTRI,label='FOCK') +call DIAGCT() +! CREATE REFERENCE CI HAMILTONIAN: +NHREF = (NREF*(NREF+1))/2 +call mma_allocate(HREF,NHREF,label='HREF') +NIJ = (LN*(LN+1))/2 +NIJKL = (NIJ*(NIJ+1))/2 +call mma_allocate(FIJKL,NIJKL,label='FIJKL') +call MKHREF(HREF,FOCK,FIJKL,JREFX) +! SOLVE REFERENCE CI EQUATIONS: +call mma_allocate(AREF,NREF,NREF,label='AREF') +call mma_allocate(EREF,NREF,label='EREF') +call mma_allocate(PLEN,NREF,label='PLEN') +call REFCI(HREF,AREF,EREF,CSPCK,CISEL,PLEN) +call mma_deallocate(HREF) +call mma_deallocate(PLEN) +if (IREFCI /= 1) then + ! SOLVE MRCI OR ACPF EQUATIONS: + ! FIRST, SET UP START CI ARRAYS, AND ALSO TRANSFORM DIAGONAL ELEMENTS: + !------ + call mma_allocate(ICI,MBUF,label='ICI') + call mma_allocate(CI,NCONF,label='CI') + call mma_allocate(SGM,NCONF,label='SGM') + call CSTART(AREF,EREF,CI,ICI) + call MQCT(AREF,EREF,CI,SGM,ICI) + call mma_deallocate(CI) + call mma_deallocate(SGM) + call mma_deallocate(ICI) + ! DENSITY (AND MAYBE TRANSITION DENSITY) MATRICES IN AO BASIS: + !PAM04 ALLOCATION OF DMO AND TDMO MOVED HERE FROM ALLOC: + call mma_allocate(DMO,NBTRI,label='DMO') + if (ITRANS == 1) call mma_allocate(TDMO,NBAST,NBAST,label='TDMO') + !PAM04 End of addition + call DENSCT(AREF) + call mma_deallocate(AREF) + call mma_deallocate(EREF) + ! NATURAL ORBITALS AND PROPERTIES (AND MAYBE TRANSITION PROPS): + call PROPCT() + !PAM04 EXPLICIT DEALLOCATION ADDED: + call mma_deallocate(DMO) + if (ITRANS == 1) call mma_deallocate(TDMO) + !PAM04 End of addition +end if +call mma_deallocate(FOCK) +call mma_deallocate(FIJKL) +call mma_deallocate(CISEL) +call mma_deallocate(JREFX) +call mma_deallocate(ISAB) +call mma_deallocate(INDX) +call mma_deallocate(INTSY) +call mma_deallocate(CSPCK) + +return + +end subroutine SDCI_MRCI diff -Nru openmolcas-22.02/src/mrci/seceq.f openmolcas-22.10/src/mrci/seceq.f --- openmolcas-22.02/src/mrci/seceq.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/seceq.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE SECEQ(A,B,C,NAL,IFT,FAC) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(NAL,NAL),B(NAL,NAL),C((NAL*(NAL+1))/2) - IF(IFT.EQ.0) THEN - IAB=0 - DO 20 NA=1,NAL - DO 10 NB=1,NA-1 - IAB=IAB+1 - C(IAB)=B(NB,NA)+A(NA,NB) -10 CONTINUE - IAB=IAB+1 - C(IAB)=FAC*A(NA,NA) -20 CONTINUE - ELSE - IAB=0 - DO 40 NA=1,NAL - DO 30 NB=1,NA-1 - IAB=IAB+1 - C(IAB)=B(NB,NA)-A(NA,NB) -30 CONTINUE - IAB=IAB+1 - C(IAB)=0.0D00 -40 CONTINUE - END IF - RETURN - END diff -Nru openmolcas-22.02/src/mrci/seceq.F90 openmolcas-22.10/src/mrci/seceq.F90 --- openmolcas-22.02/src/mrci/seceq.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/seceq.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,47 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine SECEQ(A,B,C,NAL,IFT,FAC) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: NAL, IFT +real(kind=wp), intent(in) :: A(NAL,NAL), B(NAL,NAL), FAC +real(kind=wp), intent(out) :: C((NAL*(NAL+1))/2) +integer(kind=iwp) :: IAB, NA, NB + +if (IFT == 0) then + IAB = 0 + do NA=1,NAL + do NB=1,NA-1 + IAB = IAB+1 + C(IAB) = B(NB,NA)+A(NA,NB) + end do + IAB = IAB+1 + C(IAB) = FAC*A(NA,NA) + end do +else + IAB = 0 + do NA=1,NAL + do NB=1,NA-1 + IAB = IAB+1 + C(IAB) = B(NB,NA)-A(NA,NB) + end do + IAB = IAB+1 + C(IAB) = Zero + end do +end if + +return + +end subroutine SECEQ diff -Nru openmolcas-22.02/src/mrci/secne.f openmolcas-22.10/src/mrci/secne.f --- openmolcas-22.02/src/mrci/secne.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/secne.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,30 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE SECNE(A,B,C,NAL,NBL,NSIJ,IFT) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(NAL,NBL),B(NBL,NAL),C(NBL,NAL) - IF(IFT.EQ.0) THEN - DO 20 NA=1,NAL - DO 10 NB=1,NBL - C(NB,NA)=B(NB,NA)+A(NA,NB) -10 CONTINUE -20 CONTINUE - ELSE - DO 40 NA=1,NAL - DO 30 NB=1,NBL - C(NB,NA)=B(NB,NA)-A(NA,NB) -30 CONTINUE -40 CONTINUE - END IF - RETURN -c Avoid unused argument warnings - IF (.FALSE.) CALL Unused_integer(NSIJ) - END diff -Nru openmolcas-22.02/src/mrci/secne.F90 openmolcas-22.10/src/mrci/secne.F90 --- openmolcas-22.02/src/mrci/secne.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/secne.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,38 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine SECNE(A,B,C,NAL,NBL,IFT) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: NAL, NBL, IFT +real(kind=wp), intent(in) :: A(NAL,NBL), B(NBL,NAL) +real(kind=wp), intent(out) :: C(NBL,NAL) +integer(kind=iwp) :: NA, NB + +if (IFT == 0) then + do NA=1,NAL + do NB=1,NBL + C(NB,NA) = B(NB,NA)+A(NA,NB) + end do + end do +else + do NA=1,NAL + do NB=1,NBL + C(NB,NA) = B(NB,NA)-A(NA,NB) + end do + end do +end if + +return + +end subroutine SECNE diff -Nru openmolcas-22.02/src/mrci/secular.f openmolcas-22.10/src/mrci/secular.f --- openmolcas-22.02/src/mrci/secular.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/secular.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,83 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE SECULAR(NDIM,N,NRON,HMAT,SMAT,VEC,EVAL,SCR,THR) - IMPLICIT REAL*8 (A-H,O-Z) - INTRINSIC SQRT - DIMENSION HMAT(NDIM,NDIM),SMAT(NDIM,NDIM) - DIMENSION VEC(NDIM,NDIM),EVAL(NDIM),SCR(*) - THR2=THR**2 -C PUT NORMALIZED VECTORS INTO VEC: - CALL DCOPY_(N*NDIM,[0.0D00],0,VEC,1) - DO 5 I=1,N - VEC(I,I)=1.0D00/SQRT(SMAT(I,I)) -5 CONTINUE -C GRAM-SCHMIDT ORTHONORMALIZING PROCEDURE: - NRON=0 - DO 60 I=1,N -C SMAT*(NORMALIZED VECTOR) INTO SCR: - CALL DCOPY_(N,SMAT(1,I),1,SCR,1) - CALL DSCAL_(N,VEC(I,I),SCR,1) -C PROJECT AWAY THE ALREADY ORTHONORMALIZED BASIS SET: - DO 30 J=1,NRON - MAXLEN=I-1-NRON+J - SUM=0.0D00 - DO 10 K=1,MAXLEN - SUM=SUM+VEC(K,J)*SCR(K) -10 CONTINUE - DO 20 K=1,MAXLEN - VEC(K,I)=VEC(K,I)-SUM*VEC(K,J) -20 CONTINUE -30 CONTINUE -C NORMALIZE AND MOVE INTO POSITION: - SUM=0.0D00 - DO 40 K=1,I - SUM=SUM+VEC(K,I)*SCR(K) -40 CONTINUE - IF(SUM.LT.THR2) GOTO 60 - NRON=NRON+1 - SCALE=1.0D00/SQRT(SUM) - DO 50 K=1,I - VEC(K,NRON)=SCALE*VEC(K,I) -50 CONTINUE -60 CONTINUE - DO 70 I=NRON+1,N - CALL DCOPY_(N,[0.0D00],0,VEC(1,I),1) -70 CONTINUE -C TRANSFORM HAMILTONIAN INTO SCR: - IOFF1=N*NRON - CALL DGEMM_('N','N', - & N,NRON,N, - & 1.0d0,HMAT,NDIM, - & VEC,NDIM, - & 0.0d0,SCR,N) - CALL DGEMM_('T','N', - & NRON,NRON,N, - & 1.0d0,VEC,NDIM, - & SCR,N, - & 0.0d0,SCR(IOFF1+1),NRON) -C COPY TRANSFORMED HMAT INTO TRIANGULAR STORAGE IN SCR: - IFROM=IOFF1+1 - ITO=1 - DO 110 I=1,NRON - CALL DCOPY_(I,SCR(IFROM),1,SCR(ITO),1) - ITO=ITO+I - IFROM=IFROM+NRON -110 CONTINUE -C DIAGONALIZE: - CALL Jacob(SCR,VEC,NRON,NDIM) -C COPY EIGENVALUES INTO EVAL: - II=0 - DO 120 I=1,NRON - II=II+I - EVAL(I)=SCR(II) -120 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/secular.F90 openmolcas-22.10/src/mrci/secular.F90 --- openmolcas-22.02/src/mrci/secular.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/secular.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,89 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine SECULAR(NDIM,N,NRON,HMAT,SMAT,VEC,EVAL,SCR,THR) + +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: NDIM, N +integer(kind=iwp), intent(out) :: NRON +real(kind=wp), intent(in) :: HMAT(NDIM,NDIM), SMAT(NDIM,NDIM), THR +real(kind=wp), intent(out) :: VEC(NDIM,NDIM), EVAL(NDIM) +real(kind=wp), intent(_OUT_) :: SCR(*) +integer(kind=iwp) :: I, IFROM, II, IOFF1, ITO, J, K, MAXLEN +real(kind=wp) :: RSUM, SCL, THR2 + +THR2 = THR**2 +! PUT NORMALIZED VECTORS INTO VEC: +VEC(:,1:N) = Zero +do I=1,N + VEC(I,I) = One/sqrt(SMAT(I,I)) +end do +! GRAM-SCHMIDT ORTHONORMALIZING PROCEDURE: +NRON = 0 +do I=1,N + ! SMAT*(NORMALIZED VECTOR) INTO SCR: + SCR(1:N) = VEC(I,I)*SMAT(1:N,I) + ! PROJECT AWAY THE ALREADY ORTHONORMALIZED BASIS SET: + do J=1,NRON + MAXLEN = I-1-NRON+J + RSUM = Zero + do K=1,MAXLEN + RSUM = RSUM+VEC(K,J)*SCR(K) + end do + do K=1,MAXLEN + VEC(K,I) = VEC(K,I)-RSUM*VEC(K,J) + end do + end do + ! NORMALIZE AND MOVE INTO POSITION: + RSUM = Zero + do K=1,I + RSUM = RSUM+VEC(K,I)*SCR(K) + end do + if (RSUM >= THR2) then + NRON = NRON+1 + SCL = One/sqrt(RSUM) + do K=1,I + VEC(K,NRON) = SCL*VEC(K,I) + end do + end if +end do +do I=NRON+1,N + VEC(1:N,I) = Zero +end do +! TRANSFORM HAMILTONIAN INTO SCR: +IOFF1 = N*NRON +call DGEMM_('N','N',N,NRON,N,One,HMAT,NDIM,VEC,NDIM,Zero,SCR,N) +call DGEMM_('T','N',NRON,NRON,N,One,VEC,NDIM,SCR,N,Zero,SCR(IOFF1+1),NRON) +! COPY TRANSFORMED HMAT INTO TRIANGULAR STORAGE IN SCR: +IFROM = IOFF1+1 +ITO = 1 +do I=1,NRON + call DCOPY_(I,SCR(IFROM),1,SCR(ITO),1) + ITO = ITO+I + IFROM = IFROM+NRON +end do +! DIAGONALIZE: +call Jacob(SCR,VEC,NRON,NDIM) +! COPY EIGENVALUES INTO EVAL: +II = 0 +do I=1,NRON + II = II+I + EVAL(I) = SCR(II) +end do + +return + +end subroutine SECULAR diff -Nru openmolcas-22.02/src/mrci/select.f openmolcas-22.10/src/mrci/select.f --- openmolcas-22.02/src/mrci/select.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/select.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,51 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE CI_SELECT_MRCI(NREF,AREF,PLEN,NSEL,CISEL,NRROOT,IROOT) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION AREF(NREF,NREF),CISEL(NREF,*),IROOT(NRROOT) - DIMENSION PLEN(NREF) - IF(NSEL.EQ.0) RETURN -C SELECTION BY PROJECTION ONTO SPACE SPANNED BY CISEL VECTORS. IROOT() -C IS SET TO SELECT THE NRROOT VECTORS WITH MAX PROJECTED LENGTH. - DO 140 J=1,NREF - SUM=0.0D00 - DO 130 ISEL=1,NSEL - SUM1=0.0D00 - DO 120 I=1,NREF - SUM1=SUM1+AREF(I,J)*CISEL(I,ISEL) -120 CONTINUE - SUM=SUM+SUM1**2 -130 CONTINUE - PLEN(J)=SUM+J*1.0D-12 -140 CONTINUE -C SELECT BY MAGNITUDE OF PLEN: - DO 160 J=1,NRROOT - PMAX=PLEN(1) - JMAX=1 - DO 150 JJ=2,NREF - IF(PMAX.GE.PLEN(JJ)) GOTO 150 - PMAX=PLEN(JJ) - JMAX=JJ -150 CONTINUE - PLEN(JMAX)=-PMAX -160 CONTINUE - I=0 - DO 170 IR=1,NREF - PL=PLEN(IR) - IF(PL.LT.0.0D00) THEN - I=I+1 - IROOT(I)=IR - PL=-PL - END IF - PLEN(IR)=PL-IR*1.0D-12 -170 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/setzz.f openmolcas-22.10/src/mrci/setzz.f --- openmolcas-22.02/src/mrci/setzz.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/setzz.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE SETZZ(A,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(N,N) - DO 10 I=1,N - A(I,I)=0.0 -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/siadd.f openmolcas-22.10/src/mrci/siadd.f --- openmolcas-22.02/src/mrci/siadd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/siadd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE SIADD(A,B,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(N,N),B(*) - IN=0 - DO 10 I=1,N - DO 20 J=1,I - IN=IN+1 - B(IN)=B(IN)+A(I,J)+A(J,I) -20 CONTINUE - B(IN)=B(IN)-A(I,I) -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/sigma.f openmolcas-22.10/src/mrci/sigma.f --- openmolcas-22.02/src/mrci/sigma.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/sigma.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,81 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE SIGMA(SGM,AREF,CI,INTSY,INDX,BMN,IBMN,BIAC2, - & BICA2,BFIN3,ISAB,AC1,AC2,BFIN4,ABIJ, - & AIBJ,AJBI,ASCR1,BSCR1,FSCR1,FSEC,FOCK, -*PAM04 & BFIN5,ASCR2,BSCR2,FSCR2,DBK,CSPCK) - & BFIN5,ASCR2,BSCR2,FSCR2,DBK,ICSPCK) - IMPLICIT REAL*8 (A-H,O-Z) -*PAM04 Integer INTSY(*),INDX(*),IBMN(*),ISAB(*) - Integer INTSY(*),INDX(*),IBMN(*),ISAB(*),ICSPCK(*) - Real*8 SGM(*),AREF(*),CI(*),BMN(*),BIAC2(*),BICA2(*) - Real*8 BFIN3(*),AC1(*),AC2(*),BFIN4(*),ABIJ(*) - Real*8 AIBJ(*),AJBI(*),ASCR1(*),BSCR1(*),FSCR1(*) - Real*8 FSEC(*),FOCK(*),BFIN5(*),ASCR2(*),BSCR2(*),FSCR2(*) -*PAM04 Real*8 DBK(*),CSPCK(*) - Real*8 DBK(*) -#include "WrkSpc.fh" -#include "SysDef.fh" -#include "mrci.fh" - CALL DCOPY_(NCONF,[0.0D0],0,SGM,1) - - CALL CSFTRA(' CSF',CI,AREF) - SQGP=1.0D00 - SQG =1.0D00 - IF(ICPF.EQ.1) THEN - SQGP=SQRT(GFAC) - SQG=1.0D00/SQGP - DO IREF=1,NREF - ICSF=IREFX(IREF) - CI(ICSF)=SQGP*CI(ICSF) - END DO - END IF - - CALL DIAGC(INTSY,CI,SGM) - IF(IFIRST.EQ.0 .AND. ((IREST.EQ.1).OR.(ITER.GT.1)) ) THEN - CALL ABCI_MRCI(INTSY,INDX,CI,SGM,BMN,IBMN,BIAC2,BICA2,BFIN3) - CALL ABCD_MRCI(INTSY,INDX,ISAB,CI,SGM,AC1,AC2,BFIN4) - END IF -*PAM04 CALL IJKL(INTSY,INDX,CI,SGM,FIJKL) - CALL IJKL(INTSY,INDX,CI,SGM,WORK(LFIJKL)) -c -*PAM04 CALL FAIBJ(INTSY,INDX,CI,SGM,ABIJ,AIBJ,AJBI,BFIN1,BFIN1, -*PAM04 & ASCR1,BSCR1,FSCR1,FSEC) - CALL FAIBJ(INTSY,INDX,CI,SGM,ABIJ,AIBJ,AJBI, - & ASCR1,BSCR1,FSCR1,FSEC) - - IF(ITER.GT.0) THEN - KTYP=1 -* Switch KTYP=1 means AI is actually handling AIJK integrals. -*PAM04 CALL AI(INTSY,INDX,CI,SGM,FOCK,BFIN5,BFIN5,ASCR2,BSCR2, -*PAM04 & FSCR2,DBK,KTYP) - CALL AI_MRCI(INTSY,INDX,CI,SGM,FOCK,ASCR2,BSCR2,FSCR2,DBK,KTYP) - END IF -*PAM04 CALL FIJ(CSPCK,INTSY,INDX,CI,SGM,FOCK,ASCR2,BSCR2,FSCR2,DBK) - CALL FIJ_MRCI(ICSPCK,INTSY,INDX,CI,SGM,FOCK,ASCR2,BSCR2,FSCR2,DBK) - - CALL DAXPY_(NCONF,POTNUC-ESHIFT,CI,1,SGM,1) - IF(ICPF.EQ.1) THEN - GINV=1.0D00/GFAC - CALL DSCAL_(NCONF,GINV,SGM,1) - DO IREF=1,NREF - ICSF=IREFX(IREF) - CI(ICSF)=SQG*CI(ICSF) - SGM(ICSF)=SQGP*SGM(ICSF) - END DO - END IF - - CALL CSFTRA('MCSF',SGM,AREF) - - RETURN -c Avoid unused argument warnings - IF (.FALSE.) CALL Unused_real_array(BFIN5) - END diff -Nru openmolcas-22.02/src/mrci/sigma.F90 openmolcas-22.10/src/mrci/sigma.F90 --- openmolcas-22.02/src/mrci/sigma.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/sigma.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,76 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine SIGMA(SGM,AREF,CI,INTSY,INDX,BMN,IBMN,BIAC2,BICA2,BFIN3,ISAB,AC1,AC2,BFIN4,ABIJ,AIBJ,AJBI,ASCR1,BSCR1,FSCR1,FSEC,FOCK, & + ASCR2,BSCR2,FSCR2,DBK) + +use mrci_global, only: ESHIFT, FIJKL, GFAC, ICPF, IFIRST, IREFX, IREST, ITER, NCONF, NREF, POTNUC +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +real(kind=wp), intent(_OUT_) :: SGM(*), BMN(*), BIAC2(*), BICA2(*), BFIN3(*), AC1(*), AC2(*), BFIN4(*), ASCR1(*), BSCR1(*), & + FSCR1(*), ASCR2(*), BSCR2(*), FSCR2(*), DBK(*) +real(kind=wp), intent(in) :: AREF(*) +real(kind=wp), intent(inout) :: CI(*), ABIJ(*), AIBJ(*), AJBI(*), FSEC(*), FOCK(*) +integer(kind=iwp), intent(in) :: INTSY(*), INDX(*), ISAB(*) +integer(kind=iwp), intent(_OUT_) :: IBMN(*) +integer(kind=iwp) :: ICSF, IREF, KTYP +real(kind=wp) :: GINV, SQG, SQGP + +SGM(1:NCONF) = Zero + +call CSFTRA(' CSF',CI,AREF) +SQGP = One +SQG = One +if (ICPF == 1) then + SQGP = sqrt(GFAC) + SQG = One/SQGP + do IREF=1,NREF + ICSF = IREFX(IREF) + CI(ICSF) = SQGP*CI(ICSF) + end do +end if + +call DIAGC(INTSY,CI,SGM) +if ((IFIRST == 0) .and. ((IREST == 1) .or. (ITER > 1))) then + call ABCI(INTSY,INDX,CI,SGM,BMN,IBMN,BIAC2,BICA2,BFIN3) + call ABCD(INTSY,INDX,ISAB,CI,SGM,AC1,AC2,BFIN4) +end if +call IJKL(INTSY,INDX,CI,SGM,FIJKL) + +call FAIBJ(INTSY,INDX,CI,SGM,ABIJ,AIBJ,AJBI,ASCR1,BSCR1,FSCR1,FSEC) + +if (ITER > 0) then + KTYP = 1 + ! Switch KTYP=1 means AI is actually handling AIJK integrals. + call AI_MRCI(INTSY,INDX,CI,SGM,FOCK,ASCR2,BSCR2,FSCR2,DBK,KTYP) +end if +call FIJ(INTSY,INDX,CI,SGM,FOCK,ASCR2,BSCR2,FSCR2,DBK) + +SGM(1:NCONF) = SGM(1:NCONF)+(POTNUC-ESHIFT)*CI(1:NCONF) +if (ICPF == 1) then + GINV = One/GFAC + SGM(1:NCONF) = GINV*SGM(1:NCONF) + do IREF=1,NREF + ICSF = IREFX(IREF) + CI(ICSF) = SQG*CI(ICSF) + SGM(ICSF) = SQGP*SGM(ICSF) + end do +end if + +call CSFTRA('MCSF',SGM,AREF) + +return + +end subroutine SIGMA diff -Nru openmolcas-22.02/src/mrci/sorta.f openmolcas-22.10/src/mrci/sorta.f --- openmolcas-22.02/src/mrci/sorta.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/sorta.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,355 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE SORTA(BUFS,INDS,ISAB,BUFBI,BIAC,BICA,NINTGR) - IMPLICIT REAL*8 (A-H,O-Z) - External COUNT -#include "SysDef.fh" -#include "warnings.h" -#include "mrci.fh" - DIMENSION BUFS(NBITM1,NCHN1) - DIMENSION INDS(NBITM1+2,NCHN1) - DIMENSION BUFBI(KBUFF1) - DIMENSION BIAC(ISMAX),BICA(ISMAX) - DIMENSION ISAB(*) -C SORTS INTEGRALS (AB/CI) -C FOR FIXED B,I ALL A,C -C FIRST CHAIN FOR IJKL - DIMENSION NORB0(9) - CALL COUNT(NINTGR,NSYM,NORB,MUL) - IF(IPRINT.GE.6) WRITE(6,1234)NINTGR - CALL XFLUSH(6) - 1234 FORMAT(//6X,'NUMBER OF TWO-ELECTRON INTEGRALS',I10) - - IAD50=0 - CALL iDAFILE(LUTRA,2,iTraToc,nTraToc,IAD50) -* IBOFF1=RTOI*NBITM1 -* IBBC1=IBOFF1+NBITM1+1 -* IBDA1=IBBC1+1 - - IDISK=0 - ICHK=0 - DO 5 IREC=1,NCHN1 -* INDOUT(IBBC1+(IREC-1)*RTOI*NBSIZ1)=0 -* INDOUT(IBDA1+(IREC-1)*RTOI*NBSIZ1)=-1 - INDS(NBITM1+1,IREC)=0 - INDS(NBITM1+2,IREC)=-1 -5 CONTINUE - NORB0(1)=0 - DO 4 I=1,NSYM - NORB0(I+1)=NORB0(I)+NORB(I) -4 CONTINUE -C -C TWO-ELECTRON INTEGRALS -C - DO 313 NSP=1,NSYM - NOP=NORB(NSP) - DO 312 NSQ=1,NSP - NSPQ=MUL(NSP,NSQ) - NOQ=NORB(NSQ) - DO 311 NSR=1,NSP - NSPQR=MUL(NSPQ,NSR) - NOR=NORB(NSR) - NSSM=NSR - IF(NSR.EQ.NSP)NSSM=NSQ - DO 310 NSS=1,NSSM - IF(NSS.NE.NSPQR)GO TO 310 - NOS=NORB(NSS) - NORBP=NOP*NOQ*NOR*NOS - IF(NORBP.EQ.0)GO TO 310 - CALL dDAFILE(LUTRA,2,TIBUF,NTIBUF,IAD50) - IOUT=0 - DO 309 NV=1,NOR - NXM=NOS - IF(NSR.EQ.NSS)NXM=NV - DO 308 NX=1,NXM - NTM=1 - IF(NSP.EQ.NSR)NTM=NV - DO 307 NT=NTM,NOP - NUMIN=1 - IF(NSP.EQ.NSR.AND.NT.EQ.NV)NUMIN=NX - NUMAX=NOQ - IF(NSP.EQ.NSQ)NUMAX=NT - DO 306 NU=NUMIN,NUMAX - IOUT=IOUT+1 - IF(IOUT.GT.NTIBUF) THEN - CALL dDAFILE(LUTRA,2,TIBUF,NTIBUF,IAD50) - IOUT=1 - END IF - FINI=TIBUF(IOUT) - NI=ICH(NORB0(NSP)+NT) - IF(NI.LE.0) GOTO 306 - NJ=ICH(NORB0(NSQ)+NU) - IF(NJ.LE.0) GOTO 306 - NK=ICH(NORB0(NSR)+NV) - IF(NK.LE.0) GOTO 306 - NL=ICH(NORB0(NSS)+NX) - IF(NL.LE.0) GOTO 306 -C ORDER THESE INDICES CANONICALLY - IF(NI.LT.NJ) THEN - M=NI - NI=NJ - NJ=M - END IF - IF(NK.LT.NL) THEN - M=NK - NK=NL - NL=M - END IF - IF(NI.LT.NK) THEN - M=NK - NK=NI - NI=M - M=NL - NL=NJ - NJ=M - ELSE IF((NI.EQ.NK).AND.(NJ.LT.NL)) THEN - M=NL - NL=NJ - NJ=M - END IF - IF(NI.LE.LN)GO TO 109 - IF(NK.LE.LN)GO TO 306 - IF(IFIRST.NE.0)GO TO 306 - IF(NJ.LE.LN)GO TO 42 - IF(NL.GT.LN)GO TO 306 -C ABCI - NA=NI-LN - NB=NJ-LN - NC=NK-LN - NI=NL - GO TO 108 -42 CONTINUE - IF(NL.LE.LN) GOTO 306 -C CIAB - NA=NK-LN - NB=NL-LN - NC=NI-LN - NI=NJ -108 NIB=(NI-1)*NVIRT+NB+1 -* IPOS=INDOUT(IBBC1+(NIB-1)*RTOI*NBSIZ1)+1 -* INDOUT(IBBC1+(NIB-1)*RTOI*NBSIZ1)=IPOS - IPOS=INDS(NBITM1+1,NIB)+1 - INDS(NBITM1+1,NIB)=IPOS -* BUFOUT(IPOS+(NIB-1)*NBSIZ1)=FINI -* INDOUT(IBOFF1+IPOS+(NIB-1)*RTOI*NBSIZ1)=(NA-1)*NVIRT+NC - BUFS(IPOS,NIB)=FINI - INDS(IPOS,NIB)=(NA-1)*NVIRT+NC - IF(IPOS.GE.NBITM1) THEN - JDISK=IDISK -* CALL dDAFILE(Lu_60,1,INDOUT(1+(NIB-1)*RTOI*NBSIZ1),NBSIZ1,IDISK) - CALL iDAFILE(Lu_60,1,INDS(1,NIB),NBITM1+2,IDISK) - CALL dDAFILE(Lu_60,1,BUFS(1,NIB),NBITM1,IDISK) -* INDOUT(IBDA1+(NIB-1)*RTOI*NBSIZ1)=JDISK -* INDOUT(IBBC1+(NIB-1)*RTOI*NBSIZ1)=0 - INDS(NBITM1+1,NIB)=0 - INDS(NBITM1+2,NIB)=JDISK - END IF - IF(NA.EQ.NB)GO TO 306 - NAT=NA - NA=NB - NB=NAT - NIB=(NI-1)*NVIRT+NB+1 -* IPOS=INDOUT(IBBC1+(NIB-1)*RTOI*NBSIZ1)+1 -* INDOUT(IBBC1+(NIB-1)*RTOI*NBSIZ1)=IPOS - IPOS=INDS(NBITM1+1,NIB)+1 - INDS(NBITM1+1,NIB)=IPOS -* BUFOUT(IPOS+(NIB-1)*NBSIZ1)=FINI -* INDOUT(IBOFF1+IPOS+(NIB-1)*RTOI*NBSIZ1)=(NA-1)*NVIRT+NC - BUFS(IPOS,NIB)=FINI - INDS(IPOS,NIB)=(NA-1)*NVIRT+NC - IF(IPOS.GE.NBITM1) THEN - JDISK=IDISK -* CALL dDAFILE(Lu_60,1,INDOUT(1+(NIB-1)*RTOI*NBSIZ1),NBSIZ1,IDISK) - CALL iDAFILE(Lu_60,1,INDS(1,NIB),NBITM1+2,IDISK) - CALL dDAFILE(Lu_60,1,BUFS(1,NIB),NBITM1,IDISK) -* INDOUT(IBDA1+(NIB-1)*RTOI*NBSIZ1)=JDISK -* INDOUT(IBBC1+(NIB-1)*RTOI*NBSIZ1)=0 - INDS(NBITM1+1,NIB)=0 - INDS(NBITM1+2,NIB)=JDISK - END IF - GOTO 306 -C IJKL -109 IIJ=IROW(NI)+NJ - KL=IROW(NK)+NL - IJKL=IIJ*(IIJ-1)/2+KL - IJ=1 -* IPOS=INDOUT(IBBC1+(IJ-1)*RTOI*NBSIZ1)+1 -* INDOUT(IBBC1+(IJ-1)*RTOI*NBSIZ1)=IPOS - IPOS=INDS(NBITM1+1,IJ)+1 - INDS(NBITM1+1,IJ)=IPOS -* BUFOUT(IPOS+(IJ-1)*NBSIZ1)=FINI -* INDOUT(IBOFF1+IPOS+(IJ-1)*RTOI*NBSIZ1)=IJKL - BUFS(IPOS,IJ)=FINI - INDS(IPOS,IJ)=IJKL - IF(IPOS.EQ.NBITM1) THEN - JDISK=IDISK -* CALL dDAFILE(Lu_60,1,INDOUT(1+(IJ-1)*RTOI*NBSIZ1),NBSIZ1,IDISK) - CALL iDAFILE(Lu_60,1,INDS(1,IJ),NBITM1+2,IDISK) - CALL dDAFILE(Lu_60,1,BUFS(1,IJ),NBITM1,IDISK) -* INDOUT(IBDA1+(IJ-1)*RTOI*NBSIZ1)=JDISK -* INDOUT(IBBC1+(IJ-1)*RTOI*NBSIZ1)=0 - INDS(NBITM1+1,IJ)=0 - INDS(NBITM1+2,IJ)=JDISK - END IF -306 CONTINUE -307 CONTINUE -308 CONTINUE -309 CONTINUE -310 CONTINUE -311 CONTINUE -312 CONTINUE -313 CONTINUE -C EMPTY LAST BUFFERS - If ( NChn1.gt.mChain ) then - WRITE(6,*)'SORTA Error: NCHN1 > MCHAIN (See code).' - CALL QUIT(_RC_GENERAL_ERROR_) - End If - DO 150 I=1,NCHN1 - JDISK=IDISK -* CALL dDAFILE(Lu_60,1,INDOUT(1+(I-1)*RTOI*NBSIZ1),NBSIZ1,IDISK) - CALL iDAFILE(Lu_60,1,INDS(1,I),NBITM1+2,IDISK) - CALL dDAFILE(Lu_60,1,BUFS(1,I),NBITM1,IDISK) - LASTAD(I)=JDISK -150 CONTINUE -C IJKL - IDISK=0 - IBUFIJ=0 - ISRTAD=-1 - IADR=LASTAD(1) -201 CONTINUE -* CALL dDAFILE(Lu_60,2,INDOUT,NBSIZ1,IADR) - CALL iDAFILE(Lu_60,2,INDS,NBITM1+2,IADR) - CALL dDAFILE(Lu_60,2,BUFS,NBITM1,IADR) -* LENGTH=INDOUT(IBBC1) -* IADR=INDOUT(IBDA1) - LENGTH=INDS(NBITM1+1,1) - IADR=INDS(NBITM1+2,1) - DO 202 I=1,LENGTH - IBUFIJ=IBUFIJ+1 -* VALSRT(IBUFIJ)=BUFOUT(I) -* INDSRT(IBUFIJ)=INDOUT(IBOFF1+I) - VALSRT(IBUFIJ)=BUFS(I,1) - INDSRT(IBUFIJ)=INDS(I,1) - IF(IBUFIJ.LT.NSRTMX)GO TO 202 - NSRTCN=NSRTMX - JDISK=IDISK -* - INDSRT(NSRTMX+1)=NSRTCN - INDSRT(NSRTMX+2)=ISRTAD - CALL dDAFILE(Lu_70,1,VALSRT,NSRTMX,IDISK) - CALL iDAFILE(Lu_70,1,INDSRT,NSRTMX+2,IDISK) -* - ISRTAD=JDISK - IBUFIJ=0 -202 CONTINUE - IF(IADR.NE.-1) GO TO 201 -C EMPTY LAST BUFFER - NSRTCN=IBUFIJ - JDISK=IDISK -* - INDSRT(NSRTMX+1)=NSRTCN - INDSRT(NSRTMX+2)=ISRTAD - CALL dDAFILE(Lu_70,1,VALSRT,NSRTMX,IDISK) - CALL iDAFILE(Lu_70,1,INDSRT,NSRTMX+2,IDISK) -* - LASTAD(1)=JDISK -C ABCI - IAD15=IDISK - IADABCI=IAD15 - INSOUT=0 - IADD10=IAD10(4) - CALL dDAFILE(LUSYMB,2,COP,nCOP,IADD10) - CALL iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IN=2 - NSAVE=ICOP1(IN) -100 NI=NSAVE - IOUT=0 -110 IN=IN+1 - IF(IN.GT.LEN) THEN - CALL dDAFILE(LUSYMB,2,COP,nCOP,IADD10) - CALL iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) - LEN=ICOP1(nCOP+1) - IF(LEN.LE.0)GO TO 6 - IN=1 - END IF - IF(ICHK.NE.0)GO TO 460 - IF(ICOP1(IN).EQ.0) THEN - ICHK=1 - ELSE - IOUT=IOUT+1 - END IF - GO TO 110 -460 ICHK=0 - NSAVE=ICOP1(IN) -6 CONTINUE - NIB=1+(NI-1)*NVIRT -C LOOP OVER VIRTUAL ORBITAL INDEX B: - DO 20 NB=1,NVIRT - NSIB=MUL(NSM(LN+NB),NSM(NI)) - INS=NVPAIR(NSIB) - IF(INS.NE.0) THEN - CALL FZERO(BIAC,INS) - CALL FZERO(BICA,INS) - END IF - NIB=NIB+1 -C READ & PROCESS INTEGRAL BUFFERS ON UNIT 14: - IADR=LASTAD(NIB) -203 CONTINUE -* CALL dDAFILE(Lu_60,2,INDOUT,NBSIZ1,IADR) - CALL iDAFILE(Lu_60,2,INDS,NBITM1+2,IADR) - CALL dDAFILE(Lu_60,2,BUFS,NBITM1,IADR) -* LENGTH=INDOUT(IBBC1) -* IADR=INDOUT(IBDA1) - LENGTH=INDS(NBITM1+1,1) - IADR=INDS(NBITM1+2,1) - DO 204 KK=1,LENGTH -* INND=INDOUT(IBOFF1+KK) - INND=INDS(KK,1) - NA=(INND-1)/NVIRT+1 - NC=INND-(NA-1)*NVIRT - IACS=ISAB(NA+(NC-1)*NVIRT) -* BIAC(IACS)=BIAC(IACS)+BUFOUT(KK) - BIAC(IACS)=BIAC(IACS)+BUFS(KK,1) -* IF(NA.GT.NC)BICA(IACS)=BICA(IACS)-BUFOUT(KK) -* IF(NA.LT.NC)BICA(IACS)=BICA(IACS)+BUFOUT(KK) - IF(NA.GT.NC)BICA(IACS)=BICA(IACS)-BUFS(KK,1) - IF(NA.LT.NC)BICA(IACS)=BICA(IACS)+BUFS(KK,1) -204 CONTINUE - IF(IADR.NE.-1) GO TO 203 - DO 72 ILOOP=0,1 - INSB=INS -73 INB=KBUFF1-INSOUT - INUMB=INSB - IF(INSB.GT.INB)INUMB=INB - IST=INS-INSB+1 - IF(ILOOP.EQ.0)CALL DCOPY_(INUMB,BIAC(IST),1,BUFBI(INSOUT+1),1) - IF(ILOOP.EQ.1)CALL DCOPY_(INUMB,BICA(IST),1,BUFBI(INSOUT+1),1) - INSOUT=INSOUT+INUMB - IF(INSOUT.GT.KBUFF1) THEN - WRITE(6,*) 'SortA: INSOUT.GT.KBUFF1' - WRITE(6,*) 'INSOUT=',INSOUT - WRITE(6,*) 'KBUFF1=',KBUFF1 - CALL ABEND - END IF - IF(INSOUT.EQ.KBUFF1) THEN - CALL dDAFILE(Lu_70,1,BUFBI,KBUFF1,IAD15) - INSOUT=0 - END IF - INSB=INSB-INUMB - IF(INSB.GT.0)GO TO 73 -72 CONTINUE -20 CONTINUE - IF(LEN.GE.0)GO TO 100 -C EMPTY LAST BUFFER IF NOT EMPTY - IF(INSOUT.GT.0) CALL dDAFILE(Lu_70,1,BUFBI,KBUFF1,IAD15) - RETURN - END diff -Nru openmolcas-22.02/src/mrci/sorta.F90 openmolcas-22.10/src/mrci/sorta.F90 --- openmolcas-22.02/src/mrci/sorta.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/sorta.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,341 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine SORTA(BUFS,INDS,ISAB,BUFBI,BIAC,BICA,NINTGR) +! SORTS INTEGRALS (AB/CI) +! FOR FIXED B,I ALL A,C +! FIRST CHAIN FOR IJKL + +use mrci_global, only: IADABCI, ICH, IFIRST, INDSRT, IPRINT, IROW, ISMAX, KBUFF1, LASTAD, Lu_60, Lu_70, LUSYMB, LUTRA, LN, MCHAIN, & + NBITM1, NCHN1, NORB, NSM, NSRTMX, NSYM, NTIBUF, NVIRT, NVPAIR, TIBUF, VALSRT +use guga_util_global, only: COP, IAD10, ICOP1, nCOP +use Symmetry_Info, only: Mul +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +real(kind=wp), intent(out) :: BUFS(NBITM1,NCHN1), BUFBI(KBUFF1), BIAC(ISMAX), BICA(ISMAX) +integer(kind=iwp), intent(out) :: INDS(NBITM1+2,NCHN1), NINTGR +integer(kind=iwp), intent(in) :: ISAB(*) +#include "tratoc.fh" +#include "warnings.h" +integer(kind=iwp) :: I, IACS, IAD15, IAD50, IADD10, IADR, IBUFIJ, ICHK, IDISK, IIJ, IIN, IJ, IJKL, ILEN, ILOOP, INB, INND, INS, & + INSB, INSOUT, INUMB, IOUT, IPOS, ISRTAD, IST, JDISK, KK, KL, LENGTH, M, NA, NAT, NB, NC, NI, NIB, NJ, NK, NL, & + NOP, NOQ, NOR, NORB0(9), NORBP, NOS, NSAVE, NSIB, NSP, NSPQ, NSPQR, NSQ, NSR, NSRTCN, NSS, NSSM, NT, NTM, NU, & + NUMAX, NUMIN, NV, NX, NXM +real(kind=wp) :: FINI +logical(kind=iwp) :: Skip + +call COUNT_MRCI(NINTGR,NSYM,NORB,MUL) +if (IPRINT >= 6) write(u6,1234) NINTGR + +IAD50 = 0 +call iDAFILE(LUTRA,2,iTraToc,nTraToc,IAD50) + +IDISK = 0 +ICHK = 0 +INDS(NBITM1+1,:) = 0 +INDS(NBITM1+2,:) = -1 +NORB0(1) = 0 +do I=1,NSYM + NORB0(I+1) = NORB0(I)+NORB(I) +end do + +! TWO-ELECTRON INTEGRALS + +do NSP=1,NSYM + NOP = NORB(NSP) + do NSQ=1,NSP + NSPQ = MUL(NSP,NSQ) + NOQ = NORB(NSQ) + do NSR=1,NSP + NSPQR = MUL(NSPQ,NSR) + NOR = NORB(NSR) + NSSM = NSR + if (NSR == NSP) NSSM = NSQ + do NSS=1,NSSM + if (NSS /= NSPQR) cycle + NOS = NORB(NSS) + NORBP = NOP*NOQ*NOR*NOS + if (NORBP == 0) cycle + call dDAFILE(LUTRA,2,TIBUF,NTIBUF,IAD50) + IOUT = 0 + do NV=1,NOR + NXM = NOS + if (NSR == NSS) NXM = NV + do NX=1,NXM + NTM = 1 + if (NSP == NSR) NTM = NV + do NT=NTM,NOP + NUMIN = 1 + if ((NSP == NSR) .and. (NT == NV)) NUMIN = NX + NUMAX = NOQ + if (NSP == NSQ) NUMAX = NT + do NU=NUMIN,NUMAX + IOUT = IOUT+1 + if (IOUT > NTIBUF) then + call dDAFILE(LUTRA,2,TIBUF,NTIBUF,IAD50) + IOUT = 1 + end if + FINI = TIBUF(IOUT) + NI = ICH(NORB0(NSP)+NT) + if (NI <= 0) cycle + NJ = ICH(NORB0(NSQ)+NU) + if (NJ <= 0) cycle + NK = ICH(NORB0(NSR)+NV) + if (NK <= 0) cycle + NL = ICH(NORB0(NSS)+NX) + if (NL <= 0) cycle + ! ORDER THESE INDICES CANONICALLY + if (NI < NJ) then + M = NI + NI = NJ + NJ = M + end if + if (NK < NL) then + M = NK + NK = NL + NL = M + end if + if (NI < NK) then + M = NK + NK = NI + NI = M + M = NL + NL = NJ + NJ = M + else if ((NI == NK) .and. (NJ < NL)) then + M = NL + NL = NJ + NJ = M + end if + if (NI > LN) then + if (NK <= LN) cycle + if (IFIRST /= 0) cycle + if (NJ > LN) then + if (NL > LN) cycle + ! ABCI + NA = NI-LN + NB = NJ-LN + NC = NK-LN + NI = NL + else + if (NL <= LN) cycle + ! CIAB + NA = NK-LN + NB = NL-LN + NC = NI-LN + NI = NJ + end if + NIB = (NI-1)*NVIRT+NB+1 + IPOS = INDS(NBITM1+1,NIB)+1 + INDS(NBITM1+1,NIB) = IPOS + BUFS(IPOS,NIB) = FINI + INDS(IPOS,NIB) = (NA-1)*NVIRT+NC + if (IPOS >= NBITM1) then + JDISK = IDISK + call iDAFILE(Lu_60,1,INDS(:,NIB),NBITM1+2,IDISK) + call dDAFILE(Lu_60,1,BUFS(:,NIB),NBITM1,IDISK) + INDS(NBITM1+1,NIB) = 0 + INDS(NBITM1+2,NIB) = JDISK + end if + if (NA /= NB) then + NAT = NA + NA = NB + NB = NAT + NIB = (NI-1)*NVIRT+NB+1 + IPOS = INDS(NBITM1+1,NIB)+1 + INDS(NBITM1+1,NIB) = IPOS + BUFS(IPOS,NIB) = FINI + INDS(IPOS,NIB) = (NA-1)*NVIRT+NC + if (IPOS >= NBITM1) then + JDISK = IDISK + call iDAFILE(Lu_60,1,INDS(:,NIB),NBITM1+2,IDISK) + call dDAFILE(Lu_60,1,BUFS(:,NIB),NBITM1,IDISK) + INDS(NBITM1+1,NIB) = 0 + INDS(NBITM1+2,NIB) = JDISK + end if + end if + else + ! IJKL + IIJ = IROW(NI)+NJ + KL = IROW(NK)+NL + IJKL = IIJ*(IIJ-1)/2+KL + IJ = 1 + IPOS = INDS(NBITM1+1,IJ)+1 + INDS(NBITM1+1,IJ) = IPOS + BUFS(IPOS,IJ) = FINI + INDS(IPOS,IJ) = IJKL + if (IPOS == NBITM1) then + JDISK = IDISK + call iDAFILE(Lu_60,1,INDS(:,IJ),NBITM1+2,IDISK) + call dDAFILE(Lu_60,1,BUFS(:,IJ),NBITM1,IDISK) + INDS(NBITM1+1,IJ) = 0 + INDS(NBITM1+2,IJ) = JDISK + end if + end if + end do + end do + end do + end do + end do + end do + end do +end do +! EMPTY LAST BUFFERS +if (NCHN1 > MCHAIN) then + write(u6,*) 'SORTA Error: NCHN1 > MCHAIN (See code).' + call QUIT(_RC_GENERAL_ERROR_) +end if +do I=1,NCHN1 + JDISK = IDISK + call iDAFILE(Lu_60,1,INDS(:,I),NBITM1+2,IDISK) + call dDAFILE(Lu_60,1,BUFS(:,I),NBITM1,IDISK) + LASTAD(I) = JDISK +end do +! IJKL +IDISK = 0 +IBUFIJ = 0 +ISRTAD = -1 +IADR = LASTAD(1) +do + call iDAFILE(Lu_60,2,INDS,NBITM1+2,IADR) + call dDAFILE(Lu_60,2,BUFS,NBITM1,IADR) + LENGTH = INDS(NBITM1+1,1) + IADR = INDS(NBITM1+2,1) + do I=1,LENGTH + IBUFIJ = IBUFIJ+1 + VALSRT(IBUFIJ) = BUFS(I,1) + INDSRT(IBUFIJ) = INDS(I,1) + if (IBUFIJ < NSRTMX) cycle + NSRTCN = NSRTMX + JDISK = IDISK + + INDSRT(NSRTMX+1) = NSRTCN + INDSRT(NSRTMX+2) = ISRTAD + call dDAFILE(Lu_70,1,VALSRT,NSRTMX,IDISK) + call iDAFILE(Lu_70,1,INDSRT,NSRTMX+2,IDISK) + + ISRTAD = JDISK + IBUFIJ = 0 + end do + if (IADR == -1) exit +end do +! EMPTY LAST BUFFER +NSRTCN = IBUFIJ +JDISK = IDISK +! +INDSRT(NSRTMX+1) = NSRTCN +INDSRT(NSRTMX+2) = ISRTAD +call dDAFILE(Lu_70,1,VALSRT,NSRTMX,IDISK) +call iDAFILE(Lu_70,1,INDSRT,NSRTMX+2,IDISK) + +LASTAD(1) = JDISK +! ABCI +IAD15 = IDISK +IADABCI = IAD15 +INSOUT = 0 +IADD10 = IAD10(4) +call dDAFILE(LUSYMB,2,COP,nCOP,IADD10) +call iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) +ILEN = ICOP1(nCOP+1) +IIN = 2 +NSAVE = ICOP1(IIN) +do + NI = NSAVE + IOUT = 0 + Skip = .false. + do + IIN = IIN+1 + if (IIN > ILEN) then + call dDAFILE(LUSYMB,2,COP,nCOP,IADD10) + call iDAFILE(LUSYMB,2,iCOP1,nCOP+1,IADD10) + ILEN = ICOP1(nCOP+1) + if (ILEN <= 0) then + Skip = .true. + exit + end if + IIN = 1 + end if + if (ICHK /= 0) exit + if (ICOP1(IIN) == 0) then + ICHK = 1 + else + IOUT = IOUT+1 + end if + end do + if (.not. Skip) then + ICHK = 0 + NSAVE = ICOP1(IIN) + end if + NIB = 1+(NI-1)*NVIRT + ! LOOP OVER VIRTUAL ORBITAL INDEX B: + do NB=1,NVIRT + NSIB = MUL(NSM(LN+NB),NSM(NI)) + INS = NVPAIR(NSIB) + if (INS /= 0) then + BIAC(1:INS) = Zero + BICA(1:INS) = Zero + end if + NIB = NIB+1 + ! READ & PROCESS INTEGRAL BUFFERS ON UNIT 14: + IADR = LASTAD(NIB) + do + call iDAFILE(Lu_60,2,INDS,NBITM1+2,IADR) + call dDAFILE(Lu_60,2,BUFS,NBITM1,IADR) + LENGTH = INDS(NBITM1+1,1) + IADR = INDS(NBITM1+2,1) + do KK=1,LENGTH + INND = INDS(KK,1) + NA = (INND-1)/NVIRT+1 + NC = INND-(NA-1)*NVIRT + IACS = ISAB(NA+(NC-1)*NVIRT) + BIAC(IACS) = BIAC(IACS)+BUFS(KK,1) + if (NA > NC) BICA(IACS) = BICA(IACS)-BUFS(KK,1) + if (NA < NC) BICA(IACS) = BICA(IACS)+BUFS(KK,1) + end do + if (IADR == -1) exit + end do + do ILOOP=0,1 + INSB = INS + do + INB = KBUFF1-INSOUT + INUMB = INSB + if (INSB > INB) INUMB = INB + IST = INS-INSB+1 + if (ILOOP == 0) call DCOPY_(INUMB,BIAC(IST),1,BUFBI(INSOUT+1),1) + if (ILOOP == 1) call DCOPY_(INUMB,BICA(IST),1,BUFBI(INSOUT+1),1) + INSOUT = INSOUT+INUMB + if (INSOUT > KBUFF1) then + write(u6,*) 'SortA: INSOUT > KBUFF1' + write(u6,*) 'INSOUT=',INSOUT + write(u6,*) 'KBUFF1=',KBUFF1 + call ABEND() + end if + if (INSOUT == KBUFF1) then + call dDAFILE(Lu_70,1,BUFBI,KBUFF1,IAD15) + INSOUT = 0 + end if + INSB = INSB-INUMB + if (INSB <= 0) exit + end do + end do + end do + if (ILEN < 0) exit +end do +! EMPTY LAST BUFFER IF NOT EMPTY +if (INSOUT > 0) call dDAFILE(Lu_70,1,BUFBI,KBUFF1,IAD15) + +return + +1234 format(//6X,'NUMBER OF TWO-ELECTRON INTEGRALS',I10) + +end subroutine SORTA diff -Nru openmolcas-22.02/src/mrci/sortb.f openmolcas-22.10/src/mrci/sortb.f --- openmolcas-22.02/src/mrci/sortb.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/sortb.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,286 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -* SUBROUTINE SORTB(BUFOUT,INDOUT,ACBDS,ACBDT,ISAB,BFACBD,NINTGR) - SUBROUTINE SORTB(BUFS,INDS,ACBDS,ACBDT,ISAB,BFACBD,NINTGR) - IMPLICIT REAL*8 (A-H,O-Z) -#include "SysDef.fh" -#include "warnings.h" -#include "mrci.fh" -c DIMENSION BUFOUT(NBSIZ2,NCHN2) -*PAM04 DIMENSION BUFOUT(*) - DIMENSION BUFS(NBITM2,NCHN2) -c DIMENSION INDOUT(RTOI*NBSIZ2,NCHN2) -*PAM04 DIMENSION INDOUT(*) - DIMENSION INDS(NBITM2+2,NCHN2) - DIMENSION ACBDS(*),ACBDT(*), BFACBD(*) -c DIMENSION ISAB(NVIRT,NVIRT) - DIMENSION ISAB(*) -C SORTS INTEGRALS (AB/CD) -C FOR FIXED A,C ALL B,D - DIMENSION NORB0(9) - - NVT=IROW(NVIRT+1) - NOVST=LN*NVIRT+1 - IAD16=0 - -*PAM04C Buffer layout: -*PAM04 IBOFF2=RTOI*NBITM2 -*PAM04 IBBC2=IBOFF2+NBITM2+1 -*PAM04 IBDA2=IBBC2+1 - - NORB0(1)=0 - DO I=1,NSYM - NORB0(I+1)=NORB0(I)+NORB(I) - END DO - - INSOUT=0 - IACMAX=0 - DO 50 ISTEP=1,IPASS - IAD50=0 - CALL iDAFILE(LUTRA,2,iTraToc,nTraToc,IAD50) - IDISK=0 - IACMIN=IACMAX+1 - IACMAX=IACMAX+NCHN2 - IF(IACMAX.GT.NVT)IACMAX=NVT - IF(IACMIN.GT.IACMAX)GO TO 50 - -C Initialize Buffer Counts and BackChain Links. - DO IREC=1,NCHN2 -*PAM04 INDOUT(IBBC2+(IREC-1)*RTOI*NBSIZ2)=0 -*PAM04 INDOUT(IBDA2+(IREC-1)*RTOI*NBSIZ2)=-1 - INDS(NBITM2+1,IREC)=0 - INDS(NBITM2+2,IREC)=-1 - END DO - -C Loop over symmetry blocks of all-virtual integrals. - DO 313 NSP=1,NSYM - NOP=NORB(NSP) - DO 312 NSQ=1,NSP - NSPQ=MUL(NSP,NSQ) - NOQ=NORB(NSQ) - DO 311 NSR=1,NSP - NSPQR=MUL(NSPQ,NSR) - NOR=NORB(NSR) - NSSM=NSR - IF(NSR.EQ.NSP)NSSM=NSQ - DO 310 NSS=1,NSSM - IF(NSS.NE.NSPQR)GO TO 310 - NOS=NORB(NSS) - NORBP=NOP*NOQ*NOR*NOS - IF(NORBP.EQ.0)GO TO 310 - - CALL dDAFILE(LUTRA,2,TIBUF,NTIBUF,IAD50) - -C Loop over index quadruples in this symm block - IOUT=0 - DO 309 NV=1,NOR - NXM=NOS - IF(NSR.EQ.NSS)NXM=NV - DO 308 NX=1,NXM - NTM=1 - IF(NSP.EQ.NSR)NTM=NV - DO 307 NT=NTM,NOP - NUMIN=1 - IF(NSP.EQ.NSR.AND.NT.EQ.NV)NUMIN=NX - NUMAX=NOQ - IF(NSP.EQ.NSQ)NUMAX=NT - DO 306 NU=NUMIN,NUMAX - -C MO integral value is made accessable at TIBUF(IOUT) - IOUT=IOUT+1 - IF(IOUT.GT.NTIBUF) THEN - CALL dDAFILE(LUTRA,2,TIBUF,NTIBUF,IAD50) - IOUT=1 - END IF - -C M1..M4 seqential number of orbitals. - M1=ICH(NORB0(NSP)+NT) - M2=ICH(NORB0(NSQ)+NU) - M3=ICH(NORB0(NSR)+NV) - M4=ICH(NORB0(NSS)+NX) - IF(M1.LE.LN.OR.M2.LE.LN)GO TO 306 - IF(M3.LE.LN.OR.M4.LE.LN)GO TO 306 - -C Permute orbital indices to canonical order -C and put integral value in FINI - N1=M1 - N2=M2 - IF(M1.GT.M2)GO TO 11 - N1=M2 - N2=M1 -11 N3=M3 - N4=M4 - IF(M3.GT.M4)GO TO 12 - N3=M4 - N4=M3 -12 NI=N1 - NJ=N2 - NK=N3 - NL=N4 - IF(NI.GT.NK)GO TO 502 - IF(NI.EQ.NK)GO TO 14 - NI=N3 - NJ=N4 - NK=N1 - NL=N2 - GO TO 502 -14 IF(NJ.GT.NL)GO TO 502 - NL=N2 - NJ=N4 -502 FINI=TIBUF(IOUT) - -C Compute virtual indices. - NA=NI-LN - NB=NJ-LN - NC=NK-LN - ND=NL-LN - ITURN=0 - IF(NA.EQ.NB.AND.NC.EQ.ND)GO TO 306 -107 IAC=IROW(NA)+NC - IF(IAC.LT.IACMIN)GO TO 106 - IF(IAC.GT.IACMAX)GO TO 106 - IF(NA.EQ.NC.AND.NB.EQ.ND)FINI=FINI/2 - NAC=IAC-IACMIN+1 -*PAM04 IPOS=INDOUT(IBBC2+(NAC-1)*RTOI*NBSIZ2)+1 -*PAM04 INDOUT(IBBC2+(NAC-1)*RTOI*NBSIZ2)=IPOS - IPOS=INDS(NBITM2+1,NAC)+1 - INDS(NBITM2+1,NAC)=IPOS -*PAM04 BUFOUT(IPOS+(NAC-1)*NBSIZ2)=FINI -*PAM04 INDOUT(IBOFF2+IPOS+(NAC-1)*RTOI*NBSIZ2)=NB+2**8*ND - INDS(IPOS,NAC)=NB+2**8*ND - BUFS(IPOS,NAC)=FINI - IF(IPOS.LT.NBITM2)GO TO 106 -C Save this buffer if filled up. - JDISK=IDISK -*PAM04 CALL dDAFILE(Lu_60,1,INDOUT(1+(NAC-1)*RTOI*NBSIZ2),NBSIZ2,IDISK) - CALL iDAFILE(Lu_60,1,INDS(1,NAC),NBITM2+2,IDISK) - CALL dDAFILE(Lu_60,1,BUFS(1,NAC),NBITM2,IDISK) -*PAM04 INDOUT(IBBC2+(NAC-1)*RTOI*NBSIZ2)=0 -*PAM04 INDOUT(IBDA2+(NAC-1)*RTOI*NBSIZ2)=JDISK - INDS(NBITM2+1,NAC)=0 - INDS(NBITM2+2,NAC)=JDISK - -106 IF(ITURN.EQ.1)GO TO 306 - IF(NA.EQ.NC.AND.NB.EQ.ND)GO TO 306 - IF(NA.EQ.NB.OR.NC.EQ.ND)GO TO 306 - ITURN=1 - NC=NL-LN - ND=NK-LN - GO TO 107 -306 CONTINUE -307 CONTINUE -308 CONTINUE -309 CONTINUE -310 CONTINUE -311 CONTINUE -312 CONTINUE -313 CONTINUE -C EMPTY LAST BUFFERS - NOVM=IACMAX-IACMIN+1 - If ( (NOVST+IACMIN-1+NOVM).gt.mChain ) then - WRITE(6,*)'SORTB Error: NOVST+IACMIN-1+NOVM > MCHAIN' - WRITE(6,*)'NOVST =',NOVST - WRITE(6,*)'IACMIN=',IACMIN - WRITE(6,*)'NOVM =',NOVM - WRITE(6,*)'MCHAIN=',MCHAIN - WRITE(6,*)' (See code).' - CALL QUIT(_RC_GENERAL_ERROR_) - End If - DO 150 I=1,NOVM - JDISK=IDISK -*PAM04 CALL dDAFILE(Lu_60,1,INDOUT(1+(I-1)*RTOI*NBSIZ2),NBSIZ2,IDISK) - CALL iDAFILE(Lu_60,1,INDS(1,I),NBITM2+2,IDISK) - CALL dDAFILE(Lu_60,1,BUFS(1,I),NBITM2,IDISK) - LASTAD(NOVST+IACMIN-1+I)=JDISK -150 CONTINUE - DO 40 ISYM=1,NSYM - IST1=IRC(3)+JJS(ISYM+9)+1 - IFIN1=IRC(3)+JJS(ISYM+10) - INPS=IFIN1-IST1+1 - IST2=IRC(2)+JJS(ISYM)+1 - IFIN2=IRC(2)+JJS(ISYM+1) - INPT=IFIN2-IST2+1 - ITAIL=INPS+INPT - IF(ITAIL.EQ.0)GO TO 40 - IN1=-NVIRT - DO 55 NA=1,NVIRT - IN1=IN1+NVIRT - DO 60 NC=1,NA - IAC=IROW(NA)+NC - IF(IAC.LT.IACMIN)GO TO 60 - IF(IAC.GT.IACMAX)GO TO 60 - IF(NA.EQ.1)GO TO 60 - NSAC=MUL(NSM(LN+NA),NSM(LN+NC)) - NSACL=MUL(NSAC,LSYM) - IF(NSACL.NE.ISYM)GO TO 60 - NSC=NSM(LN+NC) - NDMAX=NVIRP(NSC)+NVIR(NSC) - IF(NDMAX.GT.NA)NDMAX=NA - INS=ISAB(NA+(NDMAX-1)*NVIRT) - CALL FZERO(ACBDS,INS) - CALL FZERO(ACBDT,INS) - IADR=LASTAD(NOVST+IAC) -201 CONTINUE -*PAM04 CALL dDAFILE(Lu_60,2,INDOUT,NBSIZ2,IADR) - CALL iDAFILE(Lu_60,2,INDS,NBITM2+2,IADR) - CALL dDAFILE(Lu_60,2,BUFS,NBITM2,IADR) -*PAM04 LENGTH=INDOUT(IBBC2) -*PAM04 IADR=INDOUT(IBDA2) - LENGTH=INDS(NBITM2+1,1) - IADR=INDS(NBITM2+2,1) - IF(LENGTH.EQ.0)GO TO 209 - DO 202 KK=1,LENGTH -*PAM04 INND=INDOUT(IBOFF2+KK) - INND=INDS(KK,1) -CPAM96 NB=IAND(INND,255) -CPAM96 ND=IAND(ISHFT(INND,-8),255) -* NB=MOD(INND,2**8) -* ND=MOD(INND/2**8,2**8) - NB=IBITS(INND, 0,8) - ND=IBITS(INND, 8,8) - - IBDS=ISAB(NB+(ND-1)*NVIRT) -*PAM04 ACBDS(IBDS)=ACBDS(IBDS)+BUFOUT(KK) -*PAM04 IF(NB.GT.ND)ACBDT(IBDS)=ACBDT(IBDS)+BUFOUT(KK) -*PAM04 IF(NB.LT.ND)ACBDT(IBDS)=ACBDT(IBDS)-BUFOUT(KK) - ACBDS(IBDS)=ACBDS(IBDS)+BUFS(KK,1) - IF(NB.GT.ND)ACBDT(IBDS)=ACBDT(IBDS)+BUFS(KK,1) - IF(NB.LT.ND)ACBDT(IBDS)=ACBDT(IBDS)-BUFS(KK,1) -202 CONTINUE -209 IF(IADR.NE.-1) GO TO 201 - ILOOP=0 -72 INSB=INS -73 INB=KBUFF1-INSOUT - INUMB=INSB - IF(INSB.GT.INB)INUMB=INB - IST=INS-INSB+1 - IF(ILOOP.EQ.0) - * CALL DCOPY_(INUMB,ACBDS(IST),1,BFACBD(INSOUT+1),1) - IF(ILOOP.EQ.1) - * CALL DCOPY_(INUMB,ACBDT(IST),1,BFACBD(INSOUT+1),1) - INSOUT=INSOUT+INUMB - IF(INSOUT.LT.KBUFF1)GO TO 75 - CALL dDAFILE(Lu_80,1,BFACBD,KBUFF1,IAD16) - INSOUT=0 -75 INSB=INSB-INUMB - IF(INSB.GT.0)GO TO 73 - ILOOP=ILOOP+1 - IF(ILOOP.EQ.1)GO TO 72 -60 CONTINUE -55 CONTINUE -40 CONTINUE -50 CONTINUE -C EMPTY LAST BUFFER - IF(INSOUT.NE.0) CALL dDAFILE(Lu_80,1,BFACBD,KBUFF1,IAD16) - RETURN -c Avoid unused argument warnings - IF (.FALSE.) CALL Unused_integer(NINTGR) - END diff -Nru openmolcas-22.02/src/mrci/sortb.F90 openmolcas-22.10/src/mrci/sortb.F90 --- openmolcas-22.02/src/mrci/sortb.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/sortb.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,266 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine SORTB(BUFS,INDS,ACBDS,ACBDT,ISAB,BFACBD) +! SORTS INTEGRALS (AB/CD) +! FOR FIXED A,C ALL B,D + +use mrci_global, only: ICH, IPASS, IRC, IROW, JJS, KBUFF1, LASTAD, LN, LSYM, Lu_60, Lu_80, LUTRA, MCHAIN, NBITM2, NCHN2, NORB, & + NSM, NSYM, NTIBUF, NVIR, NVIRP, NVIRT, TIBUF +use Symmetry_Info, only: Mul +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +real(kind=wp), intent(out) :: BUFS(NBITM2,NCHN2) +integer(kind=iwp), intent(out) :: INDS(NBITM2+2,NCHN2) +real(kind=wp), intent(_OUT_) :: ACBDS(*), ACBDT(*), BFACBD(*) +integer(kind=iwp), intent(in) :: ISAB(*) +#include "tratoc.fh" +#include "warnings.h" +integer(kind=iwp) :: I, IAC, IACMAX, IACMIN, IAD16, IAD50, IADR, IBDS, IDISK, IFIN1, IFIN2, ILOOP, IN1, INB, INND, INPS, INPT, & + INS, INSB, INSOUT, INUMB, IOUT, IPOS, IST, IST1, IST2, ISTEP, ISYM, ITAIL, ITURN, JDISK, KK, LENGTH, M1, M2, & + M3, M4, N1, N2, N3, N4, NA, NAC, NB, NC, ND, NDMAX, NI, NJ, NK, NL, NOP, NOQ, NOR, NORB0(9), NORBP, NOS, & + NOVM, NOVST, NSAC, NSACL, NSC, NSP, NSPQ, NSPQR, NSQ, NSR, NSS, NSSM, NT, NTM, NU, NUMAX, NUMIN, NV, NVT, NX, & + NXM +real(kind=wp) :: FINI + +NVT = IROW(NVIRT+1) +NOVST = LN*NVIRT+1 +IAD16 = 0 + +NORB0(1) = 0 +do I=1,NSYM + NORB0(I+1) = NORB0(I)+NORB(I) +end do + +INSOUT = 0 +IACMAX = 0 +do ISTEP=1,IPASS + IAD50 = 0 + call iDAFILE(LUTRA,2,iTraToc,nTraToc,IAD50) + IDISK = 0 + IACMIN = IACMAX+1 + IACMAX = IACMAX+NCHN2 + if (IACMAX > NVT) IACMAX = NVT + if (IACMIN > IACMAX) cycle + + ! Initialize Buffer Counts and BackChain Links. + INDS(NBITM2+1,:) = 0 + INDS(NBITM2+2,:) = -1 + + ! Loop over symmetry blocks of all-virtual integrals. + do NSP=1,NSYM + NOP = NORB(NSP) + do NSQ=1,NSP + NSPQ = MUL(NSP,NSQ) + NOQ = NORB(NSQ) + do NSR=1,NSP + NSPQR = MUL(NSPQ,NSR) + NOR = NORB(NSR) + NSSM = NSR + if (NSR == NSP) NSSM = NSQ + do NSS=1,NSSM + if (NSS /= NSPQR) cycle + NOS = NORB(NSS) + NORBP = NOP*NOQ*NOR*NOS + if (NORBP == 0) cycle + + call dDAFILE(LUTRA,2,TIBUF,NTIBUF,IAD50) + + ! Loop over index quadruples in this symm block + IOUT = 0 + do NV=1,NOR + NXM = NOS + if (NSR == NSS) NXM = NV + do NX=1,NXM + NTM = 1 + if (NSP == NSR) NTM = NV + do NT=NTM,NOP + NUMIN = 1 + if ((NSP == NSR) .and. (NT == NV)) NUMIN = NX + NUMAX = NOQ + if (NSP == NSQ) NUMAX = NT + do NU=NUMIN,NUMAX + + ! MO integral value is made accessable at TIBUF(IOUT) + IOUT = IOUT+1 + if (IOUT > NTIBUF) then + call dDAFILE(LUTRA,2,TIBUF,NTIBUF,IAD50) + IOUT = 1 + end if + + ! M1..M4 seqential number of orbitals. + M1 = ICH(NORB0(NSP)+NT) + M2 = ICH(NORB0(NSQ)+NU) + M3 = ICH(NORB0(NSR)+NV) + M4 = ICH(NORB0(NSS)+NX) + if ((M1 <= LN) .or. (M2 <= LN)) cycle + if ((M3 <= LN) .or. (M4 <= LN)) cycle + + ! Permute orbital indices to canonical order + ! and put integral value in FINI + N1 = max(M1,M2) + N2 = min(M1,M2) + N3 = max(M3,M4) + N4 = min(M3,M4) + NI = N1 + NJ = N2 + NK = N3 + NL = N4 + if (NI <= NK) then + if (NI /= NK) then + NI = N3 + NJ = N4 + NK = N1 + NL = N2 + else if (NJ > NL) then + NL = N2 + NJ = N4 + end if + end if + FINI = TIBUF(IOUT) + + ! Compute virtual indices. + NA = NI-LN + NB = NJ-LN + NC = NK-LN + ND = NL-LN + ITURN = 0 + if ((NA == NB) .and. (NC == ND)) cycle + do + IAC = IROW(NA)+NC + if ((IAC >= IACMIN) .and. (IAC <= IACMAX)) then + if ((NA == NC) .and. (NB == ND)) FINI = FINI/2 + NAC = IAC-IACMIN+1 + IPOS = INDS(NBITM2+1,NAC)+1 + INDS(NBITM2+1,NAC) = IPOS + INDS(IPOS,NAC) = NB+2**8*ND + BUFS(IPOS,NAC) = FINI + if (IPOS >= NBITM2) then + ! Save this buffer if filled up. + JDISK = IDISK + call iDAFILE(Lu_60,1,INDS(1,NAC),NBITM2+2,IDISK) + call dDAFILE(Lu_60,1,BUFS(1,NAC),NBITM2,IDISK) + INDS(NBITM2+1,NAC) = 0 + INDS(NBITM2+2,NAC) = JDISK + end if + end if + + if (ITURN == 1) exit + if ((NA == NC) .and. (NB == ND)) exit + if ((NA == NB) .or. (NC == ND)) exit + ITURN = 1 + NC = NL-LN + ND = NK-LN + end do + end do + end do + end do + end do + end do + end do + end do + end do + ! EMPTY LAST BUFFERS + NOVM = IACMAX-IACMIN+1 + if ((NOVST+IACMIN-1+NOVM) > MCHAIN) then + write(u6,*) 'SORTB Error: NOVST+IACMIN-1+NOVM > MCHAIN' + write(u6,*) 'NOVST =',NOVST + write(u6,*) 'IACMIN=',IACMIN + write(u6,*) 'NOVM =',NOVM + write(u6,*) 'MCHAIN=',MCHAIN + write(u6,*) ' (See code).' + call QUIT(_RC_GENERAL_ERROR_) + end if + do I=1,NOVM + JDISK = IDISK + call iDAFILE(Lu_60,1,INDS(1,I),NBITM2+2,IDISK) + call dDAFILE(Lu_60,1,BUFS(1,I),NBITM2,IDISK) + LASTAD(NOVST+IACMIN-1+I) = JDISK + end do + do ISYM=1,NSYM + IST1 = IRC(3)+JJS(ISYM+9)+1 + IFIN1 = IRC(3)+JJS(ISYM+10) + INPS = IFIN1-IST1+1 + IST2 = IRC(2)+JJS(ISYM)+1 + IFIN2 = IRC(2)+JJS(ISYM+1) + INPT = IFIN2-IST2+1 + ITAIL = INPS+INPT + if (ITAIL == 0) cycle + IN1 = -NVIRT + do NA=1,NVIRT + IN1 = IN1+NVIRT + do NC=1,NA + IAC = IROW(NA)+NC + if (IAC < IACMIN) cycle + if (IAC > IACMAX) cycle + if (NA == 1) cycle + NSAC = MUL(NSM(LN+NA),NSM(LN+NC)) + NSACL = MUL(NSAC,LSYM) + if (NSACL /= ISYM) cycle + NSC = NSM(LN+NC) + NDMAX = NVIRP(NSC)+NVIR(NSC) + if (NDMAX > NA) NDMAX = NA + INS = ISAB(NA+(NDMAX-1)*NVIRT) + ACBDS(1:INS) = Zero + ACBDT(1:INS) = Zero + IADR = LASTAD(NOVST+IAC) + do + call iDAFILE(Lu_60,2,INDS,NBITM2+2,IADR) + call dDAFILE(Lu_60,2,BUFS,NBITM2,IADR) + LENGTH = INDS(NBITM2+1,1) + IADR = INDS(NBITM2+2,1) + do KK=1,LENGTH + INND = INDS(KK,1) + NB = ibits(INND,0,8) + ND = ibits(INND,8,8) + + IBDS = ISAB(NB+(ND-1)*NVIRT) + ACBDS(IBDS) = ACBDS(IBDS)+BUFS(KK,1) + if (NB > ND) ACBDT(IBDS) = ACBDT(IBDS)+BUFS(KK,1) + if (NB < ND) ACBDT(IBDS) = ACBDT(IBDS)-BUFS(KK,1) + end do + if (IADR == -1) exit + end do + ILOOP = 0 + do + INSB = INS + do + INB = KBUFF1-INSOUT + INUMB = INSB + if (INSB > INB) INUMB = INB + IST = INS-INSB+1 + if (ILOOP == 0) call DCOPY_(INUMB,ACBDS(IST),1,BFACBD(INSOUT+1),1) + if (ILOOP == 1) call DCOPY_(INUMB,ACBDT(IST),1,BFACBD(INSOUT+1),1) + INSOUT = INSOUT+INUMB + if (INSOUT >= KBUFF1) then + call dDAFILE(Lu_80,1,BFACBD,KBUFF1,IAD16) + INSOUT = 0 + end if + INSB = INSB-INUMB + if (INSB <= 0) exit + end do + ILOOP = ILOOP+1 + if (ILOOP /= 1) exit + end do + end do + end do + end do +end do +! EMPTY LAST BUFFER +if (INSOUT /= 0) call dDAFILE(Lu_80,1,BFACBD,KBUFF1,IAD16) + +return + +end subroutine SORTB diff -Nru openmolcas-22.02/src/mrci/sort.f openmolcas-22.10/src/mrci/sort.f --- openmolcas-22.02/src/mrci/sort.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/sort.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,333 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -*PAM04 SUBROUTINE SORT (BUFOUT,INDOUT,FC,FIIJJ,FIJIJ,NINTGR) - SUBROUTINE SORT_MRCI (BUFS,INDS,FC,FIIJJ,FIJIJ,NINTGR) - IMPLICIT REAL*8 (A-H,O-Z) - INTRINSIC ABS,LOG10 -#include "SysDef.fh" -#include "warnings.h" -#include "mrci.fh" -c DIMENSION BUFOUT(NBSIZ3,NCHN3) -c DIMENSION INDOUT(RTOI*NBSIZ3,NCHN3) -*PAM04 DIMENSION BUFOUT(*) -*PAM04 DIMENSION INDOUT(*) - DIMENSION BUFS(NBITM3,NCHN3) - DIMENSION INDS(NBITM3+2,NCHN3) - DIMENSION FC(NBTRI),FIIJJ(*),FIJIJ(*) - DIMENSION IVEC(20),IPOF(65) - DIMENSION NORB0(9) - IAD50=0 - CALL iDAFILE(LUTRA,2,iTraToc,nTraToc,IAD50) - NVT=IROW(NVIRT+1) - DO 50 I=1,20 - IVEC(I)=0 -50 CONTINUE - IN=1 - DO 3 I=1,NSYM - CALL IPO(IPOF(IN),NVIR,MUL,NSYM,I,-1) - IN=IN+NSYM -3 CONTINUE -C ORDER OF RECORD-CHAINS IS -C 1. NOT2 CHAINS (AB/IJ) -C 2. NOT2 CHAINS (AI/BJ) -C 3. NOT2 CHAINS (AI/JK) -C RECORD STRUCTURE IS -C 1. NBITM3 INTEGRALS -C 2. NBITM3 INDICES -C 3. NUMBER OF INTEGRALS IN THIS RECORD -C 4. ADDRESS OF LAST RECORD - NOT2=IROW(LN+1) - NOTT=2*NOT2 - NOVST=LN*NVIRT+1+NVT - IDISK=0 -CPAM97 The portable code should then be: -*PAM04 NBITM3=(RTOI*NBSIZ3-2)/(RTOI+1) -*PAM04 IBOFF3=RTOI*NBITM3 -*PAM04 IBBC3=IBOFF3+NBITM3+1 -*PAM04 IBDA3=IBBC3+1 - - DO 5 IREC=1,NCHN3 -*PAM04 INDOUT(IBBC3+(IREC-1)*RTOI*NBSIZ3)= 0 -*PAM04 INDOUT(IBDA3+(IREC-1)*RTOI*NBSIZ3)=-1 - INDS(NBITM3+1,IREC)=0 - INDS(NBITM3+2,IREC)=-1 -5 CONTINUE - NORB0(1)=0 - DO 2 I=1,NSYM - NORB0(I+1)=NORB0(I)+NORB(I) -2 CONTINUE -C READ ONE-ELECTRON ORBITALS. USE FIIJJ TEMPORARILY AS READ BUFFER. - NORBTT=0 - DO 7654 ISYM=1,nsym - NORBTT=NORBTT+(NORB(ISYM)*(NORB(ISYM)+1))/2 - 7654 CONTINUE - EFROZ=POTNUC - CALL FZERO(FC,NBTRI) - IADD17=ITOC17(2) - CALL dDAFILE(LUONE,2,FIIJJ,NORBTT,IADD17) - IBUF=0 - KORBI=0 - DO 200 ISYM=1,NSYM - DO 199 JORBI=KORBI+1,KORBI+NORB(ISYM) - DO 198 IORBI=KORBI+1,JORBI - IBUF=IBUF+1 - ONEHAM=FIIJJ(IBUF) - NI=ICH(IORBI) - NJ=ICH(JORBI) - IF(NI.EQ.0.OR.NJ.EQ.0)GO TO 198 - IF(NI.LT.NJ) THEN - NTMP=NI - NI=NJ - NJ=NTMP - END IF - IF(NJ.GT.0) THEN - IJT=IROW(NI)+NJ - FC(IJT)=FC(IJT)+ONEHAM - ELSE IF(NI.EQ.NJ) THEN - EFROZ=EFROZ+2*ONEHAM - END IF -198 CONTINUE -199 CONTINUE - KORBI=KORBI+NORB(ISYM) -200 CONTINUE - IF(IPRINT.GE.20) THEN - CALL TRIPRT('FC IN SORT_MRCI BEFORE TWOEL',' ',FC,NORBT) - WRITE(6,'(A,F20.8)') ' EFROZ:',EFROZ - CALL XFLUSH(6) - END IF - CALL FZERO(FIIJJ,NBTRI) - CALL FZERO(FIJIJ,NBTRI) -C TWO-ELECTRON INTEGRALS - DO 313 NSP=1,NSYM - NOP=NORB(NSP) - DO 312 NSQ=1,NSP - NSPQ=MUL(NSP,NSQ) - NOQ=NORB(NSQ) - DO 311 NSR=1,NSP - NSPQR=MUL(NSPQ,NSR) - NOR=NORB(NSR) - NSSM=NSR - IF(NSR.EQ.NSP)NSSM=NSQ - DO 310 NSS=1,NSSM - IF(NSS.NE.NSPQR)GO TO 310 - NOS=NORB(NSS) - NORBP=NOP*NOQ*NOR*NOS - IF(NORBP.EQ.0)GO TO 310 - CALL dDAFILE(LUTRA,2,TIBUF,NTIBUF,IAD50) - IOUT=0 - DO 309 NV=1,NOR - NXM=NOS - IF(NSR.EQ.NSS)NXM=NV - DO 308 NX=1,NXM - NTM=1 - IF(NSP.EQ.NSR)NTM=NV - DO 307 NT=NTM,NOP - NUMIN=1 - IF(NSP.EQ.NSR.AND.NT.EQ.NV)NUMIN=NX - NUMAX=NOQ - IF(NSP.EQ.NSQ)NUMAX=NT - DO 306 NU=NUMIN,NUMAX - IOUT=IOUT+1 - IF(IOUT.GT.NTIBUF) THEN - CALL dDAFILE(LUTRA,2,TIBUF,NTIBUF,IAD50) - IOUT=1 - END IF - M1=ICH(NORB0(NSP)+NT) - M2=ICH(NORB0(NSQ)+NU) - M3=ICH(NORB0(NSR)+NV) - M4=ICH(NORB0(NSS)+NX) - IF(M1.EQ.0.OR.M2.EQ.0)GO TO 306 - IF(M3.EQ.0.OR.M4.EQ.0)GO TO 306 -C ORDER THESE INDICES CANONICALLY - N1=M1 - N2=M2 - IF(M1.GT.M2)GO TO 11 - N1=M2 - N2=M1 -11 N3=M3 - N4=M4 - IF(M3.GT.M4)GO TO 12 - N3=M4 - N4=M3 -12 NI=N1 - NJ=N2 - NK=N3 - NL=N4 - IF(NI.GT.NK)GO TO 502 - IF(NI.EQ.NK)GO TO 14 - NI=N3 - NJ=N4 - NK=N1 - NL=N2 - GO TO 502 -14 IF(NJ.GT.NL)GO TO 502 - NL=N2 - NJ=N4 -502 FINI=TIBUF(IOUT) - IF(NI.LE.0 .OR. NJ.LE.0)GO TO 41 - IF(NK.LE.0 .OR. NL.LE.0)GO TO 41 - DFINI=ABS(FINI)+1.D-20 - IEXP=INT(-LOG10(DFINI))+5 - IF(IEXP.LE.20)IVEC(IEXP)=IVEC(IEXP)+1 - IF(NI.NE.NJ.OR.NK.NE.NL)GO TO 42 - IJ=IROW(NI)+NK - FIIJJ(IJ)=FINI -C SKIP (AA/II) INTEGRALS - GO TO 306 -42 IF(NI.NE.NK.OR.NJ.NE.NL)GO TO 43 - IJ=IROW(NI)+NJ - FIJIJ(IJ)=FINI -43 IF(NI.LE.LN)GO TO 306 - IF(NJ.GT.LN)GO TO 102 - IF(NK.GT.LN)GO TO 103 -C AIJK - JK=NOTT+IROW(NK)+NL -*PAM04 IPOS=INDOUT(IBBC3+(JK-1)*RTOI*NBSIZ3)+1 -*PAM04 INDOUT(IBBC3+(JK-1)*RTOI*NBSIZ3)=IPOS - IPOS=INDS(NBITM3+1,JK)+1 - INDS(NBITM3+1,JK)=IPOS -c BUFOUT(IPOS,JK)=FINI -*PAM04 BUFOUT(IPOS+(JK-1)*NBSIZ3)=FINI - BUFS(IPOS,JK)=FINI -*PAM04 INDOUT(IBOFF3+IPOS+(JK-1)*RTOI*NBSIZ3)=IROW(NI)+NJ - INDS(IPOS,JK)=IROW(NI)+NJ - IF(IPOS.LT.NBITM3)GO TO 306 - JDISK=IDISK -*PAM04 CALL dDAFILE(Lu_60,1,INDOUT(1+(JK-1)*RTOI*NBSIZ3),NBSIZ3,IDISK) - CALL iDAFILE(Lu_60,1,INDS(1,JK),NBITM3+2,IDISK) - CALL dDAFILE(Lu_60,1,BUFS(1,JK),NBITM3,IDISK) -*PAM04 INDOUT(IBBC3+(JK-1)*RTOI*NBSIZ3)=0 -*PAM04 INDOUT(IBDA3+(JK-1)*RTOI*NBSIZ3)=JDISK - INDS(NBITM3+1,JK)=0 - INDS(NBITM3+2,JK)=JDISK - GO TO 306 -103 IF(NL.GT.LN)GO TO 306 -C AIBJ - IIJ=NOT2+IROW(NJ)+NL - IF(NL.GT.NJ)IIJ=NOT2+IROW(NL)+NJ -*PAM04 IPOS=INDOUT(IBBC3+(IIJ-1)*RTOI*NBSIZ3)+1 -*PAM04 INDOUT(IBBC3+(IIJ-1)*RTOI*NBSIZ3)=IPOS - IPOS=INDS(NBITM3+1,IIJ)+1 - INDS(NBITM3+1,IIJ)=IPOS -c BUFOUT(IPOS,IIJ)=FINI -*PAM04 BUFOUT(IPOS+(IIJ-1)*NBSIZ3)=FINI - BUFS(IPOS,IIJ)=FINI - NSA=NSM(NI) - NAV=NI-LN-NVIRP(NSA) - NSB=NSM(NK) - NBV=NK-LN-NVIRP(NSB) - NSIJT=(MUL(NSM(NJ),NSM(NL))-1)*NSYM - IF(NL.GT.NJ)GO TO 105 - INAV=IPOF(NSIJT+NSA)+(NBV-1)*NVIR(NSA)+NAV - GO TO 104 -105 INAV=IPOF(NSIJT+NSB)+(NAV-1)*NVIR(NSB)+NBV -104 CONTINUE -*PAM04 INDOUT(IPOS+IBOFF3+(IIJ-1)*RTOI*NBSIZ3)=INAV - INDS(IPOS,IIJ)=INAV - IF(IPOS.LT.NBITM3)GO TO 108 - JDISK=IDISK -*PAM04 CALL dDAFILE(Lu_60,1,INDOUT(1+(IIJ-1)*RTOI*NBSIZ3),NBSIZ3,IDISK) - CALL iDAFILE(Lu_60,1,INDS(1,IIJ),NBITM3+2,IDISK) - CALL dDAFILE(Lu_60,1,BUFS(1,IIJ),NBITM3,IDISK) -*PAM04 INDOUT(IBBC3+(IIJ-1)*RTOI*NBSIZ3)=0 -*PAM04 INDOUT(IBDA3+(IIJ-1)*RTOI*NBSIZ3)=JDISK - INDS(NBITM3+1,IIJ)=0 - INDS(NBITM3+2,IIJ)=JDISK -108 IF(NJ.NE.NL)GO TO 306 - IF(NI.EQ.NK)GO TO 306 - IKT=IROW(NI)+NK - FC(IKT)=FC(IKT)-FINI - GO TO 306 -102 IF(NK.GT.LN)GO TO 306 -C ABIJ - IIJ=IROW(NK)+NL -*PAM04 IPOS=INDOUT(IBBC3+(IIJ-1)*RTOI*NBSIZ3)+1 -*PAM04 INDOUT(IBBC3+(IIJ-1)*RTOI*NBSIZ3)=IPOS - IPOS=INDS(NBITM3+1,IIJ)+1 - INDS(NBITM3+1,IIJ)=IPOS -*PAM04 BUFOUT(IPOS+(IIJ-1)*NBSIZ3)=FINI - BUFS(IPOS,IIJ)=FINI - NSA=NSM(NI) - NAV=NI-LN-NVIRP(NSA) - NSB=NSM(NJ) - NBV=NJ-LN-NVIRP(NSB) - NSIJT=(MUL(NSM(NK),NSM(NL))-1)*NSYM - INAV=IPOF(NSIJT+NSA)+(NBV-1)*NVIR(NSA)+NAV -*PAM04 INDOUT(IBOFF3+IPOS+(IIJ-1)*RTOI*NBSIZ3)=INAV - INDS(IPOS,IIJ)=INAV - IF(IPOS.LT.NBITM3)GO TO 106 - JDISK=IDISK -*PAM04 CALL dDAFILE(Lu_60,1,INDOUT(1+(IIJ-1)*RTOI*NBSIZ3),NBSIZ3,IDISK) - CALL iDAFILE(Lu_60,1,INDS(1,IIJ),NBITM3+2,IDISK) - CALL dDAFILE(Lu_60,1,BUFS(1,IIJ),NBITM3,IDISK) -*PAM04 INDOUT(IBBC3+(IIJ-1)*RTOI*NBSIZ3)=0 -*PAM04 INDOUT(IBDA3+(IIJ-1)*RTOI*NBSIZ3)=JDISK - INDS(NBITM3+1,IIJ)=0 - INDS(NBITM3+2,IIJ)=JDISK -106 IF(NK.NE.NL)GO TO 306 - IF(NI.EQ.NJ)GO TO 306 - IJT=IROW(NI)+NJ - FC(IJT)=FC(IJT)+2*FINI - GO TO 306 -C CHECK FOR FOCK-MATRIX, AND FROZEN ENERGY, CONTRIBUTIONS -41 CONTINUE - IF(NI.LT.0) THEN - IF((NI.EQ.NJ).AND.(NK.EQ.NL)) EFROZ=EFROZ+4*FINI - IF((NI.EQ.NK).AND.(NJ.EQ.NL)) EFROZ=EFROZ-2*FINI - ELSE IF(NL.LT.0) THEN - IF((NK.EQ.NL).AND.(NJ.GT.0)) THEN - IJT=IROW(NI)+NJ - FC(IJT)=FC(IJT)+2*FINI - ELSE IF((NJ.EQ.NL).AND.(NK.GT.0)) THEN - IKT=IROW(NI)+NK - FC(IKT)=FC(IKT)-FINI - END IF - END IF -306 CONTINUE -307 CONTINUE -308 CONTINUE -309 CONTINUE -310 CONTINUE -311 CONTINUE -312 CONTINUE -313 CONTINUE -C EMPTY LAST BUFFERS - If ( (NOVST+NCHN3).gt.mChain ) then - WRITE(6,*)'SORT_MRCI Error: NOVST+NCHN3>MCHAIN (See code).' - CALL QUIT(_RC_GENERAL_ERROR_) - End If - DO 150 I=1,NCHN3 - JDISK=IDISK -*PAM04 CALL dDAFILE(Lu_60,1,INDOUT(1+(I-1)*RTOI*NBSIZ3),NBSIZ3,IDISK) - CALL iDAFILE(Lu_60,1,INDS(1,I),NBITM3+2,IDISK) - CALL dDAFILE(Lu_60,1,BUFS(1,I),NBITM3,IDISK) - LASTAD(NOVST+I)=JDISK -150 CONTINUE - DO 95 J=1,NORBT - IND=IROW(J+1) - FC(IND)=FC(IND)+EFROZ/NELEC -95 CONTINUE - IADD25=0 - CALL dDAFILE(Lu_25,1,FC,NBTRI,IADD25) - IAD25S=IADD25 -* IF(IPRINT.GE.2) THEN - WRITE(6,154) - CALL XFLUSH(6) - WRITE(6,155)(IVEC(I),I=1,20) -154 FORMAT(//6X,'STATISTICS FOR INTEGRALS, FIRST ENTRY 10**3-10**4', - * /) - CALL XFLUSH(6) -155 FORMAT(6X,5I10) -* END IF - RETURN -c Avoid unused argument warnings - IF (.FALSE.) CALL Unused_integer(NINTGR) - END diff -Nru openmolcas-22.02/src/mrci/sort_mrci.F90 openmolcas-22.10/src/mrci/sort_mrci.F90 --- openmolcas-22.02/src/mrci/sort_mrci.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/sort_mrci.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,303 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine SORT_MRCI(BUFS,INDS,FC,FIIJJ,FIJIJ) + +use mrci_global, only: IAD25S, ICH, IPRINT, IROW, ITOC17, LASTAD, LN, Lu_25, Lu_60, LUONE, LUTRA, MCHAIN, NBITM3, NBTRI, NCHN3, & + NELEC, NORB, NORBT, NSM, NSYM, NTIBUF, NVIR, NVIRP, NVIRT, POTNUC, TIBUF +use Symmetry_Info, only: Mul +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +real(kind=wp), intent(out) :: BUFS(NBITM3,NCHN3), FC(NBTRI) +integer(kind=iwp), intent(out) :: INDS(NBITM3+2,NCHN3) +real(kind=wp), intent(_OUT_) :: FIIJJ(*), FIJIJ(*) +#include "tratoc.fh" +#include "warnings.h" +integer(kind=iwp) :: I, IAD50, IADD17, IADD25, IBUF, IDISK, IEXP, IIJ, IIN, IJ, IJT, IKT, INAV, IND, IORBI, IOUT, IPOF(65), IPOS, & + ISYM, IVEC(20), J, JDISK, JK, JORBI, KORBI, M1, M2, M3, M4, N1, N2, N3, N4, NAV, NBV, NI, NJ, NK, NL, NOP, & + NOQ, NOR, NORB0(9), NORBP, NORBTT, NOS, NOT2, NOTT, NOVST, NSA, NSB, NSIJT, NSP, NSPQ, NSPQR, NSQ, NSR, NSS, & + NSSM, NT, NTM, NTMP, NU, NUMAX, NUMIN, NV, NVT, NX, NXM +real(kind=wp) :: DFINI, EFROZ, FINI, ONEHAM + +IAD50 = 0 +call iDAFILE(LUTRA,2,iTraToc,nTraToc,IAD50) +NVT = IROW(NVIRT+1) +do I=1,20 + IVEC(I) = 0 +end do +IIN = 1 +do I=1,NSYM + call IPO(IPOF(IIN),NVIR,MUL,NSYM,I,-1) + IIN = IIN+NSYM +end do +! ORDER OF RECORD-CHAINS IS +! 1. NOT2 CHAINS (AB/IJ) +! 2. NOT2 CHAINS (AI/BJ) +! 3. NOT2 CHAINS (AI/JK) +! RECORD STRUCTURE IS +! 1. NBITM3 INTEGRALS +! 2. NBITM3 INDICES +! 3. NUMBER OF INTEGRALS IN THIS RECORD +! 4. ADDRESS OF LAST RECORD +NOT2 = IROW(LN+1) +NOTT = 2*NOT2 +NOVST = LN*NVIRT+1+NVT +IDISK = 0 + +INDS(NBITM3+1,:) = 0 +INDS(NBITM3+2,:) = -1 +NORB0(1) = 0 +do I=1,NSYM + NORB0(I+1) = NORB0(I)+NORB(I) +end do +! READ ONE-ELECTRON ORBITALS. USE FIIJJ TEMPORARILY AS READ BUFFER. +NORBTT = 0 +do ISYM=1,NSYM + NORBTT = NORBTT+(NORB(ISYM)*(NORB(ISYM)+1))/2 +end do +EFROZ = POTNUC +FC(:) = Zero +IADD17 = ITOC17(2) +call dDAFILE(LUONE,2,FIIJJ,NORBTT,IADD17) +IBUF = 0 +KORBI = 0 +do ISYM=1,NSYM + do JORBI=KORBI+1,KORBI+NORB(ISYM) + do IORBI=KORBI+1,JORBI + IBUF = IBUF+1 + ONEHAM = FIIJJ(IBUF) + NI = ICH(IORBI) + NJ = ICH(JORBI) + if ((NI == 0) .or. (NJ == 0)) cycle + if (NI < NJ) then + NTMP = NI + NI = NJ + NJ = NTMP + end if + if (NJ > 0) then + IJT = IROW(NI)+NJ + FC(IJT) = FC(IJT)+ONEHAM + else if (NI == NJ) then + EFROZ = EFROZ+2*ONEHAM + end if + end do + end do + KORBI = KORBI+NORB(ISYM) +end do +if (IPRINT >= 20) then + call TRIPRT('FC IN SORT_MRCI BEFORE TWOEL',' ',FC,NORBT) + write(u6,'(A,F20.8)') ' EFROZ:',EFROZ +end if +FIIJJ(1:NBTRI) = Zero +FIJIJ(1:NBTRI) = Zero +! TWO-ELECTRON INTEGRALS +do NSP=1,NSYM + NOP = NORB(NSP) + do NSQ=1,NSP + NSPQ = MUL(NSP,NSQ) + NOQ = NORB(NSQ) + do NSR=1,NSP + NSPQR = MUL(NSPQ,NSR) + NOR = NORB(NSR) + NSSM = NSR + if (NSR == NSP) NSSM = NSQ + do NSS=1,NSSM + if (NSS /= NSPQR) cycle + NOS = NORB(NSS) + NORBP = NOP*NOQ*NOR*NOS + if (NORBP == 0) cycle + call dDAFILE(LUTRA,2,TIBUF,NTIBUF,IAD50) + IOUT = 0 + do NV=1,NOR + NXM = NOS + if (NSR == NSS) NXM = NV + do NX=1,NXM + NTM = 1 + if (NSP == NSR) NTM = NV + do NT=NTM,NOP + NUMIN = 1 + if ((NSP == NSR) .and. (NT == NV)) NUMIN = NX + NUMAX = NOQ + if (NSP == NSQ) NUMAX = NT + do NU=NUMIN,NUMAX + IOUT = IOUT+1 + if (IOUT > NTIBUF) then + call dDAFILE(LUTRA,2,TIBUF,NTIBUF,IAD50) + IOUT = 1 + end if + M1 = ICH(NORB0(NSP)+NT) + M2 = ICH(NORB0(NSQ)+NU) + M3 = ICH(NORB0(NSR)+NV) + M4 = ICH(NORB0(NSS)+NX) + if ((M1 == 0) .or. (M2 == 0)) cycle + if ((M3 == 0) .or. (M4 == 0)) cycle + ! ORDER THESE INDICES CANONICALLY + N1 = max(M1,M2) + N2 = min(M1,M2) + N3 = max(M3,M4) + N4 = min(M3,M4) + NI = N1 + NJ = N2 + NK = N3 + NL = N4 + if (NI <= NK) then + if (NI /= NK) then + NI = N3 + NJ = N4 + NK = N1 + NL = N2 + else if (NJ <= NL) then + NL = N2 + NJ = N4 + end if + end if + FINI = TIBUF(IOUT) + if ((NI <= 0) .or. (NJ <= 0) .or. (NK <= 0) .or. (NL <= 0)) then + ! CHECK FOR FOCK-MATRIX, AND FROZEN ENERGY, CONTRIBUTIONS + if (NI < 0) then + if ((NI == NJ) .and. (NK == NL)) EFROZ = EFROZ+4*FINI + if ((NI == NK) .and. (NJ == NL)) EFROZ = EFROZ-2*FINI + else if (NL < 0) then + if ((NK == NL) .and. (NJ > 0)) then + IJT = IROW(NI)+NJ + FC(IJT) = FC(IJT)+2*FINI + else if ((NJ == NL) .and. (NK > 0)) then + IKT = IROW(NI)+NK + FC(IKT) = FC(IKT)-FINI + end if + end if + cycle + end if + DFINI = abs(FINI)+1.0e-20_wp + IEXP = int(-log10(DFINI))+5 + if (IEXP <= 20) IVEC(IEXP) = IVEC(IEXP)+1 + if ((NI == NJ) .and. (NK == NL)) then + IJ = IROW(NI)+NK + FIIJJ(IJ) = FINI + ! SKIP (AA/II) INTEGRALS + else + if ((NI == NK) .and. (NJ == NL)) then + IJ = IROW(NI)+NJ + FIJIJ(IJ) = FINI + end if + if (NI <= LN) then + else if (NJ > LN) then + if (NK > LN) cycle + ! ABIJ + IIJ = IROW(NK)+NL + IPOS = INDS(NBITM3+1,IIJ)+1 + INDS(NBITM3+1,IIJ) = IPOS + BUFS(IPOS,IIJ) = FINI + NSA = NSM(NI) + NAV = NI-LN-NVIRP(NSA) + NSB = NSM(NJ) + NBV = NJ-LN-NVIRP(NSB) + NSIJT = (MUL(NSM(NK),NSM(NL))-1)*NSYM + INAV = IPOF(NSIJT+NSA)+(NBV-1)*NVIR(NSA)+NAV + INDS(IPOS,IIJ) = INAV + if (IPOS >= NBITM3) then + JDISK = IDISK + call iDAFILE(Lu_60,1,INDS(1,IIJ),NBITM3+2,IDISK) + call dDAFILE(Lu_60,1,BUFS(1,IIJ),NBITM3,IDISK) + INDS(NBITM3+1,IIJ) = 0 + INDS(NBITM3+2,IIJ) = JDISK + end if + if (NK /= NL) cycle + if (NI == NJ) cycle + IJT = IROW(NI)+NJ + FC(IJT) = FC(IJT)+2*FINI + else if (NK > LN) then + if (NL > LN) cycle + ! AIBJ + IIJ = NOT2+IROW(NJ)+NL + if (NL > NJ) IIJ = NOT2+IROW(NL)+NJ + IPOS = INDS(NBITM3+1,IIJ)+1 + INDS(NBITM3+1,IIJ) = IPOS + BUFS(IPOS,IIJ) = FINI + NSA = NSM(NI) + NAV = NI-LN-NVIRP(NSA) + NSB = NSM(NK) + NBV = NK-LN-NVIRP(NSB) + NSIJT = (MUL(NSM(NJ),NSM(NL))-1)*NSYM + if (NL <= NJ) then + INAV = IPOF(NSIJT+NSA)+(NBV-1)*NVIR(NSA)+NAV + else + INAV = IPOF(NSIJT+NSB)+(NAV-1)*NVIR(NSB)+NBV + end if + INDS(IPOS,IIJ) = INAV + if (IPOS >= NBITM3) then + JDISK = IDISK + call iDAFILE(Lu_60,1,INDS(1,IIJ),NBITM3+2,IDISK) + call dDAFILE(Lu_60,1,BUFS(1,IIJ),NBITM3,IDISK) + INDS(NBITM3+1,IIJ) = 0 + INDS(NBITM3+2,IIJ) = JDISK + end if + if (NJ /= NL) cycle + if (NI == NK) cycle + IKT = IROW(NI)+NK + FC(IKT) = FC(IKT)-FINI + else + ! AIJK + JK = NOTT+IROW(NK)+NL + IPOS = INDS(NBITM3+1,JK)+1 + INDS(NBITM3+1,JK) = IPOS + BUFS(IPOS,JK) = FINI + INDS(IPOS,JK) = IROW(NI)+NJ + if (IPOS >= NBITM3) then + JDISK = IDISK + call iDAFILE(Lu_60,1,INDS(1,JK),NBITM3+2,IDISK) + call dDAFILE(Lu_60,1,BUFS(1,JK),NBITM3,IDISK) + INDS(NBITM3+1,JK) = 0 + INDS(NBITM3+2,JK) = JDISK + end if + end if + end if + end do + end do + end do + end do + end do + end do + end do +end do +! EMPTY LAST BUFFERS +if ((NOVST+NCHN3) > MCHAIN) then + write(u6,*) 'SORT_MRCI Error: NOVST+NCHN3>MCHAIN (See code).' + call QUIT(_RC_GENERAL_ERROR_) +end if +do I=1,NCHN3 + JDISK = IDISK + call iDAFILE(Lu_60,1,INDS(1,I),NBITM3+2,IDISK) + call dDAFILE(Lu_60,1,BUFS(1,I),NBITM3,IDISK) + LASTAD(NOVST+I) = JDISK +end do +do J=1,NORBT + IND = IROW(J+1) + FC(IND) = FC(IND)+EFROZ/NELEC +end do +IADD25 = 0 +call dDAFILE(Lu_25,1,FC,NBTRI,IADD25) +IAD25S = IADD25 +!if (IPRINT >= 2) then +write(u6,154) +write(u6,155) (IVEC(I),I=1,20) +!end if + +return + +154 format(//6X,'STATISTICS FOR INTEGRALS, FIRST ENTRY 10**3-10**4',/) +155 format(6X,5I10) + +end subroutine SORT_MRCI diff -Nru openmolcas-22.02/src/mrci/squar2.f openmolcas-22.10/src/mrci/squar2.f --- openmolcas-22.02/src/mrci/squar2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/squar2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE SQUAR2(A,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(N,N) - DO 10 I=1,N - NI=N-I+1 - CALL DCOPY_(NI,A(I,I),1,A(I,I),N) -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/squar.f openmolcas-22.10/src/mrci/squar.f --- openmolcas-22.02/src/mrci/squar.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/squar.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE SQUAR(A,B,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(*),B(N,N) - IN=1 - DO 10 I=1,N - CALL DCOPY_(I,A(IN),1,B(I,1),N) - CALL DCOPY_(I,A(IN),1,B(1,I),1) - IN=IN+I -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/squarm.f openmolcas-22.10/src/mrci/squarm.f --- openmolcas-22.02/src/mrci/squarm.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/squarm.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,24 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE SQUARM(A,B,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(*),B(N,N) - IN=2 - DO 10 I=2,N - CALL VNEG(A(IN),1,B(1,I),1,I-1) - IN=IN+I -10 CONTINUE - DO 20 I=1,N-1 - CALL VNEG(B(I,I+1),N,B(I+1,I),1,N-I) -20 CONTINUE - CALL DCOPY_(N,[0.0D00],0,B,N+1) - RETURN - END diff -Nru openmolcas-22.02/src/mrci/squarn.f openmolcas-22.10/src/mrci/squarn.f --- openmolcas-22.02/src/mrci/squarn.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/squarn.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,24 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE SQUARN(A,B,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(*),B(N,N) - IN=2 - DO 10 I=2,N - CALL DCOPY_(I-1,A(IN),1,B(1,I),1) - IN=IN+I -10 CONTINUE - DO 20 I=1,N-1 - CALL VNEG(B(I,I+1),N,B(I+1,I),1,N-I) -20 CONTINUE - CALL DCOPY_(N,[0.0D00],0,B,N+1) - RETURN - END diff -Nru openmolcas-22.02/src/mrci/tradd.f openmolcas-22.10/src/mrci/tradd.f --- openmolcas-22.02/src/mrci/tradd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/tradd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE TRADD(A,B,N) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(N,N),B(*) - IN=0 - DO 10 I=1,N - DO 20 J=1,I - IN=IN+1 - B(IN)=B(IN)+A(I,J)-A(J,I) -20 CONTINUE -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/mrci/upkvec.f openmolcas-22.10/src/mrci/upkvec.f --- openmolcas-22.02/src/mrci/upkvec.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/upkvec.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Markus P. Fuelscher * -************************************************************************ - SUBROUTINE UPKVEC(NITEM,ICVEC,CVEC) -C*********************************************************************** -C -C PURPOSE: -C DECODE THE CI-VECTOR BY CHANGING THE NUMBER REPRESENTATION FROM -C INTEGER*4 ==> REAL*8 -C -C**** M.P. FUELSCHER, UNIVERSITY OF LUND, SWEDEN, NOV. 1990 ************ -C - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION CVEC(NITEM),ICVEC(NITEM) - PARAMETER (SCALE=1.0D0/2147483647.0D0) -C - DO 10 ITEM=1,NITEM - CVEC(ITEM)=SCALE*DBLE(ICVEC(ITEM)) -10 CONTINUE -C - RETURN - END diff -Nru openmolcas-22.02/src/mrci/upkvec.F90 openmolcas-22.10/src/mrci/upkvec.F90 --- openmolcas-22.02/src/mrci/upkvec.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/mrci/upkvec.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,38 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Markus P. Fuelscher * +!*********************************************************************** + +subroutine UPKVEC(NITEM,ICVEC,CVEC) +!*********************************************************************** +! +! PURPOSE: +! DECODE THE CI-VECTOR BY CHANGING THE NUMBER REPRESENTATION FROM +! INTEGER*4 ==> REAL*8 +! +!**** M.P. FUELSCHER, UNIVERSITY OF LUND, SWEDEN, NOV. 1990 ************ + +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: NITEM, ICVEC(NITEM) +real(kind=wp), intent(out) :: CVEC(NITEM) +integer(kind=iwp) :: ITEM +real(kind=wp), parameter :: SCL = One/2147483647.0_wp + +do ITEM=1,NITEM + CVEC(ITEM) = SCL*real(ICVEC(ITEM),kind=wp) +end do + +return + +end subroutine UPKVEC diff -Nru openmolcas-22.02/src/mrci/vneg.f openmolcas-22.10/src/mrci/vneg.f --- openmolcas-22.02/src/mrci/vneg.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mrci/vneg.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - SUBROUTINE VNEG(A,K,B,L,IAB) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION A(*),B(*) - DO 10 I=0,IAB-1 - B(1+I*L)=-A(1+I*K) -10 CONTINUE - RETURN - END diff -Nru openmolcas-22.02/src/msym_util/msymapi.F90 openmolcas-22.10/src/msym_util/msymapi.F90 --- openmolcas-22.02/src/msym_util/msymapi.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/msym_util/msymapi.F90 2022-10-10 14:22:40.000000000 +0000 @@ -74,7 +74,7 @@ integer(kind=iwp) :: ret interface function cmsym_release_context(pctx,err) bind(C,name='cmsym_release_context_') - use, intrinsic :: iso_c_binding, only: c_int, c_ptr + use, intrinsic :: iso_c_binding, only: c_ptr use Definitions, only: MOLCAS_C_INT integer(kind=MOLCAS_C_INT) :: cmsym_release_context type(c_ptr), value :: pctx @@ -138,7 +138,8 @@ call mma_allocate(basis_ids,4*nMO,label='basis_ids') call Get_iArray('Basis IDs',basis_ids,4*nMO) -! INT cmsym_set_elements(msym_context *pctx, INT *pel, INT *puel, char *uelement, double xyz[][3], INT *paol, INT basis_ids[][4], int *err) +! INT cmsym_set_elements(msym_context *pctx, INT *pel, INT *puel, char *uelement, double xyz[][3], INT *paol, INT basis_ids[][4], +! int *err) call cmsym_set_elements(ctx,nAtoms,(LENIN),AtomLabel,Coord,nMO,basis_ids,ret) call mma_deallocate(basis_ids) call mma_deallocate(AtomLabel) @@ -278,7 +279,8 @@ call mma_allocate(IrrInd,nMO,label='IrrInd') call mma_allocate(irrep_strings,nMO,label='irrep_strings') -! INT cmsym_generate_orbital_subspaces(msym_context *pctx, INT *l, double c[*l][*l], INT irrep_ids[*l], INT irrep_ind[*l], INT* nirreps, char lbl[*l][8], INT *err){ +! INT cmsym_generate_orbital_subspaces(msym_context *pctx, INT *l, double c[*l][*l], INT irrep_ids[*l], INT irrep_ind[*l], +! INT* nirreps, char lbl[*l][8], INT *err){ call cmsym_generate_orbital_subspaces(ctx,nMO,CAO,IrrIds,IrrInd,nIrr,irrep_strings,ret) write(u6,*) 'Irrep indices=' write(u6,'(5i3)') IrrInd(:) diff -Nru openmolcas-22.02/src/mula/intensitymod.F90 openmolcas-22.10/src/mula/intensitymod.F90 --- openmolcas-22.02/src/mula/intensitymod.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/mula/intensitymod.F90 2022-10-10 14:22:40.000000000 +0000 @@ -59,7 +59,7 @@ use mula_global, only: mdim1, mdim2, ndim1, ndim2 use stdalloc, only: mma_allocate, mma_deallocate use Constants, only: Zero, Two, Three -use Definitions, only: iwp, wp +use Definitions, only: wp, iwp implicit none integer(kind=iwp), intent(in) :: nPolyTerm, nvar, ipow(nPolyTerm,nvar), m_max, n_max, max_dip, l_n_plot, l_m_plot, & diff -Nru openmolcas-22.02/src/nevpt2/rdinput.F90 openmolcas-22.10/src/nevpt2/rdinput.F90 --- openmolcas-22.02/src/nevpt2/rdinput.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nevpt2/rdinput.F90 2022-10-10 14:22:40.000000000 +0000 @@ -19,16 +19,17 @@ ! use global variables directly from the NEVPT2 program use nevpt2_cfg, only: igelo, MultGroup, no_pc, nr_frozen_orb, nr_states, rdm_distributed, rdm_path, rdm_read, skip_effective_ham, & skip_koopro_molcas +use text_file, only: extend_line, next_non_comment +use stdalloc, only: mma_allocate, mma_deallocate use Definitions, only: iwp, u6 implicit none character(len=*), intent(out) :: refwfnfile +integer(kind=iwp) :: LuSpool, iError, i, isplit character(len=180) :: Line, key -character(len=9001) :: dline character(len=9001) :: frozen_str -integer(kind=iwp) :: LuSpool, iError, i, isplit +character(len=:), allocatable :: dLine, Line2 integer(kind=iwp), external :: isFreeUnit -logical(kind=iwp), external :: next_non_comment character(len=180), external :: Get_Ln ! Initial values @@ -146,13 +147,13 @@ case ('MULT') !========= MULT ============= ! multi-state QD-NEVPT2 calculation requested with the states given below - if (.not. next_non_comment(LuSpool,Line)) call error(1) - read(Line,*) key + if (.not. next_non_comment(LuSpool,Line2)) call error(1) + read(Line2,*) key call upcase(key) if (trim(key) == 'ALL') then nr_states = 0 else - read(Line,*,iostat=iError) nr_states + read(Line2,*,iostat=iError) nr_states if (iError /= 0) call error(0) if (nr_states <= 0) then write(u6,*) ' number of MULT states must be > 0, quitting!' @@ -163,24 +164,26 @@ ! is deallocated somewhere in the external library if (allocated(MultGroup%State)) deallocate(MultGroup%State) allocate(MultGroup%State(nr_states)) - iSplit = scan(Line,' ') - dLine = line(iSplit:) + iSplit = scan(Line2,' ') + call mma_allocate (dLine,len(Line),label='dLine') + dLine = line2(iSplit:) iError = -1 do while (iError < 0) read(dLine,*,iostat=iError) (MultGroup%State(i),i=1,nr_states) if (iError > 0) call error(0) if (iError < 0) then - if (.not. next_non_comment(LuSpool,Line)) call error(1) - dline = trim(dline)//' '//line + if (.not. next_non_comment(LuSpool,Line2)) call error(1) + call extend_line(dLine,Line) end if end do + call mma_deallocate (dLine) case ('FILE') !========= FILE ============= ! Specifiy the name of the reference wfn file for NEVPT2. - if (.not. next_non_comment(LuSpool,Line)) call error(1) - line = adjustl(line) - call fileorb(Line,refwfnfile) + if (.not. next_non_comment(LuSpool,Line2)) call error(1) + line2(:) = adjustl(line2) + call fileorb(Line2,refwfnfile) case ('RDMR') !========= RDMR ============= a.k.a. RDMRead @@ -197,8 +200,8 @@ ! of the format "A-B-C-D", where A,B,C,D are the first four indices of the 4-RDM to be calculated ! Each subdirectory should contain the results of a single calculation in a batch rdm_distributed = .true. - if (.not. next_non_comment(LuSpool,Line)) call error(1) - read(Line,'(A)') key + if (.not. next_non_comment(LuSpool,Line2)) call error(1) + read(Line2,'(A)') key rdm_path = trim(key) case ('END ') @@ -214,6 +217,8 @@ end do ! END of Input +if (allocated(Line2)) call mma_deallocate(Line2) + !> make sure the array is allocated for the minimal input !> &NEVPT2 &END if (.not. allocated(MultGroup%State)) then diff -Nru openmolcas-22.02/src/nq_util/allok2_funi.f openmolcas-22.10/src/nq_util/allok2_funi.f --- openmolcas-22.02/src/nq_util/allok2_funi.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/allok2_funi.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,79 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1992, Roland Lindh * -* 1995, Martin Schuetz * -************************************************************************ - SubRoutine AlloK2_Funi(nr_of_Densities) -************************************************************************ -* * -* Object: Allocate space for K2 entities. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, Sweden. November '92 * -* Martin Schuetz, Dept. of Theoretical Chemistry, * -* University of Lund, Sweden. Jun '95 * -************************************************************************ - use iSD_data - use k2_arrays - use IOBUF - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) -#include "ndarray.fh" -#include "real.fh" -#include "nsd.fh" -#include "setup.fh" -#include "status.fh" -* -* - Call Nr_Shells(nSkal) -* -* determine memory size nDeDe, MaxDe, and MaxDRC - nDeDe_DFT = 0 - MaxDe = 0 -* -************************************************************************ -* * -* * -*-----Double loop over shells. These loops decide the integral type -* - Do iS = 1, nSkal -C iAng = iSD( 1,iS) - iCmp = iSD( 2,iS) - iBas = iSD( 3,iS) -C iPrim = iSD( 5,iS) - iAO = iSD( 7,iS) -C mdci = iSD(10,iS) - iShell = iSD(11,iS) -* - Do jS = 1, iS -C jAng = iSD( 1,jS) - jCmp = iSD( 2,jS) - jBas = iSD( 3,jS) -C jPrim = iSD( 5,jS) - jAO = iSD( 7,jS) -C mdcj = iSD(10,jS) - jShell = iSD(11,jS) -* -C iDeSiz = 1 + iPrim*jPrim + (iBas*jBas+1)*iCmp*jCmp - iDeSiz = iBas*jBas*iCmp*jCmp - MaxDe = Max(MaxDe,iDeSiz) - iSmLbl = 1 - nSO = MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO) - If (nSO.gt.0) Then - nDeDe_DFT = nDeDe_DFT - & + nr_of_Densities*iDeSiz*nIrrep - End If -* - End Do - End Do -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/allok2_funi.F90 openmolcas-22.10/src/nq_util/allok2_funi.F90 --- openmolcas-22.02/src/nq_util/allok2_funi.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/allok2_funi.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,76 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1992, Roland Lindh * +! 1995, Martin Schuetz * +!*********************************************************************** + +subroutine AlloK2_Funi(nr_of_Densities) +!*********************************************************************** +! * +! Object: Allocate space for K2 entities. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, Sweden. November '92 * +! Martin Schuetz, Dept. of Theoretical Chemistry, * +! University of Lund, Sweden. Jun '95 * +!*********************************************************************** + +use iSD_data, only: iSD +use k2_arrays, only: MaxDe, nDeDe_DFT +use Symmetry_Info, only: nIrrep +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: nr_of_Densities +integer(kind=iwp) :: iAO, iBas, iCmp, iDeSiz, iS, iShell, iSmLbl, jAO, jBas, jCmp, jS, jShell, nSkal, nSO +integer(kind=iwp), external :: MemSO1 + +call Nr_Shells(nSkal) + +! determine memory size nDeDe, MaxDe, and MaxDRC +nDeDe_DFT = 0 +MaxDe = 0 +! * +!*********************************************************************** +! * +! Double loop over shells. These loops decide the integral type + +do iS=1,nSkal + !iAng = iSD(1,iS) + iCmp = iSD(2,iS) + iBas = iSD(3,iS) + !iPrim = iSD(5,iS) + iAO = iSD(7,iS) + !mdci = iSD(10,iS) + iShell = iSD(11,iS) + + do jS=1,iS + !jAng = iSD(1,jS) + jCmp = iSD(2,jS) + jBas = iSD(3,jS) + !jPrim = iSD(5,jS) + jAO = iSD(7,jS) + !mdcj = iSD(10,jS) + jShell = iSD(11,jS) + + !iDeSiz = 1+iPrim*jPrim+(iBas*jBas+1)*iCmp*jCmp + iDeSiz = iBas*jBas*iCmp*jCmp + MaxDe = max(MaxDe,iDeSiz) + iSmLbl = 1 + nSO = MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell,iAO,jAO) + if (nSO > 0) nDeDe_DFT = nDeDe_DFT+nr_of_Densities*iDeSiz*nIrrep + + end do +end do + +return + +end subroutine AlloK2_Funi diff -Nru openmolcas-22.02/src/nq_util/angular_grid.f openmolcas-22.10/src/nq_util/angular_grid.f --- openmolcas-22.02/src/nq_util/angular_grid.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/angular_grid.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,79 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Angular_Grid() -************************************************************************ -* * -* Computes datas useful for the angular quadrature. * -* * -************************************************************************ - use nq_Structure, only: Info_Ang - use nq_Info - Implicit Real*8 (a-h,o-z) -#include "itmax.fh" -#include "real.fh" -#include "debug.fh" - Logical Check -* * -************************************************************************ -* * -* Statement functions * -* * - Check(i,j)=iAnd(i,2**(j-1)).ne.0 -* * -************************************************************************ -* * - nAngularGrids=0 - If (Check(iOpt_Angular,3)) Then -* * -************************************************************************ -* * -*------- Generate angular grid a la Lebedev -* - Call Lebedev_Grid(L_Quad) -* * -************************************************************************ -* * - Else If (Check(iOpt_Angular,1)) Then -* * -************************************************************************ -* * -*------- Generate angular grid a la Lobatto -* - Call Lobatto_Grid(L_Quad) -* * -************************************************************************ -* * - Else -* * -************************************************************************ -* * -*------- Generate angular grid from Gauss and Gauss-Legendre quadrature -* - Call GGL_Grid(L_Quad) -* * -************************************************************************ -* * - End If -* * -************************************************************************ -* * -* - If (Debug) Then - Do iSet = 1, nAngularGrids - nGP=Info_Ang(iSet)%nPoints - l =Info_Ang(iSet)%L_eff - Write (6,*) 'l=',l - Call RecPrt('Angular grid',' ',Info_Ang(iSet)%R,4,nGP) - End Do - End If -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/angular_grid.F90 openmolcas-22.10/src/nq_util/angular_grid.F90 --- openmolcas-22.02/src/nq_util/angular_grid.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/angular_grid.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,80 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Angular_Grid() +!*********************************************************************** +! * +! Computes data useful for the angular quadrature. * +! * +!*********************************************************************** + +use nq_Info, only: iOpt_Angular, L_Quad, nAngularGrids +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +use nq_Structure, only: Info_Ang +use Definitions, only: iwp, u6 +#endif + +implicit none +#ifdef _DEBUGPRINT_ +integer(kind=iwp) :: iSet, l, nGP +#endif + +! * +!*********************************************************************** +! * +nAngularGrids = 0 +if (btest(iOpt_Angular,2)) then + ! * + !********************************************************************* + ! * + ! Generate angular grid a la Lebedev + + call Lebedev_Grid(L_Quad) + ! * + !********************************************************************* + ! * +else if (btest(iOpt_Angular,0)) then + ! * + !********************************************************************* + ! * + ! Generate angular grid a la Lobatto + + call Lobatto_Grid(L_Quad) + ! * + !********************************************************************* + ! * +else + ! * + !********************************************************************* + ! * + ! Generate angular grid from Gauss and Gauss-Legendre quadrature + + call GGL_Grid(L_Quad) + ! * + !********************************************************************* + ! * +end if +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +do iSet=1,nAngularGrids + nGP = Info_Ang(iSet)%nPoints + l = Info_Ang(iSet)%L_eff + write(u6,*) 'l=',l + call RecPrt('Angular grid',' ',Info_Ang(iSet)%R,4,nGP) +end do +#endif + +return + +end subroutine Angular_Grid diff -Nru openmolcas-22.02/src/nq_util/angular_prune.f openmolcas-22.10/src/nq_util/angular_prune.f --- openmolcas-22.02/src/nq_util/angular_prune.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/angular_prune.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,119 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Angular_Prune(Radius,nR,iAngular_Grid,Crowding,Fade, - & R_BS,L_Quad,R_Min,lAng,nAngularGrids) - use nq_Structure, only: Info_Ang - Implicit Real*8 (a-h,o-z) - Real*8 Radius(2,nR), R_Min(0:lAng) - Integer iAngular_Grid(nR) -#include "real.fh" -* * -************************************************************************ -* * -*define _DEBUGPRINT_ -* * -************************************************************************ -* * - R_Test=R_BS/Crowding -#ifdef _DEBUGPRINT_ - Write (6,*) 'lAng=',lAng - Write (6,*) 'Crowding=',Crowding - Write (6,*) 'R_BS=',R_BS - Write (6,*) 'L_Quad=',L_Quad - Write (6,*) 'LMax_NQ=',SIZE(Info_Ang) - Write (6,*) 'nAngularGrids=',nAngularGrids - Write (6,*) 'R_Test=',R_Test - Write (6,'(A,10G10.3)') 'R_Min=',R_Min - Write (6,*) 'Info_Ang(*)%L_Eff=', - & (Info_Ang(i)%L_Eff,i=1,nAngularGrids) -#endif - Do iR = 1, nR -* - R_Value=Radius(1,iR) -#ifdef _DEBUGPRINT_ - Write (6,'(A,G10.3)') 'R_Value=',R_Value -#endif -* -*------- Establish L_Eff according to the crowding factor. -* -c Avoid overflow by converting to Int at the end - iAng=Int(Half*Min(L_Quad*R_Value/R_Test,DBLE(L_Quad))) -#ifdef _DEBUGPRINT_ - Write (6,*) 'iAng=',iAng -#endif -* -*------- Close to the nuclei we can use the alternative formula -* given by the LMG radial grid. -* - iAng=Max(iAng,lAng) - Do jAng = lAng,1,-1 - If (R_Value.lt.R_Min(jAng)) iAng=Min(iAng,jAng-1) - End Do -#ifdef _DEBUGPRINT_ - Write (6,*) 'iAng=',iAng -#endif -* -* Fade the outer part -* - R_Test2=Fade*R_BS - If (R_Value.gt.R_Test2) -c Avoid overflow by converting to Int at the end - & iAng=Int(Half*Min(L_Quad*R_Test2/R_Value,DBLE(L_Quad))) -* -*------- Since the Lebedev grid is not defined for any L_Eff -* value we have to find the closest one, i.e. of the same -* order or higher. Start loop from low order! -* - kSet = 0 - Do jSet = 1, nAngularGrids - If (Info_Ang(jSet)%L_Eff.ge.2*iAng+1.and.kSet.eq.0) Then - kSet=jSet - iAng=Info_Ang(kSet)%L_Eff/2 - End If - End Do - If (kSet.eq.0) Then - kSet = nAngularGrids - iAng=Info_Ang(kSet)%L_Eff/2 - End If -* - iAngular_Grid(iR)=kSet -* - End Do -#ifdef _DEBUGPRINT_ - Write (6,*) - Write (6,*) 'iAngular_Grid:' - Write (6,*) 'R_Min R_Max kSet nR nPoints' - RStart=Radius(1,1) - kSet=iAngular_Grid(1) - nTot=Info_Ang(1)%nPoints - mR=1 - Do iR = 2, nR - nTot=nTot+Info_Ang(iAngular_Grid(iR))%nPoints - If (iAngular_Grid(iR).ne.kSet.or.iR.eq.nR) Then - jR=iR-1 - If (iR.eq.nR) Then - jR=nR - mR = mR + 1 - End If - Write (6,'(2G10.3,I3,2I5)') RStart,Radius(1,jR),kSet, - & mR,Info_Ang(kSet)%nPoints - RStart=Radius(1,iR) - kSet=iAngular_Grid(iR) - mR = 0 - End If - mR = mR + 1 - End Do - Write (6,*) 'Total grid size:',nTot - Write (6,*) -#endif -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/angular_prune.F90 openmolcas-22.10/src/nq_util/angular_prune.F90 --- openmolcas-22.02/src/nq_util/angular_prune.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/angular_prune.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,127 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Angular_Prune(Radius,nR,iAngular_Grid,Crowding,Fade,R_BS,L_Quad,R_Min,lAng,nAngularGrids) + +use nq_Structure, only: Info_Ang +use Constants, only: Half +use Definitions, only: wp, iwp +#ifdef _DEBUGPRINT_ +use Definitions, only: u6 +#endif + +implicit none +integer(kind=iwp), intent(in) :: nR, L_Quad, lAng, nAngularGrids +real(kind=wp), intent(in) :: Radius(2,nR), Crowding, Fade, R_BS, R_Min(0:lAng) +integer(kind=iwp), intent(out) :: iAngular_Grid(nR) +integer(kind=iwp) :: iAng, iR, jAng, jSet, kSet +real(kind=wp) :: R_Test, R_Test2, R_Value + +! * +!*********************************************************************** +! * +!define _DEBUGPRINT_ +! * +!*********************************************************************** +! * +R_Test = R_BS/Crowding +#ifdef _DEBUGPRINT_ +write(u6,*) 'lAng=',lAng +write(u6,*) 'Crowding=',Crowding +write(u6,*) 'R_BS=',R_BS +write(u6,*) 'L_Quad=',L_Quad +write(u6,*) 'LMax_NQ=',size(Info_Ang) +write(u6,*) 'nAngularGrids=',nAngularGrids +write(u6,*) 'R_Test=',R_Test +write(u6,'(A,10G10.3)') 'R_Min=',R_Min +write(u6,*) 'Info_Ang(*)%L_Eff=',(Info_Ang(i)%L_Eff,i=1,nAngularGrids) +#endif +do iR=1,nR + + R_Value = Radius(1,iR) +# ifdef _DEBUGPRINT_ + write(u6,'(A,G10.3)') 'R_Value=',R_Value +# endif + + ! Establish L_Eff according to the crowding factor. + + ! Avoid overflow by converting to Int at the end + iAng = int(Half*min(L_Quad*R_Value/R_Test,real(L_Quad,kind=wp))) +# ifdef _DEBUGPRINT_ + write(u6,*) 'iAng=',iAng +# endif + + ! Close to the nuclei we can use the alternative formula + ! given by the LMG radial grid. + + iAng = max(iAng,lAng) + do jAng=lAng,1,-1 + if (R_Value < R_Min(jAng)) iAng = min(iAng,jAng-1) + end do +# ifdef _DEBUGPRINT_ + write(u6,*) 'iAng=',iAng +# endif + + ! Fade the outer part + + R_Test2 = Fade*R_BS + ! Avoid overflow by converting to Int at the end + if (R_Value > R_Test2) iAng = int(Half*min(L_Quad*R_Test2/R_Value,real(L_Quad,kind=wp))) + + ! Since the Lebedev grid is not defined for any L_Eff + ! value we have to find the closest one, i.e. of the same + ! order or higher. Start loop from low order! + + kSet = 0 + do jSet=1,nAngularGrids + if ((Info_Ang(jSet)%L_Eff >= 2*iAng+1) .and. (kSet == 0)) then + kSet = jSet + iAng = Info_Ang(kSet)%L_Eff/2 + end if + end do + if (kSet == 0) then + kSet = nAngularGrids + iAng = Info_Ang(kSet)%L_Eff/2 + end if + + iAngular_Grid(iR) = kSet + +end do +#ifdef _DEBUGPRINT_ +write(u6,*) +write(u6,*) 'iAngular_Grid:' +write(u6,*) 'R_Min R_Max kSet nR nPoints' +RStart = Radius(1,1) +kSet = iAngular_Grid(1) +nTot = Info_Ang(1)%nPoints +mR = 1 +do iR=2,nR + nTot = nTot+Info_Ang(iAngular_Grid(iR))%nPoints + if ((iAngular_Grid(iR) /= kSet) .or. (iR == nR)) then + jR = iR-1 + if (iR == nR) then + jR = nR + mR = mR+1 + end if + write(u6,'(2G10.3,I3,2I5)') RStart,Radius(1,jR),kSet,mR,Info_Ang(kSet)%nPoints + RStart = Radius(1,iR) + kSet = iAngular_Grid(iR) + mR = 0 + end if + mR = mR+1 +end do +write(u6,*) 'Total grid size:',nTot +write(u6,*) +#endif + +return + +end subroutine Angular_Prune diff -Nru openmolcas-22.02/src/nq_util/anmesh.F90 openmolcas-22.10/src/nq_util/anmesh.F90 --- openmolcas-22.02/src/nq_util/anmesh.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/anmesh.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,200 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2001, Roland Lindh * +! 2001, Laura Gagliardi * +!*********************************************************************** + +subroutine AnMesh(nscheme,pa,rPt,wPt) + +use Constants, only: Zero, One, Two, Three +use Definitions, only: wp, iwp +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +use Definitions, only: u6 +#endif + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: nscheme(8) +real(kind=wp), intent(in) :: pa(*) +real(kind=wp), intent(_OUT_) :: rPt(3,*), wPt(*) +integer(kind=iwp) :: i, ii, ip, ix, iy, iz, j, j1, jj, n1 +real(kind=wp) :: c, pp, qq, rr, ss, tt, uu, vv + +! * +!*********************************************************************** +! * + +#ifdef _DEBUGPRINT_ +write(u6,*) +write(u6,*) ' ******** The Angular Lebedev Grid ********' +write(u6,*) +write(u6,*) +#endif + +i = 0 +ip = 0 + +! nscheme(2) -> 6 points + +!lg write(u6,*) 'nscheme',(nscheme(i),i=1,8) +if (nscheme(2) > 0) then + !lg write(u6,*) 'nscheme(2)',nscheme(2) + ip = ip+1 + do ix=1,3 + do iy=1,-1,-2 + i = i+1 + wPt(i) = pa(ip) + do j=1,3 + rPt(j,i) = Zero + end do + rPt(ix,i) = real(iy,kind=wp) + !lg write(u6,*) rPt(ix,i),wPt(i) + end do + end do +end if + +! nscheme(3) -> 8 points + +if (nscheme(3) > 0) then ! + c = One/sqrt(Three) + ip = ip+1 + do ix=1,-1,-2 + do iy=1,-1,-2 + do iz=1,-1,-2 + i = i+1 + wPt(i) = pa(ip) + rPt(1,i) = real(ix,kind=wp)*c + rPt(2,i) = real(iy,kind=wp)*c + rPt(3,i) = real(iz,kind=wp)*c + end do + end do + end do +end if + +! nscheme(4) -> 12 points + +if (nscheme(4) > 0) then + c = One/sqrt(Two) + ip = ip+1 + do ix=1,-1,-2 + do iy=1,-1,-2 + do iz=1,3 + i = i+1 + wPt(i) = pa(ip) + rPt(iz,i) = real(ix,kind=wp)*c + j = mod(iz,3)+1 + rPt(j,i) = real(iy,kind=wp)*c + j = 6-iz-j + rPt(j,i) = Zero + end do + end do + end do +end if + +! 24a points + +n1 = nscheme(5) +do jj=1,n1 + ip = ip+1 + uu = pa(ip) + vv = sqrt(One-Two*uu*uu) + ip = ip+1 + do ix=1,-1,-2 + do iy=1,-1,-2 + do iz=1,-1,-2 + do j=1,3 + i = i+1 + wPt(i) = pa(ip) + do j1=1,3 + rPt(j1,i) = uu + end do + rPt(j,i) = vv + rPt(1,i) = rPt(1,i)*real(ix,kind=wp) + rPt(2,i) = rPt(2,i)*real(iy,kind=wp) + rPt(3,i) = rPt(3,i)*real(iz,kind=wp) + end do + end do + end do + end do +end do + +! 24b points + +n1 = nscheme(6) +do jj=1,n1 + ip = ip+1 + pp = pa(ip) + qq = sqrt(One-pp*pp) + ip = ip+1 + do ix=1,-1,-2 + do iy=1,-1,-2 + do ii=0,1 + do j=1,3 + i = i+1 + wPt(i) = pa(ip) + j1 = mod(j+ii,3)+1 + rPt(j1,i) = pp*real(ix,kind=wp) + j1 = mod(j+1-ii,3)+1 + rPt(j1,i) = qq*real(iy,kind=wp) + rPt(j,i) = Zero + end do + end do + end do + end do +end do + +! 48 points + +n1 = nscheme(7) +!lg write(u6,*) 'i, n1 =',i,n1 +do jj=1,n1 + ip = ip+1 + rr = pa(ip) + ip = ip+1 + ss = pa(ip) + tt = sqrt(One-rr*rr-ss*ss) + ip = ip+1 + do ix=1,-1,-2 + do iy=1,-1,-2 + do iz=1,-1,-2 + do j=1,3 + do ii=0,1 + i = i+1 + wPt(i) = pa(ip) + rPt(j,i) = rr*real(ix,kind=wp) + j1 = mod(j+ii,3)+1 + rPt(j1,i) = ss*real(iy,kind=wp) + j1 = mod(j+1-ii,3)+1 + rPt(j1,i) = tt*real(iz,kind=wp) + !lg write (u6,*) rPt(j1,i),wPt(i),j1,i + end do + !lg write (u6,*) 'Enddo1',i + end do + !lg write (u6,*) 'Enddo2',i + end do + !lg write (u6,*) 'Enddo3',i + end do + !lg write (u6,*) 'Enddo4',i + end do + !lg write (u6,*) 'Enddo5',i +end do +!lg write (u6,*) 'enddo',n1 +! * +!*********************************************************************** +! * + +!lg write(u6,*) 'End of AnMesh' + +return + +end subroutine AnMesh diff -Nru openmolcas-22.02/src/nq_util/aoadd_full.f openmolcas-22.10/src/nq_util/aoadd_full.f --- openmolcas-22.02/src/nq_util/aoadd_full.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/aoadd_full.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,49 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991,2021,2022, Roland Lindh * -************************************************************************ - SubRoutine AOAdd_Full(PrpInt,nPrp,nD) -************************************************************************ -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* January 1991 * -************************************************************************ - use nq_Grid, only: iBfn_Index - use nq_Grid, only: AOInt => Dens_AO - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - Real*8 PrpInt(nPrp,nD) -* * -************************************************************************ -* * -* Statement function -* - iTri(i,j)=Max(i,j)*(Max(i,j)-1)/2 + Min(i,j) -* * -************************************************************************ - -* - nBfn=Size(iBfn_index,2) - Do iBfn = 1, nBfn - Indi = iBfn_Index(1,iBfn) - - Do jBfn = 1, iBfn - Indj = iBfn_Index(1,jBfn) -* -* Add one matrix element -* - PrpInt(iTri(Indi,Indj),:)=PrpInt(iTri(Indi,Indj),:) - & + AOInt(iBfn,jBfn,:) - End Do - End Do -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/aoadd_full.F90 openmolcas-22.10/src/nq_util/aoadd_full.F90 --- openmolcas-22.02/src/nq_util/aoadd_full.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/aoadd_full.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,49 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991,2021,2022, Roland Lindh * +!*********************************************************************** + +subroutine AOAdd_Full(PrpInt,nPrp,nD) +!*********************************************************************** +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! January 1991 * +!*********************************************************************** + +use nq_Grid, only: Dens_AO, iBfn_Index +use Index_Functions, only: iTri +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nPrp, nD +real(kind=wp), intent(inout) :: PrpInt(nPrp,nD) +integer(kind=iwp) :: iBfn, Indi, Indj, jBfn, nBfn + +! * +!*********************************************************************** +! * + +nBfn = size(iBfn_index,2) +do iBfn=1,nBfn + Indi = iBfn_Index(1,iBfn) + + do jBfn=1,iBfn + Indj = iBfn_Index(1,jBfn) + + ! Add one matrix element + + PrpInt(iTri(Indi,Indj),:) = PrpInt(iTri(Indi,Indj),:)+Dens_AO(iBfn,jBfn,:) + end do +end do + +return + +end subroutine AOAdd_Full diff -Nru openmolcas-22.02/src/nq_util/box_on_sphere.f openmolcas-22.10/src/nq_util/box_on_sphere.f --- openmolcas-22.02/src/nq_util/box_on_sphere.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/box_on_sphere.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,117 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Box_On_Sphere(x_Min_,x_Max_, y_Min_, - & y_Max_, z_Min_,z_Max_, - & xMin_, xMax_, yMin_, - & yMax_, zMin_ ,zMax_ ) - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 xyz(3,2), xyz0(3,2), Roots(3,3) -* - delta=1.0D-15 -* - xyz(1,1)=x_min_ - xyz(1,2)=x_max_ - xyz(2,1)=y_min_ - xyz(2,2)=y_max_ - xyz(3,1)=z_min_ - xyz(3,2)=z_max_ -c Write (*,*) -c Write (*,*) 'Box limitations' -c Write (*,*) 'x:',xyz(1,1), xyz(1,2) -c Write (*,*) 'y:',xyz(2,1), xyz(2,2) -c Write (*,*) 'z:',xyz(3,1), xyz(3,2) -* -* Set extremal values -* - xyz0(1,1)= One - xyz0(1,2)=-One - xyz0(2,1)= One - xyz0(2,2)=-One - xyz0(3,1)= One - xyz0(3,2)=-One -* - Do ix = 1, 3 - iy=ix+1 - If (iy.gt.3) iy=1 - iz=iy+1 - If (iz.gt.3) iz=1 -* - xMax=xyz(ix,2) - xMin=xyz(ix,1) -c Write (*,*) - Roots(1,iy)=xyz(iy,1) - Roots(2,iy)=xyz(iy,2) - If (xyz(iy,1)*xyz(iy,2).lt.Zero) Then - ny_Roots=3 - Roots(3,iy)=Zero - Else - ny_Roots=2 - End If - Roots(1,iz)=xyz(iz,1) - Roots(2,iz)=xyz(iz,2) - If (xyz(iz,1)*xyz(iz,2).lt.Zero) Then - nz_Roots=3 - Roots(3,iz)=Zero - Else - nz_Roots=2 - End If -c Call RecPrt('Roots','(3G25.12)',Roots,3,3) -* - Do i = 1, ny_Roots -c Write (*,*) 'i=',i,ny_Roots -c Write (*,*) - y = Roots(i,iy) - Do j = 1, nz_Roots -c Write (*,*) 'j=',j,nz_Roots - z = Roots(j,iz) -* - x=xMin - r=sqrt(x**2+y**2+z**2) -c Write (*,*) x/r - If (r.eq.Zero) Then - x_r=Zero - Else - x_r=x/r - End If - xyz0(ix,1)=Min(xyz0(ix,1),x_r) - xyz0(ix,2)=Max(xyz0(ix,2),x_r) -* - x=xMax - r=sqrt(x**2+y**2+z**2) -c Write (*,*) x/r - If (r.eq.Zero) Then - x_r=Zero - Else - x_r=x/r - End If - xyz0(ix,1)=Min(xyz0(ix,1),x_r) - xyz0(ix,2)=Max(xyz0(ix,2),x_r) -* - End Do - End Do - End Do -* -c Write (*,*) 'xMin=',xyz0(1,1) -c Write (*,*) 'xMax=',xyz0(1,2) -c Write (*,*) 'yMin=',xyz0(2,1) -c Write (*,*) 'yMax=',xyz0(2,2) -c Write (*,*) 'zMin=',xyz0(3,1) -c Write (*,*) 'zMax=',xyz0(3,2) - xMin_=xyz0(1,1)-Delta - xMax_=xyz0(1,2)+Delta - yMin_=xyz0(2,1)-Delta - yMax_=xyz0(2,2)+Delta - zMin_=xyz0(3,1)-Delta - zMax_=xyz0(3,2)+Delta -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/box_on_sphere.F90 openmolcas-22.10/src/nq_util/box_on_sphere.F90 --- openmolcas-22.02/src/nq_util/box_on_sphere.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/box_on_sphere.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,121 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Box_On_Sphere(x_Min_,x_Max_,y_Min_,y_Max_,z_Min_,z_Max_,xMin_,xMax_,yMin_,yMax_,zMin_,zMax_) + +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(in) :: x_Min_, x_Max_, y_Min_, y_Max_, z_Min_, z_Max_ +real(kind=wp), intent(out) :: xMin_, xMax_, yMin_, yMax_, zMin_, zMax_ +integer(kind=iwp) :: i, ix, iy, iz, j, ny_Roots, nz_Roots +real(kind=wp) :: r, Roots(3,3), x, x_r, xMax, xMin, xyz(3,2), xyz0(3,2), y, z +real(kind=wp), parameter :: Delta = 1.0e-15_wp + +xyz(1,1) = x_min_ +xyz(1,2) = x_max_ +xyz(2,1) = y_min_ +xyz(2,2) = y_max_ +xyz(3,1) = z_min_ +xyz(3,2) = z_max_ +!write(u6,*) +!write(u6,*) 'Box limits' +!write(u6,*) 'x:',xyz(1,1),xyz(1,2) +!write(u6,*) 'y:',xyz(2,1),xyz(2,2) +!write(u6,*) 'z:',xyz(3,1),xyz(3,2) + +! Set extremal values + +xyz0(1,1) = One +xyz0(1,2) = -One +xyz0(2,1) = One +xyz0(2,2) = -One +xyz0(3,1) = One +xyz0(3,2) = -One + +do ix=1,3 + iy = ix+1 + if (iy > 3) iy = 1 + iz = iy+1 + if (iz > 3) iz = 1 + + xMax = xyz(ix,2) + xMin = xyz(ix,1) + !write(u6,*) + Roots(1,iy) = xyz(iy,1) + Roots(2,iy) = xyz(iy,2) + if (xyz(iy,1)*xyz(iy,2) < Zero) then + ny_Roots = 3 + Roots(3,iy) = Zero + else + ny_Roots = 2 + end if + Roots(1,iz) = xyz(iz,1) + Roots(2,iz) = xyz(iz,2) + if (xyz(iz,1)*xyz(iz,2) < Zero) then + nz_Roots = 3 + Roots(3,iz) = Zero + else + nz_Roots = 2 + end if + !call RecPrt('Roots','(3G25.12)',Roots,3,3) + + do i=1,ny_Roots + !write(u6,*) 'i=',i,ny_Roots + !write(u6,*) + y = Roots(i,iy) + do j=1,nz_Roots + !write(u6,*) 'j=',j,nz_Roots + z = Roots(j,iz) + + x = xMin + r = sqrt(x**2+y**2+z**2) + !write(u6,*) x/r + if (r == Zero) then + x_r = Zero + else + x_r = x/r + end if + xyz0(ix,1) = min(xyz0(ix,1),x_r) + xyz0(ix,2) = max(xyz0(ix,2),x_r) + + x = xMax + r = sqrt(x**2+y**2+z**2) + !write(u6,*) x/r + if (r == Zero) then + x_r = Zero + else + x_r = x/r + end if + xyz0(ix,1) = min(xyz0(ix,1),x_r) + xyz0(ix,2) = max(xyz0(ix,2),x_r) + + end do + end do +end do + +!write(u6,*) 'xMin=',xyz0(1,1) +!write(u6,*) 'xMax=',xyz0(1,2) +!write(u6,*) 'yMin=',xyz0(2,1) +!write(u6,*) 'yMax=',xyz0(2,2) +!write(u6,*) 'zMin=',xyz0(3,1) +!write(u6,*) 'zMax=',xyz0(3,2) +xMin_ = xyz0(1,1)-Delta +xMax_ = xyz0(1,2)+Delta +yMin_ = xyz0(2,1)-Delta +yMax_ = xyz0(2,2)+Delta +zMin_ = xyz0(3,1)-Delta +zMax_ = xyz0(3,2)+Delta + +return + +end subroutine Box_On_Sphere diff -Nru openmolcas-22.02/src/nq_util/calcorboff.F90 openmolcas-22.10/src/nq_util/calcorboff.F90 --- openmolcas-22.02/src/nq_util/calcorboff.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/calcorboff.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,61 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Jie J. Bao * +!*********************************************************************** + +! **************************************************************** +! history: * +! Jie J. Bao, on Dec. 08, 2021, created this file. * +! **************************************************************** +subroutine CalcOrbOff() + +use nq_Info, only: iOff_Ash, iOff_Bas, iOff_BasAct, mBas, mIrrep, mOrb, NASH, NASHT, nFro, nIsh, nOrbt, nPot1, OffBas, OffBas2, & + OffBasFro, OffOrb, OffOrb2, OffOrbTri +use Definitions, only: iwp + +implicit none +integer(kind=iwp) :: iIrrep, jOffA_, jOffB_, nTri + +NASHT = 0 +jOffA_ = 0 +jOffB_ = 0 +nPot1 = 0 +nTri = 0 +nOrbt = 0 +do iIrrep=0,mIrrep-1 + mOrb(iIrrep) = mBas(iIrrep)-nFro(iIrrep) + nPot1 = nPot1+mOrb(iIrrep)**2 + nOrbt = nOrbt+mOrb(iIrrep) + NASHT = NASHT+NASH(iIrrep) + iOff_Ash(iIrrep) = jOffA_ + iOff_Bas(iIrrep) = jOffB_ + OffBasFro(iIrrep) = jOffB_+nFro(iIrrep) + iOff_BasAct(iIrrep) = jOffB_+nIsh(iIrrep)+nFro(iIrrep) + OffOrbTri(iIrrep) = nTri + nTri = nTri+mOrb(iIrrep)*(mOrb(iIrrep)+1)/2 + jOffA_ = jOffA_+nAsh(iIrrep) + jOffB_ = jOffB_+mBas(iIrrep) +end do + +OffOrb(0) = 0 +OffBas(0) = 1 +OffBas2(0) = 1 +OffOrb2(0) = 0 +do IIrrep=1,mIrrep-1 + OffBas(iIrrep) = OffBas(iIrrep-1)+mBas(iIrrep-1) + OffOrb(iIrrep) = OffOrb(iIrrep-1)+mOrb(iIrrep-1) + OffBas2(iIrrep) = OffBas2(iIrrep-1)+mBas(iIrrep-1)**2 + OffOrb2(iIrrep) = OffOrb2(iIrrep-1)+mOrb(iIrrep-1)**2 +end do + +return + +end subroutine CalcOrbOff diff -Nru openmolcas-22.02/src/nq_util/calcp2mocube.F90 openmolcas-22.10/src/nq_util/calcp2mocube.F90 --- openmolcas-22.02/src/nq_util/calcp2mocube.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/calcp2mocube.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,100 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Jie J. Bao * +!*********************************************************************** + +! **************************************************************** +! history: * +! Jie J. Bao, on Dec. 08, 2021, created this file. * +! **************************************************************** +subroutine CalcP2MOCube(P2MOCube,P2MOCubex,P2MOCubey,P2MOCubez,nPMO3p,MOs,MOx,MOy,MOz,TabMO,P2Unzip,mAO,mGrid,nMOs,do_grad) + +use nq_pdft, only: lft, lGGA +use nq_Info, only: IOff_Ash, IOff_BasAct, mIrrep, nAsh, NASHT +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nPMO3p, mAO, mGrid, nMOs +real(kind=wp), intent(out) :: P2MOCube(NASHT,mGrid), P2MOCubex(NASHT,nPMO3p), P2MOCubey(NASHT,nPMO3p), P2MOCubez(NASHT,nPMO3p), & + MOs(NASHT,mGrid), MOx(NASHT,mGrid), MOy(NASHT,mGrid), MOz(NASHT,mGrid) +real(kind=wp), intent(in) :: TabMO(mAO,mGrid,nMOs), P2Unzip(NASHT,NASHT,NASHT,NASHT) +logical(kind=iwp), intent(in) :: do_grad +integer(kind=iwp) :: IIrrep, iGrid, IOff1, IOff2, NASHT2, NASHT3 +logical(kind=iwp) :: lftGGA +real(kind=wp), allocatable :: P2MO1(:), P2MOSquare(:) + +lftGGA = .false. +if (lft .and. lGGA) lftGGA = .true. +do iGrid=1,mGrid + do iIrrep=0,mIrrep-1 + IOff1 = IOff_Ash(iIrrep) + IOff2 = IOff_BasAct(iIrrep) + MOs(IOff1+1:IOff1+nAsh(iIrrep),iGrid) = TabMO(1,iGrid,IOff2+1:IOff2+nAsh(iIrrep)) + end do +end do + +if (lGGA) then + do iGrid=1,mGrid + do iIrrep=0,mIrrep-1 + IOff1 = IOff_Ash(iIrrep) + IOff2 = IOff_BasAct(iIrrep) + MOx(IOff1+1:IOff1+nAsh(iIrrep),iGrid) = TabMO(2,iGrid,IOff2+1:IOff2+nAsh(iIrrep)) + MOy(IOff1+1:IOff1+nAsh(iIrrep),iGrid) = TabMO(3,iGrid,IOff2+1:IOff2+nAsh(iIrrep)) + MOz(IOff1+1:IOff1+nAsh(iIrrep),iGrid) = TabMO(4,iGrid,IOff2+1:IOff2+nAsh(iIrrep)) + end do + end do +end if + +NASHT2 = NASHT**2 +NASHT3 = NASHT2*NASHT +call mma_allocate(P2MO1,NASHT3,label='P2MO1') +call mma_allocate(P2MOSquare,NASHT2,label='P2MOSquare') +do iGrid=1,mGrid + + !call RecPrt('MOs array','(10(F9.5,1X))',MOs(:,iGrid),1,NASHT) + + !call RecPrt('2RDM array','(10(F9.5,1X))',P2Unzip,NASHT3,NASHT) + + call DGEMM_('T','N',NASHT3,1,NASHT,One,P2UnZip,NASHT,MOs(:,iGrid),NASHT,Zero,P2MO1,NASHT3) + + !call RecPrt('P2MO1 array','(10(F9.5,1X))',P2MO1,NASHT2,NASHT) + + call DGEMM_('T','N',NASHT2,1,NASHT,One,P2MO1,NASHT,MOs(:,iGrid),NASHT,Zero,P2MOSquare,NASHT2) + + !call RecPrt('P2MOSquare array','(10(F9.5,1X))',P2MOSquare,NASHT,NASHT) + + call DGEMM_('T','N',NASHT,1,NASHT,One,P2MOSquare,NASHT,MOs(:,iGrid),NASHT,Zero,P2MOCube(:,iGrid),NASHT) + + if (lftGGA .and. Do_Grad) then + call DGEMM_('T','N',NASHT,1,NASHT,One,P2MOSquare,NASHT,MOx(:,iGrid),NASHT,Zero,P2MOCubex(:,iGrid),NASHT) + call DGEMM_('T','N',NASHT,1,NASHT,One,P2MOSquare,NASHT,MOy(:,iGrid),NASHT,Zero,P2MOCubey(:,iGrid),NASHT) + call DGEMM_('T','N',NASHT,1,NASHT,One,P2MOSquare,NASHT,MOz(:,iGrid),NASHT,Zero,P2MOCubez(:,iGrid),NASHT) + + call DGEMM_('T','N',NASHT2,1,NASHT,One,P2MO1,NASHT,MOx(:,iGrid),NASHT,Zero,P2MOSquare,NASHT2) + call DGEMM_('T','N',NASHT,1,NASHT,Two,P2MOSquare,NASHT,MOs(:,iGrid),NASHT,One,P2MOCubex(:,iGrid),NASHT) + + call DGEMM_('T','N',NASHT2,1,NASHT,One,P2MO1,NASHT,MOy(:,iGrid),NASHT,Zero,P2MOSquare,NASHT2) + call DGEMM_('T','N',NASHT,1,NASHT,Two,P2MOSquare,NASHT,MOs(:,iGrid),NASHT,One,P2MOCubey(:,iGrid),NASHT) + + call DGEMM_('T','N',NASHT2,1,NASHT,One,P2MO1,NASHT,MOz(:,iGrid),NASHT,Zero,P2MOSquare,NASHT2) + call DGEMM_('T','N',NASHT,1,NASHT,Two,P2MOSquare,NASHT,MOs(:,iGrid),NASHT,One,P2MOCubez(:,iGrid),NASHT) + end if + + !call RecPrt('P2MOCube','(10(F9.5,1X))',P2MOCube(:,iGrid),1,NASHT) +end do +call mma_deallocate(P2MO1) +call mma_deallocate(P2MOSquare) + +return + +end subroutine CalcP2MOCube diff -Nru openmolcas-22.02/src/nq_util/calc_pot1.f openmolcas-22.10/src/nq_util/calc_pot1.f --- openmolcas-22.02/src/nq_util/calc_pot1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/calc_pot1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,207 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2021, Jie J. Bao * -************************************************************************ -* **************************************************************** -* history: * -* Jie J. Bao, on Dec. 22, 2021, created this file. * -* **************************************************************** - Subroutine Calc_Pot1(Pot1,TabMO,mAO,mGrid,nMOs,P2_ontop, - & nP2_ontop, - & MOs) - use nq_Grid, only: GradRho,Weights - use nq_Grid, only: vRho, vSigma - use nq_pdft - use nq_Info -#include "ksdft.fh" -#include "stdalloc.fh" -******Input - INTEGER mAO,mGrid,nMOs,nP2_ontop - Real*8,DIMENSION(mAO,mGrid,nMOs)::TabMO - Real*8,DIMENSION(mGrid*nOrbt)::MOs - Real*8,DIMENSION(nP2_ontop,mGrid)::P2_ontop -******Output - Real*8,DIMENSION(nPot1)::Pot1 -******Internal - Real*8,DIMENSION(:),Allocatable::PreMO - Real*8 dF_dRhoax,dF_dRhoay,dF_dRhoaz, - & dF_dRhobx,dF_dRhoby,dF_dRhobz, - & dRdx,dRdy,dRdz,Diff1,dEdRhop2 -C PreMO is MO multiplied with things needed for potential -C calculation - INTEGER iGrid,iOff1,iMO,iOrb - - - CALL mma_allocate(PreMO,mGrid*nOrbt) - CALL dcopy_(mGrid*nOrbt,MOs,1,PreMO,1) - - -C black terms in the notes - DO iGrid=1,mGrid - IF(Pass1(iGrid)) THEN - dF_dRhoapb(iGrid)=vRho(1,iGrid)+vRho(2,iGrid) - dF_dRhoamb(iGrid)=vRho(1,iGrid)-vRho(2,iGrid) - dRdRho(iGrid)=RatioA(iGrid)*(-2.0d0/RhoAB(iGrid)) - dZdRho(iGrid)=dZdR(iGrid)*dRdRho(iGrid) - dEdRho(iGrid)=dF_dRhoapb(iGrid)+dF_dRhoamb(iGrid)* - & (ZetaA(iGrid)+RhoAB(iGrid)*dZdRho(iGrid)) - dRdPi(iGrid)=4.0d0/RhoAB(iGrid)**2 - ELSE - dRdPi(iGrid)=0.0d0 - dF_dRhoapb(iGrid)=0.0d0 - dF_dRhoamb(iGrid)=0.0d0 - dEdRho(iGrid)=0.0d0 - END IF - END DO - -C red terms in the notes - IF(lGGA) THEN - DO iGrid=1,mGrid - If(Pass1(iGrid)) Then - dF_dRhoax=2.0D0*vSigma(1,iGrid)*GradRho(1,iGrid)+ - & vSigma(2,iGrid)*GradRho(4,iGrid) - dF_dRhobx=2.0D0*vSigma(3,iGrid)*GradRho(4,iGrid)+ - & vSigma(2,iGrid)*GradRho(1,iGrid) - dF_dRhoay=2.0D0*vSigma(1,iGrid)*GradRho(2,iGrid)+ - & vSigma(2,iGrid)*GradRho(5,iGrid) - dF_dRhoby=2.0D0*vSigma(3,iGrid)*GradRho(5,iGrid)+ - & vSigma(2,iGrid)*GradRho(2,iGrid) - dF_dRhoaz=2.0D0*vSigma(1,iGrid)*GradRho(3,iGrid)+ - & vSigma(2,iGrid)*GradRho(6,iGrid) - dF_dRhobz=2.0D0*vSigma(3,iGrid)*GradRho(6,iGrid)+ - & vSigma(2,iGrid)*GradRho(3,iGrid) - dF_dRhoxapb(iGrid)=dF_dRhoax+dF_dRhobx - dF_dRhoxamb(iGrid)=dF_dRhoax-dF_dRhobx - dF_dRhoyapb(iGrid)=dF_dRhoay+dF_dRhoby - dF_dRhoyamb(iGrid)=dF_dRhoay-dF_dRhoby - dF_dRhozapb(iGrid)=dF_dRhoaz+dF_dRhobz - dF_dRhozamb(iGrid)=dF_dRhoaz-dF_dRhobz - - dRhodx(iGrid)=GradRho(1,iGrid)+GradRho(4,iGrid) - dRhody(iGrid)=GradRho(2,iGrid)+GradRho(5,iGrid) - dRhodz(iGrid)=GradRho(3,iGrid)+GradRho(6,iGrid) - - GradRhodFdRho(iGrid)= - & (dF_dRhoxamb(iGrid)*dRhodx(iGrid)+ - & dF_dRhoyamb(iGrid)*dRhody(iGrid)+ - & dF_dRhozamb(iGrid)*dRhodz(iGrid)) - dEdRho(iGrid)=dEdRho(iGrid)+dZdRho(iGrid)* - & GradRhodFdRho(iGrid) - - dEdRhox(iGrid)=dF_dRhoxapb(iGrid)+ - & ZetaA(iGrid)*dF_dRhoxamb(iGrid) - dEdRhoy(iGrid)=dF_dRhoyapb(iGrid)+ - & ZetaA(iGrid)*dF_dRhoyamb(iGrid) - dEdRhoz(iGrid)=dF_dRhozapb(iGrid)+ - & ZetaA(iGrid)*dF_dRhozamb(iGrid) - - Else - dF_dRhoxapb(iGrid)=0.0d0 - dF_dRhoxamb(iGrid)=0.0d0 - dF_dRhoyapb(iGrid)=0.0d0 - dF_dRhoyamb(iGrid)=0.0d0 - dF_dRhozapb(iGrid)=0.0d0 - dF_dRhozamb(iGrid)=0.0d0 - GradRhodFdRho(iGrid)=0.0d0 - dEdRhox(iGrid)=0.0d0 - dEdRhoy(iGrid)=0.0d0 - dEdRhoz(iGrid)=0.0d0 - End If - END DO -C green and blue terms in the notes - If(lft) Then - DO iGrid=1,mGrid - if(Pass1(iGrid)) then - dRdX=dRdRho(iGrid)*dRhodX(iGrid)+ - & dRdPi(iGrid) *P2_ontop(2,iGrid) - dRdY=dRdRho(iGrid)*dRhodY(iGrid)+ - & dRdPi(iGrid) *P2_ontop(3,iGrid) - dRdZ=dRdRho(iGrid)*dRhodZ(iGrid)+ - & dRdPi(iGrid) *P2_ontop(4,iGrid) - GradRdFdRho(iGrid)=dRdX*dF_dRhoxamb(iGrid)+ - & dRdY*dF_dRhoyamb(iGrid)+ - & dRdZ*dF_dRhozamb(iGrid) - GradPidFdRho(iGrid)= - & P2_ontop(2,iGrid)*dF_dRhoxamb(iGrid)+ - & P2_ontop(3,iGrid)*dF_dRhoyamb(iGrid)+ - & P2_ontop(4,iGrid)*dF_dRhozamb(iGrid) - d2RdRho2(iGrid)=6.0d0*RatioA(iGrid)/RhoAB(iGrid)**2 - d2RdRhodPi(iGrid)=-2.0d0*dRdPi(iGrid)/RhoAB(iGrid) - if(Pass2(iGrid)) then - d2ZdR2(iGrid)=2.0d0*dZdR(iGrid)**3 - else if(Pass3(iGrid)) then - Diff1=RatioA(iGrid)-ThrsNT - d2ZdR2(iGrid)= - & (2.0d1*fta*Diff1**2+1.2d1*ftb*Diff1+6.0d0*ftc)*Diff1 - else - d2ZdR2(iGrid)=0.0d0 - end if - dEdRho(iGrid)=dEdRho(iGrid)+ - & (dZdR(iGrid)+RhoAB(iGrid)*d2ZdR2(iGrid)*dRdRho(iGrid))* - & GradRdFdRho(iGrid)+ - & RhoAB(iGrid)*dZdR(iGrid)*d2RdRho2(iGrid)* - & GradRhodFdRho(iGrid)+ - & RhoAB(iGrid)*dZdR(iGrid)*d2RdRhodPi(iGrid)*GradPidFdRho(iGrid) - dEdRhop2=RhoAB(iGrid)*dZdRho(iGrid) -C end of dEdRho term -C now dEdRhoprime terms - dEdRhox(iGrid)=dEdRhox(iGrid)+dEdRhop2*dF_dRhoxamb(iGrid) - dEdRhoy(iGrid)=dEdRhoy(iGrid)+dEdRhop2*dF_dRhoyamb(iGrid) - dEdRhoz(iGrid)=dEdRhoz(iGrid)+dEdRhop2*dF_dRhozamb(iGrid) - else - GradRdFdRho(iGrid)=0.0d0 - GradPidFdRho(iGrid)=0.0d0 - d2RdRho2(iGrid)=0.0d0 - d2RdRhodPi(iGrid)=0.0d0 - d2ZdR2(iGrid)=0.0d0 - end if - END DO - End If - END IF - - CALL DScal_(mGrid,0.5d0,dEdRho,1) - - DO iGrid=1,mGrid - CALL DScal_(nOrbt,dEdRho(iGrid),PreMO(iGrid),mGrid) - END DO - - IF(lGGA) THEN - DO iIrrep=0,mIrrep-1 - Do iOrb=1,mOrb(iIrrep) - IOff1=(iOrb+OffOrb(iIrrep)-1)*mGrid - iMO=iOrb+OffBasFro(iIrrep) - do iGrid=1,mGrid - PreMO(IOff1+iGrid)=PreMO(IOff1+iGrid)+ - & TabMO(2,iGrid,iMO)*dEdRhox(iGrid)+ - & TabMO(3,iGrid,iMO)*dEdRhoy(iGrid)+ - & TabMO(4,iGrid,iMO)*dEdRhoz(iGrid) - end do - End Do - END DO - END IF - - DO iGrid=1,mGrid - CALL DScal_(nOrbt,Weights(iGrid),PreMO(iGrid),mGrid) - END DO - - DO iIrrep=0,mIrrep-1 - IOff1=OffOrb(iIrrep)*mGrid+1 - IOff2=OffOrb2(iIrrep)+1 - CALL DGEMM_('T','N',mOrb(iIrrep),mOrb(iIrrep),mGrid,1.0d0, - & PreMO(IOff1),mGrid,MOs(IOff1),mGrid, - & 1.0d0,Pot1(iOff2),mOrb(iIrrep)) - END DO - - CALL mma_deallocate(PreMO) - - - RETURN - End Subroutine diff -Nru openmolcas-22.02/src/nq_util/calc_pot1.F90 openmolcas-22.10/src/nq_util/calc_pot1.F90 --- openmolcas-22.02/src/nq_util/calc_pot1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/calc_pot1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,173 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Jie J. Bao * +!*********************************************************************** + +! **************************************************************** +! history: * +! Jie J. Bao, on Dec. 22, 2021, created this file. * +! **************************************************************** +subroutine Calc_Pot1(Pot1,TabMO,mAO,mGrid,nMOs,P2_ontop,nP2_ontop,MOs) + +use nq_Grid, only: GradRho, vRho, vSigma, Weights +use nq_pdft, only: d2RdRho2, d2RdRhodPi, d2ZdR2, dEdRho, dEdRhox, dEdRhoy, dEdRhoz, dF_dRhoapb, dF_dRhoamb, dF_dRhoxamb, & + dF_dRhoxapb, dF_dRhoyamb, dF_dRhoyapb, dF_dRhozamb, dF_dRhozapb, dRdPi, dRdRho, dRhodx, dRhody, dRhodz, dZdR, & + dZdRho, fta, ftb, ftc, GradPidFdRho, GradRdFdRho, GradRhodFdRho, lft, lGGA, Pass1, Pass2, Pass3, RatioA, RhoAB, & + ThrsNT, ZetaA +use nq_Info, only: mIrrep, mOrb, nOrbt, nPot1, OffBasFro, OffOrb, OffOrb2 +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Four, Six, Twelve, Half +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(inout) :: Pot1(nPot1) +integer(kind=iwp), intent(in) :: mAO, mGrid, nMOs, nP2_ontop +real(kind=wp), intent(in) :: TabMO(mAO,mGrid,nMOs), MOs(mGrid,nOrbt), P2_ontop(nP2_ontop,mGrid) +integer(kind=iwp) :: iGrid, iIrrep, iMO, iOff1, IOff2, iOrb +real(kind=wp) :: dEdRhop2, dF_dRhoax, dF_dRhoay, dF_dRhoaz, dF_dRhobx, dF_dRhoby, dF_dRhobz, Diff1, dRdx, dRdy, dRdz +! PreMO is MO multiplied with things needed for potential calculation +real(kind=wp), allocatable :: PreMO(:,:) + +call mma_allocate(PreMO,mGrid,nOrbt) +PreMO(:,:) = MOs + +! black terms in the notes +do iGrid=1,mGrid + if (Pass1(iGrid)) then + dF_dRhoapb(iGrid) = vRho(1,iGrid)+vRho(2,iGrid) + dF_dRhoamb(iGrid) = vRho(1,iGrid)-vRho(2,iGrid) + dRdRho(iGrid) = RatioA(iGrid)*(-Two/RhoAB(iGrid)) + dZdRho(iGrid) = dZdR(iGrid)*dRdRho(iGrid) + dEdRho(iGrid) = dF_dRhoapb(iGrid)+dF_dRhoamb(iGrid)*(ZetaA(iGrid)+RhoAB(iGrid)*dZdRho(iGrid)) + dRdPi(iGrid) = Four/RhoAB(iGrid)**2 + else + dRdPi(iGrid) = Zero + dF_dRhoapb(iGrid) = Zero + dF_dRhoamb(iGrid) = Zero + dEdRho(iGrid) = Zero + end if +end do + +! red terms in the notes +if (lGGA) then + do iGrid=1,mGrid + if (Pass1(iGrid)) then + dF_dRhoax = Two*vSigma(1,iGrid)*GradRho(1,iGrid)+vSigma(2,iGrid)*GradRho(4,iGrid) + dF_dRhobx = Two*vSigma(3,iGrid)*GradRho(4,iGrid)+vSigma(2,iGrid)*GradRho(1,iGrid) + dF_dRhoay = Two*vSigma(1,iGrid)*GradRho(2,iGrid)+vSigma(2,iGrid)*GradRho(5,iGrid) + dF_dRhoby = Two*vSigma(3,iGrid)*GradRho(5,iGrid)+vSigma(2,iGrid)*GradRho(2,iGrid) + dF_dRhoaz = Two*vSigma(1,iGrid)*GradRho(3,iGrid)+vSigma(2,iGrid)*GradRho(6,iGrid) + dF_dRhobz = Two*vSigma(3,iGrid)*GradRho(6,iGrid)+vSigma(2,iGrid)*GradRho(3,iGrid) + dF_dRhoxapb(iGrid) = dF_dRhoax+dF_dRhobx + dF_dRhoxamb(iGrid) = dF_dRhoax-dF_dRhobx + dF_dRhoyapb(iGrid) = dF_dRhoay+dF_dRhoby + dF_dRhoyamb(iGrid) = dF_dRhoay-dF_dRhoby + dF_dRhozapb(iGrid) = dF_dRhoaz+dF_dRhobz + dF_dRhozamb(iGrid) = dF_dRhoaz-dF_dRhobz + + dRhodx(iGrid) = GradRho(1,iGrid)+GradRho(4,iGrid) + dRhody(iGrid) = GradRho(2,iGrid)+GradRho(5,iGrid) + dRhodz(iGrid) = GradRho(3,iGrid)+GradRho(6,iGrid) + + GradRhodFdRho(iGrid) = (dF_dRhoxamb(iGrid)*dRhodx(iGrid)+dF_dRhoyamb(iGrid)*dRhody(iGrid)+dF_dRhozamb(iGrid)*dRhodz(iGrid)) + dEdRho(iGrid) = dEdRho(iGrid)+dZdRho(iGrid)*GradRhodFdRho(iGrid) + + dEdRhox(iGrid) = dF_dRhoxapb(iGrid)+ZetaA(iGrid)*dF_dRhoxamb(iGrid) + dEdRhoy(iGrid) = dF_dRhoyapb(iGrid)+ZetaA(iGrid)*dF_dRhoyamb(iGrid) + dEdRhoz(iGrid) = dF_dRhozapb(iGrid)+ZetaA(iGrid)*dF_dRhozamb(iGrid) + + else + dF_dRhoxapb(iGrid) = Zero + dF_dRhoxamb(iGrid) = Zero + dF_dRhoyapb(iGrid) = Zero + dF_dRhoyamb(iGrid) = Zero + dF_dRhozapb(iGrid) = Zero + dF_dRhozamb(iGrid) = Zero + GradRhodFdRho(iGrid) = Zero + dEdRhox(iGrid) = Zero + dEdRhoy(iGrid) = Zero + dEdRhoz(iGrid) = Zero + end if + end do + ! green and blue terms in the notes + if (lft) then + do iGrid=1,mGrid + if (Pass1(iGrid)) then + dRdX = dRdRho(iGrid)*dRhodX(iGrid)+dRdPi(iGrid)*P2_ontop(2,iGrid) + dRdY = dRdRho(iGrid)*dRhodY(iGrid)+dRdPi(iGrid)*P2_ontop(3,iGrid) + dRdZ = dRdRho(iGrid)*dRhodZ(iGrid)+dRdPi(iGrid)*P2_ontop(4,iGrid) + GradRdFdRho(iGrid) = dRdX*dF_dRhoxamb(iGrid)+dRdY*dF_dRhoyamb(iGrid)+dRdZ*dF_dRhozamb(iGrid) + GradPidFdRho(iGrid) = P2_ontop(2,iGrid)*dF_dRhoxamb(iGrid)+P2_ontop(3,iGrid)*dF_dRhoyamb(iGrid)+ & + P2_ontop(4,iGrid)*dF_dRhozamb(iGrid) + d2RdRho2(iGrid) = Six*RatioA(iGrid)/RhoAB(iGrid)**2 + d2RdRhodPi(iGrid) = -Two*dRdPi(iGrid)/RhoAB(iGrid) + if (Pass2(iGrid)) then + d2ZdR2(iGrid) = Two*dZdR(iGrid)**3 + else if (Pass3(iGrid)) then + Diff1 = RatioA(iGrid)-ThrsNT + d2ZdR2(iGrid) = (20.0_wp*fta*Diff1**2+Twelve*ftb*Diff1+Six*ftc)*Diff1 + else + d2ZdR2(iGrid) = Zero + end if + dEdRho(iGrid) = dEdRho(iGrid)+(dZdR(iGrid)+RhoAB(iGrid)*d2ZdR2(iGrid)*dRdRho(iGrid))*GradRdFdRho(iGrid)+ & + RhoAB(iGrid)*dZdR(iGrid)*d2RdRho2(iGrid)*GradRhodFdRho(iGrid)+ & + RhoAB(iGrid)*dZdR(iGrid)*d2RdRhodPi(iGrid)*GradPidFdRho(iGrid) + dEdRhop2 = RhoAB(iGrid)*dZdRho(iGrid) + ! end of dEdRho term + ! now dEdRhoprime terms + dEdRhox(iGrid) = dEdRhox(iGrid)+dEdRhop2*dF_dRhoxamb(iGrid) + dEdRhoy(iGrid) = dEdRhoy(iGrid)+dEdRhop2*dF_dRhoyamb(iGrid) + dEdRhoz(iGrid) = dEdRhoz(iGrid)+dEdRhop2*dF_dRhozamb(iGrid) + else + GradRdFdRho(iGrid) = Zero + GradPidFdRho(iGrid) = Zero + d2RdRho2(iGrid) = Zero + d2RdRhodPi(iGrid) = Zero + d2ZdR2(iGrid) = Zero + end if + end do + end if +end if + +dEdRho(:) = Half*dEdRho + +do iGrid=1,mGrid + PreMO(iGrid,:) = PreMO(iGrid,:)*dEdRho(iGrid) +end do + +if (lGGA) then + do iIrrep=0,mIrrep-1 + do iOrb=1,mOrb(iIrrep) + IOff1 = iOrb+OffOrb(iIrrep) + iMO = iOrb+OffBasFro(iIrrep) + do iGrid=1,mGrid + PreMO(iGrid,IOff1) = PreMO(iGrid,IOff1)+TabMO(2,iGrid,iMO)*dEdRhox(iGrid)+TabMO(3,iGrid,iMO)*dEdRhoy(iGrid)+ & + TabMO(4,iGrid,iMO)*dEdRhoz(iGrid) + end do + end do + end do +end if + +do iGrid=1,mGrid + PreMO(iGrid,:) = PreMO(iGrid,:)*Weights(iGrid) +end do + +do iIrrep=0,mIrrep-1 + IOff1 = OffOrb(iIrrep)+1 + IOff2 = OffOrb2(iIrrep)+1 + call DGEMM_('T','N',mOrb(iIrrep),mOrb(iIrrep),mGrid,One,PreMO(:,IOff1:),mGrid,MOs(:,IOff1:),mGrid,One,Pot1(iOff2:),mOrb(iIrrep)) +end do + +call mma_deallocate(PreMO) + +return + +end subroutine Calc_Pot1 diff -Nru openmolcas-22.02/src/nq_util/calc_pot2.f openmolcas-22.10/src/nq_util/calc_pot2.f --- openmolcas-22.02/src/nq_util/calc_pot2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/calc_pot2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,111 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2021, Jie J. Bao * -************************************************************************ -* **************************************************************** -* history: * -* Jie J. Bao, on Dec. 08, 2021, created this file. * -* **************************************************************** - Subroutine Calc_Pot2(Pot2,mGrid,Pi,nPi) - use nq_Grid, only: Weights - use nq_pdft - use nq_Info -#include "stdalloc.fh" -******Input - INTEGER mGrid,nPi - Real*8,DIMENSION(nPi,mGrid)::Pi -******Output - Real*8,DIMENSION(nPot2)::Pot2 -******Internal - INTEGER iGrid,nGOrb - Real*8 ThrsPi,ggaterm,ftggaterm,predEdPip - - ThrsPi=1.0d-30 - - IF(lGGA.and.lft) THEN - CALL FZero(dEdPix,mGrid) - CALL FZero(dEdPiy,mGrid) - CALL FZero(dEdPiz,mGrid) - CALL FZero(GdEdPiMO,mGrid*nOrbt) - END IF - - - DO iGrid=1,mGrid - IF(Pass1(iGrid).and.(Pi(1,iGrid).gt.ThrsPi)) THEN - If(Pass2(iGrid).or.Pass3(iGrid)) Then - if(lGGA) then - ggaterm=GradRhodFdRho(iGrid) - if(lft) then - ftggaterm=(d2ZdR2(iGrid)*dRdPi(iGrid)*GradRdFdRho(iGrid)+ - & d2RdRhodPi(iGrid)*dZdR(iGrid)*GradRhodFdRho(iGrid))* - & RhoAB(iGrid) - predEdPip=RhoAB(iGrid)*dZdR(iGrid)*dRdPi(iGrid)*Weights(iGrid) - dEdPix(iGrid)=predEdPip*dF_dRhoxamb(iGrid) - dEdPiy(iGrid)=predEdPip*dF_dRhoyamb(iGrid) - dEdPiz(iGrid)=predEdPip*dF_dRhozamb(iGrid) - else - ftggaterm=0.0d0 - end if - else - ggaterm=0.0d0 - ftggaterm=0.0d0 - end if - dEdPi(iGrid)=Weights(iGrid)*(dZdR(iGrid)*dRdPi(iGrid)* - & (RhoAB(iGrid)*dF_dRhoamb(iGrid)+ggaterm)+ftggaterm) - Else - dEdPi(iGrid)=0.0d0 - End If - ELSE - dEdPi(iGrid)=0.0d0 - END IF - END DO - nGOrb=mGrid*nOrbt - - - CALL DSCal_(mGrid,0.5d0,dEdPi,1) - IF(lGGA.and.lft) THEN - CALL DSCal_(mGrid,0.5d0,dEdPix,1) - CALL DSCal_(mGrid,0.5d0,dEdPiy,1) - CALL DSCal_(mGrid,0.5d0,dEdPiz,1) - END IF - - - CALL DCopy_(nGOrb,MOas,1,dEdPiMO,1) - - DO iGrid=1,mGrid - CALL DScal_(nOrbt,dEdPi(iGrid),dEdPiMO(iGrid),mGrid) - END DO - - IF(lft.and.lGGA) THEN - DO iGrid=1,mGrid - CALL DAXpY_(nOrbt,dEdPix(iGrid),MOax(iGrid),mGrid, - & GdEdPiMO(iGrid),mGrid) - CALL DAXpY_(nOrbt,dEdPiy(iGrid),MOay(iGrid),mGrid, - & GdEdPiMO(iGrid),mGrid) - CALL DAXpY_(nOrbt,dEdPiz(iGrid),MOaz(iGrid),mGrid, - & GdEdPiMO(iGrid),mGrid) - END DO - CALL DAXpY_(nGOrb,1.0d0,GdEdPiMO,1,dEdPiMO,1) - END IF - -* dEdPiMO is practically (Phi_p*dEdPi+Phi_p'*dEdPi') -* The subroutine below calculates -* (Phi_p*dEdPi+Phi_p'*dEdPi')*Phi_u*Phi_v*Phi_x - CALL Calc_Pot2_Inner(Pot2,mGrid,dEdPiMO,MOas,MOas,MOas,.false.) - - IF(lft.and.lGGA) THEN - CALL Calc_Pot2_Inner(Pot2,mGrid,MOas,MOas,MOas,GdEdPiMO,.true.) - END IF - - RETURN - End Subroutine - - diff -Nru openmolcas-22.02/src/nq_util/calc_pot2.F90 openmolcas-22.10/src/nq_util/calc_pot2.F90 --- openmolcas-22.02/src/nq_util/calc_pot2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/calc_pot2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,99 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Jie J. Bao * +!*********************************************************************** + +! **************************************************************** +! history: * +! Jie J. Bao, on Dec. 08, 2021, created this file. * +! **************************************************************** +subroutine Calc_Pot2(Pot2,mGrid,Pi,nPi) + +use nq_Grid, only: Weights +use nq_pdft, only: d2RdRhodPi, d2ZdR2, dEdPi, dEdPiMO, dEdPix, dEdPiy, dEdPiz, dF_dRhoamb, dF_dRhoxamb, dF_dRhoyamb, dF_dRhozamb, & + dRdPi, dZdR, GdEdPiMO, GradRdFdRho, GradRhodFdRho, lft, lGGA, MOas, MOax, MOay, MOaz, Pass1, Pass2, Pass3, RhoAB +use nq_Info, only: nPot2 +use Constants, only: Zero, Half +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(inout) :: Pot2(nPot2) +integer(kind=iwp), intent(in) :: mGrid, nPi +real(kind=wp), intent(in) :: Pi(nPi,mGrid) +integer(kind=iwp) :: iGrid +real(kind=wp) :: ftggaterm, ggaterm, predEdPip +real(kind=wp), parameter :: ThrsPi = 1.0e-30_wp + +if (lGGA .and. lft) then + dEdPix(:) = Zero + dEdPiy(:) = Zero + dEdPiz(:) = Zero + GdEdPiMO(:,:) = Zero +end if + +do iGrid=1,mGrid + if (Pass1(iGrid) .and. (Pi(1,iGrid) > ThrsPi)) then + if (Pass2(iGrid) .or. Pass3(iGrid)) then + if (lGGA) then + ggaterm = GradRhodFdRho(iGrid) + if (lft) then + ftggaterm = (d2ZdR2(iGrid)*dRdPi(iGrid)*GradRdFdRho(iGrid)+ & + d2RdRhodPi(iGrid)*dZdR(iGrid)*GradRhodFdRho(iGrid))*RhoAB(iGrid) + predEdPip = RhoAB(iGrid)*dZdR(iGrid)*dRdPi(iGrid)*Weights(iGrid) + dEdPix(iGrid) = predEdPip*dF_dRhoxamb(iGrid) + dEdPiy(iGrid) = predEdPip*dF_dRhoyamb(iGrid) + dEdPiz(iGrid) = predEdPip*dF_dRhozamb(iGrid) + else + ftggaterm = Zero + end if + else + ggaterm = Zero + ftggaterm = Zero + end if + dEdPi(iGrid) = Weights(iGrid)*(dZdR(iGrid)*dRdPi(iGrid)*(RhoAB(iGrid)*dF_dRhoamb(iGrid)+ggaterm)+ftggaterm) + else + dEdPi(iGrid) = Zero + end if + else + dEdPi(iGrid) = Zero + end if +end do + +dEdPi(:) = Half*dEdPi +if (lGGA .and. lft) then + dEdPix(:) = Half*dEdPix + dEdPiy(:) = Half*dEdPiy + dEdPiz(:) = Half*dEdPiz +end if + +do iGrid=1,mGrid + dEdPiMO(iGrid,:) = MOas(iGrid,:)*dEdPi(iGrid) +end do + +if (lft .and. lGGA) then + do iGrid=1,mGrid + GdEdPiMO(iGrid,:) = GdEdPiMO(iGrid,:)+dEdPix(iGrid)*MOax(iGrid,:)+dEdPiy(iGrid)*MOay(iGrid,:)+dEdPiz(iGrid)*MOaz(iGrid,:) + end do + dEdPiMO(:,:) = dEdPiMO+GdEdPiMO +end if + +! dEdPiMO is practically (Phi_p*dEdPi+Phi_p'*dEdPi') +! The subroutine below calculates +! (Phi_p*dEdPi+Phi_p'*dEdPi')*Phi_u*Phi_v*Phi_x +call Calc_Pot2_Inner(Pot2,mGrid,dEdPiMO,MOas,MOas,MOas,.false.) + +if (lft .and. lGGA) then + call Calc_Pot2_Inner(Pot2,mGrid,MOas,MOas,MOas,GdEdPiMO,.true.) +end if + +return + +end subroutine Calc_Pot2 diff -Nru openmolcas-22.02/src/nq_util/calc_pot2inner.f openmolcas-22.10/src/nq_util/calc_pot2inner.f --- openmolcas-22.02/src/nq_util/calc_pot2inner.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/calc_pot2inner.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,166 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2021, Jie J. Bao * -************************************************************************ -* **************************************************************** -* history: * -* Jie J. Bao, on Dec. 25, 2021, created this file. * -* **************************************************************** - Subroutine Calc_Pot2_Inner(Pot2,mGrid,MOP,MOU,MOV,MOX,lSum) - use nq_Info -#include "stdalloc.fh" -******Input - INTEGER mGrid - Logical lSum -******Note: when lSum is .true., calculate P(U'VX+UV'X+UVX'), -****** otherwise calculate PUVX - Real*8,DIMENSION(mGrid*nOrbt)::MOP,MOU,MOV,MOX -******Output - Real*8,DIMENSION(nPot2)::Pot2 - -******Intermediate - Real*8,DIMENSION(:),Allocatable::MOUVX,MOVX1,MOVX2 - INTEGER iGrid,iOff0,iOff1,iOff2,iOff3,iStack, - & nnUVX,iVX, - & pIrrep,uIrrep,vIrrep,xIrrep,xMax,puIrrep, - & u,v,x,vorb,xorb,ioffu,nporb - - - CALL mma_allocate(MOVX1,nVXt*mGrid) - IF(lSum) CALL mma_allocate(MOVX2,nVXt*mGrid) - CALL mma_allocate(MOUVX,nUVXt*mGrid) - - DO vIrrep=0,mIrrep-1 - DO xIrrep=0,vIrrep - Do v=1,nAsh(vIrrep) - vorb=v+OffOrb(vIrrep)+nIsh(vIrrep) - IOff1=(vorb-1)*mGrid - IF(xIrrep.eq.vIrrep) THEN - xMax=v - iStack=v*(v-1)/2 - ELSE - xMax=nAsh(xIrrep) - iStack=(v-1)*xMax - END IF - Do x=1,xMax - xorb=x+OffOrb(xIrrep)+nIsh(xIrrep) - IOff2=(xorb-1)*mGrid - IOff3=(OffVX(xIrrep,vIrrep)+iStack+x-1)*mGrid - do iGrid=1,mGrid - MOVX1(iGrid+IOff3)=MOV(iGrid+IOff1)*MOX(iGrid+IOff2) - end do - End Do - End Do - END DO - END DO - - - IF(lSum) THEN - DO vIrrep=0,mIrrep-1 - DO xIrrep=0,vIrrep - Do v=1,nAsh(vIrrep) - vorb=v+OffOrb(vIrrep)+nIsh(vIrrep) - IOff1=(vorb-1)*mGrid - If(xIrrep.eq.vIrrep) Then - xMax=v - iStack=v*(v-1)/2 - Else - xMax=nAsh(xIrrep) - iStack=(v-1)*xMax - End if - Do x=1,xMax - xorb=x+OffOrb(xIrrep)+nIsh(xIrrep) - IOff2=(xorb-1)*mGrid - IOff3=(OffVX(xIrrep,vIrrep)+iStack+x-1)*mGrid - do iGrid=1,mGrid - MOVX1(iGrid+IOff3)=MOVX1(iGrid+IOff3)+ - & MOX(iGrid+IOff1)*MOV(iGrid+IOff2) - MOVX2(iGrid+IOff3)=MOU(iGrid+IOff1)*MOV(iGrid+IOff2) - end do - End Do - End Do - END DO - END DO - END IF - - - - DO uIrrep=0,mIrrep-1 - IOffU=OffOrb(uIrrep)+nIsh(uIrrep) - DO vIrrep=0,mIrrep-1 - DO xIrrep=0,vIrrep - Do iVX=1,nVX(xIrrep,vIrrep) - IOff1=(Offvx(xIrrep,vIrrep)+iVX-1)*mGrid - IOff0=OffUVX(xIrrep,vIrrep,uIrrep)+(iVX-1)*nAsh(uIrrep) - Do u=1,nAsh(uIrrep) - IOff2=(iOffU+u-1)*mGrid - IOff3=(IOff0+u-1)*mGrid - do iGrid=1,mGrid - MOUVX(iGrid+IOff3)=MOU(iGrid+IOff2)*MOVX1(iGrid+IOff1) - end do - End Do - End Do - End Do - END DO - END DO - - IF(lSum) THEN - DO uIrrep=0,mIrrep-1 - IOffU=OffOrb(uIrrep)+nIsh(uIrrep) - DO vIrrep=0,mIrrep-1 - DO xIrrep=0,vIrrep - Do iVX=1,nVX(xIrrep,vIrrep) - IOff1=(Offvx(xIrrep,vIrrep)+iVX-1)*mGrid - IOff0=OffUVX(xIrrep,vIrrep,uIrrep)+(iVX-1)*nAsh(uIrrep) - Do u=1,nAsh(uIrrep) - IOff2=(iOffU+u-1)*mGrid - IOff3=(IOff0+u-1)*mGrid - do iGrid=1,mGrid - MOUVX(iGrid+IOff3)=MOUVX(iGrid+IOff3)+ - & MOX(iGrid+IOff2)*MOVX2(iGrid+IOff1) - end do - End Do - End Do - End Do - END DO - END DO - END IF - -******Use dgemm to calculate PUVX at this grid point - DO pIrrep=0,mIrrep-1 - nporb=mOrb(pIrrep) - IF(nporb.eq.0) CYCLE - IF(nAsh(pIrrep).eq.0) CYCLE - IOff1=OffOrb(pIrrep)*mGrid+1 - IOff2=OffPUVX(pIrrep)+1 - DO uIrrep=0,mIrrep-1 - puIrrep=IEOR(pIrrep,uIrrep) - DO vIrrep=0,mIrrep-1 - xIrrep=IEOR(puIrrep,vIrrep) - nnUVX=nUVX(xIrrep,vIrrep,uIrrep) - IF((xIrrep.gt.vIrrep).or.(nnUVX.eq.0)) CYCLE - IOff3=OffUVX(xIrrep,vIrrep,uIrrep)*mGrid+1 - CALL DGEMM_('T','N',npOrb,nnUVX,mGrid, - & 1.0d0,MOP(iOff1),mGrid,MOUVX(IOff3),mGrid, - & 1.0d0,Pot2(iOff2),npOrb) - IOff2=IOff2+nnUVX*npOrb - END DO - END DO - END DO - - - - CALL mma_deallocate(MOVX1) - IF(lSum) CALL mma_deallocate(MOVX2) - CALL mma_deallocate(MOUVX) - - RETURN - End Subroutine diff -Nru openmolcas-22.02/src/nq_util/calc_pot2_inner.F90 openmolcas-22.10/src/nq_util/calc_pot2_inner.F90 --- openmolcas-22.02/src/nq_util/calc_pot2_inner.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/calc_pot2_inner.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,137 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Jie J. Bao * +!*********************************************************************** + +! **************************************************************** +! history: * +! Jie J. Bao, on Dec. 25, 2021, created this file. * +! **************************************************************** +subroutine Calc_Pot2_Inner(Pot2,mGrid,MOP,MOU,MOV,MOX,lSum) + +use nq_Info, only: mIrrep, mOrb, nAsh, nIsh, nOrbt, nPot2, nUVX, nUVXt, nVX, nVXt, OffOrb, OffPUVX, OffUVX, OffVX +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(inout) :: Pot2(nPot2) +integer(kind=iwp), intent(in) :: mGrid +real(kind=wp), intent(in) :: MOP(mGrid,nOrbt), MOU(mGrid,nOrbt), MOV(mGrid,nOrbt), MOX(mGrid,nOrbt) +logical(kind=iwp) :: lSum +! Note: when lSum is .true., calculate P(U'VX+UV'X+UVX'), otherwise calculate PUVX +integer(kind=iwp) :: iOff0, iOff1, iOff2, iOff3, ioffu, iStack, iVX, nnUVX, nporb, pIrrep, puIrrep, u, uIrrep, v, vIrrep, vorb, x, & + xIrrep, xMax, xorb +real(kind=wp), allocatable :: MOUVX(:,:), MOVX1(:,:), MOVX2(:,:) + +call mma_allocate(MOVX1,mGrid,nVXt) +if (lSum) call mma_allocate(MOVX2,mGrid,nVXt) +call mma_allocate(MOUVX,mGrid,nUVXt) + +do vIrrep=0,mIrrep-1 + do xIrrep=0,vIrrep + do v=1,nAsh(vIrrep) + vorb = v+OffOrb(vIrrep)+nIsh(vIrrep) + if (xIrrep == vIrrep) then + xMax = v + iStack = v*(v-1)/2 + else + xMax = nAsh(xIrrep) + iStack = (v-1)*xMax + end if + do x=1,xMax + xorb = x+OffOrb(xIrrep)+nIsh(xIrrep) + MOVX1(:,OffVX(xIrrep,vIrrep)+iStack+x) = MOV(:,vorb)*MOX(:,xorb) + end do + end do + end do +end do + +if (lSum) then + do vIrrep=0,mIrrep-1 + do xIrrep=0,vIrrep + do v=1,nAsh(vIrrep) + vorb = v+OffOrb(vIrrep)+nIsh(vIrrep) + if (xIrrep == vIrrep) then + xMax = v + iStack = v*(v-1)/2 + else + xMax = nAsh(xIrrep) + iStack = (v-1)*xMax + end if + do x=1,xMax + xorb = x+OffOrb(xIrrep)+nIsh(xIrrep) + IOff3 = (OffVX(xIrrep,vIrrep)+iStack+x-1)*mGrid + MOVX1(:,OffVX(xIrrep,vIrrep)+iStack+x) = MOVX1(:,OffVX(xIrrep,vIrrep)+iStack+x)+MOX(:,vorb)*MOV(:,xorb) + MOVX2(:,OffVX(xIrrep,vIrrep)+iStack+x) = MOU(:,vorb)*MOV(:,xorb) + end do + end do + end do + end do +end if + +do uIrrep=0,mIrrep-1 + IOffU = OffOrb(uIrrep)+nIsh(uIrrep) + do vIrrep=0,mIrrep-1 + do xIrrep=0,vIrrep + do iVX=1,nVX(xIrrep,vIrrep) + IOff0 = OffUVX(xIrrep,vIrrep,uIrrep)+(iVX-1)*nAsh(uIrrep) + do u=1,nAsh(uIrrep) + MOUVX(:,IOff0+u) = MOU(:,iOffU+u)*MOVX1(:,Offvx(xIrrep,vIrrep)+iVX) + end do + end do + end do + end do +end do + +if (lSum) then + do uIrrep=0,mIrrep-1 + IOffU = OffOrb(uIrrep)+nIsh(uIrrep) + do vIrrep=0,mIrrep-1 + do xIrrep=0,vIrrep + do iVX=1,nVX(xIrrep,vIrrep) + IOff0 = OffUVX(xIrrep,vIrrep,uIrrep)+(iVX-1)*nAsh(uIrrep) + do u=1,nAsh(uIrrep) + MOUVX(:,IOff0+u) = MOUVX(:,IOff0+u)+MOX(:,iOffU+u)*MOVX2(:,Offvx(xIrrep,vIrrep)+iVX) + end do + end do + end do + end do + end do +end if + +! Use dgemm to calculate PUVX at this grid point +do pIrrep=0,mIrrep-1 + nporb = mOrb(pIrrep) + if (nporb == 0) cycle + if (nAsh(pIrrep) == 0) cycle + IOff1 = OffOrb(pIrrep)+1 + IOff2 = OffPUVX(pIrrep)+1 + do uIrrep=0,mIrrep-1 + puIrrep = ieor(pIrrep,uIrrep) + do vIrrep=0,mIrrep-1 + xIrrep = ieor(puIrrep,vIrrep) + nnUVX = nUVX(xIrrep,vIrrep,uIrrep) + if ((xIrrep > vIrrep) .or. (nnUVX == 0)) cycle + IOff3 = OffUVX(xIrrep,vIrrep,uIrrep)+1 + call DGEMM_('T','N',npOrb,nnUVX,mGrid,One,MOP(:,iOff1:),mGrid,MOUVX(:,IOff3:),mGrid,One,Pot2(iOff2:),npOrb) + IOff2 = IOff2+nnUVX*npOrb + end do + end do +end do + +call mma_deallocate(MOVX1) +if (lSum) call mma_deallocate(MOVX2) +call mma_deallocate(MOUVX) + +return + +end subroutine Calc_Pot2_Inner diff -Nru openmolcas-22.02/src/nq_util/calcpuvxoff.F90 openmolcas-22.10/src/nq_util/calcpuvxoff.F90 --- openmolcas-22.02/src/nq_util/calcpuvxoff.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/calcpuvxoff.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,84 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Jie J. Bao * +!*********************************************************************** + +! **************************************************************** +! history: * +! Jie J. Bao, on Dec. 08, 2021, created this file. * +! **************************************************************** + +subroutine CalcPUVXOff() + +use nq_Info, only: mIrrep, mOrb, nAsh, nPot2, nUVX, nUVXt, nVX, nVXt, OffPUVX, OffUVX, OffVX +use Definitions, only: iwp + +implicit none +integer(kind=iwp) :: iIrrep, ijIrrep, IOff1, iOrb, jAct, jIrrep, kAct, kIrrep, klIrrep, lAct, lIrrep, nklAct + +IOff1 = 0 +do kIrrep=0,mIrrep-1 + kAct = nAsh(kIrrep) + do lIrrep=0,kIrrep + lAct = nAsh(lIrrep) + nklAct = kAct*lAct + if (kIrrep == lIrrep) nklAct = kAct*(kAct+1)/2 + OffVX(lIrrep,kIrrep) = IOff1 + nVX(lIrrep,kIrrep) = nklAct + IOff1 = IOff1+nklAct + end do +end do +nVXt = iOff1 + +IOff1 = 0 +do jIrrep=0,mIrrep-1 + jAct = nAsh(jIrrep) + do kIrrep=0,mIrrep-1 + kAct = nAsh(kIrrep) + do lIrrep=0,kIrrep + lAct = nAsh(lIrrep) + nklAct = kAct*lAct + if (kIrrep == lIrrep) nklAct = kAct*(kAct+1)/2 + OffUVX(lIrrep,kIrrep,jIrrep) = IOff1 + nUVX(lIrrep,kIrrep,jIrrep) = jAct*nklAct + IOff1 = iOff1+jAct*nklAct + end do + end do +end do +nUVXt = IOff1 + +IOff1 = 0 +do iIrrep=0,mIrrep-1 + OffPUVX(iIrrep) = IOff1 + iOrb = mOrb(iIrrep) + do jIrrep=0,mIrrep-1 + jAct = nAsh(jIrrep) + ijIrrep = 1+ieor(iIrrep,jIrrep) + do kIrrep=0,mIrrep-1 + kAct = nAsh(kIrrep) + do lIrrep=0,kIrrep + lAct = nAsh(lIrrep) + klIrrep = 1+ieor(kIrrep,lIrrep) + if (ijIrrep == klIrrep) then + iOff1 = iOff1+iOrb*nUVX(lIrrep,kIrrep,jIrrep) + end if + end do + end do + end do +end do +nPot2 = IOff1 + +!write(u6,*) 'OffPUVX new method',nPot2,MaxUVX +!write(u6,'(8(I5,2X))') (OffPUVX(iIrrep),iIrrep=0,mIrrep-1) + +return + +end subroutine CalcPUVXOff diff -Nru openmolcas-22.02/src/nq_util/CMakeLists.txt openmolcas-22.10/src/nq_util/CMakeLists.txt --- openmolcas-22.02/src/nq_util/CMakeLists.txt 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -9,4 +9,109 @@ # LICENSE or in . * #*********************************************************************** +set (sources + allok2_funi.F90 + angular_grid.F90 + angular_prune.F90 + anmesh.F90 + aoadd_full.F90 + box_on_sphere.F90 + calcorboff.F90 + calcp2mocube.F90 + calc_pot1.F90 + calc_pot2.F90 + calc_pot2_inner.F90 + calcpuvxoff.F90 + comp_d.F90 + compute_d2mdx2.F90 + compute_d2odx2.F90 + compute_dmdx.F90 + compute_dodx.F90 + compute_grad.F90 + compute_m.F90 + compute_o.F90 + compute_rho.F90 + compute_tau.F90 + compute_t.F90 + converttabso.F90 + dede_funi.F90 + dft_grad.F90 + dft_int.F90 + do_batch.F90 + do_grid.F90 + do_index.F90 + do_nint_d.F90 + do_nintx.F90 + do_pi2.F90 + do_pi2grad.F90 + drvnq.F90 + drvnq_inner.F90 + dwdr.F90 + eval_rmax.F90 + eval_rmin.F90 + free_dede_funi.F90 + funi_init.F90 + funi_input.F90 + funi_print.F90 + gauleg.F90 + genradquad_b.F90 + genradquad_mhl.F90 + genradquad_mk.F90 + genradquad_pam.F90 + genradquad_ta.F90 + genvoronoi.F90 + get_subblock.F90 + g.F90 + ggl_grid.F90 + grid_on_disk.F90 + lebedev.F90 + lebedev_grid.F90 + libxc.F90 + libxc_interface.F90 + libxc_version.F90 + lobatto.F90 + lobatto_grid.F90 + mk_mos.F90 + mk_rho.F90 + mk_sos.F90 + modify_nq_grid.F90 + nbas_eff.F90 + nq_grid.F90 + nqgrid_init.F90 + nq_info.F90 + nq_init.F90 + nq_mo.F90 + nq_pdft.F90 + nq_structure.F90 + packpot1.F90 + pdftfock.F90 + pdftfock_inner.F90 + pdftmemalloc.F90 + pdftmemdealloc.F90 + phi_point.F90 + print_nq_info.F90 + process_coor.F90 + reset_nq_grid.F90 + resortd.F90 + rotgrd.F90 + setup_nq.F90 + subblock.F90 + symadp_full.F90 + transactmo2.F90 + transactmo.F90 + transfermo.F90 + translatedens.F90 + truncate_grid.F90 + unzipd1.F90 + unzipp2.F90 + w.F90 +) + +# Source files defining modules that should be available to other *_util directories +set (modfile_list + libxc.F90 + nq_grid.F90 + nq_info.F90 +) + include (${PROJECT_SOURCE_DIR}/cmake/util_template.cmake) diff -Nru openmolcas-22.02/src/nq_util/comp_d.f openmolcas-22.10/src/nq_util/comp_d.f --- openmolcas-22.02/src/nq_util/comp_d.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/comp_d.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) Giovanni Li Manni * -************************************************************************ - Real*8 Function Comp_d(Weights,mGrid,Rho,nRho,iSpin,iSwitch) -************************************************************************ -* * -* Object: integrate densities (alpha, beta, total, gradients....) * -* the object integrated is dictaded by iSwitch value: * -* iSwitch = 0 .... total density * -* iSwitch = 1 .... alpha density * -* iSwitch = 2 .... beta density * -* * -* Author: G. Li Manni... taking Sir R. Lindh as model * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - Real*8 Weights(mGrid), Rho(nRho,mGrid) -* - Comp_d=Zero -************************************************************************ -* iSpin=1 -************************************************************************ - If (iSpin.eq.1) Then - Do iGrid = 1, mGrid - d_alpha=half*Rho(1,iGrid) - if(iSwitch.eq.1) then - DTot=d_alpha - else if(iSwitch.eq.2) then - DTot=d_alpha - else !if(iSwitch.eq.0) then - DTot=Two*d_alpha - end if - Comp_d = Comp_d + DTot*Weights(iGrid) - End Do -************************************************************************ -* iSpin=/=1 -************************************************************************ - Else - Do iGrid = 1, mGrid - d_alpha=Rho(1,iGrid) - d_beta =Rho(2,iGrid) - if(iSwitch.eq.1) then - DTot=d_alpha - else if(iSwitch.eq.2) then - DTot=d_beta - else !if(iSwitch.eq.0) then - DTot=d_alpha+d_beta - end if - Comp_d = Comp_d + DTot*Weights(iGrid) - End Do - End If -************************************************************************ - Return - End diff -Nru openmolcas-22.02/src/nq_util/comp_d.F90 openmolcas-22.10/src/nq_util/comp_d.F90 --- openmolcas-22.02/src/nq_util/comp_d.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/comp_d.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,73 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) Giovanni Li Manni * +!*********************************************************************** + +function Comp_d(Weights,mGrid,Rho,nRho,iSpin,iSwitch) +!*********************************************************************** +! * +! Object: integrate densities (alpha, beta, total, gradients....) * +! the object integrated is dictaded by iSwitch value: * +! iSwitch = 0 .... total density * +! iSwitch = 1 .... alpha density * +! iSwitch = 2 .... beta density * +! * +! Author: G. Li Manni... taking Sir R. Lindh as model * +!*********************************************************************** + +use Constants, only: Zero, Two, Half +use Definitions, only: wp, iwp + +implicit none +real(kind=wp) :: Comp_d +integer(kind=iwp), intent(in) :: mGrid, nRho, iSpin, iSwitch +real(kind=wp), intent(in) :: Weights(mGrid), Rho(nRho,mGrid) +integer(kind=iwp) :: iGrid +real(kind=wp) :: d_alpha, d_beta, DTot + +Comp_d = Zero +if (iSpin == 1) then + !********************************************************************* + ! iSpin == 1 + !********************************************************************* + do iGrid=1,mGrid + d_alpha = Half*Rho(1,iGrid) + if (iSwitch == 1) then + DTot = d_alpha + else if (iSwitch == 2) then + DTot = d_alpha + else !if (iSwitch == 0) then + DTot = Two*d_alpha + end if + Comp_d = Comp_d+DTot*Weights(iGrid) + end do +else + !********************************************************************* + ! iSpin /= 1 + !********************************************************************* + do iGrid=1,mGrid + d_alpha = Rho(1,iGrid) + d_beta = Rho(2,iGrid) + if (iSwitch == 1) then + DTot = d_alpha + else if (iSwitch == 2) then + DTot = d_beta + else !if (iSwitch == 0) then + DTot = d_alpha+d_beta + end if + Comp_d = Comp_d+DTot*Weights(iGrid) + end do +end if +!*********************************************************************** + +return + +end function Comp_d diff -Nru openmolcas-22.02/src/nq_util/compute_d2mdx2.f openmolcas-22.10/src/nq_util/compute_d2mdx2.f --- openmolcas-22.02/src/nq_util/compute_d2mdx2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/compute_d2mdx2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,76 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Compute_d2Mdx2(ZA,nAtoms,iAtom,iCar,dTdRAi, - & jAtom,jCar,dTdRaj,d2Mdx2) - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 ZA(nAtoms),d2Mdx2(3,3) -* * -************************************************************************ -* * - Call FZero(d2Mdx2,9) - Do kAtom = 1, nAtoms - ZB=ZA(kAtom) - If (kAtom.eq.iAtom) Then - tmpi=One-dTdRAi - Else - tmpi= -dtdRAi - End If - If (kAtom.eq.jAtom) Then - tmpj=One-dTdRAi - Else - tmpj= -dtdRAi - End If -* - If (iCar.eq.1.and.jCar.eq.1) Then - d2Mdx2(2,2) = d2Mdx2(2,2) + Two*ZB*tmpi*tmpj - d2Mdx2(3,3) = d2Mdx2(3,3) + Two*ZB*tmpi*tmpj - End If - If (iCar.eq.1.and.jCar.eq.2) Then - d2Mdx2(1,2) = d2Mdx2(1,2) - ZB*tmpi*tmpj - d2Mdx2(2,1) = d2Mdx2(2,1) - ZB*tmpj*tmpi - End If - If (iCar.eq.1.and.jCar.eq.3) Then - d2Mdx2(1,3) = d2Mdx2(1,3) - ZB*tmpi*tmpj - d2Mdx2(3,1) = d2Mdx2(3,1) - ZB*tmpj*tmpi - End If - If (iCar.eq.2.and.jCar.eq.1) Then - d2Mdx2(1,2) = d2Mdx2(1,2) - ZB*tmpj*tmpi - d2Mdx2(2,1) = d2Mdx2(2,1) - ZB*tmpi*tmpj - End If - If (iCar.eq.2.and.jCar.eq.2) Then - d2Mdx2(1,1) = d2Mdx2(1,1) + Two*ZB*tmpi*tmpj - d2Mdx2(3,3) = d2Mdx2(3,3) + Two*ZB*tmpi*tmpj - End If - If (iCar.eq.2.and.jCar.eq.3) Then - d2Mdx2(2,3) = d2Mdx2(2,3) - ZB*tmpi*tmpj - d2Mdx2(3,2) = d2Mdx2(3,2) - ZB*tmpj*tmpi - End If - If (iCar.eq.3.and.iCar.eq.1) Then - d2Mdx2(1,3) = d2Mdx2(1,3) - ZB*tmpj*tmpi - d2Mdx2(3,1) = d2Mdx2(3,1) - ZB*tmpi*tmpj - End If - If (iCar.eq.3.and.jCar.eq.2) Then - d2Mdx2(2,3) = d2Mdx2(2,3) - ZB*tmpj*tmpi - d2Mdx2(3,2) = d2Mdx2(3,2) - ZB*tmpi*tmpj - End If - If (iCar.eq.3.and.jCar.eq.3) Then - d2Mdx2(1,1) = d2Mdx2(1,1) + Two*ZB*tmpi*tmpj - d2Mdx2(2,2) = d2Mdx2(2,2) + Two*ZB*tmpi*tmpj - End If - End Do -* * -************************************************************************ -* * - Return -c Avoid unused argument warnings - If (.False.) Call Unused_real(dTdRaj) - End diff -Nru openmolcas-22.02/src/nq_util/compute_d2mdx2.F90 openmolcas-22.10/src/nq_util/compute_d2mdx2.F90 --- openmolcas-22.02/src/nq_util/compute_d2mdx2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/compute_d2mdx2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,86 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Compute_d2Mdx2(ZA,nAtoms,iAtom,iCar,dTdRAi,jAtom,jCar,d2Mdx2) + +use Constants, only: Zero, One, Two +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nAtoms, iAtom, iCar, jAtom, jCar +real(kind=wp), intent(in) :: ZA(nAtoms), dTdRAi +real(kind=wp), intent(out) :: d2Mdx2(3,3) +integer(kind=iwp) :: kAtom +real(kind=wp) :: tmpi, tmpj, ZB + +! * +!*********************************************************************** +! * +d2Mdx2(:,:) = Zero +do kAtom=1,nAtoms + ZB = ZA(kAtom) + if (kAtom == iAtom) then + tmpi = One-dTdRAi + else + tmpi = -dTdRAi + end if + if (kAtom == jAtom) then + tmpj = One-dTdRAi + else + tmpj = -dTdRAi + end if + + select case (iCar) + case (1) + select case (jCar) + case (1) + d2Mdx2(2,2) = d2Mdx2(2,2)+Two*ZB*tmpi*tmpj + d2Mdx2(3,3) = d2Mdx2(3,3)+Two*ZB*tmpi*tmpj + case (2) + d2Mdx2(1,2) = d2Mdx2(1,2)-ZB*tmpi*tmpj + d2Mdx2(2,1) = d2Mdx2(2,1)-ZB*tmpj*tmpi + case (3) + d2Mdx2(1,3) = d2Mdx2(1,3)-ZB*tmpi*tmpj + d2Mdx2(3,1) = d2Mdx2(3,1)-ZB*tmpj*tmpi + end select + case (2) + select case (jCar) + case (1) + d2Mdx2(1,2) = d2Mdx2(1,2)-ZB*tmpj*tmpi + d2Mdx2(2,1) = d2Mdx2(2,1)-ZB*tmpi*tmpj + case (2) + d2Mdx2(1,1) = d2Mdx2(1,1)+Two*ZB*tmpi*tmpj + d2Mdx2(3,3) = d2Mdx2(3,3)+Two*ZB*tmpi*tmpj + case (3) + d2Mdx2(2,3) = d2Mdx2(2,3)-ZB*tmpi*tmpj + d2Mdx2(3,2) = d2Mdx2(3,2)-ZB*tmpj*tmpi + end select + case (3) + select case (jCar) + case (1) + d2Mdx2(1,3) = d2Mdx2(1,3)-ZB*tmpj*tmpi + d2Mdx2(3,1) = d2Mdx2(3,1)-ZB*tmpi*tmpj + case (2) + d2Mdx2(2,3) = d2Mdx2(2,3)-ZB*tmpj*tmpi + d2Mdx2(3,2) = d2Mdx2(3,2)-ZB*tmpi*tmpj + case (3) + d2Mdx2(1,1) = d2Mdx2(1,1)+Two*ZB*tmpi*tmpj + d2Mdx2(2,2) = d2Mdx2(2,2)+Two*ZB*tmpi*tmpj + end select + end select +end do +! * +!*********************************************************************** +! * + +return + +end subroutine Compute_d2Mdx2 diff -Nru openmolcas-22.02/src/nq_util/compute_d2odx2.f openmolcas-22.10/src/nq_util/compute_d2odx2.f --- openmolcas-22.02/src/nq_util/compute_d2odx2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/compute_d2odx2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,233 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Compute_d2Odx2(ZA,RA,nAtoms,T,O,EVal,Rot_Corr, - & iAtom,iCar,dTdRAi,dMdx,dOdx,Px, - & jAtom,jCar,dTdRAj,dMdy,dOdy,Py, - & d2Odx2) - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 ZA(nAtoms), RA(3,nAtoms), T(3), O(3,3), EVal(3), - & dOdx(3,3), dMdx(3,3), Px(3,3), - & dOdy(3,3), dMdy(3,3), Py(3,3), - & d2Odx2(3,3) - Logical Rot_Corr -* Local Arrays - Real*8 d2Mdx2(3,3), Pxy(3,3), RHS(3,3), Scr1(3,3), Scr2(3,3), - & Scr3(3,3) -* * -************************************************************************ -* * - If (.Not.Rot_Corr) Then - Call FZero(d2Odx2,9) - Return - End If -* * -************************************************************************ -* * -* -* Compute d2M/dxdy -* - Call Compute_d2Mdx2(ZA,nAtoms,iAtom,iCar,dTdRAi, - & jAtom,jCar,dTdRaj, - & d2Mdx2) - -* * -************************************************************************ -* * -* Form diagonal elements of Pxy directly from Px and Py -* - Gamma1=Px(1,2) - Beta1 =Px(3,1) - Alpha1=Px(2,3) - Gamma2=Py(1,2) - Beta2 =Py(3,1) - Alpha2=Py(2,3) - Pxy(1,1)=-Gamma1*Gamma2-Beta1*Beta2 - Pxy(2,2)=-Gamma1*Gamma2-Alpha1*Alpha2 - Pxy(3,3)=-Beta1*Beta2-Alpha1*Alpha2 -* * -************************************************************************ -* * -* Compute additional constraints for off-diagonals -* - c12=Beta1*Alpha2+Beta2*Alpha1 ! Pxy(2,1)+Pxy(1,2) - c13=Gamma1*Alpha2+Gamma2*Alpha1 ! Pxy(3,1)+Pxy(1,3) - c23=Beta1*Gamma2+Beta2*Gamma1 ! Pxy(2,3)+Pxy(3,2) -* * -************************************************************************ -* * -* Assemble the right hand side of eq. 26 except for Lambda^(xy). -* This will generate all off-diagonal elements of the RHS! -* - Call FZero(RHS,9) -* -* - O^T M^(xy) O -* - Call DGEMM_('T','N', - & 3,3,3, - & 1.0d0,O,3, - & d2Mdx2,3, - & 0.0d0,Scr1,3) - Call DGEMM_('N','N', - & 3,3,3, - & 1.0d0,Scr1,3, - & O,3, - & 0.0d0,Scr2,3) - Call DaXpY_(9,-One,Scr2,1,RHS,1) -* - Call FZero(Scr3,9) - Scr3(1,1)=Eval(1) - Scr3(2,2)=Eval(2) - Scr3(3,3)=Eval(3) -* -* + P^x Lambda P^y -* - Call DGEMM_('N','N', - & 3,3,3, - & 1.0d0,Px,3, - & Scr3,3, - & 0.0d0,Scr1,3) - Call DGEMM_('N','N', - & 3,3,3, - & 1.0d0,Scr1,3, - & Py,3, - & 0.0d0,Scr2,3) - Call DaXpY_(9, One,Scr2,1,RHS,1) -* -* + P^y Lambda P^x -* - Call DGEMM_('N','N', - & 3,3,3, - & 1.0d0,Py,3, - & Scr3,3, - & 0.0d0,Scr1,3) - Call DGEMM_('N','N', - & 3,3,3, - & 1.0d0,Scr1,3, - & Px,3, - & 0.0d0,Scr2,3) - Call DaXpY_(9, One,Scr2,1,RHS,1) -* -* + P^x O^T M^y O -* - Call DGEMM_('N','T', - & 3,3,3, - & 1.0d0,Px,3, - & O,3, - & 0.0d0,Scr1,3) - Call DGEMM_('N','N', - & 3,3,3, - & 1.0d0,Scr1,3, - & dMdy,3, - & 0.0d0,Scr2,3) - Call DGEMM_('N','N', - & 3,3,3, - & 1.0d0,Scr2,3, - & O,3, - & 0.0d0,Scr1,3) - Call DaXpY_(9, One,Scr1,1,RHS,1) -* -* + P^y O^T M^x O -* - Call DGEMM_('N','T', - & 3,3,3, - & 1.0d0,Py,3, - & O,3, - & 0.0d0,Scr1,3) - Call DGEMM_('N','N', - & 3,3,3, - & 1.0d0,Scr1,3, - & dMdx,3, - & 0.0d0,Scr2,3) - Call DGEMM_('N','N', - & 3,3,3, - & 1.0d0,Scr2,3, - & O,3, - & 0.0d0,Scr1,3) - Call DaXpY_(9, One,Scr1,1,RHS,1) -* -* - O^T M^x O P^y -* - Call DGEMM_('T','N', - & 3,3,3, - & 1.0d0,O,3, - & dMdx,3, - & 0.0d0,Scr1,3) - Call DGEMM_('N','N', - & 3,3,3, - & 1.0d0,Scr1,3, - & O,3, - & 0.0d0,Scr2,3) - Call DGEMM_('N','N', - & 3,3,3, - & 1.0d0,Scr2,3, - & Py,3, - & 0.0d0,Scr1,3) - Call DaXpY_(9,-One,Scr1,1,RHS,1) -* -* - O^T M^y O P^x -* - Call DGEMM_('T','N', - & 3,3,3, - & 1.0d0,O,3, - & dMdy,3, - & 0.0d0,Scr1,3) - Call DGEMM_('N','N', - & 3,3,3, - & 1.0d0,Scr1,3, - & O,3, - & 0.0d0,Scr2,3) - Call DGEMM_('N','N', - & 3,3,3, - & 1.0d0,Scr2,3, - & Px,3, - & 0.0d0,Scr1,3) - Call DaXpY_(9,-One,Scr1,1,RHS,1) -#ifdef _DEBUGPRINT_ - Call RecPrt('RHS',' ',RHS,3,3) -#endif -* -* * -************************************************************************ -* * -* Compute the off-diagonal elements. -* -* We will need some more elaborate code if the denominator is -* degenerate! Will be developed later... -* - Pxy(2,1)=(RHS(1,2)-EVal(1)*c12)/(EVal(2)-EVal(1)) - Pxy(1,2)=c12-Pxy(2,1) - Pxy(3,1)=(RHS(1,3)-EVal(1)*c13)/(EVal(3)-EVal(1)) - Pxy(1,3)=c13-Pxy(3,1) - Pxy(3,2)=(RHS(2,3)-EVal(2)*c23)/(EVal(3)-EVal(2)) - Pxy(2,3)=c23-Pxy(3,2) -* * -************************************************************************ -* * -* Finally for O^(xy) from O P^(xyz) -* - Call DGEMM_('N','N', - & 3,3,3, - & 1.0d0,O,3, - & Pxy,3, - & 0.0d0,d2Odx2,3) -* * -************************************************************************ -* * - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(RA) - Call Unused_real_array(T) - Call Unused_real_array(dOdx) - Call Unused_real_array(dOdy) - End If - End diff -Nru openmolcas-22.02/src/nq_util/compute_d2odx2.F90 openmolcas-22.10/src/nq_util/compute_d2odx2.F90 --- openmolcas-22.02/src/nq_util/compute_d2odx2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/compute_d2odx2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,148 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Compute_d2Odx2(ZA,nAtoms,O,EVal,Rot_Corr,iAtom,iCar,dTdRAi,dMdx,Px,jAtom,jCar,dMdy,Py,d2Odx2) + +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nAtoms, iAtom, iCar, jAtom, jCar +real(kind=wp), intent(in) :: ZA(nAtoms), O(3,3), EVal(3), dTdRAi, dMdx(3,3), Px(3,3), dMdy(3,3), Py(3,3) +logical(kind=iwp), intent(in) :: Rot_Corr +real(kind=wp), intent(out) :: d2Odx2(3,3) +real(kind=wp) :: Alpha1, Alpha2, Beta1, Beta2, c12, c13, c23, d2Mdx2(3,3), Gamma1, Gamma2, Pxy(3,3), RHS(3,3), Scr1(3,3), & + Scr2(3,3), Scr3(3,3) + +! * +!*********************************************************************** +! * +if (.not. Rot_Corr) then + d2Odx2(:,:) = Zero + return +end if +! * +!*********************************************************************** +! * +! +! Compute d2M/dxdy +! +call Compute_d2Mdx2(ZA,nAtoms,iAtom,iCar,dTdRAi,jAtom,jCar,d2Mdx2) + +! * +!*********************************************************************** +! * +! Form diagonal elements of Pxy directly from Px and Py +! +Gamma1 = Px(1,2) +Beta1 = Px(3,1) +Alpha1 = Px(2,3) +Gamma2 = Py(1,2) +Beta2 = Py(3,1) +Alpha2 = Py(2,3) +Pxy(1,1) = -Gamma1*Gamma2-Beta1*Beta2 +Pxy(2,2) = -Gamma1*Gamma2-Alpha1*Alpha2 +Pxy(3,3) = -Beta1*Beta2-Alpha1*Alpha2 +! * +!*********************************************************************** +! * +! Compute additional constraints for off-diagonals +! +c12 = Beta1*Alpha2+Beta2*Alpha1 ! Pxy(2,1)+Pxy(1,2) +c13 = Gamma1*Alpha2+Gamma2*Alpha1 ! Pxy(3,1)+Pxy(1,3) +c23 = Beta1*Gamma2+Beta2*Gamma1 ! Pxy(2,3)+Pxy(3,2) +! * +!*********************************************************************** +! * +! Assemble the right hand side of eq. 26 except for Lambda^(xy). +! This will generate all off-diagonal elements of the RHS! + +! - O^T M^(xy) O + +call DGEMM_('T','N',3,3,3,One,O,3,d2Mdx2,3,Zero,Scr1,3) +call DGEMM_('N','N',3,3,3,One,Scr1,3,O,3,Zero,Scr2,3) +RHS(:,:) = -Scr2 + +Scr3(:,:) = Zero +Scr3(1,1) = Eval(1) +Scr3(2,2) = Eval(2) +Scr3(3,3) = Eval(3) + +! + P^x Lambda P^y + +call DGEMM_('N','N',3,3,3,One,Px,3,Scr3,3,Zero,Scr1,3) +call DGEMM_('N','N',3,3,3,One,Scr1,3,Py,3,Zero,Scr2,3) +RHS(:,:) = RHS+Scr2 + +! + P^y Lambda P^x + +call DGEMM_('N','N',3,3,3,One,Py,3,Scr3,3,Zero,Scr1,3) +call DGEMM_('N','N',3,3,3,One,Scr1,3,Px,3,Zero,Scr2,3) +RHS(:,:) = RHS+Scr2 + +! + P^x O^T M^y O + +call DGEMM_('N','T',3,3,3,One,Px,3,O,3,Zero,Scr1,3) +call DGEMM_('N','N',3,3,3,One,Scr1,3,dMdy,3,Zero,Scr2,3) +call DGEMM_('N','N',3,3,3,One,Scr2,3,O,3,Zero,Scr1,3) +RHS(:,:) = RHS+Scr1 + +! + P^y O^T M^x O + +call DGEMM_('N','T',3,3,3,One,Py,3,O,3,Zero,Scr1,3) +call DGEMM_('N','N',3,3,3,One,Scr1,3,dMdx,3,Zero,Scr2,3) +call DGEMM_('N','N',3,3,3,One,Scr2,3,O,3,Zero,Scr1,3) +RHS(:,:) = RHS+Scr1 + +! - O^T M^x O P^y + +call DGEMM_('T','N',3,3,3,One,O,3,dMdx,3,Zero,Scr1,3) +call DGEMM_('N','N',3,3,3,One,Scr1,3,O,3,Zero,Scr2,3) +call DGEMM_('N','N',3,3,3,One,Scr2,3,Py,3,Zero,Scr1,3) +RHS(:,:) = RHS-Scr1 + +! - O^T M^y O P^x + +call DGEMM_('T','N',3,3,3,One,O,3,dMdy,3,Zero,Scr1,3) +call DGEMM_('N','N',3,3,3,One,Scr1,3,O,3,Zero,Scr2,3) +call DGEMM_('N','N',3,3,3,One,Scr2,3,Px,3,Zero,Scr1,3) +RHS(:,:) = RHS-Scr1 +#ifdef _DEBUGPRINT_ +call RecPrt('RHS',' ',RHS,3,3) +#endif + +! * +!*********************************************************************** +! * +! Compute the off-diagonal elements. + +! We will need some more elaborate code if the denominator is +! degenerate! Will be developed later... + +Pxy(2,1) = (RHS(1,2)-EVal(1)*c12)/(EVal(2)-EVal(1)) +Pxy(1,2) = c12-Pxy(2,1) +Pxy(3,1) = (RHS(1,3)-EVal(1)*c13)/(EVal(3)-EVal(1)) +Pxy(1,3) = c13-Pxy(3,1) +Pxy(3,2) = (RHS(2,3)-EVal(2)*c23)/(EVal(3)-EVal(2)) +Pxy(2,3) = c23-Pxy(3,2) +! * +!*********************************************************************** +! * +! Finally for O^(xy) from O P^(xyz) + +call DGEMM_('N','N',3,3,3,One,O,3,Pxy,3,Zero,d2Odx2,3) +! * +!*********************************************************************** +! * + +return + +end subroutine Compute_d2Odx2 diff -Nru openmolcas-22.02/src/nq_util/compute_dmdx.f openmolcas-22.10/src/nq_util/compute_dmdx.f --- openmolcas-22.02/src/nq_util/compute_dmdx.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/compute_dmdx.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,94 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Compute_dMdx(ZA,RA,nAtoms,T,iAtom,iCar,dTdRai,dMdx) - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 ZA(nAtoms), RA(3,nAtoms), T(3), dMdx(3,3) -#ifdef _DEBUGPRINT_ - Real*8 M(3,3) -#endif -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - Z_Tot=DDot_(nAtoms,[One],0,ZA,1) - delta=1.0D-4 - temp = RA(iCar,iAtom) -* - RA(iCar,iAtom) = Temp + Delta - Call Compute_M(ZA,nAtoms,RA,Z_Tot,T,M) -* - RA(iCar,iAtom) = Temp - Delta - Call Compute_M(ZA,nAtoms,RA,Z_Tot,T,dMdx) -* - RA(iCar,iAtom) = Temp -* - Do i = 1, 3 - Do j = 1, 3 - dMdx(i,j) = (M(i,j)-dMdx(i,j))/(2.0D0*Delta) - End Do - End Do - Call RecPrt('dMdx(Numerical)',' ',dMdx,3,3) -#endif - - Call FZero(dMdx,3*3) - Do jAtom = 1, nAtoms - ZB=ZA(jAtom) - If (iAtom.eq.jAtom) Then - tmp=(One-dTdRAi)*ZB - Else - tmp=( -dTdRAi)*ZB - End If -* - RTx=RA(1,jAtom)-T(1) - RTy=RA(2,jAtom)-T(2) - RTz=RA(3,jAtom)-T(3) - If (iCar.eq.1) Then - dMdx(2,2) = dMdx(2,2) + Two*tmp*RTx - dMdx(3,3) = dMdx(3,3) + Two*tmp*RTx - dMdx(1,2) = dMdx(1,2) - tmp*RTy - dMdx(2,1) = dMdx(2,1) - RTy*tmp - dMdx(1,3) = dMdx(1,3) - tmp*RTz - dMdx(3,1) = dMdx(3,1) - RTz*tmp - End If - If (iCar.eq.2) Then - dMdx(1,1) = dMdx(1,1) + Two*tmp*RTy - dMdx(3,3) = dMdx(3,3) + Two*tmp*RTy - dMdx(1,2) = dMdx(1,2) - RTx*tmp - dMdx(2,1) = dMdx(2,1) - tmp*RTx - dMdx(2,3) = dMdx(2,3) - tmp*RTz - dMdx(3,2) = dMdx(3,2) - RTz*tmp - End If - If (iCar.eq.3) Then - dMdx(1,1) = dMdx(1,1) + Two*tmp*RTz - dMdx(2,2) = dMdx(2,2) + Two*tmp*RTz - dMdx(1,3) = dMdx(1,3) - RTx*tmp - dMdx(3,1) = dMdx(3,1) - tmp*RTx - dMdx(2,3) = dMdx(2,3) - RTy*tmp - dMdx(3,2) = dMdx(3,2) - tmp*RTy - End If - End Do -* -* Remove noise -* - Do i = 1, 3 - Do j = 1, 3 - If (Abs(dMdx(i,j)).lt.1.0D-14) dMdx(i,j)=Zero - End Do - End Do -#ifdef _DEBUGPRINT_ - Call RecPrt('dMdx',' ',dMdx,3,3) -#endif -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/compute_dmdx.F90 openmolcas-22.10/src/nq_util/compute_dmdx.F90 --- openmolcas-22.02/src/nq_util/compute_dmdx.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/compute_dmdx.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,105 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Compute_dMdx(ZA,RA,nAtoms,T,iAtom,iCar,dTdRAi,dMdx) + +#ifdef _DEBUGPRINT_ +use stdalloc, only: mma_allocate, mma_deallocate +#endif +use Constants, only: Zero, One, Two +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nAtoms, iAtom, iCar +real(kind=wp), intent(in) :: ZA(nAtoms), RA(3,nAtoms), T(3), dTdRAi +real(kind=wp), intent(out) :: dMdx(3,3) +integer(kind=iwp) :: i, j, jAtom +real(kind=wp) :: RTx, RTy, RTz, tmp, ZB +#ifdef _DEBUGPRINT_ +real(kind=wp) :: M(3,3) +real(kind=wp), allocatable :: dRA(:,:) +#endif +real(kind=wp), parameter :: Thrs = 1.0e-14_wp + +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +delta = 1.0e-4_wp +call mma_allocate(dRA,3,nAtoms,label='dRA') +dRA(:,:) = RA + +dRA(iCar,iAtom) = RA(iCar,iAtom)+Delta +call Compute_M(ZA,nAtoms,dRA,T,M) + +dRA(iCar,iAtom) = RA(iCar,iAtom)-Delta +call Compute_M(ZA,nAtoms,dRA,T,dMdx) + +dRA(iCar,iAtom) = RA(iCar,iAtom) + +dMdx(:,:) = (M-dMdx)/(Two*Delta) +call RecPrt('dMdx(Numerical)',' ',dMdx,3,3) +#endif + +dMdx(:,:) = Zero +do jAtom=1,nAtoms + ZB = ZA(jAtom) + if (iAtom == jAtom) then + tmp = (One-dTdRAi)*ZB + else + tmp = (-dTdRAi)*ZB + end if + + RTx = RA(1,jAtom)-T(1) + RTy = RA(2,jAtom)-T(2) + RTz = RA(3,jAtom)-T(3) + select case (iCar) + case (1) + dMdx(2,2) = dMdx(2,2)+Two*tmp*RTx + dMdx(3,3) = dMdx(3,3)+Two*tmp*RTx + dMdx(1,2) = dMdx(1,2)-tmp*RTy + dMdx(2,1) = dMdx(2,1)-RTy*tmp + dMdx(1,3) = dMdx(1,3)-tmp*RTz + dMdx(3,1) = dMdx(3,1)-RTz*tmp + case (2) + dMdx(1,1) = dMdx(1,1)+Two*tmp*RTy + dMdx(3,3) = dMdx(3,3)+Two*tmp*RTy + dMdx(1,2) = dMdx(1,2)-RTx*tmp + dMdx(2,1) = dMdx(2,1)-tmp*RTx + dMdx(2,3) = dMdx(2,3)-tmp*RTz + dMdx(3,2) = dMdx(3,2)-RTz*tmp + case (3) + dMdx(1,1) = dMdx(1,1)+Two*tmp*RTz + dMdx(2,2) = dMdx(2,2)+Two*tmp*RTz + dMdx(1,3) = dMdx(1,3)-RTx*tmp + dMdx(3,1) = dMdx(3,1)-tmp*RTx + dMdx(2,3) = dMdx(2,3)-RTy*tmp + dMdx(3,2) = dMdx(3,2)-tmp*RTy + end select +end do + +! Remove noise + +do i=1,3 + do j=1,3 + if (abs(dMdx(i,j)) < Thrs) dMdx(i,j) = Zero + end do +end do +#ifdef _DEBUGPRINT_ +call RecPrt('dMdx',' ',dMdx,3,3) +#endif +! * +!*********************************************************************** +! * + +return + +end subroutine Compute_dMdx diff -Nru openmolcas-22.02/src/nq_util/compute_dodx.f openmolcas-22.10/src/nq_util/compute_dodx.f --- openmolcas-22.02/src/nq_util/compute_dodx.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/compute_dodx.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,121 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Compute_dOdx(ZA,RA,nAtoms,T,O,EVal,Rot_Corr, - & iAtom,iCar,dTdRAi,dMdx,dOdx,Px) - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 ZA(nAtoms), RA(3,nAtoms), T(3), O(3,3), EVal(3), - & dOdx(3,3), dMdx(3,3), Px(3,3) - Logical Rot_Corr -*---- Local arrays - Real*8 OtMx(3,3), OtMxO(3,3) -* * -************************************************************************ -* * - If (.Not.Rot_Corr) Then - Call FZero(dOdx,9) - Return - End If -* -*---- Differentiate the nuclear charge moment tensor, M. -* - Call Compute_dMdx(ZA,RA,nAtoms,T,iAtom,iCar,dTdRAi,dMdx) -* -* -* Form O(t) dMdRAi O -* - Call DGEMM_('T','N', - & 3,3,3, - & 1.0d0,O,3, - & dMdx,3, - & 0.0d0,OtMx,3) - Call DGEMM_('N','N', - & 3,3,3, - & 1.0d0,OtMx,3, - & O,3, - & 0.0d0,OtMxO,3) -* -* Compute the off diagonal elements in Px -* - If (Abs(OtMxO(2,3)+OtMxO(3,2)).lt.1.0D-14) Then - If (abs(EVal(2)-EVal(3)).lt.1.0D-14) Then - Alpha=One - Else - Alpha=Zero - End If - Else - If (abs(EVal(2)-EVal(3)).lt.1.0D-14) Then - Alpha=1.0D99 - Else - Alpha = - & -(OtMxO(2,3)+OtMxO(3,2))/(Two*(EVal(2)-EVal(3))) - End If - End If -* - If (Abs(OtMxO(1,3)+OtMxO(3,1)).lt.1.0D-14) Then - If (abs(EVal(3)-EVal(1)).lt.1.0D-14) Then - Beta=One - Else - Beta=Zero - End If - Else - If (abs(EVal(3)-EVal(1)).lt.1.0D-14) Then - Beta=1.0D99 - Else - Beta = - & -(OtMxO(1,3)+OtMxO(3,1))/(Two*(EVal(3)-EVal(1))) - End If - End If - If (Abs(OtMxO(1,2)+OtMxO(2,1)).lt.1.0D-14) Then - If (abs(EVal(1)-EVal(2)).lt.1.0D-14) Then - Gamma = One - Else - Gamma = Zero - End If - Else - If (abs(EVal(1)-EVal(2)).lt.1.0D-14) Then - Gamma=1.0D99 - Else - Gamma = - & -(OtMxO(1,2)+OtMxO(2,1))/(Two*(EVal(1)-EVal(2))) - End If - End If -* - Call FZero(Px,9) - Px(1,2)= Gamma - Px(2,1)=-Gamma - Px(1,3)=-Beta - Px(3,1)= Beta - Px(2,3)= Alpha - Px(3,2)=-Alpha -* -* Finally evaluate dO/dRAi -* - Call DGEMM_('N','N', - & 3,3,3, - & 1.0d0,O,3, - & Px,3, - & 0.0d0,dOdx(1,1),3) -#ifdef _DEBUGPRINT_ -C Call RecPrt('M','(3G20.10)',M,3,3) -C Call RecPrt('RotGrd: O','(3G20.10)',O,3,3) -C Call RecPrt('RotGrd: EVal',' ',EVal,3,1) -C Call RecPrt('RotGrd: dMdx','(3G20.10)',dMdx,3,3) -C Call RecPrt('RotGrd: OtMxO','(3G20.10)',OtMxO,3,3) -C Write (*,*) 'A,B,G=',Alpha,Beta,Gamma -C Call RecPrt('RotGrd: Px','(3G20.10)',Px,3,3) -C Call RecPrt('dOdx','(3G20.10)',dOdx,3,3) -#endif -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/compute_dodx.F90 openmolcas-22.10/src/nq_util/compute_dodx.F90 --- openmolcas-22.02/src/nq_util/compute_dodx.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/compute_dodx.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,112 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Compute_dOdx(ZA,RA,nAtoms,T,O,EVal,Rot_Corr,iAtom,iCar,dTdRAi,dMdx,dOdx,Px) + +use Constants, only: Zero, One, Two +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nAtoms, iAtom, iCar +real(kind=wp), intent(in) :: ZA(nAtoms), RA(3,nAtoms), T(3), O(3,3), EVal(3), dTdRAi +logical(kind=iwp), intent(in) :: Rot_Corr +real(kind=wp), intent(out) :: dMdx(3,3), dOdx(3,3), Px(3,3) +real(kind=wp) :: Alpha, Beta, Gmma, OtMx(3,3), OtMxO(3,3) +real(kind=wp), parameter :: Thrs = 1.0e-14_wp + +! * +!*********************************************************************** +! * +if (.not. Rot_Corr) then + dOdx(:,:) = Zero + return +end if + +! Differentiate the nuclear charge moment tensor, M. + +call Compute_dMdx(ZA,RA,nAtoms,T,iAtom,iCar,dTdRAi,dMdx) + +! Form O(t) dMdRAi O + +call DGEMM_('T','N',3,3,3,One,O,3,dMdx,3,Zero,OtMx,3) +call DGEMM_('N','N',3,3,3,One,OtMx,3,O,3,Zero,OtMxO,3) + +! Compute the off diagonal elements in Px + +if (abs(OtMxO(2,3)+OtMxO(3,2)) < Thrs) then + if (abs(EVal(2)-EVal(3)) < Thrs) then + Alpha = One + else + Alpha = Zero + end if +else + if (abs(EVal(2)-EVal(3)) < Thrs) then + Alpha = huge(Alpha) + else + Alpha = -(OtMxO(2,3)+OtMxO(3,2))/(Two*(EVal(2)-EVal(3))) + end if +end if + +if (abs(OtMxO(1,3)+OtMxO(3,1)) < Thrs) then + if (abs(EVal(3)-EVal(1)) < Thrs) then + Beta = One + else + Beta = Zero + end if +else + if (abs(EVal(3)-EVal(1)) < Thrs) then + Beta = huge(Beta) + else + Beta = -(OtMxO(1,3)+OtMxO(3,1))/(Two*(EVal(3)-EVal(1))) + end if +end if +if (abs(OtMxO(1,2)+OtMxO(2,1)) < Thrs) then + if (abs(EVal(1)-EVal(2)) < Thrs) then + Gmma = One + else + Gmma = Zero + end if +else + if (abs(EVal(1)-EVal(2)) < Thrs) then + Gmma = huge(Gmma) + else + Gmma = -(OtMxO(1,2)+OtMxO(2,1))/(Two*(EVal(1)-EVal(2))) + end if +end if + +Px(:,:) = Zero +Px(1,2) = Gmma +Px(2,1) = -Gmma +Px(1,3) = -Beta +Px(3,1) = Beta +Px(2,3) = Alpha +Px(3,2) = -Alpha + +! Finally evaluate dO/dRAi + +call DGEMM_('N','N',3,3,3,One,O,3,Px,3,Zero,dOdx(1,1),3) +#ifdef _DEBUGPRINT_ +!call RecPrt('M','(3G20.10)',M,3,3) +!call RecPrt('RotGrd: O','(3G20.10)',O,3,3) +!call RecPrt('RotGrd: EVal',' ',EVal,3,1) +!call RecPrt('RotGrd: dMdx','(3G20.10)',dMdx,3,3) +!call RecPrt('RotGrd: OtMxO','(3G20.10)',OtMxO,3,3) +!write(u6,*) 'A,B,G=',Alpha,Beta,Gmma +!call RecPrt('RotGrd: Px','(3G20.10)',Px,3,3) +!call RecPrt('dOdx','(3G20.10)',dOdx,3,3) +#endif +! * +!*********************************************************************** +! * + +return + +end subroutine Compute_dOdx diff -Nru openmolcas-22.02/src/nq_util/compute_grad.f openmolcas-22.10/src/nq_util/compute_grad.f --- openmolcas-22.02/src/nq_util/compute_grad.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/compute_grad.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,70 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2000, Roland Lindh * -************************************************************************ - Real*8 Function Compute_Grad(Weights,mGrid,iSpin) -************************************************************************ -* Author:Roland Lindh, Department of Chemical Physics, University * -* of Lund, SWEDEN. November 2000 * -************************************************************************ - use nq_Grid, only: Sigma - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - Real*8 Weights(mGrid) -* * -************************************************************************ -* * -* - Compute_Grad=Zero -* -* iSpin=1 -* - If (iSpin.eq.1) Then -* * -************************************************************************ -* * - Do iGrid = 1, mGrid -* - Gamma=Sqrt(Sigma(1,iGrid)) -* -*------- Accumulate contributions to the integrated Tau -* - Compute_Grad = Compute_Grad + Two*Gamma*Weights(iGrid) -* - End Do -* * -************************************************************************ -* * -* iSpin=/=1 -* - Else -* * -************************************************************************ -* * - Do iGrid = 1, mGrid -* - Gamma=Sqrt(Sigma(1,iGrid)+Two*Sigma(2,iGrid)+Sigma(3,iGrid)) -* -*------- Accumulate contributions to the integrated density -* - Compute_Grad = Compute_Grad + Gamma*Weights(iGrid) -* - End Do -* * -************************************************************************ -* * - End If -* * -************************************************************************ -* * -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/compute_grad.F90 openmolcas-22.10/src/nq_util/compute_grad.F90 --- openmolcas-22.02/src/nq_util/compute_grad.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/compute_grad.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,79 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2000, Roland Lindh * +!*********************************************************************** + +function Compute_Grad(Weights,mGrid,iSpin) +!*********************************************************************** +! Author:Roland Lindh, Department of Chemical Physics, University * +! of Lund, SWEDEN. November 2000 * +!*********************************************************************** + +use nq_Grid, only: Sigma +use Constants, only: Zero, Two +use Definitions, only: wp, iwp + +implicit none +real(kind=wp) :: Compute_Grad +integer(kind=iwp), intent(in) :: mGrid, iSpin +real(kind=wp), intent(in) :: Weights(mGrid) +integer(kind=iwp) :: iGrid +real(kind=wp) :: Gmma + +! * +!*********************************************************************** +! * +Compute_Grad = Zero + +if (iSpin == 1) then + ! * + !********************************************************************* + ! * + ! iSpin == 1 + + do iGrid=1,mGrid + + Gmma = sqrt(Sigma(1,iGrid)) + + ! Accumulate contributions to the integrated Tau + + Compute_Grad = Compute_Grad+Two*Gmma*Weights(iGrid) + + end do + ! * + !********************************************************************* + ! * +else + ! * + !********************************************************************* + ! * + ! iSpin /= 1 + + do iGrid=1,mGrid + + Gmma = sqrt(Sigma(1,iGrid)+Two*Sigma(2,iGrid)+Sigma(3,iGrid)) + + ! Accumulate contributions to the integrated density + + Compute_Grad = Compute_Grad+Gmma*Weights(iGrid) + + end do + ! * + !********************************************************************* + ! * +end if +! * +!*********************************************************************** +! * + +return + +end function Compute_Grad diff -Nru openmolcas-22.02/src/nq_util/compute_m.f openmolcas-22.10/src/nq_util/compute_m.f --- openmolcas-22.02/src/nq_util/compute_m.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/compute_m.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,50 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Compute_M(ZA,nAtoms,RA,Z_Tot,T,M) - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 ZA(nAtoms), RA(3,nAtoms), T(3), M(3,3) -* * -************************************************************************ -* * -*---- Form the nuclear charge moment tensor -* - Call FZero(M,9) - Do iAtom = 1, nAtoms - RTx=RA(1,iAtom)-T(1) - RTy=RA(2,iAtom)-T(2) - RTz=RA(3,iAtom)-T(3) - M(1,1) = M(1,1) + ZA(iAtom) * (RTy**2+RTz**2) - M(2,2) = M(2,2) + ZA(iAtom) * (RTx**2+RTz**2) - M(3,3) = M(3,3) + ZA(iAtom) * (RTx**2+RTy**2) -* - M(1,2) = M(1,2) + ZA(iAtom) * ( -RTx*RTy) - M(1,3) = M(1,3) + ZA(iAtom) * ( -RTx*RTz) - M(2,1) = M(2,1) + ZA(iAtom) * ( -RTy*RTx) - - M(2,3) = M(2,3) + ZA(iAtom) * ( -RTy*RTz) - M(3,1) = M(3,1) + ZA(iAtom) * ( -RTz*RTx) - M(3,2) = M(3,2) + ZA(iAtom) * ( -RTz*RTy) - End Do -* -* Remove noise -* - Do i = 1, 3 - Do j = 1, 3 - If (abs(M(i,j)).lt.1.0D-14) M(i,j)=Zero - End Do - End Do -C Call RecPrt('Compute_M: M',' ',M,3,3) -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_real(Z_Tot) - End diff -Nru openmolcas-22.02/src/nq_util/compute_m.F90 openmolcas-22.10/src/nq_util/compute_m.F90 --- openmolcas-22.02/src/nq_util/compute_m.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/compute_m.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,59 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Compute_M(ZA,nAtoms,RA,T,M) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nAtoms +real(kind=wp), intent(in) :: ZA(nAtoms), RA(3,nAtoms), T(3) +real(kind=wp), intent(out) :: M(3,3) +integer(kind=iwp) :: i, iAtom, j +real(kind=wp) :: RTx, RTy, RTz +real(kind=wp), parameter :: Thrs = 1.0e-14_wp + +! * +!*********************************************************************** +! * +! Form the nuclear charge moment tensor + +M(:,:) = Zero +do iAtom=1,nAtoms + RTx = RA(1,iAtom)-T(1) + RTy = RA(2,iAtom)-T(2) + RTz = RA(3,iAtom)-T(3) + M(1,1) = M(1,1)+ZA(iAtom)*(RTy**2+RTz**2) + M(2,2) = M(2,2)+ZA(iAtom)*(RTx**2+RTz**2) + M(3,3) = M(3,3)+ZA(iAtom)*(RTx**2+RTy**2) + + M(1,2) = M(1,2)+ZA(iAtom)*(-RTx*RTy) + M(1,3) = M(1,3)+ZA(iAtom)*(-RTx*RTz) + M(2,1) = M(2,1)+ZA(iAtom)*(-RTy*RTx) + + M(2,3) = M(2,3)+ZA(iAtom)*(-RTy*RTz) + M(3,1) = M(3,1)+ZA(iAtom)*(-RTz*RTx) + M(3,2) = M(3,2)+ZA(iAtom)*(-RTz*RTy) +end do + +! Remove noise + +do i=1,3 + do j=1,3 + if (abs(M(i,j)) < Thrs) M(i,j) = Zero + end do +end do +!call RecPrt('Compute_M: M',' ',M,3,3) + +return + +end subroutine Compute_M diff -Nru openmolcas-22.02/src/nq_util/compute_o.f openmolcas-22.10/src/nq_util/compute_o.f --- openmolcas-22.02/src/nq_util/compute_o.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/compute_o.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,53 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Compute_O(ZA,RA,nAtoms,Z_Tot,T,O,Lambda) - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 ZA(nAtoms), RA(3,nAtoms), T(3), O(3,3), Lambda(3) -* Local arrays - Real*8 EVal(6), M(3,3) -* * -************************************************************************ -* * -*---- Form the nuclear charge moment tensor -* - Call Compute_M(ZA,nAtoms,RA,Z_Tot,T,M) -* * -************************************************************************ -* * -*---- Diagonalize the nuclear charge momentum tensor to get -* the principal axis system. -* - Call FZero(O,9) - call dcopy_(3,[One],0,O,4) - EVal(1)=M(1,1) - EVal(2)=M(2,1) - EVal(3)=M(2,2) - EVal(4)=M(3,1) - EVal(5)=M(3,2) - EVal(6)=M(3,3) - Call Jacob(EVal,O,3,3) -C Call JacOrd(EVal,O,3,3) -#ifdef _DEBUGPRINT_ - Call TriPrt('RotGrd: EVal',' ',EVal,3) - Call RecPrt('RotGrd: O',' ',O,3,3) -#endif -* * -************************************************************************ -* * - Lambda(1)=EVal(1) - Lambda(2)=EVal(3) - Lambda(3)=EVal(6) -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/compute_o.F90 openmolcas-22.10/src/nq_util/compute_o.F90 --- openmolcas-22.02/src/nq_util/compute_o.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/compute_o.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,59 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Compute_O(ZA,RA,nAtoms,T,O,Lambda) + +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +integer(kind=iwp), intent(in) :: nAtoms +real(kind=wp), intent(in) :: ZA(nAtoms), RA(3,nAtoms), T(3) +real(kind=wp), intent(out) :: O(3,3), Lambda(3) +real(kind=wp) :: EVal(6), M(3,3) + +! * +!*********************************************************************** +! * +! Form the nuclear charge moment tensor + +call Compute_M(ZA,nAtoms,RA,T,M) +! * +!*********************************************************************** +! * +! Diagonalize the nuclear charge momentum tensor to get +! the principal axis system. + +O = reshape([One,Zero,Zero,Zero,One,Zero,Zero,Zero,One],[3,3]) +EVal(1) = M(1,1) +EVal(2) = M(2,1) +EVal(3) = M(2,2) +EVal(4) = M(3,1) +EVal(5) = M(3,2) +EVal(6) = M(3,3) +call Jacob(EVal,O,3,3) +!call JacOrd(EVal,O,3,3) +#ifdef _DEBUGPRINT_ +call TriPrt('RotGrd: EVal',' ',EVal,3) +call RecPrt('RotGrd: O',' ',O,3,3) +#endif +! * +!*********************************************************************** +! * +Lambda(1) = EVal(1) +Lambda(2) = EVal(3) +Lambda(3) = EVal(6) +! * +!*********************************************************************** +! * + +return + +end subroutine Compute_O diff -Nru openmolcas-22.02/src/nq_util/compute_rho.f openmolcas-22.10/src/nq_util/compute_rho.f --- openmolcas-22.02/src/nq_util/compute_rho.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/compute_rho.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,76 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2000, Roland Lindh * -************************************************************************ - Real*8 Function Compute_Rho(Weights,mGrid,iSpin) -************************************************************************ -* Author:Roland Lindh, Department of Chemical Physics, University * -* of Lund, SWEDEN. November 2000 * -************************************************************************ - use nq_Grid, only: Rho - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - Real*8 Weights(mGrid) -* * -************************************************************************ -* * -* * -************************************************************************ -* * -* - Compute_Rho=Zero -* -* iSpin=1 -* - If (iSpin.eq.1) Then -* * -************************************************************************ -* * - Do iGrid = 1, mGrid -* - d_alpha=Rho(1,iGrid) - DTot=d_alpha -* -*------- Accumulate contributions to the integrated density -* - Compute_Rho = Compute_Rho + DTot*Weights(iGrid) -* - End Do -* * -************************************************************************ -* * -* iSpin=/=1 -* - Else -* * -************************************************************************ -* * - Do iGrid = 1, mGrid -* - d_alpha=Rho(1,iGrid) - d_beta =Rho(2,iGrid) - DTot=d_alpha+d_beta -* -*------- Accumulate contributions to the integrated density -* - Compute_Rho = Compute_Rho + DTot*Weights(iGrid) -* - End Do -* * -************************************************************************ -* * - End If -* * -************************************************************************ -* * -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/compute_rho.F90 openmolcas-22.10/src/nq_util/compute_rho.F90 --- openmolcas-22.02/src/nq_util/compute_rho.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/compute_rho.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,81 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2000, Roland Lindh * +!*********************************************************************** + +function Compute_Rho(Weights,mGrid,iSpin) +!*********************************************************************** +! Author:Roland Lindh, Department of Chemical Physics, University * +! of Lund, SWEDEN. November 2000 * +!*********************************************************************** + +use nq_Grid, only: Rho +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +real(kind=wp) :: Compute_Rho +integer(kind=iwp), intent(in) :: mGrid, iSpin +real(kind=wp), intent(in) :: Weights(mGrid) +integer(kind=iwp) :: iGrid +real(kind=wp) :: d_alpha, d_beta, DTot + +! * +!*********************************************************************** +! * +Compute_Rho = Zero +if (iSpin == 1) then + ! * + !********************************************************************* + ! * + ! iSpin=1 + + do iGrid=1,mGrid + + d_alpha = Rho(1,iGrid) + DTot = d_alpha + + ! Accumulate contributions to the integrated density + + Compute_Rho = Compute_Rho+DTot*Weights(iGrid) + + end do + ! * + !********************************************************************* + ! * +else + ! * + !********************************************************************* + ! * + ! iSpin=/=1 + + do iGrid=1,mGrid + + d_alpha = Rho(1,iGrid) + d_beta = Rho(2,iGrid) + DTot = d_alpha+d_beta + + ! Accumulate contributions to the integrated density + + Compute_Rho = Compute_Rho+DTot*Weights(iGrid) + + end do + ! * + !********************************************************************* + ! * +end if +! * +!*********************************************************************** +! * + +return + +end function Compute_Rho diff -Nru openmolcas-22.02/src/nq_util/compute_tau.f openmolcas-22.10/src/nq_util/compute_tau.f --- openmolcas-22.02/src/nq_util/compute_tau.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/compute_tau.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,73 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2000, Roland Lindh * -************************************************************************ - Real*8 Function Compute_Tau(Weights,mGrid,iSpin) -************************************************************************ -* Author:Roland Lindh, Department of Chemical Physics, University * -* of Lund, SWEDEN. November 2000 * -************************************************************************ - use nq_Grid, only: Tau - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - Real*8 Weights(mGrid) -* * -************************************************************************ -* * -* * -************************************************************************ -* * -* - Compute_Tau=Zero -* -* iSpin=1 -* - If (iSpin.eq.1) Then -* * -************************************************************************ -* * - Do iGrid = 1, mGrid -* - TauA=Two*Tau(1,iGrid) -* -*------- Accumulate contributions to the integrated Tau -* - Compute_Tau = Compute_Tau + TauA*Weights(iGrid) -* - End Do -* * -************************************************************************ -* * -* iSpin=/=1 -* - Else -* * -************************************************************************ -* * - Do iGrid = 1, mGrid -* - TauA=(Tau(1,iGrid)+Tau(2,iGrid)) -* -*------- Accumulate contributions to the integrated density -* - Compute_Tau = Compute_Tau + TauA*Weights(iGrid) -* - End Do -* * -************************************************************************ -* * - End If -* * -************************************************************************ -* * -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/compute_tau.F90 openmolcas-22.10/src/nq_util/compute_tau.F90 --- openmolcas-22.02/src/nq_util/compute_tau.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/compute_tau.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,78 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2000, Roland Lindh * +!*********************************************************************** + +function Compute_Tau(Weights,mGrid,iSpin) +!*********************************************************************** +! Author:Roland Lindh, Department of Chemical Physics, University * +! of Lund, SWEDEN. November 2000 * +!*********************************************************************** + +use nq_Grid, only: Tau +use Constants, only: Zero, Two +use Definitions, only: wp, iwp + +implicit none +real(kind=wp) :: Compute_Tau +integer(kind=iwp), intent(in) :: mGrid, iSpin +real(kind=wp), intent(in) :: Weights(mGrid) +integer(kind=iwp) :: iGrid +real(kind=wp) :: TauA + +! * +!*********************************************************************** +! * +Compute_Tau = Zero +if (iSpin == 1) then + ! * + !********************************************************************* + ! * + ! iSpin == 1 + + do iGrid=1,mGrid + + TauA = Two*Tau(1,iGrid) + + ! Accumulate contributions to the integrated Tau + + Compute_Tau = Compute_Tau+TauA*Weights(iGrid) + + end do + ! * + !********************************************************************* + ! * +else + ! * + !********************************************************************* + ! * + ! iSpin /= 1 + + do iGrid=1,mGrid + + TauA = (Tau(1,iGrid)+Tau(2,iGrid)) + + ! Accumulate contributions to the integrated density + + Compute_Tau = Compute_Tau+TauA*Weights(iGrid) + + end do + ! * + !********************************************************************* + ! * +end if +! * +!*********************************************************************** +! * + +return + +end function Compute_Tau diff -Nru openmolcas-22.02/src/nq_util/compute_t.f openmolcas-22.10/src/nq_util/compute_t.f --- openmolcas-22.02/src/nq_util/compute_t.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/compute_t.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Compute_T(Z_Tot,T,ZA,RA,nAtoms) - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 T(3), ZA(nAtoms), RA(3,nAtoms) -* * -************************************************************************ -* * -*---- Form the center of nuclear charge -* - Do iCar = 1, 3 - Tmp = Zero - Do iAtom = 1, nAtoms - Tmp = Tmp + ZA(iAtom)*RA(iCar,iAtom) - End Do - T(iCar) = Tmp/Z_Tot - End Do -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/compute_t.F90 openmolcas-22.10/src/nq_util/compute_t.F90 --- openmolcas-22.02/src/nq_util/compute_t.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/compute_t.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,41 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Compute_T(Z_Tot,T,ZA,RA,nAtoms) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nAtoms +real(kind=wp), intent(in) :: Z_Tot, ZA(nAtoms), RA(3,nAtoms) +real(kind=wp), intent(out) :: T(3) +integer(kind=iwp) :: iAtom, iCar +real(kind=wp) :: Tmp + +! * +!*********************************************************************** +! * +! Form the center of nuclear charge + +do iCar=1,3 + Tmp = Zero + do iAtom=1,nAtoms + Tmp = Tmp+ZA(iAtom)*RA(iCar,iAtom) + end do + T(iCar) = Tmp/Z_Tot +end do +! * +!*********************************************************************** +! * +return + +end subroutine Compute_T diff -Nru openmolcas-22.02/src/nq_util/converttabso.F90 openmolcas-22.10/src/nq_util/converttabso.F90 --- openmolcas-22.02/src/nq_util/converttabso.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/converttabso.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,48 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Jie J. Bao * +!*********************************************************************** + +! **************************************************************** +! history: * +! Jie J. Bao, on Dec. 08, 2021, created this file. * +! **************************************************************** +subroutine ConvertTabSO(TabSO2,TabSO,mAO,mGrid,nMOs) + +use nq_pdft, only: lft, lGGA +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: mAO, mGrid, nMOs +real(kind=wp), intent(out) :: TabSO2(nMOs,mAO,mGrid) +real(kind=wp), intent(in) :: TabSO(mAO,mGrid,nMOs) +integer(kind=iwp) :: iEnd, iGrid, jAO + +! TabSO : mAO*mGrid x nMOs +! TabSO2: nMOs x mAO*nGrid + +! loop over first and optionally second derivatives of the SOs +! this defines the length of nAO to 3 or 9. +if (lft .and. lGGA) then + iEnd = 9 +else + iEnd = 3 +end if + +do iGrid=1,mGrid + do jAO=1,iEnd + TabSO2(:,jAO,iGrid) = TabSO(jAO+1,iGrid,:) + end do +end do + +return + +end subroutine ConvertTabSO diff -Nru openmolcas-22.02/src/nq_util/dede_funi.f openmolcas-22.10/src/nq_util/dede_funi.f --- openmolcas-22.02/src/nq_util/dede_funi.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/dede_funi.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine DeDe_Funi(Dens,nDens,nr_of_Densities) - use k2_arrays - use Sizes_of_Seward, only: S - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "stdalloc.fh" -#include "setup.fh" - Real*8 Dens(nDens,nr_of_Densities) - Logical Special_NoSym, DFT_Storage -* - nIndij=S%nShlls*(S%nShlls+1)/2 - nField=2+nr_of_Densities -* -* - Call mma_allocate(ipOffD,nField,nIndij,label='ipOffD') - Call mma_allocate(DeDe,nDeDe_DFT+MaxDe*nIrrep,Label='DeDe') - ipDeDe= 1 - ipD00 = ipDeDe + nDeDe_DFT - ipDijs = -1 ! Dummy value - DeDe(:)=Zero -* - Special_NoSym=.False. - DFT_Storage=.True. - Call mk_DeDe(Dens,nDens,nr_of_Densities,ipOffD,nIndij,ipDeDe, - & ipD00,MaxDe,mDeDe,mIndij,Special_NoSym,DFT_Storage, - & DeDe,nDeDe_DFT) -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/dede_funi.F90 openmolcas-22.10/src/nq_util/dede_funi.F90 --- openmolcas-22.02/src/nq_util/dede_funi.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/dede_funi.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,46 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine DeDe_Funi(Dens,nDens,nr_of_Densities) + +use k2_arrays, only: DeDe, ipD00, ipDeDe, ipDijs, ipOffD, MaxDE, nDeDe_DFT +use Sizes_of_Seward, only: S +use Symmetry_Info, only: nIrrep +use stdalloc, only: mma_allocate +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nDens, nr_of_Densities +real(kind=wp), intent(in) :: Dens(nDens,nr_of_Densities) +integer(kind=iwp) :: mDeDe, mIndij, nField, nIndij +logical(kind=iwp) :: DFT_Storage, Special_NoSym + +nIndij = S%nShlls*(S%nShlls+1)/2 +nField = 2+nr_of_Densities + +call mma_allocate(ipOffD,nField,nIndij,label='ipOffD') +call mma_allocate(DeDe,nDeDe_DFT+MaxDe*nIrrep,Label='DeDe') +ipDeDe = 1 +ipD00 = ipDeDe+nDeDe_DFT +ipDijs = -1 ! Dummy value +DeDe(:) = Zero + +Special_NoSym = .false. +DFT_Storage = .true. +call mk_DeDe(Dens,nDens,nr_of_Densities,ipOffD,nIndij,ipDeDe,ipD00,MaxDe,mDeDe,mIndij,Special_NoSym,DFT_Storage,DeDe,nDeDe_DFT) +! * +!*********************************************************************** +! * + +return + +end subroutine DeDe_Funi diff -Nru openmolcas-22.02/src/nq_util/dft_grad.f openmolcas-22.10/src/nq_util/dft_grad.f --- openmolcas-22.02/src/nq_util/dft_grad.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/dft_grad.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,589 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2002, Roland Lindh * -************************************************************************ - Subroutine DFT_Grad(Grad,nGrad,iSpin,Grid,mGrid,dRho_dR,ndRho_dR, - & nGrad_Eff,Weights,iNQ) -************************************************************************ -* * -* Object: to trace the correct parts to get the contributions to * -* the gradient due to the DFT energy. * -* * -* Author: Roland Lindh, Dept. of Chemical Physics, University of * -* Lund, Sweden. May 2002 in Bologna, Italy. * -************************************************************************ - use nq_Grid, only: F_xc, GradRho, vRho, vSigma, vTau, vLapl - use nq_Grid, only: Pax - use nq_Grid, only: IndGrd, iTab, Temp, dW_dR - use nq_Structure, only: NQ_data - use nq_Info - Implicit Real*8 (a-h,o-z) -#include "real.fh" -#include "debug.fh" -#include "Molcas.fh" -#include "itmax.fh" -#include "ksdft.fh" - Parameter (Mxdc=MxAtom) -#include "disp.fh" - Real*8 Grad(nGrad), Grid(3,mGrid), - & dRho_dR(ndRho_dR,mGrid,nGrad_Eff), OV(3,3), V(3,3), - & R_Grid(3), Weights(mGrid) -* * -************************************************************************ -* * - R_Grid(:)=NQ_Data(iNQ)%Coor(:) -*define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Debug=.True. - If (Debug) Then - Call RecPrt('R_Grid',' ',R_Grid,1,3) - Call RecPrt('Grid',' ',Grid,3,mGrid) - Call RecPrt('Weights',' ',Weights,1,mGrid) - Call RecPrt('dW_dR',' ',dW_dR,nGrad_Eff,mGrid) - Call RecPrt('dRho_dR(1)',' ',dRho_dR,ndRho_dR,mGrid) - Call RecPrt('dF_dRho',' ',dF_dRho,ndF_dRho,mGrid) - Do iEff = 1, nGrad_Eff - Write (6,*) 'iTab=',iTab(1,iEff),iTab(2,iEff),iTab(3,iEff), - & iTab(3,iEff) - Write (6,*) 'IndGrd=',IndGrd(iEff) - End Do - End If -#endif -* * -************************************************************************ -* * - Call FZero(Temp,nGrad_Eff) - Call FZero(OV,9) -* * -************************************************************************ -* * -* We have that the DFT energy is expressed as -* -* E_DFT = Sum_Gg w(r_g(G)) f(G,r_g(G)) -* -* r_g = R_G + O s_g -* -* The first derivative is computed as -* -* E_DFT^x = Sum w^x f + w f^x -* -* where -* -* f^x = f^(x) + -* -* where -* -* nabla_r f is the functional differentiated with respect to a -* displacement of a grid point. -* -* and -* -* r^x = delta_AG e_i + O^x s -* * -************************************************************************ -* * -* Add the contributions -* -* w * f^x to centers other than the origin of the current -* set of grid points. -* -* Note that for x being one of the cartesian components of the -* center of the atomic grid we do not have f^x but rather f^(x). -* The correct contribution will be added below. -* -* Here we also accumulate contributions for the rotational -* invariance. -* -* -* * -************************************************************************ -* * - Select Case (Functional_type) -* * -************************************************************************ -* * - Case (LDA_type) -* * -************************************************************************ -* * - - If (iSpin.eq.1) Then - Do i_Eff=1, nGrad_Eff - tmp=Zero - ixyz=iTab(1,i_Eff) - Do j = 1, mGrid - dF_dr = vRho(1,j) *dRho_dR(1,j,i_Eff) -* - tmp = tmp + Weights(j) * dF_dr -* -* For rotational invariance accumulate -* -* (nabla_r f_g)^T O s_g -* - OV(ixyz,1) = OV(ixyz,1) + Two* Weights(j) * - & dF_dr * (Grid(1,j)-R_Grid(1)) - OV(ixyz,2) = OV(ixyz,2) + Two* Weights(j) * - & dF_dr * (Grid(2,j)-R_Grid(2)) - OV(ixyz,3) = OV(ixyz,3) + Two* Weights(j) * - & dF_dr * (Grid(3,j)-R_Grid(3)) - End Do - If (iTab(2,i_Eff).ne.Off) - & Temp(i_Eff)=Temp(i_Eff)-tmp - End Do - Else - Do i_Eff=1, nGrad_Eff - tmp=Zero - ixyz=iTab(1,i_Eff) - Do j = 1, mGrid - dF_dr = vRho(1,j) *dRho_dR(1,j,i_Eff) - & +vRho(2,j) *dRho_dR(2,j,i_Eff) - tmp = tmp + Weights(j) * dF_dr -* -* Accumulate stuff for rotational invariance -* - OV(ixyz,1) = OV(ixyz,1) + Weights(j) * - & dF_dr * (Grid(1,j)-R_Grid(1)) - OV(ixyz,2) = OV(ixyz,2) + Weights(j) * - & dF_dr * (Grid(2,j)-R_Grid(2)) - OV(ixyz,3) = OV(ixyz,3) + Weights(j) * - & dF_dr * (Grid(3,j)-R_Grid(3)) - End Do - If (iTab(2,i_Eff).ne.Off) - & Temp(i_Eff)=Temp(i_Eff)-tmp - End Do - - End If -* * -************************************************************************ -* * - Case (GGA_type) -* * -************************************************************************ -* * - If (iSpin.eq.1) Then - Do i_Eff=1, nGrad_Eff - tmp=Zero - ixyz=iTab(1,i_Eff) - Do j = 1, mGrid - gx=Gradrho(1,j) - gy=Gradrho(2,j) - gz=Gradrho(3,j) - Temp0=vRho(1,j) - Temp1=2.0d0*vSigma(1,j)*gx - Temp2=2.0d0*vSigma(1,j)*gy - Temp3=2.0d0*vSigma(1,j)*gz -* - dF_dr = Temp0*dRho_dR(1,j,i_Eff) - & + Temp1*dRho_dR(2,j,i_Eff) - & + Temp2*dRho_dR(3,j,i_Eff) - & + Temp3*dRho_dR(4,j,i_Eff) - tmp = tmp + Weights(j) * dF_dr -* -* Accumulate stuff for rotational invariance - -* - OV(ixyz,1) = OV(ixyz,1) + Two* Weights(j) * - & dF_dr * (Grid(1,j)-R_Grid(1)) - OV(ixyz,2) = OV(ixyz,2) + Two* Weights(j) * - & dF_dr * (Grid(2,j)-R_Grid(2)) - OV(ixyz,3) = OV(ixyz,3) + Two* Weights(j) * - & dF_dr * (Grid(3,j)-R_Grid(3)) - End Do - If (iTab(2,i_Eff).ne.Off) - & Temp(i_Eff)=Temp(i_Eff)-tmp - End Do - Else - Do i_Eff=1, nGrad_Eff - tmp=Zero - ixyz=iTab(1,i_Eff) - Do j = 1, mGrid - gxa=Gradrho(1,j) - gya=Gradrho(2,j) - gza=Gradrho(3,j) - gxb=Gradrho(4,j) - gyb=Gradrho(5,j) - gzb=Gradrho(6,j) - - Temp0a=vRho(1,j) - Temp0b=vRho(2,j) - Temp1a=( 2.0d0*vSigma(1,j)*gxa - & +vSigma(2,j)*gxb ) - Temp1b=( 2.0d0*vSigma(3,j)*gxb - & +vSigma(2,j)*gxa ) - Temp2a=( 2.0d0*vSigma(1,j)*gya - & +vSigma(2,j)*gyb ) - Temp2b=( 2.0d0*vSigma(3,j)*gyb - & +vSigma(2,j)*gya ) - Temp3a=( 2.0d0*vSigma(1,j)*gza - & +vSigma(2,j)*gzb ) - Temp3b=( 2.0d0*vSigma(3,j)*gzb - & +vSigma(2,j)*gza ) -* - dF_dr = Temp0a*dRho_dR(1,j,i_Eff) - & + Temp0b*dRho_dR(2,j,i_Eff) - & + Temp1a*dRho_dR(3,j,i_Eff) - & + Temp2a*dRho_dR(4,j,i_Eff) - & + Temp3a*dRho_dR(5,j,i_Eff) - & + Temp1b*dRho_dR(6,j,i_Eff) - & + Temp2b*dRho_dR(7,j,i_Eff) - & + Temp3b*dRho_dR(8,j,i_Eff) - tmp = tmp + Weights(j) * dF_dR -* -* Accumulate stuff for rotational invariance -* - OV(ixyz,1) = OV(ixyz,1) + Weights(j) * - & dF_dr * (Grid(1,j)-R_Grid(1)) - OV(ixyz,2) = OV(ixyz,2) + Weights(j) * - & dF_dr * (Grid(2,j)-R_Grid(2)) - OV(ixyz,3) = OV(ixyz,3) + Weights(j) * - & dF_dr * (Grid(3,j)-R_Grid(3)) - End Do - If (iTab(2,i_Eff).ne.Off) - & Temp(i_Eff)=Temp(i_Eff)-tmp - End Do - End If -* * -************************************************************************ -* * - Case (meta_GGA_type1) -* * -************************************************************************ -* * - If (iSpin.eq.1) Then - Do i_Eff=1, nGrad_Eff - tmp=Zero - ixyz=iTab(1,i_Eff) - Do j = 1, mGrid - gx=Gradrho(1,j) - gy=Gradrho(2,j) - gz=Gradrho(3,j) - Temp0=vRho(1,j) - Temp1=2.0d0*vSigma(1,j)*gx - Temp2=2.0d0*vSigma(1,j)*gy - Temp3=2.0d0*vSigma(1,j)*gz - Temp4=0.25D0*vTau(1,j) -* - dF_dr = Temp0*dRho_dR(1,j,i_Eff) - & + Temp1*dRho_dR(2,j,i_Eff) - & + Temp2*dRho_dR(3,j,i_Eff) - & + Temp3*dRho_dR(4,j,i_Eff) - & + Temp4*dRho_dR(5,j,i_Eff) - tmp = tmp + Weights(j) * dF_dr -* -* Accumulate stuff for rotational invariance -* - OV(ixyz,1) = OV(ixyz,1) + Two* Weights(j) * - & dF_dr * (Grid(1,j)-R_Grid(1)) - OV(ixyz,2) = OV(ixyz,2) + Two* Weights(j) * - & dF_dr * (Grid(2,j)-R_Grid(2)) - OV(ixyz,3) = OV(ixyz,3) + Two* Weights(j) * - & dF_dr * (Grid(3,j)-R_Grid(3)) - End Do - If (iTab(2,i_Eff).ne.Off) - & Temp(i_Eff)=Temp(i_Eff)-tmp - End Do - Else - Do i_Eff=1, nGrad_Eff - tmp=Zero - ixyz=iTab(1,i_Eff) - Do j = 1, mGrid - gxa=Gradrho(1,j) - gya=Gradrho(2,j) - gza=Gradrho(3,j) - gxb=Gradrho(4,j) - gyb=Gradrho(5,j) - gzb=Gradrho(6,j) - - Temp0a=vRho(1,j) - Temp0b=vRho(2,j) - Temp1a=( 2.0d0*vSigma(1,j)*gxa - & +vSigma(2,j)*gxb ) - Temp1b=( 2.0d0*vSigma(3,j)*gxb - & +vSigma(2,j)*gxa ) - Temp2a=( 2.0d0*vSigma(1,j)*gya - & +vSigma(2,j)*gyb ) - Temp2b=( 2.0d0*vSigma(3,j)*gyb - & +vSigma(2,j)*gya ) - Temp3a=( 2.0d0*vSigma(1,j)*gza - & +vSigma(2,j)*gzb ) - Temp3b=( 2.0d0*vSigma(3,j)*gzb - & +vSigma(2,j)*gza ) - Temp4a=0.5D0*vTau(1,j) - Temp4b=0.5D0*vTau(2,j) -* - dF_dr = Temp0a*dRho_dR(1,j,i_Eff) - & + Temp0b*dRho_dR(2,j,i_Eff) - & + Temp1a*dRho_dR(3,j,i_Eff) - & + Temp2a*dRho_dR(4,j,i_Eff) - & + Temp3a*dRho_dR(5,j,i_Eff) - & + Temp1b*dRho_dR(6,j,i_Eff) - & + Temp2b*dRho_dR(7,j,i_Eff) - & + Temp3b*dRho_dR(8,j,i_Eff) - & + Temp4a*dRho_dR(9,j,i_Eff) - & + Temp4b*dRho_dR(10,j,i_Eff) - tmp = tmp + Weights(j) * dF_dR -* -* Accumulate stuff for rotational invariance -* - OV(ixyz,1) = OV(ixyz,1) + Weights(j) * - & dF_dr * (Grid(1,j)-R_Grid(1)) - OV(ixyz,2) = OV(ixyz,2) + Weights(j) * - & dF_dr * (Grid(2,j)-R_Grid(2)) - OV(ixyz,3) = OV(ixyz,3) + Weights(j) * - & dF_dr * (Grid(3,j)-R_Grid(3)) - End Do - If (iTab(2,i_Eff).ne.Off) - & Temp(i_Eff)=Temp(i_Eff)-tmp - End Do - End If -* * -************************************************************************ -* * - Case (meta_GGA_type2) -* * -************************************************************************ -* * - If (iSpin.eq.1) Then - Do i_Eff=1, nGrad_Eff - tmp=Zero - ixyz=iTab(1,i_Eff) - Do j = 1, mGrid - gx=Gradrho(1,j) - gy=Gradrho(2,j) - gz=Gradrho(3,j) - Temp0=vRho(1,j) - Temp1=2.0d0*vSigma(1,j)*gx - Temp2=2.0d0*vSigma(1,j)*gy - Temp3=2.0d0*vSigma(1,j)*gz - Temp4=0.25D0*vTau(1,j) - Temp5=vLapl(1,j) -* - dF_dr = Temp0*dRho_dR(1,j,i_Eff) - & + Temp1*dRho_dR(2,j,i_Eff) - & + Temp2*dRho_dR(3,j,i_Eff) - & + Temp3*dRho_dR(4,j,i_Eff) - & + Temp4*dRho_dR(5,j,i_Eff) - & + Temp5*dRho_dR(6,j,i_Eff) - tmp = tmp + Weights(j) * dF_dr -* -* Accumulate stuff for rotational invariance -* - OV(ixyz,1) = OV(ixyz,1) + Two* Weights(j) * - & dF_dr * (Grid(1,j)-R_Grid(1)) - OV(ixyz,2) = OV(ixyz,2) + Two* Weights(j) * - & dF_dr * (Grid(2,j)-R_Grid(2)) - OV(ixyz,3) = OV(ixyz,3) + Two* Weights(j) * - & dF_dr * (Grid(3,j)-R_Grid(3)) - End Do - If (iTab(2,i_Eff).ne.Off) - & Temp(i_Eff)=Temp(i_Eff)-tmp - End Do - Else - Do i_Eff=1, nGrad_Eff - tmp=Zero - ixyz=iTab(1,i_Eff) - Do j = 1, mGrid - gxa=Gradrho(1,j) - gya=Gradrho(2,j) - gza=Gradrho(3,j) - gxb=Gradrho(4,j) - gyb=Gradrho(5,j) - gzb=Gradrho(6,j) - - Temp0a=vRho(1,j) - Temp0b=vRho(2,j) - Temp1a=( 2.0d0*vSigma(1,j)*gxa - & +vSigma(2,j)*gxb ) - Temp1b=( 2.0d0*vSigma(3,j)*gxb - & +vSigma(2,j)*gxa ) - Temp2a=( 2.0d0*vSigma(1,j)*gya - & +vSigma(2,j)*gyb ) - Temp2b=( 2.0d0*vSigma(3,j)*gyb - & +vSigma(2,j)*gya ) - Temp3a=( 2.0d0*vSigma(1,j)*gza - & +vSigma(2,j)*gzb ) - Temp3b=( 2.0d0*vSigma(3,j)*gzb - & +vSigma(2,j)*gza ) - Temp4a=0.5D0*vTau(1,j) - Temp4b=0.5D0*vTau(2,j) - Temp5a=vLapl(1,j) - Temp5b=vLapl(2,j) -* - dF_dr = Temp0a*dRho_dR(1,j,i_Eff) - & + Temp0b*dRho_dR(2,j,i_Eff) - & + Temp1a*dRho_dR(3,j,i_Eff) - & + Temp2a*dRho_dR(4,j,i_Eff) - & + Temp3a*dRho_dR(5,j,i_Eff) - & + Temp1b*dRho_dR(6,j,i_Eff) - & + Temp2b*dRho_dR(7,j,i_Eff) - & + Temp3b*dRho_dR(8,j,i_Eff) - & + Temp4a*dRho_dR(9,j,i_Eff) - & + Temp4b*dRho_dR(10,j,i_Eff) - & + Temp5a*dRho_dR(11,j,i_Eff) - & + Temp5b*dRho_dR(12,j,i_Eff) - tmp = tmp + Weights(j) * dF_dR -* -* Accumulate stuff for rotational invariance -* - OV(ixyz,1) = OV(ixyz,1) + Weights(j) * - & dF_dr * (Grid(1,j)-R_Grid(1)) - OV(ixyz,2) = OV(ixyz,2) + Weights(j) * - & dF_dr * (Grid(2,j)-R_Grid(2)) - OV(ixyz,3) = OV(ixyz,3) + Weights(j) * - & dF_dr * (Grid(3,j)-R_Grid(3)) - End Do - If (iTab(2,i_Eff).ne.Off) - & Temp(i_Eff)=Temp(i_Eff)-tmp - End Do - End If -* * -************************************************************************ -* * - Case Default -* * -************************************************************************ -* * - Call WarningMessage(2,'Do_Grad: wrong functional type!') - Call Abend() -* * -************************************************************************ -* * - End Select -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - If (Debug) Then - Call RecPrt('w * f^x before translational contributions', - & ' ',Temp,1,nGrad_Eff) - Call RecPrt('OV',' ',OV,3,3) - End If -#endif -* * -************************************************************************ -************************************************************************ -* * -* Here we compute the term -* -* w * f^x -* -* for x being a cartesian component of the center of the atomic -* grid. This is done using the translational invariance condition. -* - If (Grid_Type.eq.Moving_Grid) Then - Do ixyz = 1, 3 - iGrad=0 - Do jGrad = 1, nGrad_Eff - If (iTab(1,jGrad).eq.ixyz .and. - & iTab(2,jGrad).eq.Off .and. - & IndGrd(jGrad).gt.0 ) iGrad=jGrad - End Do -#ifdef _DEBUGPRINT_ - If (Debug) Write (6,*) 'iGrad=',iGrad -#endif - If (iGrad.ne.0) Then -* -* Evaluate indirectly via the translational invariance -* the sum of the direct and indirect term -* - Do jGrad = 1, nGrad_Eff - If (jGrad.ne.iGrad .and. iTab(1,jGrad).eq.ixyz ) Then -* - Temp(iGrad)=Temp(iGrad)-Temp(jGrad) -* -#ifdef _DEBUGPRINT_ - If (Debug) Write (6,*) 'jGrad,Temp(jGrad)=', - & jGrad,Temp(jGrad) -#endif - End If - End Do -* - End If - End Do -#ifdef _DEBUGPRINT_ - If (Debug) Call RecPrt('w * f^x',' ',Temp,1,nGrad_Eff) -#endif -* * -************************************************************************ -* * -* For a "moving" grid add contributions due to the derivative with -* respect to the partitioning. -* -* w^x * f -* - Call DGEMM_('N','N',nGrad_Eff,1,mGrid, - & One,dW_dR,nGrad_Eff, - & F_xc,mGrid, - & One,Temp,nGrad_Eff) -#ifdef _DEBUGPRINT_ - If (Debug) Call RecPrt('w * f^x + w^x * f',' ',Temp,1,nGrad_Eff) -#endif -* * -************************************************************************ -* * -* Add the rotational invariance term -* -* First transform back to the cartesian coordinates system. -* - Call DGEMM_('N','N', - & 3,3,3, - & 1.0d0,OV,3, - & Pax,3, - & 0.0d0,V,3) -#ifdef _DEBUGPRINT_ - If (Debug) Call RecPrt('V',' ',V,3,3) -#endif -* - Do i_Eff = 1, nGrad_Eff - iCar = iTab(1,i_Eff) - jNQ = iTab(3,i_Eff) -* -* Compute < nabla_r f * r^x > as Tr (O^x V) -* - Tmp = DDot_(9,NQ_Data(jNQ)%dOdx(:,:,iCar),1,V,1) * Half -#ifdef _DEBUGPRINT_ - If (Debug) Then - Write (6,*) - Write (6,*) 'iCar,jNQ=',iCar,jNQ - Call RecPrt('dOdx',' ',NQ_Data(jNQ)%dOdx(:,:,iCar),3,3) - Write (6,*) 'Tmp=',Tmp - End If -#endif - Temp(i_Eff) = Temp(i_Eff) - Tmp - End Do -* - End If !moving grid -#ifdef _DEBUGPRINT_ - If (Debug) Call RecPrt('Gradient contribution from this block', - & ' ',Temp,1,nGrad_Eff) -#endif -* * -************************************************************************ -* * -* Accumulate and symmetry adapt. -* - Do i_Eff = 1, nGrad_Eff - i = IndGrd(i_Eff) - If (i.ge.1) Then - Fact=DBLE(iTab(4,i_Eff)) - Grad(i) = Grad(i) + Fact*Temp(i_Eff) - End If - End Do -#ifdef _DEBUGPRINT_ - If (Debug) Call RecPrt('Gradient accumulated so far', - & ' ',Grad,1,nGrad) - Debug=.False. -#endif -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/dft_grad.F90 openmolcas-22.10/src/nq_util/dft_grad.F90 --- openmolcas-22.02/src/nq_util/dft_grad.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/dft_grad.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,385 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2002, Roland Lindh * +!*********************************************************************** + +subroutine DFT_Grad(Grad,nGrad,nD,Grid,mGrid,dRho_dR,ndRho_dR,nGrad_Eff,Weights,iNQ) +!*********************************************************************** +! * +! Object: to trace the correct parts to get the contributions to * +! the gradient due to the DFT energy. * +! * +! Author: Roland Lindh, Dept. of Chemical Physics, University of * +! Lund, Sweden. May 2002 in Bologna, Italy. * +!*********************************************************************** + +use nq_Grid, only: dW_dR, F_xc, GradRho, IndGrd, iTab, Pax, Temp, vLapl, vRho, vSigma, vTau +use nq_Structure, only: NQ_data +use nq_Info, only: Functional_type, GGA_Type, Grid_Type, LDA_Type, meta_GGA_type1, meta_GGA_type2, Moving_Grid, Off +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Half, Quart +use Definitions, only: wp, iwp, r8 +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +use Definitions, only: u6 +#endif + +implicit none +integer(kind=iwp), intent(in) :: nGrad, nD, mGrid, ndRho_dR, nGrad_Eff, iNQ +real(kind=wp), intent(inout) :: Grad(nGrad) +real(kind=wp), intent(in) :: Grid(3,mGrid), dRho_dR(ndRho_dR,mGrid,nGrad_Eff), Weights(mGrid) +integer(kind=iwp) :: i, i_Eff, iCar, iGrad, ixyz, j, jGrad, jNQ +real(kind=wp) :: dF_dr, Fact, gxa, gxb, gya, gyb, gza, gzb, OV(3,3), OVT(3), R_Grid(3), tmp, V(3,3) +real(kind=wp), allocatable :: Aux(:,:) +real(kind=r8), external :: DDot_ + +! * +!*********************************************************************** +! * +R_Grid(:) = NQ_Data(iNQ)%Coor(:) +#ifdef _DEBUGPRINT_ +call RecPrt('R_Grid',' ',R_Grid,1,3) +call RecPrt('Grid',' ',Grid,3,mGrid) +call RecPrt('Weights',' ',Weights,1,mGrid) +call RecPrt('dW_dR',' ',dW_dR,nGrad_Eff,mGrid) +call RecPrt('dRho_dR(1)',' ',dRho_dR,ndRho_dR,mGrid) +call RecPrt('dF_dRho',' ',dF_dRho,ndF_dRho,mGrid) +do iEff=1,nGrad_Eff + write(u6,*) 'iTab=',iTab(1,iEff),iTab(2,iEff),iTab(3,iEff),iTab(3,iEff) + write(u6,*) 'IndGrd=',IndGrd(iEff) +end do +#endif +! * +!*********************************************************************** +! * +! We have that the DFT energy is expressed as +! +! E_DFT = Sum_Gg w(r_g(G)) f(G,r_g(G)) +! +! r_g = R_G + O s_g +! +! The first derivative is computed as +! +! E_DFT^x = Sum w^x f + w f^x +! +! where +! +! f^x = f^(x) + +! +! where +! +! nabla_r f is the functional differentiated with respect to a +! displacement of a grid point. +! +! and +! +! r^x = delta_AG e_i + O^x s +! * +!*********************************************************************** +! * +! Add the contributions +! +! w * f^x to centers other than the origin of the current +! set of grid points. +! +! Note that for x being one of the cartesian components of the +! center of the atomic grid we do not have f^x but rather f^(x). +! The correct contribution will be added below. +! +! Here we also accumulate contributions for the rotational +! invariance. +! * +!*********************************************************************** +! * +select case (Functional_type) + ! * + !********************************************************************* + ! * + case (LDA_type) + ! * + !******************************************************************* + ! * + + call mma_Allocate(Aux,nD,mGrid,Label='Aux') + if (nD == 1) then + do j=1,mGrid + Aux(1,j) = vRho(1,j) + end do + else + do j=1,mGrid + Aux(1,j) = vRho(1,j) + Aux(2,j) = vRho(2,j) + end do + end if + ! * + !******************************************************************* + ! * + case (GGA_type) + ! * + !******************************************************************* + ! + call mma_Allocate(Aux,4*nD,mGrid,Label='Aux') + if (nD == 1) then + do j=1,mGrid + Aux(1,j) = vRho(1,j) + Aux(2,j) = Two*vSigma(1,j)*Gradrho(1,j) + Aux(3,j) = Two*vSigma(1,j)*Gradrho(2,j) + Aux(4,j) = Two*vSigma(1,j)*Gradrho(3,j) + end do + else + do j=1,mGrid + gxa = Gradrho(1,j) + gya = Gradrho(2,j) + gza = Gradrho(3,j) + gxb = Gradrho(4,j) + gyb = Gradrho(5,j) + gzb = Gradrho(6,j) + + Aux(1,j) = vRho(1,j) + Aux(2,j) = vRho(2,j) + Aux(3,j) = Two*vSigma(1,j)*gxa+vSigma(2,j)*gxb + Aux(4,j) = Two*vSigma(1,j)*gya+vSigma(2,j)*gyb + Aux(5,j) = Two*vSigma(1,j)*gza+vSigma(2,j)*gzb + Aux(6,j) = Two*vSigma(3,j)*gxb+vSigma(2,j)*gxa + Aux(7,j) = Two*vSigma(3,j)*gyb+vSigma(2,j)*gya + Aux(8,j) = Two*vSigma(3,j)*gzb+vSigma(2,j)*gza + end do + end if + ! * + !******************************************************************* + ! * + case (meta_GGA_type1) + ! * + !******************************************************************* + ! * + call mma_Allocate(Aux,5*nD,mGrid,Label='Aux') + if (nD == 1) then + do j=1,mGrid + Aux(1,j) = vRho(1,j) + Aux(2,j) = Two*vSigma(1,j)*Gradrho(1,j) + Aux(3,j) = Two*vSigma(1,j)*Gradrho(2,j) + Aux(4,j) = Two*vSigma(1,j)*Gradrho(3,j) + Aux(5,j) = Quart*vTau(1,j) + end do + else + do j=1,mGrid + gxa = Gradrho(1,j) + gya = Gradrho(2,j) + gza = Gradrho(3,j) + gxb = Gradrho(4,j) + gyb = Gradrho(5,j) + gzb = Gradrho(6,j) + + Aux(1,j) = vRho(1,j) + Aux(2,j) = vRho(2,j) + Aux(3,j) = Two*vSigma(1,j)*gxa+vSigma(2,j)*gxb + Aux(4,j) = Two*vSigma(1,j)*gya+vSigma(2,j)*gyb + Aux(5,j) = Two*vSigma(1,j)*gza+vSigma(2,j)*gzb + Aux(6,j) = Two*vSigma(3,j)*gxb+vSigma(2,j)*gxa + Aux(7,j) = Two*vSigma(3,j)*gyb+vSigma(2,j)*gya + Aux(8,j) = Two*vSigma(3,j)*gzb+vSigma(2,j)*gza + Aux(9,j) = Half*vTau(1,j) + Aux(10,j) = Half*vTau(2,j) + end do + end if + ! * + !******************************************************************* + ! * + case (meta_GGA_type2) + ! * + !******************************************************************* + ! * + call mma_Allocate(Aux,6*nD,mGrid,Label='Aux') + if (nD == 1) then + do j=1,mGrid + Aux(1,j) = vRho(1,j) + Aux(2,j) = Two*vSigma(1,j)*Gradrho(1,j) + Aux(3,j) = Two*vSigma(1,j)*Gradrho(2,j) + Aux(4,j) = Two*vSigma(1,j)*Gradrho(3,j) + Aux(5,j) = Quart*vTau(1,j) + Aux(6,j) = vLapl(1,j) + end do + else + do j=1,mGrid + gxa = Gradrho(1,j) + gya = Gradrho(2,j) + gza = Gradrho(3,j) + gxb = Gradrho(4,j) + gyb = Gradrho(5,j) + gzb = Gradrho(6,j) + + Aux(1,j) = vRho(1,j) + Aux(2,j) = vRho(2,j) + Aux(3,j) = Two*vSigma(1,j)*gxa+vSigma(2,j)*gxb + Aux(4,j) = Two*vSigma(1,j)*gya+vSigma(2,j)*gyb + Aux(5,j) = Two*vSigma(1,j)*gza+vSigma(2,j)*gzb + Aux(6,j) = Two*vSigma(3,j)*gxb+vSigma(2,j)*gxa + Aux(7,j) = Two*vSigma(3,j)*gyb+vSigma(2,j)*gya + Aux(8,j) = Two*vSigma(3,j)*gzb+vSigma(2,j)*gza + Aux(9,j) = Half*vTau(1,j) + Aux(10,j) = Half*vTau(2,j) + Aux(11,j) = vLapl(1,j) + Aux(12,j) = vLapl(2,j) + end do + end if + ! * + !******************************************************************* + ! * + case default + ! * + !******************************************************************* + ! * + call WarningMessage(2,'Do_Grad: wrong functional type!') + call Abend() + ! * + !******************************************************************* + ! * +end select +! * +!*********************************************************************** +! * +OV(:,:) = Zero +do i_Eff=1,nGrad_Eff + tmp = Zero + OVT(:) = Zero + do j=1,mGrid + dF_dr = Weights(j)*DDot_(ndRho_dR,Aux(:,j),1,dRho_dR(:,j,i_Eff),1) + tmp = tmp+dF_dr + + ! Accumulate stuff for rotational invariance + + OVT(:) = OVT(:)+dF_dr*Grid(:,j) + end do + ixyz = iTab(1,i_Eff) + OV(ixyz,:) = OV(ixyz,:)+OVT(:)-tmp*R_Grid(:) + Temp(i_Eff) = -tmp +end do + +call mma_deAllocate(Aux) + +do i_Eff=1,nGrad_Eff + if (iTab(2,i_Eff) == Off) Temp(i_Eff) = Zero +end do +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +call RecPrt('w * f^x before translational contributions',' ',Temp,1,nGrad_Eff) +call RecPrt('OV',' ',OV,3,3) +#endif +! * +!*********************************************************************** +!*********************************************************************** +! * +! Here we compute the term +! +! w * f^x +! +! for x being a cartesian component of the center of the atomic +! grid. This is done using the translational invariance condition. + +if (Grid_Type == Moving_Grid) then + do ixyz=1,3 + iGrad = 0 + do jGrad=1,nGrad_Eff + if ((iTab(1,jGrad) == ixyz) .and. (iTab(2,jGrad) == Off) .and. (IndGrd(jGrad) > 0)) iGrad = jGrad + end do +# ifdef _DEBUGPRINT_ + write(u6,*) 'iGrad=',iGrad +# endif + if (iGrad /= 0) then + + ! Evaluate indirectly via the translational invariance + ! the sum of the direct and indirect term + + do jGrad=1,nGrad_Eff + if ((jGrad /= iGrad) .and. (iTab(1,jGrad) == ixyz)) then + + Temp(iGrad) = Temp(iGrad)-Temp(jGrad) + +# ifdef _DEBUGPRINT_ + write(u6,*) 'jGrad,Temp(jGrad)=',jGrad,Temp(jGrad) +# endif + end if + end do + + end if + end do +# ifdef _DEBUGPRINT_ + call RecPrt('w * f^x',' ',Temp,1,nGrad_Eff) +# endif + ! * + !********************************************************************* + ! * + ! For a "moving" grid add contributions due to the derivative with + ! respect to the partitioning. + ! + ! w^x * f + + call DGEMM_('N','N',nGrad_Eff,1,mGrid,One,dW_dR,nGrad_Eff,F_xc,mGrid,One,Temp,nGrad_Eff) +# ifdef _DEBUGPRINT_ + call RecPrt('w * f^x + w^x * f',' ',Temp,1,nGrad_Eff) +# endif + ! * + !********************************************************************* + ! * + ! Add the rotational invariance term + ! + ! First transform back to the cartesian coordinates system. + + Fact = real(2-(nD/2),kind=wp) + call DGEMM_('N','N',3,3,3,Fact,OV,3,Pax,3,Zero,V,3) +# ifdef _DEBUGPRINT_ + call RecPrt('V',' ',V,3,3) +# endif + + do i_Eff=1,nGrad_Eff + iCar = iTab(1,i_Eff) + jNQ = iTab(3,i_Eff) + + ! Compute < nabla_r f * r^x > as Tr (O^x V) + + Tmp = DDot_(9,NQ_Data(jNQ)%dOdx(:,:,iCar),1,V,1)*Half +# ifdef _DEBUGPRINT_ + write(u6,*) + write(u6,*) 'iCar,jNQ=',iCar,jNQ + call RecPrt('dOdx',' ',NQ_Data(jNQ)%dOdx(:,:,iCar),3,3) + write(u6,*) 'Tmp=',Tmp +# endif + Temp(i_Eff) = Temp(i_Eff)-Tmp + end do + +end if !moving grid +#ifdef _DEBUGPRINT_ +call RecPrt('Gradient contribution from this block',' ',Temp,1,nGrad_Eff) +#endif +! * +!*********************************************************************** +! * +! Accumulate and symmetry adapt. + +do i_Eff=1,nGrad_Eff + i = IndGrd(i_Eff) + if (i >= 1) then + Fact = real(iTab(4,i_Eff),kind=wp) + Grad(i) = Grad(i)+Fact*Temp(i_Eff) + end if +end do +#ifdef _DEBUGPRINT_ +call RecPrt('Gradient accumulated so far',' ',Grad,1,nGrad) +#endif +! * +!*********************************************************************** +! * + +return + +end subroutine DFT_Grad diff -Nru openmolcas-22.02/src/nq_util/dft_int.f openmolcas-22.10/src/nq_util/dft_int.f --- openmolcas-22.02/src/nq_util/dft_int.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/dft_int.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,62 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2000,2022, Roland Lindh * -* Ajitha Devarajan * -************************************************************************ - Subroutine DFT_Int(list_s,nlist_s,FckInt,nFckInt,nD,Fact,ndc) -************************************************************************ -* * -* Object: to compute contributions to * -* * -* ; integrals over the potential * -* * -* where * -* * -* F(r)=rho(r)*e(rho(r),grad[rho(r)]) * -* * -* Author:Roland Lindh, Department of Chemical Physics, University * -* of Lund, SWEDEN. November 2000 * -* D.Ajitha:Modifying for the new Kernel outputs * -************************************************************************ - use iSD_data - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" -#include "debug.fh" -#include "nsd.fh" -#include "setup.fh" -#include "stdalloc.fh" - Real*8 Fact(ndc**2), FckInt(nFckInt,nD) - Integer list_s(2,nlist_s) -* * -************************************************************************ -* * -*---- Evaluate the desired AO integrand here from the AOs, accumulate -* contributions to the SO integrals on the fly. -* - - Call Do_NInt_d() - Call Do_NIntX() -* * -************************************************************************ -* * -* Distribute result on to the full integral matrix. -* - If (nIrrep.eq.1) Then - Call AOAdd_Full(FckInt,nFckInt,nD) - Else - Call SymAdp_Full(FckInt,nFckInt,list_s,nlist_s,Fact,ndc,nD) - End If -* * -************************************************************************ -* * - End diff -Nru openmolcas-22.02/src/nq_util/dft_int.F90 openmolcas-22.10/src/nq_util/dft_int.F90 --- openmolcas-22.02/src/nq_util/dft_int.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/dft_int.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,61 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2000,2022, Roland Lindh * +! Ajitha Devarajan * +!*********************************************************************** + +subroutine DFT_Int(list_s,nlist_s,FckInt,nFckInt,nD,Fact,ndc) +!*********************************************************************** +! * +! Object: to compute contributions to * +! * +! ; integrals over the potential * +! * +! where * +! * +! F(r)=rho(r)*e(rho(r),grad[rho(r)]) * +! * +! Author:Roland Lindh, Department of Chemical Physics, University * +! of Lund, SWEDEN. November 2000 * +! D.Ajitha:Modifying for the new Kernel outputs * +!*********************************************************************** + +use Symmetry_Info, only: nIrrep +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nlist_s, list_s(2,nlist_s), nFckInt, nD, ndc +real(kind=wp), intent(inout) :: FckInt(nFckInt,nD) +real(kind=wp), intent(in) :: Fact(ndc**2) + +! * +!*********************************************************************** +! * +! Evaluate the desired AO integrand here from the AOs, accumulate +! contributions to the SO integrals on the fly. + +call Do_NInt_d() +call Do_NIntX() +! * +!*********************************************************************** +! * +! Distribute result on to the full integral matrix. + +if (nIrrep == 1) then + call AOAdd_Full(FckInt,nFckInt,nD) +else + call SymAdp_Full(FckInt,nFckInt,list_s,nlist_s,Fact,ndc,nD) +end if +! * +!*********************************************************************** +! * + +end subroutine DFT_Int diff -Nru openmolcas-22.02/src/nq_util/do_batch.f openmolcas-22.10/src/nq_util/do_batch.f --- openmolcas-22.02/src/nq_util/do_batch.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/do_batch.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,619 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2000,2021, Roland Lindh * -* 2021, Jie Bao * -************************************************************************ - Subroutine Do_Batch(Kernel,Func,mGrid, - & list_s,nlist_s,List_Exp,List_Bas, - & Index,nIndex,FckInt,nFckDim,nFckInt, - & mAO,nD,nP2_ontop,Do_Mo,TabMO,TabSO,nMOs, - & Do_Grad,Grad,nGrad,ndRho_dR,nGrad_Eff,iNQ, - & EG_OT,nTmpPUVX,PDFTPot1,PDFTFocI,PDFTFocA) -************************************************************************ -* Author:Roland Lindh, Department of Chemical Physics, University * -* of Lund, SWEDEN. November 2000 * -************************************************************************ - use iSD_data - use SOAO_Info, only: iAOtSO - use Real_Spherical - use Basis_Info - use Center_Info - use Phase_Info - use KSDFT_Info - use nq_Grid, only: Grid, Weights, Rho, nRho - use nq_Grid, only: GradRho, Sigma - use nq_Grid, only: l_CASDFT, TabAO, TabAO_Pack, dRho_dR - use nq_Grid, only: F_xc, F_xca, F_xcb, kAO, Grid_AO - use nq_Grid, only: Fact, Angular, Mem - use nq_Grid, only: D1UnZip, P2UnZip - use nq_Grid, only: Dens_AO, iBfn_Index - use nq_pdft - use nq_MO, only: CMO, D1MO, P2_ontop - use Grid_On_Disk - use nq_Info - Implicit Real*8 (A-H,O-Z) - External Kernel -#include "SysDef.fh" -#include "real.fh" -#include "stdalloc.fh" -#include "debug.fh" -#include "ksdft.fh" -#include "nsd.fh" -#include "setup.fh" -#include "pamint.fh" - Integer list_s(2,nlist_s),List_Exp(nlist_s),Index(nIndex), - & List_Bas(2,nlist_s) - Real*8 A(3), RA(3), Grad(nGrad), FckInt(nFckInt,nFckDim), - & TabMO(mAO,mGrid,nMOs),TabSO(mAO,mGrid,nMOs), - & PDFTPot1(nPot1),PDFTFocI(nPot1),PDFTFocA(nPot1) - Logical Do_Grad,Do_Mo - Logical l_tanhr - Real*8 P2_ontop_d(nP2_ontop,nGrad_Eff,mGrid) - Real*8,DIMENSION(:),ALLOCATABLE::P2MOCube,P2MOCubex,P2MOCubey, - & P2MOCubez,MOs,MOx,MOy,MOz -* MOs,MOx,MOy and MOz are for active MOs. -* MOas is for all MOs. - Integer nPMO3p - Real*8 EG_OT(nTmpPUVX) - Real*8, Allocatable:: RhoI(:,:), RhoA(:,:) - Real*8, Allocatable:: TabAO_Tmp(:) - Integer :: TabAO_Size(2) - Integer, Allocatable :: Tmp_Index(:,:) - -* * -************************************************************************ -* * -* Statement functions -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* * -************************************************************************ -* * - nCMO =Size(CMO) - l_tanhr=.false. - - If (l_casdft ) Then - CALL PDFTMemAlloc(mGrid,nOrbt) - mRho = nP2_ontop - Call mma_allocate(RhoI,mRho,mGrid,Label='RhoI') - Call mma_allocate(RhoA,mRho,mGrid,Label='RhoA') - RhoI(:,:)=Zero - RhoA(:,:)=Zero - End If -* * -************************************************************************ -* * -* Set up an indexation translation between the running index of -* the AOIntegrals and the actual basis function index -* - nBfn=0 - Do iList_s = 1, nList_s - iBas_Eff=List_Bas(1,ilist_s) - iSkal =list_s(1,ilist_s) - iCmp = iSD( 2,iSkal) - nBfn=nBfn+iBas_Eff*iCmp - End Do -* * -************************************************************************ -* * -*---- Evaluate the AOs on the grid points. * -* * -************************************************************************ -* - TabAO(:,:,:)=Zero - TabAO_Size(:)=0 -* * -************************************************************************ -* * -! Compute AO's or retrive from disk -! - If (NQ_Direct.eq.Off .and. (Grid_Status.eq.Use_Old .and. - & .Not.Do_Grad .and. - & Functional_Type.eq.Old_Functional_Type)) Then -* * -************************************************************************ -* * -*------- Retrieve (and unpack) the AOs from disc -* - Call iDaFile(Lu_Grid,2,TabAO_Size,2,iDisk_Grid) - If (TabAO_Size(1)==0) Then - Call Terminate() - Return - End If - nBfn=TabAO_Size(1) - Call mma_Allocate(iBfn_Index,6,nBfn,Label='iBfn_Index') - Call iDaFile(Lu_Grid,2,iBfn_Index,Size(iBfn_Index),iDisk_Grid) - - nByte=TabAO_Size(2) - If (Packing.eq.On) Then - mTabAO = (nByte+RtoB-1)/RtoB - Else - mTabAO = nByte - End If - Call dDaFile(Lu_Grid,2,TabAO,mTabAO,iDisk_Grid) -* - If (Packing.eq.On) Then - nData=Size(TabAO) - Call mma_Allocate(TabAO_Tmp,nData,Label='TabAO_Tmp') - nByte=TabAO_Size(2) - Call UpkR8(0,nData,nByte,TabAO_Pack,TabAO_Tmp) - TabAO_Pack(:)=TabAO_Tmp(:) - Call mma_deAllocate(TabAO_Tmp) - End If -* * -************************************************************************ -* * - Else -* * -************************************************************************ -* * -! Compute the AO's -! - Call mma_Allocate(iBfn_Index,6,nBfn,Label='iBfn_Index') - iBfn_Index(:,:)=0 -* -*------- Generate the values of the AOs on the grid -* - Mem(:)=Zero - ipxyz=1 -* -*#define _ANALYSIS_ -#ifdef _ANALYSIS_ - Thr=T_Y - Write (6,*) - Write (6,*) ' Sparsity analysis of AO blocks' - mlist_s=0 -#endif -! iOff = 1 - iBfn = 0 - iBfn_s= 0 - iBfn_e= 0 - Do ilist_s=1,nlist_s - ish=list_s(1,ilist_s) - - iShll = iSD( 0,iSh) - iAng = iSD( 1,iSh) - iCmp = iSD( 2,iSh) - iBas = iSD( 3,iSh) - iBas_Eff = List_Bas(1,ilist_s) - iPrim = iSD( 5,iSh) - iPrim_Eff=List_Exp(ilist_s) - iAO = iSD( 7,iSh) - mdci = iSD(10,iSh) - iShll = iSD(0,iSh) - iCnttp= iSD(13,iSh) - iCnt = iSD(14,iSh) - A(1:3)=dbsc(iCnttp)%Coor(1:3,iCnt) -! -! Set up the unsifted version of iBfn_Index -! - iAdd = iBas-iBas_Eff - iBfn_s = iBfn + 1 - Do i1 = 1, iCmp - iSO1 = iAOtSO(iAO+i1,0) ! just used when nIrrep=1 - Do i2 = 1, iBas_Eff - IndAO1 = i2 + iAdd - Indi = iSO1 + IndAO1 -1 - - iBfn = iBfn + 1 - iBfn_Index(1,iBfn) = Indi - iBfn_Index(2,iBfn) = ilist_s - iBfn_Index(3,iBfn) = i1 - iBfn_Index(4,iBfn) = i2 - iBfn_Index(5,iBfn) = mdci - iBfn_Index(6,iBfn) = IndAO1 - End Do - End Do - iBfn_e = iBfn - - nDrv = mRad - 1 - nForm = 0 - Do iDrv = 0, nDrv - nForm = nForm + nElem(iDrv) - End Do - nTerm = 2**nDrv - nxyz = mGrid*3*(iAng+mRad) -! nRadial = iBas_Eff*mGrid*mRad - ipRadial = ipxyz + nxyz -* - iR=list_s(2,ilist_s) -* - ipx=iPhase(1,iR) - ipy=iPhase(2,iR) - ipz=iPhase(3,iR) - px=DBLE(iPhase(1,iR)) - py=DBLE(iPhase(2,iR)) - pz=DBLE(iPhase(3,iR)) - RA(1) = px*A(1) - RA(2) = py*A(2) - RA(3) = pz*A(3) -* -*---------- Evaluate AOs at RA -* - Call AOEval(iAng,mGrid,Grid,Mem(ipxyz),RA, - & Shells(iShll)%Transf, - & RSph(ipSph(iAng)),nElem(iAng),iCmp, - & Angular,nTerm,nForm,T_Y,mRad, - & iPrim,iPrim_Eff,Shells(iShll)%Exp, - & Mem(ipRadial),iBas_Eff, - & Shells(iShll)%pCff(1,iBas-iBas_Eff+1), - & TabAO(:,:,iBfn_s:), - & mAO,px,py,pz,ipx,ipy,ipz) -#ifdef _ANALYSIS_ - ix = iDAMax_(mAO*mGrid*iBas_Eff*iCmp,TabAO_Pack(iOff),1) - TMax = Abs(TabAO_Pack(iOff-1+ix)) - If (TMax nData) then + call WarningMessage(2,'mData > nData') + write(u6,*) 'nData=',nData + write(u6,*) 'nData=',nData + call Abend() + end if + TabAO_Size(2) = nByte + call mma_deAllocate(TabAO_Tmp) + else + mData = mAO*mGrid*nBfn + TabAO_Size(2) = mData + end if + + call iDaFile(Lu_Grid,1,TabAO_Size,2,iDisk_Grid) + call iDaFile(Lu_Grid,1,iBfn_Index,size(iBfn_Index),iDisk_Grid) + mTabAO = mData + call dDaFile(Lu_Grid,1,TabAO,mTabAO,iDisk_Grid) + +end if +! * +!*********************************************************************** +! * +call Terminate() + +return + +contains + +subroutine Terminate() + + if (l_casdft) call PDFTMemDeAlloc() + + if (allocated(RhoI)) then + call mma_deallocate(RhoI) + call mma_deallocate(RhoA) + end if + if (allocated(iBfn_Index)) call mma_deAllocate(iBfn_Index) + if (allocated(Grid_AO)) call mma_deAllocate(Grid_AO) + if (allocated(Dens_AO)) call mma_deAllocate(Dens_AO) + +end subroutine Terminate + +subroutine Spectre(SMax) + + real(kind=wp), intent(out) :: SMax + integer(kind=iwp) :: iGrid, iAO + + SMax = Zero + do iGrid=1,mGrid + do iAO=1,mAO + SMax = max(SMax,abs(Weights(iGrid)*TabAO(iAO,iGrid,jBfn))) + end do + end do + !if (SMax < Thr) Write(u6,*) SMax,TMax + +end subroutine Spectre + +end subroutine Do_Batch diff -Nru openmolcas-22.02/src/nq_util/do_ggl.f openmolcas-22.10/src/nq_util/do_ggl.f --- openmolcas-22.02/src/nq_util/do_ggl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/do_ggl.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,71 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Do_GGL(L_Eff,mPt,R) -************************************************************************ -* * -* Computes datas useful for the angular quadrature. * -* * -************************************************************************ - use nq_Grid, only: Pax - use nq_Info - Implicit Real*8 (a-h,o-z) -#include "real.fh" -#include "stdalloc.fh" - Real*8, Allocatable:: Th(:,:) - Real*8, Allocatable:: R(:,:) -* * -************************************************************************ -* * -* Generate angular grid from Gauss and Gauss-Legendre quadrature -* -*---- Theta (polar angle): 0 =< theta =< pi -* Gauss-Legendre Quadrature (L_Quad+1)/2 points -*---- Phi (azimuthal angle): 0=< phi =< 2*pi -* Gauss-Quadrature (L_Quad+1) points -* - nTheta = (L_Eff+1)/2 - nPhi = L_Eff+1 -* - mPt = nTheta*nPhi - Call mma_Allocate(R,4,mPt,Label='R') -* - Call mma_allocate(Th,2,nTheta,Label='Th') -* - Call GauLeg(-One,One,Th,nTheta) -* - iOff = 1 - Do iTheta = 1, nTheta - Cos_Theta = Th(1,iTheta) - w_Theta = Th(2,iTheta) - Sin_Theta = Sqrt(One-Cos_Theta**2) -* - Do iPhi = 1, nPhi - Call Phi_point(iPhi,nPhi,Cos_Phi,Sin_Phi,w_Phi) -* - x = Sin_Theta*Cos_Phi - y = Sin_Theta*Sin_Phi - z = Cos_Theta - R(1,iOff)=Pax(1,1)*x+Pax(1,2)*y+Pax(1,3)*z - R(2,iOff)=Pax(2,1)*x+Pax(2,2)*y+Pax(2,3)*z - R(3,iOff)=Pax(3,1)*x+Pax(3,2)*y+Pax(3,3)*z - R(4,iOff)=w_Theta*w_Phi - iOff = iOff + 1 -* - End Do ! iPhi -* - End Do ! iTheta -* - Call mma_deallocate(Th) -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/do_ggl.F90 openmolcas-22.10/src/nq_util/do_ggl.F90 --- openmolcas-22.02/src/nq_util/do_ggl.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/do_ggl.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,86 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! This subroutine should be in a module, to avoid explicit interfaces +#ifdef _IN_MODULE_ + +subroutine Do_GGL(L_Eff,mPt,R) +!*********************************************************************** +! * +! Computes data useful for the angular quadrature. * +! * +!*********************************************************************** + +use nq_Grid, only: Pax +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: L_Eff +integer(kind=iwp), intent(out) :: mPt +real(kind=wp), allocatable, intent(out) :: R(:,:) +integer(kind=iwp) :: iOff, iPhi, iTheta, nPhi, nTheta +real(kind=wp) :: Cos_Phi, Cos_Theta, Sin_Phi, Sin_Theta, w_Phi, w_Theta, x, y, z +real(kind=wp), allocatable :: Th(:,:) + +! * +!*********************************************************************** +! * +! Generate angular grid from Gauss and Gauss-Legendre quadrature +! +!-- Theta (polar angle): 0 <= theta <= pi +! Gauss-Legendre Quadrature (L_Quad+1)/2 points +!-- Phi (azimuthal angle): 0 <= phi <= 2*pi +! Gauss-Quadrature (L_Quad+1) points +! +nTheta = (L_Eff+1)/2 +nPhi = L_Eff+1 + +mPt = nTheta*nPhi +call mma_allocate(R,4,mPt,Label='R') + +call mma_allocate(Th,2,nTheta,Label='Th') + +call GauLeg(-One,One,Th,nTheta) + +iOff = 1 +do iTheta=1,nTheta + Cos_Theta = Th(1,iTheta) + w_Theta = Th(2,iTheta) + Sin_Theta = sqrt(One-Cos_Theta**2) + + do iPhi=1,nPhi + call Phi_point(iPhi,nPhi,Cos_Phi,Sin_Phi,w_Phi) + + x = Sin_Theta*Cos_Phi + y = Sin_Theta*Sin_Phi + z = Cos_Theta + R(1,iOff) = Pax(1,1)*x+Pax(1,2)*y+Pax(1,3)*z + R(2,iOff) = Pax(2,1)*x+Pax(2,2)*y+Pax(2,3)*z + R(3,iOff) = Pax(3,1)*x+Pax(3,2)*y+Pax(3,3)*z + R(4,iOff) = w_Theta*w_Phi + iOff = iOff+1 + + end do ! iPhi + +end do ! iTheta + +call mma_deallocate(Th) +! * +!*********************************************************************** +! * + +return + +end subroutine Do_GGL + +#endif diff -Nru openmolcas-22.02/src/nq_util/do_grid.F90 openmolcas-22.10/src/nq_util/do_grid.F90 --- openmolcas-22.02/src/nq_util/do_grid.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/do_grid.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,28 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! This module contains procedures that need an interface +module Do_Grid + +implicit none +private + +public :: Do_GGL, Do_Lebedev, Do_Lebedev_Sym, Do_Lobatto + +contains + +#define _IN_MODULE_ +#include "do_ggl.F90" +#include "do_lebedev.F90" +#include "do_lebedev_sym.F90" +#include "do_lobatto.F90" + +end module Do_Grid diff -Nru openmolcas-22.02/src/nq_util/do_index.f openmolcas-22.10/src/nq_util/do_index.f --- openmolcas-22.02/src/nq_util/do_index.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/do_index.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,26 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Do_Index(Index,NrBas,NrBas_Eff,iCmp) - Implicit Real*8 (a-h,o-z) - Integer Index(NrBas_Eff*iCmp) -* - iAdd=NrBas-NrBas_Eff - Do iB_Eff = 1, NrBas_Eff - iB = iB_Eff + iAdd - Do iC = 1, iCmp - iCB = (iC-1)*NrBas + iB - iCB_Eff = (iC-1)*NrBas_Eff + iB_Eff - Index(iCB_Eff)=iCB - End Do - End Do -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/do_index.F90 openmolcas-22.10/src/nq_util/do_index.F90 --- openmolcas-22.02/src/nq_util/do_index.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/do_index.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,31 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Do_Index(Indx,NrBas,NrBas_Eff,iCmp) + +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: NrBas_Eff, iCmp, NrBas +integer(kind=iwp), intent(out) :: Indx(NrBas_Eff,iCmp) +integer(kind=iwp) :: iAdd, iB, iB_Eff, iC + +iAdd = NrBas-NrBas_Eff +do iB_Eff=1,NrBas_Eff + iB = iB_Eff+iAdd + do iC=1,iCmp + Indx(iB_Eff,iC) = (iC-1)*NrBas+iB + end do +end do + +return + +end subroutine Do_Index diff -Nru openmolcas-22.02/src/nq_util/do_lebedev.f openmolcas-22.10/src/nq_util/do_lebedev.f --- openmolcas-22.02/src/nq_util/do_lebedev.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/do_lebedev.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,70 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Do_Lebedev(L_Eff,mPt,R) -************************************************************************ -* * -* Computes datas useful for the angular quadrature. * -* * -************************************************************************ - use nq_Grid, only: Pax - use nq_Info - Implicit Real*8 (a-h,o-z) -#include "real.fh" -#include "stdalloc.fh" - Parameter (nSet=11) - Integer Lebedev_order(nSet), Lebedev_npoints(nSet) - Data Lebedev_order/5,7,11,17,23,29,35,41,47,53,59/ - Data Lebedev_npoints/14,26,50,110,194,302,434,590,770,974,1202/ - Real*8, Allocatable:: TempR(:,:), TempW(:) - Real*8, Allocatable:: R(:,:) -* * -************************************************************************ -* * -*---- Generate angular grid a la Lebedev -* - Do iSet = 1, nSet - If (Lebedev_order(iSet).eq.L_Eff) Then - mPt=Lebedev_npoints(iSet) - Call mma_allocate(R,4,mPt,Label='R') - Call mma_allocate(TempR,3,mPt,Label='TempR') - Call mma_allocate(TempW,mPt,Label='TempW') -* - Call Lebedev(TempR,TempW,nPt,mPt,L_Eff) - If (nPt.ne.mPt) Then - Call WarningMessage(2,'Lebedev_Grid: nPt.ne.mPt') - Write (6,*) 'nPt=',nPt - Write (6,*) 'mPt=',mPt - Call Abend() - End If - Call DScal_(nPt,Four*Pi,TempW,1) -* - Call DGEMM_('N','N', - & 3,nPt,3, - & 1.0d0,Pax,3, - & TempR,3, - & 0.0d0,R,4) - call dcopy_(nPt,TempW,1,R(4,1),4) -* - Call mma_deallocate(TempW) - Call mma_deallocate(TempR) -* - Return -* - End If - End Do - Write (6,'(A,I3)') 'Failed to find a Lebedev grid of order', L_EFF - Write (6,'(A)') 'Available orders are:' - Write (6,'(11(1X,I3))') (Lebedev_order(i),i=1,nSet) - Call Abend() -* * -************************************************************************ -* * - End diff -Nru openmolcas-22.02/src/nq_util/do_lebedev.F90 openmolcas-22.10/src/nq_util/do_lebedev.F90 --- openmolcas-22.02/src/nq_util/do_lebedev.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/do_lebedev.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,76 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! This subroutine should be in a module, to avoid explicit interfaces +#ifdef _IN_MODULE_ + +subroutine Do_Lebedev(L_Eff,mPt,R) +!*********************************************************************** +! * +! Computes data useful for the angular quadrature. * +! * +!*********************************************************************** + +use nq_Grid, only: Pax +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Four, Pi +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: L_Eff +integer(kind=iwp), intent(out) :: mPt +real(kind=wp), allocatable, intent(out) :: R(:,:) +integer(kind=iwp) :: iSet, nPt +integer(kind=iwp), parameter :: nSet = 11, Lebedev_order(nSet) = [5,7,11,17,23,29,35,41,47,53,59], & + Lebedev_npoints(nSet) = [14,26,50,110,194,302,434,590,770,974,1202] +real(kind=wp), allocatable :: TempR(:,:), TempW(:) + +! * +!*********************************************************************** +! * +! Generate angular grid a la Lebedev + +do iSet=1,nSet + if (Lebedev_order(iSet) == L_Eff) then + mPt = Lebedev_npoints(iSet) + call mma_allocate(R,4,mPt,Label='R') + call mma_allocate(TempR,3,mPt,Label='TempR') + call mma_allocate(TempW,mPt,Label='TempW') + + call Lebedev(TempR,TempW,nPt,mPt,L_Eff) + if (nPt /= mPt) then + call WarningMessage(2,'Lebedev_Grid: nPt /= mPt') + write(u6,*) 'nPt=',nPt + write(u6,*) 'mPt=',mPt + call Abend() + end if + + call DGEMM_('N','N',3,nPt,3,One,Pax,3,TempR,3,Zero,R,4) + R(4,:) = Four*Pi*TempW + + call mma_deallocate(TempW) + call mma_deallocate(TempR) + + return + + end if +end do +write(u6,'(A,I3)') 'Failed to find a Lebedev grid of order',L_EFF +write(u6,'(A)') 'Available orders are:' +write(u6,'(11(1X,I3))') Lebedev_order(:) +call Abend() +! * +!*********************************************************************** +! * + +end subroutine Do_Lebedev + +#endif diff -Nru openmolcas-22.02/src/nq_util/do_lebedev_sym.f openmolcas-22.10/src/nq_util/do_lebedev_sym.f --- openmolcas-22.02/src/nq_util/do_lebedev_sym.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/do_lebedev_sym.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2019, Ignacio Fdez. Galvan * -************************************************************************ - Subroutine Do_Lebedev_Sym(L_Eff,mPt,ipR) - Implicit None -#include "WrkSpc.fh" -#include "stdalloc.fh" - Integer, Intent(In) :: L_Eff - Integer, Intent(Out) :: mPt, ipR - Integer :: mPt_, i, j - Real*8, Parameter :: Thr = 1.0D-16 - Real*8, Allocatable:: R(:,:) -* * -************************************************************************ -* * - Interface - Subroutine Do_Lebedev(L_Eff,nPoints,R) - Implicit None - Integer L_Eff, nPoints - Real*8, Allocatable:: R(:,:) - End Subroutine Do_Lebedev - End Interface -* * -************************************************************************ -* * - Call Do_Lebedev(L_Eff,mPt_,R) - mPt=0 - outer: Do i=1,mPt_ - Do j=1,i-1 - If (All(Abs(R(1:3,j)+R(1:3,i)).lt.Thr)) Then - R(4,i)=0.0D0 - Cycle outer - End If - End Do - mPt=mPt+1 - End Do outer - - Call GetMem('AngRW','Allo','Real',ipR,4*mPt) - - j=1 - Do i=1,mPt_ - If (R(4,i).ne.0.0D0) Then - Call DCopy_(4,R(:,i),1,Work(ipR+(j-1)*4),1) - j=j+1 - End if - End Do - Call mma_deallocate(R) - End Subroutine Do_Lebedev_Sym diff -Nru openmolcas-22.02/src/nq_util/do_lebedev_sym.F90 openmolcas-22.10/src/nq_util/do_lebedev_sym.F90 --- openmolcas-22.02/src/nq_util/do_lebedev_sym.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/do_lebedev_sym.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,59 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2019, Ignacio Fdez. Galvan * +!*********************************************************************** + +! This subroutine should be in a module, to avoid explicit interfaces +#ifdef _IN_MODULE_ + +subroutine Do_Lebedev_Sym(L_Eff,mPt,R) + +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: L_Eff +integer(kind=iwp), intent(out) :: mPt +real(kind=wp), allocatable, intent(out) :: R(:,:) +integer(kind=iwp) :: i, j, mPt_f +real(kind=wp), allocatable :: R_f(:,:) +real(kind=wp), parameter :: Thr = 1.0e-16_wp + +! * +!*********************************************************************** +! * +call Do_Lebedev(L_Eff,mPt_f,R_f) +mPt = 0 +outer: do i=1,mPt_f + do j=1,i-1 + if (all(abs(R_f(1:3,j)+R_f(1:3,i)) < Thr)) then + R_f(4,i) = Zero + cycle outer + end if + end do + mPt = mPt+1 +end do outer + +call mma_allocate(R,4,mPt,label='R') + +j = 1 +do i=1,mPt_f + if (R_f(4,i) /= Zero) then + R(:,j) = R_f(:,i) + j = j+1 + end if +end do +call mma_deallocate(R_f) + +end subroutine Do_Lebedev_Sym + +#endif diff -Nru openmolcas-22.02/src/nq_util/do_lobatto.f openmolcas-22.10/src/nq_util/do_lobatto.f --- openmolcas-22.02/src/nq_util/do_lobatto.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/do_lobatto.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,82 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Do_Lobatto(L_Eff,nPoints,R) -************************************************************************ -* * -* Computes datas useful for the angular quadrature. * -* * -************************************************************************ - use nq_Grid, only: Pax - use nq_Info - Implicit Real*8 (a-h,o-z) -#include "real.fh" -#include "stdalloc.fh" - Real*8, Allocatable:: Labatto(:), R(:,:) -* * -************************************************************************ -* * -*---- Generate angular grid a la Lobatto -* - nPoints=0 - nTheta = (L_Eff+3)/2 - Do iTheta = 1, nTheta - nPhi = L_Eff - If(iTheta.eq.1.or.iTheta.eq.nTheta) nPhi = 1 - If(iTheta.eq.nTheta/2+1.and.nTheta/2*2-nTheta.eq.-1.and. - & nTheta.gt.3) nPhi = L_Eff+4 -* - nPoints = nPoints + nPhi -* - End Do -* - Call mma_allocate(R,4,nPoints,Label='R') -* - nTheta = (L_Eff+3)/2 - nLabatto=3*(nTheta+2)*(nTheta+3)/2 - Call mma_allocate(Labatto,nLabatto,Label='Labatto') - Call Lobatto(ntheta,Labatto) -* - mTheta=nTheta-1 - iOffT=1 + 3*mTheta*(mTheta+1)/2 - iOff = 1 - Do iTheta = 1, nTheta -* - Cos_Theta=Labatto(iOffT) - Sin_Theta=Sqrt(One-Cos_Theta**2) - w_Theta =Labatto(iOffT+1) - iOffT = iOffT + 3 -* - nPhi = L_Eff - if(iTheta.eq.1.or.iTheta.eq.nTheta) nPhi = 1 - if(iTheta.eq.nTheta/2+1.and.nTheta/2*2-nTheta.eq.-1.and. - & nTheta.gt.3) nPhi = L_Eff+4 -* - Do iPhi = 1, nPhi - Call Phi_point(iPhi,nPhi,Cos_Phi,Sin_Phi,w_Phi) -* - x = Sin_Theta*Cos_Phi - y = Sin_Theta*Sin_Phi - z = Cos_Theta - R(1,iOff)=Pax(1,1)*x+Pax(1,2)*y+Pax(1,3)*z - R(2,iOff)=Pax(2,1)*x+Pax(2,2)*y+Pax(2,3)*z - R(3,iOff)=Pax(3,1)*x+Pax(3,2)*y+Pax(3,3)*z - R(4,iOff)=w_Theta*w_Phi - iOff = iOff + 1 -* - End Do ! iPhi -* - End Do ! iTheta - Call mma_deallocate(Labatto) -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/do_lobatto.F90 openmolcas-22.10/src/nq_util/do_lobatto.F90 --- openmolcas-22.02/src/nq_util/do_lobatto.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/do_lobatto.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,96 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! This subroutine should be in a module, to avoid explicit interfaces +#ifdef _IN_MODULE_ + +subroutine Do_Lobatto(L_Eff,nPoints,R) +!*********************************************************************** +! * +! Computes data useful for the angular quadrature. * +! * +!*********************************************************************** + +use nq_Grid, only: Pax +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: L_Eff +integer(kind=iwp), intent(out) :: nPoints +real(kind=wp), allocatable, intent(out) :: R(:,:) +integer(kind=iwp) :: iOff, iOffT, iPhi, iTheta, mTheta, nLabatto, nPhi, nTheta +real(kind=wp) :: Cos_Phi, Cos_Theta, Sin_Phi, Sin_Theta, w_Phi, w_Theta, x, y, z +real(kind=wp), allocatable :: Labatto(:) + +! * +!*********************************************************************** +! * +! Generate angular grid a la Lobatto + +nPoints = 0 +nTheta = (L_Eff+3)/2 +do iTheta=1,nTheta + nPhi = L_Eff + if ((iTheta == 1) .or. (iTheta == nTheta)) nPhi = 1 + if ((iTheta == nTheta/2+1) .and. (nTheta/2*2-nTheta == -1) .and. (nTheta > 3)) nPhi = L_Eff+4 + + nPoints = nPoints+nPhi + +end do + +call mma_allocate(R,4,nPoints,Label='R') + +nTheta = (L_Eff+3)/2 +nLabatto = 3*(nTheta+2)*(nTheta+3)/2 +call mma_allocate(Labatto,nLabatto,Label='Labatto') +call Lobatto(ntheta,Labatto) + +mTheta = nTheta-1 +iOffT = 1+3*mTheta*(mTheta+1)/2 +iOff = 1 +do iTheta=1,nTheta + + Cos_Theta = Labatto(iOffT) + Sin_Theta = sqrt(One-Cos_Theta**2) + w_Theta = Labatto(iOffT+1) + iOffT = iOffT+3 + + nPhi = L_Eff + if ((iTheta == 1) .or. (iTheta == nTheta)) nPhi = 1 + if ((iTheta == nTheta/2+1) .and. (nTheta/2*2-nTheta == -1) .and. (nTheta > 3)) nPhi = L_Eff+4 + + do iPhi=1,nPhi + call Phi_point(iPhi,nPhi,Cos_Phi,Sin_Phi,w_Phi) + + x = Sin_Theta*Cos_Phi + y = Sin_Theta*Sin_Phi + z = Cos_Theta + R(1,iOff) = Pax(1,1)*x+Pax(1,2)*y+Pax(1,3)*z + R(2,iOff) = Pax(2,1)*x+Pax(2,2)*y+Pax(2,3)*z + R(3,iOff) = Pax(3,1)*x+Pax(3,2)*y+Pax(3,3)*z + R(4,iOff) = w_Theta*w_Phi + iOff = iOff+1 + + end do ! iPhi + +end do ! iTheta +call mma_deallocate(Labatto) +! * +!*********************************************************************** +! * + +return + +end subroutine Do_Lobatto + +#endif diff -Nru openmolcas-22.02/src/nq_util/do_nint_d.f openmolcas-22.10/src/nq_util/do_nint_d.f --- openmolcas-22.02/src/nq_util/do_nint_d.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/do_nint_d.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,496 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991,2021,2022, Roland Lindh * -************************************************************************ -************************************************************************ -* * - Subroutine Do_NInt_d() -* * -************************************************************************ -************************************************************************ - use nq_Grid, only: GradRho, Weights - use nq_Grid, only: vRho, vSigma, vTau, vLapl - use nq_Grid, only: Grid_AO, TabAO, iBfn_Index - use nq_Info - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -* * -************************************************************************ -************************************************************************ -* * - nD=Size(Grid_AO,4) - mGrid=Size(TabAO,2) - nBfn=Size(iBfn_Index,2) -* * -************************************************************************ -************************************************************************ -* * - Select Case(Functional_type) -* * -************************************************************************ -************************************************************************ -* * - Case (LDA_type) -! -! F(Rho) -! -! for the integrals we need: -! -! phi_i dF/dRho phi_j -! -! Grid_AO contains -! 1: phi_i dF/dRho -! -! Final integral assembled as, done in do_nIntx. -! -! Grid_AO(1)_i phi_j -* * -************************************************************************ -************************************************************************ -* * - Select Case (nD) -* * -************************************************************************ -* * - Case(1) -* * -************************************************************************ -* * - Do iGrid = 1, mGrid - -! If (Rho(1,iGrid). * +! * +! Copyright (C) 1991,2021,2022, Roland Lindh * +!*********************************************************************** + +subroutine Do_NInt_d() + +use nq_Grid, only: GradRho, Grid_AO, iBfn_Index, TabAO, vLapl, vRho, vSigma, vTau, Weights +use nq_Info, only: Functional_type, GGA_type, LDA_type, meta_GGA_type1, meta_GGA_type2 +use Constants, only: Two, Half +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp) :: iCB, iGrid, mGrid, nBfn, nD +real(kind=wp) :: gx, gxa, gxb, gy, gya, gyb, gz, gza, gzb, Temp0, Temp0a, Temp0b, Temp1, Temp1a, Temp1b, Temp2, Temp2a, Temp2b, & + Temp3, Temp3a, Temp3b, Temp4, Temp45, Temp45a, Temp45b, Temp4a, Temp4b, Temp5, Temp5a, Temp5b, Tmp, Tmp1, Tmp2 + +! * +!*********************************************************************** +! * +nD = size(Grid_AO,4) +mGrid = size(TabAO,2) +nBfn = size(iBfn_Index,2) +! * +!*********************************************************************** +! * +select case (Functional_type) + + case (LDA_type) + ! * + !******************************************************************* + !******************************************************************* + ! * + ! F(Rho) + ! + ! for the integrals we need: + ! + ! phi_i dF/dRho phi_j + ! + ! Grid_AO contains + ! 1: phi_i dF/dRho + ! + ! Final integral assembled as, done in do_nIntx. + ! + ! Grid_AO(1)_i phi_j + ! * + !******************************************************************* + !******************************************************************* + ! * + select case (nD) + ! * + !***************************************************************** + ! * + case (1) + ! * + !*************************************************************** + ! * + do iGrid=1,mGrid + + !if (Rho(1,iGrid) < Thr) cycle + Tmp = vRho(1,iGrid)*Weights(iGrid) + + do iCB=1,nBfn + Grid_AO(1,iGrid,iCB,1) = TabAO(1,iGrid,iCB)*Tmp + end do + + end do + ! * + !*************************************************************** + ! * + case (2) + ! * + !*************************************************************** + ! * + do iGrid=1,mGrid + + !if (Rho(1,iGrid)+Rho(2,iGrid) < Thr) cycle + Tmp1 = vRho(1,iGrid)*Weights(iGrid) + Tmp2 = vRho(2,iGrid)*Weights(iGrid) + + do iCB=1,nBfn + Grid_AO(1,iGrid,iCB,1) = TabAO(1,iGrid,iCB)*Tmp1 + Grid_AO(1,iGrid,iCB,2) = TabAO(1,iGrid,iCB)*Tmp2 + end do + + end do + ! * + !*************************************************************** + ! * + case default + write(u6,*) 'Invalid nD value:',nD + call Abend() + end select ! nD + ! * + !******************************************************************* + !******************************************************************* + ! * + case (GGA_type) + ! * + !******************************************************************* + !******************************************************************* + ! * + ! F(Rho,Sigma) : Sigma=GradRho*GradRho + ! + ! dF/dGradRho = dF/dSigma dSigma/dGradRho = 2 dF/dSigma GradRho + ! + ! for the integrals we need: + ! + ! phi_i dF/dRho phi_j + ! + phi_i 2 (dF/dSigma) {GradRho Grad(phi_j)} + ! + {Grad(phi_i) GradRho} 2 (dF/dSigma) phi_j + ! + ! Grid_AO contains + ! 1: 0.5 * phi_i dF/dRho + ! + {Grad(phi_i GradRho} 2 (dF/dSigma) + ! + ! Final integral assembled as, done in do_nIntx. + ! + ! Grid_AO(1)_i phi_j + ! + phi_i Grid_AO(1)_j + ! * + !******************************************************************* + !******************************************************************* + ! * + select case (nD) + ! * + !***************************************************************** + ! * + case (1) + ! * + !*************************************************************** + ! * + do iGrid=1,mGrid + + !if (Rho(1,iGrid) < Thr) cycle + gx = GradRho(1,iGrid)*Weights(iGrid) + gy = GradRho(2,iGrid)*Weights(iGrid) + gz = GradRho(3,iGrid)*Weights(iGrid) + + Temp0 = Half*vRho(1,iGrid)*Weights(iGrid) + Temp1 = gx*Two*vSigma(1,iGrid) + Temp2 = gy*Two*vSigma(1,iGrid) + Temp3 = gz*Two*vSigma(1,iGrid) + + do iCB=1,nBfn + + Grid_AO(1,iGrid,iCB,1) = TabAO(1,iGrid,iCB)*Temp0+TabAO(2,iGrid,iCB)*Temp1+TabAO(3,iGrid,iCB)*Temp2+ & + TabAO(4,iGrid,iCB)*Temp3 + end do + + end do + ! * + !************************************************************** + ! * + case (2) + ! * + !*************************************************************** + ! * + do iGrid=1,mGrid + + !if (Rho(1,iGrid)+Rho(2,iGrid) < Thr) cycle + gxa = Gradrho(1,iGrid)*Weights(iGrid) + gya = Gradrho(2,iGrid)*Weights(iGrid) + gza = Gradrho(3,iGrid)*Weights(iGrid) + gxb = Gradrho(4,iGrid)*Weights(iGrid) + gyb = Gradrho(5,iGrid)*Weights(iGrid) + gzb = Gradrho(6,iGrid)*Weights(iGrid) + + Temp0a = Half*vRho(1,iGrid)*Weights(iGrid) + Temp0b = Half*vRho(2,iGrid)*Weights(iGrid) + Temp1a = Two*vSigma(1,iGrid)*gxa+vSigma(2,iGrid)*gxb + Temp1b = Two*vSigma(3,iGrid)*gxb+vSigma(2,iGrid)*gxa + Temp2a = Two*vSigma(1,iGrid)*gya+vSigma(2,iGrid)*gyb + Temp2b = Two*vSigma(3,iGrid)*gyb+vSigma(2,iGrid)*gya + Temp3a = Two*vSigma(1,iGrid)*gza+vSigma(2,iGrid)*gzb + Temp3b = Two*vSigma(3,iGrid)*gzb+vSigma(2,iGrid)*gza + + do iCB=1,nBfn + + Grid_AO(1,iGrid,iCB,1) = TabAO(1,iGrid,iCB)*Temp0a+TabAO(2,iGrid,iCB)*Temp1a+TabAO(3,iGrid,iCB)*Temp2a+ & + TabAO(4,iGrid,iCB)*Temp3a + Grid_AO(1,iGrid,iCB,2) = TabAO(1,iGrid,iCB)*Temp0b+TabAO(2,iGrid,iCB)*Temp1b+TabAO(3,iGrid,iCB)*Temp2b+ & + TabAO(4,iGrid,iCB)*Temp3b + end do + + end do + ! * + !*************************************************************** + ! * + case default + write(u6,*) 'Invalid nD value:',nD + call Abend() + end select ! nD + ! * + !******************************************************************* + !******************************************************************* + ! * + case (meta_GGA_type1) + ! * + !******************************************************************* + !******************************************************************* + ! * + ! F(Rho,Sigma,Tau) : Sigma=GradRho*GradRho + ! + ! dF/dGradRho = dF/dSigma dSigma/dGradRho = 2 dF/dSigma GradRho + ! + ! for the integrals we need: + ! + ! phi_i dF/dRho phi_j + ! + phi_i 2 (dF/dSigma) {GradRho Grad(phi_j)} + ! + {Grad(phi_i) GradRho} 2 (dF/dSigma) phi_j + ! + dF/dTau {Grad(phi_i) Grad(phi_j)} + ! + ! Grid_AO contains + ! 1: 0.5 * phi_i dF/dRho + {Grad(phi_i) GradRho} 2 (dF/dSigma) + ! 2: Grad(phi_i)_x dF/dTau + ! 3: Grad(phi_i)_y dF/dTau + ! 4: Grad(phi_i)_z dF/dTau + ! + ! Final integral assembled as, done in do_nIntx. + ! + ! Grid_AO(1)_i phi_j + ! + Phi_i * Grid_AO(1)_j + ! + Grid_AO(2)_i Grad(phi_j)_x + ! + Grid_AO(3)_i Grad(phi_j)_y + ! + Grid_AO(4)_i Grad(phi_j)_z + ! * + !******************************************************************* + !******************************************************************* + ! * + select case (nD) + ! * + !***************************************************************** + ! * + case (1) + ! * + !*************************************************************** + ! * + do iGrid=1,mGrid + + !if (Rho(1,iGrid) < Thr) cycle + gx = GradRho(1,iGrid)*Weights(iGrid) + gy = GradRho(2,iGrid)*Weights(iGrid) + gz = GradRho(3,iGrid)*Weights(iGrid) + + Temp0 = Half*vRho(1,iGrid)*Weights(iGrid) + Temp1 = gx*Two*vSigma(1,iGrid) + Temp2 = gy*Two*vSigma(1,iGrid) + Temp3 = gz*Two*vSigma(1,iGrid) + + Temp4 = Half*vTau(1,iGrid)*Weights(iGrid) + + do iCB=1,nBfn + + Grid_AO(1,iGrid,iCB,1) = TabAO(1,iGrid,iCB)*Temp0+TabAO(2,iGrid,iCB)*Temp1+TabAO(3,iGrid,iCB)*Temp2+ & + TabAO(4,iGrid,iCB)*Temp3 + Grid_AO(2,iGrid,iCB,1) = TabAO(2,iGrid,iCB)*Temp4 + Grid_AO(3,iGrid,iCB,1) = TabAO(3,iGrid,iCB)*Temp4 + Grid_AO(4,iGrid,iCB,1) = TabAO(4,iGrid,iCB)*Temp4 + end do + + end do + ! * + !*************************************************************** + ! * + case (2) + ! * + !*************************************************************** + ! * + do iGrid=1,mGrid + + !if (Rho(1,iGrid)+Rho(2,iGrid) < Thr) cycle + gxa = Gradrho(1,iGrid)*Weights(iGrid) + gya = Gradrho(2,iGrid)*Weights(iGrid) + gza = Gradrho(3,iGrid)*Weights(iGrid) + gxb = Gradrho(4,iGrid)*Weights(iGrid) + gyb = Gradrho(5,iGrid)*Weights(iGrid) + gzb = Gradrho(6,iGrid)*Weights(iGrid) + + Temp0a = Half*vRho(1,iGrid)*Weights(iGrid) + Temp0b = Half*vRho(2,iGrid)*Weights(iGrid) + Temp1a = Two*vSigma(1,iGrid)*gxa+vSigma(2,iGrid)*gxb + Temp1b = Two*vSigma(3,iGrid)*gxb+vSigma(2,iGrid)*gxa + Temp2a = Two*vSigma(1,iGrid)*gya+vSigma(2,iGrid)*gyb + Temp2b = Two*vSigma(3,iGrid)*gyb+vSigma(2,iGrid)*gya + Temp3a = Two*vSigma(1,iGrid)*gza+vSigma(2,iGrid)*gzb + Temp3b = Two*vSigma(3,iGrid)*gzb+vSigma(2,iGrid)*gza + Temp4a = Half*vTau(1,iGrid)*Weights(iGrid) + Temp4b = Half*vTau(2,iGrid)*Weights(iGrid) + + do iCB=1,nBfn + + Grid_AO(1,iGrid,iCB,1) = TabAO(1,iGrid,iCB)*Temp0a+TabAO(2,iGrid,iCB)*Temp1a+TabAO(3,iGrid,iCB)*Temp2a+ & + TabAO(4,iGrid,iCB)*Temp3a + Grid_AO(2,iGrid,iCB,1) = TabAO(2,iGrid,iCB)*Temp4a + Grid_AO(3,iGrid,iCB,1) = TabAO(3,iGrid,iCB)*Temp4a + Grid_AO(4,iGrid,iCB,1) = TabAO(4,iGrid,iCB)*Temp4a + + Grid_AO(1,iGrid,iCB,2) = TabAO(1,iGrid,iCB)*Temp0b+TabAO(2,iGrid,iCB)*Temp1b+TabAO(3,iGrid,iCB)*Temp2b+ & + TabAO(4,iGrid,iCB)*Temp3b + Grid_AO(2,iGrid,iCB,2) = TabAO(2,iGrid,iCB)*Temp4b + Grid_AO(3,iGrid,iCB,2) = TabAO(3,iGrid,iCB)*Temp4b + Grid_AO(4,iGrid,iCB,2) = TabAO(4,iGrid,iCB)*Temp4b + + end do + + end do + ! * + !*************************************************************** + ! * + case default + write(u6,*) 'Invalid nD value:',nD + call Abend() + end select ! nD + ! * + !******************************************************************* + !******************************************************************* + ! * + case (meta_GGA_type2) + ! * + !******************************************************************* + !******************************************************************* + ! * + ! F(Rho,Sigma,Tau,Lapl) : Sigma=GradRho*GradRho + ! + ! dF/dGradRho = dF/dSigma dSigma/dGradRho = 2 dF/dSigma GradRho + ! + ! for the integrals we need: + ! + ! phi_i dF/dRho phi_j + ! + phi_i 2 dF/dSigma {GradRho Grad(phi_j)} + ! + {Grad(phi_i) GradRho} 2 (dF/dSigma) phi_j + ! + dF/dTau {Grad(phi_i) Grad(phi_j)} + ! + dF/dLapl Lapl(phi_i) phi_j + ! + dF/dLapl 2 {Grad(phi_i) Grad(phi_j)} + ! + dF/dLapl phi_i Lapl(phi_j) + ! + ! Grid_AO contains + ! 1: 0.5 phi_i dF/dRho + {Grad(phi_i) GradRho} 2 (dF/dSigma) + ! +Lapl(phi_i) dF/dLapl + ! 2: Grad(phi_i)_x (dF/dTau + 2 dF/dLapl) + ! 3: Grad(phi_i)_y (dF/dTau + 2 dF/dLapl) + ! 4: Grad(phi_i)_z (dF/dTau + 2 dF/dLapl) + ! + ! Final integral assembled as, done in do_nIntx. + ! + ! Grid_AO(1)_i phi_j + ! + phi_i Grid_AO(1)_j + ! + Grid_AO(2)_i Grad(phi_j)_x + ! + Grid_AO(3)_i Grad(phi_j)_y + ! + Grid_AO(4)_i Grad(phi_j)_z + ! * + !******************************************************************* + !******************************************************************* + ! * + select case (nD) + ! * + !***************************************************************** + ! * + case (1) + ! * + !*************************************************************** + ! * + + do iGrid=1,mGrid + + !if (Rho(1,iGrid) < Thr) cycle + gx = GradRho(1,iGrid)*Weights(iGrid) + gy = GradRho(2,iGrid)*Weights(iGrid) + gz = GradRho(3,iGrid)*Weights(iGrid) + + Temp0 = Half*vRho(1,iGrid)*Weights(iGrid) + Temp1 = gx*Two*vSigma(1,iGrid) + Temp2 = gy*Two*vSigma(1,iGrid) + Temp3 = gz*Two*vSigma(1,iGrid) + + Temp4 = Half*vTau(1,iGrid)*Weights(iGrid) + Temp5 = vLapl(1,iGrid)*Weights(iGrid) + Temp45 = Temp4+Two*Temp5 + + do iCB=1,nBfn + + Grid_AO(1,iGrid,iCB,1) = TabAO(1,iGrid,iCB)*Temp0+TabAO(2,iGrid,iCB)*Temp1+TabAO(3,iGrid,iCB)*Temp2+ & + TabAO(4,iGrid,iCB)*Temp3+(TabAO(5,iGrid,iCB)+TabAO(8,iGrid,iCB)+TabAO(10,iGrid,iCB))*Temp5 + Grid_AO(2,iGrid,iCB,1) = TabAO(2,iGrid,iCB)*Temp45 + Grid_AO(3,iGrid,iCB,1) = TabAO(3,iGrid,iCB)*Temp45 + Grid_AO(4,iGrid,iCB,1) = TabAO(4,iGrid,iCB)*Temp45 + end do + + end do + ! * + !*************************************************************** + ! * + case (2) + ! * + !*************************************************************** + ! * + do iGrid=1,mGrid + + !if (Rho(1,iGrid)+Rho(2,iGrid) < Thr) cycle + gxa = Gradrho(1,iGrid)*Weights(iGrid) + gya = Gradrho(2,iGrid)*Weights(iGrid) + gza = Gradrho(3,iGrid)*Weights(iGrid) + gxb = Gradrho(4,iGrid)*Weights(iGrid) + gyb = Gradrho(5,iGrid)*Weights(iGrid) + gzb = Gradrho(6,iGrid)*Weights(iGrid) + + Temp0a = Half*vRho(1,iGrid)*Weights(iGrid) + Temp0b = Half*vRho(2,iGrid)*Weights(iGrid) + Temp1a = Two*vSigma(1,iGrid)*gxa+vSigma(2,iGrid)*gxb + Temp1b = Two*vSigma(3,iGrid)*gxb+vSigma(2,iGrid)*gxa + Temp2a = Two*vSigma(1,iGrid)*gya+vSigma(2,iGrid)*gyb + Temp2b = Two*vSigma(3,iGrid)*gyb+vSigma(2,iGrid)*gya + Temp3a = Two*vSigma(1,iGrid)*gza+vSigma(2,iGrid)*gzb + Temp3b = Two*vSigma(3,iGrid)*gzb+vSigma(2,iGrid)*gza + Temp4a = Half*vTau(1,iGrid)*Weights(iGrid) + Temp4b = Half*vTau(2,iGrid)*Weights(iGrid) + Temp5a = vLapl(1,iGrid)*Weights(iGrid) + Temp5b = vLapl(2,iGrid)*Weights(iGrid) + Temp45a = Temp4a+Two*Temp5a + Temp45b = Temp4b+Two*Temp5b + + do iCB=1,nBfn + + Grid_AO(1,iGrid,iCB,1) = TabAO(1,iGrid,iCB)*Temp0a+TabAO(2,iGrid,iCB)*Temp1a+TabAO(3,iGrid,iCB)*Temp2a+ & + TabAO(4,iGrid,iCB)*Temp3a+(TabAO(5,iGrid,iCB)+TabAO(8,iGrid,iCB)+TabAO(10,iGrid,iCB))*Temp5a + Grid_AO(2,iGrid,iCB,1) = TabAO(2,iGrid,iCB)*Temp45a + Grid_AO(3,iGrid,iCB,1) = TabAO(3,iGrid,iCB)*Temp45a + Grid_AO(4,iGrid,iCB,1) = TabAO(4,iGrid,iCB)*Temp45a + + Grid_AO(1,iGrid,iCB,2) = TabAO(1,iGrid,iCB)*Temp0b+TabAO(2,iGrid,iCB)*Temp1b+TabAO(3,iGrid,iCB)*Temp2b+ & + TabAO(4,iGrid,iCB)*Temp3b+(TabAO(5,iGrid,iCB)+TabAO(8,iGrid,iCB)+TabAO(10,iGrid,iCB))*Temp5b + Grid_AO(2,iGrid,iCB,2) = TabAO(2,iGrid,iCB)*Temp45b + Grid_AO(3,iGrid,iCB,2) = TabAO(3,iGrid,iCB)*Temp45b + Grid_AO(4,iGrid,iCB,2) = TabAO(4,iGrid,iCB)*Temp45b + end do + + end do + ! * + !*************************************************************** + ! * + case default + write(u6,*) 'Invalid nD value:',nD + call Abend() + end select ! nD + ! * + !******************************************************************* + !******************************************************************* + ! * + case default + ! * + !******************************************************************* + !******************************************************************* + ! * + write(u6,*) 'DFT_Int: Illegal functional type!' + call Abend() + ! * + !******************************************************************* + !******************************************************************* + ! * +end select +! * +!*********************************************************************** +! * + +return + +end subroutine Do_NInt_d diff -Nru openmolcas-22.02/src/nq_util/do_nintx.f openmolcas-22.10/src/nq_util/do_nintx.f --- openmolcas-22.02/src/nq_util/do_nintx.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/do_nintx.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,231 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991,2021,2022, Roland Lindh * -************************************************************************ -************************************************************************ -* * - Subroutine Do_NIntX() -* * -************************************************************************ -************************************************************************ - use nq_Grid, only: Grid_AO, TabAO - use nq_Grid, only: AOInt => Dens_AO - use nq_Grid, only: iBfn_Index - use nq_Info - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "stdalloc.fh" - Real*8, Allocatable:: A1(:,:), A2(:,:), A_tri(:) - Real*8, Allocatable:: A3(:,:,:), A4(:,:,:) -* * -************************************************************************ -************************************************************************ -* * - mGrid=SIZE(TabAO,2) - nBfn =SIZE(iBfn_Index,2) - nD =SIZE(Grid_AO,4) - -*#define _ANALYSIS_ -#ifdef _ANALYSIS_ - mAO =SIZE(TabAO,1) - nFn =SIZE(Grid_AO,1) - Write (6,*) - Write (6,*) ' Analysing Grid_AO' - Thr=1.0D-14 - Do iD = 1, nD - Do iFn = 1, nFn - lBfn = 0 - Total=0.0D0 - Do iBfn = 1, nBfn - lGrid = 0 - Do iGrid = 1, mGrid - If (Abs(Grid_AO(iFn,iGrid,iBfn,iD)). * +! * +! Copyright (C) 1991,2021,2022, Roland Lindh * +!*********************************************************************** + +subroutine Do_NIntX() + +use nq_Grid, only: Dens_AO, Grid_AO, iBfn_Index, TabAO +use nq_Info, only: Functional_type, GGA_type, LDA_type, meta_GGA_type1, meta_GGA_type2 +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp) :: iD, mGrid, nBfn, nD +real(kind=wp) :: AOInt_Sym +real(kind=wp), allocatable :: A1(:,:), A2(:,:), A3(:,:,:), A4(:,:,:), A_tri(:) +!#define _ANALYSIS_ +#ifdef _ANALYSIS_ +real(kind=wp), parameter :: Thr = 1.0e-14_wp +#endif + +! * +!*********************************************************************** +! * +mGrid = size(TabAO,2) +nBfn = size(iBfn_Index,2) +nD = size(Grid_AO,4) + +#ifdef _ANALYSIS_ +mAO = size(TabAO,1) +nFn = size(Grid_AO,1) +write(u6,*) +write(u6,*) ' Analysing Grid_AO' +do iD=1,nD + do iFn=1,nFn + lBfn = 0 + Total = Zero + do iBfn=1,nBfn + lGrid = 0 + do iGrid=1,mGrid + if (abs(Grid_AO(iFn,iGrid,iBfn,iD)) < Thr) lGrid = lGrid+1 + end do + if (lGrid == mGrid) lBfn = lBfn+1 + Total = Total+real(lGrid,kind=wp)/real(mGrid,kind=wp) + end do + Total = Total/real(nBfn,kind=wp) + write(u6,*) 'Sparsity analysis, iD, iFn',iD,iFn + write(u6,*) ' Total sparsity in %:',100.0_wp*Total + write(u6,*) ' Complete Bfn sparsity in %:',100.0_wp*real(lBfn,kind=wp)/real(nBfn,kind=wp) + write(u6,*) + end do +end do +write(u6,*) +write(u6,*) ' Analysing TabAO' +do iAO=1,mAO + lBfn = 0 + Total = Zero + do iBfn=1,nBfn + lGrid = 0 + do iGrid=1,mGrid + if (abs(TabAO(iAO,iGrid,iBfn)) < Thr) lGrid = lGrid+1 + end do + if (lGrid == mGrid) lBfn = lBfn+1 + Total = Total+real(lGrid,kind=wp)/real(mGrid,kind=wp) + end do + Total = Total/real(nBfn,kind=wp) + write(u6,*) 'Sparsity analysis, iAO',iAO + write(u6,*) ' Total sparsity in %:',100.0_wp*Total + write(u6,*) ' Complete Bfn sparsity in %:',100.0_wp*real(lBfn,kind=wp)/real(nBfn,kind=wp) + write(u6,*) +end do +#endif +! * +!*********************************************************************** +! * +call mma_allocate(A1,mGrid,nBfn,Label='A1') +call mma_allocate(A2,mGrid,nBfn,Label='A2') +! * +!*********************************************************************** +! * +select case (Functional_type) + + case (LDA_type) + ! * + !******************************************************************* + !******************************************************************* + ! * + call mma_Allocate(A_tri,nBfn*(nBfn+1)/2,Label='A_tri') + Dens_AO(:,:,:) = Zero + A2(1:mGrid,1:nBfn) = TabAO(1,1:mGrid,1:nBfn) + do iD=1,nD + A1(1:mGrid,1:nBfn) = Grid_AO(1,1:mGrid,1:nBfn,iD) + call DGEMM_Tri('T','N',nBfn,nBfn,mGrid,One,A1,mGrid,A2,mGrid,Zero,A_Tri,nBfn) + call Sym_Dist() + end do + call mma_deAllocate(A_tri) + ! * + !******************************************************************* + ! * + case (GGA_type) + ! * + !******************************************************************* + !******************************************************************* + ! * + A2(1:mGrid,1:nBfn) = TabAO(1,1:mGrid,1:nBfn) + do iD=1,nD + A1(1:mGrid,1:nBfn) = Grid_AO(1,1:mGrid,1:nBfn,iD) + call DGEMM_('T','N',nBfn,nBfn,mGrid,One,A1,mGrid,A2,mGrid,Zero,Dens_AO(1,1,iD),nBfn) + call Symmetrize() + end do + ! * + !******************************************************************* + ! * + case (meta_GGA_type1,meta_GGA_type2) + ! * + !******************************************************************* + !******************************************************************* + ! * + A2(1:mGrid,1:nBfn) = TabAO(1,1:mGrid,1:nBfn) + do iD=1,nD + A1(1:mGrid,1:nBfn) = Grid_AO(1,1:mGrid,1:nBfn,iD) + call DGEMM_('T','N',nBfn,nBfn,mGrid,One,A1,mGrid,A2,mGrid,Zero,Dens_AO(1,1,iD),nBfn) + call Symmetrize() + end do + + call mma_allocate(A3,3,mGrid,nBfn,Label='A1') + call mma_allocate(A4,3,mGrid,nBfn,Label='A2') + + call mma_Allocate(A_tri,nBfn*(nBfn+1)/2,Label='A_tri') + A4(1:3,1:mGrid,1:nBfn) = TabAO(2:4,1:mGrid,1:nBfn) + do iD=1,nD + A3(1:3,1:mGrid,1:nBfn) = Grid_AO(2:4,1:mGrid,1:nBfn,iD) + call DGEMM_Tri('T','N',nBfn,nBfn,3*mGrid,One,A3,3*mGrid,A4,3*mGrid,Zero,A_Tri,nBfn) + call Sym_Dist() + end do + call mma_deallocate(A3) + call mma_deallocate(A4) + call mma_deAllocate(A_tri) + ! * + !******************************************************************* + ! * + case default + ! * + !******************************************************************* + !******************************************************************* + ! * + write(u6,*) 'DFT_Int: Illegal functional type!' + write(u6,*) Functional_type + call Abend() + ! * + !******************************************************************* + ! * +end select +! * +!*********************************************************************** +! * +call mma_deallocate(A1) +call mma_deallocate(A2) +! * +!*********************************************************************** +! * +!#define _ANALYSIS_ +#ifdef _ANALYSIS_ +write(u6,*) +write(u6,*) ' Analysing Dens_AO' +do iD=1,nD + lBfn = 0 + do iBfn=1,nBfn + do jBfn=1,nBfn + if (abs(Dens_AO(iBfn,jBfn,iD)) < Thr) lBfn = lBfn+1 + end do + end do + Total = real(lBfn,kind=wp)/real(nBfn**2,kind=wp) + write(u6,*) 'Sparsity analysis, iD',iD + write(u6,*) ' Total sparsity in %:',100.0_wp*Total +end do +#endif +! * +!*********************************************************************** +! * +contains + +subroutine Sym_Dist() + + integer(kind=iwp) :: iBfn, ijBfn, jBfn + + ijBfn = 0 + do iBfn=1,nBfn + do jBfn=1,iBfn-1 + ijBfn = ijBfn+1 + AOInt_Sym = A_tri(ijBfn) + Dens_AO(iBfn,jBfn,iD) = Dens_AO(iBfn,jBfn,iD)+AOInt_Sym + Dens_AO(jBfn,iBfn,iD) = Dens_AO(jBfn,iBfn,iD)+AOInt_Sym + end do + ijBfn = ijBfn+1 + AOInt_Sym = A_tri(ijBfn) + Dens_AO(iBfn,iBfn,iD) = Dens_AO(iBfn,iBfn,iD)+AOInt_Sym + end do + +end subroutine Sym_Dist + +subroutine Symmetrize() + + integer(kind=iwp) :: iBfn, jBfn + + do iBfn=1,nBfn + do jBfn=1,iBfn + AOInt_Sym = Dens_AO(iBfn,jBfn,iD)+Dens_AO(jBfn,iBfn,iD) + Dens_AO(iBfn,jBfn,iD) = AOInt_Sym + Dens_AO(jBfn,iBfn,iD) = AOInt_Sym + end do + end do + +end subroutine Symmetrize + +end subroutine Do_NIntX diff -Nru openmolcas-22.02/src/nq_util/do_pi2.f openmolcas-22.10/src/nq_util/do_pi2.f --- openmolcas-22.02/src/nq_util/do_pi2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/do_pi2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,247 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Do_PI2(D1mo,nd1mo,TabMO,mAO,mGrid,nMOs, - & P2_ontop,nP2_ontop,RhoI,RhoA,mRho,Do_Grad, - & P2MOCube,MOs,MOx,MOy,MOz) -************************************************************************ -* * -* Object: Calculation P2 ontop density and its derivatives * -* * -* Called from: Do_batch * -* * -* Calling : FZero * -* * -* INPUT: * -* D1mo = one-body density matrix in MO basis * -* nd1mo = size of D1mo * -* TabMO = MO values computed on grid * -* nMOs = number of MO basis * -* mAO = number of derivatives of AO... * -* mGrid = number of grid points * -* * -************************************************************************ - use nq_Info - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -C#include "stdalloc.fh" - Real*8 D1mo(nd1mo),TabMO(mAO,mGrid,nMOs), - & P2_ontop(nP2_ontop,mGrid) - Real*8 RhoI(mRho,mGrid) - Real*8 RhoA(mRho,mGrid) - Logical Do_Grad - - INTEGER IOff1,IOff2 - REAL*8,DIMENSION(mGrid*NASHT)::P2MOCube,MOs,MOx,MOy,MOz - Real*8 ddot_ - External DDot_ -************************************************************************ -* * - iTri(i,j) = Max(i,j)*(Max(i,j)-1)/2 + Min(i,j) -* * -************************************************************************ - If (nP2_ontop.eq.4) Then - If (mAO.ne.4.or.mRho.ne.4) Then - Call WarningMessage(2,' Somthings wrong in dim. in p2cs') - Call Abend() - End If - Else If (nP2_ontop.eq.6) Then - If (mAO.ne.10.or.mRho.ne.6) Then - Call WarningMessage(2,' Somthings wrong in dim. in p2cs') - Call Abend() - End If - End If -* - Call FZero(P2_ontop,mGrid*nP2_ontop) - jOffA_ = 0 - jOffB_ = 0 - Do iIrrep = 0, mIrrep-1 - iOff_Ash(iIrrep)=jOffA_ - iOff_Bas(iIrrep)=jOffB_ - iOff_BasAct(iIrrep)=jOffB_ + nIsh(iIrrep) + nFro(iIrrep) - jOffA_=jOffA_+nAsh(iIrrep) - jOffB_=jOffB_+mBas(iIrrep) - End Do -************************************************************************ -* * -* P(1,...) - P_2 * -* P(2,...), P(3,...), P(4,...) - grad P_2 * -* Not implemented: * -* P(5,...) - grad^2 P_2 * -* P(6,...) - additional part grad^2 P_2 for CS functional * -* P(5) and P(6) removed * -************************************************************************ - -************************************************************************ -* Inactive part: * -************************************************************************ - NumIsh = 0 - NumAsh = 0 - Do iIrrep=0, mIrrep-1 - NumIsh = NumIsh + nISh(iIrrep) - NumAsh = NumAsh + nAsh(iIrrep) - End Do -* - Do iGrid = 1, mGrid - Do iIrrep=0, mIrrep-1 -* Write(6,*) " Symm:",iIrrep - Do i_=1,nISh(iIrrep) + nFro(iIrrep) - i = iOff_Bas(iIrrep) + i_ -c -c Write(6,*) " do_p2: Inact-Inact:", iIrrep,i, -c & TabMO(1,iGrid,i) -c - RhoI(1,iGrid) = RhoI(1,iGrid) + - * TabMO(1,iGrid,i)*TabMO(1,iGrid,i) -c write(6,'(A15,2I3,2G15.8)')'iGrid,i,MO,RhoI', -c & iGrid,i,TabMO(1,iGrid,i), RhoI(1,iGrid) -! if (Functional_type.eq.GGA_type.or.Do_Grad) then - if (Functional_type.eq.GGA_type) then - RhoI(2,iGrid) = RhoI(2,iGrid) + - * TabMO(1,iGrid,i)*TabMO(2,iGrid,i) - RhoI(3,iGrid) = RhoI(3,iGrid) + - * TabMO(1,iGrid,i)*TabMO(3,iGrid,i) - RhoI(4,iGrid) = RhoI(4,iGrid) + - * TabMO(1,iGrid,i)*TabMO(4,iGrid,i) - end if -* - End Do ! i_ - End Do ! iIrrep - End Do ! iGrid -* - If (NumIsh.ne.0) Then - Do iGrid = 1, mGrid - P2_ontop(1,iGrid) = RhoI(1,iGrid)*RhoI(1,iGrid) -c Write(6,'(A15,I3,1G28.20)')'iGrid,P2(1)=', -c * iGrid,P2_ontop(1,iGrid) -* -! if (Functional_type.eq.GGA_type.or.Do_Grad) then - if (Functional_type.eq.GGA_type) then - P2_ontop(2,iGrid) = 4.0d0*RhoI(1,iGrid)*RhoI(2,iGrid) -C Write(6,'(A,1f28.20)') 'P2(2) =',P2_ontop(2,iGrid) - P2_ontop(3,iGrid) = 4.0d0*RhoI(1,iGrid)*RhoI(3,iGrid) -C Write(6,'(A,1f28.20)') 'P2(3) =',P2_ontop(3,iGrid) - P2_ontop(4,iGrid) = 4.0d0*RhoI(1,iGrid)*RhoI(4,iGrid) -C Write(6,'(A,1f28.20)') 'P2(4) =',P2_ontop(4,iGrid) - end if - if (Functional_type.eq.LDA_type.and.Do_Grad) then -!Here I must -!1. transform the 2-body density matrix to AO - -!2. Loop over effective gradients -!3. Calculate P2_ontop_d(eff_Grad,iGrid) - - - end if - End Do - End If - - -************************************************************************ -* Active-Inactive part: * -************************************************************************ - If (NumIsh.ne.0.and.NumAsh.ne.0) Then - Do kIrrep = 0, mIrrep-1 - Do k_ = 1, nASh(kIrrep) - k= k_ + iOff_BasAct(kIrrep) - Do lIrrep = 0, mIrrep-1 - Do l_ = 1, nAsh(lIrrep) - l= l_ + iOff_BasAct(lIrrep) - kl=iTri(k_ + iOff_Ash(kIrrep) , - * l_ + iOff_Ash(lIrrep) ) - Do iGrid = 1, mGrid - RhoA(1,iGrid) = RhoA(1,iGrid) + - * D1mo(kl)*TabMO(1,iGrid,k)*TabMO(1,iGrid,l) -c Write(6,'(A35,3I3,3G15.8)') 'iGrid,k,l,D1mo(kl),Tab(k),Tab(l)=', -c & iGrid,k,l,D1mo(kl),TabMO(1,iGrid,k),TabMO(1,iGrid,l) -! if (Functional_type.eq.GGA_type.or.Do_Grad) Then - if (Functional_type.eq.GGA_type) Then - RhoA(2,iGrid) = RhoA(2,iGrid) + - * D1mo(kl)*TabMO(1,iGrid,k)*TabMO(2,iGrid,l) - RhoA(3,iGrid) = RhoA(3,iGrid) + - * D1mo(kl)*TabMO(1,iGrid,k)*TabMO(3,iGrid,l) -C write(6,*) 'RhoA(4,iGrid) bf =', RhoA(4,iGrid) - RhoA(4,iGrid) = RhoA(4,iGrid) + - * D1mo(kl)*TabMO(1,iGrid,k)*TabMO(4,iGrid,l) -* Write(6,*) 'D1mo(kl),Tab(1,k),Tab(1,l)=', -* & D1mo(kl)*TabMO(1,iGrid,k)*TabMO(4,iGrid,l) - end if - End Do ! iGrid - End Do ! l_ - End Do ! lIrrep - End Do ! k_ - End Do ! kIrrep -* - Do iGrid = 1, mGrid - P2_ontop(1,iGrid) = P2_ontop(1,iGrid) + - * RhoI(1,iGrid)*RhoA(1,iGrid) - if (Functional_type.eq.GGA_type) Then - P2_ontop(2,iGrid) = P2_ontop(2,iGrid) + - * 2.0d0*RhoI(2,iGrid)*RhoA(1,iGrid) + - * 2.0d0*RhoI(1,iGrid)*RhoA(2,iGrid) -C Write(6,'(A,1f28.20)') 'P2(2) =',P2_ontop(2,iGrid) - P2_ontop(3,iGrid) = P2_ontop(3,iGrid) + - * 2.0d0*RhoI(3,iGrid)*RhoA(1,iGrid) + - * 2.0d0*RhoI(1,iGrid)*RhoA(3,iGrid) -C Write(6,'(A,1f28.20)') 'P2(3) =',P2_ontop(3,iGrid) - P2_ontop(4,iGrid) = P2_ontop(4,iGrid) + - * 2.0d0*RhoI(4,iGrid)*RhoA(1,iGrid) + - * 2.0d0*RhoI(1,iGrid)*RhoA(4,iGrid) -C Write(6,'(A,1f28.20)') 'P2(4) =',P2_ontop(4,iGrid) - end if - End Do ! loop over grid points - End If ! if Inactive -************************************************************************ -* -* Active-Active part: -* -************************************************************************ - - - IF (NumAsh.eq.0) RETURN - -C write(6,*) 'P2MOCube in do_pi2' -C CALL RecPrt(' ',' ',P2MOCube,NASHT,mGrid) -C -C write(6,*) 'MOs array in do_pi2' -C CALL RecPrt(' ',' ',MOs,NASHT,mGrid) - - DO iGrid=1,mGrid - IOff1=(iGrid-1)*NASHT - Do kIrrep=0,mIrrep-1 - IOff2=IOff1+iOff_Ash(kIrrep)+1 - P2_ontop(1,iGrid)=P2_ontop(1,iGrid)+ - & ddot_(nAsh(kIrrep),MOs(IOff2),1,P2MOCube(IOff2),1) - End Do - END DO - - IF(Functional_type.eq.GGA_type) THEN - DO iGrid=1,mGrid - IOff1=(iGrid-1)*NASHT - Do kIrrep=0,mIrrep-1 - IOff2=IOff1+iOff_Ash(kIrrep)+1 - P2_ontop(2,iGrid)=P2_ontop(2,iGrid)+ - &4.0d0*ddot_(nAsh(kIrrep),MOx(IOff2),1,P2MOCube(IOff2),1) - P2_ontop(3,iGrid)=P2_ontop(3,iGrid)+ - &4.0d0*ddot_(nAsh(kIrrep),MOy(IOff2),1,P2MOCube(IOff2),1) - P2_ontop(4,iGrid)=P2_ontop(4,iGrid)+ - &4.0d0*ddot_(nAsh(kIrrep),MOz(IOff2),1,P2MOCube(IOff2),1) - End Do - END DO - END IF - -C write(6,*) 'On-top density new code' -CC write(6,'(10(F9.6,1X))')(P2_Ontop(1,iGrid),iGrid=1,mGrid) -C write(6,*)(P2_Ontop(1,iGrid),iGrid=1,mGrid) - RETURN - END - - - diff -Nru openmolcas-22.02/src/nq_util/do_pi2.F90 openmolcas-22.10/src/nq_util/do_pi2.F90 --- openmolcas-22.02/src/nq_util/do_pi2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/do_pi2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,208 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Do_PI2(D1mo,nd1mo,TabMO,mAO,mGrid,nMOs,P2_ontop,nP2_ontop,RhoI,RhoA,mRho,P2MOCube,MOs,MOx,MOy,MOz) +!*********************************************************************** +! * +! Object: Calculation P2 ontop density and its derivatives * +! * +! Called from: Do_batch * +! * +! INPUT: * +! D1mo = one-body density matrix in MO basis * +! nd1mo = size of D1mo * +! TabMO = MO values computed on grid * +! nMOs = number of MO basis * +! mAO = number of derivatives of AO... * +! mGrid = number of grid points * +! * +!*********************************************************************** + +use nq_Info, only: Functional_type, GGA_type, iOff_Ash, iOff_Bas, iOff_BasAct, mBas, mIrrep, nAsh, NASHT, nFro, nIsh +use Index_Functions, only: iTri +use Constants, only: Zero, Two, Four +use Definitions, only: wp, iwp, r8 + +implicit none +integer(kind=iwp), intent(in) :: nd1mo, mAO, mGrid, nMOs, nP2_ontop, mRho +real(kind=wp), intent(in) :: D1mo(nd1mo), TabMO(mAO,mGrid,nMOs), P2MOCube(NASHT,mGrid), MOs(NASHT,mGrid), MOx(NASHT,mGrid), & + MOy(NASHT,mGrid), MOz(NASHT,mGrid) +real(kind=wp), intent(out) :: P2_ontop(nP2_ontop,mGrid) +real(kind=wp), intent(inout) :: RhoI(mRho,mGrid), RhoA(mRho,mGrid) +integer(kind=iwp) :: i, i_, iGrid, iIrrep, IOff, jOffA_, jOffB_, k, k_, kIrrep, kl, l, l_, lIrrep, NumAsh, NumIsh +real(kind=r8), external :: DDot_ + +! * +!*********************************************************************** +! * +if (nP2_ontop == 4) then + if ((mAO /= 4) .or. (mRho /= 4)) then + call WarningMessage(2,' Something is wrong in dim. in p2cs') + call Abend() + end if +else if (nP2_ontop == 6) then + if ((mAO /= 10) .or. (mRho /= 6)) then + call WarningMessage(2,' Something is wrong in dim. in p2cs') + call Abend() + end if +end if + +P2_ontop(:,:) = Zero +jOffA_ = 0 +jOffB_ = 0 +do iIrrep=0,mIrrep-1 + iOff_Ash(iIrrep) = jOffA_ + iOff_Bas(iIrrep) = jOffB_ + iOff_BasAct(iIrrep) = jOffB_+nIsh(iIrrep)+nFro(iIrrep) + jOffA_ = jOffA_+nAsh(iIrrep) + jOffB_ = jOffB_+mBas(iIrrep) +end do +!*********************************************************************** +! * +! P(1,...) - P_2 * +! P(2,...), P(3,...), P(4,...) - grad P_2 * +! Not implemented: * +! P(5,...) - grad^2 P_2 * +! P(6,...) - additional part grad^2 P_2 for CS functional * +! P(5) and P(6) removed * +!*********************************************************************** + +!*********************************************************************** +! Inactive part: * +!*********************************************************************** +NumIsh = 0 +NumAsh = 0 +do iIrrep=0,mIrrep-1 + NumIsh = NumIsh+nISh(iIrrep) + NumAsh = NumAsh+nAsh(iIrrep) +end do + +do iGrid=1,mGrid + do iIrrep=0,mIrrep-1 + !write(u6,*) ' Symm:',iIrrep + do i_=1,nISh(iIrrep)+nFro(iIrrep) + i = iOff_Bas(iIrrep)+i_ + + !write(u6,*) ' do_p2: Inact-Inact:',iIrrep,i,TabMO(1,iGrid,i) + + RhoI(1,iGrid) = RhoI(1,iGrid)+TabMO(1,iGrid,i)*TabMO(1,iGrid,i) + !write(u6,'(A15,2I3,2G15.8)') 'iGrid,i,MO,RhoI',iGrid,i,TabMO(1,iGrid,i),RhoI(1,iGrid) + !if ((Functional_type == GGA_type) .or. Do_Grad) then + if (Functional_type == GGA_type) then + RhoI(2,iGrid) = RhoI(2,iGrid)+TabMO(1,iGrid,i)*TabMO(2,iGrid,i) + RhoI(3,iGrid) = RhoI(3,iGrid)+TabMO(1,iGrid,i)*TabMO(3,iGrid,i) + RhoI(4,iGrid) = RhoI(4,iGrid)+TabMO(1,iGrid,i)*TabMO(4,iGrid,i) + end if + + end do ! i_ + end do ! iIrrep +end do ! iGrid + +if (NumIsh /= 0) then + do iGrid=1,mGrid + P2_ontop(1,iGrid) = RhoI(1,iGrid)*RhoI(1,iGrid) + !write(u6,'(A15,I3,1G28.20)') 'iGrid,P2(1)=',iGrid,P2_ontop(1,iGrid) + + !if ((Functional_type == GGA_type) .or. Do_Grad) then + if (Functional_type == GGA_type) then + P2_ontop(2,iGrid) = Four*RhoI(1,iGrid)*RhoI(2,iGrid) + !write(u6,'(A,1f28.20)') 'P2(2) =',P2_ontop(2,iGrid) + P2_ontop(3,iGrid) = Four*RhoI(1,iGrid)*RhoI(3,iGrid) + !write(u6,'(A,1f28.20)') 'P2(3) =',P2_ontop(3,iGrid) + P2_ontop(4,iGrid) = Four*RhoI(1,iGrid)*RhoI(4,iGrid) + !write(u6,'(A,1f28.20)') 'P2(4) =',P2_ontop(4,iGrid) + end if + !if ((Functional_type == LDA_type) .and. Do_Grad) then + ! !Here I must + ! !1. transform the 2-body density matrix to AO + ! + ! !2. Loop over effective gradients + ! !3. Calculate P2_ontop_d(eff_Grad,iGrid) + ! + !end if + end do +end if + +!*********************************************************************** +! Active-Inactive part: * +!*********************************************************************** +if ((NumIsh /= 0) .and. (NumAsh /= 0)) then + do kIrrep=0,mIrrep-1 + do k_=1,nASh(kIrrep) + k = k_+iOff_BasAct(kIrrep) + do lIrrep=0,mIrrep-1 + do l_=1,nAsh(lIrrep) + l = l_+iOff_BasAct(lIrrep) + kl = iTri(k_+iOff_Ash(kIrrep),l_+iOff_Ash(lIrrep)) + do iGrid=1,mGrid + RhoA(1,iGrid) = RhoA(1,iGrid)+D1mo(kl)*TabMO(1,iGrid,k)*TabMO(1,iGrid,l) + !write(u6,'(A35,3I3,3G15.8)') 'iGrid,k,l,D1mo(kl),Tab(k),Tab(l)=',iGrid,k,l,D1mo(kl),TabMO(1,iGrid,k),TabMO(1,iGrid,l) + !if ((Functional_type == GGA_type) .or. Do_Grad) then + if (Functional_type == GGA_type) then + RhoA(2,iGrid) = RhoA(2,iGrid)+D1mo(kl)*TabMO(1,iGrid,k)*TabMO(2,iGrid,l) + RhoA(3,iGrid) = RhoA(3,iGrid)+D1mo(kl)*TabMO(1,iGrid,k)*TabMO(3,iGrid,l) + !write(u6,*) 'RhoA(4,iGrid) bf =',RhoA(4,iGrid) + RhoA(4,iGrid) = RhoA(4,iGrid)+D1mo(kl)*TabMO(1,iGrid,k)*TabMO(4,iGrid,l) + !write(u6,*) 'D1mo(kl),Tab(1,k),Tab(1,l)=',D1mo(kl)*TabMO(1,iGrid,k)*TabMO(4,iGrid,l) + end if + end do ! iGrid + end do ! l_ + end do ! lIrrep + end do ! k_ + end do ! kIrrep + + do iGrid=1,mGrid + P2_ontop(1,iGrid) = P2_ontop(1,iGrid)+RhoI(1,iGrid)*RhoA(1,iGrid) + if (Functional_type == GGA_type) then + P2_ontop(2,iGrid) = P2_ontop(2,iGrid)+Two*RhoI(2,iGrid)*RhoA(1,iGrid)+Two*RhoI(1,iGrid)*RhoA(2,iGrid) + !write(u6,'(A,1f28.20)') 'P2(2) =',P2_ontop(2,iGrid) + P2_ontop(3,iGrid) = P2_ontop(3,iGrid)+Two*RhoI(3,iGrid)*RhoA(1,iGrid)+Two*RhoI(1,iGrid)*RhoA(3,iGrid) + !write(u6,'(A,1f28.20)') 'P2(3) =',P2_ontop(3,iGrid) + P2_ontop(4,iGrid) = P2_ontop(4,iGrid)+Two*RhoI(4,iGrid)*RhoA(1,iGrid)+Two*RhoI(1,iGrid)*RhoA(4,iGrid) + !write(u6,'(A,1f28.20)') 'P2(4) =',P2_ontop(4,iGrid) + end if + end do ! loop over grid points +end if ! if Inactive +!*********************************************************************** +! Active-Active part: * +!*********************************************************************** + +if (NumAsh == 0) return + +!call RecPrt('P2MOCube in do_pi2',' ',P2MOCube,NASHT,mGrid) + +!call RecPrt('MOs array in do_pi2',' ',MOs,NASHT,mGrid) + +do iGrid=1,mGrid + do kIrrep=0,mIrrep-1 + IOff = iOff_Ash(kIrrep)+1 + P2_ontop(1,iGrid) = P2_ontop(1,iGrid)+ddot_(nAsh(kIrrep),MOs(IOff:,iGrid),1,P2MOCube(IOff:,iGrid),1) + end do +end do + +if (Functional_type == GGA_type) then + do iGrid=1,mGrid + do kIrrep=0,mIrrep-1 + IOff = iOff_Ash(kIrrep)+1 + P2_ontop(2,iGrid) = P2_ontop(2,iGrid)+Four*ddot_(nAsh(kIrrep),MOx(IOff:,iGrid),1,P2MOCube(IOff:,iGrid),1) + P2_ontop(3,iGrid) = P2_ontop(3,iGrid)+Four*ddot_(nAsh(kIrrep),MOy(IOff:,iGrid),1,P2MOCube(IOff:,iGrid),1) + P2_ontop(4,iGrid) = P2_ontop(4,iGrid)+Four*ddot_(nAsh(kIrrep),MOz(IOff:,iGrid),1,P2MOCube(IOff:,iGrid),1) + end do + end do +end if + +!write(u6,*) 'On-top density new code' +!write(u6,'(10(F9.6,1X))') (P2_Ontop(1,iGrid),iGrid=1,mGrid) +!write(u6,*) (P2_Ontop(1,iGrid),iGrid=1,mGrid) + +return + +end subroutine Do_PI2 diff -Nru openmolcas-22.02/src/nq_util/do_pi2grad.f openmolcas-22.10/src/nq_util/do_pi2grad.f --- openmolcas-22.02/src/nq_util/do_pi2grad.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/do_pi2grad.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,469 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Do_Pi2Grad(mAO,mGrid, - & P2_ontop,nP2_ontop,nGrad_Eff, - & list_s,nlist_s,list_bas, - & D1mo,nd1mo,TabMO,P2_ontop_d, - & RhoI,RhoA,mRho,nMOs,CMO,nCMO,TabSO,ft, - & P2MOCube,P2MOCubex,P2MOCubey,P2MOCubez,nPMO3p,MOs, - & MOx,MOy,MOz) -************************************************************************ -* * -* Object: Calculation P2 ontop density and its derivatives * -* * -* Called from: Do_batch * -* * -* Calling : FZero * -* * -* INPUT: * -* D1mo = one-body density matrix in MO basis * -* nd1mo = size of D1mo * -* TabMO = MO values computed on grid * -* nMOs = number of MO basis * -* mAO = number of derivatives of AO... * -* mGrid = number of grid points * -* * -************************************************************************ - use iSD_data - use Center_Info - use Basis_Info, only: nBas - use nq_pdft, only: lft,lGGA - use nq_Grid, only: List_G - use nq_Info - Implicit Real*8 (A-H,O-Z) -#include "SysDef.fh" -#include "real.fh" -#include "stdalloc.fh" -#include "print.fh" - Integer list_s(2,nlist_s),list_bas(2,nlist_s), - & mAO,nAOs,mGrid,nP2_ontop,nGrad_Eff,nd1mo,mRho,nCMO - Real*8 D1mo(nd1mo),TabMO(mAO,mGrid,nMOs), - & P2_ontop(nP2_ontop,mGrid), - & P2_ontop_d(np2_ontop,nGrad_Eff,mGrid),CMO(nCMO) - logical ft - Real*8, allocatable, dimension(:,:,:,:) :: dTabMO - Real*8 RhoI(mRho,mGrid) - Real*8 RhoA(mRho,mGrid) - Real*8,dimension(1:mRho,1:mGrid,1:nGrad_Eff) :: dRhoI,dRhoA - integer g_eff,iGrid - Real*8 TabSO(mAO,mGrid,nMOs) - Real*8,DIMENSION(mGrid*NASHT)::P2MOCube,MOs,dMOs,MOx,MOy,MOz - INTEGER IOff1,iOff2,iOff3,nPi,iCoordOff,iGridOff,iCoord,nBasf, - & nOccO,nPMO3p,iOff0, iOffF, - & iCoord1,iCoord2,iCoord3,iCoordOff1,iCoordOff2,iCoordOff3 - Real*8,DIMENSION(nPMO3p)::P2MOCubex,P2MOCubey,P2MOCubez, - & dMOx,dMOy,dMOz - - Real*8, Allocatable :: TabSO2(:) - Real*8 dTabMO2(nMOs) - -************************************************************************ -* * - iTri(i,j) = Max(i,j)*(Max(i,j)-1)/2 + Min(i,j) -* * -************************************************************************ - Call unused_integer(naos) - - If (nP2_ontop.eq.4) Then - If (mAO.ne.10.or.mRho.ne.4) Then - Call WarningMessage(2,' Somthings wrong in dim. in p2cs') - Call Abend() - End If - Else If (nP2_ontop.eq.6) Then - If (mAO.ne.10.or.mRho.ne.6) Then - Call WarningMessage(2,' Somthings wrong in dim. in p2cs') - Call Abend() - End If - End If -* - Call FZero(P2_ontop,mGrid*nP2_ontop) - Call FZero(P2_ontop_d,nP2_ontop*nGrad_Eff*mGrid) - dRhoI(1:mRho,1:mGrid,1:nGrad_Eff)=0.0d0 - dRhoA(1:mRho,1:mGrid,1:nGrad_Eff)=0.0d0 - jOffA_ = 0 - jOffB_ = 0 - Do iIrrep = 0, mIrrep-1 - iOff_Ash(iIrrep)=jOffA_ - iOff_Bas(iIrrep)=jOffB_ - iOff_BasAct(iIrrep)=jOffB_ + nIsh(iIrrep) + nFro(iIrrep) - jOffA_=jOffA_+nAsh(iIrrep) - jOffB_=jOffB_+mBas(iIrrep) - End Do -************************************************************************ -* P(1,...) - P_2 * -* P(2,...), P(3,...), P(4,...) - grad P_2 * -************************************************************************ - - Call mma_Allocate(dTabMO,nP2_ontop,nMOs,nGrad_eff,mgrid, - & Label='dTabMO') - dTabMO(:,:,:,:)=Zero - - Call mma_Allocate(TabSO2,nMOs*mAO*mGrid,Label='TabSO2') -!:::::::::::::::::::::::::::::::::::::::::::::::::::::::: - Do ilist_s=1,nlist_s - - Call FZero(TabSO,mAO*mGrid*nMOs) - - Call mk_SOs(TabSO,mAO,mGrid,nMOs,List_s,List_Bas,nList_s, - & iList_s) - - CALL ConvertTabSO(TabSO2,TabSO,mAO,mGrid,nMOs) - - Do iGrid=1,mGrid - IGridOff=(iGrid-1)*mAO*nMOs - - Do iCoord=1,3 - ICoordOff=IGridOff+(iCoord-1)*nMOs - g_eff = list_g(iCoord,ilist_s) - - IF (lft.and.lGGA) THEN - Select Case(iCoord) - Case(1) - iCoord1=4 - iCoord2=5 - iCoord3=6 - Case(2) - iCoord1=5 - iCoord2=7 - iCoord3=8 - Case(3) - iCoord1=6 - iCoord2=8 - iCoord3=9 - End Select - ICoordOff1=IGridOff+(iCoord1-1)*nMOs - ICoordOff2=IGridOff+(iCoord2-1)*nMOs - ICoordOff3=IGridOff+(iCoord3-1)*nMOs - Else - ICoordOff1=0 - ICoordOff2=0 - ICoordOff3=0 - END IF - - do iIrrep=0,mIrrep-1 - nOccO=nIsh(iIrrep)+nAsh(iIrrep) - IF (nOccO.eq.0) CYCLE - nBasF=nBas(iIrrep) - - - iOffF=OffBas(iIrrep)+nFro(iIrrep) - - iOff0=iCoordOff + OffBas(iIrrep) - CALL DGEMM_('T','N',nOccO,1,nBasF, - & 1.0d0,CMO(OffBas2(iIrrep)),nBasF, - & TabSO2(iOff0),nBasF, - & 0.0d0,dTabMO2,nOccO) - CALL DAXPY_(nOccO,1.0d0, - & dTabMO2,1, - & dTabMO(1,iOffF,g_eff,iGrid),nP2_ontop) - - IF (lft.and.lGGA) THEN - iOff1=iCoordOff1+ OffBas(iIrrep) - iOff2=iCoordOff2+ OffBas(iIrrep) - iOff3=iCoordOff3+ OffBas(iIrrep) - - CALL DGEMM_('T','N',nOccO,1,nBasF, - & 1.0d0,CMO(OffBas2(iIrrep)),nBasF, - & TabSO2(iOff1),nBasF, - & 0.0d0,dTabMO2,nOccO) - CALL DAXPY_(nOccO,1.0d0, - & dTabMO2,1, - & dTabMO(2,iOffF,g_eff,iGrid),nP2_ontop) - - CALL DGEMM_('T','N',nOccO,1,nBasF, - & 1.0d0,CMO(OffBas2(iIrrep)),nBasF, - & TabSO2(iOff2),nBasF, - & 0.0d0,dTabMO2,nOccO) - CALL DAXPY_(nOccO,1.0d0, - & dTabMO2,1, - & dTabMO(3,iOffF,g_eff,iGrid),nP2_ontop) - - CALL DGEMM_('T','N',nOccO,1,nBasF, - & 1.0d0,CMO(OffBas2(iIrrep)),nBasF, - & TabSO2(iOff3),nBasF, - & 0.0d0,dTabMO2,nOccO) - CALL DAXPY_(nOccO,1.0d0, - & dTabMO2,1, - & dTabMO(4,iOffF,g_eff,iGrid),nP2_ontop) - END IF - end do ! iIrrep - End Do ! iCoord - End Do ! iGrid - END DO ! iList_s - Call mma_deAllocate(TabSO2) -************************************************************************ -* Inactive part: * -************************************************************************ - NumIsh = 0 - NumAsh = 0 - Do iIrrep=0, mIrrep-1 - NumIsh = NumIsh + nISh(iIrrep) - NumAsh = NumAsh + nAsh(iIrrep) - End Do -* - Do iGrid = 1, mGrid - Do iIrrep=0, mIrrep-1 - Do i_=1,nISh(iIrrep) + nFro(iIrrep) - i = iOff_Bas(iIrrep) + i_ - RhoI(1,iGrid) = RhoI(1,iGrid) + - & TabMO(1,iGrid,i) * TabMO(1,iGrid,i) - if (Functional_type.eq.GGA_type.and.ft) then - RhoI(2,iGrid) = RhoI(2,iGrid) + - * TabMO(1,iGrid,i)*TabMO(2,iGrid,i) - RhoI(3,iGrid) = RhoI(3,iGrid) + - * TabMO(1,iGrid,i)*TabMO(3,iGrid,i) - RhoI(4,iGrid) = RhoI(4,iGrid) + - * TabMO(1,iGrid,i)*TabMO(4,iGrid,i) - end if -* - !Build dRhoI - Do g_eff=1,nGrad_eff - dRhoI(1,iGrid,g_eff) = dRhoI(1,iGrid,g_eff) + - & dTabMO(1,i,g_eff,iGrid)*TabMO(1,iGrid,i)!times 2 or not? - - if (Functional_type.eq.GGA_type.and.ft) then - dRhoI(2,iGrid,g_eff) = dRhoI(2,iGrid,g_eff) + - & dTabMO(1,i,g_eff,iGrid)*TabMO(2,iGrid,i) + - & TabMO(1,iGrid,i)*dTabMO(2,i,g_eff,iGrid) - - dRhoI(3,iGrid,g_eff) = dRhoI(3,iGrid,g_eff) + - & dTabMO(1,i,g_eff,iGrid)*TabMO(3,iGrid,i) + - & TabMO(1,iGrid,i)*dTabMO(3,i,g_eff,iGrid) - - dRhoI(4,iGrid,g_eff) = dRhoI(4,iGrid,g_eff) + - & dTabMO(1,i,g_eff,iGrid)*TabMO(4,iGrid,i) + - & TabMO(1,iGrid,i)*dTabMO(4,i,g_eff,iGrid) - - end if !GGA - end do !g_eff - - End Do ! i_ - End Do ! iIrrep - End Do ! iGrid -* - If (NumIsh.ne.0) Then - Do iGrid = 1, mGrid - P2_ontop(1,iGrid) = RhoI(1,iGrid)*RhoI(1,iGrid) -* - if (Functional_type.eq.GGA_type.and.ft) then - P2_ontop(2,iGrid) = 4.0d0*RhoI(1,iGrid)*RhoI(2,iGrid) - P2_ontop(3,iGrid) = 4.0d0*RhoI(1,iGrid)*RhoI(3,iGrid) - P2_ontop(4,iGrid) = 4.0d0*RhoI(1,iGrid)*RhoI(4,iGrid) - end if - do g_eff=1,nGrad_eff - P2_ontop_d(1,g_eff,iGrid) = P2_ontop_d(1,g_eff,iGrid) + - & 4.0d0*dRhoI(1,iGrid,g_eff)*RhoI(1,iGrid) - - if (Functional_type.eq.GGA_type.and.ft) then -!******************ADD STUFF FOR FT: HERE*************** - P2_ontop_d(2,g_eff,iGrid) = P2_ontop_d(2,g_eff,iGrid) + - & 4.0d0*dRhoI(2,iGrid,g_eff)*RhoI(1,iGrid) + - & 8.0d0*dRhoI(1,iGrid,g_eff)*RhoI(2,iGrid) -! & 4.0d0*dRhoI(1,iGrid,g_eff)*RhoI(2,iGrid) + -! & 4.0d0*RhoI(1,iGrid)*dRhoI(2,iGrid,g_eff) - - P2_ontop_d(3,g_eff,iGrid) = P2_ontop_d(3,g_eff,iGrid) + - & 4.0d0*dRhoI(3,iGrid,g_eff)*RhoI(1,iGrid) + - & 8.0d0*dRhoI(1,iGrid,g_eff)*RhoI(3,iGrid) -! & 4.0d0*dRhoI(1,iGrid,g_eff)*RhoI(3,iGrid) + -! & 4.0d0*RhoI(1,iGrid)*dRhoI(3,iGrid,g_eff) - - P2_ontop_d(4,g_eff,iGrid) = P2_ontop_d(4,g_eff,iGrid) + - & 4.0d0*dRhoI(4,iGrid,g_eff)*RhoI(1,iGrid) + - & 8.0d0*dRhoI(1,iGrid,g_eff)*RhoI(4,iGrid) -! & 4.0d0*dRhoI(1,iGrid,g_eff)*RhoI(4,iGrid) + -! & 4.0d0*RhoI(1,iGrid)*dRhoI(4,iGrid,g_eff) - - end if !GGA - end do !ngrad - - - End Do - End If - -************************************************************************ -* Active-Inactive part: * -************************************************************************ - If (NumIsh.ne.0.and.NumAsh.ne.0) Then - Do kIrrep = 0, mIrrep-1 - Do k_ = 1, nASh(kIrrep) - k= k_ + iOff_BasAct(kIrrep) - Do lIrrepx = 0, mIrrep-1 - Do l_ = 1, nAsh(lIrrepx) - l= l_ + iOff_BasAct(lIrrepx) - kl=iTri(k_ + iOff_Ash(kIrrep) , - & l_ + iOff_Ash(lIrrepx) ) - Do iGrid = 1, mGrid - RhoA(1,iGrid) = RhoA(1,iGrid) + - & D1mo(kl)*TabMO(1,iGrid,k)*TabMO(1,iGrid,l) - if (Functional_type.eq.GGA_type.and.ft) Then - RhoA(2,iGrid) = RhoA(2,iGrid) + - & D1mo(kl)*TabMO(1,iGrid,k)*TabMO(2,iGrid,l) - RhoA(3,iGrid) = RhoA(3,iGrid) + - & D1mo(kl)*TabMO(1,iGrid,k)*TabMO(3,iGrid,l) - RhoA(4,iGrid) = RhoA(4,iGrid) + - & D1mo(kl)*TabMO(1,iGrid,k)*TabMO(4,iGrid,l) - end if - - do g_eff=1,nGrad_eff - dRhoA(1,iGrid,g_eff) = dRhoA(1,iGrid,g_eff) + - & D1mo(kl)*dTabMO(1,k,g_eff,iGrid)*TabMO(1,iGrid,l) - - -!******************ADD STUFF FOR FT: HERE*************** - - if(Functional_type.eq.GGA_type.and.ft) Then - dRhoA(2,iGrid,g_eff) = dRhoA(2,iGrid,g_eff) + - & D1mo(kl)*dTabMO(1,k,g_eff,iGrid)*TabMO(2,iGrid,l) + - & D1mo(kl)*TabMO(1,iGrid,k)*dTabMO(2,l,g_eff,iGrid) - - dRhoA(3,iGrid,g_eff) = dRhoA(3,iGrid,g_eff) + - & D1mo(kl)*dTabMO(1,k,g_eff,iGrid)*TabMO(3,iGrid,l) + - & D1mo(kl)*TabMO(1,iGrid,k)*dTabMO(3,l,g_eff,iGrid) - - dRhoA(4,iGrid,g_eff) = dRhoA(4,iGrid,g_eff) + - & D1mo(kl)*dTabMO(1,k,g_eff,iGrid)*TabMO(4,iGrid,l) + - & D1mo(kl)*TabMO(1,iGrid,k)*dTabMO(4,l,g_eff,iGrid) - end if !GGA - - - end do - End Do ! iGrid - End Do ! l_ - End Do ! lIrrepx - End Do ! k_ - End Do ! kIrrep -* - Do iGrid = 1, mGrid - P2_ontop(1,iGrid) = P2_ontop(1,iGrid) + - * RhoI(1,iGrid)*RhoA(1,iGrid) - if (Functional_type.eq.GGA_type.and.ft) Then - P2_ontop(2,iGrid) = P2_ontop(2,iGrid) + - * 2.0d0*RhoI(2,iGrid)*RhoA(1,iGrid) + - * 2.0d0*RhoI(1,iGrid)*RhoA(2,iGrid) - P2_ontop(3,iGrid) = P2_ontop(3,iGrid) + - * 2.0d0*RhoI(3,iGrid)*RhoA(1,iGrid) + - * 2.0d0*RhoI(1,iGrid)*RhoA(3,iGrid) - P2_ontop(4,iGrid) = P2_ontop(4,iGrid) + - * 2.0d0*RhoI(4,iGrid)*RhoA(1,iGrid) + - * 2.0d0*RhoI(1,iGrid)*RhoA(4,iGrid) - end if !gga - do g_eff=1,nGrad_Eff - P2_ontop_d(1,g_eff,iGrid) = P2_ontop_d(1,g_eff,iGrid) + - & 2.0D0*RhoI(1,iGrid)*dRhoA(1,iGrid,g_eff) + - & 2.0D0*dRhoI(1,iGrid,g_eff)*RhoA(1,iGrid) - if (Functional_type.eq.GGA_type.and.ft) Then - - P2_ontop_d(2,g_eff,iGrid) = P2_ontop_d(2,g_eff,iGrid) + - & 2.0d0*dRhoI(2,iGrid,g_eff)*RhoA(1,iGrid) + - & 4.0d0*RhoI(2,iGrid)*dRhoA(1,iGrid,g_eff) + - & 4.0d0*dRhoI(1,iGrid,g_eff)*RhoA(2,iGrid) + - & 2.0d0*RhoI(1,iGrid)*dRhoA(2,iGrid,g_eff) - - P2_ontop_d(3,g_eff,iGrid) = P2_ontop_d(3,g_eff,iGrid) + - & 2.0d0*dRhoI(3,iGrid,g_eff)*RhoA(1,iGrid) + - & 4.0d0*RhoI(3,iGrid)*dRhoA(1,iGrid,g_eff) + - & 4.0d0*dRhoI(1,iGrid,g_eff)*RhoA(3,iGrid) + - & 2.0d0*RhoI(1,iGrid)*dRhoA(3,iGrid,g_eff) - - P2_ontop_d(4,g_eff,iGrid) = P2_ontop_d(4,g_eff,iGrid) + - & 2.0d0*dRhoI(4,iGrid,g_eff)*RhoA(1,iGrid) + - & 4.0d0*RhoI(4,iGrid)*dRhoA(1,iGrid,g_eff) + - & 4.0d0*dRhoI(1,iGrid,g_eff)*RhoA(4,iGrid) + - & 2.0d0*RhoI(1,iGrid)*dRhoA(4,iGrid,g_eff) - end if !GGA - end do !g_eff - - End Do ! loop over grid points - End If ! if Inactive -************************************************************************ -* -* Active-Active part: -* -************************************************************************ - - - If (NumAsh.ne.0) Then - nPi=nP2_ontop -* - DO g_eff=1,nGrad_eff - Do iGrid=1,mGrid - IOff1=(iGrid-1)*NASHT - do iIrrep=0,mIrrep-1 - IOff2=IOff_Ash(iIrrep)+1 - IOff3=IOff_BasAct(iIrrep)+1 - CALL DCopy_(nAsh(iIrrep),dTabMO(1,iOff3,g_eff,iGrid),nPi, - & dMOs(IOff1+IOff2) ,1 ) - if(lft.and.lGGA) then - CALL DCopy_(nAsh(iIrrep),dTabMO(2,iOff3,g_eff,iGrid),nPi, - & dMOx(IOff1+IOff2) ,1 ) - CALL DCopy_(nAsh(iIrrep),dTabMO(3,iOff3,g_eff,iGrid),nPi, - & dMOy(IOff1+IOff2) ,1 ) - CALL DCopy_(nAsh(iIrrep),dTabMO(4,iOff3,g_eff,iGrid),nPi, - & dMOz(IOff1+IOff2) ,1 ) - end if - end do - End Do - - Do iGrid=1,mGrid - IOff1=(iGrid-1)*NASHT - do IIrrep=0,mIrrep-1 - IOff2=IOff1+iOff_Ash(IIrrep)+1 - P2_ontop_d(1,g_eff,iGrid)=P2_ontop_d(1,g_eff,iGrid)+ - & 4.0d0*ddot_(nAsh(IIrrep),dMOs(IOff2),1,P2MOCube(IOff2),1) - if(lft.and.lGGA) then - P2_ontop_d(2,g_eff,iGrid)=P2_ontop_d(2,g_eff,iGrid)+ - & 4.0d0*ddot_(nAsh(IIrrep),dMOx(IOff2),1,P2MOCube(IOff2),1)+ - & 4.0d0*ddot_(nAsh(IIrrep),dMOs(IOff2),1,P2MOCubex(IOff2),1) - P2_ontop_d(3,g_eff,iGrid)=P2_ontop_d(3,g_eff,iGrid)+ - & 4.0d0*ddot_(nAsh(IIrrep),dMOy(IOff2),1,P2MOCube(IOff2),1)+ - & 4.0d0*ddot_(nAsh(IIrrep),dMOs(IOff2),1,P2MOCubey(IOff2),1) - P2_ontop_d(4,g_eff,iGrid)=P2_ontop_d(4,g_eff,iGrid)+ - & 4.0d0*ddot_(nAsh(IIrrep),dMOz(IOff2),1,P2MOCube(IOff2),1)+ - & 4.0d0*ddot_(nAsh(IIrrep),dMOs(IOff2),1,P2MOCubez(IOff2),1) - end if - end do - End Do - END DO - - - DO iGrid=1,mGrid - IOff1=(iGrid-1)*NASHT - Do IIrrep=0,mIrrep-1 - IOff2=IOff1+iOff_Ash(IIrrep)+1 - P2_ontop(1,iGrid)=P2_ontop(1,iGrid)+ - & ddot_(nAsh(IIrrep),MOs(IOff2),1,P2MOCube(IOff2),1) - End Do - END DO - - If(lGGA.and.lft) Then - DO iGrid=1,mGrid - IOff1=(iGrid-1)*NASHT - Do IIrrep=0,mIrrep-1 - IOff2=IOff1+iOff_Ash(IIrrep)+1 - P2_ontop(2,iGrid)=P2_ontop(2,iGrid)+ - & 4.0d0*ddot_(nAsh(IIrrep),MOx(IOff2),1,P2MOCube(IOff2),1) - P2_ontop(3,iGrid)=P2_ontop(3,iGrid)+ - & 4.0d0*ddot_(nAsh(IIrrep),MOy(IOff2),1,P2MOCube(IOff2),1) - P2_ontop(4,iGrid)=P2_ontop(4,iGrid)+ - & 4.0d0*ddot_(nAsh(IIrrep),MOz(IOff2),1,P2MOCube(IOff2),1) -C write(6,*)'MOz used for dPiz' -C write(6,*) iGrid,iOff2-iOff1 -C CALL RecPrt(' ',' ',MOz(iOff2),1,nAsh(iIrrep)) - End Do - END DO - End If - - End If - Call mma_deAllocate(dTabMO) - RETURN - END subroutine - diff -Nru openmolcas-22.02/src/nq_util/do_pi2grad.F90 openmolcas-22.10/src/nq_util/do_pi2grad.F90 --- openmolcas-22.02/src/nq_util/do_pi2grad.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/do_pi2grad.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,382 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Do_Pi2Grad(mAO,mGrid,P2_ontop,nP2_ontop,nGrad_Eff,list_s,nlist_s,list_bas,D1mo,nd1mo,TabMO,P2_ontop_d,RhoI,RhoA,mRho, & + nMOs,CMO,nCMO,TabSO,ft,P2MOCube,P2MOCubex,P2MOCubey,P2MOCubez,nPMO3p,MOs,MOx,MOy,MOz) +!*********************************************************************** +! * +! Object: Calculation P2 ontop density and its derivatives * +! * +! Called from: Do_batch * +! * +! INPUT: * +! D1mo = one-body density matrix in MO basis * +! nd1mo = size of D1mo * +! TabMO = MO values computed on grid * +! nMOs = number of MO basis * +! mAO = number of derivatives of AO... * +! mGrid = number of grid points * +! * +!*********************************************************************** + +use Basis_Info, only: nBas +use nq_pdft, only: lft, lGGA +use nq_Grid, only: List_G +use nq_Info, only: Functional_type, GGA_type, iOff_Ash, iOff_Bas, iOff_BasAct, mBas, mIrrep, nAsh, NASHT, nFro, nIsh, OffBas, & + OffBas2 +use Index_Functions, only: iTri +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Four, Eight +use Definitions, only: wp, iwp, r8 + +implicit none +integer(kind=iwp), intent(in) :: mAO, mGrid, nP2_ontop, nGrad_Eff, nlist_s, list_s(2,nlist_s), list_bas(2,nlist_s), nd1mo, mRho, & + nMOs, nCMO, nPMO3p +real(kind=wp), intent(out) :: P2_ontop(nP2_ontop,mGrid), P2_ontop_d(np2_ontop,nGrad_Eff,mGrid), TabSO(mAO,mGrid,nMOs) +real(kind=wp), intent(in) :: D1mo(nd1mo), TabMO(mAO,mGrid,nMOs), CMO(nCMO), P2MOCube(NASHT,mGrid), P2MOCubex(NASHT,nPMO3p), & + P2MOCubey(NASHT,nPMO3p), P2MOCubez(NASHT,nPMO3p), MOs(NASHT,mGrid), MOx(NASHT,mGrid), & + MOy(NASHT,mGrid), MOz(NASHT,mGrid) +real(kind=wp), intent(inout) :: RhoA(mRho,mGrid), RhoI(mRho,mGrid) +logical(kind=iwp), intent(in) :: ft +integer(kind=iwp) :: g_eff, i, i_, iCoord, iCoord1, iCoord2, iCoord3, iGrid, iIrrep, ilist_s, IOff1, iOff2, iOffF, jOffA_, jOffB_, & + k, k_, kIrrep, kl, l, l_, lIrrepx, nBasf, nOccO, NumAsh, NumIsh +real(kind=wp), allocatable :: dMOs(:,:), dMOx(:,:), dMOy(:,:), dMOz(:,:), dRhoA(:,:,:), dRhoI(:,:,:), dTabMO(:,:,:,:), dTabMO2(:), & + TabSO2(:,:,:) +real(kind=r8), external :: DDot_ + +! * +!*********************************************************************** +! * +if (nP2_ontop == 4) then + if ((mAO /= 10) .or. (mRho /= 4)) then + call WarningMessage(2,' Something is wrong in dim. in p2cs') + call Abend() + end if +else if (nP2_ontop == 6) then + if ((mAO /= 10) .or. (mRho /= 6)) then + call WarningMessage(2,' Something is wrong in dim. in p2cs') + call Abend() + end if +end if + +P2_ontop(:,:) = Zero +P2_ontop_d(:,:,:) = Zero +call mma_allocate(dRhoI,mRho,mGrid,nGrad_Eff,Label='dRhoI') +call mma_allocate(dRhoA,mRho,mGrid,nGrad_Eff,Label='dRhoA') +dRhoI(:,:,:) = Zero +dRhoA(:,:,:) = Zero +jOffA_ = 0 +jOffB_ = 0 +do iIrrep=0,mIrrep-1 + iOff_Ash(iIrrep) = jOffA_ + iOff_Bas(iIrrep) = jOffB_ + iOff_BasAct(iIrrep) = jOffB_+nIsh(iIrrep)+nFro(iIrrep) + jOffA_ = jOffA_+nAsh(iIrrep) + jOffB_ = jOffB_+mBas(iIrrep) +end do +!*********************************************************************** +! P(1,...) - P_2 * +! P(2,...), P(3,...), P(4,...) - grad P_2 * +!*********************************************************************** + +call mma_allocate(dTabMO,nP2_ontop,nMOs,nGrad_eff,mGrid,Label='dTabMO') +dTabMO(:,:,:,:) = Zero + +call mma_allocate(TabSO2,nMOs,mAO,mGrid,Label='TabSO2') +call mma_allocate(dTabMO2,nMOs,Label='dTabMO2') + +do ilist_s=1,nlist_s + + TabSO(:,:,:) = Zero + + call mk_SOs(TabSO,mAO,mGrid,nMOs,List_s,List_Bas,nList_s,iList_s) + + call ConvertTabSO(TabSO2,TabSO,mAO,mGrid,nMOs) + + do iGrid=1,mGrid + + do iCoord=1,3 + g_eff = list_g(iCoord,ilist_s) + + iCoord1 = 0 + iCoord2 = 0 + iCoord3 = 0 + if (lft .and. lGGA) then + select case (iCoord) + case (1) + iCoord1 = 4 + iCoord2 = 5 + iCoord3 = 6 + case (2) + iCoord1 = 5 + iCoord2 = 7 + iCoord3 = 8 + case (3) + iCoord1 = 6 + iCoord2 = 8 + iCoord3 = 9 + end select + end if + + do iIrrep=0,mIrrep-1 + nOccO = nIsh(iIrrep)+nAsh(iIrrep) + if (nOccO == 0) cycle + nBasF = nBas(iIrrep) + + iOffF = OffBas(iIrrep)+nFro(iIrrep) + + call DGEMM_('T','N',nOccO,1,nBasF,One,CMO(OffBas2(iIrrep):),nBasF,TabSO2(OffBas(iIrrep):,iCoord,iGrid),nBasF,Zero,dTabMO2, & + nOccO) + dTabMO(1,iOffF:iOffF+nOccO-1,g_eff,iGrid) = dTabMO(1,iOffF:iOffF+nOccO-1,g_eff,iGrid)+dTabMO2(1:nOccO) + + if (lft .and. lGGA) then + call DGEMM_('T','N',nOccO,1,nBasF,One,CMO(OffBas2(iIrrep):),nBasF,TabSO2(OffBas(iIrrep):,iCoord1,iGrid),nBasF,Zero, & + dTabMO2,nOccO) + dTabMO(2,iOffF:iOffF+nOccO-1,g_eff,iGrid) = dTabMO(2,iOffF:iOffF+nOccO-1,g_eff,iGrid)+dTabMO2(1:nOccO) + + call DGEMM_('T','N',nOccO,1,nBasF,One,CMO(OffBas2(iIrrep):),nBasF,TabSO2(OffBas(iIrrep):,iCoord2,iGrid),nBasF,Zero, & + dTabMO2,nOccO) + dTabMO(3,iOffF:iOffF+nOccO-1,g_eff,iGrid) = dTabMO(3,iOffF:iOffF+nOccO-1,g_eff,iGrid)+dTabMO2(1:nOccO) + + call DGEMM_('T','N',nOccO,1,nBasF,One,CMO(OffBas2(iIrrep):),nBasF,TabSO2(OffBas(iIrrep):,iCoord3,iGrid),nBasF,Zero, & + dTabMO2,nOccO) + dTabMO(4,iOffF:iOffF+nOccO-1,g_eff,iGrid) = dTabMO(4,iOffF:iOffF+nOccO-1,g_eff,iGrid)+dTabMO2(1:nOccO) + end if + end do ! iIrrep + end do ! iCoord + end do ! iGrid +end do ! iList_s +call mma_deallocate(TabSO2) +call mma_deallocate(dTabMO2) +!*********************************************************************** +! Inactive part: * +!*********************************************************************** +NumIsh = 0 +NumAsh = 0 +do iIrrep=0,mIrrep-1 + NumIsh = NumIsh+nISh(iIrrep) + NumAsh = NumAsh+nAsh(iIrrep) +end do + +do iGrid=1,mGrid + do iIrrep=0,mIrrep-1 + do i_=1,nISh(iIrrep)+nFro(iIrrep) + i = iOff_Bas(iIrrep)+i_ + RhoI(1,iGrid) = RhoI(1,iGrid)+TabMO(1,iGrid,i)*TabMO(1,iGrid,i) + if ((Functional_type == GGA_type) .and. ft) then + RhoI(2,iGrid) = RhoI(2,iGrid)+TabMO(1,iGrid,i)*TabMO(2,iGrid,i) + RhoI(3,iGrid) = RhoI(3,iGrid)+TabMO(1,iGrid,i)*TabMO(3,iGrid,i) + RhoI(4,iGrid) = RhoI(4,iGrid)+TabMO(1,iGrid,i)*TabMO(4,iGrid,i) + end if + + ! Build dRhoI + do g_eff=1,nGrad_eff + dRhoI(1,iGrid,g_eff) = dRhoI(1,iGrid,g_eff)+dTabMO(1,i,g_eff,iGrid)*TabMO(1,iGrid,i) !times 2 or not? + + if ((Functional_type == GGA_type) .and. ft) then + dRhoI(2,iGrid,g_eff) = dRhoI(2,iGrid,g_eff)+dTabMO(1,i,g_eff,iGrid)*TabMO(2,iGrid,i)+ & + TabMO(1,iGrid,i)*dTabMO(2,i,g_eff,iGrid) + + dRhoI(3,iGrid,g_eff) = dRhoI(3,iGrid,g_eff)+dTabMO(1,i,g_eff,iGrid)*TabMO(3,iGrid,i)+ & + TabMO(1,iGrid,i)*dTabMO(3,i,g_eff,iGrid) + + dRhoI(4,iGrid,g_eff) = dRhoI(4,iGrid,g_eff)+dTabMO(1,i,g_eff,iGrid)*TabMO(4,iGrid,i)+ & + TabMO(1,iGrid,i)*dTabMO(4,i,g_eff,iGrid) + + end if ! GGA + end do ! g_eff + + end do ! i_ + end do ! iIrrep +end do ! iGrid + +if (NumIsh /= 0) then + do iGrid=1,mGrid + P2_ontop(1,iGrid) = RhoI(1,iGrid)*RhoI(1,iGrid) + + if ((Functional_type == GGA_type) .and. ft) then + P2_ontop(2,iGrid) = Four*RhoI(1,iGrid)*RhoI(2,iGrid) + P2_ontop(3,iGrid) = Four*RhoI(1,iGrid)*RhoI(3,iGrid) + P2_ontop(4,iGrid) = Four*RhoI(1,iGrid)*RhoI(4,iGrid) + end if + do g_eff=1,nGrad_eff + P2_ontop_d(1,g_eff,iGrid) = P2_ontop_d(1,g_eff,iGrid)+Four*dRhoI(1,iGrid,g_eff)*RhoI(1,iGrid) + + if ((Functional_type == GGA_type) .and. ft) then + !******************ADD STUFF FOR FT: HERE*************** + P2_ontop_d(2,g_eff,iGrid) = P2_ontop_d(2,g_eff,iGrid)+Four*dRhoI(2,iGrid,g_eff)*RhoI(1,iGrid)+ & + Eight*dRhoI(1,iGrid,g_eff)*RhoI(2,iGrid) + + P2_ontop_d(3,g_eff,iGrid) = P2_ontop_d(3,g_eff,iGrid)+Four*dRhoI(3,iGrid,g_eff)*RhoI(1,iGrid)+ & + Eight*dRhoI(1,iGrid,g_eff)*RhoI(3,iGrid) + + P2_ontop_d(4,g_eff,iGrid) = P2_ontop_d(4,g_eff,iGrid)+Four*dRhoI(4,iGrid,g_eff)*RhoI(1,iGrid)+ & + Eight*dRhoI(1,iGrid,g_eff)*RhoI(4,iGrid) + + end if ! GGA + end do ! ngrad + + end do +end if + +!*********************************************************************** +! Active-Inactive part: * +!*********************************************************************** +if ((NumIsh /= 0) .and. (NumAsh /= 0)) then + do kIrrep=0,mIrrep-1 + do k_=1,nASh(kIrrep) + k = k_+iOff_BasAct(kIrrep) + do lIrrepx=0,mIrrep-1 + do l_=1,nAsh(lIrrepx) + l = l_+iOff_BasAct(lIrrepx) + kl = iTri(k_+iOff_Ash(kIrrep),l_+iOff_Ash(lIrrepx)) + do iGrid=1,mGrid + RhoA(1,iGrid) = RhoA(1,iGrid)+D1mo(kl)*TabMO(1,iGrid,k)*TabMO(1,iGrid,l) + if ((Functional_type == GGA_type) .and. ft) then + RhoA(2,iGrid) = RhoA(2,iGrid)+D1mo(kl)*TabMO(1,iGrid,k)*TabMO(2,iGrid,l) + RhoA(3,iGrid) = RhoA(3,iGrid)+D1mo(kl)*TabMO(1,iGrid,k)*TabMO(3,iGrid,l) + RhoA(4,iGrid) = RhoA(4,iGrid)+D1mo(kl)*TabMO(1,iGrid,k)*TabMO(4,iGrid,l) + end if + + do g_eff=1,nGrad_eff + dRhoA(1,iGrid,g_eff) = dRhoA(1,iGrid,g_eff)+D1mo(kl)*dTabMO(1,k,g_eff,iGrid)*TabMO(1,iGrid,l) + + !******************ADD STUFF FOR FT: HERE*************** + + if ((Functional_type == GGA_type) .and. ft) then + dRhoA(2,iGrid,g_eff) = dRhoA(2,iGrid,g_eff)+D1mo(kl)*dTabMO(1,k,g_eff,iGrid)*TabMO(2,iGrid,l)+ & + D1mo(kl)*TabMO(1,iGrid,k)*dTabMO(2,l,g_eff,iGrid) + + dRhoA(3,iGrid,g_eff) = dRhoA(3,iGrid,g_eff)+D1mo(kl)*dTabMO(1,k,g_eff,iGrid)*TabMO(3,iGrid,l)+ & + D1mo(kl)*TabMO(1,iGrid,k)*dTabMO(3,l,g_eff,iGrid) + + dRhoA(4,iGrid,g_eff) = dRhoA(4,iGrid,g_eff)+D1mo(kl)*dTabMO(1,k,g_eff,iGrid)*TabMO(4,iGrid,l)+ & + D1mo(kl)*TabMO(1,iGrid,k)*dTabMO(4,l,g_eff,iGrid) + end if ! GGA + + end do + end do ! iGrid + end do ! l_ + end do ! lIrrepx + end do ! k_ + end do ! kIrrep + + do iGrid=1,mGrid + P2_ontop(1,iGrid) = P2_ontop(1,iGrid)+RhoI(1,iGrid)*RhoA(1,iGrid) + if ((Functional_type == GGA_type) .and. ft) then + P2_ontop(2,iGrid) = P2_ontop(2,iGrid)+Two*RhoI(2,iGrid)*RhoA(1,iGrid)+Two*RhoI(1,iGrid)*RhoA(2,iGrid) + P2_ontop(3,iGrid) = P2_ontop(3,iGrid)+Two*RhoI(3,iGrid)*RhoA(1,iGrid)+Two*RhoI(1,iGrid)*RhoA(3,iGrid) + P2_ontop(4,iGrid) = P2_ontop(4,iGrid)+Two*RhoI(4,iGrid)*RhoA(1,iGrid)+Two*RhoI(1,iGrid)*RhoA(4,iGrid) + end if ! GGA + do g_eff=1,nGrad_Eff + P2_ontop_d(1,g_eff,iGrid) = P2_ontop_d(1,g_eff,iGrid)+Two*RhoI(1,iGrid)*dRhoA(1,iGrid,g_eff)+ & + Two*dRhoI(1,iGrid,g_eff)*RhoA(1,iGrid) + if ((Functional_type == GGA_type) .and. ft) then + + P2_ontop_d(2,g_eff,iGrid) = P2_ontop_d(2,g_eff,iGrid)+Two*dRhoI(2,iGrid,g_eff)*RhoA(1,iGrid)+ & + Four*RhoI(2,iGrid)*dRhoA(1,iGrid,g_eff)+Four*dRhoI(1,iGrid,g_eff)*RhoA(2,iGrid)+ & + Two*RhoI(1,iGrid)*dRhoA(2,iGrid,g_eff) + + P2_ontop_d(3,g_eff,iGrid) = P2_ontop_d(3,g_eff,iGrid)+Two*dRhoI(3,iGrid,g_eff)*RhoA(1,iGrid)+ & + Four*RhoI(3,iGrid)*dRhoA(1,iGrid,g_eff)+Four*dRhoI(1,iGrid,g_eff)*RhoA(3,iGrid)+ & + Two*RhoI(1,iGrid)*dRhoA(3,iGrid,g_eff) + + P2_ontop_d(4,g_eff,iGrid) = P2_ontop_d(4,g_eff,iGrid)+Two*dRhoI(4,iGrid,g_eff)*RhoA(1,iGrid)+ & + Four*RhoI(4,iGrid)*dRhoA(1,iGrid,g_eff)+Four*dRhoI(1,iGrid,g_eff)*RhoA(4,iGrid)+ & + Two*RhoI(1,iGrid)*dRhoA(4,iGrid,g_eff) + end if ! GGA + end do ! g_eff + + end do ! loop over grid points +end if ! if Inactive + +call mma_deallocate(dRhoI) +call mma_deallocate(dRhoA) + +!*********************************************************************** +! Active-Active part: * +!*********************************************************************** +if (NumAsh /= 0) then + + call mma_allocate(dMOs,NASHT,mGrid,Label='dMOs') + if (lft .and. lGGA) then + call mma_allocate(dMOx,NASHT,mGrid,Label='dMOx') + call mma_allocate(dMOy,NASHT,mGrid,Label='dMOy') + call mma_allocate(dMOz,NASHT,mGrid,Label='dMOz') + end if + + do g_eff=1,nGrad_eff + do iGrid=1,mGrid + do iIrrep=0,mIrrep-1 + IOff1 = IOff_Ash(iIrrep) + IOff2 = IOff_BasAct(iIrrep) + dMOs(IOff1+1:IOff1+nAsh(iIrrep),iGrid) = dTabMO(1,IOff2+1:IOff2+nAsh(iIrrep),g_eff,iGrid) + if (lft .and. lGGA) then + dMOx(IOff1+1:IOff1+nAsh(iIrrep),iGrid) = dTabMO(2,IOff2+1:IOff2+nAsh(iIrrep),g_eff,iGrid) + dMOy(IOff1+1:IOff1+nAsh(iIrrep),iGrid) = dTabMO(3,IOff2+1:IOff2+nAsh(iIrrep),g_eff,iGrid) + dMOz(IOff1+1:IOff1+nAsh(iIrrep),iGrid) = dTabMO(4,IOff2+1:IOff2+nAsh(iIrrep),g_eff,iGrid) + end if + end do + end do + + do iGrid=1,mGrid + do IIrrep=0,mIrrep-1 + IOff1 = iOff_Ash(IIrrep)+1 + P2_ontop_d(1,g_eff,iGrid) = P2_ontop_d(1,g_eff,iGrid)+Four*ddot_(nAsh(IIrrep),dMOs(IOff1:,iGrid),1,P2MOCube(IOff1:,iGrid),1) + if (lft .and. lGGA) then + P2_ontop_d(2,g_eff,iGrid) = P2_ontop_d(2,g_eff,iGrid)+ & + Four*ddot_(nAsh(IIrrep),dMOx(IOff1:,iGrid),1,P2MOCube(IOff1:,iGrid),1)+ & + Four*ddot_(nAsh(IIrrep),dMOs(IOff1:,iGrid),1,P2MOCubex(IOff1:,iGrid),1) + P2_ontop_d(3,g_eff,iGrid) = P2_ontop_d(3,g_eff,iGrid)+ & + Four*ddot_(nAsh(IIrrep),dMOy(IOff1:,iGrid),1,P2MOCube(IOff1:,iGrid),1)+ & + Four*ddot_(nAsh(IIrrep),dMOs(IOff1:,iGrid),1,P2MOCubey(IOff1:,iGrid),1) + P2_ontop_d(4,g_eff,iGrid) = P2_ontop_d(4,g_eff,iGrid)+ & + Four*ddot_(nAsh(IIrrep),dMOz(IOff1:,iGrid),1,P2MOCube(IOff1:,iGrid),1)+ & + Four*ddot_(nAsh(IIrrep),dMOs(IOff1:,iGrid),1,P2MOCubez(IOff1:,iGrid),1) + end if + end do + end do + end do + + do iGrid=1,mGrid + do IIrrep=0,mIrrep-1 + IOff1 = iOff_Ash(IIrrep)+1 + P2_ontop(1,iGrid) = P2_ontop(1,iGrid)+ddot_(nAsh(IIrrep),MOs(IOff1:,iGrid),1,P2MOCube(IOff1:,iGrid),1) + end do + end do + + if (lGGA .and. lft) then + do iGrid=1,mGrid + do IIrrep=0,mIrrep-1 + IOff1 = iOff_Ash(IIrrep)+1 + P2_ontop(2,iGrid) = P2_ontop(2,iGrid)+Four*ddot_(nAsh(IIrrep),MOx(IOff1:,iGrid),1,P2MOCube(IOff1:,iGrid),1) + P2_ontop(3,iGrid) = P2_ontop(3,iGrid)+Four*ddot_(nAsh(IIrrep),MOy(IOff1:,iGrid),1,P2MOCube(IOff1:,iGrid),1) + P2_ontop(4,iGrid) = P2_ontop(4,iGrid)+Four*ddot_(nAsh(IIrrep),MOz(IOff1:,iGrid),1,P2MOCube(IOff1:,iGrid),1) + !write(u6,*) 'MOz used for dPiz' + !write(u6,*) iGrid,iOff1 + !call RecPrt(' ',' ',MOz(iOff1:,iGrid),1,nAsh(iIrrep)) + end do + end do + end if + + call mma_deallocate(dMOs) + if (lft .and. lGGA) then + call mma_deallocate(dMOx) + call mma_deallocate(dMOy) + call mma_deallocate(dMOz) + end if + +end if +call mma_deallocate(dTabMO) + +return + +end subroutine Do_Pi2Grad diff -Nru openmolcas-22.02/src/nq_util/drvnq.f openmolcas-22.10/src/nq_util/drvnq.f --- openmolcas-22.02/src/nq_util/drvnq.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/drvnq.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,494 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2001, Roland Lindh * -************************************************************************ - Subroutine DrvNQ(Kernel,FckInt,nFckDim,Funct, - & Density,nFckInt,nD, - & Do_Grad,Grad,nGrad, - & Do_MO,Do_TwoEl,DFTFOCK) -************************************************************************ -* * -* Predriver for numerical integration utility. * -* * -* Author: Roland Lindh, * -* Dept of Chemical Physics, * -* University of Lund, Sweden * -* December 2001 * -************************************************************************ - use iSD_data - use Symmetry_Info, only: nIrrep - use KSDFT_Info, only: KSDFA - use nq_Grid, only: Rho, GradRho, Sigma, Tau, Lapl - use nq_Grid, only: vRho, vSigma, vTau, vLapl - use nq_Grid, only: Grid, Weights - use nq_Grid, only: nRho, nGradRho, nTau, nSigma, nLapl, nGridMax - use nq_Grid, only: l_CASDFT, kAO - use nq_Grid, only: F_xc, F_xca, F_xcb - use nq_Grid, only: List_G, IndGrd, iTab, Temp, Angular, Mem - use nq_Grid, only: Coor, R2_trial, Pax, Fact, nR_Eff - use nq_pdft, only: lGGA - use nq_MO, only: nMOs, CMO, D1MO, P2MO, P2_ontop - use nq_Structure, only: Close_NQ_Data - use Grid_On_Disk - use libxc - use nq_Info - Implicit Real*8 (A-H,O-Z) - External Kernel -#include "real.fh" -#include "stdalloc.fh" -#include "itmax.fh" -#include "setup.fh" -#include "nsd.fh" -#include "debug.fh" -#include "status.fh" -#include "ksdft.fh" - Real*8 FckInt(nFckInt,nFckDim),Density(nFckInt,nD), Grad(nGrad) - Logical Do_Grad, Do_MO,Do_TwoEl,PMode - Character*4 DFTFOCK - Integer nBas(8), nDel(8) - Integer, Allocatable:: Maps2p(:,:), List_s(:,:), List_Exp(:), - & List_Bas(:,:), List_P(:) - Real*8, Allocatable:: R_Min(:) -* * -************************************************************************ -* * - If (Do_TwoEl) Then - Do_MO =.True. - End If -* * -************************************************************************ -* * -*-----Allocate enough memory for Maps2p -* - Call Set_Basis_Mode('Valence') - Call Nr_Shells(nShell) - Call mma_allocate(Maps2p,nShell,nIrrep,Label='Maps2p') - Call mma_allocate(R_Min,LMax_NQ+1,Label='R_Min') -* - NQ_Status=Inactive - Call Setup_NQ(Maps2p,nShell,nIrrep,nNQ,Do_Grad,Do_MO, - & PThr,PMode,R_Min,LMax_NQ) -* - Call mma_deallocate(R_Min) -* * -************************************************************************ -* * -*-----Allocate memory sufficiently large to store all grid points -* and associated weights. -* - Call mma_Allocate(Grid,3,nGridMax,Label='Grid') - Call mma_Allocate(Weights,nGridMax,Label='Weights') -* * -************************************************************************ -* * -* CASDFT stuff: -* -! Note, l_CASDFT=.True. implies that both Do_MO and Do_Twoel are -! true. - - nTmpPUVX=1 -* - NQNAC=0 - If (l_casdft) Call Get_iArray('nAsh',nAsh,mIrrep) - If (DFTFOCK.ne.'SCF '.or.l_CASDFT) Then - Do iIrrep = 0, mIrrep - 1 - NQNAC = NQNAC + nAsh(iIrrep) - End Do - End If - NQNACPAR = ( NQNAC**2 + NQNAC )/2 - NQNACPR2 = ( NQNACPAR**2 + NQNACPAR )/2 -* - LuGridFile=31 - LuGridFile=IsFreeUnit(LuGridFile) - Call Molcas_Open(LuGridFile,'GRIDFILE') - - if(Debug) write(6,*) 'l_casdft value at drvnq.f:',l_casdft - if(Debug.and.l_casdft) write(6,*) 'MCPDFT with functional:', KSDFA -************************************************************************ -************************************************************************ -* -************************************************************************ -* * -* Definition of resources needed for the functionals. * -* * -* mAO: the number of derivatives needed of an basis function. * -* Depending of the functional type and if gradients will be * -* computed. Numbers will be 1, 4, 10, 20, 35, etc. * -* nRho:the number of parameters of the functional. Note that this * -* is different for the same functional depending on if it is * -* a closed or open-shell case. * -* mdRho_dR: number of derivatives of the parameters with respect * -* to the nuclear coordinates. The true number is of course * -* three (x,y,z) times this. * -* nF_drho: the number of derivatives of the functional wrt the * -* parameters. Note that grad rho is not a direct parameter * -* but that we use gamma. * -************************************************************************ -************************************************************************ -* * - Select Case (Functional_type) -* * -************************************************************************ -* * - Case (LDA_type) -* * -************************************************************************ -* * -* We need the AOs, for gradients we need the derivatives too. -* - mAO=1 - kAO=mAO - If (Do_Grad) mAO=4 -* -* We need rho. -* For gradients we need derivatives of rho wrt the coordinates -* - nRho=nD - mdRho_dr=0 - If (Do_Grad) mdRho_dr=nD - nSigma=0 - nGradRho=0 - nLapl=0 - nTau=0 -* -* We need derivatives of the functional with respect to -* rho(alpha). In case of open-shell calculations we also -* need rho(beta). -* - nP2_ontop=1 -* * -************************************************************************ -* * - Case (GGA_type) -* * -************************************************************************ -* * -* We need the AOs and their derivatives, for gradients we need -* the second derivatives too. -* - mAO=4 - kAO=mAO - If (Do_Grad) mAO=10 -* -* We need rho and grad rho -* For gradients we need the derrivatives wrt the coordinates -* - nRho=nD - nSigma=nD*(nD+1)/2 - nGradRho=nD*3 - mdRho_dR=0 - If (Do_Grad) mdRho_dR=4*nD -* -* We need derivatives of the functional with respect to -* rho(alpha), gamma(alpha,alpha) and gamma(alpha,beta). -* In case of open-shell calculations we also -* need rho(beta) and gamma(beta,beta). -* - nP2_ontop=4 - lGGA=.True. -* * -************************************************************************ -* * - Case (meta_GGA_type1) -* * -************************************************************************ -* * -* We need the AOs and their derivatives, for gradients we need -* the second derivatives too. -* - mAO=4 - kAO=mAO - If (Do_Grad) mAO=10 -* -* We need rho, grad rho and tau. -* For gradients we need the derrivatives wrt the coordinates -* - nRho=nD - nSigma=nD*(nD+1)/2 - nGradRho=nD*3 -* nLapl=0 - nLapl=nD - nTau=nD - mdRho_dR=0 - If (Do_Grad) mdRho_dR=5*nD -* -* We need derivatives of the functional with respect to -* rho(alpha), gamma(alpha,alpha), gamma(alpha,beta) and -* tau(alpha). In case of open-shell calculations we also -* need rho(beta), gamma(beta,beta) and tau(beta). -* - nP2_ontop=4 -* * -************************************************************************ -* * - Case (meta_GGA_type2) -* * -************************************************************************ -* * -* We need the AOs and their 1st and 2nd derivatives, for -* gradients we need the 3rd order derivatives too. -* - mAO=10 - kAO=mAO - If (Do_Grad) mAO=20 -* -* We need rho, grad rho, tau, and the Laplacian -* For gradients we need the derrivatives wrt the coordinates -* - nRho=nD - nSigma=nD*(nD+1)/2 - nGradRho=nD*3 - nTau=nD - nLapl=nD - mdRho_dR=0 - If (Do_Grad) mdRho_dR=6*nD -* -* We need derivatives of the functional with respect to -* rho(alpha), gamma(alpha,alpha), gamma(alpha,beta), -* tau(alpha) and laplacian(alpha). In case of open-shell -* calculations we also need rho(beta), gamma(beta,beta), -* tau(beta) and laplacian(beta). -* - nP2_ontop=4 -* * -************************************************************************ -* * - Case Default -* * -************************************************************************ -* * - Functional_type=Other_type - Call WarningMessage(2,'DrvNQ: Invalid Functional_type!') - Call Abend() - nRho=0 -* * -************************************************************************ -* * - End Select -* * -************************************************************************ -* * - Call mma_allocate(Rho,nRho,nGridMax,Label='Rho') - Call mma_allocate(vRho,nRho,nGridMax,Label='vRho') - Call mma_allocate(dfunc_drho,nRho,nGridMax,Label='dfunc_drho') - If (nSigma.ne.0) Then - Call mma_Allocate(Sigma,nSigma,nGridMax,Label='Sigma') - Call mma_Allocate(vSigma,nSigma,nGridMax,Label='vSigma') - Call mma_Allocate(dfunc_dSigma,nSigma,nGridMax, - & Label='dfunc_dSigma') - End If - If (nGradRho.ne.0) Then - Call mma_Allocate(GradRho,nGradRho,nGridMax,Label='GradRho') - End If - If (nTau.ne.0) Then - Call mma_allocate(Tau,nTau,nGridMax,Label='Tau') - Call mma_allocate(vTau,nTau,nGridMax,Label='vTau') - Call mma_allocate(dfunc_dTau,nTau,nGridMax,Label='dfunc_dTau') - Tau(:,:)=Zero - End If - If (nLapl.ne.0) Then - Call mma_allocate(Lapl,nLapl,nGridMax,Label='Lapl') - Call mma_allocate(vLapl,nLapl,nGridMax,Label='vLapl') - Call mma_allocate(dfunc_dLapl,nLapl,nGridMax, - & Label='dfunc_dLapl') - Lapl(:,:)=Zero - End If - - Call mma_allocate(F_xc,nGridMax,Label='F_xc') - Call mma_allocate(func,nGridMax,Label='func') - If (l_casdft) Then - Call mma_allocate(F_xca,nGridMax,Label='F_xca') - Call mma_allocate(F_xcb,nGridMax,Label='F_xcb') - End If -* - Call mma_allocate(List_S,2,nIrrep*nShell,Label='List_S') - Call mma_allocate(List_Exp,nIrrep*nShell,Label='List_Exp') - Call mma_allocate(List_Bas,2,nIrrep*nShell,Label='List_Bas') - Call mma_allocate(List_P,nNQ,Label='List_P') - Call mma_allocate(R2_trial,nNQ,Label='R2_trial') - - If (Do_MO) Then - If (NQNAC.ne.0) Then - nD1MO = NQNACPAR - Call mma_allocate(D1MO,nD1MO,Label='D1MO') - Call Get_D1MO(D1MO,nD1MO) - nP2 = NQNACPR2 - Call mma_Allocate(P2MO,nP2,Label='P2MO') - call Get_P2mo(P2MO,nP2) - End If - Call Get_iArray('nBas',nBas,mIrrep) - Call Get_iArray('nDel',nDel,mIrrep) - nCMO=0 - Do i = 1, mIrrep - nCMO = nCMO + nBas(i)*(nBas(i)-nDel(i)) - End Do - Call mma_allocate(CMO,nCMO,Label='CMO') - Call Get_CMO(CMO,nCMO) - Call Get_iArray('nAsh',nAsh,mIrrep) - nMOs=0 - Do iIrrep = 0, mIrrep-1 - nMOs=nMOs+mBas(iIrrep) - End Do - End If -*** -* Prepare memory for two-electron integrals: -* nPUVX -* - If (Do_TwoEl) Then - If (.not.Do_MO) Then - Call WarningMessage(2, - & ' Can''t produce 2 el dft integrals without MO') - Call Abend() - End If -* - iStack = 0 - Do iIrrep = 0, mIrrep-1 - iOrb = mBas(iIrrep) - nFro(iIrrep) - Do jIrrep = 0, mIrrep-1 - jAsh = nAsh(jIrrep) - ijIrrep=iEor(iIrrep,jIrrep) - Do kIrrep = 0, mIrrep-1 - kAsh = nAsh(kIrrep) - ijkIrrep=iEor(ijIrrep,kIrrep) - If (ijkIrrep.le.kIrrep) Then - lAsh = nAsh(ijkIrrep) - kl_Orb_pairs = kAsh*lAsh - If ( kIrrep.eq.ijkIrrep ) - & kl_Orb_pairs = (kAsh*kAsh+kAsh)/2 - iStack = iStack + iOrb*jAsh*kl_Orb_pairs - End If - End Do - End Do - End Do - nTmpPUVX=iStack -* - End If -* - If (Do_Grad) Then - Call mma_allocate(List_g,3,nShell*nIrrep,Label='List_G') - mGrad=3*nAtoms - Call mma_allocate(IndGrd,mGrad,Label='IndGrd') - Call mma_allocate(iTab,4,mGrad,Label='iTab') - Call mma_allocate(Temp,mGrad,Label='Temp') - End If - - If (.Not.Do_Grad) Call FZero(FckInt,nFckInt*nFckDim) -* * -************************************************************************ -* * - if(Debug) write(6,*) 'l_casdft value at drvnq.f:',l_casdft - if(Debug.and.l_casdft) write(6,*) 'MCPDFT with functional:', KSDFA - - If(l_casdft) then - Call mma_allocate(P2_ontop,nP2_ontop,nGridMax,Label='P2_ontop') - P2_ontop(:,:)=Zero - end if - - Call DrvNQ_Inner(Kernel,Funct,Maps2p,nIrrep,List_S,List_Exp, - & List_bas,nShell,List_P,nNQ, - & FckInt,nFckDim,Density,nFckInt,nD, - & nGridMax,nP2_ontop,Do_Mo,nTmpPUVX, - & Do_Grad,Grad,nGrad,mAO,mdRho_dR) -* * -************************************************************************ -* * -*-----Deallocate the memory -* - Call mma_deallocate(Pax) - If (Do_Grad) Then - Call mma_deallocate(Temp) - Call mma_deallocate(iTab) - Call mma_deallocate(IndGrd) - Call mma_deallocate(List_G) - End If - Call mma_deallocate(R2_trial) - Call mma_deallocate(List_P) - Call mma_deallocate(List_Bas) - Call mma_deallocate(List_Exp) - Call mma_deallocate(List_S) -*Do_TwoEl - If (Allocated(D1MO)) Call mma_deallocate(D1MO) - If (Allocated(P2MO)) Call mma_deallocate(P2MO) - If (Allocated(CMO)) Call mma_deallocate(CMO) - If (l_casdft) Then - Call mma_deallocate(F_xcb) - Call mma_deallocate(F_xca) - End If - Call mma_deallocate(func) - Call mma_deallocate(F_xc) -* - If (Allocated(Lapl)) Then - Call mma_deallocate(dfunc_dLapl) - Call mma_deallocate(vLapl) - Call mma_deallocate(Lapl) - End If - If (Allocated(Tau)) Then - Call mma_deallocate(dfunc_dTau) - Call mma_deallocate(vTau) - Call mma_deallocate(Tau) - End If - If (Allocated(GradRho)) Call mma_deallocate(GradRho) - If (Allocated(Sigma)) Then - Call mma_deallocate(dfunc_dSigma) - Call mma_deallocate(vSigma) - Call mma_deallocate(Sigma) - End If - Call mma_deallocate(dfunc_dRho) - Call mma_deallocate(vRho) - Call mma_deallocate(Rho) - - Call mma_deallocate(Weights) - Call mma_deallocate(Grid) - - if(Debug) write(6,*) 'l_casdft value at drvnq.f:',l_casdft - if(Debug.and.l_casdft) write(6,*) 'MCPDFT with functional:', KSDFA - If (Allocated(P2_ontop)) Call mma_deallocate(P2_ontop) -* - Call mma_deallocate(nR_Eff) - Call mma_deallocate(Coor) - - Call Close_NQ_Data() - Call mma_deallocate(Mem) - Call mma_deallocate(Angular) - Call mma_deallocate(Fact) - Call mma_deallocate(Maps2p) - NQ_Status=Inactive -* * -************************************************************************ -* * -*---- Write the status flag and TOC. -* - If (iGrid_Set.eq.Intermediate .and. - & Grid_Status.eq.Regenerate) iDisk_Set(Final)=iDisk_Grid - If (Do_Grad) Then - G_S(iGrid_Set)=Regenerate - Else - G_S(iGrid_Set)=Use_Old - End If -* - iDisk_Grid=0 - Call iDaFile(Lu_Grid,1,G_S,5,iDisk_Grid) - iDisk_Grid=iDisk_Set(iGrid_Set) - Call iDaFile(Lu_Grid,1,GridInfo, - & 2*number_of_subblocks,iDisk_Grid) -* - Call DaClos(Lu_Grid) -* - Call mma_deallocate(GridInfo) -* * -************************************************************************ -* * - Call IniPkR8(PThr,PMode) -* - Call xFlush(LuGridFile) - Close(LuGridFile) - Return - End diff -Nru openmolcas-22.02/src/nq_util/drvnq.F90 openmolcas-22.10/src/nq_util/drvnq.F90 --- openmolcas-22.02/src/nq_util/drvnq.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/drvnq.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,497 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2001, Roland Lindh * +!*********************************************************************** + +subroutine DrvNQ(Kernel,FckInt,nFckDim,Funct,Density,nFckInt,nD,Do_Grad,Grad,nGrad,Do_MO,Do_TwoEl,DFTFOCK,IsFT) +!*********************************************************************** +! * +! Predriver for numerical integration utility. * +! * +! Author: Roland Lindh, * +! Dept of Chemical Physics, * +! University of Lund, Sweden * +! December 2001 * +!*********************************************************************** + +use Symmetry_Info, only: nIrrep +use nq_Grid, only: Angular, Coor, F_xc, F_xca, F_xcb, Fact, GradRho, Grid, IndGrd, iTab, kAO, l_CASDFT, Lapl, List_G, Mem, & + nGridMax, nR_Eff, nRho, Pax, R2_trial, Rho, Sigma, Tau, Temp, vLapl, vRho, vSigma, vTau, Weights +use nq_pdft, only: lft, lGGA +use nq_MO, only: nMOs, CMO, D1MO, P2MO, P2_ontop +use nq_Structure, only: Close_NQ_Data +use nq_Info, only: Functional_type, GGA_type, LDA_type, LMax_NQ, mBas, meta_GGA_type1, meta_GGA_type2, mIrrep, nAsh, nAtoms, nFro, & + number_of_subblocks, Other_type +use Grid_On_Disk, only: Final_Grid, G_S, Grid_Status, GridInfo, iDisk_Grid, iDisk_Set, iGrid_Set, Intermediate, Lu_Grid, & + LuGridFile, Old_Functional_Type, Regenerate, Use_Old +use libxc, only: dfunc_dLapl, dfunc_drho, dfunc_dsigma, dfunc_dTau, func +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp +#ifdef _DEBUGPRINT_ +use Definitions, only: u6 +#endif + +implicit none +external :: Kernel +integer(kind=iwp), intent(in) :: nFckDim, nFckInt, nD, nGrad +real(kind=wp), intent(inout) :: FckInt(nFckInt,nFckDim), Funct, Grad(nGrad) +real(kind=wp), intent(in) :: Density(nFckInt,nD) +logical(kind=iwp), intent(in) :: Do_Grad, Do_TwoEl, IsFT +logical(kind=iwp), intent(inout) :: Do_MO +character(len=4), intent(in) :: DFTFOCK +#include "status.fh" +integer(kind=iwp) :: i, iDum(1), iIrrep, ijIrrep, ijkIrrep, iOrb, iStack, jAsh, jIrrep, kAsh, kIrrep, kl_Orb_pairs, lAsh, mAO, & + mdRho_dr, mGrad, nBas(8), nCMO, nD1MO, nDel(8), nGradRho, nLapl, nNQ, nP2, nP2_ontop, nSigma, nTau, NQNAC, & + NQNACPAR, NQNACPR2, nShell, nTmpPUVX +real(kind=wp) :: PThr +logical(kind=iwp) :: PMode +integer(kind=iwp), allocatable :: List_Bas(:,:), List_Exp(:), List_P(:), List_s(:,:), Maps2p(:,:) +real(kind=wp), allocatable :: R_Min(:) +integer(kind=iwp), external :: IsFreeUnit + +! * +!*********************************************************************** +! * +lft = IsFT +if (Do_TwoEl) Do_MO = .true. +! * +!*********************************************************************** +! * +! Allocate enough memory for Maps2p + +call Set_Basis_Mode('Valence') +call Nr_Shells(nShell) +call mma_allocate(Maps2p,nShell,nIrrep,Label='Maps2p') +call mma_allocate(R_Min,LMax_NQ+1,Label='R_Min') + +NQ_Status = Inactive +call Setup_NQ(Maps2p,nShell,nIrrep,nNQ,Do_Grad,Do_MO,PThr,PMode,R_Min,LMax_NQ) + +call mma_deallocate(R_Min) +! * +!*********************************************************************** +! * +! Allocate memory sufficiently large to store all grid points +! and associated weights. + +call mma_Allocate(Grid,3,nGridMax,Label='Grid') +call mma_Allocate(Weights,nGridMax,Label='Weights') +! * +!*********************************************************************** +! * +! CASDFT stuff: +! +! Note, l_CASDFT=.True. implies that both Do_MO and Do_Twoel are true. + +nTmpPUVX = 1 + +NQNAC = 0 +if (l_casdft) call Get_iArray('nAsh',nAsh,mIrrep) +if ((DFTFOCK /= 'SCF ') .or. l_CASDFT) then + do iIrrep=0,mIrrep-1 + NQNAC = NQNAC+nAsh(iIrrep) + end do +end if +NQNACPAR = (NQNAC**2+NQNAC)/2 +NQNACPR2 = (NQNACPAR**2+NQNACPAR)/2 + +LuGridFile = 31 +LuGridFile = IsFreeUnit(LuGridFile) +call Molcas_Open(LuGridFile,'GRIDFILE') + +#ifdef _DEBUGPRINT_ +write(u6,*) 'l_casdft value at drvnq:',l_casdft +if (l_casdft) write(u6,*) 'MCPDFT with functional:',KSDFA +#endif +! * +!*********************************************************************** +!*********************************************************************** +! * +! Definition of resources needed for the functionals. * +! * +! mAO: the number of derivatives needed of an basis function. * +! Depending of the functional type and if gradients will be * +! computed. Numbers will be 1, 4, 10, 20, 35, etc. * +! nRho:the number of parameters of the functional. Note that this * +! is different for the same functional depending on if it is * +! a closed or open-shell case. * +! mdRho_dR: number of derivatives of the parameters with respect * +! to the nuclear coordinates. The true number is of course * +! three (x,y,z) times this. * +! nF_drho: the number of derivatives of the functional wrt the * +! parameters. Note that grad rho is not a direct parameter * +! but that we use gamma. * +!*********************************************************************** +!*********************************************************************** +! * +select case (Functional_type) + + case (LDA_type) + ! * + !******************************************************************* + ! * + ! We need the AOs, for gradients we need the derivatives too. + + mAO = 1 + kAO = mAO + if (Do_Grad) mAO = 4 + + ! We need rho. + ! For gradients we need derivatives of rho wrt the coordinates + + nRho = nD + mdRho_dr = 0 + if (Do_Grad) mdRho_dr = nD + nSigma = 0 + nGradRho = 0 + nLapl = 0 + nTau = 0 + + ! We need derivatives of the functional with respect to + ! rho(alpha). In case of open-shell calculations we also + ! need rho(beta). + + nP2_ontop = 1 + ! * + !******************************************************************* + ! * + case (GGA_type) + ! * + !******************************************************************* + ! * + ! We need the AOs and their derivatives, for gradients we need + ! the second derivatives too. + + mAO = 4 + kAO = mAO + if (Do_Grad) mAO = 10 + + ! We need rho and grad rho + ! For gradients we need the derrivatives wrt the coordinates + + nRho = nD + nSigma = nD*(nD+1)/2 + nGradRho = nD*3 + nLapl = 0 + nTau = 0 + mdRho_dR = 0 + if (Do_Grad) mdRho_dR = 4*nD + + ! We need derivatives of the functional with respect to + ! rho(alpha), gamma(alpha,alpha) and gamma(alpha,beta). + ! In case of open-shell calculations we also + ! need rho(beta) and gamma(beta,beta). + + nP2_ontop = 4 + lGGA = .true. + ! * + !******************************************************************* + ! * + case (meta_GGA_type1) + ! * + !******************************************************************* + ! * + ! We need the AOs and their derivatives, for gradients we need + ! the second derivatives too. + + mAO = 4 + kAO = mAO + if (Do_Grad) mAO = 10 + + ! We need rho, grad rho and tau. + ! For gradients we need the derrivatives wrt the coordinates + + nRho = nD + nSigma = nD*(nD+1)/2 + nGradRho = nD*3 + !nLapl = 0 + nLapl = nD + nTau = nD + mdRho_dR = 0 + if (Do_Grad) mdRho_dR = 5*nD + + ! We need derivatives of the functional with respect to + ! rho(alpha), gamma(alpha,alpha), gamma(alpha,beta) and + ! tau(alpha). In case of open-shell calculations we also + ! need rho(beta), gamma(beta,beta) and tau(beta). + + nP2_ontop = 4 + ! * + !******************************************************************* + ! * + case (meta_GGA_type2) + ! * + !******************************************************************* + ! * + ! We need the AOs and their 1st and 2nd derivatives, for + ! gradients we need the 3rd order derivatives too. + + mAO = 10 + kAO = mAO + if (Do_Grad) mAO = 20 + + ! We need rho, grad rho, tau, and the Laplacian + ! For gradients we need the derrivatives wrt the coordinates + + nRho = nD + nSigma = nD*(nD+1)/2 + nGradRho = nD*3 + nLapl = nD + nTau = nD + mdRho_dR = 0 + if (Do_Grad) mdRho_dR = 6*nD + + ! We need derivatives of the functional with respect to + ! rho(alpha), gamma(alpha,alpha), gamma(alpha,beta), + ! tau(alpha) and laplacian(alpha). In case of open-shell + ! calculations we also need rho(beta), gamma(beta,beta), + ! tau(beta) and laplacian(beta). + + nP2_ontop = 4 + ! * + !******************************************************************* + ! * + case default + ! * + !******************************************************************* + ! * + Functional_type = Other_type + call WarningMessage(2,'DrvNQ: Invalid Functional_type!') + call Abend() + nRho = 0 + nSigma = 0 + nGradRho = 0 + nLapl = 0 + nTau = 0 + ! * + !******************************************************************* + ! * +end select +! * +!*********************************************************************** +! * +call mma_allocate(Rho,nRho,nGridMax,Label='Rho') +call mma_allocate(vRho,nRho,nGridMax,Label='vRho') +call mma_allocate(dfunc_drho,nRho,nGridMax,Label='dfunc_drho') +if (nSigma /= 0) then + call mma_Allocate(Sigma,nSigma,nGridMax,Label='Sigma') + call mma_Allocate(vSigma,nSigma,nGridMax,Label='vSigma') + call mma_Allocate(dfunc_dSigma,nSigma,nGridMax,Label='dfunc_dSigma') +end if +if (nGradRho /= 0) then + call mma_Allocate(GradRho,nGradRho,nGridMax,Label='GradRho') +end if +if (nTau /= 0) then + call mma_allocate(Tau,nTau,nGridMax,Label='Tau') + call mma_allocate(vTau,nTau,nGridMax,Label='vTau') + call mma_allocate(dfunc_dTau,nTau,nGridMax,Label='dfunc_dTau') + Tau(:,:) = Zero +end if +if (nLapl /= 0) then + call mma_allocate(Lapl,nLapl,nGridMax,Label='Lapl') + call mma_allocate(vLapl,nLapl,nGridMax,Label='vLapl') + call mma_allocate(dfunc_dLapl,nLapl,nGridMax,Label='dfunc_dLapl') + Lapl(:,:) = Zero +end if + +call mma_allocate(F_xc,nGridMax,Label='F_xc') +call mma_allocate(func,nGridMax,Label='func') +if (l_casdft) then + call mma_allocate(F_xca,nGridMax,Label='F_xca') + call mma_allocate(F_xcb,nGridMax,Label='F_xcb') +end if + +call mma_allocate(List_S,2,nIrrep*nShell,Label='List_S') +call mma_allocate(List_Exp,nIrrep*nShell,Label='List_Exp') +call mma_allocate(List_Bas,2,nIrrep*nShell,Label='List_Bas') +call mma_allocate(List_P,nNQ,Label='List_P') +call mma_allocate(R2_trial,nNQ,Label='R2_trial') + +if (Do_MO) then + if (NQNAC /= 0) then + nD1MO = NQNACPAR + call mma_allocate(D1MO,nD1MO,Label='D1MO') + call Get_D1MO(D1MO,nD1MO) + nP2 = NQNACPR2 + call mma_Allocate(P2MO,nP2,Label='P2MO') + call Get_P2mo(P2MO,nP2) + end if + call Get_iArray('nBas',nBas,mIrrep) + call Get_iArray('nDel',nDel,mIrrep) + nCMO = 0 + do i=1,mIrrep + nCMO = nCMO+nBas(i)*(nBas(i)-nDel(i)) + end do + call mma_allocate(CMO,nCMO,Label='CMO') + call Get_CMO(CMO,nCMO) + call Get_iArray('nAsh',nAsh,mIrrep) + nMOs = 0 + do iIrrep=0,mIrrep-1 + nMOs = nMOs+mBas(iIrrep) + end do +end if + +! Prepare memory for two-electron integrals: +! nPUVX + +if (Do_TwoEl) then + if (.not. Do_MO) then + call WarningMessage(2,' Can''t produce 2 el dft integrals without MO') + call Abend() + end if + + iStack = 0 + do iIrrep=0,mIrrep-1 + iOrb = mBas(iIrrep)-nFro(iIrrep) + do jIrrep=0,mIrrep-1 + jAsh = nAsh(jIrrep) + ijIrrep = ieor(iIrrep,jIrrep) + do kIrrep=0,mIrrep-1 + kAsh = nAsh(kIrrep) + ijkIrrep = ieor(ijIrrep,kIrrep) + if (ijkIrrep <= kIrrep) then + lAsh = nAsh(ijkIrrep) + kl_Orb_pairs = kAsh*lAsh + if (kIrrep == ijkIrrep) kl_Orb_pairs = (kAsh*kAsh+kAsh)/2 + iStack = iStack+iOrb*jAsh*kl_Orb_pairs + end if + end do + end do + end do + nTmpPUVX = iStack + +end if + +if (Do_Grad) then + call mma_allocate(List_g,3,nShell*nIrrep,Label='List_G') + mGrad = 3*nAtoms + call mma_allocate(IndGrd,mGrad,Label='IndGrd') + call mma_allocate(iTab,4,mGrad,Label='iTab') + call mma_allocate(Temp,mGrad,Label='Temp') +end if + +if (.not. Do_Grad) FckInt(:,:) = Zero +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +write(u6,*) 'l_casdft value at drvnq:',l_casdft +if (l_casdft) write(u6,*) 'MCPDFT with functional:',KSDFA +#endif + +if (l_casdft) then + call mma_allocate(P2_ontop,nP2_ontop,nGridMax,Label='P2_ontop') + P2_ontop(:,:) = Zero +end if + +call DrvNQ_Inner(Kernel,Funct,Maps2p,nIrrep,List_S,List_Exp,List_bas,nShell,List_P,nNQ,FckInt,nFckDim,Density,nFckInt,nD,nGridMax, & + nP2_ontop,Do_Mo,nTmpPUVX,Do_Grad,Grad,nGrad,mAO,mdRho_dR) +! * +!*********************************************************************** +! * +! Deallocate the memory + +call mma_deallocate(Pax) +if (Do_Grad) then + call mma_deallocate(Temp) + call mma_deallocate(iTab) + call mma_deallocate(IndGrd) + call mma_deallocate(List_G) +end if +call mma_deallocate(R2_trial) +call mma_deallocate(List_P) +call mma_deallocate(List_Bas) +call mma_deallocate(List_Exp) +call mma_deallocate(List_S) +! Do_TwoEl +if (allocated(D1MO)) call mma_deallocate(D1MO) +if (allocated(P2MO)) call mma_deallocate(P2MO) +if (allocated(CMO)) call mma_deallocate(CMO) +if (l_casdft) then + call mma_deallocate(F_xcb) + call mma_deallocate(F_xca) +end if +call mma_deallocate(func) +call mma_deallocate(F_xc) +! +if (allocated(Lapl)) then + call mma_deallocate(dfunc_dLapl) + call mma_deallocate(vLapl) + call mma_deallocate(Lapl) +end if +if (allocated(Tau)) then + call mma_deallocate(dfunc_dTau) + call mma_deallocate(vTau) + call mma_deallocate(Tau) +end if +if (allocated(GradRho)) call mma_deallocate(GradRho) +if (allocated(Sigma)) then + call mma_deallocate(dfunc_dSigma) + call mma_deallocate(vSigma) + call mma_deallocate(Sigma) +end if +call mma_deallocate(dfunc_dRho) +call mma_deallocate(vRho) +call mma_deallocate(Rho) + +call mma_deallocate(Weights) +call mma_deallocate(Grid) + +#ifdef _DEBUGPRINT_ +write(u6,*) 'l_casdft value at drvnq:',l_casdft +if (l_casdft) write(u6,*) 'MCPDFT with functional:',KSDFA +#endif +if (allocated(P2_ontop)) call mma_deallocate(P2_ontop) + +call mma_deallocate(nR_Eff) +call mma_deallocate(Coor) + +call Close_NQ_Data() +call mma_deallocate(Mem) +call mma_deallocate(Angular) +call mma_deallocate(Fact) +call mma_deallocate(Maps2p) +NQ_Status = Inactive +! * +!*********************************************************************** +! * +! Write the status flag and TOC. + +if ((iGrid_Set == Intermediate) .and. (Grid_Status == Regenerate)) iDisk_Set(Final_Grid) = iDisk_Grid +if (Do_Grad) then + G_S(iGrid_Set) = Regenerate +else + G_S(iGrid_Set) = Use_Old +end if + +iDisk_Grid = 0 +call iDaFile(Lu_Grid,1,G_S,2,iDisk_Grid) +call iDaFile(Lu_Grid,1,iDisk_Set,2,iDisk_Grid) +iDum(1) = Old_Functional_Type +call iDaFile(Lu_Grid,1,iDum,1,iDisk_Grid) +iDisk_Grid = iDisk_Set(iGrid_Set) +call iDaFile(Lu_Grid,1,GridInfo,2*number_of_subblocks,iDisk_Grid) + +call DaClos(Lu_Grid) + +call mma_deallocate(GridInfo) +! * +!*********************************************************************** +! * +call IniPkR8(PThr,PMode) + +call xFlush(LuGridFile) +close(LuGridFile) + +return + +end subroutine DrvNQ diff -Nru openmolcas-22.02/src/nq_util/drvnq_inner.f openmolcas-22.10/src/nq_util/drvnq_inner.f --- openmolcas-22.02/src/nq_util/drvnq_inner.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/drvnq_inner.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,379 +0,0 @@ -*********************************************************************** -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1999, Roland Lindh * -************************************************************************ - Subroutine DrvNQ_Inner(Kernel,Func, - & Maps2p,nSym,list_s,list_exp,list_bas, - & nShell,list_p,nNQ, - & FckInt,nFckDim,Density,nFckInt,nD, - & mGrid,nP2_ontop,Do_Mo,nTmpPUVX, - & Do_Grad,Grad,nGrad,mAO,mdRho_dR) -************************************************************************ -* * -* Object: Driver for numerical quadrature. * -* * -* Author: Roland Lindh, * -* Dept of Chemical Physics, * -* University of Lund, Sweden * -* August 1999 * -************************************************************************ -#ifdef _DEBUGPRINT_ - use Basis_Info, only: nBas -#endif - use Real_Spherical - use Symmetry_Info, only: nIrrep, iOper - use KSDFT_Info, only: KSDFA, LuMC, LuMT, Funcaa, Funcbb, Funccc - use nq_Grid, only: l_casdft, D1UnZip, P2UnZip - use nq_MO, only: D1MO, P2MO - use nq_Structure, only: Close_Info_Ang - use Grid_On_Disk - use nq_Info - Implicit Real*8 (A-H,O-Z) - External Kernel, Rsv_Tsk -#include "real.fh" -#include "nsd.fh" -#include "setup.fh" -#include "status.fh" -#include "debug.fh" -#include "ksdft.fh" -#include "stdalloc.fh" - Integer Maps2p(nShell,0:nSym-1), - & list_s(nSym*nShell), list_exp(nSym*nShell), - & list_p(nNQ), list_bas(2,nSym*nShell) - Real*8 FckInt(nFckInt,nFckDim),Density(nFckInt,nD), Grad(nGrad) - Logical Check, Do_Grad, Rsv_Tsk - Logical Do_Mo,Exist,l_tgga - REAL*8,DIMENSION(:),Allocatable:: PDFTPot1,PDFTFocI,PDFTFocA - Real*8, Allocatable:: OE_OT(:), EG_OT(:) - Real*8, Allocatable:: FI_V(:), FA_V(:) -* * -************************************************************************ -* * -* Statement functions -* - Check(i,j)=iAnd(i,2**(j-1)).ne.0 -* * -************************************************************************ -* * -************************************************************************ -* Initializations for MC-PDFT * -************************************************************************ -************************************************************************ -* Open file for MC-PDFT to store density, pair density and ratio: * -* ratio = 4pi/rho^2 * -************************************************************************ - IF(l_casdft) then -! - PUVX_Time= 0d0 - FA_Time = 0d0 - sp_time = 0d0 - FI_time = 0d0 -! - IF(Debug) THEN - LuMC=37 - call OpnFl('MCPDFT',LuMC,Exist) -c Call append_file(LuMC) - write(LuMC,'(A)') ' Here densities are MCPDFT modified ones.' - write(LuMC,*) ' Used by translated functional: ', KSDFA(1:8) - write(LuMC,'(A)') ' X , Y , Z ,'// - & ' d_a*W , d_b*W ,'// - & ' dTot*W , Weights ,'// - & ' dTot , P2 , ratio' - LuMT=37 - call OpnFl('MCTRUD',LuMT,Exist) -c Call append_file(LuMT) - write(LuMT,'(A)') ' Here densities are original ones.' - write(LuMT,*) ' Used by translated functional: ', KSDFA(1:8) - write(LuMT,'(A)') ' X , Y , Z ,'// - & ' d_a*W , d_b*W ,'// - & ' dTot*W , Weights ,'// - & ' dTot ' - END IF - - CALL CalcOrbOff() - NASHT4=NASHT**4 - CALL mma_allocate(P2Unzip,NASHT4) - CALL mma_allocate(D1Unzip,NASHT**2) - CALL UnzipD1(D1Unzip,D1MO,SIZE(D1MO)) - CALL UnzipP2(P2Unzip,P2MO,SIZE(P2MO)) - END IF -************************************************************************ -* -*----- Desymmetrize the 1-particle density matrix -* - Call Allok2_Funi(nD) - Call DeDe_Funi(Density,nFckInt,nD) -* - If(l_casdft.and.do_pdftPot) then - CALL mma_allocate(PDFTPot1,nPot1) - CALL mma_allocate(PDFTFocI,nPot1) - CALL mma_allocate(PDFTFocA,nPot1) - CALL mma_allocate(OE_OT,nFckInt,Label='OE_OT') - CALL mma_allocate(EG_OT,nTmpPUVX,Label='EG_OT') - Call mma_allocate(FI_V,nFckInt,Label='FI_V') - Call mma_allocate(FA_V,nFckInt,Label='FA_V') - - OE_OT(:)=Zero - EG_OT(:)=Zero - FI_V(:)=Zero - FA_V(:)=Zero - CALL FZero(PDFTPot1,nPot1) - CALL FZero(PDFTFocI,nPot1) - CALL FZero(PDFTFocA,nPot1) - CALL CalcPUVXOff() - Else - nPot1=1 - CALL mma_allocate(OE_OT,nPot1,Label='OE_OT') - CALL mma_allocate(EG_OT,nPot1,Label='EG_OT') - Call mma_allocate(FI_V,nPot1,Label='FI_V') - Call mma_allocate(FA_V,nPot1,Label='FA_V') - CALL mma_allocate(PDFTPot1,nPot1) - CALL mma_allocate(PDFTFocI,nPot1) - CALL mma_allocate(PDFTFocA,nPot1) - End If -* * -************************************************************************ -* * -* For a parallel implementation the iterations over -* subblocks are parallelized. -* - Call Init_Tsk(id,number_of_subblocks) ! Initialize parallelization -* -*-----Loop over subblocks -* - iSB = 0 -C Do iSB = 1, number_of_subblocks -* -*------- Start of parallelized loop here! -* - 100 Continue - If (Grid_Status.eq.Regenerate) Then -* Try to get an iSB to execute. If fail: done and branch out! - If (.Not.Rsv_Tsk(id,iSB)) Go To 200 - Else -* Try to find a subblock which was generated by this processor. - iSB = iSB + 1 - If (iSB.gt.number_of_subblocks) Go To 200 - If (GridInfo(2,iSB).eq.0) Go To 100 - End If -* * -************************************************************************ -* * -*------- Eliminate redundant subblocks in case of symmetry. -* This is only done for the Lebedev grids! -* - If (nIrrep.ne.1.and.Check(iOpt_Angular,3)) Then -* -*---------- Resolve triplet index -* - iyz = 1 + (iSB-1)/nx - ix = iSB - (iyz-1)*nx - iz = 1 + (iyz-1)/ny - iy = iyz - (iz-1)*ny -* -*---------- Do symmetry by procastination. -* - Do iIrrep = 1, nIrrep-1 - jx=ix - If (iAnd(iOper(iIrrep),1).ne.0) jx=nx-jx+1 - jy=iy - If (iAnd(iOper(iIrrep),2).ne.0) jy=ny-jy+1 - jz=iz - If (iAnd(iOper(iIrrep),4).ne.0) jz=nz-jz+1 -* - jyz = (jz -1)*ny + jy - jxyz= (jyz-1)*nx + jx -C If (jxyz.gt.iSB) Go To 777 - If (jxyz.gt.iSB) Go To 100 ! go for the next task. - End Do -* - End If - Debug=.False. -C If (iSB.eq.58) Debug=.True. -C Debug=.True. - If (Debug) Write (6,*) 'DrvNQ_: iSB=',iSB -* * -************************************************************************ -* * -*-----Here the List_S is the list of all the complete shells for -* the whole system. -* - Call Get_Subblock(Kernel,Func,iSB, - & Maps2p,list_s,list_exp,list_bas,nShell,nSym, - & list_p,nNQ,FckInt,nFckDim,nFckInt,nD, - & mGrid,nP2_ontop,Do_Mo, - & Do_Grad,Grad,nGrad, - & mAO,mdRho_dR, - & EG_OT,nTmpPUVX,PDFTPot1,PDFTFocI,PDFTFocA) -* * -************************************************************************ -* * - Go To 100 ! go back and try to do another task -C777 Continue -C End Do ! number_of_subblocks - 200 Continue ! Done! - Call Free_Tsk(id) - - -* * -************************************************************************ -* * -*---- Scale result with respect to the degeneracy of the grid points -* - If (nIrrep.ne.1.and.Check(iOpt_Angular,3)) Then -* - Func = DBLE(nIrrep)*Func - Funcaa = DBLE(nIrrep)*Funcaa - Funcbb = DBLE(nIrrep)*Funcbb - Funccc = DBLE(nIrrep)*Funccc - Dens_I = DBLE(nIrrep)*Dens_I - Dens_a1 = DBLE(nIrrep)*Dens_a1 - Dens_b1 = DBLE(nIrrep)*Dens_b1 - Dens_a2 = DBLE(nIrrep)*Dens_a2 - Dens_b2 = DBLE(nIrrep)*Dens_b2 - Dens_t1 = DBLE(nIrrep)*Dens_t1 - Dens_t2 = DBLE(nIrrep)*Dens_t2 - Grad_I = DBLE(nIrrep)*Grad_I - Tau_I = DBLE(nIrrep)*Tau_I -* - Call DScal_(nFckInt*nFckDim,DBLE(nIrrep),FckInt,1) -* - End If - -* * -************************************************************************ -* * -*---- Free memory associated with the density -* - Call Free_DeDe_Funi() -* -*---- Free memory for angular grids -* - Call Close_Info_Ang() -* * -************************************************************************ -* * -*#define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Debug=.True. - If (Debug.and..Not.Do_Grad) Then - Write (6,*) 'Func=',Func - iOff=1 - Do iIrrep=0,nIrrep-1 - nB=nBas(iIrrep) - If (nB.gt.0) Then - Call TriPrt('Final FckInt(Alpha)',' ',FckInt(iOff,1),nB) - lB=nB*(nB+1)/2 - iOff = iOff + lB - End If - End Do - If (nD.eq.1) Go To 98 - iOff=1 - Do iIrrep=0,nIrrep-1 - nB=nBas(iIrrep) - If (nB.gt.0) Then - Call TriPrt('Final FckInt(Beta)',' ',FckInt(iOff,2),nB) - lB=nB*(nB+1)/2 - iOff = iOff + lB - End If - End Do - 98 Continue - End If -#endif - - IF(l_casdft) THEN - CALL mma_deallocate(D1Unzip) - CALL mma_deallocate(P2Unzip) - END IF -* * -************************************************************************ -* * -* For parallel implementation syncronize here! -* -* Data to be syncronized: FckInt, Func, Dens, and Grad. -* -* - l_tgga = .true. - If (Do_Grad) Then - Call GADSum(Grad,nGrad) - Else - Call GADSum_SCAL(Func) - Call GADSum_SCAL(Funcaa) - Call GADSum_SCAL(Funcbb) - Call GADSum_SCAL(Funccc) - Call GADSum_SCAL(Dens_I) - Call GADSum_SCAL(Dens_t1) - Call GADSum_SCAL(Dens_t2) - Call GADSum_SCAL(Dens_a1) - Call GADSum_SCAL(Dens_a2) - Call GADSum_SCAL(Dens_b1) - Call GADSum_SCAL(Dens_b2) - Call GADSum_SCAL(Grad_I) - Call GADSum_SCAL(Tau_I) - Call GADSum(FckInt,nFckInt*nD) - If(l_casdft.and.do_pdftPot) then - Call GADSum(OE_OT,nFckInt) - Call GADSum(EG_OT,nTmpPUVX) - Call GADSum(FI_V,nFckInt) - Call GADSum(FA_V,nFckInt) - if(l_tgga) then - CALL GADSum(PDFTPot1,nPot1) - CALL GADSum(PDFTFocI,nPot1) - CALL GADSum(PDFTFocA,nPot1) - end if - End If - End If -* * -************************************************************************ -* * - If(l_casdft.and.do_pdftPot) then - - - If(l_tgga) Then - CALL PackPot1(OE_OT,PDFTPot1,nFckInt,dble(nIrrep)*0.5d0) - CALL DScal_(nPot2,dble(nIrrep),EG_OT,1) - CALL PackPot1(FI_V,PDFTFocI,nFckInt,dble(nIrrep)*0.25d0) - CALL PackPot1(FA_V,PDFTFocA,nFckInt,dble(nIrrep)*0.5d0) - End If - Call Put_dArray('ONTOPO',OE_OT,nFckInt) - Call Put_dArray('ONTOPT',EG_OT,nTmpPUVX) - Call Put_dArray('FI_V',FI_V,nFckInt) - Call Put_dArray('FA_V',FA_V,nFckInt) - - End If - Call mma_deallocate(OE_OT) - Call mma_deallocate(EG_OT) - Call mma_deallocate(FA_V) - Call mma_deallocate(FI_V) - CALL mma_deallocate(PDFTPot1) - CALL mma_deallocate(PDFTFocI) - CALL mma_deallocate(PDFTFocA) - - IF(debug. and. l_casdft) THEN - write(6,*) 'Dens_I in drvnq_ :', Dens_I - write(6,*) 'Dens_a1 in drvnq_ :', Dens_a1 - write(6,*) 'Dens_b1 in drvnq_ :', Dens_b1 - write(6,*) 'Dens_a2 in drvnq_ :', Dens_a2 - write(6,*) 'Dens_b2 in drvnq_ :', Dens_b2 - write(6,*) 'Dens_t1 in drvnq_ :', Dens_t1 - write(6,*) 'Dens_t2 in drvnq_ :', Dens_t2 - write(6,*) 'Func in drvnq_ :', Func - write(6,*) 'Funcaa in drvnq_ :', Funcaa - write(6,*) 'Funcbb in drvnq_ :', Funcbb - write(6,*) 'Funccc in drvnq_ :', Funccc -* -* Close these files... - Close(LuMC) - Close(LuMT) - END IF - - Return - End diff -Nru openmolcas-22.02/src/nq_util/drvnq_inner.F90 openmolcas-22.10/src/nq_util/drvnq_inner.F90 --- openmolcas-22.02/src/nq_util/drvnq_inner.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/drvnq_inner.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,359 @@ +!********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1999, Roland Lindh * +!*********************************************************************** + +subroutine DrvNQ_Inner(Kernel,Func,Maps2p,nSym,list_s,list_exp,list_bas,nShell,list_p,nNQ,FckInt,nFckDim,Density,nFckInt,nD,mGrid, & + nP2_ontop,Do_Mo,nTmpPUVX,Do_Grad,Grad,nGrad,mAO,mdRho_dR) +!*********************************************************************** +! * +! Object: Driver for numerical quadrature. * +! * +! Author: Roland Lindh, * +! Dept of Chemical Physics, * +! University of Lund, Sweden * +! August 1999 * +!*********************************************************************** + +use Symmetry_Info, only: nIrrep, iOper +use KSDFT_Info, only: do_pdftpot, FA_time, FI_time, Funcaa, Funcbb, Funccc, PUVX_time, sp_time +use nq_Grid, only: l_casdft, D1UnZip, P2UnZip +use nq_MO, only: D1MO, P2MO +use nq_Structure, only: Close_Info_Ang +use nq_Info, only: Dens_a1, Dens_a2, Dens_b1, Dens_b2, Dens_I, Dens_t1, Dens_t2, Grad_I, iOpt_Angular, NASHT, nPot1, nPot2, & + number_of_subblocks, nx, ny, nz, Tau_I +use Grid_On_Disk, only: Grid_Status, GridInfo, Regenerate +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, Half, Quart +use Definitions, only: wp, iwp +!#define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +use Basis_Info, only: nBas +use KSDFT_Info, only: KSDFA, LuMC, LuMT +use Definitions, only: u6 +#endif + +implicit none +external :: Kernel +integer(kind=iwp), intent(in) :: nShell, nSym, Maps2p(nShell,0:nSym-1), nNQ, nFckDim, nFckInt, nD, mGrid, nP2_ontop, nTmpPUVX, & + nGrad, mAO, mdRho_dR +integer(kind=iwp), intent(out) :: list_s(nSym*nShell), list_exp(nSym*nShell), list_bas(2,nSym*nShell), list_p(nNQ) +real(kind=wp), intent(inout) :: Func, FckInt(nFckInt,nFckDim), Grad(nGrad) +real(kind=wp), intent(in) :: Density(nFckInt,nD) +logical(kind=iwp), intent(in) :: Do_Mo, Do_Grad +integer(kind=iwp) :: id, iIrrep, iSB, ix, iy, iyz, iz, jx, jxyz, jy, jyz, jz +logical(kind=iwp) :: l_tgga +real(kind=wp), allocatable :: EG_OT(:), FA_V(:), FI_V(:), OE_OT(:), PDFTFocA(:), PDFTFocI(:), PDFTPot1(:) +#ifdef _DEBUGPRINT_ +logical(kind=iwp) :: Exists +#endif +logical(kind=iwp), external :: Rsv_Tsk + +!*********************************************************************** +! Initializations for MC-PDFT * +!*********************************************************************** +!*********************************************************************** +! Open file for MC-PDFT to store density, pair density and ratio: * +! ratio = 4pi/rho^2 * +!*********************************************************************** +if (l_casdft) then + + PUVX_Time = Zero + FA_Time = Zero + sp_time = Zero + FI_time = Zero + +# ifdef _DEBUGPRINT_ + LuMC = 37 + call OpnFl('MCPDFT',LuMC,Exists) + !call append_file(LuMC) + write(LuMC,'(A)') ' Here densities are MCPDFT modified ones.' + write(LuMC,*) ' Used by translated functional: ',KSDFA(1:8) + write(LuMC,'(A)') ' X , Y , Z , d_a*W , d_b*W , dTot*W , Weights ,'// & + ' dTot , P2 , ratio' + LuMT = 37 + call OpnFl('MCTRUD',LuMT,Exists) + !call append_file(LuMT) + write(LuMT,'(A)') ' Here densities are original ones.' + write(LuMT,*) ' Used by translated functional: ',KSDFA(1:8) + write(LuMT,'(A)') ' X , Y , Z , d_a*W , d_b*W , dTot*W , Weights ,'// & + ' dTot ' +# endif + + call CalcOrbOff() + call mma_allocate(P2Unzip,NASHT,NASHT,NASHT,NASHT) + call mma_allocate(D1Unzip,NASHT,NASHT) + call UnzipD1(D1Unzip,D1MO,size(D1MO)) + call UnzipP2(P2Unzip,P2MO,size(P2MO)) +end if +!*********************************************************************** +! +! Desymmetrize the 1-particle density matrix + +call Allok2_Funi(nD) +call DeDe_Funi(Density,nFckInt,nD) + +if (l_casdft .and. do_pdftPot) then + call mma_allocate(PDFTPot1,nPot1) + call mma_allocate(PDFTFocI,nPot1) + call mma_allocate(PDFTFocA,nPot1) + call mma_allocate(OE_OT,nFckInt,Label='OE_OT') + call mma_allocate(EG_OT,nTmpPUVX,Label='EG_OT') + call mma_allocate(FI_V,nFckInt,Label='FI_V') + call mma_allocate(FA_V,nFckInt,Label='FA_V') + + OE_OT(:) = Zero + EG_OT(:) = Zero + FI_V(:) = Zero + FA_V(:) = Zero + PDFTPot1(:) = Zero + PDFTFocI(:) = Zero + PDFTFocA(:) = Zero + call CalcPUVXOff() +else + nPot1 = 1 + call mma_allocate(OE_OT,nPot1,Label='OE_OT') + call mma_allocate(EG_OT,nPot1,Label='EG_OT') + call mma_allocate(FI_V,nPot1,Label='FI_V') + call mma_allocate(FA_V,nPot1,Label='FA_V') + call mma_allocate(PDFTPot1,nPot1) + call mma_allocate(PDFTFocI,nPot1) + call mma_allocate(PDFTFocA,nPot1) +end if +! * +!*********************************************************************** +! * +! For a parallel implementation the iterations over +! subblocks are parallelized. + +call Init_Tsk(id,number_of_subblocks) ! Initialize parallelization + +! Loop over subblocks + +iSB = 0 +!do iSB=1,number_of_subblocks + +! Start of parallelized loop here! + +outer: do + if (Grid_Status == Regenerate) then + ! Try to get an iSB to execute. If fail: done and branch out! + if (.not. Rsv_Tsk(id,iSB)) exit outer + else + ! Try to find a subblock which was generated by this processor. + iSB = iSB+1 + if (iSB > number_of_subblocks) exit outer + if (GridInfo(2,iSB) == 0) cycle outer + end if + ! * + !********************************************************************* + ! * + ! Eliminate redundant subblocks in case of symmetry. + ! This is only done for the Lebedev grids! + + if ((nIrrep /= 1) .and. btest(iOpt_Angular,2)) then + + ! Resolve triplet index + + iyz = 1+(iSB-1)/nx + ix = iSB-(iyz-1)*nx + iz = 1+(iyz-1)/ny + iy = iyz-(iz-1)*ny + + ! Do symmetry by procrastination. + + do iIrrep=1,nIrrep-1 + jx = ix + if (btest(iOper(iIrrep),0)) jx = nx-jx+1 + jy = iy + if (btest(iOper(iIrrep),1)) jy = ny-jy+1 + jz = iz + if (btest(iOper(iIrrep),2)) jz = nz-jz+1 + + jyz = (jz-1)*ny+jy + jxyz = (jyz-1)*nx+jx + !if (jxyz > iSB) exit outer + if (jxyz > iSB) cycle outer ! go for the next task. + end do + + end if +# ifdef _DEBUGPRINT_ + write(u6,*) 'DrvNQ_Inner: iSB=',iSB +# endif + ! * + !********************************************************************* + ! * + ! Here the List_S is the list of all the complete shells for + ! the whole system. + + call Get_Subblock(Kernel,Func,iSB,Maps2p,list_s,list_exp,list_bas,nShell,nSym,list_p,nNQ,FckInt,nFckDim,nFckInt,nD,mGrid, & + nP2_ontop,Do_Mo,Do_Grad,Grad,nGrad,mAO,mdRho_dR,EG_OT,nTmpPUVX,PDFTPot1,PDFTFocI,PDFTFocA) + ! go back and try to do another task +end do outer +!end do ! number_of_subblocks +! * +!*********************************************************************** +! * +call Free_Tsk(id) + +! * +!*********************************************************************** +! * +! Scale result with respect to the degeneracy of the grid points + +if ((nIrrep /= 1) .and. btest(iOpt_Angular,2)) then + + Func = real(nIrrep,kind=wp)*Func + Funcaa = real(nIrrep,kind=wp)*Funcaa + Funcbb = real(nIrrep,kind=wp)*Funcbb + Funccc = real(nIrrep,kind=wp)*Funccc + Dens_I = real(nIrrep,kind=wp)*Dens_I + Dens_a1 = real(nIrrep,kind=wp)*Dens_a1 + Dens_b1 = real(nIrrep,kind=wp)*Dens_b1 + Dens_a2 = real(nIrrep,kind=wp)*Dens_a2 + Dens_b2 = real(nIrrep,kind=wp)*Dens_b2 + Dens_t1 = real(nIrrep,kind=wp)*Dens_t1 + Dens_t2 = real(nIrrep,kind=wp)*Dens_t2 + Grad_I = real(nIrrep,kind=wp)*Grad_I + Tau_I = real(nIrrep,kind=wp)*Tau_I + + FckInt(:,:) = real(nIrrep,kind=wp)*FckInt(:,:) + +end if + +! * +!*********************************************************************** +! * +! Free memory associated with the density + +call Free_DeDe_Funi() + +! Free memory for angular grids + +call Close_Info_Ang() +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +if (.not. Do_Grad) then + write(u6,*) 'Func=',Func + iOff = 1 + do iIrrep=0,nIrrep-1 + nB = nBas(iIrrep) + if (nB > 0) then + call TriPrt('Final FckInt(Alpha)',' ',FckInt(iOff,1),nB) + lB = nB*(nB+1)/2 + iOff = iOff+lB + end if + end do + if (nD /= 1) then + iOff = 1 + do iIrrep=0,nIrrep-1 + nB = nBas(iIrrep) + if (nB > 0) then + call TriPrt('Final FckInt(Beta)',' ',FckInt(iOff,2),nB) + lB = nB*(nB+1)/2 + iOff = iOff+lB + end if + end do + end if +end if +#endif + +if (l_casdft) then + call mma_deallocate(D1Unzip) + call mma_deallocate(P2Unzip) +end if +! * +!*********************************************************************** +! * +! For parallel implementation synchronize here! +! +! Data to be synchronized: FckInt, Func, Dens, and Grad. + +l_tgga = .true. +if (Do_Grad) then + call GADSum(Grad,nGrad) +else + call GADSum_SCAL(Func) + call GADSum_SCAL(Funcaa) + call GADSum_SCAL(Funcbb) + call GADSum_SCAL(Funccc) + call GADSum_SCAL(Dens_I) + call GADSum_SCAL(Dens_t1) + call GADSum_SCAL(Dens_t2) + call GADSum_SCAL(Dens_a1) + call GADSum_SCAL(Dens_a2) + call GADSum_SCAL(Dens_b1) + call GADSum_SCAL(Dens_b2) + call GADSum_SCAL(Grad_I) + call GADSum_SCAL(Tau_I) + call GADSum(FckInt,nFckInt*nD) + if (l_casdft .and. do_pdftPot) then + call GADSum(OE_OT,nFckInt) + call GADSum(EG_OT,nTmpPUVX) + call GADSum(FI_V,nFckInt) + call GADSum(FA_V,nFckInt) + if (l_tgga) then + call GADSum(PDFTPot1,nPot1) + call GADSum(PDFTFocI,nPot1) + call GADSum(PDFTFocA,nPot1) + end if + end if +end if +! * +!*********************************************************************** +! * +if (l_casdft .and. do_pdftPot) then + + if (l_tgga) then + call PackPot1(OE_OT,PDFTPot1,nFckInt,real(nIrrep,kind=wp)*Half) + EG_OT(1:nPot2) = real(nIrrep,kind=wp)*EG_OT(1:nPot2) + call PackPot1(FI_V,PDFTFocI,nFckInt,real(nIrrep,kind=wp)*Quart) + call PackPot1(FA_V,PDFTFocA,nFckInt,real(nIrrep,kind=wp)*Half) + end if + call Put_dArray('ONTOPO',OE_OT,nFckInt) + call Put_dArray('ONTOPT',EG_OT,nTmpPUVX) + call Put_dArray('FI_V',FI_V,nFckInt) + call Put_dArray('FA_V',FA_V,nFckInt) + +end if +call mma_deallocate(OE_OT) +call mma_deallocate(EG_OT) +call mma_deallocate(FA_V) +call mma_deallocate(FI_V) +call mma_deallocate(PDFTPot1) +call mma_deallocate(PDFTFocI) +call mma_deallocate(PDFTFocA) + +#ifdef _DEBUGPRINT_ +if (l_casdft) then + write(u6,*) 'Dens_I in DrvNQ_Inner :',Dens_I + write(u6,*) 'Dens_a1 in DrvNQ_Inner :',Dens_a1 + write(u6,*) 'Dens_b1 in DrvNQ_Inner :',Dens_b1 + write(u6,*) 'Dens_a2 in DrvNQ_Inner :',Dens_a2 + write(u6,*) 'Dens_b2 in DrvNQ_Inner :',Dens_b2 + write(u6,*) 'Dens_t1 in DrvNQ_Inner :',Dens_t1 + write(u6,*) 'Dens_t2 in DrvNQ_Inner :',Dens_t2 + write(u6,*) 'Func in DrvNQ_Inner :',Func + write(u6,*) 'Funcaa in DrvNQ_Inner :',Funcaa + write(u6,*) 'Funcbb in DrvNQ_Inner :',Funcbb + write(u6,*) 'Funccc in DrvNQ_Inner :',Funccc + + ! Close these files... + close(LuMC) + close(LuMT) +end if +#endif + +return + +end subroutine DrvNQ_Inner diff -Nru openmolcas-22.02/src/nq_util/dwdr.f openmolcas-22.10/src/nq_util/dwdr.f --- openmolcas-22.02/src/nq_util/dwdr.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/dwdr.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,312 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine dWdR(R,ilist_p,Weights,list_p,nlist_p, - & dW_dR,nGrad_Eff,iTab,dW_Temp,dPB,nGrid) - use nq_Grid, only: Pax - use NQ_Structure, only: NQ_data - use nq_Info - Implicit Real*8 (a-h,o-z) -#include "real.fh" -#include "itmax.fh" -#include "debug.fh" - Real*8 R(3,nGrid), Weights(nGrid), dW_dR(nGrad_Eff,nGrid), - & dW_Temp(3,nlist_p), dPB(3,nlist_p,nlist_p), sxyz(3), - & dOdxs(3), Osxyz(3) - Integer list_p(nlist_p), iTab(4,nGrad_Eff) -* * -************************************************************************ -* * - p(x)=(x*0.5D0)*(3.0D0-x**2) -* * -************************************************************************ -* * -* iNQ is the index of the current atomic grid to which these grid -* points belong. -* - iNQ=list_p(ilist_p) - iA=ilist_p - O11=Pax(1,1) - O12=Pax(2,1) - O13=Pax(3,1) - O21=Pax(1,2) - O22=Pax(2,2) - O23=Pax(3,2) - O31=Pax(1,3) - O32=Pax(2,3) - O33=Pax(3,3) -* * -************************************************************************ -* * - Do iGrid = 1, nGrid - Call FZero(dW_dR(1,iGrid),nGrad_Eff) -* * -************************************************************************ -* * -*------- The current grid point is associated with center A and the -* "atomic" displacement vector relative to center A is computed. -* - Osxyz(:) = R(:,iGrid)-NQ_data(iNQ)%Coor(:) -* - sxyz(1)=O11*Osxyz(1)+O12*Osxyz(2)+O13*Osxyz(3) - sxyz(2)=O21*Osxyz(1)+O22*Osxyz(2)+O23*Osxyz(3) - sxyz(3)=O31*Osxyz(1)+O32*Osxyz(2)+O33*Osxyz(3) -* - Z=Zero - Call FZero(dPB,3*nlist_p**2) -* -* Compute all P_B and corresponding derivatives. -* -C P_A=Zero - P_A=One ! Dummy set - Do iiB = 1, nlist_p - If (iiB.eq.1) Then - iB = iA - Else If (iiB.eq.iA) Then - iB = 1 - Else - iB = iiB - End If -* - kNQ=list_p(iB) - r_Bx=R(1,iGrid)-NQ_Data(kNQ)%Coor(1) - r_By=R(2,iGrid)-NQ_Data(kNQ)%Coor(2) - r_Bz=R(3,iGrid)-NQ_Data(kNQ)%Coor(3) - r_B=sqrt(r_Bx**2+r_By**2+r_Bz**2) -* -* loop over C=/=B for all s(mu_BC), see Eq. B3 -* - P_B=One - Do iC = 1, nlist_p -* - If (iC.ne.iB) Then - lNQ=list_p(iC) - r_Cx=R(1,iGrid)-NQ_Data(lNQ)%Coor(1) - r_Cy=R(2,iGrid)-NQ_Data(lNQ)%Coor(2) - r_Cz=R(3,iGrid)-NQ_Data(lNQ)%Coor(3) - r_C=sqrt(r_Cx**2+r_Cy**2+r_Cz**2) - R_BCx=NQ_Data(kNQ)%Coor(1)-NQ_Data(lNQ)%Coor(1) - R_BCy=NQ_Data(kNQ)%Coor(2)-NQ_Data(lNQ)%Coor(2) - R_BCz=NQ_Data(kNQ)%Coor(3)-NQ_Data(lNQ)%Coor(3) - R_BC=sqrt(R_BCx**2+R_BCy**2+R_BCz**2) -* -* Eq. B6 -* - rMU_BC=(r_B-r_C)/R_BC - If (rMU_BC.le.0.5D0) Then - p1=p(rMU_BC) - p2=p(p1) - p3=p(p2) -* -* Eq. B4 -* - s_MU_BC=Half*(One-p3) -* - P_B=P_B*s_MU_BC - If (P_B.le.1.0D-20) Go To 99 - tMU_BC=-27D0*(One-p2**2) - & *(One-p1**2) - & *(One-rMU_BC**2) - & /(16d0*Max(s_MU_BC,1.0D-99)) - Else - xdiff0=rMU_BC-1.0D0 - xdiff1=(-1.5D0-0.5D0*xdiff0)*xdiff0**2 - xdiff2=(-1.5D0-0.5D0*xdiff1)*xdiff1**2 - p3= ( 1.5D0+0.5D0*xdiff2)*xdiff2**2 - s_MU_BC=Half*p3 -* - P_B=P_B*s_MU_BC - If (P_B.le.1.0D-20) Go To 99 - tMU_BC= 27D0*(2.0D0+xdiff2)*xdiff2 - & *(2.0D0+xdiff1)*xdiff1 - & *(2.0D0+xdiff0)*xdiff0 - & /(16d0*Max(s_MU_BC,1.0D-99)) - End If -* -*---------------- Differentiate mu_BC with respect to the center, D. -* - Do iD = 1, nlist_p -C jNQ=list_p(iD) -* - If (iD.eq.iB) Then -* -* d mu_BC(r_A) / dB, Eq. B10 -* - If (r_B.eq.Zero) Then - dmu_BC_dBx = - & - (r_B-r_C)*R_BCx/R_BC**3 - dmu_BC_dBy = - & - (r_B-r_C)*R_BCy/R_BC**3 - dmu_BC_dBz = - & - (r_B-r_C)*R_BCz/R_BC**3 - Else - dmu_BC_dBx = -r_Bx/(r_B*R_BC) - & - (r_B-r_C)*R_BCx/R_BC**3 - dmu_BC_dBy = -r_By/(r_B*R_BC) - & - (r_B-r_C)*R_BCy/R_BC**3 - dmu_BC_dBz = -r_Bz/(r_B*R_BC) - & - (r_B-r_C)*R_BCz/R_BC**3 - End If -* - dPB(1,iB,iB)=dPB(1,iB,iB) + tMU_BC*dmu_BC_dBx - dPB(2,iB,iB)=dPB(2,iB,iB) + tMU_BC*dmu_BC_dBy - dPB(3,iB,iB)=dPB(3,iB,iB) + tMU_BC*dmu_BC_dBz -* - Else If (iD.eq.iC) Then -* -* d mu_BC(r_A) / dC, Eq, B10 -* - If (r_C.eq.Zero) Then - dmu_BC_dCx = - & + (r_B-r_C)*R_BCx/R_BC**3 - dmu_BC_dCy = - & + (r_B-r_C)*R_BCy/R_BC**3 - dmu_BC_dCz = - & + (r_B-r_C)*R_BCz/R_BC**3 - Else - dmu_BC_dCx = r_Cx/(r_C*R_BC) - & + (r_B-r_C)*R_BCx/R_BC**3 - dmu_BC_dCy = r_Cy/(r_C*R_BC) - & + (r_B-r_C)*R_BCy/R_BC**3 - dmu_BC_dCz = r_Cz/(r_C*R_BC) - & + (r_B-r_C)*R_BCz/R_BC**3 - End If - dPB(1,iC,iB)=dPB(1,iC,iB) + tMU_BC*dmu_BC_dCx - dPB(2,iC,iB)=dPB(2,iC,iB) + tMU_BC*dmu_BC_dCy - dPB(3,iC,iB)=dPB(3,iC,iB) + tMU_BC*dmu_BC_dCz -* - End If -* -* d mu_BC(r_A) / dr_A -* - If (r_B.eq.Zero) Then - dmu_BC_dAx = ( - r_Cx/r_C)/R_BC - dmu_BC_dAy = ( - r_Cy/r_C)/R_BC - dmu_BC_dAz = ( - r_Cz/r_C)/R_BC - Else If (r_C.eq.Zero) Then - dmu_BC_dAx = (r_Bx/r_B )/R_BC - dmu_BC_dAy = (r_By/r_B )/R_BC - dmu_BC_dAz = (r_Bz/r_B )/R_BC - Else - dmu_BC_dAx = (r_Bx/r_B - r_Cx/r_C)/R_BC - dmu_BC_dAy = (r_By/r_B - r_Cy/r_C)/R_BC - dmu_BC_dAz = (r_Bz/r_B - r_Cz/r_C)/R_BC - End If -* - If (iD.eq.iA) Then -* -* The direct term -* - dPB(1,iA,iB)=dPB(1,iA,iB) + tMU_BC*dmu_BC_dAx - dPB(2,iA,iB)=dPB(2,iA,iB) + tMU_BC*dmu_BC_dAy - dPB(3,iA,iB)=dPB(3,iA,iB) + tMU_BC*dmu_BC_dAz -* - End If -* - jNQ=list_p(iD) - Do iCar = 1, 3 - dOdx_11= NQ_Data(jNQ)%dOdx(1,1,iCar) - dOdx_21= NQ_Data(jNQ)%dOdx(2,1,iCar) - dOdx_31= NQ_Data(jNQ)%dOdx(3,1,iCar) - dOdx_12= NQ_Data(jNQ)%dOdx(1,2,iCar) - dOdx_22= NQ_Data(jNQ)%dOdx(2,2,iCar) - dOdx_32= NQ_Data(jNQ)%dOdx(3,2,iCar) - dOdx_13= NQ_Data(jNQ)%dOdx(1,3,iCar) - dOdx_23= NQ_Data(jNQ)%dOdx(2,3,iCar) - dOdx_33= NQ_Data(jNQ)%dOdx(3,3,iCar) - dOdxs(1)=dOdx_11*sxyz(1) - & +dOdx_12*sxyz(2) - & +dOdx_13*sxyz(3) - dOdxs(2)=dOdx_21*sxyz(1) - & +dOdx_22*sxyz(2) - & +dOdx_23*sxyz(3) - dOdxs(3)=dOdx_31*sxyz(1) - & +dOdx_32*sxyz(2) - & +dOdx_33*sxyz(3) - temp = tMU_BC*(dmu_BC_dAx*dOdxs(1) - & +dmu_BC_dAy*dOdxs(2) - & +dmu_BC_dAz*dOdxs(3)) -* - dPB(iCar,iD,iB) = dPB(iCar,iD,iB) - temp - End Do -* - End Do ! iD -* - End If - End Do ! iC -* - 99 Continue -* -* Multiply derivatives with P_B as in Eq. B8 -* - Do iD = 1, nlist_p - dPB(1,iD,iB)=P_B*dPB(1,iD,iB) - dPB(2,iD,iB)=P_B*dPB(2,iD,iB) - dPB(3,iD,iB)=P_B*dPB(3,iD,iB) - End Do -* - If (iB.eq.iA) P_A=P_B - If (P_A.le.1.0D-20) Go To 98 -* -* Denominator Eq. B2 - Z = Z + P_B - End Do ! iB -* - If (P_A.eq.Zero) Then - Fact=Zero - Else - Fact = Weights(iGrid)*Z/P_A - End If -* * -************************************************************************ -* * -*------- Assemble the gradient -* - Do iB = 1, nlist_p -* - dZ_dBx=Zero - dZ_dBy=Zero - dZ_dBz=Zero - Do iC = 1, nlist_p - dZ_dBx=dZ_dBx+dPB(1,iB,iC) - dZ_dBy=dZ_dBy+dPB(2,iB,iC) - dZ_dBz=dZ_dBz+dPB(3,iB,iC) - End Do -* -* Eq. B7 -* - dW_Temp(1,iB) = dPB(1,iB,iA)/Z - (P_A*dZ_dBx)/Z**2 - dW_Temp(2,iB) = dPB(2,iB,iA)/Z - (P_A*dZ_dBy)/Z**2 - dW_Temp(3,iB) = dPB(3,iB,iA)/Z - (P_A*dZ_dBz)/Z**2 - End Do -* * -************************************************************************ -* * -* Pick up the relevant gradients -* - Do iGrad = 1, nGrad_Eff - iCar=iTab(1,iGrad) - kNQ =iTab(3,iGrad) - Fact0=Fact - Do iB = 1, nlist_p - lNQ=list_p(iB) - If (kNQ.eq.lNQ) dW_dR(iGrad,iGrid)=Fact0*dW_Temp(iCar,iB) - End Do - End Do -* * -************************************************************************ -* * - 98 Continue - End Do ! iGrid -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/dwdr.F90 openmolcas-22.10/src/nq_util/dwdr.F90 --- openmolcas-22.02/src/nq_util/dwdr.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/dwdr.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,288 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine dWdR(R,ilist_p,Weights,list_p,nlist_p,dW_dR,nGrad_Eff,iTab,dW_Temp,dPB,nGrid) + +use NQ_Structure, only: NQ_data +use nq_Grid, only: Pax +use Constants, only: Zero, One, Two, Three, Half, OneHalf +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: ilist_p, nlist_p, list_p(nlist_p), nGrad_Eff, iTab(4,nGrad_Eff), nGrid +real(kind=wp), intent(in) :: R(3,nGrid), Weights(nGrid) +real(kind=wp), intent(out) :: dW_dR(nGrad_Eff,nGrid), dW_Temp(3,nlist_p), dPB(3,nlist_p,nlist_p) +integer(kind=iwp) :: iA, iB, iC, iCar, iD, iGrad, iGrid, iiB, iNQ, jNQ, kNQ, lNQ +real(kind=wp) :: dmu_BC_dAx, dmu_BC_dAy, dmu_BC_dAz, dmu_BC_dBx, dmu_BC_dBy, dmu_BC_dBz, dmu_BC_dCx, dmu_BC_dCy, dmu_BC_dCz, & + dOdx_11, dOdx_12, dOdx_13, dOdx_21, dOdx_22, dOdx_23, dOdx_31, dOdx_32, dOdx_33, dOdxs(3), dZ_dBx, dZ_dBy, & + dZ_dBz, Fact, Fact0, O11, O12, O13, O21, O22, O23, O31, O32, O33, Osxyz(3), p1, p2, p3, P_A, P_B, r_B, R_BC, & + R_BCx, R_BCy, R_BCz, r_Bx, r_By, r_Bz, r_C, r_Cx, r_Cy, r_Cz, rMU_BC, s_MU_BC, sxyz(3), temp, tMU_BC, xdiff0, & + xdiff1, xdiff2, Z +real(kind=wp), parameter :: Thrs = 1.0e-20_wp + +! * +!*********************************************************************** +! * +! iNQ is the index of the current atomic grid to which these grid +! points belong. + +iNQ = list_p(ilist_p) +iA = ilist_p +O11 = Pax(1,1) +O12 = Pax(2,1) +O13 = Pax(3,1) +O21 = Pax(1,2) +O22 = Pax(2,2) +O23 = Pax(3,2) +O31 = Pax(1,3) +O32 = Pax(2,3) +O33 = Pax(3,3) +! * +!*********************************************************************** +! * +do_grid: do iGrid=1,nGrid + dW_dR(:,iGrid) = Zero + ! * + !********************************************************************* + ! * + ! The current grid point is associated with center A and the + ! "atomic" displacement vector relative to center A is computed. + + Osxyz(:) = R(:,iGrid)-NQ_data(iNQ)%Coor(:) + + sxyz(1) = O11*Osxyz(1)+O12*Osxyz(2)+O13*Osxyz(3) + sxyz(2) = O21*Osxyz(1)+O22*Osxyz(2)+O23*Osxyz(3) + sxyz(3) = O31*Osxyz(1)+O32*Osxyz(2)+O33*Osxyz(3) + + Z = Zero + dPB(:,:,:) = Zero + + ! Compute all P_B and corresponding derivatives. + + !P_A = Zero + P_A = One ! Dummy set + do iiB=1,nlist_p + if (iiB == 1) then + iB = iA + else if (iiB == iA) then + iB = 1 + else + iB = iiB + end if + + kNQ = list_p(iB) + r_Bx = R(1,iGrid)-NQ_Data(kNQ)%Coor(1) + r_By = R(2,iGrid)-NQ_Data(kNQ)%Coor(2) + r_Bz = R(3,iGrid)-NQ_Data(kNQ)%Coor(3) + r_B = sqrt(r_Bx**2+r_By**2+r_Bz**2) + + ! loop over C=/=B for all s(mu_BC), see Eq. B3 + + P_B = One + do iC=1,nlist_p + + if (iC /= iB) then + lNQ = list_p(iC) + r_Cx = R(1,iGrid)-NQ_Data(lNQ)%Coor(1) + r_Cy = R(2,iGrid)-NQ_Data(lNQ)%Coor(2) + r_Cz = R(3,iGrid)-NQ_Data(lNQ)%Coor(3) + r_C = sqrt(r_Cx**2+r_Cy**2+r_Cz**2) + R_BCx = NQ_Data(kNQ)%Coor(1)-NQ_Data(lNQ)%Coor(1) + R_BCy = NQ_Data(kNQ)%Coor(2)-NQ_Data(lNQ)%Coor(2) + R_BCz = NQ_Data(kNQ)%Coor(3)-NQ_Data(lNQ)%Coor(3) + R_BC = sqrt(R_BCx**2+R_BCy**2+R_BCz**2) + + ! Eq. B6 + + rMU_BC = (r_B-r_C)/R_BC + if (rMU_BC <= Half) then + p1 = (rMU_BC*Half)*(Three-rMU_BC**2) + p2 = (p1*Half)*(Three-p1**2) + p3 = (p2*Half)*(Three-p2**2) + + ! Eq. B4 + + s_MU_BC = Half*(One-p3) + + P_B = P_B*s_MU_BC + if (P_B <= Thrs) exit + tMU_BC = -27.0_wp*(One-p2**2)*(One-p1**2)*(One-rMU_BC**2)/(16.0_wp*max(s_MU_BC,1.0e-99_wp)) + else + xdiff0 = rMU_BC-One + xdiff1 = (-OneHalf-Half*xdiff0)*xdiff0**2 + xdiff2 = (-OneHalf-Half*xdiff1)*xdiff1**2 + p3 = (OneHalf+Half*xdiff2)*xdiff2**2 + s_MU_BC = Half*p3 + + P_B = P_B*s_MU_BC + if (P_B <= Thrs) exit + tMU_BC = 27.0_wp*(Two+xdiff2)*xdiff2*(Two+xdiff1)*xdiff1*(Two+xdiff0)*xdiff0/(16.0_wp*max(s_MU_BC,1.0e-99_wp)) + end if + + ! Differentiate mu_BC with respect to the center, D. + + do iD=1,nlist_p + !jNQ = list_p(iD) + + if (iD == iB) then + + ! d mu_BC(r_A) / dB, Eq. B10 + + if (r_B == Zero) then + dmu_BC_dBx = -(r_B-r_C)*R_BCx/R_BC**3 + dmu_BC_dBy = -(r_B-r_C)*R_BCy/R_BC**3 + dmu_BC_dBz = -(r_B-r_C)*R_BCz/R_BC**3 + else + dmu_BC_dBx = -r_Bx/(r_B*R_BC)-(r_B-r_C)*R_BCx/R_BC**3 + dmu_BC_dBy = -r_By/(r_B*R_BC)-(r_B-r_C)*R_BCy/R_BC**3 + dmu_BC_dBz = -r_Bz/(r_B*R_BC)-(r_B-r_C)*R_BCz/R_BC**3 + end if + + dPB(1,iB,iB) = dPB(1,iB,iB)+tMU_BC*dmu_BC_dBx + dPB(2,iB,iB) = dPB(2,iB,iB)+tMU_BC*dmu_BC_dBy + dPB(3,iB,iB) = dPB(3,iB,iB)+tMU_BC*dmu_BC_dBz + + else if (iD == iC) then + + ! d mu_BC(r_A) / dC, Eq, B10 + + if (r_C == Zero) then + dmu_BC_dCx = +(r_B-r_C)*R_BCx/R_BC**3 + dmu_BC_dCy = +(r_B-r_C)*R_BCy/R_BC**3 + dmu_BC_dCz = +(r_B-r_C)*R_BCz/R_BC**3 + else + dmu_BC_dCx = r_Cx/(r_C*R_BC)+(r_B-r_C)*R_BCx/R_BC**3 + dmu_BC_dCy = r_Cy/(r_C*R_BC)+(r_B-r_C)*R_BCy/R_BC**3 + dmu_BC_dCz = r_Cz/(r_C*R_BC)+(r_B-r_C)*R_BCz/R_BC**3 + end if + dPB(1,iC,iB) = dPB(1,iC,iB)+tMU_BC*dmu_BC_dCx + dPB(2,iC,iB) = dPB(2,iC,iB)+tMU_BC*dmu_BC_dCy + dPB(3,iC,iB) = dPB(3,iC,iB)+tMU_BC*dmu_BC_dCz + + end if + + ! d mu_BC(r_A) / dr_A + + if (r_B == Zero) then + dmu_BC_dAx = (-r_Cx/r_C)/R_BC + dmu_BC_dAy = (-r_Cy/r_C)/R_BC + dmu_BC_dAz = (-r_Cz/r_C)/R_BC + else if (r_C == Zero) then + dmu_BC_dAx = (r_Bx/r_B)/R_BC + dmu_BC_dAy = (r_By/r_B)/R_BC + dmu_BC_dAz = (r_Bz/r_B)/R_BC + else + dmu_BC_dAx = (r_Bx/r_B-r_Cx/r_C)/R_BC + dmu_BC_dAy = (r_By/r_B-r_Cy/r_C)/R_BC + dmu_BC_dAz = (r_Bz/r_B-r_Cz/r_C)/R_BC + end if + + if (iD == iA) then + + ! The direct term + + dPB(1,iA,iB) = dPB(1,iA,iB)+tMU_BC*dmu_BC_dAx + dPB(2,iA,iB) = dPB(2,iA,iB)+tMU_BC*dmu_BC_dAy + dPB(3,iA,iB) = dPB(3,iA,iB)+tMU_BC*dmu_BC_dAz + + end if + + jNQ = list_p(iD) + do iCar=1,3 + dOdx_11 = NQ_Data(jNQ)%dOdx(1,1,iCar) + dOdx_21 = NQ_Data(jNQ)%dOdx(2,1,iCar) + dOdx_31 = NQ_Data(jNQ)%dOdx(3,1,iCar) + dOdx_12 = NQ_Data(jNQ)%dOdx(1,2,iCar) + dOdx_22 = NQ_Data(jNQ)%dOdx(2,2,iCar) + dOdx_32 = NQ_Data(jNQ)%dOdx(3,2,iCar) + dOdx_13 = NQ_Data(jNQ)%dOdx(1,3,iCar) + dOdx_23 = NQ_Data(jNQ)%dOdx(2,3,iCar) + dOdx_33 = NQ_Data(jNQ)%dOdx(3,3,iCar) + dOdxs(1) = dOdx_11*sxyz(1)+dOdx_12*sxyz(2)+dOdx_13*sxyz(3) + dOdxs(2) = dOdx_21*sxyz(1)+dOdx_22*sxyz(2)+dOdx_23*sxyz(3) + dOdxs(3) = dOdx_31*sxyz(1)+dOdx_32*sxyz(2)+dOdx_33*sxyz(3) + temp = tMU_BC*(dmu_BC_dAx*dOdxs(1)+dmu_BC_dAy*dOdxs(2)+dmu_BC_dAz*dOdxs(3)) + + dPB(iCar,iD,iB) = dPB(iCar,iD,iB)-temp + end do + + end do ! iD + + end if + end do ! iC + + ! Multiply derivatives with P_B as in Eq. B8 + + do iD=1,nlist_p + dPB(1,iD,iB) = P_B*dPB(1,iD,iB) + dPB(2,iD,iB) = P_B*dPB(2,iD,iB) + dPB(3,iD,iB) = P_B*dPB(3,iD,iB) + end do + + if (iB == iA) P_A = P_B + if (P_A <= Thrs) cycle do_grid + + ! Denominator Eq. B2 + Z = Z+P_B + end do ! iB + + if (P_A == Zero) then + Fact = Zero + else + Fact = Weights(iGrid)*Z/P_A + end if + ! * + !********************************************************************* + ! * + ! Assemble the gradient + + do iB=1,nlist_p + + dZ_dBx = Zero + dZ_dBy = Zero + dZ_dBz = Zero + do iC=1,nlist_p + dZ_dBx = dZ_dBx+dPB(1,iB,iC) + dZ_dBy = dZ_dBy+dPB(2,iB,iC) + dZ_dBz = dZ_dBz+dPB(3,iB,iC) + end do + + ! Eq. B7 + + dW_Temp(1,iB) = dPB(1,iB,iA)/Z-(P_A*dZ_dBx)/Z**2 + dW_Temp(2,iB) = dPB(2,iB,iA)/Z-(P_A*dZ_dBy)/Z**2 + dW_Temp(3,iB) = dPB(3,iB,iA)/Z-(P_A*dZ_dBz)/Z**2 + end do + ! * + !********************************************************************* + ! * + ! Pick up the relevant gradients + + do iGrad=1,nGrad_Eff + iCar = iTab(1,iGrad) + kNQ = iTab(3,iGrad) + Fact0 = Fact + do iB=1,nlist_p + lNQ = list_p(iB) + if (kNQ == lNQ) dW_dR(iGrad,iGrid) = Fact0*dW_Temp(iCar,iB) + end do + end do + ! * + !********************************************************************* + ! * +end do do_grid ! iGrid +! * +!*********************************************************************** +! * + +return + +end subroutine dWdR diff -Nru openmolcas-22.02/src/nq_util/eval_rmax.f openmolcas-22.10/src/nq_util/eval_rmax.f --- openmolcas-22.02/src/nq_util/eval_rmax.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/eval_rmax.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Function Eval_RMax(alpha,m,R_L) - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 Eval_RMax -* Write (6,*) 'alpha,m,R_L=', -* & alpha,m,R_L -* -* * -************************************************************************ -* * -*---- Compute r_k_H as a function of m and R_L -* -* Eq(19) R. Lindh, P.-A. Malmqvist, L. Gagliardi, -* TCA, 106:178-187 (2001) - - If (MOD(m+3,2).eq.0) Then - Gamma=One - Do i = 2, (m+3)/2, 1 - Gamma = Gamma * DBLE(i-1) - End Do - Else - Gamma=Sqrt(Pi) - Do i = 5, m+3, 2 - Gamma = Gamma * DBLE(i-1)/Two - End Do - End If -* -* x = Alpha * (r_k_H)**2 -* - x = 10.0D0 ! Start value - 123 Continue - x_new = LOG((Gamma/R_L)*x**(Half*(DBLE(m)+One))) -C Write (6,*) 'x,x_new=',x,x_new - If (ABS(x-x_new).gt.1.0D-8) Then - x=x_new - Go To 123 - End If -* - Eval_RMax=Sqrt(x/alpha) -C Write (*,*) 'Eval_RMax=',Eval_RMax -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/eval_rmax.F90 openmolcas-22.10/src/nq_util/eval_rmax.F90 --- openmolcas-22.02/src/nq_util/eval_rmax.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/eval_rmax.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,64 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +function Eval_RMax(alpha,m,R_L) + +use Constants, only: One, Ten, Half, Pi +use Definitions, only: wp, iwp + +implicit none +real(kind=wp) :: Eval_RMax +real(kind=wp), intent(in) :: alpha, R_L +integer(kind=iwp), intent(in) :: m +real(kind=wp) :: Gmma, x, x_new +integer(kind=iwp) :: i + +!write(u6,*) 'alpha,m,R_L=',alpha,m,R_L + +! * +!*********************************************************************** +! * +! Compute r_k_H as a function of m and R_L +! +! Eq(19) R. Lindh, P.-A. Malmqvist, L. Gagliardi, +! TCA, 106:178-187 (2001) + +if (mod(m+3,2) == 0) then + Gmma = One + do i=2,(m+3)/2,1 + Gmma = Gmma*real(i-1,kind=wp) + end do +else + Gmma = sqrt(Pi) + do i=5,m+3,2 + Gmma = Gmma*real(i-1,kind=wp)*Half + end do +end if + +!x = Alpha*(r_k_H)**2 + +x = Ten ! Start value +do + x_new = log((Gmma/R_L)*x**(Half*(real(m,kind=wp)+One))) + !write(u6,*) 'x,x_new=',x,x_new + if (abs(x-x_new) <= 1.0e-8_wp) exit + x = x_new +end do + +Eval_RMax = sqrt(x/alpha) +!write(u6,*) 'Eval_RMax=',Eval_RMax +! * +!*********************************************************************** +! * + +return + +end function Eval_RMax diff -Nru openmolcas-22.02/src/nq_util/eval_rmin.f openmolcas-22.10/src/nq_util/eval_rmin.f --- openmolcas-22.02/src/nq_util/eval_rmin.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/eval_rmin.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Function Eval_RMin(Alpha,m,R_H) - Implicit Real*8 (a-h,o-z) -#include "itmax.fh" -#include "real.fh" - Real*8 Eval_RMin, ln_x -* Write (6,*) 'Alpha,m,R_H=', -* & Alpha,m,R_H -* * -************************************************************************ -* * -*---- Compute r_1 as a function of m and R_H -* -* Eq(25) R. Lindh, P.-A. Malmqvist, L. Gagliardi, -* TCA, 106:178-187 (2001) -* - D_m=-4.0D0 - If (m.eq. 4) D_m=-2.3D0 - If (m.eq. 2) D_m=-1.0D0 - If (m.eq. 0) D_m= 1.9D0 - If (m.eq.-2) D_m= 9.1D0 -* -* x = alpha * (r_1)**2 -* - ln_x=(Two/(DBLE(m)+Three))*( D_m- LOG(One/R_H) ) -* - R_Min=Sqrt(Exp(ln_x)/Alpha) -* - Eval_RMin = R_Min -* Write (*,*) 'Eval_RMin=',Eval_RMin -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/eval_rmin.F90 openmolcas-22.10/src/nq_util/eval_rmin.F90 --- openmolcas-22.02/src/nq_util/eval_rmin.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/eval_rmin.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,52 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +function Eval_RMin(Alpha,m,R_H) + +use Constants, only: One, Two, Three, Four +use Definitions, only: wp, iwp + +implicit none +real(kind=wp) :: Eval_RMin +real(kind=wp), intent(in) :: Alpha, R_H +integer(kind=iwp), intent(in) :: m +real(kind=wp) :: D_m, ln_x, R_Min + +!write(u6,*) 'Alpha,m,R_H=',Alpha,m,R_H +! * +!*********************************************************************** +! * +! Compute r_1 as a function of m and R_H +! +! Eq(25) R. Lindh, P.-A. Malmqvist, L. Gagliardi, +! TCA, 106:178-187 (2001) + +D_m = -Four +if (m == 4) D_m = -2.3_wp +if (m == 2) D_m = -One +if (m == 0) D_m = 1.9_wp +if (m == -2) D_m = 9.1_wp + +!x = alpha*(r_1)**2 + +ln_x = (Two/(real(m,kind=wp)+Three))*(D_m-log(One/R_H)) + +R_Min = sqrt(exp(ln_x)/Alpha) + +Eval_RMin = R_Min +!write(u6,*) 'Eval_RMin=',Eval_RMin +! * +!*********************************************************************** +! * + +return + +end function Eval_RMin diff -Nru openmolcas-22.02/src/nq_util/free_dede_funi.f openmolcas-22.10/src/nq_util/free_dede_funi.f --- openmolcas-22.02/src/nq_util/free_dede_funi.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/free_dede_funi.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,20 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Free_DeDe_Funi() - use k2_arrays - Implicit Real*8 (A-H,O-Z) -#include "stdalloc.fh" -* - Call mma_deallocate(ipOffD) - Call mma_deallocate(DeDe) -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/free_dede_funi.F90 openmolcas-22.10/src/nq_util/free_dede_funi.F90 --- openmolcas-22.02/src/nq_util/free_dede_funi.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/free_dede_funi.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,24 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Free_DeDe_Funi() + +use k2_arrays, only: DeDe, ipOffD +use stdalloc, only: mma_deallocate + +implicit none + +call mma_deallocate(ipOffD) +call mma_deallocate(DeDe) + +return + +end subroutine Free_DeDe_Funi diff -Nru openmolcas-22.02/src/nq_util/funi_init.f openmolcas-22.10/src/nq_util/funi_init.f --- openmolcas-22.02/src/nq_util/funi_init.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/funi_init.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,61 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Funi_Init() - use nq_Info - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "itmax.fh" -* * -************************************************************************ -* * -* * -************************************************************************ -* * -* Initialize the defaults values of the parameters. -* -* Default Grid - Quadrature='MHL ' - nR=75 - L_Quad=29 - Crowding=3.0D0 - Fade=6.0D0 - MBC=' ' -* - ntotgp=0 -* -* Various default thresholds for the integral evaluation. -* - T_Y =1.0D-11 - Threshold=1.0D-25 -* - Angular_Prunning = On - Grid_Type=Moving_Grid - Rotational_Invariance= On - NQ_Direct=Off -! NQ_Direct=On -! Packing=On - Packing=Off -* -* Bit 1: set Lobatto, not set Gauss and Gauss-Legendre -* Bit 2: set scan the whole atomic grid, not set use subset -* Bit 3: set Lebedev, override bit 1 - iOpt_Angular=4 -* * -************************************************************************ -* * - Do i = 0, LMax_NQ - R_Max(i)=Zero - End Do -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/funi_init.F90 openmolcas-22.10/src/nq_util/funi_init.F90 --- openmolcas-22.02/src/nq_util/funi_init.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/funi_init.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,63 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Funi_Init() + +use nq_Info, only: Angular_Pruning, Crowding, Fade, Grid_Type, iOpt_Angular, L_Quad, MBC, Moving_Grid, NQ_Direct, nR, ntotgp, Off, & + On, Packing, Quadrature, Rotational_Invariance, T_Y, Threshold, R_Max +use Constants, only: Zero, Three, Six +use Definitions, only: wp, iwp + +implicit none + +! * +!*********************************************************************** +! * +! Initialize the default values of the parameters. + +! Default Grid +Quadrature = 'MHL ' +nR = 75 +L_Quad = 29 +Crowding = Three +Fade = Six +MBC = ' ' + +ntotgp = 0 + +! Various default thresholds for the integral evaluation. + +T_Y = 1.0e-11_wp +Threshold = 1.0e-25_wp + +Angular_Pruning = On +Grid_Type = Moving_Grid +Rotational_Invariance = On +NQ_Direct = Off +!NQ_Direct = On +!Packing = On +Packing = Off + +! Bit 0: set Lobatto, not set Gauss and Gauss-Legendre +! Bit 1: set scan the whole atomic grid, not set use subset +! Bit 2: set Lebedev, override bit 0 +iOpt_Angular = ibset(0_iwp,2) +! * +!*********************************************************************** +! * +R_Max(:) = Zero +! * +!*********************************************************************** +! * + +return + +end subroutine Funi_Init diff -Nru openmolcas-22.02/src/nq_util/funi_input.f openmolcas-22.10/src/nq_util/funi_input.f --- openmolcas-22.02/src/nq_util/funi_input.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/funi_input.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,312 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Funi_Input(LuRd) - use nq_Grid, only: nGridMax - use nq_Info - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Character*180 Get_Ln,Key,KWord - External Get_Ln - Logical Check -* * -************************************************************************ -* * -* Statement function -* - Check(i,j)=iAnd(i,2**(j-1)).ne.0 -* * -************************************************************************ -* * -* - mask_111110=62 - mask_111101=61 - mask_111011=59 - mask_111010=58 -* -* KeyWord directed input -* - 999 Continue - Key = Get_Ln(LuRd) -* Write (*,*) ' Processing:',Key - KWord = Key - Call UpCase(KWord) - If (KWord(1:4).eq.'RTHR') Go To 100 - If (KWord(1:4).eq.'GRID') Go To 101 - If (KWord(1:4).eq.'LMAX') Go To 102 - If (KWord(1:4).eq.'RQUA') Go To 103 - If (KWord(1:4).eq.'NR ') Go To 104 - If (KWord(1:4).eq.'NGRI') Go To 105 - If (KWord(1:4).eq.'LOBA') Go To 106 - If (KWord(1:4).eq.'GGL ') Go To 107 - If (KWord(1:4).eq.'WHOL') Go To 108 - If (KWord(1:4).eq.'GLOB') Go To 109 - If (KWord(1:4).eq.'DIAT') Go To 110 - If (KWord(1:4).eq.'NOPR') Go To 111 - If (KWord(1:4).eq.'CROW') Go To 112 - If (KWord(1:4).eq.'LEBE') Go To 113 - If (KWord(1:4).eq.'FIXE') Go To 114 - If (KWord(1:4).eq.'MOVI') Go To 115 - If (KWord(1:4).eq.'NORO') Go To 116 - If (KWord(1:4).eq.'RHOT') Go To 117 - If (KWord(1:4).eq.'NOSC') Go To 119 - If (KWord(1:4).eq.'T_Y ') Go To 120 - If (KWord(1:4).eq.'NQDI') Go To 121 - If (KWord(1:4).eq.'FADE') Go To 122 - If (KWord(1:4).eq.'MOSS') Go To 123 -* - If (KWord(1:4).eq.'END ') Go To 997 - iChrct=Len(KWord) - Last=iCLast(KWord,iChrct) - Write (6,*) - Call WarningMessage(2,'Error in FUNI_input') - Write (6,'(1X,A,A)') KWord(1:Last),' is not a keyword!' - Write (6,*) ' Error in keyword.' - Call Quit_OnUserError() -* * -****** RTHR ************************************************************ -* * -* Read the radial threshold -* - 100 KWord = Get_Ln(LuRd) - Call Get_F1(1,Threshold) - Threshold = Abs(Threshold) - Go To 999 -* * -****** GRID ************************************************************ -* * -* Read quadrature quality -* - 101 KWord = Get_Ln(LuRd) - Call UpCase(KWord) - If (Index(KWord,'COARSE').ne.0) Then -*------- a la Gaussian - nR=35 - L_Quad=17 - Crowding=0.90D0 - Fade=3.0D0 - Quadrature='MHL' - Else If (Index(KWord,'ULTRAFINE').ne.0) Then -*------- a la Gaussian - nR=99 - L_Quad=41 - Crowding=1.0D10 - Fade=10.0D0 - Quadrature='MHL' - Else If (Index(KWord,'FINE').ne.0) Then -*------- a la Gaussian - nR=75 - L_Quad=29 - Crowding=3.0D0 - Fade=6.0D0 - Quadrature='MHL' - Else If (Index(KWord,'SG1GRID').ne.0) Then -*------- a la Gaussian - nR=50 - L_Quad=23 - Crowding=1.0D0 - Fade=5.0D0 - Quadrature='MHL' - Else - Call WarningMessage(2,'Funi_Input: Illegal grid') - Write (6,*) 'Type=',KWord - Call Abend() - End If - Go To 999 -* * -****** LMAX ************************************************************ -* * -* Read angular grid size -* - 102 KWord = Get_Ln(LuRd) - Call Get_I1(1,L_Quad) - Go To 999 -* * -****** RQUA ************************************************************ -* * -* Read radial quadrature scheme -* - 103 KWord = Get_Ln(LuRd) - Quadrature = KWord(1:10) - Call Upcase(Quadrature) - Go To 999 -* * -****** NR ************************************************************ -* * -* Read number of radial grid points -* - 104 KWord = Get_Ln(LuRd) - Call Get_I1(1,nR) - Go To 999 -* * -****** NGRI ************************************************************ -* * -* Read max number of grid points to process at one instance -* - 105 KWord = Get_Ln(LuRd) - Call Get_I1(1,nGridMax) - Go To 999 -* * -****** LOBA ************************************************************ -* * -* Activate use of Lobatto angular quadrature -* - 106 iOpt_Angular=iOr(iAnd(iOpt_Angular,mask_111010),1) - Go To 999 -* * -****** NGRI ************************************************************ -* * -* Activate use of Gauss and Gauss-Legendre angular quadrature -* - 107 iOpt_Angular=iAnd(iOpt_Angular,mask_111010) - Go To 999 -* * -****** WHOL ************************************************************ -* * -* Activate use of routines which scan the whole atomic grid for -* each sub block. -* - 108 iOpt_Angular=iOr(iAnd(iOpt_Angular,mask_111101),2) - Go To 999 -* * -****** GLOB ************************************************************ -* * -* Activate use of global partitioning technique. -* - 109 Write (6,*) 'The Global option is redundant!' - Go To 999 -* * -****** DIAT ************************************************************ -* * -* Activate use of diatomic partitioning technique. -* - 110 Write (6,*) 'The Diatomic option is redundant!' - Go To 999 -* * -****** NOPR ************************************************************ -* * -* Turn off the the angular prunning -* - 111 Angular_Prunning = Off - Go To 999 -* * -****** CROW ************************************************************ -* * -* Read the crowding factor -* - 112 KWord = Get_Ln(LuRd) - Call Get_F1(1,Crowding) - Go To 999 -* * -****** LEBE ************************************************************ -* * -* Turn off the Lebedev angular grid -* - 113 iOpt_Angular=iOr(iAnd(iOpt_Angular,mask_111011),4) - Go To 999 -* * -****** FIXE ************************************************************ -* * -* Turn on grid type = fixed -* - 114 Grid_Type=Fixed_Grid - Go To 999 -* * -****** MOVE ************************************************************ -* * -* Turn on grid type = moving -* - 115 Grid_Type=Moving_Grid - Go To 999 -* * -****** NORO ************************************************************ -* * -* Turn of rotational invariant energy -* - 116 Rotational_Invariance = Off - Go To 999 -* * -****** RHOT ************************************************************ -* * -* Threshold for density when grid points are ignored. -* -* Obsolete command! -* - 117 KWord = Get_Ln(LuRd) - Call Get_F1(1,Dummy) - Go To 999 -* * -****** NOSC ************************************************************ -* * -* Turn of the screening and the prunning. -* - 119 T_y=0.0D0 - Crowding=1.0D10 - Angular_Prunning = Off - Go To 999 -* * -****** T_Y ************************************************************ -* * -* Screening threshold for integral computation. -* - 120 KWord = Get_Ln(LuRd) - Call Get_F1(1,T_Y) - Go To 999 -* * -****** NQDI ************************************************************ -* * -* Recompute the AO values -* - 121 NQ_Direct=On - Go To 999 -* * -****** T_Y ************************************************************ -* * -* Fading factor for angular pruning. -* - 122 KWord = Get_Ln(LuRd) - Call Get_F1(1,Fade) - Go To 999 -* * -****** MOSS ************************************************************ -* * -* Assign Mossbauer center -* - 123 KWord = Get_Ln(LuRd) - MBC=KWord(1:8) - Call UpCase(MBC) - Go To 999 -* * -************************************************************************ -************************************************************************ -* * - 997 Continue -* - If (Check(iOpt_Angular,3)) Then - If (L_Quad.ne. 5 .and. - & L_Quad.ne. 7 .and. - & L_Quad.ne.11 .and. - & L_Quad.ne.17 .and. - & L_Quad.ne.23 .and. - & L_Quad.ne.29 .and. - & L_Quad.ne.35 .and. - & L_Quad.ne.41 .and. - & L_Quad.ne.47 .and. - & L_Quad.ne.53 .and. - & L_Quad.ne.59 ) Then - Write (6,*) 'L_Quad does not comply with Lebedev grid.' - iOpt_Angular=iAnd(iOpt_Angular,mask_111011) - Write (6,*) 'Lobatto grid activated!' - iOpt_Angular=iOr(iAnd(iOpt_Angular,mask_111110),1) - End If - End If -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/funi_input.F90 openmolcas-22.10/src/nq_util/funi_input.F90 --- openmolcas-22.02/src/nq_util/funi_input.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/funi_input.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,309 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Funi_Input(LuRd) + +use nq_Grid, only: nGridMax +use nq_Info, only: Angular_Pruning, Crowding, Fade, Fixed_Grid, Grid_Type, iOpt_Angular, L_Quad, MBC, Moving_Grid, NQ_Direct, nR, & + Off, On, Quadrature, Rotational_Invariance, T_Y, Threshold +use Constants, only: Zero, One, Three, Five, Six, Ten +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: LuRd +integer(kind=iwp) :: iChrct, Last +real(kind=wp) :: Dummy +character(len=180) :: Key, KWord +integer(kind=iwp), external :: iCLast +character(len=180), external :: Get_Ln + +! * +!*********************************************************************** +! * +! KeyWord directed input + +do + Key = Get_Ln(LuRd) + !write(u6,*) ' Processing:',Key + KWord = Key + call UpCase(KWord) + select case (KWord(1:4)) + + case ('RTHR') + ! * + !***** RTHR ****************************************************** + ! * + ! Read the radial threshold + + KWord = Get_Ln(LuRd) + call Get_F1(1,Threshold) + Threshold = abs(Threshold) + + case ('GRID') + ! * + !***** GRID ****************************************************** + ! * + ! Read quadrature quality + + KWord = Get_Ln(LuRd) + call UpCase(KWord) + if (index(KWord,'COARSE') /= 0) then + ! a la Gaussian + nR = 35 + L_Quad = 17 + Crowding = 0.9_wp + Fade = Three + Quadrature = 'MHL' + else if (index(KWord,'ULTRAFINE') /= 0) then + ! a la Gaussian + nR = 99 + L_Quad = 41 + Crowding = 1.0e10_wp + Fade = Ten + Quadrature = 'MHL' + else if (index(KWord,'FINE') /= 0) then + ! a la Gaussian + nR = 75 + L_Quad = 29 + Crowding = Three + Fade = Six + Quadrature = 'MHL' + else if (index(KWord,'SG1GRID') /= 0) then + ! a la Gaussian + nR = 50 + L_Quad = 23 + Crowding = One + Fade = Five + Quadrature = 'MHL' + else + call WarningMessage(2,'Funi_Input: Illegal grid') + write(u6,*) 'Type=',KWord + call Abend() + end if + + case ('LMAX') + ! * + !***** LMAX ****************************************************** + ! * + ! Read angular grid size + + KWord = Get_Ln(LuRd) + call Get_I1(1,L_Quad) + + case ('RQUA') + ! * + !***** RQUA ****************************************************** + ! * + ! Read radial quadrature scheme + + KWord = Get_Ln(LuRd) + Quadrature = KWord(1:10) + call Upcase(Quadrature) + + case ('NR ') + ! * + !***** NR ****************************************************** + ! * + ! Read number of radial grid points + + KWord = Get_Ln(LuRd) + call Get_I1(1,nR) + + case ('NGRI') + ! * + !***** NGRI ****************************************************** + ! * + ! Read max number of grid points to process at one instance + + KWord = Get_Ln(LuRd) + call Get_I1(1,nGridMax) + + case ('LOBA') + ! * + !***** LOBA ****************************************************** + ! * + ! Activate use of Lobatto angular quadrature + + iOpt_Angular = ibset(ibclr(iOpt_Angular,2),0) + + case ('GGL ') + ! * + !***** GGL ****************************************************** + ! * + ! Activate use of Gauss and Gauss-Legendre angular quadrature + + iOpt_Angular = ibclr(ibclr(iOpt_Angular,2),0) + + case ('WHOL') + ! * + !***** WHOL ****************************************************** + ! * + ! Activate use of routines which scan the whole atomic grid for + ! each sub block. + + iOpt_Angular = ibset(iOpt_Angular,1) + + case ('GLOB') + ! * + !***** GLOB ****************************************************** + ! * + ! Activate use of global partitioning technique. + + write(u6,*) 'The Global option is redundant!' + + case ('DIAT') + ! * + !***** DIAT ****************************************************** + ! * + ! Activate use of diatomic partitioning technique. + + write(u6,*) 'The Diatomic option is redundant!' + + case ('NOPR') + ! * + !***** NOPR ****************************************************** + ! * + ! Turn off the the angular pruning + + Angular_Pruning = Off + + case ('CROW') + ! * + !***** CROW ****************************************************** + ! * + ! Read the crowding factor + + KWord = Get_Ln(LuRd) + call Get_F1(1,Crowding) + + case ('LEBE') + ! * + !***** LEBE ****************************************************** + ! * + ! Turn off the Lebedev angular grid + + iOpt_Angular = ibset(iOpt_Angular,2) + + case ('FIXE') + ! * + !***** FIXE ****************************************************** + ! * + ! Turn on grid type = fixed + + Grid_Type = Fixed_Grid + + case ('MOVI') + ! * + !***** MOVE ****************************************************** + ! * + ! Turn on grid type = moving + + Grid_Type = Moving_Grid + + case ('NORO') + ! * + !***** NORO ****************************************************** + ! * + ! Turn of rotational invariant energy + + Rotational_Invariance = Off + + case ('RHOT') + ! * + !***** RHOT ****************************************************** + ! * + ! Threshold for density when grid points are ignored. + ! + ! Obsolete command! + + KWord = Get_Ln(LuRd) + call Get_F1(1,Dummy) + + case ('NOSC') + ! * + !***** NOSC ****************************************************** + ! * + ! Turn off the screening and the pruning. + + T_y = Zero + Crowding = 1.0e10_wp + Angular_Pruning = Off + + case ('T_Y ') + ! * + !***** T_Y ****************************************************** + ! * + ! Screening threshold for integral computation. + + KWord = Get_Ln(LuRd) + call Get_F1(1,T_Y) + + case ('NQDI') + ! * + !***** NQDI ****************************************************** + ! * + ! Recompute the AO values + + NQ_Direct = On + + case ('FADE') + ! * + !***** T_Y ****************************************************** + ! * + ! Fading factor for angular pruning. + + KWord = Get_Ln(LuRd) + call Get_F1(1,Fade) + + case ('MOSS') + ! * + !***** MOSS ****************************************************** + ! * + ! Assign Mossbauer center + + KWord = Get_Ln(LuRd) + MBC = KWord(1:8) + call UpCase(MBC) + + case ('END ') + ! * + !***** END ****************************************************** + ! * + exit + + case default + iChrct = len(KWord) + Last = iCLast(KWord,iChrct) + write(u6,*) + call WarningMessage(2,'Error in FUNI_input') + write(u6,'(1X,A,A)') KWord(1:Last),' is not a keyword!' + write(u6,*) ' Error in keyword.' + call Quit_OnUserError() + + end select +end do +! * +!*********************************************************************** +! * + +if (btest(iOpt_Angular,2)) then + if ((L_Quad /= 5) .and. (L_Quad /= 7) .and. (L_Quad /= 11) .and. (L_Quad /= 17) .and. (L_Quad /= 23) .and. (L_Quad /= 29) .and. & + (L_Quad /= 35) .and. (L_Quad /= 41) .and. (L_Quad /= 47) .and. (L_Quad /= 53) .and. (L_Quad /= 59)) then + write(u6,*) 'L_Quad does not comply with Lebedev grid.' + iOpt_Angular = ibclr(iOpt_Angular,2) + write(u6,*) 'Lobatto grid activated!' + iOpt_Angular = ibset(iOpt_Angular,0) + end if +end if + +return + +end subroutine Funi_Input diff -Nru openmolcas-22.02/src/nq_util/funi_print.f openmolcas-22.10/src/nq_util/funi_print.f --- openmolcas-22.02/src/nq_util/funi_print.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/funi_print.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,101 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Funi_Print() - use nq_Grid, only: nGridMax - use nq_Info - Implicit Real*8 (A-H,O-Z) - logical Check - logical, external:: Reduce_Prt -* * -************************************************************************ -* * -* Statement function -* - Check(i,j)=iAnd(i,2**(j-1)).ne.0 -* * -************************************************************************ -* * - iPrint=iPrintLevel(-1) -* * -************************************************************************ -* * - Call Get_dScalar('EThr',EThr) - T_Y=Min(T_Y,EThr*1.0D-1) - Threshold=Min(Threshold,EThr*1.0D-4) -* * -************************************************************************ -* * - If (.not.Reduce_Prt() .and. iPrint.ge.2) Then - Write (6,*) - Write (6,'(6X,A)') 'Numerical integration parameters' - Write (6,'(6X,A)') '--------------------------------' - Write (6,'(6X,A,21X,A)') 'Radial quadrature type: ',Quadrature -* - If (Quadrature(1:3).eq.'LMG') Then - Write (6,'(6X,A,E11.4)') 'Radial quadrature accuracy:', - & Threshold - Else - Write (6,'(6X,A,18X,I5)') 'Size of radial grid: ', - & nR - End If -* - If (Check(iOpt_Angular,3)) Then - Write (6,'(6X,A,25X,I4)') 'Lebedev angular grid:',L_Quad - Else If (Check(iOpt_Angular,1)) Then - Write (6,'(6X,A,I4)') 'Lobatto angular grid, l_max:',L_Quad - Else - Write (6,'(6X,A,I4)') - & 'Gauss and Gauss-Legendre angular grid, l_max:',L_Quad - End If -* - If (Angular_Prunning.eq.On) Then - Write (6,'(6X,A,1X,ES9.2)') - & 'Angular grid prunned with the crowding factor:', - & Crowding - Write (6,'(6X,A,1X,ES9.2)') - & ' and fading factor:', - & Fade - End If - If (Check(iOpt_Angular,2)) Then - Write (6,'(6X,A)') 'The whole atomic grid is scanned for each' - & //' sub block.' - End If -* - Write (6,'(6X,A,2X,ES9.2)') - & 'Screening threshold for integral computation:', - & T_Y - If (Quadrature(1:3).ne.'LMG') Then - Write (6,'(6X,A,20X,ES9.2)') 'Radial quadrature accuracy:', - & Threshold - End If -* - Write (6,'(6X,A,17X,I7)') 'Maximum batch size: ',nGridMax - If (NQ_Direct.eq.On) Then - Write (6,'(6X,A)') 'AO values are recomputed each iteration' - Else - Write (6,'(6X,A)') 'AO values are stored on disk' - End If - End If -* * -************************************************************************ -* * -* Put flag on RUNFILE to indicate that we are doing DFT. -* -* Call Get_iOption(iOpt) - Call Get_iScalar('System BitSwitch',iOpt) - iOpt=iOr(iOpt,2**6) -* Call Put_iOption(iOpt) - Call Put_iScalar('System BitSwitch',iOpt) -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/funi_print.F90 openmolcas-22.10/src/nq_util/funi_print.F90 --- openmolcas-22.02/src/nq_util/funi_print.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/funi_print.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,93 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Funi_Print() + +use nq_Grid, only: nGridMax +use nq_Info, only: Angular_Pruning, Crowding, Fade, iOpt_Angular, L_Quad, NQ_Direct, nR, On, Quadrature, T_Y, Threshold +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp) :: iOpt, iPrint +real(kind=wp) :: EThr +integer(kind=iwp), external :: iPrintLevel +logical(kind=iwp), external :: Reduce_Prt + +! * +!*********************************************************************** +! * +iPrint = iPrintLevel(-1) +! * +!*********************************************************************** +! * +call Get_dScalar('EThr',EThr) +T_Y = min(T_Y,EThr*0.1_wp) +Threshold = min(Threshold,EThr*1.0e-4_wp) +! * +!*********************************************************************** +! * +if ((.not. Reduce_Prt()) .and. (iPrint >= 2)) then + write(u6,*) + write(u6,'(6X,A)') 'Numerical integration parameters' + write(u6,'(6X,A)') '--------------------------------' + write(u6,'(6X,A,21X,A)') 'Radial quadrature type: ',Quadrature + + if (Quadrature(1:3) == 'LMG') then + write(u6,'(6X,A,E11.4)') 'Radial quadrature accuracy:',Threshold + else + write(u6,'(6X,A,18X,I5)') 'Size of radial grid: ',nR + end if + + if (btest(iOpt_Angular,2)) then + write(u6,'(6X,A,25X,I4)') 'Lebedev angular grid:',L_Quad + else if (btest(iOpt_Angular,0)) then + write(u6,'(6X,A,I4)') 'Lobatto angular grid, l_max:',L_Quad + else + write(u6,'(6X,A,I4)') 'Gauss and Gauss-Legendre angular grid, l_max:',L_Quad + end if + + if (Angular_Pruning == On) then + write(u6,'(6X,A,1X,ES9.2)') 'Angular grid prunned with the crowding factor:',Crowding + write(u6,'(6X,A,1X,ES9.2)') ' and fading factor:',Fade + end if + if (btest(iOpt_Angular,1)) then + write(u6,'(6X,A)') 'The whole atomic grid is scanned for each sub block.' + end if + + write(u6,'(6X,A,2X,ES9.2)') 'Screening threshold for integral computation:',T_Y + if (Quadrature(1:3) /= 'LMG') then + write(u6,'(6X,A,20X,ES9.2)') 'Radial quadrature accuracy:',Threshold + end if + + write(u6,'(6X,A,17X,I7)') 'Maximum batch size: ',nGridMax + if (NQ_Direct == On) then + write(u6,'(6X,A)') 'AO values are recomputed each iteration' + else + write(u6,'(6X,A)') 'AO values are stored on disk' + end if +end if +! * +!*********************************************************************** +! * +! Put flag on RUNFILE to indicate that we are doing DFT. + +!call Get_iOption(iOpt) +call Get_iScalar('System BitSwitch',iOpt) +iOpt = ibset(iOpt,6) +!call Put_iOption(iOpt) +call Put_iScalar('System BitSwitch',iOpt) +! * +!*********************************************************************** +! * + +return + +end subroutine Funi_Print diff -Nru openmolcas-22.02/src/nq_util/gauleg.f openmolcas-22.10/src/nq_util/gauleg.f --- openmolcas-22.02/src/nq_util/gauleg.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/gauleg.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,90 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine gauleg(x1,x2,xw,n) - Implicit None -#include "real.fh" - Integer n - Real*8 x1,x2,xw(2,n) - Real*8 EPS - Parameter(EPS=3.d-14) - Integer i, j, m - Real*8 p1, p2, p3, pp, xl, xm, z, z1 -* - m=(n+1)/2 - xm=Half*(x2+x1) - xl=Half*(x2-x1) -c Write (*,*) 'm=',m - Do i = 1, m - z=Cos(Pi*(DBLE(i)-0.25D0)/(DBLE(n)+Half)) - 1 Continue - p1=One - p2=Zero - Do j = 1, n - p3=p2 - p2=p1 - p1=((Two*DBLE(j)-One)*z*p2-(DBLE(j)-One)*p3)/DBLE(j) - End Do - pp=DBLE(n)*(z*p1-p2)/(z*z-One) - z1=z - z=z1-p1/pp - If (Abs(z-z1).gt.EPS) Go To 1 - xw(1,i )=xm-xl*z - xw(1,n+1-i)=xm+xl*z - xw(2,i )=Two*xl/((One-z*z)*pp*pp) - xw(2,n+1-i)=xw(2,i) - If (Abs(xw(1,i )).lt.EPS) xw(1,i )=Zero - If (Abs(xw(1,n+1-i)).lt.EPS) xw(1,n+1-i)=Zero - If (Abs(xw(2,i )).lt.EPS) xw(1,i )=Zero - If (Abs(xw(2,n+1-i)).lt.EPS) xw(1,n+1-i)=Zero - End Do -* - Return - End - Subroutine gauleg_(x1,x2,xw,n) - Implicit None -#include "real.fh" - Integer n - Real*8 x1,x2,xw(3,n) - Real*8 EPS - Parameter(EPS=3.d-14) - Integer i, j, m - Real*8 p1, p2, p3, pp, xl, xm, z, z1 -* - m=(n+1)/2 - xm=Half*(x2+x1) - xl=Half*(x2-x1) -c Write (*,*) 'm=',m - Do i = 1, m - z=Cos(Pi*(DBLE(i)-0.25D0)/(DBLE(n)+Half)) - 1 Continue - p1=One - p2=Zero - Do j = 1, n - p3=p2 - p2=p1 - p1=((Two*DBLE(j)-One)*z*p2-(DBLE(j)-One)*p3)/DBLE(j) - End Do - pp=DBLE(n)*(z*p1-p2)/(z*z-One) - z1=z - z=z1-p1/pp - If (Abs(z-z1).gt.EPS) Go To 1 - xw(1,i )=xm-xl*z - xw(1,n+1-i)=xm+xl*z - xw(2,i )=Two*xl/((One-z*z)*pp*pp) - xw(2,n+1-i)=xw(2,i) - If (Abs(xw(1,i )).lt.EPS) xw(1,i )=Zero - If (Abs(xw(1,n+1-i)).lt.EPS) xw(1,n+1-i)=Zero - If (Abs(xw(2,i )).lt.EPS) xw(1,i )=Zero - If (Abs(xw(2,n+1-i)).lt.EPS) xw(1,n+1-i)=Zero - End Do -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/gauleg.F90 openmolcas-22.10/src/nq_util/gauleg.F90 --- openmolcas-22.02/src/nq_util/gauleg.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/gauleg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,56 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine gauleg(x1,x2,xw,n) + +use Constants, only: Zero, One, Two, Half, Quart, Pi +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: n +real(kind=wp), intent(in) :: x1, x2 +real(kind=wp), intent(out) :: xw(2,n) +integer(kind=iwp) :: i, j, m +real(kind=wp) :: p1, p2, p3, pp, xl, xm, z, z1 +real(kind=wp), parameter :: EPS = 3.e-14_wp + +m = (n+1)/2 +xm = Half*(x2+x1) +xl = Half*(x2-x1) +!write(u6,*) 'm=',m +do i=1,m + z = cos(Pi*(real(i,kind=wp)-Quart)/(real(n,kind=wp)+Half)) + do + p1 = One + p2 = Zero + do j=1,n + p3 = p2 + p2 = p1 + p1 = ((Two*real(j,kind=wp)-One)*z*p2-(real(j,kind=wp)-One)*p3)/real(j,kind=wp) + end do + pp = real(n,kind=wp)*(z*p1-p2)/(z*z-One) + z1 = z + z = z1-p1/pp + if (abs(z-z1) <= EPS) exit + end do + xw(1,i) = xm-xl*z + xw(1,n+1-i) = xm+xl*z + xw(2,i) = Two*xl/((One-z*z)*pp*pp) + xw(2,n+1-i) = xw(2,i) + if (abs(xw(1,i)) < EPS) xw(1,i) = Zero + if (abs(xw(1,n+1-i)) < EPS) xw(1,n+1-i) = Zero + if (abs(xw(2,i)) < EPS) xw(1,i) = Zero + if (abs(xw(2,n+1-i)) < EPS) xw(1,n+1-i) = Zero +end do + +return + +end subroutine gauleg diff -Nru openmolcas-22.02/src/nq_util/genradquad_b.f openmolcas-22.10/src/nq_util/genradquad_b.f --- openmolcas-22.02/src/nq_util/genradquad_b.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/genradquad_b.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine GenRadQuad_B(R,nR,nR_Eff,Alpha) - Implicit Real*8 (a-h,o-z) -#include "real.fh" -#include "debug.fh" - Real*8 R(2,nR-1), Alpha -* -*---- Last point at infinity is eliminated -* - If (Debug) Then - Write (6,*) 'Becke Algorithm' - Write (6,*) 'Alpha=',Alpha - Write (6,*) 'nR=',nR - End If - Do iR = 1, nR-1 - x = Two*DBLE(iR)/DBLE(nR)-One - R(1,iR) = Alpha * (One+x)/(One-x) - R(2,iR) = R(1,iR)**2 * Alpha * Four / ( One - x )**2 / DBLE(nR) - End Do - nR_Eff = nR-1 -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/genradquad_b.F90 openmolcas-22.10/src/nq_util/genradquad_b.F90 --- openmolcas-22.02/src/nq_util/genradquad_b.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/genradquad_b.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,44 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine GenRadQuad_B(R,nR,nR_Eff,Alpha) + +use Constants, only: One, Two, Four +use Definitions, only: wp, iwp +#ifdef _DEBUGPRINT_ +use Definitions, only: u6 +#endif + +implicit none +integer(kind=iwp), intent(in) :: nR +real(kind=wp), intent(out) :: R(2,nR-1) +integer(kind=iwp), intent(out) :: nR_Eff +real(kind=wp), intent(in) :: Alpha +integer(kind=iwp) :: iR +real(kind=wp) :: x + +! Last point at infinity is eliminated + +#ifdef _DEBUGPRINT_ +write(u6,*) 'Becke Algorithm' +write(u6,*) 'Alpha=',Alpha +write(u6,*) 'nR=',nR +#endif +do iR=1,nR-1 + x = Two*real(iR,kind=wp)/real(nR,kind=wp)-One + R(1,iR) = Alpha*(One+x)/(One-x) + R(2,iR) = R(1,iR)**2*Alpha*Four/(One-x)**2/real(nR,kind=wp) +end do +nR_Eff = nR-1 + +return + +end subroutine GenRadQuad_B diff -Nru openmolcas-22.02/src/nq_util/genradquad_mhl.f openmolcas-22.10/src/nq_util/genradquad_mhl.f --- openmolcas-22.02/src/nq_util/genradquad_mhl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/genradquad_mhl.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine GenRadQuad_MHL(R,nR,nR_Eff,Alpha) - Implicit Real*8 (a-h,o-z) -#include "real.fh" -#include "debug.fh" - Real*8 R(2,nR-1), Alpha -* -*---- Last point at infinity is eliminated -* - If (Debug) Then - Write (6,*) 'EM Algorithm (Murray, Handy, Laming)' - Write (6,*) 'Alpha=',Alpha - Write (6,*) 'nR=',nR - End If - Do iR = 1, nR-1 - x = DBLE(iR)/DBLE(nR) - R(1,iR) = Alpha * (x/(One-x))**2 - R(2,iR) = R(1,iR)**2 * Two* Alpha * x / (One-x)**3 / DBLE(nR) - End Do - nR_Eff = nR-1 -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/genradquad_mhl.F90 openmolcas-22.10/src/nq_util/genradquad_mhl.F90 --- openmolcas-22.02/src/nq_util/genradquad_mhl.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/genradquad_mhl.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,44 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine GenRadQuad_MHL(R,nR,nR_Eff,Alpha) + +use Constants, only: One, Two +use Definitions, only: wp, iwp +#ifdef _DEBUGPRINT_ +use Definitions, only: u6 +#endif + +implicit none +integer(kind=iwp), intent(in) :: nR +real(kind=wp), intent(out) :: R(2,nR-1) +integer(kind=iwp), intent(out) :: nR_Eff +real(kind=wp), intent(in) :: Alpha +integer(kind=iwp) :: iR +real(kind=wp) :: x + +! Last point at infinity is eliminated + +#ifdef _DEBUGPRINT_ +write(u6,*) 'EM Algorithm (Murray, Handy, Laming)' +write(u6,*) 'Alpha=',Alpha +write(u6,*) 'nR=',nR +#endif +do iR=1,nR-1 + x = real(iR,kind=wp)/real(nR,kind=wp) + R(1,iR) = Alpha*(x/(One-x))**2 + R(2,iR) = R(1,iR)**2*Two*Alpha*x/(One-x)**3/real(nR,kind=wp) +end do +nR_Eff = nR-1 + +return + +end subroutine GenRadQuad_MHL diff -Nru openmolcas-22.02/src/nq_util/genradquad_mk.f openmolcas-22.10/src/nq_util/genradquad_mk.f --- openmolcas-22.02/src/nq_util/genradquad_mk.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/genradquad_mk.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine GenRadQuad_MK(R,nR,nR_Eff,m,Alpha,iNQ) - Implicit Real*8 (a-h,o-z) -#include "real.fh" -#include "debug.fh" - Real*8 R(2,nR-1), Alpha, m -* -*---- Last point at infinity is eliminated -* - If (Debug) Then - Write (6,*) 'Log3 Algorithm (Mura-Knowles)' - Write (6,*) 'Alpha,m=',Alpha,m - Write (6,*) 'nR=',nR - End If - Do iR = 1, nR-1 - x = DBLE(iR)/DBLE(nR) - R(1,iR) = - Alpha * log( One - x**m ) - R(2,iR) = R(1,iR)**2 * Alpha * m * x**(m-One) - & / ( One - x**m ) / DBLE(nR) - End Do - nR_Eff = nR-1 -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(iNQ) - End diff -Nru openmolcas-22.02/src/nq_util/genradquad_mk.F90 openmolcas-22.10/src/nq_util/genradquad_mk.F90 --- openmolcas-22.02/src/nq_util/genradquad_mk.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/genradquad_mk.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,44 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine GenRadQuad_MK(R,nR,nR_Eff,m,Alpha) + +use Constants, only: One +use Definitions, only: wp, iwp +#ifdef _DEBUGPRINT_ +use Definitions, only: u6 +#endif + +implicit none +integer(kind=iwp), intent(in) :: nR +real(kind=wp), intent(out) :: R(2,nR-1) +integer(kind=iwp), intent(out) :: nR_Eff +real(kind=wp), intent(in) :: m, Alpha +integer(kind=iwp) :: iR +real(kind=wp) :: x + +! Last point at infinity is eliminated + +#ifdef _DEBUGPRINT_ +write(u6,*) 'Log3 Algorithm (Mura-Knowles)' +write(u6,*) 'Alpha,m=',Alpha,m +write(u6,*) 'nR=',nR +#endif +do iR=1,nR-1 + x = real(iR,kind=wp)/real(nR,kind=wp) + R(1,iR) = -Alpha*log(One-x**m) + R(2,iR) = R(1,iR)**2*Alpha*m*x**(m-One)/(One-x**m)/real(nR,kind=wp) +end do +nR_Eff = nR-1 + +return + +end subroutine GenRadQuad_MK diff -Nru openmolcas-22.02/src/nq_util/genradquad_pam.f openmolcas-22.10/src/nq_util/genradquad_pam.f --- openmolcas-22.02/src/nq_util/genradquad_pam.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/genradquad_pam.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,190 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine GenRadQuad_PAM(iNQ,nR_Eff,mr,Alpha,Process,QuadR, - & nQuadR) - use nq_Info - Implicit Real*8 (a-h,o-z) -#include "itmax.fh" -#include "real.fh" -#include "debug.fh" - Real*8 Alpha(2), QuadR(2,nQuadR) - Real*8 mr(2), ln_rn - Logical Process -* -*---- Last point at infinity is eliminated -* - If (Debug) Write (6,*) 'New Algorithm (Malmqvist)' -* -*-----Reading of the datas - Alpha_Min=Alpha(1) - Alpha_Max=Alpha(2) - l_Max=2*Int(mr(1)) - If (Debug) Write (6,*) 'l_Max=',l_Max - Relative_Max_Error=mr(2) - If (Debug) Write (6,*) 'Relative_Max_Error=',Relative_Max_Error -* -* Compute an approximative R_D_0 -* - Dr=Zero - h=Zero - Do k = 0, l_Max, l_Max-1 - R_D_0=Relative_Max_Error/(10.0D0**k) - Dr=-Log10(R_D_0) -* -* Starting value of h -* - h=One/(0.47D0*Dr+0.93D0) -* * -************************************************************************ -* * -*---- Compute a correct h for the approximative R_D_0 -* - C1=Four*Sqrt(Two)*Pi - C2=Pi**2/Two - 99 Continue - h_=C2/( -Log( Ten**(-Dr)*h / C1 ) ) - If (Abs(h_-h).gt.1.0D-4) Then - h=h_ - Go To 99 - End If -* * -************************************************************************ -* * -* Now find h from the correct R_D, i.e. from the highest -* angular momentum available. -* - Dr=-Log10(Relative_Max_Error) - 98 Continue - h_=C2/( - & -Log( - & Ten**(-Dr)*(h/C1)*(h/Pi)**(DBLE(k)/Two) - & *(G((DBLE(k)+Three)/Two)/G(Three/Two)) - & ) - & ) - - If (Debug) Write (6,*) 'h h_ ',h, h_ - If (Abs(h_-h).gt.1.0D-5) Then - h=h_ - Go To 98 - End If -* - If (k.eq.0) h0=h - End Do -* * -************************************************************************ -* * -*---- Compute table of R_Max as a function of l -* - Do i = l_Max, 0, -2 - D_m=-4.0D0 - If (l_Max.eq. 4) D_m=-2.3D0 - If (l_Max.eq. 2) D_m=-1.0D0 - If (l_Max.eq. 0) D_m= 1.9D0 - If (l_Max.eq.-2) D_m= 9.1D0 -* - ggg=(Two/(DBLE(i)+Three))*(D_m-Log(One/Ten**(-Dr))) - R_Max(i)=Sqrt(Exp(ggg)/Alpha_Max) - If (Debug) Then - write(6,*) 'i =',i - write(6,*) 'l_Max =',l_Max - write(6,*) 'ggg =',ggg - write(6,*) 'R_Max(i) =',R_Max(i) - End If - End Do - If (Debug) Write (6,*) 'h0,h=',h0,h -* -* For hybrid grid use R_Max for l=0 and h for l=l_max -* r1=R_Max(l_Max) - r1=R_Max(0) - ln_rn=1.7D0-log(Alpha_Min)/Two - rn=Exp(ln_rn) - gamma=r1/(Exp(h)-One) - n_High=Int(Log(rn/gamma+One)/h+One) - If (Debug) Then - Write (6,*) - Write (6,*) 'r1,Alpha_Min =',r1,Alpha_Min - Write (6,*) 'rn,Alpha_Max =',rn,Alpha_MAx - Write (6,*) 'h,Dr,n_High =',h,Dr,n_High - End If -* -*-----Store the radius and the associated weights -* - If (Debug) Write(6,*) 'n_High',n_High - iR = 0 - Do k = 0, n_High - a = DBLE(k)*h - rk = Gamma*(Exp(a)-One) -*----Note that the point at r=0 is eliminated - If (rk.ne.Zero) Then - iR = iR + 1 - If (Process) Then - QuadR(1,ir)=rk - Correction=One -* -* Gregorious correction for points close to the nuclei -* - If (k.eq.0) Correction= 46.D0/120.D0 - If (k.eq.1) Correction=137.D0/120.D0 - If (k.eq.2) Correction=118.D0/120.D0 - If (k.eq.3) Correction=119.D0/120.D0 -* - QuadR(2,ir) = h * ( rk + gamma ) * Correction - QuadR(2,ir) = QuadR(1,ir)**2 * QuadR(2,ir) - End If - End If -* - End Do -*-----Store the value of the maximum radius to which we should integrate -* for the partitionning and the number of effective radii. - nR_Eff = iR -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(iNQ) - End - Function G(Arg) - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 G - g=-1000.0D0 -* - Arg_=DBLE(Int(Arg)) - If (Abs(Arg-Arg_).lt.Half/Two) Then -* Integer argument - G=One - rG=One - Else -* fractional argument - G=Sqrt(Pi) - rG=Half - End If -* - 99 Continue - If (Abs(rG-Arg).lt.Half/Two) goto 666 - G=rG*G - rG=rG+One - Go To 99 -666 continue - return -* - End - Function RD(m,h) - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 RD, h -* - RD=(Four*Sqrt(Two)*Pi/h)*Exp(-Pi**2/(Two*h)) - If (m.eq.0) Return - RD=(G(Three/Two)/G((DBLE(m)+Three)/Two)) - & *(Pi/h)**(DBLE(m)/Two) * RD -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/genradquad_pam.F90 openmolcas-22.10/src/nq_util/genradquad_pam.F90 --- openmolcas-22.02/src/nq_util/genradquad_pam.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/genradquad_pam.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,165 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine GenRadQuad_PAM(nR_Eff,mr,Alpha,Process,QuadR,nQuadR) + +use nq_Info, only: R_Max +use Constants, only: Zero, One, Two, Three, Four, Ten, Pi +use Definitions, only: wp, iwp +#ifdef _DEBUGPRINT_ +use Definitions, only: u6 +#endif + +implicit none +integer(kind=iwp), intent(out) :: nR_Eff +real(kind=wp), intent(in) :: mr(2), Alpha(2) +integer(kind=iwp), intent(in) :: nQuadR +real(kind=wp), intent(out) :: QuadR(2,nQuadR) +logical(kind=iwp) :: Process +integer(kind=iwp) :: i, iR, k, l_Max, n_High +real(kind=wp) :: a, Alpha_Max, Alpha_Min, C1, C2, Correction, D_m, Dr, Gmma, ggg, h, h_, ln_rn, r1, R_D_0, Relative_Max_Error, rk, & + rn +real(kind=wp), external :: G + +! Last point at infinity is eliminated + +#ifdef _DEBUGPRINT_ +write(u6,*) 'New Algorithm (Malmqvist)' +#endif + +! Reading of the data +Alpha_Min = Alpha(1) +Alpha_Max = Alpha(2) +l_Max = 2*int(mr(1)) +#ifdef _DEBUGPRINT_ +write(u6,*) 'l_Max=',l_Max +#endif +Relative_Max_Error = mr(2) +#ifdef _DEBUGPRINT_ +write(u6,*) 'Relative_Max_Error=',Relative_Max_Error +#endif + +! Compute an approximative R_D_0 + +Dr = Zero +h = Zero +do k=0,l_Max,l_Max-1 + R_D_0 = Relative_Max_Error/(Ten**k) + Dr = -log10(R_D_0) + + ! Starting value of h + + h = One/(0.47_wp*Dr+0.93_wp) + ! * + !********************************************************************* + ! * + ! Compute a correct h for the approximative R_D_0 + + C1 = Four*sqrt(Two)*Pi + C2 = Pi**2/Two + do + h_ = C2/(-log(Ten**(-Dr)*h/C1)) + if (abs(h_-h) <= 1.0e-4_wp) exit + h = h_ + end do + ! * + !********************************************************************* + ! * + ! Now find h from the correct R_D, i.e. from the highest + ! angular momentum available. + + Dr = -log10(Relative_Max_Error) + do + h_ = C2/(-log(Ten**(-Dr)*(h/C1)*(h/Pi)**(real(k,kind=wp)/Two)*(G((real(k,kind=wp)+Three)/Two)/G(Three/Two)))) + +# ifdef _DEBUGPRINT_ + write(u6,*) 'h h_ ',h,h_ +# endif + if (abs(h_-h) <= 1.0e-5_wp) exit + h = h_ + end do + +# ifdef _DEBUGPRINT_ + if (k == 0) h0 = h +# endif +end do +! * +!*********************************************************************** +! * +! Compute table of R_Max as a function of l + +do i=l_Max,0,-2 + D_m = -Four + if (l_Max == 4) D_m = -2.3_wp + if (l_Max == 2) D_m = -One + if (l_Max == 0) D_m = 1.9_wp + if (l_Max == -2) D_m = 9.1_wp + + ggg = (Two/(real(i,kind=wp)+Three))*(D_m-log(One/Ten**(-Dr))) + R_Max(i) = sqrt(exp(ggg)/Alpha_Max) +# ifdef _DEBUGPRINT_ + write(u6,*) 'i =',i + write(u6,*) 'l_Max =',l_Max + write(u6,*) 'ggg =',ggg + write(u6,*) 'R_Max(i) =',R_Max(i) +# endif +end do +#ifdef _DEBUGPRINT_ +write(u6,*) 'h0,h=',h0,h +#endif + +! For hybrid grid use R_Max for l=0 and h for l=l_max +! r1=R_Max(l_Max) +r1 = R_Max(0) +ln_rn = 1.7_wp-log(Alpha_Min)/Two +rn = exp(ln_rn) +Gmma = r1/(exp(h)-One) +n_High = int(log(rn/Gmma+One)/h+One) +#ifdef _DEBUGPRINT_ +write(u6,*) +write(u6,*) 'r1,Alpha_Min =',r1,Alpha_Min +write(u6,*) 'rn,Alpha_Max =',rn,Alpha_MAx +write(u6,*) 'h,Dr,n_High =',h,Dr,n_High +#endif + +! Store the radius and the associated weights + +iR = 0 +do k=0,n_High + a = real(k,kind=wp)*h + rk = Gmma*(exp(a)-One) + ! Note that the point at r=0 is eliminated + if (rk /= Zero) then + iR = iR+1 + if (Process) then + QuadR(1,ir) = rk + Correction = One + + ! Gregorious correction for points close to the nuclei + + if (k == 0) Correction = 46.0_wp/120.0_wp + if (k == 1) Correction = 137.0_wp/120.0_wp + if (k == 2) Correction = 118.0_wp/120.0_wp + if (k == 3) Correction = 119.0_wp/120.0_wp + + QuadR(2,ir) = h*(rk+Gmma)*Correction + QuadR(2,ir) = QuadR(1,ir)**2*QuadR(2,ir) + end if + end if + +end do +! Store the value of the maximum radius to which we should integrate +! for the partitionning and the number of effective radii. +nR_Eff = iR + +return + +end subroutine GenRadQuad_PAM diff -Nru openmolcas-22.02/src/nq_util/genradquad_ta.f openmolcas-22.10/src/nq_util/genradquad_ta.f --- openmolcas-22.02/src/nq_util/genradquad_ta.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/genradquad_ta.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine GenRadQuad_TA(R,nR,nR_Eff,Alpha) - Implicit Real*8 (a-h,o-z) -#include "real.fh" -#include "debug.fh" - Real*8 R(2,nR-1), Alpha -* -*---- Last point at infinity is eliminated -* - If (Debug) Then - Write (6,*) 'Treutler-Ahlrichs Algorithm' - Write (6,*) 'Alpha=',Alpha - Write (6,*) 'nR=',nR - End If - Fact=Alpha/Log(Two) - F6=0.6D00 - Do iR = 1, nR-1 - x = Two*DBLE(iR)/DBLE(nR)-One - F1=(One+x) - F2=Log(Two/(One-x)) - R(1,iR) = Fact * F1**F6 * F2 - R(2,iR) = R(1,iR)**2 * Fact * ( - & F6*F1**(F6-One) * F2 - & + F1**F6 * One/(One-x) - & ) - & * Two / DBLE(nR) - End Do - nR_Eff = nR-1 -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/genradquad_ta.F90 openmolcas-22.10/src/nq_util/genradquad_ta.F90 --- openmolcas-22.02/src/nq_util/genradquad_ta.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/genradquad_ta.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,48 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine GenRadQuad_TA(R,nR,nR_Eff,Alpha) + +use Constants, only: One, Two +use Definitions, only: wp, iwp +#ifdef _DEBUGPRINT_ +use Definitions, only: u6 +#endif + +implicit none +integer(kind=iwp), intent(in) :: nR +real(kind=wp), intent(out) :: R(2,nR-1) +integer(kind=iwp), intent(out) :: nR_Eff +real(kind=wp), intent(in) :: Alpha +integer(kind=iwp) :: iR +real(kind=wp) :: F1, F2, F6, Fact, x + +! Last point at infinity is eliminated + +#ifdef _DEBUGPRINT_ +write(u6,*) 'Treutler-Ahlrichs Algorithm' +write(u6,*) 'Alpha=',Alpha +write(u6,*) 'nR=',nR +#endif +Fact = Alpha/log(Two) +F6 = 0.6_wp +do iR=1,nR-1 + x = Two*real(iR,kind=wp)/real(nR,kind=wp)-One + F1 = (One+x) + F2 = log(Two/(One-x)) + R(1,iR) = Fact*F1**F6*F2 + R(2,iR) = R(1,iR)**2*Fact*(F6*F1**(F6-One)*F2+F1**F6*One/(One-x))*Two/real(nR,kind=wp) +end do +nR_Eff = nR-1 + +return + +end subroutine GenRadQuad_TA diff -Nru openmolcas-22.02/src/nq_util/genvoronoi.f openmolcas-22.10/src/nq_util/genvoronoi.f --- openmolcas-22.02/src/nq_util/genvoronoi.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/genvoronoi.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,280 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine GenVoronoi(Coor,nR_Eff,nNQ,Alpha,rm,iNQ) -************************************************************************ -* * -* This version of GenVoronoi computes the radial quadrature points * -* and computes datas useful for the angular quadrature. * -* The angular part is generated by Subblock. * -* * -************************************************************************ - use NQ_Structure, only: NQ_Data - use nq_Info - Implicit Real*8 (a-h,o-z) -#include "itmax.fh" -#include "real.fh" -#include "stdalloc.fh" - Real*8 Coor(3) - Integer nR_Eff(nNQ) - Real*8 Alpha(2), rm(2) - Logical Process - Dimension Dum(2,1) -* -************************************************************************ -* -*#define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Write (6,*) 'nR,L_Quad=',nR,L_Quad -#endif - If (L_Quad.gt.lMax_NQ) Then - Call WarningMessage(2,'GenVoronoi: L_Quad.gt.lMax_NQ') - Write (6,*) 'Redimension lMax_NQ in nq_info.f90' - Write (6,*) 'lMax_NQ=',lMax_NQ - Write (6,*) 'L_Quad=',L_Quad - Call Abend() - End If - l_Max=Int(rm(1)) - Radius_Max=Eval_RMax(Alpha(1),l_Max,rm(2)) -#ifdef _DEBUGPRINT_ - Write (6,*) 'Alpha(1)=',Alpha(1) - Write (6,*) 'l_max=',l_max - Write (6,*) 'rm(2)=',rm(2) - Write (6,*) 'Radius_Max=',Radius_Max - Write (6,*) -#endif -************************************************************************ -* * -*---- Generate radial quadrature points. Observe that the integrand * -* vanish at (r=0.0). * -* - If (Quadrature.eq.'MHL') Then -* - iANr=NQ_Data(iNQ)%Atom_Nr - RBS=Bragg_Slater(iANr) - Alpha(1)=RBS - mR=nR-1 - Call mma_allocate(NQ_Data(iNQ)%R_Quad,2,mR,Label='R_Quad') - NQ_Data(iNQ)%R_Quad(:,:)=Zero - Call GenRadQuad_MHL(NQ_Data(iNQ)%R_Quad,nR,nR_Eff(iNQ), - & Alpha(1)) - Call Truncate_Grid(NQ_Data(iNQ)%R_Quad,mR,nR_Eff(iNQ), - & Radius_Max) - mR=nR_Eff(iNQ) - NQ_Data(iNQ)%R_max =NQ_Data(iNQ)%R_Quad(1,mR) -* - Else If (Quadrature.eq.'LOG3') Then -* - rm(1)=Three -*------- alpha=5 (alpha=7 for alkali and rare earth metals) - Alpha(1)=Five - iANr=NQ_Data(iNQ)%Atom_Nr - If (iANr.eq.3 .or. - & iANr.eq.4 .or. - & iANr.eq.11.or. - & iANr.eq.12.or. - & iANr.eq.19.or. - & iANr.eq.20.or. - & iANr.eq.37.or. - & iANr.eq.38.or. - & iANr.eq.55.or. - & iANr.eq.56.or. - & iANr.eq.87.or. - & iANr.eq.88 ) Alpha(1)=Seven - mR=nR-1 - Call mma_allocate(NQ_Data(iNQ)%R_Quad,2,mR,Label='R_Quad') - NQ_Data(iNQ)%R_Quad(:,:)=Zero - Call GenRadQuad_MK(NQ_Data(iNQ)%R_Quad,nR,nR_Eff(iNQ),rm(1), - & Alpha(1),iNQ) - Call Truncate_Grid(NQ_Data(iNQ)%r_Quad,mR,nR_Eff(iNQ), - & Radius_Max) - mR=nR_Eff(iNQ) - NQ_Data(iNQ)%R_max =NQ_Data(iNQ)%R_Quad(1,mR) -* - Else If (Quadrature.eq.'BECKE') Then -* - iANr=NQ_Data(iNQ)%Atom_Nr - RBS=Bragg_Slater(iANr) - If (iANr.eq.1) Then - Alpha(1)=RBS - Else - Alpha(1)=Half*RBS - End If - mR=nR-1 - Call mma_allocate(NQ_Data(iNQ)%R_Quad,2,mR,Label='R_Quad') - NQ_Data(iNQ)%R_Quad(:,:)=Zero - Call GenRadQuad_B(NQ_Data(iNQ)%R_Quad,nR,nR_Eff(iNQ),Alpha(1)) - Call Truncate_Grid(NQ_Data(iNQ)%R_Quad,mR,nR_Eff(iNQ), - & Radius_Max) - mR=nR_Eff(iNQ) - NQ_Data(iNQ)%R_max =NQ_Data(iNQ)%R_Quad(1,mR) -* - Else If (Quadrature.eq.'TA') Then -* - Alpha(1)=-One - iANr=NQ_Data(iNQ)%Atom_Nr - If (iANr.eq. 1) Then - Alpha(1)=0.8D00 - Else If (iANr.eq. 2) Then - Alpha(1)=0.9D00 - Else If (iANr.eq. 3) Then - Alpha(1)=1.8D00 - Else If (iANr.eq. 4) Then - Alpha(1)=1.4D00 - Else If (iANr.eq. 5) Then - Alpha(1)=1.3D00 - Else If (iANr.eq. 6) Then - Alpha(1)=1.1D00 - Else If (iANr.eq. 7) Then - Alpha(1)=0.9D00 - Else If (iANr.eq. 8) Then - Alpha(1)=0.9D00 - Else If (iANr.eq. 9) Then - Alpha(1)=0.9D00 - Else If (iANr.eq.10) Then - Alpha(1)=0.9D00 - Else If (iANr.eq.11) Then - Alpha(1)=1.4D00 - Else If (iANr.eq.12) Then - Alpha(1)=1.3D00 - Else If (iANr.eq.13) Then - Alpha(1)=1.3D00 - Else If (iANr.eq.14) Then - Alpha(1)=1.2D00 - Else If (iANr.eq.15) Then - Alpha(1)=1.1D00 - Else If (iANr.eq.16) Then - Alpha(1)=1.0D00 - Else If (iANr.eq.17) Then - Alpha(1)=1.0D00 - Else If (iANr.eq.18) Then - Alpha(1)=1.0D00 - Else If (iANr.eq.19) Then - Alpha(1)=1.5D00 - Else If (iANr.eq.20) Then - Alpha(1)=1.4D00 - Else If (iANr.eq.21) Then - Alpha(1)=1.3D00 - Else If (iANr.eq.22) Then - Alpha(1)=1.2D00 - Else If (iANr.eq.23) Then - Alpha(1)=1.2D00 - Else If (iANr.eq.24) Then - Alpha(1)=1.2D00 - Else If (iANr.eq.25) Then - Alpha(1)=1.2D00 - Else If (iANr.eq.26) Then - Alpha(1)=1.2D00 - Else If (iANr.eq.27) Then - Alpha(1)=1.2D00 - Else If (iANr.eq.28) Then - Alpha(1)=1.1D00 - Else If (iANr.eq.29) Then - Alpha(1)=1.1D00 - Else If (iANr.eq.30) Then - Alpha(1)=1.1D00 - Else If (iANr.eq.31) Then - Alpha(1)=1.1D00 - Else If (iANr.eq.32) Then - Alpha(1)=1.0D00 - Else If (iANr.eq.33) Then - Alpha(1)=0.9D00 - Else If (iANr.eq.34) Then - Alpha(1)=0.9D00 - Else If (iANr.eq.35) Then - Alpha(1)=0.9D00 - Else If (iANr.eq.36) Then - Alpha(1)=0.9D00 - Else - Call WarningMessage(2,'TA grid not defined') - Write (6,*) ' TA grid not defined for atom number:', iANR - Call Abend() - End If - mR=nR-1 - Call mma_allocate(NQ_Data(iNQ)%R_Quad,2,mR,Label='R_Quad') - NQ_Data(iNQ)%R_Quad(:,:)=Zero - Call GenRadQuad_TA(NQ_Data(iNQ)%R_Quad,nR,nR_Eff(iNQ),Alpha(1)) - Call Truncate_Grid(NQ_Data(iNQ)%R_Quad,mR,nR_Eff(iNQ), - & Radius_Max) - mR=nR_Eff(iNQ) - NQ_Data(iNQ)%R_max =NQ_Data(iNQ)%R_Quad(1,mR) -* - Else If (Quadrature.eq.'LMG') Then -* -* * -************************************************************************ -* * -*--------Generate radial quadrature. The first call will generate -* the size of the grid. -* - nR=1 ! Dummy size on the first call. - Process=.False. - Call GenRadQuad_PAM(iNQ,nR_Eff(iNQ),rm,Alpha(1), - & Process,Dum,nR) -* - nR=nR_Eff(iNQ) - Call mma_allocate(NQ_Data(iNQ)%R_Quad,2,nR,Label='R_Quad') - NQ_Data(iNQ)%R_Quad(:,:)=Zero - Process=.True. - Call GenRadQuad_PAM(iNQ,nR_Eff(iNQ),rm,Alpha(1), - & Process,NQ_Data(iNQ)%R_Quad,nR) - NQ_Data(iNQ)%R_max =NQ_Data(iNQ)%R_Quad(1,nR) -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - Write(6,*) 'GenRadQuad_PAM ----> GenVoronoi' - Write(6,*) 'nR_Eff=',nR_Eff(iNQ) - Write(6,*) 'rm : ',rm(1),rm(2) - Write(6,*) 'Alpha : ',Alpha(1),Alpha(2) -#endif - Else - Call WarningMessage(2, - & 'Invalid quadrature scheme:'//Quadrature) - Call Quit_OnUserError() - End If -* -#ifdef _DEBUGPRINT_ - Write (6,*) - Write (6,*) ' ******** The radial grid ********' - Write (6,*) - Write (6,*) 'Initial number of radial grid points=',nR - Write (6,*) 'iNQ=',iNQ - Write (6,*) 'Effective number of radial grid points=',nR_Eff(iNQ) - Do iR = 1, nR_Eff(iNQ) - Write (6,*) NQ_Data(iNQ)%R_Quad(1,iR), - & NQ_Data(iNQ)%R_Quad(2,iR) - End Do - Write (6,*) - Write (6,*) ' *********************************' - Write (6,*) -#endif -* * -************************************************************************ -* * - Return -c Avoid unused argument warnings - If (.False.) Call Unused_real_array(Coor) - End - Subroutine Truncate_Grid(R,nR,nR_Eff,Radius_Max) - Implicit Real*8 (a-h,o-z) - Real*8 R(2,nR) -* - nTmp=nR_Eff - Do i = 1, nTmp - If (R(1,i).gt.Radius_Max) Then - nR_Eff=i-1 - Go To 99 - End If - End Do - 99 Continue -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/genvoronoi.F90 openmolcas-22.10/src/nq_util/genvoronoi.F90 --- openmolcas-22.02/src/nq_util/genvoronoi.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/genvoronoi.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,252 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine GenVoronoi(nR_Eff,Alpha,rm,iNQ) +!*********************************************************************** +! * +! This version of GenVoronoi computes the radial quadrature points * +! and computes data useful for the angular quadrature. * +! The angular part is generated by Subblock. * +! * +!*********************************************************************** + +use NQ_Structure, only: NQ_Data +use nq_Info, only: L_Quad, lMax_NQ, nR, Quadrature +use stdalloc, only: mma_allocate +use Constants, only: Zero, One, Three, Five, Seven, Half +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(out) :: nR_Eff +real(kind=wp), intent(inout) :: Alpha(2), rm(2) +integer(kind=iwp), intent(in) :: iNQ +integer(kind=iwp) :: iANr, l_Max, mR +real(kind=wp) :: Dum(2,1), Radius_Max, RBS +logical(kind=iwp) :: Process +real(kind=wp), external :: Bragg_Slater, Eval_RMax + +! * +!*********************************************************************** +! * +!#define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +write(u6,*) 'nR,L_Quad=',nR,L_Quad +#endif +if (L_Quad > lMax_NQ) then + call WarningMessage(2,'GenVoronoi: L_Quad > lMax_NQ') + write(u6,*) 'Redimension lMax_NQ in nq_info' + write(u6,*) 'lMax_NQ=',lMax_NQ + write(u6,*) 'L_Quad=',L_Quad + call Abend() +end if +l_Max = int(rm(1)) +Radius_Max = Eval_RMax(Alpha(1),l_Max,rm(2)) +#ifdef _DEBUGPRINT_ +write(u6,*) 'Alpha(1)=',Alpha(1) +write(u6,*) 'l_max=',l_max +write(u6,*) 'rm(2)=',rm(2) +write(u6,*) 'Radius_Max=',Radius_Max +write(u6,*) +#endif +! * +!*********************************************************************** +! * +! Generate radial quadrature points. Observe that the integrand +! vanish at (r=0.0). + +if (Quadrature == 'MHL') then + + iANr = NQ_Data(iNQ)%Atom_Nr + RBS = Bragg_Slater(iANr) + Alpha(1) = RBS + mR = nR-1 + call mma_allocate(NQ_Data(iNQ)%R_Quad,2,mR,Label='R_Quad') + NQ_Data(iNQ)%R_Quad(:,:) = Zero + call GenRadQuad_MHL(NQ_Data(iNQ)%R_Quad,nR,nR_Eff,Alpha(1)) + call Truncate_Grid(NQ_Data(iNQ)%R_Quad,mR,nR_Eff,Radius_Max) + mR = nR_Eff + NQ_Data(iNQ)%R_max = NQ_Data(iNQ)%R_Quad(1,mR) + +else if (Quadrature == 'LOG3') then + + rm(1) = Three + ! alpha=5 (alpha=7 for alkali and rare earth metals) + Alpha(1) = Five + iANr = NQ_Data(iNQ)%Atom_Nr + if ((iANr == 3) .or. (iANr == 4) .or. (iANr == 11) .or. (iANr == 12) .or. (iANr == 19) .or. (iANr == 20) .or. (iANr == 37) .or. & + (iANr == 38) .or. (iANr == 55) .or. (iANr == 56) .or. (iANr == 87) .or. (iANr == 88)) Alpha(1) = Seven + mR = nR-1 + call mma_allocate(NQ_Data(iNQ)%R_Quad,2,mR,Label='R_Quad') + NQ_Data(iNQ)%R_Quad(:,:) = Zero + call GenRadQuad_MK(NQ_Data(iNQ)%R_Quad,nR,nR_Eff,rm(1),Alpha(1)) + call Truncate_Grid(NQ_Data(iNQ)%r_Quad,mR,nR_Eff,Radius_Max) + mR = nR_Eff + NQ_Data(iNQ)%R_max = NQ_Data(iNQ)%R_Quad(1,mR) + +else if (Quadrature == 'BECKE') then + + iANr = NQ_Data(iNQ)%Atom_Nr + RBS = Bragg_Slater(iANr) + if (iANr == 1) then + Alpha(1) = RBS + else + Alpha(1) = Half*RBS + end if + mR = nR-1 + call mma_allocate(NQ_Data(iNQ)%R_Quad,2,mR,Label='R_Quad') + NQ_Data(iNQ)%R_Quad(:,:) = Zero + call GenRadQuad_B(NQ_Data(iNQ)%R_Quad,nR,nR_Eff,Alpha(1)) + call Truncate_Grid(NQ_Data(iNQ)%R_Quad,mR,nR_Eff,Radius_Max) + mR = nR_Eff + NQ_Data(iNQ)%R_max = NQ_Data(iNQ)%R_Quad(1,mR) + +else if (Quadrature == 'TA') then + + Alpha(1) = -One + iANr = NQ_Data(iNQ)%Atom_Nr + if (iANr == 1) then + Alpha(1) = 0.8_wp + else if (iANr == 2) then + Alpha(1) = 0.9_wp + else if (iANr == 3) then + Alpha(1) = 1.8_wp + else if (iANr == 4) then + Alpha(1) = 1.4_wp + else if (iANr == 5) then + Alpha(1) = 1.3_wp + else if (iANr == 6) then + Alpha(1) = 1.1_wp + else if (iANr == 7) then + Alpha(1) = 0.9_wp + else if (iANr == 8) then + Alpha(1) = 0.9_wp + else if (iANr == 9) then + Alpha(1) = 0.9_wp + else if (iANr == 10) then + Alpha(1) = 0.9_wp + else if (iANr == 11) then + Alpha(1) = 1.4_wp + else if (iANr == 12) then + Alpha(1) = 1.3_wp + else if (iANr == 13) then + Alpha(1) = 1.3_wp + else if (iANr == 14) then + Alpha(1) = 1.2_wp + else if (iANr == 15) then + Alpha(1) = 1.1_wp + else if (iANr == 16) then + Alpha(1) = 1.0_wp + else if (iANr == 17) then + Alpha(1) = 1.0_wp + else if (iANr == 18) then + Alpha(1) = 1.0_wp + else if (iANr == 19) then + Alpha(1) = 1.5_wp + else if (iANr == 20) then + Alpha(1) = 1.4_wp + else if (iANr == 21) then + Alpha(1) = 1.3_wp + else if (iANr == 22) then + Alpha(1) = 1.2_wp + else if (iANr == 23) then + Alpha(1) = 1.2_wp + else if (iANr == 24) then + Alpha(1) = 1.2_wp + else if (iANr == 25) then + Alpha(1) = 1.2_wp + else if (iANr == 26) then + Alpha(1) = 1.2_wp + else if (iANr == 27) then + Alpha(1) = 1.2_wp + else if (iANr == 28) then + Alpha(1) = 1.1_wp + else if (iANr == 29) then + Alpha(1) = 1.1_wp + else if (iANr == 30) then + Alpha(1) = 1.1_wp + else if (iANr == 31) then + Alpha(1) = 1.1_wp + else if (iANr == 32) then + Alpha(1) = 1.0_wp + else if (iANr == 33) then + Alpha(1) = 0.9_wp + else if (iANr == 34) then + Alpha(1) = 0.9_wp + else if (iANr == 35) then + Alpha(1) = 0.9_wp + else if (iANr == 36) then + Alpha(1) = 0.9_wp + else + call WarningMessage(2,'TA grid not defined') + write(u6,*) ' TA grid not defined for atom number:',iANR + call Abend() + end if + mR = nR-1 + call mma_allocate(NQ_Data(iNQ)%R_Quad,2,mR,Label='R_Quad') + NQ_Data(iNQ)%R_Quad(:,:) = Zero + call GenRadQuad_TA(NQ_Data(iNQ)%R_Quad,nR,nR_Eff,Alpha(1)) + call Truncate_Grid(NQ_Data(iNQ)%R_Quad,mR,nR_Eff,Radius_Max) + mR = nR_Eff + NQ_Data(iNQ)%R_max = NQ_Data(iNQ)%R_Quad(1,mR) + +else if (Quadrature == 'LMG') then + + ! * + !********************************************************************* + ! * + ! Generate radial quadrature. The first call will generate + ! the size of the grid. + + nR = 1 ! Dummy size on the first call. + Process = .false. + call GenRadQuad_PAM(nR_Eff,rm,Alpha(1),Process,Dum,nR) + + nR = nR_Eff + call mma_allocate(NQ_Data(iNQ)%R_Quad,2,nR,Label='R_Quad') + NQ_Data(iNQ)%R_Quad(:,:) = Zero + Process = .true. + call GenRadQuad_PAM(nR_Eff,rm,Alpha(1),Process,NQ_Data(iNQ)%R_Quad,nR) + NQ_Data(iNQ)%R_max = NQ_Data(iNQ)%R_Quad(1,nR) + ! * + !********************************************************************* + ! * +# ifdef _DEBUGPRINT_ + write(u6,*) 'GenRadQuad_PAM ----> GenVoronoi' + write(u6,*) 'nR_Eff=',nR_Eff + write(u6,*) 'rm : ',rm(1),rm(2) + write(u6,*) 'Alpha : ',Alpha(1),Alpha(2) +# endif +else + call WarningMessage(2,'Invalid quadrature scheme:'//Quadrature) + call Quit_OnUserError() +end if + +#ifdef _DEBUGPRINT_ +write(u6,*) +write(u6,*) ' ******** The radial grid ********' +write(u6,*) +write(u6,*) 'Initial number of radial grid points=',nR +write(u6,*) 'iNQ=',iNQ +write(u6,*) 'Effective number of radial grid points=',nR_Eff +do iR=1,nR_Eff + write(u6,*) NQ_Data(iNQ)%R_Quad(1,iR),NQ_Data(iNQ)%R_Quad(2,iR) +end do +write(u6,*) +write(u6,*) ' *********************************' +write(u6,*) +#endif +! * +!*********************************************************************** +! * + +return + +end subroutine GenVoronoi diff -Nru openmolcas-22.02/src/nq_util/get_subblock.f openmolcas-22.10/src/nq_util/get_subblock.f --- openmolcas-22.02/src/nq_util/get_subblock.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/get_subblock.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,684 +0,0 @@ -*********************************************************************** -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1999, Roland Lindh * -************************************************************************ - Subroutine Get_Subblock(Kernel,Func,ixyz, - & Maps2p,list_s,list_exp,list_bas, - & nShell,nSym, list_p,nNQ, - & FckInt,nFckDim,nFckInt,nD, - & mGrid,nP2_ontop,Do_Mo, - & Do_Grad,Grad,nGrad, - & mAO,mdRho_dR, - & EG_OT,nTmpPUVX,PDFTPot1,PDFTFocI,PDFTFocA) -************************************************************************ -* * -* Object: to generate the list of the shell and exponent that have an * -* influence on a subblock * -* * -* Called from: Drvnq_ * -* * -* Author: Roland Lindh, * -* Dept of Chemical Physics, * -* University of Lund, Sweden * -* August 1999 * -************************************************************************ - use iSD_data - use Basis_Info - use Center_Info - use nq_Grid, only: Grid, Weights, TabAO, - & TabAO_Pack, dRho_dR, TabAO_Short, - & kAO, R2_trial - use nq_Grid, only: List_G, IndGrd, iTab, dW_dR, nR_Eff - use NQ_Structure, only: NQ_Data - use Grid_On_Disk - use nq_MO, only: nMOs - use nq_Info - Implicit Real*8 (A-H,O-Z) - External Kernel -#include "itmax.fh" -#include "Molcas.fh" -#include "nsd.fh" -#include "setup.fh" -#include "real.fh" -#include "stdalloc.fh" -#include "debug.fh" -#include "ksdft.fh" - Integer Maps2p(nShell,0:nSym-1), list_s(2,*), - & list_exp(nSym*nShell), list_bas(2,nSym*nShell), - & list_p(nNQ) - Real*8 FckInt(nFckInt,nFckDim),Grad(nGrad),Roots(3,3), - & xyz0(3,2),PDFTPot1(npot1),PDFTFocI(nPot1),PDFTFocA(nPot1) - Logical InBox(MxAtom), Do_Grad, More_to_come - Logical Do_Mo - Real*8 EG_OT(nTmpPUVX) - Integer, Allocatable:: Index(:) - Real*8, Allocatable:: dW_Temp(:,:), dPB(:,:,:) - Real*8, Allocatable:: TabMO(:), TabSO(:) -* * -************************************************************************ -* * -*#define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Write(6,*) 'Enter Get_Subblock' -#endif -* -*-----Resolve triplet index -* - iyz = 1 + (ixyz-1)/nx - ix = ixyz - (iyz-1)*nx - iz = 1 + (iyz-1)/ny - iy = iyz - (iz-1)*ny -* -*-----Get the extreme coordinates of the box. -* - x_min_= x_min+DBLE(ix-2)*Block_Size - x_max_= x_min_+Block_Size - y_min_= y_min+DBLE(iy-2)*Block_Size - y_max_= y_min_+Block_Size - z_min_= z_min+DBLE(iz-2)*Block_Size - z_max_= z_min_+Block_Size - If (ix.eq.1 ) x_min_=-1.0D99 - If (ix.eq.nx) x_max_= 1.0D99 - If (iy.eq.1 ) y_min_=-1.0D99 - If (iy.eq.ny) y_max_= 1.0D99 - If (iz.eq.1 ) z_min_=-1.0D99 - If (iz.eq.nz) z_max_= 1.0D99 -* * -#ifdef _DEBUGPRINT_ - Write(6,*) - Write(6,*) 'Block_Size=',Block_Size - Write(6,*) 'ix,iy,iz=',ix,iy,iz - Write(6,*) 'x_min_,x_max_',x_min_,x_max_ - Write(6,*) 'y_min_,y_max_',y_min_,y_max_ - Write(6,*) 'z_min_,z_max_',z_min_,z_max_ - Write(6,*) 'nNQ=',nNQ -#endif -* * -************************************************************************ -************************************************************************ -* * -*-----Generate list over atoms which contribute to the subblock. -* * -************************************************************************ -* * - ilist_p=0 - Do 10 iNQ=1,nNQ - InBox(iNQ)=.False. -*--------Get the coordinates of the partitionning - x_NQ =NQ_Data(iNQ)%Coor(1) - y_NQ =NQ_Data(iNQ)%Coor(2) - z_NQ =NQ_Data(iNQ)%Coor(3) -* -* 1) center is in the box -* - If ((x_NQ.ge.x_min_).and.(x_NQ.le.x_max_) - & .and.(y_NQ.ge.y_min_).and.(y_NQ.le.y_max_) - & .and.(z_NQ.ge.z_min_).and.(z_NQ.le.z_max_)) - & InBox(iNQ)=.True. - If (InBox(iNQ)) Then - ilist_p=ilist_p+1 - list_p(ilist_p)=iNQ - GoTo 10 - EndIf -* -* 2) atomic grid of this center extends inside the box. -* - RMax = NQ_Data(iNQ)%R_Max - t1=(x_NQ-x_min_)/(x_max_-x_min_) - If (t1.lt.Zero) t1=Zero - If (t1.gt.One ) t1=One - t2=(y_NQ-y_min_)/(y_max_-y_min_) - If (t2.lt.Zero) t2=Zero - If (t2.gt.One ) t2=One - t3=(z_NQ-z_min_)/(z_max_-z_min_) - If (t3.lt.Zero) t3=Zero - If (t3.gt.One ) t3=One - R2_Trial(iNQ)= (x_NQ-(x_max_-x_min_)*t1-x_min_)**2 - & + (y_NQ-(y_max_-y_min_)*t2-y_min_)**2 - & + (z_NQ-(z_max_-z_min_)*t3-z_min_)**2 - If (R2_Trial(iNQ).le.RMax**2) Then - ilist_p=ilist_p+1 - list_p(ilist_p)=iNQ - EndIf - 10 Continue - nlist_p=ilist_p - If (nlist_p.eq.0) return -#ifdef _DEBUGPRINT_ - Write (6,*) 'Get_Subblock: List_p:',List_p -#endif -* * -************************************************************************ -************************************************************************ -* * -*-----Generate list over shells which contribute to the subblock. -* * -************************************************************************ -* * - ilist_s=0 -*#define _ANALYSIS_ - Do iShell=1,nShell -#ifdef _DEBUGPRINT_ - Write (6,*) 'iShell,nShell=',iShell,nShell -#endif - NrExp =iSD( 5,iShell) - iAng =iSD( 1,iShell) - iShll =iSD( 0,iShell) - NrBas =iSD( 3,iShell) - mdci =iSD(10,iShell) - nDegi=nSym/dc(mdci)%nStab -* - Do jSym = 0, nDegi-1 - iSym=dc(mdci)%iCoSet(jSym,0) -#ifdef _DEBUGPRINT_ - Write (6,*) 'iSym,nDegi-1=',iSym,nDegi-1 -#endif -* - iNQ=Maps2p(iShell,NrOpr(iSym)) - RMax_NQ = NQ_Data(iNQ)%R_Max -#ifdef _DEBUGPRINT_ - Write (6,*) 'iNQ=',iNQ - Write (6,*) 'RMax_NQ=',RMax_NQ - Write (6,*) 'InBox(iNQ)=',InBox(iNQ) -#endif -* -* 1) the center of this shell is inside the box -* - If (InBox(iNQ)) Then - ilist_s=ilist_s+1 - list_s(1,ilist_s)=iShell - list_s(2,ilist_s)=iSym - list_exp(ilist_s)=NrExp - list_bas(1,ilist_s)=NrBas -#ifdef _ANALYSIS_ - Write (6,*) ' Shell is in box, ilist_s: ',ilist_s -#endif - GoTo 20 - End If -#ifdef _DEBUGPRINT_ - Write (6,*) 'Passed here!' - Write (6,*) 'Threshold:',Threshold -#endif -* -* 2) the Gaussian has a grid point which extends inside the -* box. The Gaussians are ordered from the most diffuse to -* the most contracted. -* - nExpTmp=0 - Do iExp=1,NrExp -*------------- Get the value of the exponent - ValExp=Shells(iShll)%Exp(iExp) -*------------- If the exponent has an influence then increase the -* number of actives exponents for this shell, else -* there is no other active exponent (they are ordered) - RMax=Min(Eval_RMax(ValExp,iAng,Threshold),RMax_NQ) -*#define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Write (6,*) 'iShell,iNQ=',iShell,iNQ - Write (6,*) 'ValExp,iExp=',ValExp,iExp - Write (6,*) 'RMax_NQ=',RMax_NQ - Write (6,*) 'RMax_Exp=', - & Eval_RMax(ValExp,iAng,Threshold) - Write (6,*) 'RMax=',RMax - Write (6,*) 'R2_Trial(iNQ),RMax**2=', - & R2_Trial(iNQ),RMax**2 -#endif - If (R2_Trial(iNQ).gt.RMax**2) Go To 99 - nExpTmp=nExpTmp+1 - End Do !iExp - 99 Continue - If (nExpTmp.ne.0) Then - ilist_s=ilist_s+1 - list_s(1,ilist_s)=iShell - list_s(2,ilist_s)=iSym - list_exp(ilist_s)=nExpTmp -* -* Examine if contracted basis functions can be ignored. -* This will be the case for segmented basis sets. -* - list_bas(1,ilist_s)=nBas_Eff(NrExp,NrBas, - & Shells(iShll)%Exp, - & Shells(iShll)%pCff, - & list_exp(ilist_s)) -#ifdef _ANALYSIS_ - Write (6,*) ' Shell is included, ilist_s: ',ilist_s - Write (6,*) ' nExpTmp=',nExpTmp - Write (6,*) 'R2_Trial(iNQ),RMax**2=', - & R2_Trial(iNQ),RMax**2 -#endif - End If - 20 Continue - End Do ! iSym - End Do ! iShell - nlist_s=ilist_s -#ifdef _DEBUGPRINT_ - Write (6,*) 'nList_s,nList_p=',nList_s,nList_p -#endif - If (nList_s*nList_p.eq.0) return -* * -************************************************************************ -* * -* Generate index arrays to address the density matrix, which is in -* the full shell and the reduced shell over which in the basis -* functions will be evaluated. -* - nIndex=0 - Do ilist_s=1, nlist_s - iShell=list_s(1,ilist_s) - NrBas_Eff=list_bas(1,ilist_s) - iCmp = iSD( 2,iShell) - nIndex=nIndex + NrBas_Eff*iCmp - End Do -* - Call mma_allocate(Index,nIndex,Label='Index') -* - iIndex=1 - nAOs=0 - nAOs_Eff=0 - Do ilist_s=1, nlist_s - iShell=list_s(1,ilist_s) - NrBas =iSD( 3,iShell) - NrBas_Eff=list_bas(1,ilist_s) - iCmp = iSD( 2,iShell) - nAOs=nAOs+NrBas*iCmp - nAOs_Eff=nAOs_Eff+NrBas_Eff*iCmp - list_bas(2,ilist_s)=iIndex - Call Do_Index(Index(iIndex),NrBas,NrBas_Eff,iCmp) - iIndex=iIndex + NrBas_Eff*iCmp - End Do -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - write(6,*) 'Contribution to the subblock :' - write(6,*) 'NQ :',(list_p(ilist_p) ,ilist_p=1,nlist_p) - write(6,*) 'Sh :',(list_s(1,ilist_s),ilist_s=1,nlist_s) - write(6,*) ' :',(list_s(2,ilist_s),ilist_s=1,nlist_s) - write(6,*) 'Exp:',(list_exp(ilist_s),ilist_s=1,nlist_s) -#endif -* - nBfn=0 - Do iList_s = 1, nList_s - iSkal =list_s(1,ilist_s) - NrBas_Eff=list_bas(1,ilist_s) - iCmp = iSD( 2,iSkal) - nBfn=nBfn+NrBas_Eff*iCmp - End Do -* -* - If (Do_MO) Then - nTabMO=mAO*nMOs*mGrid - nTabSO=mAO*nMOs*mGrid - Else - nTabMO=1 - nTabSO=1 - End If - Call mma_allocate(TabMO,nTabMO,Label='TabMO') - Call mma_allocate(TabSO,nTabSO,Label='TabSO') -* * -************************************************************************ -* * -* Generate indexation of which shells contributes to which centers -* and center index for each gradient contribution which is computed. -* - nGrad_Eff=0 - If (Do_Grad) Then - Call ICopy(3*nShell*nSym,[0],0,List_G,1) - Do ilist_s = 1, nlist_s - iShell=list_s(1,ilist_s) - iSym =list_s(2,ilist_s) - mdci =iSD(10,iShell) - iNQ = Maps2p(iShell,NrOpr(iSym)) - Do iCar=0,2 - If ((iSD(16+iCar,iShell).ne.0 .or. - & iSD(12,iShell).eq.1) .and. - & List_G(1+iCar,ilist_s).eq.0) Then - nGrad_Eff=nGrad_Eff+1 -* -* For pseudo centers note that there will not be a -* gradient computed for this center. -* - iPseudo=iSD(12,iShell) - If (iPseudo.eq.0) Then - IndGrd(nGrad_Eff)=iSD(16+iCar,iShell) - Else - IndGrd(nGrad_Eff)=-1 - End If - List_G(1+iCar,ilist_s)=nGrad_Eff - iTab(1,nGrad_Eff)=iCar+1 - iTab(3,nGrad_Eff)=iNQ - kNQ=Maps2p(iShell,0) - Xref=NQ_Data(kNQ)%Coor(iCar+1) - X =NQ_Data(iNQ)%Coor(iCar+1) - If (X.eq.Xref) Then - iTab(4,nGrad_Eff)=dc(mdci)%nStab - Else - iTab(4,nGrad_Eff)=-dc(mdci)%nStab - End If -* -*---------------- Find all other shells which contribute to the same -* gradient. -* - Do jlist_s = ilist_s+1, nlist_s - jShell=list_s(1,jlist_s) - If ( (iSD(16+iCar,iShell).eq. - & iSD(16+iCar,jShell)) - & .and. - & (iSym.eq.list_s(2,jlist_s)) - & ) Then - List_G(1+iCar,jlist_s)=nGrad_Eff - End If - End Do -* -* -*------- Include derivatives which will be used for -* the translational invariance equation but which do not -* contribute directly to a symmetry adapted gradient -* - Else If (iSD(16+iCar,iShell).eq.0 .and. - & List_G(1+iCar,ilist_s).eq.0) Then - nGrad_Eff=nGrad_Eff+1 - IndGrd(nGrad_Eff)=-1 - List_G(1+iCar,ilist_s)=nGrad_Eff - iTab(1,nGrad_Eff)=iCar+1 - iTab(3,nGrad_Eff)=iNQ - iTab(4,nGrad_Eff)=dc(mdci)%nStab -* -*--------------------- Find all other shells which contribute to the same -* gradient. -* - Do jlist_s = ilist_s+1, nlist_s - jShell=list_s(1,jlist_s) - jSym =list_s(2,jlist_s) - jNQ = Maps2p(jShell,NrOpr(jSym)) - If (iNQ.eq.jNQ) Then - List_G(1+iCar,jlist_s)=nGrad_Eff - End If - End Do - End If - End Do - End Do -* - If (Grid_Type.eq.Moving_Grid) Then - Call mma_allocate(dW_dR,nGrad_Eff,mGrid,Label='dW_dR') - Call mma_allocate(dW_Temp,3,nList_P,Label='dW_Temp') - Call mma_allocate(dPB,3,nlist_p,nlist_p,Label='dPB') - End If - End If - If (Do_Grad.and.nGrad_Eff.eq.0) Go To 998 - If (Grid_Status.eq.Use_Old) Go To 997 - Call ICopy(3*nBatch_Max,[0],0,iBatchInfo,1) -* * -************************************************************************ -************************************************************************ -* * -*-----For each partition active in the subblock create the grid -* and perform the integration on it. -* * -************************************************************************ -* * - number_of_grid_points=0 - nBatch = 0 - Do ilist_p=1,nlist_p - iNQ=list_p(ilist_p) -#ifdef _DEBUGPRINT_ - Write (6,*) 'ilist_p=',ilist_p - Write (6,*) 'Get_SubBlock: iNQ=',iNQ -#endif -* -*------- Select which gradient contributions that should be computed. -* For basis functions which have the center common with the grid -* do not compute any contribution. -* - If (Do_Grad) Then - Call ICopy(nGrad_Eff,[On],0,iTab(2,1),4) - If (Grid_Type.eq.Moving_Grid) Then - Do iGrad = 1, nGrad_Eff - jNQ = iTab(3,iGrad) - If (iNQ.eq.jNQ) iTab(2,iGrad)=Off - End Do - End If -#ifdef _DEBUGPRINT_ - Write (6,*) - Write (6,'(A,24I3)') ' i =',( i ,i=1,nGrad_Eff) - Write (6,'(A,24I3)') 'iTab(1,i)=',(iTab(1,i),i=1,nGrad_Eff) - Write (6,'(A,24I3)') 'iTab(2,i)=',(iTab(2,i),i=1,nGrad_Eff) - Write (6,'(A,24I3)') 'iTab(3,i)=',(iTab(3,i),i=1,nGrad_Eff) - Write (6,'(A,24I3)') 'iTab(4,i)=',(iTab(4,i),i=1,nGrad_Eff) - Write (6,*) 'IndGrd=',IndGrd - Write (6,*) -#endif -* - End If -* -*--------Get the coordinates of the partition - x_NQ =NQ_Data(iNQ)%Coor(1) - y_NQ =NQ_Data(iNQ)%Coor(2) - z_NQ =NQ_Data(iNQ)%Coor(3) -*--------Get the maximum radius on which we have to integrate for the -* partition - RMax=NQ_Data(iNQ)%R_Max -* - Call Box_On_Sphere(x_Min_-x_NQ,x_Max_-x_NQ, y_Min_-y_NQ, - & y_Max_-y_NQ, z_Min_-z_NQ,z_Max_-z_NQ, - & xyz0(1,1), xyz0(1,2), - & xyz0(2,1), xyz0(2,2), - & xyz0(3,1), xyz0(3,2)) -* * -************************************************************************ -* * -*------- Establish R_Box_Max and R_Box_Min, the longest and the shortest -* distance from the origin of the atomic grid to a point in the -* box -* - R_Box_Max=Zero - R_Box_Min=RMax -* - x_box_min = x_min_ - x_NQ - x_box_max = x_max_ - x_NQ - y_box_min = y_min_ - y_NQ - y_box_max = y_max_ - y_NQ - z_box_min = z_min_ - z_NQ - z_box_max = z_max_ - z_NQ -* - Roots(1,1)=x_box_min - Roots(2,1)=x_box_max - If (x_box_max*x_box_min.lt.Zero) Then - nx_Roots=3 - Roots(3,1)=Zero - Else - nx_Roots=2 - End If -* - Roots(1,2)=y_box_min - Roots(2,2)=y_box_max - If (y_box_max*y_box_min.lt.Zero) Then - ny_Roots=3 - Roots(3,2)=Zero - Else - ny_Roots=2 - End If -* - Roots(1,3)=z_box_min - Roots(2,3)=z_box_max - If (z_box_max*z_box_min.lt.Zero) Then - nz_Roots=3 - Roots(3,3)=Zero - Else - nz_Roots=2 - End If -* -* Check all stationary points -* - Do ix = 1, nx_Roots - x = Roots(ix,1) - Do iy = 1, ny_Roots - y = Roots(iy,2) - Do iz = 1, nz_Roots - z = Roots(iz,3) -* - r=Sqrt(x**2+y**2+z**2) -* - R_Box_Max=Max(R_Box_Max,r) - R_Box_Min=Min(R_Box_Min,r) -* - End Do - End Do - End Do -* - If (Abs(R_Box_Min).lt.1.0D-12) R_Box_Min=Zero - R_Box_Max=R_Box_Max+1.0D-15 -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - write(6,*) 'Get_Subblock ----> Subblock' -#endif -c -c Note that in gradient calculations we process the grid points -c for each atomic grid seperately in order to used the -c translational invariance on the atomic contributions to the -c gradient. -c - nTotGP_Save = nTotGP - Call Subblock(iNQ,x_NQ,y_NQ,z_NQ,InBox(iNQ), - & x_min_,x_max_, y_min_,y_max_, z_min_,z_max_, - & list_p,nlist_p,Grid,Weights,mGrid,.True., - & number_of_grid_points,R_Box_Min,R_Box_Max, - & iList_p,xyz0,NQ_Data(iNQ)%Angular,nR_Eff(iNQ)) - nTotGP = nTotGP_Save -* -#ifdef _DEBUGPRINT_ - write(6,*) 'Subblock ----> Get_Subblock' -#endif - End Do - GridInfo(1,ixyz)=iDisk_Grid - GridInfo(2,ixyz)=nBatch - Call iDaFile(Lu_Grid,1,iBatchInfo,3*nBatch,iDisk_Grid) -* * -************************************************************************ -* * -* Process grid points on file -* - 997 Continue -* - iDisk_Grid =GridInfo(1,ixyz) - nBatch=GridInfo(2,ixyz) - Call iDaFile(Lu_Grid,2,iBatchInfo,3*nBatch,iDisk_Grid) -* - iBatch = 0 - nogp=0 - 888 Continue - iBatch = iBatch + 1 - If (iBatch.gt.nBatch) Go To 996 - 887 Continue - jDisk_Grid= iBatchInfo(1,iBatch) - number_of_grid_points=iBatchInfo(2,iBatch) -* - iNQ= iBatchInfo(3,iBatch) -#ifdef _DEBUGPRINT_ - Write (6,*) - Write (6,*) 'iNQ=',iNQ - Write (6,*) -#endif - ilist_p=-1 - Do klist_p = 1, nlist_p - If (List_p(klist_p).eq.iNQ) ilist_p=klist_p - End Do -* - If (nogp+number_of_grid_points.le.mGrid) Then - Call dDaFile(Lu_Grid,2,Grid(1,nogp+1), - & 3*number_of_grid_points,jDisk_Grid) - Call dDaFile(Lu_Grid,2,Weights(nogp+1), - & number_of_grid_points,jDisk_Grid) - nogp = nogp+number_of_grid_points -* -* If this is not a gradient evaluation read next buffer if the -* current one is not the last one. -* - More_to_Come=.False. - If (.Not.Do_Grad.and.iBatch.ne.nBatch) Go To 888 - Else - More_to_Come=.True. - End If -* -* Here if it is a gradient evaluation or we have a buffer to -* process. -* - If (Do_Grad) Then - Call ICopy(nGrad_Eff,[On],0,iTab(2,1),4) - If (Grid_Type.eq.Moving_Grid) Then - Do iGrad = 1, nGrad_Eff - jNQ = iTab(3,iGrad) - If (iNQ.eq.jNQ) iTab(2,iGrad)=Off - End Do -* -*------------- Generate derivative with respect to the weights -* if needed. -* - Call dWdR(Grid,ilist_p,Weights,list_p,nlist_p, - & dW_dR,nGrad_Eff,iTab,dW_Temp, - & dPB,number_of_grid_points) - End If - End If -* - Call mma_Allocate(TabAO,mAO,nogp,nBfn,Label='TabAO') - If (Do_Grad) Call mma_Allocate(TabAO_Short,kAO,nogp,nBfn, - & Label='TabAO_Short') - TabAO_Pack(1:mAO*nogp*nBfn) => TabAO(:,:,:) - If (Do_Grad) Then - Call mma_allocate(dRho_dR,mdRho_dR,nogp, - & nGrad_eff,Label='dRho_dR') - Else - Call mma_allocate(dRho_dR,1,1,1,Label='dRho_dR') - End If - - Call Do_Batch(Kernel,Func,nogp,list_s,nlist_s,List_Exp, - & List_Bas,Index,nIndex,FckInt,nFckDim,nFckInt, - & mAO,nD,nP2_ontop,Do_Mo,TabMO,TabSO,nMOs, - & Do_Grad,Grad,nGrad,mdRho_dR,nGrad_Eff,iNQ, - & EG_OT,nTmpPUVX,PDFTPot1,PDFTFocI,PDFTFocA) -* - If (Allocated(dRho_dR)) Call mma_deallocate(dRho_dR) - If (Allocated(TabAO_Short)) Call mma_deallocate(TabAO_Short) - TabAO_Pack => Null() - Call mma_deallocate(TabAO) - - nTotGP=nTotGP+nogp -* update the "LuGridFile": - do i=1,nogp - write(LuGridFile,'(3ES24.14,1x,ES24.14)') - & (Grid(l,i),l=1,3), Weights(i) - enddo - nogp=0 - If (More_To_Come) Go To 887 - Go To 888 - 996 Continue -* -* * -************************************************************************ -* * - 998 Continue -* -* * -************************************************************************ -* * - Call mma_deAllocate(Index) - If (Allocated(TabMO)) Call mma_deallocate(TabMO) - If (Allocated(TabSO)) Call mma_deallocate(TabSO) - If (Do_Grad.and.Grid_Type.eq.Moving_Grid) Then - Call mma_deAllocate(dPB) - Call mma_deAllocate(dW_Temp) - Call mma_deAllocate(dW_dR) - End If -* * -************************************************************************ -* * - End diff -Nru openmolcas-22.02/src/nq_util/get_subblock.F90 openmolcas-22.10/src/nq_util/get_subblock.F90 --- openmolcas-22.02/src/nq_util/get_subblock.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/get_subblock.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,647 @@ +!********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1999, Roland Lindh * +!*********************************************************************** + +subroutine Get_Subblock(Kernel,Func,ixyz,Maps2p,list_s,list_exp,list_bas,nShell,nSym,list_p,nNQ,FckInt,nFckDim,nFckInt,nD,mGrid, & + nP2_ontop,Do_Mo,Do_Grad,Grad,nGrad,mAO,mdRho_dR,EG_OT,nTmpPUVX,PDFTPot1,PDFTFocI,PDFTFocA) +!*********************************************************************** +! * +! Object: to generate the list of the shell and exponent that have an * +! influence on a subblock * +! * +! Called from: Drvnq_ * +! * +! Author: Roland Lindh, * +! Dept of Chemical Physics, * +! University of Lund, Sweden * +! August 1999 * +!*********************************************************************** + +use iSD_data, only: iSD +use Basis_Info, only: Shells +use Center_Info, only: dc +use nq_Grid, only: dRho_dR, dW_dR, Grid, IndGrd, iTab, kAO, List_G, nR_Eff, R2_trial, TabAO, TabAO_Pack, TabAO_Short, Weights +use NQ_Structure, only: NQ_Data +use nq_MO, only: nMOs +use nq_Info, only: Block_Size, Grid_Type, Moving_Grid, nPot1, nTotGP, nx, ny, nz, Off, On, Threshold, x_min, y_min, z_min +use Grid_On_Disk, only: Grid_Status, GridInfo, iBatchInfo, iDisk_Grid, Lu_Grid, LuGridFile, nBatch, nBatch_Max, Use_Old +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp +!#define _DEBUGPRINT_ +!#define _ANALYSIS_ +#if defined(_DEBUGPRINT_) || defined(_ANALYSIS_) +use Definitions, only: u6 +#endif + +implicit none +external :: Kernel +integer(kind=iwp), intent(in) :: ixyz, nShell, nSym, Maps2p(nShell,0:nSym-1), nNQ, nFckDim, nFckInt, nD, mGrid, nP2_ontop, nGrad, & + mAO, mdRho_dR, nTmpPUVX +real(kind=wp), intent(inout) :: Func, FckInt(nFckInt,nFckDim), Grad(nGrad), EG_OT(nTmpPUVX), PDFTPot1(nPot1), PDFTFocI(nPot1), & + PDFTFocA(nPot1) +integer(kind=iwp), intent(out) :: list_s(2,*), list_exp(nSym*nShell), list_bas(2,nSym*nShell), list_p(nNQ) +logical(kind=iwp), intent(in) :: Do_Mo, Do_Grad +integer(kind=iwp) :: i, iAng, iBatch, iCar, iCmp, iExp, iGrad, iIndex, ilist_p, ilist_s, iNQ, iPseudo, iShell, iShll, iSkal, iSym, & + ix, iy, iyz, iz, jDisk_Grid, jlist_s, jNQ, jShell, jSym, klist_p, kNQ, mdci, nAOs, nAOs_Eff, nBfn, nDegi, & + nExpTmp, nGrad_Eff, nIndex, nlist_p, nlist_s, nogp, NrBas, NrBas_Eff, NrExp, nTabMO, nTabSO, nTotGP_Save, & + number_of_grid_points, nx_Roots, ny_Roots, nz_Roots +real(kind=wp) :: r, R_Box_Max, R_Box_Min, RMax, RMax_NQ, Roots(3,3), t1, t2, t3, ValExp, X, x_box_max, x_box_min, x_max_, x_min_, & + x_NQ, Xref, xyz0(3,2), y, y_box_max, y_box_min, y_max_, y_min_, y_NQ, z, z_box_max, z_box_min, z_max_, z_min_, z_NQ +logical(kind=iwp) :: More_to_come +integer(kind=iwp), allocatable :: Indx(:) +real(kind=wp), allocatable :: dPB(:,:,:), dW_Temp(:,:), TabMO(:), TabSO(:) +logical(kind=iwp), allocatable :: InBox(:) +integer(kind=iwp), external :: nBas_Eff, NrOpr +real(kind=wp), external :: Eval_RMax + +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +write(u6,*) 'Enter Get_Subblock' +#endif + +! Resolve triplet index + +iyz = 1+(ixyz-1)/nx +ix = ixyz-(iyz-1)*nx +iz = 1+(iyz-1)/ny +iy = iyz-(iz-1)*ny + +! Get the extreme coordinates of the box. + +x_min_ = x_min+real(ix-2,kind=wp)*Block_Size +x_max_ = x_min_+Block_Size +y_min_ = y_min+real(iy-2,kind=wp)*Block_Size +y_max_ = y_min_+Block_Size +z_min_ = z_min+real(iz-2,kind=wp)*Block_Size +z_max_ = z_min_+Block_Size +if (ix == 1) x_min_ = -1.0e99_wp +if (ix == nx) x_max_ = 1.0e99_wp +if (iy == 1) y_min_ = -1.0e99_wp +if (iy == ny) y_max_ = 1.0e99_wp +if (iz == 1) z_min_ = -1.0e99_wp +if (iz == nz) z_max_ = 1.0e99_wp + +#ifdef _DEBUGPRINT_ +write(u6,*) +write(u6,*) 'Block_Size=',Block_Size +write(u6,*) 'ix,iy,iz=',ix,iy,iz +write(u6,*) 'x_min_,x_max_',x_min_,x_max_ +write(u6,*) 'y_min_,y_max_',y_min_,y_max_ +write(u6,*) 'z_min_,z_max_',z_min_,z_max_ +write(u6,*) 'nNQ=',nNQ +#endif +! * +!*********************************************************************** +!*********************************************************************** +! * +! Generate list over atoms which contribute to the subblock. +! * +!*********************************************************************** +! * +ilist_p = 0 +call mma_allocate(InBox,nNQ,Label='InBox') +do iNQ=1,nNQ + InBox(iNQ) = .false. + ! Get the coordinates of the partitionning + x_NQ = NQ_Data(iNQ)%Coor(1) + y_NQ = NQ_Data(iNQ)%Coor(2) + z_NQ = NQ_Data(iNQ)%Coor(3) + + ! 1) center is in the box + + if ((x_NQ >= x_min_) .and. (x_NQ <= x_max_) .and. (y_NQ >= y_min_) .and. (y_NQ <= y_max_) .and. & + (z_NQ >= z_min_) .and. (z_NQ <= z_max_)) then + InBox(iNQ) = .true. + ilist_p = ilist_p+1 + list_p(ilist_p) = iNQ + else + + ! 2) atomic grid of this center extends inside the box. + + RMax = NQ_Data(iNQ)%R_Max + t1 = (x_NQ-x_min_)/(x_max_-x_min_) + if (t1 < Zero) t1 = Zero + if (t1 > One) t1 = One + t2 = (y_NQ-y_min_)/(y_max_-y_min_) + if (t2 < Zero) t2 = Zero + if (t2 > One) t2 = One + t3 = (z_NQ-z_min_)/(z_max_-z_min_) + if (t3 < Zero) t3 = Zero + if (t3 > One) t3 = One + R2_Trial(iNQ) = (x_NQ-(x_max_-x_min_)*t1-x_min_)**2+(y_NQ-(y_max_-y_min_)*t2-y_min_)**2+(z_NQ-(z_max_-z_min_)*t3-z_min_)**2 + if (R2_Trial(iNQ) <= RMax**2) then + ilist_p = ilist_p+1 + list_p(ilist_p) = iNQ + end if + end if +end do +nlist_p = ilist_p +if (nlist_p == 0) then + call mma_deallocate(InBox) + return +end if +#ifdef _DEBUGPRINT_ +write(u6,*) 'Get_Subblock: List_p:',List_p +#endif +! * +!*********************************************************************** +!*********************************************************************** +! * +! Generate list over shells which contribute to the subblock. * +! * +!*********************************************************************** +! * +ilist_s = 0 +do iShell=1,nShell +# ifdef _DEBUGPRINT_ + write(u6,*) 'iShell,nShell=',iShell,nShell +# endif + NrExp = iSD(5,iShell) + iAng = iSD(1,iShell) + iShll = iSD(0,iShell) + NrBas = iSD(3,iShell) + mdci = iSD(10,iShell) + nDegi = nSym/dc(mdci)%nStab + + do jSym=0,nDegi-1 + iSym = dc(mdci)%iCoSet(jSym,0) +# ifdef _DEBUGPRINT_ + write(u6,*) 'iSym,nDegi-1=',iSym,nDegi-1 +# endif + + iNQ = Maps2p(iShell,NrOpr(iSym)) + RMax_NQ = NQ_Data(iNQ)%R_Max +# ifdef _DEBUGPRINT_ + write(u6,*) 'iNQ=',iNQ + write(u6,*) 'RMax_NQ=',RMax_NQ + write(u6,*) 'InBox(iNQ)=',InBox(iNQ) +# endif + + ! 1) the center of this shell is inside the box + + if (InBox(iNQ)) then + ilist_s = ilist_s+1 + list_s(1,ilist_s) = iShell + list_s(2,ilist_s) = iSym + list_exp(ilist_s) = NrExp + list_bas(1,ilist_s) = NrBas +# ifdef _ANALYSIS_ + write(u6,*) ' Shell is in box, ilist_s: ',ilist_s +# endif + else +# ifdef _DEBUGPRINT_ + write(u6,*) 'Passed here!' + write(u6,*) 'Threshold:',Threshold +# endif + + ! 2) the Gaussian has a grid point which extends inside the + ! box. The Gaussians are ordered from the most diffuse to + ! the most contracted. + + nExpTmp = 0 + do iExp=1,NrExp + ! Get the value of the exponent + ValExp = Shells(iShll)%Exp(iExp) + ! If the exponent has an influence then increase the + ! number of actives exponents for this shell, else + ! there is no other active exponent (they are ordered) + RMax = min(Eval_RMax(ValExp,iAng,Threshold),RMax_NQ) +# ifdef _DEBUGPRINT_ + write(u6,*) 'iShell,iNQ=',iShell,iNQ + write(u6,*) 'ValExp,iExp=',ValExp,iExp + write(u6,*) 'RMax_NQ=',RMax_NQ + write(u6,*) 'RMax_Exp=',Eval_RMax(ValExp,iAng,Threshold) + write(u6,*) 'RMax=',RMax + write(u6,*) 'R2_Trial(iNQ),RMax**2=',R2_Trial(iNQ),RMax**2 +# endif + if (R2_Trial(iNQ) > RMax**2) exit + nExpTmp = nExpTmp+1 + end do ! iExp + if (nExpTmp /= 0) then + ilist_s = ilist_s+1 + list_s(1,ilist_s) = iShell + list_s(2,ilist_s) = iSym + list_exp(ilist_s) = nExpTmp + + ! Examine if contracted basis functions can be ignored. + ! This will be the case for segmented basis sets. + + list_bas(1,ilist_s) = nBas_Eff(NrExp,NrBas,Shells(iShll)%pCff,list_exp(ilist_s)) +# ifdef _ANALYSIS_ + write(u6,*) ' Shell is included, ilist_s: ',ilist_s + write(u6,*) ' nExpTmp=',nExpTmp + write(u6,*) 'R2_Trial(iNQ),RMax**2=',R2_Trial(iNQ),RMax**2 +# endif + end if + end if + end do ! iSym +end do ! iShell +nlist_s = ilist_s +#ifdef _DEBUGPRINT_ +write(u6,*) 'nList_s,nList_p=',nList_s,nList_p +#endif +if (nList_s*nList_p == 0) then + call mma_deallocate(InBox) + return +end if +! * +!*********************************************************************** +! * +! Generate index arrays to address the density matrix, which is in +! the full shell and the reduced shell over which in the basis +! functions will be evaluated. + +nIndex = 0 +do ilist_s=1,nlist_s + iShell = list_s(1,ilist_s) + NrBas_Eff = list_bas(1,ilist_s) + iCmp = iSD(2,iShell) + nIndex = nIndex+NrBas_Eff*iCmp +end do + +call mma_allocate(Indx,nIndex,Label='Indx') + +iIndex = 1 +nAOs = 0 +nAOs_Eff = 0 +do ilist_s=1,nlist_s + iShell = list_s(1,ilist_s) + NrBas = iSD(3,iShell) + NrBas_Eff = list_bas(1,ilist_s) + iCmp = iSD(2,iShell) + nAOs = nAOs+NrBas*iCmp + nAOs_Eff = nAOs_Eff+NrBas_Eff*iCmp + list_bas(2,ilist_s) = iIndex + call Do_Index(Indx(iIndex),NrBas,NrBas_Eff,iCmp) + iIndex = iIndex+NrBas_Eff*iCmp +end do +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +write(u6,*) 'Contribution to the subblock :' +write(u6,*) 'NQ :',(list_p(ilist_p),ilist_p=1,nlist_p) +write(u6,*) 'Sh :',(list_s(1,ilist_s),ilist_s=1,nlist_s) +write(u6,*) ' :',(list_s(2,ilist_s),ilist_s=1,nlist_s) +write(u6,*) 'Exp:',(list_exp(ilist_s),ilist_s=1,nlist_s) +#endif + +nBfn = 0 +do iList_s=1,nList_s + iSkal = list_s(1,ilist_s) + NrBas_Eff = list_bas(1,ilist_s) + iCmp = iSD(2,iSkal) + nBfn = nBfn+NrBas_Eff*iCmp +end do + +if (Do_MO) then + nTabMO = mAO*nMOs*mGrid + nTabSO = mAO*nMOs*mGrid +else + nTabMO = 1 + nTabSO = 1 +end if +call mma_allocate(TabMO,nTabMO,Label='TabMO') +call mma_allocate(TabSO,nTabSO,Label='TabSO') +! * +!*********************************************************************** +! * +! Generate indexation of which shells contributes to which centers +! and center index for each gradient contribution which is computed. + +nGrad_Eff = 0 +if (Do_Grad) then + List_G(:,:) = 0 + do ilist_s=1,nlist_s + iShell = list_s(1,ilist_s) + iSym = list_s(2,ilist_s) + mdci = iSD(10,iShell) + iNQ = Maps2p(iShell,NrOpr(iSym)) + do iCar=0,2 + if (((iSD(16+iCar,iShell) /= 0) .or. (iSD(12,iShell) == 1)) .and. (List_G(1+iCar,ilist_s) == 0)) then + nGrad_Eff = nGrad_Eff+1 + + ! For pseudo centers note that there will not be a + ! gradient computed for this center. + + iPseudo = iSD(12,iShell) + if (iPseudo == 0) then + IndGrd(nGrad_Eff) = iSD(16+iCar,iShell) + else + IndGrd(nGrad_Eff) = -1 + end if + List_G(1+iCar,ilist_s) = nGrad_Eff + iTab(1,nGrad_Eff) = iCar+1 + iTab(3,nGrad_Eff) = iNQ + kNQ = Maps2p(iShell,0) + Xref = NQ_Data(kNQ)%Coor(iCar+1) + X = NQ_Data(iNQ)%Coor(iCar+1) + if (X == Xref) then + iTab(4,nGrad_Eff) = dc(mdci)%nStab + else + iTab(4,nGrad_Eff) = -dc(mdci)%nStab + end if + + ! Find all other shells which contribute to the same gradient. + + do jlist_s=ilist_s+1,nlist_s + jShell = list_s(1,jlist_s) + if ((iSD(16+iCar,iShell) == iSD(16+iCar,jShell)) .and. (iSym == list_s(2,jlist_s))) then + List_G(1+iCar,jlist_s) = nGrad_Eff + end if + end do + + else if ((iSD(16+iCar,iShell) == 0) .and. (List_G(1+iCar,ilist_s) == 0)) then + + ! Include derivatives which will be used for + ! the translational invariance equation but which do not + ! contribute directly to a symmetry adapted gradient + + nGrad_Eff = nGrad_Eff+1 + IndGrd(nGrad_Eff) = -1 + List_G(1+iCar,ilist_s) = nGrad_Eff + iTab(1,nGrad_Eff) = iCar+1 + iTab(3,nGrad_Eff) = iNQ + iTab(4,nGrad_Eff) = dc(mdci)%nStab + + ! Find all other shells which contribute to the same gradient. + + do jlist_s=ilist_s+1,nlist_s + jShell = list_s(1,jlist_s) + jSym = list_s(2,jlist_s) + jNQ = Maps2p(jShell,NrOpr(jSym)) + if (iNQ == jNQ) then + List_G(1+iCar,jlist_s) = nGrad_Eff + end if + end do + end if + end do + end do + + if (Grid_Type == Moving_Grid) then + call mma_allocate(dW_dR,nGrad_Eff,mGrid,Label='dW_dR') + call mma_allocate(dW_Temp,3,nList_P,Label='dW_Temp') + call mma_allocate(dPB,3,nlist_p,nlist_p,Label='dPB') + end if +end if +if ((.not. Do_Grad) .or. (nGrad_Eff /= 0)) then + if (Grid_Status /= Use_Old) then + call mma_allocate(iBatchInfo,3,nBatch_Max,label='iBatchInfo') + iBatchInfo(:,:) = 0 + ! * + !******************************************************************* + !******************************************************************* + ! * + ! For each partition active in the subblock create the grid + ! and perform the integration on it. + ! * + !******************************************************************* + ! * + number_of_grid_points = 0 + nBatch = 0 + do ilist_p=1,nlist_p + iNQ = list_p(ilist_p) +# ifdef _DEBUGPRINT_ + write(u6,*) 'ilist_p=',ilist_p + write(u6,*) 'Get_SubBlock: iNQ=',iNQ +# endif + + ! Select which gradient contributions that should be computed. + ! For basis functions which have the center common with the grid + ! do not compute any contribution. + + if (Do_Grad) then + iTab(2,1:nGrad_Eff) = On + if (Grid_Type == Moving_Grid) then + do iGrad=1,nGrad_Eff + jNQ = iTab(3,iGrad) + if (iNQ == jNQ) iTab(2,iGrad) = Off + end do + end if +# ifdef _DEBUGPRINT_ + write(u6,*) + write(u6,'(A,24I3)') ' i =',(i,i=1,nGrad_Eff) + write(u6,'(A,24I3)') 'iTab(1,i)=',(iTab(1,i),i=1,nGrad_Eff) + write(u6,'(A,24I3)') 'iTab(2,i)=',(iTab(2,i),i=1,nGrad_Eff) + write(u6,'(A,24I3)') 'iTab(3,i)=',(iTab(3,i),i=1,nGrad_Eff) + write(u6,'(A,24I3)') 'iTab(4,i)=',(iTab(4,i),i=1,nGrad_Eff) + write(u6,*) 'IndGrd=',IndGrd + write(u6,*) +# endif + + end if + + ! Get the coordinates of the partition + x_NQ = NQ_Data(iNQ)%Coor(1) + y_NQ = NQ_Data(iNQ)%Coor(2) + z_NQ = NQ_Data(iNQ)%Coor(3) + ! Get the maximum radius on which we have to integrate for the partition + RMax = NQ_Data(iNQ)%R_Max + + call Box_On_Sphere(x_Min_-x_NQ,x_Max_-x_NQ,y_Min_-y_NQ,y_Max_-y_NQ,z_Min_-z_NQ,z_Max_-z_NQ,xyz0(1,1),xyz0(1,2),xyz0(2,1), & + xyz0(2,2),xyz0(3,1),xyz0(3,2)) + ! * + !***************************************************************** + ! * + ! Establish R_Box_Max and R_Box_Min, the longest and the shortest + ! distance from the origin of the atomic grid to a point in the box + + R_Box_Max = Zero + R_Box_Min = RMax + + x_box_min = x_min_-x_NQ + x_box_max = x_max_-x_NQ + y_box_min = y_min_-y_NQ + y_box_max = y_max_-y_NQ + z_box_min = z_min_-z_NQ + z_box_max = z_max_-z_NQ + + Roots(1,1) = x_box_min + Roots(2,1) = x_box_max + if (x_box_max*x_box_min < Zero) then + nx_Roots = 3 + Roots(3,1) = Zero + else + nx_Roots = 2 + end if + + Roots(1,2) = y_box_min + Roots(2,2) = y_box_max + if (y_box_max*y_box_min < Zero) then + ny_Roots = 3 + Roots(3,2) = Zero + else + ny_Roots = 2 + end if + + Roots(1,3) = z_box_min + Roots(2,3) = z_box_max + if (z_box_max*z_box_min < Zero) then + nz_Roots = 3 + Roots(3,3) = Zero + else + nz_Roots = 2 + end if + + ! Check all stationary points + + do ix=1,nx_Roots + x = Roots(ix,1) + do iy=1,ny_Roots + y = Roots(iy,2) + do iz=1,nz_Roots + z = Roots(iz,3) + + r = sqrt(x**2+y**2+z**2) + + R_Box_Max = max(R_Box_Max,r) + R_Box_Min = min(R_Box_Min,r) + + end do + end do + end do + + if (abs(R_Box_Min) < 1.0e-12_wp) R_Box_Min = Zero + R_Box_Max = R_Box_Max+1.0e-15_wp + ! * + !***************************************************************** + ! * +# ifdef _DEBUGPRINT_ + write(u6,*) 'Get_Subblock ----> Subblock' +# endif + + ! Note that in gradient calculations we process the grid points for + ! each atomic grid seperately in order to used the translational + ! invariance on the atomic contributions to the gradient. + + nTotGP_Save = nTotGP + call Subblock(iNQ,x_NQ,y_NQ,z_NQ,InBox(iNQ),x_min_,x_max_,y_min_,y_max_,z_min_,z_max_,list_p,nlist_p,Grid,Weights,mGrid, & + .true.,number_of_grid_points,R_Box_Min,R_Box_Max,iList_p,xyz0,NQ_Data(iNQ)%Angular,nR_Eff(iNQ)) + nTotGP = nTotGP_Save + +# ifdef _DEBUGPRINT_ + write(u6,*) 'Subblock ----> Get_Subblock' +# endif + end do + GridInfo(1,ixyz) = iDisk_Grid + GridInfo(2,ixyz) = nBatch + call iDaFile(Lu_Grid,1,iBatchInfo,3*nBatch,iDisk_Grid) + call mma_deallocate(iBatchInfo) + end if + ! * + !********************************************************************* + ! * + ! Process grid points on file + + iDisk_Grid = GridInfo(1,ixyz) + nBatch = GridInfo(2,ixyz) + call mma_allocate(iBatchInfo,3,nBatch,label='iBatchInfo') + call iDaFile(Lu_Grid,2,iBatchInfo,3*nBatch,iDisk_Grid) + + iBatch = 0 + nogp = 0 + outer: do + iBatch = iBatch+1 + if (iBatch > nBatch) exit outer + do + jDisk_Grid = iBatchInfo(1,iBatch) + number_of_grid_points = iBatchInfo(2,iBatch) + + iNQ = iBatchInfo(3,iBatch) +# ifdef _DEBUGPRINT_ + write(u6,*) + write(u6,*) 'iNQ=',iNQ + write(u6,*) +# endif + ilist_p = -1 + do klist_p=1,nlist_p + if (List_p(klist_p) == iNQ) ilist_p = klist_p + end do + + if (nogp+number_of_grid_points <= mGrid) then + call dDaFile(Lu_Grid,2,Grid(1,nogp+1),3*number_of_grid_points,jDisk_Grid) + call dDaFile(Lu_Grid,2,Weights(nogp+1),number_of_grid_points,jDisk_Grid) + nogp = nogp+number_of_grid_points + + ! If this is not a gradient evaluation read next buffer if the + ! current one is not the last one. + + More_to_Come = .false. + if ((.not. Do_Grad) .and. (iBatch /= nBatch)) cycle outer + else + More_to_Come = .true. + end if + + ! Here if it is a gradient evaluation or we have a buffer to process. + + if (Do_Grad) then + iTab(2,1:nGrad_Eff) = On + if (Grid_Type == Moving_Grid) then + do iGrad=1,nGrad_Eff + jNQ = iTab(3,iGrad) + if (iNQ == jNQ) iTab(2,iGrad) = Off + end do + + ! Generate derivative with respect to the weights if needed. + + call dWdR(Grid,ilist_p,Weights,list_p,nlist_p,dW_dR,nGrad_Eff,iTab,dW_Temp,dPB,number_of_grid_points) + end if + end if + + call mma_allocate(TabAO,mAO,nogp,nBfn,Label='TabAO') + if (Do_Grad) call mma_allocate(TabAO_Short,kAO,nogp,nBfn,Label='TabAO_Short') + TabAO_Pack(1:mAO*nogp*nBfn) => TabAO(:,:,:) + if (Do_Grad) then + call mma_allocate(dRho_dR,mdRho_dR,nogp,nGrad_eff,Label='dRho_dR') + else + call mma_allocate(dRho_dR,1,1,1,Label='dRho_dR') + end if + + call Do_Batch(Kernel,Func,nogp,list_s,nlist_s,List_Exp,List_Bas,Indx,nIndex,FckInt,nFckDim,nFckInt,mAO,nD,nP2_ontop,Do_Mo, & + TabMO,TabSO,nMOs,Do_Grad,Grad,nGrad,mdRho_dR,nGrad_Eff,iNQ,EG_OT,nTmpPUVX,PDFTPot1,PDFTFocI,PDFTFocA) + + if (allocated(dRho_dR)) call mma_deallocate(dRho_dR) + if (allocated(TabAO_Short)) call mma_deallocate(TabAO_Short) + TabAO_Pack => null() + call mma_deallocate(TabAO) + + nTotGP = nTotGP+nogp + ! update the "LuGridFile": + do i=1,nogp + write(LuGridFile,'(3ES24.14,1x,ES24.14)') Grid(:,i),Weights(i) + end do + nogp = 0 + if (.not. More_To_Come) exit + end do + end do outer + call mma_deallocate(iBatchInfo) +end if +! * +!*********************************************************************** +! * +call mma_deallocate(InBox) +call mma_deallocate(Indx) +if (allocated(TabMO)) call mma_deallocate(TabMO) +if (allocated(TabSO)) call mma_deallocate(TabSO) +if (Do_Grad .and. (Grid_Type == Moving_Grid)) then + call mma_deallocate(dPB) + call mma_deallocate(dW_Temp) + call mma_deallocate(dW_dR) +end if +! * +!*********************************************************************** +! * + +end subroutine Get_Subblock diff -Nru openmolcas-22.02/src/nq_util/g.F90 openmolcas-22.10/src/nq_util/g.F90 --- openmolcas-22.02/src/nq_util/g.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/g.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,43 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +function G(Arg) + +use Constants, only: One, Half, Quart, Pi +use Definitions, only: wp + +implicit none +real(kind=wp) :: G +real(kind=wp), intent(in) :: Arg +real(kind=wp) :: Arg_, rG + +g = -1.0e3_wp + +Arg_ = real(int(Arg),kind=wp) +if (abs(Arg-Arg_) < Quart) then + ! Integer argument + G = One + rG = One +else + ! Fractional argument + G = sqrt(Pi) + rG = Half +end if + +do + if (abs(rG-Arg) < Quart) exit + G = rG*G + rG = rG+One +end do + +return + +end function G diff -Nru openmolcas-22.02/src/nq_util/ggl_grid.f openmolcas-22.10/src/nq_util/ggl_grid.f --- openmolcas-22.02/src/nq_util/ggl_grid.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/ggl_grid.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,54 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine GGL_Grid(L_Max) -************************************************************************ -* * -* Computes datas useful for the angular quadrature. * -* * -************************************************************************ - use nq_Structure, only: Info_Ang - use nq_Info - Implicit Real*8 (a-h,o-z) -#include "real.fh" -* * -************************************************************************ -* * - Interface - Subroutine Do_GGL(L_Eff,nPoints,R) - Implicit None - Integer L_Eff, nPoints - Real*8, Allocatable:: R(:,:) - End Subroutine Do_GGL - End Interface -* * -************************************************************************ -* * -* Generate angular grid from Gauss and Gauss-Legendre quadrature -* -*---- Theta (polar angle): 0 =< theta =< pi -* Gauss-Legendre Quadrature (L_Quad+1)/2 points -*---- Phi (azimuthal angle): 0=< phi =< 2*pi -* Gauss-Quadrature (L_Quad+1) points -* - Do L_Eff = 1, L_Max - nAngularGrids=nAngularGrids+1 -* - Info_Ang(nAngularGrids)%L_eff=L_eff - Call Do_GGL(L_Eff, - & Info_Ang(nAngularGrids)%nPoints, - & Info_Ang(nAngularGrids)%R) -* - End Do ! L_Eff -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/ggl_grid.F90 openmolcas-22.10/src/nq_util/ggl_grid.F90 --- openmolcas-22.02/src/nq_util/ggl_grid.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/ggl_grid.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,51 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine GGL_Grid(L_Max) +!*********************************************************************** +! * +! Computes data useful for the angular quadrature. * +! * +!*********************************************************************** + +use do_grid, only: Do_GGL +use nq_Structure, only: Info_Ang +use nq_Info, only: nAngularGrids +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: L_Max +integer(kind=iwp) :: L_Eff + +! * +!*********************************************************************** +! * +! Generate angular grid from Gauss and Gauss-Legendre quadrature +! +!-- Theta (polar angle): 0 <= theta <= pi +! Gauss-Legendre Quadrature (L_Quad+1)/2 points +!-- Phi (azimuthal angle): 0 <= phi <= 2*pi +! Gauss-Quadrature (L_Quad+1) points + +do L_Eff=1,L_Max + nAngularGrids = nAngularGrids+1 + + Info_Ang(nAngularGrids)%L_eff = L_eff + call Do_GGL(L_Eff,Info_Ang(nAngularGrids)%nPoints,Info_Ang(nAngularGrids)%R) + +end do ! L_Eff +! * +!*********************************************************************** +! * + +return + +end subroutine GGL_Grid diff -Nru openmolcas-22.02/src/nq_util/grid_on_disk.f90 openmolcas-22.10/src/nq_util/grid_on_disk.f90 --- openmolcas-22.02/src/nq_util/grid_on_disk.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/grid_on_disk.f90 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** -Module Grid_On_Disk - Integer Regenerate, Use_Old, Grid_Status, G_S - Parameter(Regenerate=1,Use_Old=0) - Integer Intermediate, Final, Not_Specified, Old_Functional_Type, LuGridFile - Parameter (Intermediate=2, Final=1, Not_Specified=0) - Parameter(nBatch_Max=500) - Integer, Allocatable:: GridInfo(:,:) - Common /GridOnDisk/ Lu_Grid, iDisk_Grid,jDisk_Grid, & - & iBatchInfo(3,nBatch_Max), nBatch, & - & Grid_Status, G_S(2),iDisk_Set(2), & - & Old_Functional_Type,iGrid_Set,LuGridFile -End Module Grid_On_Disk diff -Nru openmolcas-22.02/src/nq_util/grid_on_disk.F90 openmolcas-22.10/src/nq_util/grid_on_disk.F90 --- openmolcas-22.02/src/nq_util/grid_on_disk.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/grid_on_disk.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,47 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +module Grid_On_Disk + +use Definitions, only: iwp + +implicit none +private + +integer(kind=iwp), parameter :: Use_Old = 0, Regenerate = 1, & + Not_Specified = 0, Final_Grid = 1, Intermediate = 2 +integer(kind=iwp) :: G_S(2), Grid_Status, iDisk_Grid, iDisk_Set(2), iGrid_Set, Lu_Grid, LuGridFile, nBatch, nBatch_Max = 128, & + Old_Functional_Type +integer(kind=iwp), allocatable :: GridInfo(:,:), iBatchInfo(:,:) + +public :: ExpandBatchInfo, Final_Grid, G_S, Grid_Status, GridInfo, iBatchInfo, iDisk_Grid, iDisk_Set, iGrid_Set, Intermediate, & + Lu_Grid, LuGridFile, nBatch, nBatch_Max, Not_Specified, Old_Functional_Type, Regenerate, Use_Old + +contains + +subroutine ExpandBatchInfo() + + use stdalloc, only: mma_allocate, mma_deallocate + + integer(kind=iwp) :: n + integer(kind=iwp), allocatable :: new_iBatchInfo(:,:) + + n = size(iBatchInfo,2) + nBatch_Max = 2*n + call mma_allocate(new_iBatchInfo,size(iBatchInfo,1),nBatch_Max,label='new_iBatchInfo') + new_iBatchInfo(:,1:n) = iBatchInfo + new_iBatchInfo(:,n+1:) = 0 + call mma_deallocate(iBatchInfo) + call move_alloc(new_iBatchInfo,iBatchInfo) + +end subroutine ExpandBatchInfo + +end module Grid_On_Disk diff -Nru openmolcas-22.02/src/nq_util/lebedev.f openmolcas-22.10/src/nq_util/lebedev.f --- openmolcas-22.02/src/nq_util/lebedev.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/lebedev.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,580 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2001, Roland Lindh * -* 2001, Laura Gagliardi * -************************************************************************ - Subroutine Lebedev(rPt, wPt, nPt, nDeg, lMax ) -************************************************************************ -* * -* Object: Numerical Gauss integrations over the unit sphere by a rule * -* with octahedral symmetry. * -* * -* Author:Roland Lindh, Department of Chemical Physics, University * -* of Lund, SWEDEN. * -* Laura Gagliardi, Dipartimento di Chimica G. Ciamician, * -* University of Bologna, ITALY. November 2001 * -* This has been readapted from the original routine by * -* Bernard Delley, Paul Scherrer Institut, Switzerland * -* Journal of Computational Chemistry 1996, 17, 1152--1155 * -************************************************************************ - use nq_Info - Implicit Real*8 (a-h,o-z) -#include "real.fh" -#include "debug.fh" -* - Integer nscheme5(8), nscheme7(8), nscheme11(8), nscheme17(8), - & nscheme23(8), nscheme29(8), nscheme35(8), nscheme41(8), - & nscheme47(8), nscheme53(8), nscheme59(8) -* - Real*8 rPt(3,nDeg), wPt(nDeg) - Real*8 pa5(2), pa7(3), pa11(5), pa17(10), pa23(16), pa35(33), - & pa29(24), pa41(44), pa47(56), pa53(70), pa59(85) -* - data nscheme5,pa5 / 5, 1, 1, 0, 0, 0, 0, 14, - & 6.6666666666666667D-02, 7.5000000000000000D-02 / -* - data nscheme7,pa7 / 7, 1, 1, 1, 0, 0, 0, 26, - & 4.7619047619047619D-02, 3.2142857142857143D-02, - & 3.8095238095238095D-02 / -* - data nscheme11,pa11 / 11, 1, 1, 1, 1, 0, 0, 50, - & 1.2698412698412698D-02, 2.1093750000000000D-02, - & 2.2574955908289242D-02, 3.0151134457776362D-01, - & 2.0173335537918871D-02 / -* - data nscheme17,pa17 / 17, 1, 1, 0, 3, 1, 0, 110, - & 3.8282704949371616D-03, 9.7937375124875125D-03, - & 1.8511563534473617D-01, 8.2117372831911110D-03, - & 3.9568947305594191D-01, 9.5954713360709628D-03, - & 6.9042104838229218D-01, 9.9428148911781033D-03, - & 4.7836902881215020D-01, 9.6949963616630283D-03 / -* - data nscheme23,pa23 / 23, 1, 1, 1, 4, 1, 1, 194, - & 1.7823404472446112D-03, 5.5733831788487380D-03, - & 5.7169059499771019D-03, 4.4469331787174373D-01, - & 5.5187714672736137D-03, 2.8924656275754386D-01, - & 5.1582377118053831D-03, 6.7129734426952263D-01, - & 5.6087040825879968D-03, 1.2993354476500669D-01, - & 4.1067770281693941D-03, 3.4577021976112827D-01, - & 5.0518460646148085D-03, 1.5904171053835295D-01, - & 5.2511857244364202D-01, 5.5302489162330937D-03 / -* - data nscheme29,pa29 / 29, 1, 1, 0, 6, 2, 2, 302, - & 8.5459117251281481D-04, 3.5991192850255715D-03, - & 7.0117664160895449D-01, 3.6500458076772554D-03, - & 6.5663294102196118D-01, 3.6048226014198817D-03, - & 4.7290541325810046D-01, 3.5767296617433671D-03, - & 3.5156403455701051D-01, 3.4497884243058833D-03, - & 2.2196452362941784D-01, 3.1089531224136753D-03, - & 9.6183085226147838D-02, 2.3521014136891644D-03, - & 5.7189558918789607D-01, 3.6008209322164603D-03, - & 2.6441528870606625D-01, 2.9823449631718039D-03, - & 2.5100347517704651D-01, 5.4486773725807738D-01, - & 3.5715405542733871D-03, 1.2335485325833274D-01, - & 4.1277240831685310D-01, 3.3923122050061702D-03 / - data nscheme35,pa35 / 35, 1, 1, 1, 7, 2, 4, 434, - & 5.2658979682244362D-04, 2.5123174189273072D-03, - & 2.5482199720026072D-03, 6.9093463075091106D-01, - & 2.5304038011863550D-03, 6.4566647074242561D-01, - & 2.5132671745975644D-03, 4.9143426377847465D-01, - & 2.5017251684029361D-03, 3.9272597633680022D-01, - & 2.4453734373129800D-03, 2.8612890103076384D-01, - & 2.3026947822274158D-03, 1.7748360546091578D-01, - & 2.0142790209185282D-03, 7.5680843671780184D-02, - & 1.4624956215946138D-03, 2.1027252285730696D-01, - & 1.9109512821795323D-03, 4.7159869115131592D-01, - & 2.4174423756389808D-03, 9.9217696364292373D-02, - & 3.3443631453434549D-01, 2.2366077604378487D-03, - & 2.0548236964030437D-01, 4.5023303825826254D-01, - & 2.4169300443247753D-03, 3.1042840351665415D-01, - & 5.5501523610768072D-01, 2.4966440545530860D-03, - & 1.0680182607580483D-01, 5.9051570489252711D-01, - & 2.5122368545634951D-03 / -#ifdef _OLDDATA_ - data nscheme41,pa41 / 41, 1, 1, 0, 8, 4, 6, 590, - & 1.0090057533787580D-04, 1.8514016873890461D-03, - & 7.0404760433146996D-01, 1.8686219518306975D-03, - & 6.8084561988024238D-01, 1.8648696345606001D-03, - & 6.3723669159418917D-01, 1.8497643975168892D-03, - & 5.0447558060926046D-01, 1.8450277740822388D-03, - & 4.2175447334398773D-01, 1.8164174988262214D-03, - & 3.3201962086729379D-01, 1.7449464690023229D-03, - & 2.3917494336556047D-01, 1.6278016126848035D-03, - & 1.4024070738935403D-01, 1.5576827519901693D-03, - & 9.1616343286052397D-02, 1.2680968886048433D-03, - & 2.0326292518419433D-01, 1.1183965414769017D-03, - & 3.9364042372978295D-01, 1.7287035120530033D-03, - & 6.1262355812929648D-01, 1.8551905629473527D-03, - & 8.9598759118937909D-02, 2.8114771623428322D-01, - & 1.4697353123693616D-03, 1.7327600238498666D-01, - & 3.8175470908581117D-01, 1.6819651914742022D-03, - & 2.6422260656245780D-01, 4.7452376478986998D-01, - & 1.7876372876796954D-03, 3.5189965873835832D-01, - & 5.6127905075920534D-01, 1.8400735685528423D-03, - & 8.8867910181862953D-02, 5.0324791996964975D-01, - & 1.8072536817113700D-03, 1.8154345643517542D-01, - & 5.9768324320748616D-01, 1.8527289739424312D-03 / -#else -c alternate solution 950704 BD - data nscheme41,pa41 / 41, 1, 1, 0, 9, 3, 6, 590, - & 3.0951212953061873D-04, 1.8523796985974890D-03, - & 6.0950341155071959D-02, 9.7643311650510500D-04, - & 1.4590364491577632D-01, 1.3847372348516919D-03, - & 2.3847367014218874D-01, 1.6172106472544112D-03, - & 3.3179207364721231D-01, 1.7495646572811541D-03, - & 4.2157617840109665D-01, 1.8184717781627688D-03, - & 5.0444197078003583D-01, 1.8467159561512418D-03, - & 6.3725469392587524D-01, 1.8520288282962131D-03, - & 6.8077440664552429D-01, 1.8588125854383170D-03, - & 7.0409549382274691D-01, 1.8717906392777438D-03, - & 1.7247820099077235D-01, 1.3003216858860477D-03, - & 3.9647553481998576D-01, 1.7051539963958640D-03, - & 6.1168434420098755D-01, 1.8571611967740780D-03, - & 8.2130215819325114D-02, 2.7786731905862443D-01, - & 1.5552136033968085D-03, 8.9992058420748749D-02, - & 5.0335642710751172D-01, 1.8022391280085255D-03, - & 1.8166408403602095D-01, 5.9841264978853796D-01, - & 1.8498305604436602D-03, 1.7207952256568781D-01, - & 3.7910354076955633D-01, 1.7139045071067087D-03, - & 2.6347166559379496D-01, 4.7423928425519802D-01, - & 1.8026589343774512D-03, 3.5182809277335190D-01, - & 5.6102638086220602D-01, 1.8428664729052856D-03 / -#endif -#ifdef _OLDDATA_ - data nscheme47,pa47 / 47, 1, 1, 1, 9, 4, 9, 770, - & 1.1685335608691628D-03, 1.4121215930643264D-03, - & 1.4468645950992776D-03, 1.1441365123336336D-01, - & 1.0478418864629224D-03, 1.9944675708548970D-01, - & 1.2392547584848484D-03, 2.8401278368259530D-01, - & 1.3259295792415379D-03, 3.6646411416548296D-01, - & 1.3756097758625958D-03, 4.4356118052513995D-01, - & 1.3999348863558624D-03, 5.1435709575333968D-01, - & 1.4096221218822673D-03, 6.3052081196671812D-01, - & 1.4108746499638577D-03, 6.7164784337293865D-01, - & 1.4134887639034478D-03, 6.9812332010174177D-01, - & 1.4366946685816802D-03, 1.2047667931264991D-01, - & 1.0901543574180667D-03, 3.0940302315480606D-01, - & 1.8691378448038514D-04, 3.4884276430183016D-01, - & 1.1284267652336505D-03, 5.3224214285417946D-01, - & 1.3844558026568455D-03, 6.6161599334370030D-02, - & 2.3249923409267532D-01, 1.1853923885095502D-03, - & 1.4568618765136356D-01, 3.2477344409682044D-01, - & 1.2949021664637693D-03, 2.2832839132127622D-01, - & 4.1056989039349425D-01, 1.3525857420363760D-03, - & 3.0714431901543855D-01, 4.9213658085114203D-01, - & 1.3925025908786082D-03, 3.8271180625074657D-01, - & 5.6548849812588755D-01, 1.4073257894372725D-03, - & 7.9707151879391904D-02, 4.3713473693946563D-01, - & 1.3128954307755017D-03, 1.5892620239864833D-01, - & 5.2320749473197761D-01, 1.3784632898490457D-03, - & 2.3667220253873893D-01, 6.0283033994386521D-01, - & 1.4125450609821936D-03, 7.9823288260308803D-02, - & 6.2037164721742807D-01, 1.4289835314095131D-03 / -#else -c alternate solution 950705 BD - data nscheme47,pa47 / 47, 1, 1, 1, 10, 3, 9, 770, - & 2.1929420881811841D-04, 1.4219403443358774D-03, - & 1.4364336173190798D-03, 5.0872044105023605D-02, - & 6.7981235110505020D-04, 1.2281987901788307D-01, - & 9.9131842352949122D-04, 2.0268908144087861D-01, - & 1.1802078332389488D-03, 2.8477451564642939D-01, - & 1.2965996020809207D-03, 3.6567190789780265D-01, - & 1.3658714274283164D-03, 4.4282648867134686D-01, - & 1.4029886047753253D-03, 5.1406196272497354D-01, - & 1.4186455635956094D-03, 6.3064012191668026D-01, - & 1.4213767418516618D-03, 6.7168833320226119D-01, - & 1.4239964754909616D-03, 6.9797926853368807D-01, - & 1.4315540421785668D-03, 1.4468656741953093D-01, - & 9.2544014998653679D-04, 3.3902634754112157D-01, - & 1.2502399950535093D-03, 5.3358046512635063D-01, - & 1.3943658433292301D-03, 6.9440243933494130D-02, - & 2.3551878942423264D-01, 1.1270890946717488D-03, - & 2.2690041095294599D-01, 4.1021824740457302D-01, - & 1.3457537609106701D-03, 8.0255746077753389D-02, - & 6.2143024174816046D-01, 1.4249572833167828D-03, - & 1.4679995278965720D-01, 3.2452843457173944D-01, - & 1.2615233412377500D-03, 1.5715077698247271D-01, - & 5.2244821896966297D-01, 1.3925471060526959D-03, - & 2.3657029931572456D-01, 6.0175466340895581D-01, - & 1.4187616778776564D-03, 7.7148158667657320D-02, - & 4.3465755161411628D-01, 1.3383666844795541D-03, - & 3.0629366662107302D-01, 4.9088265890376162D-01, - & 1.3937008626761314D-03, 3.8224773795247870D-01, - & 5.6487681490995005D-01, 1.4159147574669320D-03 / -#endif - data nscheme53,pa53 / 53, 1, 1, 0, 12, 4, 12, 974, - & 1.4382941905274311D-04, 1.1257722882870041D-03, - & 4.2929635453413471D-02, 4.9480293419492410D-04, - & 1.0514268540864042D-01, 7.3579901091254705D-04, - & 1.7500248676230874D-01, 8.8891327713043843D-04, - & 2.4776533796502568D-01, 9.8883478389214349D-04, - & 3.2065671239559574D-01, 1.0532996817094706D-03, - & 3.9165207498499835D-01, 1.0927788070145785D-03, - & 4.5908258741876237D-01, 1.1143893940632272D-03, - & 5.2145638884158605D-01, 1.1237247880515553D-03, - & 6.2531702446541989D-01, 1.1252393252438136D-03, - & 6.6379267445231699D-01, 1.1261532718159050D-03, - & 6.9104103984983007D-01, 1.1302869311238408D-03, - & 7.0529070074577603D-01, 1.1349865343639549D-03, - & 1.2366867626579899D-01, 6.8233679271099310D-04, - & 2.9407771144683870D-01, 9.4541581604470958D-04, - & 4.6977538492076491D-01, 1.0744299753856791D-03, - & 6.3345632411395669D-01, 1.1293000865691317D-03, - & 5.9740486141813418D-02, 2.0291287527775228D-01, - & 8.4368845009019544D-04, 1.3757604084736365D-01, - & 4.6026219424840539D-01, 1.0752557204488846D-03, - & 3.3910165263362857D-01, 5.0306739996620357D-01, - & 1.1085772368644620D-03, 1.2716751914398195D-01, - & 2.8176064224421343D-01, 9.5664753237833573D-04, - & 2.6931207404135125D-01, 4.3315612917201574D-01, - & 1.0806632507173907D-03, 1.4197864526019183D-01, - & 6.2561673585808142D-01, 1.1267971311962946D-03, - & 6.7092846007382550D-02, 3.7983952168591567D-01, - & 1.0225687153580612D-03, 7.0577381832561723D-02, - & 5.5175054214235205D-01, 1.1089602677131075D-03, - & 2.7838884778821546D-01, 6.0296191561591869D-01, - & 1.1227906534357658D-03, 1.9795789389174069D-01, - & 3.5896063295890958D-01, 1.0324018471174598D-03, - & 2.0873070611032740D-01, 5.3486664381354765D-01, - & 1.1072493822838539D-03, 4.0551221378728359D-01, - & 5.6749975460743735D-01, 1.1217800485199721D-03 / - data nscheme59 / 59, 1, 1, 1, 13, 4, 16, 1202/ - data (pa59(i),i=1,20) / - & 1.1051892332675715D-04, 9.1331597864435614D-04, - & 9.2052327380907415D-04, 3.7126364496570891D-02, - & 3.6904218980178990D-04, 9.1400604122622234D-02, - & 5.6039909286806603D-04, 1.5310778524699062D-01, - & 6.8652976292826086D-04, 2.1809288916606116D-01, - & 7.7203385511456304D-04, 2.8398745322001746D-01, - & 8.3015459588947951D-04, 3.4911776009637644D-01, - & 8.6866925501796284D-04, 4.1214314614443092D-01, - & 8.9270762858468901D-04, 4.7189936271491266D-01, - & 9.0608202385682188D-04, 5.2731454528423366D-01/ - data (pa59(i),i=21,40) / - & 9.1197772549408672D-04, 6.2094753324440192D-01, - & 9.1287201386041811D-04, 6.5697227118572905D-01, - & 9.1307149356917351D-04, 6.8417883090701434D-01, - & 9.1528737845541164D-04, 7.0126043301236308D-01, - & 9.1874362743216541D-04, 1.0723822154781661D-01, - & 5.1769773129656942D-04, 2.5820689594969680D-01, - & 7.3311436821014169D-04, 4.1727529553067168D-01, - & 8.4632328363799285D-04, 5.7003669117925033D-01, - & 9.0311226942539918D-04, 5.2106394770112841D-02, - & 1.7717740226153253D-01, 6.4857784531632566D-04/ - data (pa59(i),i=41,60) / - & 1.1156409571564867D-01, 2.4757164634262876D-01, - & 7.4350309109823692D-04, 1.7465516775786261D-01, - & 3.1736152466119767D-01, 8.1017314974680177D-04, - & 2.3902784793817240D-01, 3.8542911506692237D-01, - & 8.5562992573118124D-04, 3.0294669735289819D-01, - & 4.5074225931570644D-01, 8.8502823412654443D-04, - & 3.6498322605976536D-01, 5.1235184864198708D-01, - & 9.0226929384269151D-04, 4.2386447815223403D-01, - & 5.6937024984684411D-01, 9.1057602589701256D-04, - & 5.9058888532355084D-02, 3.3546162890664885D-01/ - data (pa59(i),i=61,80) / - & 7.9985278918390537D-04, 1.2172350510959870D-01, - & 4.0902684270853572D-01, 8.4833895745943309D-04, - & 1.8575051945473351D-01, 4.7853206759224352D-01, - & 8.8110481824257202D-04, 2.4941121623622365D-01, - & 5.4343035696939004D-01, 9.0100916771050857D-04, - & 3.1122759471496082D-01, 6.0311616930963100D-01, - & 9.1078135794827047D-04, 6.2662506241541695D-02, - & 4.9322211848512846D-01, 8.8032086797382601D-04, - & 1.2677748006842827D-01, 5.6321230207620997D-01, - & 9.0213422990406534D-04, 1.9060182227792370D-01/ - data (pa59(i),i=81,85) / - & 6.2698055090243917D-01, 9.1315780031894351D-04, - & 6.4245492242205886D-02, 6.3942796347491023D-01, - & 9.1580161746934653D-04 / -* - If (nDeg .le. 0) Then - Write (6,*) 'Lebedev: nDeg<=0' - Call Abend() - End If -clg Write (6,*) 'lMax =', lMax -* - If(lMax .le. 5) then - nPt = nscheme5(8) - If(nPt .gt.nDeg) then - nPt = -nPt - Else - call AnMesh( nscheme5, pa5, rPt, wPt) - Endif -* - Else If(lMax .le. 7) then - nPt = nscheme7(8) - If(nPt .gt.nDeg) then - nPt = -nPt - Else - call AnMesh( nscheme7, pa7, rPt, wPt) - Endif -* - Else If(lMax .le. 11) then - nPt = nscheme11(8) - If(nPt .gt.nDeg) then - nPt = -nPt - Else - call AnMesh( nscheme11, pa11, rPt, wPt) - Endif -* - Else If(lMax .le. 17) then - nPt = nscheme17(8) - If(nPt .gt.nDeg) then - nPt = -nPt - Else - call AnMesh( nscheme17, pa17, rPt, wPt) - Endif -* - Else If(lMax .le. 23) then - nPt = nscheme23(8) -clg write (*,*) 'nPt', nPt - If(nPt .gt.nDeg) then - nPt = -nPt - Else -clg write (*,*) 'Call AnMesh', nscheme23 - call AnMesh( nscheme23, pa23, rPt, wPt) - Endif -* - Else If(lMax .le. 29) then - nPt = nscheme29(8) - If(nPt .gt.nDeg) then - nPt = -nPt - Else - call AnMesh( nscheme29, pa29, rPt, wPt) - Endif -* - Else If(Lmax .le. 35) then - nPt = nscheme35(8) - If(nPt .gt.nDeg) then - nPt = -nPt - Else - call AnMesh( nscheme35, pa35, rPt, wPt) - Endif -* - Else If(lMax .le. 41) then - nPt = nscheme41(8) - If(nPt .gt.nDeg) then - nPt = -nPt - Else - call AnMesh( nscheme41, pa41, rPt, wPt) - Endif -* - Else If(lMax .le. 47) then - nPt = nscheme47(8) - If(nPt .gt.nDeg) then - nPt = -nPt - Else - call AnMesh( nscheme47, pa47, rPt, wPt) - Endif -* - Else If(lMax .le. 53) then - nPt = nscheme53(8) - If(nPt .gt.nDeg) then - nPt = -nPt - Else - call AnMesh( nscheme53, pa53, rPt, wPt) - Endif -* - Else If(lMax .le. 59) then - nPt = nscheme59(8) - If(nPt .gt.nDeg) then - nPt = -nPt - Else - call AnMesh( nscheme59, pa59, rPt, wPt) - Endif -* - Else -c such high order is not available here - nPt = -1 - Endif -* -clg write (*,*) 'End of Lebedev' - Return -* - End -* -* -************************************************************************ - Subroutine AnMesh( nscheme, pa, rPt, wPt) - use nq_Info - Implicit Real*8 (a-h,o-z) - Implicit Integer(i-n) -#include "real.fh" -#include "debug.fh" -#include "WrkSpc.fh" - Integer nscheme(8) - Real*8 pa(*), rPt(3,*), wPt(*) -************************************************************************ -* * -* - If (Debug) Then - Write (6,*) - Write (6,*) ' ******** The Angular Lebedev Grid ********' - Write (6,*) - Write (6,*) - End If -* - i = 0 - ip = 0 -* -* nscheme(2) -> 6 points -* -clg write (*,*) 'nscheme', (nscheme(i), i=1,8) - If(nscheme(2) .gt. 0) Then -clg write (*,*) 'nscheme(2)', nscheme(2) - ip = ip + 1 - Do ix=1,3 - Do iy=1,-1,-2 - i = i + 1 - wPt(i) = pa(ip) - Do j=1,3 - rPt(j,i) = Zero - Enddo - rPt(ix,i) = DBLE(iy) -clg write (*,*) rPt(ix,i), wPt(i) - Enddo - Enddo - Endif -* -* nscheme(3) -> 8 points -* - If(nscheme(3) .gt. 0) Then ! - c = One/sqrt(Three) - ip = ip + 1 - Do ix=1,-1,-2 - Do iy=1,-1,-2 - Do iz=1,-1,-2 - i = i + 1 - wPt(i) = pa(ip) - rPt(1,i) = DBLE(ix)*c - rPt(2,i) = DBLE(iy)*c - rPt(3,i) = DBLE(iz)*c - Enddo - Enddo - Enddo - Endif -* -* nscheme(4) -> 12 points -* - If(nscheme(4) .gt. 0) Then - c = One/sqrt(Two) - ip = ip + 1 - Do ix=1,-1,-2 - Do iy=1,-1,-2 - Do iz=1,3 - i = i + 1 - wPt(i) = pa(ip) - rPt(iz,i) = DBLE(ix)*c - j = mod(iz,3) + 1 - rPt(j,i) = DBLE(iy)*c - j = 6 - iz - j - rPt(j,i) = Zero - Enddo - Enddo - Enddo - endif -* -* 24a points -* - n1 = nscheme(5) - Do jj=1,n1 - ip = ip + 1 - uu = pa(ip) - vv = sqrt(One - Two*uu*uu) - ip = ip + 1 - Do ix=1,-1,-2 - Do iy=1,-1,-2 - Do iz=1,-1,-2 - Do j=1,3 - i = i + 1 - wPt(i) = pa(ip) - Do j1=1,3 - rPt(j1,i) = uu - Enddo - rPt(j,i) = vv - rPt(1,i) = rPt(1,i)*DBLE(ix) - rPt(2,i) = rPt(2,i)*DBLE(iy) - rPt(3,i) = rPt(3,i)*DBLE(iz) - Enddo - Enddo - Enddo - Enddo - Enddo -* -* 24b points -* - n1 = nscheme(6) - Do jj=1,n1 - ip = ip + 1 - pp = pa(ip) - qq = sqrt(One - pp*pp) - ip = ip + 1 - Do ix=1,-1,-2 - Do iy=1,-1,-2 - Do ii=0,1 - Do j=1,3 - i = i + 1 - wPt(i) = pa(ip) - j1 = mod(j+ii,3)+1 - rPt(j1,i) = pp*DBLE(ix) - j1 = mod(j+1-ii,3) + 1 - rPt(j1,i) = qq*DBLE(iy) - rPt(j,i) = zero - Enddo - Enddo - Enddo - Enddo - Enddo -* -* 48 points -* - n1 = nscheme(7) -clg write (*,*) 'i, n1 =', i, n1 - Do jj=1,n1 - ip = ip + 1 - rr = pa(ip) - ip = ip + 1 - ss = pa(ip) - tt = sqrt(One - rr*rr - ss*ss) - ip = ip + 1 - Do ix=1,-1,-2 - Do iy=1,-1,-2 - Do iz=1,-1,-2 - Do j=1,3 - Do ii=0,1 - i = i + 1 - wPt(i) = pa(ip) - rPt(j,i) = rr*DBLE(ix) - j1 = mod(j+ii,3) + 1 - rPt(j1,i) = ss*DBLE(iy) - j1 = mod(j+1-ii,3) + 1 - rPt(j1,i) = tt*DBLE(iz) -clg write (*,*) rPt(j1,i), wPt(i),j1,i - Enddo -clg write (*,*) 'Enddo1', i - Enddo -clg write (*,*) 'Enddo2', i - Enddo -clg write (*,*) 'Enddo3', i - Enddo -clg write (*,*) 'Enddo4', i - Enddo -clg write (*,*) 'Enddo5', i - Enddo -clg write (*,*) 'enddo', n1 -* * -************************************************************************ -* * -* -clg write (*,*) 'End of AnMesh' - Return - End diff -Nru openmolcas-22.02/src/nq_util/lebedev.F90 openmolcas-22.10/src/nq_util/lebedev.F90 --- openmolcas-22.02/src/nq_util/lebedev.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/lebedev.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,319 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2001, Roland Lindh * +! 2001, Laura Gagliardi * +!*********************************************************************** + +subroutine Lebedev(rPt,wPt,nPt,nDeg,lMax) +!*********************************************************************** +! * +! Object: Numerical Gauss integrations over the unit sphere by a rule * +! with octahedral symmetry. * +! * +! Author:Roland Lindh, Department of Chemical Physics, University * +! of Lund, SWEDEN. * +! Laura Gagliardi, Dipartimento di Chimica G. Ciamician, * +! University of Bologna, ITALY. November 2001 * +! This has been readapted from the original routine by * +! Bernard Delley, Paul Scherrer Institut, Switzerland * +! Journal of Computational Chemistry 1996, 17, 1152--1155 * +!*********************************************************************** + +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(out) :: nPt +integer(kind=iwp), intent(in) :: nDeg, lMax +real(kind=wp), intent(out) :: rPt(3,nDeg), wPt(nDeg) +integer(kind=iwp), parameter :: nscheme5(8) = [5,1,1,0,0,0,0,14], & + nscheme7(8) = [7,1,1,1,0,0,0,26], & + nscheme11(8) = [11,1,1,1,1,0,0,50], & + nscheme17(8) = [17,1,1,0,3,1,0,110], & + nscheme23(8) = [23,1,1,1,4,1,1,194], & + nscheme29(8) = [29,1,1,0,6,2,2,302], & + nscheme35(8) = [35,1,1,1,7,2,4,434], & +# ifdef _OLDDATA_ + nscheme41(8) = [41,1,1,0,8,4,6,590], & + nscheme47(8) = [47,1,1,1,9,4,9,770], & +# else + ! alternate solution 950704 BD + nscheme41(8) = [41,1,1,0,9,3,6,590], & + ! alternate solution 950705 BD + nscheme47(8) = [47,1,1,1,10,3,9,770], & +# endif + nscheme53(8) = [53,1,1,0,12,4,12,974], & + nscheme59(8) = [59,1,1,1,13,4,16,1202] +real(kind=wp), parameter :: pa5(2) = [6.6666666666666667e-2_wp,7.5000000000000000e-2_wp], & + pa7(3) = [4.7619047619047619e-2_wp,3.2142857142857143e-2_wp,3.8095238095238095e-2_wp], & + pa11(5) = [1.2698412698412698e-2_wp,2.1093750000000000e-2_wp,2.2574955908289242e-2_wp, & + 3.0151134457776362e-1_wp,2.0173335537918871e-2_wp], & + pa17(10) = [3.8282704949371616e-3_wp,9.7937375124875125e-3_wp,1.8511563534473617e-1_wp, & + 8.2117372831911110e-3_wp,3.9568947305594191e-1_wp,9.5954713360709628e-3_wp, & + 6.9042104838229218e-1_wp,9.9428148911781033e-3_wp,4.7836902881215020e-1_wp, & + 9.6949963616630283e-3_wp], & + pa23(16) = [1.7823404472446112e-3_wp,5.5733831788487380e-3_wp,5.7169059499771019e-3_wp, & + 4.4469331787174373e-1_wp,5.5187714672736137e-3_wp,2.8924656275754386e-1_wp, & + 5.1582377118053831e-3_wp,6.7129734426952263e-1_wp,5.6087040825879968e-3_wp, & + 1.2993354476500669e-1_wp,4.1067770281693941e-3_wp,3.4577021976112827e-1_wp, & + 5.0518460646148085e-3_wp,1.5904171053835295e-1_wp,5.2511857244364202e-1_wp, & + 5.5302489162330937e-3_wp], & + pa29(24) = [8.5459117251281481e-4_wp,3.5991192850255715e-3_wp,7.0117664160895449e-1_wp, & + 3.6500458076772554e-3_wp,6.5663294102196118e-1_wp,3.6048226014198817e-3_wp, & + 4.7290541325810046e-1_wp,3.5767296617433671e-3_wp,3.5156403455701051e-1_wp, & + 3.4497884243058833e-3_wp,2.2196452362941784e-1_wp,3.1089531224136753e-3_wp, & + 9.6183085226147838e-2_wp,2.3521014136891644e-3_wp,5.7189558918789607e-1_wp, & + 3.6008209322164603e-3_wp,2.6441528870606625e-1_wp,2.9823449631718039e-3_wp, & + 2.5100347517704651e-1_wp,5.4486773725807738e-1_wp,3.5715405542733871e-3_wp, & + 1.2335485325833274e-1_wp,4.1277240831685310e-1_wp,3.3923122050061702e-3_wp], & + pa35(33) = [5.2658979682244362e-4_wp,2.5123174189273072e-3_wp,2.5482199720026072e-3_wp, & + 6.9093463075091106e-1_wp,2.5304038011863550e-3_wp,6.4566647074242561e-1_wp, & + 2.5132671745975644e-3_wp,4.9143426377847465e-1_wp,2.5017251684029361e-3_wp, & + 3.9272597633680022e-1_wp,2.4453734373129800e-3_wp,2.8612890103076384e-1_wp, & + 2.3026947822274158e-3_wp,1.7748360546091578e-1_wp,2.0142790209185282e-3_wp, & + 7.5680843671780184e-2_wp,1.4624956215946138e-3_wp,2.1027252285730696e-1_wp, & + 1.9109512821795323e-3_wp,4.7159869115131592e-1_wp,2.4174423756389808e-3_wp, & + 9.9217696364292373e-2_wp,3.3443631453434549e-1_wp,2.2366077604378487e-3_wp, & + 2.0548236964030437e-1_wp,4.5023303825826254e-1_wp,2.4169300443247753e-3_wp, & + 3.1042840351665415e-1_wp,5.5501523610768072e-1_wp,2.4966440545530860e-3_wp, & + 1.0680182607580483e-1_wp,5.9051570489252711e-1_wp,2.5122368545634951e-3_wp], & +# ifdef _OLDDATA_ + pa41(44) = [1.0090057533787580e-4_wp,1.8514016873890461e-3_wp,7.0404760433146996e-1_wp, & + 1.8686219518306975e-3_wp,6.8084561988024238e-1_wp,1.8648696345606001e-3_wp, & + 6.3723669159418917e-1_wp,1.8497643975168892e-3_wp,5.0447558060926046e-1_wp, & + 1.8450277740822388e-3_wp,4.2175447334398773e-1_wp,1.8164174988262214e-3_wp, & + 3.3201962086729379e-1_wp,1.7449464690023229e-3_wp,2.3917494336556047e-1_wp, & + 1.6278016126848035e-3_wp,1.4024070738935403e-1_wp,1.5576827519901693e-3_wp, & + 9.1616343286052397e-2_wp,1.2680968886048433e-3_wp,2.0326292518419433e-1_wp, & + 1.1183965414769017e-3_wp,3.9364042372978295e-1_wp,1.7287035120530033e-3_wp, & + 6.1262355812929648e-1_wp,1.8551905629473527e-3_wp,8.9598759118937909e-2_wp, & + 2.8114771623428322e-1_wp,1.4697353123693616e-3_wp,1.7327600238498666e-1_wp, & + 3.8175470908581117e-1_wp,1.6819651914742022e-3_wp,2.6422260656245780e-1_wp, & + 4.7452376478986998e-1_wp,1.7876372876796954e-3_wp,3.5189965873835832e-1_wp, & + 5.6127905075920534e-1_wp,1.8400735685528423e-3_wp,8.8867910181862953e-2_wp, & + 5.0324791996964975e-1_wp,1.8072536817113700e-3_wp,1.8154345643517542e-1_wp, & + 5.9768324320748616e-1_wp,1.8527289739424312e-3_wp], & + pa47(56) = [1.1685335608691628e-3_wp,1.4121215930643264e-3_wp,1.4468645950992776e-3_wp, & + 1.1441365123336336e-1_wp,1.0478418864629224e-3_wp,1.9944675708548970e-1_wp, & + 1.2392547584848484e-3_wp,2.8401278368259530e-1_wp,1.3259295792415379e-3_wp, & + 3.6646411416548296e-1_wp,1.3756097758625958e-3_wp,4.4356118052513995e-1_wp, & + 1.3999348863558624e-3_wp,5.1435709575333968e-1_wp,1.4096221218822673e-3_wp, & + 6.3052081196671812e-1_wp,1.4108746499638577e-3_wp,6.7164784337293865e-1_wp, & + 1.4134887639034478e-3_wp,6.9812332010174177e-1_wp,1.4366946685816802e-3_wp, & + 1.2047667931264991e-1_wp,1.0901543574180667e-3_wp,3.0940302315480606e-1_wp, & + 1.8691378448038514e-4_wp,3.4884276430183016e-1_wp,1.1284267652336505e-3_wp, & + 5.3224214285417946e-1_wp,1.3844558026568455e-3_wp,6.6161599334370030e-2_wp, & + 2.3249923409267532e-1_wp,1.1853923885095502e-3_wp,1.4568618765136356e-1_wp, & + 3.2477344409682044e-1_wp,1.2949021664637693e-3_wp,2.2832839132127622e-1_wp, & + 4.1056989039349425e-1_wp,1.3525857420363760e-3_wp,3.0714431901543855e-1_wp, & + 4.9213658085114203e-1_wp,1.3925025908786082e-3_wp,3.8271180625074657e-1_wp, & + 5.6548849812588755e-1_wp,1.4073257894372725e-3_wp,7.9707151879391904e-2_wp, & + 4.3713473693946563e-1_wp,1.3128954307755017e-3_wp,1.5892620239864833e-1_wp, & + 5.2320749473197761e-1_wp,1.3784632898490457e-3_wp,2.3667220253873893e-1_wp, & + 6.0283033994386521e-1_wp,1.4125450609821936e-3_wp,7.9823288260308803e-2_wp, & + 6.2037164721742807e-1_wp,1.4289835314095131e-3_wp], & +# else + ! alternate solution 950704 BD + pa41(44) = [3.0951212953061873e-4_wp,1.8523796985974890e-3_wp,6.0950341155071959e-2_wp, & + 9.7643311650510500e-4_wp,1.4590364491577632e-1_wp,1.3847372348516919e-3_wp, & + 2.3847367014218874e-1_wp,1.6172106472544112e-3_wp,3.3179207364721231e-1_wp, & + 1.7495646572811541e-3_wp,4.2157617840109665e-1_wp,1.8184717781627688e-3_wp, & + 5.0444197078003583e-1_wp,1.8467159561512418e-3_wp,6.3725469392587524e-1_wp, & + 1.8520288282962131e-3_wp,6.8077440664552429e-1_wp,1.8588125854383170e-3_wp, & + 7.0409549382274691e-1_wp,1.8717906392777438e-3_wp,1.7247820099077235e-1_wp, & + 1.3003216858860477e-3_wp,3.9647553481998576e-1_wp,1.7051539963958640e-3_wp, & + 6.1168434420098755e-1_wp,1.8571611967740780e-3_wp,8.2130215819325114e-2_wp, & + 2.7786731905862443e-1_wp,1.5552136033968085e-3_wp,8.9992058420748749e-2_wp, & + 5.0335642710751172e-1_wp,1.8022391280085255e-3_wp,1.8166408403602095e-1_wp, & + 5.9841264978853796e-1_wp,1.8498305604436602e-3_wp,1.7207952256568781e-1_wp, & + 3.7910354076955633e-1_wp,1.7139045071067087e-3_wp,2.6347166559379496e-1_wp, & + 4.7423928425519802e-1_wp,1.8026589343774512e-3_wp,3.5182809277335190e-1_wp, & + 5.6102638086220602e-1_wp,1.8428664729052856e-3_wp], & + ! alternate solution 950705 BD + pa47(56) = [2.1929420881811841e-4_wp,1.4219403443358774e-3_wp,1.4364336173190798e-3_wp, & + 5.0872044105023605e-2_wp,6.7981235110505020e-4_wp,1.2281987901788307e-1_wp, & + 9.9131842352949122e-4_wp,2.0268908144087861e-1_wp,1.1802078332389488e-3_wp, & + 2.8477451564642939e-1_wp,1.2965996020809207e-3_wp,3.6567190789780265e-1_wp, & + 1.3658714274283164e-3_wp,4.4282648867134686e-1_wp,1.4029886047753253e-3_wp, & + 5.1406196272497354e-1_wp,1.4186455635956094e-3_wp,6.3064012191668026e-1_wp, & + 1.4213767418516618e-3_wp,6.7168833320226119e-1_wp,1.4239964754909616e-3_wp, & + 6.9797926853368807e-1_wp,1.4315540421785668e-3_wp,1.4468656741953093e-1_wp, & + 9.2544014998653679e-4_wp,3.3902634754112157e-1_wp,1.2502399950535093e-3_wp, & + 5.3358046512635063e-1_wp,1.3943658433292301e-3_wp,6.9440243933494130e-2_wp, & + 2.3551878942423264e-1_wp,1.1270890946717488e-3_wp,2.2690041095294599e-1_wp, & + 4.1021824740457302e-1_wp,1.3457537609106701e-3_wp,8.0255746077753389e-2_wp, & + 6.2143024174816046e-1_wp,1.4249572833167828e-3_wp,1.4679995278965720e-1_wp, & + 3.2452843457173944e-1_wp,1.2615233412377500e-3_wp,1.5715077698247271e-1_wp, & + 5.2244821896966297e-1_wp,1.3925471060526959e-3_wp,2.3657029931572456e-1_wp, & + 6.0175466340895581e-1_wp,1.4187616778776564e-3_wp,7.7148158667657320e-2_wp, & + 4.3465755161411628e-1_wp,1.3383666844795541e-3_wp,3.0629366662107302e-1_wp, & + 4.9088265890376162e-1_wp,1.3937008626761314e-3_wp,3.8224773795247870e-1_wp, & + 5.6487681490995005e-1_wp,1.4159147574669320e-3_wp], & +# endif + pa53(70) = [1.4382941905274311e-4_wp,1.1257722882870041e-3_wp,4.2929635453413471e-2_wp, & + 4.9480293419492410e-4_wp,1.0514268540864042e-1_wp,7.3579901091254705e-4_wp, & + 1.7500248676230874e-1_wp,8.8891327713043843e-4_wp,2.4776533796502568e-1_wp, & + 9.8883478389214349e-4_wp,3.2065671239559574e-1_wp,1.0532996817094706e-3_wp, & + 3.9165207498499835e-1_wp,1.0927788070145785e-3_wp,4.5908258741876237e-1_wp, & + 1.1143893940632272e-3_wp,5.2145638884158605e-1_wp,1.1237247880515553e-3_wp, & + 6.2531702446541989e-1_wp,1.1252393252438136e-3_wp,6.6379267445231699e-1_wp, & + 1.1261532718159050e-3_wp,6.9104103984983007e-1_wp,1.1302869311238408e-3_wp, & + 7.0529070074577603e-1_wp,1.1349865343639549e-3_wp,1.2366867626579899e-1_wp, & + 6.8233679271099310e-4_wp,2.9407771144683870e-1_wp,9.4541581604470958e-4_wp, & + 4.6977538492076491e-1_wp,1.0744299753856791e-3_wp,6.3345632411395669e-1_wp, & + 1.1293000865691317e-3_wp,5.9740486141813418e-2_wp,2.0291287527775228e-1_wp, & + 8.4368845009019544e-4_wp,1.3757604084736365e-1_wp,4.6026219424840539e-1_wp, & + 1.0752557204488846e-3_wp,3.3910165263362857e-1_wp,5.0306739996620357e-1_wp, & + 1.1085772368644620e-3_wp,1.2716751914398195e-1_wp,2.8176064224421343e-1_wp, & + 9.5664753237833573e-4_wp,2.6931207404135125e-1_wp,4.3315612917201574e-1_wp, & + 1.0806632507173907e-3_wp,1.4197864526019183e-1_wp,6.2561673585808142e-1_wp, & + 1.1267971311962946e-3_wp,6.7092846007382550e-2_wp,3.7983952168591567e-1_wp, & + 1.0225687153580612e-3_wp,7.0577381832561723e-2_wp,5.5175054214235205e-1_wp, & + 1.1089602677131075e-3_wp,2.7838884778821546e-1_wp,6.0296191561591869e-1_wp, & + 1.1227906534357658e-3_wp,1.9795789389174069e-1_wp,3.5896063295890958e-1_wp, & + 1.0324018471174598e-3_wp,2.0873070611032740e-1_wp,5.3486664381354765e-1_wp, & + 1.1072493822838539e-3_wp,4.0551221378728359e-1_wp,5.6749975460743735e-1_wp, & + 1.1217800485199721e-3_wp], & + pa59(85) = [1.1051892332675715e-4_wp,9.1331597864435614e-4_wp,9.2052327380907415e-4_wp, & + 3.7126364496570891e-2_wp,3.6904218980178990e-4_wp,9.1400604122622234e-2_wp, & + 5.6039909286806603e-4_wp,1.5310778524699062e-1_wp,6.8652976292826086e-4_wp, & + 2.1809288916606116e-1_wp,7.7203385511456304e-4_wp,2.8398745322001746e-1_wp, & + 8.3015459588947951e-4_wp,3.4911776009637644e-1_wp,8.6866925501796284e-4_wp, & + 4.1214314614443092e-1_wp,8.9270762858468901e-4_wp,4.7189936271491266e-1_wp, & + 9.0608202385682188e-4_wp,5.2731454528423366e-1_wp,9.1197772549408672e-4_wp, & + 6.2094753324440192e-1_wp,9.1287201386041811e-4_wp,6.5697227118572905e-1_wp, & + 9.1307149356917351e-4_wp,6.8417883090701434e-1_wp,9.1528737845541164e-4_wp, & + 7.0126043301236308e-1_wp,9.1874362743216541e-4_wp,1.0723822154781661e-1_wp, & + 5.1769773129656942e-4_wp,2.5820689594969680e-1_wp,7.3311436821014169e-4_wp, & + 4.1727529553067168e-1_wp,8.4632328363799285e-4_wp,5.7003669117925033e-1_wp, & + 9.0311226942539918e-4_wp,5.2106394770112841e-2_wp,1.7717740226153253e-1_wp, & + 6.4857784531632566e-4_wp,1.1156409571564867e-1_wp,2.4757164634262876e-1_wp, & + 7.4350309109823692e-4_wp,1.7465516775786261e-1_wp,3.1736152466119767e-1_wp, & + 8.1017314974680177e-4_wp,2.3902784793817240e-1_wp,3.8542911506692237e-1_wp, & + 8.5562992573118124e-4_wp,3.0294669735289819e-1_wp,4.5074225931570644e-1_wp, & + 8.8502823412654443e-4_wp,3.6498322605976536e-1_wp,5.1235184864198708e-1_wp, & + 9.0226929384269151e-4_wp,4.2386447815223403e-1_wp,5.6937024984684411e-1_wp, & + 9.1057602589701256e-4_wp,5.9058888532355084e-2_wp,3.3546162890664885e-1_wp, & + 7.9985278918390537e-4_wp,1.2172350510959870e-1_wp,4.0902684270853572e-1_wp, & + 8.4833895745943309e-4_wp,1.8575051945473351e-1_wp,4.7853206759224352e-1_wp, & + 8.8110481824257202e-4_wp,2.4941121623622365e-1_wp,5.4343035696939004e-1_wp, & + 9.0100916771050857e-4_wp,3.1122759471496082e-1_wp,6.0311616930963100e-1_wp, & + 9.1078135794827047e-4_wp,6.2662506241541695e-2_wp,4.9322211848512846e-1_wp, & + 8.8032086797382601e-4_wp,1.2677748006842827e-1_wp,5.6321230207620997e-1_wp, & + 9.0213422990406534e-4_wp,1.9060182227792370e-1_wp,6.2698055090243917e-1_wp, & + 9.1315780031894351e-4_wp,6.4245492242205886e-2_wp,6.3942796347491023e-1_wp, & + 9.1580161746934653e-4_wp] + +if (nDeg <= 0) then + write(u6,*) 'Lebedev: nDeg<=0' + call Abend() +end if +!lg write(u6,*) 'lMax =',lMax + +if (lMax <= 5) then + nPt = nscheme5(8) + if (nPt > nDeg) then + nPt = -nPt + else + call AnMesh(nscheme5,pa5,rPt,wPt) + end if + +else if (lMax <= 7) then + nPt = nscheme7(8) + if (nPt > nDeg) then + nPt = -nPt + else + call AnMesh(nscheme7,pa7,rPt,wPt) + end if + +else if (lMax <= 11) then + nPt = nscheme11(8) + if (nPt > nDeg) then + nPt = -nPt + else + call AnMesh(nscheme11,pa11,rPt,wPt) + end if + +else if (lMax <= 17) then + nPt = nscheme17(8) + if (nPt > nDeg) then + nPt = -nPt + else + call AnMesh(nscheme17,pa17,rPt,wPt) + end if + +else if (lMax <= 23) then + nPt = nscheme23(8) + !lg write(u6,*) 'nPt',nPt + if (nPt > nDeg) then + nPt = -nPt + else + !lg write(u6,*) 'Call AnMesh',nscheme23 + call AnMesh(nscheme23,pa23,rPt,wPt) + end if + +else if (lMax <= 29) then + nPt = nscheme29(8) + if (nPt > nDeg) then + nPt = -nPt + else + call AnMesh(nscheme29,pa29,rPt,wPt) + end if + +else if (Lmax <= 35) then + nPt = nscheme35(8) + if (nPt > nDeg) then + nPt = -nPt + else + call AnMesh(nscheme35,pa35,rPt,wPt) + end if + +else if (lMax <= 41) then + nPt = nscheme41(8) + if (nPt > nDeg) then + nPt = -nPt + else + call AnMesh(nscheme41,pa41,rPt,wPt) + end if + +else if (lMax <= 47) then + nPt = nscheme47(8) + if (nPt > nDeg) then + nPt = -nPt + else + call AnMesh(nscheme47,pa47,rPt,wPt) + end if + +else if (lMax <= 53) then + nPt = nscheme53(8) + if (nPt > nDeg) then + nPt = -nPt + else + call AnMesh(nscheme53,pa53,rPt,wPt) + end if + +else if (lMax <= 59) then + nPt = nscheme59(8) + if (nPt > nDeg) then + nPt = -nPt + else + call AnMesh(nscheme59,pa59,rPt,wPt) + end if + +else + ! such high order is not available here + nPt = -1 +end if + +!lg write(u6,*) 'End of Lebedev' + +return + +end subroutine Lebedev diff -Nru openmolcas-22.02/src/nq_util/lebedev_grid.f openmolcas-22.10/src/nq_util/lebedev_grid.f --- openmolcas-22.02/src/nq_util/lebedev_grid.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/lebedev_grid.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,74 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Lebedev_Grid(L_Max) -************************************************************************ -* * -* Computes datas useful for the angular quadrature. * -* * -************************************************************************ - use nq_Structure, only: Info_Ang - use nq_Info - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Parameter (nSet=11) - Integer Lebedev_order(nSet) - Data Lebedev_order/5,7,11,17,23,29,35,41,47,53,59/ -* * -************************************************************************ -* * - Interface - Subroutine Do_GGL(L_Eff,nPoints,R) - Implicit None - Integer L_Eff, nPoints - Real*8, Allocatable:: R(:,:) - End Subroutine Do_GGL - Subroutine Do_Lebedev(L_Eff,nPoints,R) - Implicit None - Integer L_Eff, nPoints - Real*8, Allocatable:: R(:,:) - End Subroutine Do_Lebedev - End Interface -* * -************************************************************************ -* * -* Use the GGL grids to minimize the number of grid points. -* - If (L_Max.lt.3) Return - nAngularGrids=nAngularGrids+1 - Info_Ang(nAngularGrids)%L_Eff=3 - Call Do_GGL(3, - & Info_Ang(nAngularGrids)%nPoints, - & Info_Ang(nAngularGrids)%R) -* * -************************************************************************ -* * -*---- Generate angular grid a la Lebedev -* - Do iSet = 1, nSet - If (Lebedev_order(iSet).le.L_Max) Then - nAngularGrids=nAngularGrids+1 - L_Eff=Lebedev_order(iSet) -* - Info_Ang(nAngularGrids)%L_Eff=L_Eff - Call Do_Lebedev(L_Eff, - & Info_Ang(nAngularGrids)%nPoints, - & Info_Ang(nAngularGrids)%R) - Else -* - Return -* - End If - End Do -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/lebedev_grid.F90 openmolcas-22.10/src/nq_util/lebedev_grid.F90 --- openmolcas-22.02/src/nq_util/lebedev_grid.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/lebedev_grid.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,62 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Lebedev_Grid(L_Max) +!*********************************************************************** +! * +! Computes data useful for the angular quadrature. * +! * +!*********************************************************************** + +use do_grid, only: Do_GGL, Do_Lebedev +use nq_Structure, only: Info_Ang +use nq_Info, only: nAngularGrids +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: L_Max +integer(kind=iwp) :: iSet, L_Eff +integer(kind=iwp), parameter :: Lebedev_order(11) = [5,7,11,17,23,29,35,41,47,53,59] + +! * +!*********************************************************************** +! * +! Use the GGL grids to minimize the number of grid points. + +if (L_Max < 3) return +nAngularGrids = nAngularGrids+1 +Info_Ang(nAngularGrids)%L_Eff = 3 +call Do_GGL(3,Info_Ang(nAngularGrids)%nPoints,Info_Ang(nAngularGrids)%R) +! * +!*********************************************************************** +! * +! Generate angular grid a la Lebedev + +do iSet=1,size(Lebedev_order) + if (Lebedev_order(iSet) <= L_Max) then + nAngularGrids = nAngularGrids+1 + L_Eff = Lebedev_order(iSet) + + Info_Ang(nAngularGrids)%L_Eff = L_Eff + call Do_Lebedev(L_Eff,Info_Ang(nAngularGrids)%nPoints,Info_Ang(nAngularGrids)%R) + else + + return + + end if +end do +! * +!*********************************************************************** +! * + +return + +end subroutine Lebedev_Grid diff -Nru openmolcas-22.02/src/nq_util/libxc.f90 openmolcas-22.10/src/nq_util/libxc.f90 --- openmolcas-22.02/src/nq_util/libxc.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/libxc.f90 1970-01-01 00:00:00.000000000 +0000 @@ -1,20 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -! * -! Copyright (C) 2021, Roland Lindh * -!*********************************************************************** -Module libxc -Real*8, Allocatable:: func(:) -Real*8, Allocatable:: dfunc_drho(:,:) -Real*8, Allocatable:: dfunc_dsigma(:,:) -Real*8, Allocatable:: dfunc_dtau(:,:) -Real*8, Allocatable:: dfunc_dlapl(:,:) -Logical :: Only_exc=.False. -End Module libxc diff -Nru openmolcas-22.02/src/nq_util/libxc.F90 openmolcas-22.10/src/nq_util/libxc.F90 --- openmolcas-22.02/src/nq_util/libxc.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/libxc.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,26 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Roland Lindh * +!*********************************************************************** + +module libxc + +use Definitions, only: wp, iwp + +implicit none +private + +real(kind=wp), allocatable :: dfunc_dlapl(:,:), dfunc_drho(:,:), dfunc_dsigma(:,:), dfunc_dtau(:,:), func(:) +logical(kind=iwp) :: Only_exc = .false. + +public :: dfunc_dlapl, dfunc_drho, dfunc_dsigma, dfunc_dtau, func, Only_exc + +end module libxc diff -Nru openmolcas-22.02/src/nq_util/libxc_interface.f90 openmolcas-22.10/src/nq_util/libxc_interface.f90 --- openmolcas-22.02/src/nq_util/libxc_interface.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/libxc_interface.f90 1970-01-01 00:00:00.000000000 +0000 @@ -1,287 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -! * -! Copyright (C) 2022, Susi Lehtola * -! 2022, Roland Lindh * -!*********************************************************************** -Subroutine libxc_interface(xc_func,xc_info,mGrid,nD,F_xc,Coeff) -use xc_f03_lib_m -use nq_Grid, only: Rho, Sigma, Tau, Lapl -use nq_Grid, only:vRho, vSigma, vTau, vLapl -use nq_Grid, only: l_casdft -use nq_Grid, only: F_xca, F_xcb -use libxc -use Definitions, only: wp, iwp, LibxcReal, LibxcSize -implicit none -integer(kind=iwp) :: mGrid, nD, iGrid -Real(kind=wp) :: F_xc(mGrid) -Real(kind=wp) :: Coeff - -TYPE(xc_f03_func_t) :: xc_func ! xc functional -TYPE(xc_f03_func_info_t) :: xc_info ! xc functional info - -if ((LibxcSize /= iwp) .or. (LibxcReal /= wp)) then - write(6,*) 'Libxc type mismatch!' - call abend() -end if -! * -!*********************************************************************** -! * -! Evaluate energy depending on the family -select case (xc_f03_func_info_get_family(xc_info)) -! * -!*********************************************************************** -! * -case(XC_FAMILY_LDA) -! * -!*********************************************************************** -! * - func(1:mGrid) = 0.0D0! Initialize memory - dfunc_drho(:,1:mGrid) = 0.0D0 - - If (Only_exc) Then - call xc_f03_lda_exc(xc_func, mGrid, Rho(1,1), func(1)) - Else - call xc_f03_lda_exc_vxc(xc_func, mGrid, Rho(1,1), func(1), dfunc_drho(1,1)) - End If - - ! Libxc evaluates energy density per particle; multiply by - ! density to get out what we really want - ! Collect the potential - - If (nD.eq.1) Then - If (Only_exc) Then - Do iGrid = 1, mGrid - F_xc(iGrid) = F_xc(iGrid) + Coeff*func(iGrid)*Rho(1, iGrid) - End Do - Else - Do iGrid = 1, mGrid - F_xc(iGrid) = F_xc(iGrid) + Coeff*func(iGrid)*Rho(1, iGrid) - vRho(1,iGrid) = vRho(1,iGrid) + Coeff*dfunc_drho(1, iGrid) - End Do - End If - Else - If (Only_exc) Then - Do iGrid = 1, mGrid - F_xc(iGrid) =F_xc(iGrid) +Coeff*func(iGrid)*(Rho(1, iGrid) + Rho(2, iGrid)) - End Do - Else - Do iGrid = 1, mGrid - F_xc(iGrid) =F_xc(iGrid) +Coeff*func(iGrid)*(Rho(1, iGrid) + Rho(2, iGrid)) - vRho(1,iGrid) = vRho(1,iGrid) + Coeff*dfunc_drho(1, iGrid) - vRho(2,iGrid) = vRho(2,iGrid) + Coeff*dfunc_drho(2, iGrid) - End Do - End If - - If (l_casdft) Then - select case(xc_f03_func_info_get_kind(xc_info)) - case (XC_EXCHANGE); - dFunc_dRho(:,1:mGrid)=Rho(:,1:mGrid) - Rho(2,1:mGrid)=0.0D0 - func(1:mGrid)=0.0D0 - call xc_f03_lda_exc(xc_func, mGrid, Rho(1,1), func(1)) - Do iGrid = 1, mGrid - F_xca(iGrid) = F_xca(iGrid) + Coeff*func(iGrid)*Rho(1, iGrid) - End Do - Rho(1,1:mGrid)=0.0D0 - Rho(2,1:mGrid)=dFunc_dRho(2,1:mGrid) - func(:)=0.0D0 - call xc_f03_lda_exc(xc_func, mGrid, Rho(1,1), func(1)) - Do iGrid = 1, mGrid - F_xcb(iGrid) = F_xcb(iGrid) + Coeff*func(iGrid)*Rho(2, iGrid) - End Do - Rho(:,1:mGrid)=dFunc_dRho(:,1:mGrid) - end Select - End If - End If -! * -!*********************************************************************** -! * -case(XC_FAMILY_GGA, XC_FAMILY_HYB_GGA) -! * -!*********************************************************************** -! * - func(1:mGrid) = 0.0D0 ! Initialize memory - dfunc_drho(:,1:mGrid) = 0.0D0 - dfunc_dSigma(:,1:mGrid) = 0.0D0 - - If (Only_exc) Then - call xc_f03_gga_exc(xc_func, mGrid, Rho(1,1), Sigma(1,1), func(1)) - Else - call xc_f03_gga_exc_vxc(xc_func, mGrid, Rho(1,1), Sigma(1,1), func(1), dfunc_dRho(1,1), dfunc_dSigma(1,1)) - End If - - ! Libxc evaluates energy density per particle; multiply by - ! density to get out what we really want - ! Collect the potential - - If (nD.eq.1) Then - If (Only_exc) Then - Do iGrid = 1, mGrid - F_xc(iGrid) = F_xc(iGrid) + Coeff*func(iGrid)*Rho(1, iGrid) - End Do - Else - Do iGrid = 1, mGrid - F_xc(iGrid) = F_xc(iGrid) + Coeff*func(iGrid)*Rho(1, iGrid) - vRho(1,iGrid) = vRho(1,iGrid) + Coeff*dfunc_drho(1, iGrid) - vSigma(1,iGrid) = vSigma(1,iGrid) + Coeff*dfunc_dSigma(1, iGrid) - End Do - End If - Else - If (Only_exc) Then - Do iGrid = 1, mGrid - F_xc(iGrid) =F_xc(iGrid) +Coeff*func(iGrid)*(Rho(1, iGrid) + Rho(2, iGrid)) - End Do - Else - Do iGrid = 1, mGrid - F_xc(iGrid) =F_xc(iGrid) +Coeff*func(iGrid)*(Rho(1, iGrid) + Rho(2, iGrid)) - vRho(1,iGrid) = vRho(1,iGrid) + Coeff*dfunc_drho(1, iGrid) - vRho(2,iGrid) = vRho(2,iGrid) + Coeff*dfunc_drho(2, iGrid) - vSigma(1,iGrid) = vSigma(1,iGrid) + Coeff*dfunc_dSigma(1, iGrid) - vSigma(2,iGrid) = vSigma(2,iGrid) + Coeff*dfunc_dSigma(2, iGrid) - vSigma(3,iGrid) = vSigma(3,iGrid) + Coeff*dfunc_dSigma(3, iGrid) - End Do - End If - - If (l_casdft) Then - select case(xc_f03_func_info_get_kind(xc_info)) - case (XC_EXCHANGE); - dFunc_dRho(:,1:mGrid)=Rho(:,1:mGrid) - Rho(2,1:mGrid)=0.0D0 - func(1:mGrid)=0.0D0 - call xc_f03_gga_exc(xc_func, mGrid, Rho(1,1), Sigma(1,1), func(1)) - Do iGrid = 1, mGrid - F_xca(iGrid) = F_xca(iGrid) + Coeff*func(iGrid)*Rho(1, iGrid) - End Do - Rho(1,1:mGrid)=0.0D0 - Rho(2,1:mGrid)=dFunc_dRho(2,:) - func(1:mGrid)=0.0D0 - call xc_f03_gga_exc(xc_func, mGrid, Rho(1,1), Sigma(1,1), func(1)) - Do iGrid = 1, mGrid - F_xcb(iGrid) = F_xcb(iGrid) + Coeff*func(iGrid)*Rho(2, iGrid) - End Do - Rho(:,1:mGrid)=dFunc_dRho(:,1:mGrid) - end Select - End If - End If -! * -!*********************************************************************** -! * -case(XC_FAMILY_MGGA, XC_FAMILY_HYB_MGGA) -! * -!*********************************************************************** -! * - func(1:mGrid) = 0.0D0 ! Initialize memory - dfunc_drho(:,1:mGrid) = 0.0D0 - dfunc_dSigma(:,1:mGrid) = 0.0D0 - if (Allocated(Tau)) dfunc_dTau(:,1:mGrid) = 0.0D0 - if (Allocated(Lapl)) dfunc_dLapl(:,1:mGrid) = 0.0D0 - - If (Only_exc) Then - call xc_f03_mgga_exc(xc_func, mGrid, Rho(1,1), Sigma(1,1), Lapl(1,1), Tau(1,1), func(1) ) - Else - call xc_f03_mgga_exc_vxc(xc_func, mGrid, Rho(1,1), Sigma(1,1), Lapl(1,1), Tau(1,1), & - func(1), dfunc_dRho(1,1), dfunc_dSigma(1,1), dfunc_dLapl(1,1), dfunc_dTau(1,1)) - End If - - ! Libxc evaluates energy density per particle; multiply by - ! density to get out what we really want - ! Collect the potential - - If (nD.eq.1) Then - If (Only_exc) Then - Do iGrid = 1, mGrid - F_xc(iGrid) = F_xc(iGrid) + Coeff*func(iGrid)*Rho(1, iGrid) - End Do - Else - Do iGrid = 1, mGrid - F_xc(iGrid) = F_xc(iGrid) + Coeff*func(iGrid)*Rho(1, iGrid) - vRho(1,iGrid) = vRho(1,iGrid) + Coeff*dfunc_drho(1, iGrid) - vSigma(1,iGrid) = vSigma(1,iGrid) + Coeff*dfunc_dSigma(1, iGrid) - End Do - If (Allocated(Tau)) Then - Do iGrid = 1, mGrid - vTau(1,iGrid) = vTau(1,iGrid) + Coeff*dfunc_dTau(1, iGrid) - End Do - End If - If (Allocated(Lapl)) Then - Do iGrid = 1, mGrid - vLapl(1,iGrid) = vLapl(1,iGrid) + Coeff*dfunc_dLapl(1, iGrid) - End Do - End If - End If - Else - If (Only_exc) Then - Do iGrid = 1, mGrid - F_xc(iGrid) =F_xc(iGrid) +Coeff*func(iGrid)*(Rho(1, iGrid) + Rho(2, iGrid)) - End Do - Else - Do iGrid = 1, mGrid - F_xc(iGrid) =F_xc(iGrid) +Coeff*func(iGrid)*(Rho(1, iGrid) + Rho(2, iGrid)) - vRho(1,iGrid) = vRho(1,iGrid) + Coeff*dfunc_drho(1, iGrid) - vRho(2,iGrid) = vRho(2,iGrid) + Coeff*dfunc_drho(2, iGrid) - vSigma(1,iGrid) = vSigma(1,iGrid) + Coeff*dfunc_dSigma(1, iGrid) - vSigma(2,iGrid) = vSigma(2,iGrid) + Coeff*dfunc_dSigma(2, iGrid) - vSigma(3,iGrid) = vSigma(3,iGrid) + Coeff*dfunc_dSigma(3, iGrid) - End Do - If (Allocated(Tau)) Then - Do iGrid = 1, mGrid - vTau(1,iGrid) = vTau(1,iGrid) + Coeff*dfunc_dTau(1, iGrid) - vTau(2,iGrid) = vTau(2,iGrid) + Coeff*dfunc_dTau(2, iGrid) - End Do - End If - If (Allocated(Lapl)) Then - Do iGrid = 1, mGrid - vLapl(1,iGrid) = vLapl(1,iGrid) + Coeff*dfunc_dLapl(1, iGrid) - vLapl(2,iGrid) = vLapl(2,iGrid) + Coeff*dfunc_dLapl(2, iGrid) - End Do - End If - End If - - If (l_casdft) Then - Write (6,*) "Uncharted territory!" - Call Abend() - select case(xc_f03_func_info_get_kind(xc_info)) - case (XC_EXCHANGE); - dFunc_dRho(:,1:mGrid)=Rho(:,1:mGrid) - Rho(2,1:mGrid)=0.0D0 - func(1:mGrid)=0.0D0 - call xc_f03_mgga_exc(xc_func, mGrid, Rho(1,1), Sigma(1,1), Lapl(1,1), Tau(1,1), func(1)) - Do iGrid = 1, mGrid - F_xca(iGrid) = F_xca(iGrid) + Coeff*func(iGrid)*Rho(1, iGrid) - End Do - Rho(1,1:mGrid)=0.0D0 - Rho(2,1:mGrid)=dFunc_dRho(2,:) - func(1:mGrid)=0.0D0 - call xc_f03_mgga_exc(xc_func, mGrid, Rho(1,1), Sigma(1,1), Lapl(1,1), Tau(1,1), func(1)) - Do iGrid = 1, mGrid - F_xcb(iGrid) = F_xcb(iGrid) + Coeff*func(iGrid)*Rho(2, iGrid) - End Do - Rho(:,1:mGrid)=dFunc_dRho(:,1:mGrid) - end Select - End If - End If -! * -!*********************************************************************** -! * - Case Default - Write (6,*) "Libxc family not properly identified." - Call Abend() -! * -!*********************************************************************** -! * -end select -! * -!*********************************************************************** -! * - -Return - -End Subroutine libxc_interface diff -Nru openmolcas-22.02/src/nq_util/libxc_interface.F90 openmolcas-22.10/src/nq_util/libxc_interface.F90 --- openmolcas-22.02/src/nq_util/libxc_interface.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/libxc_interface.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,290 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2022, Susi Lehtola * +! 2022, Roland Lindh * +!*********************************************************************** + +subroutine libxc_interface(xc_func,xc_info,mGrid,nD,F_xc,Coeff) + +use xc_f03_lib_m, only: XC_EXCHANGE, xc_f03_func_info_get_family, xc_f03_func_info_get_kind, xc_f03_func_info_t, xc_f03_func_t, & + xc_f03_gga_exc, xc_f03_gga_exc_vxc, xc_f03_lda_exc, xc_f03_lda_exc_vxc, xc_f03_mgga_exc, & + xc_f03_mgga_exc_vxc, XC_FAMILY_GGA, XC_FAMILY_HYB_GGA, XC_FAMILY_HYB_MGGA, XC_FAMILY_LDA, XC_FAMILY_MGGA +use nq_Grid, only: F_xca, F_xcb, l_casdft, Lapl, Rho, Sigma, Tau, vLapl, vRho, vSigma, vTau +use libxc, only: dfunc_dLapl, dfunc_drho, dfunc_dSigma, dfunc_dTau, func, Only_exc +use Constants, only: Zero +use Definitions, only: wp, iwp, u6, LibxcReal, LibxcSize + +implicit none +type(xc_f03_func_t), intent(in) :: xc_func ! xc functional +type(xc_f03_func_info_t), intent(in) :: xc_info ! xc functional info +integer(kind=iwp), intent(in) :: mGrid, nD +real(kind=wp), intent(inout) :: F_xc(mGrid) +real(kind=wp), intent(in) :: Coeff +integer(kind=iwp) :: iGrid + +if ((LibxcSize /= iwp) .or. (LibxcReal /= wp)) then + write(u6,*) 'Libxc type mismatch!' + call abend() +end if +! * +!*********************************************************************** +! * +! Evaluate energy depending on the family +select case (xc_f03_func_info_get_family(xc_info)) + ! * + !********************************************************************* + ! * + case (XC_FAMILY_LDA) + ! * + !******************************************************************* + ! * + func(1:mGrid) = Zero ! Initialize memory + dfunc_drho(:,1:mGrid) = Zero + + if (Only_exc) then + call xc_f03_lda_exc(xc_func,mGrid,Rho(1,1),func(1)) + else + call xc_f03_lda_exc_vxc(xc_func,mGrid,Rho(1,1),func(1),dfunc_drho(1,1)) + end if + + ! Libxc evaluates energy density per particle; multiply by + ! density to get out what we really want + ! Collect the potential + + if (nD == 1) then + if (Only_exc) then + do iGrid=1,mGrid + F_xc(iGrid) = F_xc(iGrid)+Coeff*func(iGrid)*Rho(1,iGrid) + end do + else + do iGrid=1,mGrid + F_xc(iGrid) = F_xc(iGrid)+Coeff*func(iGrid)*Rho(1,iGrid) + vRho(1,iGrid) = vRho(1,iGrid)+Coeff*dfunc_drho(1,iGrid) + end do + end if + else + if (Only_exc) then + do iGrid=1,mGrid + F_xc(iGrid) = F_xc(iGrid)+Coeff*func(iGrid)*(Rho(1,iGrid)+Rho(2,iGrid)) + end do + else + do iGrid=1,mGrid + F_xc(iGrid) = F_xc(iGrid)+Coeff*func(iGrid)*(Rho(1,iGrid)+Rho(2,iGrid)) + vRho(1,iGrid) = vRho(1,iGrid)+Coeff*dfunc_drho(1,iGrid) + vRho(2,iGrid) = vRho(2,iGrid)+Coeff*dfunc_drho(2,iGrid) + end do + end if + + if (l_casdft) then + select case (xc_f03_func_info_get_kind(xc_info)) + case (XC_EXCHANGE) + dFunc_dRho(:,1:mGrid) = Rho(:,1:mGrid) + Rho(2,1:mGrid) = Zero + func(1:mGrid) = Zero + call xc_f03_lda_exc(xc_func,mGrid,Rho(1,1),func(1)) + do iGrid=1,mGrid + F_xca(iGrid) = F_xca(iGrid)+Coeff*func(iGrid)*Rho(1,iGrid) + end do + Rho(1,1:mGrid) = Zero + Rho(2,1:mGrid) = dFunc_dRho(2,1:mGrid) + func(:) = Zero + call xc_f03_lda_exc(xc_func,mGrid,Rho(1,1),func(1)) + do iGrid=1,mGrid + F_xcb(iGrid) = F_xcb(iGrid)+Coeff*func(iGrid)*Rho(2,iGrid) + end do + Rho(:,1:mGrid) = dFunc_dRho(:,1:mGrid) + end select + end if + end if + ! * + !******************************************************************* + ! * + case (XC_FAMILY_GGA,XC_FAMILY_HYB_GGA) + ! * + !******************************************************************* + ! * + func(1:mGrid) = Zero ! Initialize memory + dfunc_drho(:,1:mGrid) = Zero + dfunc_dSigma(:,1:mGrid) = Zero + + if (Only_exc) then + call xc_f03_gga_exc(xc_func,mGrid,Rho(1,1),Sigma(1,1),func(1)) + else + call xc_f03_gga_exc_vxc(xc_func,mGrid,Rho(1,1),Sigma(1,1),func(1),dfunc_dRho(1,1),dfunc_dSigma(1,1)) + end if + + ! Libxc evaluates energy density per particle; multiply by + ! density to get out what we really want + ! Collect the potential + + if (nD == 1) then + if (Only_exc) then + do iGrid=1,mGrid + F_xc(iGrid) = F_xc(iGrid)+Coeff*func(iGrid)*Rho(1,iGrid) + end do + else + do iGrid=1,mGrid + F_xc(iGrid) = F_xc(iGrid)+Coeff*func(iGrid)*Rho(1,iGrid) + vRho(1,iGrid) = vRho(1,iGrid)+Coeff*dfunc_drho(1,iGrid) + vSigma(1,iGrid) = vSigma(1,iGrid)+Coeff*dfunc_dSigma(1,iGrid) + end do + end if + else + if (Only_exc) then + do iGrid=1,mGrid + F_xc(iGrid) = F_xc(iGrid)+Coeff*func(iGrid)*(Rho(1,iGrid)+Rho(2,iGrid)) + end do + else + do iGrid=1,mGrid + F_xc(iGrid) = F_xc(iGrid)+Coeff*func(iGrid)*(Rho(1,iGrid)+Rho(2,iGrid)) + vRho(1,iGrid) = vRho(1,iGrid)+Coeff*dfunc_drho(1,iGrid) + vRho(2,iGrid) = vRho(2,iGrid)+Coeff*dfunc_drho(2,iGrid) + vSigma(1,iGrid) = vSigma(1,iGrid)+Coeff*dfunc_dSigma(1,iGrid) + vSigma(2,iGrid) = vSigma(2,iGrid)+Coeff*dfunc_dSigma(2,iGrid) + vSigma(3,iGrid) = vSigma(3,iGrid)+Coeff*dfunc_dSigma(3,iGrid) + end do + end if + + if (l_casdft) then + select case (xc_f03_func_info_get_kind(xc_info)) + case (XC_EXCHANGE) + dFunc_dRho(:,1:mGrid) = Rho(:,1:mGrid) + Rho(2,1:mGrid) = Zero + func(1:mGrid) = Zero + call xc_f03_gga_exc(xc_func,mGrid,Rho(1,1),Sigma(1,1),func(1)) + do iGrid=1,mGrid + F_xca(iGrid) = F_xca(iGrid)+Coeff*func(iGrid)*Rho(1,iGrid) + end do + Rho(1,1:mGrid) = Zero + Rho(2,1:mGrid) = dFunc_dRho(2,:) + func(1:mGrid) = Zero + call xc_f03_gga_exc(xc_func,mGrid,Rho(1,1),Sigma(1,1),func(1)) + do iGrid=1,mGrid + F_xcb(iGrid) = F_xcb(iGrid)+Coeff*func(iGrid)*Rho(2,iGrid) + end do + Rho(:,1:mGrid) = dFunc_dRho(:,1:mGrid) + end select + end if + end if + ! * + !******************************************************************* + ! * + case (XC_FAMILY_MGGA,XC_FAMILY_HYB_MGGA) + ! * + !******************************************************************* + ! * + func(1:mGrid) = Zero ! Initialize memory + dfunc_drho(:,1:mGrid) = Zero + dfunc_dSigma(:,1:mGrid) = Zero + if (allocated(Tau)) dfunc_dTau(:,1:mGrid) = Zero + if (allocated(Lapl)) dfunc_dLapl(:,1:mGrid) = Zero + + if (Only_exc) then + call xc_f03_mgga_exc(xc_func,mGrid,Rho(1,1),Sigma(1,1),Lapl(1,1),Tau(1,1),func(1)) + else + call xc_f03_mgga_exc_vxc(xc_func,mGrid,Rho(1,1),Sigma(1,1),Lapl(1,1),Tau(1,1),func(1),dfunc_dRho(1,1),dfunc_dSigma(1,1), & + dfunc_dLapl(1,1),dfunc_dTau(1,1)) + end if + + ! Libxc evaluates energy density per particle; multiply by + ! density to get out what we really want + ! Collect the potential + + if (nD == 1) then + if (Only_exc) then + do iGrid=1,mGrid + F_xc(iGrid) = F_xc(iGrid)+Coeff*func(iGrid)*Rho(1,iGrid) + end do + else + do iGrid=1,mGrid + F_xc(iGrid) = F_xc(iGrid)+Coeff*func(iGrid)*Rho(1,iGrid) + vRho(1,iGrid) = vRho(1,iGrid)+Coeff*dfunc_drho(1,iGrid) + vSigma(1,iGrid) = vSigma(1,iGrid)+Coeff*dfunc_dSigma(1,iGrid) + end do + if (allocated(Tau)) then + do iGrid=1,mGrid + vTau(1,iGrid) = vTau(1,iGrid)+Coeff*dfunc_dTau(1,iGrid) + end do + end if + if (allocated(Lapl)) then + do iGrid=1,mGrid + vLapl(1,iGrid) = vLapl(1,iGrid)+Coeff*dfunc_dLapl(1,iGrid) + end do + end if + end if + else + if (Only_exc) then + do iGrid=1,mGrid + F_xc(iGrid) = F_xc(iGrid)+Coeff*func(iGrid)*(Rho(1,iGrid)+Rho(2,iGrid)) + end do + else + do iGrid=1,mGrid + F_xc(iGrid) = F_xc(iGrid)+Coeff*func(iGrid)*(Rho(1,iGrid)+Rho(2,iGrid)) + vRho(1,iGrid) = vRho(1,iGrid)+Coeff*dfunc_drho(1,iGrid) + vRho(2,iGrid) = vRho(2,iGrid)+Coeff*dfunc_drho(2,iGrid) + vSigma(1,iGrid) = vSigma(1,iGrid)+Coeff*dfunc_dSigma(1,iGrid) + vSigma(2,iGrid) = vSigma(2,iGrid)+Coeff*dfunc_dSigma(2,iGrid) + vSigma(3,iGrid) = vSigma(3,iGrid)+Coeff*dfunc_dSigma(3,iGrid) + end do + if (allocated(Tau)) then + do iGrid=1,mGrid + vTau(1,iGrid) = vTau(1,iGrid)+Coeff*dfunc_dTau(1,iGrid) + vTau(2,iGrid) = vTau(2,iGrid)+Coeff*dfunc_dTau(2,iGrid) + end do + end if + if (allocated(Lapl)) then + do iGrid=1,mGrid + vLapl(1,iGrid) = vLapl(1,iGrid)+Coeff*dfunc_dLapl(1,iGrid) + vLapl(2,iGrid) = vLapl(2,iGrid)+Coeff*dfunc_dLapl(2,iGrid) + end do + end if + end if + + if (l_casdft) then + write(u6,*) 'Uncharted territory!' + call Abend() + select case (xc_f03_func_info_get_kind(xc_info)) + case (XC_EXCHANGE) + dFunc_dRho(:,1:mGrid) = Rho(:,1:mGrid) + Rho(2,1:mGrid) = Zero + func(1:mGrid) = Zero + call xc_f03_mgga_exc(xc_func,mGrid,Rho(1,1),Sigma(1,1),Lapl(1,1),Tau(1,1),func(1)) + do iGrid=1,mGrid + F_xca(iGrid) = F_xca(iGrid)+Coeff*func(iGrid)*Rho(1,iGrid) + end do + Rho(1,1:mGrid) = Zero + Rho(2,1:mGrid) = dFunc_dRho(2,:) + func(1:mGrid) = Zero + call xc_f03_mgga_exc(xc_func,mGrid,Rho(1,1),Sigma(1,1),Lapl(1,1),Tau(1,1),func(1)) + do iGrid=1,mGrid + F_xcb(iGrid) = F_xcb(iGrid)+Coeff*func(iGrid)*Rho(2,iGrid) + end do + Rho(:,1:mGrid) = dFunc_dRho(:,1:mGrid) + end select + end if + end if + ! * + !******************************************************************* + ! * + case default + write(u6,*) 'Libxc family not properly identified.' + call Abend() + ! * + !******************************************************************* + ! * +end select +! * +!*********************************************************************** +! * + +return + +end subroutine libxc_interface diff -Nru openmolcas-22.02/src/nq_util/libxc_parameters.f90 openmolcas-22.10/src/nq_util/libxc_parameters.f90 --- openmolcas-22.02/src/nq_util/libxc_parameters.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/libxc_parameters.f90 1970-01-01 00:00:00.000000000 +0000 @@ -1,127 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -! * -! Copyright (C) 2000,2022, Roland Lindh * -! 2022, Susi Lehtola * -!*********************************************************************** -Module libxc_parameters -use xc_f03_lib_m -use Definitions, only: LibxcInt -Implicit None -Private -#include "ksdft.fh" - -Public :: nFuncs_max, nFuncs, Coeffs, func_id, xc_func, xc_info, Initiate_Libxc_functionals, Remove_Libxc_functionals, & - libxc_functionals - -Integer, parameter :: nFuncs_max=4 -Integer :: i -Integer :: nFuncs=0 -Real*8 :: Coeffs(nFuncs_Max)=[(0.0D0,i=1,nFuncs_Max)] -Integer(kind=LibxcInt) :: func_id(nFuncs_Max)=[(0_LibxcInt,i=1,nFuncs_Max)] - -TYPE(xc_f03_func_t) :: xc_func(nFuncs_Max) ! xc functional -TYPE(xc_f03_func_info_t) :: xc_info(nFuncs_Max) ! xc functional info - -! -!*********************************************************************** -! -Contains -! -!*********************************************************************** -! -Subroutine Initiate_Libxc_functionals(nD) -use nq_Grid, only: l_casdft -Implicit None -Integer nD, iFunc -Real*8 :: Coeff - -! if it is a mixed functional and we do MC-PDFT split it up in the components for -! further analysis. -If (nFuncs==1 .and. l_casdft) Then - call xc_f03_func_init(xc_func(1), func_id(1), int(nD, kind=LibxcInt)) - nFuncs = Max(1,INT(xc_f03_num_aux_funcs(xc_func(1)))) - - If (nFuncs/=1) Then - call xc_f03_aux_func_ids(xc_func(1), func_id) - call xc_f03_aux_func_weights(xc_func(1), Coeffs) - End If - call xc_f03_func_end(xc_func(1)) - -End If -Do iFunc = 1, nFuncs - ! Initialize libxc functional: nD = 2 means spin-polarized - call xc_f03_func_init(xc_func(iFunc), func_id(iFunc), int(nD, kind=LibxcInt)) - ! Get the functional's information - xc_info(iFunc) = xc_f03_func_get_info(xc_func(iFunc)) - -! Reset coefficients according to input - - Coeff = Coeffs(iFunc) - Select case(xc_f03_func_info_get_kind(xc_info(iFunc))) - case (XC_EXCHANGE) - Coeff = Coeff * CoefX - case (XC_CORRELATION) - Coeff = Coeff * CoefR - End Select - Coeffs(iFunc) = Coeff - -End Do - -End Subroutine Initiate_Libxc_functionals -! -!*********************************************************************** -! -Subroutine Remove_Libxc_functionals() -Implicit None -Integer iFunc -Do iFunc = 1, nFuncs - call xc_f03_func_end(xc_func(iFunc)) -End Do -Coeffs(:)=0.0D0 -func_id(:)=0 -End Subroutine Remove_Libxc_functionals -! -!*********************************************************************** -! -Subroutine libxc_functionals(mGrid,nD) -use nq_Grid, only: F_xc, F_xca, F_xcb, l_casdft -use nq_Grid, only: vRho, vSigma, vTau, vLapl -Implicit None -Integer mGrid,nD, iFunc -Real*8 Coeff -Real*8, Parameter :: Zero=0.0D0 -! -!*********************************************************************** -! -vRho(:,1:mGrid)=Zero -If (Allocated(vSigma)) vSigma(:,1:mGrid)=Zero -If (Allocated(vTau)) vTau(:,1:mGrid)=Zero -If (Allocated(vLapl)) vLapl(:,1:mGrid)=Zero -F_xc(1:mGrid)=Zero -If (l_casdft) Then - F_xca(1:mGrid)=Zero - F_xcb(1:mGrid)=Zero -End If -! -!*********************************************************************** -! - -Do iFunc = 1, nFuncs - Coeff = Coeffs(iFunc) - call libxc_interface(xc_func(iFunc),xc_info(iFunc),mGrid,nD,F_xc,Coeff) -End Do - -Return -End Subroutine libxc_functionals -! -!*********************************************************************** -! -End Module libxc_parameters diff -Nru openmolcas-22.02/src/nq_util/libxc_version.f90 openmolcas-22.10/src/nq_util/libxc_version.f90 --- openmolcas-22.02/src/nq_util/libxc_version.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/libxc_version.f90 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -! * -! Copyright (C) 2022, Roland Lindh * -! 2022, Susi Lehtola * -!*********************************************************************** -Subroutine libxc_version() - use xc_f03_lib_m - use Definitions, only: LibxcInt, iwp - implicit none - integer(kind=LibxcInt) :: vmajor, vminor, vmicro - character(len=128) :: libxc_reference, libxc_reference_doi - logical(kind=iwp), external :: Reduce_Prt - if (Reduce_Prt()) return - ! Get the data from libxc - call xc_f03_version(vmajor, vminor, vmicro) - call xc_f03_reference(libxc_reference) - call xc_f03_reference_doi(libxc_reference_doi) - ! Print out the version - write(6,'(6X,"Using Libxc version: ",I0,".",I0,".",I0)') vmajor, vminor, vmicro - ! Print out the Libxc literature reference - write(6,'(6X,"Please cite the following reference:")') - write(6,'(6X,A," doi:",A)') trim(libxc_reference), trim(libxc_reference_doi) -End Subroutine libxc_version diff -Nru openmolcas-22.02/src/nq_util/libxc_version.F90 openmolcas-22.10/src/nq_util/libxc_version.F90 --- openmolcas-22.02/src/nq_util/libxc_version.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/libxc_version.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,36 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2022, Roland Lindh * +! 2022, Susi Lehtola * +!*********************************************************************** + +subroutine libxc_version() + +use xc_f03_lib_m, only: xc_f03_reference, xc_f03_reference_doi, xc_f03_version +use Definitions, only: iwp, LibxcInt, u6 + +implicit none +integer(kind=LibxcInt) :: vmajor, vminor, vmicro +character(len=128) :: libxc_reference, libxc_reference_doi +logical(kind=iwp), external :: Reduce_Prt + +if (Reduce_Prt()) return +! Get the data from libxc +call xc_f03_version(vmajor,vminor,vmicro) +call xc_f03_reference(libxc_reference) +call xc_f03_reference_doi(libxc_reference_doi) +! Print out the version +write(u6,'(6X,"Using Libxc version: ",I0,".",I0,".",I0)') vmajor,vminor,vmicro +! Print out the Libxc literature reference +write(u6,'(6X,"Please cite the following reference:")') +write(u6,'(6X,A," doi:",A)') trim(libxc_reference),trim(libxc_reference_doi) + +end subroutine libxc_version diff -Nru openmolcas-22.02/src/nq_util/lobatto.f openmolcas-22.10/src/nq_util/lobatto.f --- openmolcas-22.02/src/nq_util/lobatto.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/lobatto.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,123 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Lobatto(ndeg,Trw) - implicit real*8 (a-h,o-z) - parameter(mxdeg=100) - dimension roots(mxdeg,mxdeg),wghts(mxdeg,mxdeg) - dimension recurs(mxdeg),trw(3*(ndeg+2)*(ndeg+3)/2) - -C Start: Accurately known are p0=1 and p1=x - roots(1,1)=0.0d0 -C Recursion coefficients: - do k=1,ndeg - rk=DBLE(k)*1.0d0 - recurs(k)=(rk*(rk+2.0d0))/((2.0D0*rk+1.0d0)*(2.0D0*rk+3.0d0)) - end do - - do k=2,ndeg -C Construct a start approximation to the roots: - roots(1,k)=(DBLE(k)*(roots(1, k-1)+1.0d0))/DBLE(k+1)-1.0d0 - roots(k,k)=(DBLE(k)*(roots(k-1,k-1)-1.0d0))/DBLE(k+1)+1.0d0 - do ir=2,k-1 - roots(ir,k)=( DBLE(k+1-ir)*roots(ir ,k-1) - & +DBLE(ir )*roots(ir-1,k-1) )/DBLE(k+1) - end do -C Start modified Newton-Raphson iterations. Parallell treatment of roots: - 10 continue - dmax=0.0d0 - do ir=1,k -C Compute value and derivative of polynomial: - x=roots(ir,k) - fpold=0.0d0 - fold=1.0d0 - fp=1.0d0 - f=x - do n=2,k - c=recurs(n-1) - fpnew=x*fp+f-c*fpold - fnew=x*f-c*fold - fpold=fp - fold=f - fp=fpnew - f=fnew - end do -C Compute the extra denominator term: - xterm=0.0d0 - do jr=1,k - if(jr.ne.ir) xterm=xterm+1.0d0/(x-roots(jr,k)) - end do -C Update: - delta=-f/(fp-f*xterm) - roots(ir,k)=roots(ir,k)+delta - dmax=max(dmax,abs(delta)) - end do - if(dmax.gt.1.0d-12) goto 10 - end do - -C Compute weights: - do k=1,ndeg - do ir=1,k - x=roots(ir,k) - fold=1.0d0 - f=x - do n=1,k - fnew=x*f*(2.0d0*DBLE(n)+1.0d0) - & / (DBLE(n)+1.0d0)-fold*DBLE(n)/(DBLE(n)+1.0d0) - fold=f - f=fnew - end do - wghts(ir,k)=2.0d0/(f*f*DBLE(k+1)*DBLE(k+2)) - end do - end do - - do n=3,ndeg+2 - trw(3*n*(n-1)/2+1)=-1.0d0 ! (n-1,1,1) n=nDeg+2 - trw(3*n*(n-1)/2+2)=2.0d0/DBLE(n*(n-1)) ! (n-1,1,2) - trw(3*n*(n+1)/2-2)=1.0d0 ! (n-1,n-1,1) - trw(3*n*(n+1)/2-1)=2.0d0/DBLE(n*(n-1)) ! (n-1,n-1,2) - end do - -* (1,1,1) -* (1,1,2) -* (1,1,3) -* (2,1,1) -* (2,1,1) -* (2,1,2) -* (2,2,3) -* (2,2,2) -* (2,2,3) - - do i=1,9 - trw(i)=0.0D0 - end do - - do k=1,ndeg - n=k+1 - do ir=1,k - ii=3*n*(n+1)/2+ir*3+1 ! (n+1,ir,1) n=nDeg+1, ir=2,nDeg - jj=3*n*(n+1)/2+ir*3+2 ! (n+1,ir,2) - trw(ii)=roots(ir,k) - trw(jj)=wghts(ir,k) - end do - end do - -* write(*,*) 'Lobatto' -* do i=1,ndeg+2 -* write(*,*) 'i=',i -* do j=1,i -* write(*,*) trw(3*i*(i-1)/2+3*(j-1)+1), -* & trw(3*i*(i-1)/2+3*(j-1)+2), -* & trw(3*i*(i-1)/2+3*(j-1)+3) -* end do -* end do - - return - end diff -Nru openmolcas-22.02/src/nq_util/lobatto.F90 openmolcas-22.10/src/nq_util/lobatto.F90 --- openmolcas-22.02/src/nq_util/lobatto.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/lobatto.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,135 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Lobatto(ndeg,trw) + +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Three +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: ndeg +real(kind=wp), intent(out) :: trw(3*(ndeg+2)*(ndeg+3)/2) +integer(kind=iwp) :: ii, ir, jj, jr, k, n +real(kind=wp) :: c, delta, dmax, f, fnew, fold, fp, fpnew, fpold, rk, x, xterm +real(kind=wp), allocatable :: recurs(:), roots(:,:), wghts(:,:) + +call mma_allocate(roots,ndeg,ndeg,label='roots') +call mma_allocate(recurs,ndeg,label='recurs') +! Start: Accurately known are p0=1 and p1=x +roots(1,1) = Zero +! Recursion coefficients: +do k=1,ndeg + rk = real(k,kind=wp) + recurs(k) = (rk*(rk+Two))/((Two*rk+One)*(Two*rk+Three)) +end do + +do k=2,ndeg + ! Construct a start approximation to the roots: + roots(1,k) = (real(k,kind=wp)*(roots(1,k-1)+One))/real(k+1,kind=wp)-One + roots(k,k) = (real(k,kind=wp)*(roots(k-1,k-1)-One))/real(k+1,kind=wp)+One + do ir=2,k-1 + roots(ir,k) = (real(k+1-ir,kind=wp)*roots(ir,k-1)+real(ir,kind=wp)*roots(ir-1,k-1))/real(k+1,kind=wp) + end do + ! Start modified Newton-Raphson iterations. Parallell treatment of roots: + do + dmax = Zero + do ir=1,k + ! Compute value and derivative of polynomial: + x = roots(ir,k) + fpold = Zero + fold = One + fp = One + f = x + do n=2,k + c = recurs(n-1) + fpnew = x*fp+f-c*fpold + fnew = x*f-c*fold + fpold = fp + fold = f + fp = fpnew + f = fnew + end do + ! Compute the extra denominator term: + xterm = Zero + do jr=1,k + if (jr /= ir) xterm = xterm+One/(x-roots(jr,k)) + end do + ! Update: + delta = -f/(fp-f*xterm) + roots(ir,k) = roots(ir,k)+delta + dmax = max(dmax,abs(delta)) + end do + if (dmax <= 1.0e-12_wp) exit + end do +end do + +call mma_deallocate(recurs) +call mma_allocate(wghts,ndeg,ndeg,label='wghts') + +! Compute weights: +do k=1,ndeg + do ir=1,k + x = roots(ir,k) + fold = One + f = x + do n=1,k + fnew = x*f*(Two*real(n,kind=wp)+One)/(real(n,kind=wp)+One)-fold*real(n,kind=wp)/(real(n,kind=wp)+One) + fold = f + f = fnew + end do + wghts(ir,k) = Two/(f*f*real(k+1,kind=wp)*real(k+2,kind=wp)) + end do +end do + +do n=3,ndeg+2 + trw(3*n*(n-1)/2+1) = -One ! (n-1,1,1) n=nDeg+2 + trw(3*n*(n-1)/2+2) = Two/real(n*(n-1),kind=wp) ! (n-1,1,2) + trw(3*n*(n+1)/2-2) = One ! (n-1,n-1,1) + trw(3*n*(n+1)/2-1) = Two/real(n*(n-1),kind=wp) ! (n-1,n-1,2) +end do + +! (1,1,1) +! (1,1,2) +! (1,1,3) +! (2,1,1) +! (2,1,1) +! (2,1,2) +! (2,2,3) +! (2,2,2) +! (2,2,3) + +trw(1:9) = Zero + +do k=1,ndeg + n = k+1 + do ir=1,k + ii = 3*n*(n+1)/2+ir*3+1 ! (n+1,ir,1) n=nDeg+1, ir=2,nDeg + jj = 3*n*(n+1)/2+ir*3+2 ! (n+1,ir,2) + trw(ii) = roots(ir,k) + trw(jj) = wghts(ir,k) + end do +end do + +call mma_deallocate(roots) +call mma_deallocate(wghts) + +!write(u6,*) 'Lobatto' +!do i=1,ndeg+2 +! write(u6,*) 'i=',i +! do j=1,i +! write(u6,*) trw(3*i*(i-1)/2+3*(j-1)+1),trw(3*i*(i-1)/2+3*(j-1)+2),trw(3*i*(i-1)/2+3*(j-1)+3) +! end do +!end do + +return + +end subroutine Lobatto diff -Nru openmolcas-22.02/src/nq_util/lobatto_grid.f openmolcas-22.10/src/nq_util/lobatto_grid.f --- openmolcas-22.02/src/nq_util/lobatto_grid.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/lobatto_grid.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,54 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Lobatto_Grid(L_Max) -************************************************************************ -* * -* Computes datas useful for the angular quadrature. * -* * -************************************************************************ - use nq_Structure, only: Info_Ang - use nq_Info - Implicit Real*8 (a-h,o-z) -#include "real.fh" -* * -************************************************************************ -* * - Interface - Subroutine Do_Lobatto(L_Eff,nPoints,R) - Implicit None - Integer L_Eff, nPoints - Real*8, Allocatable:: R(:,:) - End Subroutine Do_Lobatto - End Interface -* * -************************************************************************ -* * -* Observe that we use standard GGL for orders 1 and 2. - Call GGL_Grid(2) -* * -************************************************************************ -* * -*---- Generate angular grid a la Lobatto -* - Do L_Eff = 3, L_Max - nAngularGrids=nAngularGrids+1 -* - Info_Ang(nAngularGrids)%L_Eff=L_Eff - Call Do_Lobatto(L_Eff, - & Info_Ang(nAngularGrids)%nPoints, - & Info_Ang(nAngularGrids)%R) -* - End Do ! L_Eff -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/lobatto_grid.F90 openmolcas-22.10/src/nq_util/lobatto_grid.F90 --- openmolcas-22.02/src/nq_util/lobatto_grid.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/lobatto_grid.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,52 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Lobatto_Grid(L_Max) +!*********************************************************************** +! * +! Computes data useful for the angular quadrature. * +! * +!*********************************************************************** + +use do_grid, only: Do_Lobatto +use nq_Structure, only: Info_Ang +use nq_Info, only: nAngularGrids +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: L_Max +integer(kind=iwp) :: L_Eff + +! * +!*********************************************************************** +! * +! Observe that we use standard GGL for orders 1 and 2. + +call GGL_Grid(2) +! * +!*********************************************************************** +! * +! Generate angular grid a la Lobatto + +do L_Eff=3,L_Max + nAngularGrids = nAngularGrids+1 + + Info_Ang(nAngularGrids)%L_Eff = L_Eff + call Do_Lobatto(L_Eff,Info_Ang(nAngularGrids)%nPoints,Info_Ang(nAngularGrids)%R) + +end do ! L_Eff +! * +!*********************************************************************** +! * + +return + +end subroutine Lobatto_Grid diff -Nru openmolcas-22.02/src/nq_util/mk_MOs.f openmolcas-22.10/src/nq_util/mk_MOs.f --- openmolcas-22.02/src/nq_util/mk_MOs.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/mk_MOs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,58 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2022, Roland Lindh * -************************************************************************ - Subroutine mk_MOs(SOValue,mAO,nCoor,MOValue,nMOs,CMOs,nCMO) - use Basis_Info, only: nBas - use Symmetry_Info, only: nIrrep - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 SOValue(mAO*nCoor,nMOs), - & MOValue(mAO*nCoor,nMOs), CMOs(nCMO) -*#define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Character*80 Label -#endif -* -#ifdef _DEBUGPRINT_ - Write (6,*) 'mk_MOs: MO-Coefficients' - iOff=1 - Do iIrrep = 0, nIrrep-1 - If (nBas(iIrrep).gt.0) Then - Write (6,*) ' Symmetry Block',iIrrep - Call RecPrt(' ',' ',CMOs(iOff),nBas(iIrrep),nBas(iIrrep)) - End If - iOff=iOff+nBas(iIrrep)**2 - End Do -#endif -* -*---- Compute some offsets -* - iSO=1 - iCMO=1 - Do iIrrep = 0, nIrrep-1 - If (nBas(iIrrep)==0) Cycle - Call DGeMM_('N','N', - & mAO*nCoor,nBas(iIrrep),nBas(iIrrep), - & One,SOValue(:,iSO:),mAO*nCoor, - & CMOs(iCMO:),nBas(iIrrep), - & Zero,MOValue(:,iSO:),mAO*nCoor) - iSO =iSO +nBas(iIrrep) - iCMO=iCMO+nBas(iIrrep)*nBas(iIrrep) - End Do -* -#ifdef _DEBUGPRINT_ - Write (Label,'(A)')'mk_MOs: MOValue(mAO*nCoor,nMOs)' - Call RecPrt(Label,' ',MOValue(1,1),mAO*nCoor,nMOs) -#endif -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/mk_mos.F90 openmolcas-22.10/src/nq_util/mk_mos.F90 --- openmolcas-22.02/src/nq_util/mk_mos.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/mk_mos.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,65 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2022, Roland Lindh * +!*********************************************************************** + +subroutine mk_MOs(SOValue,mAO,nCoor,MOValue,nMOs,CMOs,nCMO) + +use Basis_Info, only: nBas +use Symmetry_Info, only: nIrrep +use Constants, only: Zero, One +use Definitions, only: wp, iwp +!#define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +use Definitions, only: u6 +#endif + +implicit none +integer(kind=iwp), intent(in) :: mAO, nCoor, nMOs, nCMO +real(kind=wp), intent(in) :: SOValue(mAO*nCoor,nMOs), CMOs(nCMO) +real(kind=wp), intent(out) :: MOValue(mAO*nCoor,nMOs) +integer(kind=iwp) :: iCMO, iIrrep, iSO +#ifdef _DEBUGPRINT_ +character(len=80) :: Label +#endif + +#ifdef _DEBUGPRINT_ +write(u6,*) 'mk_MOs: MO-Coefficients' +iOff = 1 +do iIrrep=0,nIrrep-1 + if (nBas(iIrrep) > 0) then + write(u6,*) ' Symmetry Block',iIrrep + call RecPrt(' ',' ',CMOs(iOff),nBas(iIrrep),nBas(iIrrep)) + end if + iOff = iOff+nBas(iIrrep)**2 +end do +#endif + +! Compute some offsets + +iSO = 1 +iCMO = 1 +do iIrrep=0,nIrrep-1 + if (nBas(iIrrep) == 0) cycle + call DGeMM_('N','N',mAO*nCoor,nBas(iIrrep),nBas(iIrrep),One,SOValue(:,iSO:),mAO*nCoor,CMOs(iCMO:),nBas(iIrrep),Zero, & + MOValue(:,iSO:),mAO*nCoor) + iSO = iSO+nBas(iIrrep) + iCMO = iCMO+nBas(iIrrep)*nBas(iIrrep) +end do + +#ifdef _DEBUGPRINT_ +write(Label,'(A)') 'mk_MOs: MOValue(mAO*nCoor,nMOs)' +call RecPrt(Label,' ',MOValue(1,1),mAO*nCoor,nMOs) +#endif + +return + +end subroutine mk_MOs diff -Nru openmolcas-22.02/src/nq_util/mk_rho.f openmolcas-22.10/src/nq_util/mk_rho.f --- openmolcas-22.02/src/nq_util/mk_rho.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/mk_rho.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,704 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2000,2021, Roland Lindh * -************************************************************************ - Subroutine Mk_Rho(list_s,nlist_s,Fact,mdc,list_bas,Index,nIndex, - & Do_Grad) -************************************************************************ -* Author:Roland Lindh, Department of Chemical Physics, University * -* of Lund, SWEDEN. 2000 * -************************************************************************ - use iSD_data - use k2_arrays, only: DeDe, ipDijS - use nq_grid, only: Rho, TabAO, Dens_AO, Grid_AO, TabAO_Short - use nq_grid, only: GradRho, Tau, Lapl, kAO - use nq_Grid, only: dRho_dR, iBfn_Index - use nq_Grid, only: List_G - use nq_Info -#ifdef _DEBUGPRINT_ - use nq_grid, only: nRho -#endif - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" -#include "debug.fh" -#include "nsd.fh" -#include "setup.fh" -#include "stdalloc.fh" - Integer Index(nIndex) - Real*8 Fact(mdc**2) - Integer ipD(2) - Integer list_s(2,nlist_s), list_bas(2,nlist_s) - Integer, Parameter :: Index_d2(3,3)= - & Reshape([5,6,7, 6,8,9, 7,9,10],[3,3]) - Integer, Parameter :: Index_d3(3,3) = - & Reshape([11,14,16, 12,17,19, 13,18,20],[3,3]) - Logical Do_Grad - Integer, Allocatable:: Ind_Grd(:,:) -* * -************************************************************************ -* * -* Statement functions - iTri(i,j) = Max(i,j)*(Max(i,j)-1)/2 + Min(i,j) -* * -************************************************************************ -* * -* - nD = SIZE(Dens_AO,3) - nAO = SIZE(Dens_AO,1) - Dens_AO(:,:,:)=Zero - mAO = SIZE(TabAO,1) - mGrid = SIZE(TabAO,2) - -*#define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Write (6,*) 'mAO=',mAO - Write (6,*) 'mGrid=',mGrid - Write (6,*) 'nlist_s=',nlist_s - Call RecPrt('Rho: TabAO',' ',TabAO,mAO*mGrid,nAO) -#endif -* * -************************************************************************ -************************************************************************ -* * -* Generate the one-particle density matrix, D(mu,nu) * -* * -************************************************************************ -************************************************************************ -* * -* - If (Do_Grad) Then - Call mma_Allocate(Ind_Grd,3,nAO,Label='Ind_Grd') - Ind_Grd(:,:)=0 - End If - - nBfn=SIZE(iBfn_Index,2) - If (nBfn/=nAO) Then - Write (6,*) 'mk_Rho: internal error!' - Call Abend() - End If - Factor = DBLE(2/nD) - Do iBfn = 1, nBfn - ilist_s=iBfn_Index(2,iBfn) - i1 =iBfn_Index(3,iBfn) - i2 =iBfn_Index(4,iBfn) - iSkal = list_s(1,ilist_s) - kDCRE = list_s(2,ilist_s) - iCmp = iSD( 2,iSkal) - iBas = iSD( 3,iSkal) - mdci = iSD(10,iSkal) - iShell= iSD(11,iSkal) - iBas_Eff=list_bas(1,ilist_s) - index_i =list_bas(2,ilist_s) - nFunc_i=iBas*iCmp - - i_R=(i1-1)*iBas_Eff+i2 - iCB = Index(index_i-1+i_R) - - If (Do_Grad) Ind_Grd(:,iBfn)=List_g(:,ilist_s) - - Do jBfn = 1, iBfn - jlist_s=iBfn_Index(2,jBfn) - j1 =iBfn_Index(3,jBfn) - j2 =iBfn_Index(4,jBfn) - jSkal = list_s(1,jlist_s) - kDCRR = list_s(2,jlist_s) - jCmp = iSD( 2,jSkal) - jBas = iSD( 3,jSkal) - mdcj = iSD(10,jSkal) - jShell= iSD(11,jSkal) - jBas_Eff=list_bas(1,jlist_s) - index_j =list_bas(2,jlist_s) - nFunc_j=jBas*jCmp - - j_R=(j1-1)*jBas_Eff+j2 - jCB = Index(index_j-1+j_R) - - ijS=iTri(iShell,jShell) - ip_Tmp=ipDijs - Call Dens_Info(ijS,ipDij,ipDSij,mDCRij,ipDDij,ip_Tmp,nD) - ij = (mdcj-1)*mdc + mdci - - iER=iEOr(kDCRE,kDCRR) - lDCRER=NrOpr(iER) - - mDij=nFunc_i*nFunc_j - ip_D_a=ipDij+lDCRER*mDij - ip_D_b=ip_D_a - If (nD.ne.1) ip_D_b=ipDSij+lDCRER*mDij - ipD(1)=ip_D_a - ipD(2)=ip_D_b - - ij_D = (jCB-1)*nFunc_i + iCB - 1 - Do iD = 1, nD - DAij =DeDe(ipD(iD)+ij_D)*Fact(ij)*Factor - Dens_AO(iBfn,jBfn,iD) = DAij - Dens_AO(jBfn,iBfn,iD) = DAij - End Do - - End Do - - End Do -* * -************************************************************************ -* * -*#define _ANALYSIS_ -#ifdef _ANALYSIS_ - Thr=1.0D-15 - Write (6,*) - Write (6,*) ' Sparsity analysis of D(i,j)' - Write (6,*) ' Threshold: ',Thr - Write (6,*) ' Grid size: ',mGrid - Write (6,*) ' Dimension: ',n,' x ',n - n=SIZE(Dens_AO,1) - n2 = n**2 - Do iD = 1, nD - m=0 - Do i = 1, n - Do j = 1, n - If (Abs(Dens_AO(i,j,iD)). * +! * +! Copyright (C) 2000,2021, Roland Lindh * +!*********************************************************************** + +subroutine Mk_Rho(list_s,nlist_s,Fact,mdc,list_bas,Indx,nIndex,Do_Grad) +!*********************************************************************** +! Author:Roland Lindh, Department of Chemical Physics, University * +! of Lund, SWEDEN. 2000 * +!*********************************************************************** + +use iSD_data, only: iSD +use k2_arrays, only: DeDe, ipDijS +use nq_Grid, only: Dens_AO, dRho_dR, GradRho, Grid_AO, iBfn_Index, kAO, Lapl, List_G, Rho, TabAO, TabAO_Short, Tau +use nq_Info, only: Functional_type, GGA_Type, LDA_Type, meta_GGA_Type1, meta_GGA_Type2 +#ifdef _DEBUGPRINT_ +use nq_Grid, only: nRho +#endif +use Index_Functions, only: iTri +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Four, Half +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nlist_s, list_s(2,nlist_s), mdc, list_bas(2,nlist_s), nIndex, Indx(nIndex) +real(kind=wp), intent(in) :: Fact(mdc,mdc) +logical(kind=iwp), intent(in) :: Do_Grad +integer(kind=iwp) :: i1, i2, i_R, iAO, iBas, iBas_Eff, iBfn, iCar, iCB, iCmp, iD, idjx, idjx2, idjy, idjy2, idjz, idjz2, iDx, & + idx2, iDy, idy2, iDz, idz2, iER, iGrid, ij_D, ijS, iL, ilist_s, Ind_xyz, index_i, index_j, ip_D_a, ip_D_b, & + ip_Tmp, ipD(2), ipDDij, ipDij, ipDSij, iShell, iSkal, iT, ix, iy, iz, j, j1, j2, j_R, jBas, jBas_Eff, jBfn, & + jCB, jCmp, jlist_s, jShell, jSkal, kDCRE, kDCRR, lDCRER, mAO, mdci, mdcj, mDCRij, mDij, mGrid, nAO, nBfn, nD, & + nFunc_i, nFunc_j +real(kind=wp) :: DAij, Factor +integer(kind=iwp), parameter :: Index_d2(3,3) = reshape([5,6,7,6,8,9,7,9,10],[3,3]), & + Index_d3(3,3) = reshape([11,14,16,12,17,19,13,18,20],[3,3]) +integer(kind=iwp), allocatable :: Ind_Grd(:,:) +integer(kind=iwp), external :: NrOpr + +! * +!*********************************************************************** +! * +nD = size(Dens_AO,3) +nAO = size(Dens_AO,1) +Dens_AO(:,:,:) = Zero +mAO = size(TabAO,1) +mGrid = size(TabAO,2) + +!#define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +write(u6,*) 'mAO=',mAO +write(u6,*) 'mGrid=',mGrid +write(u6,*) 'nlist_s=',nlist_s +call RecPrt('Rho: TabAO',' ',TabAO,mAO*mGrid,nAO) +#endif +! * +!*********************************************************************** +!*********************************************************************** +! * +! Generate the one-particle density matrix, D(mu,nu) * +! * +!*********************************************************************** +!*********************************************************************** +! * + +if (Do_Grad) then + call mma_Allocate(Ind_Grd,3,nAO,Label='Ind_Grd') + Ind_Grd(:,:) = 0 +end if + +nBfn = size(iBfn_Index,2) +if (nBfn /= nAO) then + write(u6,*) 'mk_Rho: internal error!' + call Abend() +end if +Factor = real(2/nD,kind=wp) +do iBfn=1,nBfn + ilist_s = iBfn_Index(2,iBfn) + i1 = iBfn_Index(3,iBfn) + i2 = iBfn_Index(4,iBfn) + iSkal = list_s(1,ilist_s) + kDCRE = list_s(2,ilist_s) + iCmp = iSD(2,iSkal) + iBas = iSD(3,iSkal) + mdci = iSD(10,iSkal) + iShell = iSD(11,iSkal) + iBas_Eff = list_bas(1,ilist_s) + index_i = list_bas(2,ilist_s) + nFunc_i = iBas*iCmp + + i_R = (i1-1)*iBas_Eff+i2 + iCB = Indx(index_i-1+i_R) + + if (Do_Grad) Ind_Grd(:,iBfn) = List_g(:,ilist_s) + + do jBfn=1,iBfn + jlist_s = iBfn_Index(2,jBfn) + j1 = iBfn_Index(3,jBfn) + j2 = iBfn_Index(4,jBfn) + jSkal = list_s(1,jlist_s) + kDCRR = list_s(2,jlist_s) + jCmp = iSD(2,jSkal) + jBas = iSD(3,jSkal) + mdcj = iSD(10,jSkal) + jShell = iSD(11,jSkal) + jBas_Eff = list_bas(1,jlist_s) + index_j = list_bas(2,jlist_s) + nFunc_j = jBas*jCmp + + j_R = (j1-1)*jBas_Eff+j2 + jCB = Indx(index_j-1+j_R) + + ijS = iTri(iShell,jShell) + ip_Tmp = ipDijs + call Dens_Info(ijS,ipDij,ipDSij,mDCRij,ipDDij,ip_Tmp,nD) + + iER = ieor(kDCRE,kDCRR) + lDCRER = NrOpr(iER) + + mDij = nFunc_i*nFunc_j + ip_D_a = ipDij+lDCRER*mDij + ip_D_b = ip_D_a + if (nD /= 1) ip_D_b = ipDSij+lDCRER*mDij + ipD(1) = ip_D_a + ipD(2) = ip_D_b + + ij_D = (jCB-1)*nFunc_i+iCB-1 + do iD=1,nD + DAij = DeDe(ipD(iD)+ij_D)*Fact(mdci,mdcj)*Factor + Dens_AO(iBfn,jBfn,iD) = DAij + Dens_AO(jBfn,iBfn,iD) = DAij + end do + + end do + +end do +! * +!*********************************************************************** +! * +!#define _ANALYSIS_ +#ifdef _ANALYSIS_ +Thr = 1.0e-15_wp +write(u6,*) +write(u6,*) ' Sparsity analysis of D(i,j)' +write(u6,*) ' Threshold: ',Thr +write(u6,*) ' Grid size: ',mGrid +write(u6,*) ' Dimension: ',n,' x ',n +n = size(Dens_AO,1) +n2 = n**2 +do iD=1,nD + m = 0 + do i=1,n + do j=1,n + if (abs(Dens_AO(i,j,iD)) < Thr) m = m+1 + end do + end do + write(u6,*) 'Total Sparsity in %',100.0_wp*real(m,kind=wp)/real(n2,kind=wp) + k = 0 + do i=1,n + m = 0 + do j=1,n + if (abs(Dens_AO(i,j,iD)) < Thr) m = m+1 + end do + if (m == n) k = k+1 + end do + write(u6,*) 'Column Sparsity in %',100.0_wp*real(k,kind=wp)/real(n,kind=wp) + k = 0 + do j=1,n + m = 0 + do i=1,n + if (abs(Dens_AO(i,j,iD)) < Thr) m = m+1 + end do + if (m == n) k = k+1 + end do + write(u6,*) 'Row Sparsity in %',100.0_wp*real(k,kind=wp)/real(n,kind=wp) +end do +#endif +! * +!*********************************************************************** +!*********************************************************************** +! * +! Construct: Sum_i D_ij TabAO(i,iGrid,iAO) +! D_ij is the one-electron density +! TabAO(i,iGrid,iAO) are values with respect to the ith AO +! i=1 is the value of the AO +! i=2-4 are the values of the first order derivatives +! i=5-10 are the values of the second order derivatives +! i=11-20 are the values of the third order derivatives +! +! During a gradient calculation the size of the fast index of +! TabAO is larger than that of Grid_AO. In those cases we copy +! the part of TabAO which we need to TabAO_Short before we make the +! contraction with the 1-particle density matrix. + +if (Do_Grad) then + TabAO_Short(1:kAO,1:mGrid,:) = TabAO(1:kAO,1:mGrid,:) + call DGEMM_('N','N',kAO*mGrid,nAO*nD,nAO,One,TabAO_Short,kAO*mGrid,Dens_AO,nAO,Zero,Grid_AO,kAO*mGrid) +else + call DGEMM_('N','N',kAO*mGrid,nAO*nD,nAO,One,TabAO,mAO*mGrid,Dens_AO,nAO,Zero,Grid_AO,kAO*mGrid) +end if +! * +!*********************************************************************** +!*********************************************************************** +! * +if (allocated(dRho_dR)) dRho_dR(:,:,:) = Zero + +select case (Functional_Type) + ! * + !********************************************************************* + !********************************************************************* + ! * + case (LDA_Type) + ! * + !******************************************************************* + !******************************************************************* + ! * + Rho(:,1:mGrid) = Zero + do iD=1,nD + do iAO=1,nAO + + do iGrid=1,mGrid + Rho(iD,iGrid) = Rho(iD,iGrid)+Grid_AO(1,iGrid,iAO,iD)*TabAO(1,iGrid,iAO) + end do + + if (Do_Grad) then + + ! Loop over cartesian components + + do iCar=1,3 + + Ind_xyz = Ind_Grd(iCar,iAO) + j = iCar+1 + + if (Ind_xyz /= 0) then + do iGrid=1,mGrid + + ! Cartesian derivative of the density. + + dRho_dR(iD,iGrid,Ind_xyz) = dRho_dR(iD,iGrid,Ind_xyz)+Two*Grid_AO(1,iGrid,iAO,iD)*TabAO(j,iGrid,iAO) + end do + end if + + end do + + end if + end do + end do + ! * + !******************************************************************* + !******************************************************************* + ! * + case (GGA_Type) + ! * + !******************************************************************* + !******************************************************************* + ! * + Rho(:,1:mGrid) = Zero + GradRho(:,1:mGrid) = Zero + do iD=1,nD + ix = (iD-1)*3+1 + iy = (iD-1)*3+2 + iz = (iD-1)*3+3 + do iAO=1,nAO + + do iGrid=1,mGrid + Rho(iD,iGrid) = Rho(iD,iGrid)+Grid_AO(1,iGrid,iAO,iD)*TabAO(1,iGrid,iAO) + GradRho(ix,iGrid) = GradRho(ix,iGrid)+Grid_AO(1,iGrid,iAO,iD)*TabAO(2,iGrid,iAO)+ & + Grid_AO(2,iGrid,iAO,iD)*TabAO(1,iGrid,iAO) + GradRho(iy,iGrid) = GradRho(iy,iGrid)+Grid_AO(1,iGrid,iAO,iD)*TabAO(3,iGrid,iAO)+ & + Grid_AO(3,iGrid,iAO,iD)*TabAO(1,iGrid,iAO) + GradRho(iz,iGrid) = GradRho(iz,iGrid)+Grid_AO(1,iGrid,iAO,iD)*TabAO(4,iGrid,iAO)+ & + Grid_AO(4,iGrid,iAO,iD)*TabAO(1,iGrid,iAO) + end do + + if (Do_Grad) then + + ! Loop over cartesian components + + do iCar=1,3 + + Ind_xyz = Ind_Grd(iCar,iAO) ! index of nuclear gradient + + j = iCar+1 ! index derivative of AO + + iDx = nD+(iD-1)*3+1 ! index of grad rho component + iDy = iDx+1 + iDz = iDy+1 + + idjx = Index_d2(1,iCar) + idjy = Index_d2(2,iCar) + idjz = Index_d2(3,iCar) + if (Ind_xyz /= 0) then + do iGrid=1,mGrid + + ! Cartesian derivative of rho + + dRho_dR(iD,iGrid,Ind_xyz) = dRho_dR(iD,iGrid,Ind_xyz)+Two*Grid_AO(1,iGrid,iAO,iD)*TabAO(j,iGrid,iAO) + + ! Cartesian derivatives of grad rho + + dRho_dR(iDx,iGrid,Ind_xyz) = dRho_dR(iDx,iGrid,Ind_xyz)+Two*TabAO(idjx,iGrid,iAO)*Grid_AO(1,iGrid,iAO,iD)+ & + Two*TabAO(j,iGrid,iAO)*Grid_AO(2,iGrid,iAO,iD) + dRho_dR(iDy,iGrid,Ind_xyz) = dRho_dR(iDy,iGrid,Ind_xyz)+Two*TabAO(idjy,iGrid,iAO)*Grid_AO(1,iGrid,iAO,iD)+ & + Two*TabAO(j,iGrid,iAO)*Grid_AO(3,iGrid,iAO,iD) + dRho_dR(iDz,iGrid,Ind_xyz) = dRho_dR(iDz,iGrid,Ind_xyz)+Two*TabAO(idjz,iGrid,iAO)*Grid_AO(1,iGrid,iAO,iD)+ & + Two*TabAO(j,iGrid,iAO)*Grid_AO(4,iGrid,iAO,iD) + end do + end if + + end do + end if + + end do + end do + ! * + !******************************************************************* + !******************************************************************* + ! * + case (meta_GGA_Type1) + ! * + !******************************************************************* + !******************************************************************* + ! * + Rho(:,1:mGrid) = Zero + GradRho(:,1:mGrid) = Zero + Tau(:,1:mGrid) = Zero + do iD=1,nD + ix = (iD-1)*3+1 + iy = (iD-1)*3+2 + iz = (iD-1)*3+3 + do iAO=1,nAO + + do iGrid=1,mGrid + Rho(iD,iGrid) = Rho(iD,iGrid)+Grid_AO(1,iGrid,iAO,iD)*TabAO(1,iGrid,iAO) + GradRho(ix,iGrid) = GradRho(ix,iGrid)+Grid_AO(1,iGrid,iAO,iD)*TabAO(2,iGrid,iAO)+ & + Grid_AO(2,iGrid,iAO,iD)*TabAO(1,iGrid,iAO) + GradRho(iy,iGrid) = GradRho(iy,iGrid)+Grid_AO(1,iGrid,iAO,iD)*TabAO(3,iGrid,iAO)+ & + Grid_AO(3,iGrid,iAO,iD)*TabAO(1,iGrid,iAO) + GradRho(iz,iGrid) = GradRho(iz,iGrid)+Grid_AO(1,iGrid,iAO,iD)*TabAO(4,iGrid,iAO)+ & + Grid_AO(4,iGrid,iAO,iD)*TabAO(1,iGrid,iAO) + Tau(iD,iGrid) = Tau(iD,iGrid)+Grid_AO(2,iGrid,iAO,iD)*TabAO(2,iGrid,iAO)+Grid_AO(3,iGrid,iAO,iD)*TabAO(3,iGrid,iAO)+ & + Grid_AO(4,iGrid,iAO,iD)*TabAO(4,iGrid,iAO) + end do + + if (Do_Grad) then + + ! Loop over cartesian components + + do iCar=1,3 + + Ind_xyz = Ind_Grd(iCar,iAO) ! index of nuclear gradient + + j = iCar+1 ! index derivative of AO + + iDx = nD+(iD-1)*3+1 ! index of grad rho component + iDy = iDx+1 + iDz = iDy+1 + + iT = nD*4+iD ! index of tau component + + idjx = Index_d2(1,iCar) + idjy = Index_d2(2,iCar) + idjz = Index_d2(3,iCar) + if (Ind_xyz /= 0) then + do iGrid=1,mGrid + + ! Cartesian derivative of rho + + dRho_dR(iD,iGrid,Ind_xyz) = dRho_dR(iD,iGrid,Ind_xyz)+Two*Grid_AO(1,iGrid,iAO,iD)*TabAO(j,iGrid,iAO) + + ! Cartesian derivatives of grad rho + + dRho_dR(iDx,iGrid,Ind_xyz) = dRho_dR(iDx,iGrid,Ind_xyz)+Two*TabAO(idjx,iGrid,iAO)*Grid_AO(1,iGrid,iAO,iD)+ & + Two*TabAO(j,iGrid,iAO)*Grid_AO(2,iGrid,iAO,iD) + dRho_dR(iDy,iGrid,Ind_xyz) = dRho_dR(iDy,iGrid,Ind_xyz)+Two*TabAO(idjy,iGrid,iAO)*Grid_AO(1,iGrid,iAO,iD)+ & + Two*TabAO(j,iGrid,iAO)*Grid_AO(3,iGrid,iAO,iD) + dRho_dR(iDz,iGrid,Ind_xyz) = dRho_dR(iDz,iGrid,Ind_xyz)+Two*TabAO(idjz,iGrid,iAO)*Grid_AO(1,iGrid,iAO,iD)+ & + Two*TabAO(j,iGrid,iAO)*Grid_AO(4,iGrid,iAO,iD) + + ! Cartesian derivatives of tau + + dRho_dR(iT,iGrid,Ind_xyz) = dRho_dR(iT,iGrid,Ind_xyz)+Four*TabAO(idjx,iGrid,iAO)*Grid_AO(2,iGrid,iAO,iD)+ & + Four*TabAO(idjy,iGrid,iAO)*Grid_AO(3,iGrid,iAO,iD)+ & + Four*TabAO(idjz,iGrid,iAO)*Grid_AO(4,iGrid,iAO,iD) + end do + end if + + end do + + end if + end do + end do + ! * + !******************************************************************* + !******************************************************************* + ! * + case (meta_GGA_Type2) + ! * + !******************************************************************* + !******************************************************************* + ! * + Rho(:,1:mGrid) = Zero + GradRho(:,1:mGrid) = Zero + Tau(:,1:mGrid) = Zero + Lapl(:,1:mGrid) = Zero + do iD=1,nD + ix = (iD-1)*3+1 + iy = (iD-1)*3+2 + iz = (iD-1)*3+3 + do iAO=1,nAO + + do iGrid=1,mGrid + Rho(iD,iGrid) = Rho(iD,iGrid)+Grid_AO(1,iGrid,iAO,iD)*TabAO(1,iGrid,iAO) + GradRho(ix,iGrid) = GradRho(ix,iGrid)+Grid_AO(1,iGrid,iAO,iD)*TabAO(2,iGrid,iAO)+ & + Grid_AO(2,iGrid,iAO,iD)*TabAO(1,iGrid,iAO) + GradRho(iy,iGrid) = GradRho(iy,iGrid)+Grid_AO(1,iGrid,iAO,iD)*TabAO(3,iGrid,iAO)+ & + Grid_AO(3,iGrid,iAO,iD)*TabAO(1,iGrid,iAO) + GradRho(iz,iGrid) = GradRho(iz,iGrid)+Grid_AO(1,iGrid,iAO,iD)*TabAO(4,iGrid,iAO)+ & + Grid_AO(4,iGrid,iAO,iD)*TabAO(1,iGrid,iAO) + Tau(iD,iGrid) = Tau(iD,iGrid)+Grid_AO(2,iGrid,iAO,iD)*TabAO(2,iGrid,iAO)+Grid_AO(3,iGrid,iAO,iD)*TabAO(3,iGrid,iAO)+ & + Grid_AO(4,iGrid,iAO,iD)*TabAO(4,iGrid,iAO) + Lapl(iD,iGrid) = Lapl(iD,iGrid)+TabAO(1,iGrid,iAO)*(Grid_AO(5,iGrid,iAO,iD)+Grid_AO(8,iGrid,iAO,iD)+ & + Grid_AO(10,iGrid,iAO,iD))+Two*(Grid_AO(2,iGrid,iAO,iD)*TabAO(2,iGrid,iAO)+ & + Grid_AO(3,iGrid,iAO,iD)*TabAO(3,iGrid,iAO)+Grid_AO(4,iGrid,iAO,iD)*TabAO(4,iGrid,iAO))+ & + Grid_AO(1,iGrid,iAO,iD)*(TabAO(5,iGrid,iAO)+TabAO(8,iGrid,iAO)+TabAO(10,iGrid,iAO)) + end do + + if (Do_Grad) then + + ! Loop over cartesian components + + do iCar=1,3 + + Ind_xyz = Ind_Grd(iCar,iAO) ! index of nuclear gradient + + j = iCar+1 ! index derivative of AO + + iDx = nD+(iD-1)*3+1 ! index of grad rho component + iDy = iDx+1 + iDz = iDy+1 + + iT = nD*4+iD ! index of tau component + + iL = nD*5+iD ! index of laplacian component + + idjx = Index_d2(1,iCar) + idjy = Index_d2(2,iCar) + idjz = Index_d2(3,iCar) + + idjx2 = Index_d3(1,iCar) + idjy2 = Index_d3(2,iCar) + idjz2 = Index_d3(3,iCar) + idx2 = Index_d2(1,1) + idy2 = Index_d2(2,2) + idz2 = Index_d2(3,3) + if (Ind_xyz /= 0) then + do iGrid=1,mGrid + + ! Cartesian derivative of rho + + dRho_dR(iD,iGrid,Ind_xyz) = dRho_dR(iD,iGrid,Ind_xyz)+Two*Grid_AO(1,iGrid,iAO,iD)*TabAO(j,iGrid,iAO) + + ! Cartesian derivatives of grad rho + + dRho_dR(iDx,iGrid,Ind_xyz) = dRho_dR(iDx,iGrid,Ind_xyz)+Two*TabAO(idjx,iGrid,iAO)*Grid_AO(1,iGrid,iAO,iD)+ & + Two*TabAO(j,iGrid,iAO)*Grid_AO(2,iGrid,iAO,iD) + dRho_dR(iDy,iGrid,Ind_xyz) = dRho_dR(iDy,iGrid,Ind_xyz)+Two*TabAO(idjy,iGrid,iAO)*Grid_AO(1,iGrid,iAO,iD)+ & + Two*TabAO(j,iGrid,iAO)*Grid_AO(3,iGrid,iAO,iD) + dRho_dR(iDz,iGrid,Ind_xyz) = dRho_dR(iDz,iGrid,Ind_xyz)+Two*TabAO(idjz,iGrid,iAO)*Grid_AO(1,iGrid,iAO,iD)+ & + Two*TabAO(j,iGrid,iAO)*Grid_AO(4,iGrid,iAO,iD) + + ! Cartesian derivatives of tau + + dRho_dR(iT,iGrid,Ind_xyz) = dRho_dR(iT,iGrid,Ind_xyz)+Four*TabAO(idjx,iGrid,iAO)*Grid_AO(2,iGrid,iAO,iD)+ & + Four*TabAO(idjy,iGrid,iAO)*Grid_AO(3,iGrid,iAO,iD)+ & + Four*TabAO(idjz,iGrid,iAO)*Grid_AO(4,iGrid,iAO,iD) + + ! Cartesian derivatives of the laplacian + + dRho_dR(iL,iGrid,Ind_xyz) = dRho_dR(iL,iGrid,Ind_xyz)+Two*Grid_AO(1,iGrid,iAO,iD)*(TabAO(idjx2,iGrid,iAO)+ & + TabAO(idjy2,iGrid,iAO)+TabAO(idjz2,iGrid,iAO))+Two*(Grid_AO(idx2,iGrid,iAO,iD)+ & + Grid_AO(idy2,iGrid,iAO,iD)+Grid_AO(idz2,iGrid,iAO,iD))*TabAO(j,iGrid,iAO)+ & + Four*Grid_AO(2,iGrid,iAO,iD)*TabAO(idjx,iGrid,iAO)+ & + Four*Grid_AO(3,iGrid,iAO,iD)*TabAO(idjy,iGrid,iAO)+ & + Four*Grid_AO(4,iGrid,iAO,iD)*TabAO(idjz,iGrid,iAO) + + end do + end if + + end do + + end if + + end do + end do + ! * + !******************************************************************* + !******************************************************************* + ! * + case default + ! * + !******************************************************************* + !******************************************************************* + ! * + call abend() + ! * + !******************************************************************* + !******************************************************************* + ! * +end select +! * +!*********************************************************************** +!*********************************************************************** +! * +#ifdef _ANALYSIS_ +write(u6,*) +write(u6,*) 'Rho Sparsity analysis' +n = 0 +do iGrid=1,mGrid + tmp = Zero + do iD=1,nD + tmp = tmp+Rho(iD,iGrid) + end do + if (tmp < Thr) n = n+1 +end do +write(u6,*) 'Rho Sparsity in %: ',100.0_wp*real(n,kind=wp)/real(mGrid,kind=wp) +#endif +! * +!*********************************************************************** +!*********************************************************************** +! * +! Scale Tau to compy with the Libxc definition. +! +if (allocated(Tau)) Tau(:,1:mGrid) = Half*Tau(:,1:mGrid) +! * +!*********************************************************************** +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +do iD=1,nD + call RecPrt('Dens_AO',' ',Dens_AO(:,:,iD),nAO,nAO) + call RecPrt('Grid_AO',' ',Grid_AO(:,:,:,iD),mAO*mGrid,nAO) +end do +if (Do_Grad) then + nGrad_Eff = size(dRho_dR,3) + call RecPrt('dRho_dR_LDA: dRho_dR',' ',dRho_dR,size(dRho_dR,1)*mGrid,nGrad_Eff) +end if +#endif +! * +!*********************************************************************** +!*********************************************************************** +! * +if (allocated(Ind_grd)) call mma_deAllocate(Ind_Grd) + +return + +end subroutine Mk_Rho diff -Nru openmolcas-22.02/src/nq_util/mk_SOs.f openmolcas-22.10/src/nq_util/mk_SOs.f --- openmolcas-22.02/src/nq_util/mk_SOs.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/mk_SOs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,80 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2022, Roland Lindh * -************************************************************************ - Subroutine mk_SOs(TabSO,mAO,mGrid,nMOs,List_s,List_Bas,nList_s, - & jList_s) - use iSD_data - use Center_Info - use Symmetry_Info, only: nIrrep, iChTbl - use SOAO_Info, only: iAOtSO - use Basis_Info, only: MolWgh, nBas - use nq_Grid, only: iBfn_Index, TabAO - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 TabSO(mAO*mGrid,nMOs) - Integer :: list_s(2,nList_s), list_bas(2,nlist_s) - Integer iOff_MO(0:7) - Integer :: jList_s -* -*---- Compute some offsets -* - itmp1=1 - Do iIrrep = 0, nIrrep-1 - iOff_MO(iIrrep)=itmp1 - itmp1=itmp1+nBas(iIrrep) - End Do - - nBfn=Size(iBfn_Index,2) - Do iBfn = 1, nBfn - ilist_s=iBfn_Index(2,iBfn) - If (jlist_s/=0.and.ilist_s/=jlist_s) Cycle - i1 =iBfn_Index(3,iBfn) - i2 =iBfn_Index(4,iBfn) - iSh =list_s(1,ilist_s) - kDCRE = list_s(2,ilist_s) - mBas_Eff=List_Bas(1,ilist_s) - mBas =iSD( 3,iSh) - iAO =iSD( 7,iSh) - mdci =iSD(10,iSh) - nDeg =nIrrep/dc(mdci)%nStab - nOp = NrOpr(kDCRE) - - If (MolWgh.eq.0) Then - Fact=One/DBLE(nDeg) - Else If (MolWgh.eq.1) Then - Fact=One - Else - Fact=One/Sqrt(DBLE(nDeg)) - End If - - iAdd=mBas-mBas_Eff - Do iIrrep = 0, nIrrep-1 - iSO0=iAOtSO(iAO+i1,iIrrep) - If (iSO0<0) Cycle - - iMO=iOff_MO(iIrrep) - - xa= DBLE(iChTbl(iIrrep,nOp)) - iSO = iSO0 + i2 - 1 - iSO1=iMO+iSO-1+iAdd - Call DaXpY_(mAO*mGrid,Fact*xa, - & TabAO(:,:,iBfn),1, - & TabSO(:,iSO1),1) - End Do - End Do -* -#ifdef _DEBUGPRINT_ - Call RecPrt('mk_SOs: TabSO',' ',TabSO,mAO*mGrid,nMOs) -#endif -* - Return - End Subroutine mk_SOs diff -Nru openmolcas-22.02/src/nq_util/mk_sos.F90 openmolcas-22.10/src/nq_util/mk_sos.F90 --- openmolcas-22.02/src/nq_util/mk_sos.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/mk_sos.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,84 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2022, Roland Lindh * +!*********************************************************************** + +subroutine mk_SOs(TabSO,mAO,mGrid,nMOs,List_s,List_Bas,nList_s,jList_s) + +use iSD_data, only: iSD +use Center_Info, only: dc +use Symmetry_Info, only: iChTbl, nIrrep +use SOAO_Info, only: iAOtSO +use Basis_Info, only: MolWgh, nBas +use nq_Grid, only: iBfn_Index, TabAO +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: mAO, mGrid, nMOs, nlist_s, list_s(2,nlist_s), list_bas(2,nlist_s), jList_s +real(kind=wp), intent(inout) :: TabSO(mAO,mGrid,nMOs) +integer(kind=iwp) :: i1, i2, iAdd, iAO, iBfn, iIrrep, ilist_s, iMO, iOff_MO(0:7), iSh, iSO, iSO0, iSO1, itmp1, kDCRE, mBas, & + mBas_Eff, mdci, nBfn, nDeg, nOp +real(kind=wp) :: Fact, xa +integer(kind=iwp), external :: NrOpr + +! Compute some offsets + +itmp1 = 1 +do iIrrep=0,nIrrep-1 + iOff_MO(iIrrep) = itmp1 + itmp1 = itmp1+nBas(iIrrep) +end do + +nBfn = size(iBfn_Index,2) +do iBfn=1,nBfn + ilist_s = iBfn_Index(2,iBfn) + if ((jlist_s /= 0) .and. (ilist_s /= jlist_s)) cycle + i1 = iBfn_Index(3,iBfn) + i2 = iBfn_Index(4,iBfn) + iSh = list_s(1,ilist_s) + kDCRE = list_s(2,ilist_s) + mBas_Eff = List_Bas(1,ilist_s) + mBas = iSD(3,iSh) + iAO = iSD(7,iSh) + mdci = iSD(10,iSh) + nDeg = nIrrep/dc(mdci)%nStab + nOp = NrOpr(kDCRE) + + if (MolWgh == 0) then + Fact = One/real(nDeg,kind=wp) + else if (MolWgh == 1) then + Fact = One + else + Fact = One/sqrt(real(nDeg,kind=wp)) + end if + + iAdd = mBas-mBas_Eff + do iIrrep=0,nIrrep-1 + iSO0 = iAOtSO(iAO+i1,iIrrep) + if (iSO0 < 0) cycle + + iMO = iOff_MO(iIrrep) + + xa = real(iChTbl(iIrrep,nOp),kind=wp) + iSO = iSO0+i2-1 + iSO1 = iMO+iSO-1+iAdd + TabSO(:,:,iSO1) = TabSO(:,:,iSO1)+Fact*xa*TabAO(:,:,iBfn) + end do +end do + +#ifdef _DEBUGPRINT_ +call RecPrt('mk_SOs: TabSO',' ',TabSO,mAO*mGrid,nMOs) +#endif + +return + +end subroutine mk_SOs diff -Nru openmolcas-22.02/src/nq_util/modify_nq_grid.f openmolcas-22.10/src/nq_util/modify_nq_grid.f --- openmolcas-22.02/src/nq_util/modify_nq_grid.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/modify_nq_grid.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,53 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Modify_NQ_grid - use Grid_On_Disk - use nq_Info - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "itmax.fh" - Parameter (L_Quad_Low=23, Threshold_High=1.0D-7, nR_Low=50) -* * -************************************************************************ -* * -* * -************************************************************************ -* * -* Reduce the size and the accuracy of the grid temporarily -* - L_Quad_Save=L_Quad - Threshold_save=Threshold - nR_Save=nR - ThrC = Crowding -* - L_Quad=Min(L_Quad,L_Quad_Low) - If (Quadrature(1:3).eq.'LMG') Then - Threshold =Max(Threshold_High,Threshold) - Else - nR =Min(nR_Low,nR) - End If - Crowding=Max(ThrC-Two,One) -* - Write (6,*) - Write (6,*) 'Modify the NQ grid!' - Write (6,*) - Call Funi_Print() -* * -************************************************************************ -* * -* Change the Grid set index. -* - iGrid_Set=Intermediate -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/modify_nq_grid.F90 openmolcas-22.10/src/nq_util/modify_nq_grid.F90 --- openmolcas-22.02/src/nq_util/modify_nq_grid.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/modify_nq_grid.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,57 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Modify_NQ_grid() + +use Grid_On_Disk, only: iGrid_Set, Intermediate +use nq_Info, only: Crowding, L_Quad, L_Quad_Save, nR, nR_Save, Quadrature, ThrC, Threshold, Threshold_save +use Constants, only: One, Two +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), parameter :: L_Quad_Low = 23, nR_Low = 50 +real(kind=wp), parameter :: Threshold_High = 1.0e-7_wp + +! * +!*********************************************************************** +! * +! Reduce the size and the accuracy of the grid temporarily + +L_Quad_Save = L_Quad +Threshold_save = Threshold +nR_Save = nR +ThrC = Crowding + +L_Quad = min(L_Quad,L_Quad_Low) +if (Quadrature(1:3) == 'LMG') then + Threshold = max(Threshold_High,Threshold) +else + nR = min(nR_Low,nR) +end if +Crowding = max(ThrC-Two,One) + +write(u6,*) +write(u6,*) 'Modify the NQ grid!' +write(u6,*) +call Funi_Print() +! * +!*********************************************************************** +! * +! Change the Grid set index. + +iGrid_Set = Intermediate +! * +!*********************************************************************** +! * + +return + +end subroutine Modify_NQ_grid diff -Nru openmolcas-22.02/src/nq_util/nbas_eff.f openmolcas-22.10/src/nq_util/nbas_eff.f --- openmolcas-22.02/src/nq_util/nbas_eff.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/nbas_eff.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Integer Function nBas_Eff(NrExp,NrBas,Exp,Cff,nExp_Eff) - Implicit Real*8 (a-h,o-z) - Real*8 Exp(NrExp), Cff(NrExp,NrBas) -* - nBas_Eff=NrBas -* - Do iBas = 1, NrBas -* - Do iExp = 1, nExp_Eff -* - If (Cff(iExp,iBas).ne.0.0D0) Then - nBas_Eff = NrBas-iBas+1 - Return - End If -* - End Do -* - End Do -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_real_array(Exp) - End diff -Nru openmolcas-22.02/src/nq_util/nbas_eff.F90 openmolcas-22.10/src/nq_util/nbas_eff.F90 --- openmolcas-22.02/src/nq_util/nbas_eff.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/nbas_eff.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,40 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +function nBas_Eff(NrExp,NrBas,Cff,nExp_Eff) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp) :: nBas_Eff +integer(kind=iwp), intent(in) :: NrExp, NrBas, nExp_Eff +real(kind=wp), intent(in) :: Cff(NrExp,NrBas) +integer(kind=iwp) :: iBas, iExp + +nBas_Eff = NrBas + +do iBas=1,NrBas + + do iExp=1,nExp_Eff + + if (Cff(iExp,iBas) /= Zero) then + nBas_Eff = NrBas-iBas+1 + return + end if + + end do + +end do + +return + +end function nBas_Eff diff -Nru openmolcas-22.02/src/nq_util/nq_grid.F90 openmolcas-22.10/src/nq_util/nq_grid.F90 --- openmolcas-22.02/src/nq_util/nq_grid.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/nq_grid.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,34 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +module nq_Grid + +use Definitions, only: wp, iwp + +implicit none +private + +! nGridMax: size of the array Grid +integer(kind=iwp) :: kAO = 0, nGridMax = 128, nRho = 0 +logical(kind=iwp) :: l_CASDFT = .false. +integer(kind=iwp), allocatable :: Angular(:), iBfn_Index(:,:), IndGrd(:), iTab(:,:), List_G(:,:), nR_Eff(:) +real(kind=wp), allocatable :: Coor(:,:), D1Unzip(:,:), Dens_AO(:,:,:), dRho_dR(:,:,:), dW_dR(:,:), F_xc(:), F_xca(:), F_xcb(:), & + Fact(:,:), GradRho(:,:), Grid(:,:), Grid_AO(:,:,:,:), Lapl(:,:), Mem(:), P2Unzip(:,:,:,:), Pax(:,:), & + R2_trial(:), Rho(:,:), Sigma(:,:), Tau(:,:), Temp(:), vLapl(:,:), vRho(:,:), vSigma(:,:), vTau(:,:), & + Weights(:) +real(kind=wp), allocatable, target :: TabAO(:,:,:), TabAO_Short(:,:,:) +real(kind=wp), pointer :: TabAO_pack(:) => null() + +public :: Angular, Coor, D1Unzip, Dens_AO, dRho_dR, dW_dR, F_xc, F_xca, F_xcb, Fact, GradRho, Grid, Grid_AO, iBfn_Index, IndGrd, & + iTab, kAO, l_CASDFT, Lapl, List_G, Mem, nGridMax, nR_Eff, nRho, P2Unzip, Pax, R2_trial, Rho, Sigma, TabAO, TabAO_pack, & + TabAO_Short, Tau, Temp, vLapl, vRho, vSigma, vTau, Weights + +end module nq_Grid diff -Nru openmolcas-22.02/src/nq_util/nq_Grid.f90 openmolcas-22.10/src/nq_util/nq_Grid.f90 --- openmolcas-22.02/src/nq_util/nq_Grid.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/nq_Grid.f90 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** -Module nq_Grid -Real*8, Allocatable:: Pax(:,:) -Real*8, Allocatable:: Coor(:,:) -Real*8, Allocatable:: R2_trial(:) -Real*8, Allocatable:: Fact(:,:) -Real*8, Allocatable:: Mem(:) -Integer, Allocatable:: Angular(:) -Integer, Allocatable:: nR_Eff(:) - -Integer, Allocatable:: List_G(:,:) -Integer, Allocatable:: iTab(:,:) -Integer, Allocatable:: IndGrd(:) -Real*8, Allocatable:: Temp(:) -Real*8, Allocatable:: P2Unzip(:), D1Unzip(:) -Real*8, Allocatable:: dW_dR(:,:) - -Real*8, Allocatable:: Weights(:) -Real*8, Allocatable:: Grid(:,:) -! nGridMax: size of the array Grid -Integer :: nGridMax=128 -Real*8, Allocatable:: Rho(:,:) -Real*8, Allocatable:: vRho(:,:) -Integer :: nRho=0 -Real*8, Allocatable:: GradRho(:,:) -Integer :: nGradRho=0 -Real*8, Allocatable:: Sigma(:,:) -Real*8, Allocatable:: vSigma(:,:) -Integer :: nSigma=0 -Real*8, Allocatable:: Lapl(:,:) -Real*8, Allocatable:: vLapl(:,:) -Integer :: nLapl=0 -Real*8, Allocatable:: Tau(:,:) -Real*8, Allocatable:: vTau(:,:) -Integer :: nTau=0 -Logical :: l_CASDFT=.FALSE. -Real*8, Allocatable:: F_xc(:), F_xca(:), F_xcb(:) -Real*8, Allocatable, Target:: TabAO(:,:,:) -Real*8, Allocatable, Target:: TabAO_Short(:,:,:) -Real*8, Pointer:: TabAO_pack(:) => Null() -Real*8, Allocatable:: Grid_AO(:,:,:,:) -Real*8, Allocatable:: Dens_AO(:,:,:) -Real*8, Allocatable:: dRho_dR(:,:,:) -Integer, Allocatable:: iBfn_Index(:,:) -Integer :: kAO=0 -End Module nq_Grid diff -Nru openmolcas-22.02/src/nq_util/nqgrid_init.f openmolcas-22.10/src/nq_util/nqgrid_init.f --- openmolcas-22.02/src/nq_util/nqgrid_init.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/nqgrid_init.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,46 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine NQGrid_Init() - use Grid_On_Disk - Implicit Real*8 (A-H,O-Z) -#include "functional_types.fh" -* * -************************************************************************ -* * -* Make the grid file dirty -* -*---- Open the file. - Lu_Grid=77 - Call DaName_MF_WA(Lu_Grid,'NQGRID') -* -*---- Write the status flag and disk addresses fo the sets. -* - iDisk_Set(Final)=-1 - iDisk_Set(Intermediate)=-1 - G_S(Final)=Regenerate - G_S(Intermediate)=Regenerate - Old_Functional_Type=Other_Type -* - iDisk_Grid=0 - Call iDaFile(Lu_Grid,1,G_S,5,iDisk_Grid) -* - iDisk_Set(Final)=iDisk_Grid - iDisk_Set(Intermediate)=iDisk_Grid -* - iDisk_Grid=0 - Call iDaFile(Lu_Grid,1,G_S,5,iDisk_Grid) -* - Call DaClos(Lu_Grid) -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/nqgrid_init.F90 openmolcas-22.10/src/nq_util/nqgrid_init.F90 --- openmolcas-22.02/src/nq_util/nqgrid_init.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/nqgrid_init.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,57 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine NQGrid_Init() + +use Grid_On_Disk, only: Final_Grid, G_S, iDisk_Grid, iDisk_Set, Intermediate, Lu_Grid, Old_Functional_Type, Regenerate +use nq_Info, only: Other_Type +use Definitions, only: iwp + +implicit none +integer(kind=iwp) :: iDisk, iDum(1) + +! * +!*********************************************************************** +! * +! Make the grid file dirty + +! Open the file. +Lu_Grid = 77 +call DaName_MF_WA(Lu_Grid,'NQGRID') + +! Write the status flag and disk addresses fo the sets. + +iDisk_Set(Final_Grid) = -1 +iDisk_Set(Intermediate) = -1 +G_S(Final_Grid) = Regenerate +G_S(Intermediate) = Regenerate +Old_Functional_Type = Other_Type + +iDisk_Grid = 0 +call iDaFile(Lu_Grid,1,G_S,2,iDisk_Grid) +iDisk = iDisk_Grid +call iDaFile(Lu_Grid,1,iDisk_Set,2,iDisk_Grid) +iDum(1) = Old_Functional_Type +call iDaFile(Lu_Grid,1,iDum,1,iDisk_Grid) + +iDisk_Set(Final_Grid) = iDisk_Grid +iDisk_Set(Intermediate) = iDisk_Grid + +call iDaFile(Lu_Grid,1,iDisk_Set,2,iDisk) + +call DaClos(Lu_Grid) +! * +!*********************************************************************** +! * + +return + +end subroutine NQGrid_Init diff -Nru openmolcas-22.02/src/nq_util/nq_info.f90 openmolcas-22.10/src/nq_util/nq_info.f90 --- openmolcas-22.02/src/nq_util/nq_info.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/nq_info.f90 1970-01-01 00:00:00.000000000 +0000 @@ -1,98 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** -! -! R_Max : Maximum radius associated with the i'th center for the -! radial loop. -! Integer -! -! L_Quad : Value of the angular momentum for which the grid is -! generated unless the quadrature is pruned. -! nR : Initial number of radial points for which the grid is -! generated. -! nAtoms : Number of atoms in the system. -! nMaxExp : Maximum number of exponents over all the shells. -! NbrMxBas: Maximum number of basis functions over all the shells. -! nTotGP : Total number of grid points generated during the program. -! iAngMax : Maximum angulart momentum for the system. -! -! Pointer -! -! ip_ioffsh : Pointer to the offset of the shells in the -! overlap matrix. -! -Module nq_Info - Integer LMax_NQ - Parameter(LMax_NQ=62) - Integer mBas(0:7),nISh(0:7), nAsh(0:7), nFro(0:7),mOrb(0:7) - Integer IOff_Ash(0:7),IOff_Bas(0:7),IOff_BasAct(0:7) - Integer OffOrb(0:7),OffOrb2(0:7),OffOrbTri(0:7),OffBas2(0:7) - Integer OffBas(0:7),OffBasFro(0:7),OffPUVX(0:7) - INTEGER OffUVX(0:7,0:7,0:7),nUVX(0:7,0:7,0:7) - INTEGER OffVX(0:7,0:7),nVX(0:7,0:7) -#include "functional_types.fh" - Integer Grid_Type, Fixed_Grid, Moving_Grid - Parameter(Fixed_Grid=0,Moving_Grid=1) - Integer Angular_Prunning, On, Off, Rotational_Invariance, & - & Functional_Type - Integer Packing - Parameter(On=1, Off=0) - Integer iQStrt,NASHT,NASHT4,NPOt1,nOrbt,nPot2,maxUVX, & - & ndc,nUVXt ,nVXt, & - & nAngularGrids, & - & L_Quad_save, nR_Save, & - & nx,ny,nz,number_of_subblocks, & - & ip_nR_Eff,ip_R,ipMem,nMem, & - & L_Quad,nR,nAtoms,nMaxExp, & - & nTotGP,nbrmxbas,iAngMax,ip_ioffsh, & - & iOpt_Angular, mIrrep, & - & mTmp,mRad,nAOMax, & - & NQ_Direct, & - & iQEnd,ip_OrbDip(3) - Common /Quad_i / iQStrt,NASHT,NASHT4,NPot1,nOrbt,nPot2,maxUVX, & - & ndc, & - & nAngularGrids, & - & L_Quad_save, nR_Save, Angular_Prunning, & - & nx,ny,nz,number_of_subblocks, & - & ip_nR_Eff,ip_R,ipMem,nMem, & - & L_Quad,nR,nAtoms,nMaxExp, & - & nTotGP,nbrmxbas,iAngMax,ip_ioffsh, & - & iOpt_Angular, & - & mIrrep, nISh, nAsh, mBas,Functional_type,mOrb, & - & Grid_Type, Rotational_Invariance, & - & mTmp,mRad,nAOMax, & - & NQ_Direct,Packing,OffPUVX, & - & iQEnd,ip_OrbDip,ioff_ash,ioff_bas,ioff_basact, & - & OffBas,OffOrb,OffOrb2,OffOrbTri,OffBas2, & - & OffBasFro,OffUVX,nUVX,nUVXt,OffVX,nVX,nVXt - Common /Quad_ii / nFro -! - Real*8 R_Max(0:LMax_NQ) - Real*8 rQStrt,Threshold_save,Crowding,Threshold,Energy_integrated, & - & Dens_I,Grad_I,Tau_I,Dens_a1,Dens_b1,Dens_a2,Dens_b2, & - & Dens_t1,Dens_t2,Block_Size,x_min,x_max,y_min,y_max,z_min, & - & z_max,Fade,ThrC,T_Y,rQEnd - Common /Quad_r /rQStrt, & - & Threshold_save, Crowding, & - & Threshold,R_Max,Energy_integrated, & - & Dens_I,Grad_I,Tau_I, & - & Dens_a1,Dens_b1,Dens_a2,Dens_b2,Dens_t1,Dens_t2, & - & Block_Size,x_min,x_max,y_min,y_max,z_min,z_max, & - & Fade, ThrC, T_Y, & - & rQEnd -! - Integer cQStrt, cQEnd - Character Quadrature*10, Pad*6, MBC*8 -! - Common /Quad_c /cQStrt, & - & Quadrature, Pad, MBC, & - & cQEnd -! -End Module nq_Info diff -Nru openmolcas-22.02/src/nq_util/nq_info.F90 openmolcas-22.10/src/nq_util/nq_info.F90 --- openmolcas-22.02/src/nq_util/nq_info.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/nq_info.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,337 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +module nq_Info + +use Definitions, only: wp, iwp + +implicit none +private + +! R_Max : Maximum radius associated with the i'th center for the +! radial loop. +! Integer +! +! L_Quad : Value of the angular momentum for which the grid is +! generated unless the quadrature is pruned. +! nR : Initial number of radial points for which the grid is +! generated. +! nAtoms : Number of atoms in the system. +! nTotGP : Total number of grid points generated during the program. + +integer(kind=iwp), parameter :: LMax_NQ = 62, & + Other_Type = 0, LDA_Type = 1, GGA_Type = 2, meta_GGA_Type1 = 3, meta_GGA_Type2 = 4, & + Fixed_Grid = 0, Moving_Grid = 1, & + On = 1, Off = 0 +integer(kind=iwp) :: Angular_Pruning, Functional_Type, Grid_Type, IOff_Ash(0:7), IOff_Bas(0:7), IOff_BasAct(0:7), iOpt_Angular, & + L_Quad, L_Quad_save, mBas(0:7), mIrrep, mOrb(0:7), mRad, nAngularGrids, nAsh(0:7), NASHT, nAtoms, ndc, & + nFro(0:7), nISh(0:7), nOrbt, nPot1, nPot2, NQ_Direct, nR, nR_Save, nTotGP, number_of_subblocks, & + nUVX(0:7,0:7,0:7), nUVXt, nVX(0:7,0:7), nVXt, nx, ny, nz, OffBas(0:7), OffBas2(0:7), OffBasFro(0:7), & + OffOrb(0:7), OffOrb2(0:7), OffOrbTri(0:7), OffPUVX(0:7), OffUVX(0:7,0:7,0:7), OffVX(0:7,0:7), Packing, & + Rotational_Invariance +real(kind=wp) :: Block_Size, Crowding, Dens_a1, Dens_a2, Dens_b1, Dens_b2, Dens_I, Dens_t1, Dens_t2, Energy_integrated, Fade, & + Grad_I, R_Max(0:LMax_NQ), T_Y, Tau_I, ThrC, Threshold, Threshold_save, x_min, y_min, z_min +character(len=10) :: Quadrature +character(len=8) :: MBC + +public :: Angular_Pruning, Block_Size, Crowding, Dens_a1, Dens_a2, Dens_b1, Dens_b2, Dens_I, Dens_t1, Dens_t2, Energy_integrated, & + Fade, Fixed_Grid, Functional_Type, GGA_Type, Grad_I, Grid_Type, IOff_Ash, IOff_Bas, IOff_BasAct, iOpt_Angular, L_Quad, & + L_Quad_save, LDA_Type, LMax_NQ, mBas, MBC, meta_GGA_Type1, meta_GGA_Type2, mIrrep, mOrb, Moving_Grid, mRad, & + nAngularGrids, nAsh, NASHT, nAtoms, ndc, nFro, nISh, nOrbt, nPot1, nPot2, NQ_Direct, NQ_Info_Dmp, NQ_Info_Get, nR, & + nR_Save, nTotGP, number_of_subblocks, nUVX, nUVXt, nVX, nVXt, nx, ny, nz, Off, OffBas, OffBas2, OffBasFro, OffOrb, & + OffOrb2, OffOrbTri, OffPUVX, OffUVX, OffVX, On, Other_Type, Packing, Quadrature, R_Max, Rotational_Invariance, T_Y, & + Tau_I, ThrC, Threshold, Threshold_save, x_min, y_min, z_min + +contains + +subroutine NQ_Info_Dmp() + + use fortran_strings, only: char_array, str + use stdalloc, only: mma_allocate, mma_deallocate + + integer(kind=iwp) :: i, lcDmp + integer(kind=iwp), allocatable :: iDmp(:) + real(kind=wp), allocatable :: rDmp(:) + character, allocatable :: cDmp(:) + integer(kind=iwp), parameter :: liDmp = 25+5*8, lrDmp = 20+(LMax_NQ+1) + + ! Real Stuff + + call mma_allocate(rDmp,lrDmp,Label='rDmp') + i = 1 + rDmp(i) = Threshold_save + i = i+1 + rDmp(i) = Crowding + i = i+1 + rDmp(i) = Threshold + i = i+1 + rDmp(i:i+LMax_NQ) = R_Max + i = i+LMax_NQ+1 + rDmp(i) = Energy_integrated + i = i+1 + rDmp(i) = Dens_I + i = i+1 + rDmp(i) = Grad_I + i = i+1 + rDmp(i) = Tau_I + i = i+1 + rDmp(i) = Dens_a1 + i = i+1 + rDmp(i) = Dens_b1 + i = i+1 + rDmp(i) = Dens_a2 + i = i+1 + rDmp(i) = Dens_b2 + i = i+1 + rDmp(i) = Dens_t1 + i = i+1 + rDmp(i) = Dens_t2 + i = i+1 + rDmp(i) = Block_Size + i = i+1 + rDmp(i) = x_min + i = i+1 + rDmp(i) = y_min + i = i+1 + rDmp(i) = z_min + i = i+1 + rDmp(i) = Fade + i = i+1 + rDmp(i) = ThrC + i = i+1 + rDmp(i) = T_Y + i = i+1 + call Put_dArray('Quad_r',rDmp,lrDmp) + call mma_deallocate(rDmp) + + ! Integer Stuff + + call mma_allocate(iDmp,liDmp,Label='iDmp') + i = 1 + iDmp(i) = NASHT + i = i+1 + iDmp(i) = nPot1 + i = i+1 + iDmp(i) = nOrbt + i = i+1 + iDmp(i) = nPot2 + i = i+1 + iDmp(i) = ndc + i = i+1 + iDmp(i) = nAngularGrids + i = i+1 + iDmp(i) = L_Quad_save + i = i+1 + iDmp(i) = nR_Save + i = i+1 + iDmp(i) = Angular_Pruning + i = i+1 + iDmp(i) = nx + i = i+1 + iDmp(i) = ny + i = i+1 + iDmp(i) = nz + i = i+1 + iDmp(i) = number_of_subblocks + i = i+1 + iDmp(i) = L_Quad + i = i+1 + iDmp(i) = nR + i = i+1 + iDmp(i) = nAtoms + i = i+1 + iDmp(i) = nTotGP + i = i+1 + iDmp(i) = iOpt_Angular + i = i+1 + iDmp(i) = mIrrep + i = i+1 + iDmp(i:i+7) = nISh + i = i+8 + iDmp(i:i+7) = nAsh + i = i+8 + iDmp(i:i+7) = mBas + i = i+8 + iDmp(i) = Functional_type + i = i+1 + iDmp(i:i+7) = mOrb + i = i+8 + iDmp(i) = Grid_Type + i = i+1 + iDmp(i) = Rotational_Invariance + i = i+1 + iDmp(i) = mRad + i = i+1 + iDmp(i) = NQ_Direct + i = i+1 + iDmp(i) = Packing + i = i+1 + iDmp(i:i+7) = OffPUVX + i = i+8 + call Put_iArray('Quad_i',iDmp,liDmp) + call mma_deallocate(iDmp) + + ! Character Stuff + + lcDmp = len(Quadrature)+len(MBC) + call mma_allocate(cDmp,lcDmp,Label='cDmp') + i = 0 + cDmp(i+1:i+len(Quadrature)) = char_array(Quadrature) + i = i+len(Quadrature) + cDmp(i+1:i+len(MBC)) = char_array(MBC) + i = i+len(MBC) + call Put_cArray('Quad_c',str(cDmp),lcDmp) + call mma_deallocate(cDmp) + +end subroutine + +subroutine NQ_Info_Get() + + use fortran_strings, only: str + use stdalloc, only: mma_allocate, mma_deallocate + + integer(kind=iwp) :: i, lcDmp + integer(kind=iwp), allocatable :: iDmp(:) + real(kind=wp), allocatable :: rDmp(:) + character, allocatable :: cDmp(:) + integer(kind=iwp), parameter :: liDmp = 25+5*8, lrDmp = 20+(LMax_NQ+1) + + ! Real Stuff + + call mma_allocate(rDmp,lrDmp,Label='rDmp') + call Get_dArray('Quad_r',rDmp,lrDmp) + i = 1 + Threshold_save = rDmp(i) + i = i+1 + Crowding = rDmp(i) + i = i+1 + Threshold = rDmp(i) + i = i+1 + R_Max = rDmp(i:i+LMax_NQ) + i = i+LMax_NQ+1 + Energy_integrated = rDmp(i) + i = i+1 + Dens_I = rDmp(i) + i = i+1 + Grad_I = rDmp(i) + i = i+1 + Tau_I = rDmp(i) + i = i+1 + Dens_a1 = rDmp(i) + i = i+1 + Dens_b1 = rDmp(i) + i = i+1 + Dens_a2 = rDmp(i) + i = i+1 + Dens_b2 = rDmp(i) + i = i+1 + Dens_t1 = rDmp(i) + i = i+1 + Dens_t2 = rDmp(i) + i = i+1 + Block_Size = rDmp(i) + i = i+1 + x_min = rDmp(i) + i = i+1 + y_min = rDmp(i) + i = i+1 + z_min = rDmp(i) + i = i+1 + Fade = rDmp(i) + i = i+1 + ThrC = rDmp(i) + i = i+1 + T_Y = rDmp(i) + i = i+1 + call mma_deallocate(rDmp) + + ! Integer Stuff + + call mma_allocate(iDmp,liDmp,Label='iDmp') + call Get_iArray('Quad_i',iDmp,liDmp) + i = 1 + NASHT = iDmp(i) + i = i+1 + NPot1 = iDmp(i) + i = i+1 + nOrbt = iDmp(i) + i = i+1 + nPot2 = iDmp(i) + i = i+1 + ndc = iDmp(i) + i = i+1 + nAngularGrids = iDmp(i) + i = i+1 + L_Quad_save = iDmp(i) + i = i+1 + nR_Save = iDmp(i) + i = i+1 + Angular_Pruning = iDmp(i) + i = i+1 + nx = iDmp(i) + i = i+1 + ny = iDmp(i) + i = i+1 + nz = iDmp(i) + i = i+1 + number_of_subblocks = iDmp(i) + i = i+1 + L_Quad = iDmp(i) + i = i+1 + nR = iDmp(i) + i = i+1 + nAtoms = iDmp(i) + i = i+1 + nTotGP = iDmp(i) + i = i+1 + iOpt_Angular = iDmp(i) + i = i+1 + mIrrep = iDmp(i) + i = i+1 + nISh = iDmp(i:i+7) + i = i+8 + nAsh = iDmp(i:i+7) + i = i+8 + mBas = iDmp(i:i+7) + i = i+8 + Functional_type = iDmp(i) + i = i+1 + mOrb = iDmp(i:i+7) + i = i+8 + Grid_Type = iDmp(i) + i = i+1 + Rotational_Invariance = iDmp(i) + i = i+1 + mRad = iDmp(i) + i = i+1 + NQ_Direct = iDmp(i) + i = i+1 + Packing = iDmp(i) + i = i+1 + OffPUVX = iDmp(i:i+7) + i = i+8 + call mma_deallocate(iDmp) + + ! Character Stuff + + lcDmp = len(Quadrature)+len(MBC) + call mma_allocate(cDmp,lcDmp,Label='cDmp') + call Get_cArray('Quad_c',cDmp,lcDmp) + i = 0 + Quadrature = str(cDmp(i+1:i+len(Quadrature))) + i = i+len(Quadrature) + MBC = str(cDmp(i+1:i+len(MBC))) + i = i+len(MBC) + call mma_deallocate(cDmp) + +end subroutine NQ_Info_Get + +end module nq_Info diff -Nru openmolcas-22.02/src/nq_util/nq_init.f openmolcas-22.10/src/nq_util/nq_init.f --- openmolcas-22.02/src/nq_util/nq_init.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/nq_init.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine NQ_Init() - use Grid_On_Disk -* -*---- Inititalize to no specified grid set. -* - iGrid_Set=Not_Specified -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/nq_init.F90 openmolcas-22.10/src/nq_util/nq_init.F90 --- openmolcas-22.02/src/nq_util/nq_init.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/nq_init.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,24 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine NQ_Init() + +use Grid_On_Disk, only: iGrid_Set, Not_Specified + +implicit none + +! Initialize to no specified grid set. + +iGrid_Set = Not_Specified + +return + +end subroutine NQ_Init diff -Nru openmolcas-22.02/src/nq_util/nq_mo.F90 openmolcas-22.10/src/nq_util/nq_mo.F90 --- openmolcas-22.02/src/nq_util/nq_mo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/nq_mo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,24 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +module nq_MO + +use Definitions, only: wp + +implicit none +private + +integer :: nMOs = 0 +real(kind=wp), allocatable :: CMO(:), D1MO(:), P2_ontop(:,:), P2MO(:) + +public :: CMO, D1MO, nMOs, P2_ontop, P2MO + +end module nq_MO diff -Nru openmolcas-22.02/src/nq_util/nq_MO.f90 openmolcas-22.10/src/nq_util/nq_MO.f90 --- openmolcas-22.02/src/nq_util/nq_MO.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/nq_MO.f90 1970-01-01 00:00:00.000000000 +0000 @@ -1,16 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** -Module nq_MO - Integer:: nMOs=0 - Real*8, Allocatable:: CMO(:) - Real*8, Allocatable:: D1MO(:), P2MO(:) - Real*8, Allocatable:: P2_ontop(:,:) -End Module nq_MO diff -Nru openmolcas-22.02/src/nq_util/nq_pdft.f90 openmolcas-22.10/src/nq_util/nq_pdft.f90 --- openmolcas-22.02/src/nq_util/nq_pdft.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/nq_pdft.f90 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** -Module nq_pdft - -! ThrsRho: threshold of total density -! ThrsOMR: threshold of (1 - R) -! ThrsFT : threshold for doing full translation in ft functionals -! a.k.a R0 in the ft paper -! ThrsNT : threshold for not doing any translation in ft functionals -! a.k.a R1 in the ft paper - -Real*8 :: ThrsRho = 1.00d-15 -Real*8 :: ThrsOMR = 1.00d-15 -Real*8 :: ThrsFT = 0.90d0 -Real*8 :: ThrsNT = 1.15d0 -Real*8 :: fta = -4.756065601d2 -Real*8 :: ftb = -3.794733192d2 -Real*8 :: ftc = -8.538149682d1 - -Logical :: lGGA=.False., lft=.False. -Logical,DIMENSION(:),Allocatable::Pass1,Pass2,Pass3 -Real*8 ,DIMENSION(:),Allocatable::RhoAB,OnePZ,OneMZ,RatioA,ZetaA -Real*8 ,DIMENSION(:),Allocatable::dZdR,dRdRho,dZdRho,dRdPi -Real*8 ,DIMENSION(:),Allocatable::dRhoadZ,dRhoaxdZ,dRhoaydZ,dRhoazdZ -Real*8 ,DIMENSION(:),Allocatable::dRhodX,dRhodY,dRhodZ -Real*8 ,DIMENSION(:),Allocatable::dF_dRhoapb,dF_dRhoamb -Real*8 ,DIMENSION(:),Allocatable::dF_dRhoxapb,dF_dRhoxamb -Real*8 ,DIMENSION(:),Allocatable::dF_dRhoyapb,dF_dRhoyamb -Real*8 ,DIMENSION(:),Allocatable::dF_dRhozapb,dF_dRhozamb -Real*8 ,DIMENSION(:),Allocatable::GradRhodFdRho,GradRdFdRho,GradPidFdRho -Real*8 ,DIMENSION(:),Allocatable::dEdRho,dEdRhox,dEdRhoy,dEdRhoz -Real*8 ,DIMENSION(:),Allocatable::dEdPi,dEdPix,dEdPiy,dEdPiz -Real*8 ,DIMENSION(:),Allocatable::dEdPiMO,GdEdPiMO -Real*8 ,DIMENSION(:),Allocatable::d2RdRho2,d2RdRhodPi,d2ZdR2 -Real*8 ,DIMENSION(:),Allocatable::MOas,MOax,MOay,MOaz -End Module nq_pdft diff -Nru openmolcas-22.02/src/nq_util/nq_pdft.F90 openmolcas-22.10/src/nq_util/nq_pdft.F90 --- openmolcas-22.02/src/nq_util/nq_pdft.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/nq_pdft.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,42 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +module nq_pdft + +use Definitions, only: wp, iwp + +implicit none +private + +! ThrsRho: threshold of total density +! ThrsOMR: threshold of (1 - R) +! ThrsFT : threshold for doing full translation in ft functionals +! a.k.a. R0 in the ft paper +! ThrsNT : threshold for not doing any translation in ft functionals +! a.k.a. R1 in the ft paper + +real(kind=wp), parameter :: fta = -475.6065601_wp, ftb = -379.4733192_wp, ftc = -85.3814968_wp, ThrsFT = 0.9_wp, ThrsNT = 1.15_wp, & + ThrsOMR = 1.0e-15_wp, ThrsRho = 1.0e-15_wp +logical(kind=iwp) :: lft = .false., lGGA = .false. +real(kind=wp), allocatable :: d2RdRho2(:), d2RdRhodPi(:), d2ZdR2(:), dEdPi(:), dEdPiMO(:,:), dEdPix(:), dEdPiy(:), dEdPiz(:), & + dEdRho(:), dEdRhox(:), dEdRhoy(:), dEdRhoz(:), dF_dRhoamb(:), dF_dRhoapb(:), dF_dRhoxamb(:), & + dF_dRhoxapb(:), dF_dRhoyamb(:), dF_dRhoyapb(:), dF_dRhozamb(:), dF_dRhozapb(:), dRdPi(:), dRdRho(:), & + dRhodX(:), dRhodY(:), dRhodZ(:), dZdR(:), dZdRho(:), GdEdPiMO(:,:), GradPidFdRho(:), GradRdFdRho(:), & + GradRhodFdRho(:), MOas(:,:), MOax(:,:), MOay(:,:), MOaz(:,:), OneMZ(:), OnePZ(:), RatioA(:), & + RhoAB(:), ZetaA(:) +logical(kind=iwp), allocatable :: Pass1(:), Pass2(:), Pass3(:) + +public :: d2RdRho2, d2RdRhodPi, d2ZdR2, dEdPi, dEdPiMO, dEdPix, dEdPiy, dEdPiz, dEdRho, dEdRhox, dEdRhoy, dEdRhoz, dF_dRhoamb, & + dF_dRhoapb, dF_dRhoxamb, dF_dRhoxapb, dF_dRhoyamb, dF_dRhoyapb, dF_dRhozamb, dF_dRhozapb, dRdPi, dRdRho, dRhodX, dRhodY, & + dRhodZ, dZdR, dZdRho, fta, ftb, ftc, GdEdPiMO, GradPidFdRho, GradRdFdRho, GradRhodFdRho, lft, lGGA, MOas, MOax, MOay, & + MOaz, OneMZ, OnePZ, Pass1, Pass2, Pass3, RatioA, RhoAB, ThrsFT, ThrsNT, ThrsOMR, ThrsRho, ZetaA + +end module nq_pdft diff -Nru openmolcas-22.02/src/nq_util/nqpdft_util.f openmolcas-22.10/src/nq_util/nqpdft_util.f --- openmolcas-22.02/src/nq_util/nqpdft_util.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/nqpdft_util.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,487 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2021, Jie J. Bao * -************************************************************************ -* **************************************************************** -* history: * -* Jie J. Bao, on Dec. 08, 2021, created this file. * -* **************************************************************** - Subroutine CalcOrbOff() - use nq_Info - - INTEGER jOffA_,jOffB_,nTri,iIrrep - - NASHT=0 - jOffA_ = 0 - jOffB_ = 0 - nPot1=0 - nTri=0 - nOrbt=0 - DO iIrrep=0,mIrrep-1 - mOrb(iIrrep)=mBas(iIrrep)-nFro(iIrrep) - nPot1=nPot1+mOrb(iIrrep)**2 - nOrbt=nOrbt+mOrb(iIrrep) - NASHT=NASHT+NASH(iIrrep) - iOff_Ash(iIrrep)=jOffA_ - iOff_Bas(iIrrep)=jOffB_ - OffBasFro(iIrrep)=jOffB_+nFro(iIrrep) - iOff_BasAct(iIrrep)=jOffB_ + nIsh(iIrrep) + nFro(iIrrep) - OffOrbTri(iIrrep)=nTri - nTri=nTri+mOrb(iIrrep)*(mOrb(iIrrep)+1)/2 - jOffA_=jOffA_+nAsh(iIrrep) - jOffB_=jOffB_+mBas(iIrrep) - END DO - - OffOrb(0)=0 - OffBas(0)=1 - OffBas2(0)=1 - OffOrb2(0)=0 - DO IIrrep=1,mIrrep-1 - OffBas(iIrrep) =OffBas(iIrrep-1) +mBas(iIrrep-1) - OffOrb(iIrrep) =OffOrb(iIrrep-1) +mOrb(iIrrep-1) - OffBas2(iIrrep)=OffBas2(iIrrep-1)+mBas(iIrrep-1)**2 - OffOrb2(iIrrep)=OffOrb2(iIrrep-1)+mOrb(iIrrep-1)**2 - END DO - - RETURN - End Subroutine - - Subroutine CalcPUVXOff() - use nq_Info - - INTEGER IOff1,iIrrep,jIrrep,kIrrep,lIrrep,iOrb,jAct,kAct,lAct, - & ijIrrep,klIrrep,nklAct - - IOff1=0 - DO kIrrep=0,mIrrep-1 - kAct=nAsh(kIrrep) - Do lIrrep=0,kIrrep - lAct=nAsh(lIrrep) - nklAct=kAct*lAct - If(kIrrep.eq.lIrrep) nklAct=kAct*(kAct+1)/2 - OffVX(lIrrep,kIrrep)=IOff1 - nVX(lIrrep,kIrrep)=nklAct - IOff1=IOff1+nklAct - End Do - END DO - nVXt=iOff1 - - IOff1=0 - DO jIrrep=0,mIrrep-1 - jAct=nAsh(jIrrep) - Do kIrrep=0,mIrrep-1 - kAct=nAsh(kIrrep) - do lIrrep=0,kIrrep - lAct=nAsh(lIrrep) - nklAct=kAct*lAct - If(kIrrep.eq.lIrrep) nklAct=kAct*(kAct+1)/2 - OffUVX(lIrrep,kIrrep,jIrrep)=IOff1 - nUVX(lIrrep,kIrrep,jIrrep)=jAct*nklAct - IOff1=iOff1+jAct*nklAct - end do - End Do - END DO - nUVXt=IOff1 - - IOff1=0 - DO iIrrep=0,mIrrep-1 - OffPUVX(iIrrep)=IOff1 - iOrb=mOrb(iIrrep) - Do jIrrep=0,mIrrep-1 - jAct=nAsh(jIrrep) - ijIrrep=1+IEOR(iIrrep,jIrrep) - Do kIrrep=0,mIrrep-1 - kAct=nAsh(kIrrep) - do lIrrep=0,kIrrep - lAct=nAsh(lIrrep) - klIrrep=1+IEOR(kIrrep,lIrrep) - IF(ijIrrep.eq.klIrrep) THEN - iOff1=iOff1+iOrb*nUVX(lIrrep,kIrrep,jIrrep) - END IF - end do - End Do - End Do - END DO - nPot2=IOff1 - -C write(6,*)'OffPUVX new method',nPot2,MaxUVX -C write(6,'(8(I5,2X))')(OffPUVX(iIrrep),iIrrep=0,mIrrep-1) - RETURN - End Subroutine - - Subroutine TransActMO(MOs,TabMO,mAO,mGrid,nMOs) - use nq_Info -******Purpose: -******Trasnferring active orbitals to the MOs array. -******It records the MO values on each grid point. -******The first and the second elements are the MO values -******of the first and the second active MO at grid point 1. -******Input - INTEGER mAO,mGrid,nMOs - Real*8,DIMENSION(mAO,mGrid,nMOs)::TabMO -******Output - Real*8,DIMENSION(mGrid*NASHT)::MOs -******Auxiliary - INTEGER nGridPi,iIrrep,IOff1,iOff2,iOff3 - - - nGridPi=mAO*mGrid - DO iGrid=1,mGrid - IOff1=(iGrid-1)*NASHT - Do iIrrep=0,mIrrep-1 - IOff2=IOff_Ash(iIrrep)+1 - IOff3=IOff_BasAct(iIrrep)+1 - CALL DCopy_(nAsh(iIrrep),TabMO(1,iGrid,IOff3),nGridPi, - & MOs(IOff1+IOff2) ,1) - End Do - END DO - RETURN - End Subroutine - - - Subroutine TransActMO2(MOs,MOas,mGrid) - use nq_Info -******Purpose: -******obtaining an active MO array with a structure of MOs in -******TransActMO from an MO array with a structure of that in -******TransferMO -******Input - INTEGER mGrid - Real*8,DIMENSION(mGrid*nOrbt)::MOas -******Output - Real*8,DIMENSION(mGrid*NASHT)::MOs -******Auxiliary - INTEGER iIrrep,IOff1,iOff2,iOff3 - - DO iGrid=1,mGrid - IOff3=(iGrid-1)*nAsht - Do iIrrep=0,mIrrep-1 - IOff2=IOff3+iOff_Ash(iIrrep)+1 - IOff1=(OffOrb(iIrrep)+nIsh(iIrrep))*mGrid+iGrid - CALL DCopy_(nAsh(iIrrep),MOas(iOff1),mGrid, - & MOs(IOff2) ,1 ) - End Do - END DO - - RETURN - End Subroutine - - - Subroutine TransferMO(MOas,TabMO,mAO,mGrid,nMOs,iAO) - use nq_Info - -******Purpose: -******Transferring MO information to MOas to be used in dgemm. -******It records the MO values on each grid point, too. -******But the difference from TransActMO is that the first and -******the second elements are the values of the first MO at grid -******point 1 and grid point 2. - -******Input - INTEGER mAO,mGrid,nMOs,iAO - Real*8,DIMENSION(mAO,mGrid,nMOs)::TabMO -******Output - Real*8,DIMENSION(mGrid*nOrbt)::MOas - -******Auxiliary - INTEGER iIrrep,IOff1,iOff2,iOff3,nCP - IOff3=0 - DO iIrrep=0,mIrrep-1 - IOff1=OffBasFro(iIrrep)+1 - IOff2=IOff3*mGrid+1 - nCP=mOrb(iIrrep)*mGrid - CALL DCopy_(nCP,TabMO(iAO,1,IOff1),mAO,MOas(IOff2),1) - IOff3=IOff3+mOrb(iIrrep) - END DO - RETURN - End Subroutine - - - Subroutine PackPot1(Packed,Full,nPack,Factor) - use nq_Info - -******Input - Real*8 Factor - Real*8,DIMENSION(NPot1)::Full -******Output - Real*8,DIMENSION(nPack)::Packed -******Auxiliary - INTEGER iIrrep,p,q,iOff1,IOff2,nOrbs - DO iIrrep=0,mIrrep-1 - nOrbs=mOrb(iIrrep) - IOff1=OffOrbTri(iIrrep) - IOff2=OffOrb2(iIrrep) - Do P=1,nOrbs - do Q=1,P - Packed(IOff1+(P-1)*P/2+Q)= - &Full(IOff2+(P-1)*nOrbs+Q)+Full(IOff2+(Q-1)*nOrbs+P) - end do - End Do - END DO - CALL DScal_(nPack,Factor,Packed,1) - RETURN - End Subroutine - - Subroutine UnzipD1(D1Unzip,D1MO,nD1MO) - use nq_Info - -******Input - INTEGER nD1MO - Real*8,DIMENSION(nD1MO)::D1MO -******Output - Real*8,DIMENSION(NASHT**2)::D1Unzip -******Intermediate - INTEGER iv,ix,iLoc1,iLoc2,iLoc3 - - CALL FZero(D1Unzip,NASHT**2) - DO iv=1,NASHT - Do ix=1,iv-1 - iLoc1=(iv-1)*NASHT+ix - iLoc2=(ix-1)*NASHT+iv - iLoc3=(iv-1)*iv/2+ix - D1Unzip(iLoc1)=0.5d0*D1MO(iLoc3) - D1Unzip(iLoc2)=D1Unzip(iLoc1) - End Do - ix=iv - iLoc1=(iv-1)*NASHT+ix - iLoc3=(iv+1)*iv/2 - D1Unzip(iLoc1)=0.5d0*D1MO(iLoc3) - END DO - - RETURN - End Subroutine - - - - Subroutine UnzipP2(P2Unzip,P2MO,nP2Act) - use nq_Info - -******Input - INTEGER nP2Act - Real*8,DIMENSION(nP2Act)::P2MO -******Output - Real*8,DIMENSION(NASHT4)::P2Unzip -******AUXILIARY - INTEGER NASHT2,NASHT3,IOFF1,IOff2,IOff3, - &I,J,K,L,IAct,JAct,kAct,LAct,iIrrep,jIrrep,kIrrep,lIrrep, - &IJ,KL,IJKL - Real*8 Fact - -************************************************************************ -* * - iTri(i,j) = Max(i,j)*(Max(i,j)-1)/2 + Min(i,j) -* * -************************************************************************ - - IF(NASHT4.eq.0) RETURN - - NASHT2=NASHT**2 - NASHT3=NASHT2*NASHT - - DO IIrrep = 0, mIrrep-1 - DO I=1,NASH(iIrrep) - IAct=iOff_Ash(iIrrep)+I - IOff1=(IAct-1)*NASHT3 - Do jIrrep = 0, mIrrep-1 - Do J=1,NASH(JIrrep) - JAct=iOff_Ash(JIrrep)+J - IOff2=IOff1+(JAct-1)*NASHT2 - IJ=iTri(IAct,JAct) - do kIrrep = 0, mIrrep-1 - do K=1,NASH(KIrrep) - KAct=IOff_Ash(KIrrep)+K - IOff3=IOff2+(KAct-1)*NASHT - do lIrrep = 0, mIrrep-1 - do L=1,NASH(lIrrep) - LAct=IOff_Ash(LIrrep)+L - KL=iTri(KAct,LAct) - IJKL=iTri(ij,kl) - Fact=0.5d0 - if((ij.ge.kl).and.(kAct.eq.lAct)) Fact=1.0d0 - if((kl.ge.ij).and.(iAct.eq.jAct)) Fact=1.0d0 - P2Unzip(IOff3+LAct)=P2MO(ijkl)*Fact - end do - end do - end do - end do - End Do - End Do - END DO - END DO - - RETURN - End Subroutine - -*********************************************************************** - - -*********************************************************************** - Subroutine CalcP2MOCube(P2MOCube,P2MOCubex,P2MOCubey,P2MOCubez, - & nPMO3p,MOs,MOx,MOy,MOz,TabMO,P2Unzip, - & mAO,mGrid,nMOs,do_grad) - use nq_pdft, only: lft, lGGA - use nq_Info - Implicit Real*8 (A-H,O-Z) -#include "stdalloc.fh" - -******Input - INTEGER mAO,mGrid,nMOs,nPMO3p - REAL*8,DIMENSION(mAO,mGrid,nMOs)::TabMO - Real*8,DIMENSION(NASHT4)::P2Unzip - Logical do_grad -******Output - REAL*8,DIMENSION(mGrid*NASHT)::P2MOCube,MOs,MOx,MOy,MOz - REAL*8,DIMENSION(nPMO3p)::P2MOCubex,P2MOCubey,P2MOCubez - -******Auxiliary - INTEGER iOff1,IOff2,IOff3,IIrrep,nGridPi,NASHT2,NASHT3,icount - Real*8,DIMENSION(NASHT**3)::P2MO1 - Real*8,DIMENSION(NASHT**2)::P2MOSquare - Logical lftGGA - - lftGGA=.false. - IF(lft.and.lGGA) lftGGA=.true. - nGridPi=mAO*mGrid - DO iGrid=1,mGrid - IOff1=(iGrid-1)*NASHT - Do iIrrep=0,mIrrep-1 - IOff2=IOff_Ash(iIrrep)+1 - IOff3=IOff_BasAct(iIrrep)+1 - CALL DCopy_(nAsh(iIrrep),TabMO(1,iGrid,IOff3),nGridPi, - & MOs(IOff1+IOff2) ,1) - do icount=1,nAsh(iIrrep) - end do - End Do - END DO - - - IF (lGGA) THEN - DO iGrid=1,mGrid - IOff1=(iGrid-1)*NASHT - Do iIrrep=0,mIrrep-1 - IOff2=IOff_Ash(iIrrep)+1 - IOff3=IOff_BasAct(iIrrep)+1 - CALL DCopy_(nAsh(iIrrep),TabMO(2,iGrid,IOff3),nGridPi, - & MOx(IOff1+IOff2) ,1) - CALL DCopy_(nAsh(iIrrep),TabMO(3,iGrid,IOff3),nGridPi, - & MOy(IOff1+IOff2) ,1) - CALL DCopy_(nAsh(iIrrep),TabMO(4,iGrid,IOff3),nGridPi, - & MOz(IOff1+IOff2) ,1) - End Do - END DO - END IF - - NASHT2=NASHT**2 - NASHT3=NASHT2*NASHT - DO iGrid=1,mGrid - IOff1=(iGrid-1)*NASHT+1 - -C write(6,*) 'MOs array' -C CALL RecPrt(' ','(10(F9.5,1X))',MOs(IOff1),1,NASHT) -C -C write(6,*) '2RDM array' -C CALL RecPrt(' ','(10(F9.5,1X))',P2Unzip,NASHT3,NASHT) - - CALL DGEMM_('T','N',NASHT3,1,NASHT,1.0d0, - & P2UnZip,NASHT,MOs(IOff1),NASHT, - & 0.0d0,P2MO1,NASHT3) - -C write(6,*) 'P2MO1 array' -C CALL RecPrt(' ','(10(F9.5,1X))',P2MO1,NASHT2,NASHT) - - CALL DGEMM_('T','N',NASHT2,1,NASHT,1.0d0, - & P2MO1,NASHT,MOs(IOff1),NASHT, - & 0.0d0,P2MOSquare,NASHT2) - -C write(6,*) 'P2MOSquare array' -C CALL RecPrt(' ','(10(F9.5,1X))',P2MOSquare,NASHT,NASHT) - - CALL DGEMM_('T','N',NASHT,1,NASHT,1.0d0, - & P2MOSquare,NASHT,MOs(IOff1),NASHT, - & 0.0d0,P2MOCube(iOff1),NASHT) - - IF(lftGGA.and.Do_Grad) THEN - CALL DGEMM_('T','N',NASHT,1,NASHT,1.0d0, - & P2MOSquare,NASHT,MOx(IOff1),NASHT, - & 0.0d0,P2MOCubex(iOff1),NASHT) - CALL DGEMM_('T','N',NASHT,1,NASHT,1.0d0, - & P2MOSquare,NASHT,MOy(IOff1),NASHT, - & 0.0d0,P2MOCubey(iOff1),NASHT) - CALL DGEMM_('T','N',NASHT,1,NASHT,1.0d0, - & P2MOSquare,NASHT,MOz(IOff1),NASHT, - & 0.0d0,P2MOCubez(iOff1),NASHT) - - CALL DGEMM_('T','N',NASHT2,1,NASHT,1.0d0, - & P2MO1,NASHT,MOx(IOff1),NASHT, - & 0.0d0,P2MOSquare,NASHT2) - CALL DGEMM_('T','N',NASHT,1,NASHT,2.0d0, - & P2MOSquare,NASHT,MOs(IOff1),NASHT, - & 1.0d0,P2MOCubex(iOff1),NASHT) - - CALL DGEMM_('T','N',NASHT2,1,NASHT,1.0d0, - & P2MO1,NASHT,MOy(IOff1),NASHT, - & 0.0d0,P2MOSquare,NASHT2) - CALL DGEMM_('T','N',NASHT,1,NASHT,2.0d0, - & P2MOSquare,NASHT,MOs(IOff1),NASHT, - & 1.0d0,P2MOCubey(iOff1),NASHT) - - CALL DGEMM_('T','N',NASHT2,1,NASHT,1.0d0, - & P2MO1,NASHT,MOz(IOff1),NASHT, - & 0.0d0,P2MOSquare,NASHT2) - CALL DGEMM_('T','N',NASHT,1,NASHT,2.0d0, - & P2MOSquare,NASHT,MOs(IOff1),NASHT, - & 1.0d0,P2MOCubez(iOff1),NASHT) - END IF - -C write(6,*) 'P2MOCube array' -C CALL RecPrt(' ','(10(F9.5,1X))',P2MOCube(IOff1),1,NASHT) - END DO - - - RETURN - END SUBROUTINE - - Subroutine ConvertTabSO(TabSO2,TabSO,mAO,mGrid,nMOs) - use nq_pdft, only: lft, lGGA - - INTEGER mAO,mGrid,nMOs,iGrid,nAOGrid - Real*8 :: TabSO(mAO,mGrid,nMOs) - Real*8 :: TabSO2(nMOs,mAO*mGrid) - - INTEGER :: iSt, iEnd, iAO, jAO, iOff - - nAOGrid=mAO*mGrid ! TabSO : mAO*mGrid x nMOs - ! TabSO2: nMOs x mAO*nGrid - - ! loop over first and optionally second derivatives of the SOs - ! this defines the length of nAO to 3 or 9. - iSt = 1 - If (lft.and.lGGA) Then - iEnd = 9 - Else - iEnd = 3 - End If - - Do iGrid=1,mGrid - - - Do jAO=iSt, iEnd - - iOff = (iGrid-1)*mAO + jAO - - iAO=jAO+1 - CALL DCopy_(nMOs,TabSO(iAO,iGrid,1),nAOGrid, - & TabSO2(:,iOff),1) - End Do - End Do - - RETURN - End Subroutine ConvertTabSO diff -Nru openmolcas-22.02/src/nq_util/nq_structure.f90 openmolcas-22.10/src/nq_util/nq_structure.f90 --- openmolcas-22.02/src/nq_util/nq_structure.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/nq_structure.f90 1970-01-01 00:00:00.000000000 +0000 @@ -1,80 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -! * -! Copyright (C) 2021, Roland Lindh * -!*********************************************************************** -Module NQ_Structure -Implicit None -Private -Public :: NQ_data, Close_NQ_Data, Info_Ang, Close_Info_Ang, LMax_NQ - -#include "stdalloc.fh" - -!define declare_ip_dodx ip_dOdx(iNQ,i) =ipNQ+(iNQ-1)*l_NQ+15+(iTabMx+1)+(i-1)*9 - -Type NQ_data_raw - Sequence - Real*8, Allocatable:: Coor(:) - Real*8 :: A_High=-1.0D99 - Real*8 :: A_Low = 1.0D99 - Real*8 :: R_RS =0.0D0 - Real*8 :: R_max =0.0D0 - Integer :: l_max=-1 - Real*8, Allocatable :: R_Quad(:,:) - Integer, Allocatable :: Angular(:) - Integer :: Atom_Nr=-1 - Real*8, Allocatable :: dOdx(:,:,:) -End Type NQ_data_raw - -Type (NQ_data_raw), Allocatable:: NQ_data(:) - -Type Info_A - Sequence - Integer :: L_eff=0 - Integer :: nPoints=0 - Real*8, Allocatable:: R(:,:) -End Type Info_A - -Integer, Parameter:: LMax_NQ=62 -Type (Info_A) Info_Ang(LMax_NQ) - -Contains - -Subroutine Close_Info_Ang() - -Integer iAngular -Do iAngular = 1, SIZE(Info_Ang) - Info_Ang(iAngular)%L_eff=0 - Info_Ang(iAngular)%nPoints=0 - If (Allocated(Info_Ang(iAngular)%R)) Call mma_deallocate(Info_Ang(iAngular)%R) -End Do -End Subroutine Close_Info_Ang - -Subroutine Close_NQ_Data() -Integer iNQ, nNQ -! Cleanup and close - nNQ = SIZE(NQ_data) - Do iNQ = 1, nNQ - Call mma_deallocate(NQ_data(iNQ)%Coor) - NQ_data(iNQ)%A_High=-1.0D99 - NQ_data(iNQ)%A_Low = 1.0D99 - NQ_data(iNQ)%R_RS =0.0D0 - NQ_data(iNQ)%R_max =0.0D0 - NQ_data(iNQ)%l_Max =-1 - If (Allocated(NQ_data(iNQ)%R_Quad))Call mma_deallocate(NQ_data(iNQ)%R_Quad) - If (Allocated(NQ_data(iNQ)%Angular))Call mma_deallocate(NQ_data(iNQ)%Angular) - NQ_Data(iNQ)%Atom_Nr=-1 - If (Allocated(NQ_data(iNQ)%dOdx))Call mma_deallocate(NQ_data(iNQ)%dOdx) - End Do - Deallocate(NQ_Data) -End Subroutine Close_NQ_Data - -End Module NQ_Structure - diff -Nru openmolcas-22.02/src/nq_util/nq_structure.F90 openmolcas-22.10/src/nq_util/nq_structure.F90 --- openmolcas-22.02/src/nq_util/nq_structure.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/nq_structure.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,126 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Roland Lindh * +!*********************************************************************** + +module NQ_Structure + +use NQ_Info, only: LMax_NQ +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +private + +type Info_Ang_t + integer(kind=iwp) :: L_eff = 0 + integer(kind=iwp) :: nPoints = 0 + real(kind=wp), allocatable :: R(:,:) +end type Info_Ang_t + +type NQ_data_t + real(kind=wp), allocatable :: Coor(:) + real(kind=wp) :: A_High = -huge(Zero) + real(kind=wp) :: A_Low = huge(Zero) + real(kind=wp) :: R_RS = Zero + real(kind=wp) :: R_max = Zero + integer(kind=iwp) :: l_max = -1 + real(kind=wp), allocatable :: R_Quad(:,:) + integer(kind=iwp), allocatable :: Angular(:) + integer(kind=iwp) :: Atom_Nr = -1 + real(kind=wp), allocatable :: dOdx(:,:,:) +end type NQ_data_t + +type(Info_Ang_t) Info_Ang(LMax_NQ) +type(NQ_data_t), allocatable :: NQ_data(:) + +public :: Close_Info_Ang, Close_NQ_Data, Info_Ang, NQ_data, Open_NQ_Data + +! Private extensions to mma interfaces + +interface cptr2loff + module procedure nqd_cptr2loff +end interface +interface mma_allocate + module procedure nqdata_mma_allo_1D, nqdata_mma_allo_1D_lim +end interface +interface mma_deallocate + module procedure nqdata_mma_free_1D +end interface + +contains + +subroutine Open_NQ_Data(Coor) + + real(kind=wp), intent(in) :: Coor(:,:) + integer(kind=iwp) :: iNQ, nNQ + + nNQ = size(Coor,2) + call mma_allocate(NQ_data,nNQ,'NQ_data') + do iNQ=1,nNQ + call mma_allocate(NQ_data(iNQ)%Coor,3,Label='NQ_data(iNQ)%Coor') + NQ_data(iNQ)%Coor(:) = Coor(1:3,iNQ) + end do + +# include "macros.fh" + unused_proc(mma_allocate(NQ_data,[0,0])) + +end subroutine Open_NQ_Data + +subroutine Close_Info_Ang() + + integer(kind=iwp) :: iAngular + + do iAngular=1,size(Info_Ang) + Info_Ang(iAngular)%L_eff = 0 + Info_Ang(iAngular)%nPoints = 0 + if (allocated(Info_Ang(iAngular)%R)) call mma_deallocate(Info_Ang(iAngular)%R) + end do + +end subroutine Close_Info_Ang + +subroutine Close_NQ_Data() + + integer(kind=iwp) :: iNQ + + ! Cleanup and close + do iNQ=1,size(NQ_data) + call mma_deallocate(NQ_data(iNQ)%Coor) + if (allocated(NQ_data(iNQ)%R_Quad)) call mma_deallocate(NQ_data(iNQ)%R_Quad) + if (allocated(NQ_data(iNQ)%Angular)) call mma_deallocate(NQ_data(iNQ)%Angular) + if (allocated(NQ_data(iNQ)%dOdx)) call mma_deallocate(NQ_data(iNQ)%dOdx) + end do + call mma_deallocate(NQ_Data) + +end subroutine Close_NQ_Data + +! Private extensions to mma_interfaces, using preprocessor templates +! (see src/mma_util/stdalloc.f) + +! Define nqd_cptr2loff, nqdata_mma_allo_1D, nqdata_mma_allo_1D_lim, nqdata_mma_free_1D +! (using _NO_GARBLE_ because all members are initialized) +#define _TYPE_ type(NQ_data_t) +# define _NO_GARBLE_ +# define _FUNC_NAME_ nqd_cptr2loff +# include "cptr2loff_template.fh" +# undef _FUNC_NAME_ +# define _SUBR_NAME_ nqdata_mma +# define _DIMENSIONS_ 1 +# define _DEF_LABEL_ 'nqd_mma' +# include "mma_allo_template.fh" +# undef _SUBR_NAME_ +# undef _DIMENSIONS_ +# undef _DEF_LABEL_ +# undef _NO_GARBLE_ +#undef _TYPE_ + +end module NQ_Structure diff -Nru openmolcas-22.02/src/nq_util/packpot1.F90 openmolcas-22.10/src/nq_util/packpot1.F90 --- openmolcas-22.02/src/nq_util/packpot1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/packpot1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,42 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Jie J. Bao * +!*********************************************************************** + +! **************************************************************** +! history: * +! Jie J. Bao, on Dec. 08, 2021, created this file. * +! **************************************************************** +subroutine PackPot1(Packed,Full,nPack,Factor) + +use nq_Info, only: mIrrep, mOrb, OffOrb2, OffOrbTri, nPot1 +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nPack +real(kind=wp), intent(out) :: Packed(nPack) +real(kind=wp), intent(in) :: Full(nPot1), Factor +integer(kind=iwp) :: iIrrep, iOff1, IOff2, nOrbs, p, q + +do iIrrep=0,mIrrep-1 + nOrbs = mOrb(iIrrep) + IOff1 = OffOrbTri(iIrrep) + IOff2 = OffOrb2(iIrrep) + do P=1,nOrbs + do Q=1,P + Packed(IOff1+(P-1)*P/2+Q) = Factor*(Full(IOff2+(P-1)*nOrbs+Q)+Full(IOff2+(Q-1)*nOrbs+P)) + end do + end do +end do + +return + +end subroutine PackPot1 diff -Nru openmolcas-22.02/src/nq_util/pdftfock.f openmolcas-22.10/src/nq_util/pdftfock.f --- openmolcas-22.02/src/nq_util/pdftfock.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/pdftfock.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,133 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2021, Jie J. Bao * -************************************************************************ -* **************************************************************** -* history: * -* Jie J. Bao, on Dec. 22, 2021, created this file. * -* **************************************************************** - - Subroutine PDFTFock(FI,FA,D1,mGrid,ActMO) - use nq_pdft - use nq_Info - -******Input - INTEGER mGrid - Real*8,DIMENSION(mGrid*NASHT)::ActMO - Real*8,DIMENSION(NASHT**2)::D1 -******Output - Real*8,DIMENSION(nPot1)::FI,FA -******Intermediate - Real*8,DIMENSION(mGrid)::Fact2 - Real*8,DIMENSION(mGrid*NASHT)::SumDX,dEdPiAct - Real*8 TempD1 - INTEGER iGrid,iIrrep,ik,k,iOff1,nGOrb - Real*8 ddot_ - External DDot_ - - nGOrb=mGrid*nOrbt - -******calculate FI. FI=2*dEdPi*pq*sum_k{kk*Fact1} -******TempD1: sum_k{kk} -******Fact2 : 2sum_k{kk} - DO iGrid=1,mGrid - TempD1=0.0d0 - Do iIrrep=0,mIrrep-1 - do ik=1,nIsh(iIrrep) - k=ik+OffOrb(iIrrep) - IOff1=(k-1)*mGrid+iGrid - TempD1=TempD1+MOas(IOff1)**2 - end do - End Do - Fact2(iGrid)=TempD1 - END DO - - CALL DScal_(mGrid,2.0d0,Fact2,1) - IF(lft.and.lGGA) THEN -****** In the end (drvnq_inner.f) there will be a process -****** in which FI_pq=0.5(FI_pq+FI_qp) -****** However, we do not want the factor of 0.5 for p'qrs part -****** So we add another copy of GdEdPiMO to pick up the factor -****** of 0.5 - CALL DAXpY_(nGOrb,1.0d0,GdEdPiMO,1,dEdPiMO,1) -****** Also the pqr's part is needed with the help of the following -***** array - CALL TransActMO2(dEdPiAct,GdEdPiMO,mGrid) - END IF - CALL PDFTFock_Inner(FI,Fact2,dEdPiMO,MOas,mGrid) - - IF(lft.and.lGGA) THEN - DO iGrid=1,mGrid - TempD1=0.0d0 - Do iIrrep=0,mIrrep-1 - do ik=1,nIsh(iIrrep) - k=ik+OffOrb(iIrrep) - IOff1=(k-1)*mGrid+iGrid - TempD1=TempD1+MOas(IOff1)*GdEdPiMO(iOff1) - end do - End Do - Fact2(iGrid)=TempD1 - END DO - CALL DScal_(mGrid,4.0d0,Fact2,1) - CALL PDFTFock_Inner(FI,Fact2,MOas,MOas,mGrid) - END IF -******calculate FA. FA=pq*sum_vx{vx*Dvx*Fact1} -******First calcualte sum_x{Dvx*x} - DO iGrid=1,mGrid - IOff1=(iGrid-1)*NASHT+1 - CALL DGEMM_('T','N',NASHT,1,NASHT,1.0d0, - & D1,NASHT,ActMO(IOff1),NASHT,0.0d0,SumDX(iOff1),NASHT) - Fact2(iGrid)=ddot_(NASHT,ActMO(iOff1),1,SumDX(iOff1),1) - END DO - CALL PDFTFock_Inner(FA,Fact2,dEdPiMO,MOas,mGrid) - IF(lft.and.lGGA) THEN - DO iGrid=1,mGrid - IOff1=(iGrid-1)*NASHT+1 - CALL DGEMM_('T','N',NASHT,1,NASHT,1.0d0, - & D1,NASHT,ActMO(IOff1),NASHT,0.0d0,SumDX(iOff1),NASHT) - Fact2(iGrid)=ddot_(NASHT,dEdPiAct(iOff1),1,SumDX(iOff1),1) - END DO - CALL DScal_(mGrid,2.0d0,Fact2,1) - CALL PDFTFock_Inner(FA,Fact2,MOas,MOas,mGrid) - END IF - RETURN - End Subroutine - - - Subroutine PDFTFock_Inner(Fock,Kern,MO1,MO2,mGrid) - use nq_Info -******Input - INTEGER mGrid - Real*8,DIMENSION(mGrid*nOrbt)::MO1,MO2 - Real*8,DIMENSION(mGrid)::Kern -******Output - Real*8,DIMENSION(nPot1)::Fock -******Intermediate - Real*8,DIMENSION(mGrid*nOrbt)::KernMO - INTEGER iGrid,iIrrep,iOff1,iOff2 - - CALL dcopy_(mGrid*nOrbt,MO1,1,KernMO,1) - - DO iGrid=1,mGrid - CALL DScal_(nOrbt,Kern(iGrid),KernMO(iGrid),mGrid) - END DO - - DO iIrrep=0,mIrrep-1 - IOff1=OffOrb(iIrrep)*mGrid+1 - IOff2=OffOrb2(iIrrep)+1 - CALL DGEMM_('T','N',mOrb(iIrrep),mOrb(iIrrep),mGrid,1.0d0, - & KernMO(IOff1),mGrid,MO2(IOff1),mGrid, - & 1.0d0,Fock(iOff2),mOrb(iIrrep)) - END DO - - - RETURN - End Subroutine diff -Nru openmolcas-22.02/src/nq_util/pdftfock.F90 openmolcas-22.10/src/nq_util/pdftfock.F90 --- openmolcas-22.02/src/nq_util/pdftfock.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/pdftfock.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,96 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Jie J. Bao * +!*********************************************************************** + +! **************************************************************** +! history: * +! Jie J. Bao, on Dec. 22, 2021, created this file. * +! **************************************************************** +subroutine PDFTFock(FI,FA,D1,mGrid,ActMO) + +use nq_pdft, only: dEdPiMO, GdEdPiMO, lft, lGGA, MOas +use nq_Info, only: mIrrep, NASHT, nIsh, nPot1, OffOrb +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Four +use Definitions, only: wp, iwp, r8 + +implicit none +real(kind=wp), intent(inout) :: FI(nPot1), FA(nPot1) +integer(kind=iwp), intent(in) :: mGrid +real(kind=wp), intent(in) :: D1(NASHT,NASHT), ActMO(NASHT,mGrid) +integer(kind=iwp) :: iGrid, iIrrep, ik, k +real(kind=wp) :: TempD1 +real(kind=wp), allocatable :: dEdPiAct(:,:), Fact2(:), SumDX(:,:) +real(kind=r8), external :: DDot_ + +! calculate FI. FI=2*dEdPi*pq*sum_k{kk*Fact1} +! TempD1: sum_k{kk} +! Fact2 : 2sum_k{kk} +call mma_allocate(Fact2,mGrid,label='Fact2') +do iGrid=1,mGrid + TempD1 = Zero + do iIrrep=0,mIrrep-1 + do ik=1,nIsh(iIrrep) + k = ik+OffOrb(iIrrep) + TempD1 = TempD1+MOas(iGrid,k)**2 + end do + end do + Fact2(iGrid) = Two*TempD1 +end do + +if (lft .and. lGGA) then + ! In the end (drvnq_inner) there will be a process + ! in which FI_pq=0.5(FI_pq+FI_qp) + ! However, we do not want the factor of 0.5 for p'qrs part + ! So we add another copy of GdEdPiMO to pick up the factor of 0.5 + dEdPiMO(:,:) = dEdPiMO+GdEdPiMO + ! Also the pqr's part is needed with the help of the following! array + call mma_allocate(dEdPiAct,NASHT,mGrid,label='dEdPiAct') + call TransActMO2(dEdPiAct,GdEdPiMO,mGrid) +end if +call PDFTFock_Inner(FI,Fact2,dEdPiMO,MOas,mGrid) + +if (lft .and. lGGA) then + do iGrid=1,mGrid + TempD1 = Zero + do iIrrep=0,mIrrep-1 + do ik=1,nIsh(iIrrep) + k = ik+OffOrb(iIrrep) + TempD1 = TempD1+MOas(iGrid,k)*GdEdPiMO(iGrid,k) + end do + end do + Fact2(iGrid) = Four*TempD1 + end do + call PDFTFock_Inner(FI,Fact2,MOas,MOas,mGrid) +end if +! calculate FA. FA=pq*sum_vx{vx*Dvx*Fact1} +! First calculate sum_x{Dvx*x} +call mma_allocate(SumDX,NASHT,mGrid,label='SumDX') +do iGrid=1,mGrid + call DGEMM_('T','N',NASHT,1,NASHT,One,D1,NASHT,ActMO(:,iGrid),NASHT,Zero,SumDX(:,iGrid),NASHT) + Fact2(iGrid) = ddot_(NASHT,ActMO(:,iGrid),1,SumDX(:,iGrid),1) +end do +call PDFTFock_Inner(FA,Fact2,dEdPiMO,MOas,mGrid) +if (lft .and. lGGA) then + do iGrid=1,mGrid + call DGEMM_('T','N',NASHT,1,NASHT,One,D1,NASHT,ActMO(:,iGrid),NASHT,Zero,SumDX(:,iGrid),NASHT) + Fact2(iGrid) = Two*ddot_(NASHT,dEdPiAct(:,iGrid),1,SumDX(:,iGrid),1) + end do + call mma_deallocate(dEdPiAct) + call PDFTFock_Inner(FA,Fact2,MOas,MOas,mGrid) +end if +call mma_deallocate(Fact2) +call mma_deallocate(SumDX) + +return + +end subroutine PDFTFock diff -Nru openmolcas-22.02/src/nq_util/pdftfock_inner.F90 openmolcas-22.10/src/nq_util/pdftfock_inner.F90 --- openmolcas-22.02/src/nq_util/pdftfock_inner.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/pdftfock_inner.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,48 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Jie J. Bao * +!*********************************************************************** + +! **************************************************************** +! history: * +! Jie J. Bao, on Dec. 22, 2021, created this file. * +! **************************************************************** +subroutine PDFTFock_Inner(Fock,Kern,MO1,MO2,mGrid) + +use nq_Info, only: mIrrep, mOrb, nOrbt, nPot1, OffOrb, OffOrb2 +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(inout) :: Fock(nPot1) +integer(kind=iwp), intent(in) :: mGrid +real(kind=wp), intent(in) :: Kern(mGrid), MO1(mGrid,nOrbt), MO2(mGrid,nOrbt) +integer(kind=iwp) :: iGrid, iIrrep, iOff1, iOff2 +real(kind=wp), allocatable :: KernMO(:,:) + +call mma_allocate(KernMO,mGrid,nOrbt,label='KernMO') + +do iGrid=1,mGrid + KernMO(iGrid,:) = MO1(iGrid,:)*Kern(iGrid) +end do + +do iIrrep=0,mIrrep-1 + IOff1 = OffOrb(iIrrep)+1 + IOff2 = OffOrb2(iIrrep)+1 + call DGEMM_('T','N',mOrb(iIrrep),mOrb(iIrrep),mGrid,One,KernMO(:,IOff1:),mGrid,MO2(:,IOff1:),mGrid,One,Fock(iOff2),mOrb(iIrrep)) +end do + +call mma_deallocate(KernMO) + +return + +end subroutine PDFTFock_Inner diff -Nru openmolcas-22.02/src/nq_util/pdftmemalloc.f openmolcas-22.10/src/nq_util/pdftmemalloc.f --- openmolcas-22.02/src/nq_util/pdftmemalloc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/pdftmemalloc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,76 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2021, Jie J. Bao * -************************************************************************ -* **************************************************************** -* history: * -* Jie J. Bao, on Dec. 22, 2021, created this file. * -* **************************************************************** - Subroutine PDFTMemAlloc(mGrid,nOrbt) - - use nq_pdft -#include "stdalloc.fh" -#include "ksdft.fh" - - INTEGER mGrid,nOrbt - - - CALL mma_allocate(RatioA ,mGrid) - CALL mma_allocate(OnePz ,mGrid) - CALL mma_allocate(OneMz ,mGrid) - CALL mma_allocate(RhoAB ,mGrid) - CALL mma_allocate(ZetaA ,mGrid) - CALL mma_allocate(dZdR ,mGrid) - CALL mma_allocate(Pass1 ,mGrid) - CALL mma_allocate(Pass2 ,mGrid) - -* for ft-functional - CALL mma_allocate(Pass3 ,mGrid) - - IF(do_pdftPot) THEN - CALL mma_allocate(dRdRho ,mGrid) - CALL mma_allocate(dRhodX ,mGrid) - CALL mma_allocate(dRhodY ,mGrid) - CALL mma_allocate(dRhodZ ,mGrid) - CALL mma_allocate(dF_dRhoapb ,mGrid) - CALL mma_allocate(dF_dRhoamb ,mGrid) - CALL mma_allocate(dF_dRhoxapb ,mGrid) - CALL mma_allocate(dF_dRhoyapb ,mGrid) - CALL mma_allocate(dF_dRhozapb ,mGrid) - CALL mma_allocate(dF_dRhoxamb ,mGrid) - CALL mma_allocate(dF_dRhoyamb ,mGrid) - CALL mma_allocate(dF_dRhozamb ,mGrid) - CALL mma_allocate(dEdRho ,mGrid) - CALL mma_allocate(dZdRho ,mGrid) - CALL mma_allocate(dEdRhox ,mGrid) - CALL mma_allocate(dEdRhoy ,mGrid) - CALL mma_allocate(dEdRhoz ,mGrid) - CALL mma_allocate(dEdPi ,mGrid) - CALL mma_allocate(GradRhodFdRho,mGrid) - CALL mma_allocate(d2ZdR2 ,mGrid) - CALL mma_allocate(d2RdRho2 ,mGrid) - CALL mma_allocate(d2RdRhodPi ,mGrid) - CALL mma_allocate(MOas ,mGrid*nOrbt) - -* for ft-functional - CALL mma_allocate(dRdPi ,mGrid) - CALL mma_allocate(GradRdFdRho ,mGrid) - CALL mma_allocate(GradPidFdRho ,mGrid) - CALL mma_allocate(dEdPix ,mGrid) - CALL mma_allocate(dEdPiy ,mGrid) - CALL mma_allocate(dEdPiz ,mGrid) - CALL mma_allocate(dEdPiMO ,mGrid*nOrbt) - CALL mma_allocate(GdEdPiMO ,mGrid*nOrbt) - CALL mma_allocate(MOax ,mGrid*nOrbt) - CALL mma_allocate(MOay ,mGrid*nOrbt) - CALL mma_allocate(MOaz ,mGrid*nOrbt) - END IF - End Subroutine diff -Nru openmolcas-22.02/src/nq_util/pdftmemalloc.F90 openmolcas-22.10/src/nq_util/pdftmemalloc.F90 --- openmolcas-22.02/src/nq_util/pdftmemalloc.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/pdftmemalloc.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,82 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Jie J. Bao * +!*********************************************************************** + +! **************************************************************** +! history: * +! Jie J. Bao, on Dec. 22, 2021, created this file. * +! **************************************************************** +subroutine PDFTMemAlloc(mGrid,nOrbt) + +use nq_pdft, only: d2RdRho2, d2RdRhodPi, d2ZdR2, dEdPi, dEdPiMO, dEdPix, dEdPiy, dEdPiz, dEdRho, dEdRhox, dEdRhoy, dEdRhoz, & + dF_dRhoamb, dF_dRhoapb, dF_dRhoxamb, dF_dRhoxapb, dF_dRhoyamb, dF_dRhoyapb, dF_dRhozamb, dF_dRhozapb, dRdPi, & + dRdRho, dRhodX, dRhodY, dRhodZ, dZdR, dZdRho, GdEdPiMO, GradPidFdRho, GradRdFdRho, GradRhodFdRho, MOas, MOax, & + MOay, MOaz, OneMz, OnePz, Pass1, Pass2, Pass3, RatioA, RhoAB, ZetaA +use KSDFT_Info, only: do_pdftpot +use stdalloc, only: mma_allocate +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: mGrid, nOrbt + +call mma_allocate(RatioA,mGrid) +call mma_allocate(OnePz,mGrid) +call mma_allocate(OneMz,mGrid) +call mma_allocate(RhoAB,mGrid) +call mma_allocate(ZetaA,mGrid) +call mma_allocate(dZdR,mGrid) +call mma_allocate(Pass1,mGrid) +call mma_allocate(Pass2,mGrid) + +! for ft-functional +call mma_allocate(Pass3,mGrid) + +if (do_pdftPot) then + call mma_allocate(dRdRho,mGrid) + call mma_allocate(dRhodX,mGrid) + call mma_allocate(dRhodY,mGrid) + call mma_allocate(dRhodZ,mGrid) + call mma_allocate(dF_dRhoapb,mGrid) + call mma_allocate(dF_dRhoamb,mGrid) + call mma_allocate(dF_dRhoxapb,mGrid) + call mma_allocate(dF_dRhoyapb,mGrid) + call mma_allocate(dF_dRhozapb,mGrid) + call mma_allocate(dF_dRhoxamb,mGrid) + call mma_allocate(dF_dRhoyamb,mGrid) + call mma_allocate(dF_dRhozamb,mGrid) + call mma_allocate(dEdRho,mGrid) + call mma_allocate(dZdRho,mGrid) + call mma_allocate(dEdRhox,mGrid) + call mma_allocate(dEdRhoy,mGrid) + call mma_allocate(dEdRhoz,mGrid) + call mma_allocate(dEdPi,mGrid) + call mma_allocate(GradRhodFdRho,mGrid) + call mma_allocate(d2ZdR2,mGrid) + call mma_allocate(d2RdRho2,mGrid) + call mma_allocate(d2RdRhodPi,mGrid) + call mma_allocate(MOas,mGrid,nOrbt) + + ! for ft-functional + call mma_allocate(dRdPi,mGrid) + call mma_allocate(GradRdFdRho,mGrid) + call mma_allocate(GradPidFdRho,mGrid) + call mma_allocate(dEdPix,mGrid) + call mma_allocate(dEdPiy,mGrid) + call mma_allocate(dEdPiz,mGrid) + call mma_allocate(dEdPiMO,mGrid,nOrbt) + call mma_allocate(GdEdPiMO,mGrid,nOrbt) + call mma_allocate(MOax,mGrid,nOrbt) + call mma_allocate(MOay,mGrid,nOrbt) + call mma_allocate(MOaz,mGrid,nOrbt) +end if + +end subroutine PDFTMemAlloc diff -Nru openmolcas-22.02/src/nq_util/pdftmemdealloc.f openmolcas-22.10/src/nq_util/pdftmemdealloc.f --- openmolcas-22.02/src/nq_util/pdftmemdealloc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/pdftmemdealloc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,75 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2021, Jie J. Bao * -************************************************************************ -* **************************************************************** -* history: * -* Jie J. Bao, on Dec. 22, 2021, created this file. * -* **************************************************************** - Subroutine PDFTMemDeAlloc() - - use nq_pdft -#include "stdalloc.fh" -#include "ksdft.fh" - - - - - CALL mma_deallocate(RatioA ) - CALL mma_deallocate(OnePz ) - CALL mma_deallocate(OneMz ) - CALL mma_deallocate(RhoAB ) - CALL mma_deallocate(ZetaA ) - CALL mma_deallocate(dZdR ) - CALL mma_deallocate(Pass1 ) - CALL mma_deallocate(Pass2 ) - -* for ft-functional - CALL mma_deallocate(Pass3 ) - - IF(do_pdftPot) THEN - CALL mma_deallocate(dRdRho ) - CALL mma_deallocate(dRhodX ) - CALL mma_deallocate(dRhodY ) - CALL mma_deallocate(dRhodZ ) - CALL mma_deallocate(dF_dRhoapb ) - CALL mma_deallocate(dF_dRhoamb ) - CALL mma_deallocate(dF_dRhoxapb ) - CALL mma_deallocate(dF_dRhoyapb ) - CALL mma_deallocate(dF_dRhozapb ) - CALL mma_deallocate(dF_dRhoxamb ) - CALL mma_deallocate(dF_dRhoyamb ) - CALL mma_deallocate(dF_dRhozamb ) - CALL mma_deallocate(dEdRho ) - CALL mma_deallocate(dZdRho ) - CALL mma_deallocate(dEdRhox ) - CALL mma_deallocate(dEdRhoy ) - CALL mma_deallocate(dEdRhoz ) - CALL mma_deallocate(dEdPi ) - CALL mma_deallocate(GradRhodFdRho) - CALL mma_deallocate(d2ZdR2 ) - CALL mma_deallocate(d2RdRho2 ) - CALL mma_deallocate(d2RdRhodPi ) - CALL mma_deallocate(MOas ) -* for ft-functional - CALL mma_deallocate(dRdPi ) - CALL mma_deallocate(GradRdFdRho ) - CALL mma_deallocate(GradPidFdRho ) - CALL mma_deallocate(dEdPix ) - CALL mma_deallocate(dEdPiy ) - CALL mma_deallocate(dEdPiz ) - CALL mma_deallocate(dEdPiMO ) - CALL mma_deallocate(GdEdPiMO ) - CALL mma_deallocate(MOax ) - CALL mma_deallocate(MOay ) - CALL mma_deallocate(MOaz ) - END IF - End Subroutine diff -Nru openmolcas-22.02/src/nq_util/pdftmemdealloc.F90 openmolcas-22.10/src/nq_util/pdftmemdealloc.F90 --- openmolcas-22.02/src/nq_util/pdftmemdealloc.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/pdftmemdealloc.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,79 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Jie J. Bao * +!*********************************************************************** + +! **************************************************************** +! history: * +! Jie J. Bao, on Dec. 22, 2021, created this file. * +! **************************************************************** +subroutine PDFTMemDeAlloc() + +use nq_pdft, only: d2RdRho2, d2RdRhodPi, d2ZdR2, dEdPi, dEdPiMO, dEdPix, dEdPiy, dEdPiz, dEdRho, dEdRhox, dEdRhoy, dEdRhoz, & + dF_dRhoamb, dF_dRhoapb, dF_dRhoxamb, dF_dRhoxapb, dF_dRhoyamb, dF_dRhoyapb, dF_dRhozamb, dF_dRhozapb, dRdPi, & + dRdRho, dRhodX, dRhodY, dRhodZ, dZdR, dZdRho, GdEdPiMO, GradPidFdRho, GradRdFdRho, GradRhodFdRho, MOas, MOax, & + MOay, MOaz, OneMz, OnePz, Pass1, Pass2, Pass3, RatioA, RhoAB, ZetaA +use KSDFT_Info, only: do_pdftpot +use stdalloc, only: mma_deallocate + +implicit none + +call mma_deallocate(RatioA) +call mma_deallocate(OnePz) +call mma_deallocate(OneMz) +call mma_deallocate(RhoAB) +call mma_deallocate(ZetaA) +call mma_deallocate(dZdR) +call mma_deallocate(Pass1) +call mma_deallocate(Pass2) + +! for ft-functional +call mma_deallocate(Pass3) + +if (do_pdftPot) then + call mma_deallocate(dRdRho) + call mma_deallocate(dRhodX) + call mma_deallocate(dRhodY) + call mma_deallocate(dRhodZ) + call mma_deallocate(dF_dRhoapb) + call mma_deallocate(dF_dRhoamb) + call mma_deallocate(dF_dRhoxapb) + call mma_deallocate(dF_dRhoyapb) + call mma_deallocate(dF_dRhozapb) + call mma_deallocate(dF_dRhoxamb) + call mma_deallocate(dF_dRhoyamb) + call mma_deallocate(dF_dRhozamb) + call mma_deallocate(dEdRho) + call mma_deallocate(dZdRho) + call mma_deallocate(dEdRhox) + call mma_deallocate(dEdRhoy) + call mma_deallocate(dEdRhoz) + call mma_deallocate(dEdPi) + call mma_deallocate(GradRhodFdRho) + call mma_deallocate(d2ZdR2) + call mma_deallocate(d2RdRho2) + call mma_deallocate(d2RdRhodPi) + call mma_deallocate(MOas) + ! for ft-functional + call mma_deallocate(dRdPi) + call mma_deallocate(GradRdFdRho) + call mma_deallocate(GradPidFdRho) + call mma_deallocate(dEdPix) + call mma_deallocate(dEdPiy) + call mma_deallocate(dEdPiz) + call mma_deallocate(dEdPiMO) + call mma_deallocate(GdEdPiMO) + call mma_deallocate(MOax) + call mma_deallocate(MOay) + call mma_deallocate(MOaz) +end if + +end subroutine PDFTMemDeAlloc diff -Nru openmolcas-22.02/src/nq_util/phi_point.f openmolcas-22.10/src/nq_util/phi_point.f --- openmolcas-22.02/src/nq_util/phi_point.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/phi_point.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Phi_point(iPhi,nPhi,Cos_Phi,Sin_Phi,w_Phi) - Implicit Real*8 (a-h,o-z) -#include "real.fh" -* - q = Pi*(Two*DBLE(iPhi)-1.0d0)/DBLE(nPhi) - If (Abs(Cos(q)).gt.1.0D-14) Then - Cos_Phi=Cos(q) - Else - Cos_Phi=Zero - End If - If (Abs(Sin(q)).gt.1.0D-14) Then - Sin_Phi=Sin(q) - Else - Sin_Phi=Zero - End If - w_Phi=Two*Pi/DBLE(nPhi) -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/phi_point.F90 openmolcas-22.10/src/nq_util/phi_point.F90 --- openmolcas-22.02/src/nq_util/phi_point.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/phi_point.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,38 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Phi_point(iPhi,nPhi,Cos_Phi,Sin_Phi,w_Phi) + +use Constants, only: Zero, One, Two, Pi +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iPhi, nPhi +real(kind=wp), intent(out) :: Cos_Phi, Sin_Phi, w_Phi +real(kind=wp) :: q +real(kind=wp), parameter :: Thrs = 1.0e-14_wp + +q = Pi*(Two*real(iPhi,kind=wp)-One)/real(nPhi,kind=wp) +if (abs(cos(q)) > Thrs) then + Cos_Phi = cos(q) +else + Cos_Phi = Zero +end if +if (abs(sin(q)) > Thrs) then + Sin_Phi = sin(q) +else + Sin_Phi = Zero +end if +w_Phi = Two*Pi/real(nPhi,kind=wp) + +return + +end subroutine Phi_point diff -Nru openmolcas-22.02/src/nq_util/print_nq_info.f openmolcas-22.10/src/nq_util/print_nq_info.f --- openmolcas-22.02/src/nq_util/print_nq_info.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/print_nq_info.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,53 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Print_NQ_Info(iSpin) - use nq_Info - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Logical Reduce_Prt - External Reduce_Prt -* * -************************************************************************ -* * - iPL=iPrintLevel(-1) - If (Reduce_Prt().and.iPL.lt.3) iPL=0 -* * -************************************************************************ -* * - If (iPL.ge.3) Then - Call GAIGOP_SCAL(nTotGP,'+') - Write (6,*) - Write (6,'(6X,A,T52,F17.10)') - & 'Integrated DFT Energy ',Energy_integrated - Write (6,'(6X,A,T56,G17.10)') - & 'Integrated number of electrons',Dens_I - If (Grad_I.ne.Zero) - & Write (6,'(6X,A,T56,G17.10)') - & 'Integrated |grad| ',Grad_I - If (Tau_I .ne.Zero) - & Write (6,'(6X,A,T56,G17.10)') - & 'Integrated tau ',Tau_I - Write (6,'(6X,A,T54,I13)') - & 'Total number of prunned grid points ',nTotGP - Write (6,*) - End If -* * -************************************************************************ -* * - Call Add_Info('DFT_Energy',[Energy_integrated],1,6) - Call Add_Info('NQ_Density',[Dens_I],1,8) -* * -************************************************************************ -* * - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(iSpin) - End diff -Nru openmolcas-22.02/src/nq_util/print_nq_info.F90 openmolcas-22.10/src/nq_util/print_nq_info.F90 --- openmolcas-22.02/src/nq_util/print_nq_info.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/print_nq_info.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,52 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Print_NQ_Info() + +use nq_Info, only: Dens_I, Energy_integrated, Grad_I, nTotGP, Tau_I +use Constants, only: Zero +use Definitions, only: iwp, u6 + +implicit none +integer(kind=iwp) :: iPL +integer(kind=iwp), external :: iPrintLevel +logical(kind=iwp), external :: Reduce_Prt + +! * +!*********************************************************************** +! * +iPL = iPrintLevel(-1) +if (Reduce_Prt() .and. (iPL < 3)) iPL = 0 +! * +!*********************************************************************** +! * +if (iPL >= 3) then + call GAIGOP_SCAL(nTotGP,'+') + write(u6,*) + write(u6,'(6X,A,T52,F17.10)') 'Integrated DFT Energy ',Energy_integrated + write(u6,'(6X,A,T56,G17.10)') 'Integrated number of electrons',Dens_I + if (Grad_I /= Zero) write(u6,'(6X,A,T56,G17.10)') 'Integrated |grad| ',Grad_I + if (Tau_I /= Zero) write(u6,'(6X,A,T56,G17.10)') 'Integrated tau ',Tau_I + write(u6,'(6X,A,T54,I13)') 'Total number of prunned grid points ',nTotGP + write(u6,*) +end if +! * +!*********************************************************************** +! * +call Add_Info('DFT_Energy',[Energy_integrated],1,6) +call Add_Info('NQ_Density',[Dens_I],1,8) +! * +!*********************************************************************** +! * + +return + +end subroutine Print_NQ_Info diff -Nru openmolcas-22.02/src/nq_util/process_coor.f openmolcas-22.10/src/nq_util/process_coor.f --- openmolcas-22.02/src/nq_util/process_coor.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/process_coor.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,70 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Process_Coor(R,Coor,nAtoms,nSym,iOper) - Implicit Real*8 (a-h,o-z) - Real*8 R(3), Coor(3,*) - Integer iOper(0:nSym-1) -* -* Local array -* - Real*8 Q(3) -* * -************************************************************************ -* * -C Call RecPrt('Coor(Enter)',' ',Coor,3,nAtoms) -C Call RecPrt('R',' ',R,3,1) -* * -************************************************************************ -* * -* Identify if this is a new center. -* - Do iAtom = 1, nAtoms - If (R(1).eq.Coor(1,iAtom) .and. - & R(2).eq.Coor(2,iAtom) .and. - & R(3).eq.Coor(3,iAtom) ) Return - End Do -* * -************************************************************************ -* * -* Add this atom to the list -* - nAtoms=nAtoms+1 - call dcopy_(3,R,1,Coor(1,nAtoms),1) - iRef = nAtoms -C Call RecPrt('Coor(updated)',' ',Coor,3,nAtoms) -C Write (*,*) 'nSym=',nSym -C Write (*,*) 'iOper=',iOper -* * -************************************************************************ -* * -* Add symmetry degenerate atoms to the list -* - Do iSym = 1, nSym-1 -C Write (6,*) 'iOper(iSym)=',iOper(iSym) - call dcopy_(3,R,1,Q,1) - If (iAnd(iOper(iSym),1).ne.0) Q(1)=-Q(1) - If (iAnd(iOper(iSym),2).ne.0) Q(2)=-Q(2) - If (iAnd(iOper(iSym),4).ne.0) Q(3)=-Q(3) -C Call RecPrt('Q',' ',Q,3,1) - Do iAtom = iRef, nAtoms - If (Q(1).eq.Coor(1,iAtom) .and. - & Q(2).eq.Coor(2,iAtom) .and. - & Q(3).eq.Coor(3,iAtom) ) Go To 100 - End Do - nAtoms = nAtoms + 1 - call dcopy_(3,Q,1,Coor(1,nAtoms),1) - 100 Continue - End Do -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/process_coor.F90 openmolcas-22.10/src/nq_util/process_coor.F90 --- openmolcas-22.02/src/nq_util/process_coor.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/process_coor.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,72 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Process_Coor(R,Coor,nAtoms,nSym,iOper) + +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(in) :: R(3) +real(kind=wp), intent(inout) :: Coor(3,*) +integer(kind=iwp), intent(inout) :: nAtoms +integer(kind=iwp), intent(in) :: nSym, iOper(0:nSym-1) +integer(kind=iwp) :: iAtom, iRef, iSym +real(kind=wp) :: Q(3) + +! * +!*********************************************************************** +! * +!call RecPrt('Coor(Enter)',' ',Coor,3,nAtoms) +!call RecPrt('R',' ',R,3,1) +! * +!*********************************************************************** +! * +! Identify if this is a new center. + +do iAtom=1,nAtoms + if ((R(1) == Coor(1,iAtom)) .and. (R(2) == Coor(2,iAtom)) .and. (R(3) == Coor(3,iAtom))) return +end do +! * +!*********************************************************************** +! * +! Add this atom to the list + +nAtoms = nAtoms+1 +Coor(:,nAtoms) = R +iRef = nAtoms +!call RecPrt('Coor(updated)',' ',Coor,3,nAtoms) +!write(u6,*) 'nSym=',nSym +!write(u6,*) 'iOper=',iOper +! * +!*********************************************************************** +! * +! Add symmetry degenerate atoms to the list + +outer: do iSym=1,nSym-1 + !write(u6,*) 'iOper(iSym)=',iOper(iSym) + Q(:) = R + if (btest(iOper(iSym),0)) Q(1) = -Q(1) + if (btest(iOper(iSym),1)) Q(2) = -Q(2) + if (btest(iOper(iSym),2)) Q(3) = -Q(3) + !call RecPrt('Q',' ',Q,3,1) + do iAtom=iRef,nAtoms + if ((Q(1) == Coor(1,iAtom)) .and. (Q(2) == Coor(2,iAtom)) .and. (Q(3) == Coor(3,iAtom))) cycle outer + end do + nAtoms = nAtoms+1 + Coor(:,nAtoms) = Q +end do outer +! * +!*********************************************************************** +! * + +return + +end subroutine Process_Coor diff -Nru openmolcas-22.02/src/nq_util/reset_nq_grid.f openmolcas-22.10/src/nq_util/reset_nq_grid.f --- openmolcas-22.02/src/nq_util/reset_nq_grid.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/reset_nq_grid.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,50 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Reset_NQ_Grid - use Grid_On_Disk - use nq_Info - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "itmax.fh" -* * -************************************************************************ -* * -* * -************************************************************************ -* * -* Reset the size and the accuracy of the grid to the requested -* values. -* - L_Quad=L_Quad_Save - If (Quadrature(1:3).eq.'LMG') Then - Threshold=Threshold_Save - Else - nR=nR_save - End If -* - Crowding =ThrC -* - Write (6,*) - Write (6,'(6X,A)') 'Reset the NQ grid!' - Write (6,*) - Call Funi_Print() - Write (6,*) -* * -************************************************************************ -* * -* Change the Grid set index -* - iGrid_Set=Final -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/reset_nq_grid.F90 openmolcas-22.10/src/nq_util/reset_nq_grid.F90 --- openmolcas-22.02/src/nq_util/reset_nq_grid.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/reset_nq_grid.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,51 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Reset_NQ_Grid() + +use Grid_On_Disk, only: Final_Grid, iGrid_Set +use nq_Info, only: Crowding, L_Quad, L_Quad_Save, nR, nR_Save, Quadrature, ThrC, Threshold, Threshold_Save +use Definitions, only: u6 + +implicit none + +! * +!*********************************************************************** +! * +! Reset the size and the accuracy of the grid to the requested values. + +L_Quad = L_Quad_Save +if (Quadrature(1:3) == 'LMG') then + Threshold = Threshold_Save +else + nR = nR_save +end if + +Crowding = ThrC + +write(u6,*) +write(u6,'(6X,A)') 'Reset the NQ grid!' +write(u6,*) +call Funi_Print() +write(u6,*) +! * +!*********************************************************************** +! * +! Change the Grid set index + +iGrid_Set = Final_Grid +! * +!*********************************************************************** +! * + +return + +end subroutine Reset_NQ_Grid diff -Nru openmolcas-22.02/src/nq_util/resortd.f openmolcas-22.10/src/nq_util/resortd.f --- openmolcas-22.02/src/nq_util/resortd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/resortd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,27 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine ResortD(D_Old,D_New,iBas,iCmp,jBas,jCmp) - Implicit Real*8 (a-h,o-z) -* - Real*8 D_Old(iBas,jBas,iCmp,jCmp), D_New(iBas,iCmp,jBas,jCmp) -* - Do jC = 1, jCmp - Do jB = 1, jBas - Do iC = 1, iCmp - Do iB = 1, iBas - D_New(iB,iC,jB,jC)=D_Old(iB,jB,iC,jC) - End Do - End Do - End Do - End Do -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/resortd.F90 openmolcas-22.10/src/nq_util/resortd.F90 --- openmolcas-22.02/src/nq_util/resortd.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/resortd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,32 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ResortD(D_Old,D_New,iBas,iCmp,jBas,jCmp) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iBas, iCmp, jBas, jCmp +real(kind=wp), intent(in) :: D_Old(iBas,jBas,iCmp,jCmp) +real(kind=wp), intent(out) :: D_New(iBas,iCmp,jBas,jCmp) +integer(kind=iwp) :: iC, jB, jC + +do jC=1,jCmp + do jB=1,jBas + do iC=1,iCmp + D_New(:,iC,jB,jC) = D_Old(:,jB,iC,jC) + end do + end do +end do + +return + +end subroutine ResortD diff -Nru openmolcas-22.02/src/nq_util/rotgrd.f openmolcas-22.10/src/nq_util/rotgrd.f --- openmolcas-22.02/src/nq_util/rotgrd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/rotgrd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,148 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2003, Roland Lindh * -************************************************************************ - Subroutine RotGrd(RA,ZA,O,dOdx,d2Odx2,nAtoms,Do_Grad,Do_Hess) -************************************************************************ -* * -* Object: Compute the principle axis system and to optionally * -* evaluate the gradient of the principle axis system. * -* * -* See: B. G. Johnson et al., CPL, 220, 377 (1994). * -* * -* Author: R. Lindh, Dept. of Chem. Phys., Univ. of Lund, Sweden. * -* * -* Created on board M/S Polarlys on voyage from Tromso to * -* Trondheim, Sept. 2003. * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 RA(3,nAtoms), ZA(nAtoms), - & O(3,3), dOdx(3,3,nAtoms,3), d2Odx2(3,3,nAtoms,3,nAtoms,3), - & dMdx(3,3), dMdy(3,3), - & EVal(3), T(3), - & Px(3,3), Py(3,3) - Logical Do_Grad, Rot_Corr, Do_Hess -* * -************************************************************************ -* * -*define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Call RecPrt('RotGrd: RA',' ',RA,3,nAtoms) - Call RecPrt('RotGrd: ZA',' ',ZA,1,nAtoms) -#endif -* * -************************************************************************ -* * -*---- Compute the total charge -* - Z_Tot=DDot_(nAtoms,[One],0,ZA,1) -* -*---- Form the center of nuclear charge -* - Call Compute_T(Z_Tot,T,ZA,RA,nAtoms) -* -*---- Form O -* - Call Compute_O(ZA,RA,nAtoms,Z_Tot,T,O,EVal) -* * -************************************************************************ -* * - If (.Not.Do_Grad) Return -* * -************************************************************************ -* * -* Turn off rotational correction to the gradient if the eigen -* vectors are close to degeneracy! -* - Rot_Corr=.True. - If (Abs(Eval(1)-Eval(2))/(EVal(1)+EVal(2)).lt.0.001D0) Then - Write (6,*) 'Rotational correction to the DFT gradient is ' - & //'turned off due to close-to-degeneracy problems!' - Rot_Corr=.False. - End If - If (Abs(Eval(1)-Eval(3))/(EVal(1)+EVal(3)).lt.0.001D0) Then - Write (6,*) 'Rotational correction to the DFT gradient is ' - & //'turned off due to close-to-degeneracy problems!' - Rot_Corr=.False. - End If - If (Abs(Eval(2)-Eval(3))/(EVal(2)+EVal(3)).lt.0.001D0) Then - Write (6,*) 'Rotational correction to the DFT gradient is ' - & //'turned off due to close-to-degeneracy problems!' - Rot_Corr=.False. - End If -* * -************************************************************************ -* * -*---- Compute the gradient -* - Do iAtom = 1, nAtoms - dTdRAi=ZA(iAtom)/Z_Tot - Do iCar = 1, 3 -* -*---------- Form dO/dx -* - Call Compute_dOdx(ZA,RA,nAtoms,T,O,EVal,Rot_Corr, - & iAtom,iCar,dTdRAi,dMdx, - & dOdx(1,1,iAtom,iCar),Px) -* - End Do - End Do -* * -************************************************************************ -* * - If (.Not.Do_Hess) Return -* * -************************************************************************ -* * -* Compute the Hessian -* - Do iAtom = 1, nAtoms - dTdRAi=ZA(iAtom)/Z_Tot - Do iCar = 1, 3 - Call Compute_dOdx(ZA,RA,nAtoms,T,O,EVal,Rot_Corr, - & iAtom,iCar,dTdRAi,dMdx, - & dOdx(1,1,iAtom,iCar),Px) -* - Do jAtom = 1, iAtom - dTdRAj=ZA(jAtom)/Z_Tot - jCar_Max = 3 - If (iAtom.eq.jAtom) jCar_Max = iCar - Do jCar = 1, jCar_Max - Call Compute_dOdx(ZA,RA,nAtoms,T,O,EVal,Rot_Corr, - & jAtom,jCar,dTdRAj,dMdy, - & dOdx(1,1,jAtom,jCar),Py) -* -*---------------- Form d2O/dx2 -* - Call Compute_d2Odx2(ZA,RA,nAtoms,T,O,EVal,Rot_Corr, - & iAtom,iCar,dTdRAi,dMdx, - & dOdx(1,1,iAtom,iCar),Px, - & jAtom,jCar,dTdRAj,dMdy, - & dOdx(1,1,jAtom,jCar),Py, - & d2Odx2(1,1,iAtom,iCar,jAtom,jCar)) -* - If (iAtom.ne.jAtom .or. - & (iAtom.eq.jAtom.and.iCar.ne.jCar)) Then - call dcopy_(9,d2Odx2(1,1,iAtom,iCar,jAtom,jCar),1, - & d2Odx2(1,1,jAtom,jCar,iAtom,iCar),1) - End If -* - End Do ! jCar - End Do ! iCar -* - End Do ! jAtom - End Do ! iAtom -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/rotgrd.F90 openmolcas-22.10/src/nq_util/rotgrd.F90 --- openmolcas-22.02/src/nq_util/rotgrd.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/rotgrd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,140 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2003, Roland Lindh * +!*********************************************************************** + +subroutine RotGrd(RA,ZA,O,dOdx,d2Odx2,nAtoms,Do_Grad,Do_Hess) +!*********************************************************************** +! * +! Object: Compute the principal axes system and to optionally * +! evaluate the gradient of the principal axes system. * +! * +! See: B. G. Johnson et al., CPL, 220, 377 (1994). * +! * +! Author: R. Lindh, Dept. of Chem. Phys., Univ. of Lund, Sweden. * +! * +! Created on board M/S Polarlys on voyage from Tromso to * +! Trondheim, Sept. 2003. * +!*********************************************************************** + +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nAtoms +real(kind=wp), intent(in) :: RA(3,nAtoms), ZA(nAtoms) +real(kind=wp), intent(out) :: O(3,3), dOdx(3,3,nAtoms,3) +real(kind=wp), intent(inout) :: d2Odx2(3,3,nAtoms,3,nAtoms,3) +logical(kind=iwp), intent(in) :: Do_Grad, Do_Hess +integer(kind=iwp) :: iAtom, iCar, jAtom, jCar, jCar_Max +real(kind=wp) :: dMdx(3,3), dMdy(3,3), dTdRAi, dTdRAj, EVal(3), Px(3,3), Py(3,3), T(3), Z_Tot +logical(kind=iwp) :: Rot_Corr +real(kind=wp), parameter :: Thrs = 1.0e-3_wp + +! * +!*********************************************************************** +! * +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +call RecPrt('RotGrd: RA',' ',RA,3,nAtoms) +call RecPrt('RotGrd: ZA',' ',ZA,1,nAtoms) +#endif +! * +!*********************************************************************** +! * +! Compute the total charge + +Z_Tot = sum(ZA) + +! Form the center of nuclear charge + +call Compute_T(Z_Tot,T,ZA,RA,nAtoms) + +! Form O + +call Compute_O(ZA,RA,nAtoms,T,O,EVal) +! * +!*********************************************************************** +! * +if (.not. Do_Grad) return +! * +!*********************************************************************** +! * +! Turn off rotational correction to the gradient if the eigenvectors +! are close to degeneracy! + +Rot_Corr = .true. +if (abs(Eval(1)-Eval(2))/(EVal(1)+EVal(2)) < Thrs) then + write(u6,*) 'Rotational correction to the DFT gradient is turned off due to close-to-degeneracy problems!' + Rot_Corr = .false. +end if +if (abs(Eval(1)-Eval(3))/(EVal(1)+EVal(3)) < Thrs) then + write(u6,*) 'Rotational correction to the DFT gradient is turned off due to close-to-degeneracy problems!' + Rot_Corr = .false. +end if +if (abs(Eval(2)-Eval(3))/(EVal(2)+EVal(3)) < Thrs) then + write(u6,*) 'Rotational correction to the DFT gradient is turned off due to close-to-degeneracy problems!' + Rot_Corr = .false. +end if +! * +!*********************************************************************** +! * +! Compute the gradient + +do iAtom=1,nAtoms + dTdRAi = ZA(iAtom)/Z_Tot + do iCar=1,3 + + ! Form dO/dx + + call Compute_dOdx(ZA,RA,nAtoms,T,O,EVal,Rot_Corr,iAtom,iCar,dTdRAi,dMdx,dOdx(:,:,iAtom,iCar),Px) + + end do +end do +! * +!*********************************************************************** +! * +if (.not. Do_Hess) return +! * +!*********************************************************************** +! * +! Compute the Hessian + +do iAtom=1,nAtoms + dTdRAi = ZA(iAtom)/Z_Tot + do iCar=1,3 + call Compute_dOdx(ZA,RA,nAtoms,T,O,EVal,Rot_Corr,iAtom,iCar,dTdRAi,dMdx,dOdx(:,:,iAtom,iCar),Px) + + do jAtom=1,iAtom + dTdRAj = ZA(jAtom)/Z_Tot + jCar_Max = 3 + if (iAtom == jAtom) jCar_Max = iCar + do jCar=1,jCar_Max + call Compute_dOdx(ZA,RA,nAtoms,T,O,EVal,Rot_Corr,jAtom,jCar,dTdRAj,dMdy,dOdx(:,:,jAtom,jCar),Py) + + ! Form d2O/dx2 + + call Compute_d2Odx2(ZA,nAtoms,O,EVal,Rot_Corr,iAtom,iCar,dTdRAi,dMdx,Px,jAtom,jCar,dMdy,Py, & + d2Odx2(:,:,iAtom,iCar,jAtom,jCar)) + + if ((iAtom /= jAtom) .or. (iCar /= jCar)) d2Odx2(:,:,jAtom,jCar,iAtom,iCar) = d2Odx2(:,:,iAtom,iCar,jAtom,jCar) + + end do ! jCar + end do ! iCar + + end do ! jAtom +end do ! iAtom +! * +!*********************************************************************** +! * + +return + +end subroutine RotGrd diff -Nru openmolcas-22.02/src/nq_util/setup_nq.f openmolcas-22.10/src/nq_util/setup_nq.f --- openmolcas-22.02/src/nq_util/setup_nq.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/setup_nq.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,676 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1999, Roland Lindh * -************************************************************************ - Subroutine Setup_NQ(Maps2p,nShell,nSym,nNQ,Do_Grad,On_Top, - & Pck_Old,PMode_old,R_Min,nR_Min) -************************************************************************ -* * -* Object: to set up information for calculation of integrals via a * -* numerical quadrature. * -* Warning: The exponents of each shell are reordered diffuse to compact* -* * -* Author: Roland Lindh, * -* Dept of Chemical Physics, * -* University of Lund, Sweden * -* August 1999 * -************************************************************************ - use Real_Spherical - use iSD_data - use Basis_Info - use Center_Info - use Symmetry_Info, only: nIrrep, iOper - use nq_Grid, only: nGridMax, Coor, Pax, Fact, nR_Eff - use nq_Grid, only: Angular, Mem - use nq_structure, only: NQ_Data - use Grid_On_Disk - use nq_Info - Implicit Real*8 (A-H,O-Z) -#include "itmax.fh" -#include "real.fh" -#include "stdalloc.fh" -#include "status.fh" -#include "nsd.fh" -#include "setup.fh" -#include "print.fh" - Real*8 XYZ(3), C(3) - Logical EQ, Do_Grad, On_Top, PMode_Old - Real*8 Alpha(2),rm(2), R_Min(0:nR_Min) - Integer Maps2p(nShell,0:nSym-1) - Integer iDCRR(0:7) - Dimension Dummy(1) - Real*8, Allocatable:: TempC(:,:), ZA(:), Crd(:,:), dOdx(:,:,:,:) -* * -************************************************************************ -* * -* Statement Functions -* - nElem(i)=(i+1)*(i+2)/2 -* * -************************************************************************ -* * - Call ICopy(nShell*nSym,[-99999999],0,Maps2p,1) -*define _DEBUGPRINT_ -* * -************************************************************************ -* * -c Write(6,*) '********** Setup_NQ ***********' - ntotgp=0 -* * -************************************************************************ -* * -*-----Check if NQ environment has been activated -* - If (NQ_Status.ne.Active.and.NQ_Status.ne.Inactive) Then - Call WarningMessage(2,'Setup_NQ: NQ_Status not initialized') - Call Quit_OnUserError() - End If - If (NQ_Status.eq.Active) Return - NQ_Status=Active -* * -************************************************************************ -* * -*---- Get the coordinates to the centers of all Voronoi polyhedra -* -* Note that this will be all centers with valence basis sets on -* them. Hence this will also include any pseudo centers! -* - Call mma_allocate(TempC,3,nShell*nSym,Label='TempC') - nAtoms = 0 - If (nShell.gt.nskal_iSD) Then - Write (6,*) 'nShell.gt.nSkal_iSD' - Write (6,*) 'nShell=',nShell - Write (6,*) 'nSkal_iSD=',nSkal_iSD - Call AbEnd() - End If - Do iShell = 1, nShell - iCnttp=iSD(13,iShell) - iCnt =iSD(14,iShell) - XYZ(1:3)=dbsc(iCnttp)%Coor(1:3,iCnt) - Call Process_Coor(XYZ,TempC,nAtoms,nSym,iOper) - End Do - Call mma_allocate(Coor,3,nAtoms,Label='Coor') - call dcopy_(3*nAtoms,TempC,1,Coor,1) - Call mma_deallocate(TempC) -* * -************************************************************************ -* * -*---- Get the symmetry unique coordinates -* - nNQ=nAtoms - Allocate(NQ_data(1:nNQ)) - Do iNQ = 1, nNQ - Call mma_allocate(NQ_data(iNQ)%Coor,3, - & Label='NQ_data(iNQ)%Coor') - call dcopy_(3,Coor(1:3,iNQ),1,NQ_data(iNQ)%Coor,1) - End Do -* * -************************************************************************ -* * -*-----Pick up the requested accuracy. -* -* Dr=-Log10(Thr) -* * -************************************************************************ -* * -*-----Loop over each unique center, and find the highest and lowest * -* Gaussians exponents associated with this center. The later * -* information will be used to design the radial grid associated * -* with this center. * -* * - iAngMax=0 - NbrMxBas=0 - Do iShell=1,nShell - iAng =iSD(1,iShell) - nCntrc=iSD(3,iShell) !Get the # of contracted functions - !for iShell - mExp =iSD(5,iShell) ! Get the number of exponents of ishell - NbrMxBas=Max(NbrMxbas,nCntrc) - iAngMax=Max(iAngMax,iAng) - End Do -* -*-----Loop over the shells -* - nMaxExp=0 - nAOMax=0 - Do iShell = 1, nShell -* -*------- Get the Atom number - iANr=dbsc(iSD(13,iShell))%AtmNr -* - iShll=iSD(0,iShell) ! Get the angular momentum of ishell - iAng=iSD(1,iShell) ! Get the angular momentum of ishell - iCmp=iSD(2,iShell) ! Get the # of angular components - nCntrc=iSD(3,iShell) !Get the # of contracted functions - !for iShell - mExp=iSD(5,iShell) ! Get the number of exponents of ishell - nMaxExp=Max(nMaxExp,mExp) - nAOMax=Max(nAOMax,iCmp*nCntrc) -* -************************************************************************ -* * -* Order the exponents diffuse to compact for the active shell * -* * -************************************************************************ - Call OrdExpD2C(mExp,Shells(iShll)%Exp,nCntrc, - & Shells(iShll)%pCff) -* -*-----Get the extreme exponents for the active shell. - A_low =Shells(iShll)%Exp(1) - A_high=Shells(iShll)%Exp(mExp) -* - iCnttp=iSD(13,iShell) - iCnt =iSD(14,iShell) - C(1:3)=dbsc(iCnttp)%Coor(1:3,iCnt) - Do iIrrep = 0, nIrrep-1 - Call OA(iOper(iIrrep),C,XYZ) - Do iNQ=1,nNQ -* - If (EQ(NQ_data(iNQ)%Coor,XYZ)) Then -* - NQ_Data(iNQ)%Atom_Nr=iANR -* -*------------- Assign the BS radius to the center - NQ_Data(iNQ)%R_RS=Bragg_Slater(iANr) -* -*------------- What is the maximum angular momentum for the active center ? - NQ_Data(iNQ)%l_Max=Max(NQ_Data(iNQ)%l_max,iAng) -* -*------------- Get the extreme exponents for the atom - NQ_Data(iNQ)%A_high=Max(NQ_Data(iNQ)%A_high,A_High) - NQ_Data(iNQ)%A_low =Min(NQ_Data(iNQ)%A_low ,A_low) -* - Maps2p(iShell,iIrrep)=iNQ - Go To 100 - End If - End Do ! iNQ - Call WarningMessage(2, - & 'Didn''t find a center associated with the shell!') - Call Abend() - 100 Continue - End Do ! iIrrep -* - End Do !iShell -* -************************************************************************ -* * -* END OF THE LOOP OVER THE SHELLS. * -* Now we have the number of unique center and their associated * -* exponents and maximum angular momentum. And for each shell the * -* exponents are ordered diffuse to compact. * -* * -************************************************************************ -* * -* Loop over all the atoms to create the radial quadrature * -* * -************************************************************************ -* -*-----Allocate memory to store the number of effective radial points for -* each center and the radius of this center. - Call mma_Allocate(nR_Eff,nNQ,Label='nR_Eff') -* - iNQ_MBC=0 - iReset=0 - Threshold_tmp=Zero - nR_tmp=0 - Do iNQ=1,nNQ -*--------Get the extreme exponents for the atom - Alpha(1)=NQ_Data(iNQ)%A_low - Alpha(2)=NQ_Data(iNQ)%A_high -* -*--------Get the coordinates of the atom - call dcopy_(3,NQ_Data(iNQ)%Coor,1,XYZ,1) -* -* For a special center we can increase the accuracy. -* - If (MBC.ne.' ') Then - Do iS = 1, nShell - iCnttp=iSD(13,iS) - iCnt =iSD(14,iS) - C(1:3)=dbsc(iCnttp)%Coor(1:3,iCnt) - If ( EQ(NQ_Data(iNQ)%Coor,C) ) Then - mdci=iSD(10,iS) - If (dc(mdci)%LblCnt.eq.MBC) Then - nR_tmp=nR - nR=INT(DBLE(nR)*2.0D0) - Threshold_tmp=Threshold - Threshold=Threshold*1.0D-6 -* - iReset=1 - iNQ_MBC=iNQ - Go To 1771 - End If - End If - End Do - End If - 1771 Continue -* -* Max angular momentum for the atom -> rm(1) -* Max Relative Error -> rm(2) - rm(1)=DBLE(NQ_Data(iNQ)%l_Max) - rm(2)=Threshold -* - Call GenVoronoi(XYZ,nR_Eff,nNQ,Alpha,rm,iNQ) -* - If (iReset.eq.1) Then - nR=nR_tmp - Threshold=Threshold_tmp - iReset=0 - End If -* - End Do ! iNQ -* * -************************************************************************ -* * -* Compute the principal axis system and optionally to -* compute derivatives of the principal axis. Needed in order to -* compute the gradient of the rotationally invariant DFT energy. -* - Call mma_allocate(Pax,3,3,Label='Pax') - Call mma_allocate(dOdx,3,3,nNQ,3,Label='dOdx') - dOdx(:,:,:,:)=Zero - Call mma_Allocate(ZA,nNQ,Label='ZA') - Call mma_Allocate(Crd,3,nNQ) -* -* Collect coordinates and charges of the nuclei -* - Do iNQ = 1, nNQ - ZA(iNQ)=DBLE(NQ_Data(iNQ)%Atom_Nr) - call dcopy_(3,NQ_data(iNQ)%Coor,1,Crd(:,iNQ),1) - End Do -* - Call RotGrd(Crd,ZA,Pax,dOdx,Dummy,nNQ,Do_Grad,.False.) -* -* Distribute derivative of the principle axis system -* - If (Do_Grad) Then - Do iNQ = 1, nNQ - Call mma_allocate(NQ_Data(iNQ)%dOdx,3,3,3,Label='dOdx') - Do iCar = 1, 3 - call dcopy_(9,dOdx(:,:,iNQ,iCar),1, - & NQ_Data(iNQ)%dOdx(:,:,iCar),1) - End Do - End Do - End If -* - Call mma_deallocate(dOdX) - Call mma_deallocate(Crd) - Call mma_deallocate(ZA) -* * -************************************************************************ -* * - If (Rotational_Invariance.eq.Off) Then - Call FZero(Pax,9) - call dcopy_(3,[One],0,Pax,4) - Do iNQ = 1, nNQ - If (.Not.Allocated(NQ_Data(iNQ)%dOdx)) - & Call mma_allocate(NQ_Data(iNQ)%dOdx,3,3,3,Label='dOdx') - NQ_Data(iNQ)%dOdx(:,:,:)=Zero - End Do - End If -* * -************************************************************************ -* * -* Generate the angular grid -* - Call Angular_grid() -* - Crowding_tmp=Zero - Do iNQ = 1, nNQ -* -* Assign the angular grid to be used with each radial grid point -* - Call mma_allocate(NQ_Data(iNQ)%Angular,nR_Eff(iNQ), - & Label='Angular') - NQ_Data(iNQ)%Angular(:)=nAngularGrids -* -* Prune the angular grid -* - If (Angular_Prunning.eq.On) Then -* -* -*---------- Find the R_min values of each angular shell -* - lAng=NQ_Data(iNQ)%l_max - Do iAng = 0, lAng - R_Min(iAng)=Zero - ValExp=-One - iSet=0 - Do iShell=1,nShell - iShll =iSD(0,iShell) - iAng_ =iSD(1,iShell) - NrExp =iSD(5,iShell) -* Write (6,*) 'iAng_,iAng=',iAng_,iAng - If (iAng_.eq.iAng.and.NrExp.ge.1) Then - Do iSym = 0, nSym-1 - iNQ_=Maps2p(iShell,iSym) -* Write (6,*) 'iNQ_,iNQ=',iNQ_,iNQ - If (iNQ_.eq.iNQ) Then - ValExp=Shells(iShll)%Exp(NrExp) - iSet=1 - End If - End Do - End If - End Do - If (ValExp.lt.Zero.and.iSet.eq.1) Then - Call WarningMessage(2,'ValExp.lt.Zero') - Call Abend() - End If - If (iSet.eq.1) Then - R_Min(iAng)=Eval_RMin(ValExp,iAng,Threshold) - If (iAng.eq.0) R_Min(iAng)=Zero - End If - End Do -* - R_BS = NQ_Data(iNQ)%R_RS -* - If (iNQ.eq.iNQ_MBC) Then - Crowding_tmp=Crowding - Crowding=One + (Crowding-One)*0.25D0 - iReset=1 - End If -* - Call Angular_Prune(NQ_Data(iNQ)%R_Quad,nR_Eff(iNQ), - & NQ_Data(iNQ)%Angular,Crowding, - & Fade,R_BS,L_Quad,R_Min,lAng, - & nAngularGrids) -* - If (iReset.eq.1) Then - Crowding=Crowding_tmp - iReset=0 - End If -* - End if -* - End Do -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - Write (6,*) - Write (6,'(A)') ' ==================================' - Write (6,'(A)') ' = Grid information =' - Write (6,'(A)') ' ==================================' - Write (6,'(A)') ' Legend ' - Write (6,'(A)') ' ----------------------------------' - Write (6,'(A)') ' ANr: element number' - Write (6,'(A)') ' nR : number of radial grid points' - Write (6,'(A)') ' iNQ: grid index' - Write (6,'(A)') ' ----------------------------------' - Write (6,*) - Write (6,'(A)') ' iNQ ANr nR' - Do iNQ=1,nNQ - iANr=NQ_Data(iNQ)%Atom_Nr - kR=nR_Eff(iNQ) - Write (6,'(3I4)') iNQ, iANr, kR - End Do - Write (6,*) -#endif -* * -************************************************************************ -* * -*-----Determine the spatial extension of the molecular system -* -! Box_Size=Four ! Angstrom - Box_Size=Two ! Angstrom -! Box_Size=1.0d0/Two ! Angstrom - Block_size=Box_Size - x_min=1.0D99 - y_min=1.0D99 - z_min=1.0D99 - x_max=-1.0D99 - y_max=-1.0D99 - z_max=-1.0D99 - Do iAt = 1, nAtoms - x_min=Min(x_min,Coor(1,iAt)) - y_min=Min(y_min,Coor(2,iAt)) - z_min=Min(z_min,Coor(3,iAt)) - x_max=Max(x_max,Coor(1,iAt)) - y_max=Max(y_max,Coor(2,iAt)) - z_max=Max(z_max,Coor(3,iAt)) - End Do -* -*---- Add half an box size around the whole molecule -* - x_min=x_min-Box_Size/Two - y_min=y_min-Box_Size/Two - z_min=z_min-Box_Size/Two - x_max=x_max+Box_Size/Two - y_max=y_max+Box_Size/Two - z_max=z_max+Box_Size/Two -* -*---- At least one finite box. Adjust to an even number of boxes. -* - nx=Int((x_max-x_min+Box_Size)/Box_Size) - nx=2*((nx+1)/2) - ny=Int((y_max-y_min+Box_Size)/Box_Size) - ny=2*((ny+1)/2) - nz=Int((z_max-z_min+Box_Size)/Box_Size) - nz=2*((nz+1)/2) -* -*---- Adjust extremal values to fit exactly with the -* box size. -* - dx=(DBLE(nx)*Box_Size-(x_max-x_min))/Two - dy=(DBLE(ny)*Box_Size-(y_max-y_min))/Two - dz=(DBLE(nz)*Box_Size-(z_max-z_min))/Two -* - x_min=x_min-dx - y_min=y_min-dy - z_min=z_min-dz - x_max=x_max+dx - y_max=y_max+dy - z_max=z_max+dz -* -*---- Add the infinite edge boxes -* - nx=nx+2 - ny=ny+2 - nz=nz+2 -#ifdef _DEBUGPRINT_ - Write (6,*) 'x_min=',x_min,dx - Write (6,*) 'y_min=',y_min,dy - Write (6,*) 'z_min=',z_min,dz - Write (6,*) 'x_max=',x_max - Write (6,*) 'y_max=',y_max - Write (6,*) 'z_max=',z_max - Write (6,*) 'nx,ny,nz=',nx,ny,nz - Write (6,*) 'Total number of blocks=',nx*ny*nz -#endif - number_of_subblocks=nx*ny*nz -* * -************************************************************************ -* * -* nFOrd: the order of the functional. nFOrd-1 is the number of times -* the basis functions has to be differentiated to compute the -* energy contribution. -* mRad: number of different radial functions associated with a -* basis function. This number depends on the type of -* functional and the number of times the basis function has -* to be differentiated in order to produce the values of the -* parameters which the functional depends on (rho, grad rho, -* and nabla rho). -* mAO: number of elements a basis function generates upon -* differentiation (1,4,10,20, etc.) -* - Select Case (Functional_type) - - Case (LDA_type) - nFOrd=1 - mAO=(nFOrd*(nFOrd+1)*(nFOrd+2))/6 - if(do_grad) mAO=4!AMS - GRADIENTS? - If (.Not.Do_Grad) Then - mRad=nFOrd - Else - mRad=nFOrd+1 - End If -* - Case (GGA_type) - nFOrd=2 - mAO=(nFOrd*(nFOrd+1)*(nFOrd+2))/6 - if(do_grad) mAO=10 - If (.Not.Do_Grad) Then - mRad=nFOrd - Else - mRad=nFOrd+1 - End If -* - Case (meta_GGA_type1) - nFOrd=2 - mAO=(nFOrd*(nFOrd+1)*(nFOrd+2))/6 - If (.Not.Do_Grad) Then - mRad=nFOrd - Else - mRad=NFOrd+1 - End If -* - Case (meta_GGA_type2) - nFOrd=3 - mAO=(nFOrd*(nFOrd+1)*(nFOrd+2))/6 - If (.Not.Do_Grad) Then - mRad=nFOrd - Else - mRad=NFOrd+1 - End If -* - Case Default - mRad=0 ! Dummy initialize - mAO=0 ! Dummy initialize - Call WarningMessage(2,'Functional_type.eq.Other_type') - Call Abend() - End Select -! * -!*********************************************************************** -! * -! Allocate scratch for processing AO's on the grid -! -* - nMem=0 - nSO =0 - lSO =0 - lAngular=0 - Do ish = 1, nShell - iAng = iSD( 1,iSh) - iCmp = iSD( 2,iSh) - iBas = iSD( 3,iSh) - iPrim = iSD( 5,iSh) -* - nxyz = nGridMax*3*(iAng+mRad) - nDrv = mRad - 1 - nForm = 0 - Do iDrv = 0, nDrv - nForm = nForm + nElem(iDrv) - End Do - nTerm = 2**nDrv - nAngular = 5*nForm*nTerm - nRad = iPrim*nGridMax*mRad - nRadial = iBas*nGridMax*mRad - If (On_Top) Then - mdci = iSD(10,iSh) - kAO=iCmp*iBas*nGridMax - nSO=kAO*nSym/dc(mdci)%nStab*mAO - End If - nMem=Max(nMem,nxyz+nRad+nRadial) - lSO=Max(lSO,nSO) - lAngular=Max(lAngular,nAngular) - End Do -* - Call mma_allocate(Angular,lAngular,Label='Angular') - Call mma_allocate(Mem,nMem,Label='Mem') -* * -************************************************************************ -* * -* Access the file with Grid points and weights. -* -*---- Open the file. - Lu_Grid=88 - Call DaName_MF_WA(Lu_Grid,'NQGRID') -* - If (iGrid_Set.eq.Not_Specified) iGrid_Set=Final -* -*---- Read the status flag. - iDisk_Grid=0 - Call iDaFile(Lu_Grid,2,G_S,5,iDisk_Grid) -* - Grid_Status=G_S(iGrid_Set) - If (Old_Functional_Type.ne.Functional_Type) Then - G_S(Final)=Regenerate - G_S(Intermediate)=Regenerate - Grid_Status=Regenerate - End If - iDisk_Grid=iDisk_Set(iGrid_Set) -* -*---- Allocate memory for the master TOC. - Call mma_Allocate(GridInfo,2,number_of_subblocks, - & Label='GridInfo') -* -*---- Retrieve the TOC or regenerate it. -* -* The table contains two data items per subblock. -* 1) disk address and 2) number of batches. -* - If (Grid_Status.eq.Regenerate) Then -! Write (6,*) 'Grid_Status.eq.Regenerate' - Grid_Status=Regenerate - GridInfo(:,:)=0 - Call iDaFile(Lu_Grid,1,GridInfo, - & 2*number_of_subblocks,iDisk_Grid) - Old_Functional_Type=Functional_Type - Else If (Grid_Status.eq.Use_Old) Then -! Write (6,*) 'Grid_Status.eq.Use_Old' - Call iDaFile(Lu_Grid,2,GridInfo, - & 2*number_of_subblocks,iDisk_Grid) - Else - Call WarningMessage(2,'Illegal Grid Status!') - Call Abend() - End If -* - Call ParmPkR8(Pck_Old,PMode_old) - Call IniPkR8(T_Y,.True.) -* * -************************************************************************ -* * -* Setup some symmetry stuff outside the loop -* - ndc = 0 - Do iSh = 1, nShell - ndc = Max(ndc,iSD(10,iSh)) - End Do - Call mma_allocate(Fact,ndc,ndc,Label='Fact') - Do mdci = 1, ndc - nDegi=nIrrep/dc(mdci)%nStab - Do mdcj = 1, ndc - nDegj=nIrrep/dc(mdcj)%nStab -* - Call DCR(LmbdR,dc(mdci)%iStab,dc(mdci)%nStab, - & dc(mdcj)%iStab,dc(mdcj)%nStab,iDCRR,nDCRR) -* - iuv = dc(mdci)%nStab*dc(mdcj)%nStab - If (MolWgh.eq.1) Then - Fct = DBLE(nIrrep) / DBLE(LmbdR) - Else If (MolWgh.eq.0) Then - Fct = DBLE(iuv) / DBLE(nIrrep * LmbdR) - Else - Fct = Sqrt(DBLE(iuv))/ DBLE(LmbdR) - End If - Fct=Fct*DBLE(nDCRR)/DBLE(nDegi*nDegj) -* -*---------- Save: Fact -* - Fact(mdci,mdcj) = Fct -* - End Do - End Do -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/setup_nq.F90 openmolcas-22.10/src/nq_util/setup_nq.F90 --- openmolcas-22.02/src/nq_util/setup_nq.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/setup_nq.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,644 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1999, Roland Lindh * +!*********************************************************************** + +subroutine Setup_NQ(Maps2p,nShell,nSym,nNQ,Do_Grad,On_Top,Pck_Old,PMode_old,R_Min,nR_Min) +!*********************************************************************** +! * +! Object: to set up information for calculation of integrals via a * +! numerical quadrature. * +! Warning: The exponents of each shell are reordered diffuse to compact* +! * +! Author: Roland Lindh, * +! Dept of Chemical Physics, * +! University of Lund, Sweden * +! August 1999 * +!*********************************************************************** + +use iSD_data, only: iSD, nskal_iSD +use Basis_Info, only: dbsc, MolWgh, Shells +use Center_Info, only: dc +use Symmetry_Info, only: nIrrep, iOper +use nq_Grid, only: Angular, Coor, Fact, Mem, nGridMax, nR_Eff, Pax +use nq_structure, only: NQ_Data, Open_NQ_Data +use nq_Info, only: Angular_Pruning, Block_size, Crowding, Fade, Functional_Type, GGA_type, L_Quad, LDA_type, MBC, meta_GGA_type1, & + meta_GGA_type2, mRad, nAngularGrids, nAtoms, ndc, nR, ntotgp, number_of_subblocks, nx, ny, nz, Off, On, & + Rotational_Invariance, T_Y, Threshold, x_min, y_min, z_min +use Grid_On_Disk, only: Final_Grid, G_S, Grid_Status, GridInfo, iDisk_Grid, iDisk_Set, iGrid_Set, Intermediate, Lu_Grid, & + Not_Specified, Old_Functional_Type, Regenerate, Use_Old +use Index_Functions, only: nTri_Elem1 +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Quart +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nShell, nSym, nR_Min +integer(kind=iwp), intent(out) :: Maps2p(nShell,0:nSym-1), nNQ +logical(kind=iwp), intent(in) :: Do_Grad, On_Top +real(kind=wp), intent(out) :: Pck_Old, R_Min(0:nR_Min) +logical(kind=iwp), intent(out) :: PMode_old +#include "status.fh" +integer(kind=iwp) :: iAng, iAng_, iANr, iAt, iBas, iCar, iCmp, iCnt, iCnttp, iDCRR(0:7), iDrv, iDum(1), iIrrep, iNQ, iNQ_, & + iNQ_MBC, iPrim, iReset, iS, iSet, ish, iShell, iShll, iSym, iuv, kAO, lAng, lAngular, LmbdR, lSO, mAO, mdci, & + mdcj, mExp, nAngular, nCntrc, nDCRR, nDegi, nDegj, nDrv, nFOrd, nForm, nMem, nR_tmp, nRad, nRadial, NrExp, & + nSO, nTerm, nxyz +real(kind=wp) :: A_high, A_low, Alpha(2), Box_Size, C(3), Crowding_tmp, Dummy(1), dx, dy, dz, Fct, R_BS, rm(2), Threshold_tmp, & + ValExp, x_max, XYZ(3), y_max, z_max +logical(kind=iwp) :: EQ +real(kind=wp), allocatable :: Crd(:,:), dOdx(:,:,:,:), TempC(:,:), ZA(:) +real(kind=wp), external :: Bragg_Slater, Eval_RMin + +! * +!*********************************************************************** +! * +Maps2p(:,:) = -99999999 +!define _DEBUGPRINT_ +! * +!*********************************************************************** +! * +!write(u6,*) '********** Setup_NQ ***********' +ntotgp = 0 +! * +!*********************************************************************** +! * +! Check if NQ environment has been activated + +if ((NQ_Status /= Active) .and. (NQ_Status /= Inactive)) then + call WarningMessage(2,'Setup_NQ: NQ_Status not initialized') + call Quit_OnUserError() +end if +if (NQ_Status == Active) return +NQ_Status = Active +! * +!*********************************************************************** +! * +! Get the coordinates to the centers of all Voronoi polyhedra +! +! Note that this will be all centers with valence basis sets on +! them. Hence this will also include any pseudo centers! + +call mma_allocate(TempC,3,nShell*nSym,Label='TempC') +nAtoms = 0 +if (nShell > nskal_iSD) then + write(u6,*) 'nShell > nSkal_iSD' + write(u6,*) 'nShell=',nShell + write(u6,*) 'nSkal_iSD=',nSkal_iSD + call AbEnd() +end if +do iShell=1,nShell + iCnttp = iSD(13,iShell) + iCnt = iSD(14,iShell) + XYZ(1:3) = dbsc(iCnttp)%Coor(1:3,iCnt) + call Process_Coor(XYZ,TempC,nAtoms,nSym,iOper) +end do +call mma_allocate(Coor,3,nAtoms,Label='Coor') +Coor(:,:) = TempC(:,1:nAtoms) +call mma_deallocate(TempC) +! * +!*********************************************************************** +! * +! Get the symmetry unique coordinates + +nNQ = nAtoms +call Open_NQ_Data(Coor) +! * +!*********************************************************************** +! * +! Pick up the requested accuracy. + +!Dr = -Log10(Thr) +! * +!*********************************************************************** +! * +! Loop over each unique center, and find the highest and lowest +! Gaussians exponents associated with this center. The latter +! information will be used to design the radial grid associated +! with this center. + +! Loop over the shells + +do iShell=1,nShell + + ! Get the Atom number + iANr = dbsc(iSD(13,iShell))%AtmNr + + iShll = iSD(0,iShell) ! Get the angular momentum of ishell + iAng = iSD(1,iShell) ! Get the angular momentum of ishell + nCntrc = iSD(3,iShell) ! Get the # of contracted functions for iShell + mExp = iSD(5,iShell) ! Get the number of exponents of ishell + + !********************************************************************* + ! * + ! Order the exponents diffuse to compact for the active shell * + ! * + !********************************************************************* + call OrdExpD2C(mExp,Shells(iShll)%Exp,nCntrc,Shells(iShll)%pCff) + + ! Get the extreme exponents for the active shell. + A_low = Shells(iShll)%Exp(1) + A_high = Shells(iShll)%Exp(mExp) + + iCnttp = iSD(13,iShell) + iCnt = iSD(14,iShell) + C(1:3) = dbsc(iCnttp)%Coor(1:3,iCnt) + outer: do iIrrep=0,nIrrep-1 + call OA(iOper(iIrrep),C,XYZ) + do iNQ=1,nNQ + + if (EQ(NQ_data(iNQ)%Coor,XYZ)) then + + NQ_Data(iNQ)%Atom_Nr = iANR + + ! Assign the BS radius to the center + NQ_Data(iNQ)%R_RS = Bragg_Slater(iANr) + + ! What is the maximum angular momentum for the active center ? + NQ_Data(iNQ)%l_Max = max(NQ_Data(iNQ)%l_max,iAng) + + ! Get the extreme exponents for the atom + NQ_Data(iNQ)%A_high = max(NQ_Data(iNQ)%A_high,A_High) + NQ_Data(iNQ)%A_low = min(NQ_Data(iNQ)%A_low,A_low) + + Maps2p(iShell,iIrrep) = iNQ + cycle outer + end if + end do ! iNQ + call WarningMessage(2,'Did not find a center associated with the shell!') + call Abend() + end do outer ! iIrrep + +end do ! iShell + +!*********************************************************************** +! * +! END OF THE LOOP OVER THE SHELLS. * +! Now we have the number of unique center and their associated * +! exponents and maximum angular momentum. And for each shell the * +! exponents are ordered diffuse to compact. * +! * +!*********************************************************************** +! * +! Loop over all the atoms to create the radial quadrature * +! * +!*********************************************************************** +! +! Allocate memory to store the number of effective radial points for +! each center and the radius of this center. +call mma_Allocate(nR_Eff,nNQ,Label='nR_Eff') + +iNQ_MBC = 0 +iReset = 0 +Threshold_tmp = Zero +nR_tmp = 0 +do iNQ=1,nNQ + ! Get the extreme exponents for the atom + Alpha(1) = NQ_Data(iNQ)%A_low + Alpha(2) = NQ_Data(iNQ)%A_high + + ! Get the coordinates of the atom + XYZ(:) = NQ_Data(iNQ)%Coor + + ! For a special center we can increase the accuracy. + + if (MBC /= ' ') then + do iS=1,nShell + iCnttp = iSD(13,iS) + iCnt = iSD(14,iS) + C(1:3) = dbsc(iCnttp)%Coor(1:3,iCnt) + if (EQ(NQ_Data(iNQ)%Coor,C)) then + mdci = iSD(10,iS) + if (dc(mdci)%LblCnt == MBC) then + nR_tmp = nR + nR = int(real(nR,kind=wp)*Two) + Threshold_tmp = Threshold + Threshold = Threshold*1.0e-6_wp + + iReset = 1 + iNQ_MBC = iNQ + exit + end if + end if + end do + end if + + ! Max angular momentum for the atom -> rm(1) + ! Max Relative Error -> rm(2) + rm(1) = real(NQ_Data(iNQ)%l_Max,kind=wp) + rm(2) = Threshold + + call GenVoronoi(nR_Eff(iNQ),Alpha,rm,iNQ) + + if (iReset == 1) then + nR = nR_tmp + Threshold = Threshold_tmp + iReset = 0 + end if + +end do ! iNQ +! * +!*********************************************************************** +! * +! Compute the principal axis system and optionally to +! compute derivatives of the principal axis. Needed in order to +! compute the gradient of the rotationally invariant DFT energy. + +call mma_allocate(Pax,3,3,Label='Pax') +call mma_allocate(dOdx,3,3,nNQ,3,Label='dOdx') +dOdx(:,:,:,:) = Zero +call mma_Allocate(ZA,nNQ,Label='ZA') +call mma_Allocate(Crd,3,nNQ) + +! Collect coordinates and charges of the nuclei + +do iNQ=1,nNQ + ZA(iNQ) = real(NQ_Data(iNQ)%Atom_Nr,kind=wp) + Crd(:,iNQ) = NQ_data(iNQ)%Coor +end do + +call RotGrd(Crd,ZA,Pax,dOdx,Dummy,nNQ,Do_Grad,.false.) + +! Distribute derivative of the principal axis system + +if (Do_Grad) then + do iNQ=1,nNQ + call mma_allocate(NQ_Data(iNQ)%dOdx,3,3,3,Label='dOdx') + do iCar=1,3 + NQ_Data(iNQ)%dOdx(:,:,iCar) = dOdx(:,:,iNQ,iCar) + end do + end do +end if + +call mma_deallocate(dOdX) +call mma_deallocate(Crd) +call mma_deallocate(ZA) +! * +!*********************************************************************** +! * +if (Rotational_Invariance == Off) then + Pax(:,:) = reshape([One,Zero,Zero,Zero,One,Zero,Zero,Zero,One],[3,3]) + do iNQ=1,nNQ + if (.not. allocated(NQ_Data(iNQ)%dOdx)) call mma_allocate(NQ_Data(iNQ)%dOdx,3,3,3,Label='dOdx') + NQ_Data(iNQ)%dOdx(:,:,:) = Zero + end do +end if +! * +!*********************************************************************** +! * +! Generate the angular grid + +call Angular_grid() + +Crowding_tmp = Zero +do iNQ=1,nNQ + + ! Assign the angular grid to be used with each radial grid point + + call mma_allocate(NQ_Data(iNQ)%Angular,nR_Eff(iNQ),Label='Angular') + NQ_Data(iNQ)%Angular(:) = nAngularGrids + + ! Prune the angular grid + + if (Angular_Pruning == On) then + + ! Find the R_min values of each angular shell + + lAng = NQ_Data(iNQ)%l_max + do iAng=0,lAng + R_Min(iAng) = Zero + ValExp = -One + iSet = 0 + do iShell=1,nShell + iShll = iSD(0,iShell) + iAng_ = iSD(1,iShell) + NrExp = iSD(5,iShell) + !write(u6,*) 'iAng_,iAng=',iAng_,iAng + if ((iAng_ == iAng) .and. (NrExp >= 1)) then + do iSym=0,nSym-1 + iNQ_ = Maps2p(iShell,iSym) + !write(u6,*) 'iNQ_,iNQ=',iNQ_,iNQ + if (iNQ_ == iNQ) then + ValExp = Shells(iShll)%Exp(NrExp) + iSet = 1 + end if + end do + end if + end do + if ((ValExp < Zero) .and. (iSet == 1)) then + call WarningMessage(2,'ValExp < Zero') + call Abend() + end if + if (iSet == 1) then + R_Min(iAng) = Eval_RMin(ValExp,iAng,Threshold) + if (iAng == 0) R_Min(iAng) = Zero + end if + end do + + R_BS = NQ_Data(iNQ)%R_RS + + if (iNQ == iNQ_MBC) then + Crowding_tmp = Crowding + Crowding = One+(Crowding-One)*Quart + iReset = 1 + end if + + call Angular_Prune(NQ_Data(iNQ)%R_Quad,nR_Eff(iNQ),NQ_Data(iNQ)%Angular,Crowding,Fade,R_BS,L_Quad,R_Min,lAng,nAngularGrids) + + if (iReset == 1) then + Crowding = Crowding_tmp + iReset = 0 + end if + + end if + +end do +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +write(u6,*) +write(u6,'(A)') ' ==================================' +write(u6,'(A)') ' = Grid information =' +write(u6,'(A)') ' ==================================' +write(u6,'(A)') ' Legend ' +write(u6,'(A)') ' ----------------------------------' +write(u6,'(A)') ' ANr: element number' +write(u6,'(A)') ' nR : number of radial grid points' +write(u6,'(A)') ' iNQ: grid index' +write(u6,'(A)') ' ----------------------------------' +write(u6,*) +write(u6,'(A)') ' iNQ ANr nR' +do iNQ=1,nNQ + iANr = NQ_Data(iNQ)%Atom_Nr + kR = nR_Eff(iNQ) + write(u6,'(3I4)') iNQ,iANr,kR +end do +write(u6,*) +#endif +! * +!*********************************************************************** +! * +! Determine the spatial extension of the molecular system + +!Box_Size = Four ! Angstrom +Box_Size = Two ! Angstrom +!Box_Size = Half ! Angstrom +Block_size = Box_Size +x_min = huge(x_min) +y_min = huge(y_min) +z_min = huge(z_min) +x_max = -huge(x_max) +y_max = -huge(y_max) +z_max = -huge(z_max) +do iAt=1,nAtoms + x_min = min(x_min,Coor(1,iAt)) + y_min = min(y_min,Coor(2,iAt)) + z_min = min(z_min,Coor(3,iAt)) + x_max = max(x_max,Coor(1,iAt)) + y_max = max(y_max,Coor(2,iAt)) + z_max = max(z_max,Coor(3,iAt)) +end do + +! Add half a box size around the whole molecule + +x_min = x_min-Box_Size/Two +y_min = y_min-Box_Size/Two +z_min = z_min-Box_Size/Two +x_max = x_max+Box_Size/Two +y_max = y_max+Box_Size/Two +z_max = z_max+Box_Size/Two + +! At least one finite box. Adjust to an even number of boxes. + +nx = int((x_max-x_min+Box_Size)/Box_Size) +nx = 2*((nx+1)/2) +ny = int((y_max-y_min+Box_Size)/Box_Size) +ny = 2*((ny+1)/2) +nz = int((z_max-z_min+Box_Size)/Box_Size) +nz = 2*((nz+1)/2) + +! Adjust extremal values to fit exactly with the box size. + +dx = (real(nx,kind=wp)*Box_Size-(x_max-x_min))/Two +dy = (real(ny,kind=wp)*Box_Size-(y_max-y_min))/Two +dz = (real(nz,kind=wp)*Box_Size-(z_max-z_min))/Two + +x_min = x_min-dx +y_min = y_min-dy +z_min = z_min-dz +x_max = x_max+dx +y_max = y_max+dy +z_max = z_max+dz + +! Add the infinite edge boxes + +nx = nx+2 +ny = ny+2 +nz = nz+2 +#ifdef _DEBUGPRINT_ +write(u6,*) 'x_min=',x_min,dx +write(u6,*) 'y_min=',y_min,dy +write(u6,*) 'z_min=',z_min,dz +write(u6,*) 'x_max=',x_max +write(u6,*) 'y_max=',y_max +write(u6,*) 'z_max=',z_max +write(u6,*) 'nx,ny,nz=',nx,ny,nz +write(u6,*) 'Total number of blocks=',nx*ny*nz +#endif +number_of_subblocks = nx*ny*nz +! * +!*********************************************************************** +! * +! nFOrd: the order of the functional. nFOrd-1 is the number of times +! the basis functions has to be differentiated to compute the +! energy contribution. +! mRad: number of different radial functions associated with a +! basis function. This number depends on the type of +! functional and the number of times the basis function has +! to be differentiated in order to produce the values of the +! parameters which the functional depends on (rho, grad rho, +! and nabla rho). +! mAO: number of elements a basis function generates upon +! differentiation (1,4,10,20, etc.) + +select case (Functional_type) + + case (LDA_type) + nFOrd = 1 + mAO = (nFOrd*(nFOrd+1)*(nFOrd+2))/6 + if (do_grad) mAO = 4 !AMS - GRADIENTS? + if (.not. Do_Grad) then + mRad = nFOrd + else + mRad = nFOrd+1 + end if + + case (GGA_type) + nFOrd = 2 + mAO = (nFOrd*(nFOrd+1)*(nFOrd+2))/6 + if (do_grad) mAO = 10 + if (.not. Do_Grad) then + mRad = nFOrd + else + mRad = nFOrd+1 + end if + + case (meta_GGA_type1) + nFOrd = 2 + mAO = (nFOrd*(nFOrd+1)*(nFOrd+2))/6 + if (.not. Do_Grad) then + mRad = nFOrd + else + mRad = NFOrd+1 + end if + + case (meta_GGA_type2) + nFOrd = 3 + mAO = (nFOrd*(nFOrd+1)*(nFOrd+2))/6 + if (.not. Do_Grad) then + mRad = nFOrd + else + mRad = NFOrd+1 + end if + + case default + mRad = 0 ! Dummy initialize + mAO = 0 ! Dummy initialize + call WarningMessage(2,'Functional_type == Other_type') + call Abend() +end select +! * +!*********************************************************************** +! * +! Allocate scratch for processing AO's on the grid + +nMem = 0 +nSO = 0 +lSO = 0 +lAngular = 0 +do ish=1,nShell + iAng = iSD(1,iSh) + iCmp = iSD(2,iSh) + iBas = iSD(3,iSh) + iPrim = iSD(5,iSh) + + nxyz = nGridMax*3*(iAng+mRad) + nDrv = mRad-1 + nForm = 0 + do iDrv=0,nDrv + nForm = nForm+nTri_Elem1(iDrv) + end do + nTerm = 2**nDrv + nAngular = 5*nForm*nTerm + nRad = iPrim*nGridMax*mRad + nRadial = iBas*nGridMax*mRad + if (On_Top) then + mdci = iSD(10,iSh) + kAO = iCmp*iBas*nGridMax + nSO = kAO*nSym/dc(mdci)%nStab*mAO + end if + nMem = max(nMem,nxyz+nRad+nRadial) + lSO = max(lSO,nSO) + lAngular = max(lAngular,nAngular) +end do + +call mma_allocate(Angular,lAngular,Label='Angular') +call mma_allocate(Mem,nMem,Label='Mem') +! * +!*********************************************************************** +! * +! Access the file with Grid points and weights. + +! Open the file. +Lu_Grid = 88 +call DaName_MF_WA(Lu_Grid,'NQGRID') + +if (iGrid_Set == Not_Specified) iGrid_Set = Final_Grid + +! Read the status flag. +iDisk_Grid = 0 +call iDaFile(Lu_Grid,2,G_S,2,iDisk_Grid) +call iDaFile(Lu_Grid,2,iDisk_Set,2,iDisk_Grid) +call iDaFile(Lu_Grid,2,iDum,1,iDisk_Grid) +Old_Functional_Type = iDum(1) + +Grid_Status = G_S(iGrid_Set) +if (Old_Functional_Type /= Functional_Type) then + G_S(Final_Grid) = Regenerate + G_S(Intermediate) = Regenerate + Grid_Status = Regenerate +end if +iDisk_Grid = iDisk_Set(iGrid_Set) + +! Allocate memory for the master TOC. +call mma_Allocate(GridInfo,2,number_of_subblocks,Label='GridInfo') + +! Retrieve the TOC or regenerate it. + +! The table contains two data items per subblock. +! 1) disk address and 2) number of batches. + +if (Grid_Status == Regenerate) then + !write(u6,*) 'Grid_Status == Regenerate' + Grid_Status = Regenerate + GridInfo(:,:) = 0 + call iDaFile(Lu_Grid,1,GridInfo,2*number_of_subblocks,iDisk_Grid) + Old_Functional_Type = Functional_Type +else if (Grid_Status == Use_Old) then + !write(u6,*) 'Grid_Status == Use_Old' + call iDaFile(Lu_Grid,2,GridInfo,2*number_of_subblocks,iDisk_Grid) +else + call WarningMessage(2,'Illegal Grid Status!') + call Abend() +end if + +call ParmPkR8(Pck_Old,PMode_old) +call IniPkR8(T_Y,.true.) +! * +!*********************************************************************** +! * +! Setup some symmetry stuff outside the loop + +ndc = 0 +do iSh=1,nShell + ndc = max(ndc,iSD(10,iSh)) +end do +call mma_allocate(Fact,ndc,ndc,Label='Fact') +do mdci=1,ndc + nDegi = nIrrep/dc(mdci)%nStab + do mdcj=1,ndc + nDegj = nIrrep/dc(mdcj)%nStab + + call DCR(LmbdR,dc(mdci)%iStab,dc(mdci)%nStab,dc(mdcj)%iStab,dc(mdcj)%nStab,iDCRR,nDCRR) + + iuv = dc(mdci)%nStab*dc(mdcj)%nStab + if (MolWgh == 1) then + Fct = real(nIrrep,kind=wp)/real(LmbdR,kind=wp) + else if (MolWgh == 0) then + Fct = real(iuv,kind=wp)/real(nIrrep*LmbdR,kind=wp) + else + Fct = sqrt(real(iuv,kind=wp))/real(LmbdR,kind=wp) + end if + Fct = Fct*real(nDCRR,kind=wp)/real(nDegi*nDegj,kind=wp) + + ! Save: Fact + + Fact(mdci,mdcj) = Fct + + end do +end do +! * +!*********************************************************************** +! * + +return + +end subroutine Setup_NQ diff -Nru openmolcas-22.02/src/nq_util/subblock.f openmolcas-22.10/src/nq_util/subblock.f --- openmolcas-22.02/src/nq_util/subblock.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/subblock.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,358 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1999, Roland Lindh * -************************************************************************ - SubRoutine Subblock(iNQ,x_NQ,y_NQ,z_NQ,InBox, - & x_min_,x_max_, - & y_min_,y_max_, - & z_min_,z_max_, - & list_p,nlist_p, - & Grid,Weights,mGrid, - & Process, - & number_of_grid_points, - & R_box_min,R_box_max, - & ilist_p,xyz0,iAngular_Grid,nR_Eff) -************************************************************************ -* * -* Object: * -* * -* Author: Roland Lindh, * -* Dept of Chemical Physics, * -* University of Lund, Sweden * -* August 1999 * -************************************************************************ - use NQ_structure, only: NQ_Data, Info_Ang - use Grid_On_Disk - use nq_Info - Implicit Real*8 (A-H,O-Z) -#include "itmax.fh" -#include "real.fh" -#include "setup.fh" -#include "nsd.fh" -#include "debug.fh" - Integer list_p(nlist_p) - Real*8 Grid(3,mGrid), Weights(mGrid), xyz0(3,2) - Logical Process,InBox, Check - Integer iAngular_Grid(nR_Eff) -* * -************************************************************************ -* * -* Statement functions * -* * - Check(i,j)=iAnd(i,2**(j-1)).ne.0 - x_a(i,iSet)=Info_Ang(iSet)%R(1,i) - y_a(i,iSet)=Info_Ang(iSet)%R(2,i) - z_a(i,iSet)=Info_Ang(iSet)%R(3,i) - w_a(i,iSet)=Info_Ang(iSet)%R(4,i) -* * -************************************************************************ -* * - nGrid=(9*mGrid)/10 - iStrt=number_of_grid_points+1 -* * -************************************************************************ -* * -*---- Start loop over the atomic grid -* -#ifdef _DEBUGPRINT_ - If (Debug) Then - Write (6,*) ' x_NQ=',x_NQ - Write (6,*) ' y_NQ=',y_NQ - Write (6,*) ' z_NQ=',z_NQ - Write (6,*) ' Process=',Process - Write (6,*) ' number_of_grid_points=',number_of_grid_points - Write (6,*) 'x:', x_min_,x_max_ - Write (6,*) 'y:', y_min_,y_max_ - Write (6,*) 'z:', z_min_,z_max_ - Write (6,*) - End If -#endif -* * -************************************************************************ -* * - iStart_R= nR_Eff - iEnd_R=1 -c Write (*,*) -c Write (*,*) 'Start range:',iEnd_R, iStart_R - If (.Not.Check(iOpt_Angular,2)) Then -c Write (*,*) 'Find R subrange!' -* -*------- Compute valid subrange for R -* - iR_End = iEnd_R - Do iR = iEnd_R, iStart_R - R_Value = NQ_Data(iNQ)%R_Quad(1,iR) - If (R_Value.le.R_box_Min) Then - iR_End = iR - Else - Go To 8888 - End If - End Do - 8888 Continue -* - iR_Start = iStart_R - Do iR = iStart_R, iR_End, -1 - R_Value = NQ_Data(iNQ)%R_Quad(1,iR) - If (R_Value.ge.R_Box_Max) Then - iR_Start = iR - Else - Go To 8889 - End If - End Do - 8889 Continue -* - Else -c Write (*,*) 'Do whole R range!' -* -*------- Scan the whole range -* - iR_Start=iStart_R - iR_End =iEnd_R -* - End If -* -*---- Reset iStart_R and iEnd_R, these are not to be modified again! -* - iStart_R=iR_Start - iEnd_R =iR_End - iSet=-1 -c Write (*,*) 'Actual range:',iEnd_R, iStart_R -* * -************************************************************************ -* * -* Outer loop over angular grids -* - 999 Continue -* * -************************************************************************ -* * -* Determine a range (iStart_R,iEnd_R) where we will use a -* specific angular grid. As we get closer to the nuclei we will -* reduce the order of the angular grid. -* -* -*------- Start loop at the outermost point and iterate towards the -* nuclei. -* - iR_End=iR_Start+1 - Do iR = iR_Start, iEnd_R, -1 - kSet = iAngular_Grid(iR) -* -*---------- Save new iSet for the first point of this -* subrange. -* - If (iR.eq.iR_Start) iSet = kSet -* -*---------- Branch out if we hit on a range where we can reduce the -* angular grid further. -* - If (kSet.ne.iSet) Go To 888 -* -*---------- Update inner index -* - iR_End = iR - End Do -* - 888 Continue -* -*------ Branch out if subrange is outside the box -* - R_Value_Min = NQ_Data(iNQ)%R_Quad(1,iR_End) - If (R_Value_Min.gt.R_box_Max) Go To 8887 - R_Value_Max = NQ_Data(iNQ)%R_Quad(1,iR_Start) - If (R_Value_Max.lt.R_box_Min) Go To 8887 -* -c Write (*,*) 'Selected range:',iR_End, iR_Start -c Write (*,*) 'l_max=',Info_Ang(iSet)%L_Eff -* * -************************************************************************ -* * -*---- Angular loop -* - Do iPoint=1,Info_Ang(iSet)%nPoints -#ifdef _DEBUGPRINT_ - If (Debug) Then - Write (6,*) 'X,Y,Z*',x_a(iPoint,iSet), - & y_a(iPoint,iSet), - & z_a(iPoint,iSet) - End If -#endif -* - If (.Not.InBox.and..Not.Check(iOpt_Angular,2)) Then -c Write (*,*) 'Select angular points!' - If (x_a(iPoint,iset).lt.xyz0(1,1) .or. - & x_a(iPoint,iset).gt.xyz0(1,2) .or. - & y_a(iPoint,iset).lt.xyz0(2,1) .or. - & y_a(iPoint,iset).gt.xyz0(2,2) .or. - & z_a(iPoint,iset).lt.xyz0(3,1) .or. - & z_a(iPoint,iset).gt.xyz0(3,2) ) Go To 7777 - End If -* * -************************************************************************ -* * -*------- Radial loop over the reduced range -* - Do iR = iR_End,iR_Start - Radius=NQ_Data(iNQ)%R_Quad(1,iR) -* In the atomic referential - xpt=Radius*x_a(iPoint,iSet) - ypt=Radius*y_a(iPoint,iSet) - zpt=Radius*z_a(iPoint,iSet) -* In the system referential - x=xpt+x_NQ - y=ypt+y_NQ - z=zpt+z_NQ -#ifdef _DEBUGPRINT_ - If (Debug) Then - Write (6,*) 'Radius=',Radius - Write (6,*) ' x,y,z:',x,y,z - Write (6,*) x_NQ, y_NQ, z_NQ - End If -#endif -* -*---------- Check if the point is inside the box. -* Points on the border of boxes are shared. -* - If ( - & (x.ge.x_min_).and.(x.le.x_max_) .and. - & (y.ge.y_min_).and.(y.le.y_max_) .and. - & (z.ge.z_min_).and.(z.le.z_max_) - & ) Then -* -*------------- For shared points modify the weight. -* - Fact=One - If (x.eq.x_min_) Fact=Fact*Half - If (y.eq.y_min_) Fact=Fact*Half - If (z.eq.z_min_) Fact=Fact*Half - If (x.eq.x_max_) Fact=Fact*Half - If (y.eq.y_max_) Fact=Fact*Half - If (z.eq.z_max_) Fact=Fact*Half -#ifdef _DEBUGPRINT_ - If (Debug) Then - Write (6,*) x_a(iPoint,iSet), - & y_a(iPoint,iSet), - & z_a(iPoint,iSet) - Write (6,*) 'x:', xyz0(1,1),xyz0(1,2) - Write (6,*) 'y:', xyz0(2,1),xyz0(2,2) - Write (6,*) 'z:', xyz0(3,1),xyz0(3,2) - Write (6,*) ' Inside:',x,y,z - End If -#endif -* -* Radial weight - weight=NQ_Data(iNQ)%R_Quad(2,iR) -* Combine the radial and angular weight - w_g=weight*w_a(iPoint,iSet) - If (w_g*Fact>=1.0D-15) Then - number_of_grid_points=number_of_grid_points+1 - Grid(1,number_of_grid_points)= x - Grid(2,number_of_grid_points)= y - Grid(3,number_of_grid_points)= z -* Compute the partitioning weight - Weights(number_of_grid_points)=w_g*Fact - End If - End If -* * -************************************************************************ -* * -* The call of Do_Batch is done if the buffer is full : -* (number_of_grid_points.gt.nGrid) -* * -************************************************************************ -* * - If (number_of_grid_points.gt.mGrid) Then - Call WarningMessage(2,'Subblock: Buffer overflowed!;'// - & 'Try a larger buffer size!') - Call Abend() - End If - If (number_of_grid_points.gt.nGrid) Then -* -*---------- Dump grid information to disk - nBatch = nBatch + 1 - If (nBatch.gt.nBatch_Max) Then - Call WarningMessage(2,'Subblock: nBatch.gt.nBatch_Max') - Call Abend() - End If -* -*---------- Generate weights -* - mGrid_= number_of_grid_points-iStrt+1 - Call W(Grid(1,iStrt),ilist_p,Weights(iStrt),list_p, - & nList_p,mGrid_,nRemoved) - number_of_grid_points=number_of_grid_points-nRemoved - - iBatchInfo(1,nBatch)=iDisk_Grid - iBatchInfo(3,nBatch)=iNQ - iBatchInfo(2,nBatch)=number_of_grid_points - - Call dDaFile(Lu_Grid,1,Grid,3*number_of_grid_points, - & iDisk_Grid) - Call dDaFile(Lu_Grid,1,Weights,number_of_grid_points, - & iDisk_Grid) -* - ntotgp=ntotgp+number_of_grid_points -C Write (*,*) 'ntotgp=',ntotgp - number_of_grid_points=0 - iStrt=number_of_grid_points+1 - End If -* - End Do ! iR, Radial loop - 7777 Continue - End Do ! iPoint -* * -************************************************************************ -* * - 8887 Continue - iR_Start=iR_End-1 - If (Angular_Prunning.eq.On.and.iR_End.ne.iEnd_R) Go To 999 -* * -************************************************************************ -* * -*---- Generate weights -* -* Write (6,*) 'number_of_grid_points=',number_of_grid_points -* Write (6,*) 'iStrt=',iStrt - If (number_of_grid_points-iStrt+1.gt.0) Then - mGrid_=number_of_grid_points-iStrt+1 - Call W(Grid(1,iStrt),ilist_p,Weights(iStrt),list_p, - & nList_p,mGrid_,nRemoved) - number_of_grid_points=number_of_grid_points-nRemoved - End If -* * -************************************************************************ -* * -*---- Process batch if not processed yet. -* - If (Process.and.number_of_grid_points.gt.0) Then -* -*------- Dump grid information to disk - nBatch = nBatch + 1 - If (nBatch.gt.nBatch_Max) Then - Call WarningMessage(2,'Subblock: nBatch.gt.nBatch_Max') - Call Abend() - End If - iBatchInfo(1,nBatch)=iDisk_Grid - iBatchInfo(2,nBatch)=number_of_grid_points - iBatchInfo(3,nBatch)=iNQ - Call dDaFile(Lu_Grid,1,Grid,3*number_of_grid_points, - & iDisk_Grid) - Call dDaFile(Lu_Grid,1,Weights,number_of_grid_points, - & iDisk_Grid) -* - ntotgp=ntotgp+number_of_grid_points -C Write (*,*) 'ntotgp=',ntotgp - number_of_grid_points=0 - End If -* * -************************************************************************ -* * - End diff -Nru openmolcas-22.02/src/nq_util/subblock.F90 openmolcas-22.10/src/nq_util/subblock.F90 --- openmolcas-22.02/src/nq_util/subblock.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/subblock.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,301 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1999, Roland Lindh * +!*********************************************************************** + +subroutine Subblock(iNQ,x_NQ,y_NQ,z_NQ,InBox,x_min_,x_max_,y_min_,y_max_,z_min_,z_max_,list_p,nlist_p,Grid,Weights,mGrid,Process, & + number_of_grid_points,R_box_min,R_box_max,ilist_p,xyz0,iAngular_Grid,nR_Eff) +!*********************************************************************** +! * +! Object: * +! * +! Author: Roland Lindh, * +! Dept of Chemical Physics, * +! University of Lund, Sweden * +! August 1999 * +!*********************************************************************** + +use NQ_structure, only: Info_Ang, NQ_Data +use nq_Info, only: Angular_Pruning, iOpt_Angular, ntotgp, On +use Grid_On_Disk, only: ExpandBatchInfo, iBatchInfo, iDisk_Grid, Lu_Grid, nBatch +use Constants, only: One, Half +use Definitions, only: wp, iwp +#ifdef _DEBUGPRINT_ +use Definitions, only: u6 +#endif + +implicit none +integer(kind=iwp), intent(in) :: iNQ, nlist_p, list_p(nlist_p), mGrid, ilist_p, nR_Eff, iAngular_Grid(nR_Eff) +real(kind=wp), intent(in) :: x_NQ, y_NQ, z_NQ, x_min_, x_max_, y_min_, y_max_, z_min_, z_max_, R_box_min, R_box_max, xyz0(3,2) +logical(kind=iwp), intent(in) :: InBox, Process +real(kind=wp), intent(inout) :: Grid(3,mGrid), Weights(mGrid) +integer(kind=iwp), intent(inout) :: number_of_grid_points +integer(kind=iwp) :: iEnd_R, iPoint, iR, iR_End, iR_Start, iSet, iStart_R, iStrt, kSet, mGrid_, nGrid, nRemoved +real(kind=wp) :: Fact, R_Value, Radius, w_g, weight, x, xpt, y, ypt, z, zpt + +! * +!*********************************************************************** +! * +nGrid = (9*mGrid)/10 +iStrt = number_of_grid_points+1 +! * +!*********************************************************************** +! * +! Start loop over the atomic grid + +#ifdef _DEBUGPRINT_ +write(u6,*) ' x_NQ=',x_NQ +write(u6,*) ' y_NQ=',y_NQ +write(u6,*) ' z_NQ=',z_NQ +write(u6,*) ' Process=',Process +write(u6,*) ' number_of_grid_points=',number_of_grid_points +write(u6,*) 'x:',x_min_,x_max_ +write(u6,*) 'y:',y_min_,y_max_ +write(u6,*) 'z:',z_min_,z_max_ +write(u6,*) +#endif +! * +!*********************************************************************** +! * +iStart_R = nR_Eff +iEnd_R = 1 +!write(u6,*) +!write(u6,*) 'Start range:',iEnd_R,iStart_R +if (.not. btest(iOpt_Angular,1)) then + !write(u6,*) 'Find R subrange!' + + ! Compute valid subrange for R + + iR_End = iEnd_R + do iR=iEnd_R,iStart_R + R_Value = NQ_Data(iNQ)%R_Quad(1,iR) + if (R_Value > R_box_Min) exit + iR_End = iR + end do + + iR_Start = iStart_R + do iR=iStart_R,iR_End,-1 + R_Value = NQ_Data(iNQ)%R_Quad(1,iR) + if (R_Value < R_Box_Max) exit + iR_Start = iR + end do + +else + !write(u6,*) 'Do whole R range!' + + ! Scan the whole range + + iR_Start = iStart_R + iR_End = iEnd_R + +end if + +! Reset iStart_R and iEnd_R, these are not to be modified again! + +iStart_R = iR_Start +iEnd_R = iR_End +iSet = -1 +!write(u6,*) 'Actual range:',iEnd_R,iStart_R +! * +!*********************************************************************** +! * +! Outer loop over angular grids + +do + ! * + !********************************************************************* + ! * + ! Determine a range (iStart_R,iEnd_R) where we will use a + ! specific angular grid. As we get closer to the nuclei we will + ! reduce the order of the angular grid. + + ! Start loop at the outermost point and iterate towards the + ! nuclei. + + iR_End = iR_Start+1 + do iR=iR_Start,iEnd_R,-1 + kSet = iAngular_Grid(iR) + + ! Save new iSet for the first point of this subrange. + + if (iR == iR_Start) iSet = kSet + + ! Branch out if we hit on a range where we can reduce the + ! angular grid further. + + if (kSet /= iSet) exit + + ! Update inner index + + iR_End = iR + end do + + ! Branch out if subrange is outside the box + + if ((NQ_Data(iNQ)%R_Quad(1,iR_End) <= R_box_Max) .and. (NQ_Data(iNQ)%R_Quad(1,iR_Start) >= R_box_Min)) then + + !write(u6,*) 'Selected range:',iR_End,iR_Start + !write(u6,*) 'l_max=',Info_Ang(iSet)%L_Eff + ! * + !******************************************************************* + ! * + ! Angular loop + + do iPoint=1,Info_Ang(iSet)%nPoints +# ifdef _DEBUGPRINT_ + write(u6,*) 'X,Y,Z*',Info_Ang(iSet)%R(1,iPoint),Info_Ang(iSet)%R(2,iPoint),Info_Ang(iSet)%R(3,iPoint) +# endif + + if ((.not. InBox) .and. (.not. btest(iOpt_Angular,1))) then + !write(u6,*) 'Select angular points!' + if ((Info_Ang(iSet)%R(1,iPoint) < xyz0(1,1)) .or. (Info_Ang(iSet)%R(1,iPoint) > xyz0(1,2)) .or. & + (Info_Ang(iSet)%R(2,iPoint) < xyz0(2,1)) .or. (Info_Ang(iSet)%R(2,iPoint) > xyz0(2,2)) .or. & + (Info_Ang(iSet)%R(3,iPoint) < xyz0(3,1)) .or. (Info_Ang(iSet)%R(3,iPoint) > xyz0(3,2))) cycle + end if + ! * + !***************************************************************** + ! * + ! Radial loop over the reduced range + + do iR=iR_End,iR_Start + Radius = NQ_Data(iNQ)%R_Quad(1,iR) + ! In the atomic referential + xpt = Radius*Info_Ang(iSet)%R(1,iPoint) + ypt = Radius*Info_Ang(iSet)%R(2,iPoint) + zpt = Radius*Info_Ang(iSet)%R(3,iPoint) + ! In the system referential + x = xpt+x_NQ + y = ypt+y_NQ + z = zpt+z_NQ +# ifdef _DEBUGPRINT_ + write(u6,*) 'Radius=',Radius + write(u6,*) ' x,y,z:',x,y,z + write(u6,*) x_NQ,y_NQ,z_NQ +# endif + + ! Check if the point is inside the box. + ! Points on the border of boxes are shared. + + if ((x >= x_min_) .and. (x <= x_max_) .and. (y >= y_min_) .and. (y <= y_max_) .and. (z >= z_min_) .and. (z <= z_max_)) then + + ! For shared points modify the weight. + + Fact = One + if (x == x_min_) Fact = Fact*Half + if (y == y_min_) Fact = Fact*Half + if (z == z_min_) Fact = Fact*Half + if (x == x_max_) Fact = Fact*Half + if (y == y_max_) Fact = Fact*Half + if (z == z_max_) Fact = Fact*Half +# ifdef _DEBUGPRINT_ + write(u6,*) Info_Ang(iSet)%R(1,iPoint),Info_Ang(iSet)%R(2,iPoint),Info_Ang(iSet)%R(3,iPoint) + write(u6,*) 'x:',xyz0(1,1),xyz0(1,2) + write(u6,*) 'y:',xyz0(2,1),xyz0(2,2) + write(u6,*) 'z:',xyz0(3,1),xyz0(3,2) + write(u6,*) ' Inside:',x,y,z +# endif + + ! Radial weight + weight = NQ_Data(iNQ)%R_Quad(2,iR) + ! Combine the radial and angular weight + w_g = weight*Info_Ang(iSet)%R(4,iPoint) + if (w_g*Fact >= 1.0e-15_wp) then + number_of_grid_points = number_of_grid_points+1 + Grid(1,number_of_grid_points) = x + Grid(2,number_of_grid_points) = y + Grid(3,number_of_grid_points) = z + ! Compute the partitioning weight + Weights(number_of_grid_points) = w_g*Fact + end if + end if + ! * + !*************************************************************** + ! * + ! The call of Do_Batch is done if the buffer is full: + ! (number_of_grid_points > nGrid) + ! * + !*************************************************************** + ! * + if (number_of_grid_points > mGrid) then + call WarningMessage(2,'Subblock: Buffer overflowed!;Try a larger buffer size!') + call Abend() + end if + if (number_of_grid_points > nGrid) then + + ! Dump grid information to disk + nBatch = nBatch+1 + if (nBatch > size(iBatchInfo,2)) call ExpandBatchInfo() + + ! Generate weights + + mGrid_ = number_of_grid_points-iStrt+1 + call W(Grid(1,iStrt),ilist_p,Weights(iStrt),list_p,nList_p,mGrid_,nRemoved) + number_of_grid_points = number_of_grid_points-nRemoved + + iBatchInfo(1,nBatch) = iDisk_Grid + iBatchInfo(3,nBatch) = iNQ + iBatchInfo(2,nBatch) = number_of_grid_points + + call dDaFile(Lu_Grid,1,Grid,3*number_of_grid_points,iDisk_Grid) + call dDaFile(Lu_Grid,1,Weights,number_of_grid_points,iDisk_Grid) + + ntotgp = ntotgp+number_of_grid_points + !write(u6,*) 'ntotgp=',ntotgp + number_of_grid_points = 0 + iStrt = number_of_grid_points+1 + end if + + end do ! iR, Radial loop + end do ! iPoint + end if + ! * + !********************************************************************* + ! * + iR_Start = iR_End-1 + if ((Angular_Pruning /= On) .or. (iR_End == iEnd_R)) exit +end do +! * +!*********************************************************************** +! * +! Generate weights +! +!write(u6,*) 'number_of_grid_points=',number_of_grid_points +!write(u6,*) 'iStrt=',iStrt +if (number_of_grid_points-iStrt+1 > 0) then + mGrid_ = number_of_grid_points-iStrt+1 + call W(Grid(1,iStrt),ilist_p,Weights(iStrt),list_p,nList_p,mGrid_,nRemoved) + number_of_grid_points = number_of_grid_points-nRemoved +end if +! * +!*********************************************************************** +! * +! Process batch if not processed yet. + +if (Process .and. (number_of_grid_points > 0)) then + + ! Dump grid information to disk + nBatch = nBatch+1 + if (nBatch > size(iBatchInfo,2)) call ExpandBatchInfo() + iBatchInfo(1,nBatch) = iDisk_Grid + iBatchInfo(2,nBatch) = number_of_grid_points + iBatchInfo(3,nBatch) = iNQ + call dDaFile(Lu_Grid,1,Grid,3*number_of_grid_points,iDisk_Grid) + call dDaFile(Lu_Grid,1,Weights,number_of_grid_points,iDisk_Grid) + + ntotgp = ntotgp+number_of_grid_points + !write(u6,*) 'ntotgp=',ntotgp + number_of_grid_points = 0 +end if +! * +!*********************************************************************** +! * + +end subroutine Subblock diff -Nru openmolcas-22.02/src/nq_util/symadp_full.f openmolcas-22.10/src/nq_util/symadp_full.f --- openmolcas-22.02/src/nq_util/symadp_full.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/symadp_full.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,107 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991,2021, Roland Lindh * -************************************************************************ - Subroutine SymAdp_Full(SOIntegrals,nSOInt,list_s,nlist_s,Fact,ndc, - & nD) -************************************************************************ -* * -* Object: to transform the one-electon matrix elements from AO basis * -* to SO basis. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* January 1991 * -************************************************************************ - use iSD_data - use Symmetry_Info, only: nIrrep, iChTbl - use SOAO_Info, only: iAOtSO - use nq_Grid, only: iBfn_Index - use nq_Grid, only: AOIntegrals => Dens_AO - use Basis_Info, only: nBas - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "stdalloc.fh" - Real*8 SOIntegrals(nSOInt,nD), Fact(ndc,ndc) - Integer list_s(2,nlist_s) - Integer nOp(2) - Integer, Parameter:: iTwoj(0:7)=[1,2,4,8,16,32,64,128] - Integer, Allocatable:: BasList(:,:) -* * -************************************************************************ -* * -* Statement functions - iTri(i,j) = max(i,j)*(max(i,j)-3)/2+i+j -* * -************************************************************************ -* * - nBfn=SIZE(iBfn_Index,2) - Call mma_Allocate(BasList,2,nBfn,Label='BasList') - loper=1 - Do j1 = 0, nIrrep-1 - iPnt = iPntSO(j1,j1,lOper,nbas) - - ! Pick up only basis functions which contribute to (j1,j1) - mBfn=0 - Do iBfn = 1, nBfn - ilist_s = iBfn_Index(2,iBfn) - iCmp = iBfn_Index(3,iBfn) - indAO1 = iBfn_Index(6,iBfn) - iSkal = list_s(1,ilist_s) - iAO = iSD( 7,iSkal) - iSO1=iAOtSO(iAO+iCmp,j1) - If (iSO1<0) Cycle - mBfn=mBfn+1 - BasList(1,mBfn)=iBfn - BasList(2,mBfn)=iSO1+IndAO1-1 - End Do - - Do iBfn_ = 1, mBfn - iBfn=BasList(1,iBfn_) - iSO=BasList(2,iBfn_) - - ilist_s = iBfn_Index(2,iBfn) - iSkal = list_s(1,ilist_s) - kDCRE = list_s(2,ilist_s) - mdci = iSD(10,iSkal) - iShell = iSD(11,iSkal) - nOp(1) = NrOpr(kDCRE) - xa = DBLE(iChTbl(j1,nOp(1))) - - Do jBfn_= 1, iBfn_ - jBfn=BasList(1,jBfn_) - jSO=BasList(2,jBfn_) - - jlist_s = iBfn_Index(2,jBfn) - jSkal = list_s(1,jlist_s) - kDCRR = list_s(2,jlist_s) - mdcj = iSD(10,jSkal) - jShell = iSD(11,jSkal) - nOp(2) = NrOpr(kDCRR) - xb = DBLE(iChTbl(j1,nOp(2))) - - xaxb=xa*xb - If (iShell==jShell .and. nOp(1)/=nOp(2) - & .and. iSO==jSO) xaxb=xaxb*Two - - Indij = iPnt + iTri(iSO,jSO) - - SOIntegrals(Indij,:) = SOIntegrals(Indij,:) - & + Fact(mdci,mdcj)*xaxb - & * AOIntegrals(iBfn,jBfn,:) - - End Do ! jBfn - End Do ! iBfn - End Do ! j1 - Call mma_deAllocate(BasList) -* - Return - End diff -Nru openmolcas-22.02/src/nq_util/symadp_full.F90 openmolcas-22.10/src/nq_util/symadp_full.F90 --- openmolcas-22.02/src/nq_util/symadp_full.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/symadp_full.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,107 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991,2021, Roland Lindh * +!*********************************************************************** + +subroutine SymAdp_Full(SOIntegrals,nSOInt,list_s,nlist_s,Fact,ndc,nD) +!*********************************************************************** +! * +! Object: to transform the one-electron matrix elements from AO basis * +! to SO basis. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! January 1991 * +!*********************************************************************** + +use iSD_data, only: iSD +use Basis_Info, only: nBas +use Symmetry_Info, only: iChTbl, nIrrep +use SOAO_Info, only: iAOtSO +use nq_Grid, only: Dens_AO, iBfn_Index +use Index_Functions, only: iTri +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Two +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nSOInt, nlist_s, list_s(2,nlist_s), ndc, nD +real(kind=wp), intent(inout) :: SOIntegrals(nSOInt,nD) +real(kind=wp), intent(in) :: Fact(ndc,ndc) +integer(kind=iwp) :: iAO, iBfn, iBfn_, iCmp, ilist_s, indAO1, Indij, iPnt, iShell, iSkal, iSO, iSO1, j1, jBfn, jBfn_, jlist_s, & + jShell, jSkal, jSO, kDCRE, kDCRR, loper, mBfn, mdci, mdcj, nBfn, nOp(2) +real(kind=wp) :: xa, xaxb, xb +integer(kind=iwp), allocatable :: BasList(:,:) +integer(kind=iwp), external :: iPntSO, NrOpr + +! * +!*********************************************************************** +! * +nBfn = size(iBfn_Index,2) +call mma_Allocate(BasList,2,nBfn,Label='BasList') +loper = 1 +do j1=0,nIrrep-1 + iPnt = iPntSO(j1,j1,lOper,nbas) + + ! Pick up only basis functions which contribute to (j1,j1) + mBfn = 0 + do iBfn=1,nBfn + ilist_s = iBfn_Index(2,iBfn) + iCmp = iBfn_Index(3,iBfn) + indAO1 = iBfn_Index(6,iBfn) + iSkal = list_s(1,ilist_s) + iAO = iSD(7,iSkal) + iSO1 = iAOtSO(iAO+iCmp,j1) + if (iSO1 < 0) cycle + mBfn = mBfn+1 + BasList(1,mBfn) = iBfn + BasList(2,mBfn) = iSO1+IndAO1-1 + end do + + do iBfn_=1,mBfn + iBfn = BasList(1,iBfn_) + iSO = BasList(2,iBfn_) + + ilist_s = iBfn_Index(2,iBfn) + iSkal = list_s(1,ilist_s) + kDCRE = list_s(2,ilist_s) + mdci = iSD(10,iSkal) + iShell = iSD(11,iSkal) + nOp(1) = NrOpr(kDCRE) + xa = real(iChTbl(j1,nOp(1)),kind=wp) + + do jBfn_=1,iBfn_ + jBfn = BasList(1,jBfn_) + jSO = BasList(2,jBfn_) + + jlist_s = iBfn_Index(2,jBfn) + jSkal = list_s(1,jlist_s) + kDCRR = list_s(2,jlist_s) + mdcj = iSD(10,jSkal) + jShell = iSD(11,jSkal) + nOp(2) = NrOpr(kDCRR) + xb = real(iChTbl(j1,nOp(2)),kind=wp) + + xaxb = xa*xb + if ((iShell == jShell) .and. (nOp(1) /= nOp(2)) .and. (iSO == jSO)) xaxb = xaxb*Two + + Indij = iPnt+iTri(iSO,jSO) + + SOIntegrals(Indij,:) = SOIntegrals(Indij,:)+Fact(mdci,mdcj)*xaxb*Dens_AO(iBfn,jBfn,:) + + end do ! jBfn + end do ! iBfn +end do ! j1 +call mma_deAllocate(BasList) + +return + +end subroutine SymAdp_Full diff -Nru openmolcas-22.02/src/nq_util/transactmo2.F90 openmolcas-22.10/src/nq_util/transactmo2.F90 --- openmolcas-22.02/src/nq_util/transactmo2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/transactmo2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,42 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Jie J. Bao * +!*********************************************************************** + +! **************************************************************** +! history: * +! Jie J. Bao, on Dec. 08, 2021, created this file. * +! **************************************************************** +subroutine TransActMO2(MOs,MOas,mGrid) +! Purpose: +! obtaining an active MO array with a structure of MOs in TransActMO +! from an MO array with a structure of that in TransferMO + +use nq_Info, only: iOff_Ash, mIrrep, nAsh, NASHT, nIsh, nOrbt, OffOrb +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: mGrid +real(kind=wp), intent(out) :: MOs(NASHT,mGrid) +real(kind=wp), intent(in) :: MOas(mGrid,nOrbt) +integer(kind=iwp) :: iGrid, iIrrep, IOff1, IOff2 + +do iGrid=1,mGrid + do iIrrep=0,mIrrep-1 + IOff2 = iOff_Ash(iIrrep) + IOff1 = OffOrb(iIrrep)+nIsh(iIrrep) + MOs(IOff2+1:IOff2+nAsh(iIrrep),iGrid) = MOas(iGrid,IOff1+1:IOff1+nAsh(iIrrep)) + end do +end do + +return + +end subroutine TransActMO2 diff -Nru openmolcas-22.02/src/nq_util/transactmo.F90 openmolcas-22.10/src/nq_util/transactmo.F90 --- openmolcas-22.02/src/nq_util/transactmo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/transactmo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,44 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Jie J. Bao * +!*********************************************************************** + +! **************************************************************** +! history: * +! Jie J. Bao, on Dec. 08, 2021, created this file. * +! **************************************************************** +subroutine TransActMO(MOs,TabMO,mAO,mGrid,nMOs) +! Purpose: +! Trasnferring active orbitals to the MOs array. +! It records the MO values on each grid point. +! The first and the second elements are the MO values +! of the first and the second active MO at grid point 1. + +use nq_Info, only: IOff_Ash, IOff_BasAct, mIrrep, nAsh, NASHT +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: mAO, mGrid, nMOs +real(kind=wp), intent(out) :: MOs(NASHT,mGrid) +real(kind=wp), intent(in) :: TabMO(mAO,mGrid,nMOs) +integer(kind=iwp) :: iGrid, iIrrep, IOff1, IOff2 + +do iGrid=1,mGrid + do iIrrep=0,mIrrep-1 + IOff1 = IOff_Ash(iIrrep) + IOff2 = IOff_BasAct(iIrrep) + MOs(IOff1+1:IOff1+nAsh(iIrrep),iGrid) = TabMO(1,iGrid,IOff2+1:IOff2+nAsh(iIrrep)) + end do +end do + +return + +end subroutine TransActMO diff -Nru openmolcas-22.02/src/nq_util/transfermo.F90 openmolcas-22.10/src/nq_util/transfermo.F90 --- openmolcas-22.02/src/nq_util/transfermo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/transfermo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,44 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Jie J. Bao * +!*********************************************************************** + +! **************************************************************** +! history: * +! Jie J. Bao, on Dec. 08, 2021, created this file. * +! **************************************************************** +subroutine TransferMO(MOas,TabMO,mAO,mGrid,nMOs,iAO) +! Purpose: +! Transferring MO information to MOas to be used in dgemm. +! It records the MO values on each grid point, too. +! But the difference from TransActMO is that the first and +! the second elements are the values of the first MO at grid +! point 1 and grid point 2. + +use nq_Info, only: mIrrep, mOrb, nOrbt, OffBasFro +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: mAO, mGrid, nMOs, iAO +real(kind=wp), intent(out) :: MOas(mGrid,nOrbt) +real(kind=wp), intent(in) :: TabMO(mAO,mGrid,nMOs) +integer(kind=iwp) :: iIrrep, IOff1, iOff2 + +IOff2 = 0 +do iIrrep=0,mIrrep-1 + IOff1 = OffBasFro(iIrrep) + MOas(:,IOff2+1:IOff2+mOrb(iIrrep)) = TabMO(iAO,:,IOff1+1:IOff1+mOrb(iIrrep)) + IOff2 = IOff2+mOrb(iIrrep) +end do + +return + +end subroutine TransferMO diff -Nru openmolcas-22.02/src/nq_util/translatedens.f openmolcas-22.10/src/nq_util/translatedens.f --- openmolcas-22.02/src/nq_util/translatedens.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/translatedens.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,353 +0,0 @@ -********************************************************************* -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2021, Jie J. Bao * -************************************************************************ -* **************************************************************** -* history: * -* Jie J. Bao, on Dec. 18, 2021, created this file. * -* **************************************************************** - Subroutine TranslateDens(Pi,dRho_dr,dPi,l_tanhr,nRho,mGrid, - & nPi,ndRho_dr,nEGrad,DoGrad) - use nq_Grid, only: Rho, GradRho, nGradRho - use nq_pdft, only: ThrsRho,ThrsOMR,ThrsFT,ThrsNT,fta,ftb,ftc, - & Pass1,Pass2,Pass3, - & OnePZ,OneMZ,RatioA,ZetaA,RhoAB,dZdR, - * lft,lGGA -******Input - INTEGER nRho,mGrid,nPi,ndRho_dr,nEGrad - Real*8,DIMENSION(nPi,mGrid)::Pi - Real*8,DIMENSION(nPi,nEGrad,mGrid)::dPi - Logical DoGrad,l_tanhr -******Input & Output - Real*8,DIMENSION(ndRho_dr,mGrid,nEGrad)::dRho_dr -******In-subroutine - INTEGER iGrid,iEGrad,ngragri,iOff1,nGRho - Real*8 TempR,RRatio,Diff1,Rd2ZdR2,RdRdRho,RdRdPi,Rd2RdRho2, - & Rd2RdRhodPi,Rd2ZdRdZ,XAdd,YAdd,ZAdd, -C & RatioX,RatioY,RatioZ,GraddZdR, - & GraddZdR, - & GradRatio,GradRatioX,GradRatioY,GradRatioZ, - & ZetaX,ZetaY,ZetaZ,GradZetaX,GradZetaY,GradZetaZ - - Real*8,DIMENSION(mGrid)::dRhodx,dRhody,dRhodz, - & tanhrx,tanhry,tanhrz,ftx23,fty23,ftz23, - & RatioX,RatioY,RatioZ - Real*8,DIMENSION(mGrid*nEGrad)::GradRhoAB,GradRhoX,GradRhoY, - & GradRhoZ,dRatio,dZeta -******PassX -* Pass1. Total density is greater than thresRho -* Pass2. Do translation -* Pass3. Do full translation -* if Pass1 is false, Pass2, 3, are both false. -* if Pass1 is true, Pass2 and 3 cannot both be true (can both be -* false). -********************************************************************* - - nGRho=nGradRho -********************************************************************* -* calculating total density at each grid -********************************************************************* - CALL DCopy_(mGrid,Rho(1,1),nRho,RhoAB,1) - CALL DAXPY_(mGrid,1.0d0,Rho(2,1),nRho,RhoAB,1) - - -********************************************************************* -* calculating x, y, z components of density gradient -********************************************************************* - IF(lGGA) THEN - CALL DCopy_(mGrid,GradRho(1,1),nGRho,dRhodx,1) - CALL DAXPY_(mGrid,1.0d0,GradRho(4,1),nGRho,dRhodx,1) - CALL DCopy_(mGrid,GradRho(2,1),nGRho,dRhody,1) - CALL DAXPY_(mGrid,1.0d0,GradRho(5,1),nGRho,dRhody,1) - CALL DCopy_(mGrid,GradRho(3,1),nGRho,dRhodz,1) - CALL DAXPY_(mGrid,1.0d0,GradRho(6,1),nGRho,dRhodz,1) - END IF - - -********************************************************************* -* Ratio and Zeta at each grid point -********************************************************************* - CALL FZero( ZetaA,mGrid) - CALL FZero(RatioA,mGrid) - CALL FZero(dZdR ,mGrid) - DO iGrid=1,mGrid - Pass1(iGrid)=.false. - Pass2(iGrid)=.false. - Pass3(iGrid)=.false. - END DO - - IF(.not.lft) THEN - DO iGrid=1,mGrid - If(RhoAB(iGrid).ge.ThrsRho) Then - Pass1(iGrid)=.true. - RRatio=4.0d0*Pi(1,iGrid)/(RhoAB(iGrid)**2) - RatioA(iGrid)=Rratio - if(l_tanhr) RRatio=tanh(RRatio) - if((1.0d0-Rratio).gt.ThrsOMR) then - ZetaA(iGrid)=sqrt(1.0d0-Rratio) - Pass2(iGrid)=.true. - dZdR(iGrid)=-0.5d0/ZetaA(iGrid) - end if - End If - END DO - ELSE - DO iGrid=1,mGrid - If(RhoAB(iGrid).ge.ThrsRho) Then - Pass1(iGrid)=.true. - RRatio=4.0d0*Pi(1,iGrid)/(RhoAB(iGrid)**2) - RatioA(iGrid)=Rratio - if(RRatio.lt.ThrsFT) then ! do t-translation - ZetaA(iGrid)=sqrt(1.0d0-Rratio) - Pass2(iGrid)=.true. - dZdR(iGrid)=-0.5d0/ZetaA(iGrid) - else if(RRatio.le.ThrsNT) then ! do ft-translation - Diff1=RRatio-ThrsNT - ZetaA(iGrid)=(fta*Diff1**2+ftb*Diff1+ftc)*Diff1**3 - Pass3(iGrid)=.true. - dZdR(iGrid)= - & (5.0d0*fta*Diff1**2+4.0d0*ftb*Diff1+3.0d0*ftc)*Diff1**2 - end if - End If - END DO - END IF - -********************************************************************* -* (1 + zeta)/2 and (1 - zeta)/2 -********************************************************************* - CALL DCopy_(mGrid,[0.5d0],0,OnePZ,1) - CALL DCopy_(mGrid,[0.5d0],0,OneMZ,1) - CALL DAXPY_(mGrid, 0.5d0,ZetaA,1,OnePZ,1) - CALL DAXPY_(mGrid,-0.5d0,ZetaA,1,OneMZ,1) - - -********************************************************************* -* translating rho_a and rho_b -********************************************************************* - DO iGrid=1,mGrid - IF(Pass1(iGrid)) THEN - Rho(1,iGrid)=OnePZ(iGrid)*RhoAB(iGrid) - Rho(2,iGrid)=OneMZ(iGrid)*RhoAB(iGrid) - END IF - END DO - -********************************************************************* -* translating gradient component of rho_a and rho_b -********************************************************************* - IF(lGGA) THEN - DO iGrid=1,mGrid - If(Pass1(iGrid)) Then - GradRho(1,iGrid)=OnePZ(iGrid)*dRhodX(iGrid) - GradRho(2,iGrid)=OnePZ(iGrid)*dRhodY(iGrid) - GradRho(3,iGrid)=OnePZ(iGrid)*dRhodZ(iGrid) - GradRho(4,iGrid)=OneMZ(iGrid)*dRhodX(iGrid) - GradRho(5,iGrid)=OneMZ(iGrid)*dRhodY(iGrid) - GradRho(6,iGrid)=OneMZ(iGrid)*dRhodZ(iGrid) - End If - END DO - - If(lft) Then - DO iGrid=1,mGrid - if(Pass1(iGrid)) then - RatioX(iGrid)=(4.0d0*Pi(2,iGrid)/RhoAB(iGrid)- - & 2.0d0*RatioA(iGrid)*dRhodX(iGrid))/RhoAB(iGrid) - RatioY(iGrid)=(4.0d0*Pi(3,iGrid)/RhoAB(iGrid)- - & 2.0d0*RatioA(iGrid)*dRhodY(iGrid))/RhoAB(iGrid) - RatioZ(iGrid)=(4.0d0*Pi(4,iGrid)/RhoAB(iGrid)- - & 2.0d0*RatioA(iGrid)*dRhodZ(iGrid))/RhoAB(iGrid) - else - RatioX(iGrid)=0.0d0 - RatioY(iGrid)=0.0d0 - RatioZ(iGrid)=0.0d0 - end if - ftx23(iGrid)=0.5d0*RhoAB(iGrid)*dZdR(iGrid)*RatioX(iGrid) - fty23(iGrid)=0.5d0*RhoAB(iGrid)*dZdR(iGrid)*RatioY(iGrid) - ftz23(iGrid)=0.5d0*RhoAB(iGrid)*dZdR(iGrid)*RatioZ(iGrid) - END DO - CALL DaXpY_(mGrid, 1.0d0,ftx23,1,GradRho(1,1),6) - CALL DaXpY_(mGrid, 1.0d0,fty23,1,GradRho(2,1),6) - CALL DaXpY_(mGrid, 1.0d0,ftz23,1,GradRho(3,1),6) - CALL DaXpY_(mGrid,-1.0d0,ftx23,1,GradRho(4,1),6) - CALL DaXpY_(mGrid,-1.0d0,fty23,1,GradRho(5,1),6) - CALL DaXpY_(mGrid,-1.0d0,ftz23,1,GradRho(6,1),6) - End If - END IF - -********************************************************************* -* Additional terms in the tanh translation -********************************************************************* - IF(l_tanhr) THEN - CALL FZero(tanhrx,mGrid) - CALL FZero(tanhry,mGrid) - CALL FZero(tanhrz,mGrid) - DO iGrid=1,mGrid - If(Pass1(iGrid)) Then - RRatio=RatioA(iGrid) - TempR=4.0d0*Pi(1,iGrid)/RhoAB(iGrid) - TanhrX(iGrid)=(RRatio**2-1.0d0)*(Pi(2,iGrid)- - &(dRhodX(iGrid)*TempR))/(RhoAB(iGrid)*ZetaA(iGrid)) - TanhrY(iGrid)=(RRatio**2-1.0d0)*(Pi(3,iGrid)- - &(dRhodY(iGrid)*TempR))/(RhoAB(iGrid)*ZetaA(iGrid)) - TanhrZ(iGrid)=(RRatio**2-1.0d0)*(Pi(4,iGrid)- - &(dRhodZ(iGrid)*TempR))/(RhoAB(iGrid)*ZetaA(iGrid)) - End If - END DO - CALL DAXPY_(mGrid, 1.0d0,TanhrX,1,GradRho(1,1),nRho) - CALL DAXPY_(mGrid,-1.0d0,TanhrX,1,GradRho(4,1),nRho) - CALL DAXPY_(mGrid, 1.0d0,TanhrY,1,GradRho(2,1),nRho) - CALL DAXPY_(mGrid,-1.0d0,TanhrY,1,GradRho(5,1),nRho) - CALL DAXPY_(mGrid, 1.0d0,TanhrZ,1,GradRho(3,1),nRho) - CALL DAXPY_(mGrid,-1.0d0,TanhrZ,1,GradRho(6,1),nRho) - END IF - - - -********************************************************************* -* calculating terms needed in gradient calculation -********************************************************************* -* if not doing gradient, code ends here - IF(.not.DoGrad) RETURN -********************************************************************* -* calculating density gradient wrt geometrical changes -********************************************************************* - ngragri=mGrid*nEGrad - CALL DCopy_(ngragri,dRho_dr(1,1,1),ndRho_dr,GradRhoAB,1) - CALL DAXPY_(ngragri,1.0d0,dRho_dr(2,1,1),ndRho_dr,GradRhoAB,1) - - IF(lGGA) Then - CALL DCopy_(ngragri,dRho_dr(3,1,1),ndRho_dr,GradRhoX,1) - CALL DAXPY_(ngragri,1.0d0,dRho_dr(6,1,1),ndRho_dr,GradRhoX,1) - CALL DCopy_(ngragri,dRho_dr(4,1,1),ndRho_dr,GradRhoY,1) - CALL DAXPY_(ngragri,1.0d0,dRho_dr(7,1,1),ndRho_dr,GradRhoY,1) - CALL DCopy_(ngragri,dRho_dr(5,1,1),ndRho_dr,GradRhoZ,1) - CALL DAXPY_(ngragri,1.0d0,dRho_dr(8,1,1),ndRho_dr,GradRhoZ,1) - END IF - -********************************************************************* -* dRatio and dZeta at each grid point -********************************************************************* -* Calculate dRatio - CALL Fzero(dRatio,nGraGri) - DO iGrid=1,mGrid - IF(Pass1(iGrid)) THEN - Do iEGrad=1,nEGrad - IOff1=(iEGrad-1)*mGrid - dRatio(IOff1+iGrid)=4.0d0*dPi(1,iEGrad,iGrid)/(RhoAB(iGrid)**2) - & -8.0d0*Pi(1,iGrid)*GradRhoAB(IOff1+iGrid)/(RhoAB(iGrid)**3) - End Do - END IF - END DO -* alculate dZeta - CALL Fzero(dZeta,nGraGri) - DO iGrid=1,mGrid - CALL DAxpy_(nEGrad,dZdR(iGrid),dRatio(iGrid),mGrid, - & dZeta(iGrid),mGrid) - END DO - - DO iEGrad=1,nEGrad - IOff1=(iEGrad-1)*mGrid - Do iGrid=1,mGrid - If(Pass1(iGrid)) Then - dRho_dr(1,iGrid,iEGrad)=OnePZ(iGrid)*GradRhoAB(IOff1+iGrid)+ - & 0.50d0*dZeta(IOFf1+iGrid)*RhoAB(iGrid) - dRho_dr(2,iGrid,iEGrad)=OneMZ(iGrid)*GradRhoAB(IOff1+iGrid)- - & 0.50d0*dZeta(IOFf1+iGrid)*RhoAB(iGrid) - End If - End Do - END DO - - IF(lGGA) THEN - DO iEGrad=1,nEGrad - IOff1=(iEGrad-1)*mGrid - Do iGrid=1,mGrid - If(Pass1(iGrid)) Then - dRho_dr(3,iGrid,iEGrad)=OnePZ(iGrid)*GradRhoX(IOff1+iGrid)+ - & 0.50d0*dZeta(IOFf1+iGrid)*dRhodx(iGrid) - dRho_dr(6,iGrid,iEGrad)=OneMZ(iGrid)*GradRhoX(IOff1+iGrid)- - & 0.50d0*dZeta(IOFf1+iGrid)*dRhodx(iGrid) - dRho_dr(4,iGrid,iEGrad)=OnePZ(iGrid)*GradRhoY(IOff1+iGrid)+ - & 0.50d0*dZeta(IOFf1+iGrid)*dRhody(iGrid) - dRho_dr(7,iGrid,iEGrad)=OneMZ(iGrid)*GradRhoY(IOff1+iGrid)- - & 0.50d0*dZeta(IOFf1+iGrid)*dRhody(iGrid) - dRho_dr(5,iGrid,iEGrad)=OnePZ(iGrid)*GradRhoZ(IOff1+iGrid)+ - & 0.50d0*dZeta(IOFf1+iGrid)*dRhodz(iGrid) - dRho_dr(8,iGrid,iEGrad)=OneMZ(iGrid)*GradRhoZ(IOff1+iGrid)- - & 0.50d0*dZeta(IOFf1+iGrid)*dRhodz(iGrid) - End If - End Do - END DO - If(lft) Then - DO iGrid=1,mGrid - if(.not.Pass1(iGrid)) cycle - if(.not.(Pass2(iGrid).or.Pass3(iGrid))) cycle - ZetaX=dZdR(iGrid)*RatioX(iGrid) - ZetaY=dZdR(iGrid)*RatioY(iGrid) - ZetaZ=dZdR(iGrid)*RatioZ(iGrid) - RdRdRho=-2.0d0*RatioA(iGrid)/RhoAB(iGrid) - RdRdPi=4.0d0/RhoAB(iGrid)**2 - Rd2RdRho2=-3.0d0*RdRdRho/RhoAB(iGrid) - Rd2RdRhodPi=-2.0d0*RdRdPi/RhoAB(iGrid) - Rd2ZdRdZ=0.0d0 - Rd2ZdR2=0.0d0 - if(Pass2(iGrid)) Rd2ZdRdZ=0.5d0/ZetaA(iGrid)**2 - if(Pass3(iGrid)) then - Diff1=RatioA(iGrid)-ThrsNT - Rd2ZdR2=(2.0d1*fta*Diff1**2+1.2d1*ftb*Diff1+6.0d0*ftc)*Diff1 - end if - Do iEGrad=1,nEGrad - IOff1=(iEGrad-1)*mGrid - GradRatio=dRatio(iOff1+iGrid) - GradRatioX=(Rd2RdRho2*dRhodX(iGrid)+Rd2RdRhodPi*Pi(2,iGrid))* - & GradRhoAB(iOff1+iGrid)+ - & Rd2RdRhodPi*dRhodX(iGrid)*dPi(1,iEGrad,iGrid)+ - & RdRdRho*GradRhoX(iOff1+iGrid)+ - & RdRdPi*dPi(2,iEGrad,iGrid) - - GradRatioY=(Rd2RdRho2*dRhodY(iGrid)+Rd2RdRhodPi*Pi(3,iGrid))* - & GradRhoAB(iOff1+iGrid)+ - & Rd2RdRhodPi*dRhodY(iGrid)*dPi(1,iEGrad,iGrid)+ - & RdRdRho*GradRhoY(iOff1+iGrid)+ - & RdRdPi*dPi(3,iEGrad,iGrid) - - GradRatioZ=(Rd2RdRho2*dRhodZ(iGrid)+Rd2RdRhodPi*Pi(4,iGrid))* - & GradRhoAB(iOff1+iGrid)+ - & Rd2RdRhodPi*dRhodZ(iGrid)*dPi(1,iEGrad,iGrid)+ - & RdRdRho*GradRhoZ(iOff1+iGrid)+ - & RdRdPi*dPi(4,iEGrad,iGrid) - GraddZdR=0.0d0 - if(Pass2(iGrid)) then - GraddZdR=Rd2ZdRdZ*dZeta(iOff1+iGrid) - else if(Pass3(iGrid)) then - GraddZdR=Rd2ZdR2*GradRatio - end if - - GradZetax=GraddZdR*RatioX(iGrid)+dZdR(iGrid)*GradRatioX - GradZetaY=GraddZdR*RatioY(iGrid)+dZdR(iGrid)*GradRatioY - GradZetaZ=GraddZdR*RatioZ(iGrid)+dZdR(iGrid)*GradRatioZ - - XAdd=0.5d0*(RhoAB(iGrid)*GradZetaX+ZetaX*GradRhoAB(iOff1+iGrid)) - YAdd=0.5d0*(RhoAB(iGrid)*GradZetaY+ZetaY*GradRhoAB(iOff1+iGrid)) - ZAdd=0.5d0*(RhoAB(iGrid)*GradZetaZ+ZetaZ*GradRhoAB(iOff1+iGrid)) - - dRho_dr(3,iGrid,iEGrad)=dRho_dr(3,iGrid,iEGrad)+XAdd - dRho_dr(6,iGrid,iEGrad)=dRho_dr(6,iGrid,iEGrad)-XAdd - dRho_dr(4,iGrid,iEGrad)=dRho_dr(4,iGrid,iEGrad)+YAdd - dRho_dr(7,iGrid,iEGrad)=dRho_dr(7,iGrid,iEGrad)-YAdd - dRho_dr(5,iGrid,iEGrad)=dRho_dr(5,iGrid,iEGrad)+ZAdd - dRho_dr(8,iGrid,iEGrad)=dRho_dr(8,iGrid,iEGrad)-ZAdd - End Do - END DO - End If - END IF - - RETURN - END SUBROUTINE - -*********************************************************************** diff -Nru openmolcas-22.02/src/nq_util/translatedens.F90 openmolcas-22.10/src/nq_util/translatedens.F90 --- openmolcas-22.02/src/nq_util/translatedens.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/translatedens.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,341 @@ +!******************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Jie J. Bao * +!*********************************************************************** + +! **************************************************************** +! history: * +! Jie J. Bao, on Dec. 18, 2021, created this file. * +! **************************************************************** +subroutine TranslateDens(Pi,dRho_dr,dPi,l_tanhr,mGrid,nPi,ndRho_dr,nEGrad,DoGrad) + +use nq_Grid, only: GradRho, Rho +use nq_pdft, only: dZdR, fta, ftb, ftc, lft, lGGA, OneMZ, OnePZ, Pass1, Pass2, Pass3, RatioA, RhoAB, ThrsFT, ThrsNT, ThrsOMR, & + ThrsRho, ZetaA +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Three, Four, Five, Six, Eight, Twelve, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: mGrid, nPi, ndRho_dr, nEGrad +real(kind=wp), intent(in) :: Pi(nPi,mGrid), dPi(nPi,nEGrad,mGrid) +real(kind=wp), intent(inout) :: dRho_dr(ndRho_dr,mGrid,nEGrad) +logical(kind=iwp), intent(in) :: l_tanhr, DoGrad +integer(kind=iwp) :: iEGrad, iGrid +real(kind=wp) :: Diff1, GraddZdR, GradRatio, GradRatioX, GradRatioY, GradRatioZ, GradZetaX, GradZetaY, GradZetaZ, Rd2RdRho2, & + Rd2RdRhodPi, Rd2ZdR2, Rd2ZdRdZ, RdRdPi, RdRdRho, RRatio, TempR, XAdd, YAdd, ZAdd, ZetaX, ZetaY, ZetaZ +real(kind=wp), allocatable :: dRatio(:,:), dRhodx(:), dRhody(:), dRhodz(:), dZeta(:,:), ftx23(:), fty23(:), ftz23(:), & + GradRhoAB(:,:), GradRhoX(:,:), GradRhoY(:,:), GradRhoZ(:,:), RatioX(:), RatioY(:), RatioZ(:), & + tanhrx(:), tanhry(:), tanhrz(:) +! PassX +! Pass1. Total density is greater than thresRho +! Pass2. Do translation +! Pass3. Do full translation +! if Pass1 is false, Pass2, 3, are both false. +! if Pass1 is true, Pass2 and 3 cannot both be true (can both be +! false). +!*********************************************************************** + +!*********************************************************************** +! calculating total density at each grid +!*********************************************************************** +RhoAB(:) = Rho(1,1:mGrid)+Rho(2,1:mGrid) + +!*********************************************************************** +! calculating x, y, z components of density gradient +!*********************************************************************** +if (lGGA) then + call mma_allocate(dRhodx,mGrid,label='dRhodx') + call mma_allocate(dRhody,mGrid,label='dRhody') + call mma_allocate(dRhodz,mGrid,label='dRhodz') + dRhodx(:) = GradRho(1,1:mGrid)+GradRho(4,1:mGrid) + dRhody(:) = GradRho(2,1:mGrid)+GradRho(5,1:mGrid) + dRhodz(:) = GradRho(3,1:mGrid)+GradRho(6,1:mGrid) +end if + +!*********************************************************************** +! Ratio and Zeta at each grid point +!*********************************************************************** +ZetaA(:) = Zero +RatioA(:) = Zero +dZdR(:) = Zero +do iGrid=1,mGrid + Pass1(iGrid) = .false. + Pass2(iGrid) = .false. + Pass3(iGrid) = .false. +end do + +if (.not. lft) then + do iGrid=1,mGrid + if (RhoAB(iGrid) >= ThrsRho) then + Pass1(iGrid) = .true. + RRatio = Four*Pi(1,iGrid)/(RhoAB(iGrid)**2) + RatioA(iGrid) = Rratio + if (l_tanhr) RRatio = tanh(RRatio) + if ((One-Rratio) > ThrsOMR) then + ZetaA(iGrid) = sqrt(One-Rratio) + Pass2(iGrid) = .true. + dZdR(iGrid) = -Half/ZetaA(iGrid) + end if + end if + end do +else + do iGrid=1,mGrid + if (RhoAB(iGrid) >= ThrsRho) then + Pass1(iGrid) = .true. + RRatio = Four*Pi(1,iGrid)/(RhoAB(iGrid)**2) + RatioA(iGrid) = Rratio + if (RRatio < ThrsFT) then ! do t-translation + ZetaA(iGrid) = sqrt(One-Rratio) + Pass2(iGrid) = .true. + dZdR(iGrid) = -Half/ZetaA(iGrid) + else if (RRatio <= ThrsNT) then ! do ft-translation + Diff1 = RRatio-ThrsNT + ZetaA(iGrid) = (fta*Diff1**2+ftb*Diff1+ftc)*Diff1**3 + Pass3(iGrid) = .true. + dZdR(iGrid) = (Five*fta*Diff1**2+Four*ftb*Diff1+Three*ftc)*Diff1**2 + end if + end if + end do +end if + +!*********************************************************************** +! (1 + zeta)/2 and (1 - zeta)/2 +!*********************************************************************** +OnePZ(:) = Half*(One+ZetaA) +OneMZ(:) = Half*(One-ZetaA) + +!*********************************************************************** +! translating rho_a and rho_b +!*********************************************************************** +do iGrid=1,mGrid + if (Pass1(iGrid)) then + Rho(1,iGrid) = OnePZ(iGrid)*RhoAB(iGrid) + Rho(2,iGrid) = OneMZ(iGrid)*RhoAB(iGrid) + end if +end do + +!*********************************************************************** +! translating gradient component of rho_a and rho_b +!*********************************************************************** +if (lGGA) then + do iGrid=1,mGrid + if (Pass1(iGrid)) then + GradRho(1,iGrid) = OnePZ(iGrid)*dRhodX(iGrid) + GradRho(2,iGrid) = OnePZ(iGrid)*dRhodY(iGrid) + GradRho(3,iGrid) = OnePZ(iGrid)*dRhodZ(iGrid) + GradRho(4,iGrid) = OneMZ(iGrid)*dRhodX(iGrid) + GradRho(5,iGrid) = OneMZ(iGrid)*dRhodY(iGrid) + GradRho(6,iGrid) = OneMZ(iGrid)*dRhodZ(iGrid) + end if + end do + + if (lft) then + call mma_allocate(RatioX,mGrid,label='RatioX') + call mma_allocate(RatioY,mGrid,label='RatioY') + call mma_allocate(RatioZ,mGrid,label='RatioZ') + call mma_allocate(ftx23,mGrid,label='ftx23') + call mma_allocate(fty23,mGrid,label='fty23') + call mma_allocate(ftz23,mGrid,label='ftz23') + do iGrid=1,mGrid + if (Pass1(iGrid)) then + RatioX(iGrid) = (Four*Pi(2,iGrid)/RhoAB(iGrid)-Two*RatioA(iGrid)*dRhodX(iGrid))/RhoAB(iGrid) + RatioY(iGrid) = (Four*Pi(3,iGrid)/RhoAB(iGrid)-Two*RatioA(iGrid)*dRhodY(iGrid))/RhoAB(iGrid) + RatioZ(iGrid) = (Four*Pi(4,iGrid)/RhoAB(iGrid)-Two*RatioA(iGrid)*dRhodZ(iGrid))/RhoAB(iGrid) + else + RatioX(iGrid) = Zero + RatioY(iGrid) = Zero + RatioZ(iGrid) = Zero + end if + ftx23(iGrid) = Half*RhoAB(iGrid)*dZdR(iGrid)*RatioX(iGrid) + fty23(iGrid) = Half*RhoAB(iGrid)*dZdR(iGrid)*RatioY(iGrid) + ftz23(iGrid) = Half*RhoAB(iGrid)*dZdR(iGrid)*RatioZ(iGrid) + end do + GradRho(1,:) = GradRho(1,:)+ftx23 + GradRho(2,:) = GradRho(2,:)+fty23 + GradRho(3,:) = GradRho(3,:)+ftz23 + GradRho(4,:) = GradRho(4,:)-ftx23 + GradRho(5,:) = GradRho(5,:)-fty23 + GradRho(6,:) = GradRho(6,:)-ftz23 + call mma_deallocate(ftx23) + call mma_deallocate(fty23) + call mma_deallocate(ftz23) + end if +end if + +!******************************************************************** +! Additional terms in the tanh translation +!******************************************************************** +if (l_tanhr) then + call mma_allocate(tanhrx,mGrid,label='tanhrx') + call mma_allocate(tanhry,mGrid,label='tanhry') + call mma_allocate(tanhrz,mGrid,label='tanhrz') + tanhrx(:) = Zero + tanhry(:) = Zero + tanhrz(:) = Zero + do iGrid=1,mGrid + if (Pass1(iGrid)) then + RRatio = RatioA(iGrid) + TempR = Four*Pi(1,iGrid)/RhoAB(iGrid) + TanhrX(iGrid) = (RRatio**2-One)*(Pi(2,iGrid)-(dRhodX(iGrid)*TempR))/(RhoAB(iGrid)*ZetaA(iGrid)) + TanhrY(iGrid) = (RRatio**2-One)*(Pi(3,iGrid)-(dRhodY(iGrid)*TempR))/(RhoAB(iGrid)*ZetaA(iGrid)) + TanhrZ(iGrid) = (RRatio**2-One)*(Pi(4,iGrid)-(dRhodZ(iGrid)*TempR))/(RhoAB(iGrid)*ZetaA(iGrid)) + end if + end do + GradRho(1,:) = GradRho(1,:)+TanhrX + GradRho(2,:) = GradRho(2,:)+TanhrY + GradRho(3,:) = GradRho(3,:)+TanhrZ + GradRho(4,:) = GradRho(4,:)-TanhrX + GradRho(5,:) = GradRho(5,:)-TanhrY + GradRho(6,:) = GradRho(6,:)-TanhrZ + call mma_deallocate(tanhrx) + call mma_deallocate(tanhry) + call mma_deallocate(tanhrz) +end if + +!*********************************************************************** +! calculating terms needed in gradient calculation +!*********************************************************************** +! if not doing gradient, code ends here + +if (DoGrad) then + !********************************************************************* + ! calculating density gradient wrt geometrical changes + !********************************************************************* + call mma_allocate(GradRhoAB,mGrid,nEGrad,label='GradRhoAB') + GradRhoAB(:,:) = dRho_dr(1,:,:)+dRho_dr(2,:,:) + + if (lGGA) then + call mma_allocate(GradRhoX,mGrid,nEGrad,label='GradRhoX') + call mma_allocate(GradRhoY,mGrid,nEGrad,label='GradRhoY') + call mma_allocate(GradRhoZ,mGrid,nEGrad,label='GradRhoZ') + GradRhoX(:,:) = dRho_dr(3,:,:)+dRho_dr(6,:,:) + GradRhoY(:,:) = dRho_dr(4,:,:)+dRho_dr(7,:,:) + GradRhoZ(:,:) = dRho_dr(5,:,:)+dRho_dr(8,:,:) + end if + + !*********************************************************************** + ! dRatio and dZeta at each grid point + !*********************************************************************** + call mma_allocate(dRatio,mGrid,nEGrad,label='dRatio') + call mma_allocate(dZeta,mGrid,nEGrad,label='dZeta') + ! Calculate dRatio + dRatio(:,:) = Zero + do iGrid=1,mGrid + if (Pass1(iGrid)) then + do iEGrad=1,nEGrad + dRatio(iGrid,iEGrad) = Four*dPi(1,iEGrad,iGrid)/(RhoAB(iGrid)**2)- & + Eight*Pi(1,iGrid)*GradRhoAB(iGrid,iEGrad)/(RhoAB(iGrid)**3) + end do + end if + end do + ! Calculate dZeta + do iGrid=1,mGrid + dZeta(iGrid,:) = dZdR(iGrid)*dRatio(iGrid,:) + end do + + do iEGrad=1,nEGrad + do iGrid=1,mGrid + if (Pass1(iGrid)) then + dRho_dr(1,iGrid,iEGrad) = OnePZ(iGrid)*GradRhoAB(iGrid,iEGrad)+Half*dZeta(iGrid,iEGrad)*RhoAB(iGrid) + dRho_dr(2,iGrid,iEGrad) = OneMZ(iGrid)*GradRhoAB(iGrid,iEGrad)-Half*dZeta(iGrid,iEGrad)*RhoAB(iGrid) + end if + end do + end do + + if (lGGA) then + do iEGrad=1,nEGrad + do iGrid=1,mGrid + if (Pass1(iGrid)) then + dRho_dr(3,iGrid,iEGrad) = OnePZ(iGrid)*GradRhoX(iGrid,iEGrad)+Half*dZeta(iGrid,iEGrad)*dRhodx(iGrid) + dRho_dr(6,iGrid,iEGrad) = OneMZ(iGrid)*GradRhoX(iGrid,iEGrad)-Half*dZeta(iGrid,iEGrad)*dRhodx(iGrid) + dRho_dr(4,iGrid,iEGrad) = OnePZ(iGrid)*GradRhoY(iGrid,iEGrad)+Half*dZeta(iGrid,iEGrad)*dRhody(iGrid) + dRho_dr(7,iGrid,iEGrad) = OneMZ(iGrid)*GradRhoY(iGrid,iEGrad)-Half*dZeta(iGrid,iEGrad)*dRhody(iGrid) + dRho_dr(5,iGrid,iEGrad) = OnePZ(iGrid)*GradRhoZ(iGrid,iEGrad)+Half*dZeta(iGrid,iEGrad)*dRhodz(iGrid) + dRho_dr(8,iGrid,iEGrad) = OneMZ(iGrid)*GradRhoZ(iGrid,iEGrad)-Half*dZeta(iGrid,iEGrad)*dRhodz(iGrid) + end if + end do + end do + if (lft) then + do iGrid=1,mGrid + if (.not. Pass1(iGrid)) cycle + if (.not. (Pass2(iGrid) .or. Pass3(iGrid))) cycle + ZetaX = dZdR(iGrid)*RatioX(iGrid) + ZetaY = dZdR(iGrid)*RatioY(iGrid) + ZetaZ = dZdR(iGrid)*RatioZ(iGrid) + RdRdRho = -Two*RatioA(iGrid)/RhoAB(iGrid) + RdRdPi = Four/RhoAB(iGrid)**2 + Rd2RdRho2 = -Three*RdRdRho/RhoAB(iGrid) + Rd2RdRhodPi = -Two*RdRdPi/RhoAB(iGrid) + Rd2ZdRdZ = Zero + Rd2ZdR2 = Zero + if (Pass2(iGrid)) Rd2ZdRdZ = Half/ZetaA(iGrid)**2 + if (Pass3(iGrid)) then + Diff1 = RatioA(iGrid)-ThrsNT + Rd2ZdR2 = (20.0_wp*fta*Diff1**2+Twelve*ftb*Diff1+Six*ftc)*Diff1 + end if + do iEGrad=1,nEGrad + GradRatio = dRatio(iGrid,iEGrad) + GradRatioX = (Rd2RdRho2*dRhodX(iGrid)+Rd2RdRhodPi*Pi(2,iGrid))*GradRhoAB(iGrid,iEGrad)+ & + Rd2RdRhodPi*dRhodX(iGrid)*dPi(1,iEGrad,iGrid)+RdRdRho*GradRhoX(iGrid,iEGrad)+RdRdPi*dPi(2,iEGrad,iGrid) + + GradRatioY = (Rd2RdRho2*dRhodY(iGrid)+Rd2RdRhodPi*Pi(3,iGrid))*GradRhoAB(iGrid,iEGrad)+ & + Rd2RdRhodPi*dRhodY(iGrid)*dPi(1,iEGrad,iGrid)+RdRdRho*GradRhoY(iGrid,iEGrad)+RdRdPi*dPi(3,iEGrad,iGrid) + + GradRatioZ = (Rd2RdRho2*dRhodZ(iGrid)+Rd2RdRhodPi*Pi(4,iGrid))*GradRhoAB(iGrid,iEGrad)+ & + Rd2RdRhodPi*dRhodZ(iGrid)*dPi(1,iEGrad,iGrid)+RdRdRho*GradRhoZ(iGrid,iEGrad)+RdRdPi*dPi(4,iEGrad,iGrid) + GraddZdR = Zero + if (Pass2(iGrid)) then + GraddZdR = Rd2ZdRdZ*dZeta(iGrid,iEGrad) + else if (Pass3(iGrid)) then + GraddZdR = Rd2ZdR2*GradRatio + end if + + GradZetax = GraddZdR*RatioX(iGrid)+dZdR(iGrid)*GradRatioX + GradZetaY = GraddZdR*RatioY(iGrid)+dZdR(iGrid)*GradRatioY + GradZetaZ = GraddZdR*RatioZ(iGrid)+dZdR(iGrid)*GradRatioZ + + XAdd = Half*(RhoAB(iGrid)*GradZetaX+ZetaX*GradRhoAB(iGrid,iEGrad)) + YAdd = Half*(RhoAB(iGrid)*GradZetaY+ZetaY*GradRhoAB(iGrid,iEGrad)) + ZAdd = Half*(RhoAB(iGrid)*GradZetaZ+ZetaZ*GradRhoAB(iGrid,iEGrad)) + + dRho_dr(3,iGrid,iEGrad) = dRho_dr(3,iGrid,iEGrad)+XAdd + dRho_dr(6,iGrid,iEGrad) = dRho_dr(6,iGrid,iEGrad)-XAdd + dRho_dr(4,iGrid,iEGrad) = dRho_dr(4,iGrid,iEGrad)+YAdd + dRho_dr(7,iGrid,iEGrad) = dRho_dr(7,iGrid,iEGrad)-YAdd + dRho_dr(5,iGrid,iEGrad) = dRho_dr(5,iGrid,iEGrad)+ZAdd + dRho_dr(8,iGrid,iEGrad) = dRho_dr(8,iGrid,iEGrad)-ZAdd + end do + end do + end if + call mma_deallocate(GradRhoX) + call mma_deallocate(GradRhoY) + call mma_deallocate(GradRhoZ) + end if + call mma_deallocate(GradRhoAB) + call mma_deallocate(dRatio) + call mma_deallocate(dZeta) +end if + +if (lGGA) then + call mma_deallocate(dRhodx) + call mma_deallocate(dRhody) + call mma_deallocate(dRhodz) + if (lft) then + call mma_deallocate(RatioX) + call mma_deallocate(RatioY) + call mma_deallocate(RatioZ) + end if +end if + +return + +end subroutine TranslateDens diff -Nru openmolcas-22.02/src/nq_util/truncate_grid.F90 openmolcas-22.10/src/nq_util/truncate_grid.F90 --- openmolcas-22.02/src/nq_util/truncate_grid.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/truncate_grid.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,32 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Truncate_Grid(R,nR,nR_Eff,Radius_Max) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nR +real(kind=wp), intent(in) :: R(2,nR), Radius_Max +integer(kind=iwp), intent(inout) :: nR_Eff +integer(kind=iwp) :: i, nTmp + +nTmp = nR_Eff +do i=1,nTmp + if (R(1,i) > Radius_Max) then + nR_Eff = i-1 + exit + end if +end do + +return + +end subroutine Truncate_Grid diff -Nru openmolcas-22.02/src/nq_util/unzipd1.F90 openmolcas-22.10/src/nq_util/unzipd1.F90 --- openmolcas-22.02/src/nq_util/unzipd1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/unzipd1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,44 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Jie J. Bao * +!*********************************************************************** + +! **************************************************************** +! history: * +! Jie J. Bao, on Dec. 08, 2021, created this file. * +! **************************************************************** +subroutine UnzipD1(D1Unzip,D1MO,nD1MO) + +use nq_Info, only: NASHT +use Constants, only: Zero, Half +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(out) :: D1Unzip(NASHT,NASHT) +integer(kind=iwp), intent(in) :: nD1MO +real(kind=wp), intent(in) :: D1MO(nD1MO) +integer(kind=iwp) :: iLoc, iv, ix + +D1Unzip(:,:) = Zero +do iv=1,NASHT + do ix=1,iv-1 + iLoc = (iv-1)*iv/2+ix + D1Unzip(ix,iv) = Half*D1MO(iLoc) + D1Unzip(iv,ix) = D1Unzip(ix,iv) + end do + ix = iv + iLoc = (iv+1)*iv/2 + D1Unzip(ix,iv) = Half*D1MO(iLoc) +end do + +return + +end subroutine UnzipD1 diff -Nru openmolcas-22.02/src/nq_util/unzipp2.F90 openmolcas-22.10/src/nq_util/unzipp2.F90 --- openmolcas-22.02/src/nq_util/unzipp2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/unzipp2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,64 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2021, Jie J. Bao * +!*********************************************************************** + +! **************************************************************** +! history: * +! Jie J. Bao, on Dec. 08, 2021, created this file. * +! **************************************************************** +subroutine UnzipP2(P2Unzip,P2MO,nP2Act) + +use nq_Info, only: iOff_Ash, mIrrep, NASH, NASHT +use Index_Functions, only: iTri +use Constants, only: One, Half +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(out) :: P2Unzip(NASHT,NASHT,NASHT,NASHT) +integer(kind=iwp), intent(in) :: nP2Act +real(kind=wp), intent(in) :: P2MO(nP2Act) +integer(kind=iwp) :: I, IAct, iIrrep, IJ, IJKL, J, JAct, jIrrep, K, kAct, kIrrep, KL, L, LAct, lIrrep +real(kind=wp) :: Fact + +if (NASHT == 0) return + +do IIrrep=0,mIrrep-1 + do I=1,NASH(iIrrep) + IAct = iOff_Ash(iIrrep)+I + do jIrrep=0,mIrrep-1 + do J=1,NASH(JIrrep) + JAct = iOff_Ash(JIrrep)+J + IJ = iTri(IAct,JAct) + do kIrrep=0,mIrrep-1 + do K=1,NASH(KIrrep) + KAct = IOff_Ash(KIrrep)+K + do lIrrep=0,mIrrep-1 + do L=1,NASH(lIrrep) + LAct = IOff_Ash(LIrrep)+L + KL = iTri(KAct,LAct) + IJKL = iTri(ij,kl) + Fact = Half + if ((ij >= kl) .and. (kAct == lAct)) Fact = One + if ((kl >= ij) .and. (iAct == jAct)) Fact = One + P2Unzip(LAct,KAct,JAct,IAct) = P2MO(ijkl)*Fact + end do + end do + end do + end do + end do + end do + end do +end do + +return + +end subroutine UnzipP2 diff -Nru openmolcas-22.02/src/nq_util/w.f openmolcas-22.10/src/nq_util/w.f --- openmolcas-22.02/src/nq_util/w.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/nq_util/w.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,114 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine W(R,ilist_p,Weights,list_p,nlist_p,nGrid,nRemoved) - use NQ_Structure, only: NQ_Data - use nq_Info - Implicit Real*8 (a-h,o-z) -#include "real.fh" -#include "itmax.fh" -#include "debug.fh" - Real*8 R(3,nGrid), Weights(nGrid) - Integer list_p(nlist_p) -* * -************************************************************************ -* * - p(x)=(x*0.5D0)*(3.0D0-x**2) -* * -************************************************************************ -* * - P_i = Zero ! dummy initialize -* -* iNQ is the index of the current atomic grid to which these grid -* points belong. -* - iNQ=list_p(ilist_p) -C Write (*,*) 'ilist_p=',ilist_p -C Write (*,*) 'nlist_p=',nlist_p -C Write (*,*) 'nGrid=',nGrid -C Write (*,*) 'iNQ=',iNQ -* * -************************************************************************ -* * - jGrid = 0 - nRemoved = 0 - Do iGrid = 1, nGrid -* Write (*,*) 'iGrid=',iGrid -* * -************************************************************************ -! * -!---- Becke's partitioning -! - Sum_P_k=Zero - Do klist_p = 1, nlist_p - kNQ=list_p(klist_p) - r_k=sqrt((R(1,iGrid)-NQ_Data(kNQ)%Coor(1))**2 - & +(R(2,iGrid)-NQ_Data(kNQ)%Coor(2))**2 - & +(R(3,iGrid)-NQ_Data(kNQ)%Coor(3))**2) - P_k=One - Do llist_p = 1, nlist_p - lNQ=list_p(llist_p) -* - If (kNQ.ne.lNQ) Then -* - r_l=sqrt((R(1,iGrid)-NQ_Data(lNQ)%Coor(1))**2 - & +(R(2,iGrid)-NQ_Data(lNQ)%Coor(2))**2 - & +(R(3,iGrid)-NQ_Data(lNQ)%Coor(3))**2) - R_kl=sqrt((NQ_Data(kNQ)%Coor(1)- - & NQ_Data(lNQ)%Coor(1))**2 - & +(NQ_Data(kNQ)%Coor(2)- - & NQ_Data(lNQ)%Coor(2))**2 - & +(NQ_Data(kNQ)%Coor(3)- - & NQ_Data(lNQ)%Coor(3))**2) - rMU_kl=(r_k-r_l)/R_kl - If (rMU_kl.le.0.5D0) Then - p1=p(rMU_kl) - p2=p(p1) - p3=p(p2) - s=Half*(One-p3) - Else - xdiff=rMU_kl-1.0D0 - xdiff=(-1.5D0-0.5D0*xdiff)*xdiff**2 - xdiff=(-1.5D0-0.5D0*xdiff)*xdiff**2 - p3= ( 1.5D0+0.5D0*xdiff)*xdiff**2 - s=Half*p3 - End If - P_k=P_k*s - End If - End Do -* - If (kNQ.eq.iNQ) P_i=P_k - Sum_P_k = Sum_P_k + P_k - End Do - Fact=Weights(iGrid) - Weights(iGrid)=Fact*P_i/Sum_P_k - If (Weights(iGrid)>=1.0D-14) Then - jGrid = jGrid + 1 - If (jGrid.ne.iGrid) Then - Weights(jGrid)=Weights(iGrid) - R(1,jGrid) =R(1,iGrid) - R(2,jGrid) =R(2,iGrid) - R(3,jGrid) =R(3,iGrid) - End If - Else - nRemoved = nRemoved + 1 - End If -* Write (*,*) 'Fact,P_A,Z,Weights=',Fact,P_i,Sum_P_k, -* & Weights(jGrid) -* * -************************************************************************ -* * - End Do -* Write (6,*) 'nRemoved=',nRemoved -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/nq_util/w.F90 openmolcas-22.10/src/nq_util/w.F90 --- openmolcas-22.02/src/nq_util/w.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/nq_util/w.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,108 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine W(R,ilist_p,Weights,list_p,nlist_p,nGrid,nRemoved) + +use NQ_Structure, only: NQ_Data +use Constants, only: Zero, One, Three, Half, OneHalf +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: ilist_p, nlist_p, list_p(nlist_p), nGrid +real(kind=wp), intent(inout) :: R(3,nGrid), Weights(nGrid) +integer(kind=iwp), intent(out) :: nRemoved +integer(kind=iwp) :: iGrid, iNQ, jGrid, klist_p, kNQ, llist_p, lNQ +real(kind=wp) :: p1, p2, p3, P_i, P_k, r_k, R_kl, r_l, rMU_kl, s, Sum_P_k, xdiff +real(kind=wp), parameter :: Thrs = 1.0e-14_wp + +! * +!*********************************************************************** +! * +P_i = Zero ! dummy initialize + +! iNQ is the index of the current atomic grid to which these grid +! points belong. + +iNQ = list_p(ilist_p) +!write(u6,*) 'ilist_p=',ilist_p +!write(u6,*) 'nlist_p=',nlist_p +!write(u6,*) 'nGrid=',nGrid +!write(u6,*) 'iNQ=',iNQ +! * +!*********************************************************************** +! * +jGrid = 0 +nRemoved = 0 +do iGrid=1,nGrid + !write(u6,*) 'iGrid=',iGrid + ! * + !********************************************************************* + ! * + ! Becke's partitioning + + Sum_P_k = Zero + do klist_p=1,nlist_p + kNQ = list_p(klist_p) + r_k = sqrt((R(1,iGrid)-NQ_Data(kNQ)%Coor(1))**2+(R(2,iGrid)-NQ_Data(kNQ)%Coor(2))**2+(R(3,iGrid)-NQ_Data(kNQ)%Coor(3))**2) + P_k = One + do llist_p=1,nlist_p + lNQ = list_p(llist_p) + + if (kNQ /= lNQ) then + + r_l = sqrt((R(1,iGrid)-NQ_Data(lNQ)%Coor(1))**2+(R(2,iGrid)-NQ_Data(lNQ)%Coor(2))**2+(R(3,iGrid)-NQ_Data(lNQ)%Coor(3))**2) + R_kl = sqrt((NQ_Data(kNQ)%Coor(1)-NQ_Data(lNQ)%Coor(1))**2+(NQ_Data(kNQ)%Coor(2)-NQ_Data(lNQ)%Coor(2))**2+ & + (NQ_Data(kNQ)%Coor(3)-NQ_Data(lNQ)%Coor(3))**2) + rMU_kl = (r_k-r_l)/R_kl + if (rMU_kl <= Half) then + p1 = (rMU_kl*Half)*(Three-rMU_kl**2) + p2 = (p1*Half)*(Three-p1**2) + p3 = (p2*Half)*(Three-p2**2) + s = Half*(One-p3) + else + xdiff = rMU_kl-One + xdiff = (-OneHalf-Half*xdiff)*xdiff**2 + xdiff = (-OneHalf-Half*xdiff)*xdiff**2 + p3 = (OneHalf+Half*xdiff)*xdiff**2 + s = Half*p3 + end if + P_k = P_k*s + end if + end do + + if (kNQ == iNQ) P_i = P_k + Sum_P_k = Sum_P_k+P_k + end do + Weights(iGrid) = Weights(iGrid)*P_i/Sum_P_k + if (Weights(iGrid) >= Thrs) then + jGrid = jGrid+1 + if (jGrid /= iGrid) then + Weights(jGrid) = Weights(iGrid) + R(1,jGrid) = R(1,iGrid) + R(2,jGrid) = R(2,iGrid) + R(3,jGrid) = R(3,iGrid) + end if + else + nRemoved = nRemoved+1 + end if + !write(u6,*) 'P_A,Z,Weights=',P_i,Sum_P_k,Weights(jGrid) + ! * + !********************************************************************* + ! * +end do +!write(u6,*) 'nRemoved=',nRemoved +! * +!*********************************************************************** +! * + +return + +end subroutine W diff -Nru openmolcas-22.02/src/numerical_gradient/numerical_gradient.F90 openmolcas-22.10/src/numerical_gradient/numerical_gradient.F90 --- openmolcas-22.02/src/numerical_gradient/numerical_gradient.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/numerical_gradient/numerical_gradient.F90 2022-10-10 14:22:40.000000000 +0000 @@ -316,7 +316,7 @@ iChxyz = iChAtm(Coor(:,i)) call Stblz(iChxyz,nStab,jStab,MaxDCR,iCoSet) - call IZero(iDispXYZ,3) + iDispXYZ(:) = 0 do j=0,nStab-1 if (btest(jStab(j),0)) then iDispXYZ(1) = iDispXYZ(1)-1 @@ -337,7 +337,7 @@ ! If this is a MM atom, do not make displacements - if (DoTinker .and. (IsMM(i) == 1)) call IZero(iDispXYZ,3) + if (DoTinker .and. (IsMM(i) == 1)) iDispXYZ(:) = 0 DispX = iDispXYZ(1) /= 0 DispY = iDispXYZ(2) /= 0 DispZ = iDispXYZ(3) /= 0 diff -Nru openmolcas-22.02/src/oneint_util/ampint.f openmolcas-22.10/src/oneint_util/ampint.f --- openmolcas-22.02/src/oneint_util/ampint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/ampint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,147 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1996, Per Ake Malmqvist * -* 1996, Roland Lindh * -************************************************************************ - SubRoutine AMPInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for computing matrix elements of the * -* six hermitized products of two angular momentum ops * -* * -* Author: Per-AAke Malmqvist, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* November '96 * -* After pattern of other SEWARD soubroutines by R. Lindh. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - -#include "int_interface.fh" - -* Local Variables - Real*8 TC(3) - Integer iStabO(0:7), iDCRT(0:7) -* -* Statement function for Cartesian index -* - nElem(ixyz) = ((ixyz+1)*(ixyz+2))/2 -* - iRout = 220 - iPrint = nPrint(iRout) -* - nip = 1 - ipB = nip - nip = nip + nZeta - ipTpp = nip - nip = nip + nZeta*nElem(la)*nElem(lb+2)*6 - ipTp = nip - nip = nip + nZeta*nElem(la)*nElem(lb+1)*3 - ipT = nip - nip = nip + nZeta*nElem(la)*nElem(lb )*6 - ipTm = 1 - ipTmm = 1 - if(lb.gt.0) then - ipTm = nip - nip = nip + nZeta*nElem(la)*nElem(lb-1)*3 - if(lb.gt.1) then - ipTmm = nip - nip = nip + nZeta*nElem(la)*nElem(lb-2)*6 - end if - end if - ipRes=nip - nip = nip + nZeta*nElem(la)*nElem(lb)*nComp - If (nip-1.gt.nZeta*nArr) Then - Call WarningMessage(2,' AMPInt: nip-1.gt.nZeta*nArr') - call Abend() - End If - ipArr = nip - mArr = (nArr*nZeta - (nip-1))/nZeta - - call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) - - ipOff = ipB - Do iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ipOff),nAlpha) - ipOff = ipOff + 1 - End Do - - llOper = lOper(1) - Do iComp = 2, nComp - iDum=lOper(iComp) - llOper = iOr(llOper,iDum) - End Do - -C Compute stabilizer, and then the double coset representation: - Call SOS(iStabO,nStabO,llOper) - Call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) - -C Loop over the cosets of the stabilizer group: - Do lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT), Ccoor, TC) - - -C Generate the quadrupole integral tables: - iComp=6 - iOrdOp = 2 - nHer = (la + (lb+2) + 2 + 2) / 2 - Call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P, - & Array(ipTpp),nZeta,iComp,la,lb+2,A,RB,nHer, - & Array(ipArr),mArr,TC,iOrdOp) - nHer = (la + lb + 2 + 2) / 2 - Call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P, - & Array(ipT ),nZeta,iComp,la,lb ,A,RB,nHer, - & Array(ipArr),mArr,TC,iOrdOp) - if(lb.ge.2) then - nHer = (la + (lb-2) + 2 + 2) / 2 - Call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P, - & Array(ipTmm),nZeta,iComp,la,lb-2,A,RB,nHer, - & Array(ipArr),mArr,TC,iOrdOp) - end if -C Generate the dipole integral tables: - iComp=3 - iOrdOp = 1 - nHer = (la + (lb+1) + 1 + 2) / 2 - Call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P, - & Array(ipTp ),nZeta,iComp,la,lb+1,A,RB,nHer, - & Array(ipArr),mArr,TC,iOrdOp) - if(lb.ge.1) then - nHer = (la + (lb-1) + 1 + 2) / 2 - Call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P, - & Array(ipTm ),nZeta,iComp,la,lb-1,A,RB,nHer, - & Array(ipArr),mArr,TC,iOrdOp) - end if - - if(iprint.gt.49) write(6,*)' AMPInt calling AMPr.' - Call AMPr(Array(ipB),nZeta,Array(ipRes),la,lb,Array(ipTpp), - & Array(ipTp),Array(ipT),Array(ipTm),Array(ipTmm)) - -C Symmetry adaption: - if(iprint.gt.49) write(6,*)' AMPInt calling SymAdO' - nOp = NrOpr(iDCRT(lDCRT)) - Call SymAdO(Array(ipRes),nZeta,la,lb,nComp,Final,nIC, - & nOp,lOper,iChO,One) - if(iprint.gt.49) write(6,*)' Back to AMPInt.' - End Do - - if(iprint.gt.49) write(6,*)' Leaving AMPInt.' - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(nOrdOp) - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/ampint.F90 openmolcas-22.10/src/oneint_util/ampint.F90 --- openmolcas-22.02/src/oneint_util/ampint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/ampint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,135 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1996, Per Ake Malmqvist * +! 1996, Roland Lindh * +!*********************************************************************** + +subroutine AMPInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for computing matrix elements of the * +! six hermitized products of two angular momentum ops * +! * +! Author: Per-AAke Malmqvist, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! November '96 * +! After pattern of other SEWARD soubroutines by R. Lindh. * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "print.fh" +integer(kind=iwp) :: iBeta, iComp, iDCRT(0:7), iDum, iOrdOp, ipArr, ipB, ipOff, ipRes, iPrint, ipT, ipTm, ipTmm, ipTp, ipTpp, & + iRout, iStabO(0:7), lDCRT, llOper, LmbdT, mArr, nDCRT, nip, nOp, nStabO +real(kind=wp) :: TC(3) +integer(kind=iwp), external :: NrOpr + +#include "macros.fh" +unused_var(nOrdOp) +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 220 +iPrint = nPrint(iRout) + +nip = 1 +ipB = nip +nip = nip+nZeta +ipTpp = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb+2)*6 +ipTp = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb+1)*3 +ipT = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb)*6 +ipTm = 1 +ipTmm = 1 +if (lb > 0) then + ipTm = nip + nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb-1)*3 + if (lb > 1) then + ipTmm = nip + nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb-2)*6 + end if +end if +ipRes = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb)*nComp +if (nip-1 > nZeta*nArr) then + call WarningMessage(2,' AMPInt: nip-1 > nZeta*nArr') + call Abend() +end if +ipArr = nip +mArr = (nArr*nZeta-(nip-1))/nZeta + +rFinal(:,:,:,:) = Zero + +ipOff = ipB-1 +do iBeta=1,nBeta + Array(ipOff+1:ipOff+nAlpha) = Beta(iBeta) + ipOff = ipOff+nAlpha +end do + +llOper = lOper(1) +do iComp=2,nComp + iDum = lOper(iComp) + llOper = ior(llOper,iDum) +end do + +! Compute stabilizer, and then the double coset representation: +call SOS(iStabO,nStabO,llOper) +call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) + +! Loop over the cosets of the stabilizer group: +do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),Ccoor,TC) + + ! Generate the quadrupole integral tables: + iComp = 6 + iOrdOp = 2 + nHer = (la+(lb+2)+2+2)/2 + call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipTpp),nZeta,iComp,la,lb+2,A,RB,nHer,Array(ipArr),mArr,TC,iOrdOp) + nHer = (la+lb+2+2)/2 + call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipT),nZeta,iComp,la,lb,A,RB,nHer,Array(ipArr),mArr,TC,iOrdOp) + if (lb >= 2) then + nHer = (la+(lb-2)+2+2)/2 + call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipTmm),nZeta,iComp,la,lb-2,A,RB,nHer,Array(ipArr),mArr,TC,iOrdOp) + end if + ! Generate the dipole integral tables: + iComp = 3 + iOrdOp = 1 + nHer = (la+(lb+1)+1+2)/2 + call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipTp),nZeta,iComp,la,lb+1,A,RB,nHer,Array(ipArr),mArr,TC,iOrdOp) + if (lb >= 1) then + nHer = (la+(lb-1)+1+2)/2 + call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipTm),nZeta,iComp,la,lb-1,A,RB,nHer,Array(ipArr),mArr,TC,iOrdOp) + end if + + if (iprint > 49) write(u6,*) ' AMPInt calling AMPr.' + call AMPr(Array(ipB),nZeta,Array(ipRes),la,lb,Array(ipTpp),Array(ipTp),Array(ipT),Array(ipTm),Array(ipTmm)) + + ! Symmetry adaption: + if (iprint > 49) write(u6,*) ' AMPInt calling SymAdO' + nOp = NrOpr(iDCRT(lDCRT)) + call SymAdO(Array(ipRes),nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,One) + if (iprint > 49) write(u6,*) ' Back to AMPInt.' +end do + +if (iprint > 49) write(u6,*) ' Leaving AMPInt.' + +return + +end subroutine AMPInt diff -Nru openmolcas-22.02/src/oneint_util/ampmem.f openmolcas-22.10/src/oneint_util/ampmem.f --- openmolcas-22.02/src/oneint_util/ampmem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/ampmem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,53 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1996, Per Ake Malmqvist * -* 1996, Roland Lindh * -************************************************************************ - Subroutine AMPMem( -#define _CALLING_ -#include "mem_interface.fh" - &) -#include "mem_interface.fh" -C Statement function for Cartesian index - nElem(ixyz) = ((ixyz+1)*(ixyz+2))/2 - -C Mem1: Workspace for MltPrm. -C Mem2: Tables Tpp,Tp,T0,Tm, and Tmm. -C Mem3: Result from AMPr. - Mem1=0 - Call MltMmP(nOrder,Mem,la,lb+2,2) - Mem1=max(Mem1,Mem) - Mem2=6*nElem(la)*nElem(lb+2) - nHer = nOrder - Call MltMmP(nOrder,Mem,la,lb+1,1) - Mem1=max(Mem1,Mem) - Mem2=Mem2+3*nElem(la)*nElem(lb+1) - Call MltMmP(nOrder,Mem,la,lb ,2) - Mem1=max(Mem1,Mem) - Mem2=Mem2+6*nElem(la)*nElem(lb) - If (lb.ge.1) Then - Call MltMmP(nOrder,Mem,la,lb-1,1) - Mem1=max(Mem1,Mem) - Mem2=Mem2+3*nElem(la)*nElem(lb-1) - If (lb.ge.2) Then - Call MltMmP(nOrder,Mem,la,lb-2,2) - Mem1=max(Mem1,Mem) - Mem2=Mem2+6*nElem(la)*nElem(lb-2) - End If - End If - Mem3=6*nElem(la)*nElem(lb) - - Mem=Mem1+Mem2+Mem3+1 - - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(lr) - End diff -Nru openmolcas-22.02/src/oneint_util/ampmem.F90 openmolcas-22.10/src/oneint_util/ampmem.F90 --- openmolcas-22.02/src/oneint_util/ampmem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/ampmem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,60 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1996, Per Ake Malmqvist * +! 1996, Roland Lindh * +!*********************************************************************** + +subroutine AMPMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: Mem1, Mem2, Mem3, nOrder + +#include "macros.fh" +unused_var(lr) + +! Mem1: Workspace for MltPrm. +! Mem2: Tables Tpp,Tp,T0,Tm, and Tmm. +! Mem3: Result from AMPr. +Mem1 = 0 +call MltMmP(nOrder,Mem,la,lb+2,2) +Mem1 = max(Mem1,Mem) +Mem2 = 6*nTri_Elem1(la)*nTri_Elem1(lb+2) +nHer = nOrder +call MltMmP(nOrder,Mem,la,lb+1,1) +Mem1 = max(Mem1,Mem) +Mem2 = Mem2+3*nTri_Elem1(la)*nTri_Elem1(lb+1) +call MltMmP(nOrder,Mem,la,lb,2) +Mem1 = max(Mem1,Mem) +Mem2 = Mem2+6*nTri_Elem1(la)*nTri_Elem1(lb) +if (lb >= 1) then + call MltMmP(nOrder,Mem,la,lb-1,1) + Mem1 = max(Mem1,Mem) + Mem2 = Mem2+3*nTri_Elem1(la)*nTri_Elem1(lb-1) + if (lb >= 2) then + call MltMmP(nOrder,Mem,la,lb-2,2) + Mem1 = max(Mem1,Mem) + Mem2 = Mem2+6*nTri_Elem1(la)*nTri_Elem1(lb-2) + end if +end if +Mem3 = 6*nTri_Elem1(la)*nTri_Elem1(lb) + +Mem = Mem1+Mem2+Mem3+1 + +return + +end subroutine AMPMem diff -Nru openmolcas-22.02/src/oneint_util/ampr.f openmolcas-22.10/src/oneint_util/ampr.f --- openmolcas-22.02/src/oneint_util/ampr.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/ampr.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,377 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1996, Per Ake Malmqvist * -************************************************************************ - SubRoutine AMPr(Beta,nZeta,Rslt,la,lb,Tabpp,Tabp,Tab0, - & Tabm,Tabmm) -************************************************************************ -* * -* Object: Compute matrix elements of hermitized products of angular * -* moment operators, using elementary overlaps, dipole, and * -* quadrupole integrals. * -* * -* Author: Per-AAke Malmqvist, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* November '96 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Rslt (nZeta,((la+1)*(la+2))/2,((lb+1)*(lb+2))/2,6), - & Tabpp (nZeta,((la+1)*(la+2))/2,((lb+3)*(lb+4))/2,6), - & Tabp (nZeta,((la+1)*(la+2))/2,((lb+2)*(lb+3))/2,3), - & Tab0 (nZeta,((la+1)*(la+2))/2,((lb+1)*(lb+2))/2,6), - & Tabm (nZeta,((la+1)*(la+2))/2,( lb *(lb+1))/2,3), - & Tabmm (nZeta,((la+1)*(la+2))/2,((lb-1)* lb )/2,6), - & Beta(nZeta) - Character*80 Label - data kx, ky, kz / 1, 2, 3 / - data kxx,kxy,kxz,kyy,kyz,kzz / 1,2,3,4,5,6 / - data kyx,kzx,kzy/ 2,3,5 / -* -* Statement function for cartesian index - Ind(j,k)=((j+k)*(j+k+1))/2+k+1 - nElem(ix) = (ix+1)*(ix+2)/2 -* - iRout = 221 - iPrint = nPrint(iRout) -* - If (iPrint.ge.99) Then - Write (6,*) ' In AMPr la,lb=',la,lb - Call RecPrt('Beta',' ',Beta,nZeta,1) - Do ia = 1, nElem(la) - Do ib = 1, nElem(lb+2) - Write (Label,'(A,I2,A,I2,A)') - & ' Tabpp(',ia,',',ib,'xx)' - Call RecPrt(Label,' ',Tabpp(1,ia,ib,1),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tabpp(',ia,',',ib,'xy)' - Call RecPrt(Label,' ',Tabpp(1,ia,ib,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tabpp(',ia,',',ib,'xz)' - Call RecPrt(Label,' ',Tabpp(1,ia,ib,3),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tabpp(',ia,',',ib,'yy)' - Call RecPrt(Label,' ',Tabpp(1,ia,ib,4),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tabpp(',ia,',',ib,'yz)' - Call RecPrt(Label,' ',Tabpp(1,ia,ib,5),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tabpp(',ia,',',ib,'zz)' - Call RecPrt(Label,' ',Tabpp(1,ia,ib,6),nZeta,1) - End Do - End Do - Do ia = 1, nElem(la) - Do ib = 1, nElem(lb+1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tabp(',ia,',',ib,'x)' - Call RecPrt(Label,' ',Tabp(1,ia,ib,1),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tabp(',ia,',',ib,'y)' - Call RecPrt(Label,' ',Tabp(1,ia,ib,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tabp(',ia,',',ib,'z)' - Call RecPrt(Label,' ',Tabp(1,ia,ib,3),nZeta,1) - End Do - End Do - Do ia = 1, nElem(la) - Do ib = 1, nElem(lb) - Write (Label,'(A,I2,A,I2,A)') - & ' Tab0',ia,',',ib,'xx)' - Call RecPrt(Label,' ',Tab0(1,ia,ib,1),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tab0',ia,',',ib,'xy)' - Call RecPrt(Label,' ',Tab0(1,ia,ib,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tab0',ia,',',ib,'xz)' - Call RecPrt(Label,' ',Tab0(1,ia,ib,3),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tab0',ia,',',ib,'yy)' - Call RecPrt(Label,' ',Tab0(1,ia,ib,4),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tab0',ia,',',ib,'yz)' - Call RecPrt(Label,' ',Tab0(1,ia,ib,5),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tab0',ia,',',ib,'zz)' - Call RecPrt(Label,' ',Tab0(1,ia,ib,6),nZeta,1) - End Do - End Do - If (lb.gt.0) Then - Do ia = 1, nElem(la) - Do ib = 1, nElem(lb-1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tabm(',ia,',',ib,'x)' - Call RecPrt(Label,' ',Tabm(1,ia,ib,1),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tabm(',ia,',',ib,'y)' - Call RecPrt(Label,' ',Tabm(1,ia,ib,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tabm(',ia,',',ib,'z)' - Call RecPrt(Label,' ',Tabm(1,ia,ib,3),nZeta,1) - End Do - End Do - End If - If (lb.gt.1) Then - Do ia = 1, nElem(la) - Do ib = 1, nElem(lb-2) - Write (Label,'(A,I2,A,I2,A)') - & ' Tabmm(',ia,',',ib,'xx)' - Call RecPrt(Label,' ',Tabmm(1,ia,ib,1),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tabmm(',ia,',',ib,'xy)' - Call RecPrt(Label,' ',Tabmm(1,ia,ib,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tabmm(',ia,',',ib,'xz)' - Call RecPrt(Label,' ',Tabmm(1,ia,ib,3),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tabmm(',ia,',',ib,'yy)' - Call RecPrt(Label,' ',Tabmm(1,ia,ib,4),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tabmm(',ia,',',ib,'yz)' - Call RecPrt(Label,' ',Tabmm(1,ia,ib,5),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Tabmm(',ia,',',ib,'zz)' - Call RecPrt(Label,' ',Tabmm(1,ia,ib,6),nZeta,1) - End Do - End Do - End If - End If -* - Do 100 ixa = la, 0, -1 - Do 101 iya = la-ixa, 0, -1 - iza = la-ixa-iya - ipa = Ind(iya,iza) -* - Do 200 ixb = lb, 0, -1 - Do 201 iyb = lb-ixb, 0, -1 - izb = lb-ixb-iyb - ipb = Ind(iyb,izb) - ix=ixb - iy=iyb - iz=izb -* - Do 300 iZeta = 1, nZeta - B=Beta(iZeta) - B2=B**2 - Bx2=Dble(2*ix)*B - By2=Dble(2*iy)*B - Bz2=Dble(2*iz)*B -C First compute Lx**2, Ly**2, and Lz**2: -C------------------ - Term1= 2d0*Bz2*Tab0 (iZeta,ipa,Ind(iy ,iz ),kyy) - & -4d0*B2*Tabpp(iZeta,ipa,Ind(iy ,iz+2),kyy) - & +2d0*B*Tab0 (iZeta,ipa,Ind(iy ,iz ),kyy) - Term2= -2d0*By2*Tab0 (iZeta,ipa,Ind(iy-1,iz+1),kyz) - & -2d0*Bz2*Tab0 (iZeta,ipa,Ind(iy+1,iz-1),kyz) - & +8d0*B2*Tabpp(iZeta,ipa,Ind(iy+1,iz+1),kyz) - Term3= 2d0*By2*Tab0 (iZeta,ipa,Ind(iy ,iz ),kzz) - & -4d0*B2*Tabpp(iZeta,ipa,Ind(iy+2,iz ),kzz) - & +2d0*B*Tab0 (iZeta,ipa,Ind(iy ,iz ),kzz) - Term4= -2d0*B*Tabp (iZeta,ipa,Ind(iy+1,iz ),ky ) - & -2d0*B*Tabp (iZeta,ipa,Ind(iy ,iz+1),kz ) - if(lb.ge.1) then - Term4=Term4 +Dble(iy)*Tabm (iZeta,ipa,Ind(iy-1,iz ),ky ) - & +Dble(iz)*Tabm (iZeta,ipa,Ind(iy ,iz-1),kz ) - if(lb.ge.2) then - Term1=Term1 - & -Dble(iz*(iz-1))*Tabmm(iZeta,ipa,Ind(iy ,iz-2),kyy) - Term2=Term2 - & +Dble(2*iy*iz)*Tabmm(iZeta,ipa,Ind(iy-1,iz-1),kyz) - Term3=Term3 - & -Dble(iy*(iy-1))*Tabmm(iZeta,ipa,Ind(iy-2,iz ),kzz) - end if - end if - Rslt(iZeta,ipa,ipb,kxx) = Term1+Term2+Term3+Term4 -C------------------ - Term1= 2d0*Bx2*Tab0 (iZeta,ipa,Ind(iy,iz ),kzz) - & -4d0*B2*Tabpp(iZeta,ipa,Ind(iy,iz ),kzz) - & +2d0*B*Tab0 (iZeta,ipa,Ind(iy,iz ),kzz) - Term2= -2d0*Bz2*Tab0 (iZeta,ipa,Ind(iy,iz-1),kzx) - & -2d0*Bx2*Tab0 (iZeta,ipa,Ind(iy,iz+1),kzx) - & +8d0*B2*Tabpp(iZeta,ipa,Ind(iy,iz+1),kzx) - Term3= 2d0*Bz2*Tab0 (iZeta,ipa,Ind(iy,iz ),kxx) - & -4d0*B2*Tabpp(iZeta,ipa,Ind(iy,iz+2),kxx) - & +2d0*B*Tab0 (iZeta,ipa,Ind(iy,iz ),kxx) - Term4= -2d0*B*Tabp (iZeta,ipa,Ind(iy,iz+1),kz ) - & -2d0*B*Tabp (iZeta,ipa,Ind(iy,iz ),kx ) - if(lb.ge.1) then - Term4=Term4 +Dble(iz)*Tabm (iZeta,ipa,Ind(iy,iz-1),kz ) - & +Dble(ix)*Tabm (iZeta,ipa,Ind(iy,iz ),kx ) - if(lb.ge.2) then - Term1= - & Term1-Dble(ix*(ix-1))*Tabmm(iZeta,ipa,Ind(iy,iz ),kzz) - Term2= - & Term2+ Dble(2*iz*ix)*Tabmm(iZeta,ipa,Ind(iy,iz-1),kzx) - Term3= - & Term3-Dble(iz*(iz-1))*Tabmm(iZeta,ipa,Ind(iy,iz-2),kxx) - end if - end if - Rslt(iZeta,ipa,ipb,kyy) = Term1+Term2+Term3+Term4 -C------------------ - Term1= 2d0*By2*Tab0 (iZeta,ipa,Ind(iy ,iz),kxx) - & -4d0*B2*Tabpp(iZeta,ipa,Ind(iy+2,iz),kxx) - & +2d0*B*Tab0 (iZeta,ipa,Ind(iy ,iz),kxx) - Term2= -2d0*Bx2*Tab0 (iZeta,ipa,Ind(iy+1,iz),kxy) - & -2d0*By2*Tab0 (iZeta,ipa,Ind(iy-1,iz),kxy) - & +8d0*B2*Tabpp(iZeta,ipa,Ind(iy+1,iz),kxy) - Term3= 2d0*Bx2*Tab0 (iZeta,ipa,Ind(iy ,iz),kyy) - & -4d0*B2*Tabpp(iZeta,ipa,Ind(iy ,iz),kyy) - & +2d0*B*Tab0 (iZeta,ipa,Ind(iy ,iz),kyy) - Term4= -2d0*B*Tabp (iZeta,ipa,Ind(iy ,iz),kx ) - & -2d0*B*Tabp (iZeta,ipa,Ind(iy+1,iz),ky ) - if(lb.ge.1) then - Term4=Term4+ Dble(ix)*Tabm (iZeta,ipa,Ind(iy ,iz),kx ) - & +Dble(iy)*Tabm (iZeta,ipa,Ind(iy-1,iz),ky ) - if(lb.ge.2) then - Term1= - & Term1-Dble(iy*(iy-1))*Tabmm(iZeta,ipa,Ind(iy-2,iz),kxx) - Term2= - & Term2+ Dble(2*ix*iy)*Tabmm(iZeta,ipa,Ind(iy-1,iz),kxy) - Term3= - & Term3-Dble(ix*(ix-1))*Tabmm(iZeta,ipa,Ind(iy ,iz),kyy) - end if - end if - Rslt(iZeta,ipa,ipb,kzz) = Term1+Term2+Term3+Term4 -C------------------ -C Compute (Lx*Ly+Ly*Lx)/2, etc cyclical. -C With Term5, (Lx*Ly) obtains. With Term6, (Ly*Lx). -C We want the hermitian average. -C------------------ (Lx,Ly) - Term1= Bx2*Tab0 (iZeta,ipa,Ind(iy ,iz+1),kyz) - & +Bz2*Tab0 (iZeta,ipa,Ind(iy ,iz-1),kyz) - & -4d0*B2*Tabpp(iZeta,ipa,Ind(iy ,iz+1),kyz) - Term2= -2d0*Bz2*Tab0 (iZeta,ipa,Ind(iy ,iz ),kxy) - & +4d0*B2*Tabpp(iZeta,ipa,Ind(iy ,iz+2),kxy) - & -2d0*B*Tab0 (iZeta,ipa,Ind(iy ,iz ),kxy) - Term3= -Bx2*Tab0 (iZeta,ipa,Ind(iy+1,iz ),kzz) - & -By2*Tab0 (iZeta,ipa,Ind(iy-1,iz ),kzz) - & +4d0*B2*Tabpp(iZeta,ipa,Ind(iy+1,iz ),kzz) - Term4= By2*Tab0 (iZeta,ipa,Ind(iy-1,iz+1),kxz) - & +Bz2*Tab0 (iZeta,ipa,Ind(iy+1,iz-1),kxz) - & -4d0*B2*Tabpp(iZeta,ipa,Ind(iy+1,iz+1),kxz) - Term5= +2d0*B*Tabp (iZeta,ipa,Ind(iy ,iz ),ky ) - Term6= +2d0*B*Tabp (iZeta,ipa,Ind(iy+1,iz ),kx ) - if(lb.ge.1) then - Term5=Term5-Dble(ix)*Tabm (iZeta,ipa,Ind(iy ,iz ),ky ) - Term6=Term6-Dble(iy)*Tabm (iZeta,ipa,Ind(iy-1,iz ),kx ) - if(lb.ge.2) then - Term1=Term1 - & -Dble(ix*iz)*Tabmm(iZeta,ipa,Ind(iy ,iz-1),kyz) - Term2=Term2 - & +Dble(iz*(iz-1))*Tabmm(iZeta,ipa,Ind(iy ,iz-2),kxy) - Term3=Term3 - & +Dble(ix*iy)*Tabmm(iZeta,ipa,Ind(iy-1,iz ),kzz) - Term4=Term4 - & -Dble(iy*iz)*Tabmm(iZeta,ipa,Ind(iy-1,iz-1),kxz) - end if - end if - Rslt(iZeta,ipa,ipb,kxy) = Term1+Term2+Term3+Term4 - & +0.5D0*(Term5+Term6) -C------------------ (Ly,Lz) - Term1= By2*Tab0 (iZeta,ipa,Ind(iy-1,iz ),kzx) - & +Bx2*Tab0 (iZeta,ipa,Ind(iy+1,iz ),kzx) - & -4d0*B2*Tabpp(iZeta,ipa,Ind(iy+1,iz ),kzx) - Term2= -2d0*Bx2*Tab0 (iZeta,ipa,Ind(iy ,iz ),kyz) - & +4d0*B2*Tabpp(iZeta,ipa,Ind(iy ,iz ),kyz) - & -2d0*B*Tab0 (iZeta,ipa,Ind(iy ,iz ),kyz) - Term3= -By2*Tab0 (iZeta,ipa,Ind(iy-1,iz+1),kxx) - & -Bz2*Tab0 (iZeta,ipa,Ind(iy+1,iz-1),kxx) - & +4d0*B2*Tabpp(iZeta,ipa,Ind(iy+1,iz+1),kxx) - Term4= Bz2*Tab0 (iZeta,ipa,Ind(iy ,iz-1),kyx) - & +Bx2*Tab0 (iZeta,ipa,Ind(iy ,iz+1),kyx) - & -4d0*B2*Tabpp(iZeta,ipa,Ind(iy ,iz+1),kyx) - Term5= +2d0*B*Tabp (iZeta,ipa,Ind(iy+1,iz ),kz ) - Term6= +2d0*B*Tabp (iZeta,ipa,Ind(iy ,iz+1),ky ) - if(lb.ge.1) then - Term5=Term5-Dble(iy)*Tabm (iZeta,ipa,Ind(iy-1,iz ),kz ) - Term6=Term6-Dble(iz)*Tabm (iZeta,ipa,Ind(iy ,iz-1),ky ) - if(lb.ge.2) then - Term1= - & Term1 -Dble(iy*ix)*Tabmm(iZeta,ipa,Ind(iy-1,iz ),kzx) - Term2=Term2 - & +Dble(ix*(ix-1))*Tabmm(iZeta,ipa,Ind(iy ,iz ),kyz) - Term3= - & Term3 +Dble(iy*iz)*Tabmm(iZeta,ipa,Ind(iy-1,iz-1),kxx) - Term4= - & Term4 -Dble(iz*ix)*Tabmm(iZeta,ipa,Ind(iy ,iz-1),kyx) - end if - end if - Rslt(iZeta,ipa,ipb,kyz) = Term1+Term2+Term3+Term4 - & +0.5D0*(Term5+Term6) -C------------------ (Lx,Lz) - Term1= Bz2*Tab0 (iZeta,ipa,Ind(iy+1,iz-1),kxy) - & +By2*Tab0 (iZeta,ipa,Ind(iy-1,iz+1),kxy) - & -4d0*B2*Tabpp(iZeta,ipa,Ind(iy+1,iz+1),kxy) - Term2= -2d0*By2*Tab0 (iZeta,ipa,Ind(iy ,iz ),kzx) - & +4d0*B2*Tabpp(iZeta,ipa,Ind(iy+2,iz ),kzx) - & -2d0*B*Tab0 (iZeta,ipa,Ind(iy ,iz ),kzx) - Term3= -Bz2*Tab0 (iZeta,ipa,Ind(iy ,iz-1),kyy) - & -Bx2*Tab0 (iZeta,ipa,Ind(iy ,iz+1),kyy) - & +4d0*B2*Tabpp(iZeta,ipa,Ind(iy ,iz+1),kyy) - Term4= Bx2*Tab0 (iZeta,ipa,Ind(iy+1,iz ),kzy) - & +By2*Tab0 (iZeta,ipa,Ind(iy-1,iz ),kzy) - & -4d0*B2*Tabpp(iZeta,ipa,Ind(iy+1,iz ),kzy) - Term5= +2d0*B*Tabp (iZeta,ipa,Ind(iy ,iz+1),kx ) - Term6= +2d0*B*Tabp (iZeta,ipa,Ind(iy ,iz ),kz ) - if(lb.ge.1) then - Term5=Term5 -Dble(iz)*Tabm (iZeta,ipa,Ind(iy ,iz-1),kx ) - Term6=Term6 -Dble(ix)*Tabm (iZeta,ipa,Ind(iy ,iz ),kz ) - if(lb.ge.2) then - Term1=Term1 - & -Dble(iz*iy)*Tabmm(iZeta,ipa,Ind(iy-1,iz-1),kxy) - Term2=Term2 - & +Dble(iy*(iy-1))*Tabmm(iZeta,ipa,Ind(iy-2,iz ),kzx) - Term3=Term3 - & +Dble(iz*ix)*Tabmm(iZeta,ipa,Ind(iy ,iz-1),kyy) - Term4=Term4 - & -Dble(ix*iy)*Tabmm(iZeta,ipa,Ind(iy-1,iz ),kzy) - end if - end if - Rslt(iZeta,ipa,ipb,kxz) = Term1+Term2+Term3+Term4 - & +0.5D0*(Term5+Term6) - - 300 Continue -* - 201 Continue - 200 Continue -* - 101 Continue - 100 Continue -* - If (iPrint.ge.49) Then - Write (6,*) ' In AMPr la,lb=',la,lb - Do iElem = 1, nElem(la) - Do jElem = 1, nElem(lb) - Write (Label,'(A,I2,A,I2,A)') - & ' Rslt (',iElem,',',jElem,',xx) ' - Call RecPrt(Label,' ',Rslt(1,iElem,jElem,kxx),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Rslt (',iElem,',',jElem,',xy) ' - Call RecPrt(Label,' ',Rslt(1,iElem,jElem,kxy),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Rslt (',iElem,',',jElem,',xz) ' - Call RecPrt(Label,' ',Rslt(1,iElem,jElem,kxz),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Rslt (',iElem,',',jElem,',yy) ' - Call RecPrt(Label,' ',Rslt(1,iElem,jElem,kyy),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Rslt (',iElem,',',jElem,',yz) ' - Call RecPrt(Label,' ',Rslt(1,iElem,jElem,kyz),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Rslt (',iElem,',',jElem,',zz) ' - Call RecPrt(Label,' ',Rslt(1,iElem,jElem,kzz),nZeta,1) - End Do - End Do - Write (6,*) ' Leaving AMPr.' - End If -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/ampr.F90 openmolcas-22.10/src/oneint_util/ampr.F90 --- openmolcas-22.02/src/oneint_util/ampr.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/ampr.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,301 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1996, Per Ake Malmqvist * +!*********************************************************************** + +subroutine AMPr(Beta,nZeta,Rslt,la,lb,Tabpp,Tabp,Tab0,Tabm,Tabmm) +!*********************************************************************** +! * +! Object: Compute matrix elements of hermitized products of angular * +! moment operators, using elementary overlaps, dipole, and * +! quadrupole integrals. * +! * +! Author: Per-AAke Malmqvist, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! November '96 * +!*********************************************************************** + +use Index_Functions, only: C_Ind3, nTri_Elem1 +use Constants, only: Two, Four, Eight, Half +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb +real(kind=wp), intent(in) :: Beta(nZeta), Tabpp(nZeta,nTri_Elem1(la),nTri_Elem1(lb+2),6), & + Tabp(nZeta,nTri_Elem1(la),nTri_Elem1(lb+1),3), Tab0(nZeta,nTri_Elem1(la),nTri_Elem1(lb),6), & + Tabm(nZeta,nTri_Elem1(la),nTri_Elem1(lb-1),3), Tabmm(nZeta,nTri_Elem1(la),nTri_Elem1(lb-2),6) +real(kind=wp), intent(out) :: Rslt(nZeta,nTri_Elem1(la),nTri_Elem1(lb),6) +#include "print.fh" +integer(kind=iwp) :: ia, ib, iElem, ipa, ipb, iPrint, iRout, ix, ixa, ixb, iy, iya, iyb, iz, iza, izb, iZeta, jElem +real(kind=wp) :: B, B2, Bx2, By2, Bz2, Term1, Term2, Term3, Term4, Term5, Term6 +character(len=80) :: Label +integer(kind=iwp), parameter :: kx = 1, ky = 2, kz = 3, & + kxx = 1, kxy = 2, kxz = 3, & + kyx = 2, kyy = 4, kyz = 5, & + kzx = 3, kzy = 5, kzz = 6 + +iRout = 221 +iPrint = nPrint(iRout) + +if (iPrint >= 99) then + write(u6,*) ' In AMPr la,lb=',la,lb + call RecPrt('Beta',' ',Beta,nZeta,1) + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb+2) + write(Label,'(A,I2,A,I2,A)') ' Tabpp(',ia,',',ib,'xx)' + call RecPrt(Label,' ',Tabpp(:,ia,ib,1),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Tabpp(',ia,',',ib,'xy)' + call RecPrt(Label,' ',Tabpp(:,ia,ib,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Tabpp(',ia,',',ib,'xz)' + call RecPrt(Label,' ',Tabpp(:,ia,ib,3),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Tabpp(',ia,',',ib,'yy)' + call RecPrt(Label,' ',Tabpp(:,ia,ib,4),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Tabpp(',ia,',',ib,'yz)' + call RecPrt(Label,' ',Tabpp(:,ia,ib,5),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Tabpp(',ia,',',ib,'zz)' + call RecPrt(Label,' ',Tabpp(:,ia,ib,6),nZeta,1) + end do + end do + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb+1) + write(Label,'(A,I2,A,I2,A)') ' Tabp(',ia,',',ib,'x)' + call RecPrt(Label,' ',Tabp(:,ia,ib,1),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Tabp(',ia,',',ib,'y)' + call RecPrt(Label,' ',Tabp(:,ia,ib,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Tabp(',ia,',',ib,'z)' + call RecPrt(Label,' ',Tabp(:,ia,ib,3),nZeta,1) + end do + end do + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb) + write(Label,'(A,I2,A,I2,A)') ' Tab0',ia,',',ib,'xx)' + call RecPrt(Label,' ',Tab0(:,ia,ib,1),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Tab0',ia,',',ib,'xy)' + call RecPrt(Label,' ',Tab0(:,ia,ib,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Tab0',ia,',',ib,'xz)' + call RecPrt(Label,' ',Tab0(:,ia,ib,3),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Tab0',ia,',',ib,'yy)' + call RecPrt(Label,' ',Tab0(:,ia,ib,4),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Tab0',ia,',',ib,'yz)' + call RecPrt(Label,' ',Tab0(:,ia,ib,5),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Tab0',ia,',',ib,'zz)' + call RecPrt(Label,' ',Tab0(:,ia,ib,6),nZeta,1) + end do + end do + if (lb > 0) then + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb-1) + write(Label,'(A,I2,A,I2,A)') ' Tabm(',ia,',',ib,'x)' + call RecPrt(Label,' ',Tabm(:,ia,ib,1),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Tabm(',ia,',',ib,'y)' + call RecPrt(Label,' ',Tabm(:,ia,ib,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Tabm(',ia,',',ib,'z)' + call RecPrt(Label,' ',Tabm(:,ia,ib,3),nZeta,1) + end do + end do + end if + if (lb > 1) then + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb-2) + write(Label,'(A,I2,A,I2,A)') ' Tabmm(',ia,',',ib,'xx)' + call RecPrt(Label,' ',Tabmm(:,ia,ib,1),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Tabmm(',ia,',',ib,'xy)' + call RecPrt(Label,' ',Tabmm(:,ia,ib,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Tabmm(',ia,',',ib,'xz)' + call RecPrt(Label,' ',Tabmm(:,ia,ib,3),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Tabmm(',ia,',',ib,'yy)' + call RecPrt(Label,' ',Tabmm(:,ia,ib,4),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Tabmm(',ia,',',ib,'yz)' + call RecPrt(Label,' ',Tabmm(:,ia,ib,5),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Tabmm(',ia,',',ib,'zz)' + call RecPrt(Label,' ',Tabmm(:,ia,ib,6),nZeta,1) + end do + end do + end if +end if + +do ixa=la,0,-1 + do iya=la-ixa,0,-1 + iza = la-ixa-iya + ipa = C_Ind3(ixa,iya,iza) + + do ixb=lb,0,-1 + do iyb=lb-ixb,0,-1 + izb = lb-ixb-iyb + ipb = C_Ind3(ixb,iyb,izb) + ix = ixb + iy = iyb + iz = izb + + do iZeta=1,nZeta + B = Beta(iZeta) + B2 = B**2 + Bx2 = real(2*ix,kind=wp)*B + By2 = real(2*iy,kind=wp)*B + Bz2 = real(2*iz,kind=wp)*B + ! First compute Lx**2, Ly**2, and Lz**2: + !------------------ + Term1 = Two*Bz2*Tab0(iZeta,ipa,C_Ind3(ix,iy,iz),kyy)-Four*B2*Tabpp(iZeta,ipa,C_Ind3(ix,iy,iz+2),kyy)+ & + Two*B*Tab0(iZeta,ipa,C_Ind3(ix,iy,iz),kyy) + Term2 = -Two*By2*Tab0(iZeta,ipa,C_Ind3(ix,iy-1,iz+1),kyz)-Two*Bz2*Tab0(iZeta,ipa,C_Ind3(ix,iy+1,iz-1),kyz)+ & + Eight*B2*Tabpp(iZeta,ipa,C_Ind3(ix,iy+1,iz+1),kyz) + Term3 = Two*By2*Tab0(iZeta,ipa,C_Ind3(ix,iy,iz),kzz)-Four*B2*Tabpp(iZeta,ipa,C_Ind3(ix,iy+2,iz),kzz)+ & + Two*B*Tab0(iZeta,ipa,C_Ind3(ix,iy,iz),kzz) + Term4 = -Two*B*Tabp(iZeta,ipa,C_Ind3(ix,iy+1,iz),ky)-Two*B*Tabp(iZeta,ipa,C_Ind3(ix,iy,iz+1),kz) + if (lb >= 1) then + Term4 = Term4+real(iy,kind=wp)*Tabm(iZeta,ipa,C_Ind3(ix,iy-1,iz),ky)+ & + real(iz,kind=wp)*Tabm(iZeta,ipa,C_Ind3(ix,iy,iz-1),kz) + if (lb >= 2) then + Term1 = Term1-real(iz*(iz-1),kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix,iy,iz-2),kyy) + Term2 = Term2+real(2*iy*iz,kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix,iy-1,iz-1),kyz) + Term3 = Term3-real(iy*(iy-1),kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix,iy-2,iz),kzz) + end if + end if + Rslt(iZeta,ipa,ipb,kxx) = Term1+Term2+Term3+Term4 + !------------------ + Term1 = Two*Bx2*Tab0(iZeta,ipa,C_Ind3(ix,iy,iz),kzz)-Four*B2*Tabpp(iZeta,ipa,C_Ind3(ix+2,iy,iz),kzz)+ & + Two*B*Tab0(iZeta,ipa,C_Ind3(ix,iy,iz),kzz) + Term2 = -Two*Bz2*Tab0(iZeta,ipa,C_Ind3(ix+1,iy,iz-1),kzx)-Two*Bx2*Tab0(iZeta,ipa,C_Ind3(ix-1,iy,iz+1),kzx)+ & + Eight*B2*Tabpp(iZeta,ipa,C_Ind3(ix+1,iy,iz+1),kzx) + Term3 = Two*Bz2*Tab0(iZeta,ipa,C_Ind3(ix,iy,iz),kxx)-Four*B2*Tabpp(iZeta,ipa,C_Ind3(ix,iy,iz+2),kxx)+ & + Two*B*Tab0(iZeta,ipa,C_Ind3(ix,iy,iz),kxx) + Term4 = -Two*B*Tabp(iZeta,ipa,C_Ind3(ix,iy,iz+1),kz)-Two*B*Tabp(iZeta,ipa,C_Ind3(ix+1,iy,iz),kx) + if (lb >= 1) then + Term4 = Term4+real(iz,kind=wp)*Tabm(iZeta,ipa,C_Ind3(ix,iy,iz-1),kz)+ & + real(ix,kind=wp)*Tabm(iZeta,ipa,C_Ind3(ix-1,iy,iz),kx) + if (lb >= 2) then + Term1 = Term1-real(ix*(ix-1),kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix-2,iy,iz),kzz) + Term2 = Term2+real(2*iz*ix,kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix-1,iy,iz-1),kzx) + Term3 = Term3-real(iz*(iz-1),kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix,iy,iz-2),kxx) + end if + end if + Rslt(iZeta,ipa,ipb,kyy) = Term1+Term2+Term3+Term4 + !------------------ + Term1 = Two*By2*Tab0(iZeta,ipa,C_Ind3(ix,iy,iz),kxx)-Four*B2*Tabpp(iZeta,ipa,C_Ind3(ix,iy+2,iz),kxx)+ & + Two*B*Tab0(iZeta,ipa,C_Ind3(ix,iy,iz),kxx) + Term2 = -Two*Bx2*Tab0(iZeta,ipa,C_Ind3(ix-1,iy+1,iz),kxy)-Two*By2*Tab0(iZeta,ipa,C_Ind3(ix+1,iy-1,iz),kxy)+ & + Eight*B2*Tabpp(iZeta,ipa,C_Ind3(ix+1,iy+1,iz),kxy) + Term3 = Two*Bx2*Tab0(iZeta,ipa,C_Ind3(ix,iy,iz),kyy)-Four*B2*Tabpp(iZeta,ipa,C_Ind3(ix+2,iy,iz),kyy)+ & + Two*B*Tab0(iZeta,ipa,C_Ind3(ix,iy,iz),kyy) + Term4 = -Two*B*Tabp(iZeta,ipa,C_Ind3(ix+1,iy,iz),kx)-Two*B*Tabp(iZeta,ipa,C_Ind3(ix,iy+1,iz),ky) + if (lb >= 1) then + Term4 = Term4+real(ix,kind=wp)*Tabm(iZeta,ipa,C_Ind3(ix-1,iy,iz),kx)+ & + real(iy,kind=wp)*Tabm(iZeta,ipa,C_Ind3(ix,iy-1,iz),ky) + if (lb >= 2) then + Term1 = Term1-real(iy*(iy-1),kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix,iy-2,iz),kxx) + Term2 = Term2+real(2*ix*iy,kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix-1,iy-1,iz),kxy) + Term3 = Term3-real(ix*(ix-1),kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix-2,iy,iz),kyy) + end if + end if + Rslt(iZeta,ipa,ipb,kzz) = Term1+Term2+Term3+Term4 + !------------------ + ! Compute (Lx*Ly+Ly*Lx)/2, etc cyclical. + ! With Term5, (Lx*Ly) obtains. With Term6, (Ly*Lx). + ! We want the hermitian average. + !------------------ (Lx,Ly) + Term1 = Bx2*Tab0(iZeta,ipa,C_Ind3(ix-1,iy,iz+1),kyz)+Bz2*Tab0(iZeta,ipa,C_Ind3(ix+1,iy,iz-1),kyz)- & + Four*B2*Tabpp(iZeta,ipa,C_Ind3(ix+1,iy,iz+1),kyz) + Term2 = -Two*Bz2*Tab0(iZeta,ipa,C_Ind3(ix,iy,iz),kxy)+Four*B2*Tabpp(iZeta,ipa,C_Ind3(ix,iy,iz+2),kxy)- & + Two*B*Tab0(iZeta,ipa,C_Ind3(ix,iy,iz),kxy) + Term3 = -Bx2*Tab0(iZeta,ipa,C_Ind3(ix-1,iy+1,iz),kzz)-By2*Tab0(iZeta,ipa,C_Ind3(ix+1,iy-1,iz),kzz)+ & + Four*B2*Tabpp(iZeta,ipa,C_Ind3(ix+1,iy+1,iz),kzz) + Term4 = By2*Tab0(iZeta,ipa,C_Ind3(ix,iy-1,iz+1),kxz)+Bz2*Tab0(iZeta,ipa,C_Ind3(ix,iy+1,iz-1),kxz)- & + Four*B2*Tabpp(iZeta,ipa,C_Ind3(ix,iy+1,iz+1),kxz) + Term5 = Two*B*Tabp(iZeta,ipa,C_Ind3(ix+1,iy,iz),ky) + Term6 = Two*B*Tabp(iZeta,ipa,C_Ind3(ix,iy+1,iz),kx) + if (lb >= 1) then + Term5 = Term5-real(ix,kind=wp)*Tabm(iZeta,ipa,C_Ind3(ix-1,iy,iz),ky) + Term6 = Term6-real(iy,kind=wp)*Tabm(iZeta,ipa,C_Ind3(ix,iy-1,iz),kx) + if (lb >= 2) then + Term1 = Term1-real(ix*iz,kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix-1,iy,iz-1),kyz) + Term2 = Term2+real(iz*(iz-1),kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix,iy,iz-2),kxy) + Term3 = Term3+real(ix*iy,kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix-1,iy-1,iz),kzz) + Term4 = Term4-real(iy*iz,kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix,iy-1,iz-1),kxz) + end if + end if + Rslt(iZeta,ipa,ipb,kxy) = Term1+Term2+Term3+Term4+Half*(Term5+Term6) + ! (Ly,Lz) + Term1 = By2*Tab0(iZeta,ipa,C_Ind3(ix+1,iy-1,iz),kzx)+Bx2*Tab0(iZeta,ipa,C_Ind3(ix-1,iy+1,iz),kzx)- & + Four*B2*Tabpp(iZeta,ipa,C_Ind3(ix+1,iy+1,iz),kzx) + Term2 = -Two*Bx2*Tab0(iZeta,ipa,C_Ind3(ix,iy,iz),kyz)+Four*B2*Tabpp(iZeta,ipa,C_Ind3(ix+2,iy,iz),kyz)- & + Two*B*Tab0(iZeta,ipa,C_Ind3(ix,iy,iz),kyz) + Term3 = -By2*Tab0(iZeta,ipa,C_Ind3(ix,iy-1,iz+1),kxx)-Bz2*Tab0(iZeta,ipa,C_Ind3(ix,iy+1,iz-1),kxx)+ & + Four*B2*Tabpp(iZeta,ipa,C_Ind3(ix,iy+1,iz+1),kxx) + Term4 = Bz2*Tab0(iZeta,ipa,C_Ind3(ix+1,iy,iz-1),kyx)+Bx2*Tab0(iZeta,ipa,C_Ind3(ix-1,iy,iz+1),kyx)- & + Four*B2*Tabpp(iZeta,ipa,C_Ind3(ix+1,iy,iz+1),kyx) + Term5 = Two*B*Tabp(iZeta,ipa,C_Ind3(ix,iy+1,iz),kz) + Term6 = Two*B*Tabp(iZeta,ipa,C_Ind3(ix,iy,iz+1),ky) + if (lb >= 1) then + Term5 = Term5-real(iy,kind=wp)*Tabm(iZeta,ipa,C_Ind3(ix,iy-1,iz),kz) + Term6 = Term6-real(iz,kind=wp)*Tabm(iZeta,ipa,C_Ind3(ix,iy,iz-1),ky) + if (lb >= 2) then + Term1 = Term1-real(iy*ix,kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix-1,iy-1,iz),kzx) + Term2 = Term2+real(ix*(ix-1),kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix-2,iy,iz),kyz) + Term3 = Term3+real(iy*iz,kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix,iy-1,iz-1),kxx) + Term4 = Term4-real(iz*ix,kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix-1,iy,iz-1),kyx) + end if + end if + Rslt(iZeta,ipa,ipb,kyz) = Term1+Term2+Term3+Term4+Half*(Term5+Term6) + ! (Lx,Lz) + Term1 = Bz2*Tab0(iZeta,ipa,C_Ind3(ix,iy+1,iz-1),kxy)+By2*Tab0(iZeta,ipa,C_Ind3(ix,iy-1,iz+1),kxy)- & + Four*B2*Tabpp(iZeta,ipa,C_Ind3(ix,iy+1,iz+1),kxy) + Term2 = -Two*By2*Tab0(iZeta,ipa,C_Ind3(ix,iy,iz),kzx)+Four*B2*Tabpp(iZeta,ipa,C_Ind3(ix,iy+2,iz),kzx)- & + Two*B*Tab0(iZeta,ipa,C_Ind3(ix,iy,iz),kzx) + Term3 = -Bz2*Tab0(iZeta,ipa,C_Ind3(ix+1,iy,iz-1),kyy)-Bx2*Tab0(iZeta,ipa,C_Ind3(ix-1,iy,iz+1),kyy)+ & + Four*B2*Tabpp(iZeta,ipa,C_Ind3(ix+1,iy,iz+1),kyy) + Term4 = Bx2*Tab0(iZeta,ipa,C_Ind3(ix-1,iy+1,iz),kzy)+By2*Tab0(iZeta,ipa,C_Ind3(ix+1,iy-1,iz),kzy)- & + Four*B2*Tabpp(iZeta,ipa,C_Ind3(ix+1,iy+1,iz),kzy) + Term5 = Two*B*Tabp(iZeta,ipa,C_Ind3(ix,iy,iz+1),kx) + Term6 = Two*B*Tabp(iZeta,ipa,C_Ind3(ix+1,iy,iz),kz) + if (lb >= 1) then + Term5 = Term5-real(iz,kind=wp)*Tabm(iZeta,ipa,C_Ind3(ix,iy,iz-1),kx) + Term6 = Term6-real(ix,kind=wp)*Tabm(iZeta,ipa,C_Ind3(ix-1,iy,iz),kz) + if (lb >= 2) then + Term1 = Term1-real(iz*iy,kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix,iy-1,iz-1),kxy) + Term2 = Term2+real(iy*(iy-1),kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix,iy-2,iz),kzx) + Term3 = Term3+real(iz*ix,kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix-1,iy,iz-1),kyy) + Term4 = Term4-real(ix*iy,kind=wp)*Tabmm(iZeta,ipa,C_Ind3(ix-1,iy-1,iz),kzy) + end if + end if + Rslt(iZeta,ipa,ipb,kxz) = Term1+Term2+Term3+Term4+Half*(Term5+Term6) + + end do + + end do + end do + + end do +end do + +if (iPrint >= 49) then + write(u6,*) ' In AMPr la,lb=',la,lb + do iElem=1,nTri_Elem1(la) + do jElem=1,nTri_Elem1(lb) + write(Label,'(A,I2,A,I2,A)') ' Rslt (',iElem,',',jElem,',xx) ' + call RecPrt(Label,' ',Rslt(:,iElem,jElem,kxx),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Rslt (',iElem,',',jElem,',xy) ' + call RecPrt(Label,' ',Rslt(:,iElem,jElem,kxy),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Rslt (',iElem,',',jElem,',xz) ' + call RecPrt(Label,' ',Rslt(:,iElem,jElem,kxz),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Rslt (',iElem,',',jElem,',yy) ' + call RecPrt(Label,' ',Rslt(:,iElem,jElem,kyy),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Rslt (',iElem,',',jElem,',yz) ' + call RecPrt(Label,' ',Rslt(:,iElem,jElem,kyz),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Rslt (',iElem,',',jElem,',zz) ' + call RecPrt(Label,' ',Rslt(:,iElem,jElem,kzz),nZeta,1) + end do + end do + write(u6,*) ' Leaving AMPr.' +end if + +return + +end subroutine AMPr diff -Nru openmolcas-22.02/src/oneint_util/assemble_dTdmu.f openmolcas-22.10/src/oneint_util/assemble_dTdmu.f --- openmolcas-22.02/src/oneint_util/assemble_dTdmu.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/assemble_dTdmu.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,134 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine Assemble_dTdmu(nZeta,Final,la,lb,Elalbp,Elalbm,Beta) -************************************************************************ -* * -* Object: to assemble the diamagnetic shielding integrals from * -* electric field integrals. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* February '91 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Final (nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,3), - & Elalbp(nZeta,(la+1)*(la+2)/2,(lb+2)*(lb+3)/2,3), - & Elalbm(nZeta,(la+1)*(la+2)/2,(lb )*(lb+1)/2,3), - & Beta(nZeta) - Character*80 Label -* -* Statement function for cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 - nElem(ix) = (ix+1)*(ix+2)/2 -* - iRout = 231 - iPrint = nPrint(iRout) -* -* Fact = -1.D6 * One2C2 - If (iPrint.ge.99) Then - Write (6,*) ' In Assemble_dTdmu la,lb=',la,lb - Do ia = 1, nElem(la) - Do ib = 1, nElem(lb+1) - Write (Label,'(A,I2,A,I2,A)') - & ' Elalbp(',ia,',',ib,',x)' - Call RecPrt(Label,' ',Elalbp(1,ia,ib,1),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Elalbp(',ia,',',ib,',y)' - Call RecPrt(Label,' ',Elalbp(1,ia,ib,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Elalbp(',ia,',',ib,',z)' - Call RecPrt(Label,' ',Elalbp(1,ia,ib,3),nZeta,1) - End Do - End Do - Do ia = 1, nElem(la) - ib_max=nElem(lb-1) - If (lb.eq.0) ib_max=0 - Do ib = 1, ib_max - Write (Label,'(A,I2,A,I2,A)') - & ' Elalbm(',ia,',',ib,',x)' - Call RecPrt(Label,' ',Elalbm(1,ia,ib,1),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Elalbm(',ia,',',ib,',y)' - Call RecPrt(Label,' ',Elalbm(1,ia,ib,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Elalbm(',ia,',',ib,',z)' - Call RecPrt(Label,' ',Elalbm(1,ia,ib,3),nZeta,1) - End Do - End Do - End If -* - Do ixa = la, 0, -1 - Do iya = la-ixa, 0, -1 - iza = la-ixa-iya - ipa = Ind(la,ixa,iza) -* - Do ixb = lb, 0, -1 - Do iyb = lb-ixb, 0, -1 - izb = lb-ixb-iyb - ipb = Ind(lb,ixb,izb) -* - Do iZeta = 1, nZeta - xyTmp=-Two*Beta(nzeta)*Elalbp(iZeta,ipa, - & Ind(lb+1,ixb ,izb ),1) - yxTmp=-Two*Beta(nzeta)*Elalbp(iZeta,ipa, - & Ind(lb+1,ixb+1,izb ),2) - yzTmp=-Two*Beta(nzeta)*Elalbp(iZeta,ipa, - & Ind(lb+1,ixb ,izb+1),2) - zyTmp=-Two*Beta(nzeta)*Elalbp(iZeta,ipa, - & Ind(lb+1,ixb ,izb ),3) - zxTmp=-Two*Beta(nzeta)*Elalbp(iZeta,ipa, - & Ind(lb+1,ixb+1,izb ),3) - xzTmp=-Two*Beta(nzeta)*Elalbp(iZeta,ipa, - & Ind(lb+1,ixb ,izb+1),1) - If (ixb.ge.1) Then - yxTmp = yxTmp + Dble(ixb)*Elalbm(iZeta,ipa, - & Ind(lb-1,ixb-1,izb ),2) - zxTmp = zxTmp + Dble(ixb)*Elalbm(iZeta,ipa, - & Ind(lb-1,ixb-1,izb ),3) - End If - If (iyb.ge.1) Then - xyTmp = xyTmp + Dble(iyb)*Elalbm(iZeta,ipa, - & Ind(lb-1,ixb ,izb ),1) - zyTmp = xyTmp + Dble(iyb)*Elalbm(iZeta,ipa, - & Ind(lb-1,ixb ,izb ),3) - End If - If (izb.ge.1) Then - xzTmp = xzTmp + Dble(izb)*Elalbm(iZeta,ipa, - & Ind(lb-1,ixb ,izb-1),1) - yzTmp = yzTmp + Dble(izb)*Elalbm(iZeta,ipa, - & Ind(lb-1,ixb ,izb-1),2) - End If - Final(iZeta,ipa,ipb,1) = -(xyTmp - yxTmp) - Final(iZeta,ipa,ipb,2) = -(yzTmp - zyTmp) - Final(iZeta,ipa,ipb,3) = -(zxTmp - xzTmp) - End Do -* - End Do - End Do -* - End Do - End Do -* - If (iPrint.ge.49) Then - Do iComp = 1, 3 - Write (Label,'(A,I2,A)') ' Final (',iComp,') ' - Call RecPrt(Label,' ',Final(1,1,1,iComp),nZeta, - & nElem(la)*nELem(lb)) - End Do - End If -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/assemble_dtdmu.F90 openmolcas-22.10/src/oneint_util/assemble_dtdmu.F90 --- openmolcas-22.02/src/oneint_util/assemble_dtdmu.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/assemble_dtdmu.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,118 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine Assemble_dTdmu(nZeta,rFinal,la,lb,Elalbp,Elalbm,Beta) +!*********************************************************************** +! * +! Object: to assemble the diamagnetic shielding integrals from * +! electric field integrals. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! February '91 * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: Two +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb +real(kind=wp), intent(out) :: rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),3) +real(kind=wp), intent(in) :: Elalbp(nZeta,nTri_Elem1(la),nTri_Elem1(lb+1),3), Elalbm(nZeta,nTri_Elem1(la),nTri_Elem1(lb-1),3), & + Beta(nZeta) +#include "print.fh" +integer(kind=iwp) :: ia, ib, ib_max, iComp, ipa, ipb, iPrint, iRout, ixa, ixb, iya, iyb, iza, izb, iZeta +real(kind=wp) :: xyTmp, xzTmp, yxTmp, yzTmp, zxTmp, zyTmp +character(len=80) Label + +iRout = 231 +iPrint = nPrint(iRout) + +!Fact = -1.0e6_wp*Half/c_in_au**2 +if (iPrint >= 99) then + write(u6,*) ' In Assemble_dTdmu la,lb=',la,lb + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb+1) + write(Label,'(A,I2,A,I2,A)') ' Elalbp(',ia,',',ib,',x)' + call RecPrt(Label,' ',Elalbp(:,ia,ib,1),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Elalbp(',ia,',',ib,',y)' + call RecPrt(Label,' ',Elalbp(:,ia,ib,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Elalbp(',ia,',',ib,',z)' + call RecPrt(Label,' ',Elalbp(:,ia,ib,3),nZeta,1) + end do + end do + do ia=1,nTri_Elem1(la) + ib_max = nTri_Elem1(lb-1) + if (lb == 0) ib_max = 0 + do ib=1,ib_max + write(Label,'(A,I2,A,I2,A)') ' Elalbm(',ia,',',ib,',x)' + call RecPrt(Label,' ',Elalbm(:,ia,ib,1),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Elalbm(',ia,',',ib,',y)' + call RecPrt(Label,' ',Elalbm(:,ia,ib,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Elalbm(',ia,',',ib,',z)' + call RecPrt(Label,' ',Elalbm(:,ia,ib,3),nZeta,1) + end do + end do +end if + +do ixa=la,0,-1 + do iya=la-ixa,0,-1 + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + + do ixb=lb,0,-1 + do iyb=lb-ixb,0,-1 + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + + do iZeta=1,nZeta + xyTmp = -Two*Beta(nzeta)*Elalbp(iZeta,ipa,C_Ind(lb+1,ixb,izb),1) + yxTmp = -Two*Beta(nzeta)*Elalbp(iZeta,ipa,C_Ind(lb+1,ixb+1,izb),2) + yzTmp = -Two*Beta(nzeta)*Elalbp(iZeta,ipa,C_Ind(lb+1,ixb,izb+1),2) + zyTmp = -Two*Beta(nzeta)*Elalbp(iZeta,ipa,C_Ind(lb+1,ixb,izb),3) + zxTmp = -Two*Beta(nzeta)*Elalbp(iZeta,ipa,C_Ind(lb+1,ixb+1,izb),3) + xzTmp = -Two*Beta(nzeta)*Elalbp(iZeta,ipa,C_Ind(lb+1,ixb,izb+1),1) + if (ixb >= 1) then + yxTmp = yxTmp+real(ixb,kind=wp)*Elalbm(iZeta,ipa,C_Ind(lb-1,ixb-1,izb),2) + zxTmp = zxTmp+real(ixb,kind=wp)*Elalbm(iZeta,ipa,C_Ind(lb-1,ixb-1,izb),3) + end if + if (iyb >= 1) then + xyTmp = xyTmp+real(iyb,kind=wp)*Elalbm(iZeta,ipa,C_Ind(lb-1,ixb,izb),1) + zyTmp = xyTmp+real(iyb,kind=wp)*Elalbm(iZeta,ipa,C_Ind(lb-1,ixb,izb),3) + end if + if (izb >= 1) then + xzTmp = xzTmp+real(izb,kind=wp)*Elalbm(iZeta,ipa,C_Ind(lb-1,ixb,izb-1),1) + yzTmp = yzTmp+real(izb,kind=wp)*Elalbm(iZeta,ipa,C_Ind(lb-1,ixb,izb-1),2) + end if + rFinal(iZeta,ipa,ipb,1) = -(xyTmp-yxTmp) + rFinal(iZeta,ipa,ipb,2) = -(yzTmp-zyTmp) + rFinal(iZeta,ipa,ipb,3) = -(zxTmp-xzTmp) + end do + + end do + end do + + end do +end do + +if (iPrint >= 49) then + do iComp=1,3 + write(Label,'(A,I2,A)') ' rFinal (',iComp,') ' + call RecPrt(Label,' ',rFinal(:,:,:,iComp),nZeta,nTri_Elem1(la)*nTri_Elem1(lb)) + end do +end if + +return + +end subroutine Assemble_dTdmu diff -Nru openmolcas-22.02/src/oneint_util/assemble_dVdB.f openmolcas-22.10/src/oneint_util/assemble_dVdB.f --- openmolcas-22.02/src/oneint_util/assemble_dVdB.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/assemble_dVdB.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,48 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2002, Roland Lindh * -************************************************************************ - Subroutine Assemble_dVdB(NAInt,EFInt,nZeta,la,lb,A,B,C) -************************************************************************ -* * -* Object: to assemble the derivative of the nuclear attractoion * -* integrals with respect to the magnetic field. * -* * -* Author: Roland Lindh, Dept. of Chemical Physics, * -* University of Lund, SWEDEN * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 NAInt(nZeta*((la+1)*(la+2)/2)*((lb+1)*(lb+2)/2)), - & EFInt(nZeta*((la+1)*(la+2)/2)*((lb+1)*(lb+2)/2),3), - & A(3), B(3), C(3), RAB(3) -* - RAB(1)=A(1)-B(1) - RAB(2)=A(2)-B(2) - RAB(3)=A(3)-B(3) -* -*---- Recombine in place! -* - nVec=nZeta*((la+1)*(la+2)/2)*((lb+1)*(lb+2)/2) - Do iVec = 1, nVec - EFInt_x=EFInt(iVec,1) - EFInt_y=EFInt(iVec,2) - EFInt_z=EFInt(iVec,3) - EFInt(iVec,1)=RAB(2)*(EFInt_z+C(3)*NAInt(iVec)) - & -RAB(3)*(EFInt_y+C(2)*NAInt(iVec)) - EFInt(iVec,2)=RAB(3)*(EFInt_x+C(1)*NAInt(iVec)) - & -RAB(1)*(EFInt_z+C(3)*NAInt(iVec)) - EFInt(iVec,3)=RAB(1)*(EFInt_y+C(2)*NAInt(iVec)) - & -RAB(2)*(EFInt_x+C(1)*NAInt(iVec)) - End Do -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/assemble_dvdb.F90 openmolcas-22.10/src/oneint_util/assemble_dvdb.F90 --- openmolcas-22.02/src/oneint_util/assemble_dvdb.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/assemble_dvdb.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,50 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2002, Roland Lindh * +!*********************************************************************** + +subroutine Assemble_dVdB(NAInt,EFInt,nZeta,la,lb,A,B,C) +!*********************************************************************** +! * +! Object: to assemble the derivative of the nuclear attraction * +! integrals with respect to the magnetic field. * +! * +! Author: Roland Lindh, Dept. of Chemical Physics, * +! University of Lund, SWEDEN * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb +real(kind=wp), intent(in) :: NAInt(nZeta*nTri_Elem1(la)*nTri_Elem1(lb)), A(3), B(3), C(3) +real(kind=wp), intent(inout) :: EFInt(nZeta*nTri_Elem1(la)*nTri_Elem1(lb),3) +integer(kind=iwp) :: iVec, nVec +real(kind=wp) :: EFInt_x, EFInt_y, EFInt_z, RAB(3) + +RAB(:) = A-B + +! Recombine in place! + +nVec = size(EFInt,1) +do iVec=1,nVec + EFInt_x = EFInt(iVec,1) + EFInt_y = EFInt(iVec,2) + EFInt_z = EFInt(iVec,3) + EFInt(iVec,1) = RAB(2)*(EFInt_z+C(3)*NAInt(iVec))-RAB(3)*(EFInt_y+C(2)*NAInt(iVec)) + EFInt(iVec,2) = RAB(3)*(EFInt_x+C(1)*NAInt(iVec))-RAB(1)*(EFInt_z+C(3)*NAInt(iVec)) + EFInt(iVec,3) = RAB(1)*(EFInt_y+C(2)*NAInt(iVec))-RAB(2)*(EFInt_x+C(1)*NAInt(iVec)) +end do + +return + +end subroutine Assemble_dVdB diff -Nru openmolcas-22.02/src/oneint_util/assemble_mgauss.f openmolcas-22.10/src/oneint_util/assemble_mgauss.f --- openmolcas-22.02/src/oneint_util/assemble_mgauss.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/assemble_mgauss.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,20 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Assemble_mGauss(As,Ad,nAs) - Implicit Real*8(a-h,o-z) - Real*8 As(nAs), Ad(nAs,6) -* - Call DaXpY_(nAs,1.0D0,Ad(1,1),1,As,1) - Call DaXpY_(nAs,1.0D0,Ad(1,4),1,As,1) - Call DaXpY_(nAs,1.0D0,Ad(1,6),1,As,1) -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/assemble_mgauss.F90 openmolcas-22.10/src/oneint_util/assemble_mgauss.F90 --- openmolcas-22.02/src/oneint_util/assemble_mgauss.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/assemble_mgauss.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,25 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Assemble_mGauss(As,Ad,nAs) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nAs +real(kind=wp), intent(inout) :: As(nAs) +real(kind=wp), intent(in) :: Ad(nAs,6) + +As(:) = As+Ad(:,1)+Ad(:,4)+Ad(:,6) + +return + +end subroutine Assemble_mGauss diff -Nru openmolcas-22.02/src/oneint_util/assmbl.f openmolcas-22.10/src/oneint_util/assmbl.f --- openmolcas-22.02/src/oneint_util/assmbl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/assmbl.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,73 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Assmbl(Rnxyz,Axyz,la,Rxyz,lr,Bxyz,lb,nZeta,HerW,nHer) -************************************************************************ -* * -* Object: to assemble the cartesian components of the multipole moment * -* matrix within the framework of the Gauss-Hermite quadrature. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* November '90 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Rnxyz(nZeta*3,0:la,0:lb,0:lr), HerW(nHer), - & Axyz(nZeta*3,nHer,0:la), - & Rxyz(nZeta*3,nHer,0:lr), - & Bxyz(nZeta*3,nHer,0:lb) - Character*80 Label -* - iRout = 123 - iPrint = nPrint(iRout) - If (iPrint.ge.99) Then - Call RecPrt(' In Assmbl:HerW',' ',HerW,1,nHer) - Call RecPrt(' In Assmbl:Axyz',' ',Axyz,nZeta*3,nHer*(la+1)) - Call RecPrt(' In Assmbl:Bxyz',' ',Bxyz,nZeta*3,nHer*(lb+1)) - Call RecPrt(' In Assmbl:Rxyz',' ',Rxyz,nZeta*3,nHer*(lr+1)) - End If -* -* - call dcopy_(3*nZeta*(la+1)*(lb+1)*(lr+1),[Zero],0, - & Rnxyz,1) - Do 100 ia = 0, la - Do 110 ib = 0, lb - Do 120 ir = 0, lr -* -* Generate the cartesian components of the multipole moment -* matrix as a sum of the value of the integrand, evaluated -* at a root, times a weight. -* - Do 30 iHer = 1, nHer - Do 10 iZCar = 1, 3*nZeta - Rnxyz(iZCar,ia,ib,ir) = Rnxyz(iZCar,ia,ib,ir) + - & Axyz(iZCar,iHer,ia)* - & Rxyz(iZCar,iHer,ir)* - & Bxyz(iZCar,iHer,ib)* - & HerW(iHer) - 10 Continue - 30 Continue -* - If (iPrint.ge.99) Then - Write (Label,'(A,I2,A,I2,A,I2,A)') - & ' In Assmbl: Rnxyz(',ia,',',ib,',',ir,')' - Call RecPrt(Label,' ',Rnxyz(1,ia,ib,ir),nZeta,3) - End If - 120 Continue - 110 Continue - 100 Continue -* -* Call GetMem(' Exit Assmbl ','LIST','REAL',iDum,iDum) - Return - End diff -Nru openmolcas-22.02/src/oneint_util/assmbl.F90 openmolcas-22.10/src/oneint_util/assmbl.F90 --- openmolcas-22.02/src/oneint_util/assmbl.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/assmbl.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,68 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Assmbl(Rnxyz,Axyz,la,Rxyz,lr,Bxyz,lb,nZeta,HerW,nHer) +!*********************************************************************** +! * +! Object: to assemble the cartesian components of the multipole moment * +! matrix within the framework of the Gauss-Hermite quadrature. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! November '90 * +!*********************************************************************** + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: la, lr, lb, nZeta, nHer +real(kind=wp), intent(out) :: Rnxyz(nZeta*3,0:la,0:lb,0:lr) +real(kind=wp), intent(in) :: Axyz(nZeta*3,nHer,0:la), Rxyz(nZeta*3,nHer,0:lr), Bxyz(nZeta*3,nHer,0:lb), HerW(nHer) +#include "print.fh" +integer(kind=iwp) :: ia, ib, iHer, iPrint, ir, iRout +character(len=80) :: Label + +iRout = 123 +iPrint = nPrint(iRout) +if (iPrint >= 99) then + call RecPrt(' In Assmbl:HerW',' ',HerW,1,nHer) + call RecPrt(' In Assmbl:Axyz',' ',Axyz,nZeta*3,nHer*(la+1)) + call RecPrt(' In Assmbl:Bxyz',' ',Bxyz,nZeta*3,nHer*(lb+1)) + call RecPrt(' In Assmbl:Rxyz',' ',Rxyz,nZeta*3,nHer*(lr+1)) +end if + +Rnxyz(:,:,:,:) = Zero +do ia=0,la + do ib=0,lb + do ir=0,lr + + ! Generate the cartesian components of the multipole moment + ! matrix as a sum of the value of the integrand, evaluated + ! at a root, times a weight. + + do iHer=1,nHer + Rnxyz(:,ia,ib,ir) = Rnxyz(:,ia,ib,ir)+Axyz(:,iHer,ia)*Rxyz(:,iHer,ir)*Bxyz(:,iHer,ib)*HerW(iHer) + end do + + if (iPrint >= 99) then + write(Label,'(A,I2,A,I2,A,I2,A)') ' In Assmbl: Rnxyz(',ia,',',ib,',',ir,')' + call RecPrt(Label,' ',Rnxyz(:,ia,ib,ir),nZeta,3) + end if + end do + end do +end do + +return + +end subroutine Assmbl diff -Nru openmolcas-22.02/src/oneint_util/ass_px.f openmolcas-22.10/src/oneint_util/ass_px.f --- openmolcas-22.02/src/oneint_util/ass_px.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/ass_px.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,161 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1994, Bernd Artur Hess * -************************************************************************ - SubRoutine Ass_pX(Alpha,nZeta,Final,la,lb,Slaplb,Slamlb,nComp) -************************************************************************ -* * -* Object: to assemble the pV integrals from * -* derivative integrals of the electric potential. * -* * -* Author: Bernd Hess, Institut fuer Physikalische und Theoretische * -* Chemie, University of Bonn, Germany, August 1994 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Final (nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,3,nComp), - * Slaplb(nZeta,(la+2)*(la+3)/2,(lb+1)*(lb+2)/2,nComp), - * Slamlb(nZeta, la *(la+1)/2,(lb+1)*(lb+2)/2,nComp), - * Alpha(nZeta) - Character*80 Label -* -* Statement function for cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 - nElem(ix) = (ix+1)*(ix+2)/2 -* - iRout = 203 - iPrint = nPrint(iRout) -* - If (iPrint.ge.99) Then - Write (6,*) - Write (6,*) ' In Ass_pX la,lb,nComp=',la,lb,nComp - Write (6,*) - Call RecPrt('Alpha','(10G15.8)',Alpha,nZeta,1) - Do iComp = 1, nComp - Write (6,*) - Write (6,*) 'iComp=',iComp - Write (6,*) - Write (Label,'(A,I2,A)') - & 'Ass_pX: Slaplb(iComp=',iComp,')' - Call RecPrt(Label,'(10f15.8)',Slaplb(1,1,1,iComp), - & nZeta,nElem(la+1)*nElem(lb)) - If (la.gt.0) Then - Write (Label,'(A,I2,A)') - & 'Ass_pX: Slamlb(iComp=,',iComp,')' - Call RecPrt(Label,'(10G15.8)',Slamlb(1,1,1,iComp), - & nZeta,nElem(la-1)*nElem(lb)) - End If - End Do - End If -* - Do iComp = 1, nComp -* - Do 10 ixa = la, 0, -1 - Do 11 iya = la-ixa, 0, -1 - iza = la-ixa-iya - ipa = Ind(la,ixa,iza) -* - Do 20 ixb = lb, 0, -1 - Do 21 iyb = lb-ixb, 0, -1 - izb = lb-ixb-iyb - ipb = Ind(lb,ixb,izb) -* * -************************************************************************ -* * - If (ixa.EQ.0) Then - ixp=Ind(la+1,ixa+1,iza) - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1,iComp) = - & Two*Alpha(iZeta)*Slaplb(iZeta,ixp,ipb,iComp) - End Do - Else - ixp=Ind(la+1,ixa+1,iza) - ixm=Ind(la-1,ixa-1,iza) - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1,iComp) = - & Two*Alpha(iZeta)*Slaplb(iZeta,ixp,ipb,iComp) - & -Dble(ixa)* Slamlb(iZeta,ixm,ipb,iComp) - End Do - End If -* - If (iya.EQ.0) Then - iyp=Ind(la+1,ixa,iza) - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,2,iComp) = - & Two*Alpha(iZeta)*Slaplb(iZeta,iyp,ipb,iComp) - End Do - Else - iyp=Ind(la+1,ixa,iza) - iym=Ind(la-1,ixa,iza) - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,2,iComp) = - & Two*Alpha(iZeta)*Slaplb(iZeta,iyp,ipb,iComp) - & -Dble(iya)* Slamlb(iZeta,iym,ipb,iComp) - End Do - End If -* - If (iza.EQ.0) Then - izp=Ind(la+1,ixa,iza+1) - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,3,iComp) = - & Two*Alpha(iZeta)*Slaplb(iZeta,izp,ipb,iComp) - End Do - Else - izp=Ind(la+1,ixa,iza+1) - izm=Ind(la-1,ixa,iza-1) - Do iZeta = 1, nZeta - Final(iZeta,ipa,ipb,3,iComp) = - & Two*Alpha(iZeta)*Slaplb(iZeta,izp,ipb,iComp) - & -Dble(iza)* Slamlb(iZeta,izm,ipb,iComp) - End Do - End If -* * -************************************************************************ -* * -21 Continue -20 Continue -* -11 Continue -10 Continue -* - End Do -* - If (iPrint.ge.49) Then - Write (6,*) ' In Ass_pX la,lb,nComp=',la,lb,nComp - Do iComp = 1, nComp - Write (6,*) - Write (6,*) 'iComp=',iComp - Write (6,*) -* - Write (Label,'(A,I2,A)') - & ' Ass_pX: pX( 1,iComp=',iComp,')' - Call RecPrt(Label,'(10G15.8)', - & Final(1,1,1,1,iComp),nZeta, - & nElem(la)*nElem(lb)) -* - Write (Label,'(A,I2,A)') - & ' Ass_pX: pX( 2,iComp=',iComp,')' - Call RecPrt(Label,'(10G15.8)', - & Final(1,1,1,2,iComp),nZeta, - & nElem(la)*nElem(lb)) -* - Write (Label,'(A,I2,A)') - & ' Ass_pX: pX( 3,iComp=',iComp,')' - Call RecPrt(Label,'(10G15.8)', - & Final(1,1,1,3,iComp),nZeta, - & nElem(la)*nElem(lb)) - End Do - End If -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/ass_px.F90 openmolcas-22.10/src/oneint_util/ass_px.F90 --- openmolcas-22.02/src/oneint_util/ass_px.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/ass_px.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,129 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1994, Bernd Artur Hess * +!*********************************************************************** + +subroutine Ass_pX(Alpha,nZeta,rFinal,la,lb,Slaplb,Slamlb,nComp) +!*********************************************************************** +! * +! Object: to assemble the pV integrals from * +! derivative integrals of the electric potential. * +! * +! Author: Bernd Hess, Institut fuer Physikalische und Theoretische * +! Chemie, University of Bonn, Germany, August 1994 * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: Two +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb, nComp +real(kind=wp), intent(in) :: Alpha(nZeta), Slaplb(nZeta,nTri_Elem1(la+1),nTri_Elem1(lb),nComp), & + Slamlb(nZeta,nTri_Elem1(la-1),nTri_Elem1(lb),nComp) +real(kind=wp), intent(out) :: rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),3,nComp) +#include "print.fh" +integer(kind=iwp) :: iComp, ipa, ipb, iPrint, iRout, ixa, ixb, ixm, ixp, iya, iyb, iym, iyp, iza, izb, izm, izp +character(len=80) :: Label + +iRout = 203 +iPrint = nPrint(iRout) + +if (iPrint >= 99) then + write(u6,*) + write(u6,*) ' In Ass_pX la,lb,nComp=',la,lb,nComp + write(u6,*) + call RecPrt('Alpha','(10G15.8)',Alpha,nZeta,1) + do iComp=1,nComp + write(u6,*) + write(u6,*) 'iComp=',iComp + write(u6,*) + write(Label,'(A,I2,A)') 'Ass_pX: Slaplb(iComp=',iComp,')' + call RecPrt(Label,'(10f15.8)',Slaplb(:,:,:,iComp),nZeta,nTri_Elem1(la+1)*nTri_Elem1(lb)) + if (la > 0) then + write(Label,'(A,I2,A)') 'Ass_pX: Slamlb(iComp=,',iComp,')' + call RecPrt(Label,'(10G15.8)',Slamlb(:,:,:,iComp),nZeta,nTri_Elem1(la-1)*nTri_Elem1(lb)) + end if + end do +end if + +do iComp=1,nComp + + do ixa=la,0,-1 + do iya=la-ixa,0,-1 + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + + do ixb=lb,0,-1 + do iyb=lb-ixb,0,-1 + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + ! * + !************************************************************* + ! * + if (ixa == 0) then + ixp = C_Ind(la+1,ixa+1,iza) + rFinal(:,ipa,ipb,1,iComp) = Two*Alpha*Slaplb(:,ixp,ipb,iComp) + else + ixp = C_Ind(la+1,ixa+1,iza) + ixm = C_Ind(la-1,ixa-1,iza) + rFinal(:,ipa,ipb,1,iComp) = Two*Alpha*Slaplb(:,ixp,ipb,iComp)-real(ixa,kind=wp)*Slamlb(:,ixm,ipb,iComp) + end if + + if (iya == 0) then + iyp = C_Ind(la+1,ixa,iza) + rFinal(:,ipa,ipb,2,iComp) = Two*Alpha*Slaplb(:,iyp,ipb,iComp) + else + iyp = C_Ind(la+1,ixa,iza) + iym = C_Ind(la-1,ixa,iza) + rFinal(:,ipa,ipb,2,iComp) = Two*Alpha*Slaplb(:,iyp,ipb,iComp)-real(iya,kind=wp)*Slamlb(:,iym,ipb,iComp) + end if + + if (iza == 0) then + izp = C_Ind(la+1,ixa,iza+1) + rFinal(:,ipa,ipb,3,iComp) = Two*Alpha*Slaplb(:,izp,ipb,iComp) + else + izp = C_Ind(la+1,ixa,iza+1) + izm = C_Ind(la-1,ixa,iza-1) + rFinal(:,ipa,ipb,3,iComp) = Two*Alpha*Slaplb(:,izp,ipb,iComp)-real(iza,kind=wp)*Slamlb(:,izm,ipb,iComp) + end if + ! * + !************************************************************* + ! * + end do + end do + + end do + end do + +end do + +if (iPrint >= 49) then + write(u6,*) ' In Ass_pX la,lb,nComp=',la,lb,nComp + do iComp=1,nComp + write(u6,*) + write(u6,*) 'iComp=',iComp + write(u6,*) + + write(Label,'(A,I2,A)') ' Ass_pX: pX( 1,iComp=',iComp,')' + call RecPrt(Label,'(10G15.8)',rFinal(:,:,:,1,iComp),nZeta,nTri_Elem1(la)*nTri_Elem1(lb)) + + write(Label,'(A,I2,A)') ' Ass_pX: pX( 2,iComp=',iComp,')' + call RecPrt(Label,'(10G15.8)',rFinal(:,:,:,2,iComp),nZeta,nTri_Elem1(la)*nTri_Elem1(lb)) + + write(Label,'(A,I2,A)') ' Ass_pX: pX( 3,iComp=',iComp,')' + call RecPrt(Label,'(10G15.8)',rFinal(:,:,:,3,iComp),nZeta,nTri_Elem1(la)*nTri_Elem1(lb)) + end do +end if + +return + +end subroutine Ass_pX diff -Nru openmolcas-22.02/src/oneint_util/ass_pxp.f openmolcas-22.10/src/oneint_util/ass_pxp.f --- openmolcas-22.02/src/oneint_util/ass_pxp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/ass_pxp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,135 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1994, Bernd Artur Hess * -************************************************************************ - SubRoutine Ass_pXp(Beta,nZeta,Final,la,lb,Slalbp,Slalbm,nComp) -************************************************************************ -* * -* Object: to assemble the pVp integrals * -* * -* Author: Bernd Hess, Institut fuer Physikalische und Theoretische * -* Chemie, University of Bonn, Germany, August 1994 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Final (nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nComp), - * Slalbp(nZeta,(la+1)*(la+2)/2,(lb+2)*(lb+3)/2,3,nComp), - * Slalbm(nZeta,(la+1)*(la+2)/2, lb *(lb+1)/2,3,nComp), - * Beta(nZeta) - Character*80 Label -* -* Statement function for cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 - nElem(ix) = (ix+1)*(ix+2)/2 -* - iRout = 211 - iPrint = nPrint(iRout) -* - If (iPrint.ge.99) Then - Write (6,*) - Write (6,*) ' In Ass_pXp la,lb,nComp,=',la,lb,nComp - Write (6,*) - Call RecPrt('Beta','(10G15.8)',Beta,nZeta,1) - Do iComp = 1, nComp - Write (6,*) 'iComp=',iComp - Write (Label,'(A,I2,A)') - & ' Ass_pXp: Slalbp(1,iComp=',iComp,')' - Call RecPrt(Label,'(10G15.8)',Slalbp(1,1,1,1,iComp), - & nZeta,nElem(la)*nElem(lb+1)) - Write (Label,'(A,I2,A)') - & ' Ass_pXp: Slalbp(2,iComp=',iComp,')' - Call RecPrt(Label,'(10G15.8)',Slalbp(1,1,1,2,iComp), - & nZeta,nElem(la)*nElem(lb+1)) - Write (Label,'(A,I2,A)') - & ' Ass_pXp: Slalbp(3,iComp=',iComp,')' - Call RecPrt(Label,'(10G15.8)',Slalbp(1,1,1,3,iComp), - & nZeta,nElem(la)*nElem(lb+1)) - If (lb.gt.0) Then - Write (Label,'(A,I2,A)') - & 'Ass_pXp: Slalbm(1,iComp=',iComp,')' - Call RecPrt(Label,'(10G15.8)',Slalbm(1,1,1,1,iComp), - & nZeta,nElem(la)*nElem(lb-1)) - Write (Label,'(A,I2,A)') - & 'Ass_pXp: Slalbm(2,iComp=',iComp,')' - Call RecPrt(Label,'(10G15.8)',Slalbm(1,1,1,2,iComp), - & nZeta,nElem(la)*nElem(lb-1)) - Write (Label,'(A,I2,A)') - & 'Ass_pXp: Slalbm(3,iComp=',iComp,')' - Call RecPrt(Label,'(10G15.8)',Slalbm(1,1,1,3,iComp), - & nZeta,nElem(la)*nElem(lb-1)) - End If - End Do - End If -* - Do iComp = 1, nComp -* - Do 10 ixa = la, 0, -1 - Do 11 iya = la-ixa, 0, -1 - iza = la-ixa-iya - ipa = Ind(la,ixa,iza) -* - Do 20 ixb = lb, 0, -1 - Do 21 iyb = lb-ixb, 0, -1 - izb = lb-ixb-iyb - ipb = Ind(lb,ixb,izb) -* - Do 30 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,iComp) = - & Two*Beta(iZeta) * - & Slalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb ),1,iComp) - & +Two*Beta(iZeta) * - & Slalbp(iZeta,ipa,Ind(lb+1,ixb ,izb ),2,iComp) - & +Two*Beta(iZeta) * - & Slalbp(iZeta,ipa,Ind(lb+1,ixb ,izb+1),3,iComp) -30 Continue -* - If (ixb.gt.0) Then - Do 31 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,iComp)=Final(iZeta,ipa,ipb,iComp) - & -Dble(ixb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb-1,izb),1,iComp) -31 Continue - End If -* - If (iyb.gt.0) Then - Do 32 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,iComp)=Final(iZeta,ipa,ipb,iComp) - & -Dble(iyb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb),2,iComp) -32 Continue - End If -* - If (izb.gt.0) Then - Do 33 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,iComp)=Final(iZeta,ipa,ipb,iComp) - & -Dble(izb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb-1),3,iComp) -33 Continue - End If -* -21 Continue -20 Continue -* -11 Continue -10 Continue -* - End Do ! iComp -* - If (iPrint.ge.49) Then - Do iComp = 1, nComp - Write (Label,'(A,I2,A,I2,A,I2,A)') - & ' Ass_pXp: pXp(iComp=',iComp,')' - Call RecPrt(Label,'(10G15.8)',Final(1,1,1,iComp), - & nZeta,nElem(la)*nElem(lb)) - End Do - End If -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/ass_pxp.F90 openmolcas-22.10/src/oneint_util/ass_pxp.F90 --- openmolcas-22.02/src/oneint_util/ass_pxp.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/ass_pxp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,105 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1994, Bernd Artur Hess * +!*********************************************************************** + +subroutine Ass_pXp(Beta,nZeta,rFinal,la,lb,Slalbp,Slalbm,nComp) +!*********************************************************************** +! * +! Object: to assemble the pVp integrals * +! * +! Author: Bernd Hess, Institut fuer Physikalische und Theoretische * +! Chemie, University of Bonn, Germany, August 1994 * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: Two +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb, nComp +real(kind=wp), intent(in) :: Beta(nZeta), Slalbp(nZeta,nTri_Elem1(la),nTri_Elem1(lb+1),3,nComp), & + Slalbm(nZeta,nTri_Elem1(la),nTri_Elem1(lb-1),3,nComp) +real(kind=wp), intent(out) :: rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),nComp) +#include "print.fh" +integer(kind=iwp) :: iComp, ipa, ipb, iPrint, iRout, ixa, ixb, iya, iyb, iza, izb +character(len=80) :: Label + +iRout = 211 +iPrint = nPrint(iRout) + +if (iPrint >= 99) then + write(u6,*) + write(u6,*) ' In Ass_pXp la,lb,nComp,=',la,lb,nComp + write(u6,*) + call RecPrt('Beta','(10G15.8)',Beta,nZeta,1) + do iComp=1,nComp + write(u6,*) 'iComp=',iComp + write(Label,'(A,I2,A)') ' Ass_pXp: Slalbp(1,iComp=',iComp,')' + call RecPrt(Label,'(10G15.8)',Slalbp(:,:,:,1,iComp),nZeta,nTri_Elem1(la)*nTri_Elem1(lb+1)) + write(Label,'(A,I2,A)') ' Ass_pXp: Slalbp(2,iComp=',iComp,')' + call RecPrt(Label,'(10G15.8)',Slalbp(:,:,:,2,iComp),nZeta,nTri_Elem1(la)*nTri_Elem1(lb+1)) + write(Label,'(A,I2,A)') ' Ass_pXp: Slalbp(3,iComp=',iComp,')' + call RecPrt(Label,'(10G15.8)',Slalbp(:,:,:,3,iComp),nZeta,nTri_Elem1(la)*nTri_Elem1(lb+1)) + if (lb > 0) then + write(Label,'(A,I2,A)') 'Ass_pXp: Slalbm(1,iComp=',iComp,')' + call RecPrt(Label,'(10G15.8)',Slalbm(:,:,:,1,iComp),nZeta,nTri_Elem1(la)*nTri_Elem1(lb-1)) + write(Label,'(A,I2,A)') 'Ass_pXp: Slalbm(2,iComp=',iComp,')' + call RecPrt(Label,'(10G15.8)',Slalbm(:,:,:,2,iComp),nZeta,nTri_Elem1(la)*nTri_Elem1(lb-1)) + write(Label,'(A,I2,A)') 'Ass_pXp: Slalbm(3,iComp=',iComp,')' + call RecPrt(Label,'(10G15.8)',Slalbm(:,:,:,3,iComp),nZeta,nTri_Elem1(la)*nTri_Elem1(lb-1)) + end if + end do +end if + +do iComp=1,nComp + + do ixa=la,0,-1 + do iya=la-ixa,0,-1 + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + + do ixb=lb,0,-1 + do iyb=lb-ixb,0,-1 + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + + rFinal(:,ipa,ipb,iComp) = Two*Beta*(Slalbp(:,ipa,C_Ind(lb+1,ixb+1,izb),1,iComp)+ & + Slalbp(:,ipa,C_Ind(lb+1,ixb,izb),2,iComp)+ & + Slalbp(:,ipa,C_Ind(lb+1,ixb,izb+1),3,iComp)) + + if (ixb > 0) & + rFinal(:,ipa,ipb,iComp) = rFinal(:,ipa,ipb,iComp)-real(ixb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb-1,izb),1,iComp) + + if (iyb > 0) & + rFinal(:,ipa,ipb,iComp) = rFinal(:,ipa,ipb,iComp)-real(iyb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb),2,iComp) + + if (izb > 0) & + rFinal(:,ipa,ipb,iComp) = rFinal(:,ipa,ipb,iComp)-real(izb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb-1),3,iComp) + + end do + end do + + end do + end do + +end do ! iComp + +if (iPrint >= 49) then + do iComp=1,nComp + write(Label,'(A,I2,A,I2,A,I2,A)') ' Ass_pXp: pXp(iComp=',iComp,')' + call RecPrt(Label,'(10G15.8)',rFinal(:,:,:,iComp),nZeta,nTri_Elem1(la)*nTri_Elem1(lb)) + end do +end if + +return + +end subroutine Ass_pXp diff -Nru openmolcas-22.02/src/oneint_util/cassmbl.f openmolcas-22.10/src/oneint_util/cassmbl.f --- openmolcas-22.02/src/oneint_util/cassmbl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/cassmbl.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,82 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine CAssmbl(Rnxyz,Axyz,la,Bxyz,lb,nZeta,HerW,nHer) -************************************************************************ -* * -* Object: to assemble the cartesian components of the multipole moment * -* matrix within the framework of the Gauss-Hermite quadrature. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* November '90 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 HerW(nHer) - Complex*16 Rnxyz(nZeta*3,0:la,0:lb), - & Axyz(nZeta*3,nHer,0:la), - & Bxyz(nZeta*3,nHer,0:lb) - Character*80 Label -* - iRout = 123 - iPrint = nPrint(iRout) - If (iPrint.ge.99) Then - Call RecPrt(' In CAssmbl:HerW',' ',HerW,1,nHer) - Call CRecPrt(' In CAssmbl:Axyz',' ', - & Axyz,nZeta*3,nHer*(la+1),'R') - Call CRecPrt(' In CAssmbl:Axyz',' ', - & Axyz,nZeta*3,nHer*(la+1),'I') - Call CRecPrt(' In CAssmbl:Bxyz',' ', - & Bxyz,nZeta*3,nHer*(lb+1),'R') - Call CRecPrt(' In CAssmbl:Bxyz',' ', - & Bxyz,nZeta*3,nHer*(lb+1),'I') - End If -* -* Initialize to zero -* - Do ib = 0, lb - Do ia = 0, la - Do iZeta = 1, nZeta - Rnxyz(iZeta,ia,ib)=DCMPLX(Zero,Zero) - End Do - End Do - End Do -* - Do 100 ia = 0, la - Do 110 ib = 0, lb -* -* Generate the cartesian components of the multipole moment -* matrix as a sum of the value of the integrand, evaluated -* at a root, times a weight. -* - Do 30 iHer = 1, nHer - Do 10 iZCar = 1, 3*nZeta - Rnxyz(iZCar,ia,ib) = Rnxyz(iZCar,ia,ib) + - & Axyz(iZCar,iHer,ia)* - & Bxyz(iZCar,iHer,ib)* - & HerW(iHer) - 10 Continue - 30 Continue -* - If (iPrint.ge.99) Then - Write (Label,'(A,I2,A,I2,A)') - & ' In CAssmbl: Rnxyz(',ia,',',ib,')' - Call CRecPrt(Label,' ',Rnxyz(1,ia,ib),nZeta,3,'R') - Call CRecPrt(Label,' ',Rnxyz(1,ia,ib),nZeta,3,'I') - End If - 110 Continue - 100 Continue -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/cassmbl.F90 openmolcas-22.10/src/oneint_util/cassmbl.F90 --- openmolcas-22.02/src/oneint_util/cassmbl.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/cassmbl.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,72 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine CAssmbl(Rnxyz,Axyz,la,Bxyz,lb,nZeta,HerW,nHer) +!*********************************************************************** +! * +! Object: to assemble the cartesian components of the multipole moment * +! matrix within the framework of the Gauss-Hermite quadrature. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! November '90 * +!*********************************************************************** + +use Constants, only: cZero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: la, lb, nZeta, nHer +complex(kind=wp), intent(out) :: Rnxyz(nZeta*3,0:la,0:lb) +complex(kind=wp), intent(in) :: Axyz(nZeta*3,nHer,0:la), Bxyz(nZeta*3,nHer,0:lb) +real(kind=wp), intent(in) :: HerW(nHer) +#include "print.fh" +integer(kind=iwp) :: ia, ib, iHer, iPrint, iRout +character(len=80) :: Label + +iRout = 123 +iPrint = nPrint(iRout) +if (iPrint >= 99) then + call RecPrt(' In CAssmbl:HerW',' ',HerW,1,nHer) + call CRecPrt(' In CAssmbl:Axyz',' ',Axyz,nZeta*3,nHer*(la+1),'R') + call CRecPrt(' In CAssmbl:Axyz',' ',Axyz,nZeta*3,nHer*(la+1),'I') + call CRecPrt(' In CAssmbl:Bxyz',' ',Bxyz,nZeta*3,nHer*(lb+1),'R') + call CRecPrt(' In CAssmbl:Bxyz',' ',Bxyz,nZeta*3,nHer*(lb+1),'I') +end if + +! Initialize to zero + +Rnxyz(:,:,:) = cZero + +do ia=0,la + do ib=0,lb + + ! Generate the cartesian components of the multipole moment + ! matrix as a sum of the value of the integrand, evaluated + ! at a root, times a weight. + + do iHer=1,nHer + Rnxyz(:,ia,ib) = Rnxyz(:,ia,ib)+Axyz(:,iHer,ia)*Bxyz(:,iHer,ib)*HerW(iHer) + end do + + if (iPrint >= 99) then + write(Label,'(A,I2,A,I2,A)') ' In CAssmbl: Rnxyz(',ia,',',ib,')' + call CRecPrt(Label,' ',Rnxyz(:,ia,ib),nZeta,3,'R') + call CRecPrt(Label,' ',Rnxyz(:,ia,ib),nZeta,3,'I') + end if + end do +end do + +return + +end subroutine CAssmbl diff -Nru openmolcas-22.02/src/oneint_util/ccmbnmp.f openmolcas-22.10/src/oneint_util/ccmbnmp.f --- openmolcas-22.02/src/oneint_util/ccmbnmp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/ccmbnmp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,74 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine CCmbnMP(Rnxyz,nZeta,la,lb,lr,Zeta,rKappa,Final,nComp, - & kVector,P) -************************************************************************ -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Complex*16 Rnxyz(nZeta,3,0:la,0:lb,0:lr), Temp, i - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nComp), - & Zeta(nZeta), rKappa(nZeta), kVector(3), P(nZeta,3), - & k_Dot_P, Fact -* -* Statement function for Cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 -* - i = (0.0D0,1.0D0) - Do 10 ixa = 0, la - iyaMax=la-ixa - Do 11 ixb = 0, lb - iybMax=lb-ixb - Do 20 iya = 0, iyaMax - iza = la-ixa-iya - ipa= Ind(la,ixa,iza) - Do 21 iyb = 0, iybMax - izb = lb-ixb-iyb - ipb= Ind(lb,ixb,izb) -* -* Combine multipole moment integrals -* - iComp = 0 - Do 41 ix = lr, 0, -1 - Do 42 iy = lr-ix, 0, -1 - iz = lr-ix-iy - Do 30 iZeta = 1, nZeta - rTemp=KVector(1)**2 + kVector(2)**2 + kVector(3)**2 - rTemp=rTemp/(Four*Zeta(iZeta)) - Fact = rKappa(iZeta) * (1.0D0/Sqrt(Zeta(iZeta)**3)) - & * Exp(-rTemp) - k_Dot_P = kVector(1)*P(iZeta,1) - & + kVector(2)*P(iZeta,2) - & + kVector(3)*P(iZeta,3) - Temp = Exp(i * k_Dot_P) * Fact * - & Rnxyz(iZeta,1,ixa,ixb,ix)* - & Rnxyz(iZeta,2,iya,iyb,iy)* - & Rnxyz(iZeta,3,iza,izb,iz) - Final(iZeta,ipa,ipb,iComp+1) = DBLE(Temp) - Final(iZeta,ipa,ipb,iComp+2) = DIMAG(Temp) - 30 Continue - iComp=iComp+2 - 42 Continue - 41 Continue -* - 21 Continue - 20 Continue - 11 Continue - 10 Continue -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/ccmbnmp.F90 openmolcas-22.10/src/oneint_util/ccmbnmp.F90 --- openmolcas-22.02/src/oneint_util/ccmbnmp.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/ccmbnmp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,71 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine CCmbnMP(Rnxyz,nZeta,la,lb,lr,Zeta,rKappa,rFinal,nComp,kVector,P) +!*********************************************************************** +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: One, Quart, Onei +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb, lr, nComp +complex(kind=wp), intent(in) :: Rnxyz(nZeta,3,0:la,0:lb,0:lr) +real(kind=wp), intent(in) :: Zeta(nZeta), rKappa(nZeta), kVector(3), P(nZeta,3) +real(kind=wp), intent(out) :: rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),nComp) +integer(kind=iwp) :: iComp, ipa, ipb, ix, ixa, ixb, iy, iya, iyaMax, iyb, iybMax, iz, iza, izb, iZeta +complex(kind=wp) :: Temp +real(kind=wp) :: Fact, k_Dot_P, kModQ, rTemp + +kModQ = Quart*(kVector(1)**2+kVector(2)**2+kVector(3)**2) + +do ixa=0,la + iyaMax = la-ixa + do ixb=0,lb + iybMax = lb-ixb + do iya=0,iyaMax + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + do iyb=0,iybMax + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + + ! Combine multipole moment integrals + + iComp = 0 + do ix=lr,0,-1 + do iy=lr-ix,0,-1 + iz = lr-ix-iy + do iZeta=1,nZeta + rTemp = kModQ/Zeta(iZeta) + Fact = rKappa(iZeta)*(One/sqrt(Zeta(iZeta)**3))*exp(-rTemp) + k_Dot_P = kVector(1)*P(iZeta,1)+kVector(2)*P(iZeta,2)+kVector(3)*P(iZeta,3) + Temp = exp(Onei*k_Dot_P)*Fact*Rnxyz(iZeta,1,ixa,ixb,ix)*Rnxyz(iZeta,2,iya,iyb,iy)*Rnxyz(iZeta,3,iza,izb,iz) + rFinal(iZeta,ipa,ipb,iComp+1) = real(Temp) + rFinal(iZeta,ipa,ipb,iComp+2) = aimag(Temp) + end do + iComp = iComp+2 + end do + end do + + end do + end do + end do +end do + +return + +end subroutine CCmbnMP diff -Nru openmolcas-22.02/src/oneint_util/ccmbnve.f openmolcas-22.10/src/oneint_util/ccmbnve.f --- openmolcas-22.02/src/oneint_util/ccmbnve.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/ccmbnve.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,124 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine CCmbnVe(Rnxyz,nZeta,la,lb,Zeta,rKappa,Final,nComp, - & Vxyz,KVector,P) -************************************************************************ -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* January 91 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nComp), - & Zeta(nZeta), rKappa(nZeta), rTemp, Fact, KVector(3), - & P(nZeta,3), k_dot_P - Complex*16 Rnxyz(nZeta,3,0:la+1,0:lb+1), - & Vxyz(nZeta,3,0:la,0:lb,2), Temp1, Temp2, - & Tempp, Tempm, i -* -* Statement function for Cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 -* - iRout = 161 - iPrint = nPrint(iRout) -* - i = (0.0D0,1.0D0) - Do 10 ixa = 0, la - iyaMax=la-ixa - Do 11 ixb = 0, lb - iybMax=lb-ixb - Do 20 iya = 0, iyaMax - iza = la-ixa-iya - ipa= Ind(la,ixa,iza) - Do 21 iyb = 0, iybMax - izb = lb-ixb-iyb - ipb= Ind(lb,ixb,izb) -* -* Combine integrals -* - Do 30 iZeta = 1, nZeta -* -* Put in the correct prefactors -* - rTemp=KVector(1)**2 + kVector(2)**2 + kVector(3)**2 - rTemp=rTemp/(Four*Zeta(iZeta)) - Fact = rKappa(iZeta) * Zeta(iZeta)**(-Three/Two) * - & Exp(-rTemp) - k_dot_P=kVector(1)*P(iZeta,1) - & +kVector(2)*P(iZeta,2) - & +kVector(3)*P(iZeta,3) - Temp1=Vxyz(iZeta,1,ixa,ixb,1)* - & Rnxyz(iZeta,2,iya,iyb)* - & Rnxyz(iZeta,3,iza,izb) - Temp2=Vxyz(iZeta,1,ixa,ixb,2)* - & Rnxyz(iZeta,2,iya,iyb)* - & Rnxyz(iZeta,3,iza,izb) - Tempp = Exp(i*k_dot_P) * Fact * (Temp1+Temp2) * Half - Tempm = Exp(i*k_dot_P) * Fact * (Temp1-Temp2) * Half - Final(iZeta,ipa,ipb,1) = DBLE(Tempp) - Final(iZeta,ipa,ipb,4) = DBLE(Tempm) - Final(iZeta,ipa,ipb,7) = DIMAG(Tempp) - Final(iZeta,ipa,ipb,10)= DIMAG(Tempm) - Temp1=Rnxyz(iZeta,1,ixa,ixb)* - & Vxyz(iZeta,2,iya,iyb,1)* - & Rnxyz(iZeta,3,iza,izb) - Temp2=Rnxyz(iZeta,1,ixa,ixb)* - & Vxyz(iZeta,2,iya,iyb,2)* - & Rnxyz(iZeta,3,iza,izb) - Tempp = Exp(i*k_dot_P) * Fact * (Temp1+Temp2) * Half - Tempm = Exp(i*k_dot_P) * Fact * (Temp1-Temp2) * Half - Final(iZeta,ipa,ipb,2) = DBLE(Tempp) - Final(iZeta,ipa,ipb,5) = DBLE(Tempm) - Final(iZeta,ipa,ipb,8) = DIMAG(Tempp) - Final(iZeta,ipa,ipb,11)= DIMAG(Tempm) - Temp1=Rnxyz(iZeta,1,ixa,ixb)* - & Rnxyz(iZeta,2,iya,iyb)* - & Vxyz(iZeta,3,iza,izb,1) - Temp2=Rnxyz(iZeta,1,ixa,ixb)* - & Rnxyz(iZeta,2,iya,iyb)* - & Vxyz(iZeta,3,iza,izb,2) - Tempp = Exp(i*k_dot_P) * Fact * (Temp1+Temp2) * Half - Tempm = Exp(i*k_dot_P) * Fact * (Temp1-Temp2) * Half - Final(iZeta,ipa,ipb,3) = DBLE(Tempp) - Final(iZeta,ipa,ipb,6 )= DBLE(Tempm) - Final(iZeta,ipa,ipb,9 )= DIMAG(Tempp) - Final(iZeta,ipa,ipb,12)= DIMAG(Tempm) - 30 Continue - If (iPrint.ge.99) Then - Write (6,*) '(',ixa,iya,iza,ixb,iyb,izb,')' - Write (6,*) 'x-component' - Write (6,*) Final(1,ipa,ipb,1) - Write (6,*) Final(1,ipa,ipb,4) - Write (6,*) Final(1,ipa,ipb,7) - Write (6,*) Final(1,ipa,ipb,10) - Write (6,*) 'y-component' - Write (6,*) Final(1,ipa,ipb,2) - Write (6,*) Final(1,ipa,ipb,5) - Write (6,*) Final(1,ipa,ipb,8) - Write (6,*) Final(1,ipa,ipb,11) - Write (6,*) 'z-component' - Write (6,*) Final(1,ipa,ipb,3) - Write (6,*) Final(1,ipa,ipb,6) - Write (6,*) Final(1,ipa,ipb,9) - Write (6,*) Final(1,ipa,ipb,12) - End If -* - 21 Continue - 20 Continue - 11 Continue - 10 Continue -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/ccmbnve.F90 openmolcas-22.10/src/oneint_util/ccmbnve.F90 --- openmolcas-22.02/src/oneint_util/ccmbnve.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/ccmbnve.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,111 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine CCmbnVe(Rnxyz,nZeta,la,lb,Zeta,rKappa,rFinal,nComp,Vxyz,KVector,P) +!*********************************************************************** +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! January 91 * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: Half, Quart, OneHalf, Onei +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb, nComp +complex(kind=wp), intent(in) :: Rnxyz(nZeta,3,0:la+1,0:lb+1), Vxyz(nZeta,3,0:la,0:lb,2) +real(kind=wp), intent(in) :: Zeta(nZeta), rKappa(nZeta), kVector(3), P(nZeta,3) +real(kind=wp), intent(out) :: rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),nComp) +#include "print.fh" +integer(kind=iwp) :: ipa, ipb, iPrint, iRout, ixa, ixb, iya, iyaMax, iyb, iybMax, iza, izb, iZeta +real(kind=wp) :: Fact, k_dot_P, kModQ, rTemp +complex(kind=wp) :: Temp1, Temp2, Tempm, Tempp + +iRout = 161 +iPrint = nPrint(iRout) + +kModQ = Quart*(kVector(1)**2+kVector(2)**2+kVector(3)**2) + +do ixa=0,la + iyaMax = la-ixa + do ixb=0,lb + iybMax = lb-ixb + do iya=0,iyaMax + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + do iyb=0,iybMax + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + + ! Combine integrals + + do iZeta=1,nZeta + + ! Put in the correct prefactors + + rTemp = kModQ/Zeta(iZeta) + Fact = rKappa(iZeta)*Zeta(iZeta)**(-OneHalf)*exp(-rTemp) + k_dot_P = kVector(1)*P(iZeta,1)+kVector(2)*P(iZeta,2)+kVector(3)*P(iZeta,3) + Temp1 = Vxyz(iZeta,1,ixa,ixb,1)*Rnxyz(iZeta,2,iya,iyb)*Rnxyz(iZeta,3,iza,izb) + Temp2 = Vxyz(iZeta,1,ixa,ixb,2)*Rnxyz(iZeta,2,iya,iyb)*Rnxyz(iZeta,3,iza,izb) + Tempp = exp(Onei*k_dot_P)*Fact*(Temp1+Temp2)*Half + Tempm = exp(Onei*k_dot_P)*Fact*(Temp1-Temp2)*Half + rFinal(iZeta,ipa,ipb,1) = real(Tempp) + rFinal(iZeta,ipa,ipb,4) = real(Tempm) + rFinal(iZeta,ipa,ipb,7) = aimag(Tempp) + rFinal(iZeta,ipa,ipb,10) = aimag(Tempm) + Temp1 = Rnxyz(iZeta,1,ixa,ixb)*Vxyz(iZeta,2,iya,iyb,1)*Rnxyz(iZeta,3,iza,izb) + Temp2 = Rnxyz(iZeta,1,ixa,ixb)*Vxyz(iZeta,2,iya,iyb,2)*Rnxyz(iZeta,3,iza,izb) + Tempp = exp(Onei*k_dot_P)*Fact*(Temp1+Temp2)*Half + Tempm = exp(Onei*k_dot_P)*Fact*(Temp1-Temp2)*Half + rFinal(iZeta,ipa,ipb,2) = real(Tempp) + rFinal(iZeta,ipa,ipb,5) = real(Tempm) + rFinal(iZeta,ipa,ipb,8) = aimag(Tempp) + rFinal(iZeta,ipa,ipb,11) = aimag(Tempm) + Temp1 = Rnxyz(iZeta,1,ixa,ixb)*Rnxyz(iZeta,2,iya,iyb)*Vxyz(iZeta,3,iza,izb,1) + Temp2 = Rnxyz(iZeta,1,ixa,ixb)*Rnxyz(iZeta,2,iya,iyb)*Vxyz(iZeta,3,iza,izb,2) + Tempp = exp(Onei*k_dot_P)*Fact*(Temp1+Temp2)*Half + Tempm = exp(Onei*k_dot_P)*Fact*(Temp1-Temp2)*Half + rFinal(iZeta,ipa,ipb,3) = real(Tempp) + rFinal(iZeta,ipa,ipb,6) = real(Tempm) + rFinal(iZeta,ipa,ipb,9) = aimag(Tempp) + rFinal(iZeta,ipa,ipb,12) = aimag(Tempm) + end do + if (iPrint >= 99) then + write(u6,*) '(',ixa,iya,iza,ixb,iyb,izb,')' + write(u6,*) 'x-component' + write(u6,*) rFinal(1,ipa,ipb,1) + write(u6,*) rFinal(1,ipa,ipb,4) + write(u6,*) rFinal(1,ipa,ipb,7) + write(u6,*) rFinal(1,ipa,ipb,10) + write(u6,*) 'y-component' + write(u6,*) rFinal(1,ipa,ipb,2) + write(u6,*) rFinal(1,ipa,ipb,5) + write(u6,*) rFinal(1,ipa,ipb,8) + write(u6,*) rFinal(1,ipa,ipb,11) + write(u6,*) 'z-component' + write(u6,*) rFinal(1,ipa,ipb,3) + write(u6,*) rFinal(1,ipa,ipb,6) + write(u6,*) rFinal(1,ipa,ipb,9) + write(u6,*) rFinal(1,ipa,ipb,12) + end if + + end do + end do + end do +end do + +return + +end subroutine CCmbnVe diff -Nru openmolcas-22.02/src/oneint_util/ccrtcmp.f openmolcas-22.10/src/oneint_util/ccrtcmp.f --- openmolcas-22.02/src/oneint_util/ccrtcmp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/ccrtcmp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,94 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990,2015, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine CCrtCmp(Zeta,P,nZeta,A,Axyz,na,HerR,nHer,ABeq,KVector) -************************************************************************ -* * -* Object: to compile the value of the angular part of a basis function * -* evaluated at a root of the quadrature. * -* * -* Called from: PrpInt * -* * -* Calling : * -* RecPrt * -* DCopy (ESSL) * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* November '90 * -* * -* Roland Lindh, Uppsala Universitet, Uppsala Sweden * -* December 2015. * -* Modification to wave vectors and complex representation. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Zeta(nZeta), P(nZeta,3), A(3), HerR(nHer), KVector(3) - Complex*16 Axyz(nZeta,3,nHer,0:na) - Character*80 Label - Logical ABeq(3) -* - iRout = 116 - iPrint = nPrint(iRout) -* - If (na.lt.0) Then - Call WarningMessage(2,'CCrtCmp: na.lt.0') - Call Abend() - End If - If (iPrint.ge.99) Then - Call RecPrt(' In CCrtCmp: HerR',' ',HerR,1,nHer) - Call RecPrt(' In CCrtCmp: Zeta',' ',Zeta,nZeta,1) - Call RecPrt(' In CCrtCmp: A ',' ',A ,1 ,3) - Call RecPrt(' In CCrtCmp: P ',' ',P ,nZeta,3) - Call RecPrt(' In CCrtCmp: KVec',' ',KVector,1,3) - End If - Do iHer = 1, nHer - Do iCar = 1, 3 - Do iZeta = 1, nZeta - Axyz(iZeta,iCar,iHer,0) = DCMPLX(One,Zero) - End Do - End Do - End Do - If (na.eq.0) Go to 99 -* - Do iHer = 1, nHer - Do iCar = 1, 3 -* - Do iZeta = 1, nZeta - Axyz(iZeta,iCar,iHer,1) = - & DCMPLX( - & HerR(iHer)*1/Sqrt(Zeta(iZeta)) + - & P(iZeta,iCar) - A(iCar), - & KVector(iCar)/(Two*Zeta(iZeta))) - End Do -* - Do ia = 2, na - Do iZeta = 1, nZeta - Axyz(iZeta,iCar,iHer,ia) = Axyz(iZeta,iCar,iHer,1) * - & Axyz(iZeta,iCar,iHer,ia-1) - End Do - End Do -* - End Do - End Do - 99 Continue -* - If (iPrint.ge.99) Then - Write (Label,'(A)') ' In CCrtCmp: Axyz ' - Call CRecPrt(Label,' ',Axyz,nZeta*3,nHer*(na+1),'R') - Call CRecPrt(Label,' ',Axyz,nZeta*3,nHer*(na+1),'I') - End If - Return -c Avoid unused argument warnings - If (.False.) Call Unused_logical_array(ABeq) - End diff -Nru openmolcas-22.02/src/oneint_util/ccrtcmp.F90 openmolcas-22.10/src/oneint_util/ccrtcmp.F90 --- openmolcas-22.02/src/oneint_util/ccrtcmp.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/ccrtcmp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,83 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990,2015, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine CCrtCmp(Zeta,P,nZeta,A,Axyz,na,HerR,nHer,kVector) +!*********************************************************************** +! * +! Object: to compile the value of the angular part of a basis function * +! evaluated at a root of the quadrature. * +! * +! Called from: PrpInt * +! * +! Calling : * +! RecPrt * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! November '90 * +! * +! Roland Lindh, Uppsala Universitet, Uppsala Sweden * +! December 2015. * +! Modification to wave vectors and complex representation. * +!*********************************************************************** + +use Constants, only: Two, cOne +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, na, nHer +real(kind=wp), intent(in) :: Zeta(nZeta), P(nZeta,3), A(3), HerR(nHer), kVector(3) +complex(kind=wp), intent(out) :: Axyz(nZeta,3,nHer,0:na) +#include "print.fh" +integer(kind=iwp) :: ia, iCar, iHer, iPrint, iRout +character(len=80) :: Label + +iRout = 116 +iPrint = nPrint(iRout) + +if (na < 0) then + call WarningMessage(2,'CCrtCmp: na < 0') + call Abend() +end if +if (iPrint >= 99) then + call RecPrt(' In CCrtCmp: HerR',' ',HerR,1,nHer) + call RecPrt(' In CCrtCmp: Zeta',' ',Zeta,nZeta,1) + call RecPrt(' In CCrtCmp: A ',' ',A,1,3) + call RecPrt(' In CCrtCmp: P ',' ',P,nZeta,3) + call RecPrt(' In CCrtCmp: KVec',' ',kVector,1,3) +end if +Axyz(:,:,:,0) = cOne + +if (na /= 0) then + do iHer=1,nHer + do iCar=1,3 + + Axyz(:,iCar,iHer,1) = cmplx(HerR(iHer)/sqrt(Zeta)+P(:,iCar)-A(iCar),kVector(iCar)/(Two*Zeta),kind=wp) + + do ia=2,na + Axyz(:,iCar,iHer,ia) = Axyz(:,iCar,iHer,1)*Axyz(:,iCar,iHer,ia-1) + end do + + end do + end do +end if + +if (iPrint >= 99) then + write(Label,'(A)') ' In CCrtCmp: Axyz ' + call CRecPrt(Label,' ',Axyz,nZeta*3,nHer*(na+1),'R') + call CRecPrt(Label,' ',Axyz,nZeta*3,nHer*(na+1),'I') +end if + +return + +end subroutine CCrtCmp diff -Nru openmolcas-22.02/src/oneint_util/CMakeLists.txt openmolcas-22.10/src/oneint_util/CMakeLists.txt --- openmolcas-22.02/src/oneint_util/CMakeLists.txt 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -9,4 +9,112 @@ # LICENSE or in . * #*********************************************************************** +set (sources + ampint.F90 + ampmem.F90 + ampr.F90 + assemble_dtdmu.F90 + assemble_dvdb.F90 + assemble_mgauss.F90 + assmbl.F90 + ass_px.F90 + ass_pxp.F90 + cassmbl.F90 + ccmbnmp.F90 + ccmbnve.F90 + ccrtcmp.F90 + cmbnke.F90 + cmbnke_giao.F90 + cmbnker.F90 + cmbnmp_giao.F90 + cmbnmv.F90 + cmbnve.F90 + cntint.F90 + cntmem.F90 + contact.F90 + cvelint.F90 + d1int.F90 + d1mem.F90 + darwin.F90 + dmsint.F90 + dmsmem.F90 + dtdmu_int.F90 + dtdmu_mem.F90 + dumint.F90 + dummem.F90 + efint.F90 + efmem.F90 + emfint.F90 + emfmem.F90 + epeint.F90 + epemem.F90 + kneint.F90 + kneint_giao.F90 + knemem.F90 + knemem_giao.F90 + knemmp.F90 + kntc.F90 + kntc_giao.F90 + m1int.F90 + m1mem.F90 + m2int.F90 + m2mem.F90 + mltint.F90 + mltint_giao.F90 + mltmem.F90 + mltmem_giao.F90 + mltmmp.F90 + mve.F90 + mveint.F90 + mvemem.F90 + naint.F90 + naint_giao.F90 + namem.F90 + namem_giao.F90 + oamint.F90 + oammem.F90 + omqint.F90 + omqmem.F90 + one2h5_crtmom.F90 + one2h5_fckint.F90 + one2h5_ovlmat.F90 + pam2.F90 + pam2int.F90 + pam2mem.F90 + p_int.F90 + p_mem.F90 + potint.F90 + pot_nuc.F90 + prjint.F90 + prjmem.F90 + pvint.F90 + pvmem.F90 + pxint.F90 + pxmem.F90 + pxpint.F90 + pxpmem.F90 + qpvint.F90 + qpvmem.F90 + sroint.F90 + sromem.F90 + util1.F90 + util2.F90 + util3.F90 + util4.F90 + util5.F90 + util8.F90 + veint.F90 + velint.F90 + vemem.F90 + vpint.F90 + vpmem.F90 + welint.F90 + welmem.F90 + xfdint.F90 + xfdmem.F90 +) + +# Source files defining modules that should be available to other *_util directories +set (modfile_list "") + include (${PROJECT_SOURCE_DIR}/cmake/util_template.cmake) diff -Nru openmolcas-22.02/src/oneint_util/cmbnke.f openmolcas-22.10/src/oneint_util/cmbnke.f --- openmolcas-22.02/src/oneint_util/cmbnke.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/cmbnke.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,74 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine CmbnKE(Rnxyz,nZeta,la,lb,lr,Zeta,rKappa,Final,nComp, - & Txyz) -************************************************************************ -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Final(nZeta,nComp,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2), - & Zeta(nZeta), rKappa(nZeta), - & Rnxyz(nZeta,3,0:la+1,0:lb+1,0:lr), - & Txyz(nZeta,3,0:la,0:lb) -* -* Statement function for Cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 -* -* iRout = 134 -* iPrint = nPrint(iRout) -* Call GetMem(' Enter CmbnKE','LIST','REAL',iDum,iDum) -* - iComp = 1 - Do 10 ixa = 0, la - iyaMax=la-ixa - Do 11 ixb = 0, lb - iybMax=lb-ixb - Do 20 iya = 0, iyaMax - iza = la-ixa-iya - ipa= Ind(la,ixa,iza) - Do 21 iyb = 0, iybMax - izb = lb-ixb-iyb - ipb= Ind(lb,ixb,izb) -* If (iPrint.ge.99) Then -* Write (*,*) ixa,iya,iza,ixb,iyb,izb -* Write (*,*) ipa,ipb -* End If -* -* Combine integrals -* - Do 30 iZeta = 1, nZeta - Tmp = Txyz (iZeta,1,ixa,ixb)* - & Rnxyz(iZeta,2,iya,iyb,0)* - & Rnxyz(iZeta,3,iza,izb,0) + - & Rnxyz(iZeta,1,ixa,ixb,0)* - & Txyz( iZeta,2,iya,iyb)* - & Rnxyz(iZeta,3,iza,izb,0) + - & Rnxyz(iZeta,1,ixa,ixb,0)* - & Rnxyz(iZeta,2,iya,iyb,0)* - & Txyz (iZeta,3,iza,izb) - Final(iZeta,iComp,ipa,ipb) = rKappa(iZeta) * - & Zeta(iZeta)**(-Three/Two) * Tmp - 30 Continue -* - 21 Continue - 20 Continue - 11 Continue - 10 Continue -* -* Call GetMem(' Exit CmbnKE','LIST','REAL',iDum,iDum) - Return - End diff -Nru openmolcas-22.02/src/oneint_util/cmbnke.F90 openmolcas-22.10/src/oneint_util/cmbnke.F90 --- openmolcas-22.02/src/oneint_util/cmbnke.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/cmbnke.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,62 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine CmbnKE(Rnxyz,nZeta,la,lb,lr,Zeta,rKappa,rFinal,nComp,Txyz) +!*********************************************************************** +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: OneHalf +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb, lr, nComp +real(kind=wp), intent(in) :: Rnxyz(nZeta,3,0:la+1,0:lb+1,0:lr), Zeta(nZeta), rKappa(nZeta), Txyz(nZeta,3,0:la,0:lb) +real(kind=wp), intent(out) :: rFinal(nZeta,nComp,nTri_Elem1(la),nTri_Elem1(lb)) +integer(kind=iwp) :: iComp, ipa, ipb, ixa, ixb, iya, iyaMax, iyb, iybMax, iza, izb + +!iRout = 134 +!iPrint = nPrint(iRout) + +iComp = 1 +do ixa=0,la + iyaMax = la-ixa + do ixb=0,lb + iybMax = lb-ixb + do iya=0,iyaMax + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + do iyb=0,iybMax + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + !if (iPrint >= 99) then + ! write(u6,*) ixa,iya,iza,ixb,iyb,izb + ! write(u6,*) ipa,ipb + !end if + + ! Combine integrals + + rFinal(:,iComp,ipa,ipb) = rKappa*Zeta**(-OneHalf)*(Txyz(:,1,ixa,ixb)*Rnxyz(:,2,iya,iyb,0)*Rnxyz(:,3,iza,izb,0)+ & + Rnxyz(:,1,ixa,ixb,0)*Txyz(:,2,iya,iyb)*Rnxyz(:,3,iza,izb,0)+ & + Rnxyz(:,1,ixa,ixb,0)*Rnxyz(:,2,iya,iyb,0)*Txyz(:,3,iza,izb)) + + end do + end do + end do +end do + +return + +end subroutine CmbnKE diff -Nru openmolcas-22.02/src/oneint_util/cmbnke_giao.f openmolcas-22.10/src/oneint_util/cmbnke_giao.f --- openmolcas-22.02/src/oneint_util/cmbnke_giao.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/cmbnke_giao.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,150 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991,2002, Roland Lindh * -************************************************************************ - SubRoutine CmbnKE_GIAO(Rxyz,nZeta,la,lb,lr,Zeta,rKappa,Final, - & nComp,nB,Txyz,Wxyz,A,RB,C) -************************************************************************ -* * -* Object: to compute the first derivative of the kinetic energy * -* integrals with respect to the magnetic field. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* * -* Modified for GIAO's by RL June 2002, Tokyo, Japan. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Final(nZeta,nComp,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nB), - & Zeta(nZeta), rKappa(nZeta), - & Rxyz(nZeta,3,0:la+1,0:lb+1,0:lr+1), - & Txyz(nZeta,3,0:la ,0:lb ,0:lr+1), - & Wxyz(nZeta,3,0:la ,0:lb ,2), - & A(3), RB(3), RAB(3), C(3) - Integer Index(3,2) -* -* Statement function for Cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 -* -* iRout = 134 -* iPrint = nPrint(iRout) -* - RAB(1)=A(1)-RB(1) - RAB(2)=A(2)-RB(2) - RAB(3)=A(3)-RB(3) -* - iComp = 1 - Do ixa = 0, la - iyaMax=la-ixa - Index(1,1)=ixa - Do ixb = 0, lb - iybMax=lb-ixb - Index(1,2)=ixb - Do iya = 0, iyaMax - iza = la-ixa-iya - Index(2,1)=iya - Index(3,1)=iza - ipa= Ind(la,ixa,iza) - Do iyb = 0, iybMax - izb = lb-ixb-iyb - Index(2,2)=iyb - Index(3,2)=izb - ipb= Ind(lb,ixb,izb) -* -* If (iPrint.ge.99) Then -* Write (*,*) -* Write (*,*) ixa,iya,iza -* Write (*,*) ixb,iyb,izb -* Write (*,*) ipa,ipb -* End If -* * -************************************************************************ -* * -* Loop over components of B -* - Do iBx = 1, 3 - iBy=iBx+1-((iBx+1)/4)*3 - iBz=iBy+1-((iBy+1)/4)*3 - jxa=Index(iBx,1) - jxb=Index(iBx,2) - jya=Index(iBy,1) - jyb=Index(iBy,2) - jza=Index(iBz,1) - jzb=Index(iBz,2) -* Write (*,*) 'iBx,iBy,iBz=',iBx,iBy,iBz -* Write (*,*) 'nZeta=',nZeta -* Write (*,*) jxa,jya,jza -* Write (*,*) jxb,jyb,jzb -* * -************************************************************************ -* * -* Combine integrals -* - Do iZeta = 1, nZeta -* - Fact = rKappa(iZeta) * Zeta(iZeta)**(-Three/Two) -* - temp1= Rxyz(iZeta,iBx,jxa ,jxb ,0) * - & (+Wxyz(iZeta,iBy,jya ,jyb ,2) - & *Rxyz(iZeta,iBz,jza+1,jzb ,0) - & -Rxyz(iZeta,iBy,jya+1,jyb ,0) - & *Wxyz(iZeta,iBz,jza ,jzb ,2) - & -Wxyz(iZeta,iBy,jya ,jyb ,1) - & *Rxyz(iZeta,iBz,jza ,jzb+1,0) - & +Rxyz(iZeta,iBy,jya ,jyb+1,0) - & *Wxyz(iZeta,iBz,jza ,jzb ,1)) -* - temp2a= Txyz(iZeta,iBx,jxa ,jxb ,0)* ( - & RAB(iBy)*Rxyz(iZeta,iBy,jya ,jyb ,0) * - & ( Rxyz(iZeta,iBz,jza ,jzb ,1) - & +Rxyz(iZeta,iBz,jza ,jzb ,0)*C(iBz) ) - & - ( Rxyz(iZeta,iBy,jya ,jyb ,1) - & +Rxyz(iZeta,iBy,jya ,jyb ,0)*C(iBy) ) - & *RAB(iBz)*Rxyz(iZeta,iBz,jza ,jzb ,0) ) -* - temp2b= Rxyz(iZeta,iBx,jxa ,jxb ,0)* ( - & RAB(iBy)*Txyz(iZeta,iBy,jya ,jyb ,0) * - & ( Rxyz(iZeta,iBz,jza ,jzb ,1) - & +Rxyz(iZeta,iBz,jza ,jzb ,0)*C(iBz) ) - & - ( Txyz(iZeta,iBy,jya ,jyb ,1) - & +Txyz(iZeta,iBy,jya ,jyb ,0)*C(iBy) ) - & *RAB(iBz)*Rxyz(iZeta,iBz,jza ,jzb ,0) ) -* - temp2c= Rxyz(iZeta,iBx,jxa ,jxb ,0)* ( - & RAB(iBy)*Rxyz(iZeta,iBy,jya ,jyb ,0) * - & ( Txyz(iZeta,iBz,jza ,jzb ,1) - & +Txyz(iZeta,iBz,jza ,jzb ,0)*C(iBz) ) - & - ( Rxyz(iZeta,iBy,jya ,jyb ,1) - & +Rxyz(iZeta,iBy,jya ,jyb ,0)*C(iBy) ) - & *RAB(iBz)*Txyz(iZeta,iBz,jza ,jzb ,0) ) -* - Final(iZeta,iComp,ipa,ipb,iBx) = Half* Fact * ( - & temp1 + Half*(temp2a + temp2b + temp2c) - & ) - End Do -* Write (*,*) -* * -************************************************************************ -* * - End Do ! iBx -* * -************************************************************************ -* * - End Do - End Do - End Do - End Do -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/cmbnke_giao.F90 openmolcas-22.10/src/oneint_util/cmbnke_giao.F90 --- openmolcas-22.02/src/oneint_util/cmbnke_giao.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/cmbnke_giao.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,132 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991,2002, Roland Lindh * +!*********************************************************************** + +subroutine CmbnKE_GIAO(Rxyz,nZeta,la,lb,lr,Zeta,rKappa,rFinal,nComp,nB,Txyz,Wxyz,A,RB,C) +!*********************************************************************** +! * +! Object: to compute the first derivative of the kinetic energy * +! integrals with respect to the magnetic field. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! * +! Modified for GIAO's by RL June 2002, Tokyo, Japan. * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: Half, OneHalf +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb, lr, nComp, nB +real(kind=wp), intent(in) :: Rxyz(nZeta,3,0:la+1,0:lb+1,0:lr+1), Zeta(nZeta), rKappa(nZeta), Txyz(nZeta,3,0:la,0:lb,0:lr+1), & + Wxyz(nZeta,3,0:la,0:lb,2), A(3), RB(3), C(3) +real(kind=wp), intent(out) :: rFinal(nZeta,nComp,nTri_Elem1(la),nTri_Elem1(lb),nB) +integer(kind=iwp) :: iBx, iBy, iBz, iComp, indx(3,2), ipa, ipb, ixa, ixb, iya, iyaMax, iyb, iybMax, iza, izb, iZeta, jxa, jxb, & + jya, jyb, jza, jzb +real(kind=wp) :: Fact, RAB(3), temp1, temp2a, temp2b, temp2c + +!iRout = 134 +!iPrint = nPrint(iRout) + +RAB(:) = A-RB + +iComp = 1 +do ixa=0,la + iyaMax = la-ixa + indx(1,1) = ixa + do ixb=0,lb + iybMax = lb-ixb + indx(1,2) = ixb + do iya=0,iyaMax + iza = la-ixa-iya + indx(2,1) = iya + indx(3,1) = iza + ipa = C_Ind(la,ixa,iza) + do iyb=0,iybMax + izb = lb-ixb-iyb + indx(2,2) = iyb + indx(3,2) = izb + ipb = C_Ind(lb,ixb,izb) + + !if (iPrint >= 99) then + ! write(u6,*) + ! write(u6,*) ixa,iya,iza + ! write(u6,*) ixb,iyb,izb + ! write(u6,*) ipa,ipb + !end if + ! * + !*************************************************************** + ! * + ! Loop over components of B + + do iBx=1,3 + iBy = iBx+1-((iBx+1)/4)*3 + iBz = iBy+1-((iBy+1)/4)*3 + jxa = indx(iBx,1) + jxb = indx(iBx,2) + jya = indx(iBy,1) + jyb = indx(iBy,2) + jza = indx(iBz,1) + jzb = indx(iBz,2) + !write(u6,*) 'iBx,iBy,iBz=',iBx,iBy,iBz + !write(u6,*) 'nZeta=',nZeta + !write(u6,*) jxa,jya,jza + !write(u6,*) jxb,jyb,jzb + ! * + !************************************************************* + ! * + ! Combine integrals + + do iZeta=1,nZeta + + Fact = rKappa(iZeta)*Zeta(iZeta)**(-OneHalf) + + temp1 = Rxyz(iZeta,iBx,jxa,jxb,0)*(Wxyz(iZeta,iBy,jya,jyb,2)*Rxyz(iZeta,iBz,jza+1,jzb,0)- & + Rxyz(iZeta,iBy,jya+1,jyb,0)*Wxyz(iZeta,iBz,jza,jzb,2)- & + Wxyz(iZeta,iBy,jya,jyb,1)*Rxyz(iZeta,iBz,jza,jzb+1,0)+ & + Rxyz(iZeta,iBy,jya,jyb+1,0)*Wxyz(iZeta,iBz,jza,jzb,1)) + + temp2a = Txyz(iZeta,iBx,jxa,jxb,0)*(RAB(iBy)*Rxyz(iZeta,iBy,jya,jyb,0)* & + (Rxyz(iZeta,iBz,jza,jzb,1)+Rxyz(iZeta,iBz,jza,jzb,0)*C(iBz))- & + (Rxyz(iZeta,iBy,jya,jyb,1)+Rxyz(iZeta,iBy,jya,jyb,0)*C(iBy))* & + RAB(iBz)*Rxyz(iZeta,iBz,jza,jzb,0)) + + temp2b = Rxyz(iZeta,iBx,jxa,jxb,0)*(RAB(iBy)*Txyz(iZeta,iBy,jya,jyb,0)* & + (Rxyz(iZeta,iBz,jza,jzb,1)+Rxyz(iZeta,iBz,jza,jzb,0)*C(iBz))- & + (Txyz(iZeta,iBy,jya,jyb,1)+Txyz(iZeta,iBy,jya,jyb,0)*C(iBy))* & + RAB(iBz)*Rxyz(iZeta,iBz,jza,jzb,0)) + + temp2c = Rxyz(iZeta,iBx,jxa,jxb,0)*(RAB(iBy)*Rxyz(iZeta,iBy,jya,jyb,0)* & + (Txyz(iZeta,iBz,jza,jzb,1)+Txyz(iZeta,iBz,jza,jzb,0)*C(iBz))- & + (Rxyz(iZeta,iBy,jya,jyb,1)+Rxyz(iZeta,iBy,jya,jyb,0)*C(iBy))* & + RAB(iBz)*Txyz(iZeta,iBz,jza,jzb,0)) + + rFinal(iZeta,iComp,ipa,ipb,iBx) = Half*Fact*(temp1+Half*(temp2a+temp2b+temp2c)) + end do + !write(u6,*) + ! * + !************************************************************* + ! * + end do ! iBx + ! * + !*************************************************************** + ! * + end do + end do + end do +end do + +return + +end subroutine CmbnKE_GIAO diff -Nru openmolcas-22.02/src/oneint_util/cmbnker.f openmolcas-22.10/src/oneint_util/cmbnker.f --- openmolcas-22.02/src/oneint_util/cmbnker.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/cmbnker.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,218 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) Kurt Pfingst * -************************************************************************ - SubRoutine CmbnKEr(Rnr,qC,Di,nZeta,la,lb,Zeta,Final,nComp,Alpha, - & nAlpha,Beta,nBeta) -************************************************************************ -* Author: Kurt Pfingst * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" -#include "nrmf.fh" -#include "rmat.fh" -#include "gam.fh" - Real*8 Final(nZeta,nComp,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2), - * Zeta(nZeta),Rnr(nZeta,0:la+lb+2),qC(nZeta,0:la+lb), - * Di(nZeta,-1:la+lb-1),Alpha(nAlpha),Beta(nBeta) - Character*80 Label -* -* Statement function for Cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 -* - iRout = 134 - iPrint = nPrint(iRout) -* Call GetMem(' Enter CmbnKE','LIST','REAL',iDum,iDum) -* - iComp = 1 - Do 10 ixa = 0, la - Do 11 ixb = 0, lb - rx1=DBLE(ixb*(ixb-1)) - n=ixa+ixb - Do 20 iya = 0, la-ixa - iza = la-ixa-iya - ipa= Ind(la,ixa,iza) - Do 21 iyb = 0, lb-ixb - izb = lb-ixb-iyb - ipb= Ind(lb,ixb,izb) - ry1=DBLE(iyb*(iyb-1)) - m=iya+iyb - rz1=DBLE(izb*(izb-1)) - k=iza+izb -* -* Combine integrals -* define various factors -************************************************************** - ck1=2d0*DBLE(ixb+iyb+izb)+3d0 -************************************************************** -************************************************************** - const1=rx1*gammath(n+m-2,k)*gammaph(m,n-2) -************************************************************** - const2=ry1*gammath(n+m-2,k)*gammaph(m-2,n) -************************************************************** - const3=rz1*gammath(n+m,k-2)*gammaph(m,n) -************************************************************** - CConst1=const1+const2+const3 -************************************************************** -************************************************************** - CConst2=ck1*gammath(n+m,k)*gammaph(m,n) -************************************************************** - CConst3=gammath(n+m,k)*gammaph(m,n) -************************************************************** -* Constants for Bloch term b1/b2/b3 - na=ixa+iya+iza - nb=ixb+iyb+izb - b1 =0.5D0*(DBLE(nb)+1.d0)*rmatr**(na+nb+1) - b1a=0.5D0*(DBLE(na)+1.d0)*rmatr**(na+nb+1) - W=gammath(n+m,k)*gammaph(m,n) -* - ibeta=1 - ialpha=1 - kc=1 - Do 30 iZeta = 1, nZeta - ralpha=alpha(ialpha) - rbeta=beta(ibeta) - b2 =rbeta*rmatr**(na+nb+3) - b2a=ralpha*rmatr**(na+nb+3) - b3=exp(-Zeta(iZeta)*rmatr*rmatr) - BBLoch=W*b3*((b1-b2)-bParm*(b1-b2)*(b1a-b2a)) - c0=0.5d0 - c1=-rbeta - c2= 2d0*rbeta*rbeta - Final(iZeta,iComp,ipa,ipb) = - & BBloch - & -(c0*CConst1*Rnr(iZeta,n+m+k-2)+ - & c1*CConst2*Rnr(iZeta,n+m+k)+ - & c2*CConst3*Rnr(iZeta,n+m+k+2)) - if(iZeta.eq.kc*nalpha) then - ibeta=ibeta+1 - ialpha=0 - kc=kc+1 - endif - ialpha=ialpha+1 -30 Continue -* -21 Continue -20 Continue -11 Continue -10 Continue -* -************************************************************************ -* - If (iPrint.ge.99) Then - Write (6,*) ' Result in Cmbnker1' - Do ia = 1, (la+1)*(la+2)/2 - Do ib = 1, (lb+1)*(lb+2)/2 - Write (Label,'(A,I2,A,I2,A)') - * ' Final(',ia,',',ib,')' - Call RecPrt(Label,' ',Final(1,1,ia,ib),nZeta,nComp) - End Do - End Do - End If -* -************************************************************************ -* -* Add Coulomb contributions for photoionization calculations -* -* -* - If(abs(qCoul).gt.Epsq) then - Do 210 ixa = 0, la - Do 211 ixb = 0, lb - Do 220 iya = 0, la-ixa - iza = la-ixa-iya - ipa= Ind(la,ixa,iza) - Do 221 iyb = 0, lb-ixb - izb = lb-ixb-iyb - ipb= Ind(lb,ixb,izb) - lrs=ixa+ixb+iya+iyb+iza+izb - lcost=iza+izb - lsint=ixa+ixb+iya+iyb - lsinf=iya+iyb - lcosf=ixa+ixb - Fact=gammath(lsint,lcost)*gammaph(lsinf,lcosf) - Do 230 iZeta = 1, nZeta - Final(iZeta,iComp,ipa,ipb) = Final(iZeta,iComp,ipa,ipb)+ - * Fact * qCoul * qC(iZeta,lrs) -230 Continue -* -221 Continue -220 Continue -211 Continue -210 Continue - endif -************************************************************************ -* - If (iPrint.ge.99) Then - Write (6,*) ' Result in Cmbnker2' - Do ia = 1, (la+1)*(la+2)/2 - Do ib = 1, (lb+1)*(lb+2)/2 - Write (Label,'(A,I2,A,I2,A)') - * ' Final(',ia,',',ib,')' - Call RecPrt(Label,' ',Final(1,1,ia,ib),nZeta,nComp) - End Do - End Do - End If -* -************************************************************************ -* -* Add DIPOL contributions for photoionization calculations -* -* -* -* - If(abs(Dipol1).gt.Epsq) then - Do ixa = 0, la - Do ixb = 0, lb - Do iya = 0, la-ixa - iza = la-ixa-iya - ipa= Ind(la,ixa,iza) - Do iyb = 0, lb-ixb - izb = lb-ixb-iyb - ipb= Ind(lb,ixb,izb) - lrs=ixa+ixb+iya+iyb+iza+izb -* Beitrag der x-Komponente - lcost=iza+izb - lsint=ixa+ixb+iya+iyb+1 - lsinf=iya+iyb - lcosf=ixa+ixb+1 - Fact1=Dipol(1)*gammath(lsint,lcost)*gammaph(lsinf,lcosf) -* Beitrag der y-Komponente - lcost=iza+izb - lsint=ixa+ixb+iya+iyb+1 - lsinf=iya+iyb+1 - lcosf=ixa+ixb - Fact2=Dipol(2)*gammath(lsint,lcost)*gammaph(lsinf,lcosf) -* Beitrag der z-Komponente - lcost=iza+izb+1 - lsint=ixa+ixb+iya+iyb - lsinf=iya+iyb - lcosf=ixa+ixb - Fact3=Dipol(3)*gammath(lsint,lcost)*gammaph(lsinf,lcosf) -* Summe - Fact=Fact1+Fact2+Fact3 - Do iZeta = 1, nZeta - Final(iZeta,iComp,ipa,ipb) = Final(iZeta,iComp,ipa,ipb)+ - * Fact * Di(iZeta,lrs) - End do -* - End do - End do - End do - End do - endif -************************************************************************ -* -* Call GetMem(' Exit CmbnKE','LIST','REAL',iDum,iDum) - Return - End diff -Nru openmolcas-22.02/src/oneint_util/cmbnker.F90 openmolcas-22.10/src/oneint_util/cmbnker.F90 --- openmolcas-22.02/src/oneint_util/cmbnker.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/cmbnker.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,203 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) Kurt Pfingst * +!*********************************************************************** + +subroutine CmbnKEr(Rnr,qC,Di,nZeta,la,lb,Zeta,rFinal,nComp,Alpha,nAlpha,Beta,nBeta) +!*********************************************************************** +! Author: Kurt Pfingst * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: Two, Three, Half +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb, nComp, nAlpha, nBeta +real(kind=wp), intent(in) :: Rnr(nZeta,0:la+lb+2), qC(nZeta,0:la+lb), Di(nZeta,-1:la+lb-1), Zeta(nZeta), Alpha(nAlpha), Beta(nBeta) +real(kind=wp), intent(out) :: rFinal(nZeta,nComp,nTri_Elem1(la),nTri_Elem1(lb)) +#include "print.fh" +#include "nrmf.fh" +#include "rmat.fh" +#include "gam.fh" +integer(kind=iwp) :: ia, ialpha, ib, ibeta, iComp, ipa, ipb, iPrint, iRout, ixa, ixb, iya, iyb, iza, izb, iZeta, k, kc, lrs, m, n, & + na, nb +real(kind=wp) :: b1, b1a, b2, b2a, b3, BBLoch, CConst1, CConst2, CConst3, ck1, const1, const2, const3, Fact, Fact1, Fact2, Fact3, & + ralpha, rbeta, rx1, ry1, rz1, W +character(len=80) :: Label + +iRout = 134 +iPrint = nPrint(iRout) + +iComp = 1 +do ixa=0,la + do ixb=0,lb + rx1 = real(ixb*(ixb-1),kind=wp) + n = ixa+ixb + do iya=0,la-ixa + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + do iyb=0,lb-ixb + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + ry1 = real(iyb*(iyb-1),kind=wp) + m = iya+iyb + rz1 = real(izb*(izb-1),kind=wp) + k = iza+izb + + ! Combine integrals + ! define various factors + !*************************************************** + ck1 = Two*real(ixb+iyb+izb,kind=wp)+Three + !*************************************************** + !*************************************************** + const1 = rx1*gammath(n+m-2,k)*gammaph(m,n-2) + !*************************************************** + const2 = ry1*gammath(n+m-2,k)*gammaph(m-2,n) + !*************************************************** + const3 = rz1*gammath(n+m,k-2)*gammaph(m,n) + !*************************************************** + !*************************************************** + CConst1 = const1+const2+const3 + !*************************************************** + CConst2 = ck1*gammath(n+m,k)*gammaph(m,n) + !*************************************************** + CConst3 = gammath(n+m,k)*gammaph(m,n) + !*************************************************** + ! Constants for Bloch term b1/b2/b3 + na = ixa+iya+iza + nb = ixb+iyb+izb + b1 = Half*(real(nb+1,kind=wp))*rmatr**(na+nb+1) + b1a = Half*(real(na+1,kind=wp))*rmatr**(na+nb+1) + W = gammath(n+m,k)*gammaph(m,n) + + ibeta = 1 + ialpha = 1 + kc = 1 + do iZeta=1,nZeta + ralpha = Alpha(ialpha) + rbeta = Beta(ibeta) + b2 = rbeta*rmatr**(na+nb+3) + b2a = ralpha*rmatr**(na+nb+3) + b3 = exp(-Zeta(iZeta)*rmatr**2) + BBLoch = W*b3*((b1-b2)-bParm*(b1-b2)*(b1a-b2a)) + rFinal(iZeta,iComp,ipa,ipb) = BBloch-(Half*CConst1*Rnr(iZeta,n+m+k-2)-rbeta*CConst2*Rnr(iZeta,n+m+k)+ & + Two*rbeta**2*CConst3*Rnr(iZeta,n+m+k+2)) + if (iZeta == kc*nAlpha) then + ibeta = ibeta+1 + ialpha = 0 + kc = kc+1 + end if + ialpha = ialpha+1 + end do + + end do + end do + end do +end do + +!*********************************************************************** + +if (iPrint >= 99) then + write(u6,*) ' Result in Cmbnker1' + do ia=1,(la+1)*(la+2)/2 + do ib=1,(lb+1)*(lb+2)/2 + write(Label,'(A,I2,A,I2,A)') ' rFinal(',ia,',',ib,')' + call RecPrt(Label,' ',rFinal(:,:,ia,ib),nZeta,nComp) + end do + end do +end if + +!*********************************************************************** + +! Add Coulomb contributions for photoionization calculations + +if (abs(qCoul) > Epsq) then + do ixa=0,la + do ixb=0,lb + do iya=0,la-ixa + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + do iyb=0,lb-ixb + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + lrs = ixa+ixb+iya+iyb+iza+izb + lcost = iza+izb + lsint = ixa+ixb+iya+iyb + lsinf = iya+iyb + lcosf = ixa+ixb + Fact = gammath(lsint,lcost)*gammaph(lsinf,lcosf) + rFinal(:,iComp,ipa,ipb) = rFinal(:,iComp,ipa,ipb)+Fact*qCoul*qC(:,lrs) + + end do + end do + end do + end do +end if + +!*********************************************************************** + +if (iPrint >= 99) then + write(u6,*) ' Result in Cmbnker2' + do ia=1,(la+1)*(la+2)/2 + do ib=1,(lb+1)*(lb+2)/2 + write(Label,'(A,I2,A,I2,A)') ' rFinal(',ia,',',ib,')' + call RecPrt(Label,' ',rFinal(:,:,ia,ib),nZeta,nComp) + end do + end do +end if + +!*********************************************************************** + +! Add DIPOL contributions for photoionization calculations + +if (abs(Dipol1) > Epsq) then + do ixa=0,la + do ixb=0,lb + do iya=0,la-ixa + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + do iyb=0,lb-ixb + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + lrs = ixa+ixb+iya+iyb+iza+izb + ! Beitrag der x-Komponente + lcost = iza+izb + lsint = ixa+ixb+iya+iyb+1 + lsinf = iya+iyb + lcosf = ixa+ixb+1 + Fact1 = Dipol(1)*gammath(lsint,lcost)*gammaph(lsinf,lcosf) + ! Beitrag der y-Komponente + lcost = iza+izb + lsint = ixa+ixb+iya+iyb+1 + lsinf = iya+iyb+1 + lcosf = ixa+ixb + Fact2 = Dipol(2)*gammath(lsint,lcost)*gammaph(lsinf,lcosf) + ! Beitrag der z-Komponente + lcost = iza+izb+1 + lsint = ixa+ixb+iya+iyb + lsinf = iya+iyb + lcosf = ixa+ixb + Fact3 = Dipol(3)*gammath(lsint,lcost)*gammaph(lsinf,lcosf) + ! Summe + rFinal(:,iComp,ipa,ipb) = rFinal(:,iComp,ipa,ipb)+(Fact1+Fact2+Fact3)*Di(:,lrs) + + end do + end do + end do + end do +end if + +!*********************************************************************** + +return + +end subroutine CmbnKEr diff -Nru openmolcas-22.02/src/oneint_util/cmbnmp_giao.f openmolcas-22.10/src/oneint_util/cmbnmp_giao.f --- openmolcas-22.02/src/oneint_util/cmbnmp_giao.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/cmbnmp_giao.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,89 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991,2000, Roland Lindh * -************************************************************************ - SubRoutine CmbnMP_GIAO(Rnxyz,nZeta,la,lb,lr,Zeta,rKappa,Final, - & nComp,nB,RAB,C) -************************************************************************ -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* * -* Modified to GIAO 1st derivatives by R. Lindh in Tokyo, * -* Japan, January 2000. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nComp,nB), - & Zeta(nZeta), rKappa(nZeta), - & Rnxyz(nZeta,3,0:la,0:lb,0:lr+1), RAB(3), C(3) - Integer ix_(3,2) -* -* Statement function for Cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 -* - Do 10 ixa = 0, la - iyaMax=la-ixa - Do 11 ixb = 0, lb - iybMax=lb-ixb - Do 20 iya = 0, iyaMax - iza = la-ixa-iya - ipa= Ind(la,ixa,iza) - Do 21 iyb = 0, iybMax - izb = lb-ixb-iyb - ipb= Ind(lb,ixb,izb) -* -* Combine multipole moment integrals -* - Do iBx = 1, 3 - iBy = iBx + 1 - If (iBy.gt.3) iBy=iBy-3 - iBz = iBy + 1 - If (iBz.gt.3) iBz=iBz-3 - Call ICopy(6,[0],0,ix_,1) - ix_(iBz,1)=1 - ix_(iBy,2)=1 - iComp = 0 - Do ix = lr, 0, -1 - Do iy = lr-ix, 0, -1 - iz = lr-ix-iy - iComp=iComp+1 - Do iZeta = 1, nZeta - Fact = rKappa(iZeta) * Zeta(iZeta)**(-Three/Two) - temp = Rnxyz(iZeta,1,ixa,ixb,ix)* - & Rnxyz(iZeta,2,iya,iyb,iy)* - & Rnxyz(iZeta,3,iza,izb,iz) - tempz= Rnxyz(iZeta,1,ixa,ixb,ix+ix_(1,1))* - & Rnxyz(iZeta,2,iya,iyb,iy+ix_(2,1))* - & Rnxyz(iZeta,3,iza,izb,iz+ix_(3,1)) - tempy= Rnxyz(iZeta,1,ixa,ixb,ix+ix_(1,2))* - & Rnxyz(iZeta,2,iya,iyb,iy+ix_(2,2))* - & Rnxyz(iZeta,3,iza,izb,iz+ix_(3,2)) -* -*------------------- The term has only an imaginary component -* - Final(iZeta,ipa,ipb,iComp,iBx) = Half * Fact * ( - & RAB(iBy)*(Tempz+C(iBz)*Temp) - & - RAB(iBz)*(Tempy+C(iBy)*Temp) - & ) - End Do - End Do - End Do - End Do ! iB -* - 21 Continue - 20 Continue - 11 Continue - 10 Continue -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/cmbnmp_giao.F90 openmolcas-22.10/src/oneint_util/cmbnmp_giao.F90 --- openmolcas-22.02/src/oneint_util/cmbnmp_giao.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/cmbnmp_giao.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,80 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991,2000, Roland Lindh * +!*********************************************************************** + +subroutine CmbnMP_GIAO(Rnxyz,nZeta,la,lb,lr,Zeta,rKappa,rFinal,nComp,nB,RAB,C) +!*********************************************************************** +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! * +! Modified to GIAO 1st derivatives by R. Lindh in Tokyo, * +! Japan, January 2000. * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: Half, OneHalf +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb, lr, nComp, nB +real(kind=wp), intent(in) :: Rnxyz(nZeta,3,0:la,0:lb,0:lr+1), Zeta(nZeta), rKappa(nZeta), RAB(3), C(3) +real(kind=wp), intent(out) :: rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),nComp,nB) +integer(kind=iwp) :: iBx, iBy, iBz, iComp, ipa, ipb, ix, ix_(3,2), ixa, ixb, iy, iya, iyaMax, iyb, iybMax, iz, iza, izb, iZeta +real(kind=wp) :: Fact, temp, tempy, tempz + +do ixa=0,la + iyaMax = la-ixa + do ixb=0,lb + iybMax = lb-ixb + do iya=0,iyaMax + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + do iyb=0,iybMax + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + + ! Combine multipole moment integrals + + do iBx=1,3 + iBy = iBx+1 + if (iBy > 3) iBy = iBy-3 + iBz = iBy+1 + if (iBz > 3) iBz = iBz-3 + ix_(:,:) = 0 + ix_(iBz,:) = 1 + iComp = 0 + do ix=lr,0,-1 + do iy=lr-ix,0,-1 + iz = lr-ix-iy + iComp = iComp+1 + do iZeta=1,nZeta + Fact = rKappa(iZeta)*Zeta(iZeta)**(-OneHalf) + temp = Rnxyz(iZeta,1,ixa,ixb,ix)*Rnxyz(iZeta,2,iya,iyb,iy)*Rnxyz(iZeta,3,iza,izb,iz) + tempz = Rnxyz(iZeta,1,ixa,ixb,ix+ix_(1,1))*Rnxyz(iZeta,2,iya,iyb,iy+ix_(2,1))*Rnxyz(iZeta,3,iza,izb,iz+ix_(3,1)) + tempy = Rnxyz(iZeta,1,ixa,ixb,ix+ix_(1,2))*Rnxyz(iZeta,2,iya,iyb,iy+ix_(2,2))*Rnxyz(iZeta,3,iza,izb,iz+ix_(3,2)) + + ! The term has only an imaginary component + + rFinal(iZeta,ipa,ipb,iComp,iBx) = Half*Fact*(RAB(iBy)*(Tempz+C(iBz)*Temp)-RAB(iBz)*(Tempy+C(iBy)*Temp)) + end do + end do + end do + end do ! iB + + end do + end do + end do +end do + +return + +end subroutine CmbnMP_GIAO diff -Nru openmolcas-22.02/src/oneint_util/cmbnmv.f openmolcas-22.10/src/oneint_util/cmbnmv.f --- openmolcas-22.02/src/oneint_util/cmbnmv.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/cmbnmv.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,97 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine CmbnMV(Rnxyz,nZeta,la,lb,lr,Zeta,rKappa,Final,nComp, - & rV2Int,rV4Int) -************************************************************************ -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN, February '91 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Final(nZeta,nComp,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2), - & Zeta(nZeta), rKappa(nZeta), - & Rnxyz(nZeta,3,0:la+2,0:lb+2,0:lr), - & rV2Int(nZeta,3,0:la,0:lb,2), - & rV4Int(nZeta,3,0:la,0:lb) -* -* Statement function for Cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 -* -* iRout = 191 -* iPrint = nPrint(iRout) -* Call GetMem(' Enter CmbnMV','LIST','REAL',iDum,iDum) -* - Const = - One2C2/Four - iComp = 1 - Do 10 ixa = 0, la - iyaMax=la-ixa - Do 11 ixb = 0, lb - iybMax=lb-ixb - Do 20 iya = 0, iyaMax - iza = la-ixa-iya - ipa= Ind(la,ixa,iza) - Do 21 iyb = 0, iybMax - izb = lb-ixb-iyb - ipb= Ind(lb,ixb,izb) -* If (iPrint.ge.99) Then -* Write (*,*) ixa,iya,iza,ixb,iyb,izb -* Write (*,*) ipa,ipb -* End If -* -* Combine integrals -* - Do 30 iZeta = 1, nZeta - Fact = rKappa(iZeta) * Zeta(iZeta)**(-Three/Two) * Const - x2x2 = rV4Int(iZeta,1,ixa,ixb)* - & Rnxyz(iZeta,2,iya,iyb,0)* - & Rnxyz(iZeta,3,iza,izb,0) - x2y2 = rV2Int(iZeta,1,ixa,ixb,1)* - & rV2Int(iZeta,2,iya,iyb,2)* - & Rnxyz(iZeta,3,iza,izb,0) - x2z2 = rV2Int(iZeta,1,ixa,ixb,1)* - & Rnxyz(iZeta,2,iya,iyb,0)* - & rV2Int(iZeta,3,iza,izb,2) - y2x2 = rV2Int(iZeta,1,ixa,ixb,2)* - & rV2Int(iZeta,2,iya,iyb,1)* - & Rnxyz(iZeta,3,iza,izb,0) - y2y2 = Rnxyz(iZeta,1,ixa,ixb,0)* - & rV4Int(iZeta,2,iya,iyb)* - & Rnxyz(iZeta,3,iza,izb,0) - y2z2 = Rnxyz(iZeta,1,ixa,ixb,0)* - & rV2Int(iZeta,2,iya,iyb,1)* - & rV2Int(iZeta,3,iza,izb,2) - z2x2 = rV2Int(iZeta,1,ixa,ixb,2)* - & Rnxyz(iZeta,2,iya,iyb,0)* - & rV2Int(iZeta,3,iza,izb,1) - z2y2 = Rnxyz(iZeta,1,ixa,ixb,0)* - & rV2Int(iZeta,2,iya,iyb,2)* - & rV2Int(iZeta,3,iza,izb,1) - z2z2 = Rnxyz(iZeta,1,ixa,ixb,0)* - & Rnxyz(iZeta,2,iya,iyb,0)* - & rV4Int(iZeta,3,iza,izb) -* - rMVel= x2x2+x2y2+x2z2+y2x2+y2y2+y2z2+z2x2+z2y2+z2z2 -* - Final(iZeta,iComp,ipa,ipb) = Fact * rMVel - 30 Continue -* - 21 Continue - 20 Continue - 11 Continue - 10 Continue -* -* Call GetMem(' Exit CmbnMV','LIST','REAL',iDum,iDum) - Return - End diff -Nru openmolcas-22.02/src/oneint_util/cmbnmv.F90 openmolcas-22.10/src/oneint_util/cmbnmv.F90 --- openmolcas-22.02/src/oneint_util/cmbnmv.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/cmbnmv.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,70 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine CmbnMV(Rnxyz,nZeta,la,lb,lr,Zeta,rKappa,rFinal,nComp,rV2Int,rV4Int) +!*********************************************************************** +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN, February '91 * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: One, Eight, OneHalf, c_in_au +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb, lr, nComp +real(kind=wp), intent(in) :: Rnxyz(nZeta,3,0:la+2,0:lb+2,0:lr), Zeta(nZeta), rKappa(nZeta), rV2Int(nZeta,3,0:la,0:lb,2), & + rV4Int(nZeta,3,0:la,0:lb) +real(kind=wp), intent(out) :: rFinal(nZeta,nComp,nTri_Elem1(la),nTri_Elem1(lb)) +integer(kind=iwp) :: iComp, ipa, ipb, ixa, ixb, iya, iyaMax, iyb, iybMax, iza, izb +real(kind=wp), parameter :: Const = -One/(Eight*c_in_au**2) + +!iRout = 191 +!iPrint = nPrint(iRout) + +iComp = 1 +do ixa=0,la + iyaMax = la-ixa + do ixb=0,lb + iybMax = lb-ixb + do iya=0,iyaMax + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + do iyb=0,iybMax + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + !if (iPrint >= 99) then + ! write(u6,*) ixa,iya,iza,ixb,iyb,izb + ! write(u6,*) ipa,ipb + !end if + + ! Combine integrals + + rFinal(:,iComp,ipa,ipb) = rKappa*Zeta**(-OneHalf)*Const*(rV4Int(:,1,ixa,ixb)*Rnxyz(:,2,iya,iyb,0)*Rnxyz(:,3,iza,izb,0)+ & + rV2Int(:,1,ixa,ixb,1)*rV2Int(:,2,iya,iyb,2)*Rnxyz(:,3,iza,izb,0)+ & + rV2Int(:,1,ixa,ixb,1)*Rnxyz(:,2,iya,iyb,0)*rV2Int(:,3,iza,izb,2)+ & + rV2Int(:,1,ixa,ixb,2)*rV2Int(:,2,iya,iyb,1)*Rnxyz(:,3,iza,izb,0)+ & + Rnxyz(:,1,ixa,ixb,0)*rV4Int(:,2,iya,iyb)*Rnxyz(:,3,iza,izb,0)+ & + Rnxyz(:,1,ixa,ixb,0)*rV2Int(:,2,iya,iyb,1)*rV2Int(:,3,iza,izb,2)+ & + rV2Int(:,1,ixa,ixb,2)*Rnxyz(:,2,iya,iyb,0)*rV2Int(:,3,iza,izb,1)+ & + Rnxyz(:,1,ixa,ixb,0)*rV2Int(:,2,iya,iyb,2)*rV2Int(:,3,iza,izb,1)+ & + Rnxyz(:,1,ixa,ixb,0)*Rnxyz(:,2,iya,iyb,0)*rV4Int(:,3,iza,izb)) + + end do + end do + end do +end do + +return + +end subroutine CmbnMV diff -Nru openmolcas-22.02/src/oneint_util/cmbnve.f openmolcas-22.10/src/oneint_util/cmbnve.f --- openmolcas-22.02/src/oneint_util/cmbnve.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/cmbnve.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,76 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine CmbnVe(Rnxyz,nZeta,la,lb,lr,Zeta,rKappa,Final,nComp, - & Vxyz) -************************************************************************ -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* January '91 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nComp), - & Zeta(nZeta), rKappa(nZeta), - & Rnxyz(nZeta,3,0:la,0:lb+1,0:lr), - & Vxyz(nZeta,3,0:la,0:lb) -* -* Statement function for Cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 -* -* iRout = 161 -* iPrint = nPrint(iRout) -* Call GetMem(' Enter CmbnVe','LIST','REAL',iDum,iDum) -* - Do 10 ixa = 0, la - iyaMax=la-ixa - Do 11 ixb = 0, lb - iybMax=lb-ixb - Do 20 iya = 0, iyaMax - iza = la-ixa-iya - ipa= Ind(la,ixa,iza) - Do 21 iyb = 0, iybMax - izb = lb-ixb-iyb - ipb= Ind(lb,ixb,izb) -* If (iPrint.ge.99) Then -* Write (*,*) ixa,iya,iza,ixb,iyb,izb -* Write (*,*) ipa,ipb -* End If -* -* Combine integrals -* - Do 30 iZeta = 1, nZeta - Fact = rKappa(iZeta) * Zeta(iZeta)**(-Three/Two) - Final(iZeta,ipa,ipb,1) = Fact * - & Vxyz(iZeta,1,ixa,ixb)* - & Rnxyz(iZeta,2,iya,iyb,0)* - & Rnxyz(iZeta,3,iza,izb,0) - Final(iZeta,ipa,ipb,2) = Fact * - & Rnxyz(iZeta,1,ixa,ixb,0)* - & Vxyz(iZeta,2,iya,iyb)* - & Rnxyz(iZeta,3,iza,izb,0) - Final(iZeta,ipa,ipb,3) = Fact * - & Rnxyz(iZeta,1,ixa,ixb,0)* - & Rnxyz(iZeta,2,iya,iyb,0)* - & Vxyz(iZeta,3,iza,izb) - 30 Continue -* - 21 Continue - 20 Continue - 11 Continue - 10 Continue -* -* Call GetMem(' Exit CmbnVe','LIST','REAL',iDum,iDum) - Return - End diff -Nru openmolcas-22.02/src/oneint_util/cmbnve.F90 openmolcas-22.10/src/oneint_util/cmbnve.F90 --- openmolcas-22.02/src/oneint_util/cmbnve.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/cmbnve.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,62 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine CmbnVe(Rnxyz,nZeta,la,lb,lr,Zeta,rKappa,rFinal,nComp,Vxyz) +!*********************************************************************** +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! January '91 * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: OneHalf +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb, lr, nComp +real(kind=wp), intent(in) :: Rnxyz(nZeta,3,0:la,0:lb+1,0:lr), Zeta(nZeta), rKappa(nZeta), Vxyz(nZeta,3,0:la,0:lb) +real(kind=wp), intent(out) :: rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),nComp) +integer(kind=iwp) :: ipa, ipb, ixa, ixb, iya, iyaMax, iyb, iybMax, iza, izb + +!iRout = 161 +!iPrint = nPrint(iRout) + +do ixa=0,la + iyaMax = la-ixa + do ixb=0,lb + iybMax = lb-ixb + do iya=0,iyaMax + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + do iyb=0,iybMax + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + !if (iPrint >= 99) then + ! write(u6,*) ixa,iya,iza,ixb,iyb,izb + ! write(u6,*) ipa,ipb + !end if + + ! Combine integrals + + rFinal(:,ipa,ipb,1) = rKappa*Zeta**(-OneHalf)*Vxyz(:,1,ixa,ixb)*Rnxyz(:,2,iya,iyb,0)*Rnxyz(:,3,iza,izb,0) + rFinal(:,ipa,ipb,2) = rKappa*Zeta**(-OneHalf)*Rnxyz(:,1,ixa,ixb,0)*Vxyz(:,2,iya,iyb)*Rnxyz(:,3,iza,izb,0) + rFinal(:,ipa,ipb,3) = rKappa*Zeta**(-OneHalf)*Rnxyz(:,1,ixa,ixb,0)*Rnxyz(:,2,iya,iyb,0)*Vxyz(:,3,iza,izb) + + end do + end do + end do +end do + +return + +end subroutine CmbnVe diff -Nru openmolcas-22.02/src/oneint_util/cntint.f openmolcas-22.10/src/oneint_util/cntint.f --- openmolcas-22.02/src/oneint_util/cntint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/cntint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,99 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991,2008, Roland Lindh * -************************************************************************ - SubRoutine CntInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: to compute contact integrals. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, Sweden, February '91 * -* Modified from D1Int January 2008. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - -#include "int_interface.fh" - -* Local variables - - Character*80 Label -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - iRout = 150 - iPrint = nPrint(iRout) -* - Call FZero(Final,nZeta*((la+1)*(la+2)/2)*((lb+1)*(lb+2)/2)*nIC) -* - nip = 1 - ipAxyz = nip - nip = nip + nZeta*3*nHer*(la+1) - ipBxyz = nip - nip = nip + nZeta*3*nHer*(lb+1) - ipArr=nip - na=(la+1)*(la+2)/2 - nb=(lb+1)*(lb+2)/2 - mArr=na*nb - nip = nip + nZeta*mArr - If (nip-1.gt.nArr*nZeta) Then - Call WarningMessage(2,'CntInt: nip-1.gt.nArr*nZeta') - Write (6,*) 'nip=',nip - Write (6,*) 'nArr,nZeta=',nArr,nZeta - Call Abend() - End If -* - If (iPrint.ge.49) Then - Call RecPrt(' In CntInt: A',' ',A,1,3) - Call RecPrt(' In CntInt: RB',' ',RB,1,3) - Call RecPrt(' In CntInt: Ccoor',' ',Ccoor,1,3) - Call RecPrt(' In CntInt: P',' ',P,nZeta,3) - Write (6,*) ' In CntInt: la,lb=',la,lb - End If -* -* Compute the contact terms. -* - Call Contact(Zeta,P,nZeta, - & A,Array(ipAxyz),la, - & RB,Array(ipBxyz),lb, - & Ccoor,lOper,iCho,nIC, - & Array(ipArr),mArr, - & Final,iStabM,nStabM,nComp,rKappa) -* - If (iPrint.ge.99) Then - Do iIC = 1, nIC - Do ia = 1, nElem(la) - Do ib = 1, nElem(lb) - Write (Label,'(A,I2,A,I2,A)') - & 'Contact term(',ia,',',ib,')' - Call RecPrt(Label,' ',Final(1,ia,ib,iIC),1,nZeta) - End Do - End Do - End Do - End If -* -* Call GetMem(' Exit CntInt','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Alpha) - Call Unused_real_array(Beta) - Call Unused_real_array(ZInv) - Call Unused_integer(nOrdOp) - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/cntint.F90 openmolcas-22.10/src/oneint_util/cntint.F90 --- openmolcas-22.02/src/oneint_util/cntint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/cntint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,92 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991,2008, Roland Lindh * +!*********************************************************************** + +subroutine CntInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute contact integrals. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, Sweden, February '91 * +! Modified from D1Int January 2008. * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "print.fh" +integer(kind=iwp) :: ia, ib, iIC, ipArr, ipAxyz, ipBxyz, iPrint, iRout, na, nb, nip +character(len=80) :: Label + +#include "macros.fh" +unused_var(Alpha) +unused_var(Beta) +unused_var(ZInv) +unused_var(nOrdOp) +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 150 +iPrint = nPrint(iRout) + +rFinal(:,:,:,:) = Zero + +nip = 1 +ipAxyz = nip +nip = nip+nZeta*3*nHer*(la+1) +ipBxyz = nip +nip = nip+nZeta*3*nHer*(lb+1) +ipArr = nip +na = (la+1)*(la+2)/2 +nb = (lb+1)*(lb+2)/2 +nip = nip+nZeta*na*nb +if (nip-1 > nArr*nZeta) then + call WarningMessage(2,'CntInt: nip-1 > nArr*nZeta') + write(u6,*) 'nip=',nip + write(u6,*) 'nArr,nZeta=',nArr,nZeta + call Abend() +end if + +if (iPrint >= 49) then + call RecPrt(' In CntInt: A',' ',A,1,3) + call RecPrt(' In CntInt: RB',' ',RB,1,3) + call RecPrt(' In CntInt: Ccoor',' ',Ccoor,1,3) + call RecPrt(' In CntInt: P',' ',P,nZeta,3) + write(u6,*) ' In CntInt: la,lb=',la,lb +end if + +! Compute the contact terms. + +call Contact(Zeta,P,nZeta,A,Array(ipAxyz),la,RB,Array(ipBxyz),lb,Ccoor,lOper,iCho,nIC,Array(ipArr),rFinal,iStabM,nStabM,nComp, & + rKappa) + +if (iPrint >= 99) then + do iIC=1,nIC + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb) + write(Label,'(A,I2,A,I2,A)') 'Contact term(',ia,',',ib,')' + call RecPrt(Label,' ',rFinal(:,ia,ib,iIC),1,nZeta) + end do + end do + end do +end if + +return + +end subroutine CntInt diff -Nru openmolcas-22.02/src/oneint_util/cntmem.f openmolcas-22.10/src/oneint_util/cntmem.f --- openmolcas-22.02/src/oneint_util/cntmem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/cntmem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,28 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine CntMem( -#define _CALLING_ -#include "mem_interface.fh" - &) - use Sizes_of_Seward, only: s - Implicit Real*8 (A-H,O-Z) -#include "mem_interface.fh" -* - nHer=S%mCentr - Mem = 3*(la+1)*nHer + - & 3*(lb+1)*nHer + - & ((la+1)*(la+2)/2) * - & ((lb+1)*(lb+2)/2) -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(lr) - End diff -Nru openmolcas-22.02/src/oneint_util/cntmem.F90 openmolcas-22.10/src/oneint_util/cntmem.F90 --- openmolcas-22.02/src/oneint_util/cntmem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/cntmem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,31 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine CntMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Sizes_of_Seward, only: s +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" + +#include "macros.fh" +unused_var(lr) + +nHer = S%mCentr +Mem = 3*(la+1)*nHer+3*(lb+1)*nHer+((la+1)*(la+2)/2)*((lb+1)*(lb+2)/2) + +return + +end subroutine CntMem diff -Nru openmolcas-22.02/src/oneint_util/contact.f openmolcas-22.10/src/oneint_util/contact.f --- openmolcas-22.02/src/oneint_util/contact.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/contact.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,167 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine Contact(Zeta,P,nZeta,A,Axyz,la,RB,Bxyz,lb, Ccoor, - & lOper,iChO,nIC,Array,nArr,Final, - & iStabM,nStabM,nComp,rKappa) -************************************************************************ -* * -* Object: to compoute the 1-electron contact term. * -* * -* Author: Roland Lindh, Dept. Of Theoretical Chemistry, * -* University of Lund, Sweden, February '91 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nIC), - & rKappa(nZeta), Ccoor(3), - & Array(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2), - & Axyz(nZeta,3,0:la), Bxyz(nZeta,3,0:lb), - & Zeta(nZeta), P(nZeta,3), A(3), RB(3), TC(3) - Integer iStabM(0:nStabM-1), iStabO(0:7), iDCRT(0:7), lOper(nComp), - & iChO(nComp) -* * -************************************************************************ -* * -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 -* * -************************************************************************ -* * - iRout = 170 - iPrint = nPrint(iRout) - If (iPrint.ge.99) Then - Call RecPrt(' In Contact: rKappa',' ',rKappa,nZeta,1) - Call RecPrt(' In Contact: Zeta',' ',Zeta,nZeta,1) - Call RecPrt(' In Contact: P',' ',P,nZeta,3) - End If -* * -************************************************************************ -* * - llOper = lOper(1) - Do iComp = 2, nComp - llOper = iOr(llOper,lOper(iComp)) - End Do - Call SOS(iStabO,nStabO,llOper) - Call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) -* - Do lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),Ccoor,TC) -* - call dcopy_(nZeta*nElem(la)*nElem(lb),[Zero],0,Array,1) -* -*--------Compute the value of the angular components associated -* to the basis functions centered on the first center. -* - call dcopy_(nZeta*3,[One],0,Axyz(1,1,0),1) - If (la.eq.0) Go To 60 -* - Do iCar = 1, 3 -* - Do iZeta = 1, nZeta - Axyz(iZeta,iCar,1) =TC(iCar) -A(iCar) - End Do -* - Do ia = 2, la - Do iZeta = 1, nZeta - Axyz(iZeta,iCar,ia) = Axyz(iZeta,iCar,1) * - & Axyz(iZeta,iCar,ia-1) - End Do - End Do -* - End Do - 60 Continue -* -*--------Compute the value of the angular components associated to -* the basis functions centered on the second center. -* - call dcopy_(nZeta*3,[One],0,Bxyz(1,1,0),1) -* -*--------Modify z-component to carry the the exponetial -* contribution. -* - Do iZeta = 1, nZeta - Bxyz(iZeta,3,0) = - & Exp ( -Zeta(iZeta) * ( (TC(1)-P(iZeta,1))**2 + - & (TC(2)-P(iZeta,2))**2 + - & (TC(3)-P(iZeta,3))**2 )) - End Do - If (lb.eq.0) Go To 61 -* - Do iCar = 1, 3 -* - Do iZeta = 1, nZeta - Bxyz(iZeta,iCar,1) =TC(iCar) -RB(iCar) - End Do -* - Do ib = 2, lb - Do iZeta = 1, nZeta - Bxyz(iZeta,iCar,ib) = Bxyz(iZeta,iCar,1) * - & Bxyz(iZeta,iCar,ib-1) - End Do - End Do - End Do -* -*--------Modify z-components with the exponential contribution -* - Do ib = 1, lb - Do iZeta = 1, nZeta - Bxyz(iZeta,3,ib) = Bxyz(iZeta,3,ib) * - & Bxyz(iZeta,3,0) - End Do - End Do -* - 61 Continue -* -*--------Combine contributions from the varoius angular -* components. -* - Do ixa = la, 0, -1 - Do ixb = lb, 0, -1 - Do iya = la-ixa, 0, -1 - iza = la-ixa-iya - ipa = Ind(la,ixa,iza) - Do iyb = lb-ixb, 0, -1 - izb = lb-ixb-iyb - ipb = Ind(lb,ixb,izb) - Do iZeta = 1, nZeta - Array(iZeta,ipa,ipb) = - & Array(iZeta,ipa,ipb) + - & rKappa(iZeta) * - & Axyz(iZeta,1,ixa) * - & Axyz(iZeta,2,iya) * - & Axyz(iZeta,3,iza) * - & Bxyz(iZeta,1,ixb) * - & Bxyz(iZeta,2,iyb) * - & Bxyz(iZeta,3,izb) - End Do - End Do - End Do - End Do - End Do -* -*------- Accumulate contributions -* - nOp = NrOpr(iDCRT(lDCRT)) - Call SymAdO(Array,nZeta,la,lb,nComp,Final,nIC, - & nOp ,lOper,iChO,One) -* - End Do -* -* Call GetMem(' Exit Contact ','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(nArr) - End diff -Nru openmolcas-22.02/src/oneint_util/contact.F90 openmolcas-22.10/src/oneint_util/contact.F90 --- openmolcas-22.02/src/oneint_util/contact.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/contact.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,132 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine Contact(Zeta,P,nZeta,A,Axyz,la,RB,Bxyz,lb,Ccoor,lOper,iChO,nIC,Array,rFinal,iStabM,nStabM,nComp,rKappa) +!*********************************************************************** +! * +! Object: to compoute the 1-electron contact term. * +! * +! Author: Roland Lindh, Dept. Of Theoretical Chemistry, * +! University of Lund, Sweden, February '91 * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb, nComp, lOper(nComp), iCho(nComp), nIC, nStabM, iStabM(0:nStabM-1) +real(kind=wp), intent(in) :: Zeta(nZeta), P(nZeta,3), A(3), RB(3), Ccoor(3), rKappa(nZeta) +real(kind=wp), intent(out) :: Axyz(nZeta,3,0:la), Bxyz(nZeta,3,0:lb), Array(nZeta,nTri_Elem1(la),nTri_Elem1(lb)) +real(kind=wp), intent(inout) :: rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),nIC) +#include "print.fh" +integer(kind=iwp) :: ia, ib, iCar, iComp, iDCRT(0:7), ipa, ipb, iPrint, iRout, iStabO(0:7), ixa, ixb, iya, iyb, iza, izb, lDCRT, & + llOper, LmbdT, nDCRT, nOp, nStabO +real(kind=wp) :: TC(3) +integer(kind=iwp), external :: NrOpr + +! * +!*********************************************************************** +! * +iRout = 170 +iPrint = nPrint(iRout) +if (iPrint >= 99) then + call RecPrt(' In Contact: rKappa',' ',rKappa,nZeta,1) + call RecPrt(' In Contact: Zeta',' ',Zeta,nZeta,1) + call RecPrt(' In Contact: P',' ',P,nZeta,3) +end if +! * +!*********************************************************************** +! * +llOper = lOper(1) +do iComp=2,nComp + llOper = ior(llOper,lOper(iComp)) +end do +call SOS(iStabO,nStabO,llOper) +call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) + +do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),Ccoor,TC) + + Array(:,:,:) = Zero + + ! Compute the value of the angular components associated + ! to the basis functions centered on the first center. + + Axyz(:,:,0) = One + + if (la /= 0) then + do iCar=1,3 + + Axyz(:,iCar,1) = TC(iCar)-A(iCar) + + do ia=2,la + Axyz(:,iCar,ia) = Axyz(:,iCar,1)*Axyz(:,iCar,ia-1) + end do + + end do + end if + + ! Compute the value of the angular components associated to + ! the basis functions centered on the second center. + + Bxyz(:,:,0) = One + + ! Modify z-component to carry the the exponential contribution. + + Bxyz(:,3,0) = exp(-Zeta*((TC(1)-P(:,1))**2+(TC(2)-P(:,2))**2+(TC(3)-P(:,3))**2)) + + if (lb /= 0) then + do iCar=1,3 + + Bxyz(:,iCar,1) = TC(iCar)-RB(iCar) + + do ib=2,lb + Bxyz(:,iCar,ib) = Bxyz(:,iCar,1)*Bxyz(:,iCar,ib-1) + end do + end do + + ! Modify z-components with the exponential contribution + + do ib=1,lb + Bxyz(:,3,ib) = Bxyz(:,3,ib)*Bxyz(:,3,0) + end do + end if + + ! Combine contributions from the various angular components. + + do ixa=la,0,-1 + do ixb=lb,0,-1 + do iya=la-ixa,0,-1 + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + do iyb=lb-ixb,0,-1 + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + Array(:,ipa,ipb) = Array(:,ipa,ipb)+rKappa*Axyz(:,1,ixa)*Axyz(:,2,iya)*Axyz(:,3,iza)*Bxyz(:,1,ixb)*Bxyz(:,2,iyb)* & + Bxyz(:,3,izb) + end do + end do + end do + end do + + ! Accumulate contributions + + nOp = NrOpr(iDCRT(lDCRT)) + call SymAdO(Array,nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,One) + +end do + +return + +end subroutine Contact diff -Nru openmolcas-22.02/src/oneint_util/cvelint.f openmolcas-22.10/src/oneint_util/cvelint.f --- openmolcas-22.02/src/oneint_util/cvelint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/cvelint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,98 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine CVelInt(Vxyz,Sxyz,na,nb,Alpha,Beta,nZeta) -************************************************************************ -* * -* Object: to assemble the cartesian components of the velocity inte- * -* grals from the cartesian components of the overlap integals. * -* * -* Called from: PrpInt * -* * -* Calling : CRecPrt * -* RecPrt * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* November '90 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - Complex*16 Vxyz(nZeta,3,0:na,0:nb,2), Sxyz(nZeta,3,0:na+1,0:nb+1) - Real*8 Alpha(nZeta), Beta(nZeta) - Character*80 Label - iRout=160 - iPrint = nPrint(iRout) - - If (iPrint.ge.99) Then - Call RecPrt(' In CVelInt: Beta ',' ',Beta ,nZeta,1) - End If - Do 10 ia = 0, na - Do 20 ib = 0, nb - If (ia.ne.0 .and. ib.ne.0) Then - Do iCar = 1, 3 - Do iZeta = 1, nZeta - Vxyz(iZeta,iCar,ia,ib,1) = - & Dble(ia) * Sxyz(iZeta,iCar,ia-1,ib) - & - Alpha(iZeta) * Two * Sxyz(iZeta,iCar,ia+1,ib) - Vxyz(iZeta,iCar,ia,ib,2) = - & Dble(ib) * Sxyz(iZeta,iCar,ia,ib-1) - & - Beta(iZeta) * Two * Sxyz(iZeta,iCar,ia,ib+1) - End Do - End Do - Else If (ia.eq.0 .and. ib.ne.0) Then - Do iCar = 1, 3 - Do iZeta = 1, nZeta - Vxyz(iZeta,iCar,ia,ib,1) = - & - Alpha(iZeta) * Two * Sxyz(iZeta,iCar,ia+1,ib) - Vxyz(iZeta,iCar,ia,ib,2) = - & Dble(ib) * Sxyz(iZeta,iCar,ia,ib-1) - & - Beta(iZeta) * Two * Sxyz(iZeta,iCar,ia,ib+1) - End Do - End Do - Else If (ia.ne.0 .and. ib.eq.0) Then - Do iCar = 1, 3 - Do iZeta = 1, nZeta - Vxyz(iZeta,iCar,ia,ib,1) = - & Dble(ia) * Sxyz(iZeta,iCar,ia-1,ib) - & - Alpha(iZeta) * Two * Sxyz(iZeta,iCar,ia+1,ib) - Vxyz(iZeta,iCar,ia,ib,2) = - & - Beta(iZeta) * Two * Sxyz(iZeta,iCar,ia,ib+1) - End Do - End Do - Else - Do iCar = 1, 3 - Do iZeta = 1, nZeta - Vxyz(iZeta,iCar,ia,ib,1) = - & - Alpha(iZeta) * Two * Sxyz(iZeta,iCar,ia+1,ib) - Vxyz(iZeta,iCar,ia,ib,2) = - & - Beta(iZeta) * Two * Sxyz(iZeta,iCar,ia,ib+1) - End Do - End Do - End If -* - If (iPrint.ge.99) Then - Write (Label,'(A,I2,A,I2,A)') ' In CVelInt: Vxyz(', - & ia,',',ib,',1)' - Call CRecPrt(Label,' ',Vxyz(1,1,ia,ib,1),nZeta,3,'R') - Call CRecPrt(Label,' ',Vxyz(1,1,ia,ib,1),nZeta,3,'I') - Write (Label,'(A,I2,A,I2,A)') ' In CVelInt: Vxyz(', - & ia,',',ib,',2)' - Call CRecPrt(Label,' ',Vxyz(1,1,ia,ib,2),nZeta,3,'R') - Call CRecPrt(Label,' ',Vxyz(1,1,ia,ib,2),nZeta,3,'I') - End If - 20 Continue - 10 Continue - - Return - End diff -Nru openmolcas-22.02/src/oneint_util/cvelint.F90 openmolcas-22.10/src/oneint_util/cvelint.F90 --- openmolcas-22.02/src/oneint_util/cvelint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/cvelint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,85 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine CVelInt(Vxyz,Sxyz,na,nb,Alpha,Beta,nZeta) +!*********************************************************************** +! * +! Object: to assemble the cartesian components of the velocity inte- * +! grals from the cartesian components of the overlap integals. * +! * +! Called from: PrpInt * +! * +! Calling : CRecPrt * +! RecPrt * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! November '90 * +!*********************************************************************** + +use Constants, only: Two +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: na, nb, nZeta +complex(kind=wp), intent(out) :: Vxyz(nZeta,3,0:na,0:nb,2) +complex(kind=wp), intent(in) :: Sxyz(nZeta,3,0:na+1,0:nb+1) +real(kind=wp), intent(in) :: Alpha(nZeta), Beta(nZeta) +#include "print.fh" +integer(kind=iwp) :: ia, ib, iCar, iPrint, iRout +character(len=80) :: Label + +iRout = 160 +iPrint = nPrint(iRout) + +if (iPrint >= 99) then + call RecPrt(' In CVelInt: Beta ',' ',Beta,nZeta,1) +end if +do ia=0,na + do ib=0,nb + if ((ia /= 0) .and. (ib /= 0)) then + do iCar=1,3 + Vxyz(:,iCar,ia,ib,1) = real(ia,kind=wp)*Sxyz(:,iCar,ia-1,ib)-Alpha*Two*Sxyz(:,iCar,ia+1,ib) + Vxyz(:,iCar,ia,ib,2) = real(ib,kind=wp)*Sxyz(:,iCar,ia,ib-1)-Beta*Two*Sxyz(:,iCar,ia,ib+1) + end do + else if (ib /= 0) then + do iCar=1,3 + Vxyz(:,iCar,ia,ib,1) = -Alpha*Two*Sxyz(:,iCar,ia+1,ib) + Vxyz(:,iCar,ia,ib,2) = real(ib,kind=wp)*Sxyz(:,iCar,ia,ib-1)-Beta*Two*Sxyz(:,iCar,ia,ib+1) + end do + else if (ia /= 0) then + do iCar=1,3 + Vxyz(:,iCar,ia,ib,1) = real(ia,kind=wp)*Sxyz(:,iCar,ia-1,ib)-Alpha*Two*Sxyz(:,iCar,ia+1,ib) + Vxyz(:,iCar,ia,ib,2) = -Beta*Two*Sxyz(:,iCar,ia,ib+1) + end do + else + do iCar=1,3 + Vxyz(:,iCar,ia,ib,1) = -Alpha*Two*Sxyz(:,iCar,ia+1,ib) + Vxyz(:,iCar,ia,ib,2) = -Beta*Two*Sxyz(:,iCar,ia,ib+1) + end do + end if + + if (iPrint >= 99) then + write(Label,'(A,I2,A,I2,A)') ' In CVelInt: Vxyz(',ia,',',ib,',1)' + call CRecPrt(Label,' ',Vxyz(:,:,ia,ib,1),nZeta,3,'R') + call CRecPrt(Label,' ',Vxyz(:,:,ia,ib,1),nZeta,3,'I') + write(Label,'(A,I2,A,I2,A)') ' In CVelInt: Vxyz(',ia,',',ib,',2)' + call CRecPrt(Label,' ',Vxyz(:,:,ia,ib,2),nZeta,3,'R') + call CRecPrt(Label,' ',Vxyz(:,:,ia,ib,2),nZeta,3,'I') + end if + end do +end do + +return + +end subroutine CVelInt diff -Nru openmolcas-22.02/src/oneint_util/d1int.f openmolcas-22.10/src/oneint_util/d1int.f --- openmolcas-22.02/src/oneint_util/d1int.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/d1int.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,88 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine D1Int( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: to compute the 1-electron Darwin contact term. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, Sweden, February '91 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - -#include "int_interface.fh" - -* Local variables - - Character*80 Label -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - iRout = 150 - iPrint = nPrint(iRout) -* - nip = 1 - ipAxyz = nip - nip = nip + nZeta*3*nHer*(la+1) - ipBxyz = nip - nip = nip + nZeta*3*nHer*(lb+1) - If (nip-1.gt.nArr*nZeta) Then - Call WarningMessage(2,'D1Int: nip-1.gt.nArr*nZeta') - Write (6,*) 'nip=',nip - Write (6,*) 'nArr,nZeta=',nArr,nZeta - Call Abend() - End If -* - If (iPrint.ge.49) Then - Call RecPrt(' In D1Int: A',' ',A,1,3) - Call RecPrt(' In D1Int: RB',' ',RB,1,3) - Call RecPrt(' In D1Int: Ccoor',' ',Ccoor,1,3) - Call RecPrt(' In D1Int: P',' ',P,nZeta,3) - Write (6,*) ' In D1Int: la,lb=',la,lb - End If -* -* Compute the contact terms. -* - Call Darwin(Zeta,P,nZeta,A,Array(ipAxyz),la, - & RB,Array(ipBxyz),lb, - & Final,iStabM,nStabM,nComp,rKappa) -* - If (iPrint.ge.99) Then - Do 300 ia = 1, nElem(la) - Do 310 ib = 1, nElem(lb) - Write (Label,'(A,I2,A,I2,A)') - & 'Darwin contact(',ia,',',ib,')' - Call RecPrt(Label,' ',Final(1,1,ia,ib),nZeta,nComp) - 310 Continue - 300 Continue - End If -* -* Call GetMem(' Exit D1Int','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Alpha) - Call Unused_real_array(Beta) - Call Unused_real_array(ZInv) - Call Unused_integer(nOrdOp) - Call Unused_integer_array(lOper) - Call Unused_integer_array(iChO) - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/d1int.F90 openmolcas-22.10/src/oneint_util/d1int.F90 --- openmolcas-22.02/src/oneint_util/d1int.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/d1int.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,83 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine D1Int( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the 1-electron Darwin contact term. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, Sweden, February '91 * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "print.fh" +integer(kind=iwp) :: ia, ib, ipAxyz, ipBxyz, iPrint, iRout, nip +character(len=80) :: Label + +#include "macros.fh" +unused_var(Alpha) +unused_var(Beta) +unused_var(ZInv) +unused_var(nOrdOp) +unused_var(lOper) +unused_var(iChO) +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 150 +iPrint = nPrint(iRout) + +nip = 1 +ipAxyz = nip +nip = nip+nZeta*3*nHer*(la+1) +ipBxyz = nip +nip = nip+nZeta*3*nHer*(lb+1) +if (nip-1 > nArr*nZeta) then + call WarningMessage(2,'D1Int: nip-1 > nArr*nZeta') + write(u6,*) 'nip=',nip + write(u6,*) 'nArr,nZeta=',nArr,nZeta + call Abend() +end if + +if (iPrint >= 49) then + call RecPrt(' In D1Int: A',' ',A,1,3) + call RecPrt(' In D1Int: RB',' ',RB,1,3) + call RecPrt(' In D1Int: Ccoor',' ',Ccoor,1,3) + call RecPrt(' In D1Int: P',' ',P,nZeta,3) + write(u6,*) ' In D1Int: la,lb=',la,lb +end if + +! Compute the contact terms. + +call Darwin(Zeta,P,nZeta,A,Array(ipAxyz),la,RB,Array(ipBxyz),lb,rFinal,iStabM,nStabM,nComp,rKappa) + +if (iPrint >= 99) then + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb) + write(Label,'(A,I2,A,I2,A)') 'Darwin contact(',ia,',',ib,')' + call RecPrt(Label,' ',rFinal(:,ia,ib,:),nZeta,nComp) + end do + end do +end if + +return + +end subroutine D1Int diff -Nru openmolcas-22.02/src/oneint_util/d1mem.f openmolcas-22.10/src/oneint_util/d1mem.f --- openmolcas-22.02/src/oneint_util/d1mem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/d1mem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,26 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine D1Mem( -#define _CALLING_ -#include "mem_interface.fh" - &) - use Sizes_of_Seward, only: S - Implicit Real*8 (A-H,O-Z) -#include "mem_interface.fh" -* - nHer=S%mCentr - Mem = 3*(la+1)*nHer + - & 3*(lb+1)*nHer -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(lr) - End diff -Nru openmolcas-22.02/src/oneint_util/d1mem.F90 openmolcas-22.10/src/oneint_util/d1mem.F90 --- openmolcas-22.02/src/oneint_util/d1mem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/d1mem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,31 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine D1Mem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Sizes_of_Seward, only: S +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" + +#include "macros.fh" +unused_var(lr) + +nHer = S%mCentr +Mem = 3*(la+1)*nHer+3*(lb+1)*nHer + +return + +end subroutine D1Mem diff -Nru openmolcas-22.02/src/oneint_util/darwin.f openmolcas-22.10/src/oneint_util/darwin.f --- openmolcas-22.02/src/oneint_util/darwin.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/darwin.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,173 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine Darwin(Zeta,P,nZeta,A,Axyz,la,RB,Bxyz,lb, Final, - & iStabM,nStabM,nComp,rKappa) -************************************************************************ -* * -* Object: to compoute the 1-electron Darwin contact term. * -* * -* Author: Roland Lindh, Dept. Of Theoretical Chemistry, * -* University of Lund, Sweden, February '91 * -************************************************************************ - use Basis_Info - use Center_Info - Implicit Real*8 (A-H,O-Z) -#include "constants.fh" -#include "print.fh" -#include "real.fh" - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nComp), - & rKappa(nZeta), - & Axyz(nZeta,3,0:la), Bxyz(nZeta,3,0:lb), - & Zeta(nZeta), P(nZeta,3), A(3), RB(3), C(3), TC(3) - Integer iStabM(0:nStabM-1), iDCRT(0:7) -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 -* - iRout = 170 - iPrint = nPrint(iRout) - If (iPrint.ge.99) Then - Call RecPrt(' In Darwin: rKappa',' ',rKappa,nZeta,1) - Call RecPrt(' In Darwin: Zeta',' ',Zeta,nZeta,1) - Call RecPrt(' In Darwin: P',' ',P,nZeta,3) - End If -* - call dcopy_(nZeta*nElem(la)*nElem(lb)*nComp,[Zero],0,Final,1) -* - kdc = 0 - Do 500 kCnttp = 1, nCnttp - If (dbsc(kCnttp)%Aux .or. - & dbsc(kCnttp)%ECP .or. - & dbsc(kcnttp)%Frag) Exit - Do 501 kCnt = 1, dbsc(kCnttp)%nCntr - C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) -* - Call DCR(LmbdT,iStabM,nStabM, - & dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) - Fact = DBLE(nStabM) / DBLE(LmbdT) -* - Do 502 lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),C,TC) -* -*--------------Compute the value of the angular components associated -* to the basis functions centered on the first center. -* - call dcopy_(nZeta*3,[One],0,Axyz(1,1,0),1) - If (la.eq.0) Go To 60 -* - Do 20 iCar = 1, 3 -* - Do 30 iZeta = 1, nZeta - Axyz(iZeta,iCar,1) =TC(iCar) -A(iCar) - 30 Continue -* - Do 40 ia = 2, la - Do 50 iZeta = 1, nZeta - Axyz(iZeta,iCar,ia) = Axyz(iZeta,iCar,1) * - & Axyz(iZeta,iCar,ia-1) - 50 Continue - 40 Continue -* - 20 Continue - 60 Continue -* -*--------------Compute the value of the angular components associated to -* the basis functions centered on the second center. -* - call dcopy_(nZeta*3,[One],0,Bxyz(1,1,0),1) -* -*--------------Modify z-component to carry the charge and the exponetial -* contribution. -* - Do 210 iZeta = 1, nZeta - Bxyz(iZeta,3,0) = dbsc(kCnttp)%Charge * - & Exp ( -Zeta(iZeta) * ( (TC(1)-P(iZeta,1))**2 + - & (TC(2)-P(iZeta,2))**2 + - & (TC(3)-P(iZeta,3))**2 )) - 210 Continue - If (lb.eq.0) Go To 61 -* - Do 21 iCar = 1, 3 -* - Do 31 iZeta = 1, nZeta - Bxyz(iZeta,iCar,1) =TC(iCar) -RB(iCar) - 31 Continue -* - Do 41 ib = 2, lb - Do 51 iZeta = 1, nZeta - Bxyz(iZeta,iCar,ib) = Bxyz(iZeta,iCar,1) * - & Bxyz(iZeta,iCar,ib-1) - 51 Continue - 41 Continue - 21 Continue -* -*--------------Modify z-components with the exponential contribution -* - Do 32 ib = 1, lb - Do 42 iZeta = 1, nZeta - Bxyz(iZeta,3,ib) = Bxyz(iZeta,3,ib) * - & Bxyz(iZeta,3,0) - 42 Continue - 32 Continue -* - 61 Continue -* -*--------------Combine contributions from the varoius angular -* components. -* - Do 100 ixa = la, 0, -1 - Do 101 ixb = lb, 0, -1 - Do 110 iya = la-ixa, 0, -1 - iza = la-ixa-iya - ipa = Ind(la,ixa,iza) - Do 111 iyb = lb-ixb, 0, -1 - izb = lb-ixb-iyb - ipb = Ind(lb,ixb,izb) - Do 130 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = - & Final(iZeta,ipa,ipb,1) + Fact * - & Axyz(iZeta,1,ixa) * - & Axyz(iZeta,2,iya) * - & Axyz(iZeta,3,iza) * - & Bxyz(iZeta,1,ixb) * - & Bxyz(iZeta,2,iyb) * - & Bxyz(iZeta,3,izb) - 130 Continue - 111 Continue - 110 Continue - 101 Continue - 100 Continue - - 502 Continue - 501 Continue - kdc = kdc + dbsc(kCnttp)%nCntr - 500 Continue -* -* Factor from operator (pi/(2*c**2), c=137.036 au) -* -* Factor = Pi * One2C2 - Factor = Pi / (Two* CONST_C_IN_AU_ **2) - Do 140 ipa = 1, nElem(la) - Do 141 ipb = 1, nELem(lb) - Do 142 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = rKappa(iZeta) * - & Factor * Final(iZeta,ipa,ipb,1) - 142 Continue - 141 Continue - 140 Continue -* -* Call GetMem(' Exit Darwin ','LIST','REAL',iDum,iDum) - Return - End diff -Nru openmolcas-22.02/src/oneint_util/darwin.F90 openmolcas-22.10/src/oneint_util/darwin.F90 --- openmolcas-22.02/src/oneint_util/darwin.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/darwin.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,136 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine Darwin(Zeta,P,nZeta,A,Axyz,la,RB,Bxyz,lb,rFinal,iStabM,nStabM,nComp,rKappa) +!*********************************************************************** +! * +! Object: to compoute the 1-electron Darwin contact term. * +! * +! Author: Roland Lindh, Dept. Of Theoretical Chemistry, * +! University of Lund, Sweden, February '91 * +!*********************************************************************** + +use Basis_Info, only: dbsc, nCnttp +use Center_Info, only: dc +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: Zero, One, Half, Pi, c_in_au +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb, nStabM, iStabM(0:nStabM-1), nComp +real(kind=wp), intent(in) :: Zeta(nZeta), P(nZeta,3), A(3), RB(3), rKappa(nZeta) +real(kind=wp), intent(out) :: Axyz(nZeta,3,0:la), Bxyz(nZeta,3,0:lb), rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),nComp) +#include "print.fh" +integer(kind=iwp) :: ia, ib, iCar, iDCRT(0:7), ipa, ipb, iPrint, iRout, ixa, ixb, iya, iyb, iza, izb, kCnt, kCnttp, kdc, lDCRT, & + LmbdT, nDCRT +real(kind=wp) :: C(3), Fact, Factor, TC(3) + +iRout = 170 +iPrint = nPrint(iRout) +if (iPrint >= 99) then + call RecPrt(' In Darwin: rKappa',' ',rKappa,nZeta,1) + call RecPrt(' In Darwin: Zeta',' ',Zeta,nZeta,1) + call RecPrt(' In Darwin: P',' ',P,nZeta,3) +end if + +rFinal(:,:,:,:) = Zero + +kdc = 0 +do kCnttp=1,nCnttp + if (dbsc(kCnttp)%Aux .or. dbsc(kCnttp)%ECP .or. dbsc(kcnttp)%Frag) exit + do kCnt=1,dbsc(kCnttp)%nCntr + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + + call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) + Fact = real(nStabM,kind=wp)/real(LmbdT,kind=wp) + + do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),C,TC) + + ! Compute the value of the angular components associated + ! to the basis functions centered on the first center. + + Axyz(:,:,0) = One + + if (la /= 0) then + do iCar=1,3 + + Axyz(:,iCar,1) = TC(iCar)-A(iCar) + + do ia=2,la + Axyz(:,iCar,ia) = Axyz(:,iCar,1)*Axyz(:,iCar,ia-1) + end do + + end do + end if + + ! Compute the value of the angular components associated to + ! the basis functions centered on the second center. + + Bxyz(:,:,0) = One + + ! Modify z-component to carry the charge and the exponential contribution. + + Bxyz(:,3,0) = dbsc(kCnttp)%Charge*exp(-Zeta*((TC(1)-P(:,1))**2+(TC(2)-P(:,2))**2+(TC(3)-P(:,3))**2)) + + if (lb /= 0) then + do iCar=1,3 + + Bxyz(:,iCar,1) = TC(iCar)-RB(iCar) + + do ib=2,lb + Bxyz(:,iCar,ib) = Bxyz(:,iCar,1)*Bxyz(:,iCar,ib-1) + end do + end do + + ! Modify z-components with the exponential contribution + + do ib=1,lb + Bxyz(:,3,ib) = Bxyz(:,3,ib)*Bxyz(:,3,0) + end do + end if + + ! Combine contributions from the various angular components. + + do ixa=la,0,-1 + do ixb=lb,0,-1 + do iya=la-ixa,0,-1 + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + do iyb=lb-ixb,0,-1 + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + rFinal(:,ipa,ipb,1) = rFinal(:,ipa,ipb,1)+Fact*Axyz(:,1,ixa)*Axyz(:,2,iya)*Axyz(:,3,iza)*Bxyz(:,1,ixb)* & + Bxyz(:,2,iyb)*Bxyz(:,3,izb) + end do + end do + end do + end do + + end do + end do + kdc = kdc+dbsc(kCnttp)%nCntr +end do + +! Factor from operator (pi/(2*c**2), c=137.036 au) + +Factor = Pi*Half/c_in_au**2 +do ipa=1,nTri_Elem1(la) + do ipb=1,nTri_Elem1(lb) + rFinal(:,ipa,ipb,1) = rKappa*Factor*rFinal(:,ipa,ipb,1) + end do +end do + +return + +end subroutine Darwin diff -Nru openmolcas-22.02/src/oneint_util/dmsint.f openmolcas-22.10/src/oneint_util/dmsint.f --- openmolcas-22.02/src/oneint_util/dmsint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/dmsint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,110 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine DMSInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of diamagnetic shielding * -* integrals. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, Sweden, February '91 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - -#include "int_interface.fh" - -* Local variables - - Real*8 TC(3,2) - Integer iDCRT(0:7), iStabO(0:7) -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - iRout = 230 - iPrint = nPrint(iRout) -* - nRys=nHer -* - If (iPrint.ge.99) Then - Call RecPrt(' In DMSInt: Alpha',' ',Alpha,nAlpha,1) - Call RecPrt(' In DMSInt: Beta',' ',Beta,nBeta,1) - End If -* - nip = 1 - ipS1 = nip - nip = nip + nZeta*nElem(la)*nElem(lb+1)*3 - ipS2 = nip - nip = nip + nZeta*nElem(la)*nElem(lb)*3 - ipRes = nip - nip = nip + nZeta*nElem(la)*nElem(lb)*nComp - If (nip-1.gt.nZeta*nArr) Then - Call WarningMessage(2,'DMSInt: nip-1.gt.nZeta*nArr') - Write (6,*) 'nip=',nip - Write (6,*) 'nZeta,nArr=',nZeta,nArr - Call Abend() - End If - ipArr = nip - mArr = nZeta*nArr - nip + 1 -* - call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) -* - iComp = 1 - llOper = lOper(1) - Do 90 iComp = 2, nComp - llOper = iOr(llOper,lOper(iComp)) - 90 Continue - Call SOS(iStabO,nStabO,llOper) - Call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) -* - Do 102 lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),Ccoor(1:3,1),TC(1:3,1)) - Call OA(iDCRT(lDCRT),Ccoor(1:3,2),TC(1:3,2)) -* -*-------Compute contribution from a,b+1 -* - nComp_=1 - Call EFPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P, - & Array(ipS1),nZeta,nComp_,la,lb+1,A,RB,nRys, - & Array(ipArr),mArr,TC,nOrdOp-1) -* -*--------Compute contribution from a,b -* - Call EFPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P, - & Array(ipS2),nZeta,nComp_,la,lb,A,RB,nRys, - & Array(ipArr),mArr,TC,nOrdOp-1) -* -*--------Assemble final integral from the derivative integrals -* - Call Util4(nZeta,Array(ipRes),la,lb, - & Array(ipS1),Array(ipS2),RB,TC(1,2)) -* - nOp = NrOpr(iDCRT(lDCRT)) - Call SymAdO(Array(ipRes),nZeta,la,lb,nComp,Final,nIC, - & nOp,lOper,iChO,One) -* - 102 Continue -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/dmsint.F90 openmolcas-22.10/src/oneint_util/dmsint.F90 --- openmolcas-22.02/src/oneint_util/dmsint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/dmsint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,103 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine DMSInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of diamagnetic shielding * +! integrals. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, Sweden, February '91 * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "print.fh" +integer(kind=iwp) :: iComp, iDCRT(0:7), ipArr, ipRes, iPrint, ipS1, ipS2, iRout, iStabO(0:7), lDCRT, llOper, LmbdT, mArr, nComp_, & + nDCRT, nip, nOp, nRys, nStabO +real(kind=wp) :: TC(3,2) +integer(kind=iwp), external :: NrOpr + +#include "macros.fh" +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 230 +iPrint = nPrint(iRout) + +nRys = nHer + +if (iPrint >= 99) then + call RecPrt(' In DMSInt: Alpha',' ',Alpha,nAlpha,1) + call RecPrt(' In DMSInt: Beta',' ',Beta,nBeta,1) +end if + +nip = 1 +ipS1 = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb+1)*3 +ipS2 = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb)*3 +ipRes = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb)*nComp +if (nip-1 > nZeta*nArr) then + call WarningMessage(2,'DMSInt: nip-1 > nZeta*nArr') + write(u6,*) 'nip=',nip + write(u6,*) 'nZeta,nArr=',nZeta,nArr + call Abend() +end if +ipArr = nip +mArr = nZeta*nArr-nip+1 + +rFinal(:,:,:,:) = Zero + +iComp = 1 +llOper = lOper(1) +do iComp=2,nComp + llOper = ior(llOper,lOper(iComp)) +end do +call SOS(iStabO,nStabO,llOper) +call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) + +do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),Ccoor(1:3,1),TC(1:3,1)) + call OA(iDCRT(lDCRT),Ccoor(1:3,2),TC(1:3,2)) + + ! Compute contribution from a,b+1 + + nComp_ = 1 + call EFPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipS1),nZeta,nComp_,la,lb+1,A,RB,nRys,Array(ipArr),mArr,TC,nOrdOp-1) + + ! Compute contribution from a,b + + call EFPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipS2),nZeta,nComp_,la,lb,A,RB,nRys,Array(ipArr),mArr,TC,nOrdOp-1) + + ! Assemble final integral from the derivative integrals + + call Util4(nZeta,Array(ipRes),la,lb,Array(ipS1),Array(ipS2),RB,TC(1,2)) + + nOp = NrOpr(iDCRT(lDCRT)) + call SymAdO(Array(ipRes),nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,One) + +end do + +return + +end subroutine DMSInt diff -Nru openmolcas-22.02/src/oneint_util/dmsmem.f openmolcas-22.10/src/oneint_util/dmsmem.f --- openmolcas-22.02/src/oneint_util/dmsmem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/dmsmem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine DMSMem( -#define _CALLING_ -#include "mem_interface.fh" - &) -#include "mem_interface.fh" -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - Mem=0 - nHer =0 - Call EFMmP(nOrder,MmEFP,la,lb+1,lr-1) - Mem=Max(Mem,MmEFP) - nHer =Max(nHer,nOrder) - Call EFMmP(nOrder,MmEFP,la,lb,lr-1) - Mem=Max(Mem,MmEFP) - nHer =Max(nHer,nOrder) -* -* Add a scratch area for intermediate integrals -* - MemDer = 3*(nElem(la)*nElem(lb+1) + nElem(la)*nElem(lb)) - Mem = Mem + MemDer - Mem = Mem + nElem(la)*nElem(lb)*9 -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/dmsmem.F90 openmolcas-22.10/src/oneint_util/dmsmem.F90 --- openmolcas-22.02/src/oneint_util/dmsmem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/dmsmem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,43 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine DMSMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: MemDer, MmEFP, nOrder + +Mem = 0 +nHer = 0 +call EFMmP(nOrder,MmEFP,la,lb+1,lr-1) +Mem = max(Mem,MmEFP) +nHer = max(nHer,nOrder) +call EFMmP(nOrder,MmEFP,la,lb,lr-1) +Mem = max(Mem,MmEFP) +nHer = max(nHer,nOrder) + +! Add a scratch area for intermediate integrals + +MemDer = 3*(nTri_Elem1(la)*nTri_Elem1(lb+1)+nTri_Elem1(la)*nTri_Elem1(lb)) +Mem = Mem+MemDer +Mem = Mem+nTri_Elem1(la)*nTri_Elem1(lb)*9 + +return + +end subroutine DMSMem diff -Nru openmolcas-22.02/src/oneint_util/dTdmu_int.f openmolcas-22.10/src/oneint_util/dTdmu_int.f --- openmolcas-22.02/src/oneint_util/dTdmu_int.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/dTdmu_int.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,118 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2002, Roland Lindh * -************************************************************************ - SubRoutine dTdmu_int( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of diamagnetic shielding * -* integrals. * -* * -* Author: Roland Lindh, Dept. of Chemical Physics, University * -* of Lund, Sweden, September 2002. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - -#include "int_interface.fh" - -* Local variables - Real*8 TC(3,2) - Integer iDCRT(0:7), iStabO(0:7) -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - iRout = 230 - iPrint = nPrint(iRout) -* - nRys=nHer -* - If (iPrint.ge.99) Then - Call RecPrt(' In dTdmu_int: Alpha',' ',Alpha,nAlpha,1) - Call RecPrt(' In dTdmu_int: Beta',' ',Beta,nBeta,1) - End If -* - nip = 1 - ipS1 = nip - nip = nip + nZeta*nElem(la)*nElem(lb+1)*3 - ipS2 = nip - If (lb.ge.1) nip = nip + nZeta*nElem(la)*nElem(lb-1)*3 - ipRes = nip - nip = nip + nZeta*nElem(la)*nElem(lb)*nComp - ipB = nip - nip = nip + nZeta - If (nip-1.gt.nZeta*nArr) Then - Call WarningMessage(2,'dTdmu_int: nip-1.gt.nZeta*nArr') - Write (6,*) 'nip=',nip - Write (6,*) 'nZeta,nArr=',nZeta,nArr - Call Abend() - End If - ipArr = nip - mArr = nZeta*nArr - nip + 1 -* - call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) -* - ipOff = ipB - Do iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ipOff),nAlpha) - ipOff = ipOff + 1 - End Do -* - iComp = 1 - llOper = lOper(1) - Do iComp = 2, nComp - llOper = iOr(llOper,lOper(iComp)) - End Do - Call SOS(iStabO,nStabO,llOper) - Call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) -* - Do lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),Ccoor(1:3,1),TC(1:3,1)) - Call OA(iDCRT(lDCRT),Ccoor(1:3,2),TC(1:3,2)) -* -*-------Compute contribution from a,b+1 -* - Call EFPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P, - & Array(ipS1),nZeta,nComp,la,lb+1,A,RB,nRys, - & Array(ipArr),mArr,TC,nOrdOp) -* -*--------Compute contribution from a,b-1 -* - If (lb.ge.1) - & Call EFPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P, - & Array(ipS2),nZeta,nComp,la,lb-1,A,RB,nRys, - & Array(ipArr),mArr,TC,nOrdOp) -* -*--------Assemble final integral from the derivative integrals -* - Call Assemble_dTdmu(nZeta,Array(ipRes),la,lb, - & Array(ipS1),Array(ipS2),Array(ipB)) -* - nOp = NrOpr(iDCRT(lDCRT)) - Call SymAdO(Array(ipRes),nZeta,la,lb,nComp,Final,nIC, - & nOp ,lOper,iChO,One) -* - End Do -* -* Call GetMem(' Exit dTdmu_int','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/dtdmu_int.F90 openmolcas-22.10/src/oneint_util/dtdmu_int.F90 --- openmolcas-22.02/src/oneint_util/dtdmu_int.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/dtdmu_int.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,111 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2002, Roland Lindh * +!*********************************************************************** + +subroutine dTdmu_int( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of diamagnetic shielding * +! integrals. * +! * +! Author: Roland Lindh, Dept. of Chemical Physics, University * +! of Lund, Sweden, September 2002. * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "print.fh" +integer(kind=iwp) :: iBeta, iComp, iDCRT(0:7), ipArr, ipB, ipOff, ipRes, iPrint, ipS1, ipS2, iRout, iStabO(0:7), lDCRT, llOper, & + LmbdT, mArr, nDCRT, nip, nOp, nRys, nStabO +real(kind=wp) :: TC(3,2) +integer(kind=iwp), external :: NrOpr + +#include "macros.fh" +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 230 +iPrint = nPrint(iRout) + +nRys = nHer + +if (iPrint >= 99) then + call RecPrt(' In dTdmu_int: Alpha',' ',Alpha,nAlpha,1) + call RecPrt(' In dTdmu_int: Beta',' ',Beta,nBeta,1) +end if + +nip = 1 +ipS1 = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb+1)*3 +ipS2 = nip +if (lb >= 1) nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb-1)*3 +ipRes = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb)*nComp +ipB = nip +nip = nip+nZeta +if (nip-1 > nZeta*nArr) then + call WarningMessage(2,'dTdmu_int: nip-1 > nZeta*nArr') + write(u6,*) 'nip=',nip + write(u6,*) 'nZeta,nArr=',nZeta,nArr + call Abend() +end if +ipArr = nip +mArr = nZeta*nArr-nip+1 + +rFinal(:,:,:,:) = Zero + +ipOff = ipB-1 +do iBeta=1,nBeta + Array(ipOff+1:ipOff+nAlpha) = Beta(iBeta) + ipOff = ipOff+nAlpha +end do + +iComp = 1 +llOper = lOper(1) +do iComp=2,nComp + llOper = ior(llOper,lOper(iComp)) +end do +call SOS(iStabO,nStabO,llOper) +call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) + +do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),Ccoor(1:3,1),TC(1:3,1)) + call OA(iDCRT(lDCRT),Ccoor(1:3,2),TC(1:3,2)) + + ! Compute contribution from a,b+1 + + call EFPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipS1),nZeta,nComp,la,lb+1,A,RB,nRys,Array(ipArr),mArr,TC,nOrdOp) + + ! Compute contribution from a,b-1 + + if (lb >= 1) & + call EFPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipS2),nZeta,nComp,la,lb-1,A,RB,nRys,Array(ipArr),mArr,TC,nOrdOp) + + ! Assemble final integral from the derivative integrals + + call Assemble_dTdmu(nZeta,Array(ipRes),la,lb,Array(ipS1),Array(ipS2),Array(ipB)) + + nOp = NrOpr(iDCRT(lDCRT)) + call SymAdO(Array(ipRes),nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,One) + +end do + +return + +end subroutine dTdmu_int diff -Nru openmolcas-22.02/src/oneint_util/dTdmu_mem.f openmolcas-22.10/src/oneint_util/dTdmu_mem.f --- openmolcas-22.02/src/oneint_util/dTdmu_mem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/dTdmu_mem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine dTdmu_mem( -#define _CALLING_ -#include "mem_interface.fh" - &) -#include "mem_interface.fh" -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - Mem=0 - nHer =0 - Call EFMmP(nOrder,MmEFP,la,lb+1,lr) - Mem=Max(Mem,MmEFP) - nHer =Max(nHer,nOrder) - If (lb.ge.1) Then - Call EFMmP(nOrder,MmEFP,la,lb-1,lr) - Mem=Max(Mem,MmEFP) - nHer =Max(nHer,nOrder) - End If -* -* Add a scratch area for intermediate integrals -* - MemDer = 3*nElem(la)*nElem(lb+1) - If (lb.ge.1) MemDer=MemDer + 3*nElem(la)*nElem(lb-1) - Mem = Mem + MemDer + 1 - Mem = Mem + nElem(la)*nElem(lb)*3 -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/dtdmu_mem.F90 openmolcas-22.10/src/oneint_util/dtdmu_mem.F90 --- openmolcas-22.02/src/oneint_util/dtdmu_mem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/dtdmu_mem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,46 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine dTdmu_mem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: MemDer, MmEFP, nOrder + +Mem = 0 +nHer = 0 +call EFMmP(nOrder,MmEFP,la,lb+1,lr) +Mem = max(Mem,MmEFP) +nHer = max(nHer,nOrder) +if (lb >= 1) then + call EFMmP(nOrder,MmEFP,la,lb-1,lr) + Mem = max(Mem,MmEFP) + nHer = max(nHer,nOrder) +end if + +! Add a scratch area for intermediate integrals + +MemDer = 3*nTri_Elem1(la)*nTri_Elem1(lb+1) +if (lb >= 1) MemDer = MemDer+3*nTri_Elem1(la)*nTri_Elem1(lb-1) +Mem = Mem+MemDer+1 +Mem = Mem+nTri_Elem1(la)*nTri_Elem1(lb)*3 + +return + +end subroutine dTdmu_mem diff -Nru openmolcas-22.02/src/oneint_util/dumint.F90 openmolcas-22.10/src/oneint_util/dumint.F90 --- openmolcas-22.02/src/oneint_util/dumint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/dumint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,61 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine DumInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: dummy routine that should never be actually called. * +! * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: wp, iwp + +implicit none +#include "int_interface.fh" + +#include "macros.fh" +unused_var(Alpha) +unused_var(nAlpha) +unused_var(Beta) +unused_var(nBeta) +unused_var(Zeta) +unused_var(ZInv) +unused_var(rKappa) +unused_var(P) +unused_var(rFinal) +unused_var(nZeta) +unused_var(nIC) +unused_var(nComp) +unused_var(la) +unused_var(lb) +unused_var(A) +unused_var(RB) +unused_var(nHer) +unused_var(Array) +unused_var(nArr) +unused_var(Ccoor) +unused_var(nOrdOp) +unused_var(lOper) +unused_var(iChO) +unused_var(iStabM) +unused_var(nStabM) +unused_var(PtChrg) +unused_var(nGrid) +unused_var(iAddPot) + +call WarningMessage(2,'DumInt should never be called') +call Abend() + +end subroutine DumInt diff -Nru openmolcas-22.02/src/oneint_util/dummem.F90 openmolcas-22.10/src/oneint_util/dummem.F90 --- openmolcas-22.02/src/oneint_util/dummem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/dummem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,37 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine DumMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) +!*********************************************************************** +! * +! Object: dummy routine that should never be actually called. * +! * +!*********************************************************************** + +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" + +#include "macros.fh" +nHer = 0 +Mem = 0 +unused_var(la) +unused_var(lb) +unused_var(lr) + +call WarningMessage(2,'DumInt should never be called') +call Abend() + +end subroutine DumMem diff -Nru openmolcas-22.02/src/oneint_util/efint.f openmolcas-22.10/src/oneint_util/efint.f --- openmolcas-22.02/src/oneint_util/efint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/efint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,189 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991,1995, Roland Lindh * -************************************************************************ - SubRoutine EFInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of electric field * -* integrals. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, Sweden, January '91 * -* * -* Modified for explicit code, R. Lindh, February '95. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) - External TNAI, Fake, XCff2D, XRys2D -#include "real.fh" -#include "print.fh" - -#include "int_interface.fh" - -* Local variables - Integer iDCRT(0:7), iStabO(0:7) - Real*8 TC(3), Coori(3,4), CoorAC(3,2) - Logical EQ, NoSpecial - Integer iAnga(4) - Character*80 Label -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - nabSz(ixyz) = (ixyz+1)*(ixyz+2)*(ixyz+3)/6 - 1 -* - iRout = 200 - iPrint = nPrint(iRout) -* -* - call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) -* - iAnga(1) = la - iAnga(2) = lb - iAnga(3) = nOrdOp - iAnga(4) = 0 - call dcopy_(3, A,1,Coori(1,1),1) - call dcopy_(3,RB,1,Coori(1,2),1) - mabMin=nabSz(Max(la,lb)-1)+1 - mabMax=nabSz(la+lb) - If (EQ(A,RB)) mabMin=nabSz(la+lb-1)+1 - mcdMin=nabSz(nOrdOp-1)+1 - mcdMax=nabSz(nOrdop) - lab=(mabMax-mabMin+1) - kab=nElem(la)*nElem(lb) - lcd=(mcdMax-mcdMin+1) - labcd=lab*lcd -* -*---- Compute Flop's and size of work array which HRR will Use. -* - Call mHRR(la,lb,nFLOP,nMem) -* -*---- Distribute the work array -* - ip2 = 1 - ip1 = ip2 + nZeta*Max(labcd,lcd*nMem) - mArr = nArr - Max(labcd,lcd*nMem) -* -*---- Find center to accumulate angular momentum on. (HRR) -* - If (la.ge.lb) Then - call dcopy_(3, A,1,CoorAC(1,1),1) - Else - call dcopy_(3,RB,1,CoorAC(1,1),1) - End If -* - llOper = lOper(1) - Do 90 iComp = 2, nComp - llOper = iOr(llOper,lOper(iComp)) - 90 Continue - Call SOS(iStabO,nStabO,llOper) - Call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) -* -* - Do 102 lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),CCoor,TC) - call dcopy_(3,TC,1,CoorAC(1,2),1) - call dcopy_(3,TC,1, Coori(1,3),1) - call dcopy_(3,TC,1, Coori(1,4),1) -* -*------- Compute integrals with the Rys-Gauss quadrature. -* - nT=nZeta - NoSpecial=.True. - Call Rys(iAnga,nT, - & Zeta,ZInv,nZeta,[One],[One],1, - & P,nZeta,TC,1, - & rKappa,[One],Coori,Coori,CoorAC, - & mabMin,mabMax,mcdMin,mcdMax,Array(ip1),mArr*nZeta, - & TNAI,Fake,XCff2D,XRys2D,NoSpecial) -* -*------- The integrals are now ordered as ijkl,e,f -* -* a) Change the order to f,ijkl,e -* b) Unfold e to ab, f,ijkl,ab -* c) Change the order back to ijkl,ab,f -* -*a)----- -* - Call DGetMO(Array(ip1),nZeta*lab,nZeta*lab,lcd,Array(ip2),lcd) -* -*b)----- Use the HRR to unfold e to ab -* - Call HRR(la,lb,A,RB,Array(ip2),lcd*nZeta,nMem,ipIn) - ip3=ip2-1+ipIn -* -*c)----- -* - Call DGetMO(Array(ip3),lcd,lcd,nZeta*kab,Array(ip1),nZeta*kab) -* -*------- Modify to traceless form, the sixth element contains r*r and -* - If (nOrdOp.eq.2) Then -* If (.False.) Then - nzab=nZeta*kab - iOffxx=ip1 - iOffyy=ip1+nzab*3 - iOffzz=ip1+nzab*5 - ThreeI = One / Three - Do i = 0, nzab-1 - RR = Array(iOffxx+i) - & + Array(iOffyy+i) - & + Array(iOffzz+i) - XX = Two * Array(iOffxx+i) - - & Array(iOffyy+i) - Array(iOffzz+i) - YY = Two * Array(iOffyy+i) - - & Array(iOffxx+i) - Array(iOffzz+i) - Array(iOffxx+i) = XX * ThreeI - Array(iOffyy+i) = YY * ThreeI - Array(iOffzz+i) = RR - End Do - End If -* -* Stored as nZeta,iElem,jElem,iComp -* - If (iPrint.ge.49) Then - Write (6,*) ' In EFInt la,lb=',la,lb - nzab=nZeta*kab - Do iElem = 1, nElem(la) - Do jElem = 1, nElem(lb) - ij = (jElem-1)*nElem(la) + iElem - ip = ip1 + nZeta*(ij-1) - Do iComp = 1, nComp - Write (Label,'(A,I2,A,I2,A,I2,A)') - & ' Final (',iElem,',',jElem,',',iComp,') ' - Call RecPrt(Label,' ',Array(ip),nZeta,1) - ip = ip + nzab - End Do - End Do - End Do - End If -* -*------- Accumulate contributions -* - nOp = NrOpr(iDCRT(lDCRT)) - Call SymAdO(Array(ip1),nZeta,la,lb,nComp,Final,nIC, - & nOp ,lOper,iChO,One) -* - 102 Continue -* Call GetMem(' Exit EFInt','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Alpha) - Call Unused_real_array(Beta) - Call Unused_integer(nHer) - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/efint.F90 openmolcas-22.10/src/oneint_util/efint.F90 --- openmolcas-22.02/src/oneint_util/efint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/efint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,177 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991,1995, Roland Lindh * +!*********************************************************************** + +subroutine EFInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of electric field * +! integrals. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, Sweden, January '91 * +! * +! Modified for explicit code, R. Lindh, February '95. * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1, nTri3_Elem1 +use Constants, only: Zero, One, Two, Three +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "print.fh" +integer(kind=iwp) :: i, iAnga(4), iComp, iDCRT(0:7), iElem, ij, iOffxx, iOffyy, iOffzz, ip, ip1, ip2, ip3, ipIn, iPrint, iRout, & + iStabO(0:7), jElem, kab, lab, labcd, lcd, lDCRT, llOper, LmbdT, mabMax, mabMin, mArr, mcdMax, mcdMin, nDCRT, & + nFLOP, nMem, nOp, nStabO, nT, nzab +real(kind=wp) :: CoorAC(3,2), Coori(3,4), RR, TC(3), XX, YY +logical(kind=iwp) :: NoSpecial +character(len=80) :: Label +real(kind=wp), parameter :: ThreeI = One/Three +integer(kind=iwp), external :: NrOpr +logical(kind=iwp), external :: EQ +external :: Fake, TNAI, XCff2D, XRys2D + +#include "macros.fh" +unused_var(Alpha) +unused_var(Beta) +unused_var(nHer) +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 200 +iPrint = nPrint(iRout) + +rFinal(:,:,:,:) = Zero + +iAnga(1) = la +iAnga(2) = lb +iAnga(3) = nOrdOp +iAnga(4) = 0 +Coori(:,1) = A +Coori(:,2) = RB +mabMin = nTri3_Elem1(max(la,lb)-1) +mabMax = nTri3_Elem1(la+lb)-1 +if (EQ(A,RB)) mabMin = nTri3_Elem1(la+lb-1) +mcdMin = nTri3_Elem1(nOrdOp-1) +mcdMax = nTri3_Elem1(nOrdop)-1 +lab = (mabMax-mabMin+1) +kab = nTri_Elem1(la)*nTri_Elem1(lb) +lcd = (mcdMax-mcdMin+1) +labcd = lab*lcd + +! Compute Flop's and size of work array which HRR will Use. + +call mHRR(la,lb,nFLOP,nMem) + +! Distribute the work array + +ip2 = 1 +ip1 = ip2+nZeta*max(labcd,lcd*nMem) +mArr = nArr-max(labcd,lcd*nMem) + +! Find center to accumulate angular momentum on. (HRR) + +if (la >= lb) then + CoorAC(:,1) = A +else + CoorAC(:,1) = RB +end if + +llOper = lOper(1) +do iComp=2,nComp + llOper = ior(llOper,lOper(iComp)) +end do +call SOS(iStabO,nStabO,llOper) +call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) + +do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),CCoor,TC) + CoorAC(:,2) = TC + Coori(:,3) = TC + Coori(:,4) = TC + + ! Compute integrals with the Rys-Gauss quadrature. + + nT = nZeta + NoSpecial = .true. + call Rys(iAnga,nT,Zeta,ZInv,nZeta,[One],[One],1,P,nZeta,TC,1,rKappa,[One],Coori,Coori,CoorAC,mabMin,mabMax,mcdMin,mcdMax, & + Array(ip1),mArr*nZeta,TNAI,Fake,XCff2D,XRys2D,NoSpecial) + + ! The integrals are now ordered as ijkl,e,f + + ! a) Change the order to f,ijkl,e + ! b) Unfold e to ab, f,ijkl,ab + ! c) Change the order back to ijkl,ab,f + + ! a) + + call DGetMO(Array(ip1),nZeta*lab,nZeta*lab,lcd,Array(ip2),lcd) + + ! b) Use the HRR to unfold e to ab + + call HRR(la,lb,A,RB,Array(ip2),lcd*nZeta,nMem,ipIn) + ip3 = ip2-1+ipIn + + ! c) + + call DGetMO(Array(ip3),lcd,lcd,nZeta*kab,Array(ip1),nZeta*kab) + + ! Modify to traceless form, the sixth element contains r*r and + + if (nOrdOp == 2) then + !if (.false.) then + nzab = nZeta*kab + iOffxx = ip1 + iOffyy = ip1+nzab*3 + iOffzz = ip1+nzab*5 + do i=0,nzab-1 + RR = Array(iOffxx+i)+Array(iOffyy+i)+Array(iOffzz+i) + XX = Two*Array(iOffxx+i)-Array(iOffyy+i)-Array(iOffzz+i) + YY = Two*Array(iOffyy+i)-Array(iOffxx+i)-Array(iOffzz+i) + Array(iOffxx+i) = XX*ThreeI + Array(iOffyy+i) = YY*ThreeI + Array(iOffzz+i) = RR + end do + end if + + ! Stored as nZeta,iElem,jElem,iComp + + if (iPrint >= 49) then + write(u6,*) ' In EFInt la,lb=',la,lb + nzab = nZeta*kab + do iElem=1,nTri_Elem1(la) + do jElem=1,nTri_Elem1(lb) + ij = (jElem-1)*nTri_Elem1(la)+iElem + ip = ip1+nZeta*(ij-1) + do iComp=1,nComp + write(Label,'(A,I2,A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,',',iComp,') ' + call RecPrt(Label,' ',Array(ip),nZeta,1) + ip = ip+nzab + end do + end do + end do + end if + + ! Accumulate contributions + + nOp = NrOpr(iDCRT(lDCRT)) + call SymAdO(Array(ip1),nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,One) + +end do + +return + +end subroutine EFInt diff -Nru openmolcas-22.02/src/oneint_util/efmem.f openmolcas-22.10/src/oneint_util/efmem.f --- openmolcas-22.02/src/oneint_util/efmem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/efmem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,50 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine EFMem( -#define _CALLING_ -#include "mem_interface.fh" - &) -#include "mem_interface.fh" -* - Integer iAngV(4) -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - nabSz(ixyz) = (ixyz+1)*(ixyz+2)*(ixyz+3)/6 - 1 -* - lc = lr - ld = 0 - nHer = (la+lb+lc+ld+2)/2 - labMin=nabSz(Max(la,lb)-1)+1 - labMax=nabSz(la+lb) - lcdMin=nabSz(lr-1)+1 - lcdMax=nabSz(lr) - lab = (labMax-labMin+1) - kab = nElem(la)*nElem(lb) - lcd = (lcdMax-lcdMin+1) - labcd = lab*lcd -* - Call mHRR(la,lb,nFlop,nMem) - Mem1=Max(lcd*nMem,labcd) -* - iAngV(1) = la - iAngV(2) = lb - iAngV(3) = lc - iAngV(4) = ld - Call MemRys(iAngV,Mem2) - Mem2 = Max(Mem2,kab*lcd) -* - Mem=Mem1 + Mem2 - Return - End diff -Nru openmolcas-22.02/src/oneint_util/efmem.F90 openmolcas-22.10/src/oneint_util/efmem.F90 --- openmolcas-22.02/src/oneint_util/efmem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/efmem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,52 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine EFMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri3_Elem1, nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: iAngV(4), kab, lab, labcd, labMax, labMin, lc, lcd, lcdMax, lcdMin, ld, Mem1, Mem2, nFlop, nMem + +lc = lr +ld = 0 +nHer = (la+lb+lc+ld+2)/2 +labMin = nTri3_Elem1(max(la,lb)-1) +labMax = nTri3_Elem1(la+lb)-1 +lcdMin = nTri3_Elem1(lr-1) +lcdMax = nTri3_Elem1(lr)-1 +lab = (labMax-labMin+1) +kab = nTri_Elem1(la)*nTri_Elem1(lb) +lcd = (lcdMax-lcdMin+1) +labcd = lab*lcd + +call mHRR(la,lb,nFlop,nMem) +Mem1 = max(lcd*nMem,labcd) + +iAngV(1) = la +iAngV(2) = lb +iAngV(3) = lc +iAngV(4) = ld +call MemRys(iAngV,Mem2) +Mem2 = max(Mem2,kab*lcd) + +Mem = Mem1+Mem2 + +return + +end subroutine EFMem diff -Nru openmolcas-22.02/src/oneint_util/emfint.f openmolcas-22.10/src/oneint_util/emfint.f --- openmolcas-22.02/src/oneint_util/emfint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/emfint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,205 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2015, Roland Lindh * -************************************************************************ - SubRoutine EMFInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: to compute the electromagnetic field radiation integrals * -* using a complex Gauss-Hermite quadrature. * -* * -* Called from: OneEl * -* * -* Calling : RecPrt * -* CCrtCmp * -* CAssmbl * -* CVelInt * -* CCmbnVe * -* * -* Author: Roland Lindh, Dept. of Chemistry - Angstrom, * -* University of Uppsala, Sweden. December 2015 * -************************************************************************ - use Her_RW - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - -#include "int_interface.fh" - -* Local variables - Logical ABeq(3) - Integer iStabO(0:7), iDCRT(0:7) -* - Call EMFInt_Internal(Array) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(ZInv) - Call Unused_integer(nOrdOp) - Call Unused_integer_array(lOper) - Call Unused_integer_array(iChO) - Call Unused_integer_array(iStabM) - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If -* -* This is to allow type punning without an explicit interface - Contains - SubRoutine EMFInt_Internal(Array) - Use Iso_C_Binding - Real*8, Target :: Array(*) - Complex*16, Pointer :: zAxyz(:),zBxyz(:),zQxyz(:),zVxyz(:) -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - iRout = 195 - iPrint = nPrint(iRout) - ABeq(1) = A(1).eq.RB(1) - ABeq(2) = A(2).eq.RB(2) - ABeq(3) = A(3).eq.RB(3) -* - nip = 1 - ipAxyz = nip - nip = nip + nZeta*3*nHer*(la+1+nOrdOp) * 2 - ipBxyz = nip - nip = nip + nZeta*3*nHer*(lb+1+nOrdOp) * 2 - ipQxyz = nip - nip = nip + nZeta*3*(la+1+nOrdOp)*(lb+1+nOrdOp) * 2 - If (nOrdOp.eq.1) Then - ipVxyz = nip - nip = nip + nZeta*6*(la+1)*(lb+1) * 2 - ipA = nip - nip = nip + nZeta - ipB = nip - nip = nip + nZeta - ipRes = nip - nip = nip + nZeta*nElem(la)*nElem(lb)*nComp - Else - ipVxyz = nip - ipA = nip - ipB = nip - ipRes = nip - nip = nip + nZeta*nElem(la)*nElem(lb)*nComp - End If - If (nip-1.gt.nArr*nZeta) Then - Call WarningMessage(2,'EMFInt: nip-1.gt.nArr*nZeta') - Write (6,*) ' nArr is Wrong! ', nip-1,' > ',nArr*nZeta - Write (6,*) ' Abend in EMFInt' - Call Abend() - End If -* - If (iPrint.ge.49) Then - Call RecPrt(' In EMFInt: A',' ',A,1,3) - Call RecPrt(' In EMFInt: RB',' ',RB,1,3) - Call RecPrt(' In EMFInt: KVector',' ',CCoor,1,3) - Call RecPrt(' In EMFInt: P',' ',P,nZeta,3) - Write (6,*) ' In EMFInt: la,lb=',la,lb - End If -* - call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) -* -* Compute the cartesian values of the basis functions angular part -* Note that these arrays are complex. -* - Call C_F_Pointer(C_Loc(Array(ipAxyz)),zAxyz, - & [nZeta*3*nHer*(la+nOrdOp+1)]) - Call CCrtCmp(Zeta,P,nZeta,A,zAxyz, - & la+nOrdOp,HerR(iHerR(nHer)),nHer,ABeq,CCoor) - Call C_F_Pointer(C_Loc(Array(ipBxyz)),zBxyz, - & [nZeta*3*nHer*(lb+nOrdOp+1)]) - Call CCrtCmp(Zeta,P,nZeta,RB,zBxyz, - & lb+nOrdOp,HerR(iHerR(nHer)),nHer,ABeq,CCoor) - Nullify(zAxyz,zBxyz) -* -* Compute the cartesian components for the multipole moment -* integrals. The integrals are factorized into components. -* - Call C_F_Pointer(C_Loc(Array(ipAxyz)),zAxyz, - & [nZeta*3*nHer*(la+nOrdOp+1)]) - Call C_F_Pointer(C_Loc(Array(ipQxyz)),zQxyz, - & [nZeta*3*(la+nOrdOp+1)*(lb+nOrdOp+1)]) - Call C_F_Pointer(C_Loc(Array(ipBxyz)),zBxyz, - & [nZeta*3*nHer*(lb+nOrdOp+1)]) - Call CAssmbl(zQxyz, - & zAxyz,la+nOrdOp, - & zBxyz,lb+nOrdOp, - & nZeta,HerW(iHerW(nHer)),nHer) - Nullify(zAxyz,zBxyz,zQxyz) -* -* Compute the cartesian components for the velocity integrals. -* The velocity components are linear combinations of overlap -* components. -* - If (nOrdOp.eq.1) Then - ipAOff = ipA - Do iBeta = 1, nBeta - call dcopy_(nAlpha,Alpha,1,Array(ipAOff),1) - ipAOff = ipAOff + nAlpha - End Do - - ipBOff = ipB - Do iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ipBOff),nAlpha) - ipBOff = ipBOff + 1 - End Do -* - Call C_F_Pointer(C_Loc(Array(ipVxyz)),zVxyz, - & [nZeta*3*(la+1)*(lb+1)]) - Call C_F_Pointer(C_Loc(Array(ipQxyz)),zQxyz, - & [nZeta*3*(la+1)*(lb+1)]) - Call CVelInt(zVxyz,zQxyz,la,lb, - & Array(ipA),Array(ipB),nZeta) - Nullify(zVxyz,zQxyz) -* -* Combine the cartesian components to the full one electron -* integral. -* - Call C_F_Pointer(C_Loc(Array(ipQxyz)),zQxyz, - & [nZeta*3*(la+1)*(lb+1)]) - Call C_F_Pointer(C_Loc(Array(ipVxyz)),zVxyz, - & [nZeta*3*(la+1)*(lb+1)*2]) - Call CCmbnVe(zQxyz,nZeta,la,lb,Zeta,rKappa, - & Array(ipRes),nComp,zVxyz,CCoor,P) - Nullify(zQxyz,zVxyz) - Else - Call C_F_Pointer(C_Loc(Array(ipQxyz)),zQxyz, - & [nZeta*3*(la+1)*(lb+1)*(nOrdOp+1)]) - Call CCmbnMP(zQxyz,nZeta,la,lb,nOrdOp,Zeta, - & rKappa,Array(ipRes),nComp,CCoor,P) - Nullify(zQxyz) - End If -* - llOper=lOper(1) - Do iComp = 2, nComp - llOper = iOr(llOper,lOper(iComp)) - End Do - Call SOS(iStabO,nStabO,llOper) - Call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) -* - Do lDCRT = 0, nDCRT-1 -* -*--------Accumulate contributions -* - nOp = NrOpr(iDCRT(lDCRT)) - Call SymAdO(Array(ipRes),nZeta,la,lb,nComp,Final,nIC, - & nOp ,lOper,iChO,One) -* - End Do -* - Return - End SubRoutine EMFInt_internal -* - End diff -Nru openmolcas-22.02/src/oneint_util/emfint.F90 openmolcas-22.10/src/oneint_util/emfint.F90 --- openmolcas-22.02/src/oneint_util/emfint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/emfint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,175 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2015, Roland Lindh * +!*********************************************************************** + +subroutine EMFInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the electromagnetic field radiation integrals * +! using a complex Gauss-Hermite quadrature. * +! * +! Called from: OneEl * +! * +! Calling : RecPrt * +! CCrtCmp * +! CAssmbl * +! CVelInt * +! CCmbnVe * +! * +! Author: Roland Lindh, Dept. of Chemistry - Angstrom, * +! University of Uppsala, Sweden. December 2015 * +!*********************************************************************** + +use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc +use Her_RW, only: HerR, HerW, iHerR, iHerW +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "print.fh" +integer(kind=iwp) :: iComp, iDCRT(0:7), ipA, ipAOff, ipAxyz, ipB, ipBOff, ipBxyz, ipQxyz, ipRes, iPrint, ipVxyz, iRout, & + iStabO(0:7), lDCRT, llOper, LmbdT, nDCRT, nip, nOp, nStabO +integer(kind=iwp), external :: NrOpr + +#include "macros.fh" +unused_var(ZInv) +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 195 +iPrint = nPrint(iRout) + +nip = 1 +ipAxyz = nip +nip = nip+nZeta*3*nHer*(la+1+nOrdOp)*2 +ipBxyz = nip +nip = nip+nZeta*3*nHer*(lb+1+nOrdOp)*2 +ipQxyz = nip +nip = nip+nZeta*3*(la+1+nOrdOp)*(lb+1+nOrdOp)*2 +if (nOrdOp == 1) then + ipVxyz = nip + nip = nip+nZeta*6*(la+1)*(lb+1)*2 + ipA = nip + nip = nip+nZeta + ipB = nip + nip = nip+nZeta + ipRes = nip + nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb)*nComp +else + ipVxyz = nip + ipA = nip + ipB = nip + ipRes = nip + nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb)*nComp +end if +if (nip-1 > nArr*nZeta) then + call WarningMessage(2,'EMFInt: nip-1 > nArr*nZeta') + write(u6,*) ' nArr is Wrong! ',nip-1,' > ',nArr*nZeta + write(u6,*) ' Abend in EMFInt' + call Abend() +end if + +if (iPrint >= 49) then + call RecPrt(' In EMFInt: A',' ',A,1,3) + call RecPrt(' In EMFInt: RB',' ',RB,1,3) + call RecPrt(' In EMFInt: KVector',' ',CCoor,1,3) + call RecPrt(' In EMFInt: P',' ',P,nZeta,3) + write(u6,*) ' In EMFInt: la,lb=',la,lb +end if + +rFinal(:,:,:,:) = Zero + +call EMFInt_Internal(Array) + +llOper = lOper(1) +do iComp=2,nComp + llOper = ior(llOper,lOper(iComp)) +end do +call SOS(iStabO,nStabO,llOper) +call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) + +do lDCRT=0,nDCRT-1 + + ! Accumulate contributions + + nOp = NrOpr(iDCRT(lDCRT)) + call SymAdO(Array(ipRes),nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,One) + +end do + +return + +! This is to allow type punning without an explicit interface +contains + +subroutine EMFInt_Internal(Array) + + real(kind=wp), target :: Array(*) + complex(kind=wp), pointer :: zAxyz(:,:,:,:), zBxyz(:,:,:,:), zQxyz(:,:,:,:), zQxyz2(:,:,:,:,:), zVxyz(:,:,:,:,:) + integer(kind=iwp) :: iBeta + + ! Compute the cartesian values of the basis functions angular part + ! Note that these arrays are complex. + + call c_f_pointer(c_loc(Array(ipAxyz)),zAxyz,[nZeta,3,nHer,la+nOrdOp+1]) + call c_f_pointer(c_loc(Array(ipBxyz)),zBxyz,[nZeta,3,nHer,lb+nOrdOp+1]) + call c_f_pointer(c_loc(Array(ipQxyz)),zQxyz,[nZeta,3,la+nOrdOp+1,lb+nOrdOp+1]) + + call CCrtCmp(Zeta,P,nZeta,A,zAxyz,la+nOrdOp,HerR(iHerR(nHer)),nHer,CCoor) + call CCrtCmp(Zeta,P,nZeta,RB,zBxyz,lb+nOrdOp,HerR(iHerR(nHer)),nHer,CCoor) + + ! Compute the cartesian components for the multipole moment + ! integrals. The integrals are factorized into components. + + call CAssmbl(zQxyz,zAxyz,la+nOrdOp,zBxyz,lb+nOrdOp,nZeta,HerW(iHerW(nHer)),nHer) + + ! Compute the cartesian components for the velocity integrals. + ! The velocity components are linear combinations of overlap components. + + if (nOrdOp == 1) then + ipAOff = ipA-1 + do iBeta=1,nBeta + Array(ipAOff+1:ipAOff+nAlpha) = Alpha + ipAOff = ipAOff+nAlpha + end do + + ipBOff = ipB-1 + do iBeta=1,nBeta + Array(ipBOff+1:ipBOff+nAlpha) = Beta(iBeta) + ipBOff = ipBOff+nAlpha + end do + + call c_f_pointer(c_loc(Array(ipVxyz)),zVxyz,[nZeta,3,la+1,lb+1,2]) + call CVelInt(zVxyz,zQxyz,la,lb,Array(ipA),Array(ipB),nZeta) + + ! Combine the cartesian components to the full one electron integral. + + call CCmbnVe(zQxyz,nZeta,la,lb,Zeta,rKappa,Array(ipRes),nComp,zVxyz,CCoor,P) + nullify(zVxyz) + else + call c_f_pointer(c_loc(Array(ipQxyz)),zQxyz2,[nZeta,3,la+1,lb+1,nOrdOp+1]) + call CCmbnMP(zQxyz2,nZeta,la,lb,nOrdOp,Zeta,rKappa,Array(ipRes),nComp,CCoor,P) + nullify(zQxyz2) + end if + + nullify(zAxyz,zBxyz,zQxyz) + + return + +end subroutine EMFInt_internal + +end subroutine EMFInt diff -Nru openmolcas-22.02/src/oneint_util/emfmem.f openmolcas-22.10/src/oneint_util/emfmem.f --- openmolcas-22.02/src/oneint_util/emfmem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/emfmem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine EMFMem( -#define _CALLING_ -#include "mem_interface.fh" - &) -#include "mem_interface.fh" -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - nHer=(la+lb+lr+2)/2 - Mem = 3*nHer*(la+1+lr) * 2 - & + 3*nHer*(lb+1+lr) * 2 - & + 3*(la+1+lr)*(lb+1+lr) * 2 - If (lr.eq.1) Then - Mem = Mem - & + 6*(la+1)*(lb+1) * 2 + 2 - & + nElem(la)*nElem(lb)*nElem(lr)*12 - Else - Mem = Mem - & + nElem(la)*nElem(lb)*nElem(lr)*2 - End If -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(lr) - End diff -Nru openmolcas-22.02/src/oneint_util/emfmem.F90 openmolcas-22.10/src/oneint_util/emfmem.F90 --- openmolcas-22.02/src/oneint_util/emfmem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/emfmem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,33 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine EMFMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" + +nHer = (la+lb+lr+2)/2 +Mem = 3*nHer*(la+1+lr)*2+3*nHer*(lb+1+lr)*2+3*(la+1+lr)*(lb+1+lr)*2 +if (lr == 1) then + Mem = Mem+6*(la+1)*(lb+1)*2+2+nTri_Elem1(la)*nTri_Elem1(lb)*nTri_Elem1(lr)*12 +else + Mem = Mem+nTri_Elem1(la)*nTri_Elem1(lb)*nTri_Elem1(lr)*2 +end if + +return + +end subroutine EMFMem diff -Nru openmolcas-22.02/src/oneint_util/epeint.f openmolcas-22.10/src/oneint_util/epeint.f --- openmolcas-22.02/src/oneint_util/epeint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/epeint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,113 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine EPEInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of nuclear attraction * -* integrals. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, Sweden, February '91 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) - External TNAI, Fake, Cff2D, XRys2D -#include "real.fh" -#include "print.fh" - -#include "int_interface.fh" - -* Local variables - Real*8 TC(3), Coori(3,4), Coora(3,4), CoorAC(3,2) - Integer iAnga(4), iDCRT(0:7), iStabO(0:7) - Logical EQ, NoSpecial -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - nabSz(ixyz) = (ixyz+1)*(ixyz+2)*(ixyz+3)/6 - 1 -* - call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) -* - iAnga(1) = la - iAnga(2) = lb - iAnga(3) = 0 - iAnga(4) = 0 - call dcopy_(3,A,1,Coora(1,1),1) - call dcopy_(3,RB,1,Coora(1,2),1) - call dcopy_(2*3,Coora(1,1),1,Coori(1,1),1) - mabMin = nabSz(Max(la,lb)-1)+1 - mabMax = nabSz(la+lb) - If (EQ(A,RB)) mabMin = nabSz(la+lb-1)+1 -* -* Compute FLOP's and size of the work array which Hrr will use. -* - Call mHrr(la,lb,nFLOP,nMem) -* -*-----Find center to accumulate angular momentum on. -* - If (la.ge.lb) Then - call dcopy_(3,A,1,CoorAC(1,1),1) - Else - call dcopy_(3,RB,1,CoorAC(1,1),1) - End If -* - llOper = lOper(1) - Do 90 iComp = 2, nComp - llOper = iOr(llOper,lOper(iComp)) - 90 Continue - Call SOS(iStabO,nStabO,llOper) - Call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) - Do 100 lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),CCoor,TC) - call dcopy_(3,TC,1,CoorAC(1,2),1) - call dcopy_(3,TC,1,Coori(1,3),1) - call dcopy_(3,TC,1,Coori(1,4),1) - call dcopy_(3,TC,1,Coora(1,3),1) - call dcopy_(3,TC,1,Coora(1,4),1) -* -*--------Compute primitive integrals before the application of HRR. -* - nT = nZeta - NoSpecial=.True. - Call Rys(iAnga,nt,Zeta,ZInv,nZeta,[One],[One],1,P,nZeta, - & TC,1,rKappa,[One],Coori,Coora,CoorAC, - & mabmin,mabmax,0,0,Array,nArr*nZeta, - & TNAI,Fake,Cff2D,xRys2D,NoSpecial) -* -*--------Use the HRR to compute the required primitive integrals. -* - Call HRR(la,lb,A,RB,Array,nZeta,nMem,ipIn) -* -*--------Accumulate contributions to the symmetry adaped operator -* - nOp = NrOpr(iDCRT(lDCRT)) - Call SymAdO(Array(ipIn),nZeta,la,lb,nComp,Final,nIC, - & nOp ,lOper,iChO,One) -* - 100 Continue -* -* Call GetMem(' Exit EPEInt','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Alpha) - Call Unused_real_array(Beta) - Call Unused_integer(nHer) - Call Unused_integer(nOrdOp) - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/epeint.F90 openmolcas-22.10/src/oneint_util/epeint.F90 --- openmolcas-22.02/src/oneint_util/epeint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/epeint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,108 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine EPEInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of nuclear attraction * +! integrals. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, Sweden, February '91 * +!*********************************************************************** + +use Index_Functions, only: nTri3_Elem1, nTri_Elem1 +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +#include "int_interface.fh" +integer(kind=iwp) :: iAnga(4), iComp, iDCRT(0:7), ipIn, iStabO(0:7), lDCRT, llOper, LmbdT, mabMax, mabMin, nDCRT, nFLOP, nMem, & + nOp, nStabO, nT +real(kind=wp) :: Coora(3,4), CoorAC(3,2), Coori(3,4), TC(3) +logical(kind=iwp) :: NoSpecial +integer(kind=iwp), external :: NrOpr +logical(kind=iwp), external :: EQ +external :: Cff2D, Fake, TNAI, XRys2D + +#include "macros.fh" +unused_var(Alpha) +unused_var(Beta) +unused_var(nHer) +unused_var(nOrdOp) +unused_var(PtChrg) +unused_var(iAddPot) + +rFinal(:,:,:,:) = Zero + +iAnga(1) = la +iAnga(2) = lb +iAnga(3) = 0 +iAnga(4) = 0 +Coora(:,1) = A +Coora(:,2) = RB +Coori(:,1:2) = Coora(:,1:2) +mabMin = nTri3_Elem1(max(la,lb)-1) +mabMax = nTri3_Elem1(la+lb)-1 +if (EQ(A,RB)) mabMin = nTri3_Elem1(la+lb-1) + +! Compute FLOP's and size of the work array which Hrr will use. + +call mHrr(la,lb,nFLOP,nMem) + +! Find center to accumulate angular momentum on. + +if (la >= lb) then + CoorAC(:,1) = A +else + CoorAC(:,1) = RB +end if + +llOper = lOper(1) +do iComp=2,nComp + llOper = ior(llOper,lOper(iComp)) +end do +call SOS(iStabO,nStabO,llOper) +call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) +do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),CCoor,TC) + CoorAC(:,2) = TC + Coori(:,3) = TC + Coori(:,4) = TC + Coora(:,3) = TC + Coora(:,4) = TC + + ! Compute primitive integrals before the application of HRR. + + nT = nZeta + NoSpecial = .true. + call Rys(iAnga,nt,Zeta,ZInv,nZeta,[One],[One],1,P,nZeta,TC,1,rKappa,[One],Coori,Coora,CoorAC,mabmin,mabmax,0,0,Array,nArr*nZeta, & + TNAI,Fake,Cff2D,xRys2D,NoSpecial) + + ! Use the HRR to compute the required primitive integrals. + + call HRR(la,lb,A,RB,Array,nZeta,nMem,ipIn) + + ! Accumulate contributions to the symmetry adapted operator + + nOp = NrOpr(iDCRT(lDCRT)) + call SymAdO(Array(ipIn),nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,One) + +end do + +return + +end subroutine EPEInt diff -Nru openmolcas-22.02/src/oneint_util/epemem.f openmolcas-22.10/src/oneint_util/epemem.f --- openmolcas-22.02/src/oneint_util/epemem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/epemem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine EPEMem( -#define _CALLING_ -#include "mem_interface.fh" - &) -#include "mem_interface.fh" -* - Integer iAngV(4) -* - Call mHrr(la,lb,nFlop,MemHrr) -* - nHer=(la+lb+2)/2 - iAngV(1) = la - iAngV(2) = lb - iAngV(3) = 0 - iAngV(4) = 0 - Call MemRys(iAngV,Mem) -* - Mem = Max(Mem,MemHrr) - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(lr) - End diff -Nru openmolcas-22.02/src/oneint_util/epemem.F90 openmolcas-22.10/src/oneint_util/epemem.F90 --- openmolcas-22.02/src/oneint_util/epemem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/epemem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,41 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine EPEMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: iAngV(4), MemHrr, nFlop + +#include "macros.fh" +unused_var(lr) + +call mHrr(la,lb,nFlop,MemHrr) + +nHer = (la+lb+2)/2 +iAngV(1) = la +iAngV(2) = lb +iAngV(3) = 0 +iAngV(4) = 0 +call MemRys(iAngV,Mem) + +Mem = max(Mem,MemHrr) + +return + +end subroutine EPEMem diff -Nru openmolcas-22.02/src/oneint_util/kneint.f openmolcas-22.10/src/oneint_util/kneint.f --- openmolcas-22.02/src/oneint_util/kneint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/kneint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,196 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine KnEInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: to compute the kinetic energy integrals with the Gauss- * -* Hermite quadrature. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* November '90 * -* Modified to multipole moments November '90 * -************************************************************************ - use Her_RW - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -* -#include "rmat_option.fh" -#include "rmat.fh" -* -#include "print.fh" - -#include "int_interface.fh" -* Local variables - Logical ABeq(3) -* - iRout = 150 - iPrint = nPrint(iRout) - ABeq(1) = A(1).eq.RB(1) - ABeq(2) = A(2).eq.RB(2) - ABeq(3) = A(3).eq.RB(3) -* - nip = 1 - ipAxyz = nip - nip = nip + nZeta*3*nHer*(la+2) - ipBxyz = nip - nip = nip + nZeta*3*nHer*(lb+2) - ipRxyz = nip - nip = nip + nZeta*3*nHer*(nOrdOp-1) - ipQxyz = nip - nip = nip + nZeta*3*(la+2)*(lb+2)*(nOrdOp-1) - ipTxyz = nip - nip = nip + nZeta*3*(la+1)*(lb+1) - ipA = nip - nip = nip + nZeta - ipB = nip - nip = nip + nZeta -* * -************************************************************************ -* * - If (RMat_type_integrals) Then - ipRnr=nip - nip = nip + nZeta*(la+lb+3) - ipqC = nip - nip = nip + nZeta*(la+lb+1) - ipDi =nip - nip = nip + nZeta*(la+lb+1) - Else - ipRnr=-1 - ipqC =-1 - ipDi =-1 - End If -* * -************************************************************************ -* * - If (nip-1.gt.nArr*nZeta) Then - Call WarningMessage(2,'KNEInt: nip-1.gt.nArr*nZeta') - Write (6,*) 'nip=',nip - Write (6,*) 'nArr,nZeta=',nArr,nZeta - Call Abend() - End If -* - If (iPrint.ge.49) Then - Call RecPrt(' In KnEInt: A',' ',A,1,3) - Call RecPrt(' In KnEInt: RB',' ',RB,1,3) - Call RecPrt(' In KnEInt: Ccoor',' ',Ccoor,1,3) - Call RecPrt(' In KnEInt: P',' ',P,nZeta,3) - Write (6,*) ' In KnEInt: la,lb=',la,lb - End If -* - If (RMat_type_integrals) Then -* * -************************************************************************ -* * -* R-matrix calculations: continuum basis functions (A=B=P=0) -* Compute the contributions of the basis functions and multipole -* radial part -* - lsum=la+lb+2 - Call radlc(Zeta,nZeta,lsum,Array(ipRnr)) -* -* Optional for photoionization: -* R-matrix calculations: continuum basis functions (A=B=P=0) -* Compute the contributions of the Coulomb operator times qCoul -* outside the sphere Omega -* - if(abs(qCoul).gt.Epsq) then - lsum=la+lb - icop=1 - Call radlq(Zeta,nzeta,lsum,Array(ipqC),icop) - endif -* - if(abs(dipol1).gt.Epsq) then - lsum=la+lb - icop=2 - Call radlq(Zeta,nzeta,lsum,Array(ipDi),icop) - endif -* -* Combine the radial and angular component to the full one electron -* integral. -* - Call CmbnKEr(Array(ipRnr),Array(ipqC),Array(ipDi), - & nZeta,la,lb,Zeta,Final, - & nComp,Alpha,nAlpha,Beta,nBeta) -* - Else -* * -************************************************************************ -* * -* -* Compute the cartesian values of the basis functions angular part -* - Call CrtCmp(Zeta,P,nZeta,A,Array(ipAxyz), - & la+1,HerR(iHerR(nHer)),nHer,ABeq) - Call CrtCmp(Zeta,P,nZeta,RB,Array(ipBxyz), - & lb+1,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the contribution from the multipole moment operator -* - ABeq(1) = .False. - ABeq(2) = .False. - ABeq(3) = .False. - Call CrtCmp(Zeta,P,nZeta,Ccoor,Array(ipRxyz), - & nOrdOp-2,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the cartesian components for the multipole moment -* integrals. The integrals are factorized into components. -* - Call Assmbl(Array(ipQxyz), - & Array(ipAxyz),la+1, - & Array(ipRxyz),nOrdOp-2, - & Array(ipBxyz),lb+1, - & nZeta,HerW(iHerW(nHer)),nHer) -* -* Compute the cartesian components for the kinetic energy integrals. -* The kinetic energy components are linear combinations of overlap -* components. -* - ipAOff = ipA - Do 200 iBeta = 1, nBeta - call dcopy_(nAlpha,Alpha,1,Array(ipAOff),1) - ipAOff = ipAOff + nAlpha - 200 Continue -* - ipBOff = ipB - Do 210 iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ipBOff),nAlpha) - ipBOff = ipBOff + 1 - 210 Continue -* - Call Kntc(Array(ipTxyz),Array(ipQxyz),la,lb, - & Array(ipA),Array(ipB),nZeta) -* -* Combine the cartesian components to the full one electron -* integral. -* - Call CmbnKE(Array(ipQxyz),nZeta,la,lb,nOrdOp-2,Zeta,rKappa,Final, - & nComp,Array(ipTxyz)) -* - End If -* -* Call GetMem(' Exit KnEInt','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(ZInv) - Call Unused_integer_array(lOper) - Call Unused_integer_array(iChO) - Call Unused_integer_array(iStabM) - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/kneint.F90 openmolcas-22.10/src/oneint_util/kneint.F90 --- openmolcas-22.02/src/oneint_util/kneint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/kneint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,179 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine KnEInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the kinetic energy integrals with the Gauss- * +! Hermite quadrature. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! November '90 * +! Modified to multipole moments November '90 * +!*********************************************************************** + +use Her_RW, only: HerR, HerW, iHerR, iHerW +use Index_Functions, only: nTri_Elem1 +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "rmat_option.fh" +#include "rmat.fh" +#include "print.fh" +integer(kind=iwp) :: iBeta, icop, ipA, ipAOff, ipAxyz, ipB, ipBOff, ipBxyz, ipDi, ipqC, ipQxyz, iPrint, ipRnr, ipRxyz, ipTxyz, & + iRout, lsum, nip +logical(kind=iwp) :: ABeq(3) + +#include "macros.fh" +unused_var(ZInv) +unused_var(lOper) +unused_var(iChO) +unused_var(iStabM) +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 150 +iPrint = nPrint(iRout) +ABeq(:) = A == RB + +nip = 1 +ipAxyz = nip +nip = nip+nZeta*3*nHer*(la+2) +ipBxyz = nip +nip = nip+nZeta*3*nHer*(lb+2) +ipRxyz = nip +nip = nip+nZeta*3*nHer*(nOrdOp-1) +ipQxyz = nip +nip = nip+nZeta*3*(la+2)*(lb+2)*(nOrdOp-1) +ipTxyz = nip +nip = nip+nZeta*3*(la+1)*(lb+1) +ipA = nip +nip = nip+nZeta +ipB = nip +nip = nip+nZeta +! * +!*********************************************************************** +! * +if (RMat_type_integrals) then + ipRnr = nip + nip = nip+nZeta*(la+lb+3) + ipqC = nip + nip = nip+nZeta*(la+lb+1) + ipDi = nip + nip = nip+nZeta*(la+lb+1) +else + ipRnr = -1 + ipqC = -1 + ipDi = -1 +end if +! * +!*********************************************************************** +! * +if (nip-1 > nArr*nZeta) then + call WarningMessage(2,'KNEInt: nip-1 > nArr*nZeta') + write(u6,*) 'nip=',nip + write(u6,*) 'nArr,nZeta=',nArr,nZeta + call Abend() +end if + +if (iPrint >= 49) then + call RecPrt(' In KnEInt: A',' ',A,1,3) + call RecPrt(' In KnEInt: RB',' ',RB,1,3) + call RecPrt(' In KnEInt: Ccoor',' ',Ccoor,1,3) + call RecPrt(' In KnEInt: P',' ',P,nZeta,3) + write(u6,*) ' In KnEInt: la,lb=',la,lb +end if + +if (RMat_type_integrals) then + ! * + !********************************************************************* + ! * + ! R-matrix calculations: continuum basis functions (A=B=P=0) + ! Compute the contributions of the basis functions and multipole + ! radial part + + lsum = la+lb+2 + call radlc(Zeta,nZeta,lsum,Array(ipRnr)) + + ! Optional for photoionization: + ! R-matrix calculations: continuum basis functions (A=B=P=0) + ! Compute the contributions of the Coulomb operator times qCoul + ! outside the sphere Omega + + if (abs(qCoul) > Epsq) then + lsum = la+lb + icop = 1 + call radlq(Zeta,nzeta,lsum,Array(ipqC),icop) + end if + + if (abs(dipol1) > Epsq) then + lsum = la+lb + icop = 2 + call radlq(Zeta,nzeta,lsum,Array(ipDi),icop) + end if + + ! Combine the radial and angular component to the full one electron integral. + + call CmbnKEr(Array(ipRnr),Array(ipqC),Array(ipDi),nZeta,la,lb,Zeta,rFinal,nComp,Alpha,nAlpha,Beta,nBeta) + +else + ! * + !********************************************************************* + ! * + + ! Compute the cartesian values of the basis functions angular part + + call CrtCmp(Zeta,P,nZeta,A,Array(ipAxyz),la+1,HerR(iHerR(nHer)),nHer,ABeq) + call CrtCmp(Zeta,P,nZeta,RB,Array(ipBxyz),lb+1,HerR(iHerR(nHer)),nHer,ABeq) + + ! Compute the contribution from the multipole moment operator + + ABeq(:) = .false. + call CrtCmp(Zeta,P,nZeta,Ccoor,Array(ipRxyz),nOrdOp-2,HerR(iHerR(nHer)),nHer,ABeq) + + ! Compute the cartesian components for the multipole moment + ! integrals. The integrals are factorized into components. + + call Assmbl(Array(ipQxyz),Array(ipAxyz),la+1,Array(ipRxyz),nOrdOp-2,Array(ipBxyz),lb+1,nZeta,HerW(iHerW(nHer)),nHer) + + ! Compute the cartesian components for the kinetic energy integrals. + ! The kinetic energy components are linear combinations of overlap components. + + ipAOff = ipA-1 + do iBeta=1,nBeta + Array(ipAOff+1:ipAOff+nAlpha) = Alpha + ipAOff = ipAOff+nAlpha + end do + + ipBOff = ipB-1 + do iBeta=1,nBeta + Array(ipBOff+1:ipBOff+nAlpha) = Beta(iBeta) + ipBOff = ipBOff+nAlpha + end do + + call Kntc(Array(ipTxyz),Array(ipQxyz),la,lb,Array(ipA),Array(ipB),nZeta) + + ! Combine the cartesian components to the full one electron integral. + + call CmbnKE(Array(ipQxyz),nZeta,la,lb,nOrdOp-2,Zeta,rKappa,rFinal,nComp,Array(ipTxyz)) + +end if + +return + +end subroutine KnEInt diff -Nru openmolcas-22.02/src/oneint_util/kneint_giao.f openmolcas-22.10/src/oneint_util/kneint_giao.f --- openmolcas-22.02/src/oneint_util/kneint_giao.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/kneint_giao.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,178 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine KnEInt_GIAO(Alpha,nAlpha,Beta, nBeta,Zeta,ZInv,rKappa, - & P,Final,nZeta,nIC,nComp,la,lb,A,RB,nHer, - & Array,nArr,Ccoor,nOrdOp,lOper,iChO, - & iStabM,nStabM, - & PtChrg,nGrid,iAddPot) -************************************************************************ -* * -* Object: to compute the kinetic energy integrals with the Gauss- * -* Hermite quadrature. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* November '90 * -* Modified to multipole moments November '90 * -************************************************************************ - use Her_RW - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -* -#include "rmat_option.fh" -#include "rmat.fh" -* -#include "print.fh" - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nIC), - & Zeta(nZeta), ZInv(nZeta), Alpha(nAlpha), Beta(nBeta), - & rKappa(nZeta), P(nZeta,3), A(3), RB(3), TC(3), - & Array(nZeta*nArr), Ccoor(3) - Integer lOper(nComp), iStabM(0:nStabM-1), iStabO(0:7), - & iDCRT(0:7), iChO(nComp) - Logical ABeq(3) -* -* Statement function for Cartesian index -* - nElem(i) = (i+1)*(i+2)/2 -* Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 -* iOff(ixyz) = ixyz*(ixyz+1)*(ixyz+2)/6 -* Index(ixyz,ix,iz) = Ind(ixyz,ix,iz) + iOff(ixyz) -* - iRout = 150 - iPrint = nPrint(iRout) - ABeq(1) = A(1).eq.RB(1) - ABeq(2) = A(2).eq.RB(2) - ABeq(3) = A(3).eq.RB(3) -* - nip = 1 - ipAxyz = nip - nip = nip + nZeta*3*nHer*(la+2) - ipBxyz = nip - nip = nip + nZeta*3*nHer*(lb+2) - ipRxyz = nip - nip = nip + nZeta*3*nHer*(nOrdOp+2) - ipQxyz = nip - nip = nip + nZeta*3*(la+2)*(lb+2)*(nOrdOp+2) - ipTxyz = nip - nip = nip + nZeta*3*(la+1)*(lb+1)*(nOrdOp+2) - ipWxyz = nip - nip = nip + nZeta*3*(la+1)*(lb+1)*2 - ipA = nip - nip = nip + nZeta - ipB = nip - nip = nip + nZeta - ipFnl = nip - nip = nip + nZeta*nElem(la)*nElem(lb)*nComp -* * -************************************************************************ -* * - If (nip-1.gt.nArr*nZeta) Then - Call WarningMessage(2,'KNEInt: nip-1.gt.nArr*nZeta') - Write (6,*) 'nip=',nip - Write (6,*) 'nArr,nZeta=',nArr,nZeta - Call Abend() - End If -* - If (iPrint.ge.49) Then - Call RecPrt(' In KnEInt: A',' ',A,1,3) - Call RecPrt(' In KnEInt: RB',' ',RB,1,3) - Call RecPrt(' In KnEInt: Ccoor',' ',Ccoor,1,3) - Call RecPrt(' In KnEInt: P',' ',P,nZeta,3) - Write (6,*) ' In KnEInt: la,lb=',la,lb - End If -* * -************************************************************************ -* * - llOper = lOper(1) - Do iComp = 2, nComp - llOper = iOr(llOper,lOper(iComp)) - End Do -* * -************************************************************************ -* * -* -* Compute the cartesian values of the basis functions angular part -* - Call CrtCmp(Zeta,P,nZeta,A,Array(ipAxyz), - & la+1,HerR(iHerR(nHer)),nHer,ABeq) - Call CrtCmp(Zeta,P,nZeta,RB,Array(ipBxyz), - & lb+1,HerR(iHerR(nHer)),nHer,ABeq) -* - Call SOS(iStabO,nStabO,llOper) - Call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) -* - Do lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),CCoor,TC) -* -* Compute the contribution from the multipole moment operator -* - ABeq(1) = .False. - ABeq(2) = .False. - ABeq(3) = .False. - Call CrtCmp(Zeta,P,nZeta,TC,Array(ipRxyz), - & nOrdOp+1,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the cartesian components for the multipole moment -* integrals. The integrals are factorized into components. -* - Call Assmbl(Array(ipQxyz), - & Array(ipAxyz),la+1, - & Array(ipRxyz),nOrdOp+1, - & Array(ipBxyz),lb+1, - & nZeta,HerW(iHerW(nHer)),nHer) -* -* Compute the cartesian components for the kinetic energy -* integrals. The kinetic energy components are linear -* combinations of overlap components. -* - ipAOff = ipA - Do iBeta = 1, nBeta - call dcopy_(nAlpha,Alpha,1,Array(ipAOff),1) - ipAOff = ipAOff + nAlpha - End Do -* - ipBOff = ipB - Do iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ipBOff),nAlpha) - ipBOff = ipBOff + 1 - End Do -* - Call Kntc_GIAO(Array(ipTxyz),Array(ipQxyz),Array(ipWxyz), - & la,lb,nOrdOp, - & Array(ipA),Array(ipB),nZeta) -* -* Combine the cartesian components to the full one electron -* integral. -* - nB=3 - Call CmbnKE_GIAO(Array(ipQxyz),nZeta,la,lb,nOrdOp,Zeta,rKappa, - & Array(ipFnl),nComp/nB,nB,Array(ipTxyz), - & Array(ipWxyz),A,RB,TC) -* -* Accumulate contributions -* - nOp = NrOpr(iDCRT(lDCRT)) - Call SymAdO(Array(ipFnl),nZeta,la,lb,nComp,Final,nIC, - & nOp ,lOper,iChO,One) -* - End Do -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(ZInv) - Call Unused_real(PtChrg) - Call Unused_integer(nGrid) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/kneint_giao.F90 openmolcas-22.10/src/oneint_util/kneint_giao.F90 --- openmolcas-22.02/src/oneint_util/kneint_giao.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/kneint_giao.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,152 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine KnEInt_GIAO( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the kinetic energy integrals with the Gauss- * +! Hermite quadrature. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! November '90 * +! Modified to multipole moments November '90 * +!*********************************************************************** + +use Her_RW, only: HerR, HerW, iHerR, iHerW +use Index_Functions, only: nTri_Elem1 +use Constants, only: One +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "print.fh" +integer(kind=iwp) :: iBeta, iComp, iDCRT(0:7), ipA, ipAOff, ipAxyz, ipB, ipBOff, ipBxyz, ipFnl, ipQxyz, iPrint, ipRxyz, ipTxyz, & + ipWxyz, iRout, iStabO(0:7), lDCRT, llOper, LmbdT, nB, nDCRT, nip, nOp, nStabO +real(kind=wp) :: TC(3) +logical(kind=iwp) :: ABeq(3) +integer(kind=iwp), external :: NrOpr + +#include "macros.fh" +unused_var(ZInv) +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 150 +iPrint = nPrint(iRout) +ABeq(:) = A == RB + +nip = 1 +ipAxyz = nip +nip = nip+nZeta*3*nHer*(la+2) +ipBxyz = nip +nip = nip+nZeta*3*nHer*(lb+2) +ipRxyz = nip +nip = nip+nZeta*3*nHer*(nOrdOp+2) +ipQxyz = nip +nip = nip+nZeta*3*(la+2)*(lb+2)*(nOrdOp+2) +ipTxyz = nip +nip = nip+nZeta*3*(la+1)*(lb+1)*(nOrdOp+2) +ipWxyz = nip +nip = nip+nZeta*3*(la+1)*(lb+1)*2 +ipA = nip +nip = nip+nZeta +ipB = nip +nip = nip+nZeta +ipFnl = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb)*nComp +! * +!*********************************************************************** +! * +if (nip-1 > nArr*nZeta) then + call WarningMessage(2,'KNEInt: nip-1 > nArr*nZeta') + write(u6,*) 'nip=',nip + write(u6,*) 'nArr,nZeta=',nArr,nZeta + call Abend() +end if + +if (iPrint >= 49) then + call RecPrt(' In KnEInt: A',' ',A,1,3) + call RecPrt(' In KnEInt: RB',' ',RB,1,3) + call RecPrt(' In KnEInt: Ccoor',' ',Ccoor,1,3) + call RecPrt(' In KnEInt: P',' ',P,nZeta,3) + write(u6,*) ' In KnEInt: la,lb=',la,lb +end if +! * +!*********************************************************************** +! * +llOper = lOper(1) +do iComp=2,nComp + llOper = ior(llOper,lOper(iComp)) +end do +! * +!*********************************************************************** +! * + +! Compute the cartesian values of the basis functions angular part + +call CrtCmp(Zeta,P,nZeta,A,Array(ipAxyz),la+1,HerR(iHerR(nHer)),nHer,ABeq) +call CrtCmp(Zeta,P,nZeta,RB,Array(ipBxyz),lb+1,HerR(iHerR(nHer)),nHer,ABeq) + +call SOS(iStabO,nStabO,llOper) +call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) + +do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),CCoor,TC) + + ! Compute the contribution from the multipole moment operator + + ABeq(:) = .false. + call CrtCmp(Zeta,P,nZeta,TC,Array(ipRxyz),nOrdOp+1,HerR(iHerR(nHer)),nHer,ABeq) + + ! Compute the cartesian components for the multipole moment + ! integrals. The integrals are factorized into components. + + call Assmbl(Array(ipQxyz),Array(ipAxyz),la+1,Array(ipRxyz),nOrdOp+1,Array(ipBxyz),lb+1,nZeta,HerW(iHerW(nHer)),nHer) + + ! Compute the cartesian components for the kinetic energy + ! integrals. The kinetic energy components are linear + ! combinations of overlap components. + + ipAOff = ipA-1 + do iBeta=1,nBeta + Array(ipAOff+1:ipAOff+nAlpha) = Alpha + ipAOff = ipAOff+nAlpha + end do + + ipBOff = ipB-1 + do iBeta=1,nBeta + Array(ipBOff+1:ipBOff+nAlpha) = Beta(iBeta) + ipBOff = ipBOff+nAlpha + end do + + call Kntc_GIAO(Array(ipTxyz),Array(ipQxyz),Array(ipWxyz),la,lb,Array(ipA),Array(ipB),nZeta) + + ! Combine the cartesian components to the full one electron integral. + + nB = 3 + call CmbnKE_GIAO(Array(ipQxyz),nZeta,la,lb,nOrdOp,Zeta,rKappa,Array(ipFnl),nComp/nB,nB,Array(ipTxyz),Array(ipWxyz),A,RB,TC) + + ! Accumulate contributions + + nOp = NrOpr(iDCRT(lDCRT)) + call SymAdO(Array(ipFnl),nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,One) + +end do + +return + +end subroutine KnEInt_GIAO diff -Nru openmolcas-22.02/src/oneint_util/knemem.f openmolcas-22.10/src/oneint_util/knemem.f --- openmolcas-22.02/src/oneint_util/knemem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/knemem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine KnEMem( -#define _CALLING_ -#include "mem_interface.fh" - &) -#include "mem_interface.fh" -* -#include "rmat_option.fh" -* - nHer=(la+lb+lr+2)/2 - Mem = 3*nHer*(la+2) + - & 3*nHer*(lb+2) + - & 3*nHer*(lr-1) + - & 3*(la+2)*(lb+2)*(lr-1) + - & 3*(la+1)*(lb+1) + 1 + 1 - If (RMat_type_integrals) Then - Mem = Mem - & + la+lb+3 - & + la+lb+1 - & + la+lb+1 - End If -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/knemem.F90 openmolcas-22.10/src/oneint_util/knemem.F90 --- openmolcas-22.02/src/oneint_util/knemem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/knemem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,29 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine KnEMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +#include "rmat_option.fh" + +nHer = (la+lb+lr+2)/2 +Mem = 3*nHer*(la+2)+3*nHer*(lb+2)+3*nHer*(lr-1)+3*(la+2)*(lb+2)*(lr-1)+3*(la+1)*(lb+1)+1+1 +if (RMat_type_integrals) Mem = Mem+la+lb+3+la+lb+1+la+lb+1 + +return + +end subroutine KnEMem diff -Nru openmolcas-22.02/src/oneint_util/knemem_giao.f openmolcas-22.10/src/oneint_util/knemem_giao.f --- openmolcas-22.02/src/oneint_util/knemem_giao.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/knemem_giao.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,27 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine KnEMem_GIAO(nHer,MemKne_GIAO,la,lb,lr) -* - nElem(i) = (i+1)*(i+2)/2 -* - nHer=((la+1)+(lb+1)+lr+3)/2 - - MemKnE_GIAO = 3*nHer*(la+2) - & + 3*nHer*(lb+2) - & + 3*nHer*(lr+2) - & + 3*(la+2)*(lb+2)*(lr+2) - & + 3*(la+1)*(lb+1)*(lr+2) - & + 3*(la+1)*(lb+1)*2 - & + 1 + 1 - & + nElem(la)*nElem(lb)*3 -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/knemem_giao.F90 openmolcas-22.10/src/oneint_util/knemem_giao.F90 --- openmolcas-22.02/src/oneint_util/knemem_giao.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/knemem_giao.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,30 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine KnEMem_GIAO( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" + +nHer = ((la+1)+(lb+1)+lr+3)/2 + +Mem = 3*nHer*(la+2)+3*nHer*(lb+2)+3*nHer*(lr+2)+3*(la+2)*(lb+2)*(lr+2)+3*(la+1)*(lb+1)*(lr+2)+3*(la+1)*(lb+1)*2+1+1+ & + nTri_Elem1(la)*nTri_Elem1(lb)*3 + +return + +end subroutine KnEMem_GIAO diff -Nru openmolcas-22.02/src/oneint_util/knemmp.f openmolcas-22.10/src/oneint_util/knemmp.f --- openmolcas-22.02/src/oneint_util/knemmp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/knemmp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine KnEMmP(nHer,MmKneP,la,lb,lr) -* - nHer=(la+lb+lr+2)/2 - MmKnEP = 3*nHer*(la+2) + - & 3*nHer*(lb+2) + - & 3*nHer*(lr-1) + - & 3*(la+2)*(lb+2)*(lr-1) + - & 3*(la+1)*(lb+1) + 1 + 1 -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/knemmp.F90 openmolcas-22.10/src/oneint_util/knemmp.F90 --- openmolcas-22.02/src/oneint_util/knemmp.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/knemmp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,27 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine KnEMmP( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" + +nHer = (la+lb+lr+2)/2 +Mem = 3*nHer*(la+2)+3*nHer*(lb+2)+3*nHer*(lr-1)+3*(la+2)*(lb+2)*(lr-1)+3*(la+1)*(lb+1)+1+1 + +return + +end subroutine KnEMmP diff -Nru openmolcas-22.02/src/oneint_util/kntc.f openmolcas-22.10/src/oneint_util/kntc.f --- openmolcas-22.02/src/oneint_util/kntc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/kntc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,95 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Kntc(Txyz,Sxyz,na,nb,Alpha,Beta,nZeta) -************************************************************************ -* * -* Object: to assemble the cartesian components of the kinetic energy * -* integral from the cartesian components of the overlap * -* integral. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* November '90 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Txyz(nZeta,3,0:na,0:nb), Sxyz(nZeta,3,0:na+1,0:nb+1), - & Alpha(nZeta), Beta(nZeta) - Character*80 Label -* - iRout = 115 - iPrint = nPrint(iRout) -* - If (iPrint.ge.99) Then - Call RecPrt(' In Kntc: Alpha',' ',Alpha,nZeta,1) - Call RecPrt(' In Kntc: Beta ',' ',Beta ,nZeta,1) - Do 1 ia = 0, na+1 - Do 2 ib = 0, nb+1 - Write (Label,'(A,I2,A,I2,A)') - & ' In Kntc: Sxyz(',ia,',',ib,')' - Call RecPrt(Label,' ',Sxyz(1,1,ia,ib),nZeta,3) - 2 Continue - 1 Continue - End If - Do 10 ia = 0, na - Do 20 ib = 0, nb - If (ia.eq.0 .and. ib.eq.0) Then - Do 31 iCar = 1, 3 - Do 41 iZeta = 1, nZeta - Txyz(iZeta,iCar,ia,ib) = - & Two * Alpha(iZeta) * Beta(iZeta) * - & Sxyz(iZeta,iCar,ia+1,ib+1) - 41 Continue - 31 Continue - Else If (ia.eq.0) Then - Do 32 iCar = 1, 3 - Do 42 iZeta = 1, nZeta - Txyz(iZeta,iCar,ia,ib) = - & Two * Alpha(iZeta) * Beta(iZeta) * - & Sxyz(iZeta,iCar,ia+1,ib+1) - & - Alpha(iZeta) * DBLE(ib) * Sxyz(iZeta,iCar,ia+1,ib-1) - 42 Continue - 32 Continue - Else If (ib.eq.0) Then - Do 33 iCar = 1, 3 - Do 43 iZeta = 1, nZeta - Txyz(iZeta,iCar,ia,ib) = - & Two * Alpha(iZeta) * Beta(iZeta) * - & Sxyz(iZeta,iCar,ia+1,ib+1) - & - Beta(iZeta) * DBLE(ia) * Sxyz(iZeta,iCar,ia-1,ib+1) - 43 Continue - 33 Continue - Else - Do 30 iCar = 1, 3 - Do 40 iZeta = 1, nZeta - Txyz(iZeta,iCar,ia,ib) = - & Half * DBLE(ia * ib) * Sxyz(iZeta,iCar,ia-1,ib-1) - & - Beta(iZeta) * DBLE(ia) * Sxyz(iZeta,iCar,ia-1,ib+1) - & - Alpha(iZeta) * DBLE(ib) * Sxyz(iZeta,iCar,ia+1,ib-1) - & + Two * Alpha(iZeta) * Beta(iZeta) * - & Sxyz(iZeta,iCar,ia+1,ib+1) - 40 Continue - 30 Continue - End If - If (iPrint.ge.99) Then - Write (Label,'(A,I2,A,I2,A)') ' In Kntc: Txyz(',ia,',', - & ib,')' - Call RecPrt(Label,' ',Txyz(1,1,ia,ib),nZeta,3) - End If - 20 Continue - 10 Continue -* -* Call GetMem(' Exit Kntc ','CHECK','REAL',iDum,iDum) - Return - End diff -Nru openmolcas-22.02/src/oneint_util/kntc.F90 openmolcas-22.10/src/oneint_util/kntc.F90 --- openmolcas-22.02/src/oneint_util/kntc.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/kntc.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,79 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Kntc(Txyz,Sxyz,na,nb,Alpha,Beta,nZeta) +!*********************************************************************** +! * +! Object: to assemble the cartesian components of the kinetic energy * +! integral from the cartesian components of the overlap * +! integral. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! November '90 * +!*********************************************************************** + +use Constants, only: Two, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: na, nb, nZeta +real(kind=wp), intent(out) :: Txyz(nZeta,3,0:na,0:nb) +real(kind=wp), intent(in) :: Sxyz(nZeta,3,0:na+1,0:nb+1), Alpha(nZeta), Beta(nZeta) +#include "print.fh" +integer(kind=iwp) :: ia, ib, iCar, iPrint, iRout +character(len=80) :: Label + +iRout = 115 +iPrint = nPrint(iRout) + +if (iPrint >= 99) then + call RecPrt(' In Kntc: Alpha',' ',Alpha,nZeta,1) + call RecPrt(' In Kntc: Beta ',' ',Beta,nZeta,1) + do ia=0,na+1 + do ib=0,nb+1 + write(Label,'(A,I2,A,I2,A)') ' In Kntc: Sxyz(',ia,',',ib,')' + call RecPrt(Label,' ',Sxyz(:,:,ia,ib),nZeta,3) + end do + end do +end if +do ia=0,na + do ib=0,nb + if ((ia /= 0) .and. (ib /= 0)) then + do iCar=1,3 + Txyz(:,iCar,ia,ib) = Two*Alpha*Beta*Sxyz(:,iCar,ia+1,ib+1)+Half*real(ia*ib,kind=wp)*Sxyz(:,iCar,ia-1,ib-1)- & + Alpha*real(ib,kind=wp)*Sxyz(:,iCar,ia+1,ib-1)-Beta*real(ia,kind=wp)*Sxyz(:,iCar,ia-1,ib+1) + end do + else if (ia /= 0) then + do iCar=1,3 + Txyz(:,iCar,ia,ib) = Two*Alpha*Beta*Sxyz(:,iCar,ia+1,ib+1)-Beta*real(ia,kind=wp)*Sxyz(:,iCar,ia-1,ib+1) + end do + else if (ib /= 0) then + do iCar=1,3 + Txyz(:,iCar,ia,ib) = Two*Alpha*Beta*Sxyz(:,iCar,ia+1,ib+1)-Alpha*real(ib,kind=wp)*Sxyz(:,iCar,ia+1,ib-1) + end do + else + do iCar=1,3 + Txyz(:,iCar,ia,ib) = Two*Alpha*Beta*Sxyz(:,iCar,ia+1,ib+1) + end do + end if + if (iPrint >= 99) then + write(Label,'(A,I2,A,I2,A)') ' In Kntc: Txyz(',ia,',',ib,')' + call RecPrt(Label,' ',Txyz(:,:,ia,ib),nZeta,3) + end if + end do +end do + +return + +end subroutine Kntc diff -Nru openmolcas-22.02/src/oneint_util/kntc_giao.f openmolcas-22.10/src/oneint_util/kntc_giao.f --- openmolcas-22.02/src/oneint_util/kntc_giao.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/kntc_giao.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,170 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Kntc_GIAO(Txyz,Rxyz,Wxyz,na,nb,nr,Alpha,Beta,nZeta) -************************************************************************ -* * -* Object: to assemble the cartesian components of the kinetic energy * -* integral from the cartesian components of the overlap * -* integral. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* November '90 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Txyz(nZeta,3,0:na ,0:nb, 0:1), - & Rxyz(nZeta,3,0:na+1,0:nb+1,0:1), - & Wxyz(nZeta,3,0:na ,0:nb , 2), - & Alpha(nZeta), Beta(nZeta) - Character*80 Label -* * -************************************************************************ -* * - iRout = 115 - iPrint = nPrint(iRout) -* * -************************************************************************ -* * - If (iPrint.ge.99) Then - Call RecPrt(' In Kntc: Alpha',' ',Alpha,nZeta,1) - Call RecPrt(' In Kntc: Beta ',' ',Beta ,nZeta,1) - Do ia = 0, na+1 - Do ib = 0, nb+1 - Write (Label,'(A,I2,A,I2,A)') - & ' In Kntc: Rxyz(',ia,',',ib,',0)' - Call RecPrt(Label,' ',Rxyz(1,1,ia,ib,0),nZeta,3) - Write (Label,'(A,I2,A,I2,A)') - & ' In Kntc: Rxyz(',ia,',',ib,',1)' - Call RecPrt(Label,' ',Rxyz(1,1,ia,ib,1),nZeta,3) - End Do - End Do - End If -* * -************************************************************************ -* * - Do ia = 0, na - Do ib = 0, nb - If (ia.eq.0 .and. ib.eq.0) Then - Do iCar = 1, 3 - Do iZeta = 1, nZeta - Txyz(iZeta,iCar,ia,ib,0) = - & Two * Alpha(iZeta) * Beta(iZeta) * - & Rxyz(iZeta,iCar,ia+1,ib+1,0) - Txyz(iZeta,iCar,ia,ib,1) = - & Two * Alpha(iZeta) * Beta(iZeta) * - & Rxyz(iZeta,iCar,ia+1,ib+1,1) - Wxyz(iZeta,iCar,ia,ib,1) = - & -Two * Alpha(iZeta) * - & Rxyz(iZeta,iCar,ia+1,ib ,0) - Wxyz(iZeta,iCar,ia,ib,2) = - & -Two * Beta(iZeta) * - & Rxyz(iZeta,iCar,ia ,ib+1,0) - End Do - End Do - Else If (ia.eq.0) Then - Do iCar = 1, 3 - Do iZeta = 1, nZeta - Txyz(iZeta,iCar,ia,ib,0) = - & Two * Alpha(iZeta) * Beta(iZeta) * - & Rxyz(iZeta,iCar,ia+1,ib+1,0) - & - Alpha(iZeta) * ib * Rxyz(iZeta,iCar,ia+1,ib-1,0) - Txyz(iZeta,iCar,ia,ib,1) = - & Two * Alpha(iZeta) * Beta(iZeta) * - & Rxyz(iZeta,iCar,ia+1,ib+1,1) - & - Alpha(iZeta) * ib * Rxyz(iZeta,iCar,ia+1,ib-1,1) - Wxyz(iZeta,iCar,ia,ib,1) = - & -Two * Alpha(iZeta) * - & Rxyz(iZeta,iCar,ia+1,ib ,0) - Wxyz(iZeta,iCar,ia,ib,2) = - & -Two * Beta(iZeta) * - & Rxyz(iZeta,iCar,ia ,ib+1,0) - & + ib * Rxyz(iZeta,iCar,ia ,ib-1,0) - End Do - End Do - Else If (ib.eq.0) Then - Do iCar = 1, 3 - Do iZeta = 1, nZeta - Txyz(iZeta,iCar,ia,ib,0) = - & Two * Alpha(iZeta) * Beta(iZeta) * - & Rxyz(iZeta,iCar,ia+1,ib+1,0) - & - Beta(iZeta) * ia * Rxyz(iZeta,iCar,ia-1,ib+1,0) - Txyz(iZeta,iCar,ia,ib,1) = - & Two * Alpha(iZeta) * Beta(iZeta) * - & Rxyz(iZeta,iCar,ia+1,ib+1,1) - & - Beta(iZeta) * ia * Rxyz(iZeta,iCar,ia-1,ib+1,1) - Wxyz(iZeta,iCar,ia,ib,1) = - & -Two * Alpha(iZeta) * - & Rxyz(iZeta,iCar,ia+1,ib ,0) - & + ia * Rxyz(iZeta,iCar,ia-1,ib ,0) - Wxyz(iZeta,iCar,ia,ib,2) = - & -Two * Beta(iZeta) * - & Rxyz(iZeta,iCar,ia ,ib+1,0) - End Do - End Do - Else - Do iCar = 1, 3 - Do iZeta = 1, nZeta - Txyz(iZeta,iCar,ia,ib,0) = - & Half * ia * ib * Rxyz(iZeta,iCar,ia-1,ib-1,0) - & - Beta(iZeta) * ia * Rxyz(iZeta,iCar,ia-1,ib+1,0) - & - Alpha(iZeta) * ib * Rxyz(iZeta,iCar,ia+1,ib-1,0) - & + Two * Alpha(iZeta) * Beta(iZeta) * - & Rxyz(iZeta,iCar,ia+1,ib+1,0) - Txyz(iZeta,iCar,ia,ib,1) = - & Half * ia * ib * Rxyz(iZeta,iCar,ia-1,ib-1,1) - & - Beta(iZeta) * ia * Rxyz(iZeta,iCar,ia-1,ib+1,1) - & - Alpha(iZeta) * ib * Rxyz(iZeta,iCar,ia+1,ib-1,1) - & + Two * Alpha(iZeta) * Beta(iZeta) * - & Rxyz(iZeta,iCar,ia+1,ib+1,1) - Wxyz(iZeta,iCar,ia,ib,1) = - & -Two * Alpha(iZeta) * - & Rxyz(iZeta,iCar,ia+1,ib ,0) - & + ia * Rxyz(iZeta,iCar,ia-1,ib ,0) - Wxyz(iZeta,iCar,ia,ib,2) = - & -Two * Beta(iZeta) * - & Rxyz(iZeta,iCar,ia ,ib+1,0) - & + ib * Rxyz(iZeta,iCar,ia ,ib-1,0) - End Do - End Do - End If -* * -************************************************************************ -* * - If (iPrint.ge.99) Then - Write (Label,'(A,I2,A,I2,A)') ' In Kntc: Txyz(',ia,',', - & ib,',0)' - Call RecPrt(Label,' ',Txyz(1,1,ia,ib,0),nZeta,3) - Write (Label,'(A,I2,A,I2,A)') ' In Kntc: Txyz(',ia,',', - & ib,',1)' - Call RecPrt(Label,' ',Txyz(1,1,ia,ib,1),nZeta,3) - Write (Label,'(A,I2,A,I2,A)') ' In Kntc: Wxyz(',ia,',', - & ib,',1)' - Call RecPrt(Label,' ',Wxyz(1,1,ia,ib,1),nZeta,3) - Write (Label,'(A,I2,A,I2,A)') ' In Kntc: Wxyz(',ia,',', - & ib,',2)' - Call RecPrt(Label,' ',Wxyz(1,1,ia,ib,2),nZeta,3) - End If -* * -************************************************************************ -* * - End Do - End Do -* * -************************************************************************ -* * - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(nr) - End diff -Nru openmolcas-22.02/src/oneint_util/kntc_giao.F90 openmolcas-22.10/src/oneint_util/kntc_giao.F90 --- openmolcas-22.02/src/oneint_util/kntc_giao.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/kntc_giao.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,117 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Kntc_GIAO(Txyz,Rxyz,Wxyz,na,nb,Alpha,Beta,nZeta) +!*********************************************************************** +! * +! Object: to assemble the cartesian components of the kinetic energy * +! integral from the cartesian components of the overlap * +! integral. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! November '90 * +!*********************************************************************** + +use Constants, only: Two, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: na, nb, nZeta +real(kind=wp), intent(in) :: Rxyz(nZeta,3,0:na+1,0:nb+1,0:1), Alpha(nZeta), Beta(nZeta) +real(kind=wp), intent(out) :: Txyz(nZeta,3,0:na,0:nb,0:1), Wxyz(nZeta,3,0:na,0:nb,2) +#include "print.fh" +integer(kind=iwp) :: ia, ib, iCar, iPrint, iRout +character(len=80) :: Label + +! * +!*********************************************************************** +! * +iRout = 115 +iPrint = nPrint(iRout) +! * +!*********************************************************************** +! * +if (iPrint >= 99) then + call RecPrt(' In Kntc: Alpha',' ',Alpha,nZeta,1) + call RecPrt(' In Kntc: Beta ',' ',Beta,nZeta,1) + do ia=0,na+1 + do ib=0,nb+1 + write(Label,'(A,I2,A,I2,A)') ' In Kntc: Rxyz(',ia,',',ib,',0)' + call RecPrt(Label,' ',Rxyz(:,:,ia,ib,0),nZeta,3) + write(Label,'(A,I2,A,I2,A)') ' In Kntc: Rxyz(',ia,',',ib,',1)' + call RecPrt(Label,' ',Rxyz(:,:,ia,ib,1),nZeta,3) + end do + end do +end if +! * +!*********************************************************************** +! * +do ia=0,na + do ib=0,nb + if ((ia /= 0) .and. (ib /= 0)) then + do iCar=1,3 + Txyz(:,iCar,ia,ib,0) = Two*Alpha*Beta*Rxyz(:,iCar,ia+1,ib+1,0)+Half*ia*ib*Rxyz(:,iCar,ia-1,ib-1,0)- & + Beta*ia*Rxyz(:,iCar,ia-1,ib+1,0)-Alpha*ib*Rxyz(:,iCar,ia+1,ib-1,0) + Txyz(:,iCar,ia,ib,1) = Two*Alpha*Beta*Rxyz(:,iCar,ia+1,ib+1,1)+Half*ia*ib*Rxyz(:,iCar,ia-1,ib-1,1)- & + Beta*ia*Rxyz(:,iCar,ia-1,ib+1,1)-Alpha*ib*Rxyz(:,iCar,ia+1,ib-1,1) + Wxyz(:,iCar,ia,ib,1) = -Two*Alpha*Rxyz(:,iCar,ia+1,ib,0)+ia*Rxyz(:,iCar,ia-1,ib,0) + Wxyz(:,iCar,ia,ib,2) = -Two*Beta*Rxyz(:,iCar,ia,ib+1,0)+ib*Rxyz(:,iCar,ia,ib-1,0) + end do + else if (ia /= 0) then + do iCar=1,3 + Txyz(:,iCar,ia,ib,0) = Two*Alpha*Beta*Rxyz(:,iCar,ia+1,ib+1,0)-Beta*ia*Rxyz(:,iCar,ia-1,ib+1,0) + Txyz(:,iCar,ia,ib,1) = Two*Alpha*Beta*Rxyz(:,iCar,ia+1,ib+1,1)-Beta*ia*Rxyz(:,iCar,ia-1,ib+1,1) + Wxyz(:,iCar,ia,ib,1) = -Two*Alpha*Rxyz(:,iCar,ia+1,ib,0)+ia*Rxyz(:,iCar,ia-1,ib,0) + Wxyz(:,iCar,ia,ib,2) = -Two*Beta*Rxyz(:,iCar,ia,ib+1,0) + end do + else if (ib /= 0) then + do iCar=1,3 + Txyz(:,iCar,ia,ib,0) = Two*Alpha*Beta*Rxyz(:,iCar,ia+1,ib+1,0)-Alpha*ib*Rxyz(:,iCar,ia+1,ib-1,0) + Txyz(:,iCar,ia,ib,1) = Two*Alpha*Beta*Rxyz(:,iCar,ia+1,ib+1,1)-Alpha*ib*Rxyz(:,iCar,ia+1,ib-1,1) + Wxyz(:,iCar,ia,ib,1) = -Two*Alpha*Rxyz(:,iCar,ia+1,ib,0) + Wxyz(:,iCar,ia,ib,2) = -Two*Beta*Rxyz(:,iCar,ia,ib+1,0)+ib*Rxyz(:,iCar,ia,ib-1,0) + end do + else + do iCar=1,3 + Txyz(:,iCar,ia,ib,0) = Two*Alpha*Beta*Rxyz(:,iCar,ia+1,ib+1,0) + Txyz(:,iCar,ia,ib,1) = Two*Alpha*Beta*Rxyz(:,iCar,ia+1,ib+1,1) + Wxyz(:,iCar,ia,ib,1) = -Two*Alpha*Rxyz(:,iCar,ia+1,ib,0) + Wxyz(:,iCar,ia,ib,2) = -Two*Beta*Rxyz(:,iCar,ia,ib+1,0) + end do + end if + ! * + !******************************************************************* + ! * + if (iPrint >= 99) then + write(Label,'(A,I2,A,I2,A)') ' In Kntc: Txyz(',ia,',',ib,',0)' + call RecPrt(Label,' ',Txyz(:,:,ia,ib,0),nZeta,3) + write(Label,'(A,I2,A,I2,A)') ' In Kntc: Txyz(',ia,',',ib,',1)' + call RecPrt(Label,' ',Txyz(:,:,ia,ib,1),nZeta,3) + write(Label,'(A,I2,A,I2,A)') ' In Kntc: Wxyz(',ia,',',ib,',1)' + call RecPrt(Label,' ',Wxyz(:,:,ia,ib,1),nZeta,3) + write(Label,'(A,I2,A,I2,A)') ' In Kntc: Wxyz(',ia,',',ib,',2)' + call RecPrt(Label,' ',Wxyz(:,:,ia,ib,2),nZeta,3) + end if + ! * + !******************************************************************* + ! * + end do +end do +! * +!*********************************************************************** +! * + +return + +end subroutine Kntc_GIAO diff -Nru openmolcas-22.02/src/oneint_util/m1int.f openmolcas-22.10/src/oneint_util/m1int.f --- openmolcas-22.02/src/oneint_util/m1int.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/m1int.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,247 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1993, Roland Lindh * -* 1993, Per Boussard * -************************************************************************ - SubRoutine M1Int( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of the M1 integrals used * -* ECP calculations. The operator is the nuclear attraction * -* operator times a s-type gaussian function. * -* * -* Alpha : exponents of bra gaussians * -* nAlpha: number of primitives (exponents) of bra gaussians * -* Beta : as Alpha but for ket gaussians * -* nBeta : as nAlpha but for the ket gaussians * -* Zeta : sum of exponents (nAlpha x nBeta) * -* ZInv : inverse of Zeta * -* rKappa: gaussian prefactor for the products of bra and ket * -* gaussians. * -* P : center of new gaussian from the products of bra and ket * -* gaussians. * -* Final : array for computed integrals * -* nZeta : nAlpha x nBeta * -* nComp : number of components in the operator (e.g. dipolmoment * -* operator has three components) * -* la : total angular momentum of bra gaussian * -* lb : total angular momentum of ket gaussian * -* A : center of bra gaussian * -* B : center of ket gaussian * -* nRys : order of Rys- or Hermite-Gauss polynomial * -* Array : Auxiliary memory as requested by ECPMem * -* nArr : length of Array * -* Ccoor : coordinates of the operator, zero for symmetric oper. * -* NOrdOp: Order of the operator * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, Sweden, and Per Boussard, Dept. of Theoretical * -* Physics, University of Stockholm, Sweden, October '93. * -************************************************************************ - use Basis_Info - use Center_Info - Implicit Real*8 (A-H,O-Z) - External TNAI, Fake, Cff2D, XRys2D -#include "real.fh" -#include "print.fh" - -#include "int_interface.fh" - -* Local variables - Real*8 C(3), TC(3), CoorAC(3,2), Coori(3,4), Coora(3,4) - Character*80 Label - Integer iDCRT(0:7), iAnga(4) - Logical EQ, NoSpecial -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - nabSz(ixyz) = (ixyz+1)*(ixyz+2)*(ixyz+3)/6 - 1 -* - iRout = 193 - iPrint = nPrint(iRout) -* - If (iPrint.ge.49) Then - Call RecPrt(' In M1Int: A',' ',A,1,3) - Call RecPrt(' In M1Int: RB',' ',RB,1,3) - Call RecPrt(' In M1Int: Ccoor',' ',Ccoor,1,3) - Call RecPrt(' In M1Int: P',' ',P,nZeta,3) - Write (6,*) ' In M1Int: la,lb=',' ',la,lb - End If -* - iAnga(1) = la - iAnga(2) = lb - iAnga(3) = 0 - iAnga(4) = 0 - mabMin = nabSz(Max(la,lb)-1)+1 - mabMax = nabSz(la+lb) - If (EQ(A,RB)) mabMin=nabSz(la+lb-1)+1 - mAInt = (mabMax-mabMin+1) -* -* Find center to accumulate angular momentum on. (HRR) -* - If (la.ge.lb) Then - call dcopy_(3,A,1,CoorAC(1,1),1) - Else - call dcopy_(3,RB,1,CoorAC(1,1),1) - End If -* -*-----Compute FLOP's and size of work array which HRR will use. -* - Call mHrr(la,lb,nFlop,nMem) -* -*-----Allocate Scratch for primitives and work area for HRR -* - ip = 1 - ipAInt = ip - k = nabSz(la+lb) - nabSz(Max(la,lb)-1) - ip = ip + nZeta*Max(k,nMem) - ipK = ip - ip = ip + nZeta - ipZ = ip - ip = ip + nZeta - ipZI = ip - ip = ip + nZeta - ipPx = ip - ip = ip + nZeta - ipPy = ip - ip = ip + nZeta - ipPz = ip - ip = ip + nZeta - If (ip-1.gt.nArr*nZeta) Then - Call WarningMessage(2,'M1Int: ip-1.gt.nArr*nZeta') - Write (6,*) ' nArr,nZeta=',nArr,nZeta - Write (6,*) ' nMem=',nMem - Call Abend() - End If - ipTmp = ip - mArray = nArr*nZeta - ip + 1 -* - call dcopy_(nZeta*Max(k,nMem),[Zero],0,Array(ipAInt),1) -* -*-----Loop over nuclear centers. -* - kdc = 0 - Do 100 kCnttp = 1, nCnttp - If (.Not.dbsc(kCnttp)%ECP) Go To 111 - If (dbsc(kCnttp)%nM1.eq.0) Go To 111 - Do 101 kCnt = 1, dbsc(kCnttp)%nCntr - C(1:3)= dbsc(kCnttp)%Coor(1:3,kCnt) -* - Call DCR(LmbdT,iStabM,nStabM, - & dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) - Fact = DBLE(nStabM) / DBLE(LmbdT) -* - Do 102 lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),C,TC) - call dcopy_(3,A,1,Coora(1,1),1) - call dcopy_(3,RB,1,Coora(1,2),1) - call dcopy_(6,Coora(1,1),1,Coori(1,1),1) - If (.Not.EQ(A,RB) .or. .Not.EQ(A,TC)) Then - Coori(1,1) = Coori(1,1)+One -* Coora(1,1) = Coora(1,1)+One - End If - call dcopy_(3,TC,1,CoorAC(1,2),1) - call dcopy_(3,TC,1,Coori(1,3),1) - call dcopy_(3,TC,1,Coori(1,4),1) - call dcopy_(3,TC,1,Coora(1,3),1) - call dcopy_(3,TC,1,Coora(1,4),1) -* - Do 1011 iM1xp=1, dbsc(kCnttp)%nM1 - Gamma = dbsc(kCnttp)%M1xp(iM1xp) -* -*-----------------Modify the original basis. Observe that -* simplification due to A=B are not valid for the -* exponent index, eq. P-A=/=0. -* - Do 1012 iZeta = 1, nZeta - PTC2 = (P(iZeta,1)-TC(1))**2 - & + (P(iZeta,2)-TC(2))**2 - & + (P(iZeta,3)-TC(3))**2 - Tmp0 = Zeta(iZeta)+Gamma - Tmp1 = Exp(-Zeta(iZeta)*Gamma*PTC2/Tmp0) - Array(ipK+iZeta-1) = rKappa(iZeta) * Tmp1 - Array(ipZ+iZeta-1) = Tmp0 - Array(ipZI+iZeta-1) = One/Tmp0 - Array(ipPx+iZeta-1) = - & (Zeta(iZeta)*P(iZeta,1)+Gamma*TC(1))/Tmp0 - Array(ipPy+iZeta-1) = - & (Zeta(iZeta)*P(iZeta,2)+Gamma*TC(2))/Tmp0 - Array(ipPz+iZeta-1) = - & (Zeta(iZeta)*P(iZeta,3)+Gamma*TC(3))/Tmp0 - 1012 Continue -* -*-----------------Compute integrals with the Rys quadrature. -* - nT = nZeta - NoSpecial=.True. - Call Rys(iAnga,nT,Array(ipZ),Array(ipZI),nZeta, - & [One],[One],1,Array(ipPx),nZeta,TC,1, - & Array(ipK),[One],Coori,Coora,CoorAC, - & mabmin,mabmax,0,0,Array(ipTmp),mArray, - & TNAI,Fake,Cff2D,XRys2D,NoSpecial) -* -*-----------------Accumulate result for all nuclei. Take the charge on -* the center into account. -* - Factor = -dbsc(kCnttp)%Charge*dbsc(kCnttp)%M1cf(iM1xp) - & * Fact - Call DaXpY_(nZeta*mAInt,Factor,Array(ipTmp),1, - & Array(ipAInt),1) - If (iPrint.ge.99) Then - Call Recprt(' [a+b,0|A|0] in Array',' ', - & Array(ipTmp),nZeta,mAInt) - Call RecPrt(' [a+b,0|A|0] in AInt',' ', - & Array(ipAInt),nZeta,mAInt) - End If -* - 1011 Continue - 102 Continue - 101 Continue - 111 kdc = kdc + dbsc(kCnttp)%nCntr - 100 Continue -* -*-----Use the HRR to compute the required primitive integrals. -* - Call HRR(la,lb,A,RB,Array(ipAInt),nZeta,nMem,ipIn) - ii = ipAInt + ipIn - 1 -*-----Move result - call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,Array(ii),1,Final,1) -* - If (iPrint.ge.99) Then - Write (6,*) ' Result in M1Int' - Do 150 ia = 1, nElem(la) - Do 250 ib = 1, nElem(lb) - Write (Label,'(A,I2,A,I2,A)') - & ' Final(',ia,',',ib,')' - Call RecPrt(Label,' ',Final(1,ia,ib,1),nAlpha,nBeta) - 250 Continue - 150 Continue - End If -* -* Call GetMem(' Exit M1Int','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Alpha) - Call Unused_real_array(Beta) - Call Unused_real_array(ZInv) - Call Unused_integer(nHer) - Call Unused_integer_array(lOper) - Call Unused_integer_array(iChO) - Call Unused_integer(nOrdOp) - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/m1int.F90 openmolcas-22.10/src/oneint_util/m1int.F90 --- openmolcas-22.02/src/oneint_util/m1int.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/m1int.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,208 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993, Roland Lindh * +! 1993, Per Boussard * +!*********************************************************************** + +subroutine M1Int( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of the M1 integrals used * +! ECP calculations. The operator is the nuclear attraction * +! operator times a s-type gaussian function. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, Sweden, and Per Boussard, Dept. of Theoretical * +! Physics, University of Stockholm, Sweden, October '93. * +!*********************************************************************** + +use Basis_Info, only: dbsc, nCnttp +use Center_Info, only: dc +use Index_Functions, only: nTri3_Elem1, nTri_Elem1 +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "print.fh" +integer(kind=iwp) :: ia, iAnga(4), ib, iDCRT(0:7), ii, iM1xp, ip, ipAInt, ipIn, ipK, ipPx, ipPy, ipPz, iPrint, ipTmp, ipZ, ipZI, & + iRout, iZeta, k, kCnt, kCnttp, kdc, l, lDCRT, LmbdT, mabMax, mabMin, mAInt, mArray, nDCRT, nFlop, nMem, nT +real(kind=wp) :: C(3), Coora(3,4), CoorAC(3,2), Coori(3,4), Fact, Factor, Gmma, PTC2, TC(3), Tmp0, Tmp1 +character(len=80) :: Label +logical(kind=iwp) :: NoSpecial +logical(kind=iwp), external :: EQ +external :: Cff2D, Fake, TNAI, XRys2D + +#include "macros.fh" +unused_var(Alpha) +unused_var(Beta) +unused_var(ZInv) +unused_var(nHer) +unused_var(lOper) +unused_var(iChO) +unused_var(nOrdOp) +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 193 +iPrint = nPrint(iRout) + +if (iPrint >= 49) then + call RecPrt(' In M1Int: A',' ',A,1,3) + call RecPrt(' In M1Int: RB',' ',RB,1,3) + call RecPrt(' In M1Int: Ccoor',' ',Ccoor,1,3) + call RecPrt(' In M1Int: P',' ',P,nZeta,3) + write(u6,*) ' In M1Int: la,lb=',' ',la,lb +end if + +iAnga(1) = la +iAnga(2) = lb +iAnga(3) = 0 +iAnga(4) = 0 +mabMin = nTri3_Elem1(max(la,lb)-1) +mabMax = nTri3_Elem1(la+lb)-1 +if (EQ(A,RB)) mabMin = nTri3_Elem1(la+lb-1) +mAInt = (mabMax-mabMin+1) + +! Find center to accumulate angular momentum on. (HRR) + +if (la >= lb) then + CoorAC(:,1) = A +else + CoorAC(:,1) = RB +end if + +! Compute FLOP's and size of work array which HRR will use. + +call mHrr(la,lb,nFlop,nMem) + +! Allocate Scratch for primitives and work area for HRR + +ip = 1 +ipAInt = ip +k = nTri3_Elem1(la+lb)-nTri3_Elem1(max(la,lb)-1) +ip = ip+nZeta*max(k,nMem) +ipK = ip +ip = ip+nZeta +ipZ = ip +ip = ip+nZeta +ipZI = ip +ip = ip+nZeta +ipPx = ip +ip = ip+nZeta +ipPy = ip +ip = ip+nZeta +ipPz = ip +ip = ip+nZeta +if (ip-1 > nArr*nZeta) then + call WarningMessage(2,'M1Int: ip-1 > nArr*nZeta') + write(u6,*) ' nArr,nZeta=',nArr,nZeta + write(u6,*) ' nMem=',nMem + call Abend() +end if +ipTmp = ip +mArray = nArr*nZeta-ip+1 + +Array(ipAInt:ipAInt+nZeta*max(k,nMem)-1) = Zero + +! Loop over nuclear centers. + +kdc = 0 +do kCnttp=1,nCnttp + if (kCnttp > 1) kdc = kdc+dbsc(kCnttp-1)%nCntr + if (.not. dbsc(kCnttp)%ECP) cycle + if (dbsc(kCnttp)%nM1 == 0) cycle + do kCnt=1,dbsc(kCnttp)%nCntr + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + + call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) + Fact = real(nStabM,kind=wp)/real(LmbdT,kind=wp) + + do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),C,TC) + Coora(:,1) = A + Coora(:,2) = RB + Coori(:,1:2) = Coora(:,1:2) + if ((.not. EQ(A,RB)) .or. (.not. EQ(A,TC))) then + Coori(1,1) = Coori(1,1)+One + !Coora(1,1) = Coora(1,1)+One + end if + CoorAC(:,2) = TC + Coori(:,3) = TC + Coori(:,4) = TC + Coora(:,3) = TC + Coora(:,4) = TC + + do iM1xp=1,dbsc(kCnttp)%nM1 + Gmma = dbsc(kCnttp)%M1xp(iM1xp) + + ! Modify the original basis. Observe that + ! simplification due to A=B are not valid for the + ! exponent index, eq. P-A=/=0. + + do iZeta=1,nZeta + PTC2 = (P(iZeta,1)-TC(1))**2+(P(iZeta,2)-TC(2))**2+(P(iZeta,3)-TC(3))**2 + Tmp0 = Zeta(iZeta)+Gmma + Tmp1 = exp(-Zeta(iZeta)*Gmma*PTC2/Tmp0) + Array(ipK+iZeta-1) = rKappa(iZeta)*Tmp1 + Array(ipZ+iZeta-1) = Tmp0 + Array(ipZI+iZeta-1) = One/Tmp0 + Array(ipPx+iZeta-1) = (Zeta(iZeta)*P(iZeta,1)+Gmma*TC(1))/Tmp0 + Array(ipPy+iZeta-1) = (Zeta(iZeta)*P(iZeta,2)+Gmma*TC(2))/Tmp0 + Array(ipPz+iZeta-1) = (Zeta(iZeta)*P(iZeta,3)+Gmma*TC(3))/Tmp0 + end do + + ! Compute integrals with the Rys quadrature. + + nT = nZeta + NoSpecial = .true. + call Rys(iAnga,nT,Array(ipZ),Array(ipZI),nZeta,[One],[One],1,Array(ipPx),nZeta,TC,1,Array(ipK),[One],Coori,Coora,CoorAC, & + mabmin,mabmax,0,0,Array(ipTmp),mArray,TNAI,Fake,Cff2D,XRys2D,NoSpecial) + + ! Accumulate result for all nuclei. Take the charge on + ! the center into account. + + Factor = -dbsc(kCnttp)%Charge*dbsc(kCnttp)%M1cf(iM1xp)*Fact + l = nZeta*mAInt + Array(ipAInt:ipAInt+l-1) = Array(ipAInt:ipAInt+l-1)+Factor*Array(ipTmp:ipTmp+l-1) + if (iPrint >= 99) then + call Recprt(' [a+b,0|A|0] in Array',' ',Array(ipTmp),nZeta,mAInt) + call RecPrt(' [a+b,0|A|0] in AInt',' ',Array(ipAInt),nZeta,mAInt) + end if + + end do + end do + end do +end do + +! Use the HRR to compute the required primitive integrals. + +call HRR(la,lb,A,RB,Array(ipAInt),nZeta,nMem,ipIn) +ii = ipAInt+ipIn-1 +! Move result +call dcopy_(size(rFinal),Array(ii),1,rFinal,1) + +if (iPrint >= 99) then + write(u6,*) ' Result in M1Int' + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb) + write(Label,'(A,I2,A,I2,A)') ' rFinal(',ia,',',ib,')' + call RecPrt(Label,' ',rFinal(:,ia,ib,1),nAlpha,nBeta) + end do + end do +end if + +return + +end subroutine M1Int diff -Nru openmolcas-22.02/src/oneint_util/m1mem.f openmolcas-22.10/src/oneint_util/m1mem.f --- openmolcas-22.02/src/oneint_util/m1mem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/m1mem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1993, Roland Lindh * -************************************************************************ - Subroutine M1Mem( -#define _CALLING_ -#include "mem_interface.fh" - &) -************************************************************************ -* Object: to compute the number of real*8 the kernel routine will * -* need for the computation of a matrix element between two * -* cartesian Gaussian functions with the total angular momentum* -* of la and lb (la=0 s-function, la=1 p-function, etc.) * -* lr is the order of the operator (this is only used when the * -* integrals are computed with the Hermite-Gauss quadrature). * -* * -* Called from: OneEl * -* * -************************************************************************ -* -#include "mem_interface.fh" - Integer iAng(4) -* - nabSz(ixyz) = (ixyz+1)*(ixyz+2)*(ixyz+3)/6 - 1 -* - Call mHrr(la,lb,nFlop,nMem) -* - iAng(1) = la - iAng(2) = lb - iAng(3) = 0 - iAng(4) = 0 - Call MemRys(iAng,MemPrm) - MemM10= 6 + MemPrm - nHer = (la+lb+2)/2 -* - k = nabSz(la+lb) - nabSz(Max(la,lb)-1) -* -*-----nMem : memory for Hrr -* k : memory for primitives in M1Int0 -* MemM10: scratch in M1Int0 -* - Mem = MemM10 + Max(nMem,k) -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(lr) - End diff -Nru openmolcas-22.02/src/oneint_util/m1mem.F90 openmolcas-22.10/src/oneint_util/m1mem.F90 --- openmolcas-22.02/src/oneint_util/m1mem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/m1mem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,60 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993, Roland Lindh * +!*********************************************************************** + +subroutine M1Mem( & +# define _CALLING_ +# include "mem_interface.fh" + ) +!*********************************************************************** +! Object: to compute the number of real*8 the kernel routine will * +! need for the computation of a matrix element between two * +! cartesian Gaussian functions with the total angular momentum* +! of la and lb (la=0 s-function, la=1 p-function, etc.) * +! lr is the order of the operator (this is only used when the * +! integrals are computed with the Hermite-Gauss quadrature). * +! * +! Called from: OneEl * +! * +!*********************************************************************** + +use Index_Functions, only: nTri3_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: iAng(4), k, MemM10, MemPrm, nFlop, nMem + +#include "macros.fh" +unused_var(lr) + +call mHrr(la,lb,nFlop,nMem) + +iAng(1) = la +iAng(2) = lb +iAng(3) = 0 +iAng(4) = 0 +call MemRys(iAng,MemPrm) +MemM10 = 6+MemPrm +nHer = (la+lb+2)/2 + +k = nTri3_Elem1(la+lb)-nTri3_Elem1(max(la,lb)-1) + +! nMem : memory for Hrr +! k : memory for primitives in M1Int0 +! MemM10: scratch in M1Int0 + +Mem = MemM10+max(nMem,k) + +return + +end subroutine M1Mem diff -Nru openmolcas-22.02/src/oneint_util/m2int.f openmolcas-22.10/src/oneint_util/m2int.f --- openmolcas-22.02/src/oneint_util/m2int.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/m2int.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,257 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1993, Roland Lindh * -* 1993, Per Boussard * -************************************************************************ - SubRoutine M2Int( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of M2 integrals used in * -* ECP calculations. The operator is a s-type gaussian * -* * -* Alpha : exponents of bra gaussians * -* nAlpha: number of primitives (exponents) of bra gaussians * -* Beta : as Alpha but for ket gaussians * -* nBeta : as nAlpha but for the ket gaussians * -* Zeta : sum of exponents (nAlpha x nBeta) * -* ZInv : inverse of Zeta * -* rKappa: gaussian prefactor for the products of bra and ket * -* gaussians. * -* P : center of new gaussian from the products of bra and ket * -* gaussians. * -* Final : array for computed integrals * -* nZeta : nAlpha x nBeta * -* nComp : number of components in the operator (e.g. dipolmoment * -* operator has three components) * -* la : total angular momentum of bra gaussian * -* lb : total angular momentum of ket gaussian * -* A : center of bra gaussian * -* B : center of ket gaussian * -* nRys : order of Rys- or Hermite-Gauss polynomial * -* Array : Auxiliary memory as requested by ECPMem * -* nArr : length of Array * -* Ccoor : coordinates of the operator, zero for symmetric oper. * -* NOrdOp: Order of the operator * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, Sweden, and Per Boussard, Dept. of Theoretical * -* Physics, University of Stockholm, Sweden, October '93. * -************************************************************************ - use Basis_Info - use Center_Info - use Her_RW - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - -#include "int_interface.fh" - -* Local variables. - Real*8 TC(3), C(3) - Character*80 Label - Logical ABeq(3) - Integer iDCRT(0:7) -* -*-----Statement function for Cartesian index -* - nElem(k)=(k+1)*(k+2)/2 -* - iRout = 122 - iPrint = nPrint(iRout) -* Call GetMem(' Enter M2Int','LIST','REAL',iDum,iDum) -* - nip = 1 - ipAxyz = nip - nip = nip + nZeta*3*nHer*(la+1) - ipBxyz = nip - nip = nip + nZeta*3*nHer*(lb+1) - ipRxyz = nip - nip = nip + nZeta*3*nHer - ipQxyz = nip - nip = nip + nZeta*3*(la+1)*(lb+1) - ipK = nip - nip = nip + nZeta - ipZ = nip - nip = nip + nZeta - ipPx= nip - nip = nip + nZeta - ipPy= nip - nip = nip + nZeta - ipPz= nip - nip = nip + nZeta - ipRes = nip - nip = nip + nZeta*nComp*nElem(la)*nElem(lb) - If (nip-1.gt.nArr*nZeta) Then - Call WarningMessage(2,'M2Int: nip-1.gt.nArr*nZeta') - Write (6,*) ' nArr is Wrong! ', nip-1,' > ',nArr*nZeta - Write (6,*) ' Abend in M2Int' - Call Abend() - End If -* - If (iPrint.ge.49) Then - Call RecPrt(' In M2Int: A',' ',A,1,3) - Call RecPrt(' In M2Int: RB',' ',RB,1,3) - Call RecPrt(' In M2Int: Ccoor',' ',Ccoor,1,3) - Call RecPrt(' In M2Int: Kappa',' ',rKappa,nAlpha,nBeta) - Call RecPrt(' In M2Int: Zeta',' ',Zeta,nAlpha,nBeta) - Call RecPrt(' In M2Int: P',' ',P,nZeta,3) - Write (6,*) ' In M2Int: la,lb,nHer=',la,lb,nHer - End If -* - call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) -* -*-----Loop over nuclear centers -* - kdc=0 - Do 100 kCnttp = 1, nCnttp - If (.Not.dbsc(kCnttp)%ECP) Go To 111 - If (dbsc(kCnttp)%nM2.eq.0) Go To 111 -* - Do 101 kCnt = 1, dbsc(kCnttp)%nCntr - C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) -* - Call DCR(LmbdT,iStabM,nStabM, - & dc(kdc+kCnt)%iStab, dc(kdc+kCnt)%nStab,iDCRT,nDCRT) - Fact = DBLE(nStabM) / DBLE(LmbdT) -* - Do 102 lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),C,TC) -* - Do 1011 iM2xp = 1, dbsc(kCnttp)%nM2 - Gamma = dbsc(kCnttp)%M2xp(iM2xp) - If (iPrint.ge.99) Write (6,*) ' Gamma=',Gamma -* -*-----------------Modify the original basis. -* - Do 1012 iZeta = 1, nZeta - PTC2 = (P(iZeta,1)-TC(1))**2 - & + (P(iZeta,2)-TC(2))**2 - & + (P(iZeta,3)-TC(3))**2 - Tmp0 = Zeta(iZeta)+Gamma - Tmp1 = Exp(-Zeta(iZeta)*Gamma*PTC2/Tmp0) - Array(ipK+iZeta-1) = rKappa(iZeta) * Tmp1 - Array(ipZ+iZeta-1) = Tmp0 - Array(ipPx+iZeta-1) = - & (Zeta(iZeta)*P(iZeta,1)+Gamma*TC(1))/Tmp0 - Array(ipPy+iZeta-1) = - & (Zeta(iZeta)*P(iZeta,2)+Gamma*TC(2))/Tmp0 - Array(ipPz+iZeta-1) = - & (Zeta(iZeta)*P(iZeta,3)+Gamma*TC(3))/Tmp0 - 1012 Continue - If (iPrint.ge.99) Then - Write (6,*) ' The modified basis set' - Call RecPrt(' In M2Int: Kappa',' ', - & Array(ipK),nAlpha,nBeta) - Call RecPrt(' In M2Int: Zeta',' ', - & Array(ipZ),nAlpha,nBeta) - Call RecPrt(' In M2Int: P',' ',Array(ipPx),nZeta,3) - End If -* -*-----------------Compute the cartesian values of the basis functions -* angular part -* - ABeq(1) = A(1).eq.RB(1) .and. A(1).eq.TC(1) - ABeq(2) = A(2).eq.RB(2) .and. A(2).eq.TC(2) - ABeq(3) = A(3).eq.RB(3) .and. A(3).eq.TC(3) - Call CrtCmp(Array(ipZ),Array(ipPx),nZeta,A, - & Array(ipAxyz),la,HerR(iHerR(nHer)), - & nHer,ABeq) - Call CrtCmp(Array(ipZ),Array(ipPx),nZeta,RB, - & Array(ipBxyz),lb,HerR(iHerR(nHer)), - & nHer,ABeq) -* -*-----------------Compute the contribution from the multipole moment -* operator -* - ABeq(1) = .False. - ABeq(2) = .False. - ABeq(3) = .False. - Call CrtCmp(Array(ipZ),Array(ipPx),nZeta,TC, - & Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)), - & nHer,ABeq) -* -*-----------------Compute the cartesian components for the multipole -* moment integrals. The integrals are factorized into -* components. -* - Call Assmbl(Array(ipQxyz), - & Array(ipAxyz),la, - & Array(ipRxyz),nOrdOp, - & Array(ipBxyz),lb, - & nZeta,HerW(iHerW(nHer)),nHer) -* -*-----------------Combine the cartesian components to the full one -* electron integral. -* - Call CmbnMP(Array(ipQxyz),nZeta,la,lb,nOrdOp, - & Array(ipZ),Array(ipK),Array(ipRes),nComp) - If (iPrint.ge.99) Then - Write (6,*) ' Intermediate result in M2Int' - Do 9101 ia = 1, nElem(la) - Do 9201 ib = 1, nElem(lb) - iab = (ib-1)*nElem(la) + ia - ipab = (iab-1)*nZeta + ipRes - Write (Label,'(A,I2,A,I2,A)') - & ' Array(',ia,',',ib,')' - If (nComp.ne.1) Then - Call RecPrt(Label,' ', - & Array(ipab),nZeta,nComp) - Else - Call RecPrt(Label,' ', - & Array(ipab),nAlpha,nBeta) - End If - 9201 Continue - 9101 Continue - End If -* -*-----------------Multiply result by Zeff*Const -* - Factor = -dbsc(kCnttp)%Charge*dbsc(kCnttp)%M2cf(iM2xp) - & * Fact - If (iPrint.ge.99) Write (6,*) ' Factor=',Factor - Call DaXpY_(nZeta*nElem(la)*nElem(lb)*nIC,Factor, - & Array(ipRes),1,Final,1) -* - 1011 Continue -* - 102 Continue - 101 Continue - 111 kdc = kdc + dbsc(kCnttp)%nCntr -* - 100 Continue -* - If (iPrint.ge.99) Then - Write (6,*) ' Result in M2Int' - Do 9100 ia = 1, nElem(la) - Do 9200 ib = 1, nElem(lb) - Write (Label,'(A,I2,A,I2,A)') - & ' Final(ia=',ia,',ib=',ib,')' - Call RecPrt(Label,' ',Final(1,ia,ib,1),nAlpha,nBeta) - 9200 Continue - 9100 Continue - End If -* -* Call GetMem(' Exit M2Int','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Alpha) - Call Unused_real_array(Beta) - Call Unused_real_array(ZInv) - Call Unused_integer_array(lOper) - Call Unused_integer_array(iChO) - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/m2int.F90 openmolcas-22.10/src/oneint_util/m2int.F90 --- openmolcas-22.02/src/oneint_util/m2int.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/m2int.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,197 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993, Roland Lindh * +! 1993, Per Boussard * +!*********************************************************************** + +subroutine M2Int( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of M2 integrals used in * +! ECP calculations. The operator is a s-type gaussian * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, Sweden, and Per Boussard, Dept. of Theoretical * +! Physics, University of Stockholm, Sweden, October '93. * +!*********************************************************************** + +use Basis_Info, only: dbsc, nCnttp +use Center_Info, only: dc +use Her_RW, only: HerR, HerW, iHerR, iHerW +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "print.fh" +integer(kind=iwp) :: ia, iab, ib, iDCRT(0:7), iM2xp, ipab, ipAxyz, ipBxyz, ipK, ipPx, ipPy, ipPz, ipQxyz, ipRes, iPrint, ipRxyz, & + ipZ, iRout, iZeta, kCnt, kCnttp, kdc, lDCRT, LmbdT, nDCRT, nip +real(kind=wp) :: C(3), Fact, Factor, Gmma, PTC2, TC(3), Tmp0, Tmp1 +character(len=80) :: Label +logical(kind=iwp) :: ABeq(3) + +#include "macros.fh" +unused_var(Alpha) +unused_var(Beta) +unused_var(ZInv) +unused_var(lOper) +unused_var(iChO) +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 122 +iPrint = nPrint(iRout) + +nip = 1 +ipAxyz = nip +nip = nip+nZeta*3*nHer*(la+1) +ipBxyz = nip +nip = nip+nZeta*3*nHer*(lb+1) +ipRxyz = nip +nip = nip+nZeta*3*nHer +ipQxyz = nip +nip = nip+nZeta*3*(la+1)*(lb+1) +ipK = nip +nip = nip+nZeta +ipZ = nip +nip = nip+nZeta +ipPx = nip +nip = nip+nZeta +ipPy = nip +nip = nip+nZeta +ipPz = nip +nip = nip+nZeta +ipRes = nip +nip = nip+nZeta*nComp*nTri_Elem1(la)*nTri_Elem1(lb) +if (nip-1 > nArr*nZeta) then + call WarningMessage(2,'M2Int: nip-1 > nArr*nZeta') + write(u6,*) ' nArr is Wrong! ',nip-1,' > ',nArr*nZeta + write(u6,*) ' Abend in M2Int' + call Abend() +end if + +if (iPrint >= 49) then + call RecPrt(' In M2Int: A',' ',A,1,3) + call RecPrt(' In M2Int: RB',' ',RB,1,3) + call RecPrt(' In M2Int: Ccoor',' ',Ccoor,1,3) + call RecPrt(' In M2Int: Kappa',' ',rKappa,nAlpha,nBeta) + call RecPrt(' In M2Int: Zeta',' ',Zeta,nAlpha,nBeta) + call RecPrt(' In M2Int: P',' ',P,nZeta,3) + write(u6,*) ' In M2Int: la,lb,nHer=',la,lb,nHer +end if + +rFinal(:,:,:,:) = Zero + +! Loop over nuclear centers + +kdc = 0 +do kCnttp=1,nCnttp + if (kCnttp > 1) kdc = kdc+dbsc(kCnttp-1)%nCntr + if (.not. dbsc(kCnttp)%ECP) cycle + if (dbsc(kCnttp)%nM2 == 0) cycle + + do kCnt=1,dbsc(kCnttp)%nCntr + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + + call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) + Fact = real(nStabM,kind=wp)/real(LmbdT,kind=wp) + + do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),C,TC) + + do iM2xp=1,dbsc(kCnttp)%nM2 + Gmma = dbsc(kCnttp)%M2xp(iM2xp) + if (iPrint >= 99) write(u6,*) ' Gamma=',Gmma + + ! Modify the original basis. + + do iZeta=1,nZeta + PTC2 = (P(iZeta,1)-TC(1))**2+(P(iZeta,2)-TC(2))**2+(P(iZeta,3)-TC(3))**2 + Tmp0 = Zeta(iZeta)+Gmma + Tmp1 = exp(-Zeta(iZeta)*Gmma*PTC2/Tmp0) + Array(ipK+iZeta-1) = rKappa(iZeta)*Tmp1 + Array(ipZ+iZeta-1) = Tmp0 + Array(ipPx+iZeta-1) = (Zeta(iZeta)*P(iZeta,1)+Gmma*TC(1))/Tmp0 + Array(ipPy+iZeta-1) = (Zeta(iZeta)*P(iZeta,2)+Gmma*TC(2))/Tmp0 + Array(ipPz+iZeta-1) = (Zeta(iZeta)*P(iZeta,3)+Gmma*TC(3))/Tmp0 + end do + if (iPrint >= 99) then + write(u6,*) ' The modified basis set' + call RecPrt(' In M2Int: Kappa',' ',Array(ipK),nAlpha,nBeta) + call RecPrt(' In M2Int: Zeta',' ',Array(ipZ),nAlpha,nBeta) + call RecPrt(' In M2Int: P',' ',Array(ipPx),nZeta,3) + end if + + ! Compute the cartesian values of the basis functions angular part + + ABeq(:) = (A == RB) .and. (A == TC) + call CrtCmp(Array(ipZ),Array(ipPx),nZeta,A,Array(ipAxyz),la,HerR(iHerR(nHer)),nHer,ABeq) + call CrtCmp(Array(ipZ),Array(ipPx),nZeta,RB,Array(ipBxyz),lb,HerR(iHerR(nHer)),nHer,ABeq) + + ! Compute the contribution from the multipole moment operator + + ABeq(:) = .false. + call CrtCmp(Array(ipZ),Array(ipPx),nZeta,TC,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) + + ! Compute the cartesian components for the multipole + ! moment integrals. The integrals are factorized into components. + + call Assmbl(Array(ipQxyz),Array(ipAxyz),la,Array(ipRxyz),nOrdOp,Array(ipBxyz),lb,nZeta,HerW(iHerW(nHer)),nHer) + + ! Combine the cartesian components to the full one electron integral. + + call CmbnMP(Array(ipQxyz),nZeta,la,lb,nOrdOp,Array(ipZ),Array(ipK),Array(ipRes),nComp) + if (iPrint >= 99) then + write(u6,*) ' Intermediate result in M2Int' + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb) + iab = (ib-1)*nTri_Elem1(la)+ia + ipab = (iab-1)*nZeta+ipRes + write(Label,'(A,I2,A,I2,A)') ' Array(',ia,',',ib,')' + if (nComp /= 1) then + call RecPrt(Label,' ',Array(ipab),nZeta,nComp) + else + call RecPrt(Label,' ',Array(ipab),nAlpha,nBeta) + end if + end do + end do + end if + + ! Multiply result by Zeff*Const + + Factor = -dbsc(kCnttp)%Charge*dbsc(kCnttp)%M2cf(iM2xp)*Fact + if (iPrint >= 99) write(u6,*) ' Factor=',Factor + call DaXpY_(size(rFinal),Factor,Array(ipRes),1,rFinal,1) + + end do + + end do + end do + +end do + +if (iPrint >= 99) then + write(u6,*) ' Result in M2Int' + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb) + write(Label,'(A,I2,A,I2,A)') ' rFinal(ia=',ia,',ib=',ib,')' + call RecPrt(Label,' ',rFinal(:,ia,ib,1),nAlpha,nBeta) + end do + end do +end if + +return + +end subroutine M2Int diff -Nru openmolcas-22.02/src/oneint_util/m2mem.f openmolcas-22.10/src/oneint_util/m2mem.f --- openmolcas-22.02/src/oneint_util/m2mem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/m2mem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,73 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1993, Roland Lindh * -************************************************************************ - Subroutine M2Mem( -#define _CALLING_ -#include "mem_interface.fh" - &) -************************************************************************ -* Object: to compute the number of real*8 the kernel routine will * -* need for the computation of a matrix element between two * -* cartesian Gaussian functions with the total angular momentum* -* of la and lb (la=0 s-function, la=1 p-function, etc.) * -* lr is the order of the operator (this is only used when the * -* integrals are computed with the Hermite-Gauss quadrature). * -* * -* Called from: OneEl * -* * -************************************************************************ -* -#include "mem_interface.fh" - nElem(i) = (i+1)*(i+2)/2 -* - nHer=(la+lb+2)/2 - Mem = 3*nHer*(la+1) + - & 3*nHer*(lb+1) + - & 3*nHer + - & 3*(la+1)*(lb+1) + - & 5 + nElem(la)*nElem(lb) -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(lr) - End -* - Subroutine PAM2Mem( -#define _CALLING_ -#include "mem_interface.fh" - &) -************************************************************************ -* Object: to compute the number of real*8 the kernel routine will * -* need for the computation of a matrix element between two * -* cartesian Gaussian functions with the total angular momentum* -* of la and lb (la=0 s-function, la=1 p-function, etc.) * -* lr is the order of the operator (this is only used when the * -* integrals are computed with the Hermite-Gauss quadrature). * -* * -* Called from: OneEl * -* * -************************************************************************ -* -#include "mem_interface.fh" - nElem(i) = (i+1)*(i+2)/2 -* - nComp = nElem(lr) -* - nHer=(la+lb+lr+2)/2 - Mem = 3*nHer*(la+1) + - & 3*nHer*(lb+1) + - & 3*nHer*(lr+1) + - & 3*(la+1)*(lb+1)*(lr+1) + - & 5 + nElem(la)*nElem(lb)*nComp -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/m2mem.F90 openmolcas-22.10/src/oneint_util/m2mem.F90 --- openmolcas-22.02/src/oneint_util/m2mem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/m2mem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,44 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993, Roland Lindh * +!*********************************************************************** + +subroutine M2Mem( & +# define _CALLING_ +# include "mem_interface.fh" + ) +!*********************************************************************** +! Object: to compute the number of real*8 the kernel routine will * +! need for the computation of a matrix element between two * +! cartesian Gaussian functions with the total angular momentum* +! of la and lb (la=0 s-function, la=1 p-function, etc.) * +! lr is the order of the operator (this is only used when the * +! integrals are computed with the Hermite-Gauss quadrature). * +! * +! Called from: OneEl * +! * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" + +#include "macros.fh" +unused_var(lr) + +nHer = (la+lb+2)/2 +Mem = 3*nHer*(la+1)+3*nHer*(lb+1)+3*nHer+3*(la+1)*(lb+1)+5+nTri_Elem1(la)*nTri_Elem1(lb) + +return + +end subroutine M2Mem diff -Nru openmolcas-22.02/src/oneint_util/mltint.f openmolcas-22.10/src/oneint_util/mltint.f --- openmolcas-22.02/src/oneint_util/mltint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/mltint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,247 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine MltInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: to compute the multipole moments integrals with the * -* Gauss-Hermite quadrature. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* November '90 * -* Modified to multipole moments November '90 * -************************************************************************ - use Her_RW - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -* -#include "rmat_option.fh" -* -#include "oneswi.fh" -#include "print.fh" - -#include "int_interface.fh" - -* Local variable - Real*8 TC(3), Origin(3) - Integer iStabO(0:7), iDCRT(0:7) - Logical ABeq(3), EQ - Character*80 Label, ChOper(0:7)*3 - Data ChOper/'E ','x ','y ','xy ','z ','xz ','yz ','xyz'/ - Data Origin/0.0D0,0.0D0,0.0D0/ -* -* Statement function for Cartesian index -* - nElem(i) = (i+1)*(i+2)/2 -* - iRout = 122 - iPrint = nPrint(iRout) -* - call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) -* -* Call GetMem(' Enter MltInt','LIST','REAL',iDum,iDum) - ABeq(1) = A(1).eq.RB(1) - ABeq(2) = A(2).eq.RB(2) - ABeq(3) = A(3).eq.RB(3) -* switch (only single center overlap matrix...) - If (NDDO.AND. - & .NOT.(ABeq(1).AND.ABeq(2).AND.ABeq(3))) Then - call dcopy_(nZeta*nIC*nElem(la)*nElem(lb),[Zero],0,Final,1) - Return - End If -* switch - nip = 1 - ipAxyz = nip - nip = nip + nZeta*3*nHer*(la+1) - ipBxyz = nip - nip = nip + nZeta*3*nHer*(lb+1) - ipRxyz = nip - nip = nip + nZeta*3*nHer*(nOrdOp+1) - ipQxyz = nip - nip = nip + nZeta*3*(la+1)*(lb+1)*(nOrdOp+1) - ipFnl = nip - nip = nip + nZeta*nElem(la)*nElem(lb)*nComp -* * -************************************************************************ -* * - If (RMat_type_integrals) Then - ipRnr = nip - nip = nip + nZeta*(la+lb+nOrdOp+1) - Else - ipRnr=-1 - End If -* * -************************************************************************ -* * - If (nip-1.gt.nArr*nZeta) Then - Call WarningMessage(2,'MltInt: nip-1.gt.nArr*nZeta') - Write (6,*) ' nArr is Wrong! ', nip-1,' > ',nArr*nZeta - Write (6,*) ' Abend in MltInt' - Call Abend() - End If -* - If (iPrint.ge.49) Then - Call RecPrt(' In MltInt: A',' ',A,1,3) - Call RecPrt(' In MltInt: RB',' ',RB,1,3) - Call RecPrt(' In MltInt: Ccoor',' ',Ccoor,1,3) - Call RecPrt(' In MltInt: Kappa',' ',rKappa,nAlpha,nBeta) - Call RecPrt(' In MltInt: Zeta',' ',Zeta,nAlpha,nBeta) - Call RecPrt(' In MltInt: P',' ',P,nZeta,3) - Write (6,*) ' In MltInt: la,lb=',la,lb - End If -* - llOper = lOper(1) - Do 90 iComp = 2, nComp - llOper = iOr(llOper,lOper(iComp)) - 90 Continue -* * -************************************************************************ -* * - If (RMat_type_integrals) Then -* - If (.Not.EQ(CCoor,Origin)) Then - Call WarningMessage(2,'MltInt: R-matrix error') - Write (6,*) 'MltInt: Wrong center of origin in case of', - & ' R-matrix type of integrals!' - Write (6,*) ' Origin should always be (0.0,0.0,0.0)!' - Write (6,*) ' User the CENTER option to do this', - & ' (see the SEWARD input sectio in the manual).' - Write (6,'(A,I3)') 'nOrdOp=',nOrdOp - Call Abend() - End If -* -* R-matrix calculations: continuum basis functions (A=B=P=0) -* Compute the contributions of the basis functions and multipole -* radial part -* - lsum=la+lb+nOrdOp - Call radlc(Zeta,nZeta,lsum,Array(ipRnr)) -* -* Combine the radial and angular component to the full one electron -* integral. -* - Call CmbnMPr(Array(ipRnr),nZeta,la,lb,nOrdOp,Zeta, - & Array(ipFnl),nComp) -* - Call SOS(iStabO,nStabO,llOper) - Call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) - If (iPrint.ge.99) Then - Write (6,*) ' m =',nStabM - Write (6,'(9A)') '{M}=', - & (ChOper(iStabM(ii)),ii = 0, nStabM-1) - Write (6,*) ' s =',nStabO - Write (6,'(9A)') '{S}=', - & (ChOper(iStabO(ii)),ii = 0, nStabO-1) - Write (6,*) ' LambdaT=',LmbdT - Write (6,*) ' t =',nDCRT - Write (6,'(9A)') '{T}=',(ChOper(iDCRT(ii)),ii = 0, nDCRT-1) - End If -* - Do lDCRT = 0, nDCRT-1 -* -* Accumulate contributions -* - nOp = NrOpr(iDCRT(lDCRT)) - Call SymAdO(Array(ipFnl),nZeta,la,lb,nComp,Final,nIC, - & nOp ,lOper,iChO,One) - End Do -* - Else -* * -************************************************************************ -* * -* Compute the cartesian values of the basis functions angular part -* - Call CrtCmp(Zeta,P,nZeta,A,Array(ipAxyz), - & la,HerR(iHerR(nHer)),nHer,ABeq) - Call CrtCmp(Zeta,P,nZeta,RB,Array(ipBxyz), - & lb,HerR(iHerR(nHer)),nHer,ABeq) -* - Call SOS(iStabO,nStabO,llOper) - Call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) - If (iPrint.ge.99) Then - Write (6,*) ' m =',nStabM - Write (6,'(9A)') '{M}=',(ChOper(iStabM(ii)),ii = 0, nStabM-1) - Write (6,*) ' s =',nStabO - Write (6,'(9A)') '{S}=',(ChOper(iStabO(ii)),ii = 0, nStabO-1) - Write (6,*) ' LambdaT=',LmbdT - Write (6,*) ' t =',nDCRT - Write (6,'(9A)') '{T}=',(ChOper(iDCRT(ii)),ii = 0, nDCRT-1) - End If -* - Do lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),CCoor,TC) -* -* Compute the contribution from the multipole moment operator -* - ABeq(1) = .False. - ABeq(2) = .False. - ABeq(3) = .False. - Call CrtCmp(Zeta,P,nZeta,TC,Array(ipRxyz), - & nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the cartesian components for the multipole moment -* integrals. The integrals are factorized into components. -* - Call Assmbl(Array(ipQxyz), - & Array(ipAxyz),la, - & Array(ipRxyz),nOrdOp, - & Array(ipBxyz),lb, - & nZeta,HerW(iHerW(nHer)),nHer) -* -* Combine the cartesian components to the full one electron -* integral. -* - Call CmbnMP(Array(ipQxyz),nZeta,la,lb,nOrdOp,Zeta,rKappa, - & Array(ipFnl),nComp) -* -* Accumulate contributions -* - nOp = NrOpr(iDCRT(lDCRT)) - Call SymAdO(Array(ipFnl),nZeta,la,lb,nComp,Final,nIC, - & nOp ,lOper,iChO,One) -* - End Do -* - End If -* -* - If (iPrint.ge.99) Then - Write (6,*) - Write (6,*) ' Result in MltInt' - Write (6,*) - Write (6,*) 'la,lb,nHer=',la,lb,nHer - Write (6,*) 'nComp=',nComp - Write (6,*) - Do iIC = 1, nIC - Write (Label,'(A,I2,A)') - & ' MltInt(iIC=',iIC,')' - Call RecPrt(Label,'(10G15.8) ',Final(1,1,1,iIC),nZeta, - & nElem(la)*nElem(lb)) - End Do - End If -* -* Call GetMem(' Exit MltInt','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Alpha) - Call Unused_real_array(Beta) - Call Unused_real_array(ZInv) - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/mltint.F90 openmolcas-22.10/src/oneint_util/mltint.F90 --- openmolcas-22.02/src/oneint_util/mltint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/mltint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,216 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine MltInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the multipole moments integrals with the * +! Gauss-Hermite quadrature. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! November '90 * +! Modified to multipole moments November '90 * +!*********************************************************************** + +use Her_RW, only: HerR, HerW, iHerR, iHerW +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "rmat_option.fh" +#include "oneswi.fh" +#include "print.fh" +integer(kind=iwp) :: iComp, iDCRT(0:7), ii, iIC, ipAxyz, ipBxyz, ipFnl, ipQxyz, iPrint, ipRnr, ipRxyz, iRout, iStabO(0:7), lDCRT, & + llOper, LmbdT, lsum, nDCRT, nip, nOp, nStabO +real(kind=wp) :: TC(3) +logical(kind=iwp) :: ABeq(3) +character(len=80) :: Label +real(kind=wp), parameter :: Origin(3) = Zero +character(len=*), parameter :: ChOper(0:7) = ['E ','x ','y ','xy ','z ','xz ','yz ','xyz'] +integer(kind=iwp), external :: NrOpr +logical(kind=iwp), external :: EQ + +#include "macros.fh" +unused_var(Alpha) +unused_var(Beta) +unused_var(ZInv) +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 122 +iPrint = nPrint(iRout) + +rFinal(:,:,:,:) = Zero + +ABeq(:) = A == RB +! switch (only single center overlap matrix...) +if (NDDO .and. (.not.(ABeq(1)) .and. ABeq(2) .and. ABeq(3))) return +! switch +nip = 1 +ipAxyz = nip +nip = nip+nZeta*3*nHer*(la+1) +ipBxyz = nip +nip = nip+nZeta*3*nHer*(lb+1) +ipRxyz = nip +nip = nip+nZeta*3*nHer*(nOrdOp+1) +ipQxyz = nip +nip = nip+nZeta*3*(la+1)*(lb+1)*(nOrdOp+1) +ipFnl = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb)*nComp +! * +!*********************************************************************** +! * +if (RMat_type_integrals) then + ipRnr = nip + nip = nip+nZeta*(la+lb+nOrdOp+1) +else + ipRnr = -1 +end if +! * +!*********************************************************************** +! * +if (nip-1 > nArr*nZeta) then + call WarningMessage(2,'MltInt: nip-1 > nArr*nZeta') + write(u6,*) ' nArr is Wrong! ',nip-1,' > ',nArr*nZeta + write(u6,*) ' Abend in MltInt' + call Abend() +end if + +if (iPrint >= 49) then + call RecPrt(' In MltInt: A',' ',A,1,3) + call RecPrt(' In MltInt: RB',' ',RB,1,3) + call RecPrt(' In MltInt: Ccoor',' ',Ccoor,1,3) + call RecPrt(' In MltInt: Kappa',' ',rKappa,nAlpha,nBeta) + call RecPrt(' In MltInt: Zeta',' ',Zeta,nAlpha,nBeta) + call RecPrt(' In MltInt: P',' ',P,nZeta,3) + write(u6,*) ' In MltInt: la,lb=',la,lb +end if + +llOper = lOper(1) +do iComp=2,nComp + llOper = ior(llOper,lOper(iComp)) +end do +! * +!*********************************************************************** +! * +if (RMat_type_integrals) then + + if (.not. EQ(CCoor,Origin)) then + call WarningMessage(2,'MltInt: R-matrix error') + write(u6,*) 'MltInt: Wrong center of origin in case of R-matrix type of integrals!' + write(u6,*) ' Origin should always be (0.0,0.0,0.0)!' + write(u6,*) ' User the CENTER option to do this (see the SEWARD input section in the manual).' + write(u6,'(A,I3)') 'nOrdOp=',nOrdOp + call Abend() + end if + + ! R-matrix calculations: continuum basis functions (A=B=P=0) + ! Compute the contributions of the basis functions and multipole + ! radial part + + lsum = la+lb+nOrdOp + call radlc(Zeta,nZeta,lsum,Array(ipRnr)) + + ! Combine the radial and angular component to the full one electron integral. + + call CmbnMPr(Array(ipRnr),nZeta,la,lb,nOrdOp,Zeta,Array(ipFnl),nComp) + + call SOS(iStabO,nStabO,llOper) + call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) + if (iPrint >= 99) then + write(u6,*) ' m =',nStabM + write(u6,'(9A)') '{M}=',(ChOper(iStabM(ii)),ii=0,nStabM-1) + write(u6,*) ' s =',nStabO + write(u6,'(9A)') '{S}=',(ChOper(iStabO(ii)),ii=0,nStabO-1) + write(u6,*) ' LambdaT=',LmbdT + write(u6,*) ' t =',nDCRT + write(u6,'(9A)') '{T}=',(ChOper(iDCRT(ii)),ii=0,nDCRT-1) + end if + + do lDCRT=0,nDCRT-1 + + ! Accumulate contributions + + nOp = NrOpr(iDCRT(lDCRT)) + call SymAdO(Array(ipFnl),nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,One) + end do + +else + ! * + !********************************************************************* + ! * + ! Compute the cartesian values of the basis functions angular part + + call CrtCmp(Zeta,P,nZeta,A,Array(ipAxyz),la,HerR(iHerR(nHer)),nHer,ABeq) + call CrtCmp(Zeta,P,nZeta,RB,Array(ipBxyz),lb,HerR(iHerR(nHer)),nHer,ABeq) + + call SOS(iStabO,nStabO,llOper) + call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) + if (iPrint >= 99) then + write(u6,*) ' m =',nStabM + write(u6,'(9A)') '{M}=',(ChOper(iStabM(ii)),ii=0,nStabM-1) + write(u6,*) ' s =',nStabO + write(u6,'(9A)') '{S}=',(ChOper(iStabO(ii)),ii=0,nStabO-1) + write(u6,*) ' LambdaT=',LmbdT + write(u6,*) ' t =',nDCRT + write(u6,'(9A)') '{T}=',(ChOper(iDCRT(ii)),ii=0,nDCRT-1) + end if + + do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),CCoor,TC) + + ! Compute the contribution from the multipole moment operator + + ABeq(:) = .false. + call CrtCmp(Zeta,P,nZeta,TC,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) + + ! Compute the cartesian components for the multipole moment + ! integrals. The integrals are factorized into components. + + call Assmbl(Array(ipQxyz),Array(ipAxyz),la,Array(ipRxyz),nOrdOp,Array(ipBxyz),lb,nZeta,HerW(iHerW(nHer)),nHer) + + ! Combine the cartesian components to the full one electron integral. + + call CmbnMP(Array(ipQxyz),nZeta,la,lb,nOrdOp,Zeta,rKappa,Array(ipFnl),nComp) + + ! Accumulate contributions + + nOp = NrOpr(iDCRT(lDCRT)) + call SymAdO(Array(ipFnl),nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,One) + + end do + +end if + +if (iPrint >= 99) then + write(u6,*) + write(u6,*) ' Result in MltInt' + write(u6,*) + write(u6,*) 'la,lb,nHer=',la,lb,nHer + write(u6,*) 'nComp=',nComp + write(u6,*) + do iIC=1,nIC + write(Label,'(A,I2,A)') ' MltInt(iIC=',iIC,')' + call RecPrt(Label,'(10G15.8) ',rFinal(:,:,:,iIC),nZeta,nTri_Elem1(la)*nTri_Elem1(lb)) + end do +end if + +return + +end subroutine MltInt diff -Nru openmolcas-22.02/src/oneint_util/mltint_giao.f openmolcas-22.10/src/oneint_util/mltint_giao.f --- openmolcas-22.02/src/oneint_util/mltint_giao.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/mltint_giao.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,179 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine MltInt_GIAO(Alpha,nAlpha,Beta, nBeta,Zeta,ZInv,rKappa, - & P,Final,nZeta,nIC,nComp,la,lb,A,RB,nHer, - & Array,nArr,Ccoor,nOrdOp,lOper,iChO, - & iStabM,nStabM, - & PtChrg,nGrid,iAddPot) -************************************************************************ -* * -* Object: to compute the multipole moments integrals with the * -* Gauss-Hermite quadrature. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* November '90 * -* Modified to multipole moments November '90 * -************************************************************************ - use Her_RW - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "oneswi.fh" -#include "print.fh" - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nIC), - & Zeta(nZeta), ZInv(nZeta), Alpha(nAlpha), Beta(nBeta), - & rKappa(nZeta), P(nZeta,3), A(3), RB(3), RAB(3), - & Array(nZeta*nArr), Ccoor(3), TC(3) - Character*80 Label, ChOper(0:7)*3 - Integer lOper(nComp), iStabM(0:nStabM-1), iStabO(0:7), - & iDCRT(0:7), iChO(nComp) - Logical ABeq(3), EQ - Data ChOper/'E ','x ','y ','xy ','z ','xz ','yz ','xyz'/ -* -* Statement function -* - nElem(i) = (i+1)*(i+2)/2 -* - iRout = 122 - iPrint = nPrint(iRout) -* - call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) - If (EQ(A,RB)) Go To 999 -* - ABeq(1) = A(1).eq.RB(1) - ABeq(2) = A(2).eq.RB(2) - ABeq(3) = A(3).eq.RB(3) - RAB(1)=A(1)-RB(1) - RAB(2)=A(2)-RB(2) - RAB(3)=A(3)-RB(3) -* switch (only single center overlap matrix...) - If (NDDO.AND. - & .NOT.(ABeq(1).AND.ABeq(2).AND.ABeq(3))) Then - call dcopy_(nZeta*nIC*nElem(la)*nElem(lb),[Zero],0,Final,1) - Return - End If -* switch -* - nip = 1 - ipAxyz = nip - nip = nip + nZeta*3*nHer*(la+1) - ipBxyz = nip - nip = nip + nZeta*3*nHer*(lb+1) - ipRxyz = nip - nip = nip + nZeta*3*nHer*(nOrdOp+2) - ipQxyz = nip - nip = nip + nZeta*3*(la+1)*(lb+1)*(nOrdOp+2) - ipFnl = nip - nip = nip + nZeta*nElem(la)*nElem(lb)*nComp - If (nip-1.gt.nArr*nZeta) Then - Call WarningMessage(2,'MltInt_GIAO: nip-1.gt.nArr*nZeta') - Write (6,*) ' nArr is Wrong! ', nip-1,' > ',nArr*nZeta - Write (6,*) ' Abend in MltInt' - Call Abend() - End If -* - If (iPrint.ge.49) Then - Call RecPrt(' In MltInt: A',' ',A,1,3) - Call RecPrt(' In MltInt: RB',' ',RB,1,3) - Call RecPrt(' In MltInt: Ccoor',' ',Ccoor,1,3) - Call RecPrt(' In MltInt: Kappa',' ',rKappa,nAlpha,nBeta) - Call RecPrt(' In MltInt: Zeta',' ',Zeta,nAlpha,nBeta) - Call RecPrt(' In MltInt: P',' ',P,nZeta,3) - Write (6,*) ' In MltInt: la,lb=',la,lb - End If -* - llOper = lOper(1) - Do 90 iComp = 2, nComp - llOper = iOr(llOper,lOper(iComp)) - 90 Continue -* -* Compute the cartesian values of the basis functions angular part -* - Call CrtCmp(Zeta,P,nZeta,A,Array(ipAxyz), - & la,HerR(iHerR(nHer)),nHer,ABeq) - Call CrtCmp(Zeta,P,nZeta,RB,Array(ipBxyz), - & lb,HerR(iHerR(nHer)),nHer,ABeq) -* -* - Call SOS(iStabO,nStabO,llOper) - Call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) - If (iPrint.ge.99) Then - Write (6,*) ' m =',nStabM - Write (6,'(9A)') '{M}=',(ChOper(iStabM(ii)),ii = 0, nStabM-1) - Write (6,*) ' s =',nStabO - Write (6,'(9A)') '{S}=',(ChOper(iStabO(ii)),ii = 0, nStabO-1) - Write (6,*) ' LambdaT=',LmbdT - Write (6,*) ' t =',nDCRT - Write (6,'(9A)') '{T}=',(ChOper(iDCRT(ii)),ii = 0, nDCRT-1) - End If -* - Do 102 lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),CCoor,TC) -* -* Compute the contribution from the multipole moment operator -* - ABeq(1) = .False. - ABeq(2) = .False. - ABeq(3) = .False. - Call CrtCmp(Zeta,P,nZeta,TC,Array(ipRxyz), - & nOrdOp+1,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the cartesian components for the multipole moment -* integrals. The integrals are factorized into components. -* - Call Assmbl(Array(ipQxyz), - & Array(ipAxyz),la, - & Array(ipRxyz),nOrdOp+1, - & Array(ipBxyz),lb, - & nZeta,HerW(iHerW(nHer)),nHer) -* -* Combine the cartesian components to the full one electron -* integral. -* - nB=3 - Call CmbnMP_GIAO(Array(ipQxyz),nZeta,la,lb,nOrdOp,Zeta,rKappa, - & Array(ipFnl),nComp/nB,nB,RAB,TC) -* -* Accumulate contributions -* - nOp = NrOpr(iDCRT(lDCRT)) - Call SymAdO(Array(ipFnl),nZeta,la,lb,nComp,Final,nIC, - & nOp ,lOper,iChO,One) -* - 102 Continue -* - 999 Continue - If (iPrint.ge.99) Then - Write (6,*) ' Result in MltInt' - Do 100 ia = 1, (la+1)*(la+2)/2 - Do 200 ib = 1, (lb+1)*(lb+2)/2 - Do 300 iIC = 1, nIC - Write (Label,'(A,I2,A,I2,A,I2,A)') - & ' Final(a=',ia,',b=',ib,',iIC=',iIC,')' - Call RecPrt(Label,' ',Final(1,ia,ib,iIC),nAlpha,nBeta) - 300 Continue - 200 Continue - 100 Continue - End If -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Alpha) - Call Unused_real_array(Beta) - Call Unused_real_array(ZInv) - Call Unused_real(PtChrg) - Call Unused_integer(nGrid) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/mltint_giao.F90 openmolcas-22.10/src/oneint_util/mltint_giao.F90 --- openmolcas-22.02/src/oneint_util/mltint_giao.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/mltint_giao.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,159 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine MltInt_GIAO( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the multipole moments integrals with the * +! Gauss-Hermite quadrature. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! November '90 * +! Modified to multipole moments November '90 * +!*********************************************************************** + +use Her_RW, only: HerR, HerW, iHerR, iHerW +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "oneswi.fh" +#include "print.fh" +integer(kind=iwp) :: ia, ib, iComp, iDCRT(0:7), ii, iIC, ipAxyz, ipBxyz, ipFnl, ipQxyz, iPrint, ipRxyz, iRout, iStabO(0:7), lDCRT, & + llOper, LmbdT, nB, nDCRT, nip, nOp, nStabO +real(kind=wp) :: RAB(3), TC(3) +character(len=80) :: Label +logical(kind=iwp) :: ABeq(3) +character(len=*), parameter :: ChOper(0:7) = ['E ','x ','y ','xy ','z ','xz ','yz ','xyz'] +integer(kind=iwp), external :: NrOpr +logical(kind=iwp), external :: EQ + +#include "macros.fh" +unused_var(Alpha) +unused_var(Beta) +unused_var(ZInv) +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 122 +iPrint = nPrint(iRout) + +rFinal(:,:,:,:) = Zero + +if (.not. EQ(A,RB)) then + + ABeq(:) = A == RB + RAB(:) = A-RB + ! switch (only single center overlap matrix...) + if (NDDO .and. (.not.(ABeq(1)) .and. ABeq(2) .and. ABeq(3))) return + ! switch + nip = 1 + ipAxyz = nip + nip = nip+nZeta*3*nHer*(la+1) + ipBxyz = nip + nip = nip+nZeta*3*nHer*(lb+1) + ipRxyz = nip + nip = nip+nZeta*3*nHer*(nOrdOp+2) + ipQxyz = nip + nip = nip+nZeta*3*(la+1)*(lb+1)*(nOrdOp+2) + ipFnl = nip + nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb)*nComp + if (nip-1 > nArr*nZeta) then + call WarningMessage(2,'MltInt_GIAO: nip-1 > nArr*nZeta') + write(u6,*) ' nArr is Wrong! ',nip-1,' > ',nArr*nZeta + write(u6,*) ' Abend in MltInt' + call Abend() + end if + + if (iPrint >= 49) then + call RecPrt(' In MltInt: A',' ',A,1,3) + call RecPrt(' In MltInt: RB',' ',RB,1,3) + call RecPrt(' In MltInt: Ccoor',' ',Ccoor,1,3) + call RecPrt(' In MltInt: Kappa',' ',rKappa,nAlpha,nBeta) + call RecPrt(' In MltInt: Zeta',' ',Zeta,nAlpha,nBeta) + call RecPrt(' In MltInt: P',' ',P,nZeta,3) + write(u6,*) ' In MltInt: la,lb=',la,lb + end if + + llOper = lOper(1) + do iComp=2,nComp + llOper = ior(llOper,lOper(iComp)) + end do + + ! Compute the cartesian values of the basis functions angular part + + call CrtCmp(Zeta,P,nZeta,A,Array(ipAxyz),la,HerR(iHerR(nHer)),nHer,ABeq) + call CrtCmp(Zeta,P,nZeta,RB,Array(ipBxyz),lb,HerR(iHerR(nHer)),nHer,ABeq) + + call SOS(iStabO,nStabO,llOper) + call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) + if (iPrint >= 99) then + write(u6,*) ' m =',nStabM + write(u6,'(9A)') '{M}=',(ChOper(iStabM(ii)),ii=0,nStabM-1) + write(u6,*) ' s =',nStabO + write(u6,'(9A)') '{S}=',(ChOper(iStabO(ii)),ii=0,nStabO-1) + write(u6,*) ' LambdaT=',LmbdT + write(u6,*) ' t =',nDCRT + write(u6,'(9A)') '{T}=',(ChOper(iDCRT(ii)),ii=0,nDCRT-1) + end if + + do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),CCoor,TC) + + ! Compute the contribution from the multipole moment operator + + ABeq(1) = .false. + ABeq(2) = .false. + ABeq(3) = .false. + call CrtCmp(Zeta,P,nZeta,TC,Array(ipRxyz),nOrdOp+1,HerR(iHerR(nHer)),nHer,ABeq) + + ! Compute the cartesian components for the multipole moment + ! integrals. The integrals are factorized into components. + + call Assmbl(Array(ipQxyz),Array(ipAxyz),la,Array(ipRxyz),nOrdOp+1,Array(ipBxyz),lb,nZeta,HerW(iHerW(nHer)),nHer) + + ! Combine the cartesian components to the full one electron integral. + + nB = 3 + call CmbnMP_GIAO(Array(ipQxyz),nZeta,la,lb,nOrdOp,Zeta,rKappa,Array(ipFnl),nComp/nB,nB,RAB,TC) + + ! Accumulate contributions + + nOp = NrOpr(iDCRT(lDCRT)) + call SymAdO(Array(ipFnl),nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,One) + + end do + +end if + +if (iPrint >= 99) then + write(u6,*) ' Result in MltInt' + do ia=1,(la+1)*(la+2)/2 + do ib=1,(lb+1)*(lb+2)/2 + do iIC=1,nIC + write(Label,'(A,I2,A,I2,A,I2,A)') ' rFinal(a=',ia,',b=',ib,',iIC=',iIC,')' + call RecPrt(Label,' ',rFinal(:,ia,ib,iIC),nAlpha,nBeta) + end do + end do + end do +end if + +return + +end subroutine MltInt_GIAO diff -Nru openmolcas-22.02/src/oneint_util/mltmem.f openmolcas-22.10/src/oneint_util/mltmem.f --- openmolcas-22.02/src/oneint_util/mltmem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/mltmem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine MltMem( -#define _CALLING_ -#include "mem_interface.fh" - &) -#include "mem_interface.fh" -* -#include "rmat_option.fh" -* - nElem(i) = (i+1)*(i+2)/2 -* - nHer=(la+lb+lr+2)/2 - nComp = nElem(lr) - Mem = 3*nHer*(la+1) + - & 3*nHer*(lb+1) + - & 3*nHer*(lr+1) + - & 3*(la+1)*(lb+1)*(lr+1) + - & nElem(la)*nElem(lb)*nComp - If (RMat_type_integrals) Then - Mem = Mem + la+lb+lr+1 - End If -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/mltmem.F90 openmolcas-22.10/src/oneint_util/mltmem.F90 --- openmolcas-22.02/src/oneint_util/mltmem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/mltmem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,32 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine MltMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +#include "rmat_option.fh" +integer(kind=iwp) :: nComp + +nHer = (la+lb+lr+2)/2 +nComp = nTri_Elem1(lr) +Mem = 3*nHer*(la+1)+3*nHer*(lb+1)+3*nHer*(lr+1)+3*(la+1)*(lb+1)*(lr+1)+nTri_Elem1(la)*nTri_Elem1(lb)*nComp +if (RMat_type_integrals) Mem = Mem+la+lb+lr+1 + +return + +end subroutine MltMem diff -Nru openmolcas-22.02/src/oneint_util/mltmem_giao.f openmolcas-22.10/src/oneint_util/mltmem_giao.f --- openmolcas-22.02/src/oneint_util/mltmem_giao.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/mltmem_giao.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,24 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine MltMem_GIAO(nHer,MemMlt,la,lb,lr) - Parameter(nB=3) -* - nElem(i) = (i+1)*(i+2)/2 -* - nHer=(la+lb+lr+3)/2 - MemMlt = 3*nHer*(la+1) + - & 3*nHer*(lb+1) + - & 3*nHer*(lr+2) + - & 3*(la+1)*(lb+1)*(lr+2) + - & nElem(la)*nElem(lb)*nElem(lr)*nB -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/mltmem_giao.F90 openmolcas-22.10/src/oneint_util/mltmem_giao.F90 --- openmolcas-22.02/src/oneint_util/mltmem_giao.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/mltmem_giao.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,29 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine MltMem_GIAO( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp), parameter :: nB = 3 + +nHer = (la+lb+lr+3)/2 +Mem = 3*nHer*(la+1)+3*nHer*(lb+1)+3*nHer*(lr+2)+3*(la+1)*(lb+1)*(lr+2)+nTri_Elem1(la)*nTri_Elem1(lb)*nTri_Elem1(lr)*nB + +return + +end subroutine MltMem_GIAO diff -Nru openmolcas-22.02/src/oneint_util/mltmmp.f openmolcas-22.10/src/oneint_util/mltmmp.f --- openmolcas-22.02/src/oneint_util/mltmmp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/mltmmp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,20 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine MltMmP(nHer,MmMltP,la,lb,lr) -* - nHer=(la+lb+lr+2)/2 - MmMltP = 3*nHer*(la+1) + - & 3*nHer*(lb+1) + - & 3*nHer*(lr+1) + - & 3*(la+1)*(lb+1)*(lr+1) -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/mltmmp.F90 openmolcas-22.10/src/oneint_util/mltmmp.F90 --- openmolcas-22.02/src/oneint_util/mltmmp.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/mltmmp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,27 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine MltMmP( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" + +nHer = (la+lb+lr+2)/2 +Mem = 3*nHer*(la+1)+3*nHer*(lb+1)+3*nHer*(lr+1)+3*(la+1)*(lb+1)*(lr+1) + +return + +end subroutine MltMmP diff -Nru openmolcas-22.02/src/oneint_util/mve.f openmolcas-22.10/src/oneint_util/mve.f --- openmolcas-22.02/src/oneint_util/mve.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/mve.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,133 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990,1998, Roland Lindh * -* 1998, Samuel Mikes * -************************************************************************ - SubRoutine MVe(rV2Int,rV4Int,Sxyz,na,nb,Alpha,Beta,nZeta) -************************************************************************ -* * -* Object: to compute intermediate integrals for the evaluation of the * -* mass velocity integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* November '90 * -* * -* Correct out of bound reference, February '98, Samuel * -* Mikes and Roland Lindh. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 rV2Int(nZeta,3,0:na,0:nb,2), - & rV4Int(nZeta,3,0:na,0:nb), - & Sxyz(nZeta,3,0:na+2,0:nb+2), - & Alpha(nZeta), Beta(nZeta) - Character*80 Label -* - iRout = 192 - iPrint = nPrint(iRout) -* - If (iPrint.ge.99) Then - Call RecPrt(' In MVe: Alpha',' ',Alpha,nZeta,1) - Call RecPrt(' In MVe: Beta ',' ',Beta ,nZeta,1) - Do ib = 0, nb+2 - Do ia = 0, na+2 - Write (Label,'(A,I2,A,I2,A)') - & ' In MVe: Sxyz(',ia,',',ib,')' - Call RecPrt(Label,' ',Sxyz(1,1,ia,ib),nZeta,3) - End Do - End Do -* - End If - Do ib = 0, nb - Do ia = 0, na - Do iCar = 1, 3 - Do iZeta = 1, nZeta -* - rV2Int(iZeta,iCar,ia,ib,1) = - & Four*Alpha(iZeta)**2*Sxyz(iZeta,iCar,ia+2,ib) - & -Two*Alpha(iZeta)*(Two*Dble(ia)+One)* - & Sxyz(iZeta,iCar,ia,ib) - If (ia.ge.2) Then - rV2Int(iZeta,iCar,ia,ib,1) = - & rV2Int(iZeta,iCar,ia,ib,1) - & +Dble(ia*(ia-1))* Sxyz(iZeta,iCar,ia-2,ib) - End If -* - rV2Int(iZeta,iCar,ia,ib,2) = - & Four* Beta(iZeta)**2*Sxyz(iZeta,iCar,ia,ib+2) - & -Two* Beta(iZeta)*(Two*Dble(ib)+One)* - & Sxyz(iZeta,iCar,ia,ib) - If (ib.ge.2) Then - rV2Int(iZeta,iCar,ia,ib,2) = - & rV2Int(iZeta,iCar,ia,ib,2) - & +Dble(ib*(ib-1))* Sxyz(iZeta,iCar,ia,ib-2) - End If -* - rV4Int(iZeta,iCar,ia,ib) = - & Four*Alpha(iZeta)**2* - & Four* Beta(iZeta)**2*Sxyz(iZeta,iCar,ia+2,ib+2) - & -Four*Alpha(iZeta)**2* - & Two* Beta(iZeta)*(Two*Dble(ib)+One)* - & Sxyz(iZeta,iCar,ia+2,ib) - & -Four* Beta(iZeta)**2* - & Two*Alpha(iZeta)*(Two*Dble(ia)+One)* - & Sxyz(iZeta,iCar,ia,ib+2) - & +Two*Alpha(iZeta)*(Two*Dble(ia)+One)* - & Two* Beta(iZeta)*(Two*Dble(ib)+One)* - & Sxyz(iZeta,iCar,ia,ib) - If (ia.ge.2) Then - rV4Int(iZeta,iCar,ia,ib) = - & rV4Int(iZeta,iCar,ia,ib) + Dble(ia*(ia-1))* ( - & Four* Beta(iZeta)**2 * - & Sxyz(iZeta,iCar,ia-2,ib+2) - & -Two* Beta(iZeta)*(Two*Dble(ib)+One)* - & Sxyz(iZeta,iCar,ia-2,ib) ) - End If - If (ib.ge.2) Then - rV4Int(iZeta,iCar,ia,ib) = - & rV4Int(iZeta,iCar,ia,ib) + Dble(ib*(ib-1))* ( - & Four*Alpha(iZeta)**2 * - & Sxyz(iZeta,iCar,ia+2,ib-2) - & -Two*Alpha(iZeta)*(Two*Dble(ia)+One)* - & Sxyz(iZeta,iCar,ia,ib-2) ) - End If - If (ia.ge.2.and.ib.ge.2) Then - rV4Int(iZeta,iCar,ia,ib) = - & rV4Int(iZeta,iCar,ia,ib) - & +Dble(ia*(ia-1)*ib*(ib-1)) * - & Sxyz(iZeta,iCar,ia-2,ib-2) - End If -* - End Do - End Do - End Do - End Do -* - If (iPrint.ge.99) Then - Do ib = 0, nb - Do ia = 0, na - Write (Label,'(A,I2,A,I2,A)') - & 'In MVe: rV2Int(',ia,',',ib,',1)' - Call RecPrt(Label,' ',rV2Int(1,1,ia,ib,1),nZeta,3) - Write (Label,'(A,I2,A,I2,A)') - & 'In MVe: rV2Int(',ia,',',ib,',2)' - Call RecPrt(Label,' ',rV2Int(1,1,ia,ib,2),nZeta,3) - Write (Label,'(A,I2,A,I2,A)') - & 'In MVe: rV4Int(',ia,',',ib,')' - Call RecPrt(Label,' ',rV4Int(1,1,ia,ib),nZeta,3) - End Do - End Do - End If -* -* Call GetMem(' Exit MVe ','CHECK','REAL',iDum,iDum) - Return - End diff -Nru openmolcas-22.02/src/oneint_util/mve.F90 openmolcas-22.10/src/oneint_util/mve.F90 --- openmolcas-22.02/src/oneint_util/mve.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/mve.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,91 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990,1998, Roland Lindh * +! 1998, Samuel Mikes * +!*********************************************************************** + +subroutine MVe(rV2Int,rV4Int,Sxyz,na,nb,Alpha,Beta,nZeta) +!*********************************************************************** +! * +! Object: to compute intermediate integrals for the evaluation of the * +! mass velocity integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! November '90 * +! * +! Correct out of bound reference, February '98, Samuel * +! Mikes and Roland Lindh. * +!*********************************************************************** + +use Constants, only: Two, Four +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: na, nb, nZeta +real(kind=wp), intent(out) :: rV2Int(nZeta,3,0:na,0:nb,2), rV4Int(nZeta,3,0:na,0:nb) +real(kind=wp), intent(in) :: Sxyz(nZeta,3,0:na+2,0:nb+2), Alpha(nZeta), Beta(nZeta) +#include "print.fh" +integer(kind=iwp) :: ia, ib, iCar, iPrint, iRout +character(len=80) :: Label + +iRout = 192 +iPrint = nPrint(iRout) + +if (iPrint >= 99) then + call RecPrt(' In MVe: Alpha',' ',Alpha,nZeta,1) + call RecPrt(' In MVe: Beta ',' ',Beta,nZeta,1) + do ib=0,nb+2 + do ia=0,na+2 + write(Label,'(A,I2,A,I2,A)') ' In MVe: Sxyz(',ia,',',ib,')' + call RecPrt(Label,' ',Sxyz(:,:,ia,ib),nZeta,3) + end do + end do + +end if +do ib=0,nb + do ia=0,na + do iCar=1,3 + rV2Int(:,iCar,ia,ib,1) = Four*Alpha**2*Sxyz(:,iCar,ia+2,ib)-Two*Alpha*real(2*ia+1,kind=wp)*Sxyz(:,iCar,ia,ib) + if (ia >= 2) rV2Int(:,iCar,ia,ib,1) = rV2Int(:,iCar,ia,ib,1)+real(ia*(ia-1),kind=wp)*Sxyz(:,iCar,ia-2,ib) + + rV2Int(:,iCar,ia,ib,2) = Four*Beta**2*Sxyz(:,iCar,ia,ib+2)-Two*Beta*real(2*ib+1,kind=wp)*Sxyz(:,iCar,ia,ib) + if (ib >= 2) rV2Int(:,iCar,ia,ib,2) = rV2Int(:,iCar,ia,ib,2)+real(ib*(ib-1),kind=wp)*Sxyz(:,iCar,ia,ib-2) + + rV4Int(:,iCar,ia,ib) = Four*Alpha**2*Four*Beta**2*Sxyz(:,iCar,ia+2,ib+2)- & + Four*Alpha**2*Two*Beta*real(2*ib+1,kind=wp)*Sxyz(:,iCar,ia+2,ib)- & + Four*Beta**2*Two*Alpha*real(2*ia+1,kind=wp)*Sxyz(:,iCar,ia,ib+2)+ & + Two*Alpha*real(2*ia+1,kind=wp)*Two*Beta*real(2*ib+1,kind=wp)*Sxyz(:,iCar,ia,ib) + if (ia >= 2) rV4Int(:,iCar,ia,ib) = rV4Int(:,iCar,ia,ib)+real(ia*(ia-1),kind=wp)* & + (Four*Beta**2*Sxyz(:,iCar,ia-2,ib+2)-Two*Beta*real(2*ib+1,kind=wp)*Sxyz(:,iCar,ia-2,ib)) + if (ib >= 2) rV4Int(:,iCar,ia,ib) = rV4Int(:,iCar,ia,ib)+real(ib*(ib-1),kind=wp)* & + (Four*Alpha**2*Sxyz(:,iCar,ia+2,ib-2)-Two*Alpha*real(2*ia+1,kind=wp)*Sxyz(:,iCar,ia,ib-2)) + if ((ia >= 2) .and. (ib >= 2)) rV4Int(:,iCar,ia,ib) = rV4Int(:,iCar,ia,ib)+ & + real(ia*(ia-1)*ib*(ib-1),kind=wp)*Sxyz(:,iCar,ia-2,ib-2) + end do + end do +end do + +if (iPrint >= 99) then + do ib=0,nb + do ia=0,na + write(Label,'(A,I2,A,I2,A)') 'In MVe: rV2Int(',ia,',',ib,',1)' + call RecPrt(Label,' ',rV2Int(:,:,ia,ib,1),nZeta,3) + write(Label,'(A,I2,A,I2,A)') 'In MVe: rV2Int(',ia,',',ib,',2)' + call RecPrt(Label,' ',rV2Int(:,:,ia,ib,2),nZeta,3) + write(Label,'(A,I2,A,I2,A)') 'In MVe: rV4Int(',ia,',',ib,')' + call RecPrt(Label,' ',rV4Int(:,:,ia,ib),nZeta,3) + end do + end do +end if + +return + +end subroutine MVe diff -Nru openmolcas-22.02/src/oneint_util/mveint.f openmolcas-22.10/src/oneint_util/mveint.f --- openmolcas-22.02/src/oneint_util/mveint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/mveint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,152 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine MVeInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: to compute the mass-velocity integrals with the Gauss- * -* Hermite quadrature. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, Sweden. February '91 * -************************************************************************ - use Her_RW - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - -#include "int_interface.fh" - -* Local variables - Logical ABeq(3) - Character*80 Label -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - iRout = 190 - iPrint = nPrint(iRout) - ABeq(1) = A(1).eq.RB(1) - ABeq(2) = A(2).eq.RB(2) - ABeq(3) = A(3).eq.RB(3) -* - nip = 1 - ipAxyz = nip - nip = nip + nZeta*3*nHer*(la+3) - ipBxyz = nip - nip = nip + nZeta*3*nHer*(lb+3) - ipRxyz = nip - nip = nip + nZeta*3*nHer*(nOrdOp-3) - ipQxyz = nip - nip = nip + nZeta*3*(la+3)*(lb+3)*(nOrdOp-3) - iprV2 = nip - nip = nip + nZeta*3*(la+1)*(lb+1)* 2 - iprV4 = nip - nip = nip + nZeta*3*(la+1)*(lb+1) - ipA = nip - nip = nip + nZeta - ipB = nip - nip = nip + nZeta - If (nip-1.gt.nArr*nZeta) Then - Call WarningMessage(2,'MVeInt: nip-1.gt.nArr*nZeta') - Write (6,*) ' nArr is Wrong! ', nip-1,' > ',nArr*nZeta - Write (6,*) ' Abend in MVeInt' - Call Abend() - End If -* - If (iPrint.ge.49) Then - Call RecPrt(' In MVeInt: A',' ',A,1,3) - Call RecPrt(' In MVeInt: RB',' ',RB,1,3) - Call RecPrt(' In MVeInt: Ccoor',' ',Ccoor,1,3) - Call RecPrt(' In MVeInt: P',' ',P,nZeta,3) - Call RecPrt(' In MVeInt: Zeta',' ',Zeta,nZeta,1) - Call RecPrt(' In MVeInt: Roots',' ', - & HerR(iHerR(nHer)),nHer,1) - Call GetMem(' In MVeInt','LIST','REAL',iDum,iDum) - Write (6,*) ' In MVeInt: la,lb=',la,lb - End If -* -* Compute the cartesian values of the basis functions angular part -* - Call CrtCmp(Zeta,P,nZeta,A,Array(ipAxyz), - & la+2,HerR(iHerR(nHer)),nHer,ABeq) - Call CrtCmp(Zeta,P,nZeta,RB,Array(ipBxyz), - & lb+2,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the contribution from the multipole moment operator -* - ABeq(1) = .False. - ABeq(2) = .False. - ABeq(3) = .False. - Call CrtCmp(Zeta,P,nZeta,Ccoor,Array(ipRxyz), - & nOrdOp-4,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the cartesian components for the multipole moment -* integrals. The integrals are factorized into components. -* - Call Assmbl(Array(ipQxyz), - & Array(ipAxyz),la+2, - & Array(ipRxyz),nOrdOp-4, - & Array(ipBxyz),lb+2, - & nZeta,HerW(iHerW(nHer)),nHer) -* -* Compute the cartesian components for the mass-velocity integrals. -* The kinetic energy components are linear combinations of overlap -* components. -* - ipAOff = ipA - Do 200 iBeta = 1, nBeta - call dcopy_(nAlpha,Alpha,1,Array(ipAOff),1) - ipAOff = ipAOff + nAlpha - 200 Continue -* - ipBOff = ipB - Do 210 iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ipBOff),nAlpha) - ipBOff = ipBOff + 1 - 210 Continue -* - Call MVe(Array(iprV2),Array(iprV4), Array(ipQxyz),la,lb, - & Array(ipA),Array(ipB),nZeta) -* -* Combine the cartesian components to the full one electron -* integral. -* - Call CmbnMV(Array(ipQxyz),nZeta,la,lb,nOrdOp-4,Zeta,rKappa,Final, - & nComp,Array(iprV2),Array(iprV4)) -* - If (iPrint.ge.99) Then - Do 300 ia = 1, nElem(la) - Do 310 ib = 1, nElem(lb) - Write (Label,'(A,I2,A,I2,A)') - & 'Mass-Velocity(',ia,',',ib,')' - Call RecPrt(Label,' ',Final(1,1,ia,ib),nZeta,nComp) - 310 Continue - 300 Continue - End If -* -* Call GetMem(' Exit MVeInt','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(ZInv) - Call Unused_integer_array(lOper) - Call Unused_integer_array(iChO) - Call Unused_integer_array(iStabM) - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/mveint.F90 openmolcas-22.10/src/oneint_util/mveint.F90 --- openmolcas-22.02/src/oneint_util/mveint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/mveint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,131 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine MVeInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the mass-velocity integrals with the Gauss- * +! Hermite quadrature. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, Sweden. February '91 * +!*********************************************************************** + +use Her_RW, only: HerR, HerW, iHerR, iHerW +use Index_Functions, only: nTri_Elem1 +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "print.fh" +integer(kind=iwp) :: ia, ib, iBeta, ipA, ipAOff, ipAxyz, ipB, ipBOff, ipBxyz, ipQxyz, iPrint, iprV2, iprV4, ipRxyz, iRout, nip +logical(kind=iwp) :: ABeq(3) +character(len=80) :: Label + +#include "macros.fh" +unused_var(ZInv) +unused_var(lOper) +unused_var(iChO) +unused_var(iStabM) +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 190 +iPrint = nPrint(iRout) +ABeq(:) = A == RB + +nip = 1 +ipAxyz = nip +nip = nip+nZeta*3*nHer*(la+3) +ipBxyz = nip +nip = nip+nZeta*3*nHer*(lb+3) +ipRxyz = nip +nip = nip+nZeta*3*nHer*(nOrdOp-3) +ipQxyz = nip +nip = nip+nZeta*3*(la+3)*(lb+3)*(nOrdOp-3) +iprV2 = nip +nip = nip+nZeta*3*(la+1)*(lb+1)*2 +iprV4 = nip +nip = nip+nZeta*3*(la+1)*(lb+1) +ipA = nip +nip = nip+nZeta +ipB = nip +nip = nip+nZeta +if (nip-1 > nArr*nZeta) then + call WarningMessage(2,'MVeInt: nip-1 > nArr*nZeta') + write(u6,*) ' nArr is Wrong! ',nip-1,' > ',nArr*nZeta + write(u6,*) ' Abend in MVeInt' + call Abend() +end if + +if (iPrint >= 49) then + call RecPrt(' In MVeInt: A',' ',A,1,3) + call RecPrt(' In MVeInt: RB',' ',RB,1,3) + call RecPrt(' In MVeInt: Ccoor',' ',Ccoor,1,3) + call RecPrt(' In MVeInt: P',' ',P,nZeta,3) + call RecPrt(' In MVeInt: Zeta',' ',Zeta,nZeta,1) + call RecPrt(' In MVeInt: Roots',' ',HerR(iHerR(nHer)),nHer,1) + write(u6,*) ' In MVeInt: la,lb=',la,lb +end if + +! Compute the cartesian values of the basis functions angular part + +call CrtCmp(Zeta,P,nZeta,A,Array(ipAxyz),la+2,HerR(iHerR(nHer)),nHer,ABeq) +call CrtCmp(Zeta,P,nZeta,RB,Array(ipBxyz),lb+2,HerR(iHerR(nHer)),nHer,ABeq) + +! Compute the contribution from the multipole moment operator + +ABeq(:) = .false. +call CrtCmp(Zeta,P,nZeta,Ccoor,Array(ipRxyz),nOrdOp-4,HerR(iHerR(nHer)),nHer,ABeq) + +! Compute the cartesian components for the multipole moment +! integrals. The integrals are factorized into components. + +call Assmbl(Array(ipQxyz),Array(ipAxyz),la+2,Array(ipRxyz),nOrdOp-4,Array(ipBxyz),lb+2,nZeta,HerW(iHerW(nHer)),nHer) + +! Compute the cartesian components for the mass-velocity integrals. +! The kinetic energy components are linear combinations of overlap components. + +ipAOff = ipA-1 +do iBeta=1,nBeta + Array(ipAOff+1:ipAOff+nAlpha) = Alpha + ipAOff = ipAOff+nAlpha +end do + +ipBOff = ipB-1 +do iBeta=1,nBeta + Array(ipBOff+1:ipBOff+nAlpha) = Beta(iBeta) + ipBOff = ipBOff+nAlpha +end do + +call MVe(Array(iprV2),Array(iprV4),Array(ipQxyz),la,lb,Array(ipA),Array(ipB),nZeta) + +! Combine the cartesian components to the full one electron integral. + +call CmbnMV(Array(ipQxyz),nZeta,la,lb,nOrdOp-4,Zeta,rKappa,rFinal,nComp,Array(iprV2),Array(iprV4)) + +if (iPrint >= 99) then + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb) + write(Label,'(A,I2,A,I2,A)') 'Mass-Velocity(',ia,',',ib,')' + call RecPrt(Label,' ',rFinal(:,ia,ib,:),nZeta,nComp) + end do + end do +end if + +return + +end subroutine MVeInt diff -Nru openmolcas-22.02/src/oneint_util/mvemem.f openmolcas-22.10/src/oneint_util/mvemem.f --- openmolcas-22.02/src/oneint_util/mvemem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/mvemem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine MVeMem( -#define _CALLING_ -#include "mem_interface.fh" - &) -#include "mem_interface.fh" -* - nHer=(la+lb+lr+2)/2 - Mem = 3*nHer*(la+3) + - & 3*nHer*(lb+3) + - & 3*nHer*(lr-3) + - & 3*(la+3)*(lb+3)*(lr-3) + - & 3*(la+1)*(lb+1)*2 + - & 3*(la+1)*(lb+1) + - & 1 + 1 -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/mvemem.F90 openmolcas-22.10/src/oneint_util/mvemem.F90 --- openmolcas-22.02/src/oneint_util/mvemem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/mvemem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,29 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine MVeMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" + +nHer = (la+lb+lr+2)/2 +Mem = 3*nHer*(la+3)+3*nHer*(lb+3)+3*nHer*(lr-3)+3*(la+3)*(lb+3)*(lr-3)+3*(la+1)*(lb+1)*2+3*(la+1)*(lb+1)+1+1 + +return + +end subroutine MVeMem diff -Nru openmolcas-22.02/src/oneint_util/naint.f openmolcas-22.10/src/oneint_util/naint.f --- openmolcas-22.02/src/oneint_util/naint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/naint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,292 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine NAInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of nuclear attraction * -* integrals. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, Sweden, January 1991 * -************************************************************************ - Use Basis_Info - use Center_Info - use Gateway_global, only: Primitive_Pass - use DKH_Info, only: DKroll - Implicit Real*8 (A-H,O-Z) -* Used for normal nuclear attraction integrals - External TNAI, Fake, XCff2D, XRys2D -* Used for finite nuclei - External TERI, ModU2, vCff2D, vRys2D -#include "real.fh" -#include "oneswi.fh" -#include "print.fh" - -#include "int_interface.fh" - -*-----Local arrys - Real*8 C(3), TC(3), Coora(3,4), Coori(3,4), CoorAC(3,2) - Logical EQ, NoSpecial, No3Cnt, lECP - Integer iAnga(4), iDCRT(0:7) - Character ChOper(0:7)*3 - Data ChOper/'E ','x ','y ','xy ','z ','xz ','yz ','xyz'/ -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - nabSz(ixyz) = (ixyz+1)*(ixyz+2)*(ixyz+3)/6 - 1 -* - iRout = 151 - iPrint = nPrint(iRout) -* - call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) -* - lECP = .False. - DO i = 1, nCnttp - lECP = lECP .or. dbsc(i)%ECP - End Do - lc=0 - ld=0 - iAnga(1) = la - iAnga(2) = lb - iAnga(3) = lc - iAnga(4) = ld - call dcopy_(3,A,1,Coora(1,1),1) - call dcopy_(3,RB,1,Coora(1,2),1) - call dcopy_(2*3,Coora,1,Coori,1) - mabMin = nabSz(Max(la,lb)-1)+1 - mabMax = nabSz(la+lb) - No3Cnt = .FALSE. - If (EQ(A,RB)) Then - mabMin=nabSz(la+lb-1)+1 - Else If (NDDO) Then - No3Cnt = .TRUE. - End If -* -* Compute FLOPs and size of work array which Hrr will use. -* - Call mHrr(la,lb,nFLOP,nMem) -* -* Find center to accumulate angular momentum on. (HRR) -* - If (la.ge.lb) Then - call dcopy_(3,A,1,CoorAC(1,1),1) - Else - call dcopy_(3,RB,1,CoorAC(1,1),1) - End If -* -* Modify Zeta if the two-electron code will be used! -* - If (Nuclear_Model.eq.Gaussian_Type .or. - & Nuclear_Model.eq.mGaussian_Type) Then - Do iZeta = 1, nZeta - rKappa(iZeta)=rKappa(iZeta)*(TwoP54/Zeta(iZeta)) - End Do - End If -* -* Loop over nuclear centers. -* - kdc = 0 - Do kCnttp = 1, nCnttp - If (kCnttp/=1) kdc = kdc + dbsc(kCnttp-1)%nCntr -* -* Change nuclear charge if this is a relativistic ECP-case. This -* is used for the DKH transformation (see dkh_util/dkrelint.f)! -* - If (DKroll.and.Primitive_Pass.and.lECP) Then - Q_Nuc=DBLE(dbsc(kCnttp)%AtmNr) - Else - Q_Nuc=dbsc(kCnttp)%Charge - End If - - If (kCnttp==iCnttp_Dummy) Cycle - If (Q_Nuc.eq.Zero) Cycle - Do 101 kCnt = 1, dbsc(kCnttp)%nCntr - C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) - If (iPrint.ge.99) Call RecPrt('C',' ',C,1,3) -* -*-----------Find the DCR for M and S -* - Call DCR(LmbdT,iStabM,nStabM, - & dc(kdc+kCnt)%iStab ,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) - Fact = DBLE(nStabM) / DBLE(LmbdT) -* - If (iPrint.ge.99) Then - Write (6,*) ' m =',nStabM - Write (6,'(9A)') '(M)=',(ChOper(iStabM(ii)), - & ii = 0, nStabM-1) - Write (6,*) ' s =',dc(kdc+kCnt)%nStab - Write (6,'(9A)') '(S)=',(ChOper(dc(kdc+kCnt)%iStab(ii)), - & ii = 0, dc(kdc+kCnt)%nStab-1) - Write (6,*) ' LambdaT=',LmbdT - Write (6,*) ' t =',nDCRT - Write (6,'(9A)') '(T)=',(ChOper(iDCRT(ii)), - & ii = 0, nDCRT-1) - End If - -* - Do 102 lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),C,TC) -* switch (only two center NA matrix...) - If (No3Cnt .AND. .NOT.(EQ(A,TC).OR.EQ(RB,TC))) Go To 102 -* switch - call dcopy_(3,TC,1,CoorAC(1,2),1) - call dcopy_(3,TC,1,Coori(1,3),1) - call dcopy_(3,TC,1,Coori(1,4),1) - call dcopy_(3,TC,1,Coora(1,3),1) - call dcopy_(3,TC,1,Coora(1,4),1) -* * -************************************************************************ -* * -* Compute integrals with the Rys quadrature. -* * -************************************************************************ -* * - nT = nZeta -* * -************************************************************************ -* * - If (Nuclear_Model.eq.Gaussian_Type) Then -* -* Gaussian nuclear charge distribution -* - NoSpecial=.False. - Eta=dbsc(kCnttp)%ExpNuc - EInv=One/Eta - rKappcd=TwoP54/Eta -* Tag on the normalization - rKappcd=rKappcd*(Eta/Pi)**(Three/Two) -* s-type function - mcdMin=0 - mcdMax=0 - Call Rys(iAnga,nT,Zeta,ZInv,nZeta, - & [Eta],[EInv],1,P,nZeta, - & TC,1,rKappa,[rKappcd],Coori,Coora,CoorAC, - & mabmin,mabmax,mcdMin,mcdMax, - & Array,nArr*nZeta, - & TERI,ModU2,vCff2D,vRys2D,NoSpecial) -* * -************************************************************************ -* * - Else If (Nuclear_Model.eq.mGaussian_Type) Then -* -* Modified Gaussian nuclear charge distribution -* - NoSpecial=.False. - Eta=dbsc(kCnttp)%ExpNuc - EInv=One/Eta - rKappcd=TwoP54/Eta -* Tag on the normalization - rKappcd=rKappcd*(Eta/Pi)**(Three/Two) - & /(One+Three*dbsc(kCnttp)%w_mGauss/(Two*Eta)) -* s type function - mcdMin=0 - mcdMax=0 - Call Rys(iAnga,nT,Zeta,ZInv,nZeta, - & [Eta],[EInv],1,P,nZeta, - & TC,1,rKappa,[rKappcd],Coori,Coora,CoorAC, - & mabmin,mabmax,mcdMin,mcdMax, - & Array,nArr*nZeta, - & TERI,ModU2,vCff2D,vRys2D,NoSpecial) -* -* d type function w*(x**2+y**2+z**2) - If (dbsc(kCnttp)%w_mGauss.gt.0.0D0) Then - rKappcd = rKappcd*dbsc(kCnttp)%w_mGauss - iAnga(3)=2 - mcdMin=nabSz(2+ld-1)+1 - mcdMax = nabSz(2+ld) -* tweak the pointers - ipOff = 1 + nZeta * (la+1)*(la+2)/2 - & * (lb+1)*(lb+2)/2 - mArr = nArr - (la+1)*(la+2)/2*(lb+1)*(lb+2)/2 - Call Rys(iAnga,nT,Zeta,ZInv,nZeta, - & [Eta],[EInv],1,P,nZeta, - & TC,1,rKappa,[rKappcd],Coori,Coora,CoorAC, - & mabMin,mabMax,mcdMin,mcdMax, - & Array(ipOff),mArr*nZeta, - & TERI,ModU2,vCff2D,vRys2D,NoSpecial) - iAnga(3)=0 -* -* Add the s and d contributions together! -* - Call Assemble_mGauss(Array,Array(ipOff), - & nZeta*(mabMax-mabMin+1)) - End If -* * -************************************************************************ -* * - Else If (Nuclear_Model.eq.Point_Charge) Then -* -* Point-like nuclear charge distribution -* - NoSpecial=.True. - Eta=One - EInv=One - rKappcd=One - mcdMin=0 - mcdMax=0 - Call Rys(iAnga,nT,Zeta,ZInv,nZeta, - & [Eta],[EInv],1,P,nZeta, - & TC,1,rKappa,[rKappcd],Coori,Coora,CoorAC, - & mabMin,mabMax,mcdMin,mcdMax, - & Array,nArr*nZeta, - & TNAI,Fake,XCff2D,XRys2D,NoSpecial) - End If -* * -************************************************************************ -* * -* -*--------------Use the HRR to compute the required primitive integrals. -* - Call HRR(la,lb,A,RB,Array,nZeta,nMem,ipIn) -* -*--------------Accumulate contributions to the symmetry adapted operator -* - nOp = NrOpr(iDCRT(lDCRT)) - Call SymAdO(Array(ipIn),nZeta,la,lb,nComp,Final,nIC, - & nOp ,lOper,iChO,-Fact*Q_Nuc) - If (iPrint.ge.99) Then - Write (6,*) Fact*Q_Nuc - Call RecPrt('NaInt: Array(ipIn)',' ',Array(ipIn), - & nZeta,nElem(la)*nElem(lb)*nComp) - Call RecPrt('NaInt: Final',' ',Final, - & nZeta,nElem(la)*nElem(lb)*nIC) - End If -* - 102 Continue - 101 Continue - End Do -* - If (Nuclear_Model.eq.Gaussian_Type .or. - & Nuclear_Model.eq.mGaussian_Type) Then - Do iZeta = 1, nZeta - rKappa(iZeta)=rKappa(iZeta)/(TwoP54/Zeta(iZeta)) - End Do - End If -* -* Call GetMem(' Exit NAInt','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Alpha) - Call Unused_real_array(Beta) - Call Unused_integer(nHer) - Call Unused_real_array(CCoor) - Call Unused_integer(nOrdOp) - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/naint.F90 openmolcas-22.10/src/oneint_util/naint.F90 --- openmolcas-22.02/src/oneint_util/naint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/naint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,256 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine NAInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of nuclear attraction * +! integrals. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, Sweden, January 1991 * +!*********************************************************************** + +use Basis_Info, only: dbsc, Gaussian_Type, iCnttp_Dummy, mGaussian_Type, nCnttp, Nuclear_Model, Point_Charge +use Center_Info, only: dc +use Gateway_global, only: Primitive_Pass +use DKH_Info, only: DKroll +use Index_Functions, only: nTri3_Elem1, nTri_Elem1 +use Constants, only: Zero, One, Two, Three, OneHalf, Pi, TwoP54 +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "oneswi.fh" +#include "print.fh" +integer(kind=iwp) :: i, iAnga(4), iDCRT(0:7), ii, ipIn, ipOff, iPrint, iRout, kCnt, kCnttp, kdc, lc, ld, lDCRT, LmbdT, mabMax, & + mabMin, mArr, mcdMax, mcdMin, nDCRT, nFLOP, nMem, nOp, nT +real(kind=wp) :: C(3), Coora(3,4), CoorAC(3,2), Coori(3,4), EInv, Eta, Fact, Q_Nuc, rKappcd, TC(3) +logical(kind=iwp) :: lECP, No3Cnt, NoSpecial +character(len=*), parameter :: ChOper(0:7) = ['E ','x ','y ','xy ','z ','xz ','yz ','xyz'] +integer(kind=iwp), external :: NrOpr +logical(kind=iwp), external :: EQ +! Used for normal nuclear attraction integrals: TNAI, Fake, XCff2D, XRys2D +! Used for finite nuclei: TERI, ModU2, vCff2D, vRys2D +external :: Fake, ModU2, TERI, TNAI, vCff2D, vRys2D, XCff2D, XRys2D + +#include "macros.fh" +unused_var(Alpha) +unused_var(Beta) +unused_var(nHer) +unused_var(Ccoor) +unused_var(nOrdOp) +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 151 +iPrint = nPrint(iRout) + +rFinal(:,:,:,:) = Zero + +lECP = .false. +do i=1,nCnttp + lECP = lECP .or. dbsc(i)%ECP +end do +lc = 0 +ld = 0 +iAnga(1) = la +iAnga(2) = lb +iAnga(3) = lc +iAnga(4) = ld +Coora(:,1) = A +Coora(:,2) = RB +Coori(:,1:2) = Coora(:,1:2) +mabMin = nTri3_Elem1(max(la,lb)-1) +mabMax = nTri3_Elem1(la+lb)-1 +No3Cnt = .false. +if (EQ(A,RB)) then + mabMin = nTri3_Elem1(la+lb-1) +else if (NDDO) then + No3Cnt = .true. +end if + +! Compute FLOPs and size of work array which Hrr will use. + +call mHrr(la,lb,nFLOP,nMem) + +! Find center to accumulate angular momentum on. (HRR) + +if (la >= lb) then + CoorAC(:,1) = A +else + CoorAC(:,1) = RB +end if + +! Modify Zeta if the two-electron code will be used! + +if ((Nuclear_Model == Gaussian_Type) .or. (Nuclear_Model == mGaussian_Type)) then + rKappa(:) = rKappa*(TwoP54/Zeta) +end if + +! Loop over nuclear centers. + +kdc = 0 +do kCnttp=1,nCnttp + if (kCnttp > 1) kdc = kdc+dbsc(kCnttp-1)%nCntr + + ! Change nuclear charge if this is a relativistic ECP-case. This + ! is used for the DKH transformation (see dkh_util/dkrelint_dp)! + + if (DKroll .and. Primitive_Pass .and. lECP) then + Q_Nuc = real(dbsc(kCnttp)%AtmNr,kind=wp) + else + Q_Nuc = dbsc(kCnttp)%Charge + end if + + if (kCnttp == iCnttp_Dummy) cycle + if (Q_Nuc == Zero) cycle + do kCnt=1,dbsc(kCnttp)%nCntr + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + if (iPrint >= 99) call RecPrt('C',' ',C,1,3) + + ! Find the DCR for M and S + + call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) + Fact = real(nStabM,kind=wp)/real(LmbdT,kind=wp) + + if (iPrint >= 99) then + write(u6,*) ' m =',nStabM + write(u6,'(9A)') '(M)=',(ChOper(iStabM(ii)),ii=0,nStabM-1) + write(u6,*) ' s =',dc(kdc+kCnt)%nStab + write(u6,'(9A)') '(S)=',(ChOper(dc(kdc+kCnt)%iStab(ii)),ii=0,dc(kdc+kCnt)%nStab-1) + write(u6,*) ' LambdaT=',LmbdT + write(u6,*) ' t =',nDCRT + write(u6,'(9A)') '(T)=',(ChOper(iDCRT(ii)),ii=0,nDCRT-1) + end if + + do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),C,TC) + ! switch (only two center NA matrix...) + if (No3Cnt .and. (.not. (EQ(A,TC) .or. EQ(RB,TC)))) cycle + ! switch + CoorAC(:,2) = TC + Coori(:,3) = TC + Coori(:,4) = TC + Coora(:,3) = TC + Coora(:,4) = TC + ! * + !***************************************************************** + ! * + ! Compute integrals with the Rys quadrature. + ! * + !***************************************************************** + ! * + nT = nZeta + ! * + !***************************************************************** + ! * + if (Nuclear_Model == Gaussian_Type) then + + ! Gaussian nuclear charge distribution + + NoSpecial = .false. + Eta = dbsc(kCnttp)%ExpNuc + EInv = One/Eta + rKappcd = TwoP54/Eta + ! Tag on the normalization + rKappcd = rKappcd*(Eta/Pi)**OneHalf + ! s-type function + mcdMin = 0 + mcdMax = 0 + call Rys(iAnga,nT,Zeta,ZInv,nZeta,[Eta],[EInv],1,P,nZeta,TC,1,rKappa,[rKappcd],Coori,Coora,CoorAC,mabmin,mabmax,mcdMin, & + mcdMax,Array,nArr*nZeta,TERI,ModU2,vCff2D,vRys2D,NoSpecial) + ! * + !*************************************************************** + ! * + else if (Nuclear_Model == mGaussian_Type) then + + ! Modified Gaussian nuclear charge distribution + + NoSpecial = .false. + Eta = dbsc(kCnttp)%ExpNuc + EInv = One/Eta + rKappcd = TwoP54/Eta + ! Tag on the normalization + rKappcd = rKappcd*(Eta/Pi)**OneHalf/(One+Three*dbsc(kCnttp)%w_mGauss/(Two*Eta)) + ! s type function + mcdMin = 0 + mcdMax = 0 + call Rys(iAnga,nT,Zeta,ZInv,nZeta,[Eta],[EInv],1,P,nZeta,TC,1,rKappa,[rKappcd],Coori,Coora,CoorAC,mabmin,mabmax,mcdMin, & + mcdMax,Array,nArr*nZeta,TERI,ModU2,vCff2D,vRys2D,NoSpecial) + + ! d type function w*(x**2+y**2+z**2) + if (dbsc(kCnttp)%w_mGauss > Zero) then + rKappcd = rKappcd*dbsc(kCnttp)%w_mGauss + iAnga(3) = 2 + mcdMin = nTri3_Elem1(2+ld-1) + mcdMax = nTri3_Elem1(2+ld)-1 + ! tweak the pointers + ipOff = 1+nZeta*(la+1)*(la+2)/2*(lb+1)*(lb+2)/2 + mArr = nArr-(la+1)*(la+2)/2*(lb+1)*(lb+2)/2 + call Rys(iAnga,nT,Zeta,ZInv,nZeta,[Eta],[EInv],1,P,nZeta,TC,1,rKappa,[rKappcd],Coori,Coora,CoorAC,mabMin,mabMax,mcdMin, & + mcdMax,Array(ipOff),mArr*nZeta,TERI,ModU2,vCff2D,vRys2D,NoSpecial) + iAnga(3) = 0 + + ! Add the s and d contributions together! + + call Assemble_mGauss(Array,Array(ipOff),nZeta*(mabMax-mabMin+1)) + end if + ! * + !*************************************************************** + ! * + else if (Nuclear_Model == Point_Charge) then + + ! Point-like nuclear charge distribution + + NoSpecial = .true. + Eta = One + EInv = One + rKappcd = One + mcdMin = 0 + mcdMax = 0 + call Rys(iAnga,nT,Zeta,ZInv,nZeta,[Eta],[EInv],1,P,nZeta,TC,1,rKappa,[rKappcd],Coori,Coora,CoorAC,mabMin,mabMax,mcdMin, & + mcdMax,Array,nArr*nZeta,TNAI,Fake,XCff2D,XRys2D,NoSpecial) + end if + ! * + !***************************************************************** + ! * + ! + ! Use the HRR to compute the required primitive integrals. + + call HRR(la,lb,A,RB,Array,nZeta,nMem,ipIn) + + ! Accumulate contributions to the symmetry adapted operator + + nOp = NrOpr(iDCRT(lDCRT)) + call SymAdO(Array(ipIn),nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,-Fact*Q_Nuc) + if (iPrint >= 99) then + write(u6,*) Fact*Q_Nuc + call RecPrt('NaInt: Array(ipIn)',' ',Array(ipIn),nZeta,nTri_Elem1(la)*nTri_Elem1(lb)*nComp) + call RecPrt('NaInt: rFinal',' ',rFinal,nZeta,nTri_Elem1(la)*nTri_Elem1(lb)*nIC) + end if + + end do + end do +end do + +if ((Nuclear_Model == Gaussian_Type) .or. (Nuclear_Model == mGaussian_Type)) then + rKappa = rKappa/(TwoP54/Zeta) +end if + +return + +end subroutine NAInt diff -Nru openmolcas-22.02/src/oneint_util/naint_giao.f openmolcas-22.10/src/oneint_util/naint_giao.f --- openmolcas-22.02/src/oneint_util/naint_giao.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/naint_giao.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,280 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991,1995,2002, Roland Lindh * -************************************************************************ - SubRoutine NAInt_GIAO(Alpha,nAlpha,Beta, nBeta,Zeta,ZInv,rKappa,P, - & Final,nZeta,nIC,nComp,la,lb,A,RB,nRys, - & Array,nArr,Ccoor,nOrdOp,lOper,iChO, - & iStabM,nStabM, - & PtChrg,nGrid,iAddPot) -************************************************************************ -* * -* Object: kernel routine for the computation of electric field * -* integrals. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, Sweden, January '91 * -* * -* Modified for explicit code, R. Lindh, February '95. * -* * -* Modified for GIAOs, R. Lindh, June 2002, Tokyo, Japan. * -************************************************************************ - Use Basis_Info - use Center_Info - Implicit Real*8 (A-H,O-Z) - External TNAI, Fake, XCff2D, XRys2D - External TERI, MODU2, vCff2D, vRys2D -#include "real.fh" -#include "print.fh" - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,nIC), - & Zeta(nZeta), ZInv(nZeta), Alpha(nAlpha), Beta(nBeta), - & rKappa(nZeta), P(nZeta,3), A(3), RB(3), - & Array(nZeta*nArr), Ccoor(3) - Integer iStabM(0:nStabM-1), iDCRT(0:7), - & lOper(nComp), iChO(nComp) -*---- Local arrays - Real*8 C(3), TC(3), Coori(3,4), CoorAC(3,2) - Logical EQ, NoSpecial - Integer iAnga_EF(4), iAnga_NA(4) -* * -************************************************************************ -* * -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - nabSz(ixyz) = (ixyz+1)*(ixyz+2)*(ixyz+3)/6 - 1 -* * -************************************************************************ -* * - iRout = 200 - iPrint = nPrint(iRout) -* - call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) -* - call dcopy_(3, A,1,Coori(1,1),1) - call dcopy_(3,RB,1,Coori(1,2),1) -* - iAnga_EF(1) = la - iAnga_EF(2) = lb - iAnga_NA(1) = la - iAnga_NA(2) = lb - mabMin=nabSz(Max(la,lb)-1)+1 - If (EQ(A,RB)) mabMin=nabSz(la+lb-1)+1 - mabMax=nabSz(la+lb) - lab=(mabMax-mabMin+1) - kab=nElem(la)*nElem(lb) -* - iAnga_EF(3) = nOrdOp - iAnga_EF(4) = 0 - mcdMin_EF=nabSz(nOrdOp-1)+1 - mcdMax_EF=nabSz(nOrdop) - lcd_EF=(mcdMax_EF-mcdMin_EF+1) - labcd_EF=lab*lcd_EF -* - iAnga_NA(3) = nOrdOp-1 - iAnga_NA(4) = 0 - mcdMin_NA=nabSz(nOrdOp-2)+1 - mcdMax_NA=nabSz(nOrdop-1) - lcd_NA=(mcdMax_NA-mcdMin_NA+1) - labcd_NA=lab*lcd_NA -* -*---- Compute Flop's and size of work array which HRR will Use. -* - Call mHRR(la,lb,nFLOP,nMem) - nHRR=Max(labcd_EF,labcd_NA,lcd_EF*nMem,lcd_NA*nMem) -* -*---- Distribute the work array -* - mArr = nArr - labcd_EF - nHRR - ipEFInt = 1 - ipRys = ipEFInt + nZeta*labcd_EF - ipHRR = ipRys + nZeta*mArr -* -*---- Find center to accumulate angular momentum on. (HRR) -* - If (la.ge.lb) Then - call dcopy_(3, A,1,CoorAC(1,1),1) - Else - call dcopy_(3,RB,1,CoorAC(1,1),1) - End If -* - llOper = lOper(1) - Do 90 iComp = 2, nComp - llOper = iOr(llOper,lOper(iComp)) - 90 Continue -* -* Modify Zeta if the two-electron code will be used! -* - If (Nuclear_Model.eq.Gaussian_Type) Then - Do iZeta = 1, nZeta - rKappa(iZeta)=rKappa(iZeta)*(TwoP54/Zeta(iZeta)) - End Do - End If -* * -************************************************************************ -* * -* Loop over nuclear centers -* - kdc = 0 - Do 100 kCnttp = 1, nCnttp - If (dbsc(kCnttp)%Charge.eq.Zero) Go To 111 - Do 101 kCnt = 1, dbsc(kCnttp)%nCntr - C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) - If (iPrint.ge.99) Call RecPrt('C',' ',C,1,3) -* -*-----------Find the DCR for M and S -* - Call DCR(LmbdT,iStabM,nStabM, - & dc(kdc+kCnt)%iStab, dc(kdc+kCnt)%nStab, - & iDCRT,nDCRT) - Fact = DBLE(nStabM) / DBLE(LmbdT) -* - Do 102 lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),C,TC) - call dcopy_(3,TC,1,CoorAC(1,2),1) - call dcopy_(3,TC,1, Coori(1,3),1) - call dcopy_(3,TC,1, Coori(1,4),1) -* * -************************************************************************ -* * -*------------- Compute integrals with the Rys-Gauss quadrature. * -* * -************************************************************************ -*1) * -* Do the EF integrals -* - nT=nZeta - If (Nuclear_Model.eq.Gaussian_Type) Then - NoSpecial=.False. - Eta=dbsc(kCnttp)%ExpNuc - EInv=One/Eta - rKappcd=TwoP54/Eta -* Tag on the normalization - rKappcd=rKappcd*(Eta/Pi)**(Three/Two) - Call Rys(iAnga_EF,nT,Zeta,ZInv,nZeta, - & [Eta],[EInv],1,P,nZeta,TC,1, - & rKappa,[rKappcd],Coori,Coori,CoorAC, - & mabMin,mabMax,mcdMin_EF,mcdMax_EF, - & Array(ipRys),mArr*nZeta, - & TERI,MODU2,vCff2D,vRys2D,NoSpecial) - Else If (Nuclear_Model.eq.Point_Charge) Then - NoSpecial=.True. - Call Rys(iAnga_EF,nT,Zeta,ZInv,nZeta, - & [One],[One],1,P,nZeta,TC,1, - & rKappa,[One],Coori,Coori,CoorAC, - & mabMin,mabMax,mcdMin_EF,mcdMax_EF, - & Array(ipRys),mArr*nZeta, - & TNAI,Fake,XCff2D,XRys2D,NoSpecial) - Else -*...more to come... - End If -* -*------------- The integrals are now ordered as ijkl,e,f -* -* a) Change the order to f,ijkl,e -* b) Unfold e to ab, f,ijkl,ab -* c) Change the order back to ijkl,ab,f -* -*a)----------- -* - Call DGetMO(Array(ipRys),nZeta*lab,nZeta*lab,lcd_EF, - & Array(ipHRR),lcd_EF) -* -*b)----------- Use the HRR to unfold e to ab -* - Call HRR(la,lb,A,RB,Array(ipHRR),lcd_EF*nZeta,nMem,ipIn) - ip3=ipHRR-1+ipIn -* -*c)----------- -* - Call DGetMO(Array(ip3),lcd_EF,lcd_EF,nZeta*kab, - & Array(ipEFInt),nZeta*kab) -* -* Stored as nZeta,iElem,jElem,iComp -* * -************************************************************************ -*2) * -* Do the NA integrals -* - If (Nuclear_Model.eq.Gaussian_Type) Then - NoSpecial=.False. - Eta=dbsc(kCnttp)%ExpNuc - EInv=One/Eta - rKappcd=TwoP54/Eta -* Tag on the normalization - rKappcd=rKappcd*(Eta/Pi)**(Three/Two) - Call Rys(iAnga_NA,nT,Zeta,ZInv,nZeta, - & [Eta],[EInv],1,P,nZeta,TC,1, - & rKappa,[rKappcd],Coori,Coori,CoorAC, - & mabMin,mabMax,0,0, - & Array(ipRys),mArr*nZeta, - & TERI,MODU2,vCff2D,vRys2D,NoSpecial) - Else If (Nuclear_Model.eq.Point_Charge) Then - NoSpecial=.True. - Call Rys(iAnga_NA,nT,Zeta,ZInv,nZeta, - & [One],[One],1,P,nZeta,TC,1, - & rKappa,[One],Coori,Coori,CoorAC, - & mabMin,mabMax,0,0, - & Array(ipRys),mArr*nZeta, - & TNAI,Fake,XCff2D,XRys2D,NoSpecial) - Else -*...more to come... - End If -* -*--------------Use the HRR to compute the required primitive integrals -* - Call HRR(la,lb,A,RB,Array(ipRys),nZeta,nMem,ipNAInt) -* * -************************************************************************ -* * -* Assemble dV/dB -* - Call Assemble_dVdB(Array(ipNAInt), - & Array(ipEFInt), - & nZeta,la,lb,A,RB,TC) -* -* * -************************************************************************ -* * -*------- Accumulate contributions -* - nOp = NrOpr(iDCRT(lDCRT)) - Call SymAdO(Array(ipEFInt),nZeta,la,lb,nComp,Final,nIC, - & nOp,lOper,iChO,-Fact*dbsc(kCnttp)%Charge) -* - 102 Continue - 101 Continue - 111 kdc = kdc + dbsc(kCnttp)%nCntr - 100 Continue -* * -************************************************************************ -* * - If (Nuclear_Model.eq.Gaussian_Type) Then - Do iZeta = 1, nZeta - rKappa(iZeta)=rKappa(iZeta)*(TwoP54/Zeta(iZeta)) - End Do - End If -* * -************************************************************************ -* * -* Call GetMem(' Exit EFInt','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Alpha) - Call Unused_real_array(Beta) - Call Unused_integer(nRys) - Call Unused_real_array(Ccoor) - Call Unused_real(PtChrg) - Call Unused_integer(nGrid) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/naint_giao.F90 openmolcas-22.10/src/oneint_util/naint_giao.F90 --- openmolcas-22.02/src/oneint_util/naint_giao.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/naint_giao.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,246 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991,1995,2002, Roland Lindh * +!*********************************************************************** + +subroutine NAInt_GIAO( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of electric field * +! integrals. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, Sweden, January '91 * +! * +! Modified for explicit code, R. Lindh, February '95. * +! * +! Modified for GIAOs, R. Lindh, June 2002, Tokyo, Japan. * +!*********************************************************************** + +use Basis_Info, only: dbsc, Gaussian_Type, nCnttp, Nuclear_Model, Point_Charge +use Center_Info, only: dc +use Index_Functions, only: nTri3_Elem1, nTri_Elem1 +use Constants, only: Zero, One, OneHalf, Pi, TwoP54 +use Definitions, only: wp, iwp + +implicit none +#include "int_interface.fh" +#include "print.fh" +integer(kind=iwp) :: iAnga_EF(4), iAnga_NA(4), iComp, iDCRT(0:7), ip3, ipEFInt, ipHRR, ipIn, ipNAInt, iPrint, ipRys, iRout, kab, & + kCnt, kCnttp, kdc, lab, labcd_EF, labcd_NA, lcd_EF, lcd_NA, lDCRT, llOper, LmbdT, mabMax, mabMin, mArr, & + mcdMax_EF, mcdMax_NA, mcdMin_EF, mcdMin_NA, nDCRT, nFLOP, nHRR, nMem, nOp, nT +real(kind=wp) :: C(3), CoorAC(3,2), Coori(3,4), EInv, Eta, Fact, rKappcd, TC(3) +logical(kind=iwp) :: NoSpecial +integer(kind=iwp), external :: NrOpr +logical(kind=iwp), external :: EQ +external :: Fake, MODU2, TERI, TNAI, vCff2D, vRys2D, XCff2D, XRys2D + +#include "macros.fh" +unused_var(Alpha) +unused_var(Beta) +unused_var(nHer) +unused_var(Ccoor) +unused_var(PtChrg) +unused_var(iAddPot) +! * +!*********************************************************************** +! * +iRout = 200 +iPrint = nPrint(iRout) + +rFinal(:,:,:,:) = Zero + +Coori(:,1) = A +Coori(:,2) = RB + +iAnga_EF(1) = la +iAnga_EF(2) = lb +iAnga_NA(1) = la +iAnga_NA(2) = lb +mabMin = nTri3_Elem1(max(la,lb)-1) +if (EQ(A,RB)) mabMin = nTri3_Elem1(la+lb-1) +mabMax = nTri3_Elem1(la+lb)-1 +lab = (mabMax-mabMin+1) +kab = nTri_Elem1(la)*nTri_Elem1(lb) + +iAnga_EF(3) = nOrdOp +iAnga_EF(4) = 0 +mcdMin_EF = nTri3_Elem1(nOrdOp-1) +mcdMax_EF = nTri3_Elem1(nOrdop)-1 +lcd_EF = (mcdMax_EF-mcdMin_EF+1) +labcd_EF = lab*lcd_EF + +iAnga_NA(3) = nOrdOp-1 +iAnga_NA(4) = 0 +mcdMin_NA = nTri3_Elem1(nOrdOp-2) +mcdMax_NA = nTri3_Elem1(nOrdop-1)-1 +lcd_NA = (mcdMax_NA-mcdMin_NA+1) +labcd_NA = lab*lcd_NA + +! Compute Flop's and size of work array which HRR will Use. + +call mHRR(la,lb,nFLOP,nMem) +nHRR = max(labcd_EF,labcd_NA,lcd_EF*nMem,lcd_NA*nMem) + +! Distribute the work array + +mArr = nArr-labcd_EF-nHRR +ipEFInt = 1 +ipRys = ipEFInt+nZeta*labcd_EF +ipHRR = ipRys+nZeta*mArr + +! Find center to accumulate angular momentum on. (HRR) + +if (la >= lb) then + CoorAC(:,1) = A +else + CoorAC(:,1) = RB +end if + +llOper = lOper(1) +do iComp=2,nComp + llOper = ior(llOper,lOper(iComp)) +end do + +! Modify Zeta if the two-electron code will be used! + +if (Nuclear_Model == Gaussian_Type) then + rKappa = rKappa*(TwoP54/Zeta) +end if +! * +!*********************************************************************** +! * +! Loop over nuclear centers + +kdc = 0 +do kCnttp=1,nCnttp + if (kCnttp > 1) kdc = kdc+dbsc(kCnttp-1)%nCntr + if (dbsc(kCnttp)%Charge == Zero) cycle + do kCnt=1,dbsc(kCnttp)%nCntr + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + if (iPrint >= 99) call RecPrt('C',' ',C,1,3) + + ! Find the DCR for M and S + + call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) + Fact = real(nStabM,kind=wp)/real(LmbdT,kind=wp) + + do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),C,TC) + CoorAC(:,2) = TC + Coori(:,3) = TC + Coori(:,4) = TC + ! * + !***************************************************************** + ! * + !------- Compute integrals with the Rys-Gauss quadrature. * + ! * + !***************************************************************** + ! 1) * + ! Do the EF integrals + + nT = nZeta + if (Nuclear_Model == Gaussian_Type) then + NoSpecial = .false. + Eta = dbsc(kCnttp)%ExpNuc + EInv = One/Eta + rKappcd = TwoP54/Eta + ! Tag on the normalization + rKappcd = rKappcd*(Eta/Pi)**OneHalf + call Rys(iAnga_EF,nT,Zeta,ZInv,nZeta,[Eta],[EInv],1,P,nZeta,TC,1,rKappa,[rKappcd],Coori,Coori,CoorAC,mabMin,mabMax, & + mcdMin_EF,mcdMax_EF,Array(ipRys),mArr*nZeta,TERI,MODU2,vCff2D,vRys2D,NoSpecial) + else if (Nuclear_Model == Point_Charge) then + NoSpecial = .true. + call Rys(iAnga_EF,nT,Zeta,ZInv,nZeta,[One],[One],1,P,nZeta,TC,1,rKappa,[One],Coori,Coori,CoorAC,mabMin,mabMax,mcdMin_EF, & + mcdMax_EF,Array(ipRys),mArr*nZeta,TNAI,Fake,XCff2D,XRys2D,NoSpecial) + else + ! ...more to come... + end if + ! + ! The integrals are now ordered as ijkl,e,f + ! + ! a) Change the order to f,ijkl,e + ! b) Unfold e to ab, f,ijkl,ab + ! c) Change the order back to ijkl,ab,f + ! + ! a) + + call DGetMO(Array(ipRys),nZeta*lab,nZeta*lab,lcd_EF,Array(ipHRR),lcd_EF) + + ! b) Use the HRR to unfold e to ab + + call HRR(la,lb,A,RB,Array(ipHRR),lcd_EF*nZeta,nMem,ipIn) + ip3 = ipHRR-1+ipIn + + ! c) + + call DGetMO(Array(ip3),lcd_EF,lcd_EF,nZeta*kab,Array(ipEFInt),nZeta*kab) + + ! Stored as nZeta,iElem,jElem,iComp + ! * + !***************************************************************** + ! 2) * + ! Do the NA integrals + + if (Nuclear_Model == Gaussian_Type) then + NoSpecial = .false. + Eta = dbsc(kCnttp)%ExpNuc + EInv = One/Eta + rKappcd = TwoP54/Eta + ! Tag on the normalization + rKappcd = rKappcd*(Eta/Pi)**OneHalf + call Rys(iAnga_NA,nT,Zeta,ZInv,nZeta,[Eta],[EInv],1,P,nZeta,TC,1,rKappa,[rKappcd],Coori,Coori,CoorAC,mabMin,mabMax,0,0, & + Array(ipRys),mArr*nZeta,TERI,MODU2,vCff2D,vRys2D,NoSpecial) + else if (Nuclear_Model == Point_Charge) then + NoSpecial = .true. + call Rys(iAnga_NA,nT,Zeta,ZInv,nZeta,[One],[One],1,P,nZeta,TC,1,rKappa,[One],Coori,Coori,CoorAC,mabMin,mabMax,0,0, & + Array(ipRys),mArr*nZeta,TNAI,Fake,XCff2D,XRys2D,NoSpecial) + else + ! ...more to come... + end if + + ! Use the HRR to compute the required primitive integrals + + call HRR(la,lb,A,RB,Array(ipRys),nZeta,nMem,ipNAInt) + ! * + !***************************************************************** + ! * + ! Assemble dV/dB + + call Assemble_dVdB(Array(ipNAInt),Array(ipEFInt),nZeta,la,lb,A,RB,TC) + + ! * + !***************************************************************** + ! * + ! Accumulate contributions + + nOp = NrOpr(iDCRT(lDCRT)) + call SymAdO(Array(ipEFInt),nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,-Fact*dbsc(kCnttp)%Charge) + + end do + end do +end do +! * +!*********************************************************************** +! * +if (Nuclear_Model == Gaussian_Type) then + rKappa = rKappa*(TwoP54/Zeta) +end if +! * +!*********************************************************************** +! * + +return + +end subroutine NAInt_GIAO diff -Nru openmolcas-22.02/src/oneint_util/namem.f openmolcas-22.10/src/oneint_util/namem.f --- openmolcas-22.02/src/oneint_util/namem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/namem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,46 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine NAMem( -#define _CALLING_ -#include "mem_interface.fh" - &) - use Basis_Info -#include "mem_interface.fh" - Integer iAngV(4) -* -* * -************************************************************************ -* * - Call mHrr(la,lb,nFlop,nMem) -* - iAngV(1) = la - iAngV(2) = lb - iAngV(3) = lr - iAngV(4) = 0 - Call MemRys(iAngV,Mem) - nHer=(la+lb+lr+2)/2 - If (Nuclear_Model.eq.mGaussian_Type) Then -* - labcd = (la+1)*(la+2)/2 * (lb+1)*(lb+2)/2 -* - iAngV(3)=lr+2 - Call MemRys(iAngV,MemNA2) - Mem=Max(Mem,MemNA2) - nHer=(la+lb+lr+4)/2 - Mem=Mem+labcd - End If -* - Mem = Max(nMem,Mem) -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/namem.F90 openmolcas-22.10/src/oneint_util/namem.F90 --- openmolcas-22.02/src/oneint_util/namem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/namem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,52 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine NAMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Basis_Info, only: mGaussian_Type, Nuclear_Model +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: iAngV(4), labcd, MemNA2, nFlop, nMem + +! * +!*********************************************************************** +! * +call mHrr(la,lb,nFlop,nMem) + +iAngV(1) = la +iAngV(2) = lb +iAngV(3) = lr +iAngV(4) = 0 +call MemRys(iAngV,Mem) +nHer = (la+lb+lr+2)/2 +if (Nuclear_Model == mGaussian_Type) then + + labcd = (la+1)*(la+2)/2*(lb+1)*(lb+2)/2 + + iAngV(3) = lr+2 + call MemRys(iAngV,MemNA2) + Mem = max(Mem,MemNA2) + nHer = (la+lb+lr+4)/2 + Mem = Mem+labcd +end if + +Mem = max(nMem,Mem) + +return + +end subroutine NAMem diff -Nru openmolcas-22.02/src/oneint_util/namem_giao.f openmolcas-22.10/src/oneint_util/namem_giao.f --- openmolcas-22.02/src/oneint_util/namem_giao.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/namem_giao.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine NAMem_GIAO(nRys,MemNA_GIAO,la,lb,lr) -* - Integer iAngV(4) -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - nabSz(ixyz) = (ixyz+1)*(ixyz+2)*(ixyz+3)/6 - 1 -* - lc = lr - ld = 0 - nRys = (la+lb+lc+ld+2)/2 -* - labMin=nabSz(Max(la,lb)-1)+1 - labMax=nabSz(la+lb) - lab = (labMax-labMin+1) - kab = nElem(la)*nElem(lb) -* - lcdMin_EF=nabSz(lr-1)+1 - lcdMax_EF=nabSz(lr) - lcd_EF = (lcdMax_EF-lcdMin_EF+1) - labcd_EF = lab*lcd_EF - Mem0=labcd_EF -* - lcdMin_NA=nabSz(lr-2)+1 - lcdMax_NA=nabSz(lr-1) - lcd_NA = (lcdMax_NA-lcdMin_NA+1) -* - Call mHRR(la,lb,nFlop,nMem) - Mem1=Max(lcd_EF,lcd_NA)*nMem -* - iAngV(1) = la - iAngV(2) = lb - iAngV(3) = lc - iAngV(4) = ld - Call MemRys(iAngV,Mem2_EF) - iAngV(3) = 0 - Call MemRys(iAngV,Mem2_NA) - Mem2 = Max(Mem2_EF,Mem2_NA,kab*Max(lcd_EF,lcd_NA)) -* - MemNA_GIAO = Mem0 + Mem1 + Mem2 - Return - End diff -Nru openmolcas-22.02/src/oneint_util/namem_giao.F90 openmolcas-22.10/src/oneint_util/namem_giao.F90 --- openmolcas-22.02/src/oneint_util/namem_giao.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/namem_giao.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,62 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine NAMem_GIAO( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri3_Elem1, nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: iAngV(4), kab, lab, labcd_EF, labMax, labMin, lc, lcd_EF, lcd_NA, lcdMax_EF, lcdMax_NA, lcdMin_EF, lcdMin_NA, & + ld, Mem0, Mem1, Mem2, Mem2_EF, Mem2_NA, nFlop, nMem + +lc = lr +ld = 0 +nHer = (la+lb+lc+ld+2)/2 + +labMin = nTri3_Elem1(max(la,lb)-1) +labMax = nTri3_Elem1(la+lb)-1 +lab = (labMax-labMin+1) +kab = nTri_Elem1(la)*nTri_Elem1(lb) + +lcdMin_EF = nTri3_Elem1(lr-1) +lcdMax_EF = nTri3_Elem1(lr)-1 +lcd_EF = (lcdMax_EF-lcdMin_EF+1) +labcd_EF = lab*lcd_EF +Mem0 = labcd_EF + +lcdMin_NA = nTri3_Elem1(lr-2) +lcdMax_NA = nTri3_Elem1(lr-1)-1 +lcd_NA = (lcdMax_NA-lcdMin_NA+1) + +call mHRR(la,lb,nFlop,nMem) +Mem1 = max(lcd_EF,lcd_NA)*nMem + +iAngV(1) = la +iAngV(2) = lb +iAngV(3) = lc +iAngV(4) = ld +call MemRys(iAngV,Mem2_EF) +iAngV(3) = 0 +call MemRys(iAngV,Mem2_NA) +Mem2 = max(Mem2_EF,Mem2_NA,kab*max(lcd_EF,lcd_NA)) + +Mem = Mem0+Mem1+Mem2 + +return + +end subroutine NAMem_GIAO diff -Nru openmolcas-22.02/src/oneint_util/oamint.f openmolcas-22.10/src/oneint_util/oamint.f --- openmolcas-22.02/src/oneint_util/oamint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/oamint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,116 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -* 2016, Lasse Kragh Soerensen * -************************************************************************ - SubRoutine OAMInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of orbital angular * -* momentum integrals. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, Sweden, February '91 * -* Placed restrictions on the differentiation. Lasse '16 * -************************************************************************ - use Gateway_Info, only: lUPONLY, lDOWNONLY - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - -#include "int_interface.fh" - -* Local variables - Real*8 TC(3) - Integer iStabO(0:7), iDCRT(0:7) -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - nip = 1 - ipB = nip - nip = nip + nZeta - ipS1 = nip - nip = nip + nZeta*nElem(la)*nElem(lb+1)*3 - ipS2 = 1 - If (lb.gt.0) Then - ipS2 = nip - nip = nip + nZeta*nElem(la)*nElem(lb-1)*3 - End If - ipRes = nip - nip = nip + nZeta*nElem(la)*nElem(lb)*nComp - If (nip-1.gt.nZeta*nArr) Then - Call WarningMessage(2,' OAMInt: nip-1.gt.nZeta*nArr') - Call Abend() - End If - ipArr = nip - mArr = (nArr*nZeta - (nip-1))/nZeta -* - call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) -* - iComp=3 - llOper = lOper(1) - Do 90 iComp = 2, nComp - llOper = iOr(llOper,lOper(iComp)) - 90 Continue - Call SOS(iStabO,nStabO,llOper) - Call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) -* - ipOff = ipB - Do 100 iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ipOff),nAlpha) - ipOff = ipOff + 1 - 100 Continue -* - Do 102 lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),CCoor,TC) -* - IF (.NOT.lDOWNONLY) THEN - nHer = (la + (lb+1) + (nOrdOp-1) + 2) / 2 - Call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P, - & Array(ipS1),nZeta,iComp,la,lb+1,A,RB,nHer, - & Array(ipArr),mArr,TC,nOrdOp-1) - END IF -* - If (lb.gt.0) Then - IF (.NOT.lUPONLY) THEN - nHer = (la + (lb-1) + (nOrdOp-1) + 2) / 2 - Call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P, - & Array(ipS2),nZeta,iComp,la,lb-1,A,RB,nHer, - & Array(ipArr),mArr,TC,nOrdOp-1) - END IF - End If -* -* Combine derivatives of dipole integrals to generate the -* orbital angular momentum integrals. -* - Call Util2(Array(ipB),nZeta,Array(ipRes),la,lb,Array(ipS1), - & Array(ipS2)) -* -*--------Accumulate contributions -* - nOp = NrOpr(iDCRT(lDCRT)) - Call SymAdO(Array(ipRes),nZeta,la,lb,nComp,Final,nIC, - & nOp ,lOper,iChO,One) -* - 102 Continue -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/oamint.F90 openmolcas-22.10/src/oneint_util/oamint.F90 --- openmolcas-22.02/src/oneint_util/oamint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/oamint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,110 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +! 2016, Lasse Kragh Soerensen * +!*********************************************************************** + +subroutine OAMInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of orbital angular * +! momentum integrals. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, Sweden, February '91 * +! Placed restrictions on the differentiation. Lasse '16 * +!*********************************************************************** + +use Gateway_Info, only: lDOWNONLY, lUPONLY +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +#include "int_interface.fh" +integer(kind=iwp) :: iBeta, iComp, iDCRT(0:7), ipArr, ipB, ipOff, ipRes, ipS1, ipS2, iStabO(0:7), lDCRT, llOper, LmbdT, mArr, & + nDCRT, nip, nOp, nStabO +real(kind=wp) :: TC(3) +integer(kind=iwp), external :: NrOpr + +#include "macros.fh" +unused_var(PtChrg) +unused_var(iAddPot) + +nip = 1 +ipB = nip +nip = nip+nZeta +ipS1 = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb+1)*3 +ipS2 = 1 +if (lb > 0) then + ipS2 = nip + nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb-1)*3 +end if +ipRes = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb)*nComp +if (nip-1 > nZeta*nArr) then + call WarningMessage(2,' OAMInt: nip-1 > nZeta*nArr') + call Abend() +end if +ipArr = nip +mArr = (nArr*nZeta-(nip-1))/nZeta + +rFinal(:,:,:,:) = Zero + +iComp = 3 +llOper = lOper(1) +do iComp=2,nComp + llOper = ior(llOper,lOper(iComp)) +end do +call SOS(iStabO,nStabO,llOper) +call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) + +ipOff = ipB-1 +do iBeta=1,nBeta + Array(ipOff+1:ipOff+nAlpha) = Beta(iBeta) + ipOff = ipOff+nAlpha +end do + +do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),CCoor,TC) + + if (.not. lDOWNONLY) then + nHer = (la+(lb+1)+(nOrdOp-1)+2)/2 + call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipS1),nZeta,iComp,la,lb+1,A,RB,nHer,Array(ipArr),mArr,TC,nOrdOp-1) + end if + + if (lb > 0) then + if (.not. lUPONLY) then + nHer = (la+(lb-1)+(nOrdOp-1)+2)/2 + call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipS2),nZeta,iComp,la,lb-1,A,RB,nHer,Array(ipArr),mArr,TC, & + nOrdOp-1) + end if + end if + + ! Combine derivatives of dipole integrals to generate the + ! orbital angular momentum integrals. + + call Util2(Array(ipB),nZeta,Array(ipRes),la,lb,Array(ipS1),Array(ipS2)) + + ! Accumulate contributions + + nOp = NrOpr(iDCRT(lDCRT)) + call SymAdO(Array(ipRes),nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,One) + +end do + +return + +end subroutine OAMInt diff -Nru openmolcas-22.02/src/oneint_util/oammem.f openmolcas-22.10/src/oneint_util/oammem.f --- openmolcas-22.02/src/oneint_util/oammem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/oammem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine OAMMem( -#define _CALLING_ -#include "mem_interface.fh" - &) -#include "mem_interface.fh" -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - Call MltMmP(nOrder,Mem,la,lb+1,lr-1) - nHer = nOrder - If (lb.gt.0) Then - Call MltMmP(nOrder,MmMltP,la,lb-1,lr-1) - Mem = Max(Mem,MmMltP) + nElem(la)*nElem(lb-1)*3 - End If - Mem = Mem + 1 + nElem(la)*nElem(lb+1)*3 - Mem = Mem + nElem(la)*nElem(lb)*3 -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/oammem.F90 openmolcas-22.10/src/oneint_util/oammem.F90 --- openmolcas-22.02/src/oneint_util/oammem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/oammem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,37 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine OAMMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: MmMltP, nOrder + +call MltMmP(nOrder,Mem,la,lb+1,lr-1) +nHer = nOrder +if (lb > 0) then + call MltMmP(nOrder,MmMltP,la,lb-1,lr-1) + Mem = max(Mem,MmMltP)+nTri_Elem1(la)*nTri_Elem1(lb-1)*3 +end if +Mem = Mem+1+nTri_Elem1(la)*nTri_Elem1(lb+1)*3 +Mem = Mem+nTri_Elem1(la)*nTri_Elem1(lb)*3 + +return + +end subroutine OAMMem diff -Nru openmolcas-22.02/src/oneint_util/omqint.f openmolcas-22.10/src/oneint_util/omqint.f --- openmolcas-22.02/src/oneint_util/omqint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/omqint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,128 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2015, Lasse Kragh Soerensen * -* 2015, Roland Lindh * -************************************************************************ - SubRoutine OMQInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of orbital magnetic * -* quadrupole integrals => OMQInt * -* * -* Author: Lasse Kragh Soerensen and Roland Lindh 2015 * -* Based on OAMInt * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - -#include "int_interface.fh" - -* Local variables - Real*8 TC(3) - Integer iStabO(0:7), iDCRT(0:7) -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - nip = 1 - ipB = nip - nip = nip + nZeta - -! L + 1 component - ipS1 = nip - nip = nip + nZeta*nElem(la)*nElem(lb+1)*6 ! not ncomp - -! L - 1 component - ipS2 = 1 - If (lb.gt.0) Then - ipS2 = nip - nip = nip + nZeta*nElem(la)*nElem(lb-1)*6 ! not ncomp - End If - -! L + 0 component - ipS3 = nip - nip = nip + nZeta*nElem(la)*nElem(lb)*3 - - ipRes = nip - nip = nip + nZeta*nElem(la)*nElem(lb)*nComp - If (nip-1.gt.nZeta*nArr) Then - Call WarningMessage(2,' OMQInt: nip-1.gt.nZeta*nArr') - Call Abend() - End If - ipArr = nip - mArr = (nArr*nZeta - (nip-1))/nZeta -* - Call DCopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) -* - llOper = lOper(1) - Do 90 iComp = 2, nComp - llOper = iOr(llOper,lOper(iComp)) - 90 Continue - Call SOS(iStabO,nStabO,llOper) - Call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) -* - ipOff = ipB - Do 100 iAlpha = 1, nAlpha - Call DCopy_(nBeta,Beta,1,Array(ipOff),nAlpha) - ipOff = ipOff + 1 - 100 Continue -* - Do 102 lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),CCoor,TC) -* - iComp=6 ! Why are these here ncomp is passed down? -* - nHer = (la + (lb+1) + (nOrdOp-1) + 2) / 2 - Call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P, - & Array(ipS1),nZeta,iComp,la,lb+1,A,RB,nHer, - & Array(ipArr),mArr,TC,nOrdOp-1) -* - If (lb.gt.0) Then - nHer = (la + (lb-1) + (nOrdOp-1) + 2) / 2 - Call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P, - & Array(ipS2),nZeta,iComp,la,lb-1,A,RB,nHer, - & Array(ipArr),mArr,TC,nOrdOp-1) - End If -* - iComp=3 ! Why are these here ncomp is passed down? -* - nHer = (la + lb + (nOrdOp-2) + 2) / 2 -! check to see dipole integral sure looks a lot like dipole integrals - Call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P, - & Array(ipS3),nZeta,iComp,la,lb,A,RB,nHer, - & Array(ipArr),mArr,TC,nOrdOp-2) -* -* Combine derivatives of dipole integrals to generate the -* orbital angular momentum integrals. -* - Call Util3(Array(ipB),nZeta,Array(ipRes),la,lb,Array(ipS1), - & Array(ipS3),Array(ipS2)) -* -*--------Accumulate contributions -* - nOp = NrOpr(iDCRT(lDCRT)) - Call SymAdO(Array(ipRes),nZeta,la,lb,nComp,Final,nIC, - & nOp ,lOper,iChO,One) -* - 102 Continue -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/omqint.F90 openmolcas-22.10/src/oneint_util/omqint.F90 --- openmolcas-22.02/src/oneint_util/omqint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/omqint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,119 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2015, Lasse Kragh Soerensen * +! 2015, Roland Lindh * +!*********************************************************************** + +subroutine OMQInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of orbital magnetic * +! quadrupole integrals => OMQInt * +! * +! Author: Lasse Kragh Soerensen and Roland Lindh 2015 * +! Based on OAMInt * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +#include "int_interface.fh" +integer(kind=iwp) :: iBeta, iComp, iDCRT(0:7), ipArr, ipB, ipOff, ipRes, ipS1, ipS2, ipS3, iStabO(0:7), lDCRT, llOper, LmbdT, & + mArr, nDCRT, nip, nOp, nStabO +real(kind=wp) :: TC(3) +integer(kind=iwp), external :: NrOpr + +#include "macros.fh" +unused_var(PtChrg) +unused_var(iAddPot) + +nip = 1 +ipB = nip +nip = nip+nZeta + +! L + 1 component +ipS1 = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb+1)*6 ! not ncomp + +! L - 1 component +ipS2 = 1 +if (lb > 0) then + ipS2 = nip + nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb-1)*6 ! not ncomp +end if + +! L + 0 component +ipS3 = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb)*3 + +ipRes = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb)*nComp +if (nip-1 > nZeta*nArr) then + call WarningMessage(2,' OMQInt: nip-1 > nZeta*nArr') + call Abend() +end if +ipArr = nip +mArr = (nArr*nZeta-(nip-1))/nZeta + +rFinal(:,:,:,:) = Zero + +llOper = lOper(1) +do iComp=2,nComp + llOper = ior(llOper,lOper(iComp)) +end do +call SOS(iStabO,nStabO,llOper) +call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) + +ipOff = ipB-1 +do iBeta=1,nBeta + Array(ipOff+1:ipOff+nAlpha) = Beta(iBeta) + ipOff = ipOff+nAlpha +end do + +do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),CCoor,TC) + + iComp = 6 ! Why are these here ncomp is passed down? + + nHer = (la+(lb+1)+(nOrdOp-1)+2)/2 + call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipS1),nZeta,iComp,la,lb+1,A,RB,nHer,Array(ipArr),mArr,TC,nOrdOp-1) + + if (lb > 0) then + nHer = (la+(lb-1)+(nOrdOp-1)+2)/2 + call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipS2),nZeta,iComp,la,lb-1,A,RB,nHer,Array(ipArr),mArr,TC,nOrdOp-1) + end if + + iComp = 3 ! Why are these here ncomp is passed down? + + nHer = (la+lb+(nOrdOp-2)+2)/2 + ! check to see dipole integral sure looks a lot like dipole integrals + call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipS3),nZeta,iComp,la,lb,A,RB,nHer,Array(ipArr),mArr,TC,nOrdOp-2) + + ! Combine derivatives of dipole integrals to generate the + ! orbital angular momentum integrals. + + call Util3(Array(ipB),nZeta,Array(ipRes),la,lb,Array(ipS1),Array(ipS3),Array(ipS2)) + + ! Accumulate contributions + + nOp = NrOpr(iDCRT(lDCRT)) + call SymAdO(Array(ipRes),nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,One) + +end do + +return + +end subroutine OMQInt diff -Nru openmolcas-22.02/src/oneint_util/omqmem.f openmolcas-22.10/src/oneint_util/omqmem.f --- openmolcas-22.02/src/oneint_util/omqmem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/omqmem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,41 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine OMQMem( -#define _CALLING_ -#include "mem_interface.fh" - &) -#include "mem_interface.fh" -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - Call MltMmP(nOrder,MemP,la,lb+1,lr-1) -! Not sure what this does. nHer is set on the outside anyway??? - nHer = nOrder -! not same order (1 not 3) hence lr-2 - Call MltMmP(nOrder,MemN,la,lb,lr-2) - Mem = Max(MemP,MemN) - If (lb.gt.0) Then - Call MltMmP(nOrder,MemM,la,lb-1,lr-1) -! For L - 1 Component - Mem = Max(Mem,MemM) + nElem(la)*nElem(lb-1)*6 - End If -! For dipole term ( L + 0 Component) - Mem = Mem + nElem(la)*nElem(lb)*3 -! For L + 1 Component - Mem = Mem + 1 + nElem(la)*nElem(lb+1)*6 - Mem = Mem + nElem(la)*nElem(lb)*9 ! final term -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/omqmem.F90 openmolcas-22.10/src/oneint_util/omqmem.F90 --- openmolcas-22.02/src/oneint_util/omqmem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/omqmem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,45 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine OMQMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: MemM, MemN, MemP, nOrder + +call MltMmP(nOrder,MemP,la,lb+1,lr-1) +! Not sure what this does. nHer is set on the outside anyway??? +nHer = nOrder +! not same order (1 not 3) hence lr-2 +call MltMmP(nOrder,MemN,la,lb,lr-2) +Mem = max(MemP,MemN) +if (lb > 0) then + call MltMmP(nOrder,MemM,la,lb-1,lr-1) + ! For L - 1 Component + Mem = max(Mem,MemM)+nTri_Elem1(la)*nTri_Elem1(lb-1)*6 +end if +! For dipole term ( L + 0 Component) +Mem = Mem+nTri_Elem1(la)*nTri_Elem1(lb)*3 +! For L + 1 Component +Mem = Mem+1+nTri_Elem1(la)*nTri_Elem1(lb+1)*6 +Mem = Mem+nTri_Elem1(la)*nTri_Elem1(lb)*9 ! final term + +return + +end subroutine OMQMem diff -Nru openmolcas-22.02/src/oneint_util/one2h5_crtmom.F90 openmolcas-22.10/src/oneint_util/one2h5_crtmom.F90 --- openmolcas-22.02/src/oneint_util/one2h5_crtmom.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/one2h5_crtmom.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,176 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +#include "compiler_features.h" +#ifdef _HDF5_ + +subroutine one2h5_crtmom(fileid,nSym,nBas) +! SVC: read cartesian moments from the 1-electron integral file +! and write it to the HDF5 file specified with fileid. +! This routine does nothing if HDF5 is not supported. +! FP: also include the origins used for the operators +! +! Datasets: +! MLTPL_X, MLTPL_Y, MLTPL_Z +! MLTPL_XX, MLTPL_YY, MLTPL_ZZ, MLTPL_XY, MLTPL_YZ, MLTPL_XZ +! MLTPL_ORIG + +use Symmetry_Info, only: Mul +use mh5, only: mh5_close_dset, mh5_create_dset_real, mh5_init_attr, mh5_put_dset +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: fileid, nSym, nBas(nSym) +integer(kind=iwp) :: dsetid, i, iBas, iComp, iOff, iOpt, iRc, iScrOff, iSym, iSyMsk, j, jBas, jOff, jsym, msym, nB1, nB2, nbast +real(kind=wp) :: mp_orig(3,3) +character(len=8) :: Label +real(kind=wp), allocatable :: MLTPL(:,:), Scratch(:) +character(len=*), parameter :: mltpl1_comp(3) = ['X','Y','Z'], mltpl2_comp(6) = ['XX','XY','XZ','YY','YZ','ZZ'] + +nbast = 0 +do iSym=1,nSym + nbast = nbast+nBas(iSym) +end do + +mp_orig(:,:) = 0. + +call mma_allocate(MLTPL,NBAST,NBAST) +call mma_allocate(Scratch,NBAST**2+3) + +do icomp=1,3 + MLTPL = Zero + iRc = -1 + iOpt = 4 + iSyMsk = 0 + Label = 'Mltpl 1' + call RdOne(iRc,iOpt,Label,iComp,Scratch,iSyMsk) + ! iSyMsk tells us which symmetry combination is valid + iScrOff = 0 + iOff = 0 + do iSym=1,nSym + jOff = 0 + nB1 = nBas(iSym) + do jSym=1,iSym + mSym = Mul(iSym,jSym) + nB2 = nBas(jSym) + if (btest(iSyMsk,mSym-1)) then + if (iSym == jSym) then + do j=1,nB2 + jBas = jOff+j + do i=1,j + iBas = iOff+i + MLTPL(iBas,jBas) = Scratch(1+iScrOff) + iScrOff = iScrOff+1 + end do + end do + else + do j=1,nB2 + jBas = jOff+j + do i=1,nB1 + iBas = iOff+i + MLTPL(jBas,iBas) = Scratch(1+iScrOff) + iScrOff = iScrOff+1 + end do + end do + end if + end if + jOff = jOff+nB2 + end do + iOff = iOff+nB1 + end do + do j=1,nBasT + do i=1,j-1 + MLTPL(j,i) = MLTPL(i,j) + end do + end do + dsetid = mh5_create_dset_real(fileid,'AO_MLTPL_'//mltpl1_comp(icomp),2,[NBAST,NBAST]) + call mh5_init_attr(dsetid,'DESCRIPTION', & + '1st-order multipole matrix of the atomic orbitals, arranged as matrix of size [NBAST,NBAST]') + call mh5_put_dset(dsetid,MLTPL) + call mh5_close_dset(dsetid) +end do + +mp_orig(1:3,2) = Scratch(iScrOff+1:iScrOff+3) + +do icomp=1,6 + MLTPL = Zero + iRc = -1 + iOpt = 4 + iSyMsk = 0 + Label = 'Mltpl 2' + call RdOne(iRc,iOpt,Label,iComp,Scratch,iSyMsk) + ! iSyMsk tells us which symmetry combination is valid + iScrOff = 0 + iOff = 0 + do iSym=1,nSym + jOff = 0 + nB1 = nBas(iSym) + do jSym=1,iSym + mSym = Mul(iSym,jSym) + nB2 = nBas(jSym) + if (btest(iSyMsk,mSym-1)) then + if (iSym == jSym) then + do j=1,nB2 + jBas = jOff+j + do i=1,j + iBas = iOff+i + MLTPL(iBas,jBas) = Scratch(1+iScrOff) + iScrOff = iScrOff+1 + end do + end do + else + do j=1,nB2 + jBas = jOff+j + do i=1,nB1 + iBas = iOff+i + MLTPL(jBas,iBas) = Scratch(1+iScrOff) + iScrOff = iScrOff+1 + end do + end do + end if + end if + jOff = jOff+nB2 + end do + iOff = iOff+nB1 + end do + do j=1,nBasT + do i=1,j-1 + MLTPL(j,i) = MLTPL(i,j) + end do + end do + dsetid = mh5_create_dset_real(fileid,'AO_MLTPL_'//mltpl2_comp(icomp),2,[NBAST,NBAST]) + call mh5_init_attr(dsetid,'DESCRIPTION', & + '2nd-order multipole matrix of the atomic orbitals, arranged as matrix of size [NBAST,NBAST]') + call mh5_put_dset(dsetid,MLTPL) + call mh5_close_dset(dsetid) +end do + +mp_orig(1:3,3) = Scratch(iScrOff+1:iScrOff+3) + +call mma_deallocate(MLTPL) +call mma_deallocate(Scratch) + +dsetid = mh5_create_dset_real(fileid,'MLTPL_ORIG',2,[3,3]) +call mh5_init_attr(dsetid,'DESCRIPTION','Origin used for the multipole moment operators: arranged as overlap, dipole, quadrupole') +call mh5_put_dset(dsetid,mp_orig,[3,3],[0,0]) +call mh5_close_dset(dsetid) + +end subroutine one2h5_crtmom + +#elif !defined (EMPTY_FILES) + +! Some compilers do not like empty files +#include "macros.fh" +dummy_empty_procedure(one2h5_crtmom) + +#endif diff -Nru openmolcas-22.02/src/oneint_util/one2h5.f openmolcas-22.10/src/oneint_util/one2h5.f --- openmolcas-22.02/src/oneint_util/one2h5.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/one2h5.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,335 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -#ifdef _HDF5_ - - subroutine one2h5_ovlmat(fileid, nsym, nbas) -* IFG: read atomic overlap matrix from the 1-electron integral file -* and write it to the HDF5 file specified with fileid. -* This routine does nothing if HDF5 is not supported. -* -* Datasets: -* AO_OVERLAP_MATRIX - - use mh5, only: mh5_init_attr, mh5_create_dset_real, mh5_put_dset, - & mh5_close_dset - implicit none - integer :: fileid - integer :: nsym, nbas(*) -# include "Molcas.fh" -# include "stdalloc.fh" - - integer :: isym - integer :: nb, nbast, nbast1, nbast2 - - real*8, allocatable :: SAO(:), Scr(:) - - integer :: iRc, iOpt, iComp, iSyLbl - character(len=8) :: Label - - integer :: iOff1, iOff2 - - integer :: dsetid - - nbast=0 - nbast1=0 - nbast2=0 - do isym=1,nsym - nb=nbas(isym) - nbast=nbast+nb - nbast1=nbast1+(nb*(nb+1))/2 - nbast2=nbast2+nb**2 - end do - -* atomic orbital overlap matrix - dsetid = mh5_create_dset_real(fileid, - $ 'AO_OVERLAP_MATRIX', 1, [NBAST2]) - call mh5_init_attr(dsetid, 'DESCRIPTION', - $ 'Overlap matrix of the atomic orbitals, '// - $ 'arranged as blocks of size [NBAS(i)**2], i=1,#irreps') - - call mma_allocate(SAO,NBAST1) - iRc=-1 - iOpt=6 - iComp=1 - iSyLbl=1 - Label='Mltpl 0' - Call RdOne(iRc,iOpt,Label,iComp,SAO,iSyLbl) - iOff1 = 0 - iOff2 = 0 - Do iSym = 1,nSym - nB = nBas(iSym) - If ( nb.gt.0 ) then - call mma_allocate(scr,nb*nb) - Call Square(SAO(1+iOff1),Scr,1,nb,nb) - call mh5_put_dset(dsetid, - $ Scr,[nb*nb],[iOff2]) - call mma_deallocate(scr) - end if - iOff1 = iOff1 + (nb*nb+nb)/2 - iOff2 = iOff2 + (nb*nb) - end do - call mma_deallocate(SAO) - - call mh5_close_dset(dsetid) - - end - - subroutine one2h5_fckint(fileid, nsym, nbas) -* IFG: read atomic Fock matrix from the 1-electron integral file -* and write it to the HDF5 file specified with fileid. -* This routine does nothing if HDF5 is not supported. -* -* Datasets: -* AO_FOCKINT_MATRIX - - use mh5, only: mh5_init_attr, mh5_create_dset_real, mh5_put_dset, - & mh5_close_dset - implicit none - integer :: fileid - integer :: nsym, nbas(*) -# include "Molcas.fh" -# include "stdalloc.fh" - - integer :: isym - integer :: nb, nbast, nbast1, nbast2 - - real*8, allocatable :: SAO(:), Scr(:) - - integer :: iRc, iOpt, iComp, iSyLbl - character(len=8) :: Label - - integer :: iOff1, iOff2 - - integer :: dsetid - - nbast=0 - nbast1=0 - nbast2=0 - do isym=1,nsym - nb=nbas(isym) - nbast=nbast+nb - nbast1=nbast1+(nb*(nb+1))/2 - nbast2=nbast2+nb**2 - end do - -* atomic orbital Fock matrix - dsetid = mh5_create_dset_real(fileid, - $ 'AO_FOCKINT_MATRIX', 1, [NBAST2]) - call mh5_init_attr(dsetid, 'DESCRIPTION', - $ 'Fock matrix of the atomic orbitals, '// - $ 'arranged as blocks of size [NBAS(i)**2], i=1,#irreps') - - call mma_allocate(SAO,NBAST1) - iRc=-1 - iOpt=6 - iComp=1 - iSyLbl=1 - Label='FckInt ' - Call RdOne(iRc,iOpt,Label,iComp,SAO,iSyLbl) - iOff1 = 0 - iOff2 = 0 - Do iSym = 1,nSym - nB = nBas(iSym) - If ( nb.gt.0 ) then - call mma_allocate(scr,nb*nb) - Call Square(SAO(1+iOff1),Scr,1,nb,nb) - call mh5_put_dset(dsetid, - $ Scr,[nb*nb],[iOff2]) - call mma_deallocate(scr) - end if - iOff1 = iOff1 + (nb*nb+nb)/2 - iOff2 = iOff2 + (nb*nb) - end do - call mma_deallocate(SAO) - - call mh5_close_dset(dsetid) - - end - - subroutine one2h5_crtmom(fileid, nsym, nbas) -* SVC: read cartesian moments from the 1-electron integral file -* and write it to the HDF5 file specified with fileid. -* This routine does nothing if HDF5 is not supported. -* FP: also include the origins used for the operators -* -* Datasets: -* MLTPL_X, MLTPL_Y, MLTPL_Z -* MLTPL_XX, MLTPL_YY, MLTPL_ZZ, MLTPL_XY, MLTPL_YZ, MLTPL_XZ -* MLTPL_ORIG - - use Symmetry_Info, only: Mul - use mh5, only: mh5_init_attr, mh5_create_dset_real, mh5_put_dset, - & mh5_close_dset - implicit none - integer :: fileid - integer :: nsym, nbas(*) -# include "Molcas.fh" -# include "stdalloc.fh" - - integer :: isym, jsym, msym - integer :: nb, nbast, nB1, nB2 - - real*8, allocatable :: MLTPL(:,:), Scratch(:) - real*8, dimension(3,3) :: mp_orig - - integer :: iRc, iOpt, iComp, iSyMsk - character(len=8) :: Label - - character(len=1)::mltpl1_comp(3) = ['X','Y','Z'] - character(len=2)::mltpl2_comp(6) = ['XX','XY','XZ','YY','YZ','ZZ'] - - integer :: i, j, iOff, jOff, iScrOff, iBas, jBas - - integer :: dsetid - - nbast=0 - do isym=1,nsym - nb=nbas(isym) - nbast=nbast+nb - end do - - mp_orig(:,:) = 0. - - call mma_allocate(MLTPL,NBAST,NBAST) - call mma_allocate(Scratch,NBAST**2+3) - - do icomp=1,3 - MLTPL=0.0D0 - iRc=-1 - iOpt=4 - iSyMsk=0 - Label='Mltpl 1' - Call RdOne(iRc,iOpt,Label,iComp,Scratch,iSyMsk) -* iSyMsk tells us which symmetry combination is valid - iScrOff = 0 - iOff = 0 - Do iSym = 1,nSym - jOff = 0 - nB1 = nBas(iSym) - Do jSym = 1,iSym - mSym = Mul(iSym,jSym) - nB2 = nBas(jSym) - If (IAND(2**(mSym-1),iSyMsk).ne.0) Then - If (iSym.eq.jSym) Then - Do j=1,nB2 - jBas = jOff + j - Do i=1,j - iBas = iOff + i - MLTPL(iBas,jBas) = Scratch(1+iScrOff) - iScrOff = iScrOff + 1 - End Do - End Do - Else - Do j=1,nB2 - jBas = jOff + j - Do i=1,nB1 - iBas = iOff + i - MLTPL(jBas,iBas) = Scratch(1+iScrOff) - iScrOff = iScrOff + 1 - End Do - End Do - End If - End If - jOff = jOff + nB2 - End Do - iOff = iOff + nB1 - End Do - Do j=1,nBasT - Do i=1,j-1 - MLTPL(j,i)=MLTPL(i,j) - End Do - End Do - dsetid = mh5_create_dset_real(fileid, - $ 'AO_MLTPL_'//mltpl1_comp(icomp), 2, [NBAST,NBAST]) - call mh5_init_attr(dsetid, 'DESCRIPTION', - $ '1st-order multipole matrix of the atomic orbitals, '// - $ 'arranged as matrix of size [NBAST,NBAST]') - call mh5_put_dset(dsetid,MLTPL) - call mh5_close_dset(dsetid) - end do - - mp_orig(1:3,2) = Scratch(iScrOff+1:iScrOff+3) - - do icomp=1,6 - MLTPL=0.0D0 - iRc=-1 - iOpt=4 - iSyMsk=0 - Label='Mltpl 2' - Call RdOne(iRc,iOpt,Label,iComp,Scratch,iSyMsk) -* iSyMsk tells us which symmetry combination is valid - iScrOff = 0 - iOff = 0 - Do iSym = 1,nSym - jOff = 0 - nB1 = nBas(iSym) - Do jSym = 1,iSym - mSym = Mul(iSym,jSym) - nB2 = nBas(jSym) - If (IAND(2**(mSym-1),iSyMsk).ne.0) Then - If (iSym.eq.jSym) Then - Do j=1,nB2 - jBas = jOff + j - Do i=1,j - iBas = iOff + i - MLTPL(iBas,jBas) = Scratch(1+iScrOff) - iScrOff = iScrOff + 1 - End Do - End Do - Else - Do j=1,nB2 - jBas = jOff + j - Do i=1,nB1 - iBas = iOff + i - MLTPL(jBas,iBas) = Scratch(1+iScrOff) - iScrOff = iScrOff + 1 - End Do - End Do - End If - End If - jOff = jOff + nB2 - End Do - iOff = iOff + nB1 - End Do - Do j=1,nBasT - Do i=1,j-1 - MLTPL(j,i)=MLTPL(i,j) - End Do - End Do - dsetid = mh5_create_dset_real(fileid, - $ 'AO_MLTPL_'//mltpl2_comp(icomp), 2, [NBAST,NBAST]) - call mh5_init_attr(dsetid, 'DESCRIPTION', - $ '2nd-order multipole matrix of the atomic orbitals, '// - $ 'arranged as matrix of size [NBAST,NBAST]') - call mh5_put_dset(dsetid,MLTPL) - call mh5_close_dset(dsetid) - end do - - mp_orig(1:3,3) = Scratch(iScrOff+1:iScrOff+3) - - call mma_deallocate(MLTPL) - call mma_deallocate(Scratch) - - dsetid = mh5_create_dset_real(fileid, - $ 'MLTPL_ORIG', 2, [3,3]) - call mh5_init_attr(dsetid, 'DESCRIPTION', - $ 'Origin used for the multipole moment operators: '// - $ 'arranged as overlap, dipole, quadrupole') - call mh5_put_dset(dsetid,mp_orig,[3,3],[0,0]) - call mh5_close_dset(dsetid) - - end - -#elif defined (NAGFOR) -c Some compilers do not like empty files - Subroutine empty_one2h5_ovlmat() - End -#endif diff -Nru openmolcas-22.02/src/oneint_util/one2h5_fckint.F90 openmolcas-22.10/src/oneint_util/one2h5_fckint.F90 --- openmolcas-22.02/src/oneint_util/one2h5_fckint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/one2h5_fckint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,79 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +#include "compiler_features.h" +#ifdef _HDF5_ + +subroutine one2h5_fckint(fileid,nSym,nBas) +! IFG: read atomic Fock matrix from the 1-electron integral file +! and write it to the HDF5 file specified with fileid. +! This routine does nothing if HDF5 is not supported. +! +! Datasets: +! AO_FOCKINT_MATRIX + +use mh5, only: mh5_close_dset, mh5_create_dset_real, mh5_init_attr, mh5_put_dset +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp) :: fileid, nSym, nBas(nSym) +integer(kind=iwp) :: dsetid, iComp, iOff1, iOff2, iOpt, iRc, iSyLbl, iSym, nb, nbast, nbast1, nbast2 +character(len=8) :: Label +real(kind=wp), allocatable :: FAO(:), Scr(:,:) + +nbast = 0 +nbast1 = 0 +nbast2 = 0 +do iSym=1,nSym + nb = nBas(iSym) + nbast = nbast+nb + nbast1 = nbast1+(nb*(nb+1))/2 + nbast2 = nbast2+nb**2 +end do + +! atomic orbital Fock matrix +dsetid = mh5_create_dset_real(fileid,'AO_FOCKINT_MATRIX',1,[NBAST2]) +call mh5_init_attr(dsetid,'DESCRIPTION','Fock matrix of the atomic orbitals, arranged as blocks of size [NBAS(i)**2], i=1,#irreps') + +call mma_allocate(FAO,NBAST1) +iRc = -1 +iOpt = 6 +iComp = 1 +iSyLbl = 1 +Label = 'FckInt ' +call RdOne(iRc,iOpt,Label,iComp,FAO,iSyLbl) +iOff1 = 0 +iOff2 = 0 +do iSym=1,nSym + nb = nBas(iSym) + if (nb > 0) then + call mma_allocate(Scr,nb,nb,label='Scr') + call Square(FAO(1+iOff1),Scr,1,nb,nb) + call mh5_put_dset(dsetid,Scr,[nb*nb],[iOff2]) + call mma_deallocate(Scr) + end if + iOff1 = iOff1+nb*(nb+1)/2 + iOff2 = iOff2+nb**2 +end do +call mma_deallocate(FAO) + +call mh5_close_dset(dsetid) + +end subroutine one2h5_fckint + +#elif !defined (EMPTY_FILES) + +! Some compilers do not like empty files +#include "macros.fh" +dummy_empty_procedure(one2h5_fckint) + +#endif diff -Nru openmolcas-22.02/src/oneint_util/one2h5_ovlmat.F90 openmolcas-22.10/src/oneint_util/one2h5_ovlmat.F90 --- openmolcas-22.02/src/oneint_util/one2h5_ovlmat.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/one2h5_ovlmat.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,80 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +#include "compiler_features.h" +#ifdef _HDF5_ + +subroutine one2h5_ovlmat(fileid,nSym,nBas) +! IFG: read atomic overlap matrix from the 1-electron integral file +! and write it to the HDF5 file specified with fileid. +! This routine does nothing if HDF5 is not supported. +! +! Datasets: +! AO_OVERLAP_MATRIX + +use mh5, only: mh5_close_dset, mh5_create_dset_real, mh5_init_attr, mh5_put_dset +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp) :: fileid, nSym, nBas(nSym) +integer(kind=iwp) :: dsetid, iComp, iOff1, iOff2, iOpt, iRc, iSyLbl, iSym, nb, nbast, nbast1, nbast2 +character(len=8) :: Label +real(kind=wp), allocatable :: SAO(:), Scr(:,:) + +nbast = 0 +nbast1 = 0 +nbast2 = 0 +do iSym=1,nSym + nb = nBas(iSym) + nbast = nbast+nb + nbast1 = nbast1+(nb*(nb+1))/2 + nbast2 = nbast2+nb**2 +end do + +! atomic orbital overlap matrix +dsetid = mh5_create_dset_real(fileid,'AO_OVERLAP_MATRIX',1,[NBAST2]) +call mh5_init_attr(dsetid,'DESCRIPTION', & + 'Overlap matrix of the atomic orbitals, arranged as blocks of size [NBAS(i)**2], i=1,#irreps') + +call mma_allocate(SAO,NBAST1) +iRc = -1 +iOpt = 6 +iComp = 1 +iSyLbl = 1 +Label = 'Mltpl 0' +call RdOne(iRc,iOpt,Label,iComp,SAO,iSyLbl) +iOff1 = 0 +iOff2 = 0 +do iSym=1,nSym + nb = nBas(iSym) + if (nb > 0) then + call mma_allocate(Scr,nb,nb,label='Scr') + call Square(SAO(1+iOff1),Scr,1,nb,nb) + call mh5_put_dset(dsetid,Scr,[nb*nb],[iOff2]) + call mma_deallocate(Scr) + end if + iOff1 = iOff1+nb*(nb+1)/2 + iOff2 = iOff2+nb**2 +end do +call mma_deallocate(SAO) + +call mh5_close_dset(dsetid) + +end subroutine one2h5_ovlmat + +#elif !defined (EMPTY_FILES) + +! Some compilers do not like empty files +#include "macros.fh" +dummy_empty_procedure(one2h5_ovlmat) + +#endif diff -Nru openmolcas-22.02/src/oneint_util/pam2.F90 openmolcas-22.10/src/oneint_util/pam2.F90 --- openmolcas-22.02/src/oneint_util/pam2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/pam2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,23 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +module PAM2 + +use Definitions, only: iwp + +implicit none +private + +integer(kind=iwp) :: iPAMCount = 0, iPAMPrim = 0, kCnttpPAM = 0 + +public :: iPAMcount, iPAMPrim, kCnttpPAM + +end module PAM2 diff -Nru openmolcas-22.02/src/oneint_util/PAM2.f90 openmolcas-22.10/src/oneint_util/PAM2.f90 --- openmolcas-22.02/src/oneint_util/PAM2.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/PAM2.f90 1970-01-01 00:00:00.000000000 +0000 @@ -1,14 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in . * -!*********************************************************************** -! -Module PAM2 -Integer :: kCnttpPAM=0, iPAMPrim=0, iPAMCount=0 -End Module PAM2 diff -Nru openmolcas-22.02/src/oneint_util/pam2int.f openmolcas-22.10/src/oneint_util/pam2int.f --- openmolcas-22.02/src/oneint_util/pam2int.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/pam2int.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,282 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1993, Roland Lindh * -* 1993, Per Boussard * -************************************************************************ - SubRoutine PAM2Int( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of PAM integrals used in * -* PAM calculations. The operator is a gaussian type function * -* * -* Alpha : exponents of bra gaussians * -* nAlpha: number of primitives (exponents) of bra gaussians * -* Beta : as Alpha but for ket gaussians * -* nBeta : as nAlpha but for the ket gaussians * -* Zeta : sum of exponents (nAlpha x nBeta) * -* ZInv : inverse of Zeta * -* rKappa: gaussian prefactor for the products of bra and ket * -* gaussians. * -* P : center of new gaussian from the products of bra and ket * -* gaussians. * -* Final : array for computed integrals * -* nZeta : nAlpha x nBeta * -* nComp : number of components in the operator (e.g. dipolmoment * -* operator has three components) * -* la : total angular momentum of bra gaussian * -* lb : total angular momentum of ket gaussian * -* A : center of bra gaussian * -* B : center of ket gaussian * -* nRys : order of Rys- or Hermite-Gauss polynomial * -* Array : Auxiliary memory as requested by ECPMem * -* nArr : length of Array * -* Ccoor : coordinates of the operator, zero for symmetric oper. * -* NOrdOp: Order of the operator * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, Sweden, and Per Boussard, Dept. of Theoretical * -* Physics, University of Stockholm, Sweden, October '93. * -************************************************************************ - use Basis_Info - use Center_Info - use Her_RW - use PAM2 - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "WrkSpc.fh" -#include "print.fh" - -#include "int_interface.fh" - -* Local variables - Real*8 TC(3), C(3) - Character*80 Label - Logical ABeq(3) - Integer iDCRT(0:7) -* -*-----Statement function for Cartesian index -* - nElem(k)=(k+1)*(k+2)/2 -* - iRout = 122 - iPrint = nPrint(iRout) -* Call GetMem(' Enter PAM2Int','LIST','REAL',iDum,iDum) -* - nip = 1 - ipAxyz = nip - nip = nip + nZeta*3*nHer*(la+1) - ipBxyz = nip - nip = nip + nZeta*3*nHer*(lb+1) - ipRxyz = nip - nip = nip + nZeta*3*nHer*(nOrdOp+1) - ipQxyz = nip - nip = nip + nZeta*3*(la+1)*(lb+1)*(nOrdOp+1) - ipK = nip - nip = nip + nZeta - ipZ = nip - nip = nip + nZeta - ipPx= nip - nip = nip + nZeta - ipPy= nip - nip = nip + nZeta - ipPz= nip - nip = nip + nZeta - ipRes = nip - nip = nip + nZeta*nComp*nElem(la)*nElem(lb) - If (nip-1.gt.nArr*nZeta) Then - Call WarningMessage(2,'PAM2Int: nip-1.gt.nArr*nZeta') - Write (6,*) ' nArr is Wrong! ', nip-1,' > ',nArr*nZeta - Write (6,*) ' Abend in PAM2Int' - Call Abend() - End If -* - If (iPrint.ge.49) Then - Call RecPrt(' In PAM2Int: A',' ',A,1,3) - Call RecPrt(' In PAM2Int: RB',' ',RB,1,3) - Call RecPrt(' In PAM2Int: Ccoor',' ',Ccoor,1,3) - Call RecPrt(' In PAM2Int: Kappa',' ',rKappa,nAlpha,nBeta) - Call RecPrt(' In PAM2Int: Zeta',' ',Zeta,nAlpha,nBeta) - Call RecPrt(' In PAM2Int: P',' ',P,nZeta,3) - Write (6,*) ' In PAM2Int: la,lb,nHer=',la,lb,nHer - End If -* - call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) -* -*-----Loop over nuclear centers -* - kdc=0 - if (kCnttpPAM.gt.1) Then - do ikdc=1,kCnttpPAM-1 - kdc = kdc + dbsc(ikdc)%nCntr - end do - end if - - - kCnttp = kCnttpPAM - If (.Not.dbsc(kCnttp)%lPAM2) Go To 111 - If (dbsc(kCnttp)%nPAM2.eq.-1) Go To 111 -* - Do 101 kCnt = 1, dbsc(kCnttp)%nCntr - C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) -* - Call DCR(LmbdT,iStabM,nStabM, - & dc(kdc+kCnt)%iStab, dc(kdc+kCnt)%nStab,iDCRT,nDCRT) - Fact = DBLE(nStabM) / DBLE(LmbdT) -* - Do 102 lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),C,TC) -* - Call GetMem(' Scr','ALLO','REAL',ipScr, - & nZeta*nElem(la)*nElem(lb)*nComp) - call dcopy_(nZeta*nElem(la)*nElem(lb)*nComp, - & [Zero],0,Work(ipScr),1) - Do 1011 iM2xp = 1, iPAMPrim - Gamma = PAMexp(iM2xp,1) - - - If (iPrint.ge.99) Write (6,*) ' Gamma=',Gamma -* -*-----------------Modify the original basis. -* - Do 1012 iZeta = 1, nZeta - PTC2 = (P(iZeta,1)-TC(1))**2 - & + (P(iZeta,2)-TC(2))**2 - & + (P(iZeta,3)-TC(3))**2 - Tmp0 = Zeta(iZeta)+Gamma - Tmp1 = Exp(-Zeta(iZeta)*Gamma*PTC2/Tmp0) - Array(ipK+iZeta-1) = rKappa(iZeta) * Tmp1 - Array(ipZ+iZeta-1) = Tmp0 - Array(ipPx+iZeta-1) = - & (Zeta(iZeta)*P(iZeta,1)+Gamma*TC(1))/Tmp0 - Array(ipPy+iZeta-1) = - & (Zeta(iZeta)*P(iZeta,2)+Gamma*TC(2))/Tmp0 - Array(ipPz+iZeta-1) = - & (Zeta(iZeta)*P(iZeta,3)+Gamma*TC(3))/Tmp0 - 1012 Continue - If (iPrint.ge.99) Then - Write (6,*) ' The modified basis set' - Call RecPrt(' In PAM2Int: Kappa',' ', - & Array(ipK),nAlpha,nBeta) - Call RecPrt(' In PAM2Int: Zeta',' ', - & Array(ipZ),nAlpha,nBeta) - Call RecPrt(' In PAM2Int: P',' ',Array(ipPx),nZeta,3) - End If -* -*-----------------Compute the cartesian values of the basis functions -* angular part -* - ABeq(1) = A(1).eq.RB(1) .and. A(1).eq.TC(1) - ABeq(2) = A(2).eq.RB(2) .and. A(2).eq.TC(2) - ABeq(3) = A(3).eq.RB(3) .and. A(3).eq.TC(3) - Call CrtCmp(Array(ipZ),Array(ipPx),nZeta,A, - & Array(ipAxyz),la,HerR(iHerR(nHer)), - & nHer,ABeq) - Call CrtCmp(Array(ipZ),Array(ipPx),nZeta,RB, - & Array(ipBxyz),lb,HerR(iHerR(nHer)), - & nHer,ABeq) -* -*-----------------Compute the contribution from the multipole moment -* operator -* - ABeq(1) = .False. - ABeq(2) = .False. - ABeq(3) = .False. - Call CrtCmp(Array(ipZ),Array(ipPx),nZeta,TC, - & Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)), - & nHer,ABeq) -* -*-----------------Compute the cartesian components for the multipole -* moment integrals. The integrals are factorized into -* components. -* - Call Assmbl(Array(ipQxyz), - & Array(ipAxyz),la, - & Array(ipRxyz),nOrdOp, - & Array(ipBxyz),lb, - & nZeta,HerW(iHerW(nHer)),nHer) -* -*-----------------Combine the cartesian components to the full one -* electron integral. -* - Call CmbnMP(Array(ipQxyz),nZeta,la,lb,nOrdOp, - & Array(ipZ),Array(ipK),Array(ipRes),nComp) - If (iPrint.ge.99) Then - Write (6,*) ' Intermediate result in PAM2Int' - Do 9101 ia = 1, nElem(la) - Do 9201 ib = 1, nElem(lb) - iab = (ib-1)*nElem(la) + ia - ipab = (iab-1)*nZeta + ipRes - Write (Label,'(A,I2,A,I2,A)') - & ' Array(',ia,',',ib,')' - If (nComp.ne.1) Then - Call RecPrt(Label,' ', - & Array(ipab),nZeta,nComp) - Else - Call RecPrt(Label,' ', - & Array(ipab),nAlpha,nBeta) - End If - 9201 Continue - 9101 Continue - End If -* -*-----------------Multiply result by Zeff*Const -* - Factor = -dbsc(kCnttp)%Charge*PAMexp(iM2xp,2) - & * Fact -* -* FOR DMFT calculation!!! -* -c write(6,*) ' Cff',PAMexp(iM2xp,2) - Factor = 1.00d0*Fact*PAMexp(iM2xp,2) - If (iPrint.ge.99) Write (6,*) ' Factor=',Factor - Call DaXpY_(nZeta*nElem(la)*nElem(lb)*nComp,Factor, - & Array(ipRes),1,Work(ipScr),1) -* - 1011 Continue -* -*-----------------Accumulate contributions -* - nOp = NrOpr(iDCRT(lDCRT)) - Call SymAdO(Work(ipScr),nZeta,la,lb,nComp,Final, - & nIC,nOp,lOper,iChO,One) - Call GetMem(' Scr','FREE','REAL',ipScr, - & nZeta*nElem(la)*nElem(lb)*nComp) -* - 102 Continue - 101 Continue - 111 kdc = kdc + dbsc(kCnttp)%nCntr -* -c If (nOrdOp.eq.1) Then - If (iPrint.ge.99) Then - Write (6,*) ' Result in PAM2Int' - Do 9100 ia = 1, nElem(la) - Do 9200 ib = 1, nElem(lb) - Write (Label,'(A,I2,A,I2,A)') - & ' Final(ia=',ia,',ib=',ib,')' - Call RecPrt(Label,' ',Final(1,ia,ib,1),nAlpha,nBeta) - 9200 Continue - 9100 Continue - End If -* -* Call GetMem(' Exit PAM2Int','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - Call Unused_real_array(Alpha) - Call Unused_real_array(Beta) - Call Unused_real_array(ZInv) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/pam2int.F90 openmolcas-22.10/src/oneint_util/pam2int.F90 --- openmolcas-22.02/src/oneint_util/pam2int.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/pam2int.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,215 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993, Roland Lindh * +! 1993, Per Boussard * +!*********************************************************************** + +subroutine PAM2Int( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of PAM integrals used in * +! PAM calculations. The operator is a gaussian type function * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, Sweden, and Per Boussard, Dept. of Theoretical * +! Physics, University of Stockholm, Sweden, October '93. * +!*********************************************************************** + +use Basis_Info, only: dbsc, PAMexp +use Center_Info, only: dc +use Her_RW, only: HerR, HerW, iHerR, iHerW +use PAM2, only: iPAMPrim, kCnttpPAM +use Index_Functions, only: nTri_Elem1 +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "print.fh" +integer(kind=iwp) :: ia, iab, ib, iDCRT(0:7), ikdc, iM2xp, ipab, ipAxyz, ipBxyz, ipK, ipPx, ipPy, ipPz, ipQxyz, ipRes, iPrint, & + ipRxyz, ipZ, iRout, iZeta, kCnt, kCnttp, kdc, lDCRT, LmbdT, nDCRT, nip, nOp +real(kind=wp) :: C(3), Fact, Factor, Gmma, PTC2, TC(3), Tmp0, Tmp1 +character(len=80) :: Label +logical(kind=iwp) :: ABeq(3) +real(kind=wp), allocatable :: Scr(:) +integer(kind=iwp), external :: NrOpr + +#include "macros.fh" +unused_var(Alpha) +unused_var(Beta) +unused_var(ZInv) +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 122 +iPrint = nPrint(iRout) + +nip = 1 +ipAxyz = nip +nip = nip+nZeta*3*nHer*(la+1) +ipBxyz = nip +nip = nip+nZeta*3*nHer*(lb+1) +ipRxyz = nip +nip = nip+nZeta*3*nHer*(nOrdOp+1) +ipQxyz = nip +nip = nip+nZeta*3*(la+1)*(lb+1)*(nOrdOp+1) +ipK = nip +nip = nip+nZeta +ipZ = nip +nip = nip+nZeta +ipPx = nip +nip = nip+nZeta +ipPy = nip +nip = nip+nZeta +ipPz = nip +nip = nip+nZeta +ipRes = nip +nip = nip+nZeta*nComp*nTri_Elem1(la)*nTri_Elem1(lb) +if (nip-1 > nArr*nZeta) then + call WarningMessage(2,'PAM2Int: nip-1 > nArr*nZeta') + write(u6,*) ' nArr is Wrong! ',nip-1,' > ',nArr*nZeta + write(u6,*) ' Abend in PAM2Int' + call Abend() +end if + +if (iPrint >= 49) then + call RecPrt(' In PAM2Int: A',' ',A,1,3) + call RecPrt(' In PAM2Int: RB',' ',RB,1,3) + call RecPrt(' In PAM2Int: Ccoor',' ',Ccoor,1,3) + call RecPrt(' In PAM2Int: Kappa',' ',rKappa,nAlpha,nBeta) + call RecPrt(' In PAM2Int: Zeta',' ',Zeta,nAlpha,nBeta) + call RecPrt(' In PAM2Int: P',' ',P,nZeta,3) + write(u6,*) ' In PAM2Int: la,lb,nHer=',la,lb,nHer +end if + +rFinal(:,:,:,:) = Zero + +! Loop over nuclear centers + +kdc = 0 +if (kCnttpPAM > 1) then + do ikdc=1,kCnttpPAM-1 + kdc = kdc+dbsc(ikdc)%nCntr + end do +end if + +kCnttp = kCnttpPAM + +call mma_allocate(Scr,nZeta*nTri_Elem1(la)*nTri_Elem1(lb)*nComp,label='Scr') +do kCnt=1,dbsc(kCnttp)%nCntr + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + + call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) + Fact = real(nStabM,kind=wp)/real(LmbdT,kind=wp) + + do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),C,TC) + + Scr(:) = Zero + do iM2xp=1,iPAMPrim + Gmma = PAMexp(iM2xp,1) + + if (iPrint >= 99) write(u6,*) ' Gamma=',Gmma + + ! Modify the original basis. + + do iZeta=1,nZeta + PTC2 = (P(iZeta,1)-TC(1))**2+(P(iZeta,2)-TC(2))**2+(P(iZeta,3)-TC(3))**2 + Tmp0 = Zeta(iZeta)+Gmma + Tmp1 = exp(-Zeta(iZeta)*Gmma*PTC2/Tmp0) + Array(ipK+iZeta-1) = rKappa(iZeta)*Tmp1 + Array(ipZ+iZeta-1) = Tmp0 + Array(ipPx+iZeta-1) = (Zeta(iZeta)*P(iZeta,1)+Gmma*TC(1))/Tmp0 + Array(ipPy+iZeta-1) = (Zeta(iZeta)*P(iZeta,2)+Gmma*TC(2))/Tmp0 + Array(ipPz+iZeta-1) = (Zeta(iZeta)*P(iZeta,3)+Gmma*TC(3))/Tmp0 + end do + if (iPrint >= 99) then + write(u6,*) ' The modified basis set' + call RecPrt(' In PAM2Int: Kappa',' ',Array(ipK),nAlpha,nBeta) + call RecPrt(' In PAM2Int: Zeta',' ',Array(ipZ),nAlpha,nBeta) + call RecPrt(' In PAM2Int: P',' ',Array(ipPx),nZeta,3) + end if + + ! Compute the cartesian values of the basis functions angular part + + ABeq(:) = (A == RB) .and. (A == TC) + call CrtCmp(Array(ipZ),Array(ipPx),nZeta,A,Array(ipAxyz),la,HerR(iHerR(nHer)),nHer,ABeq) + call CrtCmp(Array(ipZ),Array(ipPx),nZeta,RB,Array(ipBxyz),lb,HerR(iHerR(nHer)),nHer,ABeq) + + ! Compute the contribution from the multipole moment operator + + ABeq(:) = .false. + call CrtCmp(Array(ipZ),Array(ipPx),nZeta,TC,Array(ipRxyz),nOrdOp,HerR(iHerR(nHer)),nHer,ABeq) + + ! Compute the cartesian components for the multipole moment + ! integrals. The integrals are factorized into components. + + call Assmbl(Array(ipQxyz),Array(ipAxyz),la,Array(ipRxyz),nOrdOp,Array(ipBxyz),lb,nZeta,HerW(iHerW(nHer)),nHer) + + ! Combine the cartesian components to the full one electron integral. + + call CmbnMP(Array(ipQxyz),nZeta,la,lb,nOrdOp,Array(ipZ),Array(ipK),Array(ipRes),nComp) + if (iPrint >= 99) then + write(u6,*) ' Intermediate result in PAM2Int' + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb) + iab = (ib-1)*nTri_Elem1(la)+ia + ipab = (iab-1)*nZeta+ipRes + write(Label,'(A,I2,A,I2,A)') ' Array(',ia,',',ib,')' + if (nComp /= 1) then + call RecPrt(Label,' ',Array(ipab),nZeta,nComp) + else + call RecPrt(Label,' ',Array(ipab),nAlpha,nBeta) + end if + end do + end do + end if + + ! Multiply result by Zeff*Const + + Factor = -dbsc(kCnttp)%Charge*PAMexp(iM2xp,2)*Fact + + ! FOR DMFT calculation!!! + + !write(u6,*) ' Cff',PAMexp(iM2xp,2) + Factor = Fact*PAMexp(iM2xp,2) + if (iPrint >= 99) write(u6,*) ' Factor=',Factor + Scr(:) = Scr+Factor*Array(ipRes:ipRes+size(Scr)-1) + + end do + + ! Accumulate contributions + + nOp = NrOpr(iDCRT(lDCRT)) + call SymAdO(Scr,nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,One) + + end do +end do +call mma_deallocate(Scr) + +!if (nOrdOp == 1) then +if (iPrint >= 99) then + write(u6,*) ' Result in PAM2Int' + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb) + write(Label,'(A,I2,A,I2,A)') ' rFinal(ia=',ia,',ib=',ib,')' + call RecPrt(Label,' ',rFinal(:,ia,ib,1),nAlpha,nBeta) + end do + end do +end if + +return + +end subroutine PAM2Int diff -Nru openmolcas-22.02/src/oneint_util/pam2mem.F90 openmolcas-22.10/src/oneint_util/pam2mem.F90 --- openmolcas-22.02/src/oneint_util/pam2mem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/pam2mem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,44 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993, Roland Lindh * +!*********************************************************************** + +subroutine PAM2Mem( & +# define _CALLING_ +# include "mem_interface.fh" + ) +!*********************************************************************** +! Object: to compute the number of real*8 the kernel routine will * +! need for the computation of a matrix element between two * +! cartesian Gaussian functions with the total angular momentum* +! of la and lb (la=0 s-function, la=1 p-function, etc.) * +! lr is the order of the operator (this is only used when the * +! integrals are computed with the Hermite-Gauss quadrature). * +! * +! Called from: OneEl * +! * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: nComp + +nComp = nTri_Elem1(lr) + +nHer = (la+lb+lr+2)/2 +Mem = 3*nHer*(la+1)+3*nHer*(lb+1)+3*nHer*(lr+1)+3*(la+1)*(lb+1)*(lr+1)+5+nTri_Elem1(la)*nTri_Elem1(lb)*nComp + +return + +end subroutine PAM2Mem diff -Nru openmolcas-22.02/src/oneint_util/p_int.f openmolcas-22.10/src/oneint_util/p_int.f --- openmolcas-22.02/src/oneint_util/p_int.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/p_int.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,83 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine P_Int ( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: to compute the multipole moments integrals with the * -* Gauss-Hermite quadrature. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* November '90 * -* Modified to multipole moments November '90 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "oneswi.fh" -#include "print.fh" - -#include "int_interface.fh" - -* Local variables - Character*80 Label -* -* Statement function for Cartesian index -* - nElem(i) = (i+1)*(i+2)/2 -* - iRout = 122 - iPrint = nPrint(iRout) -* -*---- Observe that this code does not make any sense in case of symmetry! -* - call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) -* - If (iPrint.ge.99) Then - Write (6,*) ' Result in P_Int' - Do ia = 1, nElem(la) - Do ib = 1, nElem(lb) - Do iIC = 1, nIC - Write (Label,'(A,I2,A,I2,A,I2,A)') - & ' Final(a=',ia,',b=',ib,',iIC=',iIC,')' - Call RecPrt(Label,' ',Final(1,ia,ib,iIC),nAlpha,nBeta) - End Do - End Do - End Do - End If -* -* Call GetMem(' Exit P_Int','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Alpha) - Call Unused_real_array(Beta) - Call Unused_real_array(Zeta) - Call Unused_real_array(ZInv) - Call Unused_real_array(rKappa) - Call Unused_real_array(P) - Call Unused_real_array(A) - Call Unused_real_array(RB) - Call Unused_integer(nHer) - Call Unused_real_array(Array) - Call Unused_real_array(Ccoor) - Call Unused_integer(nOrdOp) - Call Unused_integer_array(lOper) - Call Unused_integer_array(iChO) - Call Unused_integer_array(iStabM) - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/p_int.F90 openmolcas-22.10/src/oneint_util/p_int.F90 --- openmolcas-22.02/src/oneint_util/p_int.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/p_int.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,77 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine P_Int( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the multipole moments integrals with the * +! Gauss-Hermite quadrature. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! November '90 * +! Modified to multipole moments November '90 * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "print.fh" +integer(kind=iwp) :: ia, ib, iIC, iPrint, iRout +character(len=80) :: Label + +#include "macros.fh" +unused_var(Alpha) +unused_var(Beta) +unused_var(Zeta) +unused_var(ZInv) +unused_var(rKappa) +unused_var(P) +unused_var(A) +unused_var(RB) +unused_var(nHer) +unused_var(Array) +unused_var(Ccoor) +unused_var(nOrdOp) +unused_var(lOper) +unused_var(iChO) +unused_var(iStabM) +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 122 +iPrint = nPrint(iRout) +! Observe that this code does not make any sense in case of symmetry! +rFinal(:,:,:,:) = Zero + +if (iPrint >= 99) then + write(u6,*) ' Result in P_Int' + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb) + do iIC=1,nIC + write(Label,'(A,I2,A,I2,A,I2,A)') ' rFinal(a=',ia,',b=',ib,',iIC=',iIC,')' + call RecPrt(Label,' ',rFinal(:,ia,ib,iIC),nAlpha,nBeta) + end do + end do + end do +end if + +return + +end subroutine P_Int diff -Nru openmolcas-22.02/src/oneint_util/p_mem.f openmolcas-22.10/src/oneint_util/p_mem.f --- openmolcas-22.02/src/oneint_util/p_mem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/p_mem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,27 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine P_Mem( -#define _CALLING_ -#include "mem_interface.fh" - &) -#include "mem_interface.fh" -* - Mem=1 -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(nHer) - Call Unused_integer(la) - Call Unused_integer(lb) - Call Unused_integer(lr) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/p_mem.F90 openmolcas-22.10/src/oneint_util/p_mem.F90 --- openmolcas-22.02/src/oneint_util/p_mem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/p_mem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,32 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine P_Mem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" + +#include "macros.fh" +unused_var(la) +unused_var(lb) +unused_var(lr) + +Mem = 1 +nHer = 0 + +return + +end subroutine P_Mem diff -Nru openmolcas-22.02/src/oneint_util/potint.f openmolcas-22.10/src/oneint_util/potint.f --- openmolcas-22.02/src/oneint_util/potint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/potint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,180 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine PotInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of potential integrals * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, Sweden, January '91 * -************************************************************************ - use Phase_Info - Implicit Real*8 (A-H,O-Z) -* Used for normal nuclear attraction integrals - External TNAI, Fake, XCff2D, XRys2D -#include "real.fh" -#include "oneswi.fh" -#include "print.fh" - -#include "int_interface.fh" - -*-----Local variables - Integer iStabO(0:7), iPh(3), iAnga(4), iDCRT(0:7) - Real*8 TC(3), Coora(3,4), Coori(3,4), CoorAC(3,2) - Logical EQ, NoSpecial -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - nabSz(ixyz) = (ixyz+1)*(ixyz+2)*(ixyz+3)/6 - 1 -* - Call fzero(final,nZeta*nElem(la)*nElem(lb)*nIC) -* - iAnga(1) = la - iAnga(2) = lb - iAnga(3) = 0 - iAnga(4) = 0 - call dcopy_(3,A,1,Coora(1,1),1) - call dcopy_(3,RB,1,Coora(1,2),1) - call dcopy_(2*3,Coora,1,Coori,1) - mabMin = nabSz(Max(la,lb)-1)+1 - mabMax = nabSz(la+lb) - If (EQ(A,RB)) mabMin=nabSz(la+lb-1)+1 -* -* Compute FLOP's and size of work array which Hrr will use. -* - Call mHrr(la,lb,nFLOP,nMem) -* -* Find center to accumulate angular momentum on. (HRR) -* - If (la.ge.lb) Then - call dcopy_(3,A,1,CoorAC(1,1),1) - Else - call dcopy_(3,RB,1,CoorAC(1,1),1) - End If -* - llOper = lOper(1) -* -* Loop over grid -* -*-----------Find the DCR for M and S -* - Call SOS(iStabO,nStabO,llOper) - Call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) -c Fact = DBLE(nStabM) / DBLE(LmbdT) - FACT=1.D0 - - nT = nZeta - Chrg=-1.d0 - NoSpecial=.True. -* - Do lDCRT = 0, nDCRT-1 - - Do i = 1, 3 - iph(i) = iPhase(i,iDCRT(lDCRT)) - End Do - nOp = NrOpr(iDCRT(lDCRT)) - - Do 100 iGrid = 1, nGrid - If (iAddPot.ne.0) Chrg=ptchrg(iGrid) - If (Chrg.eq.Zero) Go To 100 -* - Do i = 1, 3 - TC(i)=DBLE(iPh(i))*CCoor(i,iGrid) - CoorAC(i,2)=TC(i) - Coori(i,3)=TC(i) - Coori(i,4)=TC(i) - Coora(i,3)=TC(i) - Coora(i,4)=TC(i) - End Do -* -* Compute integrals with the Rys quadrature. -* - Call Rys(iAnga,nT,Zeta,ZInv,nZeta, - & [One],[One],1,P,nZeta, - & TC,1,rKappa,[One],Coori,Coora,CoorAC, - & mabmin,mabmax,0,0,Array,nArr*nZeta, - & TNAI,Fake,XCff2D,XRys2D,NoSpecial) -* -*--------------Use the HRR to compute the required primitive integrals. -* - Call HRR(la,lb,A,RB,Array,nZeta,nMem,ipIn) -* -*--------------Accumulate contributions to the symmetry adapted operator -* - Call SymAdO(Array(ipIn),nZeta,la,lb,nComp,Final,nIC, - & nOp,lOper,iChO,-Fact*Chrg) - 100 Continue - End Do -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Alpha) - Call Unused_real_array(Beta) - Call Unused_integer(nHer) - Call Unused_integer(nOrdOp) - End If - End - SubRoutine Pot_nuc(CCoor,pot,nGrid) - use Basis_Info - use Center_Info - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - Real*8 CCoor(3,nGrid),pot(nGrid) - Real*8 C(3), TC(3) - Integer iStabM(0:7),iDCRT(0:7) -* -* compute nuclear contribution to potential -* - kdc = 0 - Do iGrid=1,nGrid - pot(iGrid)=0d0 - End Do -* -chjw is this always correct? - istabm(0)=0 - nstabm=1 -* - Do 100 kCnttp = 1, nCnttp - If (dbsc(kCnttp)%Charge.eq.Zero) Go To 111 -* - Do 101 kCnt = 1, dbsc(kCnttp)%nCntr -* - C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) - Call DCR(LmbdT,iStabM,nStabM, - & dc(kdc+kCnt)%iStab ,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) - Fact = DBLE(nStabM) / DBLE(LmbdT) -* - Do lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),C,TC) -* - Do iGrid=1,nGrid - r12=sqrt((TC(1)-CCoor(1,iGrid))**2 - & +(TC(2)-CCoor(2,iGrid))**2 - & +(TC(3)-CCoor(3,iGrid))**2) - if(r12.gt.1.d-8) - & pot(iGrid)=pot(iGrid)+dbsc(kCnttp)%Charge*fact/r12 - End Do -* - End Do - 101 Continue - 111 kdc = kdc + dbsc(kCnttp)%nCntr - 100 Continue -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/potint.F90 openmolcas-22.10/src/oneint_util/potint.F90 --- openmolcas-22.02/src/oneint_util/potint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/potint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,122 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine PotInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of potential integrals * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, Sweden, January '91 * +!*********************************************************************** + +use Phase_Info, only: iPhase +use Index_Functions, only: nTri3_Elem1, nTri_Elem1 +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +#include "int_interface.fh" +integer(kind=iwp) :: i, iAnga(4), iDCRT(0:7), iGrid, iPh(3), ipIn, iStabO(0:7), lDCRT, llOper, LmbdT, mabMax, mabMin, nDCRT, & + nFLOP, nMem, nOp, nStabO, nT +real(kind=wp) :: Chrg, Coora(3,4), CoorAC(3,2), Coori(3,4), FACT, TC(3) +logical(kind=iwp) :: NoSpecial +integer(kind=iwp), external :: NrOpr +logical(kind=iwp), external :: EQ +external :: Fake, TNAI, XCff2D, XRys2D + +#include "macros.fh" +unused_var(Alpha) +unused_var(Beta) +unused_var(nHer) +unused_var(nOrdOp) + +rFinal(:,:,:,:) = Zero + +iAnga(1) = la +iAnga(2) = lb +iAnga(3) = 0 +iAnga(4) = 0 +Coora(:,1) = A +Coora(:,2) = RB +Coori(:,1:2) = Coora(:,1:2) +mabMin = nTri3_Elem1(max(la,lb)-1) +mabMax = nTri3_Elem1(la+lb)-1 +if (EQ(A,RB)) mabMin = nTri3_Elem1(la+lb-1) + +! Compute FLOP's and size of work array which Hrr will use. + +call mHrr(la,lb,nFLOP,nMem) + +! Find center to accumulate angular momentum on. (HRR) + +if (la >= lb) then + CoorAC(:,1) = A +else + CoorAC(:,1) = RB +end if + +llOper = lOper(1) + +! Loop over grid + +! Find the DCR for M and S + +call SOS(iStabO,nStabO,llOper) +call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) +!Fact = real(nStabM,kind=wp)/real(LmbdT,kind=wp) +FACT = One + +nT = nZeta +Chrg = -One +NoSpecial = .true. + +do lDCRT=0,nDCRT-1 + + iPh(:) = iPhase(:,iDCRT(lDCRT)) + nOp = NrOpr(iDCRT(lDCRT)) + + do iGrid=1,nGrid + if (iAddPot /= 0) Chrg = ptchrg(iGrid) + if (Chrg == Zero) cycle + + do i=1,3 + TC(i) = real(iPh(i),kind=wp)*CCoor(i,iGrid) + CoorAC(i,2) = TC(i) + Coori(i,3) = TC(i) + Coori(i,4) = TC(i) + Coora(i,3) = TC(i) + Coora(i,4) = TC(i) + end do + + ! Compute integrals with the Rys quadrature. + + call Rys(iAnga,nT,Zeta,ZInv,nZeta,[One],[One],1,P,nZeta,TC,1,rKappa,[One],Coori,Coora,CoorAC,mabmin,mabmax,0,0,Array, & + nArr*nZeta,TNAI,Fake,XCff2D,XRys2D,NoSpecial) + + ! Use the HRR to compute the required primitive integrals. + + call HRR(la,lb,A,RB,Array,nZeta,nMem,ipIn) + + ! Accumulate contributions to the symmetry adapted operator + + call SymAdO(Array(ipIn),nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,-Fact*Chrg) + end do +end do + +return + +end subroutine PotInt diff -Nru openmolcas-22.02/src/oneint_util/pot_nuc.F90 openmolcas-22.10/src/oneint_util/pot_nuc.F90 --- openmolcas-22.02/src/oneint_util/pot_nuc.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/pot_nuc.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,61 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine Pot_nuc(CCoor,pot,nGrid) + +use Basis_Info, only: dbsc, nCnttp +use Center_Info, only: dc +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nGrid +real(kind=wp), intent(in) :: CCoor(3,nGrid) +real(kind=wp), intent(out) :: pot(nGrid) +integer(kind=iwp) :: iDCRT(0:7), iGrid, iStabM(0:7), kCnt, kCnttp, kdc, lDCRT, LmbdT, nDCRT, nstabm +real(kind=wp) :: C(3), Fact, r12, TC(3) + +! compute nuclear contribution to potential + +pot(:) = Zero + +!hjw is this always correct? +istabm(0) = 0 +nstabm = 1 + +kdc = 0 +do kCnttp=1,nCnttp + if (kCnttp > 1) kdc = kdc+dbsc(kCnttp-1)%nCntr + if (dbsc(kCnttp)%Charge == Zero) cycle + + do kCnt=1,dbsc(kCnttp)%nCntr + + C(1:3) = dbsc(kCnttp)%Coor(1:3,kCnt) + call DCR(LmbdT,iStabM,nStabM,dc(kdc+kCnt)%iStab,dc(kdc+kCnt)%nStab,iDCRT,nDCRT) + Fact = real(nStabM,kind=wp)/real(LmbdT,kind=wp) + + do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),C,TC) + + do iGrid=1,nGrid + r12 = sqrt((TC(1)-CCoor(1,iGrid))**2+(TC(2)-CCoor(2,iGrid))**2+(TC(3)-CCoor(3,iGrid))**2) + if (r12 > 1.0e-8_wp) pot(iGrid) = pot(iGrid)+dbsc(kCnttp)%Charge*fact/r12 + end do + + end do + end do +end do + +return + +end subroutine Pot_nuc diff -Nru openmolcas-22.02/src/oneint_util/prjint.f openmolcas-22.10/src/oneint_util/prjint.f --- openmolcas-22.02/src/oneint_util/prjint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/prjint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,334 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1993, Roland Lindh * -* 1993, Per Boussard * -************************************************************************ - SubRoutine PrjInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of ECP integrals. * -* * -* Alpha : exponents of bra gaussians * -* nAlpha: number of primitives (exponents) of bra gaussians * -* Beta : as Alpha but for ket gaussians * -* nBeta : as nAlpha but for the ket gaussians * -* Zeta : sum of exponents (nAlpha x nBeta) * -* ZInv : inverse of Zeta * -* rKappa: gaussian prefactor for the products of bra and ket * -* gaussians. * -* P : center of new gaussian from the products of bra and ket * -* gaussians. * -* Final : array for computed integrals * -* nZeta : nAlpha x nBeta * -* nComp : number of components in the operator (e.g. dipolmoment * -* operator has three components) * -* la : total angular momentum of bra gaussian * -* lb : total angular momentum of ket gaussian * -* A : center of bra gaussian * -* B : center of ket gaussian * -* nRys : order of Rys- or Hermite-Gauss polynomial * -* Array : Auxiliary memory as requested by ECPMem * -* nArr : length of Array * -* Ccoor : coordinates of the operator, zero for symmetric oper. * -* NOrdOp: Order of the operator * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, Sweden, and Per Boussard, Dept. of Theoretical * -* Physics, University of Stockholm, Sweden, October '93. * -************************************************************************ - use Basis_Info - use Center_Info - use Real_Spherical - use Symmetry_Info, only: nIrrep, iChTbl - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - -#include "int_interface.fh" - -* Local varables - Real*8 C(3), TC(3) - Integer iDCRT(0:7), iTwoj(0:7) -!#define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Character*80 Label -#endif - Data iTwoj/1,2,4,8,16,32,64,128/ -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* -#ifdef _DEBUGPRINT_ - Call RecPrt(' In PrjInt: Zeta',' ',Zeta,1,nZeta) - Call RecPrt(' In PrjInt: A',' ',A,1,3) - Call RecPrt(' In PrjInt: RB',' ',RB,1,3) - Call RecPrt(' In PrjInt: Ccoor',' ',Ccoor,1,3) - Call RecPrt(' In PrjInt: P',' ',P,nZeta,3) - Write (6,*) ' In PrjInt: la,lb=',' ',la,lb -#endif -* -* call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) - Final(:,:,:,:)=Zero -* - llOper = lOper(1) - iComp = 1 - mdc = 0 - Do iCnttp = 1, nCnttp - If (.Not.dbsc(iCnttp)%ECP) Then - mdc = mdc + dbsc(iCnttp)%nCntr - Cycle - End If - Do iCnt = 1,dbsc(iCnttp)%nCntr - C(1:3) = dbsc(iCnttp)%Coor(1:3,iCnt) -* - Call DCR(LmbdT,iStabM,nStabM, - & dc(mdc+iCnt)%iStab,dc(mdc+iCnt)%nStab,iDCRT,nDCRT) - Fact = DBLE(nStabM) / DBLE(LmbdT) -* - Do lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),C,TC) - Do iAng = 0, dbsc(iCnttp)%nPrj-1 - iShll = dbsc(iCnttp)%iPrj + iAng - nExpi=Shells(iShll)%nExp - nBasisi=Shells(iShll)%nBasis - If (nExpi.eq.0 .or. nBasisi.eq.0) Cycle -* -#ifdef _DEBUGPRINT_ - Call RecPrt('Cff',' ',Shells(iShll)%pCff,nExpi, - & nBasisi) -#endif - ip = 1 - ipF1 = ip - nac = nElem(la)*nElem(iAng) - ip = ip + nAlpha*nExpi*nac - ipP1 = ip - ip = ip + 3 * nAlpha*nExpi - ipZ1 = ip - ip = ip + nAlpha*nExpi - ipK1 = ip - ip = ip + nAlpha*nExpi - ipZI1 = ip - ip = ip + nAlpha*nExpi - If (ip-1.gt.nArr*nZeta) Then - Call WarningMessage(2,'PrjInt: ip-1.gt.nArr*nZeta(1)') - Call Abend() - End If - mArr = (nArr*nZeta-(ip-1))/nZeta -* -*--------------Calculate Effective center and exponent for -* - Call ZXia(Array(ipZ1),Array(ipZI1),nAlpha,nExpi, - & Alpha,Shells(iShll)%Exp) - Call SetUp1(Alpha,nAlpha,Shells(iShll)%Exp,nExpi, - & A,TC,Array(ipK1),Array(ipP1),Array(ipZI1)) -* -*--------------Calculate Overlap -* - nHer = (la+iAng+2)/2 - Call MltPrm(Alpha,nAlpha,Shells(iShll)%Exp,nExpi, - & Array(ipZ1),Array(ipZI1), - & Array(ipK1),Array(ipP1), - & Array(ipF1),nAlpha*nExpi,iComp, - & la,iAng,A,TC,nHer,Array(ip), - & mArr,CCoor,nOrdOp) - ip = ip - 6 * nAlpha*nExpi -* - ipF2 = ip - ncb = nElem(iAng)*nElem(lb) - ip = ip + nExpi*nBeta*ncb - ipP2 = ip - ip = ip + 3 * nExpi*nBeta - ipZ2 = ip - ip = ip + nExpi*nBeta - ipK2 = ip - ip = ip + nExpi*nBeta - ipZI2 = ip - ip = ip + nExpi*nBeta - If (ip-1.gt.nArr*nZeta) Then - Call WarningMessage(2,'PrjInt: ip-1.gt.nArr*nZeta(2)') - Call Abend() - End If - mArr = (nArr*nZeta-(ip-1))/nZeta -* -*--------------Calculate Effective center and exponent for -* - Call ZXia(Array(ipZ2),Array(ipZI2),nExpi,nBeta, - & Shells(iShll)%Exp,Beta) - Call SetUp1(Shells(iShll)%Exp,nExpi,Beta,nBeta, - & TC,RB,Array(ipK2),Array(ipP2),Array(ipZI2)) -* -*--------------Calculate Overlap -* - nHer = (iAng+lb+2)/2 - Call MltPrm(Shells(iShll)%Exp,nExpi,Beta,nBeta, - & Array(ipZ2),Array(ipZI2), - & Array(ipK2),Array(ipP2), - & Array(ipF2),nExpi*nBeta,iComp, - & iAng,lb,TC,RB,nHer,Array(ip), - & mArr,CCoor,nOrdOp) - ip = ip - 6 * nExpi*nBeta - ipTmp = ip - ip = ip + Max(nAlpha*nExpi*nac, - & nBeta*ncb*nBasisi) - If (ip-1.gt.nArr*nZeta) Then - Call WarningMessage(2,'PrjInt: ip-1.gt.nArr*nZeta(3)') - Call Abend() - End If -* -*--------------Calculate Contraction over components of the core -* orbitals of type Bc where we now have in -* Array(ipF1) the cartesian components of , and -* similarily, in Array(ipF2), we have stored the cartesian -* components of . Observe that the core orbitals -* orthonomal atomic orbitals. Hence, the transformation -* to the spherical harmonics has to be for normilized -* spherical harminics. -* -*--------------From the lefthandside overlap, form iKaC from ikac by -* 1) i,kac -> k,aci -* - Call DgeTMo(Array(ipF1),nAlpha,nAlpha, - & nExpi*nac,Array(ipTmp),nExpi*nac) -* -*--------------2) aciK = k,aci * k,K -* - Call DGEMM_('T','N', - & nAlpha*nac,nBasisi,nExpi, - & 1.0d0,Array(ipTmp),nExpi, - & Shells(iShll)%pCff,nExpi, - & 0.0d0,Array(ipF1),nAlpha*nac) -* -*--------------3) Mult by shiftoperators aci,K -> Bk(K) * aci,K -* - Do iBk = 1, nBasisi - Bk = Shells(ishll)%Bk(iBk) - Call DScal_(nAlpha*nac,Bk, - & Array(ipF1+(iBk-1)*nAlpha*nac),1) - End Do ! iBk -* -*--------------4) a,ciK -> ciKa -* - Call DgeTMo(Array(ipF1),nElem(la),nElem(la), - & nElem(iAng)*nAlpha*nBasisi, - & Array(ipTmp), - & nElem(iAng)*nAlpha*nBasisi) -* -*--------------5) iKa,C = c,iKa * c,C -* - Call DGEMM_('T','N', - & nAlpha*nBasisi*nElem(la), - & (2*iAng+1),nElem(iAng), - & 1.0d0,Array(ipTmp),nElem(iAng), - & RSph(ipSph(iAng)),nElem(iAng), - & 0.0d0,Array(ipF1), - & nAlpha*nBasisi*nElem(la)) -* -*--------------And (almost) the same thing for the righthand side, form -* KjCb from kjcb -* 1) jcb,K = k,jcb * k,K -* - Call DGEMM_('T','N', - & nBeta*ncb,nBasisi,nExpi, - & 1.0d0,Array(ipF2),nExpi, - & Shells(iShll)%pCff,nExpi, - & 0.0d0,Array(ipTmp),nBeta*ncb) -* -*--------------2) j,cbK -> cbK,j -* - Call DgeTMo(Array(ipTmp),nBeta,nBeta, - & nBasisi*ncb,Array(ipF2), - & nBasisi*ncb) -* -*--------------3) bKj,C = c,bKj * c,C -* - Call DGEMM_('T','N', - & nElem(lb)*nBasisi*nBeta, - & (2*iAng+1),nElem(iAng), - & 1.0d0,Array(ipF2),nElem(iAng), - & RSph(ipSph(iAng)),nElem(iAng), - & 0.0d0,Array(ipTmp), - & nElem(lb)*nBasisi*nBeta) -* -*--------------4) b,KjC -> KjC,b -* - Call DgeTMo(Array(ipTmp),nElem(lb),nElem(lb), - & nBasisi*nBeta*(2*iAng+1),Array(ipF2), - & nBasisi*nBeta*(2*iAng+1)) -* -*--------------Next Contract (iKaC)*(KjCb) over K and C, producing ijab, -* by the following procedure: -* Loop over a and b -* Loop over C -* Contract iK(aC)*Kj(Cb), over K producing ij(aCb), -* accumulate to ij(ab) -* End loop C -* End Loop b and a -* - Do ib = 1, nElem(lb) - Do ia = 1, nElem(la) -* - Do iC = 1, (2*iAng+1) - iaC = (iC-1)*nElem(la) + ia - ipaC = (iaC-1)*nAlpha*nBasisi + ipF1 - iCb = (ib-1)*(2*iAng+1) + iC - ipCb = (iCb-1)*nBasisi*nBeta + ipF2 -* - iIC = 0 - Do iIrrep = 0, nIrrep-1 - If (iAnd(llOper,iTwoj(iIrrep)).eq.0) Cycle - iIC = iIC + 1 - nOp = NrOpr(iDCRT(lDCRT)) - Xg=DBLE(iChTbl(iIrrep,nOp )) - Factor=Xg*Fact - Call DGEMM_('N','N', - & nAlpha,nBeta,nBasisi, - & Factor,Array(ipaC),nAlpha, - & Array(ipCb),nBasisi, - & One,Final(1,ia,ib,iIC),nAlpha) - End Do ! iIrrep -* - End Do ! iC - End Do ! ia - End Do ! ib - End Do ! iAng -* - End Do ! lDCRT - End Do ! iCnt - mdc = mdc + dbsc(iCnttp)%nCntr - End Do ! iCnttp -* -#ifdef _DEBUGPRINT_ - Write (6,*) ' Result in PrjInt' - Do 100 ia = 1, (la+1)*(la+2)/2 - Do 200 ib = 1, (lb+1)*(lb+2)/2 - Write (Label,'(A,I2,A,I2,A)') - & ' Final(',ia,',',ib,')' - Call RecPrt(Label,' ',Final(1,ia,ib,1),nAlpha,nBeta) - 200 Continue - 100 Continue -#endif -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(P) - Call Unused_real_array(Zeta) - Call Unused_real_array(ZInv) - Call Unused_real_array(rKappa) - Call Unused_integer(nRys) - Call Unused_integer_array(iChO) - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/prjint.F90 openmolcas-22.10/src/oneint_util/prjint.F90 --- openmolcas-22.02/src/oneint_util/prjint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/prjint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,260 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993, Roland Lindh * +! 1993, Per Boussard * +!*********************************************************************** + +subroutine PrjInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of ECP integrals. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, Sweden, and Per Boussard, Dept. of Theoretical * +! Physics, University of Stockholm, Sweden, October '93. * +!*********************************************************************** + +use Basis_Info, only: dbsc, nCnttp, Shells +use Center_Info, only: dc +use Real_Spherical, only: ipSph, RSph +use Symmetry_Info, only: iChTbl, nIrrep +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +#include "int_interface.fh" +integer(kind=iwp) :: ia, iaC, iAng, ib, iBk, iC, iCb, iCnt, iCnttp, iComp, iDCRT(0:7), iIC, iIrrep, ip, ipaC, ipCb, ipF1, ipf2, & + ipK1, ipK2, ipOff, ipP1, ipP2, ipTmp, ipZ1, ipZ2, ipZI1, ipZI2, iShll, lDCRT, llOper, LmbdT, mArr, mdc, nac, & + nBasisi, ncb, nDCRT, nExpi, nOp +real(kind=wp) :: C(3), Fact, Factor, TC(3), Xg +!#define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +character(len=80) :: Label +#endif +integer(kind=iwp), external :: NrOpr + +#include "macros.fh" +unused_var(P) +unused_var(Zeta) +unused_var(ZInv) +unused_var(rKappa) +unused_var(iChO) +unused_var(PtChrg) +unused_var(iAddPot) + +#ifdef _DEBUGPRINT_ +call RecPrt(' In PrjInt: A',' ',A,1,3) +call RecPrt(' In PrjInt: RB',' ',RB,1,3) +call RecPrt(' In PrjInt: Ccoor',' ',Ccoor,1,3) +write(u6,*) ' In PrjInt: la,lb=',' ',la,lb +#endif + +rFinal(:,:,:,:) = Zero + +llOper = lOper(1) +iComp = 1 +mdc = 0 +do iCnttp=1,nCnttp + if (dbsc(iCnttp)%ECP) then + do iCnt=1,dbsc(iCnttp)%nCntr + C(1:3) = dbsc(iCnttp)%Coor(1:3,iCnt) + + call DCR(LmbdT,iStabM,nStabM,dc(mdc+iCnt)%iStab,dc(mdc+iCnt)%nStab,iDCRT,nDCRT) + Fact = real(nStabM,kind=wp)/real(LmbdT,kind=wp) + + do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),C,TC) + do iAng=0,dbsc(iCnttp)%nPrj-1 + iShll = dbsc(iCnttp)%iPrj+iAng + nExpi = Shells(iShll)%nExp + nBasisi = Shells(iShll)%nBasis + if ((nExpi == 0) .or. (nBasisi == 0)) cycle + +# ifdef _DEBUGPRINT_ + call RecPrt('Cff',' ',Shells(iShll)%pCff,nExpi,nBasisi) +# endif + ip = 1 + ipF1 = ip + nac = nTri_Elem1(la)*nTri_Elem1(iAng) + ip = ip+nAlpha*nExpi*nac + ipP1 = ip + ip = ip+3*nAlpha*nExpi + ipZ1 = ip + ip = ip+nAlpha*nExpi + ipK1 = ip + ip = ip+nAlpha*nExpi + ipZI1 = ip + ip = ip+nAlpha*nExpi + if (ip-1 > nArr*nZeta) then + call WarningMessage(2,'PrjInt: ip-1 > nArr*nZeta(1)') + call Abend() + end if + mArr = (nArr*nZeta-(ip-1))/nZeta + + ! Calculate Effective center and exponent for + + call ZXia(Array(ipZ1),Array(ipZI1),nAlpha,nExpi,Alpha,Shells(iShll)%Exp) + call SetUp1(Alpha,nAlpha,Shells(iShll)%Exp,nExpi,A,TC,Array(ipK1),Array(ipP1),Array(ipZI1)) + + ! Calculate Overlap + + nHer = (la+iAng+2)/2 + call MltPrm(Alpha,nAlpha,Shells(iShll)%Exp,nExpi,Array(ipZ1),Array(ipZI1),Array(ipK1),Array(ipP1),Array(ipF1), & + nAlpha*nExpi,iComp,la,iAng,A,TC,nHer,Array(ip),mArr,CCoor,nOrdOp) + ip = ip-6*nAlpha*nExpi + + ipF2 = ip + ncb = nTri_Elem1(iAng)*nTri_Elem1(lb) + ip = ip+nExpi*nBeta*ncb + ipP2 = ip + ip = ip+3*nExpi*nBeta + ipZ2 = ip + ip = ip+nExpi*nBeta + ipK2 = ip + ip = ip+nExpi*nBeta + ipZI2 = ip + ip = ip+nExpi*nBeta + if (ip-1 > nArr*nZeta) then + call WarningMessage(2,'PrjInt: ip-1 > nArr*nZeta(2)') + call Abend() + end if + mArr = (nArr*nZeta-(ip-1))/nZeta + + ! Calculate Effective center and exponent for + + call ZXia(Array(ipZ2),Array(ipZI2),nExpi,nBeta,Shells(iShll)%Exp,Beta) + call SetUp1(Shells(iShll)%Exp,nExpi,Beta,nBeta,TC,RB,Array(ipK2),Array(ipP2),Array(ipZI2)) + + ! Calculate Overlap + + nHer = (iAng+lb+2)/2 + call MltPrm(Shells(iShll)%Exp,nExpi,Beta,nBeta,Array(ipZ2),Array(ipZI2),Array(ipK2),Array(ipP2),Array(ipF2),nExpi*nBeta, & + iComp,iAng,lb,TC,RB,nHer,Array(ip),mArr,CCoor,nOrdOp) + ip = ip-6*nExpi*nBeta + ipTmp = ip + ip = ip+max(nAlpha*nExpi*nac,nBeta*ncb*nBasisi) + if (ip-1 > nArr*nZeta) then + call WarningMessage(2,'PrjInt: ip-1 > nArr*nZeta(3)') + call Abend() + end if + + ! Calculate Contraction over components of the core + ! orbitals of type Bc where we now have in + ! Array(ipF1) the cartesian components of , and + ! similarily, in Array(ipF2), we have stored the cartesian + ! components of . Observe that the core orbitals + ! orthonomal atomic orbitals. Hence, the transformation + ! to the spherical harmonics has to be for normilized + ! spherical harmonics. + + ! From the lefthandside overlap, form iKaC from ikac by + ! 1) i,kac -> k,aci + + call DgeTMo(Array(ipF1),nAlpha,nAlpha,nExpi*nac,Array(ipTmp),nExpi*nac) + + ! 2) aciK = k,aci * k,K + + call DGEMM_('T','N',nAlpha*nac,nBasisi,nExpi,One,Array(ipTmp),nExpi,Shells(iShll)%pCff,nExpi,Zero,Array(ipF1),nAlpha*nac) + + ! 3) Mult by shiftoperators aci,K -> Bk(K) * aci,K + + ipOff = ipF1-1 + do iBk=1,nBasisi + Array(ipOff+1:ipOff+nAlpha*nac) = Shells(ishll)%Bk(iBk)*Array(ipOff+1:ipOff+nAlpha*nac) + ipOff = ipOff+nAlpha*nac + end do ! iBk + + ! 4) a,ciK -> ciKa + + call DgeTMo(Array(ipF1),nTri_Elem1(la),nTri_Elem1(la),nTri_Elem1(iAng)*nAlpha*nBasisi,Array(ipTmp), & + nTri_Elem1(iAng)*nAlpha*nBasisi) + + ! 5) iKa,C = c,iKa * c,C + + call DGEMM_('T','N',nAlpha*nBasisi*nTri_Elem1(la),(2*iAng+1),nTri_Elem1(iAng),One,Array(ipTmp),nTri_Elem1(iAng), & + RSph(ipSph(iAng)),nTri_Elem1(iAng),Zero,Array(ipF1),nAlpha*nBasisi*nTri_Elem1(la)) + + ! And (almost) the same thing for the righthand side, form + ! KjCb from kjcb + ! 1) jcb,K = k,jcb * k,K + + call DGEMM_('T','N',nBeta*ncb,nBasisi,nExpi,One,Array(ipF2),nExpi,Shells(iShll)%pCff,nExpi,Zero,Array(ipTmp),nBeta*ncb) + + ! 2) j,cbK -> cbK,j + + call DgeTMo(Array(ipTmp),nBeta,nBeta,nBasisi*ncb,Array(ipF2),nBasisi*ncb) + + ! 3) bKj,C = c,bKj * c,C + + call DGEMM_('T','N',nTri_Elem1(lb)*nBasisi*nBeta,(2*iAng+1),nTri_Elem1(iAng),One,Array(ipF2),nTri_Elem1(iAng), & + RSph(ipSph(iAng)),nTri_Elem1(iAng),Zero,Array(ipTmp),nTri_Elem1(lb)*nBasisi*nBeta) + + ! 4) b,KjC -> KjC,b + + call DgeTMo(Array(ipTmp),nTri_Elem1(lb),nTri_Elem1(lb),nBasisi*nBeta*(2*iAng+1),Array(ipF2),nBasisi*nBeta*(2*iAng+1)) + + ! Next Contract (iKaC)*(KjCb) over K and C, producing ijab, + ! by the following procedure: + ! Loop over a and b + ! Loop over C + ! Contract iK(aC)*Kj(Cb), over K producing ij(aCb), + ! accumulate to ij(ab) + ! End loop C + ! End Loop b and a + + do ib=1,nTri_Elem1(lb) + do ia=1,nTri_Elem1(la) + + do iC=1,(2*iAng+1) + iaC = (iC-1)*nTri_Elem1(la)+ia + ipaC = (iaC-1)*nAlpha*nBasisi+ipF1 + iCb = (ib-1)*(2*iAng+1)+iC + ipCb = (iCb-1)*nBasisi*nBeta+ipF2 + + iIC = 0 + do iIrrep=0,nIrrep-1 + if (.not. btest(llOper,iIrrep)) cycle + iIC = iIC+1 + nOp = NrOpr(iDCRT(lDCRT)) + Xg = real(iChTbl(iIrrep,nOp),kind=wp) + Factor = Xg*Fact + call DGEMM_('N','N',nAlpha,nBeta,nBasisi,Factor,Array(ipaC),nAlpha,Array(ipCb),nBasisi,One,rFinal(1,ia,ib,iIC), & + nAlpha) + end do ! iIrrep + + end do ! iC + end do ! ia + end do ! ib + end do ! iAng + + end do ! lDCRT + end do ! iCnt + end if + mdc = mdc+dbsc(iCnttp)%nCntr +end do ! iCnttp + +#ifdef _DEBUGPRINT_ +write(u6,*) ' Result in PrjInt' +do ia=1,(la+1)*(la+2)/2 + do ib=1,(lb+1)*(lb+2)/2 + write(Label,'(A,I2,A,I2,A)') ' rFinal(',ia,',',ib,')' + call RecPrt(Label,' ',rFinal(:,ia,ib,1),nAlpha,nBeta) + end do +end do +#endif + +return + +end subroutine PrjInt diff -Nru openmolcas-22.02/src/oneint_util/prjmem.f openmolcas-22.10/src/oneint_util/prjmem.f --- openmolcas-22.02/src/oneint_util/prjmem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/prjmem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,77 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1993, Roland Lindh * -************************************************************************ - Subroutine PrjMem( -#define _CALLING_ -#include "mem_interface.fh" - &) -************************************************************************ -* * -* Object: to compute the number of real*8 the kernel routine will * -* need for the computation of a matrix element between two * -* cartesian Gaussian functions with the total angular momentum* -* of la and lb (la=0 s-function, la=1 p-function, etc.) * -* lr is the order of the operator (this is only used when the * -* integrals are computed with the Hermite-Gauss quadrature). * -* * -* Called from: OneEl * -* * -************************************************************************ -* - use Basis_Info, only: dbsc, nCnttp, Shells -#include "mem_interface.fh" -* - nElem(i) = (i+1)*(i+2)/2 -* - nHer=0 - Mem = 0 - Do 1960 iCnttp = 1, nCnttp - If (.Not.dbsc(iCnttp)%ECP) Cycle - Do 1966 iAng = 0, dbsc(iCnttp)%nPrj-1 - iShll = dbsc(iCnttp)%iPrj + iAng - nExpi=Shells(iShll)%nExp - nBasisi=Shells(iShll)%nBasis - If (nExpi.eq.0 .or. nBasisi.eq.0) Go To 1966 -* - ip = 0 - nac = nElem(la)*nElem(iAng) - ip = ip + nExpi*nac - ip = ip + 3 * nExpi - ip = ip + nExpi - ip = ip + nExpi - ip = ip + nExpi -* - Call MltMmP(nH,MemMlt,la,iAng,lr) - nHer = Max(nH,nHer) - Mem = Max(Mem,ip+nExpi*MemMlt) - ip = ip - 6 * nExpi -* - ncb = nElem(iAng)*nElem(lb) - ip = ip + nExpi*ncb - ip = ip + 3 * nExpi - ip = ip + nExpi - ip = ip + nExpi - ip = ip + nExpi -* - Call MltMmP(nH,MemMlt,iAng,lb,lr) - nHer = Max(nH,nHer) - Mem = Max(Mem,ip+nExpi*MemMlt) - ip = ip - 6 * nExpi -* - ip = ip + Max(nExpi*nac,ncb*nBasisi) - Mem = Max(Mem,ip) -* - 1966 Continue - 1960 Continue -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/prjmem.F90 openmolcas-22.10/src/oneint_util/prjmem.F90 --- openmolcas-22.02/src/oneint_util/prjmem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/prjmem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,83 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993, Roland Lindh * +!*********************************************************************** + +subroutine PrjMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the number of real*8 the kernel routine will * +! need for the computation of a matrix element between two * +! cartesian Gaussian functions with the total angular momentum* +! of la and lb (la=0 s-function, la=1 p-function, etc.) * +! lr is the order of the operator (this is only used when the * +! integrals are computed with the Hermite-Gauss quadrature). * +! * +! Called from: OneEl * +! * +!*********************************************************************** + +use Basis_Info, only: dbsc, nCnttp, Shells +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: iAng, iCnttp, ip, iShll, memMlt, nac, nBasisi, ncb, nExpi, nH + +nHer = 0 +Mem = 0 +do iCnttp=1,nCnttp + if (dbsc(iCnttp)%ECP) then + do iAng=0,dbsc(iCnttp)%nPrj-1 + iShll = dbsc(iCnttp)%iPrj+iAng + nExpi = Shells(iShll)%nExp + nBasisi = Shells(iShll)%nBasis + if ((nExpi == 0) .or. (nBasisi == 0)) cycle + + ip = 0 + nac = nTri_Elem1(la)*nTri_Elem1(iAng) + ip = ip+nExpi*nac + ip = ip+3*nExpi + ip = ip+nExpi + ip = ip+nExpi + ip = ip+nExpi + + call MltMmP(nH,MemMlt,la,iAng,lr) + nHer = max(nH,nHer) + Mem = max(Mem,ip+nExpi*MemMlt) + ip = ip-6*nExpi + + ncb = nTri_Elem1(iAng)*nTri_Elem1(lb) + ip = ip+nExpi*ncb + ip = ip+3*nExpi + ip = ip+nExpi + ip = ip+nExpi + ip = ip+nExpi + + call MltMmP(nH,MemMlt,iAng,lb,lr) + nHer = max(nH,nHer) + Mem = max(Mem,ip+nExpi*MemMlt) + ip = ip-6*nExpi + + ip = ip+max(nExpi*nac,ncb*nBasisi) + Mem = max(Mem,ip) + + end do + end if +end do + +return + +end subroutine PrjMem diff -Nru openmolcas-22.02/src/oneint_util/pvint.f openmolcas-22.10/src/oneint_util/pvint.f --- openmolcas-22.02/src/oneint_util/pvint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/pvint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,130 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1993, Bernd Artur Hess * -************************************************************************ - SubRoutine PVInt( -#define _CALLING_ -#include "int_interface.fh" - & , Kernel) -************************************************************************ -* * -* Object: kernel routine for the computation of pX integrals * -* * -* Author: Bernd Hess, Institut fuer Physikalische und Theoretische * -* Chemie, University of Bonn, Germany, April 1993 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) - External Kernel -#include "real.fh" -#include "print.fh" - -#include "int_interface.fh" -* -* Statement function for Cartesian index -* - nElem(ixyz) = ((ixyz+1)*(ixyz+2))/2 -* * -************************************************************************ -* * -* Interface -* Subroutine Kernel( -*#define _CALLING_ -*#include "int_interface.fh" -* & ) -*#include "int_interface.fh" -* End Subroutine Kernel -* End Interface -* * -************************************************************************ -* * - iRout = 221 - iPrint = nPrint(iRout) -* - If (iPrint.ge.99) Then - Write (6,*) 'PVInt: nIC,nComp=',nIC,nComp - Call RecPrt(' In pvint: Alpha','(5D20.13)',Alpha,nAlpha,1) - Call RecPrt(' In pvint: Beta','(5D20.13)',Beta,nBeta,1) - End If -* - nip = 1 - ipA = nip - nip = nip + nZeta - ipS1 = nip - nip = nip + nZeta*nElem(la+1)*nElem(lb)*nIC - ipS2 = 1 - If (la.gt.0) Then - ipS2 = nip - nip = nip + nZeta*nElem(la-1)*nElem(lb)*nIC - Else - ipS2=ipS1 - End If - ipArr = nip - mArr = nArr-(nip-1)/nZeta - If (mArr.lt.0) Then - Call WarningMessage(2,'pVInt: mArr<0!') - Call Abend() - End If -* * -************************************************************************ -* * -* Compute contribution from a+1,b -* - kRys = ((la+1)+lb+2)/2 - Call Kernel(Alpha,nAlpha,Beta, nBeta,Zeta,ZInv,rKappa,P, - & Array(ipS1),nZeta,nIC,nComp,la+1,lb,A,RB,kRys, - & Array(ipArr),mArr,CCoor,nOrdOp,lOper,iChO, - & iStabM,nStabM, - & PtChrg,nGrid,iAddPot) -* * -************************************************************************ -* * -* Compute contribution from a-1,b -* - If (la.gt.0) Then - kRys = ((la-1)+lb+2)/2 - Call Kernel(Alpha,nAlpha,Beta, nBeta,Zeta,ZInv,rKappa,P, - & Array(ipS2),nZeta,nIC,nComp,la-1,lb,A,RB,kRys, - & Array(ipArr),mArr,CCoor,nOrdOp,lOper,iChO, - & iStabM,nStabM, - & PtChrg,nGrid,iAddPot) - End If -* * -************************************************************************ -* * - ipOff = ipA - Do iBeta = 1, nBeta - call dcopy_(nAlpha,Alpha,1,Array(ipOff),1) - ipOff = ipOff + nAlpha - End Do - If (iPrint.ge.99) Then - Call RecPrt(' In pvint: Alpha (expanded)','(5D20.13)', - & Array(ipA),nZeta,1) - End If -* * -************************************************************************ -* * -* Assemble final integral from the derivative integrals -* - Call Ass_pX(Array(ipA),nZeta,Final,la,lb,Array(ipS1),Array(ipS2), - & nIC) -* * -************************************************************************ -* * - If (iPrint.ge.49) Then - Do i=1,3 - Call RecPrt('pVInt: Final',' ',Final(1,1,1,i), - & nZeta,nElem(la)*nElem(lb)) - End Do - End If - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(nHer) - End diff -Nru openmolcas-22.02/src/oneint_util/pvint.F90 openmolcas-22.10/src/oneint_util/pvint.F90 --- openmolcas-22.02/src/oneint_util/pvint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/pvint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,117 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993, Bernd Artur Hess * +!*********************************************************************** + +subroutine PVInt(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,rFinal,nZeta,nIC,nComp,la,lb,A,RB,nHer,Array,nArr,Ccoor,nOrdOp,lOper, & + iChO,iStabM,nStabM,PtChrg,nGrid,iAddPot,Kernel) +!*********************************************************************** +! * +! Object: kernel routine for the computation of pX integrals * +! * +! (See arguments in int_interface.fh) * +! * +! Author: Bernd Hess, Institut fuer Physikalische und Theoretische * +! Chemie, University of Bonn, Germany, April 1993 * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: wp, iwp, u6 + +implicit none +! TODO: unknown intents, probably all "in" except rFinal (see int_interface.fh) +integer(kind=iwp) :: nAlpha, nBeta, nZeta, nIC, nComp, la, lb, nHer, nArr, nOrdOp, lOper(nComp), iChO(nComp), nStabM, & + iStabM(0:nStabM-1), nGrid, iAddPot +real(kind=wp) :: Alpha(nAlpha), Beta(nBeta), Zeta(nZeta), ZInv(nZeta), rKappa(nZeta), P(nZeta,3), & + rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),nIC), A(3), RB(3), Array(nZeta*nArr), Ccoor(3,nComp), PtChrg(nGrid) +external :: Kernel +#include "print.fh" +integer(kind=iwp) :: i, iBeta, ipA, ipArr, ipOff, iPrint, ipS1, ipS2, iRout, kRys, mArr, nip + +#include "macros.fh" +unused_var(nHer) +! * +!*********************************************************************** +! * +iRout = 221 +iPrint = nPrint(iRout) + +if (iPrint >= 99) then + write(u6,*) 'PVInt: nIC,nComp=',nIC,nComp + call RecPrt(' In pvint: Alpha','(5D20.13)',Alpha,nAlpha,1) + call RecPrt(' In pvint: Beta','(5D20.13)',Beta,nBeta,1) +end if + +nip = 1 +ipA = nip +nip = nip+nZeta +ipS1 = nip +nip = nip+nZeta*nTri_Elem1(la+1)*nTri_Elem1(lb)*nIC +ipS2 = 1 +if (la > 0) then + ipS2 = nip + nip = nip+nZeta*nTri_Elem1(la-1)*nTri_Elem1(lb)*nIC +else + ipS2 = ipS1 +end if +ipArr = nip +mArr = nArr-(nip-1)/nZeta +if (mArr < 0) then + call WarningMessage(2,'pVInt: mArr<0!') + call Abend() +end if +! * +!*********************************************************************** +! * +! Compute contribution from a+1,b + +kRys = ((la+1)+lb+2)/2 +call Kernel(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipS1),nZeta,nIC,nComp,la+1,lb,A,RB,kRys,Array(ipArr),mArr,CCoor, & + nOrdOp,lOper,iChO,iStabM,nStabM,PtChrg,nGrid,iAddPot) +! * +!*********************************************************************** +! * +! Compute contribution from a-1,b + +if (la > 0) then + kRys = ((la-1)+lb+2)/2 + call Kernel(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipS2),nZeta,nIC,nComp,la-1,lb,A,RB,kRys,Array(ipArr),mArr,CCoor, & + nOrdOp,lOper,iChO,iStabM,nStabM,PtChrg,nGrid,iAddPot) +end if +! * +!*********************************************************************** +! * +ipOff = ipA-1 +do iBeta=1,nBeta + Array(ipOff+1:ipOff+nAlpha) = Alpha + ipOff = ipOff+nAlpha +end do +if (iPrint >= 99) then + call RecPrt(' In pvint: Alpha (expanded)','(5D20.13)',Array(ipA),nZeta,1) +end if +! * +!*********************************************************************** +! * +! Assemble final integral from the derivative integrals + +call Ass_pX(Array(ipA),nZeta,rFinal,la,lb,Array(ipS1),Array(ipS2),nIC) +! * +!*********************************************************************** +! * +if (iPrint >= 49) then + do i=1,3 + call RecPrt('pVInt: rFinal',' ',rFinal(:,:,:,i),nZeta,nTri_Elem1(la)*nTri_Elem1(lb)) + end do +end if + +return + +end subroutine PVInt diff -Nru openmolcas-22.02/src/oneint_util/pvmem.f openmolcas-22.10/src/oneint_util/pvmem.f --- openmolcas-22.02/src/oneint_util/pvmem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/pvmem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,27 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine PVMem(nHer,Mem,la,lb,lr,KrnMem) - External KrnMem -* - Call KrnMem(nHer,MemNA1,la+1,lb,lr-1) -* - If (la.ne.0) Then - Call KrnMem(nHer,MemNA2,la-1,lb,lr-1) - Else - MemNA2=0 - End If -* - Mem=Max(MemNA1,MemNA2) -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/pvmem.F90 openmolcas-22.10/src/oneint_util/pvmem.F90 --- openmolcas-22.02/src/oneint_util/pvmem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/pvmem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,36 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine PVMem(nHer,Mem,la,lb,lr,KrnMem) + +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(out) :: nHer, Mem +integer(kind=iwp), intent(in) :: la, lb, lr +external :: KrnMem +integer(kind=iwp) :: MemNA1, MemNA2 + +call KrnMem(nHer,MemNA1,la+1,lb,lr-1) + +if (la /= 0) then + call KrnMem(nHer,MemNA2,la-1,lb,lr-1) +else + MemNA2 = 0 +end if + +Mem = max(MemNA1,MemNA2) + +return + +end subroutine PVMem diff -Nru openmolcas-22.02/src/oneint_util/pxint.f openmolcas-22.10/src/oneint_util/pxint.f --- openmolcas-22.02/src/oneint_util/pxint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/pxint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,225 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 2006, Roland Lindh * -************************************************************************ - SubRoutine PXInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of pX integrals * -* * -* Called from: OneEl * -* * -* Author: Roland Lindh, Dept. Chem. Phys., Lund University, * -* June 2006 * -************************************************************************ - use Symmetry_Info, only: nIrrep, iChBas - Implicit Real*8 (A-H,O-Z) - External NAInt, MltInt, EFInt, CntInt -#include "print.fh" -#include "property_label.fh" - -#include "int_interface.fh" - -* Local variables - Parameter (mComp=200) - Integer kOper(mComp), kChO(mComp) -* * -************************************************************************ -* * -* Interface -* Subroutine PVINT( -*#define _CALLING_ -*#include "int_interface.fh" -* & , Kernel) -*#include "int_interface.fh" -* External Kernel -* End Subroutine PVINT -* End Interface -* * -************************************************************************ -* * -* -* * -************************************************************************ -* * -* nIC: number of symmetry adapted blocks in total for the nComp -* elements of the compund operator, pX. -* nComp: is the number of elements of the compund operator -* -* kIC: number of symmetry adapted blocks in total for the kComp -* elements of the operator X -* kComp: is the number of elements of the operator X. -* * -************************************************************************ -* * -* Note that the p operator's each element is only a basis function -* of a single irreducible representation. Hence, 3*kIC=nIC. -* -* In addition if the operator X has kComp elements pX has 3*kComp -* elements. -* * -************************************************************************ -* * - nRys = nHer - kIC=nIC/3 - kComp=nComp/3 - kOrdOp = nOrdOp-1 -* * -************************************************************************ -* * -* Now produce the kOper array with kComp elements from the lOper -* array. Dito kChO/iChO. -* -* lOper is an integer which bit pattern indicate to which irreps -* the component of the operator is a basis function. Note that the -* operator is not symmetry adapted, i.e. it can be a basis function -* in more than one irrep. -* -* iChO is an integer which describe the parity character of the -* operator with respect to X, Y, and Z coordinates. For example, -* if the first bit is set this means that the operator change sign -* under a reflextion in the yz-plane, etc. -* - If (kComp.gt.mComp) Then - Call WarningMessage(2,'PXInt: kComp.gt.mComp') - Write (6,*) 'kComp=',kComp - Write (6,*) 'mComp=',mComp - Call Abend() - End If -* -* As we remove the p operator (three of them) X should be the same -* regardless of if we remove d/dx, d/dy, or d/dz. -* - iSym_p1 = IrrFnc(1) ! d/dx - iSym_p2 = IrrFnc(2) ! d/dy - iSym_p3 = IrrFnc(4) ! d/dz -C Write (6,*) -C Write (6,*) 'pXInt******' -C Write (*,*) 'iSym_p=',iSym_p1,iSym_p2,iSym_p3 - ipar_p1 = iChBas(2) - ipar_p2 = iChBas(3) - ipar_p3 = iChBas(4) -C Write (6,*) 'ipar_p=',ipar_p1,ipar_p2,ipar_p3 - Do iComp = 1, kComp - jComp1 = (iComp-1)*3 + 1 - jComp2 = (iComp-1)*3 + 2 - jComp3 = (iComp-1)*3 + 3 - jpar_p1 = iChO(jComp1) - jpar_p2 = iChO(jComp2) - jpar_p3 = iChO(jComp3) -* -* Look thru all irreps and check if pX is a basis function in -* irrep iSym_pX. If so find the symmetry to which X is a basis -* function -* - jTemp1= 0 - jTemp2= 0 - jTemp3= 0 -C Write (6,*) 'lOper=',lOper(jComp1),lOper(jComp2),lOper(jComp3) - Do iSym_pX = 0, nIrrep-1 - If (iAnd(2**iSym_pX,lOper(jComp1)).ne.0) Then - iSym_X = iEOr(iSym_pX,iSym_p1) -C Write (6,*) 'iSym_pX,iSym_X=',iSym_pX,iSym_X - jTemp1=iOr(jTemp1,2**iSym_X) -C Write (6,*) 'jTemp1=',jTemp1 - End If - If (iAnd(2**iSym_pX,lOper(jComp2)).ne.0) Then - iSym_X = iEOr(iSym_pX,iSym_p2) -C Write (6,*) 'iSym_pX,iSym_X=',iSym_pX,iSym_X - jTemp2=iOr(jTemp2,2**iSym_X) -C Write (6,*) 'jTemp2=',jTemp2 - End If - If (iAnd(2**iSym_pX,lOper(jComp3)).ne.0) Then - iSym_X = iEOr(iSym_pX,iSym_p3) -C Write (6,*) 'iSym_pX,iSym_X=',iSym_pX,iSym_X - jTemp3=iOr(jTemp3,2**iSym_X) -C Write (6,*) 'jTemp3=',jTemp3 - End If - End Do -* -* Check for consistency! -* - If (jTemp1.ne.jTemp2.or.jTemp1.ne.jTemp3) Then - Call WarningMessage(2,'PXInt: corrupted jTemps!') - Write (6,*) 'jTemp1,jTemp2,jTemp3=', - & jTemp1,jTemp2,jTemp3 - Call Abend() - End If -* -* Compute the parity of X -* - jpar_p1=iEOr(jpar_p1,ipar_p1) - jpar_p2=iEOr(jpar_p2,ipar_p2) - jpar_p3=iEOr(jpar_p3,ipar_p3) -* - If (jpar_p1.ne.jpar_p2.or.jpar_p1.ne.jpar_p3) Then - Call WarningMessage(2,'PXInt: corrupted jpars!') - Call Abend() - End If -* -* Store the data -* - kOper(iComp)=jTemp1 - kChO(iComp)=jpar_p1 - End Do -* -C Write (6,*) 'pXpInt' -C Do iComp = 1, nComp -C Write (6,*) lOper(iComp), iChO(iComp) -C End Do -C Write (6,*) -C Do iComp = 1, kComp -C Write (6,*) kOper(iComp), kChO(iComp) -C End Do -* * -************************************************************************ -* * -* Compute now the integrals -* - If (PLabel.eq.'NAInt ') Then - Call PVInt(Alpha,nAlpha,Beta, nBeta,Zeta,ZInv,rKappa,P, - & Final,nZeta,kIC,kComp,la,lb,A,RB,nRys, - & Array,nArr,CCoor,kOrdOp,kOper,kChO, - & iStabM,nStabM, - & PtChrg,nGrid,iAddPot, - & NAInt) - Else If (PLabel.eq.'MltInt') Then - Call PVInt(Alpha,nAlpha,Beta, nBeta,Zeta,ZInv,rKappa,P, - & Final,nZeta,kIC,kComp,la,lb,A,RB,nRys, - & Array,nArr,CCoor,kOrdOp,kOper,kChO, - & iStabM,nStabM, - & PtChrg,nGrid,iAddPot, - & MltInt) - Else If (PLabel.eq.'EFInt ') Then - Call PVInt(Alpha,nAlpha,Beta, nBeta,Zeta,ZInv,rKappa,P, - & Final,nZeta,kIC,kComp,la,lb,A,RB,nRys, - & Array,nArr,CCoor,kOrdOp,kOper,kChO, - & iStabM,nStabM, - & PtChrg,nGrid,iAddPot, - & EFInt) - Else If (PLabel.eq.'CntInt') Then - Call PVInt(Alpha,nAlpha,Beta, nBeta,Zeta,ZInv,rKappa,P, - & Final,nZeta,kIC,kComp,la,lb,A,RB,nRys, - & Array,nArr,CCoor,kOrdOp,kOper,kChO, - & iStabM,nStabM, - & PtChrg,nGrid,iAddPot, - & CntInt) - Else - Call WarningMessage(2,'PXInt: Illegal type!') - Write(6,*) ' PLabel=',PLabel - Call Abend() - End If -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/pxint.F90 openmolcas-22.10/src/oneint_util/pxint.F90 --- openmolcas-22.02/src/oneint_util/pxint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/pxint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,197 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 2006, Roland Lindh * +!*********************************************************************** + +subroutine PXInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of pX integrals * +! * +! Called from: OneEl * +! * +! Author: Roland Lindh, Dept. Chem. Phys., Lund University, * +! June 2006 * +!*********************************************************************** + +use Symmetry_Info, only: nIrrep, iChBas +use Index_Functions, only: nTri_Elem1 +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "property_label.fh" +integer(kind=iwp), parameter :: mComp = 200 +integer(kind=iwp) :: iComp, ipar_p1, ipar_p2, ipar_p3, iSym_p1, iSym_p2, iSym_p3, iSym_px, iSym_X, jComp1, jComp2, jComp3, & + jpar_p1, jpar_p2, jpar_p3, jTemp1, jTemp2, jTemp3, kComp, kIC, kOrdOp, nRys +integer(kind=iwp), allocatable :: kChO(:), kOper(:) +integer(kind=iwp), external :: IrrFnc +external :: CntInt, EFInt, MltInt, NAInt + +! * +!*********************************************************************** +! * +! nIC: number of symmetry adapted blocks in total for the nComp +! elements of the compund operator, pX. +! nComp: is the number of elements of the compund operator +! +! kIC: number of symmetry adapted blocks in total for the kComp +! elements of the operator X +! kComp: is the number of elements of the operator X. +! * +!*********************************************************************** +! * +! Note that the p operator's each element is only a basis function +! of a single irreducible representation. Hence, 3*kIC=nIC. +! +! In addition if the operator X has kComp elements pX has 3*kComp +! elements. +! * +!*********************************************************************** +! * +nRys = nHer +kIC = nIC/3 +kComp = nComp/3 +kOrdOp = nOrdOp-1 +! * +!*********************************************************************** +! * +! Now produce the kOper array with kComp elements from the lOper +! array. Ditto kChO/iChO. +! +! lOper is an integer which bit pattern indicate to which irreps +! the component of the operator is a basis function. Note that the +! operator is not symmetry adapted, i.e. it can be a basis function +! in more than one irrep. +! +! iChO is an integer which describe the parity character of the +! operator with respect to X, Y, and Z coordinates. For example, +! if the first bit is set this means that the operator change sign +! under a reflection in the yz-plane, etc. + +call mma_allocate(kChO,kComp,label='kChO') +call mma_allocate(kOper,kComp,label='kOper') + +! As we remove the p operator (three of them) X should be the same +! regardless of if we remove d/dx, d/dy, or d/dz. + +iSym_p1 = IrrFnc(1) ! d/dx +iSym_p2 = IrrFnc(2) ! d/dy +iSym_p3 = IrrFnc(4) ! d/dz +!write(u6,*) +!write(u6,*) 'pXInt******' +!write(u6,*) 'iSym_p=',iSym_p1,iSym_p2,iSym_p3 +ipar_p1 = iChBas(2) +ipar_p2 = iChBas(3) +ipar_p3 = iChBas(4) +!write(u6,*) 'ipar_p=',ipar_p1,ipar_p2,ipar_p3 +do iComp=1,kComp + jComp1 = (iComp-1)*3+1 + jComp2 = (iComp-1)*3+2 + jComp3 = (iComp-1)*3+3 + jpar_p1 = iChO(jComp1) + jpar_p2 = iChO(jComp2) + jpar_p3 = iChO(jComp3) + + ! Look thru all irreps and check if pX is a basis function in + ! irrep iSym_pX. If so find the symmetry to which X is a basis function + + jTemp1 = 0 + jTemp2 = 0 + jTemp3 = 0 + !write(u6,*) 'lOper=',lOper(jComp1),lOper(jComp2),lOper(jComp3) + do iSym_pX=0,nIrrep-1 + if (btest(lOper(jComp1),iSym_pX)) then + iSym_X = ieor(iSym_pX,iSym_p1) + !write(u6,*) 'iSym_pX,iSym_X=',iSym_pX,iSym_X + jTemp1 = ibset(jTemp1,iSym_X) + !write(u6,*) 'jTemp1=',jTemp1 + end if + if (btest(lOper(jComp2),iSym_pX)) then + iSym_X = ieor(iSym_pX,iSym_p2) + !write(u6,*) 'iSym_pX,iSym_X=',iSym_pX,iSym_X + jTemp2 = ibset(jTemp2,iSym_X) + !write(u6,*) 'jTemp2=',jTemp2 + end if + if (btest(lOper(jComp3),iSym_pX)) then + iSym_X = ieor(iSym_pX,iSym_p3) + !write(u6,*) 'iSym_pX,iSym_X=',iSym_pX,iSym_X + jTemp3 = ibset(jTemp3,iSym_X) + !write(u6,*) 'jTemp3=',jTemp3 + end if + end do + + ! Check for consistency! + + if ((jTemp1 /= jTemp2) .or. (jTemp1 /= jTemp3)) then + call WarningMessage(2,'PXInt: corrupted jTemps!') + write(u6,*) 'jTemp1,jTemp2,jTemp3=',jTemp1,jTemp2,jTemp3 + call Abend() + end if + + ! Compute the parity of X + + jpar_p1 = ieor(jpar_p1,ipar_p1) + jpar_p2 = ieor(jpar_p2,ipar_p2) + jpar_p3 = ieor(jpar_p3,ipar_p3) + + if ((jpar_p1 /= jpar_p2) .or. (jpar_p1 /= jpar_p3)) then + call WarningMessage(2,'PXInt: corrupted jpars!') + call Abend() + end if + + ! Store the data + + kOper(iComp) = jTemp1 + kChO(iComp) = jpar_p1 +end do + +!write(u6,*) 'pXpInt' +!do iComp=1,nComp +! write(u6,*) lOper(iComp),iChO(iComp) +!end do +!write(u6,*) +!do iComp=1,kComp +! write(u6,*) kOper(iComp),kChO(iComp) +!end do +! * +!*********************************************************************** +! * +! Compute now the integrals + +if (PLabel == 'NAInt ') then + call PVInt(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,rFinal,nZeta,kIC,kComp,la,lb,A,RB,nRys,Array,nArr,CCoor,kOrdOp,kOper,kChO, & + iStabM,nStabM,PtChrg,nGrid,iAddPot,NAInt) +else if (PLabel == 'MltInt') then + call PVInt(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,rFinal,nZeta,kIC,kComp,la,lb,A,RB,nRys,Array,nArr,CCoor,kOrdOp,kOper,kChO, & + iStabM,nStabM,PtChrg,nGrid,iAddPot,MltInt) +else if (PLabel == 'EFInt ') then + call PVInt(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,rFinal,nZeta,kIC,kComp,la,lb,A,RB,nRys,Array,nArr,CCoor,kOrdOp,kOper,kChO, & + iStabM,nStabM,PtChrg,nGrid,iAddPot,EFInt) +else if (PLabel == 'CntInt') then + call PVInt(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,rFinal,nZeta,kIC,kComp,la,lb,A,RB,nRys,Array,nArr,CCoor,kOrdOp,kOper,kChO, & + iStabM,nStabM,PtChrg,nGrid,iAddPot,CntInt) +else + call WarningMessage(2,'PXInt: Illegal type!') + write(u6,*) ' PLabel=',PLabel + call Abend() +end if + +call mma_deallocate(kChO) +call mma_deallocate(kOper) + +return + +end subroutine PXInt diff -Nru openmolcas-22.02/src/oneint_util/pxmem.f openmolcas-22.10/src/oneint_util/pxmem.f --- openmolcas-22.02/src/oneint_util/pxmem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/pxmem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine PXMem( -#define _CALLING_ -#include "mem_interface.fh" - &) -#include "mem_interface.fh" - External NAMem, MltMem, EFMem, CntMem -#include "property_label.fh" -* - If (PLabel.eq.'NAInt ') Then - Call PVMem(nHer,Mem,la,lb,lr,NAMem) - Else If (PLabel.eq.'MltInt') Then - Call PVMem(nHer,Mem,la,lb,lr,MltMem) - Else If (PLabel.eq.'EFInt ') Then - Call PVMem(nHer,Mem,la,lb,lr,EFMem) - Else If (PLabel.eq.'CntInt') Then - Call PVMem(nHer,Mem,la,lb,lr,CntMem) - Else - Call WarningMessage(2,'PXMem: Illegal type!') - Write(6,*) ' PLabel=',PLabel - Call Abend() - End If -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/pxmem.F90 openmolcas-22.10/src/oneint_util/pxmem.F90 --- openmolcas-22.02/src/oneint_util/pxmem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/pxmem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,42 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine PXMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Definitions, only: iwp, u6 + +implicit none +#include "mem_interface.fh" +#include "property_label.fh" +external :: CntMem, EFMem, MltMem, NAMem + +if (PLabel == 'NAInt ') then + call PVMem(nHer,Mem,la,lb,lr,NAMem) +else if (PLabel == 'MltInt') then + call PVMem(nHer,Mem,la,lb,lr,MltMem) +else if (PLabel == 'EFInt ') then + call PVMem(nHer,Mem,la,lb,lr,EFMem) +else if (PLabel == 'CntInt') then + call PVMem(nHer,Mem,la,lb,lr,CntMem) +else + call WarningMessage(2,'PXMem: Illegal type!') + write(u6,*) ' PLabel=',PLabel + call Abend() +end if + +return + +end subroutine PXMem diff -Nru openmolcas-22.02/src/oneint_util/pxpint.f openmolcas-22.10/src/oneint_util/pxpint.f --- openmolcas-22.02/src/oneint_util/pxpint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/pxpint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,175 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1993, Bernd Artur Hess * -* 1999, Roland Lindh * -************************************************************************ - SubRoutine pXpInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the comutation of pXp integrals * -* * -* Author: Bernd Hess, Institut fuer Physikalische und Theoretische * -* Chemie, University of Bonn, Germany, April 1993 * -* R. Lindh, modified to molcas 4.1 form, Oct 1999 * -************************************************************************ - use Symmetry_Info, only: nIrrep, iChBas - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - -#include "int_interface.fh" - -* Local variables - Parameter (mComp=200) - Integer kOper(mComp), kChO(mComp) -* -* Statement function for Cartesian index -* - nElem(ixyz) = ((ixyz+1)*(ixyz+2))/2 -* - iRout = 220 - iPrint = nPrint(iRout) -* - iSize=nZeta*nElem(la)*nElem(lb)*nComp - call dcopy_(iSize,[Zero],0,Final,1) - call dcopy_(nZeta*nArr,[Zero],0,Array,1) - nip = 1 - ipB = nip - nip = nip + nZeta - ipS1 = nip - nip = nip + nZeta*nElem(la)*nElem(lb+1)*3*nIC - If (lb.gt.0) Then - ipS2 = nip - nip = nip + nZeta*nElem(la)*nElem(lb-1)*3*nIC - Else - ipS2=ipS1 - End If - ipArr = nip - mArr=nArr-(nip-1)/nZeta - If (mArr.lt.0) Then - Call WarningMessage(2,'pXpInt: mArr<0!') - Call Abend() - End If -* * -************************************************************************ -* * -* nIC: the number of blocks of the symmetry adapted operator pXp -* nComp: number of components of the operator pXp -* -* pXp = d/dx X d/dx + d/dy X d/dy + d/dz X d/dz -* - kIC=nIC*3 - kComp=nComp*3 - kOrdOp = nOrdOp-1 - If (kComp.gt.mComp) Then - Write (6,*) 'pxpint: kComp.gt.mComp' - Call Abend() - End If -C Write (6,*) -C Write (6,*) 'pXpInt:**********' -* - iSym_p1 = IrrFnc(1) - iSym_p2 = IrrFnc(2) - iSym_p3 = IrrFnc(4) -C Write (6,*) 'iSym_p=',iSym_p1,iSym_p2,iSym_p3 - ipar_p1 = iChBas(2) - ipar_p2 = iChBas(3) - ipar_p3 = iChBas(4) -C Write (6,*) 'ipar_p=',ipar_p1,ipar_p2,ipar_p3 - Do iComp = 1, nComp - jComp1 = (iComp-1)*3 + 1 - jComp2 = (iComp-1)*3 + 2 - jComp3 = (iComp-1)*3 + 3 - iTemp = lOper(iComp) - ipar = iChO(iComp) -* - jTemp1= 0 - jTemp2= 0 - jTemp3= 0 - Do iSym_pXp = 0, nIrrep-1 - If (iAnd(2**iSym_pXp,iTemp).ne.0) Then - iSym_pX = iEor(iSym_pXp,iSym_p1) -C Write (6,*) 'iSym_pXp,iSym_pX=',iSym_pXp,iSym_pX - jTemp1=iOr(jTemp1,2**iSym_pX) - End If - If (iAnd(2**iSym_pXp,iTemp).ne.0) Then - iSym_pX = iEor(iSym_pXp,iSym_p2) -C Write (6,*) 'iSym_pXp,iSym_pX=',iSym_pXp,iSym_pX - jTemp2=iOr(jTemp2,2**iSym_pX) - End If - If (iAnd(2**iSym_pXp,iTemp).ne.0) Then - iSym_pX = iEor(iSym_pXp,iSym_p3) -C Write (6,*) 'iSym_pXp,iSym_pX=',iSym_pXp,iSym_pX - jTemp3=iOr(jTemp3,2**iSym_pX) - End If - End Do - kOper(jComp1)=jTemp1 - kOper(jComp2)=jTemp2 - kOper(jComp3)=jTemp3 -* - kChO(jComp1)=iEOr(ipar,ipar_p1) - kChO(jComp2)=iEOr(ipar,ipar_p2) - kChO(jComp3)=iEOr(ipar,ipar_p3) -* - End Do -* * -************************************************************************ -* * - Call pXint(Alpha,nAlpha,Beta, nBeta,Zeta,ZInv,rKappa,P, - & Array(ipS1),nZeta,kIC,kComp,la,lb+1,A,RB,iDum, - & Array(ipArr),mArr,CCoor,kOrdOp,kOper,kChO, - & iStabM,nStabM, - & PtChrg,nGrid,iAddPot) -* * -************************************************************************ -* * - If (lb.gt.0) Then - Call pXint(Alpha,nAlpha,Beta, nBeta,Zeta,ZInv,rKappa,P, - & Array(ipS2),nZeta,kIC,kComp,la,lb-1,A,RB,iDum, - & Array(ipArr),mArr,CCoor,kOrdOp,kOper,kChO, - & iStabM,nStabM, - & PtChrg,nGrid,iAddPot) - End If -* * -************************************************************************ -* * - ipOff = ipB - Do iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ipOff),nAlpha) - ipOff = ipOff + 1 - End Do -* - If (iPrint.ge.99) Then - Call RecPrt(' In pXpint: Beta (expanded)','(5D20.13)', - * Array(ipB),nZeta,1) - End If -* * -************************************************************************ -* * -* Combine pX integrals to generate the pXp integrals. -* -* Note that the pX integrals have 3*nComp components. -* - Call Ass_pXp(Array(ipB),nZeta,Final,la,lb,Array(ipS1),Array(ipS2), - & nComp) -* * -************************************************************************ -* * - If (iPrint.ge.49) Call RecPrt('pXpInt: Final',' ',Final, - & nZeta,nElem(la)*nElem(lb)) -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(nHer) - End diff -Nru openmolcas-22.02/src/oneint_util/pxpint.F90 openmolcas-22.10/src/oneint_util/pxpint.F90 --- openmolcas-22.02/src/oneint_util/pxpint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/pxpint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,161 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993, Bernd Artur Hess * +! 1999, Roland Lindh * +!*********************************************************************** + +subroutine pXpInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the comutation of pXp integrals * +! * +! Author: Bernd Hess, Institut fuer Physikalische und Theoretische * +! Chemie, University of Bonn, Germany, April 1993 * +! R. Lindh, modified to molcas 4.1 form, Oct 1999 * +!*********************************************************************** + +use Symmetry_Info, only: iChBas, nIrrep +use Index_Functions, only: nTri_Elem1 +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +#include "int_interface.fh" +#include "print.fh" +integer(kind=iwp) :: iBeta, iComp, iDum, ipar, ipar_p1, ipar_p2, ipar_p3, ipArr, ipB, ipOff, iPrint, ipS1, ipS2, iRout, iSym_p1, & + iSym_p2, iSym_p3, iSym_pX, iSym_pXp, iTemp, jTemp1, jTemp2, jTemp3, kComp, kIC, kOrdOp, mArr, nip +integer(kind=iwp), allocatable :: kChO(:,:), kOper(:,:) +integer(kind=iwp), external :: IrrFnc + +#include "macros.fh" +unused_var(nHer) + +iRout = 220 +iPrint = nPrint(iRout) + +rFinal(:,:,:,:) = Zero +Array(:) = Zero +nip = 1 +ipB = nip +nip = nip+nZeta +ipS1 = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb+1)*3*nIC +if (lb > 0) then + ipS2 = nip + nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb-1)*3*nIC +else + ipS2 = ipS1 +end if +ipArr = nip +mArr = nArr-(nip-1)/nZeta +if (mArr < 0) then + call WarningMessage(2,'pXpInt: mArr<0!') + call Abend() +end if +! * +!*********************************************************************** +! * +! nIC: the number of blocks of the symmetry adapted operator pXp +! nComp: number of components of the operator pXp +! +! pXp = d/dx X d/dx + d/dy X d/dy + d/dz X d/dz + +kIC = nIC*3 +kComp = nComp*3 +kOrdOp = nOrdOp-1 +call mma_allocate(kChO,3,nComp,label='kChO') +call mma_allocate(kOper,3,nComp,label='kOper') +!write(u6,*) +!write(u6,*) 'pXpInt:**********' + +iSym_p1 = IrrFnc(1) +iSym_p2 = IrrFnc(2) +iSym_p3 = IrrFnc(4) +!write(u6,*) 'iSym_p=',iSym_p1,iSym_p2,iSym_p3 +ipar_p1 = iChBas(2) +ipar_p2 = iChBas(3) +ipar_p3 = iChBas(4) +!write(u6,*) 'ipar_p=',ipar_p1,ipar_p2,ipar_p3 +do iComp=1,nComp + iTemp = lOper(iComp) + ipar = iChO(iComp) + + jTemp1 = 0 + jTemp2 = 0 + jTemp3 = 0 + do iSym_pXp=0,nIrrep-1 + if (btest(iTemp,iSym_pXp)) then + iSym_pX = ieor(iSym_pXp,iSym_p1) + !write(u6,*) 'iSym_pXp,iSym_pX=',iSym_pXp,iSym_pX + jTemp1 = ibset(jTemp1,iSym_pX) + iSym_pX = ieor(iSym_pXp,iSym_p2) + !write(u6,*) 'iSym_pXp,iSym_pX=',iSym_pXp,iSym_pX + jTemp2 = ibset(jTemp2,iSym_pX) + iSym_pX = ieor(iSym_pXp,iSym_p3) + !write(u6,*) 'iSym_pXp,iSym_pX=',iSym_pXp,iSym_pX + jTemp3 = ibset(jTemp3,iSym_pX) + end if + end do + kOper(1,iComp) = jTemp1 + kOper(2,iComp) = jTemp2 + kOper(3,iComp) = jTemp3 + + kChO(1,iComp) = ieor(ipar,ipar_p1) + kChO(2,iComp) = ieor(ipar,ipar_p2) + kChO(3,iComp) = ieor(ipar,ipar_p3) + +end do +! * +!*********************************************************************** +! * +call pXint(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipS1),nZeta,kIC,kComp,la,lb+1,A,RB,iDum,Array(ipArr),mArr,CCoor, & + kOrdOp,kOper,kChO,iStabM,nStabM,PtChrg,nGrid,iAddPot) +! * +!*********************************************************************** +! * +if (lb > 0) then + call pXint(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipS2),nZeta,kIC,kComp,la,lb-1,A,RB,iDum,Array(ipArr),mArr,CCoor, & + kOrdOp,kOper,kChO,iStabM,nStabM,PtChrg,nGrid,iAddPot) +end if +call mma_deallocate(kChO) +call mma_deallocate(kOper) +! * +!*********************************************************************** +! * +ipOff = ipB-1 +do iBeta=1,nBeta + Array(ipOff+1:ipOff+nAlpha) = Beta(iBeta) + ipOff = ipOff+nAlpha +end do + +if (iPrint >= 99) then + call RecPrt(' In pXpint: Beta (expanded)','(5D20.13)',Array(ipB),nZeta,1) +end if +! * +!*********************************************************************** +! * +! Combine pX integrals to generate the pXp integrals. +! +! Note that the pX integrals have 3*nComp components. + +call Ass_pXp(Array(ipB),nZeta,rFinal,la,lb,Array(ipS1),Array(ipS2),nComp) +! * +!*********************************************************************** +! * +if (iPrint >= 49) call RecPrt('pXpInt: rFinal',' ',rFinal(:,:,:,1),nZeta,nTri_Elem1(la)*nTri_Elem1(lb)) + +return + +end subroutine pXpInt diff -Nru openmolcas-22.02/src/oneint_util/pxpmem.f openmolcas-22.10/src/oneint_util/pxpmem.f --- openmolcas-22.02/src/oneint_util/pxpmem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/pxpmem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine PXPMem( -#define _CALLING_ -#include "mem_interface.fh" - &) -#include "mem_interface.fh" -* -* Statement function for Cartesian index -* - Mem=0 - nHer =0 - Call PXMem(nOrder,MemPX,la,lb+1,lr-1) - Mem=Max(Mem,MemPX) - nHer =Max(nHer,nOrder) - If (lb.GT.0) Then - Call PXMem(nOrder,MemPX,la,lb-1,lr-1) - Mem=Max(Mem,MemPX) - nHer =Max(nHer,nOrder) - End If -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/pxpmem.F90 openmolcas-22.10/src/oneint_util/pxpmem.F90 --- openmolcas-22.02/src/oneint_util/pxpmem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/pxpmem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,36 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine pXpMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: MemPX, nOrder + +Mem = 0 +nHer = 0 +call PXMem(nOrder,MemPX,la,lb+1,lr-1) +Mem = max(Mem,MemPX) +nHer = max(nHer,nOrder) +if (lb > 0) then + call PXMem(nOrder,MemPX,la,lb-1,lr-1) + Mem = max(Mem,MemPX) + nHer = max(nHer,nOrder) +end if + +return + +end subroutine pXpMem diff -Nru openmolcas-22.02/src/oneint_util/qpvint.f openmolcas-22.10/src/oneint_util/qpvint.f --- openmolcas-22.02/src/oneint_util/qpvint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/qpvint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,109 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine QpVInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of velocity quadrupole * -* integrals. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, Sweden, February '91 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - -#include "int_interface.fh" - -* Local variables - Real*8 TC(3) - Integer iStabO(0:7), iDCRT(0:7) -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - nip = 1 - ipB = nip - nip = nip + nZeta - ipS1 = nip - nip = nip + nZeta*nElem(la)*nElem(lb+1)*3 - ipS2 = 1 - If (lb.gt.0) Then - ipS2 = nip - nip = nip + nZeta*nElem(la)*nElem(lb-1)*3 - End If - ipRes = nip - nip = nip + nZeta*nElem(la)*nElem(lb)*nComp - If (nip-1.gt.nZeta*nArr) Then - Call WarningMessage(2,' QpVInt: nip-1.gt.nZeta*nArr') - Call Abend() - End If - ipArr = nip - mArr = (nArr*nZeta - (nip-1))/nZeta -* - call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) -* - iComp=3 - llOper = lOper(1) - Do 90 iComp = 2, nComp - llOper = iOr(llOper,lOper(iComp)) - 90 Continue - Call SOS(iStabO,nStabO,llOper) - Call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) -* - ipOff = ipB - Do 100 iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ipOff),nAlpha) - ipOff = ipOff + 1 - 100 Continue -* - Do 102 lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),Ccoor,TC) -* - nHer = (la + (lb+1) + (nOrdOp-1) + 2) / 2 - Call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P, - & Array(ipS1),nZeta,iComp,la,lb+1,A,RB,nHer, - & Array(ipArr),mArr,TC,nOrdOp-1) -* - If (lb.gt.0) Then - nHer = (la + (lb-1) + (nOrdOp-1) + 2) / 2 - Call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P, - & Array(ipS2),nZeta,iComp,la,lb-1,A,RB,nHer, - & Array(ipArr),mArr,TC,nOrdOp-1) - End If -* -* Combine derivatives and dipole integrals to generate the -* velocity quadrupole integrals. -* - Call Util5(Array(ipB),nZeta,Array(ipRes),la,lb,Array(ipS1), - & Array(ipS2)) -* -*--------Accumulate contributions -* - nOp = NrOpr(iDCRT(lDCRT)) - Call SymAdO(Array(ipRes),nZeta,la,lb,nComp,Final,nIC, - & nOp ,lOper,iChO,One) -* - 102 Continue -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/qpvint.F90 openmolcas-22.10/src/oneint_util/qpvint.F90 --- openmolcas-22.02/src/oneint_util/qpvint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/qpvint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,102 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine QpVInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of velocity quadrupole * +! integrals. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, Sweden, February '91 * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +#include "int_interface.fh" +integer(kind=iwp) :: iBeta, iComp, iDCRT(0:7), ipArr, ipB, ipOff, ipRes, ipS1, ipS2, iStabO(0:7), lDCRT, llOper, LmbdT, mArr, & + nDCRT, nip, nOp, nStabO +real(kind=wp) :: TC(3) +integer(kind=iwp), external :: NrOpr + +#include "macros.fh" +unused_var(PtChrg) +unused_var(iAddPot) + +nip = 1 +ipB = nip +nip = nip+nZeta +ipS1 = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb+1)*3 +ipS2 = 1 +if (lb > 0) then + ipS2 = nip + nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb-1)*3 +end if +ipRes = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb)*nComp +if (nip-1 > nZeta*nArr) then + call WarningMessage(2,' QpVInt: nip-1 > nZeta*nArr') + call Abend() +end if +ipArr = nip +mArr = (nArr*nZeta-(nip-1))/nZeta + +rFinal(:,:,:,:) = Zero + +iComp = 3 +llOper = lOper(1) +do iComp=2,nComp + llOper = ior(llOper,lOper(iComp)) +end do +call SOS(iStabO,nStabO,llOper) +call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) + +ipOff = ipB-1 +do iBeta=1,nBeta + Array(ipOff+1:ipOff+nAlpha) = Beta(iBeta) + ipOff = ipOff+nAlpha +end do + +do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),Ccoor,TC) + + nHer = (la+(lb+1)+(nOrdOp-1)+2)/2 + call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipS1),nZeta,iComp,la,lb+1,A,RB,nHer,Array(ipArr),mArr,TC,nOrdOp-1) + + if (lb > 0) then + nHer = (la+(lb-1)+(nOrdOp-1)+2)/2 + call MltPrm(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipS2),nZeta,iComp,la,lb-1,A,RB,nHer,Array(ipArr),mArr,TC,nOrdOp-1) + end if + + ! Combine derivatives and dipole integrals to generate the + ! velocity quadrupole integrals. + + call Util5(Array(ipB),nZeta,Array(ipRes),la,lb,Array(ipS1),Array(ipS2)) + + ! Accumulate contributions + + nOp = NrOpr(iDCRT(lDCRT)) + call SymAdO(Array(ipRes),nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,One) + +end do + +return + +end subroutine QpVInt diff -Nru openmolcas-22.02/src/oneint_util/qpvmem.f openmolcas-22.10/src/oneint_util/qpvmem.f --- openmolcas-22.02/src/oneint_util/qpvmem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/qpvmem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine QpVMem( -#define _CALLING_ -#include "mem_interface.fh" - &) -#include "mem_interface.fh" -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - Call MltMmP(nOrder,Mem,la,lb+1,lr-1) - nHer = nOrder - If (lb.gt.0) Then - Call MltMmP(nOrder,MmMltP,la,lb-1,lr-1) - Mem = Max(Mem,MmMltP) + nElem(la)*nElem(lb-1)*3 - End If - Mem = Mem + 1 + nElem(la)*nElem(lb+1)*3 - Mem = Mem + nElem(la)*nElem(lb)*6 -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/qpvmem.F90 openmolcas-22.10/src/oneint_util/qpvmem.F90 --- openmolcas-22.02/src/oneint_util/qpvmem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/qpvmem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,37 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine QpVMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: MmMltP, nOrder + +call MltMmP(nOrder,Mem,la,lb+1,lr-1) +nHer = nOrder +if (lb > 0) then + call MltMmP(nOrder,MmMltP,la,lb-1,lr-1) + Mem = max(Mem,MmMltP)+nTri_Elem1(la)*nTri_Elem1(lb-1)*3 +end if +Mem = Mem+1+nTri_Elem1(la)*nTri_Elem1(lb+1)*3 +Mem = Mem+nTri_Elem1(la)*nTri_Elem1(lb)*6 + +return + +end subroutine QpVmem diff -Nru openmolcas-22.02/src/oneint_util/sroint.f openmolcas-22.10/src/oneint_util/sroint.f --- openmolcas-22.02/src/oneint_util/sroint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/sroint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,350 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1994, Roland Lindh * -* 1994, Luis Seijo * -************************************************************************ - SubRoutine SROInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of MP integrals. * -* * -* Alpha : exponents of bra gaussians * -* nAlpha: number of primitives (exponents) of bra gaussians * -* Beta : as Alpha but for ket gaussians * -* nBeta : as nAlpha but for the ket gaussians * -* Zeta : sum of exponents (nAlpha x nBeta) * -* ZInv : inverse of Zeta * -* rKappa: gaussian prefactor for the products of bra and ket * -* gaussians. * -* P : center of new gaussian from the products of bra and ket * -* gaussians. * -* Final : array for computed integrals * -* nZeta : nAlpha x nBeta * -* nComp : number of components in the operator (e.g. dipolmoment * -* operator has three components) * -* la : total angular momentum of bra gaussian * -* lb : total angular momentum of ket gaussian * -* A : center of bra gaussian * -* B : center of ket gaussian * -* nRys : order of Rys- or Hermite-Gauss polynomial * -* Array : Auxiliary memory as requested by ECPMem * -* nArr : length of Array * -* Ccoor : coordinates of the operator, zero for symmetric oper. * -* NOrdOp: Order of the operator * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, Sweden, and Luis Seijo, Dept. of Applied Phys- * -* ical Chemistry, the Free University of Madrid, Spain, * -* September '94. * -************************************************************************ - use Basis_Info - use Center_Info - use Real_Spherical - use Symmetry_Info, only: nIrrep, iChTbl - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - -#include "int_interface.fh" - -* Local variables - Real*8 C(3), TC(3) - Integer iDCRT(0:7), iTwoj(0:7) - Character*80 Label - Logical EQ - Data iTwoj/1,2,4,8,16,32,64,128/ -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - iRout = 191 - iPrint = nPrint(iRout) -* - If (iPrint.ge.49) Then - Call RecPrt(' In SROInt: A',' ',A,1,3) - Call RecPrt(' In SROInt: RB',' ',RB,1,3) - Call RecPrt(' In SROInt: Ccoor',' ',Ccoor,1,3) - Call RecPrt(' In SROInt: P',' ',P,nZeta,3) - Write (6,*) ' In SROInt: la,lb=',' ',la,lb - End If -* - call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) -* - llOper = lOper(1) - iComp = 1 - mdc = 0 - Do iCnttp = 1, nCnttp - If (.Not.dbsc(iCnttp)%ECP .or. dbsc(iCnttp)%nSRO.le.0) Then - mdc = mdc + dbsc(iCnttp)%nCntr - Cycle - End If - Do iCnt = 1,dbsc(iCnttp)%nCntr - C(1:3) = dbsc(iCnttp)%Coor(1:3,iCnt) -* - Call DCR(LmbdT,iStabM,nStabM, - & dc(mdc+iCnt)%iStab,dc(mdc+iCnt)%nStab,iDCRT,nDCRT) - Fact = DBLE(nStabM) / DBLE(LmbdT) -* - Do lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),C,TC) - Do iAng = 0, dbsc(iCnttp)%nSRO-1 - iShll = dbsc(iCnttp)%iSRO + iAng - nExpi = Shells(iShll)%nExp - If (nExpi.eq.0) Cycle -* -* - ip = 1 - ipC = ip - ip = ip + nExpi**2 -* - If (iPrint.ge.49) - & Call RecPrt(' The Akl matrix',' ', - & Shells(iShll)%Akl(1,1,1), - & nExpi,nExpi) - call dcopy_(nExpi**2,Shells(iShll)%Akl(1,1,1),1, - & Array(ipC),1) - If (EQ(A,RB).and.EQ(A,TC).and.dbsc(iCnttp)%NoPair) Then - If (iPrint.ge.49) - & Call RecPrt(' The Adl matrix',' ', - & Shells(iShll)%Akl(1,1,2), - & nExpi,nExpi) - Call DaXpY_(nExpi**2,One, - & Shells(iShll)%Akl(1,1,2),1, - & Array(ipC),1) - End If -* - ipF1 = ip - nac = nElem(la)*nElem(iAng) - ip = ip + nAlpha*nExpi*nac - ipP1 = ip - ip = ip + 3 * nAlpha*nExpi - ipZ1 = ip - ip = ip + nAlpha*nExpi - ipK1 = ip - ip = ip + nAlpha*nExpi - ipZI1 = ip - ip = ip + nAlpha*nExpi - If (ip-1.gt.nArr*nZeta) Then - Call WarningMessage(2,'SROInt: ip-1.gt.nArr*nZeta(1)') - Write (6,*) ' nArr, nZeta=',nArr, nZeta - Write (6,*) ' nac, nAlpha=', nac, nAlpha - Write (6,*) ' nExpi=',nExpi - Call Abend() - End If - mArr = (nArr*nZeta-(ip-1))/nZeta -* -*--------------Calculate Effective center and exponent for -* - Call ZXia(Array(ipZ1),Array(ipZI1),nAlpha,nExpi, - & Alpha,Shells(iShll)%Exp) - Call SetUp1(Alpha,nAlpha,Shells(iShll)%Exp,nExpi, - & A,TC,Array(ipK1),Array(ipP1),Array(ipZI1)) -* -*--------------Calculate Overlap -* - nHer = (la+iAng+2)/2 - Call MltPrm(Alpha,nAlpha,Shells(iShll)%Exp,nExpi, - & Array(ipZ1),Array(ipZI1), - & Array(ipK1),Array(ipP1), - & Array(ipF1),nAlpha*nExpi,iComp, - & la,iAng,A,TC,nHer,Array(ip), - & mArr,CCoor,nOrdOp) - If (iPrint.ge.99) Call RecPrt('',' ', - & Array(ipF1),nAlpha*nExpi,nac) - ip = ip - 6 * nAlpha*nExpi -* - ipF2 = ip - ncb = nElem(iAng)*nElem(lb) - ip = ip + nExpi*nBeta*ncb - ipP2 = ip - ip = ip + 3 * nExpi*nBeta - ipZ2 = ip - ip = ip + nExpi*nBeta - ipK2 = ip - ip = ip + nExpi*nBeta - ipZI2 = ip - ip = ip + nExpi*nBeta - If (ip-1.gt.nArr*nZeta) Then - Call WarningMessage(2,'SROInt: ip-1.gt.nArr*nZeta(2)') - Call Abend() - End If - mArr = (nArr*nZeta-(ip-1))/nZeta -* -*--------------Calculate Effective center and exponent for -* - Call ZXia(Array(ipZ2),Array(ipZI2),nExpi,nBeta, - & Shells(iShll)%Exp,Beta) - Call SetUp1(Shells(iShll)%Exp,nExpi,Beta,nBeta, - & TC,RB,Array(ipK2),Array(ipP2),Array(ipZI2)) -* -*--------------Calculate Overlap -* - nHer = (iAng+lb+2)/2 - Call MltPrm(Shells(iShll)%Exp,nExpi,Beta,nBeta, - & Array(ipZ2),Array(ipZI2), - & Array(ipK2),Array(ipP2), - & Array(ipF2),nExpi*nBeta,iComp, - & iAng,lb,TC,RB,nHer,Array(ip), - & mArr,CCoor,nOrdOp) - If (iPrint.ge.99) Call RecPrt('',' ', - & Array(ipF2),nExpi*nBeta,ncb) - ip = ip - 6 * nExpi*nBeta - ipTmp = ip - ip = ip + Max(nAlpha*nExpi*nac, - & nExpi*nBeta*ncb) - If (ip-1.gt.nArr*nZeta) Then - Call WarningMessage(2,'SROInt: ip-1.gt.nArr*nZeta(3)') - Call Abend() - End If -* -*--------------Calculate Contraction over the spectral resolvent basis -* set of the type A(l;ab) where we now have in -* Array(ipF1) the cartesian components of , and -* similarily, in Array(ipF2), we have stored the cartesian -* components of . Observe that as opposed to the -* projection operator that this contraction is done in the -* primitive basis. -* -*--------------From the lefthandside overlap, form ikaC from ikac by -* 1) ika,c -> c,ika -* - Call DgeTMo(Array(ipF1),nAlpha*nExpi*nElem(la), - & nAlpha*nExpi*nElem(la), - & nElem(iAng),Array(ipTmp),nElem(iAng)) -* -*--------------2) ika,C = c,ika * c,C -* - Call DGEMM_('T','N', - & nAlpha*nExpi*nElem(la), - & (2*iAng+1),nElem(iAng), - & 1.0d0,Array(ipTmp),nElem(iAng), - & RSph(ipSph(iAng)),nElem(iAng), - & 0.0d0,Array(ipF1), - & nAlpha*nExpi*nElem(la)) - If (iPrint.ge.99) Call RecPrt('',' ', - & Array(ipF1),nAlpha*nExpi, - & nElem(la)*(2*iAng+1)) -* -*--------------And (almost) the same thing for the righthand side, form -* kjCb from kjcb -*-------------1) kj,cb -> cb,kj -* - Call DgeTMo(Array(ipF2), - & nBeta*nExpi,nBeta*nExpi, - & nElem(iAng)*nElem(lb),Array(ipTmp), - & nElem(iAng)*nElem(lb)) -* -*--------------2) bkj,C = c,bkj * c,C -* - Call DGEMM_('T','N', - & nElem(lb)*nExpi*nBeta, - & (2*iAng+1),nElem(iAng), - & 1.0d0,Array(ipTmp),nElem(iAng), - & RSph(ipSph(iAng)),nElem(iAng), - & 0.0d0,Array(ipF2),nElem(lb)*nExpi*nBeta) -* -*--------------3) b,kjC -> kjC,b -* - Call DgeTMo(Array(ipF2),nElem(lb),nElem(lb), - & nExpi*nBeta*(2*iAng+1),Array(ipTmp), - & nExpi*nBeta*(2*iAng+1)) - call dcopy_(nExpi*nBeta*(2*iAng+1)*nElem(lb), - & Array(ipTmp),1,Array(ipF2),1) - If (iPrint.ge.99) Call RecPrt('',' ', - & Array(ipF2),nExpi*nBeta, - & (2*iAng+1)*nElem(lb)) -* -*--------------Next Contract (ikaC)*(klC)*(ljCb) over k,l and C, -* producing ijab, -* by the following procedure: -* Loop over a and b -* Loop over C -* Contract ik(aC)*kl(C), over k producing il(aC), -* Contract il(aC)*lj(Cb), over l producing ij(aCb) -* accumulate to ij(ab) -* End loop C -* End Loop b and a -* - Do ib = 1, nElem(lb) - Do ia = 1, nElem(la) - If (iPrint.ge.99) Write (6,*) ' ia,ib=',ia,ib -* - Do iC = 1, (2*iAng+1) - If (iPrint.ge.99) Write (6,*) ' iC,=',iC - iaC = (iC-1)*nElem(la) + ia - ipaC = (iaC-1)*nAlpha*nExpi + ipF1 - iCb = (ib-1)*(2*iAng+1) + iC - ipCb = (iCb-1)*nExpi*nBeta + ipF2 -* - iIC = 0 - If (iPrint.ge.99) Then - Call RecPrt('',' ',Array(ipaC), - & nAlpha,nExpi) - Call RecPrt('',' ',Array(ipCb), - & nExpi,nBeta) - End If - Do iIrrep = 0, nIrrep-1 - If (iAnd(llOper,iTwoj(iIrrep)).eq.0) Cycle - If (iPrint.ge.99) Write (6,*) ' iIC=',iIC - iIC = iIC + 1 - nOp = NrOpr(iDCRT(lDCRT)) - Xg=DBLE(iChTbl(iIrrep,nOp )) - Factor=Xg*Fact - Call DGEMM_('N','N', - & nAlpha,nExpi,nExpi, - & One,Array(ipaC),nAlpha, - & Array(ipC),nExpi, - & Zero,Array(ipTmp),nAlpha) - Call DGEMM_('N','N', - & nAlpha,nBeta,nExpi, - & Factor,Array(ipTmp),nAlpha, - & Array(ipCb),nExpi, - & One,Final(1,ia,ib,iIC),nAlpha) - End Do -* - End Do - End Do - End Do -* - End Do - End Do - End Do - mdc = mdc + dbsc(iCnttp)%nCntr - End Do -* - If (iPrint.ge.99) Then - Write (6,*) ' Result in SROInt' - Do ia = 1, (la+1)*(la+2)/2 - Do ib = 1, (lb+1)*(lb+2)/2 - Write (Label,'(A,I2,A,I2,A)') - & ' Final(',ia,',',ib,')' - Call RecPrt(Label,' ',Final(1,ia,ib,1),nAlpha,nBeta) - End Do - End Do - End If -* -* Call GetMem(' Exit SROInt','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Zeta) - Call Unused_real_array(ZInv) - Call Unused_real_array(rKappa) - Call Unused_integer(nRys) - Call Unused_integer_array(iChO) - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/sroint.F90 openmolcas-22.10/src/oneint_util/sroint.F90 --- openmolcas-22.02/src/oneint_util/sroint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/sroint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,268 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1994, Roland Lindh * +! 1994, Luis Seijo * +!*********************************************************************** + +subroutine SROInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of MP integrals. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, Sweden, and Luis Seijo, Dept. of Applied Phys- * +! ical Chemistry, the Free University of Madrid, Spain, * +! September '94. * +!*********************************************************************** + +use Basis_Info, only: dbsc, nCnttp, Shells +use Center_Info, only: dc +use Real_Spherical, only: ipSph, RSph +use Symmetry_Info, only: iChTbl, nIrrep +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "print.fh" +integer(kind=iwp) :: ia, iaC, iAng, ib, iC, iCb, iCnt, iCnttp, iComp, iDCRT(0:7), iIC, iIrrep, ip, ipaC, ipC, ipCb, ipF1, ipF2, & + ipK1, ipK2, ipP1, ipP2, iPrint, ipTmp, ipZ1, ipZ2, ipZI1, ipZI2, iRout, iShll, l, lDCRT, llOper, LmbdT, mArr, & + mdc, nac, ncb, nDCRT, nExpi, nOp +real(kind=wp) :: C(3), Fact, Factor, TC(3), Xg +character(len=80) :: Label +integer(kind=iwp), external :: NrOpr +logical(kind=iwp), external :: EQ + +#include "macros.fh" +unused_var(Zeta) +unused_var(ZInv) +unused_var(rKappa) +unused_var(iChO) +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 191 +iPrint = nPrint(iRout) + +if (iPrint >= 49) then + call RecPrt(' In SROInt: A',' ',A,1,3) + call RecPrt(' In SROInt: RB',' ',RB,1,3) + call RecPrt(' In SROInt: Ccoor',' ',Ccoor,1,3) + call RecPrt(' In SROInt: P',' ',P,nZeta,3) + write(u6,*) ' In SROInt: la,lb=',' ',la,lb +end if + +rFinal(:,:,:,:) = Zero + +llOper = lOper(1) +iComp = 1 +mdc = 0 +do iCnttp=1,nCnttp + if (dbsc(iCnttp)%ECP .and. (dbsc(iCnttp)%nSRO > 0)) then + do iCnt=1,dbsc(iCnttp)%nCntr + C(1:3) = dbsc(iCnttp)%Coor(1:3,iCnt) + + call DCR(LmbdT,iStabM,nStabM,dc(mdc+iCnt)%iStab,dc(mdc+iCnt)%nStab,iDCRT,nDCRT) + Fact = real(nStabM,kind=wp)/real(LmbdT,kind=wp) + + do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),C,TC) + do iAng=0,dbsc(iCnttp)%nSRO-1 + iShll = dbsc(iCnttp)%iSRO+iAng + nExpi = Shells(iShll)%nExp + if (nExpi == 0) cycle + + ip = 1 + ipC = ip + ip = ip+nExpi**2 + + if (iPrint >= 49) call RecPrt(' The Akl matrix',' ',Shells(iShll)%Akl(:,:,1),nExpi,nExpi) + Array(ipC:ipC+nExpi**2-1) = pack(Shells(iShll)%Akl(:,:,1),.true.) + if (EQ(A,RB) .and. EQ(A,TC) .and. dbsc(iCnttp)%NoPair) then + if (iPrint >= 49) call RecPrt(' The Adl matrix',' ',Shells(iShll)%Akl(:,:,2),nExpi,nExpi) + Array(ipC:ipC+nExpi**2-1) = Array(ipC:ipC+nExpi**2-1)+pack(Shells(iShll)%Akl(:,:,2),.true.) + end if + + ipF1 = ip + nac = nTri_Elem1(la)*nTri_Elem1(iAng) + ip = ip+nAlpha*nExpi*nac + ipP1 = ip + ip = ip+3*nAlpha*nExpi + ipZ1 = ip + ip = ip+nAlpha*nExpi + ipK1 = ip + ip = ip+nAlpha*nExpi + ipZI1 = ip + ip = ip+nAlpha*nExpi + if (ip-1 > nArr*nZeta) then + call WarningMessage(2,'SROInt: ip-1 > nArr*nZeta(1)') + write(u6,*) ' nArr, nZeta=',nArr,nZeta + write(u6,*) ' nac, nAlpha=',nac,nAlpha + write(u6,*) ' nExpi=',nExpi + call Abend() + end if + mArr = (nArr*nZeta-(ip-1))/nZeta + + ! Calculate Effective center and exponent for + + call ZXia(Array(ipZ1),Array(ipZI1),nAlpha,nExpi,Alpha,Shells(iShll)%Exp) + call SetUp1(Alpha,nAlpha,Shells(iShll)%Exp,nExpi,A,TC,Array(ipK1),Array(ipP1),Array(ipZI1)) + + ! Calculate Overlap + + nHer = (la+iAng+2)/2 + call MltPrm(Alpha,nAlpha,Shells(iShll)%Exp,nExpi,Array(ipZ1),Array(ipZI1),Array(ipK1),Array(ipP1),Array(ipF1), & + nAlpha*nExpi,iComp,la,iAng,A,TC,nHer,Array(ip),mArr,CCoor,nOrdOp) + if (iPrint >= 99) call RecPrt('',' ',Array(ipF1),nAlpha*nExpi,nac) + ip = ip-6*nAlpha*nExpi + + ipF2 = ip + ncb = nTri_Elem1(iAng)*nTri_Elem1(lb) + ip = ip+nExpi*nBeta*ncb + ipP2 = ip + ip = ip+3*nExpi*nBeta + ipZ2 = ip + ip = ip+nExpi*nBeta + ipK2 = ip + ip = ip+nExpi*nBeta + ipZI2 = ip + ip = ip+nExpi*nBeta + if (ip-1 > nArr*nZeta) then + call WarningMessage(2,'SROInt: ip-1 > nArr*nZeta(2)') + call Abend() + end if + mArr = (nArr*nZeta-(ip-1))/nZeta + + ! Calculate Effective center and exponent for + + call ZXia(Array(ipZ2),Array(ipZI2),nExpi,nBeta,Shells(iShll)%Exp,Beta) + call SetUp1(Shells(iShll)%Exp,nExpi,Beta,nBeta,TC,RB,Array(ipK2),Array(ipP2),Array(ipZI2)) + + ! Calculate Overlap + + nHer = (iAng+lb+2)/2 + call MltPrm(Shells(iShll)%Exp,nExpi,Beta,nBeta,Array(ipZ2),Array(ipZI2),Array(ipK2),Array(ipP2),Array(ipF2),nExpi*nBeta, & + iComp,iAng,lb,TC,RB,nHer,Array(ip),mArr,CCoor,nOrdOp) + if (iPrint >= 99) call RecPrt('',' ',Array(ipF2),nExpi*nBeta,ncb) + ip = ip-6*nExpi*nBeta + ipTmp = ip + ip = ip+max(nAlpha*nExpi*nac,nExpi*nBeta*ncb) + if (ip-1 > nArr*nZeta) then + call WarningMessage(2,'SROInt: ip-1 > nArr*nZeta(3)') + call Abend() + end if + + ! Calculate Contraction over the spectral resolvent basis + ! set of the type A(l;ab) where we now have in + ! Array(ipF1) the cartesian components of , and + ! similarily, in Array(ipF2), we have stored the cartesian + ! components of . Observe that as opposed to the + ! projection operator that this contraction is done in the + ! primitive basis. + + ! From the lefthandside overlap, form ikaC from ikac by + ! 1) ika,c -> c,ika + + call DgeTMo(Array(ipF1),nAlpha*nExpi*nTri_Elem1(la),nAlpha*nExpi*nTri_Elem1(la),nTri_Elem1(iAng),Array(ipTmp), & + nTri_Elem1(iAng)) + + ! 2) ika,C = c,ika * c,C + + call DGEMM_('T','N',nAlpha*nExpi*nTri_Elem1(la),(2*iAng+1),nTri_Elem1(iAng),One,Array(ipTmp),nTri_Elem1(iAng), & + RSph(ipSph(iAng)),nTri_Elem1(iAng),Zero,Array(ipF1),nAlpha*nExpi*nTri_Elem1(la)) + if (iPrint >= 99) call RecPrt('',' ',Array(ipF1),nAlpha*nExpi,nTri_Elem1(la)*(2*iAng+1)) + + ! And (almost) the same thing for the righthand side, form + ! kjCb from kjcb + ! 1) kj,cb -> cb,kj + + call DgeTMo(Array(ipF2),nBeta*nExpi,nBeta*nExpi,nTri_Elem1(iAng)*nTri_Elem1(lb),Array(ipTmp), & + nTri_Elem1(iAng)*nTri_Elem1(lb)) + + ! 2) bkj,C = c,bkj * c,C + + call DGEMM_('T','N',nTri_Elem1(lb)*nExpi*nBeta,(2*iAng+1),nTri_Elem1(iAng),One,Array(ipTmp),nTri_Elem1(iAng), & + RSph(ipSph(iAng)),nTri_Elem1(iAng),Zero,Array(ipF2),nTri_Elem1(lb)*nExpi*nBeta) + + ! 3) b,kjC -> kjC,b + + call DgeTMo(Array(ipF2),nTri_Elem1(lb),nTri_Elem1(lb),nExpi*nBeta*(2*iAng+1),Array(ipTmp),nExpi*nBeta*(2*iAng+1)) + l = nExpi*nBeta*(2*iAng+1)*nTri_Elem1(lb) + Array(ipF2:ipF2+l-1) = Array(ipTmp:ipTmp+l-1) + if (iPrint >= 99) call RecPrt('',' ',Array(ipF2),nExpi*nBeta,(2*iAng+1)*nTri_Elem1(lb)) + + ! Next Contract (ikaC)*(klC)*(ljCb) over k,l and C, + ! producing ijab, + ! by the following procedure: + ! Loop over a and b + ! Loop over C + ! Contract ik(aC)*kl(C), over k producing il(aC), + ! Contract il(aC)*lj(Cb), over l producing ij(aCb) + ! accumulate to ij(ab) + ! End loop C + ! End Loop b and a + + do ib=1,nTri_Elem1(lb) + do ia=1,nTri_Elem1(la) + if (iPrint >= 99) write(u6,*) ' ia,ib=',ia,ib + + do iC=1,(2*iAng+1) + if (iPrint >= 99) write(u6,*) ' iC,=',iC + iaC = (iC-1)*nTri_Elem1(la)+ia + ipaC = (iaC-1)*nAlpha*nExpi+ipF1 + iCb = (ib-1)*(2*iAng+1)+iC + ipCb = (iCb-1)*nExpi*nBeta+ipF2 + + iIC = 0 + if (iPrint >= 99) then + call RecPrt('',' ',Array(ipaC),nAlpha,nExpi) + call RecPrt('',' ',Array(ipCb),nExpi,nBeta) + end if + do iIrrep=0,nIrrep-1 + if (.not. btest(llOper,iIrrep)) cycle + if (iPrint >= 99) write(u6,*) ' iIC=',iIC + iIC = iIC+1 + nOp = NrOpr(iDCRT(lDCRT)) + Xg = real(iChTbl(iIrrep,nOp),kind=wp) + Factor = Xg*Fact + call DGEMM_('N','N',nAlpha,nExpi,nExpi,One,Array(ipaC),nAlpha,Array(ipC),nExpi,Zero,Array(ipTmp),nAlpha) + call DGEMM_('N','N',nAlpha,nBeta,nExpi,Factor,Array(ipTmp),nAlpha,Array(ipCb),nExpi,One,rFinal(1,ia,ib,iIC), & + nAlpha) + end do + + end do + end do + end do + + end do + end do + end do + end if + mdc = mdc+dbsc(iCnttp)%nCntr +end do + +if (iPrint >= 99) then + write(u6,*) ' Result in SROInt' + do ia=1,(la+1)*(la+2)/2 + do ib=1,(lb+1)*(lb+2)/2 + write(Label,'(A,I2,A,I2,A)') ' rFinal(',ia,',',ib,')' + call RecPrt(Label,' ',rFinal(:,ia,ib,1),nAlpha,nBeta) + end do + end do +end if + +return + +end subroutine SROInt diff -Nru openmolcas-22.02/src/oneint_util/sromem.f openmolcas-22.10/src/oneint_util/sromem.f --- openmolcas-22.02/src/oneint_util/sromem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/sromem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,76 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine SROMem( -#define _CALLING_ -#include "mem_interface.fh" - &) -************************************************************************ -* Object: to compute the number of real*8 the kernel routine will * -* need for the computation of a matrix element between two * -* cartesian Gaussian functions with the total angular momentum* -* of la and lb (la=0 s-function, la=1 p-function, etc.) * -* lr is the order of the operator (this is only used when the * -* integrals are computed with the Hermite-Gauss quadrature). * -* * -* Called from: OneEl * -* * -************************************************************************ -* - use Basis_Info, only: dbsc, nCnttp, Shells -#include "mem_interface.fh" -* - nElem(i) = (i+1)*(i+2)/2 -* - nHer = 0 - Mem = 0 - Do 1960 iCnttp = 1, nCnttp - If (.Not.dbsc(iCnttp)%ECP) Cycle - Do 1966 iAng = 0, dbsc(iCnttp)%nSRO-1 - iShll = dbsc(iCnttp)%iSRO + iAng - nExpi = Shells(iShll)%nExp - If (nExpi.eq.0) Cycle -* - ip = 0 - ip = ip + nExpi**2 - nac = nElem(la)*nElem(iAng) - ip = ip + nExpi*nac - ip = ip + 3 * nExpi - ip = ip + nExpi - ip = ip + nExpi - ip = ip + nExpi -* - Call MltMmP(nH,MemMlt,la,iAng,lr) - nHer = Max(nH,nHer) - Mem = Max(Mem,ip+nExpi*MemMlt) - ip = ip - 6 * nExpi -* - ncb = nElem(iAng)*nElem(lb) - ip = ip + nExpi*ncb - ip = ip + 3 * nExpi - ip = ip + nExpi - ip = ip + nExpi - ip = ip + nExpi -* - Call MltMmP(nH,MemMlt,iAng,lb,lr) - nHer = Max(nH,nHer) - Mem = Max(Mem,ip+nExpi*MemMlt) - ip = ip - 6 * nExpi -* - ip = ip + Max(nExpi*nac,ncb*nExpi) - Mem = Max(Mem,ip) -* - 1966 Continue - 1960 Continue -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/sromem.F90 openmolcas-22.10/src/oneint_util/sromem.F90 --- openmolcas-22.02/src/oneint_util/sromem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/sromem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,82 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine SROMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) +!*********************************************************************** +! Object: to compute the number of real*8 the kernel routine will * +! need for the computation of a matrix element between two * +! cartesian Gaussian functions with the total angular momentum* +! of la and lb (la=0 s-function, la=1 p-function, etc.) * +! lr is the order of the operator (this is only used when the * +! integrals are computed with the Hermite-Gauss quadrature). * +! * +! Called from: OneEl * +! * +!*********************************************************************** + +use Basis_Info, only: dbsc, nCnttp, Shells +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: iAng, iCnttp, ip, iShll, memMlt, nac, ncb, nExpi, nH + +nHer = 0 +Mem = 0 +do iCnttp=1,nCnttp + if (dbsc(iCnttp)%ECP) then + do iAng=0,dbsc(iCnttp)%nSRO-1 + iShll = dbsc(iCnttp)%iSRO+iAng + nExpi = Shells(iShll)%nExp + if (nExpi == 0) cycle + + ip = 0 + ip = ip+nExpi**2 + nac = nTri_Elem1(la)*nTri_Elem1(iAng) + ip = ip+nExpi*nac + ip = ip+3*nExpi + ip = ip+nExpi + ip = ip+nExpi + ip = ip+nExpi + + call MltMmP(nH,MemMlt,la,iAng,lr) + nHer = max(nH,nHer) + Mem = max(Mem,ip+nExpi*MemMlt) + ip = ip-6*nExpi + + ncb = nTri_Elem1(iAng)*nTri_Elem1(lb) + ip = ip+nExpi*ncb + ip = ip+3*nExpi + ip = ip+nExpi + ip = ip+nExpi + ip = ip+nExpi + + call MltMmP(nH,MemMlt,iAng,lb,lr) + nHer = max(nH,nHer) + Mem = max(Mem,ip+nExpi*MemMlt) + ip = ip-6*nExpi + + ip = ip+max(nExpi*nac,ncb*nExpi) + Mem = max(Mem,ip) + + end do + end if +end do + +return + +end subroutine SROMem diff -Nru openmolcas-22.02/src/oneint_util/util1.f openmolcas-22.10/src/oneint_util/util1.f --- openmolcas-22.02/src/oneint_util/util1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/util1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,211 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine Util1(Alpha,Beta,nZeta,Final,la,lb, - * Slaplb,Slamlb,Slalbp,Slalbm) -************************************************************************ -* * -* Object: to assemble the electric field integrals from * -* derivative integrals of the electric potential. * -* * -* Author: Roland Lindh, Dep. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* February '91 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Final(nZeta,3,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2), - * Slaplb(nZeta,(la+2)*(la+3)/2,(lb+1)*(lb+2)/2), - * Slamlb(nZeta,(la)*(la+1)/2,(lb+1)*(lb+2)/2), - * Slalbp(nZeta,(la+1)*(la+2)/2,(lb+2)*(lb+3)/2), - * Slalbm(nZeta,(la+1)*(la+2)/2,(lb)*(lb+1)/2), - * Alpha(nZeta), Beta(nZeta) - Character*80 Label -* -* Statement function for cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 - nElem(ix) = (ix+1)*(ix+2)/2 -* - iRout = 203 - iPrint = nPrint(iRout) -* - If (iPrint.ge.99) Then - Write (6,*) ' In Util1 la,lb=',la,lb - Call RecPrt('Alpha',' ',Alpha,nZeta,1) - Call RecPrt('Beta',' ',Beta,nZeta,1) - Do 200 ib = 1, nElem(lb) - Write (Label,'(A,I2,A)') ' Slaplb(la,',ib,')' - Call RecPrt(Label,' ',Slaplb(1,1,ib),nZeta,nElem(la+1)) -200 Continue - If (la.gt.0) Then - Do 201 ib = 1, nElem(lb) - Write (Label,'(A,I2,A)') ' Slamlb(la,',ib,')' - Call RecPrt(Label,' ',Slamlb(1,1,ib),nZeta,nElem(la-1)) -201 Continue - End If - Do 300 ib = 1, nElem(lb+1) - Write (Label,'(A,I2,A)') ' Slalbp(la,',ib,')' - Call RecPrt(Label,' ',Slalbp(1,1,ib),nZeta,nElem(la)) -300 Continue - If (lb.gt.0) Then - Do 301 ib = 1, nElem(lb-1) - Write (Label,'(A,I2,A)') ' Slalbm(la,',ib,')' - Call RecPrt(Label,' ',Slalbm(1,1,ib),nZeta,nElem(la)) -301 Continue - End If - End If -* - Do 10 ixa = la, 0, -1 - Do 11 iya = la-ixa, 0, -1 - iza = la-ixa-iya - ipa = Ind(la,ixa,iza) -* - Do 20 ixb = lb, 0, -1 - Do 21 iyb = lb-ixb, 0, -1 - izb = lb-ixb-iyb - ipb = Ind(lb,ixb,izb) -* - If (ixa.eq.0 .and. ixb.eq.0) Then -* - Do 33 iZeta = 1, nZeta - Final(iZeta,1,ipa,ipb) = - * Two*Alpha(iZeta)*Slaplb(iZeta,Ind(la+1,ixa+1,iza),ipb) - * +Two*Beta(iZeta)*Slalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb)) -33 Continue -* - Else If (ixa.eq.0) Then -* - Do 32 iZeta = 1, nZeta - Final(iZeta,1,ipa,ipb) = - * Two*Alpha(iZeta)*Slaplb(iZeta,Ind(la+1,ixa+1,iza),ipb) - * +Two*Beta(iZeta)*Slalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb)) - * -Dble(ixb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb-1,izb)) -32 Continue -* - Else If (ixb.eq.0) Then -* - Do 31 iZeta = 1, nZeta - Final(iZeta,1,ipa,ipb) = - * Two*Alpha(iZeta)*Slaplb(iZeta,Ind(la+1,ixa+1,iza),ipb) - * -Dble(ixa)*Slamlb(iZeta,Ind(la-1,ixa-1,iza),ipb) - * +Two*Beta(iZeta)*Slalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb)) -31 Continue -* - Else -* - Do 30 iZeta = 1, nZeta - Final(iZeta,1,ipa,ipb) = - * Two*Alpha(iZeta)*Slaplb(iZeta,Ind(la+1,ixa+1,iza),ipb) - * -Dble(ixa)*Slamlb(iZeta,Ind(la-1,ixa-1,iza),ipb) - * +Two*Beta(iZeta)*Slalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb)) - * -Dble(ixb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb-1,izb)) -30 Continue -* - End If -* - If (iya.eq.0 .and. iyb.eq.0) Then -* - Do 63 iZeta = 1, nZeta - Final(iZeta,2,ipa,ipb) = - * Two*Alpha(iZeta)*Slaplb(iZeta,Ind(la+1,ixa,iza),ipb) - * +Two*Beta(iZeta)*Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb)) -63 Continue -* - Else If (iya.eq.0) Then -* - Do 62 iZeta = 1, nZeta - Final(iZeta,2,ipa,ipb) = - * Two*Alpha(iZeta)*Slaplb(iZeta,Ind(la+1,ixa,iza),ipb) - * +Two*Beta(iZeta)*Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb)) - * -Dble(iyb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb)) -62 Continue -* - Else If (iyb.eq.0) Then -* - Do 61 iZeta = 1, nZeta - Final(iZeta,2,ipa,ipb) = - * Two*Alpha(iZeta)*Slaplb(iZeta,Ind(la+1,ixa,iza),ipb) - * -Dble(iya)*Slamlb(iZeta,Ind(la-1,ixa,iza),ipb) - * +Two*Beta(iZeta)*Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb)) -61 Continue -* - Else -* - Do 60 iZeta = 1, nZeta - Final(iZeta,2,ipa,ipb) = - * Two*Alpha(iZeta)*Slaplb(iZeta,Ind(la+1,ixa,iza),ipb) - * -Dble(iya)*Slamlb(iZeta,Ind(la-1,ixa,iza),ipb) - * +Two*Beta(iZeta)*Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb)) - * -Dble(iyb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb)) -60 Continue -* - End If -* - If (iza.eq.0 .and. izb.eq.0) Then -* - Do 93 iZeta = 1, nZeta - Final(iZeta,3,ipa,ipb) = - * Two*Alpha(iZeta)*Slaplb(iZeta,Ind(la+1,ixa,iza+1),ipb) - * +Two*Beta(iZeta)*Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb+1)) -93 Continue -* - Else If (iza.eq.0) Then -* - Do 92 iZeta = 1, nZeta - Final(iZeta,3,ipa,ipb) = - * Two*Alpha(iZeta)*Slaplb(iZeta,Ind(la+1,ixa,iza+1),ipb) - * +Two*Beta(iZeta)*Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb+1)) - * -Dble(izb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb-1)) -92 Continue -* - Else If (izb.eq.0) Then -* - Do 91 iZeta = 1, nZeta - Final(iZeta,3,ipa,ipb) = - * Two*Alpha(iZeta)*Slaplb(iZeta,Ind(la+1,ixa,iza+1),ipb) - * -Dble(iza)*Slamlb(iZeta,Ind(la-1,ixa,iza-1),ipb) - * +Two*Beta(iZeta)*Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb+1)) -91 Continue -* - Else -* - Do 90 iZeta = 1, nZeta - Final(iZeta,3,ipa,ipb) = - * Two*Alpha(iZeta)*Slaplb(iZeta,Ind(la+1,ixa,iza+1),ipb) - * -Dble(iza)*Slamlb(iZeta,Ind(la-1,ixa,iza-1),ipb) - * +Two*Beta(iZeta)*Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb+1)) - * -Dble(izb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb-1)) -90 Continue -* - End If -* -21 Continue -20 Continue -* -11 Continue -10 Continue -* - If (iPrint.ge.49) Then - Write (6,*) ' In Util1 la,lb=',la,lb - Do 400 iElem = 1, nElem(la) - Do 410 jElem = 1, nElem(lb) - Write (Label,'(A,I2,A,I2,A)') - * ' Final (',iElem,',',jElem,') ' - Call RecPrt(Label,' ',Final(1,1,iElem,jElem),nZeta,3) -410 Continue -400 Continue - End If -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/util1.F90 openmolcas-22.10/src/oneint_util/util1.F90 --- openmolcas-22.02/src/oneint_util/util1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/util1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,138 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine Util1(Alpha,Beta,nZeta,rFinal,la,lb,Slaplb,Slamlb,Slalbp,Slalbm) +!*********************************************************************** +! * +! Object: to assemble the electric field integrals from * +! derivative integrals of the electric potential. * +! * +! Author: Roland Lindh, Dep. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! February '91 * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: Two +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb +real(kind=wp), intent(in) :: Alpha(nZeta), Beta(nZeta), Slaplb(nZeta,nTri_Elem1(la+1),nTri_Elem1(lb)), & + Slamlb(nZeta,nTri_Elem1(la-1),nTri_Elem1(lb)), Slalbp(nZeta,nTri_Elem1(la),nTri_Elem1(lb+1)), & + Slalbm(nZeta,nTri_Elem1(la),nTri_Elem1(lb-1)) +real(kind=wp), intent(out) :: rFinal(nZeta,3,nTri_Elem1(la),nTri_Elem1(lb)) +#include "print.fh" +integer(kind=iwp) :: ib, iElem, ipa, ipb, iPrint, iRout, ixa, ixb, iya, iyb, iza, izb, jElem +character(len=80) :: Label + +iRout = 203 +iPrint = nPrint(iRout) + +if (iPrint >= 99) then + write(u6,*) ' In Util1 la,lb=',la,lb + call RecPrt('Alpha',' ',Alpha,nZeta,1) + call RecPrt('Beta',' ',Beta,nZeta,1) + do ib=1,nTri_Elem1(lb) + write(Label,'(A,I2,A)') ' Slaplb(la,',ib,')' + call RecPrt(Label,' ',Slaplb(:,:,ib),nZeta,nTri_Elem1(la+1)) + end do + if (la > 0) then + do ib=1,nTri_Elem1(lb) + write(Label,'(A,I2,A)') ' Slamlb(la,',ib,')' + call RecPrt(Label,' ',Slamlb(:,:,ib),nZeta,nTri_Elem1(la-1)) + end do + end if + do ib=1,nTri_Elem1(lb+1) + write(Label,'(A,I2,A)') ' Slalbp(la,',ib,')' + call RecPrt(Label,' ',Slalbp(:,:,ib),nZeta,nTri_Elem1(la)) + end do + if (lb > 0) then + do ib=1,nTri_Elem1(lb-1) + write(Label,'(A,I2,A)') ' Slalbm(la,',ib,')' + call RecPrt(Label,' ',Slalbm(:,:,ib),nZeta,nTri_Elem1(la)) + end do + end if +end if + +do ixa=la,0,-1 + do iya=la-ixa,0,-1 + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + + do ixb=lb,0,-1 + do iyb=lb-ixb,0,-1 + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + + if ((ixa /= 0) .and. (ixb /= 0)) then + rFinal(:,1,ipa,ipb) = Two*Alpha*Slaplb(:,C_Ind(la+1,ixa+1,iza),ipb)+Two*Beta*Slalbp(:,ipa,C_Ind(lb+1,ixb+1,izb))- & + real(ixa,kind=wp)*Slamlb(:,C_Ind(la-1,ixa-1,iza),ipb)- & + real(ixb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb-1,izb)) + else if (ixa /= 0) then + rFinal(:,1,ipa,ipb) = Two*Alpha*Slaplb(:,C_Ind(la+1,ixa+1,iza),ipb)+Two*Beta*Slalbp(:,ipa,C_Ind(lb+1,ixb+1,izb))- & + real(ixa,kind=wp)*Slamlb(:,C_Ind(la-1,ixa-1,iza),ipb) + else if (ixb /= 0) then + rFinal(:,1,ipa,ipb) = Two*Alpha*Slaplb(:,C_Ind(la+1,ixa+1,iza),ipb)+Two*Beta*Slalbp(:,ipa,C_Ind(lb+1,ixb+1,izb))- & + real(ixb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb-1,izb)) + else + rFinal(:,1,ipa,ipb) = Two*Alpha*Slaplb(:,C_Ind(la+1,ixa+1,iza),ipb)+Two*Beta*Slalbp(:,ipa,C_Ind(lb+1,ixb+1,izb)) + end if + + if ((iya /= 0) .and. (iyb /= 0)) then + rFinal(:,2,ipa,ipb) = Two*Alpha*Slaplb(:,C_Ind(la+1,ixa,iza),ipb)+Two*Beta*Slalbp(:,ipa,C_Ind(lb+1,ixb,izb))- & + real(iya,kind=wp)*Slamlb(:,C_Ind(la-1,ixa,iza),ipb)- & + real(iyb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb)) + else if (iya /= 0) then + rFinal(:,2,ipa,ipb) = Two*Alpha*Slaplb(:,C_Ind(la+1,ixa,iza),ipb)+Two*Beta*Slalbp(:,ipa,C_Ind(lb+1,ixb,izb))- & + real(iya,kind=wp)*Slamlb(:,C_Ind(la-1,ixa,iza),ipb) + else if (iyb /= 0) then + rFinal(:,2,ipa,ipb) = Two*Alpha*Slaplb(:,C_Ind(la+1,ixa,iza),ipb)+Two*Beta*Slalbp(:,ipa,C_Ind(lb+1,ixb,izb))- & + real(iyb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb)) + else + rFinal(:,2,ipa,ipb) = Two*Alpha*Slaplb(:,C_Ind(la+1,ixa,iza),ipb)+Two*Beta*Slalbp(:,ipa,C_Ind(lb+1,ixb,izb)) + end if + + if ((iza /= 0) .and. (izb /= 0)) then + rFinal(:,3,ipa,ipb) = Two*Alpha*Slaplb(:,C_Ind(la+1,ixa,iza+1),ipb)+Two*Beta*Slalbp(:,ipa,C_Ind(lb+1,ixb,izb+1))- & + real(iza,kind=wp)*Slamlb(:,C_Ind(la-1,ixa,iza-1),ipb)- & + real(izb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb-1)) + else if (iza /= 0) then + rFinal(:,3,ipa,ipb) = Two*Alpha*Slaplb(:,C_Ind(la+1,ixa,iza+1),ipb)+Two*Beta*Slalbp(:,ipa,C_Ind(lb+1,ixb,izb+1))- & + real(iza,kind=wp)*Slamlb(:,C_Ind(la-1,ixa,iza-1),ipb) + else if (izb /= 0) then + rFinal(:,3,ipa,ipb) = Two*Alpha*Slaplb(:,C_Ind(la+1,ixa,iza+1),ipb)+Two*Beta*Slalbp(:,ipa,C_Ind(lb+1,ixb,izb+1))- & + real(izb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb-1)) + else + rFinal(:,3,ipa,ipb) = Two*Alpha*Slaplb(:,C_Ind(la+1,ixa,iza+1),ipb)+Two*Beta*Slalbp(:,ipa,C_Ind(lb+1,ixb,izb+1)) + end if + + end do + end do + + end do +end do + +if (iPrint >= 49) then + write(u6,*) ' In Util1 la,lb=',la,lb + do iElem=1,nTri_Elem1(la) + do jElem=1,nTri_Elem1(lb) + write(Label,'(A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,') ' + call RecPrt(Label,' ',rFinal(:,:,iElem,jElem),nZeta,3) + end do + end do +end if + +return + +end subroutine Util1 diff -Nru openmolcas-22.02/src/oneint_util/util2.f openmolcas-22.10/src/oneint_util/util2.f --- openmolcas-22.02/src/oneint_util/util2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/util2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,146 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine Util2(Beta,nZeta,Final,la,lb,Slalbp,Slalbm) -************************************************************************ -* * -* Object: to assemble the orbital angular momentum integrals from the * -* derivative integrals and dipole integrals. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* February '91 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Final (nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,3), - & Slalbp(nZeta,(la+1)*(la+2)/2,(lb+2)*(lb+3)/2,3), - & Slalbm(nZeta,(la+1)*(la+2)/2, lb *(lb+1)/2,3), - & Beta(nZeta) - Character*80 Label -* -* Statement function for cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 - nElem(ix) = (ix+1)*(ix+2)/2 -* - iRout = 211 - iPrint = nPrint(iRout) -* - If (iPrint.ge.99) Then - Write (6,*) ' In Util2 la,lb=',la,lb - Call RecPrt('Beta',' ',Beta,nZeta,1) - Do 100 ia = 1, nElem(la) - Do 200 ib = 1, nElem(lb+1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbp(',ia,',',ib,'x)' - Call RecPrt(Label,' ',Slalbp(1,ia,ib,1),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbp(',ia,',',ib,'y)' - Call RecPrt(Label,' ',Slalbp(1,ia,ib,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbp(',ia,',',ib,'z)' - Call RecPrt(Label,' ',Slalbp(1,ia,ib,3),nZeta,1) - 200 Continue - 100 Continue - If (lb.gt.0) Then - Do 101 ia = 1, nElem(la) - Do 201 ib = 1, nElem(lb-1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbm(',ia,',',ib,'x)' - Call RecPrt(Label,' ',Slalbm(1,ia,ib,1),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbm(',ia,',',ib,'y)' - Call RecPrt(Label,' ',Slalbm(1,ia,ib,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbm(',ia,',',ib,'z)' - Call RecPrt(Label,' ',Slalbm(1,ia,ib,3),nZeta,1) - 201 Continue - 101 Continue - End If - End If -* - Do 10 ixa = la, 0, -1 - Do 11 iya = la-ixa, 0, -1 - iza = la-ixa-iya - ipa = Ind(la,ixa,iza) -* - Do 20 ixb = lb, 0, -1 - Do 21 iyb = lb-ixb, 0, -1 - izb = lb-ixb-iyb - ipb = Ind(lb,ixb,izb) -* - Do 30 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = Two*Beta(iZeta) * ( - & Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb+1),2) - & -Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb),3) ) - Final(iZeta,ipa,ipb,2) = Two*Beta(iZeta) * ( - & Slalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb),3) - & -Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb+1),1) ) - Final(iZeta,ipa,ipb,3) = Two*Beta(iZeta) * ( - & Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb),1) - & -Slalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb),2) ) - 30 Continue -* - If (ixb.gt.0) Then - Do 31 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,2) = Final(iZeta,ipa,ipb,2) - & -Dble(ixb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb-1,izb),3) - Final(iZeta,ipa,ipb,3) = Final(iZeta,ipa,ipb,3) - & +Dble(ixb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb-1,izb),2) - 31 Continue - End If -* - If (iyb.gt.0) Then - Do 32 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,3) = Final(iZeta,ipa,ipb,3) - & -Dble(iyb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb),1) - Final(iZeta,ipa,ipb,1) = Final(iZeta,ipa,ipb,1) - & +Dble(iyb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb),3) - 32 Continue - End If -* - If (izb.gt.0) Then - Do 33 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = Final(iZeta,ipa,ipb,1) - & -Dble(izb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb-1),2) - Final(iZeta,ipa,ipb,2) = Final(iZeta,ipa,ipb,2) - & +Dble(izb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb-1),1) - 33 Continue - End If -* - 21 Continue - 20 Continue -* - 11 Continue - 10 Continue -* - If (iPrint.ge.49) Then - Write (6,*) ' In Util2 la,lb=',la,lb - Do 300 iElem = 1, nElem(la) - Do 310 jElem = 1, nElem(lb) - Write (Label,'(A,I2,A,I2,A)') - & ' Final (',iElem,',',jElem,',x) ' - Call RecPrt(Label,' ',Final(1,iElem,jElem,1),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Final (',iElem,',',jElem,',y) ' - Call RecPrt(Label,' ',Final(1,iElem,jElem,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Final (',iElem,',',jElem,',z) ' - Call RecPrt(Label,' ',Final(1,iElem,jElem,3),nZeta,1) - 310 Continue - 300 Continue - End If -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/util2.F90 openmolcas-22.10/src/oneint_util/util2.F90 --- openmolcas-22.02/src/oneint_util/util2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/util2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,119 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine Util2(Beta,nZeta,rFinal,la,lb,Slalbp,Slalbm) +!*********************************************************************** +! * +! Object: to assemble the orbital angular momentum integrals from the * +! derivative integrals and dipole integrals. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! February '91 * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: Two +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb +real(kind=wp), intent(in) :: Beta(nZeta), Slalbp(nZeta,nTri_Elem1(la),nTri_Elem1(lb+1),3), & + Slalbm(nZeta,nTri_Elem1(la),nTri_Elem1(lb-1),3) +real(kind=wp), intent(out) :: rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),3) +#include "print.fh" +integer(kind=iwp) :: ia, ib, iElem, ipa, ipb, iPrint, iRout, ixa, ixb, iya, iyb, iza, izb, jElem +character(len=80) :: Label + +iRout = 211 +iPrint = nPrint(iRout) + +if (iPrint >= 99) then + write(u6,*) ' In Util2 la,lb=',la,lb + call RecPrt('Beta',' ',Beta,nZeta,1) + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb+1) + write(Label,'(A,I2,A,I2,A)') ' Slalbp(',ia,',',ib,'x)' + call RecPrt(Label,' ',Slalbp(:,ia,ib,1),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbp(',ia,',',ib,'y)' + call RecPrt(Label,' ',Slalbp(:,ia,ib,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbp(',ia,',',ib,'z)' + call RecPrt(Label,' ',Slalbp(:,ia,ib,3),nZeta,1) + end do + end do + if (lb > 0) then + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb-1) + write(Label,'(A,I2,A,I2,A)') ' Slalbm(',ia,',',ib,'x)' + call RecPrt(Label,' ',Slalbm(:,ia,ib,1),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbm(',ia,',',ib,'y)' + call RecPrt(Label,' ',Slalbm(:,ia,ib,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbm(',ia,',',ib,'z)' + call RecPrt(Label,' ',Slalbm(:,ia,ib,3),nZeta,1) + end do + end do + end if +end if + +do ixa=la,0,-1 + do iya=la-ixa,0,-1 + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + + do ixb=lb,0,-1 + do iyb=lb-ixb,0,-1 + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + + rFinal(:,ipa,ipb,1) = Two*Beta*(Slalbp(:,ipa,C_Ind(lb+1,ixb,izb+1),2)-Slalbp(:,ipa,C_Ind(lb+1,ixb,izb),3)) + rFinal(:,ipa,ipb,2) = Two*Beta*(Slalbp(:,ipa,C_Ind(lb+1,ixb+1,izb),3)-Slalbp(:,ipa,C_Ind(lb+1,ixb,izb+1),1)) + rFinal(:,ipa,ipb,3) = Two*Beta*(Slalbp(:,ipa,C_Ind(lb+1,ixb,izb),1)-Slalbp(:,ipa,C_Ind(lb+1,ixb+1,izb),2)) + + if (ixb > 0) then + rFinal(:,ipa,ipb,2) = rFinal(:,ipa,ipb,2)-real(ixb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb-1,izb),3) + rFinal(:,ipa,ipb,3) = rFinal(:,ipa,ipb,3)+real(ixb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb-1,izb),2) + end if + + if (iyb > 0) then + rFinal(:,ipa,ipb,3) = rFinal(:,ipa,ipb,3)-real(iyb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb),1) + rFinal(:,ipa,ipb,1) = rFinal(:,ipa,ipb,1)+real(iyb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb),3) + end if + + if (izb > 0) then + rFinal(:,ipa,ipb,1) = rFinal(:,ipa,ipb,1)-real(izb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb-1),2) + rFinal(:,ipa,ipb,2) = rFinal(:,ipa,ipb,2)+real(izb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb-1),1) + end if + + end do + end do + + end do +end do + +if (iPrint >= 49) then + write(u6,*) ' In Util2 la,lb=',la,lb + do iElem=1,nTri_Elem1(la) + do jElem=1,nTri_Elem1(lb) + write(Label,'(A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,',x) ' + call RecPrt(Label,' ',rFinal(:,iElem,jElem,1),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,',y) ' + call RecPrt(Label,' ',rFinal(:,iElem,jElem,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,',z) ' + call RecPrt(Label,' ',rFinal(:,iElem,jElem,3),nZeta,1) + end do + end do +end if + +return + +end subroutine Util2 diff -Nru openmolcas-22.02/src/oneint_util/util3.f openmolcas-22.10/src/oneint_util/util3.f --- openmolcas-22.02/src/oneint_util/util3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/util3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,331 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991,2015, Roland Lindh * -* 2015, Lasse Kragh Soerensen * -************************************************************************ - SubRoutine Util3(Beta,nZeta,Final,la,lb,Slalbp,Slalb,Slalbm) -************************************************************************ -* * -* Object: to assemble the orbital magnetic quadrupole integrals from * -* the derivative integrals and dipole integrals. * -* * -* Author: Roland Lindh, Lasse Kragh Soerensen * -* Dept. of Theoretical Chemistry, * -* University of Uppsala, SWEDEN * -* February '15 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - - Real*8 Final (nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,9), - & Slalbp(nZeta,(la+1)*(la+2)/2,(lb+2)*(lb+3)/2,6), - & Slalb (nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,3), - & Slalbm(nZeta,(la+1)*(la+2)/2, lb *(lb+1)/2,6), - & Beta(nZeta) -*define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Character*80 Label -#endif -! -! Notice CmbnMP has just 6 components instead of 9!!! (automatically assumes symmetry) Well fuck you CmbnMP -! This means Slalbp and Slalbm in reality only have 6 components.... -! XX = 1, XY=YX=2, XZ=ZX=3, YY=4, YZ=ZY=5 and ZZ=6 -! There are only six components since zy d/di = yz d/di -! We still keep the 9 components in final -! -* -* Statement function for cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 -#ifdef _DEBUGPRINT_ - nElem(ix) = (ix+1)*(ix+2)/2 -#endif -* -#ifdef _DEBUGPRINT_ - Write (6,*) ' In Util3 la,lb=',la,lb - Call RecPrt('Beta',' ',Beta,nZeta,1) - Do ia = 1, nElem(la) - Do ib = 1, nElem(lb+1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbp(',ia,',',ib,'xx)' - Call RecPrt(Label,' ',Slalbp(1,ia,ib,1),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbp(',ia,',',ib,'xy)' - Call RecPrt(Label,' ',Slalbp(1,ia,ib,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbp(',ia,',',ib,'xz)' - Call RecPrt(Label,' ',Slalbp(1,ia,ib,3),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbp(',ia,',',ib,'yx)' - Call RecPrt(Label,' ',Slalbp(1,ia,ib,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbp(',ia,',',ib,'yy)' - Call RecPrt(Label,' ',Slalbp(1,ia,ib,4),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbp(',ia,',',ib,'yz)' - Call RecPrt(Label,' ',Slalbp(1,ia,ib,5),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbp(',ia,',',ib,'zx)' - Call RecPrt(Label,' ',Slalbp(1,ia,ib,3),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbp(',ia,',',ib,'zy)' - Call RecPrt(Label,' ',Slalbp(1,ia,ib,5),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbp(',ia,',',ib,'zz)' - Call RecPrt(Label,' ',Slalbp(1,ia,ib,6),nZeta,1) - End Do - End Do - Do ia = 1, nElem(la) - Do ib = 1, nElem(lb) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalb (',ia,',',ib,'x)' - Call RecPrt(Label,' ',Slalb (1,ia,ib,1),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalb (',ia,',',ib,'y)' - Call RecPrt(Label,' ',Slalb (1,ia,ib,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalb (',ia,',',ib,'z)' - Call RecPrt(Label,' ',Slalb (1,ia,ib,3),nZeta,1) - End Do - End Do - If (lb.gt.0) Then - Do ia = 1, nElem(la) - Do ib = 1, nElem(lb-1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbm(',ia,',',ib,'xx)' - Call RecPrt(Label,' ',Slalbm(1,ia,ib,1),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbm(',ia,',',ib,'xy)' - Call RecPrt(Label,' ',Slalbm(1,ia,ib,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbm(',ia,',',ib,'xz)' - Call RecPrt(Label,' ',Slalbm(1,ia,ib,3),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbm(',ia,',',ib,'yx)' - Call RecPrt(Label,' ',Slalbm(1,ia,ib,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbm(',ia,',',ib,'yy)' - Call RecPrt(Label,' ',Slalbm(1,ia,ib,4),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbm(',ia,',',ib,'yz)' - Call RecPrt(Label,' ',Slalbm(1,ia,ib,5),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbm(',ia,',',ib,'zx)' - Call RecPrt(Label,' ',Slalbm(1,ia,ib,3),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbm(',ia,',',ib,'zy)' - Call RecPrt(Label,' ',Slalbm(1,ia,ib,5),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbm(',ia,',',ib,'zz)' - Call RecPrt(Label,' ',Slalbm(1,ia,ib,6),nZeta,1) - End Do - End Do - End If -#endif -* - Do 10 ixa = la, 0, -1 - Do 11 iya = la-ixa, 0, -1 - iza = la-ixa-iya - ipa = Ind(la,ixa,iza) -* - Do 20 ixb = lb, 0, -1 - Do 21 iyb = lb-ixb, 0, -1 - izb = lb-ixb-iyb - ipb = Ind(lb,ixb,izb) -* - Do 30 iZeta = 1, nZeta - temp_xx = Two*Beta(iZeta) * ( - & Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb+1),2) - & -Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb ),3) ) - temp_xy = Two*Beta(iZeta) * ( - & Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb+1),4) - & -Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb ),5) ) - temp_xz = Two*Beta(iZeta) * ( - & Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb+1),5) - & -Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb ),6) ) - temp_yx = Two*Beta(iZeta) * ( - & Slalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb),3) - & -Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb+1),1) ) - temp_yy = Two*Beta(iZeta) * ( - & Slalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb),5) - & -Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb+1),2) ) - temp_yz = Two*Beta(iZeta) * ( - & Slalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb),6) - & -Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb+1),3) ) - temp_zx = Two*Beta(iZeta) * ( - & Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb ),1) - & -Slalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb),2) ) - temp_zy = Two*Beta(iZeta) * ( - & Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb ),2) - & -Slalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb),4) ) - temp_zz = Two*Beta(iZeta) * ( - & Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb ),3) - & -Slalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb),5) ) -* - temp_x = Slalb (iZeta,ipa,Ind(lb,ixb,izb),1) - temp_y = Slalb (iZeta,ipa,Ind(lb,ixb,izb),2) - temp_z = Slalb (iZeta,ipa,Ind(lb,ixb,izb),3) -* -* xx term - Final(iZeta,ipa,ipb,1) = Two * temp_xx -* xy term - Final(iZeta,ipa,ipb,2) = Two * temp_xy - temp_z -* xz term - Final(iZeta,ipa,ipb,3) = Two * temp_xz + temp_y -* yx term - Final(iZeta,ipa,ipb,4) = Two * temp_yx + temp_z -* yy term - Final(iZeta,ipa,ipb,5) = Two * temp_yy -* yz term - Final(iZeta,ipa,ipb,6) = Two * temp_yz - temp_x -* zx term - Final(iZeta,ipa,ipb,7) = Two * temp_zx - temp_y -* zy term - Final(iZeta,ipa,ipb,8) = Two * temp_zy + temp_x -* zz term - Final(iZeta,ipa,ipb,9) = Two * temp_zz - 30 Continue -* - If (ixb.gt.0) Then - Do 31 iZeta = 1, nZeta - temp_yx = Dble(ixb) * - & Slalbm(iZeta,ipa,Ind(lb-1,ixb-1,izb),3) - temp_yy = Dble(ixb) * - & Slalbm(iZeta,ipa,Ind(lb-1,ixb-1,izb),5) - temp_yz = Dble(ixb) * - & Slalbm(iZeta,ipa,Ind(lb-1,ixb-1,izb),6) - temp_zx =-Dble(ixb) * - & Slalbm(iZeta,ipa,Ind(lb-1,ixb-1,izb),2) - temp_zy =-Dble(ixb) * - & Slalbm(iZeta,ipa,Ind(lb-1,ixb-1,izb),4) - temp_zz =-Dble(ixb) * - & Slalbm(iZeta,ipa,Ind(lb-1,ixb-1,izb),5) -* - Final(iZeta,ipa,ipb,4) = Final(iZeta,ipa,ipb,4) - & + Two * temp_yx - Final(iZeta,ipa,ipb,5) = Final(iZeta,ipa,ipb,5) - & + Two * temp_yy - Final(iZeta,ipa,ipb,6) = Final(iZeta,ipa,ipb,6) - & + Two * temp_yz - Final(iZeta,ipa,ipb,7) = Final(iZeta,ipa,ipb,7) - & + Two * temp_zx - Final(iZeta,ipa,ipb,8) = Final(iZeta,ipa,ipb,8) - & + Two * temp_zy - Final(iZeta,ipa,ipb,9) = Final(iZeta,ipa,ipb,9) - & + Two * temp_zz - 31 Continue - End If -* - If (iyb.gt.0) Then - Do 32 iZeta = 1, nZeta - temp_xx =-Dble(iyb) * - & Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb ),3) - temp_xy =-Dble(iyb) * - & Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb ),5) - temp_xz =-Dble(iyb) * - & Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb ),6) - temp_zx = Dble(iyb) * - & Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb ),1) - temp_zy = Dble(iyb) * - & Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb ),2) - temp_zz = Dble(iyb) * - & Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb ),3) -* - Final(iZeta,ipa,ipb,1) = Final(iZeta,ipa,ipb,1) - & + Two * temp_xx - Final(iZeta,ipa,ipb,2) = Final(iZeta,ipa,ipb,2) - & + Two * temp_xy - Final(iZeta,ipa,ipb,3) = Final(iZeta,ipa,ipb,3) - & + Two * temp_xz - Final(iZeta,ipa,ipb,7) = Final(iZeta,ipa,ipb,7) - & + Two * temp_zx - Final(iZeta,ipa,ipb,8) = Final(iZeta,ipa,ipb,8) - & + Two * temp_zy - Final(iZeta,ipa,ipb,9) = Final(iZeta,ipa,ipb,9) - & + Two * temp_zz -* - 32 Continue - End If -* - If (izb.gt.0) Then - Do 33 iZeta = 1, nZeta - temp_xx = Dble(izb) * - & Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb-1),2) - temp_xy = Dble(izb) * - & Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb-1),4) - temp_xz = Dble(izb) * - & Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb-1),5) - temp_yx =-Dble(izb) * - & Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb-1),1) - temp_yy =-Dble(izb) * - & Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb-1),2) - temp_yz =-Dble(izb) * - & Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb-1),3) -* - Final(iZeta,ipa,ipb,1) = Final(iZeta,ipa,ipb,1) - & + Two * temp_xx - Final(iZeta,ipa,ipb,2) = Final(iZeta,ipa,ipb,2) - & + Two * temp_xy - Final(iZeta,ipa,ipb,3) = Final(iZeta,ipa,ipb,3) - & + Two * temp_xz - Final(iZeta,ipa,ipb,4) = Final(iZeta,ipa,ipb,4) - & + Two * temp_yx - Final(iZeta,ipa,ipb,5) = Final(iZeta,ipa,ipb,5) - & + Two * temp_yy - Final(iZeta,ipa,ipb,6) = Final(iZeta,ipa,ipb,6) - & + Two * temp_yz - 33 Continue - End If -* - 21 Continue - 20 Continue -* - 11 Continue - 10 Continue -* -#ifdef _DEBUGPRINT_ - Write (6,*) ' In Util3 la,lb=',la,lb - Do 300 iElem = 1, nElem(la) - Do 310 jElem = 1, nElem(lb) - Write (Label,'(A,I2,A,I2,A)') - & ' Final (',iElem,',',jElem,',xx) ' - Call RecPrt(Label,' ',Final(1,iElem,jElem,1),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Final (',iElem,',',jElem,',xy) ' - Call RecPrt(Label,' ',Final(1,iElem,jElem,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Final (',iElem,',',jElem,',xz) ' - Call RecPrt(Label,' ',Final(1,iElem,jElem,3),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Final (',iElem,',',jElem,',yx) ' - Call RecPrt(Label,' ',Final(1,iElem,jElem,4),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Final (',iElem,',',jElem,',yy) ' - Call RecPrt(Label,' ',Final(1,iElem,jElem,5),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Final (',iElem,',',jElem,',yz) ' - Call RecPrt(Label,' ',Final(1,iElem,jElem,6),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Final (',iElem,',',jElem,',zx) ' - Call RecPrt(Label,' ',Final(1,iElem,jElem,7),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Final (',iElem,',',jElem,',zy) ' - Call RecPrt(Label,' ',Final(1,iElem,jElem,8),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Final (',iElem,',',jElem,',zz) ' - Call RecPrt(Label,' ',Final(1,iElem,jElem,9),nZeta,1) - 310 Continue - 300 Continue -#endif -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/util3.F90 openmolcas-22.10/src/oneint_util/util3.F90 --- openmolcas-22.02/src/oneint_util/util3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/util3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,204 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991,2015, Roland Lindh * +! 2015, Lasse Kragh Soerensen * +!*********************************************************************** + +subroutine Util3(Beta,nZeta,rFinal,la,lb,Slalbp,Slalb,Slalbm) +!*********************************************************************** +! * +! Object: to assemble the orbital magnetic quadrupole integrals from * +! the derivative integrals and dipole integrals. * +! * +! Author: Roland Lindh, Lasse Kragh Soerensen * +! Dept. of Theoretical Chemistry, * +! University of Uppsala, SWEDEN * +! February '15 * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: Two, Four +use Definitions, only: wp, iwp + +! Notice CmbnMP has just 6 components instead of 9!!! (automatically assumes symmetry) Well fuck you CmbnMP +! This means Slalbp and Slalbm in reality only have 6 components.... +! XX = 1, XY=YX=2, XZ=ZX=3, YY=4, YZ=ZY=5 and ZZ=6 +! There are only six components since zy d/di = yz d/di +! We still keep the 9 components in rFinal +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb +real(kind=wp), intent(in) :: Beta(nZeta), Slalbp(nZeta,nTri_Elem1(la),nTri_Elem1(lb+1),6), & + Slalb(nZeta,nTri_Elem1(la),nTri_Elem1(lb),3), Slalbm(nZeta,nTri_Elem1(la),nTri_Elem1(lb-1),6) +real(kind=wp), intent(out) :: rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),9) +integer(kind=iwp) :: ipa, ipb, ixa, ixb, iya, iyb, iza, izb +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +character(len=80) :: Label +#endif + +#ifdef _DEBUGPRINT_ +write(u6,*) ' In Util3 la,lb=',la,lb +call RecPrt('Beta',' ',Beta,nZeta,1) +do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb+1) + write(Label,'(A,I2,A,I2,A)') ' Slalbp(',ia,',',ib,'xx)' + call RecPrt(Label,' ',Slalbp(:,ia,ib,1),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbp(',ia,',',ib,'xy)' + call RecPrt(Label,' ',Slalbp(:,ia,ib,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbp(',ia,',',ib,'xz)' + call RecPrt(Label,' ',Slalbp(:,ia,ib,3),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbp(',ia,',',ib,'yx)' + call RecPrt(Label,' ',Slalbp(:,ia,ib,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbp(',ia,',',ib,'yy)' + call RecPrt(Label,' ',Slalbp(:,ia,ib,4),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbp(',ia,',',ib,'yz)' + call RecPrt(Label,' ',Slalbp(:,ia,ib,5),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbp(',ia,',',ib,'zx)' + call RecPrt(Label,' ',Slalbp(:,ia,ib,3),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbp(',ia,',',ib,'zy)' + call RecPrt(Label,' ',Slalbp(:,ia,ib,5),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbp(',ia,',',ib,'zz)' + call RecPrt(Label,' ',Slalbp(:,ia,ib,6),nZeta,1) + end do +end do +do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb) + write(Label,'(A,I2,A,I2,A)') ' Slalb (',ia,',',ib,'x)' + call RecPrt(Label,' ',Slalb(:,ia,ib,1),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalb (',ia,',',ib,'y)' + call RecPrt(Label,' ',Slalb(:,ia,ib,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalb (',ia,',',ib,'z)' + call RecPrt(Label,' ',Slalb(:,ia,ib,3),nZeta,1) + end do +end do +if (lb > 0) then + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb-1) + write(Label,'(A,I2,A,I2,A)') ' Slalbm(',ia,',',ib,'xx)' + call RecPrt(Label,' ',Slalbm(:,ia,ib,1),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbm(',ia,',',ib,'xy)' + call RecPrt(Label,' ',Slalbm(:,ia,ib,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbm(',ia,',',ib,'xz)' + call RecPrt(Label,' ',Slalbm(:,ia,ib,3),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbm(',ia,',',ib,'yx)' + call RecPrt(Label,' ',Slalbm(:,ia,ib,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbm(',ia,',',ib,'yy)' + call RecPrt(Label,' ',Slalbm(:,ia,ib,4),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbm(',ia,',',ib,'yz)' + call RecPrt(Label,' ',Slalbm(:,ia,ib,5),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbm(',ia,',',ib,'zx)' + call RecPrt(Label,' ',Slalbm(:,ia,ib,3),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbm(',ia,',',ib,'zy)' + call RecPrt(Label,' ',Slalbm(:,ia,ib,5),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbm(',ia,',',ib,'zz)' + call RecPrt(Label,' ',Slalbm(:,ia,ib,6),nZeta,1) + end do + end do +end if +#endif + +do ixa=la,0,-1 + do iya=la-ixa,0,-1 + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + + do ixb=lb,0,-1 + do iyb=lb-ixb,0,-1 + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + + ! xx term + rFinal(:,ipa,ipb,1) = Four*Beta*(Slalbp(:,ipa,C_Ind(lb+1,ixb,izb+1),2)-Slalbp(:,ipa,C_Ind(lb+1,ixb,izb),3)) + ! xy term + rFinal(:,ipa,ipb,2) = Four*Beta*(Slalbp(:,ipa,C_Ind(lb+1,ixb,izb+1),4)-Slalbp(:,ipa,C_Ind(lb+1,ixb,izb),5))- & + Slalb(:,ipa,C_Ind(lb,ixb,izb),3) + ! xz term + rFinal(:,ipa,ipb,3) = Four*Beta*(Slalbp(:,ipa,C_Ind(lb+1,ixb,izb+1),5)-Slalbp(:,ipa,C_Ind(lb+1,ixb,izb),6))+ & + Slalb(:,ipa,C_Ind(lb,ixb,izb),2) + ! yx term + rFinal(:,ipa,ipb,4) = Four*Beta*(Slalbp(:,ipa,C_Ind(lb+1,ixb+1,izb),3)-Slalbp(:,ipa,C_Ind(lb+1,ixb,izb+1),1))+ & + Slalb(:,ipa,C_Ind(lb,ixb,izb),3) + ! yy term + rFinal(:,ipa,ipb,5) = Four*Beta*(Slalbp(:,ipa,C_Ind(lb+1,ixb+1,izb),5)-Slalbp(:,ipa,C_Ind(lb+1,ixb,izb+1),2)) + ! yz term + rFinal(:,ipa,ipb,6) = Four*Beta*(Slalbp(:,ipa,C_Ind(lb+1,ixb+1,izb),6)-Slalbp(:,ipa,C_Ind(lb+1,ixb,izb+1),3))- & + Slalb(:,ipa,C_Ind(lb,ixb,izb),1) + ! zx term + rFinal(:,ipa,ipb,7) = Four*Beta*(Slalbp(:,ipa,C_Ind(lb+1,ixb,izb),1)-Slalbp(:,ipa,C_Ind(lb+1,ixb+1,izb),2))- & + Slalb(:,ipa,C_Ind(lb,ixb,izb),2) + ! zy term + rFinal(:,ipa,ipb,8) = Four*Beta*(Slalbp(:,ipa,C_Ind(lb+1,ixb,izb),2)-Slalbp(:,ipa,C_Ind(lb+1,ixb+1,izb),4))+ & + Slalb(:,ipa,C_Ind(lb,ixb,izb),1) + ! zz term + rFinal(:,ipa,ipb,9) = Four*Beta*(Slalbp(:,ipa,C_Ind(lb+1,ixb,izb),3)-Slalbp(:,ipa,C_Ind(lb+1,ixb+1,izb),5)) + + if (ixb > 0) then + rFinal(:,ipa,ipb,4) = rFinal(:,ipa,ipb,4)+Two*real(ixb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb-1,izb),3) + rFinal(:,ipa,ipb,5) = rFinal(:,ipa,ipb,5)+Two*real(ixb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb-1,izb),5) + rFinal(:,ipa,ipb,6) = rFinal(:,ipa,ipb,6)+Two*real(ixb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb-1,izb),6) + rFinal(:,ipa,ipb,7) = rFinal(:,ipa,ipb,7)-Two*real(ixb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb-1,izb),2) + rFinal(:,ipa,ipb,8) = rFinal(:,ipa,ipb,8)-Two*real(ixb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb-1,izb),4) + rFinal(:,ipa,ipb,9) = rFinal(:,ipa,ipb,9)-Two*real(ixb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb-1,izb),5) + end if + + if (iyb > 0) then + rFinal(:,ipa,ipb,1) = rFinal(:,ipa,ipb,1)-Two*real(iyb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb),3) + rFinal(:,ipa,ipb,2) = rFinal(:,ipa,ipb,2)-Two*real(iyb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb),5) + rFinal(:,ipa,ipb,3) = rFinal(:,ipa,ipb,3)-Two*real(iyb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb),6) + rFinal(:,ipa,ipb,7) = rFinal(:,ipa,ipb,7)+Two*real(iyb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb),1) + rFinal(:,ipa,ipb,8) = rFinal(:,ipa,ipb,8)+Two*real(iyb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb),2) + rFinal(:,ipa,ipb,9) = rFinal(:,ipa,ipb,9)+Two*real(iyb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb),3) + end if + + if (izb > 0) then + rFinal(:,ipa,ipb,1) = rFinal(:,ipa,ipb,1)+Two*real(izb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb-1),2) + rFinal(:,ipa,ipb,2) = rFinal(:,ipa,ipb,2)+Two*real(izb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb-1),4) + rFinal(:,ipa,ipb,3) = rFinal(:,ipa,ipb,3)+Two*real(izb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb-1),5) + rFinal(:,ipa,ipb,4) = rFinal(:,ipa,ipb,4)-Two*real(izb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb-1),1) + rFinal(:,ipa,ipb,5) = rFinal(:,ipa,ipb,5)-Two*real(izb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb-1),2) + rFinal(:,ipa,ipb,6) = rFinal(:,ipa,ipb,6)-Two*real(izb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb-1),3) + end if + + end do + end do + + end do +end do + +#ifdef _DEBUGPRINT_ +write(u6,*) ' In Util3 la,lb=',la,lb +do iElem=1,nTri_Elem1(la) + do jElem=1,nTri_Elem1(lb) + write(Label,'(A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,',xx) ' + call RecPrt(Label,' ',rFinal(:,iElem,jElem,1),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,',xy) ' + call RecPrt(Label,' ',rFinal(:,iElem,jElem,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,',xz) ' + call RecPrt(Label,' ',rFinal(:,iElem,jElem,3),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,',yx) ' + call RecPrt(Label,' ',rFinal(:,iElem,jElem,4),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,',yy) ' + call RecPrt(Label,' ',rFinal(:,iElem,jElem,5),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,',yz) ' + call RecPrt(Label,' ',rFinal(:,iElem,jElem,6),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,',zx) ' + call RecPrt(Label,' ',rFinal(:,iElem,jElem,7),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,',zy) ' + call RecPrt(Label,' ',rFinal(:,iElem,jElem,8),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,',zz) ' + call RecPrt(Label,' ',rFinal(:,iElem,jElem,9),nZeta,1) + end do +end do +#endif + +return + +end subroutine Util3 diff -Nru openmolcas-22.02/src/oneint_util/util4.f openmolcas-22.10/src/oneint_util/util4.f --- openmolcas-22.02/src/oneint_util/util4.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/util4.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,129 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine Util4(nZeta,Final,la,lb,Elalbp,Elalb,Bcoor,Dcoor) -************************************************************************ -* * -* Object: to assemble the diamagnetic shielding integrals from * -* electric field integrals. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* February '91 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Final(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,9), - & Elalbp(nZeta,(la+1)*(la+2)/2,(lb+2)*(lb+3)/2,3), - & Elalb(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,3), - & Bcoor(3), Dcoor(3), BD(3) - Character*80 Label -* -* Statement function for cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 - nElem(ix) = (ix+1)*(ix+2)/2 -* - iRout = 231 - iPrint = nPrint(iRout) -* - BD(1) = Bcoor(1) - Dcoor(1) - BD(2) = Bcoor(2) - Dcoor(2) - BD(3) = Bcoor(3) - Dcoor(3) - Fact = -1.D6 * One2C2 - If (iPrint.ge.99) Then - Write (6,*) ' In Util4 la,lb=',la,lb - Do 100 ia = 1, nElem(la) - Do 200 ib = 1, nElem(lb+1) - Write (Label,'(A,I2,A,I2,A)') - & ' Elalbp(',ia,',',ib,',x)' - Call RecPrt(Label,' ',Elalbp(1,ia,ib,1),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Elalbp(',ia,',',ib,',y)' - Call RecPrt(Label,' ',Elalbp(1,ia,ib,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Elalbp(',ia,',',ib,',z)' - Call RecPrt(Label,' ',Elalbp(1,ia,ib,3),nZeta,1) - 200 Continue - 100 Continue - Do 101 ia = 1, nElem(la) - Do 201 ib = 1, nElem(lb) - Write (Label,'(A,I2,A,I2,A)') - & ' Elalb(',ia,',',ib,',x)' - Call RecPrt(Label,' ',Elalb(1,ia,ib,1),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Elalb(',ia,',',ib,',y)' - Call RecPrt(Label,' ',Elalb(1,ia,ib,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Elalb(',ia,',',ib,',z)' - Call RecPrt(Label,' ',Elalb(1,ia,ib,3),nZeta,1) - 201 Continue - 101 Continue - End If -* - Do 10 ixa = la, 0, -1 - Do 11 iya = la-ixa, 0, -1 - iza = la-ixa-iya - ipa = Ind(la,ixa,iza) -* - Do 20 ixb = lb, 0, -1 - Do 21 iyb = lb-ixb, 0, -1 - izb = lb-ixb-iyb - ipb = Ind(lb,ixb,izb) -* - Do 30 iZeta = 1, nZeta - xCxD = Elalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb),1) + BD(1)* - & Elalb(iZeta,ipa,ipb,1) - yCxD = Elalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb),2) + BD(1)* - & Elalb(iZeta,ipa,ipb,2) - zCxD = Elalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb),3) + BD(1)* - & Elalb(iZeta,ipa,ipb,3) - xCyD = Elalbp(iZeta,ipa,Ind(lb+1,ixb,izb),1) + BD(2)* - & Elalb(iZeta,ipa,ipb,1) - yCyD = Elalbp(iZeta,ipa,Ind(lb+1,ixb,izb),2) + BD(2)* - & Elalb(iZeta,ipa,ipb,2) - zCyD = Elalbp(iZeta,ipa,Ind(lb+1,ixb,izb),3) + BD(2)* - & Elalb(iZeta,ipa,ipb,3) - xCzD = Elalbp(iZeta,ipa,Ind(lb+1,ixb,izb+1),1) + BD(3)* - & Elalb(iZeta,ipa,ipb,1) - yCzD = Elalbp(iZeta,ipa,Ind(lb+1,ixb,izb+1),2) + BD(3)* - & Elalb(iZeta,ipa,ipb,2) - zCzD = Elalbp(iZeta,ipa,Ind(lb+1,ixb,izb+1),3) + BD(3)* - & Elalb(iZeta,ipa,ipb,3) - Final(iZeta,ipa,ipb,1) = Fact * ( +yCyD+zCzD) - Final(iZeta,ipa,ipb,2) = Fact * ( -yCxD ) - Final(iZeta,ipa,ipb,3) = Fact * ( -zCxD ) - Final(iZeta,ipa,ipb,4) = Fact * ( -xCyD ) - Final(iZeta,ipa,ipb,5) = Fact * (xCxD +zCzD) - Final(iZeta,ipa,ipb,6) = Fact * ( -zCyD ) - Final(iZeta,ipa,ipb,7) = Fact * ( -xCzD ) - Final(iZeta,ipa,ipb,8) = Fact * ( -yCzD ) - Final(iZeta,ipa,ipb,9) = Fact * (xCxD+yCyD ) - 30 Continue -* - 21 Continue - 20 Continue -* - 11 Continue - 10 Continue -* - If (iPrint.ge.49) Then - Do 300 iComp = 1, 9 - Write (Label,'(A,I2,A)') ' Final (',iComp,') ' - Call RecPrt(Label,' ',Final(1,1,1,iComp),nZeta, - & nElem(la)*nELem(lb)) - 300 Continue - End If -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/util4.F90 openmolcas-22.10/src/oneint_util/util4.F90 --- openmolcas-22.02/src/oneint_util/util4.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/util4.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,108 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine Util4(nZeta,rFinal,la,lb,Elalbp,Elalb,Bcoor,Dcoor) +!*********************************************************************** +! * +! Object: to assemble the diamagnetic shielding integrals from * +! electric field integrals. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! February '91 * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: Half, c_in_au +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb +real(kind=wp), intent(out) :: rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),9) +real(kind=wp), intent(in) :: Elalbp(nZeta,nTri_Elem1(la),nTri_Elem1(lb+1),3), Elalb(nZeta,nTri_Elem1(la),nTri_Elem1(lb),3), & + Bcoor(3), Dcoor(3) +#include "print.fh" +integer(kind=iwp) :: ia, ib, iComp, ipa, ipb, iPrint, iRout, ixa, ixb, iya, iyb, iza, izb +real(kind=wp) :: BD(3), Fact +character(len=80) :: Label + +iRout = 231 +iPrint = nPrint(iRout) + +BD(1) = Bcoor(1)-Dcoor(1) +BD(2) = Bcoor(2)-Dcoor(2) +BD(3) = Bcoor(3)-Dcoor(3) +Fact = -1.0e-6_wp*Half/c_in_au**2 +if (iPrint >= 99) then + write(u6,*) ' In Util4 la,lb=',la,lb + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb+1) + write(Label,'(A,I2,A,I2,A)') ' Elalbp(',ia,',',ib,',x)' + call RecPrt(Label,' ',Elalbp(:,ia,ib,1),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Elalbp(',ia,',',ib,',y)' + call RecPrt(Label,' ',Elalbp(:,ia,ib,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Elalbp(',ia,',',ib,',z)' + call RecPrt(Label,' ',Elalbp(:,ia,ib,3),nZeta,1) + end do + end do + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb) + write(Label,'(A,I2,A,I2,A)') ' Elalb(',ia,',',ib,',x)' + call RecPrt(Label,' ',Elalb(:,ia,ib,1),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Elalb(',ia,',',ib,',y)' + call RecPrt(Label,' ',Elalb(:,ia,ib,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Elalb(',ia,',',ib,',z)' + call RecPrt(Label,' ',Elalb(:,ia,ib,3),nZeta,1) + end do + end do +end if + +do ixa=la,0,-1 + do iya=la-ixa,0,-1 + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + + do ixb=lb,0,-1 + do iyb=lb-ixb,0,-1 + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + + rFinal(:,ipa,ipb,1) = Fact*(Elalbp(:,ipa,C_Ind(lb+1,ixb,izb),2)+BD(2)*Elalb(:,ipa,ipb,2)+ & + Elalbp(:,ipa,C_Ind(lb+1,ixb,izb+1),3)+BD(3)*Elalb(:,ipa,ipb,3)) + rFinal(:,ipa,ipb,2) = -Fact*(Elalbp(:,ipa,C_Ind(lb+1,ixb+1,izb),2)+BD(1)*Elalb(:,ipa,ipb,2)) + rFinal(:,ipa,ipb,3) = -Fact*(Elalbp(:,ipa,C_Ind(lb+1,ixb+1,izb),3)+BD(1)*Elalb(:,ipa,ipb,3)) + rFinal(:,ipa,ipb,4) = -Fact*(Elalbp(:,ipa,C_Ind(lb+1,ixb,izb),1)+BD(2)*Elalb(:,ipa,ipb,1)) + rFinal(:,ipa,ipb,5) = Fact*(Elalbp(:,ipa,C_Ind(lb+1,ixb+1,izb),1)+BD(1)*Elalb(:,ipa,ipb,1)+ & + Elalbp(:,ipa,C_Ind(lb+1,ixb,izb+1),3)+BD(3)*Elalb(:,ipa,ipb,3)) + rFinal(:,ipa,ipb,6) = -Fact*(Elalbp(:,ipa,C_Ind(lb+1,ixb,izb),3)+BD(2)*Elalb(:,ipa,ipb,3)) + rFinal(:,ipa,ipb,7) = -Fact*(Elalbp(:,ipa,C_Ind(lb+1,ixb,izb+1),1)+BD(3)*Elalb(:,ipa,ipb,1)) + rFinal(:,ipa,ipb,8) = -Fact*(Elalbp(:,ipa,C_Ind(lb+1,ixb,izb+1),2)+BD(3)*Elalb(:,ipa,ipb,2)) + rFinal(:,ipa,ipb,9) = Fact*(Elalbp(:,ipa,C_Ind(lb+1,ixb+1,izb),1)+BD(1)*Elalb(:,ipa,ipb,1)+ & + Elalbp(:,ipa,C_Ind(lb+1,ixb,izb),2)+BD(2)*Elalb(:,ipa,ipb,2)) + + end do + end do + + end do +end do + +if (iPrint >= 49) then + do iComp=1,9 + write(Label,'(A,I2,A)') ' rFinal (',iComp,') ' + call RecPrt(Label,' ',rFinal(:,:,:,iComp),nZeta,nTri_Elem1(la)*nTri_Elem1(lb)) + end do +end if + +return + +end subroutine Util4 diff -Nru openmolcas-22.02/src/oneint_util/util5.f openmolcas-22.10/src/oneint_util/util5.f --- openmolcas-22.02/src/oneint_util/util5.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/util5.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,172 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -* 2019, Ignacio Fdez. Galvan * -************************************************************************ - SubRoutine Util5(Beta,nZeta,Final,la,lb,Slalbp,Slalbm) -************************************************************************ -* * -* Object: to assemble the velocity quadrupole integrals from the * -* derivative integrals and dipole integrals. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* February '91 * -* Adapted from util2: Ignacio Fdez. Galvan, July 2019 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Final (nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,6), - & Slalbp(nZeta,(la+1)*(la+2)/2,(lb+2)*(lb+3)/2,3), - & Slalbm(nZeta,(la+1)*(la+2)/2, lb *(lb+1)/2,3), - & Beta(nZeta) - Character*80 Label -* -* Statement function for cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 - nElem(ix) = (ix+1)*(ix+2)/2 -* - iRout = 211 - iPrint = nPrint(iRout) -* - If (iPrint.ge.99) Then - Write (6,*) ' In Util5 la,lb=',la,lb - Call RecPrt('Beta',' ',Beta,nZeta,1) - Do 100 ia = 1, nElem(la) - Do 200 ib = 1, nElem(lb+1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbp(',ia,',',ib,'x)' - Call RecPrt(Label,' ',Slalbp(1,ia,ib,1),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbp(',ia,',',ib,'y)' - Call RecPrt(Label,' ',Slalbp(1,ia,ib,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbp(',ia,',',ib,'z)' - Call RecPrt(Label,' ',Slalbp(1,ia,ib,3),nZeta,1) - 200 Continue - 100 Continue - If (lb.gt.0) Then - Do 101 ia = 1, nElem(la) - Do 201 ib = 1, nElem(lb-1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbm(',ia,',',ib,'x)' - Call RecPrt(Label,' ',Slalbm(1,ia,ib,1),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbm(',ia,',',ib,'y)' - Call RecPrt(Label,' ',Slalbm(1,ia,ib,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Slalbm(',ia,',',ib,'z)' - Call RecPrt(Label,' ',Slalbm(1,ia,ib,3),nZeta,1) - 201 Continue - 101 Continue - End If - End If -* - Do 10 ixa = la, 0, -1 - Do 11 iya = la-ixa, 0, -1 - iza = la-ixa-iya - ipa = Ind(la,ixa,iza) -* - Do 20 ixb = lb, 0, -1 - Do 21 iyb = lb-ixb, 0, -1 - izb = lb-ixb-iyb - ipb = Ind(lb,ixb,izb) -* - Do 30 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = Two*Beta(iZeta)* - & Two*Slalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb),1) - Final(iZeta,ipa,ipb,2) = Two*Beta(iZeta)* - & (Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb) ,1)+ - & Slalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb),2)) - Final(iZeta,ipa,ipb,3) = Two*Beta(iZeta)* - & (Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb+1),1)+ - & Slalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb),3)) - Final(iZeta,ipa,ipb,4) = Two*Beta(iZeta)* - & Two*Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb) ,2) - Final(iZeta,ipa,ipb,5) = Two*Beta(iZeta)* - & (Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb+1),2)+ - & Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb) ,3)) - Final(iZeta,ipa,ipb,6) = Two*Beta(iZeta)* - & Two*Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb+1),3) - 30 Continue -* - If (ixb.gt.0) Then - Do 31 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = Final(iZeta,ipa,ipb,1) - & -Dble(ixb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb-1,izb),1) - & *Two - Final(iZeta,ipa,ipb,2) = Final(iZeta,ipa,ipb,2) - & -Dble(ixb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb-1,izb),2) - Final(iZeta,ipa,ipb,3) = Final(iZeta,ipa,ipb,3) - & -Dble(ixb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb-1,izb),3) - 31 Continue - End If -* - If (iyb.gt.0) Then - Do 32 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,2) = Final(iZeta,ipa,ipb,2) - & -Dble(iyb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb) ,1) - Final(iZeta,ipa,ipb,4) = Final(iZeta,ipa,ipb,4) - & -Dble(iyb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb) ,2) - & *Two - Final(iZeta,ipa,ipb,5) = Final(iZeta,ipa,ipb,5) - & -Dble(iyb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb) ,3) - 32 Continue - End If -* - If (izb.gt.0) Then - Do 33 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,3) = Final(iZeta,ipa,ipb,3) - & -Dble(izb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb-1),1) - Final(iZeta,ipa,ipb,5) = Final(iZeta,ipa,ipb,5) - & -Dble(izb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb-1),2) - Final(iZeta,ipa,ipb,6) = Final(iZeta,ipa,ipb,6) - & -Dble(izb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb-1),3) - & *Two - 33 Continue - End If -* - 21 Continue - 20 Continue -* - 11 Continue - 10 Continue -* - If (iPrint.ge.49) Then - Write (6,*) ' In Util5 la,lb=',la,lb - Do 300 iElem = 1, nElem(la) - Do 310 jElem = 1, nElem(lb) - Write (Label,'(A,I2,A,I2,A)') - & ' Final (',iElem,',',jElem,',xx) ' - Call RecPrt(Label,' ',Final(1,iElem,jElem,1),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Final (',iElem,',',jElem,',xy) ' - Call RecPrt(Label,' ',Final(1,iElem,jElem,2),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Final (',iElem,',',jElem,',xz) ' - Call RecPrt(Label,' ',Final(1,iElem,jElem,3),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Final (',iElem,',',jElem,',yy) ' - Call RecPrt(Label,' ',Final(1,iElem,jElem,4),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Final (',iElem,',',jElem,',yz) ' - Call RecPrt(Label,' ',Final(1,iElem,jElem,5),nZeta,1) - Write (Label,'(A,I2,A,I2,A)') - & ' Final (',iElem,',',jElem,',zz) ' - Call RecPrt(Label,' ',Final(1,iElem,jElem,6),nZeta,1) - 310 Continue - 300 Continue - End If -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/util5.F90 openmolcas-22.10/src/oneint_util/util5.F90 --- openmolcas-22.02/src/oneint_util/util5.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/util5.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,133 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +! 2019, Ignacio Fdez. Galvan * +!*********************************************************************** + +subroutine Util5(Beta,nZeta,rFinal,la,lb,Slalbp,Slalbm) +!*********************************************************************** +! * +! Object: to assemble the velocity quadrupole integrals from the * +! derivative integrals and dipole integrals. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! February '91 * +! Adapted from util2: Ignacio Fdez. Galvan, July 2019 * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: Two +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb +real(kind=wp), intent(in) :: Beta(nZeta), Slalbp(nZeta,nTri_Elem1(la),nTri_Elem1(lb+1),3), & + Slalbm(nZeta,nTri_Elem1(la),nTri_Elem1(lb-1),3) +real(kind=wp), intent(out) :: rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),6) +#include "print.fh" +integer(kind=iwp) :: ia, ib, iElem, ipa, ipb, iPrint, iRout, ixa, ixb, iya, iyb, iza, izb, jElem +character(len=80) :: Label + +iRout = 211 +iPrint = nPrint(iRout) + +if (iPrint >= 99) then + write(u6,*) ' In Util5 la,lb=',la,lb + call RecPrt('Beta',' ',Beta,nZeta,1) + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb+1) + write(Label,'(A,I2,A,I2,A)') ' Slalbp(',ia,',',ib,'x)' + call RecPrt(Label,' ',Slalbp(:,ia,ib,1),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbp(',ia,',',ib,'y)' + call RecPrt(Label,' ',Slalbp(:,ia,ib,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbp(',ia,',',ib,'z)' + call RecPrt(Label,' ',Slalbp(:,ia,ib,3),nZeta,1) + end do + end do + if (lb > 0) then + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb-1) + write(Label,'(A,I2,A,I2,A)') ' Slalbm(',ia,',',ib,'x)' + call RecPrt(Label,' ',Slalbm(:,ia,ib,1),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbm(',ia,',',ib,'y)' + call RecPrt(Label,' ',Slalbm(:,ia,ib,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' Slalbm(',ia,',',ib,'z)' + call RecPrt(Label,' ',Slalbm(:,ia,ib,3),nZeta,1) + end do + end do + end if +end if + +do ixa=la,0,-1 + do iya=la-ixa,0,-1 + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + + do ixb=lb,0,-1 + do iyb=lb-ixb,0,-1 + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + + rFinal(:,ipa,ipb,1) = Two*Beta*Two*Slalbp(:,ipa,C_Ind(lb+1,ixb+1,izb),1) + rFinal(:,ipa,ipb,2) = Two*Beta*(Slalbp(:,ipa,C_Ind(lb+1,ixb,izb),1)+Slalbp(:,ipa,C_Ind(lb+1,ixb+1,izb),2)) + rFinal(:,ipa,ipb,3) = Two*Beta*(Slalbp(:,ipa,C_Ind(lb+1,ixb,izb+1),1)+Slalbp(:,ipa,C_Ind(lb+1,ixb+1,izb),3)) + rFinal(:,ipa,ipb,4) = Two*Beta*Two*Slalbp(:,ipa,C_Ind(lb+1,ixb,izb),2) + rFinal(:,ipa,ipb,5) = Two*Beta*(Slalbp(:,ipa,C_Ind(lb+1,ixb,izb+1),2)+Slalbp(:,ipa,C_Ind(lb+1,ixb,izb),3)) + rFinal(:,ipa,ipb,6) = Two*Beta*Two*Slalbp(:,ipa,C_Ind(lb+1,ixb,izb+1),3) + + if (ixb > 0) then + rFinal(:,ipa,ipb,1) = rFinal(:,ipa,ipb,1)-real(ixb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb-1,izb),1)*Two + rFinal(:,ipa,ipb,2) = rFinal(:,ipa,ipb,2)-real(ixb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb-1,izb),2) + rFinal(:,ipa,ipb,3) = rFinal(:,ipa,ipb,3)-real(ixb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb-1,izb),3) + end if + + if (iyb > 0) then + rFinal(:,ipa,ipb,2) = rFinal(:,ipa,ipb,2)-real(iyb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb),1) + rFinal(:,ipa,ipb,4) = rFinal(:,ipa,ipb,4)-real(iyb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb),2)*Two + rFinal(:,ipa,ipb,5) = rFinal(:,ipa,ipb,5)-real(iyb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb),3) + end if + + if (izb > 0) then + rFinal(:,ipa,ipb,3) = rFinal(:,ipa,ipb,3)-real(izb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb-1),1) + rFinal(:,ipa,ipb,5) = rFinal(:,ipa,ipb,5)-real(izb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb-1),2) + rFinal(:,ipa,ipb,6) = rFinal(:,ipa,ipb,6)-real(izb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb-1),3)*Two + end if + + end do + end do + + end do +end do + +if (iPrint >= 49) then + write(u6,*) ' In Util5 la,lb=',la,lb + do iElem=1,nTri_Elem1(la) + do jElem=1,nTri_Elem1(lb) + write(Label,'(A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,',xx) ' + call RecPrt(Label,' ',rFinal(:,iElem,jElem,1),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,',xy) ' + call RecPrt(Label,' ',rFinal(:,iElem,jElem,2),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,',xz) ' + call RecPrt(Label,' ',rFinal(:,iElem,jElem,3),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,',yy) ' + call RecPrt(Label,' ',rFinal(:,iElem,jElem,4),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,',yz) ' + call RecPrt(Label,' ',rFinal(:,iElem,jElem,5),nZeta,1) + write(Label,'(A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,',zz) ' + call RecPrt(Label,' ',rFinal(:,iElem,jElem,6),nZeta,1) + end do + end do +end if + +return + +end subroutine Util5 diff -Nru openmolcas-22.02/src/oneint_util/util8.f openmolcas-22.10/src/oneint_util/util8.f --- openmolcas-22.02/src/oneint_util/util8.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/util8.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,130 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1994, Bernd Artur Hess * -************************************************************************ - SubRoutine util8(Beta,nZeta,Final,la,lb,Slalbp,Slalbm) -************************************************************************ -* * -* Object: to assemble the Vp integrals from * -* derivative integrals of the electric potential. * -* * -* Author: Bernd Hess, Institut fuer Physikalische und Theoretische * -* Chemie, University of Bonn, Germany, August 1994 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Final (nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,3), - * Slalbp(nZeta,(la+1)*(la+2)/2,(lb+2)*(lb+3)/2), - * Slalbm(nZeta,(la+1)*(la+2)/2, lb *(lb+1)/2), - * Beta(nZeta) - Character*80 Label -* -* Statement function for cartesian index -* - Ind(ixyz,ix,iz) = (ixyz-ix)*(ixyz-ix+1)/2 + iz + 1 - nElem(ix) = (ix+1)*(ix+2)/2 -* - iRout = 203 - iPrint = nPrint(iRout) -* -* - If (iPrint.ge.99) Then - Write (6,*) ' In util8 la,lb=',la,lb - Call RecPrt('Beta','(5f15.8)',Beta,nZeta,1) - Do 200 ib = 1, nElem(lb) - Write (Label,'(A,I2,A)') ' Slalbp(',la,ib,')' - Call RecPrt(Label,'(5f15.8)',Slalbp(1,1,ib),nZeta,nElem(la+1)) -200 Continue - If (lb.gt.0) Then - Do 201 ia = 1, nElem(la) - Write (Label,'(A,I2,A)') ' Slalbm(',la,ib,')' - Call RecPrt(Label,'(5f15.8)',Slalbm(1,1,ib),nZeta,nElem(lb-1)) -201 Continue - End If - End If -* - Do 10 ixa = la, 0, -1 - Do 11 iya = la-ixa, 0, -1 - iza = la-ixa-iya - ipa = Ind(la,ixa,iza) -* - Do 20 ixb = lb, 0, -1 - Do 21 iyb = lb-ixb, 0, -1 - izb = lb-ixb-iyb - ipb = Ind(lb,ixb,izb) -* - IF (ixb.EQ.0) THEN - Do 33 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = - * Two*Beta(iZeta)*Slalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb)) -33 Continue - ELSE - Do 31 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,1) = - * Two*Beta(iZeta)*Slalbp(iZeta,ipa,Ind(lb+1,ixb+1,izb)) - * -Dble(ixb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb-1,izb)) -31 Continue - ENDIF -* - IF (iyb.EQ.0) THEN -* - Do 63 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,2) = - * Two*Beta(iZeta)*Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb)) -63 Continue - ELSE - Do 62 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,2) = - * Two*Beta(iZeta)*Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb)) - * -Dble(iyb)*Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb)) -62 Continue - ENDIF -* - IF (izb.EQ.0) THEN -* - Do 93 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,3) = - * Two*Beta(iZeta)*Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb+1)) -93 Continue - ELSE - Do 91 iZeta = 1, nZeta - Final(iZeta,ipa,ipb,3) = - * Two*Beta(iZeta)*Slalbp(iZeta,ipa,Ind(lb+1,ixb,izb+1)) - * -Dble(iza)*Slalbm(iZeta,ipa,Ind(lb-1,ixb,izb-1)) -91 Continue - ENDIF -* -21 Continue -20 Continue -* -11 Continue -10 Continue -* - If (iPrint.ge.49) Then - Write (6,*) ' In UTIL8 la,lb=',la,lb - Do 380 iiComp=1,3 - Do 410 jElem = 1, nElem(lb) - Do 400 iElem = 1, nElem(la) - Do 390 iiZeta=1,nZeta - Write (Label,'(A,I2,A,I2,A)') - * ' Final (',iElem,',',jElem,') ' -* Call RecPrt(Label,'(5f15.8)', - write(6,*) iiZeta,iElem,jElem,iiComp, - * Final(iiZeta,iElem,jElem,iiComp) -390 Continue -400 Continue -410 Continue -380 Continue - End If -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/util8.F90 openmolcas-22.10/src/oneint_util/util8.F90 --- openmolcas-22.02/src/oneint_util/util8.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/util8.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,106 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1994, Bernd Artur Hess * +!*********************************************************************** + +subroutine Util8(Beta,nZeta,rFinal,la,lb,Slalbp,Slalbm) +!*********************************************************************** +! * +! Object: to assemble the Vp integrals from * +! derivative integrals of the electric potential. * +! * +! Author: Bernd Hess, Institut fuer Physikalische und Theoretische * +! Chemie, University of Bonn, Germany, August 1994 * +!*********************************************************************** + +use Index_Functions, only: C_Ind, nTri_Elem1 +use Constants, only: Two +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nZeta, la, lb +real(kind=wp), intent(in) :: Beta(nZeta), Slalbp(nZeta,nTri_Elem1(la),nTri_Elem1(lb+1)), & + Slalbm(nZeta,nTri_Elem1(la),nTri_Elem1(lb-1)) +real(kind=wp), intent(out) :: rFinal(nZeta,nTri_Elem1(la),nTri_Elem1(lb),3) +#include "print.fh" +integer(kind=iwp) :: ia, ib, iElem, iiComp, iiZeta, ipa, ipb, iPrint, iRout, ixa, ixb, iya, iyb, iza, izb, jElem +character(len=80) :: Label + +iRout = 203 +iPrint = nPrint(iRout) + +if (iPrint >= 99) then + write(u6,*) ' In util8 la,lb=',la,lb + call RecPrt('Beta','(5f15.8)',Beta,nZeta,1) + do ib=1,nTri_Elem1(lb) + write(Label,'(A,I2,A)') ' Slalbp(',la,ib,')' + call RecPrt(Label,'(5f15.8)',Slalbp(:,:,ib),nZeta,nTri_Elem1(la+1)) + end do + if (lb > 0) then + do ia=1,nTri_Elem1(la) + write(Label,'(A,I2,A)') ' Slalbm(',la,ib,')' + call RecPrt(Label,'(5f15.8)',Slalbm(:,:,ib),nZeta,nTri_Elem1(lb-1)) + end do + end if +end if + +do ixa=la,0,-1 + do iya=la-ixa,0,-1 + iza = la-ixa-iya + ipa = C_Ind(la,ixa,iza) + + do ixb=lb,0,-1 + do iyb=lb-ixb,0,-1 + izb = lb-ixb-iyb + ipb = C_Ind(lb,ixb,izb) + + if (ixb == 0) then + rFinal(:,ipa,ipb,1) = Two*Beta*Slalbp(:,ipa,C_Ind(lb+1,ixb+1,izb)) + else + rFinal(:,ipa,ipb,1) = Two*Beta*Slalbp(:,ipa,C_Ind(lb+1,ixb+1,izb))-real(ixb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb-1,izb)) + end if + + if (iyb == 0) then + rFinal(:,ipa,ipb,2) = Two*Beta*Slalbp(:,ipa,C_Ind(lb+1,ixb,izb)) + else + rFinal(:,ipa,ipb,2) = Two*Beta*Slalbp(:,ipa,C_Ind(lb+1,ixb,izb))-real(iyb,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb)) + end if + + if (izb == 0) then + rFinal(:,ipa,ipb,3) = Two*Beta*Slalbp(:,ipa,C_Ind(lb+1,ixb,izb+1)) + else + rFinal(:,ipa,ipb,3) = Two*Beta*Slalbp(:,ipa,C_Ind(lb+1,ixb,izb+1))-real(iza,kind=wp)*Slalbm(:,ipa,C_Ind(lb-1,ixb,izb-1)) + end if + + end do + end do + + end do +end do + +if (iPrint >= 49) then + write(u6,*) ' In UTIL8 la,lb=',la,lb + do iiComp=1,3 + do jElem=1,nTri_Elem1(lb) + do iElem=1,nTri_Elem1(la) + do iiZeta=1,nZeta + write(Label,'(A,I2,A,I2,A)') ' rFinal (',iElem,',',jElem,') ' + !call RecPrt(Label,'(5f15.8)', + write(u6,*) iiZeta,iElem,jElem,iiComp,rFinal(iiZeta,iElem,jElem,iiComp) + end do + end do + end do + end do +end if + +return + +end subroutine Util8 diff -Nru openmolcas-22.02/src/oneint_util/veint.f openmolcas-22.10/src/oneint_util/veint.f --- openmolcas-22.02/src/oneint_util/veint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/veint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,148 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine VeInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: to compute the velocity integrals with the Gauss-Hermite * -* quadrature. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, Sweden, January '91 * -************************************************************************ - use Her_RW - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - -#include "int_interface.fh" - -* Local variables. - Logical ABeq(3) - Integer iStabO(0:7), iDCRT(0:7) -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - iRout = 195 - iPrint = nPrint(iRout) - ABeq(1) = A(1).eq.RB(1) - ABeq(2) = A(2).eq.RB(2) - ABeq(3) = A(3).eq.RB(3) -* - nip = 1 - ipAxyz = nip - nip = nip + nZeta*3*nHer*(la+1) - ipBxyz = nip - nip = nip + nZeta*3*nHer*(lb+2) - ipRxyz = nip - nip = nip + nZeta*3*nHer - ipQxyz = nip - nip = nip + nZeta*3*(la+1)*(lb+2) - ipVxyz = nip - nip = nip + nZeta*3*(la+1)*(lb+1) - ipB = nip - nip = nip + nZeta - ipRes = nip - nip = nip + nZeta*nElem(la)*nElem(lb)*nComp - If (nip-1.gt.nArr*nZeta) Then - Call WarningMessage(2,'VeInt: nip-1.gt.nArr*nZeta') - Write (6,*) ' nArr is Wrong! ', nip-1,' > ',nArr*nZeta - Write (6,*) ' Abend in VeInt' - Call Abend() - End If -* - If (iPrint.ge.49) Then - Call RecPrt(' In VeInt: A',' ',A,1,3) - Call RecPrt(' In VeInt: RB',' ',RB,1,3) - Call RecPrt(' In VeInt: Ccoor',' ',Ccoor,1,3) - Call RecPrt(' In VeInt: P',' ',P,nZeta,3) - Write (6,*) ' In VeInt: la,lb=',la,lb - End If -* - call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) -* -* Compute the cartesian values of the basis functions angular part -* - Call CrtCmp(Zeta,P,nZeta,A,Array(ipAxyz), - & la,HerR(iHerR(nHer)),nHer,ABeq) - Call CrtCmp(Zeta,P,nZeta,RB,Array(ipBxyz), - & lb+1,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the contribution from the multipole moment operator -* - ABeq(1) = .False. - ABeq(2) = .False. - ABeq(3) = .False. - Call CrtCmp(Zeta,P,nZeta,Ccoor,Array(ipRxyz), - & 0,HerR(iHerR(nHer)),nHer,ABeq) -* -* Compute the cartesian components for the multipole moment -* integrals. The integrals are factorized into components. -* - Call Assmbl(Array(ipQxyz), - & Array(ipAxyz),la, - & Array(ipRxyz),0, - & Array(ipBxyz),lb+1, - & nZeta,HerW(iHerW(nHer)),nHer) -* -* Compute the cartesian components for the velocity integrals. -* The velocity components are linear combinations of overlap -* components. -* - ipBOff = ipB - Do 210 iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ipBOff),nAlpha) - ipBOff = ipBOff + 1 - 210 Continue -* - Call VelInt(Array(ipVxyz),Array(ipQxyz),la,lb, - & Array(ipB),nZeta) -* -* Combine the cartesian components to the full one electron -* integral. -* - Call CmbnVe(Array(ipQxyz),nZeta,la,lb,0,Zeta,rKappa,Array(ipRes), - & nComp,Array(ipVxyz)) -* - llOper=lOper(1) - Do 90 iComp = 2, nComp - llOper = iOr(llOper,lOper(iComp)) - 90 Continue - Call SOS(iStabO,nStabO,llOper) - Call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) -* - Do 102 lDCRT = 0, nDCRT-1 -* -*--------Accumulate contributions -* - nOp = NrOpr(iDCRT(lDCRT)) - Call SymAdO(Array(ipRes),nZeta,la,lb,nComp,Final,nIC, - & nOp ,lOper,iChO,One) -* - 102 Continue -* -* Call GetMem(' Exit VeInt','LIST','REAL',iDum,iDum) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Alpha) - Call Unused_real_array(ZInv) - Call Unused_integer(nOrdOp) - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/veint.F90 openmolcas-22.10/src/oneint_util/veint.F90 --- openmolcas-22.02/src/oneint_util/veint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/veint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,131 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine VeInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the velocity integrals with the Gauss-Hermite * +! quadrature. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, Sweden, January '91 * +!*********************************************************************** + +use Her_RW, only: HerR, HerW, iHerR, iHerW +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "print.fh" +integer(kind=iwp) :: iBeta, iComp, iDCRT(0:7), ipAxyz, ipB, ipBOff, ipBxyz, ipQxyz, ipRes, iPrint, ipRxyz, ipVxyz, iRout, & + iStabO(0:7), lDCRT, llOper, LmbdT, nDCRT, nip, nOp, nStabO +logical(kind=iwp) :: ABeq(3) +integer(kind=iwp), external :: NrOpr + +#include "macros.fh" +unused_var(Alpha) +unused_var(ZInv) +unused_var(nOrdOp) +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 195 +iPrint = nPrint(iRout) +ABeq(:) = A == RB + +nip = 1 +ipAxyz = nip +nip = nip+nZeta*3*nHer*(la+1) +ipBxyz = nip +nip = nip+nZeta*3*nHer*(lb+2) +ipRxyz = nip +nip = nip+nZeta*3*nHer +ipQxyz = nip +nip = nip+nZeta*3*(la+1)*(lb+2) +ipVxyz = nip +nip = nip+nZeta*3*(la+1)*(lb+1) +ipB = nip +nip = nip+nZeta +ipRes = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb)*nComp +if (nip-1 > nArr*nZeta) then + call WarningMessage(2,'VeInt: nip-1 > nArr*nZeta') + write(u6,*) ' nArr is Wrong! ',nip-1,' > ',nArr*nZeta + write(u6,*) ' Abend in VeInt' + call Abend() +end if + +if (iPrint >= 49) then + call RecPrt(' In VeInt: A',' ',A,1,3) + call RecPrt(' In VeInt: RB',' ',RB,1,3) + call RecPrt(' In VeInt: Ccoor',' ',Ccoor,1,3) + call RecPrt(' In VeInt: P',' ',P,nZeta,3) + write(u6,*) ' In VeInt: la,lb=',la,lb +end if + +rFinal(:,:,:,:) = Zero + +! Compute the cartesian values of the basis functions angular part + +call CrtCmp(Zeta,P,nZeta,A,Array(ipAxyz),la,HerR(iHerR(nHer)),nHer,ABeq) +call CrtCmp(Zeta,P,nZeta,RB,Array(ipBxyz),lb+1,HerR(iHerR(nHer)),nHer,ABeq) + +! Compute the contribution from the multipole moment operator + +ABeq(:) = .false. +call CrtCmp(Zeta,P,nZeta,Ccoor,Array(ipRxyz),0,HerR(iHerR(nHer)),nHer,ABeq) + +! Compute the cartesian components for the multipole moment +! integrals. The integrals are factorized into components. + +call Assmbl(Array(ipQxyz),Array(ipAxyz),la,Array(ipRxyz),0,Array(ipBxyz),lb+1,nZeta,HerW(iHerW(nHer)),nHer) + +! Compute the cartesian components for the velocity integrals. +! The velocity components are linear combinations of overlap components. + +ipBOff = ipB-1 +do iBeta=1,nBeta + Array(ipBOff+1:ipBOff+nAlpha) = Beta(iBeta) + ipBOff = ipBOff+nAlpha +end do + +call VelInt(Array(ipVxyz),Array(ipQxyz),la,lb,Array(ipB),nZeta) + +! Combine the cartesian components to the full one electron integral. + +call CmbnVe(Array(ipQxyz),nZeta,la,lb,0,Zeta,rKappa,Array(ipRes),nComp,Array(ipVxyz)) + +llOper = lOper(1) +do iComp=2,nComp + llOper = ior(llOper,lOper(iComp)) +end do +call SOS(iStabO,nStabO,llOper) +call DCR(LmbdT,iStabM,nStabM,iStabO,nStabO,iDCRT,nDCRT) + +do lDCRT=0,nDCRT-1 + + ! Accumulate contributions + + nOp = NrOpr(iDCRT(lDCRT)) + call SymAdO(Array(ipRes),nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,One) + +end do + +return + +end subroutine VeInt diff -Nru openmolcas-22.02/src/oneint_util/velint.f openmolcas-22.10/src/oneint_util/velint.f --- openmolcas-22.02/src/oneint_util/velint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/velint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,64 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine VelInt(Vxyz,Sxyz,na,nb,Beta,nZeta) -************************************************************************ -* * -* Object: to assemble the cartesian components of the velocity inte- * -* grals from the cartesian components of the overlap integals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* November '90 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - Real*8 Vxyz(nZeta,3,0:na,0:nb), Sxyz(nZeta,3,0:na,0:nb+1), - & Beta(nZeta) - Character*80 Label - iRout=160 - iPrint = nPrint(iRout) - - If (iPrint.ge.99) Then - Call RecPrt(' In VelInt: Beta ',' ',Beta ,nZeta,1) - End If - Do 10 ia = 0, na - Do 20 ib = 0, nb - If (ib.eq.0) Then - Do 33 iCar = 1, 3 - Do 43 iZeta = 1, nZeta - Vxyz(iZeta,iCar,ia,ib) = - & - Beta(iZeta) * Two * Sxyz(iZeta,iCar,ia,ib+1) - 43 Continue - 33 Continue - Else - Do 30 iCar = 1, 3 - Do 40 iZeta = 1, nZeta - Vxyz(iZeta,iCar,ia,ib) = - & Dble(ib) * Sxyz(iZeta,iCar,ia,ib-1) - & - Beta(iZeta) * Two * Sxyz(iZeta,iCar,ia,ib+1) - 40 Continue - 30 Continue - End If -* - If (iPrint.ge.99) Then - Write (Label,'(A,I2,A,I2,A)') ' In VelInt: Vxyz(',ia,',', - & ib,')' - Call RecPrt(Label,' ',Vxyz(1,1,ia,ib),nZeta,3) - End If - 20 Continue - 10 Continue - -* Call GetMem(' Exit VelInt ','CHECK','REAL',iDum,iDum) - Return - End diff -Nru openmolcas-22.02/src/oneint_util/velint.F90 openmolcas-22.10/src/oneint_util/velint.F90 --- openmolcas-22.02/src/oneint_util/velint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/velint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,63 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine VelInt(Vxyz,Sxyz,na,nb,Beta,nZeta) +!*********************************************************************** +! * +! Object: to assemble the cartesian components of the velocity inte- * +! grals from the cartesian components of the overlap integals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! November '90 * +!*********************************************************************** + +use Constants, only: Two +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: na, nb, nZeta +real(kind=wp), intent(out) :: Vxyz(nZeta,3,0:na,0:nb) +real(kind=wp), intent(in) :: Sxyz(nZeta,3,0:na,0:nb+1), Beta(nZeta) +#include "print.fh" +integer(kind=iwp) :: ia, ib, iCar, iPrint, iRout +character(len=80) :: Label + +iRout = 160 +iPrint = nPrint(iRout) + +if (iPrint >= 99) then + call RecPrt(' In VelInt: Beta ',' ',Beta,nZeta,1) +end if +do ia=0,na + do ib=0,nb + if (ib == 0) then + do iCar=1,3 + Vxyz(:,iCar,ia,ib) = -Beta*Two*Sxyz(:,iCar,ia,ib+1) + end do + else + do iCar=1,3 + Vxyz(:,iCar,ia,ib) = real(ib,kind=wp)*Sxyz(:,iCar,ia,ib-1)-Beta*Two*Sxyz(:,iCar,ia,ib+1) + end do + end if + + if (iPrint >= 99) then + write(Label,'(A,I2,A,I2,A)') ' In VelInt: Vxyz(',ia,',',ib,')' + call RecPrt(Label,' ',Vxyz(:,:,ia,ib),nZeta,3) + end if + end do +end do + +return + +end subroutine VelInt diff -Nru openmolcas-22.02/src/oneint_util/vemem.f openmolcas-22.10/src/oneint_util/vemem.f --- openmolcas-22.02/src/oneint_util/vemem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/vemem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,28 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine VeMem( -#define _CALLING_ -#include "mem_interface.fh" - &) -#include "mem_interface.fh" -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -* - nHer=(la+(lb+1)+2)/2 - Mem = 3*nHer*(la+1) - & + 3*nHer*(lb+2) - & + 3*nHer - & + 3*(la+1)*(lb+2) - & + 3*(la+1)*(lb+1) + 1 - & + 3*nElem(la)*nElem(lb)*nELem(lr) -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/vemem.F90 openmolcas-22.10/src/oneint_util/vemem.F90 --- openmolcas-22.02/src/oneint_util/vemem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/vemem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,28 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine VeMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" + +nHer = (la+(lb+1)+2)/2 +Mem = 3*nHer*(la+1)+3*nHer*(lb+2)+3*nHer+3*(la+1)*(lb+2)+3*(la+1)*(lb+1)+1+3*nTri_Elem1(la)*nTri_Elem1(lb)*nTri_Elem1(lr) + +return + +end subroutine VeMem diff -Nru openmolcas-22.02/src/oneint_util/vpint.f openmolcas-22.10/src/oneint_util/vpint.f --- openmolcas-22.02/src/oneint_util/vpint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/vpint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,110 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1993, Bernd Artur Hess * -************************************************************************ - SubRoutine VPInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of pV integrals * -* * -* Author: Bernd Hess, Institut fuer Physikalische und Theoretische * -* Chemie, University of Bonn, Germany, April 1993 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) - External TNAI, Fake, XCff2D, XRys2D -#include "real.fh" -#include "print.fh" - -#include "int_interface.fh" -* -* Statement function for Cartesian index -* - nElem(ixyz) = ((ixyz+1)*(ixyz+2))/2 -* - iRout = 221 - iPrint = nPrint(iRout) -* -* - If (iPrint.ge.99) Then - Call RecPrt(' In vpint: Alpha','(5D20.13)',Alpha,nAlpha,1) - Call RecPrt(' In vpint: Beta','(5D20.13)',Beta,nBeta,1) - End If -* - nRys=nHer -* - nip = 1 - ipB = nip - nip = nip + nZeta - ipS1 = nip - nip = nip + nZeta*nElem(la)*nElem(lb+1) - If (lb.gt.0) Then - ipS2 = nip - nip = nip + nZeta*nElem(la)*nElem(lb-1) - Else - ipS2=ipS1 - End If - ipArr = nip - mArr = nArr - (nip-1)/nZeta - If (mArr.lt.0) Then - Call WarningMessage(2,'VpInt: mArr<0!') - Call Abend() - End If -* - call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) - call dcopy_(nZeta*nArr,[Zero],0,Array,1) -* Compute contribution from a,b+1 -* - kRys = ((la+1)+lb+2)/2 -* - kIC=1 - kComp=1 - Call NAInt(Alpha,nAlpha,Beta, nBeta,Zeta,ZInv,rKappa,P, - & Array(ipS1),nZeta,nIC,nComp,la,lb+1,A,RB,kRys, - & Array(ipArr),mArr,CCoor,nOrdOp,lOper,iChO, - & iStabM,nStabM, - & PtChrg,nGrid,iAddPot) - - ipOff = ipB - Do 100 iAlpha = 1, nAlpha - call dcopy_(nBeta,Beta,1,Array(ipOff),nAlpha) - ipOff = ipOff + 1 -100 Continue -* -* Compute contribution from a,b-1 -* - If (lb.gt.0) Then - kRys = ((la-1)+lb+2)/2 -* - Call NAInt(Alpha,nAlpha,Beta, nBeta,Zeta,ZInv,rKappa,P, - & Array(ipS2),nZeta,kIC,kComp,la,lb-1,A,RB,nRys, - & Array(ipArr),mArr,CCoor,nOrdOp,lOper,iChO, - & iStabM,nStabM, - & PtChrg,nGrid,iAddPot) - End If -* -* Assemble final integral from the derivative integrals -* - If (iPrint.ge.99) Call RecPrt(' In vpint: Beta (expanded)', - & '(5D20.13)',Array(ipB),nZeta,1) -* - Call Util8(Array(ipB),nZeta,Final,la,lb,Array(ipS1),Array(ipS2)) -* - If (iPrint.ge.49) Then - Do i=1,3 - Call RecPrt('VpInt: Final',' ',Final(1,1,1,i),nZeta, - & nElem(la)*nElem(lb)) - End Do - End If - Return - End diff -Nru openmolcas-22.02/src/oneint_util/vpint.F90 openmolcas-22.10/src/oneint_util/vpint.F90 --- openmolcas-22.02/src/oneint_util/vpint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/vpint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,104 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1993, Bernd Artur Hess * +!*********************************************************************** + +subroutine VPInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of pV integrals * +! * +! Author: Bernd Hess, Institut fuer Physikalische und Theoretische * +! Chemie, University of Bonn, Germany, April 1993 * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +#include "int_interface.fh" +#include "print.fh" +integer(kind=iwp) :: i, iBeta, ipArr, ipB, ipOff, iPrint, ipS1, ipS2, iRout, kComp, kIC, kRys, mArr, nip, nRys +external :: Fake, TNAI, XCff2D, XRys2D + +iRout = 221 +iPrint = nPrint(iRout) + +if (iPrint >= 99) then + call RecPrt(' In vpint: Alpha','(5D20.13)',Alpha,nAlpha,1) + call RecPrt(' In vpint: Beta','(5D20.13)',Beta,nBeta,1) +end if + +nRys = nHer + +nip = 1 +ipB = nip +nip = nip+nZeta +ipS1 = nip +nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb+1) +if (lb > 0) then + ipS2 = nip + nip = nip+nZeta*nTri_Elem1(la)*nTri_Elem1(lb-1) +else + ipS2 = ipS1 +end if +ipArr = nip +mArr = nArr-(nip-1)/nZeta +if (mArr < 0) then + call WarningMessage(2,'VpInt: mArr<0!') + call Abend() +end if + +rFinal(:,:,:,:) = Zero +Array(:) = Zero +! Compute contribution from a,b+1 + +kRys = ((la+1)+lb+2)/2 + +kIC = 1 +kComp = 1 +call NAInt(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipS1),nZeta,nIC,nComp,la,lb+1,A,RB,kRys,Array(ipArr),mArr,CCoor, & + nOrdOp,lOper,iChO,iStabM,nStabM,PtChrg,nGrid,iAddPot) + +ipOff = ipB-1 +do iBeta=1,nBeta + Array(ipOff+1:ipOff+nAlpha) = Beta(iBeta) + ipOff = ipOff+nAlpha +end do + +! Compute contribution from a,b-1 + +if (lb > 0) then + kRys = ((la-1)+lb+2)/2 + + call NAInt(Alpha,nAlpha,Beta,nBeta,Zeta,ZInv,rKappa,P,Array(ipS2),nZeta,kIC,kComp,la,lb-1,A,RB,nRys,Array(ipArr),mArr,CCoor, & + nOrdOp,lOper,iChO,iStabM,nStabM,PtChrg,nGrid,iAddPot) +end if + +! Assemble final integral from the derivative integrals + +if (iPrint >= 99) call RecPrt(' In vpint: Beta (expanded)','(5D20.13)',Array(ipB),nZeta,1) + +call Util8(Array(ipB),nZeta,rFinal,la,lb,Array(ipS1),Array(ipS2)) + +if (iPrint >= 49) then + do i=1,3 + call RecPrt('VpInt: rFinal',' ',rFinal(:,:,:,i),nZeta,nTri_Elem1(la)*nTri_Elem1(lb)) + end do +end if + +return + +end subroutine VPInt diff -Nru openmolcas-22.02/src/oneint_util/vpmem.f openmolcas-22.10/src/oneint_util/vpmem.f --- openmolcas-22.02/src/oneint_util/vpmem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/vpmem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine VpMem( -#define _CALLING_ -#include "mem_interface.fh" - &) -#include "mem_interface.fh" - Integer iAngV(4) -* - nElem(i)=(i+1)*(i+2)/2 -* - Call mHrr(la,lb+1,nFlop,nMem) -* - nHer=(la+lb+1+lr+2)/2 - iAngV(1) = la - iAngV(2) = lb+1 - iAngV(3) = 0 - iAngV(4) = 0 - Call MemRys(iAngV,MemNA1) -* - MemNA1 = Max(nMem,MemNA1) -* - If (lb.ne.0) Then - Call mHrr(la,lb-1,nFlop,nMem) -* - nHer=(la+lb-1+lr+2)/2 - iAngV(1) = la - iAngV(2) = lb-1 - iAngV(3) = 0 - iAngV(4) = 0 - Call MemRys(iAngV,MemNA2) -* - MemNA2 = Max(nMem,MemNA2) - Else - MemNA2=0 - End If -* - Mem=Max(MemNA1,MemNA2) -* - Mem=Mem+1 -* - Mem = Mem+nElem(la)*nElem(lb+1) - If (lb.ne.0) Mem=Mem+nElem(la)*nElem(lb-1) -* - Return - End diff -Nru openmolcas-22.02/src/oneint_util/vpmem.F90 openmolcas-22.10/src/oneint_util/vpmem.F90 --- openmolcas-22.02/src/oneint_util/vpmem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/vpmem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,61 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine VPMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: iAngV(4), MemNA1, MemNA2, nFlop, nMem + +call mHrr(la,lb+1,nFlop,nMem) + +nHer = (la+lb+1+lr+2)/2 +iAngV(1) = la +iAngV(2) = lb+1 +iAngV(3) = 0 +iAngV(4) = 0 +call MemRys(iAngV,MemNA1) + +MemNA1 = max(nMem,MemNA1) + +if (lb /= 0) then + call mHrr(la,lb-1,nFlop,nMem) + + nHer = (la+lb-1+lr+2)/2 + iAngV(1) = la + iAngV(2) = lb-1 + iAngV(3) = 0 + iAngV(4) = 0 + call MemRys(iAngV,MemNA2) + + MemNA2 = max(nMem,MemNA2) +else + MemNA2 = 0 +end if + +Mem = max(MemNA1,MemNA2) + +Mem = Mem+1 + +Mem = Mem+nTri_Elem1(la)*nTri_Elem1(lb+1) +if (lb /= 0) Mem = Mem+nTri_Elem1(la)*nTri_Elem1(lb-1) + +return + +end subroutine VPMem diff -Nru openmolcas-22.02/src/oneint_util/welint.f openmolcas-22.10/src/oneint_util/welint.f --- openmolcas-22.02/src/oneint_util/welint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/welint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,123 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1992, Roland Lindh * -************************************************************************ - SubRoutine WelInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: to compute the Pauli repulsion integrals with the * -* Gauss-Hermite quadrature. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, Sweden. October '92. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "wldata.fh" -#include "print.fh" - -#include "int_interface.fh" -* - iRout = 122 - iPrint = nPrint(iRout) -* iQ = 1 - If (iPrint.ge.59) Then - Write (6,*) ' In WelInt' - Write (6,*) ' r0, ExpB=',r0,ExpB - Write (6,*) ' la,lb=',la,lb - End If -* - k = la + lb - jsum = 1 - Do 10 i = 1, k - jsum = jsum + 3**i - 10 Continue -* - ip = 1 - ipGri = ip - ip = ip + nZeta*jsum - ipGrin= ip - ip = ip + nZeta*(k+1)*(k/2+1)*(k/4+1) - iPxyz = ip - ip = ip + nZeta - If (ip-1.gt.nZeta*nArr) Then - Call WarningMessage(2, 'WelInt: ip-1.gt.nZeta*nArr(pos.1)') - Write (6,*) ip-1,'>',nZeta*nArr - Call Abend() - End If -* - Call Rowel(nZeta,r0,expB,k,Zeta,P,Array(iPxyz),Array(ipGri), - & Array(ipGrin),jsum) - ip = ip - nZeta - ip = ip - nZeta*(k+1)*(k/2+1)*(k/4+1) -* - ipA = ip - ip = ip + nZeta*9 - ipScr = ip - ip = ip + nZeta*3**k - If (ip-1.gt.nZeta*nArr) Then - Call WarningMessage(2, 'WelInt: ip-1.gt.nZeta*nArr(pos.2)') - Write (6,*) ip-1,'>',nZeta*nArr - Call Abend() - End If -* -*-----Transform each block to the global coordinate system -* - iOff = ipgri + nZeta - Do 100 ik = 1, k - If (ik.eq.1) Call SetUpA(nZeta,Array(ipA),P) - Call Traxyz(nZeta,ik,Array(iOff),Array(ipScr),Array(ipA)) - iOff = iOff + nZeta*3**ik - 100 Continue - If (iPrint.ge.99) Call RecPrt(' In WelInt: Array(ipGri)',' ', - & Array(ipGri),nZeta,jSum) - ip = ip - nZeta*3**k - ip = ip - nZeta*9 -* - ip1 = ip - ip = ip + nZeta - ip2 = ip - ip = ip + nZeta - ip3 = ip - ip = ip + nZeta - ip4 = ip - ip = ip + nZeta - ip5 = ip - ip = ip + nZeta - If (ip-1.gt.nZeta*nArr) Then - Call WarningMessage(2, 'WelInt: ip-1.gt.nZeta*nArr(pos.3)') - Write (6,*) ip-1,'>',nZeta*nArr - Call Abend() - End If - Call TraPAB(nZeta,la,lb,Final,Array(ipgri),jSum,rKappa,Array(ip1), - & Array(ip2),Array(ip3),Array(ip4),Array(ip5),A,RB,P) - ip = ip - nZeta*5 - ip = ip - nZeta*jsum -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Alpha) - Call Unused_real_array(Beta) - Call Unused_real_array(ZInv) - Call Unused_integer(nHer) - Call Unused_real_array(Ccoor) - Call Unused_integer(nOrdOp) - Call Unused_integer_array(lOper) - Call Unused_integer_array(iChO) - Call Unused_integer_array(iStabM) - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/welint.F90 openmolcas-22.10/src/oneint_util/welint.F90 --- openmolcas-22.02/src/oneint_util/welint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/welint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,124 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1992, Roland Lindh * +!*********************************************************************** + +subroutine WelInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: to compute the Pauli repulsion integrals with the * +! Gauss-Hermite quadrature. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, Sweden. October '92. * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "wldata.fh" +#include "print.fh" +integer(kind=iwp) :: i, ik, iOff, ip, ip1, ip2, ip3, ip4, ip5, ipA, ipGri, ipGrin, iPrint, ipScr, iPxyz, iRout, jsum, k + +#include "macros.fh" +unused_var(Alpha) +unused_var(Beta) +unused_var(ZInv) +unused_var(nHer) +unused_var(Ccoor) +unused_var(nOrdOp) +unused_var(lOper) +unused_var(iChO) +unused_var(iStabM) +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 122 +iPrint = nPrint(iRout) +!iQ = 1 +if (iPrint >= 59) then + write(u6,*) ' In WelInt' + write(u6,*) ' r0, ExpB=',r0,ExpB + write(u6,*) ' la,lb=',la,lb +end if + +k = la+lb +jsum = 1 +do i=1,k + jsum = jsum+3**i +end do + +ip = 1 +ipGri = ip +ip = ip+nZeta*jsum +ipGrin = ip +ip = ip+nZeta*(k+1)*(k/2+1)*(k/4+1) +iPxyz = ip +ip = ip+nZeta +if (ip-1 > nZeta*nArr) then + call WarningMessage(2,'WelInt: ip-1 > nZeta*nArr(pos.1)') + write(u6,*) ip-1,'>',nZeta*nArr + call Abend() +end if + +call Rowel(nZeta,r0,expB,k,Zeta,P,Array(iPxyz),Array(ipGri),Array(ipGrin),jsum) +ip = ip-nZeta +ip = ip-nZeta*(k+1)*(k/2+1)*(k/4+1) + +ipA = ip +ip = ip+nZeta*9 +ipScr = ip +ip = ip+nZeta*3**k +if (ip-1 > nZeta*nArr) then + call WarningMessage(2,'WelInt: ip-1 > nZeta*nArr(pos.2)') + write(u6,*) ip-1,'>',nZeta*nArr + call Abend() +end if + +! Transform each block to the global coordinate system + +iOff = ipgri+nZeta +do ik=1,k + if (ik == 1) call SetUpA(nZeta,Array(ipA),P) + call Traxyz(nZeta,ik,Array(iOff),Array(ipScr),Array(ipA)) + iOff = iOff+nZeta*3**ik +end do +if (iPrint >= 99) call RecPrt(' In WelInt: Array(ipGri)',' ',Array(ipGri),nZeta,jSum) +ip = ip-nZeta*3**k +ip = ip-nZeta*9 + +ip1 = ip +ip = ip+nZeta +ip2 = ip +ip = ip+nZeta +ip3 = ip +ip = ip+nZeta +ip4 = ip +ip = ip+nZeta +ip5 = ip +ip = ip+nZeta +if (ip-1 > nZeta*nArr) then + call WarningMessage(2,'WelInt: ip-1 > nZeta*nArr(pos.3)') + write(u6,*) ip-1,'>',nZeta*nArr + call Abend() +end if +call TraPAB(nZeta,la,lb,rFinal,Array(ipgri),jSum,rKappa,Array(ip1),Array(ip2),Array(ip3),Array(ip4),Array(ip5),A,RB,P) +ip = ip-nZeta*5 +ip = ip-nZeta*jsum + +return + +end subroutine WelInt diff -Nru openmolcas-22.02/src/oneint_util/welmem.f openmolcas-22.10/src/oneint_util/welmem.f --- openmolcas-22.02/src/oneint_util/welmem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/welmem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,30 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine WelMem( -#define _CALLING_ -#include "mem_interface.fh" - &) -#include "mem_interface.fh" -* - k = la+lb - jsum = 1 - Do 10 i = 1, k - jsum = jsum + 3**i - 10 Continue - nHer=1 - Mem = jsum +Max((k+1)*(k/2+1)*(k/4+1)+1, - & 9+3**k, - & 5) -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(lr) - End diff -Nru openmolcas-22.02/src/oneint_util/welmem.F90 openmolcas-22.10/src/oneint_util/welmem.F90 --- openmolcas-22.02/src/oneint_util/welmem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/welmem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,36 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine WelMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: i, jsum, k + +#include "macros.fh" +unused_var(lr) + +k = la+lb +jsum = 1 +do i=1,k + jsum = jsum+3**i +end do +nHer = 1 +Mem = jsum+max((k+1)*(k/2+1)*(k/4+1)+1,9+3**k,5) + +return + +end subroutine WelMem diff -Nru openmolcas-22.02/src/oneint_util/xfdint.f openmolcas-22.10/src/oneint_util/xfdint.f --- openmolcas-22.02/src/oneint_util/xfdint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/xfdint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,242 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1995, Roland Lindh * -************************************************************************ - SubRoutine XFdInt( -#define _CALLING_ -#include "int_interface.fh" - & ) -************************************************************************ -* * -* Object: kernel routine for the computation of nuclear attraction * -* integrals. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, Sweden, April '95 * -************************************************************************ - use external_centers - use Phase_Info - Implicit Real*8 (A-H,O-Z) - External TNAI, Fake, XCff2D, XRys2D -#include "itmax.fh" -#include "real.fh" -#include "print.fh" - -#include "int_interface.fh" - -*-----Local variables - Real*8 C(3), TC(3), Coori(3,4), CoorAC(3,2), - & ZFd((iTabMx+1)*(iTabMx+2)/2), ZRFd((iTabMx+1)*(iTabMx+2)/2) - Logical EQ, NoLoop, NoSpecial - Integer iAnga(4), iDCRT(0:7), iStb(0:7), jCoSet(8,8) - Character ChOper(0:7)*3 - Data ChOper/'E ','x ','y ','xy ','z ','xz ','yz ','xyz'/ -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 -C nElem(ixyz) = 2*ixyz+1 - nabSz(ixyz) = (ixyz+1)*(ixyz+2)*(ixyz+3)/6 - 1 -* - iRout = 151 - iPrint = nPrint(iRout) -* - call dcopy_(nZeta*nElem(la)*nElem(lb)*nIC,[Zero],0,Final,1) -* -*---- Loop over charges and dipole moments in the external field -* - nData=3 - Do iOrdOp = 0, nOrdOp -* - iAnga(1) = la - iAnga(2) = lb - iAnga(3) = iOrdOp - iAnga(4) = 0 - call dcopy_(3, A,1,Coori(1,1),1) - call dcopy_(3,RB,1,Coori(1,2),1) - mabMin = nabSz(Max(la,lb)-1)+1 - mabMax = nabSz(la+lb) - If (EQ(A,RB)) mabMin=nabSz(la+lb-1)+1 - mcdMin = nabSz(iOrdOp-1)+1 - mcdMax = nabSz(iOrdOp) - lab=(mabMax-mabMin+1) - kab=nElem(la)*nElem(lb) - lcd=(mcdMax-mcdMin+1) - labcd=lab*lcd -* -* Compute FLOP's and size of work array which Hrr will use. -* - Call mHrr(la,lb,nFLOP,nMem) -* -*---- Distribute the work array -* - ip2 = 1 - ip1 = ip2 + nZeta*Max(labcd,lcd*nMem) - mArr = nArr - Max(labcd,lcd*nMem) -* -* Find center to accumulate angular momentum on. (HRR) -* - If (la.ge.lb) Then - call dcopy_(3,A,1,CoorAC(1,1),1) - Else - call dcopy_(3,RB,1,CoorAC(1,1),1) - End If -* -* Loop over centers of the external field. -* - iDum=0 - Do iFd = 1, nXF -* - NoLoop=.True. - Do jElem = 1, nElem(iOrdOp) - ZFd(jElem)=XF(nData+jElem,iFd) -* Divide quadrupole diagonal by 2 due to different normalisation - if((iOrdOp.eq.2).and. - & (jElem.eq.1.or.jElem.eq.4.or.jElem.eq.6)) - & ZFd(jElem)=ZFd(jElem)*0.5D0 - NoLoop = NoLoop .and. ZFd(jElem).eq.Zero - End Do -* - If (NoLoop) Go To 111 -*------- Pick up the center coordinates - C(1:3)=XF(1:3,iFd) - - If (iPrint.ge.99) Call RecPrt('C',' ',C,1,3) -* -*------- Generate stabilizor of C -* - iChxyz=iChAtm(C) - Call Stblz(iChxyz,nStb,iStb,iDum,jCoSet) -* -*--------Find the DCR for M and S -* - Call DCR(LmbdT,iStabM,nStabM,iStb,nStb,iDCRT,nDCRT) - Fact = DBLE(nStabM) / DBLE(LmbdT) -* - If (iPrint.ge.99) Then - Write (6,*) ' m =',nStabM - Write (6,'(9A)') '(M)=',(ChOper(iStabM(ii)), - & ii = 0, nStabM-1) - Write (6,*) ' s =',nStb - Write (6,'(9A)') '(S)=',(ChOper(iStb(ii)), - & ii = 0, nStb-1) - Write (6,*) ' LambdaT=',LmbdT - Write (6,*) ' t =',nDCRT - Write (6,'(9A)') '(T)=',(ChOper(iDCRT(ii)), - & ii = 0, nDCRT-1) - End If - -* - Do lDCRT = 0, nDCRT-1 - Call OA(iDCRT(lDCRT),C,TC) -* - jElem=0 - Do ix = iOrdOp, 0, -1 - If (Mod(ix,2).eq.0) Then - Factx=One - Else - Factx=DBLE(iPhase(1,iDCRT(lDCRT))) - End If - Do iy = iOrdOp-ix, 0, -1 - If (Mod(iy,2).eq.0) Then - Facty=One - Else - Facty=DBLE(iPhase(2,iDCRT(lDCRT))) - End If - iz = iOrdOp-ix-iy - If (Mod(iz,2).eq.0) Then - Factz=One - Else - Factz=DBLE(iPhase(3,iDCRT(lDCRT))) - End If -* - jElem = jElem + 1 - ZRFd(jElem)=Factx*Facty*Factz*ZFd(jElem) - End Do - End Do -* - call dcopy_(3,TC,1,CoorAC(1,2),1) - call dcopy_(3,TC,1,Coori(1,3),1) - call dcopy_(3,TC,1,Coori(1,4),1) -* -* Compute integrals with the Rys quadrature. -* - nT = nZeta - NoSpecial=.True. - Call Rys(iAnga,nT,Zeta,ZInv,nZeta, - & [One],[One],1,P,nZeta, - & TC,1,rKappa,[One],Coori,Coori,CoorAC, - & mabmin,mabmax,mcdMin,mcdMax, - & Array(ip1),mArr*nZeta, - & TNAI,Fake,XCff2D,XRys2D,NoSpecial) -* -*---------- The integrals are now ordered as ijkl,e,f -* -* a) Change the order to f,ijkl,e -* b) Unfold e to ab, f,ijkl,ab -* c) Change the order back to ijkl,ab,f -* -*a)-------- -* - Call DGeTMO(Array(ip1),nZeta*lab,nZeta*lab,lcd, - & Array(ip2),lcd) -* -*b)---------Use the HRR to unfold e to ab -* - Call HRR(la,lb,A,RB,Array(ip2),lcd*nZeta,nMem,ipIn) - ip3=ip2-1+ipIn -* -*c)-------- -* - Call DGeTMO(Array(ip3),lcd,lcd,nZeta*kab,Array(ip1), - & nZeta*kab) -* -*-----------Accumulate contributions to the symmetry adapted operator -* - nOp = NrOpr(iDCRT(lDCRT)) - ipI=ip1 -* - Do i = 1, nElem(iOrdOp) - If (ZRFd(i).ne.Zero) - & Call SymAdO(Array(ipI),nZeta,la,lb,nComp,Final,nIC, - & nOp ,lOper,iChO,-Fact*ZRFd(i)) - ipI=ipI+nZeta*nElem(la)*nElem(lb) - End Do -* -*#define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Write (6,*) (Fact*ZFd(i),i = 1, nElem(iOrdOp)) - Call RecPrt('Array(ip1)',' ',Array(ip1),nZeta, - & (la+1)*(la+2)/2*(lb+1)*(lb+2)/2*nElem(iOrdOp)) - Call RecPrt('Final',' ',Final, - & nZeta,(la+1)*(la+2)/2*(lb+1)*(lb+2)/2*nIC) -#endif - -* - End Do ! End loop over DCRs -* -111 Continue - End Do ! iFd -* - nData = nData + nElem(iOrdOp) - End Do ! iOrdOp -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Alpha) - Call Unused_real_array(Beta) - Call Unused_integer(nHer) - Call Unused_real_array(CCoor) - Call Unused_real_array(PtChrg) - Call Unused_integer(iAddPot) - End If - End diff -Nru openmolcas-22.02/src/oneint_util/xfdint.F90 openmolcas-22.10/src/oneint_util/xfdint.F90 --- openmolcas-22.02/src/oneint_util/xfdint.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/xfdint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,227 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1995, Roland Lindh * +!*********************************************************************** + +subroutine XFdInt( & +# define _CALLING_ +# include "int_interface.fh" + ) +!*********************************************************************** +! * +! Object: kernel routine for the computation of nuclear attraction * +! integrals. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, Sweden, April '95 * +!*********************************************************************** + +use external_centers, only: nXF, XF +use Phase_Info, only: iPhase +use Index_Functions, only: nTri3_Elem1, nTri_Elem1 +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Half +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_interface.fh" +#include "print.fh" +integer(kind=iwp) :: i, iAnga(4), iChxyz, iDCRT(0:7), iDum, iFd, ii, iOrdOp, ip1, ip2, ip3, ipI, ipIn, iPrint, iRout, iStb(0:7), & + ix, iy, iz, jCoSet(8,8), jElem, kab, lab, labcd, lcd, lDCRT, LmbdT, mabMax, mabMin, mArr, mcdMax, mcdMin, & + nData, nDCRT, nFLOP, nMem, nOp, nStb, nT +real(kind=wp) :: C(3), CoorAC(3,2), Coori(3,4), Fact, Factx, Facty, Factz, TC(3) +logical(kind=iwp) :: NoLoop, NoSpecial +real(kind=wp), allocatable :: ZFd(:), ZRFd(:) +character(len=*), parameter :: ChOper(0:7) = ['E ','x ','y ','xy ','z ','xz ','yz ','xyz'] +integer(kind=iwp), external :: iChAtm, NrOpr +logical(kind=iwp), external :: EQ +external TNAI, Fake, XCff2D, XRys2D + +#include "macros.fh" +unused_var(Alpha) +unused_var(Beta) +unused_var(nHer) +unused_var(Ccoor) +unused_var(PtChrg) +unused_var(iAddPot) + +iRout = 151 +iPrint = nPrint(iRout) + +rFinal(:,:,:,:) = Zero + +call mma_allocate(ZFd,nTri_Elem1(nOrdOp),label='ZFd') +call mma_allocate(ZRFd,nTri_Elem1(nOrdOp),label='ZRFd') + +! Loop over charges and dipole moments in the external field + +nData = 3 +do iOrdOp=0,nOrdOp + + iAnga(1) = la + iAnga(2) = lb + iAnga(3) = iOrdOp + iAnga(4) = 0 + Coori(:,1) = A + Coori(:,2) = RB + mabMin = nTri3_Elem1(max(la,lb)-1) + mabMax = nTri3_Elem1(la+lb)-1 + if (EQ(A,RB)) mabMin = nTri3_Elem1(la+lb-1) + mcdMin = nTri3_Elem1(iOrdOp-1) + mcdMax = nTri3_Elem1(iOrdOp)-1 + lab = (mabMax-mabMin+1) + kab = nTri_Elem1(la)*nTri_Elem1(lb) + lcd = (mcdMax-mcdMin+1) + labcd = lab*lcd + + ! Compute FLOP's and size of work array which Hrr will use. + + call mHrr(la,lb,nFLOP,nMem) + + ! Distribute the work array + + ip2 = 1 + ip1 = ip2+nZeta*max(labcd,lcd*nMem) + mArr = nArr-max(labcd,lcd*nMem) + + ! Find center to accumulate angular momentum on. (HRR) + + if (la >= lb) then + CoorAC(:,1) = A + else + CoorAC(:,1) = RB + end if + + ! Loop over centers of the external field. + + iDum = 0 + do iFd=1,nXF + + NoLoop = .true. + do jElem=1,nTri_Elem1(iOrdOp) + ZFd(jElem) = XF(nData+jElem,iFd) + ! Divide quadrupole diagonal by 2 due to different normalisation + if ((iOrdOp == 2) .and. ((jElem == 1) .or. (jElem == 4) .or. (jElem == 6))) ZFd(jElem) = ZFd(jElem)*Half + NoLoop = NoLoop .and. (ZFd(jElem) == Zero) + end do + + if (NoLoop) cycle + ! Pick up the center coordinates + C(1:3) = XF(1:3,iFd) + + if (iPrint >= 99) call RecPrt('C',' ',C,1,3) + + ! Generate stabilizer of C + + iChxyz = iChAtm(C) + call Stblz(iChxyz,nStb,iStb,iDum,jCoSet) + + !-Find the DCR for M and S + + call DCR(LmbdT,iStabM,nStabM,iStb,nStb,iDCRT,nDCRT) + Fact = real(nStabM,kind=wp)/real(LmbdT,kind=wp) + + if (iPrint >= 99) then + write(u6,*) ' m =',nStabM + write(u6,'(9A)') '(M)=',(ChOper(iStabM(ii)),ii=0,nStabM-1) + write(u6,*) ' s =',nStb + write(u6,'(9A)') '(S)=',(ChOper(iStb(ii)),ii=0,nStb-1) + write(u6,*) ' LambdaT=',LmbdT + write(u6,*) ' t =',nDCRT + write(u6,'(9A)') '(T)=',(ChOper(iDCRT(ii)),ii=0,nDCRT-1) + end if + + do lDCRT=0,nDCRT-1 + call OA(iDCRT(lDCRT),C,TC) + + jElem = 0 + do ix=iOrdOp,0,-1 + if (mod(ix,2) == 0) then + Factx = One + else + Factx = real(iPhase(1,iDCRT(lDCRT)),kind=wp) + end if + do iy=iOrdOp-ix,0,-1 + if (mod(iy,2) == 0) then + Facty = One + else + Facty = real(iPhase(2,iDCRT(lDCRT)),kind=wp) + end if + iz = iOrdOp-ix-iy + if (mod(iz,2) == 0) then + Factz = One + else + Factz = real(iPhase(3,iDCRT(lDCRT)),kind=wp) + end if + + jElem = jElem+1 + ZRFd(jElem) = Factx*Facty*Factz*ZFd(jElem) + end do + end do + + CoorAC(:,2) = TC + Coori(:,3) = TC + Coori(:,4) = TC + + ! Compute integrals with the Rys quadrature. + + nT = nZeta + NoSpecial = .true. + call Rys(iAnga,nT,Zeta,ZInv,nZeta,[One],[One],1,P,nZeta,TC,1,rKappa,[One],Coori,Coori,CoorAC,mabmin,mabmax,mcdMin,mcdMax, & + Array(ip1),mArr*nZeta,TNAI,Fake,XCff2D,XRys2D,NoSpecial) + + ! The integrals are now ordered as ijkl,e,f + + ! a) Change the order to f,ijkl,e + ! b) Unfold e to ab, f,ijkl,ab + ! c) Change the order back to ijkl,ab,f + + ! a) + + call DGeTMO(Array(ip1),nZeta*lab,nZeta*lab,lcd,Array(ip2),lcd) + + ! b) Use the HRR to unfold e to ab + + call HRR(la,lb,A,RB,Array(ip2),lcd*nZeta,nMem,ipIn) + ip3 = ip2-1+ipIn + + ! c) + + call DGeTMO(Array(ip3),lcd,lcd,nZeta*kab,Array(ip1),nZeta*kab) + + ! Accumulate contributions to the symmetry adapted operator + + nOp = NrOpr(iDCRT(lDCRT)) + ipI = ip1 + + do i=1,nTri_Elem1(iOrdOp) + if (ZRFd(i) /= Zero) call SymAdO(Array(ipI),nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,-Fact*ZRFd(i)) + ipI = ipI+nZeta*nTri_Elem1(la)*nTri_Elem1(lb) + end do + +# ifdef _DEBUGPRINT_ + write(u6,*) (Fact*ZFd(i),i=1,nTri_Elem1(iOrdOp)) + call RecPrt('Array(ip1)',' ',Array(ip1),nZeta,(la+1)*(la+2)/2*(lb+1)*(lb+2)/2*nTri_Elem1(iOrdOp)) + call RecPrt('rFinal',' ',rFinal,nZeta,(la+1)*(la+2)/2*(lb+1)*(lb+2)/2*nIC) +# endif + + end do ! End loop over DCRs + end do ! iFd + + nData = nData+nTri_Elem1(iOrdOp) +end do ! iOrdOp + +call mma_deallocate(ZFd) +call mma_deallocate(ZRFd) + +return + +end subroutine XFdInt diff -Nru openmolcas-22.02/src/oneint_util/xfdmem.f openmolcas-22.10/src/oneint_util/xfdmem.f --- openmolcas-22.02/src/oneint_util/xfdmem.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/xfdmem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,50 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - Subroutine XFdMem( -#define _CALLING_ -#include "mem_interface.fh" - &) -#include "mem_interface.fh" -* - Integer iAngV(4) -* -* Statement function for Cartesian index -* - nElem(ixyz) = (ixyz+1)*(ixyz+2)/2 - nabSz(ixyz) = (ixyz+1)*(ixyz+2)*(ixyz+3)/6 - 1 -* - lc = lr - ld = 0 - nHer = (la+lb+lc+ld+2)/2 - labMin=nabSz(Max(la,lb)-1)+1 - labMax=nabSz(la+lb) - lcdMin=nabSz(lr-1)+1 - lcdMax=nabSz(lr) - lab = (labMax-labMin+1) - kab = nElem(la)*nElem(lb) - lcd = (lcdMax-lcdMin+1) - labcd = lab*lcd -* - Call mHRR(la,lb,nFlop,nMem) - Mem1=Max(lcd*nMem,labcd) -* - iAngV(1) = la - iAngV(2) = lb - iAngV(3) = lc - iAngV(4) = ld - Call MemRys(iAngV,Mem2) - Mem2 = Max(Mem2,kab*lcd) -* - Mem=Mem1 + Mem2 - Return - End diff -Nru openmolcas-22.02/src/oneint_util/xfdmem.F90 openmolcas-22.10/src/oneint_util/xfdmem.F90 --- openmolcas-22.02/src/oneint_util/xfdmem.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/oneint_util/xfdmem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,52 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine XFdMem( & +# define _CALLING_ +# include "mem_interface.fh" + ) + +use Index_Functions, only: nTri3_Elem1, nTri_Elem1 +use Definitions, only: iwp + +implicit none +#include "mem_interface.fh" +integer(kind=iwp) :: iAngV(4), kab, lab, labcd, labMax, labMin, lc, lcd, lcdMax, lcdMin, ld, Mem1, Mem2, nFlop, nMem + +lc = lr +ld = 0 +nHer = (la+lb+lc+ld+2)/2 +labMin = nTri3_Elem1(max(la,lb)-1) +labMax = nTri3_Elem1(la+lb)-1 +lcdMin = nTri3_Elem1(lr-1) +lcdMax = nTri3_Elem1(lr)-1 +lab = (labMax-labMin+1) +kab = nTri_Elem1(la)*nTri_Elem1(lb) +lcd = (lcdMax-lcdMin+1) +labcd = lab*lcd + +call mHRR(la,lb,nFlop,nMem) +Mem1 = max(lcd*nMem,labcd) + +iAngV(1) = la +iAngV(2) = lb +iAngV(3) = lc +iAngV(4) = ld +call MemRys(iAngV,Mem2) +Mem2 = max(Mem2,kab*lcd) + +Mem = Mem1+Mem2 + +return + +end subroutine XFdMem diff -Nru openmolcas-22.02/src/pcm_util/datasol.F90 openmolcas-22.10/src/pcm_util/datasol.F90 --- openmolcas-22.02/src/pcm_util/datasol.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/pcm_util/datasol.F90 2022-10-10 14:22:40.000000000 +0000 @@ -35,6 +35,10 @@ !CMF = SolvData(IDSolv)%CMF ! Atomic parameters for dispersion and repulsion !Rho = SolvData(IDSolv)%Rho +if (size(SolvData(IDSolv)%Atoms) > MxA) then + call WarningMessage(2,'DataSol: num. solv. atoms > MxA') + call Abend() +end if do i=1,size(SolvData(IDSolv)%Atoms) if (SolvData(IDSolv)%Atoms(i)%NTT == 0) then !NATyp = i-1 diff -Nru openmolcas-22.02/src/pcm_util/fndsph.F90 openmolcas-22.10/src/pcm_util/fndsph.F90 --- openmolcas-22.02/src/pcm_util/fndsph.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/pcm_util/fndsph.F90 2022-10-10 14:22:40.000000000 +0000 @@ -27,30 +27,31 @@ #include "rctfld.fh" ! Assign GEPOL sphere positions and radii according to solute atoms nature -if (ITypRad == 1) then - ! United Atom Topological Model (UATM) radii: - call mma_allocate(Chg,NAt,label='Chg') - Chg(:) = Zero - call UATM(u6,ICharg,NAt,NSinit,m,Rad,Alpha,C,IAt,NOrd,Chg,iPrint) - call mma_deallocate(Chg) -else if (ITypRad == 2) then - ! Pauling radii on each atom: - do I=1,NAt - NOrd(I) = I - Rad(I) = Pauling(IAt(I)) - end do - Alpha = 1.2_wp - NSinit = NAt -else if (ITypRad == 3) then - ! Sphere radii given in the input - NOrd(1:NSphInp) = NOrdInp(1:NSphInp) - Rad(1:NSphInp) = RadInp(1:NSphInp) - Alpha = 1.2_wp - NSinit = NSphInp -else - write(u6,'(a)') 'Unrecognized radii type !' - call Abend() -end if +select case (ITypRad) + case (1) + ! United Atom Topological Model (UATM) radii: + call mma_allocate(Chg,NAt,label='Chg') + Chg(:) = Zero + call UATM(u6,ICharg,NAt,NSinit,m,Rad,Alpha,C,IAt,NOrd,Chg,iPrint) + call mma_deallocate(Chg) + case (2) + ! Pauling radii on each atom: + do I=1,NAt + NOrd(I) = I + Rad(I) = Pauling(IAt(I)) + end do + Alpha = 1.2_wp + NSinit = NAt + case (3) + ! Sphere radii given in the input + NOrd(1:NSphInp) = NOrdInp(1:NSphInp) + Rad(1:NSphInp) = RadInp(1:NSphInp) + Alpha = 1.2_wp + NSinit = NSphInp + case default + write(u6,'(a)') 'Unrecognized radii type !' + call Abend() +end select if (((ITypRad == 2) .or. (ITypRad == 3)) .and. (iPrint > 5)) call PrtCav(u6,ITypRad,NSinit,NOrd,Alpha,Rad) do I=1,NSinit diff -Nru openmolcas-22.02/src/pcm_util/fndtess.F90 openmolcas-22.10/src/pcm_util/fndtess.F90 --- openmolcas-22.02/src/pcm_util/fndtess.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/pcm_util/fndtess.F90 2022-10-10 14:22:40.000000000 +0000 @@ -81,11 +81,12 @@ RTDD2 = RTDD*RTDD NET = NS NN = 2 -NE = NS +NE = NET-1 ! just to get the loop started NEV = NS FIRST = .true. -do +do while (NET /= NE) if (FIRST) then + NE = NS FIRST = .false. else NN = NE+1 @@ -102,16 +103,16 @@ RIJ = sqrt(RIJ2) RJD = Rs(J)+RSOLV TEST1 = Rs(I)+RJD+RSOLV - if (RIJ >= TEST1) cycle + if (RIJ >= TEST1) cycle middle REG = max(Rs(I),Rs(J)) REP = min(Rs(I),Rs(J)) REG2 = REG*REG REP2 = REP*REP TEST2 = REP*SENOM+sqrt(REG2-REP2*COSOM2) - if (RIJ <= TEST2) cycle + if (RIJ <= TEST2) cycle middle REGD2 = (REG+RSOLV)*(REG+RSOLV) TEST3 = (REGD2+REG2-RTDD2)/REG - if (RIJ >= TEST3) cycle + if (RIJ >= TEST3) cycle middle do K=1,NEV if ((K == J) .or. (K == I)) cycle RJK2 = (Xs(J)-Xs(K))**2+(Ys(J)-Ys(K))**2+(Zs(J)-Zs(K))**2 @@ -133,38 +134,26 @@ R2GN = RIJ-REP+REG RGN = R2GN*Half FC = R2GN/(RIJ+REP-REG) - FC1 = FC+One - TEST7 = REG-Rs(I) - if (TEST7 <= 1.0e-9_wp) then - KG = I - KP = J - XEN = (Xs(KG)+FC*Xs(KP))/FC1 - YEN = (Ys(KG)+FC*Ys(KP))/FC1 - ZEN = (Zs(KG)+FC*Zs(KP))/FC1 - REN = sqrt(REGD2+RGN*(RGN-(REGD2+RIJ2-REPD2)/RIJ))-RSOLV - else - KG = J - KP = I - end if + REN = sqrt(REGD2+RGN*(RGN-(REGD2+RIJ2-REPD2)/RIJ))-RSOLV else REND2 = REGD2+REG2-(REG/RIJ)*(REGD2+RIJ2-REPD2) - if (REND2 <= RTDD2) cycle + if (REND2 <= RTDD2) cycle middle REN = sqrt(REND2)-RSOLV FC = REG/(RIJ-REG) - TEST7 = REG-Rs(I) - if (TEST7 <= 1.0e-9_wp) then - KG = I - KP = J - FC1 = FC+One - XEN = (Xs(KG)+FC*Xs(KP))/FC1 - YEN = (Ys(KG)+FC*Ys(KP))/FC1 - ZEN = (Zs(KG)+FC*Zs(KP))/FC1 - ITYPC = 1 - else - KG = J - KP = I - end if + ITYPC = 1 end if + FC1 = FC+One + TEST7 = REG-Rs(I) + if (TEST7 <= 1.0e-9_wp) then + KG = I + KP = J + else + KG = J + KP = I + end if + XEN = (Xs(KG)+FC*Xs(KP))/FC1 + YEN = (Ys(KG)+FC*Ys(KP))/FC1 + ZEN = (Zs(KG)+FC*Zs(KP))/FC1 NET = NET+1 Xs(NET) = XEN Ys(NET) = YEN diff -Nru openmolcas-22.02/src/pcm_util/inprct.F90 openmolcas-22.10/src/pcm_util/inprct.F90 --- openmolcas-22.02/src/pcm_util/inprct.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/pcm_util/inprct.F90 2022-10-10 14:22:40.000000000 +0000 @@ -311,6 +311,10 @@ ITypRad = 3 ISlPar(9) = ITypRad i_sph_inp = i_sph_inp+1 + if (i_sph_inp > MxA) then + call WarningMessage(2,'InpRct: i_sph_inp > MxA') + call Abend() + end if NOrdInp(i_sph_inp) = I_Sph RadInp(i_sph_inp) = Radius ISlPar(14) = i_sph_inp diff -Nru openmolcas-22.02/src/pcm_util/oneel_g_pcm.F90 openmolcas-22.10/src/pcm_util/oneel_g_pcm.F90 --- openmolcas-22.02/src/pcm_util/oneel_g_pcm.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/pcm_util/oneel_g_pcm.F90 2022-10-10 14:22:40.000000000 +0000 @@ -284,7 +284,7 @@ ! trace the result. call Kernel(Shells(iShll)%Exp,iPrim,Shells(jShll)%Exp,jPrim,Zeta,ZI,Kappa,Pcoor,Fnl,iPrim*jPrim,iAng,jAng,A,RB,nOrder,Kern, & - MemKer,Ccoor,nOrdOp,Grad,nGrad,IfGrad,IndGrd,DAO,mdci,mdcj,nOp,lOper,nComp,iStabM,nStabM) + MemKer,Ccoor,nOrdOp,Grad,nGrad,IfGrad,IndGrd,DAO,mdci,mdcj,nOp,nComp,iStabM,nStabM) if (iPrint >= 49) call PrGrad_pcm(' In Oneel',Grad,nGrad,ChDisp,5) end do diff -Nru openmolcas-22.02/src/pcm_util/pcmgrd1.F90 openmolcas-22.10/src/pcm_util/pcmgrd1.F90 --- openmolcas-22.02/src/pcm_util/pcmgrd1.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/pcm_util/pcmgrd1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -36,8 +36,8 @@ implicit none #include "grd_interface.fh" integer(kind=iwp) :: i, iAlpha, iAnga(4), iBeta, iCar, iDAO, iDCRT(0:7), ii, ipA, ipAOff, ipB, ipBOff, ipDAO, iPrint, iRout, & - iStb(0:7), iTs, iuvwx(4), iZeta, j, JndGrd(3,4), lDCRT, LmbdT, lOp(4), mGrad, mRys, nArray, nDAO, nDCRT, & - nDiff, nip, nStb, nT + iStb(0:7), iTs, iuvwx(4), iZeta, JndGrd(3,4), lDCRT, LmbdT, lOp(4), mGrad, mRys, nArray, nDAO, nDCRT, nDiff, & + nip, nStb, nT real(kind=wp) :: C(3), CoorAC(3,2), Coori(3,4), Fact, Q, TC(3) logical(kind=iwp) :: NoLoop, JfGrad(3,4) character(len=3), parameter :: ChOper(0:7) = ['E ','x ','y ','xy ','z ','xz ','yz ','xyz'] @@ -48,8 +48,8 @@ #include "macros.fh" unused_var(rFinal) unused_var(nHer) -unused_var(Ccoor) -unused_var(lOper) +unused_var(Ccoor(1)) +unused_var(nComp) iRout = 151 iPrint = nPrint(iRout) @@ -83,15 +83,15 @@ iAnga(2) = lb iAnga(3) = nOrdOp iAnga(4) = 0 -call dcopy_(3,A,1,Coori(1,1),1) -call dcopy_(3,RB,1,Coori(1,2),1) +Coori(:,1) = A +Coori(:,2) = RB ! Find center to accumulate angular momentum on. (HRR) if (la >= lb) then - call dcopy_(3,A,1,CoorAC(1,1),1) + CoorAC(:,1) = A else - call dcopy_(3,RB,1,CoorAC(1,1),1) + CoorAC(:,1) = RB end if iuvwx(1) = dc(mdc)%nStab iuvwx(2) = dc(ndc)%nStab @@ -151,24 +151,14 @@ end if iuvwx(3) = nStb iuvwx(4) = nStb - call ICopy(6,IndGrd,1,JndGrd,1) - do i=1,3 - do j=1,2 - JfGrad(i,j) = IfGrad(i,j) - end do - end do + JndGrd(:,1:2) = IndGrd + JfGrad(:,1:2) = IfGrad ! No derivatives with respect to the third or fourth center. ! The positions of the points in the external field are frozen. - call ICopy(3,[0],0,JndGrd(1,3),1) - JfGrad(1,3) = .false. - JfGrad(2,3) = .false. - JfGrad(3,3) = .false. - call ICopy(3,[0],0,JndGrd(1,4),1) - JfGrad(1,4) = .false. - JfGrad(2,4) = .false. - JfGrad(3,4) = .false. + JndGrd(:,3:4) = 0 + JfGrad(:,3:4) = .false. mGrad = 0 do iCar=1,3 do i=1,2 @@ -182,11 +172,11 @@ lOp(3) = NrOpr(iDCRT(lDCRT)) lOp(4) = lOp(3) call OA(iDCRT(lDCRT),C,TC) - call dcopy_(3,TC,1,CoorAC(1,2),1) - call dcopy_(3,TC,1,Coori(1,3),1) - call dcopy_(3,TC,1,Coori(1,4),1) + CoorAC(:,2) = TC + Coori(:,3) = TC + Coori(:,4) = TC - call DYaX(nZeta*nDAO,Fact*Q,DAO,1,Array(ipDAO),1) + Array(ipDAO:ipDAO+nZeta*nDAO-1) = Fact*Q*pack(DAO,.true.) ! Compute integrals with the Rys quadrature. @@ -196,7 +186,7 @@ call Rysg1(iAnga,mRys,nT,Array(ipA),Array(ipB),[One],[One],Zeta,ZInv,nZeta,[One],[One],1,P,nZeta,TC,1,Coori,Coori,CoorAC, & Array(nip),nArray,TNAI1,Fake,XCff2D,Array(ipDAO),nDAO*nTri_Elem1(nOrdOp),Grad,nGrad,JfGrad,JndGrd,lOp,iuvwx) - !call RecPrt(' In PCMgrd:Grad',' ',Grad,nGrad,1) + !call RecPrt(' In PCMgrd1:Grad',' ',Grad,nGrad,1) end do ! End loop over DCRs end do ! End loop over centers in the external field diff -Nru openmolcas-22.02/src/pcm_util/pcmhss.F90 openmolcas-22.10/src/pcm_util/pcmhss.F90 --- openmolcas-22.02/src/pcm_util/pcmhss.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/pcm_util/pcmhss.F90 2022-10-10 14:22:40.000000000 +0000 @@ -29,13 +29,13 @@ ! R. Lindh. * !*********************************************************************** +use Index_Functions, only: nTri_Elem1 use PCM_arrays, only: PCM_SQ, PCMTess use Center_Info, only: dc use Constants, only: Zero, One, Two, Pi use Definitions, only: wp, iwp, u6 implicit none -#define _USE_WP_ #include "hss_interface.fh" integer(kind=iwp) :: iAlpha, iAnga(4), iAtom, iBeta, iCar, iDAO, iDCRT(0:7), iIrrep, idx(3,4), ipA, ipAOff, ipB, ipBOff, ipDAO, & iPrint, iRout, iStb(0:7), iTs, iuvwx(4), iZeta, jAtom, jCar, JndGrd(0:2,0:3,0:7), & @@ -49,7 +49,7 @@ #include "rctfld.fh" #include "macros.fh" -unused_var(Final) +unused_var(rFinal) unused_var(nHer) unused_var(Ccoor) unused_var(lOper) @@ -142,7 +142,7 @@ call DCR(LmbdT,iStabM,nStabM,iStb,nStb,iDCRT,nDCRT) Fact = -q_i*real(nStabM,kind=wp)/real(LmbdT,kind=wp) - call DYaX(nZeta*nDAO,Fact,DAO,1,Array(ipDAO),1) + Array(ipDAO:ipDAO+nZeta*nDAO-1) = Fact*pack(DAO,.true.) iuvwx(3) = nStb iuvwx(4) = nStb @@ -157,10 +157,10 @@ ! Initialize JfGrd, JndGrd, JfHss, and JndHss. - call LCopy(12,[.false.],0,JfGrd,1) - call ICopy(nSym*4*3,[0],0,JndGrd,1) - call LCopy(144,[.false.],0,JfHss,1) - call ICopy(nSym*16*9,[0],0,JndHss,1) + JfGrd(:,:) = .false. + JndGrd(:,:,0:nSym-1) = 0 + JfHss(:,:,:,:) = .false. + JndHss(:,:,:,:,0:nSym-1) = 0 ! Overwrite with information in IfGrd, IndGrd, IfHss, ! and IndHss. This sets up the info for the first two @@ -192,13 +192,9 @@ ! This requires the 2nd derivatives on the other centers. ! Note: We want no such thing! - call LCopy(4,[.false.],0,Tr,1) - - IfG(0) = .true. - IfG(1) = .true. - IfG(2) = .false. - IfG(3) = .false. - call LCopy(12,[.false.],0,JfGrd,1) + Tr(:) = .false. + IfG(:) = [.true.,.true.,.false.,.false.] + JfGrd(:,:) = .false. ! Compute integrals with the Rys quadrature. diff -Nru openmolcas-22.02/src/pcm_util/pcmmmh.F90 openmolcas-22.10/src/pcm_util/pcmmmh.F90 --- openmolcas-22.02/src/pcm_util/pcmmmh.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/pcm_util/pcmmmh.F90 2022-10-10 14:22:40.000000000 +0000 @@ -20,16 +20,15 @@ use Definitions, only: iwp implicit none -#define _USE_WP_ #include "mem_interface.fh" -integer(kind=iwp) :: iAng(4), MemTmp +integer(kind=iwp) :: iAng(4) iAng(1) = la iAng(2) = lb iAng(3) = lr iAng(4) = 0 -call MemRg2(iAng,nHer,MemTmp,2) -Mem = MemTmp+2+nTri_Elem1(la)*nTri_Elem1(lb)*nTri_Elem1(lr) +call MemRg2(iAng,nHer,Mem,2) +Mem = Mem+2+nTri_Elem1(la)*nTri_Elem1(lb)*nTri_Elem1(lr) return diff -Nru openmolcas-22.02/src/pcm_util/prtcav.F90 openmolcas-22.10/src/pcm_util/prtcav.F90 --- openmolcas-22.02/src/pcm_util/prtcav.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/pcm_util/prtcav.F90 2022-10-10 14:22:40.000000000 +0000 @@ -28,7 +28,7 @@ write(iOut,*) write(IOut,'(6X,A)') ' NOrd Alpha Radius' do IS=1,NS - write(IOut,'(6X,1X,I3,3X,F4.2,3X,F5.3)') NOrd(IS),Alpha,Rad(IS) + write(IOut,'(6X,I5,2X,F5.2,2X,F6.3)') NOrd(IS),Alpha,Rad(IS) end do write(IOut,'(6X,1X,78("-"))') write(IOut,*) diff -Nru openmolcas-22.02/src/ppint_util/assemble_ppgrd.F90 openmolcas-22.10/src/ppint_util/assemble_ppgrd.F90 --- openmolcas-22.02/src/ppint_util/assemble_ppgrd.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ppint_util/assemble_ppgrd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -9,14 +9,15 @@ ! LICENSE or in . * !*********************************************************************** -subroutine Assemble_PPGrd(Fin,nZeta,la,lb,iZeta,Alpha,Beta,A_laplb,A_lamlb,A_lalbp,A_lalbm,JfGrad) +subroutine Assemble_PPGrd(rFinal,nZeta,la,lb,iZeta,Alpha,Beta,A_laplb,A_lamlb,A_lalbp,A_lalbm,JfGrad) +use Index_Functions, only: C_Ind3 use Constants, only: Two use Definitions, only: wp, iwp implicit none integer(kind=iwp), intent(in) :: nZeta, la, lb, iZeta -real(kind=wp), intent(inout) :: Fin(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,6) +real(kind=wp), intent(inout) :: rFinal(nZeta,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2,6) real(kind=wp), intent(in) :: Alpha, Beta, A_laplb((la+2)*(la+3)/2,(lb+1)*(lb+2)/2), A_lamlb((la+0)*(la+1)/2,(lb+1)*(lb+2)/2), & A_lalbp((la+1)*(la+2)/2,(lb+2)*(lb+3)/2), A_lalbm((la+1)*(la+2)/2,(lb+0)*(lb+1)/2) logical(kind=iwp), intent(in) :: JfGrad(3,2) @@ -46,10 +47,10 @@ if (JfGrad(1,1)) then i6 = i6+1 if (ix == 0) then - Fin(iZeta,Ind(iy,iz),Ind(jy,jz),i6) = Two*Alpha*A_laplb(Ind(iy,iz),Ind(jy,jz)) + rFinal(iZeta,C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz),i6) = Two*Alpha*A_laplb(C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz)) else - Fin(iZeta,Ind(iy,iz),Ind(jy,jz),i6) = Two*Alpha*A_laplb(Ind(iy,iz),Ind(jy,jz))- & - real(ix,kind=wp)*A_lamlb(Ind(iy,iz),Ind(jy,jz)) + rFinal(iZeta,C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz),i6) = Two*Alpha*A_laplb(C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz))- & + real(ix,kind=wp)*A_lamlb(C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz)) end if end if ! * @@ -60,10 +61,10 @@ if (JfGrad(1,2)) then i6 = i6+1 if (jx == 0) then - Fin(iZeta,Ind(iy,iz),Ind(jy,jz),i6) = Two*Beta*A_lalbp(Ind(iy,iz),Ind(jy,jz)) + rFinal(iZeta,C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz),i6) = Two*Beta*A_lalbp(C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz)) else - Fin(iZeta,Ind(iy,iz),Ind(jy,jz),i6) = Two*Beta*A_lalbp(Ind(iy,iz),Ind(jy,jz))- & - real(jx,kind=wp)*A_lalbm(Ind(iy,iz),Ind(jy,jz)) + rFinal(iZeta,C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz),i6) = Two*Beta*A_lalbp(C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz))- & + real(jx,kind=wp)*A_lalbm(C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz)) end if end if ! * @@ -74,10 +75,10 @@ if (JfGrad(2,1)) then i6 = i6+1 if (iy == 0) then - Fin(iZeta,Ind(iy,iz),Ind(jy,jz),i6) = Two*Alpha*A_laplb(Ind(iy+1,iz),Ind(jy,jz)) + rFinal(iZeta,C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz),i6) = Two*Alpha*A_laplb(C_Ind3(ix,iy+1,iz),C_Ind3(jx,jy,jz)) else - Fin(iZeta,Ind(iy,iz),Ind(jy,jz),i6) = Two*Alpha*A_laplb(Ind(iy+1,iz),Ind(jy,jz))- & - real(iy,kind=wp)*A_lamlb(Ind(iy-1,iz),Ind(jy,jz)) + rFinal(iZeta,C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz),i6) = Two*Alpha*A_laplb(C_Ind3(ix,iy+1,iz),C_Ind3(jx,jy,jz))- & + real(iy,kind=wp)*A_lamlb(C_Ind3(ix,iy-1,iz),C_Ind3(jx,jy,jz)) end if end if ! * @@ -88,10 +89,10 @@ if (JfGrad(2,2)) then i6 = i6+1 if (jy == 0) then - Fin(iZeta,Ind(iy,iz),Ind(jy,jz),i6) = Two*Beta*A_lalbp(Ind(iy,iz),Ind(jy+1,jz)) + rFinal(iZeta,C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz),i6) = Two*Beta*A_lalbp(C_Ind3(ix,iy,iz),C_Ind3(jx,jy+1,jz)) else - Fin(iZeta,Ind(iy,iz),Ind(jy,jz),i6) = Two*Beta*A_lalbp(Ind(iy,iz),Ind(jy+1,jz))- & - real(jy,kind=wp)*A_lalbm(Ind(iy,iz),Ind(jy-1,jz)) + rFinal(iZeta,C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz),i6) = Two*Beta*A_lalbp(C_Ind3(ix,iy,iz),C_Ind3(jx,jy+1,jz))- & + real(jy,kind=wp)*A_lalbm(C_Ind3(ix,iy,iz),C_Ind3(jx,jy-1,jz)) end if end if ! * @@ -102,10 +103,10 @@ if (JfGrad(3,1)) then i6 = i6+1 if (iz == 0) then - Fin(iZeta,Ind(iy,iz),Ind(jy,jz),i6) = Two*Alpha*A_laplb(Ind(iy,iz+1),Ind(jy,jz)) + rFinal(iZeta,C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz),i6) = Two*Alpha*A_laplb(C_Ind3(ix,iy,iz+1),C_Ind3(jx,jy,jz)) else - Fin(iZeta,Ind(iy,iz),Ind(jy,jz),i6) = Two*Alpha*A_laplb(Ind(iy,iz+1),Ind(jy,jz))- & - real(iz,kind=wp)*A_lamlb(Ind(iy,iz-1),Ind(jy,jz)) + rFinal(iZeta,C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz),i6) = Two*Alpha*A_laplb(C_Ind3(ix,iy,iz+1),C_Ind3(jx,jy,jz))- & + real(iz,kind=wp)*A_lamlb(C_Ind3(ix,iy,iz-1),C_Ind3(jx,jy,jz)) end if end if ! * @@ -116,10 +117,10 @@ if (JfGrad(3,2)) then i6 = i6+1 if (jz == 0) then - Fin(iZeta,Ind(iy,iz),Ind(jy,jz),i6) = Two*Beta*A_lalbp(Ind(iy,iz),Ind(jy,jz+1)) + rFinal(iZeta,C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz),i6) = Two*Beta*A_lalbp(C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz+1)) else - Fin(iZeta,Ind(iy,iz),Ind(jy,jz),i6) = Two*Beta*A_lalbp(Ind(iy,iz),Ind(jy,jz+1))- & - real(jz,kind=wp)*A_lalbm(Ind(iy,iz),Ind(jy,jz-1)) + rFinal(iZeta,C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz),i6) = Two*Beta*A_lalbp(C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz+1))- & + real(jz,kind=wp)*A_lalbm(C_Ind3(ix,iy,iz),C_Ind3(jx,jy,jz-1)) end if end if ! * @@ -129,19 +130,10 @@ end do end do end do -!call RecPrt('Fin',' ',Fin,nZeta*nTri0Elem(la)*nTri0Elem(lb),6) +!call RecPrt('rFinal',' ',rFinal,nZeta*nTri0Elem(la)*nTri0Elem(lb),6) ! * !*********************************************************************** ! * return -contains - -pure function Ind(ly,lz) - use Index_util, only: iTri0 - integer(kind=iwp) :: Ind - integer(kind=iwp), intent(in) :: ly, lz - Ind = iTri0(ly+lz,lz) -end function Ind - end subroutine Assemble_PPGrd diff -Nru openmolcas-22.02/src/ppint_util/ppgrd.F90 openmolcas-22.10/src/ppint_util/ppgrd.F90 --- openmolcas-22.02/src/ppint_util/ppgrd.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ppint_util/ppgrd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -22,7 +22,7 @@ use Basis_Info, only: dbsc, nCnttp, Shells use Center_Info, only: dc use Symmetry_Info, only: iOper -use Index_util, only: nTri0Elem +use Index_Functions, only: nTri_Elem1 use Constants, only: Zero, One use Definitions, only: wp, iwp, u6 @@ -30,7 +30,7 @@ #include "grd_interface.fh" integer(kind=iwp), parameter :: lproju = 9, imax = 100, kcrs = 1 integer(kind=iwp) :: i, ia, iAlpha, ib, iBeta, iCar, iCmp, iCnttp, iDCRT(0:7), iExp, iIrrep, iOff, iplalbm, iplalbp, iplamlb, & - iplaplb, ipRef, iPrint, iRout, iSh, iStrt, iuvwx(4), iVec, iZeta, j, JndGrd(3,4), kCnt, kdc, kSh, kShEnd, & + iplaplb, ipRef, iPrint, iRout, iSh, iStrt, iuvwx(4), iVec, iZeta, JndGrd(3,4), kCnt, kdc, kSh, kShEnd, & kShStr, lcr(kcrs), lDCRT, LmbdT, lOp(4), mGrad, nArray, ncr(imax), ncrr, nDAO, nDCRT, nDisp, & nkcrl(lproju+1,kcrs), nkcru(lproju+1,kcrs), nlalbm, nlalbp, nlamlb, nlaplb, npot, nPP_S real(kind=wp) :: C(3), ccr(imax), Fact, TC(3), zcr(imax) @@ -47,9 +47,8 @@ unused_var(rKappa) unused_var(P) unused_var(nHer) -unused_var(Ccoor) +unused_var(Ccoor(1)) unused_var(nOrdOp) -unused_var(lOper) ! * !*********************************************************************** @@ -57,7 +56,7 @@ iRout = 122 iPrint = nPrint(iRout) -nDAO = nTri0Elem(la)*nTri0Elem(lb) +nDAO = nTri_Elem1(la)*nTri_Elem1(lb) iIrrep = 0 iuvwx(1) = dc(mdc)%nStab iuvwx(2) = dc(ndc)%nStab @@ -73,14 +72,14 @@ ! la+1, lb -nlaplb = max(nTri0Elem(la+1),nTri0Elem(lb))**2 +nlaplb = max(nTri_Elem1(la+1),nTri_Elem1(lb))**2 iplaplb = ipRef+2*nArray nArray = nArray+nlaplb ! la-1, lb if (la > 0) then - nlamlb = max(nTri0Elem(la-1),nTri0Elem(lb))**2 + nlamlb = max(nTri_Elem1(la-1),nTri_Elem1(lb))**2 else nlamlb = 0 end if @@ -89,14 +88,14 @@ ! la, lb+1 -nlalbp = max(nTri0Elem(la),nTri0Elem(lb+1))**2 +nlalbp = max(nTri_Elem1(la),nTri_Elem1(lb+1))**2 iplalbp = ipRef+2*nArray nArray = nArray+nlalbp ! la, lb-1 if (lb > 0) then - nlalbm = max(nTri0Elem(la),nTri0Elem(lb-1))**2 + nlalbm = max(nTri_Elem1(la),nTri_Elem1(lb-1))**2 else nlalbm = 0 end if @@ -176,12 +175,8 @@ iuvwx(3) = dc(kdc+kCnt)%nStab iuvwx(4) = dc(kdc+kCnt)%nStab - call ICopy(6,IndGrd,1,JndGrd,1) - do i=1,3 - do j=1,2 - JfGrad(i,j) = IfGrad(i,j) - end do - end do + JndGrd(:,1:2) = IndGrd + JfGrad(:,1:2) = IfGrad nDisp = IndDsp(kdc+kCnt,iIrrep) do iCar=0,2 @@ -202,10 +197,8 @@ JndGrd(iCar+1,3) = 0 end if end do - call ICopy(3,[0],0,JndGrd(1,4),1) - JfGrad(1,4) = .false. - JfGrad(2,4) = .false. - JfGrad(3,4) = .false. + JndGrd(:,4) = 0 + JfGrad(:,4) = .false. mGrad = 0 do iCar=1,3 do i=1,2 @@ -264,16 +257,16 @@ end do ! iBeta !AOM< - if (abs(Fact-One) > 1.0e-7_wp) call dscal_(nAlpha*nBeta*nTri0Elem(la)*nTri0Elem(lb)*mGrad,Fact,rFinal,1) + if (abs(Fact-One) > 1.0e-7_wp) call dscal_(nAlpha*nBeta*nTri_Elem1(la)*nTri_Elem1(lb)*mGrad,Fact,rFinal,1) !AOM> if (iPrint >= 99) then write(u6,*) ' Result in PPGrd' write(u6,*) JfGrad - do ia=1,nTri0Elem(la) - do ib=1,nTri0Elem(lb) + do ia=1,nTri_Elem1(la) + do ib=1,nTri_Elem1(lb) do iVec=1,mGrad write(Label,'(A,I2,A,I2,A)') ' rFinal(',ia,',',ib,')' - call RecPrt(Label,' ',rFinal(1,ia,ib,iVec),nAlpha,nBeta) + call RecPrt(Label,' ',rFinal(:,ia,ib,1,iVec),nAlpha,nBeta) end do end do end do diff -Nru openmolcas-22.02/src/ppint_util/ppint.F90 openmolcas-22.10/src/ppint_util/ppint.F90 --- openmolcas-22.02/src/ppint_util/ppint.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ppint_util/ppint.F90 2022-10-10 14:22:40.000000000 +0000 @@ -21,12 +21,11 @@ use Basis_Info, only: dbsc, nCnttp, Shells use Center_Info, only: dc -use Index_util, only: nTri0Elem +use Index_Functions, only: nTri_Elem1 use Constants, only: Zero use Definitions, only: wp, iwp, u6 implicit none -#define _USE_WP_ #include "int_interface.fh" integer(kind=iwp), parameter :: lproju = 9, imax = 100, kcrs = 1 integer(kind=iwp) :: iA, iAB, iAlpha, iB, iBeta, iCntr, iCnttp, iDCRT(0:7), iExp, intmax, iOff, iOff2, ipA, ipScr, iSh, iStrt, & @@ -53,17 +52,17 @@ ! * !*********************************************************************** ! * -call dcopy_(nZeta*nTri0Elem(la)*nTri0Elem(lb)*nIC,[Zero],0,Final,1) +call dcopy_(nZeta*nTri_Elem1(la)*nTri_Elem1(lb)*nIC,[Zero],0,rFinal,1) ! * !*********************************************************************** ! * nArray = 0 ipScr = 1 -intmax = max(nTri0Elem(la),nTri0Elem(lb)) +intmax = max(nTri_Elem1(la),nTri_Elem1(lb)) intmax = intmax**2 nArray = nArray+intmax ipA = ipScr+2*intmax -nArray = nArray+nZeta*nTri0Elem(la)*nTri0Elem(lb) +nArray = nArray+nZeta*nTri_Elem1(la)*nTri_Elem1(lb) if (nArray > nZeta*nArr) then write(u6,*) 'nArray > nZeta*nArr' call Abend() @@ -148,10 +147,10 @@ call Pseudo(Alpha(iAlpha),A(1),A(2),A(3),la+1,Beta(iBeta),RB(1),RB(2),RB(3),lb+1,Array(ipScr),intmax,max(la+1,lb+1),ccr, & zcr,nkcrl,nkcru,lcr,ncr,TC(1),TC(2),TC(3),npot) - do iB=1,nTri0Elem(lb) - do iA=1,nTri0Elem(la) - iAB = (iB-1)*nTri0Elem(la)+iA - iOff2 = (iB-1)*nTri0Elem(la)*nZeta+(iA-1)*nZeta+iZeta+ipA-1 + do iB=1,nTri_Elem1(lb) + do iA=1,nTri_Elem1(la) + iAB = (iB-1)*nTri_Elem1(la)+iA + iOff2 = (iB-1)*nTri_Elem1(la)*nZeta+(iA-1)*nZeta+iZeta+ipA-1 Array(iOff2) = Array(iAB+ipScr-1) end do ! iA end do ! iB @@ -164,7 +163,7 @@ ! Symmetry Adapt nOp = NrOpr(iDCRT(lDCRT)) - call SymAdO(Array(ipA),nZeta,la,lb,nComp,Final,nIC,nOp,lOper,iChO,Fact) + call SymAdO(Array(ipA),nZeta,la,lb,nComp,rFinal,nIC,nOp,lOper,iChO,Fact) end do ! lDCRT ! * !******************************************************************* diff -Nru openmolcas-22.02/src/ppint_util/ppmem.F90 openmolcas-22.10/src/ppint_util/ppmem.F90 --- openmolcas-22.02/src/ppint_util/ppmem.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ppint_util/ppmem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -14,11 +14,10 @@ # include "mem_interface.fh" ) -use Index_util, only: nTri0Elem +use Index_Functions, only: nTri_Elem1 use Definitions, only: iwp implicit none -#define _USE_WP_ #include "mem_interface.fh" integer(kind=iwp) :: intmax @@ -27,7 +26,7 @@ nHer = 0 Mem = 0 -intmax = max(nTri0Elem(la),nTri0Elem(lb)) +intmax = max(nTri_Elem1(la),nTri_Elem1(lb)) intmax = intmax**2 Mem = Mem+3*intmax diff -Nru openmolcas-22.02/src/ppint_util/ppmmg.F90 openmolcas-22.10/src/ppint_util/ppmmg.F90 --- openmolcas-22.02/src/ppint_util/ppmmg.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ppint_util/ppmmg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -14,11 +14,10 @@ # include "mem_interface.fh" ) -use Index_util, only: nTri0Elem +use Index_Functions, only: nTri_Elem1 use Definitions, only: iwp implicit none -#define _USE_WP_ #include "mem_interface.fh" integer(kind=iwp) :: lalbm, lalbp, lambl, lapbl @@ -28,21 +27,21 @@ nHer = 0 Mem = 0 -lapbl = max(nTri0Elem(la+1),nTri0Elem(lb))**2 +lapbl = max(nTri_Elem1(la+1),nTri_Elem1(lb))**2 Mem = Mem+2*lapbl if (la > 0) then - lambl = max(nTri0Elem(la-1),nTri0Elem(lb))**2 + lambl = max(nTri_Elem1(la-1),nTri_Elem1(lb))**2 else lambl = 0 end if Mem = Mem+2*lambl -lalbp = max(nTri0Elem(la),nTri0Elem(lb+1))**2 +lalbp = max(nTri_Elem1(la),nTri_Elem1(lb+1))**2 Mem = Mem+2*lalbp if (lb > 0) then - lalbm = max(nTri0Elem(la),nTri0Elem(lb-1))**2 + lalbm = max(nTri_Elem1(la),nTri_Elem1(lb-1))**2 else lalbm = 0 end if diff -Nru openmolcas-22.02/src/property_util/charge.F90 openmolcas-22.10/src/property_util/charge.F90 --- openmolcas-22.02/src/property_util/charge.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/property_util/charge.F90 2022-10-10 14:22:40.000000000 +0000 @@ -14,6 +14,7 @@ subroutine CHARGE(NSYM,NBAS,BNAME,CMO,OCCN,SMAT,iCase,FullMlk,lSave) +use SpinAV, only: Do_SpinAV, DSc use stdalloc, only: mma_allocate, mma_deallocate use Constants, only: Zero, One, Two, Half use Definitions, only: wp, iwp, u6, r8 @@ -55,7 +56,6 @@ !character(len=4), allocatable :: TLbl(:) !character(len=LenIn), allocatable :: LblCnt(:) #include "angtp.fh" -#include "spave.fh" #include "WrkSpc.fh" ! * @@ -467,7 +467,7 @@ end do if (DMN_SpinAV) then - DMN = DMN+xsg*Work(ip_DSc+(NY+IB-1)*NBAST+MY+IB-1) + DMN = DMN+xsg*DSc((NY-1)*NB+MY+IMO) end if if (DoBond) then diff -Nru openmolcas-22.02/src/property_util/CMakeLists.txt openmolcas-22.10/src/property_util/CMakeLists.txt --- openmolcas-22.02/src/property_util/CMakeLists.txt 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/property_util/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -54,6 +54,7 @@ rdvec_hdf5.F90 s2calc.F90 seek_n_destroy.F90 + spinav.F90 tpidx2orb.F90 tpidx2orb_sym.F90 tpidx2tpstr.F90 @@ -67,6 +68,7 @@ xprop.F90 ) +# Source files defining modules that should be available to other *_util directories set (modfile_list isotopes.F90 prppnt.F90 diff -Nru openmolcas-22.02/src/property_util/isotopes.F90 openmolcas-22.10/src/property_util/isotopes.F90 --- openmolcas-22.02/src/property_util/isotopes.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/property_util/isotopes.F90 2022-10-10 14:22:40.000000000 +0000 @@ -13,10 +13,6 @@ ! ! Isotope numbers and masses ! -! Taken from NIST: "Atomic Weights and Isotopic Compositions with -! Relative Atomic Masses" (https://www.nist.gov/pml/data/comp.cfm) -! Last updated: March 2017 (Version 4.1, July 2015) -! ! Each item in the the array ElementList contains data for an element: ! - %Symbol: symbol ! - %Natural: number of natural ocurring isotopes @@ -30,11 +26,6 @@ ! ! The "default" isotope for each element is simply the first item in ! the %Isotopes member. -! -! Manual changes from NIST data: -! - Definitive symbols for all elements -! - Most stable isotope (from Wikipedia) selected for Z > 94 -! - 3H and 14C included as natural module Isotopes diff -Nru openmolcas-22.02/src/property_util/molden_interface.F90 openmolcas-22.10/src/property_util/molden_interface.F90 --- openmolcas-22.02/src/property_util/molden_interface.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/property_util/molden_interface.F90 2022-10-10 14:22:40.000000000 +0000 @@ -826,7 +826,7 @@ ! * if (jPL >= 2) then write(u6,*) - write(u6,*) ' Input file to MOLDEN was generated!' + write(u6,'(6X,A)') 'Input file to MOLDEN was generated!' write(u6,*) end if ! * diff -Nru openmolcas-22.02/src/property_util/prop.F90 openmolcas-22.10/src/property_util/prop.F90 --- openmolcas-22.02/src/property_util/prop.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/property_util/prop.F90 2022-10-10 14:22:40.000000000 +0000 @@ -562,7 +562,11 @@ ! * !*********************************************************************** ! * -iTol = 5 +if (OpLab(1:3) == 'EF2') then + iTol = 4 +else + iTol = 5 +end if iTol_E0 = 8 iTol_E1 = Cho_X_GetTol(iTol_E0) iTol = int(real(iTol*iTol_E1,kind=wp)/real(iTol_E0,kind=wp)) diff -Nru openmolcas-22.02/src/property_util/prpt_.F90 openmolcas-22.10/src/property_util/prpt_.F90 --- openmolcas-22.02/src/property_util/prpt_.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/property_util/prpt_.F90 2022-10-10 14:22:40.000000000 +0000 @@ -259,7 +259,11 @@ if (nCen > 0) then ! set the tolerance according to the total number of centers ! (assuming error scales with sqrt(ncen)) - iTol = 5 + if (Label(1:3) == 'EF2') then + iTol = 4 + else + iTol = 5 + end if iTol = iTol-nint(Half*log10(real(nCen,kind=wp))) ! set MAG_X2C to avoid tests of electric field properties when ! wavefunction is X2C transformed (there is no way to tell but we diff -Nru openmolcas-22.02/src/property_util/prpt.F90 openmolcas-22.10/src/property_util/prpt.F90 --- openmolcas-22.02/src/property_util/prpt.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/property_util/prpt.F90 2022-10-10 14:22:40.000000000 +0000 @@ -127,7 +127,7 @@ Occ(:,:) = Zero var = .true. else - write(u6,*) 'Properties not supported for ',Method + write(u6,'(6X,2A)') 'Properties not supported for ',Method end if call Prpt_(nIrrep,nBas,nDim,Occ,n2Tot,Vec,var,Short,iUHF,ifallorb) diff -Nru openmolcas-22.02/src/property_util/spinav.F90 openmolcas-22.10/src/property_util/spinav.F90 --- openmolcas-22.02/src/property_util/spinav.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/property_util/spinav.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,24 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +module SpinAV + +use Definitions, only: wp, iwp + +implicit none +private + +logical(kind=iwp) :: Do_SpinAV=.FALSE. +real(kind=wp), allocatable :: DSc(:) + +public :: Do_SpinAV, DSc + +end module SpinAV diff -Nru openmolcas-22.02/src/qmstat/abboth.F90 openmolcas-22.10/src/qmstat/abboth.F90 --- openmolcas-22.02/src/qmstat/abboth.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/abboth.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,124 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! Routine for the case where both centres are diffuse. Since these +! formulas are pretty nasty and apparently with little general +! structure, each type of interaction is hard-coded. +subroutine ABBoth(iLA,iLB,dMulA,dKappa,Rho,RhoA,RhoB,Rinv,lTooSmall,Colle) + +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero, Two +use Definitions, only: wp, iwp, u6 + +! Maximum multipole implemented +#define _MxM_ 2 + +implicit none +integer(kind=iwp), intent(in) :: iLA, iLB +real(kind=wp), intent(in) :: dMulA(nTri_Elem1(_MxM_)), dKappa, Rho, RhoA, RhoB, Rinv +logical(kind=iwp), intent(in) :: lTooSmall +real(kind=wp), intent(out) :: Colle(3) +real(kind=wp) :: Ex, ExA, ExB, Pi1, Pi2, Sigma, Width +real(kind=wp), external :: CoulT0_1, CoulT0_2, CoulT0_4, CoulT0_5, CoulTN_1, CoulTN_2, CoulTN_4, CoulTN_5 +#include "warnings.h" + +! To calculate the interaction Sigma is the product of both multipoles +! in A and in B but since we need potential, field and field gradient +! for the QM system whe do not multiply for multipoles in B, but we +! have to take into account to move the result for the original +! coordinate system in QmStat. + +Colle(:) = Zero + +if ((iLA == 0) .and. (iLB == 0)) then + ! s-s interaction. There is only sigma-components, hence simple. + + Sigma = dMulA(1) + if (lTooSmall) then + Ex = exp(-Two*Rho) + Colle(1) = Sigma*CoulT0_1(Rho,Rinv,Ex) + else + ExA = exp(-Two*RhoA) + ExB = exp(-Two*RhoB) + Colle(1) = Sigma*CoulTN_1(RhoA,RhoB,dKappa,Rinv,ExA,ExB) + end if + +else if ((iLA == 1) .and. (iLB == 0)) then + ! s-p interaction. Only the z-component of the dipole interacts + ! through a sigma-interaction with the s-distribution. Observe + ! that in the case that iLA > iLB, then the formulas by Roothan + ! has to be reversed, i.e. RhoA and RhoB change place and + ! Kappa changes sign. + + Sigma = dMulA(3) + if (lTooSmall) then + Ex = exp(-Two*Rho) + Colle(1) = Sigma*CoulT0_2(Rho,Rinv,Ex) + else + ExA = exp(-Two*RhoA) + ExB = exp(-Two*RhoB) + Colle(1) = Sigma*CoulTN_2(RhoB,RhoA,-dKappa,Rinv,ExB,ExA) + end if +else if ((iLA == 0) .and. (iLB == 1)) then + Sigma = dMulA(1) + if (lTooSmall) then + Ex = exp(-Two*Rho) + Colle(1) = Sigma*CoulT0_2(Rho,Rinv,Ex) + else + ExA = exp(-Two*RhoA) + ExB = exp(-Two*RhoB) + Colle(1) = Sigma*CoulTN_2(RhoA,RhoB,dKappa,Rinv,ExA,ExB) + end if + +else if ((iLA == 1) .and. (iLB == 1)) then + ! p-p interaction. The z-z combination gives a sigma-interaction, + ! and the x-x and y-y combinations give pi-interactions. + + ! The sigma-component. + + Sigma = dMulA(3) + if (lTooSmall) then + Ex = exp(-Two*Rho) + Colle(1) = Sigma*CoulT0_4(Rho,Rinv,Ex) + else + ExA = exp(-Two*RhoA) + ExB = exp(-Two*RhoB) + Colle(1) = Sigma*CoulTN_4(RhoA,RhoB,dKappa,Rinv,ExA,ExB) + end if + + ! The two pi-components. + + Pi1 = dMulA(1) + Pi2 = dMulA(2) + if (lTooSmall) then + Ex = exp(-Two*Rho) + Width = CoulT0_5(Rho,Rinv,Ex) + Colle(2) = Pi1*Width + Colle(3) = Pi2*Width + else + ExA = exp(-Two*RhoA) + ExB = exp(-Two*RhoB) + Width = CoulTN_5(RhoA,RhoB,dKappa,Rinv,ExA,ExB) + Colle(2) = Pi1*Width + Colle(3) = Pi2*Width + end if + +else + ! Higher angular momentum interactions. + + write(u6,*) 'Too high angular momentum' + write(u6,*) 'at least you start to implement.' + call Quit(_RC_IO_ERROR_READ_) +end if + +return + +end subroutine ABBoth diff -Nru openmolcas-22.02/src/qmstat/abnone.F90 openmolcas-22.10/src/qmstat/abnone.F90 --- openmolcas-22.02/src/qmstat/abnone.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/abnone.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,95 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! All points. A bunch of special cases, see ABOne and ABBoth for more details. +subroutine ABNone(iLA,iLB,dMulA,Rinv,Colle) + +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero, Two, Three +use Definitions, only: wp, iwp + +! Maximum multipole implemented +#define _MxM_ 2 + +implicit none +integer(kind=iwp), intent(in) :: iLA, iLB +real(kind=wp), intent(in) :: dMulA(nTri_Elem1(_MxM_)), Rinv +real(kind=wp), intent(out) :: Colle(3) +real(kind=wp) :: d3, Pi1, Pi2, Sigma + +Colle(:) = Zero + +if (iLA == 0) then + if (iLB == 0) then + Sigma = dMulA(1) + Colle(1) = Sigma*Rinv + else if (iLB == 1) then + Sigma = dMulA(1) + Colle(1) = Sigma*Rinv**2 + else if (iLB == 2) then + Sigma = dMulA(1) + Colle(1) = Sigma*Rinv**3 + end if +else if (iLA == 1) then + if (iLB == 0) then + Sigma = dMulA(3) + Colle(1) = Sigma*Rinv**2 + else if (iLB == 1) then + Sigma = dMulA(3) + Pi1 = dMulA(1) + Pi2 = dMulA(2) + Colle(1) = Two*Sigma*(Rinv**3) + Colle(2) = Pi1*(Rinv**3) + Colle(3) = Pi2*(Rinv**3) + else if (iLB == 2) then + d3 = sqrt(Three) + Sigma = dMulA(3) + Pi1 = dMulA(1) + Pi2 = dMulA(2) + Colle(1) = Three*Sigma*(Rinv**4) + Colle(2) = d3*Pi1*(Rinv**4) + Colle(3) = d3*Pi2*(Rinv**4) + end if + +! Jose* This is for Quadrupoles in Classical. We do not use in QmStat. +!-------------------------------------- +!else if (iLA == 2) then +! if (iLB == 0) then +! Sigma = dMulA(3) +! Colle(1) = Sigma*Rinv**3 +! else if (iLB == 1) then +! d3 = sqrt(Three) +! Sigma = dMulA(3) +! Pi1 = dMulA(2) +! Pi2 = dMulA(4) +! Colle(1) = Three*Sigma*(Rinv**4) +! Colle(2) = d3*Pi1*(Rinv**4) +! Colle(3) = d3*Pi2*(Rinv**4) +! else if (iLB == 2) then +! Sigma = dMulA(3) +! Pi1 = dMulA(2) +! Pi2 = dMulA(4) +! ! Jose. Remember dMulB(1)=sqrt(3)*xy +! ! and dMulB(5)=Half*sqrt(3)*(x2-y2) +! Del1 = dMulA(1) +! Del2 = dMulA(5) +! Colle(1) = Six*Sigma*(Rinv**5) +! Colle(2) = Four*Pi1*(Rinv**5) +! Colle(3) = Four*Pi2*(Rinv**5) +! Colle(4) = Del1*(Rinv**5) +! Colle(5) = Del2*(Rinv**5) +! end if +!-------------------------------------- +end if + +return + +end subroutine ABNone diff -Nru openmolcas-22.02/src/qmstat/abone.F90 openmolcas-22.10/src/qmstat/abone.F90 --- openmolcas-22.02/src/qmstat/abone.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/abone.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,113 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! One diffuse, the other not diffuse. +subroutine ABOne(iLdiff,iLpoi,dMul,Ep,R,Rinv,Colle,lDiffA) + +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero, One, Two, Three, Four, Nine, OneHalf +use Definitions, only: wp, iwp, u6 + +! Maximum multipole implemented +#define _MxM_ 2 + +implicit none +integer(kind=iwp), intent(in) :: iLdiff, iLpoi +real(kind=wp), intent(in) :: dMul(nTri_Elem1(_MxM_)), Ep, R, Rinv +real(kind=wp), intent(out) :: Colle(3) +logical(kind=iwp), intent(in) :: lDiffA +real(kind=wp) :: DAMP, er, Ex, Pi1, Pi2, Sigma +real(kind=wp), parameter :: d3 = sqrt(Three) +#include "warnings.h" + +! The omnipresent exponential and distance-exponent product. + +er = Ep*R +Ex = exp(-Two*er) +Colle(:) = Zero + +if ((iLdiff == 0) .and. (iLpoi == 0)) then + ! s-s; see ABBoth for comments on sigma and similar below. + + Sigma = dMul(1) + DAMP = (One+er)*Ex + Colle(1) = Sigma*Rinv*(One-DAMP) + +else if ((iLdiff == 0) .and. (iLpoi == 1)) then + ! s-p + + Sigma = dMul(3) + if (lDiffA) then + Sigma = dMul(1) + end if + DAMP = (One+Two*er+Two*er**2)*Ex + Colle(1) = Sigma*Rinv**2*(One-DAMP) + +else if ((iLdiff == 0) .and. (iLpoi == 2)) then + ! s-d + + Sigma = dMul(3) + if (lDiffA) then + Sigma = dMul(1) + end if + DAMP = (One+Two*er+Two*er**2+Four*er**3/Three)*Ex + Colle(1) = Sigma*Rinv**3*(One-DAMP) + +else if ((iLdiff == 1) .and. (iLpoi == 0)) then + ! p-s + + Sigma = dMul(1) + if (lDiffA) then + Sigma = dMul(3) + end if + DAMP = (One+Two*er+Two*er**2+er**3)*Ex + Colle(1) = Sigma*Rinv**2*(One-DAMP) + +else if ((iLdiff == 1) .and. (iLpoi == 1)) then + ! p-p + + Sigma = dMul(3) + Pi1 = dMul(1) + Pi2 = dMul(2) + DAMP = (One+Two*er+Two*er**2+OneHalf*er**3+er**4)*Ex + Colle(1) = Two*Sigma*Rinv**3*(One-DAMP) + DAMP = (One+Two*er+Two*er**2+er**3)*Ex + Colle(2) = Pi1*Rinv**3*(One-DAMP) + Colle(3) = Pi2*Rinv**3*(One-DAMP) + +else if ((iLdiff == 1) .and. (iLpoi == 2)) then + ! p-d + + Sigma = dMul(3) + Pi1 = dMul(2) + Pi2 = dMul(4) + if (lDiffA) then + Pi1 = dMul(1) + Pi2 = dMul(2) + end if + DAMP = (One+Two*er+Two*er**2+Four*er**3/Three+Two*er**4/Three+Four*er**5/Nine)*Ex + Colle(1) = Three*Sigma*Rinv**4*(One-DAMP) + DAMP = (One+Two*er+Two*er**2+Four*er**3/Three+Two*er**4/Three)*Ex + Colle(2) = d3*Pi1*Rinv**4*(One-DAMP) + Colle(3) = d3*Pi2*Rinv**4*(One-DAMP) + !Colle = Colle1+Colle2+Colle3 + +else + ! Higher moments. + + write(u6,*) + write(u6,*) 'Too high momentum!' + call Quit(_RC_IO_ERROR_READ_) +end if + +return + +end subroutine ABOne diff -Nru openmolcas-22.02/src/qmstat/allenginsberg.f openmolcas-22.10/src/qmstat/allenginsberg.f --- openmolcas-22.02/src/qmstat/allenginsberg.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/allenginsberg.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,161 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine AllenGinsberg(QMMethod,Eint,Poli,dNuc,Cha,Dip,Qua - & ,MxBaux,iVEC,nDim,iExtr_Atm,lEig,iEig - & ,iQ_Atoms,ip_ExpCento,E_Nuc_Part - & ,lSlater,Eint_Nuc) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "numbers.fh" -#include "WrkSpc.fh" -#include "warnings.h" - - Dimension Eint(MxQCen,10),Poli(MxQCen,10) - Dimension Cha(MxBaux,MxQCen),Dip(MxBaux,3,MxQCen) - Dimension Qua(MxBaux,6,MxQCen),dNuc(MxAt) - Dimension iExtr_Atm(MxAt),Eint_Nuc(MxAt) - Dimension iCenSet(MxAt**2) - Character QMMethod*5 - Logical lEig,Check1,Check2,lSlater - -* -*-- Set up centre index set. The order of centres are decided by -* the MpProp-program and are hence collected in the get_center -* routine. -* -* -*-- Atom centres -* - Do 901, iAt=1,MxAt - If(iExtr_Atm(iAt).eq.-1) then - GoTo 902 - Else - iCenSet(iAt)=iExtr_Atm(iAt) - Endif -901 Continue - NExtrAt=iAt -902 Continue - NExtrAt=iAt-1 -* -*-- Bond centres -* - kaunter=iQ_Atoms - kaunt=NExtrAt - Do 905, iAt=2,iQ_Atoms - Do 906, jAt=1,iAt-1 - kaunter=kaunter+1 - Check1=.false. - Check2=.false. - Do 907, i1=1,NExtrAt - If(iAt.eq.iCenSet(i1)) Check1=.true. - If(jAt.eq.iCenSet(i1)) Check2=.true. -907 Continue - If(Check1.and.Check2) then - kaunt=kaunt+1 - iCenSet(kaunt)=kaunter - Endif -906 Continue -905 Continue -* -*-- A minor check. -* - NExpect=NExtrAt*(nExtrAt+1)/2 - NTotal=kaunt - If(NTotal.ne.NExpect) then - Write(6,*) - Write(6,*)' Error in atom specification for partial' - &//' perturbation extraction.' - Call Quit(_RC_GENERAL_ERROR_) - Endif - -* -*-- Compute partial nuclear contribution. -* - E_Nuc_Part=0.0d0 - Do 931, iAt=1,NExtrAt - iCx=iCenSet(iAt) - If(lSlater) then - E_Nuc_Part=E_Nuc_Part - & -(Eint_Nuc(iCx)+Poli(iCx,1))*dNuc(iCx) - Else - E_Nuc_Part=E_Nuc_Part - & -(Eint(iCx,1)+Poli(iCx,1))*dNuc(iCx) - Endif -931 Continue - -* -*-- Set up matrix elements for the partial perturbations. -* Compare with hel, helstate, polink and polins. -* - Call GetMem('VelPart','Allo','Real',iVelP,nDim*(nDim+1)/2) - Call GetMem('VpoPart','Allo','Real',iVpoP,nDim*(nDim+1)/2) - call dcopy_(nDim*(nDim+1)/2,[ZERO],iZERO,Work(iVelP),iONE) - call dcopy_(nDim*(nDim+1)/2,[ZERO],iZERO,Work(iVpoP),iONE) - kk=0 - Do 911, i=1,nDim - Do 912, j=1,i - kk=kk+1 - Do 913, k=1,NTotal - iCx=iCenSet(k) - dMp=Cha(kk,iCx) - Work(iVelP+kk-1)=Work(iVelP+kk-1)+Eint(iCx,1)*dMp - Work(iVpoP+kk-1)=Work(iVpoP+kk-1)+Poli(iCx,1)*dMp - dMp=Dip(kk,1,iCx) - Work(iVelP+kk-1)=Work(iVelP+kk-1)+Eint(iCx,2)*dMp - Work(iVpoP+kk-1)=Work(iVpoP+kk-1)+Poli(iCx,2)*dMp - dMp=Dip(kk,2,iCx) - Work(iVelP+kk-1)=Work(iVelP+kk-1)+Eint(iCx,3)*dMp - Work(iVpoP+kk-1)=Work(iVpoP+kk-1)+Poli(iCx,3)*dMp - dMp=Dip(kk,3,iCx) - Work(iVelP+kk-1)=Work(iVelP+kk-1)+Eint(iCx,4)*dMp - Work(iVpoP+kk-1)=Work(iVpoP+kk-1)+Poli(iCx,4)*dMp - dMp=Qua(kk,1,iCx) - Work(iVelP+kk-1)=Work(iVelP+kk-1)+Eint(iCx,5)*dMp - Work(iVpoP+kk-1)=Work(iVpoP+kk-1)+Poli(iCx,5)*dMp - dMp=Qua(kk,3,iCx) - Work(iVelP+kk-1)=Work(iVelP+kk-1)+Eint(iCx,7)*dMp - Work(iVpoP+kk-1)=Work(iVpoP+kk-1)+Poli(iCx,7)*dMp - dMp=Qua(kk,6,iCx) - Work(iVelP+kk-1)=Work(iVelP+kk-1)+Eint(iCx,10)*dMp - Work(iVpoP+kk-1)=Work(iVpoP+kk-1)+Poli(iCx,10)*dMp - dMp=Qua(kk,2,iCx) - Work(iVelP+kk-1)=Work(iVelP+kk-1)+Eint(iCx,6)*dMp*2.0d0 - Work(iVpoP+kk-1)=Work(iVpoP+kk-1)+Poli(iCx,6)*dMp*2.0d0 - dMp=Qua(kk,4,iCx) - Work(iVelP+kk-1)=Work(iVelP+kk-1)+Eint(iCx,8)*dMp*2.0d0 - Work(iVpoP+kk-1)=Work(iVpoP+kk-1)+Poli(iCx,8)*dMp*2.0d0 - dMp=Qua(kk,5,iCx) - Work(iVelP+kk-1)=Work(iVelP+kk-1)+Eint(iCx,9)*dMp*2.0d0 - Work(iVpoP+kk-1)=Work(iVpoP+kk-1)+Poli(iCx,9)*dMp*2.0d0 -913 Continue -912 Continue -911 Continue - -* -*-- Collect expectation value for the partial perturbation. -* - Call Expectus(QMMethod,Work(iVelP),Work(iVelP),Work(iVpoP) - & ,Work(iVpoP),MxBaux,iVEC,nDim,lEig,iEig - & ,ip_ExpCento) - -* -*-- Deallocate. -* - Call GetMem('VelPart','Free','Real',iVelP,nDim*(nDim+1)/2) - Call GetMem('VpoPart','Free','Real',iVpoP,nDim*(nDim+1)/2) - -* -*-- Howl -* - - Return - End diff -Nru openmolcas-22.02/src/qmstat/allenginsberg.F90 openmolcas-22.10/src/qmstat/allenginsberg.F90 --- openmolcas-22.02/src/qmstat/allenginsberg.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/allenginsberg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,130 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine AllenGinsberg(QMMethod,Eint,Poli,dNuc,Cha,Dip,Qua,VEC,nDim,lEig,iEig,iQ_Atoms,ExpCento,E_Nuc_Part,lSlater,Eint_Nuc) + +use qmstat_global, only: iExtr_Atm +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, Two +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +character(len=5), intent(in) :: QMMethod +integer(kind=iwp), intent(in) :: nDim, iEig, iQ_Atoms +real(kind=wp), intent(in) :: Eint(nTri_Elem(iQ_Atoms),10), Poli(nTri_Elem(iQ_Atoms),10), dNuc(iQ_Atoms), & + Cha(nTri_Elem(nDim),nTri_Elem(iQ_Atoms)), Dip(nTri_Elem(nDim),3,nTri_Elem(iQ_Atoms)), & + Qua(nTri_Elem(nDim),6,nTri_Elem(iQ_Atoms)), VEC(nDim,nDim), Eint_Nuc(iQ_Atoms) +logical(kind=iwp), intent(in) :: lEig, lSlater +real(kind=wp), intent(_OUT_) :: ExpCento(4,*) +real(kind=wp), intent(out) :: E_Nuc_Part +integer(kind=iwp) :: i, i1, iAt, iCx, j, jAt, k, kaunt, kaunter, kk, NExpect, NExtrAt, NTotal +logical(kind=iwp) :: Check1, Check2 +integer(kind=iwp), allocatable :: iCenSet(:) +real(kind=wp), allocatable :: VelP(:), VpoP(:) +#include "warnings.h" + +! Set up centre index set. The order of centres are decided by +! the MpProp-program and are hence collected in the get_center +! routine. + +! Atom centres + +NExtrAt = size(iExtr_Atm) + +call mma_allocate(iCenSet,NExtrAt+nTri_Elem(iQ_Atoms-1),label='iCenSet') +iCenSet(1:NExtrAt) = iExtr_Atm(1:NExtrAt) + +! Bond centres + +kaunter = iQ_Atoms +kaunt = NExtrAt +do iAt=2,iQ_Atoms + do jAt=1,iAt-1 + kaunter = kaunter+1 + Check1 = .false. + Check2 = .false. + do i1=1,NExtrAt + if (iAt == iCenSet(i1)) Check1 = .true. + if (jAt == iCenSet(i1)) Check2 = .true. + end do + if (Check1 .and. Check2) then + kaunt = kaunt+1 + iCenSet(kaunt) = kaunter + end if + end do +end do + +! A minor check. + +NExpect = NExtrAt*(nExtrAt+1)/2 +NTotal = kaunt +if (NTotal /= NExpect) then + write(u6,*) + write(u6,*) ' Error in atom specification for partial perturbation extraction.' + call Quit(_RC_GENERAL_ERROR_) +end if + +! Compute partial nuclear contribution. + +E_Nuc_Part = Zero +do iAt=1,NExtrAt + iCx = iCenSet(iAt) + if (lSlater) then + E_Nuc_Part = E_Nuc_Part-(Eint_Nuc(iCx)+Poli(iCx,1))*dNuc(iCx) + else + E_Nuc_Part = E_Nuc_Part-(Eint(iCx,1)+Poli(iCx,1))*dNuc(iCx) + end if +end do + +! Set up matrix elements for the partial perturbations. +! Compare with hel, helstate, polink and polins. + +call mma_allocate(VelP,nTri_Elem(nDim),label='VelPart') +call mma_allocate(VpoP,nTri_Elem(nDim),label='VpoPart') +VelP(:) = Zero +VpoP(:) = Zero +kk = 0 +do i=1,nDim + do j=1,i + kk = kk+1 + do k=1,NTotal + iCx = iCenSet(k) + VelP(kk) = VelP(kk)+Eint(iCx,1)*Cha(kk,iCx)+ & + Eint(iCx,2)*Dip(kk,1,iCx)+Eint(iCx,3)*Dip(kk,2,iCx)+Eint(iCx,4)*Dip(kk,3,iCx)+ & + Eint(iCx,5)*Qua(kk,1,iCx)+Eint(iCx,7)*Qua(kk,3,iCx)+Eint(iCx,10)*Qua(kk,6,iCx)+ & + Eint(iCx,6)*Qua(kk,2,iCx)*Two+Eint(iCx,8)*Qua(kk,4,iCx)*Two+Eint(iCx,9)*Qua(kk,5,iCx)*Two + VpoP(kk) = VpoP(kk)+Poli(iCx,1)*Cha(kk,iCx)+ & + Poli(iCx,2)*Dip(kk,1,iCx)+Poli(iCx,3)*Dip(kk,2,iCx)+Poli(iCx,4)*Dip(kk,3,iCx)+ & + Poli(iCx,5)*Qua(kk,1,iCx)+Poli(iCx,7)*Qua(kk,3,iCx)+Poli(iCx,10)*Qua(kk,6,iCx)+ & + Poli(iCx,6)*Qua(kk,2,iCx)*Two+Poli(iCx,8)*Qua(kk,4,iCx)*Two+Poli(iCx,9)*Qua(kk,5,iCx)*Two + end do + end do +end do + +call mma_deallocate(iCenSet) + +! Collect expectation value for the partial perturbation. + +call Expectus(QMMethod,VelP,VelP,VpoP,VpoP,VEC,nDim,lEig,iEig,ExpCento) + +! Deallocate. + +call mma_deallocate(VelP) +call mma_deallocate(VpoP) + +! Howl + +return + +end subroutine AllenGinsberg diff -Nru openmolcas-22.02/src/qmstat/analyze_q.f openmolcas-22.10/src/qmstat/analyze_q.f --- openmolcas-22.02/src/qmstat/analyze_q.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/analyze_q.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,124 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Analyze_Q(iQ_Atoms) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "files_qmstat.fh" -#include "qminp.fh" -#include "WrkSpc.fh" -#include "warnings.h" - - Parameter(iHUltraMax=1000) - Dimension iCo(3) - Dimension gR(MxAt,3,iHUltraMax) - Data Dum/0.0d0/ - Dimension iDum(1) - -*----------------------------------------------------------------------* -* Some numbers and defaults. * -*----------------------------------------------------------------------* - iHMax=0 - iCStart=(((iQ_Atoms-1)/nAtom)+1)*nCent+1 - iCNum=iCStart/nCent - dR=0.1d0 -*----------------------------------------------------------------------* -* Just say what we are doing. * -*----------------------------------------------------------------------* - Call NiceOutPut('AAA',Dum,Dum,Dum) -*----------------------------------------------------------------------* -* Open sampfile. Get some numbers about how many sampled etc. * -*----------------------------------------------------------------------* - Call DaName(iLuSaIn,SaFilIn) - iDiskSa=0 - Call iDaFile(iLuSaIn,2,iDum,1,iDiskSa) - iHowMSamp=iDum(1) - iDiskTemp=iDiskSa - Call WrRdSim(iLuSaIn,2,iDiskSa,iTCSim,64,Etot,Ract,nPart,Dum,Dum - & ,Dum) - iDiskSa=iDiskTemp -*----------------------------------------------------------------------* -* Say something about these numbers to the user. * -*----------------------------------------------------------------------* - Write(6,*) - Write(6,*)'The sampfile ',SaFilIn,' contains ',iHowMSamp,' sample' - &//'d configurations.' - Write(6,*)'Total number of particles:', nPart -*----------------------------------------------------------------------* -* BEGIN ANALYZING! * -*----------------------------------------------------------------------* - Do 101, iSamp=1,iHowMSamp -*----------------------------------------------------------------------* -* Begin by getting the coordinates for this configuration. They are * -* stored in Work(iCo(i)) where i=1 means x-coordinate, i=2 y-coordinate* -* and i=3 z-coordinate. * -*----------------------------------------------------------------------* - Call WrRdSim(iLuSaIn,2,iDiskSa,iTcSim,64,Etot,Ract,nPart,Dum - & ,Dum,Dum) - iDiskSa=iTcSim(1) - Do 1001, i=1,3 - Call GetMem('Coordinates','Allo','Real',iCo(i),nPart*nCent) - Call dDafile(iLuSaIn,2,Work(iCo(i)),nPart*nCent,iDiskSa) -1001 Continue -*----------------------------------------------------------------------* -* Once we have coordinates, lets compute some distances and start * -* building various distribution functions. * -*----------------------------------------------------------------------* - Do 111, i=1,iQ_Atoms - Do 112, j=1,nAtom - Do 113, k=1,nPart-iCNum - dist2=0.0d0 - Do 114, l=1,3 - ind=iCStart+(j-1)+(k-1)*nCent - dist2=dist2+(Work(iCo(l)+i-1)-Work(iCo(l)+ind-1))**2 -114 Continue - dist=sqrt(dist2) - iH=int((dist+dR*0.5d0)/dR) - if(iH.gt.iHMax) then - iHMax=iH - if(iH.gt.iHUltraMax) then - Write(6,*) - Write(6,*)'Too fine sections for g(r). Increase secti' - &//'on size or allocate more memory.' - Call Quit(_RC_INTERNAL_ERROR_) - Endif - Endif - gR(i,j,iH)=gR(i,j,iH)+1/dist2 -113 Continue -112 Continue -111 Continue -*----------------------------------------------------------------------* -* End loop over sampled configurations. * -*----------------------------------------------------------------------* - Do 1002, i=1,3 - Call GetMem('Coordinates','Free','Real',iCo(i),nPart*nCent) -1002 Continue -101 Continue -*----------------------------------------------------------------------* -* Time to generate a nice output. * -*----------------------------------------------------------------------* - Write(6,*) - Write(6,*)'SUMMARY OF RESULTS FOR SAMPFILE ANALYSIS.' - Write(6,*) - Do 9991, i=1,iQ_Atoms - Write(6,*) - Write(6,*)'Quantum atom ',i - Write(6,'(5X,A,5X,5(A,I2,1X))')'Separation' - & ,('Solvent atom',k,k=1,nAtom) - Do 9992, iH=1,iHMax - Write(6,'(F15.7,5(F15.7))')dR*iH,(gR(i,j,iH),j=1,nAtom) -9992 Continue -9991 Continue - - Call DaClos(iLuSaIn) - - Return - End diff -Nru openmolcas-22.02/src/qmstat/analyze_q.F90 openmolcas-22.10/src/qmstat/analyze_q.F90 --- openmolcas-22.02/src/qmstat/analyze_q.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/analyze_q.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,122 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Analyze_Q(iQ_Atoms) + +use qmstat_global, only: iLuSaIn, iTcSim, nAtom, nCent, nPart, SaFilIn +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Half +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iQ_Atoms +integer(kind=iwp) :: i, iCNum, iCStart, iDiskSa, iDiskTemp, iDum(1), iH, iHMax, iHowMSamp, ind, iSamp, j, k, l +real(kind=wp) :: dist, dist2, dR, Dum, Etot, Ract +real(kind=wp), allocatable :: Co(:,:), gR(:,:,:) +integer(kind=iwp), parameter :: iHUltraMax = 1000 +#include "warnings.h" + +Dum = Zero +!----------------------------------------------------------------------* +! Some numbers and defaults. * +!----------------------------------------------------------------------* +iHMax = 0 +iCStart = (((iQ_Atoms-1)/nAtom)+1)*nCent+1 +iCNum = iCStart/nCent +dR = 0.1_wp +!----------------------------------------------------------------------* +! Just say what we are doing. * +!----------------------------------------------------------------------* +call NiceOutPut('AAA') +!----------------------------------------------------------------------* +! Open sampfile. Get some numbers about how many sampled etc. * +!----------------------------------------------------------------------* +call DaName(iLuSaIn,SaFilIn) +iDiskSa = 0 +call iDaFile(iLuSaIn,2,iDum,1,iDiskSa) +iHowMSamp = iDum(1) +iDiskTemp = iDiskSa +call WrRdSim(iLuSaIn,2,iDiskSa,iTCSim,64,Etot,Ract,nPart,Dum,Dum,Dum) +iDiskSa = iDiskTemp +!----------------------------------------------------------------------* +! Say something about these numbers to the user. * +!----------------------------------------------------------------------* +write(u6,*) +write(u6,*) 'The sampfile ',SaFilIn,' contains ',iHowMSamp,' sampled configurations.' +write(u6,*) 'Total number of particles:',nPart +!----------------------------------------------------------------------* +! BEGIN ANALYZING! * +!----------------------------------------------------------------------* +call mma_allocate(gR,iQ_Atoms,nAtom,iHUltraMax,label='gR') +gR(:,:,:) = Zero +do iSamp=1,iHowMSamp + !--------------------------------------------------------------------* + ! Begin by getting the coordinates for this configuration. They are * + ! stored in Co(:,i) where i=1 means x-coordinate, i=2 y-coordinate * + ! and i=3 z-coordinate. * + !--------------------------------------------------------------------* + call WrRdSim(iLuSaIn,2,iDiskSa,iTcSim,64,Etot,Ract,nPart,Dum,Dum,Dum) + iDiskSa = iTcSim(1) + call mma_allocate(Co,nPart*nCent,3,label='Coordinates') + call dDafile(iLuSaIn,2,Co,3*nPart*nCent,iDiskSa) + !--------------------------------------------------------------------* + ! Once we have coordinates, lets compute some distances and start * + ! building various distribution functions. * + !--------------------------------------------------------------------* + do i=1,iQ_Atoms + do j=1,nAtom + do k=1,nPart-iCNum + dist2 = Zero + do l=1,3 + ind = iCStart+(j-1)+(k-1)*nCent + dist2 = dist2+(Co(i,l)-Co(ind,l))**2 + end do + dist = sqrt(dist2) + iH = int((dist+dR*Half)/dR) + if (iH > iHMax) then + iHMax = iH + if (iH > iHUltraMax) then + write(u6,*) + write(u6,*) 'Too fine sections for g(r). Increase section size or allocate more memory.' + call Quit(_RC_INTERNAL_ERROR_) + end if + end if + gR(i,j,iH) = gR(i,j,iH)+One/dist2 + end do + end do + end do + !--------------------------------------------------------------------* + ! End loop over sampled configurations. * + !--------------------------------------------------------------------* + call mma_deallocate(Co) +end do +!----------------------------------------------------------------------* +! Time to generate a nice output. * +!----------------------------------------------------------------------* +write(u6,*) +write(u6,*) 'SUMMARY OF RESULTS FOR SAMPFILE ANALYSIS.' +write(u6,*) +do i=1,iQ_Atoms + write(u6,*) + write(u6,*) 'Quantum atom ',i + write(u6,'(5X,A,5X,5(A,I2,1X))') 'Separation',('Solvent atom',k,k=1,nAtom) + do iH=1,iHMax + write(u6,'(F15.7,5(F15.7))') dR*iH,gR(i,:,iH) + end do +end do + +call mma_deallocate(gR) + +call DaClos(iLuSaIn) + +return + +end subroutine Analyze_Q diff -Nru openmolcas-22.02/src/qmstat/aointegrate.f openmolcas-22.10/src/qmstat/aointegrate.f --- openmolcas-22.02/src/qmstat/aointegrate.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/aointegrate.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,121 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine AOIntegrate(iCStart,nBaseQ,nBaseC,Ax,Ay,Az,nCnC_C - & ,iQ_Atoms,nAtomsCC,ipAOint,ipAOintpar,iV2,N,lmax - & ,Inside) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "integral.fh" -#include "WrkSpc.fh" -#include "lenin.fh" - - Dimension V2(MxBasC,MxOrb_C) - Dimension nCnC_C(MxBasC) - Dimension Sint(MxBas,MxBasC),SintPar(MxBas,MxBasC),Rot(3,3) - Dimension Inside(MxAt,3) - Character Snack*30,BsLbl*(LENIN8*MxBasC) - Logical PrEne,PrOcc,Inside - Dimension Dummy(1) - -*--------------------------------------------------------------------------* -* Call Transrot. There we compute the rotation matrix for the classical * -* water under consideration. Used later. * -*--------------------------------------------------------------------------* - Call TransRot(Cordst,N+1,Rot,Dx,Dy,Dz,Ax,Ay,Az) - If(iPrint.ge.17) then - Write(6,*) - Write(6,*)'ROTATION MATRIX, Molecule ',N/nCent - Write(6,*)(Rot(1,k),k=1,3) - Write(6,*)(Rot(2,k),k=1,3) - Write(6,*)(Rot(3,k),k=1,3) - Endif -*--------------------------------------------------------------------------* -* Call OrbRot2. Given the rotation matrix (Rot) and the original MO- * -* coefficients, we transform them to new MO-coefficients. V2 is on input * -* the original MO-coefficients (stored in V3), and on output the rotated. * -*--------------------------------------------------------------------------* - Do 5201, iOrS=1,iOrb(2) !Collect original MO-coeff. - Do 5202, iBaS=1,nBaseC - V2(iBaS,iOrS)=V3(iBaS,iOrS) -5202 Continue -5201 Continue - Call OrbRot2(Rot,V2,iQn,iOrb(2),lMax,nCnC_C) - kaunt=0 - Do 5211, iMO=1,iOrb(2) !Store the rotated in vector for - Do 5212, iBa=1,nBaseC !later convinience. - Work(iV2+kaunt)=V2(iBa,iMO) - kaunt=kaunt+1 -5212 Continue -5211 Continue - If(iPrint.ge.25) then !Optional print-out. - PrOcc=.false. - PrEne=.false. - Write(snack,'(A,I3)')'Rotated orbitals for water ',N/ncent - Call GetMem('PrCMO','Allo','Real',ipPPP,nBaseC*iOrb(2)) - kauntadetta=0 - Do 525, i=1,iOrb(2) - Do 526, j=1,nBaseC - Work(ipPPP+kauntadetta)=V2(j,i) - kauntadetta=kauntadetta+1 -526 Continue -525 Continue - Call NameRun('WRUNFIL') - Call Get_cArray('Unique Basis Names',BsLbl,LENIN8*nBaseC) - Call Primo(Snack,PrOcc,PrEne,Dummy(1),Dummy(1),1,[nBaseC] - & ,iOrb(2),BsLbl,Dummy,Dummy,Work(ipPPP),3) - Call GetMem('PrCMO','Free','Real',ipPPP,nBaseC*iOrb(2)) - Endif - Do 531, m=1,lMax !New basis function origo definied. - x=0 - y=0 - z=0 - Do 541, j=1,3 - x=x+Rot(1,j)*SavOri(j,m) - y=y+Rot(2,j)*SavOri(j,m) - z=z+Rot(3,j)*SavOri(j,m) -541 Continue - CasOri(1,m)=x+Dx - CasOri(2,m)=y+Dy - CasOri(3,m)=z+Dz -531 Continue -*----------------------------------------------------------------------* -* Compute overlap between the contracted basis functions on the water * -* molecule presently studied and the QM-molecule. * -*----------------------------------------------------------------------* - Do i=1,nBaseQ - Do j=1,nBaseC - Sint(i,j)=0 - SintPar(i,j)=0 - Enddo - Enddo - Call ContractOvl(Sint,SintPar,nBaseQ,nBaseC - & ,N,nCent,iEl,iQ_Atoms,nAtomsCC,iPrint,Inside) - !To be able to use the fast matrix multiplication routine DGEMM_, - !we have to put the Sint (and Sintpar) matrices in vector form. - !In the future we might 'cut out the middle-man' and already - !above put the overlap matrix in vector shape. - kaunt=0 - Do 547, iC=1,nBaseC - Do 548, iQ=1,nBaseQ - Work(ipAOint+kaunt)=Sint(iQ,iC) - kaunt=kaunt+1 -548 Continue -547 Continue - - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(iCStart) - Call Unused_integer(ipAOintpar) - End If - End diff -Nru openmolcas-22.02/src/qmstat/aointegrate.F90 openmolcas-22.10/src/qmstat/aointegrate.F90 --- openmolcas-22.02/src/qmstat/aointegrate.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/aointegrate.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,78 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine AOIntegrate(nBaseQ,nBaseC,Ax,Ay,Az,iQ_Atoms,nAtomsCC,AOint,oV2,N,lmax,Inside) + +use qmstat_global, only: CasOri, Cordst, iOrb, iPrint, iQn, nCent, nCnC_C, SavOri, V3 +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nBaseQ, nBaseC, iQ_Atoms, nAtomsCC, N, lmax +real(kind=wp), intent(in) :: Ax, Ay, Az +real(kind=wp), intent(out) :: AOint(nBaseQ,nBaseC), oV2(nBaseC,iOrb(2)) +logical(kind=iwp), intent(in) :: Inside(iQ_Atoms,nAtomsCC) +#include "Molcas.fh" +integer(kind=iwp) :: m +real(kind=wp) :: Dummy(1), Dx, Dy, Dz, Rot(3,3), x, y, z +logical(kind=iwp) :: PrEne, PrOcc +character(len=30) :: Snack +character(len=LenIn8), allocatable :: BsLbl(:) + +!----------------------------------------------------------------------* +! Call Transrot. There we compute the rotation matrix for the classical* +! water under consideration. Used later. * +!----------------------------------------------------------------------* +call TransRot(Cordst(:,N+1:N+3),N+1,Rot,Dx,Dy,Dz,Ax,Ay,Az) +if (iPrint >= 17) then + write(u6,*) + write(u6,*) 'ROTATION MATRIX, Molecule ',N/nCent + write(u6,*) Rot(1,:) +end if +!----------------------------------------------------------------------* +! Call OrbRot2. Given the rotation matrix (Rot) and the original MO- * +! coefficients, we transform them to new MO-coefficients. V2 is on * +! input the original MO-coefficients (stored in V3), and on output the * +! rotated. * +!----------------------------------------------------------------------* +! Collect original MO-coeff. +oV2(:,:) = V3 +call OrbRot2(Rot,oV2,iQn,iOrb(2),nBaseC,lMax,nCnC_C) +if (iPrint >= 25) then !Optional print-out. + PrOcc = .false. + PrEne = .false. + write(snack,'(A,I3)') 'Rotated orbitals for water ',N/nCent + call mma_allocate(BsLbl,nBaseC,label='BsLbl') + call NameRun('WRUNFIL') + call Get_cArray('Unique Basis Names',BsLbl,LenIn8*nBaseC) + Dummy(1) = Zero + call Primo(Snack,PrOcc,PrEne,Zero,Zero,1,[nBaseC],iOrb(2),BsLbl,Dummy,Dummy,oV2,3) + call mma_deallocate(BsLbl) +end if +do m=1,lMax !New basis function origo defined. + x = Rot(1,1)*SavOri(1,m)+Rot(1,2)*SavOri(2,m)+Rot(1,3)*SavOri(3,m) + y = Rot(2,1)*SavOri(1,m)+Rot(2,2)*SavOri(2,m)+Rot(2,3)*SavOri(3,m) + z = Rot(3,1)*SavOri(1,m)+Rot(3,2)*SavOri(2,m)+Rot(3,3)*SavOri(3,m) + CasOri(1,m) = x+Dx + CasOri(2,m) = y+Dy + CasOri(3,m) = z+Dz +end do +!----------------------------------------------------------------------* +! Compute overlap between the contracted basis functions on the water * +! molecule presently studied and the QM-molecule. * +!----------------------------------------------------------------------* +AOInt(:,:) = Zero +call ContractOvl(AOint,nBaseQ,nBaseC,N,nCent,iQ_Atoms,nAtomsCC,iPrint,Inside) + +return + +end subroutine AOIntegrate diff -Nru openmolcas-22.02/src/qmstat/avermep.f openmolcas-22.10/src/qmstat/avermep.f --- openmolcas-22.02/src/qmstat/avermep.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/avermep.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,302 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine AverMEP(Kword,Eint,Poli,ici,SumElcPot - & ,NCountField,PertElcInt - & ,iQ_Atoms,nBas,nOcc,natyp,nntyp) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "numbers.fh" -#include "qminp.fh" -#include "qm1.fh" -#include "qm2.fh" -#include "qmcom.fh" -#include "files_qmstat.fh" -#include "WrkSpc.fh" -#include "warnings.h" - Dimension Eint(MxQCen,10),Poli(MxQCen,10) - Dimension SumElcPot(MxQCen,10) - Dimension PertElcInt(MxBas*(MxBas+1)/2),SumOld(MxQCen,10) - Dimension iCent(MxBas*MxBas) - Dimension iMME(MxMltp*(MxMltp+1)*(MxMltp+2)/6) - Dimension nOcc(*),natyp(*),ForceNuc(MxAt,3) - - Character*4 Kword - Character*20 MemLab,MemLab1 - Logical Exist - Dimension iiDum(1) - - Call UpCase(Kword) -*************** -* This subroutine include three different options. All have to do with the -* calculation of a Mean Electrostatic Potential, Field and Field gradients, -* and to evalute the perturbation of them in the One electron Hamiltoniam -* this perturbation is added to the SEWARD One Electron File. -* Option 1: Add the components of Potential, etc -* Option 2: Obtain the Average -* Option 3: Calculate the electrostatic perturbation energy integrals -* and add them to the one-electron file. -* Calculation involve up to the field gradients because the charge density -* is expanded to the quadrupoles. If the expansion is bigger the number 10 -* must be changed, but also all the eqscf and eqras subroutines shoud be -* change in the last option the array nMlt is used instead of the -* number so if a smaller expantion is used, non problem, -* since this index take care of that. -****************** -* -*-- The keywords and their labels. -* - If(Kword(1:4).eq.'ADD ') Go To 101 - If(Kword(1:4).eq.'AVER') Go To 102 - If(Kword(1:4).eq.'PERT') Go To 103 - -101 Continue - Do 1001, i=1,iCi - Do 1002, j=1,10 !Charges (1),Dipoles(3),Quadrupoles(6) - SumOld(i,j)=SumElcPot(i,j) - SumElcPot(i,j)=SumOld(i,j)+Eint(i,j)+Poli(i,j) -1002 Continue -1001 Continue - If(iPrint.ge.9) then - Write(6,*)'Total Sum Potential' - Do 1010, i=1,iCi - Write(6,*)(SumElcPot(i,j),j=1,10) -1010 Continue - Endif - Go to 9999 - -102 Continue - Do 2001, i=1,iCi - Do 2002, j=1,10 !Charges (1),Dipoles(3),Quadrupoles(6) - AvElcPot(i,j)=SumElcPot(i,j)/Dble(NCountField) -2002 Continue -* -*-- The order of Field gradients is changed in order to follow -*-- the same order than Molcas -* - AvTemp=AvElcPot(i,8) ! This change is due to the - AvElcPot(i,8)=AvElcPot(i,7) ! different order of quadrupoles - AvElcPot(i,7)=AvTemp ! in QmStat and Molcas. -2001 Continue ! QmStat:xx,xy,yy,xz,yz,zz - ! Molcas:xx,xy,xz,yy,yz,zz - -******************************** -* This multiplication comes because the off-diagonal -* quadrupoles must be multiply by two since we use -* a triangular form to compute the Interaction -* Energy with the Electric Field Gradient. -* Since it is easier multiply the Average potential -* than the quadrupole for each pair of basis, we perform -* the multiplication here -*********************** - AvElcPot(i,6)=2.0d0*AvElcPot(i,6) - AvElcPot(i,7)=2.0d0*AvElcPot(i,7) - AvElcPot(i,9)=2.0d0*AvElcPot(i,9) -*********************** - If(iPrint.ge.9) then - Write(6,*)'Total Averg Potential' - Do 1020, i=1,iCi - Write(6,*)(AvElcPot(i,j),j=1,10) -1020 Continue - Endif - - Go to 9999 - - -103 Continue -* -*----First we read the multipoles expansion for each pair of basis. -*----The index iCent(i) will give us to which center belongs each pair of basis. -* - Call GetMem('Dummy','Allo','Inte',iDum,nBas**2) - Call MultiNew(iQ_Atoms,nBas,nOcc,natyp,nntyp,iMME - & ,iCent,iWork(iDum),nMlt,outxyz,SlExpQ,.false.) - Call GetMem('Dummy','Free','Inte',iDum,nBas**2) - - -********************** -* Calculate the forces for the nuclei -* these forces will compensate parcially -* the forces due to the electrons -* They will be printed and added to the -* RUNFILE in the optimization procedure -* after Alaska module -********************* -* This model do not work -* To calculate the forces in the nuclei -* with a Slater representation since -* you have to calculate the field -* in a set of point charges and not in -* distributed charges as the field is calculated -* when used Slater representation -* also there are a more dark and complicated -* problem about the string interaction keeping -* together the distributed electronic charge -* and the point nuclear charge under different -* forces. -********************** - Do 2030, i=1,iQ_Atoms - Do 2032, j=1,3 - ForceNuc(i,j)=ChaNuc(i)*AvElcPot(i,j+1) -2032 Continue -2030 Continue - iLuField=63 - iLuField=IsFreeUnit(iLuField) - Call OpnFl(FieldNuc,iLuField,Exist) - Write(6,*)'FieldNuc',FieldNuc - Do 2036, i=1,iQ_Atoms - Write(iLuField,*)(ForceNuc(i,j),j=1,3) -2036 Continue - Close(iLuField) - - If(iPrint.ge.9) then - Write(6,*)'Nuclei charge and Forces' - Do 1030, i=1,iQ_Atoms - Write(6,*)ChaNuc(i),(ForceNuc(i,j),j=1,3) -1030 Continue - Endif -********************* - - nTyp=0 - Do 3000, i=1,nMlt - nTyp=nTyp+i*(i+1)/2 -3000 Continue - Do 3001, i=1,(nBas*(nBas+1)/2) - PertElcInt(i)=0.0d0 -3001 Continue - -*-- Put quadrupoles in Buckinghamform. -* - Do 191, i1=1,nBas - Do 192, i2=1,i1 - indMME=i2+i1*(i1-1)/2 - Do 194, j=5,10 - Work(iMME(j)+indMME-1)= - & Work(iMME(j)+indMME-1)*1.5 -194 Continue - Tra=Work(iMME(5)+indMME-1) - & +Work(iMME(8)+indMME-1)+Work(iMME(10)+indMME-1) - Tra=Tra/3 - Work(iMME(5)+indMME-1)=Work(iMME(5)+indMME-1)-Tra - Work(iMME(8)+indMME-1)=Work(iMME(8)+indMME-1)-Tra - Work(iMME(10)+indMME-1)=Work(iMME(10)+indMME-1)-Tra -192 Continue -191 Continue - - - - irc=-1 - Lu_One=49 - Lu_One=IsFreeUnit(Lu_One) - Call OpnOne(irc,0,'ONEINT',Lu_One) - If(irc.ne.0) then - Write(6,*) - Write(6,*)'ERROR! Could not open one-electron integral file.' - Call Quit(_RC_IO_ERROR_READ_) - Endif - -* -*---We Read the size of the unperturbed Hamiltonian 'OneHam 0' in OneInt. -* - irc=-1 - iOpt=1 - iSmLbl=1 - nSize=0 - Call iRdOne(irc,iOpt,'OneHam 0',1,iiDum,iSmLbl) - nSize=iiDum(1) - If(irc.ne.0) then - Write(6,*) - Write(6,*)'ERROR! Failed to read number of one-electron i' - &//'ntegrals.' - Call Quit(_RC_IO_ERROR_READ_) - Endif - If(nSize.eq.0) then - Write(6,*) - Write(6,*)'ERROR! Problem reading size of unperturbed' - &//' Hamiltonian in OneInt' - Call Quit(_RC_IO_ERROR_READ_) - Endif - -*---Memory allocation for the unperturbed Hamiltonian - Write(MemLab,*)'MAver' - Call GetMem(MemLab,'Allo','Real',iH0,nSize+4) - irc=-1 - iOpt=0 - iSmLbl=0 - -*---Read the unperturbed Hamiltonian - Call RdOne(irc,iOpt,'OneHam 0',1 - & ,Work(iH0),iSmLbl) !Collect non perturbed integrals - Write(MemLab1,*)'MAver1' - Call GetMem(MemLab1,'Allo','Real',iH1,nSize+4) - If(iPrint.ge.9) then - Call TriPrt('Non Perturb One-e',' ',Work(iH0),nBas) - Endif -* - -*---We perform the multiplication for each pair of basis in a triangular form. -*---The perturbation is added to the unperturbed Hamiltonian 'iH0'. -* - kaunta=0 - Do 3003, iB1=1,nBas - Do 3004, iB2=1,iB1 - kaunta=kaunta+1 - indMME=iB2+iB1*(iB1-1)/2 - Do 3005, iTyp=1,nTyp - PertElcInt(indMME)=PertElcInt(indMME) - & +AvElcPot(iCent(kaunta),iTyp)*Work(iMME(iTyp)+indMME-1) -3005 Continue - Work(iH1+kaunta-1)=Work(iH0+kaunta-1)+PertElcInt(indMME) -3004 Continue -3003 Continue - - If(iPrint.ge.9) then - Call TriPrt('H0+Elec One-e',' ',Work(iH1),nBas) - Endif - -*---The non-Electrostatic perturbation is added. The PertNElcInt array comes -*---throught the include file qminp.fh. - - If(iPrint.ge.10) then - Call TriPrt('PertNElcInt-e',' ',PertNElcInt,nBas) - Endif - - iTriBasQ=nBas*(nBas+1)/2 - Call DaxPy_(iTriBasQ,ONE,PertNElcInt,iONE,Work(iH1),iONE) - - If(iPrint.ge.9) then - Call TriPrt('H0+Elec+nonEl One-e',' ',Work(iH1),nBas) - Endif - -*----The perturbed Hamiltonian 'H1' is writen in OneInt. - irc=-1 - iOpt=0 - iSmLbl=1 - Call WrOne(irc,iOpt,'OneHam ',1 - & ,Work(iH1),iSmLbl) !Write perturbed integrals - If(iPrint.ge.9) then - Call TriPrt('Perturb One-e',' ',Work(iH1),nBas) - Endif - - If(iPrint.ge.10) then - Call TriPrt('Non Perturb One-e AGAIN',' ',Work(iH0),nBas) - Endif - - Call ClsOne(irc,Lu_One) - - Call GetMem(MemLab,'Free','Real',iH0,nSize+4) - Call GetMem(MemLab1,'Free','Real',iH1,nSize+4) - - -9999 Continue - - Return - End diff -Nru openmolcas-22.02/src/qmstat/avermep.F90 openmolcas-22.10/src/qmstat/avermep.F90 --- openmolcas-22.02/src/qmstat/avermep.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/avermep.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,254 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine AverMEP(Kword,Eint,Poli,iCi,SumElcPot,NCountField,PertElcInt,iQ_Atoms,nBas,nOcc,natyp,nntyp) + +use qmstat_global, only: AvElcPot, ChaNuc, FieldNuc, iPrint, MxMltp, nMlt, outxyz, PertNElcInt +use Index_Functions, only: iTri, nTri3_Elem, nTri_Elem +use Data_Structures, only: Alloc1DArray_Type, Allocate_DT, Deallocate_DT +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, Two, Three, OneHalf +use Definitions, only: wp, iwp, u6 + +implicit none +character(len=4), intent(inout) :: Kword +integer(kind=iwp), intent(in) :: iCi, NCountField, iQ_Atoms, nBas, nntyp, nOcc(nntyp), natyp(nntyp) +real(kind=wp), intent(in) :: Eint(iCi,10), Poli(iCi,10) +real(kind=wp), intent(inout) :: SumElcPot(iCi,10) +real(kind=wp), intent(out) :: PertElcInt(nTri_Elem(nBas)) +integer(kind=iwp) :: i, i1, i2, iB1, iB2, iiDum(1), iLuField, indMME, iOpt, irc, iSmLbl, iTyp, j, kaunta, Lu_One, nSize, nTyp +real(kind=wp) :: Tra +logical(kind=iwp) :: Exists +integer(kind=iwp), allocatable :: Dum(:,:), iCent(:) +real(kind=wp), allocatable :: AvTemp(:), ForceNuc(:,:), H0(:), H1(:) +type(Alloc1DArray_Type), allocatable :: MME(:) +integer(kind=iwp), external :: IsFreeUnit +#include "warnings.h" + +call UpCase(Kword) +!************** +! This subroutine includes three different options. All have to do with the +! calculation of a Mean Electrostatic Potential, Field and Field gradients, +! and to evalute the perturbation of them in the One electron Hamiltoniam +! this perturbation is added to the SEWARD One Electron File. +! Option 1: Add the components of Potential, etc +! Option 2: Obtain the Average +! Option 3: Calculate the electrostatic perturbation energy integrals +! and add them to the one-electron file. +! Calculations involve up to the field gradients because the charge density +! is expanded to the quadrupoles. If the expansion is bigger the number 10 +! must be changed, but also all the eqscf and eqras subroutines shoud be +! changed. In the last option the array nMlt is used instead of the +! number so if a smaller expantion is used, non problem, +! since this index takes care of that. +!***************** + +select case (Kword(1:4)) + + case default !('ADD ') + do i=1,iCi + do j=1,10 !Charges(1),Dipoles(3),Quadrupoles(6) + SumElcPot(i,j) = SumElcPot(i,j)+Eint(i,j)+Poli(i,j) + end do + end do + if (iPrint >= 9) then + write(u6,*) 'Total Sum Potential' + do i=1,iCi + write(u6,*) SumElcPot(i,:) + end do + end if + + case ('AVER') + AvElcPot(:,:) = SumElcPot/real(NCountField,kind=wp) + + ! Charges (1),Dipoles(3),Quadrupoles(6) + + ! The order of Field gradients is changed in order to follow the same order than Molcas + ! This change is due to the different order of quadrupoles in QmStat and Molcas. + ! QmStat:xx,xy,yy,xz,yz,zz Molcas:xx,xy,xz,yy,yz,zz + call mma_allocate(AvTemp,iCi,label='AvTemp') + AvTemp(:) = AvElcPot(:,8) + AvElcPot(:,8) = AvElcPot(:,7) + AvElcPot(:,8) = AvTemp + call mma_deallocate(AvTemp) + + !******************************* + ! This multiplication comes because the off-diagonal + ! quadrupoles must be multiplied by two since we use + ! a triangular form to compute the Interaction + ! Energy with the Electric Field Gradient. + ! Since it is easier to multiply the Average potential + ! than the quadrupole for each pair of bases, we perform + ! the multiplication here + !********************** + AvElcPot(:,6) = Two*AvElcPot(:,6) + AvElcPot(:,7) = Two*AvElcPot(:,7) + AvElcPot(:,9) = Two*AvElcPot(:,9) + !********************** + if (iPrint >= 9) then + write(u6,*) 'Total Averg Potential' + do i=1,iCi + write(u6,*) AvElcPot(i,:) + end do + end if + + case ('PERT') + ! First we read the multipoles expansion for each pair of bases. + ! The index iCent(i) will give us to which center belongs each pair of bases. + + call mma_allocate(outxyz,3,nTri_Elem(iQ_Atoms),label='outxyz') + call mma_allocate(iCent,nTri_Elem(nBas),label='iCent') + call mma_allocate(Dum,nBas,nBas,label='Dummy') + call Allocate_DT(MME,[1,nTri3_Elem(MxMltp)],label='MME') + call MultiNew(iQ_Atoms,nBas,nOcc,natyp,nntyp,MME,iCent,Dum,nMlt,outxyz,.false.) + call mma_deallocate(Dum) + + !********************* + ! Calculate the forces for the nuclei these forces will compensate partially + ! the forces due to the electrons, They will be printed and added to the + ! RUNFILE in the optimization procedure after Alaska module + !******************** + ! This model does not work for calculating the forces in the nuclei + ! with a Slater representation since you have to calculate the field + ! in a set of point charges and not in distributed charges as the field + ! is calculated when used Slater representation also there is a more + ! dark and complicated problem about the string interaction keeping + ! together the distributed electronic charge and the point nuclear + ! charge under different forces. + !********************* + call mma_allocate(ForceNuc,3,iQ_Atoms,label='ForceNuc') + do i=1,iQ_Atoms + ForceNuc(:,i) = ChaNuc(i)*AvElcPot(i,2:4) + end do + iLuField = IsFreeUnit(63) + call OpnFl(FieldNuc,iLuField,Exists) + write(u6,*) 'FieldNuc',FieldNuc + do i=1,iQ_Atoms + write(iLuField,*) ForceNuc(:,i) + end do + close(iLuField) + + if (iPrint >= 9) then + write(u6,*) 'Nuclei charge and Forces' + do i=1,iQ_Atoms + write(u6,*) ChaNuc(i),ForceNuc(:,i) + end do + end if + call mma_deallocate(ForceNuc) + !******************** + + nTyp = 0 + do i=1,nMlt + nTyp = nTyp+nTri_Elem(i) + end do + PertElcInt(:) = Zero + + ! Put quadrupoles in Buckingham form. + + do i1=1,nBas + do i2=1,i1 + indMME = iTri(i1,i2) + do j=5,10 + MME(j)%A(indMME) = MME(j)%A(indMME)*OneHalf + end do + Tra = (MME(5)%A(indMME)+MME(8)%A(indMME)+MME(10)%A(indMME))/Three + MME(5)%A(indMME) = MME(5)%A(indMME)-Tra + MME(8)%A(indMME) = MME(8)%A(indMME)-Tra + MME(10)%A(indMME) = MME(10)%A(indMME)-Tra + end do + end do + + irc = -1 + Lu_One = IsFreeUnit(49) + call OpnOne(irc,0,'ONEINT',Lu_One) + if (irc /= 0) then + write(u6,*) + write(u6,*) 'ERROR! Could not open one-electron integral file.' + call Quit(_RC_IO_ERROR_READ_) + end if + + ! We read the size of the unperturbed Hamiltonian 'OneHam 0' in OneInt. + + irc = -1 + iOpt = 1 + iSmLbl = 1 + nSize = 0 + call iRdOne(irc,iOpt,'OneHam 0',1,iiDum,iSmLbl) + nSize = iiDum(1) + if (irc /= 0) then + write(u6,*) + write(u6,*) 'ERROR! Failed to read number of one-electron integrals.' + call Quit(_RC_IO_ERROR_READ_) + end if + if (nSize == 0) then + write(u6,*) + write(u6,*) 'ERROR! Problem reading size of unperturbed Hamiltonian in OneInt' + call Quit(_RC_IO_ERROR_READ_) + end if + + ! Memory allocation for the unperturbed Hamiltonian + call mma_allocate(H0,nSize,label='MAver') + irc = -1 + iOpt = 6 + iSmLbl = 0 + + ! Read the unperturbed Hamiltonian + call RdOne(irc,iOpt,'OneHam 0',1,H0,iSmLbl) !Collect non perturbed integrals + call mma_allocate(H1,nSize,label='MAver1') + if (iPrint >= 9) call TriPrt('Non Perturb One-e',' ',H0,nBas) + + ! We perform the multiplication for each pair of bases in a triangular form. + ! The perturbation is added to the unperturbed Hamiltonian 'H0'. + + kaunta = 0 + do iB1=1,nBas + do iB2=1,iB1 + kaunta = kaunta+1 + indMME = iTri(iB1,iB2) + do iTyp=1,nTyp + PertElcInt(indMME) = PertElcInt(indMME)+AvElcPot(iCent(kaunta),iTyp)*MME(iTyp)%A(indMME) + end do + H1(kaunta) = H0(kaunta)+PertElcInt(indMME) + end do + end do + call mma_deallocate(iCent) + call Deallocate_DT(MME) + + if (iPrint >= 9) call TriPrt('H0+Elec One-e',' ',H1,nBas) + + ! The non-Electrostatic perturbation is added. The PertNElcInt array comes + ! through the module qmstat_global + + if (iPrint >= 10) call TriPrt('PertNElcInt-e',' ',PertNElcInt,nBas) + + H1(:) = H1+PertNElcInt + + if (iPrint >= 9) call TriPrt('H0+Elec+nonEl One-e',' ',H1,nBas) + + ! The perturbed Hamiltonian 'H1' is writen in OneInt. + irc = -1 + iOpt = 0 + iSmLbl = 1 + call WrOne(irc,iOpt,'OneHam ',1,H1,iSmLbl) !Write perturbed integrals + if (iPrint >= 9) call TriPrt('Perturb One-e',' ',H1,nBas) + + if (iPrint >= 10) call TriPrt('Non Perturb One-e AGAIN',' ',H0,nBas) + + call ClsOne(irc,Lu_One) + + call mma_deallocate(H0) + call mma_deallocate(H1) + +end select + +return + +end subroutine AverMEP diff -Nru openmolcas-22.02/src/qmstat/boostrep.f openmolcas-22.10/src/qmstat/boostrep.f --- openmolcas-22.02/src/qmstat/boostrep.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/boostrep.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,81 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine BoostRep(AddRep,SmatPure,iVecs,nSize,InCutOff) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "numbers.fh" -#include "qminp.fh" -#include "WrkSpc.fh" - - Dimension SmatPure(*) - Logical InCutOff - -* -*-- Enter. -* -* -*-- Common section. -* - Scalar=0 -* -*-- Take different route for different QM-method. -* - If(QmType(1:3).eq.'SCF') then -* -*-- Repulsion term added to the Energy -*-- Calculated as S_i*S_i*CPsi_m* CPis_n -*-- S_i is the overlap integral (with the solvent molecule) -*-- for the occupied orbitals of the quantum system -*-- CPsi_m and CPsi_n are the transformation coeficients -*-- obtained from the diagonalization procedure of the Fock matrix -*-- to go from the original wavefunction to the final wavefunction -*-- after the SCF procedure. These coeficientes run over all basis set -* - Do 801, iO1=1,nSize - Do 802, iO2=1,nSize - Do 803, i=1,iOcc1 - kaunter=i*(i+1)/2 - ind1=nSize*(iO1-1)+i-1 - ind2=nSize*(iO2-1)+i-1 - Scalar=Scalar+(Work(iVecs+ind1)*Work(iVecs+ind2) - & *SmatPure(kaunter)) -803 Continue -802 Continue -801 Continue - AddRep=exrep4*abs(Scalar)**2+exrep6*abs(Scalar)**3 - & +exrep10*abs(Scalar)**5 - Elseif(QmType(1:4).eq.'RASS') then - Do 813, i=1,nSize - Do 814, j=1,nSize - If(i.ge.j) then - kaunter=i*(i+1)/2-i+j - Else - kaunter=j*(j+1)/2-j+i - Endif - ind1=nSize*(nEqState-1)+i-1 - ind2=nSize*(nEqState-1)+j-1 - Scalar=Scalar+Work(iVecs+ind1)*Work(iVecs+ind2) - & *SmatPure(kaunter) -814 Continue -813 Continue - AddRep=exrep4*abs(Scalar)**2+exrep6*abs(Scalar)**3 - & +exrep10*abs(Scalar)**5 - Endif - -* -*-- Crazy energy added if inner cut-off has been passed. Ensure reject. -* - If(InCutOff) AddRep=1D+20 - - - Return - End diff -Nru openmolcas-22.02/src/qmstat/boostrep.F90 openmolcas-22.10/src/qmstat/boostrep.F90 --- openmolcas-22.02/src/qmstat/boostrep.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/boostrep.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,73 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine BoostRep(AddRep,SmatPure,Vecs,nSize,InCutOff) + +use qmstat_global, only: exrep10, exrep4, exrep6, iOcc1, nEqState, QmType +use Index_Functions, only: iTri, nTri_Elem +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(out) :: AddRep +integer(kind=iwp), intent(in) :: nSize +real(kind=wp), intent(in) :: SmatPure(*), Vecs(nSize,nSize) +logical(kind=iwp), intent(in) :: InCutOff +integer(kind=iwp) :: i, iO1, iO2, j, kaunter +real(kind=wp) :: Scalar + +! Enter. + +! Common section. + +Scalar = Zero + +! Take different route for different QM-method. + +if (QmType(1:3) == 'SCF') then + + ! Repulsion term added to the Energy + ! Calculated as S_i*S_i*CPsi_m* CPis_n + ! S_i is the overlap integral (with the solvent molecule) + ! for the occupied orbitals of the quantum system + ! CPsi_m and CPsi_n are the transformation coefficients + ! obtained from the diagonalization procedure of the Fock matrix + ! to go from the original wavefunction to the final wavefunction + ! after the SCF procedure. These coeficientes run over all basis set + + do iO1=1,nSize + do iO2=1,nSize + do i=1,iOcc1 + kaunter = nTri_Elem(i) + Scalar = Scalar+(Vecs(i,iO1)*Vecs(i,iO2)*SmatPure(kaunter)) + end do + end do + end do + Scalar = abs(Scalar) + AddRep = exrep4*Scalar**2+exrep6*Scalar**3+exrep10*Scalar**5 +else if (QmType(1:4) == 'RASS') then + do i=1,nSize + do j=1,nSize + kaunter = iTri(i,j) + Scalar = Scalar+Vecs(i,nEqState)*Vecs(j,nEqState)*SmatPure(kaunter) + end do + end do + Scalar = abs(Scalar) + AddRep = exrep4*Scalar**2+exrep6*Scalar**3+exrep10*Scalar**5 +end if + +! Crazy energy added if inner cut-off has been passed. Ensure reject. + +if (InCutOff) AddRep = huge(AddRep) + +return + +end subroutine BoostRep diff -Nru openmolcas-22.02/src/qmstat/bornmayerbk.f openmolcas-22.10/src/qmstat/bornmayerbk.f --- openmolcas-22.02/src/qmstat/bornmayerbk.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/bornmayerbk.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,61 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine BornMayerBK(iQ_Atoms,BoMaH,BoMaO) -* -*-- With the Brdarski-Karlstrom scheme, construct the Born-Mayer -* parameters. -* - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" - - Dimension BoMaH(MxAt),BoMaO(MxAt) - Dimension rBdi(MxCen),rBdiQ(MxAt) - Parameter (cjhr=0.1734d0) - -* -*-- The solvent part. -* - Do 3, i=1,2 - rdi2=0 - Do 4, j=1,3 - rdi2=rdi2+quadi(j,i) -4 Continue - rBdi(i)=Sqrt(rdi2/charDi(i)) -3 Continue - -* -*-- The solute part. -* - Do 5, i=1,iQ_Atoms - rdi2=0 - Do 6, j=1,3 - rdi2=rdi2+QuadiQ(j,i) -6 Continue - rBdiQ(i)=Sqrt(rdi2/charDiQ(i)) -5 Continue - -* -*-- Put together. -* - Do 7,i=1,iQ_Atoms - BoMaH(i)=1/(cjhr*(RBdiQ(i)+rbdi(1))) - BoMaO(i)=1/(cjhr*(RBdiQ(i)+rbdi(2))) - If(iPrint.ge.8) then - Write(6,*)' Born-Mayer parameters.' - Write(6,'(A,i2,A,2(f12.4))')' Atom ',i,' (H/O):',BoMaH(i) - &,BoMaO(i) - Endif -7 Continue - - Return - End diff -Nru openmolcas-22.02/src/qmstat/bornmayerbk.F90 openmolcas-22.10/src/qmstat/bornmayerbk.F90 --- openmolcas-22.02/src/qmstat/bornmayerbk.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/bornmayerbk.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,63 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine BornMayerBK(iQ_Atoms,BoMaH,BoMaO) +! With the Brdarski-Karlstrom scheme, construct the Born-Mayer parameters. + +use qmstat_global, only: CharDi, CharDiQ, iPrint, QuaDi, QuaDiQ +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iQ_Atoms +real(kind=wp), intent(out) :: BoMaH(iQ_Atoms), BoMaO(iQ_Atoms) +integer(kind=iwp) :: i, j +real(kind=wp) :: rBdi(2), rdi2 +real(kind=wp), allocatable :: rBdiQ(:) +real(kind=wp), parameter :: cjhr = 0.1734_wp ! What is this number? + +! The solvent part. + +do i=1,2 + rdi2 = Zero + do j=1,3 + rdi2 = rdi2+QuaDi(j,i) + end do + rBdi(i) = sqrt(rdi2/CharDi(i)) +end do + +! The solute part. + +call mma_allocate(rBdiQ,iQ_Atoms,label='rBdiQ') +do i=1,iQ_Atoms + rdi2 = Zero + do j=1,3 + rdi2 = rdi2+QuaDiQ(j,i) + end do + rBdiQ(i) = sqrt(rdi2/CharDiQ(i)) +end do + +! Put together. + +BoMaH(:) = One/(cjhr*(RBdiQ(:)+rbdi(1))) +BoMaO(:) = One/(cjhr*(RBdiQ(:)+rbdi(2))) +if (iPrint >= 8) then + write(6,*) ' Born-Mayer parameters.' + do i=1,iQ_Atoms + write(6,'(A,i2,A,2(f12.4))') ' Atom ',i,' (H/O):',BoMaH(i),BoMaO(i) + end do +end if +call mma_deallocate(rBdiQ) + +return + +end subroutine BornMayerBK diff -Nru openmolcas-22.02/src/qmstat/chk_oneham.f openmolcas-22.10/src/qmstat/chk_oneham.f --- openmolcas-22.02/src/qmstat/chk_oneham.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/chk_oneham.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Chk_OneHam(nBas) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "WrkSpc.fh" - - Dimension nBas(MxSym) - Character Label_Read*8, Label_Pure*8 - - Lu_One=49 - Lu_One=IsFreeUnit(Lu_One) - Label_Read='OneHam ' - Label_Pure='OneHam 0' - nBT=nBas(1)*(nBas(1)+1)/2 - Call OpnOne(irc,0,'ONEINT',Lu_One) - Call GetMem('Read','Allo','Real',iOneR,nBT+4) - Call GetMem('Pure','Allo','Real',iOneP,nBT+4) - - irc=-1 - iopt=0 - iSmLbl=0 - Call RdOne(irc,iopt,Label_Read,1,Work(iOneR),iSmLbl) - irc=-1 - iopt=0 - iSmLbl=0 - Call RdOne(irc,iopt,Label_Pure,1,Work(iOneP),iSmLbl) - Call ClsOne(irc,Lu_One) - - Call DaxPy_(nBT,-1.0d0,Work(iOneR),1,Work(iOneP),1) - - dNorm=dnrm2_(nBT,Work(iOneP),1) - - If(dNorm.gt.1d-8) then - Write(6,*) - Write(6,*) - Write(6,*)' WARNING!' - Write(6,*) - Write(6,*)' Your one-electron hamiltonian is not purely' - &//' vacuum. This means that the Hamiltonian' - Write(6,*)' in QmStat can be contaminated. Is this' - &//' intentional? If not, then make sure that the ONEINT' - Write(6,*)' file comes directly from a Seward calculation' - &//' without any calls from' - Write(6,*)' FFPT (or similar) in between.' - Write(6,*) - Write(6,*) - Endif - - Call GetMem('Read','Free','Real',iOneR,nBT+4) - Call GetMem('Pure','Free','Real',iOneP,nBT+4) - - Return - End diff -Nru openmolcas-22.02/src/qmstat/chk_oneham.F90 openmolcas-22.10/src/qmstat/chk_oneham.F90 --- openmolcas-22.02/src/qmstat/chk_oneham.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/chk_oneham.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,66 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Chk_OneHam(nBas) + +use qmstat_global, only: MxSymQ +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp, u6, r8 + +implicit none +integer(kind=iwp), intent(in) :: nBas(MxSymQ) +integer(kind=iwp) :: iopt, irc, iSmLbl, Lu_One, nBT +real(kind=wp) :: dNorm +character(len=8) :: Label_Pure, Label_Read +real(kind=wp), allocatable :: OneP(:), OneR(:) +integer(kind=iwp), external :: IsFreeUnit +real(kind=r8), external :: dnrm2_ + +Lu_One = IsFreeUnit(49) +Label_Read = 'OneHam ' +Label_Pure = 'OneHam 0' +nBT = nTri_Elem(nBas(1)) +call OpnOne(irc,0,'ONEINT',Lu_One) +call mma_allocate(OneR,nBT,label='Read') +call mma_allocate(OneP,nBT,label='Pure') + +irc = -1 +iopt = 6 +iSmLbl = 0 +call RdOne(irc,iopt,Label_Read,1,OneR,iSmLbl) +irc = -1 +call RdOne(irc,iopt,Label_Pure,1,OneP,iSmLbl) +call ClsOne(irc,Lu_One) + +OneP(:) = OneP-OneR + +dNorm = dnrm2_(nBT,OneP,1) + +if (dNorm > 1.0e-8_wp) then + write(u6,*) + write(u6,*) + write(u6,*) ' WARNING!' + write(u6,*) + write(u6,*) ' Your one-electron hamiltonian is not purely vacuum. This means that the Hamiltonian' + write(u6,*) ' in QmStat can be contaminated. Is this intentional? If not, then make sure that the ONEINT' + write(u6,*) ' file comes directly from a Seward calculation without any calls from' + write(u6,*) ' FFPT (or similar) in between.' + write(u6,*) + write(u6,*) +end if + +call mma_deallocate(OneP) +call mma_deallocate(OneR) + +return + +end subroutine Chk_OneHam diff -Nru openmolcas-22.02/src/qmstat/ciselector.f openmolcas-22.10/src/qmstat/ciselector.f --- openmolcas-22.02/src/qmstat/ciselector.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/ciselector.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine CiSelector(nEqState,nState,iSTC,nCIRef,iCIInd,dCIRef) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "WrkSpc.fh" - - Dimension iCIInd(MxState) - Dimension dCIRef(MxState) - -* -*-- Initial stuff -* - dScalMAX=0.0d0 - indMAX=1 -* -*-- Compute relevant scalar products -* - Do 501, iState=1,nState - dScal=0.0d0 - Do 502, iRef=1,nCIRef - indBase=nState*(iState-1) - indx=indBase+iCIInd(iRef)-1 - dScal=dScal+Work(iSTC+indx)*dCIRef(iRef) -502 Continue - dScal=abs(dScal) -* -*---- Test if largest -* - If(dScal.gt.dScalMAX) then - dScalMAX=dScal - indMAX=iState - Endif -501 Continue - -* -*-- If maximum overlap is small, scream! -* - If(dScalMAX.lt.0.7071067811d0) then - Write(6,*) - Write(6,*)' WARNING! Less than 50% of CISElect reference' - &//'found. Consider to redefine reference!' - Endif - -* -*-- Now set nEqState -* - nEqState=indMAX - -* -*-- Auf Wiedersehen -* - Return - End diff -Nru openmolcas-22.02/src/qmstat/ciselector.F90 openmolcas-22.10/src/qmstat/ciselector.F90 --- openmolcas-22.02/src/qmstat/ciselector.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/ciselector.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,61 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine CiSelector(nEqState,nState,STC,nCIRef,iCIInd,dCIRef) + +use Constants, only: Zero, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(out) :: nEqState +integer(kind=iwp), intent(in) :: nState, nCIRef, iCIInd(nCIRef) +real(kind=wp), intent(in) :: STC(nState,nState), dCIRef(nCIRef) +integer(kind=iwp) :: indMAX, iRef, iState +real(kind=wp) :: dScal, dScalMAX + +! Initial stuff + +dScalMAX = Zero +indMAX = 1 + +! Compute relevant scalar products + +do iState=1,nState + dScal = Zero + do iRef=1,nCIRef + dScal = dScal+STC(iCIInd(iRef),iState)*dCIRef(iRef) + end do + dScal = abs(dScal) + + ! Test if largest + + if (dScal > dScalMAX) then + dScalMAX = dScal + indMAX = iState + end if +end do + +! If maximum overlap is small, scream! + +if (dScalMAX < sqrt(Half)) then + write(6,*) + write(6,*) ' WARNING! Less than 50% of CISElect reference found. Consider to redefine reference!' +end if + +! Now set nEqState + +nEqState = indMAX + +! Auf Wiedersehen + +return + +end subroutine CiSelector diff -Nru openmolcas-22.02/src/qmstat/clasclas.f openmolcas-22.10/src/qmstat/clasclas.f --- openmolcas-22.02/src/qmstat/clasclas.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/clasclas.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,300 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine ClasClas(iCNum,iCStart,ncParm,Coord,iFP,iGP,iDT,iFI - & ,iDist,iDistIm,Elene,Edisp,Exrep,E2Die,ExDie) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "qmcom.fh" -#include "WrkSpc.fh" - - Dimension iFP(3),iGP(3),iDT(3),iFI(3) - Dimension Coord(MxAt*3) - Character Memlabel*20,Memlaabe*20,Memlaaab*20,MemLaaaa*20,ChCo*2 - Parameter (ExLim=10) - -*----------------------------------------------------------------------* -* Compute the distance matrices between the classical centers and the * -* classical image centers. * -*----------------------------------------------------------------------* - nClas=nPart-iCNum - Adisp=Disp(1,2) - nSize=(nClas*(nClas-1)/2)*(nCent**2) !Get memory - Call GetMem('DistMat','Allo','Real',iDist,nSize) - nSizeIm=(nClas*nCent)**2 - Call GetMem('DistMatIm','Allo','Real',iDistIm,nSizeIm) - Ind=0 - Do 201, ii=iCNum+2,nPart - Do 202, jj=iCNum+1,ii-1 - Do 203, ij=1,nCent - i=(ii-1)*nCent+ij - Do 204, k=1,nCent - Ind=Ind+1 - j=(jj-1)*nCent+k - r=0 - Do 205, l=1,3 - r=(Cordst(i,l)-Cordst(j,l))**2+r -205 Continue - Work(iDist+Ind-1)=1/Sqrt(r) -204 Continue -203 Continue -202 Continue -201 Continue - Jnd=0 - Do 206, i=iCStart,nCent*nPart - Do 207, j=iCStart,nCent*nPart - Jnd=Jnd+1 - r=0 - Do 208, k=1,3 - r=(CordIm(i,k)-Cordst(j,k))**2+r -208 Continue - Work(iDistIm+Jnd-1)=1.0d0/Sqrt(r) -207 Continue -206 Continue -*----------------------------------------------------------------------* -* Compute the pairwise interaction between the solvent. Classical all * -* the way... early NEMO all the way. * -*----------------------------------------------------------------------* - Elene=0 - Edisp=0 - Exrep=0 - aLim=1.0d0/ExLim - Sum1=0 - Sum2=0 - Sum3=0 - Sum4=0 -*The electrostatic part - Do 2011, i=1,nSize,nCent**2 !This loop ONLY works for the - !early Nemo model of water. If the solvent - !model is changed this loop must be rewritten. - Sum1=Sum1+Work(iDist+i-1+6)*Qsta(1)*Qsta(1)!H-H - Sum2=Sum2+Work(iDist+i-1+7)*Qsta(1)*Qsta(2)!H-H - Sum3=Sum3+Work(iDist+i-1+8)*Qsta(1)*Qsta(3)!H-V - Sum4=Sum4+Work(iDist+i-1+9)*Qsta(1)*Qsta(4)!H-V - Sum1=Sum1+Work(iDist+i-1+11)*Qsta(2)*Qsta(1)!H-H - Sum2=Sum2+Work(iDist+i-1+12)*Qsta(2)*Qsta(2)!H-H - Sum3=Sum3+Work(iDist+i-1+13)*Qsta(2)*Qsta(3)!H-V - Sum4=Sum4+Work(iDist+i-1+14)*Qsta(2)*Qsta(4)!H-V - Sum1=Sum1+Work(iDist+i-1+18)*Qsta(3)*Qsta(3)!V-V - Sum2=Sum2+Work(iDist+i-1+19)*Qsta(3)*Qsta(4)!V-V - Sum3=Sum3+Work(iDist+i-1+16)*Qsta(3)*Qsta(1)!V-H - Sum4=Sum4+Work(iDist+i-1+17)*Qsta(3)*Qsta(2)!V-H - Sum1=Sum1+Work(iDist+i-1+23)*Qsta(4)*Qsta(3)!V-V - Sum2=Sum2+Work(iDist+i-1+24)*Qsta(4)*Qsta(4)!V-V - Sum3=Sum3+Work(iDist+i-1+21)*Qsta(4)*Qsta(1)!V-H - Sum4=Sum4+Work(iDist+i-1+22)*Qsta(4)*Qsta(2)!V-H -2011 Continue - Elene=Sum1+Sum2+Sum3+Sum4 - - Sum1=0 - Sum2=0 - Sum3=0 - Sum4=0 - Sum5=0 -*The dispersion, now with damping. - Do 211, i=1,nSize,nCent**2 - DampFunk=1-Exp(-1.0d0/(Work(iDist+i-1)*2.2677d0))**4 - Sum1=Sum1+Work(iDist+i-1)**6*DampFunk - DampFunk=1-Exp(-1.0d0/(Work(iDist+i-1+1)*2.2677d0))**4 - Sum2=Sum2+Work(iDist+i-1+1)**6*DampFunk - DampFunk=1-Exp(-1.0d0/(Work(iDist+i-1+2)*2.2677d0))**4 - Sum3=Sum3+Work(iDist+i-1+2)**6*DampFunk - DampFunk=1-Exp(-1.0d0/(Work(iDist+i-1+11)*2.2677d0))**4 - Sum4=Sum4+Work(iDist+i-1+11)**6*DampFunk - DampFunk=1-Exp(-1.0d0/(Work(iDist+i-1+7)*2.2677d0))**4 - Sum5=Sum5+Work(iDist+i-1+7)**6*DampFunk - DampFunk=1-Exp(-1.0d0/(Work(iDist+i-1+5)*2.2677d0))**4 - Sum2=Sum2+Work(iDist+i-1+5)**6*DampFunk - DampFunk=1-Exp(-1.0d0/(Work(iDist+i-1+10)*2.2677d0))**4 - Sum3=Sum3+Work(iDist+i-1+10)**6*DampFunk - DampFunk=1-Exp(-1.0d0/(Work(iDist+i-1+6)*2.2677d0))**4 - Sum4=Sum4+Work(iDist+i-1+6)**6*DampFunk - DampFunk=1-Exp(-1.0d0/(Work(iDist+i-1+12)*2.2677d0))**4 - Sum5=Sum5+Work(iDist+i-1+12)**6*DampFunk -211 Continue - Edisp=Sum1*Disp(1,1)+(Sum2+Sum3)*Disp(1,2)+(Sum4+Sum5)*Disp(2,2) -*The exchange repulsion - Do 221, i=1,nSize,nCent**2 - If(Work(iDist+i-1).gt.aLim) Exrep=Exrep+ - & ExNemo(1,1,Work(iDist+i-1)) - If(Work(iDist+i-1+1).gt.aLim) Exrep=Exrep+ - & ExNemo(1,2,Work(iDist+i-1+1)) - If(Work(iDist+i-1+2).gt.aLim) Exrep=Exrep+ - & ExNemo(1,2,Work(iDist+i-1+2)) - If(Work(iDist+i-1+5).gt.aLim) Exrep=Exrep+ - & ExNemo(1,2,Work(iDist+i-1+5)) - If(Work(iDist+i-1+6).gt.aLim) Exrep=Exrep+ - & ExNemo(2,2,Work(iDist+i-1+6)) - If(Work(iDist+i-1+7).gt.aLim) Exrep=Exrep+ - & ExNemo(2,2,Work(iDist+i-1+7)) - If(Work(iDist+i-1+10).gt.aLim) Exrep=Exrep+ - & ExNemo(1,2,Work(iDist+i-1+10)) - If(Work(iDist+i-1+11).gt.aLim) Exrep=Exrep+ - & ExNemo(2,2,Work(iDist+i-1+11)) - If(Work(iDist+i-1+12).gt.aLim) Exrep=Exrep+ - & ExNemo(2,2,Work(iDist+i-1+12)) -221 Continue -*----------------------------------------------------------------------* -* Compute pair-wise interaction with image charges. * -*----------------------------------------------------------------------* - Sum1=0.0d0 - Sum2=0.0d0 - Do 231, i=iCNum+1,nPart - Do 232, j=nCent-nCha+1,nCent !Only count over - !charged centers. - Q1=QIm((i-1)*nCent+j) !The image charge. - Inc=ncParm*nCent*(i-(iCNum+1))+(j-1)*ncParm !Counting - !elements. - Do 233, k=nCent-nCha+1,nCent - Inc2=Inc+k - Q2=QSta(k-nCent+nCha) - Do 234, l=iCNum+1,nPart !Here is the electrostatic - !interaction computed. Observe the difference with the real - !charges, since here interaction between ALL - !real-image charge pair is computed. - Sum1=Sum1+Q1*Q2*Work(iDistIm+Inc2+(l-(iCnum+1))*nCent-1) - Sum1=Sum1-Adisp*Work(iDistIm+Inc2+(l-(iCnum+1))*nCent-1)**6 - & *(1-Exp(-1/(Work(iDistIm+Inc2+(l-(iCnum+1))*nCent-1) - & *2.9677d0)**6)) -234 Continue -233 Continue -232 Continue -* Include a repulsion with the boundary to prevent the waters to merge -*into the dielectric continuum. Its construction is such that the -*repulsion only is between the particle and the image of the particle, -*no other repulsion over the boundary. - Sum2=Sum2+ExNemo(1,2,Work(iDistIm-1+(i-(iCNum+1)) - & *nClas*nCent**2 - & +(nClas+i-(iCNum+1))*nCent+2)) - Sum2=Sum2+ExNemo(1,2,Work(iDistIm-1+(i-(iCNum+1)) - & *nClas*nCent**2 - & +(2*nClas+i-(iCNum+1))*nCent+3)) - Sum2=Sum2+ExNemo(1,1,Work(iDistIm-1+(i-(iCNum+1)) - & *nClas*nCent**2 - & +1+(i-(iCNum+1))*nCent))*Exdt1 -231 Continue - E2Die=sum1*0.5d0 !The half is added since what we actually has - !computed is the interaction between charge and a part - !of its reaction field (recall:0.5*q*fi_q). - EXDie=sum2*0.5d0*ExdTal -*----------------------------------------------------------------------* -* Compute the static electric field on the polarizabilities and obtain * -* initial guess of induced dipoles. * -*----------------------------------------------------------------------* - IndMa=nPol*nPart - Do 300,i=1,3 !Allocate memory - Write(ChCo,'(I2.2)')i - Write(MemLabel,*)'FP'//ChCo - Write(MemLaabe,*)'GP'//ChCo - Write(MemLaaab,*)'DT'//ChCo - Write(MemLaaaa,*)'FI'//ChCo - !Explanation: iFP-field iGP plus reaction field, - ! iGP-field from real charges on polarizable centers, - ! iFi-induced field. - Call GetMem(MemLabel,'Allo','Real',iFP(i),IndMa) - Call GetMem(MemLaabe,'Allo','Real',iGP(i),IndMa) - Call GetMem(MemLaaab,'Allo','Real',iDT(i),IndMa) - Call GetMem(MemLaaaa,'Allo','Real',iFi(i),IndMa) -300 Continue - Do 302, j=1,3 - Do 301, i=0,Indma-1 !Set some zeros - Work(iFI(j)+i)=0.0d0 - Work(iGP(j)+i)=0.0d0 - Work(iDT(j)+i)=0.0d0 - Work(iFP(j)+i)=0.0d0 -301 Continue -302 Continue -*Real centers: The field at the polarizabilities - no reaction field. - Ind=0 - Do 310, ii=iCNum+2,nPart - Do 311, jj=iCNum+1,ii-1 - Do 312, ij=1,nCent - i=(ii-1)*nCent+ij - Do 313, l=1,nCent - j=(jj-1)*nCent+l - Ind=Ind+1 - X=Cordst(i,1)-Cordst(j,1) - Y=Cordst(i,2)-Cordst(j,2) - Z=Cordst(i,3)-Cordst(j,3) - ri=Work(iDist+Ind-1)**3 - If(ij.gt.(nCent-nCha).and.l.le.nPol) then - !Given that ij is - !counting on centers with charges and - !l on polarizable centers, then compute - !the field from charge ij on center l. - Q1=Qsta(ij-nCent+nCha) - Ind1=(jj-1)*nPol+l - Work(iGP(1)+Ind1-1)=Work(iGP(1)+Ind1-1)+x*Q1*ri - Work(iGP(2)+Ind1-1)=Work(iGP(2)+Ind1-1)+y*Q1*ri - Work(iGP(3)+Ind1-1)=Work(iGP(3)+Ind1-1)+z*Q1*ri - Endif - If(l.gt.(nCent-nCha).and.ij.le.nPol) then !If ij is - !on center with polarizability and l is on - !center with charge, then compute the field - !from charge l on center ij. - Q2=Qsta(l-nCent+nCha) - Ind1=(ii-1)*nPol+ij - Work(iGP(1)+Ind1-1)=Work(iGP(1)+Ind1-1)-x*Q2*ri - Work(iGP(2)+Ind1-1)=Work(iGP(2)+Ind1-1)-y*Q2*ri - Work(iGP(3)+Ind1-1)=Work(iGP(3)+Ind1-1)-z*Q2*ri - Endif -313 Continue -312 Continue -311 Continue -310 Continue - Epoll=0 - Do 320, i=1+nPol*iCNum,IndMa !Compute polarization energy. - !This is only for checking, and will - !not enter the energy expression. - k=i-((i-1)/nPol)*nPol - Work(iFP(1)+i-1)=Work(iGP(1)+i-1) - Work(iFP(2)+i-1)=Work(iGP(2)+i-1) - Work(iFP(3)+i-1)=Work(iGP(3)+i-1) - F=(Work(iFP(1)+i-1)**2+Work(iFP(2)+i-1)**2+Work(iFP(3)+i-1)**2) - & *Pol(k) - Epoll=Epoll+F -320 Continue - Epoll=-Epoll*0.5d0 -*Image centers: The field at the polarizabilities - reaction field to the -*point charges added. - Do 330, i=iCStart,nCent*nPart - Q=Qim(i) - Do 331, k=1,nPol - indSep=(i-iCStart)*nCent*(nPart-iCNum)+k - indR=k+iCNum*nCent - indF=k+iCNum*nPol - Do 332, j=nPol*(iCNum+1),IndMa,nPol - x=CordIm(i,1)-Cordst(indR,1) - y=CordIm(i,2)-Cordst(indR,2) - z=CordIm(i,3)-Cordst(indR,3) - r3=Work(iDistIm-1+indSep)**3 - Work(iFP(1)+indF-1)=Work(iFP(1)+indF-1)+x*Q*r3 - Work(iFP(2)+indF-1)=Work(iFP(2)+indF-1)+y*Q*r3 - Work(iFP(3)+indF-1)=Work(iFP(3)+indF-1)+z*Q*r3 - indR=indR+nCent - indSep=indSep+nCent - indF=indF+nPol -332 Continue -331 Continue -330 Continue -*We obtain an initial guess of the induced dipoles on the solvent. - Do 340, i=1+nPol*iCnum,IndMa - k=i-((i-1)/nPol)*nPol - Do 341, l=1,3 - Work(iDt(l)+i-1)=Work(iFP(l)+i-1)*Pol(k) -341 Continue -340 Continue - - Return -c Avoid unused argument warnings - If (.False.) Call Unused_real_array(Coord) - End diff -Nru openmolcas-22.02/src/qmstat/clasclas.F90 openmolcas-22.10/src/qmstat/clasclas.F90 --- openmolcas-22.02/src/qmstat/clasclas.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/clasclas.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,258 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ClasClas(iCNum,nClas,FP,GP,DT,FI,Dist,DistIm,Elene,Edisp,Exrep,E2Die,ExDie) + +use qmstat_global, only: CordIm, Cordst, Disp, Exdt1, ExdTal, nCent, nCha, nPart, nPol, Pol, QIm, QSta +use Index_Functions, only: nTri_Elem +use Constants, only: Zero, One, Ten, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iCNum, nClas +real(kind=wp), intent(out) :: FP(3,nPol*nPart), GP(3,nPol*nPart), DT(3,nPol*nPart), FI(3,nPol*nPart), & + Dist(nCent,nCent,nTri_Elem(nClas-1)), DistIm(nCent,nClas,nCent,nClas), Elene, Edisp, Exrep, E2Die, & + ExDie +integer(kind=iwp) :: i, ii, ij, Ind, Ind1, indF, IndMa, indR, j, jj, k, l, nSize +real(kind=wp) :: Adisp, aLim, Dampfunk, Epoll, F, Q, Q1, Q2, r, r3, ri, Sum1, Sum2, Sum3, Sum4, X, Y, Z +real(kind=wp), parameter :: Const = 2.2677_wp, ExLim = Ten ! What is Const? +real(kind=wp), external :: ExNemo + +!----------------------------------------------------------------------* +! Compute the distance matrices between the classical centers and the * +! classical image centers. * +!----------------------------------------------------------------------* +Adisp = Disp(1,2) +nSize = nTri_Elem(nClas-1) +Ind = 0 +do ii=iCNum+2,nPart + do jj=iCNum+1,ii-1 + Ind = Ind+1 + do ij=1,nCent + i = (ii-1)*nCent+ij + do k=1,nCent + j = (jj-1)*nCent+k + r = (Cordst(1,i)-Cordst(1,j))**2+(Cordst(2,i)-Cordst(2,j))**2+(Cordst(3,i)-Cordst(3,j))**2 + Dist(k,ij,Ind) = One/sqrt(r) + end do + end do + end do +end do +do ii=iCNum+1,nPart + do i=1,nCent + k = i+(ii-1)*nCent + do jj=iCNum+1,nPart + do j=1,nCent + l = j+(jj-1)*nCent + r = (CordIm(1,k)-Cordst(1,l))**2+(CordIm(2,k)-Cordst(2,l))**2+(CordIm(3,k)-Cordst(3,l))**2 + DistIm(j,jj-iCNum,i,ii-iCNum) = One/sqrt(r) + end do + end do + end do +end do +!----------------------------------------------------------------------* +! Compute the pairwise interaction between the solvent. Classical all * +! the way... early NEMO all the way. * +!----------------------------------------------------------------------* +aLim = One/ExLim +! The electrostatic part + +! This loop ONLY works for the early Nemo model of water. +! If the solvent model is changed this loop must be rewritten. +Sum1 = Zero +Sum2 = Zero +Sum3 = Zero +Sum4 = Zero +do i=1,nSize + Sum1 = Sum1+Dist(2,2,i)*Qsta(1)*Qsta(1) !H-H + Sum2 = Sum2+Dist(3,2,i)*Qsta(1)*Qsta(2) !H-H + Sum3 = Sum3+Dist(4,2,i)*Qsta(1)*Qsta(3) !H-V + Sum4 = Sum4+Dist(5,2,i)*Qsta(1)*Qsta(4) !H-V + Sum1 = Sum1+Dist(2,3,i)*Qsta(2)*Qsta(1) !H-H + Sum2 = Sum2+Dist(3,3,i)*Qsta(2)*Qsta(2) !H-H + Sum3 = Sum3+Dist(4,3,i)*Qsta(2)*Qsta(3) !H-V + Sum4 = Sum4+Dist(5,3,i)*Qsta(2)*Qsta(4) !H-V + Sum1 = Sum1+Dist(4,4,i)*Qsta(3)*Qsta(3) !V-V + Sum2 = Sum2+Dist(5,4,i)*Qsta(3)*Qsta(4) !V-V + Sum3 = Sum3+Dist(2,4,i)*Qsta(3)*Qsta(1) !V-H + Sum4 = Sum4+Dist(3,4,i)*Qsta(3)*Qsta(2) !V-H + Sum1 = Sum1+Dist(4,5,i)*Qsta(4)*Qsta(3) !V-V + Sum2 = Sum2+Dist(5,5,i)*Qsta(4)*Qsta(4) !V-V + Sum3 = Sum3+Dist(2,5,i)*Qsta(4)*Qsta(1) !V-H + Sum4 = Sum4+Dist(3,5,i)*Qsta(4)*Qsta(2) !V-H +end do +Elene = Sum1+Sum2+Sum3+Sum4 + +Sum1 = Zero +Sum2 = Zero +Sum3 = Zero +Sum4 = Zero +! The dispersion, now with damping. +do i=1,nSize + DampFunk = One-exp(-One/(Dist(1,1,i)*Const))**4 + Sum1 = Sum1+Dist(1,1,i)**6*DampFunk + DampFunk = One-exp(-One/(Dist(2,1,i)*Const))**4 + Sum2 = Sum2+Dist(2,1,i)**6*DampFunk + DampFunk = One-exp(-One/(Dist(3,1,i)*Const))**4 + Sum2 = Sum2+Dist(3,1,i)**6*DampFunk + DampFunk = One-exp(-One/(Dist(1,2,i)*Const))**4 + Sum2 = Sum2+Dist(1,2,i)**6*DampFunk + DampFunk = One-exp(-One/(Dist(2,2,i)*Const))**4 + Sum3 = Sum3+Dist(2,2,i)**6*DampFunk + DampFunk = One-exp(-One/(Dist(3,2,i)*Const))**4 + Sum3 = Sum3+Dist(3,2,i)**6*DampFunk + DampFunk = One-exp(-One/(Dist(1,3,i)*Const))**4 + Sum2 = Sum2+Dist(1,3,i)**6*DampFunk + DampFunk = One-exp(-One/(Dist(2,3,i)*Const))**4 + Sum3 = Sum3+Dist(2,3,i)**6*DampFunk + DampFunk = One-exp(-One/(Dist(3,3,i)*Const))**4 + Sum3 = Sum3+Dist(3,3,i)**6*DampFunk +end do +Edisp = Sum1*Disp(1,1)+Sum2*Disp(1,2)+Sum3*Disp(2,2) +!The exchange repulsion +Exrep = Zero +do i=1,nSize + if (Dist(1,1,i) > aLim) Exrep = Exrep+ExNemo(1,1,Dist(1,1,i)) + if (Dist(2,1,i) > aLim) Exrep = Exrep+ExNemo(1,2,Dist(2,1,i)) + if (Dist(3,1,i) > aLim) Exrep = Exrep+ExNemo(1,2,Dist(3,1,i)) + if (Dist(1,2,i) > aLim) Exrep = Exrep+ExNemo(1,2,Dist(1,2,i)) + if (Dist(2,2,i) > aLim) Exrep = Exrep+ExNemo(2,2,Dist(2,2,i)) + if (Dist(3,2,i) > aLim) Exrep = Exrep+ExNemo(2,2,Dist(3,2,i)) + if (Dist(1,3,i) > aLim) Exrep = Exrep+ExNemo(1,2,Dist(1,3,i)) + if (Dist(2,3,i) > aLim) Exrep = Exrep+ExNemo(2,2,Dist(2,3,i)) + if (Dist(3,3,i) > aLim) Exrep = Exrep+ExNemo(2,2,Dist(3,3,i)) +end do +!----------------------------------------------------------------------* +! Compute pair-wise interaction with image charges. * +!----------------------------------------------------------------------* +Sum1 = Zero +Sum2 = Zero +do i=iCNum+1,nPart + do j=nCent-nCha+1,nCent !Only count over charged centers. + Q1 = QIm((i-1)*nCent+j) !The image charge. + do k=nCent-nCha+1,nCent + Q2 = QSta(k-nCent+nCha) + ! Here is the electrostatic interaction computed. + ! Observe the difference with the real charges, + ! since here interaction between ALL real-image charge pair is computed. + do l=iCNum+1,nPart + Sum1 = Sum1+Q1*Q2*DistIm(k,l-iCNum,j,i-iCNum) + ! should this be Const=2.2677 ? + Sum1 = Sum1-Adisp*DistIm(k,l-iCNum,j,i-iCNum)**6*(One-exp(-One/(DistIm(k,l-iCNum,j,i-iCNum)*2.9677_wp)**6)) + end do + end do + end do + ! Include a repulsion with the boundary to prevent the waters to merge + ! into the dielectric continuum. Its construction is such that the + ! repulsion only is between the particle and the image of the particle, + ! no other repulsion over the boundary. + Sum2 = Sum2+ExNemo(1,1,DistIm(1,i-iCNum,1,i-iCNum))*Exdt1 + Sum2 = Sum2+ExNemo(1,2,DistIm(2,i-iCNum,2,i-iCNum)) + Sum2 = Sum2+ExNemo(1,2,DistIm(3,i-iCNum,3,i-iCNum)) +end do +! The half is added since what we actually have +! computed is the interaction between charge and a part +! of its reaction field (recall:0.5*q*fi_q). +E2Die = sum1*Half +EXDie = sum2*Half*ExdTal +!----------------------------------------------------------------------* +! Compute the static electric field on the polarizabilities and obtain * +! initial guess of induced dipoles. * +!----------------------------------------------------------------------* +IndMa = nPol*nPart +! Explanation: FP-field GP plus reaction field, +! GP-field from real charges on polarizable centers, +! FI-induced field. +FP(:,:) = Zero +GP(:,:) = Zero +DT(:,:) = Zero +FI(:,:) = Zero +! Real centers: The field at the polarizabilities - no reaction field. +Ind = 0 +do ii=iCNum+2,nPart + do jj=iCNum+1,ii-1 + Ind = Ind+1 + do ij=1,nCent + i = (ii-1)*nCent+ij + do l=1,nCent + j = (jj-1)*nCent+l + X = Cordst(1,i)-Cordst(1,j) + Y = Cordst(2,i)-Cordst(2,j) + Z = Cordst(3,i)-Cordst(3,j) + ri = Dist(l,ij,Ind)**3 + if ((ij > nCent-nCha) .and. (l <= nPol)) then + ! Given that ij is + ! counting on centers with charges and + ! l on polarizable centers, then compute + ! the field from charge ij on center l. + Q1 = Qsta(ij-nCent+nCha) + Ind1 = (jj-1)*nPol+l + GP(1,Ind1) = GP(1,Ind1)+x*Q1*ri + GP(2,Ind1) = GP(2,Ind1)+y*Q1*ri + GP(3,Ind1) = GP(3,Ind1)+z*Q1*ri + end if + if ((l > nCent-nCha) .and. (ij <= nPol)) then + ! If ij is + ! on center with polarizability and l is on + ! center with charge, then compute the field + ! from charge l on center ij. + Q2 = Qsta(l-nCent+nCha) + Ind1 = (ii-1)*nPol+ij + GP(1,Ind1) = GP(1,Ind1)-x*Q2*ri + GP(2,Ind1) = GP(2,Ind1)-y*Q2*ri + GP(3,Ind1) = GP(3,Ind1)-z*Q2*ri + end if + end do + end do + end do +end do +Epoll = Zero +! Compute polarization energy. +! This is only for checking, and will +! not enter the energy expression. +do i=1+nPol*iCNum,IndMa + k = i-((i-1)/nPol)*nPol + FP(:,i) = GP(:,i) + F = (FP(1,i)**2+FP(2,i)**2+FP(3,i)**2)*Pol(k) + Epoll = Epoll+F +end do +Epoll = -Epoll*Half +! Image centers: The field at the polarizabilities - reaction field to the point charges added. +do jj=iCNum+1,nPart + do ii=1,nCent + i = ii+(jj-1)*nCent + Q = Qim(i) + do k=1,nPol + indR = k+iCNum*nCent + indF = k+iCNum*nPol + do j=1,nClas + x = CordIm(1,i)-Cordst(1,indR) + y = CordIm(2,i)-Cordst(2,indR) + z = CordIm(3,i)-Cordst(3,indR) + r3 = DistIm(k,j,ii,jj-iCNum)**3 + FP(1,indF) = FP(1,indF)+x*Q*r3 + FP(2,indF) = FP(2,indF)+y*Q*r3 + FP(3,indF) = FP(3,indF)+z*Q*r3 + indR = indR+nCent + indF = indF+nPol + end do + end do + end do +end do +! We obtain an initial guess of the induced dipoles on the solvent. +do i=1+nPol*iCnum,IndMa + k = i-((i-1)/nPol)*nPol + DT(:,i) = FP(:,i)*Pol(k) +end do + +return + +end subroutine ClasClas diff -Nru openmolcas-22.02/src/qmstat/CMakeLists.txt openmolcas-22.10/src/qmstat/CMakeLists.txt --- openmolcas-22.02/src/qmstat/CMakeLists.txt 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -9,4 +9,110 @@ # LICENSE or in . * #*********************************************************************** +set (sources + main.F90 + abboth.F90 + abnone.F90 + abone.F90 + allenginsberg.F90 + analyze_q.F90 + aointegrate.F90 + avermep.F90 + boostrep.F90 + bornmayerbk.F90 + chk_oneham.F90 + ciselector.F90 + clasclas.F90 + contractovl.F90 + contrasbas.F90 + cooout.F90 + coult0_1.F90 + coult0_2.F90 + coult0_4.F90 + coult0_5.F90 + coultn_1.F90 + coultn_2.F90 + coultn_4.F90 + coultn_5.F90 + dcorrcorr.F90 + densi_mo.F90 + densist.F90 + dispenergy.F90 + editstart.F90 + eqras.F90 + eqscf.F90 + exnemo.F90 + expectus.F90 + exras.F90 + exscf.F90 + extract.F90 + extractr.F90 + extracts.F90 + fetchtdm.F90 + ffactor.F90 + geogen.F90 + get8.F90 + get9.F90 + get_centers.F90 + get_qmstat_input.F90 + get_slater.F90 + haveweconv.F90 + hel.F90 + helstate.F90 + idubfac.F90 + isitvalid.F90 + m2trans.F90 + mandatoryinp.F90 + mbpt2corr.F90 + moldendump.F90 + momentmod.F90 + moreduce.F90 + multinew.F90 + niceoutput.F90 + noverp_q.F90 + nypart.F90 + offatom.F90 + oneoverr.F90 + oneoverr_sl.F90 + orbrot2.F90 + overlq.F90 + pararoot.F90 + placeit9.F90 + placeit.F90 + planevectors.F90 + polink.F90 + polins.F90 + polprep.F90 + polras.F90 + polscf.F90 + polsolv.F90 + put8.F90 + put9.F90 + qfread.F90 + qmposition.F90 + qmstat.F90 + qmstat_global.F90 + qmstat_init.F90 + qmstat_procedures.F90 + rash0.F90 + rasrastrans.F90 + rassihandm.F90 + reaind.F90 + revolution.F90 + rotation_qmstat.F90 + scfh0.F90 + scfhandm.F90 + singp.F90 + sl_grad.F90 + spherical.F90 + sqtotri_q.F90 + statemmeao.F90 + statemme.F90 + statemmemo.F90 + tdmtrans.F90 + tkp.F90 + transrot.F90 + wrrdsim.F90 +) + include (${PROJECT_SOURCE_DIR}/cmake/prog_template.cmake) diff -Nru openmolcas-22.02/src/qmstat/contractovl.f openmolcas-22.10/src/qmstat/contractovl.f --- openmolcas-22.02/src/qmstat/contractovl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/contractovl.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,195 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) Anders Ohrn * -************************************************************************ -* ContractOvl -* -*> @brief -*> Compute the overlaps between solvent and solute in contracted basis-functions -*> @author A. Ohrn -*> -*> @details -*> Here the overlap between the QM-region contracted AO-basis -*> functions and the present solvent molecule contracted AO-basis -*> functions are computed. In order to use the fact that we use -*> contracted functions to the maximum, we compute the overlaps with -*> primitive functions only once, then we transform this matrix to -*> all relevant contracted overlaps. After that, the old primitive -*> integrals are discarded and a new set of primitive are computed. -*> This is very nice since ::OverLq is rather slow. The problems we -*> get are that we must use rather elaborate schemes to get right -*> digit in right place. -*> -*> @param[out] Sint The contracted basis function overlaps -*> @param[out] SintPar The contracted basis function overlaps with extra atom--atom weights *if* this has been requested by user, otherwise unchanged -*> @param[in] nBaseQ Number of AO-basis functions in QM-region -*> @param[in] nBaseC Like \p nBaseQ but for solvent -*> @param[in] N Which solvent molecule this is -*> @param[in] nCent How many centers the solvent molecule has -*> @param[in] iEl Number of elements in QM-region -*> @param[in] nAtomsCC How many solvent atoms -*> @param[in] iPrint Print level -************************************************************************ - Subroutine ContractOvl(Sint,SintPar,nBaseQ,nBaseC - &,N,nCent,iEl,iQ_Atoms,nAtomsCC,iPrint,Inside) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "integral.fh" -#include "WrkSpc.fh" - - Parameter(MxSphAng=2*MxAngqNr-1) - Dimension Sint(MxBas,MxBasC),SintPar(MxBas,MxBasC) - Dimension Bori(3),Cori(3),Alf(MxCont),Bet(MxCont) - Dimension Conkort(MxCont),Donkort(MxCont),ContrI(MxSphAng**2) - Dimension Inside(MxAt,3) - Logical Inside - - nSph1=0 - nSph2=0 - iQcontBSAV=0 - iCcontBSAV=0 - iQcontBSAV1=0 - iCcontBSAV1=0 - iQcontBSAV2=0 - iCcontBSAV2=0 - Do 11, iA1=1,iQ_Atoms !The atoms - Do 12, iA2=1,nAtomsCC - If(.not.Inside(iA1,iA2)) then !when atom-pair too far from - !each other, do this then skip. - iCcontBSAV=iCcontBSAV+nBonA_C(iA2) - iCcontBSAV1=iCcontBSAV - iCcontBSAV2=iCcontBSAV - If(iA2.eq.nAtomsCC) then - iQcontBSAV=iQcontBSAV+nBonA_Q(iA1) - iQcontBSAV1=iQcontBSAV - Endif - Go To 12 - Endif - Do 13, iB1=1,nBA_Q(iA1) !The basis functions on this specific - Do 14, iB2=1,nBA_C(iA2) !atom - iQcontB=iQcontBSAV - Do 15, iNcB1=1,nCBoA_Q(iA1,iB1) !The basis of angular - iQcontB=iQcontB+1 !type. - iCcontB=iCcontBSAV - Bori(1)=BasOri(1,iQcontB) !Suck-out proper coord - Bori(2)=BasOri(2,iQcontB) !for QM. - Bori(3)=BasOri(3,iQcontB) - iqqqQ=iQang(iQcontB) !Various integers, see qfread - nExp1=nPrimus(iQcontB) !to understand their meaning. - nSph1=2*iqqqQ-1 - Do 5411, i=1,nPrimus(iQcontB) !Suck-out the proper - Alf(i)=alfa(iQcontB,i) !exponents for QM-region - Conkort(i)=cont(iQcontB,i) -5411 Continue - Do 16, iNcB2=1,nCBoA_C(iA2,iB2) - iCcontB=iCcontB+1 - Cori(1)=CasOri(1,iCcontB) !Coord. of the atoms of - Cori(2)=CasOri(2,iCcontB) !this solvent mol. - Cori(3)=CasOri(3,iCcontB) - iqqqC=iQn(iCcontB) - nExp2=mPrimus(iCcontB) - nSph2=2*iqqqC-1 - Do 5412, j=1,mPrimus(iCcontB) !Exponents and stuff. - Bet(j)=beta(iCcontB,j) - Donkort(j)=dont(iCcontB,j) -5412 Continue -*------ Now call on the routine that computes a block of primitive -* integrals. So if we are integrating the np-mp overlap we -* compute ALL primitive p-p integrals, in the first call, then -* they are merely contracted. This is an economical procedure -* for both general and ordinary contracted basis sets since all -* primitve overlaps are needed at some point in the contracted -* overlaps, the difference between general and ordinary is that -* in the former primitve overlaps are needed at all instances, -* while in the latter primitve overlaps are needed only once. - If(iNcB1.eq.1.and.iNcB2.eq.1) then - Call OverLq(Bori,Cori,Alf,Bet,iqqqQ,iqqqC,nExp1 - & ,nExp2,iPSint,Trans) - Endif - kaunter=0 - Do 501, i=1,nSph2 !contract - Do 502, j=1,nSph1 - kaunter=kaunter+1 - DaNumber=0 - Do 503, iCC=1,nExp2 - Do 504, iCQ=1,nExp1 - iindex=(i-1)*nSph1*nExp1+j-1+nSph1*(iCQ-1) - & +nSph1*nExp1*nSph2*(iCC-1) - DaNumber=DaNumber+Conkort(iCQ)*Donkort(iCC) - & *Work(iPSint+iindex) -504 Continue -503 Continue - ContrI(kaunter)=DaNumber -502 Continue -501 Continue - If(iPrint.ge.30) then - Write(6,*)'Basis',iQcontB,iCcontB - Write(6,*)'Coord.',Bori(1),Bori(2),Bori(3) - Write(6,*)'Coord.',Cori(1),Cori(2),Cori(3) - Write(6,*)'Alfa',(Alf(i),i=1,nPrimus(iQcontB)) - Write(6,*)'Beta',(Bet(i),i=1,mPrimus(iCcontB)) - Write(6,*)'ConQ',(Conkort(i),i=1,nPrimus(iQcontB)) - Write(6,*)'ConC',(Donkort(i),i=1,mPrimus(iCcontB)) - Write(6,*)'Angular',iqqqQ,iqqqC - Write(6,*)'#primitive',nExp1,nExp2 - Write(6,*)(ContrI(k),k=1,nSph1*nSph2) - Endif - kreichner=0 - Do 5421, iC=1,nSph2 - Do 5422, iQ=1,nSph1 - kreichner=kreichner+1 - Sint(iWoGehenQ(iQcontB,iQ),iWoGehenC(iCcontB,iC))= - & ContrI(kreichner) -5422 Continue -5421 Continue -16 Continue -15 Continue - iCcontBSAV=iCcontB - !This vector is allocated in OverLq. - nSize=nExp1*nExp2*nSph1*nSph2 - Call GetMem('AllPrims','Free','Real',iPSint,nSize) -14 Continue - iQcontBSAV=iQcontB !OH NO!, these things have to do with - iCcontBSAV1=iCcontBSAV !getting the right number in right - iCcontBSAV=iCcontBSAV2 !place. This should probably be -13 Continue !changed sometime to a less cumbersome - iQcontBSAV1=iQcontBSAV !method. - iQcontBSAV=iQcontBSAV2 - iCcontBSAV2=iCcontBSAV1 - iCcontBSAV=iCcontBSAV1 -12 Continue - iQcontBSAV2=iQcontBSAV1 - iQcontBSAV=iQcontBSAV1 - iCcontBSAV=0 - iCcontBSAV1=0 - iCcontBSAV2=0 -11 Continue - If(iPrint.ge.30) then !Optional print-out. - Write(6,*) - Write(6,*)'OVERLAP BETWEEN QM-SYSTEM AND SOLVENT MOLECULE' - &,N/nCent - Write(6,*)'QM-AO SOLV-AO OVERLAP' - Do 545, i=1,nBaseQ - Do 546, j=1,nBaseC - Write(6,8888)i,j,Sint(i,j) -546 Continue -545 Continue - Endif -8888 Format(I3,' ',I3,' ',F12.10) - - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(SintPar) - Call Unused_integer(iEl) - End If - End diff -Nru openmolcas-22.02/src/qmstat/contractovl.F90 openmolcas-22.10/src/qmstat/contractovl.F90 --- openmolcas-22.02/src/qmstat/contractovl.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/contractovl.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,198 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) Anders Ohrn * +!*********************************************************************** +! ContractOvl +! +!> @brief +!> Compute the overlaps between solvent and solute in contracted basis-functions +!> @author A. Ohrn +!> +!> @details +!> Here the overlap between the QM-region contracted AO-basis +!> functions and the present solvent molecule contracted AO-basis +!> functions are computed. In order to use the fact that we use +!> contracted functions to the maximum, we compute the overlaps with +!> primitive functions only once, then we transform this matrix to +!> all relevant contracted overlaps. After that, the old primitive +!> integrals are discarded and a new set of primitive are computed. +!> This is very nice since ::OverLq is rather slow. The problems we +!> get are that we must use rather elaborate schemes to get right +!> digit in right place. +!> +!> @param[out] Sint The contracted basis function overlaps +!> @param[in] nBaseQ Number of AO-basis functions in QM-region +!> @param[in] nBaseC Like \p nBaseQ but for solvent +!> @param[in] N Which solvent molecule this is +!> @param[in] nCent How many centers the solvent molecule has +!> @param[in] iQ_Atoms +!> @param[in] nAtomsCC How many solvent atoms +!> @param[in] iPrint Print level +!> @param[in] Inside +!*********************************************************************** + +subroutine ContractOvl(Sint,nBaseQ,nBaseC,N,nCent,iQ_Atoms,nAtomsCC,iPrint,Inside) + +use qmstat_global, only: Alfa, BasOri, Beta, CasOri, Cont, Dont, iQang, iQn, iWoGehenC, iWoGehenQ, mPrimus, MxAngqNr, nBA_C, & + nBA_Q, nBonA_C, nBonA_Q, nCBoA_C, nCBoA_Q, nPrimus +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: nBaseQ, nBaseC, N, nCent, iQ_Atoms, nAtomsCC, iPrint +real(kind=wp), intent(_OUT_) :: Sint(nBaseQ,nBaseC) +logical(kind=iwp), intent(in) :: Inside(iQ_Atoms,nAtomsCC) +integer(kind=iwp) :: i, iA1, iA2, iB1, iB2, iC, iCC, iCcontB, iCcontBSAV, iCcontBSAV1, iCcontBSAV2, iCQ, iNcB1, iNcB2, iQ, & + iQcontB, iQcontBSAV, iQcontBSAV1, iQcontBSAV2, iqqqC, iqqqQ, j, kaunter, kreichner, nExp1, nExp2, nSph1, nSph2 +real(kind=wp) :: Bori(3), Cori(3), DaNumber +real(kind=wp), allocatable :: Alf(:), Bet(:), Conkort(:), ContrI(:), Donkort(:), PSint(:,:,:,:) + +call mma_allocate(Alf,size(Alfa,2),label='Alf') +call mma_allocate(Bet,size(Beta,2),label='Bet') +call mma_allocate(Conkort,size(Cont,2),label='Conkort') +call mma_allocate(Donkort,size(Dont,2),label='Donkort') +call mma_allocate(ContrI,(2*MxAngqNr-1)**2,label='ContrI') + +nSph1 = 0 +nSph2 = 0 +iQcontBSAV = 0 +iCcontBSAV = 0 +iQcontBSAV1 = 0 +iCcontBSAV1 = 0 +iQcontBSAV2 = 0 +iCcontBSAV2 = 0 +do iA1=1,iQ_Atoms !The atoms + do iA2=1,nAtomsCC + if (.not. Inside(iA1,iA2)) then !when atom-pair too far from each other, do this then skip. + iCcontBSAV = iCcontBSAV+nBonA_C(iA2) + iCcontBSAV1 = iCcontBSAV + iCcontBSAV2 = iCcontBSAV + if (iA2 == nAtomsCC) then + iQcontBSAV = iQcontBSAV+nBonA_Q(iA1) + iQcontBSAV1 = iQcontBSAV + end if + cycle + end if + do iB1=1,nBA_Q(iA1) !The basis functions on this specific atom + do iB2=1,nBA_C(iA2) + iQcontB = iQcontBSAV + do iNcB1=1,nCBoA_Q(iA1,iB1) !The basis of angular type. + iQcontB = iQcontB+1 + iCcontB = iCcontBSAV + Bori(:) = BasOri(:,iQcontB) !Suck-out proper coord for QM. + iqqqQ = iQang(iQcontB) !Various integers, see qfread to understand their meaning. + nExp1 = nPrimus(iQcontB) + nSph1 = 2*iqqqQ-1 + ! Suck-out the proper exponents for QM-region + Alf(1:nPrimus(iQcontB)) = alfa(iQcontB,1:nPrimus(iQcontB)) + Conkort(1:nPrimus(iQcontB)) = cont(iQcontB,1:nPrimus(iQcontB)) + do iNcB2=1,nCBoA_C(iA2,iB2) + iCcontB = iCcontB+1 + Cori(:) = CasOri(:,iCcontB) !Coord. of the atoms of this solvent mol. + iqqqC = iQn(iCcontB) + nExp2 = mPrimus(iCcontB) + nSph2 = 2*iqqqC-1 + ! Exponents and stuff. + Bet(1:mPrimus(iCcontB)) = beta(iCcontB,1:mPrimus(iCcontB)) + Donkort(1:mPrimus(iCcontB)) = dont(iCcontB,1:mPrimus(iCcontB)) + ! Now call on the routine that computes a block of primitive + ! integrals. So if we are integrating the np-mp overlap we + ! compute ALL primitive p-p integrals, in the first call, then + ! they are merely contracted. This is an economical procedure + ! for both general and ordinary contracted basis sets since all + ! primitive overlaps are needed at some point in the contracted + ! overlaps, the difference between general and ordinary is that + ! in the former primitive overlaps are needed at all instances, + ! while in the latter primitive overlaps are needed only once. + if ((iNcB1 == 1) .and. (iNcB2 == 1)) then + call mma_allocate(PSint,nSph1,nExp1,nSph2,nExp2,label='AllPrims') + call OverLq(Bori,Cori,Alf,Bet,iqqqQ,iqqqC,nExp1,nExp2,PSint) + end if + kaunter = 0 + do i=1,nSph2 !contract + do j=1,nSph1 + kaunter = kaunter+1 + DaNumber = Zero + do iCC=1,nExp2 + do iCQ=1,nExp1 + DaNumber = DaNumber+Conkort(iCQ)*Donkort(iCC)*PSint(j,iCQ,i,iCC) + end do + end do + ContrI(kaunter) = DaNumber + end do + end do + if (iPrint >= 30) then + write(u6,*) 'Basis',iQcontB,iCcontB + write(u6,*) 'Coord.',Bori(1),Bori(2),Bori(3) + write(u6,*) 'Coord.',Cori(1),Cori(2),Cori(3) + write(u6,*) 'Alfa',(Alf(i),i=1,nPrimus(iQcontB)) + write(u6,*) 'Beta',(Bet(i),i=1,mPrimus(iCcontB)) + write(u6,*) 'ConQ',(Conkort(i),i=1,nPrimus(iQcontB)) + write(u6,*) 'ConC',(Donkort(i),i=1,mPrimus(iCcontB)) + write(u6,*) 'Angular',iqqqQ,iqqqC + write(u6,*) '#primitive',nExp1,nExp2 + write(u6,*) ContrI(1:nSph1*nSph2) + end if + kreichner = 0 + do iC=1,nSph2 + do iQ=1,nSph1 + kreichner = kreichner+1 + Sint(iWoGehenQ(iQcontB,iQ),iWoGehenC(iCcontB,iC)) = ContrI(kreichner) + end do + end do + end do + end do + iCcontBSAV = iCcontB + call mma_deallocate(PSint) + end do + ! OH NO!, these things have to do with + ! getting the right number in right + ! place. This should probably be + ! changed sometime to a less cumbersome method. + iQcontBSAV = iQcontB + iCcontBSAV1 = iCcontBSAV + iCcontBSAV = iCcontBSAV2 + end do + iQcontBSAV1 = iQcontBSAV + iQcontBSAV = iQcontBSAV2 + iCcontBSAV2 = iCcontBSAV1 + iCcontBSAV = iCcontBSAV1 + end do + iQcontBSAV2 = iQcontBSAV1 + iQcontBSAV = iQcontBSAV1 + iCcontBSAV = 0 + iCcontBSAV1 = 0 + iCcontBSAV2 = 0 +end do +call mma_deallocate(Alf) +call mma_deallocate(Bet) +call mma_deallocate(Conkort) +call mma_deallocate(Donkort) +call mma_deallocate(ContrI) +if (iPrint >= 30) then !Optional print-out. + write(u6,*) + write(u6,*) 'OVERLAP BETWEEN QM-SYSTEM AND SOLVENT MOLECULE',N/nCent + write(u6,*) 'QM-AO SOLV-AO OVERLAP' + do i=1,nBaseQ + do j=1,nBaseC + write(u6,8888) i,j,Sint(i,j) + end do + end do +end if + +return + +8888 format(I3,' ',I3,' ',F12.10) + +end subroutine ContractOvl diff -Nru openmolcas-22.02/src/qmstat/contrasbas.f openmolcas-22.10/src/qmstat/contrasbas.f --- openmolcas-22.02/src/qmstat/contrasbas.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/contrasbas.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,157 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -* Subroutine ContRASBas(nBas,nStatePrim,iNonH,iNonS,Eigis) - Subroutine ContRASBas(nBas,nStatePrim,iNonH,iNonS,iEig2) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "qm2.fh" -#include "numbers.fh" -#include "WrkSpc.fh" - - Dimension nBas(MxSym)!,Eigis(MxState,MxState) - -* -*--- Hi y'all -* - Write(6,*)' ----- Constructing CASSI eigenstates.' - -* -*--- Diagonalize overlap matrix. -* - Call GetMem('EigV1','Allo','Real',iEig1,nStatePrim**2) - kaunter=0 - Do 1, i=1,nStatePrim - Do 2, j=1,nStatePrim - If(i.eq.j) then - Work(iEig1+kaunter)=ONE - Else - Work(iEig1+kaunter)=ZERO - Endif - kaunter=kaunter+1 -2 Continue -1 Continue - Call Jacob(Work(iNonS),Work(iEig1),nStatePrim,nStatePrim) - If(iPrint.ge.15) then - Call TriPrt('Diagonal RASSCF overlap matrix',' ' - & ,Work(iNonS),nStatePrim) - Endif - -* -*--- Construct TS^(-1/2) for canonical orthogonalization. -* - ii=0 - Do 4, i=1,nStatePrim - ii=ii+i - x=1.0D00/Sqrt(Max(1.0D-14,Work(iNonS-1+ii))) - Do 5, k=1,nStatePrim - ind=k+nStatePrim*(i-1)-1 - Work(iEig1+ind)=x*Work(iEig1+ind) -5 Continue -4 Continue - -* -*--- Make reductions if requested. -* - Call GetMem('RedEigV1','Allo','Real',iEig2,nStatePrim**2) - iT=0 - If(ContrStateB) then - Do 61, iS=1,nStatePrim - kaunt=iS*(iS+1)/2-1 - sss=Work(iNonS+kaunt) - If(sss.gt.ThrsCont) then - iT=iT+1 - call dcopy_(nStatePrim,Work(iEig1+nStatePrim*(iS-1)),iONE - & ,Work(iEig2+nStatePrim*(iT-1)),iONE) - Endif -61 Continue - nStateRed=iT - Write(6,6199)' ----- Contraction:',nStatePrim,' ---> ' - & ,nStateRed -6199 Format(A,I3,A,I3) - Else - call dcopy_(nStatePrim**2,Work(iEig1),iONE,Work(iEig2),iONE) - nStateRed=nStatePrim - Endif - -* -*--- Transform H and diagonalize in the original basis. -* - nTri=nStateRed*(nStateRed+1)/2 - Call GetMem('TEMP','Allo','Real',iTEMP,nStatePrim**2) - Call GetMem('SqH','Allo','Real',iSqH,nStatePrim**2) - Call GetMem('RedHSq','Allo','Real',iRedHSq,nStateRed**2) - Call GetMem('RedHTr','Allo','Real',iRedHTr,nTri) - Call Square(Work(iNonH),Work(iSqH),iONE,nStatePrim,nStatePrim) - Call Dgemm_('N','N',nStatePrim,nStateRed,nStatePrim,ONE,Work(iSqH) - & ,nStatePrim,Work(iEig2),nStatePrim,ZERO,Work(iTEMP) - & ,nStatePrim) - Call Dgemm_('T','N',nStateRed,nStateRed,nStatePrim,ONE,Work(iEig2) - & ,nStatePrim,Work(iTEMP),nStatePrim,ZERO,Work(iRedHSq) - & ,nStateRed) - Call SqToTri_Q(Work(iRedHSq),Work(iRedHTr),nStateRed) - Call Jacob(Work(iRedHTr),Work(iEig2),nStateRed,nStatePrim) - Call JacOrd(Work(iRedHTr),Work(iEig2),nStateRed,nStatePrim) - -* -*--- At this stage we have eigenvectors to the CASSI states and their -* eigenenergies, hence time to construct the first H_0 and store the -* eigenvectors for subsequent transformations. -* - kaunter=0 - nLvlInd=1 - Do 55, iState=1,nStateRed - Do 56, jState=1,iState - kaunter=kaunter+1 - HMatState(kaunter)=ZERO -56 Continue - HMatState(kaunter)=Work(iRedHTr+kaunter-1) -*---- If requested, introduce level-shift of states. - If(nLvlShift.ne.0) then - If(iState.eq.iLvlShift(nLvlInd)) then - HMatState(kaunter)=HMatState(kaunter)+dLvlShift(nLvlInd) - nLvlInd=nLvlInd+1 - Endif - Endif -55 Continue - -* -*--- Print. -* - If(iPrint.ge.10) then - Call TriPrt('RASSI Hamiltonian',' ',HMatState,nStateRed) - Write(6,*) - Call RecPrt('RASSI eigenvectors',' ',Work(iEig2),nStatePrim - & ,nStateRed) - Endif - -* -*--- Deallocate. -* - Call GetMem('EigV1','Free','Real',iEig1,nStatePrim**2) - Call GetMem('TEMP','Free','Real',iTEMP,nStatePrim**2) - Call GetMem('SqH','Free','Real',iSqH,nStatePrim**2) - Call GetMem('RedHSq','Free','Real',iRedHSq,nStateRed**2) - Call GetMem('RedHTr','Free','Real',iRedHTr,nTri) - -* -*--- OBSERVE! CAUTION! ATTENTION! The variable nState is defined. -* - nState=nStateRed - -* -*--- No parasan! -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer_array(nBas) - End diff -Nru openmolcas-22.02/src/qmstat/contrasbas.F90 openmolcas-22.10/src/qmstat/contrasbas.F90 --- openmolcas-22.02/src/qmstat/contrasbas.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/contrasbas.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,133 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ContRASBas(nStatePrim,NonH,NonS,Eig2) + +use qmstat_global, only: ContrStateB, dLvlShift, HmatSOld, HmatState, iLvlShift, iPrint, nLvlShift, nState, ThrsCont +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, one +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nStatePrim +real(kind=wp), intent(in) :: NonH(nTri_Elem(nStatePrim)) +real(kind=wp), intent(inout) :: NonS(nTri_Elem(nStatePrim)) +real(kind=wp), intent(out) :: Eig2(nStatePrim,nStatePrim) +integer(kind=iwp) :: i, ii, iS, iState, iT, kaunt, kaunter, nLvlInd, nStateRed, nTri +real(kind=wp) :: sss, x +real(kind=wp), allocatable :: Eig1(:,:), RedHSq(:,:), RedHTr(:), SqH(:,:), TEMP(:,:) + +! Hi y'all + +write(u6,*) ' ----- Constructing CASSI eigenstates.' + +! Diagonalize overlap matrix. + +call mma_allocate(Eig1,nStatePrim,nStatePrim,label='EigV1') +Eig1(:,:) = Zero +do i=1,nStatePrim + Eig1(i,i) = One +end do +call Jacob(NonS,Eig1,nStatePrim,nStatePrim) +if (iPrint >= 15) call TriPrt('Diagonal RASSCF overlap matrix',' ',NonS,nStatePrim) + +! Construct TS^(-1/2) for canonical orthogonalization. + +ii = 0 +do i=1,nStatePrim + ii = ii+i + x = One/sqrt(max(1.0e-14_wp,NonS(ii))) + Eig1(:,i) = x*Eig1(:,i) +end do + +! Make reductions if requested. + +iT = 0 +if (ContrStateB) then + do iS=1,nStatePrim + kaunt = nTri_Elem(iS)+1 + sss = NonS(kaunt) + if (sss > ThrsCont) then + iT = iT+1 + Eig2(:,iT) = Eig1(:,iS) + end if + end do + nStateRed = iT + write(u6,6199) ' ----- Contraction:',nStatePrim,' ---> ',nStateRed +else + Eig2(:,:) = Eig1 + nStateRed = nStatePrim +end if + +! Transform H and diagonalize in the original basis. + +nTri = nTri_Elem(nStateRed) +call mma_allocate(TEMP,nStatePrim,nStatePrim,label='TEMP') +call mma_allocate(SqH,nStatePrim,nStatePrim,label='SqH') +call mma_allocate(RedHSq,nStateRed,nStateRed,label='RedHSq') +call mma_allocate(RedHTr,nTri,label='RedHTr') +call Square(NonH,SqH,1,nStatePrim,nStatePrim) +call Dgemm_('N','N',nStatePrim,nStateRed,nStatePrim,One,SqH,nStatePrim,Eig2,nStatePrim,Zero,TEMP,nStatePrim) +call Dgemm_('T','N',nStateRed,nStateRed,nStatePrim,One,Eig2,nStatePrim,TEMP,nStatePrim,Zero,RedHSq,nStateRed) +call SqToTri_Q(RedHSq,RedHTr,nStateRed) +call Jacob(RedHTr,Eig2,nStateRed,nStatePrim) +call JacOrd(RedHTr,Eig2,nStateRed,nStatePrim) + +! At this stage we have eigenvectors to the CASSI states and their +! eigenenergies, hence time to construct the first H_0 and store the +! eigenvectors for subsequent transformations. + +call mma_allocate(HMatState,nTri_Elem(nStateRed),label='HMatState') +call mma_allocate(HMatSOld,nTri_Elem(nStateRed),label='HMatSOld') + +kaunter = 0 +nLvlInd = 1 +HMatState(:) = Zero +do iState=1,nStateRed + kaunter = nTri_Elem(iState) + HMatState(kaunter) = RedHTr(kaunter) + ! If requested, introduce level-shift of states. + if (nLvlShift > 0) then + if (iState == iLvlShift(nLvlInd)) then + HMatState(kaunter) = HMatState(kaunter)+dLvlShift(nLvlInd) + nLvlInd = nLvlInd+1 + end if + end if +end do + +! Print. + +if (iPrint >= 10) then + call TriPrt('RASSI Hamiltonian',' ',HMatState,nStateRed) + write(u6,*) + call RecPrt('RASSI eigenvectors',' ',Eig2,nStatePrim,nStateRed) +end if + +! Deallocate. + +call mma_deallocate(Eig1) +call mma_deallocate(TEMP) +call mma_deallocate(SqH) +call mma_deallocate(RedHSq) +call mma_deallocate(RedHTr) + +! OBSERVE! CAUTION! ATTENTION! The variable nState is defined. + +nState = nStateRed + +! No parasan! + +return + +6199 format(A,I3,A,I3) + +end subroutine ContRASBas diff -Nru openmolcas-22.02/src/qmstat/cooout.f openmolcas-22.10/src/qmstat/cooout.f --- openmolcas-22.02/src/qmstat/cooout.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/cooout.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Cooout(Head,Cordst,nPart,nCent) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" - - Dimension Cordst(MxCen*MxPut,3) - Character Head*200 - - Write(6,*) - Write(6,*) - Write(6,'(A)')Head - kaunter=0 - Do 1, i=1,nPart - Write(6,*)'Molecule ',i - Do 2, j=1,nCent - kaunter=kaunter+1 - Write(6,*)(Cordst(kaunter,ii),ii=1,3) -2 Continue -1 Continue - - Return - End diff -Nru openmolcas-22.02/src/qmstat/cooout.F90 openmolcas-22.10/src/qmstat/cooout.F90 --- openmolcas-22.02/src/qmstat/cooout.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/cooout.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,36 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Cooout(Head,Cordst,nPart,nCent) + +use Definitions, only: wp, iwp, u6 + +implicit none +character(len=200), intent(in) :: Head +integer(kind=iwp), intent(in) :: nPart, nCent +real(kind=wp), intent(in) :: Cordst(3,nPart*nCent) +integer(kind=iwp) :: i, j, kaunter + +write(u6,*) +write(u6,*) +write(u6,'(A)') Head +kaunter = 0 +do i=1,nPart + write(u6,*) 'Molecule ',i + do j=1,nCent + kaunter = kaunter+1 + write(u6,*) Cordst(:,kaunter) + end do +end do + +return + +end subroutine Cooout diff -Nru openmolcas-22.02/src/qmstat/coult0_1.F90 openmolcas-22.10/src/qmstat/coult0_1.F90 --- openmolcas-22.02/src/qmstat/coult0_1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/coult0_1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,31 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! s-s interaction, with too small exponent difference. +function CoulT0_1(Rho,dSepInv,Expo) + +use Constants, only: One, Three, Four, Six, Eight, Eleven +use Definitions, only: wp + +implicit none +real(kind=wp) :: CoulT0_1 +real(kind=wp), intent(in) :: Rho, dSepInv, Expo +real(kind=wp) :: T1, T2, T3, T4 + +T1 = One +T2 = (Eleven/Eight)*Rho +T3 = (Three/Four)*Rho**2 +T4 = (One/Six)*Rho**3 +CoulT0_1 = dSepInv*(One-(T1+T2+T3+T4)*Expo) + +return + +end function CoulT0_1 diff -Nru openmolcas-22.02/src/qmstat/coult0_2.F90 openmolcas-22.10/src/qmstat/coult0_2.F90 --- openmolcas-22.02/src/qmstat/coult0_2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/coult0_2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,33 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! s-p interaction, with too small exponent difference. +function CoulT0_2(Rho,dSepInv,Expo) + +use Constants, only: One, Two, Eleven, Twelve +use Definitions, only: wp + +implicit none +real(kind=wp) :: CoulT0_2 +real(kind=wp), intent(in) :: Rho, dSepInv, Expo +real(kind=wp) :: T1, T2, T3, T4, T5, T6 + +T1 = One +T2 = Two*Rho +T3 = Two*Rho**2 +T4 = (59.0_wp/48.0_wp)*Rho**3 +T5 = (Eleven/24.0_wp)*Rho**4 +T6 = (One/Twelve)*Rho**5 +CoulT0_2 = dSepInv**2*(One-(T1+T2+T3+T4+T5+T6)*Expo) + +return + +end function CoulT0_2 diff -Nru openmolcas-22.02/src/qmstat/coult0_4.F90 openmolcas-22.10/src/qmstat/coult0_4.F90 --- openmolcas-22.02/src/qmstat/coult0_4.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/coult0_4.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,35 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! p-p (sigma), with too small exponent difference. +function CoulT0_4(Rho,dSepInv,Expo) + +use Constants, only: One, Two, Ten +use Definitions, only: wp + +implicit none +real(kind=wp) :: CoulT0_4 +real(kind=wp), intent(in) :: Rho, dSepInv, Expo +real(kind=wp) :: T1, T2, T3, T4, T5, T6, T7, T8 + +T1 = One +T2 = Two*Rho +T3 = Two*Rho**2 +T4 = (263.0_wp/192.0_wp)*Rho**3 +T5 = (71.0_wp/96.0_wp)*Rho**4 +T6 = (77.0_wp/240.0_wp)*Rho**5 +T7 = (One/Ten)*Rho**6 +T8 = (One/60.0_wp)*Rho**7 +CoulT0_4 = Two*dSepInv**3*(One-(T1+T2+T3+T4+T5+T6+T7+T8)*Expo) + +return + +end function CoulT0_4 diff -Nru openmolcas-22.02/src/qmstat/coult0_5.F90 openmolcas-22.10/src/qmstat/coult0_5.F90 --- openmolcas-22.02/src/qmstat/coult0_5.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/coult0_5.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,34 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! p-p (pi), with too small exponent difference. +function CoulT0_5(Rho,dSepInv,Expo) + +use Constants, only: One, Two +use Definitions, only: wp + +implicit none +real(kind=wp) :: CoulT0_5 +real(kind=wp), intent(in) :: Rho, dSepInv, Expo +real(kind=wp) :: T1, T2, T3, T4, T5, T6, T7 + +T1 = One +T2 = Two*Rho +T3 = Two*Rho**2 +T4 = (121.0_wp/96.0_wp)*Rho**3 +T5 = (25.0_wp/48.0_wp)*Rho**4 +T6 = (Two/15.0_wp)*Rho**5 +T7 = (One/60.0_wp)*Rho**6 +CoulT0_5 = dSepInv**3*(One-(T1+T2+T3+T4+T5+T6+T7)*Expo) + +return + +end function CoulT0_5 diff -Nru openmolcas-22.02/src/qmstat/coultn_1.F90 openmolcas-22.10/src/qmstat/coultn_1.F90 --- openmolcas-22.02/src/qmstat/coultn_1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/coultn_1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,33 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! s-s interaction, normal case. +function CoulTN_1(RA,RB,C,dSepInv,ExpA,ExpB) + +use Constants, only: One, Two, Quart +use Definitions, only: wp + +implicit none +real(kind=wp) :: CoulTN_1 +real(kind=wp), intent(in) :: RA, RB, C, dSepInv, ExpA, ExpB +real(kind=wp) :: T1, T2, TA, TB + +T1 = Quart*(Two+C) +T2 = Quart*RA +TA = (One-C)**2*(T1+T2)*ExpA +T1 = Quart*(Two-C) +T2 = Quart*RB +TB = (One+C)**2*(T1+T2)*ExpB +CoulTN_1 = dSepInv*(One-TA-TB) + +return + +end function CoulTN_1 diff -Nru openmolcas-22.02/src/qmstat/coultn_2.F90 openmolcas-22.10/src/qmstat/coultn_2.F90 --- openmolcas-22.02/src/qmstat/coultn_2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/coultn_2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,34 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! s-p interaction, normal case. +function CoulTN_2(RA,RB,C,dSepInv,ExpA,ExpB) + +use Constants, only: One, Two, Three, Five, Ten, Eleven, Half, Quart +use Definitions, only: wp + +implicit none +real(kind=wp) :: CoulTN_2 +real(kind=wp), intent(in) :: RA, RB, C, dSepInv, ExpA, ExpB +real(kind=wp) :: T1, T2, T3, TA, TB + +T1 = (One/16.0_wp)*(Five+Three*C)*(One+Two*RA) +T2 = Quart*RA**2 +TA = (One-C)**3*(T1+T2)*ExpA +T1 = (One/16.0_wp)*(Eleven-Ten*C+Three*C**2)*(One+Two*RB) +T2 = Half*(Two-C)*RB**2 +T3 = Quart*RB**3 +TB = (One+C)**2*(T1+T2+T3)*ExpB +CoulTN_2 = dSepInv**2*(One-TA-TB) + +return + +end function CoulTN_2 diff -Nru openmolcas-22.02/src/qmstat/coultn_4.F90 openmolcas-22.10/src/qmstat/coultn_4.F90 --- openmolcas-22.02/src/qmstat/coultn_4.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/coultn_4.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,35 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! p-p (sigma), normal case. +function CoulTN_4(RA,RB,C,dSepInv,ExpA,ExpB) + +use Constants, only: One, Two, Three, Eight, Nine +use Definitions, only: wp + +implicit none +real(kind=wp) :: CoulTN_4 +real(kind=wp), intent(in) :: RA, RB, C, dSepInv, ExpA, ExpB +real(kind=wp) :: T1, T2, T3, TA, TB + +T1 = (One/16.0_wp)*(Eight+Nine*C+Three*C**2)*(One+Two*RA+Two*RA**2) +T2 = (Three/16.0_wp)*(Three+Two*C)*RA**3 +T3 = (One/Eight)*RA**4 +TA = (One-C)**3*(T1+T2+T3)*ExpA +T1 = (One/16.0_wp)*(Eight-Nine*C+Three*C**2)*(One+Two*RB+Two*RB**2) +T2 = (Three/16.0_wp)*(Three-Two*C)*RB**3 +T3 = (One/Eight)*RB**4 +TB = (One+C)**3*(T1+T2+T3)*ExpB +CoulTN_4 = Two*dSepInv**3*(One-TA-TB) + +return + +end function CoulTN_4 diff -Nru openmolcas-22.02/src/qmstat/coultn_5.F90 openmolcas-22.10/src/qmstat/coultn_5.F90 --- openmolcas-22.02/src/qmstat/coultn_5.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/coultn_5.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,35 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! p-p (pi), normal case. +function CoulTN_5(RA,RB,C,dSepInv,ExpA,ExpB) + +use Constants, only: One, Two, Three, Five, Eight, Nine +use Definitions, only: wp + +implicit none +real(kind=wp) :: CoulTN_5 +real(kind=wp), intent(in) :: RA, RB, C, dSepInv, ExpA, ExpB +real(kind=wp) :: T1, T2, T3, TA, TB + +T1 = (One/16.0_wp)*(Eight+Nine*C+Three*C**2)*(One+Two*RA) +T2 = (One/Eight)*(Five+Three*C)*RA**2 +T3 = (One/Eight)*RA**3 +TA = (One-C)**3*(T1+T2+T3)*ExpA +T1 = (One/16.0_wp)*(Eight-Nine*C+Three*C**2)*(One+Two*RB) +T2 = (One/Eight)*(Five-Three*C)*RB**2 +T3 = (One/Eight)*RB**3 +TB = (One+C)**3*(T1+T2+T3)*ExpB +CoulTN_5 = dSepInv**3*(One-TA-TB) + +return + +end function CoulTN_5 diff -Nru openmolcas-22.02/src/qmstat/dcorrcorr.F90 openmolcas-22.10/src/qmstat/dcorrcorr.F90 --- openmolcas-22.02/src/qmstat/dcorrcorr.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/dcorrcorr.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,36 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! MP2 density correction. +subroutine DCorrCorr(Dens,DenCorr,Trace_Diff,iOrb,iOcc) + +use Index_Functions, only: nTri_Elem +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iOrb, iOcc +real(kind=wp), intent(inout) :: Dens(nTri_Elem(iOrb)) +real(kind=wp), intent(in) :: DenCorr(nTri_Elem(iOrb)), Trace_Diff +real(kind=wp) :: T, Trace_HF + +Trace_HF = real(iOcc*2,kind=wp) +T = Trace_HF/(Trace_HF-Trace_Diff) +Dens(:) = T*(Dens(:)-DenCorr(:)) +!Trace = Zero +!kaunt = 0 +!do i=1,iOrb +! Trace = Trace+Dens(nTri_Elem(i)) +!end do +!call triprt('KKK',' ',Dens,iorb) +!write(u6,*) 'QQQ:',Trace +return + +end subroutine DCorrCorr diff -Nru openmolcas-22.02/src/qmstat/densi.f openmolcas-22.10/src/qmstat/densi.f --- openmolcas-22.02/src/qmstat/densi.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/densi.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,91 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -* Here we construct the density matrix given the orbital -* coefficients. - SUBROUTINE DENSI_MO(DENS,ORBCO,IS,IA,NBAS,IDIM) - IMPLICIT Real*8 (A-H,O-Z) - DIMENSION DENS(*),ORBCO(IDIM,*) - IJ=0 - DO 8 I=1,NBAS - DO 9 J=1,I - IJ=IJ+1 - DENS(IJ)=0.0d0 - 9 CONTINUE - 8 CONTINUE - DO 10 I=IS,IS+IA-1 - IJ=0 - DO 11 J=1,NBAS - DO 12 K=1,J - IJ=IJ+1 - DENS(IJ)=DENS(IJ)+4.d0*ORBCO(J,I)*ORBCO(K,I) - 12 CONTINUE - DENS(IJ)=DENS(IJ)-ORBCO(J,I)*ORBCO(J,I)*2.d0 - 11 CONTINUE - 10 CONTINUE - RETURN - END - - -* The RASSI-density matrix subroutine. - Subroutine DensiSt(Dens,StVec,iS,nSt,iDim) - Implicit Real*8 (a-h,o-z) - Dimension Dens(*),StVec(iDim,*) - -* iS - Which state that is occupied. -* Dens - The density -* StVec - The coefficients for how the new states are expressed -* with the old. - kaunt=0 - Do 101, i=1,nSt - Do 102, j=1,i - kaunt=kaunt+1 - Dens(kaunt)=0.0d0 -102 Continue -101 Continue - kaunt=0 - Do 112, ii=1,nSt - Do 113, jj=1,ii - kaunt=kaunt+1 - If(ii.eq.jj) then - Dens(kaunt)=1.0d0*StVec(ii,iS)*StVec(jj,iS) - Else - Dens(kaunt)=2.0d0*StVec(ii,iS)*StVec(jj,iS) - Endif -113 Continue -112 Continue - Return - End - -* MP2 density correction. - Subroutine DCorrCorr(Dens,DenCorr,Trace_Diff,iOrb,iOcc) - Implicit Real*8 (a-h,o-z) - Dimension Dens(*),DenCorr(*) - Trace_HF=dble(iOcc*2) - kaunt=0 - T=Trace_HF/(Trace_HF-Trace_Diff) - Do 183, i=1,iOrb - Do 184, j=1,i - kaunt=kaunt+1 - Dens(kaunt)=T*(Dens(kaunt)-DenCorr(kaunt)) -184 Continue -183 Continue -* Trace=0.0d0 -* kaunt=0 -* Do 181, i=1,iOrb -* Do 182, j=1,i -* kaunt=kaunt+1 -* If(i.eq.j)Trace=Trace+Dens(kaunt) -*182 Continue -*181 Continue -* call triprt('KKK',' ',Dens,iorb) -* write(6,*)'QQQ:',Trace - Return - End diff -Nru openmolcas-22.02/src/qmstat/densi_mo.F90 openmolcas-22.10/src/qmstat/densi_mo.F90 --- openmolcas-22.02/src/qmstat/densi_mo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/densi_mo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,39 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! Here we construct the density matrix given the orbital coefficients. +subroutine DENSI_MO(DENS,ORBCO,IS,IA,NBAS,IDM) + +use Index_Functions, only: nTri_Elem +use Constants, only: Zero, Two, Four +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: IS, IA, NBAS, IDM +real(kind=wp), intent(out) :: DENS(nTri_Elem(NBAS)) +real(kind=wp), intent(in) :: ORBCO(IDM,*) +integer(kind=iwp) :: I, IJ, J, K + +DENS(:) = Zero +do I=IS,IS+IA-1 + IJ = 0 + do J=1,NBAS + do K=1,J + IJ = IJ+1 + DENS(IJ) = DENS(IJ)+Four*ORBCO(J,I)*ORBCO(K,I) + end do + DENS(IJ) = DENS(IJ)-ORBCO(J,I)*ORBCO(J,I)*Two + end do +end do + +return + +end subroutine DENSI_MO diff -Nru openmolcas-22.02/src/qmstat/densist.F90 openmolcas-22.10/src/qmstat/densist.F90 --- openmolcas-22.02/src/qmstat/densist.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/densist.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,40 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! The RASSI-density matrix subroutine. +subroutine DensiSt(Dens,StVec,iS,nSt,iDm) +! iS - Which state that is occupied. +! Dens - The density +! StVec - The coefficients for how the new states are expressed with the old. + +use Index_Functions, only: nTri_Elem +use Constants, only: Two +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iS, nSt, iDm +real(kind=wp), intent(out) :: Dens(nTri_Elem(nSt)) +real(kind=wp), intent(in) :: StVec(iDm,*) +integer(kind=iwp) :: i, j, kaunt + +kaunt = 0 +do i=1,nSt + do j=1,i-1 + kaunt = kaunt+1 + Dens(kaunt) = Two*StVec(i,iS)*StVec(j,iS) + end do + kaunt = kaunt+1 + Dens(kaunt) = StVec(i,iS)*StVec(i,iS) +end do + +return + +end subroutine DensiSt diff -Nru openmolcas-22.02/src/qmstat/dispenergy.f openmolcas-22.10/src/qmstat/dispenergy.f --- openmolcas-22.02/src/qmstat/dispenergy.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/dispenergy.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,72 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine DispEnergy(EEDisp,BoMaH,BoMaO,dAtO1,dAtH1,dAtH2 - & ,Rab13i,Rab23i,Rab33i,indQAt) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" - - Dimension BoMaH(MxAt),BoMaO(MxAt) - Dimension DampBarn(3) - -* -*--- If Damping, do it, otherwise easy stuff -* - If(DispDamp) then -* -*--- Get the damping, for the relevant QM-atom with all solvent -* atoms. -* - kFac=1 - DampBarn(1)=1.0d0 - Do 661, k=1,6 - kFac=kFac*k - DampBarn(1)=DampBarn(1)+(BoMaH(indQAt)*dAtH1)**k/dble(kFac) -661 Continue - DampBarn(1)=1.0d0-DampBarn(1)*exp(-BoMaH(indQAt)*dAtH1) - - kFac=1 - DampBarn(2)=1.0d0 - Do 662, k=1,6 - kFac=kFac*k - DampBarn(2)=DampBarn(2)+(BoMaH(indQAt)*dAtH2)**k/dble(kFac) -662 Continue - DampBarn(2)=1.0d0-DampBarn(2)*exp(-BoMaH(indQAt)*dAtH2) - - kFac=1 - DampBarn(3)=1.0d0 - Do 663, k=1,6 - kFac=kFac*k - DampBarn(3)=DampBarn(3)+(BoMaO(indQAt)*dAtO1)**k/dble(kFac) -663 Continue - DampBarn(3)=1.0d0-DampBarn(3)*exp(-BoMaO(indQAt)*dAtO1) - -* -*--- If not damping, set factors to 1.0d0 -* - Else - DampBarn(1)=1.0d0 - DampBarn(2)=1.0d0 - DampBarn(3)=1.0d0 - Endif - -* -*--- Now evaluate the Dispersion energy. -* - EfromO1=Rab13i**2*DampBarn(3)*uDisp(indQAt,1) - EfromH1=Rab23i**2*DampBarn(1)*uDisp(indQAt,2) - EfromH2=Rab33i**2*DampBarn(2)*uDisp(indQAt,2) - - EEDisp=EEdisp+EfromO1+EfromH1+EfromH2 - - Return - End diff -Nru openmolcas-22.02/src/qmstat/dispenergy.F90 openmolcas-22.10/src/qmstat/dispenergy.F90 --- openmolcas-22.02/src/qmstat/dispenergy.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/dispenergy.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,57 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine DispEnergy(EEDisp,BoMaH,BoMaO,dAtO1,dAtH1,dAtH2,Rab13i,Rab23i,Rab33i,indQAt) + +use qmstat_global, only: DispDamp, uDisp +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(inout) :: EEDisp +real(kind=wp), intent(in) :: BoMaH, BoMaO, dAtO1, dAtH1, dAtH2, Rab13i, Rab23i, Rab33i +integer(kind=iwp), intent(in) :: indQAt +integer(kind=iwp) :: k, kFac +real(kind=wp) :: BM(3), DampBarn(3), EfromH1, EfromH2, EfromO1 + +! If not damping, set factors to 1.0 + +DampBarn(:) = One + +if (DispDamp) then + + ! If Damping, do it, otherwise easy stuff + + ! Get the damping, for the relevant QM-atom with all solvent atoms. + BM(1) = BoMaH*dAtH1 + BM(2) = BoMaH*dAtH2 + BM(3) = BoMaO*dAtO1 + + kFac = 1 + do k=1,6 + kFac = kFac*k + DampBarn(:) = DampBarn(:)+BM(:)**k/real(kFac,kind=wp) + end do + DampBarn(:) = One-DampBarn(:)*exp(-BM(:)) + +end if + +! Now evaluate the Dispersion energy. + +EfromH1 = Rab23i**2*DampBarn(1)*uDisp(2,indQAt) +EfromH2 = Rab33i**2*DampBarn(2)*uDisp(2,indQAt) +EfromO1 = Rab13i**2*DampBarn(3)*uDisp(1,indQAt) + +EEDisp = EEdisp+EfromO1+EfromH1+EfromH2 + +return + +end subroutine DispEnergy diff -Nru openmolcas-22.02/src/qmstat/editstart.f openmolcas-22.10/src/qmstat/editstart.f --- openmolcas-22.02/src/qmstat/editstart.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/editstart.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,297 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine EditStart - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "files_qmstat.fh" -#include "WrkSpc.fh" -#include "warnings.h" - - Parameter (ThrdSpread=1.0d0) - Dimension iC(3),iC2(3) - Dimension Coord(MxCen*MxPut,3),Coo(MxCen,3),CooRef(MxCen,3) - Character Filstart*6,FilSlut*6,Head*200 - Logical Exist,ValidOrNot - -* -*-- Inquire if file exists, and if so open it. -* - Write(FilStart,'(A5,i1.1)')'STFIL',NrStarti - Call f_Inquire(FilStart,Exist) - If(.not.Exist) then - Write(6,*) - Write(6,*)'The input startfile given in the EDITstartfile' - &//' section was not found.' - Call Quit(_RC_IO_ERROR_READ_) - Endif - iLu=73 - Call DaName(iLu,Filstart) - -* -*-- Read header and coordinates. -* - iDisk=0 - Call WrRdSim(iLu,2,iDisk,iTcSim,64,Etot,Ract,nPart,Gamold - & ,GaOld,Esub) - iDisk=iTcSim(1) - Do 5,l=1,3 - Call GetMem('Coordinates','Allo','Real',iC(l),nPart*nCent) - Call dDaFile(iLu,2,Work(iC(l)),nPart*nCent,iDisk) -5 Continue - Call DaClos(iLu) - -* -*-- Now take different paths depending of what user have requested in -* the input. -* - -* -*-- If deleting solvent molecules. -* - If(DelOrAdd(1)) then -* -*----Find the solvent molecules fartherst away from origo and -* delete them. -* - Do 10, i=1,nDel - rMax=0.0d0 - indMax=0 - Do 20, j=1,nPart - r=0.0d0 - Do 30, k=1,3 - r=r+Work(iC(k)+(j-1)*nCent)**2 -30 Continue - If(r.gt.rMax) then - rMax=r - indMax=j - Endif -20 Continue - Do 40, j=indMax,nPart-i - Do 50, l=1,3 - Do 60, ll=1,nCent - Work(iC(l)+(j-1)*nCent+ll-1)=Work(iC(l)+j*nCent+ll-1) -60 Continue -50 Continue -40 Continue -10 Continue -* -*----Print the new set of coordinates to a startfile. -* - iLu=74 - Write(FilSlut,'(A5,i1.1)')'STFIL',NrStartu - Call DaName(iLu,FilSlut) - iDisk=0 - Call WrRdSim(iLu,1,iDisk,iTcSim,64,Etot,Ract,nPart-nDel,Gamold - & ,Gaold,Esub) - iTcSim(1)=iDisk - Do 70, l=1,3 - Call dDaFile(iLu,1,Work(iC(l)),(nPart-nDel)*nCent,iDisk) - iTcSim(1+l)=iDisk -70 Continue - iDisk=0 - Call WrRdSim(iLu,1,iDisk,iTcSim,64,Etot,Ract,nPart-nDel,Gamold - & ,Gaold,Esub) - Call DaClos(iLu) -* -*----If user wants, print print print. -* - If(iPrint.ge.10) then - Do 1001, i=1,(nPart-nDel)*nCent - Coord(i,1)=Work(iC(1)+i-1) - Coord(i,2)=Work(iC(2)+i-1) - Coord(i,3)=Work(iC(3)+i-1) -1001 Continue - Write(Head,*)'Final coordinates' - Call Cooout(Head,Coord,nPart-nDel,nCent) - Endif - Endif - -* -*-- If adding solvent molecules. -* - If(DelOrAdd(2)) then - Do 301, i=1,nPart*nCent - Coord(i,1)=Work(iC(1)+i-1) - Coord(i,2)=Work(iC(2)+i-1) - Coord(i,3)=Work(iC(3)+i-1) -301 Continue - If(nAdd.ne.0) then -*---- Just an ugly trick for using nypart. It requires that the first -* slot contains the solvent coordinates, so we, temporarily, put -* them there. - Do 3010, i=1,nCent - Do 3011, j=1,3 - Coord(i,j)=Cordst(i,j) -3011 Continue -3010 Continue -*---- Introduce the new particles. nPart is redefined. - Call NyPart(nAdd,nPart,Coord,rStart,nCent,iSeed) -*---- The ugly trick is reversed, and the first slot is retained. - Do 3012, i=1,nCent - Do 3013, j=1,3 - Coord(i,j)=Work(iC(j)+i-1) -3013 Continue -3012 Continue - Endif -* -*----Then dump new coordinates on designated startfile. -* - Do 3001, k=1,3 - Call GetMem('NewCoo','Allo','Real',iC2(k),nPart*nCent) -3001 Continue - Do 302, i=1,nPart*nCent - Work(iC2(1)+i-1)=Coord(i,1) - Work(iC2(2)+i-1)=Coord(i,2) - Work(iC2(3)+i-1)=Coord(i,3) -302 Continue - iLu=74 - Write(FilSlut,'(A5,i1.1)')'STFIL',NrStartu - Call DaName(iLu,FilSlut) - iDisk=0 - Call WrRdSim(iLu,1,iDisk,iTcSim,64,Etot,RStart,nPart,Gamold - & ,Gaold,Esub) - iTcSim(1)=iDisk - Do 270, l=1,3 - Call dDaFile(iLu,1,Work(iC2(l)),nPart*nCent,iDisk) - iTcSim(1+l)=iDisk -270 Continue - iDisk=0 - Call WrRdSim(iLu,1,iDisk,iTcSim,64,Etot,RStart,nPart,Gamold - & ,Gaold,Esub) - Call DaClos(iLu) - If(iPrint.ge.10) then - Write(Head,*)'Final coordinates' - Call Cooout(Head,Coord,nPart,nCent) - Endif - Do 3002, k=1,3 - Call GetMem('NewCoo','Free','Real',iC2(k),nPart*nCent) -3002 Continue - Endif - -* -*-- If requested, substitute all particles that are not of valid water -* geometry for, you guessed it, valid water molecules. -* - If(DelOrAdd(3)) then - nRemoved=0 - Do 451, iPart=1,nPart - ind=nCent*(iPart-1) - Do 452, iCent=1,nCent - Coo(iCent,1)=Work(iC(1)+ind+iCent-1) - Coo(iCent,2)=Work(iC(2)+ind+iCent-1) - Coo(iCent,3)=Work(iC(3)+ind+iCent-1) - CooRef(iCent,1)=Cordst(iCent,1) - CooRef(iCent,2)=Cordst(iCent,2) - CooRef(iCent,3)=Cordst(iCent,3) -452 Continue - Call IsItValid(Coo,CooRef,ValidOrNot) - If(.not.ValidOrNot) then - dCMx=0.0d0 - dCMy=0.0d0 - dCMz=0.0d0 - Do 453, iCent=1,nCent - dCMx=dCMx+Work(iC(1)+ind+iCent-1) - dCMy=dCMy+Work(iC(2)+ind+iCent-1) - dCMz=dCMz+Work(iC(3)+ind+iCent-1) -453 Continue - dCMx=dCMx*(1.0d0/dble(nCent)) - dCMy=dCMy*(1.0d0/dble(nCent)) - dCMz=dCMz*(1.0d0/dble(nCent)) -*------ Check if the points are spread out, otherwise just delete. - dSpread=0.0d0 - Do 455, iCent=1,nCent - dSpread=dSpread+(Work(iC(1)+ind+iCent-1)-dCMx)**2 - dSpread=dSpread+(Work(iC(2)+ind+iCent-1)-dCMy)**2 - dSpread=dSpread+(Work(iC(3)+ind+iCent-1)-dCMz)**2 -455 Continue - dSpread=dSpread*(1.0d0/dble(nCent)) - If(dSpread.lt.ThrdSpread) then - nRemoved=nRemoved+1 - Do 456, jP=iPart,nPart-1 - jnd1=(jP-1)*nCent - jnd2=(jP)*nCent - Do 457, iCent=1,nCent - Work(iC(1)+jnd1+iCent-1)=Work(iC(1)+jnd2+iCent-1) - Work(iC(2)+jnd1+iCent-1)=Work(iC(2)+jnd2+iCent-1) - Work(iC(3)+jnd1+iCent-1)=Work(iC(3)+jnd2+iCent-1) -457 Continue -456 Continue - Else - Do 454, iCent=1,nCent - Work(iC(1)+ind+iCent-1)=dCMx+CooRef(iCent,1) - Work(iC(2)+ind+iCent-1)=dCMy+CooRef(iCent,2) - Work(iC(3)+ind+iCent-1)=dCMz+CooRef(iCent,3) -454 Continue - Endif - Endif -451 Continue - nPart=nPart-nRemoved -* -*----Print the new set of coordinates to a startfile. -* - iLu=74 - Write(FilSlut,'(A5,i1.1)')'STFIL',NrStartu - Call DaName(iLu,FilSlut) - iDisk=0 - Call WrRdSim(iLu,1,iDisk,iTcSim,64,Etot,Ract,nPart,Gamold - & ,Gaold,Esub) - iTcSim(1)=iDisk - Do 71, l=1,3 - Call dDaFile(iLu,1,Work(iC(l)),nPart*nCent,iDisk) - iTcSim(1+l)=iDisk -71 Continue - iDisk=0 - Call WrRdSim(iLu,1,iDisk,iTcSim,64,Etot,Ract,nPart,Gamold - & ,Gaold,Esub) - Call DaClos(iLu) -* -*----If user wants, print print print. -* - If(iPrint.ge.10) then - Do 1002, i=1,nPart*nCent - Coord(i,1)=Work(iC(1)+i-1) - Coord(i,2)=Work(iC(2)+i-1) - Coord(i,3)=Work(iC(3)+i-1) -1002 Continue - Write(Head,*)'Final coordinates' - Call Cooout(Head,Coord,nPart,nCent) - Endif - Endif - -* -*-- If the user want to, print the coordinates in some format suitable -* for graphical representation. -* - If(DelOrAdd(4)) then - If(cDumpForm(1:4).eq.'MOLD') then - Do 444, iCent=1,nCent - CooRef(iCent,1)=Cordst(iCent,1) - CooRef(iCent,2)=Cordst(iCent,2) - CooRef(iCent,3)=Cordst(iCent,3) -444 Continue - Call MoldenDump(iC,CooRef,nPart,nAtom,nCent) - Endif - Endif - -* -*-- Deallocate. -* - Do 501,l=1,3 - Call GetMem('Coordinates','Free','Real',iC(l),nPart*nCent) -501 Continue - -* -*-- This routine ends now! -* - Return - End diff -Nru openmolcas-22.02/src/qmstat/editstart.F90 openmolcas-22.10/src/qmstat/editstart.F90 --- openmolcas-22.02/src/qmstat/editstart.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/editstart.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,247 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine EditStart() + +use qmstat_global, only: cDumpForm, Cordst, DelOrAdd, iPrint, iSeed, iTcSim, nAdd, nCent, nDel, nPart, NrStarti, NrStartu, rStart +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +real(kind=wp) :: Coo(3,nCent), CooRef(3,nCent) +integer(kind=iwp) :: i, iCent, iDisk, iLu, ind, indMax, iPart, j, jnd1, jnd2, jP, k, l, nRemoved, nTmp +real(kind=wp) :: dCMx, dCMy, dCMz, dSpread, Esub, Etot, Gamold, GaOld, r, Ract, rMax +logical(kind=iwp) :: Exists, ValidOrNot +character(len=200) :: Head +character(len=6) :: FilSlut, Filstart +real(kind=wp), allocatable :: C(:,:), C2(:,:), Coord(:,:) +real(kind=wp), parameter :: ThrdSpread = One +#include "warnings.h" + +! Inquire if file exists, and if so open it. + +write(FilStart,'(A5,i1.1)') 'STFIL',NrStarti +call f_Inquire(FilStart,Exists) +if (.not. Exists) then + write(u6,*) + write(u6,*) 'The input startfile given in the EDITstartfile section was not found.' + call Quit(_RC_IO_ERROR_READ_) +end if +iLu = 73 +call DaName(iLu,Filstart) + +! Read header and coordinates. + +iDisk = 0 +call WrRdSim(iLu,2,iDisk,iTcSim,64,Etot,Ract,nPart,Gamold,GaOld,Esub) +iDisk = iTcSim(1) +call mma_allocate(C,nPart*nCent,3,label='Coordinates') +call dDaFile(iLu,2,C,3*nPart*nCent,iDisk) +call DaClos(iLu) + +! Now take different paths depending of what user have requested in the input. + +call mma_allocate(Coord,3,nPart*nCent,label='Coord') + +! If deleting solvent molecules. + +if (DelOrAdd(1)) then + + ! Find the solvent molecules farthest away from origo and delete them. + + do i=1,nDel + rMax = Zero + indMax = 0 + do j=1,nPart + r = C((j-1)*nCent+1,1)**2+C((j-1)*nCent+1,2)**2+C((j-1)*nCent+1,3)**2 + if (r > rMax) then + rMax = r + indMax = j + end if + end do + do j=indMax,nPart-i + k = (j-1)*nCent + C(k+1:k+nCent,:) = C(k+nCent+1:k+2*nCent,:) + end do + end do + + ! Print the new set of coordinates to a startfile. + + nTmp = nPart-nDel + iLu = 74 + write(FilSlut,'(A5,i1.1)') 'STFIL',NrStartu + call DaName(iLu,FilSlut) + iDisk = 0 + call WrRdSim(iLu,1,iDisk,iTcSim,64,Etot,Ract,nTmp,Gamold,Gaold,Esub) + iTcSim(1) = iDisk + do l=1,3 + call dDaFile(iLu,1,C(:,l),(nPart-nDel)*nCent,iDisk) + iTcSim(1+l) = iDisk + end do + iDisk = 0 + call WrRdSim(iLu,1,iDisk,iTcSim,64,Etot,Ract,nTmp,Gamold,Gaold,Esub) + call DaClos(iLu) + + ! If user wants, print print print. + + if (iPrint >= 10) then + do i=1,(nPart-nDel)*nCent + Coord(:,i) = C(i,:) + end do + write(Head,*) 'Final coordinates' + call Cooout(Head,Coord,nPart-nDel,nCent) + end if +end if + +! If adding solvent molecules. + +if (DelOrAdd(2)) then + do i=1,nPart*nCent + Coord(:,i) = C(i,:) + end do + if (nAdd /= 0) then + ! Just an ugly trick for using nypart. It requires that the first + ! slot contains the solvent coordinates, so we, temporarily, put + ! them there. + Coord(:,1:nCent) = Cordst(:,1:nCent) + ! Introduce the new particles. nPart is redefined. + call NyPart(nAdd,nPart,Coord,rStart,nCent,iSeed) + ! The ugly trick is reversed, and the first slot is retained. + do j=1,3 + Coord(j,1:nCent) = C(1:nCent,j) + end do + end if + + ! Then dump new coordinates on designated startfile. + + call mma_allocate(C2,nPart*nCent,3,label='NewCoo') + do i=1,3 + C2(:,i) = Coord(i,:) + end do + iLu = 74 + write(FilSlut,'(A5,i1.1)') 'STFIL',NrStartu + call DaName(iLu,FilSlut) + iDisk = 0 + call WrRdSim(iLu,1,iDisk,iTcSim,64,Etot,rStart,nPart,Gamold,Gaold,Esub) + iTcSim(1) = iDisk + do l=1,3 + call dDaFile(iLu,1,C2(:,l),nPart*nCent,iDisk) + iTcSim(1+l) = iDisk + end do + iDisk = 0 + call WrRdSim(iLu,1,iDisk,iTcSim,64,Etot,rStart,nPart,Gamold,Gaold,Esub) + call DaClos(iLu) + if (iPrint >= 10) then + write(Head,*) 'Final coordinates' + call Cooout(Head,Coord,nPart,nCent) + end if + call mma_deallocate(C2) +end if + +! If requested, substitute all particles that are not of valid water +! geometry for, you guessed it, valid water molecules. + +if (DelOrAdd(3)) then + nRemoved = 0 + do iPart=1,nPart + ind = nCent*(iPart-1) + do iCent=1,nCent + Coo(:,iCent) = C(ind+iCent,:) + CooRef(:,iCent) = Cordst(:,iCent) + end do + call IsItValid(Coo,CooRef,ValidOrNot) + if (.not. ValidOrNot) then + dCMx = Zero + dCMy = Zero + dCMz = Zero + do iCent=1,nCent + dCMx = dCMx+C(ind+iCent,1) + dCMy = dCMy+C(ind+iCent,2) + dCMz = dCMz+C(ind+iCent,3) + end do + dCMx = dCMx/real(nCent,kind=wp) + dCMy = dCMy/real(nCent,kind=wp) + dCMz = dCMz/real(nCent,kind=wp) + ! Check if the points are spread out, otherwise just delete. + dSpread = Zero + do iCent=1,nCent + dSpread = dSpread+(C(ind+iCent,1)-dCMx)**2+(C(ind+iCent,2)-dCMy)**2+(C(ind+iCent,3)-dCMz)**2 + end do + dSpread = dSpread/real(nCent,kind=wp) + if (dSpread < ThrdSpread) then + nRemoved = nRemoved+1 + do jP=iPart,nPart-1 + jnd1 = (jP-1)*nCent + jnd2 = (jP)*nCent + do iCent=1,nCent + C(jnd1+iCent,:) = C(jnd2+iCent,:) + end do + end do + else + do iCent=1,nCent + C(ind+iCent,1) = dCMx+CooRef(1,iCent) + C(ind+iCent,2) = dCMy+CooRef(2,iCent) + C(ind+iCent,3) = dCMz+CooRef(3,iCent) + end do + end if + end if + end do + nPart = nPart-nRemoved + + ! Print the new set of coordinates to a startfile. + + iLu = 74 + write(FilSlut,'(A5,i1.1)') 'STFIL',NrStartu + call DaName(iLu,FilSlut) + iDisk = 0 + call WrRdSim(iLu,1,iDisk,iTcSim,64,Etot,Ract,nPart,Gamold,Gaold,Esub) + iTcSim(1) = iDisk + do l=1,3 + call dDaFile(iLu,1,C(:,l),nPart*nCent,iDisk) + iTcSim(1+l) = iDisk + end do + iDisk = 0 + call WrRdSim(iLu,1,iDisk,iTcSim,64,Etot,Ract,nPart,Gamold,Gaold,Esub) + call DaClos(iLu) + + ! If user wants, print print print. + + if (iPrint >= 10) then + do i=1,3 + Coord(i,:) = C(:,i) + end do + write(Head,*) 'Final coordinates' + call Cooout(Head,Coord,nPart,nCent) + end if +end if + +call mma_deallocate(Coord) + +! If the user want to, print the coordinates in some format suitable +! for graphical representation. + +if (DelOrAdd(4)) then + if (cDumpForm(1:4) == 'MOLD') then + CooRef(:,1:nCent) = Cordst(:,1:nCent) + call MoldenDump(C,CooRef,nPart,nCent) + end if +end if + +! Deallocate. + +call mma_deallocate(C) + +! This routine ends now! + +return + +end subroutine EditStart diff -Nru openmolcas-22.02/src/qmstat/eqras.f openmolcas-22.10/src/qmstat/eqras.f --- openmolcas-22.02/src/qmstat/eqras.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/eqras.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,674 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine EqRas(iQ_Atoms,nAtomsCC,Coord,nBas,nBas_C,nCnC_C - & ,iBigForDeAll,nSizeBig,ip_UNCLE_MOE,nB) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "files_qmstat.fh" -#include "qmcom.fh" -#include "qm2.fh" -#include "numbers.fh" -#include "integral.fh" -#include "WrkSpc.fh" -#include "warnings.h" -#include "constants.fh" - - Parameter (Conver1=1.0d10*CONST_BOHR_RADIUS_IN_SI_) - Parameter (Conver2=2.0d0*Pi/360.0d0) -* Parameter (BoltzK=1.0d-3*CONST_BOLTZMANN_/CONV_AU_TO_KJ_) - Dimension nBas(1),nBas_C(1),nCnC_C(MxBasC),Coord(MxAt*3) - Dimension Eint(MxQCen,10),Poli(MxQCen,10) - Dimension iFP(3),iGP(3),iDT(3),iFi(3),iFil(MxQCen,10) - Dimension Smat(MxStOT),SmatPure(MxStOT),Vmat(MxStOT) - Dimension BoMaH(MxAt),BoMaO(MxAt) -*****Jose** Interaction with Slater type to consider Penetration - Dimension Eint_Nuc(MxAt) -*****JoseMEP**New variables for the MEP calculation - Dimension SumElcPot(MxQCen,10) - Dimension PertElcInt(MxBas*(MxBas+1)/2) - Character*4 Labjhr -***** - Character Memlabel*20,Memlaabe*20,Memlaaab*20,MemLaaaa*20 - Character MemQFal*20,ChCo*2,ChCo2*2 - Logical DidWeAccept,Haveri,Exist,CalledBefore,SampleThis,InCutOff - Character Head*200 - Parameter (ExLim=10) !Over how long distance the exchange rep. - !is computed, the solv-solv. - External Ranf - Dimension iDum(1) - -* -*-- Enter eqras. -* - -* -*-- Numbers, initializations, conversions. -* - BoltzK=1.0d-3*CONST_BOLTZMANN_/CONV_AU_TO_KJ_ - Ract=Rstart !Initial radie - delX=delX/Conver1 !angstrom-->Bohr - delFi=delFi*Conver2 !degree-->radian - delR=delR/Conver1 !angstrom-->Bohrn - CalledBefore=.false. - Samplethis=.true. - iBigForDeAll=iBigT - If(ParallelT) nMacro=nTemp*nMacro - -* -*---- If we have vacuum, then no volume-pressure work is done, nor do we -* have any cavitation free-energy. -* - If(abs(Diel-1).le.0.0001d0) then - Gamma=0 - Gam=0 - Else - If(SURF.le.0.0d0) then - Gamma=0 - Gam=0 - Else - Gamma=Pres*4.188790205d0*.52917d0**3*6.023d0*.00001d0 - & *1.01325d0/627.52d0/4.184d0 - Gam=.0005973455d0/74d0*SURF - Endif - Endif -* -*--- More numbers. -* - If(Temp.le.0.0d0) then - BetaBol=1.0d23 - Else - BetaBol=1.0d0/(Temp*BoltzK) - Endif - DiFac=-(Diel-1.0d0)/(Diel+1.0d0) - Expran=0.0d0 - iHowMSampIN=0 - iHowMSampUT=0 - nBaseC=nBas_C(1) - nBaseQ=nBas(1) - iTriBasQ=nBaseQ*(nBaseQ+1)/2 - iTriState=nState*(nState+1)/2 - timeCLAS=0 - timeEX=0 - timeEL=0 - timeMC=0 - - -* -*---- If some damping has been requested, prepare it here and print. -* - If((Dispdamp.or.FieldDamp).and.iPrint.ge.8) then - Write(6,*) - Write(6,*)'-----Various damping data.' - Write(6,*) - Endif - If(Dispdamp) then - -* -*---- Construct the Born-Mayer parameters, a la Brdarski-Karlstrom -* - Call BornMayerBK(iQ_Atoms,BoMaH,BoMaO) - Endif - -* -*---- Damping of field. -* - If(Fielddamp) then - if(iPrint.ge.8) then - Write(6,*)' Damping the field between Qm-region and solvent.' - Write(6,*)'E_damp=E_0*(1-exp(alpha*distance))^N' - Write(6,*)' alpha(QM-oxygen) =',CAFieldG - Write(6,*)' alpha(QM-hydrogen) =',CBFieldG - Write(6,*)' N =',CFexp - endif - Endif - -* -*-- Check what type of simulation to run, and generate some output of -* outmost beauty. -* - If(Qmeq.and.iRead.ne.9) then - Call NiceOutPut('EIQ',Gam,Gamma,BetaBol) - Elseif(QmProd.and.iRead.ne.9) then - Call NiceOutPut('PIQ',Gam,Gamma,BetaBol) - Call DaName(iLuSaUt,SaFilUt) - iDisk=0 !Put some dummy on the sampfile so we have space for - !the real number later. - iDum(1)=iHowMSampUT - Call iDaFile(iLuSaUt,1,iDum,1,iDisk) - !Below we make a check for extreme cases. Our algorithm to - !select sampling configurations sets this limit. - iProdMax=(2**30-1)*2 - If((nMacro*nMicro).ge.iProdMax) then - Write(6,*) - Write(6,*)'WARNING! Too large numbers for nMacro and nMicro t' - &//'o run production!' - Write(6,*)' Their product must not be greater than 2**31!' - Write(6,*)' If you wish to make such large samples, you ca' - &//'n run several samplings and collect several sampfiles.' - Call Quit(_RC_INTERNAL_ERROR_) - Endif - Elseif(iRead.eq.9) then !If we read from sampfile: open the - !sampfile and read how many configurations - !and open extract file. - Call NiceOutPut('SSS',Gam,Gamma,BetaBol) - Call DaName(iLuSaIn,SaFilIn) - iDiskSa=0 - Call iDaFile(iLuSaIn,2,iDum,1,iDiskSa) - iHowMSampIN=iDum(1) - iLuExtr=54 - iLuExtr=IsFreeUnit(iLuExtr) - Call OpnFl(SimEx,iLuExtr,Exist) - Write(iLuExtr,*)'Extract-File' - Write(iLuExtr,*) - !And put some words in the output - Write(6,*) - Write(6,*)' Total number of sampled configurations:' - & ,iHowMSampIN - Write(6,*)' Reading from the file ',SaFilIn - Write(6,*)' Summarizing data put on ',SimEx -******JoseMEP - ! If we perform MEP calculation, first we make some zeros - ! and allocate some memory. - If(lExtr(8)) then - Do ijhr=1,MxQCen - Do jjhr=1,10 - SumElcPot(ijhr,jjhr)=0.0d0 - AvElcPot(ijhr,jjhr)=0.0d0 - End do - End do - NCountField=0 - - iTriMaxBasQ=MxBas*(MxBas+1)/2 - call dcopy_(iTriMaxBasQ,[ZERO],iZERO,PertNElcInt,iONE) - Call GetMem('SumOvlAOQ','Allo','Real',ipAOSum,iTriBasQ) - call dcopy_(iTriBasQ,[ZERO],iZERO,Work(ipAOSum),iONE) - Endif -********** - Else - Write(6,*) - Write(6,*)'An invalid number of iRead detected.' - Call Quit(_RC_INTERNAL_ERROR_) - Endif -*----------------------------------------------------------------------* -* If we have input file, then read from it. * -*----------------------------------------------------------------------* - iCStart=(((iQ_Atoms-1)/nAtom)+1)*nCent+1 - iCNum=(iCStart-1)/nCent - i9=0 !i9 is active if iRead.eq.9 and we are collecting - !configurations from the sampfile. -58886 Continue - i9=i9+1 - If(iRead.le.8.and.iRead.ge.6) then - Call Get8(Ract,Dum) - Elseif(iRead.eq.9) then - Call Get9(Ract,Coord,info_atom,iQ_Atoms,iDiskSa) - Else - If(iExtra.gt.0) then - Call NyPart(iExtra,nPart,Cordst,Rstart,nCent,iSeed) - Endif - If(iPrint.ge.10) then - Write(Head,*)'Coordinates of the initial distribution.' - Call Cooout(Head,Cordst,nPart,nCent) - Endif - Endif -* -*-- Give a startvalue for the Total energy. The effect is that we -* always accept the first microstep. -* - Etot=1D+10 - -* -*-- Some numbers. -* - ncpart=Ncent*nPart - ncParm=ncPart-(nCent*icNum) - nClas=nPart-iCNum - indma=npart*npol - iCi=(iQ_Atoms*(iQ_Atoms+1))/2 - -* -*-- Put QM-molecule in its place. -* - If(iRead.eq.8.or.iRead.eq.0) then - Call PlaceIt(Coord,iQ_Atoms,iCNum) - Elseif(iRead.eq.6) then - Call PlaceIt9(Coord,Cordst,info_atom,iQ_Atoms) - If(iPrint.ge.10) then - Write(Head,*)'CM-centred coordinates after substitution.' - Call Cooout(Head,Cordst,nPart,nCent) - Endif - Endif - -*----------------------------------------------------------------------* -* * -*------------------------- START SIMULATION ---------------------------* -* * -*----------------------------------------------------------------------* - - iSnurr=0 !How many steps taken totally. -* -*---- The Macrosteps. -* - Do 2000, iMacro=1,nMacro - Esav=0.0d0 - If(iRead.eq.9) then - iAcc=1 - Else - iAcc=0 - Endif - -*------ If we are running parallel tempering, then... - If(ParallelT) Call ParaRoot(Ract,BetaBol,Etot,CalledBefore - & ,SampleThis) -* -*------ The Microsteps. -* - Do 2001, iMicro=1,nMicro - Call Timing(Cpu1,Tim1,Tim2,Tim3) - Eold=Etot - iSnurr=iSnurr+1 -* -*-------- Generate new configuration, both solvent and QM-region. -* - Call GeoGen(Ract,Rold,iCNum,iQ_Atoms) -* -*-------- Compute Solvent-solvent interaction. -* - Call ClasClas(iCNum,iCStart,ncParm,Coord,iFP,iGP,iDT,iFI,iDist - & ,iDistIm,Elene,Edisp,Exrep,E2Die,ExDie) - Call QMPosition(EHam,Cordst,Coord,Forcek,dLJrep,Ract,iQ_Atoms) - Call Timing(Cpu2,Tim1,Tim2,Tim3) - timeCLAS=timeCLAS+(Cpu2-Cpu1) -*--------------------------------------------------------------------------* -* Work a bit with the quantum part. * -*--------------------------------------------------------------------------* - Do 4002, i=1,3 - xyzMyQ(i)=0 !Dipoles for the QM-part, see polink.f. - xyzMyI(i)=0 -4002 Continue - nSize=3*nPol*nPart - Do 400, i=1,iCi !Allocate memory for the field on the QM-mol. - Do 4000, j=1,10 !iCi: number of quantum molecule sites. - Write(MemQFal,'(A,i2.2,i2.2)')'Falt',i,j - Call GetMem(MemQFal,'Allo','Real',iFil(i,j),nSize) -4000 Continue -400 Continue - Do 401, i=1,iCi - Do 402, j=1,10 !Charges (1),Dipoles(3),Quadrupoles(6) - Do 403, k=1,nPart*nPol !Classical polarisation sites - !including quantum molecule. - Work(iFil(i,j)-1+k)=0.0d0 - Work(iFil(i,j)-1+k+nPart*nPol)=0.0d0 - Work(iFil(i,j)-1+k+2*nPart*nPol)=0.0d0 -403 Continue - Eint(i,j)=0.0d0 -402 Continue - If (i.le.MxAt) Eint_Nuc(i)=0.0d0 -401 Continue -* -*-------- Compute the exchange operator. -* - Call ExRas(iCStart,nBaseQ,nBaseC,nCnC_C,iQ_Atoms - & ,nAtomsCC,Ax,Ay,Az,iTriState,Smat,SmatPure - & ,InCutOff,ipAOSum) - Call Timing(Cpu3,Tim1,Tim2,Tim3) - timeEX=timeEX+(Cpu3-Cpu2) -* -*------ Electrostatics commencing. -* -* -*------ Compute various gradients of 1/r. -* - If(lSlater) then - Call OneOverR_Sl(iFil,Ax,Ay,Az,BoMaH,BoMaO,EEDisp - & ,iCNum,Eint,iQ_Atoms,outxyzRAS - & ,Eint_Nuc) - Else - Call OneOverR(iFil,Ax,Ay,Az,BoMaH,BoMaO,EEDisp - & ,iCNum,Eint,iQ_Atoms,outxyzRAS) - Endif - -* -*----- Couple the point-charges in the solvent to the QM-region. -* - Call HelState(Eint,nState,iCi,RasCha,RasDip,RasQua,Vmat - & ,iPrint) -* -*----- Let QM-region and solvent polarize. -* - Call PolRas(iDist,iDistIM,iDT,iFI,iFP,iFil,iCStart - & ,iTriState,VMat,Smat,DiFac,Ract,iCNum,Energy - & ,nVarv,iSTC,Haveri,iQ_Atoms,ip_ExpVal,Poli) -* -*----- Energy from QM-nuclei interacting with solvent field. -* - If(lSlater) then - Do 702, i=1,iQ_Atoms - Energy=Energy-Eint_Nuc(i)*ChaNuc(i) -702 Continue - Else - Do 703, i=1,iQ_Atoms - Energy=Energy-Eint(i,1)*ChaNuc(i) -703 Continue - Endif -* -*----- Some additional boost of short-range repulsion. -* - Call BoostRep(AddRep,SmatPure,iSTC,nState,InCutOff) -* -*----- Sum-up what we will call QM-region energy. -* - Energy=Energy-EEdisp+AddRep -*----------------------------------------------------------------------* -* Final induction and reaction field energies. * -*----------------------------------------------------------------------* - Call ReaInd(iGP,iDT,iDistIm,iCNum,IndMa,NcParm,Sum1,s90um) - Call Timing(Cpu4,Tim1,Tim2,Tim3) - timeEL=timeEL+(Cpu4-Cpu3) -*----------------------------------------------------------------------* -* Construct the final energy. * -*----------------------------------------------------------------------* - EnCLAS=Elene+EHam-Edisp+Exrep+E2Die+ExDie - Etot=EnCLAS-0.5*S90um-Sum1+Gamma*Ract**3+Energy+Gam*Ract**2 - Dele=Etot-Eold -*----------------------------------------------------------------------* -* Printing and various if requsted. * -*----------------------------------------------------------------------* - If(iPrint.ge.10) then - If(Haveri) Etot=999999 - Write(6,*) - Write(6,*)' ----Microstep',iMicro - Write(6,*)' Number of iterations:',nVarv - Write(6,*)' Total energy:',Etot - Write(6,*)' Of which is' - Write(6,*)' Pairwise solvent-solvent interaction' - &//':',EnCLAS - Write(6,*)' Solvent-solvent Electrostatic' - &,Elene - Write(6,*)' Harmonic Spring:',EHam - Write(6,*)' Solvent-solvent Dispersion:',-Edisp - Write(6,*)' Solvent-solvent Exchange:',Exrep - Write(6,*)' Energy of induced dipoles in field f' - &//'rom explicit solvent:',-Sum1 - Write(6,*)' Energy of solvent charge distributio' - &//'n in reaction field:',-0.5*S90um - Write(6,*)' Solvent E-interaction with image:' - &,E2Die - Write(6,*)' Solvent Repulsion with boundary:' - &,ExDie - Write(6,*)' Solvent-Solute dispersion:',EEdisp - Write(6,*)' Energy of QM-region:',Energy - Write(6,*)' Higher order overlap exchange pair' - &//'-term:',AddRep - Write(6,*)' Surface tension term:',Gam*Ract**2 - Write(6,*)' Volume-pressure term:',Gamma*Ract**3 - Write(6,*)' Previous accepted energy:',Eold - Write(6,*)' Difference:',Dele - Write(6,*)' Total dipole in QM-region:(',-xyzMyQ(1), - &',',-xyzMyQ(2),',',-xyzMyQ(3),')' - Write(6,*)' Radie:',Ract - If(Haveri) then - Write(6,*)' WARNING! SOME OF THE NUMBERS ABOVE HAVE N' - &//'O MEANING SINCE THE POLARIZATION DID NOT CONVERGE!!!' - GoTo 8194 - Endif - Endif - -* -*-- If we are collecting stuff from a sampfile, now is the time to put -* data on the extract file. If center-specific expectation values -* are requested, call Allen. -* - If(iRead.eq.9) then - If(lExtr(6)) then - E_Nuc_Rubbet=0.0d0 - If(lSlater) then - Do 6347, iAt=1,iQ_Atoms - E_Nuc_Rubbet=E_Nuc_Rubbet - & -(Eint_Nuc(iAt)+Poli(iAt,1))*ChaNuc(iAt) -6347 Continue - Else - Do 6348, iAt=1,iQ_Atoms - E_Nuc_Rubbet=E_Nuc_Rubbet - & -(Eint(iAt,1)+Poli(iAt,1))*ChaNuc(iAt) -6348 Continue - Endif - Endif - If(lExtr(7)) then - Call AllenGinsberg('RASSI',Eint,Poli,ChaNuc,RasCha,RasDip - & ,RasQua,MxStOT,iSTC,nState,iExtr_Atm - & ,lExtr(4),iExtr_Eig,iQ_Atoms - & ,ip_ExpCento,E_Nuc_Part,lSlater - & ,Eint_Nuc) - Endif - Call Extract(iLuExtr,i9,Etot,xyzMyQ,HMatState,iSTC,iDt - & ,nState,HMatSOld,xyzQuQ,ip_ExpVal,ip_ExpCento - & ,E_Nuc_Rubbet,E_Nuc_Part) -****JoseMEP********** - ! If MEP option. Add electr. potential, field, etc - ! for all solvent config. - If(lExtr(8)) then - Labjhr='Add ' - Call AverMEP(Labjhr,Eint,Poli,iCi,SumElcPot - & ,NCountField,PertElcInt,iONE - & ,iONE,[iONE],[iONE],iONE) - NCountField=NCountField+1 - Endif -******* - GoTo 9090 - Endif - -* -*-- Resume the MC-wrap up. -* - Dele=Dele*BetaBol - DidWeAccept=.true. - If(Dele.lt.0) then - iAcc=iAcc+1 - Else - Expe=Exp(-Dele) - Expran=ranf(iseed) - If(iPrint.ge.10) then - Write(6,*)' Positive energy change!' - Write(6,*)' Boltzmann weight:',Expe - Write(6,*)' Random number:',ExpRan - Endif - iAcc=iAcc+1 - If(Expe.lt.ExpRan) then - Call Oldge(iAcc,Etot,Eold,Ract,Rold) - DidWeAccept=.false. - If(iPrint.ge.10) then - Write(6,*)' Not accepted!' - Endif - Endif - Endif - If(DidWeAccept)Esav=Esav+Etot -*----------------------------------------------------------------------* -* If this is a production run, then put stuff on the sampfile. * -*----------------------------------------------------------------------* - If(QmProd.and.iRead.ne.9) then - If(SampleThis) then - If(Inter.ne.0) then - Inte=(iSnurr/Inter)*Inter - If(Inte.eq.((iMacro-1)*nMicro+iMicro)) then - Call Put9(Etot,Ract,iDT,iHowMSampUT,Gamma,Gam,Esav - & ,iDisk) - Endif - Endif - Endif - Endif - -* -*-- Free memory. -* -9090 Continue - nSize=(nClas*(nClas-1)/2)*(nCent**2) - nSizeIm=(nClas*nCent)**2 - Call GetMem('DistMat','Free','Real',iDist,nSize) - Call GetMem('DistMatIm','Free','Real',iDistIm,nSizeIm) - Do 90001,i=1,3 - Write(ChCo,'(I1.1)')i - Write(MemLabel,*)'FP'//ChCo - Write(MemLaabe,*)'GP'//ChCo - Write(MemLaaab,*)'DT'//ChCo - Write(MemLaaaa,*)'FI'//ChCo - Call GetMem(MemLabel,'Free','Real',iFP(i),IndMa) - Call GetMem(MemLaabe,'Free','Real',iGP(i),IndMa) - Call GetMem(MemLaaab,'Free','Real',iDT(i),IndMa) - Call GetMem(MemLaaaa,'Free','Real',iFI(i),IndMa) -90001 Continue - nSize=3*nPol*nPart - Do 90002, i=1,iCi - Do 90003, j=1,10 - Write(ChCo,'(I2.2)')i - Write(ChCo2,'(I2.2)')j - Write(MemQFal,*)'Falt'//ChCo//ChCo2 - Call GetMem(MemQFal,'Free','Real',iFil(i,j),nSize) -90003 Continue -90002 Continue - Call GetMem('Coeff','Free','Real',iSTC,nState**2) - Call Timing(Cpu5,Tim1,Tim2,Tim3) - timeMC=timeMC+(Cpu5-Cpu4) - -*---------------------------------------------------------------------* -*-- End of Microstep. * -* * -*---------------------------------------------------------------------* -2001 Continue -*---------------------------------------------------------------------* -*-- Have we collected all sampled configurations? If no, go up again. * -* If yes, then close some files and take a little jump downwards to * -* the END!!! * -*---------------------------------------------------------------------* -*Jose*************************************** -* This point is also used to perform the Average of the Potential, -* Field and Field gradients to obtain and average Electrostatic -* perturbation. The Non-Electr. perturbation is also obtained here -* it will be added directly to the One-electron file. -******************************************* - - If(i9.lt.iHowMSampIN.and.iRead.eq.9) then - GoTo 58886 - Elseif(i9.ge.iHowMSampIN.and.iRead.eq.9) then -******JoseMEP** - ! If MEP option. Obtain the mean Potential, Field - ! and Field Gradients. - ! It si also obtained the average of the Non-Electrostatic - ! perturbation - If(lExtr(8)) then - Labjhr='Aver' - Call AverMEP(Labjhr,Eint,Poli,iCi,SumElcPot - & ,NCountField,PertElcInt,iONE - & ,iONE,[iONE],[iONE],iONE) - AverFact=1.0d0/Dble(NCountField) - Call DaxPy_(iTriBasQ,AverFact,Work(ipAOSum),iONE - & ,PertNElcInt,iONE) - Call GetMem('SumOvlAOQ','Free','Real',ipAOSum,iTriBasQ) - Endif -********* - - Call DaClos(iLuSaIn) - Close(iLuExtr) - GoTo 58887 - Endif -*----------------------------------------------------------------------* -* Write to startfile. * -*----------------------------------------------------------------------* -8194 Continue - ESav=Esav/Dble(iAcc) - Call Put8(Ract,Etot,Gamma,Gam,ESav) - If(Haveri) Call Quit(_RC_NOT_CONVERGED_) -*----------------------------------------------------------------------* -* Print some things here at the end of the macrostep. * -*----------------------------------------------------------------------* - If(.not.ParallelT) then - jMacro=iMacro - Else - jMacro=1+(iMacro-1)/nTemp - Endif - Write(6,'(A,i4)')'---Macrostep ',jMacro - Write(6,'(A,i4)')' Number of microsteps:',nMicro - Pr=100.0d0*(Dble(iAcc)/Dble(nMicro)) - Write(6,'(A,i4,A,f5.1,A)')' Number of acceptances:',iAcc,'(' - & ,Pr,'%)' - Write(6,'(A,f12.4)')' Radie (a.u.):',Ract - Write(6,'(A,f16.8)')' Average Energy (a.u.) in Macrostep:' - & ,Esav - Write(6,'(A,3(f12.4))')' Total dipole in QM-region last mic' - &//'rostep (a.u.):',-xyzMyQ(1),-xyzMyQ(2),-xyzMyQ(3) - Write(6,*) - Call xFlush(6) -*--------------------------------------------------------------------------* -* End of Macrostep. * -*--------------------------------------------------------------------------* -2000 Continue -*----------------------------------------------------------------------* -* Put some things on info-file. Used to make tests. * -*----------------------------------------------------------------------* - Call Add_Info('Total Energy',[Etot],1,6) - Call Add_Info('Induction of system',[Sum1],1,6) - Call Add_Info('React. field int.',[s90um],1,6) - Call Add_Info('Solv-Solu Disp.',[EEdisp],1,6) - Call Add_Info('QM-region Energy',[Energy],1,6) - Call Add_Info('QM-region dipole',xyzMyQ,3,5) - RRRnVarv=dble(nVarv) - Call Add_Info('Pol.Iterations',[RRRnVarv],1,8) -*----------------------------------------------------------------------* -* Close some external files. * -*----------------------------------------------------------------------* -58887 Continue - If(QmProd.and.iRead.ne.9) then - iDisk=0 - iDum(1)=iHowMSampUT - Call iDaFile(iLuSaUt,1,iDum,1,iDisk) - Call DaClos(iLuSaUt) - Endif -*--------------------------------------------------------------------------* -* The End... be happy! * -*--------------------------------------------------------------------------* - If(MoAveRed) then - nB=nRedMO - ip_UNCLE_MOE=ipAvRed - Else - nB=nBaseQ - Endif - nSizeBig=nState*(nState+1)*nB*(nB+1)/4 - - Write(6,*) - Write(6,*) - Write(6,*)' Time statistics. (hour:minute:second)' - Write(6,*)' -----------------------------------------------------' - it1h=int(timeCLAS)/3600 - it1m=int(timeCLAS-it1h*3600)/60 - t1s=timeCLAS-it1h*3600-it1m*60 - Write(6,9)' Time spent on pair-wise solvent-solvent interaction' - &//'s: ',it1h,':',it1m,':',t1s - it2h=int(timeEX)/3600 - it2m=int(timeEX-it2h*3600)/60 - t2s=timeEX-it2h*3600-it2m*60 - Write(6,9)' Time spent on solvent-solute overlap calculations: ' - &,it2h,':',it2m,':',t2s - it3h=int(timeEL)/3600 - it3m=int(timeEL-it3h*3600)/60 - t3s=timeEL-it3h*3600-it3m*60 - Write(6,9)' Time spent on solvent and solute electrostatic inte' - &//'raction: ',it3h,':',it3m,':',t3s - it4h=int(timeMC)/3600 - it4m=int(timeMC-it4h*3600)/60 - t4s=timeMC-it4h*3600-it4m*60 - Write(6,9)' Time spent on the Metropolis-Monte Carlo decision: ' - &,it4h,':',it4m,':',t4s -9 Format(A,I4,A,I3,A,F5.2) - - Return - End diff -Nru openmolcas-22.02/src/qmstat/eqras.F90 openmolcas-22.10/src/qmstat/eqras.F90 --- openmolcas-22.02/src/qmstat/eqras.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/eqras.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,582 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine EqRas(iQ_Atoms,nAtomsCC,Coord,nBas,nBas_C) + +use qmstat_global, only: AvElcPot, CAFieldG, CBFieldG, CFexp, ChaNuc, CordIm, Cordst, DelFi, DelR, DelX, Diel, DispDamp, dLJrep, & + FieldDamp, Forcek, HmatState, iExtr_Eig, iExtra, iLuSaIn, iLuSaUt, info_atom, Inter, iPrint, iRead, & + iSeed, lExtr, lSlater, nAtom, nCent, nMacro, nMicro, nPart, nPol, nState, nTemp, OldGeo, outxyzRAS, & + PertNElcInt, Pres, Qmeq, QmProd, ParallelT, RasCha, RasDip, RasQua, rStart, SaFilIn, SaFilUt, SimEx, & + SURF, Temp, xyzMyI, xyzMyQ, xyzQuQ +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Three, Four, Ten, Half, Pi, Angstrom, atmToau, auTokJ, deg2rad, KBoltzmann +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iQ_Atoms, nAtomsCC, nBas(1), nBas_C(1) +real(kind=wp), intent(in) :: Coord(3,iQ_Atoms) +integer(kind=iwp) :: i, i9, iAcc, iAt, iCi, iCNum, iCStart, iDisk, iDiskSa, iDum(1), iHowMSampIN, iHowMSampUT, iLuExtr, iMacro, & + iMicro, IndMa, Inte, iProdMax, iSnurr, it1h, it1m, it2h, it2m, it3h, it3m, it4h, it4m, iTriBasQ, iTriState, & + jMacro, nBaseC, nBaseQ, nClas, NCountField, nVarv +real(kind=wp) :: AddRep, Ax, Ay, Az, BetaBol, Cpu1, Cpu2, Cpu3, Cpu4, Cpu5, dele, DiFac, Dum, E2Die, E_Nuc_Part, E_Nuc_Rubbet, & + Edisp, EEDisp, EHam, Elene, EnCLAS, Energy, Eold, Esav, Etot, Exrep, Expe, Expran, ExDie, Gam, Gmma, & + PertElcInt(1), Pr, Ract, Rold, RRRnVarv, s90um, Sum1, t1s, t2s, t3s, t4s, Tim1, Tim2, Tim3, timeCLAS, timeEL, & + timeEX, timeMC +logical(kind=iwp) :: CalledBefore, DidWeAccept, Exists, Haveri, InCutOff, Loop, SampleThis, Skip +character(len=200) :: Head +character(len=4) :: Labjhr +real(kind=wp), allocatable :: AOSum(:), BoMaH(:), BoMaO(:), Dist(:,:,:), DistIm(:,:,:,:), DT(:,:), Eint(:,:), Eint_Nuc(:), & + ExpCento(:,:), ExpVal(:,:), FI(:,:), Fil(:,:,:,:), FP(:,:), GP(:,:), Poli(:,:), Smat(:), & + SmatPure(:), STC(:,:), SumElcPot(:,:), Vmat(:) +real(kind=wp), parameter :: BoltzK = 1.0e-3_wp*KBoltzmann/auTokJ, & + ExLim = Ten !Over how long distance the exchange rep. is computed, the solv-solv. +integer(kind=iwp), external :: IsFreeUnit +real(kind=wp), external :: Random_Molcas +#include "warnings.h" +!****Jose** Interaction with Slater type to consider Penetration +! Eint_Nuc +!****JoseMEP**New variables for the MEP calculation +! SumElcPot, PertElcInt, Labjhr + +! Enter eqras. + +! Numbers, initializations, conversions. + +Ract = rStart !Initial radie +delX = delX/Angstrom !angstrom-->bohr +delFi = delFi*deg2rad !degree-->radian +delR = delR/Angstrom !angstrom-->bohr +CalledBefore = .false. +SampleThis = .true. +if (ParallelT) nMacro = nTemp*nMacro + +! If we have vacuum, then no volume-pressure work is done, nor do we +! have any cavitation free-energy. + +if ((abs(Diel-One) > 1.0e-4_wp) .and. (SURF > Zero)) then + Gmma = Pres*Four/Three*Pi*atmToau + Gam = 5.973455e-4_wp/74.0_wp*SURF !What are these numbers? Is 74.0 supposed to be the surface tension of water in mN/m? +else + Gmma = Zero + Gam = Zero +end if + +! More numbers. + +if (Temp <= Zero) then + BetaBol = 1.0e23_wp +else + BetaBol = One/(Temp*BoltzK) +end if +DiFac = -(Diel-One)/(Diel+One) +Expran = Zero +iHowMSampIN = 0 +iHowMSampUT = 0 +nBaseC = nBas_C(1) +nBaseQ = nBas(1) +iTriBasQ = nTri_Elem(nBaseQ) +iTriState = nTri_Elem(nState) +iCi = nTri_Elem(iQ_Atoms) +timeCLAS = Zero +timeEX = Zero +timeEL = Zero +timeMC = Zero + +! If some damping has been requested, prepare it here and print. + +if ((DispDamp .or. FieldDamp) .and. (iPrint >= 8)) then + write(u6,*) + write(u6,*) '-----Various damping data.' + write(u6,*) +end if +call mma_allocate(BoMaH,iQ_Atoms,label='BoMaH') +call mma_allocate(BoMaO,iQ_Atoms,label='BoMaO') + +! Construct the Born-Mayer parameters, a la Brdarski-Karlstrom +if (DispDamp) call BornMayerBK(iQ_Atoms,BoMaH,BoMaO) + +! Damping of field. + +if (FieldDamp .and. (iPrint >= 8)) then + write(u6,*) ' Damping the field between Qm-region and solvent.' + write(u6,*) ' E_damp=E_0*(1-exp(alpha*distance))^N' + write(u6,*) ' alpha(QM-oxygen) =',CAFieldG + write(u6,*) ' alpha(QM-hydrogen) =',CBFieldG + write(u6,*) ' N =',CFexp +end if + +! Check what type of simulation to run, and generate some output of utmost beauty. + +call mma_allocate(SumElcPot,iCi,10,label='SumElcPot') + +if (Qmeq .and. (iRead /= 9)) then + call NiceOutPut('EIQ') +else if (QmProd .and. (iRead /= 9)) then + call NiceOutPut('PIQ') + call DaName(iLuSaUt,SaFilUt) + iDisk = 0 !Put some dummy on the sampfile so we have space for the real number later. + iDum(1) = iHowMSampUT + call iDaFile(iLuSaUt,1,iDum,1,iDisk) + ! Below we make a check for extreme cases. Our algorithm to + ! select sampling configurations sets this limit. + iProdMax = (2**30-1)*2 + if ((nMacro*nMicro) >= iProdMax) then + write(u6,*) + write(u6,*) 'WARNING! Too large numbers for nMacro and nMicro to run production!' + write(u6,*) ' Their product must not be greater than 2**31!' + write(u6,*) ' If you wish to make such large samples, you can run several samplings and collect several sampfiles.' + call Quit(_RC_INTERNAL_ERROR_) + end if +else if (iRead == 9) then + ! If we read from sampfile: open the + ! sampfile and read how many configurations and open extract file. + call NiceOutPut('SSS') + call DaName(iLuSaIn,SaFilIn) + iDiskSa = 0 + call iDaFile(iLuSaIn,2,iDum,1,iDiskSa) + iHowMSampIN = iDum(1) + iLuExtr = IsFreeUnit(54) + call OpnFl(SimEx,iLuExtr,Exists) + write(iLuExtr,*) 'Extract-File' + write(iLuExtr,*) + ! And put some words in the output + write(u6,*) + write(u6,*) ' Total number of sampled configurations:',iHowMSampIN + write(u6,*) ' Reading from the file ',SaFilIn + write(u6,*) ' Summarizing data put on ',SimEx + !*****JoseMEP + ! If we perform MEP calculation, first we make some zeros and allocate some memory. + if (lExtr(8)) then + call mma_allocate(AvElcPot,iCi,10,label='AvElcPot') + SumElcPot(:,:) = Zero + AvElcPot(:,:) = Zero + NCountField = 0 + + PertNElcInt(:) = Zero + call mma_allocate(AOSum,iTriBasQ,label='SumOvlAOQ') + AOSum(:) = Zero + end if + !********* +else + write(u6,*) + write(u6,*) 'An invalid number of iRead detected.' + call Quit(_RC_INTERNAL_ERROR_) +end if +if (.not. allocated(AOSum)) call mma_allocate(AOSum,0,label='SumOvlAOQ') +!----------------------------------------------------------------------* +! If we have input file, then read from it. * +!----------------------------------------------------------------------* +call mma_allocate(Fil,nPol*nPart,3,iCi,10,label='Fil') +call mma_allocate(Eint,iCi,10,label='Eint') +call mma_allocate(Eint_Nuc,iQ_Atoms,label='Eint_Nuc') +call mma_allocate(Poli,iCi,10,label='Poli') +call mma_allocate(Smat,iTriState,label='Smat') +call mma_allocate(Vmat,iTriState,label='Vmat') +call mma_allocate(SmatPure,iTriState,label='SmatPure') +call mma_allocate(STC,nState,nState,label='Coeff') +call mma_allocate(ExpVal,4,nState,label='ExpVals') +call mma_allocate(ExpCento,4,nState,label='ExpCento') +if (.not. allocated(CordIm)) call mma_allocate(CordIm,3,nPart*nCent,label='CordIm') +iCStart = (((iQ_Atoms-1)/nAtom)+1)*nCent+1 +iCNum = (iCStart-1)/nCent +i9 = 0 !i9 is active if iRead == 9 and we are collecting configurations from the sampfile. +outer: do + Loop = .false. + i9 = i9+1 + if ((iRead <= 8) .and. (iRead >= 6)) then + call Get8(Ract,Dum) + else if (iRead == 9) then + call Get9(Ract,Coord,info_atom,iQ_Atoms,iDiskSa) + else + if (iExtra > 0) call NyPart(iExtra,nPart,Cordst,rStart,nCent,iSeed) + if (iPrint >= 10) then + write(Head,*) 'Coordinates of the initial distribution.' + call Cooout(Head,Cordst,nPart,nCent) + end if + end if + + ! Give a startvalue for the Total energy. The effect is that we + ! always accept the first microstep. + + Etot = 1.0e10_wp + + ! Some numbers. + + nClas = nPart-iCNum + IndMa = nPart*nPol + + ! Put QM-molecule in its place. + + if ((iRead == 8) .or. (iRead == 0)) then + call PlaceIt(Coord,iQ_Atoms,iCNum) + else if (iRead == 6) then + call PlaceIt9(Coord,Cordst,info_atom,iQ_Atoms) + if (iPrint >= 10) then + write(Head,*) 'CM-centred coordinates after substitution.' + call Cooout(Head,Cordst,nPart,nCent) + end if + end if + + !--------------------------------------------------------------------* + ! * + !------------------------- START SIMULATION -------------------------* + ! * + !--------------------------------------------------------------------* + + iSnurr = 0 !How many steps taken totally. + + ! The Macrosteps. + + do iMacro=1,nMacro + Esav = Zero + if (iRead == 9) then + iAcc = 1 + else + iAcc = 0 + end if + + ! If we are running parallel tempering, then... + if (ParallelT) call ParaRoot(Ract,BetaBol,Etot,CalledBefore,SampleThis) + + ! The Microsteps. + + Skip = .false. + do iMicro=1,nMicro + call Timing(Cpu1,Tim1,Tim2,Tim3) + Eold = Etot + iSnurr = iSnurr+1 + + ! Generate new configuration, both solvent and QM-region. + + call GeoGen(Ract,Rold,iCNum,iQ_Atoms) + + ! Compute Solvent-solvent interaction. + + call mma_allocate(FP,3,nPol*nPart,label='FP') + call mma_allocate(GP,3,nPol*nPart,label='GP') + call mma_allocate(DT,3,nPol*nPart,label='DT') + call mma_allocate(FI,3,nPol*nPart,label='FI') + call mma_allocate(Dist,nCent,nCent,nTri_Elem(nClas-1),label='Dist') + call mma_allocate(DistIm,nCent,nClas,nCent,nClas,label='DistIm') + call ClasClas(iCNum,nClas,FP,GP,DT,FI,Dist,DistIm,Elene,Edisp,Exrep,E2Die,ExDie) + call QMPosition(EHam,Cordst,Coord(:,1),Forcek,dLJrep,Ract,iQ_Atoms) + call Timing(Cpu2,Tim1,Tim2,Tim3) + timeCLAS = timeCLAS+(Cpu2-Cpu1) + !----------------------------------------------------------------* + ! Work a bit with the quantum part. * + !----------------------------------------------------------------* + xyzMyQ(:) = Zero !Dipoles for the QM-part, see polink. + xyzMyI(:) = Zero + Fil(:,:,:,:) = Zero + Eint(:,:) = Zero + Eint_Nuc(:) = Zero + + ! Compute the exchange operator. + + call ExRas(iCStart,nBaseQ,nBaseC,iQ_Atoms,nAtomsCC,Ax,Ay,Az,iTriState,Smat,SmatPure,InCutOff,AOSum) + call Timing(Cpu3,Tim1,Tim2,Tim3) + timeEX = timeEX+(Cpu3-Cpu2) + + ! Electrostatics commencing. + + ! Compute various gradients of 1/r. + + if (lSlater) then + call OneOverR_Sl(Fil,Ax,Ay,Az,BoMaH,BoMaO,EEDisp,iCNum,Eint,iQ_Atoms,outxyzRAS,Eint_Nuc) + else + call OneOverR(Fil,Ax,Ay,Az,BoMaH,BoMaO,EEDisp,iCNum,Eint,iQ_Atoms,outxyzRAS) + end if + + ! Couple the point-charges in the solvent to the QM-region. + + call HelState(Eint,nState,iCi,RasCha,RasDip,RasQua,Vmat) + + ! Let QM-region and solvent polarize. + call PolRas(Dist,DistIM,DT,FI,FP,Fil,iCStart,iTriState,VMat,Smat,DiFac,Ract,iCNum,Energy,nVarv,STC,Haveri,iQ_Atoms,ExpVal, & + Poli) + + ! Energy from QM-nuclei interacting with solvent field. + + if (lSlater) then + do i=1,iQ_Atoms + Energy = Energy-Eint_Nuc(i)*ChaNuc(i) + end do + else + do i=1,iQ_Atoms + Energy = Energy-Eint(i,1)*ChaNuc(i) + end do + end if + + ! Some additional boost of short-range repulsion. + + call BoostRep(AddRep,SmatPure,STC,nState,InCutOff) + + ! Sum-up what we will call QM-region energy. + + Energy = Energy-EEdisp+AddRep + + !----------------------------------------------------------------* + ! Final induction and reaction field energies. * + !----------------------------------------------------------------* + call ReaInd(GP,DT,DistIm,iCNum,IndMa,nClas,Sum1,s90um) + call Timing(Cpu4,Tim1,Tim2,Tim3) + timeEL = timeEL+(Cpu4-Cpu3) + !----------------------------------------------------------------* + ! Construct the final energy. * + !----------------------------------------------------------------* + EnCLAS = Elene+EHam-Edisp+Exrep+E2Die+ExDie + Etot = EnCLAS-Half*S90um-Sum1+Gmma*Ract**3+Energy+Gam*Ract**2 + Dele = Etot-Eold + !----------------------------------------------------------------* + ! Printing and various if requested. * + !----------------------------------------------------------------* + if (iPrint >= 10) then + if (Haveri) Etot = 999999.0_wp + write(u6,*) + write(u6,*) ' ----Microstep',iMicro + write(u6,*) ' Number of iterations:',nVarv + write(u6,*) ' Total energy:',Etot + write(u6,*) ' Of which is' + write(u6,*) ' Pairwise solvent-solvent interaction:',EnCLAS + write(u6,*) ' Solvent-solvent Electrostatic',Elene + write(u6,*) ' Harmonic Spring:',EHam + write(u6,*) ' Solvent-solvent Dispersion:',-Edisp + write(u6,*) ' Solvent-solvent Exchange:',Exrep + write(u6,*) ' Energy of induced dipoles in field from explicit solvent:',-Sum1 + write(u6,*) ' Energy of solvent charge distribution in reaction field:',-Half*S90um + write(u6,*) ' Solvent E-interaction with image:',E2Die + write(u6,*) ' Solvent Repulsion with boundary:',ExDie + write(u6,*) ' Solvent-Solute dispersion:',EEdisp + write(u6,*) ' Energy of QM-region:',Energy + write(u6,*) ' Higher order overlap exchange pair-term:',AddRep + write(u6,*) ' Surface tension term:',Gam*Ract**2 + write(u6,*) ' Volume-pressure term:',Gmma*Ract**3 + write(u6,*) ' Previous accepted energy:',Eold + write(u6,*) ' Difference:',Dele + write(u6,*) ' Total dipole in QM-region:(',-xyzMyQ(1),',',-xyzMyQ(2),',',-xyzMyQ(3),')' + write(u6,*) ' Radie:',Ract + if (Haveri) then + write(u6,*) ' WARNING! SOME OF THE NUMBERS ABOVE HAVE NO MEANING SINCE THE POLARIZATION DID NOT CONVERGE!!!' + Skip = .true. + exit + end if + end if + + ! If we are collecting stuff from a sampfile, now is the time to put + ! data on the extract file. If center-specific expectation values + ! are requested, call Allen. + + if (iRead == 9) then + if (lExtr(6)) then + E_Nuc_Rubbet = Zero + if (lSlater) then + do iAt=1,iQ_Atoms + E_Nuc_Rubbet = E_Nuc_Rubbet-(Eint_Nuc(iAt)+Poli(iAt,1))*ChaNuc(iAt) + end do + else + do iAt=1,iQ_Atoms + E_Nuc_Rubbet = E_Nuc_Rubbet-(Eint(iAt,1)+Poli(iAt,1))*ChaNuc(iAt) + end do + end if + end if + if (lExtr(7)) call AllenGinsberg('RASSI',Eint,Poli,ChaNuc,RasCha,RasDip,RasQua,STC,nState,lExtr(4),iExtr_Eig,iQ_Atoms, & + ExpCento,E_Nuc_Part,lSlater,Eint_Nuc) + + call Extract(iLuExtr,i9,Etot,xyzMyQ,HMatState,STC,nState,xyzQuQ,ExpVal,ExpCento,E_Nuc_Rubbet,E_Nuc_Part) + !***JoseMEP********** + ! If MEP option. Add electr. potential, field, etc. for all solvent config. + if (lExtr(8)) then + Labjhr = 'Add ' + call AverMEP(Labjhr,Eint,Poli,iCi,SumElcPot,NCountField,PertElcInt,1,1,[1],[1],1) + NCountField = NCountField+1 + end if + !******** + else + ! Resume the MC-wrap up. + + Dele = Dele*BetaBol + DidWeAccept = .true. + if (Dele < Zero) then + iAcc = iAcc+1 + else + Expe = exp(-Dele) + Expran = Random_Molcas(iSeed) + if (iPrint >= 10) then + write(u6,*) ' Positive energy change!' + write(u6,*) ' Boltzmann weight:',Expe + write(u6,*) ' Random number:',ExpRan + end if + if (Expe >= ExpRan) then + iAcc = iAcc+1 + else + Etot = Eold + Ract = Rold + Cordst(:,:) = OldGeo + DidWeAccept = .false. + if (iPrint >= 10) write(u6,*) ' Not accepted!' + end if + end if + if (DidWeAccept) Esav = Esav+Etot + !--------------------------------------------------------------* + ! If this is a production run, then put stuff on the sampfile. * + !--------------------------------------------------------------* + if (QmProd .and. (iRead /= 9)) then + if (SampleThis) then + if (Inter /= 0) then + Inte = (iSnurr/Inter)*Inter + if (Inte == ((iMacro-1)*nMicro+iMicro)) call Put9(Etot,Ract,iHowMSampUT,Gmma,Gam,Esav,iDisk) + end if + end if + end if + end if + + ! Free memory. + + call mma_deallocate(Dist) + call mma_deallocate(DistIm) + call mma_deallocate(FP) + call mma_deallocate(GP) + call mma_deallocate(DT) + call mma_deallocate(FI) + call Timing(Cpu5,Tim1,Tim2,Tim3) + timeMC = timeMC+(Cpu5-Cpu4) + + !----------------------------------------------------------------* + ! End of Microstep. * + !----------------------------------------------------------------* + end do + !------------------------------------------------------------------* + ! Have we collected all sampled configurations? If no, go up again.* + ! If yes, then close some files and take a little jump downwards to* + ! the END!!! * + !------------------------------------------------------------------* + !Jose*************************************** + ! This point is also used to perform the Average of the Potential, + ! Field and Field gradients to obtain and average Electrostatic + ! perturbation. The Non-Electr. perturbation is also obtained here + ! it will be added directly to the One-electron file. + !****************************************** + + if (.not. Skip) then + if ((i9 < iHowMSampIN) .and. (iRead == 9)) then + cycle outer + else if ((i9 >= iHowMSampIN) .and. (iRead == 9)) then + !*****JoseMEP** + ! If MEP option. Obtain the mean Potential, Field and Field Gradients. + ! It is also obtained the average of the Non-Electrostatic perturbation + if (lExtr(8)) then + Labjhr = 'Aver' + call AverMEP(Labjhr,Eint,Poli,iCi,SumElcPot,NCountField,PertElcInt,1,1,[1],[1],1) + + PertNElcInt(:) = PertNElcInt+AOSum/real(NCountField,kind=wp) + call mma_deallocate(AOSum) + end if + !******** + + call DaClos(iLuSaIn) + close(iLuExtr) + exit outer + end if + end if + !------------------------------------------------------------------* + ! Write to startfile. * + !------------------------------------------------------------------* + ESav = Esav/real(iAcc,kind=wp) + call Put8(Ract,Etot,Gmma,Gam,ESav) + if (Haveri) call Quit(_RC_NOT_CONVERGED_) + !------------------------------------------------------------------* + ! Print some things here at the end of the macrostep. * + !------------------------------------------------------------------* + if (.not. ParallelT) then + jMacro = iMacro + else + jMacro = 1+(iMacro-1)/nTemp + end if + write(u6,'(A,i4)') '---Macrostep ',jMacro + write(u6,'(A,i4)') ' Number of microsteps:',nMicro + Pr = 100.0_wp*(real(iAcc,kind=wp)/real(nMicro,kind=wp)) + write(u6,'(A,i4,A,f5.1,A)') ' Number of acceptances:',iAcc,'(',Pr,'%)' + write(u6,'(A,f12.4)') ' Radie (a.u.):',Ract + write(u6,'(A,f16.8)') ' Average Energy (a.u.) in Macrostep:',Esav + write(u6,'(A,3(f12.4))') ' Total dipole in QM-region last microstep (a.u.):',-xyzMyQ(1),-xyzMyQ(2),-xyzMyQ(3) + write(u6,*) + call xFlush(u6) + !------------------------------------------------------------------* + ! End of Macrostep. * + !------------------------------------------------------------------* + end do + !--------------------------------------------------------------------* + ! Put some things on info-file. Used to make tests. * + !--------------------------------------------------------------------* + call Add_Info('Total Energy',[Etot],1,6) + call Add_Info('Induction of system',[Sum1],1,6) + call Add_Info('React. field int.',[s90um],1,6) + call Add_Info('Solv-Solu Disp.',[EEdisp],1,6) + call Add_Info('QM-region Energy',[Energy],1,6) + call Add_Info('QM-region dipole',xyzMyQ,3,5) + RRRnVarv = real(nVarv,kind=wp) + call Add_Info('Pol.Iterations',[RRRnVarv],1,8) + if (.not. Loop) exit outer +end do outer +call mma_deallocate(BoMaH) +call mma_deallocate(BoMaO) +call mma_deallocate(Fil) +call mma_deallocate(Eint) +call mma_deallocate(Eint_Nuc) +call mma_deallocate(Poli) +call mma_deallocate(Smat) +call mma_deallocate(Vmat) +call mma_deallocate(SmatPure) +call mma_deallocate(STC) +call mma_deallocate(ExpVal) +call mma_deallocate(ExpCento) +call mma_deallocate(SumElcPot) +if (allocated(AOSum)) call mma_deallocate(AOSum) +!----------------------------------------------------------------------* +! Close some external files. * +!----------------------------------------------------------------------* +if (QmProd .and. (iRead /= 9)) then + iDisk = 0 + iDum(1) = iHowMSampUT + call iDaFile(iLuSaUt,1,iDum,1,iDisk) + call DaClos(iLuSaUt) +end if +!----------------------------------------------------------------------* +! The End... be happy! * +!----------------------------------------------------------------------* + +write(u6,*) +write(u6,*) +write(u6,*) ' Time statistics. (hour:minute:second)' +write(u6,*) ' -----------------------------------------------------' +it1h = int(timeCLAS)/3600 +it1m = int(timeCLAS-it1h*3600)/60 +t1s = timeCLAS-it1h*3600-it1m*60 +write(u6,9) ' Time spent on pair-wise solvent-solvent interactions: ',it1h,':',it1m,':',t1s +it2h = int(timeEX)/3600 +it2m = int(timeEX-it2h*3600)/60 +t2s = timeEX-it2h*3600-it2m*60 +write(u6,9) ' Time spent on solvent-solute overlap calculations: ',it2h,':',it2m,':',t2s +it3h = int(timeEL)/3600 +it3m = int(timeEL-it3h*3600)/60 +t3s = timeEL-it3h*3600-it3m*60 +write(u6,9) ' Time spent on solvent and solute electrostatic interaction: ',it3h,':',it3m,':',t3s +it4h = int(timeMC)/3600 +it4m = int(timeMC-it4h*3600)/60 +t4s = timeMC-it4h*3600-it4m*60 +write(u6,9) ' Time spent on the Metropolis-Monte Carlo decision: ',it4h,':',it4m,':',t4s + +return + +9 format(A,I4,A,I3,A,F5.2) + +end subroutine EqRas diff -Nru openmolcas-22.02/src/qmstat/eqscf.f openmolcas-22.10/src/qmstat/eqscf.f --- openmolcas-22.02/src/qmstat/eqscf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/eqscf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,671 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine EqScf(iQ_Atoms,nAtomsCC,Coord,nBas,nBas_C,nCnC_C - & ,iSupDeAll,iV1DeAll) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "files_qmstat.fh" -#include "qmcom.fh" -#include "qm1.fh" -#include "integral.fh" -#include "numbers.fh" -#include "WrkSpc.fh" -#include "warnings.h" -#include "constants.fh" - - Parameter (Conver1=1.0d10*CONST_BOHR_RADIUS_IN_SI_) - Parameter (Conver2=2.0d0*Pi/360.0d0) -* Parameter (BoltzK=1.0d-3*CONST_BOLTZMANN_/CONV_AU_TO_KJ_) - Dimension nBas(1),nBas_C(1),nCnC_C(MxBasC),Coord(MxAt*3) - Dimension Eint(MxQCen,10),Poli(MxQCen,10) - Dimension iFP(3),iGP(3),iDT(3),iFi(3),iFil(MxQCen,10) - Dimension Smat(MxOT),Vmat(MxOT),BoMaH(MxAt),BoMaO(MxAt) - Dimension SmatPure(MxOT) -*****Jose** Interaction with Slater type to consider Penetration - Dimension Eint_Nuc(MxAt) -*****JoseMEP**New variables for the MEP calculation - Dimension SumElcPot(MxQCen,10) - Dimension PertElcInt(MxBas*(MxBas+1)/2) - Character*4 Labjhr -***** - Character Memlabel*20,Memlaabe*20,Memlaaab*20,MemLaaaa*20 - Character MemQFal*20,Head*200,ChCo*2,ChCo2*2 - Logical DidWeAccept,Haveri,CalledBefore,SampleThis,InCutOff - Parameter (ExLim=10) !Over how long distance the exchange rep. - !is computed, the solv-solv. - External Ranf - Logical Exist - Dimension Dum(1),iDum(1) - -*----------------------------------------------------------------------* -* Enter. * -*----------------------------------------------------------------------* -*----------------------------------------------------------------------* -* Make some conversions, initializations and zeros. * -*----------------------------------------------------------------------* - BoltzK=1.0d-3*CONST_BOLTZMANN_/CONV_AU_TO_KJ_ - Ract=Rstart !Initial radie - delX=delX/Conver1 !angstrom-->Bohr - delFi=delFi*Conver2 !degree-->radian - delR=delR/Conver1 !angstrom-->Bohr - CalledBefore=.false. - SampleThis=.true. - iSupDeAll=iSupM - iV1DeAll=iV1 - If(ParallelT) nMacro=nTemp*nMacro -* -*---- If we have vacuum, then no volume-pressure work is done, nor do we -* have any cavitation free-energy. -* - If(abs(Diel-1).le.0.0001d0) then - Gamma=0 - Gam=0 - Else - If(SURF.le.0.0d0) then - Gamma=0 - Gam=0 - Else - Gamma=Pres*4.188790205d0*.52917d0**3*6.023d0*.00001d0 - & *1.01325d0/627.52d0/4.184d0 - Gam=.0005973455d0/74d0*SURF - Endif - Endif - If(Temp.le.0.0d0) then - BetaBol=1.0d23 - Else - BetaBol=1.0d0/(Temp*BoltzK) - Endif - DiFac=-(Diel-1)/(Diel+1) - Expran=0 - iHowMSampUT=0 - iHowMSampIN=0 - nBaseC=nBas_C(1) - nBaseQ=nBas(1) - iTri=(iOrb(1)*(iOrb(1)+1))/2 - iTriBasQ=nBaseQ*(nBaseQ+1)/2 - timeCLAS=0 - timeEX=0 - timeEL=0 - timeMC=0 -* -*---- If some damping has been requested, prepare it here and print. -* - If((Dispdamp.or.FieldDamp).and.iPrint.ge.8) then - Write(6,*) - Write(6,*)'-----Various damping data.' - Write(6,*) - Endif - If(Dispdamp) then -* -*---- Construct the Born-Mayer parameters, a la Brdarski-Karlstrom -* - Call BornMayerBK(iQ_Atoms,BoMaH,BoMaO) - Endif - - If(Fielddamp) then - if(iPrint.ge.8) then - Write(6,*)' Damping the field between Qm-region and solvent.' - Write(6,*)' E_damp=E_0*(1-exp(alpha*distance))^N' - Write(6,*)' alpha(QM-oxygen) =',CAFieldG - Write(6,*)' alpha(QM-hydrogen) =',CBFieldG - Write(6,*)' N =',CFexp - endif - Endif -*--------------------------------------------------------------------------* -* Check what to run - equilibration or production - and say something * -* beautiful to the user. * -*--------------------------------------------------------------------------* - If(Qmeq.and.iRead.ne.9) then - Call NiceOutPut('EIQ',Gam,Gamma,BetaBol) - Elseif(QmProd.and.iRead.ne.9) then - Call NiceOutPut('PIQ',Gam,Gamma,BetaBol) - Call DaName(iLuSaUt,SaFilUt) - iDisk=0 !Put some dummy on the sampfile so we have space for - !the real number later. - iDum(1)=iHowMSampUT - Call iDaFile(iLuSaUt,1,iDum,1,iDisk) - !Below we make a check for extreme cases. Our algorithm to - !select sampling configurations sets this limit. - iProdMax=(2**30-1)*2 - If((nMacro*nMicro).ge.iProdMax) then - Write(6,*) - Write(6,*)'WARNING! Too large numbers for nMacro and nMicro t' - &//'o run production!' - Write(6,*)' Their product must not be greater than 2**31!' - Write(6,*)' If you wish to make such large samples, you can' - &//' run several samplings and collect several sampfiles.' - Call Quit(_RC_INTERNAL_ERROR_) - Endif - Elseif(iRead.eq.9) then !If we read from sampfile: open the - !sampfile and read how many configurations - !and open extract file. - Call NiceOutPut('SSS',Gam,Gamma,BetaBol) - Call DaName(iLuSaIn,SaFilIn) - iDiskSa=0 - Call iDaFile(iLuSaIn,2,iDum,1,iDiskSa) - iHowMSampIN=iDum(1) - iLuExtr=54 - iLuExtr=IsFreeUnit(iLuExtr) - Call OpnFl(SimEx,iLuExtr,Exist) - Write(iLuExtr,*)'Extract-File' - Write(iLuExtr,*) - !And put some words in the output - Write(6,*) - Write(6,*)' Total number of sampled configurations:' - & ,iHowMSampIN - Write(6,*)' Reading from the file ',SaFilIn - Write(6,*)' Summarizing data put on ',SimEx -******JoseMEP - ! If we perform MEP calculation, first we make some zeros - ! and allocate some memory. - If(lExtr(8)) then - Do 1001, ijhr=1,MxQCen - Do 1002, jjhr=1,10 - SumElcPot(ijhr,jjhr)=0.0d0 - AvElcPot(ijhr,jjhr)=0.0d0 -1002 Continue -1001 Continue - NCountField=0 - - iTriMaxBasQ=MxBas*(MxBas+1)/2 - call dcopy_(iTriMaxBasQ,[ZERO],iZERO,PertNElcInt,iONE) -c write(6,*)'ipAOSum',ipAOSum - Call GetMem('SumOvlAOQ','Allo','Real',ipAOSum,iTriBasQ) - call dcopy_(iTriBasQ,[ZERO],iZERO,Work(ipAOSum),iONE) -c write(6,*)'ipAOSum',ipAOSum - Endif -********** - Else - Write(6,*) - Write(6,*)'Error 1 in classical subroutine.' - Call Quit(_RC_INTERNAL_ERROR_) - Endif -*----------------------------------------------------------------------* -* If we have input file, then read from it. * -*----------------------------------------------------------------------* - iCStart=(((iQ_Atoms-1)/nAtom)+1)*nCent+1 - iCNum=(iCStart-1)/nCent - i9=0 -58886 Continue - i9=i9+1 - If(iRead.le.8.and.iRead.ge.6) then - Call Get8(Ract,Dum(1)) - Elseif(iRead.eq.9) then - Call Get9(Ract,Coord,info_atom,iQ_Atoms,iDiskSa) - Else - If(iExtra.gt.0) then - Call NyPart(iExtra,nPart,Cordst,Rstart,nCent,iSeed) - Endif - If(iPrint.ge.10) then - Write(Head,*)'Coordinates of the initial distribution.' - Call Cooout(Head,Cordst,nPart,nCent) - Endif - Endif -* -*---- Give a startvalue for the Total energy. The effect is that we -* always accept the first microstep. -* - Etot=1D+10 -*----------------------------------------------------------------------* -* Compute som numbers to simplify the handling of indeces. * -*----------------------------------------------------------------------* - ncpart=Ncent*nPart - ncParm=ncPart-(nCent*icNum) - nClas=nPart-iCNum - indma=npart*npol - iCi=(iQ_Atoms*(iQ_Atoms+1))/2 -*----------------------------------------------------------------------* -* Substitue classical waters for quantum molecule. * -*----------------------------------------------------------------------* - If(iRead.eq.8.or.iRead.eq.0) then - Call PlaceIt(Coord,iQ_Atoms,iCNum) - Elseif(iRead.eq.6) then - Call PlaceIt9(Coord,Cordst,info_atom,iQ_Atoms) - If(iPrint.ge.10) then - Write(Head,*)'CM-centred coordinates after substitution.' - Call Cooout(Head,Cordst,nPart,nCent) - Endif - Endif -*----------------------------------------------------------------------* -* * -*------------------------- START SIMULATION ---------------------------* -* * -*----------------------------------------------------------------------* - iSnurr=0 !How many steps taken totally. -* -*---- The Macrosteps. -* - Do 2000, iMacro=1,nMacro - Esav=0.0d0 - If(iRead.eq.9) then - iAcc=1 - Else - iAcc=0 - Endif - -*------ If we are running parallel tempering, then... - If(ParallelT) Call ParaRoot(Ract,BetaBol,Etot,CalledBefore - & ,SampleThis) - -* -*------ The Microsteps. -* - Do 2001, iMicro=1,nMicro - Call Timing(Cpu1,Tim1,Tim2,Tim3) - Eold=Etot - iSnurr=iSnurr+1 -* -*-------- Generate new configuration, both solvent and QM-region. -* - Call GeoGen(Ract,Rold,iCNum,iQ_Atoms) -* -*-------- Compute Solvent-solvent interaction. -* - Call ClasClas(iCNum,iCStart,ncParm,Coord,iFP,iGP,iDT,iFI,iDist - & ,iDistIm,Elene,Edisp,Exrep,E2Die,ExDie) - Call QMPosition(EHam,Cordst,Coord,Forcek,dLJrep,Ract,iQ_Atoms) - Call Timing(Cpu2,Tim1,Tim2,Tim3) - timeCLAS=timeCLAS+(Cpu2-Cpu1) -*--------------------------------------------------------------------------* -* Work a bit with the quantum part. * -*--------------------------------------------------------------------------* - Do 4002, i=1,3 - xyzMyQ(i)=0 !Dipoles for the QM-part, see polink.f. - xyzMyI(i)=0 -4002 Continue - nSize=3*nPol*nPart - Do 400, i=1,iCi !Allocate memory for the field on the QM-mol. - Do 4000, j=1,10 !iCi: number of quantum molecule sites. - Write(MemQFal,'(A,i2.2,i2.2)')'Falt',i,j - Call GetMem(MemQFal,'Allo','Real',iFil(i,j),nSize) -4000 Continue -400 Continue - Do 401, i=1,iCi - Do 402, j=1,10 !Charges (1),Dipoles(3),Quadrupoles(6) - Do 403, k=1,nPart*nPol !Classical polarisation sites - !including quantum molecule. - Work(iFil(i,j)-1+k)=0.0d0 - Work(iFil(i,j)-1+k+nPart*nPol)=0.0d0 - Work(iFil(i,j)-1+k+2*nPart*nPol)=0.0d0 -403 Continue - Eint(i,j)=0.0d0 -402 Continue - If (i.le.MxAt) Eint_Nuc(i)=0.0d0 -401 Continue -* -*-------- Compute the exchange operator. -* - Call ExScf(iCStart,nBaseQ,nBaseC,nCnC_C,iQ_Atoms - & ,nAtomsCC,Ax,Ay,Az,iTri,Smat,SmatPure,InCutOff - & ,ipAOSum) - Call Timing(Cpu3,Tim1,Tim2,Tim3) - timeEX=timeEX+(Cpu3-Cpu2) - -* -*---- Electrostatics, anfangen bitte. -* -* -*-------- Compute various gradients of 1/r. -* - If(lSlater) then - Call OneOverR_Sl(iFil,Ax,Ay,Az,BoMaH,BoMaO,EEDisp - & ,iCNum,Eint,iQ_Atoms,outxyz - & ,Eint_Nuc) - Else - Call OneOverR(iFil,Ax,Ay,Az,BoMaH,BoMaO,EEDisp - & ,iCNum,Eint,iQ_Atoms,outxyz) - Endif - -* -*-- Couple the pair-part of the electrostatics with QM-region. -* - Call Hel(Eint,iTri,iCi,Cha,DipMy,Quad,Vmat,iprint) - -* -*-- Polarize system. -* - Call PolScf(iDist,iDistIm,iDT,iFI,iFP,iFil,iCStart,iTri - & ,VMat,Smat,DiFac,Ract,icnum,energy,NVarv - & ,iMOC,Haveri,iQ_Atoms,ip_ExpVal,Poli) - -* -*----- Energy from QM-nuclei interacting with solvent field. -* - If(lSlater) then - Do 702, i=1,iQ_Atoms - Energy=Energy-Eint_Nuc(i)*ChaNuc(i) -702 Continue - Else - Do 703, i=1,iQ_Atoms - Energy=Energy-Eint(i,1)*ChaNuc(i) -703 Continue - Endif - -* -*----- Some additional boost of short-range repulsion. -* - Call BoostRep(AddRep,SmatPure,iMOC,iOrb(1),InCutOff) - -* -*----- Sum-up what we will call QM-region energy. -* - Energy=Energy-EEdisp+AddRep - -*----------------------------------------------------------------------* -* Final induction and reaction field energies. * -*----------------------------------------------------------------------* - Call ReaInd(iGP,iDT,iDistIm,iCNum,IndMa,NcParm,Sum1,s90um) - Call Timing(Cpu4,Tim1,Tim2,Tim3) - timeEL=timeEL+(Cpu4-Cpu3) -*----------------------------------------------------------------------* -* Construct the final energy. * -*----------------------------------------------------------------------* - EnCLAS=Elene+EHam-Edisp+Exrep+E2Die+ExDie - Etot=EnCLAS-0.5*S90um-Sum1+Gamma*Ract**3+Energy+Gam*Ract**2 - Dele=Etot-Eold -*--------------------------------------------------------------------------* -* Printing and various if requsted. * -*--------------------------------------------------------------------------* - If(iPrint.ge.10) then - If(Haveri) Etot=999999 - Write(6,*) - Write(6,*)' ----Microstep',iMicro - Write(6,*)' Number of iterations:',nVarv - Write(6,*)' Total energy:',Etot - Write(6,*)' Of which is' - Write(6,*)' Pairwise solvent-solvent ' - &//'interaction:',EnCLAS - Write(6,*)' Solvent-solvent Electrostatic' - &,Elene - Write(6,*)' Harmonic Spring:',EHam - Write(6,*)' Solvent-solvent Dispersion:',-Edisp - Write(6,*)' Solvent-solvent Exchange:',Exrep - Write(6,*)' Energy of induced dipoles in field f' - &//'rom explicit solvent:',-Sum1 - Write(6,*)' Energy of solvent charge distributio' - &//'n in reaction field:',-0.5*S90um - Write(6,*)' Solvent E-interaction with image:' - &,E2Die - Write(6,*)' Solvent Repulsion with boundary:' - &,ExDie - Write(6,*)' Solvent-Solute dispersion:',EEdisp - Write(6,*)' Energy of QM-region:',Energy - Write(6,*)' Higher order overlap exchange pair' - &//'-term:',AddRep - Write(6,*)' Surface tension term:',Gam*Ract**2 - Write(6,*)' Volume-pressure term:',Gamma*Ract**3 - Write(6,*)' Previous accepted energy:',Eold - Write(6,*)' Difference:',Dele - Write(6,*)' Total dipole in QM-region:(',-xyzMyQ(1), - &',',-xyzMyQ(2),',',-xyzMyQ(3),')' - Write(6,*)' Radie:',Ract - If(Haveri) then - Write(6,*)' WARNING! SOME OF THE NUMBERS ABOVE HAVE NO' - &//' MEANING SINCE THE POLARIZATION DID NOT CONVERGE!!!' - GoTo 8194 - Endif - Endif - -* -*-- If we are collecting stuff from a sampfile, now is the time to put -* data on the extract file. For centre specific stuff, call good-old -* Allen for them. -* - If(iRead.eq.9) then - If(lExtr(6)) then - E_Nuc_Rubbet=0.0d0 - If(lSlater) then - Do 6347, iAt=1,iQ_Atoms - E_Nuc_Rubbet=E_Nuc_Rubbet - & -(Eint_Nuc(iAt)+Poli(iAt,1))*ChaNuc(iAt) -6347 Continue - Else - Do 6348, iAt=1,iQ_Atoms - E_Nuc_Rubbet=E_Nuc_Rubbet - & -(Eint(iAt,1)+Poli(iAt,1))*ChaNuc(iAt) -6348 Continue - Endif - Endif - If(lExtr(7)) then - Call AllenGinsberg('SCF ',Eint,Poli,ChaNuc,Cha,DipMy - & ,Quad,MxOT,iMOC,iOrb(1),iExtr_Atm - & ,.false.,iOcc1,iQ_Atoms - & ,ip_ExpCento,E_Nuc_Part,lSlater - & ,Eint_Nuc) - - Endif - Call Extract(iLuExtr,i9,Etot,xyzMyQ,FockM,iMOC,iDt,iOrb(1) - & ,Dum,xyzQuQ,ip_ExpVal,ip_ExpCento - & ,E_Nuc_Rubbet,E_Nuc_Part) -****JoseMEP********** - ! If MEP option. Add electr. potential, field, etc for - ! all solvent config. - If(lExtr(8)) then - Labjhr='Add ' - Call AverMEP(Labjhr,Eint,Poli,iCi,SumElcPot - & ,NCountField,PertElcInt - & ,iONE,iONE,[iONE],[iONE],iONE) - NCountField=NCountField+1 - Endif -********* - GoTo 9090 - Endif -*----------------------------------------------------------------------* -* Resume the MC-wrap up. * -*----------------------------------------------------------------------* - Dele=Dele*BetaBol - DidWeAccept=.true. - If(Dele.lt.0) then - iAcc=iAcc+1 - Else - Expe=Exp(-Dele) - Expran=ranf(iseed) - If(iPrint.ge.10) then - Write(6,*)' Positive energy change!' - Write(6,*)' Boltzmann weight:',Expe - Write(6,*)' Random number:',ExpRan - Endif - iAcc=iAcc+1 - If(Expe.lt.ExpRan) then - Call Oldge(iAcc,Etot,Eold,Ract,Rold) - DidWeAccept=.false. - If(iPrint.ge.10) then - Write(6,*)' Not accepted!' - Endif - Endif - Endif - If(DidWeAccept)Esav=Esav+Etot -*----------------------------------------------------------------------* -* If this is a production run, then put stuff on the sampfile. * -*----------------------------------------------------------------------* - If(QmProd) then !<-- Are we producing. - If(SampleThis) then !<-- Should we sample this (relevant - !when paralleltempering is used). - If(Inter.ne.0) then - Inte=(iSnurr/Inter)*Inter - If(Inte.eq.((iMacro-1)*nMicro+iMicro)) then - Call Put9(Etot,Ract,iDT,iHowMSampUT,Gamma,Gam,Esav - & ,iDisk) - Endif - Endif - Endif - Endif -*--------------------------------------------------------------------------* -* Free memory. * -*--------------------------------------------------------------------------* -9090 Continue - iOrba=iOrb(1) - nSize=(nClas*(nClas-1)/2)*(nCent**2) - nSizeIm=(nClas*nCent)**2 - Call GetMem('DistMat','Free','Real',iDist,nSize) - Call GetMem('DistMatIm','Free','Real',iDistIm,nSizeIm) - IndMa=nPol*nPart - Do 90001,i=1,3 - Write(ChCo,'(I1.1)')i - Write(MemLabel,*)'FP'//ChCo - Write(MemLaabe,*)'GP'//ChCo - Write(MemLaaab,*)'DT'//ChCo - Write(MemLaaaa,*)'FI'//ChCo - Call GetMem(MemLabel,'Free','Real',iFP(i),IndMa) - Call GetMem(MemLaabe,'Free','Real',iGP(i),IndMa) - Call GetMem(MemLaaab,'Free','Real',iDT(i),IndMa) - Call GetMem(MemLaaaa,'Free','Real',iFI(i),IndMa) -90001 Continue - nSize=3*nPol*nPart - Do 90002, i=1,iCi - Do 90003, j=1,10 - Write(ChCo,'(I2.2)')i - Write(ChCo2,'(I2.2)')j - Write(MemQFal,*)'Falt'//ChCo//ChCo2 - Call GetMem(MemQFal,'Free','Real',iFil(i,j),nSize) -90003 Continue -90002 Continue - Call GetMem('Coeff','Free','Real',iMOC,iOrba**2) - Call Timing(Cpu5,Tim1,Tim2,Tim3) - timeMC=timeMC+(Cpu5-Cpu4) -*--------------------------------------------------------------------------* -* End of Microstep. * -*--------------------------------------------------------------------------* -2001 Continue -*----------------------------------------------------------------------* -* Have we collected all sampled configurations? If no, go up again. * -* If yes, then close some files and take a little jump downwards to * -* the END!!! * -*----------------------------------------------------------------------* -*Jose*************************************** -* This point is also used to perform the Average of the Potential, -* Field and Field gradients to obtain and average Electrostatic -* perturbation. The Non-Electr. perturbation is also obtained here -* it will be added directly to the One-electron file. -******************************************* - - If(i9.lt.iHowMSampIN.and.iRead.eq.9) then - GoTo 58886 - Elseif(i9.ge.iHowMSampIN.and.iRead.eq.9) then -******JoseMEP** - ! If MEP option. Obtain the mean Potential, Field - ! and Field Gradients. - ! It si also obtained the average of the Non-Electrostatic - ! perturbation - If(lExtr(8)) then - Labjhr='Aver' - Call AverMEP(Labjhr,Eint,Poli,iCi,SumElcPot - & ,NCountField,PertElcInt - & ,iONE,iONE,[iONE],[iONE],iONE) -* - AverFact=1.0d0/Dble(NCountField) - Call DaxPy_(iTriBasQ,AverFact,Work(ipAOSum),iONE - & ,PertNElcInt,iONE) - Call GetMem('SumOvlAOQ','Free','Real',ipAOSum,iTriBasQ) - Endif -********* - Call DaClos(iLuSaIn) - Close(iLuExtr) - GoTo 58887 - Endif -*----------------------------------------------------------------------* -* Write to startfile. * -*----------------------------------------------------------------------* -8194 Continue - ESav=Esav/Dble(iAcc) - Call Put8(Ract,Etot,Gamma,Gam,Esav) - If(Haveri) Call Quit(_RC_NOT_CONVERGED_) -*----------------------------------------------------------------------* -* Print some things here at the end of the macrostep. * -*----------------------------------------------------------------------* - If(.not.ParallelT) then - jMacro=iMacro - Else - jMacro=1+(iMacro-1)/nTemp - Endif - Write(6,'(A,i4)')'---Macrostep ',jMacro - Write(6,'(A,i4)')' Number of microsteps:',nMicro - Pr=100.0d0*(Dble(iAcc)/Dble(nMicro)) - Write(6,'(A,i4,A,f5.1,A)')' Number of acceptances:',iAcc,'(' - & ,Pr,'%)' - Write(6,'(A,f12.4)')' Radie (a.u.):',Ract - Write(6,'(A,f16.8)')' Average Energy (a.u.) in Macrostep:' - & ,Esav - Write(6,'(A,3(f12.4))')' Total dipole in QM-region last mic' - &//'rostep (a.u.):',-xyzMyQ(1),-xyzMyQ(2),-xyzMyQ(3) - Write(6,*) - Call xFlush(6) -*--------------------------------------------------------------------------* -* End of Macrostep. * -*--------------------------------------------------------------------------* -2000 Continue -*----------------------------------------------------------------------* -* Put some things on info-file. Used to make tests. * -*----------------------------------------------------------------------* - Call Add_Info('Total Energy',[Etot],1,6) - Call Add_Info('Induction of system',[Sum1],1,6) - Call Add_Info('React. field int.',[s90um],1,6) - Call Add_Info('Solv-Solu Disp.',[EEdisp],1,6) - Call Add_Info('QM-region Energy',[Energy],1,6) - Call Add_Info('QM-region dipole',xyzMyQ,3,5) -*----------------------------------------------------------------------* -* Close some external files. * -*----------------------------------------------------------------------* -58887 Continue - If(QmProd.and.iRead.ne.9) then - iDisk=0 - iDum(1)=iHowMSampUT - Call iDaFile(iLuSaUt,1,iDum,1,iDisk) - Call DaClos(iLuSaUt) - Endif -*--------------------------------------------------------------------------* -* The End... be happy! * -*--------------------------------------------------------------------------* - Write(6,*) - Write(6,*) - Write(6,*)' Time statistics. (hour:minute:second)' - Write(6,*)' -----------------------------------------------------' - it1h=int(timeCLAS)/3600 - it1m=int(timeCLAS-it1h*3600)/60 - t1s=timeCLAS-it1h*3600-it1m*60 - Write(6,8)' Time spent on pair-wise solvent-solvent interaction' - &//'s: ',it1h,':',it1m,':',t1s - it2h=int(timeEX)/3600 - it2m=int(timeEX-it2h*3600)/60 - t2s=timeEX-it2h*3600-it2m*60 - Write(6,8)' Time spent on solvent-solute overlap calculations: ' - &,it2h,':',it2m,':',t2s - it3h=int(timeEL)/3600 - it3m=int(timeEL-it3h*3600)/60 - t3s=timeEL-it3h*3600-it3m*60 - Write(6,8)' Time spent on solvent and solute electrostatic inte' - &//'raction: ',it3h,':',it3m,':',t3s - it4h=int(timeMC)/3600 - it4m=int(timeMC-it4h*3600)/60 - t4s=timeMC-it4h*3600-it4m*60 - Write(6,8)' Time spent on the Metropolis-Monte Carlo decision: ' - &,it4h,':',it4m,':',t4s -8 Format(A,I4,A,I3,A,F5.2) - - Return - End - - -*--------------------------------------------------------------------------* -* A small internal subroutine to compute the Nemo exchange repulsion. * -*--------------------------------------------------------------------------* - Real*8 Function ExNemo(i,j,a) - Implicit Real*8 (a-h,o-z) -#include "maxi.fh" -#include "qminp.fh" - Real*8 a - Integer i,j -*The function - ExNemo=Exp(-Sexrep(i,j)/a)*Sexre1(i,j)+Sexre2(i,j)*(a**20) - Return - End diff -Nru openmolcas-22.02/src/qmstat/eqscf.F90 openmolcas-22.10/src/qmstat/eqscf.F90 --- openmolcas-22.02/src/qmstat/eqscf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/eqscf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,578 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine EqScf(iQ_Atoms,nAtomsCC,Coord,nBas,nBas_C) + +use qmstat_global, only: AvElcPot, CAFieldG, CBFieldG, CFexp, Cha, ChaNuc, CordIm, Cordst, delFi, delR, delX, Diel, DipMy, & + DispDamp, dLJrep, FieldDamp, FockM, Forcek, iExtra, info_atom, Inter, iLuSaIn, iLuSaUt, iOcc1, iOrb, & + iPrint, iRead, iSeed, lExtr, lSlater, nAtom, nCent, nMacro, nMicro, nPart, nPol, nTemp, OldGeo, outxyz, & + ParallelT, PertNElcInt, Pres, Qmeq, QmProd, Quad, rStart, SaFilIn, SaFilUt, SimEx, SURF, Temp, xyzMyI, & + xyzMyQ, xyzQuQ +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Three, Four, Ten, Half, Pi, Angstrom, atmToau, auTokJ, deg2rad, KBoltzmann +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iQ_Atoms, nAtomsCC, nBas(1), nBas_C(1) +real(kind=wp), intent(in) :: Coord(3,iQ_Atoms) +integer(kind=iwp) :: i, i9, iAcc, iAt, iCi, iCNum, iCStart, iDisk, iDiskSa, iDum(1), iHowMSampIN, iHowMSampUT, iLuExtr, iMacro, & + iMicro, IndMa, Inte, iProdMax, iSnurr, it1h, it1m, it2h, it2m, it3h, it3m, it4h, it4m, iTri, iTriBasQ, & + jMacro, nBaseC, nBaseQ, nClas, NCountField, NVarv +real(kind=wp) :: AddRep, Ax, Ay, Az, BetaBol, Cpu1, Cpu2, Cpu3, Cpu4, Cpu5, Dele, DiFac, Dum, E2Die, E_Nuc_Part, E_Nuc_Rubbet, & + Edisp, EEDisp, EHam, Elene, EnCLAS, energy, Eold, Esav, Etot, ExpCento(4), ExDie, Expe, Expran, Exrep, ExpVal(4), & + Gam, Gmma, PertElcInt(1), Pr, Ract, Rold, s90um, Sum1, t1s, t2s, t3s, t4s, Tim1, Tim2, Tim3, timeCLAS, timeEL, & + timeEX, timeMC +logical(kind=iwp) :: CalledBefore, DidWeAccept, Exists, Haveri, InCutOff, Loop, SampleThis, Skip +character(len=200) :: Head +character(len=4) :: Labjhr +real(kind=wp), allocatable :: AOSum(:), BoMaH(:), BoMaO(:), Dist(:,:,:), DistIm(:,:,:,:), DT(:,:), Eint(:,:), Eint_Nuc(:), & + FI(:,:), Fil(:,:,:,:), FP(:,:), GP(:,:), MOC(:,:), Poli(:,:), Smat(:), SmatPure(:), SumElcPot(:,:), & + Vmat(:) +real(kind=wp), parameter :: BoltzK = 1.0e-3_wp*KBoltzmann/auTokJ, & + ExLim = Ten !Over how long distance the exchange rep. is computed, the solv-solv. +integer(kind=iwp), external :: IsFreeUnit +real(kind=wp), external :: Random_Molcas +#include "warnings.h" +!****Jose** Interaction with Slater type to consider Penetration +! Eint_Nuc +!****JoseMEP**New variables for the MEP calculation +! SumElcPot, PertElcInt, Labjhr + +!----------------------------------------------------------------------* +! Enter. * +!----------------------------------------------------------------------* +!----------------------------------------------------------------------* +! Make some conversions, initializations and zeros. * +!----------------------------------------------------------------------* +Ract = rStart !Initial radie +delX = delX/Angstrom !angstrom-->bohr +delFi = delFi*deg2rad !degree-->radian +delR = delR/Angstrom !angstrom-->bohr +CalledBefore = .false. +SampleThis = .true. +if (ParallelT) nMacro = nTemp*nMacro + +! If we have vacuum, then no volume-pressure work is done, nor do we +! have any cavitation free-energy. + +if ((abs(Diel-One) > 1.0e-4_wp) .and. (SURF > Zero)) then + Gmma = Pres*Four/Three*Pi*atmToau + Gam = 5.973455e-4_wp/74.0_wp*SURF !What are these numbers? Is 74.0 supposed to be the surface tension of water in mN/m? +else + Gmma = Zero + Gam = Zero +end if + +if (Temp <= Zero) then + BetaBol = 1.0e23_wp +else + BetaBol = One/(Temp*BoltzK) +end if +DiFac = -(Diel-One)/(Diel+One) +Expran = Zero +iHowMSampIN = 0 +iHowMSampUT = 0 +nBaseC = nBas_C(1) +nBaseQ = nBas(1) +iTri = nTri_Elem(iOrb(1)) +iTriBasQ = nTri_Elem(nBaseQ) +iCi = nTri_Elem(iQ_Atoms) +timeCLAS = Zero +timeEX = Zero +timeEL = Zero +timeMC = Zero + +! If some damping has been requested, prepare it here and print. + +if ((DispDamp .or. FieldDamp) .and. (iPrint >= 8)) then + write(u6,*) + write(u6,*) '-----Various damping data.' + write(u6,*) +end if +call mma_allocate(BoMaH,iQ_Atoms,label='BoMaH') +call mma_allocate(BoMaO,iQ_Atoms,label='BoMaO') + +! Construct the Born-Mayer parameters, a la Brdarski-Karlstrom +if (DispDamp) call BornMayerBK(iQ_Atoms,BoMaH,BoMaO) + +if (FieldDamp .and. (iPrint >= 8)) then + write(u6,*) ' Damping the field between Qm-region and solvent.' + write(u6,*) ' E_damp=E_0*(1-exp(alpha*distance))^N' + write(u6,*) ' alpha(QM-oxygen) =',CAFieldG + write(u6,*) ' alpha(QM-hydrogen) =',CBFieldG + write(u6,*) ' N =',CFexp +end if +!----------------------------------------------------------------------* +! Check what to run - equilibration or production - and say something * +! beautiful to the user. * +!----------------------------------------------------------------------* + +call mma_allocate(SumElcPot,iCi,10,label='SumElcPot') + +if (Qmeq .and. (iRead /= 9)) then + call NiceOutPut('EIQ') +else if (QmProd .and. (iRead /= 9)) then + call NiceOutPut('PIQ') + call DaName(iLuSaUt,SaFilUt) + iDisk = 0 !Put some dummy on the sampfile so we have space for the real number later. + iDum(1) = iHowMSampUT + call iDaFile(iLuSaUt,1,iDum,1,iDisk) + ! Below we make a check for extreme cases. Our algorithm to + ! select sampling configurations sets this limit. + iProdMax = (2**30-1)*2 + if ((nMacro*nMicro) >= iProdMax) then + write(u6,*) + write(u6,*) 'WARNING! Too large numbers for nMacro and nMicro to run production!' + write(u6,*) ' Their product must not be greater than 2**31!' + write(u6,*) ' If you wish to make such large samples, you can run several samplings and collect several sampfiles.' + call Quit(_RC_INTERNAL_ERROR_) + end if +else if (iRead == 9) then + ! If we read from sampfile: open the + ! sampfile and read how many configurations and open extract file. + call NiceOutPut('SSS') + call DaName(iLuSaIn,SaFilIn) + iDiskSa = 0 + call iDaFile(iLuSaIn,2,iDum,1,iDiskSa) + iHowMSampIN = iDum(1) + iLuExtr = IsFreeUnit(54) + call OpnFl(SimEx,iLuExtr,Exists) + write(iLuExtr,*) 'Extract-File' + write(iLuExtr,*) + ! And put some words in the output + write(u6,*) + write(u6,*) ' Total number of sampled configurations:',iHowMSampIN + write(u6,*) ' Reading from the file ',SaFilIn + write(u6,*) ' Summarizing data put on ',SimEx + !*****JoseMEP + ! If we perform MEP calculation, first we make some zeros and allocate some memory. + if (lExtr(8)) then + call mma_allocate(AvElcPot,iCi,10,label='AvElcPot') + SumElcPot(:,:) = Zero + AvElcPot(:,:) = Zero + NCountField = 0 + + PertNElcInt(:) = Zero + call mma_allocate(AOSum,iTriBasQ,label='SumOvlAOQ') + AOSum(:) = Zero + end if + !********* +else + write(u6,*) + write(u6,*) 'Error 1 in classical subroutine.' + call Quit(_RC_INTERNAL_ERROR_) +end if +if (.not. allocated(AOSum)) call mma_allocate(AOSum,0,label='SumOvlAOQ') +!----------------------------------------------------------------------* +! If we have input file, then read from it. * +!----------------------------------------------------------------------* +call mma_allocate(Fil,nPol*nPart,3,iCi,10,label='Fil') +call mma_allocate(Eint,iCi,10,label='Eint') +call mma_allocate(Eint_Nuc,iQ_Atoms,label='Eint_Nuc') +call mma_allocate(Poli,iCi,10,label='Poli') +call mma_allocate(Smat,iTri,label='Smat') +call mma_allocate(Vmat,iTri,label='Vmat') +call mma_allocate(SmatPure,iTri,label='SmatPure') +call mma_allocate(FockM,iTri,label='FockM') +call mma_allocate(MOC,iOrb(1),iOrb(1),label='Coeff') +if (.not. allocated(CordIm)) call mma_allocate(CordIm,3,nPart*nCent,label='CordIm') +iCStart = (((iQ_Atoms-1)/nAtom)+1)*nCent+1 +iCNum = (iCStart-1)/nCent +i9 = 0 +outer: do + Loop = .false. + i9 = i9+1 + if ((iRead <= 8) .and. (iRead >= 6)) then + call Get8(Ract,Dum) + else if (iRead == 9) then + call Get9(Ract,Coord,info_atom,iQ_Atoms,iDiskSa) + else + if (iExtra > 0) call NyPart(iExtra,nPart,Cordst,rStart,nCent,iSeed) + if (iPrint >= 10) then + write(Head,*) 'Coordinates of the initial distribution.' + call Cooout(Head,Cordst,nPart,nCent) + end if + end if + + ! Give a startvalue for the Total energy. The effect is that we + ! always accept the first microstep. + + Etot = 1.0e10_wp + !--------------------------------------------------------------------* + ! Compute some numbers to simplify the handling of indices. * + !--------------------------------------------------------------------* + nClas = nPart-iCNum + IndMa = nPart*nPol + !--------------------------------------------------------------------* + ! Substitute classical waters for quantum molecule. * + !--------------------------------------------------------------------* + if ((iRead == 8) .or. (iRead == 0)) then + call PlaceIt(Coord,iQ_Atoms,iCNum) + else if (iRead == 6) then + call PlaceIt9(Coord,Cordst,info_atom,iQ_Atoms) + if (iPrint >= 10) then + write(Head,*) 'CM-centred coordinates after substitution.' + call Cooout(Head,Cordst,nPart,nCent) + end if + end if + + !--------------------------------------------------------------------* + ! * + !------------------------- START SIMULATION -------------------------* + ! * + !--------------------------------------------------------------------* + + iSnurr = 0 !How many steps taken totally. + + ! The Macrosteps. + + do iMacro=1,nMacro + Esav = Zero + if (iRead == 9) then + iAcc = 1 + else + iAcc = 0 + end if + + ! If we are running parallel tempering, then... + if (ParallelT) call ParaRoot(Ract,BetaBol,Etot,CalledBefore,SampleThis) + + ! The Microsteps. + + Skip = .false. + do iMicro=1,nMicro + call Timing(Cpu1,Tim1,Tim2,Tim3) + Eold = Etot + iSnurr = iSnurr+1 + + ! Generate new configuration, both solvent and QM-region. + + call GeoGen(Ract,Rold,iCNum,iQ_Atoms) + + ! Compute Solvent-solvent interaction. + + call mma_allocate(FP,3,nPol*nPart,label='FP') + call mma_allocate(GP,3,nPol*nPart,label='GP') + call mma_allocate(DT,3,nPol*nPart,label='DT') + call mma_allocate(FI,3,nPol*nPart,label='FI') + call mma_allocate(Dist,nCent,nCent,nTri_Elem(nClas-1),label='Dist') + call mma_allocate(DistIm,nCent,nClas,nCent,nClas,label='DistIm') + call ClasClas(iCNum,nClas,FP,GP,DT,FI,Dist,DistIm,Elene,Edisp,Exrep,E2Die,ExDie) + call QMPosition(EHam,Cordst,Coord(:,1),Forcek,dLJrep,Ract,iQ_Atoms) + call Timing(Cpu2,Tim1,Tim2,Tim3) + timeCLAS = timeCLAS+(Cpu2-Cpu1) + !----------------------------------------------------------------* + ! Work a bit with the quantum part. * + !----------------------------------------------------------------* + xyzMyQ(:) = Zero !Dipoles for the QM-part, see polink. + xyzMyI(:) = Zero + Fil(:,:,:,:) = Zero + Eint(:,:) = Zero + Eint_Nuc(:) = Zero + + ! Compute the exchange operator. + + call ExScf(iCStart,nBaseQ,nBaseC,iQ_Atoms,nAtomsCC,Ax,Ay,Az,iTri,Smat,SmatPure,InCutOff,AOSum) + call Timing(Cpu3,Tim1,Tim2,Tim3) + timeEX = timeEX+(Cpu3-Cpu2) + + ! Electrostatics, anfangen bitte. + + ! Compute various gradients of 1/r. + + if (lSlater) then + call OneOverR_Sl(Fil,Ax,Ay,Az,BoMaH,BoMaO,EEDisp,iCNum,Eint,iQ_Atoms,outxyz,Eint_Nuc) + else + call OneOverR(Fil,Ax,Ay,Az,BoMaH,BoMaO,EEDisp,iCNum,Eint,iQ_Atoms,outxyz) + end if + + ! Couple the pair-part of the electrostatics with QM-region. + + call Hel(Eint,iTri,iCi,Cha,DipMy,Quad,Vmat) + + ! Polarize system. + call PolScf(Dist,DistIm,DT,FI,FP,Fil,iCStart,iTri,VMat,Smat,DiFac,Ract,icnum,energy,NVarv,MOC,Haveri,iQ_Atoms,ExpVal,Poli) + + ! Energy from QM-nuclei interacting with solvent field. + + if (lSlater) then + do i=1,iQ_Atoms + Energy = Energy-Eint_Nuc(i)*ChaNuc(i) + end do + else + do i=1,iQ_Atoms + Energy = Energy-Eint(i,1)*ChaNuc(i) + end do + end if + + ! Some additional boost of short-range repulsion. + + call BoostRep(AddRep,SmatPure,MOC,iOrb(1),InCutOff) + + ! Sum-up what we will call QM-region energy. + + Energy = Energy-EEdisp+AddRep + + !----------------------------------------------------------------* + ! Final induction and reaction field energies. * + !----------------------------------------------------------------* + call ReaInd(GP,DT,DistIm,iCNum,IndMa,nClas,Sum1,s90um) + call Timing(Cpu4,Tim1,Tim2,Tim3) + timeEL = timeEL+(Cpu4-Cpu3) + !----------------------------------------------------------------* + ! Construct the final energy. * + !----------------------------------------------------------------* + EnCLAS = Elene+EHam-Edisp+Exrep+E2Die+ExDie + Etot = EnCLAS-Half*S90um-Sum1+Gmma*Ract**3+Energy+Gam*Ract**2 + Dele = Etot-Eold + !----------------------------------------------------------------* + ! Printing and various if requested. * + !----------------------------------------------------------------* + if (iPrint >= 10) then + if (Haveri) Etot = 999999.0_wp + write(u6,*) + write(u6,*) ' ----Microstep',iMicro + write(u6,*) ' Number of iterations:',nVarv + write(u6,*) ' Total energy:',Etot + write(u6,*) ' Of which is' + write(u6,*) ' Pairwise solvent-solvent interaction:',EnCLAS + write(u6,*) ' Solvent-solvent Electrostatic',Elene + write(u6,*) ' Harmonic Spring:',EHam + write(u6,*) ' Solvent-solvent Dispersion:',-Edisp + write(u6,*) ' Solvent-solvent Exchange:',Exrep + write(u6,*) ' Energy of induced dipoles in field from explicit solvent:',-Sum1 + write(u6,*) ' Energy of solvent charge distribution in reaction field:',-Half*S90um + write(u6,*) ' Solvent E-interaction with image:',E2Die + write(u6,*) ' Solvent Repulsion with boundary:',ExDie + write(u6,*) ' Solvent-Solute dispersion:',EEdisp + write(u6,*) ' Energy of QM-region:',Energy + write(u6,*) ' Higher order overlap exchange pair-term:',AddRep + write(u6,*) ' Surface tension term:',Gam*Ract**2 + write(u6,*) ' Volume-pressure term:',Gmma*Ract**3 + write(u6,*) ' Previous accepted energy:',Eold + write(u6,*) ' Difference:',Dele + write(u6,*) ' Total dipole in QM-region:(',-xyzMyQ(1),',',-xyzMyQ(2),',',-xyzMyQ(3),')' + write(u6,*) ' Radie:',Ract + if (Haveri) then + write(u6,*) ' WARNING! SOME OF THE NUMBERS ABOVE HAVE NO MEANING SINCE THE POLARIZATION DID NOT CONVERGE!!!' + Skip = .true. + exit + end if + end if + + ! If we are collecting stuff from a sampfile, now is the time to put + ! data on the extract file. For centre specific stuff, call good-old + ! Allen for them. + + if (iRead == 9) then + if (lExtr(6)) then + E_Nuc_Rubbet = Zero + if (lSlater) then + do iAt=1,iQ_Atoms + E_Nuc_Rubbet = E_Nuc_Rubbet-(Eint_Nuc(iAt)+Poli(iAt,1))*ChaNuc(iAt) + end do + else + do iAt=1,iQ_Atoms + E_Nuc_Rubbet = E_Nuc_Rubbet-(Eint(iAt,1)+Poli(iAt,1))*ChaNuc(iAt) + end do + end if + end if + if (lExtr(7)) call AllenGinsberg('SCF ',Eint,Poli,ChaNuc,Cha,DipMy,Quad,MOC,iOrb(1),.false.,iOcc1,iQ_Atoms,ExpCento, & + E_Nuc_Part,lSlater,Eint_Nuc) + + call Extract(iLuExtr,i9,Etot,xyzMyQ,FockM,MOC,iOrb(1),xyzQuQ,ExpVal,ExpCento,E_Nuc_Rubbet,E_Nuc_Part) + !***JoseMEP********** + ! If MEP option. Add electr. potential, field, etc. for all solvent config. + if (lExtr(8)) then + Labjhr = 'Add ' + call AverMEP(Labjhr,Eint,Poli,iCi,SumElcPot,NCountField,PertElcInt,1,1,[1],[1],1) + NCountField = NCountField+1 + end if + !******** + else + !--------------------------------------------------------------* + ! Resume the MC-wrap up. * + !--------------------------------------------------------------* + Dele = Dele*BetaBol + DidWeAccept = .true. + if (Dele < Zero) then + iAcc = iAcc+1 + else + Expe = exp(-Dele) + Expran = Random_Molcas(iSeed) + if (iPrint >= 10) then + write(u6,*) ' Positive energy change!' + write(u6,*) ' Boltzmann weight:',Expe + write(u6,*) ' Random number:',ExpRan + end if + if (Expe >= ExpRan) then + iAcc = iAcc+1 + else + Etot = Eold + Ract = Rold + Cordst(:,:) = OldGeo + DidWeAccept = .false. + if (iPrint >= 10) write(u6,*) ' Not accepted!' + end if + end if + if (DidWeAccept) Esav = Esav+Etot + !--------------------------------------------------------------* + ! If this is a production run, then put stuff on the sampfile. * + !--------------------------------------------------------------* + if (QmProd) then !<-- Are we producing. + if (SampleThis) then !<-- Should we sample this (relevant when paralleltempering is used). + if (Inter /= 0) then + Inte = (iSnurr/Inter)*Inter + if (Inte == ((iMacro-1)*nMicro+iMicro)) call Put9(Etot,Ract,iHowMSampUT,Gmma,Gam,Esav,iDisk) + end if + end if + end if + end if + !----------------------------------------------------------------* + ! Free memory. * + !----------------------------------------------------------------* + call mma_deallocate(Dist) + call mma_deallocate(DistIm) + call mma_deallocate(FP) + call mma_deallocate(GP) + call mma_deallocate(DT) + call mma_deallocate(FI) + call Timing(Cpu5,Tim1,Tim2,Tim3) + timeMC = timeMC+(Cpu5-Cpu4) + + !----------------------------------------------------------------* + ! End of Microstep. * + !----------------------------------------------------------------* + end do + !------------------------------------------------------------------* + ! Have we collected all sampled configurations? If no, go up again.* + ! If yes, then close some files and take a little jump downwards to* + ! the END!!! * + !------------------------------------------------------------------* + !Jose*************************************** + ! This point is also used to perform the Average of the Potential, + ! Field and Field gradients to obtain and average Electrostatic + ! perturbation. The Non-Electr. perturbation is also obtained here + ! it will be added directly to the One-electron file. + !****************************************** + + if (.not. Skip) then + if ((i9 < iHowMSampIN) .and. (iRead == 9)) then + cycle outer + else if ((i9 >= iHowMSampIN) .and. (iRead == 9)) then + !*****JoseMEP** + ! If MEP option. Obtain the mean Potential, Field and Field Gradients. + ! It is also obtained the average of the Non-Electrostatic perturbation + if (lExtr(8)) then + Labjhr = 'Aver' + call AverMEP(Labjhr,Eint,Poli,iCi,SumElcPot,NCountField,PertElcInt,1,1,[1],[1],1) + + PertNElcInt(:) = PertNElcInt+AOSum/real(NCountField,kind=wp) + call mma_deallocate(AOSum) + end if + !******** + + call DaClos(iLuSaIn) + close(iLuExtr) + exit outer + end if + end if + !------------------------------------------------------------------* + ! Write to startfile. * + !------------------------------------------------------------------* + ESav = Esav/real(iAcc,kind=wp) + call Put8(Ract,Etot,Gmma,Gam,ESav) + if (Haveri) call Quit(_RC_NOT_CONVERGED_) + !------------------------------------------------------------------* + ! Print some things here at the end of the macrostep. * + !------------------------------------------------------------------* + if (.not. ParallelT) then + jMacro = iMacro + else + jMacro = 1+(iMacro-1)/nTemp + end if + write(u6,'(A,i4)') '---Macrostep ',jMacro + write(u6,'(A,i4)') ' Number of microsteps:',nMicro + Pr = 100.0_wp*(real(iAcc,kind=wp)/real(nMicro,kind=wp)) + write(u6,'(A,i4,A,f5.1,A)') ' Number of acceptances:',iAcc,'(',Pr,'%)' + write(u6,'(A,f12.4)') ' Radie (a.u.):',Ract + write(u6,'(A,f16.8)') ' Average Energy (a.u.) in Macrostep:',Esav + write(u6,'(A,3(f12.4))') ' Total dipole in QM-region last microstep (a.u.):',-xyzMyQ(1),-xyzMyQ(2),-xyzMyQ(3) + write(u6,*) + call xFlush(u6) + !------------------------------------------------------------------* + ! End of Macrostep. * + !------------------------------------------------------------------* + end do + !--------------------------------------------------------------------* + ! Put some things on info-file. Used to make tests. * + !--------------------------------------------------------------------* + call Add_Info('Total Energy',[Etot],1,6) + call Add_Info('Induction of system',[Sum1],1,6) + call Add_Info('React. field int.',[s90um],1,6) + call Add_Info('Solv-Solu Disp.',[EEdisp],1,6) + call Add_Info('QM-region Energy',[Energy],1,6) + call Add_Info('QM-region dipole',xyzMyQ,3,5) + if (.not. Loop) exit outer +end do outer +call mma_deallocate(BoMaH) +call mma_deallocate(BoMaO) +call mma_deallocate(Fil) +call mma_deallocate(Eint) +call mma_deallocate(Eint_Nuc) +call mma_deallocate(Poli) +call mma_deallocate(Smat) +call mma_deallocate(Vmat) +call mma_deallocate(SmatPure) +call mma_deallocate(FockM) +call mma_deallocate(MOC) +call mma_deallocate(SumElcPot) +if (allocated(AOSum)) call mma_deallocate(AOSum) +!----------------------------------------------------------------------* +! Close some external files. * +!----------------------------------------------------------------------* +if (QmProd .and. (iRead /= 9)) then + iDisk = 0 + iDum(1) = iHowMSampUT + call iDaFile(iLuSaUt,1,iDum,1,iDisk) + call DaClos(iLuSaUt) +end if +!----------------------------------------------------------------------* +! The End... be happy! * +!----------------------------------------------------------------------* + +write(u6,*) +write(u6,*) +write(u6,*) ' Time statistics. (hour:minute:second)' +write(u6,*) ' -----------------------------------------------------' +it1h = int(timeCLAS)/3600 +it1m = int(timeCLAS-it1h*3600)/60 +t1s = timeCLAS-it1h*3600-it1m*60 +write(u6,9) ' Time spent on pair-wise solvent-solvent interactions: ',it1h,':',it1m,':',t1s +it2h = int(timeEX)/3600 +it2m = int(timeEX-it2h*3600)/60 +t2s = timeEX-it2h*3600-it2m*60 +write(u6,9) ' Time spent on solvent-solute overlap calculations: ',it2h,':',it2m,':',t2s +it3h = int(timeEL)/3600 +it3m = int(timeEL-it3h*3600)/60 +t3s = timeEL-it3h*3600-it3m*60 +write(u6,9) ' Time spent on solvent and solute electrostatic interaction: ',it3h,':',it3m,':',t3s +it4h = int(timeMC)/3600 +it4m = int(timeMC-it4h*3600)/60 +t4s = timeMC-it4h*3600-it4m*60 +write(u6,9) ' Time spent on the Metropolis-Monte Carlo decision: ',it4h,':',it4m,':',t4s + +return + +9 format(A,I4,A,I3,A,F5.2) + +end subroutine EqScf diff -Nru openmolcas-22.02/src/qmstat/exnemo.F90 openmolcas-22.10/src/qmstat/exnemo.F90 --- openmolcas-22.02/src/qmstat/exnemo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/exnemo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,30 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +!----------------------------------------------------------------------* +! A small function to compute the Nemo exchange repulsion. * +!----------------------------------------------------------------------* +function ExNemo(i,j,a) + +use qmstat_global, only: Sexre1, Sexre2, Sexrep +use Definitions, only: wp, iwp + +implicit none +real(kind=wp) :: ExNemo +integer(kind=iwp), intent(in) :: i, j +real(kind=wp), intent(in) :: a + +!The function +ExNemo = exp(-Sexrep(i,j)/a)*Sexre1(i,j)+Sexre2(i,j)*(a**20) + +return + +end function ExNemo diff -Nru openmolcas-22.02/src/qmstat/expectus.f openmolcas-22.10/src/qmstat/expectus.f --- openmolcas-22.02/src/qmstat/expectus.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/expectus.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,91 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Expectus(QMMethod,HmatOld,Vmat,VpolMat,Smat,MxDim - & ,iVEC,nDim,lEig,iEig,ip_ExpVal) - Implicit Real*8 (a-h,o-z) - -#include "numbers.fh" -#include "WrkSpc.fh" -#include "warnings.h" - - Dimension HmatOld(MxDim),Vmat(MxDim),VpolMat(MxDim),Smat(MxDim) - Character QMMethod*5 - Logical lEig - -* -*-- Take different path for different QM-method. -* - If(QMMethod(1:5).eq.'RASSI') then -* -*---- For how many roots are the eigenvalues to be computed. -* - If(lEig) then - nRoots=iEig - Else - nRoots=nDim - Endif -* -*---- Loop over roots and compute expectation values according to -* well-known formulas. -* - nDTri=nDim*(nDim+1)/2 - Call GetMem('DenTemp','Allo','Real',iDTmp,nDTri) - Call GetMem('ExpVals','Allo','Real',ip_ExpVal,4*nRoots) - Do 801, iRoot=1,nRoots -* -*------ Generate density matrix for relevant root. -* - Call DensiSt(Work(iDTmp),Work(iVEC),iRoot,nDim,nDim) -* -*------ Expectation values. -* - Work(ip_ExpVal+4*(iRoot-1)+0)=Ddot_(nDTri,Work(iDTmp),iOne - & ,HmatOld,iOne) - Work(ip_ExpVal+4*(iRoot-1)+1)=Ddot_(nDTri,Work(iDTmp),iOne - & ,Vmat,iOne) - Work(ip_ExpVal+4*(iRoot-1)+2)=Ddot_(nDTri,Work(iDTmp),iOne - & ,Vpolmat,iOne) - Work(ip_ExpVal+4*(iRoot-1)+3)=Ddot_(nDTri,Work(iDTmp),iOne - & ,Smat,iOne) -801 Continue - Call GetMem('DenTemp','Free','Real',iDTmp,nDTri) - -* -*-- If its SCF we are running. -* - Elseif(QMMethod(1:5).eq.'SCF ') then - nDTri=nDim*(nDim+1)/2 - Call GetMem('DenTemp','Allo','Real',iDTmp,nDTri) - Call GetMem('ExpVals','Allo','Real',ip_ExpVal,4) - Call Densi_MO(Work(iDTmp),Work(iVEC),1,iEig,nDim,nDim) -* -*------ Expectation values. -* - Work(ip_ExpVal+0)=Ddot_(nDTri,Work(iDTmp),iOne,HmatOld,iOne) - Work(ip_ExpVal+1)=Ddot_(nDTri,Work(iDTmp),iOne,Vmat,iOne) - Work(ip_ExpVal+2)=Ddot_(nDTri,Work(iDTmp),iOne,Vpolmat,iOne) - Work(ip_ExpVal+3)=Ddot_(nDTri,Work(iDTmp),iOne,Smat,iOne) - Call GetMem('DenTemp','Free','Real',iDTmp,nDTri) - -* -*-- Shit happens. -* - Else - Write(6,*) - Write(6,*)' Now how did this happen, says Expectus!' - Call Quit(_RC_INTERNAL_ERROR_ ) - Endif - -* -*-- What's you major malfunction, numb nuts! -* - Return - End diff -Nru openmolcas-22.02/src/qmstat/expectus.F90 openmolcas-22.10/src/qmstat/expectus.F90 --- openmolcas-22.02/src/qmstat/expectus.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/expectus.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,91 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Expectus(QMMethod,HmatOld,Vmat,VpolMat,Smat,VEC,nDim,lEig,iEig,ExpVal) + +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp, u6, r8 + +#include "intent.fh" + +implicit none +character(len=5), intent(in) :: QMMethod +integer(kind=iwp), intent(in) :: nDIM, iEig +real(kind=wp), intent(in) :: HmatOld(nTri_Elem(nDim)), Vmat(nTri_Elem(nDim)), VpolMat(nTri_Elem(nDim)), Smat(nTri_Elem(nDim)), & + VEC(nDim,nDim) +logical(kind=iwp), intent(in) :: lEig +real(kind=wp), intent(_OUT_) :: ExpVal(4,*) +integer(kind=iwp) :: iRoot, nDTri, nRoots +real(kind=wp), allocatable :: DTmp(:) +real(kind=r8), external :: Ddot_ +#include "warnings.h" + +! Take different path for different QM-method. + +if (QMMethod(1:5) == 'RASSI') then + + ! For how many roots are the eigenvalues to be computed. + + if (lEig) then + nRoots = iEig + else + nRoots = nDim + end if + + ! Loop over roots and compute expectation values according to + ! well-known formulas. + + nDTri = nTri_Elem(nDim) + call mma_allocate(DTmp,nDTri,label='DenTemp') + do iRoot=1,nRoots + + ! Generate density matrix for relevant root. + + call DensiSt(DTmp,VEC,iRoot,nDim,nDim) + + ! Expectation values. + + ExpVal(1,iRoot) = Ddot_(nDTri,DTmp,1,HmatOld,1) + ExpVal(2,iRoot) = Ddot_(nDTri,DTmp,1,Vmat,1) + ExpVal(3,iRoot) = Ddot_(nDTri,DTmp,1,Vpolmat,1) + ExpVal(4,iRoot) = Ddot_(nDTri,DTmp,1,Smat,1) + end do + call mma_deallocate(DTmp) + +else if (QMMethod(1:5) == 'SCF ') then + ! If it's SCF we are running. + + nDTri = nTri_Elem(nDim) + call mma_allocate(DTmp,nDTri,label='DenTemp') + call Densi_MO(DTmp,VEC,1,iEig,nDim,nDim) + + ! Expectation values. + + ExpVal(1,1) = Ddot_(nDTri,DTmp,1,HmatOld,1) + ExpVal(2,1) = Ddot_(nDTri,DTmp,1,Vmat,1) + ExpVal(3,1) = Ddot_(nDTri,DTmp,1,Vpolmat,1) + ExpVal(4,1) = Ddot_(nDTri,DTmp,1,Smat,1) + call mma_deallocate(DTmp) + +else + ! Shit happens. + + write(u6,*) + write(u6,*) ' Now how did this happen, says Expectus!' + call Quit(_RC_INTERNAL_ERROR_) +end if + +! What's you major malfunction, numb nuts! + +return + +end subroutine Expectus diff -Nru openmolcas-22.02/src/qmstat/exras.f openmolcas-22.10/src/qmstat/exras.f --- openmolcas-22.02/src/qmstat/exras.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/exras.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,270 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine ExRas(iCStart,nBaseQ,nBaseC,nCnC_C,iQ_Atoms - & ,nAtomsCC,Ax,Ay,Az,itristate,SmatRas,SmatPure - & ,InCutOff,ipAOSum) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "qmcom.fh" -#include "qm2.fh" -#include "numbers.fh" -#include "WrkSpc.fh" - - Dimension SmatRas(MxStOT),CorTemp(3) - Dimension nCnC_C(MxBasC),SmatPure(MxStOT) - Dimension Inside(MxAt,3) - Logical Inside,NearBy,InCutOff - -*----------------------------------------------------------------------* -* Deduce how much the QM-molecule is translated from its position as * -* definied in Seward. * -*----------------------------------------------------------------------* - Ax=Cordst(1,1)-outxyzRAS(1,1) - Ay=Cordst(1,2)-outxyzRAS(1,2) - Az=Cordst(1,3)-outxyzRAS(1,3) - -* -*-- Make some initializations. -* - Cut_ExSq1=Cut_Ex1**2 - Cut_ExSq2=Cut_Ex2**2 - nV2size=iOrb(2)*nBaseC - nAObaseSize=nBaseQ*nBaseC - Call GetMem('RotOrb','Allo','Real',iV2,nV2size) - Call GetMem('Sint','Allo','Real',ipAOint,nAObaseSize) - Call GetMem('Sintpar','Allo','Real',ipAOintpar,nAObaseSize) - nHalf=nBaseQ*iOrb(2) - nGross=nBaseQ*(nBaseQ+1)/2 - Call GetMem('HalfTrans','Allo','Real',iHalfpar,nHalf) - Call GetMem('HalfPure','Allo','Real',iHalf,nHalf) - Call GetMem('HalfOrbE','Allo','Real',iHalfE,nHalf) - Call GetMem('Auxiliary','Allo','Real',ipAux,nBaseQ**2) - Call GetMem('AuxiliaryP','Allo','Real',ipAuxp,nBaseQ**2) - Call GetMem('GammaAO','Allo','Real',ipAOG,nGross) - Call GetMem('Accumulate','Allo','Real',ipACC,nBaseQ**2) - Call GetMem('Accumulate','Allo','Real',ipACCp,nBaseQ**2) - Call GetMem('AccumulateT','Allo','Real',ipACCt,nGross) - Call GetMem('AccumulateTP','Allo','Real',ipACCtp,nGross) - Call GetMem('TEMP','Allo','Real',iTEMP,nRedMO*iOrb(2)) - call dcopy_(nBaseQ**2,[ZERO],iZERO,Work(ipACC),iONE) - call dcopy_(nBaseQ**2,[ZERO],iZERO,Work(ipACCp),iONE) -*Jose**************************************************************** - If(lExtr(8)) then - Call GetMem('qAOclMOOvl','Allo','Real',iAOMOOvl,nHalf) - Call GetMem('qAOclMOOvlE','Allo','Real',iAOMOOvlE,nHalf) - Call GetMem('AuxAOp','Allo','Real',ipAOAUX,nBaseQ**2) - Call GetMem('AuxAOpTri','Allo','Real',ipAOAUXtri,nGross) - Endif -********************************************************************* - InCutOff=.false. - Do 575, i=1,iTriState - SmatRas(i)=0 - SmatPure(i)=0 -575 Continue - nInsideCut=0 - If(MoAveRed) then - nDim1=nRedMO - nDim2=iOrb(2) - Else - nDim1=nBaseQ - nDim2=iOrb(2) - Endif - nDimP=nDim1*nDim2 - nDimT=nDim1*(nDim1+1)/2 -* -*-- Start loop over all solvent molecules. -* - Do 501, N=iCStart-1,nCent*(nPart-1),nCent - -* -*-- Initialize -* - dist_sw=1D20 - r3=1D20 - Do 11, i=1,MxAt - Inside(i,1)=.false. - Inside(i,2)=.false. - Inside(i,3)=.false. -11 Continue - NearBy=.false. -*-----Loop over atoms. - Do 511, inwm=1,iQ_Atoms - Do 512, k=1,3 - CorTemp(k)=(Cordst(N+1,k)-Cordst(inwm,k))**2 -512 Continue - r2=CorTemp(1)+CorTemp(2)+CorTemp(3) - dist_sw=min(dist_sw,r2) - DH1=0.0d0 !Distances for the inner cut-off. Also include the - DH2=0.0d0 !hydrogens. - Do 513, k=1,3 - DH1=DH1+(Cordst(N+2,k)-Cordst(inwm,k))**2 - DH2=DH2+(Cordst(N+3,k)-Cordst(inwm,k))**2 -513 Continue - r3temp1=min(DH1,DH2) - r3temp2=min(r3temp1,r2) - r3=min(r3,r3temp2) -*-----See if these atom-atom pairs inside cut-off. - If(r2.lt.Cut_ExSq1) then - Inside(inwm,1)=.true. - NearBy=.true. - Endif - If(DH1.lt.Cut_ExSq1) then - Inside(inwm,2)=.true. - NearBy=.true. - Endif - If(DH2.lt.Cut_ExSq1) then - Inside(inwm,3)=.true. - NearBy=.true. - Endif -511 Continue -* -*-----Make some cut-off tests. -* - If(.not.NearBy) Go To 501 !If all distances larger than - !cut-off, jump to new solvent. - If(r3.lt.Cut_ExSq2) then !Inner cut-off. Set flag to true then - InCutOff=.true. !huge energy is added later. - Endif !S*S matrix, however! - nInsideCut=nInsideCut+1 - -* -*-----Start integrating. -* - Call AOIntegrate(iCStart,nBaseQ,nBaseC,Ax,Ay,Az,nCnC_C - & ,iQ_Atoms,nAtomsCC,ipAOint,ipAOintpar,iV2,N,lmax - & ,Inside) - -* -*-- Transform overlaps from solvent AO to solvent MO. -* - Call Dgemm_('N','N',nBaseQ,iOrb(2),nBaseC,ONE - & ,Work(ipAOint),nBaseQ,Work(iV2),nBaseC,ZERO - & ,Work(iHalf),nBaseQ) -*Jose*************************************************************** - If(lExtr(8)) then - call dcopy_(nHalf,Work(iHalf),iONE,Work(iAOMOOvl),iONE) - call dcopy_(nHalf,[ZERO],iZERO,Work(iAOMOOvlE),iONE) - Do 5731, k=1,iOrb(2) - ind=nBaseQ*(k-1) - Call DaxPy_(nBaseQ,c_orbene(k),Work(iAOMOOvl+ind),iONE - & ,Work(iAOMOOvlE+ind),iONE) -5731 Continue - Endif -******************************************************************** -* -*-- If average natural orbital basis used, transform again. We also -* define Dim1 and Dim2 as dimensions of matrices depending on -* whether average natural orbitals have been used. This means that -* some vectors may be larger than necessary, but since no -* huge demand of memory is required, this should not cause problem. -* - If(MoAveRed) then - Call Dgemm_ ('T','N',nRedMO,iOrb(2),nBaseQ,ONE - & ,Work(ipAvRed),nBaseQ,Work(iHalf),nBaseQ,ZERO - & ,Work(iTEMP),nRedMO) - call dcopy_(nDim1*nDim2,Work(iTEMP),iONE,Work(iHalf),iONE) - Endif -* -*-- Hook on the orbital energy. -* - call dcopy_(nDimP,[ZERO],iZERO,Work(iHalfE),iONE) - Do 5751, k=1,iOrb(2) - ind=nDim1*(k-1) - Call DaxPy_(nDim1,c_orbene(k),Work(iHalf+ind),iONE - & ,Work(iHalfE+ind),iONE) -5751 Continue - -* -*-- Construct auxiliary matrix for the non-electrostatic operator -* in AO-basis for QM region. Also construct matrix of pure -* overlaps for the higher order terms. -* - Call Dgemm_('N','T',nDim1,nDim1,iOrb(2),ONE - & ,Work(iHalf),nDim1,Work(iHalfE),nDim1,ZERO - & ,Work(ipAUX),nDim1) - Call Dgemm_('N','T',nDim1,nDim1,iOrb(2),ONE - & ,Work(iHalf),nDim1,Work(iHalf),nDim1,ZERO - & ,Work(ipAUXp),nDim1) - -* -*-- Accumulate. -* - Call DaxPy_(nDim1**2,ONE,Work(ipAUX),iONE,Work(ipACC),iONE) - Call DaxPy_(nDim1**2,ONE,Work(ipAUXp),iONE,Work(ipACCp),iONE) - -*Jose********************************* - If(lExtr(8)) then - Call Dgemm_('N','T',nBaseQ,nBaseQ,iOrb(2),exrep2 - & ,Work(iAOMOOvl),nBaseQ,Work(iAOMOOvlE),nBaseQ,ZERO - & ,Work(ipAOAUX),nBaseQ) - Call SqToTri_Q(Work(ipAOAUX),Work(ipAOAUXtri),nBaseQ) - Call DaxPy_(nGross,ONE,Work(ipAOAUXtri),iONE,Work(ipAOSum) - & ,iONE) - Endif -************************************** -* -*-- The end for this solvent molecule. -* -501 Continue -* -*-- Now construct the matrix elements to the non-electrostatic -* operator in RASSI basis. -* - kaunter=0 - Do 5703, iS=1,nState - Do 5704, jS=1,iS - HighS=0 - kaunter=kaunter+1 -*--------Collect the relevant part of the transistion density matrix. - Call dCopy_(nDimT,Work(iBigT+nDimT*(kaunter-1)) - & ,iONE,Work(ipAOG),iONE) -*--------Then transform according to theory. - Call SqToTri_Q(Work(ipACC),Work(ipACCt),nDim1) - Addition=Ddot_(nDimT,Work(ipAOG),iONE,Work(ipACCt),iONE) - SmatRas(kaunter)=SmatRas(kaunter)+exrep2*Addition -*--------And include pure S*S for subsequent higher order overlap -* repulsion. - Call SqToTri_Q(Work(ipACCp),Work(ipACCtp),nDim1) - HighS=Ddot_(nDimT,Work(ipAOG),iONE,Work(ipACCtp),iONE) - SmatPure(kaunter)=SmatPure(kaunter)+HighS -5704 Continue -5703 Continue - -* -*-- Deallocations. -* - Call GetMem('RotOrb','Free','Real',iV2,nV2size) - Call GetMem('Sint','Free','Real',ipAOint,nAObaseSize) - Call GetMem('Sintpar','Free','Real',ipAOintpar,nAObaseSize) - Call GetMem('HalfTrans','Free','Real',iHalfpar,nHalf) - Call GetMem('HalfPure','Free','Real',iHalf,nHalf) - Call GetMem('HalfOrbE','Free','Real',iHalfE,nHalf) - Call GetMem('Auxiliary','Free','Real',ipAux,nBaseQ**2) - Call GetMem('AuxiliaryP','Free','Real',ipAuxp,nBaseQ**2) - Call GetMem('GammaAO','Free','Real',ipAOG,nGross) - Call GetMem('Accumulate','Free','Real',ipACC,nBaseQ**2) - Call GetMem('Accumulate','Free','Real',ipACCp,nBaseQ**2) - Call GetMem('AccumulateT','Free','Real',ipACCt,nGross) - Call GetMem('AccumulateTP','Free','Real',ipACCtp,nGross) - Call GetMem('TEMP','Free','Real',iTEMP,nRedMO*iOrb(2)) -*Jose**************************************************************** - If(lExtr(8)) then - Call GetMem('qAOclMOOvl','Free','Real',iAOMOOvl,nHalf) - Call GetMem('qAOclMOOvlE','Free','Real',iAOMOOvlE,nHalf) - Call GetMem('AuxAOp','Free','Real',ipAOAUX,nBaseQ**2) - Call GetMem('AuxAOpTri','Free','Real',ipAOAUXtri,nGross) - Endif -********************************************************************* - - Return - End diff -Nru openmolcas-22.02/src/qmstat/exras.F90 openmolcas-22.10/src/qmstat/exras.F90 --- openmolcas-22.02/src/qmstat/exras.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/exras.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,221 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ExRas(iCStart,nBaseQ,nBaseC,iQ_Atoms,nAtomsCC,Ax,Ay,Az,itristate,SmatRas,SmatPure,InCutOff,AOSum) + +use qmstat_global, only: AvRed, BigT, c_orbene, Cordst, Cut_Ex1, Cut_Ex2, exrep2, iOrb, lExtr, lmax, MoAveRed, nCent, nPart, & + nRedMO, nState, outxyzRAS +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, r8 + +implicit none +integer(kind=iwp), intent(in) :: iCStart, nBaseQ, nBaseC, iQ_Atoms, nAtomsCC, itristate +real(kind=wp), intent(out) :: Ax, Ay, Az, SmatRas(itristate), SmatPure(itristate) +logical(kind=iwp), intent(out) :: InCutOff +real(kind=wp), intent(inout) :: AOSum(nTri_Elem(nBaseQ)) +integer(kind=iwp) :: i, ind, inwm, iS, js, kaunter, N, nDim1, nDimT, nGross, nHalf, nInsideCut +real(kind=wp) :: Addition, Cut_ExSq1, Cut_ExSq2, DH1, DH2, dist_sw, HighS, r2, r3, r3temp1, r3temp2 +logical(kind=iwp) :: NearBy +real(kind=wp), allocatable :: ACC(:,:), ACCp(:,:), ACCt(:), ACCtp(:), AOAUX(:,:), AOAUXtri(:), AOint(:,:), AOG(:), AOMOOvl(:,:), & + AOMOOvlE(:,:), HalfE(:,:), HalfP(:), TEMP(:,:), V2(:,:) +logical(kind=iwp), allocatable :: Inside(:,:) +real(kind=r8), external :: Ddot_ + +!----------------------------------------------------------------------* +! Deduce how much the QM-molecule is translated from its position as * +! defined in Seward. * +!----------------------------------------------------------------------* +Ax = Cordst(1,1)-outxyzRAS(1,1) +Ay = Cordst(2,1)-outxyzRAS(2,1) +Az = Cordst(3,1)-outxyzRAS(3,1) + +! Make some initializations. + +Cut_ExSq1 = Cut_Ex1**2 +Cut_ExSq2 = Cut_Ex2**2 +call mma_allocate(V2,nBaseC,iOrb(2),label='RotOrb') +call mma_allocate(AOint,nBaseQ,nBaseC,label='Sint') +nHalf = nBaseQ*iOrb(2) +nGross = nTri_Elem(nBaseQ) +call mma_allocate(HalfP,nBaseQ*iOrb(2),label='HalfPure') +!Jose**************************************************************** +if (lExtr(8)) then + call mma_allocate(AOMOOvl,nBaseQ,iOrb(2),label='qAOclMOOvl') + call mma_allocate(AOMOOvlE,nBaseQ,iOrb(2),label='qAOclMOOvlE') + call mma_allocate(AOAUX,nBaseQ,nBaseQ,label='AuxAOp') + call mma_allocate(AOAUXtri,nGross,label='AuxAOpTri') +end if +!******************************************************************** +InCutOff = .false. +SmatRas(:) = Zero +SmatPure(:) = Zero +nInsideCut = 0 +if (MoAveRed) then + nDim1 = nRedMO + call mma_allocate(TEMP,nDim1,iOrb(2),label='TEMP') +else + nDim1 = nBaseQ +end if +nDimT = nTri_Elem(nDim1) +call mma_allocate(HalfE,nDim1,iOrb(2),label='HalfOrbE') +call mma_allocate(AOG,nDimT,label='GammaAO') +call mma_allocate(ACC,nDim1,nDim1,label='Accumulate') +call mma_allocate(ACCp,nDim1,nDim1,label='AccumulateP') +call mma_allocate(ACCt,nDimT,label='AccumulateT') +call mma_allocate(ACCtp,nDimT,label='AccumulateTP') +ACC(:,:) = Zero +ACCp(:,:) = Zero + +! Start loop over all solvent molecules. + +call mma_allocate(Inside,iQ_Atoms,nAtomsCC,label='Inside') +do N=iCStart-1,nCent*(nPart-1),nCent + + ! Initialize + + dist_sw = huge(dist_sw) + r3 = huge(r3) + Inside(:,:) = .false. + NearBy = .false. + ! Loop over atoms. + do inwm=1,iQ_Atoms + r2 = (Cordst(1,N+1)-Cordst(1,inwm))**2+(Cordst(2,N+1)-Cordst(2,inwm))**2+(Cordst(3,N+1)-Cordst(3,inwm))**2 + dist_sw = min(dist_sw,r2) + ! Distances for the inner cut-off. Also include the hydrogens. + DH1 = (Cordst(1,N+2)-Cordst(1,inwm))**2+(Cordst(2,N+2)-Cordst(2,inwm))**2+(Cordst(3,N+2)-Cordst(3,inwm))**2 + DH2 = (Cordst(1,N+3)-Cordst(1,inwm))**2+(Cordst(2,N+3)-Cordst(2,inwm))**2+(Cordst(3,N+3)-Cordst(3,inwm))**2 + r3temp1 = min(DH1,DH2) + r3temp2 = min(r3temp1,r2) + r3 = min(r3,r3temp2) + ! See if these atom-atom pairs inside cut-off. + if (r2 < Cut_ExSq1) then + Inside(inwm,1) = .true. + NearBy = .true. + end if + if (DH1 < Cut_ExSq1) then + Inside(inwm,2) = .true. + NearBy = .true. + end if + if (DH2 < Cut_ExSq1) then + Inside(inwm,3) = .true. + NearBy = .true. + end if + end do + + ! Make some cut-off tests. + + if (.not. NearBy) cycle !If all distances larger than cut-off, jump to new solvent. + ! Inner cut-off. Set flag to true then huge energy is added later. S*S matrix, however! + if (r3 < Cut_ExSq2) InCutOff = .true. + nInsideCut = nInsideCut+1 + + ! Start integrating. + call AOIntegrate(nBaseQ,nBaseC,Ax,Ay,Az,iQ_Atoms,nAtomsCC,AOint,V2,N,lmax,Inside) + + ! Transform overlaps from solvent AO to solvent MO. + + call Dgemm_('N','N',nBaseQ,iOrb(2),nBaseC,One,AOint,nBaseQ,V2,nBaseC,Zero,HalfP,nBaseQ) + !Jose*************************************************************** + if (lExtr(8)) then + call dcopy_(nHalf,HalfP,1,AOMOOvl,1) + do i=1,iOrb(2) + AOMOOvlE(:,i) = c_orbene(i)*AOMOOvl(:,i) + end do + end if + !******************************************************************* + + ! If average natural orbital basis used, transform again. We also + ! define Dim1 and Dim2 as dimensions of matrices depending on + ! whether average natural orbitals have been used. This means that + ! some vectors may be larger than necessary, but since no + ! huge demand of memory is required, this should not cause problem. + + if (MoAveRed) then + call Dgemm_('T','N',nRedMO,iOrb(2),nBaseQ,One,AvRed,nBaseQ,HalfP,nBaseQ,Zero,TEMP,nRedMO) + call dcopy_(nDim1*iOrb(2),TEMP,1,HalfP,1) + end if + + ! Hook on the orbital energy. + + do i=1,iOrb(2) + ind = nDim1*(i-1) + HalfE(:,i) = c_orbene(i)*HalfP(ind+1:ind+nDim1) + end do + + ! Construct auxiliary matrix for the non-electrostatic operator + ! in AO-basis for QM region. Also construct matrix of pure + ! overlaps for the higher order terms. + ! And accumulate. + + call Dgemm_('N','T',nDim1,nDim1,iOrb(2),One,HalfP,nDim1,HalfE,nDim1,One,ACC,nDim1) + call Dgemm_('N','T',nDim1,nDim1,iOrb(2),One,HalfP,nDim1,HalfP,nDim1,One,ACCp,nDim1) + + !Jose********************************* + if (lExtr(8)) then + call Dgemm_('N','T',nBaseQ,nBaseQ,iOrb(2),exrep2,AOMOOvl,nBaseQ,AOMOOvlE,nBaseQ,Zero,AOAUX,nBaseQ) + call SqToTri_Q(AOAUX,AOAUXtri,nBaseQ) + AOSum(:) = AOSum+AOAUXTri + end if + !************************************* + + ! The end for this solvent molecule. + +end do + +! Now construct the matrix elements to the non-electrostatic +! operator in RASSI basis. + +kaunter = 0 +do iS=1,nState + do jS=1,iS + HighS = 0 + kaunter = kaunter+1 + ! Collect the relevant part of the transition density matrix. + AOG(:) = BigT(1:nDimT,kaunter) + ! Then transform according to theory. + call SqToTri_Q(ACC,ACCt,nDim1) + Addition = Ddot_(nDimT,AOG,1,ACCt,1) + SmatRas(kaunter) = SmatRas(kaunter)+exrep2*Addition + ! And include pure S*S for subsequent higher order overlap repulsion. + call SqToTri_Q(ACCp,ACCtp,nDim1) + HighS = Ddot_(nDimT,AOG,1,ACCtp,1) + SmatPure(kaunter) = SmatPure(kaunter)+HighS + end do +end do + +! Deallocations. + +call mma_deallocate(Inside) + +call mma_deallocate(V2) +call mma_deallocate(AOint) +call mma_deallocate(HalfP) +call mma_deallocate(HalfE) +call mma_deallocate(AOG) +call mma_deallocate(ACC) +call mma_deallocate(ACCp) +call mma_deallocate(ACCt) +call mma_deallocate(ACCtp) +if (MoAveRed) call mma_deallocate(TEMP) +!Jose**************************************************************** +if (lExtr(8)) then + call mma_deallocate(AOMOOvl) + call mma_deallocate(AOMOOvlE) + call mma_deallocate(AOAUX) + call mma_deallocate(AOAUXtri) +end if +!******************************************************************** + +return + +end subroutine ExRas diff -Nru openmolcas-22.02/src/qmstat/exscf.f openmolcas-22.10/src/qmstat/exscf.f --- openmolcas-22.02/src/qmstat/exscf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/exscf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,223 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine ExScf(iCStart,nBaseQ,nBaseC,nCnC_C,iQ_Atoms - & ,nAtomsCC,Ax,Ay,Az,itri,Smat,SmatPure,InCutOff - & ,ipAOSum) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "qmcom.fh" -#include "qm1.fh" -#include "numbers.fh" -#include "WrkSpc.fh" - - Dimension Smat(MxOT),CorTemp(3),nCnC_C(MxBasC) - Dimension SmatPure(MxOT) - Dimension Inside(MxAt,3) - Logical Inside,NearBy,InCutOff - -*----------------------------------------------------------------------* -* Deduce how much the QM-molecule is translated from its position as * -* definied in Seward. * -*----------------------------------------------------------------------* - Ax=Cordst(1,1)-outxyz(1,1) - Ay=Cordst(1,2)-outxyz(1,2) - Az=Cordst(1,3)-outxyz(1,3) -*----------------------------------------------------------------------* -* Rotate solvent orbitals and make AO integration. * -*----------------------------------------------------------------------* - Cut_ExSq1=Cut_Ex1**2 - Cut_ExSq2=Cut_Ex2**2 - nOrbSize=iOrb(1)*iOrb(2) - nV2size=iOrb(2)*nBaseC - nAObaseSize=nBaseQ*nBaseC - nStorlek=iOrb(1)*nBaseC - Call GetMem('RotOrb','Allo','Real',iV2,nV2size) - Call GetMem('Sint','Allo','Real',ipAOint,nAObaseSize) - Call GetMem('Sintpar','Allo','Real',ipAOintpar,nAObaseSize) - Call GetMem('OvlMO','Allo','Real',iOvlMO,nOrbSize) - Call GetMem('Intermed','Allo','Real',iInte,nStorlek) - Call GetMem('OvlMOpure','Allo','Real',iOPure,nOrbSize) - Call GetMem('OvlMOene','Allo','Real',iOvlMOE,nOrbSize) - Call GetMem('AUX','Allo','Real',ipAUX,iOrb(1)**2) - Call GetMem('AUXp','Allo','Real',ipAUXp,iOrb(1)**2) - Call GetMem('AUXtri','Allo','Real',ipAUXtri,iTri) -*Jose**************************************************************** - If(lExtr(8)) then - nAOqMOcl=nBaseQ*iOrb(2) - iAOAOTri=nBaseQ*(nBaseQ+1)/2 - Call GetMem('qAOclMOOvl','Allo','Real',iAOMOOvl,nAOqMOcl) - Call GetMem('qAOclMOOvlE','Allo','Real',iAOMOOvlE,nAOqMOcl) - Call GetMem('AuxAOp','Allo','Real',ipAOAUX,nBaseQ**2) - Call GetMem('AuxAOpTri','Allo','Real',ipAOAUXtri,iAOAOTri) - Endif -* Call GetMem('SumOvlAOQ','Allo','Real',ipAOSum,iAOAOTri) -********************************************************************* - InCutOff=.false. - Do 575, i=1,iTri - Smat(i)=0 - SmatPure(i)=0 -575 Continue - nInsideCut=0 - Do 501, N=iCStart-1,nCent*(nPart-1),nCent -* -*-- Initialize. -* - dist_sw=1D20 - r3=1D20 - Do 11, i=1,MxAt - Inside(i,1)=.false. - Inside(i,2)=.false. - Inside(i,3)=.false. -11 Continue - NearBy=.false. -*-----Loop over atoms. - Do 511, inwm=1,iQ_Atoms - Do 512, k=1,3 - CorTemp(k)=(Cordst(N+1,k)-Cordst(inwm,k))**2 -512 Continue - r2=CorTemp(1)+CorTemp(2)+CorTemp(3) - dist_sw=min(dist_sw,r2) - DH1=0.0d0 !Distances for the inner cut-off. Also include the - DH2=0.0d0 !hydrogens. - Do 513, k=1,3 - DH1=DH1+(Cordst(N+2,k)-Cordst(inwm,k))**2 - DH2=DH2+(Cordst(N+3,k)-Cordst(inwm,k))**2 -513 Continue - r3temp1=min(DH1,DH2) - r3temp2=min(r3temp1,r2) - r3=min(r3,r3temp2) -*----Check if this atom-atom pair inside - If(r2.lt.Cut_ExSq1) then - Inside(inwm,1)=.true. - NearBy=.true. - Endif - If(DH1.lt.Cut_ExSq1) then - Inside(inwm,2)=.true. - NearBy=.true. - Endif - If(DH2.lt.Cut_ExSq1) then - Inside(inwm,3)=.true. - NearBy=.true. - Endif -511 Continue -* -*-- Now make the cut-off test. -* - If(.not.NearBy) Go To 501 - If(r3.lt.Cut_ExSq2) then !Inner cut-off. - InCutOff=.true. - Endif - nInsideCut=nInsideCut+1 - -* -*-- Make the AO-AO overlap integration. -* - Call AOIntegrate(iCStart,nBaseQ,nBaseC,Ax,Ay,Az,nCnC_C - & ,iQ_Atoms,nAtomsCC,ipAOint,ipAOintpar,iV2,N,lmax - & ,Inside) - -* -*-- Transform to MO-MO overlap. -* - Call Dgemm_('T','N',iOrb(1),nBaseC,nBaseQ,ONE,Work(iV1) - & ,nBaseQ,Work(ipAOint),nBaseQ,ZERO,Work(iInte),iOrb(1)) - Call Dgemm_('N','N',iOrb(1),iOrb(2),nBaseC,ONE,Work(iInte) - & ,iOrb(1),Work(iV2),nBaseC,ZERO,Work(iOvlMO),iOrb(1)) - call dcopy_(nOrbSize,[ZERO],iZERO,Work(iOvlMOE),iONE) - Do 5751, i=1,iOrb(2) - ind=iOrb(1)*(i-1) - Call DaxPy_(iOrb(1),c_orbene(i),Work(iOvlMO+ind),iONE - & ,Work(iOvlMOE+ind),iONE) -5751 Continue -* -***Jose - If(lExtr(8)) then - Call Dgemm_('N','N',nBaseQ,iOrb(2),nBaseC,ONE,Work(ipAOint) - & ,nBaseQ,Work(iV2),nBaseC,ZERO,Work(iAOMOOvl),nBaseQ) - call dcopy_(nAOqMOcl,[ZERO],iZERO,Work(iAOMOOvlE),iONE) - Do 5761, i=1,iOrb(2) - ind=nBaseQ*(i-1) - Call DaxPy_(nBaseQ,c_orbene(i),Work(iAOMOOvl+ind),iONE - & ,Work(iAOMOOvlE+ind),iONE) -5761 Continue - Endif -******************** -* -*-- If you are interested, print some bla bla bla. -* - If(iPrint.ge.29) then - Write(6,*) - Write(6,*)'OVERLAP BETWEEN QM-SYSTEM AND SOLVENT MOLECULE ' - &,N/nCent - Write(6,*)'QM-MO SOLV-MO OVERLAP' - call dcopy_(iOrb(1)*iOrb(2),Work(iOvlMO),iONE - & ,Work(iOPure),iONE) - Do 54599, i=0,iOrb(1)-1 - Do 54699, j=0,iOrb(2)-1 - Write(6,8888)i+1,j+1,Work(iOPure+i+j*iOrb(1)) -54699 Continue -54599 Continue -8888 Format(I3,' ',I3,' ',F12.10) - Endif - -* -*-- Construct the perturbation and accumulate pure overlap for -* subsequent construction of higher order term. -* - Call Dgemm_('N','T',iOrb(1),iOrb(1),iOrb(2),exrep2 - & ,Work(iOvlMO),iOrb(1),Work(iOvlMOE),iOrb(1),ZERO - & ,Work(ipAUX),iOrb(1)) - Call SqToTri_Q(Work(ipAUX),Work(ipAUXtri),iOrb(1)) - Call DaxPy_(iTri,ONE,Work(ipAUXtri),iONE,Smat,iONE) - Call Dgemm_('N','T',iOrb(1),iOrb(1),iOrb(2),ONE - & ,Work(iOvlMO),iOrb(1),Work(iOvlMO),iOrb(1),ZERO - & ,Work(ipAUXp),iOrb(1)) - Call SqToTri_Q(Work(ipAUXp),Work(ipAUXtri),iOrb(1)) - Call DaxPy_(iTri,ONE,Work(ipAUXtri),iONE,SmatPure,iONE) - -*Jose********************************* - If(lExtr(8)) then - Call Dgemm_('N','T',nBaseQ,nBaseQ,iOrb(2),exrep2 - & ,Work(iAOMOOvl),nBaseQ,Work(iAOMOOvlE),nBaseQ,ZERO - & ,Work(ipAOAUX),nBaseQ) - Call SqToTri_Q(Work(ipAOAUX),Work(ipAOAUXtri),nBaseQ) - Call DaxPy_(iAOAOTri,ONE,Work(ipAOAUXtri),iONE,Work(ipAOSum) - & ,iONE) - Endif -************************************** -* -*-- This solvent molecule ends now! -* -501 Continue - - Call GetMem('RotOrb','Free','Real',iV2,nV2size) - Call GetMem('Sint','Free','Real',ipAOint,nAObaseSize) - Call GetMem('Sintpar','Free','Real',ipAOintpar,nAObaseSize) - Call GetMem('OvlMO','Free','Real',iOvlMO,nOrbSize) - Call GetMem('Intermed','Free','Real',iInte,nStorlek) - Call GetMem('OvlMOpure','Free','Real',iOPure,nOrbSize) - Call GetMem('OvlMOene','Free','Real',iOvlMOE,nOrbSize) - Call GetMem('AUX','Free','Real',ipAUX,iOrb(1)**2) - Call GetMem('AUXp','Free','Real',ipAUXp,iOrb(1)**2) - Call GetMem('AUXtri','Free','Real',ipAUXtri,iTri) -*Jose**************************************************************** - If(lExtr(8)) then - Call GetMem('qAOclMOOvl','Free','Real',iAOMOOvl,nAOqMOcl) - Call GetMem('qAOclMOOvlE','Free','Real',iAOMOOvlE,nAOqMOcl) - Call GetMem('AuxAOp','Free','Real',ipAOAUX,nBaseQ**2) - Call GetMem('AuxAOpTri','Free','Real',ipAOAUXtri,iAOAOTri) - Endif -********************************************************************* - - Return - End diff -Nru openmolcas-22.02/src/qmstat/exscf.F90 openmolcas-22.10/src/qmstat/exscf.F90 --- openmolcas-22.02/src/qmstat/exscf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/exscf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,185 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ExScf(iCStart,nBaseQ,nBaseC,iQ_Atoms,nAtomsCC,Ax,Ay,Az,itri,Smat,SmatPure,InCutOff,AOSum) + +use qmstat_global, only: c_orbene, Cordst, Cut_Ex1, Cut_Ex2, exrep2, iOrb, iPrint, lExtr, lmax, nCent, nPart, outxyz, V1 +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iCStart, nBaseQ, nBaseC, iQ_Atoms, nAtomsCC, itri +real(kind=wp), intent(out) :: Ax, Ay, Az, Smat(itri), SmatPure(itri) +logical(kind=iwp), intent(out) :: InCutOff +real(kind=wp), intent(inout) :: AOSum(*) +integer(kind=iwp) :: i, iAOAOTri, inwm, j, N, nInsideCut +real(kind=wp) :: Cut_ExSq1, Cut_ExSq2, DH1, DH2, dist_sw, r2, r3, r3temp1, r3temp2 +logical(kind=iwp) :: NearBy +real(kind=wp), allocatable :: AOAUX(:,:), AOAUXtri(:), AOint(:,:), AOMOOvl(:,:), AOMOOvlE(:,:), AUX(:,:), AUXp(:,:), AUXtri(:), & + Inte(:,:), OvlMO(:,:), OvlMOE(:,:), V2(:,:) +logical(kind=iwp), allocatable :: Inside(:,:) + +!----------------------------------------------------------------------* +! Deduce how much the QM-molecule is translated from its position as * +! defined in Seward. * +!----------------------------------------------------------------------* +Ax = Cordst(1,1)-outxyz(1,1) +Ay = Cordst(2,1)-outxyz(2,1) +Az = Cordst(3,1)-outxyz(3,1) +!----------------------------------------------------------------------* +! Rotate solvent orbitals and make AO integration. * +!----------------------------------------------------------------------* +Cut_ExSq1 = Cut_Ex1**2 +Cut_ExSq2 = Cut_Ex2**2 +call mma_allocate(V2,nBaseC,iOrb(2),label='RotOrb') +call mma_allocate(AOint,nBaseQ,nBaseC,label='Sint') +call mma_allocate(OvlMO,iOrb(1),iOrb(2),label='OvlMO') +call mma_allocate(Inte,iOrb(1),nBaseC,label='Intermed') +call mma_allocate(OvlMOE,iOrb(1),iOrb(2),label='OvlMOene') +call mma_allocate(AUX,iOrb(1),iOrb(1),label='AUX') +call mma_allocate(AUXp,iOrb(1),iOrb(1),label='AUXp') +call mma_allocate(AUXtri,iTri,label='AUXtri') +!Jose**************************************************************** +if (lExtr(8)) then + iAOAOTri = nTri_Elem(nBaseQ) + call mma_allocate(AOMOOvl,nBaseQ,iOrb(2),label='qAOclMOOvl') + call mma_allocate(AOMOOvlE,nBaseQ,iOrb(2),label='qAOclMOOvlE') + call mma_allocate(AOAUX,nBaseQ,nBaseQ,label='AuxAOp') + call mma_allocate(AOAUXtri,iAOAOTri,label='AuxAOpTri') +end if +!******************************************************************** +InCutOff = .false. +Smat(:) = Zero +SmatPure(:) = Zero +nInsideCut = 0 +call mma_allocate(Inside,iQ_Atoms,nAtomsCC,label='Inside') +do N=iCStart-1,nCent*(nPart-1),nCent + + ! Initialize. + + dist_sw = huge(dist_sw) + r3 = huge(r3) + Inside(:,:) = .false. + NearBy = .false. + ! Loop over atoms. + do inwm=1,iQ_Atoms + r2 = (Cordst(1,N+1)-Cordst(1,inwm))**2+(Cordst(2,N+1)-Cordst(2,inwm))**2+(Cordst(3,N+1)-Cordst(3,inwm))**2 + dist_sw = min(dist_sw,r2) + ! Distances for the inner cut-off. Also include the hydrogens. + DH1 = (Cordst(1,N+2)-Cordst(1,inwm))**2+(Cordst(2,N+2)-Cordst(2,inwm))**2+(Cordst(3,N+2)-Cordst(3,inwm))**2 + DH2 = (Cordst(1,N+3)-Cordst(1,inwm))**2+(Cordst(2,N+3)-Cordst(2,inwm))**2+(Cordst(3,N+3)-Cordst(3,inwm))**2 + r3temp1 = min(DH1,DH2) + r3temp2 = min(r3temp1,r2) + r3 = min(r3,r3temp2) + ! Check if this atom-atom pair inside + if (r2 < Cut_ExSq1) then + Inside(inwm,1) = .true. + NearBy = .true. + end if + if (DH1 < Cut_ExSq1) then + Inside(inwm,2) = .true. + NearBy = .true. + end if + if (DH2 < Cut_ExSq1) then + Inside(inwm,3) = .true. + NearBy = .true. + end if + end do + + ! Now make the cut-off test. + + if (.not. NearBy) cycle + ! Inner cut-off. + if (r3 < Cut_ExSq2) InCutOff = .true. + nInsideCut = nInsideCut+1 + + ! Make the AO-AO overlap integration. + + call AOIntegrate(nBaseQ,nBaseC,Ax,Ay,Az,iQ_Atoms,nAtomsCC,AOint,V2,N,lmax,Inside) + + ! Transform to MO-MO overlap. + + call Dgemm_('T','N',iOrb(1),nBaseC,nBaseQ,One,V1,nBaseQ,AOint,nBaseQ,Zero,Inte,iOrb(1)) + call Dgemm_('N','N',iOrb(1),iOrb(2),nBaseC,One,Inte,iOrb(1),V2,nBaseC,Zero,OvlMO,iOrb(1)) + do i=1,iOrb(2) + OvlMOE(:,i) = c_orbene(i)*OvlMO(:,i) + end do + + !**Jose + if (lExtr(8)) then + call Dgemm_('N','N',nBaseQ,iOrb(2),nBaseC,One,AOint,nBaseQ,V2,nBaseC,Zero,AOMOOvl,nBaseQ) + do i=1,iOrb(2) + AOMOOvlE(:,i) = c_orbene(i)*AOMOOvl(:,i) + end do + end if + !******************* + + ! If you are interested, print some bla bla bla. + + if (iPrint >= 29) then + write(u6,*) + write(u6,*) 'OVERLAP BETWEEN QM-SYSTEM AND SOLVENT MOLECULE ',N/nCent + write(u6,*) 'QM-MO SOLV-MO OVERLAP' + do i=1,iOrb(1) + do j=1,iOrb(2) + write(u6,8888) i,j,OvlMO(i,j) + end do + end do + end if + + ! Construct the perturbation and accumulate pure overlap for + ! subsequent construction of higher order term. + + call Dgemm_('N','T',iOrb(1),iOrb(1),iOrb(2),exrep2,OvlMO,iOrb(1),OvlMOE,iOrb(1),Zero,AUX,iOrb(1)) + call SqToTri_Q(AUX,AUXtri,iOrb(1)) + Smat(:) = Smat+AUXtri + call Dgemm_('N','T',iOrb(1),iOrb(1),iOrb(2),One,OvlMO,iOrb(1),OvlMO,iOrb(1),Zero,AUXp,iOrb(1)) + call SqToTri_Q(AUXp,AUXtri,iOrb(1)) + SmatPure(:) = SmatPure+AUXtri + + !Jose********************************* + if (lExtr(8)) then + call Dgemm_('N','T',nBaseQ,nBaseQ,iOrb(2),exrep2,AOMOOvl,nBaseQ,AOMOOvlE,nBaseQ,Zero,AOAUX,nBaseQ) + call SqToTri_Q(AOAUX,AOAUXtri,nBaseQ) + AOSum(1:iAOAOTri) = AOSum(1:iAOAOTri)+AOAUXtri + end if + !************************************* + + ! This solvent molecule ends now! + +end do + +call mma_deallocate(Inside) + +call mma_deallocate(V2) +call mma_deallocate(AOint) +call mma_deallocate(OvlMO) +call mma_deallocate(Inte) +call mma_deallocate(OvlMOE) +call mma_deallocate(AUX) +call mma_deallocate(AUXp) +call mma_deallocate(AUXtri) +!Jose**************************************************************** +if (lExtr(8)) then + call mma_deallocate(AOMOOvl) + call mma_deallocate(AOMOOvlE) + call mma_deallocate(AOAUX) + call mma_deallocate(AOAUXtri) +end if +!******************************************************************** + +return + +8888 format(I3,' ',I3,' ',F12.10) + +end subroutine ExScf diff -Nru openmolcas-22.02/src/qmstat/extract.f openmolcas-22.10/src/qmstat/extract.f --- openmolcas-22.02/src/qmstat/extract.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/extract.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,151 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine Extract(iLu,i9,Etot,xyzMy,Hmat,iC,iDt,nMatBas,HMatOld - & ,xyzQuQ,ip_ExpVal,ip_ExpCento,ENR,ENP) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" - - Dimension xyzMy(3),Hmat(*),HMatOld(*),xyzQuQ(6) - Dimension iDt(3) - -* -*--- Just pass on the numbers according to QM-method. -* - If(QmType(1:4).eq.'RASS') then - Call ExtractR(iLu,i9,Etot,xyzMy,Hmat,iC,iDt,nMatBas,HMatOld - & ,xyzQuQ,lExtr,iExtr_Eig,iExtr_Atm,ip_ExpVal - & ,ip_ExpCento,ENR,ENP) - ElseIf(QmType(1:3).eq.'SCF') then - Call ExtractS(iLu,i9,Etot,xyzMy,Hmat,iC,iDt,nMatBas,xyzQuQ - & ,lExtr,iExtr_Atm,ip_ExpVal,ip_ExpCento,ENR,ENP) - Endif - - Return - End - - - Subroutine ExtractR(iLu,i9,Etot,xyzMy,Hmat,iC,iDt,nState,HMatOld - & ,xyzQu,lExtr,iExtr_Eig,iExtr_Atm,ip_ExpVal - & ,ip_ExpCento,ENR,ENP) - Implicit Real*8 (a-h,o-z) - -#include "WrkSpc.fh" - - Dimension xyzMy(3),Hmat(*),HMatOld(*),xyzQu(6) - Dimension iDt(3),iExtr_Atm(*) - Logical lExtr(*) - - Write(iLu,*)'<<<<<<>>>>>>' - If(lExtr(1)) then - Write(iLu,*)'Total Energy' - Write(iLu,'(F15.8)')Etot - Endif - If(lExtr(2)) then - Write(iLu,*)'QM-Dipole' - Write(iLu,'(3(F12.5))')(xyzMy(k),k=1,3) - Endif - If(lExtr(3)) then - Write(iLu,*)'QM-Quadrupole' - Write(iLu,'(6(F12.5))')(xyzQu(k),k=1,6) - Endif - If(lExtr(4)) then - Write(iLu,*)'Eigenvalues of RASSI-matrix' - Do 1, i=1,iExtr_Eig - ind=i*(i+1)/2 - Write(iLu,'(F15.8)')Hmat(ind) -1 Continue - Endif - If(lExtr(5)) then - Write(iLu,*)'Corresponding eigenvectors' - Do 2, j=0,iExtr_Eig-1 - Write(iLu,'(5(F15.8))')(Work(iC+j*nState+k),k=0,nState-1) -2 Continue - Endif - If(lExtr(6)) then - Write(iLu,*)'Expectation values (H_0,V_el,V_pol,V_pp)' - Write(iLu,*)' Nuc cont:',ENR - If(lExtr(4)) nDim=iExtr_Eig - If(.not.lExtr(4)) nDim=nState - Do 3, i=1,nDim - Write(iLu,'(4(F15.8))')(Work(ip_ExpVal+4*(i-1)+k),k=0,3) -3 Continue - Call GetMem('ExpVals','Free','Real',ip_ExpVal,4*nDim) - Endif - If(lExtr(7)) then - Write(iLu,*)'Expectation values partial V_el, V_pol' - Write(iLu,*)' Nuc cont:',ENP - If(lExtr(4)) nDim=iExtr_Eig - If(.not.lExtr(4)) nDim=nState - Do 4, j=1,nDim - Write(iLu,'(2(F15.8))')(Work(ip_ExpCento+4*(j-1)+k),k=1,2) -4 Continue - Call GetMem('ExpVals','Free','Real',ip_ExpCento,4*nDim) - Endif - - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer_array(iDt) - Call Unused_real_array(HMatOld) - Call Unused_integer_array(iExtr_Atm) - End If - End - - - Subroutine ExtractS(iLu,i9,Etot,xyzMy,Hmat,iC,iDt,nBas,xyzQu - & ,lExtr,iExtr_Atm,ip_ExpVal,ip_ExpCento - & ,ENR,ENP) - Implicit Real*8 (a-h,o-z) - -#include "WrkSpc.fh" - - Dimension xyzMy(3),Hmat(*),xyzQu(6) - Dimension iDt(3),iExtr_Atm(*) - Logical lExtr(*) - - Write(iLu,*)'<<<<<<>>>>>>' - If(lExtr(1)) then - Write(iLu,*)'Total Energy' - Write(iLu,'(F15.8)')Etot - Endif - If(lExtr(2)) then - Write(iLu,*)'QM-Dipole' - Write(iLu,'(3(F12.5))')(xyzMy(k),k=1,3) - Endif - If(lExtr(3)) then - Write(iLu,*)'QM-Quadrupole' - Write(iLu,'(6(F12.5))')(xyzQu(k),k=1,6) - Endif - If(lExtr(6)) then - Write(iLu,*)'Expectation values (T+H_nuc,V_el,V_pol,V_pp)' - Write(iLu,*)' Nuc cont:',ENR - Write(iLu,'(4(F15.8))')(Work(ip_ExpVal+k),k=0,3) - Call GetMem('ExpVals','Free','Real',ip_ExpVal,4) - Endif - If(lExtr(7)) then - Write(iLu,*)'Expectation values partial V_el, V_pol' - Write(iLu,*)' Nuc cont:',ENP - Write(iLu,'(2(F15.8))')(Work(ip_ExpCento+k),k=1,2) - Call GetMem('ExpVals','Free','Real',ip_ExpCento,4) - Endif - - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Hmat) - Call Unused_integer(iC) - Call Unused_integer_array(iDt) - Call Unused_integer(nBas) - Call Unused_integer_array(iExtr_Atm) - End If - End diff -Nru openmolcas-22.02/src/qmstat/extract.F90 openmolcas-22.10/src/qmstat/extract.F90 --- openmolcas-22.02/src/qmstat/extract.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/extract.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,33 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine Extract(iLu,i9,Etot,xyzMy,Hmat,C,nMatBas,xyzQuQ,ExpVal,ExpCento,ENR,ENP) + +use qmstat_global, only: iExtr_Eig, lExtr, QmType +use Index_Functions, only: nTri_Elem +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iLu, i9, nMatBas +real(kind=wp), intent(in) :: Etot, xyzMY(3), Hmat(nTri_Elem(iExtr_Eig)), C(nMatBas,nMatBas), xyzQuQ(6), ExpVal(4,*), & + ExpCento(4,*), ENR, ENP + +! Just pass on the numbers according to QM-method. + +if (QmType(1:4) == 'RASS') then + call ExtractR(iLu,i9,Etot,xyzMy,Hmat,C,nMatBas,xyzQuQ,lExtr,iExtr_Eig,ExpVal,ExpCento,ENR,ENP) +else if (QmType(1:3) == 'SCF') then + call ExtractS(iLu,i9,Etot,xyzMy,xyzQuQ,lExtr,ExpVal,ExpCento,ENR,ENP) +end if + +return + +end subroutine Extract diff -Nru openmolcas-22.02/src/qmstat/extractr.F90 openmolcas-22.10/src/qmstat/extractr.F90 --- openmolcas-22.02/src/qmstat/extractr.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/extractr.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,77 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ExtractR(iLu,i9,Etot,xyzMy,Hmat,C,nState,xyzQu,lExtr,iExtr_Eig,ExpVal,ExpCento,ENR,ENP) + +use Index_Functions, only: nTri_Elem +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iLu, i9, nState, iExtr_Eig +real(kind=wp), intent(in) :: Etot, xyzMy(3), Hmat(nTri_Elem(iExtr_Eig)), C(nState,nState), xyzQu(6), ExpVal(4,nState), & + ExpCento(4,nState), ENR, ENP +logical(kind=iwp), intent(in) :: lExtr(*) +integer(kind=iwp) :: i, ind, j, nDim + +write(iLu,*) '<<<<<<>>>>>>' +if (lExtr(1)) then + write(iLu,*) 'Total Energy' + write(iLu,'(F15.8)') Etot +end if +if (lExtr(2)) then + write(iLu,*) 'QM-Dipole' + write(iLu,'(3(F12.5))') xyzMy(:) +end if +if (lExtr(3)) then + write(iLu,*) 'QM-Quadrupole' + write(iLu,'(6(F12.5))') xyzQu(:) +end if +if (lExtr(4)) then + write(iLu,*) 'Eigenvalues of RASSI-matrix' + do i=1,iExtr_Eig + ind = nTri_Elem(i) + write(iLu,'(F15.8)') Hmat(ind) + end do +end if +if (lExtr(5)) then + write(iLu,*) 'Corresponding eigenvectors' + do j=1,iExtr_Eig + write(iLu,'(5(F15.8))') C(:,j) + end do +end if +if (lExtr(6)) then + write(iLu,*) 'Expectation values (H_0,V_el,V_pol,V_pp)' + write(iLu,*) ' Nuc cont:',ENR + if (lExtr(4)) then + nDim = iExtr_Eig + else + nDim = nState + end if + do i=1,nDim + write(iLu,'(4(F15.8))') ExpVal(:,i) + end do +end if +if (lExtr(7)) then + write(iLu,*) 'Expectation values partial V_el, V_pol' + write(iLu,*) ' Nuc cont:',ENP + if (lExtr(4)) then + nDim = iExtr_Eig + else + nDim = nState + end if + do j=1,nDim + write(iLu,'(2(F15.8))') ExpCento(:,i) + end do +end if + +return + +end subroutine ExtractR diff -Nru openmolcas-22.02/src/qmstat/extracts.F90 openmolcas-22.10/src/qmstat/extracts.F90 --- openmolcas-22.02/src/qmstat/extracts.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/extracts.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,47 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine ExtractS(iLu,i9,Etot,xyzMy,xyzQu,lExtr,ExpVal,ExpCento,ENR,ENP) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iLu, i9 +real(kind=wp), intent(in) :: Etot, xyzMy(3), xyzQu(6), ExpVal(4,1), ExpCento(4,1), ENR, ENP +logical(kind=iwp), intent(in) :: lExtr(*) + +write(iLu,*) '<<<<<<>>>>>>' +if (lExtr(1)) then + write(iLu,*) 'Total Energy' + write(iLu,'(F15.8)') Etot +end if +if (lExtr(2)) then + write(iLu,*) 'QM-Dipole' + write(iLu,'(3(F12.5))') xyzMy(:) +end if +if (lExtr(3)) then + write(iLu,*) 'QM-Quadrupole' + write(iLu,'(6(F12.5))') xyzQu(:) +end if +if (lExtr(6)) then + write(iLu,*) 'Expectation values (T+H_nuc,V_el,V_pol,V_pp)' + write(iLu,*) ' Nuc cont:',ENR + write(iLu,'(4(F15.8))') ExpVal(:,1) +end if +if (lExtr(7)) then + write(iLu,*) 'Expectation values partial V_el, V_pol' + write(iLu,*) ' Nuc cont:',ENP + write(iLu,'(2(F15.8))') ExpCento(:,1) +end if + +return + +end subroutine ExtractS diff -Nru openmolcas-22.02/src/qmstat/fetchtdm.f openmolcas-22.10/src/qmstat/fetchtdm.f --- openmolcas-22.02/src/qmstat/fetchtdm.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/fetchtdm.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ - Subroutine FetchTDM(nB,nS,iBigT,TDMchar) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "WrkSpc.fh" - - Dimension iTocBig(MxStOT) - - Character TDMchar*6 - - iDisk=0 - kaunter=0 - nSize=nB*(nB+1)/2 - index=0 - Lu=72 - Lu=IsFreeUnit(Lu) - Call DaName(Lu,TDMchar) - Call iDaFile(Lu,2,iTocBig,MxStOT,iDisk) - Do 99991, iS1=1,nS - Do 99992, iS2=1,iS1 - kaunter=kaunter+1 - iDisk=iTocBig(kaunter) - Call dDaFile(Lu,2,Work(iBigT+index),nSize,iDisk) - index=index+nSize -99992 Continue -99991 Continue - Call DaClos(Lu) - - Return - End diff -Nru openmolcas-22.02/src/qmstat/fetchtdm.F90 openmolcas-22.10/src/qmstat/fetchtdm.F90 --- openmolcas-22.02/src/qmstat/fetchtdm.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/fetchtdm.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,45 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +subroutine FetchTDM(nB,nS,TDMchar) + +use qmstat_global, only: BigT, nState +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: nB, nS +character(len=*), intent(in) :: TDMchar +integer(kind=iwp) :: iDisk, iS1, iS2, kaunter, Lu, nSize +integer(kind=iwp), allocatable :: iTocBig(:) +integer(kind=iwp), external :: IsFreeUnit + +iDisk = 0 +kaunter = 0 +nSize = nTri_Elem(nB) +Lu = IsFreeUnit(72) +call DaName(Lu,TDMchar) +call mma_allocate(iTocBig,nTri_Elem(nState),label='iTocBig') +call iDaFile(Lu,2,iTocBig,nTri_Elem(nState),iDisk) +do iS1=1,nS + do iS2=1,iS1 + kaunter = kaunter+1 + iDisk = iTocBig(kaunter) + call dDaFile(Lu,2,BigT(:,kaunter),nSize,iDisk) + end do +end do +call mma_deallocate(iTocBig) +call DaClos(Lu) + +return + +end subroutine FetchTDM diff -Nru openmolcas-22.02/src/qmstat/ffactor.F90 openmolcas-22.10/src/qmstat/ffactor.F90 --- openmolcas-22.02/src/qmstat/ffactor.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/ffactor.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,101 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) Anders Ohrn * +!*********************************************************************** + +!----------------------------------------------------------------------* +! A subroutine that computes those darn f-factors. They are defined * +! in equation (2.4) in doi:10.1143/JPSJ.21.2313. As can be seen from * +! that equation, the computation of the f-factors is actually a matter * +! of using the binomial theorem. This is what we do below and to make * +! the computation efficient the expression (2.4) is written as a * +! succint double sum. * +!----------------------------------------------------------------------* +subroutine fFactor(loneX,ltwoX,lsumX,loneY,ltwoY,lsumY,loneZ,ltwoZ,lsumZ,PAxyz,PBxyz,FactorX,FactorY,FactorZ) + +use qmstat_global, only: MxAngqNr +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: loneX, ltwoX, lsumX, loneY, ltwoY, lsumY, loneZ, ltwoZ, lsumZ +real(kind=wp), intent(in) :: PAxyz(3), PBxyz(3) +real(kind=wp), intent(out) :: FactorX(2*MxAngqNr+1), FactorY(2*MxAngqNr+1), FactorZ(2*MxAngqNr+1) +integer(kind=iwp) :: i, ia, iLowB, iUpB +real(kind=wp) :: fff1, fff2, PAraise, PBraise +integer(kind=iwp), external :: NoverP_Q + +do ia=0,lsumX !We use unrolled loops with regard to x,y and z therefore, here we start with the x-factors. + fff2 = 0 + ! These lower and upper bounds have to do + ! with the allowed numbers in the binomial coefficients. + iLowB = max(0,ia-ltwoX) + iUpB = min(ia,loneX) + do i=iLowB,iUpB + fff1 = NoverP_Q(loneX,i)*NoverP_Q(ltwoX,ia-i) + if (i /= 0) then !This is needed for some compilers (NAG_64) + PAraise = PAxyz(1)**i + else + PAraise = One + end if + if (ia-i /= 0) then + PBraise = PBxyz(1)**(ia-i) + else + PBraise = One + end if + fff2 = fff2+fff1*PAraise*PBraise + end do + FactorX(lsumX-ia+1) = fff2 +end do +do ia=0,lsumY !y-factors. + fff2 = 0 + iLowB = max(0,ia-ltwoY) + iUpB = min(ia,loneY) + do i=iLowB,iUpB + fff1 = NoverP_Q(loneY,i)*NoverP_Q(ltwoY,ia-i) + if (i /= 0) then !This is needed for some compilers (NAG_64) + PAraise = PAxyz(2)**i + else + PAraise = One + end if + if (ia-i /= 0) then + PBraise = PBxyz(2)**(ia-i) + else + PBraise = One + end if + fff2 = fff2+fff1*PAraise*PBraise + end do + FactorY(lsumY-ia+1) = fff2 +end do +do ia=0,lsumZ !z-factorz. + fff2 = 0 + iLowB = max(0,ia-ltwoZ) + iUpB = min(ia,loneZ) + do i=iLowB,iUpB + fff1 = NoverP_Q(loneZ,i)*NoverP_Q(ltwoZ,ia-i) + if (i /= 0) then !This is needed for some compilers (NAG_64) + PAraise = PAxyz(3)**i + else + PAraise = One + end if + if (ia-i /= 0) then + PBraise = PBxyz(3)**(ia-i) + else + PBraise = One + end if + fff2 = fff2+fff1*PAraise*PBraise + end do + Factorz(lsumZ-ia+1) = fff2 +end do + +return + +end subroutine fFactor diff -Nru openmolcas-22.02/src/qmstat/files_qmstat.fh openmolcas-22.10/src/qmstat/files_qmstat.fh --- openmolcas-22.02/src/qmstat/files_qmstat.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/files_qmstat.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,26 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -*--------------------------------------------------------------------* -* An include file to keep check of the files generated by Qmstat. * -*--------------------------------------------------------------------* - Integer iLuStIn,iLuStUt,iLuSaIn,iLuSaUt,iLuBlockIn - &,iLuBlockUt - Character*6 StFilIn,SaFilIn,StFilUt,SaFilUt - &,BlockIn,BlockUt,JbName,RassiM,GammaO,EigV,SimEx,AddOns -*--Jose: New file for the optimization procedure*---- - &,FieldNuc - Common /Uni/ iLuStIn, iLuSaIn,iLuStUt,iLuSaUt - &,iLuBlockIn,iLuBlockUt - Common /FilNa/ StFilIn,SaFilIn,StFilUt,SaFilUt - &,BlockIn,BlockUt,JbName(MxJobs),RassiM,GammaO,EigV,SimEx - &,AddOns(3),FieldNuc - - Common /Tocs_QMSTAT/ iTcSim(64) diff -Nru openmolcas-22.02/src/qmstat/geogen.f openmolcas-22.10/src/qmstat/geogen.f --- openmolcas-22.02/src/qmstat/geogen.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/geogen.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,214 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -* * -* Copyright (C) Anders Ohrn * -************************************************************************ -* Geogen -* -*> @brief -*> Generate the new configuration in typical random manner -*> @author A. Ohrn -*> -*> @details -*> The creator of random geometries in typical Monte-Carlo fashion. -*> The changes made are: -*> -*> 1. The dielectric radius is modified -*> 2. Each coordinate *except* the \c iSta-1 -th molecule is changed -*> 3. All molecules (with the above exception) are rotated around the oxygen (which approximately equals the CM) -*> 4. Every molecule except the fixed ones are rotated slightly around one of the global \f$ x \f$-, \f$ y \f$- or \f$ z \f$-axes; -*> the purpose of this is to emulate a rotation of the central molecule and therefore make the system more dynamic. -*> -*> @param[in,out] Ract The dielectric radius on input and the slightly perturbed radius on output -*> @param[out] Rold Stores the input dielectric radius -*> @param[in] iCNum How many solvent places that are taken up by the QM-molecule -************************************************************************ - Subroutine Geogen(Ract,Rold,iCNum,iQ_Atoms) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qmcom.fh" -#include "qminp.fh" - - Dimension Dq(3) - External Ranf -*------------------------------------------------------------------------* -* Store old configuration. * -*------------------------------------------------------------------------* - Do 12,i=1,nPart*nCent - Do 13,j=1,3 - OldGeo(i,j)=Cordst(i,j) -13 Continue -12 Continue -*------------------------------------------------------------------------* -* Query which type of simulation this is, and if quantum then change * -* the quantum molecule. * -*------------------------------------------------------------------------* - If(Qmeq.or.QmProd) then !Which coordinates to keep fixed. - iSta=iCNum+1 !This sees to that the QM-molecule is excluded - !from the moves below. - Dq(1)=delX*(ranf(iseed)-0.5) - Dq(2)=delX*(ranf(iseed)-0.5) - Dq(3)=delX*(ranf(iseed)-0.5) - Do 21,iAt=1,iQ_Atoms - Do 22,ii=1,3 - Cordst(iAt,ii)=Cordst(iAt,ii)+Dq(ii) !Move QM-mol. -22 Continue -21 Continue - Endif -*-----------------------------------------------------------------------* -* Obtain the random-stuff and make small geometry change. * -*-----------------------------------------------------------------------* - Rold=Ract - Ract=Ract+(ranf(iseed)-0.5)*DelR !Change in cavity radius - Do 100, i=iSta,nPart !Which molecules to give new coordinates. - ij=(i-1)*nCent - Do 101, j=1,3 - Dx=DelX*(ranf(iseed)-0.5) - Do 102, k=1,nCent - ii=ij+k - Cordst(ii,j)=Cordst(ii,j)+Dx !Make translation -102 Continue -101 Continue - Cx=Cordst(ij+1,1) !The oxygen, around which we rotate - Cy=Cordst(ij+1,2) - Cz=Cordst(ij+1,3) - B=(ranf(iseed)-0.5)*DelFi - CB=Cos(B) - SB=Sin(B) - Do 111, k=2,nCent !Rotate around the oxygen in yz-plane, i.e. - y=Cordst(ij+k,2)-Cy !around x-axis. - z=Cordst(ij+k,3)-Cz - yNy=y*CB+z*SB !This is a rotation matrix - zNy=z*CB-y*SB - Cordst(ij+k,2)=yNy+Cy - Cordst(ij+k,3)=zNy+Cz -111 Continue - B=(ranf(iseed)-0.5)*DelFi - CB=Cos(B) - SB=Sin(B) - Do 112, k=2,nCent !And now rotate in xz-plane - x=Cordst(ij+k,1)-Cx - z=Cordst(ij+k,3)-Cz - xNy=x*CB+z*SB - zNy=z*CB-x*SB - Cordst(ij+k,1)=xNy+Cx - Cordst(ij+k,3)=zNy+Cz -112 Continue - B=(ranf(iseed)-0.5)*DelFi - CB=Cos(B) - SB=Sin(B) - Do 113, k=2,nCent !To your surprise, here we rotate in the - x=Cordst(ij+k,1)-Cx !xy-plane. - y=Cordst(ij+k,2)-Cy - xNy=x*CB+y*SB - yNy=y*CB-x*SB - Cordst(ij+k,1)=xNy+Cx - Cordst(ij+k,2)=yNy+Cy -113 Continue -100 Continue -*Here all other water molecules rotate around one of the three axes, -*except the ones we fix, which in a qm-simulation is the -*quantum particle. - A=ranf(iseed) - B=(ranf(iseed)-0.5)*DelFi*0.1 - CB=Cos(B) - SB=Sin(B) - If(A.le.0.33333333) then !make it random whether we rotate around - !x, y or z. - Do 201, i=iSta,nPart - ij=(i-1)*nCent - Do 202, k=1,nCent - ii=ij+k - Cy=Cordst(ii,2) - Cz=Cordst(ii,3) - Cordst(ii,2)=Cy*CB+Cz*SB - Cordst(ii,3)=Cz*CB-Cy*SB -202 Continue -201 Continue - Else - If(A.le.0.66666667) then - Do 211, i=iSta,nPart - ij=(i-1)*nCent - Do 212, k=1,nCent - ii=ij+k - Cx=Cordst(ii,1) - Cz=Cordst(ii,3) - Cordst(ii,1)=Cx*CB+Cz*SB - Cordst(ii,3)=CB*Cz-SB*Cx -212 Continue -211 Continue - Else - Do 221, i=iSta,nPart - ij=(i-1)*nCent - Do 222, k=1,nCent - ii=ij+k - Cx=Cordst(ii,1) - Cy=Cordst(ii,2) - Cordst(ii,1)=Cx*CB+Cy*SB - Cordst(ii,2)=CB*Cy-SB*Cx -222 Continue -221 Continue - Endif - Endif -*---------------------------------------------------------------------* -* Generate the image points that correspond with the new coordinates. * -* We follow Friedman. Since no image is created here for the qm- * -* molecule, start with query. * -*---------------------------------------------------------------------* - Ind=0 !The SM-defaults. - iImage=1 - If(Qmeq.or.QmProd) then - Ind=iCNum*nCent !Makes sure that the first slots in CordIm - !are empty - iImage=iSta - Endif - iQsta=nCent-nCha+1 - A2=Ract**2 - DiFac=-(DiEl-1.0)/(DiEl+1.0) - Do 301, i=1,3 - xyzMyp(i)=0 -301 Continue - Do 302, i=iImage,nPart - Do 303, j=1,nCent - Ind=Ind+1 - S2=0 - Do 304, k=1,3 - S2=S2+Cordst(Ind,k)**2 -304 Continue - S2=A2/S2 - Sqrts2=Sqrt(S2) - Sqrs(Ind)=Sqrts2 - If(j.le.nPol) then - QImp(Ind)=0 - Do 305, k=1,3 - Dim(Ind,k)=0 -305 Continue - Endif - If(j.ge.iQsta) then - qq=Qsta(j-nCent+nCha) - q=DiFac*Sqrts2*qq - Qim(Ind)=q - Else - qq=0 - Qim(Ind)=0 - Endif - Do 306, k=1,3 - xyzMyp(k)=xyzMyp(k)-qq*Cordst(Ind,k) !Total dipole of - !the cavity; used in polink.f. - CordIm(Ind,k)=Cordst(Ind,k)*S2 -306 Continue -303 Continue -302 Continue -*-----------------------------------------------------------------------* -* Exit. * -*-----------------------------------------------------------------------* - Return - End diff -Nru openmolcas-22.02/src/qmstat/geogen.F90 openmolcas-22.10/src/qmstat/geogen.F90 --- openmolcas-22.02/src/qmstat/geogen.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/geogen.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,200 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +! * +! Copyright (C) Anders Ohrn * +!*********************************************************************** +! Geogen +! +!> @brief +!> Generate the new configuration in typical random manner +!> @author A. Ohrn +!> +!> @details +!> The creator of random geometries in typical Monte-Carlo fashion. +!> The changes made are: +!> +!> 1. The dielectric radius is modified +!> 2. Each coordinate *except* the \c iSta-1 -th molecule is changed +!> 3. All molecules (with the above exception) are rotated around the oxygen (which approximately equals the CM) +!> 4. Every molecule except the fixed ones are rotated slightly around one of the global \f$ x \f$-, \f$ y \f$- or \f$ z \f$-axes; +!> the purpose of this is to emulate a rotation of the central molecule and therefore make the system more dynamic. +!> +!> @param[in,out] Ract The dielectric radius on input and the slightly perturbed radius on output +!> @param[out] Rold Stores the input dielectric radius +!> @param[in] iCNum How many solvent places that are taken up by the QM-molecule +!> @param[in] iQ_Atoms +!*********************************************************************** + +subroutine Geogen(Ract,Rold,iCNum,iQ_Atoms) + +use qmstat_global, only: CordIm, Cordst, DelFi, DelR, delX, Diel, DipIm, iSeed, iSta, nCent, nCha, nPart, nPol, OldGeo, Sqrs, Qim, & + Qimp, Qmeq, QmProd, Qsta, xyzMyp +use Constants, only: Zero, One, Two, Three, Ten, Half +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(inout) :: Ract +real(kind=wp), intent(out) :: Rold +integer(kind=iwp), intent(in) :: iCNum, iQ_Atoms +integer(kind=iwp) :: i, ii, iImage, ij, Ind, iQsta, j, k +real(kind=wp) :: A, A2, B, CB, Cx, Cy, Cz, DiFac, Dx, q, qq, S2, SB, Sqrts2, x, xNy, y, yNy, z, zNy +real(kind=wp), external :: Random_Molcas + +!----------------------------------------------------------------------* +! Store old configuration. * +!----------------------------------------------------------------------* +OldGeo(:,:) = Cordst +!----------------------------------------------------------------------* +! Query which type of simulation this is, and if quantum then change * +! the quantum molecule. * +!----------------------------------------------------------------------* +if (Qmeq .or. QmProd) then !Which coordinates to keep fixed. + iSta = iCNum+1 !This sees to that the QM-molecule is excluded from the moves below. + do j=1,3 + Dx = delX*(Random_Molcas(iSeed)-Half) + Cordst(j,1:iQ_Atoms) = Cordst(j,1:iQ_Atoms)+Dx !Move QM-mol. + end do +end if +!----------------------------------------------------------------------* +! Obtain the random-stuff and make small geometry change. * +!----------------------------------------------------------------------* +Rold = Ract +Ract = Ract+(Random_Molcas(iSeed)-Half)*DelR !Change in cavity radius +do i=iSta,nPart !Which molecules to give new coordinates. + ij = (i-1)*nCent + do j=1,3 + Dx = DelX*(Random_Molcas(iSeed)-Half) + Cordst(j,ij+1:ij+nCent) = Cordst(j,ij+1:ij+nCent)+Dx !Make translation + end do + Cx = Cordst(1,ij+1) !The oxygen, around which we rotate + Cy = Cordst(2,ij+1) + Cz = Cordst(3,ij+1) + B = (Random_Molcas(iSeed)-Half)*DelFi + CB = cos(B) + SB = sin(B) + do k=2,nCent !Rotate around the oxygen in yz-plane, i.e. around x-axis. + y = Cordst(2,ij+k)-Cy + z = Cordst(3,ij+k)-Cz + yNy = y*CB+z*SB !This is a rotation matrix + zNy = z*CB-y*SB + Cordst(2,ij+k) = yNy+Cy + Cordst(3,ij+k) = zNy+Cz + end do + B = (Random_Molcas(iSeed)-Half)*DelFi + CB = cos(B) + SB = sin(B) + do k=2,nCent !And now rotate in xz-plane + x = Cordst(1,ij+k)-Cx + z = Cordst(3,ij+k)-Cz + xNy = x*CB+z*SB + zNy = z*CB-x*SB + Cordst(1,ij+k) = xNy+Cx + Cordst(3,ij+k) = zNy+Cz + end do + B = (Random_Molcas(iSeed)-Half)*DelFi + CB = cos(B) + SB = sin(B) + do k=2,nCent !To your surprise, here we rotate in the xy-plane + x = Cordst(1,ij+k)-Cx + y = Cordst(2,ij+k)-Cy + xNy = x*CB+y*SB + yNy = y*CB-x*SB + Cordst(1,ij+k) = xNy+Cx + Cordst(2,ij+k) = yNy+Cy + end do +end do +! Here all other water molecules rotate around one of the three axes, +! except the ones we fix, which in a QM-simulation is the quantum particle. +A = Random_Molcas(iSeed) +B = (Random_Molcas(iSeed)-Half)*DelFi/Ten +CB = cos(B) +SB = sin(B) +if (A*Three <= One) then !make it random whether we rotate around x, y or z. + do i=iSta,nPart + ij = (i-1)*nCent + do k=1,nCent + ii = ij+k + Cy = Cordst(2,ii) + Cz = Cordst(3,ii) + Cordst(2,ii) = Cy*CB+Cz*SB + Cordst(3,ii) = Cz*CB-Cy*SB + end do + end do +else if (A*Three <= Two) then + do i=iSta,nPart + ij = (i-1)*nCent + do k=1,nCent + ii = ij+k + Cx = Cordst(1,ii) + Cz = Cordst(3,ii) + Cordst(1,ii) = Cx*CB+Cz*SB + Cordst(3,ii) = CB*Cz-SB*Cx + end do + end do +else + do i=iSta,nPart + ij = (i-1)*nCent + do k=1,nCent + ii = ij+k + Cx = Cordst(1,ii) + Cy = Cordst(2,ii) + Cordst(1,ii) = Cx*CB+Cy*SB + Cordst(2,ii) = CB*Cy-SB*Cx + end do + end do +end if +!----------------------------------------------------------------------* +! Generate the image points that correspond with the new coordinates. * +! We follow Friedman. Since no image is created here for the qm- * +! molecule, start with query. * +!----------------------------------------------------------------------* +Ind = 0 !The SM-defaults. +iImage = 1 +if (Qmeq .or. QmProd) then + Ind = iCNum*nCent !Makes sure that the first slots in CordIm are empty + iImage = iSta +end if +iQsta = nCent-nCha+1 +A2 = Ract**2 +DiFac = -(Diel-One)/(Diel+One) +xyzMyp(:) = Zero +do i=iImage,nPart + do j=1,nCent + Ind = Ind+1 + S2 = Zero + do k=1,3 + S2 = S2+Cordst(k,Ind)**2 + end do + S2 = A2/S2 + Sqrts2 = sqrt(S2) + Sqrs(Ind) = Sqrts2 + if (j <= nPol) then + QImp(Ind) = Zero + DipIm(:,Ind) = Zero + end if + if (j >= iQsta) then + qq = Qsta(j-nCent+nCha) + q = DiFac*Sqrts2*qq + Qim(Ind) = q + else + qq = Zero + Qim(Ind) = Zero + end if + xyzMyp(:) = xyzMyp-qq*Cordst(:,Ind) !Total dipole of the cavity; used in polink. + CordIm(:,Ind) = Cordst(:,Ind)*S2 + end do +end do + +!----------------------------------------------------------------------* +! Exit. * +!----------------------------------------------------------------------* +return + +end subroutine Geogen diff -Nru openmolcas-22.02/src/qmstat/georea.f openmolcas-22.10/src/qmstat/georea.f --- openmolcas-22.02/src/qmstat/georea.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/georea.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,54 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -*----------------------------------------------------------------------* -* -*----------------------------------------------------------------------* - Subroutine GeoRea(nskipp,quantum) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" - - Logical quantum - Dimension Dum(1) -*-----------------------------------------------------------------------* -* Enter. * -*-----------------------------------------------------------------------* -*-----------------------------------------------------------------------* -* Read! * -*-----------------------------------------------------------------------* - iDisk=0 - If(nSkipp.ne.0.and.iPrint.ge.4) then !If we are to skip - Write(6,*)' Reading from configuration ',nskipp,'.' !something. - Endif - Do 11, j=1,nSkipp+1 - If(j.ne.1.and.iRead.ne.9) then - Call dDaFile(9,2,Dum,1,iDisk) !Etot - Call dDaFile(9,2,Dum,1,iDisk) !Ract - Call dDaFile(9,2,Dum,1,iDisk) !GamOld - Call dDaFile(9,2,Dum,1,iDisk) !Gam - Call dDaFile(9,2,Dum,1,iDisk) !ESub - Endif - If(iRead.eq.9) then !If this is a sampfile we do not care about - !the induced dipoles, so we just read them to - !get rid of them. -c Do 12, i=1+nPol,IndMa -c -c12 Continue - Endif -11 Continue -*-----------------------------------------------------------------------* -* Exit. * -*-----------------------------------------------------------------------* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_logical(quantum) - End diff -Nru openmolcas-22.02/src/qmstat/get8.F90 openmolcas-22.10/src/qmstat/get8.F90 --- openmolcas-22.02/src/qmstat/get8.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/get8.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,53 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! GET NUMBERS FROM STARTFILE. +subroutine Get8(Ract,Etot) + +use qmstat_global, only: Cordst, iLuStIn, iPrint, iTcSim, nCent, nPart, StFilIn +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(out) :: Ract, Etot +integer(kind=iwp) :: i, iDisk +real(kind=wp) :: Esub, Gamold, GaOld +character(len=200) :: Head +real(kind=wp), allocatable :: CT(:) + +iDisk = 0 +call DaName(iLuStIn,StFilIn) +call WrRdSim(iLuStIn,2,iDisk,iTcSim,64,Etot,Ract,nPart,Gamold,GaOld,Esub) +iDisk = iTcSim(1) + +! In this loop we read the coordinates. The construction of Cordst +! makes this loop necessary. Maybe we should consider going to +! dynamic allocation. + +call mma_allocate(CT,nPart*nCent,label='CTemp') +do i=1,3 + call dDaFile(iLuStIn,2,CT,nPart*nCent,iDisk) + Cordst(i,:) = CT + iDisk = iTcSim(i+1) +end do +call mma_deallocate(CT) +call DaClos(iLuStIn) + +! If requested, print initial coordinates. + +if (iPrint >= 10) then + write(Head,*) 'Coordinates read from startfile.' + call Cooout(Head,Cordst,nPart,nCent) +end if + +return + +end subroutine Get8 diff -Nru openmolcas-22.02/src/qmstat/get9.F90 openmolcas-22.10/src/qmstat/get9.F90 --- openmolcas-22.02/src/qmstat/get9.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/get9.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,68 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +! GET NUMBERS FROM SAMPFILE. +subroutine Get9(Ract,Coord,info_atom,iQ_Atoms,iDiskSa) + +use qmstat_global, only: Cordst, delFi, delR, delX, iLuSaIn, iPrint, iTcSim, nCent, nMacro, nMicro, nPart +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(out) :: Ract +integer(kind=iwp), intent(in) :: iQ_Atoms, info_atom(iQ_Atoms) +real(kind=wp), intent(in) :: Coord(3,iQ_Atoms) +integer(kind=iwp), intent(inout) :: iDiskSa +integer(kind=iwp) :: i +real(kind=wp) :: Esub, Etot, Gamold, GaOld +character(len=200) :: Head +real(kind=wp), allocatable :: CT(:) + +call WrRdSim(iLuSaIn,2,iDiskSa,iTcSim,64,Etot,Ract,nPart,Gamold,GaOld,Esub) +iDiskSa = iTcSim(1) +call mma_allocate(CT,nPart*nCent,label='CTemp') +do i=1,3 + call dDaFile(iLuSaIn,2,CT,nPart*nCent,iDiskSa) + Cordst(i,:) = CT + iDiskSa = iTcSim(i+1) +end do +call mma_deallocate(CT) + +! We dummy-read the induced dipoles from the sampfile. + +!call mma_allocate(Dum,nPart*nPol,label='Dummy') +!do i=1,3 +! call dDaFile(iLuSaIn,2,Dum,nPol*nPart,iDiskSa) +!end do +!call mma_deallocate(Dum) + +! And now we place the QM-molecule in proper place and set some +! numbers to zero or one so we only collect configurations from +! the sampfile. + +call PlaceIt9(Coord,Cordst,info_atom,iQ_Atoms) +delX = Zero +delFi = Zero +delR = Zero +nMacro = 1 +nMicro = 1 + +! Some printing if requested. + +if (iPrint >= 15) then + write(Head,*) 'Coordinates after substitution in configuration read from sampfile.' + call Cooout(Head,Cordst,nPart,nCent) +end if + +return + +end subroutine Get9 diff -Nru openmolcas-22.02/src/qmstat/get_centers.f openmolcas-22.10/src/qmstat/get_centers.f --- openmolcas-22.02/src/qmstat/get_centers.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/get_centers.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,74 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -*----------------------------------------------------------------------* -* This subroutine reads from the formatted output of mpprop the * -* coordinates of the expansion centers. * -*----------------------------------------------------------------------* - Subroutine Get_Centers(nAt,xyz) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "files_qmstat.fh" -#include "warnings.h" - - Dimension xyz(MxAt,MxAt,3) - Character*13 TheLine - Logical Exist - -*Open the file - Lu=40 - Lu=IsFreeUnit(40) - Call Opnfl('MPPROP',Lu,Exist) - If(.not.Exist) then - Write(6,*) - Write(6,*)' Can not locate output file from MpProp. ' - Call Quit(_RC_IO_ERROR_READ_) - Endif - Rewind(Lu) - -*Read until you get standard line -10 Continue - Read(Lu,'(A)') TheLine - If(TheLine.ne.'* All centers') Go To 10 - Read(Lu,*) i - -*Read atom centers. - Do 15, i=1,nAt - Read(Lu,'(A)') TheLine - Read(Lu,*)(xyz(i,i,k),k=1,3) - Do 25, j=1,10 - Read(Lu,'(A)') TheLine -25 Continue -15 Continue - -*Read bond centers. - Do 30, i=2,nAt - Do 32, j=1,i-1 - Read(Lu,'(A)') TheLine - Read(Lu,*)(xyz(i,j,k),k=1,3) - Do 35, jj=1,10 - Read(Lu,'(A)') TheLine -35 Continue -32 Continue -30 Continue - -*Square xyz for later convinience - Do 40, i=2,nAt - Do 42, j=1,i-1 - xyz(j,i,1)=xyz(i,j,1) - xyz(j,i,2)=xyz(i,j,2) - xyz(j,i,3)=xyz(i,j,3) -42 Continue -40 Continue - - Close(Lu) - Return - End diff -Nru openmolcas-22.02/src/qmstat/get_centers.F90 openmolcas-22.10/src/qmstat/get_centers.F90 --- openmolcas-22.02/src/qmstat/get_centers.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/get_centers.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,77 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in . * +!*********************************************************************** + +!----------------------------------------------------------------------* +! This subroutine reads from the formatted output of mpprop the * +! coordinates of the expansion centers. * +!----------------------------------------------------------------------* +subroutine Get_Centers(nAt,xyz) + +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nAt +real(kind=wp), intent(out) :: xyz(3,nAt,nAt) +integer(kind=iwp) :: i, j, jj, Lu +logical(kind=iwp) :: Exists +character(len=13) :: TheLine +integer(kind=iwp), external :: IsFreeUnit +#include "warnings.h" + +! Open the file +Lu = IsFreeUnit(40) +call Opnfl('MPPROP',Lu,Exists) +if (.not. Exists) then + write(u6,*) + write(u6,*) ' Can not locate output file from MpProp. ' + call Quit(_RC_IO_ERROR_READ_) +end if +rewind(Lu) + +! Read until you get standard line +do + read(Lu,'(A)') TheLine + if (TheLine == '* All centers') exit +end do +read(Lu,*) i + +! Read atom centers. +do i=1,nAt + read(Lu,'(A)') TheLine + read(Lu,*) xyz(:,i,i) + do j=1,10 + read(Lu,'(A)') TheLine + end do +end do + +! Read bond centers. +do i=2,nAt + do j=1,i-1 + read(Lu,'(A)') TheLine + read(Lu,*) xyz(:,i,j) + do jj=1,10 + read(Lu,'(A)') TheLine + end do + end do +end do + +! Square xyz for later convenience +do i=2,nAt + do j=1,i-1 + xyz(:,j,i) = xyz(:,i,j) + end do +end do + +close(Lu) + +return + +end subroutine Get_Centers diff -Nru openmolcas-22.02/src/qmstat/get_input_q.f openmolcas-22.10/src/qmstat/get_input_q.f --- openmolcas-22.02/src/qmstat/get_input_q.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/get_input_q.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,936 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in . * -************************************************************************ -* -*-- Process input to QMSTAT. All input variables are stored in -* qminp.fh which in turn are initialized in qmstat_init. -* - Subroutine Get_Qmstat_Input(iQ_Atoms) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "files_qmstat.fh" -#include "warnings.h" - - Character*180 Key - Character*20 Kword - Character*180 Get_Ln - Character VecsQue*3 - Dimension CoTEMP1(3),CoTEMP2(3),CoTEMP3(3),CoTEMP4(3),CoTEMP5(3) - Dimension SlFacTemp(6) - External Get_Ln,iClast - Logical YesNo(20),Changed - -* -*-- Say what is done and set all YesNo to false; their purpose is to -* keep track on compulsory keywords and certain keyword combinations. -* -* Write(6,*) -* Write(6,*)'Input processed...' - Do 1, i=1,20 - YesNo(i)=.false. -1 Continue - -* -*-- Use some nice routines to collect input. -* - LuRd=79 - LuRd=IsFreeUnit(LuRd) - Call SpoolInp(LuRd) - Rewind(LuRd) - Call RdNlst(LuRd,'QMSTAT') - -* -*-- The turning-point in this do-while loop. -* -1000 Continue - -* -*-- Use Get_Ln to read the lines; it takes care of commented lines. -* - Key=Get_Ln(LuRd) - Kword=Trim(Key) - Call UpCase(Kword) - -* -*-- The keywords and their labels. -* - If(Kword(1:4).eq.'TITL') Go To 101 - If(Kword(1:4).eq.'SIMU') Go To 103 - If(Kword(1:4).eq.'THRE') Go To 104 - If(Kword(1:4).eq.'STEP') Go To 105 - If(Kword(1:4).eq.'RUN ') Go To 106 - If(Kword(1:4).eq.'PRIN') Go To 107 - If(Kword(1:4).eq.'EXTE') Go To 108 - If(Kword(1:4).eq.'EDIT') Go To 109 - If(Kword(1:4).eq.'CONF') Go To 110 - If(Kword(1:4).eq.'QMSU') Go To 111 - If(Kword(1:4).eq.'SOLV') Go To 112 - If(Kword(1:4).eq.'RASS') Go To 113 - If(Kword(1:4).eq.'SCFS') Go To 114 - If(Kword(1:4).eq.'SING') Go To 115 - If(Kword(1:4).eq.'ANAL') Go To 116 - If(Kword(1:4).eq.'EXTR') Go To 117 - If(Kword(1:4).eq.'END ') Go To 99999 - -* -*-- This code is only reached if an illegal keyword in the -* first tier is encountered. -* -** - iChrct=Len(Kword) - Last=iCLast(Kword,iChrct) - Write(6,*) - Write(6,*)'ERROR!' - Write(6,'(1X,A,A)')Kword(1:Last),' is not a valid keyword!' - Call Quit(_RC_INPUT_ERROR_) - -* -* <<>> Read title. -* -101 Continue - Key=Get_Ln(LuRd) - Joblab=Trim(Key) - ATitle=.true. - Go To 1000 - -* -* <<<SIMUlation parameters>>> Read a variety of simulation -* parameters. -* -103 Continue - Key=Get_Ln(LuRd) - Kword=Trim(Key) - Call UpCase(Kword) -*---<<<RADIe>>> - If(Kword(1:4).eq.'RADI') then - Key=Get_Ln(LuRd) - Call Get_F1(1,Rstart) - Go To 103 -*---<<<PERMitivity>>> - Elseif(Kword(1:4).eq.'PERM') then - Key=Get_Ln(LuRd) - Call Get_F1(1,Diel) - Go To 103 -*---<<<TEMPerature>>> - Elseif(Kword(1:4).eq.'TEMP') then - Key=Get_Ln(LuRd) - Call Get_F1(1,Temp) - Go To 103 -*---<<<PRESsure>>> - Elseif(Kword(1:4).eq.'PRES') then - Key=Get_Ln(LuRd) - Call Get_F1(1,Pres) - Go To 103 -*---<<<SURFace>>> - Elseif(Kword(1:4).eq.'SURF') then - Key=Get_Ln(LuRd) - Call Get_F1(1,Surf) - Go To 103 -*---<<<TRANslation>>> - Elseif(Kword(1:4).eq.'TRAN') then - Key=Get_Ln(LuRd) - Call Get_F1(1,DelX) - Go To 103 -*---<<<ROTAtion>>> - Elseif(Kword(1:4).eq.'ROTA') then - Key=Get_Ln(LuRd) - Call Get_F1(1,DelFi) - Go To 103 -*---<<<CAVIty>>> - Elseif(Kword(1:4).eq.'CAVI') then - Key=Get_Ln(LuRd) - Call Get_F1(1,DelR) - Go To 103 -*---<<<FORCe>>> - Elseif(Kword(1:4).eq.'FORC') then - Key=Get_Ln(LuRd) - Call Get_F1(1,Forcek) - Go To 103 -*---<<<BREPulsion>>> - Elseif(Kword(1:4).eq.'BREP') then - Key=Get_Ln(LuRd) - Call Get_F1(1,dLJRep) - Go To 103 -*---<<<SEED>>> - Elseif(Kword(1:4).eq.'SEED') then - Key=Get_Ln(LuRd) - Call Get_I1(1,iSeed) - Go To 103 -*---<<<PARAlleltemp>>> - Elseif(Kword(1:4).eq.'PARA') then - ParallelT=.true. - Key=Get_Ln(LuRd) - Call Get_I1(1,nTemp) - Key=Get_Ln(LuRd) - Call Get_I(1,nStFilT,nTemp) - Key=Get_Ln(LuRd) - Call Get_F(1,ParaTemps,nTemp) - Go To 103 -*---<<<END simulation parameters>>> - Elseif(Kword(1:4).eq.'END ') then - Go To 1000 - Endif -*---Here we come if something gets wrong above - Write(6,*) - Write(6,*)' Unrecognized keyword in the SIMUlation parameter sect' - &//'ion:',Kword(1:4) - Call Quit(_RC_INPUT_ERROR_) - -* -* <<<THREshold>>> Get the polarization thresholds. -* -104 Continue - Key=Get_Ln(LuRd) - Call Get_F1(1,Pollim) - Call Get_F1(2,Enelim) - Call Get_I1(3,itMax) - Go To 1000 - -* -* <<<STEPs>>> Specify how many macro- and microsteps. -* -105 Continue - Key=Get_Ln(LuRd) - Call Get_I1(1,NMacro) - Call Get_I1(2,NMicro) - Go To 1000 - -* -* <<<RUN >>> What type of simulation are we to run? -* -106 Continue - Key=Get_Ln(LuRd) - Kword=Trim(Key) - Call UpCase(Kword) - If(Kword(1:4).eq.'ANAL') Anal=.true. - If(Kword(1:4).eq.'QMEQ') Qmeq=.true. - If(Kword(1:4).eq.'QMPR') then - QmProd=.true. - Read(LuRd,*)Inter,iNrUt - Write(SaFilUt(6:6),'(i1.1)')iNrUt - iLuSaUt=32+iNrUt - Endif - If(Kword(1:2).eq.'SM') then - Write(6,*) - Write(6,*)'No classical simulations are available.' - Call Quit(_RC_INPUT_ERROR_) - Endif - YesNo(8)=.true. - Go To 1000 - -* -* <<<PRINt>>> Specify print-level. -* -107 Continue - Key=Get_Ln(LuRd) - Call Get_I1(1,iPrint) - Go To 1000 - -* -* <<<EXTErnal>>> External one-electron perturbation -* should be added on the hamiltonian. -* -108 Continue - AddExt=.true. - Key=Get_Ln(LuRd) - Call Get_I1(1,nExtAddOns) - If(nExtAddOns.gt.MxExtAddOn) then - Write(6,*) - Write(6,*)'Too many external perturbations asked for.' - Call Quit(_RC_INPUT_ERROR_) - Endif - Do 10801, i=1,nExtAddOns - Read(LuRd,*)ScalExt(i),ExtLabel(i),iCompExt(i) -10801 Continue - Go To 1000 - -* -* <<<EDITstartfile>>> Section for editing and displaying stuff on -* given startfile. -* -109 Continue - EdSt=.true. - Key=Get_Ln(LuRd) - Kword=Trim(Key) - Call UpCase(Kword) -*----<<<DELEte>>> Delete solvent molecules. - If(Kword(1:4).eq.'DELE') then - DelOrAdd(1)=.true. - Key=Get_Ln(LuRd) - Call Get_I1(1,NrStarti) - Call Get_I1(2,NrStartu) - Key=Get_Ln(LuRd) - Call Get_I1(1,nDel) - Go To 109 - Endif -*----<<<ADD >>> Add solvent molecules. - If(Kword(1:4).eq.'ADD ') then - DelOrAdd(2)=.true. - Key=Get_Ln(LuRd) - Call Get_I1(1,NrStarti) - Call Get_I1(2,NrStartu) - Key=Get_Ln(LuRd) - Call Get_I1(1,nAdd) - Go To 109 - Endif -*----<<<QMDElete>>> Substitute all slots with non-water coordinates -* with water coordinates. - If(Kword(1:4).eq.'QMDE') then - DelOrAdd(3)=.true. - Key=Get_Ln(LuRd) - Call Get_I1(1,NrStarti) - Call Get_I1(2,NrStartu) - Go To 109 - Endif -*----<<<DUMP coordinates>>> Dump coordinates in a way suitable for -* graphical display. - If(Kword(1:4).eq.'DUMP') then - DelOrAdd(4)=.true. - Key=Get_Ln(LuRd) - Call UpCase(Key) - cDumpForm=Key(1:4) - Key=Get_Ln(LuRd) - Call Get_I1(1,NrStarti) - Go To 109 - Endif -*----<<<END editstartfile>>> - If(Kword(1:4).eq.'END ') then - Write(StFilIn(6:6),'(i1.1)')NrStarti - Write(StFilUt(6:6),'(i1.1)')NrStartu - Go To 1000 - Endif -*---Here we come if something gets wrong above - Write(6,*) - Write(6,*)' Unrecognized keyword in the EDITstartfile sect' - &//'ion:',Kword(1:4) - Call Quit(_RC_INPUT_ERROR_) - -* -* <<<CONFiguration>>> Where is the initial configuration to be -* obtained. Also, if we wish to edit the -* startfile. -* -110 Continue - Key=Get_Ln(LuRd) - Kword=Trim(Key) - Call UpCase(Kword) -*---<<<ADD >>> How many to add at random. - If(Kword(1:4).eq.'ADD ') then - Key=Get_Ln(LuRd) - Call Get_I1(1,iExtra) - If(iExtra.gt.MxPut) then - Write(6,*) - Write(6,*)'The present limit of explicit solvent molecules i' - &//'s',MxPut,'.' - Call Quit(_RC_INPUT_ERROR_) - Endif - Go To 110 -*---<<<FILE>>> Read configuration/s from a file and put them there. - Elseif(Kword(1:4).eq.'FILE') then - Key=Get_Ln(LuRd) - Kword=Trim(Key) - Call UpCase(Kword) -*------<<<STARtfile>>> Read from startfile. - If(Kword(1:4).eq.'STAR') then - Key=Get_Ln(LuRd) - Kword=Trim(Key) - Call UpCase(Kword) -*---------<<<SCRAtch>>> Just put QM as given on RUNFILE. - If(Kword(1:4).eq.'SCRA') then - Key=Get_Ln(LuRd) - Call Get_I1(1,iNrIn) - Call Get_I1(2,iNrUt) - iRead=8 -*---------<<<COPY>>> Collect place of QM from startfile. WARNING! -* You must use consistent startfile and RUNFILE! - Elseif(Kword(1:4).eq.'COPY') then - Key=Get_Ln(LuRd) - Call Get_I1(1,iNrIn) - Call Get_I1(2,iNrUt) - iRead=7 -*---------<<<CM >>> Put QM in CM of QM-place on startfile. - Elseif(Kword(1:2).eq.'CM') then - Key=Get_Ln(LuRd) - Call Get_I1(1,iNrIn) - Call Get_I1(2,iNrUt) - iRead=6 - Else - Write(6,*) - Write(6,*)'Illegal StartFile option.' - Call Quit(_RC_INPUT_ERROR_) - Endif -*------<<<SAMPfile>>> Read configurations from sampfile and collect -* the extracted information in iNrExtr. - Elseif(Kword(1:4).eq.'SAMP') then - Key=Get_Ln(LuRd) - Call Get_I1(1,iNrIn) - Call Get_I1(2,iNrExtr) - iRead=9 - Write(SimEx(6:6),'(i1.1)')iNrExtr - YesNo(9)=.true. -*-----CRASH-BOOM-BANG! - Else - Write(6,*) - Write(6,*)' Error in CONFiguration section, FILE subsection.' - Call Quit(_RC_INPUT_ERROR_) - Endif - Write(StFilIn(6:6),'(i1.1)')iNrIn - Write(StFilUt(6:6),'(i1.1)')iNrUt - Write(SaFilIn(6:6),'(i1.1)')iNrIn - iLuStIn=8+iNrIn - iLuStUt=16+iNrUt - iLuSaIn=24+iNrIn - Go To 110 -*---<<<INPUt>>> Signify that the first configuration will be given -* explicitly in input. The coordinates are then given -* in the solvent section. - Elseif(Kword(1:4).eq.'INPU') then - Key=Get_Ln(LuRd) - Call Get_I1(1,iNrUt) - iLuStUt=16+iNrUt - YesNo(5)=.true. !User will give coord:s in input. - Go To 110 - Elseif(Kword(1:4).eq.'END ') then - YesNo(2)=.true. !Signify that source of starting conf. is - !specified. - Go To 1000 - Endif -*---Here we come if something gets wrong above - Write(6,*) - Write(6,*)' Unrecognized keyword in the CONFiguration section:' - &,Kword(1:4) - Call Quit(_RC_INPUT_ERROR_) - -* -* <<<QMSUrrounding>>> Give parameters for the QM-Stat.Mech. -* interaction. -* -111 Continue - Key=Get_Ln(LuRd) - Kword=Trim(Key) - Call UpCase(Kword) -*---<<<DPARameters>>> Dispersion - If(Kword(1:4).eq.'DPAR') then - Do 1111, i=1,iQ_Atoms - Key=Get_Ln(LuRd) - Call Get_F(1,Udisp(i,1),1) - Call Get_F(2,Udisp(i,2),1) -1111 Continue - Go To 111 -*---<<<ELECtrostatic>>> Electrostatic Slater Numbers - Elseif(Kword(1:4).eq.'ELEC') then -1131 Continue - Key=Get_Ln(LuRd) - Kword=Trim(Key) - Call UpCase(Kword) -*------<<<THREsholds>>> First is the Cutoff (distance Quantum Site- -* Classical molecule) to evaluate Penetration -* effects. Second, difference between two Slater -* exponents to not be consider the same value. - If(Kword(1:4).eq.'THRE') then - Key=Get_Ln(LuRd) - Call Get_F1(1,Cut_Elc) - Call Get_F1(2,DifSlExp) - Go To 1131 - Endif -*-----<<<NOPEnetration>>> Electrostatic Penetration Not Computed - If(Kword(1:4).eq.'NOPE') then - lSlater=.false. - Go To 1131 - Endif -*-----<<<QUADrupoles>>> Electrostatic Penetration Computed in quadrupoles. - If(Kword(1:4).eq.'QUAD') then - lQuad=.true. - Go To 1131 - Endif -*------<<<END Electrostatic>>> - If(Kword(1:4).eq.'END ') then - Go To 111 - Endif - Write(6,*) - Write(6,*)' Error in QMSUrrounding section, ELECtrostatic sub' - &//'section.' - Call Quit(_RC_INPUT_ERROR_) -*---<<<XPARameters>>> Exchange repulsion - Elseif(Kword(1:4).eq.'XPAR') then -1112 Continue - Key=Get_Ln(LuRd) - Kword=Trim(Key) - Call UpCase(Kword) -*------<<<S2 >>> The S2 parameter - If(Kword(1:4).eq.'S2 ') then - Key=Get_Ln(LuRd) - Call Get_F1(1,Exrep2) - Go To 1112 - Endif -*------<<<S4 >>> The S4 parameter - If(Kword(1:4).eq.'S4 ') then - Key=Get_Ln(LuRd) - Call Get_F1(1,Exrep4) - Go To 1112 - Endif -*------<<<S6 >>> The S6 parameter - If(Kword(1:4).eq.'S6 ') then - Key=Get_Ln(LuRd) - Call Get_F1(1,Exrep6) - Go To 1112 - Endif -*------<<<S10 >>> The S10 parameter - If(Kword(1:4).eq.'S10 ') then - Key=Get_Ln(LuRd) - Call Get_F1(1,Exrep10) - Go To 1112 - Endif -*------<<<CUTOff>>> The cut-off radii for repulsion. The first is -* outer radius that says EX=0 if R.gt.Cut_Ex1, while -* the second is a EX=infinity if R.lt.Cut_Ex2. - If(Kword(1:4).eq.'CUTO') then - Key=Get_Ln(LuRd) - Call Get_F1(1,Cut_Ex1) - Call Get_F1(2,Cut_Ex2) - Go To 1112 - Endif -*------<<<END xparameters>>> - If(Kword(1:4).eq.'END ') then - Go To 111 - Endif - Write(6,*) - Write(6,*)' Error in QMSUrrounding section, XPARameters subsec' - &//'tion.' - Call Quit(_RC_INPUT_ERROR_) -*---<<<DAMPing>>> Damping parameters for Qm-Surrounding interaction. - Elseif(Kword(1:4).eq.'DAMP') then -1119 Continue - Key=Get_Ln(LuRd) - Kword=Trim(Key) - Call UpCase(Kword) -*------<<<DISPersion>>> Dispersion damping parameters. This part -* should have a AUTO keyword which collects -* default parameters from the MpProp file. - If(Kword(1:4).eq.'DISP') then - Dispdamp=.true. - Key=Get_Ln(LuRd) -*-- Damping numbers for solvent - Call Get_F(1,CharDi(1),1) - Call Get_F(2,QuaDi(1,1),1) - Call Get_F(3,QuaDi(2,1),1) - Call Get_F(4,QuaDi(3,1),1) - Key=Get_Ln(LuRd) - Call Get_F(1,CharDi(2),1) - Call Get_F(2,QuaDi(1,2),1) - Call Get_F(3,QuaDi(2,2),1) - Call Get_F(4,QuaDi(3,2),1) -*-- Damping numbers for solute - Do 11711, i=1,iQ_Atoms - Key=Get_Ln(LuRd) - Call Get_F(1,CharDiQ(i),1) - Call Get_F(2,QuaDiQ(1,i),1) - Call Get_F(3,QuaDiQ(2,i),1) - Call Get_F(4,QuaDiQ(3,i),1) -11711 Continue - Go To 1119 -*------<<<FIELd>>> Parameters for damping electric field. - Elseif(Kword(1:4).eq.'FIEL') then - Fielddamp=.true. - Key=Get_Ln(LuRd) - Call Get_F1(1,CAFieldG) - Call Get_F1(2,CBFieldG) - Call Get_F1(3,CFExp) - Go To 1119 -*------<<<END damping>>> - Elseif(Kword(1:4).eq.'END ') then - Go To 111 - Endif - Write(6,*) - Write(6,*)' Error in QMSUrrounding section, DAMPing subsection.' - Call Quit(_RC_INPUT_ERROR_) -*---<<<END qmsurrounding>>> - Elseif(Kword(1:4).eq.'END ') then - Go To 1000 - Endif -*---And here we only go if unrecognized keyword is encountered. - Write(6,*) - Write(6,*)' Unrecognized keyword in the QMSUrrounding section:' - &,Kword(1:4) - Call Quit(_RC_INPUT_ERROR_) - -* -* <<<SOLVent>>> Specify stuff about the solvent. Usually, these -* parameters should not be altered. -* -112 Continue - Key=Get_Ln(LuRd) - Kword=Trim(Key) - Call UpCase(Kword) -*---<<<EXCHange>>> Exchange repulsion parameters to solvent-solvent. - If(Kword(1:4).eq.'EXCH') then - Do 1081, i=1,nAtom - Do 1082, j=1,i - Key=Get_Ln(LuRd) - Call Get_F(1,Sexrep(i,j),1) - Call Get_F(2,Sexre1(i,j),1) - Call Get_F(3,Sexre2(i,j),1) - Sexrep(j,i)=Sexrep(i,j) - Sexre1(j,i)=Sexre1(i,j) - Sexre2(j,i)=Sexre2(i,j) -1082 Continue -1081 Continue - Go To 112 - Endif -*---<<<DISPersion>>> Dispersion parameters to solvent-solvent. - If(Kword(1:4).eq.'DISP') then - Do 1091, i=1,nPol - Do 1092, j=1,i - Key=Get_Ln(LuRd) - Call Get_F(1,Disp(i,j),1) - Disp(j,i)=Disp(i,j) -1092 Continue -1091 Continue - Go To 112 - Endif -*---<<<COORdinates>>> Explicitly given coordinates of solvent -* molecules. Also need number of particles. - If(Kword(1:4).eq.'COOR') then - YesNo(6)=.true. !Signify that user gives coordinates. - Key=Get_Ln(LuRd) - Call Get_I1(1,nPart) - kaunt=0 - Do 1101, i=1,nPart - Do 1102, j=1,nAtom - kaunt=kaunt+1 - Key=Get_Ln(LuRd) - Call Get_F(1,Cordst(kaunt,1),1) - Call Get_F(2,Cordst(kaunt,2),1) - Call Get_F(3,Cordst(kaunt,3),1) -1102 Continue - Do 1103, kk=1,3 - CoTEMP1(kk)=Cordst(kaunt-2,kk) - CoTEMP2(kk)=Cordst(kaunt-1,kk) - CoTEMP3(kk)=Cordst(kaunt-0,kk) -1103 Continue - Call OffAtom(CoTEMP1,CoTEMP2,CoTEMP3,CoTEMP4,CoTEMP5) - kaunt=kaunt+1 - Do 1104, kk=1,3 - Cordst(kaunt,kk)=CoTEMP4(kk) -1104 Continue - kaunt=kaunt+1 - Do 1105, kk=1,3 - Cordst(kaunt,kk)=CoTEMP5(kk) -1105 Continue -1101 Continue - Go To 112 - Endif -*---<<<CAVRepulsion>>> Repulsion parameters between solvent and -* cavity boundary. - If(Kword(1:4).eq.'CAVR') then - Key=Get_Ln(LuRd) - Call Get_F1(1,Exdtal) - Call Get_F1(2,Exdt1) - Go To 112 - Endif -*---<<<OCORbitals>>> Occupied Orbitals for the solvent molecule - If(Kword(1:4).eq.'OCOR') then - Key=Get_Ln(LuRd) - Call Get_I(1,iOrb(2),1) - Go To 112 - Endif -*---<<<ATCEchpol>>> Number of atoms, centers, charges and -* polarizabilities. -* Jose Slater Sites - If(Kword(1:4).eq.'ATCE') then - Key=Get_Ln(LuRd) - Call Get_I1(1,nAtom) - Call Get_I1(2,nCent) - Call Get_I1(3,nCha) - Call Get_I1(4,nPol) - Call Get_I1(5,nSlSiteC) - Go To 112 - Endif -*---<<<CHARge>>> Magnitude of the charges. - If(Kword(1:4).eq.'CHAR') then - Key=Get_Ln(LuRd) - Call Get_F(1,Qsta,nCha) - Go To 112 - Endif -*---<<<POLArizability>>> Magnitude of polarizabilities. - If(Kword(1:4).eq.'POLA') then - Key=Get_Ln(LuRd) - Call Get_F(1,Pol,nPol) - Go To 112 - Endif -*Jose+++++++++++++ -*---<<<SLATer>>> Magnitude of Slater PreFactors and Exponents. - If(Kword(1:4).eq.'SLAT') then - Key=Get_Ln(LuRd) - Call Get_I1(1,lMltSlC) - If(lMltSlC.gt.1) then - Write(6,*) - Write(6,*)'Too high order of multipole in classical system' - Write(6,*)' Higher order is 1' - Call Quit(_RC_INPUT_ERROR_) - Endif - Do 2221, i=1,nSlSiteC - Do 2223, j=0,lMltSlC - nS=j*(j+1)*(j+2)/6 - nT=(j+1)*(j+2)*(j+3)/6 - Key=Get_Ln(LuRd) - Call Get_F1(1,SlExpTemp) - SlExpC(j+1,i)=SlExpTemp - njhr=nT-nS - Key=Get_Ln(LuRd) - Call Get_F(1,SlFacTemp,njhr) - njhr=1 - Do 2224, k=nS+1,nT - SlFactC(k,i)=SlFacTemp(njhr) - njhr=njhr+1 -2224 Continue -2223 Continue - Key=Get_Ln(LuRd) - Call Get_F(1,SlPC(i),1) -2221 Continue - Go To 112 - Endif - -*---<<<END solvent>>> - If(Kword(1:4).eq.'END ') then - Go To 1000 - Endif -*---And the bla bla bla if something gets wrong. - Write(6,*) - Write(6,*)' Unrecognized keyword in the SOLVent section:' - &,Kword(1:4) - Call Quit(_RC_INPUT_ERROR_) - -* -* <<<RASSisection>>> Give some numbers specific for the handling -* of the RASSI-construction of the wave-func. -* -113 Continue - QmType='RASSI' - Key=Get_Ln(LuRd) - Kword=Trim(Key) - Call UpCase(Kword) -*---<<<JOBFiles>>> How many jobfiles and how many states in them. - If(Kword(1:4).eq.'JOBF') then - Key=Get_Ln(LuRd) - Call Get_I1(1,NrFiles) - Key=Get_Ln(LuRd) - Call Get_I(1,NrStates,NrFiles) - Go To 113 - Endif -*---<<<EQSTate>>> Which state is to be equilibrated. - If(Kword(1:4).eq.'EQST') then - Key=Get_Ln(LuRd) - Call Get_I1(1,nEqState) - Go To 113 - Endif -*---<<<MOREduce>>> Work in reduced MO-basis. - If(Kword(1:4).eq.'MORE') then - Key=Get_Ln(LuRd) - Call Get_F1(1,ThrsRedOcc) - MoAveRed=.true. - Go To 113 - Endif -*---<<<CONTract>>> Contract the RASSI state basis. - If(Kword(1:4).eq.'CONT') then - Key=Get_Ln(LuRd) - Call Get_F1(1,ThrsCont) - ContrStateB=.true. - Go To 113 - Endif -*---<<<LEVElshift>>> Introduce levelshift of RASSI states. - If(Kword(1:4).eq.'LEVE') then - Key=Get_Ln(LuRd) - Call Get_I1(1,nLvlShift) - Key=Get_Ln(LuRd) - Call Get_I(1,iLvlShift,nLvlShift) - Key=Get_Ln(LuRd) - Call Get_F(1,dLvlShift,nLvlShift) -*----- Just a little sorting. -7485 Continue - Changed=.false. - Do 7484, i=1,nLvlShift-1 - If(iLvlShift(i).gt.iLvlShift(i+1)) then - iTemp=iLvlShift(i) - iLvlShift(i)=iLvlShift(i+1) - iLvlShift(i+1)=iTemp - dTemp=dLvlShift(i) - dLvlShift(i)=dLvlShift(i+1) - dLvlShift(i+1)=dTemp - Changed=.true. - Endif -7484 Continue - If(Changed) GoTo 7485 - Go To 113 - Endif -*---<<<CISElect>>> Use overlap criterion in choosing state. - If(Kword(1:4).eq.'CISE') then - lCiSelect=.true. - Key=Get_Ln(LuRd) - Call Get_I1(1,nCIRef) - Key=Get_Ln(LuRd) - Call Get_I(1,iCIInd,nCIRef) - Key=Get_Ln(LuRd) - Call Get_F(1,dCIRef,nCIRef) - GoTo 113 - Endif -*---<<<END rassisection>>> - If(Kword(1:4).eq.'END ') then - YesNo(3)=.true. !Rassi section has been visited. - Go To 1000 - Endif -*---HOW COULD IT GET WRONG HERE? - Write(6,*) - Write(6,*)' Unrecognized keyword in the RASSisection section:' - &,Kword(1:4) - Call Quit(_RC_INPUT_ERROR_) - -* -* <<<SCFSection>>> Numbers for a SCF-QmStat run. -* -114 Continue - QmType='SCF' - Key=Get_Ln(LuRd) - Kword=Trim(Key) - Call UpCase(Kword) -*---<<<ORBItals>>> Specifiy the reduced orbital space in which the -* problem is solved. - If(Kword(1:4).eq.'ORBI') then - Key=Get_Ln(LuRd) - Call Get_I(1,iOrb(1),1) - Call Get_I1(2,iOcc1) - If(iOrb(1).gt.MxOrb) then - Write(6,*) - Write(6,*)'The parameter MxOrb is set too low, or your ' - &//'total number of orbitals too high.' - Call Quit(_RC_INPUT_ERROR_) - Endif - Go To 114 - Endif -*---<<<MP2Denscorr>>> - If(Kword(1:4).eq.'MP2D') then - Mp2DensCorr=.true. - Go To 114 - Endif -*---<<<END scfsection>>> - If(Kword(1:4).eq.'END ') then - YesNo(4)=.true. !Scf section has been visited. - Go To 1000 - Endif -*---ETWAS FALSCH! - Write(6,*) - Write(6,*)' Unrecognized keyword in the SCFSection:',Kword(1:4) - Call Quit(_RC_INPUT_ERROR_) - -* -* <<<SINGle-point>>> Signify that a set of single point calculations -* are to be done. -* -115 Continue - SingPoint=.true. - YesNo(7)=.true. - Go To 1000 - -* -* <<<ANALyze section>>> Give details what analysis of the sampfile -* coordinates that is to be done. -* -116 Continue - Go To 1000 - -* -* <<<EXTRact section>>> Give details what QM and QM/MM analysis -* that is to be done from the sampfile -* coordinates. -* -117 Continue - Key=Get_Ln(LuRd) - Kword=Trim(Key) - Call UpCase(Kword) -*---<<<TOTAl energy>>> - If(Kword(1:4).eq.'TOTA') then - lExtr(1)=.true. - Go To 117 - Endif -*---<<<DIPOle>>> - If(Kword(1:4).eq.'DIPO') then - lExtr(2)=.true. - Go To 117 - Endif -*---<<<QUADrupole>>> - If(Kword(1:4).eq.'QUAD') then - lExtr(3)=.true. - Go To 117 - Endif -*---<<<EIGEn things>>> - If(Kword(1:4).eq.'EIGE') then - lExtr(4)=.true. - Key=Get_Ln(LuRd) - Call Get_I1(1,iExtr_Eig) - Call Get_S(2,VecsQue,1) - Call UpCase(VecsQue) - If(VecsQue(1:3).eq.'YES') lExtr(5)=.true. - Go To 117 - Endif -*---<<<EXPEctation values>>> - If(Kword(1:4).eq.'EXPE') then - lExtr(6)=.true. - Go To 117 - Endif -*---<<<ELOCal>>> - If(Kword(1:4).eq.'ELOC') then - lExtr(7)=.true. - Key=Get_Ln(LuRd) - Call Get_I1(1,NExtr_Atm) - Key=Get_Ln(LuRd) - Call Get_I(1,iExtr_Atm,NExtr_Atm) - Go To 117 - Endif -******JoseMEP**************** -*---<<<MESP>>> -* The Main Electrostatic potential, field and field gradients will -* be obtained in order to produce perturbation integrals that will -* be used to optimize the intramolecular geometry of the QM system. -* - If(Kword(1:4).eq.'MESP') then - lExtr(8)=.true. - Go To 117 - Endif -****************************** -*---<<<END extract section>>> - If(Kword(1:4).eq.'END ') then - YesNo(10)=.true. - GoTo 1000 - Endif -*---ETWAS FALSCH! - Write(6,*) - Write(6,*)' Unrecognized keyword in the EXTRact section:' - & ,Kword(1:4) - Call Quit(_RC_INPUT_ERROR_) - -* -*-- Exit -* -99999 Continue - -* -*-- Check if mandatory input was included and that no blatant -* inconcistencies exist. Not fool-proof, fools! -* - Call MandatoryInp(YesNo) - -* -*-- Good bye. -* - - Return - End diff -Nru openmolcas-22.02/src/qmstat/get_qmstat_input.F90 openmolcas-22.10/src/qmstat/get_qmstat_input.F90 --- openmolcas-22.02/src/qmstat/get_qmstat_input.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/get_qmstat_input.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,868 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! Process input to QMSTAT. All input variables are stored in +! qmstat_global which in turn are initialized in qmstat_init. +subroutine Get_Qmstat_Input(iQ_Atoms) + +use qmstat_global, only: AddExt, Anal, ATitle, CAFieldG, CBFieldG, cDumpForm, CFExp, CharDi, CharDiQ, ContrStateB, Cordst, & + Cut_Elc, Cut_Ex1, Cut_Ex2, dCIRef, DelFi, DelOrAdd, DelR, DelX, Diel, DifSlExp, Disp, DispDamp, dLJRep, & + dLvlShift, EdSt, Enelim, ExtLabel, Exdt1, Exdtal, Exrep10, Exrep2, Exrep4, Exrep6, FieldDamp, Forcek, & + iCIInd, iCompExt, iExtr_Atm, iExtr_Eig, iExtra, iLuSaIn, iLuSaUt, iLuStIn, iLuStUt, iLvlShift, iNrIn, & + iNrUt, Inter, iOcc1, iOrb, iPrint, iRead, iSeed, itMax, Joblab, lCiSelect, lExtr, lMltSlC, lQuad, & + lSlater, MoAveRed, Mp2DensCorr, MxPut, nAdd, nAtom, nCent, nCha, nCIRef, nDel, nEqState, nExtAddOns, & + nLvlShift, nMacro, nMicro, nPart, nPol, NrFiles, NrStarti, NrStartu, NrStates, nSlSiteC, nStFilT, nTemp, & + ParallelT, ParaTemps, Pol, Pollim, Pres, Qmeq, QmProd, QmType, Qsta, QuaDi, QuaDiQ, rStart, SaFilIn, & + SaFilUt, ScalExt, Sexre1, Sexre2, Sexrep, SimEx, SingPoint, SlExpC, SlFactC, SlPC, StFilIn, StFilUt, & + Surf, Temp, ThrsCont, ThrsRedOcc, Udisp +use Index_Functions, only: nTri3_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iQ_Atoms +#include "warnings.h" +integer(kind=iwp) :: i, iChrct, iNrExtr, iTemp, j, kaunt, Last, LuRd, NExtr_Atm, njhr, nS, nT +real(kind=wp) :: CoTEMP1(3), CoTEMP2(3), CoTEMP3(3), CoTEMP4(3), CoTEMP5(3), dTemp, SlExpTemp, SlFacTemp(6) +logical(kind=iwp) :: Changed, YesNo(20) +character(len=180) :: Key +character(len=20) :: Kword +character(len=3) :: VecsQue +integer(kind=iwp), external :: iClast, IsFreeUnit +character(len=180), external :: Get_Ln +real(kind=wp), allocatable :: Tmp(:), Tmp2(:,:) + +! Say what is done and set all YesNo to false; their purpose is to +! keep track on compulsory keywords and certain keyword combinations. + +!write(u6,*) +!write(u6,*)'Input processed...' +YesNo(:) = .false. + +! Use some nice routines to collect input. + +LuRd = IsFreeUnit(79) +call SpoolInp(LuRd) +rewind(LuRd) +call RdNlst(LuRd,'QMSTAT') + +! The turning-point in this do-while loop. + +do + + ! Use Get_Ln to read the lines; it takes care of commented lines. + + Key = Get_Ln(LuRd) + Kword = trim(Key) + call UpCase(Kword) + + ! The keywords and their labels. + + select case (Kword(1:4)) + case default + ! This code is only reached if an illegal keyword in the + ! first tier is encountered. + + iChrct = len(Kword) + Last = iCLast(Kword,iChrct) + write(u6,*) + write(u6,*) 'ERROR!' + write(u6,'(1X,A,A)') Kword(1:Last),' is not a valid keyword!' + call Quit(_RC_INPUT_ERROR_) + + case ('TITL') + ! <<<TITLe>>> Read title. + + Key = Get_Ln(LuRd) + Joblab = trim(Key) + ATitle = .true. + + case ('SIMU') + ! <<<SIMUlation parameters>>> Read a variety of simulation parameters. + + do + Key = Get_Ln(LuRd) + Kword = trim(Key) + call UpCase(Kword) + select case (KWord(1:4)) + case default + ! Here we come if something gets wrong + write(u6,*) + write(u6,*) ' Unrecognized keyword in the SIMUlation parameter section:',Kword(1:4) + call Quit(_RC_INPUT_ERROR_) + case ('RADI') + ! <<<RADIe>>> + Key = Get_Ln(LuRd) + call Get_F1(1,rStart) + case ('PERM') + ! <<<PERMitivity>>> + Key = Get_Ln(LuRd) + call Get_F1(1,Diel) + case ('TEMP') + ! <<<TEMPerature>>> + Key = Get_Ln(LuRd) + call Get_F1(1,Temp) + case ('PRES') + ! <<<PRESsure>>> + Key = Get_Ln(LuRd) + call Get_F1(1,Pres) + case ('SURF') + ! <<<SURFace>>> + Key = Get_Ln(LuRd) + call Get_F1(1,Surf) + case ('TRAN') + ! <<<TRANslation>>> + Key = Get_Ln(LuRd) + call Get_F1(1,DelX) + case ('ROTA') + ! <<<ROTAtion>>> + Key = Get_Ln(LuRd) + call Get_F1(1,DelFi) + case ('CAVI') + ! <<<CAVIty>>> + Key = Get_Ln(LuRd) + call Get_F1(1,DelR) + case ('FORC') + ! <<<FORCe>>> + Key = Get_Ln(LuRd) + call Get_F1(1,Forcek) + case ('BREP') + ! <<<BREPulsion>>> + Key = Get_Ln(LuRd) + call Get_F1(1,dLJRep) + case ('SEED') + ! <<<SEED>>> + Key = Get_Ln(LuRd) + call Get_I1(1,iSeed) + case ('PARA') + ! <<<PARAlleltemp>>> + ParallelT = .true. + Key = Get_Ln(LuRd) + call Get_I1(1,nTemp) + call mma_allocate(nStFilT,nTemp,label='nStFilT') + call mma_allocate(Paratemps,nTemp,label='Paratemps') + Key = Get_Ln(LuRd) + call Get_I(1,nStFilT,nTemp) + Key = Get_Ln(LuRd) + call Get_F(1,ParaTemps,nTemp) + case ('END ') + ! <<<END simulation parameters>>> + exit + end select + end do + + case ('THRE') + ! <<<THREshold>>> Get the polarization thresholds. + + Key = Get_Ln(LuRd) + call Get_F1(1,Pollim) + call Get_F1(2,Enelim) + call Get_I1(3,itMax) + + case ('STEP') + ! <<<STEPs>>> Specify how many macro- and microsteps. + + Key = Get_Ln(LuRd) + call Get_I1(1,nMacro) + call Get_I1(2,nMicro) + + case ('RUN ') + ! <<<RUN >>> What type of simulation are we to run? + + Key = Get_Ln(LuRd) + Kword = trim(Key) + call UpCase(Kword) + select case (Kword(1:4)) + case ('ANAL') + Anal = .true. + case ('QMEQ') + Qmeq = .true. + case ('QMPR') + QmProd = .true. + read(LuRd,*) Inter,iNrUt + write(SaFilUt(6:6),'(i1.1)') iNrUt + iLuSaUt = 32+iNrUt + case default + if (Kword(1:2) == 'SM') then + write(u6,*) + write(u6,*) 'No classical simulations are available.' + call Quit(_RC_INPUT_ERROR_) + end if + end select + YesNo(8) = .true. + + case ('PRIN') + ! <<<PRINt>>> Specify print-level. + + Key = Get_Ln(LuRd) + call Get_I1(1,iPrint) + + case ('EXTE') + ! <<<EXTErnal>>> External one-electron perturbation + ! should be added on the hamiltonian. + + AddExt = .true. + Key = Get_Ln(LuRd) + call Get_I1(1,nExtAddOns) + call mma_allocate(ScalExt,nExtAddOns,label='ScalExt') + call mma_allocate(ExtLabel,nExtAddOns,label='ExtLabel') + call mma_allocate(iCompExt,nExtAddOns,label='iCompExt') + do i=1,nExtAddOns + read(LuRd,*) ScalExt(i),ExtLabel(i),iCompExt(i) + end do + + case ('EDIT') + ! <<<EDITstartfile>>> Section for editing and displaying stuff on given startfile. + + do + EdSt = .true. + Key = Get_Ln(LuRd) + Kword = trim(Key) + call UpCase(Kword) + select case (Kword(1:4)) + case default + ! Here we come if something gets wrong + write(u6,*) + write(u6,*) ' Unrecognized keyword in the EDITstartfile section:',Kword(1:4) + call Quit(_RC_INPUT_ERROR_) + case ('DELE') + ! <<<DELEte>>> Delete solvent molecules. + DelOrAdd(1) = .true. + Key = Get_Ln(LuRd) + call Get_I1(1,NrStarti) + call Get_I1(2,NrStartu) + Key = Get_Ln(LuRd) + call Get_I1(1,nDel) + case ('ADD ') + ! <<<ADD >>> Add solvent molecules. + DelOrAdd(2) = .true. + Key = Get_Ln(LuRd) + call Get_I1(1,NrStarti) + call Get_I1(2,NrStartu) + Key = Get_Ln(LuRd) + call Get_I1(1,nAdd) + case ('QMDE') + ! <<<QMDElete>>> Substitute all slots with non-water coordinates with water coordinates. + DelOrAdd(3) = .true. + Key = Get_Ln(LuRd) + call Get_I1(1,NrStarti) + call Get_I1(2,NrStartu) + case ('DUMP') + ! <<<DUMP coordinates>>> Dump coordinates in a way suitable for graphical display. + DelOrAdd(4) = .true. + Key = Get_Ln(LuRd) + call UpCase(Key) + cDumpForm = Key(1:4) + Key = Get_Ln(LuRd) + call Get_I1(1,NrStarti) + case ('END ') + ! <<<END editstartfile>>> + write(StFilIn(6:6),'(i1.1)') NrStarti + write(StFilUt(6:6),'(i1.1)') NrStartu + exit + end select + end do + + case ('CONF') + ! <<<CONFiguration>>> Where is the initial configuration to be + ! obtained. Also, if we wish to edit the startfile. + + do + Key = Get_Ln(LuRd) + Kword = trim(Key) + call UpCase(Kword) + select case (Kword(1:4)) + case default + ! Here we come if something gets wrong + write(u6,*) + write(u6,*) ' Unrecognized keyword in the CONFiguration section:',Kword(1:4) + call Quit(_RC_INPUT_ERROR_) + case ('ADD ') + ! <<<ADD >>> How many to add at random. + Key = Get_Ln(LuRd) + call Get_I1(1,iExtra) + if (iExtra > MxPut) then + write(u6,*) + write(u6,*) 'The present limit of explicit solvent molecules is',MxPut,'.' + call Quit(_RC_INPUT_ERROR_) + end if + case ('FILE') + ! <<<FILE>>> Read configuration/s from a file and put them there. + Key = Get_Ln(LuRd) + Kword = trim(Key) + call UpCase(Kword) + select case (Kword(1:4)) + case default + ! CRASH-BOOM-BANG! + write(u6,*) + write(u6,*) ' Error in CONFiguration section, FILE subsection.' + call Quit(_RC_INPUT_ERROR_) + case ('STAR') + ! <<<STARtfile>>> Read from startfile. + Key = Get_Ln(LuRd) + Kword = trim(Key) + call UpCase(Kword) + select case (KWord(1:4)) + case default + write(u6,*) + write(u6,*) 'Illegal StartFile option.' + call Quit(_RC_INPUT_ERROR_) + case ('SCRA') + ! <<<SCRAtch>>> Just put QM as given on RUNFILE. + Key = Get_Ln(LuRd) + call Get_I1(1,iNrIn) + call Get_I1(2,iNrUt) + iRead = 8 + case ('COPY') + ! <<<COPY>>> Collect place of QM from startfile. WARNING! + ! You must use consistent startfile and RUNFILE! + Key = Get_Ln(LuRd) + call Get_I1(1,iNrIn) + call Get_I1(2,iNrUt) + iRead = 7 + case ('CM ') + ! <<<CM >>> Put QM in CM of QM-place on startfile. + Key = Get_Ln(LuRd) + call Get_I1(1,iNrIn) + call Get_I1(2,iNrUt) + iRead = 6 + end select + case ('SAMP') + ! <<<SAMPfile>>> Read configurations from sampfile and collect + ! the extracted information in iNrExtr. + Key = Get_Ln(LuRd) + call Get_I1(1,iNrIn) + call Get_I1(2,iNrExtr) + iRead = 9 + write(SimEx(6:6),'(i1.1)') iNrExtr + YesNo(9) = .true. + end select + write(StFilIn(6:6),'(i1.1)') iNrIn + write(StFilUt(6:6),'(i1.1)') iNrUt + write(SaFilIn(6:6),'(i1.1)') iNrIn + iLuStIn = 8+iNrIn + iLuStUt = 16+iNrUt + iLuSaIn = 24+iNrIn + case ('INPU') + ! <<<INPUt>>> Signify that the first configuration will be given + ! explicitly in input. The coordinates are then given + ! in the solvent section. + Key = Get_Ln(LuRd) + call Get_I1(1,iNrUt) + iLuStUt = 16+iNrUt + YesNo(5) = .true. !User will give coords in input. + case ('END ') + YesNo(2) = .true. !Signify that source of starting conf. is specified. + exit + end select + end do + + case ('QMSU') + ! <<<QMSUrrounding>>> Give parameters for the QM-Stat.Mech. interaction. + + do + Key = Get_Ln(LuRd) + Kword = trim(Key) + call UpCase(Kword) + select case (Kword(1:4)) + case default + ! Here we only go if unrecognized keyword is encountered. + write(u6,*) + write(u6,*) ' Unrecognized keyword in the QMSUrrounding section:',Kword(1:4) + call Quit(_RC_INPUT_ERROR_) + case ('DPAR') + ! <<<DPARameters>>> Dispersion + do i=1,iQ_Atoms + Key = Get_Ln(LuRd) + call Get_F(1,Udisp(1,i),1) + call Get_F(2,Udisp(2,i),1) + end do + case ('ELEC') + ! <<<ELECtrostatic>>> Electrostatic Slater Numbers + do + Key = Get_Ln(LuRd) + Kword = trim(Key) + call UpCase(Kword) + select case (Kword(1:4)) + case default + write(u6,*) + write(u6,*) ' Error in QMSUrrounding section, ELECtrostatic subsection.' + call Quit(_RC_INPUT_ERROR_) + case ('THRE') + ! <<<THREsholds>>> First is the Cutoff (distance Quantum Site- + ! Classical molecule) to evaluate Penetration + ! effects. Second, difference between two Slater + ! exponents to not be consider the same value. + Key = Get_Ln(LuRd) + call Get_F1(1,Cut_Elc) + call Get_F1(2,DifSlExp) + case ('NOPE') + ! <<<NOPEnetration>>> Electrostatic Penetration Not Computed + lSlater = .false. + case ('QUAD') + ! <<QUADrupoles>>> Electrostatic Penetration Computed in quadrupoles. + lQuad = .true. + case ('END ') + ! <<<END Electrostatic>>> + exit + end select + end do + case ('XPAR') + ! <<<XPARameters>>> Exchange repulsion + do + Key = Get_Ln(LuRd) + Kword = trim(Key) + call UpCase(Kword) + select case (Kword(1:4)) + case default + write(u6,*) + write(u6,*) ' Error in QMSUrrounding section, XPARameters subsection.' + call Quit(_RC_INPUT_ERROR_) + case ('S2 ') + ! <<<S2 >>> The S2 parameter + Key = Get_Ln(LuRd) + call Get_F1(1,Exrep2) + case ('S4 ') + ! <<<S4 >>> The S4 parameter + Key = Get_Ln(LuRd) + call Get_F1(1,Exrep4) + case ('S6 ') + ! <<<S6 >>> The S6 parameter + Key = Get_Ln(LuRd) + call Get_F1(1,Exrep6) + case ('S10 ') + ! <<<S10 >>> The S10 parameter + Key = Get_Ln(LuRd) + call Get_F1(1,Exrep10) + case ('CUTO') + ! <<<CUTOff>>> The cut-off radii for repulsion. The first is + ! outer radius that says EX=0 if R > Cut_Ex1, while + ! the second is a EX=infinity if R < Cut_Ex2. + Key = Get_Ln(LuRd) + call Get_F1(1,Cut_Ex1) + call Get_F1(2,Cut_Ex2) + case ('END ') + ! <<<END xparameters>>> + exit + end select + end do + case ('DAMP') + ! <<<DAMPing>>> Damping parameters for Qm-Surrounding interaction. + do + Key = Get_Ln(LuRd) + Kword = trim(Key) + call UpCase(Kword) + select case (Kword(1:4)) + case default + write(u6,*) + write(u6,*) ' Error in QMSUrrounding section, DAMPing subsection.' + call Quit(_RC_INPUT_ERROR_) + case ('DISP') + ! <<<DISPersion>>> Dispersion damping parameters. This part + ! should have a AUTO keyword which collects + ! default parameters from the MpProp file. + DispDamp = .true. + Key = Get_Ln(LuRd) + ! Damping numbers for solvent + call Get_F(1,CharDi(1),1) + call Get_F(2,QuaDi(1,1),1) + call Get_F(3,QuaDi(2,1),1) + call Get_F(4,QuaDi(3,1),1) + Key = Get_Ln(LuRd) + call Get_F(1,CharDi(2),1) + call Get_F(2,QuaDi(1,2),1) + call Get_F(3,QuaDi(2,2),1) + call Get_F(4,QuaDi(3,2),1) + ! Damping numbers for solute + call mma_allocate(CharDiQ,iQ_Atoms,label='CharDiQ') + call mma_allocate(QuaDiQ,3,iQ_Atoms,label='QuaDiQ') + do i=1,iQ_Atoms + Key = Get_Ln(LuRd) + call Get_F(1,CharDiQ(i),1) + call Get_F(2,QuaDiQ(1,i),1) + call Get_F(3,QuaDiQ(2,i),1) + call Get_F(4,QuaDiQ(3,i),1) + end do + case ('FIEL') + ! <<<FIELd>>> Parameters for damping electric field. + FieldDamp = .true. + Key = Get_Ln(LuRd) + call Get_F1(1,CAFieldG) + call Get_F1(2,CBFieldG) + call Get_F1(3,CFExp) + case ('END ') + ! <<<END damping>>> + exit + end select + end do + case ('END ') + ! <<<END qmsurrounding>>> + exit + end select + end do + + case ('SOLV') + ! <<<SOLVent>>> Specify stuff about the solvent. Usually, these + ! parameters should not be altered. + + do + Key = Get_Ln(LuRd) + Kword = trim(Key) + call UpCase(Kword) + select case (KWord(1:4)) + case default + ! The bla bla bla if something gets wrong. + write(u6,*) + write(u6,*) ' Unrecognized keyword in the SOLVent section:',Kword(1:4) + call Quit(_RC_INPUT_ERROR_) + case ('EXCH') + ! <<<EXCHange>>> Exchange repulsion parameters to solvent-solvent. + do i=1,nAtom + do j=1,i + Key = Get_Ln(LuRd) + call Get_F(1,Sexrep(i,j),1) + call Get_F(2,Sexre1(i,j),1) + call Get_F(3,Sexre2(i,j),1) + Sexrep(j,i) = Sexrep(i,j) + Sexre1(j,i) = Sexre1(i,j) + Sexre2(j,i) = Sexre2(i,j) + end do + end do + case ('DISP') + ! <<<DISPersion>>> Dispersion parameters to solvent-solvent. + do i=1,nPol + do j=1,i + Key = Get_Ln(LuRd) + call Get_F(1,Disp(i,j),1) + Disp(j,i) = Disp(i,j) + end do + end do + case ('COOR') + ! <<<COORdinates>>> Explicitly given coordinates of solvent + ! molecules. Also need number of particles. + YesNo(6) = .true. !Signify that user gives coordinates. + Key = Get_Ln(LuRd) + call Get_I1(1,nPart) + kaunt = 0 + do i=1,nPart + do j=1,nAtom + kaunt = kaunt+1 + Key = Get_Ln(LuRd) + call Get_F(1,Cordst(1,kaunt),1) + call Get_F(2,Cordst(2,kaunt),1) + call Get_F(3,Cordst(3,kaunt),1) + end do + CoTEMP1(:) = Cordst(:,kaunt-2) + CoTEMP2(:) = Cordst(:,kaunt-1) + CoTEMP3(:) = Cordst(:,kaunt-0) + call OffAtom(CoTEMP1,CoTEMP2,CoTEMP3,CoTEMP4,CoTEMP5) + kaunt = kaunt+1 + Cordst(:,kaunt) = CoTEMP4(:) + kaunt = kaunt+1 + Cordst(:,kaunt) = CoTEMP5(:) + end do + case ('CAVR') + ! <<<CAVRepulsion>>> Repulsion parameters between solvent and cavity boundary. + Key = Get_Ln(LuRd) + call Get_F1(1,Exdtal) + call Get_F1(2,Exdt1) + case ('OCOR') + ! <<<OCORbitals>>> Occupied Orbitals for the solvent molecule + Key = Get_Ln(LuRd) + call Get_I(1,iOrb(2),1) + case ('ATCE') + ! <<<ATCEchpol>>> Number of atoms, centers, charges and polarizabilities. + ! Jose Slater Sites + Key = Get_Ln(LuRd) + call Get_I1(1,nAtom) + call Get_I1(2,nCent) + call Get_I1(3,nCha) + call Get_I1(4,nPol) + call Get_I1(5,nSlSiteC) + ! Reallocate Qsta + call mma_allocate(Tmp,max(size(Qsta),nCha),label='Tmp') + Tmp(1:size(Qsta)) = Qsta + call mma_deallocate(Qsta) + call move_alloc(Tmp,Qsta) + ! Reallocate Pol + call mma_allocate(Tmp,max(size(Pol),nPol),label='Tmp') + Tmp(1:size(Pol)) = Pol + call mma_deallocate(Pol) + call move_alloc(Tmp,Pol) + ! Reallocate Disp + call mma_allocate(Tmp2,max(size(Disp,1),nPol),max(size(Disp,2),nPol),label='Tmp') + Tmp2(1:size(Disp,1),1:size(Disp,2)) = Disp + call mma_deallocate(Disp) + call move_alloc(Tmp2,Disp) + ! Reallocate SlExpC + call mma_allocate(Tmp2,4,max(size(SlExpC,2),nSlSiteC),label='Tmp') + Tmp2(:,1:size(SlExpC,2)) = SlExpC + call mma_deallocate(SlExpC) + call move_alloc(Tmp2,SlExpC) + ! Reallocate SlFactC + call mma_allocate(Tmp2,4,max(size(SlFactC,2),nSlSiteC),label='Tmp') + Tmp2(:,1:size(SlFactC,2)) = SlFactC + call mma_deallocate(SlFactC) + call move_alloc(Tmp2,SlFactC) + ! Reallocate SlPC + call mma_allocate(Tmp,max(size(SlPC),nSlSiteC),label='Tmp') + Tmp(1:size(SlPC)) = SlPC + call mma_deallocate(SlPC) + call move_alloc(Tmp,SlPC) + ! Reallocate Sexrep + call mma_allocate(Tmp2,max(size(Sexrep,1),nAtom),max(size(Sexrep,2),nAtom),label='Tmp') + Tmp2(1:size(Sexrep,1),1:size(Sexrep,2)) = Sexrep + call mma_deallocate(Sexrep) + call move_alloc(Tmp2,Sexrep) + ! Reallocate Sexre1 + call mma_allocate(Tmp2,max(size(Sexre1,1),nAtom),max(size(Sexre1,2),nAtom),label='Tmp') + Tmp2(1:size(Sexre1,1),1:size(Sexre1,2)) = Sexre1 + call mma_deallocate(Sexre1) + call move_alloc(Tmp2,Sexre1) + ! Reallocate Sexre2 + call mma_allocate(Tmp2,max(size(Sexre2,1),nAtom),max(size(Sexre2,2),nAtom),label='Tmp') + Tmp2(1:size(Sexre2,1),1:size(Sexre2,2)) = Sexre2 + call mma_deallocate(Sexre2) + call move_alloc(Tmp2,Sexre2) + case ('CHAR') + ! <<<CHARge>>> Magnitude of the charges. + Key = Get_Ln(LuRd) + call Get_F(1,Qsta,nCha) + case ('POLA') + ! <<<POLArizability>>> Magnitude of polarizabilities. + Key = Get_Ln(LuRd) + call Get_F(1,Pol,nPol) + case ('SLAT') + !Jose+++++++++++++ + ! <<<SLATer>>> Magnitude of Slater PreFactors and Exponents. + Key = Get_Ln(LuRd) + call Get_I1(1,lMltSlC) + if (lMltSlC > 1) then + write(u6,*) + write(u6,*) 'Too high order of multipole in classical system' + write(u6,*) ' Highest order is 1' + call Quit(_RC_INPUT_ERROR_) + end if + do i=1,nSlSiteC + do j=0,lMltSlC + nS = nTri3_Elem(j) + nT = nTri3_Elem(j+1) + Key = Get_Ln(LuRd) + call Get_F1(1,SlExpTemp) + SlExpC(j+1,i) = SlExpTemp + njhr = nT-nS + Key = Get_Ln(LuRd) + call Get_F(1,SlFacTemp,njhr) + SlFactC(nS+1:nT,i) = SlFacTemp(1:nT-nS) + end do + Key = Get_Ln(LuRd) + call Get_F(1,SlPC(i),1) + end do + !+++++++++++++++++ + case ('END ') + ! <<<END solvent>>> + exit + end select + end do + + case ('RASS') + ! <<<RASSisection>>> Give some numbers specific for the handling + ! of the RASSI-construction of the wave-func. + + QmType = 'RASSI' + do + Key = Get_Ln(LuRd) + Kword = trim(Key) + call UpCase(Kword) + select case (Kword(1:4)) + case default + ! HOW COULD IT GET WRONG HERE? + write(u6,*) + write(u6,*) ' Unrecognized keyword in the RASSisection section:',Kword(1:4) + call Quit(_RC_INPUT_ERROR_) + case ('JOBF') + ! <<<JOBFiles>>> How many jobfiles and how many states in them. + Key = Get_Ln(LuRd) + call Get_I1(1,NrFiles) + call mma_allocate(NrStates,NrFiles,label='NrStates') + Key = Get_Ln(LuRd) + call Get_I(1,NrStates,NrFiles) + case ('EQST') + ! <<<EQSTate>>> Which state is to be equilibrated. + Key = Get_Ln(LuRd) + call Get_I1(1,nEqState) + case ('MORE') + ! <<<MOREduce>>> Work in reduced MO-basis. + Key = Get_Ln(LuRd) + call Get_F1(1,ThrsRedOcc) + MoAveRed = .true. + case ('CONT') + ! <<<CONTract>>> Contract the RASSI state basis. + Key = Get_Ln(LuRd) + call Get_F1(1,ThrsCont) + ContrStateB = .true. + case ('LEVE') + ! <<<LEVElshift>>> Introduce levelshift of RASSI states. + Key = Get_Ln(LuRd) + call Get_I1(1,nLvlShift) + call mma_allocate(iLvlShift,nLvlShift,label='iLvlShift') + call mma_allocate(dLvlShift,nLvlShift,label='dLvlShift') + Key = Get_Ln(LuRd) + call Get_I(1,iLvlShift,nLvlShift) + Key = Get_Ln(LuRd) + call Get_F(1,dLvlShift,nLvlShift) + ! Just a little sorting. + do + Changed = .false. + do i=1,nLvlShift-1 + if (iLvlShift(i) > iLvlShift(i+1)) then + iTemp = iLvlShift(i) + iLvlShift(i) = iLvlShift(i+1) + iLvlShift(i+1) = iTemp + dTemp = dLvlShift(i) + dLvlShift(i) = dLvlShift(i+1) + dLvlShift(i+1) = dTemp + Changed = .true. + end if + end do + if (.not. Changed) exit + end do + case ('CISE') + ! <<<CISElect>>> Use overlap criterion in choosing state. + lCiSelect = .true. + call mma_allocate(iCIInd,nCIRef,label='iCIInd') + call mma_allocate(dCIRef,nCIRef,label='dCIRef') + Key = Get_Ln(LuRd) + call Get_I1(1,nCIRef) + Key = Get_Ln(LuRd) + call Get_I(1,iCIInd,nCIRef) + Key = Get_Ln(LuRd) + call Get_F(1,dCIRef,nCIRef) + case ('END ') + ! <<<END rassisection>>> + YesNo(3) = .true. !Rassi section has been visited. + exit + end select + end do + + case ('SCFS') + ! <<<SCFSection>>> Numbers for a SCF-QmStat run. + + QmType = 'SCF' + do + Key = Get_Ln(LuRd) + Kword = trim(Key) + call UpCase(Kword) + select case (Kword(1:4)) + case default + ! ETWAS FALSCH! + write(u6,*) + write(u6,*) ' Unrecognized keyword in the SCFSection:',Kword(1:4) + call Quit(_RC_INPUT_ERROR_) + case ('ORBI') + ! <<<ORBItals>>> Specifiy the reduced orbital space in which the problem is solved. + Key = Get_Ln(LuRd) + call Get_I(1,iOrb(1),1) + call Get_I1(2,iOcc1) + case ('MP2D') + ! <<<MP2Denscorr>>> + Mp2DensCorr = .true. + case ('END ') + ! <<<END scfsection>>> + YesNo(4) = .true. !Scf section has been visited. + exit + end select + end do + + case ('SING') + ! <<<SINGle-point>>> Signify that a set of single point calculations are to be done. + + SingPoint = .true. + YesNo(7) = .true. + + case ('ANAL') + ! <<<ANALyze section>>> Give details what analysis of the sampfile coordinates that is to be done. + + case ('EXTR') + ! <<<EXTRact section>>> Give details what QM and QM/MM analysis + ! that is to be done from the sampfile coordinates. + + do + Key = Get_Ln(LuRd) + Kword = trim(Key) + call UpCase(Kword) + select case (Kword(1:4)) + case default + ! ETWAS FALSCH! + write(u6,*) + write(u6,*) ' Unrecognized keyword in the EXTRact section:',Kword(1:4) + call Quit(_RC_INPUT_ERROR_) + case ('TOTA') + ! <<<TOTAl energy>>> + lExtr(1) = .true. + case ('DIPO') + ! <<<DIPOle>>> + lExtr(2) = .true. + case ('QUAD') + ! <<<QUADrupole>>> + lExtr(3) = .true. + case ('EIGE') + ! <<<EIGEn things>>> + lExtr(4) = .true. + Key = Get_Ln(LuRd) + call Get_I1(1,iExtr_Eig) + call Get_S(2,VecsQue,1) + call UpCase(VecsQue) + if (VecsQue(1:3) == 'YES') lExtr(5) = .true. + case ('EXPE') + ! <<<EXPEctation values>>> + lExtr(6) = .true. + case ('ELOC') + ! <<<ELOCal>>> + lExtr(7) = .true. + Key = Get_Ln(LuRd) + call Get_I1(1,NExtr_Atm) + call mma_deallocate(iExtr_Atm) + call mma_allocate(iExtr_Atm,NExtr_Atm,label='iExtr_Atm') + Key = Get_Ln(LuRd) + call Get_I(1,iExtr_Atm,NExtr_Atm) + case ('MESP') + !*****JoseMEP**************** + ! <<<MESP>>> + ! The Main Electrostatic potential, field and field gradients will + ! be obtained in order to produce perturbation integrals that will + ! be used to optimize the intramolecular geometry of the QM system. + lExtr(8) = .true. + !***************************** + case ('END ') + ! <<<END extract section>>> + YesNo(10) = .true. + end select + end do + + case ('END ') + ! <<<END >>> + + exit + + end select +end do + +! Check if mandatory input was included and that no blatant +! inconsistencies exist. Not fool-proof, fools! + +call MandatoryInp(YesNo) + +! Good bye. + +return + +end subroutine Get_Qmstat_Input diff -Nru openmolcas-22.02/src/qmstat/get_slater.f openmolcas-22.10/src/qmstat/get_slater.f --- openmolcas-22.02/src/qmstat/get_slater.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/get_slater.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,95 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -*----------------------------------------------------------------------* -* This subroutine reads from the formatted file DIFFPR coming from * -* generated by MpProp the Slater Exponents, Factors and Nuclear Charges* -*----------------------------------------------------------------------* - Subroutine Get_Slater(SlExpQ,LMltSlQ,outxyz,nAt) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "files_qmstat.fh" -#include "warnings.h" - - Dimension CoordTest(3),SlFactQ(6) - Dimension SlExpQ(MxMltp+1,MxQCen),outxyz(MxQCen,3) - Logical Exist,lCheck - - -*Open the file - Lu=40 - Lu=IsFreeUnit(40) - Call Opnfl('DIFFPR',Lu,Exist) - If(.not.Exist) then - Write(6,*) - Write(6,*)' Can not locate output file DiffPr. ' - Call Quit(_RC_IO_ERROR_READ_) - Endif - Rewind(Lu) - -*-- Read Number of centers and angular momentums. -* - Read(Lu,101)nSlCentQ - Read(Lu,101)LMltSlQ - -* A first test - nTestjhr=nAt*(nAt+1)/2 - If(nSlCentQ.ne.nTestjhr) then - Write(6,*)'ERROR! Number of centers in DiffPr file',nSlCentQ - & ,' is different from number of centers obtained from RUNFILE' - & ,nTestjhr,' Check your files.' - Call Quit(_RC_GENERAL_ERROR_) - Endif - -*-- Read Exponentials for the Centers - Do iC=1,nSlCentQ - lCheck=.false. - Read(Lu,103)(CoordTest(k),k=1,3) - ind=0 - Do jhr=1,nSlCentQ - If(abs(CoordTest(1)-outxyz(jhr,1)).lt.1.0d-4) then - If(abs(CoordTest(2)-outxyz(jhr,2)).lt.1.0d-4) then - If(abs(CoordTest(3)-outxyz(jhr,3)).lt.1.0d-4) then - lCheck=.true. - ind=jhr - Endif - Endif - Endif - Enddo - If(.not.lCheck) then - write(6,*)'ERROR. Something is very wrong, coordinates' - &//' of DiffPr and MpProp files do not match.' - &//' DiffPr center',iC - Endif - Do l=0,LMltSlQ - nS=l*(l+1)*(l+2)/6 - nT=(l+1)*(l+2)*(l+3)/6 - Read(Lu,104)SlExpQ(l+1,ind) - Read(Lu,105)(SlFactQ(kk),kk=nS+1,nT) -* Read(Lu,105)(SlFactQ(kk,ind),kk=nS+1,nT) - End do -*Jose. No read nuclear charge -* Read(Lu,104)PointP(ind) - Read(Lu,*) - End do - - Close(Lu) - -101 Format(I5) -103 Format(3(F20.14)) -104 Format(F20.14) -105 Format(3(F20.14)) - - Return -#ifdef _WARNING_WORKAROUND_ - If (.False.) Call Unused_real_array(SlFactQ) -#endif - End diff -Nru openmolcas-22.02/src/qmstat/get_slater.F90 openmolcas-22.10/src/qmstat/get_slater.F90 --- openmolcas-22.02/src/qmstat/get_slater.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/get_slater.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,95 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +!----------------------------------------------------------------------* +! This subroutine reads from the formatted file DIFFPR coming from * +! generated by MpProp the Slater Exponents, Factors and Nuclear Charges* +!----------------------------------------------------------------------* +subroutine Get_Slater(LMltSlQ,outxyz,nAt) + +use qmstat_global, only: SlExpQ +use Index_Functions, only: nTri3_Elem, nTri_Elem +use stdalloc, only: mma_allocate +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(out) :: LMltSlQ +integer(kind=iwp), intent(in) :: nAt +real(kind=wp), intent(in) :: outxyz(3,nTri_Elem(nAt)) +integer(kind=iwp) :: iC, ind, jhr, l, Lu, nS, nSlCentQ, nT, nTestjhr +real(kind=wp) :: CoordTest(3), SlFactQ(6) +logical(kind=iwp) :: Exists +integer(kind=iwp), external :: IsFreeUnit +#include "warnings.h" + +#include "macros.fh" + +! Open the file +Lu = IsFreeUnit(40) +call Opnfl('DIFFPR',Lu,Exists) +if (.not. Exists) then + write(u6,*) + write(u6,*) ' Can not locate output file DiffPr. ' + call Quit(_RC_IO_ERROR_READ_) +end if +rewind(Lu) + +! Read Number of centers and angular momenta. + +read(Lu,101) nSlCentQ +read(Lu,101) LMltSlQ + +! A first test +nTestjhr = nTri_Elem(nAt) +if (nSlCentQ /= nTestjhr) then + write(u6,*) 'ERROR! Number of centers in DiffPr file',nSlCentQ,' is different from number of centers obtained from RUNFILE', & + nTestjhr,' Check your files.' + call Quit(_RC_GENERAL_ERROR_) +end if + +! Read Exponentials for the Centers +call mma_allocate(SlExpQ,[0,LMltSlq],[1,nSlCentQ],label='SlExpQ') +do iC=1,nSlCentQ + read(Lu,103) CoordTest(:) + ind = 0 + do jhr=1,nSlCentQ + if (abs(CoordTest(1)-outxyz(1,jhr)) < 1.0e-4_wp) then + if (abs(CoordTest(2)-outxyz(2,jhr)) < 1.0e-4_wp) then + if (abs(CoordTest(3)-outxyz(3,jhr)) < 1.0e-4_wp) then + ind = jhr + end if + end if + end if + end do + if (ind == 0) write(u6,*) 'ERROR. Something is very wrong, coordinates of DiffPr and MpProp files do not match. DiffPr center',iC + do l=0,LMltSlQ + nS = nTri3_Elem(l) + nT = nTri3_Elem(l+1) + read(Lu,104) SlExpQ(l,ind) + read(Lu,105) SlFactQ(nS+1:nT) + !read(Lu,105) SlFactQ(nS+1:nT,ind) + unused_var(SlFactQ) + end do + !Jose. No read nuclear charge + !read(Lu,104) PointP(ind) + read(Lu,*) +end do + +close(Lu) + +return + +101 format(I5) +103 format(3(F20.14)) +104 format(F20.14) +105 format(3(F20.14)) + +end subroutine Get_Slater diff -Nru openmolcas-22.02/src/qmstat/givemeinfo.f openmolcas-22.10/src/qmstat/givemeinfo.f --- openmolcas-22.02/src/qmstat/givemeinfo.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/givemeinfo.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,254 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -*----------------------------------------------------------------------* - Subroutine GiveMeInfo(nBB,nntyp,natyp,BasCoo,iCon,nPrim,nBA,nCBoA, - & nBona,ipExpo,ipCont,nSh,nfSh,nSize,iPrint, - & MxAtQ,MxPrCon,MxBasQ,MxAngqNr,ipAcc, - & nACCSize) - use Basis_Info - use Center_Info - use Her_RW - use Real_Spherical - Implicit Real*8 (a-h,o-z) - -*------------------------------------------------------------------------* -* Include files that got to do with the info-file generated by seward. * -*------------------------------------------------------------------------* -#include "numbers.fh" -#include "WrkSpc.fh" -#include "stdalloc.fh" -*------------------------------------------------------------------------* -* Ordinary variables. * -*------------------------------------------------------------------------* - Dimension BasCoo(3,MxBasQ),nBona(MxAtQ) - Dimension nSh(MxAtQ),nFSh(MxAtQ,MxAngqNr),iCon(MxAtQ,MxPrCon) - Dimension natyp(MxAtQ),nPrim(MxBasQ),nBA(MxAtQ) - Dimension nCBoA(MxAtQ,MxAngqNr) - Real*8, Allocatable:: TEMP1(:), TEMP2(:) - Logical DoRys - - -*------------------------------------------------------------------------* -* Initialize in order to read properly from the info file. * -*------------------------------------------------------------------------* - Call Seward_Init() - -*------------------------------------------------------------------------* -* GetInf reads everything in the runfile and puts it in variables * -* in modules. * -*------------------------------------------------------------------------* - nDiff=0 - DoRys=.false. - Call GetInf(DoRys,nDiff) - -*------------------------------------------------------------------------* -* Set nntyp. * -*------------------------------------------------------------------------* - nntyp=nCnttp - -*------------------------------------------------------------------------* -* Compute what we came here for. iBasAng will contain nBas elements with * -* integers, such that 1=s-orbitals, 2=p-orbitals, 3=d-orbitals, ... * -*------------------------------------------------------------------------* -C ii=0 !ii is number of basis sets. -C10 Continue -C ii=ii+1 -C If(dbsc(ii)%nCntr.ne.0) Go To 10 -C ii=ii-1 -C If(ii.eq.0) then -C Write(6,*) -C Write(6,*)'ERROR in GiveMeInfo. No atoms?' -C Endif - ii=nCnttp -* - kaunta=0 - kaunt=0 - kaunter=0 - krekna=0 - MaxAng=0 - Do 20, i=1,ii - kauntSav=kaunt - Do 25, ioio=1,dbsc(i)%nCntr - krekna=krekna+1 - krekna2=0 - kaunt=kauntSav - kaunterPrev=kaunter - nBA(krekna)=dbsc(i)%nShells - If(nBA(krekna).gt.MaxAng)MaxAng=nBA(krekna) - Do 30, j=1,dbsc(i)%nShells - kaunt=kaunt+1 - krekna2=krekna2+1 - nCBoA(krekna,krekna2)=Shells(kaunt)%nBasis - Do 40, jj=1,Shells(kaunt)%nBasis - kaunter=kaunter+1 -40 Continue -30 Continue - kaunta=kaunta+1 - nBonA(kaunta)=kaunter-kaunterPrev !Number of bases on each, -25 Continue !atom used below. -20 Continue - -*--------------------------------------------------------------------------* -* And now coordinates of each basis. * -*--------------------------------------------------------------------------* - kaunter=0 - kaunt=0 - Do 101, i=1,ii - Do 111, j=1,dbsc(i)%nCntr - kaunt=kaunt+1 - Do 121, kk=1,nBonA(kaunt) - kaunter=kaunter+1 - Do 131, k=1,3 - BasCoo(k,kaunter)=dbsc(i)%Coor(k,j) -131 Continue -121 Continue -111 Continue -101 Continue - -*--------------------------------------------------------------------------* -* Now get info regarding the contraction. Icon is an array that for each * -* basis type contain n1+n2+...+nx elements where n1 is the number of * -* contracted basis functions of s-type, n2 the same number for p-type etc. * -* The value of the first n1 elements is the number of primitive basis * -* functions of s-type, etc. So a contraction 7s3p.4s1p generates the vector* -* 7,7,7,7,3. We also compute natyp and also collect all exponents and * -* contraction coefficients. These are stored dynamically and then we return* -* the pointers only. * -*--------------------------------------------------------------------------* - kaunt=0 - Do 201, i=1,ii - kaunter=0 - Do 203, k=1,dbsc(i)%nShells - kaunt=kaunt+1 - Do 205, ll=1,Shells(kaunt)%nBasis - kaunter=kaunter+1 - Icon(i,kaunter)=Shells(kaunt)%nExp -205 Continue -203 Continue -201 Continue - - ndc=0 - iAngSav=1 - nSize=0 - kaunt=0 - Do 2101, kk=1,ii !Just to get size of vector - Do 2102, kkk=1,dbsc(kk)%nShells - kaunt=kaunt+1 - nSize=nSize+Shells(kaunt)%nBasis*Shells(kaunt)%nExp -2102 Continue -2101 Continue - Call GetMem('Exponents','Allo','Real',ipExpo,nSize*MxAtQ) - Call GetMem('ContrCoef','Allo','Real',ipCont,nSize*MxAtQ) - Call FZero(Work(ipExpo),nSize*MxAtQ) - Call FZero(Work(ipCont),nSize*MxAtQ) - - Do 211, iCnttp=1,nCnttp !Here we set NaTyp. - jSum=0 - iTemp=0 - nVarv=dbsc(iCnttp)%nShells - nSh(iCnttp)=nVarv - M=iCnttp-1 - Do 212, iCnt=1,dbsc(iCnttp)%nCntr - ndc=ndc+1 - iTemp=iTemp+dc(ndc)%nStab -212 Continue - NaTyp(iCnttp)=iTemp - Do 213, iAng=0,nVarv-1 !And in this loop we get hold of the - !contraction coefficients and the exponents. - iCount=iAng+iAngSav - iPrim=Shells(iCount)%nExp - iBas=Shells(iCount)%nBasis -#ifdef _DEBUGPRINT_ - Call RecPrt('Exp',' ',Shells(iCount)%Exp,iPrim,1) - Call RecPrt('Cff',' ',Shells(iCount)%pCff,iPrim,iBas) -#endif - nfSh(iCnttp,iAng+1)=iBas - Do 214, i=1,iBas - Call dCopy_(iPrim,Shells(iCount)%Exp,1, - & Work(ipExpo+jSum*MxAtQ+M),MxAtQ) - Call dCopy_(iPrim,Shells(iCount)%pCff(1,i),1, - & Work(ipCont+jSum*MxAtQ+M),MxAtQ) - jSum=jSum+iPrim -214 Continue -213 Continue - iAngSav=iAngSav+iAng -211 Continue - If(iPrint.ge.30) then - Write(6,*)'Exp.' - Write(6,'(10G13.4)')(Work(ipExpo+k),k=0,nSize*MxAtQ-1) - Write(6,*)'Contr.' - Write(6,'(10G13.4)')(Work(ipCont+k),k=0,nSize*MxAtQ-1) - Endif - -*---------------------------------------------------------------------------* -* Contruct the nPrim vector. * -*---------------------------------------------------------------------------* - iBas=0 - Do 301, i=1,nntyp - na=natyp(i) - Do 302, j=1,na - ind=0 - nshj=nsh(i) - Do 303, k=1,nshj - nnaa=nfsh(i,k) - Do 304, l=1,nnaa - iBas=iBas+1 - ind=ind+1 - nPrim(iBas)=iCon(i,ind) -304 Continue -303 Continue -302 Continue -301 Continue -* -*-- Then since overlap integrations are in cartesian coordinates while -* the AO-basis is spherical, we need transformation matrix for this. -* To our great joy, old reliable Seward computes this matrix of any -* order (within Molcas limits). Due to conflicting order conventions, -* some numbers gymnastics are required. -* - MaxAng=MaxAng-1 - nSize=(2*MaxAng+1)*(MaxAng+1)*(MaxAng+2)/2 - nACCSize=0 - Do i=2,MaxAng - nACCSize=nACCSize+(2*i+1)*(i+1)*(i+2)/2 - End Do - nSumma=0 - Call mma_allocate(TEMP1,nSize,Label='TEMP1') - Call mma_allocate(TEMP2,nSize,Label='TEMP2') - Call GetMem('AccTransa','Allo','Real',ipAcc,nACCSize) -* - Do i=2,MaxAng - ind1=(i+1)*(i+2)/2 - ind2=2*i+1 - iHowMuch=ind1*ind2 - Call DCopy_(iHowMuch,RSph(ipSph(i)),iONE,TEMP1,iONE) - ind3=1 - Do jj=1,ind1 - call dcopy_(ind2,TEMP1(jj),ind1,TEMP2(ind3),iONE) - ind3=ind3+ind2 - End Do -* Call recprt('FFF',' ',TEMP1,(i+1)*(i+2)/2,2*i+1) -* Call recprt('GGG',' ',TEMP2,ind2,ind1) - call dcopy_(iHowMuch,TEMP2,iONE,Work(ipAcc+nSumma),iONE) - nSumma=nSumma+iHowMuch - End Do -* - Call mma_deallocate(TEMP1) - Call mma_deallocate(TEMP2) -*----------------------------------------------------------------------* -* Make deallocations. They are necessary because of the getinf. * -*----------------------------------------------------------------------* - Call ClsSew() - - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(nBB) - End diff -Nru openmolcas-22.02/src/qmstat/givemeinfo.F90 openmolcas-22.10/src/qmstat/givemeinfo.F90 --- openmolcas-22.02/src/qmstat/givemeinfo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/givemeinfo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,262 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! This subroutine should be in a module, to avoid explicit interfaces +#ifdef _IN_MODULE_ + +subroutine GiveMeInfo(nntyp,natyp,BasCoo,iCon,nPrim,nBA,nCBoA,nBonA,Expo,Cont,nSh,nfSh,nSize,iPrint,nAtoms,MxAngqNr,Acc,nBas) + +use Basis_Info, only: dbsc, nCnttp, Shells +use Center_Info, only: dc +use Real_Spherical, only: ipSph, RSph +use Index_Functions, only: nTri_Elem1 +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iPrint, nAtoms, MxAngqNr +integer(kind=iwp), intent(out) :: nntyp, natyp(nAtoms), nBA(nAtoms), nCBoA(nAtoms,MxAngqNr), nBonA(nAtoms), nSh(nAtoms), & + nfSh(nAtoms,MxAngqNr), nSize, nBas +integer(kind=iwp), allocatable, intent(out) :: iCon(:,:), nPrim(:) +real(kind=wp), allocatable, intent(out) :: Expo(:,:), Cont(:,:), BasCoo(:,:), Acc(:) +integer(kind=iwp) :: i, iAng, iAngSav, iBas, iCnt, iCnttp, iCount, iHowMuch, ii, ind, ind1, ind2, ind3, ioio, iPrim, iTemp, j, jj, & + jSum, k, kaunt, kaunta, kaunter, kaunterPrev, kauntSav, kk, kkk, krekna, krekna2, l, ll, MaxAng, MxPrCon, na, & + nACCSize, ndc, nDiff, nnaa, nshj, nSumma, nVarv +real(kind=wp), allocatable :: TEMP1(:), TEMP2(:) +logical(kind=iwp) :: DoRys +#include "warnings.h" + +!----------------------------------------------------------------------* +! Initialize in order to read properly from the info file. * +!----------------------------------------------------------------------* +call Seward_Init() + +!----------------------------------------------------------------------* +! GetInf reads everything in the runfile and puts it in variables * +! in modules. * +!----------------------------------------------------------------------* +nDiff = 0 +DoRys = .false. +call GetInf(DoRys,nDiff) + +!----------------------------------------------------------------------* +! Set nntyp. * +!----------------------------------------------------------------------* +nntyp = nCnttp + +!----------------------------------------------------------------------* +! Compute what we came here for. iBasAng will contain nBas elements * +! with integers, such that 1=s-orbitals, 2=p-orbitals, 3=d-orbitals... * +!----------------------------------------------------------------------* +!ii = 0 !ii is number of basis sets. +!do +! ii = ii+1 +! if (dbsc(ii)%nCntr == 0) exit +!end do +!ii = ii-1 +!if (ii == 0) then +! write(u6,*) +! write(u6,*) 'ERROR in GiveMeInfo. No atoms?' +!end if +ii = nntyp + +kaunta = 0 +kaunt = 0 +kaunter = 0 +krekna = 0 +MaxAng = 0 +do i=1,ii + kauntSav = kaunt + do ioio=1,dbsc(i)%nCntr + krekna = krekna+1 + krekna2 = 0 + kaunt = kauntSav + kaunterPrev = kaunter + nBA(krekna) = dbsc(i)%nShells + if (nBA(krekna) > MaxAng) MaxAng = nBA(krekna) + do j=1,dbsc(i)%nShells + kaunt = kaunt+1 + krekna2 = krekna2+1 + nCBoA(krekna,krekna2) = Shells(kaunt)%nBasis + kaunter = kaunter+Shells(kaunt)%nBasis + end do + kaunta = kaunta+1 + nBonA(kaunta) = kaunter-kaunterPrev !Number of bases on each atom used below. + end do +end do +nBas = kaunter +call mma_allocate(BasCoo,3,nBas,label='BasCoo') + +!----------------------------------------------------------------------* +! And now coordinates of each basis. * +!----------------------------------------------------------------------* +kaunter = 0 +kaunt = 0 +do i=1,ii + do j=1,dbsc(i)%nCntr + kaunt = kaunt+1 + do kk=1,nBonA(kaunt) + kaunter = kaunter+1 + BasCoo(:,kaunter) = dbsc(i)%Coor(:,j) + end do + end do +end do + +!----------------------------------------------------------------------* +! Now get info regarding the contraction. Icon is an array that for * +! each basis type contain n1+n2+...+nx elements where n1 is the number * +! of contracted basis functions of s-type, n2 the same number for * +! p-type etc. The value of the first n1 elements is the number of * +! primitive basis functions of s-type, etc. So a contraction 7s3p.4s1p * +! generates the vector 7,7,7,7,3. We also compute natyp and also * +! collect all exponents and contraction coefficients. These are stored * +! dynamically and then we return the pointers only. * +!----------------------------------------------------------------------* +MxPrCon = 0 +kaunt = 0 +do i=1,ii + kaunter = 0 + do k=1,dbsc(i)%nShells + kaunt = kaunt+1 + kaunter = kaunter+Shells(kaunt)%nBasis + end do + MxPrCon = max(MxPrCon,kaunter) +end do + +call mma_allocate(Icon,nAtoms,MxPrCon,label='Icon') +kaunt = 0 +do i=1,ii + kaunter = 0 + do k=1,dbsc(i)%nShells + kaunt = kaunt+1 + do ll=1,Shells(kaunt)%nBasis + kaunter = kaunter+1 + Icon(i,kaunter) = Shells(kaunt)%nExp + end do + end do +end do + +ndc = 0 +iAngSav = 1 +nSize = 0 +kaunt = 0 +do kk=1,ii !Just to get size of vector + do kkk=1,dbsc(kk)%nShells + kaunt = kaunt+1 + nSize = nSize+Shells(kaunt)%nBasis*Shells(kaunt)%nExp + end do +end do +call mma_allocate(Expo,nntyp,nSize,label='Exponents') +call mma_allocate(Cont,nntyp,nSize,label='ContrCoef') +Expo(:,:) = Zero +Cont(:,:) = Zero + +do iCnttp=1,nCnttp !Here we set NaTyp. + jSum = 0 + iTemp = 0 + nVarv = dbsc(iCnttp)%nShells + nSh(iCnttp) = nVarv + do iCnt=1,dbsc(iCnttp)%nCntr + ndc = ndc+1 + iTemp = iTemp+dc(ndc)%nStab + end do + NaTyp(iCnttp) = iTemp + do iAng=0,nVarv-1 !And in this loop we get hold of the contraction coefficients and the exponents. + iCount = iAng+iAngSav + iPrim = Shells(iCount)%nExp + iBas = Shells(iCount)%nBasis +# ifdef _DEBUGPRINT_ + call RecPrt('Exp',' ',Shells(iCount)%Exp,iPrim,1) + call RecPrt('Cff',' ',Shells(iCount)%pCff,iPrim,iBas) +# endif + nfSh(iCnttp,iAng+1) = iBas + do i=1,iBas + Expo(iCnttp,jSum+1:jSum+iPrim) = Shells(iCount)%Exp(1:iPrim) + Cont(iCnttp,jSum+1:jSum+iPrim) = Shells(iCount)%pCff(1:iPrim,i) + jSum = jSum+iPrim + end do + end do + iAngSav = iAngSav+iAng +end do +if (iPrint >= 30) then + write(u6,*) 'Exp.' + write(u6,'(10G13.4)') Expo(:,:) + write(u6,*) 'Contr.' + write(u6,'(10G13.4)') Cont(:,:) +end if + +!----------------------------------------------------------------------* +! Construct the nPrim vector. * +!----------------------------------------------------------------------* +call mma_allocate(nPrim,nbas,label='nPrim') +iBas = 0 +do i=1,nntyp + na = natyp(i) + do j=1,na + ind = 0 + nshj = nsh(i) + do k=1,nshj + nnaa = nfsh(i,k) + do l=1,nnaa + iBas = iBas+1 + ind = ind+1 + nPrim(iBas) = iCon(i,ind) + end do + end do + end do +end do + +! Then since overlap integrations are in cartesian coordinates while +! the AO-basis is spherical, we need transformation matrix for this. +! To our great joy, old reliable Seward computes this matrix of any +! order (within Molcas limits). Due to conflicting order conventions, +! some numbers gymnastics are required. + +MaxAng = MaxAng-1 +nSize = (2*MaxAng+1)*nTri_Elem1(MaxAng) +nACCSize = 0 +do i=2,MaxAng + nACCSize = nACCSize+(2*i+1)*nTri_Elem1(i) +end do +call mma_allocate(TEMP1,nSize,Label='TEMP1') +call mma_allocate(TEMP2,nSize,Label='TEMP2') +call mma_allocate(Acc,nACCSize,label='AccTransa') + +nSumma = 0 +do i=2,MaxAng + ind1 = nTri_Elem1(i) + ind2 = 2*i+1 + iHowMuch = ind1*ind2 + TEMP1(1:iHowMuch) = RSph(ipSph(i):ipSph(i)+iHowMuch-1) + ind3 = 1 + do jj=1,ind1 + call dcopy_(ind2,TEMP1(jj),ind1,TEMP2(ind3),1) + ind3 = ind3+ind2 + end do + !call recprt('FFF',' ',TEMP1,nTri_Elem1(i),2*i+1) + !call recprt('GGG',' ',TEMP2,ind2,ind1) + Acc(nSumma+1:nSumma+iHowMuch) = Temp2(1:iHowMuch) + nSumma = nSumma+iHowMuch +end do + +call mma_deallocate(TEMP1) +call mma_deallocate(TEMP2) +!----------------------------------------------------------------------* +! Make deallocations. They are necessary because of the getinf. * +!----------------------------------------------------------------------* +call ClsSew() + +return + +end subroutine GiveMeInfo + +#endif diff -Nru openmolcas-22.02/src/qmstat/haveweconv.f openmolcas-22.10/src/qmstat/haveweconv.f --- openmolcas-22.02/src/qmstat/haveweconv.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/haveweconv.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,84 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine HaveWeConv(iCNum,iCStart,iQ_Atoms,Indma,iDT,FFp,xyzMyI - &,Egun,Energy,NVarv,JaNej,Haveri) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "WrkSpc.fh" - - Dimension iDT(3) - Dimension FFp(npol*npart,3),xyzMyI(3) - Logical JaNej,Haveri - -*----------------------------------------------------------------------* -* With the new and the old induced dipoles, check if we have converged.* -* We also have energy check. * -*----------------------------------------------------------------------* - JaNej=.true. - Haveri=.false. - Diffab=0 - xyzMyi(1)=0 - xyzMyi(2)=0 - xyzMyi(3)=0 - Do 821, i=1+(nPol*iCnum),IndMa - k=i-((i-1)/nPol)*nPol - Do 822, l=1,3 - Dtil=FFp(i,l)*Pol(k) - Diff=Abs(Work(iDT(l)+i-1)-Dtil) - If(Diff.gt.Diffab) Diffab=Diff - xyzMyi(l)=xyzMyi(l)+Dtil - Work(iDT(l)+i-1)=Dtil !This is the quantities that has - !changed during the iteration and that through FFp - !includes the effect of the polarization of the - !QM-molecule. It enters the iteration above, unless - !we have converged. -822 Continue -821 Continue - Egtest=Egun-Energy - Egun=Energy - If(nVarv.ge.itMax) then !itMax is from input or default. - Write(6,*) - Write(6,*)' No convergence for the induced dipoles.' - Write(6,*)' Difference remaining after ',nVarv,' iterations: ' - &,Diffab - Haveri=.true. - iPrint=10 - Do 842, j=icstart,npart*ncent,ncent - distmin=1000.0d0 - kmin=0 - imin=0 - Do 841, i=1,iq_atoms - Do 843, k=0,ncent-1 - dist=sqrt((cordst(i,1)-cordst(j+k,1))**2 - & +(cordst(i,2)-cordst(j+k,2))**2 - & +(cordst(i,3)-cordst(j+k,3))**2) - if(dist.lt.distmin) then - distmin=dist - imin=i - kmin=k - endif -843 Continue -841 Continue - Write(6,*)'solv.',j,'iq_atom',imin,'center',kmin+1 - & ,'dist',distmin -842 Continue - Write(6,*) - GoTo 9898 - Endif - If(abs(egtest).gt.Enelim) JaNej=.false. - If(Diffab.gt.PolLim) JaNej=.false. - -9898 Continue - - Return - End diff -Nru openmolcas-22.02/src/qmstat/haveweconv.F90 openmolcas-22.10/src/qmstat/haveweconv.F90 --- openmolcas-22.02/src/qmstat/haveweconv.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/haveweconv.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,82 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine HaveWeConv(iCNum,iCStart,iQ_Atoms,Indma,DT,FFp,xyzMyI,Egun,Energy,NVarv,JaNej,Haveri) + +use qmstat_global, only: Cordst, Enelim, iPrint, itMax, nCent, nPart, nPol, Pol, PolLim +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iCNum, iCStart, iQ_Atoms, Indma, NVarv +real(kind=wp), intent(inout) :: DT(3,nPol*nPart), Egun +real(kind=wp), intent(in) :: FFp(nPol*nPart,3), Energy +real(kind=wp), intent(out) :: xyzMyI(3) +logical(kind=iwp), intent(out) :: JaNej, Haveri +integer(kind=iwp) :: i, imin, j, k, kmin, l +real(kind=wp) :: Diff, Diffab, dist, distmin, Dtil, Egtest + +!----------------------------------------------------------------------* +! With the new and the old induced dipoles, check if we have converged.* +! We also have energy check. * +!----------------------------------------------------------------------* +JaNej = .true. +Haveri = .false. +Diffab = Zero +xyzMyi(:) = Zero +do i=1+(nPol*iCnum),IndMa + k = i-((i-1)/nPol)*nPol + do l=1,3 + Dtil = FFp(i,l)*Pol(k) + Diff = abs(DT(l,i)-Dtil) + if (Diff > Diffab) Diffab = Diff + xyzMyi(l) = xyzMyi(l)+Dtil + ! This is the quantity that has + ! changed during the iteration and that through FFp + ! includes the effect of the polarization of the + ! QM-molecule. It enters the iteration above, unless + ! we have converged. + DT(l,i) = Dtil + end do +end do +Egtest = Egun-Energy +Egun = Energy +if (nVarv >= itMax) then !itMax is from input or default. + write(u6,*) + write(u6,*) ' No convergence for the induced dipoles.' + write(u6,*) ' Difference remaining after ',nVarv,' iterations: ',Diffab + Haveri = .true. + iPrint = 10 + do j=icstart,nPart*nCent,nCent + distmin = 1.0e4_wp + kmin = 0 + imin = 0 + do i=1,iq_atoms + do k=0,nCent-1 + dist = sqrt((Cordst(1,i)-Cordst(1,j+k))**2+(Cordst(2,i)-Cordst(2,j+k))**2+(Cordst(3,i)-Cordst(3,j+k))**2) + if (dist < distmin) then + distmin = dist + imin = i + kmin = k + end if + end do + end do + write(u6,*) 'solv.',j,'iq_atom',imin,'center',kmin+1,'dist',distmin + end do + write(u6,*) +else + if (abs(egtest) > Enelim) JaNej = .false. + if (Diffab > PolLim) JaNej = .false. +end if + +return + +end subroutine HaveWeConv diff -Nru openmolcas-22.02/src/qmstat/hel.f openmolcas-22.10/src/qmstat/hel.f --- openmolcas-22.02/src/qmstat/hel.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/hel.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,66 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Anders Ohrn * -************************************************************************ -* Hel -* -*> @brief -*> Couple the electrostatic part of the solvent with the QM-region. -*> Only include the static part, no polarization at this moment -*> @author A. Ohrn -*> -*> @details -*> (2) The electrostatics. -*> -*> @param[in] Eint The static field from the solvent on the QM molecule centers -*> @param[in] itri Number of elements in triangular \f$ H \f$-matrix -*> @param[in] ici Number of MME-centers -*> @param[in] ql MME-charges, obtained from the MME -*> @param[in] dil MME-dipoles -*> @param[in] qqxxyy MME-quadrupoles. -*> @param[out] vmat The electrostatic part of the solute-solvent interaction matrix -*> @param[in] iprint Print parameter -************************************************************************ - Subroutine Hel(Eint,itri,ici,ql,dil,qqxxyy,vmat,iprint) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "WrkSpc.fh" - - Dimension Ql(MxOT,MxQCen),Dil(MxOT,3,MxQCen) - &,QQxxyy(MxOT,6,MxQCen),Eint(MxQCen,10),Vmat(MxOT) - - -*Zeros - Do 9, i=1,itri - Vmat(i)=0.0d0 -9 Continue - -*The electrostatic perturbation: <psi_i|V_el|psi_j> - Do 10, i=1,itri - Do 11, k=1,ici - Vmat(i)=Vmat(i)+Eint(k,1)*Ql(i,k) - Do 12, j=1,3 - Vmat(i)=Vmat(i)+Eint(k,j+1)*Dil(i,j,k) -12 Continue - Vmat(i)=Vmat(i)+Eint(k,5)*QQxxyy(i,1,k) - Vmat(i)=Vmat(i)+Eint(k,7)*QQxxyy(i,3,k) - Vmat(i)=Vmat(i)+Eint(k,10)*QQxxyy(i,6,k) - Vmat(i)=Vmat(i)+Eint(k,6)*QQxxyy(i,2,k)*2.0d0 - Vmat(i)=Vmat(i)+Eint(k,8)*QQxxyy(i,4,k)*2.0d0 - Vmat(i)=Vmat(i)+Eint(k,9)*QQxxyy(i,5,k)*2.0d0 -11 Continue -10 Continue - - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(iprint) - End diff -Nru openmolcas-22.02/src/qmstat/hel.F90 openmolcas-22.10/src/qmstat/hel.F90 --- openmolcas-22.02/src/qmstat/hel.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/hel.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,58 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Anders Ohrn * +!*********************************************************************** +! Hel +! +!> @brief +!> Couple the electrostatic part of the solvent with the QM-region. +!> Only include the static part, no polarization at this moment +!> @author A. Ohrn +!> +!> @details +!> (2) The electrostatics. +!> +!> @param[in] Eint The static field from the solvent on the QM molecule centers +!> @param[in] itri Number of elements in triangular \f$ H \f$-matrix +!> @param[in] ici Number of MME-centers +!> @param[in] ql MME-charges, obtained from the MME +!> @param[in] dil MME-dipoles +!> @param[in] qqxxyy MME-quadrupoles. +!> @param[out] vmat The electrostatic part of the solute-solvent interaction matrix +!*********************************************************************** + +subroutine Hel(Eint,itri,ici,ql,dil,qqxxyy,vmat) + +use Constants, only: Zero, Two +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: itri, ici +real(kind=wp), intent(in) :: Eint(ici,10), Ql(itri,ici), Dil(itri,3,ici), QQxxyy(itri,6,ici) +real(kind=wp), intent(out) :: Vmat(itri) +integer(kind=iwp) :: i, j + +! Zeros +Vmat(:) = Zero + +! The electrostatic perturbation: <psi_i|V_el|psi_j> +do i=1,itri + do j=1,ici + Vmat(i) = Vmat(i)+Eint(j,1)*Ql(i,j)+ & + Eint(j,2)*Dil(i,1,j)+Eint(j,3)*Dil(i,2,j)+Eint(j,4)*Dil(i,3,j)+ & + Eint(j,5)*QQxxyy(i,1,j)+Eint(j,7)*QQxxyy(i,3,j)+Eint(j,10)*QQxxyy(i,6,j)+ & + Eint(j,6)*QQxxyy(i,2,j)*Two+Eint(j,8)*QQxxyy(i,4,j)*Two+Eint(j,9)*QQxxyy(i,5,j)*Two + end do +end do + +return + +end subroutine Hel diff -Nru openmolcas-22.02/src/qmstat/helstate.f openmolcas-22.10/src/qmstat/helstate.f --- openmolcas-22.02/src/qmstat/helstate.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/helstate.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,78 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Anders Ohrn * -************************************************************************ -* HelState -* -*> @brief -*> Couple the electrostatic part of the solvent with the QM-region. -*> Only include the static part, no polarization at this moment -*> @author A. Ohrn -*> -*> @note -*> The quadrupoles are put in 'Buckingham-style'. -*> -*> @details -*> Rather easy to follow. This subroutine is a slightly modified -*> copy of hel.f. The interesting quantities are collected in -*> \p Vmat and are later to be added to the 'RASSI-matrix'. -*> -*> @param[in] Eint Field from static part of solvent on the Qm-molecule centers -*> @param[in] nrstate Number of states in RASSI -*> @param[in] ici Number of MME-centers -*> @param[in] Cha Charges -*> @param[in] Dip Dipoles -*> @param[in] Qua Quadrupoles -*> @param[out] Vmat The electrostatic part of the solute-solvent interaction matrix -*> @param[in] iPrint Print-level -************************************************************************ - Subroutine HelState(Eint,nrstate,ici,Cha,Dip,Qua,Vmat,iPrint) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "WrkSpc.fh" - - Dimension Eint(MxQCen,10),Vmat(MxOt) - Dimension Cha(MxStOT,MxQCen),Dip(MxStOT,3,MxQCen) - Dimension Qua(MxStOT,6,MxQCen) - - kaunt=0 - Do 9, i=1,nrState - Do 99, j=1,i - kaunt=kaunt+1 - Vmat(kaunt)=0.0d0 -99 Continue -9 Continue - - kaunt=0 !The interaction between the distributed multipoles - !and the generalized field from the solvent. - Do 10, i=1,nrState - Do 11, j=1,i - kaunt=kaunt+1 - Do 12, k=1,ici - Vmat(kaunt)=Vmat(kaunt)+Eint(k,1)*Cha(kaunt,k) - Vmat(kaunt)=Vmat(kaunt)+Eint(k,2)*Dip(kaunt,1,k) - Vmat(kaunt)=Vmat(kaunt)+Eint(k,3)*Dip(kaunt,2,k) - Vmat(kaunt)=Vmat(kaunt)+Eint(k,4)*Dip(kaunt,3,k) - Vmat(kaunt)=Vmat(kaunt)+Eint(k,5)*Qua(kaunt,1,k) - Vmat(kaunt)=Vmat(kaunt)+Eint(k,7)*Qua(kaunt,3,k) - Vmat(kaunt)=Vmat(kaunt)+Eint(k,10)*Qua(kaunt,6,k) - Vmat(kaunt)=Vmat(kaunt)+Eint(k,6)*Qua(kaunt,2,k)*2 - Vmat(kaunt)=Vmat(kaunt)+Eint(k,8)*Qua(kaunt,4,k)*2 - Vmat(kaunt)=Vmat(kaunt)+Eint(k,9)*Qua(kaunt,5,k)*2 -12 Continue -11 Continue -10 Continue - - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(iPrint) - End diff -Nru openmolcas-22.02/src/qmstat/helstate.F90 openmolcas-22.10/src/qmstat/helstate.F90 --- openmolcas-22.02/src/qmstat/helstate.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/helstate.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,68 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Anders Ohrn * +!*********************************************************************** +! HelState +! +!> @brief +!> Couple the electrostatic part of the solvent with the QM-region. +!> Only include the static part, no polarization at this moment +!> @author A. Ohrn +!> +!> @note +!> The quadrupoles are put in 'Buckingham-style'. +!> +!> @details +!> Rather easy to follow. This subroutine is a slightly modified +!> copy of ::hel. The interesting quantities are collected in +!> \p Vmat and are later to be added to the 'RASSI-matrix'. +!> +!> @param[in] Eint Field from static part of solvent on the Qm-molecule centers +!> @param[in] nrstate Number of states in RASSI +!> @param[in] ici Number of MME-centers +!> @param[in] Cha Charges +!> @param[in] Dip Dipoles +!> @param[in] Qua Quadrupoles +!> @param[out] Vmat The electrostatic part of the solute-solvent interaction matrix +!*********************************************************************** + +subroutine HelState(Eint,nrstate,ici,Cha,Dip,Qua,Vmat) + +use Index_Functions, only: nTri_Elem +use Constants, only: Zero, Two +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nrstate, ici +real(kind=wp), intent(in) :: Eint(ici,10), Cha(nTri_Elem(nrstate),ici), Dip(nTri_Elem(nrstate),3,ici), Qua(nTri_Elem(nrstate),6,ici) +real(kind=wp), intent(out) :: Vmat(nTri_Elem(nrstate)) +integer(kind=iwp) :: i, j, k, kaunt + +Vmat(:) = Zero + +! The interaction between the distributed multipoles +! and the generalized field from the solvent. +kaunt = 0 +do i=1,nrState + do j=1,i + kaunt = kaunt+1 + do k=1,ici + Vmat(kaunt) = Vmat(kaunt)+Eint(k,1)*Cha(kaunt,k)+ & + Eint(k,2)*Dip(kaunt,1,k)+Eint(k,3)*Dip(kaunt,2,k)+Eint(k,4)*Dip(kaunt,3,k)+ & + Eint(k,5)*Qua(kaunt,1,k)+Eint(k,7)*Qua(kaunt,3,k)+Eint(k,10)*Qua(kaunt,6,k)+ & + Eint(k,6)*Qua(kaunt,2,k)*Two+Eint(k,8)*Qua(kaunt,4,k)*Two+Eint(k,9)*Qua(kaunt,5,k)*Two + end do + end do +end do + +return + +end subroutine HelState diff -Nru openmolcas-22.02/src/qmstat/idubfac.F90 openmolcas-22.10/src/qmstat/idubfac.F90 --- openmolcas-22.02/src/qmstat/idubfac.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/idubfac.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,36 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Anders Ohrn * +!*********************************************************************** + +!----------------------------------------------------------------------* +! A function that will return the double factorial. We do not expect * +! big numbers, so we do it brute-force. Observe that N must be odd, but* +! to skip the if-sentence, we assume that the one who calls this * +! function has seen to that. * +!----------------------------------------------------------------------* +function iDubFac(N) + +use Definitions, only: iwp + +implicit none +integer(kind=iwp) :: iDubFac +integer(kind=iwp), intent(in) :: N +integer(kind=iwp) :: k + +iDubFac = 1 +do k=3,N,2 + iDubFac = iDubFac*k +end do + +return + +end function iDubFac diff -Nru openmolcas-22.02/src/qmstat/integral.fh openmolcas-22.10/src/qmstat/integral.fh --- openmolcas-22.02/src/qmstat/integral.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/integral.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,53 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -********************************************************************** -* iQn - Array that specifies the angular momentum * -* quantum number for each basis function on * -* solvent molecules. * -* iQang - Like iQn, but for QM-region. * -* nPrimus - Actually a rewriting of Icon. * -* mPrimus - Like nPrim but for solvent. * -* iCharOnBasQ - Charge on atom on which the i:th contracted * -* AO-basis is centered in QM-system. * -* iCharOnBasC - Like iCharOnBasQ, but for solvent. * -* iWoGehenQ - The (i:th,j:th) element tells which index the* -* i:th QM-region base (not basis-function) of * -* the j:th m_l-quantum number is to take. * -* Needed when ordering the AO-overlaps. * -* iWoGehenC - Like iWoGehenQ but for solvent molecule. * -* iCon - About contraction, see givemeinfo.f * -* iCon_C - Like iCon, but for solvent. * -* nBonA_Q - Number of basis functions on atoms in QM * -* nBonA_C - Like nBonA_Q but for solvent molecule. * -* CasOri - Array with coordinates for each basis * -* function for solvent molecules. * -* SavOri - Initially like CasOri, but not overwritten. * -* BasOri - Like CasOri, but for QM-region. * -* Alfa - Basis exponents. * -* Beta - Like Alfa but for solvent. * -* Cont - Contraction coefficients for QM-region. * -* Dont - Like Cont but for solvent. * -* V3 - Original solvent MOs. * -* Trans - Cartesian to spherical transformation* -********************************************************************** - Common/IntegralsI/nBA_Q(MxAt),nBA_C(MxAt),nCBoA_Q(MxAt,MxAngqNr) - &,nCBoA_C(MxAt,MxAngqNr),iQang(MxBas) - &,nPrimus(MxBas),iCharOnBasQ(MxBas),iCharOnBasC(MxBasC) - &,iQn(MxBasC),mPrimus(MxBasC) - &,iWoGehenC(MxBB,2*MxAngqNr-1),iWoGehenQ(MxBB,2*MxAngqNr-1) - &,nBonA_Q(MxAt),nBonA_C(3) -* &,iCon(MxAt,MxPrCon),iC_iCon(MxAt,MxPrCon),nBonA_Q(MxAt),nBonA_C(3) - - Common/IntegralsR/Alfa(MxBas,MxCont),Beta(MxBasC,MxCont) - &,Cont(MxBas,MxCont),Dont(MxBasC,MxCont),CasOri(3,MxBasC) - &,BasOri(3,MxBas),SavOri(3,MxBasC),V3(MxBasC,MxOrb_C) - &,Trans(int(dble(3*MxAngqNr**2-2*MxAngqNr-10+8*MxAngqNr**3 - & +3*MxAngqNr**4)/12)) diff -Nru openmolcas-22.02/src/qmstat/isitvalid.f openmolcas-22.10/src/qmstat/isitvalid.f --- openmolcas-22.02/src/qmstat/isitvalid.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/isitvalid.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine IsItValid(Coo,CooRef,ValidOrNot) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" - - Parameter (dTroskel=1d-4) - - Dimension Coo(MxCen,3),CooRef(MxCen,3) - - Logical ValidOrNot - - ValidOrNot=.true. -*-- Lengths. - Do 101, i=1,4 - Do 102, j=i+1,5 - dL_test=0.0d0 - dL_ref=0.0d0 - Do 103, k=1,3 - dL_test=dL_test+(Coo(i,k)-Coo(j,k))**2 - dL_ref=dL_ref+(CooRef(i,k)-CooRef(j,k))**2 -103 Continue - If(abs(dL_test-dL_ref).gt.dTroskel) then - ValidOrNot=.false. - Go To 999 - Endif -102 Continue -101 Continue - -999 Continue - - Return - End diff -Nru openmolcas-22.02/src/qmstat/isitvalid.F90 openmolcas-22.10/src/qmstat/isitvalid.F90 --- openmolcas-22.02/src/qmstat/isitvalid.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/isitvalid.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,38 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine IsItValid(Coo,CooRef,ValidOrNot) + +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(in) :: Coo(3,5), CooRef(3,5) +logical(kind=iwp), intent(out) :: ValidOrNot +integer(kind=iwp) :: i, j +real(kind=wp) :: dL_ref, dL_test +real(kind=wp), parameter :: dTroskel = 1.0e-4_wp + +ValidOrNot = .true. +! Lengths. +outer: do i=1,4 + do j=i+1,5 + dL_test = (Coo(1,i)-Coo(1,j))**2+(Coo(2,i)-Coo(2,j))**2+(Coo(3,i)-Coo(3,j))**2 + dL_ref = (CooRef(1,i)-CooRef(1,j))**2+(CooRef(2,i)-CooRef(2,j))**2+(CooRef(3,i)-CooRef(3,j))**2 + if (abs(dL_test-dL_ref) > dTroskel) then + ValidOrNot = .false. + exit outer + end if + end do +end do outer + +return + +end subroutine IsItValid diff -Nru openmolcas-22.02/src/qmstat/lenin.fh openmolcas-22.10/src/qmstat/lenin.fh --- openmolcas-22.02/src/qmstat/lenin.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/lenin.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -c -c VV: this should not exist, and Molcas.fh must be used instead -c but since qmstat has another definitions of vars declared in Molcas.fh -c this hack is used her. -c - - Parameter(LENIN=6) - Parameter(LENIN8=LENIN+8) diff -Nru openmolcas-22.02/src/qmstat/m2trans.F90 openmolcas-22.10/src/qmstat/m2trans.F90 --- openmolcas-22.02/src/qmstat/m2trans.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/m2trans.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,77 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! Routine to generate the transformation for the second moments. +subroutine M2Trans(Rotte,TD) + +use Definitions, only: wp + +implicit none +real(kind=wp), intent(in) :: Rotte(3,3) +real(kind=wp), intent(out) :: TD(6,6) + +! The transformation of x2. + +TD(1,1) = Rotte(1,1)*Rotte(1,1) +TD(2,1) = Rotte(1,1)*Rotte(2,1) +TD(3,1) = Rotte(1,1)*Rotte(3,1) +TD(4,1) = Rotte(2,1)*Rotte(2,1) +TD(5,1) = Rotte(2,1)*Rotte(3,1) +TD(6,1) = Rotte(3,1)*Rotte(3,1) + +! The transformation of xy. + +TD(1,2) = Rotte(1,1)*Rotte(1,2)+Rotte(1,2)*Rotte(1,1) +TD(2,2) = Rotte(1,1)*Rotte(2,2)+Rotte(1,2)*Rotte(2,1) +TD(3,2) = Rotte(1,1)*Rotte(3,2)+Rotte(1,2)*Rotte(3,1) +TD(4,2) = Rotte(2,1)*Rotte(2,2)+Rotte(2,2)*Rotte(2,1) +TD(5,2) = Rotte(2,1)*Rotte(3,2)+Rotte(2,2)*Rotte(3,1) +TD(6,2) = Rotte(3,1)*Rotte(3,2)+Rotte(3,2)*Rotte(3,1) + +! The transformation of xz. + +TD(1,3) = Rotte(1,1)*Rotte(1,3)+Rotte(1,3)*Rotte(1,1) +TD(2,3) = Rotte(1,1)*Rotte(2,3)+Rotte(1,3)*Rotte(2,1) +TD(3,3) = Rotte(1,1)*Rotte(3,3)+Rotte(1,3)*Rotte(3,1) +TD(4,3) = Rotte(2,1)*Rotte(2,3)+Rotte(2,3)*Rotte(2,1) +TD(5,3) = Rotte(2,1)*Rotte(3,3)+Rotte(2,3)*Rotte(3,1) +TD(6,3) = Rotte(3,1)*Rotte(3,3)+Rotte(3,3)*Rotte(3,1) + +! The transformation of y2. + +TD(1,4) = Rotte(1,2)*Rotte(1,2) +TD(2,4) = Rotte(1,2)*Rotte(2,2) +TD(3,4) = Rotte(1,2)*Rotte(3,2) +TD(4,4) = Rotte(2,2)*Rotte(2,2) +TD(5,4) = Rotte(2,2)*Rotte(3,2) +TD(6,4) = Rotte(3,2)*Rotte(3,2) + +! The transformation of yz. + +TD(1,5) = Rotte(1,2)*Rotte(1,3)+Rotte(1,3)*Rotte(1,2) +TD(2,5) = Rotte(1,2)*Rotte(2,3)+Rotte(1,3)*Rotte(2,2) +TD(3,5) = Rotte(1,2)*Rotte(3,3)+Rotte(1,3)*Rotte(3,2) +TD(4,5) = Rotte(2,2)*Rotte(2,3)+Rotte(2,3)*Rotte(2,2) +TD(5,5) = Rotte(2,2)*Rotte(3,3)+Rotte(2,3)*Rotte(3,2) +TD(6,5) = Rotte(3,2)*Rotte(3,3)+Rotte(3,3)*Rotte(3,2) + +! The transformation of z2. + +TD(1,6) = Rotte(1,3)*Rotte(1,3) +TD(2,6) = Rotte(1,3)*Rotte(2,3) +TD(3,6) = Rotte(1,3)*Rotte(3,3) +TD(4,6) = Rotte(2,3)*Rotte(2,3) +TD(5,6) = Rotte(2,3)*Rotte(3,3) +TD(6,6) = Rotte(3,3)*Rotte(3,3) + +return + +end subroutine M2Trans diff -Nru openmolcas-22.02/src/qmstat/main.f openmolcas-22.10/src/qmstat/main.f --- openmolcas-22.02/src/qmstat/main.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/main.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - program main -#ifdef _FPE_TRAP_ - Use, Intrinsic :: IEEE_Exceptions -#endif - implicit Real*8 (a-h,o-z) - Character*20 Module_Name - Parameter (Module_Name = 'qmstat') -#ifdef _FPE_TRAP_ - Call IEEE_Set_Halting_Mode(IEEE_Usual,.True._4) -#endif - - Call Start(Module_Name) - Call qmstat(ireturn) - Call Finish(ireturn) - end diff -Nru openmolcas-22.02/src/qmstat/main.F90 openmolcas-22.10/src/qmstat/main.F90 --- openmolcas-22.02/src/qmstat/main.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/main.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,31 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +program Main + +#ifdef _FPE_TRAP_ +use, intrinsic :: IEEE_Exceptions, only: IEEE_Set_Halting_Mode, IEEE_Usual +use Definitions, only: DefInt +#endif +use Definitions, only: iwp + +implicit none +integer(kind=iwp) :: rc + +#ifdef _FPE_TRAP_ +call IEEE_Set_Halting_Mode(IEEE_Usual,.true._DefInt) +#endif + +call Start('qmstat') +call qmstat(rc) +call Finish(rc) + +end program Main diff -Nru openmolcas-22.02/src/qmstat/mandatoryinp.f openmolcas-22.10/src/qmstat/mandatoryinp.f --- openmolcas-22.02/src/qmstat/mandatoryinp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/mandatoryinp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,76 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine MandatoryInp(YesNo) - Implicit Real*8 (a-h,o-z) - -#include "warnings.h" - - Logical YesNo(20) - - If(.not.YesNo(8).and..not.YesNo(7)) then - Write(6,*) - Write(6,*)' You have not specified what type of calculation' - &//' this is.' - Write(6,*)' Use either the RUN keyword or the SINGle-point' - &//' keyword.' - Call Quit(_RC_INPUT_ERROR_) - Endif - - If(YesNo(3).and.YesNo(4)) then - Write(6,*) - Write(6,*)' You have specified both a SCFSection and a' - &//' RASSisection.' - Write(6,*)' They are mutually exclusive. Remove one.' - Call Quit(_RC_INPUT_ERROR_) - Endif - - If(YesNo(7).and..not.YesNo(6)) then - Write(6,*) - Write(6,*)' You have requested a single-point calculation, but' - &//' no input coordinates were given.' - Write(6,*)' Provide these in the SOLVent section.' - Call Quit(_RC_INPUT_ERROR_) - Endif - - If(YesNo(5).and..not.YesNo(6)) then - Write(6,*) - Write(6,*)' You have specified that initial coordinates are to' - &//' be given in input, but no coordinates are found.' - Write(6,*)' Provide these in the SOLVent section.' - Call Quit(_RC_INPUT_ERROR_) - Endif - - If(.not.YesNo(2).and..not.YesNo(7)) then - Write(6,*) - Write(6,*)' You fail to specify where from initial' - &//' configuration should be collected.' - Write(6,*)' Do this with the CONFiguration keyword.' - Call Quit(_RC_INPUT_ERROR_) - Endif - - If(YesNo(9).and..not.YesNo(10)) then - Write(6,*) - Write(6,*)' Your file specification implies that an' - &//' extraction file is to be generated.' - Write(6,*)' However, you have no EXTRact section.' - Call Quit(_RC_INPUT_ERROR_) - Endif - - If(.not.YesNo(9).and.YesNo(10)) then - Write(6,*) - Write(6,*)' You have a EXTRact section, but the file to' - &//' read from is not a sampfile.' - Write(6,*)' Change this after the FILE keyword.' - Call Quit(_RC_INPUT_ERROR_) - Endif - - Return - End diff -Nru openmolcas-22.02/src/qmstat/mandatoryinp.F90 openmolcas-22.10/src/qmstat/mandatoryinp.F90 --- openmolcas-22.02/src/qmstat/mandatoryinp.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/mandatoryinp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,71 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine MandatoryInp(YesNo) + +use Definitions, only: iwp, u6 + +implicit none +logical(kind=iwp), intent(in) :: YesNo(*) +#include "warnings.h" + +if ((.not. YesNo(8)) .and. (.not. YesNo(7))) then + write(u6,*) + write(u6,*) ' You have not specified what type of calculation this is.' + write(u6,*) ' Use either the RUN keyword or the SINGle-point keyword.' + call Quit(_RC_INPUT_ERROR_) +end if + +if (YesNo(3) .and. YesNo(4)) then + write(u6,*) + write(u6,*) ' You have specified both a SCFSection and a RASSisection.' + write(u6,*) ' They are mutually exclusive. Remove one.' + call Quit(_RC_INPUT_ERROR_) +end if + +if (YesNo(7) .and. (.not. YesNo(6))) then + write(u6,*) + write(u6,*) ' You have requested a single-point calculation, but no input coordinates were given.' + write(u6,*) ' Provide these in the SOLVent section.' + call Quit(_RC_INPUT_ERROR_) +end if + +if (YesNo(5) .and. (.not. YesNo(6))) then + write(u6,*) + write(u6,*) ' You have specified that initial coordinates are to be given in input, but no coordinates are found.' + write(u6,*) ' Provide these in the SOLVent section.' + call Quit(_RC_INPUT_ERROR_) +end if + +if ((.not. YesNo(2)) .and. (.not. YesNo(7))) then + write(u6,*) + write(u6,*) ' You fail to specify where from initial configuration should be collected.' + write(u6,*) ' Do this with the CONFiguration keyword.' + call Quit(_RC_INPUT_ERROR_) +end if + +if (YesNo(9) .and. (.not. YesNo(10))) then + write(u6,*) + write(u6,*) ' Your file specification implies that an extraction file is to be generated.' + write(u6,*) ' However, you have no EXTRact section.' + call Quit(_RC_INPUT_ERROR_) +end if + +if ((.not. YesNo(9)) .and. YesNo(10)) then + write(u6,*) + write(u6,*) ' You have a EXTRact section, but the file to read from is not a sampfile.' + write(u6,*) ' Change this after the FILE keyword.' + call Quit(_RC_INPUT_ERROR_) +end if + +return + +end subroutine MandatoryInp diff -Nru openmolcas-22.02/src/qmstat/maxi.fh openmolcas-22.10/src/qmstat/maxi.fh --- openmolcas-22.02/src/qmstat/maxi.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/maxi.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,62 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -*------------------------------------------------------ -* Define some bounds for qmstat. -*------------------------------------------------------ -* MxCha - Maximal number of charges on water -* MxPol - Maximal number of polarizabilities on water -* MxAt - Maximal number of atoms on QM -* MxCen - Maximal number of center on water -* MxMltp - Highest order multipole in MME -* MxComp - Maximal number of components for the multipoles -* MxBas - Maximal number of bases -* MxSym - Maximal number of symmetries -* MxOrb - Maximal number of orbitals, used with motra. -* MxOT - Maximal number of triangular orbital overlap. -* MxOrb_C - Maximal number of orbitals for solvent. -* MxPut - Maximal number of molecules to put in system -* MxQCen - Maximal number of centers in QM-molecule -* Mum - Maximal number of coordinates for the solvent -* polarizabilities of one component. -* MxBasC - Maximal number of basis functions for classical part. -* MxCont - Maximal number of bases of any angular type that is -* being contracted. 12s8p5d would need at least MxCont=12. -* MxAngqNr - Maximal angular quantum number for basis functions -* in QM-region. 1 is s, 2 is p etc. -* MxPrCon - Maximal sum of the contracted number of bases. 12s8p5d -* would need at least 12+8+5=25. -* MxBB - Maximal number of bases (not basis-functions!) -* MxParT - Maximal number of parallel temperature ensembles. -* MxExtAddOn - Maximal number of external perturbations. -* MxSlFactQ - Maximal number of Slater Prefactors for one site in -* QM-system -*--RASSI things -* MxState - Maximal number of states. -* MxStOT - Maximal number of unique pairs of states. -* MxJobs - Maximal number of jobs. -*----------------------------------------------------------- - Integer MxCha,MxPol,MxAt,MxCen - Integer MxMltp,MxComp,MxBas,MxSym,MxOrb,Mum - Integer MxPut,MxQCen,MxOT,MxBB,MxAngqNr - Integer MxBasC,MxPrCon,MxCont,MxState,MxStOT - Integer MxJobs,MxParT,MxExtAddOn - Parameter(MxCha=4,MxPol=3,MxAt=18,MxCen=5,MxMltp=3) - Parameter(MxComp=MxMltp*(MxMltp+1)/2,MxBas=350,MxSym=1) - Parameter(MxOrb=100,MxOT=MxOrb*(MxOrb+1)/2,MxOrb_C=10,MxPut=220) - Parameter(MxQCen=MxAt*(MxAt+1)/2,Mum=MxPut*MxPol,MxBasC=50) - Parameter(MxCont=20,MxAngqNr=7,MxPrCon=MxCont*MxAngqNr) - Parameter(MxBB=MxCont*MxAngqNr*MxAt,MxParT=4,MxExtAddOn=3) -*Jose. Slater -* Parameter(MxSlFactQ=(MxMltp*(MxMltp**2+6*MxMltp+11)+6)/6) -*Observe! MxState must be the same as MXSTAT in cntrl.fh in src/rassi -* (but there's no such variable) - Parameter(MxState=200,MxStOT=MxState*(MxState+1)/2) - Parameter(MxJobs=40) diff -Nru openmolcas-22.02/src/qmstat/mbpt2corr.f openmolcas-22.10/src/qmstat/mbpt2corr.f --- openmolcas-22.02/src/qmstat/mbpt2corr.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/mbpt2corr.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,130 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -* -* Not properly worked through. Do not use! -* - Subroutine Mbpt2Corr(nBas,Cmo) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "numbers.fh" -#include "qm1.fh" -#include "qminp.fh" -#include "WrkSpc.fh" -#include "stdalloc.fh" -#include "warnings.h" - Real*8, Allocatable:: Diff(:) - Dimension Cmo(MxBas**2) - - Write(6,*) - Write(6,*)'MP2 density correction is requested.' - Write(6,*)' -- perturbative correlation correction to the solute ' - &//'density.' -* -*-- No-no zone! -* - Write(6,*) - Write(6,*)'THIS OPTION IS NOT PROPERLY WORKED THROUGH! SHOULD NOT' - &//' BE USED!' - Call Quit(_RC_GENERAL_ERROR_) -*--- Check that the density difference is sound. - iT=nBas*(nBas+1)/2 - Call mma_allocate(Diff,iT,Label='Diff') - Call Get_D1ao(Diff,iT) - If(iPrint.ge.10) then - Call TriPrt('Non-reduced difference density matrix',' ' - & ,Diff,nBas) - Endif -*--- Transform density difference to orbital basis. - Call GetMem('SqDenA','Allo','Real',ipSqD,nBas**2) - Call GetMem('SqDenM','Allo','Real',ipSqE,nBas**2) - Call GetMem('TEMP','Allo','Real',ipTEMP,nBas**2) - Call GetMem('Inv','Allo','Real',iI,nBas**2) - Call GetMem('RedSq','Allo','Real',iRedSq,nBas**2) - call dcopy_(nBas**2,[ZERO],iZERO,Work(ipSqD),iONE) - call dcopy_(iOrb(1)**2,[ZERO],iZERO,Work(ipSqE),iONE) - call dcopy_(nBas*iOrb(1),[ZERO],iZERO,Work(ipTEMP),iONE) -*--- Do not forget the density matrix convention in Molcas. - Call Dsq(Diff,Work(ipSqD),iONE,nBas,nBas) -*--- Inverse of orbital file and transformation. - Call Minv(Cmo,Work(iI),Ising,Det,nBas) - Call Dgemm_('N','N',nBas,nBas,nBas,ONE,Work(iI),nBas,Work(ipSqD) - & ,nBas,ZERO,Work(ipTEMP),nBas) - Call Dgemm_('N','T',nBas,nBas,nBas,ONE,Work(ipTEMP),nBas,Work(iI) - & ,nBas,ZERO,Work(ipSqE),nBas) -*--- Remove all except the suck-out orbitals. - kaunt1=0 - Do i=1,nBas - Do j=1,nBas - If(i.le.iOrb(1).and.j.le.iOrb(1)) then - Work(iRedSq+kaunt1)=Work(ipSqE+kaunt1) - Else - Work(iRedSq+kaunt1)=0.0d0 - Endif - kaunt1=kaunt1+1 - Enddo - Enddo -*--- Make a check of the trace. Should be small. - kaunter=0 - Trace_MP2=0 - Do 108, iB1=1,nBas - do jjj=1,nBas - If(iB1.eq.jjj)Trace_MP2=Trace_MP2+Work(iRedSq+kaunter) - kaunter=kaunter+1 - enddo -108 Continue - If(iPrint.ge.10) then - Write(6,*)'Trace: ',Trace_MP2 - Endif -*--- Make things a bit more tidy. - kaunt1=0 - kaunt2=0 - Do i=1,iOrb(1) - Do j=1,nBas - If(j.le.iOrb(1)) then - Work(ipSqE+kaunt1)=Work(iRedSq+kaunt2) - kaunt1=kaunt1+1 - Endif - kaunt2=kaunt2+1 - Enddo - Enddo - Call SqToTri_q(Work(ipSqE),DenCorrD,iOrb(1)) - -*--- Transform back if we want to keep things in AO-basis. Not -* used in QMSTAT at the present. If you wish, comment away the -* code below 'make things a bit more tidy' and you are in -* ready to rumble. -* Call Dgemm_('N','N',nBas,nBas,nBas,ONE,Cmo,nBas -* & ,Work(iRedSq),nBas,ZERO,Work(ipTEMP),nBas) -* Call Dgemm_('N','T',nBas,nBas,nBas,ONE,Work(ipTEMP),nBas -* & ,Cmo,nBas,ZERO,Work(ipSqE),nBas) -* k=0 -* Do i=1,nBas -* Do j=1,nBas -* If(i.ne.j)Work(ipSqE+k)=Work(ipSqE+k)*2 -* k=k+1 -* Enddo -* Enddo -* Call SqToTri_q(Work(ipSqE),Work(ipTrDiffD),nBas) -* If(iPrint.ge.10) then -* Call TriPrt('Reduced difference density matrix',' ' -* & ,Work(ipTrDiffD),nBas) -* Endif - - Call mma_deallocate(Diff) - Call GetMem('SqDenA','Free','Real',ipSqD,nBas**2) - Call GetMem('SqDenM','Free','Real',ipSqE,nBas**2) - Call GetMem('TEMP','Free','Real',ipTEMP,nBas**2) - Call GetMem('Inv','Free','Real',iI,nBas**2) - Call GetMem('RedSq','Free','Real',iRedSq,nBas**2) - - Return - End diff -Nru openmolcas-22.02/src/qmstat/mbpt2corr.F90 openmolcas-22.10/src/qmstat/mbpt2corr.F90 --- openmolcas-22.02/src/qmstat/mbpt2corr.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/mbpt2corr.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,107 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! Not properly worked through. Do not use! +subroutine Mbpt2Corr(nBas,Cmo) + +use qmstat_global, only: DenCorrD, iOrb, iPrint, Trace_MP2 +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nBas +real(kind=wp), intent(in) :: Cmo(nBas,nBas) +integer(kind=iwp) :: i, iB1, Ising, iT, j, kaunt1 +real(kind=wp) :: Det +real(kind=wp), allocatable :: Diff(:), Inv(:,:), RedSq(:,:), SqD(:,:), SqE(:), TEMP(:,:) +#include "warnings.h" + +write(u6,*) +write(u6,*) 'MP2 density correction is requested.' +write(u6,*) ' -- perturbative correlation correction to the solute density.' + +! No-no zone! + +write(u6,*) +write(u6,*) 'THIS OPTION IS NOT PROPERLY WORKED THROUGH! SHOULD NOT BE USED!' +call Quit(_RC_GENERAL_ERROR_) +! Check that the density difference is sound. +iT = nTri_Elem(nBas) +call mma_allocate(Diff,iT,Label='Diff') +call Get_D1ao(Diff,iT) +if (iPrint >= 10) call TriPrt('Non-reduced difference density matrix',' ',Diff,nBas) +! Transform density difference to orbital basis. +call mma_allocate(SqD,nBas,nBas,label='SqDenA') +call mma_allocate(SqE,nBas**2,label='SqDenM') +call mma_allocate(TEMP,nBas,nBas,label='TEMP') +call mma_allocate(Inv,nBas,nBas,label='Inv') +call mma_allocate(RedSq,nBas,nBas,label='RedSq') +! Do not forget the density matrix convention in Molcas. +call Dsq(Diff,SqD,1,nBas,nBas) +! Inverse of orbital file and transformation. +call Minv(Cmo,Inv,Ising,Det,nBas) +call Dgemm_('N','N',nBas,nBas,nBas,One,Inv,nBas,SqD,nBas,Zero,TEMP,nBas) +call Dgemm_('N','T',nBas,nBas,nBas,One,TEMP,nBas,Inv,nBas,Zero,SqE,nBas) +! Remove all except the suck-out orbitals. +do i=1,nBas + do j=1,nBas + if ((i <= iOrb(1)) .and. (j <= iOrb(1))) then + RedSq(j,i) = SqE(j+(i-1)*nBas) + else + RedSq(j,i) = Zero + end if + end do +end do +! Make a check of the trace. Should be small. +Trace_MP2 = Zero +do iB1=1,nBas + Trace_MP2 = Trace_MP2+RedSq(iB1,iB1) +end do +if (iPrint >= 10) then + write(u6,*) 'Trace: ',Trace_MP2 +end if +! Make things a bit more tidy. +kaunt1 = 0 +do i=1,iOrb(1) + do j=1,iOrb(1) + kaunt1 = kaunt1+1 + SqE(kaunt1) = RedSq(j,i) + end do +end do +call mma_allocate(DenCorrD,nTri_Elem(iOrb(1)),label='DenCorrD') +call SqToTri_q(SqE,DenCorrD,iOrb(1)) + +! Transform back if we want to keep things in AO-basis. Not +! used in QMSTAT at the present. If you wish, comment away the +! code below 'make things a bit more tidy' and you are in +! ready to rumble. +!call Dgemm_('N','N',nBas,nBas,nBas,One,Cmo,nBas,RedSq,nBas,Zero,TEMP,nBas) +!call Dgemm_('N','T',nBas,nBas,nBas,One,TEMP,nBas,Cmo,nBas,Zero,SqE,nBas) +!do i=1,nBas +! do j=1,nBas +! if (i /= j) SqE(j+(i-1)*nBas) = SqE(j+(i-1)*nBas)*Two +! end do +!end do +!call SqToTri_q(SqE,TrDiffD,nBas) +!if (iPrint >= 10) call TriPrt('Reduced difference density matrix',' ',TrDiffD,nBas) + +call mma_deallocate(Diff) +call mma_deallocate(SqD) +call mma_deallocate(SqE) +call mma_deallocate(TEMP) +call mma_deallocate(Inv) +call mma_deallocate(RedSq) + +return + +end subroutine Mbpt2Corr diff -Nru openmolcas-22.02/src/qmstat/memory_polprep.f openmolcas-22.10/src/qmstat/memory_polprep.f --- openmolcas-22.02/src/qmstat/memory_polprep.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/memory_polprep.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Memory_PolPrep(Que,ixx,iyy,izz,irr3,ixxi,iyyi - & ,izzi,iGri,nPol,nPart) - Implicit Real*8 (a-h,o-z) - -#include "numbers.fh" -#include "WrkSpc.fh" - - Character*(*) Que - - nSize=nPart*nPol - Call GetMem('xx',Que,'Real',ixx,nSize**2) - Call GetMem('yy',Que,'Real',iyy,nSize**2) - Call GetMem('zz',Que,'Real',izz,nSize**2) - Call GetMem('ixx',Que,'Real',ixxi,nSize**2) - Call GetMem('iyy',Que,'Real',iyyi,nSize**2) - Call GetMem('izz',Que,'Real',izzi,nSize**2) - Call GetMem('irr3',Que,'Real',irr3,nSize**2) - Call GetMem('iGri',Que,'Real',iGri,nSize**2) - - If(Que(1:4).eq.'Allo') then - call dcopy_(nSize**2,[ZERO],iZERO,Work(ixx),iONE) - call dcopy_(nSize**2,[ZERO],iZERO,Work(iyy),iONE) - call dcopy_(nSize**2,[ZERO],iZERO,Work(izz),iONE) - call dcopy_(nSize**2,[ZERO],iZERO,Work(ixxi),iONE) - call dcopy_(nSize**2,[ZERO],iZERO,Work(iyyi),iONE) - call dcopy_(nSize**2,[ZERO],iZERO,Work(izzi),iONE) - call dcopy_(nSize**2,[ZERO],iZERO,Work(irr3),iONE) - call dcopy_(nSize**2,[ZERO],iZERO,Work(iGri),iONE) - Endif - - Return - End diff -Nru openmolcas-22.02/src/qmstat/mmetormo.f openmolcas-22.10/src/qmstat/mmetormo.f --- openmolcas-22.02/src/qmstat/mmetormo.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/mmetormo.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine MMEtoRMO(nAObas,nMObas,ipAvRed,iMME) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "numbers.fh" -#include "WrkSpc.fh" - - Dimension iMME(MxMltp*(MxMltp+1)*(MxMltp+2)/6) - -* -*--- First all multipoles are transformed to MO-basis... -* - Call GetMem('Squared','Allo','Real',iSq,nAObas**2) - Call GetMem('TEMP','Allo','Real',iTEMP,nAObas*nMObas) - Call GetMem('Final','Allo','Real',iMmeMO,nMObas**2) - nUniqueM=1+3+6 - Do 11, iMlt=1,nUniqueM - Call Square(Work(iMME(iMlt)),Work(iSq),iONE,nAObas,nAObas) - Call Dgemm_('T','N',nMObas,nAObas,nAObas,ONE,Work(ipAvRed) - & ,nAObas,Work(iSq),nAObas,ZERO,Work(iTEMP),nMObas) - Call Dgemm_('N','N',nMObas,nMObas,nAObas,ONE,Work(iTEMP) - & ,nMObas,Work(ipAvRed),nAObas,ZERO,Work(iMmeMO),nMObas) - Call SqToTri_Q(Work(iMmeMO),Work(iMME(iMlt)),nMObas) -11 Continue - Call GetMem('Squared','Free','Real',iSq,nAObas**2) - Call GetMem('TEMP','Free','Real',iTEMP,nAObas*nMObas) - Call GetMem('Final','Free','Real',iMmeMO,nMObas**2) - - Return - End diff -Nru openmolcas-22.02/src/qmstat/moldendump.f openmolcas-22.10/src/qmstat/moldendump.f --- openmolcas-22.02/src/qmstat/moldendump.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/moldendump.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,76 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine MoldenDump(iC,CooRef,nP,nA,nC) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "WrkSpc.fh" -#include "constants.fh" -#include "real.fh" - - Parameter (AuAng=1d10*CONST_BOHR_RADIUS_IN_SI_) - - Dimension CooRef(MxCen,3),Coo(MxCen,3) - Dimension iC(3) - - Logical ValidOrNot - -* -*-- Clarifying words. -* - Write(6,*) - Write(6,*) - Write(6,*)' * Coordinates given in form for Molden *' - Write(6,*) - Write(6,*)' Put everything within the lines in a separate file' - &//' and view with Molden.' - Write(6,*)' Observe that the identity of molecules that are not' - &//' valid water molecules is unknown.' - Write(6,*) - Write(6,*)'------------------------------------------------------' - &//'------------------------------' - -* -*-- Print total number of particles. -* - Write(6,*)' Substitue this line with number of atoms.' - Write(6,*) - Do 101, iP=1,nP - ind=nC*(iP-1) - Do 102, jC=1,nC - Coo(jC,1)=Work(iC(1)+ind+jC-1) - Coo(jC,2)=Work(iC(2)+ind+jC-1) - Coo(jC,3)=Work(iC(3)+ind+jC-1) -102 Continue - Call IsItValid(Coo,CooRef,ValidOrNot) - If(.not.ValidOrNot) then - Do 103, jC=1,nC - Write(6,92)'C ',(AuAng*Coo(jC,kk),kk=1,3) -103 Continue - Else - Write(6,92)'O ',(AuAng*Coo(1,kk),kk=1,3) - Write(6,92)'H ',(AuAng*Coo(2,kk),kk=1,3) - Write(6,92)'H ',(AuAng*Coo(3,kk),kk=1,3) - Endif -101 Continue - Write(6,*) - Write(6,*)'------------------------------------------------------' - &//'------------------------------' - -* -*-- Formats -* -92 Format(A,3(F10.6)) - - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(nA) - End diff -Nru openmolcas-22.02/src/qmstat/moldendump.F90 openmolcas-22.10/src/qmstat/moldendump.F90 --- openmolcas-22.02/src/qmstat/moldendump.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/moldendump.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,65 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine MoldenDump(C,CooRef,nP,nC) + +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Angstrom +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nP, nC +real(kind=wp), intent(in) :: C(nP*nC,3), CooRef(3,5) +integer(kind=iwp) :: ind, iP, jC +logical(kind=iwp) :: ValidOrNot +real(kind=wp), allocatable :: Coo(:,:) + +! Clarifying words. + +write(u6,*) +write(u6,*) +write(u6,*) ' * Coordinates given in form for Molden *' +write(u6,*) +write(u6,*) ' Put everything within the lines in a separate file and view with Molden.' +write(u6,*) ' Observe that the identity of molecules that are not valid water molecules is unknown.' +write(u6,*) +write(u6,*) '------------------------------------------------------------------------------------' + +! Print total number of particles. + +call mma_allocate(Coo,3,nC,label='Coo') +write(u6,*) ' Substitute this line with number of atoms.' +write(u6,*) +do iP=1,nP + ind = nC*(iP-1) + do jC=1,nC + Coo(:,jC) = C(ind+jC,:) + end do + call IsItValid(Coo,CooRef,ValidOrNot) + if (.not. ValidOrNot) then + do jC=1,nC + write(u6,92) 'C ',Angstrom*Coo(:,jC) + end do + else + write(u6,92) 'O ',Angstrom*Coo(:,1) + write(u6,92) 'H ',Angstrom*Coo(:,2) + write(u6,92) 'H ',Angstrom*Coo(:,3) + end if +end do +write(u6,*) +write(u6,*) '------------------------------------------------------------------------------------' +call mma_deallocate(Coo) + +return + +92 format(A,3(F10.6)) + +end subroutine MoldenDump diff -Nru openmolcas-22.02/src/qmstat/momentmod.F90 openmolcas-22.10/src/qmstat/momentmod.F90 --- openmolcas-22.02/src/qmstat/momentmod.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/momentmod.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,114 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine MomentMod(Re,NRe,Cmo,nBRe,nBNRe,LindMOs,iS1,iS2,First,DiffMax) + +use qmstat_global, only: iPrint +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6, r8 + +implicit none +integer(kind=iwp), intent(in) :: nBRe, nBNRe, iS1, iS2 +real(kind=wp), intent(in) :: Re(nTri_Elem(nBRe)), NRe(nBNRe,nBNRe), Cmo(nBNRe,nBNRe) +logical(kind=iwp), intent(in) :: LindMOs(nBNRe) +logical(kind=iwp), intent(inout) :: First +real(kind=wp), intent(out) :: DiffMax +integer(kind=iwp) :: i, icomp, iopt, irc, iSmLbl, j, kaunt1, nSize1, nSize2 +real(kind=wp) :: Diffx, Diffy, Diffz, DipRe(3), DipNRe(3) +real(kind=wp), allocatable :: D(:), Dsq(:,:), DxM(:,:), DxRe(:), DyM(:,:), DyRe(:), DzM(:,:), DzRe(:), TEMP(:,:) +real(kind=r8), external :: Ddot_ + +if (First .and. (iPrint >= 5)) then + write(u6,*) + write(u6,*) ' Modifications of dipoles by renormalization and basis reduction.' + write(u6,*) + write(u6,*) ' State pair | Difference ' + write(u6,*) ' --------------|---------------------' + First = .false. +end if + +nSize1 = nTri_Elem(nBNRe) +nSize2 = nTri_Elem(nBRe) +call mma_allocate(D,nSize1,label='Dip') +call mma_allocate(DxRe,nSize2,label='DipXre') +call mma_allocate(DyRe,nSize2,label='DipYre') +call mma_allocate(DzRe,nSize2,label='DipZre') +call mma_allocate(Dsq,nBNRe,nBNre,label='Dipsq') +call mma_allocate(DxM,nBNRe,nBNRe,label='DipXm') +call mma_allocate(DyM,nBNRe,nBNRe,label='DipYm') +call mma_allocate(DzM,nBNRe,nBNRe,label='DipZm') +call mma_allocate(TEMP,nBNRe,nBNRe,label='TEMP') +irc = -1 +iopt = 6 +iSmLbl = 0 +! X +icomp = 1 +call RdOne(irc,iopt,'Mltpl 1',icomp,D,iSmLbl) +call Square(D,Dsq,1,nBNRe,nBNRe) +call Dgemm_('T','N',nBNRe,nBNRe,nBNRe,One,Cmo,nBNRe,Dsq,nBNRe,Zero,TEMP,nBNRe) +call Dgemm_('N','N',nBNRe,nBNRe,nBNRe,One,TEMP,nBNRe,Cmo,nBNRe,Zero,DxM,nBNRe) +! Y +icomp = 2 +call RdOne(irc,iopt,'Mltpl 1',icomp,D,iSmLbl) +call Square(D,Dsq,1,nBNRe,nBNRe) +call Dgemm_('T','N',nBNRe,nBNRe,nBNRe,One,Cmo,nBNRe,Dsq,nBNRe,Zero,TEMP,nBNRe) +call Dgemm_('N','N',nBNRe,nBNRe,nBNRe,One,TEMP,nBNRe,Cmo,nBNRe,Zero,DyM,nBNRe) +! Z +icomp = 3 +call RdOne(irc,iopt,'Mltpl 1',icomp,D,iSmLbl) +call Square(D,Dsq,1,nBNRe,nBNRe) +call Dgemm_('T','N',nBNRe,nBNRe,nBNRe,One,Cmo,nBNRe,Dsq,nBNRe,Zero,TEMP,nBNRe) +call Dgemm_('N','N',nBNRe,nBNRe,nBNRe,One,TEMP,nBNRe,Cmo,nBNRe,Zero,DzM,nBNRe) +! Triangularize and reduce. +kaunt1 = 0 +do i=1,nBNRe + if (.not. LindMOs(i)) cycle + do j=1,i + if (.not. LindMOs(j)) cycle + kaunt1 = kaunt1+1 + DxRe(kaunt1) = DxM(j,i) + DyRe(kaunt1) = DyM(j,i) + DzRe(kaunt1) = DzM(j,i) + end do +end do +! Density +DipNRe(1) = Ddot_(nBNRe**2,DxM,1,NRe,1) +DipNRe(2) = Ddot_(nBNRe**2,DyM,1,NRe,1) +DipNRe(3) = Ddot_(nBNRe**2,DzM,1,NRe,1) +DipRe(1) = Ddot_(nSize2,DxRe,1,Re,1) +DipRe(2) = Ddot_(nSize2,DyRe,1,Re,1) +DipRe(3) = Ddot_(nSize2,DzRe,1,Re,1) +Diffx = abs(DipRe(1)-DipNRe(1)) +Diffy = abs(DipRe(2)-DipNRe(2)) +Diffz = abs(DipRe(3)-DipNRe(3)) +if (iPrint >= 5) write(u6,99) iS1,iS2,'(',Diffx,',',Diffy,',',Diffz,')' +! Return number +DiffMax = Diffy +if (Diffx >= Diffy) DiffMax = Diffx +if ((Diffz >= Diffx) .and. (Diffz >= Diffy)) DiffMax = Diffz +! Deallocate en masse. +call mma_deallocate(D) +call mma_deallocate(DxRe) +call mma_deallocate(DyRe) +call mma_deallocate(DzRe) +call mma_deallocate(Dsq) +call mma_deallocate(DxM) +call mma_deallocate(DyM) +call mma_deallocate(DzM) +call mma_deallocate(TEMP) + +return + +99 format(' ',2I3,' ',3(A,F10.7),A) + +end subroutine MomentMod diff -Nru openmolcas-22.02/src/qmstat/moreduce.f openmolcas-22.10/src/qmstat/moreduce.f --- openmolcas-22.02/src/qmstat/moreduce.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/moreduce.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,514 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine MoReduce(nBas,MOsToKeep,ipAvRedMO) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "files_qmstat.fh" -#include "qminp.fh" -#include "qm2.fh" -#include "numbers.fh" -#include "WrkSpc.fh" -#include "lenin.fh" - - Parameter (ReduceWarning=0.5d0) - - Dimension nBas(MxSym),iTocBig(MxStOT) - - Character Header*50,BsLbl*1 - - Dimension BsLbl(LENIN8*MxBas) - - Logical LindMOs(MxBas),First - - Data First /.true./ - - Dimension Dummy(1) - -* -*--- A word of welcome. -* - Write(6,*)' ----- Transform to average natural MO-reduced' - &//' basis.' -* -*--- First we accumulate the different density matrices. -* - nSize=nBas(1)*(nBas(1)+1)/2 - weight=ONE/dble(nState) - Call GetMem('DenM','Allo','Real',iDin,nSize) - Call GetMem('DenA','Allo','Real',iDav,nSize) - call dcopy_(nSize,[ZERO],iZERO,Work(iDav),iONE) - Do 201, iS1=1,nState - Do 202, iS2=1,iS1 - index=(iS1*(iS1-1)/2+iS2-1)*nSize - call dcopy_(nSize,Work(iBigT+index),iONE,Work(iDin),iONE) - If(iS1.ne.iS2) GoTo 202 - kaunt=0 - Do 203, iB1=1,nBas(1) - Do 204, iB2=1,iB1 - If(iB1.eq.iB2) then - Fac=1.0d0*weight - Else - Fac=0.5d0*weight - Endif - Work(iDav+kaunt)=Work(iDav+kaunt)+Work(iDin+kaunt)*Fac - kaunt=kaunt+1 -204 Continue -203 Continue -202 Continue -201 Continue -* -*--- Then since we are working in the non-orthogonal AO-basis, -* it is necessary to orthogonalize before we diagonalize -* accumulated density. -* - Call GetMem('Vecs','Allo','Real',iVecs,nBas(1)**2) - Call GetMem('Vecs2','Allo','Real',iVecs2,nBas(1)**2) - Call GetMem('AuxS','Allo','Real',iAUX,nBas(1)**2) - Call GetMem('OvlSs','Allo','Real',iSs,nBas(1)**2) - Call GetMem('OvlSs','Allo','Real',iSx,nSize) - Call GetMem('OvlSi','Allo','Real',iSst,nBas(1)**2) - Call GetMem('OvlSi','Allo','Real',iSt,nSize) - Call GetMem('DavSq','Allo','Real',iDavS,nBas(1)**2) - Call GetMem('Trans','Allo','Real',iTrans,nBas(1)**2) - Call GetMem('Trans','Allo','Real',iTransB,nBas(1)**2) - Call GetMem('OrtoAvDen','Allo','Real',iOtD,nBas(1)**2) - Call GetMem('OrtoAcDeT','Allo','Real',iOtDt,nSize) - Call GetMem('OvlS','Allo','Real',iS,nSize+4) - Call GetMem('Occs','Allo','Real',iOcc,nBas(1)) - kaunter=0 - Do 211, iB1=1,nBas(1) - Do 212, iB2=1,nBas(1) - Work(iVecs+kaunter)=0 - If(iB1.eq.iB2)Work(iVecs+kaunter)=1 - kaunter=kaunter+1 -212 Continue -211 Continue -*--- Symmetric orthogonalization, hence get overlap matrix, S. - Lu_One=92 - Call OpnOne(irc,0,'ONEINT',Lu_One) - irc=-1 - iopt=0 - iSmLbl=0 - icomp=1 - Call RdOne(irc,iopt,'Mltpl 0',icomp,Work(iS),iSmLbl) - Call Jacob(Work(iS),Work(iVecs),nBas(1),nBas(1)) - call dcopy_(nSize,[ZERO],iZERO,Work(iSx),iONE) - call dcopy_(nSize,[ZERO],iZERO,Work(iSt),iONE) - Do 221, i=1,nBas(1) - Sqroot=sqrt(Work(iS+i*(i+1)/2-1)) - Work(iSx+i*(i+1)/2-1)=ONE/Sqroot - Work(iSt+i*(i+1)/2-1)=Sqroot -221 Continue - Call Square(Work(iSx),Work(iSs),iONE,nBas(1),nBas(1)) - Call Square(Work(iSt),Work(iSst),iONE,nBas(1),nBas(1)) -*------S^(-1/2) - Call Dgemm_('N','N',nBas(1),nBas(1),nBas(1),ONE,Work(iVecs) - & ,nBas(1),Work(iSs),nBas(1),ZERO,Work(iAUX),nBas(1)) - Call Dgemm_('N','T',nBas(1),nBas(1),nBas(1),ONE,Work(iAUX) - & ,nBas(1),Work(iVecs),nBas(1),ZERO,Work(iTrans),nBas(1)) -*------S^(1/2) - Call Dgemm_('N','N',nBas(1),nBas(1),nBas(1),ONE,Work(iVecs) - & ,nBas(1),Work(iSst),nBas(1),ZERO,Work(iAUX),nBas(1)) - Call Dgemm_('N','T',nBas(1),nBas(1),nBas(1),ONE,Work(iAUX) - & ,nBas(1),Work(iVecs),nBas(1),ZERO,Work(iTransB),nBas(1)) -*--- The density matrix transforms 'inversly' from the matrix-elements, -* thus let S^(1/2) transform it, not S^(-1/2) which applies to the -* matrix elements. - Call Square(Work(iDav),Work(iDavS),iONE,nBas(1),nBas(1)) - Call Dgemm_('N','N',nBas(1),nBas(1),nBas(1),ONE,Work(iTransB) - & ,nBas(1),Work(iDavS),nBas(1),ZERO,Work(iAUX),nBas(1)) - Call Dgemm_('N','N',nBas(1),nBas(1),nBas(1),ONE,Work(iAUX) - & ,nBas(1),Work(iTransB),nBas(1),ZERO,Work(iOtD),nBas(1)) - kaunter=0 - Do 213, iB1=1,nBas(1) - Do 214, iB2=1,nBas(1) - Work(iVecs2+kaunter)=0 - If(iB1.eq.iB2)Work(iVecs2+kaunter)=1 - kaunter=kaunter+1 -214 Continue -213 Continue - Call SqToTri_Q(Work(iOtD),Work(iOtDt),nBas(1)) - Call Jacob(Work(iOtDt),Work(iVecs2),nBas(1),nBas(1)) -*--- With diagonalized density matrix, collect occupation numbers and -* natural orbital coefficients. - Call Dgemm_('N','N',nBas(1),nBas(1),nBas(1),ONE,Work(iTrans) - & ,nBas(1),Work(iVecs2),nBas(1),ZERO,Work(iAUX),nBas(1)) - kaunt=0 - kaunter=0 - Do 231, i=1,nBas(1) - Do 232, j=1,i - If(i.eq.j) then - Work(iOcc+kaunt)=Work(iOtDt+kaunter) - kaunt=kaunt+1 - Endif - kaunter=kaunter+1 -232 Continue -231 Continue - TraceFull=0 - Do 233, i=1,nBas(1) - TraceFull=TraceFull+Work(iOcc+i-1) -233 Continue - If(iPrint.ge.10) then - Call Get_cArray('Unique Basis Names',BsLbl,LENIN8*nBas(1)) - Write(Header,'(A)')'All average transition density orbitals' - ThrOcc=-1D-0 - Call Primo(Header,.true.,.false.,ThrOcc,Dum,iONE,nBas(1),nBas(1) - & ,BsLbl,Dummy,Work(iOcc),Work(iAUX),-1) - Write(6,*) - Write(6,*)' Trace = ',TraceFull - Endif -*--- Deallocations. - Call GetMem('DenM','Free','Real',iDin,nSize) - Call GetMem('DenA','Free','Real',iDav,nSize) - Call GetMem('Vecs','Free','Real',iVecs,nBas(1)**2) - Call GetMem('Vecs2','Free','Real',iVecs2,nBas(1)**2) - Call GetMem('OvlSs','Free','Real',iSs,nBas(1)**2) - Call GetMem('OvlSs','Free','Real',iSx,nSize) - Call GetMem('OvlSi','Free','Real',iSst,nBas(1)**2) - Call GetMem('OvlSi','Free','Real',iSt,nSize) - Call GetMem('DavSq','Free','Real',iDavS,nBas(1)**2) - Call GetMem('Trans','Free','Real',iTrans,nBas(1)**2) - Call GetMem('Trans','Free','Real',iTransB,nBas(1)**2) - Call GetMem('OrtoAvDen','Free','Real',iOtD,nBas(1)**2) - Call GetMem('OrtoAcDeT','Free','Real',iOtDt,nSize) - Call GetMem('OvlS','Free','Real',iS,nSize+4) - -* -*--- Jetzt far wir mal wieder. Reduce MO-basis according to input -* criterion. -* - MOsToKeep=0 - Do 301, iB=1,nBas(1) - If(Work(iOcc+iB-1).ge.ThrsRedOcc) then - LindMOs(iB)=.true. - MOsToKeep=MOsToKeep+1 - Else - LindMOs(iB)=.false. - Endif -301 Continue - nSize=nBas(1)*MOsToKeep - Call GetMem('UncleMoe','Allo','Real',ipAvRedMO,nSize) - Call GetMem('NewOccs','Allo','Real',iNewOcc,MOsToKeep) - ind2=0 - ind3=0 -*--- Loop to suck-out the nice MOs. - Do 302, iB=1,nBas(1) - If(LindMOs(iB)) then - ind1=nBas(1)*(iB-1) - call dcopy_(nBas(1),Work(iAUX+ind1),iONE,Work(ipAvRedMO+ind2) - & ,iONE) - Work(iNewOcc+ind3)=Work(iOcc+iB-1) - ind2=ind2+nBas(1) - ind3=ind3+1 - Endif -302 Continue - TraceRed=0 - Do 303, i=1,MOsToKeep - TraceRed=TraceRed+Work(iNewOcc+i-1) -303 Continue -*--- Make a trace check. - If((TraceFull-TraceRed).ge.ReduceWarning) then - Write(6,*) - Write(6,*)'WARNING! With your occupation threshold, the densit' - &//'y matrix trace' - Write(6,*)'differs by ',TraceFull-TraceRed,'.' - Write(6,*)'You should consider lowering the threshold!' - Endif - If(iPrint.ge.5) then - Call Get_cArray('Unique Basis Names',BsLbl,LENIN8*nBas(1)) - Write(Header,'(A)')'Reduced average orbitals' - ThrOcc=-1D-0 - Call Primo(Header,.true.,.false.,ThrOcc,Dum,iONE,nBas(1) - & ,[MOsToKeep],BsLbl,Dummy,Work(iNewOcc) - & ,Work(ipAvRedMO),-1) - Write(6,*) - Write(6,*)' Trace = ',TraceRed,MOsToKeep - Endif - -* -*--- Time to reduce all individual density matrices in the big TDM to -* the reduced MO-basis. Once more, observe that the density -* transforms contravariantly. But sadly, we need to invert the -* full square MO-matrix before we make reductions. -* - Call GetMem('InverseC','Allo','Real',ipInv,nBas(1)**2) - Call MInv(Work(iAUX),Work(ipInv),Ising,Det,nBas(1)) - -* -*--- Now all those transformations and density reductions. To check for -* density losses, the overlaps are read. These partially transformed -* transition density matrix is stored in a scratch file. -* - DiffMegaMax=0.0d0 - nSize=nBas(1)*(nBas(1)+1)/2 - nMtK=MOsToKeep*(MOsToKeep+1)/2 - Call GetMem('Temporary','Allo','Real',ipTEMP,nBas(1)**2) - Call GetMem('MOtrDen','Allo','Real',ipTmoD,nBas(1)**2) - Call GetMem('MOreDen','Allo','Real',ipTreD,MOsToKeep**2) - Call GetMem('MOreDen','Allo','Real',ipTreT,nMtK) - Call GetMem('DenM','Allo','Real',iDin,nSize) - Call GetMem('DenMsq','Allo','Real',iDsq,nBas(1)**2) - Call GetMem('OvlS','Allo','Real',iS,nSize+4) - Call GetMem('Ssquare','Allo','Real',iSsq,nBas(1)**2) - Call GetMem('Strans','Allo','Real',iStrans,nBas(1)**2) - Call GetMem('Stri','Allo','Real',iStri,nMtK) - Lu_Scratch=57 - Lu_Scratch=IsFreeUnit(Lu_Scratch) - Call DaName(Lu_Scratch,'TDMSCR') - irc=-1 - iopt=0 - iSmLbl=0 - icomp=1 - Call RdOne(irc,iopt,'Mltpl 0',icomp,Work(iS),iSmLbl) - Call ClsOne(irc,iopt) - iDiskUt=0 - Call iDaFile(Lu_Scratch,1,iTocBig,MxStOT,iDiskUt) - Do 401, iS1=1,nState - Do 402, iS2=1,iS1 -*------- Collect this particular density matrix. - index=(iS1*(iS1-1)/2+iS2-1)*nSize - call dcopy_(nSize,Work(iBigT+index),iONE,Work(iDin),iONE) -*------- Square it and correct the non-diagonal (recall convention) - Call Dsq(Work(iDin),Work(iDsq),iONE,nBas(1),nBas(1)) -*------- Contravariant transformation of density matrix. - Call Dgemm_('N','N',nBas(1),nBas(1),nBas(1),ONE,Work(ipInv) - & ,nBas(1),Work(iDsq),nBas(1),ZERO,Work(ipTEMP) - & ,nBas(1)) - Call Dgemm_('N','T',nBas(1),nBas(1),nBas(1),ONE,Work(ipTEMP) - & ,nBas(1),Work(ipInv),nBas(1),ZERO,Work(ipTmoD) - & ,nBas(1)) -*------- Covariant transformation of overlap matrix. - Call Square(Work(iS),Work(iSsq),iONE,nBas(1),nBas(1)) - Call Dgemm_('T','N',nBas(1),nBas(1),nBas(1),ONE,Work(iAUX) - & ,nBas(1),Work(iSsq),nBas(1),ZERO,Work(ipTEMP) - & ,nBas(1)) - Call Dgemm_('N','N',nBas(1),nBas(1),nBas(1),ONE,Work(ipTEMP) - & ,nBas(1),Work(iAUX),nBas(1),ZERO,Work(iStrans) - & ,nBas(1)) -*------- How much charge ('overlap') is there in this density element? - ChargeNonReduced=Ddot_(nBas(1)**2,Work(ipTmoD),iONE - & ,Work(iStrans),iONE) -*------- Reduction of density matrix and overlap matrix. - kaunter=0 - ind1=0 - Do 405, iM1=1,nBas(1) - Do 406, iM2=1,nBas(1) - If(LindMOs(iM1).and.LindMOs(iM2)) then - Work(ipTreD+ind1)=Work(ipTmoD+kaunter) - Work(iSsq+ind1)=Work(iStrans+kaunter) - ind1=ind1+1 - Endif - kaunter=kaunter+1 -406 Continue -405 Continue -*------- Triangualize, jetzt! - kaunter=0 - Do 407, iM1=1,MOsToKeep - Do 408, iM2=1,MOsToKeep - If(iM1.ne.iM2)Work(ipTreD+kaunter)=2*Work(ipTreD+kaunter) - kaunter=kaunter+1 -408 Continue -407 Continue - Call SqToTri_Q(Work(ipTreD),Work(ipTreT),MOsToKeep) - Call SqToTri_Q(Work(iSsq),Work(iStri),MOsToKeep) -*------- Compute total electronic charge of this reduced density. - ChargeReduced=Ddot_(nMtK,Work(ipTreT),iONE,Work(iStri),iONE) -*------- Renormalize to get right charge ('overlap'); to safeguard -* against zero overlaps, make check. - If(abs(ChargeNonReduced).le.1D-7.or. - & abs(ChargeReduced).le.1D-7) then - Fac=1.0D0 - Else - Fac=ChargeNonReduced/ChargeReduced - Endif - kaunter=0 - Do 409, iM1=1,MOsToKeep - Do 410, iM2=1,iM1 - Work(ipTreT+kaunter)=Work(ipTreT+kaunter)*Fac - kaunter=kaunter+1 -410 Continue -409 Continue -*------- If sufficient printlevel, show moment modifications. - If(iPrint.ge.10) then - Call MomentMod(ipTreT,ipTmoD,iAUX,MOsToKeep,nBas(1),LindMOs - & ,iS1,iS2,First,DiffMax) - If(DiffMax.gt.DiffMegaMax) DiffMegaMax=DiffMax - Endif -*------- Add previous disk address to T-o-C. - ind=iS1*(iS1+1)/2-iS1+iS2 - iTocBig(ind)=iDiskUt -*------- 'Because I will take a gigant dump on you!' - Call dDaFile(Lu_Scratch,1,Work(ipTreT),nMtk,iDiskUt) -402 Continue -401 Continue -*--- The real table-of-content - iDiskUt=0 - Call iDaFile(Lu_Scratch,1,iTocBig,MxStOT,iDiskUt) -*--- Deallocations and closing. - Call GetMem('NewOccs','Free','Real',iNewOcc,MOsToKeep) - Call GetMem('InverseC','Free','Real',ipInv,nBas(1)**2) - Call GetMem('Temporary','Free','Real',ipTEMP,nBas(1)**2) - Call GetMem('MOtrDen','Free','Real',ipTmoD,nBas(1)**2) - Call GetMem('MOreDen','Free','Real',ipTreD,MOsToKeep**2) - Call GetMem('MOreDen','Free','Real',ipTreT,nMtK) - Call GetMem('DenM','Free','Real',iDin,nSize) - Call GetMem('DenMsq','Free','Real',iDsq,nBas(1)**2) - Call GetMem('OvlS','Free','Real',iS,nSize+4) - Call GetMem('Ssquare','Free','Real',iSsq,nBas(1)**2) - Call GetMem('Strans','Free','Real',iStrans,nBas(1)**2) - Call GetMem('Stri','Free','Real',iStri,nMtK) - Call GetMem('AuxS','Free','Real',iAUX,nBas(1)**2) - Call GetMem('Occs','Free','Real',iOcc,nBas(1)) - Call DaClos(Lu_Scratch) - -* -*--- Report on the reduction. -* - Write(6,*) - Write(6,90)'AO-basis ---> MO-basis reduction complete.' - Write(6,91)'From ',nBas(1),' functions to ',MosToKeep,'.' - Write(6,90)'Reduced basis renormalized to have same overlap as no' - &//'n-reduced.' - If(iPrint.ge.10) then - Write(6,92)'Largest dipole difference is ',DiffMegaMax - Endif -90 Format(' ',A) -91 Format(' ',A,I3,A,I3,A) -92 Format(' ',A,F10.7) - - Return - End - - - Subroutine MomentMod(ipRe,ipNRe,iCmo,nBRe,nBNRe,LindMOs,iS1,iS2 - & ,First,DiffMax) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "files_qmstat.fh" -#include "qminp.fh" -#include "numbers.fh" -#include "WrkSpc.fh" - - Dimension DipRe(3),DipNRe(3) - - Logical LindMOs(MxBas),First - - If(First.and.iPrint.ge.5) then - Write(6,*) - Write(6,*)' Modifications of dipoles by renormalization and' - &//' basis reduction.' - Write(6,*) - Write(6,*)' State pair | Difference ' - Write(6,*)' --------------|---------------------' - First=.false. - Endif - - nSize1=nBNRe*(nBNRe+1)/2 - nSize2=nBRe*(nBRe+1)/2 - Call GetMem('DipX','Allo','Real',ipDx,nSize1+4) - Call GetMem('DipY','Allo','Real',ipDy,nSize1+4) - Call GetMem('DipZ','Allo','Real',ipDz,nSize1+4) - Call GetMem('DipXre','Allo','Real',ipDxRe,nSize2) - Call GetMem('DipYre','Allo','Real',ipDyRe,nSize2) - Call GetMem('DipZre','Allo','Real',ipDzRe,nSize2) - Call GetMem('DipXsq','Allo','Real',ipDxsq,nBNRe**2) - Call GetMem('DipYsq','Allo','Real',ipDysq,nBNRe**2) - Call GetMem('DipZsq','Allo','Real',ipDzsq,nBNRe**2) - Call GetMem('DipXm','Allo','Real',ipDxM,nBNRe**2) - Call GetMem('DipYm','Allo','Real',ipDyM,nBNRe**2) - Call GetMem('DipZm','Allo','Real',ipDzM,nBNRe**2) - Call GetMem('TEMP','Allo','Real',ipTEMP,nBNRe**2) - irc=-1 - iopt=0 - iSmLbl=0 -*--- X - icomp=1 - Call RdOne(irc,iopt,'Mltpl 1',icomp,Work(ipDx),iSmLbl) - Call Square(Work(ipDx),Work(ipDxsq),iONE,nBNRe,nBNRe) - Call Dgemm_('T','N',nBNRe,nBNRe,nBNRe,ONE,Work(iCmo) - & ,nBNRe,Work(ipDxsq),nBNRe,ZERO,Work(ipTEMP) - & ,nBNRe) - Call Dgemm_('N','N',nBNRe,nBNRe,nBNRe,ONE,Work(ipTEMP) - & ,nBNRe,Work(iCmo),nBNRe,ZERO,Work(ipDxM) - & ,nBNRe) -*--- Y - icomp=2 - Call RdOne(irc,iopt,'Mltpl 1',icomp,Work(ipDy),iSmLbl) - Call Square(Work(ipDy),Work(ipDysq),iONE,nBNRe,nBNRe) - Call Dgemm_('T','N',nBNRe,nBNRe,nBNRe,ONE,Work(iCmo) - & ,nBNRe,Work(ipDysq),nBNRe,ZERO,Work(ipTEMP) - & ,nBNRe) - Call Dgemm_('N','N',nBNRe,nBNRe,nBNRe,ONE,Work(ipTEMP) - & ,nBNRe,Work(iCmo),nBNRe,ZERO,Work(ipDyM) - & ,nBNRe) -*--- Z - icomp=3 - Call RdOne(irc,iopt,'Mltpl 1',icomp,Work(ipDz),iSmLbl) - Call Square(Work(ipDz),Work(ipDzsq),iONE,nBNRe,nBNRe) - Call Dgemm_('T','N',nBNRe,nBNRe,nBNRe,ONE,Work(iCmo) - & ,nBNRe,Work(ipDzsq),nBNRe,ZERO,Work(ipTEMP) - & ,nBNRe) - Call Dgemm_('N','N',nBNRe,nBNRe,nBNRe,ONE,Work(ipTEMP) - & ,nBNRe,Work(iCmo),nBNRe,ZERO,Work(ipDzM) - & ,nBNRe) -*--- Triangualize and reduce. - kaunt1=0 - kaunt2=0 - Do 2001, i=1,nBNRe - Do 2002, j=1,nBNRe - If(j.le.i) then - If(LindMOs(i).and.LindMOs(j)) then - Work(ipDxRe+kaunt1)=Work(ipDxM+kaunt2) - Work(ipDyRe+kaunt1)=Work(ipDyM+kaunt2) - Work(ipDzRe+kaunt1)=Work(ipDzM+kaunt2) - kaunt1=kaunt1+1 - Endif - Endif - kaunt2=kaunt2+1 -2002 Continue -2001 Continue -*--- Density - DipNRe(1)=Ddot_(nBNRe**2,Work(ipDxM),iONE,Work(ipNRe),iONE) - DipNRe(2)=Ddot_(nBNRe**2,Work(ipDyM),iONE,Work(ipNRe),iONE) - DipNRe(3)=Ddot_(nBNRe**2,Work(ipDzM),iONE,Work(ipNRe),iONE) - DipRe(1)=Ddot_(nSize2,Work(ipDxRe),iONE,Work(ipRe),iONE) - DipRe(2)=Ddot_(nSize2,Work(ipDyRe),iONE,Work(ipRe),iONE) - DipRe(3)=Ddot_(nSize2,Work(ipDzRe),iONE,Work(ipRe),iONE) - Diffx=abs(DipRe(1)-DipNRe(1)) - Diffy=abs(DipRe(2)-DipNRe(2)) - Diffz=abs(DipRe(3)-DipNRe(3)) - If(iPrint.ge.5) then - Write(6,99)iS1,iS2,'(',Diffx,',',Diffy,',',Diffz,')' - Endif -99 Format(' ',2I3,' ',3(A,F10.7),A) -*--- Return number - DiffMax=Diffy - If(Diffx.ge.Diffy) DiffMax=Diffx - If(Diffz.ge.Diffx.and.Diffz.ge.Diffy) DiffMax=Diffz -*--- Deallocate en masse. - Call GetMem('DipX','Free','Real',ipDx,nSize1+4) - Call GetMem('DipY','Free','Real',ipDy,nSize1+4) - Call GetMem('DipZ','Free','Real',ipDz,nSize1+4) - Call GetMem('DipXre','Free','Real',ipDxRe,nSize2) - Call GetMem('DipYre','Free','Real',ipDyRe,nSize2) - Call GetMem('DipZre','Free','Real',ipDzRe,nSize2) - Call GetMem('DipXsq','Free','Real',ipDxsq,nBNRe**2) - Call GetMem('DipYsq','Free','Real',ipDysq,nBNRe**2) - Call GetMem('DipZsq','Free','Real',ipDzsq,nBNRe**2) - Call GetMem('DipXm','Free','Real',ipDxM,nBNRe**2) - Call GetMem('DipYm','Free','Real',ipDyM,nBNRe**2) - Call GetMem('DipZm','Free','Real',ipDzM,nBNRe**2) - Call GetMem('TEMP','Free','Real',ipTEMP,nBNRe**2) - - Return - End diff -Nru openmolcas-22.02/src/qmstat/moreduce.F90 openmolcas-22.10/src/qmstat/moreduce.F90 --- openmolcas-22.02/src/qmstat/moreduce.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/moreduce.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,328 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine MoReduce(nBas,MOsToKeep) + +use qmstat_global, only: AvRed, BigT, iPrint, MxSymQ, nState, ThrsRedOcc +use Index_Functions, only: iTri, nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Half +use Definitions, only: wp, iwp, u6, r8 + +implicit none +integer(kind=iwp), intent(in) :: nBas(MxSymQ) +integer(kind=iwp), intent(out) :: MOsToKeep +#include "Molcas.fh" +integer(kind=iwp) :: i, iB, iB1, iB2, icomp, iDiskUt, iM1, iM2, ind, ind1, ind2, indx, iopt, irc, iS1, iS2, Ising, iSmLbl, kaunt, & + Lu_One, Lu_Scratch, nMtK, nSize +real(kind=wp) :: ChargeNonReduced, ChargeReduced, Det, DiffMax, DiffMegaMax, Dum, Dummy(1), Sqroot, ThrOcc, TraceFull, TraceRed, & + weight +logical(kind=iwp) :: First = .true. +character(len=50) :: Header +integer(kind=iwp), allocatable :: iTocBig(:) +real(kind=wp), allocatable :: AUX(:,:), Dav(:), DavS(:,:), Din(:), DsqM(:,:), Inv(:,:), NewOcc(:), Occ(:), OtD(:,:), OtDt(:), & + S(:), Ss(:,:), Ssq(:), Sst(:,:), St(:), Strans(:,:), Stri(:), Sx(:), TEMP(:,:), TmoD(:,:), & + Trans(:,:), TransB(:,:), TreD(:,:), TreT(:), Vecs(:,:) +logical(kind=iwp), allocatable :: LindMOs(:) +character(len=LenIn8), allocatable :: BsLbl(:) +real(kind=wp), parameter :: ReduceWarning = Half +integer(kind=iwp), external :: IsFreeUnit +real(kind=r8), external :: Ddot_ + +! A word of welcome. + +write(u6,*) ' ----- Transform to average natural MO-reduced basis.' + +! First we accumulate the different density matrices. + +nSize = nTri_Elem(nBas(1)) +weight = One/real(nState,kind=wp) +call mma_allocate(Din,nSize,label='DenM') +call mma_allocate(Dav,nSize,label='DenA') +Dav(:) = Zero +do iS1=1,nState + do iS2=1,iS1 + indx = iTri(iS1,iS2) + Din(:) = BigT(:,indx) + if (iS1 /= iS2) cycle + kaunt = 0 + do iB1=1,nBas(1) + do iB2=1,iB1-1 + kaunt = kaunt+1 + Dav(kaunt) = Dav(kaunt)+Din(kaunt)*Half*weight + end do + kaunt = kaunt+1 + Dav(kaunt) = Dav(kaunt)+Din(kaunt)*weight + end do + end do +end do + +! Then since we are working in the non-orthogonal AO-basis, +! it is necessary to orthogonalize before we diagonalize +! accumulated density. + +call mma_allocate(LindMOs,nBas(1),label='LindMOs') +call mma_allocate(Vecs,nBas(1),nBas(1),label='Vecs') +call mma_allocate(AUX,nBas(1),nBas(1),label='AuxS') +call mma_allocate(Ss,nBas(1),nBas(1),label='OvlSs') +call mma_allocate(Sx,nSize,label='OvlSs') +call mma_allocate(Sst,nBas(1),nBas(1),label='OvlSi') +call mma_allocate(St,nSize,label='OvlSi') +call mma_allocate(DavS,nBas(1),nBas(1),label='DavSq') +call mma_allocate(Trans,nBas(1),nBas(1),label='Trans') +call mma_allocate(TransB,nBas(1),nBas(1),label='Trans') +call mma_allocate(OtD,nBas(1),nBas(1),label='OrtoAvDen') +call mma_allocate(OtDt,nSize,label='OrtoAcDeT') +call mma_allocate(S,nSize,label='OvlS') +call mma_allocate(Occ,nBas(1),label='Occs') +Vecs(:,:) = Zero +call dCopy_(nBas(1),[One],0,Vecs,nBas(1)+1) +! Symmetric orthogonalization, hence get overlap matrix, S. +Lu_One = 92 +call OpnOne(irc,0,'ONEINT',Lu_One) +irc = -1 +iopt = 6 +iSmLbl = 0 +icomp = 1 +call RdOne(irc,iopt,'Mltpl 0',icomp,S,iSmLbl) +call Jacob(S,Vecs,nBas(1),nBas(1)) +Sx(:) = Zero +St(:) = Zero +do i=1,nBas(1) + Sqroot = sqrt(S(nTri_Elem(i))) + Sx(nTri_Elem(i)) = One/Sqroot + St(nTri_Elem(i)) = Sqroot +end do +call Square(Sx,Ss,1,nBas(1),nBas(1)) +call Square(St,Sst,1,nBas(1),nBas(1)) +! S^(-1/2) +call Dgemm_('N','N',nBas(1),nBas(1),nBas(1),One,Vecs,nBas(1),Ss,nBas(1),Zero,AUX,nBas(1)) +call Dgemm_('N','T',nBas(1),nBas(1),nBas(1),One,AUX,nBas(1),Vecs,nBas(1),Zero,Trans,nBas(1)) +! S^(1/2) +call Dgemm_('N','N',nBas(1),nBas(1),nBas(1),One,Vecs,nBas(1),Sst,nBas(1),Zero,AUX,nBas(1)) +call Dgemm_('N','T',nBas(1),nBas(1),nBas(1),One,AUX,nBas(1),Vecs,nBas(1),Zero,TransB,nBas(1)) +! The density matrix transforms 'inversely' from the matrix-elements, +! thus let S^(1/2) transform it, not S^(-1/2) which applies to the +! matrix elements. +call Square(Dav,DavS,1,nBas(1),nBas(1)) +call Dgemm_('N','N',nBas(1),nBas(1),nBas(1),One,TransB,nBas(1),DavS,nBas(1),Zero,AUX,nBas(1)) +call Dgemm_('N','N',nBas(1),nBas(1),nBas(1),One,AUX,nBas(1),TransB,nBas(1),Zero,OtD,nBas(1)) +Vecs(:,:) = Zero +call dCopy_(nBas(1),[One],0,Vecs,nBas(1)+1) +call SqToTri_Q(OtD,OtDt,nBas(1)) +call Jacob(OtDt,Vecs,nBas(1),nBas(1)) +! With diagonalized density matrix, collect occupation numbers and +! natural orbital coefficients. +call Dgemm_('N','N',nBas(1),nBas(1),nBas(1),One,Trans,nBas(1),Vecs,nBas(1),Zero,AUX,nBas(1)) +do i=1,nBas(1) + Occ(i) = OtDt(nTri_Elem(i)) +end do +TraceFull = Zero +do i=1,nBas(1) + TraceFull = TraceFull+Occ(i) +end do +if (iPrint >= 5) then + call mma_allocate(BsLbl,nBas(1),label='BsLbl') + call Get_cArray('Unique Basis Names',BsLbl,LenIn8*nBas(1)) +end if +if (iPrint >= 10) then + write(Header,'(A)') 'All average transition density orbitals' + ThrOcc = -One + call Primo(Header,.true.,.false.,ThrOcc,Dum,1,nBas(1),nBas(1),BsLbl,Dummy,Occ,AUX,-1) + write(u6,*) + write(u6,*) ' Trace = ',TraceFull +end if +! Deallocations. +call mma_deallocate(Din) +call mma_deallocate(Dav) +call mma_deallocate(Vecs) +call mma_deallocate(Ss) +call mma_deallocate(Sx) +call mma_deallocate(Sst) +call mma_deallocate(St) +call mma_deallocate(DavS) +call mma_deallocate(Trans) +call mma_deallocate(TransB) +call mma_deallocate(OtD) +call mma_deallocate(OtDt) +call mma_deallocate(S) + +! Jetzt far wir mal wieder. Reduce MO-basis according to input criterion. + +MOsToKeep = 0 +do iB=1,nBas(1) + if (Occ(iB) >= ThrsRedOcc) then + LindMOs(iB) = .true. + MOsToKeep = MOsToKeep+1 + else + LindMOs(iB) = .false. + end if +end do +call mma_allocate(AvRed,nBas(1),MOsToKeep,label='UncleMoe') +call mma_allocate(NewOcc,MOsToKeep,label='NewOccs') +ind1 = 0 +! Loop to suck-out the nice MOs. +do iB=1,nBas(1) + if (LindMOs(iB)) then + ind1 = ind1+1 + AvRed(:,ind1) = AUX(:,iB) + NewOcc(ind1) = Occ(iB) + end if +end do +TraceRed = Zero +do i=1,MOsToKeep + TraceRed = TraceRed+NewOcc(i) +end do +! Make a trace check. +if ((TraceFull-TraceRed) >= ReduceWarning) then + write(u6,*) + write(u6,*) 'WARNING! With your occupation threshold, the density matrix trace' + write(u6,*) 'differs by ',TraceFull-TraceRed,'.' + write(u6,*) 'You should consider lowering the threshold!' +end if +if (iPrint >= 5) then + write(Header,'(A)') 'Reduced average orbitals' + ThrOcc = -One + call Primo(Header,.true.,.false.,ThrOcc,Dum,1,nBas(1),[MOsToKeep],BsLbl,Dummy,NewOcc,AvRed,-1) + write(u6,*) + write(u6,*) ' Trace = ',TraceRed,MOsToKeep + call mma_deallocate(BsLbl) +end if + +! Time to reduce all individual density matrices in the big TDM to +! the reduced MO-basis. Once more, observe that the density +! transforms contravariantly. But sadly, we need to invert the +! full square MO-matrix before we make reductions. + +call mma_allocate(Inv,nBas(1),nBas(1),label='InverseC') +call MInv(AUX,Inv,Ising,Det,nBas(1)) + +! Now all those transformations and density reductions. To check for +! density losses, the overlaps are read. These partially transformed +! transition density matrix is stored in a scratch file. + +DiffMegaMax = Zero +nSize = nTri_Elem(nBas(1)) +nMtK = nTri_Elem(MOsToKeep) +call mma_allocate(TEMP,nBas(1),nBas(1),label='Temporary') +call mma_allocate(TmoD,nBas(1),nBas(1),label='MOtrDen') +call mma_allocate(TreD,MOsToKeep,MOsToKeep,label='MOreDen') +call mma_allocate(TreT,nMtK,label='MOreDen') +call mma_allocate(Din,nSize,label='DenM') +call mma_allocate(DsqM,nBas(1),nBas(1),label='DenMsq') +call mma_allocate(S,nSize,label='OvlS') +call mma_allocate(Ssq,nBas(1)**2,label='Ssquare') +call mma_allocate(Strans,nBas(1),nBas(1),label='Strans') +call mma_allocate(Stri,nMtK,label='Stri') +Lu_Scratch = IsFreeUnit(57) +call DaName(Lu_Scratch,'TDMSCR') +irc = -1 +iopt = 6 +iSmLbl = 0 +icomp = 1 +call RdOne(irc,iopt,'Mltpl 0',icomp,S,iSmLbl) +call ClsOne(irc,iopt) +iDiskUt = 0 +call mma_allocate(iTocBig,nTri_Elem(nState),label='iTocBig') +call iDaFile(Lu_Scratch,1,iTocBig,nTri_Elem(nState),iDiskUt) +do iS1=1,nState + do iS2=1,iS1 + ! Collect this particular density matrix. + indx = iTri(iS1,iS2) + Din(:) = BigT(:,indx) + ! Square it and correct the non-diagonal (recall convention) + call Dsq(Din,DsqM,1,nBas(1),nBas(1)) + ! Contravariant transformation of density matrix. + call Dgemm_('N','N',nBas(1),nBas(1),nBas(1),One,Inv,nBas(1),DsqM,nBas(1),Zero,TEMP,nBas(1)) + call Dgemm_('N','T',nBas(1),nBas(1),nBas(1),One,TEMP,nBas(1),Inv,nBas(1),Zero,TmoD,nBas(1)) + ! Covariant transformation of overlap matrix. + call Square(S,Ssq,1,nBas(1),nBas(1)) + call Dgemm_('T','N',nBas(1),nBas(1),nBas(1),One,AUX,nBas(1),Ssq,nBas(1),Zero,TEMP,nBas(1)) + call Dgemm_('N','N',nBas(1),nBas(1),nBas(1),One,TEMP,nBas(1),AUX,nBas(1),Zero,Strans,nBas(1)) + ! How much charge ('overlap') is there in this density element? + ChargeNonReduced = Ddot_(nBas(1)**2,TmoD,1,Strans,1) + ! Reduction of density matrix and overlap matrix. + ind1 = 0 + do iM1=1,nBas(1) + if (.not. LindMOs(iM1)) cycle + ind1 = ind1+1 + ind2 = 0 + do iM2=1,nBas(1) + if (.not. LindMOs(iM2)) cycle + ind2 = ind2+1 + TreD(ind2,ind1) = TmoD(iM2,iM1) + Ssq(ind2+(ind1-1)*MOsToKeep) = Strans(iM2,iM1) + end do + end do + ! Triangularize, jetzt! + do iM1=1,MOsToKeep + do iM2=1,MOsToKeep + if (iM1 /= iM2) TreD(iM2,iM1) = Two*TreD(iM2,iM1) + end do + end do + call SqToTri_Q(TreD,TreT,MOsToKeep) + call SqToTri_Q(Ssq,Stri,MOsToKeep) + ! Compute total electronic charge of this reduced density. + ChargeReduced = Ddot_(nMtK,TreT,1,Stri,1) + ! Renormalize to get right charge ('overlap'); to safeguard + ! against zero overlaps, make check. + if ((abs(ChargeNonReduced) > 1.0e-7_wp) .and. (abs(ChargeReduced) > 1.0e-7_wp)) then + TreT(:) = TreT*ChargeNonReduced/ChargeReduced + end if + ! If sufficient printlevel, show moment modifications. + if (iPrint >= 10) then + call MomentMod(TreT,TmoD,AUX,MOsToKeep,nBas(1),LindMOs,iS1,iS2,First,DiffMax) + if (DiffMax > DiffMegaMax) DiffMegaMax = DiffMax + end if + ! Add previous disk address to T-o-C. + ind = iTri(iS1,iS2) + iTocBig(ind) = iDiskUt + ! 'Because I will take a giant dump on you!' + call dDaFile(Lu_Scratch,1,TreT,nMtk,iDiskUt) + end do +end do +! The real table-of-content +iDiskUt = 0 +call iDaFile(Lu_Scratch,1,iTocBig,nTri_Elem(nState),iDiskUt) +! Deallocations and closing. +call mma_deallocate(iTocBig) +call mma_deallocate(LindMOs) +call mma_deallocate(AUX) +call mma_deallocate(NewOcc) +call mma_deallocate(Inv) +call mma_deallocate(TEMP) +call mma_deallocate(TmoD) +call mma_deallocate(TreD) +call mma_deallocate(TreT) +call mma_deallocate(Din) +call mma_deallocate(DsqM) +call mma_deallocate(S) +call mma_deallocate(Ssq) +call mma_deallocate(Strans) +call mma_deallocate(Stri) +call mma_deallocate(Occ) +call DaClos(Lu_Scratch) + +! Report on the reduction. + +write(u6,*) +write(u6,90) 'AO-basis ---> MO-basis reduction complete.' +write(u6,91) 'From ',nBas(1),' functions to ',MosToKeep,'.' +write(u6,90) 'Reduced basis renormalized to have same overlap as non-reduced.' +if (iPrint >= 10) write(u6,92) 'Largest dipole difference is ',DiffMegaMax + +return + +90 format(' ',A) +91 format(' ',A,I3,A,I3,A) +92 format(' ',A,F10.7) + +end subroutine MoReduce diff -Nru openmolcas-22.02/src/qmstat/multinew.f openmolcas-22.10/src/qmstat/multinew.f --- openmolcas-22.02/src/qmstat/multinew.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/multinew.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,306 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Anders Ohrn * -************************************************************************ -* MultiNew -* -*> @brief -*> Perform the MME in contracted AO-basis -*> @author A. Ohrn -*> -*> @details -*> (i) Read in the multipole integrals from Seward. (ii) Construct -*> some data to simplify accessing the computed data. (iii) Make -*> the actual MME. -*> -*> @note -*> Requires numbers taken from ::qfread. We also need some integrals -*> that supposedly have been computed by Seward. -*> -*> @param[in] nAt Number of atoms in QM-molecule -*> @param[in] nBas Number of contracted basis functions -*> @param[in] nOcc Number of basis functions of the \f$ i \f$ -th atom-type -*> @param[in] natyp Number of atoms of the \f$ i \f$ -th atom-type -*> @param[in] nntyp Number of atom-types -*> @param[out] iMME Pointer to the multicenter multipole expanded densities of unique pairs of contracted basis functions -*> @param[out] iCenTri Set of indices that tells to which center the \f$ i \f$ -th unique pair of basis functions in a lower triangulary stored matrix belongs -*> @param[out] iCenTriT Just like \p iCenTri, but in square shape -*> @param[out] nMlt Highest multipole in MME -*> @param[out] outxyz Expansion centers in molecule -************************************************************************ - Subroutine MultiNew(nAt,nBas,nOcc,natyp,nntyp,iMME,iCenTri - &,iCenTriT,nMlt,outxyz,SlExpQ,lSlater) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "WrkSpc.fh" -#include "warnings.h" - - Dimension xyz(MxAt,MxAt,3),CordMul(MxMltp,3),outxyz(MxQCen,3) - Dimension nOcc(MxAt),natyp(MxAt),nBasAt(MxBas) - Dimension iCenTri(*),iCenTriT(*) - Dimension iX(6),iY(6),iMult(MxMltp,MxComp) - Dimension iMME(MxMltp*(MxMltp+1)*(MxMltp+2)/6) - Dimension SlExpQ(MxMltp+1,MxQCen) -*Jose.No Nuclear charges in Salter ,SlPQ(MxQCen) - Character MemLab*20,MMElab*20,ChCo*2,ChCo2*2 - Character*9 Integrals(3) - Logical Lika, Changed1, Changed2, lSlater - Data iX/1,1,1,2,2,3/ - Data iY/1,2,3,2,3,3/ - Data Integrals/'MLTPL 0','MLTPL 1','MLTPL 2'/ - Dimension iDum(1) -*----------------------------------------------------------------------* -* Read the multipole integrals in contracted AO-basis. * -*----------------------------------------------------------------------* - irc=-1 - Lu_One=49 - Lu_One=IsFreeUnit(Lu_One) - Call OpnOne(irc,0,'ONEINT',Lu_One) - If(irc.ne.0) then - Write(6,*) - Write(6,*)'ERROR! Could not open one-electron integral file.' - Call Quit(_RC_IO_ERROR_READ_) - Endif - -* -*-- This loop will terminate when no more multipole integrals are -* available, hence there is not a problem that we apparently loop -* over MxMltpl, which is a fixed number. -* - Do 100, iMlt=1,MxMltp - nComp=iMlt*(iMlt+1)/2 - Do 101, iComp=1,nComp - irc=-1 - iOpt=1 - iSmLbl=1 - Call iRdOne(irc,iOpt,integrals(iMlt),iComp,iDum,iSmLbl) - If(irc.eq.0) nSize=iDum(1) - If(irc.ne.0) then - If(iComp.ne.1) then - Write(6,*) - Write(6,*)'ERROR! Failed to read number of one-electron i' - &//'ntegrals.' - Call Quit(_RC_IO_ERROR_READ_) - Else !Normal exit here. - nMlt=iMlt-1 - Go To 199 - Endif - Endif - If(nSize.ne.0) then - Write(ChCo,'(I2.2)')iMlt - Write(ChCo2,'(I2.2)')iComp - Write(MemLab,*)'MEM'//ChCo//ChCo2 - Call GetMem(MemLab,'Allo','Real',iMult(iMlt,iComp),nSize+4) - irc=-1 - iOpt=0 - iSmLbl=0 - Call RdOne(irc,iOpt,integrals(iMlt),iComp - & ,Work(iMult(iMlt,iComp)),iSmLbl) !Collect integrals - Else - Write(6,*) - Write(6,*)'ERROR! Problem reading ',integrals(iMlt) - Call Quit(_RC_IO_ERROR_READ_) - Endif -101 Continue - Do 110, i=1,3 - CordMul(iMlt,i)=Work(iMult(iMlt,1)+nSize+i-1) -110 Continue - nMlt=MxMltp -100 Continue -199 Continue - -*----------------------------------------------------------------------* -* Collect centers from preceeding MpProp calculation. Compute two * -* index vectors. First one gives index of atom on which the i:th basis * -* function is centered. The other (iCenTri) gives to which center the * -* i:th unique basis function product belong. * -*----------------------------------------------------------------------* - Call Get_Centers(nAt,xyz) - kaunt=0 - Do 2001, i=1,nAt - kaunt=kaunt+1 - outxyz(kaunt,1)=xyz(i,i,1) - outxyz(kaunt,2)=xyz(i,i,2) - outxyz(kaunt,3)=xyz(i,i,3) -2001 Continue - kaunt=nAt - Do 2002, i=1,nAt - Do 2003, j=1,i-1 - kaunt=kaunt+1 - outxyz(kaunt,1)=xyz(i,j,1) - outxyz(kaunt,2)=xyz(i,j,2) - outxyz(kaunt,3)=xyz(i,j,3) -2003 Continue -2002 Continue -*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++* -*Jose. Collect data of the Slater representation of the Quantum System * -* Prefactors, Exponents, PointNuclearCharges. * -*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++* - If(lSlater) then - Call Get_Slater(SlExpQ,LMltSlQ,outxyz,nAt) - - If(LMltSlQ+1.ne.nMlt) then - Write(6,*)'ERROR! Multipole order',LMltSlQ,' in DiffPr file is' - &//' different from order',nMlt-1,' in One-electron file. Check' - &//' your files.' - Call Quit(_RC_GENERAL_ERROR_) - Endif - Endif - - kaunter=0 - iAt=0 - Do 201, i=1,nntyp - nBasA=nOcc(i)/natyp(i) - Do 202, j=1,natyp(i) - iAt=iAt+1 - Do 203,k=1,nBasA - kaunter=kaunter+1 - nBasAt(kaunter)=iAt -203 Continue -202 Continue -201 Continue - - kaunter=0 - Indie=nAt - IndiePrev=1 - nB1Prev=1 - nB2Prev=1 - Do 204, iB1=1,nBas !Count over unique pairs of bas.func. - Do 205, iB2=1,iB1 - kaunter=kaunter+1 - Lika=nBasAt(iB1).eq.nBasAt(iB2) - If(Lika) then !If equal indeces, then take that number. - iCenTri(kaunter)=nBasAt(iB1) - nB1Prev=nBasAt(iB1) - nB2Prev=nBasAt(iB2) - Else - Changed1=nB1Prev.ne.nBasAt(iB1) !Check if changed atom. - Changed2=nB2Prev.ne.nBasAt(iB2) - If(Changed1.and..not.Changed2) then !Case when from center - Indie=Indie+1 !1 to nAt+1. - nB1Prev=nBasAt(iB1) - IndiePrev=Indie - Elseif(Changed2.and..not.Changed1) then !Moving to new - If(iB2.eq.1) then !atom horizontally in lower triangular - Indie=IndiePrev !matrix. If it is a jump back to left - Else !corner, do not increase index, but - Indie=Indie+1 !get old one. - Endif - nB2Prev=nBasAt(iB2) - Elseif(Changed1.and.Changed2) then !Changing both atoms. - Indie=Indie+1 - nB1Prev=nBasAt(iB1) - nB2Prev=nBasAt(iB2) - IndiePrev=Indie - Endif - iCenTri(kaunter)=Indie - Endif -205 Continue -204 Continue - Ind=0 - Do 206, i=0,nBas-1 !Lets be square. - Do 207, j=0,i - Ind=Ind+1 - iCenTriT(1+i+j*nBas)=iCenTri(ind) - iCenTriT(1+j+i*nBas)=iCenTri(ind) -207 Continue -206 Continue - -*----------------------------------------------------------------------* -* Start the MME. To get a MME-dipole, we want <psi_i|x-x_o|psi_j> but * -* we have <psi_i|x-x_M|psi_j> where x_o is the chosen MME-center, while* -* x_M is the center that Molcas uses. We transform in this manner: * -* <psi_i|x-x_o|psi_j>=<psi_i|x-x_M|psi_j>+(x_M-x_o)*<psi_i|psi_j>. * -* The quadrupole contains a further complication: not only must we * -* include more terms, but the dipole correction may not be the MME- * -* dipole due to that Molcas may not have used the same center for * -* dipoles and quadrupoles. Let have a look: <psi_i|(x-x_o)(y-y_o)|psi_j>=* -* <psi_i|(x-x_M)(y-y_M)|psi_j>+(x_M-x_o)*<psi_i|y-y_M|psi_j>+... * -* But the last dipole term may need to be transformed further if y_M * -* for the quadrupoles are not the same as y_M for the dipoles. This is * -* the explanation for the somewhat "sliskiga" expression below for the * -* quadrupoles. * -*----------------------------------------------------------------------* - If(nMlt.gt.3) then !This number is connected to for how high - !order of multipole we have implemented below. - Write(6,*) - Write(6,*)'Too high order of multipole in MME.' - Call Quit(_RC_INTERNAL_ERROR_) - Endif - nMul=0 - Do 210, i=1,nMlt - nMul=nMul+i*(i+1)/2 -210 Continue - Do 2101, iMlt=1,nMul - Write(ChCo,'(I2.2)')iMlt - Write(MMElab,*)'MME'//ChCo - Call GetMem(MMElab,'Allo','Real',iMME(iMlt),nSize) -2101 Continue - -* -*-- The MME. -* - kaunt=0 - Do 211, iB1=1,nBas - Do 212, iB2=1,iB1 -* -*-- The charge. No translation. -* - Work(iMME(1)+kaunt)=Work(iMult(1,1)+kaunt) -* -*-- The dipole. Translation gives rise to charge. -* - Do 221, i=1,3 - Corr=(CordMul(2,i)-xyz(nBasAt(iB1),nBasAt(iB2),i)) - & *Work(iMult(1,1)+kaunt) - Work(iMME(i+1)+kaunt)=Work(iMult(2,i)+kaunt)+Corr -221 Continue -* -*-- The quadrupole. Translation gives rise to dipoles and charges. -* Also we have to keep track of the centers for the integrals computed -* by Seward. -* - Do 222, i=1,6 - CorrDip1=(CordMul(3,iX(i))-xyz(nBasAt(iB1),nBasAt(iB2),iX(i))) - & *(Work(iMult(2,iY(i))+kaunt) - & +(CordMul(2,iY(i))-CordMul(3,iY(i))) - & *Work(iMult(1,1)+kaunt)) - CorrDip2=(CordMul(3,iY(i))-xyz(nBasAt(iB1),nBasAt(iB2),iY(i))) - & *(Work(iMult(2,iX(i))+kaunt) - & +(CordMul(2,iX(i))-CordMul(3,iX(i))) - & *Work(iMult(1,1)+kaunt)) - CorrOvl=(CordMul(3,iX(i))-xyz(nBasAt(iB1),nBasAt(iB2),iX(i))) - & *(CordMul(3,iY(i))-xyz(nBasAt(iB1),nBasAt(iB2),iY(i))) - & *Work(iMult(1,1)+kaunt) - Work(iMME(i+4)+kaunt)=Work(iMult(3,i)+kaunt) - & +CorrDip1+CorrDip2+CorrOvl -222 Continue - kaunt=kaunt+1 -212 Continue -211 Continue - -* -*-- Deallocations. -* - Do 301,iMlt=1,nMlt - nComp=iMlt*(iMlt+1)/2 - Do 302, iComp=1,nComp - Write(ChCo,'(I2.2)')iMlt - Write(ChCo2,'(I2.2)')iComp - Write(MemLab,*)'MEM'//ChCo//ChCo2 - Call GetMem(MemLab,'Free','Real',iMult(iMlt,iComp),nSize+4) -302 Continue -301 Continue - Call ClsOne(irc,Lu_One) - - Return - End diff -Nru openmolcas-22.02/src/qmstat/multinew.F90 openmolcas-22.10/src/qmstat/multinew.F90 --- openmolcas-22.02/src/qmstat/multinew.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/multinew.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,294 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Anders Ohrn * +!*********************************************************************** +! MultiNew +! +!> @brief +!> Perform the MME in contracted AO-basis +!> @author A. Ohrn +!> +!> @details +!> (i) Read in the multipole integrals from Seward. (ii) Construct +!> some data to simplify accessing the computed data. (iii) Make +!> the actual MME. +!> +!> @note +!> Requires numbers taken from ::qfread. We also need some integrals +!> that supposedly have been computed by Seward. +!> +!> @param[in] nAt Number of atoms in QM-molecule +!> @param[in] nBas Number of contracted basis functions +!> @param[in] nOcc Number of basis functions of the \f$ i \f$ -th atom-type +!> @param[in] natyp Number of atoms of the \f$ i \f$ -th atom-type +!> @param[in] nntyp Number of atom-types +!> @param[out] MME The multicenter multipole expanded densities of unique pairs of contracted basis functions +!> @param[out] iCenTri Set of indices that tells to which center the \f$ i \f$ -th unique pair of basis functions in a lower +!> triangularly stored matrix belongs +!> @param[out] iCenTriT Just like \p iCenTri, but in square shape +!> @param[out] nMlt Highest multipole in MME +!> @param[out] outxyz Expansion centers in molecule +!> @param[in] lSlater +!*********************************************************************** + +subroutine MultiNew(nAt,nBas,nOcc,natyp,nntyp,MME,iCenTri,iCenTriT,nMlt,outxyz,lSlater) + +use qmstat_global, only: MxMltp +use Index_Functions, only: nTri3_Elem, nTri_Elem +use Data_Structures, only: Alloc1DArray_Type, Allocate_DT, Deallocate_DT +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nAt, nBas, nntyp, nOcc(nntyp), natyp(nntyp) +type(Alloc1DArray_Type), intent(out) :: MME(nTri3_Elem(MxMltp)) +integer(kind=iwp), intent(out) :: iCenTri(nTri_Elem(nBas)), iCenTriT(nBas,nBas), nMlt +real(kind=wp), intent(out) :: outxyz(3,nTri_Elem(nAt)) +logical(kind=iwp), intent(in) :: lSlater +integer(kind=iwp) :: i, iAt, iB1, iB2, iComp, iDum(1), iMlt, Ind, Indie, IndiePrev, iOpt, irc, iSmLbl, j, kaunt, kaunter, LMltSlq, & + Lu_One, nB1Prev, nB2Prev, nBasA, nComp, nMul, nSize +real(kind=wp) :: CordMul(MxMltp,3), Corr, CorrDip1, CorrDip2, CorrOvl +logical(kind=iwp) :: Changed1, Changed2, Lika +character(len=20) :: MemLab +character(len=2) :: ChCo, ChCo2 +integer(kind=iwp), allocatable :: nBasAt(:) +real(kind=wp), allocatable :: xyz(:,:,:) +type(Alloc1DArray_Type), allocatable :: Mult(:,:) +integer(kind=iwp), parameter :: iX(6) = [1,1,1,2,2,3], iY(6) = [1,2,3,2,3,3] +character(len=9), parameter :: Integrals(3) = ['MLTPL 0','MLTPL 1','MLTPL 2'] +integer(kind=iwp), external :: IsFreeUnit +#include "warnings.h" +!Jose.No Nuclear charges in Slater + +!----------------------------------------------------------------------* +! Read the multipole integrals in contracted AO-basis. * +!----------------------------------------------------------------------* +irc = -1 +Lu_One = IsFreeUnit(49) +call OpnOne(irc,0,'ONEINT',Lu_One) +if (irc /= 0) then + write(u6,*) + write(u6,*) 'ERROR! Could not open one-electron integral file.' + call Quit(_RC_IO_ERROR_READ_) +end if + +call Allocate_DT(Mult,[1,MxMltp],[1,nTri_Elem(MxMltp)],label='Mult') + +! This loop will terminate when no more multipole integrals are +! available, hence there is not a problem that we apparently loop +! over MxMltpl, which is a fixed number. + +outer: do iMlt=1,MxMltp + nComp = nTri_Elem(iMlt) + do iComp=1,nComp + irc = -1 + iOpt = 1 + iSmLbl = 1 + call iRdOne(irc,iOpt,integrals(iMlt),iComp,iDum,iSmLbl) + if (irc == 0) nSize = iDum(1) + if (irc /= 0) then + if (iComp /= 1) then + write(u6,*) + write(u6,*) 'ERROR! Failed to read number of one-electron integrals.' + call Quit(_RC_IO_ERROR_READ_) + else !Normal exit here. + nMlt = iMlt-1 + exit outer + end if + end if + if (nSize /= 0) then + write(ChCo,'(I2.2)') iMlt + write(ChCo2,'(I2.2)') iComp + write(MemLab,*) 'MEM'//ChCo//ChCo2 + call mma_allocate(Mult(iMlt,iComp)%A,nSize+4,label=MemLab) + irc = -1 + iOpt = 0 + iSmLbl = 0 + call RdOne(irc,iOpt,integrals(iMlt),iComp,Mult(iMlt,iComp)%A,iSmLbl) !Collect integrals + else + write(u6,*) + write(u6,*) 'ERROR! Problem reading ',integrals(iMlt) + call Quit(_RC_IO_ERROR_READ_) + end if + end do + CordMul(iMlt,:) = Mult(iMlt,1)%A(nSize+1:3) + nMlt = MxMltp +end do outer + +!----------------------------------------------------------------------* +! Collect centers from preceeding MpProp calculation. Compute two * +! index vectors. First one gives index of atom on which the ith basis * +! function is centered. The other (iCenTri) gives to which center the * +! ith unique basis function product belong. * +!----------------------------------------------------------------------* +call mma_allocate(xyz,3,nAt,nAt,label='xyz') +call Get_Centers(nAt,xyz) +do i=1,nAt + outxyz(:,i) = xyz(:,i,i) +end do +kaunt = nAt +do i=1,nAt + do j=1,i-1 + kaunt = kaunt+1 + outxyz(:,kaunt) = xyz(:,i,j) + end do +end do +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++* +!Jose. Collect data of the Slater representation of the Quantum System * +! Prefactors, Exponents, PointNuclearCharges. * +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++* +if (lSlater) then + call Get_Slater(LMltSlQ,outxyz,nAt) + + if (LMltSlQ+1 /= nMlt) then + write(u6,*) 'ERROR! Multipole order',LMltSlQ,' in DiffPr file is different from order',nMlt-1, & + ' in One-electron file. Check your files.' + call Quit(_RC_GENERAL_ERROR_) + end if +end if + +call mma_allocate(nBasAt,nBas,label='nBasAt') + +kaunter = 0 +iAt = 0 +do i=1,nntyp + nBasA = nOcc(i)/natyp(i) + do j=1,natyp(i) + iAt = iAt+1 + nBasAt(kaunter+1:kaunter+nBasA) = iAt + kaunter = kaunter+nBasA + end do +end do + +kaunter = 0 +Indie = nAt +IndiePrev = 1 +nB1Prev = 1 +nB2Prev = 1 +do iB1=1,nBas !Count over unique pairs of bas.func. + do iB2=1,iB1 + kaunter = kaunter+1 + Lika = nBasAt(iB1) == nBasAt(iB2) + if (Lika) then !If equal indices, then take that number. + iCenTri(kaunter) = nBasAt(iB1) + nB1Prev = nBasAt(iB1) + nB2Prev = nBasAt(iB2) + else + Changed1 = nB1Prev /= nBasAt(iB1) !Check if changed atom. + Changed2 = nB2Prev /= nBasAt(iB2) + if (Changed1 .and. (.not. Changed2)) then !Case when from center 1 to nAt+1. + Indie = Indie+1 + nB1Prev = nBasAt(iB1) + IndiePrev = Indie + else if (Changed2 .and. (.not. Changed1)) then + ! Moving to new atom horizontally in lower triangular + ! matrix. If it is a jump back to left corner, + ! do not increase index, but get old one. + if (iB2 == 1) then + Indie = IndiePrev + else + Indie = Indie+1 + end if + nB2Prev = nBasAt(iB2) + else if (Changed1 .and. Changed2) then !Changing both atoms. + Indie = Indie+1 + nB1Prev = nBasAt(iB1) + nB2Prev = nBasAt(iB2) + IndiePrev = Indie + end if + iCenTri(kaunter) = Indie + end if + end do +end do +Ind = 0 +do i=1,nBas !Let's be square. + do j=1,i + Ind = Ind+1 + iCenTriT(i,j) = iCenTri(ind) + iCenTriT(j,i) = iCenTri(ind) + end do +end do + +!----------------------------------------------------------------------* +! Start the MME. To get a MME-dipole, we want <psi_i|x-x_o|psi_j> but * +! we have <psi_i|x-x_M|psi_j> where x_o is the chosen MME-center, while* +! x_M is the center that Molcas uses. We transform in this manner: * +! <psi_i|x-x_o|psi_j> = <psi_i|x-x_M|psi_j>+(x_M-x_o)*<psi_i|psi_j>. * +! The quadrupole contains a further complication: not only must we * +! include more terms, but the dipole correction may not be the MME- * +! dipole due to that Molcas may not have used the same center for * +! dipoles and quadrupoles. Let have a look: * +! <psi_i|(x-x_o)(y-y_o)|psi_j>= * +! <psi_i|(x-x_M)(y-y_M)|psi_j>+(x_M-x_o)*<psi_i|y-y_M|psi_j>+... * +! But the last dipole term may need to be transformed further if y_M * +! for the quadrupoles are not the same as y_M for the dipoles. This is * +! the explanation for the somewhat "sliskiga" expression below for the * +! quadrupoles. * +!----------------------------------------------------------------------* +if (nMlt > 3) then !This number is connected to for how high order of multipole we have implemented below. + write(u6,*) + write(u6,*) 'Too high order of multipole in MME.' + call Quit(_RC_INTERNAL_ERROR_) +end if +nMul = 0 +do i=1,nMlt + nMul = nMul+nTri_Elem(i) +end do +do iMlt=1,nMul + write(ChCo,'(I2.2)') iMlt + call mma_allocate(MME(iMlt)%A,nSize,label='MME'//ChCo) +end do + +! The MME. + +kaunt = 0 +do iB1=1,nBas + do iB2=1,iB1 + kaunt = kaunt+1 + + ! The charge. No translation. + + MME(1)%A(kaunt) = Mult(1,1)%A(kaunt) + + ! The dipole. Translation gives rise to charge. + + do i=1,3 + Corr = (CordMul(2,i)-xyz(i,nBasAt(iB1),nBasAt(iB2)))*Mult(1,1)%A(kaunt) + MME(i+1)%A(kaunt) = Mult(2,i)%A(kaunt)+Corr + end do + + ! The quadrupole. Translation gives rise to dipoles and charges. + ! Also we have to keep track of the centers for the integrals computed + ! by Seward. + + do i=1,6 + CorrDip1 = (CordMul(3,iX(i))-xyz(iX(i),nBasAt(iB1),nBasAt(iB2)))* & + (Mult(2,iY(i))%A(kaunt)+(CordMul(2,iY(i))-CordMul(3,iY(i)))*Mult(1,1)%A(kaunt)) + CorrDip2 = (CordMul(3,iY(i))-xyz(iY(i),nBasAt(iB1),nBasAt(iB2)))* & + (Mult(2,iX(i))%A(kaunt)+(CordMul(2,iX(i))-CordMul(3,iX(i)))*Mult(1,1)%A(kaunt)) + CorrOvl = (CordMul(3,iX(i))-xyz(iX(i),nBasAt(iB1),nBasAt(iB2)))* & + (CordMul(3,iY(i))-xyz(iY(i),nBasAt(iB1),nBasAt(iB2)))*Mult(1,1)%A(kaunt) + MME(i+4)%A(kaunt) = Mult(3,i)%A(kaunt)+CorrDip1+CorrDip2+CorrOvl + end do + end do +end do + +! Deallocations. + +call mma_deallocate(nBasAt) +call mma_deallocate(xyz) +call Deallocate_DT(Mult) + +call ClsOne(irc,Lu_One) + +return + +end subroutine MultiNew diff -Nru openmolcas-22.02/src/qmstat/niceoutput.f openmolcas-22.10/src/qmstat/niceoutput.f --- openmolcas-22.02/src/qmstat/niceoutput.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/niceoutput.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,193 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine NiceOutPut(EelP,Gam,Gamma,BetaBol) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "real.fh" -#include "warnings.h" -#include "constants.fh" - - Parameter (Conver1=1.0d10*CONST_BOHR_RADIUS_IN_SI_) - Parameter (Conver2=2.0d0*Pi/360.0d0) - Character*3 EelP - Character*40 Word1,Word2,Word3 - Logical Eq,Pr,It,Cl,Qu - External Len_TrimAO - -* -*-- Enter. -* - -* -*-- Make sure that the string is of correct length. -* - If(Len_TrimAO(EelP).ne.3) then - Write(6,*)'Illegal call to NiceOutPut' - Call Quit(_RC_INTERNAL_ERROR_) - Endif - -* -*-- Check what type of output that is requested. -* - Eq=.false. - Pr=.false. - It=.false. - Cl=.false. - Qu=.false. - If(index(EelP,'E').ne.0) Eq=.true. - If(index(EelP,'P').ne.0) Pr=.true. - If(index(EelP,'I').ne.0) It=.true. - If(index(EelP,'C').ne.0) Cl=.true. - If(index(EelP,'Q').ne.0) Qu=.true. - -* -*-- Start printing! -* -* -*-- With aid of concatenation, we here construct a header. -* - Write(6,*) - Write(6,*) - Write(6,*)'- - - - - - - - - - - - - - - - - - - - - - - - - - -' - &//' - - - - - - - - - - - -' - Write(6,*)' * * * * * * * * * * * * * ' - &//' * * * * * * ' - Write(6,*)' - - - - - - - - - - - - - - - - - - - - - - - - - - ' - &//'- - - - - - - - - - - -' - Write(6,*) - If(It) then - Write(Word1,*)'QMStat simulation commencing: ' - Else - Write(Word1,*)'SampFile analysis commencing' - Endif - If(Cl) then - Write(Word2,*)'All Classical ' - Elseif(Qu) then - Write(Word2,*)'Combined Quantum-Classical ' - Else - Write(Word2,*)' ' - Endif - If(Eq) then - Write(Word3,*)'Equilibration' - Elseif(Pr) then - Write(Word3,*)'Production' - Else - Write(Word3,*)' ' - Endif - iM1=Len_TrimAO(Word1) - iM2=Len_TrimAO(Word2) - iM3=Len_TrimAO(Word3) - Write(6,*)Word1(1:iM1)//Word2(1:iM2)//Word3(1:iM3) - -* -*-- Now dump a lot of information. -* - If(It) then - Write(6,*) - Write(6,*) - Write(6,11)'* Parameters of the calculation *' - Write(6,*) - Write(6,12)'--Macroscopic quantities' - Write(6,12)' Temperature(K) Pressure(Atm.) Permitivity' - Write(6,13)Temp,Pres,Diel - Write(6,12)'--Maximal MC-Step parameters' - Write(6,12)' Translation(Ang.) Rotation(deg.) ' - &//'Cavity Radius(Ang.)' - Write(6,13)delX*Conver1,delFi/Conver2,delR*Conver1 - Write(6,12)'--Configuration data' - Write(6,12)' Initial conf. Writing conf. MC-Steps' - If(iNrIn.ge.0) - & Write(6,14)iNrIn,iNrUt,nMicro*nMacro - If(iNrIn.lt.0) - & Write(6,15)' Random/Input',iNrUt,nMicro*nMacro - If(QmType(1:4).ne.'RASS') then - Write(6,12)'--Hartree-Fock simulation data' - Write(6,12)' Total Occupation Number of Orbitals' - Write(6,16)iOcc1,iOrb(1) - Else - Write(6,12)'--Rassi state simulation data' - Write(6,12)' State interacting with solvent' - If(.not.lCiSelect) then - Write(6,17)nEqState - Else - Write(6,12)' CI-select overlap option used' - Endif - Write(6,12)' State threshold Density threshold' - If(MoAveRed.and.ContrStateB) then - Write(6,18)ThrsCont,ThrsRedOcc - Elseif(MoAveRed.and..not.ContrStateB) then - Write(6,19)' N/A',ThrsRedOcc - Elseif(.not.MoAveRed.and.ContrStateB) then - Write(6,20)ThrsCont,'N/A' - Else - Write(6,12)' N/A N/A' - Endif - If(nLvlShift.ne.0) then - Write(6,12)' Level shift applied' - Endif - Endif - Endif - Write(6,*) - Write(6,*)' - - - - - - - - - - - - - - - - - - - - - - - - - - ' - &//'- - - - - - - - - - - -' - Write(6,*)' * * * * * * * * * * * * * ' - &//' * * * * * * ' - Write(6,*)'- - - - - - - - - - - - - - - - - - - - - - - - - - -' - &//' - - - - - - - - - - - -' - Write(6,*) - If(iT) then - Write(6,*) - Write(6,*)'Simulation progress.' - Write(6,*) - Endif - -* -*-- Some formats -* -11 Format(' ',A) -12 Format(' ',A) -13 Format(' ',3(F10.4,' ')) -14 Format(' ',3(I8,' ')) -15 Format(' ',A,2(I8,' ')) -16 Format(' ',2(I5,' ')) -17 Format(' ',I5) -18 Format(' ',2(E11.4,' '),' ') -19 Format(' ',A,' ',E11.4) -20 Format(' ',E11.4,' ',A) - -* -*-- Tschuss -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real(Gam) - Call Unused_real(Gamma) - Call Unused_real(BetaBol) - End If - End - - -*-------------------------------------------------------------------------* -* A subroutine that emulates the len_trim of later Fortran versions, but * -* that is missing in some Fortran 77 compilers. * -*-------------------------------------------------------------------------* - Integer Function Len_TrimAO(String) - Character*(*) String - Do 15,i=Len(String),1,-1 - If(String(i:i).ne.' ') Go To 20 -15 Continue -20 Continue - Len_TrimAO=i - Return - End diff -Nru openmolcas-22.02/src/qmstat/niceoutput.F90 openmolcas-22.10/src/qmstat/niceoutput.F90 --- openmolcas-22.02/src/qmstat/niceoutput.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/niceoutput.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,141 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine NiceOutPut(EelP) + +use qmstat_global, only: ContrStateB, DelFi, DelR, DelX, Diel, iNrIn, iNrUt, iOcc1, iOrb, lCiSelect, MoAveRed, nEqState, & + nLvlShift, nMacro, nMicro, Pres, QmType, Temp, ThrsCont, ThrsRedOcc +use Constants, only: Angstrom, deg2rad +use Definitions, only: iwp, u6 + +implicit none +character(len=3), intent(in) :: EelP +logical(kind=iwp) :: Cl, Eq, It, Pr, Qu +character(len=40) :: Word1, Word2, Word3 +#include "warnings.h" + +! Enter. + +! Make sure that the string is of correct length. + +if (len_trim(EelP) /= 3) then + write(u6,*) 'Illegal call to NiceOutPut' + call Quit(_RC_INTERNAL_ERROR_) +end if + +! Check what type of output that is requested. + +Eq = index(EelP,'E') /= 0 +Pr = index(EelP,'P') /= 0 +It = index(EelP,'I') /= 0 +Cl = index(EelP,'C') /= 0 +Qu = index(EelP,'Q') /= 0 + +! Start printing! + +! With aid of concatenation, we here construct a header. + +write(u6,*) +write(u6,*) +write(u6,*) '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -' +write(u6,*) ' * * * * * * * * * * * * * * * * * * * ' +write(u6,*) '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -' +write(u6,*) +if (It) then + write(Word1,*) 'QMStat simulation commencing: ' +else + write(Word1,*) 'SampFile analysis commencing' +end if +if (Cl) then + write(Word2,*) 'All Classical ' +else if (Qu) then + write(Word2,*) 'Combined Quantum-Classical ' +else + write(Word2,*) ' ' +end if +if (Eq) then + write(Word3,*) 'Equilibration' +else if (Pr) then + write(Word3,*) 'Production' +else + write(Word3,*) ' ' +end if +write(u6,*) trim(Word1)//trim(Word2)//trim(Word3) + +! Now dump a lot of information. + +if (It) then + write(u6,*) + write(u6,*) + write(u6,11) '* Parameters of the calculation *' + write(u6,*) + write(u6,12) '--Macroscopic quantities' + write(u6,12) ' Temperature(K) Pressure(Atm.) Permitivity' + write(u6,13) Temp,Pres,Diel + write(u6,12) '--Maximal MC-Step parameters' + write(u6,12) ' Translation(Ang.) Rotation(deg.) Cavity Radius(Ang.)' + write(u6,13) delX*Angstrom,delFi/deg2rad,delR*Angstrom + write(u6,12) '--Configuration data' + write(u6,12) ' Initial conf. Writing conf. MC-Steps' + if (iNrIn >= 0) write(u6,14) iNrIn,iNrUt,nMicro*nMacro + if (iNrIn < 0) write(u6,15) ' Random/Input',iNrUt,nMicro*nMacro + if (QmType(1:4) /= 'RASS') then + write(u6,12) '--Hartree-Fock simulation data' + write(u6,12) ' Total Occupation Number of Orbitals' + write(u6,16) iOcc1,iOrb(1) + else + write(u6,12) '--Rassi state simulation data' + write(u6,12) ' State interacting with solvent' + if (.not. lCiSelect) then + write(u6,17) nEqState + else + write(u6,12) ' CI-select overlap option used' + end if + write(u6,12) ' State threshold Density threshold' + if (MoAveRed .and. ContrStateB) then + write(u6,18) ThrsCont,ThrsRedOcc + else if (MoAveRed .and. (.not. ContrStateB)) then + write(u6,19) ' N/A',ThrsRedOcc + else if ((.not. MoAveRed) .and. ContrStateB) then + write(u6,20) ThrsCont,'N/A' + else + write(u6,12) ' N/A N/A' + end if + if (nLvlShift > 0) write(u6,12) ' Level shift applied' + end if +end if +write(u6,*) +write(u6,*) '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -' +write(u6,*) ' * * * * * * * * * * * * * * * * * * * ' +write(u6,*) '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -' +write(u6,*) +if (iT) then + write(u6,*) + write(u6,*) 'Simulation progress.' + write(u6,*) +end if + +! Tschuss + +return + +11 format(' ',A) +12 format(' ',A) +13 format(' ',3(F10.4,' ')) +14 format(' ',3(I8,' ')) +15 format(' ',A,2(I8,' ')) +16 format(' ',2(I5,' ')) +17 format(' ',I5) +18 format(' ',2(E11.4,' '),' ') +19 format(' ',A,' ',E11.4) +20 format(' ',E11.4,' ',A) + +end subroutine NiceOutPut diff -Nru openmolcas-22.02/src/qmstat/noverp_q.F90 openmolcas-22.10/src/qmstat/noverp_q.F90 --- openmolcas-22.02/src/qmstat/noverp_q.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/noverp_q.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,42 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Anders Ohrn * +!*********************************************************************** + +!----------------------------------------------------------------------* +! A function that returns the binomial coefficient. The coefficients * +! are stored since N and P will not under normal circumstances be * +! so large. * +!----------------------------------------------------------------------* +function NoverP_Q(N,P) + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp, u6 + +implicit none +integer(kind=iwp) :: NoverP_Q +integer(kind=iwp), intent(in) :: N, P +integer(kind=iwp) :: ind +integer(kind=iwp), parameter :: Bino(21) = [1,1,1,1,2,1,1,3,3,1,1,4,6,4,1,1,5,10,10,5,1] +#include "warnings.h" + +NoverP_Q = 1 +if (N >= 6) then + write(u6,*) 'Must extend NoverP_Q!' + call Quit(_RC_INTERNAL_ERROR_) +else + ind = nTri_Elem1(N)-(N-P) + NoverP_Q = Bino(ind) +end if + +return + +end function NoverP_Q diff -Nru openmolcas-22.02/src/qmstat/numbers.fh openmolcas-22.10/src/qmstat/numbers.fh --- openmolcas-22.02/src/qmstat/numbers.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/numbers.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,12 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -#include "real.fh" - Parameter(iONE=1,iZERO=0,iTHREE=3,iSIX=6) diff -Nru openmolcas-22.02/src/qmstat/nypart.f openmolcas-22.10/src/qmstat/nypart.f --- openmolcas-22.02/src/qmstat/nypart.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/nypart.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,62 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - SUBROUTINE NYPART(iExtra,nPart,COORD,Rstart,nCent,iSeed) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "warnings.h" - - DIMENSION COORD(MxCen*MxPut,3) - External Ranf - -*Preparing some numbers - iMAXVAR=100*iExtra**2 - IN=1 - IVARV=0 - RLIM=RSTART-8.5d0 - rlm=rlim*2. - RLIM2=RLIM**2 -*Check if not all molecules been put out in reasonable time - 100 IF(IVARV.GE.iMAXVAR) Then - Write(6,*)'Failure to add particles. Try to increase the dielec' - &//'tric radie or change the random seed.' - Call Quit(_RC_GENERAL_ERROR_) - EndIf -*Here is the random change relative the first user definied water - DX=ranf(iseed)*RLM-rlim - DY=ranf(iseed)*RLM-rlim - DZ=ranf(iseed)*RLM-rlim - DR=DX*DX+DY*DY+DZ*DZ - IVARV=IVARV+1 - IF(DR.GT.RLIM2)GO TO 100 - IND=IN+NPART - X=DX+COORD(1,1) - Y=DY+COORD(1,2) - Z=DZ+COORD(1,3) -*Check so that two water molecules do not come too close... - DO 10 I=1,IND*NCENT,NCENT - R2=(COORD(I,1)-X)**2+(COORD(I,2)-Y)**2+(COORD(I,3)-Z)**2 - IF(R2.LT.60d0)Go To 100 -10 CONTINUE -*...and if they do not then shove its coordinates in variable - IN=IN+1 - IA=(IN+NPART-1)*NCENT - DO 20 I=1,NCENT - COORD(IA+I,1)=COORD(I,1)+DX - COORD(IA+I,2)=COORD(I,2)+DY - COORD(IA+I,3)=COORD(I,3)+DZ -20 Continue -*Check if all water molecules have been put where they should - IF(IN.LT.(IEXTRA)) GO TO 100 -*Give nPart its new value and exit gracefully - NPART=NPART+IEXTRA - RETURN - END diff -Nru openmolcas-22.02/src/qmstat/nypart.F90 openmolcas-22.10/src/qmstat/nypart.F90 --- openmolcas-22.02/src/qmstat/nypart.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/nypart.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,70 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine NYPART(iExtra,nPart,COORD,rStart,nCent,iSeed) + +use Constants, only: Two +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iExtra, nCent +integer(kind=iwp), intent(inout) :: nPart, iSeed +real(kind=wp), intent(inout) :: COORD(3,(nPart+iExtra)*nCent) +real(kind=wp), intent(in) :: rStart +integer(kind=iwp) :: I, IA, IIN, iMAXVAR, IND, IVARV +real(kind=wp) :: DR, DX, DY, DZ, R2, RLIM, RLIM2, rlm, X, Y, Z +real(kind=wp), external :: Random_Molcas +#include "warnings.h" + +! Preparing some numbers +iMAXVAR = 100*iExtra**2 +IIN = 1 +IVARV = 0 +RLIM = rStart-8.5_wp +rlm = rlim*Two +RLIM2 = RLIM**Two +! Check if not all molecules been put out in reasonable time +outer: do + if (IVARV >= iMAXVAR) then + write(u6,*) 'Failure to add particles. Try to increase the dielectric radie or change the random seed.' + call Quit(_RC_GENERAL_ERROR_) + end if + ! Here is the random change relative the first user defined water + DX = Random_Molcas(iseed)*RLM-rlim + DY = Random_Molcas(iseed)*RLM-rlim + DZ = Random_Molcas(iseed)*RLM-rlim + DR = DX*DX+DY*DY+DZ*DZ + IVARV = IVARV+1 + if (DR > RLIM2) cycle outer + IND = IIN+NPART + X = DX+COORD(1,1) + Y = DY+COORD(2,1) + Z = DZ+COORD(3,1) + ! Check so that two water molecules do not come too close... + do I=1,IND*NCENT,NCENT + R2 = (COORD(1,I)-X)**2+(COORD(2,I)-Y)**2+(COORD(3,I)-Z)**2 + if (R2 < 60.0_wp) cycle outer + end do + ! ...and if they do not then shove its coordinates in variable + IIN = IIN+1 + IA = (IIN+NPART-1)*NCENT + COORD(1,IA+1:NCENT) = COORD(1,1:NCENT)+DX + COORD(2,IA+1:NCENT) = COORD(2,1:NCENT)+DY + COORD(3,IA+1:NCENT) = COORD(3,1:NCENT)+DZ + ! Check if all water molecules have been put where they should + if (IIN >= IEXTRA) exit outer +end do outer +! Give nPart its new value and exit gracefully +NPART = NPART+IEXTRA + +return + +end subroutine NYPART diff -Nru openmolcas-22.02/src/qmstat/offatom.f openmolcas-22.10/src/qmstat/offatom.f --- openmolcas-22.02/src/qmstat/offatom.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/offatom.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine OffAtom(C1,C2,C3,C4,C5) - Implicit Real*8 (a-z) - -#include "constants.fh" -#include "real.fh" - Parameter (AuAng=1d10*CONST_BOHR_RADIUS_IN_SI_) - Dimension C1(3),C2(3),C3(3),C4(3),C5(3) - Dimension D(3),E(3),U(3),V(3) - - D(1)=(C2(1)+C3(1))/2-C1(1) - D(2)=(C2(2)+C3(2))/2-C1(2) - D(3)=(C2(3)+C3(3))/2-C1(3) - LD=sqrt(D(1)**2+D(2)**2+D(3)**2) - D(1)=D(1)/LD - D(2)=D(2)/LD - D(3)=D(3)/LD - - U(1)=C2(1)-C1(1) - U(2)=C2(2)-C1(2) - U(3)=C2(3)-C1(3) - V(1)=C3(1)-C1(1) - V(2)=C3(2)-C1(2) - V(3)=C3(3)-C1(3) - E(1)=U(2)*V(3)-V(2)*U(3) - E(2)=U(3)*V(1)-V(3)*U(1) - E(3)=U(1)*V(2)-V(1)*U(2) - LE=sqrt(E(1)**2+E(2)**2+E(3)**2) - E(1)=E(1)/LE - E(2)=E(2)/LE - E(3)=E(3)/LE - - C4(1)=C1(1)+(0.2767d0/AuAng)*cos(36.72d0*2d0*Pi/360d0)*D(1) - & +(0.2767d0/AuAng)*sin(36.72d0*2d0*Pi/360d0)*E(1) - C4(2)=C1(2)+(0.2767d0/AuAng)*cos(36.72d0*2d0*Pi/360d0)*D(2) - & +(0.2767d0/AuAng)*sin(36.72d0*2d0*Pi/360d0)*E(2) - C4(3)=C1(3)+(0.2767d0/AuAng)*cos(36.72d0*2d0*Pi/360d0)*D(3) - & +(0.2767d0/AuAng)*sin(36.72d0*2d0*Pi/360d0)*E(3) - C5(1)=C1(1)+(0.2767d0/AuAng)*cos(36.72d0*2d0*Pi/360d0)*D(1) - & -(0.2767d0/AuAng)*sin(36.72d0*2d0*Pi/360d0)*E(1) - C5(2)=C1(2)+(0.2767d0/AuAng)*cos(36.72d0*2d0*Pi/360d0)*D(2) - & -(0.2767d0/AuAng)*sin(36.72d0*2d0*Pi/360d0)*E(2) - C5(3)=C1(3)+(0.2767d0/AuAng)*cos(36.72d0*2d0*Pi/360d0)*D(3) - & -(0.2767d0/AuAng)*sin(36.72d0*2d0*Pi/360d0)*E(3) - - Return - End diff -Nru openmolcas-22.02/src/qmstat/offatom.F90 openmolcas-22.10/src/qmstat/offatom.F90 --- openmolcas-22.02/src/qmstat/offatom.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/offatom.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,41 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine OffAtom(C1,C2,C3,C4,C5) + +use Constants, only: Angstrom, deg2rad +use Constants, only: Half +use Definitions, only: wp + +implicit none +real(kind=wp), intent(in) :: C1(3), C2(3), C3(3) +real(kind=wp), intent(out) :: C4(3), C5(3) +real(kind=wp) :: D(3), E(3), LD, LE, U(3), V(3) +real(kind=wp), parameter :: R = 0.2767_wp/Angstrom, Theta = 36.72_wp*deg2rad + +D(:) = (C2+C3)*Half-C1 +LD = sqrt(D(1)**2+D(2)**2+D(3)**2) +D(:) = D/LD + +U(:) = C2-C1 +V(:) = C3-C1 +E(1) = U(2)*V(3)-V(2)*U(3) +E(2) = U(3)*V(1)-V(3)*U(1) +E(3) = U(1)*V(2)-V(1)*U(2) +LE = sqrt(E(1)**2+E(2)**2+E(3)**2) +E(:) = E/LE + +C4(:) = C1+R*(cos(Theta)*D+sin(Theta)*E) +C5(:) = C1+R*(cos(Theta)*D-sin(Theta)*E) + +return + +end subroutine OffAtom diff -Nru openmolcas-22.02/src/qmstat/oldge.f openmolcas-22.10/src/qmstat/oldge.f --- openmolcas-22.02/src/qmstat/oldge.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/oldge.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -*----------------------------------------------------------------------* -*----------------------------------------------------------------------* - Subroutine Oldge(iAcc,Etot,Eold,Ract,Rold) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" - - iAcc=iAcc-1 - Etot=Eold - Ract=Rold - icCom=0 - Do 100, i=1,nPart - Do 101, j=1,nCent - icCom=icCom+1 - Do 102, k=1,3 - Cordst(icCom,k)=OldGeo(icCom,k) -102 Continue -101 Continue -100 Continue - Return - End diff -Nru openmolcas-22.02/src/qmstat/oneoverr.f openmolcas-22.10/src/qmstat/oneoverr.f --- openmolcas-22.02/src/qmstat/oneoverr.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/oneoverr.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,282 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine OneOverR(iFil,Ax,Ay,Az,BoMaH,BoMaO,EEDisp,iCNum,Eint - & ,iQ_Atoms,outxyz) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "qmcom.fh" -#include "WrkSpc.fh" - - Dimension iFil(MxQCen,10) - Dimension Eint(MxQCen,10),BoMaH(MxAt),BoMaO(MxAt),outxyz(MxQCen,3) - - EEdisp=0.0d0 -*----------------------------------------------------------------------* -* Compute some distances and inverted distances etc. The potential, * -* the field and etc. and when we already have the numbers, we also do * -* the dispersion interaction. * -*----------------------------------------------------------------------* - iCi=(iQ_Atoms*(iQ_Atoms+1))/2 - Do 601, k=1,iCi - Gx=outxyz(k,1)+Ax - Gy=outxyz(k,2)+Ay - Gz=outxyz(k,3)+Az - Do 602, j=iCnum+1,nPart - i=1+(j-1)*nCent - ip=1+(j-1)*nPol - Rabx1=Cordst(i,1)-Gx !Below follows a lot of - Raby1=Cordst(i,2)-Gy !distances to and fro. - Rabz1=Cordst(i,3)-Gz - Rabx2=Cordst(i+1,1)-Gx - Raby2=Cordst(i+1,2)-Gy - Rabz2=Cordst(i+1,3)-Gz - Rabx3=Cordst(i+2,1)-Gx - Raby3=Cordst(i+2,2)-Gy - Rabz3=Cordst(i+2,3)-Gz - Rabx4=Cordst(i+3,1)-Gx - Raby4=Cordst(i+3,2)-Gy - Rabz4=Cordst(i+3,3)-Gz - Rabx5=Cordst(i+4,1)-Gx - Raby5=Cordst(i+4,2)-Gy - Rabz5=Cordst(i+4,3)-Gz - R21=Rabx1**2+Raby1**2+Rabz1**2 - R22=Rabx2**2+Raby2**2+Rabz2**2 - R23=Rabx3**2+Raby3**2+Rabz3**2 - R24=Rabx4**2+Raby4**2+Rabz4**2 - R25=Rabx5**2+Raby5**2+Rabz5**2 - Rg1=Sqrt(r21) - Rg2=Sqrt(r22) - Rg3=Sqrt(r23) - Rg4=Sqrt(r24) - Rg5=Sqrt(r25) - S1i=1/Rg1 - S2i=1/Rg2 - S3i=1/Rg3 - S4i=1/Rg4 - S5i=1/Rg5 - S1e=S1i - S2e=S2i - S3e=S3i - S4e=S4i - S5e=S5i - Eint(k,1)=-Qsta(1)*S2e-Qsta(2)*S3e-Qsta(3)*S4e !This term - & -Qsta(4)*S5e+Eint(k,1) !will below turn into - Rab13i=S1e/R21 !the interaction between charges - Rab23i=S2e/R22 !on water and the MME-charges on - Rab33i=S3e/R23 !the QM-molecule. - Rab43i=S4e/R24 - Rab53i=S5e/R25 -*----------------------------------------------------------------------* -* The dispersion interaction between QM-atoms and solvent is computed, * -* with or without damping. The initial if-clause sees to that only * -* atom-centers are included, while bonds and virtual centers are * -* ignored. * -*----------------------------------------------------------------------* - If(k.le.iQ_atoms) then - Call DispEnergy(EEDisp,BoMah,BoMaO,rg1,rg2,rg3 - & ,Rab13i,Rab23i,Rab33i,k) - Endif -*----------------------------------------------------------------------* -* Now we wrap up the electrostatics. * -*----------------------------------------------------------------------* - Ux1=RabX1*s1i - Uy1=RabY1*s1i - Uz1=RabZ1*s1i - Ux2=RabX2*s2i - Uy2=RabY2*s2i - Uz2=RabZ2*s2i - Ux3=RabX3*s3i - Uy3=RabY3*s3i - Uz3=RabZ3*s3i - Ux4=RabX4*s4i - Uy4=RabY4*s4i - Uz4=RabZ4*s4i - Ux5=RabX5*s5i - Uy5=RabY5*s5i - Uz5=RabZ5*s5i - !These three terms will below turn into the interaction - !between water charges and the MME-dipoles on the QM-mol. - !Change sign of charge, change sign of vector and then we - !should also change sign since when a dipole interacts with - !a field we have a minus sign, but this minus sign we have - !omitted in hel; therefore this calculation gives the right - !number eventually. - Eint(k,2)=-Qsta(1)*RabX2*Rab23i-Qsta(2)*RabX3*Rab33i - &-Qsta(3)*RabX4*Rab43i-Qsta(4)*RabX5*Rab53i+Eint(k,2) - Eint(k,3)=-Qsta(1)*RabY2*Rab23i-Qsta(2)*RabY3*Rab33i - &-Qsta(3)*RabY4*Rab43i-Qsta(4)*RabY5*Rab53i+Eint(k,3) - Eint(k,4)=-Qsta(1)*RabZ2*Rab23i-Qsta(2)*RabZ3*Rab33i - &-Qsta(3)*RabZ4*Rab43i-Qsta(4)*RabZ5*Rab53i+Eint(k,4) - !And here it is the MME-quadrupoles that are prepared. - !Change sign of charges, change sign two times of the - !vector (in effect, zero times then) and then in the - !energy expression for the interaction between the field - !vector from a charge and a quarupole there is a plus - !sign, so a minus is the right sign below. - Eint(k,5)=Eint(k,5)-Qsta(1)*Ux2**2*Rab23i-Qsta(2)*Ux3**2 - &*Rab33i-Qsta(3)*Ux4**2*Rab43i-Qsta(4)*Ux5**2*Rab53i - Eint(k,7)=Eint(k,7)-Qsta(1)*Uy2**2*Rab23i-Qsta(2)*Uy3**2 - &*Rab33i-Qsta(3)*Uy4**2*Rab43i-Qsta(4)*Uy5**2*Rab53i - Eint(k,10)=Eint(k,10)-Qsta(1)*Uz2**2*Rab23i-Qsta(2)*Uz3**2 - &*Rab33i-Qsta(3)*Uz4**2*Rab43i-Qsta(4)*Uz5**2*Rab53i - Eint(k,6)=Eint(k,6)-Qsta(1)*Ux2*Uy2*Rab23i-Qsta(2)*Ux3 - &*Uy3*Rab33i-Qsta(3)*Ux4*Rab43i*Uy4-Qsta(4)*Ux5*Rab53i*Uy5 - Eint(k,8)=Eint(k,8)-Qsta(1)*Ux2*Uz2*Rab23i-Qsta(2)*Ux3 - &*Uz3*Rab33i-Qsta(3)*Ux4*Rab43i*Uz4-Qsta(4)*Ux5*Rab53i*Uz5 - Eint(k,9)=Eint(k,9)-Qsta(1)*Uz2*Uy2*Rab23i-Qsta(2)*Uz3 - &*Uy3*Rab33i-Qsta(3)*Uz4*Rab43i*Uy4-Qsta(4)*Uz5*Rab53i*Uy5 - -*----------------------------------------------------------------------* -* And now a whole lot of grad(1/r) and higher... * -*----------------------------------------------------------------------* - !Unipoles. - Work(iFil(k,1)-1+ip)=Rabx1*Rab13i - Work(iFil(k,1)-1+ip+1)=Rabx2*Rab23i - Work(iFil(k,1)-1+ip+2)=Rabx3*Rab33i - Work(iFil(k,1)-1+nPart*nPol+ip)=Raby1*Rab13i - Work(iFil(k,1)-1+nPart*nPol+ip+1)=Raby2*Rab23i - Work(iFil(k,1)-1+nPart*nPol+ip+2)=Raby3*Rab33i - Work(iFil(k,1)-1+2*nPart*nPol+ip)=Rabz1*Rab13i - Work(iFil(k,1)-1+2*nPart*nPol+ip+1)=Rabz2*Rab23i - Work(iFil(k,1)-1+2*nPart*nPol+ip+2)=Rabz3*Rab33i - !Dipole -- x-component. - Work(iFil(k,2)-1+ip)=-(1-3*Ux1**2)*Rab13i - Work(iFil(k,2)-1+ip+1)=-(1-3*Ux2**2)*Rab23i - Work(iFil(k,2)-1+ip+2)=-(1-3*Ux3**2)*Rab33i - Work(iFil(k,2)-1+nPart*nPol+ip)=Uy1*Ux1*Rab13i*3 - Work(iFil(k,2)-1+nPart*nPol+ip+1)=Uy2*Ux2*Rab23i*3 - Work(iFil(k,2)-1+nPart*nPol+ip+2)=Uy3*Ux3*Rab33i*3 - Work(iFil(k,2)-1+2*nPart*nPol+ip)=Uz1*Ux1*Rab13i*3 - Work(iFil(k,2)-1+2*nPart*nPol+ip+1)=Uz2*Ux2*Rab23i*3 - Work(iFil(k,2)-1+2*nPart*nPol+ip+2)=Uz3*Ux3*Rab33i*3 - !Dipole -- y-component. - Work(iFil(k,3)-1+ip)=Uy1*Ux1*Rab13i*3 - Work(iFil(k,3)-1+ip+1)=Uy2*Ux2*Rab23i*3 - Work(iFil(k,3)-1+ip+2)=Uy3*Ux3*Rab33i*3 - Work(iFil(k,3)-1+nPart*nPol+ip)=-(1-3*Uy1**2)*Rab13i - Work(iFil(k,3)-1+nPart*nPol+ip+1)=-(1-3*Uy2**2)*Rab23i - Work(iFil(k,3)-1+nPart*nPol+ip+2)=-(1-3*Uy3**2)*Rab33i - Work(iFil(k,3)-1+2*nPart*nPol+ip)=Uz1*Uy1*Rab13i*3 - Work(iFil(k,3)-1+2*nPart*nPol+ip+1)=Uz2*Uy2*Rab23i*3 - Work(iFil(k,3)-1+2*nPart*nPol+ip+2)=Uz3*Uy3*Rab33i*3 - !Dipole -- z-component. - Work(iFil(k,4)-1+ip)=Uz1*Ux1*Rab13i*3 - Work(iFil(k,4)-1+ip+1)=Uz2*Ux2*Rab23i*3 - Work(iFil(k,4)-1+ip+2)=Uz3*Ux3*Rab33i*3 - Work(iFil(k,4)-1+nPart*nPol+ip)=Uz1*Uy1*Rab13i*3 - Work(iFil(k,4)-1+nPart*nPol+ip+1)=Uz2*Uy2*Rab23i*3 - Work(iFil(k,4)-1+nPart*nPol+ip+2)=Uz3*Uy3*Rab33i*3 - Work(iFil(k,4)-1+2*nPart*nPol+ip)=-(1-3*Uz1**2)*Rab13i - Work(iFil(k,4)-1+2*nPart*nPol+ip+1)=-(1-3*Uz2**2)*Rab23i - Work(iFil(k,4)-1+2*nPart*nPol+ip+2)=-(1-3*Uz3**2)*Rab33i - !Quadrupole -- xx-component. - Work(iFil(k,5)-1+ip)=(5*Ux1*(Ux1*Ux1-.4))*Rab13i*S1e - Work(iFil(k,5)-1+ip+1)=(5*Ux2*(Ux2*Ux2-.4))*Rab23i*S2e - Work(iFil(k,5)-1+ip+2)=(5*Ux3*(Ux3*Ux3-.4))*Rab33i*S3e - Work(iFil(k,5)-1+nPart*nPol+ip)=5*Uy1*Ux1*Ux1*Rab13i*S1e - Work(iFil(k,5)-1+nPart*nPol+ip+1)=5*Uy2*Ux2*Ux2*Rab23i*S2e - Work(iFil(k,5)-1+nPart*nPol+ip+2)=5*Uy3*Ux3*Ux3*Rab33i*S3e - Work(iFil(k,5)-1+2*nPart*nPol+ip)=5*Uz1*Ux1*Ux1*Rab13i*S1e - Work(iFil(k,5)-1+2*nPart*nPol+ip+1)=5*Uz2*Ux2*Ux2*Rab23i*S2e - Work(iFil(k,5)-1+2*nPart*nPol+ip+2)=5*Uz3*Ux3*Ux3*Rab33i*S3e - !Quadrupole -- yy-component. - Work(iFil(k,7)-1+ip)=5*Uy1*Uy1*Ux1*Rab13i*S1e - Work(iFil(k,7)-1+ip+1)=5*Uy2*Uy2*Ux2*Rab23i*S2e - Work(iFil(k,7)-1+ip+2)=5*Uy3*Uy3*Ux3*Rab33i*S3e - Work(iFil(k,7)-1+nPart*nPol+ip)=(5*Uy1*(Uy1*Uy1-.4)) - & *Rab13i*S1e - Work(iFil(k,7)-1+nPart*nPol+ip+1)=(5*Uy2*(Uy2*Uy2-.4)) - & *Rab23i*S2e - Work(iFil(k,7)-1+nPart*nPol+ip+2)=(5*Uy3*(Uy3*Uy3-.4)) - & *Rab33i*S3e - Work(iFil(k,7)-1+2*nPart*nPol+ip)=5*Uz1*Uy1*Uy1*Rab13i*S1e - Work(iFil(k,7)-1+2*nPart*nPol+ip+1)=5*Uz2*Uy2*Uy2*Rab23i*S2e - Work(iFil(k,7)-1+2*nPart*nPol+ip+2)=5*Uz3*Uy3*Uy3*Rab33i*S3e - !Quadrupole -- zz-component. - Work(iFil(k,10)-1+ip)=5*Uz1*Uz1*Ux1*Rab13i*S1e - Work(iFil(k,10)-1+ip+1)=5*Uz2*Uz2*Ux2*Rab23i*S2e - Work(iFil(k,10)-1+ip+2)=5*Uz3*Uz3*Ux3*Rab33i*S3e - Work(iFil(k,10)-1+nPart*nPol+ip)=5*Uz1*Uz1*Uy1*Rab13i*S1e - Work(iFil(k,10)-1+nPart*nPol+ip+1)=5*Uz2*Uz2*Uy2*Rab23i*S2e - Work(iFil(k,10)-1+nPart*nPol+ip+2)=5*Uz3*Uz3*Uy3*Rab33i*S3e - Work(iFil(k,10)-1+2*nPart*nPol+ip)=(5*Uz1*(Uz1*Uz1-.4)) - & *Rab13i*S1e - Work(iFil(k,10)-1+2*nPart*nPol+ip+1)=(5*Uz2*(Uz2*Uz2-.4)) - & *Rab23i*S2e - Work(iFil(k,10)-1+2*nPart*nPol+ip+2)=(5*Uz3*(Uz3*Uz3-.4)) - & *Rab33i*S3e - !Quadrupole -- xy-component. - Work(iFil(k,6)-1+ip)=(5*Uy1*(Ux1*Ux1-.2))*Rab13i*S1e - Work(iFil(k,6)-1+ip+1)=(5*Uy2*(Ux2*Ux2-.2))*Rab23i*S2e - Work(iFil(k,6)-1+ip+2)=(5*Uy3*(Ux3*Ux3-.2))*Rab33i*S3e - Work(iFil(k,6)-1+nPart*nPol+ip)=(5*Ux1*(Uy1*Uy1-.2)) - & *Rab13i*S1e - Work(iFil(k,6)-1+nPart*nPol+ip+1)=(5*Ux2*(Uy2*Uy2-.2)) - & *Rab23i*S2e - Work(iFil(k,6)-1+nPart*nPol+ip+2)=(5*Ux3*(Uy3*Uy3-.2)) - & *Rab33i*S3e - Work(iFil(k,6)-1+2*nPart*nPol+ip)=5*Uz1*Uy1*Ux1*Rab13i*S1e - Work(iFil(k,6)-1+2*nPart*nPol+ip+1)=5*Uz2*Uy2*Ux2*Rab23i*S2e - Work(iFil(k,6)-1+2*nPart*nPol+ip+2)=5*Uz3*Uy3*Ux3*Rab33i*S3e - !Quadrupole -- xz-component. - Work(iFil(k,8)-1+ip)=(5*Uz1*(Ux1*Ux1-.2))*Rab13i*S1e - Work(iFil(k,8)-1+ip+1)=(5*Uz2*(Ux2*Ux2-.2))*Rab23i*S2e - Work(iFil(k,8)-1+ip+2)=(5*Uz3*(Ux3*Ux3-.2))*Rab33i*S3e - Work(iFil(k,8)-1+nPart*nPol+ip)=5*Uz1*Uy1*Ux1*Rab13i*S1e - Work(iFil(k,8)-1+nPart*nPol+ip+1)=5*Uz2*Uy2*Ux2*Rab23i*S2e - Work(iFil(k,8)-1+nPart*nPol+ip+2)=5*Uz3*Uy3*Ux3*Rab33i*S3e - Work(iFil(k,8)-1+2*nPart*nPol+ip)=(5*Ux1*(Uz1*Uz1-.2)) - & *Rab13i*S1e - Work(iFil(k,8)-1+2*nPart*nPol+ip+1)=(5*Ux2*(Uz2*Uz2-.2)) - & *Rab23i*S2e - Work(iFil(k,8)-1+2*nPart*nPol+ip+2)=(5*Ux3*(Uz3*Uz3-.2)) - & *Rab33i*S3e - !Quadrupole -- yz-component. - Work(iFil(k,9)-1+ip)=5*Uz1*Uy1*Ux1*Rab13i*S1e - Work(iFil(k,9)-1+ip+1)=5*Uz2*Uy2*Ux2*Rab23i*S2e - Work(iFil(k,9)-1+ip+2)=5*Uz3*Uy3*Ux3*Rab33i*S3e - Work(iFil(k,9)-1+nPart*nPol+ip)=(5*Uz1*(Uy1*Uy1-.2)) - & *Rab13i*S1e - Work(iFil(k,9)-1+nPart*nPol+ip+1)=(5*Uz2*(Uy2*Uy2-.2)) - & *Rab23i*S2e - Work(iFil(k,9)-1+nPart*nPol+ip+2)=(5*Uz3*(Uy3*Uy3-.2)) - & *Rab33i*S3e - Work(iFil(k,9)-1+2*nPart*nPol+ip)=(5*Uy1*(Uz1*Uz1-.2)) - & *Rab13i*S1e - Work(iFil(k,9)-1+2*nPart*nPol+ip+1)=(5*Uy2*(Uz2*Uz2-.2)) - & *Rab23i*S2e - Work(iFil(k,9)-1+2*nPart*nPol+ip+2)=(5*Uy3*(Uz3*Uz3-.2)) - & *Rab33i*S3e -*----------------------------------------------------------------------* -* If damping of the field is requested, then do it. * -*----------------------------------------------------------------------* - If(FieldDamp) then - Do 620, ijhr=1,10 - Do 621, jjhr=0,2 - Work(iFil(k,ijhr)-1+jjhr*nPart*nPol+ip)= - & Work(iFil(k,ijhr)-1+jjhr*nPart*nPol+ip) - & *(1-exp(CAFieldG*rg1))**CFexp - Work(iFil(k,ijhr)-1+jjhr*nPart*nPol+ip+1)= - & Work(iFil(k,ijhr)-1+jjhr*nPart*nPol+ip+1) - & *(1-exp(CBFieldG*rg2))**CFexp - Work(iFil(k,ijhr)-1+jjhr*nPart*nPol+ip+2)= - & Work(iFil(k,ijhr)-1+jjhr*nPart*nPol+ip+2) - & *(1-exp(CBFieldG*rg3))**CFexp -621 Continue -620 Continue - Endif -602 Continue -601 Continue - - Return - End diff -Nru openmolcas-22.02/src/qmstat/oneoverr.F90 openmolcas-22.10/src/qmstat/oneoverr.F90 --- openmolcas-22.02/src/qmstat/oneoverr.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/oneoverr.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,151 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine OneOverR(Fil,Ax,Ay,Az,BoMaH,BoMaO,EEDisp,iCNum,Eint,iQ_Atoms,outxyz) + +use qmstat_global, only: CAFieldG, CBFieldG, CFexp, Cordst, FieldDamp, nCent, nPart, nPol, Qsta +use Index_Functions, only: nTri_Elem +use Constants, only: Zero, One, Two, Three, Five +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iQ_Atoms, iCNum +real(kind=wp), intent(out) :: Fil(nPol*nPart,3,nTri_Elem(iQ_Atoms),10), EEDisp +real(kind=wp), intent(in) :: Ax, Ay, Az, BoMaH(iQ_Atoms), BoMaO(iQ_Atoms), outxyz(3,nTri_Elem(iQ_Atoms)) +real(kind=wp), intent(inout) :: Eint(nTri_Elem(iQ_Atoms),10) +integer(kind=iwp) :: i, ip, j, k +real(kind=wp) :: G(3), R2(5), Rab3i(5), Rab(3,5), Rg(5), Se(5), U(3,5) + +EEdisp = Zero +!----------------------------------------------------------------------* +! Compute some distances and inverted distances etc. The potential, * +! the field and etc. and when we already have the numbers, we also do * +! the dispersion interaction. * +!----------------------------------------------------------------------* +do k=1,nTri_Elem(iQ_Atoms) + G(1) = outxyz(1,k)+Ax + G(2) = outxyz(2,k)+Ay + G(3) = outxyz(3,k)+Az + do j=iCnum+1,nPart + i = (j-1)*nCent + ip = (j-1)*nPol + !Below follow a lot of distances to and fro. + Rab(:,1) = Cordst(:,i+1)-G + Rab(:,2) = Cordst(:,i+2)-G + Rab(:,3) = Cordst(:,i+3)-G + Rab(:,4) = Cordst(:,i+4)-G + Rab(:,5) = Cordst(:,i+5)-G + R2(:) = Rab(1,:)**2+Rab(2,:)**2+Rab(3,:)**2 + Rg(:) = sqrt(R2) + Se(:) = One/Rg + ! This term will below turn into the interaction between + ! charges on water and the MME-charges on the QM-molecule. + Eint(k,1) = Eint(k,1)-Qsta(1)*Se(2)-Qsta(2)*Se(3)-Qsta(3)*Se(4)-Qsta(4)*Se(5) + Rab3i(:) = Se/R2 + !------------------------------------------------------------------* + ! The dispersion interaction between QM-atoms and solvent is * + ! computed, with or without damping. The initial if-clause sees to * + ! that only atom-centers are included, while bonds and virtual * + ! centers are ignored. * + !------------------------------------------------------------------* + if (k <= iQ_atoms) call DispEnergy(EEDisp,BoMah(k),BoMaO(k),Rg(1),Rg(2),Rg(3),Rab3i(1),Rab3i(2),Rab3i(3),k) + !------------------------------------------------------------------* + ! Now we wrap up the electrostatics. * + !------------------------------------------------------------------* + U(1,:) = Rab(1,:)*Se + U(2,:) = Rab(2,:)*Se + U(3,:) = Rab(3,:)*Se + ! These three terms will below turn into the interaction + ! between water charges and the MME-dipoles on the QM-mol. + ! Change sign of charge, change sign of vector and then we + ! should also change sign since when a dipole interacts with + ! a field we have a minus sign, but this minus sign we have + ! omitted in hel; therefore this calculation gives the right + ! number eventually. + Eint(k,2) = -Qsta(1)*Rab(1,2)*Rab3i(2)-Qsta(2)*Rab(1,3)*Rab3i(3)-Qsta(3)*Rab(1,4)*Rab3i(4)-Qsta(4)*Rab(1,5)*Rab3i(5)+Eint(k,2) + Eint(k,3) = -Qsta(1)*Rab(2,2)*Rab3i(2)-Qsta(2)*Rab(2,3)*Rab3i(3)-Qsta(3)*Rab(2,4)*Rab3i(4)-Qsta(4)*Rab(2,5)*Rab3i(5)+Eint(k,3) + Eint(k,4) = -Qsta(1)*Rab(3,2)*Rab3i(2)-Qsta(2)*Rab(3,3)*Rab3i(3)-Qsta(3)*Rab(3,4)*Rab3i(4)-Qsta(4)*Rab(3,5)*Rab3i(5)+Eint(k,4) + ! And here it is the MME-quadrupoles that are prepared. + ! Change sign of charges, change sign two times of the + ! vector (in effect, zero times then) and then in the + ! energy expression for the interaction between the field + ! vector from a charge and a quarupole there is a plus + ! sign, so a minus is the right sign below. + Eint(k,5) = Eint(k,5)-Qsta(1)*U(1,2)**2*Rab3i(2)-Qsta(2)*U(1,3)**2*Rab3i(3)-Qsta(3)*U(1,4)**2*Rab3i(4)- & + Qsta(4)*U(1,5)**2*Rab3i(5) + Eint(k,7) = Eint(k,7)-Qsta(1)*U(2,2)**2*Rab3i(2)-Qsta(2)*U(2,3)**2*Rab3i(3)-Qsta(3)*U(2,4)**2*Rab3i(4)- & + Qsta(4)*U(2,5)**2*Rab3i(5) + Eint(k,10) = Eint(k,10)-Qsta(1)*U(3,2)**2*Rab3i(2)-Qsta(2)*U(3,3)**2*Rab3i(3)-Qsta(3)*U(3,4)**2*Rab3i(4)- & + Qsta(4)*U(3,5)**2*Rab3i(5) + Eint(k,6) = Eint(k,6)-Qsta(1)*U(1,2)*U(2,2)*Rab3i(2)-Qsta(2)*U(1,3)*U(2,3)*Rab3i(3)-Qsta(3)*U(1,4)*Rab3i(4)*U(2,4)- & + Qsta(4)*U(1,5)*Rab3i(5)*U(2,5) + Eint(k,8) = Eint(k,8)-Qsta(1)*U(1,2)*U(3,2)*Rab3i(2)-Qsta(2)*U(1,3)*U(3,3)*Rab3i(3)-Qsta(3)*U(1,4)*Rab3i(4)*U(3,4)- & + Qsta(4)*U(1,5)*Rab3i(5)*U(3,5) + Eint(k,9) = Eint(k,9)-Qsta(1)*U(3,2)*U(2,2)*Rab3i(2)-Qsta(2)*U(3,3)*U(2,3)*Rab3i(3)-Qsta(3)*U(3,4)*Rab3i(4)*U(2,4)- & + Qsta(4)*U(3,5)*Rab3i(5)*U(2,5) + + !------------------------------------------------------------------* + ! And now a whole lot of grad(1/r) and higher... * + !------------------------------------------------------------------* + ! Monopoles. + Fil(ip+1:ip+3,1,k,1) = Rab(1,1:3)*Rab3i(1:3) + Fil(ip+1:ip+3,2,k,1) = Rab(2,1:3)*Rab3i(1:3) + Fil(ip+1:ip+3,3,k,1) = Rab(3,1:3)*Rab3i(1:3) + ! Dipole -- x-component. + Fil(ip+1:ip+3,1,k,2) = (Three*U(1,1:3)**2-One)*Rab3i(1:3) + Fil(ip+1:ip+3,2,k,2) = Three*U(2,1:3)*U(1,1:3)*Rab3i(1:3) + Fil(ip+1:ip+3,3,k,2) = Three*U(3,1:3)*U(1,1:3)*Rab3i(1:3) + ! Dipole -- y-component. + Fil(ip+1:ip+3,1,k,3) = Three*U(2,1:3)*U(1,1:3)*Rab3i(1:3) + Fil(ip+1:ip+3,2,k,3) = (Three*U(2,1:3)**2-One)*Rab3i(1:3) + Fil(ip+1:ip+3,3,k,3) = Three*U(3,1:3)*U(2,1:3)*Rab3i(1:3) + ! Dipole -- z-component. + Fil(ip+1:ip+3,1,k,4) = Three*U(3,1:3)*U(1,1:3)*Rab3i(1:3) + Fil(ip+1:ip+3,2,k,4) = Three*U(3,1:3)*U(2,1:3)*Rab3i(1:3) + Fil(ip+1:ip+3,3,k,4) = (Three*U(3,1:3)**2-One)*Rab3i(1:3) + ! Quadrupole -- xx-component. + Fil(ip+1:ip+3,1,k,5) = U(1,1:3)*(Five*U(1,1:3)**2-Two)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,2,k,5) = Five*U(2,1:3)*U(1,1:3)**2*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,3,k,5) = Five*U(3,1:3)*U(1,1:3)**2*Rab3i(1:3)*Se(1:3) + ! Quadrupole -- yy-component. + Fil(ip+1:ip+3,1,k,7) = Five*U(2,1:3)**2*U(1,1:3)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,2,k,7) = U(2,1:3)*(Five*U(2,1:3)**2-Two)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,3,k,7) = Five*U(3,1:3)*U(2,1:3)**2*Rab3i(1:3)*Se(1:3) + ! Quadrupole -- zz-component. + Fil(ip+1:ip+3,1,k,10) = Five*U(3,1:3)**2*U(1,1:3)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,2,k,10) = Five*U(3,1:3)**2*U(2,1:3)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,3,k,10) = U(3,1:3)*(Five*U(3,1:3)**2-Two)*Rab3i(1:3)*Se(1:3) + ! Quadrupole -- xy-component. + Fil(ip+1:ip+3,1,k,6) = U(2,1:3)*(Five*U(1,1:3)**2-One)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,2,k,6) = U(1,1:3)*(Five*U(2,1:3)**2-One)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,3,k,6) = Five*U(3,1:3)*U(2,1:3)*U(1,1:3)*Rab3i(1:3)*Se(1:3) + ! Quadrupole -- xz-component. + Fil(ip+1:ip+3,1,k,8) = U(3,1:3)*(Five*U(1,1:3)**2-One)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,2,k,8) = Five*U(3,1:3)*U(2,1:3)*U(1,1:3)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,3,k,8) = U(1,1:3)*(Five*U(3,1:3)**2-One)*Rab3i(1:3)*Se(1:3) + ! Quadrupole -- yz-component. + Fil(ip+1:ip+3,1,k,9) = Five*U(3,1:3)*U(2,1:3)*U(1,1:3)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,2,k,9) = U(3,1:3)*(Five*U(2,1:3)**2-One)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,3,k,9) = U(2,1:3)*(Five*U(3,1:3)**2-One)*Rab3i(1:3)*Se(1:3) + !------------------------------------------------------------------* + ! If damping of the field is requested, then do it. * + !------------------------------------------------------------------* + if (FieldDamp) then + Fil(ip+1,:,k,:) = Fil(ip+1,:,k,:)*(One-exp(CAFieldG*Rg(1)))**CFexp + Fil(ip+2,:,k,:) = Fil(ip+2,:,k,:)*(One-exp(CBFieldG*Rg(2)))**CFexp + Fil(ip+3,:,k,:) = Fil(ip+3,:,k,:)*(One-exp(CBFieldG*Rg(3)))**CFexp + end if + end do +end do + +return + +end subroutine OneOverR diff -Nru openmolcas-22.02/src/qmstat/oneoverr_sl.f openmolcas-22.10/src/qmstat/oneoverr_sl.f --- openmolcas-22.02/src/qmstat/oneoverr_sl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/oneoverr_sl.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,406 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 2011, Jose Manuel Hermida Ramon * -************************************************************************ - Subroutine OneOverR_Sl(iFil,Ax,Ay,Az,BoMaH,BoMaO,EEDisp,iCNum - & ,Eint,iQ_Atoms,outxyz,Eint_Nuc) - Implicit Real*8 (a-h,o-z) -*----------------------------------------------------------------------* -* Jose. Modification of the OneOverR subroutine to include the * -* electrostatic penetration of the charge density in the * -* electrostatic operator of the Hamiltonian. 2011-05-30 * -*----------------------------------------------------------------------* - -#include "maxi.fh" -#include "qminp.fh" -#include "qmcom.fh" -#include "WrkSpc.fh" - - Parameter (MxK=(MxMltp*(MxMltp**2+6*MxMltp+11)+6)/6) - - Dimension iFil(MxQCen,10) - Dimension Eint(MxQCen,10),BoMaH(MxAt),BoMaO(MxAt),outxyz(MxQCen,3) - Dimension Eint_Nuc(MxAt),EintSl(MxK) - Dimension CTemp(3,MxCen),DTemp(MxCen),DInvTemp(MxCen) - Logical lAtom - - EEdisp=0.0d0 -*----------------------------------------------------------------------* -* Compute some distances and inverted distances etc. The potential, * -* the field and etc. and when we already have the numbers, we also do * -* the dispersion interaction. * -*----------------------------------------------------------------------* - iCi=(iQ_Atoms*(iQ_Atoms+1))/2 - Do 601, k=1,iCi - lAtom=.false. - If(k.le.iQ_atoms) lAtom=.true. - Gx=outxyz(k,1)+Ax - Gy=outxyz(k,2)+Ay - Gz=outxyz(k,3)+Az - Do 602, j=iCnum+1,nPart - i=1+(j-1)*nCent - ip=1+(j-1)*nPol - Rabx1=Cordst(i,1)-Gx !Below follows a lot of - Raby1=Cordst(i,2)-Gy !distances to and fro. - Rabz1=Cordst(i,3)-Gz - Rabx2=Cordst(i+1,1)-Gx - Raby2=Cordst(i+1,2)-Gy - Rabz2=Cordst(i+1,3)-Gz - Rabx3=Cordst(i+2,1)-Gx - Raby3=Cordst(i+2,2)-Gy - Rabz3=Cordst(i+2,3)-Gz - Rabx4=Cordst(i+3,1)-Gx - Raby4=Cordst(i+3,2)-Gy - Rabz4=Cordst(i+3,3)-Gz - Rabx5=Cordst(i+4,1)-Gx - Raby5=Cordst(i+4,2)-Gy - Rabz5=Cordst(i+4,3)-Gz - R21=Rabx1**2+Raby1**2+Rabz1**2 - R22=Rabx2**2+Raby2**2+Rabz2**2 - R23=Rabx3**2+Raby3**2+Rabz3**2 - R24=Rabx4**2+Raby4**2+Rabz4**2 - R25=Rabx5**2+Raby5**2+Rabz5**2 - Rg1=Sqrt(r21) - Rg2=Sqrt(r22) - Rg3=Sqrt(r23) - Rg4=Sqrt(r24) - Rg5=Sqrt(r25) - S1i=1/Rg1 - S2i=1/Rg2 - S3i=1/Rg3 - S4i=1/Rg4 - S5i=1/Rg5 - S1e=S1i - S2e=S2i - S3e=S3i - S4e=S4i - S5e=S5i - Rab13i=S1e/R21 - Rab23i=S2e/R22 - Rab33i=S3e/R23 - Rab43i=S4e/R24 - Rab53i=S5e/R25 -*----------------------------------------------------------------------* -* The dispersion interaction between QM-atoms and solvent is computed, * -* with or without damping. The initial if-clause sees to that only * -* atom-centers are included, while bonds and virtual centers are * -* ignored. * -*----------------------------------------------------------------------* - If(lAtom) then - Call DispEnergy(EEDisp,BoMah,BoMaO,rg1,rg2,rg3 - & ,Rab13i,Rab23i,Rab33i,k) - - Endif - Ux1=RabX1*s1i - Uy1=RabY1*s1i - Uz1=RabZ1*s1i - Ux2=RabX2*s2i - Uy2=RabY2*s2i - Uz2=RabZ2*s2i - Ux3=RabX3*s3i - Uy3=RabY3*s3i - Uz3=RabZ3*s3i - Ux4=RabX4*s4i - Uy4=RabY4*s4i - Uz4=RabZ4*s4i - Ux5=RabX5*s5i - Uy5=RabY5*s5i - Uz5=RabZ5*s5i - Rg1=Sqrt(r21) - Rg2=Sqrt(r22) - Rg3=Sqrt(r23) - Rg4=Sqrt(r24) - Rg5=Sqrt(r25) - S1i=1/Rg1 - S2i=1/Rg2 - S3i=1/Rg3 - S4i=1/Rg4 - S5i=1/Rg5 -*----------------------------------------------------------------------* -* Now we wrap up the electrostatics. * -*----------------------------------------------------------------------* -* Jose. First we check if distance with at least one of the centers of * -* the clasical molecule is inside the Cut-off * -*----------------------------------------------------------------------* - distMin=min(rg1,rg2) - distMin=min(distMin,rg3) - distMin=min(distMin,rg4) - distMin=min(distMin,rg5) - If(distMin.le.Cut_Elc) then - CTemp(1,1)=Rabx1 - CTemp(2,1)=Raby1 - CTemp(3,1)=Rabz1 - CTemp(1,2)=Rabx2 - CTemp(2,2)=Raby2 - CTemp(3,2)=Rabz2 - CTemp(1,3)=Rabx3 - CTemp(2,3)=Raby3 - CTemp(3,3)=Rabz3 - CTemp(1,4)=Rabx4 - CTemp(2,4)=Raby4 - CTemp(3,4)=Rabz4 - CTemp(1,5)=Rabx5 - CTemp(2,5)=Raby5 - CTemp(3,5)=Rabz5 - DTemp(1)=Rg1 - DTemp(2)=Rg2 - DTemp(3)=Rg3 - DTemp(4)=Rg4 - DTemp(5)=Rg5 - DInvTemp(1)=S1i - DInvTemp(2)=S2i - DInvTemp(3)=S3i - DInvTemp(4)=S4i - DInvTemp(5)=S5i - If(lQuad) then - nMltTemp=nMlt-1 ! this is done because for Sl_Grad - ! charge is L=0, dipole is L=1 and - ! quadrupole is L=2. In QmStat they - ! are 1, 2 and 3, respectively. - - Call Sl_Grad(nSlSiteC,lMltSlC,CTemp,DTemp,DInvTemp - & ,SlExpC,SlFactC,SlPC,nMltTemp,SlExpQ(1,k),DifSlExp - & ,EintSl,EintSl_Nuc,lAtom) - -*-----------------------------------------------------------------------* -* Change in the order of field gradients beacuse subroutine Sl_Grad -* have the same order than Molcas xx=5, xy=6, xz=7, yy=8, yz=9 and zz=10 -* and we need the QmStat order: xx=5, xy=6, yy=7, xz=8, yz=9 and zz=10 -*-----------------------------------------------------------------------* - EintSlTemp=EintSl(7) - EintSl(7)=EintSl(8) - EintSl(8)=EintSlTemp - - Do jhr=1,10 - Eint(k,jhr)=Eint(k,jhr)-EintSl(jhr) !Check bellow why - ! it is a subtraction - ! and not a sum - End do - If(lAtom) then - Eint_Nuc(k)=Eint_Nuc(k)-EintSl_Nuc - End if - go to 3466 - Else - nMltTemp=nMlt-1 ! this is done because for Sl_Grad - ! charge is L=0, dipole is L=1 and - ! quadrupole is L=2. In QmStat they - ! are 1, 2 and 3, respectively. - - ijhr=min(nMltTemp,1) - Call Sl_Grad(nSlSiteC,lMltSlC,CTemp,DTemp,DInvTemp - & ,SlExpC,SlFactC,SlPC,ijhr,SlExpQ(1,k),DifSlExp - & ,EintSl,EintSl_Nuc,lAtom) - - Do jhr=1,4 - Eint(k,jhr)=Eint(k,jhr)-EintSl(jhr) ! Check bellow why - ! it is a subtraction - ! and not a sum - End do - If(lAtom) then - Eint_Nuc(k)=Eint_Nuc(k)-EintSl_Nuc - End if - go to 3456 - Endif - Endif -*----------------------------------------------------------------------* -* The Eint(k,1) term will below turn into the interaction between -* charges on water and the MME-charges on the QM-molecule. -* Plus the interaction between the charge densities in Water and the -* charge densities in QM-Molecule when the Penetration is evaluated -*----------------------------------------------------------------------* - Eint(k,1)=-Qsta(1)*S2e-Qsta(2)*S3e-Qsta(3)*S4e - & -Qsta(4)*S5e+Eint(k,1) - If(lAtom) then - Eint_Nuc(k)=-Qsta(1)*S2e-Qsta(2)*S3e-Qsta(3)*S4e - & -Qsta(4)*S5e+Eint_Nuc(k) - Endif - - !These three terms will below turn into the interaction - !between water charges and the MME-dipoles on the QM-mol. - !Change sign of charge, change sign of vector and then we - !should also change sign since when a dipole interacts with - !a field we have a minus sign, but this minus sign we have - !omitted in hel; therefore this calculation gives the right - !number eventually. - Eint(k,2)=-Qsta(1)*RabX2*Rab23i-Qsta(2)*RabX3*Rab33i - &-Qsta(3)*RabX4*Rab43i-Qsta(4)*RabX5*Rab53i+Eint(k,2) - Eint(k,3)=-Qsta(1)*RabY2*Rab23i-Qsta(2)*RabY3*Rab33i - &-Qsta(3)*RabY4*Rab43i-Qsta(4)*RabY5*Rab53i+Eint(k,3) - Eint(k,4)=-Qsta(1)*RabZ2*Rab23i-Qsta(2)*RabZ3*Rab33i - &-Qsta(3)*RabZ4*Rab43i-Qsta(4)*RabZ5*Rab53i+Eint(k,4) - !And here it is the MME-quadrupoles that are prepared. - !Change sign of charges, change sign two times of the - !vector (in effect, zero times then) and then in the - !energy expression for the interaction between the field - !vector from a charge and a quarupole there is a plus - !sign, so a minus is the right sign below. - -3456 Continue - - Eint(k,5)=Eint(k,5)-Qsta(1)*Ux2**2*Rab23i-Qsta(2)*Ux3**2 - &*Rab33i-Qsta(3)*Ux4**2*Rab43i-Qsta(4)*Ux5**2*Rab53i - Eint(k,7)=Eint(k,7)-Qsta(1)*Uy2**2*Rab23i-Qsta(2)*Uy3**2 - &*Rab33i-Qsta(3)*Uy4**2*Rab43i-Qsta(4)*Uy5**2*Rab53i - Eint(k,10)=Eint(k,10)-Qsta(1)*Uz2**2*Rab23i-Qsta(2)*Uz3**2 - &*Rab33i-Qsta(3)*Uz4**2*Rab43i-Qsta(4)*Uz5**2*Rab53i - Eint(k,6)=Eint(k,6)-Qsta(1)*Ux2*Uy2*Rab23i-Qsta(2)*Ux3 - &*Uy3*Rab33i-Qsta(3)*Ux4*Rab43i*Uy4-Qsta(4)*Ux5*Rab53i*Uy5 - Eint(k,8)=Eint(k,8)-Qsta(1)*Ux2*Uz2*Rab23i-Qsta(2)*Ux3 - &*Uz3*Rab33i-Qsta(3)*Ux4*Rab43i*Uz4-Qsta(4)*Ux5*Rab53i*Uz5 - Eint(k,9)=Eint(k,9)-Qsta(1)*Uz2*Uy2*Rab23i-Qsta(2)*Uz3 - &*Uy3*Rab33i-Qsta(3)*Uz4*Rab43i*Uy4-Qsta(4)*Uz5*Rab53i*Uy5 - -3466 Continue - -*----------------------------------------------------------------------* -* And now a whole lot of grad(1/r) and higher... * -*----------------------------------------------------------------------* - !Unipoles. - Work(iFil(k,1)-1+ip)=Rabx1*Rab13i - Work(iFil(k,1)-1+ip+1)=Rabx2*Rab23i - Work(iFil(k,1)-1+ip+2)=Rabx3*Rab33i - Work(iFil(k,1)-1+nPart*nPol+ip)=Raby1*Rab13i - Work(iFil(k,1)-1+nPart*nPol+ip+1)=Raby2*Rab23i - Work(iFil(k,1)-1+nPart*nPol+ip+2)=Raby3*Rab33i - Work(iFil(k,1)-1+2*nPart*nPol+ip)=Rabz1*Rab13i - Work(iFil(k,1)-1+2*nPart*nPol+ip+1)=Rabz2*Rab23i - Work(iFil(k,1)-1+2*nPart*nPol+ip+2)=Rabz3*Rab33i - !Dipole -- x-component. - Work(iFil(k,2)-1+ip)=-(1-3*Ux1**2)*Rab13i - Work(iFil(k,2)-1+ip+1)=-(1-3*Ux2**2)*Rab23i - Work(iFil(k,2)-1+ip+2)=-(1-3*Ux3**2)*Rab33i - Work(iFil(k,2)-1+nPart*nPol+ip)=Uy1*Ux1*Rab13i*3 - Work(iFil(k,2)-1+nPart*nPol+ip+1)=Uy2*Ux2*Rab23i*3 - Work(iFil(k,2)-1+nPart*nPol+ip+2)=Uy3*Ux3*Rab33i*3 - Work(iFil(k,2)-1+2*nPart*nPol+ip)=Uz1*Ux1*Rab13i*3 - Work(iFil(k,2)-1+2*nPart*nPol+ip+1)=Uz2*Ux2*Rab23i*3 - Work(iFil(k,2)-1+2*nPart*nPol+ip+2)=Uz3*Ux3*Rab33i*3 - !Dipole -- y-component. - Work(iFil(k,3)-1+ip)=Uy1*Ux1*Rab13i*3 - Work(iFil(k,3)-1+ip+1)=Uy2*Ux2*Rab23i*3 - Work(iFil(k,3)-1+ip+2)=Uy3*Ux3*Rab33i*3 - Work(iFil(k,3)-1+nPart*nPol+ip)=-(1-3*Uy1**2)*Rab13i - Work(iFil(k,3)-1+nPart*nPol+ip+1)=-(1-3*Uy2**2)*Rab23i - Work(iFil(k,3)-1+nPart*nPol+ip+2)=-(1-3*Uy3**2)*Rab33i - Work(iFil(k,3)-1+2*nPart*nPol+ip)=Uz1*Uy1*Rab13i*3 - Work(iFil(k,3)-1+2*nPart*nPol+ip+1)=Uz2*Uy2*Rab23i*3 - Work(iFil(k,3)-1+2*nPart*nPol+ip+2)=Uz3*Uy3*Rab33i*3 - !Dipole -- z-component. - Work(iFil(k,4)-1+ip)=Uz1*Ux1*Rab13i*3 - Work(iFil(k,4)-1+ip+1)=Uz2*Ux2*Rab23i*3 - Work(iFil(k,4)-1+ip+2)=Uz3*Ux3*Rab33i*3 - Work(iFil(k,4)-1+nPart*nPol+ip)=Uz1*Uy1*Rab13i*3 - Work(iFil(k,4)-1+nPart*nPol+ip+1)=Uz2*Uy2*Rab23i*3 - Work(iFil(k,4)-1+nPart*nPol+ip+2)=Uz3*Uy3*Rab33i*3 - Work(iFil(k,4)-1+2*nPart*nPol+ip)=-(1-3*Uz1**2)*Rab13i - Work(iFil(k,4)-1+2*nPart*nPol+ip+1)=-(1-3*Uz2**2)*Rab23i - Work(iFil(k,4)-1+2*nPart*nPol+ip+2)=-(1-3*Uz3**2)*Rab33i - !Quadrupole -- xx-component. - Work(iFil(k,5)-1+ip)=(5*Ux1*(Ux1*Ux1-.4))*Rab13i*S1e - Work(iFil(k,5)-1+ip+1)=(5*Ux2*(Ux2*Ux2-.4))*Rab23i*S2e - Work(iFil(k,5)-1+ip+2)=(5*Ux3*(Ux3*Ux3-.4))*Rab33i*S3e - Work(iFil(k,5)-1+nPart*nPol+ip)=5*Uy1*Ux1*Ux1*Rab13i*S1e - Work(iFil(k,5)-1+nPart*nPol+ip+1)=5*Uy2*Ux2*Ux2*Rab23i*S2e - Work(iFil(k,5)-1+nPart*nPol+ip+2)=5*Uy3*Ux3*Ux3*Rab33i*S3e - Work(iFil(k,5)-1+2*nPart*nPol+ip)=5*Uz1*Ux1*Ux1*Rab13i*S1e - Work(iFil(k,5)-1+2*nPart*nPol+ip+1)=5*Uz2*Ux2*Ux2*Rab23i*S2e - Work(iFil(k,5)-1+2*nPart*nPol+ip+2)=5*Uz3*Ux3*Ux3*Rab33i*S3e - !Quadrupole -- yy-component. - Work(iFil(k,7)-1+ip)=5*Uy1*Uy1*Ux1*Rab13i*S1e - Work(iFil(k,7)-1+ip+1)=5*Uy2*Uy2*Ux2*Rab23i*S2e - Work(iFil(k,7)-1+ip+2)=5*Uy3*Uy3*Ux3*Rab33i*S3e - Work(iFil(k,7)-1+nPart*nPol+ip)=(5*Uy1*(Uy1*Uy1-.4)) - & *Rab13i*S1e - Work(iFil(k,7)-1+nPart*nPol+ip+1)=(5*Uy2*(Uy2*Uy2-.4)) - & *Rab23i*S2e - Work(iFil(k,7)-1+nPart*nPol+ip+2)=(5*Uy3*(Uy3*Uy3-.4)) - & *Rab33i*S3e - Work(iFil(k,7)-1+2*nPart*nPol+ip)=5*Uz1*Uy1*Uy1*Rab13i*S1e - Work(iFil(k,7)-1+2*nPart*nPol+ip+1)=5*Uz2*Uy2*Uy2*Rab23i*S2e - Work(iFil(k,7)-1+2*nPart*nPol+ip+2)=5*Uz3*Uy3*Uy3*Rab33i*S3e - !Quadrupole -- zz-component. - Work(iFil(k,10)-1+ip)=5*Uz1*Uz1*Ux1*Rab13i*S1e - Work(iFil(k,10)-1+ip+1)=5*Uz2*Uz2*Ux2*Rab23i*S2e - Work(iFil(k,10)-1+ip+2)=5*Uz3*Uz3*Ux3*Rab33i*S3e - Work(iFil(k,10)-1+nPart*nPol+ip)=5*Uz1*Uz1*Uy1*Rab13i*S1e - Work(iFil(k,10)-1+nPart*nPol+ip+1)=5*Uz2*Uz2*Uy2*Rab23i*S2e - Work(iFil(k,10)-1+nPart*nPol+ip+2)=5*Uz3*Uz3*Uy3*Rab33i*S3e - Work(iFil(k,10)-1+2*nPart*nPol+ip)=(5*Uz1*(Uz1*Uz1-.4)) - & *Rab13i*S1e - Work(iFil(k,10)-1+2*nPart*nPol+ip+1)=(5*Uz2*(Uz2*Uz2-.4)) - & *Rab23i*S2e - Work(iFil(k,10)-1+2*nPart*nPol+ip+2)=(5*Uz3*(Uz3*Uz3-.4)) - & *Rab33i*S3e - !Quadrupole -- xy-component. - Work(iFil(k,6)-1+ip)=(5*Uy1*(Ux1*Ux1-.2))*Rab13i*S1e - Work(iFil(k,6)-1+ip+1)=(5*Uy2*(Ux2*Ux2-.2))*Rab23i*S2e - Work(iFil(k,6)-1+ip+2)=(5*Uy3*(Ux3*Ux3-.2))*Rab33i*S3e - Work(iFil(k,6)-1+nPart*nPol+ip)=(5*Ux1*(Uy1*Uy1-.2)) - & *Rab13i*S1e - Work(iFil(k,6)-1+nPart*nPol+ip+1)=(5*Ux2*(Uy2*Uy2-.2)) - & *Rab23i*S2e - Work(iFil(k,6)-1+nPart*nPol+ip+2)=(5*Ux3*(Uy3*Uy3-.2)) - & *Rab33i*S3e - Work(iFil(k,6)-1+2*nPart*nPol+ip)=5*Uz1*Uy1*Ux1*Rab13i*S1e - Work(iFil(k,6)-1+2*nPart*nPol+ip+1)=5*Uz2*Uy2*Ux2*Rab23i*S2e - Work(iFil(k,6)-1+2*nPart*nPol+ip+2)=5*Uz3*Uy3*Ux3*Rab33i*S3e - !Quadrupole -- xz-component. - Work(iFil(k,8)-1+ip)=(5*Uz1*(Ux1*Ux1-.2))*Rab13i*S1e - Work(iFil(k,8)-1+ip+1)=(5*Uz2*(Ux2*Ux2-.2))*Rab23i*S2e - Work(iFil(k,8)-1+ip+2)=(5*Uz3*(Ux3*Ux3-.2))*Rab33i*S3e - Work(iFil(k,8)-1+nPart*nPol+ip)=5*Uz1*Uy1*Ux1*Rab13i*S1e - Work(iFil(k,8)-1+nPart*nPol+ip+1)=5*Uz2*Uy2*Ux2*Rab23i*S2e - Work(iFil(k,8)-1+nPart*nPol+ip+2)=5*Uz3*Uy3*Ux3*Rab33i*S3e - Work(iFil(k,8)-1+2*nPart*nPol+ip)=(5*Ux1*(Uz1*Uz1-.2)) - & *Rab13i*S1e - Work(iFil(k,8)-1+2*nPart*nPol+ip+1)=(5*Ux2*(Uz2*Uz2-.2)) - & *Rab23i*S2e - Work(iFil(k,8)-1+2*nPart*nPol+ip+2)=(5*Ux3*(Uz3*Uz3-.2)) - & *Rab33i*S3e - !Quadrupole -- yz-component. - Work(iFil(k,9)-1+ip)=5*Uz1*Uy1*Ux1*Rab13i*S1e - Work(iFil(k,9)-1+ip+1)=5*Uz2*Uy2*Ux2*Rab23i*S2e - Work(iFil(k,9)-1+ip+2)=5*Uz3*Uy3*Ux3*Rab33i*S3e - Work(iFil(k,9)-1+nPart*nPol+ip)=(5*Uz1*(Uy1*Uy1-.2)) - & *Rab13i*S1e - Work(iFil(k,9)-1+nPart*nPol+ip+1)=(5*Uz2*(Uy2*Uy2-.2)) - & *Rab23i*S2e - Work(iFil(k,9)-1+nPart*nPol+ip+2)=(5*Uz3*(Uy3*Uy3-.2)) - & *Rab33i*S3e - Work(iFil(k,9)-1+2*nPart*nPol+ip)=(5*Uy1*(Uz1*Uz1-.2)) - & *Rab13i*S1e - Work(iFil(k,9)-1+2*nPart*nPol+ip+1)=(5*Uy2*(Uz2*Uz2-.2)) - & *Rab23i*S2e - Work(iFil(k,9)-1+2*nPart*nPol+ip+2)=(5*Uy3*(Uz3*Uz3-.2)) - & *Rab33i*S3e -*----------------------------------------------------------------------* -* If damping of the field is requested, then do it. * -*----------------------------------------------------------------------* - If(FieldDamp) then - Do 620, ijhr=1,10 - Do 621, jjhr=0,2 - Work(iFil(k,ijhr)-1+jjhr*nPart*nPol+ip)= - & Work(iFil(k,ijhr)-1+jjhr*nPart*nPol+ip) - & *(1-exp(CAFieldG*rg1))**CFexp - Work(iFil(k,ijhr)-1+jjhr*nPart*nPol+ip+1)= - & Work(iFil(k,ijhr)-1+jjhr*nPart*nPol+ip+1) - & *(1-exp(CBFieldG*rg2))**CFexp - Work(iFil(k,ijhr)-1+jjhr*nPart*nPol+ip+2)= - & Work(iFil(k,ijhr)-1+jjhr*nPart*nPol+ip+2) - & *(1-exp(CBFieldG*rg3))**CFexp -621 Continue -620 Continue - Endif -602 Continue -601 Continue - - Return - End diff -Nru openmolcas-22.02/src/qmstat/oneoverr_sl.F90 openmolcas-22.10/src/qmstat/oneoverr_sl.F90 --- openmolcas-22.02/src/qmstat/oneoverr_sl.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/oneoverr_sl.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,210 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 2011, Jose Manuel Hermida Ramon * +!*********************************************************************** + +subroutine OneOverR_Sl(Fil,Ax,Ay,Az,BoMaH,BoMaO,EEDisp,iCNum,Eint,iQ_Atoms,outxyz,Eint_Nuc) +!----------------------------------------------------------------------* +! Jose. Modification of the OneOverR subroutine to include the * +! electrostatic penetration of the charge density in the * +! electrostatic operator of the Hamiltonian. 2011-05-30 * +!----------------------------------------------------------------------* + +use qmstat_global, only: CAFieldG, CBFieldG, CFexp, Cordst, Cut_Elc, DifSlExp, FieldDamp, lMltSlC, lQuad, MxMltp, nCent, nMlt, & + nPart, nPol, nSlSiteC, Qsta, SlExpC, SlExpQ, SlFactC, SlPC +use Index_Functions, only: nTri3_Elem1, nTri_Elem +use Constants, only: Zero, One, Two, Three, Five +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iQ_Atoms, iCNum +real(kind=wp), intent(out) :: Fil(nPol*nPart,3,nTri_Elem(iQ_Atoms),10), EEDisp +real(kind=wp), intent(in) :: Ax, Ay, Az, BoMaH(iQ_Atoms), BoMaO(iQ_Atoms), outxyz(3,nTri_Elem(iQ_Atoms)) +real(kind=wp), intent(inout) :: Eint(nTri_Elem(iQ_Atoms),10), Eint_Nuc(iQ_Atoms) +integer(kind=iwp) :: i, ijhr, ip, j, k, nMltTemp +real(kind=wp) :: distMin, EintSl(nTri3_Elem1(MxMltp)), EintSl_Nuc, EintSlTemp, G(3), R2(5), Rab3i(5), Rab(3,5), Rg(5), Se(5), U(3,5) +logical(kind=iwp) :: lAtom, Skip + +EEdisp = Zero +!----------------------------------------------------------------------* +! Compute some distances and inverted distances etc. The potential, * +! the field and etc. and when we already have the numbers, we also do * +! the dispersion interaction. * +!----------------------------------------------------------------------* +do k=1,nTri_Elem(iQ_Atoms) + lAtom = (k <= iQ_atoms) + G(1) = outxyz(1,k)+Ax + G(2) = outxyz(2,k)+Ay + G(3) = outxyz(3,k)+Az + do j=iCnum+1,nPart + i = (j-1)*nCent + ip = (j-1)*nPol + !Below follows a lot of distances to and fro. + Rab(:,1) = Cordst(:,i+1)-G + Rab(:,2) = Cordst(:,i+2)-G + Rab(:,3) = Cordst(:,i+3)-G + Rab(:,4) = Cordst(:,i+4)-G + Rab(:,5) = Cordst(:,i+5)-G + R2(:) = Rab(1,:)**2+Rab(2,:)**2+Rab(3,:)**2 + Rg(:) = sqrt(R2) + Se(:) = One/Rg + Rab3i(:) = Se/R2 + !------------------------------------------------------------------* + ! The dispersion interaction between QM-atoms and solvent is * + ! computed, with or without damping. The initial if-clause sees to * + ! that only atom-centers are included, while bonds and virtual * + ! centers are ignored. * + !------------------------------------------------------------------* + if (lAtom) call DispEnergy(EEDisp,BoMaH(k),BoMaO(k),Rg(1),Rg(2),Rg(3),Rab3i(1),Rab3i(2),Rab3i(3),k) + U(1,:) = Rab(1,:)*Se + U(2,:) = Rab(2,:)*Se + U(3,:) = Rab(3,:)*Se + !------------------------------------------------------------------* + ! Now we wrap up the electrostatics. * + !------------------------------------------------------------------* + ! Jose. First we check if distance with at least one of the centers* + ! of the clasical molecule is inside the Cut-off * + !------------------------------------------------------------------* + distMin = minval(Rg) + Skip = .false. + if (distMin <= Cut_Elc) then + if (lQuad) then + ! this is done because for Sl_Grad charge is L=0, dipole is L=1 and + ! quadrupole is L=2. In QmStat they are 1, 2 and 3, respectively. + nMltTemp = nMlt-1 + + call Sl_Grad(nSlSiteC,lMltSlC,Rab,Rg,Se,SlExpC,SlFactC,SlPC,nMltTemp,SlExpQ(:,k),DifSlExp,EintSl,EintSl_Nuc,lAtom) + + !--------------------------------------------------------------* + ! Change in the order of field gradients because subroutine * + ! Sl_Grad has the same order as Molcas: xx=5, xy=6, xz=7, yy=8,* + ! yz=9 and zz=10 and we need the QmStat order: xx=5, xy=6, * + ! yy=7, xz=8, yz=9 and zz=10 * + !--------------------------------------------------------------* + EintSlTemp = EintSl(7) + EintSl(7) = EintSl(8) + EintSl(8) = EintSlTemp + + Eint(k,:) = Eint(k,:)-EintSl(:) !Check below why it is a subtraction and not a sum + if (lAtom) Eint_Nuc(k) = Eint_Nuc(k)-EintSl_Nuc + Skip = .true. + else + ! this is done because for Sl_Grad charge is L=0, dipole is L=1 and + ! quadrupole is L=2. In QmStat they are 1, 2 and 3, respectively. + nMltTemp = nMlt-1 + + ijhr = min(nMltTemp,1) + call Sl_Grad(nSlSiteC,lMltSlC,Rab,Rg,Se,SlExpC,SlFactC,SlPC,ijhr,SlExpQ(:,k),DifSlExp,EintSl,EintSl_Nuc,lAtom) + + Eint(k,1:4) = Eint(k,1:4)-EintSl(1:4) ! Check below why it is a subtraction and not a sum + if (lAtom) Eint_Nuc(k) = Eint_Nuc(k)-EintSl_Nuc + end if + else + !----------------------------------------------------------------* + ! The Eint(k,1) term will below turn into the interaction between* + ! charges on water and the MME-charges on the QM-molecule. Plus * + ! the interaction between the charge densities in Water and the * + ! charge densities in QM-Molecule when the Penetration is * + ! evaluated * + !----------------------------------------------------------------* + Eint(k,1) = -Qsta(1)*Se(2)-Qsta(2)*Se(3)-Qsta(3)*Se(4)-Qsta(4)*Se(5)+Eint(k,1) + if (lAtom) Eint_Nuc(k) = -Qsta(1)*Se(2)-Qsta(2)*Se(3)-Qsta(3)*Se(4)-Qsta(4)*Se(5)+Eint_Nuc(k) + + ! These three terms will below turn into the interaction + ! between water charges and the MME-dipoles on the QM-mol. + ! Change sign of charge, change sign of vector and then we + ! should also change sign since when a dipole interacts with + ! a field we have a minus sign, but this minus sign we have + ! omitted in hel; therefore this calculation gives the right + ! number eventually. + Eint(k,2) = -Qsta(1)*Rab(1,2)*Rab3i(2)-Qsta(2)*Rab(1,3)*Rab3i(3)-Qsta(3)*Rab(1,4)*Rab3i(4)-Qsta(4)*Rab(1,5)*Rab3i(5)+Eint(k,2) + Eint(k,3) = -Qsta(1)*Rab(2,2)*Rab3i(2)-Qsta(2)*Rab(2,3)*Rab3i(3)-Qsta(3)*Rab(2,4)*Rab3i(4)-Qsta(4)*Rab(2,5)*Rab3i(5)+Eint(k,3) + Eint(k,4) = -Qsta(1)*Rab(3,2)*Rab3i(2)-Qsta(2)*Rab(3,3)*Rab3i(3)-Qsta(3)*Rab(3,4)*Rab3i(4)-Qsta(4)*Rab(3,5)*Rab3i(5)+Eint(k,4) + end if + + if (.not. Skip) then + ! And here it is the MME-quadrupoles that are prepared. + ! Change sign of charges, change sign two times of the + ! vector (in effect, zero times then) and then in the + ! energy expression for the interaction between the field + ! vector from a charge and a quarupole there is a plus + ! sign, so a minus is the right sign below. + Eint(k,5) = Eint(k,5)-Qsta(1)*U(1,2)**2*Rab3i(2)-Qsta(2)*U(1,3)**2*Rab3i(3)-Qsta(3)*U(1,4)**2*Rab3i(4)- & + Qsta(4)*U(1,5)**2*Rab3i(5) + Eint(k,7) = Eint(k,7)-Qsta(1)*U(2,2)**2*Rab3i(2)-Qsta(2)*U(2,3)**2*Rab3i(3)-Qsta(3)*U(2,4)**2*Rab3i(4)- & + Qsta(4)*U(2,5)**2*Rab3i(5) + Eint(k,10) = Eint(k,10)-Qsta(1)*U(3,2)**2*Rab3i(2)-Qsta(2)*U(3,3)**2*Rab3i(3)-Qsta(3)*U(3,4)**2*Rab3i(4)- & + Qsta(4)*U(3,5)**2*Rab3i(5) + Eint(k,6) = Eint(k,6)-Qsta(1)*U(1,2)*U(2,2)*Rab3i(2)-Qsta(2)*U(1,3)*U(2,3)*Rab3i(3)-Qsta(3)*U(1,4)*Rab3i(4)*U(2,4)- & + Qsta(4)*U(1,5)*Rab3i(5)*U(2,5) + Eint(k,8) = Eint(k,8)-Qsta(1)*U(1,2)*U(3,2)*Rab3i(2)-Qsta(2)*U(1,3)*U(3,3)*Rab3i(3)-Qsta(3)*U(1,4)*Rab3i(4)*U(3,4)- & + Qsta(4)*U(1,5)*Rab3i(5)*U(3,5) + Eint(k,9) = Eint(k,9)-Qsta(1)*U(3,2)*U(2,2)*Rab3i(2)-Qsta(2)*U(3,3)*U(2,3)*Rab3i(3)-Qsta(3)*U(3,4)*Rab3i(4)*U(2,4)- & + Qsta(4)*U(3,5)*Rab3i(5)*U(2,5) + end if + + !------------------------------------------------------------------* + ! And now a whole lot of grad(1/r) and higher... * + !------------------------------------------------------------------* + ! Monopoles. + Fil(ip+1:ip+3,1,k,1) = Rab(1,1:3)*Rab3i(1:3) + Fil(ip+1:ip+3,2,k,1) = Rab(2,1:3)*Rab3i(1:3) + Fil(ip+1:ip+3,3,k,1) = Rab(3,1:3)*Rab3i(1:3) + ! Dipole -- x-component. + Fil(ip+1:ip+3,1,k,2) = (Three*U(1,1:3)**2-One)*Rab3i(1:3) + Fil(ip+1:ip+3,2,k,2) = Three*U(2,1:3)*U(1,1:3)*Rab3i(1:3) + Fil(ip+1:ip+3,3,k,2) = Three*U(3,1:3)*U(1,1:3)*Rab3i(1:3) + ! Dipole -- y-component. + Fil(ip+1:ip+3,1,k,3) = Three*U(2,1:3)*U(1,1:3)*Rab3i(1:3) + Fil(ip+1:ip+3,2,k,3) = (Three*U(2,1:3)**2-One)*Rab3i(1:3) + Fil(ip+1:ip+3,3,k,3) = Three*U(3,1:3)*U(2,1:3)*Rab3i(1:3) + ! Dipole -- z-component. + Fil(ip+1:ip+3,1,k,4) = Three*U(3,1:3)*U(1,1:3)*Rab3i(1:3) + Fil(ip+1:ip+3,2,k,4) = Three*U(3,1:3)*U(2,1:3)*Rab3i(1:3) + Fil(ip+1:ip+3,3,k,4) = (Three*U(3,1:3)**2-One)*Rab3i(1:3) + ! Quadrupole -- xx-component. + Fil(ip+1:ip+3,1,k,5) = U(1,1:3)*(Five*U(1,1:3)**2-Two)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,2,k,5) = Five*U(2,1:3)*U(1,1:3)**2*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,3,k,5) = Five*U(3,1:3)*U(1,1:3)**2*Rab3i(1:3)*Se(1:3) + ! Quadrupole -- yy-component. + Fil(ip+1:ip+3,1,k,7) = Five*U(2,1:3)**2*U(1,1:3)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,2,k,7) = U(2,1:3)*(Five*U(2,1:3)**2-Two)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,3,k,7) = Five*U(3,1:3)*U(2,1:3)**2*Rab3i(1:3)*Se(1:3) + ! Quadrupole -- zz-component. + Fil(ip+1:ip+3,1,k,10) = Five*U(3,1:3)**2*U(1,1:3)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,2,k,10) = Five*U(3,1:3)**2*U(2,1:3)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,3,k,10) = U(3,1:3)*(Five*U(3,1:3)**2-Two)*Rab3i(1:3)*Se(1:3) + ! Quadrupole -- xy-component. + Fil(ip+1:ip+3,1,k,6) = U(2,1:3)*(Five*U(1,1:3)**2-One)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,2,k,6) = U(1,1:3)*(Five*U(2,1:3)**2-One)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,3,k,6) = Five*U(3,1:3)*U(2,1:3)*U(1,1:3)*Rab3i(1:3)*Se(1:3) + ! Quadrupole -- xz-component. + Fil(ip+1:ip+3,1,k,8) = U(3,1:3)*(Five*U(1,1:3)**2-One)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,2,k,8) = Five*U(3,1:3)*U(2,1:3)*U(1,1:3)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,3,k,8) = U(1,1:3)*(Five*U(3,1:3)**2-One)*Rab3i(1:3)*Se(1:3) + ! Quadrupole -- yz-component. + Fil(ip+1:ip+3,1,k,9) = Five*U(3,1:3)*U(2,1:3)*U(1,1:3)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,2,k,9) = U(3,1:3)*(Five*U(2,1:3)**2-One)*Rab3i(1:3)*Se(1:3) + Fil(ip+1:ip+3,3,k,9) = U(2,1:3)*(Five*U(3,1:3)**2-One)*Rab3i(1:3)*Se(1:3) + !------------------------------------------------------------------* + ! If damping of the field is requested, then do it. * + !------------------------------------------------------------------* + if (FieldDamp) then + Fil(ip+1,:,k,:) = Fil(ip+1,:,k,:)*(One-exp(CAFieldG*Rg(1)))**CFexp + Fil(ip+2,:,k,:) = Fil(ip+2,:,k,:)*(One-exp(CBFieldG*Rg(2)))**CFexp + Fil(ip+3,:,k,:) = Fil(ip+3,:,k,:)*(One-exp(CBFieldG*Rg(3)))**CFexp + end if + end do +end do + +return + +end subroutine OneOverR_Sl diff -Nru openmolcas-22.02/src/qmstat/orbrot2.f openmolcas-22.10/src/qmstat/orbrot2.f --- openmolcas-22.02/src/qmstat/orbrot2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/orbrot2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,243 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Anders Ohrn * -************************************************************************ -* OrbRot2 -* -*> @brief -*> Rotate orbitals of the solvent -*> @author A. Ohrn -*> -*> @details -*> Given a rotation matrix \f$ R \f$ it is easy to rotate the p-orbitals since -*> they behave just like the three axes. The d-orbitals are more -*> intricate. -*> -*> To obtain a representation -*> of the d-orbital \f$ \mathrm{d}_{xy} \f$ we perform the outer product \f$ \mathrm{d}_x \mathrm{d}_y + \mathrm{d}_y \mathrm{d}_x \f$, -*> which generates a two-dimensional matrix. Now rotate each px and py -*> and perform this multiplication. We obtain a symmetric matrix from -*> whose elements we can compute how the \f$ \mathrm{d}_{xy} \f$ transforms when -*> rotated. The same is done for the other d-orbitals and we can -*> construct a transformation matrix, which we apply to the MO-coeff. -*> Other ways to look at it are available, but the present one can be -*> seen as a generation of table 3 in \cite Iva1996-JPC-100-6342. -*> The present method is efficient -*> with no trigonometric functions and ample use of BLAS_UTIL. -*> -*> @note -*> ::Qfread as well as ::transrot must precede. -*> -*> @param[in] Rot The rotation matrix -*> @param[in] Cmo The MO-coefficients -*> @param[in] iQ The angular type of the \f$ i \f$ -th basis (observe, not the \f$ i \f$ -th basis function, see givemeinfo.f) -*> @param[in] iOrb Number of orbitals -*> @param[in] lMax Number of bases (not basis functions), see qfread.f -*> @param[in] nCnC Number of contracted basis functions of same type as the \f$ i \f$ -th basis. For example 7s4p will have vector ``7,7,7,7,7,7,7,4,4,4,4``. -************************************************************************ - Subroutine OrbRot2(Rot,Cmo,iQ,iOrb,lMax,nCnC) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "numbers.fh" -#include "warnings.h" - - Dimension Rot(3,3),Cmo(MxBasC,MxOrb_C),iQ(MxBasC),nCnC(MxBasC) - - Dimension Px(3),Py(3),Pz(3),Resx(3),Resy(3),Resz(3) - Dimension Dzz(6),Dxy(6),Dxz(6),Dyz(6),Dxmin(6),Dzer(6) - &,Dkopia(6),Unit(6) - - Dimension PBlock(3,3),DBlock(5,5) - - Logical NewIq - - Data Px/1.0d0,0.0d0,0.0d0/ - Data Py/0.0d0,1.0d0,0.0d0/ - Data Pz/0.0d0,0.0d0,1.0d0/ - Data Dzer/0.0d0,0.0d0,0.0d0,0.0d0,0.0d0,0.0d0/ - Data Unit/-1.0d0,0.0d0,0.0d0,-1.0d0,0.0d0,-1.0d0/ - -* -*-- Dgemv multiply the matrix Rot on the vector Px. For details about -* various parameter see the source code for the routine; it is very -* detailed. Here we get the p-orbitals which also are used to obtain -* the transformation of the other orbitals. -* - Call dGeMV_('N',ithree,ithree,ONE,Rot,ithree - &,Px,ione,ZERO,Resx,ione) - Call dGeMV_('N',ithree,ithree,ONE,Rot,ithree - &,Py,ione,ZERO,Resy,ione) - Call dGeMV_('N',ithree,ithree,ONE,Rot,ithree - &,Pz,ione,ZERO,Resz,ione) - -* -*-- Construct the p-block. Easy since they are linear polynomials in -* the cartesian R-matrix. -* - PBlock(1,1)=Resx(1) - PBlock(2,1)=Resx(2) - PBlock(3,1)=Resx(3) - PBlock(1,2)=Resy(1) - PBlock(2,2)=Resy(2) - PBlock(3,2)=Resy(3) - PBlock(1,3)=Resz(1) - PBlock(2,3)=Resz(2) - PBlock(3,3)=Resz(3) - -* -*-- Generation of quadratic polynomial of R-matrix elements for d_xy. -* - call dcopy_(isix,Dzer,ione,Dkopia,ione) - Call Dspr2('L',ithree,ONE,Resx,ione,Resy,ione,Dzer) - call dcopy_(isix,Dzer,ione,Dxy,ione) - call dcopy_(isix,Dkopia,ione,Dzer,ione) - -* -*-- Generation of quadratic polynomial of R-matrix elements for d_xz. -* - call dcopy_(isix,Dzer,ione,Dkopia,ione) - Call Dspr2('L',ithree,ONE,Resx,ione,Resz,ione,Dzer) - call dcopy_(isix,Dzer,ione,Dxz,ione) - call dcopy_(isix,Dkopia,ione,Dzer,ione) - -* -*-- Generation of quadratic polynomial of R-matrix elements for d_yz. -* - call dcopy_(isix,Dzer,ione,Dkopia,ione) - Call Dspr2('L',ithree,ONE,Resy,ione,Resz,ione,Dzer) - call dcopy_(isix,Dzer,ione,Dyz,ione) - call dcopy_(isix,Dkopia,ione,Dzer,ione) - -* -*-- Generation of quadratic polynomial of R-matrix elements for d_xx-yy. -* - call dcopy_(isix,Dzer,ione,Dkopia,ione) - Call Dspr('L',ithree,-1.0d0*ONE,Resy,ione,Dzer) - call dcopy_(isix,Dzer,ione,Dxmin,ione) - call dcopy_(isix,Dkopia,ione,Dzer,ione) - Call Dspr('L',ithree,ONE,Resx,ione,Dxmin) - call dcopy_(isix,Dkopia,ione,Dzer,ione) - -* -*-- Generation of quadratic polynomial of R-matrix elements for d_3zz-1. -* - call dcopy_(isix,Unit,ione,Dkopia,ione) - Call Dspr('L',ithree,THREE,Resz,ione,Unit) - call dcopy_(isix,Unit,ione,Dzz,ione) - call dcopy_(isix,Dkopia,ione,Unit,ione) - -* -*-- Construct the d-block. This requires knowledge of how Molcas -* handles it d-orbitals, especially its normalization, which is the -* reason for the constants r1,r2,r3,r4. -* - r1=1.0d0 - r2=sqrt(dble(3)) - r3=1.0d0 - r4=1.0d0/sqrt(dble(3)) - DBlock(1,1)=r1*Dxy(2) !dxy-->dxy - DBlock(2,1)=r1*Dxy(5) !dxy-->dyz - DBlock(3,1)=(r1/r4)*0.5*Dxy(6) !dxy-->d3zz-1 - DBlock(4,1)=r1*Dxy(3) !dxy-->dxz - DBlock(5,1)=(r1/r3)*(Dxy(1)+0.5*Dxy(6)) !dxy-->dxx-yy - DBlock(1,2)=r1*Dyz(2) !dyz-->dxy - DBlock(2,2)=r1*Dyz(5) !dyz-->dyz - DBlock(3,2)=(r1/r4)*0.5*Dyz(6) !dyz-->d3zz-1 - DBlock(4,2)=r1*Dyz(3) !dyz-->dxz - DBlock(5,2)=(r1/r3)*(Dyz(1)+0.5*Dyz(6)) !dyz-->dxx-yy - DBlock(1,3)=r4*Dzz(2) !d3zz-->dxy - DBlock(2,3)=r4*Dzz(5) !d3zz-->dyz - DBlock(3,3)=r1*0.5*Dzz(6) !d3zz-->d3zz - DBlock(4,3)=r4*Dzz(3) !d3zz-->dxz - DBlock(5,3)=(r1/r2)*(Dzz(1)+0.5*Dzz(6)) !d3zz-->dxx-yy - DBlock(1,4)=r1*Dxz(2) !dxz-->dxy - DBlock(2,4)=r1*Dxz(5) !dxz-->dyz - DBlock(3,4)=(r1/r4)*0.5*Dxz(6) !dxz-->d3zz-1 - DBlock(4,4)=r1*Dxz(3) !dxz-->dxz - DBlock(5,4)=(r1/r3)*(Dxz(1)+0.5*Dxz(6)) !dxz-->dxx-yy - DBlock(1,5)=r3*Dxmin(2) !dxx-yy-->dxy - DBlock(2,5)=r3*Dxmin(5) !dxx-yy-->dyz - DBlock(3,5)=r2*0.5*Dxmin(6) !dxx-yy-->d3zz - DBlock(4,5)=r3*Dxmin(3) !dxx-yy-->dxz - DBlock(5,5)=r1*(Dxmin(1)+0.5*Dxmin(6)) !dxx-yy-->dxx-yy - -* -*-- With the proper number of blocks at hand, we make transformation. -* The brute force way is to construct the entire transformation matrix -* and make a matrix multiplication. Since so many elements in that -* matrix are zero, more effecient ways to transform are available. -* That is what is used below. The formulas follow from considering the -* transformation matrix multiplied with the CMO-matrix. Multio -* importante is it to observe how the basis functions in Molcas are -* ordered! -* - Do 10, i=1,iOrb - In=1 !OBSERVE!!! WE ARE ASSUMING THAT THE FIRST BASIS IS OF - !S-TYPE!!! IF YOU ARE IMPLEMENTING SYMMETRY, THIS - Do 20, j=2,lMax !MIGHT NOT BE A VALID ASSUMPTION SO THEN THE - In=In+1 !NEWIQ-CONSTRUCT BELOW MUST BE ALTERED!!! - IqSuckOut=iQ(j) - NewIq=iQ(j).ne.iQ(j-1) - If(Newiq) then !This if-clause controls the jumping when new - In=In+(2*iQ(j-1)-2)*nCnC(j-1) !angular basis function - Endif !appears. - If(IqSuckOut.eq.1) then !This is s-function - Go To 20 - ElseIf(IqSuckOut.eq.2) then !This is p-function - iSkutt=nCnC(j) - Ctemp1=PBlock(1,1)*Cmo(In,i)+PBlock(1,2)*Cmo(In+iSkutt,i) - & +PBlock(1,3)*Cmo(In+2*iSkutt,i) - Ctemp2=PBlock(2,1)*Cmo(In,i)+PBlock(2,2)*Cmo(In+iSkutt,i) - & +PBlock(2,3)*Cmo(In+2*iSkutt,i) - Ctemp3=PBlock(3,1)*Cmo(In,i)+PBlock(3,2)*Cmo(In+iSkutt,i) - & +PBlock(3,3)*Cmo(In+2*iSkutt,i) - Cmo(In,i)=Ctemp1 - Cmo(In+iSkutt,i)=Ctemp2 - Cmo(In+2*iSkutt,i)=Ctemp3 - ElseIf(IqSuckOut.eq.3) then !This is d-function - iSkutt=nCnC(j) - Ctemp1=DBlock(1,1)*Cmo(In,i)+DBlock(1,2)*Cmo(In+iSkutt,i) - & +DBlock(1,3)*Cmo(In+2*iSkutt,i) - & +DBlock(1,4)*Cmo(In+3*iSkutt,i) - & +DBlock(1,5)*Cmo(In+4*iSkutt,i) - Ctemp2=DBlock(2,1)*Cmo(In,i)+DBlock(2,2)*Cmo(In+iSkutt,i) - & +DBlock(2,3)*Cmo(In+2*iSkutt,i) - & +DBlock(2,4)*Cmo(In+3*iSkutt,i) - & +DBlock(2,5)*Cmo(In+4*iSkutt,i) - Ctemp3=DBlock(3,1)*Cmo(In,i)+DBlock(3,2)*Cmo(In+iSkutt,i) - & +DBlock(3,3)*Cmo(In+2*iSkutt,i) - & +DBlock(3,4)*Cmo(In+3*iSkutt,i) - & +DBlock(3,5)*Cmo(In+4*iSkutt,i) - Ctemp4=DBlock(4,1)*Cmo(In,i)+DBlock(4,2)*Cmo(In+iSkutt,i) - & +DBlock(4,3)*Cmo(In+2*iSkutt,i) - & +DBlock(4,4)*Cmo(In+3*iSkutt,i) - & +DBlock(4,5)*Cmo(In+4*iSkutt,i) - Ctemp5=DBlock(5,1)*Cmo(In,i)+DBlock(5,2)*Cmo(In+iSkutt,i) - & +DBlock(5,3)*Cmo(In+2*iSkutt,i) - & +DBlock(5,4)*Cmo(In+3*iSkutt,i) - & +DBlock(5,5)*Cmo(In+4*iSkutt,i) - Cmo(In,i)=Ctemp1 - Cmo(In+iSkutt,i)=Ctemp2 - Cmo(In+2*iSkutt,i)=Ctemp3 - Cmo(In+3*iSkutt,i)=Ctemp4 - Cmo(In+4*iSkutt,i)=Ctemp5 - Else !Here we go if non-implemented angular quantum number - !appears. - Write(6,*) - Write(6,*)' ERROR in OrbRot2. I''m not ready for f-orbitals' - Call Quit(_RC_GENERAL_ERROR_) - Endif -20 Continue -10 Continue - - Return - End diff -Nru openmolcas-22.02/src/qmstat/orbrot2.F90 openmolcas-22.10/src/qmstat/orbrot2.F90 --- openmolcas-22.02/src/qmstat/orbrot2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/orbrot2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,199 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Anders Ohrn * +!*********************************************************************** +! OrbRot2 +! +!> @brief +!> Rotate orbitals of the solvent +!> @author A. Ohrn +!> +!> @details +!> Given a rotation matrix \f$ R \f$ it is easy to rotate the p-orbitals since +!> they behave just like the three axes. The d-orbitals are more +!> intricate. +!> +!> To obtain a representation +!> of the d-orbital \f$ \mathrm{d}_{xy} \f$ we perform the outer product +!> \f$ \mathrm{d}_x \mathrm{d}_y + \mathrm{d}_y \mathrm{d}_x \f$, +!> which generates a two-dimensional matrix. Now rotate each px and py +!> and perform this multiplication. We obtain a symmetric matrix from +!> whose elements we can compute how the \f$ \mathrm{d}_{xy} \f$ transforms when +!> rotated. The same is done for the other d-orbitals and we can +!> construct a transformation matrix, which we apply to the MO-coeff. +!> Other ways to look at it are available, but the present one can be +!> seen as a generation of table 3 in \cite Iva1996-JPC-100-6342. +!> The present method is efficient +!> with no trigonometric functions and ample use of BLAS_UTIL. +!> +!> @note +!> ::Qfread as well as ::transrot must precede. +!> +!> @param[in] Rot The rotation matrix +!> @param[in,out] Cmo The MO-coefficients +!> @param[in] iQ The angular type of the \f$ i \f$ -th basis +!> (observe, not the \f$ i \f$ -th basis function, see givemeinfo) +!> @param[in] iOrb Number of orbitals +!> @param[in] nBas Number of basis functions +!> @param[in] lMax Number of bases (not basis functions), see ::qfread +!> @param[in] nCnC Number of contracted basis functions of same type as the \f$ i \f$ -th basis. +!> For example 7s4p will have vector ``7,7,7,7,7,7,7,4,4,4,4``. +!*********************************************************************** + +subroutine OrbRot2(Rot,Cmo,iQ,iOrb,nBas,lMax,nCnC) + +use Constants, only: Zero, One, Three, Half +use Definitions, only: wp, iwp, u6 + +implicit none +real(kind=wp), intent(in) :: Rot(3,3) +integer(kind=iwp), intent(in) :: lMax, iQ(lMax), iOrb, nBas, nCnC(lMax) +real(kind=wp), intent(inout) :: Cmo(nBas,iOrb) +integer(kind=iwp) :: i, iIn, IqSuckOut, ISkutt, j +real(kind=wp) :: Ctemp1, Ctemp2, Ctemp3, Ctemp4, Ctemp5, DBlock(5,5), Dxmin(6), Dxy(6), Dxz(6), Dyz(6), Dzz(6), PBlock(3,3), r1, & + r2, r3, r4, Resx(3), Resy(3), Resz(3) +logical(kind=iwp) :: NewIq +real(kind=wp), parameter :: dUnit(6) = [-One,Zero,Zero,-One,Zero,-One], Px(3) = [One,Zero,Zero], Py(3) = [Zero,One,Zero], & + Pz(3) = [Zero,Zero,One] +#include "warnings.h" + +! Dgemv multiply the matrix Rot on the vector Px. For details about +! various parameters see the source code for the routine; it is very +! detailed. Here we get the p-orbitals which also are used to obtain +! the transformation of the other orbitals. + +call dGeMV_('N',3,3,One,Rot,3,Px,1,Zero,Resx,1) +call dGeMV_('N',3,3,One,Rot,3,Py,1,Zero,Resy,1) +call dGeMV_('N',3,3,One,Rot,3,Pz,1,Zero,Resz,1) + +! Construct the p-block. Easy since they are linear polynomials in the cartesian R-matrix. + +PBlock(:,1) = Resx +PBlock(:,2) = Resy +PBlock(:,3) = Resz + +! Generation of quadratic polynomial of R-matrix elements for d_xy. + +Dxy(:) = Zero +call Dspr2('L',3,One,Resx,1,Resy,1,Dxy) + +! Generation of quadratic polynomial of R-matrix elements for d_xz. + +Dxz(:) = Zero +call Dspr2('L',3,One,Resx,1,Resz,1,Dxz) + +! Generation of quadratic polynomial of R-matrix elements for d_yz. + +Dyz(:) = Zero +call Dspr2('L',3,One,Resy,1,Resz,1,Dyz) + +! Generation of quadratic polynomial of R-matrix elements for d_xx-yy. + +Dxmin(:) = Zero +call Dspr('L',3,One,Resx,1,Dxmin) +call Dspr('L',3,-One,Resy,1,Dxmin) + +! Generation of quadratic polynomial of R-matrix elements for d_3zz-1. + +Dzz(:) = dUnit +call Dspr('L',3,Three,Resz,1,Dzz) + +! Construct the d-block. This requires knowledge of how Molcas +! handles d-orbitals, especially their normalization, which is the +! reason for the constants r1,r2,r3,r4. + +r1 = One +r2 = sqrt(Three) +r3 = One +r4 = One/sqrt(Three) +DBlock(1,1) = r1*Dxy(2) !dxy-->dxy +DBlock(2,1) = r1*Dxy(5) !dxy-->dyz +DBlock(3,1) = (r1/r4)*Half*Dxy(6) !dxy-->d3zz-1 +DBlock(4,1) = r1*Dxy(3) !dxy-->dxz +DBlock(5,1) = (r1/r3)*(Dxy(1)+Half*Dxy(6)) !dxy-->dxx-yy +DBlock(1,2) = r1*Dyz(2) !dyz-->dxy +DBlock(2,2) = r1*Dyz(5) !dyz-->dyz +DBlock(3,2) = (r1/r4)*Half*Dyz(6) !dyz-->d3zz-1 +DBlock(4,2) = r1*Dyz(3) !dyz-->dxz +DBlock(5,2) = (r1/r3)*(Dyz(1)+Half*Dyz(6)) !dyz-->dxx-yy +DBlock(1,3) = r4*Dzz(2) !d3zz-->dxy +DBlock(2,3) = r4*Dzz(5) !d3zz-->dyz +DBlock(3,3) = r1*Half*Dzz(6) !d3zz-->d3zz +DBlock(4,3) = r4*Dzz(3) !d3zz-->dxz +DBlock(5,3) = (r1/r2)*(Dzz(1)+Half*Dzz(6)) !d3zz-->dxx-yy +DBlock(1,4) = r1*Dxz(2) !dxz-->dxy +DBlock(2,4) = r1*Dxz(5) !dxz-->dyz +DBlock(3,4) = (r1/r4)*Half*Dxz(6) !dxz-->d3zz-1 +DBlock(4,4) = r1*Dxz(3) !dxz-->dxz +DBlock(5,4) = (r1/r3)*(Dxz(1)+Half*Dxz(6)) !dxz-->dxx-yy +DBlock(1,5) = r3*Dxmin(2) !dxx-yy-->dxy +DBlock(2,5) = r3*Dxmin(5) !dxx-yy-->dyz +DBlock(3,5) = r2*Half*Dxmin(6) !dxx-yy-->d3zz +DBlock(4,5) = r3*Dxmin(3) !dxx-yy-->dxz +DBlock(5,5) = r1*(Dxmin(1)+Half*Dxmin(6)) !dxx-yy-->dxx-yy + +! With the proper number of blocks at hand, we make transformation. +! The brute force way is to construct the entire transformation matrix +! and make a matrix multiplication. Since so many elements in that +! matrix are zero, more effecient ways to transform are available. +! That is what is used below. The formulas follow from considering the +! transformation matrix multiplied with the CMO-matrix. Multio +! importante is it to observe how the basis functions in Molcas are +! ordered! + +do i=1,iOrb + ! OBSERVE!!! WE ARE ASSUMING THAT THE FIRST BASIS IS OF S-TYPE!!! IF YOU ARE IMPLEMENTING SYMMETRY, THIS + ! MIGHT NOT BE A VALID ASSUMPTION SO THEN THE NEWIQ-CONSTRUCT BELOW MUST BE ALTERED!!! + iIn = 1 + do j=2,lMax + iIn = iIn+1 + IqSuckOut = iQ(j) + NewIq = iQ(j) /= iQ(j-1) + !This if-clause controls the jumping when new angular basis function appears. + if (Newiq) iIn = iIn+(2*iQ(j-1)-2)*nCnC(j-1) + select case (iqSuckOut) + case (1) !This is s-function + case (2) !This is p-function + iSkutt = nCnC(j) + Ctemp1 = PBlock(1,1)*Cmo(iIn,i)+PBlock(1,2)*Cmo(iIn+iSkutt,i)+PBlock(1,3)*Cmo(iIn+2*iSkutt,i) + Ctemp2 = PBlock(2,1)*Cmo(iIn,i)+PBlock(2,2)*Cmo(iIn+iSkutt,i)+PBlock(2,3)*Cmo(iIn+2*iSkutt,i) + Ctemp3 = PBlock(3,1)*Cmo(iIn,i)+PBlock(3,2)*Cmo(iIn+iSkutt,i)+PBlock(3,3)*Cmo(iIn+2*iSkutt,i) + Cmo(iIn,i) = Ctemp1 + Cmo(iIn+iSkutt,i) = Ctemp2 + Cmo(iIn+2*iSkutt,i) = Ctemp3 + case (3) !This is d-function + iSkutt = nCnC(j) + Ctemp1 = DBlock(1,1)*Cmo(iIn,i)+DBlock(1,2)*Cmo(iIn+iSkutt,i)+DBlock(1,3)*Cmo(iIn+2*iSkutt,i)+ & + DBlock(1,4)*Cmo(iIn+3*iSkutt,i)+DBlock(1,5)*Cmo(iIn+4*iSkutt,i) + Ctemp2 = DBlock(2,1)*Cmo(iIn,i)+DBlock(2,2)*Cmo(iIn+iSkutt,i)+DBlock(2,3)*Cmo(iIn+2*iSkutt,i)+ & + DBlock(2,4)*Cmo(iIn+3*iSkutt,i)+DBlock(2,5)*Cmo(iIn+4*iSkutt,i) + Ctemp3 = DBlock(3,1)*Cmo(iIn,i)+DBlock(3,2)*Cmo(iIn+iSkutt,i)+DBlock(3,3)*Cmo(iIn+2*iSkutt,i)+ & + DBlock(3,4)*Cmo(iIn+3*iSkutt,i)+DBlock(3,5)*Cmo(iIn+4*iSkutt,i) + Ctemp4 = DBlock(4,1)*Cmo(iIn,i)+DBlock(4,2)*Cmo(iIn+iSkutt,i)+DBlock(4,3)*Cmo(iIn+2*iSkutt,i)+ & + DBlock(4,4)*Cmo(iIn+3*iSkutt,i)+DBlock(4,5)*Cmo(iIn+4*iSkutt,i) + Ctemp5 = DBlock(5,1)*Cmo(iIn,i)+DBlock(5,2)*Cmo(iIn+iSkutt,i)+DBlock(5,3)*Cmo(iIn+2*iSkutt,i)+ & + DBlock(5,4)*Cmo(iIn+3*iSkutt,i)+DBlock(5,5)*Cmo(iIn+4*iSkutt,i) + Cmo(iIn,i) = Ctemp1 + Cmo(iIn+iSkutt,i) = Ctemp2 + Cmo(iIn+2*iSkutt,i) = Ctemp3 + Cmo(iIn+3*iSkutt,i) = Ctemp4 + Cmo(iIn+4*iSkutt,i) = Ctemp5 + case default !Here we go if non-implemented angular quantum number appears. + write(u6,*) + write(u6,*) ' ERROR in OrbRot2. Not ready for f-orbitals' + call Quit(_RC_GENERAL_ERROR_) + end select + end do +end do + +return + +end subroutine OrbRot2 diff -Nru openmolcas-22.02/src/qmstat/overlq.f openmolcas-22.10/src/qmstat/overlq.f --- openmolcas-22.02/src/qmstat/overlq.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/overlq.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,359 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Anders Ohrn * -************************************************************************ -* OverLq -* -*> @brief -*> Compute overlap between primitve bases, which for bases of other type than s, -*> will mean that several overlaps between basis-functions are computed. One -*> function is on the solvent, the other in the QM-region. Observe that we do not -*> care about overlaps within the QM-region or among the solvent molecules. -*> @author A. Ohrn -*> -*> @details -*> Uses the formulas in \cite Tak1966-JPSJ-21-2313. It is hard to give any -*> easy explanation, so if you want to understand exactly what is -*> going on below, see the article, especially equations (2.4) and -*> (2.12); then the source-code comments will provide you with -*> sufficient information. -*> -*> @param[in] Bori Center for the QM-region contracted basis-function -*> @param[in] Cori Like Bori, but for the solvent basis-function -*> @param[in] Alfa Exponents for the primitive basis-functions that build this contracted function -*> @param[in] Beta Like \p alfa, but for solvent -*> @param[in] iQ1 = ``1`` if s-type, = ``2`` if p-type, etc. for the function in the QM-region -*> @param[in] iQ2 Like \p iQ1, but for solvent function -*> @param[in] nExp1 How many primitives there are in this contracted function -*> @param[in] nExp2 Like \p nExp1, but for (surprise) the solvent -*> @param[out] iPSint Pointer to the matrix of overlaps -*> @param[in] Trans Transition matrix between Cartesian and spherical basis functions -************************************************************************ - Subroutine OverLq(Bori,Cori,Alfa,Beta,iQ1,iQ2,nExp1,nExp2,iPSint - & ,Trans) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "numbers.fh" -#include "WrkSpc.fh" -#include "warnings.h" - -* MaxAngqNr=4 means f-function is top. There is no limit in the -* algorithm though, so if higher is needed, change this number. - Parameter(MaxAr=MxAngqNr*(MxAngqNr+1)/2) - Dimension Bori(3),Cori(3),Alfa(MxCont),Beta(MxCont) - Dimension Trans(int(dble(3*MxAngqNr**2-2*MxAngqNr-10+8*MxAngqNr**3 - & +3*MxAngqNr**4)/12)) - Dimension PAxyz(3),PBxyz(3),TheCent(3) - Dimension FactorX(2*MxAngqNr+1),FactorY(2*MxAngqNr+1) - Dimension FactorZ(2*MxAngqNr+1) - Dimension nCartxQ(MaxAr),nCartyQ(MaxAr),nCartzQ(MaxAr) - Dimension nCartxC(MaxAr),nCartyC(MaxAr),nCartzC(MaxAr) -*----------------------------------------------------------------------* -* Prepare some numbers for later. * -*----------------------------------------------------------------------* - ind=0 - nSpecific1=iQ1*(iQ1+1)/2 !Remember that each base consist of - nSpecific2=iQ2*(iQ2+1)/2 !many functions - this is how many. - icompo=nSpecific1 - Do 14, ix=0,iQ1-1 !Then follows the NEW loops that compute how - Do 15, iy=0,iQ1-1-ix !the cartesian components are ordered in - iz=iQ1-1-iy-ix !various basis functions. - ncartxQ(icompo)=ix - ncartyQ(icompo)=iy - ncartzQ(icompo)=iz - icompo=icompo-1 -15 Continue -14 Continue - icompo=nSpecific2 - Do 16, ix=0,iQ2-1 !And for the solvent orbitals. - Do 17, iy=0,iQ2-1-ix - iz=iQ2-1-iy-ix - ncartxC(icompo)=ix - ncartyC(icompo)=iy - ncartzC(icompo)=iz - icompo=icompo-1 -17 Continue -16 Continue - nSph1=2*iQ1-1 - nSph2=2*iQ2-1 - nSizeCart=nSpecific1*nSpecific2 - nSizeSph=nSph1*nSph2 - nBigP=nExp1*nExp2*nSph1*nSph2 - Call GetMem('PrimCar','Allo','Real',iPpS,nSizeCart) - Call GetMem('PrimSph','Allo','Real',iPsphS,nSizeSph) - Call GetMem('AllPrims','Allo','Real',iPSint,nBigP) - Do 8, i=1,nBigP - Work(iPSint+i-1)=0 -8 Continue - Separation=((Bori(1)-Cori(1))**2+(Bori(2)-Cori(2))**2 - & +(Bori(3)-Cori(3))**2) -*----------------------------------------------------------------------* -* Start loop over primitives. * -*----------------------------------------------------------------------* - Kaunt=0 - Do 101, iP1=1,nExp1 - Do 102, iP2=1,nExp2 - Kaunt=Kaunt+1 - TheCent(1)=(Alfa(iP1)*Bori(1)+Beta(iP2)*Cori(1)) - TheCent(2)=(Alfa(iP1)*Bori(2)+Beta(iP2)*Cori(2)) - TheCent(3)=(Alfa(iP1)*Bori(3)+Beta(iP2)*Cori(3)) - Divide=1/(Alfa(iP1)+Beta(iP2)) !gamma in article - TheCent(1)=TheCent(1)*Divide !The new center, P - TheCent(2)=TheCent(2)*Divide - TheCent(3)=TheCent(3)*Divide - Piconst=Pi*Divide - SqPiconst=sqrt(Piconst) - Piconst=Piconst*SqPiconst !That constant to the power of 3/2 - Expo=Alfa(iP1)*Beta(iP2)*Separation*Divide - TheFirstFac=Piconst*exp(-Expo) !This is the exponential factor -*Now we should get those difficult f-functions. - PAxyz(1)=TheCent(1)-Bori(1) - PAxyz(2)=TheCent(2)-Bori(2) - PAxyz(3)=TheCent(3)-Bori(3) - PBxyz(1)=TheCent(1)-Cori(1) - PBxyz(2)=TheCent(2)-Cori(2) - PBxyz(3)=TheCent(3)-Cori(3) - kaunter=0 - Do 103, iSp1=1,nSpecific1 - Do 104, iSp2=1,nSpecific2 - kaunter=kaunter+1 - loneX=ncartxQ(iSp1) - ltwoX=ncartxC(iSp2) - lsumX=loneX+ltwoX - loneY=ncartyQ(iSp1) - ltwoY=ncartyC(iSp2) - lsumY=loneY+ltwoY - loneZ=ncartzQ(iSp1) - ltwoZ=ncartzC(iSp2) - lsumZ=loneZ+ltwoZ - Call fFactor(loneX,ltwoX,lsumX,loneY,ltwoY,lsumY,loneZ - & ,ltwoZ,lsumZ,PAxyz,PBxyz,FactorX,FactorY - & ,FactorZ) -*Now we have the f-factors for this specific angular type of this -*specific primitive basis-function. Now put things together. - iUpX=lsumX/2 !Yes, it should be like this, even when lsumX - iUpY=lsumY/2 !is odd. - iUpZ=lsumZ/2 - SummaX=0 - SummaY=0 - SummaZ=0 - Do 131, ixxx=0,iUpX - Extra=iDubFac(2*ixxx-1)*(0.5*Divide)**ixxx !This is - SummaX=SummaX+FactorX(2*ixxx+1)*Extra !just a matter of -131 Continue !putting things - Do 132, iyyy=0,iUpY !together according to the - Extra=iDubFac(2*iyyy-1)*(0.5*Divide)**iyyy !formula - SummaY=SummaY+FactorY(2*iyyy+1)*Extra -132 Continue - Do 133, izzz=0,iUpZ - Extra=iDubFac(2*izzz-1)*(0.5*Divide)**izzz - SummaZ=SummaZ+FactorZ(2*izzz+1)*Extra -133 Continue - Primequals=TheFirstFac*SummaX*SummaY*SummaZ - Work(iPpS+kaunter-1)=Primequals -104 Continue -103 Continue -*----------------------------------------------------------------------* -* This was the overlap for the primitives in terms of cartesian * -* functions, but in the new qmstat we use spherical functions, so we * -* need to transform if any d-function or higher is involved. In the * -* matrix Trans the numbers for how spherical functions are expressed in* -* cartesian functions are stored, including the extra normalization so * -* that all d-functions (and higher) have the same combined contraction * -* and normalization coefficient. The rest is just a matter of getting * -* the matrix multiplications right. The convention I use is this: The * -* matrix with the overlaps contain elements such as <psi_QM|psi_Solv> * -* in other words, the QM-orbitals count over the rows and the solvent * -* orbitals over the columns; observe however that this is NOT the way * -* the matrix enters from above, since there the fastest couting index * -* is over solvent orbitals (iSp2), so given this and the knowledge of * -* how Fortran stores multidimensional matrices, we can figure out when * -* to transpose. All this means that if it is the QM-orbitals that are * -* to be transformed, the transformation matrix is multiplied from left,* -* while it is multiplied from the right -- transposed of course -- if * -* it is the solvent orbitals that are to be transformed. In the case * -* that both orbitals are to be transformed we simply apply the trans- * -* formation matrix from both directions. * -*----------------------------------------------------------------------* - If(iQ1.ge.3.or.iQ2.ge.3) then !Check if any transformations - !are necessary. - If(iQ2.lt.3) then !If only the base of the QM-region needs - !to be transformed. - ind=1+(iQ1-3)*(3*iQ1**3+5*iQ1**2+12*iQ1+40)/12 - Call Dgemm_('N','T',nSph1,nSpecific2,nSpecific1,ONE - & ,Trans(ind),nSph1,Work(iPps),nSpecific2,ZERO - & ,Work(iPsphS),nSph1) - Elseif(iQ1.lt.3) then !If only solvent base needs to be - !transformed. - ind=1+(iQ2-3)*(3*iQ2**3+5*iQ2**2+12*iQ2+40)/12 - Call Dgemm_('T','T',nSph1,nSph2,nSpecific2,ONE - & ,Work(iPps),nSpecific2,Trans(ind),nSph2,ZERO - & ,Work(iPsphS),nSph1) - Else !Both QM-region and Solvent need to be transformed. - ind1=1+(iQ1-3)*(3*iQ1**3+5*iQ1**2+12*iQ1+40)/12 - ind2=1+(iQ2-3)*(3*iQ2**3+5*iQ2**2+12*iQ2+40)/12 - Call GetMem('Intmd','Allo','Real',iPInte,nSph1*nSpecific2) - Call Dgemm_('N','T',nSph1,nSpecific2,nSpecific1,ONE - & ,Trans(ind1),nSph1,Work(iPps),nSpecific2,ZERO - & ,Work(iPInte),nSph1) - Call Dgemm_('N','T',nSph1,nSph2,nSpecific2,ONE - & ,Work(iPInte),nSph1,Trans(ind2),nSph2,ZERO - & ,Work(iPsphS),nSph1) - Call GetMem('Intmd','Free','Real',iPInte,nSph1*nSpecific2) - Endif - Else !Here we only transpose to get integrals in right - krakna=0 !order. - Do 136, i=0,nSph1-1 - Do 137, j=0,nSph2-1 - Work(iPsphS+krakna)=Work(iPps+i+j*nSph1) - krakna=krakna+1 -137 Continue -136 Continue - Endif -*----------------------------------------------------------------------* -* Put this thing in the slowly growing overlap matrix for the * -* primitive basis functions. The reason the index is so nasty is that * -* we compute small blocks of the matrix and now have to fit it in the * -* right place in the growing, much larger, matrix. Nasty! * -*----------------------------------------------------------------------* - krakna=0 - Do 141, j=0,nSph2-1 - Do 142, i=0,nSph1-1 - jndex=i+j*nExp1*nSph1+(iP1-1)*nSph1 - & +(iP2-1)*nExp1*nSph1*nSph2 - Work(iPSint+jndex)=Work(iPsphS+krakna) - krakna=krakna+1 -142 Continue -141 Continue -102 Continue -101 Continue -*----------------------------------------------------------------------* -* Deallocate and ta'ta! * -*----------------------------------------------------------------------* - Call GetMem('PrimCar','Free','Real',iPpS,nSizeCart) - Call GetMem('PrimSph','Free','Real',iPsphS,nSizeSph) - - Return - End - -*----------------------------------------------------------------------* -* A function that returns the binomial coefficient. The coefficients * -* are stored since N and P will not under normal circumstances be * -* so large. * -*----------------------------------------------------------------------* - Integer Function NoverP_Q(N,P) - Integer N,P,Bino(22) - Data (Bino(i),i=1,21)/1,1,1,1,2,1,1,3,3,1 - & ,1,4,6,4,1,1,5,10,10,5,1/ - NoverP_Q=1 - If(N.ge.6) then - Write(6,*)'Must extend NoverP_Q!' - Call Quit(_RC_INTERNAL_ERROR_) - Else - ind=(N+1)*(N+2)/2-(N-P) - NoverP_Q=Bino(ind) - Endif - Return - End -*----------------------------------------------------------------------* -* A function that will return the double factorial. We do not expect * -* big numbers, so we do it brute-force. Observe that N must be odd, but* -* to skip the if-sentence, we assume that the one who calls this * -* function has seen to that. * -*----------------------------------------------------------------------* - Integer Function iDubFac(N) - Integer N - iDubFac=1 - Do 1101, k=3,N,2 - iDubFac=iDubFac*k -1101 Continue - Return - End -*----------------------------------------------------------------------* -* A subroutine that computes those darn f-factors. They are definied * -* in equation (2.4) in the article cited above. As can be seen from * -* that equation, the computation of the f-factors is actually a matter * -* of using the binomial theorem. This is what we do below and to make * -* the computation efficient the expression (2.4) is written as a * -* succint double sum. * -*----------------------------------------------------------------------* - Subroutine fFactor(loneX,ltwoX,lsumX,loneY,ltwoY,lsumY,loneZ - & ,ltwoZ,lsumZ,PAxyz,PBxyz,FactorX,FactorY,FactorZ) - Implicit Real*8 (a-h,o-z) - - Parameter(MaxAngqNr=6,MaxAr=MaxAngqNr*(MaxAngqNr+1)/2) - Dimension FactorX(2*MaxAngqNr+1),FactorY(2*MaxAngqNr+1) - Dimension FactorZ(2*MaxAngqNr+1) - Dimension PAxyz(3),PBxyz(3) - - Do 105, ia=0,lsumX !We use unrolled loops with regard to x,y and z - fff2=0 !therefore, here we start with the x-factors. - iLowB=max(0,ia-ltwoX) !These lower and upper bounds have to do - iUpB=min(ia,loneX) !with the allowed numbers in the binomial - Do 106, i=iLowB,iUpB !coefficients. - fff1=NoverP_Q(loneX,i)*NoverP_Q(ltwoX,ia-i) - If(i.ne.0) then !This is needed for some compilers (NAG_64) - PAraise=PAxyz(1)**i - Else - PAraise=1.0d0 - Endif - If(ia-i.ne.0) then - PBraise=PBxyz(1)**(ia-i) - Else - PBraise=1.0d0 - Endif - fff2=fff2+fff1*PAraise*PBraise -106 Continue - FactorX(lsumX-ia+1)=fff2 -105 Continue - Do 115, ia=0,lsumY !y-factors. - fff2=0 - iLowB=max(0,ia-ltwoY) - iUpB=min(ia,loneY) - Do 116, i=iLowB,iUpB - fff1=NoverP_Q(loneY,i)*NoverP_Q(ltwoY,ia-i) - If(i.ne.0) then !This is needed for some compilers (NAG_64) - PAraise=PAxyz(2)**i - Else - PAraise=1.0d0 - Endif - If(ia-i.ne.0) then - PBraise=PBxyz(2)**(ia-i) - Else - PBraise=1.0 - Endif - fff2=fff2+fff1*PAraise*PBraise -116 Continue - FactorY(lsumY-ia+1)=fff2 -115 Continue - Do 125, ia=0,lsumZ !z-factorz. - fff2=0 - iLowB=max(0,ia-ltwoZ) - iUpB=min(ia,loneZ) - Do 126, i=iLowB,iUpB - fff1=NoverP_Q(loneZ,i)*NoverP_Q(ltwoZ,ia-i) - If(i.ne.0) then !This is needed for some compilers (NAG_64) - PAraise=PAxyz(3)**i - Else - PAraise=1.0d0 - Endif - If(ia-i.ne.0) then - PBraise=PBxyz(3)**(ia-i) - Else - PBraise=1.0d0 - Endif - fff2=fff2+fff1*PAraise*PBraise -126 Continue - Factorz(lsumZ-ia+1)=fff2 -125 Continue - Return - End diff -Nru openmolcas-22.02/src/qmstat/overlq.F90 openmolcas-22.10/src/qmstat/overlq.F90 --- openmolcas-22.02/src/qmstat/overlq.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/overlq.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,227 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Anders Ohrn * +!*********************************************************************** +! OverLq +! +!> @brief +!> Compute overlap between primitive bases, which for bases of other type than s, +!> will mean that several overlaps between basis-functions are computed. One +!> function is on the solvent, the other in the QM-region. Observe that we do not +!> care about overlaps within the QM-region or among the solvent molecules. +!> @author A. Ohrn +!> +!> @details +!> Uses the formulas in \cite Tak1966-JPSJ-21-2313. It is hard to give any +!> easy explanation, so if you want to understand exactly what is +!> going on below, see the article, especially equations (2.4) and +!> (2.12); then the source-code comments will provide you with +!> sufficient information. +!> +!> @param[in] Bori Center for the QM-region contracted basis-function +!> @param[in] Cori Like Bori, but for the solvent basis-function +!> @param[in] Alfa Exponents for the primitive basis-functions that build this contracted function +!> @param[in] Beta Like \p alfa, but for solvent +!> @param[in] iQ1 = ``1`` if s-type, = ``2`` if p-type, etc. for the function in the QM-region +!> @param[in] iQ2 Like \p iQ1, but for solvent function +!> @param[in] nExp1 How many primitives there are in this contracted function +!> @param[in] nExp2 Like \p nExp1, but for (surprise) the solvent +!> @param[out] PSint The matrix of overlaps +!*********************************************************************** + +subroutine OverLq(Bori,Cori,Alfa,Beta,iQ1,iQ2,nExp1,nExp2,PSint) + +use qmstat_global, only: MxAngqNr, Trans +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Half, Pi +use Definitions, only: wp, iwp + +implicit none +! MaxAngqNr=4 means f-function is top. There is no limit in the algorithm though, so if higher is needed, change this number. +integer(kind=iwp), intent(in) :: iQ1, iQ2, nExp1, nExp2 +real(kind=wp), intent(in) :: Bori(3), Cori(3), Alfa(nExp1), Beta(nExp2) +real(kind=wp), intent(out) :: PSint(2*iQ1-1,nExp1,2*iQ2-1,nExp2) +integer(kind=iwp) :: i, icompo, ind, ind1, ind2, iP1, iP2, iSp1, iSp2, iUpX, iUpY, iUpZ, ix, ixxx, iy, iyyy, iz, izzz, j, Kaunt, & + kaunter, krakna, loneX, loneY, loneZ, lsumX, lsumY, lsumZ, ltwoX, ltwoY, ltwoZ, nCartxC(nTri_Elem(MxAngqNr)), & + nCartxQ(nTri_Elem(MxAngqNr)), nCartyC(nTri_Elem(MxAngqNr)), nCartyQ(nTri_Elem(MxAngqNr)), & + nCartzC(nTri_Elem(MxAngqNr)), nCartzQ(nTri_Elem(MxAngqNr)), nSizeCart, nSizeSph, nSpecific1, nSpecific2, & + nSph1, nSph2 +real(kind=wp) :: Divide, Expo, Extra, FactorX(2*MxAngqNr+1), FactorY(2*MxAngqNr+1), FactorZ(2*MxAngqNr+1), PAxyz(3), PBxyz(3), & + Piconst, Primequals, Separation, SqPiconst, SummaX, SummaY, SummaZ, TheCent(3), TheFirstFac +real(kind=wp), allocatable :: PInte(:,:), Pps(:), PsphS(:) +integer(kind=iwp), external :: iDubFac + +!----------------------------------------------------------------------* +! Prepare some numbers for later. * +!----------------------------------------------------------------------* +ind = 0 +! Remember that each base consist of many functions - this is how many. +nSpecific1 = nTri_Elem(iQ1) +nSpecific2 = nTri_Elem(iQ2) +icompo = nSpecific1 +! Then follows the NEW loops that compute how the cartesian components are ordered in various basis functions. +do ix=0,iQ1-1 + do iy=0,iQ1-1-ix + iz = iQ1-1-iy-ix + ncartxQ(icompo) = ix + ncartyQ(icompo) = iy + ncartzQ(icompo) = iz + icompo = icompo-1 + end do +end do +icompo = nSpecific2 +! And for the solvent orbitals. +do ix=0,iQ2-1 + do iy=0,iQ2-1-ix + iz = iQ2-1-iy-ix + ncartxC(icompo) = ix + ncartyC(icompo) = iy + ncartzC(icompo) = iz + icompo = icompo-1 + end do +end do +nSph1 = 2*iQ1-1 +nSph2 = 2*iQ2-1 +nSizeCart = nSpecific1*nSpecific2 +nSizeSph = nSph1*nSph2 +call mma_allocate(PpS,nSizeCart,label='PrimCar') +call mma_allocate(PsphS,nSizeSph,label='PrimSph') +PSint(:,:,:,:) = Zero +Separation = ((Bori(1)-Cori(1))**2+(Bori(2)-Cori(2))**2+(Bori(3)-Cori(3))**2) +!----------------------------------------------------------------------* +! Start loop over primitives. * +!----------------------------------------------------------------------* +Kaunt = 0 +do iP1=1,nExp1 + do iP2=1,nExp2 + Kaunt = Kaunt+1 + TheCent(:) = (Alfa(iP1)*Bori(:)+Beta(iP2)*Cori(:)) + Divide = One/(Alfa(iP1)+Beta(iP2)) !gamma in article + TheCent(:) = TheCent(:)*Divide !The new center, P + Piconst = Pi*Divide + SqPiconst = sqrt(Piconst) + Piconst = Piconst*SqPiconst !That constant to the power of 3/2 + Expo = Alfa(iP1)*Beta(iP2)*Separation*Divide + TheFirstFac = Piconst*exp(-Expo) !This is the exponential factor + ! Now we should get those difficult f-functions. + PAxyz(:) = TheCent-Bori + PBxyz(:) = TheCent-Cori + kaunter = 0 + do iSp1=1,nSpecific1 + do iSp2=1,nSpecific2 + kaunter = kaunter+1 + loneX = ncartxQ(iSp1) + ltwoX = ncartxC(iSp2) + lsumX = loneX+ltwoX + loneY = ncartyQ(iSp1) + ltwoY = ncartyC(iSp2) + lsumY = loneY+ltwoY + loneZ = ncartzQ(iSp1) + ltwoZ = ncartzC(iSp2) + lsumZ = loneZ+ltwoZ + call fFactor(loneX,ltwoX,lsumX,loneY,ltwoY,lsumY,loneZ,ltwoZ,lsumZ,PAxyz,PBxyz,FactorX,FactorY,FactorZ) + ! Now we have the f-factors for this specific angular type of this + ! specific primitive basis-function. Now put things together. + iUpX = lsumX/2 !Yes, it should be like this, even when lsumX is odd. + iUpY = lsumY/2 + iUpZ = lsumZ/2 + SummaX = Zero + SummaY = Zero + SummaZ = Zero + ! This is just a matter of putting things together according to the formula + do ixxx=0,iUpX + Extra = iDubFac(2*ixxx-1)*(Half*Divide)**ixxx + SummaX = SummaX+FactorX(2*ixxx+1)*Extra + end do + do iyyy=0,iUpY + Extra = iDubFac(2*iyyy-1)*(Half*Divide)**iyyy + SummaY = SummaY+FactorY(2*iyyy+1)*Extra + end do + do izzz=0,iUpZ + Extra = iDubFac(2*izzz-1)*(Half*Divide)**izzz + SummaZ = SummaZ+FactorZ(2*izzz+1)*Extra + end do + Primequals = TheFirstFac*SummaX*SummaY*SummaZ + PpS(kaunter) = Primequals + end do + end do + !------------------------------------------------------------------* + ! This was the overlap for the primitives in terms of cartesian * + ! functions, but in the new qmstat we use spherical functions, so * + ! we need to transform if any d-function or higher is involved. In * + ! the matrix Trans the numbers for how spherical functions are * + ! expressed in cartesian functions are stored, including the extra * + ! normalization so that all d-functions (and higher) have the same * + ! combined contraction and normalization coefficient. The rest is * + ! just a matter of getting the matrix multiplications right. The * + ! convention I use is this: The matrix with the overlaps contains * + ! elements such as <psi_QM|psi_Solv> in other words, the * + ! QM-orbitals count over the rows and the solvent orbitals over the* + ! columns; observe however that this is NOT the way the matrix * + ! enters from above, since there the fastest couting index is over * + ! solvent orbitals (iSp2), so given this and the knowledge of how * + ! Fortran stores multidimensional matrices, we can figure out when * + ! to transpose. All this means that if it is the QM-orbitals that * + ! are to be transformed, the transformation matrix is multiplied * + ! from left, while it is multiplied from the right -- transposed of* + ! course -- if it is the solvent orbitals that are to be * + ! transformed. In the case that both orbitals are to be transformed* + ! we simply apply the transformation matrix from both directions. * + !------------------------------------------------------------------* + if ((iQ1 >= 3) .or. (iQ2 >= 3)) then !Check if any transformations are necessary. + if (iQ2 < 3) then !If only the base of the QM-region needs!to be transformed. + ind = 1+(iQ1-3)*(3*iQ1**3+5*iQ1**2+12*iQ1+40)/12 + call Dgemm_('N','T',nSph1,nSpecific2,nSpecific1,One,Trans(ind),nSph1,PpS,nSpecific2,Zero,PsphS,nSph1) + else if (iQ1 < 3) then !If only solvent base needs to be transformed. + ind = 1+(iQ2-3)*(3*iQ2**3+5*iQ2**2+12*iQ2+40)/12 + call Dgemm_('T','T',nSph1,nSph2,nSpecific2,One,PpS,nSpecific2,Trans(ind),nSph2,Zero,PsphS,nSph1) + else !Both QM-region and Solvent need to be transformed. + ind1 = 1+(iQ1-3)*(3*iQ1**3+5*iQ1**2+12*iQ1+40)/12 + ind2 = 1+(iQ2-3)*(3*iQ2**3+5*iQ2**2+12*iQ2+40)/12 + call mma_allocate(PInte,nSph1,nSpecific2,label='Intmd') + call Dgemm_('N','T',nSph1,nSpecific2,nSpecific1,One,Trans(ind1),nSph1,PpS,nSpecific2,Zero,PInte,nSph1) + call Dgemm_('N','T',nSph1,nSph2,nSpecific2,One,PInte,nSph1,Trans(ind2),nSph2,Zero,PsphS,nSph1) + call mma_deallocate(PInte) + end if + else !Here we only transpose to get integrals in right order. + krakna = 0 + do i=1,nSph1 + do j=1,nSph2 + krakna = krakna+1 + PsphS(krakna) = PpS(i+(j-1)*nSph1) + end do + end do + end if + !------------------------------------------------------------------* + ! Put this thing in the slowly growing overlap matrix for the * + ! primitive basis functions. The reason the index is so nasty is * + ! that we compute small blocks of the matrix and now have to fit it* + ! in the right place in the growing, much larger, matrix. Nasty! * + !------------------------------------------------------------------* + krakna = 0 + do j=1,nSph2 + do i=1,nSph1 + krakna = krakna+1 + PSint(i,iP1,j,iP2) = PsphS(krakna) + end do + end do + end do +end do +!----------------------------------------------------------------------* +! Deallocate and ta'ta! * +!----------------------------------------------------------------------* +call mma_deallocate(PpS) +call mma_deallocate(PsphS) + +return + +end subroutine OverLq diff -Nru openmolcas-22.02/src/qmstat/pararoot.f openmolcas-22.10/src/qmstat/pararoot.f --- openmolcas-22.02/src/qmstat/pararoot.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/pararoot.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,229 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Anders Ohrn * -************************************************************************ -* ParaRoot -* -*> @brief -*> Manage the parallel tempering routine -*> @author A. Ohrn -*> -*> @details -*> If our system is difficult and has small transition elements -*> in the Markov chain, we can use the parallel tempering to -*> boost sampling. This routine is the root for this; it -*> mainly handles the various configurations for the different -*> temperature ensembles; also, manages the ensemble switch. -*> -*> @param[in] Ract -*> @param[in] BetaBol -*> @param[in] Etot -*> @param[in,out] CalledBefore -*> @param[out] SampleThis -************************************************************************ - Subroutine ParaRoot(Ract,BetaBol,Etot,CalledBefore,SampleThis) - Implicit Real*8 (a-h,o-z) - External Ranf -#include "maxi.fh" -#include "qminp.fh" -#include "files_qmstat.fh" -#include "WrkSpc.fh" -#include "constants.fh" - -* Parameter (BoltzK=1.0d-3*CONST_BOLTZMANN_/CONV_AU_TO_KJ_) - Dimension iPermutation(2,MxParT) - Dimension CordstTEMP(MxCen*MxPut,3) - Logical CalledBefore,WeiterBitte,Accept,SampleThis - Save iTemp - - BoltzK=1.0d-3*CONST_BOLTZMANN_/CONV_AU_TO_KJ_ - Dum1=0.0d0 -* -*-- If this is first time to call on this routine. -* - If(.not.CalledBefore) then - iTemp=0 - CalledBefore=.true. - Endif - -* -*-- See what to do. -* -999 Continue - If(iTemp.lt.nTemp) then - WeiterBitte=.true. - iTemp=iTemp+1 - Write(6,*) - Write(6,*)' Run a new temperature ensemble...',iTemp - -*----A logical variable to make parallel tempering sampling correct. - If(iTemp.eq.1) then - SampleThis=.true. - Else - SampleThis=.false. - Endif - - Else - WeiterBitte=.false. - iTemp=0 - Write(6,*) - Write(6,*)' Evaluate temperature ensemble interchanges.' - Endif - -* -*-- If we are to run a new ensemble. -* - If(WeiterBitte) then - iLuStIn=8+nStFilT(iTemp) - iLuStUt=16+nStFilT(iTemp) - Write(StFilIn(6:6),'(i1.1)')nStFilT(iTemp) - Write(StFilUt(6:6),'(i1.1)')nStFilT(iTemp) - -*---- Collect coordinates from proper startfile. - Call Get8(Ract,Etot) - -*---- Set temperature. - BetaBol=1.0d0/(ParaTemps(iTemp)*BoltzK) - -* -*-- If we are to attempt interchanges. -* - Else - - Do 10, iPa=1,MxParT - iPermutation(1,iPa)=iPa - iPermutation(2,iPa)=iPa -10 Continue - -*-- Construct permutations, treat nTemp.eq.2 as special case, the others -* are obtained with general algorithm. - If(nTemp.eq.2) then - iPermutation(2,1)=2 - iPermutation(2,2)=1 - Go To 101 - Endif - - PerType=Ranf(iseed) - If(PerType.lt.0.5D+0) then - - If(Mod(nTemp,2).eq.1) then - mTemp=nTemp-1 - Else - mTemp=nTemp - Endif - -*------ Construct permutation for odd iMac - Do 12, iPa=1,mTemp,2 - iPermutation(2,iPa)=iPermutation(1,iPa+1) - iPermutation(2,iPa+1)=iPermutation(1,iPa) -12 Continue - - Else - - mTemp=2*((nTemp-1)/2) -*------ Contruct permutation for even iMac - Do 13, iPa=2,mTemp,2 - iPermutation(2,iPa)=iPermutation(1,iPa+1) - iPermutation(2,iPa+1)=iPermutation(1,iPa) -13 Continue - Endif - -101 Continue - -* -*-- Now attempt interchange. -* - iEnsemb=1 -2001 Continue - If(iPermutation(1,iEnsemb).eq.iPermutation(2,iEnsemb)) then - iEnsemb=iEnsemb+1 - Go To 2001 - Endif - -*------ Collect energies for the permutations. - iLuStIn=8+nStFilT(iPermutation(1,iEnsemb)) - iLuStUt=16+nStFilT(iPermutation(1,iEnsemb)) - Write(StFilIn(6:6),'(i1.1)')nStFilT(iPermutation(1,iEnsemb)) - Write(StFilUt(6:6),'(i1.1)')nStFilT(iPermutation(1,iEnsemb)) - Call Get8(Dum,E1) - iLuStIn=8+nStFilT(iPermutation(2,iEnsemb)) - iLuStUt=16+nStFilT(iPermutation(2,iEnsemb)) - Write(StFilIn(6:6),'(i1.1)')nStFilT(iPermutation(2,iEnsemb)) - Write(StFilUt(6:6),'(i1.1)')nStFilT(iPermutation(2,iEnsemb)) - Call Get8(Dum,E2) - T1=ParaTemps(iPermutation(1,iEnsemb)) - T2=ParaTemps(iPermutation(2,iEnsemb)) - B1=1.0d0/(BoltzK*T1) - B2=1.0d0/(BoltzK*T2) - -*------ Make the Metropolis thing. - BigDelta=(B2-B1)*(E2-E1) - Expe=exp(BigDelta) - Accept=.true. - If(Expe.lt.1.0D+0) then - Expran=ranf(iseed) - If(Expe.lt.Expran) Accept=.false. - Endif - - If(Accept) then -*-----Ct=C2 - iLuStIn=8+nStFilT(iPermutation(2,iEnsemb)) - iLuStUt=16+nStFilT(iPermutation(2,iEnsemb)) - Write(StFilIn(6:6),'(i1.1)')nStFilT(iPermutation(2,iEnsemb)) - Write(StFilUt(6:6),'(i1.1)')nStFilT(iPermutation(2,iEnsemb)) - Call Get8(R2,E2) - Do 221, i=1,3 - Do 222, j=1,nCent*nPart - CordstTEMP(j,i)=Cordst(j,i) -222 Continue -221 Continue -*-----C2=C1 - iLuStIn=8+nStFilT(iPermutation(1,iEnsemb)) - iLuStUt=16+nStFilT(iPermutation(1,iEnsemb)) - Write(StFilIn(6:6),'(i1.1)')nStFilT(iPermutation(1,iEnsemb)) - Write(StFilUt(6:6),'(i1.1)')nStFilT(iPermutation(1,iEnsemb)) - Call Get8(R1,E1) - iLuStIn=8+nStFilT(iPermutation(2,iEnsemb)) - iLuStUt=16+nStFilT(iPermutation(2,iEnsemb)) - Write(StFilIn(6:6),'(i1.1)')nStFilT(iPermutation(2,iEnsemb)) - Write(StFilUt(6:6),'(i1.1)')nStFilT(iPermutation(2,iEnsemb)) - Call Put8(R1,E1,Dum1,Dum1,Dum1) -*-----C1=Ct - Do 223, i=1,3 - Do 224, j=1,nCent*nPart - Cordst(j,i)=CordstTEMP(j,i) -224 Continue -223 Continue - iLuStIn=8+nStFilT(iPermutation(1,iEnsemb)) - iLuStUt=16+nStFilT(iPermutation(1,iEnsemb)) - Write(StFilIn(6:6),'(i1.1)')nStFilT(iPermutation(1,iEnsemb)) - Write(StFilUt(6:6),'(i1.1)')nStFilT(iPermutation(1,iEnsemb)) - Call Put8(R2,E2,Dum1,Dum1,Dum1) - Endif - - iEnsemb=iEnsemb+2 - If(Accept)Write(6,*)' accepted!' - If(.not.Accept)Write(6,*)' not accepted!' - If(iEnsemb.lt.nTemp) Go To 2001 - Write(6,*) - -* -*-- Do some stuff before exit. The reason we go back up is that this -* way we will collect the right coordinates from first startfile. -* Observe that iTemp has been reset hence we are back at the -* square one again. -* - Go To 999 - - Endif - - Return - End diff -Nru openmolcas-22.02/src/qmstat/pararoot.F90 openmolcas-22.10/src/qmstat/pararoot.F90 --- openmolcas-22.02/src/qmstat/pararoot.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/pararoot.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,225 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Anders Ohrn * +!*********************************************************************** +! ParaRoot +! +!> @brief +!> Manage the parallel tempering routine +!> @author A. Ohrn +!> +!> @details +!> If our system is difficult and has small transition elements +!> in the Markov chain, we can use the parallel tempering to +!> boost sampling. This routine is the root for this; it +!> mainly handles the various configurations for the different +!> temperature ensembles; also, manages the ensemble switch. +!> +!> @param[out] Ract +!> @param[out] BetaBol +!> @param[out] Etot +!> @param[in,out] CalledBefore +!> @param[out] SampleThis +!*********************************************************************** + +subroutine ParaRoot(Ract,BetaBol,Etot,CalledBefore,SampleThis) + +use qmstat_global, only: Cordst, iLuStIn, iLuStUt, iSeed, nCent, nPart, nStFilT, nTemp, ParaTemps, StFilIn, StFilUt +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Half, auTokJ, KBoltzmann +use Definitions, only: wp, iwp, u6 + +implicit none +real(kind=wp), intent(out) :: Ract, BetaBol, Etot +logical(kind=iwp), intent(inout) :: CalledBefore +logical(kind=iwp), intent(out) :: SampleThis +integer(kind=iwp) :: iEnsemb, iPa, iTemp = 0, mTemp +real(kind=wp) :: B1, B2, BigDelta, Dum, Dum1, E1, E2, Expe, Expran, PerType, R1, R2, T1, T2 +logical(kind=iwp) :: WeiterBitte, Accept +integer(kind=iwp), allocatable :: iPermutation(:,:) +real(kind=wp), allocatable :: CordstTEMP(:,:) +real(kind=wp), parameter :: BoltzK = 1.0e-3_wp*KBoltzmann/auTokJ +real(kind=wp), external :: Random_Molcas + +Dum1 = Zero + +! If this is first time to call on this routine. + +if (.not. CalledBefore) then + iTemp = 0 + CalledBefore = .true. +end if + +! See what to do. + +call mma_allocate(CordstTEMP,3,nCent*nPart,label='CordstTEMP') +call mma_allocate(iPermutation,2,nTemp,label='iPermutation') + +do + if (iTemp < nTemp) then + WeiterBitte = .true. + iTemp = iTemp+1 + write(u6,*) + write(u6,*) ' Run a new temperature ensemble...',iTemp + + ! A logical variable to make parallel tempering sampling correct. + if (iTemp == 1) then + SampleThis = .true. + else + SampleThis = .false. + end if + + else + WeiterBitte = .false. + iTemp = 0 + write(u6,*) + write(u6,*) ' Evaluate temperature ensemble interchanges.' + end if + + if (WeiterBitte) then + ! If we are to run a new ensemble. + + iLuStIn = 8+nStFilT(iTemp) + iLuStUt = 16+nStFilT(iTemp) + write(StFilIn(6:6),'(i1.1)') nStFilT(iTemp) + write(StFilUt(6:6),'(i1.1)') nStFilT(iTemp) + + ! Collect coordinates from proper startfile. + call Get8(Ract,Etot) + + ! Set temperature. + BetaBol = One/(ParaTemps(iTemp)*BoltzK) + exit + + else + ! If we are to attempt interchanges. + + do iPa=1,nTemp + iPermutation(:,iPa) = iPa + end do + + ! Construct permutations, treat nTemp == 2 as special case, the others + ! are obtained with general algorithm. + if (nTemp == 2) then + iPermutation(2,1) = 2 + iPermutation(2,2) = 1 + else + + PerType = Random_Molcas(iSeed) + if (PerType < Half) then + + if (mod(nTemp,2) == 1) then + mTemp = nTemp-1 + else + mTemp = nTemp + end if + + ! Construct permutation for odd iMac + do iPa=1,mTemp,2 + iPermutation(2,iPa) = iPermutation(1,iPa+1) + iPermutation(2,iPa+1) = iPermutation(1,iPa) + end do + + else + + mTemp = 2*((nTemp-1)/2) + ! Construct permutation for even iMac + do iPa=2,mTemp,2 + iPermutation(2,iPa) = iPermutation(1,iPa+1) + iPermutation(2,iPa+1) = iPermutation(1,iPa) + end do + end if + + end if + + ! Now attempt interchange. + + iEnsemb = 1 + do + if (iPermutation(1,iEnsemb) == iPermutation(2,iEnsemb)) then + iEnsemb = iEnsemb+1 + cycle + end if + + ! Collect energies for the permutations. + iLuStIn = 8+nStFilT(iPermutation(1,iEnsemb)) + iLuStUt = 16+nStFilT(iPermutation(1,iEnsemb)) + write(StFilIn(6:6),'(i1.1)') nStFilT(iPermutation(1,iEnsemb)) + write(StFilUt(6:6),'(i1.1)') nStFilT(iPermutation(1,iEnsemb)) + call Get8(Dum,E1) + iLuStIn = 8+nStFilT(iPermutation(2,iEnsemb)) + iLuStUt = 16+nStFilT(iPermutation(2,iEnsemb)) + write(StFilIn(6:6),'(i1.1)') nStFilT(iPermutation(2,iEnsemb)) + write(StFilUt(6:6),'(i1.1)') nStFilT(iPermutation(2,iEnsemb)) + call Get8(Dum,E2) + T1 = ParaTemps(iPermutation(1,iEnsemb)) + T2 = ParaTemps(iPermutation(2,iEnsemb)) + B1 = One/(BoltzK*T1) + B2 = One/(BoltzK*T2) + + ! Make the Metropolis thing. + BigDelta = (B2-B1)*(E2-E1) + Expe = exp(BigDelta) + Accept = .true. + if (Expe < One) then + Expran = Random_Molcas(iSeed) + if (Expe < Expran) Accept = .false. + end if + + if (Accept) then + ! Ct=C2 + iLuStIn = 8+nStFilT(iPermutation(2,iEnsemb)) + iLuStUt = 16+nStFilT(iPermutation(2,iEnsemb)) + write(StFilIn(6:6),'(i1.1)') nStFilT(iPermutation(2,iEnsemb)) + write(StFilUt(6:6),'(i1.1)') nStFilT(iPermutation(2,iEnsemb)) + call Get8(R2,E2) + CordstTEMP(:,:) = Cordst + ! C2=C1 + iLuStIn = 8+nStFilT(iPermutation(1,iEnsemb)) + iLuStUt = 16+nStFilT(iPermutation(1,iEnsemb)) + write(StFilIn(6:6),'(i1.1)') nStFilT(iPermutation(1,iEnsemb)) + write(StFilUt(6:6),'(i1.1)') nStFilT(iPermutation(1,iEnsemb)) + call Get8(R1,E1) + iLuStIn = 8+nStFilT(iPermutation(2,iEnsemb)) + iLuStUt = 16+nStFilT(iPermutation(2,iEnsemb)) + write(StFilIn(6:6),'(i1.1)') nStFilT(iPermutation(2,iEnsemb)) + write(StFilUt(6:6),'(i1.1)') nStFilT(iPermutation(2,iEnsemb)) + call Put8(R1,E1,Dum1,Dum1,Dum1) + ! C1=Ct + Cordst(:,:) = CordstTEMP + iLuStIn = 8+nStFilT(iPermutation(1,iEnsemb)) + iLuStUt = 16+nStFilT(iPermutation(1,iEnsemb)) + write(StFilIn(6:6),'(i1.1)') nStFilT(iPermutation(1,iEnsemb)) + write(StFilUt(6:6),'(i1.1)') nStFilT(iPermutation(1,iEnsemb)) + call Put8(R2,E2,Dum1,Dum1,Dum1) + end if + + iEnsemb = iEnsemb+2 + if (Accept) write(u6,*) ' accepted!' + if (.not. Accept) write(u6,*) ' not accepted!' + if (iEnsemb >= nTemp) exit + end do + write(u6,*) + + ! Do some stuff before exit. The reason we go back up is that this + ! way we will collect the right coordinates from first startfile. + ! Observe that iTemp has been reset hence we are back at the + ! square one again. + + end if +end do + +call mma_deallocate(CordstTEMP) +call mma_deallocate(iPermutation) + +return + +end subroutine ParaRoot diff -Nru openmolcas-22.02/src/qmstat/placeit9.F90 openmolcas-22.10/src/qmstat/placeit9.F90 --- openmolcas-22.02/src/qmstat/placeit9.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/placeit9.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,60 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +!----------------------------------------------------------------------* +! With this function we wish to place the QM-molecule properly when we * +! run with solvetn configurations from the sampfile. This we do by * +! making the center-of-masses to coincide. * +!----------------------------------------------------------------------* +subroutine PlaceIt9(Coord,Cordst,info_atom,iQ_Atoms) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iQ_Atoms, info_atom(iQ_Atoms) +real(kind=wp), intent(in) :: Coord(3,iQ_Atoms) +real(kind=wp), intent(out) :: Cordst(3,iQ_Atoms) +integer(kind=iwp) :: i +real(kind=wp) :: CMSamx, CMSamy, CMSamz, CMSewx, CMSewy, CMSewz, Tx, Ty, Tz, Wtot + +CMSewx = Zero +CMSewy = Zero +CMSewz = Zero +CMSamx = Zero +CMSamy = Zero +CMSamz = Zero +Wtot = Zero +do i=1,iQ_Atoms + CMSewx = CMSewx+Coord(1,i)*info_atom(i) + CMSewy = CMSewy+Coord(2,i)*info_atom(i) + CMSewz = CMSewz+Coord(3,i)*info_atom(i) + CMSamx = CMSamx+Cordst(1,i)*info_atom(i) + CMSamy = CMSamy+Cordst(2,i)*info_atom(i) + CMSamz = CMSamz+Cordst(3,i)*info_atom(i) + Wtot = Wtot+real(info_atom(i),kind=wp) +end do +CMSewx = CMSewx/Wtot +CMSewy = CMSewy/Wtot +CMSewz = CMSewz/Wtot +CMSamx = CMSamx/Wtot +CMSamy = CMSamy/Wtot +CMSamz = CMSamz/Wtot +Tx = CMSewx-CMSamx +Ty = CMSewy-CMSamy +Tz = CMSewz-CMSamz +Cordst(1,:) = Coord(1,:)-Tx +Cordst(2,:) = Coord(2,:)-Ty +Cordst(3,:) = Coord(3,:)-Tz + +return + +end subroutine PlaceIt9 diff -Nru openmolcas-22.02/src/qmstat/placeit.f openmolcas-22.10/src/qmstat/placeit.f --- openmolcas-22.02/src/qmstat/placeit.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/placeit.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,138 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine PlaceIt(Coord,iQ_Atoms,iCNum) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" - - Dimension Coord(MxAt*3) - Dimension AvstPart(MxPut),IndexSet(MxPut) - Dimension CordstTemp(MxPut*MxCen,3) - Character Head*200 - Logical Changed - - - Do 11, i=1,nPart !For each solvent particle, compute the - Sbig=1D+20 !smallest distance to any QM-atom from the - Do 12, j=1,iQ_Atoms !oxygen on water. - S=0 - Do 13, k=1,3 - S=S+(Coord((j-1)*3+k)-Cordst(nCent*(i-1)+1,k))**2 -13 Continue - If(S.le.Sbig) then - Sbig=S - AvstPart(i)=S - Endif -12 Continue -11 Continue - - Do 21, i=1,MxPut - IndexSet(i)=i -21 Continue - -31 Continue !Order the indeces suchwise that smallest distance - Changed=.false. !goes first. The sorting routine is blunt - Do 32, i=1,nPart-1 !but at this stage of the execution time - If(AvstPart(i+1).lt.AvstPart(i)) then !is not a problem. - Atemp=AvstPart(i) - AvstPart(i)=AvstPart(i+1) - AvstPart(i+1)=Atemp - iTemp=IndexSet(i) - IndexSet(i)=IndexSet(i+1) - IndexSet(i+1)=iTemp - Changed=.true. - Endif -32 Continue - If(Changed) GoTo 31 - - Do 41, i=1,nPart !Put coordinates of solvent suchwise that - Do 42, j=1,nCent !smallest distances goes first. - CordstTemp((i-1)*nCent+j,1)=Cordst((i-1)*nCent+j,1) - CordstTemp((i-1)*nCent+j,2)=Cordst((i-1)*nCent+j,2) - CordstTemp((i-1)*nCent+j,3)=Cordst((i-1)*nCent+j,3) -42 Continue -41 Continue - Do 43, i=1,nPart - ind=IndexSet(i) - Do 44, j=1,nCent - Cordst((i-1)*nCent+j,1)=CordstTemp((ind-1)*nCent+j,1) - Cordst((i-1)*nCent+j,2)=CordstTemp((ind-1)*nCent+j,2) - Cordst((i-1)*nCent+j,3)=CordstTemp((ind-1)*nCent+j,3) -44 Continue -43 Continue - - Do 51,iz=1,iQ_Atoms !Substitute the first coordinate slots with - Cordst(iz,1)=Coord((iz-1)*3+1) !QM-molecule, or since we have - Cordst(iz,2)=Coord((iz-1)*3+2) !ordered above, this is - Cordst(iz,3)=Coord((iz-1)*3+3) !equivalent with removing closest -51 Continue !solvents and there put QM-mol. - Do 52, iextr=iQ_Atoms+1,iCnum*nCent !Just dummy-coordinates - Cordst(iextr,1)=Coord(1) !added to empty slots. - Cordst(iextr,2)=Coord(2) - Cordst(iextr,3)=Coord(3) -52 Continue - - If(iPrint.ge.10) then !Optional printing. - Write(Head,*)'Coordinates of the system after substitution and' - &//' reordening of solvent molecules.' - Call Cooout(Head,Cordst,nPart,nCent) - Endif - - Return - End - -*----------------------------------------------------------------------* -* With this function we wish to place the QM-molecule properly when we * -* run with solvetn configurations from the sampfile. This we do by * -* making the center-of-masses to coincide. * -*----------------------------------------------------------------------* - Subroutine PlaceIt9(Coord,Cordst,info_atom,iQ_Atoms) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" - - Dimension Coord(MxAt*3),Cordst(MxCen*MxPut,3) - Dimension info_atom(MxAt) - - CMSewx=0 - CMSewy=0 - CMSewz=0 - CMSamx=0 - CMSamy=0 - CMSamz=0 - Wtot=0 - Do 1, i=1,iQ_Atoms - CMSewx=CMSewx+Coord((i-1)*3+1)*info_atom(i) - CMSewy=CMSewy+Coord((i-1)*3+2)*info_atom(i) - CMSewz=CMSewz+Coord((i-1)*3+3)*info_atom(i) - CMSamx=CMSamx+Cordst(i,1)*info_atom(i) - CMSamy=CMSamy+Cordst(i,2)*info_atom(i) - CMSamz=CMSamz+Cordst(i,3)*info_atom(i) - Wtot=Wtot+dble(info_atom(i)) -1 Continue - CMSewx=CMSewx/Wtot - CMSewy=CMSewy/Wtot - CMSewz=CMSewz/Wtot - CMSamx=CMSamx/Wtot - CMSamy=CMSamy/Wtot - CMSamz=CMSamz/Wtot - Tx=CMSewx-CMSamx - Ty=CMSewy-CMSamy - Tz=CMSewz-CMSamz - Do 2, i=1,iQ_Atoms - Cordst(i,1)=Coord((i-1)*3+1)-Tx - Cordst(i,2)=Coord((i-1)*3+2)-Ty - Cordst(i,3)=Coord((i-1)*3+3)-Tz -2 Continue - - Return - End diff -Nru openmolcas-22.02/src/qmstat/placeit.F90 openmolcas-22.10/src/qmstat/placeit.F90 --- openmolcas-22.02/src/qmstat/placeit.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/placeit.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,94 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine PlaceIt(Coord,iQ_Atoms,iCNum) + +use qmstat_global, only: Cordst, iPrint, nCent, nPart +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iQ_Atoms, iCNum +real(kind=wp), intent(in) :: Coord(3,iQ_Atoms) +integer(kind=iwp) :: i, ind, iTemp, j, k +real(kind=wp) :: Atemp, S, Sbig +logical(kind=iwp) :: Changed +character(len=200) :: Head +integer(kind=iwp), allocatable :: IndexSet(:) +real(kind=wp), allocatable :: AvstPart(:), CordstTemp(:,:) + +call mma_allocate(AvstPart,nPart,label='AvstPart') + +!For each solvent particle, compute the smallest distance to any QM-atom from the oxygen of water. +do i=1,nPart + k = (i-1)*nCent+1 + Sbig = 1.0e20_wp + do j=1,iQ_Atoms + S = (Coord(1,j)-Cordst(1,k))**2+(Coord(2,j)-Cordst(2,k))**2+(Coord(3,j)-Cordst(3,k))**2 + if (S <= Sbig) then + Sbig = S + AvstPart(i) = S + end if + end do +end do + +call mma_allocate(IndexSet,nPart,label='IndexSet') +do i=1,nPart + IndexSet(i) = i +end do + +do + ! Order the indices suchwise that smallest distance goes first. The sorting routine is blunt + ! but at this stage of the execution time is not a problem. + Changed = .false. + do i=1,nPart-1 + if (AvstPart(i+1) < AvstPart(i)) then + Atemp = AvstPart(i) + AvstPart(i) = AvstPart(i+1) + AvstPart(i+1) = Atemp + iTemp = IndexSet(i) + IndexSet(i) = IndexSet(i+1) + IndexSet(i+1) = iTemp + Changed = .true. + end if + end do + if (.not. Changed) exit +end do + +call mma_deallocate(AvstPart) + +! Put coordinates of solvent suchwise that smallest distances goes first. +call mma_allocate(CordstTemp,3,nPart*nCent,label='CordstTemp') +CordstTemp(:,:) = Cordst(:,1:nPart*nCent) +do i=1,nPart + k = (i-1)*nCent + ind = (IndexSet(i)-1)*nCent + Cordst(:,k+1:k+nCent) = CordstTemp(:,ind+1:ind+nCent) +end do +call mma_deallocate(IndexSet) +call mma_deallocate(CordstTemp) + +! Substitute the first coordinate slots with QM-molecule, or since we have +! ordered above, this is equivalent with removing closest solvents and there put QM-mol. +Cordst(:,1:iQ_Atoms) = Coord +! Just dummy-coordinates added to empty slots. +Cordst(1,iQ_Atoms+1:iCnum*nCent) = Coord(1,1) +Cordst(2,iQ_Atoms+1:iCnum*nCent) = Coord(2,1) +Cordst(3,iQ_Atoms+1:iCnum*nCent) = Coord(3,1) + +if (iPrint >= 10) then !Optional printing. + write(Head,*) 'Coordinates of the system after substitution and reordering of solvent molecules.' + call Cooout(Head,Cordst,nPart,nCent) +end if + +return + +end subroutine PlaceIt diff -Nru openmolcas-22.02/src/qmstat/planevectors.F90 openmolcas-22.10/src/qmstat/planevectors.F90 --- openmolcas-22.02/src/qmstat/planevectors.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/planevectors.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,50 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! Routine to give base vectors of the plane with v as normal. +subroutine PlaneVectors(u,w,v,Rinv) + +use Constants, only: Zero, One, Half +use Definitions, only: wp + +implicit none +real(kind=wp), intent(out) :: u(3), w(3) +real(kind=wp), intent(in) :: v(3), Rinv +real(kind=wp) :: const, dLu, p(3), Scal, Shitx, Shity, Shitz + +! Construct an arbitrary normalized vector orthogonal to the v-vector. + +const = Zero +Shitx = One +Shity = Zero +Shitz = Zero +do + p(1) = Shitx+const + p(2) = Shity+Half*const + p(3) = Shitz-const + Scal = p(1)*v(1)+p(2)*v(2)+p(3)*v(3) + u(:) = p-Scal*Rinv**2*v + if ((abs(u(1)) >= 1.0e-6_wp) .or. (abs(u(2)) >= 1.0e-6_wp) .or. (abs(u(3)) >= 1.0-6_wp)) exit + const = const+One +end do +dLu = sqrt(u(1)**2+u(2)**2+u(3)**2) +u(:) = u/dLu + +! Construct the final pi-vector, which is orthogonal to the v-vector +! and the recently constructed pi-vector. + +w(1) = Rinv*(u(2)*v(3)-u(3)*v(2)) +w(2) = Rinv*(u(3)*v(1)-u(1)*v(3)) +w(3) = Rinv*(u(1)*v(2)-u(2)*v(1)) + +return + +end subroutine PlaneVectors diff -Nru openmolcas-22.02/src/qmstat/polink.f openmolcas-22.10/src/qmstat/polink.f --- openmolcas-22.02/src/qmstat/polink.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/polink.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,268 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Anders Ohrn * -************************************************************************ -* Polink -* -*> @brief -*> Add the field from the QM-region onto the solvent. Include the field from the -*> polarizabilities in the solvent onto the QM-region. -*> (The effect of the static field is taken care of in hel.f) -*> @author A. Ohrn -*> -*> @details -*> To begin with we obtain the charge distribution of the QM-region -*> as it exists due to the pressent density matrix (recall that it -*> is the changes in the density matrix that causes the QM-region to -*> be polarized). The field from these new multipoles are added on to -*> solvent. We also include the reaction field from the QM-region. -*> Then, with the new field from the QM-region included, we compute -*> the field from the polarizabiolities in the solvent onto the QM-region, -*> which is done just like in hel.f. -*> -*> @param[out] Energy The energy of the electrostatic interaction -*> @param[in,out] iCall An integer that tells if this is the first call in the iteration. Necessary for the copy of the one-particle Hamiltonian -*> @param[in] iAtom2 Number of particles in the solvent, times number of polarizabilities per solvent molecule -*> @param[in] iCi Number of centers in QM-molecule -*> @param[in] iFil Pointer to the static field from the solvent -*> @param[out] VpolMat The matrix due to polarization -*> @param[in,out] fil The field from the induced dipoles in the solvent -*> @param[in] polfac A factor for the computation of the image -*> @param[out] poli The solvent polarized field on QM-region -*> @param[in] iCstart Number to keep track of solvent molecules -*> @param[in] iTri ``iOrb(1)*(iOrb(1)+1)/2`` -************************************************************************ - Subroutine Polink(Energy,iCall,iAtom2,iCi,iFil,VpolMat,fil,polfac - &,poli,iCstart,iTri,iQ_Atoms,qTot,ChaNuc,xyzMyQ,xyzMyI,xyzMyP - &,RoMat,xyzQuQ,CT) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "qm1.fh" -#include "WrkSpc.fh" - - Dimension Fil(npart*npol,3),Qm(MxQCen),Dm(MxQCen,3),QQm(MxQCen,6) - &,Poli(MxQCen,10),Gunnar(10),Eil(MxPut*MxPol,3),xyzMyC(3),CofC(3) - &,VpolMat(MxOt),ChaNuc(MxAt),xyzMyQ(3),xyzMyI(3),xyzMyP(3) - &,RoMat(MxOT) - Dimension xyzQuQ(6),qQ(6),qD(6),qK(6),CT(3) - Dimension iFil(MxQCen,10) - -*----------------------------------------------------------------------* -* Begin with some zeros. * -*----------------------------------------------------------------------* - iCnum=iCStart/Ncent - Do 2, i=1,iCi - Qm(i)=0.0d0 - If(i.le.iQ_Atoms) Qm(i)=-ChaNuc(i) !Here is nuclear contribution - Do 3, j=1,3 !added to atoms. - Dm(i,j)=0.0d0 - QQm(i,j)=0.0d0 - QQm(i,j+3)=0.0d0 -3 Continue -2 Continue - Do 6644, i=1,MxPut*MxPol - Do 6645, j=1,3 - Eil(i,j)=0.0d0 -6645 Continue -6644 Continue -*----------------------------------------------------------------------* -* Below we compute how the MME of the QM-molecule changes with the new * -* density matrix Romat. What we actually do is a HF-SCF procedure with * -* a MME-expanded density. A change in the density has the effect that * -* the set of multipoles in the MME are slightly perturbed. * -*----------------------------------------------------------------------* - Do 4, i=1,iTri - Do 41, j=1,iCi - Qm(j)=Cha(i,j)*Romat(i)+Qm(j) - Dm(j,1)=Dm(j,1)+DipMy(i,1,j)*Romat(i) - Dm(j,2)=Dm(j,2)+DipMy(i,2,j)*Romat(i) - Dm(j,3)=Dm(j,3)+DipMy(i,3,j)*Romat(i) - QQm(j,1)=QQm(j,1)+Quad(i,1,j)*Romat(i) - QQm(j,3)=QQm(j,3)+Quad(i,3,j)*Romat(i) - QQm(j,6)=QQm(j,6)+Quad(i,6,j)*Romat(i) - QQm(j,2)=QQm(j,2)+Quad(i,2,j)*Romat(i) - QQm(j,4)=QQm(j,4)+Quad(i,4,j)*Romat(i) - QQm(j,5)=QQm(j,5)+Quad(i,5,j)*Romat(i) -41 Continue -4 Continue - Do 775, kk=1,3 - xyzMyQ(kk)=0 - xyzMyC(kk)=0 - CofC(kk)=0 -775 Continue - Do 776, kk=1,6 - xyzQuQ(kk)=0 - qQ(kk)=0 - qD(kk)=0 - qK(kk)=0 -776 Continue - !Observe one trixy thing about xyzmyq: the electric multipoles - !we use above are actually of opposite sign, so how can xyzmyq be - !the dipole in the qm-region unless we change sign (which we does - !not)? The reason is that the density matrix elements will also - !have opposite sign, which in turn has not physical meaning. - !We also compute the quadupole moment - a mezzy formula. - Do 866,i=1,iCi - xyzMyQ(1)=xyzMyQ(1)+Dm(i,1)+Qm(i)*outxyz(i,1) - xyzMyQ(2)=xyzMyQ(2)+Dm(i,2)+Qm(i)*outxyz(i,2) - xyzMyQ(3)=xyzMyQ(3)+Dm(i,3)+Qm(i)*outxyz(i,3) - qQ(1)=qQ(1)+Qm(i)*(outxyz(i,1)-CT(1))*(outxyz(i,1)-CT(1)) - qQ(2)=qQ(2)+Qm(i)*(outxyz(i,1)-CT(1))*(outxyz(i,2)-CT(2)) - qQ(3)=qQ(3)+Qm(i)*(outxyz(i,1)-CT(1))*(outxyz(i,3)-CT(3)) - qQ(4)=qQ(4)+Qm(i)*(outxyz(i,2)-CT(2))*(outxyz(i,2)-CT(2)) - qQ(5)=qQ(5)+Qm(i)*(outxyz(i,2)-CT(2))*(outxyz(i,3)-CT(3)) - qQ(6)=qQ(6)+Qm(i)*(outxyz(i,3)-CT(3))*(outxyz(i,3)-CT(3)) - qD(1)=qD(1)+2*Dm(i,1)*(outxyz(i,1)-CT(1)) - qD(2)=qD(2)+Dm(i,1)*(outxyz(i,2)-CT(2)) - & +Dm(i,2)*(outxyz(i,1)-CT(1)) - qD(3)=qD(3)+Dm(i,1)*(outxyz(i,3)-CT(3)) - & +Dm(i,3)*(outxyz(i,1)-CT(1)) - qD(4)=qD(4)+2*Dm(i,2)*(outxyz(i,2)-CT(2)) - qD(5)=qD(5)+Dm(i,2)*(outxyz(i,3)-CT(3)) - & +Dm(i,3)*(outxyz(i,2)-CT(2)) - qD(6)=qD(6)+2*Dm(i,3)*(outxyz(i,3)-CT(3)) - qK(1)=qK(1)+QQm(i,1) - qK(2)=qK(2)+QQm(i,2) - qK(3)=qK(3)+QQm(i,4) - qK(4)=qK(4)+QQm(i,3) - qK(5)=qK(5)+QQm(i,5) - qK(6)=qK(6)+QQm(i,6) -866 Continue - Trace1=qQ(1)+qQ(4)+qQ(6) - Trace2=qD(1)+qD(4)+qD(6) - Trace1=Trace1/3 - Trace2=Trace2/3 - xyzQuQ(1)=1.5*(qQ(1)+qD(1)-Trace1-Trace2)+qK(1) - xyzQuQ(2)=1.5*(qQ(2)+qD(2))+qK(2) - xyzQuQ(3)=1.5*(qQ(3)+qD(3))+qK(3) - xyzQuQ(4)=1.5*(qQ(4)+qD(4)-Trace1-Trace2)+qK(4) - xyzQuQ(5)=1.5*(qQ(5)+qD(5))+qK(5) - xyzQuQ(6)=1.5*(qQ(6)+qD(6)-Trace1-Trace2)+qK(6) - If(ChargedQM) then !If charged system, then do... - qs=0 - Do 721, i=1,iCi - CofC(1)=CofC(1)+abs(qm(i))*outxyz(i,1) !Center of charge - CofC(2)=CofC(2)+abs(qm(i))*outxyz(i,2) - CofC(3)=CofC(3)+abs(qm(i))*outxyz(i,3) - qs=qs+abs(qm(i)) -721 Continue - CofC(1)=CofC(1)/qs - CofC(2)=CofC(2)/qs - CofC(3)=CofC(3)/qs - Gx=CofC(1)-outxyz(1,1)+Cordst(1,1) !Where C-of-C is globally - Gy=CofC(2)-outxyz(1,2)+Cordst(1,2) - Gz=CofC(3)-outxyz(1,3)+Cordst(1,3) - xyzMyC(1)=xyzMyC(1)+qtot*Gx !Dipole - xyzMyC(2)=xyzMyC(2)+qtot*Gy - xyzMyC(3)=xyzMyC(3)+qtot*Gz - Endif - Do 9977, i=1,3 - !Change sign on both the dipoles, which in effect gives - !no sign change, all in order with Boettcher, p.145. - Energy=Energy+Polfac*xyzMyQ(i)*(xyzMyQ(i)+xyzMyi(i)) -9977 Continue -*----------------------------------------------------------------------* -* The multipoles of the QM-region, modified due to the polarization, * -* now interacts with each polarizability in the solvent. * -*----------------------------------------------------------------------* - Do 5, i=1,iCi - Do 6, j=1+(nPol*iCnum),iAtom2 - Do 7, k=1,3 - Eil(j,k)=Eil(j,k)+Work(iFil(i,1)-1+j+(k-1)*nPart*nPol)*Qm(i) - Do 8, l=1,3 - Eil(j,k)=Eil(j,k)+Work(iFil(i,l+1)-1+j+(k-1)*nPart*nPol) - & *Dm(i,l) -8 Continue - Eil(j,k)=Eil(j,k)+Work(iFil(i,5)-1+j+(k-1)*nPart*nPol)*QQm(i,1) - Eil(j,k)=Eil(j,k)+Work(iFil(i,7)-1+j+(k-1)*nPart*nPol)*QQm(i,3) - Eil(j,k)=Eil(j,k)+Work(iFil(i,10)-1+j+(k-1)*nPart*nPol)*QQm(i,6) - Eil(j,k)=Eil(j,k)+Work(iFil(i,6)-1+j+(k-1)*nPart*nPol)*QQm(i,2)*2 - Eil(j,k)=Eil(j,k)+Work(iFil(i,8)-1+j+(k-1)*nPart*nPol)*QQm(i,4)*2 - Eil(j,k)=Eil(j,k)+Work(iFil(i,9)-1+j+(k-1)*nPart*nPol)*QQm(i,5)*2 -7 Continue -6 Continue -5 Continue -C...THIS IS LEBENSGEFAHRLICH (original comment says it all!) -*----------------------------------------------------------------------* -* We add up the field from the QM-region to the field on all the * -* solvent polarizabilities. * -*----------------------------------------------------------------------* - Do 10, i=1+(nPol*iCNum),iAtom2 - Iu=i-((i-1)/nPol)*nPol - Do 11, j=1,3 !Here we add the QM-molecule image to the solvent - !polarizabilities. Good old classical dielectric - !cavity model! - Fil(i,j)=Fil(i,j)+PolFac*xyzMyQ(j)+Eil(i,j) - Energy=Energy+Fil(i,j)*Eil(i,j)*Pol(iu) !How much the induced - !dipoles in solvent interacts with the field - !from the QM-region. -11 Continue -10 Continue -*----------------------------------------------------------------------* -* Now we wish to make the induced field from the solvent interact with * -* the QM-region. The static field has already interacted in helstate.f.* -* The reaction field of the QM-region in the dielectric cavity is * -* also included, excluding the quadrupoles and higher; they are * -* small anyway, so this is not a major restriction. * -*----------------------------------------------------------------------* - Do 1801, i=1,10 - Gunnar(i)=0 -1801 Continue - Gunnar(2)=PolFac*(xyzMyP(1)+xyzMyQ(1)+xyzMyI(1)+xyzMyC(1)) - Gunnar(3)=PolFac*(xyzMyP(2)+xyzMyQ(2)+xyzMyI(2)+xyzMyC(2)) - Gunnar(4)=PolFac*(xyzMyP(3)+xyzMyQ(3)+xyzMyI(3)+xyzMyC(3)) - Do 1304, l=1,iCi - Gunnar(1)=Gunnar(2)*outxyz(l,1)+Gunnar(3)*outxyz(l,2) - & +Gunnar(4)*outxyz(l,3) !Potential from the apparent - Do 1305, i=1,10 !surface charge, see Boettcher (4.22). - Poli(l,i)=Gunnar(i) - Do 1306, j=1+(nPol*iCnum),iAtom2 - Iu=j-((j-1)/nPol)*nPol - Do 1307, k=1,3 !Compute the generalized field - !from induced dipoles in solvent on the - !QM-region cites. - Poli(l,i)=Poli(l,i)-Fil(j,k)*Pol(iu) - & *Work(iFil(l,i)-1+j+(k-1)*nPart*nPol) -1307 Continue -1306 Continue -1305 Continue -1304 Continue - Do 201, i=1,iTri - VpolMat(i)=0 -201 Continue - Do 300, i=1,iTri - Do 301, j=1,iCi - Vpolmat(i)=Vpolmat(i)+Poli(j,1)*Cha(i,j) - Vpolmat(i)=Vpolmat(i)+Poli(j,2)*DipMy(i,1,j) - Vpolmat(i)=Vpolmat(i)+Poli(j,3)*DipMy(i,2,j) - Vpolmat(i)=Vpolmat(i)+Poli(j,4)*DipMy(i,3,j) - Vpolmat(i)=Vpolmat(i)+Poli(j,5)*Quad(i,1,j) - Vpolmat(i)=Vpolmat(i)+Poli(j,7)*Quad(i,3,j) - Vpolmat(i)=Vpolmat(i)+Poli(j,10)*Quad(i,6,j) - Vpolmat(i)=Vpolmat(i)+Poli(j,6)*Quad(i,2,j)*2 - Vpolmat(i)=Vpolmat(i)+Poli(j,8)*Quad(i,4,j)*2 - Vpolmat(i)=Vpolmat(i)+Poli(j,9)*Quad(i,5,j)*2 -301 Continue -300 Continue - Do 400, i=1,iQ_Atoms !This is how the nuclei interact with the - !induced field (in equil2 exists a corresponding - !term for the interaction with the static field). - !This way interaction between a charged molecule - !and the induced/permanent potential is included. - Energy=Energy-2*Poli(i,1)*ChaNuc(i) -400 Continue - - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(iCall) - End diff -Nru openmolcas-22.02/src/qmstat/polink.F90 openmolcas-22.10/src/qmstat/polink.F90 --- openmolcas-22.02/src/qmstat/polink.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/polink.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,227 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Anders Ohrn * +!*********************************************************************** +! Polink +! +!> @brief +!> Add the field from the QM-region onto the solvent. Include the field from the +!> polarizabilities in the solvent onto the QM-region. +!> (The effect of the static field is taken care of in hel) +!> @author A. Ohrn +!> +!> @details +!> To begin with we obtain the charge distribution of the QM-region +!> as it exists due to the pressent density matrix (recall that it +!> is the changes in the density matrix that causes the QM-region to +!> be polarized). The field from these new multipoles are added on to +!> solvent. We also include the reaction field from the QM-region. +!> Then, with the new field from the QM-region included, we compute +!> the field from the polarizabiolities in the solvent onto the QM-region, +!> which is done just like in ::hel. +!> +!> @param[in,out] Energy The energy of the electrostatic interaction +!> @param[in] iAtom2 Number of particles in the solvent, times number of polarizabilities per solvent molecule +!> @param[in] iCi Number of centers in QM-molecule +!> @param[in] Fil The static field from the solvent +!> @param[out] VpolMat The matrix due to polarization +!> @param[in,out] FFp The field from the induced dipoles in the solvent +!> @param[in] polfac A factor for the computation of the image +!> @param[out] poli The solvent polarized field on QM-region +!> @param[in] iCstart Number to keep track of solvent molecules +!> @param[in] iTri ``iOrb(1)*(iOrb(1)+1)/2`` +!> @param[in] iQ_Atoms +!> @param[in] qTot +!> @param[in] ChaNuc +!> @param[out] xyzMyQ +!> @param[in] xyzMyI +!> @param[in] xyzMyP +!> @param[in] RoMat +!> @param[out] xyzQuQ +!> @param[in] CT +!*********************************************************************** + +subroutine Polink(Energy,iAtom2,iCi,Fil,VpolMat,FFp,polfac,poli,iCstart,iTri,iQ_Atoms,qTot,ChaNuc,xyzMyQ,xyzMyI,xyzMyP,RoMat, & + xyzQuQ,CT) + +use qmstat_global, only: Cha, ChargedQM, Cordst, DipMy, nCent, nPart, nPol, outxyz, Pol, Quad +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, Two, Half, OneHalf +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iAtom2, iCi, iCstart, iTri, iQ_Atoms +real(kind=wp), intent(inout) :: Energy, FFp(nPart*nPol,3) +real(kind=wp), intent(out) :: VpolMat(iTri), Poli(iCi,10), xyzMyQ(3), xyzQuQ(6) +real(kind=wp), intent(in) :: Fil(nPart*nPol,3,iCi,10), polfac, qTot, ChaNuc(iQ_Atoms), xyzMyI(3), xyzMyP(3), RoMat(iTri), CT(3) +integer(kind=iwp) :: i, iCnum, Iu, j, l +real(kind=wp) :: CofC(3), Gunnar(10), G(3), qD(6), qK(6), qQ(6), qs, Trace1, Trace2, xyzMyC(3) +real(kind=wp), allocatable :: Dm(:,:), Eil(:,:), Qm(:), QQm(:,:) + +!----------------------------------------------------------------------* +! Begin with some zeros. * +!----------------------------------------------------------------------* +call mma_allocate(Qm,iCi,label='Qm') +call mma_allocate(Dm,iCi,3,label='Dm') +call mma_allocate(QQm,iCi,6,label='QQm') +call mma_allocate(Eil,iAtom2,3,label='Eil') +iCnum = iCStart/nCent +Qm(1:iQ_Atoms) = -ChaNuc !Here is nuclear contribution added to atoms. +Qm(iQ_Atoms+1:) = Zero +Dm(:,:) = Zero +QQm(:,:) = Zero +Eil(:,:) = Zero +!----------------------------------------------------------------------* +! Below we compute how the MME of the QM-molecule changes with the new * +! density matrix Romat. What we actually do is a HF-SCF procedure with * +! a MME-expanded density. A change in the density has the effect that * +! the set of multipoles in the MME are slightly perturbed. * +!----------------------------------------------------------------------* +do i=1,iTri + Qm(:) = Cha(i,:)*Romat(i)+Qm(:) + Dm(:,1) = Dm(:,1)+DipMy(i,1,:)*Romat(i) + Dm(:,2) = Dm(:,2)+DipMy(i,2,:)*Romat(i) + Dm(:,3) = Dm(:,3)+DipMy(i,3,:)*Romat(i) + QQm(:,1) = QQm(:,1)+Quad(i,1,:)*Romat(i) + QQm(:,3) = QQm(:,3)+Quad(i,3,:)*Romat(i) + QQm(:,6) = QQm(:,6)+Quad(i,6,:)*Romat(i) + QQm(:,2) = QQm(:,2)+Quad(i,2,:)*Romat(i) + QQm(:,4) = QQm(:,4)+Quad(i,4,:)*Romat(i) + QQm(:,5) = QQm(:,5)+Quad(i,5,:)*Romat(i) +end do +xyzMyQ(:) = Zero +xyzMyC(:) = Zero +xyzQuQ(:) = Zero +CofC(:) = Zero +qQ(:) = Zero +qD(:) = Zero +qK(:) = Zero +! Observe one tricky thing about xyzmyq: the electric multipoles +! we use above are actually of opposite sign, so how can xyzmyq be +! the dipole in the qm-region unless we change sign (which we do +! not)? The reason is that the density matrix elements will also +! have opposite sign, which in turn has no physical meaning. +! We also compute the quadupole moment -- a messy formula. +do i=1,iCi + xyzMyQ(:) = xyzMyQ(:)+Dm(i,:)+Qm(i)*outxyz(:,i) + qQ(1) = qQ(1)+Qm(i)*(outxyz(1,i)-CT(1))*(outxyz(1,i)-CT(1)) + qQ(2) = qQ(2)+Qm(i)*(outxyz(1,i)-CT(1))*(outxyz(2,i)-CT(2)) + qQ(3) = qQ(3)+Qm(i)*(outxyz(1,i)-CT(1))*(outxyz(3,i)-CT(3)) + qQ(4) = qQ(4)+Qm(i)*(outxyz(2,i)-CT(2))*(outxyz(2,i)-CT(2)) + qQ(5) = qQ(5)+Qm(i)*(outxyz(2,i)-CT(2))*(outxyz(3,i)-CT(3)) + qQ(6) = qQ(6)+Qm(i)*(outxyz(3,i)-CT(3))*(outxyz(3,i)-CT(3)) + qD(1) = qD(1)+Two*Dm(i,1)*(outxyz(1,i)-CT(1)) + qD(2) = qD(2)+Dm(i,1)*(outxyz(2,i)-CT(2))+Dm(i,2)*(outxyz(1,i)-CT(1)) + qD(3) = qD(3)+Dm(i,1)*(outxyz(3,i)-CT(3))+Dm(i,3)*(outxyz(1,i)-CT(1)) + qD(4) = qD(4)+Two*Dm(i,2)*(outxyz(2,i)-CT(2)) + qD(5) = qD(5)+Dm(i,2)*(outxyz(3,i)-CT(3))+Dm(i,3)*(outxyz(2,i)-CT(2)) + qD(6) = qD(6)+Two*Dm(i,3)*(outxyz(3,i)-CT(3)) + qK(1) = qK(1)+QQm(i,1) + qK(2) = qK(2)+QQm(i,2) + qK(3) = qK(3)+QQm(i,4) + qK(4) = qK(4)+QQm(i,3) + qK(5) = qK(5)+QQm(i,5) + qK(6) = qK(6)+QQm(i,6) +end do +Trace1 = qQ(1)+qQ(4)+qQ(6) +Trace2 = qD(1)+qD(4)+qD(6) +Trace1 = Trace1 +Trace2 = Trace2 +xyzQuQ(:) = OneHalf*(qQ+qD)+qK +xyzQuQ(1) = xyzQuQ(1)-Half*(Trace1+Trace2) +xyzQuQ(4) = xyzQuQ(4)-Half*(Trace1+Trace2) +xyzQuQ(6) = xyzQuQ(6)-Half*(Trace1+Trace2) +if (ChargedQM) then !If charged system, then do... + qs = Zero + do i=1,iCi + CofC(:) = CofC+abs(Qm(i))*outxyz(:,i) !Center of charge + qs = qs+abs(Qm(i)) + end do + CofC(:) = CofC/qs + G(:) = CofC-outxyz(:,1)+Cordst(:,1) !Where C-of-C is globally + xyzMyC(:) = xyzMyC+qtot*G !Dipole +end if +do i=1,3 + ! Change sign on both the dipoles, which in effect gives + ! no sign change, all in order with Boettcher, p.145. + Energy = Energy+Polfac*xyzMyQ(i)*(xyzMyQ(i)+xyzMyi(i)) +end do +!----------------------------------------------------------------------* +! The multipoles of the QM-region, modified due to the polarization, * +! now interacts with each polarizability in the solvent. * +!----------------------------------------------------------------------* +do i=1,iCi + do j=1+(nPol*iCnum),iAtom2 + Eil(j,:) = Eil(j,:)+Fil(j,:,i,1)*Qm(i)+ & + Fil(j,:,i,2)*Dm(i,1)+Fil(j,:,i,3)*Dm(i,2)+Fil(j,:,i,4)*Dm(i,3)+ & + Fil(j,:,i,5)*QQm(i,1)+Fil(j,:,i,7)*QQm(i,3)+Fil(j,:,i,10)*QQm(i,6)+ & + Fil(j,:,i,6)*QQm(i,2)*Two+Fil(j,:,i,8)*QQm(i,4)*Two+Fil(j,:,i,9)*QQm(i,5)*Two + end do +end do +! THIS IS LEBENSGEFAHRLICH (original comment says it all!) +!----------------------------------------------------------------------* +! We add up the field from the QM-region to the field on all the * +! solvent polarizabilities. * +!----------------------------------------------------------------------* +do i=1+(nPol*iCNum),iAtom2 + Iu = i-((i-1)/nPol)*nPol + ! Here we add the QM-molecule image to the solvent polarizabilities. + ! Good old classical dielectric cavity model! + do j=1,3 + FFp(i,j) = FFp(i,j)+PolFac*xyzMyQ(j)+Eil(i,j) + ! How much the induced dipoles in solvent interacts with the field from the QM-region. + Energy = Energy+FFp(i,j)*Eil(i,j)*Pol(iu) + end do +end do +call mma_deallocate(Qm) +call mma_deallocate(Dm) +call mma_deallocate(QQm) +call mma_deallocate(Eil) +!----------------------------------------------------------------------* +! Now we wish to make the induced field from the solvent interact with * +! the QM-region. The static field has already interacted in helstate. * +! The reaction field of the QM-region in the dielectric cavity is * +! also included, excluding the quadrupoles and higher; they are * +! small anyway, so this is not a major restriction. * +!----------------------------------------------------------------------* +Gunnar(:) = Zero +Gunnar(2:4) = PolFac*(xyzMyP+xyzMyQ+xyzMyI+xyzMyC) +do l=1,iCi + ! Potential from the apparent surface charge, see Boettcher (4.22). + Gunnar(1) = Gunnar(2)*outxyz(1,l)+Gunnar(3)*outxyz(2,l)+Gunnar(4)*outxyz(3,l) + do i=1,10 + Poli(l,i) = Gunnar(i) + do j=1+(nPol*iCnum),iAtom2 + Iu = j-((j-1)/nPol)*nPol + ! Compute the generalized field from induced dipoles in solvent on the QM-region cites. + Poli(l,i) = Poli(l,i)-FFp(j,1)*Pol(iu)*Fil(j,1,l,i)-FFp(j,2)*Pol(iu)*Fil(j,2,l,i)-FFp(j,3)*Pol(iu)*Fil(j,3,l,i) + end do + end do +end do +VpolMat(:) = Zero +do i=1,iTri + do j=1,iCi + Vpolmat(i) = Vpolmat(i)+Poli(j,1)*Cha(i,j)+ & + Poli(j,2)*DipMy(i,1,j)+Poli(j,3)*DipMy(i,2,j)+Poli(j,4)*DipMy(i,3,j)+ & + Poli(j,5)*Quad(i,1,j)+Poli(j,7)*Quad(i,3,j)+Poli(j,10)*Quad(i,6,j)+ & + Poli(j,6)*Quad(i,2,j)*Two+Poli(j,8)*Quad(i,4,j)*Two+Poli(j,9)*Quad(i,5,j)*Two + end do +end do +! This is how the nuclei interact with the induced field (in equil2 exists a corresponding +! term for the interaction with the static field). +! This way interaction between a charged molecule and the induced/permanent potential is included. +do i=1,iQ_Atoms + Energy = Energy-2*Poli(i,1)*ChaNuc(i) +end do + +return + +end subroutine Polink diff -Nru openmolcas-22.02/src/qmstat/polins.f openmolcas-22.10/src/qmstat/polins.f --- openmolcas-22.02/src/qmstat/polins.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/polins.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,280 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Anders Ohrn * -************************************************************************ -* Polins -* -*> @brief -*> Add the field from the QM-region onto the solvent. -*> Include the field from the polarizabilities in the solvent onto the QM-region. -*> (The effect of the static field is taken care of in helstate.f) -*> @author A. Ohrn -*> -*> @details -*> First we compute the field from the QM-region onto the solvent. The -*> central quantity is the density matrix, which gives us how the -*> QM-region polarizes. The reaction field due to the QM-region is also -*> accounted for. Then we allow the polarized field from the solvent -*> to interact with the QM-region. The static field from the solvent, -*> in other word that from the charges, is already coupled in -*> ::helstate. -*> -*> @param[out] Energy The energy of the electrostatic interaction -*> @param[in,out] iCall An integer that tells if this is the first call in the iteration. -*> Necessary for the copy of the one-particle Hamiltonian -*> @param[in] iAtom2 Number of particles in the solvent, times number of polarizabilities per solvent molecule -*> @param[in] iCi Number of centers in QM-molecule -*> @param[in] iFil Pointer to the static field from the solvent -*> @param[out] VpolMat The polarization matrix -*> @param[in,out] fil The field from the induced dipoles in the solvent -*> @param[in] polfac A factor for the computation of the image -*> @param[out] poli The solvent polarized field on QM -*> @param[in] xyzmyq Total dipole of QM-region -*> @param[in] xyzmyi Total induced dipole of solvent -*> @param[in] xyzmyp Total permanent dipole of solvent -*> @param[in] qtot Total charge of QM-region -*> @param[in] iCstart Number to keep track of solvent molecules -************************************************************************ - Subroutine Polins(Energy,iCall,iAtom2,iCi,iFil,VpolMat,fil,polfac - & ,poli,xyzmyq,xyzmyi,xyzmyp,iCstart,iQ_Atoms,qtot,ChaNuc - & ,RoMatSt,xyzQuQ,CT) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "qm2.fh" -#include "WrkSpc.fh" - - Dimension Fil(npart*npol,3),Qm(MxQCen),Dm(MxQCen,3),QQm(MxQCen,6) - &,Poli(MxQCen,10),Gunnar(10),ChaNuc(MxAt) - &,Eil(MxPut*MxPol,3),xyzMyC(3),CofC(3),xyzmyq(3),xyzmyi(3) - &,xyzmyp(3),VpolMat(MxStOt),RoMatSt(MxStOT) - Dimension xyzQuQ(6),qQ(6),qD(6),qK(6),CT(3) - Dimension iFil(MxQCen,10) - -*----------------------------------------------------------------------* -* Begin with some zeros. * -*----------------------------------------------------------------------* - iCnum=iCStart/Ncent - Do 2, i=1,iCi - Qm(i)=0 - If(i.le.iQ_Atoms) Qm(i)=-ChaNuc(i) - Do 3, j=1,3 - Dm(i,j)=0 - QQm(i,j)=0 - QQm(i,j+3)=0 -3 Continue -2 Continue - Do 6644, i=1,MxPut*MxPol - Do 6645, j=1,3 - Eil(i,j)=0 -6645 Continue -6644 Continue -*----------------------------------------------------------------------* -* Below we compute how the MME of the QM-molecule changes with the new * -* density matrix Romat. In this step we connect a state density with * -* various multipoles, which will go on and interact with the solvent. * -* This is one of the pivotal steps in coupling the QM-region with the * -* classical region. * -*----------------------------------------------------------------------* - kaunt=0 - Do 14, i=1,nState - Do 15, j=1,i - kaunt=kaunt+1 - Do 41, k=1,iCi - Qm(k)=Qm(k)+RasCha(kaunt,k)*RomatSt(kaunt) - Dm(k,1)=Dm(k,1)+RasDip(kaunt,1,k)*RomatSt(kaunt) - Dm(k,2)=Dm(k,2)+RasDip(kaunt,2,k)*RomatSt(kaunt) - Dm(k,3)=Dm(k,3)+RasDip(kaunt,3,k)*RomatSt(kaunt) - QQm(k,1)=QQm(k,1)+RasQua(kaunt,1,k)*RomatSt(kaunt) - QQm(k,3)=QQm(k,3)+RasQua(kaunt,3,k)*RomatSt(kaunt) - QQm(k,6)=QQm(k,6)+RasQua(kaunt,6,k)*RomatSt(kaunt) - QQm(k,2)=QQm(k,2)+RasQua(kaunt,2,k)*RomatSt(kaunt) - QQm(k,4)=QQm(k,4)+RasQua(kaunt,4,k)*RomatSt(kaunt) - QQm(k,5)=QQm(k,5)+RasQua(kaunt,5,k)*RomatSt(kaunt) -41 Continue -15 Continue -14 Continue - Do 775, kk=1,3 - xyzMyQ(kk)=0 - xyzMyC(kk)=0 - CofC(kk)=0 -775 Continue - Do 776, kk=1,6 - xyzQuQ(kk)=0 - qQ(kk)=0 - qD(kk)=0 - qK(kk)=0 -776 Continue - Do 866,i=1,iCi - Do 8661, kk=1,3 - xyzMyQ(kk)=xyzMyQ(kk)+Dm(i,kk)+Qm(i)*outxyzRAS(i,kk) -8661 Continue - qQ(1)=qQ(1)+Qm(i)*(outxyzRAS(i,1)-CT(1))*(outxyzRAS(i,1)-CT(1)) - qQ(2)=qQ(2)+Qm(i)*(outxyzRAS(i,1)-CT(1))*(outxyzRAS(i,2)-CT(2)) - qQ(3)=qQ(3)+Qm(i)*(outxyzRAS(i,1)-CT(1))*(outxyzRAS(i,3)-CT(3)) - qQ(4)=qQ(4)+Qm(i)*(outxyzRAS(i,2)-CT(2))*(outxyzRAS(i,2)-CT(2)) - qQ(5)=qQ(5)+Qm(i)*(outxyzRAS(i,2)-CT(2))*(outxyzRAS(i,3)-CT(3)) - qQ(6)=qQ(6)+Qm(i)*(outxyzRAS(i,3)-CT(3))*(outxyzRAS(i,3)-CT(3)) - qD(1)=qD(1)+2*Dm(i,1)*(outxyzRAS(i,1)-CT(1)) - qD(2)=qD(2)+Dm(i,1)*(outxyzRAS(i,2)-CT(2)) - & +Dm(i,2)*(outxyzRAS(i,1)-CT(1)) - qD(3)=qD(3)+Dm(i,1)*(outxyzRAS(i,3)-CT(3)) - & +Dm(i,3)*(outxyzRAS(i,1)-CT(1)) - qD(4)=qD(4)+2*Dm(i,2)*(outxyzRAS(i,2)-CT(2)) - qD(5)=qD(5)+Dm(i,2)*(outxyzRAS(i,3)-CT(3)) - & +Dm(i,3)*(outxyzRAS(i,2)-CT(2)) - qD(6)=qD(6)+2*Dm(i,3)*(outxyzRAS(i,3)-CT(3)) - qK(1)=qK(1)+QQm(i,1) - qK(2)=qK(2)+QQm(i,2) - qK(3)=qK(3)+QQm(i,4) - qK(4)=qK(4)+QQm(i,3) - qK(5)=qK(5)+QQm(i,5) - qK(6)=qK(6)+QQm(i,6) -866 Continue - Trace1=qQ(1)+qQ(4)+qQ(6) - Trace2=qD(1)+qD(4)+qD(6) - Trace1=Trace1/3 - Trace2=Trace2/3 - xyzQuQ(1)=1.5*(qQ(1)+qD(1)-Trace1-Trace2)+qK(1) - xyzQuQ(2)=1.5*(qQ(2)+qD(2))+qK(2) - xyzQuQ(3)=1.5*(qQ(3)+qD(3))+qK(3) - xyzQuQ(4)=1.5*(qQ(4)+qD(4)-Trace1-Trace2)+qK(4) - xyzQuQ(5)=1.5*(qQ(5)+qD(5))+qK(5) - xyzQuQ(6)=1.5*(qQ(6)+qD(6)-Trace1-Trace2)+qK(6) - If(ChargedQM) then !If charged system, then do... - qs=0 - Do 721, i=1,iCi - CofC(1)=CofC(1)+abs(qm(i))*outxyzRAS(i,1) !Center of charge - CofC(2)=CofC(2)+abs(qm(i))*outxyzRAS(i,2) - CofC(3)=CofC(3)+abs(qm(i))*outxyzRAS(i,3) - qs=qs+abs(qm(i)) -721 Continue - CofC(1)=CofC(1)/qs - CofC(2)=CofC(2)/qs - CofC(3)=CofC(3)/qs - Gx=CofC(1)-outxyzRAS(1,1)+Cordst(1,1) !Where C-of-C is globally - Gy=CofC(2)-outxyzRAS(1,2)+Cordst(1,2) - Gz=CofC(3)-outxyzRAS(1,3)+Cordst(1,3) - xyzMyC(1)=xyzMyC(1)+qtot*Gx !Dipole - xyzMyC(2)=xyzMyC(2)+qtot*Gy - xyzMyC(3)=xyzMyC(3)+qtot*Gz - Endif - Do 9977, i=1,3 !The energy of the induced dipole in its reaction - !field. It is ok since polfac*(xyzMyQ+xyzMyi) is - !the field from the induced dipole according to - !the image approximation. And the sought energy - !is -0.5*my_perm*R_ind, which is the thing below, - !see Boethcer p. 145. - Energy=Energy+Polfac*xyzMyQ(i)*(xyzMyQ(i)+xyzMyi(i)) -9977 Continue -*----------------------------------------------------------------------* -* The multipoles of the QM-region, modified due to the polarization, * -* now interacts with each polarizability in the solvent. * -*----------------------------------------------------------------------* - Do 5, i=1,iCi - Do 6, j=1+(nPol*iCnum),iAtom2 - Do 7, k=1,3 - Eil(j,k)=Eil(j,k)+Work(iFil(i,1)-1+j+(k-1)*nPart*nPol)*Qm(i) - Do 8, l=1,3 - Eil(j,k)=Eil(j,k)+Work(iFil(i,l+1)-1+j+(k-1)*nPart*nPol) - & *Dm(i,l) -8 Continue - Eil(j,k)=Eil(j,k)+Work(iFil(i,5)-1+j+(k-1)*nPart*nPol)*QQm(i,1) - Eil(j,k)=Eil(j,k)+Work(iFil(i,7)-1+j+(k-1)*nPart*nPol)*QQm(i,3) - Eil(j,k)=Eil(j,k)+Work(iFil(i,10)-1+j+(k-1)*nPart*nPol)*QQm(i,6) - Eil(j,k)=Eil(j,k)+Work(iFil(i,6)-1+j+(k-1)*nPart*nPol)*QQm(i,2)*2 - Eil(j,k)=Eil(j,k)+Work(iFil(i,8)-1+j+(k-1)*nPart*nPol)*QQm(i,4)*2 - Eil(j,k)=Eil(j,k)+Work(iFil(i,9)-1+j+(k-1)*nPart*nPol)*QQm(i,5)*2 -7 Continue -6 Continue -5 Continue -C...THIS IS LEBENSGEFAHRLICH (original comment says it all!) -*----------------------------------------------------------------------* -* We add up the field from the QM-region to the field on all the * -* solvent polarizabilities. * -*----------------------------------------------------------------------* - Do 10, i=1+(nPol*iCNum),iAtom2 - Iu=i-((i-1)/nPol)*nPol - Do 11, j=1,3 !Here we add the QM-molecule image to the solvent - !polarizabilities. Good old classical dielectric - !cavity model! Fil now contains the field on each - !solvent polarizability from all different - !sources. - Fil(i,j)=Fil(i,j)+PolFac*xyzMyQ(j)+Eil(i,j) - Energy=Energy+Fil(i,j)*Eil(i,j)*Pol(iu) -11 Continue -10 Continue -*----------------------------------------------------------------------* -* Now we wish to make the induced field from the solvent interact with * -* the QM-region. The static field has already interacted in helstate.f.* -* The reaction field of the QM-region in the dielectric cavity is * -* also included, excluding the quadrupoles and higher; they are * -* small anyway, so this is not a major restriction. * -*----------------------------------------------------------------------* - Do 1801, i=1,10 - Gunnar(i)=0 -1801 Continue - Gunnar(2)=PolFac*(xyzMyP(1)+xyzMyQ(1)+xyzMyI(1)+xyzMyC(1)) - Gunnar(3)=PolFac*(xyzMyP(2)+xyzMyQ(2)+xyzMyI(2)+xyzMyC(2)) - Gunnar(4)=PolFac*(xyzMyP(3)+xyzMyQ(3)+xyzMyI(3)+xyzMyC(3)) - Do 1304, l=1,iCi - Gunnar(1)=Gunnar(2)*outxyzRAS(l,1)+Gunnar(3)*outxyzRAS(l,2) - & +Gunnar(4)*outxyzRAS(l,3) !The potential from the - !dipole (the 1/r*r*r is - !in Work(iFil...). - Do 1305, i=1,10 - Poli(l,i)=Gunnar(i) - Do 1306, j=1+(nPol*iCnum),iAtom2 - Iu=j-((j-1)/nPol)*nPol - Do 1307, k=1,3 - !Poli is the polarized field of the solvent. Remember that - !Fil() is the total field on the polarizabilities. - Poli(l,i)=Poli(l,i)-Fil(j,k)*Pol(iu) - & *Work(iFil(l,i)-1+j+(k-1)*nPart*nPol) -1307 Continue -1306 Continue -1305 Continue -1304 Continue - Do 299, i=1,nState*(nState+1)/2 - VpolMat(i)=0 -299 Continue - kaunt=0 - Do 300, iS=1,nState !Attention! The reason we use RasCha etc. and - Do 301, jS=1,iS !not the computed Qm, Dm etc. from above is - kaunt=kaunt+1 !that the density we want to describe is the - Do 302, j=1,iCi !density of the basis-functions. Compare with - !ordinary <psi_i|V_el|psi_j>. - Vpolmat(kaunt)=Vpolmat(kaunt)+Poli(j,1)*RasCha(kaunt,j) - Vpolmat(kaunt)=Vpolmat(kaunt)+Poli(j,2)*RasDip(kaunt,1,j) - Vpolmat(kaunt)=Vpolmat(kaunt)+Poli(j,3)*RasDip(kaunt,2,j) - Vpolmat(kaunt)=Vpolmat(kaunt)+Poli(j,4)*RasDip(kaunt,3,j) - Vpolmat(kaunt)=Vpolmat(kaunt)+Poli(j,5)*RasQua(kaunt,1,j) - Vpolmat(kaunt)=Vpolmat(kaunt)+Poli(j,7)*RasQua(kaunt,3,j) - Vpolmat(kaunt)=Vpolmat(kaunt)+Poli(j,10)*RasQua(kaunt,6,j) - Vpolmat(kaunt)=Vpolmat(kaunt)+Poli(j,6)*RasQua(kaunt,2,j)*2 - Vpolmat(kaunt)=Vpolmat(kaunt)+Poli(j,8)*RasQua(kaunt,4,j)*2 - Vpolmat(kaunt)=Vpolmat(kaunt)+Poli(j,9)*RasQua(kaunt,5,j)*2 -302 Continue -301 Continue -300 Continue - Do 400, i=1,iQ_Atoms !This is how the nuclei interact with the - !induced field (in equil2 exists a corresponding - !term for the interaction with the static field). - !This way interaction between a charged molecule - !and the induced/permanent potential is included. - Energy=Energy-2*Poli(i,1)*ChaNuc(i) -400 Continue - - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(iCall) - End diff -Nru openmolcas-22.02/src/qmstat/polins.F90 openmolcas-22.10/src/qmstat/polins.F90 --- openmolcas-22.02/src/qmstat/polins.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/polins.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,236 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Anders Ohrn * +!*********************************************************************** +! Polins +! +!> @brief +!> Add the field from the QM-region onto the solvent. +!> Include the field from the polarizabilities in the solvent onto the QM-region. +!> (The effect of the static field is taken care of in helstate) +!> @author A. Ohrn +!> +!> @details +!> First we compute the field from the QM-region onto the solvent. The +!> central quantity is the density matrix, which gives us how the +!> QM-region polarizes. The reaction field due to the QM-region is also +!> accounted for. Then we allow the polarized field from the solvent +!> to interact with the QM-region. The static field from the solvent, +!> in other word that from the charges, is already coupled in +!> ::helstate. +!> +!> @param[in,out] Energy The energy of the electrostatic interaction +!> @param[in] iAtom2 Number of particles in the solvent, times number of polarizabilities per solvent molecule +!> @param[in] iCi Number of centers in QM-molecule +!> @param[in] Fil The static field from the solvent +!> @param[out] VpolMat The polarization matrix +!> @param[in,out] FFp The field from the induced dipoles in the solvent +!> @param[in] polfac A factor for the computation of the image +!> @param[out] poli The solvent polarized field on QM +!> @param[out] xyzmyq Total dipole of QM-region +!> @param[in] xyzmyi Total induced dipole of solvent +!> @param[in] xyzmyp Total permanent dipole of solvent +!> @param[in] iCstart Number to keep track of solvent molecules +!> @param[in] iQ_Atoms +!> @param[in] qtot Total charge of QM-region +!> @param[in] ChaNuc +!> @param[in] RoMatSt +!> @param[out] xyzQuQ +!> @param[in] CT +!*********************************************************************** + +subroutine Polins(Energy,iAtom2,iCi,Fil,VpolMat,FFp,polfac,poli,xyzmyq,xyzmyi,xyzmyp,iCstart,iQ_Atoms,qtot,ChaNuc,RoMatSt,xyzQuQ,CT) + +use qmstat_global, only: ChargedQM, Cordst, nCent, nPart, nPol, nState, outxyzRAS, Pol, RasCha, RasDip, RasQua +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, Two, Half, OneHalf +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iAtom2, iCI, iCstart, iQ_Atoms +real(kind=wp), intent(inout) :: Energy, FFp(nPart*nPol,3) +real(kind=wp), intent(in) :: Fil(nPart*nPol,3,iCi,10), polfac, xyzmyi(3), xyzmyp(3), qtot, ChaNuc(iQ_Atoms), & + RoMatSt(nTri_Elem(nState)), CT(3) +real(kind=wp), intent(out) :: VpolMat(nTri_Elem(nState)), Poli(iCi,10), xyzmyq(3), xyzQuQ(6) +integer(kind=iwp) :: i, iCnum, iS, Iu, j, jS, k, kaunt, l +real(kind=wp) :: CofC(3), Gunnar(10), G(3), qD(6), qK(6), qs, qQ(6), Trace1, Trace2, xyzMyC(3) +real(kind=wp), allocatable :: Dm(:,:), Eil(:,:), Qm(:), QQm(:,:) + +!----------------------------------------------------------------------* +! Begin with some zeros. * +!----------------------------------------------------------------------* +call mma_allocate(Qm,iCi,label='Qm') +call mma_allocate(Dm,iCi,3,label='Dm') +call mma_allocate(QQm,iCi,6,label='QQm') +call mma_allocate(Eil,iAtom2,3,label='Eil') +iCnum = iCStart/nCent +Qm(1:iQ_Atoms) = -ChaNuc +Qm(iQ_Atoms+1:) = Zero +Dm(:,:) = Zero +QQm(:,:) = Zero +Eil(:,:) = Zero +!----------------------------------------------------------------------* +! Below we compute how the MME of the QM-molecule changes with the new * +! density matrix Romat. In this step we connect a state density with * +! various multipoles, which will go on and interact with the solvent. * +! This is one of the pivotal steps in coupling the QM-region with the * +! classical region. * +!----------------------------------------------------------------------* +kaunt = 0 +do i=1,nState + do j=1,i + kaunt = kaunt+1 + Qm(:) = Qm(:)+RasCha(kaunt,:)*RomatSt(kaunt) + Dm(:,1) = Dm(:,1)+RasDip(kaunt,1,:)*RomatSt(kaunt) + Dm(:,2) = Dm(:,2)+RasDip(kaunt,2,:)*RomatSt(kaunt) + Dm(:,3) = Dm(:,3)+RasDip(kaunt,3,:)*RomatSt(kaunt) + QQm(:,1) = QQm(:,1)+RasQua(kaunt,1,:)*RomatSt(kaunt) + QQm(:,3) = QQm(:,3)+RasQua(kaunt,3,:)*RomatSt(kaunt) + QQm(:,6) = QQm(:,6)+RasQua(kaunt,6,:)*RomatSt(kaunt) + QQm(:,2) = QQm(:,2)+RasQua(kaunt,2,:)*RomatSt(kaunt) + QQm(:,4) = QQm(:,4)+RasQua(kaunt,4,:)*RomatSt(kaunt) + QQm(:,5) = QQm(:,5)+RasQua(kaunt,5,:)*RomatSt(kaunt) + end do +end do +xyzMyQ(:) = Zero +xyzMyC(:) = Zero +xyzQuQ(:) = Zero +CofC(:) = Zero +qQ(:) = Zero +qD(:) = Zero +qK(:) = Zero +do i=1,iCi + xyzMyQ(:) = xyzMyQ(:)+Dm(i,:)+Qm(i)*outxyzRAS(:,i) + qQ(1) = qQ(1)+Qm(i)*(outxyzRAS(1,i)-CT(1))*(outxyzRAS(1,i)-CT(1)) + qQ(2) = qQ(2)+Qm(i)*(outxyzRAS(1,i)-CT(1))*(outxyzRAS(2,i)-CT(2)) + qQ(3) = qQ(3)+Qm(i)*(outxyzRAS(1,i)-CT(1))*(outxyzRAS(3,i)-CT(3)) + qQ(4) = qQ(4)+Qm(i)*(outxyzRAS(2,i)-CT(2))*(outxyzRAS(2,i)-CT(2)) + qQ(5) = qQ(5)+Qm(i)*(outxyzRAS(2,i)-CT(2))*(outxyzRAS(3,i)-CT(3)) + qQ(6) = qQ(6)+Qm(i)*(outxyzRAS(3,i)-CT(3))*(outxyzRAS(3,i)-CT(3)) + qD(1) = qD(1)+Two*Dm(i,1)*(outxyzRAS(1,i)-CT(1)) + qD(2) = qD(2)+Dm(i,1)*(outxyzRAS(2,i)-CT(2))+Dm(i,2)*(outxyzRAS(1,i)-CT(1)) + qD(3) = qD(3)+Dm(i,1)*(outxyzRAS(3,i)-CT(3))+Dm(i,3)*(outxyzRAS(1,i)-CT(1)) + qD(4) = qD(4)+Two*Dm(i,2)*(outxyzRAS(2,i)-CT(2)) + qD(5) = qD(5)+Dm(i,2)*(outxyzRAS(3,i)-CT(3))+Dm(i,3)*(outxyzRAS(2,i)-CT(2)) + qD(6) = qD(6)+Two*Dm(i,3)*(outxyzRAS(3,i)-CT(3)) + qK(1) = qK(1)+QQm(i,1) + qK(2) = qK(2)+QQm(i,2) + qK(3) = qK(3)+QQm(i,4) + qK(4) = qK(4)+QQm(i,3) + qK(5) = qK(5)+QQm(i,5) + qK(6) = qK(6)+QQm(i,6) +end do +Trace1 = qQ(1)+qQ(4)+qQ(6) +Trace2 = qD(1)+qD(4)+qD(6) +Trace1 = Trace1 +Trace2 = Trace2 +xyzQuQ(:) = OneHalf*(qQ+qD)+qK +xyzQuQ(1) = xyzQuQ(1)-Half*(Trace1+Trace2) +xyzQuQ(4) = xyzQuQ(4)-Half*(Trace1+Trace2) +xyzQuQ(6) = xyzQuQ(6)-Half*(Trace1+Trace2) +if (ChargedQM) then !If charged system, then do... + qs = Zero + do i=1,iCi + CofC(:) = CofC+abs(qm(i))*outxyzRAS(:,i) !Center of charge + qs = qs+abs(qm(i)) + end do + CofC(:) = CofC/qs + G(:) = CofC-outxyzRAS(:,1)+Cordst(:,1) !Where C-of-C is globally + xyzMyC(:) = xyzMyC+qtot*G !Dipole +end if +! The energy of the induced dipole in its reaction field. It is ok since polfac*(xyzMyQ+xyzMyi) is +! the field from the induced dipole according to the image approximation. And the sought energy +! is -0.5*my_perm*R_ind, which is the thing below, see Boethcer p. 145. +do i=1,3 + Energy = Energy+Polfac*xyzMyQ(i)*(xyzMyQ(i)+xyzMyi(i)) +end do +!----------------------------------------------------------------------* +! The multipoles of the QM-region, modified due to the polarization, * +! now interact with each polarizability in the solvent. * +!----------------------------------------------------------------------* +do i=1,iCi + do j=1+(nPol*iCnum),iAtom2 + Eil(j,:) = Eil(j,:)+Fil(j,:,i,1)*Qm(i)+ & + Fil(j,:,i,2)*Dm(i,1)+Fil(j,:,i,3)*Dm(i,2)+Fil(j,:,i,4)*Dm(i,3)+ & + Fil(j,:,i,5)*QQm(i,1)+Fil(j,:,i,7)*QQm(i,3)+Fil(j,:,i,10)*QQm(i,6)+ & + Fil(j,:,i,6)*QQm(i,2)*Two+Fil(j,:,i,8)*QQm(i,4)*Two+Fil(j,:,i,9)*QQm(i,5)*Two + end do +end do +! THIS IS LEBENSGEFAHRLICH (original comment says it all!) +!----------------------------------------------------------------------* +! We add up the field from the QM-region to the field on all the * +! solvent polarizabilities. * +!----------------------------------------------------------------------* +do i=1+(nPol*iCNum),iAtom2 + Iu = i-((i-1)/nPol)*nPol + ! Here we add the QM-molecule image to the solvent polarizabilities. + ! Good old classical dielectric cavity model! + ! FFp now contains the field on each solvent polarizability from all different sources. + do j=1,3 + FFp(i,j) = FFp(i,j)+PolFac*xyzMyQ(j)+Eil(i,j) + Energy = Energy+FFp(i,j)*Eil(i,j)*Pol(iu) + end do +end do +call mma_deallocate(Qm) +call mma_deallocate(Dm) +call mma_deallocate(QQm) +call mma_deallocate(Eil) +!----------------------------------------------------------------------* +! Now we wish to make the induced field from the solvent interact with * +! the QM-region. The static field has already interacted in helstate. * +! The reaction field of the QM-region in the dielectric cavity is * +! also included, excluding the quadrupoles and higher; they are * +! small anyway, so this is not a major restriction. * +!----------------------------------------------------------------------* +Gunnar(:) = Zero +Gunnar(2:4) = PolFac*(xyzMyP+xyzMyQ+xyzMyI+xyzMyC) +do l=1,iCi + ! The potential from the dipole (the 1/r*r*r is in Fil(...). + Gunnar(1) = Gunnar(2)*outxyzRAS(1,l)+Gunnar(3)*outxyzRAS(2,l)+Gunnar(4)*outxyzRAS(3,l) + do i=1,10 + Poli(l,i) = Gunnar(i) + do j=1+(nPol*iCnum),iAtom2 + Iu = j-((j-1)/nPol)*nPol + do k=1,3 + !Poli is the polarized field of the solvent. Remember that + !FFp() is the total field on the polarizabilities. + Poli(l,i) = Poli(l,i)-FFp(j,k)*Pol(iu)*Fil(j,k,l,i) + end do + end do + end do +end do +VpolMat(:) = Zero +kaunt = 0 +! Attention! The reason we use RasCha etc. and not the computed Qm, Dm etc. from above is +! that the density we want to describe is the density of the basis-functions. Compare with +! ordinary <psi_i|V_el|psi_j>. +do iS=1,nState + do jS=1,iS + kaunt = kaunt+1 + do j=1,iCi + Vpolmat(kaunt) = Vpolmat(kaunt)+Poli(j,1)*RasCha(kaunt,j)+ & + Poli(j,2)*RasDip(kaunt,1,j)+Poli(j,3)*RasDip(kaunt,2,j)+Poli(j,4)*RasDip(kaunt,3,j)+ & + Poli(j,5)*RasQua(kaunt,1,j)+Poli(j,7)*RasQua(kaunt,3,j)+Poli(j,10)*RasQua(kaunt,6,j)+ & + Poli(j,6)*RasQua(kaunt,2,j)*Two+Poli(j,8)*RasQua(kaunt,4,j)*Two+Poli(j,9)*RasQua(kaunt,5,j)*Two + end do + end do +end do +! This is how the nuclei interact with the induced field (in equil2 exists a corresponding +! term for the interaction with the static field). +! This way interaction between a charged molecule and the induced/permanent potential is included. +do i=1,iQ_Atoms + Energy = Energy-Two*Poli(i,1)*ChaNuc(i) +end do + +return + +end subroutine Polins diff -Nru openmolcas-22.02/src/qmstat/polprep.f openmolcas-22.10/src/qmstat/polprep.f --- openmolcas-22.02/src/qmstat/polprep.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/polprep.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,99 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine PolPrep(iDist,iDistIm,xx,yy,zz,rr3,xxi,yyi,zzi,Gri - & ,iCNum,nSize) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "qmcom.fh" -#include "WrkSpc.fh" - - Dimension xx(nSize,nSize),yy(nSize,nSize),zz(nSize,nSize) - Dimension rr3(nSize,nSize),xxi(nSize,nSize),yyi(nSize,nSize) - Dimension zzi(nSize,nSize),Gri(nSize,nSize) -*----------------------------------------------------------------------* -* Simply compute some vectors etc. for the ensuing polarization * -* calculation. * -*----------------------------------------------------------------------* - ncParm=ncent*npart-ncent*icNum - Do 711, i=nPol*iCNum+1,nPol*nPart !Loop over solvent polar- - Do 712, j=nPol*iCNum+1,nPol*nPart !ization sites. - rr3(i,j)=0 -712 Continue -711 Continue - IndTr1=0 - !If (iCNum+1).eq.nPart this loop will not be run, but that is - !okey since then we only have one solvent and thus it can not - !experience any field from other solvent molecules. - Do 721, i=1,nPol - Indp1=i+iCnum*nPol - Indco1=i+iCNum*nCent - Do 722, j=iCnum+2,nPart - IndP1=IndP1+nPol - IndCo1=IndCo1+nCent - IndTr=((j-(iCnum+2))*(j-(iCNum+1)))/2*nCent**2+(i-1)*nCent - Do 723, k=1,nPol - IndP2=k+(iCnum-1)*nPol - IndCo2=k+(iCNum-1)*nCent - Do 724, l=iCnum+1,j-1 - IndTr1=Indtr1+1 - Indp2=Indp2+nPol - Indco2=Indco2+nCent - IndTri=IndTr+(l-(iCnum+1))*nCent**2+k - xx(Indp1,Indp2)=(Cordst(indco1,1)-Cordst(indco2,1)) - & *Work(iDist+indtri-1) - yy(Indp1,Indp2)=(Cordst(indco1,2)-Cordst(indco2,2)) - & *Work(iDist+indtri-1) - zz(Indp1,Indp2)=(Cordst(indco1,3)-Cordst(indco2,3)) - & *Work(iDist+indtri-1) - rr3(IndP1,IndP2)=Work(iDist+Indtri-1)**3 - !Why should xx(indp2,indp1)=xx(indp1,indp2), you wonder, should - !they not be of different sign? The answer is, it does not - !matter. Recall that the formula for the field from an ideal - !dipole change sign two times, thus no time in effect, when - !the sign of the r-vector is changed. - xx(Indp2,Indp1)=xx(Indp1,Indp2) - yy(Indp2,Indp1)=yy(Indp1,Indp2) - zz(Indp2,Indp1)=zz(Indp1,Indp2) - rr3(Indp2,Indp1)=rr3(Indp1,Indp2) -724 Continue -723 Continue -722 Continue -721 Continue - Do 725, ii=1,nSize - Do 726, jj=1,nSize - Gri(ii,jj)=0 -726 Continue -725 Continue - Do 731, i=1,nPol - k=i+(iCnum-1)*nCent - Do 732, i1=iCnum+1,nPart - k=k+nCent - imd=(i1-1)*nPol+i - Do 733, j=1,nPol - l=j+(iCnum-1)*nCent - jnd=((i1-(iCnum+1))*nCent+i-1)*ncparm+j-nCent - Do 734, j1=iCnum+1,nPart - l=l+nCent - ild=(j1-1)*nPol+j - jnd=jnd+nCent - Gri(imd,ild)=Work(iDistIm+jnd-1) - xxi(imd,ild)=(Cordim(k,1)-Cordst(l,1))*Work(iDistIm+jnd-1) - yyi(imd,ild)=(Cordim(k,2)-Cordst(l,2))*Work(iDistIm+jnd-1) - zzi(imd,ild)=(Cordim(k,3)-Cordst(l,3))*Work(iDistIm+jnd-1) -734 Continue -733 Continue -732 Continue -731 Continue - - Return - End diff -Nru openmolcas-22.02/src/qmstat/polprep.F90 openmolcas-22.10/src/qmstat/polprep.F90 --- openmolcas-22.02/src/qmstat/polprep.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/polprep.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,93 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine PolPrep(Dist,DistIm,xx,yy,zz,rr3,xxi,yyi,zzi,Gri,iCNum,nSize) + +use qmstat_global, only: CordIm, Cordst, nCent, nPart, nPol +use Index_Functions, only: nTri_Elem +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iCNum, nSize +real(kind=wp), intent(in) :: Dist(nCent,nCent,nTri_Elem(nPart-iCNum-1)), DistIm(nCent,nPart-iCNum,nCent,nPart-iCNum) +real(kind=wp), intent(out) :: xx(nSize,nSize), yy(nSize,nSize), zz(nSize,nSize), rr3(nSize,nSize), xxi(nSize,nSize), & + yyi(nSize,nSize), zzi(nSize,nSize), Gri(nSize,nSize) +integer(kind=iwp) :: i, i1, ild, imd, Indco1, IndCo2, Indp1, IndP2, IndTr, IndTr1, IndTri, j, j1, jnd, k, l, ncParm + +!----------------------------------------------------------------------* +! Simply compute some vectors etc. for the ensuing polarization * +! calculation. * +!----------------------------------------------------------------------* +ncParm = nCent*nPart-nCent*icNum +! Loop over solvent polarization sites. +rr3(nPol*iCNum+1:,nPol*iCNum+1:) = Zero +IndTr1 = 0 +! If (iCNum+1) == nPart this loop will not be run, but that is +! okey since then we only have one solvent and thus it can not +! experience any field from other solvent molecules. +do i=1,nPol + Indp1 = i+iCnum*nPol + Indco1 = i+iCNum*nCent + do j=iCnum+2,nPart + IndP1 = IndP1+nPol + IndCo1 = IndCo1+nCent + IndTr = nTri_Elem(j-(iCnum+2)) + do k=1,nPol + IndP2 = k+(iCnum-1)*nPol + IndCo2 = k+(iCNum-1)*nCent + do l=iCnum+1,j-1 + IndTr1 = Indtr1+1 + Indp2 = Indp2+nPol + Indco2 = Indco2+nCent + IndTri = IndTr+l-iCnum + xx(Indp1,Indp2) = (Cordst(1,indco1)-Cordst(1,indco2))*Dist(k,i,IndTri) + yy(Indp1,Indp2) = (Cordst(2,indco1)-Cordst(2,indco2))*Dist(k,i,IndTri) + zz(Indp1,Indp2) = (Cordst(3,indco1)-Cordst(3,indco2))*Dist(k,i,IndTri) + rr3(IndP1,IndP2) = Dist(k,i,IndTri)**3 + ! Why should xx(indp2,indp1)=xx(indp1,indp2), you wonder, should + ! they not be of different sign? The answer is, it does not + ! matter. Recall that the formula for the field from an ideal + ! dipole changes sign twice, thus no time in effect, when + ! the sign of the r-vector is changed. + xx(Indp2,Indp1) = xx(Indp1,Indp2) + yy(Indp2,Indp1) = yy(Indp1,Indp2) + zz(Indp2,Indp1) = zz(Indp1,Indp2) + rr3(Indp2,Indp1) = rr3(Indp1,Indp2) + end do + end do + end do +end do +Gri(:,:) = Zero +do i=1,nPol + k = i+(iCnum-1)*nCent + do i1=iCnum+1,nPart + k = k+nCent + imd = (i1-1)*nPol+i + do j=1,nPol + l = j+(iCnum-1)*nCent + jnd = ((i1-(iCnum+1))*nCent+i-1)*ncparm+j-nCent + do j1=iCnum+1,nPart + l = l+nCent + ild = (j1-1)*nPol+j + jnd = jnd+nCent + Gri(imd,ild) = DistIm(j,j1-iCnum,i,i1-iCnum) + xxi(imd,ild) = (Cordim(1,k)-Cordst(1,l))*DistIm(j,j1-iCnum,i,i1-iCnum) + yyi(imd,ild) = (Cordim(2,k)-Cordst(2,l))*DistIm(j,j1-iCnum,i,i1-iCnum) + zzi(imd,ild) = (Cordim(3,k)-Cordst(3,l))*DistIm(j,j1-iCnum,i,i1-iCnum) + end do + end do + end do +end do + +return + +end subroutine PolPrep diff -Nru openmolcas-22.02/src/qmstat/polras.f openmolcas-22.10/src/qmstat/polras.f --- openmolcas-22.02/src/qmstat/polras.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/polras.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,121 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine PolRas(iDist,iDistIm,iDT,iFI,iFP,iFil,iCStart - & ,iTriState,VMat,Smat,DiFac,Ract,icnum,Energy - & ,NVarv,iSTC,Haveri,iQ_Atoms,ip_ExpVal,Poli) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "qmcom.fh" -#include "qm2.fh" -#include "numbers.fh" -#include "WrkSpc.fh" - - Dimension Poli(MxQCen,10),VMat(MxStOT),FFp(nPol*nPart,3) - Dimension VpolMat(MxStOT),Smat(MxStOT),RoMatSt(MxStOT) - Dimension EEigen(MxState) - Dimension iDT(3),iFI(3),iFP(3),iFil(MxQCen,10) - Logical JaNej,Haveri - -* -*-- Allocate and initialize the eigenvector matrix with the unit matrix. -* - Call GetMem('Coeff','Allo','Real',iSTC,nState**2) - call dcopy_(nState**2,[ZERO],iZERO,Work(iSTC),iONE) - call dcopy_(nState,[ONE],iZERO,Work(iSTC),nState+1) -* -*-- Define some numbers. -* - nQMCent=(iQ_Atoms*(iQ_Atoms+1))/2 - nPolCent=nPart*nPol - Rinv=1.0d0/Ract - R2inv=Rinv**2 - PolFac=DiFac/Ract**3 - Egun=0.0d0 - -* -*-- Compute distances and vectors needed for solving the polarization -* equations. Observe the use of a memory allocator before the call -* to polprep. This is to conserve memory but without having to -* rewrite the entire polprep routine (written originally with -* static allocations). A future project is to rewrite polprep. -* - Call Memory_PolPrep('Allo',ixx,iyy,izz,irr3,ixxi,iyyi,izzi - & ,iGri,nPol,nPart) - Call PolPrep(iDist,iDistIM,Work(ixx),Work(iyy),Work(izz) - & ,Work(irr3),Work(ixxi),Work(iyyi),Work(izzi) - & ,Work(iGri),iCNum,nPolCent) - -* -*-- Polarization loop commencing. -* - NVarv=0 -7912 Continue - NVarv=NVarv+1 - Energy=0.0d0 - Call PolSolv(iDT,iFI,iFP,Work(ixx),Work(iyy),Work(izz),Work(irr3) - & ,Work(ixxi),Work(iyyi),Work(izzi),Work(iGri),FFp - & ,iCNum,r2Inv,DiFac,nPolCent) - Call DensiSt(RomatSt,Work(iSTC),nEqState,nState,nState) - Call Polins(Energy,iCall,nPolCent,nQMCent,iFil,VpolMat,FFp - & ,PolFac,poli,xyzMyQ,xyzMyI,xyzMyP,iCstart,iQ_Atoms - & ,qTot,ChaNuc,RoMatSt,xyzQuQ,CT) - -* -*-- Assemble the Hamiltonian matrix. -* - Do 815, i=1,iTriState - HmatState(i)=HmatSOld(i)+Vmat(i)+VpolMat(i)+SMat(i) -815 Continue - Energy=0.5*Energy - -* -*-- Diagonalize the bastard. Eigenvalues are sorted and the -* relevant eigenvalue is added to total energy. -* - Call GetMem('Scratch','Allo','Real',iScratch,nState**2) - Call Diag_Driver('V','A','L',nState,HMatState,Work(iScratch) - & ,nState,Dummy,Dummy,iDum,iDum,EEigen,Work(iSTC) - & ,nState,1,-1,'J',nFound,iErr) - If(lCiSelect) Call CiSelector(nEqState,nState,iSTC,nCIRef,iCIInd - & ,dCIRef) - Energy=Energy+EEigen(nEqState) - Call GetMem('Scratch','Free','Real',iScratch,nState**2) - -* -*-- Check if polarization loop has converged. -* - Call HaveWeConv(iCNum,iCStart,iQ_Atoms,nPolCent,iDT,FFp,xyzMyI - & ,Egun,Energy,NVarv,JaNej,Haveri) - If(Haveri) GoTo 8108 - If(.not.JaNej) GoTo 7912 - -8108 Continue - -* -*-- Deallocate. -* - Call Memory_PolPrep('Free',ixx,iyy,izz,irr3,ixxi,iyyi,izzi,iGri - & ,nPol,nPart) - -* -*-- If expectation values are extracted, make a detour. -* - If(lExtr(6))Call Expectus('RASSI',HmatSOld,Vmat,VpolMat,Smat - & ,MxStOT,iSTC,nState,lExtr(4),iExtr_Eig - & ,ip_ExpVal) - -* -*-- Is it dead? It's terminated! -* - Return - End diff -Nru openmolcas-22.02/src/qmstat/polras.F90 openmolcas-22.10/src/qmstat/polras.F90 --- openmolcas-22.02/src/qmstat/polras.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/polras.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,132 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine PolRas(Dist,DistIm,DT,FI,FP,Fil,iCStart,iTriState,VMat,Smat,DiFac,Ract,icnum,Energy,NVarv,STC,Haveri,iQ_Atoms,ExpVal, & + Poli) + +use qmstat_global, only: ChaNuc, CT, dCIRef, HmatSOld, HmatState, iCIInd, iExtr_Eig, lCiSelect, lExtr, nCent, nCIRef, nEqState, & + nPart, nPol, nState, qTot, xyzMyI, xyzMyP, xyzMyQ, xyzQuQ +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iQ_Atoms, iCStart, iTriState, icnum +real(kind=wp), intent(in) :: Dist(nCent,nCent,nTri_Elem(nPart-icnum-1)), DistIm(nCent,nPart-icnum,nCent,nPart-icnum), & + FP(3,nPol*nPart), Fil(nPol*nPart,3,nTri_Elem(iQ_Atoms),10), VMat(iTriState), Smat(iTriState), DiFac, & + Ract +real(kind=wp), intent(inout) :: DT(3,nPol*nPart), Energy +real(kind=wp), intent(out) :: FI(3,nPol*nPart), STC(nState,nState), ExpVal(4,nState), Poli(nTri_Elem(iQ_Atoms),10) +integer(kind=iwp), intent(out) :: NVarv +logical(kind=iwp), intent(out) :: Haveri +integer(kind=iwp) :: iDum, iErr, nFound, nPolCent, nQMCent +real(kind=wp) :: Dummy, Egun, PolFac, R2inv, Rinv +logical(kind=iwp) :: JaNej +real(kind=wp), allocatable :: EEigen(:), FFp(:,:), Gri(:,:), RoMatSt(:), rr3(:,:), Scratch(:,:), VpolMat(:), xx(:,:), xxi(:,:), & + yy(:,:), yyi(:,:), zz(:,:), zzi(:,:) + +! Allocate and initialize the eigenvector matrix with the unit matrix. + +STC(:,:) = Zero +call dcopy_(nState,[One],0,STC,nState+1) + +! Define some numbers. + +nQMCent = nTri_Elem(iQ_Atoms) +nPolCent = nPart*nPol +Rinv = One/Ract +R2inv = Rinv**2 +PolFac = DiFac/Ract**3 +Egun = Zero + +! Compute distances and vectors needed for solving the polarization +! equations. Observe the use of a memory allocator before the call +! to polprep. This is to conserve memory but without having to +! rewrite the entire polprep routine (written originally with +! static allocations). A future project is to rewrite polprep. + +call mma_allocate(xx,nPolCent,nPolCent,label='xx') +call mma_allocate(yy,nPolCent,nPolCent,label='yy') +call mma_allocate(zz,nPolCent,nPolCent,label='zz') +call mma_allocate(xxi,nPolCent,nPolCent,label='ixx') +call mma_allocate(yyi,nPolCent,nPolCent,label='iyy') +call mma_allocate(zzi,nPolCent,nPolCent,label='izz') +call mma_allocate(rr3,nPolCent,nPolCent,label='irr3') +call mma_allocate(Gri,nPolCent,nPolCent,label='iGri') +xx(:,:) = Zero +yy(:,:) = Zero +zz(:,:) = Zero +xxi(:,:) = Zero +yyi(:,:) = Zero +zzi(:,:) = Zero +rr3(:,:) = Zero +Gri(:,:) = Zero +call PolPrep(Dist,DistIm,xx,yy,zz,rr3,xxi,yyi,zzi,Gri,iCNum,nPolCent) + +! Polarization loop commencing. + +call mma_allocate(FFp,nPolCent,3,label='FFp') +call mma_allocate(RoMatSt,nTri_Elem(nState),label='RoMatSt') +call mma_allocate(VpolMat,nTri_Elem(nState),label='VpolMat') +call mma_allocate(EEigen,nState,label='EEigen') +NVarv = 0 +do + NVarv = NVarv+1 + Energy = Zero + call PolSolv(DT,FI,FP,xx,yy,zz,rr3,xxi,yyi,zzi,Gri,FFp,iCNum,r2Inv,DiFac,nPolCent) + call DensiSt(RomatSt,STC,nEqState,nState,nState) + call Polins(Energy,nPolCent,nQMCent,Fil,VpolMat,FFp,PolFac,poli,xyzMyQ,xyzMyI,xyzMyP,iCstart,iQ_Atoms,qTot,ChaNuc,RoMatSt, & + xyzQuQ,CT) + + ! Assemble the Hamiltonian matrix. + + HmatState(:) = HmatSOld+Vmat+VpolMat+SMat + Energy = Half*Energy + + ! Diagonalize the bastard. Eigenvalues are sorted and the relevant eigenvalue is added to total energy. + + call mma_allocate(Scratch,nState,nState,label='Scratch') + call Diag_Driver('V','A','L',nState,HMatState,Scratch,nState,Dummy,Dummy,iDum,iDum,EEigen,STC,nState,1,-1,'J',nFound,iErr) + if (lCiSelect) call CiSelector(nEqState,nState,STC,nCIRef,iCIInd,dCIRef) + Energy = Energy+EEigen(nEqState) + call mma_deallocate(Scratch) + + ! Check if polarization loop has converged. + + call HaveWeConv(iCNum,iCStart,iQ_Atoms,nPolCent,DT,FFp,xyzMyI,Egun,Energy,NVarv,JaNej,Haveri) + if (Haveri .or. JaNej) exit +end do + +! Deallocate. + +call mma_deallocate(FFp) +call mma_deallocate(RoMatSt) +call mma_deallocate(VpolMat) +call mma_deallocate(EEigen) +call mma_deallocate(xx) +call mma_deallocate(yy) +call mma_deallocate(zz) +call mma_deallocate(xxi) +call mma_deallocate(yyi) +call mma_deallocate(zzi) +call mma_deallocate(rr3) +call mma_deallocate(Gri) + +! If expectation values are extracted, make a detour. + +if (lExtr(6)) call Expectus('RASSI',HmatSOld,Vmat,VpolMat,Smat,STC,nState,lExtr(4),iExtr_Eig,ExpVal) + +! Is it dead? It's terminated! + +return + +end subroutine PolRas diff -Nru openmolcas-22.02/src/qmstat/polscf.f openmolcas-22.10/src/qmstat/polscf.f --- openmolcas-22.02/src/qmstat/polscf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/polscf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,138 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine PolScf(iDist,iDistIm,iDT,iFI,iFP,iFil,iCStart - & ,iTri,VMat,Smat,DiFac,Ract,icnum,Energy - & ,NVarv,iMOC,Haveri,iQ_Atoms,ip_ExpVal,Poli) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "qmcom.fh" -#include "qm1.fh" -#include "numbers.fh" -#include "WrkSpc.fh" -#include "warnings.h" - - Dimension Poli(MxQCen,10),VMat(MxOT),FFp(nPol*nPart,3) - Dimension VpolMat(MxOT),Smat(MxOT),RoMat(MxOT) - Dimension EEigen(MxOrb) - Dimension iDT(3),iFI(3),iFP(3),iFil(MxQCen,10) - Logical JaNej,Haveri - -* -*-- Allocate and initialize the eigenvector matrix with the unit matrix. -* - iOrba=iOrb(1) - Call GetMem('Coeff','Allo','Real',iMOC,iOrba**2) - call dcopy_(iOrba**2,[ZERO],iZERO,Work(iMOC),iONE) - call dcopy_(iOrba,[ONE],iZERO,Work(iMOC),iOrba+1) - -* -*-- Define some numbers. -* - nQMCent=(iQ_Atoms*(iQ_Atoms+1))/2 - nPolCent=nPart*nPol - Rinv=1.0d0/Ract - R2inv=Rinv**2 - PolFac=DiFac/Ract**3 - Egun=0.0d0 - -* -*-- Compute some distances needed for the polarization. See polras for -* some additional information on this. -* - Call Memory_PolPrep('Allo',ixx,iyy,izz,irr3,ixxi,iyyi,izzi - & ,iGri,nPol,nPart) - Call PolPrep(iDist,iDistIM,Work(ixx),Work(iyy),Work(izz) - & ,Work(irr3),Work(ixxi),Work(iyyi),Work(izzi) - & ,Work(iGri),iCNum,nPolCent) - -* -*-- Polarization loop commencing. -* - NVarv=0 -7912 Continue - NVarv=NVarv+1 - Energy=0.0d0 - Call PolSolv(iDT,iFI,iFP,Work(ixx),Work(iyy),Work(izz),Work(irr3) - & ,Work(ixxi),Work(iyyi),Work(izzi),Work(iGri),FFp - & ,iCNum,r2Inv,DiFac,nPolCent) - Call Densi_MO(Romat,Work(iMOC),1,iOcc1,iOrb(1),iOrb(1)) - If(Mp2DensCorr) Call DCorrCorr(Romat,DenCorrD,Trace_MP2 - & ,iOrb(1),iOcc1) - Call Polink(Energy,iCall,nPolCent,nQMCent,iFil,VpolMat,FFp - & ,PolFac,Poli,iCstart,iTri,iQ_Atoms,qTot,ChaNuc,xyzMyQ - & ,xyzMyI,xyzMyP,Romat,xyzQuQ,CT) - -* -*-- Construct the Fock-matrix from two-electron super-matrix and -* one-electron matrix, with solvent perturbations added. -* - Do 801, i=1,iTri - FockM(i)=0.0d0 - Do 802, j=1,iTri - FockM(i)=FockM(i)+RoMat(j)*Work(iSupM+iTri*(i-1)+j-1) -802 Continue - OneEl=HHmat(i)+Vmat(i)+VpolMat(i)+Smat(i) - FockM(i)=FockM(i)+OneEl -*---- See Szabo-Ostlund eq. 3.184. - Energy=Energy+(FockM(i)+OneEl)*RoMat(i) -801 Continue -*-- Add potential-nuclear energy. - Energy=Potnuc+Energy*0.5 - -* -*-- If energy is strange, scream! -* - If(Energy.gt.0) then - Write(6,*) - Write(6,*)' SCF energy is positive. Serious error somewhere.' - Call Quit(_RC_GENERAL_ERROR_) - Endif - -* -*-- Diagonalize the Fock-matrix. Eigenvalues are sorted. -* - Call GetMem('Scratch','Allo','Real',iScratch,iOrba**2) - Call Diag_Driver('V','A','L',iOrba,FockM,Work(iScratch) - & ,iOrba,Dummy,Dummy,iDum,iDum,EEigen,Work(iMOC) - & ,iOrba,1,-1,'J',nFound,iErr) - Call GetMem('Scratch','Free','Real',iScratch,iOrba**2) - -* -*-- Check if polarization loop has converged. -* - Call HaveWeConv(iCNum,iCStart,iQ_Atoms,nPolCent,iDT,FFp,xyzMyI - & ,Egun,Energy,NVarv,JaNej,Haveri) - If(Haveri) GoTo 8108 - If(.not.JaNej) GoTo 7912 - -8108 Continue - -* -*-- Deallocate. -* - Call Memory_PolPrep('Free',ixx,iyy,izz,irr3,ixxi,iyyi,izzi,iGri - & ,nPol,nPart) - -* -*-- If expectation values are extracted, make a detour. -* - If(lExtr(6))Call Expectus('SCF ',HHmat,Vmat,VpolMat,Smat - & ,MxOT,iMOC,iOrba,.false.,iOcc1 - & ,ip_ExpVal) - -* -*-- The end is near, hold me! -* - - Return - End diff -Nru openmolcas-22.02/src/qmstat/polscf.F90 openmolcas-22.10/src/qmstat/polscf.F90 --- openmolcas-22.02/src/qmstat/polscf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/polscf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,145 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine PolScf(Dist,DistIm,DT,FI,FP,Fil,iCStart,iTri,VMat,Smat,DiFac,Ract,icnum,Energy,NVarv,MOC,Haveri,iQ_Atoms,ExpVal,Poli) + +use qmstat_global, only: ChaNuc, CT, DenCorrD, FockM, HHmat, iOcc1, iOrb, lExtr, Mp2DensCorr, nCent, nPart, nPol, PotNuc, qTot, & + SupM, Trace_MP2, xyzMyI, xyzMyP, xyzMyQ, xyzQuQ +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Half +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iQ_Atoms, iCStart, iTri, icnum +real(kind=wp), intent(in) :: Dist(nCent,nCent,nTri_Elem(nPart-icnum-1)), DistIm(nCent,nPart-icnum,nCent,nPart-icnum), & + FP(3,nPol*nPart), Fil(nPol*nPart,3,nTri_Elem(iQ_Atoms),10), VMat(iTri), Smat(iTri), DiFac, Ract +real(kind=wp), intent(inout) :: DT(3,nPol*nPart), Energy +real(kind=wp), intent(out) :: FI(3,nPol*nPart), MOC(iOrb(1),iOrb(1)), ExpVal(4,1), Poli(nTri_Elem(iQ_Atoms),10) +integer(kind=iwp), intent(out) :: NVarv +logical(kind=iwp), intent(out) :: Haveri +integer(kind=iwp) :: i, iDum, iErr, iOrba, j, nFound, nPolCent, nQMCent +real(kind=wp) :: Dummy, Egun, OneEl, PolFac, R2inv, Rinv +logical(kind=iwp) :: JaNej +real(kind=wp), allocatable :: EEigen(:), FFp(:,:), Gri(:,:), RoMat(:), rr3(:,:), Scratch(:,:), VpolMat(:), xx(:,:), xxi(:,:), & + yy(:,:), yyi(:,:), zz(:,:), zzi(:,:) +#include "warnings.h" + +! Allocate and initialize the eigenvector matrix with the unit matrix. + +iOrba = iOrb(1) +MOC(:,:) = Zero +call dcopy_(iOrba,[One],0,MOC,iOrba+1) + +! Define some numbers. + +nQMCent = nTri_Elem(iQ_Atoms) +nPolCent = nPart*nPol +Rinv = One/Ract +R2inv = Rinv**2 +PolFac = DiFac/Ract**3 +Egun = Zero + +! Compute some distances needed for the polarization. See polras for some additional information on this. + +call mma_allocate(xx,nPolCent,nPolCent,label='xx') +call mma_allocate(yy,nPolCent,nPolCent,label='yy') +call mma_allocate(zz,nPolCent,nPolCent,label='zz') +call mma_allocate(xxi,nPolCent,nPolCent,label='ixx') +call mma_allocate(yyi,nPolCent,nPolCent,label='iyy') +call mma_allocate(zzi,nPolCent,nPolCent,label='izz') +call mma_allocate(rr3,nPolCent,nPolCent,label='irr3') +call mma_allocate(Gri,nPolCent,nPolCent,label='iGri') +xx(:,:) = Zero +yy(:,:) = Zero +zz(:,:) = Zero +xxi(:,:) = Zero +yyi(:,:) = Zero +zzi(:,:) = Zero +rr3(:,:) = Zero +Gri(:,:) = Zero +call PolPrep(Dist,DistIm,xx,yy,zz,rr3,xxi,yyi,zzi,Gri,iCNum,nPolCent) + +! Polarization loop commencing. + +call mma_allocate(FFp,nPolCent,3,label='FFp') +call mma_allocate(RoMat,max(nTri_Elem(iOrba),iTri),label='RoMat') +call mma_allocate(VpolMat,max(nTri_Elem(iOrba),iTri),label='VpolMat') +call mma_allocate(EEigen,iOrba,label='EEigen') +NVarv = 0 +do + NVarv = NVarv+1 + Energy = Zero + call PolSolv(DT,FI,FP,xx,yy,zz,rr3,xxi,yyi,zzi,Gri,FFp,iCNum,r2Inv,DiFac,nPolCent) + call Densi_MO(Romat,MOC,1,iOcc1,iOrba,iOrba) + if (Mp2DensCorr) call DCorrCorr(Romat,DenCorrD,Trace_MP2,iOrba,iOcc1) + call Polink(Energy,nPolCent,nQMCent,Fil,VpolMat,FFp,PolFac,Poli,iCstart,iTri,iQ_Atoms,qTot,ChaNuc,xyzMyQ,xyzMyI,xyzMyP,Romat, & + xyzQuQ,CT) + + ! Construct the Fock-matrix from two-electron super-matrix and one-electron matrix, with solvent perturbations added. + + FockM(:) = Zero + do i=1,iTri + do j=1,iTri + FockM(i) = FockM(i)+RoMat(j)*SupM(j,i) + end do + OneEl = HHmat(i)+Vmat(i)+VpolMat(i)+Smat(i) + FockM(i) = FockM(i)+OneEl + ! See Szabo-Ostlund eq. 3.184. + Energy = Energy+(FockM(i)+OneEl)*RoMat(i) + end do + ! Add potential-nuclear energy. + Energy = Potnuc+Energy*Half + + ! If energy is strange, scream! + + if (Energy > 0) then + write(u6,*) + write(u6,*) ' SCF energy is positive. Serious error somewhere.' + call Quit(_RC_GENERAL_ERROR_) + end if + + ! Diagonalize the Fock-matrix. Eigenvalues are sorted. + + call mma_allocate(Scratch,iOrba,iOrba,label='Scratch') + call Diag_Driver('V','A','L',iOrba,FockM,Scratch,iOrba,Dummy,Dummy,iDum,iDum,EEigen,MOC,iOrba,1,-1,'J',nFound,iErr) + call mma_deallocate(Scratch) + + ! Check if polarization loop has converged. + + call HaveWeConv(iCNum,iCStart,iQ_Atoms,nPolCent,DT,FFp,xyzMyI,Egun,Energy,NVarv,JaNej,Haveri) + if (Haveri .or. JaNej) exit +end do + +! Deallocate. + +call mma_deallocate(FFp) +call mma_deallocate(RoMat) +call mma_deallocate(EEigen) +call mma_deallocate(xx) +call mma_deallocate(yy) +call mma_deallocate(zz) +call mma_deallocate(xxi) +call mma_deallocate(yyi) +call mma_deallocate(zzi) +call mma_deallocate(rr3) +call mma_deallocate(Gri) + +! If expectation values are extracted, make a detour. + +if (lExtr(6)) call Expectus('SCF ',HHmat,Vmat,VpolMat,Smat,MOC,iOrba,.false.,iOcc1,ExpVal) +call mma_deallocate(VpolMat) + +! The end is near, hold me! + +return + +end subroutine PolScf diff -Nru openmolcas-22.02/src/qmstat/polsolv.f openmolcas-22.10/src/qmstat/polsolv.f --- openmolcas-22.02/src/qmstat/polsolv.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/polsolv.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,108 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine PolSolv(iDT,iFI,iFP,xx,yy,zz,rr3,xxi,yyi,zzi,Gri - &,FFp,iCNum,r2inv,difac,nSize) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "qmcom.fh" -#include "WrkSpc.fh" - - Dimension xx(nSize,nSize),yy(nSize,nSize),zz(nSize,nSize) - Dimension xxi(nSize,nSize),yyi(nSize,nSize),zzi(nSize,nSize) - Dimension rr3(nSize,nSize),Gri(nSize,nSize) - Dimension FFp(nSize,3) - Dimension iDT(3),iFI(3),iFP(3) - -* -*-- The field between the solvent molecules are computed as well as -* the image charge contribtion. Rather basic formules, but keeping -* track on indeces may be difficult. -* - Do 741, j=1,nPol - IndCor=j+(iCnum-1)*Ncent - Inddt=j+(iCnum-1)*nPol - Do 742, i=iCnum+1,nPart - IndCor=IndCor+nCent - Inddt=Inddt+nPol - Agr=Sqrs(IndCor) !Sqrs come from geogen.f. - Skal=Work(iDT(1)+Inddt-1)*Cordst(IndCor,1) - & +Work(iDT(2)+Inddt-1)*Cordst(IndCor,2) - & +Work(iDT(3)+Inddt-1)*Cordst(IndCor,3) - Ta=Skal*Agr**2*R2inv - Tal=-Difac*Ta - Qimp(Inddt)=tal*agr -*------ Image dipoles: Reflect dipole vector in radial vector. This -* is vector geometry at its best. - Dim(IndDt,1)=(Tal*Cordst(IndCor,1)*2 - & +DiFac*Work(iDt(1)+IndDt-1))*Agr**3 - Dim(IndDt,2)=(Tal*Cordst(IndCor,2)*2 - & +DiFac*Work(iDt(2)+IndDt-1))*Agr**3 - Dim(IndDt,3)=(Tal*Cordst(IndCor,3)*2 - & +DiFac*Work(iDt(3)+IndDt-1))*Agr**3 -742 Continue -741 Continue - Do 7432, j=1,3 - Do 7431, i=1+(nPol*iCnum),nSize - Work(iFi(j)+i-1)=0 -7431 Continue -7432 Continue - -* -*-- Here the actual fields are computed, both from the explicit -* solvent and from its image. -* - Do 743, i=1+(nPol*iCNum),nPart*nPol !The real part. - Do 744, j=1+(nPol*iCnum),nPart*nPol - idel1=(i-1)/nPol - idel2=(j-1)/nPol - if(idel1.eq.idel2) GoTo 744 - Skal=xx(i,j)*Work(iDt(1)+i-1)+yy(i,j)*Work(iDt(2)+i-1) - & +zz(i,j)*Work(iDt(3)+i-1) - Skal=Skal*3 - Work(iFi(1)+j-1)=Work(iFi(1)+j-1)-(Work(iDt(1)+i-1)-Skal - & *xx(i,j))*rr3(i,j) - Work(iFi(2)+j-1)=Work(iFi(2)+j-1)-(Work(iDt(2)+i-1)-Skal - & *yy(i,j))*rr3(i,j) - Work(iFi(3)+j-1)=Work(iFi(3)+j-1)-(Work(iDt(3)+i-1)-Skal - & *zz(i,j))*rr3(i,j) -744 Continue -743 Continue - Do 745, i=1+(nPol*iCnum),nPart*nPol !The image part. - Do 746, j=1+(nPol*iCnum),nPart*nPol - Skal=(xxi(i,j)*Dim(i,1)+yyi(i,j)*Dim(i,2)+zzi(i,j)*Dim(i,3)) - Skal=Skal*3 - Work(iFi(1)+j-1)=Work(iFi(1)+j-1)-(Dim(i,1)-Skal*xxi(i,j)) - & *Gri(i,j)**3-Qimp(i)*xxi(i,j)*Gri(i,j)**2 - Work(iFi(2)+j-1)=Work(iFi(2)+j-1)-(Dim(i,2)-Skal*yyi(i,j)) - & *Gri(i,j)**3-Qimp(i)*yyi(i,j)*Gri(i,j)**2 - Work(iFi(3)+j-1)=Work(iFi(3)+j-1)-(Dim(i,3)-Skal*zzi(i,j)) - & *Gri(i,j)**3-Qimp(i)*zzi(i,j)*Gri(i,j)**2 -746 Continue -745 Continue - -* -*-- Add up the things, and add also the part from the permanent -* charges. -* - Do 747, i=1+(nPol*iCnum),nSize - FFp(i,1)=Work(iFi(1)+i-1)+Work(iFp(1)+i-1) - FFp(i,2)=Work(iFi(2)+i-1)+Work(iFp(2)+i-1) - FFp(i,3)=Work(iFi(3)+i-1)+Work(iFp(3)+i-1) -747 Continue - -* -*-- The circle is now complete. I left you when I was about to learn -* and I meet you as the master. -* - Return - End diff -Nru openmolcas-22.02/src/qmstat/polsolv.F90 openmolcas-22.10/src/qmstat/polsolv.F90 --- openmolcas-22.02/src/qmstat/polsolv.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/polsolv.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,81 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine PolSolv(DT,FI,FP,xx,yy,zz,rr3,xxi,yyi,zzi,Gri,FFp,iCNum,r2inv,difac,nSize) + +use qmstat_global, only: Cordst, DipIm, nCent, nPart, nPol, Sqrs, Qimp +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iCNum, nSize +real(kind=wp), intent(in) :: DT(3,nPol*nPart), FP(3,nPol*nPart), xx(nSize,nSize), yy(nSize,nSize), zz(nSize,nSize), & + rr3(nSize,nSize), xxi(nSize,nSize), yyi(nSize,nSize), zzi(nSize,nSize), Gri(nSize,nSize), r2inv, difac +real(kind=wp), intent(out) :: FI(3,nPol*nPart), FFp(nSize,3) +integer(kind=iwp) :: i, idel1, idel2, IndCor, Inddt, j +real(kind=wp) :: Agr, Skal, Ta, Tal + +! The fields between the solvent molecules are computed as well as +! the image charge contribution. Rather basic formulas, but keeping +! track on indices may be difficult. + +do j=1,nPol + IndCor = j+(iCnum-1)*nCent + Inddt = j+(iCnum-1)*nPol + do i=iCnum+1,nPart + IndCor = IndCor+nCent + Inddt = Inddt+nPol + Agr = Sqrs(IndCor) !Sqrs come from geogen. + Skal = DT(1,Inddt)*Cordst(1,IndCor)+DT(2,Inddt)*Cordst(2,IndCor)+DT(3,Inddt)*Cordst(3,IndCor) + Ta = Skal*Agr**2*R2inv + Tal = -Difac*Ta + Qimp(Inddt) = tal*agr + ! Image dipoles: Reflect dipole vector in radial vector. This is vector geometry at its best. + DipIm(:,IndDt) = (Tal*Cordst(:,IndCor)*2+DiFac*DT(:,IndDt))*Agr**3 + end do +end do +FI(:,nPol*iCnum+1:nSize) = Zero + +! Here the actual fields are computed, both from the explicit solvent and from its image. + +do i=1+(nPol*iCNum),nPart*nPol !The real part. + do j=1+(nPol*iCnum),nPart*nPol + idel1 = (i-1)/nPol + idel2 = (j-1)/nPol + if (idel1 == idel2) cycle + Skal = xx(i,j)*DT(1,i)+yy(i,j)*DT(2,i)+zz(i,j)*DT(3,i) + Skal = Skal*3 + FI(1,j) = FI(1,j)-(DT(1,i)-Skal*xx(i,j))*rr3(i,j) + FI(2,j) = FI(2,j)-(DT(2,i)-Skal*yy(i,j))*rr3(i,j) + FI(3,j) = FI(3,j)-(DT(3,i)-Skal*zz(i,j))*rr3(i,j) + end do +end do +do i=1+(nPol*iCnum),nPart*nPol !The image part. + do j=1+(nPol*iCnum),nPart*nPol + Skal = (xxi(i,j)*DipIm(1,i)+yyi(i,j)*DipIm(2,i)+zzi(i,j)*DipIm(3,i)) + Skal = Skal*3 + FI(1,j) = FI(1,j)-(DipIm(1,i)-Skal*xxi(i,j))*Gri(i,j)**3-Qimp(i)*xxi(i,j)*Gri(i,j)**2 + FI(2,j) = FI(2,j)-(DipIm(2,i)-Skal*yyi(i,j))*Gri(i,j)**3-Qimp(i)*yyi(i,j)*Gri(i,j)**2 + FI(3,j) = FI(3,j)-(DipIm(3,i)-Skal*zzi(i,j))*Gri(i,j)**3-Qimp(i)*zzi(i,j)*Gri(i,j)**2 + end do +end do + +! Add up the things, and add also the part from the permanent charges. + +do i=1+(nPol*iCnum),nSize + FFp(i,:) = Fi(:,i)+FP(:,i) +end do + +! The circle is now complete. I left you when I was about to learn and I meet you as the master. + +return + +end subroutine PolSolv diff -Nru openmolcas-22.02/src/qmstat/put8.F90 openmolcas-22.10/src/qmstat/put8.F90 --- openmolcas-22.02/src/qmstat/put8.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/put8.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,50 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! PUT NUMBERS ON STARTFILE. +subroutine Put8(Ract,Etot,Gmma,Gam,Esav) + +use qmstat_global, only: Cordst, iLuStut, iPrint, iTcSim, nCent, nPart, StFilUt +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +real(kind=wp), intent(_IN_) :: Ract, Etot, Gmma, Gam, Esav +integer(kind=iwp) :: i, iDisk +character(len=200) :: Head +real(kind=wp), allocatable :: CT(:) + +call DaName(iLuStUt,StFilUt) !Here follows a general output to the startfile +iDisk = 0 +call WrRdSim(iLuStUt,1,iDisk,iTcSim,64,Etot,Ract,nPart,Gmma,Gam,Esav) +iTcSim(1) = iDisk +! In this loop the coordinates are put on file. +! The loop is needed due to how Cordst is statically allocated. +call mma_allocate(CT,nPart*nCent,label='CTemp') +do i=1,3 + CT(:) = Cordst(i,1:nPart*nCent) + call dDaFile(iLuStUt,1,CT,nPart*nCent,iDisk) + iTcSim(1+i) = iDisk +end do +call mma_deallocate(CT) +iDisk = 0 +call WrRdSim(iLuStUt,1,iDisk,iTcSim,64,Etot,Ract,nPart,Gmma,Gam,Esav) +call DaClos(iLuStUt) +if (iPrint >= 10) then !Print the stored configuration. + write(Head,*) ' Coordinates put on the startfile solvent configuration.' + call Cooout(Head,Cordst,nPart,nCent) +end if + +return + +end subroutine PUT8 diff -Nru openmolcas-22.02/src/qmstat/put9.F90 openmolcas-22.10/src/qmstat/put9.F90 --- openmolcas-22.02/src/qmstat/put9.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/put9.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,53 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! PUT NUMBERS ON SAMPFILE. +subroutine Put9(Etot,Ract,iHowMSamp,Gmma,Gam,Esav,iDisk) + +use qmstat_global, only: Cordst, iLuSaUt, iPrint, iTcSim, nCent, nPart +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +real(kind=wp), intent(_IN_) :: Etot, Ract, Gmma, Gam, Esav +integer(kind=iwp), intent(inout) :: iHowMSamp, iDisk +integer(kind=iwp) :: i, iDiskHead, iDiskOld +character(len=200) :: Head +real(kind=wp), allocatable :: CT(:) + +iHowMSamp = iHowMSamp+1 +iDiskOld = iDisk +call WrRdSim(iLuSaUt,1,iDisk,iTcSim,64,Etot,Ract,nPart,Gmma,Gam,Esav) !A header +iTcSim(1) = iDisk +call mma_allocate(CT,nPart*nCent) +do i=1,3 + CT(:) = Cordst(i,1:nCent*nPart) + call dDaFile(iLuSaUt,1,CT,nPart*nCent,iDisk) + ! The solvent coordinates. + iTcSim(i+1) = iDisk +end do +call mma_deallocate(CT) +!call dDaFile(iLuSaUt,1,-DT,3*nPart*nPol,iDisk) +!iTcSim(5) = iDisk +iDiskHead = iDiskOld +! Put header again, but now with a meaningful iTcSim vector that contains the table of contents which simplifies reading +call WrRdSim(iLuSaUt,1,iDiskHead,iTcSim,64,Etot,Ract,nPart,Gmma,Gam,Esav) + +if (iPrint >= 15) then + write(Head,*) ' Coordinates put on sampfile.' + call Cooout(Head,Cordst,nPart,nCent) +end if + +return + +end subroutine PUT9 diff -Nru openmolcas-22.02/src/qmstat/putsgets.f openmolcas-22.10/src/qmstat/putsgets.f --- openmolcas-22.02/src/qmstat/putsgets.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/putsgets.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,198 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -* -* ALL SUBROUTINE HERE HAVE THE PURPOSE TO PUT OR GET NUMBERS ON/FROM -* STARTFILES AND SAMPFILES. -* - Subroutine Get8(Ract,Etot) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "files_qmstat.fh" -#include "WrkSpc.fh" - - Character Head*200 - - iDisk=0 - Call DaName(iLuStIn,StFilIn) - Call WrRdSim(iLuStIn,2,iDisk,iTcSim,64,Etot,Ract,nPart,Gamold - &,GaOld,Esub) - iDisk=iTcSim(1) -* -*---- In this loop we read the coordinates. The construction of Cordst -* makes this loop necessary. Maybe we should consider going to -* dynamic allocation. -* - Do 1020, i=1,3 - Call GetMem('CTemp','Allo','Real',iCT,nPart*nCent) - Call dDaFile(iLuStIn,2,Work(iCT),nPart*nCent,iDisk) - Do 1021, j=1,nCent*nPart - Cordst(j,i)=Work(iCT+j-1) -1021 Continue - Call GetMem('CTemp','Free','Real',iCT,nPart*nCent) - iDisk=iTcSim(i+1) -1020 Continue - Call DaClos(iLuStIn) -* -*---- If requested, print initial coordinates. -* - If(iPrint.ge.10) then - Write(Head,*)'Coordinates read from startfile.' - Call Cooout(Head,Cordst,nPart,nCent) - Endif - - Return - End - - - Subroutine Get9(Ract,Coord,info_atom,iQ_Atoms,iDiskSa) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "files_qmstat.fh" -#include "WrkSpc.fh" - - Dimension Coord(MxAt*3) - Dimension info_atom(MxAt) - Character Head*200 - - Call WrRdSim(iLuSaIn,2,iDiskSa,iTcSim,64,Etot,Ract,nPart,Gamold - &,GaOld,Esub) - iDiskSa=iTcSim(1) - Do 1022, i=1,3 - Call GetMem('CTemp','Allo','Real',iCT,nPart*nCent) - Call dDaFile(iLuSaIn,2,Work(iCT),nPart*nCent,iDiskSa) - Do 1023, j=1,nCent*nPart - Cordst(j,i)=Work(iCT+j-1) -1023 Continue - Call GetMem('CTemp','Free','Real',iCT,nPart*nCent) - iDiskSa=iTcSim(i+1) -1022 Continue -* -*---- We dummy-read the induced dipoles from the sampfile. -* -* Call GetMem('Dummy','Allo','Real',iDum,nPart*nPol) -* Do 1777, i=1,3 -* Call dDaFile(iLuSaIn,2,Work(iDum),nPol*nPart,iDiskSa) -*1777 Continue -* Call GetMem('Dummy','Free','Real',iDum,nPart*nPol) -* -*---- And now we place the QM-molecule in proper place and set some -* numbers to zero or one so we only collect configurations from -* the sampfile. -* - Call PlaceIt9(Coord,Cordst,info_atom,iQ_Atoms) - delX=0 - delFi=0 - delR=0 - nMacro=1 - nMicro=1 -* -*---- Some printing if requested. -* - If(iPrint.ge.15) then - Write(Head,*)'Coordinates after substitution in configuration r' - &//'ead from sampfile.' - Call Cooout(Head,Cordst,nPart,nCent) - Endif - - Return - End - - - Subroutine Put9(Etot,Ract,iDT,iHowMSamp,Gamma,Gam,Esav,iDisk) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "files_qmstat.fh" -#include "WrkSpc.fh" - - Dimension iDT(3) - Character Head*200 - - iHowMSamp=iHowMSamp+1 - iDiskOld=iDisk - Call WrRdSim(iLuSaUt,1,iDisk,iTcSim,64,Etot,Ract,nPart - & ,Gamma,Gam,Esav) !A header - iTcSim(1)=iDisk - Do 1024, i=1,3 - Call GetMem('CTemp','Allo','Real',iCT,nPart*nCent) - Do 1025, j=1,nCent*nPart - Work(iCT+j-1)=Cordst(j,i) -1025 Continue - Call dDaFile(iLuSaUt,1,Work(iCT),nPart*nCent,iDisk) - !The solvent coordinates. - Call GetMem('CTemp','Free','Real',iCT,nPart*nCent) - iTcSim(i+1)=iDisk -1024 Continue -* Do 777, i=1,3 -* Call dDaFile(iLuSaUt,1,-Work(iDT(i)),nPart*nPol,iDisk) -*777 Continue !Induced dipoles. -* iTcSim(5)=iDisk - iDiskHead=iDiskOld - Call WrRdSim(iLuSaUt,1,iDiskHead,iTcSim,64,Etot,Ract,nPart - & ,Gamma,Gam,Esav) !Put header again, but - !now with a - !meaningful iTcSim vector that contains - !the table of content which simplifies reading - - If(iPrint.ge.15) then - Write(Head,*)' Coordinates put on sampfile.' - Call Cooout(Head,Cordst,nPart,nCent) - Endif - - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer_array(iDT) - End - - - Subroutine Put8(Ract,Etot,Gamma,Gam,Esav) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "files_qmstat.fh" -#include "WrkSpc.fh" - - Character Head*200 - - Call DaName(iLuStUt,StFilUt) !Here follows a general output - iDisk=0 !to the startfile. - Call WrRdSim(iLuStUt,1,iDisk,iTcSim,64,Etot,Ract,nPart,Gamma - & ,Gam,Esav) - iTcSim(1)=iDisk - Do 1010,i=1,3 !In this loop the coordinates are put on file. - !The loop is needed due to how Cordst is - !statically allocated. - Call GetMem('CTemp','Allo','Real',iCT,nPart*nCent) - Do 1011,j=1,nPart*nCent - Work(iCT+j-1)=Cordst(j,i) -1011 Continue - Call dDaFile(iLuStUt,1,Work(iCT),nPart*nCent,iDisk) - iTcSim(1+i)=iDisk - Call GetMem('CTemp','Free','Real',iCT,nPart*nCent) -1010 Continue - iDisk=0 - Call WrRdSim(iLuStUt,1,iDisk,iTcSim,64,Etot,Ract,nPart,Gamma - & ,Gam,Esav) - Call DaClos(iLuStUt) - If(iPrint.ge.10) then !Print the stored configuration. - Write(Head,*)' Coordinates put on the startfile solvent configu' - &//'ration.' - Call Cooout(Head,Cordst,nPart,nCent) - Endif - - Return - End diff -Nru openmolcas-22.02/src/qmstat/qfread.f openmolcas-22.10/src/qmstat/qfread.f --- openmolcas-22.02/src/qmstat/qfread.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/qfread.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,408 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Anders Ohrn * -************************************************************************ -* Qfread -* -*> @brief -*> Read in all data that comes from external Molcas routines and prepare various quantities, such as MME -*> @author A. Ohrn -*> -*> @details -*> This subroutine handles the interaction with the rest of Molcas. -*> Here orbitals and various matrices are stored and to some extent -*> modified to our purpose. We call on this subroutine even when -*> we are running classical stuff. The reason for this is that we -*> wish to collect some numbers, but really, we could easily have -*> constructed thing differently so that this subroutine only would -*> be called when quantum-classical stuff is running. For RASSI -*> implementation, we also read in and transform the transition density -*> matrix. At the end, we also call the routines that make the -*> multicenter multipole expansion. -*> -*> @note -*> Seward is mandatory for both SCF and RASSI. For SCF also, -*> Motra, Averd; for RASSI also, RASSCF and RASSI. -*> -*> @param[out] nAtomsCC Atoms in solvent -*> @param[out] Coord Unique coordinates of the atoms in the molecule in the QM-region -*> @param[out] nBas Number of basis functions in QM-region -*> @param[out] nBasCC Like nBas but for a solvent molecule -*> @param[out] nCnC_C Like nCnC, but for solvent -*> @param[out] nntyp Number of basis-function types. -*> @param[out] nOcc The total number of basis functions that belong to a certain basis-function type. -*> @param[out] natyp Number of atoms of the i:th basis-function type -************************************************************************ -*******JoseMEP the last three variables are included to the MEP calculation - Subroutine Qfread(iQ_Atoms,nAtomsCC,Coord,nBas,nBasCC,nCnC_C - &,nOcc,natyp,nntyp) - Implicit Real*8 (a-h,o-z) - -*-----------------------------------------------------------------------* -* Variables * -*-----------------------------------------------------------------------* -#include "maxi.fh" -#include "qminp.fh" -#include "files_qmstat.fh" -#include "qmcom.fh" -#include "qm1.fh" -#include "qm2.fh" -#include "integral.fh" -#include "numbers.fh" -#include "WrkSpc.fh" -#include "tratoc.fh" -#include "warnings.h" - - Parameter (IndMax=nTraBuf) !nTraBuf definied in tratoc.fh - - Dimension Coord(MxAt*3),Chge(MxAt),CoordCC(3*3),ChgeCC(3) - Dimension Cmo(MxBas**2),Cmo_S(MxBas**2),Occu(MxBas),Dummy(MxBas) - - Dimension nSh(MxAt),nfSh(MxAt,MxAngqNr),nCnC_C(MxBasC) - Dimension nOcc(MxBas),natyp(MxAt),natypC(MxAt),iDumm(MxBas) - Dimension nBas(MxSym),nBasCC(1),iCon(MxAt,MxPrCon) - Dimension iC_icon(MxAt,MxPrCon) - - Character Line*120,BlLine*120,Title*100,OrbName*100,WhatGet*10 - Character StLine*120 - Dimension iDummy(1) - Integer ipACC - -*-----------------------------------------------------------------------* -* Enter * -*-----------------------------------------------------------------------* - -*------------------------------------------------------------------------* -* Print the joblabel. It is obtained in get_input.f * -*------------------------------------------------------------------------* - If(ATitle) then - lLine=Len(Line) - Do 9990, i=1,lLine - BlLine(i:i)=' ' - StLine(i:i)='*' -9990 Continue - Write(6,*) - Do 9991, i=1,6 - Line=BlLine - If(i.eq.1.or.i.eq.6) Line=StLine - If(i.eq.3) Line='Project:' - If(i.eq.4) Write(Line,'(A72)')JobLab - Call Center_Text(Line) - Write(6,*)'*'//Line//'*' -9991 Continue - Write(6,*) - Endif - Write(6,*)'Auxiliary data being read and pre-processed.' -*----------------------------------------------------------------------* -* Collect some data from RUNFILE about the QM-region molecule. * -*----------------------------------------------------------------------* - Call Get_iScalar('nSym',nSym) - If(nSym.ne.1) then !A minor restriction, no symmetry allowed, - !i.e. nSym=1. - Write(6,*) - Write(6,*)' QmStat does not run with symmetry!' - Write(6,*)' The perturbation from the solvent breaks all symmet' - &//'ry.' - Call Quit(_RC_GENERAL_ERROR_) - Endif - Call Get_iScalar('Unique atoms',iQ_Atoms) - If(iQ_Atoms.gt.MxAt) then - Write(6,*) - Write(6,*)'Maximum number of atoms exceeded. Increase MxAt in ' - &//'maxi.fh in QmStat source directory.' - Call Quit(_RC_GENERAL_ERROR_) - Endif - Call Get_dArray('Nuclear charge',Chge,iQ_Atoms) - Call Get_dArray('Unique Coordinates',Coord,3*iQ_Atoms) - Call Get_dArray('Center of Mass',CT,3) - Call Get_iArray('nBas',nBas,nSym) - If(nBas(1).gt.MxBas) then - Write(6,*) - Write(6,*)'Maximum number of basis functions exceeded. Increase' - &//' MxBas in maxi.fh in QmStat source directory.' - Call Quit(_RC_GENERAL_ERROR_) - Endif - -*------------------------------------------------------------------------* -* Print elementary information about molecule. * -*------------------------------------------------------------------------* - Write(6,*) - Write(6,*)' ------------------------------' - Write(6,*)' | QM-region data |' - Write(6,*)' ------------------------------' - Write(6,*) - Write(6,'(A,15X,I5)')' Number of basis functions:' - & ,(nBas(i),i=1,nSym) - Write(6,'(A,3F10.6)')' Centre of mass =',(CT(kk),kk=1,3) - Call PrCoor - -*----------------------------------------------------------------------* -* If the Qmtype is SCF we now want the orbitals. On the other hand if * -* we are running RASSI, another route must be taken, hence here we * -* inquire which QM-method that is used. * -*----------------------------------------------------------------------* - If(QmType(1:3).eq.'SCF') then -*----------------------------------------------------------------------* -* SSS CCC FFFFFF * -* SS CC FF * -* SS CC FFFF * -* SS CC FF * -* SSS CCC FF * -*----------------------------------------------------------------------* - -*----------------------------------------------------------------------* -* Print information about orbitals and store coefficients in new * -* variable. * -*----------------------------------------------------------------------* - iLu=15 - iLu=IsFreeUnit(iLu) - Write(OrbName,'(A)')'AVEORB' - Write(WhatGet,'(A)')'CO' - iWarn=1 - Call RdVec(OrbName,iLu,WhatGet,nSym,nBas,nBas,Cmo,Occu,Dummy - &,iDumm,Title,iWarn,iErr) - If(iErr.ne.0) then - Write(6,*) - Write(6,*)'Error when reading AVEORB' - Write(6,*) - Call Quit(_RC_IO_ERROR_READ_) - Endif - kaunter=0 - Call GetMem('OrbCoeffQ','Allo','Real',iV1,iOrb(1)*nBas(1)) - Do 102,j=1,iOrb(1) - Do 103,k=1,nBas(1) - Work(iV1+kaunter)=Cmo(k+(j-1)*nBas(1)) - kaunter=kaunter+1 -103 Continue -102 Continue -* Write(6,'(A,I4)')' Number of Orbitals:',iOrb(1) - Call Get_dScalar('PotNuc',PotNuc) - - Elseif(QmType(1:4).eq.'RASS') then -*----------------------------------------------------------------------* -* RRRR AA SSS SSS II * -* RR R A A SS SS II * -* RR R AAAAAA SS SS II * -* RRR AA AA SS SS II * -* RR R AA AA SSS SSS II * -*----------------------------------------------------------------------* - Call TdmTrans(nBas) - Endif - Write(6,*) - Write(6,*) -*----------------------------------------------------------------------* -* Compute various information about system. This we use for computing * -* integrals later. GiveMeInfo collects stuff from seward, somtime with * -* some recomputations. * -*----------------------------------------------------------------------* - Call GiveMeInfo(nBas(1),nntyp,natyp,BasOri,Icon,nPrimus,nBA_Q - &,nCBoA_Q,nBonA_Q,ipE,ipC,nsh,nfsh,nSize,iPrint,MxAt,MxPrCon,MxBas - &,MxAngqNr,ipACC,nACCSizeQ) - iBas=0 - iAtom=0 - kold=1 - iold=1 - indold=0 - Do 149, i=1,nntyp - nOcc(i)=0 -149 Continue - Do 150, i=1,nntyp - na=natyp(i) - Do 151, j=1,na - ind=0 - jnd=0 - iAtom=iAtom+1 - ChaNuc(iAtom)=Chge(iAtom) - info_atom(iAtom)=int(Chge(iAtom)) - nShj=nSh(i) - Do 152, k=1,nShj - nnaa=nfsh(i,k) - Do 153, l=1,nnaa - ibas=ibas+1 - indold=indold+1 - nOcc(i)=nOcc(i)+2*k-1 - ind=ind+1 - iQang(ibas)=k - icont=Icon(i,ind) - iCharOnBasQ(ibas)=int(Chge(iAtom)) - Do 1531, ix=1,2*k-1 !Here we construct an array of - If(k.ne.kold) then !indeces which is used to put right - If(i.ne.iold) then !AO-overlap in right matrix pos. - Indold=Indold+nfsh(iold,kold)*(2*kold-2) - iold=i - Else - Indold=Indold+nfsh(i,kold)*(2*kold-2) - Endif - kold=k - Endif - iWoGehenQ(ibas,ix)=indold+nnaa*(ix-1) -1531 Continue - Do 154, m=1,icont - jnd=jnd+1 - alfa(ibas,m)=Work(ipE+i-1+MxAt*(jnd-1)) - cont(ibas,m)=Work(ipC+i-1+MxAt*(jnd-1)) -154 Continue -153 Continue -152 Continue -151 Continue -150 Continue - Kmax=ibas - call dcopy_(nACCSizeQ,Work(ipACC),iONE,Trans,iONE) - Call GetMem('AccTransa','Free','Real',ipACC,nACCSizeQ) - Call GetMem('Exponents','Free','Real',ipE,nSize*MxAt) !Now we - Call GetMem('ContrCoef','Free','Real',ipC,nSize*MxAt) !do not - !need them, so deallocate. - -*------------------------------------------------------------------------* -* Obtain and print information about solvent. This requires a renaming * -* of the runfile. * -*------------------------------------------------------------------------* - Call NameRun('WRUNFIL') - Call Get_iScalar('nSym',nSymCC) - If(nSymCC.ne.1) then - Write(6,*) - Write(6,*)' QmStat does not run with symmetry!' - Call Quit(_RC_GENERAL_ERROR_) - Endif - Call Get_iScalar('Unique atoms',nAtomsCC) - If(nAtomsCC.ne.3) then - Write(6,*) - Write(6,*)'Now now... what strange solvent molecule do you try' - &//' to feed QmStat with?' - Call Quit(_RC_GENERAL_ERROR_) - Endif - Call Get_dArray('Nuclear charge',ChgeCC,nAtomsCC) - Call Get_dArray('Unique Coordinates',CoordCC,3*nAtomsCC) - Call Get_iArray('nBas',nBasCC,nSymCC) - If(nBasCC(1).gt.MxBasC) then - Write(6,*) - Write(6,*)'Number of solvent molecule basis functions exceeded.' - &//' Increase MxBasC in maxi.fh in QmStat source directory.' - Call Quit(_RC_GENERAL_ERROR_) - Endif - Write(6,*) - Write(6,*)' ------------------------------' - Write(6,*)' | Solvent molecule data |' - Write(6,*)' ------------------------------' - Write(6,*) - Write(6,'(A,15X,I5)')' Number of basis functions:' - & ,(nBasCC(i),i=1,nSymCC) - Call PrCoor - -* -*--- Collect information about the solvent orbitals. -* - iLu=16 - iLu=IsFreeUnit(iLu) - Write(OrbName,'(A)')'SOLORB' - Write(WhatGet,'(A)')'CE' - iWarn=1 - Call GetMem('OrbitalEnergy','Allo','Real',iOe,Sum(nBasCC)) - Call RdVec(OrbName,iLu,WhatGet,nSymCC,nBasCC,nBasCC,Cmo_S - &,Dummy,Work(iOe),iDummy,Title,iWarn,iErr) - Do 22, i=1,iOrb(2) - c_orbene(i)=Work(iOe+i-1) -22 Continue - Call GetMem('OrbitalEnergy','Free','Real',iOe,Sum(nBasCC)) - -* -*--- We should not need two solvent orbital vectors, so this should -* be removed when the orbital rotation routine is fixed. -* - Do 202,j=1,iOrb(2) - Do 203,k=1,nBasCC(1) - V3(k,j)=Cmo_S(k+(j-1)*nBasCC(1)) -203 Continue -202 Continue -* Write(6,'(A,I4)')' Number of Orbitals:',iOrb(2) - Write(6,*) - Write(6,*) -*-----------------------------------------------------------------------* -* And now basis set information. * -*-----------------------------------------------------------------------* - Call GiveMeInfo(nBasCC(1),nntypC,natypC,SavOri,iC_Icon,mPrimus - &,nBA_C,nCBoA_C,nBonA_C,ipE_C,ipC_C,nsh,nfsh,nSize,iPrint,MxAt - &,MxPrCon,MxBas,MxAngqNr,ipACC,nACCSizeC) - iBas=0 - iAtom=0 - kold=1 - iold=1 - indold=0 - Do 250, i=1,nntypC !Like the corresponding thing above for - na=natypC(i) !the QM-region. - Do 251, j=1,na - ind=0 - jnd=0 - nShj=nSh(i) - iAtom=iAtom+1 - Do 252, k=1,nShj - nnaa=nfsh(i,k) - Do 253, l=1,nnaa - ibas=ibas+1 - indold=indold+1 - nCnC_C(ibas)=nnaa - ind=ind+1 - icont=iC_Icon(i,ind) - iqn(ibas)=k - iCharOnBasC(ibas)=int(ChgeCC(iAtom)) - Do 2531, ix=1,2*k-1 !Here we construct an array of - If(k.ne.kold) then !indeces which is used to put right - If(i.ne.iold) then !AO-overlap in right matrix pos. - Indold=Indold+nfsh(iold,kold)*(2*kold-2) - iold=i - Else - Indold=Indold+nfsh(i,kold)*(2*kold-2) - Endif - kold=k - Endif - iWoGehenC(ibas,ix)=indold+nnaa*(ix-1) -2531 Continue - Do 254, m=1,icont - jnd=jnd+1 - beta(ibas,m)=Work(ipE_C+i-1+MxAt*(jnd-1)) - dont(ibas,m)=Work(ipC_C+i-1+MxAt*(jnd-1)) -254 Continue -253 Continue -252 Continue -251 Continue -250 Continue - Lmax=ibas - If(nACCSizeC.gt.nACCSizeQ) then - call dcopy_(nACCSizeC,Work(ipACC),iONE,Trans,iONE) - Endif - Call GetMem('AccTransa','Free','Real',ipACC,nACCSizeC) - Call GetMem('Exponents','Free','Real',ipE_C,nSize*MxAt) !Now we - Call GetMem('ContrCoef','Free','Real',ipC_C,nSize*MxAt) !do not - !need them, so deallocate. -* -*----------------------------------------------------------------------* -* A small test to see if max-limits are violated. * -*----------------------------------------------------------------------* - If(Kmax.gt.MxBB.or.Lmax.gt.MxBB) then - Write(6,*) - Write(6,*)'ERROR! MxBB too small!' - Call Quit(_RC_INTERNAL_ERROR_) - Endif -*----------------------------------------------------------------------* -* The multipoles and the Hamiltonian matrix are radically different * -* between the QM-method alternatives, so once more an inquire. * -*----------------------------------------------------------------------* - Call NameRun('RUNFILE') - If(QmType(1:3).eq.'SCF') then - Call ScfHandM(Cmo,nBas,iQ_Atoms,nOcc,natyp,nntyp,Occu) - Elseif(QmType(1:4).eq.'RASS') then - Call RassiHandM(nBas,iQ_Atoms,nOcc,natyp,nntyp) - Endif -*----------------------------------------------------------------------* -* Here is the end. * -*----------------------------------------------------------------------* - Return - End diff -Nru openmolcas-22.02/src/qmstat/qfread.F90 openmolcas-22.10/src/qmstat/qfread.F90 --- openmolcas-22.02/src/qmstat/qfread.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/qfread.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,404 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Anders Ohrn * +!*********************************************************************** +! Qfread +! +!> @brief +!> Read in all data that comes from external Molcas routines and prepare various quantities, such as MME +!> @author A. Ohrn +!> +!> @details +!> This subroutine handles the interaction with the rest of Molcas. +!> Here orbitals and various matrices are stored and to some extent +!> modified to our purpose. We call on this subroutine even when +!> we are running classical stuff. The reason for this is that we +!> wish to collect some numbers, but really, we could easily have +!> constructed thing differently so that this subroutine only would +!> be called when quantum-classical stuff is running. For RASSI +!> implementation, we also read in and transform the transition density +!> matrix. At the end, we also call the routines that make the +!> multicenter multipole expansion. +!> +!> @note +!> Seward is mandatory for both SCF and RASSI. For SCF also, +!> Motra, Averd; for RASSI also, RASSCF and RASSI. +!> +!> @param[in] iQ_Atoms +!> @param[out] nAtomsCC Atoms in solvent +!> @param[out] Coord Unique coordinates of the atoms in the molecule in the QM-region +!> @param[out] nBas Number of basis functions in QM-region +!> @param[out] nBasCC Like nBas but for a solvent molecule +!> @param[out] nOcc The total number of basis functions that belong to a certain basis-function type. +!> @param[out] natyp Number of atoms of the i:th basis-function type +!> @param[out] nntyp Number of basis-function types. +!*********************************************************************** + +!******JoseMEP the last three variables are included to the MEP calculation +subroutine Qfread(iQ_Atoms,nAtomsCC,Coord,nBas,nBasCC,nOcc,natyp,nntyp) + +use qmstat_global, only: Alfa, ATitle, BasOri, Beta, c_orbene, ChaNuc, Cont, CT, Dont, info_atom, iOrb, iPrint, iQang, iQn, & + iWoGehenC, iWoGehenQ, Joblab, lmax, mPrimus, MxAngqNr, MxSymQ, nBA_C, nBA_Q, nBonA_C, nBonA_Q, nCBoA_C, & + nCBoA_Q, nCnC_C, nPrimus, PotNuc, QmType, SavOri, Trans, V1, V3 +use qmstat_procedures, only: GiveMeInfo +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iQ_Atoms +integer(kind=iwp), intent(out) :: nAtomsCC, nBas(MxSymQ), nBasCC(1), nOcc(iQ_Atoms), natyp(iQ_Atoms), nntyp +real(kind=wp), intent(out) :: Coord(3,iQ_Atoms) +integer(kind=iwp) :: i, iAtom, iBas, icont, iDummy(1), iErr, iLu, ind, indold, iold, iWarn, ix, j, jnd, k, kk, kold, l, lLine, na, & + nnaa, nntypC, nSize, nSym, nSymCC, ntBas +real(kind=wp) :: ChgeCC(3), CoordCC(3*3), Dummy(1) +character(len=120) :: Line, StLine +character(len=100) :: OrbName, Title +character(len=10) :: WhatGet +integer(kind=iwp), allocatable :: iC_Icon(:,:), Icon(:,:), natypC(:), nfSh(:,:), nSh(:) +real(kind=wp), allocatable :: C(:,:), Chge(:), Cmo(:,:), Cmo_S(:), E(:,:), Occu(:), Oe(:), Tmp(:,:), TransC(:) +integer(kind=iwp), external :: IsFreeUnit +#include "warnings.h" + +!----------------------------------------------------------------------* +! Enter * +!----------------------------------------------------------------------* + +!----------------------------------------------------------------------* +! Print the joblabel. It is obtained in get_input * +!----------------------------------------------------------------------* +if (ATitle) then + lLine = len(Line) + do i=1,lLine + StLine(i:i) = '*' + end do + write(u6,*) + do i=1,6 + Line = '' + if ((i == 1) .or. (i == 6)) Line = StLine + if (i == 3) Line = 'Project:' + if (i == 4) write(Line,'(A72)') JobLab + call Center_Text(Line) + write(u6,*) '*'//Line//'*' + end do + write(u6,*) +end if +write(u6,*) 'Auxiliary data being read and pre-processed.' +!----------------------------------------------------------------------* +! Collect some data from RUNFILE about the QM-region molecule. * +!----------------------------------------------------------------------* +call Get_iScalar('nSym',nSym) +if (nSym /= 1) then !A minor restriction, no symmetry allowed, i.e. nSym=1. + write(u6,*) + write(u6,*) ' QmStat does not run with symmetry!' + write(u6,*) ' The perturbation from the solvent breaks all symmetry.' + call Quit(_RC_GENERAL_ERROR_) +end if +call Get_iScalar('Unique atoms',iQ_Atoms) +call mma_allocate(Chge,iQ_Atoms,label='Chge') +call Get_dArray('Nuclear charge',Chge,iQ_Atoms) +call Get_dArray('Unique Coordinates',Coord,3*iQ_Atoms) +call Get_dArray('Center of Mass',CT,3) +call Get_iArray('nBas',nBas,nSym) + +!----------------------------------------------------------------------* +! Print elementary information about molecule. * +!----------------------------------------------------------------------* +write(u6,*) +write(u6,*) ' ------------------------------' +write(u6,*) ' | QM-region data |' +write(u6,*) ' ------------------------------' +write(u6,*) +write(u6,'(A,15X,I5)') ' Number of basis functions:',(nBas(i),i=1,nSym) +write(u6,'(A,3F10.6)') ' Centre of mass =',(CT(kk),kk=1,3) +call PrCoor() + +!----------------------------------------------------------------------* +! If the Qmtype is SCF we now want the orbitals. On the other hand if * +! we are running RASSI, another route must be taken, hence here we * +! inquire which QM-method is used. * +!----------------------------------------------------------------------* +if (QmType(1:3) == 'SCF') then + !--------------------------------------------------------------------* + ! SSS CCC FFFFFF * + ! SS CC FF * + ! SS CC FFFF * + ! SS CC FF * + ! SSS CCC FF * + !--------------------------------------------------------------------* + + !--------------------------------------------------------------------* + ! Print information about orbitals and store coefficients in new * + ! variable. * + !--------------------------------------------------------------------* + iLu = 15 + iLu = IsFreeUnit(iLu) + write(OrbName,'(A)') 'AVEORB' + write(WhatGet,'(A)') 'CO' + iWarn = 1 + call mma_allocate(Cmo,nBas(1),nBas(1),label='Cmo') + call mma_allocate(Occu,nBas(1),label='Occu') + call RdVec(OrbName,iLu,WhatGet,nSym,nBas,nBas,Cmo,Occu,Dummy,iDummy,Title,iWarn,iErr) + if (iErr /= 0) then + write(u6,*) + write(u6,*) 'Error when reading AVEORB' + write(u6,*) + call Quit(_RC_IO_ERROR_READ_) + end if + call mma_allocate(V1,nBas(1),iOrb(1),label='OrbCoeffQ') + V1(:,:) = Cmo(:,1:iOrb(1)) + !write(u6,'(A,I4)') ' Number of Orbitals:',iOrb(1) + call Get_dScalar('PotNuc',PotNuc) + +else if (QmType(1:4) == 'RASS') then + !--------------------------------------------------------------------* + ! RRRR AA SSS SSS II * + ! RR R A A SS SS II * + ! RR R AAAAAA SS SS II * + ! RRR AA AA SS SS II * + ! RR R AA AA SSS SSS II * + !--------------------------------------------------------------------* + call TdmTrans(nBas) +end if +write(u6,*) +write(u6,*) +!----------------------------------------------------------------------* +! Compute various information about system. This we use for computing * +! integrals later. GiveMeInfo collects stuff from seward, sometime with* +! some recomputations. * +!----------------------------------------------------------------------* +call mma_allocate(nSh,iQ_Atoms,label='nSh') +call mma_allocate(nfSh,iQ_Atoms,MxAngqNr,label='nfSh') +call mma_allocate(nBA_Q,iQ_Atoms,label='nBA_Q') +call mma_allocate(nBonA_Q,iQ_Atoms,label='nBonA_Q') +call mma_allocate(nCBoA_Q,iQ_Atoms,MxAngqNr,label='nCBoA_Q') +call GiveMeInfo(nntyp,natyp,BasOri,Icon,nPrimus,nBA_Q,nCBoA_Q,nBonA_Q,E,C,nSh,nfSh,nSize,iPrint,iQ_Atoms,MxAngqNr,Trans,ntBas) +iBas = 0 +iAtom = 0 +kold = 1 +iold = 1 +indold = 0 +nOcc(1:nntyp) = 0 +call mma_allocate(alfa,ntBas,0,label='alfa') +call mma_allocate(cont,ntBas,0,label='cont') +call mma_allocate(iWoGehenQ,ntBas,2*MxAngqNr-1,label='iWoGehenQ') +call mma_allocate(iQang,ntBas,label='iQang') +do i=1,nntyp + na = natyp(i) + do j=1,na + ind = 0 + jnd = 0 + iAtom = iAtom+1 + ChaNuc(iAtom) = Chge(iAtom) + info_atom(iAtom) = int(Chge(iAtom)) + do k=1,nSh(i) + nnaa = nfSh(i,k) + do l=1,nnaa + ibas = ibas+1 + indold = indold+1 + nOcc(i) = nOcc(i)+2*k-1 + ind = ind+1 + iQang(ibas) = k + icont = Icon(i,ind) + !iCharOnBasQ(ibas) = int(Chge(iAtom)) + ! Here we construct an array of indices which is used to put right AO-overlap in right matrix pos. + do ix=1,2*k-1 + if (k /= kold) then + if (i /= iold) then + Indold = Indold+nfSh(iold,kold)*(2*kold-2) + iold = i + else + Indold = Indold+nfSh(i,kold)*(2*kold-2) + end if + kold = k + end if + iWoGehenQ(ibas,ix) = indold+nnaa*(ix-1) + end do + if (icont > size(cont,2)) then + call mma_allocate(Tmp,size(alfa,1),icont,label='Tmp') + Tmp(:,1:size(alfa,2)) = alfa + call mma_deallocate(alfa) + call move_alloc(Tmp,alfa) + call mma_allocate(Tmp,size(cont,1),icont,label='Tmp') + Tmp(:,1:size(cont,2)) = cont + call mma_deallocate(cont) + call move_alloc(Tmp,cont) + end if + alfa(ibas,1:icont) = E(i,jnd+1:jnd+icont) + cont(ibas,1:icont) = C(i,jnd+1:jnd+icont) + jnd = jnd+icont + end do + end do + end do +end do +! Now we do not need them, so deallocate +call mma_deallocate(Chge) +call mma_deallocate(Icon) +call mma_deallocate(E) +call mma_deallocate(C) + +!----------------------------------------------------------------------* +! Obtain and print information about solvent. This requires a renaming * +! of the runfile. * +!----------------------------------------------------------------------* +call NameRun('WRUNFIL') +call Get_iScalar('nSym',nSymCC) +if (nSymCC /= 1) then + write(u6,*) + write(u6,*) ' QmStat does not run with symmetry!' + call Quit(_RC_GENERAL_ERROR_) +end if +call Get_iScalar('Unique atoms',nAtomsCC) +if (nAtomsCC /= 3) then + write(u6,*) + write(u6,*) 'Now now... what strange solvent molecule do you try to feed QmStat with?' + call Quit(_RC_GENERAL_ERROR_) +end if +call Get_dArray('Nuclear charge',ChgeCC,nAtomsCC) +call Get_dArray('Unique Coordinates',CoordCC,3*nAtomsCC) +call Get_iArray('nBas',nBasCC,nSymCC) +write(u6,*) +write(u6,*) ' ------------------------------' +write(u6,*) ' | Solvent molecule data |' +write(u6,*) ' ------------------------------' +write(u6,*) +write(u6,'(A,15X,I5)') ' Number of basis functions:',(nBasCC(i),i=1,nSymCC) +call PrCoor() + +! Collect information about the solvent orbitals. + +iLu = IsFreeUnit(16) +write(OrbName,'(A)') 'SOLORB' +write(WhatGet,'(A)') 'CE' +iWarn = 1 +call mma_allocate(Oe,sum(nBasCC),label='OrbitalEnergy') +call mma_allocate(Cmo_S,nBasCC(1)**2,label='Cmo_S') +call RdVec(OrbName,iLu,WhatGet,nSymCC,nBasCC,nBasCC,Cmo_S,Dummy,Oe,iDummy,Title,iWarn,iErr) +call mma_allocate(c_orbene,iOrb(2),label='c_orbene') +c_orbene(1:iOrb(2)) = Oe(1:iOrb(2)) +call mma_deallocate(Oe) + +! We should not need two solvent orbital vectors, so this should +! be removed when the orbital rotation routine is fixed. + +call mma_allocate(V3,nBasCC(1),iOrb(2),label='V3') +do j=1,iOrb(2) + do k=1,nBasCC(1) + V3(k,j) = Cmo_S(k+(j-1)*nBasCC(1)) + end do +end do +call mma_deallocate(Cmo_S) +!write(u6,'(A,I4)') ' Number of Orbitals:',iOrb(2) +write(u6,*) +write(u6,*) +!----------------------------------------------------------------------* +! And now basis set information. * +!----------------------------------------------------------------------* +if (nAtomsCC /= iQ_Atoms) then + call mma_deallocate(nSh) + call mma_deallocate(nfSh) + call mma_allocate(nSh,nAtomsCC,label='nSh') + call mma_allocate(nfSh,nAtomsCC,MxAngqNr,label='nfSh') +end if +call mma_allocate(natypC,nAtomsCC,label='natypC') +call mma_allocate(nBA_C,nAtomsCC,label='nBA_C') +call mma_allocate(nBonA_C,nAtomsCC,label='nBonA_C') +call mma_allocate(nCBoA_C,nAtomsCC,MxAngqNr,label='nCBoA_C') +call GiveMeInfo(nntypC,natypC,SavOri,iC_Icon,mPrimus,nBA_C,nCBoA_C,nBonA_C,E,C,nSh,nfSh,nSize,iPrint,nAtomsCC,MxAngqNr,TransC,ntBas) +iBas = 0 +iAtom = 0 +kold = 1 +iold = 1 +indold = 0 +call mma_allocate(beta,ntBas,0,label='beta') +call mma_allocate(dont,ntBas,0,label='dont') +call mma_allocate(iWoGehenC,ntBas,2*MxAngqNr-1,label='iWoGehenC') +call mma_allocate(iQn,ntBas,label='iQn') +call mma_allocate(nCnC_C,ntBas,label='nCnC_C') +Lmax = ntBas +do i=1,nntypC !Like the corresponding thing above for the QM-region. + na = natypC(i) + do j=1,na + ind = 0 + jnd = 0 + iAtom = iAtom+1 + do k=1,nSh(i) + nnaa = nfSh(i,k) + do l=1,nnaa + ibas = ibas+1 + indold = indold+1 + nCnC_C(ibas) = nnaa + ind = ind+1 + iQn(ibas) = k + icont = iC_Icon(i,ind) + !iCharOnBasC(ibas) = int(ChgeCC(iAtom)) + ! Here we construct an array of indices which is used to put right AO-overlap in right matrix pos. + do ix=1,2*k-1 + if (k /= kold) then + if (i /= iold) then + Indold = Indold+nfSh(iold,kold)*(2*kold-2) + iold = i + else + Indold = Indold+nfSh(i,kold)*(2*kold-2) + end if + kold = k + end if + iWoGehenC(ibas,ix) = indold+nnaa*(ix-1) + end do + if (icont > size(dont,2)) then + call mma_allocate(Tmp,size(beta,1),icont,label='Tmp') + Tmp(:,1:size(beta,2)) = beta + call mma_deallocate(beta) + call move_alloc(Tmp,beta) + call mma_allocate(Tmp,size(dont,1),icont,label='Tmp') + Tmp(:,1:size(dont,2)) = dont + call mma_deallocate(dont) + call move_alloc(Tmp,dont) + end if + beta(ibas,1:icont) = E(i,jnd+1:jnd+icont) + dont(ibas,1:icont) = C(i,jnd+1:jnd+icont) + jnd = jnd+icont + end do + end do + end do +end do +if (size(TransC) > size(Trans)) then + call mma_deallocate(Trans) + call move_alloc(TransC,Trans) +else + call mma_deallocate(TransC) +end if +! Now we do not need them, so deallocate. +call mma_deallocate(natypC) +call mma_deallocate(nSh) +call mma_deallocate(nfSh) +call mma_deallocate(iC_Icon) +call mma_deallocate(E) +call mma_deallocate(C) + +!----------------------------------------------------------------------* +! The multipoles and the Hamiltonian matrix are radically different * +! between the QM-method alternatives, so once more an inquire. * +!----------------------------------------------------------------------* +call NameRun('RUNFILE') +if (QmType(1:3) == 'SCF') then + call ScfHandM(Cmo,nBas,iQ_Atoms,nOcc,natyp,nntyp,Occu) + call mma_deallocate(Cmo) + call mma_deallocate(Occu) +else if (QmType(1:4) == 'RASS') then + call RassiHandM(nBas,iQ_Atoms,nOcc,natyp,nntyp) +end if + +!----------------------------------------------------------------------* +! Here is the end. * +!----------------------------------------------------------------------* +return + +end subroutine Qfread diff -Nru openmolcas-22.02/src/qmstat/qm1.fh openmolcas-22.10/src/qmstat/qm1.fh --- openmolcas-22.02/src/qmstat/qm1.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/qm1.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,43 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -*--------------------------------------------------------------------* -* Common variables, unique for SCF. * -*--------------------------------------------------------------------* -* INTEGER: * -* -------- * -* iSupM - Pointer to the supermatrix. * -* iV1 - Pointer to MO-coefficients for QM-region* -* * -* REAL: * -* ----- * -* HHMat - The one-electron contribution to the * -* Hamiltonian. * -* outxyz - Coordinates of the MME-sites in the QM-mol. * -* Cha - The charges in the MME expansion. * -* DipMy - The dipoles in the MME expansion. * -* Quad - The quadrupoles in the MME expansion. * -* PotNuc - Nuclear repulsion. * -* DenCorrD - Density difference between HF and MP2. * -* Trace_MP2 - Trace to MP2-HF difference density. * -* * -* CHARACTER: * -* ---------- * -* * -* LOGICAL: * -* -------- * -* * -*--------------------------------------------------------------------* - - Common/ScfQMinte/iSupM,iV1 - - Common/ScfQmreal/HHMat(MxOT),outxyz(MxQCen,3),Cha(MxOT,MxQCen) - &,DipMy(MxOT,3,MxQCen),Quad(MxOt,6,MxQCen),PotNuc,FockM(MxOT) - &,DenCorrD(MxOT),Trace_MP2 diff -Nru openmolcas-22.02/src/qmstat/qm2.fh openmolcas-22.10/src/qmstat/qm2.fh --- openmolcas-22.02/src/qmstat/qm2.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/qm2.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,41 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -*----------------------------------------------------------------------* -* Variables to include for the Rassi-stuff. * -*----------------------------------------------------------------------* -* Integer: * -* -------- * -* nState - Number of contracted RASSI states. * -* ipRASOrb - Pointer to the RASSCF orbital coefficients. * -* ipRASOcc - Pointer to the RASSCF orbital occupation * -* numbers. * -* nWhichFile - An array to keep track of from which file the* -* i:th state comes from. * -* iBigT - Pointer to ALL Gamma-matrices. * -* nRedMO - Number of reduced MOs in reduced basis. * -* ipAvRed - Pointer to optional reduced MO-basis. * -* * -* Real: * -* ----- * -* HmatState - The Hamiltonian matrix. * -* HmatSOld - The stored Hamiltonian matrix. * -* RasCha - MME-charges. * -* RasDip - MME-dipoles. * -* RasQua - MME-quadrupoles. * -* outxyzRAS - The MME-centers for RASSI. * -*----------------------------------------------------------------------* - - Common/RassiQinte/nState,nStateRed,ipRASORB(MxJobs) - &,ipRASOcc(MxJobs),nWhichFile(MxState),iBigT,nRedMO,ipAvRed - - Common/RassiQreal/HmatState(MxStOT),RasCha(MxStOT,MxQCen) - &,RasDip(MxStOT,3,MxQCen),RasQua(MxStOT,6,MxQCen) - &,outxyzRAS(MxQCen,3),HmatSOld(MxStOT) diff -Nru openmolcas-22.02/src/qmstat/qmcom.fh openmolcas-22.10/src/qmstat/qmcom.fh --- openmolcas-22.02/src/qmstat/qmcom.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/qmcom.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -*----------------------------------------------------------------------* -* Common variables shared by all QmTypes. -*----------------------------------------------------------------------* -* INTEGER: -* -------- -* lMax - How many bases in solvent region. -* info_atom - Atomic number of QM atoms. -* -* REAL: -* ------ -* QIm - Vector of charges of the imagepoints. -* CordIm - Coordinates of the imagepoints. -* QImp - Image charge due to dipole in cavity. -* Dim - Image dipole due to dipole in cavity. -* c_orbene - Solvent orbital energies. -* ChaNuc - Nuclear charges. -* qTot - Total charge on QM molecule. -* xyzMyQ - Total dipole of QM-region. -* xyzMyI - The induced dipole of QM-region. -* xyzMyP - Total dipole of the explicit solvent. -* xyzQuQ - Total traceless quadrupole moment of QM-region. -* CT - Centre of mass for QM-molecule. -*----------------------------------------------------------------------* - Common/AllQmTypesI/lmax,info_atom(MxAt) - - Common/AllQmTypesR/QIm(MxCen*MxPut),CordIm(MxCen*MxPut,3) - &,QImp(MxCen*MxPut),Dim(MxCen*MxPut,3) - &,c_orbene(MxOrb_C),ChaNuc(MxAt),qTot,xyzMyQ(3),xyzMyI(3),xyzMyP(3) - &,Sqrs(MxPut*MxCen),CT(3),xyzQuQ(6) diff -Nru openmolcas-22.02/src/qmstat/qminp.fh openmolcas-22.10/src/qmstat/qminp.fh --- openmolcas-22.02/src/qmstat/qminp.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/qminp.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -*----------------------------------------------------------------------* -* Common variables for qm-part. * -*----------------------------------------------------------------------* -* - Common/QMinte/iOrb(3),iOcc1,nPart,nAtom,nCent - &,nPol,nCha,iExtra,Inter,iPrint,iRead,iSta,itMax - &,iNrIn,iNrUt,NrStarti,NrStartu,nDel,NrFiles - &,NrStates(MxState),nEqState,iSeed,nMacro,nMicro,nAdd,iNrExtr - &,nExtAddOns,nTemp,nStFilT(MxParT),iCompExt(MxExtAddOn) - &,nLvlShift,iLvlShift(MxState),nCIRef,iCIInd(MxState) - &,iExtr_Eig,iExtr_Atm(MxAt) - &,nSlSiteC,lMltSlC,nMlt !Jose. Penetration using Slater - !determinants. nMlt=order of QM - !Mutipoles+1 - - Common/QMreal/rStart,Diel,Qsta(MxCha),Pol(MxPol) - &,SexRep(MxAt,MxAt),SexRe1(MxAt,MxAt),SexRe2(MxAt,MxAt) - &,Disp(MxPol,MxPol),Cordst(MxCen*MxPut,3) - &,OldGeo(MxCen*MxPut,3) - &,Udisp(MxAt,MxCen),Exrep2,Exrep4,Exrep6,Exrep10 - &,CharDi(MxCen),QuaDi(3,MxCen) - &,CharDiQ(MxAt),QuadiQ(3,MxAt) - &,CAFieldG,CBFieldG,DelX,DelFi,DelR,Forcek,dLJrep,Temp,Pres,Surf - &,CFexp,Pollim,Enelim,Exdtal,Exdt1,Cut_Ex1,Cut_Ex2,AlphaD - &,RasEne(MxState),ScalExt(MxExtAddOn),ParaTemps(MxParT),ThrsRedOcc - &,ThrsCont,dLvlShift(MxState),dCIRef(MxState) -* Jose. Penetration using Slater functions. Classical system is up to dipole, -* so there is 4 Factors and 2 exponents. - &,SlFactC(4,MxCen),SlExpC(2,MxCen),SlPC(MxCen),Cut_Elc,DifSlExp - $,SlExpQ(MxMltp+1,MxQCen) -* JoseMEP. The new arrays AvElcPot and PertNElcInt are included - &,AvElcPot(MxQCen,10),PertNElcInt(MxBas*(MxBas+1)/2) - - Character JobLab*100,QmType*20,ExtLabel*8,cDumpForm*10 - Common/QMchar/JobLab,QmType,ExtLabel(MxExtAddOn),cDumpForm - - Logical Smeq,Qmeq,Fielddamp,Dispdamp,SmProd,QmProd - &,EdSt,ChargedQM,DelOrAdd(12),ATitle - &,Anal,AddExt,SingPoint,ParallelT,Mp2DensCorr -* JoseMEP. The dimension was increased from 8 to 12 also in DelOrAdd - &,MoAveRed,ContrStateB,lCiSelect,lExtr(12),lAnal(12) - &,lSlater,lQuad ! Jose. Penetration using Slater. - Common/QMlogi/Smeq,Qmeq,Fielddamp,Dispdamp,SmProd,QmProd - &,EdSt,ChargedQM,DelOrAdd,ATitle - &,Anal,AddExt,SingPoint,ParallelT,Mp2DensCorr - &,MoAveRed,ContrStateB,lCiSelect,lExtr,lAnal,lSlater,lQuad diff -Nru openmolcas-22.02/src/qmstat/qmposition.f openmolcas-22.10/src/qmstat/qmposition.f --- openmolcas-22.02/src/qmstat/qmposition.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/qmposition.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine QMPosition(EHam,Cordst,Coord,Forcek - & ,dLJrep,Ract,iQ_Atoms) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" - - Dimension Cordst(MxCen*MxPut,3),Coord(MxAt*3) - -* -*-- First the harmonic potential that keeps QM close to centre. -* - dDepart=(Cordst(1,1)-Coord(1))**2 - & +(Cordst(1,2)-Coord(2))**2 - & +(Cordst(1,3)-Coord(3))**2 - EHam=Forcek*0.5d0*dDepart - -* -*-- Second the repulsion with boundary that keeps QM away from -* boundary. -* - Do 901, iAt=1,iQ_Atoms - R=Cordst(iAt,1)**2+Cordst(iAt,2)**2+Cordst(iAt,3)**2 - R=sqrt(R) - Diff=Ract-R - EHam=EHam+(dLJRep/Diff)**12 -901 Continue - - Return - End diff -Nru openmolcas-22.02/src/qmstat/qmposition.F90 openmolcas-22.10/src/qmstat/qmposition.F90 --- openmolcas-22.02/src/qmstat/qmposition.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/qmposition.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,40 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine QMPosition(EHam,Cordst,Coord,Forcek,dLJrep,Ract,iQ_Atoms) + +use Constants, only: Half +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(out) :: EHam +integer(kind=iwp), intent(in) :: iQ_Atoms +real(kind=wp), intent(in) :: Cordst(3,iQ_Atoms), Coord(3), Forcek, dLJrep, Ract +integer(kind=iwp) :: iAt +real(kind=wp) :: dDepart, Diff, R + +! First the harmonic potential that keeps QM close to centre. + +dDepart = (Cordst(1,1)-Coord(1))**2+(Cordst(2,1)-Coord(2))**2+(Cordst(3,1)-Coord(3))**2 +EHam = Forcek*Half*dDepart + +! Second the repulsion with boundary that keeps QM away from boundary. + +do iAt=1,iQ_Atoms + R = Cordst(1,iAt)**2+Cordst(2,iAt)**2+Cordst(3,iAt)**2 + R = sqrt(R) + Diff = Ract-R + EHam = EHam+(dLJRep/Diff)**12 +end do + +return + +end subroutine QMPosition diff -Nru openmolcas-22.02/src/qmstat/qmstat.f openmolcas-22.10/src/qmstat/qmstat.f --- openmolcas-22.02/src/qmstat/qmstat.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/qmstat.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,182 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Qmstat(ireturn) -#ifdef _MOLCAS_MPP_ - Use Para_Info, Only: Is_Real_Par -#endif - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "WrkSpc.fh" -#include "warnings.h" - - Dimension Coord(MxAt*3) - Dimension nBas(1),nBas_C(1),nCnC_C(MxBasC) -*******JoseMEP New variables to perform the MEP calculation - Dimension Eint(MxQCen,10),Poli(MxQCen,10) - Dimension SumElcPot(MxQCen,10) - Dimension PertElcInt(MxBas*(MxBas+1)/2) - Dimension nOcc(MxBas),natyp(MxAt) - Character Labjhr*4 -**************** - -* -*-- The journey begins. Set non-zero return code. -* - ireturn=99 - -* -*-- If parallel compilation, terminate, but gracefully. -* -#ifdef _MOLCAS_MPP_ - If (Is_Real_Par()) Then - Write(6,*) - Write(6,*)' QMStat does not run in parallel!' - Write(6,*) - Call Quit(_RC_NOT_AVAILABLE_) - End If -#endif - -* -*-- Set defaults, zeros and initial values. -* - Call Qmstat_init - -* -*-- Make discrete banner. -* - -* -*-- Read ('process') input. To do that we need the number of atoms in -* the QM-region, therefore that initial call to the RUNFILE. -* - Call Get_iScalar('Unique atoms',iQ_Atoms) - Call Get_Qmstat_Input(iQ_Atoms) - -* -*-- If only the startfile is to be edited or the sampfile analyzed, -* go here, then terminate. -* - If(EdSt) then - Call EditStart - Go To 666 - Endif - If(Anal) then - Call Analyze_Q(iQ_Atoms) - Go To 666 - Endif - -* -*-- Read in orbitals, basis functions, integrals and bla bla bla. This -* is the centre for communicating with the rest of Molcas. -* -*******JoseMEP*** Qfread is called with more variables to the MEP calculation - Call Qfread(iQ_Atoms,nAtomsCC,Coord,nBas,nBas_C,nCnC_C - &,nOcc,natyp,nntyp) -******** - -* -*-- The turning point for the single-point calculation. -* - nCalls=0 -3333 Continue - -* -*-- If user request a set of single point calcualtions, then go in to -* a separate routine and do a 'reintrepreation' of the input. -* - If(SingPoint) Call SingP(nCalls,iQ_Atoms,ipStoreCoo,nPart2) - -* -*-- Decide which type of calculation we are to run. At this stage only -* QM equilibration and QM production is available. Should probably -* be so in the future, hence all-classical should be removed -* at some stage. Also, ordinary sampfile analysis is performed -* seperately. -* - If(Smeq.or.Smprod) then - Write(6,*) - Write(6,*)'All classical simulation is currently not available.' - Call Quit(_RC_GENERAL_ERROR_) - Elseif(Qmeq.or.Qmprod) then !Qmeq=.true. is default option. - If(QmType(1:3).eq.'SCF') then - Call EqScf(iQ_Atoms,nAtomsCC,Coord,nBas,nBas_C,nCnC_C - & ,iSupDeAll,iV1DeAll) - Elseif(QmType(1:4).eq.'RASS') then - Call EqRas(iQ_Atoms,nAtomsCC,Coord,nBas,nBas_C,nCnC_C - & ,iBigDeAll,nSizeBig,ip,nRM) - Endif - Endif -* -*********JoseMEP -* If MEP option true. Calculate the Interaction energy coming from the -* Interaction with Mean Elec. Potential, Field and Field-Gradient -* E=q*Pot-dipol*field+quad*field-grad -* Also is included the non_Electr perturbation -* For a quantum AO i nonE=d*Sum_k <Xi|Chi_k>*Sum_k <Xi|Chi_k>*E_k -* These Energies are added to the SEWARD One-electron file -* as a perturbation to the One-e Hamiltoniam -* - If(lExtr(8)) then - Labjhr='Pert' - Call AverMEP(Labjhr,Eint,Poli,iCi,SumElcPot - & ,NCountField,PertElcInt - & ,iQ_Atoms,nBas(1),nOcc(1),natyp(1),nntyp) - Endif -********* -* -*-- If we are doing single point calculations, then jump back up. -* - If(SingPoint) then - If(nCalls.lt.nPart2) then - Write(6,*) - Write(6,*) - Write(6,*) - Write(6,*)' *********** << NEW CALCULATION >> ***********' - Write(6,'(A,I3,A)')'Single point-calculation nr.',nCalls+1,' ' - &//'follows below.' - Write(6,*) - Write(6,*) - Go To 3333 - Else - Call GetMem('Store','Free','Real',ipStoreCoo,nPart2*nCent*3) - Write(6,*) - Write(6,*) - Write(6,*)' Single-point calculation ended.' - Write(6,*) - Endif - Endif - -* -*-- Deallocations of stuff from qfread to simulations. These are unique -* for the QM-method. -* - If(QmType(1:4).eq.'RASS') then - Call GetMem('ALLES','Free','Real',iBigDeAll,nSizeBig) - If(MoAveRed) then - Call GetMem('UncleMoe','Free','Real',ip,nBas(1)*nRM) - Endif - Elseif(QmType(1:3).eq.'SCF') then - nS=iOrb(1)*(iOrb(1)+1)/2 - Call GetMem('SUPER','Free','Real',iSupDeAll,nS**2) - Call GetMem('OrbCoeffQ','Free','Real',iV1DeAll,iOrb(1)*nBas(1)) - Endif - -* -*-- Exit -* -666 Continue - - ireturn=0 - - Return - End diff -Nru openmolcas-22.02/src/qmstat/qmstat.F90 openmolcas-22.10/src/qmstat/qmstat.F90 --- openmolcas-22.02/src/qmstat/qmstat.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/qmstat.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,218 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Qmstat(ireturn) + +use qmstat_global, only: Anal, AvRed, BasOri, BigT, CasOri, ChaNuc, Cordst, DipIm, EdSt, info_atom, iQang, iQn, iWoGehenC, & + iWoGehenQ, lExtr, MoAveRed, mPrimus, MxPut, nBA_C, nBA_Q, nBonA_C, nBonA_Q, nCBoA_C, nCBoA_Q, nCent, & + nCnC_C, nPart, nPol, nPrimus, OldGeo, PertNElcInt, QIm, QImp, Qmeq, QmProd, Qmstat_end, QmType, SavOri, & + SingPoint, Sqrs, SupM, Trans, Udisp, V1 +#ifdef _MOLCAS_MPP_ +use Para_Info, only: Is_Real_Par +#endif +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(out) :: ireturn +integer(kind=iwp) :: iCi, iQ_Atoms, nAtomsCC, nBas(1), nBas_C(1), nCalls, NCountField, nntyp +character(len=4) :: Labjhr +integer(kind=iwp), allocatable :: natyp(:), nOcc(:) +real(kind=wp), allocatable :: Coord(:,:), Eint(:,:), PertElcInt(:), Poli(:,:), StoreCoo(:,:,:), SumElcPot(:,:) +#include "warnings.h" +!******JoseMEP New variables to perform the MEP calculation +!Eint, Poli, SumElcPot, PertElcInt, nOcc, natyp, Labjhr + +! The journey begins. Set non-zero return code. + +ireturn = 99 + +! If parallel compilation, terminate, but gracefully. + +#ifdef _MOLCAS_MPP_ +if (Is_Real_Par()) then + write(u6,*) + write(u6,*) ' QMStat does not run in parallel!' + write(u6,*) + call Quit(_RC_NOT_AVAILABLE_) +end if +#endif + +! Set defaults, zeros and initial values. + +call Qmstat_init() + +! Make discrete banner. + +! Read ('process') input. To do that we need the number of atoms in +! the QM-region, therefore that initial call to the RUNFILE. + +call Get_iScalar('Unique atoms',iQ_Atoms) +call mma_allocate(info_atom,iQ_Atoms,label='info_atom') +call mma_allocate(ChaNuc,iQ_Atoms,label='ChaNuc') +call mma_allocate(Udisp,2,iQ_Atoms,label='Udisp') +uDisp(:,:) = Zero +call Get_Qmstat_Input(iQ_Atoms) + +! If only the startfile is to be edited or the sampfile analyzed, go here, then terminate. + +if (EdSt) then + + call EditStart() + +else if (Anal) then + + call Analyze_Q(iQ_Atoms) + +else + + ! Read in orbitals, basis functions, integrals and bla bla bla. This + ! is the centre for communicating with the rest of Molcas. + + call mma_allocate(Coord,3,iQ_Atoms,label='Coord') + call mma_allocate(nOcc,iQ_Atoms,label='nOcc') + call mma_allocate(natyp,iQ_Atoms,label='natyp') + + !******JoseMEP*** Qfread is called with more variables to the MEP calculation + call Qfread(iQ_Atoms,nAtomsCC,Coord,nBas,nBas_C,nOcc,natyp,nntyp) + !******* + + call mma_allocate(PertElcInt,nTri_Elem(nBas(1)),label='PertElcInt') + call mma_allocate(Eint,nTri_Elem(iQ_Atoms),10,label='Eint') + call mma_allocate(Poli,nTri_Elem(iQ_Atoms),10,label='Poli') + call mma_allocate(SumElcPot,nTri_Elem(iQ_Atoms),10,label='SumElcPot') + call mma_allocate(OldGeo,3,size(Cordst,2),label='OldGeo') + call mma_allocate(DipIm,3,MxPut*max(nCent,nPol),label='DipIm') + call mma_allocate(QIm,MxPut*nCent,label='QIm') + call mma_allocate(QImp,MxPut*max(nCent,nPol),label='QImp') + call mma_allocate(Sqrs,MxPut*nCent,label='Sqrs') + call mma_allocate(PertNElcInt,nTri_Elem(nBas(1)),label='PertNElcInt') + call mma_allocate(CasOri,3,size(SavOri,2),label='CasOri') + + ! The turning point for the single-point calculation. + + nCalls = 0 + do + + ! If user request a set of single point calculations, then go in to + ! a separate routine and do a 'reintrepretation' of the input. + + if (SingPoint) then + if (nCalls == 0) call mma_allocate(StoreCoo,3,nCent,nPart,label='Store') + call SingP(nCalls,iQ_Atoms,StoreCoo) + end if + + ! Decide which type of calculation we are to run. At this stage only + ! QM equilibration and QM production is available. + ! Also, ordinary sampfile analysis is performed separately. + + if (Qmeq .or. Qmprod) then !Qmeq=.true. is default option. + if (QmType(1:3) == 'SCF') then + call EqScf(iQ_Atoms,nAtomsCC,Coord,nBas,nBas_C) + else if (QmType(1:4) == 'RASS') then + call EqRas(iQ_Atoms,nAtomsCC,Coord,nBas,nBas_C) + end if + end if + + !********JoseMEP + ! If MEP option true. Calculate the Interaction energy coming from the + ! Interaction with Mean Elec. Potential, Field and Field-Gradient + ! E=q*Pot-dipol*field+quad*field-grad + ! Also is included the non_Electr perturbation + ! For a quantum AO i nonE=d*Sum_k <Xi|Chi_k>*Sum_k <Xi|Chi_k>*E_k + ! These Energies are added to the SEWARD One-electron file + ! as a perturbation to the One-e Hamiltoniam + + if (lExtr(8)) then + Labjhr = 'Pert' + call AverMEP(Labjhr,Eint,Poli,iCi,SumElcPot,NCountField,PertElcInt,iQ_Atoms,nBas(1),nOcc,natyp,nntyp) + end if + !******** + + ! If we are doing single point calculations, then jump back up. + + if (.not. SingPoint) exit + if (nCalls < size(StoreCoo,3)) then + write(u6,*) + write(u6,*) + write(u6,*) + write(u6,*) ' *********** << NEW CALCULATION >> ***********' + write(u6,'(A,I3,A)') 'Single point-calculation nr.',nCalls+1,' follows below.' + write(u6,*) + write(u6,*) + else + call mma_deallocate(StoreCoo) + write(u6,*) + write(u6,*) + write(u6,*) ' Single-point calculation ended.' + write(u6,*) + exit + end if + end do + + call mma_deallocate(Coord) + call mma_deallocate(nOcc) + call mma_deallocate(natyp) + call mma_deallocate(Eint) + call mma_deallocate(Poli) + call mma_deallocate(SumElcPot) + call mma_deallocate(PertElcInt) + call mma_deallocate(OldGeo) + call mma_deallocate(DipIm) + call mma_deallocate(QIm) + call mma_deallocate(QImp) + call mma_deallocate(Sqrs) + call mma_deallocate(PertNElcInt) + call mma_deallocate(CasOri) + call mma_deallocate(nBA_C) + call mma_deallocate(nBA_Q) + call mma_deallocate(nBonA_C) + call mma_deallocate(nBonA_Q) + call mma_deallocate(nCBoA_C) + call mma_deallocate(nCBoA_Q) + call mma_deallocate(nCnC_C) + call mma_deallocate(iWoGehenC) + call mma_deallocate(iWoGehenQ) + call mma_deallocate(iQn) + call mma_deallocate(iQang) + call mma_deallocate(BasOri) + call mma_deallocate(SavOri) + call mma_deallocate(mPrimus) + call mma_deallocate(nPrimus) + call mma_deallocate(Trans) + + ! Deallocations of stuff from qfread to simulations. These are unique for the QM-method. + + if (QmType(1:4) == 'RASS') then + call mma_deallocate(BigT) + if (MoAveRed) call mma_deallocate(AvRed) + else if (QmType(1:3) == 'SCF') then + call mma_deallocate(SupM) + call mma_deallocate(V1) + end if + +end if + +call mma_deallocate(info_atom) +call mma_deallocate(ChaNuc) +call mma_deallocate(Udisp) + +! Exit + +call Qmstat_end() + +ireturn = 0 + +return + +end subroutine Qmstat diff -Nru openmolcas-22.02/src/qmstat/qmstat_global.F90 openmolcas-22.10/src/qmstat/qmstat_global.F90 --- openmolcas-22.02/src/qmstat/qmstat_global.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/qmstat_global.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,228 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +module qmstat_global + +use Definitions, only: wp, iwp + +implicit none +private + +!----------------------------------------------------------------------* +! Define some bounds for qmstat. +!----------------------------------------------------------------------* +! MxAngqNr - Maximal angular quantum number for basis +! functions in QM-region. 1 is s, 2 is p etc. +! MxMltp - Highest order multipole in MME +! MxPut - Maximal number of molecules to put in system +! MxSymQ - Maximal number of symmetries +!----------------------------------------------------------------------* + +!----------------------------------------------------------------------* +! Common variables shared by all QmTypes. +!----------------------------------------------------------------------* +! INTEGER: +! -------- +! lMax - How many bases in solvent region. +! info_atom - Atomic number of QM atoms. +! +! REAL: +! ----- +! QIm - Vector of charges of the imagepoints. +! CordIm - Coordinates of the imagepoints. +! QImp - Image charge due to dipole in cavity. +! DipIm - Image dipole due to dipole in cavity. +! c_orbene - Solvent orbital energies. +! ChaNuc - Nuclear charges. +! qTot - Total charge on QM molecule. +! xyzMyQ - Total dipole of QM-region. +! xyzMyI - The induced dipole of QM-region. +! xyzMyP - Total dipole of the explicit solvent. +! xyzQuQ - Total traceless quadrupole moment of QM-region. +! CT - Centre of mass for QM-molecule. +!----------------------------------------------------------------------* + +!----------------------------------------------------------------------* +! Common variables, unique for SCF. +!----------------------------------------------------------------------* +! INTEGER: +! -------- +! SupM - The supermatrix. +! V1 - MO-coefficients for QM-region. +! +! REAL: +! ----- +! HHMat - The one-electron contribution to the Hamiltonian. +! outxyz - Coordinates of the MME-sites in the QM-mol. +! Cha - The charges in the MME expansion. +! DipMy - The dipoles in the MME expansion. +! Quad - The quadrupoles in the MME expansion. +! PotNuc - Nuclear repulsion. +! DenCorrD - Density difference between HF and MP2. +! Trace_MP2 - Trace to MP2-HF difference density. +!----------------------------------------------------------------------* + +!----------------------------------------------------------------------* +! Variables to include for the Rassi-stuff. +!----------------------------------------------------------------------* +! INTEGER: +! -------- +! nState - Number of contracted RASSI states. +! BigT - ALL Gamma-matrices. +! nRedMO - Number of reduced MOs in reduced basis. +! AvRed - Optional reduced MO-basis. +! +! REAL: +! ----- +! HmatState - The Hamiltonian matrix. +! HmatSOld - The stored Hamiltonian matrix. +! RasCha - MME-charges. +! RasDip - MME-dipoles. +! RasQua - MME-quadrupoles. +! outxyzRAS - The MME-centers for RASSI. +!----------------------------------------------------------------------* + +!----------------------------------------------------------------------* +! iQn - Array that specifies the angular momentum +! quantum number for each basis function on +! solvent molecules. +! iQang - Like iQn, but for QM-region. +! nPrimus - Actually a rewriting of Icon. +! mPrimus - Like nPrim but for solvent. +! iWoGehenQ - The (ith,jth) element tells which index the +! ith QM-region base (not basis-function) of +! the jth m_l-quantum number is to take. +! Needed when ordering the AO-overlaps. +! iWoGehenC - Like iWoGehenQ but for solvent molecule. +! nBonA_Q - Number of basis functions on atoms in QM. +! nBonA_C - Like nBonA_Q but for solvent molecule. +! CasOri - Array with coordinates for each basis +! function for solvent molecules. +! SavOri - Initially like CasOri, but not overwritten. +! BasOri - Like CasOri, but for QM-region. +! Alfa - Basis exponents. +! Beta - Like Alfa but for solvent. +! Cont - Contraction coefficients for QM-region. +! Dont - Like Cont but for solvent. +! V3 - Original solvent MOs. +! Trans - Cartesian to spherical transformation. +!----------------------------------------------------------------------* + +integer(kind=iwp), parameter :: MxAngqNr = 7, MxMltp = 3, MxPut = 220, MxSymQ = 1 + +integer(kind=iwp) :: iExtr_Eig, iExtra, iLuSaIn, iLuSaUt, iLuStIn, iLuStUt, iNrIn, iNrUt, Inter, iOcc1, iOrb(3), iPrint, iRead, & + iSeed, iSta, iTcSim(64), itMax, lmax, lMltSlC, nAdd, nAtom, nCent, nCha, nCIRef, nDel, nEqState, nExtAddOns, & + nLvlShift, nMacro, nMicro, nMlt, nPart, nPol, nRedMO, NrFiles, NrStarti, NrStartu, nSlSiteC, nState, nTemp +real(kind=wp) :: CAFieldG, CBFieldG, CFexp, CharDi(2), CT(3), Cut_Elc, Cut_Ex1, Cut_Ex2, DelFi, DelR, DelX, Diel, DifSlExp, & + dLJrep, Enelim, Exdt1, Exdtal, Exrep10, Exrep2, Exrep4, Exrep6, Forcek, Pollim, PotNuc, Pres, qTot, QuaDi(3,2), & + rStart, Surf, Temp, ThrsCont, ThrsRedOcc, Trace_MP2, xyzMyI(3), xyzMyP(3), xyzMyQ(3), xyzQuQ(6) +logical(kind=iwp) :: AddExt, Anal, ATitle, ChargedQM, ContrStateB, DelOrAdd(12), DispDamp, EdSt, FieldDamp, lCiSelect, lExtr(12), & + lQuad, lSlater, MoAveRed, Mp2DensCorr, ParallelT, Qmeq, QmProd, SingPoint +character(len=100) :: JobLab +character(len=10) :: cDumpForm +character(len=6) :: StFilIn, SaFilIn, StFilUt, SaFilUt, FieldNuc, SimEx, RassiM, EigV, QmType +integer(kind=iwp), allocatable :: iCIInd(:), iCompExt(:), iExtr_Atm(:), iLvlShift(:), info_atom(:), iQang(:), iQn(:), & + iWoGehenC(:,:), iWoGehenQ(:,:), mPrimus(:), nPrimus(:), nBA_C(:), nBA_Q(:), nBonA_C(:), & + nBonA_Q(:), nCBoA_C(:,:), nCBoA_Q(:,:), nCnC_C(:), NrStates(:), nStFilT(:) +real(kind=wp), allocatable :: Alfa(:,:), AvElcPot(:,:), AvRed(:,:), BasOri(:,:), Beta(:,:), BigT(:,:), c_orbene(:), CasOri(:,:), & + Cha(:,:), ChaNuc(:), CharDiQ(:), Cont(:,:), CordIm(:,:), Cordst(:,:), dCIRef(:), DenCorrD(:), & + DipIm(:,:), DipMy(:,:,:), Disp(:,:), dLvlShift(:), Dont(:,:), FockM(:), HHmat(:), HmatSOld(:), & + HmatState(:), OldGeo(:,:), outxyz(:,:), outxyzRAS(:,:), Paratemps(:), PertNElcInt(:), Pol(:), & + QIm(:), QImp(:), Qsta(:), Quad(:,:,:), QuaDiQ(:,:), RasCha(:,:), RasDip(:,:,:), RasQua(:,:,:), & + SavOri(:,:), ScalExt(:), Sexre1(:,:), Sexre2(:,:), Sexrep(:,:), SlExpC(:,:), SlExpQ(:,:), & + SlFactC(:,:), SlPC(:), Sqrs(:), SupM(:,:), Trans(:), Udisp(:,:), V1(:,:), V3(:,:) +character(len=8), allocatable :: ExtLabel(:) + +public :: AddExt, Alfa, Anal, ATitle, AvElcPot, AvRed, BasOri, Beta, BigT, c_orbene, CAFieldG, CasOri, CBFieldG, cDumpForm, CFexp, & + Cha, ChaNuc, CharDi, CharDiQ, ChargedQM, Cont, ContrStateB, CordIm, Cordst, CT, Cut_Elc, Cut_Ex1, Cut_Ex2, dCIRef, & + DelFi, DelOrAdd, DelR, DelX, DenCorrD, Diel, DifSlExp, DipIm, DipMy, Disp, DispDamp, dLJrep, dLvlShift, Dont, EdSt, & + EigV, Enelim, Exdt1, Exdtal, Exrep10, Exrep2, Exrep4, Exrep6, ExtLabel, FieldDamp, FieldNuc, FockM, Forcek, HHMat, & + HmatSOld, HmatState, iCIInd, iCompExt, iExtr_Atm, iExtr_Eig, iExtra, iLuSaIn, iLuSaUt, iLuStIn, iLuStUt, iLvlShift, & + info_atom, iNrIn, iNrUt, Inter, iOcc1, iOrb, iPrint, iQang, iQn, iRead, iSeed, iSta, iTcSim, itMax, iWoGehenC, & + iWoGehenQ, JobLab, lCiSelect, lExtr, lmax, lMltSlC, lQuad, lSlater, MoAveRed, Mp2DensCorr, mPrimus, MxAngqNr, MxMltp, & + MxPut, MxSymQ, nAdd, nAtom, nBA_C, nBA_Q, nBonA_C, nBonA_Q, nCBoA_C, nCBoA_Q, nCent, nCha, nCIRef, nCnC_C, nDel, & + nEqState, nExtAddOns, nLvlShift, nMacro, nMicro, nMlt, nPart, nPol, nPrimus, nRedMO, NrFiles, NrStarti, NrStartu, & + NrStates, nSlSiteC, nState, nStFilT, nTemp, OldGeo, outxyz, outxyzRAS, ParallelT, ParaTemps, PertNElcInt, Pol, Pollim, & + PotNuc, Pres, QIm, QImp, Qmeq, QmProd, Qmstat_end, QmType, Qsta, qTot, Quad, QuaDi, QuaDiQ, RasCha, RasDip, RasQua, & + RassiM, rStart, SaFilIn, SaFilUt, SavOri, ScalExt, SexRe1, SexRe2, SexRep, SimEx, SingPoint, SlExpC, SlExpQ, SlFactC, & + SlPC, Sqrs, StFilIn, StFilUt, SupM, Surf, Temp, ThrsCont, ThrsRedOcc, Trace_MP2, Trans, Udisp, V1, V3, xyzMyI, xyzMyP, & + xyzMyQ, xyzQuQ + +contains + +subroutine Qmstat_end() + + use stdalloc, only: mma_deallocate + + if (lCiSelect) then + call mma_deallocate(iCIInd) + call mma_deallocate(dCIRef) + end if + + if (nLvlShift > 0) then + call mma_deallocate(iLvlShift) + call mma_deallocate(dLvlShift) + end if + + if (AddExt) then + call mma_deallocate(ScalExt) + call mma_deallocate(ExtLabel) + call mma_deallocate(iCompExt) + end if + + if (ParallelT) then + call mma_deallocate(nStFilT) + end if + + if (DispDamp) then + call mma_deallocate(CharDiQ) + call mma_deallocate(QuaDiQ) + end if + + if (allocated(Alfa)) call mma_deallocate(Alfa) + if (allocated(AvElcPot)) call mma_deallocate(AvElcPot) + if (allocated(Beta)) call mma_deallocate(Beta) + if (allocated(c_orbene)) call mma_deallocate(c_orbene) + if (allocated(Cha)) call mma_deallocate(Cha) + if (allocated(Cont)) call mma_deallocate(Cont) + if (allocated(CordIm)) call mma_deallocate(CordIm) + if (allocated(DenCorrD)) call mma_deallocate(DenCorrD) + if (allocated(DipMy)) call mma_deallocate(DipMy) + if (allocated(Dont)) call mma_deallocate(Dont) + if (allocated(HHmat)) call mma_deallocate(HHmat) + if (allocated(HmatSOld)) call mma_deallocate(HmatSOld) + if (allocated(HmatState)) call mma_deallocate(HmatState) + if (allocated(NrStates)) call mma_deallocate(NrStates) + if (allocated(outxyz)) call mma_deallocate(outxyz) + if (allocated(outxyzRAS)) call mma_deallocate(outxyzRAS) + if (allocated(Quad)) call mma_deallocate(Quad) + if (allocated(RasCha)) call mma_deallocate(RasCha) + if (allocated(RasDip)) call mma_deallocate(RasDip) + if (allocated(RasQua)) call mma_deallocate(RasQua) + if (allocated(SlExpQ)) call mma_deallocate(SlExpQ) + if (allocated(Udisp)) call mma_deallocate(Udisp) + if (allocated(V3)) call mma_deallocate(V3) + + call mma_deallocate(Cordst) + call mma_deallocate(Disp) + call mma_deallocate(iExtr_Atm) + call mma_deallocate(Pol) + call mma_deallocate(Qsta) + call mma_deallocate(Sexre1) + call mma_deallocate(Sexre2) + call mma_deallocate(Sexrep) + call mma_deallocate(SlExpC) + call mma_deallocate(SlFactC) + call mma_deallocate(SlPC) + +end subroutine Qmstat_end + +end module qmstat_global diff -Nru openmolcas-22.02/src/qmstat/qmstat_init.f openmolcas-22.10/src/qmstat/qmstat_init.f --- openmolcas-22.02/src/qmstat/qmstat_init.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/qmstat_init.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,196 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -* -*-- Subroutine with purpose to initialize and set defaults for the -* input section. -* - Subroutine Qmstat_Init - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "files_qmstat.fh" - -*IO_stuff - StFilIn='STFIL0' - SAFilIn='SAFIL0' - StFilUt='STFIL0' - SAFilUt='SAFIL0' - BlockIn='BLOCIN' - BlockUt='BLOCUT' - SimEx='EXTRA0' -*--Jose: File for the optimization procedure - FieldNuc='AVENUC' -*-------- - Do 101, i=1,MxJobs - Write(JbName(i),'(A,i3.3)')'JOB',i -101 Continue - RassiM='RASSIM' - GammaO='GAMORB' - EigV='EIGV' - AddOns(1)='ADDON1' - AddOns(2)='ADDON2' - AddOns(3)='ADDON3' - iNrIn=-1 - iNrUt=0 - iLuStIn=8+iNrIn - iLuStUt=16+iNrUt - iLuSaIn=24+iNrIn - iLuSaUt=32+iNrUt - iLuBlockIn=3 - iLuBlockUt=4 - iRead=0 -*Defaults - nEqState=1 - Cut_Ex1=10.0d0 - Cut_Ex2=0.0d0 - DelX = 0.00d0 - DelFi = 0.0d0 - DelR = 0.00d0 - Temp = 300.0d0 - ISEED = 791204 - IPrint = 1 - NMACRO = 1 - NMICRO = 1 - RSTART = 80.0d0 - NPART = 0 - nAtom=3 - NCENT = 5 - NPOL = 3 - NCHA = 4 -*Jose.Slater Penetration - nSlSiteC=5 - lMltSlC=0 -***** - nLvlShift=0 - Do 119, i=1,MxAt - iExtr_Atm(i)=-1 -119 Continue - QSTA(1) = 0.5836d0 - QSTA(2) = 0.5836d0 - QSTA(3) =-0.5836d0 - QSTA(4) =-0.5836d0 - POL(1) = 5.932d0 - POL(2) = 0.641d0 - POL(3) = 0.641d0 -*Jose.Slater Penetration - Cut_Elc=6.0d0 - DifSlExp=0.001d0 - - SlFactC(1,1)=-0.50d0 - SlFactC(1,2)=-0.4164d0 - SlFactC(1,3)=-0.4164d0 - SlFactC(1,4)=-0.5836d0 - SlFactC(1,5)=-0.5836d0 - Do 217, i=1,5 - Do 218, j=2,4 - SlFactC(j,i)=0.0d0 -218 Continue -217 Continue - SlExpC(1,1)=2.5552d0 - SlExpC(1,2)=2.6085d0 - SlExpC(1,3)=2.6085d0 - SlExpC(1,4)=2.5552d0 - SlExpC(1,5)=2.5552d0 - Do 219, i=1,5 - SlExpC(2,i)=0.00d0 -219 Continue - SlPC(1)=0.5d0 - SlPC(2)=1.0d0 - SlPC(3)=1.0d0 - SlPC(4)=0.0d0 - SlPC(5)=0.0d0 -******************************* - sExRep(1,1) = 2.092338000000000000d0 - sExRe1(1,1) = 158.998000000000000d0 - sExRe2(1,1) = 4.660090000000000d10 - sExRep(2,1) = 2.112447000000000000d0 - sExRe1(2,1) = 8.31922000000000000d0 - sExRe2(2,1) = 97560.62000000000000d0 - sExRep(2,2) = 1.075803000000000000d0 - sExRe1(2,2) = 0.06521000000000000d0 - sExRe2(2,2) = 1121941276d0 - sExRep(3,1) = 2.112447000000000000d0 - sExRe1(3,1) = 8.31922000000000000d0 - sExRe2(3,1) = 97560.62000000000000d0 - sExRep(3,2) = 1.075803000000000000d0 - sExRe1(3,2) = 0.06521000000000000d0 - sExRe2(3,2) = 1121941276d0 - sExRep(3,3) = 1.075803000000000000d0 - sExRe1(3,3) = 0.06521000000000000d0 - sExRe2(3,3) = 1121941276d0 - Disp(1,1) = 11.3380000000000000d0 - Disp(2,1) = 3.38283000000000000d0 - Disp(2,2) = 0.627068000000000000d0 - Disp(3,1) = 3.38283000000000000d0 - Disp(3,2) = 0.627068000000000000d0 - Disp(3,3) = 0.627068000000000000d0 - DO 10, I=1,NPOL - DO 20, J=1,I - DISP(J,I)=DISP(I,J) - SEXREP(J,I)=SEXREP(I,J) - SEXRE1(J,I)=SEXRE1(I,J) - SEXRE2(J,I)=SEXRE2(I,J) -20 Continue -10 Continue - CORDST(1,1) = 0.0d0 - CORDST(2,1) = 0.0d0 - CORDST(3,1) = 0.0d0 - CORDST(4,1) = 0.3126d0 - CORDST(5,1) = -0.3126d0 - CORDST(1,2) = 0.0d0 - CORDST(2,2) = 1.43d0 - CORDST(3,2) = -1.43d0 - CORDST(4,2) = 0.0d0 - CORDST(5,2) = 0.0d0 - CORDST(1,3) = 0.3d0 - CORDST(2,3) = -0.807d0 - CORDST(3,3) = -0.807d0 - CORDST(4,3) = -0.1191d0 - CORDST(5,3) = -0.1191d0 - ForceK = 0.001d0 - dLJrep=0.0d0 - Pres = 1.0d0 - PolLim = 0.0001d0 - EneLim = 0.0000001d0 - itMax=30 - Exdtal = 30.0d0 - Exdt1 = 0.060d0 - Surf = 30.0d0 - iOrb(2)=5 - Diel = 80.0d0 - iExtra = 0 - Smeq=.false. - Qmeq=.false. - Fielddamp=.false. - Dispdamp=.false. - Smprod=.false. - QmProd=.false. - ChargedQM=.false. - ATitle=.false. - Anal=.false. - ParallelT=.false. - Mp2DensCorr=.false. - MoAveRed=.false. - lCiSelect=.false. - EdSt=.false. -*JoseMEP***** The dimension was increased from 8 to 12 - Do 41, i=1,12 - DelOrAdd(i)=.false. - lExtr(i)=.false. - lAnal(i)=.false. -41 Continue - lSlater=.true. - lQuad=.false. - - - Return - End diff -Nru openmolcas-22.02/src/qmstat/qmstat_init.F90 openmolcas-22.10/src/qmstat/qmstat_init.F90 --- openmolcas-22.02/src/qmstat/qmstat_init.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/qmstat_init.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,195 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! Subroutine with purpose to initialize and set defaults for the input section. +subroutine Qmstat_Init() + +use qmstat_global, only: Anal, ATitle, ChargedQM, Cordst, Cut_Elc, Cut_Ex1, Cut_Ex2, DelFi, DelOrAdd, DelR, DelX, Diel, DifSlExp, & + Disp, DispDamp, dLJRep, EdSt, EigV, EneLim, Exdt1, Exdtal, Exrep10, Exrep2, Exrep4, Exrep6, FieldDamp, & + FieldNuc, Forcek, iExtr_Atm, iExtra, iLuSaIn, iLuSaUt, iLuStIn, iLuStUt, iNrIn, iNrUt, iOrb, iPrint, & + iRead, iSeed, itMax, lCiSelect, lExtr, lMltSlC, lQuad, lSlater, MoAveRed, Mp2DensCorr, MxPut, nAtom, & + nCent, nCha, nEqState, nLvlShift, nMacro, nMicro, nPart, nPol, nSlSiteC, ParallelT, Pol, PolLim, Pres, & + Qmeq, QmProd, Qsta, RassiM, rStart, SaFilIn, SaFilUt, Sexre1, Sexre2, Sexrep, SimEx, SlExpC, SlFactC, & + SlPC, StFilIn, StFilUt, Surf, Temp +use stdalloc, only: mma_allocate +use Constants, only: Zero, One, Six, Ten, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp) :: i, j + +!IO_stuff +StFilIn = 'STFIL0' +SaFilIn = 'SAFIL0' +StFilUt = 'STFIL0' +SaFilUt = 'SAFIL0' +SimEx = 'EXTRA0' +!Jose: File for the optimization procedure +FieldNuc = 'AVENUC' +RassiM = 'RASSIM' +EigV = 'EIGV' +iNrIn = -1 +iNrUt = 0 +iLuStIn = 8+iNrIn +iLuStUt = 16+iNrUt +iLuSaIn = 24+iNrIn +iLuSaUt = 32+iNrUt +iRead = 0 +! Defaults +nEqState = 1 +Cut_Ex1 = Ten +Cut_Ex2 = Zero +DelX = Zero +DelFi = Zero +DelR = Zero +Temp = 300.0_wp +call GetSeed(ISEED) +iPrint = 1 +NMACRO = 1 +NMICRO = 1 +RSTART = 80.0_wp +NPART = 0 +nAtom = 3 +NCENT = 5 +NPOL = 3 +NCHA = 4 +!Jose.Slater Penetration +nSlSiteC = 5 +lMltSlC = 0 +!**** +nLvlShift = 0 +call mma_allocate(iExtr_Atm,0,label='iExtr_Atm') +call mma_allocate(Qsta,NCHA,label='Qsta') +QSTA(1) = 0.5836_wp +QSTA(2) = 0.5836_wp +QSTA(3) = -0.5836_wp +QSTA(4) = -0.5836_wp +call mma_allocate(Pol,NPOL,label='Pol') +POL(1) = 5.932_wp +POL(2) = 0.641_wp +POL(3) = 0.641_wp +!Jose.Slater Penetration +Cut_Elc = Six +DifSlExp = 1.0e-3_wp + +call mma_allocate(SlFactC,4,nSlSiteC,label='SlFactC') +SlFactC(1,1) = -Half +SlFactC(1,2) = -0.4164_wp +SlFactC(1,3) = -0.4164_wp +SlFactC(1,4) = -0.5836_wp +SlFactC(1,5) = -0.5836_wp +SlFactC(2:4,:) = Zero +call mma_allocate(SlExpC,2,nSlSiteC,label='SlExpC') +SlExpC(1,1) = 2.5552_wp +SlExpC(1,2) = 2.6085_wp +SlExpC(1,3) = 2.6085_wp +SlExpC(1,4) = 2.5552_wp +SlExpC(1,5) = 2.5552_wp +SlExpC(2,:) = Zero +call mma_allocate(SlPC,nSlSiteC,label='SlPC') +SlPC(1) = Half +SlPC(2) = One +SlPC(3) = One +SlPC(4) = Zero +SlPC(5) = Zero +!****************************** +Exrep2 = Zero +Exrep4 = Zero +Exrep6 = Zero +Exrep10 = Zero +call mma_allocate(sExRep,nAtom,nAtom,label='sExRep') +call mma_allocate(sExRe1,nAtom,nAtom,label='sExRe1') +call mma_allocate(sExRe2,nAtom,nAtom,label='sExRe2') +sExRep(1,1) = 2.092338_wp +sExRe1(1,1) = 158.998_wp +sExRe2(1,1) = 4.66009e10_wp +sExRep(2,1) = 2.112447_wp +sExRe1(2,1) = 8.31922_wp +sExRe2(2,1) = 97560.62_wp +sExRep(2,2) = 1.075803_wp +sExRe1(2,2) = 0.06521_wp +sExRe2(2,2) = 1121941276.0_wp +sExRep(3,1) = 2.112447_wp +sExRe1(3,1) = 8.31922_wp +sExRe2(3,1) = 97560.62_wp +sExRep(3,2) = 1.075803_wp +sExRe1(3,2) = 0.06521_wp +sExRe2(3,2) = 1121941276.0_wp +sExRep(3,3) = 1.075803_wp +sExRe1(3,3) = 0.06521_wp +sExRe2(3,3) = 1121941276.0_wp +do I=1,NATOM + do J=1,I + SEXREP(J,I) = SEXREP(I,J) + SEXRE1(J,I) = SEXRE1(I,J) + SEXRE2(J,I) = SEXRE2(I,J) + end do +end do +call mma_allocate(Disp,NPOL,NPOL,label='Disp') +Disp(1,1) = 11.338_wp +Disp(2,1) = 3.38283_wp +Disp(2,2) = 0.627068_wp +Disp(3,1) = 3.38283_wp +Disp(3,2) = 0.627068_wp +Disp(3,3) = 0.627068_wp +do I=1,NPOL + do J=1,I + DISP(J,I) = DISP(I,J) + end do +end do +call mma_allocate(Cordst,3,MxPut*nCent,label='Cordst') +CORDST(1,1) = Zero +CORDST(1,2) = Zero +CORDST(1,3) = Zero +CORDST(1,4) = 0.3126_wp +CORDST(1,5) = -0.3126_wp +CORDST(2,1) = Zero +CORDST(2,2) = 1.43_wp +CORDST(2,3) = -1.43_wp +CORDST(2,4) = Zero +CORDST(2,5) = Zero +CORDST(3,1) = 0.3_wp +CORDST(3,2) = -0.807_wp +CORDST(3,3) = -0.807_wp +CORDST(3,4) = -0.1191_wp +CORDST(3,5) = -0.1191_wp +ForceK = 1.0e-3_wp +dLJrep = Zero +Pres = One +PolLim = 1.0e-4_wp +EneLim = 1.0e-7_wp +itMax = 30 +Exdtal = 30.0_wp +Exdt1 = 0.06_wp +Surf = 30.0_wp +iOrb(2) = 5 +Diel = 80.0_wp +iExtra = 0 +Qmeq = .false. +FieldDamp = .false. +DispDamp = .false. +QmProd = .false. +ChargedQM = .false. +ATitle = .false. +Anal = .false. +ParallelT = .false. +Mp2DensCorr = .false. +MoAveRed = .false. +lCiSelect = .false. +EdSt = .false. +DelOrAdd(:) = .false. +lExtr(:) = .false. +lSlater = .true. +lQuad = .false. + +return + +end subroutine Qmstat_Init diff -Nru openmolcas-22.02/src/qmstat/qmstat_procedures.F90 openmolcas-22.10/src/qmstat/qmstat_procedures.F90 --- openmolcas-22.02/src/qmstat/qmstat_procedures.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/qmstat_procedures.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,25 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! This module contains procedures that need an interface +module qmstat_procedures + +implicit none +private + +public :: GiveMeInfo + +contains + +#define _IN_MODULE_ +#include "givemeinfo.F90" + +end module qmstat_procedures diff -Nru openmolcas-22.02/src/qmstat/ranf.f openmolcas-22.10/src/qmstat/ranf.f --- openmolcas-22.02/src/qmstat/ranf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/ranf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,54 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - function ranf(idum) - integer idum,IM1,IM2,IMM1,IA1,IA2,IQ1,IQ2,IR1,IR2,NTAB,NDIV - real*8 ranf,AM,EPS,RNMX - parameter(IM1=2147483563,IM2=2147483399,AM=1./dble(IM1), - *IMM1=IM1-1,IA1=40014,IA2=40692,IQ1=53668,IQ2=52774,IR1=12211, - *IR2=3791,NTAB=32,NDIV=1+int(dble(IMM1)/NTAB),EPS=1.2e-7, - *RNMX=1.-EPS) - integer idum2,j,k,iv(NTAB),iy - save iv,iy,idum2 - data idum2/123456789/, iv/NTAB*0/, iy/0/ - if (idum.le.0) then - idum=max(-idum,1) - idum2=idum - do 11 j=NTAB+8,1,-1 - k=idum/IQ1 - idum=IA1*(idum-k*IQ1)-k*IR1 - if(idum.lt.0) idum=idum+IM1 - if(j.le.NTAB)iv(j)=idum -11 continue - iy = iv(1) - endif - k=idum/IQ1 - idum=IA1*(idum-k*IQ1)-k*IR1 - if (idum.lt.0) idum = idum+IM1 - k=idum2/IQ2 - idum2=IA2*(idum2-k*IQ2)-k*IR2 - if (idum2.lt.0) idum2=idum2+IM2 - j=1+iy/NDIV - iy=iv(j)-idum2 - iv(j)=idum - if(iy.lt.1)iy=iy+IMM1 - ranf=min(AM*iy,RNMX) - return - end - -* function ranf(iSeed) -* Implicit Real*4 (a-h,o-z) -* Parameter (scale=0.5e0**31) -* Integer fact -* Data fact,mask/x'00003ED7',x'7FFFFFFF'/ -* iSeed=iAnd(mask,iSeed*fact) -* Ranf=scale*iSeed -* Return -* End diff -Nru openmolcas-22.02/src/qmstat/rash0.f openmolcas-22.10/src/qmstat/rash0.f --- openmolcas-22.02/src/qmstat/rash0.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/rash0.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,120 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -* -*-- In this routine H_0 in RASSI basis is constructed, possibly with -* external perturbation added on. -* - Subroutine RasH0(nB) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "numbers.fh" -#include "qminp.fh" -#include "qm2.fh" -#include "WrkSpc.fh" -#include "warnings.h" - - Dimension DiagH0(MxState) - - nBTri=nB*(nB+1)/2 - If(.not.AddExt) then - kaunter=0 - Do 1, i=1,nState - Do 2, j=1,i - kaunter=kaunter+1 -2 Continue - DiagH0(i)=HmatState(kaunter) -1 Continue - Write(6,*)' -----RASSI H_0 eigenvalues:' - Write(6,99)(DiagH0(k),k=1,nState) - Else -* -*---- Collect one-electron perturbations. -* - Lu_One=49 - Lu_One=IsFreeUnit(Lu_One) - Call OpnOne(irc,0,'ONEINT',Lu_One) - Call GetMem('AOExt','Allo','Real',ipAOx,nBTri+4) - Do 101, iExt=1,nExtAddOns - irc=-1 - iopt=0 - iSmLbl=0 - Call RdOne(irc,iopt,ExtLabel(iExt),iCompExt(iExt),Work(ipAOx) - & ,iSmLbl) - call dscal_(nBTri,ScalExt(iExt),Work(ipAOx),iONE) - If(irc.ne.0) then - Write(6,*) - Write(6,*)'ERROR when reading ',ExtLabel(iExt),'.' - Write(6,*)'Have Seward computed this integral?' - Call Quit(_RC_IO_ERROR_READ_) - Endif -* -*---- We need to know in which basis the TDM is and then transform -* the one-electron integrals to RASSI-basis. -* - If(.not.MoAveRed) then - Call GetMem('Transition','Allo','Real',ipAOG,nBTri) - kaunter=0 - Do 102, iS1=1,nState - Do 103, iS2=1,iS1 - call dcopy_(nBTri,Work(iBigT+nBTri*kaunter),iONE - & ,Work(ipAOG),iONE) - Element=Ddot_(nBTri,Work(ipAOG),iONE,Work(ipAOx),iONE) - kaunter=kaunter+1 - HmatState(kaunter)=HmatState(kaunter)+Element -103 Continue -102 Continue - Call GetMem('Transition','Free','Real',ipAOG,nBTri) - Else - nSize=nRedMO*(nRedMO+1)/2 - Call GetMem('Transition','Allo','Real',ipMOG,nSize) - Call GetMem('AUX','Allo','Real',iAUX,nRedMO*nB) - Call GetMem('SquareAO','Allo','Real',iSqAO,nB**2) - Call GetMem('SquareMO','Allo','Real',iSqMO,nRedMO**2) - Call GetMem('MOExt','Allo','Real',ipMOx,nSize) - Call Square(Work(ipAOx),Work(iSqAO),iONE,nB,nB) - Call Dgemm_('T','N',nRedMO,nB,nB,ONE,Work(ipAvRed) - & ,nB,Work(iSqAO),nB,ZERO,Work(iAUX),nRedMO) - Call Dgemm_('N','N',nRedMO,nRedMO,nB,ONE,Work(iAUX) - & ,nRedMO,Work(ipAvRed),nB,ZERO,Work(iSqMO),nRedMO) - Call SqToTri_Q(Work(iSqMO),Work(ipMOx),nRedMO) - kaunter=0 - Do 104, iS1=1,nState - Do 105, iS2=1,nState - call dcopy_(nSize,Work(iBigT+nSize*kaunter),iONE - & ,Work(ipMOG),iONE) - Element=Ddot_(nSize,Work(ipMOG),iONE,Work(ipMOx),iONE) - kaunter=kaunter+1 - HmatState(kaunter)=HmatState(kaunter)+Element -105 Continue -104 Continue - Call GetMem('Transition','Free','Real',ipMOG,nSize) - Call GetMem('AUX','Free','Real',iAUX,nRedMO*nB) - Call GetMem('SquareAO','Free','Real',iSqAO,nB**2) - Call GetMem('SquareMO','Free','Real',iSqMO,nRedMO**2) - Call GetMem('MOExt','Free','Real',ipMOx,nSize) - Endif -101 Continue - Call GetMem('AOExt','Free','Real',ipAOx,nBTri+4) - Call ClsOne(irc,Lu_One) -* -*-- If sufficient print level, print HmatState with perturbation added. -* - If(iPrint.ge.5) then - Write(6,*) - Call TriPrt('H_0+External perturbation',' ',HmatState,nState) - Endif - Endif - -99 Format(' ',9(F12.7,' ')) - - Return - End diff -Nru openmolcas-22.02/src/qmstat/rash0.F90 openmolcas-22.10/src/qmstat/rash0.F90 --- openmolcas-22.02/src/qmstat/rash0.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/rash0.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,117 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! In this routine H_0 in RASSI basis is constructed, possibly with external perturbation added on. +subroutine RasH0(nB) + +use qmstat_global, only: AddExt, AvRed, BigT, ExtLabel, HmatState, iCompExt, iPrint, MoAveRed, nExtAddOns, nRedMo, nState, ScalExt +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6, r8 + +implicit none +integer(kind=iwp), intent(in) :: nB +integer(kind=iwp) :: i, iExt, iopt, irc, iS1, iS2, iSmLbl, kaunter, Lu_One, nBTri, nSize +real(kind=wp) :: Element +real(kind=wp), allocatable :: AOG(:), AOx(:), AUX(:,:), DiagH0(:), MOG(:), MOx(:), SqAO(:,:), SqMO(:,:) +integer(kind=iwp), external :: IsFreeUnit +real(kind=r8), external :: Ddot_ +#include "warnings.h" + +nBTri = nTri_Elem(nB) +if (.not. AddExt) then + call mma_allocate(DiagH0,nState,label='DiagH0') + do i=1,nState + DiagH0(i) = HmatState(nTri_Elem(i)) + end do + write(u6,*) ' -----RASSI H_0 eigenvalues:' + write(u6,99) DiagH0(:) + call mma_deallocate(DiagH0) +else + + ! Collect one-electron perturbations. + + Lu_One = IsFreeUnit(49) + call OpnOne(irc,0,'ONEINT',Lu_One) + call mma_allocate(AOx,nBTri,label='AOExt') + do iExt=1,nExtAddOns + irc = -1 + iopt = 6 + iSmLbl = 0 + call RdOne(irc,iopt,ExtLabel(iExt),iCompExt(iExt),AOx,iSmLbl) + AOx(:) = AOx*ScalExt(iExt) + if (irc /= 0) then + write(u6,*) + write(u6,*) 'ERROR when reading ',ExtLabel(iExt),'.' + write(u6,*) 'Have Seward computed this integral?' + call Quit(_RC_IO_ERROR_READ_) + end if + + ! We need to know in which basis the TDM is and then transform + ! the one-electron integrals to RASSI-basis. + + if (.not. MoAveRed) then + call mma_allocate(AOG,nBTri,label='Transition') + kaunter = 0 + do iS1=1,nState + do iS2=1,iS1 + kaunter = kaunter+1 + AOG(:) = BigT(:,kaunter) + Element = Ddot_(nBTri,AOG,1,AOx,1) + HmatState(kaunter) = HmatState(kaunter)+Element + end do + end do + call mma_deallocate(AOG) + else + nSize = nTri_Elem(nRedMO) + call mma_allocate(MOG,nSize,label='Transition') + call mma_allocate(AUX,nRedMO,nB,label='AUX') + call mma_allocate(SqAO,nB,nB,label='SquareAO') + call mma_allocate(SqMO,nRedMO,nRedMO,label='SquareMO') + call mma_allocate(MOx,nSize,label='MOExt') + call Square(AOx,SqAO,1,nB,nB) + call Dgemm_('T','N',nRedMO,nB,nB,One,AvRed,nB,SqAO,nB,Zero,AUX,nRedMO) + call Dgemm_('N','N',nRedMO,nRedMO,nB,One,AUX,nRedMO,AvRed,nB,Zero,SqMO,nRedMO) + call SqToTri_Q(SqMO,MOx,nRedMO) + kaunter = 0 + do iS1=1,nState + ! This was 1,nState before... I think that was a bug, because HMatState is triangular + do iS2=1,iS1 + kaunter = kaunter+1 + MOG(:) = BigT(1:nSize,kaunter) + Element = Ddot_(nSize,MOG,1,MOx,1) + HmatState(kaunter) = HmatState(kaunter)+Element + end do + end do + call mma_deallocate(MOG) + call mma_deallocate(AUX) + call mma_deallocate(SqAO) + call mma_deallocate(SqMO) + call mma_deallocate(MOx) + end if + end do + call mma_deallocate(AOx) + call ClsOne(irc,Lu_One) + + ! If sufficient print level, print HmatState with perturbation added. + + if (iPrint >= 5) then + write(u6,*) + call TriPrt('H_0+External perturbation',' ',HmatState,nState) + end if +end if + +return + +99 format(' ',9(F12.7,' ')) + +end subroutine RasH0 diff -Nru openmolcas-22.02/src/qmstat/rasrastrans.f openmolcas-22.10/src/qmstat/rasrastrans.f --- openmolcas-22.02/src/qmstat/rasrastrans.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/rasrastrans.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,162 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine RasRasTrans(nB,nStatePrim,iEig2,iPrint) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "files_qmstat.fh" -#include "qm2.fh" -#include "numbers.fh" -#include "WrkSpc.fh" -#include "warnings.h" - - Dimension iTocBig(MxStOT) - - Character*30 OutLine - -* -*--- Guten Tag. -* - Write(6,*)' ----- Transform from non-orthogonal RASSCF states' - &//' to orthogonal RASSI states.' - -* -*--- Set zeros and decide if transformation is at all possible. -* - LuIn=66 - kaunt=0 - iDisk=0 - Call DaName(LuIn,RassiM) - nTriSP=nStatePrim*(nStatePrim+1)/2 - Call iDaFile(LuIn,2,iTocBig,nTriSP,iDisk) - nSize=nB*(nB+1)/2 - nTriS=nState*(nState+1)/2 - nSizeBig=nSize*nTriS - nSizeBigPrim=nSize*nTriSP - Call GetMem('HOWMUCH','Max','Real',ipMAX,MEMMAX) -* -*-- This means that we do not have memory enough for TDM in contracted -* form. Then there is no use to proceed at all. -* - If(MEMMAX.le.nSizeBig) then - Write(6,*) - Write(6,*)'The transition density matrix is too big to put in m' - &//'emory!' - Write(6,*)'Either,' - Write(6,*)' (1) increase MOLCAS_MEM,' - Write(6,*)' (2) contract number of states further.' - Call Quit(_RC_GENERAL_ERROR_) -* -*-- Here we go if there is enough memory for an in core transformation. -* - Elseif(MEMMAX.ge.(nSizeBig+nSizeBigPrim+nTriSP+nTriS+nStatePrim**2 - & +nState*nStatePrim+nState**2)) then - Call GetMem('ALLES','Allo','Real',iBigT,nSizeBig) - Call GetMem('ALLESin','Allo','Real',iBigV,nSizeBigPrim) - Call GetMem('Int1','Allo','Real',iInt1,nTriSP) - Call GetMem('Int2','Allo','Real',iInt2,nTriS) - Call GetMem('Square1','Allo','Real',iSnt1,nStatePrim**2) - Call GetMem('Square2','Allo','Real',iSnt2,nState*nStatePrim) - Call GetMem('Square3','Allo','Real',iSnt3,nState**2) - call dcopy_(nSizeBig,[ZERO],iZERO,Work(iBigT),iONE) - kaunt=0 - Do 78, i=1,nStatePrim - Do 79, j=1,i - kaunt=kaunt+1 - iDisk=iTocBig(kaunt) - Call dDaFile(LuIn,2,Work(iBigV+(kaunt-1)*nSize),nSize,iDisk) -79 Continue -78 Continue -* -*---- A lot of printing of TDM if requested. -* - If(iPrint.ge.25) then - kaunt=0 - Do 17, i=1,nStatePrim - Do 18, j=1,i - Write(OutLine,'(A,I3,I3)')'TDM, Piece ',i,j - Call TriPrt(OutLine,' ',Work(iBigV+kaunt),nB) - kaunt=kaunt+nSize -18 Continue -17 Continue - Endif -* -*---- Proceed with transformation. -* - kaunt=0 - Do 10001, iBas=1,nB - Do 10002, jBas=1,iBas - call dcopy_(nTriSP,Work(iBigV+kaunt),nSize,Work(iInt1),iONE) - Call Square(Work(iInt1),Work(iSnt1),iONE,nStatePrim - & ,nStatePrim) - Call Dgemm_('T','N',nState,nStatePrim,nStatePrim,ONE - & ,Work(iEig2),nStatePrim,Work(iSnt1),nStatePrim - & ,ZERO,Work(iSnt2),nState) - Call Dgemm_('N','N',nState,nState,nStatePrim,ONE,Work(iSnt2) - & ,nState,Work(iEig2),nStatePrim,ZERO,Work(iSnt3) - & ,nState) - Call SqToTri_Q(Work(iSnt3),Work(iInt2),nState) - call dcopy_(nTriS,Work(iInt2),iONE,Work(iBigT+kaunt),nSize) - kaunt=kaunt+1 -10002 Continue -10001 Continue - Call GetMem('ALLESin','Free','Real',iBigV,nSizeBigPrim) - Call GetMem('Int1','Free','Real',iInt1,nTriSP) - Call GetMem('Int2','Free','Real',iInt2,nTriS) - Call GetMem('Square1','Free','Real',iSnt1,nStatePrim**2) - Call GetMem('Square2','Free','Real',iSnt2,nState*nStatePrim) - Call GetMem('Square3','Free','Real',iSnt3,nState**2) -* -*-- Here we go if both TDM's can not be put in memory. Might be a bit -* slow due to its nested nature with repeated IO. -* - Else - Call GetMem('ALLES','Allo','Real',iBigT,nSizeBig) - Call GetMem('AOGamma','Allo','Real',ipAOG,nSize) - call dcopy_(nSizeBig,[ZERO],iZERO,Work(iBigT),iONE) - Do 11001, iiS=1,nStatePrim - Do 11002, jjS=1,nStatePrim - If(iiS.le.jjS) then - indypop=jjS*(jjS+1)/2-jjS+iiS - Else - indypop=iiS*(iiS+1)/2-iiS+jjS - Endif - iDisk=iTocBig(indypop) - Call dDaFile(LuIn,2,Work(ipAOG),nSize,iDisk) - kaunter=0 - Do 11003, iB=1,nB - Do 11004, jB=1,iB - Do 11005, iS=1,nState - Do 11006, jS=1,iS - index=(iS*(iS-1)/2+jS-1)*nSize - index=index+kaunter - Work(iBigT+index)=Work(iBigT+index) - & +Work(iEig2+iiS-1+(iS-1)*nStatePrim) - & *Work(iEig2+jjS-1+(jS-1)*nStatePrim) - & *Work(ipAOG+kaunter) -11006 Continue -11005 Continue - kaunter=kaunter+1 -11004 Continue -11003 Continue -11002 Continue -11001 Continue - Call GetMem('AOGamma','Free','Real',ipAOG,nSize) - Endif - -* -*--- Deallocations and finish up. -* - Call GetMem('RedEigV1','Free','Real',iEig2,nStatePrim**2) - Call DaClos(LuIn) - - Return - End diff -Nru openmolcas-22.02/src/qmstat/rasrastrans.F90 openmolcas-22.10/src/qmstat/rasrastrans.F90 --- openmolcas-22.02/src/qmstat/rasrastrans.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/rasrastrans.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,150 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine RasRasTrans(nB,nStatePrim,Eig2,iPrint) + +use qmstat_global, only: BigT, nState, RassiM +use Index_Functions, only: iTri, nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nB, nStatePrim, iPrint +real(kind=wp), intent(in) :: Eig2(nStatePrim,nStatePrim) +integer(kind=iwp) :: i, iB, iBas, iDisk, iiS, indx, indypop, iS, j, jB, jBas, jjS, jS, kaunt, kaunter, LuIn, MEMMAX, nSize, & + nSizeBig, nSizeBigPrim, nTriS, nTriSP +character(len=30) :: OutLine +integer(kind=iwp), allocatable :: iTocBig(:) +real(kind=wp), allocatable :: AOG(:), BigV(:,:), Int1(:), Int2(:), Snt1(:,:), Snt2(:,:), Snt3(:,:) +#include "warnings.h" + +!Guten Tag. + +write(u6,*) ' ----- Transform from non-orthogonal RASSCF states to orthogonal RASSI states.' + +! Set zeros and decide if transformation is at all possible. + +LuIn = 66 +kaunt = 0 +iDisk = 0 +call DaName(LuIn,RassiM) +nTriSP = nTri_Elem(nStatePrim) +call mma_allocate(iTocBig,nTriSP,label='iTocBig') +call iDaFile(LuIn,2,iTocBig,nTriSP,iDisk) +nSize = nTri_Elem(nB) +nTriS = nTri_Elem(nState) +nSizeBig = nSize*nTriS +nSizeBigPrim = nSize*nTriSP +call mma_maxDBLE(MEMMAX) + +if (MEMMAX <= nSizeBig) then + ! This means that we do not have memory enough for TDM in contracted + ! form. Then there is no use to proceed at all. + + write(u6,*) + write(u6,*) 'The transition density matrix is too big to put in memory!' + write(u6,*) 'Either,' + write(u6,*) ' (1) increase MOLCAS_MEM,' + write(u6,*) ' (2) contract number of states further.' + call Quit(_RC_GENERAL_ERROR_) + +else if (MEMMAX >= (nSizeBig+nSizeBigPrim+nTriSP+nTriS+nStatePrim**2+nState*nStatePrim+nState**2)) then + ! Here we go if there is enough memory for an in core transformation. + + call mma_allocate(BigT,nSize,nTriS,label='ALLES') + call mma_allocate(BigV,nSize,nTriSP,label='ALLESin') + call mma_allocate(Int1,nTriSP,label='Int1') + call mma_allocate(Int2,nTriS,label='Int2') + call mma_allocate(Snt1,nStatePrim,nStatePrim,label='Square1') + call mma_allocate(Snt2,nState,nStatePrim,label='Square2') + call mma_allocate(Snt3,nState,nState,label='Square3') + BigT(:,:) = Zero + kaunt = 0 + do i=1,nStatePrim + do j=1,i + kaunt = kaunt+1 + iDisk = iTocBig(kaunt) + call dDaFile(LuIn,2,BigV(:,kaunt),nSize,iDisk) + end do + end do + + ! A lot of printing of TDM if requested. + + if (iPrint >= 25) then + kaunt = 0 + do i=1,nStatePrim + do j=1,i + kaunt = kaunt+1 + write(OutLine,'(A,I3,I3)') 'TDM, Piece ',i,j + call TriPrt(OutLine,' ',BigV(:,kaunt),nB) + end do + end do + end if + + ! Proceed with transformation. + + kaunt = 0 + do iBas=1,nB + do jBas=1,iBas + kaunt = kaunt+1 + Int1(:) = BigV(kaunt,:) + call Square(Int1,Snt1,1,nStatePrim,nStatePrim) + call Dgemm_('T','N',nState,nStatePrim,nStatePrim,One,Eig2,nStatePrim,Snt1,nStatePrim,Zero,Snt2,nState) + call Dgemm_('N','N',nState,nState,nStatePrim,One,Snt2,nState,Eig2,nStatePrim,Zero,Snt3,nState) + call SqToTri_Q(Snt3,Int2,nState) + BigT(kaunt,:) = Int2 + end do + end do + call mma_deallocate(BigV) + call mma_deallocate(Int1) + call mma_deallocate(Int2) + call mma_deallocate(Snt1) + call mma_deallocate(Snt2) + call mma_deallocate(Snt3) + +else + ! Here we go if both TDM's can not be put in memory. Might be a bit + ! slow due to its nested nature with repeated IO. + + call mma_allocate(BigT,nSize,nTriS,label='ALLES') + call mma_allocate(AOG,nSize,label='AOGamma') + BigT(:,:) = Zero + do iiS=1,nStatePrim + do jjS=1,nStatePrim + indypop = iTri(iiS,jjS) + iDisk = iTocBig(indypop) + call dDaFile(LuIn,2,AOG,nSize,iDisk) + kaunter = 0 + do iB=1,nB + do jB=1,iB + kaunter = kaunter+1 + do iS=1,nState + do jS=1,iS + indx = iTri(iS,jS) + BigT(kaunter,indx) = BigT(kaunter,indx)+Eig2(iiS,iS)*Eig2(jjS,jS)*AOG(kaunter) + end do + end do + end do + end do + end do + end do + call mma_deallocate(AOG) +end if + +! Deallocations and finish up. + +call mma_deallocate(iTocBig) +call DaClos(LuIn) + +return + +end subroutine RasRasTrans diff -Nru openmolcas-22.02/src/qmstat/rassihandm.f openmolcas-22.10/src/qmstat/rassihandm.f --- openmolcas-22.02/src/qmstat/rassihandm.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/rassihandm.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,329 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Anders Ohrn * -************************************************************************ -* RassiHandM -* -*> @brief -*> Make a multicenter multipole expansion of the various densities in the RASSI-state Hamiltonian to be. -*> We also construct the gas-phase RASSI-state Hamiltonian -*> @author A. Ohrn -*> -*> @details -*> First construct the unperturbed RASSI-state Hamiltonian. The \c RasEne -*> are given in input (could be changed later). Then we obtain the -*> MME of the densities of each unique pair of AO-basis functions, -*> which we with the transition density matrices transform to their -*> RASSI-state counterparts---a process that requires some knowledge -*> about that matrix. For example, it should be noted that the matrix -*> is triangularily stored *with* corrections made for the difference -*> between diagonal and non-diagonal elements; therefore we do not -*> need to treat them differently, like we have to in the subroutine -*> ::scfhandm. If requested, we compute total charges and dipoles of -*> every state and print. -*> -*> @note -*> Requires Qfread and of course a RASSI-computation and also MPPROP. -*> -*> @param[in] nBas Number of contracted AO-basis functions -*> @param[in] nOcc Number of basis functions on the \f$ i \f$ th atom-type. -*> @param[in] natyp Number of atoms of the \f$ i \f$ th atom-type -*> @param[in] nntyp Number of atom-types -************************************************************************ - Subroutine RassiHandM(nBas,iQ_Atoms,nOcc,natyp,nntyp) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "qmcom.fh" -#include "qm2.fh" -#include "files_qmstat.fh" -#include "numbers.fh" -#include "WrkSpc.fh" - - Dimension nBas(MxSym),natyp(MxAt),nOcc(MxBas) - Dimension iMME(MxMltp*(MxMltp+1)*(MxMltp+2)/6),iCent(MxBas*MxBas) - Character MMElab*20,ChCo*2 - -* -*-- A modest entrance. -* - -* -*-- Zeros. -* - kaunt=0 - iCi=iQ_Atoms*(iQ_Atoms+1)/2 - Do 1, i=1,nState - Do 2, j=1,i - kaunt=kaunt+1 - Do 3, k=1,iCi - RasCha(kaunt,k)=0 - RasDip(kaunt,1,k)=0 - RasDip(kaunt,2,k)=0 - RasDip(kaunt,3,k)=0 - RasQua(kaunt,1,k)=0 - RasQua(kaunt,2,k)=0 - RasQua(kaunt,3,k)=0 - RasQua(kaunt,4,k)=0 - RasQua(kaunt,5,k)=0 - RasQua(kaunt,6,k)=0 -3 Continue -2 Continue -1 Continue - -* -*-- Construct H_0 with external perturbation if requested. Construct -* a copy also. -* - Write(6,*) - If(.not.AddExt) then - Write(6,*)' Constructs H_0.' - Else - Write(6,*)' Constructs H_0 with external perturbation.' - Endif - Call Chk_OneHam(nBas) - Call RasH0(nBas(1)) - kaunter=0 - Do 11, i=1,nState - Do 12, j=1,i - kaunter=kaunter+1 - HMatSOld(kaunter)=HmatState(kaunter) -12 Continue -11 Continue - Write(6,*)' ...Done!' - Write(6,*) - -* -*-- Here the MME is performed. First the expansion is performed in the -* AO-basis. Then depending on whether we use a reduced MO-basis or -* not, the proper approach is chosen. -* -* -*-- Say what we do. -* - Write(6,*) - Write(6,*)' Multicenter multipole expanding the charge' - &//' density expressed in RASSI eigenstates.' - -* -*-- Frist obtain MME in AO-basis. -* - Call GetMem('Dummy','Allo','Inte',iDum,nBas(1)**2) - Call MultiNew(iQ_Atoms,nBas(1),nOcc,natyp,nntyp,iMME,iCent - & ,iWork(iDum),nMlt,outxyzRAS - & ,SlExpQ,lSlater) - Call GetMem('Dummy','Free','Inte',iDum,nBas(1)**2) - -* -*-- Set nTyp, which is number of unique multipole components. -* - nTyp=0 - Do 100, i=1,nMlt - nTyp=nTyp+i*(i+1)/2 -100 Continue - -* -*-- Transform to State-basis. The logical flag MoAveRed decides which -* path to go in this subroutine. -* - Call StateMME(MoAveRed,nBas(1),nRedMO,nState,nTyp,iCi,iBigT,iMME - & ,iCent,ipAvRed,RasCha,RasDip,RasQua) - -* -*-- Deallocate the MME in AO-basis. -* - Do 106,i=1,nTyp - Write(ChCo,'(I2.2)')i - Write(MMElab,*)'MME'//ChCo - Call GetMem(MMElab,'Free','Real',iMME(i),nSize) -106 Continue - -* -*-- Buckinghamification of the quadrupoles. -* - kaunter=0 - Do 991, i=1,nState - Do 992, j=1,i - kaunter=kaunter+1 - Do 993, k=1,ici - Do 994, l=1,6 - RasQua(kaunter,l,k)=RasQua(kaunter,l,k)*1.5 -994 Continue - Tra=RasQua(kaunter,1,k)+RasQua(kaunter,3,k) - & +RasQua(kaunter,6,k) - Tra=Tra/3 - RasQua(kaunter,1,k)=RasQua(kaunter,1,k)-Tra - RasQua(kaunter,3,k)=RasQua(kaunter,3,k)-Tra - RasQua(kaunter,6,k)=RasQua(kaunter,6,k)-Tra -993 Continue -992 Continue -991 Continue -* -*--- And do some printing if asked for. -* - If(iPrint.ge.10) then - Write(6,*) - Write(6,*)' Distributed multipoles for each state' - Do 31, i=1,nState - k=i*(i+1)/2 - Write(6,*)' State ',i - Do 32, j=1,iCi - Write(6,*)' Center ',j - Q=-RasCha(k,j) - If(j.le.iQ_Atoms) Q=Q+ChaNuc(j) - Write(6,*)' ',Q - D1=-RasDip(k,1,j) - D2=-RasDip(k,2,j) - D3=-RasDip(k,3,j) - Write(6,*)' ',D1,D2,D3 -32 Continue -31 Continue - Endif - If(iPrint.ge.5) then - Write(6,*) - Write(6,*)' Summed multipoles for each state (not state-over' - &//'laps)' - Write(6,*)' Charge Dipole(x) Dipole(y) Dipole' - &//'(z) Quadrup(xx) Quadrup(xy) Quadrup(xz) Quadrup(yy) Quadrup(' - &//'yz) Quadrup(zz)' - Endif - Do 26, i=1,nState !Total charge and dipole. - k=i*(i+1)/2 - qEl=0 - dipx=0 - dipy=0 - dipz=0 - dipx0=0 - dipy0=0 - dipz0=0 - quaxx=0 - quaxy=0 - quaxz=0 - quayy=0 - quayz=0 - quazz=0 - quaDxx=0 - quaDxy=0 - quaDxz=0 - quaDyx=0 - quaDyy=0 - quaDyz=0 - quaDzx=0 - quaDzy=0 - quaDzz=0 - quaQxx=0 - quaQxy=0 - quaQxz=0 - quaQyy=0 - quaQyz=0 - quaQzz=0 - qtot=0 - dTox=0 - dToy=0 - dToz=0 - dQxx=0 - dQxy=0 - dQxz=0 - dQyy=0 - dQyz=0 - dQzz=0 - Trace1=0 - Trace2=0 - Trace3=0 - Do 27, j=1,iCi - qEl=qEl+RasCha(k,j) - dipx=dipx+RasDip(k,1,j) - dipy=dipy+RasDip(k,2,j) - dipz=dipz+RasDip(k,3,j) - dipx0=dipx0+RasCha(k,j)*outxyzRAS(j,1) - dipy0=dipy0+RasCha(k,j)*outxyzRAS(j,2) - dipz0=dipz0+RasCha(k,j)*outxyzRAS(j,3) - quaxx=quaxx+RasQua(k,1,j) - quaxy=quaxy+RasQua(k,2,j) - quaxz=quaxz+RasQua(k,4,j) - quayy=quayy+RasQua(k,3,j) - quayz=quayz+RasQua(k,5,j) - quazz=quazz+RasQua(k,6,j) - quaDxx=quaDxx+RasDip(k,1,j)*(outxyzRAS(j,1)-CT(1)) - quaDxy=quaDxy+RasDip(k,1,j)*(outxyzRAS(j,2)-CT(2)) - quaDxz=quaDxz+RasDip(k,1,j)*(outxyzRAS(j,3)-CT(3)) - quaDyx=quaDyx+RasDip(k,2,j)*(outxyzRAS(j,1)-CT(1)) - quaDyy=quaDyy+RasDip(k,2,j)*(outxyzRAS(j,2)-CT(2)) - quaDyz=quaDyz+RasDip(k,2,j)*(outxyzRAS(j,3)-CT(3)) - quaDzx=quaDzx+RasDip(k,3,j)*(outxyzRAS(j,1)-CT(1)) - quaDzy=quaDzy+RasDip(k,3,j)*(outxyzRAS(j,2)-CT(2)) - quaDzz=quaDzz+RasDip(k,3,j)*(outxyzRAS(j,3)-CT(3)) - quaQxx=quaQxx+RasCha(k,j)*(outxyzRAS(j,1)-CT(1)) - & *(outxyzRAS(j,1)-CT(1)) - quaQxy=quaQxy+RasCha(k,j)*(outxyzRAS(j,1)-CT(1)) - & *(outxyzRAS(j,2)-CT(2)) - quaQxz=quaQxz+RasCha(k,j)*(outxyzRAS(j,1)-CT(1)) - & *(outxyzRAS(j,3)-CT(3)) - quaQyy=quaQyy+RasCha(k,j)*(outxyzRAS(j,2)-CT(2)) - & *(outxyzRAS(j,2)-CT(2)) - quaQyz=quaQyz+RasCha(k,j)*(outxyzRAS(j,2)-CT(2)) - & *(outxyzRAS(j,3)-CT(3)) - quaQzz=quaQzz+RasCha(k,j)*(outxyzRAS(j,3)-CT(3)) - & *(outxyzRAS(j,3)-CT(3)) -27 Continue - Do 28, kk=1,iQ_Atoms - qtot=qtot+ChaNuc(kk) - dTox=dTox+ChaNuc(kk)*outxyzRAS(kk,1) - dToy=dToy+ChaNuc(kk)*outxyzRAS(kk,2) - dToz=dToz+ChaNuc(kk)*outxyzRAS(kk,3) - dQxx=dQxx+ChaNuc(kk)*(outxyzRAS(kk,1)-CT(1)) - & *(outxyzRAS(kk,1)-CT(1)) - dQxy=dQxy+ChaNuc(kk)*(outxyzRAS(kk,1)-CT(1)) - & *(outxyzRAS(kk,2)-CT(2)) - dQxz=dQxz+ChaNuc(kk)*(outxyzRAS(kk,1)-CT(1)) - & *(outxyzRAS(kk,3)-CT(3)) - dQyy=dQyy+ChaNuc(kk)*(outxyzRAS(kk,2)-CT(2)) - & *(outxyzRAS(kk,2)-CT(2)) - dQyz=dQyz+ChaNuc(kk)*(outxyzRAS(kk,2)-CT(2)) - & *(outxyzRAS(kk,3)-CT(3)) - dQzz=dQzz+ChaNuc(kk)*(outxyzRAS(kk,3)-CT(3)) - & *(outxyzRAS(kk,3)-CT(3)) -28 Continue -*--- Observe! qTot is not just a check. It is used later as a sign -* to see if QM-region is charged. - qtot=qtot-qEl - dTox=dTox-dipx-dipx0 - dToy=dToy-dipy-dipy0 - dToz=dToz-dipz-dipz0 - Trace1=dQxx+dQyy+dQzz - Trace2=-quaDxx-quaDyy-quaDzz - Trace3=-quaQxx-quaQyy-quaQzz - Trace1=Trace1/3 - Trace2=2*Trace2/3 - Trace3=Trace3/3 - dQxx=1.5*(dQxx-2*quaDxx-quaQxx-Trace1-Trace2-Trace3)-quaxx - dQyy=1.5*(dQyy-2*quaDyy-quaQyy-Trace1-Trace2-Trace3)-quayy - dQzz=1.5*(dQzz-2*quaDzz-quaQzz-Trace1-Trace2-Trace3)-quazz - dQxy=1.5*(dQxy-quaDxy-quaDyx-quaQxy)-quaxy - dQxz=1.5*(dQxz-quaDxz-quaDzx-quaQxz)-quaxz - dQyz=1.5*(dQyz-quaDyz-quaDzy-quaQyz)-quayz - If(iPrint.ge.5) then - Write(6,9001)' State ',i,' ',qtot,dTox,dToy,dToz,dQxx - & ,dQxy,dQxz,dQyy,dQyz,dQzz - Endif - If(.not.abs(qtot).le.0.0001) ChargedQM=.true. -26 Continue -*Jose This format has problems to print anions -*9001 Format(A,i2,A,F5.3,9(F12.8)) -9001 Format(A,i2,A,F5.1,9(F12.8)) - Write(6,*)' ...Done!' - -*----------------------------------------------------------------------* -* The end has come. * -*----------------------------------------------------------------------* - Return - End diff -Nru openmolcas-22.02/src/qmstat/rassihandm.F90 openmolcas-22.10/src/qmstat/rassihandm.F90 --- openmolcas-22.02/src/qmstat/rassihandm.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/rassihandm.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,284 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Anders Ohrn * +!*********************************************************************** +! RassiHandM +! +!> @brief +!> Make a multicenter multipole expansion of the various densities in the RASSI-state Hamiltonian to be. +!> We also construct the gas-phase RASSI-state Hamiltonian +!> @author A. Ohrn +!> +!> @details +!> First construct the unperturbed RASSI-state Hamiltonian. The \c RasEne +!> are given in input (could be changed later). Then we obtain the +!> MME of the densities of each unique pair of AO-basis functions, +!> which we with the transition density matrices transform to their +!> RASSI-state counterparts---a process that requires some knowledge +!> about that matrix. For example, it should be noted that the matrix +!> is triangularily stored *with* corrections made for the difference +!> between diagonal and non-diagonal elements; therefore we do not +!> need to treat them differently, like we have to in the subroutine +!> ::scfhandm. If requested, we compute total charges and dipoles of +!> every state and print. +!> +!> @note +!> Requires Qfread and of course a RASSI-computation and also MPPROP. +!> +!> @param[in] nBas Number of contracted AO-basis functions +!> @param[in] iQ_Atoms +!> @param[in] nOcc Number of basis functions on the \f$ i \f$ th atom-type. +!> @param[in] natyp Number of atoms of the \f$ i \f$ th atom-type +!> @param[in] nntyp Number of atom-types +!*********************************************************************** + +subroutine RassiHandM(nBas,iQ_Atoms,nOcc,natyp,nntyp) + +use qmstat_global, only: AddExt, ChaNuc, ChargedQM, CT, HmatSOld, HmatState, iPrint, lSlater, MoAveRed, MxMltp, MxSymQ, nMlt, & + nRedMO, nState, outxyzRAS, qTot, RasCha, RasDip, RasQua +use Index_Functions, only: nTri3_Elem, nTri_Elem +use Data_Structures, only: Alloc1DArray_Type, Allocate_DT, Deallocate_DT +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, Two, Three, OneHalf +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nBas(MxSymQ), iQ_Atoms, nntyp, nOcc(nntyp), natyp(nntyp) +integer(kind=iwp) :: i, iCi, j, k, kaunter, kk, nTyp +real(kind=wp) :: D1, D2, D3, dipx, dipx0, dipy, dipy0, dipz, dipz0, dQxx, dQxy, dQxz, dQyy, dQyz, dQzz, dTox, dToy, dToz, Q, qEl, & + quaDxx, quaDxy, quaDxz, quaDyy, quaDyx, quaDyz, quaDzx, quaDzy, quaDzz, quaQxx, quaQxy, quaQxz, quaQyy, quaQyz, & + quaQzz, quaxx, quaxy, quaxz, quayy, quayz, quazz, Tra, Trace1, Trace2, Trace3 +integer(kind=iwp), allocatable :: Dum(:,:), iCent(:) +type(Alloc1DArray_Type), allocatable :: MME(:) + +! A modest entrance. + +iCi = nTri_Elem(iQ_Atoms) +call mma_allocate(RasCha,nTri_Elem(nState),iCi,label='RasCha') +call mma_allocate(RasDip,nTri_Elem(nState),3,iCi,label='RasDip') +call mma_allocate(RasQua,nTri_Elem(nState),6,iCi,label='RasQua') + +! Zeros. + +RasCha(:,:) = Zero +RasDip(:,:,:) = Zero +RasQua(:,:,:) = Zero + +! Construct H_0 with external perturbation if requested. Construct a copy also. + +write(u6,*) +if (.not. AddExt) then + write(u6,*) ' Constructs H_0.' +else + write(u6,*) ' Constructs H_0 with external perturbation.' +end if +call Chk_OneHam(nBas) +call RasH0(nBas(1)) +HMatSOld(:) = HmatState +write(u6,*) ' ...Done!' +write(u6,*) + +! Here the MME is performed. First the expansion is performed in the +! AO-basis. Then depending on whether we use a reduced MO-basis or +! not, the proper approach is chosen. + +! Say what we do. + +write(u6,*) +write(u6,*) ' Multicenter multipole expanding the charge density expressed in RASSI eigenstates.' + +! First obtain MME in AO-basis. + +call mma_allocate(iCent,nTri_Elem(nBas(1)),label='iCent') +call mma_allocate(outxyzRAS,3,nTri_Elem(iQ_Atoms),label='outxyzRAS') +call mma_allocate(Dum,nBas(1),nBas(1),label='Dummy') +call Allocate_DT(MME,[1,nTri3_Elem(MxMltp)],label='MME') +call MultiNew(iQ_Atoms,nBas(1),nOcc,natyp,nntyp,MME,iCent,Dum,nMlt,outxyzRAS,lSlater) +call mma_deallocate(Dum) + +! Set nTyp, which is number of unique multipole components. + +nTyp = 0 +do i=1,nMlt + nTyp = nTyp+nTri_Elem(i) +end do + +! Transform to State-basis. The logical flag MoAveRed decides which path to go in this subroutine. + +call StateMME(MoAveRed,nBas(1),nRedMO,nState,nTyp,MME,iCent,RasCha,RasDip,RasQua) + +! Deallocate the MME in AO-basis. + +call mma_deallocate(iCent) + +call Deallocate_DT(MME) + +! Buckinghamification of the quadrupoles. + +RasQua(:,:,:) = RasQua*OneHalf +kaunter = 0 +do i=1,nState + do j=1,i + kaunter = kaunter+1 + do k=1,iCi + Tra = (RasQua(kaunter,1,k)+RasQua(kaunter,3,k)+RasQua(kaunter,6,k))/Three + RasQua(kaunter,1,k) = RasQua(kaunter,1,k)-Tra + RasQua(kaunter,3,k) = RasQua(kaunter,3,k)-Tra + RasQua(kaunter,6,k) = RasQua(kaunter,6,k)-Tra + end do + end do +end do + +! And do some printing if asked for. + +if (iPrint >= 10) then + write(u6,*) + write(u6,*) ' Distributed multipoles for each state' + do i=1,nState + k = nTri_Elem(i) + write(u6,*) ' State ',i + do j=1,iCi + write(u6,*) ' Center ',j + Q = -RasCha(k,j) + if (j <= iQ_Atoms) Q = Q+ChaNuc(j) + write(u6,*) ' ',Q + D1 = -RasDip(k,1,j) + D2 = -RasDip(k,2,j) + D3 = -RasDip(k,3,j) + write(u6,*) ' ',D1,D2,D3 + end do + end do +end if +if (iPrint >= 5) then + write(u6,*) + write(u6,*) ' Summed multipoles for each state (not state-overlaps)' + write(u6,*) ' Charge Dipole(x) Dipole(y) Dipole(z) '// & + 'Quadrup(xx) Quadrup(xy) Quadrup(xz) Quadrup(yy) Quadrup(yz) Quadrup(zz)' +end if +do i=1,nState !Total charge and dipole. + k = nTri_Elem(i) + qEl = Zero + dipx = Zero + dipy = Zero + dipz = Zero + dipx0 = Zero + dipy0 = Zero + dipz0 = Zero + quaxx = Zero + quaxy = Zero + quaxz = Zero + quayy = Zero + quayz = Zero + quazz = Zero + quaDxx = Zero + quaDxy = Zero + quaDxz = Zero + quaDyx = Zero + quaDyy = Zero + quaDyz = Zero + quaDzx = Zero + quaDzy = Zero + quaDzz = Zero + quaQxx = Zero + quaQxy = Zero + quaQxz = Zero + quaQyy = Zero + quaQyz = Zero + quaQzz = Zero + qtot = Zero + dTox = Zero + dToy = Zero + dToz = Zero + dQxx = Zero + dQxy = Zero + dQxz = Zero + dQyy = Zero + dQyz = Zero + dQzz = Zero + Trace1 = Zero + Trace2 = Zero + Trace3 = Zero + do j=1,iCi + qEl = qEl+RasCha(k,j) + dipx = dipx+RasDip(k,1,j) + dipy = dipy+RasDip(k,2,j) + dipz = dipz+RasDip(k,3,j) + dipx0 = dipx0+RasCha(k,j)*outxyzRAS(1,j) + dipy0 = dipy0+RasCha(k,j)*outxyzRAS(2,j) + dipz0 = dipz0+RasCha(k,j)*outxyzRAS(3,j) + quaxx = quaxx+RasQua(k,1,j) + quaxy = quaxy+RasQua(k,2,j) + quaxz = quaxz+RasQua(k,4,j) + quayy = quayy+RasQua(k,3,j) + quayz = quayz+RasQua(k,5,j) + quazz = quazz+RasQua(k,6,j) + quaDxx = quaDxx+RasDip(k,1,j)*(outxyzRAS(1,j)-CT(1)) + quaDxy = quaDxy+RasDip(k,1,j)*(outxyzRAS(2,j)-CT(2)) + quaDxz = quaDxz+RasDip(k,1,j)*(outxyzRAS(3,j)-CT(3)) + quaDyx = quaDyx+RasDip(k,2,j)*(outxyzRAS(1,j)-CT(1)) + quaDyy = quaDyy+RasDip(k,2,j)*(outxyzRAS(2,j)-CT(2)) + quaDyz = quaDyz+RasDip(k,2,j)*(outxyzRAS(3,j)-CT(3)) + quaDzx = quaDzx+RasDip(k,3,j)*(outxyzRAS(1,j)-CT(1)) + quaDzy = quaDzy+RasDip(k,3,j)*(outxyzRAS(2,j)-CT(2)) + quaDzz = quaDzz+RasDip(k,3,j)*(outxyzRAS(3,j)-CT(3)) + quaQxx = quaQxx+RasCha(k,j)*(outxyzRAS(1,j)-CT(1))*(outxyzRAS(1,j)-CT(1)) + quaQxy = quaQxy+RasCha(k,j)*(outxyzRAS(1,j)-CT(1))*(outxyzRAS(2,j)-CT(2)) + quaQxz = quaQxz+RasCha(k,j)*(outxyzRAS(1,j)-CT(1))*(outxyzRAS(3,j)-CT(3)) + quaQyy = quaQyy+RasCha(k,j)*(outxyzRAS(2,j)-CT(2))*(outxyzRAS(2,j)-CT(2)) + quaQyz = quaQyz+RasCha(k,j)*(outxyzRAS(2,j)-CT(2))*(outxyzRAS(3,j)-CT(3)) + quaQzz = quaQzz+RasCha(k,j)*(outxyzRAS(3,j)-CT(3))*(outxyzRAS(3,j)-CT(3)) + end do + do kk=1,iQ_Atoms + qtot = qtot+ChaNuc(kk) + dTox = dTox+ChaNuc(kk)*outxyzRAS(1,kk) + dToy = dToy+ChaNuc(kk)*outxyzRAS(2,kk) + dToz = dToz+ChaNuc(kk)*outxyzRAS(3,kk) + dQxx = dQxx+ChaNuc(kk)*(outxyzRAS(1,kk)-CT(1))*(outxyzRAS(1,kk)-CT(1)) + dQxy = dQxy+ChaNuc(kk)*(outxyzRAS(1,kk)-CT(1))*(outxyzRAS(2,kk)-CT(2)) + dQxz = dQxz+ChaNuc(kk)*(outxyzRAS(1,kk)-CT(1))*(outxyzRAS(3,kk)-CT(3)) + dQyy = dQyy+ChaNuc(kk)*(outxyzRAS(2,kk)-CT(2))*(outxyzRAS(2,kk)-CT(2)) + dQyz = dQyz+ChaNuc(kk)*(outxyzRAS(2,kk)-CT(2))*(outxyzRAS(3,kk)-CT(3)) + dQzz = dQzz+ChaNuc(kk)*(outxyzRAS(3,kk)-CT(3))*(outxyzRAS(3,kk)-CT(3)) + end do + ! Observe! qTot is not just a check. It is used later as a sign to see if QM-region is charged. + qtot = qtot-qEl + dTox = dTox-dipx-dipx0 + dToy = dToy-dipy-dipy0 + dToz = dToz-dipz-dipz0 + Trace1 = dQxx+dQyy+dQzz + Trace2 = -quaDxx-quaDyy-quaDzz + Trace3 = -quaQxx-quaQyy-quaQzz + Trace1 = Trace1/Three + Trace2 = Two*Trace2/Three + Trace3 = Trace3/Three + dQxx = OneHalf*(dQxx-Two*quaDxx-quaQxx-Trace1-Trace2-Trace3)-quaxx + dQyy = OneHalf*(dQyy-Two*quaDyy-quaQyy-Trace1-Trace2-Trace3)-quayy + dQzz = OneHalf*(dQzz-Two*quaDzz-quaQzz-Trace1-Trace2-Trace3)-quazz + dQxy = OneHalf*(dQxy-quaDxy-quaDyx-quaQxy)-quaxy + dQxz = OneHalf*(dQxz-quaDxz-quaDzx-quaQxz)-quaxz + dQyz = OneHalf*(dQyz-quaDyz-quaDzy-quaQyz)-quayz + if (iPrint >= 5) then + write(u6,9001) ' State ',i,' ',qtot,dTox,dToy,dToz,dQxx,dQxy,dQxz,dQyy,dQyz,dQzz + end if + if (abs(qtot) > 1.0e-4_wp) ChargedQM = .true. +end do +write(u6,*) ' ...Done!' + +!----------------------------------------------------------------------* +! The end has come. * +!----------------------------------------------------------------------* +return + +!Jose This format has problems to print anions +!9001 format(A,i2,A,F5.3,9(F12.8)) +9001 format(A,i2,A,F5.1,9(F12.8)) + +end subroutine RassiHandM diff -Nru openmolcas-22.02/src/qmstat/reaind.f openmolcas-22.10/src/qmstat/reaind.f --- openmolcas-22.02/src/qmstat/reaind.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/reaind.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,81 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine ReaInd(iGP,iDT,iDistIm,iCNum,indma,ncparm,Sum1,s90um) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "qmcom.fh" -#include "WrkSpc.fh" - - Dimension iGP(3),iDT(3) - - Sum1=0 -* irekn=0 -* xled=0 -* yled=0 -* zled=0 - Do 901, i=1+(nPol*iCnum),indma - Do 902, j=1,3 !The energy of the induced dipoles (iDT) in - !the field from the real charges. Yes, this - !is the polarization energy in a system - !without permanent dipoles, see good old - !Bottcher, eq. (3.129). Observe also that - !we here include effects of the reaction - !field on the induced dipoles, see the - !polarization loop. - Sum1=Sum1+Work(iGP(j)+i-1)*Work(iDT(j)+i-1) -902 Continue -* IF WE WISH TO MONITOR THE INDUCED DIPOLES, UNCOMMENT THIS, AND THE -* COMMENTED THING ABOVE. -* irekn=irekn+1 -* xled=xled+Work(iDt(1)+i-1) -* yled=yled+Work(iDt(2)+i-1) -* zled=zled+Work(iDt(3)+i-1) -* if(irekn.eq.3) then -* irekn=0 -* TOT=sqrt(xled**2+yled**2+zled**2) -* write(6,*)'HHH',TOT -* xled=0 -* yled=0 -* zled=0 -* endif -901 Continue - Sum1=Sum1*0.5 - S90um=0 - Do 911, i=iCnum+1,nPart !Energy of charge distribution - Do 912, j=1,nPol !in the reaction field to - Q1=Qimp((i-1)*nPol+j) !the induced dipoles. - D1x=Dim((i-1)*nPol+j,1) !Once more, see Bottcher eq. - D1y=Dim((i-1)*nPol+j,2) !(4.69): we are computing the - D1z=Dim((i-1)*nPol+j,3) !product between charges and the - x=CordIm((i-1)*nCent+j,1) !potential connected with the - y=CordIm((i-1)*nCent+j,2) !reaction field. - z=CordIm((i-1)*nCent+j,3) - Inc=ncparm*nCent*(i-(iCnum+1))+(j-1)*ncparm - Do 913, l=nCent-nCha+1,nCent - Inc2=Inc+l - Q2=Qsta(l-nCent+nCha) - Do 914, k=iCnum+1,nPart - X1=(X-Cordst(l+(k-1)*nCent,1))*D1x - X1=(Y-Cordst(l+(k-1)*nCent,2))*D1y+X1 - X1=(Z-Cordst(l+(k-1)*nCent,3))*D1z+X1 - !Change sign on Q2 since we are in the backwards land, while - !Q1 and X1 already are backward. - S90um=S90um-(Q1+X1*Work(iDistIm-1+inc2+(k-(iCnum+1))*nCent)**2) - & *Q2*Work(iDistIm-1+inc2+(k-(iCnum+1))*nCent) -914 Continue -913 Continue -912 Continue -911 Continue - - Return - End diff -Nru openmolcas-22.02/src/qmstat/reaind.F90 openmolcas-22.10/src/qmstat/reaind.F90 --- openmolcas-22.02/src/qmstat/reaind.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/reaind.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,78 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine ReaInd(GP,DT,DistIm,iCNum,indma,nClas,Sum1,s90um) + +use qmstat_global, only: CordIm, Cordst, DipIm, nCent, nCha, nPart, nPol, Qimp, Qsta +use Constants, only: Zero, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iCNum, indma, nClas +real(kind=wp), intent(in) :: GP(3,nPol*nPart), DistIm(nCent,nClas,nCent,nClas), DT(3,nPol*nPart) +real(kind=wp), intent(out) :: Sum1, s90um +integer(kind=iwp) :: i, j, k, l +real(kind=wp) :: D, D1(3), Q1, Q2, x, X1, y, z + +Sum1 = Zero +!irekn = 0 +!xled = Zero +!yled = Zero +!zled = Zero +do i=1+(nPol*iCnum),indma + ! The energy of the induced dipoles (DT) in the field from the real charges. Yes, this + ! is the polarization energy in a system without permanent dipoles, see good old + ! Bottcher, eq. (3.129). Observe also that we here include effects of the reaction + ! field on the induced dipoles, see the polarization loop. + do j=1,3 !The energy of the induced dipoles (DT) in + Sum1 = Sum1+GP(j,i)*DT(j,i) + end do + ! IF WE WISH TO MONITOR THE INDUCED DIPOLES, UNCOMMENT THIS, AND THE COMMENTED THING ABOVE. + !irekn = irekn+1 + !xled = xled+DT(1,i) + !yled = yled+DT(2,i) + !zled = zled+DT(3,i) + !if (irekn == 3) then + ! irekn = 0 + ! TOT = sqrt(xled**2+yled**2+zled**2) + ! write(u6,*) 'HHH',TOT + ! xled = Zero + ! yled = Zero + ! zled = Zero + !end if +end do +Sum1 = Sum1*Half +S90um = Zero +! Energy of charge distribution in the reaction field to the induced dipoles. +! Once more, see Bottcher eq. (4.69): we are computing the product between charges and the +! potential connected with the reaction field. +do i=iCnum+1,nPart + do j=1,nPol + Q1 = Qimp((i-1)*nPol+j) + D1(:) = DipIm(:,(i-1)*nPol+j) + x = CordIm(1,(i-1)*nCent+j) + y = CordIm(2,(i-1)*nCent+j) + z = CordIm(3,(i-1)*nCent+j) + do l=nCent-nCha+1,nCent + Q2 = Qsta(l-nCent+nCha) + do k=iCnum+1,nPart + X1 = (X-Cordst(1,l+(k-1)*nCent))*D1(1)+(Y-Cordst(2,l+(k-1)*nCent))*D1(2)+(Z-Cordst(3,l+(k-1)*nCent))*D1(3) + ! Change sign on Q2 since we are in the backwards land, while Q1 and X1 already are backward. + D = DistIm(l,k-iCnum,j,i-iCnum) + S90um = S90um-(Q1+X1*D**2)*Q2*D + end do + end do + end do +end do + +return + +end subroutine ReaInd diff -Nru openmolcas-22.02/src/qmstat/revolution.F90 openmolcas-22.10/src/qmstat/revolution.F90 --- openmolcas-22.02/src/qmstat/revolution.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/revolution.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,38 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! Construct rotation matrix. +subroutine Revolution(v,Rinv,Rotte) + +use Definitions, only: wp + +implicit none +real(kind=wp), intent(in) :: v(3), Rinv +real(kind=wp), intent(out) :: Rotte(3,3) +real(kind=wp) :: u(3), w(3), t(3) + +! Obtain base-vectors for the plane to which v in the normal vector. + +call PlaneVectors(u,w,v,Rinv) + +! Normalize v. + +t(:) = Rinv*v + +! Assemble rotation matrix + +Rotte(1,:) = u +Rotte(2,:) = w +Rotte(3,:) = t + +return + +end subroutine Revolution diff -Nru openmolcas-22.02/src/qmstat/rotation_qmstat.F90 openmolcas-22.10/src/qmstat/rotation_qmstat.F90 --- openmolcas-22.02/src/qmstat/rotation_qmstat.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/rotation_qmstat.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,75 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! Rotate multipole. +subroutine Rotation_qmstat(iL,dMul,Rotte,Sigge) + +use Index_Functions, only: nTri_Elem1 +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +! Maximum multipole implemented +#define _MxM_ 2 + +implicit none +integer(kind=iwp), intent(in) :: iL +real(kind=wp), intent(inout) :: dMul(nTri_Elem1(_MxM_)) +real(kind=wp), intent(in) :: Rotte(3,3), Sigge +real(kind=wp) :: d1, d2, d3, dMTrans(6), Sig, TD(6,6) +integer(kind=iwp) :: i, j +#include "warnings.h" + +if (iL == 0) then + ! Charge, trivial to rotate. + +else if (iL == 1) then + ! Dipole, transforms as a vector. Sigge controls that if the + ! multipole is located not in origin, but at the other end, + ! i.e. molecule A, then any odd occurrence of z should be + ! mirrored. Applies for the quadrupole as well, see below. + + d1 = dMul(1) + d2 = dMul(2) + d3 = dMul(3) + dMul(:) = Rotte(:,1)*d1+Rotte(:,2)*d2+Rotte(:,3)*d3 + dMul(3) = Sigge*dMul(3) +else if (iL == 2) then + ! Quadrupole, transforms as a quadratic form. Also, transform to spherical representation. + + ! Compute the transformation matrix for second-moments. + + call M2Trans(Rotte,TD) + + ! Transform. Sigge is explained above. + + dMTrans(:) = Zero + do i=1,6 + do j=1,6 + dMTrans(i) = dMTrans(i)+TD(i,j)*dMul(j) + end do + end do + do i=1,6 + Sig = One + if ((i == 3) .or. (i == 5)) Sig = Sigge + dMul(i) = dMTrans(i)*Sig + end do + + ! Go to spherical representation. + + call Spherical(dMul) +else + write(u6,*) 'Nope!, Error in sl_grad' + call Quit(_RC_IO_ERROR_READ_) +end if + +return + +end subroutine Rotation_qmstat diff -Nru openmolcas-22.02/src/qmstat/scfh0.f openmolcas-22.10/src/qmstat/scfh0.f --- openmolcas-22.02/src/qmstat/scfh0.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/scfh0.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,224 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -* -*-- Read all MO-transformed integrals and construct zeroth Fock-matrix. -* - Subroutine ScfH0(nBas) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "files_qmstat.fh" -#include "qm1.fh" -#include "numbers.fh" -#include "tratoc.fh" -#include "WrkSpc.fh" -#include "warnings.h" - - Dimension nBasM(MxSym),nOrbM(MxSym),nDelM(MxSym),nFroM(MxSym) - Dimension nBas(MxSym) - Dimension iToc(64) - Parameter (lenin8=6+8) - Parameter (maxbfn=10000) - Character NameM*(lenin8*maxbfn),firstind*10 - -* -*-- Wilkommen. -* - Write(6,*) - Write(6,*) - Write(6,*)'Reading MO-transformed integrals. Zero:th hamiltonian ' - &//'constructed.' - -* -*-- Numbers and files. -* - nSize=iOrb(1)*(iOrb(1)+1)/2 - Call GetMem('FockM','Allo','Real',iPointF,nSize) - Call GetMem('SUPER','Allo','Real',iSupM,nSize**2) - iLu1=56 - iLu2=58 - Call DaName(iLu1,'TRAONE') - Call DaName(iLu2,'TRAINT') - iDisk=0 -*--- This is special utility to read header of TRAONE. - Call Wr_Motra_Info(iLu1,2,iDisk,iToc,64,Ecor,nSymM,nBasM,nOrbM - &,nFroM,nDelM,MxSym,NameM,lenin8*maxbfn) !Last argument depends on - !mxorb in Molcas.fh. -* -*-- One checks. -* - If(nBasM(1).ne.nBas(1)) then - Write(6,*) - Write(6,*)' ERROR! Conflict between one-electron file and MO-t' - &//'ransformed one-electron file.' - Write(6,*)' nBas=',nBas(1),' MO-nBas=',nBasM(1) - Call Quit(_RC_GENERAL_ERROR_) - Endif - -* -*-- Read one-electron matrix elements. -* - iDisk=iToc(2) - Call dDaFile(iLu1,2,Work(iPointF),nSize,iDisk) - call dcopy_(nSize,Work(iPointF),iONE,HHmat,iONE) - Call GetMem('FockM','Free','Real',iPointF,nSize) - Call DaClos(iLu1) - -* -*-- Add external perturbation if requested. -* - If(AddExt) then - Write(6,*)' -- Adding external perturbation.' - nBTri=nBas(1)*(nBas(1)+1)/2 - Lu_One=49 - Lu_One=IsFreeUnit(Lu_One) - Call OpnOne(irc,0,'ONEINT',Lu_One) - Call GetMem('AOExt','Allo','Real',ipAOx,nBTri+4) - Call GetMem('TEMP','Allo','Real',iTEMP,nBas(1)*iOrb(1)) - Call GetMem('Final','Allo','Real',iFine,iOrb(1)**2) - Call GetMem('Squared','Allo','Real',iSqAO,nBas(1)**2) - Call GetMem('MOExt','Allo','Real',ipMOx,nSize) - Do 9901, iExt=1,nExtAddOns - irc=-1 - iopt=0 - iSmLbl=0 - Call RdOne(irc,iopt,ExtLabel(iExt),iCompExt(iExt),Work(ipAOx) - & ,iSmLbl) - Call DScal_(nBTri,ScalExt(iExt),Work(ipAOx),iONE) - If(irc.ne.0) then - Write(6,*) - Write(6,*)'ERROR when reading ',ExtLabel(iExt),'.' - Write(6,*)'Have Seward computed this integral?' - Call Quit(_RC_IO_ERROR_READ_) - Endif - Call Square(Work(ipAOx),Work(iSqAO),iONE,nBas(1),nBas(1)) - Call Dgemm_('T','N',iOrb(1),nBas(1),nBas(1),ONE,Work(iV1) - & ,nBas(1),Work(iSqAO),nBas(1),ZERO,Work(iTEMP) - & ,iOrb(1)) - Call Dgemm_('N','N',iOrb(1),iOrb(1),nBas(1),ONE,Work(iTEMP) - & ,iOrb(1),Work(iV1),nBas(1),ZERO,Work(iFine),iOrb(1)) - Call SqToTri_Q(Work(iFine),Work(ipMOx),iOrb(1)) - Call DaxPy_(nSize,ONE,Work(ipMOx),iONE,HHmat,iONE) -9901 Continue - Call GetMem('AOExt','Free','Real',ipAOx,nBTri+4) - Call GetMem('TEMP','Free','Real',iTEMP,nBas(1)*iOrb(1)) - Call GetMem('Final','Free','Real',iFine,iOrb(1)**2) - Call GetMem('Squared','Free','Real',iSqAO,nBas(1)**2) - Call GetMem('MOExt','Free','Real',ipMOx,nSize) - Call ClsOne(irc,Lu_One) - Endif - -* -*-- Now to the two-electron matrix elements. -* - iDisk=0 - Call iDaFile(iLu2,2,iTraToc,nTraToc,iDisk) - iDisk=iTraToc(1) - iSup=0 -*--- Ooohhhh, lets get crude! Read ALL (yes, you read right) integrals -* and then order them. - nBuf1=nOrbM(1)*(nOrbM(1)+1)/2 - nBuf2=nBuf1*(nBuf1+1)/2 -* -*--- Lets check if this construct is possible. If not advise user what -* to do. -* - Call GetMem('MAX','Max','Real',iDum,nMAX) - If(nMAX.lt.(nBuf2+nBuf1**2)) then - Write(6,*) - Write(6,*)' Too many MO-transformed two-electron integrals' - & //' from Motra. Do you need all?' - Write(6,*)' If not, then use the DELEte keyword in Motra' - & //' to remove the superfluous ones.' - Call Quit(_RC_GENERAL_ERROR_) - Endif -* -*--- Proceed! -* - Call GetMem('Buffer','Allo','Real',iBuff,nBuf2) - Call GetMem('Temporary','Allo','Real',iTEMP,nBuf1**2) - Call dDaFile(iLu2,2,Work(iBuff),nBuf2,iDisk) - Do 311, i=1,nBuf1 - Do 312, j=i,nBuf1 - iSup=iSup+1 - If(i.le.nSize.and.j.le.nSize) then - Work(iTEMP+(i-1)*nBuf1+j-1)=Work(iBuff+iSup-1) - Work(iTEMP+(j-1)*nBuf1+i-1)=Work(iBuff+iSup-1) - Endif -312 Continue -311 Continue - -* -* and sees to that right numbers get in the right place. -* - Do 321, i=1,iOrb(1) - Do 322, j=1,i - Do 323, k=1,i - llmax=k - If(i.eq.k) llmax=j - Do 324, l=1,llmax - ij=ipair_qmstat(i,j) - ik=ipair_qmstat(i,k) - il=ipair_qmstat(i,l) - jk=ipair_qmstat(j,k) - jl=ipair_qmstat(j,l) - kl=ipair_qmstat(k,l) - Work(iSupM+nSize*(ij-1)+kl-1)=Work(iTEMP+(ij-1)*nBuf1+kl-1) - &-(Work(iTEMP+(ik-1)*nBuf1+jl-1)+Work(iTEMP+(il-1)*nBuf1+jk-1))/4 - Work(iSupM+nSize*(kl-1)+ij-1)=Work(iSupM+nSize*(ij-1)+kl-1) - Work(iSupM+nSize*(ik-1)+jl-1)=Work(iTEMP+(ik-1)*nBuf1+jl-1) - &-(Work(iTEMP+(ij-1)*nBuf1+kl-1)+Work(iTEMP+(il-1)*nBuf1+jk-1))/4 - Work(iSupM+nSize*(jl-1)+ik-1)=Work(iSupM+nSize*(ik-1)+jl-1) - Work(iSupM+nSize*(il-1)+jk-1)=Work(iTEMP+(il-1)*nBuf1+jk-1) - &-(Work(iTEMP+(ik-1)*nBuf1+jl-1)+Work(iTEMP+(ij-1)*nBuf1+kl-1))/4 - Work(iSupM+nSize*(jk-1)+il-1)=Work(iSupM+nSize*(il-1)+jk-1) -324 Continue -323 Continue -322 Continue -321 Continue - Call GetMem('Buffer','Free','Real',iBuff,nBuf2) - Call GetMem('Temporary','Free','Real',iTEMP,nBuf1**2) - Call DaClos(iLu2) - -* -*-- Serious amount of printing! -* - If(iPrint.ge.35) then - Write(6,*) - Write(6,*)'The Super Matrix in all its divine g(l)ory:' - kaunter=0 - Do 331, i=1,iOrb(1) - Do 332, j=1,i - Write(firstind,'(I3,A,I3)')i,',',j - Call TriPrt(firstind,' ',Work(iSupM+nSize*kaunter),iOrb(1)) - kaunter=kaunter+1 -332 Continue -331 Continue - Write(6,*)'Super Matrix End.' - Endif - Write(6,*)'...Done!' - -* -*-- The end. -* - Return - End - - -* -*-- Little bastard. -* - Integer Function iPair_qmstat(a,b) - Implicit Integer (a-z) - iPair_qmstat=(Max(a,b)*(Max(a,b)-1))/2+Min(a,b) - Return - End diff -Nru openmolcas-22.02/src/qmstat/scfh0.F90 openmolcas-22.10/src/qmstat/scfh0.F90 --- openmolcas-22.02/src/qmstat/scfh0.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/scfh0.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,191 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! Read all MO-transformed integrals and construct zeroth Fock-matrix. +subroutine ScfH0(nBas) + +use qmstat_global, only: AddExt, ExtLabel, HHmat, iCompExt, iOrb, iPrint, MxSymQ, nExtAddOns, ScalExt, SupM, V1 +use Index_Functions, only: iTri, nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Quart +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nBas(MxSymQ) +#include "Molcas.fh" +#include "tratoc.fh" +integer(kind=iwp) :: i, iDisk, iExt, ij, ik, il, iLu1, iLu2, iopt, irc, iSmLbl, iSup, iToc(64), j, jk, jl, k, kaunter, kl, l, & + llmax, Lu_One, nBasM(MxSymQ), nBTri, nBuf1, nBuf2, nDelM(MxSymQ), nFroM(MxSymQ), nMAX, nOrbM(MxSymQ), nSize, & + nSymM +real(kind=wp) :: Ecor +character(len=LenIn8) :: NameM(maxbfn) +character(len=10) :: firstind +real(kind=wp), allocatable :: AOx(:), Buff(:), Fine(:,:), MOx(:), SqAO(:,:), TEMP(:,:) +integer(kind=iwp), external :: IsFreeUnit +#include "warnings.h" + +! Wilkommen. + +write(u6,*) +write(u6,*) +write(u6,*) 'Reading MO-transformed integrals. Zeroth hamiltonian constructed.' + +! Numbers and files. + +nSize = nTri_Elem(iOrb(1)) +call mma_allocate(SupM,nSize,nSize,label='SUPER') +iLu1 = 56 +iLu2 = 58 +call DaName(iLu1,'TRAONE') +call DaName(iLu2,'TRAINT') +iDisk = 0 +! This is special utility to read header of TRAONE. +call Wr_Motra_Info(iLu1,2,iDisk,iToc,64,Ecor,nSymM,nBasM,nOrbM,nFroM,nDelM,MxSymQ,NameM,LenIn8*maxbfn) + +! One checks. + +if (nBasM(1) /= nBas(1)) then + write(u6,*) + write(u6,*) ' ERROR! Conflict between one-electron file and MO-transformed one-electron file.' + write(u6,*) ' nBas=',nBas(1),' MO-nBas=',nBasM(1) + call Quit(_RC_GENERAL_ERROR_) +end if + +! Read one-electron matrix elements. + +iDisk = iToc(2) +call mma_allocate(HHmat,nSize,label='HHmat') +call dDaFile(iLu1,2,HHmat,nSize,iDisk) +call DaClos(iLu1) + +! Add external perturbation if requested. + +if (AddExt) then + write(u6,*) ' -- Adding external perturbation.' + nBTri = nTri_Elem(nBas(1)) + Lu_One = IsFreeUnit(49) + call OpnOne(irc,0,'ONEINT',Lu_One) + call mma_allocate(AOx,nBTri,label='AOExt') + call mma_allocate(TEMP,iOrb(1),nBas(1),label='TEMP') + call mma_allocate(Fine,iOrb(1),iOrb(1),label='Final') + call mma_allocate(SqAO,nBas(1),nBas(1),label='Squared') + call mma_allocate(MOx,nSize,label='MOExt') + do iExt=1,nExtAddOns + irc = -1 + iopt = 6 + iSmLbl = 0 + call RdOne(irc,iopt,ExtLabel(iExt),iCompExt(iExt),AOx,iSmLbl) + AOx(:) = AOx*ScalExt(iExt) + if (irc /= 0) then + write(u6,*) + write(u6,*) 'ERROR when reading ',ExtLabel(iExt),'.' + write(u6,*) 'Have Seward computed this integral?' + call Quit(_RC_IO_ERROR_READ_) + end if + call Square(AOx,SqAO,1,nBas(1),nBas(1)) + call Dgemm_('T','N',iOrb(1),nBas(1),nBas(1),One,V1,nBas(1),SqAO,nBas(1),Zero,TEMP,iOrb(1)) + call Dgemm_('N','N',iOrb(1),iOrb(1),nBas(1),One,TEMP,iOrb(1),V1,nBas(1),Zero,Fine,iOrb(1)) + call SqToTri_Q(Fine,MOx,iOrb(1)) + HHmat(:) = HHmat+MOx + end do + call mma_deallocate(AOx) + call mma_deallocate(TEMP) + call mma_deallocate(Fine) + call mma_deallocate(SqAO) + call mma_deallocate(MOx) + call ClsOne(irc,Lu_One) +end if + +! Now to the two-electron matrix elements. + +iDisk = 0 +call iDaFile(iLu2,2,iTraToc,nTraToc,iDisk) +iDisk = iTraToc(1) +iSup = 0 +! Ooohhhh, lets get crude! Read ALL (yes, you read right) integrals and then order them. +nBuf1 = nTri_Elem(nOrbM(1)) +nBuf2 = nTri_Elem(nBuf1) + +! Let's check if this construct is possible. If not advise user what to do. + +call mma_maxDBLE(nMAX) +if (nMAX < (nBuf2+nBuf1**2)) then + write(u6,*) + write(u6,*) ' Too many MO-transformed two-electron integrals from Motra. Do you need all?' + write(u6,*) ' If not, then use the DELEte keyword in Motra to remove the superfluous ones.' + call Quit(_RC_GENERAL_ERROR_) +end if + +! Proceed! + +call mma_allocate(Buff,nBuf2,label='Buffer') +call mma_allocate(TEMP,nBuf1,nBuf1,label='Temporary') +call dDaFile(iLu2,2,Buff,nBuf2,iDisk) +do i=1,nBuf1 + do j=i,nBuf1 + iSup = iSup+1 + if ((i <= nSize) .and. (j <= nSize)) then + TEMP(j,i) = Buff(iSup) + TEMP(i,j) = Buff(iSup) + end if + end do +end do + +! and see to that right numbers get in the right place. + +do i=1,iOrb(1) + do j=1,i + do k=1,i + llmax = k + if (i == k) llmax = j + do l=1,llmax + ij = iTri(i,j) + ik = iTri(i,k) + il = iTri(i,l) + jk = iTri(j,k) + jl = iTri(j,l) + kl = iTri(k,l) + SupM(kl,ij) = TEMP(kl,ij)-(TEMP(jl,ik)+TEMP(jk,il))*Quart + SupM(ij,kl) = SupM(kl,ij) + SupM(jl,ik) = TEMP(jl,ik)-(TEMP(kl,ij)+TEMP(jk,il))*Quart + SupM(ik,jl) = SupM(jl,ik) + SupM(jk,il) = TEMP(jk,il)-(TEMP(jl,ik)+TEMP(kl,ij))*Quart + SupM(il,jk) = SupM(jk,il) + end do + end do + end do +end do +call mma_deallocate(Buff) +call mma_deallocate(TEMP) +call DaClos(iLu2) + +! Serious amount of printing! + +if (iPrint >= 35) then + write(u6,*) + write(u6,*) 'The Super Matrix in all its divine g(l)ory:' + kaunter = 0 + do i=1,iOrb(1) + do j=1,i + write(firstind,'(I3,A,I3)') i,',',j + kaunter = kaunter+1 + call TriPrt(firstind,' ',SupM(:,kaunter),iOrb(1)) + end do + end do + write(u6,*) 'Super Matrix End.' +end if +write(u6,*) '...Done!' + +! The end. + +return + +end subroutine ScfH0 diff -Nru openmolcas-22.02/src/qmstat/scfhandm.f openmolcas-22.10/src/qmstat/scfhandm.f --- openmolcas-22.02/src/qmstat/scfhandm.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/scfhandm.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,268 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Anders Ohrn * -************************************************************************ -* ScfHandM -* -*> @brief -*> (i) construct the multicenter multipole expansion for the MO-Hamiltonian, -*> (ii) read in the one-electron part of the Hamiltonian and -*> (iii) construct the super-matrix. The last two are MO-transformed -*> @author A. Ohrn -*> -*> @details -*> First call on the MME-routine. It returns things in AO-basis -*> which we need to put into MO-form. Observe that the quadrupoles -*> in Qmstat are ordered differently compared to Molcas. Qmstat: -*> \f$ xx \f$ \f$ xy \f$ \f$ yy \f$ \f$ xz \f$ \f$ yz \f$ \f$ zz \f$; Molcas: -*> \f$ xx \f$ \f$ xy \f$ \f$ xz \f$ \f$ yy \f$ \f$ yz \f$ \f$ zz \f$. Then we -*> read in parts of the unperturbed Hamiltonian and construct the -*> super-matrix. -*> -*> @param[in] Cmo Orbital coeff. -*> @param[in] nBas Number of contracted basis functions -*> @param[in] nOcc Number of contracted basis functions of a certain atom-type -*> @param[in] natyp Number of atoms of a certain atom-type (for water, hydrogen is 2) -*> @param[in] nntyp Number of atom-types in molecule -*> @param[in] Occu Orbital occupation numbers -************************************************************************ - Subroutine ScfHandM(Cmo,nBas,iQ_Atoms,nOcc,natyp,nntyp,Occu) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "qmcom.fh" -#include "qm1.fh" -#include "WrkSpc.fh" -#include "tratoc.fh" - - Dimension Cmo(MxBas**2),Occu(MxBas),nOcc(MxBas),natyp(MxAt) - Dimension nBas(MxSym),iCent(MxBas*MxBas) - Dimension iMME(MxMltp*(MxMltp+1)*(MxMltp+2)/6) - Character MMElab*20,ChCo*2 - -*----------------------------------------------------------------------* -* Zeros. * -*----------------------------------------------------------------------* - iCi=iQ_Atoms*(iQ_Atoms+1)/2 - Do 51, i=1,iOrb(1)*(iOrb(1)+1)/2 - Do 52, j=1,iCi - Cha(i,j)=0 - DipMy(i,1,j)=0 - DipMy(i,2,j)=0 - DipMy(i,3,j)=0 - Quad(i,1,j)=0 - Quad(i,2,j)=0 - Quad(i,3,j)=0 - Quad(i,4,j)=0 - Quad(i,5,j)=0 - Quad(i,6,j)=0 -52 Continue -51 Continue - -* -*-- MulticenterMultipoleExpansion -* -* -*--- First get the expansion in AO-format. -* - Call GetMem('Dummy','Allo','Inte',iDum,nBas(1)**2) - Call MultiNew(iQ_Atoms,nBas(1),nOcc,natyp,nntyp,iMME - & ,iWork(iDum),iCent,nMlt,outxyz - & ,SlExpQ,lSlater) - Call GetMem('Dummy','Free','Inte',iDum,nBas(1)**2) - -* -*-- If MP2 density correction is requested, go here. This option is -* not working nicely, alas, hence do not use! -* - If(Mp2DensCorr) then - Call Mbpt2Corr(nBas(1),Cmo) - Endif - -* -*--- Then transform this to MO-format since that is the basis we use -* here! -* - nTyp=0 - Do 100, i=1,nMlt - nTyp=nTyp+i*(i+1)/2 -100 Continue - Call GetMem('OnTheWay','Allo','Real',ipO,nTyp) - kaunter=0 - Do 101, iO1=1,iOrb(1) - Do 102, iO2=1,iO1 - kaunter=kaunter+1 - kaunta=0 - Do 103, iB1=1,nBas(1) - Do 104, iB2=1,nBas(1) - kaunta=kaunta+1 - iX1=max(iB1,iB2) - iX2=min(iB1,iB2) - indMME=iX2+iX1*(iX1-1)/2 - cProd=Cmo(iB1+(iO1-1)*nBas(1))*Cmo(iB2+(iO2-1)*nBas(1)) - Do 105, iTyp=1,nTyp - Work(ipO+iTyp-1)=cProd*Work(iMME(iTyp)+indMME-1) -105 Continue - Cha(kaunter,iCent(kaunta))=Cha(kaunter,iCent(kaunta)) - & +Work(ipO) - DipMy(kaunter,1,iCent(kaunta))=DipMy(kaunter,1,iCent(kaunta)) - & +Work(ipO+1) - DipMy(kaunter,2,iCent(kaunta))=DipMy(kaunter,2,iCent(kaunta)) - & +Work(ipO+2) - DipMy(kaunter,3,iCent(kaunta))=DipMy(kaunter,3,iCent(kaunta)) - & +Work(ipO+3) - Quad(kaunter,1,iCent(kaunta))=Quad(kaunter,1,iCent(kaunta)) - & +Work(ipO+4) - Quad(kaunter,2,iCent(kaunta))=Quad(kaunter,2,iCent(kaunta)) - & +Work(ipO+5) - Quad(kaunter,3,iCent(kaunta))=Quad(kaunter,3,iCent(kaunta)) - & +Work(ipO+7) !Why seven? See <Description> - Quad(kaunter,4,iCent(kaunta))=Quad(kaunter,4,iCent(kaunta)) - & +Work(ipO+6) - Quad(kaunter,5,iCent(kaunta))=Quad(kaunter,5,iCent(kaunta)) - & +Work(ipO+8) - Quad(kaunter,6,iCent(kaunta))=Quad(kaunter,6,iCent(kaunta)) - & +Work(ipO+9) -104 Continue -103 Continue -102 Continue -101 Continue - Call GetMem('OnTheWay','Free','Real',ipO,nTyp) - -* -*-- Deallocate the AO-multipoles. -* - Do 106,i=1,nTyp - Write(ChCo,'(I2.2)')i - Write(MMElab,*)'MME'//ChCo - Call GetMem(MMElab,'Free','Real',iMME(i),nBas(1)*(nBas(1)+1)/2) -106 Continue - -* -*-- Put quadrupoles in Buckinghamform. -* - kaunter=0 - Do 191, i1=1,iOrb(1) - Do 192, i2=1,i1 - kaunter=kaunter+1 - Do 193, k=1,ici - Do 194, j=1,6 - Quad(kaunter,j,k)=Quad(kaunter,j,k)*1.5 -194 Continue - Tra=Quad(kaunter,1,k)+Quad(kaunter,3,k) - & +Quad(kaunter,6,k) - Tra=Tra/3 - Quad(kaunter,1,k)=Quad(kaunter,1,k)-Tra - Quad(kaunter,3,k)=Quad(kaunter,3,k)-Tra - Quad(kaunter,6,k)=Quad(kaunter,6,k)-Tra -193 Continue -192 Continue -191 Continue -*----------------------------------------------------------------------* -* To conclude, we sum up. This serves two purposes: (1) to make a check* -* if thing have proceeded nicely, (2) to deduce if the QM-molecule is * -* charged. * -*----------------------------------------------------------------------* - qEl=0 - dipx=0 - dipy=0 - dipz=0 - dipx0=0 - dipy0=0 - dipz0=0 - qtot=0 - dTox=0 - dToy=0 - dToz=0 - Call GetMem('TotMME','Allo','Real',iMtot - & ,10*iQ_Atoms*(iQ_Atoms+1)/2) - Call dCopy_(10*iQ_Atoms*(iQ_Atoms+1)/2,[0.0D0],0,Work(iMtot),1) - Do 110, ii=1,iOrb(1) - i=ii*(ii+1)/2 - Do 111, j=1,iQ_Atoms*(iQ_Atoms+1)/2 - qEl=qEl+Cha(i,j)*Occu(ii) - Work(iMtot+10*(j-1))=Work(iMtot+10*(j-1))+Cha(i,j)*Occu(ii) - dipx=dipx+DipMy(i,1,j)*Occu(ii) - dipy=dipy+DipMy(i,2,j)*Occu(ii) - dipz=dipz+DipMy(i,3,j)*Occu(ii) - Work(iMtot+10*(j-1)+1)=Work(iMtot+10*(j-1)+1) - & +DipMy(i,1,j)*Occu(ii) - Work(iMtot+10*(j-1)+2)=Work(iMtot+10*(j-1)+2) - & +DipMy(i,2,j)*Occu(ii) - Work(iMtot+10*(j-1)+3)=Work(iMtot+10*(j-1)+3) - & +DipMy(i,3,j)*Occu(ii) - dipx0=dipx0+Cha(i,j)*outxyz(j,1)*Occu(ii) - dipy0=dipy0+Cha(i,j)*outxyz(j,2)*Occu(ii) - dipz0=dipz0+Cha(i,j)*outxyz(j,3)*Occu(ii) - Work(iMtot+10*(j-1)+4)=Work(iMtot+10*(j-1)+4) - & +Quad(i,1,j)*Occu(ii) - Work(iMtot+10*(j-1)+5)=Work(iMtot+10*(j-1)+5) - & +Quad(i,2,j)*Occu(ii) - Work(iMtot+10*(j-1)+6)=Work(iMtot+10*(j-1)+6) - & +Quad(i,3,j)*Occu(ii) - Work(iMtot+10*(j-1)+7)=Work(iMtot+10*(j-1)+7) - & +Quad(i,4,j)*Occu(ii) - Work(iMtot+10*(j-1)+8)=Work(iMtot+10*(j-1)+8) - & +Quad(i,5,j)*Occu(ii) - Work(iMtot+10*(j-1)+9)=Work(iMtot+10*(j-1)+9) - & +Quad(i,6,j)*Occu(ii) -111 Continue -110 Continue - If(iPrint.ge.10) then - Write(6,*) - Write(6,*)' Distributed multipole in each centre' - Write(6,*)' (Compare with output from MpProp.)' - Do 1111, j=1,iQ_Atoms*(iQ_Atoms+1)/2 - If(j.le.iQ_Atoms) then - Work(iMtot+10*(j-1))=Work(iMtot+10*(j-1))-Chanuc(j) - Endif - Write(6,*)' Center: ',j - Write(6,*)' Charge: ',-Work(iMtot+10*(j-1)) - Write(6,*)' Dipole: ',(-Work(iMtot+10*(j-1)+kk),kk=1,3) - Write(6,*) -1111 Continue - Endif - Call GetMem('TotMME','Free','Real',iMtot - & ,4*iQ_Atoms*(iQ_Atoms+1)/2) - Do 112, i=1,iQ_Atoms - qtot=qtot+ChaNuc(i) - dTox=dTox+ChaNuc(i)*outxyz(i,1) - dToy=dToy+ChaNuc(i)*outxyz(i,2) - dToz=dToz+ChaNuc(i)*outxyz(i,3) -112 Continue - qtot=qtot-qEl - dTox=dTox-dipx-dipx0 - dToy=dToy-dipy-dipy0 - dToz=dToz-dipz-dipz0 - If(iPrint.ge.5) then - Write(6,*) - Write(6,*)' Summed multipoles for unperturbed w.f.' - Write(6,*)' Charge: ',qtot - Write(6,*)' Dipole: ',dTox,',',dToy,',',dToz - Endif - If(.not.abs(qtot).le.0.0001) ChargedQM=.true. - -* -*-- Make a check of the one-electron matrix: is it pure? -* - Call Chk_OneHam(nBas) - -* -*-- So read integrals and construct super-matrix. -* - Call ScfH0(nBas) - -* -*-- The End... -* - Return - End diff -Nru openmolcas-22.02/src/qmstat/scfhandm.F90 openmolcas-22.10/src/qmstat/scfhandm.F90 --- openmolcas-22.02/src/qmstat/scfhandm.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/scfhandm.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,216 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Anders Ohrn * +!*********************************************************************** +! ScfHandM +! +!> @brief +!> (i) construct the multicenter multipole expansion for the MO-Hamiltonian, +!> (ii) read in the one-electron part of the Hamiltonian and +!> (iii) construct the super-matrix. The last two are MO-transformed +!> @author A. Ohrn +!> +!> @details +!> First call on the MME-routine. It returns things in AO-basis +!> which we need to put into MO-form. Observe that the quadrupoles +!> in Qmstat are ordered differently compared to Molcas. Qmstat: +!> \f$ xx \f$ \f$ xy \f$ \f$ yy \f$ \f$ xz \f$ \f$ yz \f$ \f$ zz \f$; Molcas: +!> \f$ xx \f$ \f$ xy \f$ \f$ xz \f$ \f$ yy \f$ \f$ yz \f$ \f$ zz \f$. Then we +!> read in parts of the unperturbed Hamiltonian and construct the +!> super-matrix. +!> +!> @param[in] Cmo Orbital coeff. +!> @param[in] nBas Number of contracted basis functions +!> @param[in] iQ_Atoms +!> @param[in] nOcc Number of contracted basis functions of a certain atom-type +!> @param[in] natyp Number of atoms of a certain atom-type (for water, hydrogen is 2) +!> @param[in] nntyp Number of atom-types in molecule +!> @param[in] Occu Orbital occupation numbers +!*********************************************************************** + +subroutine ScfHandM(Cmo,nBas,iQ_Atoms,nOcc,natyp,nntyp,Occu) + +use qmstat_global, only: Cha, ChaNuc, ChargedQM, DipMy, iOrb, iPrint, lSlater, Mp2DensCorr, MxMltp, MxSymQ, nMlt, outxyz, qTot, Quad +use Index_Functions, only: iTri, nTri3_Elem, nTri_Elem +use Data_Structures, only: Alloc1DArray_Type, Allocate_DT, Deallocate_DT +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, Three, OneHalf +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nBas(MxSymQ), iQ_Atoms, nntyp, nOcc(nntyp), natyp(nntyp) +real(kind=wp), intent(in) :: Cmo(nBas(1),nBas(1)), Occu(nBas(1)) +integer(kind=iwp) :: i, i1, i2, iB1, iB2, iCi, ii, indMME, iO1, iO2, iTyp, j, k, kaunta, kaunter, nTyp +real(kind=wp) :: cProd, dipx, dipx0, dipy, dipy0, dipz, dipz0, dTox, dToy, dToz, qEl, Tra +integer(kind=iwp), allocatable :: Dum(:), iCent(:,:) +real(kind=wp), allocatable :: Mtot(:,:), O(:) +type(Alloc1DArray_Type), allocatable :: MME(:) + +iCi = nTri_Elem(iQ_Atoms) +call mma_allocate(Cha,nTri_Elem(iOrb(1)),iCi,label='Cha') +call mma_allocate(DipMy,nTri_Elem(iOrb(1)),3,iCi,label='DipMy') +call mma_allocate(Quad,nTri_Elem(iOrb(1)),6,iCi,label='Quad') + +!----------------------------------------------------------------------* +! Zeros. * +!----------------------------------------------------------------------* +Cha(:,:) = Zero +DipMy(:,:,:) = Zero +Quad(:,:,:) = Zero + +! MulticenterMultipoleExpansion + +! First get the expansion in AO-format. + +call mma_allocate(outxyz,3,nTri_Elem(iQ_Atoms),label='outxyz') +call mma_allocate(iCent,nBas(1),nBas(1),label='iCent') +call mma_allocate(Dum,nTri_Elem(nBas(1)),label='Dummy') +call Allocate_DT(MME,[1,nTri3_Elem(MxMltp)],label='MME') +call MultiNew(iQ_Atoms,nBas(1),nOcc,natyp,nntyp,MME,Dum,iCent,nMlt,outxyz,lSlater) +call mma_deallocate(Dum) + +! If MP2 density correction is requested, go here. This option is +! not working nicely, alas, hence do not use! + +if (Mp2DensCorr) call Mbpt2Corr(nBas(1),Cmo) + +! Then transform this to MO-format since that is the basis we use here! + +nTyp = 0 +do i=1,nMlt + nTyp = nTyp+nTri_Elem(i) +end do +call mma_allocate(O,nTyp,label='OnTheWay') +kaunter = 0 +do iO1=1,iOrb(1) + do iO2=1,iO1 + kaunter = kaunter+1 + do iB1=1,nBas(1) + do iB2=1,nBas(1) + kaunta = iCent(iB2,iB1) + indMME = iTri(iB1,iB2) + cProd = Cmo(iB1,iO1)*Cmo(iB2,iO2) + do iTyp=1,nTyp + O(iTyp) = cProd*MME(iTyp)%A(indMME) + end do + Cha(kaunter,kaunta) = Cha(kaunter,kaunta)+O(1) + DipMy(kaunter,1,kaunta) = DipMy(kaunter,1,kaunta)+O(2) + DipMy(kaunter,2,kaunta) = DipMy(kaunter,2,kaunta)+O(3) + DipMy(kaunter,3,kaunta) = DipMy(kaunter,3,kaunta)+O(4) + Quad(kaunter,1,kaunta) = Quad(kaunter,1,kaunta)+O(5) + Quad(kaunter,2,kaunta) = Quad(kaunter,2,kaunta)+O(6) + Quad(kaunter,3,kaunta) = Quad(kaunter,3,kaunta)+O(8) !Why eight? See @details + Quad(kaunter,4,kaunta) = Quad(kaunter,4,kaunta)+O(7) + Quad(kaunter,5,kaunta) = Quad(kaunter,5,kaunta)+O(9) + Quad(kaunter,6,kaunta) = Quad(kaunter,6,kaunta)+O(10) + end do + end do + end do +end do +call mma_deallocate(O) +call mma_deallocate(iCent) + +! Deallocate the AO-multipoles. + +call Deallocate_DT(MME) + +! Put quadrupoles in Buckingham form. + +Quad(:,:,:) = Quad*OneHalf +kaunter = 0 +do i1=1,iOrb(1) + do i2=1,i1 + kaunter = kaunter+1 + do k=1,iCi + Tra = (Quad(kaunter,1,k)+Quad(kaunter,3,k)+Quad(kaunter,6,k))/Three + Quad(kaunter,1,k) = Quad(kaunter,1,k)-Tra + Quad(kaunter,3,k) = Quad(kaunter,3,k)-Tra + Quad(kaunter,6,k) = Quad(kaunter,6,k)-Tra + end do + end do +end do +!----------------------------------------------------------------------* +! To conclude, we sum up. This serves two purposes: (1) to make a check* +! if things have proceeded nicely, (2) to deduce if the QM-molecule is * +! charged. * +!----------------------------------------------------------------------* +qEl = Zero +dipx = Zero +dipy = Zero +dipz = Zero +dipx0 = Zero +dipy0 = Zero +dipz0 = Zero +qtot = Zero +dTox = Zero +dToy = Zero +dToz = Zero +call mma_allocate(Mtot,10,nTri_Elem(iQ_Atoms),label='TotMME') +Mtot(:,:) = Zero +do ii=1,iOrb(1) + i = ntri_Elem(ii) + do j=1,nTri_Elem(iQ_Atoms) + qEl = qEl+Cha(i,j)*Occu(ii) + Mtot(1,j) = Mtot(1,j)+Cha(i,j)*Occu(ii) + dipx = dipx+DipMy(i,1,j)*Occu(ii) + dipy = dipy+DipMy(i,2,j)*Occu(ii) + dipz = dipz+DipMy(i,3,j)*Occu(ii) + Mtot(2:4,j) = Mtot(2:4,j)+DipMy(i,1:3,j)*Occu(ii) + dipx0 = dipx0+Cha(i,j)*outxyz(1,j)*Occu(ii) + dipy0 = dipy0+Cha(i,j)*outxyz(2,j)*Occu(ii) + dipz0 = dipz0+Cha(i,j)*outxyz(3,j)*Occu(ii) + Mtot(5:10,j) = Mtot(5:10,j)+Quad(i,1:6,j)*Occu(ii) + end do +end do +if (iPrint >= 10) then + write(u6,*) + write(u6,*) ' Distributed multipole in each centre' + write(u6,*) ' (Compare with output from MpProp.)' + do j=1,nTri_Elem(iQ_Atoms) + if (j <= iQ_Atoms) Mtot(1,j) = Mtot(1,j)-ChaNuc(j) + write(u6,*) ' Center: ',j + write(u6,*) ' Charge: ',-Mtot(1,j) + write(u6,*) ' Dipole: ',-Mtot(2:4,j) + write(u6,*) + end do +end if +call mma_deallocate(Mtot) +do i=1,iQ_Atoms + qtot = qtot+ChaNuc(i) + dTox = dTox+ChaNuc(i)*outxyz(1,i) + dToy = dToy+ChaNuc(i)*outxyz(2,i) + dToz = dToz+ChaNuc(i)*outxyz(3,i) +end do +qtot = qtot-qEl +dTox = dTox-dipx-dipx0 +dToy = dToy-dipy-dipy0 +dToz = dToz-dipz-dipz0 +if (iPrint >= 5) then + write(u6,*) + write(u6,*) ' Summed multipoles for unperturbed w.f.' + write(u6,*) ' Charge: ',qtot + write(u6,*) ' Dipole: ',dTox,',',dToy,',',dToz +end if +if (abs(qtot) > 1.0e-4_wp) ChargedQM = .true. + +! Make a check of the one-electron matrix: is it pure? + +call Chk_OneHam(nBas) + +! So read integrals and construct super-matrix. + +call ScfH0(nBas) + +! The End... + +return + +end subroutine ScfHandM diff -Nru openmolcas-22.02/src/qmstat/singp.f openmolcas-22.10/src/qmstat/singp.f --- openmolcas-22.02/src/qmstat/singp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/singp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,103 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine SingP(nCalls,iQ_Atoms,ipStoreCoo,nPart2) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "qminp.fh" -#include "WrkSpc.fh" - -* -*-- If this is first call, issue a warning. -* - If(nCalls.eq.0) then - Write(6,*) - Write(6,*) - Write(6,*)'---->>> WARNING <<<----' - Write(6,*) - Write(6,*)'You have specified that a set of single-point ' - &//'calculations are to be preformed.' - Write(6,*)'This means that the input will be given to some ' - &//'extent a new meaning.' - Write(6,*) - -* -*-- Put coordinates in a new vector if first call. -* - kaunter=0 - nPart2=nPart - Call GetMem('Store','Allo','Real',ipStoreCoo,nPart2*nCent*3) - Do 11, iPart=1,nPart2 - Do 12, iCent=1,nCent - kaunter=kaunter+1 - Work(ipStoreCoo+3*(kaunter-1))=Cordst(kaunter,1) - Work(ipStoreCoo+3*(kaunter-1)+1)=Cordst(kaunter,2) - Work(ipStoreCoo+3*(kaunter-1)+2)=Cordst(kaunter,3) -12 Continue -11 Continue - -* -*-- Put dummies that will be substituted for the qm-region. -* - nAllQm=(((iQ_Atoms-1)/nAtom)+1)*nCent - Do 16, i=1,nAllQm - Do 17, j=1,3 - Cordst(i,j)=0.0d0 -17 Continue -16 Continue - -* -*-- Put the coordinates of first iteration. -* - Do 18, iCent=1,nCent - Cordst(nAllQm+iCent,1)=Work(ipStoreCoo+3*(iCent-1)) - Cordst(nAllQm+iCent,2)=Work(ipStoreCoo+3*(iCent-1)+1) - Cordst(nAllQm+iCent,3)=Work(ipStoreCoo+3*(iCent-1)+2) -18 Continue - -* -*-- Set new value on some variables. -* - nMicro=1 - nMacro=1 - DelX=0 - DelFi=0 - DelR=0 - QmEq=.true. - nPart=(nAllQm/nCent)+1 - Write(6,*) - Write(6,*)'Resetting for FIT:' - Write(6,*)'Number of macrosteps:',nMacro - Write(6,*)'Number of microsteps:',nMicro - Write(6,*)'No translation, rotation or radie modification.' - Write(6,*)'Take the QmEq path.' - -* -*-- If not first call, then collect relevant coordinates. -* - Else - Initial1=(((iQ_Atoms-1)/nAtom)+1)*nCent - Initial2=3*nCent*nCalls-1 - Do 21, iCent=1,nCent - Cordst(Initial1+iCent,1)=Work(ipStoreCoo+Initial2+(iCent-1)*3+1) - Cordst(Initial1+iCent,2)=Work(ipStoreCoo+Initial2+(iCent-1)*3+2) - Cordst(Initial1+iCent,3)=Work(ipStoreCoo+Initial2+(iCent-1)*3+3) -21 Continue - Endif - -* -*-- Up-date nCalls. -* - nCalls=nCalls+1 - - - Return - End diff -Nru openmolcas-22.02/src/qmstat/singp.F90 openmolcas-22.10/src/qmstat/singp.F90 --- openmolcas-22.02/src/qmstat/singp.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/singp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,83 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine SingP(nCalls,iQ_Atoms,StoreCoo) + +use qmstat_global, only: Cordst, DelFi, DelR, DelX, nAtom, nCent, nMacro, nMicro, nPart, Qmeq +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(inout) :: nCalls +integer(kind=iwp), intent(in) :: iQ_Atoms +real(kind=wp), intent(inout) :: StoreCoo(3,nCent,nPart) +integer(kind=iwp) :: iCent, Initial1, iPart, kaunter, nAllQm + +if (nCalls == 0) then + ! If this is first call, issue a warning. + + write(u6,*) + write(u6,*) + write(u6,*) '---->>> WARNING <<<----' + write(u6,*) + write(u6,*) 'You have specified that a set of single-point calculations are to be performed.' + write(u6,*) 'This means that the input will be given to some extent a new meaning.' + write(u6,*) + + ! Put coordinates in a new vector if first call. + + kaunter = 0 + do iPart=1,nPart + do iCent=1,nCent + kaunter = kaunter+1 + StoreCoo(:,iCent,iPart) = Cordst(:,kaunter) + end do + end do + + ! Put dummies that will be substituted for the qm-region. + + nAllQm = (((iQ_Atoms-1)/nAtom)+1)*nCent + Cordst(:,1:nAllQm) = Zero + + ! Put the coordinates of first iteration. + + Cordst(:,nAllQm+1:nAllQm+nCent) = StoreCoo(:,:,1) + + ! Set new value on some variables. + + nMicro = 1 + nMacro = 1 + DelX = Zero + DelFi = Zero + DelR = Zero + QmEq = .true. + nPart = (nAllQm/nCent)+1 + write(u6,*) + write(u6,*) 'Resetting for FIT:' + write(u6,*) 'Number of macrosteps:',nMacro + write(u6,*) 'Number of microsteps:',nMicro + write(u6,*) 'No translation, rotation or radie modification.' + write(u6,*) 'Take the QmEq path.' + +else + ! If not first call, then collect relevant coordinates. + + Initial1 = (((iQ_Atoms-1)/nAtom)+1)*nCent + Cordst(:,Initial1+1:Initial1+nCent) = StoreCoo(:,:,nCalls+1) +end if + +! Update nCalls. + +nCalls = nCalls+1 + +return + +end subroutine SingP diff -Nru openmolcas-22.02/src/qmstat/sl_grad.f openmolcas-22.10/src/qmstat/sl_grad.f --- openmolcas-22.02/src/qmstat/sl_grad.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/sl_grad.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1098 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -* Sl_Grad -* -*> @brief -*> This subroutine is taken from the Anders program called Diffsph that calculates -*> the Coulombic interaction between two Slater-type densities -*> @author A. Ohrn -*> @modified_by Jose -*> -*> @details -*> The subroutine (originally called ``Coulomb``) is taken and simplified -*> to QmStat purposes. Molecule A is going to be always the Solvent -*> Molecule and Molecule B the Quantum system. The subroutine is -*> writen for one center in the QM system, so it is called for each -*> center of the QM, and gives the Potential, Field and Field gradient -*> generated by all centers of the classical molecule in this center of the -*> QM molecule but considering the penetration. The original subroutine is for -*> classical molecules with as S (charge) slater distribution and a P -*> (dipole) distribution and it is not ready for Qmstat purposes. -*> Quantum molecule is represented up to \f$ L = 2 \f$. Interaction with -*> Multipole distributed Quadrupoles can be treated using an S -*> distribution in the clasical molecules. However a ``Logical`` -*> variable is introduced to avoid the evaluation of this -*> iteraction and perform (in QmStat) less cumbersome calculations -*> using point charges in the classical molecule. -*> -*> This subroutine works with the Molcas order for the quadrupoles -*> \f$ xx=1 \f$, \f$ xy=2 \f$, \f$ xz=3 \f$, \f$ yy=4 \f$, \f$ yz=5 \f$ and \f$ zz=6 \f$ -*> So the \p EintSl have to be changed outside the subroutine -*> to be adapted to the QmStat order -*> \f$ xx=1 \f$, \f$ xy=2 \f$, \f$ yy=3 \f$, \f$ xz=4 \f$, \f$ yz=5 \f$ and \f$ zz=6 \f$ -*> The subroutine has the parameter \c MxMltp that should be -*> changed if higher multipoles are included. -************************************************************************ - Subroutine Sl_Grad(nCentA,lMaxA,Coord,Dist,DInv - & ,ExpoA,FactorA,SlPA,lMaxB,ExpoB,dNeigh - & ,EintSl,EintSl_Nuc,lAtom) - Implicit Real*8 (a-h,o-z) - -#include "warnings.h" - - Parameter (MxMltp=2,MxK=(MxMltp*(MxMltp**2+6*MxMltp+11)+6)/6) - - Dimension Coord(3,nCentA),Dist(nCentA),DInv(nCentA) - Dimension FactorA(4,nCentA),ExpoA(2,nCentA) - Dimension SlPA(nCentA),ExpoB(MxMltp+1) - - Dimension EintSl(MxK),Colle(3) - Dimension TMPA((MxMltp+1)*(MxMltp+2)/2) - Dimension Rotte(3,3),v(3),TR(6,6) - - Logical lDiffA,lDiffB,lTooSmall,lAtom - - -*-- Some zeros. - Do ijhr=1,MxK - EintSl(ijhr)=0.0d0 - End do - EintSl_Nuc=0.0d0 - -* -*-- Loop over all centers in molecule A. -* - Do iCA=1,nCentA - v(1)=Coord(1,iCA) - v(2)=Coord(2,iCA) - v(3)=Coord(3,iCA) - R=Dist(iCA) - Rinv=DInv(iCA) - -* -*---- Obtain rotation matrix. -* - Call Revolution(v,Rinv,Rotte) - -*--------- Obtain the Matrix used to transform the Quadrupoles -* This 6x6 matrix is really 6 matrix of 3x3 in diagonal form -* Each element of each matrix gives the contribution from the -* old quadrupole to the new quadrupole (new coordinate system) -* Thus, if xx=1, xy=2, xz=3, yy=4, yz=5 and zz=6 -* QNew(1)=Qold(1)*TD(1,1)+Qold(2)*TD(1,2)+Qold(3)+TD(1,3)+... -* So, to get field gradient for xx from the sigma interaction -* (see Anders paper) we have -* FG(xx)=FGSigma*(TD(6,1)-0.5(TD(1,1)*TD(4,1))) . Remember that -* the Energy contribution in sigma is calculated using spherical -* armonics so ESigma=FGSigma(Qnew(6)-0.5(Qnew(1)+Qnew(4))) -* - Call M2Trans(Rotte,TR) -* -*---- Loop over centres on A. Suck out exponents, factors and -* point-part. Rotate multipole. -* - Do iLA=0,lMaxA - EA=ExpoA(iLA+1,iCA) - lDiffA=EA.gt.-1.0d0 - nS=iLA*(iLA+1)*(iLA+2)/6 - nT=(iLA+1)*(iLA+2)*(iLA+3)/6 - kaunt=0 - Do kComp=nS+1,nT - kaunt=kaunt+1 - TMPA(kaunt)=FactorA(kComp,iCA) - Enddo -* -*------ Rotate and go over to spherical representation. -* - Sigge=-1.0d0 - Call Rotation_qmstat(iLA,TMPA,Rotte,Sigge) - -* -*------- Jose. Only one center in B so not loop over centres on B. -* Not Suck out Factors since we do not use them here. -* - - Do iLB=0,lMaxB - EB=ExpoB(iLB+1) - lDiffB=EB.gt.-1.0d0 -* -*-------- There is not rotation of Multipoles in B since we do not use them. -* - -* -*---- ELECTRON--ELECTRON. -* -* -*------ Both diffuse. -* - EAp=0.5d0*EA - EBp=0.5d0*EB - If(lDiffA.and.lDiffB) then - Call TKP(Tau,dKappa,Rho,RhoA,RhoB,EAp,EBp,R - & ,dNeigh,lTooSmall) - Call ABBoth(iLA,iLB,TMPA - & ,Tau,dKappa,Rho,RhoA,RhoB - & ,Rinv,lTooSmall,Colle) - If(iLB.eq.0) then - EintSl(1)=EintSl(1)+Colle(1) - Else ! if iLB not 0 then it is 1 - If(iLA.eq.0) then - Do ijhr=1,3 - EintSl(ijhr+1)=EintSl(ijhr+1) - & +Colle(1)*Rotte(3,ijhr) - End do - Else ! if iLA is not 0 is 1 - Do ijhr=1,3 - EintSl(ijhr+1)=EintSl(ijhr+1) - & +Colle(1)*Rotte(3,ijhr)+Colle(2)*Rotte(1,ijhr) - & +Colle(3)*Rotte(2,ijhr) - End do - Endif - Endif -* -*------ One diffuse, one not diffuse. -* - ElseIf(lDiffA.and..not.lDiffB) then - Call ABOne(iLA,iLB,TMPA - & ,EAp,R,Rinv,Colle,lDiffA) - If(iLB.eq.0) then - EintSl(1)=EintSl(1)+Colle(1) - ElseIf(iLB.eq.1) then - If(iLA.eq.0) then - Do ijhr=1,3 - EintSl(ijhr+1)=EintSl(ijhr+1) - & +Colle(1)*Rotte(3,ijhr) - End do - Else ! if iLA not 0 then it is 1 - Do ijhr=1,3 - EintSl(ijhr+1)=EintSl(ijhr+1) - & +Colle(1)*Rotte(3,ijhr) - & +Colle(2)*Rotte(1,ijhr) - & +Colle(3)*Rotte(2,ijhr) - End do - Endif - ElseIf(iLB.eq.2) then - If(iLA.eq.0) then - Do ijhr=1,6 ! Remember Qsigma=z2-0.5(x2+y2) - EintSl(ijhr+4)=EintSl(ijhr+4) - & +Colle(1)*(TR(6,ijhr)-0.5d0*(TR(1,ijhr) - & +TR(4,ijhr))) - End do - Else ! if iLA not 0 then it is 1 - Do ijhr=1,6 ! Remember Qsigma=z2-0.5(x2+y2) - ! QPi1=sqrt(3)*xz - ! QPi2=sqrt(3)*yz - EintSl(ijhr+4)=EintSl(ijhr+4) - & +Colle(1)*(TR(6,ijhr)-0.5d0*(TR(1,ijhr) - & +TR(4,ijhr))) - & +Colle(2)*sqrt(3.0d0)*TR(3,ijhr) - & +Colle(3)*sqrt(3.0d0)*TR(5,ijhr) - End do - Endif - Endif - - ElseIf(.not.lDiffA.and.lDiffB) then - Call ABOne(iLB,iLA,TMPA - & ,EBp,R,Rinv,Colle,lDiffA) - - If(iLB.eq.0) then - EintSl(1)=EintSl(1)+Colle(1) - Else ! if iLB not 0 then it is 1 - If(iLA.eq.0) then - Do ijhr=1,3 - EintSl(ijhr+1)=EintSl(ijhr+1) - & +Colle(1)*Rotte(3,ijhr) - End do - Else ! is the same for iLA 1 and 2 - ! because both have sigma pi1 and pi2 - ! components regarding to B - Do ijhr=1,3 - EintSl(ijhr+1)=EintSl(ijhr+1) - & +Colle(1)*Rotte(3,ijhr) - & +Colle(2)*Rotte(1,ijhr) - & +Colle(3)*Rotte(2,ijhr) - End do - Endif - Endif -* -*------ Neither diffuse. -* - ElseIf(.not.lDiffA.and..not.lDiffB) then - Call ABNone(iLA,iLB,TMPA,Rinv,Colle) - - If(iLB.eq.0) then - EintSl(1)=EintSl(1)+Colle(1) - ElseIf(iLB.eq.1) then - If(iLA.eq.0) then - Do ijhr=1,3 - EintSl(ijhr+1)=EintSl(ijhr+1) - & +Colle(1)*Rotte(3,ijhr) - End do - Else ! is the same for iLA 1 or 2 - Do ijhr=1,3 - EintSl(ijhr+1)=EintSl(ijhr+1) - & +Colle(1)*Rotte(3,ijhr) - & +Colle(2)*Rotte(1,ijhr) - & +Colle(3)*Rotte(2,ijhr) - End do - Endif - ElseIf(iLB.eq.2) then - If(iLA.eq.0) then - Do ijhr=1,6 ! Remember Qsigma=z2-0.5(x2+y2) - EintSl(ijhr+4)=EintSl(ijhr+4) - & +Colle(1)*(TR(6,ijhr)-0.5d0*(TR(1,ijhr) - & +TR(4,ijhr))) - End do - ElseIf(iLA.eq.1) then - Do ijhr=1,6 ! Remember Qsigma=z2-0.5(x2+y2) - ! QPi1=sqrt(3)*xz - ! QPi2=sqrt(3)*yz - EintSl(ijhr+4)=EintSl(ijhr+4) - & +Colle(1)*(TR(6,ijhr)-0.5d0*(TR(1,ijhr) - & +TR(4,ijhr))) - & +Colle(2)*sqrt(3.d0)*TR(3,ijhr) - & +Colle(3)*sqrt(3.0d0)*TR(5,ijhr) - End do - -*------------------Jose. This will be for a d-d interaction -C ElseIf(iLA.eq.2) then -C Do ijhr=1,6 ! Remember Qsigma=z2-0.5(x2+y2) -C ! QPi1=sqrt(3)*xz -C ! QPi2=sqrt(3)*yz -C ! Del1=sqrt(3)*xy -C ! Del2=0.5*sqrt(3)*(x2-y2) -C EintSl(ijhr+4)=EintSl(ijhr+4) -C & +Colle(1)*(TR(6,ijhr)-0.5d0*(TR(1,ijhr) -C & +TR(4,ijhr)))+Colle(2)*sqrt(3.d0)*TR(3,ijhr) -C & +Colle(3)*sqrt(3.0d0)*TR(5,ijhr) -C & +Colle(4)*sqrt(3.0d0)*TR(2,ijhr) -C & +Colle(5)*0.5d0*sqrt(3.0d0)*(TR(1,ijhr) -C & -TR(4,ijhr)) -C End do -*------------------ - Endif - Endif - - Endif - Enddo - -* -*---- ELECTRON--POINT. -* -*------ Point on centre B. -* Jose. Potential, Field and Field Gradient of Multipole -* distribution in A on B (to obtain nuclear interaction in B) -* - If(lAtom) then - If(lDiffA) then - Call ABOne(iLA,0,TMPA,EAp,R,Rinv,Colle,lDiffA) - EintSl_Nuc=EintSl_Nuc+Colle(1) - Else - Call ABNone(iLA,0,TMPA,Rinv,Colle) - EintSl_Nuc=EintSl_Nuc+Colle(1) - Endif - Endif - -* - - Enddo - -*---- ELECTRON--POINT. -* -*------ Point on centre A. -* Jose. Potential, Field and Field Gradient of nuclear -* charge in A on the B sites -* - If(SlPA(iCA).gt.1.0d-8)then - Do iLB=0,lMaxB - EB=ExpoB(iLB+1) - lDiffB=EB.gt.-1.0d0 - EBp=0.5d0*EB - - If(lDiffB) then - Call ABOne(iLB,0,SlPA(iCA) - & ,EBp,R,Rinv,Colle,.false.) - Else - Call ABNone(0,iLB,SlPA(iCA) - & ,Rinv,Colle) - Endif - If(iLB.eq.0) then - EintSl(1)=EintSl(1)+Colle(1) - ElseIf(iLB.eq.1) then - Do ijhr=1,3 - EintSl(ijhr+1)=EintSl(ijhr+1) - & +Colle(1)*Rotte(3,ijhr) - End do - ElseIf(iLB.eq.2) then - Do ijhr=1,6 ! Remember Qsigma=z2-0.5(x2+y2) - EintSl(ijhr+4)=EintSl(ijhr+4) - & +Colle(1)*(TR(6,ijhr)-0.5d0*(TR(1,ijhr) - & +TR(4,ijhr))) - End do - Endif - End do - -* -*---- POINT--POINT. -* Jose. Potential of nuclear charge in A on B -* (to obtain nuclear interaction in B) - If(lAtom) then - Call ABNone(0,0,SlPA(iCA),Rinv,Colle) - EintSl_Nuc=EintSl_Nuc+Colle(1) - Endif - Endif - - Enddo - - Return - End - - -* -*-- Construct rotation matrix. -* - Subroutine Revolution(v,Rinv,Rotte) - Implicit Real*8 (a-h,o-z) - - Dimension v(3),Rotte(3,3) - Dimension u(3),w(3),t(3) - -* -*-- Obtain base-vectors for the plane to which v in the normal vector. -* - Call PlaneVectors(u,w,v,Rinv) - -* -*-- Normalize v. -* - t(1)=Rinv*v(1) - t(2)=Rinv*v(2) - t(3)=Rinv*v(3) - -* -*-- Assemble rotation matrix -* - Rotte(1,1)=u(1) - Rotte(1,2)=u(2) - Rotte(1,3)=u(3) - Rotte(2,1)=w(1) - Rotte(2,2)=w(2) - Rotte(2,3)=w(3) - Rotte(3,1)=t(1) - Rotte(3,2)=t(2) - Rotte(3,3)=t(3) - - Return - End - - -* -*-- Rotate multipole. -* - Subroutine Rotation_qmstat(iL,dMul,Rotte,Sigge) - Implicit Real*8 (a-h,o-z) - - Parameter (MxMltp=2) - - Dimension dMul((MxMltp+1)*(MxMltp+2)/2),Rotte(3,3) - Dimension dMTrans(6),TD(6,6) - -* -*-- Charge, trivial to rotate. -* - If(iL.eq.0) then - dMul(1)=dMul(1) -* -*-- Dipole, transforms as a vector. Sigge controls that if the -* multipole is located not in origin, but at the other end, -* i.e. molecule A, then any odd occurrence of z should be -* mirrored. Applies for the quadrupole as well, see below. -* - ElseIf(iL.eq.1) then - d1=dMul(1) - d2=dMul(2) - d3=dMul(3) - dMul(1)=Rotte(1,1)*d1+Rotte(1,2)*d2+Rotte(1,3)*d3 - dMul(2)=Rotte(2,1)*d1+Rotte(2,2)*d2+Rotte(2,3)*d3 - dMul(3)=Rotte(3,1)*d1+Rotte(3,2)*d2+Rotte(3,3)*d3 - dMul(1)=dMul(1) - dMul(2)=dMul(2) - dMul(3)=Sigge*dMul(3) -* -*-- Quadrupole, transforms as a quadratic form. Also, transform -* to spherical representation. -* - ElseIf(iL.eq.2) then -* -*---- Compute the transformation matrix for second-moments. -* - Call M2Trans(Rotte,TD) -* -*---- Transform. Sigge is explained above. -* - Do i=1,6 - dMTrans(i)=0.0d0 - Do j=1,6 - dMTrans(i)=dMTrans(i)+TD(i,j)*dMul(j) - Enddo - Enddo - Do i=1,6 - Sig=1.0d0 - If(i.eq.3.or.i.eq.5)Sig=Sigge - dMul(i)=dMTrans(i)*Sig - Enddo -* -*---- Go to spherical representation. -* - Call Spherical(dMul) - Else - Write(6,*)'Nope!, Error in sl_grad' - Call Quit(_RC_IO_ERROR_READ_) - Endif - - Return - End - - -* -*-- Routine for the case where both centres are diffuse. Since these -* formulas are pretty nasty and apparently with little general -* structure, each type of interaction is hard-coded. -* - Subroutine ABBoth(iLA,iLB,dMulA - & ,Tau,dKappa,Rho,RhoA,RhoB - & ,Rinv,lTooSmall,Colle) - Implicit Real*8 (a-h,o-z) - - Parameter (MxMltp=2) - - Dimension dMulA((MxMltp+1)*(MxMltp+2)/2),Colle(3) - - Logical lTooSmall - -*-- To calculate the interaction Sigma is the product of both multipoles -* in A and in B but since we need potential, field and field gradient -* for the QM system whe do not multiply for multipoles in B, but we -* have to take into account to move the result for the original -* coordinate system in QmStat. -* - Do i=1,3 - Colle(i)=0.0d0 - End do -* -*-- s-s interaction. There is only sigma-components, hence simple. -* - If(iLA.eq.0.and.iLB.eq.0) then - Sigma=dMulA(1) - If(lTooSmall) then - Ex=Exp((-2.0d0)*Rho) - Colle(1)=Sigma*CoulT0_1(Rho,Rinv,Ex) - Else - ExA=Exp((-2.0d0)*RhoA) - ExB=Exp((-2.0d0)*RhoB) - Colle(1)=Sigma*CoulTN_1(RhoA,RhoB,dKappa,Rinv,ExA,ExB) - Endif - -* -*-- s-p interaction. Only the z-component of the dipole interacts -* through a sigma-interaction with the s-distribution. Observe -* that in the case that iLA.gt.iLB, then the formulas by Roothan -* has to be reversed, i.e. RhoA and RhoB change place and -* Tau and Kappa changes sign. -* - ElseIf(iLA.eq.1.and.iLB.eq.0) then - Sigma=dMulA(3) - If(lTooSmall) then - Ex=Exp((-2.0d0)*Rho) - Colle(1)=Sigma*CoulT0_2(Rho,Rinv,Ex) - Else - ExA=Exp((-2.0d0)*RhoA) - ExB=Exp((-2.0d0)*RhoB) - Colle(1)=Sigma*CoulTN_2(Rho,-Tau,RhoB,RhoA,-dKappa,Rinv - & ,ExB,ExA) - Endif - ElseIf(iLA.eq.0.and.iLB.eq.1) then - Sigma=dMulA(1) - If(lTooSmall) then - Ex=Exp((-2.0d0)*Rho) - Colle(1)=Sigma*CoulT0_2(Rho,Rinv,Ex) - Else - ExA=Exp((-2.0d0)*RhoA) - ExB=Exp((-2.0d0)*RhoB) - Colle(1)=Sigma*CoulTN_2(Rho,Tau,RhoA,RhoB,dKappa, - & Rinv,ExA,ExB) - Endif - -* -*-- p-p interaction. The z-z combination gives a sigma-interaction, -* and the x-x and y-y combinations give pi-interactions. -* - ElseIf(iLA.eq.1.and.iLB.eq.1) then -* -*-- The sigma-component. -* - Sigma=dMulA(3) - If(lTooSmall) then - Ex=Exp((-2.0d0)*Rho) - Colle(1)=Sigma*CoulT0_4(Rho,Rinv,Ex) - Else - ExA=Exp((-2.0d0)*RhoA) - ExB=Exp((-2.0d0)*RhoB) - Colle(1)=Sigma*CoulTN_4(Rho,Tau,RhoA,RhoB,dKappa - & ,Rinv,ExA,ExB) - Endif -* -*-- The two pi-components. -* - Pi1=dMulA(1) - Pi2=dMulA(2) - If(lTooSmall) then - Ex=Exp((-2.0d0)*Rho) - Width=CoulT0_5(Rho,Rinv,Ex) - Colle(2)=Pi1*Width - Colle(3)=Pi2*Width - Else - ExA=Exp((-2.0d0)*RhoA) - ExB=Exp((-2.0d0)*RhoB) - Width=CoulTN_5(Rho,Tau,RhoA,RhoB,dKappa,Rinv,ExA,ExB) - Colle(2)=Pi1*Width - Colle(3)=Pi2*Width - Endif - -* -*-- Higher angular momentum interactions. -* - Else - Write(6,*)'Too high angular momentum' - Write(6,*)'at least you start to implement.' - Call Quit(_RC_IO_ERROR_READ_) - Endif - - Return - End - -* -*-- One diffuse, the other not diffuse. -* - Subroutine ABOne(iLdiff,iLpoi,dMul - & ,Ep,R,Rinv,Colle,lDiffA) - Implicit Real*8 (a-h,o-z) - - Parameter (MxMltp=2) - - Dimension dMul((MxMltp+1)*(MxMltp+2)/2),Colle(3) - Logical lDiffA - -* -*-- The omnipresent exponential and distance-exponent product. -* - er=Ep*R - Ex=Exp((-2.0d0)*er) - d3=sqrt(3.0d0) - Do i=1,3 - Colle(i)=0.0d0 - End do - -* -*-- s-s; see ABBoth for comments on sigma and similar below. -* - If(iLdiff.eq.0.and.iLpoi.eq.0) then - Sigma=dMul(1) - DAMP=(1.0d0+er)*Ex - Colle(1)=Sigma*Rinv*(1.0d0-DAMP) - -* -*-- s-p -* - ElseIf(iLdiff.eq.0.and.iLpoi.eq.1) then - Sigma=dMul(3) - If(lDiffA) then - Sigma=dMul(1) - End If - DAMP=(1.0d0+2.0d0*er+2.0d0*er**2)*Ex - Colle(1)=Sigma*Rinv**2*(1.0d0-DAMP) - -* -*-- s-d -* - ElseIf(iLdiff.eq.0.and.iLpoi.eq.2) then - Sigma=dMul(3) - If(lDiffA) then - Sigma=dMul(1) - End If - DAMP=(1.0d0+2.0d0*er+2.0d0*er**2+4.0d0*er**3/3.0d0)*Ex - Colle(1)=Sigma*Rinv**3*(1.0d0-DAMP) - -* -*-- p-s -* - ElseIf(iLdiff.eq.1.and.iLpoi.eq.0) then - Sigma=dMul(1) - If(lDiffA) then - Sigma=dMul(3) - End If - DAMP=(1.0d0+2.0d0*er+2.0d0*er**2+er**3)*Ex - Colle(1)=Sigma*Rinv**2*(1.0d0-DAMP) - -* -*-- p-p -* - ElseIf(iLdiff.eq.1.and.iLpoi.eq.1) then - Sigma=dMul(3) - Pi1=dMul(1) - Pi2=dMul(2) - DAMP=(1.0d0+2.0d0*er+2.0d0*er**2+3.0d0*er**3/2.0d0+er**4)*Ex - Colle(1)=2.0d0*Sigma*Rinv**3*(1.0d0-DAMP) - DAMP=(1.0d0+2.0d0*er+2.0d0*er**2+er**3)*Ex - Colle(2)=Pi1*Rinv**3*(1.0d0-DAMP) - Colle(3)=Pi2*Rinv**3*(1.0d0-DAMP) - -* -*-- p-d -* - ElseIf(iLdiff.eq.1.and.iLpoi.eq.2) then - Sigma=dMul(3) - Pi1=dMul(2) - Pi2=dMul(4) - If(lDiffA) then - Pi1=dMul(1) - Pi2=dMul(2) - End If - DAMP=(1.0d0+2.0d0*er+2.0d0*er**2+4.0d0*er**3/3.0d0 - & +2.0d0*er**4/3.0d0+4.0d0*er**5/9.0d0)*Ex - Colle(1)=3.0d0*Sigma*Rinv**4*(1.0d0-DAMP) - DAMP=(1.0d0+2.0d0*er+2.0d0*er**2+4.0d0*er**3/3.0d0 - & +2.0d0*er**4/3.0d0)*Ex - Colle(2)=d3*Pi1*Rinv**4*(1.0d0-DAMP) - Colle(3)=d3*Pi2*Rinv**4*(1.0d0-DAMP) -c Colle=Colle1+Colle2+Colle3 - -* -*-- Higher moments. -* - Else - Write(6,*) - Write(6,*)'Too high momentum!' - Call Quit(_RC_IO_ERROR_READ_) - Endif - - Return - End - - -* -*-- All points. A bunch of special cases, see ABOne and ABBoth for -* more details. -* - Subroutine ABNone(iLA,iLB,dMulA - & ,Rinv,Colle) - Implicit Real*8 (a-h,o-z) - - Parameter (MxMltp=2) - - Dimension dMulA((MxMltp+1)*(MxMltp+2)/2) - Dimension Colle(3) - - Do i=1,3 - Colle(i)=0.0d0 - End do - - If(iLA.eq.0) then - If(iLB.eq.0) then - Sigma=dMulA(1) - Colle(1)=Sigma*Rinv - ElseIf(iLB.eq.1) then - Sigma=dMulA(1) - Colle(1)=Sigma*Rinv**2 - ElseIf(iLB.eq.2) then - Sigma=dMulA(1) - Colle(1)=Sigma*Rinv**3 - Endif - ElseIf(iLA.eq.1) then - If(iLB.eq.0) then - Sigma=dMulA(3) - Colle(1)=Sigma*Rinv**2 - ElseIf(iLB.eq.1) then - Sigma=dMulA(3) - Pi1=dMulA(1) - Pi2=dMulA(2) - Colle(1)=2.0d0*Sigma*(Rinv**3) - Colle(2)=Pi1*(Rinv**3) - Colle(3)=Pi2*(Rinv**3) - ElseIf(iLB.eq.2) then - d3=sqrt(3.0d0) - Sigma=dMulA(3) - Pi1=dMulA(1) - Pi2=dMulA(2) - Colle(1)=3.0d0*Sigma*(Rinv**4) - Colle(2)=d3*Pi1*(Rinv**4) - Colle(3)=d3*Pi2*(Rinv**4) - Endif - -C Jose* This is for Quadrupoles in Classical. We do not use in QmStat. -*-------------------------------------- -C ElseIf(iLA.eq.2) then -C If(iLB.eq.0) then -C Sigma=dMulA(3) -C Colle(1)=Sigma*Rinv**3 -C ElseIf(iLB.eq.1) then -C d3=sqrt(3.0d0) -C Sigma=dMulA(3) -C Pi1=dMulA(2) -C Pi2=dMulA(4) -C Colle(1)=3.0d0*Sigma*(Rinv**4) -C Colle(2)=d3*Pi1*(Rinv**4) -C Colle(3)=d3*Pi2*(Rinv**4) -C ElseIf(iLB.eq.2) then -C Sigma=dMulA(3) -C Pi1=dMulA(2) -C Pi2=dMulA(4) -C* Jose. Remember dMulB(1)=sqrt(3)*xy -C* and dMulB(5)=0.5*sqrt(3)*(x2-y2) -C Del1=dMulA(1) -C Del2=dMulA(5) -C Colle(1)=6.0d0*Sigma*(Rinv**5) -C Colle(2)=4.0d0*Pi1*(Rinv**5) -C Colle(3)=4.0d0*Pi2*(Rinv**5) -C Colle(4)=Del1*(Rinv**5) -C Colle(5)=Del2*(Rinv**5) -C Endif -*-------------------------------------- - Endif - - Return - End - - -* -*-- s-s interaction, with too small exponent difference. -* - Real*8 Function CoulT0_1(Rho,dSepInv,Expo) - Implicit Real*8 (a-h,o-z) - - T1=1.0d0 - T2=(11.0d0/8.0d0)*Rho - T3=(3.0d0/4.0d0)*Rho**2 - T4=(1.0d0/6.0d0)*Rho**3 - CoulT0_1=dSepInv*(1.0d0-(T1+T2+T3+T4)*Expo) - - Return - End - -* -*-- s-s interaction, normal case. -* - Real*8 Function CoulTN_1(RA,RB,C,dSepInv,ExpA,ExpB) - Implicit Real*8 (a-h,o-z) - - T1=0.25d0*(2.0d0+C) - T2=0.25d0*RA - TA=(1.0d0-C)**2*(T1+T2)*ExpA - T1=0.25d0*(2.0d0-C) - T2=0.25d0*RB - TB=(1.0d0+C)**2*(T1+T2)*ExpB - CoulTN_1=dSepInv*(1.0d0-TA-TB) - - Return - End - -* -*-- s-p interaction, with too small exponent difference. -* - Real*8 Function CoulT0_2(Rho,dSepInv,Expo) - Implicit Real*8 (a-h,o-z) - - T1=1.0d0 - T2=2.0d0*Rho - T3=2.0d0*Rho**2 - T4=(59.0d0/48.0d0)*Rho**3 - T5=(11.0d0/24.0d0)*Rho**4 - T6=(1.0d0/12.0d0)*Rho**5 - CoulT0_2=dSepInv**2*(1.0d0-(T1+T2+T3+T4+T5+T6)*Expo) - - Return - End - -* -*-- s-p interaction, normal case. -* - Real*8 Function CoulTN_2(R,T,RA,RB,C,dSepInv,ExpA,ExpB) - Implicit Real*8 (a-h,o-z) - - T1=(1.0d0/16.0d0)*(5.0d0+3.0d0*C)*(1.0d0+2.0d0*RA) - T2=0.25d0*RA**2 - TA=(1.0d0-C)**3*(T1+T2)*ExpA - T1=(1.0d0/16.0d0)*(11.0d0-10.0d0*C+3.0d0*C**2)*(1.0d0+2.0d0*RB) - T2=0.5d0*(2.0d0-C)*RB**2 - T3=0.25d0*RB**3 - TB=(1.0d0+C)**2*(T1+T2+T3)*ExpB - CoulTN_2=dSepInv**2*(1.0d0-TA-TB) - - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real(R) - Call Unused_real(T) - End If - End - -* -*-- p-p (sigma), with too small exponent difference. -* - Real*8 Function CoulT0_4(Rho,dSepInv,Expo) - Implicit Real*8 (a-h,o-z) - - T1=1.0d0 - T2=2.0d0*Rho - T3=2.0d0*Rho**2 - T4=(263.0d0/192.0d0)*Rho**3 - T5=(71.0d0/96.0d0)*Rho**4 - T6=(77.0d0/240.0d0)*Rho**5 - T7=(1.0d0/10.0d0)*Rho**6 - T8=(1.0d0/60.0d0)*Rho**7 - CoulT0_4=2.0d0*dSepInv**3*(1.0d0-(T1+T2+T3+T4+T5+T6+T7+T8)*Expo) - - Return - End - -* -*-- p-p (sigma), normal case. -* - Real*8 Function CoulTN_4(R,T,RA,RB,C,dSepInv,ExpA,ExpB) - Implicit Real*8 (a-h,o-z) - - T1=(1.0d0/16.0d0)*(8.0d0+9.0d0*C+3.0d0*C**2) - & *(1.0d0+2.0d0*RA+2.0d0*RA**2) - T2=(3.0d0/16.0d0)*(3.0d0+2.0d0*C)*RA**3 - T3=(1.0d0/8.0d0)*RA**4 - TA=(1.0d0-C)**3*(T1+T2+T3)*ExpA - T1=(1.0d0/16.0d0)*(8.0d0-9.0d0*C+3.0d0*C**2) - & *(1.0d0+2.0d0*RB+2.0d0*RB**2) - T2=(3.0d0/16.0d0)*(3.0d0-2.0d0*C)*RB**3 - T3=(1.0d0/8.0d0)*RB**4 - TB=(1.0d0+C)**3*(T1+T2+T3)*ExpB - CoulTN_4=2.0d0*dSepInv**3*(1.0d0-TA-TB) - - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real(R) - Call Unused_real(T) - End If - End - -* -*-- p-p (pi), with too small exponent difference. -* - Real*8 Function CoulT0_5(Rho,dSepInv,Expo) - Implicit Real*8 (a-h,o-z) - - T1=1.0d0 - T2=2.0d0*Rho - T3=2.0d0*Rho**2 - T4=(121.0d0/96.0d0)*Rho**3 - T5=(25.0d0/48.0d0)*Rho**4 - T6=(2.0d0/15.0d0)*Rho**5 - T7=(1.0d0/60.0d0)*Rho**6 - CoulT0_5=dSepInv**3*(1.0d0-(T1+T2+T3+T4+T5+T6+T7)*Expo) - - Return - End - -* -*-- p-p (pi), normal case. -* - Real*8 Function CoulTN_5(R,T,RA,RB,C,dSepInv,ExpA,ExpB) - Implicit Real*8 (a-h,o-z) - - T1=(1.0d0/16.0d0)*(8.0d0+9.0d0*C+3.0d0*C**2)*(1.0d0+2.0d0*RA) - T2=(1.0d0/8.0d0)*(5.0d0+3.0d0*C)*RA**2 - T3=(1.0d0/8.0d0)*RA**3 - TA=(1.0d0-C)**3*(T1+T2+T3)*ExpA - T1=(1.0d0/16.0d0)*(8.0d0-9.0d0*C+3.0d0*C**2)*(1.0d0+2.0d0*RB) - T2=(1.0d0/8.0d0)*(5.0d0-3.0d0*C)*RB**2 - T3=(1.0d0/8.0d0)*RB**3 - TB=(1.0d0+C)**3*(T1+T2+T3)*ExpB - CoulTN_5=dSepInv**3*(1.0d0-TA-TB) - - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real(R) - Call Unused_real(T) - End If - End - - -* -*-- Compute some auxiliary numbers. -* - Subroutine TKP(Tau,dKappa,Rho,RhoA,RhoB,EA,EB,R - & ,dNeigh,lTooSmall) - Implicit Real*8 (a-h,o-z) - - - Logical lTooSmall - - Tau=(EA-EB)/(EA+EB) - Rho=0.5d0*(EA+EB)*R - RhoA=(1+Tau)*Rho - RhoB=(1-Tau)*Rho - If(abs(Tau).gt.dNeigh) then - dKappa=0.5d0*(Tau+1.0d0/Tau) - lTooSmall=.false. - Else - lTooSmall=.true. - Endif - - Return - End - - -* -*-- Routine to give base vectors of the plane with v as normal. -* - Subroutine PlaneVectors(u,w,v,Rinv) - Implicit Real*8 (a-h,o-z) - - Dimension u(3),w(3),v(3),p(3) - -* -*-- Construct an arbitrary normalized vector orthogonal to the v-vector. -* - const=0.0d0 - Shitx=1.0d0 - Shity=0.0d0 - Shitz=0.0d0 -1001 Continue - p(1)=Shitx+1.0d0*const - p(2)=Shity+0.5d0*const - p(3)=Shitz-1.0d0*const - Scal=p(1)*v(1)+p(2)*v(2)+p(3)*v(3) - u(1)=p(1)-Scal*Rinv**2*v(1) - u(2)=p(2)-Scal*Rinv**2*v(2) - u(3)=p(3)-Scal*Rinv**2*v(3) - If(abs(u(1)).lt.1d-6.and. - & abs(u(2)).lt.1d-6.and. - & abs(u(3)).lt.1d-6) then - const=const+1.0d0 - Go To 1001 - Else - Go To 1002 - Endif -1002 Continue - dLu=sqrt(u(1)**2+u(2)**2+u(3)**2) - u(1)=u(1)/dLu - u(2)=u(2)/dLu - u(3)=u(3)/dLu -* -*-- Construct the final pi-vector, which is orthogonal to the v-vector -* and the recently constructed pi-vector. -* - w(1)=Rinv*(u(2)*v(3)-u(3)*v(2)) - w(2)=Rinv*(u(3)*v(1)-u(1)*v(3)) - w(3)=Rinv*(u(1)*v(2)-u(2)*v(1)) - - Return - End - - -* -*-- Routine to generate the transformation for the second moments. -* - Subroutine M2Trans(Rotte,TD) - Implicit Real*8 (a-h,o-z) - - Dimension Rotte(3,3),TD(6,6) - -* -*-- The transformation of x2. -* - TD(1,1)=Rotte(1,1)*Rotte(1,1) - TD(2,1)=Rotte(1,1)*Rotte(2,1) - TD(3,1)=Rotte(1,1)*Rotte(3,1) - TD(4,1)=Rotte(2,1)*Rotte(2,1) - TD(5,1)=Rotte(2,1)*Rotte(3,1) - TD(6,1)=Rotte(3,1)*Rotte(3,1) -* -*-- The transformation of xy. -* - TD(1,2)=Rotte(1,1)*Rotte(1,2)+Rotte(1,2)*Rotte(1,1) - TD(2,2)=Rotte(1,1)*Rotte(2,2)+Rotte(1,2)*Rotte(2,1) - TD(3,2)=Rotte(1,1)*Rotte(3,2)+Rotte(1,2)*Rotte(3,1) - TD(4,2)=Rotte(2,1)*Rotte(2,2)+Rotte(2,2)*Rotte(2,1) - TD(5,2)=Rotte(2,1)*Rotte(3,2)+Rotte(2,2)*Rotte(3,1) - TD(6,2)=Rotte(3,1)*Rotte(3,2)+Rotte(3,2)*Rotte(3,1) -* -*-- The transformation of xz. -* - TD(1,3)=Rotte(1,1)*Rotte(1,3)+Rotte(1,3)*Rotte(1,1) - TD(2,3)=Rotte(1,1)*Rotte(2,3)+Rotte(1,3)*Rotte(2,1) - TD(3,3)=Rotte(1,1)*Rotte(3,3)+Rotte(1,3)*Rotte(3,1) - TD(4,3)=Rotte(2,1)*Rotte(2,3)+Rotte(2,3)*Rotte(2,1) - TD(5,3)=Rotte(2,1)*Rotte(3,3)+Rotte(2,3)*Rotte(3,1) - TD(6,3)=Rotte(3,1)*Rotte(3,3)+Rotte(3,3)*Rotte(3,1) -* -*-- The transformation of y2. -* - TD(1,4)=Rotte(1,2)*Rotte(1,2) - TD(2,4)=Rotte(1,2)*Rotte(2,2) - TD(3,4)=Rotte(1,2)*Rotte(3,2) - TD(4,4)=Rotte(2,2)*Rotte(2,2) - TD(5,4)=Rotte(2,2)*Rotte(3,2) - TD(6,4)=Rotte(3,2)*Rotte(3,2) -* -*-- The transformation of yz. -* - TD(1,5)=Rotte(1,2)*Rotte(1,3)+Rotte(1,3)*Rotte(1,2) - TD(2,5)=Rotte(1,2)*Rotte(2,3)+Rotte(1,3)*Rotte(2,2) - TD(3,5)=Rotte(1,2)*Rotte(3,3)+Rotte(1,3)*Rotte(3,2) - TD(4,5)=Rotte(2,2)*Rotte(2,3)+Rotte(2,3)*Rotte(2,2) - TD(5,5)=Rotte(2,2)*Rotte(3,3)+Rotte(2,3)*Rotte(3,2) - TD(6,5)=Rotte(3,2)*Rotte(3,3)+Rotte(3,3)*Rotte(3,2) -* -*-- The transformation of z2. -* - TD(1,6)=Rotte(1,3)*Rotte(1,3) - TD(2,6)=Rotte(1,3)*Rotte(2,3) - TD(3,6)=Rotte(1,3)*Rotte(3,3) - TD(4,6)=Rotte(2,3)*Rotte(2,3) - TD(5,6)=Rotte(2,3)*Rotte(3,3) - TD(6,6)=Rotte(3,3)*Rotte(3,3) - - Return - End - -* -*-- Take higher multipole into spherical representation. -* - Subroutine Spherical(dMul) - Implicit Real*8 (a-h,o-z) - - Parameter (MxMltp=2) - - Dimension dMul((MxMltp+1)*(MxMltp+2)/2) - - d3=sqrt(3.0d0) - x2=dMul(1) - y2=dMul(4) - z2=dMul(6) - xy=dMul(2) - xz=dMul(3) - yz=dMul(5) - dMul(1)=d3*xy - dMul(2)=d3*xz - dMul(3)=z2-0.5d0*(x2+y2) - dMul(4)=d3*yz - dMul(5)=0.5d0*d3*(x2-y2) - - Return - End diff -Nru openmolcas-22.02/src/qmstat/sl_grad.F90 openmolcas-22.10/src/qmstat/sl_grad.F90 --- openmolcas-22.02/src/qmstat/sl_grad.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/sl_grad.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,268 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** +! Sl_Grad +! +!> @brief +!> This subroutine is taken from the Anders program called Diffsph that calculates +!> the Coulombic interaction between two Slater-type densities +!> @author A. Ohrn +!> @modified_by Jose +!> +!> @details +!> The subroutine (originally called ``Coulomb``) is taken and simplified +!> to QmStat purposes. Molecule A is going to be always the Solvent +!> Molecule and Molecule B the Quantum system. The subroutine is +!> writen for one center in the QM system, so it is called for each +!> center of the QM, and gives the Potential, Field and Field gradient +!> generated by all centers of the classical molecule in this center of the +!> QM molecule but considering the penetration. The original subroutine is for +!> classical molecules with as S (charge) slater distribution and a P +!> (dipole) distribution and it is not ready for Qmstat purposes. +!> Quantum molecule is represented up to \f$ L = 2 \f$. Interaction with +!> Multipole distributed Quadrupoles can be treated using an S +!> distribution in the clasical molecules. However a ``Logical`` +!> variable is introduced to avoid the evaluation of this +!> iteraction and perform (in QmStat) less cumbersome calculations +!> using point charges in the classical molecule. +!> +!> This subroutine works with the Molcas order for the quadrupoles +!> \f$ xx=1 \f$, \f$ xy=2 \f$, \f$ xz=3 \f$, \f$ yy=4 \f$, \f$ yz=5 \f$ and \f$ zz=6 \f$ +!> So the \p EintSl have to be changed outside the subroutine +!> to be adapted to the QmStat order +!> \f$ xx=1 \f$, \f$ xy=2 \f$, \f$ yy=3 \f$, \f$ xz=4 \f$, \f$ yz=5 \f$ and \f$ zz=6 \f$ +!> The subroutine has the parameter \c _MxM_ that should be +!> changed if higher multipoles are included. +!*********************************************************************** + +subroutine Sl_Grad(nCentA,lMaxA,Coord,Dist,DInv,ExpoA,FactorA,SlPA,lMaxB,ExpoB,dNeigh,EintSl,EintSl_Nuc,lAtom) + +use Index_Functions, only: nTri_Elem1, nTri3_Elem, nTri3_Elem1 +use Constants, only: Zero, One, Three, Half +use Definitions, only: wp, iwp + +! Maximum multipole implemented +#define _MxM_ 2 + +implicit none +integer(kind=iwp), intent(in) :: nCentA, lMaxA, lMaxB +real(kind=wp), intent(in) :: Coord(3,nCentA), Dist(nCentA), DInv(nCentA), ExpoA(2,nCentA), FactorA(4,nCentA), SlPA(nCentA), & + ExpoB(_MxM_+1), dNeigh +real(kind=wp), intent(out) :: EintSl(nTri3_Elem1(_MxM_)), EintSl_Nuc +logical(kind=iwp), intent(in) :: lAtom +integer(kind=iwp) :: iCA, iLA, iLB, kaunt, kComp, nS, nT +real(kind=wp) :: Colle(3), dKappa, EA, EAp, EB, EBp, R, Rho, RhoA, RhoB, Rinv, Rotte(3,3), Sigge, Tau, TMPA(nTri_Elem1(_MxM_)), & + TR(6,6), v(3) +logical(kind=iwp) :: lDiffA, lDiffB, lTooSmall + +! Some zeros. +EintSl(:) = Zero +EintSl_Nuc = Zero + +! Loop over all centers in molecule A. + +do iCA=1,nCentA + v(:) = Coord(:,iCA) + R = Dist(iCA) + Rinv = DInv(iCA) + + ! Obtain rotation matrix. + + call Revolution(v,Rinv,Rotte) + + ! Obtain the Matrix used to transform the Quadrupoles + ! This 6x6 matrix is really 6 matrix of 3x3 in diagonal form + ! Each element of each matrix gives the contribution from the + ! old quadrupole to the new quadrupole (new coordinate system) + ! Thus, if xx=1, xy=2, xz=3, yy=4, yz=5 and zz=6 + ! QNew(1)=Qold(1)*TD(1,1)+Qold(2)*TD(1,2)+Qold(3)+TD(1,3)+... + ! So, to get field gradient for xx from the sigma interaction + ! (see Anders paper) we have + ! FG(xx)=FGSigma*(TD(6,1)-0.5(TD(1,1)*TD(4,1))). Remember that + ! the Energy contribution in sigma is calculated using spherical + ! harmonics so ESigma=FGSigma(Qnew(6)-0.5(Qnew(1)+Qnew(4))) + + call M2Trans(Rotte,TR) + + ! Loop over centres on A. Suck out exponents, factors and point-part. Rotate multipole. + + do iLA=0,lMaxA + EA = ExpoA(iLA+1,iCA) + lDiffA = EA > -One + nS = nTri3_Elem(iLA) + nT = nTri3_Elem((iLA+1)) + kaunt = 0 + do kComp=nS+1,nT + kaunt = kaunt+1 + TMPA(kaunt) = FactorA(kComp,iCA) + end do + + ! Rotate and go over to spherical representation. + + Sigge = -One + call Rotation_qmstat(iLA,TMPA,Rotte,Sigge) + + ! Jose. Only one center in B so not loop over centres on B. + ! Not Suck out Factors since we do not use them here. + + do iLB=0,lMaxB + EB = ExpoB(iLB+1) + lDiffB = EB > -One + + ! There is no rotation of Multipoles in B since we do not use them. + + ! ELECTRON--ELECTRON. + + EAp = Half*EA + EBp = Half*EB + if (lDiffA .and. lDiffB) then + ! Both diffuse. + + call TKP(Tau,dKappa,Rho,RhoA,RhoB,EAp,EBp,R,dNeigh,lTooSmall) + call ABBoth(iLA,iLB,TMPA,dKappa,Rho,RhoA,RhoB,Rinv,lTooSmall,Colle) + if (iLB == 0) then + EintSl(1) = EintSl(1)+Colle(1) + else ! if iLB not 0 then it is 1 + if (iLA == 0) then + EintSl(2:4) = EintSl(2:4)+Colle(1)*Rotte(3,:) + else ! if iLA is not 0 is 1 + EintSl(2:4) = EintSl(2:4)+Colle(1)*Rotte(3,:)+Colle(2)*Rotte(1,:)+Colle(3)*Rotte(2,:) + end if + end if + + else if (lDiffA .and. (.not. lDiffB)) then + ! One diffuse, one not diffuse. + + call ABOne(iLA,iLB,TMPA,EAp,R,Rinv,Colle,lDiffA) + if (iLB == 0) then + EintSl(1) = EintSl(1)+Colle(1) + else if (iLB == 1) then + if (iLA == 0) then + EintSl(2:4) = EintSl(2:4)+Colle(1)*Rotte(3,:) + else ! if iLA not 0 then it is 1 + EintSl(2:4) = EintSl(2:4)+Colle(1)*Rotte(3,:)+Colle(2)*Rotte(1,:)+Colle(3)*Rotte(2,:) + end if + else if (iLB == 2) then + if (iLA == 0) then + ! Remember Qsigma=z2-0.5(x2+y2) + EintSl(5:10) = EintSl(5:10)+Colle(1)*(TR(6,:)-Half*(TR(1,:)+TR(4,:))) + else ! if iLA not 0 then it is 1 + ! Remember Qsigma=z2-0.5(x2+y2) QPi1=sqrt(3)*xz QPi2=sqrt(3)*yz + EintSl(5:10) = EintSl(5:10)+Colle(1)*(TR(6,:)-Half*(TR(1,:)+TR(4,:)))+ & + Colle(2)*sqrt(Three)*TR(3,:)+Colle(3)*sqrt(Three)*TR(5,:) + end if + end if + + else if ((.not. lDiffA) .and. lDiffB) then + call ABOne(iLB,iLA,TMPA,EBp,R,Rinv,Colle,lDiffA) + + if (iLB == 0) then + EintSl(1) = EintSl(1)+Colle(1) + else ! if iLB not 0 then it is 1 + if (iLA == 0) then + EintSl(2:4) = EintSl(2:4)+Colle(1)*Rotte(3,:) + else ! is the same for iLA 1 and 2 because both have sigma pi1 and pi2 components regarding to B + EintSl(2:4) = EintSl(2:4)+Colle(1)*Rotte(3,:)+Colle(2)*Rotte(1,:)+Colle(3)*Rotte(2,:) + end if + end if + else if ((.not. lDiffA) .and. (.not. lDiffB)) then + ! Neither diffuse. + + call ABNone(iLA,iLB,TMPA,Rinv,Colle) + + if (iLB == 0) then + EintSl(1) = EintSl(1)+Colle(1) + else if (iLB == 1) then + if (iLA == 0) then + EintSl(2:4) = EintSl(2:4)+Colle(1)*Rotte(3,:) + else ! is the same for iLA 1 or 2 + EintSl(2:4) = EintSl(2:4)+Colle(1)*Rotte(3,:)+Colle(2)*Rotte(1,:)+Colle(3)*Rotte(2,:) + end if + else if (iLB == 2) then + if (iLA == 0) then + ! Remember Qsigma=z2-0.5(x2+y2) + EintSl(5:10) = EintSl(5:10)+Colle(1)*(TR(6,:)-Half*(TR(1,:)+TR(4,:))) + else if (iLA == 1) then + ! Remember Qsigma=z2-0.5(x2+y2) QPi1=sqrt(3)*xz QPi2=sqrt(3)*yz + EintSl(5:10) = EintSl(5:10)+Colle(1)*(TR(6,:)-Half*(TR(1,:)+TR(4,:)))+ & + Colle(2)*sqrt(Three)*TR(3,:)+Colle(3)*sqrt(Three)*TR(5,:) + !Jose. This will be for a d-d interaction + !else if (iLA == 2) then + ! ! Remember Qsigma=z2-0.5(x2+y2) QPi1=sqrt(3)*xz QPi2=sqrt(3)*yz Del1=sqrt(3)*xy Del2=0.5*sqrt(3)*(x2-y2) + ! EintSl(5:10) = EintSl(5:10)+Colle(1)*(TR(6,:)-Half*(TR(1,:)+TR(4,:)))+ & + ! Colle(2)*sqrt(Three)*TR(3,:)+Colle(3)*sqrt(Three)*TR(5,:)+ & + ! Colle(4)*sqrt(Three)*TR(2,:)+Colle(5)*Half*sqrt(Three)*(TR(1,:)-TR(4,:)) + ! end do + !-------- + end if + end if + + end if + end do + + ! ELECTRON--POINT. + + ! Point on centre B. + ! Jose. Potential, Field and Field Gradient of Multipole + ! distribution in A on B (to obtain nuclear interaction in B) + + if (lAtom) then + if (lDiffA) then + call ABOne(iLA,0,TMPA,EAp,R,Rinv,Colle,lDiffA) + EintSl_Nuc = EintSl_Nuc+Colle(1) + else + call ABNone(iLA,0,TMPA,Rinv,Colle) + EintSl_Nuc = EintSl_Nuc+Colle(1) + end if + end if + + end do + + ! ELECTRON--POINT. + + ! Point on centre A. + ! Jose. Potential, Field and Field Gradient of nuclear + ! charge in A on the B sites + + if (SlPA(iCA) > 1.0e-8_wp) then + do iLB=0,lMaxB + EB = ExpoB(iLB+1) + lDiffB = EB > -One + EBp = Half*EB + + if (lDiffB) then + call ABOne(iLB,0,SlPA(iCA),EBp,R,Rinv,Colle,.false.) + else + call ABNone(0,iLB,SlPA(iCA),Rinv,Colle) + end if + if (iLB == 0) then + EintSl(1) = EintSl(1)+Colle(1) + else if (iLB == 1) then + EintSl(2:4) = EintSl(2:4)+Colle(1)*Rotte(3,:) + else if (iLB == 2) then + ! Remember Qsigma=z2-0.5(x2+y2) + EintSl(5:10) = EintSl(5:10)+Colle(1)*(TR(6,:)-Half*(TR(1,:)+TR(4,:))) + end if + end do + + ! POINT--POINT. + ! Jose. Potential of nuclear charge in A on B + ! (to obtain nuclear interaction in B) + if (lAtom) then + call ABNone(0,0,SlPA(iCA),Rinv,Colle) + EintSl_Nuc = EintSl_Nuc+Colle(1) + end if + end if + +end do + +return + +end subroutine Sl_Grad diff -Nru openmolcas-22.02/src/qmstat/spherical.F90 openmolcas-22.10/src/qmstat/spherical.F90 --- openmolcas-22.02/src/qmstat/spherical.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/spherical.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,38 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! Take higher multipole into spherical representation. +subroutine Spherical(dMul) + +use Index_Functions, only: nTri_Elem1 +use Constants, only: Three, Half +use Definitions, only: wp + +implicit none +real(kind=wp), intent(inout) :: dMul(nTri_Elem1(2)) +real(kind=wp) :: x2, xy, xz, y2, yz, z2 +real(kind=wp), parameter :: d3 = sqrt(Three) + +x2 = dMul(1) +y2 = dMul(4) +z2 = dMul(6) +xy = dMul(2) +xz = dMul(3) +yz = dMul(5) +dMul(1) = d3*xy +dMul(2) = d3*xz +dMul(3) = z2-Half*(x2+y2) +dMul(4) = d3*yz +dMul(5) = Half*d3*(x2-y2) + +return + +end subroutine Spherical diff -Nru openmolcas-22.02/src/qmstat/sqtotri_q.f openmolcas-22.10/src/qmstat/sqtotri_q.f --- openmolcas-22.02/src/qmstat/sqtotri_q.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/sqtotri_q.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine SqToTri_Q(SqMat,TriMat,iDi) - Implicit Real*8 (a-h,o-z) - Dimension SqMat(*),TriMat(*) - kaunter=0 - Do 10, i=1,iDi - Do 20, j=1,i - kaunter=kaunter+1 - TriMat(kaunter)=SqMat(i+(j-1)*iDi) -20 Continue -10 Continue - Return - End diff -Nru openmolcas-22.02/src/qmstat/sqtotri_q.F90 openmolcas-22.10/src/qmstat/sqtotri_q.F90 --- openmolcas-22.02/src/qmstat/sqtotri_q.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/sqtotri_q.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,33 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine SqToTri_Q(SqMat,TriMat,iDi) + +use Index_Functions, only: nTri_Elem +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iDi +real(kind=wp), intent(in) :: SqMat(iDi,iDi) +real(kind=wp), intent(out) :: TriMat(nTri_Elem(iDi)) +integer(kind=iwp) :: i, j, kaunter + +kaunter = 0 +do i=1,iDi + do j=1,i + kaunter = kaunter+1 + TriMat(kaunter) = SqMat(i,j) + end do +end do + +return + +end subroutine SqToTri_Q diff -Nru openmolcas-22.02/src/qmstat/statemmeao.F90 openmolcas-22.10/src/qmstat/statemmeao.F90 --- openmolcas-22.02/src/qmstat/statemmeao.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/statemmeao.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,66 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! AO-basis route. +subroutine StateMMEao(nAObas,nState,nTyp,MME,iCent,Cha,Dip,Qua) + +use qmstat_global, only: BigT, MxMltp +use Index_Functions, only: nTri3_Elem, nTri_Elem +use Data_Structures, only: Alloc1DArray_Type +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nAObas, nState, nTyp, iCent(nTri_Elem(nAObas)) +type(Alloc1DArray_Type), intent(in) :: MME(nTri3_Elem(MxMltp)) +real(kind=wp), intent(inout) :: Cha(nTri_Elem(nState),*), Dip(nTri_Elem(nState),3,*), Qua(nTri_Elem(nState),6,*) +integer(kind=iwp) :: iB1, iB2, iS1, iS2, iTyp, kaunta, kaunter, nSize +real(kind=wp) :: PerAake +real(kind=wp), allocatable :: AOG(:), O(:) +! The reason why 8 and 7 are interchanged is that +! QMSTAT uses the ordering xx,xy,yy,xz,yz,zz while +! Seward uses the ordering xx,xy,xz,yy,yz,zz. +integer(kind=iwp), parameter :: xTyp(10) = [1,2,3,4,5,6,8,7,9,10] + +kaunter = 0 +nSize = nTri_Elem(nAObas) +call mma_allocate(AOG,nSize,label='Transition') +call mma_allocate(O,nTyp,label='OnTheWay') +! Loop over state pairs. +do iS1=1,nState + do iS2=1,iS1 + kaunter = kaunter+1 + ! Collect this piece of the TDM in AO-basis. + AOG(:) = BigT(:,kaunter) + kaunta = 0 + ! Loop over AO-basis pairs and transform them as well as + ! distribute their multipoles. Observe that the array iCent + ! keeps track on where a certain AO-basis pair belongs. + do iB1=1,nAObas + do iB2=1,iB1 + kaunta = kaunta+1 + PerAake = AOG(kaunta) + do iTyp=1,nTyp + O(iTyp) = MME(xTyp(iTyp))%A(kaunta)*PerAake + end do + Cha(kaunter,iCent(kaunta)) = Cha(kaunter,iCent(kaunta))+O(1) + Dip(kaunter,:,iCent(kaunta)) = Dip(kaunter,:,iCent(kaunta))+O(2:4) + Qua(kaunter,:,iCent(kaunta)) = Qua(kaunter,:,iCent(kaunta))+O(5:10) + end do + end do + end do +end do +call mma_deallocate(AOG) +call mma_deallocate(O) + +return + +end subroutine StateMMEao diff -Nru openmolcas-22.02/src/qmstat/statemme.f openmolcas-22.10/src/qmstat/statemme.f --- openmolcas-22.02/src/qmstat/statemme.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/statemme.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,307 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -* -*-- This is just an interface for the state transformation. Either -* we use usual AO-basis route, or we take the reduced MO-basis -* route. -* - Subroutine StateMME(MoOrNot,nAObas,nMObas,nState,nTyp,iCi,iBigT - & ,iMME,iCent,ipAvRed,Cha,Dip,Qua) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "WrkSpc.fh" - - Dimension iMME(MxMltp*(MxMltp+1)*(MxMltp+2)/6),iCent(MxBas**2) - Dimension Cha(MxStOT,MxQCen),Dip(MxStOT,3,MxQCen) - Dimension Qua(MxStOT,6,MxQCen) - Logical MoOrNot - - If(.not.MoOrNot) then - Call StateMMEao(nAObas,nState,nTyp,iBigT,iMME,iCent,Cha,Dip,Qua) - Else - Call StateMMEmo(nAObas,nMObas,nState,nTyp,iCi,iBigT,iMME,iCent - & ,ipAvRed,Cha,Dip,Qua) - Endif - - Return - End - - -* -*-- AO-basis route. -* - Subroutine StateMMEao(nAObas,nState,nTyp,iBigT,iMME,iCent,Cha,Dip - & ,Qua) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "numbers.fh" -#include "WrkSpc.fh" - - Dimension iMME(MxMltp*(MxMltp+1)*(MxMltp+2)/6),iCent(MxBas**2) - Dimension Cha(MxStOT,MxQCen),Dip(MxStOT,3,MxQCen) - Dimension Qua(MxStOT,6,MxQCen) - - kaunter=0 - nSize=nAObas*(nAObas+1)/2 - Call GetMem('Transition','Allo','Real',ipAOG,nSize) - Call GetMem('OnTheWay','Allo','Real',ipO,nTyp) -*--- Loop over state pairs. - Do 101, iS1=1,nState - Do 102, iS2=1,iS1 - kaunter=kaunter+1 -*------Collect this piece of the TDM in AO-basis. - Call dCopy_(nSize,Work(iBigT+nSize*(kaunter-1)),iONE - & ,Work(ipAOG),iONE) - kaunta=0 -*------- Loop over AO-basis pairs and transform them as well as -* distribute their multipoles. Observe that the array iCent -* keeps track on where a certain AO-basis pair belongs. - Do 103, iB1=1,nAObas - Do 104, iB2=1,iB1 - PerAake=Work(ipAOG+kaunta) - Do 105, iTyp=1,nTyp - Work(ipO+iTyp-1)=Work(iMME(iTyp)+kaunta)*PerAake -105 Continue - kaunta=kaunta+1 - Cha(kaunter,iCent(kaunta))= - & Cha(kaunter,iCent(kaunta))+Work(ipO) - Dip(kaunter,1,iCent(kaunta))= - & Dip(kaunter,1,iCent(kaunta))+Work(ipO+1) - Dip(kaunter,2,iCent(kaunta))= - & Dip(kaunter,2,iCent(kaunta))+Work(ipO+2) - Dip(kaunter,3,iCent(kaunta))= - & Dip(kaunter,3,iCent(kaunta))+Work(ipO+3) - Qua(kaunter,1,iCent(kaunta))= - & Qua(kaunter,1,iCent(kaunta))+Work(ipO+4) - Qua(kaunter,2,iCent(kaunta))= - & Qua(kaunter,2,iCent(kaunta))+Work(ipO+5) -*----------- The reason why 7 and 6 are interchanged is that -* QMSTAT uses the ordering xx,xy,yy,xz,yz,zz while -* Seward uses the ordering xx,xy,xz,yy,yz,zz. - Qua(kaunter,3,iCent(kaunta))= - & Qua(kaunter,3,iCent(kaunta))+Work(ipO+7) - Qua(kaunter,4,iCent(kaunta))= - & Qua(kaunter,4,iCent(kaunta))+Work(ipO+6) - Qua(kaunter,5,iCent(kaunta))= - & Qua(kaunter,5,iCent(kaunta))+Work(ipO+8) - Qua(kaunter,6,iCent(kaunta))= - & Qua(kaunter,6,iCent(kaunta))+Work(ipO+9) -104 Continue -103 Continue -102 Continue -101 Continue - Call GetMem('OnTheWay','Free','Real',ipO,nTyp) - Call GetMem('Transition','Free','Real',ipAOG,nSize) - - Return - End - - -* -*-- MO-basis route. -* - Subroutine StateMMEmo(nAObas,nMObas,nState,nTyp,iCi,iBigT,iMME - & ,iCent,ipAvRed,Cha,Dip,Qua) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "numbers.fh" -#include "WrkSpc.fh" - - Dimension iMME(MxMltp*(MxMltp+1)*(MxMltp+2)/6),iCent(MxBas**2) - Dimension Cha(MxStOT,MxQCen),Dip(MxStOT,3,MxQCen) - Dimension Qua(MxStOT,6,MxQCen) - - kaunter=0 - nSizeA=nAObas*(nAObas+1)/2 - nSizeM=nMObas*(nMObas+1)/2 - Call GetMem('Transition','Allo','Real',ipMOG,nSizeM) - Call GetMem('SqMO','Allo','Real',ipMOG_s,nMObas**2) - Call GetMem('TEMP','Allo','Real',iTEMP,nAObas*nMObas) - Call GetMem('SqAO','Allo','Real',ipAOG_s,nAObas**2) - Call GetMem('TransitionA','Allo','Real',ipAOG,nSizeA) - Call GetMem('OnTheWay','Allo','Real',ipO,nTyp) -* -*--- Loop over state pairs. -* - Do 101, iS1=1,nState - Do 102, iS2=1,iS1 - kaunter=kaunter+1 -* -*------- Collect the proper piece of the TDM in MO-basis. -* - Call dCopy_(nSizeM,Work(iBigT+nSizeM*(kaunter-1)),iONE - & ,Work(ipMOG),iONE) -* -*------- Additional transformation step from MO to AO. -* - Call Square(Work(ipMOG),Work(ipMOG_s),iONE,nMObas,nMObas) - kk=0 - Do 403, i=1,nMObas - Do 404, j=1,nMObas - If(i.ne.j)Work(ipMOG_s+kk)=0.5d0*Work(ipMOG_s+kk) - kk=kk+1 -404 Continue -403 Continue - Call Dgemm_('N','N',nAObas,nMObas,nMObas,ONE,Work(ipAvRed) - & ,nAObas,Work(ipMOG_s),nMObas,ZERO,Work(iTEMP) - & ,nAObas) - Call Dgemm_('N','T',nAObas,nAObas,nMObas,ONE,Work(iTEMP) - & ,nAObas,Work(ipAvRed),nAObas,ZERO,Work(ipAOG_s) - & ,nAObas) - kk=0 - Do 405, i=1,nAObas - Do 406, j=1,nAObas - If(i.ne.j)Work(ipAOG_s+kk)=2.0d0*Work(ipAOG_s+kk) - kk=kk+1 -406 Continue -405 Continue - Call SqToTri_Q(Work(ipAOG_s),Work(ipAOG),nAObas) -* -*------- Loop over AO-basis pairs. -* - kaunta=0 - Do 103, iB1=1,nAObas - Do 104, iB2=1,iB1 - PerAake=Work(ipAOG+kaunta) - Do 105, iTyp=1,nTyp - Work(ipO+iTyp-1)=Work(iMME(iTyp)+kaunta)*PerAake -105 Continue - kaunta=kaunta+1 - Cha(kaunter,iCent(kaunta))= - & Cha(kaunter,iCent(kaunta))+Work(ipO) - Dip(kaunter,1,iCent(kaunta))= - & Dip(kaunter,1,iCent(kaunta))+Work(ipO+1) - Dip(kaunter,2,iCent(kaunta))= - & Dip(kaunter,2,iCent(kaunta))+Work(ipO+2) - Dip(kaunter,3,iCent(kaunta))= - & Dip(kaunter,3,iCent(kaunta))+Work(ipO+3) - Qua(kaunter,1,iCent(kaunta))= - & Qua(kaunter,1,iCent(kaunta))+Work(ipO+4) - Qua(kaunter,2,iCent(kaunta))= - & Qua(kaunter,2,iCent(kaunta))+Work(ipO+5) -*----------- The reason why 7 and 6 are interchanged is that -* QMSTAT uses the ordering xx,xy,yy,xz,yz,zz while -* Seward uses the ordering xx,xy,xz,yy,yz,zz. - Qua(kaunter,3,iCent(kaunta))= - & Qua(kaunter,3,iCent(kaunta))+Work(ipO+7) - Qua(kaunter,4,iCent(kaunta))= - & Qua(kaunter,4,iCent(kaunta))+Work(ipO+6) - Qua(kaunter,5,iCent(kaunta))= - & Qua(kaunter,5,iCent(kaunta))+Work(ipO+8) - Qua(kaunter,6,iCent(kaunta))= - & Qua(kaunter,6,iCent(kaunta))+Work(ipO+9) -104 Continue -103 Continue -102 Continue -101 Continue - Call GetMem('Transition','Free','Real',ipMOG,nSizeM) - Call GetMem('SqMO','Free','Real',ipMOG_s,nMObas**2) - Call GetMem('TEMP','Free','Real',iTEMP,nAObas*nMObas) - Call GetMem('SqAO','Free','Real',ipAOG_s,nAObas**2) - Call GetMem('TransitionA','Free','Real',ipAOG,nSizeA) - Call GetMem('OnTheWay','Free','Real',ipO,nTyp) - - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(iCi) - End - - -* -*-- The reduced MO-basis route. OBSOLOTE!! WORKS BUT IS SLOW!!! -* - Subroutine StateMMEmo_NO(nAObas,nMObas,nState,nTyp,iCi,iBigT,iMME - & ,iCent,ipAvRed,Cha,Dip,Qua) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "numbers.fh" -#include "WrkSpc.fh" - - Dimension iMME(MxMltp*(MxMltp+1)*(MxMltp+2)/6),iCent(MxBas**2) - Dimension iAcc(MxMltp*(MxMltp+1)*(MxMltp+2)/6) - Dimension Cha(MxStOT,MxQCen),Dip(MxStOT,3,MxQCen) - Dimension Qua(MxStOT,6,MxQCen) - - kaunter=0 - nSizeA=nAObas*(nAObas+1)/2 - nSizeM=nMObas*(nMObas+1)/2 - Call GetMem('Transition','Allo','Real',ipMOG,nSizeM) - Do 200, i=1,nTyp - Call GetMem('Accumulate','Allo','Real',iAcc(i),nSizeA) -200 Continue -*--- Loop over state pairs. - Do 201, iS1=1,nState - Do 202, iS2=1,iS1 - kaunter=kaunter+1 -*------- Collect the proper piece of the TDM in MO-basis. - Call dCopy_(nSizeM,Work(iBigT+nSizeM*(kaunter-1)),iONE - & ,Work(ipMOG),iONE) -*------- Loop over centres in molecule. This is now necessary since -* MOs are contrary to AOs not localized, hence the simple -* construction with iCent used above, can not be used here. - Do 203, iCentre=1,iCi - Do 2031, i=1,nTyp - Call dCopy_(nSizeA,[ZERO],iZERO,Work(iAcc(i)),iONE) -2031 Continue - kaunta=0 -*--------- Loop over AO-basis pairs. - Do 204, iB1=1,nAObas - Do 205, iB2=1,iB1 - kaunta=kaunta+1 -*------------- If this basis pair belongs to the given centre, -* accumulate all multipoles. - If(iCent(kaunta).eq.iCentre) then - Do 2051, i=1,nTyp - Work(iAcc(i)+kaunta-1)=Work(iAcc(i)+kaunta-1) - & +Work(iMME(i)+kaunta-1) -2051 Continue - Endif -205 Continue -204 Continue -*--------- Transform the MME on this centre to MO-basis. We hence -* get the contribution to the density distributed on a -* specific centre. - Call MMEtoRMO(nAObas,nMObas,ipAvRed,iAcc) -*--------- Ordinary evaluations of expectation values. - Cha(kaunter,iCentre)=Ddot_(nSizeM,Work(iAcc(1)),iONE - & ,Work(ipMOG),iONE) - Dip(kaunter,1,iCentre)=Ddot_(nSizeM,Work(iAcc(2)),iONE - & ,Work(ipMOG),iONE) - Dip(kaunter,2,iCentre)=Ddot_(nSizeM,Work(iAcc(3)),iONE - & ,Work(ipMOG),iONE) - Dip(kaunter,3,iCentre)=Ddot_(nSizeM,Work(iAcc(4)),iONE - & ,Work(ipMOG),iONE) - Qua(kaunter,1,iCentre)=Ddot_(nSizeM,Work(iAcc(5)),iONE - & ,Work(ipMOG),iONE) - Qua(kaunter,2,iCentre)=Ddot_(nSizeM,Work(iAcc(6)),iONE - & ,Work(ipMOG),iONE) - Qua(kaunter,3,iCentre)=Ddot_(nSizeM,Work(iAcc(8)),iONE - & ,Work(ipMOG),iONE) - Qua(kaunter,4,iCentre)=Ddot_(nSizeM,Work(iAcc(7)),iONE - & ,Work(ipMOG),iONE) - Qua(kaunter,5,iCentre)=Ddot_(nSizeM,Work(iAcc(9)),iONE - & ,Work(ipMOG),iONE) - Qua(kaunter,6,iCentre)=Ddot_(nSizeM,Work(iAcc(10)),iONE - & ,Work(ipMOG),iONE) -203 Continue -202 Continue -201 Continue - Call GetMem('Transition','Free','Real',ipMOG,nSizeM) - Do 206, i=1,nTyp - Call GetMem('Accumulate','Free','Real',iAcc(i),nSizeA) -206 Continue - - Return - End diff -Nru openmolcas-22.02/src/qmstat/statemme.F90 openmolcas-22.10/src/qmstat/statemme.F90 --- openmolcas-22.02/src/qmstat/statemme.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/statemme.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,35 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! This is just an interface for the state transformation. Either +! we use usual AO-basis route, or we take the reduced MO-basis route. +subroutine StateMME(MoOrNot,nAObas,nMObas,nState,nTyp,MME,iCent,Cha,Dip,Qua) + +use qmstat_global, only: MxMltp +use Index_Functions, only: nTri3_Elem, nTri_Elem +use Data_Structures, only: Alloc1DArray_Type +use Definitions, only: wp, iwp + +implicit none +logical(kind=iwp), intent(in) :: MoOrNot +integer(kind=iwp), intent(in) :: nAObas, nMObas, nState, nTyp, iCent(nTri_Elem(nAObas)) +type(Alloc1DArray_Type), intent(in) :: MME(nTri3_Elem(MxMltp)) +real(kind=wp), intent(inout) :: Cha(nTri_Elem(nState),*), Dip(nTri_Elem(nState),3,*), Qua(nTri_Elem(nState),6,*) + +if (.not. MoOrNot) then + call StateMMEao(nAObas,nState,nTyp,MME,iCent,Cha,Dip,Qua) +else + call StateMMEmo(nAObas,nMObas,nState,nTyp,MME,iCent,Cha,Dip,Qua) +end if + +return + +end subroutine StateMME diff -Nru openmolcas-22.02/src/qmstat/statemmemo.F90 openmolcas-22.10/src/qmstat/statemmemo.F90 --- openmolcas-22.02/src/qmstat/statemmemo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/statemmemo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,99 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! MO-basis route. +subroutine StateMMEmo(nAObas,nMObas,nState,nTyp,MME,iCent,Cha,Dip,Qua) + +use qmstat_global, only: AvRed, BigT, MxMltp +use Index_Functions, only: nTri3_Elem, nTri_Elem +use Data_Structures, only: Alloc1DArray_Type +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nAObas, nMObas, nState, nTyp, iCent(nTri_Elem(nAObas)) +type(Alloc1DArray_Type), intent(in) :: MME(nTri3_Elem(MxMltp)) +real(kind=wp), intent(inout) :: Cha(nTri_Elem(nState),*), Dip(nTri_Elem(nState),3,*), Qua(nTri_Elem(nState),6,*) +integer(kind=iwp) :: i, iB1, iB2, iS1, iS2, iTyp, j, kaunta, kaunter, nSizeA, nSizeM +real(kind=wp) :: PerAake +real(kind=wp), allocatable :: AOG(:), AOG_S(:,:), MOG(:), MOG_s(:,:), O(:), TEMP(:,:) +! The reason why 8 and 7 are interchanged is that +! QMSTAT uses the ordering xx,xy,yy,xz,yz,zz while +! Seward uses the ordering xx,xy,xz,yy,yz,zz. +integer(kind=iwp), parameter :: xTyp(10) = [1,2,3,4,5,6,8,7,9,10] + +kaunter = 0 +nSizeA = nTri_Elem(nAObas) +nSizeM = nTri_Elem(nMObas) +call mma_allocate(MOG,nSizeM,label='Transition') +call mma_allocate(MOG_s,nMObas,nMObas,label='SqMO') +call mma_allocate(TEMP,nAObas,nMObas,label='TEMP') +call mma_allocate(AOG_s,nAObas,nAObas,label='SqAO') +call mma_allocate(AOG,nSizeA,label='TransitionA') +call mma_allocate(O,nTyp,label='OnTheWay') + +! Loop over state pairs. + +do iS1=1,nState + do iS2=1,iS1 + kaunter = kaunter+1 + + ! Collect the proper piece of the TDM in MO-basis. + + MOG(:) = BigT(1:nSizeM,kaunter) + + ! Additional transformation step from MO to AO. + + call Square(MOG,MOG_s,1,nMObas,nMObas) + do i=1,nMObas + do j=1,nMObas + if (i == j) cycle + MOG_s(j,i) = Half*MOG_s(j,i) + end do + end do + call Dgemm_('N','N',nAObas,nMObas,nMObas,One,AvRed,nAObas,MOG_s,nMObas,Zero,TEMP,nAObas) + call Dgemm_('N','T',nAObas,nAObas,nMObas,One,TEMP,nAObas,AvRed,nAObas,Zero,AOG_s,nAObas) + do i=1,nAObas + do j=1,nAObas + if (i == j) cycle + AOG_s(j,i) = Two*AOG_s(j,i) + end do + end do + call SqToTri_Q(AOG_s,AOG,nAObas) + + ! Loop over AO-basis pairs. + + kaunta = 0 + do iB1=1,nAObas + do iB2=1,iB1 + kaunta = kaunta+1 + PerAake = AOG(kaunta) + do iTyp=1,nTyp + O(iTyp) = MME(xTyp(iTyp))%A(kaunta)*PerAake + end do + Cha(kaunter,iCent(kaunta)) = Cha(kaunter,iCent(kaunta))+O(1) + Dip(kaunter,:,iCent(kaunta)) = Dip(kaunter,:,iCent(kaunta))+O(2:4) + Qua(kaunter,:,iCent(kaunta)) = Qua(kaunter,:,iCent(kaunta))+O(5:10) + end do + end do + end do +end do +call mma_deallocate(MOG) +call mma_deallocate(MOG_s) +call mma_deallocate(TEMP) +call mma_deallocate(AOG_s) +call mma_deallocate(AOG) +call mma_deallocate(O) + +return + +end subroutine StateMMEmo diff -Nru openmolcas-22.02/src/qmstat/tdmtrans.f openmolcas-22.10/src/qmstat/tdmtrans.f --- openmolcas-22.02/src/qmstat/tdmtrans.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/tdmtrans.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,125 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine TdmTrans(nBas) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "files_qmstat.fh" -#include "qminp.fh" -#include "qm2.fh" -#include "numbers.fh" -#include "WrkSpc.fh" -#include "warnings.h" - - Dimension nBas(MxSym) - - Character TDMchar*6 - - Logical Exist - -* -*--- Sag hej till publiken. -* - Write(6,*) - Write(6,*)' Transforming the transition density matrices.' - -* -*--- Inquire if the ToFile is in WorkDir. -* - Call f_Inquire(RassiM,Exist) - If(.not.Exist) then - Write(6,*) - Write(6,*)'No Transition density matrix file found.' - Write(6,*)'Did you use the TOFIle keyword in RASSI?' - Call Quit(_RC_IO_ERROR_READ_) - Endif - Call f_Inquire(EigV,Exist) - If(.not.Exist) then - Write(6,*) - Write(6,*)'No Rassi eigenvectors found.' - Write(6,*)'Did you use the TOFIle keyword in RASSI?' - Call Quit(_RC_IO_ERROR_READ_) - Endif - -* -*--- Compute number of 'primitive' states. -* - nStatePrim=0 - Do 111, i=1,NrFiles - nStatePrim=nStatePrim+NrStates(i) -111 Continue - -* -*--- Open EigV file and read information. -* - Lu=92 - Call DaName(Lu,EigV) - iDisk=0 - -* -*--- Read RASSCF overlap and H-matrix. -* - nSize=nStatePrim*(nStatePrim+1)/2 - Call GetMem('NonOrtH','Allo','Real',iNonH,nSize) - Call GetMem('NonOrtS','Allo','Real',iNonS,nSize) - kaunt=0 - Do 201, i=1,nStatePrim - Do 203, j=1,i - Call dDaFile(Lu,2,Work(iNonH+kaunt),1,iDisk) - kaunt=kaunt+1 -203 Continue -201 Continue - kaunt=0 - Do 202, i=1,nStatePrim - Do 204, j=1,i - Call dDaFile(Lu,2,Work(iNonS+kaunt),1,iDisk) - kaunt=kaunt+1 -204 Continue -202 Continue - If(iPrint.ge.10) then - Call TriPrt('RASSCF Hamiltonian',' ',Work(iNonH),nStatePrim) - Call TriPrt('RASSCF Overlaps',' ',Work(iNonS),nStatePrim) - Endif - Call DaClos(Lu) - -* -*--- Construct CASSI state basis. -* - Call ContRASBas(nBas,nStatePrim,iNonH,iNonS,iEig2) - Call GetMem('NonOrtH','Free','Real',iNonH,nSize) - Call GetMem('NonOrtS','Free','Real',iNonS,nSize) - -* -*--- Now transform from 'primitive' RASSCF to 'contracted' RASSI states. -* - Call RasRasTrans(nBas(1),nStatePrim,iEig2,iPrint) - -* -*--- If requested, obtain reduced MO-basis, otherwise just go as -* usual. -* - If(MoAveRed) then - Call MoReduce(nBas,nRedMO,ipAvRed) - Write(TDMchar,'(A)')'TDMSCR' - Call FetchTDM(nRedMO,nState,iBigT,TDMchar) - Else - Write(6,*)' ----- Use AO-representation of the transition' - &//' density matrix.' - nRedMO=0 !Only a dummy. - Endif - -* -*--- Finished! -* - Write(6,*)' ...Done!' - - Return - End diff -Nru openmolcas-22.02/src/qmstat/tdmtrans.F90 openmolcas-22.10/src/qmstat/tdmtrans.F90 --- openmolcas-22.02/src/qmstat/tdmtrans.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/tdmtrans.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,115 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine TdmTrans(nBas) + +use qmstat_global, only: iPrint, MoAveRed, MxSymQ, nRedMO, NrFiles, NrStates, nState, RassiM, EigV +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nBas(MxSymQ) +integer(kind=iwp) :: i, iDisk, j, kaunt, Lu, nStatePrim +character(len=6) :: TDMchar +logical(kind=iwp) :: Exists +real(kind=wp), allocatable :: Eig2(:,:), NonH(:), NonS(:) +#include "warnings.h" + +! Sag hej till publiken. + +write(u6,*) +write(u6,*) ' Transforming the transition density matrices.' + +! Inquire if the ToFile is in WorkDir. + +call f_Inquire(RassiM,Exists) +if (.not. Exists) then + write(u6,*) + write(u6,*) 'No Transition density matrix file found.' + write(u6,*) 'Did you use the TOFIle keyword in RASSI?' + call Quit(_RC_IO_ERROR_READ_) +end if +call f_Inquire(EigV,Exists) +if (.not. Exists) then + write(u6,*) + write(u6,*) 'No Rassi eigenvectors found.' + write(u6,*) 'Did you use the TOFIle keyword in RASSI?' + call Quit(_RC_IO_ERROR_READ_) +end if + +! Compute number of 'primitive' states. + +nStatePrim = 0 +do i=1,NrFiles + nStatePrim = nStatePrim+NrStates(i) +end do + +! Open EigV file and read information. + +Lu = 92 +call DaName(Lu,EigV) +iDisk = 0 + +! Read RASSCF overlap and H-matrix. + +call mma_allocate(NonH,nTri_Elem(nStatePrim),label='NonOrtH') +call mma_allocate(NonS,nTri_Elem(nStatePrim),label='NonOrtS') +kaunt = 0 +do i=1,nStatePrim + do j=1,i + kaunt = kaunt+1 + call dDaFile(Lu,2,NonH(kaunt),1,iDisk) + end do +end do +kaunt = 0 +do i=1,nStatePrim + do j=1,i + kaunt = kaunt+1 + call dDaFile(Lu,2,NonS(kaunt),1,iDisk) + end do +end do +if (iPrint >= 10) then + call TriPrt('RASSCF Hamiltonian',' ',NonH,nStatePrim) + call TriPrt('RASSCF Overlaps',' ',NonS,nStatePrim) +end if +call DaClos(Lu) + +! Construct CASSI state basis. + +call mma_allocate(Eig2,nStatePrim,nStatePrim,label='RedEigV1') +call ContRASBas(nStatePrim,NonH,NonS,Eig2) +call mma_deallocate(NonH) +call mma_deallocate(NonS) + +! Now transform from 'primitive' RASSCF to 'contracted' RASSI states. + +call RasRasTrans(nBas(1),nStatePrim,Eig2,iPrint) +call mma_deallocate(Eig2) + +! If requested, obtain reduced MO-basis, otherwise just go as usual. + +if (MoAveRed) then + call MoReduce(nBas,nRedMO) + write(TDMchar,'(A)') 'TDMSCR' + call FetchTDM(nRedMO,nState,TDMchar) +else + write(u6,*) ' ----- Use AO-representation of the transition density matrix.' + nRedMO = 0 !Only a dummy. +end if + +! Finished! + +write(u6,*) ' ...Done!' + +return + +end subroutine TdmTrans diff -Nru openmolcas-22.02/src/qmstat/tkp.F90 openmolcas-22.10/src/qmstat/tkp.F90 --- openmolcas-22.02/src/qmstat/tkp.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/tkp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,36 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! Compute some auxiliary numbers. +subroutine TKP(Tau,dKappa,Rho,RhoA,RhoB,EA,EB,R,dNeigh,lTooSmall) + +use Constants, only: One, Half +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(out) :: Tau, dKappa, Rho, RhoA, RhoB +real(kind=wp), intent(in) :: EA, EB, R, dNeigh +logical(kind=iwp), intent(out) :: lTooSmall + +Tau = (EA-EB)/(EA+EB) +Rho = Half*(EA+EB)*R +RhoA = (1+Tau)*Rho +RhoB = (1-Tau)*Rho +if (abs(Tau) > dNeigh) then + dKappa = Half*(Tau+One/Tau) + lTooSmall = .false. +else + lTooSmall = .true. +end if + +return + +end subroutine TKP diff -Nru openmolcas-22.02/src/qmstat/transrot.f openmolcas-22.10/src/qmstat/transrot.f --- openmolcas-22.02/src/qmstat/transrot.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/transrot.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,93 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -*--------------------------------------------------------------------------* -* Compute rotation matrix for this specific solvent. * -*--------------------------------------------------------------------------* - Subroutine TransRot(Cordst,i,Rot,xt,yt,zt,Ax,Ay,Az) - Implicit Real*8 (a-h,o-z) - -#include "maxi.fh" -#include "warnings.h" - - Dimension Rot(3,3),Cordst(MxPut*MxCen,3) - - XO=CORDST(I,1)-AX - YO=CORDST(I,2)-AY - ZO=CORDST(I,3)-AZ - XH=CORDST(I+1,1)-AX - YH=CORDST(I+1,2)-AY - ZH=CORDST(I+1,3)-AZ - XA=CORDST(I+2,1)-AX - YA=CORDST(I+2,2)-AY - ZA=CORDST(I+2,3)-AZ - DELX=(XH+XA)/2.-XO - DELY=(YH+YA)/2.-YO - DELZ=(ZH+ZA)/2.-ZO - DELR=DELX*DELX+DELY*DELY+DELZ*DELZ - DELR=DELR-1.225449d0 - IF(ABS(DELR).GT..0001)THEN !This is a check of the water geometry. - Write(6,*)'Molecule',((i-1)/5)+1 !If we enter here, something - WRITE(6,*)' WARNING IN TRANSROT ', 'delr',delr !is wrong. - WRITE(6,*)' O',XO,YO,ZO - WRITE(6,*)' H',XH,YH,ZH - WRITE(6,*)' A',XA,YA,ZA - Call Quit(_RC_GENERAL_ERROR_) - ENDIF - XT=XO+.3d0/1.107d0*DELX - YT=YO+.3d0/1.107d0*DELY - ZT=ZO+.3d0/1.107d0*DELZ - ROT(1,3)=(XO-XT)/.3d0 - ROT(2,3)=(YO-YT)/.3d0 - ROT(3,3)=(ZO-ZT)/.3d0 - ROT(1,2)=(XH-XA)/2.86d0 - ROT(2,2)=(YH-YA)/2.86d0 - ROT(3,2)=(ZH-ZA)/2.86d0 - ANORM=1./SQRT(ROT(1,3)**2+ROT(2,3)**2+ROT(3,3)**2) - ROT(1,3)=ROT(1,3)*ANORM - ROT(2,3)=ROT(2,3)*ANORM - ROT(3,3)=ROT(3,3)*ANORM - ANORM=1./SQRT(ROT(1,2)**2+ROT(2,2)**2+ROT(3,2)**2) - ROT(1,2)=ROT(1,2)*ANORM - ROT(2,2)=ROT(2,2)*ANORM - ROT(3,2)=ROT(3,2)*ANORM - ROT(1,1)=1.-ROT(1,3)**2-ROT(1,2)**2 - IF(ROT(1,1).LT.0.)ROT(1,1)=0d0 - ROT(1,1)=SQRT(ROT(1,1)) - ROT(2,1)=1.-ROT(2,2)**2-ROT(2,3)**2 - IF(ROT(2,1).LT.0.)ROT(2,1)=0d0 - ROT(2,1)=SQRT(ROT(2,1)) - ROT(3,1)=1.-ROT(3,3)**2-ROT(3,2)**2 - IF(ROT(3,1).LT.0.)ROT(3,1)=0d0 - ROT(3,1)=SQRT(ROT(3,1)) - - IFLAG=0 -732 Continue - TAL=ROT(1,1)*ROT(1,2)+ROT(2,1)*ROT(2,2)+ROT(3,1)*ROT(3,2) - ROT(1,1)=ROT(1,1)-TAL*ROT(1,2) - ROT(2,1)=ROT(2,1)-TAL*ROT(2,2) - ROT(3,1)=ROT(3,1)-TAL*ROT(3,2) - TAL=ROT(1,1)*ROT(1,3)+ROT(2,1)*ROT(2,3)+ROT(3,1)*ROT(3,3) - ROT(1,1)=ROT(1,1)-TAL*ROT(1,3) - ROT(2,1)=ROT(2,1)-TAL*ROT(2,3) - ROT(3,1)=ROT(3,1)-TAL*ROT(3,3) - A=1d0/SQRT(ROT(1,1)**2+ROT(2,1)**2+ROT(3,1)**2) - ROT(1,1)=ROT(1,1)*A - ROT(2,1)=ROT(2,1)*A - ROT(3,1)=ROT(3,1)*A - IFLAG=IFLAG+1 - IF(IFLAG.GT.3) THEN - WRITE(6,*) ' STOP IN TRANSROT' - Call Quit(_RC_GENERAL_ERROR_) - ENDIF - IF(A.GT.10.) GO TO 732 - - Return - End diff -Nru openmolcas-22.02/src/qmstat/transrot.F90 openmolcas-22.10/src/qmstat/transrot.F90 --- openmolcas-22.02/src/qmstat/transrot.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/transrot.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,90 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +!----------------------------------------------------------------------* +! Compute rotation matrix for this specific solvent. * +!----------------------------------------------------------------------* +subroutine TransRot(Cordst,i,Rot,xt,yt,zt,Ax,Ay,Az) + +use qmstat_global, only: nCent +use Constants, only: Zero, One, Ten, Half +use Definitions, only: wp, iwp, u6 + +implicit none +real(kind=wp), intent(in) :: Cordst(3,3), Ax, Ay, Az +integer(kind=iwp), intent(in) :: i +real(kind=wp), intent(out) :: Rot(3,3), xt, yt, zt +integer(kind=iwp) :: IFLAG +real(kind=wp) :: A, ANORM, DELR, DEL(3), TAL, XA(3), XH(3), XO(3) +#include "warnings.h" + +XO(1) = CORDST(1,1)-AX +XO(2) = CORDST(2,1)-AY +XO(3) = CORDST(3,1)-AZ +XH(1) = CORDST(1,2)-AX +XH(2) = CORDST(2,2)-AY +XH(3) = CORDST(3,2)-AZ +XA(1) = CORDST(1,3)-AX +XA(2) = CORDST(2,3)-AY +XA(3) = CORDST(3,3)-AZ +DEL = (XH+XA)*Half-XO +DELR = DEL(1)**2+DEL(2)**2+DEL(3)**2 +DELR = DELR-1.225449_wp +!This is a check of the water geometry. +!If we enter here, something is wrong. +if (abs(DELR) > 1.0e-4_wp) then + write(u6,*) 'Molecule',((i-1)/nCent)+1 + write(u6,*) ' WARNING IN TRANSROT ','delr',delr + write(u6,*) ' O',XO + write(u6,*) ' H',XH + write(u6,*) ' A',XA + call Quit(_RC_GENERAL_ERROR_) +end if +XT = XO(1)+0.3_wp/1.107_wp*DEL(1) +YT = XO(2)+0.3_wp/1.107_wp*DEL(2) +ZT = XO(3)+0.3_wp/1.107_wp*DEL(3) +ROT(1,3) = (XO(1)-XT)/0.3_wp +ROT(2,3) = (XO(2)-YT)/0.3_wp +ROT(3,3) = (XO(3)-ZT)/0.3_wp +ROT(:,2) = (XH-XA)/2.86_wp +ANORM = One/sqrt(ROT(1,3)**2+ROT(2,3)**2+ROT(3,3)**2) +ROT(:,3) = ROT(:,3)*ANORM +ANORM = One/sqrt(ROT(1,2)**2+ROT(2,2)**2+ROT(3,2)**2) +ROT(:,2) = ROT(:,2)*ANORM +ROT(1,1) = One-ROT(1,3)**2-ROT(1,2)**2 +if (ROT(1,1) < Zero) ROT(1,1) = Zero +ROT(1,1) = sqrt(ROT(1,1)) +ROT(2,1) = One-ROT(2,2)**2-ROT(2,3)**2 +if (ROT(2,1) < Zero) ROT(2,1) = Zero +ROT(2,1) = sqrt(ROT(2,1)) +ROT(3,1) = One-ROT(3,3)**2-ROT(3,2)**2 +if (ROT(3,1) < Zero) ROT(3,1) = Zero +ROT(3,1) = sqrt(ROT(3,1)) + +IFLAG = 0 +do + TAL = ROT(1,1)*ROT(1,2)+ROT(2,1)*ROT(2,2)+ROT(3,1)*ROT(3,2) + ROT(:,1) = ROT(:,1)-TAL*ROT(:,2) + TAL = ROT(1,1)*ROT(1,3)+ROT(2,1)*ROT(2,3)+ROT(3,1)*ROT(3,3) + ROT(:,1) = ROT(:,1)-TAL*ROT(:,3) + A = One/sqrt(ROT(1,1)**2+ROT(2,1)**2+ROT(3,1)**2) + ROT(:,1) = ROT(:,1)*A + IFLAG = IFLAG+1 + if (IFLAG > 3) then + write(u6,*) ' STOP IN TRANSROT' + call Quit(_RC_GENERAL_ERROR_) + end if + if (A <= Ten) exit +end do + +return + +end subroutine TransRot diff -Nru openmolcas-22.02/src/qmstat/wrrdsim.f openmolcas-22.10/src/qmstat/wrrdsim.f --- openmolcas-22.02/src/qmstat/wrrdsim.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/qmstat/wrrdsim.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,41 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -*----------------------------------------------------------------------* -* A routine inspired by the wr_motra_info utility. * -*----------------------------------------------------------------------* - Subroutine WrRdSim(iLu,iOpt,iDisk,iTcSim,nTcSim,Etot - &,Radie,nPart,Gamma,Gam,Esav) - Implicit Real*8 (a-h,o-z) - Dimension iTcSim(nTcSim) - Dimension Dum(1),iDum(1) - - Call iDaFile(iLu,iOpt,iTcSim,nTcSim,iDisk) - Dum(1)=Etot - Call dDaFile(iLu,iOpt,Dum,1,iDisk) - Etot=Dum(1) - Dum(1)=Radie - Call dDaFile(iLu,iOpt,Dum,1,iDisk) - Radie=Dum(1) - iDum(1)=nPart - Call iDaFile(iLu,iOpt,iDum,1,iDisk) - nPart=iDum(1) - Dum(1)=Gamma - Call dDaFile(iLu,iOpt,Dum,1,iDisk) - Gamma=Dum(1) - Dum(1)=Gam - Call dDaFile(iLu,iOpt,Dum,1,iDisk) - Gam=Dum(1) - Dum(1)=Esav - Call dDaFile(iLu,iOpt,Dum,1,iDisk) - Esav=Dum(1) - - Return - End diff -Nru openmolcas-22.02/src/qmstat/wrrdsim.F90 openmolcas-22.10/src/qmstat/wrrdsim.F90 --- openmolcas-22.02/src/qmstat/wrrdsim.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/qmstat/wrrdsim.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,48 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +!----------------------------------------------------------------------* +! A routine inspired by the wr_motra_info utility. * +!----------------------------------------------------------------------* +subroutine WrRdSim(iLu,iOpt,iDisk,iTcSim,nTcSim,Etot,Radie,nPart,Gmma,Gam,Esav) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iLu, iOpt, nTcSim +integer(kind=iwp), intent(inout) :: iDisk, iTcSim(nTcSim), nPart +real(kind=wp), intent(inout) :: Etot, Radie, Gmma, Gam, Esav +integer(kind=iwp) :: iDum(1) +real(kind=wp) :: Dum(1) + +call iDaFile(iLu,iOpt,iTcSim,nTcSim,iDisk) +Dum(1) = Etot +call dDaFile(iLu,iOpt,Dum,1,iDisk) +Etot = Dum(1) +Dum(1) = Radie +call dDaFile(iLu,iOpt,Dum,1,iDisk) +Radie = Dum(1) +iDum(1) = nPart +call iDaFile(iLu,iOpt,iDum,1,iDisk) +nPart = iDum(1) +Dum(1) = Gmma +call dDaFile(iLu,iOpt,Dum,1,iDisk) +Gmma = Dum(1) +Dum(1) = Gam +call dDaFile(iLu,iOpt,Dum,1,iDisk) +Gam = Dum(1) +Dum(1) = Esav +call dDaFile(iLu,iOpt,Dum,1,iDisk) +Esav = Dum(1) + +return + +end subroutine WrRdSim diff -Nru openmolcas-22.02/src/rasscf/calcnewx.f openmolcas-22.10/src/rasscf/calcnewx.f --- openmolcas-22.02/src/rasscf/calcnewx.f 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rasscf/calcnewx.f 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,162 @@ +************************************************************************ +* This file is part of OpenMolcas. * +* * +* OpenMolcas is free software; you can redistribute it and/or modify * +* it under the terms of the GNU Lesser General Public License, v. 2.1. * +* OpenMolcas is distributed in the hope that it will be useful, but it * +* is provided "as is" and without any express or implied warranties. * +* For more details see the full text of the license in the file * +* LICENSE or in <http://www.gnu.org/licenses/>. * +* * +* Copyright (C) 2022, Jie J. Bao * +************************************************************************ +* **************************************************************** +* history: * +* Jie J. Bao, on Apr. 12, 2022, created this file. * +* **************************************************************** + Subroutine CalcNewX(X,H,G,nSPair,XScr,GScr,EigVal, + & ScrDiag,nScr) + +C Commented lines are options under development and may be used in +C future + use CMS, only:CMSThres,PosHess,BigQaaGrad,nPosHess,LargestQaaGrad, + & NeedMoreStep + INTEGER nSPair,INFO,iPair,nScr + Real*8 X(nSPair),G(nSPair),XScr(nSPair) + Real*8 H(nSPair**2),ScrDiag(nScr),GScr(nSPair) + Real*8 EigVal(nSPair**2) + Real*8 MinGrad,ThreG,ThreH + Real*8 ValGrad,AbsGrad,ValHess,AbsHess +******Thanks to Matthew R. Hermes for this algorithm + +******Solve for x in hx=-g. +******1. diagonalize h to h' with rotation matrix C +******2. (C^T)h(C)(C^T)x=(C^T)g +******3. define x'=(C^T)x; g'=(C^T)g, we have (h')(x')=(g') +******4. (x')_p = (g')_p / (h')_pp +******5. x=(C)(C^T)x=(C)(x') + +* write(6,*) 'gradient before diag' +* CALL RecPrt(' ',' ',G,1,nSPair) +* write(6,*) 'hessian before diag' +* CALL RecPrt(' ',' ',EigVal,1,nSPair) +******Step 1 + CALL DSYEV_('V','U',nSPair,H,nSPair,EigVal,ScrDiag,nScr,INFO) + +******Step 3, g'=(C^T)g + CALL DGEMM_('n','n',1,nSPair,nSPair,1.0d0,G,1,H,nSPair, + & 0.0d0,GScr,1) + +******Step 4 + ThreG=CMSThres*1.0d-2 + ThreH=CMSThres*1.0d-4 + MinGrad=CMSThres*1.0d5 +C write(6,*) 'gradient' +C CALL RecPrt(' ','(1X,15(F9.6,1X))',GScr,1,nSPair) +C write(6,*) 'hessian' +C CALL RecPrt(' ','(1X,15(F9.6,1X))',EigVal,1,nSPair) + + LargestQaaGrad=0.0d0 + nPosHess=0 + DO iPair=1,nSPair + ValGrad=GScr(iPair) + AbsGrad=Abs(ValGrad) + ValHess=EigVal(iPair) + AbsHess=Abs(ValHess) + + IF(ValHess.gt.ThreH) THEN + nPosHess=nPosHess+1 + END IF + IF(AbsGrad.gt.LargestQaaGrad) + & LargestQaaGrad=AbsGrad + + IF( (AbsGrad.lt.ThreG) + & .and.(AbsHess.lt.ThreH)) THEN +C write(6,*) 'constant Qaa for pair',ipair + XScr(iPair)=0.0d0 + ELSE + XScr(iPair)=ValGrad/AbsHess + END IF + + IF( (AbsGrad .lt. ThreG) + & .and.(ValHess .gt. ThreH)) THEN +C write(6,*) 'local minimum for pair',ipair + XScr(iPair)=MinGrad/Abs(EigVal(iPair)) + If(XScr(iPair).gt.1.0d-2) XScr(iPair)=1.0d-2 + END IF + +C END IF + END DO + + PosHess=.false. + BigQaaGrad=.false. + NeedMoreStep=.false. + IF(nPosHess.gt.0) PosHess=.true. + IF(LargestQaaGrad.gt.ThreG) BigQaaGrad=.true. + + IF(PosHess.or.BigQaaGrad) NeedMoreStep=.true. + +C write(6,*) 'steps taken' +C CALL RecPrt(' ','(1X,15(F9.6,1X))',XScr,1,nSPair) +******Step 5 + CALL DGEMM_('n','t',1,nSPair,nSPair, + & 1.0d0,XScr,1,H,nSPair, + & 0.0d0,X,1) + RETURN + End Subroutine + + + + +************************************************************************ + + Subroutine CMSScaleX(X,R,DeltaR,Qnew,Qold, + & RCopy,GDCopy,DgCopy, + & GDstate,GDOrbit,Dgstate,DgOrbit,DDg, + & nSPair,lRoots2,nGD,NAC2,nDDg,Saved) + use CMS, only: NCMSScale +#include "rasdim.fh" +#include "rasscf.fh" +#include "general.fh" +#include "SysDef.fh" +#include "input_ras.fh" +#include "warnings.h" + INTEGER nSPair,lRoots2,nGD,NAC2,nDDg + Real*8 X(nSPair),R(lRoots2),DeltaR(lRoots2),RCopy(lRoots2), + & GDCopy(nGD),DgCopy(nGD),GDState(nGD),Dgstate(nGD), + & GDOrbit(nGD),DgOrbit(nGD),DDg(nDDg) + Real*8 Qnew,Qold + Logical Saved + + INTEGER nScaleMax + + Saved=.true. + + NScaleMax=5 + DO WHILE ((Qold-Qnew).gt.CMSThreshold) + NCMSScale=NCMSScale+1 + IF(NCMSScale.eq.nScaleMax) THEN + write(6,'(6X,A)') + & 'Scaling does not save Qaa from decreasing.' + write(6,'(6X,A)') + & 'Q_a-a decreases for this step.' + Saved=.false. + Exit + END IF + CALL DCopy_(lRoots2,RCopy,1,R,1) + CALL DCopy_(nGD,GDCopy,1,GDState,1) + CALL DCopy_(nGD,DgCopy,1,DgState,1) + CALL DScal_(nSPair,0.1d0,X,1) + + CALL UpDateRotMat(R,DeltaR,X,lRoots,nSPair) + CALL RotGD(GDstate,DeltaR,nGD,lRoots,NAC2) + CALL RotGD(Dgstate,DeltaR,nGD,lRoots,NAC2) + CALL TransposeMat(Dgorbit,Dgstate,nGD,lRoots2,NAC2) + CALL TransposeMat(GDorbit,GDstate,nGD,lRoots2,NAC2) + CALL CalcDDg(DDg,GDorbit,Dgorbit,nDDg,nGD,lRoots2,NAC2) + CALL CalcQaa(Qnew,DDg,lRoots,nDDg) + + END DO + + RETURN + End Subroutine diff -Nru openmolcas-22.02/src/rasscf/CC_CI.f90 openmolcas-22.10/src/rasscf/CC_CI.f90 --- openmolcas-22.02/src/rasscf/CC_CI.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/CC_CI.f90 2022-10-10 14:22:40.000000000 +0000 @@ -24,7 +24,7 @@ use linalg_mod, only: verify_, abort_ use rasscf_data, only: iter, lRoots, EMY, & - S, KSDFT, Ener, nAc, nAcPar, nAcPr2 + S, KSDFT, Ener, nAc, nAcPar, nAcPr2, nroots use general_data, only: iSpin, nSym, nConf, & ntot, ntot1, ntot2, nAsh, nActEl use gas_data, only: ngssh, iDoGas @@ -32,7 +32,10 @@ use generic_CI, only: CI_solver_t use index_symmetry, only: one_el_idx, two_el_idx_flatten use CI_solver_util, only: wait_and_read, RDM_to_runfile, & - CleanMat, triangular_number, inv_triang_number, write_RDM + CleanMat, inv_triang_number, write_RDM +#ifdef _ADDITIONAL_RUNTIME_CHECK_ + use CI_solver_util, only: triangular_number +#endif implicit none save @@ -60,17 +63,17 @@ contains - subroutine CC_CI_ctl(this, actual_iter, CMO, DIAF, D1I_AO, D1A_AO, & - TUVX, F_IN, D1S_MO, DMAT, PSMAT, PAMAT) + subroutine CC_CI_ctl(this, actual_iter, ifinal, iroot, weight, CMO, DIAF, D1I_AO, & + D1A_AO, TUVX, F_IN, D1S_MO, DMAT, PSMAT, PAMAT) use fcidump_reorder, only : get_P_GAS, get_P_inp,ReOrFlag,ReOrInp use fcidump, only : make_fcidumps, transform class(CC_CI_solver_t), intent(in) :: this - integer, intent(in) :: actual_iter - real(wp), intent(in) :: & + integer, intent(in) :: actual_iter, iroot(nroots), ifinal + real(wp), intent(in) :: weight(nroots), & CMO(nTot2), DIAF(nTot), D1I_AO(nTot2), D1A_AO(nTot2), TUVX(nAcpr2) real(wp), intent(inout) :: F_In(nTot1), D1S_MO(nAcPar) real(wp), intent(out) :: DMAT(nAcpar), PSMAT(nAcpr2), PAMAT(nAcpr2) - real(wp) :: energy + real(wp) :: energy(nroots) integer :: jRoot integer, allocatable :: permutation(:) real(wp) :: orbital_E(nTot), folded_Fock(nAcPar) @@ -82,25 +85,30 @@ unused_var(this) + if (size(iroot) >= 2) then + call abort_('SA-CC-CASSCF yet to be implemented.') + write(6,*) 'ifinal, weight have to be printed to compile NAGFOR.', & + ifinal, weight + end if -! SOME DIRTY SETUPS + ! SOME DIRTY SETUPS S = 0.5_wp * dble(iSpin - 1) call check_options(lRoots, lRf, KSDFT, iDoGAS) -! Produce a working FCIDUMP file + ! Produce a working FCIDUMP file if (ReOrFlag /= 0) then allocate(permutation(sum(nAsh(:nSym)))) if (ReOrFlag >= 2) permutation(:) = get_P_inp(ReOrInp) if (ReOrFlag == -1) permutation(:) = get_P_GAS(nGSSH) end if -! This call is not side effect free, sets EMY and modifies F_IN + ! This call is not side effect free, sets EMY and modifies F_IN call transform(actual_iter, CMO, DIAF, D1I_AO, D1A_AO, D1S_MO, F_IN, orbital_E, folded_Fock) -! Fortran Standard 2008 12.5.2.12: -! Allocatable actual arguments that are passed to -! non-allocatable, optional dummy arguments are **not** present. + ! Fortran Standard 2008 12.5.2.12: + ! Allocatable actual arguments that are passed to + ! non-allocatable, optional dummy arguments are **not** present. call make_fcidumps(ascii_fcidmp, h5_fcidmp, & orbital_E, folded_Fock, TUVX, EMY, permutation) @@ -113,7 +121,7 @@ fake_run=actual_iter == 1, energy=energy, & D1S_MO=D1S_MO, DMAT=DMAT, PSMAT=PSMAT, PAMAT=PAMAT) do jRoot = 1, lRoots - ENER(jRoot, ITER) = energy + ENER(jRoot, ITER) = energy(jRoot) end do if (nAsh(1) /= nac) call dblock(dmat) @@ -125,9 +133,10 @@ fake_run, energy, D1S_MO, DMAT, PSMAT, PAMAT) character(len=*), intent(in) :: ascii_fcidmp, h5_fcidmp logical, intent(in) :: fake_run - real(wp), intent(out) :: energy, D1S_MO(nAcPar), DMAT(nAcpar), & + real(wp), intent(out) :: energy(nroots), D1S_MO(nAcPar), DMAT(nAcpar),& PSMAT(nAcpr2), PAMAT(nAcpr2) - real(wp), save :: previous_energy = 0.0_wp + ! real(wp), save :: previous_energy = 0.0_wp + real(wp) :: previous_energy(nroots) character(len=*), parameter :: & input_name = 'CC_CI.inp', energy_file = 'NEWCYCLE' @@ -216,10 +225,10 @@ !> !> @author Oskar Weser !> -!> @paramin[out] DMAT Average 1 body density matrix -!> @paramin[out] DSPN Average spin 1-dens matrix -!> @paramin[out] PSMAT Average symm. 2-dens matrix -!> @paramin[out] PAMAT Average antisymm. 2-dens matrix +!> @param[out] DMAT Average 1 body density matrix +!> @param[out] D1S_MO Average spin 1-dens matrix +!> @param[out] PSMAT Average symm. 2-dens matrix +!> @param[out] PAMAT Average antisymm. 2-dens matrix subroutine read_CC_RDM(DMAT, D1S_MO, PSMAT, PAMAT) real(wp), intent(out) :: DMAT(nAcpar), D1S_MO(nAcPar), & PSMAT(nAcpr2), PAMAT(nAcpr2) diff -Nru openmolcas-22.02/src/rasscf/cictl.f openmolcas-22.10/src/rasscf/cictl.f --- openmolcas-22.02/src/rasscf/cictl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/cictl.f 2022-10-10 14:22:40.000000000 +0000 @@ -35,6 +35,7 @@ *> @param[out] P Average symm. 2-dens matrix *> @param[out] PA Average antisymm. 2-dens matrix *> @param[out] FI Fock matrix from inactive density +*> @param FA *> @param[in,out] D1I Inactive 1-dens matrix *> @param[in,out] D1A Active 1-dens matrix *> @param[in] TUVX Active 2-el integrals @@ -61,6 +62,8 @@ #ifdef _HDF5_ use mh5, only: mh5_put_dset #endif + use csfbas, only: CONF, KCFTP + use CMS, only: iCMSOpt,CMSGiveOpt Implicit Real* 8 (A-H,O-Z) Dimension CMO(*),D(*),DS(*),P(*),PA(*),FI(*),FA(*),D1I(*),D1A(*), @@ -81,7 +84,6 @@ #include "output_ras.fh" Character*16 ROUTINE Parameter (ROUTINE='CICTL ') -#include "csfbas.fh" #include "gugx.fh" #include "WrkSpc.fh" #include "SysDef.fh" @@ -550,8 +552,18 @@ CALL XMSRot(CMO,FI,FA) End If IF(ICMSP.eq.1) THEN - CALL XMSRot(CMO,FI,FA) - CALL CMSRot(TUVX) + If(trim(CMSStartMat).eq.'XMS') Then + CALL XMSRot(CMO,FI,FA) + End If + If(.not.CMSGiveOpt) Then + if(lRoots.eq.2) iCMSOpt=2 + if(lRoots.ge.3) iCMSOpt=1 + End If + If(iCMSOpt.eq.1) Then + CALL CMSOpt(TUVX) + Else If (iCMSOpt.eq.2) Then + CALL CMSRot(TUVX) + End If END IF If(IRotPsi==1) Then CALL f_inquire('ROT_VEC',Do_Rotate) @@ -781,7 +793,7 @@ call getmem('kcnf','allo','inte',ivkcnf,nactel) if(.not.iDoGas)then Call Reord2(NAC,NACTEL,STSYM,0, - & iWork(KICONF(1)),iWork(KCFTP), + & CONF,iWork(KCFTP), & Work(LW4),Work(LW11),iWork(ivkcnf)) c end if c call getmem('kcnf','free','inte',ivkcnf,nactel) @@ -825,7 +837,7 @@ c prwthr,' for root', i Write(LF,'(6X,A,F15.6)') c 'energy=',ener(i,iter) - call gasprwf(iwork(lw12),nac,nactel,stsym,iwork(kiconf(1)), + call gasprwf(iwork(lw12),nac,nactel,stsym,conf, c iwork(kcftp),work(lw4),iwork(ivkcnf)) End If end if @@ -849,7 +861,7 @@ * reorder it according to the split graph GUGA conventions call getmem('kcnf','allo','inte',ivkcnf,nactel) Call Reord2(NAC,NACTEL,STSYM,0, - & iWork(KICONF(1)),iWork(KCFTP), + & CONF,iWork(KCFTP), & Work(LW4),Work(LW11),iWork(ivkcnf)) call getmem('kcnf','free','inte',ivkcnf,nactel) * save reorder CI vector on disk diff -Nru openmolcas-22.02/src/rasscf/CI_solver_util.f openmolcas-22.10/src/rasscf/CI_solver_util.f --- openmolcas-22.02/src/rasscf/CI_solver_util.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/CI_solver_util.f 2022-10-10 14:22:40.000000000 +0000 @@ -10,6 +10,7 @@ * * * Copyright (C) 2019, Giovanni Li Manni * * 2020, Oskar Weser * +* 2021,2022, Arta Safari * ************************************************************************ #include "macros.fh" @@ -23,11 +24,11 @@ use Para_Info, only: MyRank use stdalloc, only: mma_allocate, mma_deallocate use linalg_mod, only: verify_ - use rasscf_data, only: iAdr15, nAc, nAcPar, nAcpr2 + use rasscf_data, only: nAc, nAcPar, nAcpr2, nroots use general_data, only: JobIPH implicit none private - public :: wait_and_read, RDM_to_runfile, + public :: wait_and_read, RDM_to_runfile, rdm_from_runfile, & cleanMat, triangular_number, inv_triang_number, write_RDM #ifdef _MOLCAS_MPP_ #include "global.fh" @@ -50,9 +51,9 @@ use f90_unix_proc, only: sleep #endif character(len=*), intent(in) :: filename - real(wp), intent(out) :: energy + real(wp), intent(out) :: energy(nroots) logical :: newcycle_found - integer :: LuNewC + integer :: LuNewC, i newcycle_found = .false. do while(.not. newcycle_found) call sleep(1) @@ -68,9 +69,9 @@ write(6, *) 'NEWCYCLE file found. Proceding with SuperCI' LuNewC = isFreeUnit(12) call molcas_open(LuNewC, 'NEWCYCLE') - read(LuNewC,*) energy + read(LuNewC,*) (energy(i), i = 1, nroots) close(LuNewC, status='delete') - write(6, *) 'I read the following energy:', energy + write(6, *) 'I read the following energies:', energy end if #ifdef _MOLCAS_MPP_ if (is_real_par()) then @@ -85,21 +86,30 @@ !> !> @author Giovanni Li Manni, Oskar Weser !> -!> @paramin[out] DMAT Average 1 body density matrix -!> @paramin[out] DSPN Average spin 1-dens matrix -!> @paramin[out] PSMAT Average symm. 2-dens matrix -!> @paramin[out] PAMAT Average antisymm. 2-dens matrix - subroutine RDM_to_runfile(DMAT, D1S_MO, PSMAT, PAMAT) +!> @param[out] DMAT Average 1 body density matrix +!> @param[out] D1S_MO Average spin 1-dens matrix +!> @param[out] PSMAT Average symm. 2-dens matrix +!> @param[out] PAMAT Average antisymm. 2-dens matrix +!> @param[in,out] jDisk + subroutine RDM_to_runfile(DMAT, D1S_MO, PSMAT, PAMAT, jDisk) #include "intent.fh" +! _IN_ is not a semantic IN, since DDAFILE is both a read and +! write routine. Redefinition to suppress compiler warning. real(wp), intent(_IN_) :: DMAT(nAcpar), D1S_MO(nAcPar), & PSMAT(nAcpr2), PAMAT(nAcpr2) - integer :: jDisk + integer, intent(inout), optional :: jDisk -! Put it on the RUNFILE + ! Put it on the RUNFILE call Put_D1MO(DMAT,NACPAR) call Put_P2MO(PSMAT,NACPR2) -! Save density matrices on disk - jDisk = IADR15(3) + ! Save density matrices on disk + ! DDAFILE calls BDAFile, iOpt option code + ! 1 = synchronous write + ! 2 = synchronous read + ! BUF = array carrying data + ! lBUF = length of array carrying data + ! jDisk = memory address (automatically incremented upon + ! repeated DDAFILE call) call DDafile(JOBIPH, 1, DMAT, NACPAR, jDisk) call DDafile(JOBIPH, 1, D1S_MO, NACPAR, jDisk) call DDafile(JOBIPH, 1, PSMAT, NACPR2, jDisk) @@ -107,6 +117,21 @@ end subroutine RDM_to_runfile + subroutine rdm_from_runfile(dmat, d1s_mo, psmat, pamat, jdisk) +#include "intent.fh" + ! _OUT_ is not a semantic OUT, since DDAFILE is both a read and + ! write routine. Redefinition to suppress compiler warning. + real(wp), intent(_OUT_) :: dmat(nacpar), d1s_mo(nacpar), + & psmat(nacpr2), pamat(nacpr2) + integer, intent(inout), optional :: jdisk + + call ddafile(jobiph, 2, dmat, nacpar, jdisk) + call ddafile(jobiph, 2, d1s_mo, nacpar, jdisk) + call ddafile(jobiph, 2, psmat, nacpr2, jdisk) + call ddafile(jobiph, 2, pamat, nacpr2, jdisk) + end subroutine rdm_from_runfile + + Subroutine CleanMat(MAT) ************* by G. Li Manni Stuttgart April 2016 ************* * @@ -126,7 +151,7 @@ * ** ** ** ** ** ** ** 89 99 * ** ** ** ** ** ** ** 810 910 1010 * """"""""""""""""""""""""""""""""""" -* mimicking a system with (2 0 0 1 4 3 0 0) actice orbitals (blocked by Irreps) +* mimicking a system with (2 0 0 1 4 3 0 0) active orbitals (blocked by Irreps) * DMAT will be destroyed and replaced with a positive semi-definite one. * N-representability will be preserved. @@ -265,6 +290,4 @@ end subroutine - - end module CI_solver_util diff -Nru openmolcas-22.02/src/rasscf/cmsddg_util.f openmolcas-22.10/src/rasscf/cmsddg_util.f --- openmolcas-22.02/src/rasscf/cmsddg_util.f 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rasscf/cmsddg_util.f 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,160 @@ +************************************************************************ +* This file is part of OpenMolcas. * +* * +* OpenMolcas is free software; you can redistribute it and/or modify * +* it under the terms of the GNU Lesser General Public License, v. 2.1. * +* OpenMolcas is distributed in the hope that it will be useful, but it * +* is provided "as is" and without any express or implied warranties. * +* For more details see the full text of the license in the file * +* LICENSE or in <http://www.gnu.org/licenses/>. * +* * +* Copyright (C) 2022, Jie J. Bao * +************************************************************************ +****************************************************************** +* history: * +* Jie J. Bao, on Apr. 12, 2022, created this file. * +****************************************************************** + +*This file contains subroutines that calculates the DDg matrix, Q_aa, +* the Gradient and Hessian of Q_aa wrt intermediate-state rotations. + +************************************************************************ + Subroutine CalcDDg(DDg,GD,Dg,nDDg,nGD,lRoots2,NAC2) +****************************************************************** +* Gtuvx : two-electron integral, g_tuvx * +* GD : "generalized 1-e density matrix" * +* GD^KL: transition density matrix from L to K * +* GD^KK: density matrix for state K * +* Dg : sum_{vx}{GD^KL_vx * g_tuvx} * +* In GDorbit and Dgorbit, the leading index is orbital index;* +* In GDstate and Dgstate, the leading index is state index. * +* * +* DDg : sum_{tuvx}{GD^KL_tu * GD^MN_vx * g_tuvx} * +* namely, sum_{tu}{GD^KL_tu * Dg^MN_tu} * +****************************************************************** + INTEGER nDDg, nGD, lRoots2, NAC2 + Real*8 DDg(nDDg),GD(nGD),Dg(nGD) + + + CALL DGEMM_('T','N',lRoots2,lRoots2,NAC2, + & 1.0d0, Dg, NAC2, GD, NAC2, + & 0.0d0, DDg, lRoots2) + + RETURN + End Subroutine + +************************************************************************ + + + Subroutine CalcHessCMS(Hess,DDg,nDDg,lRoots,nSPair) + INTEGER nDDg,lRoots,nSPair + Real*8 DDg(nDDg),Hess(nSPair**2) + Real*8 Vklmn,Vlknm,Vklnm,Vlkmn + INTEGER K,L,M,N,iKL,iMN,iLoc1,iLoc2,iLoc3,iLoc4,iLoc5, + & lRoots2,lRoots3,lRoots23 + + lRoots2=lRoots**2 + lRoots3=lRoots2*lRoots + lRoots23=lRoots2+lRoots3 + + DO K=2,lRoots + DO L=1,K-1 + iKL=(K-2)*(K-1)/2+L + Do M=2,lRoots + Do N=1,M-1 + iMN=(M-2)*(M-1)/2+N + Vklmn=0.0d0 + Vlknm=0.0d0 + Vlkmn=0.0d0 + Vklnm=0.0d0 + iLoc5=K+(L-1)*lRoots+(M-1)*lRoots2+(N-1)*lRoots3 + IF(L.eq.M) THEN + iLoc4=K+(N-1)*lRoots + iLoc1=iLoc4+(K-1)*lRoots23 + iLoc2=iLoc4+(N-1)*lRoots23 + iLoc3=iLoc4+(L-1)*lRoots23 + Vklmn=DDg(iLoc1)+DDg(iLoc2)-2.0d0*DDg(iLoc3)-4.0d0*DDg(iLoc5) +C Vklmn=DDg(K,N,K,K)+DDg(K,N,N,N)-2.0d0*DDg(K,N,L,L) +C & -4.0d0*DDg(K,L,M,N) + END IF + IF(K.eq.N) THEN + iLoc4=L+(M-1)*lRoots + iLoc1=iLoc4+(L-1)*lRoots23 + iLoc2=iLoc4+(M-1)*lRoots23 + iLoc3=iLoc4+(K-1)*lRoots23 + Vlknm=DDg(iLoc1)+DDg(iLoc2)-2.0d0*DDg(iLoc3)-4.0d0*DDg(iLoc5) +C Vlknm=DDg(L,M,L,L)+DDg(L,M,M,M)-2.0d0*DDg(L,M,K,K) +C & -4.0d0*DDg(K,L,M,N) + END IF + IF(K.eq.M) THEN + iLoc4=L+(N-1)*lRoots + iLoc1=iLoc4+(L-1)*lRoots23 + iLoc2=iLoc4+(N-1)*lRoots23 + iLoc3=iLoc4+(K-1)*lRoots23 + Vlkmn=DDg(iLoc1)+DDg(iLoc2)-2.0d0*DDg(iLoc3)-4.0d0*DDg(iLoc5) +C Vlkmn=DDg(L,N,L,L)+DDg(L,N,N,N)-2.0d0*DDg(L,N,K,K) +C & -4.0d0*DDg(K,L,M,N) + END IF + IF(L.eq.N) THEN + iLoc4=K+(M-1)*lRoots + iLoc1=iLoc4+(K-1)*lRoots23 + iLoc2=iLoc4+(M-1)*lRoots23 + iLoc3=iLoc4+(L-1)*lRoots23 + Vklnm=DDg(iLoc1)+DDg(iLoc2)-2.0d0*DDg(iLoc3)-4.0d0*DDg(iLoc5) +C Vklnm=DDg(K,M,K,K)+DDg(K,M,M,M)-2.0d0*DDg(K,M,L,L) +C & -4.0d0*DDg(K,L,M,N) + END IF + Hess((iKL-1)*nSPair+iMN)=Vklmn+Vlknm-Vklnm-Vlkmn + End Do + End Do + END DO + END DO + + + RETURN + End Subroutine + +************************************************************************ + + Subroutine CalcGradCMS(Grad,DDg,nDDg,lRoots,nSPair) + INTEGER nDDg,lRoots,nSPair + Real*8 Grad(nSPair),DDg(nDDg) + + INTEGER K,L,iKL,lRoots2,lRoots3,iLoc1,iLoc2 + + lRoots2=lRoots**2 + lRoots3=lRoots*lRoots2 + + DO K=2,lRoots + Do L=1,K-1 + iLoc1=K+(K-1)*lRoots+(K-1)*lRoots2+(L-1)*lRoots3 + iLoc2=L+(L-1)*lRoots+(K-1)*lRoots2+(L-1)*lRoots3 + iKL=(K-1)*(K-2)/2+L + Grad(iKL)=DDg(iLoc1)-DDg(iLoc2) + End Do + END DO + CALL DSCal_(nSPair,2.0d0,Grad,1) + RETURN + End Subroutine +************************************************************************ + + +************************************************************************ + Subroutine CalcQaa(Qaa,DDg,lRoots,nDDg) + INTEGER lRoots,nDDg + Real*8 DDg(nDDg) + Real*8 Qaa + + INTEGER iState,iLoc,Int1,lRoots2 + + lRoots2=lRoots**2 + Int1=(lRoots2+1)*(lRoots+1) + Qaa=0.0d0 + DO iState=1,lRoots + iLoc=(iState-1)*Int1+1 + Qaa=Qaa+DDg(iLoc) + END DO + Qaa=Qaa/2.0d0 + + RETURN + End Subroutine diff -Nru openmolcas-22.02/src/rasscf/cms.f90 openmolcas-22.10/src/rasscf/cms.f90 --- openmolcas-22.02/src/rasscf/cms.f90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rasscf/cms.f90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,29 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 2022, Jie J. Bao * +!*********************************************************************** +! **************************************************************** +! history: * +! Jie J. Bao, on Apr. 01, 2022, created this file. * +! **************************************************************** + +Module CMS +logical CMSNotConverged +Logical CMSGiveOpt +Real*8 CMSThres +Real*8,DIMENSION(:),Allocatable:: RGD +INTEGER iCMSOpt +Logical PosHess,BigQaaGrad,NeedMoreStep +INTEGER nPosHess,nCMSScale +Real*8 LargestQaaGrad +CHARACTER*128 cmsguessfile +End Module CMS + diff -Nru openmolcas-22.02/src/rasscf/cmsgd_util.f openmolcas-22.10/src/rasscf/cmsgd_util.f --- openmolcas-22.02/src/rasscf/cmsgd_util.f 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rasscf/cmsgd_util.f 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,167 @@ +************************************************************************ +* This file is part of OpenMolcas. * +* * +* OpenMolcas is free software; you can redistribute it and/or modify * +* it under the terms of the GNU Lesser General Public License, v. 2.1. * +* OpenMolcas is distributed in the hope that it will be useful, but it * +* is provided "as is" and without any express or implied warranties. * +* For more details see the full text of the license in the file * +* LICENSE or in <http://www.gnu.org/licenses/>. * +* * +* Copyright (C) 2022, Jie J. Bao * +************************************************************************ +****************************************************************** +* history: * +* Jie J. Bao, on Apr. 11, 2022, created this file. * +****************************************************************** + +* This file contains subroutines relating to generalized 1-e +* density matrix (GD) called in CMSNewton, including +* CalcGD: calculating GD with lucia. +* CalcDg: calculating Dg matrix, namely sum_{vx}{GD^KL_vx * g_tuvx} +* RotGD: GD^KL_tu = sum_{MN}{U^KM * U^LN * GD^MN_tu} +* TransposeMat: transform GD^KL_tu from leading with state indices +* to leading with orbital indices in mode 1, and vice +* versa in mode 2. + + + + Subroutine RotGD(GD,R,nGD,lRoots,NAC2) + use CMS, only: RGD + INTEGER nGD,lRoots,NAC2 + Real*8 GD(nGD),R(lRoots**2) + + INTEGER iNAC2,iLoc,lRoots2 +* Real*8 RGD(lRoots**2),RGDR(lRoots**2) + + lRoots2=lRoots**2 + + +C write(6,*) 'rotation matrix in RotGD' +C CALL RecPrt(' ',' ',R,lRoots,lRoots) +C +C write(6,*) 'GD matrix after rotation' +C CALL RecPrt(' ',' ',GD,lRoots2,NAC2) + + + DO iNAC2=1,NAC2 + iLoc=(iNAC2-1)*lRoots2+1 + CALL DGEMM_('T','N',lRoots,lRoots,lRoots, + & 1.0d0,R ,lRoots,GD(iLoc),lRoots, + & 0.0d0,RGD ,lRoots) + CALL DGEMM_('N','N',lRoots,lRoots,lRoots, + & 1.0d0,RGD ,lRoots,R ,lRoots, + & 0.0d0,GD(iLoc),lRoots) + END DO + +C write(6,*) 'GD matrix after rotation' +C CALL RecPrt(' ',' ',GD,lRoots2,NAC2) + + RETURN + End Subroutine + + + Subroutine TransposeMat(Matout,Matin,nElem,nRow_in,nCol_in) + INTEGER nElem,nRow_in,nCol_in,iRow,iCol,iOff1,iOff2 + Real*8 Matin(nElem),Matout(nElem) + + IF(nRow_in*nCol_in.ne.nElem) THEN + write(6,*) 'Error in TransposeMat()' + write(6,*) 'nRow_in*nCol_in != nElem' + END IF + + DO iCol=1,nCol_in + iOff1=(iCol-1)*nRow_in + Do iRow=1,nRow_in + iOff2=(iRow-1)*nCol_in + Matout(iOff2+iCol)=Matin(iOff1+iRow) + End Do + END DO + + RETURN + End Subroutine +************************************************************************ + + Subroutine CalcDg(Dgorbit,GDorbit,Gtuvx,nGD,nTUVX,NAC,lRoots) + INTEGER nGD,nTUVX,NAC,lRoots + Real*8 Dgorbit(nGD),GDorbit(nGD),Gtuvx(nTUVX) + + INTEGER NAC2,lRoots2 + + NAC2=NAC**2 + lRoots2=lRoots**2 + + CALL DGEMM_('T','N',NAC2,lRoots2,NAC2,1.0d0, + & Gtuvx,NAC2,GDorbit,NAC2,0.0d0, + & Dgorbit,NAC2) + + RETURN + End Subroutine +************************************************************************ + + Subroutine CalcGD(GD,nGD) +#include "rasdim.fh" +#include "rasscf.fh" +#include "general.fh" +#include "WrkSpc.fh" +#include "SysDef.fh" +#include "input_ras.fh" +#include "warnings.h" +#include "rasscf_lucia.fh" + INTEGER nGD + Real*8 GD(nGD) + INTEGER CIDisk1,CIDisk2,iVecL,iVecR,iDummy + INTEGER tlw6,tlw7,ldtmp,lsdtmp + INTEGER p,q,ipq,iqp,NAC2,IOffNIJ1,IOffNIJ2 + REAL*8 Dummy(1) + + NAC2=NAC**2 + tlw6=lw6 + tlw7=lw7 + Call GetMem('LVEC','ALLO','REAL',iVecL,NConf) + Call GetMem('RVEC','ALLO','REAL',iVecR,NConf) + Call GetMem('Dtmp','ALLO','REAL',ldtmp,NAC**2) + Call GetMem('SDtmp','ALLO','REAL',lsdtmp,NAC**2) + lw6=ldtmp + lw7=lsdtmp + CIDisk1=IADR15(4) + Do jRoot=1,lRoots + Call DDafile(JOBIPH,2,Work(iVecL),nConf,CIDisk1) + C_Pointer=iVecL + CIDisk2=IADR15(4) + Do kRoot=1,jRoot-1 + Call DDafile(JOBIPH,2,Work(iVecR),nConf,CIDisk2) + Call Lucia_Util('Densi',iVecR,iDummy,Dummy) + IOffNIJ1=(lRoots*(jRoot-1)+kRoot-1)*NAC2 + IOffNIJ2=(lRoots*(kRoot-1)+jRoot-1)*NAC2 +C write(6,*)'GD matrix',jRoot,kRoot +C CALL RecPrt(' ',' ',WORK(LW6),NAC,NAC) + Call DCopy_(NAC2,WORK(LW6),1,GD(IOffNIJ1+1),1) + dO q=1,NAC + do p=1,NAC + ipq=(q-1)*NAC+p + iqp=(p-1)*NAC+q + GD(IOffNIJ2+iqp)=WORK(LW6+ipq-1) +* GDMat(NIJ2,q,p)=WORK(LW6+q-1+(p-1)*NAC) + end do + eND dO + End Do + kRoot=jRoot + Call DDafile(JOBIPH,2,Work(iVecR),nConf,CIDisk2) + Call Lucia_Util('Densi',iVecR,iDummy,Dummy) + IOffNIJ1=(lRoots+1)*(jRoot-1)*NAC2 +C write(6,*)'GD matrix',jRoot,kRoot +C CALL RecPrt(' ',' ',WORK(LW6),NAC,NAC) + Call DCopy_(NAC2,WORK(LW6),1,GD(IOffNIJ1+1),1) + End DO + lw6=tlw6 + lw7=tlw7 + Call GetMem('LVEC','FREE','REAL',iVecL,NConf) + Call GetMem('RVEC','FREE','REAL',iVecR,NConf) + Call GetMem('Dtmp','FREE','REAL',ldtmp,NAC**2) + Call GetMem('SDtmp','Free','REAL',lsdtmp,NAC**2) + RETURN + END Subroutine +************************************************************************ + + diff -Nru openmolcas-22.02/src/rasscf/cmsnewton.f openmolcas-22.10/src/rasscf/cmsnewton.f --- openmolcas-22.02/src/rasscf/cmsnewton.f 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rasscf/cmsnewton.f 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,157 @@ +************************************************************************ +* This file is part of OpenMolcas. * +* * +* OpenMolcas is free software; you can redistribute it and/or modify * +* it under the terms of the GNU Lesser General Public License, v. 2.1. * +* OpenMolcas is distributed in the hope that it will be useful, but it * +* is provided "as is" and without any express or implied warranties. * +* For more details see the full text of the license in the file * +* LICENSE or in <http://www.gnu.org/licenses/>. * +* * +* Copyright (C) 2022, Jie J. Bao * +************************************************************************ +****************************************************************** +* history: * +* Jie J. Bao, on Apr. 11, 2022, created this file. * +****************************************************************** + + + Subroutine CMSNewton(R,GDorbit,GDstate,Dgorbit,Dgstate,nGD) + use CMS, only:CMSNotConverged,CMSThres,NeedMoreStep, + & nPosHess,LargestQaaGrad,NCMSScale + use stdalloc, only : mma_allocate, mma_deallocate +#include "rasdim.fh" +#include "rasscf.fh" +#include "general.fh" +#include "SysDef.fh" +#include "input_ras.fh" +#include "warnings.h" + INTEGER nGD + Real*8 R(lRoots**2), + & GDorbit(nGD),GDstate(nGD), + & Dgorbit(nGD),Dgstate(nGD) + Real*8,DIMENSION(:),Allocatable::X,Hess,Grad,EigVal,deltaR,DDg, + & XScr,GScr,ScrDiag, + & RCopy,GDCopy,DgCopy + + Real*8,DIMENSION(:,:),Allocatable::RotMat + INTEGER iStep,nDDg,lRoots2,NAC2, + & nSPair,nSPair2,nScr + Real*8 Qnew,Qold + Logical Saved + +* preparation + lRoots2=lRoots**2 + NAC2=NAC**2 + nDDg=lRoots2**2 + nSPair=(lRoots-1)*lRoots/2 + nSPair2=nSPair**2 + CMSThres=CMSThreshold + CALL mma_allocate(DDg ,nDDg ) + Call mma_allocate(X ,nSPair ) + Call mma_allocate(XScr ,nSPair ) + Call mma_allocate(GScr ,nSPair ) + Call mma_allocate(Grad ,nSPair ) + Call mma_allocate(Hess ,nSPair2 ) + Call mma_allocate(EigVal ,nSPair ) + CALL mma_allocate(DeltaR ,lRoots2 ) + CALL mma_allocate(GDCopy ,nGD ) + CALL mma_allocate(DgCopy ,nGD ) + CALL mma_allocate(RCopy ,lRoots2 ) + CALL mma_allocate(RotMat ,lRoots,lRoots) +* Step 0 + iStep=0 + Qold=0.0d0 +* Note that the following six lines appear as a group + CALL RotGD(GDstate,R,nGD,lRoots,NAC2) + CALL RotGD(Dgstate,R,nGD,lRoots,NAC2) + CALL TransposeMat(Dgorbit,Dgstate,nGD,lRoots2,NAC2) + CALL TransposeMat(GDorbit,GDstate,nGD,lRoots2,NAC2) + CALL CalcDDg(DDg,GDorbit,Dgorbit,nDDg,nGD,lRoots2,NAC2) + CALL CalcQaa(Qnew,DDg,lRoots,nDDg) + nPosHess=0 + LargestQaaGrad=0.0d0 + Qold=Qnew + CALL PrintCMSIter(iStep,Qnew,Qold,R,lRoots) + CALL CalcGradCMS(Grad,DDg,nDDg,lRoots,nSPair) + CALL CalcHessCMS(Hess,DDg,nDDg,lRoots,nSPair) + CALL GetDiagScr(nScr,Hess,EigVal,nSPair) + CALL mma_allocate(ScrDiag,nScr ) + +* Starting iteration + DO WHILE(CMSNotConverged) + iStep=iStep+1 + Qold=Qnew + IF(iStep.gt.iCMSIterMax) THEN + write(6,'(4X,A)')'NOT CONVERGED AFTER MAX NUMBER OF CYCLES' + Exit + END IF + + CALL DCopy_(lRoots2,R,1,RCopy,1) + CALL DCopy_(nGD,GDState,1,GDCopy,1) + CALL DCopy_(nGD,DgState,1,DgCopy,1) + + CALL CalcNewX(X,Hess,Grad,nSPair, + & XScr,GScr,EigVal,ScrDiag,nScr) + CALL UpDateRotMat(R,DeltaR,X,lRoots,nSPair) + + CALL RotGD(GDstate,DeltaR,nGD,lRoots,NAC2) + CALL RotGD(Dgstate,DeltaR,nGD,lRoots,NAC2) + CALL TransposeMat(Dgorbit,Dgstate,nGD,lRoots2,NAC2) + CALL TransposeMat(GDorbit,GDstate,nGD,lRoots2,NAC2) + CALL CalcDDg(DDg,GDorbit,Dgorbit,nDDg,nGD,lRoots2,NAC2) + CALL CalcQaa(Qnew,DDg,lRoots,nDDg) + + NCMSScale=0 + Saved=.true. + IF((Qold-Qnew).gt.CMSThreshold) THEN + If(iStep.gt.ICMSIterMin) Then +* When Onew is less than Qold, scale the rotation matrix + CALL CMSScaleX(X,R,DeltaR,Qnew,Qold, + & RCopy,GDCopy,DgCopy, + & GDstate,GDOrbit,Dgstate,DgOrbit,DDg, + & nSPair,lRoots2,nGD,NAC2,nDDg,Saved) + End If + END IF + CALL PrintCMSIter(iStep,Qnew,Qold,R,lRoots) + CALL AntiOneDFoil(RotMat,R,lRoots,lRoots) + CALL PrintMat('ROT_VEC','CMS-PDFT temp', + & RotMat,lroots,lroots,7,13,'T') + + IF(.not. Saved) THEN + CMSNotConverged=.true. +* Exit + END IF +* sanity check + IF(abs(Qnew-Qold).lt.CMSThreshold) THEN + CMSNotConverged=.false. + If(NeedMoreStep) CMSNotConverged=.true. + If(iStep.lt.iCMSIterMin) CMSNotConverged=.true. + If(NCMSScale.gt.0) CMSNotConverged=.true. + END IF + IF(CMSNotConverged) THEN + CALL CalcGradCMS(Grad,DDg,nDDg,lRoots,nSPair) + CALL CalcHessCMS(Hess,DDg,nDDg,lRoots,nSPair) + ELSE + write(6,'(4X,A)')'CONVERGENCE REACHED' + END IF + END DO + + CALL mma_deallocate(DDg ) + Call mma_deallocate(X ) + Call mma_deallocate(XScr ) + Call mma_deallocate(GScr ) + Call mma_deallocate(Grad ) + Call mma_deallocate(Hess ) + Call mma_deallocate(EigVal ) + CALL mma_deallocate(DeltaR ) + CALL mma_deallocate(ScrDiag) + CALL mma_deallocate(GDCopy ) + CALL mma_deallocate(DgCopy ) + CALL mma_deallocate(RCopy ) + CALL mma_deallocate(RotMat ) + RETURN + End Subroutine + + + diff -Nru openmolcas-22.02/src/rasscf/cmsopt.f openmolcas-22.10/src/rasscf/cmsopt.f --- openmolcas-22.02/src/rasscf/cmsopt.f 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rasscf/cmsopt.f 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,123 @@ +************************************************************************ +* This file is part of OpenMolcas. * +* * +* OpenMolcas is free software; you can redistribute it and/or modify * +* it under the terms of the GNU Lesser General Public License, v. 2.1. * +* OpenMolcas is distributed in the hope that it will be useful, but it * +* is provided "as is" and without any express or implied warranties. * +* For more details see the full text of the license in the file * +* LICENSE or in <http://www.gnu.org/licenses/>. * +* * +* Copyright (C) 2022, Jie J. Bao * +************************************************************************ + Subroutine CMSOpt(TUVX) +* **************************************************************** +* history: * +* Jie J. Bao, on Apr. 07, 2022, created this file. * +* **************************************************************** + use stdalloc, only : mma_allocate, mma_deallocate + use CMS, only: CMSNotConverged,RGD +#include "rasdim.fh" +#include "rasscf.fh" +#include "general.fh" +#include "SysDef.fh" +#include "input_ras.fh" +#include "warnings.h" + + Real*8,DIMENSION(NACPR2)::TUVX + Real*8,DIMENSION(:),Allocatable::Gtuvx,R, + & GDstate,GDorbit, + & Dgstate,Dgorbit + Real*8,DIMENSION(:,:),Allocatable::RotMat + + INTEGER nTUVX,nGD,lRoots2,NAC2 + + CHARACTER(len=16)::VecName +****************************************************************** +* some notes on the arrays: * +* Gtuvx : two-electron integral, g_tuvx * +* GD : "generalized 1-e density matrix" * +* GD^KL: transition density matrix from L to K * +* GD^KK: density matrix for state K * +* Dg : sum_{vx}{GD^KL_vx * g_tuvx} * +* In GDorbit and Dgorbit, the leading index is orbital index;* +* In GDstate and Dgstate, the leading index is state index. * +* * +* DDg : sum_{tuvx}{GD^KL_tu * GD^MN_vx * g_tuvx} * +* namely, sum_{tu}{GD^KL_tu * Dg^MN_tu} * +****************************************************************** + + NAC2=NAC**2 + nTUVX=NAC2**2 + lRoots2=lRoots**2 + nGD=lRoots2*NAC2 + + CMSNotConverged=.true. + +******Memory Allocation + CALL mma_allocate(R ,lRoots2) + CALL mma_allocate(GDstate,nGD ) + CALL mma_allocate(Dgstate,nGD ) + CALL mma_allocate(GDorbit,nGD ) + CALL mma_allocate(Dgorbit,nGD ) + CALL mma_allocate(Gtuvx ,nTUVX ) + CALL mma_allocate(RGD ,lRoots2) + CALL mma_allocate(RotMat ,lRoots,lRoots) + +******Calculate generalized density mtrix + CALL UnzipTUVX(TUVX,Gtuvx,nTUVX) + +C write(6,*) 'Gtuvx matrix' +C CALL RecPrt(' ',' ',Gtuvx,NAC2,NAC2) + + CALL CalcGD(GDorbit,nGD) +C write(6,*) 'GD matrix orbital-leading' +C CALL RecPrt(' ',' ',GDorbit,NAC2,lRoots2) + CALL CalcDg(Dgorbit,GDorbit,Gtuvx,nGD,nTUVX,NAC,lRoots) +C write(6,*) 'Dg matrix orbital-leading' +C CALL RecPrt(' ',' ',Dgorbit,NAC2,lRoots2) + + CALL mma_deallocate(Gtuvx ) + + CALL TransposeMat(Dgstate,Dgorbit,nGD,NAC2,lRoots2) + CALL TransposeMat(GDstate,GDorbit,nGD,NAC2,lRoots2) + +******Load initial rotation matrix + CALL InitRotMat(RotMat,lRoots, + & trim(CMSStartMat),len_trim(CMSStartMat)) + + CALL OneDFoil(R,RotMat,lRoots,lRoots) + +******Print header of CMS iterations + CALL CMSHeader(trim(CMSStartMat),len_trim(CMSStartMat)) + +******Start CMS Optimization + CMSNotConverged=.true. + CALL CMSNewton(R,GDorbit,GDstate,Dgorbit,Dgstate,nGD) + +******Print end of CMS intermediate-state optimization + CALL CMSTail() + +******Save rotation matrix + CALL AntiOneDFoil(RotMat,R,lRoots,lRoots) + VecName='CMS-PDFT' + CALL PrintMat('ROT_VEC',VecName,RotMat,lroots,lroots,7,16,'T') + +******releasing memory + CALL mma_deallocate(R ) + CALL mma_deallocate(GDstate) + CALL mma_deallocate(Dgstate) + CALL mma_deallocate(GDorbit) + CALL mma_deallocate(Dgorbit) + CALL mma_deallocate(RGD ) + CALL mma_deallocate(RotMat ) + +******check convergence + IF(CMSNotConverged) THEN + Call WarningMessage(2,'CMS Intermediate States Not Converged') + Call Quit(_RC_NOT_CONVERGED_) + END IF + + RETURN + End Subroutine + diff -Nru openmolcas-22.02/src/rasscf/cmsrot.f openmolcas-22.10/src/rasscf/cmsrot.f --- openmolcas-22.02/src/rasscf/cmsrot.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/cmsrot.f 2022-10-10 14:22:40.000000000 +0000 @@ -1,4 +1,4 @@ -*********************************************************************** +************************************************************************ * This file is part of OpenMolcas. * * * * OpenMolcas is free software; you can redistribute it and/or modify * @@ -16,6 +16,7 @@ * Jie J. Bao, on Aug. 06, 2020, created this file. * * **************************************************************** use stdalloc, only : mma_allocate, mma_deallocate + use CMS, only: CMSNotConverged #include "rasdim.fh" #include "rasscf.fh" #include "general.fh" @@ -37,26 +38,29 @@ CALL mma_allocate(Gtuvx,NAC,NAC,NAC,NAC) CALL mma_allocate(DDG,lRoots,lRoots,lRoots,lRoots) - CALL ReadMat('ROT_VEC',VecName,RotMat,lroots,lroots,7,16,'N') +* printing header + write(6,*) + write(6,*) + write(6,*) ' CMS INTERMEDIATE-STATE OPTIMIZATION' + IF(trim(CMSStartMat).eq.'XMS') THEN + CALL ReadMat('ROT_VEC',VecName,RotMat,lroots,lroots,7,16,'N') + ELSE + CALL ReadMat(trim(CMSStartMat),VecName,RotMat,lroots,lroots, + & len_trim(CMSStartMat),16,'N') + END IF + CALL CMSHeader(trim(CMSStartMat),len_trim(CMSStartMat)) + CALL LoadGtuvx(TUVX,Gtuvx) + CMSNotConverged=.false. CALL GetGDMat(GDMat) IF(lRoots.lt.NAC) THEN -C write(6,*)"Optimization Approach 1" - DO I=1,lRoots - Do J=1,lRoots - if (I.eq.J) then - RotMat(I,I)=1.0d0 - else - RotMat(I,J)=0.0d0 - end if - End Do - END DO +* write(6,*)"Optimization Approach 1" CALL GetDDgMat(DDg,GDMat,Gtuvx) CALL NStateOpt(RotMat,DDg) ELSE -C write(6,*)"Optimization Approach 2" +* write(6,*)"Optimization Approach 2" CALL NStateOpt2(RotMat,GDMat,Gtuvx) END IF VecName='CMS-PDFT' @@ -67,14 +71,19 @@ CALL mma_deallocate(RotMat) CALL mma_deallocate(Gtuvx) CALL mma_deallocate(DDg) + IF(CMSNotConverged) THEN + Call WarningMessage(2,'CMS Intermediate States Not Converged') + Call Quit(_RC_NOT_CONVERGED_) + END IF RETURN End Subroutine -*********************************************************************** +************************************************************************ -*********************************************************************** +************************************************************************ Subroutine NStateOpt(RotMat,DDg) use stdalloc, only : mma_allocate, mma_deallocate + use CMS, only: CMSNotConverged #include "rasdim.fh" #include "rasscf.fh" #include "general.fh" @@ -110,24 +119,6 @@ Converged=.false. CALL Copy2DMat(FRot,RotMat,lRoots,lRoots) VeeSumOld=CalcNSumVee(RotMat,DDg) - write(6,*) - write(6,*) - write(6,*) ' CMS INTERMEDIATE STATES OPTIMIZATION' - write(6,'(4X,A12,2X,ES8.2E2)') - &'THRESHOLD',Threshold - write(6,'(4X,A12,2X,I8)') - &'MAX CYCLES',ICMSIterMax - write(6,'(4X,A12,2X,I8)') - &'MIN CYCLES',ICMSIterMin - write(6,*)('=',i=1,71) - IF(lRoots.gt.2) THEN - write(6,'(4X,A8,2X,2(A16,11X))') - &'Cycle','Q_a-a','Difference' - ELSE - write(6,'(4X,A8,2X,A18,6X,A8,12X,A12)') - &'Cycle','Rot. Angle (deg.)','Q_a-a','Q_a-a Diff.' - END IF - write(6,*)('-',i=1,71) ICMSIter=0 DO WHILE(.not.Converged) Do IPair=1,NPairs @@ -151,7 +142,9 @@ ELSE if(ICMSIter.ge.ICMSIterMax) then Converged=.true. + CMSNotConverged=.true. write(6,'(4X,A)')'NOT CONVERGED AFTER MAX NUMBER OF CYCLES' + write(6,'(4X,A)')'TEMPORARY ROTATION MATRIX SAVED' end if END IF VeeSumOld=VeeSumNew @@ -163,9 +156,9 @@ CALL mma_deallocate(FRot) RETURN END SUBROUTINE -*********************************************************************** +************************************************************************ -*********************************************************************** +************************************************************************ Subroutine ThetaOpt(FRot,theta,SumVee,StatePair,NPairs,DDg) #include "rasdim.fh" #include "rasscf.fh" @@ -198,8 +191,8 @@ END DO RETURN END SUBROUTINE -*********************************************************************** -*********************************************************************** +************************************************************************ +************************************************************************ SUBROUTINE OptOneAngle(Angle,SumVee,RotMat,DDg,I1,I2,lRoots) use stdalloc, only : mma_allocate, mma_deallocate real*8 Angle,SumVee @@ -285,8 +278,8 @@ RETURN END SUBROUTINE -*********************************************************************** -*********************************************************************** +************************************************************************ +************************************************************************ Function RMax(A,N) INTEGER N,RMax Real*8,DIMENSION(N)::A @@ -298,7 +291,7 @@ RETURN End Function -*********************************************************************** +************************************************************************ Function CalcNSumVee(RotMat,DDg) use stdalloc, only : mma_allocate, mma_deallocate #include "rasdim.fh" @@ -323,8 +316,8 @@ CALL mma_deallocate(Vee) RETURN END Function -*********************************************************************** -*********************************************************************** +************************************************************************ +************************************************************************ Subroutine Copy2DMat(A,B,NRow,NCol) INTEGER NRow,NCol,IRow,ICol Real*8,DIMENSION(NRow,NCol)::A,B @@ -335,8 +328,8 @@ END DO RETURN END SUBROUTINE -*********************************************************************** -*********************************************************************** +************************************************************************ +************************************************************************ Subroutine CMSMatRot(Mat,A,I,J,N) INTEGER I,J,N Real*8 A @@ -351,8 +344,8 @@ END DO RETURN END SUBROUTINE -*********************************************************************** -*********************************************************************** +************************************************************************ +************************************************************************ Subroutine CMSFitTrigonometric(x,y) real*8,DIMENSION(4)::x,y real*8 s12,s23,c12,c23,d12,d23,k,a,b,c,phi,psi1,psi2,val1,val2 @@ -388,9 +381,9 @@ C write(6,*)a,b,c,x(4),y(4) return END Subroutine -*********************************************************************** +************************************************************************ -*********************************************************************** +************************************************************************ Subroutine CalcVee(Vee,RMat,DDg) #include "rasdim.fh" #include "rasscf.fh" @@ -421,8 +414,8 @@ END DO RETURN END SUBROUTINE -*********************************************************************** -*********************************************************************** +************************************************************************ +************************************************************************ Subroutine GetDDgMat(DDg,GDMat,Gtuvx) #include "rasdim.fh" #include "rasscf.fh" @@ -472,7 +465,7 @@ END DO RETURN End Subroutine -*********************************************************************** +************************************************************************ Subroutine LoadGtuvx(TUVX,Gtuvx) * **************************************************************** @@ -513,9 +506,10 @@ END DO RETURN End Subroutine -*********************************************************************** +************************************************************************ Subroutine NStateOpt2(RotMat,GDMat,Gtuvx) use stdalloc, only : mma_allocate, mma_deallocate + use CMS, only: CMSNotConverged #include "rasdim.fh" #include "rasscf.fh" #include "general.fh" @@ -558,24 +552,6 @@ CALL RotGDMat(FRot,GDMat) CALL CalcVee2(Vee,GDMat,Gtuvx) VeeSumOld=SumArray(Vee,lRoots) - write(6,*) - write(6,*) - write(6,*) ' CMS INTERMEDIATE STATES OPTIMIZATION' - write(6,'(4X,A12,2X,ES8.2E2)') - &'THRESHOLD',Threshold - write(6,'(4X,A12,2X,I8)') - &'MAX CYCLES',ICMSIterMax - write(6,'(4X,A12,2X,I8)') - &'MIN CYCLES',ICMSIterMin - write(6,*)('=',i=1,71) - IF(lRoots.gt.2) THEN - write(6,'(4X,A8,2X,2(A16,11X))') - &'Cycle','Q_a-a','Difference' - ELSE - write(6,'(4X,A8,2X,A18,6X,A8,12X,A12)') - &'Cycle','Rot. Angle (deg.)','Q_a-a','Q_a-a Diff.' - END IF - write(6,*)('-',i=1,71) ICMSIter=0 * write(6,'(6X,I4,8X,F16.8,8X,ES16.4E3)') * & ICMSIter,VeeSumOld,0.0d0 @@ -607,7 +583,9 @@ ELSE if(ICMSIter.ge.ICMSIterMax) then Converged=.true. + CMSNotConverged=.true. write(6,'(4X,A)')'NOT CONVERGED AFTER MAX NUMBER OF CYCLES' + write(6,'(4X,A)')'TEMPORARY ROTATION MATRIX SAVED' end if END IF * Converged=.true. @@ -623,7 +601,7 @@ RETURN END SUBROUTINE -*********************************************************************** +************************************************************************ SubRoutine OptOneAngle2(ang,change,R,GD,I1,I2,Vee,G) use stdalloc, only : mma_allocate, mma_deallocate @@ -710,7 +688,7 @@ RETURN End Subroutine -*********************************************************************** +************************************************************************ Subroutine SumVeeNew(SV,A,GD,I1,I2,G,V1,V2,Update) use stdalloc, only : mma_allocate, mma_deallocate #include "rasdim.fh" @@ -873,9 +851,9 @@ END IF RETURN End Subroutine -*********************************************************************** +************************************************************************ -*********************************************************************** +************************************************************************ Subroutine ThetaOpt2(R,theta,deltaQ,SPair,NP,GD,Vee,G) @@ -914,7 +892,7 @@ RETURN END SUBROUTINE -*********************************************************************** +************************************************************************ Function SumArray(A,N) INTEGER N,I Real*8,DIMENSION(N)::A @@ -927,7 +905,7 @@ End Function -*********************************************************************** +************************************************************************ Subroutine CalcVee2(Vee,GD,Gtuvx) #include "rasdim.fh" #include "rasscf.fh" @@ -958,7 +936,7 @@ RETURN END SUBROUTINE -*********************************************************************** +************************************************************************ Subroutine RotGDMat(R,GD) #include "rasdim.fh" #include "rasscf.fh" diff -Nru openmolcas-22.02/src/rasscf/cms_util.f openmolcas-22.10/src/rasscf/cms_util.f --- openmolcas-22.02/src/rasscf/cms_util.f 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rasscf/cms_util.f 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,250 @@ +************************************************************************ +* This file is part of OpenMolcas. * +* * +* OpenMolcas is free software; you can redistribute it and/or modify * +* it under the terms of the GNU Lesser General Public License, v. 2.1. * +* OpenMolcas is distributed in the hope that it will be useful, but it * +* is provided "as is" and without any express or implied warranties. * +* For more details see the full text of the license in the file * +* LICENSE or in <http://www.gnu.org/licenses/>. * +* * +* Copyright (C) 2022, Jie J. Bao * +************************************************************************ +****************************************************************** +* history: * +* Jie J. Bao, on Apr. 07, 2022, created this file. * +****************************************************************** + +* This file contains simple codes called in CMSNewton. Complicated ones +* are written in files with the name as the subroutine name. + + Subroutine PrintCMSIter(iStep,Qnew,Qold,RMat,lRoots) + use CMS, only: iCMSOpt,NPosHess,LargestQaaGrad,NCMSScale + INTEGER iStep,lRoots + Real*8 Qnew,Qold,Diff + Real*8 RMat(lRoots**2) + +* write(6,*) 'iteration information' + Diff=Qnew-Qold + IF(iCMSOpt.eq.2) THEN + + + If(lRoots.eq.2) Then + write(6,'(6X,I4,8X,F6.1,9X,F16.8,5X,ES16.4E3)') + & iStep,asin(RMat(3))/atan(1.0d0)*45.0d0,Qnew,Diff + Else + write(6,'(6X,I4,2X,F14.8,2X,ES14.4E3)') + & iStep, Qnew,Diff + End If + + + ELSE + + +C If(lRoots.eq.2) Then +C write(6,'(6X,I4,8X,F6.1,9X,F16.8,5X,ES16.4E3)') +C & iStep,asin(RMat(3))/atan(1.0d0)*45.0d0,Qnew,Diff +C Else + if (NCMSScale.gt.0) then + write(6,'(6X,I4,2X,F14.8,2X,ES12.2E3,2X,I5,2X,ES14.4E3,3X,A3,I1)') + & iStep, Qnew,Diff,nPosHess,LargestQaaGrad,'1E-',NCMSScale + else + write(6,'(6X,I4,2X,F14.8,2X,ES12.2E3,2X,I5,2X,ES14.4E3,3X,A3)') + & iStep, Qnew,Diff,nPosHess,LargestQaaGrad,'1.0' + end if +C End If + + + END IF + RETURN + End Subroutine +************************************************************************ + + Subroutine UnzipTUVX(TUVX,gtuvx,nTUVX) +#include "rasdim.fh" +#include "rasscf.fh" +#include "general.fh" +#include "WrkSpc.fh" +#include "SysDef.fh" +#include "input_ras.fh" +#include "warnings.h" + INTEGER nTUVX + Real*8 gtuvx(nTUVX),TUVX(NACPR2) + INTEGER it,iu,iv,ix,ituvx,ixmax, + & jtuvx,jtuxv,jutvx,jutxv, + & jvxtu,jvxut,jxvtu,jxvut, + & NAC3,NAC2 + +* CALL FZero(gtuvx,nTUVX) + + NAC2=NAC**2 + NAC3=NAC2*NAC + ituvx=0 + DO it=1,NAC + Do iu=1,it + dO iv=1,it + ixmax=iv + if (it==iv) ixmax=iu + do ix=1,ixmax + ituvx=ituvx+1 + jtuvx=(it-1)*NAC3+(iu-1)*NAC2+(iv-1)*NAC+ix + jtuxv=(it-1)*NAC3+(iu-1)*NAC2+(ix-1)*NAC+iv + jutvx=(iu-1)*NAC3+(it-1)*NAC2+(iv-1)*NAC+ix + jutxv=(iu-1)*NAC3+(it-1)*NAC2+(ix-1)*NAC+iv + jvxtu=(iv-1)*NAC3+(ix-1)*NAC2+(it-1)*NAC+iu + jvxut=(iv-1)*NAC3+(ix-1)*NAC2+(iu-1)*NAC+it + jxvtu=(ix-1)*NAC3+(iv-1)*NAC2+(it-1)*NAC+iu + jxvut=(ix-1)*NAC3+(iv-1)*NAC2+(iu-1)*NAC+it + Gtuvx(jtuvx)=TUVX(ituvx) + Gtuvx(jtuxv)=TUVX(ituvx) + Gtuvx(jutvx)=TUVX(ituvx) + Gtuvx(jutxv)=TUVX(ituvx) + Gtuvx(jvxtu)=TUVX(ituvx) + Gtuvx(jvxut)=TUVX(ituvx) + Gtuvx(jxvtu)=TUVX(ituvx) + Gtuvx(jxvut)=TUVX(ituvx) + end do + eND dO + End Do + END DO + RETURN + End Subroutine +************************************************************************ + + + Subroutine CMSTail() + write(6,*)('=',i=1,71) + RETURN + End Subroutine +************************************************************************ + + + + Subroutine CMSHeader(CMSSFile,LenCMSS) + use CMS, only: iCMSOpt, CMSGuessFile +#include "rasdim.fh" +#include "rasscf.fh" +#include "general.fh" +#include "WrkSpc.fh" +#include "SysDef.fh" +#include "input_ras.fh" +#include "warnings.h" + INTEGER LenCMSS + CHARACTER(len=LenCMSS)::CMSSFile + write(6,*) + write(6,*) + write(6,'(4X,A35)') + & 'CMS INTERMEDIATE-STATE OPTIMIZATION' + IF(CMSSFile.eq.'XMS') THEN + write(6,'(5X,A11,9X,A25)') + &'START MATRX','XMS INTERMEDIATE STATES' + ELSE + write(6,'(5X,A11,9X,A25)') + &'START MATRX',CMSGuessFile + END IF + IF(iCMSOpt.eq.1) THEN + write(6,'(5X,A8,12X,A25)') + & 'OPT ALGO','NEWTON' + ELSE IF(iCMSOpt.eq.2) THEN + write(6,'(5X,A8,12X,A25)') + & 'OPT ALGO','JACOBI' + END IF + write(6,'(5X,A15,5X,16X,ES9.2E2)') + &'Q_a-a THRESHOLD',CMSThreshold + IF(iCMSOpt.eq.1) THEN + write(6,'(5X,A15,5X,16X,ES9.2E2)') + & 'GRAD THRESHOLD',CMSThreshold*1.0d-2 + END IF + write(6,'(5X,A10,10X,I25)') + &'MAX CYCLES',ICMSIterMax + write(6,'(5X,A10,10X,I25)') + &'MIN CYCLES',ICMSIterMin + write(6,*)('=',i=1,71) + IF(iCMSOpt.eq.2) THEN + If(lRoots.gt.2) Then + write(6,'(4X,A8,2X,2(A16,11X))') + & 'Cycle','Q_a-a','Difference' + Else + write(6,'(4X,A8,2X,A18,6X,A8,12X,A12)') + & 'Cycle','Rot. Angle (deg.)','Q_a-a','Q_a-a Diff.' + End If + ELSE + write(6,'(6X,A5,7X,A5,8X,A10,2X,A6,5X,A7,4X,A4)') + & 'Cycle','Q_a-a','Difference','# Pos.','Largest','Step' + write(6,'(43X,A7,4X,A8,3X,A6)') + & 'Hessian','Gradient','Scaled' + END IF + write(6,*)('-',i=1,71) + + RETURN + End Subroutine +************************************************************************ + + + + Subroutine AntiOneDFoil(TwoD,OneD,m,n) + INTEGER M,N,I,J,iLoc + Real*8,DIMENSION(m,n)::TwoD + Real*8,DIMENSION(m*n)::OneD + iLoc=1 + DO J=1,N + Do I=1,M + TwoD(I,J)=OneD(iLoc) + iLoc=iLoc+1 + End Do + END DO + RETURN + End Subroutine + + Subroutine OneDFoil(OneD,TwoD,m,n) + INTEGER M,N,I,J,iLoc + Real*8,DIMENSION(m,n)::TwoD + Real*8,DIMENSION(m*n)::OneD + iLoc=1 + DO J=1,N + Do I=1,M + OneD(iLoc)=TwoD(I,J) + iLoc=iLoc+1 + End Do + END DO + RETURN + End Subroutine +************************************************************************ + + + + Subroutine InitRotMat(RotMat,lRoots,CMSSFile,LenCMSS) + INTEGER LenCMSS,lRoots + CHARACTER(Len=LenCMSS)::CMSSFile + Real*8,DIMENSION(lRoots,lRoots)::RotMat + CHARACTER(Len=16)::ScrChar + + IF(CMSSFile.eq.'XMS') THEN + CALL ReadMat('ROT_VEC',ScrChar,RotMat,lroots,lroots,7,16,'T') + ELSE + CALL ReadMat(CMSSFile ,ScrChar,RotMat,lroots,lroots,LenCMSS,16, + & 'T') + END IF + RETURN + End Subroutine +************************************************************************ + + Subroutine UpdateRotMat(RMat,ExpX,X,lRoots,nSPair) + INTEGER lRoots,nSPair + Real*8 X(nSPair) + Real*8 RMat(lRoots**2),RScr(lRoots**2) + Real*8 ExpX(lRoots**2) + + + CALL ExpMat(ExpX,X,lRoots,nSPair) + CALL DGEMM_('n','n',lRoots,lRoots,lRoots,1.0d0,RMat,lRoots, + & ExpX,lRoots, + & 0.0d0,RScr,lRoots) + CALL DCopy_(lRoots**2,RScr,1,RMat,1) + RETURN + End Subroutine + + + + + diff -Nru openmolcas-22.02/src/rasscf/davcre.f openmolcas-22.10/src/rasscf/davcre.f --- openmolcas-22.02/src/rasscf/davcre.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/davcre.f 2022-10-10 14:22:40.000000000 +0000 @@ -291,7 +291,7 @@ SC(K)=EI-HD(K) IF(ABS(SC(K)).LT.THRZ) SC(K)=1.0d0 END DO - CALL VDIV(SC,1,Q(IST+NDIM),1,Q(IST),1,NDIM) + Q(IST:IST+NDIM-1) = Q(IST+NDIM:IST+2*NDIM-1)/SC(1:NDIM) IST=IST+NDIM END DO C Remove any unwanted components. These are signalled by diff -Nru openmolcas-22.02/src/rasscf/dmrgctl.f openmolcas-22.10/src/rasscf/dmrgctl.f --- openmolcas-22.02/src/rasscf/dmrgctl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/dmrgctl.f 2022-10-10 14:22:40.000000000 +0000 @@ -35,7 +35,7 @@ *> @param[in] IFINAL Calculation status switch *> @param[in] IRst DMRG restart status switch ************************************************************************ -#if defined _ENABLE_BLOCK_DMRG_ || defined _ENABLE_CHEMPS2_DMRG_ +#if defined _ENABLE_BLOCK_DMRG_ || defined _ENABLE_CHEMPS2_DMRG_ || defined _ENABLE_DICE_SHCI_ Subroutine DMRGCtl(CMO,D,DS,P,PA,FI,D1I,D1A,TUVX,IFINAL,IRst) Implicit Real* 8 (A-H,O-Z) @@ -179,6 +179,9 @@ #elif _ENABLE_CHEMPS2_DMRG_ CALL chemps2_densi_rasscf(IPCMRoot,Work(LW6),Work(LW7), & Work(LW8),Work(LW9),Work(LW10)) +#elif _ENABLE_DICE_SHCI_ + CALL dice_densi_rasscf(IPCMRoot,Work(LW6),Work(LW7), + & Work(LW8),Work(LW9),Work(LW10)) #endif * NN.14 NOTE: IFCAS must be 0 for DMRG-CASSCF @@ -267,6 +270,8 @@ Call BlockCtl(Work(LW1),Work(ipTmpTUVX),IFINAL,IRst) #elif _ENABLE_CHEMPS2_DMRG_ Call Chemps2Ctl(Work(LW1),Work(ipTmpTUVX),IFINAL,IRst) +#elif _ENABLE_DICE_SHCI_ + Call DiceCtl(Work(LW1),Work(ipTmpTUVX),IFINAL,IRst) #endif Call GetMem('TmpTUVX','Free','Real',ipTmpTUVX,NACPR2) @@ -276,6 +281,8 @@ Call BlockCtl(Work(LW1),TUVX,IFINAL,IRst) #elif _ENABLE_CHEMPS2_DMRG_ Call Chemps2Ctl(Work(LW1),TUVX,IFINAL,IRst) +#elif _ENABLE_DICE_SHCI_ + Call DiceCtl(Work(LW1),TUVX,IFINAL,IRst) #endif End If endif @@ -319,6 +326,9 @@ #elif _ENABLE_CHEMPS2_DMRG_ CALL chemps2_densi_rasscf(jRoot,Work(LW6),Work(LW7), & Work(LW8),Work(LW9),Work(LW10)) +#elif _ENABLE_DICE_SHCI_ + CALL dice_densi_rasscf(jRoot,Work(LW6),Work(LW7), + & Work(LW8),Work(LW9),Work(LW10)) #endif CALL GETMEM('PTscr','FREE','REAL',LW10,NACT4) EndIf diff -Nru openmolcas-22.02/src/rasscf/expmat.f openmolcas-22.10/src/rasscf/expmat.f --- openmolcas-22.02/src/rasscf/expmat.f 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rasscf/expmat.f 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,115 @@ +************************************************************************ +* This file is part of OpenMolcas. * +* * +* OpenMolcas is free software; you can redistribute it and/or modify * +* it under the terms of the GNU Lesser General Public License, v. 2.1. * +* OpenMolcas is distributed in the hope that it will be useful, but it * +* is provided "as is" and without any express or implied warranties. * +* For more details see the full text of the license in the file * +* LICENSE or in <http://www.gnu.org/licenses/>. * +* * +* Copyright (C) 2022, Jie J. Bao * +************************************************************************ +* **************************************************************** +* history: * +* Jie J. Bao, on Feb. 03, 2022, created this file. * +* **************************************************************** +* Purpose: Return to the exponent of a skew-symmetric matrix + Subroutine ExpMat(M,A,DimM,LenA) +* Input + INTEGER DimM, LenA + Real*8 A(LenA) +* Output + Real*8 M(DimM**2) +* Explanation: +* Calculate M=exp(-A) +* A is stored as a 1 by LenA vector, and M is a DimM by DimM matrix +* This subroutine assumes LenA=(DimM-1)*DimM/2 +* How it works: +* First transform A into a skew-symmetric matrix form. Then call +* ExpMat_Inner to calculate exp(A) +* Auxiliary: + Real*8 MatA(DimM**2) + INTEGER I,J,N,iIJ1,iIJ2 + + N=DimM**2 + CALL FZero(MatA,N) + DO I=2,DimM + Do J=1,I-1 + iIJ2=(I-2)*(I-1)/2+J + iIJ1=(I-1)*DimM+J + MatA(iIJ1)=A(iIJ2) + iIJ1=(J-1)*DimM+I + MatA(iIJ1)=-A(iIJ2) + End Do + END DO + + CALL ExpMat_Inner(M,MatA,DimM) + RETURN + End SUbroutine + + Subroutine ExpMat_Inner(R,X,nLen) +******Purpose: calculate R=exp(X) +******Explanation: +* The subroutine uses the algorithm in Section 3.1.5 on Page 83 of +* 'Molecular Electronic-Structure Theory' by T. Helgaker, P. +* J/orgensen and J. Olsen. +* Jie Bao acknowledges Dr. Chen Zhou from Xiamen University, China, for +* showing the resource of this algorithm and his code for reference. + use stdalloc, only : mma_allocate, mma_deallocate +* Input + INTEGER nLen,nLen2 + Real*8 x(nLen**2) +* Output + Real*8 R(nLen**2) +* Auxilliary + Real*8 tau2(nLen),cospart(nLen**2),sinpart(nLen**2), + & scr(nLen**2),X2(nLen**2),tau(nLen) + INTEGER nScrDiag,INFO,I + Real*8,DIMENSION(:),Allocatable::ScrDiag + Real*8 Coeff + + nLen2=nLen**2 + +*Step 1 calculate X2 + CALL DGEMM_('n','n',nLen,nLen,nLen,1.0d0,X,nLen,X,nLen, + & 0.0d0,X2,nLen) + +*Step 2 diagonalize X2 + CALL GetDiagScr(nScrDiag,X2,Scr,nLen) + CALL mma_allocate(ScrDiag,nScrDiag) + CALL DSYEV_('V','U',nLen,X2,nLen,tau2,ScrDiag,nScrDiag,INFO) + CALL mma_deallocate(ScrDiag) + + DO I=1,nLen + tau(I)=dsqrt(dabs(tau2(I))) + END DO + +*Step 3 build cos part of R matrix + CALL DCopy_(nLen2,X2,1,CosPart,1) + DO I=1,nLen + CALL DScal_(nLen,cos(tau(I)),CosPart((I-1)*nLen+1),1) + END DO + + CALL DGEMM_('n','t',nLen,nLen,nLen,1.0d0,CosPart,nLen,X2,nLen, + & 0.0d0,Scr,nLen) +* R=W * cos(tau) * W^T + CALL DCopy_(nLen2,Scr,1,R,1) +*Step 4 build sin part of R matrix + CALL DCopy_(nLen2,X2,1,SinPart,1) + DO I=1,nLen + IF(tau(I).lt.1.0d-8) THEN + Coeff=1.0d0 + ELSE + Coeff=sin(tau(I))/tau(I) + END IF + CALL DScal_(nLen,Coeff,SinPart((I-1)*nLen+1),1) + END DO + + CALL DGEMM_('n','t',nLen,nLen,nLen,1.0d0,SinPart,nLen,X2,nLen, + & 0.0d0,Scr,nLen) +* R=R+W * tau^(-1) * sin(tau) * W^T * X + CALL DGEMM_('n','n',nLen,nLen,nLen,1.0d0,Scr,nLen,X,nLen, + & 1.0d0,R,nLen) + RETURN + End Subroutine diff -Nru openmolcas-22.02/src/rasscf/fcidump_dump.f90 openmolcas-22.10/src/rasscf/fcidump_dump.f90 --- openmolcas-22.02/src/rasscf/fcidump_dump.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/fcidump_dump.f90 2022-10-10 14:22:40.000000000 +0000 @@ -30,10 +30,12 @@ !> Contains information about \p nAsh, \p nActEl, !> \p iSpin, and \p stSym. !> +!> @param[in] path !> @param[in] EMY Core energy !> @param[in] orbital_table Orbital energies with index !> @param[in] fock_table !> @param[in] two_el_table +!> @param[in] orbsym subroutine dump_ascii(path, EMY, orbital_table, fock_table, & two_el_table, orbsym) use general_data, only : nActEl, iSpin, stSym, nAsh @@ -100,10 +102,12 @@ !> Contains information about \p nAsh, \p nSym, \p nActEl, !> \p iSpin, and \p stSym. !> +!> @param[in] path !> @param[in] EMY Core energy !> @param[in] orbital_table Orbital energies with index !> @param[in] fock_table !> @param[in] two_el_table +!> @param[in] orbsym subroutine dump_hdf5(path, EMY, orbital_table, fock_table, two_el_table, orbsym) use general_data, only : nSym, nActEl, multiplicity => iSpin, stSym, nAsh use gas_data, only : iDoGAS diff -Nru openmolcas-22.02/src/rasscf/fcidump_tables.f90 openmolcas-22.10/src/rasscf/fcidump_tables.f90 --- openmolcas-22.02/src/rasscf/fcidump_tables.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/fcidump_tables.f90 2022-10-10 14:22:40.000000000 +0000 @@ -87,13 +87,10 @@ !> @author Oskar Weser !> !> @details -!> The orbitals table gets filled with the orbital energies from DIAF. -!> If it is the first iteration (iter == 1) then the one electron -!> energies are read from the InpOrb. +!> The orbitals table gets filled with the orbital energies from orbital_energies. !> -!> @param[in,out] orbitals Core -!> @param[in] DIAF -!> @param[in] iter +!> @param[in,out] table +!> @param[in] orbital_energies subroutine fill_orbitals(table, orbital_energies) use general_data, only : nBas, nSym, nAsh, nFro, nIsh implicit none @@ -156,10 +153,8 @@ !> The index is given by i and j. !> !> @param[in,out] fock_table -!> @param[in] CMO The occupation number vector in MO-space. -!> @param[in] F_In +!> @param[in] Fock !> \f[\sum_{\sigma\rho} {In}^D_{\sigma\rho} (g_{\mu\nu\sigma\rho}) \f] -!> @param[in] D1I_MO The inactive one-body density matrix in MO-space !> @param[in] cutoff Optional parameter that is set by default to !> fciqmc_tables::cutoff_default. subroutine fill_fock(fock_table, Fock, cutoff) diff -Nru openmolcas-22.02/src/rasscf/fcidump_transformations.f90 openmolcas-22.10/src/rasscf/fcidump_transformations.f90 --- openmolcas-22.02/src/rasscf/fcidump_transformations.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/fcidump_transformations.f90 2022-10-10 14:22:40.000000000 +0000 @@ -30,7 +30,7 @@ !> energies are read from the InpOrb. !> Otherwise orbital_energies is a copy of DIAF. !> -!> @param[in] iter +!> @param[in] actual_iter !> @param[in] DIAF !> @param[out] orbital_energies subroutine get_orbital_E(actual_iter, DIAF, orbital_energies) @@ -74,7 +74,7 @@ !> @details !> Generate the Fock-matrix for the frozen and inactive orbitals. !> in the basis of the active MOs as obtained from ::SGFCIN. -!> Has the sideeffect of setting ::EMY to the core energy. +!> Has the sideeffect of setting \p EMY to the core energy. !> !> @param[in] CMO The MO coefficients. !> @param[in] D1I_AO The inactive one-body density matrix in AO-space @@ -85,7 +85,7 @@ !> See ::get_D1A_rasscf. !> @param[in] D1S_MO The active spin density matrix in MO-space !> \f[ D^A_\alpha - D^A_\beta \f] -!> @param[inout] FI The inactive Fock matrix in AO-space +!> @param[in,out] F_In The inactive Fock matrix in AO-space !> \f[\sum_{\sigma\rho} D^I_{\sigma\rho}(g_{\mu\nu\sigma\rho} - \frac{1}{2} g_{\mu\sigma\rho\nu})\f] !> In output FI contains also the core energy added to !> the diagonal elements. diff -Nru openmolcas-22.02/src/rasscf/fciqmc.f openmolcas-22.10/src/rasscf/fciqmc.f --- openmolcas-22.02/src/rasscf/fciqmc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/fciqmc.f 2022-10-10 14:22:40.000000000 +0000 @@ -11,6 +11,7 @@ * Copyright (C) 2014, Giovanni Li Manni * * 2019-2021, Oskar Weser * * 2021, Werner Dobrautz * +* 2021,2022, Arta Safari * ************************************************************************ #include "macros.fh" module fciqmc @@ -31,12 +32,15 @@ use linalg_mod, only: abort_ use stdalloc, only: mma_allocate, mma_deallocate - use rasscf_data, only: nAcPar, nAcPr2 + use rasscf_data, only: nAcPar, nAcPr2, nroots use general_data, only: nSym, nConf - use CI_solver_util, only: wait_and_read, RDM_to_runfile + use CI_solver_util, only: wait_and_read use generic_CI, only: CI_solver_t + use fciqmc_read_RDM, only: read_neci_RDM, tHDF5_RDMs, + & MCM7 + use definitions, only: u6 implicit none save @@ -49,15 +53,16 @@ #ifdef _NECI_ interface subroutine NECImain(fcidmp, input_name, MemSize, NECIen) - use, intrinsic :: iso_fortran_env, only: int64, real64 + use, intrinsic :: iso_fortran_env, only: int64 + import :: wp, nroots + implicit none character(len=*), intent(in) :: fcidmp, input_name integer(int64), intent(in) :: MemSize - real(real64), intent (out) :: NECIen + real(wp), intent (out) :: NECIen(nroots) end subroutine end interface #endif - type, extends(CI_solver_t) :: fciqmc_solver_t private logical :: tGUGA @@ -77,9 +82,12 @@ logical, intent(in) :: tGUGA type(fciqmc_solver_t) :: res res%tGUGA = tGUGA - write(6,*) ' NECI activated. List of Confs might get lengthy.' - write(6,*) ' Number of Configurations computed by GUGA: ', nConf - write(6,*) ' nConf variable is set to zero to avoid JOBIPH i/o' + write(u6,*) + & ' NECI activated. List of Confs might get lengthy.' + write(u6,*) + & ' Number of Configurations computed by GUGA: ', nConf + write(u6,*) + & ' nConf variable is set to zero to avoid JOBIPH i/o' nConf= 0 end function @@ -89,8 +97,6 @@ !> @author Giovanni Li Manni, Oskar Weser !> !> @details -!> For meaning of global variables NTOT1, NTOT2, NACPAR -!> and NACPR2, see src/Include/general.inc and src/Include/rasscf.inc. !> This routine will replace CICTL in FCIQMC regime. !> Density matrices are generated via double-run procedure in NECI. !> They are then dumped on arrays DMAT, DSPN, PSMAT, PAMAT to replace @@ -99,121 +105,126 @@ !> only two-electron terms as computed in TRA_CTL2. !> In output it contains also the one-electron contribution !> -!> @paramin[in] actual_iter The actual iteration number starting at 0. +!> @param[in] this +!> @param[in] actual_iter The actual iteration number starting at 0. !> This means 0 is 1A, 1 is 1B, 2 is 2 and so on. -!> @paramin[in] CMO MO coefficients -!> @paramin[in] DIAF Diagonal of Fock matrix useful for NECI -!> @paramin[in] D1I_MO Inactive 1-dens matrix -!> @paramin[in] TUVX Active 2-el integrals -!> @paramin[inout] F_In Fock matrix from inactive density -!> @paramin[inout] D1S_MO Average spin 1-dens matrix -!> @paramin[out] DMAT Average 1 body density matrix -!> @paramin[out] PSMAT Average symm. 2-dens matrix -!> @paramin[out] PAMAT Average antisymm. 2-dens matrix -!> @paramin[in] fake_run If true the NECI run is not performed, but -!> the RDMs are read from previous runs. +!> @param[in] ifinal +!> @param[in] iroot +!> @param[in] weight +!> @param[in] CMO MO coefficients +!> @param[in] DIAF Diagonal of Fock matrix useful for NECI +!> @param[in] D1I_AO Inactive 1-dens matrix +!> @param[in] D1A_AO +!> @param[in] TUVX Active 2-el integrals +!> @param[in,out] F_In Fock matrix from inactive density +!> @param[in,out] D1S_MO Average spin 1-dens matrix +!> @param[out] DMAT Average 1 body density matrix +!> @param[out] PSMAT Average symm. 2-dens matrix +!> @param[out] PAMAT Average antisymm. 2-dens matrix subroutine fciqmc_ctl( - & this, actual_iter, CMO, DIAF, D1I_AO, D1A_AO, - & TUVX, F_IN, D1S_MO, DMAT, PSMAT, PAMAT) - use general_data, only : iSpin, ntot, ntot1, ntot2, nAsh - use rasscf_data, only : iter, lRoots, S, KSDFT, EMY, - & rotmax, Ener, Nac, nAcPar, nAcpr2 - - use gas_data, only : ngssh, iDoGas, nGAS, iGSOCCX - - use fcidump_reorder, only : get_P_GAS, get_P_inp,ReOrFlag,ReOrInp - use fcidump, only : make_fcidumps, transform + & this, actual_iter, ifinal, iroot, weight, CMO, DIAF, D1I_AO, + & D1A_AO, TUVX, F_IN, D1S_MO, DMAT, PSMAT, PAMAT + & ) + + use general_data, only : iSpin, ntot, ntot1, ntot2, nAsh + use rasscf_data, only : iter, nroots, lRoots, + & S, KSDFT, EMY, rotmax, Ener, Nac, + & nAcPar, nAcpr2 + use gas_data, only : ngssh, iDoGas, nGAS, iGSOCCX + use fcidump_reorder, only : get_P_GAS, get_P_inp,ReOrFlag, + & ReOrInp + use fcidump, only : make_fcidumps, transform #include "rctfld.fh" - class(fciqmc_solver_t), intent(in) :: this - integer, intent(in) :: actual_iter - real(wp), intent(in) :: - & CMO(nTot2), DIAF(nTot), - & D1I_AO(nTot2), D1A_AO(nTot2), TUVX(nAcpr2) - real(wp), intent(inout) :: F_In(nTot1), D1S_MO(nAcPar) - real(wp), intent(out) :: DMAT(nAcpar), - & PSMAT(nAcpr2), PAMAT(nAcpr2) - - real(wp) :: NECIen - integer, allocatable :: permutation(:), - & GAS_spaces(:, :), GAS_particles(:, :) - real(wp) :: orbital_E(nTot), folded_Fock(nAcPar) + + class(fciqmc_solver_t), intent(in) :: this + integer, intent(in) :: actual_iter, iroot(nroots), ifinal + real(wp), intent(in) :: weight(nroots), CMO(nTot2), + & DIAF(nTot), D1I_AO(nTot2), + & D1A_AO(nTot2), TUVX(nAcpr2) + real(wp), intent(inout) :: F_In(nTot1), D1S_MO(nAcPar) + real(wp), intent(out) :: DMAT(nAcpar), PSMAT(nAcpr2), + & PAMAT(nAcpr2) + integer, allocatable :: permutation(:), GAS_spaces(:, :), + & GAS_particles(:, :) + real(wp) :: NECIen(nroots), orbital_E(nTot), + & folded_Fock(nAcPar) #ifdef _MOLCAS_MPP_ - integer(MPIInt) :: error + integer(MPIInt) :: error #endif - character(len=*), parameter :: - & ascii_fcidmp = 'FCIDUMP', h5_fcidmp = 'H5FCIDUMP' - + character(len=*), parameter :: + & ascii_fcidmp = 'FCIDUMP', h5_fcidmp = 'H5FCIDUMP' -! SOME DIRTY SETUPS - S = 0.5_wp * dble(iSpin - 1) - - call check_options(lRoots, lRf, KSDFT) - -! Produce a working FCIDUMP file - if (ReOrFlag /= 0) then - allocate(permutation(sum(nAsh(:nSym)))) - if (ReOrFlag >= 2) permutation(:) = get_P_inp(ReOrInp) - if (ReOrFlag == -1) permutation(:) = get_P_GAS(nGSSH) - end if - -! This call is not side effect free, sets EMY and modifies F_IN - call transform(actual_iter, CMO, DIAF, D1I_AO, D1A_AO, D1S_MO, - & F_IN, orbital_E, folded_Fock) - -! Fortran Standard 2008 12.5.2.12: -! Allocatable actual arguments that are passed to -! non-allocatable, optional dummy arguments are **not** present. - call make_fcidumps(ascii_fcidmp, h5_fcidmp, - & orbital_E, folded_Fock, TUVX, EMY, permutation) +! ! SOME DIRTY SETUPS + S = 0.5_wp * dble(iSpin - 1) + call check_options(lRf, KSDFT) + ! Produce a working FCIDUMP file + if (ReOrFlag /= 0) then + allocate(permutation(sum(nAsh(:nSym)))) + if (ReOrFlag >= 2) permutation(:) = get_P_inp(ReOrInp) + if (ReOrFlag == -1) permutation(:) = get_P_GAS(nGSSH) + end if + +! ! This call is not side effect free, sets EMY and modifies +! ! F_IN + call transform(actual_iter, CMO, DIAF, D1I_AO, D1A_AO, D1S_MO, + & F_IN, orbital_E, folded_Fock) + +! ! Fortran Standard 2008 12.5.2.12: +! ! Allocatable actual arguments that are passed to +! ! non-allocatable, optional dummy arguments are **not** +! ! present. + call make_fcidumps( + & ascii_fcidmp, h5_fcidmp, orbital_E, folded_Fock, TUVX, + & EMY, permutation + & ) ! Run NECI #ifdef _MOLCAS_MPP_ - if (is_real_par()) call MPI_Barrier(MPI_COMM_WORLD, error) + if (is_real_par()) call MPI_Barrier(MPI_COMM_WORLD, error) #endif - if (iDoGAS) then - call mma_allocate(GAS_spaces, nGAS, nSym) - GAS_spaces(:, :) = nGSSH(: nGAS, : nSym) - call mma_allocate(GAS_particles, nGAS, nGAS) - GAS_particles(:, :) = iGSOCCX(: nGAS, : nGAS) - end if - - call run_neci(DoEmbdNECI, actual_iter == 1, - & ascii_fcidmp, h5_fcidmp, - & GAS_spaces=GAS_spaces, GAS_particles=GAS_particles, - & reuse_pops=actual_iter >= 5 .and. abs(rotmax) < 1d-2, - & NECIen=NECIen, - & D1S_MO=D1S_MO, DMAT=DMAT, PSMAT=PSMAT, PAMAT=PAMAT, - & tGUGA=this%tGUGA) -! NECIen so far is only the energy for the GS. -! Next step it will be an array containing energies for all the optimized states. - ENER(1 : lRoots, iter) = NECIen - - if (nAsh(1) /= nac) call dblock(dmat) - - - if (allocated(GAS_spaces)) then - call mma_deallocate(GAS_spaces) - call mma_deallocate(GAS_particles) - end if + if (iDoGAS) then + call mma_allocate(GAS_spaces, nGAS, nSym) + GAS_spaces(:, :) = nGSSH(: nGAS, : nSym) + call mma_allocate(GAS_particles, nGAS, nGAS) + GAS_particles(:, :) = iGSOCCX(: nGAS, : nGAS) + end if + + call run_neci(DoEmbdNECI, + & fake_run=actual_iter == 1 .or. ifinal == 2, + & ascii_fcidmp=ascii_fcidmp, h5_fcidmp=h5_fcidmp, + & GAS_spaces=GAS_spaces, GAS_particles=GAS_particles, + & reuse_pops=actual_iter >= 5 .and. abs(rotmax) < 1d-2, + & NECIen=NECIen, iroot=iroot, weight=weight, + & D1S_MO=D1S_MO, DMAT=DMAT, PSMAT=PSMAT, PAMAT=PAMAT, + & tGUGA=this%tGUGA, ifinal=ifinal) + ENER(1 : lRoots, iter) = NECIen + + if (nAsh(1) /= nac) call dblock(dmat) + if (allocated(GAS_spaces)) then + call mma_deallocate(GAS_spaces) + call mma_deallocate(GAS_particles) + end if end subroutine fciqmc_ctl subroutine run_neci(DoEmbdNECI, fake_run, & ascii_fcidmp, h5_fcidmp, & reuse_pops, - & NECIen, D1S_MO, DMAT, PSMAT, PAMAT, tGUGA, - & GAS_spaces, GAS_particles) + & NECIen, iroot, weight, + & D1S_MO, DMAT, PSMAT, PAMAT, + & GAS_spaces, GAS_particles, tGUGA, ifinal) use fciqmc_make_inp, only: make_inp logical, intent(in) :: DoEmbdNECI, fake_run, reuse_pops character(len=*), intent(in) :: ascii_fcidmp, h5_fcidmp - real(wp), intent(out) :: NECIen, D1S_MO(nAcPar), DMAT(nAcpar), - & PSMAT(nAcpr2), PAMAT(nAcpr2) + real(wp), intent(out) :: NECIen(nroots), + & D1S_MO(nAcPar), DMAT(nAcpar), PSMAT(nAcpr2), PAMAT(nAcpr2) logical, intent(in) :: tGUGA + integer, intent(in) :: iroot(nroots), ifinal + real(wp), intent(in) :: weight(nroots) integer, intent(in), optional :: & GAS_spaces(:, :), GAS_particles(:, :) - real(wp), save :: previous_NECIen = 0.0_wp - + real(wp), allocatable, save :: previous_NECIen(:) character(len=*), parameter :: input_name = 'FCINP', & energy_file = 'NEWCYCLE' @@ -222,14 +233,17 @@ ! (unitialized codepaths lead to abortion). NECIen = huge(NECIen) #endif - + if (.not. allocated(previous_NECIen)) then + allocate(previous_NECIen(nroots)) + previous_NECIen(:) = 0.0_wp + end if if (fake_run) then - NECIen = previous_NECIen + NECIen(:) = previous_NECIen(:) else if (DoEmbdNECI) then call make_inp(input_name, readpops=reuse_pops, tGUGA=tGUGA, & GAS_spaces=GAS_spaces, GAS_particles=GAS_particles) #ifdef _NECI_ - write(6,*) 'NECI called automatically within Molcas!' + write(u6,*) 'NECI called automatically within Molcas!' if (myrank /= 0) call chdir_('..') call necimain(real_path(ascii_fcidmp), & real_path(input_name), @@ -249,16 +263,17 @@ call write_ExNECI_message(input_name, ascii_fcidmp, & h5_fcidmp, energy_file, tGUGA) end if + call wait_and_read(energy_file, NECIen) end if - previous_NECIen = NECIen - call get_neci_RDM(D1S_MO, DMAT, PSMAT, PAMAT, tGUGA) - call RDM_to_runfile(DMAT, D1S_MO, PSMAT, PAMAT) + previous_NECIen(:) = NECIen(:) + call read_neci_RDM(iroot, weight, tGUGA, ifinal, + & DMAT, D1S_MO, PSMAT, PAMAT) end subroutine run_neci subroutine cleanup(this) - use fciqmc_make_inp, only : make_inp_cleanup => cleanup - use fciqmc_read_RDM, only : read_RDM_cleanup => cleanup + use fciqmc_make_inp, only: make_inp_cleanup => cleanup + use fciqmc_read_RDM, only: read_RDM_cleanup => cleanup use fcidump, only : fcidump_cleanup => cleanup class(fciqmc_solver_t), intent(inout) :: this unused_var(this) @@ -267,14 +282,10 @@ call fcidump_cleanup() end subroutine cleanup - subroutine check_options(lroots, lRf, KSDFT) - integer, intent(in) :: lroots + subroutine check_options(lRf, KSDFT) logical, intent(in) :: lRf character(len=*), intent(in) :: KSDFT logical :: Do_ESPF - if (lroots > 1) then - call abort_('FCIQMC does not support State Average yet!') - end if call DecideOnESPF(Do_ESPF) if ( lRf .or. KSDFT /= 'SCF' .or. Do_ESPF) then call abort_('FCIQMC does not support Reaction Field yet!') @@ -290,52 +301,43 @@ integer :: err call getcwd_(WorkDir, err) - if (err /= 0) write(6, *) strerror_(get_errno_()) + if (err /= 0) write(u6, *) strerror_(get_errno_()) if (tGUGA) then - write(6,'(A)')'Run spin-free GUGA NECI externally.' + write(u6,'(A)')'Run spin-free GUGA NECI externally.' else - write(6,'(A)')'Run NECI externally.' + write(u6,'(A)')'Run NECI externally.' end if - write(6,'(A)')'Get the (example) NECI input:' - write(6,'(4x, A, 1x, A, 1x, A)') + write(u6,'(A)')'Get the (example) NECI input:' + write(u6,'(4x, A, 1x, A, 1x, A)') & 'cp', real_path(input_name), '$NECI_RUN_DIR' - write(6,'(A)')'Get the ASCII formatted FCIDUMP:' - write(6,'(4x, A, 1x, A, 1x, A)') + write(u6,'(A)')'Get the ASCII formatted FCIDUMP:' + write(u6,'(4x, A, 1x, A, 1x, A)') & 'cp', real_path(ascii_fcidmp), '$NECI_RUN_DIR' - write(6,'(A)')'Or the HDF5 FCIDUMP:' - write(6,'(4x, A, 1x, A, 1x, A)') + write(u6,'(A)')'Or the HDF5 FCIDUMP:' + write(u6,'(4x, A, 1x, A, 1x, A)') & 'cp', real_path(h5_fcidmp), '$NECI_RUN_DIR' - write(6, *) - write(6,'(A)') "When finished do:" + write(u6, *) + write(u6,'(A)') "When finished do:" if (tGUGA) then - write(6,'(4x, A)') 'cp PSMAT PAMAT DMAT '//trim(WorkDir) + write(u6,'(4x, A)') 'cp PSMAT.* PAMAT.* DMAT.* '// + & trim(WorkDir) + else if (tHDF5_RDMs) then + if (MCM7) then + write(u6,'(4x, a)') + & 'copy your M7.h5 file into '//trim(WorkDir) + else + write(u6,'(4x, a)') + & 'copy your fciqmc.rdms.{iroot}.h5 file into '//trim(WorkDir) + end if else - write(6,'(4x, A)') - & 'cp TwoRDM_aaaa.1 TwoRDM_abab.1 TwoRDM_abba.1 '// - & 'TwoRDM_bbbb.1 TwoRDM_baba.1 TwoRDM_baab.1 '//trim(WorkDir) + write(u6,'(4x, A)') + & 'cp TwoRDM_* '//trim(WorkDir) end if - write(6,'(4x, A)') + write(u6,'(4x, A)') & 'echo $your_RDM_Energy > '//real_path(energy_file) call xflush(6) end subroutine write_ExNECI_message -!> Generate density matrices for Molcas -!> Neci density matrices are stored in Files TwoRDM_**** (in spacial orbital basis). -!> I will be reading them from those formatted files for the time being. -!> Next it will be nice if NECI prints them out already in Molcas format. - subroutine get_neci_RDM(D1S_MO, DMAT, PSMAT, PAMAT, tGUGA) - use fciqmc_read_RDM, only : read_neci_RDM, read_neci_GUGA_RDM - real*8, intent(out) :: - & D1S_MO(nAcPar), DMAT(nAcpar), - & PSMAT(nAcpr2), PAMAT(nAcpr2) - logical, intent(in) :: tGUGA - if (tGUGA) then - ! for GUGA we only need the spin-free 1 and 2-RDM. - ! The spin density D1S_MO is set to zero. - call read_neci_GUGA_RDM(DMAT, D1S_MO, PSMAT, PAMAT) - else - call read_neci_RDM(DMAT, D1S_MO, PSMAT, PAMAT) - end if - end subroutine get_neci_RDM end module fciqmc + diff -Nru openmolcas-22.02/src/rasscf/fciqmc_make_inp.f openmolcas-22.10/src/rasscf/fciqmc_make_inp.f --- openmolcas-22.02/src/rasscf/fciqmc_make_inp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/fciqmc_make_inp.f 2022-10-10 14:22:40.000000000 +0000 @@ -64,7 +64,12 @@ !> @author !> G. Li Manni, Oskar Weser !> -!> @paramin[in] readpops If true the readpops option for NECI is set. +!> @param[in] path +!> @param[in] readpops If true the readpops option for NECI is set. +!> @param[in] tGUGA +!> @param[in] FCIDUMP_name +!> @param[in] GAS_spaces +!> @param[in] GAS_particles subroutine make_inp(path, readpops, tGUGA, FCIDUMP_name, & GAS_spaces, GAS_particles) use general_data, only : nActEl, iSpin diff -Nru openmolcas-22.02/src/rasscf/fciqmc_read_RDM.f openmolcas-22.10/src/rasscf/fciqmc_read_RDM.f --- openmolcas-22.02/src/rasscf/fciqmc_read_RDM.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/fciqmc_read_RDM.f 2022-10-10 14:22:40.000000000 +0000 @@ -11,21 +11,37 @@ * Copyright (C) 2016,2017, Giovanni Li Manni * * 2019-2021, Oskar Weser * * 2021, Werner Dobrautz * +* 2021,2022, Arta Safari * ************************************************************************ module fciqmc_read_RDM - use definitions, only: wp +#ifdef _HDF5_ + use mh5, only: mh5_open_file_r, mh5_close_file, mh5_put_dset, + & mh5_open_group, mh5_close_group, + & mh5_open_dset, mh5_close_dset, mh5_fetch_dset, + & mh5_get_dset_dims +#endif + use fortran_strings, only: str + use definitions, only: wp, u6 + use stdalloc, only: mma_allocate, mma_deallocate use para_info, only: myRank + use rasscf_data, only : NRoots, iAdr15, NAc use general_data, only : nActEl -! Note that two_el_idx_flatten has also out parameters. - use index_symmetry, only : two_el_idx_flatten - use CI_solver_util, only: CleanMat + use index_symmetry, only : one_el_idx, two_el_idx_flatten, + & one_el_idx_flatten, two_el_idx + use CI_solver_util, only: CleanMat, RDM_to_runfile use linalg_mod, only: abort_, verify_ implicit none +! TODO: Have to figure out how to encapsulate into rasscf_data +#include "raswfn.fh" +#include "intent.fh" + private - public :: read_neci_RDM, cleanup, read_neci_GUGA_RDM + public :: read_neci_RDM, cleanup, tHDF5_RDMs, MCM7 + logical, save :: tHDF5_RDMs = .false., MCM7 = .false. + contains !> @brief @@ -39,57 +55,171 @@ !> The spin density is set to zero, because spin projection !> is not properly defined in the GUGA framework. -!> @paramin[out] DMAT Average spin-free 1 body density matrix -!> @paramin[out] DSPN spin-dependent 1-RDM (set to zero) -!> @paramin[out] PSMAT Average spin-free 2 body density matrix -!> @paramin[out] PAMAT 'fake' Average antisymm. 2-dens matrix - subroutine read_neci_GUGA_RDM(DMAT, DSPN, PSMAT, PAMAT) - real(wp), intent(out) :: DMAT(:), DSPN(:), PSMAT(:), PAMAT(:) - integer :: file_id, isfreeunit, i - logical :: tExist - real(wp) :: RDMval - - if (myRank /= 0) then - call bcast_2RDM("PSMAT") - call bcast_2RDM("PAMAT") - call bcast_2RDM("DMAT") - end if - - call f_Inquire('PSMAT',tExist) - call verify_(tExist, 'PSMAT does not exist') - call f_Inquire('PAMAT',tExist) - call verify_(tExist, 'PAMAT does not exist') - call f_Inquire('DMAT',tExist) - call verify_(tExist, 'DMAT does not exist') - - PSMAT(:) = 0.0_wp; PAMAT(:) = 0.0_wp; - DMAT(:) = 0.0_wp; DSPN(:) = 0.0_wp; - - file_id = IsFreeUnit(11) - call Molcas_Open(file_id, 'PSMAT') - do while (read_line(file_id, i, RDMval)) - psmat(i) = RDMval +!> @param[in] iroot +!> @param[in] weight +!> @param[in] tGUGA +!> @param[in] ifinal +!> @param[out] DMAT Average spin-free 1 body density matrix +!> @param[out] DSPN spin-dependent 1-RDM (set to zero) +!> @param[out] PSMAT Average spin-free 2 body density matrix +!> @param[out] PAMAT 'fake' Average antisymm. 2-dens matrix + + + subroutine read_neci_RDM( + & iroot, weight, tGUGA, ifinal, DMAT, DSPN, PSMAT, PAMAT) + + ! wrapper around `read_single_neci_(GUGA)_RDM` to average + ! normal and GUGA density matrices for stochastic SA-MCSCF. + + integer(wp), intent(in) :: iroot(:), ifinal + real(wp), intent(in) :: weight(:) + logical, intent(in) :: tGUGA + real(wp), intent(out) :: DMAT(:), DSPN(:), PSMAT(:), PAMAT(:) + integer :: i, j, jDisk + real(wp), allocatable :: temp_DMAT(:), temp_DSPN(:), + & temp_PSMAT(:), temp_PAMAT(:) +#ifdef _HDF5_ + real(wp) :: decompressed_DMAT(nAc,nAc), + & decompressed_DSPN(nAc,nAc) +#endif + + ! position in memory to write density matrices to JOBIPH + jDisk = iAdr15(3) + + ! prevent stackoverflow + call mma_allocate(temp_DMAT, size(DMAT)) + call mma_allocate(temp_DSPN, size(DSPN)) + call mma_allocate(temp_PSMAT, size(PSMAT)) + call mma_allocate(temp_PAMAT, size(PAMAT)) + + DMAT(:) = 0.0_wp; DSPN(:) = 0.0_wp + PSMAT(:) = 0.0_wp; PAMAT(:) = 0.0_wp + + do i = 1, NRoots + do j = 1, size(iroot) + if (iroot(j) == i) then + if (tGUGA) then + call read_single_neci_GUGA_RDM( + & iroot(j), temp_DMAT, temp_DSPN, + & temp_PSMAT, temp_PAMAT + & ) +#ifdef _HDF5_ + else if (tHDF5_RDMs) then + call read_hdf5_denmats(iroot(j), temp_DMAT, + & temp_DSPN, temp_PSMAT, temp_PAMAT) +#endif + else + call read_single_neci_RDM( + & iroot(j), temp_DMAT, temp_DSPN, + & temp_PSMAT, temp_PAMAT + & ) + end if + + DMAT = DMAT + weight(j) * temp_DMAT + DSPN = DSPN + weight(j) * temp_DSPN + PSMAT = PSMAT + weight(j) * temp_PSMAT + PAMAT = PAMAT + weight(j) * temp_PAMAT + + ! state-specific Natural Occupation numbers + if (ifinal > 0) then + call RDM_to_runfile( + & temp_DMAT, temp_DSPN, temp_PSMAT, + & temp_PAMAT, jDisk + & ) +#ifdef _WARNING_WORKAROUND_ +! build:garble does not recognise decompressed_dmat/dspn +#ifdef _HDF5_ + ! final iteration load decompressed 1PDMs in + ! HDF5 file. + call expand_1rdm(temp_DMAT, decompressed_DMAT) + call mh5_put_dset(wfn_dens, + & decompressed_DMAT, + & [nac, nac, 1], + & [0, 0, iroot(j) - 1]) + call expand_1rdm(temp_DSPN, decompressed_DSPN) + call mh5_put_dset(wfn_spindens, + & decompressed_DSPN, + & [nac, nac, 1], + & [0, 0, iroot(j) - 1]) +#endif +#endif + + end if + end if + end do end do - close(file_id) - file_id = IsFreeUnit(11) - call Molcas_Open(file_id, 'PAMAT') - do while (read_line(file_id, i, RDMval)) - pamat(i) = RDMval - end do - close(file_id) + call mma_deallocate(temp_DMAT) + call mma_deallocate(temp_DSPN) + call mma_deallocate(temp_PSMAT) + call mma_deallocate(temp_PAMAT) + + ! Averaged RDM during orb rotation iterations + if (ifinal == 0) then + call RDM_to_runfile( + & DMAT, DSPN, PSMAT, PAMAT, jDisk + & ) + end if - file_id = IsFreeUnit(11) - call Molcas_Open(file_id, 'DMAT') - do while (read_line(file_id, i, RDMval)) - dmat(i) = RDMval - end do - close(file_id) + end subroutine read_neci_RDM - ! Clean evil non-positive semi-definite matrices, - ! by clamping the occupation numbers between 0 and 2. - ! DMAT is intent(inout) - call cleanMat(DMAT) + + subroutine read_single_neci_GUGA_RDM( + & iroot, DMAT, DSPN, PSMAT, PAMAT + & ) + integer, intent(in) :: iroot + real(wp), intent(out) :: DMAT(:), DSPN(:), PSMAT(:), PAMAT(:) + integer :: file_id, isfreeunit, i + logical :: tExist + real(wp) :: RDMval + + if (myRank /= 0) then + call bcast_2RDM("PSMAT." // str(iroot)) + call bcast_2RDM("PAMAT." // str(iroot)) + call bcast_2RDM("DMAT." // str(iroot)) + end if + + call f_Inquire('PSMAT.' // str(iroot), tExist) + call verify_(tExist, 'PSMAT.' // str(iroot) // + & ' does not exist') + call f_Inquire('PAMAT.' // str(iroot), tExist) + call verify_(tExist, 'PAMAT.' // str(iroot) // + & ' does not exist') + call f_Inquire('DMAT.' // str(iroot), tExist) + call verify_(tExist, 'DMAT.' // str(iroot) // + & ' does not exist') + + PSMAT(:) = 0.0_wp; PAMAT(:) = 0.0_wp; + DMAT(:) = 0.0_wp; DSPN(:) = 0.0_wp; + + file_id = IsFreeUnit(11) + call Molcas_Open(file_id, 'PSMAT.' // str(iroot)) + do while (read_line(file_id, i, RDMval)) + psmat(i) = RDMval + end do + close(file_id) + + file_id = IsFreeUnit(11) + call Molcas_Open(file_id, 'PAMAT.' // str(iroot)) + do while (read_line(file_id, i, RDMval)) + pamat(i) = RDMval + end do + close(file_id) + + file_id = IsFreeUnit(11) + call Molcas_Open(file_id, 'DMAT.' // str(iroot)) + do while (read_line(file_id, i, RDMval)) + dmat(i) = RDMval + end do + close(file_id) + + dspn = dspn_from_2rdm(psmat, pamat, dmat) + + ! Clean evil non-positive semi-definite matrices, + ! by clamping the occupation numbers between 0 and 2. + ! DMAT is intent(inout) + call cleanMat(DMAT) + call cleanMat(DSPN) contains @@ -98,8 +228,10 @@ !> Return true, if line was successfully read and false !> if EOF reached. !> Aborts if IO error happens. - !> **i and RDMval are undefined, if functions returns false**! + !> **i and RDMval are undefined, if functions returns false** logical function read_line(file_id, i, RDMval) + ! changed variable names to prevent masking the parent + ! scope integer, intent(in) :: file_id integer, intent(out) :: i real(wp), intent(out) :: RDMval @@ -118,7 +250,7 @@ end if end function - end subroutine read_neci_GUGA_RDM + end subroutine read_single_neci_GUGA_RDM !> @brief !> Start and control FCIQMC. @@ -127,259 +259,250 @@ !> !> @details !> Read TwoRDM files written by NECI and transfer them to Molcas. -!> Neci can have some intermediate spin-resolved/spin-free RDMs where basically aaaa contains -!> average of aaaa and bbbb, abab contains average of abab and baba... -!> This is ok for CASSCF but not ok for spin-resolved properties, in which case the completely -!> spin-resolved RDMs need to be read-in. -!> In principle, NECI could also evaluate and store completely spin-free matrices. -!> In that case only a reordering following Molcas convention is necessary. +!> Neci can have some intermediate spin-resolved/spin-free RDMs where +!> basically aaaa contains average of aaaa and bbbb, abab contains +!> average of abab and baba... This is ok for CASSCF but not ok +!> for spin-resolved properties, in which case the completely +!> spin-resolved RDMs need to be read-in. In principle, NECI could +!> also evaluate and store completely spin-free matrices. In that +!> case only a reordering following Molcas convention is necessary. +!> +!> @param[in] iroot +!> @param[out] DMAT Average 1 body density matrix +!> @param[out] DSPN Average spin 1-dens matrix +!> @param[out] PSMAT Average symm. 2-dens matrix +!> @param[out] PAMAT Average antisymm. 2-dens matrix !> -!> @paramin[out] DMAT Average 1 body density matrix -!> @paramin[out] DSPN Average spin 1-dens matrix -!> @paramin[out] PSMAT Average symm. 2-dens matrix -!> @paramin[out] PAMAT Average antisymm. 2-dens matrix - subroutine read_neci_RDM(DMAT, DSPN, PSMAT, PAMAT) - use Para_Info, only: MyRank + subroutine read_single_neci_RDM(iroot, DMAT, DSPN, PSMAT, PAMAT) + use Para_Info, only: MyRank #include "output_ras.fh" - real*8, intent(out) :: DMAT(:), DSPN(:), PSMAT(:), PAMAT(:) - integer :: iUnit, isfreeunit, p, q, r, s, pq, rs, ps, rq, psrq, - & pqrs, iread, norb, iprlev - logical :: tExist, switch - real*8 :: fac, RDMval, fcnacte - real*8 :: D_alpha(size(DMAT)), D_beta(size(DMAT)) + integer, intent(in) :: iroot + real*8, intent(out) :: DMAT(:), DSPN(:), PSMAT(:), PAMAT(:) + integer :: iUnit, isfreeunit, p, q, r, s, pq, rs, ps, rq, + & psrq, pqrs, iread, norb, iprlev + logical :: tExist, switch + real*8 :: fac, RDMval, fcnacte + real*8 :: D_alpha(size(DMAT)), D_beta(size(DMAT)) + + iprlev = iprloc(1) + if(iprlev == debug) then + write(u6,*) 'Rank of process: ', MyRank + end if + ! TODO: Does it really matter, can we not just read all spin + ! density matrices? Currently, this just adds another level of + ! unnecessary nesting. + switch = .true. ! spin-resolved + + if(myRank /= 0) then + call bcast_2RDM("TwoRDM_aaaa." // str(iroot)) + call bcast_2RDM("TwoRDM_abab." // str(iroot)) + call bcast_2RDM("TwoRDM_abba." // str(iroot)) + call bcast_2RDM("TwoRDM_bbbb." // str(iroot)) + call bcast_2RDM("TwoRDM_baba." // str(iroot)) + call bcast_2RDM("TwoRDM_baab." // str(iroot)) + end if + call f_Inquire('TwoRDM_aaaa.' // str(iroot),tExist) + call verify_(tExist, 'TwoRDM_aaaa.' // str(iroot) // + & ' does not exist') + call f_Inquire('TwoRDM_abab.'// str(iroot),tExist) + call verify_(tExist, 'TwoRDM_abab.' // str(iroot) // + & ' does not exist') + call f_Inquire('TwoRDM_abba.'// str(iroot),tExist) + call verify_(tExist, 'TwoRDM_abba.' // str(iroot) // + & ' does not exist') + if(switch) then + call f_Inquire('TwoRDM_bbbb.' // str(iroot),tExist) + call verify_(tExist, 'TwoRDM_bbbb.' // str(iroot) // + & ' does not exist') + call f_Inquire('TwoRDM_baba.' // str(iroot),tExist) + call verify_(tExist, 'TwoRDM_baba.' // str(iroot) // + & ' does not exist') + call f_Inquire('TwoRDM_baab.' // str(iroot),tExist) + call verify_(tExist, 'TwoRDM_baab.' // str(iroot) // + & ' does not exist') + end if + D_alpha(:) = 0.0d0 + D_beta(:) = 0.0d0 + PSMAT(:) = 0.0d0 + PAMAT(:) = 0.0d0 - iprlev = iprloc(1) - if(iprlev == debug) then - write(6,*) 'Rank of process: ', MyRank - end if - switch = .true. -* ^ This variable must become a keyword for discriminating spin-resolved from spin-free input RDMs. -* ^ For now when .false. it is assumed that 3 files (only aaaa, abab and abba) are fed. -* ^ ....... when .true. it is assumed that 6 files (adding bbbb, baba and baab) are fed. -********************************************************************************* -* Broadcasting TwoRDM generated by QMC code in master node into all processors. * -********************************************************************************* -! NOTE(Giovanni, Oskar): The suffix ".1" corresponds to the root. -! For state averaged the .1 shall be replaced by iroot. (irdm in NECI) - if(myRank /= 0) then - call bcast_2RDM("TwoRDM_aaaa.1") - call bcast_2RDM("TwoRDM_aaaa.1") - call bcast_2RDM("TwoRDM_abab.1") - call bcast_2RDM("TwoRDM_abba.1") - call bcast_2RDM("TwoRDM_bbbb.1") - call bcast_2RDM("TwoRDM_baba.1") - call bcast_2RDM("TwoRDM_baab.1") - end if -********************************************************************************** -******************************** existency check ********************************* -********************************************************************************** - call f_Inquire('TwoRDM_aaaa.1',tExist) - if(.not.tExist) goto 123 - call f_Inquire('TwoRDM_abab.1',tExist) - if(.not.tExist) goto 123 - call f_Inquire('TwoRDM_abba.1',tExist) - if(.not.tExist) goto 123 - if(switch) then - call f_Inquire('TwoRDM_bbbb.1',tExist) - if(.not.tExist) goto 123 - call f_Inquire('TwoRDM_baba.1',tExist) - if(.not.tExist) goto 123 - call f_Inquire('TwoRDM_baab.1',tExist) - if(.not.tExist) goto 123 - end if + fac = merge(0.5d0, 1.0d0, switch) + fcnacte = 1.0d0 / dble(nactel - 1) - D_alpha(:) = 0.0d0 - D_beta(:) = 0.0d0 - PSMAT(:) = 0.0d0 - PAMAT(:) = 0.0d0 - - fac = merge(0.5d0, 1.0d0, switch) - fcnacte = 1.0d0 / dble(nactel - 1) - -******************************************************************************************* -*************************** Processing TwoRDM-AAAA **************************************** -******************************************************************************************* - iUnit = IsFreeUnit(11) - call Molcas_Open(iUnit, 'TwoRDM_aaaa.1') - Rewind(iUnit) - IF(IPRLEV >= DEBUG) THEN - write(6,*) ' p q r s pq rs pqrs ', - & 'RDMval PSMAT PAMAT' - write(6,*) ' ********************** AAAA ****************** ' - end if - do -******************* processing as PQRS *********************** -************************************************************** - read(iUnit, "(4I6,G25.17)", iostat=iread) s, q, r, p, RDMval - if(iread /= 0) exit - pqrs = two_el_idx_flatten(p, q, r, s, pq, rs) -******* Contribution to PSMAT and PAMAT: - PSMAT(pqrs) = PSMAT(pqrs) + fac * RDMval - if (r /= s.and.p == q) PSMAT(pqrs) = PSMAT(pqrs) + fac * RDMval - if (p > q.and.r > s) PAMAT(pqrs) = PAMAT(pqrs) + fac * RDMval - if (p > q.and.r < s) PAMAT(pqrs) = PAMAT(pqrs) - fac * RDMval + iUnit = IsFreeUnit(11) + call Molcas_Open(iUnit, 'TwoRDM_aaaa.' // str(iroot)) + Rewind(iUnit) IF(IPRLEV >= DEBUG) THEN - write(6,'(7I6,3G25.17)') - & p,q,r,s,pq,rs,pqrs, RDMval,PSMAT(pqrs),PAMAT(pqrs) - END IF -******* Contribution to D_alpha (not final): - if (p == q) D_alpha(rs) = D_alpha(rs) + RDMval - if (r == s) D_alpha(pq) = D_alpha(pq) + RDMval -******************* processing as PSRQ *********************** -************************************************************** - psrq = two_el_idx_flatten(p, s, r, q, ps, rq) -******* Contribution to PSMAT and PAMAT: - if (r <= q) then - PSMAT(psrq) = PSMAT(psrq) - fac * RDMval - if (r /= q) PAMAT(psrq) = PAMAT(psrq) + fac * RDMval - end if - if (r > q) then - PSMAT(psrq) = PSMAT(psrq) - fac * RDMval - PAMAT(psrq) = PAMAT(psrq) - fac * RDMval + write(u6,*) 'p q r s pq rs pqrs', + & 'RDMval PSMAT PAMAT' + write(u6,*) '******* AAAA *******' end if - IF(IPRLEV >= DEBUG) THEN - write(6,'(7I6,3G25.17)') - & p,s,r,q,ps,rq,psrq, RDMval,PSMAT(psrq),PAMAT(psrq) - END IF -******* Contribution to D_alpha (not final): -* The minus sign comes from the fact that in NECI these elements have opposite sign -* compared to the element in normal order, that is d_pqrs = -d_psrq. - if (p == s) D_alpha(rq) = D_alpha(rq) - RDMval - if (r == q) D_alpha(ps) = D_alpha(ps) - RDMval - end do - close(iunit) + do -******************************************************************************************* -*************************** Processing TwoRDM-BBBB **************************************** -******************************************************************************************* - if (switch) then + read(iUnit, "(4I6,G25.17)", iostat=iread) + & s, q, r, p, RDMval + if(iread /= 0) exit + pqrs = two_el_idx_flatten(p, q, r, s, pq, rs) + ! Contribution to PSMAT and PAMAT: + PSMAT(pqrs) = PSMAT(pqrs) + fac * RDMval + if (r /= s.and.p == q) PSMAT(pqrs) = PSMAT(pqrs) + & + fac * RDMval + if (p > q.and.r > s) PAMAT(pqrs) = PAMAT(pqrs) + & + fac * RDMval + if (p > q.and.r < s) PAMAT(pqrs) = PAMAT(pqrs) + & - fac * RDMval + IF(IPRLEV >= DEBUG) THEN + write(u6,'(7I6,3G25.17)') + & p,q,r,s,pq,rs,pqrs, RDMval,PSMAT(pqrs),PAMAT(pqrs) + END IF + ! Contribution to D_alpha (not final): + if (p == q) D_alpha(rs) = D_alpha(rs) + RDMval + if (r == s) D_alpha(pq) = D_alpha(pq) + RDMval + psrq = two_el_idx_flatten(p, s, r, q, ps, rq) + ! Contribution to PSMAT and PAMAT: + if (r <= q) then + PSMAT(psrq) = PSMAT(psrq) - fac * RDMval + if (r /= q) PAMAT(psrq) = PAMAT(psrq) + fac * RDMval + end if + if (r > q) then + PSMAT(psrq) = PSMAT(psrq) - fac * RDMval + PAMAT(psrq) = PAMAT(psrq) - fac * RDMval + end if + IF(IPRLEV >= DEBUG) THEN + write(u6,'(7I6,3G25.17)') + & p,s,r,q,ps,rq,psrq, RDMval,PSMAT(psrq),PAMAT(psrq) + END IF + ! Contribution to D_alpha (not final): The minus sign comes + ! from the fact that in NECI these elements have opposite + ! sign compared to the element in normal order, that is + ! d_pqrs = -d_psrq. + if (p == s) D_alpha(rq) = D_alpha(rq) - RDMval + if (r == q) D_alpha(ps) = D_alpha(ps) - RDMval + end do + close(iunit) + + ! Processing TwoRDM-BBBB + if (switch) then + iUnit=IsFreeUnit(11) + Call Molcas_Open(iUnit,'TwoRDM_bbbb.' // str(iroot)) + Rewind(iUnit) + if (IPRLEV >= DEBUG) then + write(u6,*) ' p q r s pq rs pqrs', + & 'RDMval PSMAT PAMAT' + write(u6,*) '******* BBBB *******' + end if + do + ! processing as PQRS + read(iUnit,"(4I6,G25.17)",iostat=iread) s, q, r, p, RDMval + if(iread /= 0) exit + pqrs = two_el_idx_flatten(p, q, r, s, pq, rs) + ! Contribution to PSMAT and PAMAT: + PSMAT(pqrs) = PSMAT(pqrs) + fac * RDMval + if(r /= s.and.p == q) PSMAT(pqrs) = PSMAT(pqrs) + fac*RDMval + if(p > q.and.r > s) PAMAT(pqrs) = PAMAT(pqrs) + fac * RDMval + if(p > q.and.r < s) PAMAT(pqrs) = PAMAT(pqrs) - fac * RDMval + IF(IPRLEV >= DEBUG) THEN + write(u6,'(7I6,3G25.17)') + & p,q,r,s,pq,rs,pqrs, RDMval,PSMAT(pqrs),PAMAT(pqrs) + END IF + ! Contribution to D_beta (not final): + if (p == q) D_beta(rs) = D_beta(rs) + RDMval + if (r == s) D_beta(pq) = D_beta(pq) + RDMval + ! processing as PSRQ + psrq = two_el_idx_flatten(p, s, r, q, ps, rq) + ! Contribution to PSMAT and PAMAT: + if(r <= q) then + PSMAT(psrq) = PSMAT(psrq) - fac*RDMval + if(r /= q) PAMAT(psrq) = PAMAT(psrq) + fac*RDMval + end if + if(r > q) then + PSMAT(psrq) = PSMAT(psrq) - fac*RDMval + PAMAT(psrq) = PAMAT(psrq) - fac*RDMval + end if + IF(IPRLEV >= DEBUG) THEN + write(u6,'(7I6,3G25.17)') + & p,s,r,q,ps,rq,psrq, RDMval,PSMAT(psrq),PAMAT(psrq) + END IF + ! Contribution to D_beta (not final): The minus sign comes + ! from the fact that in NECI these elements have opposite + ! sign compared to the element in normal order, that is + ! d_pqrs = -d_psrq. + if(p == s) D_beta(rq)=D_beta(rq)-RDMval + if(r == q) D_beta(ps)=D_beta(ps)-RDMval + end do + close(iunit) + end if ! End statement for spin-resolved RDMs. + ! Processing TwoRDM-ABAB iUnit=IsFreeUnit(11) - Call Molcas_Open(iUnit,'TwoRDM_bbbb.1') + Call Molcas_Open(iUnit,'TwoRDM_abab.' // str(iroot)) Rewind(iUnit) - if (IPRLEV >= DEBUG) then - write(6,*) ' p q r s pq rs pqrs ', - & 'RDMval PSMAT PAMAT' - write(6,*) ' ********************** BBBB ****************** ' - end if + IF(IPRLEV >= DEBUG) THEN + write(u6,*) '******* ABAB *******' + END IF do -******************* processing as PQRS *********************** -************************************************************** - read(iUnit,"(4I6,G25.17)",iostat=iread) s, q, r, p, RDMval + read(iUnit,"(4I6,G25.17)",iostat=iread) s,q,r,p,RDMval if(iread /= 0) exit pqrs = two_el_idx_flatten(p, q, r, s, pq, rs) -******* Contribution to PSMAT and PAMAT: - PSMAT(pqrs) = PSMAT(pqrs) + fac * RDMval - if(r /= s.and.p == q) PSMAT(pqrs) = PSMAT(pqrs) + fac*RDMval - if(p > q.and.r > s) PAMAT(pqrs) = PAMAT(pqrs) + fac * RDMval - if(p > q.and.r < s) PAMAT(pqrs) = PAMAT(pqrs) - fac * RDMval - IF(IPRLEV >= DEBUG) THEN - write(6,'(7I6,3G25.17)') - & p,q,r,s,pq,rs,pqrs, RDMval,PSMAT(pqrs),PAMAT(pqrs) - END IF -******* Contribution to D_beta (not final): - if (p == q) D_beta(rs) = D_beta(rs) + RDMval - if (r == s) D_beta(pq) = D_beta(pq) + RDMval -******************* processing as PSRQ *********************** -************************************************************** - psrq = two_el_idx_flatten(p, s, r, q, ps, rq) -******* Contribution to PSMAT and PAMAT: - if(r <= q) then - PSMAT(psrq) = PSMAT(psrq) - fac*RDMval - if(r /= q) PAMAT(psrq) = PAMAT(psrq) + fac*RDMval - end if - if(r > q) then - PSMAT(psrq) = PSMAT(psrq) - fac*RDMval - PAMAT(psrq) = PAMAT(psrq) - fac*RDMval - end if - IF(IPRLEV >= DEBUG) THEN - write(6,'(7I6,3G25.17)') - & p,s,r,q,ps,rq,psrq, RDMval,PSMAT(psrq),PAMAT(psrq) - END IF -******* Contribution to D_beta (not final): -* The minus sign comes from the fact that in NECI these elements have opposite sign -* compared to the element in normal order, that is d_pqrs = -d_psrq. - if(p == s) D_beta(rq)=D_beta(rq)-RDMval - if(r == q) D_beta(ps)=D_beta(ps)-RDMval - end do - close(iunit) - end if ! End statement for spin-resolved RDMs. -******************************************************************************************* -*************************** Processing TwoRDM-ABAB **************************************** -******************************************************************************************* - iUnit=IsFreeUnit(11) - Call Molcas_Open(iUnit,'TwoRDM_abab.1') - Rewind(iUnit) - IF(IPRLEV >= DEBUG) THEN - write(6,*) ' ********************** ABAB ****************** ' - END IF - do - read(iUnit,"(4I6,G25.17)",iostat=iread) s,q,r,p,RDMval - if(iread /= 0) exit - pqrs = two_el_idx_flatten(p, q, r, s, pq, rs) -******* Contribution to PSMAT and PAMAT: + ! Contribution to PSMAT and PAMAT: PSMAT(pqrs) = PSMAT(pqrs) + fac*RDMval if(r > s.and.p /= q) PAMAT(pqrs) = PAMAT(pqrs) + fac*RDMval if(r < s.and.p /= q) PAMAT(pqrs) = PAMAT(pqrs) - fac*RDMval if(r /= s.and.p == q) PSMAT(pqrs) = PSMAT(pqrs) + fac*RDMval if (IPRLEV >= DEBUG) then - write(6,'(7I6,3G25.17)') + write(u6,'(7I6,3G25.17)') & p,q,r,s,pq,rs,pqrs, RDMval,PSMAT(pqrs),PAMAT(pqrs) end if -******* Contribution to D_alpha and D_beta (not final): + ! Contribution to D_alpha and D_beta (not final): if (p == q) D_alpha(rs) = D_alpha(rs) + RDMval if (r == s .and. p /= r) D_beta(pq) = D_beta(pq) + RDMval end do -******* Copy D_beta to D_alpha and clean D_beta again for further use: + ! Copy D_beta to D_alpha and clean D_beta again for further use: if (.not. switch) then D_alpha(:) = D_beta(:) + D_alpha(:) D_beta(:) = 0.0d0 end if close(iunit) -******************************************************************************************* -*************************** Processing TwoRDM-BABA **************************************** -******************************************************************************************* + ! Processing TwoRDM-BABA if (switch) then iUnit = IsFreeUnit(11) - Call Molcas_Open(iUnit,'TwoRDM_baba.1') + Call Molcas_Open(iUnit,'TwoRDM_baba.' // str(iroot)) rewind(iUnit) if (IPRLEV >= DEBUG) then - write(6,*) ' ********************** BABA ****************** ' + write(u6,*) '******* BABA *******' end if do read(iUnit,"(4I6,G25.17)",iostat=iread) s,q,r,p,RDMval if(iread /= 0) exit pqrs = two_el_idx_flatten(p, q, r, s, pq, rs) -******* Contribution to PSMAT and PAMAT: + ! Contribution to PSMAT and PAMAT: PSMAT(pqrs) = PSMAT(pqrs) + fac * RDMval if(r > s.and.p /= q) PAMAT(pqrs) = PAMAT(pqrs) + fac*RDMval if(r < s.and.p /= q) PAMAT(pqrs) = PAMAT(pqrs) - fac*RDMval if(r /= s.and.p == q) PSMAT(pqrs) = PSMAT(pqrs) + fac*RDMval IF(IPRLEV >= DEBUG) THEN - write(6,'(7I6,3G25.17)') + write(u6,'(7I6,3G25.17)') & p,q,r,s,pq,rs,pqrs, RDMval,PSMAT(pqrs),PAMAT(pqrs) END IF -******* Contribution to D_alpha (not final): + ! Contribution to D_alpha (not final): if(p == q) D_beta(rs) = D_beta(rs) + RDMval if(r == s.and.p /= r) D_alpha(pq) = D_alpha(pq)+RDMval end do close(iunit) end if ! End statement for spin-resolved RDMs. -******************************************************************************************* -*************************** Processing TwoRDM-ABBA **************************************** -******************************************************************************************* + ! Processing TwoRDM-ABBA iUnit=IsFreeUnit(11) - Call Molcas_Open(iUnit,'TwoRDM_abba.1') + Call Molcas_Open(iUnit,'TwoRDM_abba.' // str(iroot)) Rewind(iUnit) IF(IPRLEV >= DEBUG) THEN - write(6,*) ' ********************** ABBA ****************** ' + write(u6,*) '******* ABBA *******' END IF do read(iUnit,"(4I6,G25.17)",iostat=iread) q,s,r,p,RDMval if(iread /= 0) exit pqrs = two_el_idx_flatten(p, q, r, s, pq, rs) -******* Contribution to PSMAT and PAMAT: + ! Contribution to PSMAT and PAMAT: PSMAT(pqrs) = PSMAT(pqrs) - fac*RDMval if(r < s) then PAMAT(pqrs) = PAMAT(pqrs) + fac*RDMval @@ -388,10 +511,10 @@ PAMAT(pqrs) = PAMAT(pqrs) - fac*RDMval end if IF(IPRLEV >= DEBUG) THEN - write(6,'(7I6,3G25.17)') + write(u6,'(7I6,3G25.17)') & p,q,r,s,pq,rs,pqrs, RDMval,PSMAT(pqrs),PAMAT(pqrs) END IF -******* Contribution to D_alpha (not final): + ! Contribution to D_alpha (not final): if(r == s) D_alpha(pq)=D_alpha(pq)-RDMval if(p == q) D_beta(rs)=D_beta(rs)-RDMval end do @@ -400,21 +523,19 @@ D_beta(:) = 0.0d0 end if close(iunit) -******************************************************************************************* -*************************** Processing TwoRDM-BAAB **************************************** -******************************************************************************************* + ! Processing TwoRDM-BAAB if(switch) then iUnit=IsFreeUnit(11) - Call Molcas_Open(iUnit,'TwoRDM_baab.1') + Call Molcas_Open(iUnit,'TwoRDM_baab.' // str(iroot)) Rewind(iUnit) IF(IPRLEV >= DEBUG) THEN - write(6,*) ' ********************** BAAB ****************** ' + write(u6,*) ' ******* BAAB *******' END IF do read(iUnit,"(4I6,G25.17)",iostat=iread) q,s,r,p,RDMval if(iread /= 0) exit pqrs = two_el_idx_flatten(p, q, r, s, pq, rs) -******* Contribution to PSMAT and PAMAT: + ! Contribution to PSMAT and PAMAT: PSMAT(pqrs) = PSMAT(pqrs) - fac*RDMval if(r < s) then PAMAT(pqrs) = PAMAT(pqrs) + fac*RDMval @@ -423,41 +544,37 @@ PAMAT(pqrs) = PAMAT(pqrs) - fac*RDMval end if IF(IPRLEV >= DEBUG) THEN - write(6,'(7I6,3G25.17)') + write(u6,'(7I6,3G25.17)') & p,q,r,s,pq,rs,pqrs, RDMval,PSMAT(pqrs),PAMAT(pqrs) END IF -******* Contribution to D_alpha (not final): + ! Contribution to D_alpha (not final): if(p == q) D_alpha(rs)=D_alpha(rs)-RDMval if(r == s) D_beta(pq)=D_beta(pq)-RDMval end do close(iunit) end if ! End statement for spin-resolved RDMs. -******************************************************************************************* -*************************** Final Updates to RDMs ************************************** -******************************************************************************************* + ! Final Updates to RDMs if (.not.switch) D_beta(:) = D_alpha(:) D_alpha(:) = fcnacte * D_alpha(:) D_beta(:) = fcnacte * D_beta(:) DSPN(:) = D_Beta(:) - D_alpha(:) DMAT(:) = D_Beta(:) + D_alpha(:) -******* Clean evil non-positive semi-definite matrices. DMAT is input and output. + ! Clean evil non-positive semi-definite matrices. DMAT is input + ! and output. call cleanMat(DMAT) + call cleanMat(DSPN) - IF(IPRLEV >= DEBUG) THEN - norb = (int(sqrt(dble(1 + 8 * size(DMAT)))) - 1) / 2 - call triprt('D_alpha in neci2molcas',' ',D_alpha,norb) - call triprt('D_beta in neci2molcas',' ',D_beta ,norb) - call triprt('DMAT in neci2molcas',' ',DMAT,norb) - call triprt('DSPN in neci2molcas',' ',DSPN,norb) - END IF + if (iprlev >= debug) then + norb = (int(sqrt(dble(1 + 8 * size(DMAT)))) - 1) / 2 + call triprt('D_alpha in neci2molcas',' ',D_alpha,norb) + call triprt('D_beta in neci2molcas',' ',D_beta ,norb) + call triprt('DMAT in neci2molcas',' ',DMAT,norb) + call triprt('DSPN in neci2molcas',' ',DSPN,norb) + end if Return + end subroutine read_single_neci_RDM -123 continue - write(6,*) 'RDM files not found!' - write(6,*) 'Probably file not generated by NECI?' - Call Abend() - end subroutine read_neci_RDM subroutine bcast_2RDM(InFile) use filesystem, only : symlink_, strerror_, get_errno_ @@ -467,13 +584,193 @@ call prgmtranslate_master(InFile, master, lmaster1) call symlink_(trim(master), trim(InFile), err) - if (err == 0) write(6, *) strerror_(get_errno_()) + if (err == 0) write(u6, *) strerror_(get_errno_()) end subroutine bcast_2RDM + function dspn_from_2rdm(psmat, pamat, dmat) result(dspn) + ! Implementation following the Columbus paper: + ! 10.1080/00268976.2022.2091049 + ! Simplest assumption S = m_s, since m_s = 0 not useful; this + ! wave function has no spin polarisation density (unless S^2 + ! symmetry is broken which will not happen with the UGA). + use general_data, only: ispin +#include "output_ras.fh" + real(wp), intent(in) :: psmat(:), pamat(:), dmat(:) + real(wp) :: dspn(size(dmat)) + real(wp) :: intermed, S, AcEl, trace + integer :: p, q, k, pq, pqrs, n, iprlev + + ! ispin and nActEl are integer + S = (real(ispin, wp) - 1)/2 + AcEl = real(nActEl, wp) + + n = 1 + do q = 1, nAc + do p = 1, nAc + pq = one_el_idx_flatten(p, q) + intermed = 0.0_wp + do k = 1, nAc + if (q == k) then + n = 1 + else if (q < k) then + n = 2 + end if + pqrs = two_el_idx_flatten(p, k, q, k) + ! the sign on the PAMAT is flipped compared to my + ! Python implementation? + intermed = intermed + 2/n * (PSMAT(pqrs) - PAMAT(pqrs)) + end do + dspn(pq) = 1/(S+1)*((2-AcEl/2) * dmat(pq) - intermed) + end do + end do + + if (ispin == 1) dspn(:) = dspn(:) * 0 + + iprlev = iprloc(1) + if (iprlev >= debug) then + trace = 0.0_wp + do p = 1, nAc + pq = one_el_idx_flatten(p, p) + trace = trace + dspn(pq) + end do + write(u6,*) 'trace DSPN: ', trace + end if + end function + + +#ifdef _HDF5_ + subroutine expand_1rdm(dmat, decompr_dmat) + ! Decompresses DMAT from subroutine read_neci_RDM from a + ! linearised vector with symmetry into the full, redundant, 1RDM + ! matrix for HDF5 writing. +#include "output_ras.fh" + real(wp), intent(in) :: dmat(:) + real(wp), intent(out) :: decompr_dmat(nAc,nAc) + integer :: pq, p, q, iprlev + + do pq = 1, size(dmat) + call one_el_idx(pq, p, q) + decompr_dmat(p,q) = dmat(pq) + end do + do p = 1, nAc + do q = 1, nAc + if (p >= q) decompr_dmat(q,p) = decompr_dmat(p,q) + end do + end do + + iprlev = iprloc(1) + if (iprlev >= debug) then + write(u6,*) 'full DMAT: ' + do p = 1, nAc + write(u6,*) 'full DMAT: ', decompr_dmat(p,:) + end do + end if + end subroutine expand_1rdm + + + subroutine read_hdf5_denmats(iroot, dmat, dspn, psmat, pamat) +#include "output_ras.fh" + integer, intent(in) :: iroot + real(wp), intent(_OUT_) :: dmat(:), dspn(:), psmat(:), pamat(:) + integer, allocatable :: indices(:,:) + real(wp), allocatable :: values(:) + integer :: len4index(2), pqrs, pq, n_kl, p, q, r, s, i, + & hdf5_file, hdf5_group, hdf5_dset + real(wp) :: rdm2_temp(nAc, nAc, nAc, nAc) + logical :: tExist + integer :: iprlev + + if (MCM7) then + ! currently no multi-root functionality + call f_Inquire('M7.h5', tExist) + call verify_(tExist, 'M7.h5 does not exist.') + hdf5_file = mh5_open_file_r('M7.h5') + hdf5_group = mh5_open_group(hdf5_file, 'archive/rdms/sf_2200') + else + call f_Inquire('fciqmc.rdms.' //str(iroot)// '.h5', tExist) + call verify_(tExist, 'fciqmc.rdms.' // str(iroot) + & // '.h5 does not exist.') + hdf5_file = mh5_open_file_r('fciqmc.rdms.' // str(iroot) + & // '.h5') + hdf5_group = mh5_open_group(hdf5_file, 'archive/rdms/2200') + end if + hdf5_dset = mh5_open_dset(hdf5_group, 'indices') + len4index(:) = 0 + call mh5_get_dset_dims(hdf5_dset, len4index) + call mh5_close_dset(hdf5_dset) + call mma_allocate(indices, 4, len4index(2)) + call mma_allocate(values, len4index(2)) + indices(:,:) = 0 + values(:) = 0.0_wp + call mh5_fetch_dset(hdf5_group, 'values', values) + call mh5_fetch_dset(hdf5_group, 'indices', indices) + call mh5_close_group(hdf5_group) + call mh5_close_file(hdf5_file) + + rdm2_temp(:,:,:,:) = 0.0_wp + do i = 1, len4index(2) + if (MCM7) then + s = indices(1, i) + 1; p = indices(2, i) + 1 + r = indices(3, i) + 1; q = indices(4, i) + 1 + else + p = indices(1, i); r = indices(2, i) + q = indices(3, i); s = indices(4, i) + end if + rdm2_temp(p, q, r, s) = values(i) + rdm2_temp(q, p, s, r) = values(i) + rdm2_temp(r, s, p, q) = values(i) + rdm2_temp(s, r, q, p) = values(i) + end do + call mma_deallocate(indices) + call mma_deallocate(values) + + dmat(:) = 0.0_wp + dspn(:) = 0.0_wp + psmat(:) = 0.0_wp + pamat(:) = 0.0_wp + n_kl = 1 + do pqrs = 1, size(psmat, dim=1) + call two_el_idx(pqrs, p, q, r, s) + if (r == s) n_kl = 1 + if (r > s) n_kl = 2 + psmat(pqrs) = 0.5_wp * n_kl + & * (rdm2_temp(p, q, r, s) + rdm2_temp(q, p, r, s))/2 + pamat(pqrs) = -0.5_wp * n_kl + & * (rdm2_temp(p, q, r, s) - rdm2_temp(q, p, r, s))/2 + end do + + do pq = 1, size(dmat, dim=1) + call one_el_idx(pq, p, q) + do r = 1, nActEl + dmat(pq) = dmat(pq) + rdm2_temp(p, q, r, r) + end do + end do + dmat(:) = dmat(:) / (nActEl - 1) + + call cleanMat(dmat) ! cleanse non-PSD elements + + dspn = dspn_from_2rdm(psmat, pamat, dmat) + call cleanMat(dspn) ! cleanse non-PSD elements + + iprlev = iprloc(1) + if (iprlev >= debug) then + do p = 1, size(psmat) + write(u6,*) 'PSMAT:', p, psmat(p) + end do + do p = 1, size(pamat) + write(u6,*) 'PAMAT:', p, pamat(p) + end do + call triprt('DMAT ',' ', dmat, 6) + call triprt('DSPN ',' ', dspn, 6) + end if + + end subroutine read_hdf5_denmats +#endif + + ! Add your deallocations here. Called when exiting rasscf. subroutine cleanup() - ! Add your deallocations here. - ! This routine will be called when exiting rasscf. - !continue end subroutine + + end module fciqmc_read_RDM diff -Nru openmolcas-22.02/src/rasscf/generic_CI.f90 openmolcas-22.10/src/rasscf/generic_CI.f90 --- openmolcas-22.02/src/rasscf/generic_CI.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/generic_CI.f90 2022-10-10 14:22:40.000000000 +0000 @@ -14,11 +14,12 @@ #include "macros.fh" !> This module defines an abstract class for CI-solvers. -!> I you inherit from CI_solver_t and override the deferred methods, +!> If you inherit from CI_solver_t and override the deferred methods, !> your initialization and cleanup will be automatically called. module generic_CI use general_data, only : ntot, ntot1, ntot2 - use rasscf_data, only : nAcPar, nAcpr2 + use rasscf_data, only : nAcPar, nAcpr2, nroots + use definitions, only: wp implicit none private public :: CI_solver_t @@ -35,27 +36,33 @@ !> !> @author Oskar Weser !> -!> @paramin[in] actual_iter The actual iteration number starting at 0. +!> @param[in] actual_iter The actual iteration number starting at 0. !> This means 0 is 1A, 1 is 1B, 2 is 2 and so on. -!> @paramin[in] CMO MO coefficients -!> @paramin[in] DIAF DIAGONAL of Fock matrix useful for NECI -!> @paramin[in] D1I_MO Inactive 1-dens matrix -!> @paramin[in] TUVX Active 2-el integrals -!> @paramin[inout] F_In Fock matrix from inactive density -!> @paramin[inout] D1S_MO Average spin 1-dens matrix -!> @paramin[out] DMAT Average 1 body density matrix -!> @paramin[out] PSMAT Average symm. 2-dens matrix -!> @paramin[out] PAMAT Average antisymm. 2-dens matrix - subroutine CI_run_t(this, actual_iter, CMO, DIAF, D1I_AO, D1A_AO, TUVX, & - F_IN, D1S_MO, DMAT, PSMAT, PAMAT) - import :: CI_solver_t, ntot, ntot1, ntot2, nAcPar, nAcpr2 +!> @param[in] iroot specified roots for SA-CASSCF, e.g. 1,3,9,... +!> @param[in] weight weights specified for roots for SA-CASSCF +!> @param[in] CMO MO coefficients +!> @param[in] DIAF DIAGONAL of Fock matrix useful for NECI +!> @param[in] D1I_MO Inactive 1-dens matrix +!> @param[in] TUVX Active 2-el integrals +!> @param[in,out] F_In Fock matrix from inactive density +!> @param[in,out] D1S_MO Average spin 1-dens matrix +!> @param[out] DMAT Average 1 body density matrix +!> @param[out] PSMAT Average symm. 2-dens matrix +!> @param[out] PAMAT Average antisymm. 2-dens matrix + + subroutine CI_run_t(this, actual_iter, ifinal, iroot, weight, & + CMO, DIAF, D1I_AO, D1A_AO, TUVX, F_IN, & + D1S_MO, DMAT, PSMAT, PAMAT) + import :: CI_solver_t, ntot, ntot1, ntot2, nAcPar, nAcpr2, nroots,& + wp class(CI_solver_t), intent(in) :: this - integer, intent(in) :: actual_iter - real*8, intent(in) :: CMO(nTot2), DIAF(nTot), D1I_AO(nTot2), & + integer, intent(in) :: actual_iter, iroot(nroots), ifinal + real(wp), intent(in) :: weight(nroots), & + CMO(nTot2), DIAF(nTot), D1I_AO(nTot2), & D1A_AO(nTot2), TUVX(nAcpr2) - real*8, intent(inout) :: F_In(nTot1), D1S_MO(nAcPar) - real*8, intent(out) :: DMAT(nAcpar), PSMAT(nAcpr2), PAMAT(nAcpr2) + real(wp), intent(inout) :: F_In(nTot1), D1S_MO(nAcPar) + real(wp), intent(out) :: DMAT(nAcpar), PSMAT(nAcpr2), PAMAT(nAcpr2) end subroutine !> @brief diff -Nru openmolcas-22.02/src/rasscf/inppri.f openmolcas-22.10/src/rasscf/inppri.f --- openmolcas-22.02/src/rasscf/inppri.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/inppri.f 2022-10-10 14:22:40.000000000 +0000 @@ -36,6 +36,7 @@ use CC_CI_mod, only: Do_CC_CI use Fock_util_global, only: DoLocK use Functionals, only: Init_Funcs, Print_Info + use KSDFT_Info, only: CoefR, CoefX Implicit Real*8 (A-H,O-Z) #include "rasdim.fh" @@ -48,11 +49,10 @@ #include "WrkSpc.fh" #include "splitcas.fh" #include "lucia_ini.fh" -#include "ksdft.fh" Character*8 Fmt1,Fmt2,Label Character*120 Line,BlLine,StLine Character*3 lIrrep(8) - Character*16 KSDFT2 + Character*80 KSDFT2 #ifdef _ENABLE_CHEMPS2_DMRG_ Character*3 SNAC #endif @@ -221,9 +221,35 @@ Call CollapseOutput(0,'Orbital specifications:') Write(LF,*) -#if defined _ENABLE_BLOCK_DMRG_ || defined _ENABLE_CHEMPS2_DMRG_ +#if defined _ENABLE_BLOCK_DMRG_ || defined _ENABLE_CHEMPS2_DMRG_ || defined _ENABLE_DICE_SHCI_ If(.Not.DoBlockDMRG) GoTo 113 +#ifdef _ENABLE_DICE_SHCI_ + Line=' ' + Write(Line(left-2:),'(A)') 'DICE specifications:' + Call CollapseOutput(1,Line) + Write(LF,Fmt1)'--------------------------' + Write(LF,*) + Write(LF,Fmt2//'A,T70,L6)')'Heat-bath configuration interaction + &(JCTC, 2017, 13, 1595)', DoBlockDMRG + Write(LF,Fmt2//'A,T45,L6)')'Semistochastic algorithm',Dice_stoc + Write(LF,Fmt2//'A,T45,L6)')'Full restart',dice_restart + Write(LF,Fmt2//'A,T45,I6)')'Max iterations',dice_iter + Write(LF,Fmt2//'A,T45,E10.3)')'Epsilon1', + & dice_eps1 + Write(LF,Fmt2//'A,T45,E10.3)')'Epsilon2', + & dice_eps2 + Write(LF,Fmt2//'A,T45,I6)')'SampleN', + & dice_sampleN + Write(LF,Fmt2//'A,T45)')'Occupation guess' + do iref_dice=1,nref_dice + write(LF,Fmt2//'A)') trim(diceocc(iref_dice)) + enddo + Call CollapseOutput(0,'DICE specifications:') + +* Skip printing CI specifications in DICE + GoTo 114 +#endif Line=' ' Write(Line(left-2:),'(A)') 'DMRG sweep specifications:' @@ -384,7 +410,7 @@ end if Call CollapseOutput(0,'CI expansion specifications:') -#if defined _ENABLE_BLOCK_DMRG_ || defined _ENABLE_CHEMPS2_DMRG_ +#if defined _ENABLE_BLOCK_DMRG_ || defined _ENABLE_CHEMPS2_DMRG_ || defined _ENABLE_DICE_SHCI_ 114 Continue #endif diff -Nru openmolcas-22.02/src/rasscf/input_ras.fh openmolcas-22.10/src/rasscf/input_ras.fh --- openmolcas-22.02/src/rasscf/input_ras.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/input_ras.fh 2022-10-10 14:22:40.000000000 +0000 @@ -13,11 +13,11 @@ Integer LuInput * Used for input processing Integer NKeys - Parameter (NKeys=134) + Parameter (NKeys=147) *------------------------------------------------------ * Logical flags, to check whether a keyword has been used * in the input: - Logical KeyFlags(0:NKeys+1) + Logical KeyFlags(0:NKeys) Logical KeyAAAA, & KeyALTE, KeyATOM, KeyAVER, KeyCHAR, KeyCHOI, & KeyCHOL, KeyCIMX, KeyCION, KeyCIRE, KeyCIRO, @@ -45,7 +45,10 @@ & KeyDFCF, KeyNKEE, KeyREOR, KeyTRIA, KeyPOPS, & KeySEMI, KeyMEMO, KeyIVO , KeyCRPR, KeyRDML, & KeyORTH, KeyCCCI, KeyROST, KeyXMSI, KeyCMSI, - & KeyCMMA, KeyCMMI, KeyCMTH, KeyGUGA, KeyZZZZ + & KeyCMMA, KeyCMMI, KeyCMTH, KeyGUGA, KeyCMSS, + & KeyCMSO, KeyPERI, KeySSCR, KeyH5DM, KeyMCM7, + & KeyDICE, KeySTOC, KeyEPSI, KeySAMP, KeyDITE, + & KeyDIRE, KeyDIOC Common /InputFlags/ KeyAAAA, & KeyALTE, KeyATOM, KeyAVER, KeyCHAR, KeyCHOI, @@ -74,7 +77,10 @@ & KeyDFCF, KeyNKEE, KeyREOR, KeyTRIA, KeyPOPS, & KeySEMI, KeyMEMO, KeyIVO , KeyCRPR, KeyRDML, & KeyORTH, KeyCCCI, KeyROST, KeyXMSI, KeyCMSI, - & KeyCMMA, KeyCMMI, KeyCMTH, KeyGUGA, KeyZZZZ + & KeyCMMA, KeyCMMI, KeyCMTH, KeyGUGA, KeyCMSS, + & KeyCMSO, KeyPERI, KeySSCR, KeyH5DM, KeyMCM7, + & KeyDICE, KeySTOC, KeyEPSI, KeySAMP, KeyDITE, + & KeyDIRE, KeyDIOC Equivalence(KeyAAAA,KeyFlags(0)) *------------------------------------------------------ @@ -106,7 +112,10 @@ & 'DFCF','NKEE','REOR','TRIA','POPS', & 'SEMI','MEMO','IVO ','CRPR','RDML', & 'ORTH','CCCI','ROST','XMSI','CMSI', - & 'CMMA','CMMI','CMTH','GUGA']) + & 'CMMA','CMMI','CMTH','GUGA','CMSS', + & 'CMSO','PERI','SSCR','H5DM','MCM7', + & 'DICE','STOC','EPSI','SAMP','DITE', + & 'DIRE','DIOC']) *------------------------------------------------------ * Input data sets: Integer iCI_I,IROOT_I,NFRO_I,NISH_I,NRS1_I,NRS2_I,NRS3_I,NDEL_I, diff -Nru openmolcas-22.02/src/rasscf/mkcot.f openmolcas-22.10/src/rasscf/mkcot.f --- openmolcas-22.02/src/rasscf/mkcot.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/mkcot.f 2022-10-10 14:22:40.000000000 +0000 @@ -18,7 +18,7 @@ IMPLICIT REAL*8 (A-H,O-Z) C #include "rasdim.fh" -#include "general.fh" +#include "general_mul.fh" #include "output_ras.fh" #include "gugx.fh" C diff -Nru openmolcas-22.02/src/rasscf/mksgnum.f openmolcas-22.10/src/rasscf/mksgnum.f --- openmolcas-22.02/src/rasscf/mksgnum.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/mksgnum.f 2022-10-10 14:22:40.000000000 +0000 @@ -17,7 +17,7 @@ C IMPLICIT REAL*8 (A-H,O-Z) #include "rasdim.fh" -#include "general.fh" +#include "general_mul.fh" #include "gugx.fh" #include "WrkSpc.fh" #include "output_ras.fh" diff -Nru openmolcas-22.02/src/rasscf/mod_p2.f openmolcas-22.10/src/rasscf/mod_p2.f --- openmolcas-22.02/src/rasscf/mod_p2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/mod_p2.f 2022-10-10 14:22:40.000000000 +0000 @@ -9,7 +9,7 @@ * LICENSE or in <http://www.gnu.org/licenses/>. * ************************************************************************ Subroutine Mod_P2(P2mo,nP2Act,D1mo,nD1mo,DS1mo,ExFac,nDet) - use nq_Info + use nq_Info, only: iOff_Ash, mIrrep, nAsh Implicit Real*8 (A-H,O-Z) #include "real.fh" #include "output_ras.fh" diff -Nru openmolcas-22.02/src/rasscf/natorb_rasscf.f openmolcas-22.10/src/rasscf/natorb_rasscf.f --- openmolcas-22.02/src/rasscf/natorb_rasscf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/natorb_rasscf.f 2022-10-10 14:22:40.000000000 +0000 @@ -37,22 +37,6 @@ iDisk=IADR15(12) jDisk=IADR15(3) -* Write(LF,*) -* Write(LF,*) ' CMO in NATORB_RASSCF very beginning' -* Write(LF,*) ' ---------------------' -* Write(LF,*) -* ioff=0 -* Do iSym = 1,nSym -* iBas = nBas(iSym) -* if(iBas.ne.0) then -* write(6,*) 'Sym =', iSym -* do i= 1,iBas -* write(6,*) (CMOO(ioff+iBas*(i-1)+j),j=1,iBas) -* end do -* iOff = iOff + (iBas*iBas) -* end if -* End Do - if(.not.DoSplitCAS) then Do kRoot = 1,lRoots If(KSDFT.eq.'SCF'.and.IPRLEV.ge.USUAL) Then diff -Nru openmolcas-22.02/src/rasscf/neworb_rasscf.f openmolcas-22.10/src/rasscf/neworb_rasscf.f --- openmolcas-22.02/src/rasscf/neworb_rasscf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/neworb_rasscf.f 2022-10-10 14:22:40.000000000 +0000 @@ -186,7 +186,7 @@ ntud=istd+itri(ioff+1) DO NT=1,ngssh(igas,isym) ntud=ntud+ioff -C YM: change ntt --> nttr for the confict if include rctfld.fh +C YM: change ntt --> nttr for the conflict if include rctfld.fh nttr=nt+nio+ioff DO NU=1,NT nut=nu+nio+ioff diff -Nru openmolcas-22.02/src/rasscf/outctl.f openmolcas-22.10/src/rasscf/outctl.f --- openmolcas-22.02/src/rasscf/outctl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/outctl.f 2022-10-10 14:22:40.000000000 +0000 @@ -173,9 +173,36 @@ Call CollapseOutput(0,'Orbital specifications:') Write(LF,*) -#if defined _ENABLE_BLOCK_DMRG_ || defined _ENABLE_CHEMPS2_DMRG_ +#if defined _ENABLE_BLOCK_DMRG_ || defined _ENABLE_CHEMPS2_DMRG_ || defined _ENABLE_DICE_SHCI_ If(.Not.DoBlockDMRG) GoTo 113 +#ifdef _ENABLE_DICE_SHCI_ + Line=' ' + Write(Line(left-2:),'(A)') 'DICE specifications:' + Call CollapseOutput(1,Line) + Write(LF,Fmt2//'A)')'--------------------------' + Write(LF,*) + Write(LF,Fmt2//'A,T70,L6)')'Heat-bath configuration interaction + &(JCTC, 2017, 13, 1595)', DoBlockDMRG + Write(LF,Fmt2//'A,T45,L6)')'Semistochastic algorithm',Dice_stoc + Write(LF,Fmt2//'A,T45,L6)')'Full restart',dice_restart + Write(LF,Fmt2//'A,T45,I6)')'Max iterations',dice_iter + Write(LF,Fmt2//'A,T45,E10.3)')'Epsilon1', + & dice_eps1 + Write(LF,Fmt2//'A,T45,E10.3)')'Epsilon2', + & dice_eps2 + Write(LF,Fmt2//'A,T45,I6)')'SampleN', + & dice_sampleN + Write(LF,Fmt2//'A,T45)')'Occupation guess' + do iref_dice=1,nref_dice + write(LF,Fmt2//'A)') trim(diceocc(iref_dice)) + enddo + Call CollapseOutput(0,'DICE specifications:') + +* Skip printing CI specifications in DICE + GoTo 114 +#endif + Line='' Write(Line(left-2:),'(A)') 'DMRG sweep specifications:' Call CollapseOutput(1,Line) @@ -330,10 +357,10 @@ & 'in a previous calculation' Write(LF,*) End If - If (KSDFT.ne.'SCF'.and.KSDFT.ne.'PAM') Call Print_NQ_Info(iSpin) + If (KSDFT.ne.'SCF'.and.KSDFT.ne.'PAM') Call Print_NQ_Info() Call CollapseOutput(0,'CI expansion specifications:') -#if defined _ENABLE_BLOCK_DMRG_ || defined _ENABLE_CHEMPS2_DMRG_ +#if defined _ENABLE_BLOCK_DMRG_ || defined _ENABLE_CHEMPS2_DMRG_ || defined _ENABLE_DICE_SHCI_ 114 Continue #endif diff -Nru openmolcas-22.02/src/rasscf/outctlSplit.f openmolcas-22.10/src/rasscf/outctlSplit.f --- openmolcas-22.02/src/rasscf/outctlSplit.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/outctlSplit.f 2022-10-10 14:22:40.000000000 +0000 @@ -209,7 +209,7 @@ & 'in a previous calculation' Write(LF,*) End If - If (KSDFT.ne.'SCF'.and.KSDFT.ne.'PAM') Call Print_NQ_Info(iSpin) + If (KSDFT.ne.'SCF'.and.KSDFT.ne.'PAM') Call Print_NQ_Info() Call CollapseOutput(0,'CI expansion specifications:') * End of long if-block A over IPRLEV diff -Nru openmolcas-22.02/src/rasscf/print_mcpdft.f openmolcas-22.10/src/rasscf/print_mcpdft.f --- openmolcas-22.02/src/rasscf/print_mcpdft.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/print_mcpdft.f 2022-10-10 14:22:40.000000000 +0000 @@ -21,10 +21,9 @@ * G. Li Manni (GLM) ****************************************************************** use KSDFT_Info, only: Funcaa, Funcbb, Funccc - use nq_Info + use nq_Info, only: Dens_a1, Dens_a2, Dens_b1, Dens_b2, Dens_I Implicit Real*8 (A-H,O-Z) #include "WrkSpc.fh" -#include "ksdft.fh" write(6,'(6X,80A)') write(6,'(6X,80A)') ('*',i=1,80) diff -Nru openmolcas-22.02/src/rasscf/proc_inp.f openmolcas-22.10/src/rasscf/proc_inp.f --- openmolcas-22.02/src/rasscf/proc_inp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/proc_inp.f 2022-10-10 14:22:40.000000000 +0000 @@ -25,12 +25,15 @@ use Para_Info, Only: mpp_procid, mpp_nprocs #endif #endif + use csfbas, only: CONF, KCFTP use Fock_util_global, only: DoCholesky - use write_orbital_files, only: OrbFiles + use write_orbital_files, only: OrbFiles, write_orb_per_iter use fcidump, only: DumpOnly use fcidump_reorder, only: ReOrInp, ReOrFlag use fciqmc, only: DoEmbdNECI, DoNECI, tGUGA_in + use fciqmc_read_RDM, only: tHDF5_RDMs, MCM7 use CC_CI_mod, only: Do_CC_CI + use spin_correlation, only: orb_range_p, orb_range_q, same_orbs use orthonormalization, only : ON_scheme, ON_scheme_values use fciqmc_make_inp, only : trial_wavefunction, pops_trial, & t_RDMsampling, RDMsampling, @@ -41,9 +44,10 @@ & mh5_exists_dset, mh5_fetch_attr, mh5_fetch_dset, & mh5_close_file #endif - + use KSDFT_Info, only: CoefR, CoefX use OFembed, only: Do_OFemb,KEonly, OFE_KSDFT, & ThrFThaw, Xsigma, dFMD + use CMS, only: iCMSOpt,CMSGiveOpt,CMSGuessFile Implicit Real*8 (A-H,O-Z) #include "SysDef.fh" #include "rasdim.fh" @@ -54,15 +58,13 @@ #include "input_ras.fh" #include "splitcas.fh" #include "bk_approx.fh" -#include "general.fh" +#include "general_mul.fh" #include "output_ras.fh" #include "orthonormalize.fh" -#include "ksdft.fh" #include "casvb.fh" #include "pamint.fh" * Lucia-stuff: #include "ciinfo.fh" -#include "csfbas.fh" #include "spinfo.fh" #include "lucia_ini.fh" #include "rasscf_lucia.fh" @@ -168,6 +170,15 @@ hfocc(i) = 0 end do +#ifdef _ENABLE_DICE_SHCI_ + dice_stoc = .false. + nref_dice = 1 + dice_eps1 = 1.0d-4 + dice_eps2 = 1.0d-5 + dice_sampleN = 200 + dice_iter = 20 + dice_restart = .false. +#endif * SplitCAS related variables declaration (GLMJ) DoSplitCAS= .false. @@ -763,7 +774,7 @@ If (Line(1:4).eq.'ROKS') DFTFOCK='ROKS' If (Line(1:6).eq.'CASDFT') DFTFOCK='DIFF' Read(LUInput,*,End=9910,Err=9920) Line - KSDFT=Line(1:16) + KSDFT=Line(1:80) Call UpCase(KSDFT) l_casdft = KSDFT(1:2).eq.'T:' .or. KSDFT(1:3).eq.'FT:' If (.NOT.l_casdft) GoTo 9920 @@ -846,6 +857,55 @@ Call SetPos(LUInput,'CMSI',Line,iRc) Call ChkIfKey() End If +*--- Process CMSS command --------------------------------------------* + CMSStartMat='XMS' + If (KeyCMSS.and.(iCMSP.eq.1)) Then + If (DBG) Then + Write(6,*)' Reading CMS inital rotation matrix' + End If + Call SetPos(LUInput,'CMSS',Line,iRc) + Line=Get_Ln(LUInput) + If(iRc.ne._RC_ALL_IS_WELL_) GoTo 9810 + Call ChkIfKey() + If (DBG) Then + Write(6,*) ' Reading CMS starting rotation matrix from' + Write(6,*) trim(Line) + End If + if(.not.(trim(Line).eq.'XMS')) then + CMSGuessFile=trim(Line) + CMSStartMat=CMSGuessFile + call F_Inquire(trim(CMSStartMat),lExists) + if(.not.lExists) then + write(LF,'(6X,A,A)') trim(CMSStartMat), + &' is not found. Use XMS intermediate states as initial guess.' + CMSStartMat='XMS' + end if +C call fileorb(Line,CMSStartMat) + end if + End If +*--- Process CMSO command --------------------------------------------* + If (KeyCMSO.and.(iCMSP.eq.1)) Then + If (DBG) Then + Write(6,*) 'Inputting CMS optimization option' + End If + Call SetPos(LUInput,'CMSO',Line,iRc) + Line=Get_Ln(LUInput) + CALL Upcase(Line) + If(Line(1:4).eq.'NEWT') Then + iCMSOpt=1 + Else If(Line(1:4).eq.'JACO') Then + iCMSOpt=2 + Else + ReadStatus='Wrong value assigned to keyword CMSO' + GoTo 9920 + End If + CMSGiveOpt=.true. + If(iRc.ne._RC_ALL_IS_WELL_) GoTo 9810 + If (DBG) Then + Write(6,*) ' CMS Optimization Option',iCMSOpt + End If + Call ChkIfKey() + End If *--- Process CMMA command --------------------------------------------* If (KeyCMMA) Then If (DBG) Write(6,*) ' CMS Max Cylces keyword was given.' @@ -967,6 +1027,72 @@ Write(6,*) ' Response field will follow CISE root: ',ICIRFROOT End If End If +*--- Process SSCR command --------------------------------------------* + if (KeySSCR) then + if (DBG) write(6,*) ' SSCR command was given.' + call setpos(luinput,'SSCR',line,irc) + If(iRc.ne._RC_ALL_IS_WELL_) GoTo 9810 + line=get_ln(luinput) + line(80:80)='0' + ReadStatus=' Failure reading after KeySSCR keyword.' + read(line,*,err=9920,end=9920) norbs, same_orbs + ReadStatus=' O.K reading after KeySSCR keyword.' + + if (norbs >= mxOrb) then + write(6,'(a)', advance="no") 'SSCR error:' + write(6,*) "number of spatial orbitals exceeds maximum" + write(6,'(a,i4)') "norbs = ", norbs + write(6,'(a)') new_line('a') + call abend() + end if + + call mma_allocate(orb_range_p,norbs) + call mma_allocate(orb_range_q,norbs) + + if (same_orbs /= 1) then + Line=Get_Ln(LUInput) + readstatus=' failure reading after SSCR keyword.' + read(Line,*) (orb_range_p(i), i = 1, norbs) + Line=Get_Ln(LUInput) + read(Line,*) (orb_range_q(j), j = 1, norbs) + + if (size(orb_range_p) /= size(orb_range_q)) then + write(6,'(a)', advance="no") 'SSCR error:' + write(6,*) "numbers of spatial orbitals do not match" + write(6,*) "orb_range_p has length ", size(orb_range_p) + write(6,*) "orb_range_q has length ", size(orb_range_q) + write(6,'(a)') new_line('a') + call abend() + end if + + do i = 1, norbs + do j = 1, norbs + if (i < j) then + if (orb_range_p(i) == orb_range_p(j)) then + write(6,'(a)', advance="no") 'SSCR error:' + write(6,*) 'first range contains duplicates.' + write(6,'(*(i4))') orb_range_p + write(6,'(a)') new_line('a') + call abend() + end if + if (orb_range_q(i) == orb_range_q(j)) then + write(6,'(a)', advance="no") 'SSCR error:' + write(6,*) 'second range contains duplicates.' + write(6,'(*(i4))') orb_range_q + write(6,'(a)') new_line('a') + call abend() + end if + end if + end do + end do + else + do i = 1, norbs + orb_range_p(i) = i + orb_range_q(i) = i + end do + end if + call ChkIfKey() + end if *--- Process CIRO command --------------------------------------------* If (DBG) Write(6,*) ' Check for CIROOTS command.' IF(KeyCIRO) Then @@ -1941,6 +2067,9 @@ goto 9930 end if end if + if (KeyPERI) then + write_orb_per_iter = .true. + end if *--- Process NECI commands -------------------------------------------* if (KeyNECI) then if(DBG) write(6, *) 'NECI is actived' @@ -1962,6 +2091,20 @@ #endif end if *---------------------------------------------------------------------------------------- + if (KeyMCM7) then + MCM7 = .true. + if(DBG) write(6, *) 'M7 CASSCF activated.' + end if +*---------------------------------------------------------------------------------------- + if (KeyH5DM) then + tHDF5_RDMs = .true. + if(DBG) write(6, *) 'RDMs will be read from HDF5 files' + if (.not. KeyNECI .or. .not. KeyMCM7) then + call WarningMessage(2, 'H5DM requires NECI/M7 keyword!') + GoTo 9930 + end if + end if +*---------------------------------------------------------------------------------------- if (KeyGUGA) then tGUGA_in = .true. if(DBG) write(6, *) 'spin-free GUGA-NECI RDMs are actived' @@ -2989,6 +3132,73 @@ write(6,*)(hfocc(i),i=1,NASHT) End If +#ifdef _ENABLE_DICE_SHCI_ +*--- Process DICE command --------------------------------------------* + If (KeyDICE) Then + DoBlockDMRG = .True. + Write(6,*) 'DICE> (semistochastic) heat bath configuration ', + & 'interaction (SHCI)' + Call SetPos(LUInput,'DICE',Line,iRc) + Call ChkIfKey() + End If +*--- Process STOC command --------------------------------------------* + If (KeySTOC) Then + Dice_Stoc=.True. + Write(6,*) 'DICE> Using semistochastic algorithm', + & 'interaction (SHCI)' + Call SetPos(LUInput,'STOC',Line,iRc) + Call ChkIfKey() + End If +*--- Process DIOC command --------------------------------------------* + DICEOCC = '' + If (KeyDIOC) Then + Call SetPos(LUInput,'DIOC',Line,iRc) + If(iRc.ne._RC_ALL_IS_WELL_) GoTo 9810 + ReadStatus=' Failure reading data after DIOC keyword.' + Read(LUInput,*,End=9910,Err=9920) nref_dice + do iref_dice=1,nref_dice + Read(LUInput,'(A)',End=9910,Err=9920) diceocc(iref_dice) + call molcas2dice(diceocc(iref_dice)) + enddo + ReadStatus=' O.K. after reading data after DIOC keyword.' + Call ChkIfKey() + End If +*--- Process EPSI command --------------------------------------------* + If (KeyEPSI) Then + If (DBG) Write(6,*) ' EPS (Thresholds) command was used.' + Call SetPos(LUInput,'EPS',Line,iRc) + If(iRc.ne._RC_ALL_IS_WELL_) GoTo 9810 + ReadStatus=' Failure reading thresholds after EPSI keyword.' + Read(LUInput,*,End=9910,Err=9920) dice_eps1,dice_eps2 + ReadStatus=' O.K. after reading thresholds after EPSI keyword.' + Call ChkIfKey() + End If +*--- Process SAMP command --------------------------------------------* + If (KeySAMP) Then + Call SetPos(LUInput,'SAMP',Line,iRc) + If(iRc.ne._RC_ALL_IS_WELL_) GoTo 9810 + ReadStatus=' Failure reading data after SAMP keyword.' + Read(LUInput,*,End=9910,Err=9920) dice_sampleN + ReadStatus=' O.K. after reading data after SAMP keyword.' + Call ChkIfKey() + End If +*--- Process DITE command --------------------------------------------* + If (KeyDITE) Then + Call SetPos(LUInput,'DITE',Line,iRc) + If(iRc.ne._RC_ALL_IS_WELL_) GoTo 9810 + ReadStatus=' Failure reading data after DITE keyword.' + Read(LUInput,*,End=9910,Err=9920) dice_iter + ReadStatus=' O.K. after reading data after DITE keyword.' + Call ChkIfKey() + End If +*--- Process DIRE command --------------------------------------------* + If (KeyDIRE) Then + dice_restart=.True. + Call SetPos(LUInput,'DIRE',Line,iRc) + Call ChkIfKey() + End If +#endif + *--- All keywords have been processed ------------------------------* If (.not.KeyINAC) Then @@ -3329,7 +3539,7 @@ IF (ICICH.EQ.1) THEN CALL GETMEM('UG2SG','ALLO','INTE',LUG2SG,NCONF) CALL UG2SG(NROOTS,NCONF,NAC,NACTEL,STSYM,IPR, - * IWORK(KICONF(1)),IWORK(KCFTP),IWORK(LUG2SG), + * CONF,IWORK(KCFTP),IWORK(LUG2SG), * ICI,JCJ,CCI,MXROOT) CALL GETMEM('UG2SG','FREE','INTE',LUG2SG,NCONF) END IF diff -Nru openmolcas-22.02/src/rasscf/qune.f openmolcas-22.10/src/rasscf/qune.f --- openmolcas-22.02/src/rasscf/qune.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/qune.f 2022-10-10 14:22:40.000000000 +0000 @@ -22,7 +22,7 @@ #include "output_ras.fh" CHARACTER*2 QNSTEP CHARACTER*3 QNUPDT - Character*16 KSDFT + Character*80 KSDFT DIMENSION BK(NDIM),XSX(NDIM),VL(NDIM),VM(NDIM) DIMENSION XQN(NDIM),XOLD(NDIM),V1(NDIM),V2(NDIM) SAVE ALPHA,BETA,ELAST,FPLAST,NVEC,NLS diff -Nru openmolcas-22.02/src/rasscf/rasscf.f openmolcas-22.10/src/rasscf/rasscf.f --- openmolcas-22.02/src/rasscf/rasscf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/rasscf.f 2022-10-10 14:22:40.000000000 +0000 @@ -50,15 +50,23 @@ #ifdef _DMRG_ ! module dependencies - use qcmaquis_interface_cfg - use qcmaquis_interface + use qcmaquis_interface, only: qcmaquis_interface_delete_chkp, + & qcmaquis_interface_prepare_hirdm_template, + & qcmaquis_interface_deinit, qcmaquis_param, + & TEMPLATE_4RDM, TEMPLATE_TRANSITION_3RDM, dmrg_energy use qcmaquis_interface_mpssi, only: qcmaquis_mpssi_transform #endif use stdalloc, only: mma_allocate, mma_deallocate use Fock_util_global, only: ALGO, DoActive, DoCholesky - use write_orbital_files, only : OrbFiles, putOrbFile + use write_orbital_files, only : OrbFiles, putOrbFile, + & write_orb_per_iter + use filesystem, only: copy_, real_path use generic_CI, only: CI_solver_t use fciqmc, only: DoNECI, fciqmc_solver_t, tGUGA_in + use para_info, only: king + use fortran_strings, only: str + use spin_correlation, only: spin_correlation_driver, + & orb_range_p, orb_range_q use CC_CI_mod, only: Do_CC_CI, CC_CI_solver_t use fcidump, only : make_fcidumps, transform, DumpOnly use orthonormalization, only : ON_scheme @@ -68,6 +76,7 @@ #endif #ifdef _HDF5_ use mh5, only: mh5_put_attr, mh5_put_dset + use csfbas, only: CONF, KCFTP #endif use OFembed, only: Do_OFemb, FMaux @@ -90,7 +99,6 @@ #include "casvb.fh" #include "rasscf_lucia.fh" #include "lucia_ini.fh" -#include "csfbas.fh" #include "gugx.fh" #include "pamint.fh" #include "qnctl.fh" @@ -807,6 +815,9 @@ if (allocated(CI_solver)) then call CI_solver%run(actual_iter=actual_iter, + & ifinal=ifinal, + & iroot=iroot, + & weight=weight, & CMO=work(LCMO : LCMO + nTot2 - 1), & DIAF=work(LDIAF : LDiaf + nTot - 1), & D1I_AO=work(lD1I : lD1I + nTot2 - 1), @@ -818,7 +829,7 @@ & PSMAT=work(lpmat : lPMat + nAcpr2 - 1), & PAMAT=work(lpa : lpa + nAcPr2 - 1)) -#if defined _ENABLE_BLOCK_DMRG_ || defined _ENABLE_CHEMPS2_DMRG_ +#if defined _ENABLE_BLOCK_DMRG_ || defined _ENABLE_CHEMPS2_DMRG_ || defined _ENABLE_DICE_SHCI_ else If(DoBlockDMRG) then CALL DMRGCTL(WORK(LCMO), & WORK(LDMAT),WORK(LDSPN),WORK(LPMAT),WORK(LPA), @@ -1071,6 +1082,9 @@ Call Timing(Swatch,Swatch,Zenith_1,Swatch) if (allocated(CI_solver)) then call CI_solver%run(actual_iter=actual_iter, + & ifinal=ifinal, + & iroot=iroot, + & weight=weight, & CMO=work(LCMO : LCMO + nTot2 - 1), & DIAF=work(LDIAF : LDiaf + nTot - 1), & D1I_AO=work(lD1I : lD1I + nTot2 - 1), @@ -1081,7 +1095,7 @@ & DMAT=work(lDMAT : lDMAT + nAcPar - 1), & PSMAT=work(lpmat : lPMat + nAcpr2 - 1), & PAMAT=work(lpa : lpa + nAcPr2 - 1)) -#if defined _ENABLE_BLOCK_DMRG_ || defined _ENABLE_CHEMPS2_DMRG_ +#if defined _ENABLE_BLOCK_DMRG_ || defined _ENABLE_CHEMPS2_DMRG_ || defined _ENABLE_DICE_SHCI_ else If(DoBlockDMRG) Then CALL DMRGCTL(WORK(LCMO), & WORK(LDMAT),WORK(LDSPN),WORK(LPMAT),WORK(LPA), @@ -1321,6 +1335,7 @@ call mh5_put_attr(wfn_iter, Iter) call mh5_put_dset(wfn_energy, ENER(1,Iter)) #endif + * * Print output of energies and convergence parameters * @@ -1485,7 +1500,11 @@ end if end if else - IF (DIFFE.GT.1.D-10 .AND. NROOTS.EQ.1) THEN + DIFFETol = 1.D-10 +#ifdef _ENABLE_DICE_SHCI_ + if (DoBlockDMRG) DIFFETol = 1.D-8 +#endif + IF (DIFFE.GT.DIFFETol .AND. NROOTS.EQ.1) THEN Write(LF,'(6X,120A1)') ('=',i=1,120) Call WarningMessage(2,'Rasscf and CI energies differ.') Write(LF,'(6X,A,I11)') 'iteration ',ITER @@ -1526,6 +1545,15 @@ END IF end if + if (write_orb_per_iter .and. king()) then + call copy_(real_path('RASORB'), + & real_path('ITERORB.'//str(actual_iter))) +#ifdef _HDF5_ + call copy_(real_path('RASWFN'), + & real_path('RASWFN.'//str(actual_iter))) + +#endif + end if * * Convergence check: @@ -1685,6 +1713,9 @@ if (allocated(CI_solver)) then call CI_solver%run(actual_iter=actual_iter, + & ifinal=ifinal, + & iroot=iroot, + & weight=weight, & CMO=work(LCMO : LCMO + nTot2 - 1), & DIAF=work(LDIAF : LDiaf + nTot - 1), & D1I_AO=work(lD1I : lD1I + nTot2 - 1), @@ -1695,7 +1726,7 @@ & DMAT=work(lDMAT : lDMAT + nAcPar - 1), & PSMAT=work(lpmat : lPMat + nAcpr2 - 1), & PAMAT=work(lpa : lpa + nAcPr2 - 1)) -#if defined _ENABLE_BLOCK_DMRG_ || defined _ENABLE_CHEMPS2_DMRG_ +#if defined _ENABLE_BLOCK_DMRG_ || defined _ENABLE_CHEMPS2_DMRG_ || defined _ENABLE_DICE_SHCI_ else If(DoBlockDMRG) Then CALL DMRGCTL(WORK(LCMO), & WORK(LDMAT),WORK(LDSPN),WORK(LPMAT),WORK(LPA), @@ -1784,7 +1815,7 @@ * Read and reorder the left CI vector Call DDafile(JOBIPH,2,Work(iTmp),nConf,jDisk) Call Reord2(NAC,NACTEL,STSYM,1, - & iWork(KICONF(1)),iWork(KCFTP), + & CONF,iWork(KCFTP), & Work(iTmp),Work(iVecL),iWork(ivkcnf)) C_Pointer=iVecL kDisk=IADR15(4) @@ -1792,7 +1823,7 @@ * Read and reorder the right CI vector Call DDafile(JOBIPH,2,Work(iTmp),nConf,kDisk) Call Reord2(NAC,NACTEL,STSYM,1, - & iWork(KICONF(1)),iWork(KCFTP), + & CONF,iWork(KCFTP), & Work(iTmp),Work(iVecR),iWork(ivkcnf)) * Compute TDM and store in h5 file Call Lucia_Util('Densi',iVecR,iDummy,Dummy) @@ -1815,6 +1846,13 @@ & 'TDM keyword ignored.') #endif End If + + if (KeySSCR) then + call spin_correlation_driver(orb_range_p, orb_range_q, iroot) + call mma_deallocate(orb_range_p) + call mma_deallocate(orb_range_q) + end if + * ***************************************************************** * Export all information relevant to geometry optimizations. @@ -2044,9 +2082,9 @@ if (NACTEL.gt.3) then ! Ignore 4-RDM if we have <4 electrons do i=1,NROOTS Write (6,'(a)') 'Writing 4-RDM QCMaquis template'// - & ' for state '//trim(str(i)) + & ' for state '//str(i) call qcmaquis_interface_prepare_hirdm_template( - & filename="meas-4rdm."//trim(str(i-1))//".in", + & filename="meas-4rdm."//str(i-1)//".in", & state=i-1, & tpl=TEMPLATE_4RDM) call qcmaquis_mpssi_transform( @@ -2062,10 +2100,9 @@ do i=1,NROOTS do j=i+1,NROOTS Write (6,'(a)') 'Writing 3-TDM QCMaquis template'// - & ' for states '//trim(str(i))//" and "//trim(str(j)) + & ' for states '//str(i)//" and "//str(j) call qcmaquis_interface_prepare_hirdm_template( - & filename="meas-3tdm."//trim(str(i-1))//"."// - & trim(str(j-1))//".in", + & filename="meas-3tdm."//str(i-1)//"."//str(j-1)//".in", & state=i-1, & state_j=j-1, & tpl=TEMPLATE_TRANSITION_3RDM) diff -Nru openmolcas-22.02/src/rasscf/rasscf_init.f openmolcas-22.10/src/rasscf/rasscf_init.f --- openmolcas-22.02/src/rasscf/rasscf_init.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/rasscf_init.f 2022-10-10 14:22:40.000000000 +0000 @@ -25,6 +25,7 @@ Use Fock_util_global, only: ALGO, Deco, DensityCheck, dmpk, & DoCholesky, DoLocK, Estimate, Nscreen, & Update + use CMS, only: iCMSOpt,CMSGiveOpt Implicit Real*8 (A-H,O-Z) External Get_SuperName Character*100 ProgName, Get_SuperName @@ -32,13 +33,12 @@ #include "output_ras.fh" #include "rasscf.fh" #include "casvb.fh" -#include "general.fh" +#include "general_mul.fh" #include "gas.fh" #include "timers.fh" #include "lucia_ini.fh" #include "orthonormalize.fh" #include "WrkSpc.fh" -#include "ksdft.fh" Integer IPRGLB_IN, IPRLOC_IN(7) * What to do with Cholesky stuff? Logical, External :: Is_First_Iter @@ -258,9 +258,6 @@ * KSDFT='SCF' ExFac=1.0D0 -* Initialize KSDF coefficients (S Dong, 2018) - CoefR = 1.0D0 - CoefX = 1.0D0 ** Default orthonormalization of CMOs to be with ** Gram-Schmidt * Lowdin_ON=.False. @@ -371,6 +368,9 @@ iCMSP=0 ICMSIterMax=100 ICMSIterMin=5 - CMSThreshold=1.0d-6 + CMSThreshold=1.0d-8 + CMSStartMat='XMS' + iCMSOpt=1 + CMSGiveOpt=.false. RETURN END diff -Nru openmolcas-22.02/src/rasscf/readvc.f openmolcas-22.10/src/rasscf/readvc.f --- openmolcas-22.02/src/rasscf/readvc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/readvc.f 2022-10-10 14:22:40.000000000 +0000 @@ -250,7 +250,7 @@ end if Else If (IPRLEV.ge.TERSE) then - Write(LF,*) ' File JOBOLD not found -- use JOBIPH.' + Write(LF,'(6X,A)') 'File JOBOLD not found -- use JOBIPH.' End If If (JOBIPH.gt.0) Then JOBOLD=JOBIPH diff -Nru openmolcas-22.02/src/rasscf/rotorb.f openmolcas-22.10/src/rasscf/rotorb.f --- openmolcas-22.02/src/rasscf/rotorb.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/rotorb.f 2022-10-10 14:22:40.000000000 +0000 @@ -46,7 +46,7 @@ Write(LF,*) - Write(LF,*)'FI+FA in RotOrb bf Unitary transform' + Write(LF,*)'FI+FA in RotOrb by Unitary transform' Write(LF,*) ' --------------' Write(LF,*) iOff = 1 diff -Nru openmolcas-22.02/src/rasscf/rotstate.f openmolcas-22.10/src/rasscf/rotstate.f --- openmolcas-22.02/src/rasscf/rotstate.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/rotstate.f 2022-10-10 14:22:40.000000000 +0000 @@ -21,7 +21,6 @@ #include "general.fh" #include "gas.fh" #include "output_ras.fh" -#include "csfbas.fh" #include "gugx.fh" #include "WrkSpc.fh" #include "SysDef.fh" @@ -38,14 +37,11 @@ Integer LHrot,NHrot ! storing info in H0_Rotate.txt Integer LRCIVec,LRCItmp,NRCIVec,LRCIScr ! storing CIVec - Integer LRState,LRSttmp,NRState ! storing info in Do_Rotate.txt + Integer LRState,NRState ! storing info in Do_Rotate.txt Integer LHScr ! calculating rotated H Integer rcidisk - INTEGER LURot,IsFreeUnit - EXTERNAL IsFreeUnit - INTEGER JRoot,Kroot,IPRLEV + INTEGER JRoot,IPRLEV CHARACTER(Len=18)::MatInfo - INTEGER ReadStat write(LF,*) write(LF,*) ('=',i=1,71) write(LF,*) @@ -77,24 +73,11 @@ IPRLEV=IPRLOC(3) *JB read rotation matrix in Do_Rotate.txt - LUROT=183 - LUROT=IsFreeUnit(LURot) - CALL Molcas_Open(LURot,'ROT_VEC') - LRSttmp=LRState - Do jRoot = 1,lRoots - read(LURot,*) (Work(LRSttmp+kRoot-1),kRoot=1,lRoots) - LRSttmp=LRSttmp+lRoots - End Do - Read(LURot,*,iostat=ReadStat) MatInfo - IF(ReadStat.eq.-1) MatInfo='an unknown method' - close(LURot) + CALL ReadMat2('ROT_VEC',MatInfo,WORK(LRState),lRoots,lRoots, + & 7,18,'T') iF(IPRLEV.GE.DEBUG) Then write(LF,*)'rotation matrix' - LRSttmp=LRState - Do jRoot = 1,lRoots - write(LF,*) (Work(LRSttmp+kRoot-1),kRoot=1,lRoots) - LRSttmp=LRSttmp+lRoots - End Do + CALL RecPrt(' ',' ',WORK(LRState),lRoots,lRoots) eND iF NHRot=lRoots**2 CALL DCOPY_(NHRot,[0.0d0],0,WORK(LHRot),1) @@ -105,14 +88,8 @@ & lRoots,Work(LHRot),lRoots,0.0D0,Work(LHScr),lRoots) Call DGEMM_('n','n',lRoots,lRoots,lRoots,1.0D0,Work(LHScr), & lRoots,Work(LRState),lRoots,0.0D0,Work(LHRot),lRoots) - LUROT=IsFreeUnit(LURot) - CALL Molcas_Open(LURot,'ROT_HAM') - Do Jroot=1,lroots - write(LUROT,*) (Work(LHRot+Jroot-1+(Kroot-1)*lroots) - & ,kroot=1,lroots) - End Do - write(LURot,*) MatInfo - Close(LUROT) + CALL PrintMat2('ROT_HAM',MatInfo,WORK(LHRot),lRoots,lRoots, + & 7,18,'T') if(IPRLEV.GE.DEBUG) Then write(LF,'(6X,A)') 'Rotated Hamiltonian matrix ' write(LF,*) (Work(LHRot+jroot),jroot=0,NHRot-1) @@ -127,8 +104,6 @@ End Do Call DGEMM_('n','n',NConf,lRoots,lRoots,1.0D0,Work(LRCIScr), & nConf,Work(LRState),lRoots,0.0D0,Work(LRCIVec),nConf) -C Call DGEMM_('n','t',lRoots,NConf,lRoots,1.0D0,Work(LRState), -C & lRoots,Work(LRCIVec),nConf,0.0D0,Work(LRCIScr),lRoots) C updating final energies as those for rotated states rcidisk=IADR15(4) diff -Nru openmolcas-22.02/src/rasscf/sgfcin.f openmolcas-22.10/src/rasscf/sgfcin.f --- openmolcas-22.02/src/rasscf/sgfcin.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/sgfcin.f 2022-10-10 14:22:40.000000000 +0000 @@ -30,7 +30,7 @@ *> *> @param[in] CMO The MO-coefficients *> @param[out] F The inactive Fock matrix in the basis of the active MO -*> @param[inout] FI The inactive Fock matrix in AO-space +*> @param[in,out] FI The inactive Fock matrix in AO-space *> \f[\sum_{\sigma\rho} D^I_{\sigma\rho}(g_{\mu\nu\sigma\rho} - \frac{1}{2} g_{\mu\sigma\rho\nu})\f] *> In output FI contains also the core energy added to *> the diagonal elements. diff -Nru openmolcas-22.02/src/rasscf/sgprwf.f openmolcas-22.10/src/rasscf/sgprwf.f --- openmolcas-22.02/src/rasscf/sgprwf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/sgprwf.f 2022-10-10 14:22:40.000000000 +0000 @@ -20,7 +20,7 @@ C #include "rasdim.fh" #include "rasscf.fh" -#include "general.fh" +#include "general_mul.fh" #include "input_ras.fh" #include "output_ras.fh" #include "gugx.fh" diff -Nru openmolcas-22.02/src/rasscf/spin_correlation.f90 openmolcas-22.10/src/rasscf/spin_correlation.f90 --- openmolcas-22.02/src/rasscf/spin_correlation.f90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rasscf/spin_correlation.f90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,96 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 2022, Arta Safari * +!*********************************************************************** + +module spin_correlation + use definitions, only: wp, u6 + use stdalloc, only: mma_allocate, mma_deallocate + use CI_solver_util, only: rdm_from_runfile + use rasscf_data, only : NRoots, iAdr15, nacpar, nacpr2 + use index_symmetry, only : one_el_idx_flatten, two_el_idx_flatten + + implicit none + private + public :: spin_correlation_driver + integer, allocatable, public, save :: orb_range_p(:), orb_range_q(:) + integer, public :: same_orbs + + +contains + + + subroutine spin_correlation_driver(orb_range_p, orb_range_q, iroot) + !! spin-spin-correlation function using orbital-resolved 2RDMs. + !! For details see Dobrautz et al. 2021, 10.1021/acs.jctc.1c00589. + integer, intent(in) :: orb_range_p(:), orb_range_q(:), iroot(:) + real(wp), allocatable :: spin_correlations(:) + real(wp) :: dmat(nacpar), dspn(nacpar), pamat(nacpr2), psmat(nacpr2) + integer :: jDisk, i, j + + jDisk = iAdr15(3) + call mma_allocate(spin_correlations, size(iroot)) + spin_correlations(:) = 0.0_wp + + write(u6,'(a)') new_line('a') + do i = 1, NRoots + do j = 1, size(iroot) + if (iroot(j) == i) then + call rdm_from_runfile(dmat, dspn, psmat, pamat, jDisk) + spin_correlations(j) = correlation_func(orb_range_p, orb_range_q, & + dmat, psmat, pamat) + write(u6,'(a,i2,a,f12.8)') ':: RASSCF root number ', iroot(j), & + ' Spin Correlation: ', spin_correlations(j) + end if + end do + end do + + ! for testing purposes + call Add_Info('spin correlation', spin_correlations(1), 1, 8) + + call mma_deallocate(spin_correlations) + end subroutine spin_correlation_driver + + + real(wp) function correlation_func(orb_range_p, orb_range_q, & + dmat, psmat, pamat) result(corr) + !! extract spin-spin-correlation function from orbital resolved RDMs. + integer, intent(in) :: orb_range_p(:), orb_range_q(:) + real(wp), intent(in) :: dmat(nacpar), psmat(nacpr2), pamat(nacpr2) + integer :: rp, rq, p, q, pp, pppp, pqqp, ppqq + real(wp) :: twordm_pqqp, twordm_ppqq, twordm_pppp, onerdm_pp + + corr = 0.0_wp + + do p = 1, size(orb_range_p) + do q = 1, size(orb_range_q) + ! dummy variables to save space + rp = orb_range_p(p); rq = orb_range_q(q) + if (rp /= rq) then + pqqp = two_el_idx_flatten(rp, rq, rq, rp) + ppqq = two_el_idx_flatten(rp, rp, rq, rq) + twordm_pqqp = psmat(pqqp) - pamat(pqqp) + twordm_ppqq = 2 * (psmat(ppqq) + pamat(ppqq)) + + corr = corr - 0.5_wp * (twordm_pqqp + 0.5_wp * twordm_ppqq) + else + pppp = two_el_idx_flatten(rp, rp, rp, rp) + pp = one_el_idx_flatten(rp, rp) + + twordm_pppp = 2 * (psmat(pppp) + pamat(pppp)) + onerdm_pp = dmat(pp) + corr = corr + 0.75_wp * (onerdm_pp - twordm_pppp) + end if + end do + end do + end function correlation_func + +end module spin_correlation diff -Nru openmolcas-22.02/src/rasscf/write_orbital_files.f openmolcas-22.10/src/rasscf/write_orbital_files.f --- openmolcas-22.02/src/rasscf/write_orbital_files.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/write_orbital_files.f 2022-10-10 14:22:40.000000000 +0000 @@ -16,13 +16,16 @@ implicit none private - public :: OrbFiles, get_typeidx, putOrbFile + public :: OrbFiles, get_typeidx, putOrbFile, + & write_orb_per_iter save interface get_typeidx module procedure RAS_get_typeidx, GAS_get_typeidx end interface + logical :: write_orb_per_iter = .false. + interface integer function isfreeunit(iseed) integer, intent(in) :: iseed diff -Nru openmolcas-22.02/src/rasscf/xmsrot.f openmolcas-22.10/src/rasscf/xmsrot.f --- openmolcas-22.02/src/rasscf/xmsrot.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rasscf/xmsrot.f 2022-10-10 14:22:40.000000000 +0000 @@ -60,7 +60,7 @@ RETURN End Subroutine -*********************************************************************** +************************************************************************ ****************************************************** Subroutine CalcFckO(CMO,FI,FA,FckO) @@ -342,11 +342,13 @@ CHARACTER(Len=LenName)::FileName CHARACTER(Len=LenInfo)::MatInfo CHARACTER(Len=1)::Trans + CHARACTER(Len=80)::PrtFmt Real*8,DIMENSION(NRow,NCol)::Matrix INTEGER LU,IsFreeUnit,IRow,ICol External IsFreeUnit + IF(LenName.gt.0) THEN LU=100 LU=IsFreeUnit(LU) @@ -354,13 +356,20 @@ ELSE LU=6 END IF + IF(Trans.eq.'N') THEN + WRITE(PrtFmt,'(A1,I5,A14)') + & '(',NCol,'(E24.14E4,1X))' DO IRow=1,NRow - write(LU,*) (Matrix(IRow,ICol),ICol=1,NCol) + write(LU,PrtFmt) + & (Matrix(IRow,ICol),ICol=1,NCol) END DO ELSE + WRITE(PrtFmt,'(A1,I5,A14)') + & '(',NRow,'(E24.14E4,1X))' DO ICol=1,NCol - write(LU,*) (Matrix(IRow,ICol),IRow=1,NRow) + write(LU,PrtFmt) + & (Matrix(IRow,ICol),IRow=1,NRow) END DO END IF WRITE(LU,*)MatInfo diff -Nru openmolcas-22.02/src/rassi/dens2hdf5.f openmolcas-22.10/src/rassi/dens2hdf5.f --- openmolcas-22.02/src/rassi/dens2hdf5.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rassi/dens2hdf5.f 2022-10-10 14:22:40.000000000 +0000 @@ -33,7 +33,6 @@ *> *> @param[in] IndexE SF states sorted by energy *> @param[in] nSS number of SO states -*> @param[in] nSS number of SO states *> @param[in] USOR SO coefficients in SF basis (real part) *> @param[in] USOI SO coefficients in SF basis (imaginary part) *> @param[in] MapSt map of SF states expanded by multiplicity diff -Nru openmolcas-22.02/src/rassi/dqvdiabat.f openmolcas-22.10/src/rassi/dqvdiabat.f --- openmolcas-22.02/src/rassi/dqvdiabat.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rassi/dqvdiabat.f 2022-10-10 14:22:40.000000000 +0000 @@ -25,6 +25,7 @@ *> order. *> *> @param[in] PROP Properties computed in RASSI +*> @param[in] HAM ************************************************************************ SUBROUTINE DQVDiabat(PROP,HAM) IMPLICIT REAL*8 (A-H,O-Z) diff -Nru openmolcas-22.02/src/rassi/eigctl.f openmolcas-22.10/src/rassi/eigctl.f --- openmolcas-22.02/src/rassi/eigctl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rassi/eigctl.f 2022-10-10 14:22:40.000000000 +0000 @@ -12,6 +12,7 @@ USE RASSI_aux USE kVectors USE rassi_global_arrays, only: JBNUM + USE do_grid, only: Do_Lebedev_Sym #ifdef _HDF5_ USE Dens2HDF5 USE mh5, ONLY: mh5_put_dset @@ -53,7 +54,7 @@ Real*8 TM_R(3), TM_I(3), TM_C(3) Character*60 FMTLINE Real*8 Wavevector(3), UK(3) - Real*8, Allocatable :: pol_Vector(:,:) + Real*8, Allocatable :: pol_Vector(:,:), Rquad(:,:) Real*8, Allocatable :: TDMZZ(:),TSDMZZ(:),WDMZZ(:),SCR(:,:) #ifdef _HDF5_ Real*8, Allocatable, Target :: Storage(:,:,:,:) @@ -311,16 +312,16 @@ C Put energies onto info file for automatic verification runs: CPAM06 Added error estimate, based on independent errors for all C components of H and S in original RASSCF wave function basis: - EPSH=MAX(5.0D-10,ABS(ENERGY(1))*5.0D-11) EPSS=5.0D-11 + EPSH=MAX(5.0D-10,ABS(ENERGY(1))*EPSS) IDX=100 DO I=1,NSTATE - EI=ENERGY(I) + EI=ENERGY(I)*EPSS V2SUM=0.0D0 DO J=1,NSTATE V2SUM=V2SUM+EIGVEC(J,I)**2 END DO - ERMS=SQRT(EPSH**2+EI**2*EPSS**2)*V2SUM + ERMS=SQRT(EPSH**2+EI**2)*V2SUM IDX=MIN(IDX,INT(-LOG10(ERMS))) END DO iTol=cho_x_gettol(IDX) ! reset thr iff Cholesky @@ -617,8 +618,8 @@ IF(DIPR) THEN WRITE(6,30) 'Dipole printing threshold changed to ',OSTHR END IF -! this is to ensure that the total transistion strength is non-zero -! Negative transitions strengths can occur for quadrupole transistions +! this is to ensure that the total transition strength is non-zero +! Negative transitions strengths can occur for quadrupole transitions ! due to the truncation of the Taylor expansion. IF(QIPR) OSTHR = OSTHR_QIPR IF(QIPR) THEN @@ -2389,15 +2390,15 @@ * If (Do_SK) Then nQuad=1 - Call GetMem('SK','ALLO','REAL',ipR,4*nQuad) + Call mma_Allocate(Rquad,4,nQuad,label='SK') nVec = nk_Vector Else Call Setup_O() * In the spin-free case, oscillator and rotatory strengths for k and -k * are equal, so we compute only half the quadrature points and multiply * the weights by 2 - Call Do_Lebedev_Sym(L_Eff,nQuad,ipR) - Call DScal_(nQuad,2.0D0,Work(ipR+3),4) + Call Do_Lebedev_Sym(L_Eff,nQuad,Rquad) + Rquad(4,:) = 2.0D0*Rquad(4,:) nVec = 1 End If If (Do_Pol) Call mma_allocate(pol_Vector,3,nVec*nQuad,Label='POL') @@ -2515,10 +2516,8 @@ * Do iVec = 1, nVec If (Do_SK) Then - Work(ipR )=k_Vector(1,iVec) - Work(ipR+1)=k_Vector(2,iVec) - Work(ipR+2)=k_Vector(3,iVec) - Work(ipR+3)=1.0D0 ! Dummy weight + Rquad(1:3,1)=k_Vector(:,iVec) + Rquad(4,1)=1.0D0 ! Dummy weight End If * iPrint=0 @@ -2570,15 +2569,13 @@ * Generate the wavevector associated with this quadrature * point and pick up the associated quadrature weight. * - UK(1)=Work((iQuad-1)*4 +ipR) - UK(2)=Work((iQuad-1)*4+1+ipR) - UK(3)=Work((iQuad-1)*4+2+ipR) + UK(:)=Rquad(1:3,iQuad) Wavevector(:)=rkNorm*UK(:) * * Note that the weights are normalized to integrate to * 4*pi over the solid angles. * - Weight=Work((iQuad-1)*4+3+ipR) + Weight=Rquad(4,iQuad) If (.Not.Do_SK) Weight=Weight/(4.0D0*PI) * * Generate the polarization vector @@ -3045,7 +3042,7 @@ * Do some cleanup * If (.NOT.Do_SK) Call Free_O() - Call Free_Work(ipR) + Call mma_deAllocate(Rquad) Call ClsSew() ************************************************************************ * * diff -Nru openmolcas-22.02/src/rassi/inpprc.f openmolcas-22.10/src/rassi/inpprc.f --- openmolcas-22.02/src/rassi/inpprc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rassi/inpprc.f 2022-10-10 14:22:40.000000000 +0000 @@ -13,6 +13,7 @@ use rassi_aux, Only : jDisk_TDM, AO_Mode, JOB_INDEX, CMO1, CMO2, & DMAB, mTRA use kVectors + USE do_grid, only: Do_Lebedev_Sym IMPLICIT REAL*8 (A-H,O-Z) #include "prgm.fh" CHARACTER*16 ROUTINE @@ -35,6 +36,7 @@ INTEGER ICMPLST(MXPROP) LOGICAL JOBMATCH,IsAvail(MXPROP),IsAvailSO(MXPROP) DIMENSION IDUM(1) + REAL*8, ALLOCATABLE :: Rquad(:,:) * Analysing and post-processing the input that was read in readin_rassi. @@ -1058,9 +1060,9 @@ Else nk_Vector = 1 Call Setup_O() - Call Do_Lebedev_Sym(L_Eff,nQuad,ipR) + Call Do_Lebedev_Sym(L_Eff,nQuad,Rquad) + Call mma_deallocate(Rquad) Call Free_O() - Call Free_Work(ipR) End If Else nk_Vector = 0 diff -Nru openmolcas-22.02/src/rassi/mktdm1.f openmolcas-22.10/src/rassi/mktdm1.f --- openmolcas-22.02/src/rassi/mktdm1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rassi/mktdm1.f 2022-10-10 14:22:40.000000000 +0000 @@ -14,7 +14,7 @@ & DET1,DET2,SIJ,NASHT,TDM1,TSDM1,WTDM1,ISTATE,JSTATE, & job1,job2,ist,jst) - !> module dependencies + ! module dependencies #ifdef _DMRG_ use rasscf_data, only: doDMRG use qcmaquis_interface_cfg diff -Nru openmolcas-22.02/src/rassi/mktdm2.f openmolcas-22.10/src/rassi/mktdm2.f --- openmolcas-22.02/src/rassi/mktdm2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rassi/mktdm2.f 2022-10-10 14:22:40.000000000 +0000 @@ -14,7 +14,7 @@ & MAPORB,DET1,DET2,NTDM2,TDM2, & ISTATE,JSTATE) - !> module dependencies + ! module dependencies #ifdef _DMRG_ use rasscf_data, only: doDMRG use qcmaquis_info diff -Nru openmolcas-22.02/src/rassi/prepMPS.f90 openmolcas-22.10/src/rassi/prepMPS.f90 --- openmolcas-22.02/src/rassi/prepMPS.f90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rassi/prepMPS.f90 2022-10-10 14:22:40.000000000 +0000 @@ -30,7 +30,7 @@ ist & ) - !> module dependencies + ! module dependencies #ifdef _DMRG_ use qcmaquis_interface_cfg use qcmaquis_info diff -Nru openmolcas-22.02/src/rassi/prprop_TM_exact.f openmolcas-22.10/src/rassi/prprop_TM_exact.f --- openmolcas-22.02/src/rassi/prprop_TM_exact.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rassi/prprop_TM_exact.f 2022-10-10 14:22:40.000000000 +0000 @@ -15,6 +15,7 @@ SUBROUTINE PRPROP_TM_Exact(PROP,USOR,USOI,ENSOR,NSS,JBNUM,EigVec) USE RASSI_AUX USE kVectors + USE do_grid, only: Do_Lebedev_Sym #ifdef _HDF5_ USE mh5, ONLY: mh5_put_dset #endif @@ -51,7 +52,7 @@ Real*8 TM_R(3), TM_I(3), TM_C(3) Real*8 wavevector(3), UK(3) Real*8 kPhase(2) - Real*8, Allocatable :: pol_Vector(:,:) + Real*8, Allocatable :: pol_Vector(:,:), Rquad(:,:) #ifdef _HDF5_ Real*8, Allocatable, Target :: Storage(:,:,:,:) Real*8, Pointer :: flatStorage(:) @@ -209,11 +210,11 @@ If (Do_SK) Then nQuad = 1 nVec=nk_Vector - Call GetMem('SK','ALLO','REAL',ipR,4*nQuad) + Call mma_allocate(Rquad,4,nQuad,label='SK') If (.Not.(PRRAW.Or.PRWEIGHT)) kPhase(2) = 0.0D0 Else Call Setup_O() - Call Do_Lebedev_Sym(L_Eff,nQuad,ipR) + Call Do_Lebedev_Sym(L_Eff,nQuad,Rquad) nVec = 1 End If If (Do_Pol) Call mma_allocate(pol_Vector,3,nVec*nQuad,Label='POL') @@ -344,10 +345,8 @@ Do iVec = 1, nVec * If (Do_SK) Then - Work(ipR )=k_Vector(1,iVec) - Work(ipR+1)=k_Vector(2,iVec) - Work(ipR+2)=k_Vector(3,iVec) - Work(ipR+3)=1.0D0 ! Dummy weight + Rquad(1:3,1)=k_Vector(:,iVec) + Rquad(4,1)=1.0D0 ! Dummy weight End If * iPrint=0 @@ -474,15 +473,13 @@ * Generate the wavevector associated with this quadrature * point and pick up the associated quadrature weight. * - UK(1)=Work((iQuad-1)*4 +ipR) - UK(2)=Work((iQuad-1)*4+1+ipR) - UK(3)=Work((iQuad-1)*4+2+ipR) + UK(:)=Rquad(1:3,iQuad) wavevector(:)=rkNorm*UK(:) * * Note that the weights are normalized to integrate to * 4*pi over the solid angles. * - Weight=Work((iQuad-1)*4+3+ipR) + Weight=Rquad(4,iQuad) If (.Not.Do_SK) Weight = Weight/(4.0D0*PI) * * Generate the polarization vector @@ -882,7 +879,7 @@ End If WRITE(6,'(4x,a,3F10.6)') & 'Direction of the k-vector: ', - & (Work(ipR+k),k=0,2) + & Rquad(1:3,1) Else CALL CollapseOutput(1, & 'Isotropic transition moment strengths '// @@ -1051,7 +1048,7 @@ Call mma_deAllocate(TSDMZZ) Call mma_deAllocate(WDMZZ) If (.NOT.Do_SK) Call Free_O() - Call Free_Work(ipR) + Call mma_deAllocate(Rquad) Call ClsSew() 666 Continue diff -Nru openmolcas-22.02/src/rassi/soeig.f openmolcas-22.10/src/rassi/soeig.f --- openmolcas-22.02/src/rassi/soeig.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rassi/soeig.f 2022-10-10 14:22:40.000000000 +0000 @@ -42,7 +42,7 @@ REAL*8 PROP(NSTATE,NSTATE,NPROP),ENERGY(NSTATE) INTEGER I,N - INTEGER ITOL + INTEGER ITOL,IDX INTEGER JOB INTEGER IPROP INTEGER IAMFIX,IAMFIY,IAMFIZ,IAMX,IAMY,IAMZ @@ -56,7 +56,7 @@ REAL*8 AU2EV,AU2CM REAL*8 AMFIX,AMFIY,AMFIZ REAL*8 CG0,CGM,CGP,CGX,CGY - REAL*8 E,E0,E1,E2,E3,E_TMP,FACT,FRAC + REAL*8 E,E0,E1,E2,E3,E_TMP,FACT,FRAC,EI,EPSH,EPSS,ERMS,V2SUM REAL*8 HSOI,HSOR,HSOTOT REAL*8 OMEGA REAL*8 S1,S2,SM1,SM2 @@ -578,7 +578,19 @@ END IF C Put energy onto info file for automatic verification runs: - iTol=cho_x_gettol(8) ! reset thr iff Cholesky + EPSS=5.0D-11 + EPSH=MAX(5.0D-10,ABS(ENSOR(1)+EMIN)*EPSS) + IDX=100 + DO ISS=1,NSS + EI=(ENSOR(ISS)+EMIN)*EPSS + V2SUM=0.0D0 + DO JSS=1,NSS + V2SUM=V2SUM+USOR(JSS,ISS)**2+USOI(JSS,ISS)**2 + END DO + ERMS=SQRT(EPSH**2+EI**2)*V2SUM + IDX=MIN(IDX,INT(-LOG10(ERMS))) + END DO + iTol=cho_x_gettol(IDX) ! reset thr iff Cholesky Call Add_Info('ESO_LOW',ENSOR+EMIN,NSS,iTol) IF(IPGLOB.GE.VERBOSE) THEN diff -Nru openmolcas-22.02/src/rassi/tmomint.f openmolcas-22.10/src/rassi/tmomint.f --- openmolcas-22.02/src/rassi/tmomint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rassi/tmomint.f 2022-10-10 14:22:40.000000000 +0000 @@ -15,7 +15,6 @@ * * ************************************************************************ Use MpmC - use nq_Info !#define _DEBUGPRINT_ #ifdef _DEBUGPRINT_ use Sizes_of_Seward, only: S diff -Nru openmolcas-22.02/src/rassi/trint.f openmolcas-22.10/src/rassi/trint.f --- openmolcas-22.02/src/rassi/trint.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rassi/trint.f 2022-10-10 14:22:40.000000000 +0000 @@ -114,13 +114,13 @@ NFAO=NBSQ Call Allocate_DT(FAO,nBasF,nBasF,nSym) -* * -*********************************************************************** -* * +* * +************************************************************************ +* * IF (.not.DoCholesky) THEN ! Conventional integrals -* * -*********************************************************************** -* * +* * +************************************************************************ +* * If ( IfTest ) Call dVcPrt('Done',' ',DINAO%A0,NDINAO) C GET THE ONE-ELECTRON HAMILTONIAN MATRIX FROM ONE-EL FILE AND @@ -154,13 +154,13 @@ #endif ECORE2=DDOT_(NBSQ,FAO%A0,1,DINAO%A0,1) -* * -*********************************************************************** -* * +* * +************************************************************************ +* * Else ! RI/CD integrals -* * -*********************************************************************** -* * +* * +************************************************************************ +* * * ------ Initialize Cholesky information CALL CHO_X_INIT(irc,ChFracMem) @@ -347,13 +347,13 @@ write(6,*)'TrInt: Cho_X_Final returns error code ',irc write(6,*)'Try recovery -- continue.' endif -* * -*********************************************************************** -* * +* * +************************************************************************ +* * EndIf -* * -*********************************************************************** -* * +* * +************************************************************************ +* * If ( IfTest ) Write (6,*) ' Etwo =',ECORE2 ECORE=0.5D0*(ECORE1+ECORE2) If ( IfTest ) Write (6,*) ' Ecore =',ECORE diff -Nru openmolcas-22.02/src/rhodyn/get_hcsf.F90 openmolcas-22.10/src/rhodyn/get_hcsf.F90 --- openmolcas-22.02/src/rhodyn/get_hcsf.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rhodyn/get_hcsf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -85,7 +85,7 @@ else HTOT_CSF(:,:) = HTOTRE_CSF+V_CSF end if -if (ipglob > 2) write(u6,*) 'end contructing full Hamiltonian' +if (ipglob > 2) write(u6,*) 'end constructing full Hamiltonian' ! Check whether total Hamiltonian is hermitian if (ipglob > 3) then diff -Nru openmolcas-22.02/src/rhodyn/kab.F90 openmolcas-22.10/src/rhodyn/kab.F90 --- openmolcas-22.02/src/rhodyn/kab.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rhodyn/kab.F90 2022-10-10 14:22:40.000000000 +0000 @@ -106,7 +106,7 @@ do i=1,Nmode write(u6,*) (G_SF(i,j),j=1,nconftot) end do - ! contruct the G_SO matrix + ! construct the G_SO matrix do i=1,NState do j=1,NState do k=1,Nmode @@ -314,7 +314,7 @@ close(lu) ! close file max_Kab_basis.dat -! contruct the matrix (k_bar)_ij=0.5*sum_k[(kab_basis)_ik+(kab_basis)_jk] +! construct the matrix (k_bar)_ij=0.5*sum_k[(kab_basis)_ik+(kab_basis)_jk] do i=1,d do j=1,d diff -Nru openmolcas-22.02/src/rhodyn/k_external.F90 openmolcas-22.10/src/rhodyn/k_external.F90 --- openmolcas-22.02/src/rhodyn/k_external.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rhodyn/k_external.F90 2022-10-10 14:22:40.000000000 +0000 @@ -154,7 +154,7 @@ end do close(lu) -! contruct the matrix (k_bar)_ij=0.5*sum_k[(kab_basis)_ik+(kab_basis)_jk] +! construct the matrix (k_bar)_ij=0.5*sum_k[(kab_basis)_ik+(kab_basis)_jk] do i=1,Nstate do j=1,Nstate do k=1,Nstate diff -Nru openmolcas-22.02/src/rhodyn/rhodyn_utils.F90 openmolcas-22.10/src/rhodyn/rhodyn_utils.F90 --- openmolcas-22.02/src/rhodyn/rhodyn_utils.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rhodyn/rhodyn_utils.F90 2022-10-10 14:22:40.000000000 +0000 @@ -16,7 +16,9 @@ module rhodyn_utils ! module contains some auxiliary routines +#ifdef _ADDITIONAL_RUNTIME_CHECK_ use linalg_mod, only: abort_ +#endif use Definitions, only: wp, iwp implicit none @@ -66,7 +68,10 @@ real(kind=wp), intent(in) :: a(:,:), b(:,:) real(kind=wp), intent(out) :: c(:,:) logical(kind=iwp), intent(in), optional :: transpA, transpB - integer(kind=iwp) :: k, k1, k2, m, n + integer(kind=iwp) :: k, k1, m, n +# ifdef _ADDITIONAL_RUNTIME_CHECK_ + integer(kind=iwp) :: k2 +# endif logical(kind=iwp) :: transpA_, transpB_ if (present(transpA)) then @@ -84,7 +89,9 @@ n = size(b,merge(1,2,transpB_)) ASSERT(n == size(c,2)) k1 = size(a,merge(1,2,transpA_)) +# ifdef _ADDITIONAL_RUNTIME_CHECK_ k2 = size(b,merge(2,1,transpB_)) +# endif ASSERT(k1 == k2) k = k1 call dgemm_(merge('T','N',transpA_),merge('T','N',transpB_),m,n,k,One,a,size(a,1),b,size(b,1),Zero,c,size(c,1)) @@ -98,7 +105,10 @@ complex(kind=wp), intent(in) :: a(:,:), b(:,:) complex(kind=wp), intent(out) :: c(:,:) logical(kind=iwp), intent(in), optional :: transpA, transpB - integer(kind=iwp) :: k, k1, k2, m, n + integer(kind=iwp) :: k, k1, m, n +# ifdef _ADDITIONAL_RUNTIME_CHECK_ + integer(kind=iwp) :: k2 +# endif logical(kind=iwp) :: transpA_, transpB_ if (present(transpA)) then @@ -116,7 +126,9 @@ n = size(b,merge(1,2,transpB_)) ASSERT(n == size(c,2)) k1 = size(a,merge(1,2,transpA_)) +# ifdef _ADDITIONAL_RUNTIME_CHECK_ k2 = size(b,merge(2,1,transpB_)) +# endif ASSERT(k1 == k2) k = k1 call zgemm_(merge('C','N',transpA_),merge('C','N',transpB_),m,n,k,cOne,a,size(a,1),b,size(b,1),cZero,c,size(c,1)) diff -Nru openmolcas-22.02/src/ri_util/a_3c_qv_s.f openmolcas-22.10/src/ri_util/a_3c_qv_s.f --- openmolcas-22.02/src/ri_util/a_3c_qv_s.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/a_3c_qv_s.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Francesco Aquilante * -************************************************************************ - SUBROUTINE A_3C_Qv_s(A_3C,Qv,Rv,nMuNu,nI,nK,QMode) -************************************************************************ -* -* Author: F. Aquilante -* -************************************************************************ - Implicit Real*8 (a-h,o-z) - Real*8 A_3C(nMuNu,*), Qv(nI,nK), Rv(nMuNu,*) - Character*1 QMode -* - If (QMode.eq.'N') Then - - Call DGEMM_('N','N',nMuNu,nK,nI, - & 1.0d0,A_3C,nMuNu, - & Qv,nI, - & 0.0d0,Rv,nMuNu) - - ElseIf (QMode.eq.'T') Then - - Call DGEMM_('N','T',nMuNu,nI,nK, - & 1.0d0,A_3C,nMuNu, - & Qv,nI, - & 1.0d0,Rv,nMuNu) ! note that Rv is accumulated - - Else - - Call WarningMessage(2,'A_3C_Qv_s: illegal QMode!') - Call Abend() - EndIf -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/a_3c_qv_s.F90 openmolcas-22.10/src/ri_util/a_3c_qv_s.F90 --- openmolcas-22.02/src/ri_util/a_3c_qv_s.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/a_3c_qv_s.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,46 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Francesco Aquilante * +!*********************************************************************** + +subroutine A_3C_Qv_s(A_3C,Qv,Rv,nMuNu,nI,nK,QMode) +!*********************************************************************** +! * +! Author: F. Aquilante * +! * +!*********************************************************************** + +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nMuNu, nI, nK +real(kind=wp), intent(in) :: A_3C(nMuNu,*), Qv(nI,nK) +real(kind=wp), intent(inout) :: Rv(nMuNu,*) +character, intent(in) :: QMode + +if (QMode == 'N') then + + call DGEMM_('N','N',nMuNu,nK,nI,One,A_3C,nMuNu,Qv,nI,Zero,Rv,nMuNu) + +else if (QMode == 'T') then + + call DGEMM_('N','T',nMuNu,nI,nK,One,A_3C,nMuNu,Qv,nI,One,Rv,nMuNu) ! note that Rv is accumulated + +else + + call WarningMessage(2,'A_3C_Qv_s: illegal QMode!') + call Abend() +end if + +return + +end subroutine A_3C_Qv_s diff -Nru openmolcas-22.02/src/ri_util/bdshell.fh openmolcas-22.10/src/ri_util/bdshell.fh --- openmolcas-22.02/src/ri_util/bdshell.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/bdshell.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,12 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Integer iBDsh(MxShll*8) - Common /BDshell/ iBDsh diff -Nru openmolcas-22.02/src/ri_util/cd_ainv.f openmolcas-22.10/src/ri_util/cd_ainv.f --- openmolcas-22.02/src/ri_util/cd_ainv.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/cd_ainv.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,286 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine CD_AInv(A,n,AInV,Thr_CD) - Implicit Real*8 (a-h,o-z) -#include "real.fh" -#include "stdalloc.fh" - Real*8 A(n,n), AInv(n,n) - Real*8, Allocatable :: ADiag(:), QVec(:,:) - Integer, Allocatable :: iADiag(:) -#ifdef _ACCURACY_ - Real*8, Allocatable :: Tmp(:,:), Tmp2(:,:) -#endif -* - Call mma_allocate(ADiag,n,Label='ADiag') - Call mma_allocate(iADiag,n,Label='iADiag') -* - iSeed=77 - Lu_A=IsFreeUnit(iSeed) - Call DaName_MF_WA(Lu_A,'AMat09') -* - iDisk=0 - Call dDaFile(Lu_A,1,A,n**2,iDisk) -* -C Call RecPrt('A',' ',A,n,n) -* - iSeed=iSeed+1 - Lu_Q=IsFreeUnit(iSeed) - Call DaName_MF_WA(Lu_Q,'QMat09') -* - call dcopy_(n,A,n+1,ADiag,1) -* - Call CD_AInv_(n,m,ADiag,iADiag,Lu_A,Lu_Q,Thr_CD) -* - Call mma_deallocate(ADiag) - Call mma_deallocate(iADiag) -* - Call mma_allocate(QVec,n,m,Label='QVec') -* - iDisk=0 - Call dDaFile(Lu_Q,2,QVec,n*m,iDisk) -* -C Call RecPrt('QVec','(6G20.10)',QVec,n,m) - Call DGEMM_('N','T',n,n,m, - & One,QVec,n, - & QVec,n, - & Zerp,AInv,n) -C Call RecPrt('AInv',' ',AInv,n,n) - Call DaEras(Lu_Q) - Call mma_deallocate(QVec) -* * -************************************************************************ -* * -* Check the accuracy I-AA^1 -* -#ifdef _ACCURACY_ - Call mma_allocate(Tmp,n,n,Label='Tmp') -*--- - Tmp(:,:)=Zero -* I - call dcopy_(n,One,0,Tmp,n+1) -* I-AA^-1 - Call DGEMM_('N','N',n,n,n, - & -One,A,n, - & AInv,n, - & One,Tmp,n) - Call RecPrt('I-AA^-1','(6G20.12)',Tmp,n,n) -* - Call DGEMM_('N','N',n,n,n, - & One,A,n, - & AInv,n, - & Zero,Tmp,n) - - Call mma_allocate(Tmp2,n,n,Label='Tmp2') - Tmp2(:,:)=Zero - call dcopy_(n,One,0,Tmp2,n+1) - Call DGEMM_('N','N',n,n,n, - & -One,Tmp,n, - & Tmp,n, - & One,Tmp2,n) - Call RecPrt('I-AA^-1AA^-1','(6G20.12)',Tmp2,n,n) -*--- - Call mma_deallocate(Tmp2) - Call mma_deallocate(Tmp) -#endif -* * -************************************************************************ -* * - Return - End - Subroutine CD_AInv_(n,m,ADiag,iADiag,Lu_A,Lu_Q,Thr_CD) - Implicit Real*8 (a-h,o-z) -#include "stdalloc.fh" -#include "real.fh" - Real*8 ADiag(n) - Integer iADiag(n) - Logical Out_of_Core - - Real*8, Allocatable :: Scr(:), Z(:), X(:) - Real*8, Allocatable, Target :: Qm(:), Am(:), Q_k(:), A_k(:) - Real*8, Pointer :: Q_l(:)=>Null(), A_l(:)=>Null() -* - nScr=3*n - Call mma_maxDBLE(MaxMem) - lScr=Min(MaxMem,nScr) - Call mma_allocate(Scr,lScr,Label='Scr') -* - nDim=n -* - Thr=Thr_CD*1.0D-1 - Lu_Z=7 - Call DaName_MF_WA(Lu_Z,'ZMAT09') - Call Get_Pivot_idx(ADiag,nDim,nVec,Lu_A,Lu_Z,iADiag,Scr,lScr,Thr) - m=nVec - If (nDim.ne.nVec) Then - Write (6,*) - Write (6,*) 'Detected lin. dep. in the auxiliary basis' - Write (6,'(A,I6)')' # of aux. bfns before lin. dep. removal: ', - & nDim - Write (6,'(A,I6)')' # of aux. bfns after lin. dep. removal: ', - & nVec - End If -* - Call Pivot_Mat(nDim,nVec,Lu_A,Lu_Z,iADiag,Scr,lScr) -* - Call mma_deallocate(Scr) -* -************************************************************************ -* A-vectors are now on disk. Go ahead and compute the Q-vectors! -************************************************************************ -* - ThrQ=Thr_CD*1.0D-1 ! Threshold for Inv_Cho_Factor -* - nB=nVec - If (nB.eq.0) Go To 777 - nQm=nB*(nB+1)/2 -* - nXZ=nB - nQm_full= nB*(nB+1)/2 -* - Out_of_Core=2*nQm_full+5*nXZ.gt.MaxMem -* - If (Out_Of_Core) Then - mQm=(nQm*MaxMem-5*nXZ)/(2*nQm_full) - a=One - b=-Two*DBLE(mQm) - mB=INT(-a/Two + Sqrt( (a/Two)**2 - b )) - kQm=mB*(mB+1)/2 - If (kQm.gt.mQm) Then - Call WarningMessage(2,'Error in CD_AInv') - Write (6,*) 'kQm.gt.mQm!' - Write (6,*) 'MaxMem=',MaxMem - Write (6,*) 'nQm,mQm,kQm=',nQm,mQm,kQm - Write (6,*) 'nB,mB=',nB,mB - Call Abend() - End If - Else - mB = nB - kQm = nQm - End If -* - lQm=kQm - lAm=lQm -* - If (lQm.lt.1) Then - Call WarningMessage(2,'Error in CD_AInv') - Write (6,*) 'lQm.lt.1' - Call Abend() - End If -* -* Some of memory for scratch arrays for Inv_Cho_Factor -* Allocate memory for the A- and Q-vectors and initialize. -* - lScr=nXZ - Call mma_allocate(Scr,lScr,Label='Scr') - Call mma_allocate(Qm,lQm,Label='Qm') - Call mma_allocate(Am,lAm,Label='Am') - Call mma_allocate(A_k,nXZ,Label='A_k') - Call mma_allocate(Q_k,nXZ,Label='Q_k') - Call mma_allocate(X,nXZ,Label='X') - Call mma_allocate(Z,nXZ,Label='Z') -* - Am(:)=Zero - Qm(:)=Zero -* * -*----------------------------------------------------------------------* -* * -* Process the A_ks to generate Q_ks. -* - iAddr=0 - nMem=mB - Do kCol = 1, nB -* - iAddr_=iAddr - If (kCol.le.nMem) Then - iOff = (kCol-1)*kCol/2 -* Point to A_k in Am - A_l(1:kCol) => Am(iOff+1:iOff+kCol) - If (kCol.eq.1) Then - nAm=nMem*(nMem+1)/2 - Call dDaFile(Lu_Z,2,Am,nAm,iAddr_) - End If -* Point to Q_k in Qm - Q_l(1:kCol) => Qm(iOff+1:iOff+kCol) - Else If (kCol.gt.nMem) Then -* Use special scratch for A_k - A_l(1:kCol) => A_k(1:kCol) - Call dDaFile(Lu_Z,2,A_l,kCol,iAddr_) -* Use special scratch for Q_k - Q_l(1:kCol) => Q_k(1:kCol) - End If -* - LinDep=2 - Call Inv_Cho_Factor(A_l,kCol, - & Am,Qm,nMem, - & Lu_Z,Lu_Q, - & Scr,lScr, - & Z,X,ThrQ, - & Q_l,LinDep) -* - If (LinDep.ne.0) Then - Call WarningMessage(2,'Error in CD_AInv') - Write(6,*) 'Inv_Cho_Factor found linear dependence!' - Call Abend() - End If -* -* Write the new A/Q-vector to file -* - iAddr_=iAddr - If (kCol.eq.nMem) Then - nQm=kCol*(kCol+1)/2 - Call dDaFile(Lu_Q,1,Qm,nQm,iAddr ) - Call dDaFile(Lu_Z,1,Am,nQm,iAddr_) - Else If (kCol.gt.nMem) Then - Call dDaFile(Lu_Q,1,Q_l,kCol,iAddr ) - Call dDaFile(Lu_Z,1,A_l,kCol,iAddr_) - End If -* - End Do -* - Q_l=>Null() - A_l=>Null() - Call mma_deallocate(X) - Call mma_deallocate(Z) - Call mma_deallocate(Q_k) - Call mma_deallocate(A_k) - Call mma_deallocate(Am) - Call mma_deallocate(Qm) - Call mma_deallocate(Scr) - 777 Continue - Call DaEras(Lu_Z) -* * -*----------------------------------------------------------------------* -* * -* Sort the Q-matrix back to the original order. -* - Call mma_maxDBLE(MaxMem2) -* - nBfnTot=n - nBfn2=n**2 - lScr=Min(MaxMem2,Max(nBfn2,2*nBfnTot)) - Call mma_allocate(Scr,lScr,Label='Scr') -* - Call Restore_Mat(nDim,nVec,Lu_Q,Lu_A,iADiag,Scr,lScr,.true.) - Call DaEras(Lu_Q) - Lu_Q=Lu_A -* -* Note: after the 'Restore' call to Sort_mat, the Q-matrix is -* no longer stored as upper-triangular but as squared -* (zeros have been added because the corresponding argument -* is set to .true.). The column index is still pivoted. -* - Call mma_deallocate(Scr) -* * -************************************************************************ -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/ri_util/cd_ainv.F90 openmolcas-22.10/src/ri_util/cd_ainv.F90 --- openmolcas-22.02/src/ri_util/cd_ainv.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/cd_ainv.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,93 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine CD_AInv(A,n,AInV,Thr_CD) + +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: One +use Constants, only: Zero +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: n +real(kind=wp), intent(_IN_) :: A(n,n) +real(kind=wp), intent(out) :: AInv(n,n) +real(kind=wp), intent(in) :: Thr_CD +integer(kind=iwp) :: iDisk, Lu_A, Lu_Q, m +real(kind=wp), allocatable :: ADiag(:), QVec(:,:) +#ifdef _ACCURACY_ +real(kind=wp), allocatable :: Tmp(:,:), Tmp2(:,:) +#endif +integer(kind=iwp), external :: IsFreeUnit + +call mma_allocate(ADiag,n,Label='ADiag') + +Lu_A = IsFreeUnit(77) +call DaName_MF_WA(Lu_A,'AMat09') + +iDisk = 0 +call dDaFile(Lu_A,1,A,n**2,iDisk) + +!call RecPrt('A',' ',A,n,n) + +Lu_Q = IsFreeUnit(78) +call DaName_MF_WA(Lu_Q,'QMat09') + +call dcopy_(n,A,n+1,ADiag,1) + +call CD_AInv_Inner(n,m,ADiag,Lu_A,Lu_Q,Thr_CD) + +call mma_deallocate(ADiag) + +call mma_allocate(QVec,n,m,Label='QVec') + +iDisk = 0 +call dDaFile(Lu_Q,2,QVec,n*m,iDisk) + +!call RecPrt('QVec','(6G20.10)',QVec,n,m) +call DGEMM_('N','T',n,n,m,One,QVec,n,QVec,n,Zero,AInv,n) +!call RecPrt('AInv',' ',AInv,n,n) +call DaEras(Lu_Q) +call mma_deallocate(QVec) +! * +!*********************************************************************** +! * +! Check the accuracy I-AA^1 + +#ifdef _ACCURACY_ +call mma_allocate(Tmp,n,n,Label='Tmp') + +Tmp(:,:) = Zero +! I +call dcopy_(n,[One],0,Tmp,n+1) +! I-AA^-1 +call DGEMM_('N','N',n,n,n,-One,A,n,AInv,n,One,Tmp,n) +call RecPrt('I-AA^-1','(6G20.12)',Tmp,n,n) + +call DGEMM_('N','N',n,n,n,One,A,n,AInv,n,Zero,Tmp,n) + +call mma_allocate(Tmp2,n,n,Label='Tmp2') +Tmp2(:,:) = Zero +call dcopy_(n,[One],0,Tmp2,n+1) +call DGEMM_('N','N',n,n,n,-One,Tmp,n,Tmp,n,One,Tmp2,n) +call RecPrt('I-AA^-1AA^-1','(6G20.12)',Tmp2,n,n) + +call mma_deallocate(Tmp2) +call mma_deallocate(Tmp) +#endif +! * +!*********************************************************************** +! * +return + +end subroutine CD_AInv diff -Nru openmolcas-22.02/src/ri_util/cd_ainv_inner.F90 openmolcas-22.10/src/ri_util/cd_ainv_inner.F90 --- openmolcas-22.02/src/ri_util/cd_ainv_inner.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/cd_ainv_inner.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,205 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine CD_AInv_Inner(n,m,ADiag,Lu_A,Lu_Q,Thr_CD) + +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Half +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: n, Lu_A +integer(kind=iwp), intent(out) :: m +real(kind=wp), intent(inout) :: ADiag(n) +integer(kind=iwp), intent(inout) :: Lu_Q +real(kind=wp), intent(in) :: Thr_CD +integer(kind=iwp) :: iAddr, iAddr_, iOff, kCol, kQm, lAm, LinDep, lQm, lScr, Lu_Z, MaxMem, MaxMem2, mb, mQm, nAm, nB, nBfn2, & + nBfnTot, nDim, nMem, nQm, nQm_full, nScr, nVec, nXZ +real(kind=wp) :: a, b, Thr, ThrQ +logical(kind=iwp) :: Out_of_Core +integer(kind=iwp), allocatable :: iADiag(:) +real(kind=wp), allocatable :: Scr(:), Z(:), X(:) +real(kind=wp), allocatable, target :: Qm(:), Am(:), Q_k(:), A_k(:) +real(kind=wp), pointer :: Q_l(:), A_l(:) + +nScr = 3*n +call mma_maxDBLE(MaxMem) +lScr = min(MaxMem,nScr) +call mma_allocate(Scr,lScr,Label='Scr') +call mma_allocate(iADiag,n,Label='iADiag') + +nDim = n + +Thr = Thr_CD*0.1_wp +Lu_Z = 7 +call DaName_MF_WA(Lu_Z,'ZMAT09') +call Get_Pivot_idx(ADiag,nDim,nVec,Lu_A,Lu_Z,iADiag,Scr,lScr,Thr) +m = nVec +if (nDim /= nVec) then + write(u6,*) + write(u6,*) 'Detected lin. dep. in the auxiliary basis' + write(u6,'(A,I6)') ' # of aux. bfns before lin. dep. removal: ',nDim + write(u6,'(A,I6)') ' # of aux. bfns after lin. dep. removal: ',nVec +end if + +call Pivot_Mat(nDim,nVec,Lu_A,Lu_Z,iADiag,Scr,lScr) + +call mma_deallocate(Scr) + +!*********************************************************************** +! A-vectors are now on disk. Go ahead and compute the Q-vectors! +!*********************************************************************** + +ThrQ = Thr_CD*0.1_wp ! Threshold for Inv_Cho_Factor + +nB = nVec +if (nB /= 0) then + nQm = nTri_Elem(nB) + + nXZ = nB + nQm_full = nTri_Elem(nB) + + Out_of_Core = 2*nQm_full+5*nXZ > MaxMem + + if (Out_Of_Core) then + mQm = (nQm*MaxMem-5*nXZ)/(2*nQm_full) + a = One + b = -Two*real(mQm,kind=wp) + mB = int(-a*Half+sqrt((a*Half)**2-b)) + kQm = nTri_Elem(mB) + if (kQm > mQm) then + call WarningMessage(2,'Error in CD_AInv_Inner') + write(u6,*) 'kQm > mQm!' + write(u6,*) 'MaxMem=',MaxMem + write(u6,*) 'nQm,mQm,kQm=',nQm,mQm,kQm + write(u6,*) 'nB,mB=',nB,mB + call Abend() + end if + else + mB = nB + kQm = nQm + end if + + lQm = kQm + lAm = lQm + + if (lQm < 1) then + call WarningMessage(2,'Error in CD_AInv_Inner') + write(u6,*) 'lQm < 1' + call Abend() + end if + + ! Some of memory for scratch arrays for Inv_Cho_Factor + ! Allocate memory for the A- and Q-vectors and initialize. + + lScr = nXZ + call mma_allocate(Scr,lScr,Label='Scr') + call mma_allocate(Qm,lQm,Label='Qm') + call mma_allocate(Am,lAm,Label='Am') + call mma_allocate(A_k,nXZ,Label='A_k') + call mma_allocate(Q_k,nXZ,Label='Q_k') + call mma_allocate(X,nXZ,Label='X') + call mma_allocate(Z,nXZ,Label='Z') + + Am(:) = Zero + Qm(:) = Zero + ! * + !--------------------------------------------------------------------* + ! * + ! Process the A_ks to generate Q_ks. + + iAddr = 0 + nMem = mB + do kCol=1,nB + + iAddr_ = iAddr + if (kCol <= nMem) then + iOff = nTri_Elem(kCol-1) + ! Point to A_k in Am + A_l(1:kCol) => Am(iOff+1:iOff+kCol) + if (kCol == 1) then + nAm = nTri_Elem(nMem) + call dDaFile(Lu_Z,2,Am,nAm,iAddr_) + end if + ! Point to Q_k in Qm + Q_l(1:kCol) => Qm(iOff+1:iOff+kCol) + else if (kCol > nMem) then + ! Use special scratch for A_k + A_l(1:kCol) => A_k(1:kCol) + call dDaFile(Lu_Z,2,A_l,kCol,iAddr_) + ! Use special scratch for Q_k + Q_l(1:kCol) => Q_k(1:kCol) + end if + + LinDep = 2 + call Inv_Cho_Factor(A_l,kCol,Am,Qm,nMem,Lu_Z,Lu_Q,Scr,lScr,Z,X,ThrQ,Q_l,LinDep) + + if (LinDep /= 0) then + call WarningMessage(2,'Error in CD_AInv_Inner') + write(u6,*) 'Inv_Cho_Factor found linear dependence!' + call Abend() + end if + + ! Write the new A/Q-vector to file + + iAddr_ = iAddr + if (kCol == nMem) then + nQm = nTri_Elem(kCol) + call dDaFile(Lu_Q,1,Qm,nQm,iAddr) + call dDaFile(Lu_Z,1,Am,nQm,iAddr_) + else if (kCol > nMem) then + call dDaFile(Lu_Q,1,Q_l,kCol,iAddr) + call dDaFile(Lu_Z,1,A_l,kCol,iAddr_) + end if + + end do + + nullify(Q_l,A_l) + call mma_deallocate(X) + call mma_deallocate(Z) + call mma_deallocate(Q_k) + call mma_deallocate(A_k) + call mma_deallocate(Am) + call mma_deallocate(Qm) + call mma_deallocate(Scr) +end if +call DaEras(Lu_Z) +! * +!----------------------------------------------------------------------* +! * +! Sort the Q-matrix back to the original order. + +call mma_maxDBLE(MaxMem2) + +nBfnTot = n +nBfn2 = n**2 +lScr = min(MaxMem2,max(nBfn2,2*nBfnTot)) +call mma_allocate(Scr,lScr,Label='Scr') + +call Restore_Mat(nDim,nVec,Lu_Q,Lu_A,iADiag,Scr,lScr,.true.) +call DaEras(Lu_Q) +Lu_Q = Lu_A + +! Note: after the 'Restore' call to Sort_mat, the Q-matrix is +! no longer stored as upper-triangular but as squared +! (zeros have been added because the corresponding argument +! is set to .true.). The column index is still pivoted. + +call mma_deallocate(Scr) +call mma_deallocate(iADiag) +! * +!*********************************************************************** +!*********************************************************************** +! * +return + +end subroutine CD_AInv_Inner diff -Nru openmolcas-22.02/src/ri_util/cho_factor.f openmolcas-22.10/src/ri_util/cho_factor.f --- openmolcas-22.02/src/ri_util/cho_factor.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/cho_factor.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,220 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 2007, Francesco Aquilante * -* 2014, Thomas Bondo Pedersen * -************************************************************************ -* CHO_FACTOR -* -*> @brief -*> Evaluation of the Cholesky factor (\f$ Z \f$) of a SPD matrix (\f$ A \f$) -*> @author F. Aquilante (Jan. 2007) -*> @modified_by T.B. Pedersen (2014) Changed criterion for too negative diagonal -*> -*> @details -*> Evaluation of the Cholesky factor (\f$ Z \f$) of a SPD matrix (\f$ A \f$) -*> -*> \code -*> For k=1,dim(A) -*> Z(k,k) = sqrt( A(k,k) - sum_j Z(k,j)^2 ) -*> Z(i,k) = ( A(i,k) - sum_j Z(i,j)*Z(k,j) ) / Z(k,k) -*> \endcode -*> -*> The result is such that \f$ A \f$ is Cholesky decomposed as -*> -*> \f[ A = Z Z^\text{T} \f] -*> -*> The Cholesky factor is in general *NOT UNIQUE!!* -*> Therefore, and for stability reason, pivoting of the -*> initial matrix \f$ A \f$ would be advisable. -*> -*> @side_effects -*> \p A_k in output contains the \p kCol -th Cholesky vector. -*> In case of detected linear dependence, the \p A_k array -*> is returned as zeros! -*> -*> @note -*> Rectangular storage must be used for the \f$ Z \f$-matrix! -*> -*> @param[in,out] Diag Updated diagonal elements of \f$ A \f$ (subtraction done by this routine) -*> @param[in,out] A_k currently treated column of \f$ A \f$. In output contains the \p kCol -th Cholesky vector -*> @param[in] iD_A indices of the columns of \f$ A \f$ -*> @param[in] kCol index of the Cholesky vector -*> @param[in] nRow number of rows of \f$ A \f$ -*> @param[in] Zm in-core matrix whose columns are the Cholesky vectors -*> @param[in] nMem max number of columns of \p Zm kept in core -*> @param[in] lu_Z file unit where the \f$ Z \f$-matrix is stored -*> @param[in] Scr scratch space used for reading out-of-core columns of \p Zm -*> @param[in] lScr size of the scratch space (≥ \p nRow or ``0`` iff in-core) -*> @param[in] thr threshold for linear dependence -*> @param[out] lindep integer indicating detected linear dependence (= ``1`` iff found lin dep, else = ``0``) -************************************************************************ - SUBROUTINE CHO_FACTOR(Diag,A_k,iD_A,kCol,nRow,Zm,nMem,lu_Z,Scr, - & lScr,thr,lindep) - - Implicit Real*8 (a-h,o-z) - Integer iD_A(*), kCol, nRow, nMem, lu_Z, lScr, lindep - Real*8 Diag(*), A_k(*), Zm(nRow,*), Scr(*) -#include "warnings.h" - Parameter ( one = 1.0d0, zero = 0.0d0 , thr_neg=-1.0d-8) - -************************************************************************ - - If (thr .lt. zero) Then - Call WarningMessage(2,'Error in Cho_Factor') - write(6,*)'thr must be .ge. zero' - Call Quit(_RC_CHO_LOG_) - EndIf - - lindep = 0 - Dmax = Diag(iD_A(kCol)) ! pivoting done by the calling routine - xfac = one/sqrt(Abs(Dmax)) - - If (kCol .le. nMem) Then - - If (Dmax.ge.thr) Then -* -* Compute elements of the k-th Cholesky vector -* ------------------------------------------------------- -C Z(i,k) = A(i,k) - sum_j Z(k,j)*Z(i,j) -* ------------------------------------------------------- - Do j=1,kCol-1 - - fac = -Zm(iD_A(kCol),j) - Call dAXPY_(nRow,fac,Zm(1,j),1,A_k(1),1) - - End Do - -C-tbp: use thr_neg as threshold for too negative diagonal -C It should not depend on the decomposition threshold! -C ElseIf (Dmax.gt.zero .or. -Dmax.le.1.0d1*thr) Then - ElseIf (Dmax.gt.thr_neg) Then - - lindep = 1 - Call Fzero(A_k(1),nRow) - Return - - Else - - Call WarningMessage(2,'Error in Cho_Factor') - write(6,*)'CHO_FACTOR: too-negative diagonal.' - write(6,*)'CHO_FACTOR: current largest Diag = ',Dmax - Call Quit(_RC_CHO_RUN_) - - EndIf -* * -************************************************************************ -* * - Else ! the first nMem columns of Z are in memory -* * -************************************************************************ -* * - - If (lScr .lt. nRow) Then - Call WarningMessage(2,'Error in Cho_Factor') - write(6,*)'lScr must be .ge. nRow' - Call Quit(_RC_CHO_LOG_) - EndIf - - If (Dmax.ge.thr) Then -* -* Compute elements of the k-th Cholesky vector (in-core contrib.) -* ----------------------------------------------------------------- -C Z(i,k) = A(i,k) - sum_j Z(k,j)*Z(i,j) -* ----------------------------------------------------------------- - Do j=1,nMem - - fac = -Zm(iD_A(kCol),j) - Call dAXPY_(nRow,fac,Zm(1,j),1,A_k(1),1) - - End Do -* -* Batch for the out-of-core previous vectors -*-------------------------------------------- - kstep = lScr/nRow - - Do kdone=nMem+1,kCol-1,kStep - - lZdone = nRow*(kdone-1) - lZrem = nRow*(kCol-kdone) - lZread = Min(LZrem,nRow*kStep) - - Call ddafile(lu_Z,2,Scr(1),lZread,lZdone) ! read -* -* Compute elements of the k-th Cholesky vector (out-of-core contrib.) -* -------------------------------------------------------------------- -C Z(i,k) = A(i,k) - sum_j Z(k,j)*Z(i,j) -* -------------------------------------------------------------------- - Do j=1,lZread/nRow - kj = nRow*(j-1) - fac = -Scr(kj+iD_A(kCol)) - Call dAXPY_(nRow,fac,Scr(1+kj),1,A_k(1),1) - End Do - - End Do - -C-tbp: use thr_neg as threshold for too negative diagonal -C It should not depend on the decomposition threshold! -C-tbp ElseIf (Dmax.gt.zero .or. -Dmax.le.1.0d1*thr) Then - ElseIf (Dmax.gt.thr_neg) Then - - lindep = 1 - Call Fzero(A_k(1),nRow) - Return - - Else - - Call WarningMessage(2,'Error in Cho_Factor') - write(6,*)'CHO_FACTOR: too-negative diagonal.' - write(6,*)'CHO_FACTOR: current largest Diag = ',Dmax - Call Quit(_RC_CHO_RUN_) - - EndIf - - EndIf -* - A_k(iD_A(kCol)) = Dmax -* -* Scaling of the vector elements : Z(i,k) = Z(i,k)/Z(k,k) -* -------------------------------------------------------- - call dscal_(nRow,xfac,A_k(1),1) -* -* Explicit zeroing of the previously treated elements -* ---------------------------------------------------- - Do i=1,kCol-1 - A_k(iD_A(i)) = zero - End Do -* -* Update diagonal elements of the A matrix -* ---------------------------------------------------- -C A(i,i) = A(i,i) - Z(i,k)^2 ( i > k ) -* ---------------------------------------------------- - Do i=1,nRow - Diag(i) = Diag(i) - A_k(i)**2 - End Do - Diag(iD_A(kCol)) = zero ! explicit zeroing of the treated diagonal - -C-tbp: zero negative diagonal elements -C Stop if too negative! - Do i = 1,nRow - If (Diag(i).lt.zero) Then - If (Diag(i).le.thr_neg) Then - Call WarningMessage(2,'Error in Cho_Factor') - write(6,*)'CHO_FACTOR: too negative diagonal.' - write(6,*)'CHO_FACTOR: i,Diag(i)= ',i,Diag(i) - Call Quit(_RC_CHO_RUN_) - Else - Diag(i)=zero - End If - End If - End Do - - Return - End diff -Nru openmolcas-22.02/src/ri_util/cho_factor.F90 openmolcas-22.10/src/ri_util/cho_factor.F90 --- openmolcas-22.02/src/ri_util/cho_factor.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/cho_factor.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,229 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 2007, Francesco Aquilante * +! 2014, Thomas Bondo Pedersen * +!*********************************************************************** +! CHO_FACTOR +! +!> @brief +!> Evaluation of the Cholesky factor (\f$ Z \f$) of a SPD matrix (\f$ A \f$) +!> @author F. Aquilante (Jan. 2007) +!> @modified_by T.B. Pedersen (2014) Changed criterion for too negative diagonal +!> +!> @details +!> Evaluation of the Cholesky factor (\f$ Z \f$) of a SPD matrix (\f$ A \f$) +!> +!> \code +!> For k=1,dim(A) +!> Z(k,k) = sqrt( A(k,k) - sum_j Z(k,j)^2 ) +!> Z(i,k) = ( A(i,k) - sum_j Z(i,j)*Z(k,j) ) / Z(k,k) +!> \endcode +!> +!> The result is such that \f$ A \f$ is Cholesky decomposed as +!> +!> \f[ A = Z Z^\text{T} \f] +!> +!> The Cholesky factor is in general *NOT UNIQUE!!* +!> Therefore, and for stability reason, pivoting of the +!> initial matrix \f$ A \f$ would be advisable. +!> +!> @side_effects +!> \p A_k in output contains the \p kCol -th Cholesky vector. +!> In case of detected linear dependence, the \p A_k array +!> is returned as zeros! +!> +!> @note +!> Rectangular storage must be used for the \f$ Z \f$-matrix! +!> +!> @param[in,out] Diag Updated diagonal elements of \f$ A \f$ (subtraction done by this routine) +!> @param[in,out] A_k currently treated column of \f$ A \f$. In output contains the \p kCol -th Cholesky vector +!> @param[in] iD_A indices of the columns of \f$ A \f$ +!> @param[in] kCol index of the Cholesky vector +!> @param[in] nRow number of rows of \f$ A \f$ +!> @param[in] Zm in-core matrix whose columns are the Cholesky vectors +!> @param[in] nMem max number of columns of \p Zm kept in core +!> @param[in] lu_Z file unit where the \f$ Z \f$-matrix is stored +!> @param[out] Scr scratch space used for reading out-of-core columns of \p Zm +!> @param[in] lScr size of the scratch space (≥ \p nRow or ``0`` iff in-core) +!> @param[in] thr threshold for linear dependence +!> @param[out] lindep integer indicating detected linear dependence (= ``1`` iff found lin dep, else = ``0``) +!*********************************************************************** + +subroutine CHO_FACTOR(Diag,A_k,iD_A,kCol,nRow,Zm,nMem,lu_Z,Scr,lScr,thr,lindep) + +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +real(kind=wp), intent(inout) :: Diag(*), A_k(*) +integer(kind=iwp), intent(in) :: iD_A(*), kCol, nRow, nMem, lu_Z, lScr +real(kind=wp), intent(in) :: Zm(nRow,*), thr +real(kind=wp), intent(_OUT_) :: Scr(*) +integer(kind=iwp), intent(out) :: lindep +#include "warnings.h" +integer(kind=iwp) :: i, j, kdone, kj, kstep, lZdone, lZread, lZrem +real(kind=wp) :: Dmax, fac, xfac +real(kind=wp), parameter :: thr_neg = -1.0e-8_wp + +!*********************************************************************** + +if (thr < zero) then + call WarningMessage(2,'Error in Cho_Factor') + write(u6,*) 'thr must be >= zero' + call Quit(_RC_CHO_LOG_) +end if + +lindep = 0 +Dmax = Diag(iD_A(kCol)) ! pivoting done by the calling routine +xfac = one/sqrt(abs(Dmax)) + +if (kCol <= nMem) then + + if (Dmax >= thr) then + + ! Compute elements of the k-th Cholesky vector + !--------------------------------------------- + ! Z(i,k) = A(i,k) - sum_j Z(k,j)*Z(i,j) + !--------------------------------------------- + do j=1,kCol-1 + + fac = -Zm(iD_A(kCol),j) + A_k(1:nRow) = A_k(1:nRow)+fac*Zm(:,j) + + end do + + !-tbp: use thr_neg as threshold for too negative diagonal + ! It should not depend on the decomposition threshold! + !else if ((Dmax > Zero) .or. (-Dmax <= Ten*thr)) then + else if (Dmax > thr_neg) then + + lindep = 1 + A_k(1:nRow) = Zero + return + + else + + call WarningMessage(2,'Error in Cho_Factor') + write(u6,*) 'CHO_FACTOR: too-negative diagonal.' + write(u6,*) 'CHO_FACTOR: current largest Diag = ',Dmax + call Quit(_RC_CHO_RUN_) + + end if + ! * + !********************************************************************* + ! * +else ! the first nMem columns of Z are in memory + ! * + !********************************************************************* + ! * + + if (lScr < nRow) then + call WarningMessage(2,'Error in Cho_Factor') + write(u6,*) 'lScr must be >= nRow' + call Quit(_RC_CHO_LOG_) + end if + + if (Dmax >= thr) then + + ! Compute elements of the k-th Cholesky vector (in-core contrib.) + !---------------------------------------------------------------- + ! Z(i,k) = A(i,k) - sum_j Z(k,j)*Z(i,j) + !---------------------------------------------------------------- + do j=1,nMem + + fac = -Zm(iD_A(kCol),j) + A_k(1:nRow) = A_k(1:nRow)+fac*Zm(:,j) + + end do + + ! Batch for the out-of-core previous vectors + !------------------------------------------- + kstep = lScr/nRow + + do kdone=nMem+1,kCol-1,kStep + + lZdone = nRow*(kdone-1) + lZrem = nRow*(kCol-kdone) + lZread = min(LZrem,nRow*kStep) + + call ddafile(lu_Z,2,Scr,lZread,lZdone) ! read + + ! Compute elements of the k-th Cholesky vector (out-of-core contrib.) + !-------------------------------------------------------------------- + ! Z(i,k) = A(i,k) - sum_j Z(k,j)*Z(i,j) + !-------------------------------------------------------------------- + do j=1,lZread/nRow + kj = nRow*(j-1) + fac = -Scr(kj+iD_A(kCol)) + A_k(1:nRow) = A_k(1:nRow)+fac*Scr(kj+1:kj+nRow) + end do + + end do + + !-tbp: use thr_neg as threshold for too negative diagonal + ! It should not depend on the decomposition threshold! + !else if ((Dmax > Zero) .or. (-Dmax <= Ten*thr)) then + else if (Dmax > thr_neg) then + + lindep = 1 + A_k(1:nRow) = Zero + return + + else + + call WarningMessage(2,'Error in Cho_Factor') + write(u6,*) 'CHO_FACTOR: too-negative diagonal.' + write(u6,*) 'CHO_FACTOR: current largest Diag = ',Dmax + call Quit(_RC_CHO_RUN_) + + end if + +end if + +A_k(iD_A(kCol)) = Dmax + +! Scaling of the vector elements : Z(i,k) = Z(i,k)/Z(k,k) +! -------------------------------------------------------- +A_k(1:nRow) = xfac*A_k(1:nRow) + +! Explicit zeroing of the previously treated elements +! ---------------------------------------------------- +do i=1,kCol-1 + A_k(iD_A(i)) = zero +end do + +! Update diagonal elements of the A matrix +!------------------------------------------ +! A(i,i) = A(i,i) - Z(i,k)^2 ( i > k ) +!------------------------------------------ +Diag(1:nRow) = Diag(1:nRow)-A_k(1:nRow)**2 +Diag(iD_A(kCol)) = zero ! explicit zeroing of the treated diagonal + +!-tbp: zero negative diagonal elements +! Stop if too negative! +do i=1,nRow + if (Diag(i) < zero) then + if (Diag(i) <= thr_neg) then + call WarningMessage(2,'Error in Cho_Factor') + write(u6,*) 'CHO_FACTOR: too negative diagonal.' + write(u6,*) 'CHO_FACTOR: i,Diag(i)= ',i,Diag(i) + call Quit(_RC_CHO_RUN_) + else + Diag(i) = zero + end if + end if +end do + +return + +end subroutine CHO_FACTOR diff -Nru openmolcas-22.02/src/ri_util/cho_get_grad.f openmolcas-22.10/src/ri_util/cho_get_grad.f --- openmolcas-22.02/src/ri_util/cho_get_grad.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/cho_get_grad.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1626 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 2007, Francesco Aquilante * -* 2011, Thomas Bondo Pedersen * -************************************************************************ - SUBROUTINE CHO_GET_GRAD(irc,nDen, - & DLT,DLT2,MSQ, - & Txy,nTxy,ipTxy,DoExchange,lSA, - & nChOrb_,AOrb,nAorb,DoCAS, - & Estimate,Update, - & V_k,nV_k, - & U_k, - & Z_p_k,nZ_p_k, - & nnP,npos) - -************************************************************************ -* Author : F. Aquilante (visiting F. Illas group in Barcelona, Spain, * -* March-April 2007) * -* * -* Purpose: * -* Computation of the relevant quantities for RI * -* (and Cholesky) gradient code * -* * -* Coulomb term : V_k = sum_gd D_gd L_gd_k * -* * -* MP2 Coulomb term : U_k = sum_gd D(MP2)_gd L_gd_k * -* * -* Active term : Z_p_k = sum_xy T(xy,p) L_xy_k * -* * -* Inact. Exchange term: the quantity returned on disk is * -* * -* L_ij_k = sum_gd L_gd_k C_gi C_dj * -* * -* * -* Input: * -* * -* nDen : is equal to 2 iff Spin Unrestricted * -* 4 for SA-CASSCF, otherwise nDen=1 * -* * -* DLT : the LT-packed and symm. blocked one-body Dmat. * -* For spin unrestricted, Dmat = Dalpha + Dbeta * -* * -* DLT2: pointer to the LT-packed and symm. blocked * -* one body MP2 Dmat. * -* * -* MSQ : Cholesky MOs stored as C(a,i) symm. blocked * -* with blocks of dim. (nBas,nBas). These are * -* obtained from CD of the 1-particle DMAT. * -* (Two pointers iff alpha and beta spinorbitals) * -* * -* ipTxy : array (8,8) of pointers to the symm. blocks * -* of the Cholesky decomposed MO-basis (symmetrized) * -* 2-body density matrix * -* T(xy,p) : is stored by compound symmetry JSYM * -* the indices {xy} are stored as PACKED * -* (sym x.le.sym y) * -* * -* DoExchange : logical to activate exchange grad. components * -* * -* nChOrb_ : array of nr. of Cholesky orbitals in each irrep * -* * -* nAorb : array with # of Active orbitals in each irrep * -* (The same orbital basis * -* in which the 2-body Dmat is expressed) * -* * -* DoCAS : logical to activate CASSCF grad. components * -* * -* nScreen : See e.g. LK-screening docum. in SCF * -* or CASSCF read-input routines. Default = 10 * -* * -* dmpK : damping for the LK-screening threshold. Def: 1.0d0 * -* * -* Estimate : logical for LK-screening. Default: .false. * -* * -* Update : logical for LK-screening. Default: .true. * -* * -* nnP : array of # of Cholesky vectors for the dec 2-body * -* density matrix in each compound symmetry * -* * -* * -* Output: * -* irc : return code * -* * -* V_k : array Real*8 for the Coulomb interm. Size=NumCho(1) * -* * -* U_k : array Real*8 for the mp2 Coulomb interm. Size=NumCho(1)* -* * -* Z_p_k : array Real*8 for the active grad. components. * -* Must be zeroed by the calling routine. Stored * -* according to jSym and blocked after symm. blocks * -* of the active orbitals (square storage). * -* * -* Modifications: * -* August 24, 2011, Thomas Bondo Pedersen: * -* Allow zero vectors on a node. * -* * -************************************************************************ - use ChoArr, only: nBasSh, nDimRS - use ChoSwp, only: nnBstRSh, InfVec, IndRed - use Data_Structures, only: DSBA_Type, SBA_Type - use Data_Structures, only: NDSBA_Type - use Data_Structures, only: L_Full_Type - use Data_Structures, only: Allocate_DT, Deallocate_DT, - & Lab_Type - use ExTerm, only: VJ, iMP2prpt, CMOi -#if defined (_MOLCAS_MPP_) - Use Para_Info, Only: Is_Real_Par -#endif - Implicit Real*8 (a-h,o-z) - - Type (NDSBA_Type) DiaH - Type (DSBA_Type) DLT(5), DLT2, MSQ(nDen), AOrb(*) - Type (SBA_Type) Laq(1), Lxy - Type (L_Full_Type) L_Full - Type (Lab_Type) Lab - - Logical DoExchange,DoCAS,lSA - Logical DoScreen,Estimate,Update,BatchWarn - Integer nDen,nChOrb_(8,5),nAorb(8),nnP(8),nIt(5) - Integer ipTxy(8,8,2) - Integer kOff(8,5), LuRVec(8,3) - Integer npos(8,3) - Integer nnA(8,8), nInd - Real*8 tread(2),tcoul(2),tmotr(2),tscrn(2),tcasg(2),tmotr2(2) - - Real*8 Txy(nTxy),V_k(nV_k,*),Z_p_k(nZ_p_k,*), U_k(*) - - Character*6 Fname - Character*50 CFmt - Character(LEN=12), Parameter :: SECNAM = 'CHO_GET_GRAD' -#include "chotime.fh" -#include "real.fh" - - Logical, Parameter :: DoRead = .false. - Real*8, Parameter :: xone = -One -#include "itmax.fh" -#include "Molcas.fh" -#include "cholesky.fh" -#include "choorb.fh" -#include "stdalloc.fh" -#include "exterm.fh" -*#define _CD_TIMING_ -#ifdef _CD_TIMING_ -#include "temptime.fh" -#endif -#include "print.fh" -#include "bdshell.fh" - Logical add - Character mode - - Real*8, Allocatable:: Lrs(:,:), Drs(:,:), Diag(:), AbsC(:), - & SvShp(:,:), MLk(:), Ylk(:,:), Drs2(:,:) - Real*8, Allocatable, Target:: Yik(:) - Real*8, Pointer:: pYik(:,:)=>Null() - Integer, Allocatable:: kOffSh(:,:), iShp_rs(:), - & Indx(:,:), Indik(:,:) - Real*8, Allocatable, Target:: Aux(:) - Real*8, Pointer:: Lik(:,:), Rik(:) -#if defined (_MOLCAS_MPP_) - Real*8, Allocatable:: DiagJ(:) -#endif - - Type V2 - Real*8, Pointer :: A2(:,:)=>Null() - End Type V2 - - Type Special - Real*8, Allocatable:: A0(:) - Type (V2) :: Den(5) - End Type Special - - Type (Special), Target:: SumClk -* * -************************************************************************ -* * - MulD2h(i,j) = iEOR(i-1,j-1) + 1 - - iTri(i,j) = max(i,j)*(max(i,j)-3)/2 + i + j -* * -************************************************************************ -* * -* General Initialization * -* * -************************************************************************ - - iRout = 9 - iPrint = nPrint(iRout) - - CALL CWTIME(TOTCPU1,TOTWALL1) !start clock for total time - - ! 1 --> CPU 2 --> Wall - tread(:) = zero !time read vectors - tcoul(:) = zero !time for computing V_k - tcasg(:) = zero !time for computing Z_p_k - tmotr(:) = zero !time for the MO transf of vectors - tmotr2(:)= zero !time for the 2nd MO transf of vectors - tscrn(:) = zero !time for screening overhead - - IREDC = -1 ! unknown reduced set in core - - BatchWarn = .True. - nInd = 0 - - Call set_nnA(nSym,nAorb,nnA) -* -** Various offsets -* - MaxB=nBas(1) - DO ISYM=2,NSYM - MaxB=Max(MaxB,nBas(iSym)) - END DO -* -** -* - nI2t=0 - nItmx=0 - nIt(:) = 0 - Do jDen=nDen,1,-1 - kOff(1,jDen)=0 - nIt(jDen)=nChOrb_(1,jDen) - Do i=2,nSym - kOff(i,jDen)=nIt(jDen) - nIt(jDen)=nIt(jDen)+nChOrb_(i,jDen) - End Do - nI2t=nI2t+nIt(jDen) - nItmx=Max(nItmx,nIt(jDen)) - End Do -* -** Initialize pointers to avoid compiler warnings -* - thrv=0.0d0 - xtau=0.0d0 -* -** Construct iBDsh for later use -* - Do iSyma=1,nSym - LKsh=0 - Do iaSh=1,nShell - iSSa=nShell*(iSyma-1)+iaSh - iBDsh(iSSa) = LKsh - LKsh = LKsh + nBasSh(iSyma,iaSh) - End Do - End Do - -! iShp_rs - Call mma_allocate(iShp_rs,nnShl_tot,Label='iShp_rs') - -************************************************************************ -* * -* Initialize a few things for ij-screening //Jonas B * -* * -************************************************************************ - If(DoExchange) Then -* -** Define the screening thresholds -* - - Call Get_dScalar('Cholesky Threshold',ThrCom) - - tau = (ThrCom/DBLE(Max(1,nItmx)))*dmpK - - MaxRedT=MaxRed - Call GAIGOP_SCAL(MaxRedT,'+') - - If (Estimate) tau=tau/DBLE(MaxRedT) - xtau = sqrt(tau) - - NumVT=NumChT - Call GAIGOP_SCAL(NumVT,'+') -! Vector MO transformation screening thresholds - thrv = ( sqrt(ThrCom/DBLE(Max(1,nItmx)*NumVT)) )*dmpK - -#if defined (_MOLCAS_MPP_) - If (Is_Real_Par() .and. Update) Then - NNBSTMX=0 - Do i=1,nSym - NNBSTMX = Max(NNBSTMX,NNBSTR(i,1)) - End Do - Call mma_allocate(DiagJ,NNBSTMX,Label='DiagJ') - DiagJ(:)=Zero - EndIf -#endif - -* -** Read the diagonal integrals (stored as 1st red set) -* - Call mma_allocate(DIAG,NNBSTRT(1),Label='Diag') - If (Update) CALL CHO_IODIAG(DIAG,2) ! 2 means "read" - -* -** Allocate memory -* -! sqrt(D(a,b)) stored in full (squared) dim - Call Allocate_DT(DiaH,nBas,nBas,nSym) - DiaH%A0(:)=Zero - - Call mma_allocate(AbsC,MaxB,Label='AbsC') - - Call mma_allocate(Ylk,MaxB,nItmx,Label='Ylk') - - Call mma_allocate(Yik,nItmx**2,Label='Yik') ! Yi[k] vectors - -*used to be nShell*something -! ML[k] lists of largest elements in significant shells - Call mma_allocate(MLk,nShell,Label='MLk') - -! list of S:= sum_l abs(C(l)[k]) - Call mma_allocate(SumClk%A0,nShell*nI2t,Label='SumClk%A0') - iE = 0 - Do i=1,nDen - iS = iE + 1 - iE = iE + nShell*nIt(i) - SumClk%Den(i)%A2(1:nShell,1:nIt(i)) - & => SumClk%A0(iS:iE) - End Do - -* -** Indx and Indik must be stored for each density, symmetry, etc. -** in case of a batched procedure -* - Do jDen=1,nKvec - Do kSym=1,nSym - nInd = nInd + nChOrb_(kSym,jDen) - End Do - End Do - -! Index array - Call mma_allocate(Indx,[0,nShell],[1,nInd],Label='Indx') - - !Yi[k] Index array - Call mma_allocate(Indik,(nItmx+1)*nItmx+1,nInd,Label='Indik') - -! kOffSh - Call mma_allocate(kOffSh,nShell,nSym,Label='kOffSh') - -! shell-pair Frobenius norm of the vectors - Call mma_allocate(SvShp,nnShl,2,Label='SvShp') - -* -** Jonas - June 2010: -** allocate memory for rearranged CMO-matrix -* - Do i=1,nDen - Call Allocate_DT(CMOi(i),nChOrb_(:,i),nBas,nSym) - End Do - - nQoT = 0 -* -** Compute Shell Offsets ( MOs and transformed vectors) -* - Do iSyma=1,nSym - LKsh=0 - Do iaSh=1,nShell ! kOffSh(iSh,iSym) - - kOffSh(iaSh,iSyma) = LKsh - - LKsh = LKsh + nBasSh(iSyma,iaSh) - End Do - End Do - -* -** Determine S:= sum_l C(l)[k]^2 in each shell of C(a,k) -* - Do jDen=1,nDen - Do kSym=1,nSym - - Do jK=1,nChOrb_(kSym,jDen) - jK_a = jK + kOff(kSym,jDen) -* - Do iaSh=1,nShell - - iS = kOffSh(iaSh,kSym) + 1 - iE = kOffSh(iaSh,kSym) + nBasSh(kSym,iaSh) - - SKSh=Zero - Do ik=iS,iE - SKsh = SKsh - & + MSQ(jDen)%SB(kSym)%A2(ik,jK)**2 - End Do - - SumClk%Den(jDen)%A2(iaSh,jK_a) = SkSh - - End Do - End Do - End Do - End Do -* -** Reorder CMO-matrix, Needed to construct B-matrix for exchange -** Jonas - June 2010 -* - Do jDen = 1, nKdens - Do kSym = 1, nSym -* -**If the orbitals come from eigenvalue decomposition, change sign -* - If (lSA.and.(jDen.ge.3)) Then - npos2=npos(ksym,jDen-2) - Do jK = 1, nPos2 - Do jGam = 1, nBas(kSym) - CMOi(jDen)%SB(kSym)%A2(jK,jGam) = - & MSQ(jDen)%SB(kSym)%A2(jGam,jK) - End Do - End Do - Do jK = npos2+1,nChOrb_(kSym,jDen) - Do jGam = 1, nBas(kSym) - CMOi(jDen)%SB(kSym)%A2(jK,jGam) = - & - MSQ(jDen)%SB(kSym)%A2(jGam,jK) - End Do - End Do - Else -* - Do jK = 1, nChOrb_(kSym,jDen) - Do jGam = 1, nBas(kSym) - CMOi(jDen)%SB(kSym)%A2(jK,jGam) = - & MSQ(jDen)%SB(kSym)%A2(jGam,jK) - End Do - End Do - EndIf - End Do - End Do - End If -* -** Mapping shell pairs from the full to the reduced set -* - Call Mk_iShp_rs(iShp_rs,nShell) - -************************************************************************ -* * -* BIG LOOP OVER VECTORS SYMMETRY * -* * -************************************************************************ -* * - DO jSym=1,nSym -* * -************************************************************************ -* * - NumCV=NumCho(jSym) - Call GAIGOP_SCAL(NumCV,'max') - If (NumCV .lt. 1) Cycle -* -** offsets for active term -* - iOffZp=0 - Do j=1,jSym-1 - iOffZp = iOffZp + nnP(j)*NumCho(j) - End Do -* -** Open some files to store exchange auxiliary vectors -* - If (DoExchange) Then - iSeed=7 - Do i=1,nSym - k=muld2h(jSym,i) - LuRVec(i,1) = IsFreeUnit(iSeed) - Write(Fname,'(A4,I1,I1)') 'CHTA',i,k - Call DANAME_MF_WA(LuRVec(i,1),Fname) - iSeed=iSeed+1 - If (nKvec.ge.2) Then - LuRVec(i,2) = IsFreeUnit(iSeed) - Write(Fname,'(A4,I1,I1)') 'CHTB',i,k - Call DANAME_MF_WA(LuRVec(i,2),Fname) - iSeed=iSeed+1 - EndIf - Enddo - EndIf -* * -************************************************************************ -************************************************************************ -* * -* M E M O R Y M A N A G E M E N T S E C T I O N * -* * -************************************************************************ -************************************************************************ -* -* For one Cholesky vector, JNUM=1, compute the amount of memory -* needed for the various vectors. - - JNUM=1 - - ! L_Full - Call Allocate_DT(L_Full,nShell,iShp_rs,JNUM,JSYM,nSym, - & Memory=nL_Full) - ! Lab - mDen=1 - Call Allocate_DT(Lab,JNUM,nBasSh,nBas,nShell,nSym,mDen, - & Memory=nLab) - If (DoCas) Then - iSwap = 0 ! Lvb,J are returned - Call Allocate_DT(Laq(1),nAorb,nBas,JNUM,JSYM,nSym, - & iSwap,Memory=nLaq) - nLxy=0 - Do iMO1=1,nAdens - iSwap_lxy=5 - If (iMO1==2) iSwap_lxy=6 - Call Allocate_DT(Lxy,nAorb,nAorb,JNUM,JSYM,nSym, - & iSwap_lxy,Memory=nLxy0) - nLxy = Max( nLxy, nLxy0) - End Do - Else - nLaq=0 - nLxy=0 - End If -* -** compute memory needed to store at least 1 vector of JSYM -** and do all the subsequent calculations -* - nLik=0 - nRik=0 - do l=1,nSym - k=Muld2h(l,JSYM) - Do jDen=1,nDen - nRik=Max(nRik,nChOrb_(l,jDen)*nChOrb_(k,jDen)) - If (nChOrb_(k,jDen).gt.0) Then - nLik=Max(nLik,nChOrb_(l,jDen)) - EndIf - End Do - end do - - ! re-use memory for the active vec - LFMAX = Max( nLaq + nLxy, nL_Full + nRik + nLik + nLab ) -* * -************************************************************************ -************************************************************************ -* -* -** -* - iLoc = 3 ! use scratch location in reduced index arrays - - If (NumCho(jSym).lt.1) Then - JRED1 = 1 - JRED2 = 1 - Else - JRED1 = InfVec(1,2,jSym) ! red set of the 1st vec - JRED2 = InfVec(NumCho(jSym),2,jSym) !red set of the last -* !vec - End If -#if defined (_MOLCAS_MPP_) - myJRED1=JRED1 ! first red set present on this node - ntv0=0 -#endif - -c --- entire red sets range for parallel run - Call GAIGOP_SCAL(JRED1,'min') - Call GAIGOP_SCAL(JRED2,'max') -* -** MGD does it need to be so? -* - DoScreen=.True. - kscreen=1 -* * -************************************************************************ -* * - Do JRED=JRED1,JRED2 -* * -************************************************************************ -* * - - If (NumCho(jSym).lt.1) Then - iVrs=0 - nVrs=0 - Else - CALL Cho_X_nVecRS(JRED,JSYM,iVrs,nVrs) - End If - - If (nVrs.eq.0) GOTO 999 ! no vectors in that (jred,jsym) - - if (nVrs.lt.0) then - Write(6,*)SECNAM// - & ': Cho_X_nVecRS returned nVrs<0. STOP!' - call Abend() - endif - -c !set index arrays at iLoc - Call Cho_X_SetRed(irc,iLoc,JRED) - if(irc.ne.0)then - Write(6,*) SECNAM,': cho_X_setred non-zero return code.', - & ' rc= ',irc - call Abend() - endif - - IREDC=JRED - - nRS = nDimRS(JSYM,JRED) - - If(JSYM.eq.1)Then - Call mma_allocate(Drs,nRS,nJdens,Label='Drs') - Drs(:,:)=Zero - If(iMp2prpt.eq.2) Then - Call mma_allocate(Drs2,nRS,1,Label='Drs2') - End If - End If - - Call mma_maxDBLE(LWORK) - - nVec = Min(LWORK/(nRS+LFMAX),nVrs) - - If (nVec.lt.1) Then - WRITE(6,*) SECNAM//': Insufficient memory for batch' - WRITE(6,*) ' LWORK= ',LWORK - WRITE(6,*) ' min. mem. need= ',nRS+LFMAX - WRITE(6,*) ' jsym= ',jsym - WRITE(6,*) ' nRS = ',nRS - WRITE(6,*) ' LFMAX = ',LFMAX - WRITE(6,*) - WRITE(6,*) ' nL_Full = ',nL_Full - WRITE(6,*) ' nRik = ',nRik - WRITE(6,*) ' nLik = ',nLik - WRITE(6,*) ' nLab = ',nLab - WRITE(6,*) - WRITE(6,*) ' nLaq = ',nLaq - WRITE(6,*) ' nLxy = ',nLxy - irc = 33 - CALL Abend() - nBatch = -9999 ! dummy assignment - End If - -* * -************************************************************************ -* * - LREAD = nRS*nVec - - Call mma_allocate(Lrs,nRS,nVec,Label='Lrs') - - If(JSYM.eq.1)Then -C --- Transform the densities to reduced set storage - add = .false. - nMat=1 - Do jDen=1,nJdens - Call swap_full2rs(irc,iLoc,nRS,nMat,JSYM, - & DLT(jDen),Drs(:,jDen), - & add) - End Do - If(iMp2prpt .eq. 2) Then - Call swap_full2rs(irc,iLoc,nRS,nMat,JSYM, - & [DLT2],Drs2(:,1),add) - End If - EndIf -* -** BATCH over the vectors -* - - nBatch = (nVrs-1)/nVec + 1 - - If (BatchWarn .and. nBatch.gt.1) Then - If (iPrint.ge.6) Then - Write(6,'(20A3)')('---',I=1,20) - Write(6,*)' Batch procedure used.'// - & ' Increase memory if possible!' - Write(6,'(20A3)')('---',I=1,20) - Write(6,*) - Call XFlush(6) - End If - BatchWarn = .False. - EndIf - -* * -************************************************************************ -* * - DO iBatch=1,nBatch -* * -************************************************************************ -* * - If (iBatch.eq.nBatch) Then - JNUM = nVrs - nVec*(nBatch-1) - Else - JNUM = nVec - Endif - - JVEC = nVec*(iBatch-1) + iVrs - IVEC2 = JVEC - 1 + JNUM - - CALL CWTIME(TCR1,TWR1) - - CALL CHO_VECRD(Lrs,LREAD,JVEC,IVEC2,JSYM, - & NUMV,IREDC,MUSED) - - If (NUMV.le.0 .or.NUMV.ne.JNUM ) then - irc=77 - RETURN - End If - - CALL CWTIME(TCR2,TWR2) - tread(1) = tread(1) + (TCR2 - TCR1) - tread(2) = tread(2) + (TWR2 - TWR1) - -************************************************************************ -************************************************************************ -** ** -** ** -** Coulomb term ** -** V{#J} = sum_ab L(ab,{#J}) * D(ab) ** -** ** -** ** -************************************************************************ -************************************************************************ - If(JSYM.eq.1)Then - - CALL CWTIME(TCC1,TWC1) - -* -** Inactive Coulomb term -* - Do jden=1,nJdens - CALL DGEMV_('T',nRS,JNUM, - & One,Lrs,nRS, - & Drs(1,jden),1, - & zero,V_k(jVec,jDen),1) - End Do -* -** MP2 Coulomb term -* - If(iMp2prpt .eq. 2) Then - CALL DGEMV_('T',nRS,JNUM, - & One,Lrs,nRS, - & Drs2(:,1),1, - & zero,U_k(jVec),1) - End If -* - CALL CWTIME(TCC2,TWC2) - tcoul(1) = tcoul(1) + (TCC2 - TCC1) - tcoul(2) = tcoul(2) + (TWC2 - TWC1) - EndIf -************************************************************************ -************************************************************************ -** ** -** E X C H A N G E T E R M ** -** ** -** ** -************************************************************************ -************************************************************************ -* - If (DoExchange) Then - - CALL CWTIME(TCS1,TWS1) -************************************************************************ -* * -* 1) Screening * -* * -* Select only important ij pairs * -* For this, one computes the quantity * -* Yik = sum_mu_nu (mu nu | mu nu)^1/2 X_mu_i X_nu_k * -* with (mu nu | mu nu) = sum_J (L_mu_nu,J)^2 * -* * -* * -* a) Estimate the diagonals : D(mu,nu) = sum_J (L_mu_nu,J)^2 * -* * -************************************************************************ - If (Estimate) Then - - Call Fzero(Diag(1+iiBstR(jSym,1)), - & NNBSTR(jSym,1)) - - Do krs=1,nRS - - mrs = iiBstR(JSYM,iLoc) + krs - jrs = IndRed(mrs,iLoc) ! address in 1st red set - - Do jvc=1,JNUM - - Diag(jrs) = Diag(jrs) + Lrs(krs,jvc)**2 - - End Do - - End Do - - EndIf - - CALL CWTIME(TCS2,TWS2) - tscrn(1) = tscrn(1) + (TCS2 - TCS1) - tscrn(2) = tscrn(2) + (TWS2 - TWS1) -* * -************************************************************************ -************************************************************************ -************************************************************************ -* * - Call Allocate_DT(L_Full,nShell,iShp_rs,JNUM,JSYM,nSym) - Call mma_allocate(Aux,(nRik+nLik)*nVec,Label='Aux') - Call Allocate_DT(Lab,JNUM,nBasSh,nBas,nShell,nSym, - & mDen) - - CALL CWTIME(TCX1,TWX1) - -* -** Reorder vectors to Full-dimensions -** -** Vectors are returned in the storage LaJ,b with the restriction: -** Sym(a).ge.Sym(b) -** and blocked in shell pairs -* - CALL CHO_getShFull(Lrs,lread,JNUM,JSYM,IREDC,L_Full, - & SvShp,nnShl,iShp_rs,nnShl_tot) - - CALL CWTIME(TCX2,TWX2) - tmotr(1) = tmotr(1) + (TCX2 - TCX1) - tmotr(2) = tmotr(2) + (TWX2 - TWX1) - -************************************************************************ -* * -* 1) Screening * -* * -* b) DH(mu,nu)=sqrt(D(mu,nu)) * -* Only the symmetry blocks with compound symmetry JSYM * -* are computed * -* * -************************************************************************ - IF (DoScreen) THEN - - CALL CWTIME(TCS1,TWS1) - - ired1 = 1 ! location of the 1st red set - Call swap_tosqrt(irc,ired1,NNBSTRT(1),JSYM, - & DIAH,DIAG) - - CALL CWTIME(TCS2,TWS2) - tscrn(1) = tscrn(1) + (TCS2 - TCS1) - tscrn(2) = tscrn(2) + (TWS2 - TWS1) - - ENDIF - -************************************************************************ -* * -* 1) Screening * -* * -* c) 1st MO transformation of DH(mu,nu) * -* Y(mu)[k] = sum_nu DH(mu,nu) * |C(nu)[k]| * -* * -************************************************************************ - - nInd = 1 - Do jDen=1,nKvec -* -** Choose which MO sets on each side -* - iMOleft=jDen - iMOright=jDen - - n1 = nIt(iMOright) - n2 = nItMx - - pYik(1:n1,1:n2) => Yik(1:n1*n2) - - If (DoCAS.and.lSA) iMOright=jDen+2 -* - - Do kSym=1,nSym - - lSym=MulD2h(JSYM,kSym) - Nik= nChOrb_(kSym,iMOleft)*nChOrb_(lSym,iMOright) - nIJR(kSym,lSym,jDen) = Nik - nIJ1(kSym,lSym,jDen) = Nik - If ((JSYM.eq.1).and.iMOleft.eq.iMOright) - & Nik = nChOrb_(kSym,iMOleft) - & *(nChOrb_(kSym,iMOleft)+1)/2 - nIJ1(kSym,lSym,jDen) = Nik - - If (Nik.eq.0) Cycle - - iS = 1 - iE = nChOrb_(lSym,iMOright) * JNUM - - Lik(1:JNUM,1:nChOrb_(lSym,iMOright))=>Aux(iS:iE) - - iS = iE +1 - iE = iE + Nik * JNUM - - Rik(1:Nik*JNUM) => Aux(iS:iE) - - Rik(:)=Zero - - Do jK=1,nChOrb_(kSym,iMOleft) - jK_a = jK + kOff(kSym,iMOleft) - - Lik(:,:)=Zero - Lab%A0(1:nBas(lSym)*JNUM)=Zero - - IF (DoScreen .and. iBatch.eq.1) THEN - CALL CWTIME(TCS1,TWS1) -C------------------------------------------------------------------ -C --- Setup the screening -C------------------------------------------------------------------ - - Do ik=1,nBas(kSym) - AbsC(ik) = abs( - & MSQ(iMOleft)%SB(kSym)%A2(ik,jK) - & ) - End Do - - If (lSym.ge.kSym) Then - - mode='N' - n1 = nBas(lSym) - n2 = nBas(kSym) - - Else ! lSym<kSym - - mode='T' - n1 = nBas(kSym) - n2 = nBas(lSym) - - EndIf - - If (n1>0) - & CALL DGEMV_(Mode,n1,n2, - & ONE,DiaH%SB(lSym,kSym)%A2,n1, - & AbsC,1, - & ZERO,Ylk(1,jK_a),1) - -************************************************************************ -* * -* 1) Screening * -* * -* d) 2nd MO transformation of DH(mu,nu) * -* Y(i)[k] = sum_mu |C(mu)[i]| * Y(mu)[k] * -* * -************************************************************************ - - If ((kSym.ne.lSym).or. - & (iMOleft.ne.iMOright)) Then - iStart=1 - Else - iStart=jK - EndIf - - nQo=0 - Do i=iStart,nChOrb_(lSym,iMOright) - - Do ik=1,nBas(lSym) - AbsC(ik) = abs( - & MSQ(iMOright)%SB(lSym)%A2(ik,i) - & ) - End Do -* - pYik(i,jK_a)=ddot_(nBas(lSym), - & AbsC,1,Ylk,1) - - If (pYik(i,jK_a).ge.xtau) Then - nQo=nQo+1 - If((iBatch.ne.1) .or. - & (JRED.ne.1)) Go To 1111 - nQoT = nQoT + 1 - If((lSym .eq. kSym) .and. - & (i .ne. jK) .and. - & (iMOright.eq.iMOleft)) Then - nQoT = nQoT + 1 - End If - If((lSym.eq.kSym).and. - & (iMOleft.eq.iMOright)) Then - End If - 1111 Indik(1+nQo,nInd)=i - Endif - - End Do - Indik(1,nInd)=nQo -************************************************************************ -* * -* 1) Screening * -* * -* e) List the shells present in Y(l)[k] by the largest element * -* and sort the list * -* * -************************************************************************ - - Do ish=1,nShell - YshMax=zero - Do ibs=1,nBasSh(lSym,ish) - ibs_a = koffSh(ish,lSym)+ibs - YshMax = Max(YshMax,Ylk(ibs_a,1)) - End Do - MLk(ish) = YshMax - End Do - - Do ish=1,nShell - Indx(ish,nInd) = ish - End Do - -************************************************************************ -* * -* 1) Screening * -* * -* f) Screening * -* * -* Here we use a non-exact bound for the exchange matrix to achieve * -* linear scaling. The positive definiteness of the exchange matrix * -* combined with the structure of the density matrix makes this * -* bound acceptable and likely to be almost exact for what concerns * -* the exchange energy * -* * -* The exact bounds (quadratic scaling of the MO transformation) * -* would be * -* If (MLk(jml)*MLk(1).ge. tau) then * -* * -* * -************************************************************************ - - numSh=0 ! # of significant shells - jml=1 - Do while (jml.le.nShell) - - YMax=MLk(jml) - jmlmax=jml - - Do iml=jml+1,nShell ! get the max - If (MLk(iml).gt.YMax) then - YMax = MLk(iml) - jmlmax = iml - Endif - End Do - - If(jmlmax.ne.jml) then ! swap positions - xTmp = MLk(jml) - iTmp = Indx(jml,nInd) - MLk(jml) = YMax - Indx(jml,nInd)=Indx(jmlmax,nInd) - MLk(jmlmax) = xTmp - Indx(jmlmax,nInd) = iTmp - Endif - - If ( MLk(jml) .ge. xtau ) then - numSh = numSh + 1 - else - jml=nShell ! exit the loop - endif - - jml=jml+1 - - End Do - - Indx(0,nInd) = numSh - - CALL CWTIME(TCS2,TWS2) - tscrn(1) = tscrn(1) + (TCS2 - TCS1) - tscrn(2) = tscrn(2) + (TWS2 - TWS1) -C------------------------------------------------------------------ - ENDIF ! Screening setup - - - CALL CWTIME(TCT1,TWT1) - -************************************************************************ -* * -* E X C H A N G E T E R M * -* * -* 2) MO transformation * -* a) 1st half transformation * -* * -* Transform vectors for shells in the list ML[k] * -* * -* Screening based on the Frobenius norm: sqrt(sum_ij A(i,j)^2) * -* || La,J[k] || .le. || Lab,J || * || Cb[k] || * -* * -************************************************************************ - - Do iSh=1,Indx(0,nInd) - - iaSh = Indx(iSh,nInd) - - Lab%Keep(iaSh,1) = .True. - - ibcount=0 - - Do ibSh=1,nShell - - iOffShb = kOffSh(ibSh,kSym) - - iShp = iTri(iaSh,ibSh) - - If ( iShp_rs(iShp)<=0) Cycle - - If ( nnBstRSh(JSym,iShp_rs(iShp),iLoc)* - & nBasSh(lSym,iaSh)* - & nBasSh(kSym,ibSh) .gt. 0 - & .and. Sqrt(Abs(SumClk%Den(iMOleft)%A2(ibSh,jK_a)* - & SvShp(iShp_rs(iShp),1) )) - & .ge. thrv )Then - - ibcount = ibcount + 1 - - IF (lSym.ge.kSym) Then - - l1 = 1 - If (iaSh<ibSh) l1 = 2 - -* -** LaJ,[k] = sum_b L(aJ,b) * C(b)[k] -** ------------------------------------ -* - Mode='N' - n1 = nBasSh(lSym,iaSh)*JNUM - n2 = nBasSh(kSym,ibSh) - - Call DGEMV_(Mode,n1,n2, - & One,L_Full%SPB(lSym,iShp_rs(iShp),l1)%A21,n1, - & MSQ(iMOleft)%SB(kSym)%A2(iOffShb+1:,jK),1, - & ONE,Lab%SB(iaSh,lSym,1)%A,1) - - Else ! lSym < kSym - - l1 = 1 - If (ibSh<iaSh) l1 = 2 - -* -** LJa,[k] = sum_b L(b,Ja) * C(b)[k] -** ------------------------------------ -* - Mode='T' - n1 = nBasSh(kSym,ibSh) - n2 = JNUM*nBasSh(lSym,iaSh) - - Call DGEMV_(Mode,n1,n2, - & One,L_Full%SPB(kSym,iShp_rs(iShp),l1)%A12,n1, - & MSQ(iMOleft)%SB(kSym)%A2(iOffShb+1:,jK),1, - & ONE,Lab%SB(iaSh,lSym,1)%A,1) - - EndIf - - EndIf - - - End Do -* -** The following re-assignement is used later on to check if the -** iaSh vector LaJ[k] can be neglected because identically zero -* - - If (ibcount==0) Lab%Keep(iaSh,1) = .False. - - End Do - -************************************************************************ -* * -* 2) MO transformation * -* b) 2nd half transformation * -* * -************************************************************************ - - nQo=Indik(1,nInd) - - Do ir=1,nQo - - it = Indik(1+ir,nInd) - - Do iSh=1,Indx(0,nInd) - - iaSh = Indx(iSh,nInd) - - If (.NOT.Lab%Keep(iaSh,1)) Cycle - - iS = kOffsh(iaSh,lSym) + 1 -* - If (lSym.ge.kSym) Then - -** LJi[k] = sum_a LaJ[k] * Cai -** ------------------------------ -* - Mode='T' - n1 = nBasSh(lSym,iaSh) - n2 = JNUM - - Else ! lSym < kSym - -** LJi[k] = sum_a LJa[k] * Cai -** -------------------------------- -* - Mode='N' - n1 = JNUM - n2 = nBasSh(lSym,iaSh) - - EndIf - - CALL DGEMV_(Mode,n1,n2, - & One,Lab%SB(iaSh,lSym,1)%A,n1, - & MSQ(iMOright)%SB(lSym)%A2(iS:,it),1, - & one,Lik(:,it),1) - - End Do - -* -** Copy LJi[k] in the standard ordered matrix Lik,J -* - If ((jSym.eq.1).and. - & (iMOright.eq.iMOleft)) Then - itk = it*(it-1)/2 + jK - Else - itk = nChOrb_(lSym,iMOright)*(jK-1) + it - EndIf - call dcopy_(JNUM,Lik(:,it),1, - & Rik(itk:),Nik) - - End Do - - nInd = nInd+1 - - CALL CWTIME(TCT2,TWT2) - tmotr2(1) = tmotr(1) + (TCT2 - TCT1) - tmotr2(2) = tmotr(2) + (TWT2 - TWT1) - - - End Do ! loop over k MOs - - CALL CWTIME(TCT1,TWT1) - -************************************************************************ -* * -* 3) Put to disk * -* * -************************************************************************ - iAdr = Nik*(JVEC-1) - call DDAFILE(LuRVec(lSym,jDen),1,Rik, - & Nik*JNUM,iAdr) - - CALL CWTIME(TCT2,TWT2) - tmotr(1) = tmotr(1) + (TCT2 - TCT1) - tmotr(2) = tmotr(2) + (TWT2 - TWT1) - - End Do ! loop over MOs symmetry - - pYik=>Null() - - End Do ! loop over densities - - Call Deallocate_DT(Lab) - Call mma_deallocate(Aux) - Call Deallocate_DT(L_Full) -* * -************************************************************************ -************************************************************************ -************************************************************************ -* * - -C ************ END EXCHANGE CONTRIBUTION **************** - -C --- Diagonals updating. It only makes sense if Nscreen > 0 - - If (Update .and. Nscreen .gt. 0) Then - - CALL CWTIME(TCS1,TWS1) -C --------------------------------------------------------------------- -C --- update the diagonals : D(a,b) = D(a,b) - sum_J (Lab,J)^2 -C -C --- subtraction is done in the 1st reduced set -#if defined (_MOLCAS_MPP_) - If (Is_Real_Par()) then - - Do krs=1,nRS - mrs = iiBstR(JSYM,iLoc) + krs - jrs = IndRed(mrs,iLoc) - iiBstR(JSYM,1) - Do jvc=1,JNUM - DiagJ(jrs) = DiagJ(jrs) + Lrs(krs,jvc)**2 - End Do - End Do - - Else - - Do krs=1,nRS - mrs = iiBstR(JSYM,iLoc) + krs - jrs = IndRed(mrs,iLoc) ! address in 1st red set - Do jvc=1,JNUM - Diag(jrs) = Diag(jrs) - Lrs(krs,jvc)**2 - End Do - End Do - - EndIf - -#else - Do krs=1,nRS - mrs = iiBstR(JSYM,iLoc) + krs - jrs = IndRed(mrs,iLoc) ! address in 1st red set - Do jvc=1,JNUM - Diag(jrs) = Diag(jrs) - Lrs(krs,jvc)**2 - End Do - End Do -#endif - - CALL CWTIME(TCS2,TWS2) - tscrn(1) = tscrn(1) + (TCS2 - TCS1) - tscrn(2) = tscrn(2) + (TWS2 - TWS1) - - EndIf - - EndIf ! DoExchange - -************************************************************************ -************************************************************************ -** ** -** ** -** Active term ** -** ** -** ** -************************************************************************ -************************************************************************ - If (DoCAS) Then - - CALL CWTIME(TCC1,TWC1) -* -** Set up the skipping flags -** The memory used before for the full-dimension AO-vectors -** is now re-used to store half and full transformed -** vectors in the active space -* - iSwap = 0 ! Lvb,J are returned - Call Allocate_DT(Laq(1),nAorb,nBas,nVec,JSYM,nSym, - & iSwap) - - iMO2=1 - Do iMO1=1,nAdens - -* iSwap_lxy=5 diagonal blocks are triangular -* iSwap_lxy=6 diagonal blocks are square - iSwap_lxy=5 - If (iMO1==2) iSwap_lxy=6 - Call Allocate_DT(Lxy,nAorb,nAorb,nVec,JSYM,nSym, - & iSwap_lxy) - - -************************************************************************ -* * -* MO transformation of Cholesky vectors * -* * -* 1) Lvb,J = sum_a C(v,a) * Lab,J * -* * -************************************************************************ - - kMOs = 1 ! - nMOs = 1 ! Active MOs (1st set) - - CALL CHO_X_getVtra(irc,Lrs,LREAD,jVEC,JNUM, - & JSYM,iSwap,IREDC,nMOs,kMOs, - & Aorb(iMO1),Laq(1),DoRead) - - if (irc.ne.0) then - RETURN - endif - -************************************************************************ -* * -* MO transformation of Cholesky vectors * -* * -* 2) Lvw,J = sum_b Lvb,J * C(w,b) * -* * -************************************************************************ - If ((JSYM.eq.1).and.(iMO1.eq.iMO2)) Then - - Do iSymb=1,nSym - - NAv = nAorb(iSymb) - - If (NAv<1) Cycle - - Do JVC=1,JNUM - ! triangular blocks - CALL DGEMM_Tri('N','T',NAv,NAv,NBAS(iSymb), - & One,Laq(1)%SB(iSymb)%A3(:,:,JVC),NAv, - & Aorb(iMO2)%SB(iSymb)%A2,NAv, - & Zero,Lxy%SB(iSymb)%A2(:,JVC),NAv) - - End Do - - End Do - - Else - - Do iSymb=1,nSym - - iSymv = MulD2h(JSYM,iSymb) - NAv = nAorb(iSymv) - NAw = nAorb(iSymb) ! iSymb=iSymw - - If(NAv*NAw.ne.0 .and. iSymv.le.iSymb)Then - - Do JVC=1,JNUM - - ! square or rectangular blocks - CALL DGEMM_('N','T',NAv,NAw,NBAS(iSymb), - & One,Laq(1)%SB(iSymv)%A3(:,:,JVC),NAv, - & Aorb(iMO2)%SB(iSymb)%A2,NAw, - & Zero,Lxy%SB(iSymv)%A2(:,JVC),NAv) - - End Do - - EndIf - - End Do - - EndIf -************************************************************************ -* * -* Evaluation of the Z_p_k * -* * -* Z(p){#J} = sum_xy T(xy,p) * L(xy,{#J}) * -* * -* T(xy,p) : is stored by compound symmetry JSYM * -* the indices {xy} are stored as PACKED (sym x.le.sym y) * -* * -************************************************************************ - Do iTxy=iMO1,nAdens - iAvec=iMO1+iTxy-1 - Do iSymy=1,nSym - - iSymx=MulD2h(iSymy,JSYM) - - If (iSymx.le.iSymy.and.nnA(iSymx,iSymy).ne.0) - & Then - - ipZp = iOffZp + nnP(JSYM)*(JVEC-1) + 1 - - If (iMO1.eq.iMO2) Then - - ! diagonal symmetry blocks are triangular - CALL DGEMM_('T','N', - & nnP(JSYM),JNUM,nnA(iSymx,iSymy), - & ONE,Txy(ipTxy(iSymx,iSymy,iTxy)),nnP(JSYM), - & Lxy%SB(iSymx)%A2,nnA(iSymx,iSymy), - & ONE,Z_p_k(ipZp,iAvec),nnP(JSYM)) - - Else -*MGD may rearrange the loops - - Do i=1,nnP(JSYM) - ioff=ipTxy(iSymx,iSymy,iTxy)+ - & nnA(iSymx,iSymy)*(i-1) - - Do j=1,JNUM - -*MGD don't work with symmetry - temp=Zero - Do k=0,nAOrb(iSymx)-1 - Do l=0,k - temp=temp+0.5d0* - & Txy(ioff+k*(k+1)/2+l)* - & (Lxy%SB(iSymx)%A2(l+1+nAOrb(iSymx)*k,j)+ - & Lxy%SB(iSymx)%A2(k+1+nAOrb(iSymx)*l,j)) - End Do - End Do - - ij = ipZp -1 + i + nnP(JSYM)*(j-1) - - Z_p_k(ij,iAvec)= Z_p_k(ij,iAvec)+temp - - End Do ! j - End Do ! i - - EndIf - - Endif - - End Do - End Do - - Call Deallocate_DT(Lxy) - End Do - - CALL CWTIME(TCC2,TWC2) - tcasg(1) = tcasg(1) + (TCC2 - TCC1) - tcasg(2) = tcasg(2) + (TWC2 - TWC1) - - Call Deallocate_DT(Laq(1)) - - - EndIf ! DoCAS - -************************************************************************ -************************************************************************ -** ** -** Epilogue ** -** ** -************************************************************************ -************************************************************************ -* * - END DO ! end batch loop -* * -************************************************************************ -* * - -C --- free memory - Call mma_deallocate(Lrs) - - If(JSYM.eq.1)Then - Call mma_deallocate(Drs) - If(iMp2prpt .eq. 2) Call mma_deallocate(Drs2) - EndIf - -999 Continue - -C --- Screening control section - DoScreen = kscreen.eq.Nscreen - - if (.not.DoScreen) then - kscreen = kscreen + 1 - else - kscreen = 1 - endif - - If (DoExchange) Then -#if defined (_MOLCAS_MPP_) - If (Is_Real_Par() .and. Update .and. DoScreen) Then - Call GaDsum(DiagJ,nnBSTR(JSYM,1)) - Call Daxpy_(nnBSTR(JSYM,1),xone,DiagJ,1, - & Diag(1+iiBstR(JSYM,1)),1) - Call Fzero(DiagJ,nnBSTR(JSYM,1)) - EndIf -C--- Need to activate the screening to setup the contributing shell -C--- indices the first time the loop is entered .OR. whenever other nodes -C--- have performed screening in the meanwhile - If (Is_Real_Par().and..not.DoScreen.and.nVrs.eq.0) Then - ntv0=ntv0+1 - DoScreen = (JRED.lt.myJRED1 .or. ntv0.ge.Nscreen) - if (DoScreen) ntv0=0 - EndIf -#endif - EndIf -* * -************************************************************************ -* * - END DO ! loop over red sets -* * -************************************************************************ -* * - If (DoExchange) Then - Do jDen=1,nKvec - Do i=1,nSym - Call DACLOS(LuRVec(i,jDen)) - End Do - End Do - End If - -* * -************************************************************************ -* * - END DO ! loop over JSYM -* * -************************************************************************ -* * -* Allocate a field to be used by Compute_A_jk later -* since allocations cannot be made at that stage -* * -************************************************************************ -* * - If(DoExchange) THen - nIJMax = 0 - Do jDen = 1, nKvec - Do iSym1 = 1, nSym - Do iSym2 = 1, nSym - nIJMax = max(nIJMax,nIJR(iSym1,iSym2,jDen)) - End Do - End Do - End Do - ljkVec = 2*nIJMax - Call mma_allocate(VJ,ljkVec,Label='VJ') - End If - - Call mma_deallocate(iShp_rs) - If (DoExchange) Then - Call mma_deallocate(SvShp) - Call mma_deallocate(kOffSh) - Call mma_deallocate(Indik) - Call mma_deallocate(Indx) - Do i = 1, nDen - SumClk%Den(i)%A2=>Null() - End Do - Call mma_deallocate(SumClk%A0) - Call mma_deallocate(MLk) - Call mma_deallocate(Yik) - Call mma_deallocate(Ylk) - Call mma_deallocate(AbsC) - Call Deallocate_DT(DiaH) -#if defined (_MOLCAS_MPP_) - If (Is_Real_Par().and.Update)CALL mma_deallocate(DiagJ) -#endif - Call mma_deallocate(Diag) - EndIf - - - CALL CWTIME(TOTCPU2,TOTWALL2) - TOTCPU = TOTCPU2 - TOTCPU1 - TOTWALL= TOTWALL2 - TOTWALL1 -#ifdef _CD_TIMING_ - ChoGet_CPU = TOTCPU - ChoGet_Wall = TOTWALL -#endif -* * -*---- Write out timing information - if(timings)then - - CFmt='(2x,A)' - Write(6,*) - Write(6,CFmt)'Cholesky Gradients timing from '//SECNAM - Write(6,CFmt)'----------------------------------------' - Write(6,*) - Write(6,CFmt)'- - - - - - - - - - - - - - - - - - - - - - - - -' - Write(6,CFmt)' CPU WALL ' - Write(6,CFmt)'- - - - - - - - - - - - - - - - - - - - - - - - -' - - Write(6,'(2x,A26,2f10.2)')'READ VECTORS ' - & //' ',tread(1),tread(2) - Write(6,'(2x,A26,2f10.2)')'COULOMB CONTRIB. ' - & //' ',tcoul(1),tcoul(2) - Write(6,'(2x,A26,2f10.2)')'SCREENING OVERHEAD ' - & //' ',tscrn(1),tscrn(2) - Write(6,'(2x,A26,2f10.2)')'INACT MO-TRANSFORM VECTORS ' - & //' ',tmotr(1),tmotr(2) - Write(6,'(2x,A26,2f10.2)')'INACT MO-TRANSFORM VECTORS 2 ' - & //' ',tmotr2(1),tmotr2(2) - Write(6,'(2x,A26,2f10.2)')'ACTIVE CONTRIB. ' - & //' ',tcasg(1),tcasg(2) - Write(6,*) - Write(6,'(2x,A26,2f10.2)')'TOTAL ' - & //' ',TOTCPU,TOTWALL - Write(6,CFmt)'- - - - - - - - - - - - - - - - - - - - - - - - -' - Write(6,*) - - endif - - irc = 0 - - - Return - END diff -Nru openmolcas-22.02/src/ri_util/cho_get_grad.F90 openmolcas-22.10/src/ri_util/cho_get_grad.F90 --- openmolcas-22.02/src/ri_util/cho_get_grad.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/cho_get_grad.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,1493 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 2007, Francesco Aquilante * +! 2011, Thomas Bondo Pedersen * +!*********************************************************************** + +subroutine CHO_GET_GRAD(irc,nDen,DLT,DLT2,MSQ,Txy,nTxy,ipTxy,DoExchange,lSA,nChOrb_,AOrb,nAorb,DoCAS,Estimate,Update,V_k,nV_k,U_k, & + Z_p_k,nZ_p_k,nnP,npos) +!*********************************************************************** +! Author : F. Aquilante (visiting F. Illas group in Barcelona, Spain, * +! March-April 2007) * +! * +! Purpose: * +! Computation of the relevant quantities for RI * +! (and Cholesky) gradient code * +! * +! Coulomb term : V_k = sum_gd D_gd L_gd_k * +! * +! MP2 Coulomb term : U_k = sum_gd D(MP2)_gd L_gd_k * +! * +! Active term : Z_p_k = sum_xy T(xy,p) L_xy_k * +! * +! Inact. Exchange term: the quantity returned on disk is * +! * +! L_ij_k = sum_gd L_gd_k C_gi C_dj * +! * +! * +! Input: * +! * +! nDen : is equal to 2 iff Spin Unrestricted * +! 4 for SA-CASSCF, otherwise nDen=1 * +! * +! DLT : the LT-packed and symm. blocked one-body Dmat. * +! For spin unrestricted, Dmat = Dalpha + Dbeta * +! * +! DLT2: pointer to the LT-packed and symm. blocked * +! one body MP2 Dmat. * +! * +! MSQ : Cholesky MOs stored as C(a,i) symm. blocked * +! with blocks of dim. (nBas,nBas). These are * +! obtained from CD of the 1-particle DMAT. * +! (Two pointers iff alpha and beta spinorbitals) * +! * +! ipTxy : array (8,8) of pointers to the symm. blocks * +! of the Cholesky decomposed MO-basis (symmetrized) * +! 2-body density matrix * +! T(xy,p) : is stored by compound symmetry JSYM * +! the indices {xy} are stored as PACKED * +! (sym x <= sym y) * +! * +! DoExchange : logical to activate exchange grad. components * +! * +! nChOrb_ : array of nr. of Cholesky orbitals in each irrep * +! * +! nAorb : array with # of Active orbitals in each irrep * +! (The same orbital basis * +! in which the 2-body Dmat is expressed) * +! * +! DoCAS : logical to activate CASSCF grad. components * +! * +! nScreen : See e.g. LK-screening docum. in SCF * +! or CASSCF read-input routines. Default = 10 * +! * +! dmpK : damping for the LK-screening threshold. Def: 1.0 * +! * +! Estimate : logical for LK-screening. Default: .false. * +! * +! Update : logical for LK-screening. Default: .true. * +! * +! nnP : array of # of Cholesky vectors for the dec 2-body * +! density matrix in each compound symmetry * +! * +! * +! Output: * +! irc : return code * +! * +! V_k : array Real*8 for the Coulomb interm. Size=NumCho(1) * +! * +! U_k : array Real*8 for the mp2 Coulomb interm. Size=NumCho(1)* +! * +! Z_p_k : array Real*8 for the active grad. components. * +! Must be zeroed by the calling routine. Stored * +! according to jSym and blocked after symm. blocks * +! of the active orbitals (square storage). * +! * +! Modifications: * +! August 24, 2011, Thomas Bondo Pedersen: * +! Allow zero vectors on a node. * +! * +!*********************************************************************** + +use Index_Functions, only: iTri, nTri_Elem +use Symmetry_Info, only: Mul +use ChoArr, only: nBasSh, nDimRS +use ChoSwp, only: IndRed, InfVec, nnBstRSh +use Data_Structures, only: Allocate_DT, Deallocate_DT, DSBA_Type, L_Full_Type, Lab_Type, NDSBA_Type, SBA_Type, V2 +use RI_glob, only: CMOi, dmpK, iBDsh, iMP2prpt, nAdens, nIJ1, nIJR, nJdens, nKdens, nKvec, nScreen, VJ +#ifdef _MOLCAS_MPP_ +use Para_Info, only: Is_Real_Par +#endif +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Half +use Definitions, only: wp, iwp, u6, r8 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(out) :: irc +integer(kind=iwp), intent(in) :: nDen, nTxy, ipTxy(8,8,2), nChOrb_(8,5), nAorb(8), nV_k, nZ_p_k, nnP(8), npos(8,3) +type(DSBA_Type), intent(in) :: DLT(5), DLT2, MSQ(nDen), AOrb(*) +real(kind=wp), intent(in) :: Txy(nTxy) +logical(kind=iwp), intent(in) :: DoExchange, lSA, DoCAS, Estimate, Update +real(kind=wp), intent(_OUT_) :: V_k(nV_k,*), U_k(*) +real(kind=wp), intent(inout) :: Z_p_k(nZ_p_k,*) +#include "Molcas.fh" +#include "chotime.fh" +#include "cholesky.fh" +#include "choorb.fh" +#include "print.fh" +!#define _CD_TIMING_ +#ifdef _CD_TIMING_ +#include "temptime.fh" +#endif +integer(kind=iwp) :: i, iAdr, iaSh, iAvec, iBatch, ibcount, ibs, ibs_a, ibSh, iE, ij, ik, iLoc, iml, iMO1, iMO2, iMOleft, & + iMOright, ioff, iOffShb, iOffZp, iPrint, ipZp, ir, ired1, IREDC, iRout, iS, iSeed, ish, iShp, iSSa, iStart, & + iSwap, iSwap_lxy, ISYM, iSym1, iSym2, iSyma, iSymb, iSymv, iSymx, iSymy, it, itk, iTmp, iTxy, IVEC2, iVrs, j, & + jDen, jGam, jK, jK_a, jml, jmlmax, JNUM, JRED, JRED1, JRED2, jrs, jSym, jvc, JVEC, k, kMOs, kOff(8,5), krs, & + kscreen, kSym, l, l1, LFMAX, LKsh, LREAD, lSym, LuRVec(8,3), LWORK, MaxB, MaxRedT, mDen, mrs, MUSED, n1, n2, & + nAv, NAw, nBatch, nI2t, nIJMax, Nik, nInd, nIt(5), nItmx, nL_Full(2), nLab(2), nLaq, nLik, nLxy, nLxy0, nMat, & + nMOs, nnA(8,8), npos2, nQo, nQoT, nRik, nRS, NumCV, numSh, NUMV, NumVT, nVec, nVrs +#ifdef _MOLCAS_MPP_ +integer(kind=iwp) :: myJRED1, NNBSTMX, ntv0 +#endif +real(kind=wp) :: SkSh, tau, tcasg(2), TCC1, TCC2, tcoul(2), TCR1, TCR2, TCS1, TCS2, TCT1, TCT2, TCX1, TCX2, temp, thrv, tmotr(2), & + tmotr2(2), TOTCPU, TOTCPU1, TOTCPU2, TOTWALL, TOTWALL1, TOTWALL2, tread(2), tscrn(2), TWC1, TWC2, TWR1, TWR2, & + TWS1, TWS2, TWT1, TWT2, TWX1, TWX2, xtau, xTmp, YMax, YshMax +logical(kind=iwp) :: add, BatchWarn, DoScreen +character(len=50) :: CFmt +character(len=6) :: Fname +character :: mode +type(L_Full_Type) :: L_Full +type(Lab_Type) :: Lab +type(NDSBA_Type) :: DiaH +type(SBA_Type) :: Laq(1), Lxy +type(V2) :: SumClk(5) +integer(kind=iwp), allocatable :: Indik(:,:), Indx(:,:), iShp_rs(:), kOffSh(:,:) +real(kind=wp), allocatable :: AbsC(:), Diag(:), Drs(:,:), Drs2(:,:), Lrs(:,:), MLk(:), SvShp(:,:), Ylk(:,:) +#ifdef _MOLCAS_MPP_ +real(kind=wp), allocatable :: DiagJ(:) +#endif +real(kind=wp), allocatable, target :: Aux(:), Aux0(:), Yik(:) +real(kind=wp), pointer :: Lik(:,:), pYik(:,:), Rik(:) +logical(kind=iwp), parameter :: DoRead = .false. +character(len=*), parameter :: SECNAM = 'CHO_GET_GRAD' +integer(kind=iwp), external :: IsFreeUnit +real(kind=r8), external :: ddot_ + +! * +!*********************************************************************** +! * +! General Initialization * +! * +!*********************************************************************** +! * + +iRout = 9 +iPrint = nPrint(iRout) + +call CWTIME(TOTCPU1,TOTWALL1) !start clock for total time + +! 1 --> CPU 2 --> Wall +tread(:) = zero !time read vectors +tcoul(:) = zero !time for computing V_k +tcasg(:) = zero !time for computing Z_p_k +tmotr(:) = zero !time for the MO transf of vectors +tmotr2(:) = zero !time for the 2nd MO transf of vectors +tscrn(:) = zero !time for screening overhead + +IREDC = -1 ! unknown reduced set in core + +BatchWarn = .true. +nInd = 0 + +call set_nnA(nSym,nAorb,nnA) + +! Various offsets + +MaxB = nBas(1) +do ISYM=2,NSYM + MaxB = max(MaxB,nBas(iSym)) +end do + +nI2t = 0 +nItmx = 0 +nIt(:) = 0 +do jDen=nDen,1,-1 + kOff(1,jDen) = 0 + nIt(jDen) = nChOrb_(1,jDen) + do i=2,nSym + kOff(i,jDen) = nIt(jDen) + nIt(jDen) = nIt(jDen)+nChOrb_(i,jDen) + end do + nI2t = nI2t+nIt(jDen) + nItmx = max(nItmx,nIt(jDen)) +end do + +! Initialize pointers to avoid compiler warnings + +thrv = Zero +xtau = Zero + +! Construct iBDsh for later use + +call mma_allocate(iBDsh,nShell*nSym,label='iBDsh') +do iSyma=1,nSym + LKsh = 0 + do iaSh=1,nShell + iSSa = nShell*(iSyma-1)+iaSh + iBDsh(iSSa) = LKsh + LKsh = LKsh+nBasSh(iSyma,iaSh) + end do +end do + +! iShp_rs +call mma_allocate(iShp_rs,nnShl_tot,Label='iShp_rs') + +!*********************************************************************** +! * +! Initialize a few things for ij-screening //Jonas B * +! * +!*********************************************************************** +if (DoExchange) then + + ! Define the screening thresholds + + call Get_dScalar('Cholesky Threshold',ThrCom) + + tau = (ThrCom/real(max(1,nItmx),kind=wp))*dmpK + + MaxRedT = MaxRed + call GAIGOP_SCAL(MaxRedT,'+') + + if (Estimate) tau = tau/real(MaxRedT,kind=wp) + xtau = sqrt(tau) + + NumVT = NumChT + call GAIGOP_SCAL(NumVT,'+') + ! Vector MO transformation screening thresholds + thrv = (sqrt(ThrCom/real(max(1,nItmx)*NumVT,kind=wp)))*dmpK + +# ifdef _MOLCAS_MPP_ + if (Is_Real_Par() .and. Update) then + NNBSTMX = 0 + do i=1,nSym + NNBSTMX = max(NNBSTMX,NNBSTR(i,1)) + end do + call mma_allocate(DiagJ,NNBSTMX,Label='DiagJ') + DiagJ(:) = Zero + end if +# endif + + ! Read the diagonal integrals (stored as 1st red set) + + call mma_allocate(DIAG,NNBSTRT(1),Label='Diag') + if (Update) call CHO_IODIAG(DIAG,2) ! 2 means "read" + + + ! Allocate memory + + ! sqrt(D(a,b)) stored in full (squared) dim + call Allocate_DT(DiaH,nBas,nBas,nSym) + DiaH%A0(:) = Zero + + call mma_allocate(AbsC,MaxB,Label='AbsC') + + call mma_allocate(Ylk,MaxB,nItmx,Label='Ylk') + + call mma_allocate(Yik,nItmx**2,Label='Yik') ! Yi[k] vectors + + ! used to be nShell*something + ! ML[k] lists of largest elements in significant shells + call mma_allocate(MLk,nShell,Label='MLk') + + ! list of S:= sum_l abs(C(l)[k]) + call mma_allocate(Aux0,nShell*nI2t,Label='Aux0') + iE = 0 + do i=1,nDen + iS = iE+1 + iE = iE+nShell*nIt(i) + SumClk(i)%A(1:nShell,1:nIt(i)) => Aux0(iS:iE) + end do + + ! Indx and Indik must be stored for each density, symmetry, etc. + ! in case of a batched procedure + do jDen=1,nKvec + do kSym=1,nSym + nInd = nInd+nChOrb_(kSym,jDen) + end do + end do + + ! Index array + call mma_allocate(Indx,[0,nShell],[1,nInd],Label='Indx') + + ! Yi[k] Index array + call mma_allocate(Indik,(nItmx+1)*nItmx+1,nInd,Label='Indik') + + ! kOffSh + call mma_allocate(kOffSh,nShell,nSym,Label='kOffSh') + + ! shell-pair Frobenius norm of the vectors + call mma_allocate(SvShp,nnShl,2,Label='SvShp') + + ! Jonas - June 2010: + ! allocate memory for rearranged CMO-matrix + + do i=1,nDen + call Allocate_DT(CMOi(i),nChOrb_(:,i),nBas,nSym) + end do + + nQoT = 0 + + ! Compute Shell Offsets ( MOs and transformed vectors) + + do iSyma=1,nSym + LKsh = 0 + do iaSh=1,nShell ! kOffSh(iSh,iSym) + + kOffSh(iaSh,iSyma) = LKsh + + LKsh = LKsh+nBasSh(iSyma,iaSh) + end do + end do + + ! Determine S:= sum_l C(l)[k]^2 in each shell of C(a,k) + + do jDen=1,nDen + do kSym=1,nSym + + do jK=1,nChOrb_(kSym,jDen) + jK_a = jK+kOff(kSym,jDen) + + do iaSh=1,nShell + + iS = kOffSh(iaSh,kSym)+1 + iE = kOffSh(iaSh,kSym)+nBasSh(kSym,iaSh) + + SKSh = Zero + do ik=iS,iE + SKsh = SKsh+MSQ(jDen)%SB(kSym)%A2(ik,jK)**2 + end do + + SumClk(jDen)%A(iaSh,jK_a) = SkSh + + end do + end do + end do + end do + + ! Reorder CMO-matrix, Needed to construct B-matrix for exchange + ! Jonas - June 2010 + + do jDen=1,nKdens + do kSym=1,nSym + + ! If the orbitals come from eigenvalue decomposition, change sign + + if (lSA .and. (jDen >= 3)) then + npos2 = npos(ksym,jDen-2) + do jK=1,nPos2 + do jGam=1,nBas(kSym) + CMOi(jDen)%SB(kSym)%A2(jK,jGam) = MSQ(jDen)%SB(kSym)%A2(jGam,jK) + end do + end do + do jK=npos2+1,nChOrb_(kSym,jDen) + do jGam=1,nBas(kSym) + CMOi(jDen)%SB(kSym)%A2(jK,jGam) = -MSQ(jDen)%SB(kSym)%A2(jGam,jK) + end do + end do + else + + do jK=1,nChOrb_(kSym,jDen) + do jGam=1,nBas(kSym) + CMOi(jDen)%SB(kSym)%A2(jK,jGam) = MSQ(jDen)%SB(kSym)%A2(jGam,jK) + end do + end do + end if + end do + end do +end if + +! Mapping shell pairs from the full to the reduced set + +call Mk_iShp_rs(iShp_rs,nShell) + +! * +!*********************************************************************** +! * +! BIG LOOP OVER VECTORS SYMMETRY * +! * +!*********************************************************************** +! * +do jSym=1,nSym + ! * + !********************************************************************* + ! * + NumCV = NumCho(jSym) + call GAIGOP_SCAL(NumCV,'max') + if (NumCV < 1) cycle + + ! offsets for active term + + iOffZp = 0 + do j=1,jSym-1 + iOffZp = iOffZp+nnP(j)*NumCho(j) + end do + + ! Open some files to store exchange auxiliary vectors + + if (DoExchange) then + iSeed = 7 + do i=1,nSym + k = Mul(jSym,i) + LuRVec(i,1) = IsFreeUnit(iSeed) + write(Fname,'(A4,I1,I1)') 'CHTA',i,k + call DANAME_MF_WA(LuRVec(i,1),Fname) + iSeed = iSeed+1 + if (nKvec >= 2) then + LuRVec(i,2) = IsFreeUnit(iSeed) + write(Fname,'(A4,I1,I1)') 'CHTB',i,k + call DANAME_MF_WA(LuRVec(i,2),Fname) + iSeed = iSeed+1 + end if + end do + end if + ! * + !********************************************************************* + !********************************************************************* + ! * + ! M E M O R Y M A N A G E M E N T S E C T I O N * + ! * + !********************************************************************* + !********************************************************************* + ! + ! For one Cholesky vector, JNUM=1, compute the amount of memory + ! needed for the various vectors. + + JNUM = 1 + + ! L_Full + call Allocate_DT(L_Full,nShell,iShp_rs,JNUM,JSYM,nSym,Memory=nL_Full) + ! Lab + mDen = 1 + call Allocate_DT(Lab,JNUM,nBasSh,nBas,nShell,nSym,mDen,Memory=nLab) + if (DoCas) then + iSwap = 0 ! Lvb,J are returned + call Allocate_DT(Laq(1),nAorb,nBas,JNUM,JSYM,nSym,iSwap,Memory=nLaq) + nLxy = 0 + do iMO1=1,nAdens + iSwap_lxy = 5 + if (iMO1 == 2) iSwap_lxy = 6 + call Allocate_DT(Lxy,nAorb,nAorb,JNUM,JSYM,nSym,iSwap_lxy,Memory=nLxy0) + nLxy = max(nLxy,nLxy0) + end do + else + nLaq = 0 + nLxy = 0 + end if + + ! compute memory needed to store at least 1 vector of JSYM + ! and do all the subsequent calculations + + nLik = 0 + nRik = 0 + do l=1,nSym + k = Mul(l,JSYM) + do jDen=1,nDen + nRik = max(nRik,nChOrb_(l,jDen)*nChOrb_(k,jDen)) + if (nChOrb_(k,jDen) > 0) then + nLik = max(nLik,nChOrb_(l,jDen)) + end if + end do + end do + + ! re-use memory for the active vec + LFMAX = max(nLaq+nLxy,nL_Full(1)+nRik+nLik+nLab(1)) + ! * + !********************************************************************* + !********************************************************************* +! * + + iLoc = 3 ! use scratch location in reduced index arrays + + if (NumCho(jSym) < 1) then + JRED1 = 1 + JRED2 = 1 + else + JRED1 = InfVec(1,2,jSym) ! red set of the 1st vec + JRED2 = InfVec(NumCho(jSym),2,jSym) ! red set of the last vec + end if +# ifdef _MOLCAS_MPP_ + myJRED1 = JRED1 ! first red set present on this node + ntv0 = 0 +# endif + + ! entire red sets range for parallel run + call GAIGOP_SCAL(JRED1,'min') + call GAIGOP_SCAL(JRED2,'max') + + ! MGD does it need to be so? + + DoScreen = .true. + kscreen = 1 + ! * + !********************************************************************* + ! * + do JRED=JRED1,JRED2 + ! * + !******************************************************************* + ! * + + if (NumCho(jSym) < 1) then + iVrs = 0 + nVrs = 0 + else + call Cho_X_nVecRS(JRED,JSYM,iVrs,nVrs) + end if + + if (nVrs /= 0) then ! some vector in that (jred,jsym) + + if (nVrs < 0) then + write(u6,*) SECNAM//': Cho_X_nVecRS returned nVrs<0. STOP!' + call Abend() + end if + + ! set index arrays at iLoc + call Cho_X_SetRed(irc,iLoc,JRED) + if (irc /= 0) then + write(u6,*) SECNAM,': cho_X_setred non-zero return code. rc= ',irc + call Abend() + end if + + IREDC = JRED + + nRS = nDimRS(JSYM,JRED) + + if (JSYM == 1) then + call mma_allocate(Drs,nRS,nJdens,Label='Drs') + Drs(:,:) = Zero + if (iMp2prpt == 2) then + call mma_allocate(Drs2,nRS,1,Label='Drs2') + end if + end if + + call mma_maxDBLE(LWORK) + + nVec = min((LWORK-nL_Full(2)-nLab(2))/(nRS+LFMAX),nVrs) + + if (nVec < 1) then + write(u6,*) SECNAM//': Insufficient memory for batch' + write(u6,*) ' LWORK= ',LWORK + write(u6,*) ' min. mem. need= ',nRS+LFMAX + write(u6,*) ' jsym= ',jsym + write(u6,*) ' nRS = ',nRS + write(u6,*) ' LFMAX = ',LFMAX + write(u6,*) + write(u6,*) ' nL_Full = ',nL_Full + write(u6,*) ' nRik = ',nRik + write(u6,*) ' nLik = ',nLik + write(u6,*) ' nLab = ',nLab + write(u6,*) + write(u6,*) ' nLaq = ',nLaq + write(u6,*) ' nLxy = ',nLxy + irc = 33 + call Abend() + nBatch = -9999 ! dummy assignment + end if + + ! * + !***************************************************************** + ! * + LREAD = nRS*nVec + + call mma_allocate(Lrs,nRS,nVec,Label='Lrs') + + if (JSYM == 1) then + ! Transform the densities to reduced set storage + add = .false. + nMat = 1 + do jDen=1,nJdens + call swap_full2rs(irc,iLoc,nRS,nMat,JSYM,DLT(jDen),Drs(:,jDen),add) + end do + if (iMp2prpt == 2) then + call swap_full2rs(irc,iLoc,nRS,nMat,JSYM,[DLT2],Drs2(:,1),add) + end if + end if + + ! BATCH over the vectors + + nBatch = (nVrs-1)/nVec+1 + + if (BatchWarn .and. (nBatch > 1)) then + if (iPrint >= 6) then + write(u6,'(20A3)') ('---',I=1,20) + write(u6,*) ' Batch procedure used. Increase memory if possible!' + write(u6,'(20A3)') ('---',I=1,20) + write(u6,*) + call XFlush(u6) + end if + BatchWarn = .false. + end if + + ! * + !***************************************************************** + ! * + do iBatch=1,nBatch + ! * + !*************************************************************** + ! * + if (iBatch == nBatch) then + JNUM = nVrs-nVec*(nBatch-1) + else + JNUM = nVec + end if + + JVEC = nVec*(iBatch-1)+iVrs + IVEC2 = JVEC-1+JNUM + + call CWTIME(TCR1,TWR1) + + call CHO_VECRD(Lrs,LREAD,JVEC,IVEC2,JSYM,NUMV,IREDC,MUSED) + + if ((NUMV <= 0) .or. (NUMV /= JNUM)) then + irc = 77 + return + end if + + call CWTIME(TCR2,TWR2) + tread(1) = tread(1)+(TCR2-TCR1) + tread(2) = tread(2)+(TWR2-TWR1) + + !*************************************************************** + !*************************************************************** + !** ** + !** Coulomb term ** + !** V{#J} = sum_ab L(ab,{#J}) * D(ab) ** + !** ** + !*************************************************************** + !*************************************************************** + if (JSYM == 1) then + + call CWTIME(TCC1,TWC1) + + ! Inactive Coulomb term + + do jden=1,nJdens + call DGEMV_('T',nRS,JNUM,One,Lrs,nRS,Drs(1,jden),1,zero,V_k(jVec,jDen),1) + end do + + ! MP2 Coulomb term + + if (iMp2prpt == 2) then + call DGEMV_('T',nRS,JNUM,One,Lrs,nRS,Drs2(:,1),1,zero,U_k(jVec),1) + end if + + call CWTIME(TCC2,TWC2) + tcoul(1) = tcoul(1)+(TCC2-TCC1) + tcoul(2) = tcoul(2)+(TWC2-TWC1) + end if + !*************************************************************** + !*************************************************************** + !** ** + !** E X C H A N G E T E R M ** + !** ** + !*************************************************************** + !*************************************************************** + + if (DoExchange) then + + call CWTIME(TCS1,TWS1) + !************************************************************* + ! * + ! 1) Screening * + ! * + ! Select only important ij pairs * + ! For this, one computes the quantity * + ! Yik = sum_mu_nu (mu nu | mu nu)^1/2 X_mu_i X_nu_k * + ! with (mu nu | mu nu) = sum_J (L_mu_nu,J)^2 * + ! * + ! * + ! a) Estimate the diagonals: * + ! D(mu,nu) = sum_J (L_mu_nu,J)^2 * + ! * + !************************************************************* + if (Estimate) then + + Diag(iiBstR(jSym,1)+1:iiBstR(jSym,1)+NNBSTR(jSym,1)) = Zero + + do krs=1,nRS + + mrs = iiBstR(JSYM,iLoc)+krs + jrs = IndRed(mrs,iLoc) ! address in 1st red set + + do jvc=1,JNUM + + Diag(jrs) = Diag(jrs)+Lrs(krs,jvc)**2 + + end do + + end do + + end if + + call CWTIME(TCS2,TWS2) + tscrn(1) = tscrn(1)+(TCS2-TCS1) + tscrn(2) = tscrn(2)+(TWS2-TWS1) + ! * + !************************************************************* + !************************************************************* + !************************************************************* + ! * + call Allocate_DT(L_Full,nShell,iShp_rs,JNUM,JSYM,nSym) + call mma_allocate(Aux,(nRik+nLik)*nVec,Label='Aux') + call Allocate_DT(Lab,JNUM,nBasSh,nBas,nShell,nSym,mDen) + + call CWTIME(TCX1,TWX1) + + ! Reorder vectors to Full-dimensions + ! + ! Vectors are returned in the storage LaJ,b with the restriction: + ! Sym(a) >= Sym(b) + ! and blocked in shell pairs + + call CHO_getShFull(Lrs,lread,JNUM,JSYM,IREDC,L_Full,SvShp,nnShl,iShp_rs,nnShl_tot) + + call CWTIME(TCX2,TWX2) + tmotr(1) = tmotr(1)+(TCX2-TCX1) + tmotr(2) = tmotr(2)+(TWX2-TWX1) + + !************************************************************* + ! * + ! 1) Screening * + ! * + ! b) DH(mu,nu)=sqrt(D(mu,nu)) * + ! Only the symmetry blocks with compound symmetry JSYM * + ! are computed * + ! * + !************************************************************* + if (DoScreen) then + + call CWTIME(TCS1,TWS1) + + ired1 = 1 ! location of the 1st red set + call swap_tosqrt(irc,ired1,NNBSTRT(1),JSYM,DIAH,DIAG) + + call CWTIME(TCS2,TWS2) + tscrn(1) = tscrn(1)+(TCS2-TCS1) + tscrn(2) = tscrn(2)+(TWS2-TWS1) + + end if + + !************************************************************* + ! * + ! 1) Screening * + ! * + ! c) 1st MO transformation of DH(mu,nu) * + ! Y(mu)[k] = sum_nu DH(mu,nu) * |C(nu)[k]| * + ! * + !************************************************************* + + nInd = 1 + do jDen=1,nKvec + + ! Choose which MO sets on each side + + iMOleft = jDen + iMOright = jDen + + n1 = nIt(iMOright) + n2 = nItMx + + pYik(1:n1,1:n2) => Yik(1:n1*n2) + + if (DoCAS .and. lSA) iMOright = jDen+2 + + do kSym=1,nSym + + lSym = Mul(JSYM,kSym) + Nik = nChOrb_(kSym,iMOleft)*nChOrb_(lSym,iMOright) + nIJR(kSym,lSym,jDen) = Nik + nIJ1(kSym,lSym,jDen) = Nik + if ((JSYM == 1) .and. (iMOleft == iMOright)) Nik = nTri_Elem(nChOrb_(kSym,iMOleft)) + nIJ1(kSym,lSym,jDen) = Nik + + if (Nik == 0) cycle + + iS = 1 + iE = nChOrb_(lSym,iMOright)*JNUM + + Lik(1:JNUM,1:nChOrb_(lSym,iMOright)) => Aux(iS:iE) + + iS = iE+1 + iE = iE+Nik*JNUM + + Rik(1:Nik*JNUM) => Aux(iS:iE) + + Rik(:) = Zero + + do jK=1,nChOrb_(kSym,iMOleft) + jK_a = jK+kOff(kSym,iMOleft) + + Lik(:,:) = Zero + Lab%A0(1:nBas(lSym)*JNUM) = Zero + + if (DoScreen .and. (iBatch == 1)) then + call CWTIME(TCS1,TWS1) + !----------------------------------------------------- + ! Setup the screening + !----------------------------------------------------- + + AbsC(1:nBas(kSym)) = abs(MSQ(iMOleft)%SB(kSym)%A2(:,jK)) + + if (lSym >= kSym) then + + mode = 'N' + n1 = nBas(lSym) + n2 = nBas(kSym) + + else ! lSym<kSym + + mode = 'T' + n1 = nBas(kSym) + n2 = nBas(lSym) + + end if + + if (n1 > 0) call DGEMV_(Mode,n1,n2,ONE,DiaH%SB(lSym,kSym)%A2,n1,AbsC,1,ZERO,Ylk(1,jK_a),1) + + !***************************************************** + ! * + ! 1) Screening * + ! * + ! d) 2nd MO transformation of DH(mu,nu) * + ! Y(i)[k] = sum_mu |C(mu)[i]| * Y(mu)[k] * + ! * + !***************************************************** + + if ((kSym /= lSym) .or. (iMOleft /= iMOright)) then + iStart = 1 + else + iStart = jK + end if + + nQo = 0 + do i=iStart,nChOrb_(lSym,iMOright) + + AbsC(1:nBas(lSym)) = abs(MSQ(iMOright)%SB(lSym)%A2(:,i)) + + pYik(i,jK_a) = ddot_(nBas(lSym),AbsC,1,Ylk,1) + + if (pYik(i,jK_a) >= xtau) then + nQo = nQo+1 + if ((iBatch == 1) .and. (JRED == 1)) then + nQoT = nQoT+1 + if ((lSym == kSym) .and. (i /= jK) .and. (iMOright == iMOleft)) nQoT = nQoT+1 + end if + Indik(1+nQo,nInd) = i + end if + + end do + Indik(1,nInd) = nQo + !***************************************************** + ! * + ! 1) Screening * + ! * + ! e) List the shells present in Y(l)[k] by the * + ! largest element and sort the list * + ! * + !***************************************************** + + do ish=1,nShell + YshMax = zero + do ibs=1,nBasSh(lSym,ish) + ibs_a = koffSh(ish,lSym)+ibs + YshMax = max(YshMax,Ylk(ibs_a,1)) + end do + MLk(ish) = YshMax + end do + + do ish=1,nShell + Indx(ish,nInd) = ish + end do + + !***************************************************** + ! * + ! 1) Screening * + ! * + ! f) Screening * + ! * + ! Here we use a non-exact bound for the exchange * + ! matrix to achieve linear scaling. The positive * + ! definiteness of the exchange matrix combined with * + ! the structure of the density matrix makes this * + ! bound acceptable and likely to be almost exact for * + ! what concerns the exchange energy * + ! * + ! The exact bounds (quadratic scaling of the MO * + ! transformation) would be * + ! If (MLk(jml)*MLk(1) >= tau) then * + ! * + !***************************************************** + + numSh = 0 ! # of significant shells + jml = 1 + do while (jml <= nShell) + + YMax = MLk(jml) + jmlmax = jml + + do iml=jml+1,nShell ! get the max + if (MLk(iml) > YMax) then + YMax = MLk(iml) + jmlmax = iml + end if + end do + + if (jmlmax /= jml) then ! swap positions + xTmp = MLk(jml) + iTmp = Indx(jml,nInd) + MLk(jml) = YMax + Indx(jml,nInd) = Indx(jmlmax,nInd) + MLk(jmlmax) = xTmp + Indx(jmlmax,nInd) = iTmp + end if + + if (MLk(jml) >= xtau) then + numSh = numSh+1 + else + jml = nShell ! exit the loop + end if + + jml = jml+1 + + end do + + Indx(0,nInd) = numSh + + call CWTIME(TCS2,TWS2) + tscrn(1) = tscrn(1)+(TCS2-TCS1) + tscrn(2) = tscrn(2)+(TWS2-TWS1) + !----------------------------------------------------- + end if ! Screening setup + + call CWTIME(TCT1,TWT1) + + !******************************************************* + ! * + ! E X C H A N G E T E R M * + ! * + ! 2) MO transformation * + ! a) 1st half transformation * + ! * + ! Transform vectors for shells in the list ML[k] * + ! * + ! Screening based on the Frobenius norm: * + ! sqrt(sum_ij A(i,j)^2) * + ! || La,J[k] || <= || Lab,J || * || Cb[k] || * + ! * + !******************************************************* + + do iSh=1,Indx(0,nInd) + + iaSh = Indx(iSh,nInd) + + Lab%Keep(iaSh,1) = .true. + + ibcount = 0 + + do ibSh=1,nShell + + iOffShb = kOffSh(ibSh,kSym) + + iShp = iTri(iaSh,ibSh) + + if (iShp_rs(iShp) <= 0) cycle + + if ((nnBstRSh(JSym,iShp_rs(iShp),iLoc)*nBasSh(lSym,iaSh)*nBasSh(kSym,ibSh) > 0) .and. & + (sqrt(abs(SumClk(iMOleft)%A(ibSh,jK_a)*SvShp(iShp_rs(iShp),1))) >= thrv)) then + + ibcount = ibcount+1 + + if (lSym >= kSym) then + + l1 = 1 + if (iaSh < ibSh) l1 = 2 + + ! LaJ,[k] = sum_b L(aJ,b) * C(b)[k] + !------------------------------------ + + Mode = 'N' + n1 = nBasSh(lSym,iaSh)*JNUM + n2 = nBasSh(kSym,ibSh) + + call DGEMV_(Mode,n1,n2,One,L_Full%SPB(lSym,iShp_rs(iShp),l1)%A21,n1, & + MSQ(iMOleft)%SB(kSym)%A2(iOffShb+1:,jK),1,ONE,Lab%SB(iaSh,lSym,1)%A,1) + + else ! lSym < kSym + + l1 = 1 + if (ibSh < iaSh) l1 = 2 + + ! LJa,[k] = sum_b L(b,Ja) * C(b)[k] + !------------------------------------ + + Mode = 'T' + n1 = nBasSh(kSym,ibSh) + n2 = JNUM*nBasSh(lSym,iaSh) + + call DGEMV_(Mode,n1,n2,One,L_Full%SPB(kSym,iShp_rs(iShp),l1)%A12,n1, & + MSQ(iMOleft)%SB(kSym)%A2(iOffShb+1:,jK),1,ONE,Lab%SB(iaSh,lSym,1)%A,1) + + end if + + end if + + end do + + ! The following re-assignement is used later on to check if the + ! iaSh vector LaJ[k] can be neglected because identically zero + + if (ibcount == 0) Lab%Keep(iaSh,1) = .false. + + end do + + !******************************************************* + ! * + ! 2) MO transformation * + ! b) 2nd half transformation * + ! * + !******************************************************* + + nQo = Indik(1,nInd) + + do ir=1,nQo + + it = Indik(1+ir,nInd) + + do iSh=1,Indx(0,nInd) + + iaSh = Indx(iSh,nInd) + + if (.not. Lab%Keep(iaSh,1)) cycle + + iS = kOffsh(iaSh,lSym)+1 + + if (lSym >= kSym) then + + ! LJi[k] = sum_a LaJ[k] * Cai + !------------------------------ + + Mode = 'T' + n1 = nBasSh(lSym,iaSh) + n2 = JNUM + + else ! lSym < kSym + + ! LJi[k] = sum_a LJa[k] * Cai + !------------------------------ + + Mode = 'N' + n1 = JNUM + n2 = nBasSh(lSym,iaSh) + + end if + + call DGEMV_(Mode,n1,n2,One,Lab%SB(iaSh,lSym,1)%A,n1,MSQ(iMOright)%SB(lSym)%A2(iS:,it),1,one,Lik(:,it),1) + + end do + + ! Copy LJi[k] in the standard ordered matrix Lik,J + + if ((jSym == 1) .and. (iMOright == iMOleft)) then + itk = nTri_Elem(it-1)+jK + else + itk = nChOrb_(lSym,iMOright)*(jK-1)+it + end if + call dcopy_(JNUM,Lik(:,it),1,Rik(itk:),Nik) + + end do + + nInd = nInd+1 + + call CWTIME(TCT2,TWT2) + tmotr2(1) = tmotr(1)+(TCT2-TCT1) + tmotr2(2) = tmotr(2)+(TWT2-TWT1) + + end do ! loop over k MOs + + call CWTIME(TCT1,TWT1) + + !********************************************************* + ! * + ! 3) Put to disk * + ! * + !********************************************************* + iAdr = Nik*(JVEC-1) + call DDAFILE(LuRVec(lSym,jDen),1,Rik,Nik*JNUM,iAdr) + + call CWTIME(TCT2,TWT2) + tmotr(1) = tmotr(1)+(TCT2-TCT1) + tmotr(2) = tmotr(2)+(TWT2-TWT1) + + end do ! loop over MOs symmetry + + nullify(pYik) + + end do ! loop over densities + + call Deallocate_DT(Lab) + call mma_deallocate(Aux) + call Deallocate_DT(L_Full) + ! * + !************************************************************* + !************************************************************* + !************************************************************* + ! * + + ! ************ END EXCHANGE CONTRIBUTION **************** + + ! Diagonals updating. It only makes sense if nScreen > 0 + + if (Update .and. (nScreen > 0)) then + + call CWTIME(TCS1,TWS1) + !------------------------------------------------------------- + ! update the diagonals : D(a,b) = D(a,b) - sum_J (Lab,J)^2 + + ! subtraction is done in the 1st reduced set +# ifdef _MOLCAS_MPP_ + if (Is_Real_Par()) then + + do krs=1,nRS + mrs = iiBstR(JSYM,iLoc)+krs + jrs = IndRed(mrs,iLoc)-iiBstR(JSYM,1) + do jvc=1,JNUM + DiagJ(jrs) = DiagJ(jrs)+Lrs(krs,jvc)**2 + end do + end do + + else + + do krs=1,nRS + mrs = iiBstR(JSYM,iLoc)+krs + jrs = IndRed(mrs,iLoc) ! address in 1st red set + do jvc=1,JNUM + Diag(jrs) = Diag(jrs)-Lrs(krs,jvc)**2 + end do + end do + + end if + +# else + do krs=1,nRS + mrs = iiBstR(JSYM,iLoc)+krs + jrs = IndRed(mrs,iLoc) ! address in 1st red set + do jvc=1,JNUM + Diag(jrs) = Diag(jrs)-Lrs(krs,jvc)**2 + end do + end do +# endif + + call CWTIME(TCS2,TWS2) + tscrn(1) = tscrn(1)+(TCS2-TCS1) + tscrn(2) = tscrn(2)+(TWS2-TWS1) + + end if + + end if ! DoExchange + + !*************************************************************** + !*************************************************************** + !** ** + !** Active term ** + !** ** + !*************************************************************** + !*************************************************************** + if (DoCAS) then + + call CWTIME(TCC1,TWC1) + + ! Set up the skipping flags + ! The memory used before for the full-dimension AO-vectors + ! is now re-used to store half and full transformed + ! vectors in the active space + + iSwap = 0 ! Lvb,J are returned + call Allocate_DT(Laq(1),nAorb,nBas,nVec,JSYM,nSym,iSwap) + + iMO2 = 1 + do iMO1=1,nAdens + + ! iSwap_lxy=5 diagonal blocks are triangular + ! iSwap_lxy=6 diagonal blocks are square + iSwap_lxy = 5 + if (iMO1 == 2) iSwap_lxy = 6 + call Allocate_DT(Lxy,nAorb,nAorb,nVec,JSYM,nSym,iSwap_lxy) + + !*********************************************************** + ! * + ! MO transformation of Cholesky vectors * + ! * + ! 1) Lvb,J = sum_a C(v,a) * Lab,J * + ! * + !*********************************************************** + + kMOs = 1 + nMOs = 1 ! Active MOs (1st set) + + call CHO_X_getVtra(irc,Lrs,LREAD,jVEC,JNUM,JSYM,iSwap,IREDC,nMOs,kMOs,Aorb(iMO1),Laq(1),DoRead) + + if (irc /= 0) then + return + end if + + !*********************************************************** + ! * + ! MO transformation of Cholesky vectors * + ! * + ! 2) Lvw,J = sum_b Lvb,J * C(w,b) * + ! * + !*********************************************************** + if ((JSYM == 1) .and. (iMO1 == iMO2)) then + + do iSymb=1,nSym + + NAv = nAorb(iSymb) + + if (NAv < 1) cycle + + do JVC=1,JNUM + ! triangular blocks + call DGEMM_Tri('N','T',NAv,NAv,NBAS(iSymb),One,Laq(1)%SB(iSymb)%A3(:,:,JVC),NAv,Aorb(iMO2)%SB(iSymb)%A2,NAv, & + Zero,Lxy%SB(iSymb)%A2(:,JVC),NAv) + + end do + + end do + + else + + do iSymb=1,nSym + + iSymv = Mul(JSYM,iSymb) + NAv = nAorb(iSymv) + NAw = nAorb(iSymb) ! iSymb=iSymw + + if ((NAv*NAw /= 0) .and. (iSymv <= iSymb)) then + + do JVC=1,JNUM + + ! square or rectangular blocks + call DGEMM_('N','T',NAv,NAw,NBAS(iSymb),One,Laq(1)%SB(iSymv)%A3(:,:,JVC),NAv,Aorb(iMO2)%SB(iSymb)%A2,NAw,Zero, & + Lxy%SB(iSymv)%A2(:,JVC),NAv) + + end do + + end if + + end do + + end if + !*********************************************************** + ! * + ! Evaluation of the Z_p_k * + ! * + ! Z(p){#J} = sum_xy T(xy,p) * L(xy,{#J}) * + ! * + ! T(xy,p) : is stored by compound symmetry JSYM * + ! the indices {xy} are stored as PACKED * + ! (sym x < = sym y) * + ! * + !*********************************************************** + do iTxy=iMO1,nAdens + iAvec = iMO1+iTxy-1 + do iSymy=1,nSym + + iSymx = Mul(iSymy,JSYM) + + if ((iSymx <= iSymy) .and. (nnA(iSymx,iSymy) /= 0)) then + + ipZp = iOffZp+nnP(JSYM)*(JVEC-1)+1 + + if (iMO1 == iMO2) then + + ! diagonal symmetry blocks are triangular + call DGEMM_('T','N',nnP(JSYM),JNUM,nnA(iSymx,iSymy),ONE,Txy(ipTxy(iSymx,iSymy,iTxy)),nnP(JSYM), & + Lxy%SB(iSymx)%A2,nnA(iSymx,iSymy),ONE,Z_p_k(ipZp,iAvec),nnP(JSYM)) + + else + !MGD may rearrange the loops + + do i=1,nnP(JSYM) + ioff = ipTxy(iSymx,iSymy,iTxy)+nnA(iSymx,iSymy)*(i-1) + + do j=1,JNUM + + !MGD don't work with symmetry + temp = Zero + do k=0,nAOrb(iSymx)-1 + do l=0,k + temp = temp+Half*Txy(ioff+iTri(k+1,l))*(Lxy%SB(iSymx)%A2(l+1+nAOrb(iSymx)*k,j)+ & + Lxy%SB(iSymx)%A2(k+1+nAOrb(iSymx)*l,j)) + end do + end do + + ij = ipZp-1+i+nnP(JSYM)*(j-1) + + Z_p_k(ij,iAvec) = Z_p_k(ij,iAvec)+temp + + end do ! j + end do ! i + + end if + + end if + + end do + end do + + call Deallocate_DT(Lxy) + end do + + call CWTIME(TCC2,TWC2) + tcasg(1) = tcasg(1)+(TCC2-TCC1) + tcasg(2) = tcasg(2)+(TWC2-TWC1) + + call Deallocate_DT(Laq(1)) + + end if ! DoCAS + + end do ! end batch loop + ! * + !***************************************************************** + !***************************************************************** + !** ** + !** Epilogue ** + !** ** + !***************************************************************** + !***************************************************************** + ! * + + ! free memory + call mma_deallocate(Lrs) + + if (JSYM == 1) then + call mma_deallocate(Drs) + if (iMp2prpt == 2) call mma_deallocate(Drs2) + end if + + end if + + ! Screening control section + DoScreen = kscreen == nScreen + + if (.not. DoScreen) then + kscreen = kscreen+1 + else + kscreen = 1 + end if + + if (DoExchange) then +# ifdef _MOLCAS_MPP_ + if (Is_Real_Par() .and. Update .and. DoScreen) then + call GaDsum(DiagJ,nnBSTR(JSYM,1)) + Diag(iiBstR(JSYM,1)+1:iiBstR(JSYM,1)+nnBstR(JSYM,1)) = Diag(iiBstR(JSYM,1)+1:iiBstR(JSYM,1)+nnBstR(JSYM,1))- & + DiagJ(1:nnBSTR(JSYM,1)) + DiagJ(1:nnBSTR(JSYM,1)) = Zero + end if + ! Need to activate the screening to setup the contributing shell + ! indices the first time the loop is entered .OR. whenever other nodes + ! have performed screening in the meanwhile + if (Is_Real_Par() .and. (.not. DoScreen) .and. (nVrs == 0)) then + ntv0 = ntv0+1 + DoScreen = ((JRED < myJRED1) .or. (ntv0 >= nScreen)) + if (DoScreen) ntv0 = 0 + end if +# endif + end if + ! * + !********************************************************************* + ! * + end do ! loop over red sets + ! * + !********************************************************************* + ! * + if (DoExchange) then + do jDen=1,nKvec + do i=1,nSym + call DACLOS(LuRVec(i,jDen)) + end do + end do + end if + + ! * + !********************************************************************* + ! * +end do ! loop over JSYM +! * +!*********************************************************************** +! * +! Allocate a field to be used by Compute_A_jk later +! since allocations cannot be made at that stage +! * +!*********************************************************************** +! * +if (DoExchange) then + nIJMax = 0 + do jDen=1,nKvec + do iSym1=1,nSym + do iSym2=1,nSym + nIJMax = max(nIJMax,nIJR(iSym1,iSym2,jDen)) + end do + end do + end do + call mma_allocate(VJ,2*nIJMax,Label='VJ') +end if + +call mma_deallocate(iShp_rs) +if (DoExchange) then + call mma_deallocate(SvShp) + call mma_deallocate(kOffSh) + call mma_deallocate(Indik) + call mma_deallocate(Indx) + do i=1,nDen + nullify(SumClk(i)%A) + end do + call mma_deallocate(Aux0) + call mma_deallocate(MLk) + call mma_deallocate(Yik) + call mma_deallocate(Ylk) + call mma_deallocate(AbsC) + call Deallocate_DT(DiaH) +# ifdef _MOLCAS_MPP_ + if (Is_Real_Par() .and. Update) call mma_deallocate(DiagJ) +# endif + call mma_deallocate(Diag) +end if + +call CWTIME(TOTCPU2,TOTWALL2) +TOTCPU = TOTCPU2-TOTCPU1 +TOTWALL = TOTWALL2-TOTWALL1 +#ifdef _CD_TIMING_ +ChoGet_CPU = TOTCPU +ChoGet_Wall = TOTWALL +#endif + +! Write out timing information +if (timings) then + + CFmt = '(2x,A)' + write(u6,*) + write(u6,CFmt) 'Cholesky Gradients timing from '//SECNAM + write(u6,CFmt) '----------------------------------------' + write(u6,*) + write(u6,CFmt) '- - - - - - - - - - - - - - - - - - - - - - - - -' + write(u6,CFmt) ' CPU WALL ' + write(u6,CFmt) '- - - - - - - - - - - - - - - - - - - - - - - - -' + + write(u6,'(2x,A26,2f10.2)') 'READ VECTORS ',tread(1),tread(2) + write(u6,'(2x,A26,2f10.2)') 'COULOMB CONTRIB. ',tcoul(1),tcoul(2) + write(u6,'(2x,A26,2f10.2)') 'SCREENING OVERHEAD ',tscrn(1),tscrn(2) + write(u6,'(2x,A26,2f10.2)') 'INACT MO-TRANSFORM VECTORS ',tmotr(1),tmotr(2) + write(u6,'(2x,A26,2f10.2)') 'INACT MO-TRANSFORM VECTORS 2 ',tmotr2(1),tmotr2(2) + write(u6,'(2x,A26,2f10.2)') 'ACTIVE CONTRIB. ',tcasg(1),tcasg(2) + write(u6,*) + write(u6,'(2x,A26,2f10.2)') 'TOTAL ',TOTCPU,TOTWALL + write(u6,CFmt) '- - - - - - - - - - - - - - - - - - - - - - - - -' + write(u6,*) + +end if + +irc = 0 + +return + +end subroutine CHO_GET_GRAD diff -Nru openmolcas-22.02/src/ri_util/cho_reorder_ri.f openmolcas-22.10/src/ri_util/cho_reorder_ri.f --- openmolcas-22.02/src/ri_util/cho_reorder_ri.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/cho_reorder_ri.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,104 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - SubRoutine Cho_Reorder_RI(Vec,lVec,nVec,iSym) - use ChoArr, only: iRS2F - Implicit Real*8 (a-h,o-z) - Real*8 Vec(lVec,nVec) -#include "cholesky.fh" -#include "choorb.fh" -#include "stdalloc.fh" - - Real*8, Allocatable :: Scr(:) - Integer, Allocatable :: iF2RS(:) - - MulD2h(i,j)=iEor(i-1,j-1)+1 - iTri(i,j)=max(i,j)*(max(i,j)-3)/2+i+j - - If (nVec .lt. 1) Return - If (lVec .lt. 1) Return - If (lVec.ne.nnBstR(iSym,1) .or. nVec.gt.NumCho(iSym)) Then - Call SysAbendMsg('Cho_Reorder_RI','Input argument error!',' ') - End If - If (nnShl .ne. nnShl_Tot) Then - Call SysAbendMsg('Cho_Reorder_RI','Screening is not allowed!', - & '(nnShl.ne.nnShl_Tot)') - End If - -C Set mapping from global address to reduced set. -C ----------------------------------------------- - - liF2RS = nBasT*(nBasT+1)/2 - Call mma_allocate(iF2RS,liF2RS,Label='iF2RS') - iF2RS(:)=0 - Do iRS = 1,nnBstR(iSym,1) - iRS_tot = iiBstR(iSym,1) + iRS - na = iRS2F(1,iRS_tot) - nb = iRS2F(2,iRS_tot) - nab = iTri(na,nb) - iF2RS(nab) = iRS - End Do - -C Reorder. -C -------- - - lScr = lVec - Call mma_allocate(Scr,lScr,Label='Scr') - Do iVec = 1,nVec - - Scr(:)=Vec(:,iVec) - kFrom = 0 - Do iSymb = 1,nSym - - iSyma = MulD2h(iSymb,iSym) - - If (iSyma .gt. iSymb) Then - Do ib = 1,nBas(iSymb) - nb = iBas(iSymb) + ib - Do ia = 1,nBas(iSyma) - na = iBas(iSyma) + ia - nab = iTri(na,nb) - iRS = iF2RS(nab) -#if defined (_DEBUGPRINT_) - If (iRS.lt.1 .or. iRS.gt.nnBstR(iSym,1)) Then - Call SysAbendMsg('Cho_Reorder_RI', - & 'Index out of bounds',' ') - End If -#endif - kFrom = kFrom + 1 - Vec(iRS,iVec) = Scr(kFrom) - End Do - End Do - Else If (iSyma .eq. iSymb) Then - Do ia = 1,nBas(iSyma) - na = iBas(iSyma) + ia - Do ib = 1,ia - nb = iBas(iSymb) + ib - nab = iTri(na,nb) - iRS = iF2RS(nab) -#if defined (_DEBUGPRINT_) - If (iRS.lt.1 .or. iRS.gt.nnBstR(iSym,1)) Then - Call SysAbendMsg('Cho_Reorder_RI', - & 'Index out of bounds',' ') - End If -#endif - kFrom = kFrom + 1 - Vec(iRS,iVec) = Scr(kFrom) - End Do - End Do - End If - - End Do - - End Do - Call mma_deallocate(Scr) - Call mma_deallocate(iF2RS) - - End diff -Nru openmolcas-22.02/src/ri_util/cho_reorder_ri.F90 openmolcas-22.10/src/ri_util/cho_reorder_ri.F90 --- openmolcas-22.02/src/ri_util/cho_reorder_ri.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/cho_reorder_ri.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,105 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Cho_Reorder_RI(Vec,lVec,nVec,iSym) + +use Index_Functions, only: iTri, nTri_Elem +use Symmetry_Info, only: Mul +use ChoArr, only: iRS2F +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: lVec, nVec, iSym +real(kind=wp), intent(inout) :: Vec(lVec,nVec) +#include "cholesky.fh" +#include "choorb.fh" +integer(kind=iwp) :: ia, ib, iRS, iRS_tot, iSyma, iSymb, iVec, kFrom, liF2RS, lScr, na, nab, nb +integer(kind=iwp), allocatable :: iF2RS(:) +real(kind=wp), allocatable :: Scr(:) + +if (nVec < 1) return +if (lVec < 1) return +if ((lVec /= nnBstR(iSym,1)) .or. (nVec > NumCho(iSym))) then + call SysAbendMsg('Cho_Reorder_RI','Input argument error!',' ') +end if +if (nnShl /= nnShl_Tot) then + call SysAbendMsg('Cho_Reorder_RI','Screening is not allowed!','(nnShl /= nnShl_Tot)') +end if + +! Set mapping from global address to reduced set. +! ----------------------------------------------- + +liF2RS = nTri_Elem(nBasT) +call mma_allocate(iF2RS,liF2RS,Label='iF2RS') +iF2RS(:) = 0 +do iRS=1,nnBstR(iSym,1) + iRS_tot = iiBstR(iSym,1)+iRS + na = iRS2F(1,iRS_tot) + nb = iRS2F(2,iRS_tot) + nab = iTri(na,nb) + iF2RS(nab) = iRS +end do + +! Reorder. +! -------- + +lScr = lVec +call mma_allocate(Scr,lScr,Label='Scr') +do iVec=1,nVec + + Scr(:) = Vec(:,iVec) + kFrom = 0 + do iSymb=1,nSym + + iSyma = Mul(iSymb,iSym) + + if (iSyma > iSymb) then + do ib=1,nBas(iSymb) + nb = iBas(iSymb)+ib + do ia=1,nBas(iSyma) + na = iBas(iSyma)+ia + nab = iTri(na,nb) + iRS = iF2RS(nab) +# ifdef _DEBUGPRINT_ + if ((iRS < 1) .or. (iRS > nnBstR(iSym,1))) then + call SysAbendMsg('Cho_Reorder_RI','Index out of bounds',' ') + end if +# endif + kFrom = kFrom+1 + Vec(iRS,iVec) = Scr(kFrom) + end do + end do + else if (iSyma == iSymb) then + do ia=1,nBas(iSyma) + na = iBas(iSyma)+ia + do ib=1,ia + nb = iBas(iSymb)+ib + nab = iTri(na,nb) + iRS = iF2RS(nab) +# ifdef _DEBUGPRINT_ + if ((iRS < 1) .or. (iRS > nnBstR(iSym,1))) then + call SysAbendMsg('Cho_Reorder_RI','Index out of bounds',' ') + end if +# endif + kFrom = kFrom+1 + Vec(iRS,iVec) = Scr(kFrom) + end do + end do + end if + + end do + +end do +call mma_deallocate(Scr) +call mma_deallocate(iF2RS) + +end subroutine Cho_Reorder_RI diff -Nru openmolcas-22.02/src/ri_util/cho_ri_final.F90 openmolcas-22.10/src/ri_util/cho_ri_final.F90 --- openmolcas-22.02/src/ri_util/cho_ri_final.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/cho_ri_final.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,30 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Cho_RI_Final(irc,nVec_RI,l_nVec_RI) + +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(out) :: irc +integer(kind=iwp), intent(in) :: l_nVec_RI, nVec_RI(l_nVec_RI) +#include "cholesky.fh" + +if (l_nVec_RI < nSym) then + irc = 1 +else + irc = 0 + call Put_iArray('nVec_RI',nVec_RI,nSym) +end if + +return + +end subroutine Cho_RI_Final diff -Nru openmolcas-22.02/src/ri_util/cho_ri_putinfo.f openmolcas-22.10/src/ri_util/cho_ri_putinfo.f --- openmolcas-22.02/src/ri_util/cho_ri_putinfo.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/cho_ri_putinfo.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - SubRoutine Cho_RI_PutInfo(iPass,iRed) -#if defined (_MOLCAS_MPP_) - Use Para_Info, Only: nProcs, Is_Real_Par -#endif - Implicit None - Integer iPass, iRed -#include "cholesky.fh" -#include "choglob.fh" - Logical doSwap - Integer iTmp -#if defined (_MOLCAS_MPP_) - doSwap = nProcs.gt.1 .and. Is_Real_Par() -#else - doSwap = .False. -#endif - - If (doSwap) Then - iTmp = LuRed - LuRed = LuRed_G - Call Cho_PutRed(iPass,iRed) ! save reduced set indices on disk - LuRed = iTmp - iTmp = LuRst - LuRst = LuRst_G - Call Cho_WrRstC(iPass) ! save disk addresses etc. on disk - LuRst = iTmp - Else - Call Cho_PutRed(iPass,iRed) ! save reduced set indices on disk - Call Cho_WrRstC(iPass) ! save disk addresses etc. on disk - End If -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/cho_ri_putinfo.F90 openmolcas-22.10/src/ri_util/cho_ri_putinfo.F90 --- openmolcas-22.02/src/ri_util/cho_ri_putinfo.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/cho_ri_putinfo.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,48 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Cho_RI_PutInfo(iPass,iRed) + +#ifdef _MOLCAS_MPP_ +use Para_Info, only: nProcs, Is_Real_Par +#endif +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: iPass, iRed +#include "cholesky.fh" +#include "choglob.fh" +integer(kind=iwp) :: iTmp +logical(kind=iwp) :: doSwap + +#ifdef _MOLCAS_MPP_ +doSwap = (nProcs > 1) .and. Is_Real_Par() +#else +doSwap = .false. +#endif + +if (doSwap) then + iTmp = LuRed + LuRed = LuRed_G + call Cho_PutRed(iPass,iRed) ! save reduced set indices on disk + LuRed = iTmp + iTmp = LuRst + LuRst = LuRst_G + call Cho_WrRstC(iPass) ! save disk addresses etc. on disk + LuRst = iTmp +else + call Cho_PutRed(iPass,iRed) ! save reduced set indices on disk + call Cho_WrRstC(iPass) ! save disk addresses etc. on disk +end if + +return + +end subroutine Cho_RI_PutInfo diff -Nru openmolcas-22.02/src/ri_util/cho_ri_swapvecunit.f openmolcas-22.10/src/ri_util/cho_ri_swapvecunit.f --- openmolcas-22.02/src/ri_util/cho_ri_swapvecunit.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/cho_ri_swapvecunit.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - SubRoutine Cho_RI_SwapVecUnit(iSym) -#if defined (_MOLCAS_MPP_) - Use Para_Info, Only: nProcs, Is_Real_Par -#endif - Implicit None - Integer iSym -#include "cholesky.fh" -#include "choglob.fh" - Logical doSwap - Integer iTmp -#if defined (_MOLCAS_MPP_) - doSwap = nProcs.gt.1 .and. Is_Real_Par() -#else - doSwap = .False. -#endif - - If (doSwap) Then - iTmp = LuCho(iSym) - LuCho(iSym) = LuCho_G(iSym) - LuCho_G(iSym) = iTmp - End If -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/cho_ri_swapvecunit.F90 openmolcas-22.10/src/ri_util/cho_ri_swapvecunit.F90 --- openmolcas-22.02/src/ri_util/cho_ri_swapvecunit.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/cho_ri_swapvecunit.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,40 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Cho_RI_SwapVecUnit(iSym) + +#ifdef _MOLCAS_MPP_ +use Para_Info, only: nProcs, Is_Real_Par +#endif +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: iSym +#include "cholesky.fh" +#include "choglob.fh" +integer(kind=iwp) :: iTmp +logical(kind=iwp) :: doSwap + +#ifdef _MOLCAS_MPP_ +doSwap = (nProcs > 1) .and. Is_Real_Par() +#else +doSwap = .false. +#endif + +if (doSwap) then + iTmp = LuCho(iSym) + LuCho(iSym) = LuCho_G(iSym) + LuCho_G(iSym) = iTmp +end if + +return + +end subroutine Cho_RI_SwapVecUnit diff -Nru openmolcas-22.02/src/ri_util/cho_x_setab.F90 openmolcas-22.10/src/ri_util/cho_x_setab.F90 --- openmolcas-22.02/src/ri_util/cho_x_setab.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/cho_x_setab.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,25 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Cho_x_setab(iS,jS) + +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: iS, jS +#include "cholesky.fh" + +SHA = iS +SHB = jS + +return + +end subroutine Cho_x_setab diff -Nru openmolcas-22.02/src/ri_util/chunk_mod.F90 openmolcas-22.10/src/ri_util/chunk_mod.F90 --- openmolcas-22.02/src/ri_util/chunk_mod.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/chunk_mod.F90 1970-01-01 00:00:00.000000000 +0000 @@ -1,17 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in <http://www.gnu.org/licenses/>. * -!*********************************************************************** -Module Chunk_Mod -#ifdef _MOLCAS_MPP_ - Integer :: ip_Chunk=0 - Integer, Allocatable :: iMap(:) -#endif -Real*8, Allocatable :: Chunk(:) -End Module Chunk_Mod diff -Nru openmolcas-22.02/src/ri_util/CMakeLists.txt openmolcas-22.10/src/ri_util/CMakeLists.txt --- openmolcas-22.02/src/ri_util/CMakeLists.txt 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -9,4 +9,113 @@ # LICENSE or in <http://www.gnu.org/licenses/>. * #*********************************************************************** +set (sources + a_3c_qv_s.F90 + cd_ainv.F90 + cd_ainv_inner.F90 + cho_factor.F90 + cho_get_grad.F90 + cho_reorder_ri.F90 + cho_ri_final.F90 + cho_ri_putinfo.F90 + cho_ri_swapvecunit.F90 + cho_x_setab.F90 + compute_a_jk.F90 + compute_auxvec.F90 + compute_b.F90 + compute_txy.F90 + compute_v12.F90 + contract_zpk_tpxy.F90 + create_chunk.F90 + decideoncholesky.F90 + destroy_chunk.F90 + drv2el_3center_ri.F90 + drv2el_ri_diag.F90 + drvg1_2center_ri.F90 + drvg1_3center_ri.F90 + drvg1_ri.F90 + fix_coeff.F90 + free_tsk2.F90 + gen_qvec.F90 + get_auxiliary_shells.F90 + get_chunk.F90 + get_maxdg.F90 + get_mxos.F90 + get_pivot_idx.F90 + get_pivot_idx_w.F90 + indsft_ri_2.F90 + indsft_ri_3.F90 + inicho_ri.F90 + inicho_ri_xtras.F90 + init_tsk2.F90 + in_place_diag.F90 + in_place_square.F90 + integral_ri_2.F90 + integral_ri_3.F90 + integral_ricd.F90 + inv_cho_factor.F90 + iramax.F90 + mk_acd_accd_shells.F90 + mk_coeffs.F90 + mk_dummy_shell.F90 + mk_indkl.F90 + mk_iso2ind.F90 + mk_list2.F90 + mk_ricd_shells.F90 + mk_ri_shells.F90 + mk_tint_p.F90 + mk_tvt.F90 + mk_tvtf.F90 + modify_tint_p.F90 + mult_3c_qv_s.F90 + mult_rijk_qkl.F90 + mult_vk_qv_s.F90 + mult_with_q_mp2.F90 + mult_zp_qv_s.F90 + nmemam.F90 + nsize_3c.F90 + nsize_rv.F90 + o2n.F90 + ofembed_dmat.F90 + off_diagonal.F90 + pget1_cd2.F90 + pget1_cd3.F90 + pget1_ri2.F90 + pget1_ri3.F90 + pget2_cd2.F90 + pget2_cd3.F90 + pget2_ri2.F90 + pget2_ri3.F90 + pivot_mat.F90 + plf_ri_2.F90 + plf_ri_3.F90 + plf_ricd.F90 + post_2center_ri.F90 + put_chunk.F90 + remap_u_k.F90 + remap_v_k.F90 + remove_high_exponents.F90 + renorm2.F90 + renorm2_inner.F90 + reord_vk.F90 + restore_mat.F90 + ri_glob.F90 + ri_procedures.F90 + ri_xdiag.F90 + rm_auxshell.F90 + rsv_tsk2.F90 + set_cho_adrvec.F90 + setchoindx_ri.F90 + setup_aux.F90 + setup_aux_inner.F90 + sort_mat.F90 + square_a.F90 + termcho_ri.F90 +) + +# Source files defining modules that should be available to other *_util directories +set (modfile_list + ri_glob.F90 +) + include (${PROJECT_SOURCE_DIR}/cmake/util_template.cmake) diff -Nru openmolcas-22.02/src/ri_util/compute_a_jk.f openmolcas-22.10/src/ri_util/compute_a_jk.f --- openmolcas-22.02/src/ri_util/compute_a_jk.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/compute_a_jk.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,41 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Jonas Bostrom * -************************************************************************ - Subroutine Compute_A_jk_mp2(iSO,jVec,kVec,Ajk,fac_ij,fac_kl, - & nVec,iOpt) -************************************************************************** -* Author: J Bostrom -* -* Purpose: Loading A-matrix for mp2 from disk -* -************************************************************************** - use ExTerm, only: iMP2prpt, LuAVector - Implicit Real*8 (a-h,o-z) -#include "exterm.fh" - Real*8 :: Ajk, Fac_ij, Fac_kl, dum(1) - - Character*16 SECNAM - Parameter (SECNAM = 'Compute_A_jk_mp2') - - Ajk = 0.0d0 - If(imp2prpt .eq. 2) Then - lTot = 1 - iAdrA = nVec*(kVec-1) + jVec - Call dDaFile(LuAVector(iOpt),2,dum,lTot,iAdrA) - Ajk_mp2=dum(1) - Ajk = Ajk + (Ajk_mp2*Fac_kl*Fac_ij) - End If - - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(iSO) - End diff -Nru openmolcas-22.02/src/ri_util/compute_a_jk.F90 openmolcas-22.10/src/ri_util/compute_a_jk.F90 --- openmolcas-22.02/src/ri_util/compute_a_jk.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/compute_a_jk.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,44 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Jonas Bostrom * +!*********************************************************************** + +subroutine Compute_A_jk_mp2(jVec,kVec,Ajk,fac_ij,fac_kl,nVec,iOpt) +!*********************************************************************** +! Author: J Bostrom * +! * +! Purpose: Loading A-matrix for mp2 from disk * +! * +!*********************************************************************** + +use RI_glob, only: iMP2prpt, LuAVector +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: jVec, kVec, nVec, iOpt +real(kind=wp), intent(out) :: Ajk +real(kind=wp), intent(in) :: Fac_ij, Fac_kl +integer(kind=iwp) :: iAdrA +real(kind=wp) :: Ajk_mp2(1) +character(len=*), parameter :: SECNAM = 'Compute_A_jk_mp2' + +if (iMP2prpt == 2) then + iAdrA = nVec*(kVec-1)+jVec + call dDaFile(LuAVector(iOpt),2,Ajk_mp2,1,iAdrA) + Ajk = Ajk_mp2(1)*Fac_kl*Fac_ij +else + Ajk = Zero +end if + +return + +end subroutine Compute_A_jk_mp2 diff -Nru openmolcas-22.02/src/ri_util/compute_auxvec.f openmolcas-22.10/src/ri_util/compute_auxvec.f --- openmolcas-22.02/src/ri_util/compute_auxvec.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/compute_auxvec.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,511 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Compute_AuxVec(ipVk,ipZpk,myProc,nProc,ipUk) - use pso_stuff - use Basis_Info, only: nBas, nBas_Aux - use Gateway_global, only: force_out_of_core - use RICD_Info, only: Do_RI, Cholesky - use Symmetry_Info, only: nIrrep - use Data_Structures, only: Allocate_DT, Deallocate_DT, DSBA_Type - use ExTerm, only: iMP2prpt, DMLT - Implicit Real*8 (a-h,o-z) - Integer ipVk(nProc), ipZpk(nProc) - Integer, Optional:: ipUk(nProc) -#include "stdalloc.fh" -#include "real.fh" -#include "cholesky.fh" -#include "etwas.fh" -#include "exterm.fh" - - Type (DSBA_Type) DSQ, ChM(5), DLT2 - - Logical DoExchange, DoCAS, Estimate, Update - Integer nIOrb(0:7),nV_l(0:7),nV_t(0:7) - Integer nU_l(0:7), nU_t(0:7) - Integer ipTxy(0:7,0:7,2),jp_V_k -#include "chotime.fh" - Character*8 Method - - Real*8, Allocatable :: TmpD(:), Zv(:), Qv(:), Scr(:) -* -************************************************************************ -* * - DoExchange=Exfac.ne.Zero -* - nV_ls=0 - Do i=0,nIrrep-1 - nV_l(i) = NumCho(i+1) ! local # of vecs in parallel run - nV_ls=nV_ls+nV_l(i) - nV_t(i) = nV_l(i) - End Do - Call GAIGOP(nV_t,nIrrep,'+') ! total # of vecs - If (nV_t(0).eq.0) Then - Call WarningMessage(2, - & 'Compute_AuxVec: no total symmetric vectors!!') - Call Abend() - EndIf -* - If(iMp2prpt.eq.2) Then - If (.NOT.Present(ipUk)) Then - Write (6,*) 'No ipUk input present!' - Call Abend() - End If - nU_ls=0 - Do i=0,nIrrep-1 - nU_l(i) = NumCho(i+1) ! local # of vecs in parallel run - nU_ls=nU_ls+nU_l(i) - nU_t(i) = nU_l(i) - End Do - Call GAIGOP(nU_t,nIrrep,'+') ! total # of vecs - If (nU_t(0).eq.0) Then - Call WarningMessage(2, - & 'Compute_AuxVec: no total symmetric vectors!!') - Call Abend() - EndIf - End If -* - NChVMx=0 - nQMax=0 - Do i=0,nIrrep-1 - NChVMx= Max(NChVMx,nV_t(i)) - nQMax = Max(nQMax,nBas_Aux(i)) - nChOrb(i,1)=0 - nChOrb(i,2)=0 - End Do - nQvMax=nQMax*NChVMx - Call mma_allocate(Scr,nQMax) -* - DoCAS=lPSO -* - If (nV_ls >=1) Then ! can be = 0 in a parallel run -* - jp_V_k = ipVk(myProc) - jp_Z_p_k = ipZpk(myProc) - jp_U_k = 1 - If(iMp2prpt .eq. 2) Then - jp_U_k = ipUk(myProc) - End If -************************************************************************ -* * -* Get (and transform) the density matrices * -* * -************************************************************************ -* - Timings=.False. -* Timings=.True. -* - Call Get_iArray('nIsh',nIOrb,nIrrep) - - If(iMp2prpt .ne. 2) Then - If (DoCAS.and.lSA) Then - nSA=5 - Do i=1,nSA - Call Allocate_DT(DMLT(i),nBas,nBas,nSym,aCase='TRI') - DMLT(i)%A0(:) = D0(:,i) - End Do -*Refold some density matrices - Do iIrrep = 0, nIrrep-1 - ij = 0 - Do iBas = 1, nBas(iIrrep) - Do jBas = 1, iBas-1 - ij = ij + 1 - DMLT(1)%SB(iIrrep+1)%A1(ij)= - & Two*DMLT(1)%SB(iIrrep+1)%A1(ij) - DMLT(3)%SB(iIrrep+1)%A1(ij)= - & Two*DMLT(3)%SB(iIrrep+1)%A1(ij) - DMLT(5)%SB(iIrrep+1)%A1(ij)= - & Two*DMLT(5)%SB(iIrrep+1)%A1(ij) - EndDo - ij = ij + 1 - EndDo - EndDo - Else - Call Allocate_DT(DMLT(1),nBas,nBas,nSym,aCase='TRI') - Call Get_D1AO_Var(DMLT(1)%A0,nDens) - EndIf - Else - Call Allocate_DT(DMLT(1),nBas,nBas,nSym,aCase='TRI') - Call Get_D1AO(DMLT(1)%A0,nDens) - End If -* - If (nKdens.eq.2) Then - Call Allocate_DT(DMLT(2),nBas,nBas,nSym,aCase='TRI') -! spin-density matrix - Call Get_D1SAO_Var(DMLT(2)%A0,nDens) - Call daxpy_(nDens,-One,DMLT(1)%A0,1, - & DMLT(2)%A0,1) - call dscal_(nDens,-Half,DMLT(2)%A0,1) ! beta DMAT - Call daxpy_(nDens,-One,DMLT(2)%A0,1, - & DMLT(1)%A0,1) ! alpha DMAT - ElseIf (nKdens.gt.4 .or. nKdens.lt.1) Then - Call WarningMessage(2, - & 'Compute_AuxVec: invalid nKdens!!') - Call Abend() - EndIf - If(iMp2prpt.eq.2) Then - Call Allocate_DT(DLT2,nBas,nBas,nSym,aCase='TRI') - Call Get_D1AO_Var(DLT2%A0,nDens) - Call daxpy_(nDens,-One,DMLT(1)%A0,1,DLT2%A0,1) - Else - End If -************************************************************************ -* * -* Compute Fr+In+Ac localized orbitals * -* using Cholesky decomposition for PD matrices * -* using Eigenvalue decomposition for non-PD matrices (SA-CASSCF) * -* * -************************************************************************ -* DoExchange=Exfac.ne.Zero -* - Call Get_cArray('Relax Method',Method,8) - If (Method.eq.'MCPDFT ' ) exfac=1.0d0 - DoExchange=Exfac.ne.Zero - - If (DoExchange .or. DoCAS) Then - Do i=1,nKdens - Call Allocate_DT(ChM(i),nBas,nBas,nSym) - End Do - If (lSA) Then - Call mma_allocate(TmpD,nDens,Label='TmpD') - EndIf -* * -************************************************************************ -* * -* PD matrices -* - Call Allocate_DT(DSQ,nBas,nBas,nSym) - Do j=1,nKvec - If (lSA) Then - If (j.eq.1) Then - call dcopy_(nDens,DMLT(1)%A0,1,TmpD,1) - Else If (j.eq.2) Then - call dcopy_(nDens,DMLT(3)%A0,1,TmpD,1) - EndIf - Call UnFold(TmpD,nDens,DSQ%A0,SIZE(DSQ%A0),nIrrep,nBas) - Else - Call UnFold(DMLT(j)%A0,nDens,DSQ%A0,SIZE(DSQ%A0), - & nIrrep,nBas) - EndIf -* - Do i=0,nIrrep-1 - Call CD_InCore(DSQ%SB(i+1)%A2,nBas(i), - & ChM(j)%SB(i+1)%A2, - & nBas(i),nChOrb(i,j),1.0d-12,irc) - End Do - If (irc.ne.0) Then - Write (6,*) - & 'Compute_AuxVec: failed to get Cholesky MOs !' - Call Abend() - End If - End Do -* * -************************************************************************ -* * -* non-PD matrices -* - If (lSA) Then -* - Do i=3,4 -* -** Get the appropriate density matrix -* - If (i.eq.3) Then - call dcopy_(nDens,DMLT(2)%A0,1,TmpD,1) - Else If (i.eq.4) Then - call dcopy_(nDens,DMLT(4)%A0,1,TmpD,1) - EndIf -* -** And eigenvalue-decompose it -* - iOffDSQ=0 - Do isym=0,nIrrep-1 -* - ChM(i)%SB(iSym+1)%A2(:,:)=Zero - call dcopy_(nbas(isym),[One],0, - & ChM(i)%SB(iSym+1)%A2,nBas(isym)+1) - Call NIdiag(TmpD(1+iOffDSQ),ChM(i)%SB(iSym+1)%A2, - & nBas(isym),nBas(isym)) -* -** First sort eigenvectors and eigenvalues -* - Do j=1,nBas(isym) - irun=iOffDSQ+j*(j+1)/2 - Do k=j,nBas(isym) - jrun=iOffDSQ+k*(k+1)/2 - If (TmpD(irun).lt.TmpD(jrun)) Then - tmp=TmpD(irun) - TmpD(irun)=TmpD(jrun) - TmpD(jrun)=tmp - Do l=1,nBas(isym) - tmp=ChM(i)%SB(iSym+1)%A2(l,j) - ChM(i)%SB(iSym+1)%A2(l,j) - & = ChM(i)%SB(iSym+1)%A2(l,k) - ChM(i)%SB(iSym+1)%A2(l,k)=tmp - End Do - End If - End Do - End Do -* - Cho_thrs=1.0d-12 - - l = 0 - Do j=1,nBas(isym) - If (TmpD(iOffDSQ+j*(j+1)/2).gt.Cho_thrs) Then - l=l+1 - tmp=Sqrt(TmpD(iOffDSQ+j*(j+1)/2)) - Do k=1,nBas(isym) - ChM(i)%SB(iSym+1)%A2(k,l) = - & ChM(i)%SB(iSym+1)%A2(k,j)*tmp - End Do - EndIf - End Do - npos(isym,i-2)=l -* - Do j=1,nBas(isym) - If (-TmpD(iOffDSQ+j*(j+1)/2).gt.Cho_thrs) Then - l=l+1 - irun=(l-1)*nBas(isym) - jrun=(j-1)*nBas(isym) - tmp=Sqrt(-TmpD(iOffDSQ+j*(j+1)/2)) - Do k=1,nBas(isym) - ChM(i)%SB(iSym+1)%A2(k,l) = - & ChM(i)%SB(iSym+1)%A2(k,j)*tmp - End Do - EndIf - End Do - nChOrb(isym,i)=l -* - iOffDSQ=iOffDSQ+nBas(isym)*(nBas(isym)+1)/2 - End Do -* - End Do -* -** Refold the other DM -* - Do iIrrep = 0, nIrrep-1 - ij = 0 - Do iBas = 1, nBas(iIrrep) - Do jBas = 1, iBas-1 - ij = ij + 1 - DMLT(2)%SB(iIrrep+1)%A1(ij)= - & Two * DMLT(2)%SB(iIrrep+1)%A1(ij) - DMLT(4)%SB(iIrrep+1)%A1(ij)= - & Two * DMLT(4)%SB(iIrrep+1)%A1(ij) - EndDo - ij = ij + 1 - EndDo - EndDo - EndIf - Call Deallocate_DT(DSQ) - If (lSA) Call mma_deallocate(TmpD) - EndIf -************************************************************************ -* * -* First contract the RI vectors with the density matrix * -* * -************************************************************************ -* --- Pointers to the Cholesky vectors of P2 - mAO=0 - iOff=0 - Do kIrrep=0,nIrrep-1 ! compound symmetry - iOff2=0 - Do jIrrep=0,nIrrep-1 - iIrrep=iEOR(jIrrep,kIrrep) - If (iIrrep.lt.jIrrep) Then - nnAorb=nASh(iIrrep)*nAsh(jIrrep) - ElseIf (iIrrep.eq.jIrrep) Then - nnAorb=nAsh(iIrrep)*(nAsh(iIrrep)+1)/2 - Else - Go To 100 - EndIf - ipTxy(iIrrep,jIrrep,1) = 1 + iOff2+iOff - ipTxy(jIrrep,iIrrep,1) = ipTxy(iIrrep,jIrrep,1) - If (lSA) Then - ipTxy(iIrrep,jIrrep,2) = ipTxy(iIrrep,jIrrep,1)+n_Txy - ipTxy(jIrrep,iIrrep,2) = ipTxy(iIrrep,jIrrep,2) - EndIf - iOff2=iOff2+nnAorb -100 Continue - End Do - iOff=iOff+iOff2*nnP(kIrrep) - mAO=mAO+nBas(kIrrep)*nASh(kIrrep) - End Do - - Allocate(AOrb(nADens)) - Do iADens = 1, nADens - Call Allocate_DT(AOrb(iADens),nAsh,nBas,nIrrep) - End Do - -* -* --- Reordering of the active MOs : C(a,v) ---> C(v,a) -* - iCount=0 - Do iIrrep=0,nIrrep-1 - - jCount = iCount + nBas(iIrrep)*nIOrb(iIrrep) - - iCount = iCount + nBas(iIrrep)**2 - If (nBas(iIrrep)*nASh(iIrrep)==0) Cycle - - Do iADens=1, nADens - - Do i=1,nASh(iIrrep) - kOff1 = 1 + jCount + nBas(iIrrep)*(i-1) - AOrb(iADens)%SB(iIrrep+1)%A2(i,1:nBas(iIrrep)) = - & CMO(kOff1:kOff1-1+nBas(iIrrep),iADens) - End Do - - End Do ! iADens - - End Do ! iIrrep -* - If (nKdens.eq.2) Then ! for Coulomb term - Call daxpy_(nDens,One,DMLT(2)%A0,1,DMLT(1)%A0,1) - EndIf -* -* Add the density of the environment in a OFE calculation (Coulomb) -* - Call OFembed_dmat(DMlt(1)%A0,nDens) -* -* nScreen=10 ! Some default values for the screening parameters -* dmpK=One - Estimate=.False. - Update=.True. - Call Cho_Get_Grad(irc,nKdens,DMLT,DLT2,ChM, - & Txy,n_Txy*nAdens,ipTxy, - & DoExchange,lSA,nChOrb,AOrb,nAsh, - & DoCAS,Estimate,Update, - & V_k(jp_V_k,1), nV_k, - & U_k(jp_U_k), - & Z_p_k(jp_Z_p_k,1), nZ_p_k, - & nnP,npos) -* - If (irc.ne.0) Then - Call WarningMessage(2, - & 'Compute_AuxVec: failed in Cho_Get_Grad !!') - Call Abend() - End If - - If (DoCAS .or. DoExchange) Then - Do i=1,nKdens - Call deallocate_DT(ChM(i)) - End Do - EndIf - If(iMp2prpt.eq.2) Then - Call deallocate_DT(DLT2) - End If -* - End If ! no vectors on this node -* -* For parallel run: reordering of the V_k(tilde) vector from -* the "node storage" to the Q-vector storage - If (nProc.gt.1) Then - Do i = 1, SIZE(V_K,2) - Call Reord_Vk(ipVk,nProc,myProc,nV_l,nV_t,[1],1,V_k(:,i)) - End Do - End If -************************************************************************ -* * -* Second step: contract with the Q-vectors to produce V_k * -* ~ T * -* V = V Q * -* * -************************************************************************ -* - If (Cholesky.and..Not.Do_RI) Then ! to cope with the calls below - nBas_Aux(0)=nBas_Aux(0)+1 - End If -* - Call mma_maxDBLE(MemMax) -* - If (Force_out_of_Core) MemMax=4*(nQvMax)/10 - nQv = Min(MemMax,nQvMax) - Call mma_allocate(Qv,nQv,Label='Qv') -* -** Coulomb -* - Do i=0,nJdens-1 - Call Mult_Vk_Qv_s(V_k(ipVk(1),1+i),nV_t(0),Qv,nQv, - & Scr,nQMax,nBas_Aux,nV_t(0),nIrrep,'T') - call dcopy_(nV_k,Scr,1,V_k(ipVk(1),1+i),1) - End Do -* -** MP2 -* - If(iMp2prpt.eq.2) Then - Call Mult_Vk_Qv_s(U_k(ipUk(1)),nU_t(0),Qv,nQv, - & Scr,nQMax,nBas_Aux,nU_t(0),nIrrep,'T') - call dcopy_(nV_k,Scr,1,U_k(ipUk(1)),1) - End If -* -** Active term -* - If (DoCAS) Then ! reorder Zp_k - - Call mma_allocate(Zv,nZ_p_k,Label='Zv') -* - Do iAvec=1,nAvec - If (nProc.gt.1) Call Reord_Vk(ipZpk(1),nProc,myProc, - & nV_l,nV_t,nnP,nIrrep,Z_p_k(:,iAVec)) -* - Call Mult_Zp_Qv_s(Z_p_k(ipZpk(1),iAvec),nZ_p_k,Qv,nQv, - & Zv,nZ_p_k,nV_t,nnP,nBas_Aux,nIrrep,'T') -* - call dcopy_(nZ_p_k,Zv,1,Z_p_k(ipZpk(1),iAvec),1) - End Do - Call mma_deallocate(Zv) - EndIf -* - Call mma_deallocate(Qv) - Call mma_deallocate(Scr) -* -** Exchange -* - If (DoExchange) Then - DoCholExch = .true. - Do iSO=1,nKvec - Call Mult_RijK_QKL(iSO,nBas_aux,nIrrep) - End Do - If(iMp2prpt.eq.2) Then - Call Mult_with_Q_MP2(nBas_aux,nBas,nIrrep) - End If - End If - If (Cholesky.and..Not.Do_RI) nBas_Aux(0)=nBas_Aux(0)-1 -* - Return - End -* * -************************************************************************ -************************************************************************ -************************************************************************ - Subroutine OFembed_dmat(Dens,nDens) - - use OFembed, only: Do_OFemb - Implicit Real*8 (a-h,o-z) - Real*8 Dens(nDens) -#include "stdalloc.fh" - Character*16 NamRfil - Real*8, Allocatable :: D_Var(:) - - If (.not.Do_OFemb) Return -* - Call Get_NameRun(NamRfil) ! save the old RUNFILE name - Call NameRun('AUXRFIL') ! switch RUNFILE name - - Call mma_allocate(D_var,nDens,Label='D_var') - Call get_dArray('D1aoVar',D_var,nDens) - Call daxpy_(nDens,One,D_var,1,Dens,1) - Call mma_deallocate(D_Var) -* - Call NameRun(NamRfil) ! switch back to old RUNFILE name -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/compute_auxvec.F90 openmolcas-22.10/src/ri_util/compute_auxvec.F90 --- openmolcas-22.02/src/ri_util/compute_auxvec.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/compute_auxvec.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,437 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Compute_AuxVec(ipVk,ipZpk,myProc,nProc,nVec) + +use Index_Functions, only: nTri_Elem +use pso_stuff, only: AOrb, CMO, D0, lPSO, lSA, n_Txy, nDens, nnP, npos, nV_k, nZ_p_k, Txy, U_k, V_k, Z_p_k +use Basis_Info, only: nBas, nBas_Aux +use Gateway_global, only: force_out_of_core +use RICD_Info, only: Cholesky, Do_RI +use Symmetry_Info, only: Mul, nIrrep +use Data_Structures, only: Allocate_DT, Deallocate_DT, DSBA_Type +use RI_glob, only: DMLT, DoCholExch, iMP2prpt, nAdens, nAvec, nChOrb, nJdens, nKdens, nKvec +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Half +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nProc, nVec, ipVk(nProc,nVec), ipZpk(nProc), myProc +#include "cholesky.fh" +#include "etwas.fh" +#include "chotime.fh" +integer(kind=iwp) :: i, iADens, iAvec, iBas, iCount, iIrrep, ij, iOff, iOff2, iOffDSQ, ipTxy(0:7,0:7,2), irc, irun, iSO, isym, j, & + jCount, jIrrep, jp_U_k, jp_V_k, jp_Z_p_k, jrun, k, kIrrep, kOff1, l, mAO, MemMax, NChVMx, nIOrb(0:7), nnAorb, & + nQMax, nQv, nQvMax, nSA, nU_l(0:7), nU_ls, nU_t(0:7), nV_l(0:7), nV_ls, nV_t(0:7) +real(kind=wp) :: Cho_thrs, tmp +logical(kind=iwp) :: DoCAS, DoExchange, Estimate, Update +character(len=8) :: Method +type(DSBA_Type) :: ChM(5), DLT2, DSQ +real(kind=wp), allocatable :: Qv(:), Scr(:), TmpD(:), Zv(:) + +! * +!*********************************************************************** +! * +DoExchange = Exfac /= Zero + +nV_l(0:nIrrep-1) = NumCho(1:nIrrep) ! local # of vecs in parallel run +nV_t(0:nIrrep-1) = NumCho(1:nIrrep) +nV_ls = 0 +do i=0,nIrrep-1 + nV_ls = nV_ls+nV_l(i) +end do +call GAIGOP(nV_t,nIrrep,'+') ! total # of vecs +if (nV_t(0) == 0) then + call WarningMessage(2,'Compute_AuxVec: no total symmetric vectors!!') + call Abend() +end if + +if (iMp2prpt == 2) then + if (nVec < 2) then + write(u6,*) 'nVec < 2, no ipUk input present!' + call Abend() + end if + nU_l(0:nIrrep-1) = NumCho(1:nIrrep) ! local # of vecs in parallel run + nU_t(0:nIrrep-1) = NumCho(1:nIrrep) + nU_ls = 0 + do i=0,nIrrep-1 + nU_ls = nU_ls+nU_l(i) + end do + call GAIGOP(nU_t,nIrrep,'+') ! total # of vecs + if (nU_t(0) == 0) then + call WarningMessage(2,'Compute_AuxVec: no total symmetric vectors!!') + call Abend() + end if +end if + +NChVMx = 0 +nQMax = 0 +do i=0,nIrrep-1 + NChVMx = max(NChVMx,nV_t(i)) + nQMax = max(nQMax,nBas_Aux(i)) +end do +nChOrb(0:nIrrep-1,1:2) = 0 +nQvMax = nQMax*NChVMx +call mma_allocate(Scr,nQMax) + +DoCAS = lPSO + +if (nV_ls >= 1) then ! can be = 0 in a parallel run + + jp_V_k = ipVk(myProc,1) + jp_Z_p_k = ipZpk(myProc) + jp_U_k = 1 + if (iMp2prpt == 2) then + jp_U_k = ipVk(myProc,2) + end if + !********************************************************************* + ! * + ! Get (and transform) the density matrices * + ! * + !********************************************************************* + + Timings = .false. + !Timings = .true. + + call Get_iArray('nIsh',nIOrb,nIrrep) + + if (iMp2prpt /= 2) then + if (DoCAS .and. lSA) then + nSA = 5 + do i=1,nSA + call Allocate_DT(DMLT(i),nBas,nBas,nSym,aCase='TRI') + DMLT(i)%A0(:) = D0(:,i) + end do + ! Refold some density matrices + do iIrrep=0,nIrrep-1 + ij = 1 + do iBas=2,nBas(iIrrep) + DMLT(1)%SB(iIrrep+1)%A1(ij+1:ij+iBas-1) = Two*DMLT(1)%SB(iIrrep+1)%A1(ij+1:ij+iBas-1) + DMLT(3)%SB(iIrrep+1)%A1(ij+1:ij+iBas-1) = Two*DMLT(3)%SB(iIrrep+1)%A1(ij+1:ij+iBas-1) + DMLT(5)%SB(iIrrep+1)%A1(ij+1:ij+iBas-1) = Two*DMLT(5)%SB(iIrrep+1)%A1(ij+1:ij+iBas-1) + ij = ij+iBas + end do + end do + else + call Allocate_DT(DMLT(1),nBas,nBas,nSym,aCase='TRI') + call Get_D1AO_Var(DMLT(1)%A0,nDens) + end if + else + call Allocate_DT(DMLT(1),nBas,nBas,nSym,aCase='TRI') + call Get_D1AO(DMLT(1)%A0,nDens) + end if + + if (nKdens == 2) then + call Allocate_DT(DMLT(2),nBas,nBas,nSym,aCase='TRI') + ! spin-density matrix + call Get_D1SAO_Var(DMLT(2)%A0,nDens) + DMLT(2)%A0(:) = Half*(DMLT(1)%A0-DMLT(2)%A0) ! beta DMAT + DMLT(1)%A0(:) = DMLT(1)%A0-DMLT(2)%A0 ! alpha DMAT + else if ((nKdens > 4) .or. (nKdens < 1)) then + call WarningMessage(2,'Compute_AuxVec: invalid nKdens!!') + call Abend() + end if + if (iMp2prpt == 2) then + call Allocate_DT(DLT2,nBas,nBas,nSym,aCase='TRI') + call Get_D1AO_Var(DLT2%A0,nDens) + DLT2%A0(:) = DLT2%A0-DMLT(1)%A0 + else + end if + !********************************************************************* + ! * + ! Compute Fr+In+Ac localized orbitals * + ! using Cholesky decomposition for PD matrices * + ! using Eigenvalue decomposition for non-PD matrices (SA-CASSCF) * + ! * + !********************************************************************* + !DoExchange = Exfac /= Zero + + call Get_cArray('Relax Method',Method,8) + if (Method == 'MCPDFT ') exfac = One + DoExchange = Exfac /= Zero + + if (DoExchange .or. DoCAS) then + do i=1,nKdens + call Allocate_DT(ChM(i),nBas,nBas,nSym) + end do + if (lSA) then + call mma_allocate(TmpD,nDens,Label='TmpD') + end if + ! * + !******************************************************************* + ! * + ! PD matrices + + call Allocate_DT(DSQ,nBas,nBas,nSym) + do j=1,nKvec + if (lSA) then + if (j == 1) then + TmpD(:) = DMLT(1)%A0 + else if (j == 2) then + TmpD(:) = DMLT(3)%A0 + end if + call UnFold(TmpD,nDens,DSQ%A0,size(DSQ%A0),nIrrep,nBas) + else + call UnFold(DMLT(j)%A0,nDens,DSQ%A0,size(DSQ%A0),nIrrep,nBas) + end if + + do i=0,nIrrep-1 + call CD_InCore(DSQ%SB(i+1)%A2,nBas(i),ChM(j)%SB(i+1)%A2,nBas(i),nChOrb(i,j),1.0e-12_wp,irc) + end do + if (irc /= 0) then + write(u6,*) 'Compute_AuxVec: failed to get Cholesky MOs !' + call Abend() + end if + end do + ! * + !******************************************************************* + ! * + ! non-PD matrices + + if (lSA) then + + do i=3,4 + + ! Get the appropriate density matrix + + if (i == 3) then + TmpD(:) = DMLT(2)%A0 + else if (i == 4) then + TmpD(:) = DMLT(4)%A0 + end if + + ! And eigenvalue-decompose it + + iOffDSQ = 0 + do isym=0,nIrrep-1 + + ChM(i)%SB(iSym+1)%A2(:,:) = Zero + call dcopy_(nbas(isym),[One],0,ChM(i)%SB(iSym+1)%A2,nBas(isym)+1) + call NIdiag(TmpD(1+iOffDSQ),ChM(i)%SB(iSym+1)%A2,nBas(isym),nBas(isym)) + + ! First sort eigenvectors and eigenvalues + + do j=1,nBas(isym) + irun = iOffDSQ+nTri_Elem(j) + do k=j,nBas(isym) + jrun = iOffDSQ+nTri_Elem(k) + if (TmpD(irun) < TmpD(jrun)) then + tmp = TmpD(irun) + TmpD(irun) = TmpD(jrun) + TmpD(jrun) = tmp + do l=1,nBas(isym) + tmp = ChM(i)%SB(iSym+1)%A2(l,j) + ChM(i)%SB(iSym+1)%A2(l,j) = ChM(i)%SB(iSym+1)%A2(l,k) + ChM(i)%SB(iSym+1)%A2(l,k) = tmp + end do + end if + end do + end do + + Cho_thrs = 1.0e-12_wp + + l = 0 + do j=1,nBas(isym) + if (TmpD(iOffDSQ+nTri_Elem(j)) > Cho_thrs) then + l = l+1 + tmp = sqrt(TmpD(iOffDSQ+nTri_Elem(j))) + ChM(i)%SB(iSym+1)%A2(:,l) = tmp*ChM(i)%SB(iSym+1)%A2(:,j) + end if + end do + npos(isym,i-2) = l + + do j=1,nBas(isym) + if (-TmpD(iOffDSQ+nTri_Elem(j)) > Cho_thrs) then + l = l+1 + irun = (l-1)*nBas(isym) + jrun = (j-1)*nBas(isym) + tmp = sqrt(-TmpD(iOffDSQ+nTri_Elem(j))) + ChM(i)%SB(iSym+1)%A2(:,l) = tmp*ChM(i)%SB(iSym+1)%A2(:,j) + end if + end do + nChOrb(isym,i) = l + + iOffDSQ = iOffDSQ+nTri_Elem(nBas(isym)) + end do + + end do + + ! Refold the other DM + + do iIrrep=0,nIrrep-1 + ij = 1 + do iBas=2,nBas(iIrrep) + DMLT(2)%SB(iIrrep+1)%A1(ij+1:ij+iBas-1) = Two*DMLT(2)%SB(iIrrep+1)%A1(ij+1:ij+iBas-1) + DMLT(4)%SB(iIrrep+1)%A1(ij+1:ij+iBas-1) = Two*DMLT(4)%SB(iIrrep+1)%A1(ij+1:ij+iBas-1) + ij = ij+iBas + end do + end do + end if + call Deallocate_DT(DSQ) + if (lSA) call mma_deallocate(TmpD) + end if + !********************************************************************* + ! * + ! First contract the RI vectors with the density matrix * + ! * + !********************************************************************* + ! Pointers to the Cholesky vectors of P2 + mAO = 0 + iOff = 0 + do kIrrep=0,nIrrep-1 ! compound symmetry + iOff2 = 0 + do jIrrep=0,nIrrep-1 + iIrrep = Mul(jIrrep+1,kIrrep+1)-1 + if (iIrrep < jIrrep) then + nnAorb = nASh(iIrrep)*nAsh(jIrrep) + else if (iIrrep == jIrrep) then + nnAorb = nTri_Elem(nAsh(iIrrep)) + else + cycle + end if + ipTxy(iIrrep,jIrrep,1) = 1+iOff2+iOff + ipTxy(jIrrep,iIrrep,1) = ipTxy(iIrrep,jIrrep,1) + if (lSA) then + ipTxy(iIrrep,jIrrep,2) = ipTxy(iIrrep,jIrrep,1)+n_Txy + ipTxy(jIrrep,iIrrep,2) = ipTxy(iIrrep,jIrrep,2) + end if + iOff2 = iOff2+nnAorb + end do + iOff = iOff+iOff2*nnP(kIrrep) + mAO = mAO+nBas(kIrrep)*nASh(kIrrep) + end do + + call Allocate_DT(AOrb,nADens,nAsh,nBas,nIrrep,label='AOrb') + + ! Reordering of the active MOs : C(a,v) ---> C(v,a) + + iCount = 0 + do iIrrep=0,nIrrep-1 + + jCount = iCount+nBas(iIrrep)*nIOrb(iIrrep) + + iCount = iCount+nBas(iIrrep)**2 + if (nBas(iIrrep)*nASh(iIrrep) == 0) cycle + + do iADens=1,nADens + + do i=1,nASh(iIrrep) + kOff1 = 1+jCount+nBas(iIrrep)*(i-1) + AOrb(iADens)%SB(iIrrep+1)%A2(i,1:nBas(iIrrep)) = CMO(kOff1:kOff1-1+nBas(iIrrep),iADens) + end do + + end do ! iADens + + end do ! iIrrep + + if (nKdens == 2) DMLT(1)%A0(:) = DMLT(1)%A0+DMLT(2)%A0 ! for Coulomb term + + ! Add the density of the environment in a OFE calculation (Coulomb) + + call OFembed_dmat(DMlt(1)%A0,nDens) + + !nScreen = 10 ! Some default values for the screening parameters + !dmpK = One + Estimate = .false. + Update = .true. + call Cho_Get_Grad(irc,nKdens,DMLT,DLT2,ChM,Txy,n_Txy*nAdens,ipTxy,DoExchange,lSA,nChOrb,AOrb,nAsh,DoCAS,Estimate,Update, & + V_k(jp_V_k,1),nV_k,U_k(jp_U_k),Z_p_k(jp_Z_p_k,1),nZ_p_k,nnP,npos) + + if (irc /= 0) then + call WarningMessage(2,'Compute_AuxVec: failed in Cho_Get_Grad !!') + call Abend() + end if + + if (DoCAS .or. DoExchange) then + do i=1,nKdens + call deallocate_DT(ChM(i)) + end do + end if + if (iMp2prpt == 2) then + call deallocate_DT(DLT2) + end if + +end if ! no vectors on this node + +! For parallel run: reordering of the V_k(tilde) vector from +! the "node storage" to the Q-vector storage +if (nProc > 1) then + do i=1,size(V_K,2) + call Reord_Vk(ipVk(:,1),nProc,myProc,nV_l,nV_t,[1],1,V_k(:,i)) + end do +end if +!*********************************************************************** +! * +! Second step: contract with the Q-vectors to produce V_k * +! ~ T * +! V = V Q * +! * +!*********************************************************************** + +if (Cholesky .and. (.not. Do_RI)) then ! to cope with the calls below + nBas_Aux(0) = nBas_Aux(0)+1 +end if + +call mma_maxDBLE(MemMax) + +if (Force_out_of_Core) MemMax = 4*(nQvMax)/10 +nQv = min(MemMax,nQvMax) +call mma_allocate(Qv,nQv,Label='Qv') + +! Coulomb + +do i=1,nJdens + call Mult_Vk_Qv_s(V_k(ipVk(1,1),i),nV_t(0),Qv,nQv,Scr,nQMax,nBas_Aux,nV_t(0),nIrrep,'T') + V_k(ipVk(1,1):ipVk(1,1)+nV_k-1,i) = Scr(1:nV_k) +end do + +! MP2 + +if (iMp2prpt == 2) then + call Mult_Vk_Qv_s(U_k(ipVk(1,2)),nU_t(0),Qv,nQv,Scr,nQMax,nBas_Aux,nU_t(0),nIrrep,'T') + U_k(ipVk(1,2):ipVk(1,2)+nV_k-1) = Scr(1:nV_k) +end if + +! Active term + +if (DoCAS) then ! reorder Zp_k + + call mma_allocate(Zv,nZ_p_k,Label='Zv') + + do iAvec=1,nAvec + if (nProc > 1) call Reord_Vk(ipZpk,nProc,myProc,nV_l,nV_t,nnP,nIrrep,Z_p_k(:,iAVec)) + + call Mult_Zp_Qv_s(Z_p_k(ipZpk(1),iAvec),nZ_p_k,Qv,nQv,Zv,nZ_p_k,nV_t,nnP,nBas_Aux,nIrrep,'T') + + Z_p_k(ipZpk(1):ipZpk(1)+nZ_p_k-1,iAvec) = Zv + end do + call mma_deallocate(Zv) +end if + +call mma_deallocate(Qv) +call mma_deallocate(Scr) + +! Exchange + +if (DoExchange) then + DoCholExch = .true. + do iSO=1,nKvec + call Mult_RijK_QKL(iSO,nBas_aux,nIrrep) + end do + if (iMp2prpt == 2) then + call Mult_with_Q_MP2(nBas_aux,nBas,nIrrep) + end if +end if +if (Cholesky .and. (.not. Do_RI)) nBas_Aux(0) = nBas_Aux(0)-1 + +return + +end subroutine Compute_AuxVec diff -Nru openmolcas-22.02/src/ri_util/compute_b.f openmolcas-22.10/src/ri_util/compute_b.f --- openmolcas-22.02/src/ri_util/compute_b.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/compute_b.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 2010, Jonas Bostrom * -************************************************************************ - Real*8 Function Compute_B(irc,kSOk,lSOl,jAOj,nBasFnc,iOpt) -****************************************************************** -* * -* Author Jonas Bostrom, June 2010 * -* * -* Purpose: To do part of MP2 gradient. * -* * -****************************************************************** - use ExTerm, only: BMP2 - Implicit Real*8 (a-h,o-z) - Integer irc,kSOk,lSOl,jAOj,nBasFnc,iOpt -#include "exterm.fh" - - - B_mp2 = 0.0d0 - iOff1 = (jAOj)*nBasFnc*nBasFnc + (kSOk-1)*nBasFnc + lSOl - iOff2 = (jAOj)*nBasFnc*nBasFnc + (lSOl-1)*nBasFnc + kSOk - B_mp2 = B_mp2 + (Bmp2(iOff1,iOpt)+Bmp2(iOff2,iOpt))/2.0d0 - Compute_B = B_mp2 - irc=0 - - End diff -Nru openmolcas-22.02/src/ri_util/compute_b.F90 openmolcas-22.10/src/ri_util/compute_b.F90 --- openmolcas-22.02/src/ri_util/compute_b.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/compute_b.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,38 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 2010, Jonas Bostrom * +!*********************************************************************** + +function Compute_B(irc,kSOk,lSOl,jAOj,nBasFnc,iOpt) +!*********************************************************************** +! * +! Author Jonas Bostrom, June 2010 * +! * +! Purpose: To do part of MP2 gradient. * +! * +!*********************************************************************** + +use RI_glob, only: BMP2 +use Constants, only: Half +use Definitions, only: wp, iwp + +implicit none +real(kind=wp) :: Compute_B +integer(kind=iwp), intent(out) :: irc +integer(kind=iwp), intent(in) :: kSOk, lSOl, jAOj, nBasFnc, iOpt +integer(kind=iwp) :: iOff1, iOff2 + +iOff1 = jAOj*nBasFnc*nBasFnc+(kSOk-1)*nBasFnc+lSOl +iOff2 = jAOj*nBasFnc*nBasFnc+(lSOl-1)*nBasFnc+kSOk +Compute_B = (Bmp2(iOff1,iOpt)+Bmp2(iOff2,iOpt))*Half +irc = 0 + +end function Compute_B diff -Nru openmolcas-22.02/src/ri_util/compute_txy.f openmolcas-22.10/src/ri_util/compute_txy.f --- openmolcas-22.02/src/ri_util/compute_txy.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/compute_txy.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,164 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - subroutine compute_txy(DM1,nDM,Txy,nTxy,nAuxVec,nIrrep,Diag, - & DMTmp,nAct) -************************************************************************ -* * -* Compute the matrices needed for CD-CASSCF gradients * -* * -* input : G2 = 2-body density matrix * -* nDM = size of the one-body DM * -* * -************************************************************************ - use pso_stuff, only: lsa, G2, nnP - Implicit none -#include "real.fh" - Integer nTxy,nAct(0:7),nCumAct(0:7),nCumAct2(0:7) - Integer nDM,i,j,icol,iline - Integer ista,iend,jsta,jend,ksta,kend,lsta,lend,isym,jsym, - & ksym,lsym,klsym,it,iu,iv,ix,itu,ivx,ituvx,ituvx2, - & nvx,itx,itv,iuv,iux,nkl,Txy_sta,Txy_sta2 - Integer nAuxVec,iVec,nIrrep - Real*8 Fac,Fac2,tmp - Real*8 DM1(nDM,nAuxVec), - & Txy(nTxy,nAuxVec),Diag(nDM,nAuxVec), - & DMtmp(nDM*(nDM+1)/2) -* - nCumAct(0)=0 - Do i=1,nIrrep-1 - nCumAct(i)=nCumAct(i-1)+nAct(i-1) - End Do -* - Do iVec=1,nAuxVec -************************************************************************ -* * -* Remove Coulomb and exchange contribution from the 2DM * -* * -************************************************************************ - Txy_sta=1 - Txy_sta2=1 - Do klsym=0,nIrrep-1 ! compound symmetry - nkl=0 -* - Do lSym=0,nIrrep-1 - lsta=nCumAct(lsym)+1 - lend=nCumAct(lsym)+nAct(lSym) - - ksym=iEOR(lsym,klsym) - If (ksym.gt.lsym) Go To 100 - ksta=nCumAct(ksym)+1 - kend=nCumAct(ksym)+nAct(ksym) - If (kSym.eq.lSym) Then - nvx=nAct(lSym)*(nAct(lSym)+1)/2 - Else - nvx=nAct(lSym)*nAct(ksym) - EndIf - nCumAct2(lSym)=nkl -* - Do jsym=0,lSym -* - jsta=nCumAct(jsym)+1 - jend=nCumAct(jsym)+nAct(jSym) - - isym=iEOR(jsym,klsym) - If (isym.gt.jsym) Go To 101 - ista=nCumAct(iSym)+1 - iend=nCumAct(iSym)+nAct(iSym) -* - iline=nkl -* - Do ix=lsta,lend - If (kSym.eq.lSym) kend=ix - Do iv=ksta,kend - ivx=max(ix,iv)*(max(ix,iv)-1)/2+min(ix,iv) - If (jSym.eq.lSym) jend=ix - iline=iline+1 - icol=nCumAct2(jSym) - Do iu=jsta,jend - iux=max(ix,iu)*(max(ix,iu)-1)/2+min(ix,iu) - iuv=max(iu,iv)*(max(iu,iv)-1)/2+min(iu,iv) - If (iSym.eq.jSym) iend=iu - Do it=ista,iend - itu=max(iu,it)*(max(iu,it)-1)/2+min(iu,it) - If (itu.gt.ivx) Go to 102 - itx=max(ix,it)*(max(ix,it)-1)/2+min(ix,it) - itv=max(iv,it)*(max(iv,it)-1)/2+min(iv,it) - ituvx=max(ivx,itu)*(max(ivx,itu)-1)/2+ - & min(itu,ivx) - icol=icol+1 - ituvx2=iline*(iline-1)/2+icol -* - Fac=One - If (ix.ne.iv) Fac=Two*Fac - If (it.ne.iu) Fac=Two*Fac - Fac2=One - If (it.eq.iu) Fac2=Two -* - DMTmp(ituvx2)=Fac*(Fac2*G2(ituvx,iVec)) - If (.Not.lSA) Then -*For SA-CASSCF, don't remove Coulomb and exchange - If (iSym.eq.jSym) - & DMTmp(ituvx2)=DMTmp(ituvx2)- - & Fac*(DM1(itu,iVec)*DM1(ivx,iVec)) - If (iSym.eq.kSym) - & DMTmp(ituvx2)=DMTmp(ituvx2)+ - & Fac*(Quart*DM1(itv,iVec)*DM1(iux,iVec)) - If (iSym.eq.lSym) - & DMTmp(ituvx2)=DMTmp(ituvx2)+ - & Fac*(Quart*DM1(itx,iVec)*DM1(iuv,iVec)) - EndIf -* - 102 Continue -* - End Do - End Do - End Do - End Do -* - 101 Continue - End Do - nkl=nkl+nvx - 100 Continue - End Do -* -************************************************************************ -* * -* Eigen-decompose the density * -* * -************************************************************************ -* -** Diagonalize G2 -* - Call Cho_DZero(Txy(Txy_sta2,iVec),nkl**2) - call dcopy_(nkl,[One],0,Txy(Txy_sta2,iVec),nkl+1) -* - Call NIdiag(DMTmp,Txy(Txy_sta2,iVec),nkl,nkl) -* -** Multiply by Sqrt[eigenvalue] -* - Do i=1,nkl - Diag(i+Txy_sta-1,iVec)=DMTmp(i*(i+1)/2) - tmp=Sqrt(abs(DMTmp(i*(i+1)/2))) - Do j=1,nkl - Txy(Txy_sta2+(i-1)*nkl+j-1,iVec)= - & Txy(Txy_sta2+(i-1)*nkl+j-1,iVec)*tmp - End Do - End Do -* -** Since there is no screening yet -* - nnP(klsym)=nkl -* - Txy_sta=Txy_sta+nkl - Txy_sta2=Txy_sta2+nkl**2 - End Do - End Do - end diff -Nru openmolcas-22.02/src/ri_util/compute_txy.F90 openmolcas-22.10/src/ri_util/compute_txy.F90 --- openmolcas-22.02/src/ri_util/compute_txy.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/compute_txy.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,152 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine compute_txy(DM1,nDM,Txy,nTxy,nAuxVec,nIrrep,Diag,DMTmp,nAct) +!*********************************************************************** +! * +! Compute the matrices needed for CD-CASSCF gradients * +! * +! input : G2 = 2-body density matrix * +! nDM = size of the one-body DM * +! * +!*********************************************************************** + +use Index_Functions, only: iTri, nTri_Elem +use Symmetry_Info, only: Mul +use pso_stuff, only: G2, lsa, nnP +use Constants, only: Zero, One, Two, Quart +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nDM, nTxy, nAuxVec, nIrrep, nAct(0:7) +real(kind=wp), intent(in) :: DM1(nDM,nAuxVec) +real(kind=wp), intent(out) :: Txy(nTxy,nAuxVec), Diag(nDM,nAuxVec), DMtmp(nTri_Elem(nDM)) +integer(kind=iwp) :: i, icol, iend, iline, ista, isym, it, itu, ituvx, ituvx2, itv, itx, iu, iuv, iux, iv, iVec, ivx, ix, jend, & + jsta, jsym, kend, klsym, ksta, ksym, lend, lsta, lsym, nCumAct(0:7), nCumAct2(0:7), nkl, nvx, Txy_sta, Txy_sta2 +real(kind=wp) :: Fac, Fac2, tmp + +nCumAct(0) = 0 +do i=1,nIrrep-1 + nCumAct(i) = nCumAct(i-1)+nAct(i-1) +end do + +do iVec=1,nAuxVec + !********************************************************************* + ! * + ! Remove Coulomb and exchange contribution from the 2DM * + ! * + !********************************************************************* + Txy_sta = 1 + Txy_sta2 = 1 + do klsym=0,nIrrep-1 ! compound symmetry + nkl = 0 + + do lSym=0,nIrrep-1 + lsta = nCumAct(lsym)+1 + lend = nCumAct(lsym)+nAct(lSym) + + ksym = Mul(lsym+1,klsym+1)-1 + if (ksym > lsym) cycle + ksta = nCumAct(ksym)+1 + kend = nCumAct(ksym)+nAct(ksym) + if (kSym == lSym) then + nvx = nTri_Elem(nAct(lSym)) + else + nvx = nAct(lSym)*nAct(ksym) + end if + nCumAct2(lSym) = nkl + + do jsym=0,lSym + + jsta = nCumAct(jsym)+1 + jend = nCumAct(jsym)+nAct(jSym) + + isym = Mul(jsym+1,klsym+1)-1 + if (isym > jsym) cycle + ista = nCumAct(iSym)+1 + iend = nCumAct(iSym)+nAct(iSym) + + iline = nkl + + do ix=lsta,lend + if (kSym == lSym) kend = ix + do iv=ksta,kend + ivx = iTri(ix,iv) + if (jSym == lSym) jend = ix + iline = iline+1 + icol = nCumAct2(jSym) + do iu=jsta,jend + iux = iTri(ix,iu) + iuv = iTri(iu,iv) + if (iSym == jSym) iend = iu + do it=ista,iend + itu = iTri(iu,it) + if (itu > ivx) cycle + itx = iTri(ix,it) + itv = iTri(iv,it) + ituvx = iTri(ivx,itu) + icol = icol+1 + ituvx2 = nTri_Elem(iline-1)+icol + + Fac = One + if (ix /= iv) Fac = Two*Fac + if (it /= iu) Fac = Two*Fac + Fac2 = One + if (it == iu) Fac2 = Two + + DMTmp(ituvx2) = Fac*(Fac2*G2(ituvx,iVec)) + if (.not. lSA) then + ! For SA-CASSCF, don't remove Coulomb and exchange + if (iSym == jSym) DMTmp(ituvx2) = DMTmp(ituvx2)-Fac*(DM1(itu,iVec)*DM1(ivx,iVec)) + if (iSym == kSym) DMTmp(ituvx2) = DMTmp(ituvx2)+Fac*(Quart*DM1(itv,iVec)*DM1(iux,iVec)) + if (iSym == lSym) DMTmp(ituvx2) = DMTmp(ituvx2)+Fac*(Quart*DM1(itx,iVec)*DM1(iuv,iVec)) + end if + + end do + end do + end do + end do + + end do + nkl = nkl+nvx + end do + + !******************************************************************* + ! * + ! Eigen-decompose the density * + ! * + !******************************************************************* + + ! Diagonalize G2 + + Txy(Txy_sta2:Txy_sta2+nkl**2-1,iVec) = Zero + call dcopy_(nkl,[One],0,Txy(Txy_sta2,iVec),nkl+1) + + call NIdiag(DMTmp,Txy(Txy_sta2,iVec),nkl,nkl) + + ! Multiply by Sqrt[eigenvalue] + + do i=1,nkl + Diag(i+Txy_sta-1,iVec) = DMTmp(nTri_Elem(i)) + tmp = sqrt(abs(DMTmp(nTri_Elem(i)))) + Txy(Txy_sta2+(i-1)*nkl:Txy_sta2+i*nkl-1,iVec) = tmp*Txy(Txy_sta2+(i-1)*nkl:Txy_sta2+i*nkl-1,iVec) + end do + + ! Since there is no screening yet + + nnP(klsym) = nkl + + Txy_sta = Txy_sta+nkl + Txy_sta2 = Txy_sta2+nkl**2 + end do +end do + +end subroutine compute_txy diff -Nru openmolcas-22.02/src/ri_util/compute_v12.f openmolcas-22.10/src/ri_util/compute_v12.f --- openmolcas-22.02/src/ri_util/compute_v12.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/compute_v12.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,78 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - SubRoutine Compute_V12(V,V12,nDim) - Implicit Real*8 (A-H,O-Z) -#include "stdalloc.fh" - Real*8 V(nDim,nDim), V12(nDim,nDim) - - Real*8, Allocatable :: Vec(:), VTri(:) -* * -************************************************************************ -* * -*define _DEBUGPRINT_ -* * -************************************************************************ -* * -* - Call mma_allocate(Vec,nDim**2,Label='Vec') - Call mma_allocate(VTri,nDim*(nDim+1)/2,Label='VTri') -* - Call Compute_V12_(V,V12,VTri,Vec,nDim) -* - Call mma_deallocate(VTri) - Call mma_deallocate(Vec) -* - Return - End - SubRoutine Compute_V12_(V,V12,VTri,Vec,nDim) - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - Real*8 V(nDim,nDim), V12(nDim,nDim), VTri(nDim*(nDim+1)/2), - & Vec(nDim,nDim) -* - Call FZero(Vec,nDim**2) - call dcopy_(nDim,[One],0,Vec,nDim+1) -* - Do i = 1, nDim - Do j = 1, i - VTri(i*(i-1)/2+j) = V(i,j) - End Do - End Do -* - Call JACOB(VTri,Vec,nDim,nDim) -* - Call FZero(V12,nDim**2) - Do i = 1, nDim -#ifdef _DEBUGPRINT_ - tmp=VTri(i*(i+1)/2) - Write (6,*) 'i,tmp=',i,tmp -#endif - tmp=Sqrt(VTri(i*(i+1)/2)) - If (tmp.lt.1.0D-90) Then - V12(i,i)=1.0D90 - Else - V12(i,i)=One/tmp - End If - End Do -* - Call DGEMM_('N','T', - & nDim,nDim,nDim, - & 1.0d0,V12,nDim, - & Vec,nDim, - & 0.0d0,V,nDim) - Call DGEMM_('N','N', - & nDim,nDim,nDim, - & 1.0d0,Vec,nDim, - & V,nDim, - & 0.0d0,V12,nDim) -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/compute_v12.F90 openmolcas-22.10/src/ri_util/compute_v12.F90 --- openmolcas-22.02/src/ri_util/compute_v12.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/compute_v12.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,63 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Compute_V12(V,V12,nDim) + +use Index_Functions, only: iTri, nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nDim +real(kind=wp), intent(inout) :: V(nDim,nDim) +real(kind=wp), intent(out) :: V12(nDim,nDim) +integer(kind=iwp) :: i, j +real(kind=wp) :: tmp +real(kind=wp), allocatable :: Vec(:,:), VTri(:) + +call mma_allocate(Vec,nDim,nDim,Label='Vec') +call mma_allocate(VTri,nTri_Elem(nDim),Label='VTri') + +Vec(:,:) = Zero +call dcopy_(nDim,[One],0,Vec,nDim+1) + +do i=1,nDim + do j=1,i + VTri(iTri(i,j)) = V(i,j) + end do +end do + +call JACOB(VTri,Vec,nDim,nDim) + +V12(:,:)= Zero +do i=1,nDim +# ifdef _DEBUGPRINT_ + tmp = VTri(iTri(i,i)) + write(u6,*) 'i,tmp=',i,tmp +# endif + tmp = sqrt(VTri(iTri(i,i))) + if (tmp < 1.0e-90_wp) then + V12(i,i) = 1.0e90_wp + else + V12(i,i) = One/tmp + end if +end do + +call DGEMM_('N','T',nDim,nDim,nDim,One,V12,nDim,Vec,nDim,Zero,V,nDim) +call DGEMM_('N','N',nDim,nDim,nDim,One,Vec,nDim,V,nDim,Zero,V12,nDim) + +call mma_deallocate(VTri) +call mma_deallocate(Vec) + +return + +end subroutine Compute_V12 diff -Nru openmolcas-22.02/src/ri_util/contract_zpk_tpxy.f openmolcas-22.10/src/ri_util/contract_zpk_tpxy.f --- openmolcas-22.02/src/ri_util/contract_zpk_tpxy.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/contract_zpk_tpxy.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,79 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - subroutine contract_Zpk_Tpxy(Zpk,nZpk,Txy,nTxy,Scrt,nScrt, - & Diag,nDiag,nnP,nBas_Aux, - & nAdens,nAvec,nAct,nIrrep) - Implicit none - Integer nZpk,nTxy,nScrt,nDiag,nIrrep,nnP(0:nIrrep-1), - & nBas_Aux(0:nIrrep-1),nact(0:nIrrep-1),nAdens,nAvec, - & i,j,k,l,nCumnnP,nCumnnP2,nCumnnP3, - & ip,jp,kp,iSym,jSym,kSym,iDen - Real*8 Zpk(nZpk,nAVec),Txy(nTxy,nAdens),Scrt(nScrt), - & Diag(nDiag,nADens) -************************************************************************ -* - Do l=1,nAVec - iDen=1 - If (l.gt.1) iDen=2 -* - nCumnnP=0 - nCumnnP2=0 - nCumnnP3=0 - Do iSym=0,nIrrep-1 - Do i=1,nBas_Aux(iSym) - ip=nCumnnP2+(i-1)*nnP(iSym) - Do j=1,nnP(iSym) - Scrt(j)=0.0d0 - Do k=1,nnP(iSym) - kp=nCumnnP3+(k-1)*nnP(iSym) - Scrt(j)=Scrt(j)+Sign(1.0d0,Diag(nCumnnP+k,iDen)) - & *Zpk(k+ip,l)*Txy(j+kp,iDen) - End Do - End Do - Do j=1,nnP(iSym) - Zpk(j+ip,l)=Scrt(j) - End Do - End Do -*Now correct for the 2 factor - Do i=1,nBas_Aux(iSym) - ip=nCumnnP2+(i-1)*nnP(iSym) - Do jSym=0,nIrrep-1 - kSym=iEOR(jsym,isym) - If (kSym.le.jSym) Then - Do j=1,nAct(jSym) - If (kSym.eq.jSym) Then - jp=ip+j*(j-1)/2 - Do k=1,j-1 - Zpk(jp+k,l)=Zpk(jp+k,l)/2.0d0 - End Do - Else - jp=ip+(j-1)*nAct(kSym) - Do k=1,nAct(kSym) - Zpk(jp+k,l)=Zpk(jp+k,l)/2.0d0 - End Do - EndIf - End Do - If (kSym.eq.jSym) Then - ip=ip+nAct(jSym)*(nAct(jSym)+1)/2 - Else - ip=ip+nAct(jSym)*nAct(kSym) - End If - End If - End Do - End Do -* -* Call RecPrt('Zpk',' ',Zpk(nCumnnP2+1,l),nnP(iSym),nBas_Aux(iSym)) - nCumnnP=nCumnnP+nnP(iSym) - nCumnnP2=nCumnnP2+nnP(iSym)*nBas_Aux(iSym) - nCumnnP3=nCumnnP3+nnP(iSym)**2 - End Do - End Do - end diff -Nru openmolcas-22.02/src/ri_util/contract_zpk_tpxy.F90 openmolcas-22.10/src/ri_util/contract_zpk_tpxy.F90 --- openmolcas-22.02/src/ri_util/contract_zpk_tpxy.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/contract_zpk_tpxy.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,79 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine contract_Zpk_Tpxy(Zpk,nZpk,Txy,nTxy,Scrt,nScrt,Diag,nDiag,nnP,nBas_Aux,nAdens,nAvec,nAct,nIrrep) + +use Index_Functions, only: nTri_Elem +use Symmetry_Info, only: Mul +use Constants, only: Zero, One, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZpk, nTxy, nScrt, nDiag, nIrrep, nnP(0:nIrrep-1), nBas_Aux(0:nIrrep-1), nAdens, nAvec, & + nAct(0:nIrrep-1) +real(kind=wp), intent(inout) :: Zpk(nZpk,nAVec) +real(kind=wp), intent(in) :: Txy(nTxy,nAdens), Diag(nDiag,nADens) +real(kind=wp), intent(out) :: Scrt(nScrt) +integer(kind=iwp) :: i, iDen, ip, iSym, j, jp, jSym, k, kp, kSym, l, nCumnnP, nCumnnP2, nCumnnP3 + +!*********************************************************************** + +do l=1,nAVec + iDen = 1 + if (l > 1) iDen = 2 + + nCumnnP = 0 + nCumnnP2 = 0 + nCumnnP3 = 0 + do iSym=0,nIrrep-1 + do i=1,nBas_Aux(iSym) + ip = nCumnnP2+(i-1)*nnP(iSym) + do j=1,nnP(iSym) + Scrt(j) = Zero + do k=1,nnP(iSym) + kp = nCumnnP3+(k-1)*nnP(iSym) + Scrt(j) = Scrt(j)+sign(One,Diag(nCumnnP+k,iDen))*Zpk(k+ip,l)*Txy(j+kp,iDen) + end do + end do + Zpk(ip+1:ip+nnP(iSym),l) = Scrt(1:nnP(iSym)) + end do + ! Now correct for the 2 factor + do i=1,nBas_Aux(iSym) + ip = nCumnnP2+(i-1)*nnP(iSym) + do jSym=0,nIrrep-1 + kSym = Mul(jsym+1,isym+1)-1 + if (kSym <= jSym) then + do j=1,nAct(jSym) + if (kSym == jSym) then + jp = ip+nTri_Elem(j-1) + Zpk(jp+1:jp+j-1,l) = Half*Zpk(jp+1:jp+j-1,l) + else + jp = ip+(j-1)*nAct(kSym) + Zpk(jp+1:jp+nAct(kSym),l) = Half*Zpk(jp+1:jp+nAct(kSym),l) + end if + end do + if (kSym == jSym) then + ip = ip+nTri_Elem(nAct(jSym)) + else + ip = ip+nAct(jSym)*nAct(kSym) + end if + end if + end do + end do + + !call RecPrt('Zpk',' ',Zpk(nCumnnP2+1,l),nnP(iSym),nBas_Aux(iSym)) + nCumnnP = nCumnnP+nnP(iSym) + nCumnnP2 = nCumnnP2+nnP(iSym)*nBas_Aux(iSym) + nCumnnP3 = nCumnnP3+nnP(iSym)**2 + end do +end do + +end subroutine contract_Zpk_Tpxy diff -Nru openmolcas-22.02/src/ri_util/create_chunk.f openmolcas-22.10/src/ri_util/create_chunk.f --- openmolcas-22.02/src/ri_util/create_chunk.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/create_chunk.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,117 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Create_Chunk(LenVec,NumVec,IncVec) - use Chunk_mod -#ifdef _MOLCAS_MPP_ - Use Para_Info, Only: MyRank, nProcs, Is_Real_Par -#endif - Implicit Real*8 (A-H,O-Z) -#include "stdalloc.fh" -#ifdef _MOLCAS_MPP_ -#include "mafdecls.fh" - External ga_create_irreg - Logical ga_create_irreg, ok - Integer myMap(2) - - -* - If (NumVec.le.0) Then - Call WarningMessage(2,'Create_Chunk: Failure NumVec.le.0') - Write (6,*) 'NumVec=',NumVec - Call Abend() - End If - - If (Is_Real_Par()) Then - Call mma_allocate(iMap,nProcs+1,Label='iMap') - iMap(:)=0 -* - FullSize=DBLE(LenVec*NumVec) - Call mma_maxDBLE(MaxMem) - iMap(1+MyRank) = MaxMem - Call GAIGOP(iMap,nProcs,'+') - TotalMemory=0.0D0 - itmp=iMap(1) -* -* Find the smallest possible memory allocation! -* - Do i = 1, nProcs-1 - itmp = Min(itmp,iMap(1+i)) - End Do - TotalMemory=DBLE(itmp)*DBLE(nProcs) -* -* Compute the number of vectors to handle at the time -* - If (TotalMemory.gt.FullSize) Then -* - IncVec = NumVec -* - Else -* - IncVec = INT ( DBLE(NumVec) *(TotalMemory/FullSize)) -* - End If - If (IncVec.le.0) Then - Call WarningMessage(2, - & 'Create_Chunk: Failure IncVec.le.0') - Write (6,*) 'FullSize=',FullSize - Write (6,*) 'NumVec=',NumVec - Write (6,*) 'LenVec=',LenVec - Write (6,*) 'TotalMemory=',TotalMemory - Write (6,*) 'Local size of memory' - Write (6,*) (iMap(i),i=1,nProcs) - Write (6,*) 'iTmp=',iTmp - Call Abend() - End If -* -* Compute the number of vectors per node, This also defines -* the Map array. -* - iNode0=0 - iStart = 1 - Do iNode = 0, nProcs-1 - If (iStart.eq.1) iNode0=iNode - iMap(1+iNode) = iStart - iStart = iStart + Max((IncVec+iNode)/nProcs,1) - End Do - iMap(1+nProcs)=iStart - IncVec0=iStart -* -C Call Put_iArray('DistVec',iMap,nProcs+1) -* - nBlocks=nProcs-iNode0 - myMap(1)=1 - Ok = GA_Create_Irreg(mt_dbl,LenVec,IncVec0,'Chunk', - & myMap,1, - & iMap(1+iNode0),nBlocks,ip_Chunk) - If (.Not. Ok) Then - Call WarningMessage(2,'Error in GA_Create_Irreg') - Call Abend() - End If - Else - Call mma_maxDBLE(MaxMem) - IncVec=Min(NumVec,MaxMem/LenVec) - Call mma_allocate(Chunk,LenVec*IncVec,Label='Chunk') - End If -* -* * -************************************************************************ -* * -#else -* * -************************************************************************ -* * - Call mma_maxDBLE(MaxMem) - IncVec=Min(NumVec,MaxMem/LenVec) - Call mma_allocate(Chunk,LenVec*IncVec,Label='Chunk') -* -#endif - Return - End diff -Nru openmolcas-22.02/src/ri_util/create_chunk.F90 openmolcas-22.10/src/ri_util/create_chunk.F90 --- openmolcas-22.02/src/ri_util/create_chunk.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/create_chunk.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,126 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Create_Chunk(LenVec,NumVec,IncVec) + +use RI_glob, only: Chunk +#ifdef _MOLCAS_MPP_ +use RI_glob, only: iMap, ip_Chunk +use Para_Info, only: Is_Real_Par, MyRank, nProcs +use Constants, only: Zero +use Definitions, only: wp, u6 +#endif +use stdalloc, only: mma_allocate +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: LenVec, NumVec +integer(kind=iwp), intent(out) :: IncVec +#ifdef _MOLCAS_MPP_ +#include "mafdecls.fh" +integer(kind=iwp) :: i, IncVec0, iNode, iNode0, iStart, itmp, myMap(2), nBlocks +real(kind=wp) :: FullSize, TotalMemory +logical(kind=iwp) :: ok +logical(kind=iwp), external :: ga_create_irreg +#endif +integer(kind=iwp) :: MaxMem + +#ifdef _MOLCAS_MPP_ +if (NumVec <= 0) then + call WarningMessage(2,'Create_Chunk: Failure NumVec <= 0') + write(u6,*) 'NumVec=',NumVec + call Abend() +end if + +if (Is_Real_Par()) then + call mma_allocate(iMap,nProcs+1,Label='iMap') + iMap(:) = 0 + + FullSize = real(LenVec*NumVec,kind=wp) + call mma_maxDBLE(MaxMem) + iMap(1+MyRank) = MaxMem + call GAIGOP(iMap,nProcs,'+') + TotalMemory = Zero + itmp = iMap(1) + + ! Find the smallest possible memory allocation! + + do i=1,nProcs-1 + itmp = min(itmp,iMap(1+i)) + end do + TotalMemory = real(itmp,kind=wp)*real(nProcs,kind=wp) + + ! Compute the number of vectors to handle at the time + + if (TotalMemory > FullSize) then + + IncVec = NumVec + + else + + IncVec = int(real(NumVec,kind=wp)*(TotalMemory/FullSize)) + + end if + if (IncVec <= 0) then + call WarningMessage(2,'Create_Chunk: Failure IncVec <= 0') + write(u6,*) 'FullSize=',FullSize + write(u6,*) 'NumVec=',NumVec + write(u6,*) 'LenVec=',LenVec + write(u6,*) 'TotalMemory=',TotalMemory + write(u6,*) 'Local size of memory' + write(u6,*) (iMap(i),i=1,nProcs) + write(u6,*) 'iTmp=',iTmp + call Abend() + end if + + ! Compute the number of vectors per node, This also defines the Map array. + + iNode0 = 0 + iStart = 1 + do iNode=0,nProcs-1 + if (iStart == 1) iNode0 = iNode + iMap(1+iNode) = iStart + iStart = iStart+max((IncVec+iNode)/nProcs,1) + end do + iMap(1+nProcs) = iStart + IncVec0 = iStart + + !call Put_iArray('DistVec',iMap,nProcs+1) + + nBlocks = nProcs-iNode0 + myMap(1) = 1 + Ok = GA_Create_Irreg(mt_dbl,LenVec,IncVec0,'Chunk',myMap,1,iMap(1+iNode0),nBlocks,ip_Chunk) + if (.not. Ok) then + call WarningMessage(2,'Error in GA_Create_Irreg') + call Abend() + end if +else + call mma_maxDBLE(MaxMem) + IncVec = min(NumVec,MaxMem/LenVec) + call mma_allocate(Chunk,LenVec*IncVec,Label='Chunk') +end if + +! * +!*********************************************************************** +! * +#else +! * +!*********************************************************************** +! * +call mma_maxDBLE(MaxMem) +IncVec = min(NumVec,MaxMem/LenVec) +call mma_allocate(Chunk,LenVec*IncVec,Label='Chunk') + +#endif + +return + +end subroutine Create_Chunk diff -Nru openmolcas-22.02/src/ri_util/decideoncholesky.f openmolcas-22.10/src/ri_util/decideoncholesky.f --- openmolcas-22.02/src/ri_util/decideoncholesky.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/decideoncholesky.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,26 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -* -* -* - SUBROUTINE DecideonCholesky(DoCholesky) - - Implicit Real*8 (a-h,o-z) - Logical DoCholesky - - - Call Get_iScalar('System BitSwitch',iOption) -* -* this is a logical variable (logical function) - DoCholesky=Iand(iOption,512).Eq.512 -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/decideoncholesky.F90 openmolcas-22.10/src/ri_util/decideoncholesky.F90 --- openmolcas-22.02/src/ri_util/decideoncholesky.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/decideoncholesky.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,27 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine DecideonCholesky(DoCholesky) + +use Definitions, only: iwp + +implicit none +logical(kind=iwp), intent(out) :: DoCholesky +integer(kind=iwp) :: iOption + +call Get_iScalar('System BitSwitch',iOption) + +! this is a logical variable (logical function) +DoCholesky = btest(iOption,9) + +return + +end subroutine DecideonCholesky diff -Nru openmolcas-22.02/src/ri_util/destroy_chunk.f openmolcas-22.10/src/ri_util/destroy_chunk.f --- openmolcas-22.02/src/ri_util/destroy_chunk.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/destroy_chunk.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,28 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Destroy_Chunk() - use Chunk_Mod -#ifdef _MOLCAS_MPP_ - Use Para_Info, Only: Is_Real_Par -#endif -#include "stdalloc.fh" -#ifdef _MOLCAS_MPP_ - If (Is_Real_Par()) Then - Call GA_Destroy(ip_Chunk) - Call mma_deallocate(iMap) - Else - Call mma_deallocate(Chunk) - End If -#else - Call mma_deallocate(Chunk) -#endif - Return - End diff -Nru openmolcas-22.02/src/ri_util/destroy_chunk.F90 openmolcas-22.10/src/ri_util/destroy_chunk.F90 --- openmolcas-22.02/src/ri_util/destroy_chunk.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/destroy_chunk.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,34 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Destroy_Chunk() + +use RI_glob, only: Chunk +#ifdef _MOLCAS_MPP_ +use RI_glob, only: iMap, ip_Chunk +use Para_Info, only: Is_Real_Par +#endif +use stdalloc, only: mma_deallocate + +#ifdef _MOLCAS_MPP_ +if (Is_Real_Par()) then + call GA_Destroy(ip_Chunk) + call mma_deallocate(iMap) +else + call mma_deallocate(Chunk) +end if +#else +call mma_deallocate(Chunk) +#endif + +return + +end subroutine Destroy_Chunk diff -Nru openmolcas-22.02/src/ri_util/drv2el_2center_ri.f openmolcas-22.10/src/ri_util/drv2el_2center_ri.f --- openmolcas-22.02/src/ri_util/drv2el_2center_ri.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/drv2el_2center_ri.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,266 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991,1993,1998,2005, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Drv2El_2Center_RI(ThrAO,A_Diag,nSO_Aux,MaxCntr,SO2C) -************************************************************************ -* * -* Object: driver for two-electron integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -* Modified for k2 loop. August '91 * -* Modified to minimize overhead for calculations with * -* small basis sets and large molecules. Sept. '93 * -* Modified driver. Jan. '98 * -* Modified to 2-center ERIs for RI June '05 * -************************************************************************ - use Basis_Info, only: nBas_Aux - use iSD_data - use Wrj12 - use Index_arrays, only: iSO2Sh, nShBF - use Gateway_Info, only: CutInt - use RICD_Info, only: LDF - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) - External Integral_RI_2 -#include "Molcas.fh" -#include "setup.fh" -#include "print.fh" -#include "real.fh" -#include "stdalloc.fh" -#include "nsd.fh" -#define _no_nShs_ -#include "iTOffs.fh" - Integer iAddr_AQ(0:7), kCol_Irrep(0:7) - Logical Verbose, Indexation, FreeK2, DoGrad, DoFock - Character Name_Q*6 - Real*8, Allocatable :: A_Diag(:) - Integer, Allocatable:: SO2C(:) - - Real*8, Allocatable :: Tmp(:,:), TMax(:), TInt(:) -* * -************************************************************************ -* * -*define _DEBUGPRINT_ -* * -************************************************************************ -* * - Call StatusLine(' Seward:',' Computing 2-center RI integrals') -* * -************************************************************************ -* * -* Handle only the auxiliary basis set -* - Call Set_Basis_Mode('Auxiliary') - Call SetUp_iSD() -* * -************************************************************************ -* * -* Initialize for 2-electron integral evaluation. -* - DoGrad=.False. - DoFock=.False. - Indexation = .True. - Call Setup_Ints(nSkal,Indexation,ThrAO,DoFock,DoGrad) -* - Call mma_Allocate(SO2Ind,nSOs,Label='SO2Ind') - Call Mk_iSO2Ind(iSO2Sh,SO2Ind,nSOs,nSkal) -* - nSO_Aux=nSOs-1 - If (LDF) Then - Call mma_allocate(SO2C,nSO_Aux,Label='SO2C') - MaxCntr=0 - Do i = 1, nSO_Aux - iSh = iSO2Sh(i) - iCenter=iSD(10,iSh) - MaxCntr=Max(MaxCntr,iCenter) - SO2C(i)=iCenter - End Do - Else - MaxCntr=0 - End If -* - nBfn2 = 0 - nBfnTot=0 - Do iIrrep = 0, nIrrep-1 - iTOffs(iIrrep+1) = nBfn2 -* - lJ=nBas_Aux(iIrrep) - If (iIrrep.eq.0) lJ=lJ-1 - nBfn2 = nBfn2 + lJ**2 - nBfnTot=nBfnTot+lJ - End Do - nA_Diag=nBfnTot - Call mma_allocate(A_Diag,nA_Diag,Label='A_Diag') -* * -************************************************************************ -* * -*--- Compute entities for prescreening at shell level -* - Call mma_allocate(TMax,nSkal,Label='TMax') - Call mma_allocate(Tmp,nSkal,nSkal,Label='Tmp') - Call Shell_MxSchwz(nSkal,Tmp) - -c Call RecPrt('Tmp',' ',Tmp,nSkal,nSkal) - - TMax(:)=Tmp(:,nSkal) - Call mma_deallocate(Tmp) - TMax_all=Zero - Do iS = 1, nSkal - TMax_all=Max(TMax_all,TMax(iS)) - End Do -* * -************************************************************************ -* * -* Preallocate some core for Seward! -* - Call mma_maxDBLE(MemSew) - MemLow=Min(MemSew/2,1024*128) - MemSew=Max(MemSew/10,MemLow) - Call xSetMem_Ints(MemSew) -* * -************************************************************************ -* * -*-----Temporary buffer for computed integrals, compute the largest -* required buffer size and set up iOffA. -* - nTInt=0 - Do jS = 1, nSkal-1 - nTInt = Max( nTInt, - & nMemAm(nShBF,nIrrep,nSkal-1,jS,iOffA, - & .True.) ) - End Do - Call mma_allocate(TInt,nTInt,Label='TInt') -* * -************************************************************************ -************************************************************************ -* * - Call CWTime(TCpu1,TWall1) -* -* Open files for the A-vectors, set iAddr_AQ, kCol_iIrrep and -* iOffA(3,iIrrep). -* - nBfnTot=0 - Do iIrrep = 0, nIrrep-1 - iOffA(3,iIrrep)=nBfnTot - mB=nBas_Aux(iIrrep) - If (iIrrep.eq.0) mB = mB - 1 - nBfnTot=nBfnTot+mB -* - iSeed=63+iIrrep - Lu_A(iIrrep)=IsFreeUnit(iSeed) - Write(Name_Q,'(A4,I2.2)') 'AVEC',iIrrep - If (mB.ne.0) Call DaName_MF_WA(Lu_A(iIrrep),Name_Q) -* - iAddr_AQ(iIrrep)=0 - kCol_Irrep(iIrrep)=0 - End Do -* - iS = nSkal - kS = nSkal -* - Do jS = 1, nSkal-1 -* * -*----------------------------------------------------------------------* -* * -* Initialize the buffer -* - nTInt_=nMemAm(nShBF,nIrrep,nSkal-1,jS,iOffA,.True.) - TInt(1:nTInt_)=Zero -* * -*----------------------------------------------------------------------* -* * -* First compute the A matrix -* - Do lS = 1, jS -* - Aint=TMax(jS)*TMax(lS) - If (AInt.lt.CutInt) Go To 14 - Call Eval_IJKL(iS,jS,kS,lS,TInt,nTInt_,Integral_RI_2) - 14 Continue -* -* Use a time slot to save the number of tasks and shell -* quadrupltes process by an individual node - Call SavStat(1,One,'+') - Call SavStat(2,One,'+') -* - End Do ! lS -* * -*----------------------------------------------------------------------* -* * -* Write the A-vectors to disk -* - Do iIrrep = 0, nIrrep-1 - mB = iOffA(2,iIrrep) ! # of bf of shell jS - If (mB.ne.0) Then -* - ip_A_n = 1 + iOffA(1,iIrrep) - iAddr=iAddr_AQ(iIrrep) ! Disk address -* - nB = nBas_Aux(iIrrep) - If (iIrrep.eq.0) nB = nB - 1 ! subtract dummy af - Do kCol = 1+kCol_Irrep(iIrrep), mB+kCol_Irrep(iIrrep) -* -* Write the A-vector to file -* - Call dDaFile(Lu_A(iIrrep),1,TInt(ip_A_n),kCol,iAddr) - - ipAs_Diag=1+iOffA(3,iIrrep)+kCol-1 - A_Diag(ipAs_Diag)=TInt(ip_A_n+kCol-1) - nZero=nB-kCol - If (nZero.ne.0) Call dDaFile(Lu_A(iIrrep),0, - & TInt(ip_A_n), - & nZero,iAddr) -* - ip_A_n = ip_A_n + kCol - End Do -* - kCol_Irrep(iIrrep)=kCol_Irrep(iIrrep)+mB - iAddr_AQ(iIrrep)=iAddr - End If -* - End Do ! iIrrep -* * -*----------------------------------------------------------------------* -* * - End Do ! jS -*----------------------------------------------------------------------* -* * -* Release the Seward core memory, the buffer, etc. -* - Call Free_iSD() - Call xRlsMem_Ints - Call mma_deallocate(TInt) - Call mma_deallocate(TMax) - Call mma_deallocate(SO2Ind) -* * -************************************************************************ -* * -* Terminate integral environment. -* - Verbose = .False. - FreeK2=.True. - Call Term_Ints(Verbose,FreeK2) -* * -************************************************************************ -* * - Call CWTime(TCpu2,TWall2) - Call SavTim(1,TCpu2-TCpu1,TWall2-TWall1) -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/ri_util/drv2el_2center_ri.F90 openmolcas-22.10/src/ri_util/drv2el_2center_ri.F90 --- openmolcas-22.02/src/ri_util/drv2el_2center_ri.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/drv2el_2center_ri.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,269 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991,1993,1998,2005, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +! This subroutine should be in a module, to avoid explicit interfaces +#ifdef _IN_MODULE_ + +subroutine Drv2El_2Center_RI(ThrAO,A_Diag,nSO_Aux,MaxCntr,SO2C) +!*********************************************************************** +! * +! Object: driver for two-electron integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +! Modified for k2 loop. August '91 * +! Modified to minimize overhead for calculations with * +! small basis sets and large molecules. Sept. '93 * +! Modified driver. Jan. '98 * +! Modified to 2-center ERIs for RI June '05 * +!*********************************************************************** + +use Basis_Info, only: nBas_Aux +use iSD_data, only: iSD +use RI_glob, only: iOffA, Lu_A, SO2Ind +use Index_arrays, only: iSO2Sh, nShBF +use Gateway_Info, only: CutInt +use RICD_Info, only: LDF +use Symmetry_Info, only: nIrrep +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(in) :: ThrAO +real(kind=wp), allocatable, intent(out) :: A_Diag(:) +integer(kind=iwp), intent(out) :: nSO_Aux, MaxCntr +integer(kind=iwp), allocatable, intent(out) :: SO2C(:) +#include "setup.fh" +#include "iTOffs.fh" +integer(kind=iwp) :: i, iAddr, iAddr_AQ(0:7), iCenter, iIrrep, ip_A_n, ipAs_Diag, iS, iSeed, jS, kCol, kCol_Irrep(0:7), kS, lJ, & + lS, mB, MemLow, MemSew, nA_Diag, nB, nBfn2, nBfnTot, nSkal, nTInt, nTInt_, nZero +real(kind=wp) :: A_int, TCpu1, TCpu2, TMax_all, TWall1, TWall2 +logical(kind=iwp) :: DoFock, DoGrad, FreeK2, Indexation, Verbose +character(len=6) :: Name_Q +real(kind=wp), allocatable :: TInt(:), TMax(:), Tmp(:,:) +integer(kind=iwp), external :: IsFreeUnit, nMemAm +external :: Integral_RI_2 + +! * +!*********************************************************************** +! * +!define _DEBUGPRINT_ +! * +!*********************************************************************** +! * +call StatusLine(' Seward:',' Computing 2-center RI integrals') +! * +!*********************************************************************** +! * +! Handle only the auxiliary basis set + +call Set_Basis_Mode('Auxiliary') +call SetUp_iSD() +! * +!*********************************************************************** +! * +! Initialize for 2-electron integral evaluation. + +DoGrad = .false. +DoFock = .false. +Indexation = .true. +call Setup_Ints(nSkal,Indexation,ThrAO,DoFock,DoGrad) + +call mma_Allocate(SO2Ind,nSOs,Label='SO2Ind') +call Mk_iSO2Ind(iSO2Sh,SO2Ind,nSOs,nSkal) + +nSO_Aux = nSOs-1 +if (LDF) then + call mma_allocate(SO2C,nSO_Aux,Label='SO2C') + MaxCntr = 0 + do i=1,nSO_Aux + iCenter = iSD(10,iSO2Sh(i)) + MaxCntr = max(MaxCntr,iCenter) + SO2C(i) = iCenter + end do +else + MaxCntr = 0 +end if + +nBfn2 = 0 +nBfnTot = 0 +do iIrrep=0,nIrrep-1 + iTOffs(iIrrep+1) = nBfn2 + + lJ = nBas_Aux(iIrrep) + if (iIrrep == 0) lJ = lJ-1 + nBfn2 = nBfn2+lJ**2 + nBfnTot = nBfnTot+lJ +end do +nA_Diag = nBfnTot +call mma_allocate(A_Diag,nA_Diag,Label='A_Diag') +! * +!*********************************************************************** +! * +! Compute entities for prescreening at shell level + +call mma_allocate(TMax,nSkal,Label='TMax') +call mma_allocate(Tmp,nSkal,nSkal,Label='Tmp') +call Shell_MxSchwz(nSkal,Tmp) + +!call RecPrt('Tmp',' ',Tmp,nSkal,nSkal) + +TMax(:) = Tmp(:,nSkal) +call mma_deallocate(Tmp) +TMax_all = Zero +do iS=1,nSkal + TMax_all = max(TMax_all,TMax(iS)) +end do +! * +!*********************************************************************** +! * +! Preallocate some core for Seward! + +call mma_maxDBLE(MemSew) +MemLow = min(MemSew/2,1024*128) +MemSew = max(MemSew/10,MemLow) +call xSetMem_Ints(MemSew) +! * +!*********************************************************************** +! * +! Temporary buffer for computed integrals, compute the largest +! required buffer size and set up iOffA. + +nTInt = 0 +do jS=1,nSkal-1 + nTInt = max(nTInt,nMemAm(nShBF,nIrrep,nSkal-1,jS,iOffA,.true.)) +end do +call mma_allocate(TInt,nTInt,Label='TInt') +! * +!*********************************************************************** +!*********************************************************************** +! * +call CWTime(TCpu1,TWall1) + +! Open files for the A-vectors, set iAddr_AQ, kCol_iIrrep and iOffA(3,iIrrep). + +nBfnTot = 0 +do iIrrep=0,nIrrep-1 + iOffA(3,iIrrep) = nBfnTot + mB = nBas_Aux(iIrrep) + if (iIrrep == 0) mB = mB-1 + nBfnTot = nBfnTot+mB + + iSeed = 63+iIrrep + Lu_A(iIrrep) = IsFreeUnit(iSeed) + write(Name_Q,'(A4,I2.2)') 'AVEC',iIrrep + if (mB /= 0) call DaName_MF_WA(Lu_A(iIrrep),Name_Q) + + iAddr_AQ(iIrrep) = 0 + kCol_Irrep(iIrrep) = 0 +end do + +iS = nSkal +kS = nSkal + +do jS=1,nSkal-1 + ! * + !--------------------------------------------------------------------* + ! * + ! Initialize the buffer + + nTInt_ = nMemAm(nShBF,nIrrep,nSkal-1,jS,iOffA,.true.) + TInt(1:nTInt_) = Zero + ! * + !--------------------------------------------------------------------* + ! * + ! First compute the A matrix + + do lS=1,jS + + A_int = TMax(jS)*TMax(lS) + if (A_Int >= CutInt) call Eval_IJKL(iS,jS,kS,lS,TInt,nTInt_,Integral_RI_2) + + ! Use a time slot to save the number of tasks and shell + ! quadruplets processed by an individual node + call SavStat(1,One,'+') + call SavStat(2,One,'+') + + end do ! lS + ! * + !--------------------------------------------------------------------* + ! * + ! Write the A-vectors to disk + + do iIrrep=0,nIrrep-1 + mB = iOffA(2,iIrrep) ! # of bf of shell jS + if (mB /= 0) then + + ip_A_n = 1+iOffA(1,iIrrep) + iAddr = iAddr_AQ(iIrrep) ! Disk address + + nB = nBas_Aux(iIrrep) + if (iIrrep == 0) nB = nB-1 ! subtract dummy af + do kCol=1+kCol_Irrep(iIrrep),mB+kCol_Irrep(iIrrep) + + ! Write the A-vector to file + + call dDaFile(Lu_A(iIrrep),1,TInt(ip_A_n),kCol,iAddr) + + ipAs_Diag = 1+iOffA(3,iIrrep)+kCol-1 + A_Diag(ipAs_Diag) = TInt(ip_A_n+kCol-1) + nZero = nB-kCol + if (nZero /= 0) call dDaFile(Lu_A(iIrrep),0,TInt(ip_A_n),nZero,iAddr) + + ip_A_n = ip_A_n+kCol + end do + + kCol_Irrep(iIrrep) = kCol_Irrep(iIrrep)+mB + iAddr_AQ(iIrrep) = iAddr + end if + + end do ! iIrrep + ! * + !--------------------------------------------------------------------* + ! * +end do ! jS +!----------------------------------------------------------------------* +! * +! Release the Seward core memory, the buffer, etc. +! +call Free_iSD() +call xRlsMem_Ints() +call mma_deallocate(TInt) +call mma_deallocate(TMax) +call mma_deallocate(SO2Ind) +! * +!*********************************************************************** +! * +! Terminate integral environment. + +Verbose = .false. +FreeK2 = .true. +call Term_Ints(Verbose,FreeK2) +! * +!*********************************************************************** +! * +call CWTime(TCpu2,TWall2) +call SavTim(1,TCpu2-TCpu1,TWall2-TWall1) +! * +!*********************************************************************** +! * +return + +end subroutine Drv2El_2Center_RI + +#endif diff -Nru openmolcas-22.02/src/ri_util/drv2el_3center_ri.f openmolcas-22.10/src/ri_util/drv2el_3center_ri.f --- openmolcas-22.02/src/ri_util/drv2el_3center_ri.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/drv2el_3center_ri.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,782 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991,1993,1998,2006,2007, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Drv2El_3Center_RI(Integral_WrOut,ThrAO) -************************************************************************ -* * -* Object: driver for the 3 center integrals in the RI approach. * -* * -* This code has three sections * -* 1) a 2-center section to generate the Q-vectors * -* 2) a 3-center section to generate the R-vectors * -* 3) a partial transpose section to generate the RI vectors * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -* Modified for k2 loop. August '91 * -* Modified to minimize overhead for calculations with * -* small basis sets and large molecules. Sept. '93 * -* Modified driver. Jan. '98 * -* Modified to 3-center ERIs for RI Jan '06 * -* Modified to out-of-core version Feb '07 * -************************************************************************ - use iSD_data - use Wrj12 - use Basis_Info, only: dbsc, nBas, nBas_Aux - use Gateway_global, only: force_out_of_core - use Gateway_Info, only: CutInt - use RICD_Info, only: LDF - use Symmetry_Info, only: nIrrep - use j12 - Implicit Real*8 (A-H,O-Z) - External Integral_WrOut, Rsv_Tsk -#include "Molcas.fh" -#include "print.fh" -#include "real.fh" -#include "stdalloc.fh" -* -#include "lRI.fh" -#include "setup.fh" -#include "nsd.fh" -#define _no_nShs_ -#include "iTOffs.fh" -* - Character Name_R*6 - Integer iOff_3C(3,0:7), Lu_R(0:7), iAddr_R(0:7), iMax_R(2,0:7), - & iTtmp(0:7), NoChoVec(0:7), iOff_Rv(0:7) - Logical Verbose, Indexation, FreeK2, - & DoGrad, DoFock, Out_of_Core, Rsv_Tsk, Reduce_Prt - External Reduce_Prt - - Real*8, Allocatable :: A_Diag(:), Local_A(:,:) - Integer, Allocatable :: SO2C(:), AB(:,:) - - Real*8, Allocatable :: Tmp(:,:), TMax_Auxiliary(:), - & TMax_Valence(:,:) - Integer, Allocatable:: TmpList(:), iRv(:), LBList(:) - Integer, Allocatable:: Addr(:), NuMu(:,:) - Real*8, Allocatable :: Arr_3C(:), Rv(:), Qv(:), Diag(:) -* * -************************************************************************ -* * - Interface - - SubRoutine Drv2El_2Center_RI(ThrAO,A_Diag,nSO_Aux,MaxCntr,SO2C) - Real*8 ThrAO - Real*8, Allocatable :: A_Diag(:) - Integer, Allocatable :: SO2C(:) - Integer nSO_Aux, MaxCntr - End SubRoutine Drv2El_2Center_RI - - SubRoutine Post_2Center_LDF(A_Diag,AB,MaxCntr,Lu_AB,Local_A, - & SO2C,nSO_Aux) - Real*8, Allocatable :: A_Diag(:), Local_A(:,:) - Integer, Allocatable:: SO2C(:), AB(:,:) - Integer MaxCntr,Lu_AB,nSO_Aux - End SubRoutine Post_2Center_LDF - - SubRoutine Post_2Center_RI(A_Diag) - Real*8, Allocatable :: A_Diag(:) - End SubRoutine Post_2Center_RI - - End Interface -* * -************************************************************************ -* * -*define _DEBUGPRINT_ -* * -************************************************************************ -* * - iRout = 9 -* -* Get global print level -* - iPL=iPrintLevel(-1) - If (iPL.eq.2) Then - iPL=5 - Else If (iPL.eq.3) Then - iPL=6 - Else If (iPL.eq.4) Then - iPL=99 - Else If (iPL.eq.5) Then - iPL=99 - End If - nPrint(iRout)=iPL -* -* Reduce print level if iterating -* - If (Reduce_Prt().and.iPL.le.5) Then - nPrint(iRout)=4 - End If - iPrint = nPrint(iRout) -* - If (iPrint.ge.6) Call CWTime(TC0,TW0) -* * -************************************************************************ -************************************************************************ -* * -* 2 - C E N T E R S E C T I O N * -* * -************************************************************************ -************************************************************************ -* * -* Compute the two-center integrals over the auxiliary basis -* - Call Drv2El_2Center_RI(ThrAO,A_Diag,nSO_Aux,MaxCntr,SO2C) -* -* Post processing to generate the Q-vectors. -* - If (LDF) Then -* -* Local RI -* - Call Post_2Center_LDF(A_Diag,AB,MaxCntr,Lu_AB,Local_A, - & SO2C,nSO_Aux) -* - Else -* -* Standard RI -* - Call Post_2Center_RI(A_Diag) -* - End If -* - Call Set_Basis_Mode('Auxiliary') - Call Nr_Shells(nSkal_Auxiliary) -* - If (iPrint.ge.6) Then - Write (6,'(A)') ' 2-center integrals:' - Call CWTime(TC1,TW1) - Write (6,'(A,F8.2,A,/,A,F8.2,A)') - & ' CPU time :',TC1-TC0,' sec.', - & ' Wall time:',TW1-TW0,' sec.' - End If -* * -************************************************************************ -************************************************************************ -* * -* 3 - C E N T E R S E C T I O N * -* * -************************************************************************ -************************************************************************ -* * -* - Call StatusLine(' Seward:',' Computing 3-center RI integrals') -* -* Handle both the valence and the auxiliary basis set -* - Call Set_Basis_Mode('WithAuxiliary') - Call SetUp_iSD -* * -************************************************************************ -* * -* Initialize for 2-electron integral evaluation. Do not generate -* tables for indexation. -* - Indexation = .False. - DoGrad=.False. - DoFock=.False. - Call Setup_Ints(nSkal,Indexation,ThrAO,DoFock,DoGrad) - nSkal_Valence=nSkal-nSkal_Auxiliary -* * -************************************************************************ -* * -*--- Compute entities for prescreening at shell level -* - Call mma_allocate(TMax_Valence,nSkal_Valence,nSkal_Valence, - & Label='TMax_Valence') - Call mma_allocate(TMax_Auxiliary,nSkal_Auxiliary, - & Label='TMax_Auxiliary') -* - Call mma_allocate(Tmp,nSkal,nSkal,Label='Tmp') - Call Shell_MxSchwz(nSkal,Tmp) - TMax_all=Zero - Do iS = 1, nSkal_Valence - Do jS = 1, iS - TMax_Valence(iS,jS)=Tmp(iS,jS) - TMax_Valence(jS,iS)=Tmp(iS,jS) - TMax_all=Max(TMax_all,Tmp(iS,jS)) - End Do - End Do - Do iS = 1, nSkal_Auxiliary-1 - iS_ = iS + nSkal_Valence - jS_ = nSkal_Valence + nSkal_Auxiliary - TMax_Auxiliary(iS)=Tmp(jS_,iS_) - TMax_all=Max(TMax_all,Tmp(jS_,iS_)) - End Do -* - Call mma_deallocate(Tmp) -* * -************************************************************************ -* * -* Set up indexation for Gaussian pairs. -* -* Generate some offsets and dimensions for the J12 matrix and -* the RI vectors. -* - Call Setup_Aux(nIrrep,nBas,nSkal_Valence,nSkal_Auxiliary,nSO, - & TMax_Valence,CutInt,nSkal2,nBas_Aux,nChV,iTOffs) -* - Call mma_Allocate(iRv,nSkal2,Label='iRv') - iRv(:)=0 -* * -************************************************************************ -* * -* Let us now decide on the memory partitioning -* -* * -*----------------------------------------------------------------------* -* * -* Preallocate some core for Seward! -* - Call mma_maxDBLE(MemSew) - MemLow=Min(MemSew/2,1024*128) - MemSew=Max(MemSew/10,MemLow) - Call xSetMem_Ints(MemSew) -* -* * -*----------------------------------------------------------------------* -* * -* During this phase we will have three memory sections -* -* 1) the three center integrals for a fixed {kl} -* 2) a similar block for the R-vectors -* 3) a buffer to contain subsets of the Q-vectors -* -* Compute the max size of 1 and 2 -* - n3CMax=0 - nRvMax=0 - Call IZero(iMax_R,2*nIrrep) - Do klS_ = 1, nSkal2 - kS = iShij(1,klS_) - lS = iShij(2,klS_) - nRv = nSize_Rv(kS,lS,nBasSh,nSkal-1,nIrrep,iOff_Rv,nChV) - nRvMax = Max (nRvMax,nRv) - n3C = nSize_3C(kS,lS,nBasSh,nSkal-1,nIrrep,iOff_3C,nBas_Aux) - n3CMax = Max (n3CMax,n3C) - Do iIrrep = 0, nIrrep-1 - iMax_R(1,iIrrep)=Max(iMax_R(1,iIrrep),iOff_3C(1,iIrrep)) - iMax_R(2,iIrrep)=iMax_R(2,iIrrep)+iOff_3C(1,iIrrep) - End Do - End Do -* - Call mma_allocate(Arr_3C,n3CMax,Label='Arr_3C') - Call mma_allocate(Rv,nRvMax,Label='Rv') -* - Call mma_maxDBLE(MaxMem) - nQv=0 - Do iIrrep = 0, nIrrep-1 - lJ=nBas_Aux(iIrrep) - If (iIrrep.eq.0) lJ=lJ-1 ! remove dummy basis function - nQv = nQv + lJ*nChV(iIrrep) - End Do -* -* The Q-vectors can be read in a single whole block or in chunks. -* - If (Force_Out_of_Core) MaxMem=(8*nQv)/10 - Out_of_Core = nQv.gt.MaxMem - nQv = Min(nQv,MaxMem) ! note that nQv is effectively reset here - Call mma_allocate(Qv,nQv,Label='Qv') -* * -************************************************************************ -* * -* In case of in-core mode read Q-vectors only once! -* - If (.Not.Out_of_Core) Then - mQv=1 - Do iIrrep = 0, nIrrep-1 - lJ=nBas_Aux(iIrrep) - If (iIrrep.eq.0) lJ=lJ-1 ! remove dummy basis function -* - If (lJ.gt.0) Then - iAddr=0 - kQv = lJ*nChV(iIrrep) - Call dDaFile(Lu_Q(iIrrep),2,Qv(mQv),kQv,iAddr) - mQv = mQv + kQv - End If - End Do - End If -* * -************************************************************************ -* * -* Open files for the R-vectors. -* - Do iIrrep = 0, nIrrep-1 - nB_Aux=nBas_Aux(iIrrep) - If (iIrrep.eq.0) nB_Aux=nB_Aux-1 - If (nB_Aux.ne.0) Then - iSeed=55+iIrrep - Lu_R(iIrrep)=IsFreeUnit(iSeed) - Write(Name_R,'(A4,I2.2)') 'RVec',iIrrep - Call DaName_MF_WA(Lu_R(iIrrep),Name_R) - End If - iAddr_R(iIrrep)=0 - End Do -* * -************************************************************************ -* * - Call CWTime(TCpu1,TWall1) -* - kCenter=0 ! dummy initialize - lCenter=0 ! dummy initialize - iS = nSkal ! point to dummy shell -* Save this field for the time being! - Call ICopy(nIrrep,iTOffs(3),3,iTtmp,1) -* - Call Init_Tsk(id,nSkal2) -* -* - klS=0 - iTask=0 -C Do klS = 1, nSkal2 - 100 Continue - If (.Not.Rsv_Tsk(id,klS)) Go To 200 -C Write (*,*) 'Processing shell-pair:',klS - iTask=iTask+1 -* - iRv(iTask) = klS - kS = iShij(1,klS) - lS = iShij(2,klS) -* -* Logic to avoid integrals with mixed muonic and electronic -* basis. -* - kCnttp=iSD(13,kS) - lCnttp=iSD(13,lS) -* - If (LDF) Then -* -* Pick up the corresponding (K|L)^{-1} block -* - kCenter=iSD(10,kS) - lCenter=iSD(10,lS) -C Write (6,*) 'kCenter, lCenter=',kCenter, lCenter - klCenter = kCenter*(kCenter-1)/2 + lCenter - iAdr_AB=AB(1,klCenter) - nAB =AB(2,klCenter) - Call dDaFile(Lu_AB,2,Local_A(:,2),nAB**2,iAdr_AB) -C Call RecPrt('A^-1',' ',Local_A,nAB,nAB) -* -* Now I need some lookup tables to be used below. I need to -* go from SO index to lO index and from a given lO index -* back to the SO index. -* - Call IZero(ISO2LO,2*(MaxBfn+MaxBfn_Aux)) - iLO=0 - nCase=1 - If (kCenter.ne.lCenter) nCase=2 - Do iCase = 1, nCase - If (iCase.eq.1) Then - jCenter=kCenter - Else - jCenter=lCenter - End If - Do iSO_Aux = 1, nSO_Aux - iCenter=SO2C(iSO_Aux) -C Write (6,*) 'iCenter=',iCenter - If (iCenter.eq.jCenter) Then - iLO = iLO + 1 -C Write (6,*) 'iLO,iSO_Aux=',iLO,iSO_Aux - iSO2LO(1,iSO_Aux)=iLO - iSO2LO(2,iLO)=iSO_Aux - End If - End Do - End Do - End If -* - Aint_kl = TMax_Valence(kS,lS) - If (dbsc(kCnttp)%fMass.ne.dbsc(lCnttp)%fMass) Aint_kl=0.0D0 -* - nRv = nSize_Rv(kS,lS,nBasSh,nSkal-1,nIrrep,iOff_Rv, - & nChV) - n3C = nSize_3C(kS,lS,nBasSh,nSkal-1,nIrrep,iOff_3C, - & nBas_Aux) - Arr_3C(1:n3C)=Zero - Rv(1:nRv)=Zero -* - Call ICopy(nIrrep,iOff_3C,3,iTOffs(3),3) -* -* Loop over the auxiliary basis set -* - Do jS = nSkal_Valence+1, nSkal-1 -C Write (6,*) 'jS,kS,lS=',jS,kS,lS - If (LDF) Then - jCenter=iSD(10,jS) - If (jCenter.ne.kCenter .and. - & jCenter.ne.lCenter ) Go To 14 -C Write (6,*) 'jCenter=',jCenter - End If -* - Aint=Aint_kl * TMax_Auxiliary(jS-nSkal_Valence) -* -#ifdef _DEBUGPRINT_ - Write (6,*) - Write (6,*) 'iS,jS,kS,lS=',iS,jS,kS,lS - Write (6,*) 'AInt,CutInt=',AInt,CutInt - Write (6,*) -#endif - If (AInt.lt.CutInt) Go To 14 - Call Eval_IJKL(iS,jS,kS,lS,Arr_3C,n3C,Integral_WrOut) - 14 Continue -* -* Use a time slot to save the number of tasks and shell -* quadrupltes process by an individual node - Call SavStat(1,One,'+') - Call SavStat(2,One,'+') -* - End Do ! jS -* * -************************************************************************ -* * -* Multiply the 3-center integrals with the Q-vectors -* -* Compute HQ -* - Call Mult_3C_Qv_S(Arr_3C,n3C,Qv,nQv,Rv,nRv,nChV, - & iOff_3C,nIrrep,Out_of_Core,Lu_Q,'N') -* * -************************************************************************ -* * -* Write the R-vectors to disk. These will be retrieved and sort -* afterwards in step 3. -* - Do iIrrep = 0, nIrrep-1 - ip_R = 1 + iOff_Rv(iIrrep) - nRv=iOff_3C(1,iIrrep)*nChV(iIrrep) -C Write (*,*) 'iAddr_R(iIrrep)=',iAddr_R(iIrrep) - If (nRv.gt.0) Then - Call dDaFile(Lu_R(iIrrep),1,Rv(ip_R),nRv,iAddr_R(iIrrep)) - End If - End Do -* * -************************************************************************ -* * -C End Do ! klS - - Go To 100 - 200 Continue - nTask=iTask -* -* Restore iTOffs(3,*) - Call ICopy(nIrrep,iTtmp,1,iTOffs(3),3) -* - Call CWTime(TCpu2,TWall2) - Call SavTim(1,TCpu2-TCpu1,TWall2-TWall1) -* * -************************************************************************ -* * -* E P I L O G U E * -* * -************************************************************************ -* * - Call Free_Tsk(id) -* -* Set up array to store the load balance if this might be needed in -* a gradient calculation. -* - Call mma_allocate(TmpList,nSkal2,Label='TmpList') - TmpList(:)=0 - Call mma_allocate(LBList,nSkal2,Label='LBList') - LBList(:)=-1 - Do iTask = 1, nTask - klS_ = iRv(iTask) - TmpList(klS_) = 1 - End Do -* - iLB=1 - Do klS_ = 1, nSkal2 - If (TmpList(klS_).eq.1) Then - LBList(iLB)=klS_ - iLB=iLB+1 - End If - End Do -* -* - Call Put_iArray('LBList',LBList,nSkal2) -* - Call mma_deallocate(LBList) - Call mma_deallocate(TmpList) -* - Call mma_deallocate(Rv) - Call mma_deallocate(Arr_3C) - Call mma_deallocate(Qv) - Call xRlsMem_Ints() - Call mma_deallocate(TMax_Auxiliary) - Call mma_deallocate(TMax_Valence) - If (LDF) Then - Call mma_deallocate(SO2C) - Call mma_deallocate(AB) - Call mma_deallocate(Local_A) - Call DaClos(Lu_AB) - End If -* * -************************************************************************ -* * -* Each node does now have an incomplete set of R-vectors! -* * -************************************************************************ -* * -* Terminate integral environment. -* - Verbose = .False. - FreeK2=.True. - Call Term_Ints(Verbose,FreeK2) -* - Call mma_deallocate(iSSOff) - Call mma_deallocate(ShlSO) - Call mma_deallocate(SOShl) - Call Free_iSD() -* -* Let go off the Q-vectors for now! -* - Do iIrrep = 0, nIrrep-1 - nB_Aux=nBas_Aux(iIrrep) - If (iIrrep.eq.0) nB_Aux=nB_Aux-1 - If (nB_Aux.ne.0) Call DaClos(Lu_Q(iIrrep)) - End Do -* - If (iPrint.ge.6) Then - Write (6,'(A)') ' 3-center integrals:' - Call CWTime(TC0,TW0) - Write (6,'(A,F8.2,A,/,A,F8.2,A)') - & ' CPU time :',TC0-TC1,' sec.', - & ' Wall time:',TW0-TW1,' sec.' - End If -* * -************************************************************************ -************************************************************************ -* * -* P A R T I A L T R A N S P O S E S E C T I O N * -* * -************************************************************************ -************************************************************************ -* * -* For the interface to work fix the tables of Seward -* - Call Set_Basis_Mode('Valence') - Call SetUp_iSD -* * -************************************************************************ -* * -* Initialize for 2-electron integral evaluation. Do generate -* tables for indexation. -* - Indexation = .True. - Call Setup_Ints(nSkal_Valence,Indexation,ThrAO,DoFock,DoGrad) -* -* Initiate stuff for Cholesky style storage. -* - Call IniCho_RI(nSkal_Valence,nChV,nIrrep,iTOffs,iShij,nSkal2) - - Call mma_allocate(Addr,nSkal2,Label='Addr') ! addr for read - Call mma_allocate(NuMu,2,nSkal2,Label='NuMu') -* * -************************************************************************ -* * -* Write out the RI vectors in Cholesky format -* -* Here we will read one chuck from the R-vector file, while we will -* store an as large part of the RI vectors in Cholesky format. -* - LenVec=0 - Do iIrrep = 0, nIrrep-1 - iChoVec=0 -* - nB_Aux=nBas_Aux(iIrrep) - If (iIrrep.eq.0) nB_Aux=nB_Aux-1 - If (nB_Aux.eq.0) Go To 998 -* - iSym = iIrrep+1 -* -* NumVec: is no longer equal to the # of auxiliary functions -* - NumVec=iTOffs(3*iIrrep+1) - If (NumVec.eq.0) Go To 999 -* - Addr(1) = 0 - Do i=2,nTask ! init the addr for reading vectors - klS_ = iRv(i-1) - kS = iShij(1,klS_) - lS = iShij(2,klS_) - n3C = nSize_3C(kS,lS,nBasSh,nSkal-1,nIrrep, - & iOff_3C,nBas_Aux) - nMuNu = iOff_3C(1,iIrrep) - Addr(i) = Addr(i-1) + nMuNu*NumVec - End Do -* - LenVec_Red = iMax_R(1,iIrrep) - n_Rv = NumVec*LenVec_Red - Call mma_allocate(Rv,n_Rv,Label='Rv') -* -* LenVec: # of valence Gaussian products in this irrep -* - LenVec = iMax_R(2,iIrrep) - Call Create_Chunk(LenVec,NumVec,IncVec) -* - Do iVec = 1, NumVec, IncVec - NumVec_ = Min(NumVec-iVec+1,IncVec) -* * -************************************************************************ -* * -* Read now the R-vectors for a fixed shell-pair and -* irrep, but for all auxiliary functions. -* - mMuNu=0 - Do klS_ = 1, nSkal2 - kS = iShij(1,klS_) - lS = iShij(2,klS_) - n3C = nSize_3C(kS,lS,nBasSh,nSkal-1,nIrrep, - & iOff_3C,nBas_Aux) - nMuNu = iOff_3C(1,iIrrep) - m3C = nMuNu * NumVec_ -* - If (m3C.le.0) Go To 555 -* - MuNu_s=mMuNu+1 - MuNu_e=mMuNu+nMuNu -* - NuMu(1,klS_) = MuNu_s - NuMu(2,klS_) = MuNu_e -* - 555 Continue - mMuNu = mMuNu + nMuNu - End Do -* - Do i = 1, nTask - klS_ = iRv(i) - kS = iShij(1,klS_) - lS = iShij(2,klS_) -* - n3C = nSize_3C(kS,lS,nBasSh,nSkal-1,nIrrep, - & iOff_3C,nBas_Aux) - nMuNu = iOff_3C(1,iIrrep) - m3C = nMuNu * NumVec_ - - If (m3C.le.0) Go To 666 -* - Call dDaFile(Lu_R(iIrrep),2,Rv,m3C,Addr(i)) - -* Copy the appropriate section into the RI vectors in -* Cholesky format. -* - MuNu_s = NuMu(1,klS_) - MuNu_e = NuMu(2,klS_) - j_s=1 - j_e=NumVec_ - Call Put_Chunk(MuNu_s,MuNu_e,j_s,j_e,Rv,nMuNu,LenVec) -* - 666 Continue - End Do -* * -************************************************************************ -* * -* -* Now transfer the RI vectors to disk -* - Call Get_Chunk(LenVec,NumVec_,iChoVec,iSym,iVec) -* - End Do ! iVec = 1, NumVec, IncVec -* - - Call Destroy_Chunk() - Call mma_deallocate(Rv) -* - 999 Continue -* -* Let go off the R-vectors for good! -* - Call DaClos(Lu_R(iIrrep)) - 998 Continue - NoChoVec(iIrrep)=iChoVec -* - End Do ! iIrrep - Call mma_deallocate(NuMu) - Call mma_deallocate(Addr) - Call mma_deallocate(iRv) - Call mma_deallocate(nBasSh) - Call mma_deallocate(iShij) -* * -************************************************************************ -* * - iPass = 1 - iRed = 1 - Call Cho_RI_PutInfo(iPass,iRed) -* * -************************************************************************ -* * -* Terminate integral environment. -* - Verbose = .False. - FreeK2=.True. - Call Term_Ints(Verbose,FreeK2) -* - If (iPrint.ge.6) Then - Write (6,'(A)') ' Block-transpose:' - Call CWTime(TC1,TW1) - Write (6,'(A,F8.2,A,/,A,F8.2,A)') - & ' CPU time :',TC1-TC0,' sec.', - & ' Wall time:',TW1-TW0,' sec.' - End If -* * -************************************************************************ -************************************************************************ -* * -* D I A G O N A L S E C T I O N * -* * -************************************************************************ -************************************************************************ -* * - nDiag = 0 - Do iIrrep = 0, nIrrep-1 - nDiag = nDiag+nBas(iIrrep) - End Do - nDiag = nDiag*(nDiag+1)/2 - Call mma_allocate(Diag,nDiag,Label='Diag') - Diag(:)=Zero -* - Call Drv2El_RI_Diag(ThrAO,Diag,nDiag) -* -* Write the diagonal to disk -* - Call Cho_IODiag(Diag,1) -* - Call mma_deallocate(Diag) -* - If (iPrint.ge.6) Then - Write (6,*) 'Diagonal vector:' - Call CWTime(TC0,TW0) - Write (6,'(A,F8.2,A,/,A,F8.2,A)') - & ' CPU time :',TC0-TC1,' sec.', - & ' Wall time:',TW0-TW1,' sec.' - End If -* * -************************************************************************ -* * -* Terminate Cholesky stuff here. -* - irc = 0 - Call TermCho_RI(irc,NoChoVec,8) - If (irc .ne. 0) Then - Write(6,*) 'TermCho_RI returned ',irc - Call SysAbendMsg('Drv2El_3Center_RI', - & 'Cholesky termination failed!',' ') - End If -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/ri_util/drv2el_3center_ri.F90 openmolcas-22.10/src/ri_util/drv2el_3center_ri.F90 --- openmolcas-22.02/src/ri_util/drv2el_3center_ri.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/drv2el_3center_ri.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,737 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991,1993,1998,2006,2007, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Drv2El_3Center_RI(Integral_WrOut,ThrAO) +!*********************************************************************** +! * +! Object: driver for the 3 center integrals in the RI approach. * +! * +! This code has three sections * +! 1) a 2-center section to generate the Q-vectors * +! 2) a 3-center section to generate the R-vectors * +! 3) a partial transpose section to generate the RI vectors * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +! Modified for k2 loop. August '91 * +! Modified to minimize overhead for calculations with * +! small basis sets and large molecules. Sept. '93 * +! Modified driver. Jan. '98 * +! Modified to 3-center ERIs for RI Jan '06 * +! Modified to out-of-core version Feb '07 * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem +use RI_procedures, only: Drv2El_2Center_RI +use iSD_data, only: iSD +use Basis_Info, only: dbsc, nBas, nBas_Aux +use Gateway_global, only: force_out_of_core +use Gateway_Info, only: CutInt +use RICD_Info, only: LDF +use Symmetry_Info, only: nIrrep +use RI_glob, only: iShij, iSSOff, klS, Lu_Q, nBasSh, nChV, nSkal_Valence, nSO, ShlSO, SOShl +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +external :: Integral_WrOut +real(kind=wp), intent(in) :: ThrAO +#include "Molcas.fh" +#include "print.fh" +#include "lRI.fh" +#include "iTOffs.fh" +integer(kind=iwp) :: i, iAddr, iAddr_R(0:7), iAdr_AB, iCase, iCenter, iChoVec, id, iIrrep, iLB, iLO, iMax_R(2,0:7), IncVec, & + iOff_3C(3,0:7), iOff_Rv(0:7), ip_R, iPass, iPL, iPrint, irc, iRed, iRout, iS, iS_, iSeed, iSO_Aux, iSym, & + iTask, iTtmp(0:7), iVec, j_e, j_s, jCenter, jS, jS_, kCenter, kCnttp, klCenter, klS_, kQv, kS, lCenter, & + lCnttp, LenVec, LenVec_Red, lJ, lS, Lu_AB, Lu_R(0:7), m3C, MaxCntr, MaxMem, MemLow, MemSew, mMuNu, mQv, & + MuNu_e, MuNu_s, n3C, n3CMax, n_Rv, nB_Aux, nCase, nDiag, nMuNu, NoChoVec(0:7), nQv, nRv, nRvMax, nSkal, & + nSkal2, nSkal_Auxiliary, nTask, NumVec, NumVec_ +real(kind=wp) :: A_int, A_int_kl, TC0, TC1, TCpu1, TCpu2, TMax_all, TW0, TW1, TWall1, Twall2 +character(len=6) :: Name_R +logical(kind=iwp) :: DoFock, DoGrad, FreeK2, Indexation, Out_of_Core, Skip, Verbose +integer(kind=iwp), allocatable :: AB(:,:), Addr(:), iRv(:), LBList(:), NuMu(:,:), SO2C(:), TmpList(:) +real(kind=wp), allocatable :: A_Diag(:), Arr_3C(:), Diag(:), Local_A(:,:), Qv(:), Rv(:), TMax_Auxiliary(:), TMax_Valence(:,:), & + Tmp(:,:) +integer(kind=iwp), external :: iPrintLevel, IsFreeUnit, nSize_3C, nSize_Rv +logical(kind=iwp), external :: Reduce_Prt, Rsv_Tsk +interface + subroutine Post_2Center_LDF(A_Diag,AB,MaxCntr,Lu_AB,Local_A,SO2C,nSO_Aux) + real*8 :: A_Diag(*) + real*8, allocatable :: Local_A(:,:) + integer, allocatable :: SO2C(:), AB(:,:) + integer MaxCntr, Lu_AB, nSO_Aux + end subroutine Post_2Center_LDF +end interface + +! * +!*********************************************************************** +! * +!define _DEBUGPRINT_ +! * +!*********************************************************************** +! * +iRout = 9 + +! Get global print level + +iPL = iPrintLevel(-1) +if (iPL == 2) then + iPL = 5 +else if (iPL == 3) then + iPL = 6 +else if (iPL == 4) then + iPL = 99 +else if (iPL == 5) then + iPL = 99 +end if +nPrint(iRout) = iPL + +! Reduce print level if iterating + +if (Reduce_Prt() .and. (iPL <= 5)) then + nPrint(iRout) = 4 +end if +iPrint = nPrint(iRout) + +if (iPrint >= 6) call CWTime(TC0,TW0) +! * +!*********************************************************************** +!*********************************************************************** +! * +! 2 - C E N T E R S E C T I O N * +! * +!*********************************************************************** +!*********************************************************************** +! * +! Compute the two-center integrals over the auxiliary basis + +call Drv2El_2Center_RI(ThrAO,A_Diag,nSO_Aux,MaxCntr,SO2C) + +! Post processing to generate the Q-vectors. + +if (LDF) then + + ! Local RI + + call Post_2Center_LDF(A_Diag,AB,MaxCntr,Lu_AB,Local_A,SO2C,nSO_Aux) + +else + + ! Standard RI + + call Post_2Center_RI(A_Diag) + +end if + +call mma_deallocate(A_Diag) + +call Set_Basis_Mode('Auxiliary') +call Nr_Shells(nSkal_Auxiliary) + +if (iPrint >= 6) then + write(u6,'(A)') ' 2-center integrals:' + call CWTime(TC1,TW1) + write(u6,'(A,F8.2,A,/,A,F8.2,A)') ' CPU time :',TC1-TC0,' sec.',' Wall time:',TW1-TW0,' sec.' +end if +! * +!*********************************************************************** +!*********************************************************************** +! * +! 3 - C E N T E R S E C T I O N * +! * +!*********************************************************************** +!*********************************************************************** +! * + +call StatusLine(' Seward:',' Computing 3-center RI integrals') + +! Handle both the valence and the auxiliary basis set + +call Set_Basis_Mode('WithAuxiliary') +call SetUp_iSD() +! * +!*********************************************************************** +! * +! Initialize for 2-electron integral evaluation. Do not generate +! tables for indexation. + +Indexation = .false. +DoGrad = .false. +DoFock = .false. +call Setup_Ints(nSkal,Indexation,ThrAO,DoFock,DoGrad) +nSkal_Valence = nSkal-nSkal_Auxiliary +! * +!*********************************************************************** +! * +! Compute entities for prescreening at shell level + +call mma_allocate(TMax_Valence,nSkal_Valence,nSkal_Valence,Label='TMax_Valence') +call mma_allocate(TMax_Auxiliary,nSkal_Auxiliary,Label='TMax_Auxiliary') + +call mma_allocate(Tmp,nSkal,nSkal,Label='Tmp') +call Shell_MxSchwz(nSkal,Tmp) +TMax_all = Zero +do iS=1,nSkal_Valence + do jS=1,iS + TMax_Valence(iS,jS) = Tmp(iS,jS) + TMax_Valence(jS,iS) = Tmp(iS,jS) + TMax_all = max(TMax_all,Tmp(iS,jS)) + end do +end do +do iS=1,nSkal_Auxiliary-1 + iS_ = iS+nSkal_Valence + jS_ = nSkal_Valence+nSkal_Auxiliary + TMax_Auxiliary(iS) = Tmp(jS_,iS_) + TMax_all = max(TMax_all,Tmp(jS_,iS_)) +end do + +call mma_deallocate(Tmp) +! * +!*********************************************************************** +! * +! Set up indexation for Gaussian pairs. + +! Generate some offsets and dimensions for the J12 matrix and +! the RI vectors. + +call Setup_Aux(nIrrep,nBas,nSkal_Valence,nSkal_Auxiliary,nSO,TMax_Valence,CutInt,nSkal2,nBas_Aux,nChV,iTOffs) + +call mma_Allocate(iRv,nSkal2,Label='iRv') +iRv(:) = 0 +! * +!*********************************************************************** +! * +! Let us now decide on the memory partitioning + +! * +!----------------------------------------------------------------------* +! * +! Preallocate some core for Seward! + +call mma_maxDBLE(MemSew) +MemLow = min(MemSew/2,1024*128) +MemSew = max(MemSew/10,MemLow) +call xSetMem_Ints(MemSew) + +! * +!----------------------------------------------------------------------* +! * +! During this phase we will have three memory sections +! +! 1) the three center integrals for a fixed {kl} +! 2) a similar block for the R-vectors +! 3) a buffer to contain subsets of the Q-vectors + +! Compute the max size of 1 and 2 + +n3CMax = 0 +nRvMax = 0 +iMax_R(:,0:nIrrep-1) = 0 +do klS_=1,nSkal2 + kS = iShij(1,klS_) + lS = iShij(2,klS_) + nRv = nSize_Rv(kS,lS,nBasSh,nSkal-1,nIrrep,iOff_Rv,nChV) + nRvMax = max(nRvMax,nRv) + n3C = nSize_3C(kS,lS,nBasSh,nSkal-1,nIrrep,iOff_3C,nBas_Aux) + n3CMax = max(n3CMax,n3C) + iMax_R(1,0:nIrrep-1) = max(iMax_R(1,0:nIrrep-1),iOff_3C(1,0:nIrrep-1)) + iMax_R(2,0:nIrrep-1) = iMax_R(2,0:nIrrep-1)+iOff_3C(1,0:nIrrep-1) +end do + +call mma_allocate(Arr_3C,n3CMax,Label='Arr_3C') +call mma_allocate(Rv,nRvMax,Label='Rv') + +call mma_maxDBLE(MaxMem) +nQv = 0 +do iIrrep=0,nIrrep-1 + lJ = nBas_Aux(iIrrep) + if (iIrrep == 0) lJ = lJ-1 ! remove dummy basis function + nQv = nQv+lJ*nChV(iIrrep) +end do + +! The Q-vectors can be read in a single whole block or in chunks. + +if (Force_Out_of_Core) MaxMem = (8*nQv)/10 +Out_of_Core = nQv > MaxMem +nQv = min(nQv,MaxMem) ! note that nQv is effectively reset here +call mma_allocate(Qv,nQv,Label='Qv') +! * +!*********************************************************************** +! * +! In case of in-core mode read Q-vectors only once! + +if (.not. Out_of_Core) then + mQv = 1 + do iIrrep=0,nIrrep-1 + lJ = nBas_Aux(iIrrep) + if (iIrrep == 0) lJ = lJ-1 ! remove dummy basis function + + if (lJ > 0) then + iAddr = 0 + kQv = lJ*nChV(iIrrep) + call dDaFile(Lu_Q(iIrrep),2,Qv(mQv),kQv,iAddr) + mQv = mQv+kQv + end if + end do +end if +! * +!*********************************************************************** +! * +! Open files for the R-vectors. + +do iIrrep=0,nIrrep-1 + nB_Aux = nBas_Aux(iIrrep) + if (iIrrep == 0) nB_Aux = nB_Aux-1 + if (nB_Aux /= 0) then + iSeed = 55+iIrrep + Lu_R(iIrrep) = IsFreeUnit(iSeed) + write(Name_R,'(A4,I2.2)') 'RVec',iIrrep + call DaName_MF_WA(Lu_R(iIrrep),Name_R) + end if + iAddr_R(iIrrep) = 0 +end do +! * +!*********************************************************************** +! * +call CWTime(TCpu1,TWall1) + +kCenter = 0 ! dummy initialize +lCenter = 0 ! dummy initialize +iS = nSkal ! point to dummy shell +! Save this field for the time being! +iTtmp(0:nIrrep-1) = iTOffs(3:3*nIrrep:3) + +call Init_Tsk(id,nSkal2) + +klS = 0 +iTask = 0 +!do klS=1,nSkal2 +do while (Rsv_Tsk(id,klS)) + !write(u6,*) 'Processing shell-pair:',klS + iTask = iTask+1 + + iRv(iTask) = klS + kS = iShij(1,klS) + lS = iShij(2,klS) + + ! Logic to avoid integrals with mixed muonic and electronic basis. + + kCnttp = iSD(13,kS) + lCnttp = iSD(13,lS) + + if (LDF) then + + ! Pick up the corresponding (K|L)^{-1} block + + kCenter = iSD(10,kS) + lCenter = iSD(10,lS) + !write(u6,*) 'kCenter, lCenter=',kCenter, lCenter + klCenter = nTri_Elem(kCenter-1)+lCenter + iAdr_AB = AB(1,klCenter) + nAB = AB(2,klCenter) + call dDaFile(Lu_AB,2,Local_A(:,2),nAB**2,iAdr_AB) + !call RecPrt('A^-1',' ',Local_A,nAB,nAB) + + ! Now I need some lookup tables to be used below. I need to + ! go from SO index to lO index and from a given lO index + ! back to the SO index. + + ISO2LO(:,:) = 0 + iLO = 0 + nCase = 1 + if (kCenter /= lCenter) nCase = 2 + do iCase=1,nCase + if (iCase == 1) then + jCenter = kCenter + else + jCenter = lCenter + end if + do iSO_Aux=1,nSO_Aux + iCenter = SO2C(iSO_Aux) + !write(u6,*) 'iCenter=',iCenter + if (iCenter == jCenter) then + iLO = iLO+1 + !write(u6,*) 'iLO,iSO_Aux=',iLO,iSO_Aux + iSO2LO(1,iSO_Aux) = iLO + iSO2LO(2,iLO) = iSO_Aux + end if + end do + end do + end if + + A_int_kl = TMax_Valence(kS,lS) + if (dbsc(kCnttp)%fMass /= dbsc(lCnttp)%fMass) A_int_kl = Zero + + nRv = nSize_Rv(kS,lS,nBasSh,nSkal-1,nIrrep,iOff_Rv,nChV) + n3C = nSize_3C(kS,lS,nBasSh,nSkal-1,nIrrep,iOff_3C,nBas_Aux) + Arr_3C(1:n3C) = Zero + Rv(1:nRv) = Zero + + iTOffs(3:3*nIrrep:3) = iOff_3C(1,0:nIrrep-1) + + ! Loop over the auxiliary basis set + + do jS=nSkal_Valence+1,nSkal-1 + !write(u6,*) 'jS,kS,lS=',jS,kS,lS + Skip = .false. + if (LDF) then + jCenter = iSD(10,jS) + if ((jCenter /= kCenter) .and. (jCenter /= lCenter)) Skip = .true. + !write(u6,*) 'jCenter=',jCenter + end if + + if (.not. Skip) then + A_int = A_int_kl*TMax_Auxiliary(jS-nSkal_Valence) + +# ifdef _DEBUGPRINT_ + write(u6,*) + write(u6,*) 'iS,jS,kS,lS=',iS,jS,kS,lS + write(u6,*) 'A_Int,CutInt=',A_Int,CutInt + write(u6,*) +# endif + if (A_Int >= CutInt) call Eval_IJKL(iS,jS,kS,lS,Arr_3C,n3C,Integral_WrOut) + end if + + ! Use a time slot to save the number of tasks and shell + ! quadruplets processed by an individual node + call SavStat(1,One,'+') + call SavStat(2,One,'+') + + end do ! jS + ! * + !********************************************************************* + ! * + ! Multiply the 3-center integrals with the Q-vectors + + ! Compute HQ + + call Mult_3C_Qv_S(Arr_3C,n3C,Qv,nQv,Rv,nRv,nChV,iOff_3C,nIrrep,Out_of_Core,Lu_Q,'N') + ! * + !********************************************************************* + ! * + ! Write the R-vectors to disk. These will be retrieved and sort + ! afterwards in step 3. + + do iIrrep=0,nIrrep-1 + ip_R = 1+iOff_Rv(iIrrep) + nRv = iOff_3C(1,iIrrep)*nChV(iIrrep) + !write(u6,*) 'iAddr_R(iIrrep)=',iAddr_R(iIrrep) + if (nRv > 0) call dDaFile(Lu_R(iIrrep),1,Rv(ip_R),nRv,iAddr_R(iIrrep)) + end do + ! * + !********************************************************************* + ! * + !end do ! klS + +end do +nTask = iTask + +! Restore iTOffs(3,*) +iTOffs(3:3*nIrrep:3) = iTtmp(0:nIrrep-1) + +call CWTime(TCpu2,TWall2) +call SavTim(1,TCpu2-TCpu1,TWall2-TWall1) +! * +!*********************************************************************** +! * +! E P I L O G U E * +! * +!*********************************************************************** +! * +call Free_Tsk(id) + +! Set up array to store the load balance if this might be needed in +! a gradient calculation. + +call mma_allocate(TmpList,nSkal2,Label='TmpList') +TmpList(:) = 0 +call mma_allocate(LBList,nSkal2,Label='LBList') +LBList(:) = -1 +do iTask=1,nTask + klS_ = iRv(iTask) + TmpList(klS_) = 1 +end do + +iLB = 1 +do klS_=1,nSkal2 + if (TmpList(klS_) == 1) then + LBList(iLB) = klS_ + iLB = iLB+1 + end if +end do + +call Put_iArray('LBList',LBList,nSkal2) + +call mma_deallocate(LBList) +call mma_deallocate(TmpList) + +call mma_deallocate(Rv) +call mma_deallocate(Arr_3C) +call mma_deallocate(Qv) +call xRlsMem_Ints() +call mma_deallocate(TMax_Auxiliary) +call mma_deallocate(TMax_Valence) +if (LDF) then + call mma_deallocate(SO2C) + call mma_deallocate(AB) + call mma_deallocate(Local_A) + call DaClos(Lu_AB) +end if +! * +!*********************************************************************** +! * +! Each node does now have an incomplete set of R-vectors! +! * +!*********************************************************************** +! * +! Terminate integral environment. + +Verbose = .false. +FreeK2 = .true. +call Term_Ints(Verbose,FreeK2) + +call mma_deallocate(iSSOff) +call mma_deallocate(ShlSO) +call mma_deallocate(SOShl) +call Free_iSD() + +! Let go off the Q-vectors for now! + +do iIrrep=0,nIrrep-1 + nB_Aux = nBas_Aux(iIrrep) + if (iIrrep == 0) nB_Aux = nB_Aux-1 + if (nB_Aux /= 0) call DaClos(Lu_Q(iIrrep)) +end do + +if (iPrint >= 6) then + write(u6,'(A)') ' 3-center integrals:' + call CWTime(TC0,TW0) + write(u6,'(A,F8.2,A,/,A,F8.2,A)') ' CPU time :',TC0-TC1,' sec.',' Wall time:',TW0-TW1,' sec.' +end if +! * +!*********************************************************************** +!*********************************************************************** +! * +! P A R T I A L T R A N S P O S E S E C T I O N * +! * +!*********************************************************************** +!*********************************************************************** +! * +! For the interface to work fix the tables of Seward + +call Set_Basis_Mode('Valence') +call SetUp_iSD() +! * +!*********************************************************************** +! * +! Initialize for 2-electron integral evaluation. Do generate +! tables for indexation. + +Indexation = .true. +call Setup_Ints(nSkal_Valence,Indexation,ThrAO,DoFock,DoGrad) + +! Initiate stuff for Cholesky style storage. + +call IniCho_RI(nSkal_Valence,nChV,nIrrep,iTOffs,iShij,nSkal2) + +call mma_allocate(Addr,nSkal2,Label='Addr') ! addr for read +call mma_allocate(NuMu,2,nSkal2,Label='NuMu') +! * +!*********************************************************************** +! * +! Write out the RI vectors in Cholesky format + +! Here we will read one chuck from the R-vector file, while we will +! store an as large part of the RI vectors in Cholesky format. + +LenVec = 0 +do iIrrep=0,nIrrep-1 + iChoVec = 0 + + nB_Aux = nBas_Aux(iIrrep) + if (iIrrep == 0) nB_Aux = nB_Aux-1 + if (nB_Aux /= 0) then + + iSym = iIrrep+1 + + ! NumVec: is no longer equal to the # of auxiliary functions + + NumVec = iTOffs(3*iIrrep+1) + if (NumVec /= 0) then + + Addr(1) = 0 + do i=2,nTask ! init the addr for reading vectors + klS_ = iRv(i-1) + kS = iShij(1,klS_) + lS = iShij(2,klS_) + n3C = nSize_3C(kS,lS,nBasSh,nSkal-1,nIrrep,iOff_3C,nBas_Aux) + nMuNu = iOff_3C(1,iIrrep) + Addr(i) = Addr(i-1)+nMuNu*NumVec + end do + + LenVec_Red = iMax_R(1,iIrrep) + n_Rv = NumVec*LenVec_Red + call mma_allocate(Rv,n_Rv,Label='Rv') + + ! LenVec: # of valence Gaussian products in this irrep + + LenVec = iMax_R(2,iIrrep) + call Create_Chunk(LenVec,NumVec,IncVec) + + do iVec=1,NumVec,IncVec + NumVec_ = min(NumVec-iVec+1,IncVec) + ! * + !*************************************************************** + ! * + ! Read now the R-vectors for a fixed shell-pair and + ! irrep, but for all auxiliary functions. + + mMuNu = 0 + do klS_=1,nSkal2 + kS = iShij(1,klS_) + lS = iShij(2,klS_) + n3C = nSize_3C(kS,lS,nBasSh,nSkal-1,nIrrep,iOff_3C,nBas_Aux) + nMuNu = iOff_3C(1,iIrrep) + m3C = nMuNu*NumVec_ + + if (m3C > 0) then + MuNu_s = mMuNu+1 + MuNu_e = mMuNu+nMuNu + + NuMu(1,klS_) = MuNu_s + NuMu(2,klS_) = MuNu_e + end if + + mMuNu = mMuNu+nMuNu + end do + + do i=1,nTask + klS_ = iRv(i) + kS = iShij(1,klS_) + lS = iShij(2,klS_) + + n3C = nSize_3C(kS,lS,nBasSh,nSkal-1,nIrrep,iOff_3C,nBas_Aux) + nMuNu = iOff_3C(1,iIrrep) + m3C = nMuNu*NumVec_ + + if (m3C <= 0) cycle + + call dDaFile(Lu_R(iIrrep),2,Rv,m3C,Addr(i)) + + ! Copy the appropriate section into the RI vectors in Cholesky format. + + MuNu_s = NuMu(1,klS_) + MuNu_e = NuMu(2,klS_) + j_s = 1 + j_e = NumVec_ + call Put_Chunk(MuNu_s,MuNu_e,j_s,j_e,Rv,nMuNu,LenVec) + + end do + ! * + !*************************************************************** + ! * + ! Now transfer the RI vectors to disk + + call Get_Chunk(LenVec,NumVec_,iChoVec,iSym,iVec) + + end do ! iVec = 1, NumVec, IncVec + + call Destroy_Chunk() + call mma_deallocate(Rv) + + end if + + ! Let go of the R-vectors for good! + + call DaClos(Lu_R(iIrrep)) + end if + NoChoVec(iIrrep) = iChoVec + +end do ! iIrrep +call mma_deallocate(NuMu) +call mma_deallocate(Addr) +call mma_deallocate(iRv) +call mma_deallocate(nBasSh) +call mma_deallocate(iShij) +! * +!*********************************************************************** +! * +iPass = 1 +iRed = 1 +call Cho_RI_PutInfo(iPass,iRed) +! * +!*********************************************************************** +! * +! Terminate integral environment. + +Verbose = .false. +FreeK2 = .true. +call Term_Ints(Verbose,FreeK2) +! +if (iPrint >= 6) then + write(u6,'(A)') ' Block-transpose:' + call CWTime(TC1,TW1) + write(u6,'(A,F8.2,A,/,A,F8.2,A)') ' CPU time :',TC1-TC0,' sec.',' Wall time:',TW1-TW0,' sec.' +end if +! * +!*********************************************************************** +!*********************************************************************** +! * +! D I A G O N A L S E C T I O N * +! * +!*********************************************************************** +!*********************************************************************** +! * +nDiag = 0 +do iIrrep=0,nIrrep-1 + nDiag = nDiag+nBas(iIrrep) +end do +nDiag = nTri_Elem(nDiag) +call mma_allocate(Diag,nDiag,Label='Diag') +Diag(:) = Zero + +call Drv2El_RI_Diag(ThrAO,Diag,nDiag) + +! Write the diagonal to disk + +call Cho_IODiag(Diag,1) + +call mma_deallocate(Diag) + +if (iPrint >= 6) then + write(u6,*) 'Diagonal vector:' + call CWTime(TC0,TW0) + write(u6,'(A,F8.2,A,/,A,F8.2,A)') ' CPU time :',TC0-TC1,' sec.',' Wall time:',TW0-TW1,' sec.' +end if +! * +!*********************************************************************** +! * +! Terminate Cholesky stuff here. + +irc = 0 +call TermCho_RI(irc,NoChoVec,8) +if (irc /= 0) then + write(u6,*) 'TermCho_RI returned ',irc + call SysAbendMsg('Drv2El_3Center_RI','Cholesky termination failed!',' ') +end if +! * +!*********************************************************************** +! * +return + +end subroutine Drv2El_3Center_RI diff -Nru openmolcas-22.02/src/ri_util/drv2el_atomic_nosym.f openmolcas-22.10/src/ri_util/drv2el_atomic_nosym.f --- openmolcas-22.02/src/ri_util/drv2el_atomic_nosym.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/drv2el_atomic_nosym.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,368 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991,1993,1998, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Drv2El_Atomic_NoSym(Integral_WrOut,ThrAO,iCnttp,jCnttp, - & TInt,nTInt, - & In_Core,ADiag,LuA,ijS_req, - & Keep_Shell) -************************************************************************ -* * -* Object: driver for two-electron integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -* Modified for k2 loop. August '91 * -* Modified to minimize overhead for calculations with * -* small basis sets and large molecules. Sept. '93 * -* Modified driver. Jan. '98 * -************************************************************************ - use Basis_Info, only: nBas - use iSD_data - use Wrj12 - use k2_arrays, only: Sew_Scr - use Basis_Info, only: dbsc - use Gateway_global, only: force_out_of_core, iWROpt - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) - External Integral_WrOut -#include "nsd.fh" -#include "setup.fh" -#include "print.fh" -#include "real.fh" -#include "stdalloc.fh" -#define _no_nShs_ -#include "iTOffs.fh" - Real*8, Allocatable :: TInt(:), ADiag(:) - Integer, Allocatable :: IJInd(:,:) - Logical Verbose, Indexation, FreeK2, DoGrad, DoFock, - & In_Core, Out_of_Core, Only_DB, Do_RI_Basis, Do_ERIs -* * -************************************************************************ -* * -* Temporary modifications to facilitate atomic calculations -* - nIrrep_Save=nIrrep - nIrrep=1 - iWROpt_Save=iWROpt - iWROpt=1 -* - Do_RI_Basis = dbsc(iCnttp)%Aux -* - Call Set_Basis_Mode_Atomic(iCnttp,jCnttp) - Call Setup_iSD() -* - If (Do_RI_Basis .and. ijS_req.eq.0) Then - Call WarningMessage(2, - & 'Do_RI_Basis .and. ijS_req.eq.0') - Call Abend() - End If -C Write (6,*) 'Do_RI_Basis=',Do_RI_Basis -* * -************************************************************************ -* * -* Initialize for 2-electron integral evaluation. Do not generate -* tables for indexation. -* - DoGrad=.False. - DoFock=.False. - Indexation = .False. - Call Setup_Ints(nSkal,Indexation,ThrAO,DoFock,DoGrad) -* * -************************************************************************ -* * -* Create list of pairs -* - Call mma_allocate(IJInd,2,nSkal*(nSkal+1)/2,Label='IJInd') - nij=0 - nBfn=0 - If (Do_RI_Basis) Then - iS=nSkal ! Dummy shell - Do jS = 1, nSkal-1 - nij = nij +1 - IJInd(1,nij)=iS - IJInd(2,nij)=jS - nBfn=nBfn+iSD(2,jS)*iSD(3,jS) - End Do - Else - Do iS = 1, nSkal - Do jS = 1, iS - nij = nij +1 - IJInd(1,nij)=iS - IJInd(2,nij)=jS - End Do - End Do - End If -C Write (6,*) 'nij=',nij -* * -************************************************************************ -* * -* Preallocate some core for Seward! -* - Call mma_MaxDBLE(MemSew) - MemLow=Min(MemSew/2,1024*128) - MemSew=Max(MemSew/10,MemLow) - Call mma_allocate(Sew_Scr,MemSew,Label='Sew_Scr') -* * -************************************************************************ -* * -* Determine if only diagonal block should be computed. -* This option is forced when the auxiliary basis set is transformed -* to the Cholesky basis! -* - Only_DB=ijS_req.ne.0 .or. Do_RI_Basis -* * -************************************************************************ -* * -* Choose between in-core and out-of-core options -* - Call mma_MaxDBLE(MemT) - MemT=MemT/2 -* - If (Only_DB) Then -* -* Only diagonal block -* - nTInt=0 - If (Do_RI_Basis) Then - Do iS = 1, nSkal-1 ! Skip the dummy shell - nBfn_i=iSD(2,iS)*iSD(3,iS) - If (iS.eq.ijS_req) nTInt=nBfn_i - End Do - If (nTInt.eq.0) Then - Call WarningMessage(2, - & 'Drv2el_atomic_nosym: nTInt.eq.0') - Call Abend() - End If -* - Call mma_Allocate(SO2Ind,nBfn,Label='SO2Ind') - Do iBfn = 1, nBfn - SO2Ind(iBfn)=iBfn - End Do - nSOs=nBfn - Else - Do iS = 1, nSkal - nBfn_i=iSD(2,iS)*iSD(3,iS) - Do jS = 1, iS-1 - ijS = iS*(iS-1)/2 + jS - nBfn_j=iSD(2,jS)*iSD(3,jS) - If (ijS.eq.ijS_req) nTInt=nBfn_i*nBfn_j - End Do - ijS = iS*(iS+1)/2 - If (ijS.eq.ijS_req) nTInt=nBfn_i*(nBfn_i+1)/2 - End Do - End If - mTInt=nTInt - nTInt2=mTInt*nTInt - If (nTInt2.gt.MemT) Then - Call WarningMessage(2,'Not enough memory!') - Call Abend() - End If -* - iTOffs(1)=0 -* - In_Core=.True. ! no out-of-core option needed. - Out_of_core=.False. - mTInt2=nTInt2 -* - Else -* -* All blocks -* - nTInt=nBas(0)*(nBas(0)+1)/2 - mTInt=nTInt - nTInt2=nTInt**2 - In_Core=nTInt2.le.MemT - If (Force_out_of_Core) In_Core=.False. - Out_of_Core=.NOT.In_Core -* -* Compute the size of the array, TInt, to write the integrals to. -* - If (Out_of_Core) Then -* -* Find the larges block for a fixed shell pair. -* - mTInt=0 - Do iS = 1, nSkal - nBfn_i=iSD(2,iS)*iSD(3,iS) - Do jS = 1, iS-1 - nBfn_j=iSD(2,jS)*iSD(3,jS) - mTInt=Max(mTInt,nBfn_i*nBfn_j) - End Do - mTInt=Max(mTInt,nBfn_i*(nBfn_i+1)/2) - End Do - nTInt2=mTInt*nTInt -* -* Open file for the A-vectors -* - iAddr=0 - iSeed=63 - LuA=IsFreeUnit(iSeed) - Call DaName_MF_WA(LuA,'AVEC0') -* - Call mma_allocate(ADiag,nTInt,label='ADiag') - Call FZero(ADiag,nTInt) -* - Else -* -* In-core option -* - mTInt2=nTInt2 - iTOffs(1)=0 ! Offset permanently set to zero! -* - End If - End If -* * -************************************************************************ -* * - iTOffs(2)=nTInt ! # of rows in TInt - iTOffs(3)=mTInt ! # of colums in TInt - Call mma_allocate(TInt,nTInt2,label='TInt') - If (In_Core) Call FZero(TInt,nTInt2) -* * -************************************************************************ -* * -* Now do a quadruple loop over shells -* - iTOff=0 - iTOffs(4)=0 ! Offset to the ij set - Do ijS = 1, nij - iS = IJInd(1,ijS) - jS = IJInd(2,ijS) -* - nBfn_i=iSD(2,iS)*iSD(3,iS) - nBfn_j=iSD(2,jS)*iSD(3,jS) - ijAng =iSD(1,iS)+iSD(1,jS) -* - If (Out_of_Core) Then - If (iS.eq.jS) Then - mTInt=nBfn_i*(nBfn_i+1)/2 - Else - mTInt=nBfn_i*nBfn_j - End If - mTInt2=mTInt*nTInt - Call FZero(TInt,mTInt2) - iTOffs(1)=iTOff - iTOffs(3)=mTInt - End If -* - iTOffs(5)=0 ! Offset to the kl set - Do klS = 1, ijS - kS = IJInd(1,klS) - lS = IJInd(2,klS) -* - nBfn_k=iSD(2,kS)*iSD(3,kS) - nBfn_l=iSD(2,lS)*iSD(3,lS) - klAng =iSD(1,kS)+iSD(1,lS) -* -* For Only_DB compute the shell quadruplet (ijS_req|ijS_req) -* - Do_ERIs = .NOT.Only_DB .or. - & (ijS.eq.ijS_req.and.klS.eq.ijS_req) -* -* If high angular combination of the product basis is skipped -* do not compute the contributions. -* - Do_ERIs = Do_ERIs .and. ijAng.le.Keep_Shell .and. - & klAng.le.Keep_Shell -* - If (Do_ERIs) Then - Call Eval_IJKL(iS,jS,kS,lS,TInt,mTInt2, - & Integral_WrOut) - End If -* - If (.NOT.Only_DB) Then - If (kS.eq.lS) Then - iTOffs(5)=iTOffs(5)+nBfn_k*(nBfn_k+1)/2 - Else - iTOffs(5)=iTOffs(5)+nBfn_k*nBfn_l - End If - End If -* - End Do -* -* For out-of-core version write the integrals to disk! -* Pick up the diagonal elements. -* - If (Out_of_Core) Then - Call dDaFile(LuA,1,TInt,mTInt2,iAddr) - call dcopy_(mTInt,TInt(1+iTOff),nTInt+1, - & ADiag(1+iTOff),1) - iTOff=iTOff+mTInt - End If -* - If (.NOT.Only_DB) Then - If (iS.eq.jS) Then - iTOffs(4)=iTOffs(4)+nBfn_i*(nBfn_i+1)/2 - Else - iTOffs(4)=iTOffs(4)+nBfn_i*nBfn_j - End If - End If -* - End Do ! ijS -* - If (Do_RI_Basis) Call mma_deallocate(SO2Ind) -* * -************************************************************************ -* * -* E P I L O G U E * -* * -************************************************************************ -* - If (Out_of_Core) Call mma_deallocate(TInt) - Call mma_deallocate(IJInd) -* * -************************************************************************ -* * -* Terminate integral environment. -* - Verbose = .False. - FreeK2=.True. - Call Term_Ints(Verbose,FreeK2) -* * -************************************************************************ -* * -* Square TInt from upper triangular to full. -* - If (In_Core.and..Not.Do_RI_Basis) Then -* - Do iTInt = 1, nTInt - Do jTInt = 1, iTInt-1 - ij = (jTInt-1)*nTInt + iTInt - ji = (iTInt-1)*nTInt + jTInt - TInt(ij)=TInt(ji) - End Do - End Do -C Call RecPrt('Drv2El_atomic: TInt',' ', -C & TInt,nTInt,nTInt) -* - Else If (.Not.Do_RI_Basis) Then -* - nij=nBas(0)*(nBas(0)+1)/2 - Call mma_MaxDBLE(MaxMem) - Call Square_A(LuA,nij,MaxMem,Force_Out_of_Core) -* - End If -* * -************************************************************************ -* * - Call Free_iSD() - nIrrep=nIrrep_Save - iWROpt=iWROpt_Save -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/ri_util/drv2el_atomic_nosym.F90 openmolcas-22.10/src/ri_util/drv2el_atomic_nosym.F90 --- openmolcas-22.02/src/ri_util/drv2el_atomic_nosym.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/drv2el_atomic_nosym.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,372 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991,1993,1998, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +! This subroutine should be in a module, to avoid explicit interfaces +#ifdef _IN_MODULE_ + +subroutine Drv2El_Atomic_NoSym(Integral_WrOut,ThrAO,iCnttp,jCnttp,TInt,nTInt,In_Core,ADiag,LuA,ijS_req,Keep_Shell) +!*********************************************************************** +! * +! Object: driver for two-electron integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +! Modified for k2 loop. August '91 * +! Modified to minimize overhead for calculations with * +! small basis sets and large molecules. Sept. '93 * +! Modified driver. Jan. '98 * +!*********************************************************************** + +use Index_Functions, only: iTri, nTri_Elem +use iSD_data, only: iSD +use RI_glob, only: SO2Ind +use k2_arrays, only: Sew_Scr +use Basis_Info, only: dbsc, nBas +use Gateway_global, only: force_out_of_core, iWROpt +use Symmetry_Info, only: nIrrep +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +external :: Integral_WrOut +real(kind=wp), intent(in) :: ThrAO +integer(kind=iwp), intent(in) :: iCnttp, jCnttp, ijS_req, Keep_Shell +real(kind=wp), allocatable, intent(out) :: TInt(:), ADiag(:) +integer(kind=iwp), intent(out) :: nTInt, LuA +logical(kind=iwp), intent(out) :: In_Core +#include "setup.fh" +#include "iTOffs.fh" +integer(kind=iwp) :: iAddr, iBfn, ij, ijAng, ijS, iS, iSeed, iTInt, iTOff, iWROpt_Save, ji, jS, jTInt, klAng, klS, kS, lS, MaxMem, & + MemLow, MemSew, MemT, mTInt, mTInt2, nBfn, nBfn_i, nBfn_j, nBfn_k, nBfn_l, nij, nIrrep_Save, nSkal, nTInt2 +logical(kind=iwp) :: Do_ERIs, Do_RI_Basis, DoFock, DoGrad, FreeK2, Indexation, Only_DB, Out_of_Core, Verbose +integer(kind=iwp), allocatable :: IJInd(:,:) +integer(kind=iwp), external :: IsFreeUnit + +! * +!*********************************************************************** +! * +! Temporary modifications to facilitate atomic calculations + +nIrrep_Save = nIrrep +nIrrep = 1 +iWROpt_Save = iWROpt +iWROpt = 1 + +Do_RI_Basis = dbsc(iCnttp)%Aux + +call Set_Basis_Mode_Atomic(iCnttp,jCnttp) +call Setup_iSD() + +if (Do_RI_Basis .and. (ijS_req == 0)) then + call WarningMessage(2,'Do_RI_Basis .and. (ijS_req == 0)') + call Abend() +end if +!write(u6,*) 'Do_RI_Basis=',Do_RI_Basis +! * +!*********************************************************************** +! * +! Initialize for 2-electron integral evaluation. Do not generate +! tables for indexation. + +DoGrad = .false. +DoFock = .false. +Indexation = .false. +call Setup_Ints(nSkal,Indexation,ThrAO,DoFock,DoGrad) +! * +!*********************************************************************** +! * +! Create list of pairs + +call mma_allocate(IJInd,2,nTri_Elem(nSkal),Label='IJInd') +nij = 0 +nBfn = 0 +if (Do_RI_Basis) then + iS = nSkal ! Dummy shell + do jS=1,nSkal-1 + nij = nij+1 + IJInd(1,nij) = iS + IJInd(2,nij) = jS + nBfn = nBfn+iSD(2,jS)*iSD(3,jS) + end do +else + do iS=1,nSkal + do jS=1,iS + nij = nij+1 + IJInd(1,nij) = iS + IJInd(2,nij) = jS + end do + end do +end if +!write(u6,*) 'nij=',nij +! * +!*********************************************************************** +! * +! Preallocate some core for Seward! + +call mma_MaxDBLE(MemSew) +MemLow = min(MemSew/2,1024*128) +MemSew = max(MemSew/10,MemLow) +call mma_allocate(Sew_Scr,MemSew,Label='Sew_Scr') +! * +!*********************************************************************** +! * +! Determine if only diagonal block should be computed. +! This option is forced when the auxiliary basis set is transformed +! to the Cholesky basis! + +Only_DB = (ijS_req /= 0) .or. Do_RI_Basis +! * +!*********************************************************************** +! * +! Choose between in-core and out-of-core options + +call mma_MaxDBLE(MemT) +MemT = MemT/2 + +if (Only_DB) then + + ! Only diagonal block + + nTInt = 0 + if (Do_RI_Basis) then + do iS=1,nSkal-1 ! Skip the dummy shell + nBfn_i = iSD(2,iS)*iSD(3,iS) + if (iS == ijS_req) nTInt = nBfn_i + end do + if (nTInt == 0) then + call WarningMessage(2,'Drv2el_atomic_nosym: nTInt == 0') + call Abend() + end if + + call mma_Allocate(SO2Ind,nBfn,Label='SO2Ind') + do iBfn=1,nBfn + SO2Ind(iBfn) = iBfn + end do + nSOs = nBfn + else + do iS=1,nSkal + nBfn_i = iSD(2,iS)*iSD(3,iS) + do jS=1,iS-1 + ijS = iTri(iS,jS) + nBfn_j = iSD(2,jS)*iSD(3,jS) + if (ijS == ijS_req) nTInt = nBfn_i*nBfn_j + end do + ijS = iTri(iS,iS) + if (ijS == ijS_req) nTInt = nTri_Elem(nBfn_i) + end do + end if + mTInt = nTInt + nTInt2 = mTInt*nTInt + if (nTInt2 > MemT) then + call WarningMessage(2,'Not enough memory!') + call Abend() + end if + + iTOffs(1) = 0 + + In_Core = .true. ! no out-of-core option needed. + Out_of_core = .false. + mTInt2 = nTInt2 + +else + + ! All blocks + + nTInt = nTri_Elem(nBas(0)) + mTInt = nTInt + nTInt2 = nTInt**2 + In_Core = nTInt2 <= MemT + if (Force_out_of_Core) In_Core = .false. + Out_of_Core = .not. In_Core + + ! Compute the size of the array, TInt, to write the integrals to. + + if (Out_of_Core) then + + ! Find the larges block for a fixed shell pair. + + mTInt = 0 + do iS=1,nSkal + nBfn_i = iSD(2,iS)*iSD(3,iS) + do jS=1,iS-1 + nBfn_j = iSD(2,jS)*iSD(3,jS) + mTInt = max(mTInt,nBfn_i*nBfn_j) + end do + mTInt = max(mTInt,nTri_Elem(nBfn_i)) + end do + nTInt2 = mTInt*nTInt + + ! Open file for the A-vectors + + iAddr = 0 + iSeed = 63 + LuA = IsFreeUnit(iSeed) + call DaName_MF_WA(LuA,'AVEC0') + + call mma_allocate(ADiag,nTInt,label='ADiag') + ADiag(:) = Zero + + else + + ! In-core option + + mTInt2 = nTInt2 + iTOffs(1) = 0 ! Offset permanently set to zero! + + end if +end if +! * +!*********************************************************************** +! * +iTOffs(2) = nTInt ! # of rows in TInt +iTOffs(3) = mTInt ! # of colums in TInt +call mma_allocate(TInt,nTInt2,label='TInt') +if (In_Core) TInt(:) = Zero +! * +!*********************************************************************** +! * +! Now do a quadruple loop over shells + +iTOff = 0 +iTOffs(4) = 0 ! Offset to the ij set +do ijS=1,nij + iS = IJInd(1,ijS) + jS = IJInd(2,ijS) + + nBfn_i = iSD(2,iS)*iSD(3,iS) + nBfn_j = iSD(2,jS)*iSD(3,jS) + ijAng = iSD(1,iS)+iSD(1,jS) + + if (Out_of_Core) then + if (iS == jS) then + mTInt = nTri_Elem(nBfn_i) + else + mTInt = nBfn_i*nBfn_j + end if + mTInt2 = mTInt*nTInt + TInt(1:mTInt2) = Zero + iTOffs(1) = iTOff + iTOffs(3) = mTInt + end if + + iTOffs(5) = 0 ! Offset to the kl set + do klS=1,ijS + kS = IJInd(1,klS) + lS = IJInd(2,klS) + + nBfn_k = iSD(2,kS)*iSD(3,kS) + nBfn_l = iSD(2,lS)*iSD(3,lS) + klAng = iSD(1,kS)+iSD(1,lS) + + ! For Only_DB compute the shell quadruplet (ijS_req|ijS_req) + + Do_ERIs = (.not. Only_DB) .or. ((ijS == ijS_req) .and. (klS == ijS_req)) + + ! If high angular combination of the product basis is skipped + ! do not compute the contributions. + + Do_ERIs = Do_ERIs .and. (ijAng <= Keep_Shell) .and. (klAng <= Keep_Shell) + + if (Do_ERIs) then + call Eval_IJKL(iS,jS,kS,lS,TInt,mTInt2,Integral_WrOut) + end if + + if (.not. Only_DB) then + if (kS == lS) then + iTOffs(5) = iTOffs(5)+nTri_Elem(nBfn_k) + else + iTOffs(5) = iTOffs(5)+nBfn_k*nBfn_l + end if + end if + + end do + + ! For out-of-core version write the integrals to disk! + ! Pick up the diagonal elements. + + if (Out_of_Core) then + call dDaFile(LuA,1,TInt,mTInt2,iAddr) + call dcopy_(mTInt,TInt(1+iTOff),nTInt+1,ADiag(1+iTOff),1) + iTOff = iTOff+mTInt + end if + + if (.not. Only_DB) then + if (iS == jS) then + iTOffs(4) = iTOffs(4)+nTri_Elem(nBfn_i) + else + iTOffs(4) = iTOffs(4)+nBfn_i*nBfn_j + end if + end if + +end do ! ijS + +if (Do_RI_Basis) call mma_deallocate(SO2Ind) +! * +!*********************************************************************** +! * +! E P I L O G U E * +! * +!*********************************************************************** + +if (Out_of_Core) call mma_deallocate(TInt) +call mma_deallocate(IJInd) +! * +!*********************************************************************** +! * +! Terminate integral environment. + +Verbose = .false. +FreeK2 = .true. +call Term_Ints(Verbose,FreeK2) +! * +!*********************************************************************** +! * +! Square TInt from upper triangular to full. + +if (In_Core .and. (.not. Do_RI_Basis)) then + + do iTInt=1,nTInt + do jTInt=1,iTInt-1 + ij = (jTInt-1)*nTInt+iTInt + ji = (iTInt-1)*nTInt+jTInt + TInt(ij) = TInt(ji) + end do + end do + !call RecPrt('Drv2El_atomic: TInt',' ',TInt,nTInt,nTInt) + +else if (.not. Do_RI_Basis) then + + nij = nTri_Elem(nBas(0)) + call mma_MaxDBLE(MaxMem) + call Square_A(LuA,nij,MaxMem,Force_Out_of_Core) + +end if +! * +!*********************************************************************** +! * +call Free_iSD() +nIrrep = nIrrep_Save +iWROpt = iWROpt_Save +! * +!*********************************************************************** +! * +return + +end subroutine Drv2El_Atomic_NoSym + +#endif diff -Nru openmolcas-22.02/src/ri_util/drv2el_ri_diag.f openmolcas-22.10/src/ri_util/drv2el_ri_diag.f --- openmolcas-22.02/src/ri_util/drv2el_ri_diag.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/drv2el_ri_diag.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,79 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991,1993,1998, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Drv2El_RI_Diag(ThrAO,TInt,nTInt) -************************************************************************ -* * -* Object: driver for two-electron integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -* Modified for k2 loop. August '91 * -* Modified to minimize overhead for calculations with * -* small basis sets and large molecules. Sept. '93 * -* Modified driver. Jan. '98 * -************************************************************************ - use SOAO_Info, only: iOffSO - use Basis_Info, only: nBas - use Symmetry_Info, only: nIrrep - use j12, only: nSkal_Valence - Implicit Real*8 (A-H,O-Z) - External Integral_WrOut - Real*8 TInt(nTInt) - Logical Verbose, Indexation, FreeK2, DoFock, DoGrad -* * -************************************************************************ -* * -* Initialize for 2-electron integral evaluation. Do not generate -* tables for indexation. -* - DoFock=.False. - DoGrad=.False. - Indexation = .False. - Call Setup_Ints(nSkal,Indexation,ThrAO,DoFock,DoGrad) - nSkal_Valence=nSkal -* * -************************************************************************ -* * -* Update iOffSO and call the Cholesky code which does this. -* - nAcc=0 - Do iIrrep = 0, nIrrep-1 - iOffSO(iIrrep) = nAcc - nAcc = nAcc + nBas(iIrrep) - End Do - Call RI_XDiag(TInt,nTInt) -* * -************************************************************************ -* * -* Terminate integral environment. -* - Verbose = .False. - FreeK2=.True. - Call Term_Ints(Verbose,FreeK2) -* * -************************************************************************ -* * - Return - End - SubRoutine Cho_x_setab(iS,jS) -#include "cholesky.fh" -* - SHA=iS - SHB=jS -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/drv2el_ri_diag.F90 openmolcas-22.10/src/ri_util/drv2el_ri_diag.F90 --- openmolcas-22.02/src/ri_util/drv2el_ri_diag.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/drv2el_ri_diag.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,79 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991,1993,1998, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Drv2El_RI_Diag(ThrAO,TInt,nTInt) +!*********************************************************************** +! * +! Object: driver for two-electron integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +! Modified for k2 loop. August '91 * +! Modified to minimize overhead for calculations with * +! small basis sets and large molecules. Sept. '93 * +! Modified driver. Jan. '98 * +!*********************************************************************** + +use SOAO_Info, only: iOffSO +use Basis_Info, only: nBas +use Symmetry_Info, only: nIrrep +use RI_glob, only: nSkal_Valence +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(in) :: ThrAO +integer(kind=iwp), intent(in) :: nTInt +real(kind=wp), intent(out) :: TInt(nTInt) +integer(kind=iwp) :: iIrrep, nAcc, nSkal +logical(kind=iwp) :: DoFock, DoGrad, FreeK2, Indexation, Verbose + +! * +!*********************************************************************** +! * +! Initialize for 2-electron integral evaluation. Do not generate +! tables for indexation. + +DoFock = .false. +DoGrad = .false. +Indexation = .false. +call Setup_Ints(nSkal,Indexation,ThrAO,DoFock,DoGrad) +nSkal_Valence = nSkal +! * +!*********************************************************************** +! * +! Update iOffSO and call the Cholesky code which does this. + +nAcc = 0 +do iIrrep=0,nIrrep-1 + iOffSO(iIrrep) = nAcc + nAcc = nAcc+nBas(iIrrep) +end do +call RI_XDiag(TInt,nTInt) +! * +!*********************************************************************** +! * +! Terminate integral environment. + +Verbose = .false. +FreeK2 = .true. +call Term_Ints(Verbose,FreeK2) +! * +!*********************************************************************** +! * +return + +end subroutine Drv2El_RI_Diag diff -Nru openmolcas-22.02/src/ri_util/drvg1_2center_ri.f openmolcas-22.10/src/ri_util/drvg1_2center_ri.f --- openmolcas-22.02/src/ri_util/drvg1_2center_ri.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/drvg1_2center_ri.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,524 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991,1992,2000,2007, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Drvg1_2Center_RI(Grad,Temp,nGrad,ij2,nij_Eff) -************************************************************************ -* * -* Object: driver for 2-center two-electron integrals in the RI scheme.* -* * -* The integral derivative is formulated as * -* -Sum(ML) X_ij^K V_LM^(1) X_kl^L where * -* * -* X_ij^K = Sum(L) R_ij_L Q_L^K * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -* Modified for k2 loop. August '91 * -* Modified for gradient calculation. January '92 * -* Modified for SetUp_Ints. January '00 * -* Modified for 2-center RI gradients, January '07 * -************************************************************************ - use k2_setup - use iSD_data - use pso_stuff - use k2_arrays, only: ipZeta, ipiZet, Mem_DBLE, Aux, Sew_Scr - use Basis_Info - use Sizes_of_Seward, only:S - use Gateway_Info, only: CutInt - use RICD_Info, only: Do_RI - use Symmetry_Info, only: nIrrep - use Para_Info, only: nProcs, King - use ExTerm, only: CijK, AMP2, iMP2prpt, A - Implicit Real*8 (A-H,O-Z) - External Rsv_Tsk -#include "itmax.fh" -#include "Molcas.fh" -#include "real.fh" -#include "stdalloc.fh" -#include "print.fh" -#include "disp.fh" -#include "nsd.fh" -#include "setup.fh" -#include "exterm.fh" -*#define _CD_TIMING_ -#ifdef _CD_TIMING_ -#include "temptime.fh" -#endif - Integer nGrad, nij_Eff - Real*8 Grad(nGrad), Temp(nGrad) - Integer, Allocatable :: ij2(:,:) - -* Local arrays - Real*8 Coor(3,4) - Integer iAnga(4), iCmpa(4), iShela(4),iShlla(4), - & iAOV(4), istabs(4), iAOst(4), JndGrd(3,4), iFnc(4) - Logical EQ, Shijij, AeqB, CeqD, - & DoGrad, DoFock, Indexation, FreeK2, Verbose, - & JfGrad(3,4), ABCDeq, No_Batch, Rsv_Tsk - Character Format*72 -* - Integer iSD4(0:nSD,4) - Save MemPrm - - Real*8, Allocatable:: TMax2(:,:), TMax1(:), Tmp(:,:) - Integer, Allocatable:: Shij(:,:) -* * -************************************************************************ -* * - iRout = 9 - iPrint = nPrint(iRout) -#ifdef _CD_TIMING_ - Twoel2_CPU = 0.0d0 - Twoel2_Wall = 0.0d0 - Pget2_CPU = 0.0d0 - Pget2_Wall = 0.0d0 -#endif - - iFnc(1)=0 - iFnc(2)=0 - iFnc(3)=0 - iFnc(4)=0 - PMax=Zero - Temp(:)=Zero -* * -************************************************************************ -* * -* Handle only the auxiliary basis set. -* - If (Do_RI) Then - Call Set_Basis_Mode('Auxiliary') - Else - Call Set_Basis_Mode('Valence') - End If - Call Setup_iSD() - -************************************************************************ -* * -*-----Precompute k2 entities. -* - Indexation=.False. - DoFock=.False. - DoGrad=.True. - ThrAO=Zero - Call SetUp_Ints(nSkal,Indexation,ThrAO,DoFock,DoGrad) - mSkal=nSkal - nPairs=nSkal*(nSkal+1)/2 - nQuad =nPairs*(nPairs+1)/2 - Pren = Zero - Prem = Zero -* * -************************************************************************ -* * - MxPrm = 0 - Do iAng = 0, S%iAngMx - MxPrm = Max(MxPrm,S%MaxPrm(iAng)) - End Do - nZeta = MxPrm * MxPrm - nEta = MxPrm * MxPrm -* * -************************************************************************ -* * -*--- Compute entities for prescreening at shell level -* - If (Do_RI) Then - nTMax=nSkal - Call mma_allocate(TMax1,nTMax,Label='TMax1') - Call mma_allocate(Tmp,nSkal,nSkal,Label='Tmp') - Call Shell_MxSchwz(nSkal,Tmp) - TMax1(1:nSkal)=Tmp(1:nSkal,nSkal) - Call mma_deallocate(Tmp) - - TMax_all=Zero - Do iS = 1, nSkal-1 - TMax_all=Max(TMax_all,TMax1(iS)) - End Do - Else - Call mma_allocate(TMax2,nSkal,nSkal,Label='TMax2') - Call Shell_MxSchwz(nSkal,TMax2) - TMax_all=Zero - Do ij = 1, nij_Eff - iS = ij2(1,ij) - jS = ij2(2,ij) - TMax_all=Max(TMax_all,TMax2(iS,jS)) - End Do - End If -* * -************************************************************************ -* * -* Allocate some scratch arrays to be used by the pget routines. -* In particular we will have temporary arrays for A_IJ and C_ijK. -* -* Lower case: valence basis set -* Upper case: auxiliary basis sets -* - If(DoCholExch) Then -* -* Find the largest number of contractions in any given shell -* of auxiliary functions. - - MxChVInShl = 1 - If(Do_RI) Then - Do i = 1, nSkal - MxChVInShl = max(MxChVInShl,iSD(3,i)) - End Do - Else - Write (6,*) 'Not Implemented for Cholesky yet!' - Call Abend() - End If -* -* Scratch for A_IJ -* - lA = MxChVInShl*MxChVInShl - Call mma_allocate(A,lA,Label='A') - If (iMP2Prpt.eq.2) Then - lA_MP2=MxChVInShl - Call mma_allocate(AMP2,lA_MP2,2,Label='AMP2') - End If -* -* Find the largest set of ij. The basis i and j is due to the -* CD of the one-particle density. -* - nIJRMax = 0 - Do jDen = 1,nKvec - Do iSym1 = 1, nIrrep - Do iSym2 = 1, nIrrep - nIJRMax = max(nIJRMax,nIJR(iSym1,iSym2,jDen)) - End Do - End Do - End Do -* -* Get scratch for C_kl^I and C_kl^J. -* Note that we need nDen arrays for C_kl^I and one for C_kl^J -* A_IJ = Sum(kl) C_kl^I x C_kl^J -* - Call mma_allocate(CijK,nIJRMax*MxChVInShl*(nKvec+1), - & Label='CijK') -* - End If -* * -************************************************************************ -* * -* Create list of non-vanishing pairs -* - If (Do_RI) Then - mij=(nSkal-1) - Call mma_allocate(Shij,2,mij,Label='Shij') - nij=0 - Do iS = 1, nSkal-1 - If (TMax_All*TMax1(iS).ge.CutInt) Then - nij = nij + 1 - Shij(1,nij)=nSkal - Shij(2,nij)=iS - End If - End Do - Else - mij=nij_Eff - Call mma_allocate(Shij,2,mij,Label='Shij') - nij=0 - Do ij = 1, nij_Eff - iS = ij2(1,ij) - jS = ij2(2,ij) - If (TMax_All*TMax2(iS,jS).ge.CutInt) Then - nij = nij + 1 - Shij(1,nij)=iS - Shij(2,nij)=jS - End If - End Do - End If -* * -************************************************************************ -* * -*-----Compute FLOP's for the transfer equation. -* - Do iAng = 0, S%iAngMx - Do jAng = 0, iAng - nHrrab = 0 - Do i = 0, iAng+1 - Do j = 0, jAng+1 - If (i+j.le.iAng+jAng+1) Then - ijMax = Min(iAng,jAng)+1 - nHrrab = nHrrab + ijMax*2+1 - End If - End Do - End Do - End Do - End Do -* * -************************************************************************ -* * -* For a parallel implementation the iterations over shell-pairs -* are parallelized. - - Call Init_Tsk(id,nij*(nij+1)/2) -* * -************************************************************************ -* * -* In MPP case dispatch one processor to do 1-el gradients first -* - If (nProcs.gt.1.and.King()) Then - If (Do_RI) Call Free_iSD() - Call Drvh1(Grad,Temp,nGrad) -* If (nPrint(1).ge.15) -* & Call PrGrad(' Gradient excluding two-electron contribution', -* & Grad,lDisp(0),ChDisp) - call dcopy_(nGrad,[Zero],0,Temp,1) - If (Do_RI) Then - Call Set_Basis_Mode('Auxiliary') - Call Setup_iSD() - End If - End If -* * -************************************************************************ -* * - Call mma_MaxDBLE(MemMax) - Call mma_allocate(Sew_Scr,MemMax,Label='Sew_Scr') - ipMem1=1 -* * -************************************************************************ -* * -C If (MyRank.ne.0) Go To 11 -* big loop over individual tasks, distributed over individual nodes - 10 Continue -* make reservation of a task on global task list and get task range -* in return. Function will be false if no more tasks to execute. - If (.Not.Rsv_Tsk(id,jlS)) Go To 11 -* -* Now do a quadruple loop over shells -* - jS_= Int((One+sqrt(Eight*DBLE(jlS)-Three))/Two) - iS = Shij(1,jS_) - jS = Shij(2,jS_) - lS_= Int(DBLE(jlS)-DBLE(jS_)*(DBLE(jS_)-One)/Two) - kS = Shij(1,lS_) - lS = Shij(2,lS_) - Call CWTime(TCpu1,TWall1) -* - If (Do_RI) Then - Aint=TMax1(jS)*TMax1(lS) - Else - Aint=TMax2(iS,jS)*TMax2(kS,lS) - End If - If (AInt.lt.CutInt) Go To 10 -C If (is.eq.3.and.js.eq.3.and.ks.eq.1.and.ls.eq.1) Then -C iPrint=15 -C nPrint(39)=15 -C Else -C iPrint=nPrint(iRout) -C nPrint(39)=5 -C End If - If (iPrint.ge.15) Write (6,*) 'iS,jS,kS,lS=',iS,jS,kS,lS -* * -************************************************************************ -* * - Call Gen_iSD4(iS, jS, kS, lS,iSD,nSD,iSD4) - Call Size_SO_block_g(iSD4,nSD,nSO,No_batch) - If (No_batch) Go To 140 -* - Call Int_Prep_g(iSD4,nSD,Coor,Shijij,iAOV,iStabs) -* -* * -************************************************************************ -* * -* --------> Memory Managment <-------- -* -* Compute memory request for the primitives, i.e. -* how much memory is needed up to the transfer -* equation. -* - Call MemRys_g(iSD4,nSD,nRys,MemPrm) -* * -************************************************************************ -* * - ABCDeq=EQ(Coor(1,1),Coor(1,2)) .and. - & EQ(Coor(1,1),Coor(1,3)) .and. - & EQ(Coor(1,1),Coor(1,4)) - ijklA=iSD4(1,1)+iSD4(1,2) - & +iSD4(1,3)+iSD4(1,4) - If (nIrrep.eq.1.and.ABCDeq.and.Mod(ijklA,2).eq.1) - & Go To 140 -* * -************************************************************************ -* * -* Decide on the partioning of the shells based on the -* available memory and the requested memory. -* -* Now check if all blocks can be computed and stored at -* once. -* - - Call SOAO_g(iSD4,nSD,nSO, - & MemPrm, MemMax, - & iBsInc,jBsInc,kBsInc,lBsInc, - & iPrInc,jPrInc,kPrInc,lPrInc, - & ipMem1,ipMem2, Mem1, Mem2, - & iFnc, MemPSO) - iBasi = iSD4(3,1) - jBasj = iSD4(3,2) - kBask = iSD4(3,3) - lBasl = iSD4(3,4) -* * -************************************************************************ -* * - Call Int_Parm_g(iSD4,nSD,iAnga, - & iCmpa,iShlla,iShela, - & iPrimi,jPrimj,kPrimk,lPriml, - & k2ij,nDCRR,k2kl,nDCRS, - & mdci,mdcj,mdck,mdcl,AeqB,CeqD, - & nZeta,nEta,ipZeta,ipZI, - & ipP,ipEta,ipEI,ipQ,ipiZet,ipiEta, - & ipxA,ipxB,ipxG,ipxD,l2DI,nab,nHmab,ncd,nHmcd, - & nIrrep) -* * -************************************************************************ -* * -* Scramble arrays (follow angular index) -* - Do iCar = 1, 3 - Do iSh = 1, 4 - JndGrd(iCar,iSh) = iSD4(15+iCar,iSh) - If ((iSh.eq.1 .or. iSh.eq.3).and.Do_RI) Then - JfGrad(iCar,iSh) = .False. - Else If (iAnd(iSD4(15,iSh),2**(iCar-1)) .eq. - & 2**(iCar-1)) Then - JfGrad(iCar,iSh) = .True. - Else - JfGrad(iCar,iSh) = .False. - End If - End Do - End Do -* - Do 400 iBasAO = 1, iBasi, iBsInc - iBasn=Min(iBsInc,iBasi-iBasAO+1) - iAOst(1) = iBasAO-1 - Do 410 jBasAO = 1, jBasj, jBsInc - jBasn=Min(jBsInc,jBasj-jBasAO+1) - iAOst(2) = jBasAO-1 -* - Do 420 kBasAO = 1, kBask, kBsInc - kBasn=Min(kBsInc,kBask-kBasAO+1) - iAOst(3) = kBasAO-1 - Do 430 lBasAO = 1, lBasl, lBsInc - lBasn=Min(lBsInc,lBasl-lBasAO+1) - iAOst(4) = lBasAO-1 -* -*----------Get the 2nd order density matrix in SO basis. -* - nijkl = iBasn*jBasn*kBasn*lBasn -#ifdef _CD_TIMING_ - CALL CWTIME(Pget0CPU1,Pget0WALL1) -#endif - Call PGet0(iCmpa, - & iBasn,jBasn,kBasn,lBasn,Shijij, - & iAOV,iAOst,nijkl,Sew_Scr(ipMem1),nSO, - & iFnc(1)*iBasn,iFnc(2)*jBasn, - & iFnc(3)*kBasn,iFnc(4)*lBasn,MemPSO, - & Sew_Scr(ipMem2),Mem2,iS,jS,kS,lS,nQuad,PMax) -#ifdef _CD_TIMING_ - CALL CWTIME(Pget0CPU2,Pget0WALL2) - Pget2_CPU = Pget2_CPU + Pget0CPU2-Pget0CPU1 - Pget2_Wall = Pget2_Wall + Pget0WALL2-Pget0WALL1 -#endif - If (AInt*PMax.lt.CutInt) Go To 430 -* -*----------Compute gradients of shell quadruplet -* -#ifdef _CD_TIMING_ - Call CWTIME(TwoelCPU1,TwoelWall1) -#endif - Call TwoEl_g(Coor, - & iAnga,iCmpa,iShela,iShlla,iAOV, - & mdci,mdcj,mdck,mdcl,nRys, - & Data_k2(k2ij),nab,nHmab,nDCRR, - & Data_k2(k2kl),ncd,nHmcd,nDCRS,Pren,Prem, - & iPrimi,iPrInc,jPrimj,jPrInc, - & kPrimk,kPrInc,lPriml,lPrInc, - & Shells(iSD4(0,1))%pCff(1,iBasAO),iBasn, - & Shells(iSD4(0,2))%pCff(1,jBasAO),jBasn, - & Shells(iSD4(0,3))%pCff(1,kBasAO),kBasn, - & Shells(iSD4(0,4))%pCff(1,lBasAO),lBasn, - & Mem_DBLE(ipZeta),Mem_DBLE(ipZI),Mem_DBLE(ipP),nZeta, - & Mem_DBLE(ipEta), Mem_DBLE(ipEI),Mem_DBLE(ipQ),nEta, - & Mem_DBLE(ipxA),Mem_DBLE(ipxB), - & Mem_DBLE(ipxG),Mem_DBLE(ipxD),Temp,nGrad, - & JfGrad,JndGrd,Sew_Scr(ipMem1), nSO,Sew_Scr(ipMem2),Mem2, - & Aux,nAux,Shijij) -#ifdef _CD_TIMING_ - Call CWTIME(TwoelCPU2,TwoelWall2) - Twoel2_CPU = Twoel2_CPU + TwoelCPU2-TwoelCPU1 - Twoel2_Wall = Twoel2_Wall + TwoelWall2-TwoelWall1 -#endif - If (iPrint.ge.15) - & Call PrGrad(' In Drvg1_2Center_RI: Grad', - & Temp,nGrad,ChDisp) -* - 430 Continue - 420 Continue -* - 410 Continue - 400 Continue -* - 140 Continue -* - Go To 10 - 11 Continue -* End of big task loop -* * -************************************************************************ -* * -* E P I L O G U E * -* * -************************************************************************ -* * - Call mma_deallocate(Sew_Scr) - Call Free_Tsk(id) - Call mma_deallocate(Shij) - If (Allocated(TMax1)) Call mma_deallocate(TMax1) - If (Allocated(TMax2)) Call mma_deallocate(TMax2) -* * -************************************************************************ -* * - Verbose = .False. - FreeK2=.True. - Call Term_Ints(Verbose,FreeK2) -* * -************************************************************************ -* * - Call Sync_Data(Pren,Prem,nBtch,mBtch,kBtch) -* - iPren=3+Max(1,Int(Log10(Pren+0.001D+00))) - iPrem=3+Max(1,Int(Log10(Prem+0.001D+00))) - Write (Format,'(A,I2,A,I2,A)') '(A,F',iPren, - & '.0,A,F',iPrem,'.0,A)' - If (iPrint.ge.6) Then - Write (6,Format) - & ' A total of', Pren,' entities were prescreened and', - & Prem,' were kept.' - End If -* * -************************************************************************ -* * - If(DoCholExch) Then - Call mma_deallocate(CijK) - Call mma_deallocate(A) - End If - If (Allocated(AMP2)) Call mma_deallocate(AMP2) -* - Call Free_iSD() -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/ri_util/drvg1_2center_ri.F90 openmolcas-22.10/src/ri_util/drvg1_2center_ri.F90 --- openmolcas-22.02/src/ri_util/drvg1_2center_ri.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/drvg1_2center_ri.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,484 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991,1992,2000,2007, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Drvg1_2Center_RI(Grad,Temp,nGrad,ij2,nij_Eff) +!*********************************************************************** +! * +! Object: driver for 2-center two-electron integrals in the RI scheme.* +! * +! The integral derivative is formulated as * +! -Sum(ML) X_ij^K V_LM^(1) X_kl^L where * +! * +! X_ij^K = Sum(L) R_ij_L Q_L^K * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +! Modified for k2 loop. August '91 * +! Modified for gradient calculation. January '92 * +! Modified for SetUp_Ints. January '00 * +! Modified for 2-center RI gradients, January '07 * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem +use iSD_data, only: iSD +use k2_setup, only: Data_k2 +use k2_arrays, only: Aux, ipiZet, ipZeta, Mem_DBLE, Sew_Scr +use Basis_Info, only: Shells +use Sizes_of_Seward, only: S +use Gateway_Info, only: CutInt +use RICD_Info, only: Do_RI +use Symmetry_Info, only: nIrrep +use Para_Info, only: King, nProcs +use RI_glob, only: A, AMP2, CijK, DoCholExch, iMP2prpt, MxChVInShl, nIJR, nKvec +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Three, Eight, Half +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nGrad, nij_Eff, ij2(2,nij_Eff) +real(kind=wp), intent(inout) :: Grad(nGrad) +real(kind=wp), intent(out) :: Temp(nGrad) +#include "Molcas.fh" +#include "print.fh" +#include "disp.fh" +#include "nsd.fh" +#include "setup.fh" +!#define _CD_TIMING_ +#ifdef _CD_TIMING_ +#include "temptime.fh" +#endif +integer(kind=iwp) :: i, iAng, iAnga(4), iAOst(4), iAOV(4), iBasAO, iBasi, iBasn, iBsInc, iCar, iCmpa(4), id, iFnc(4), ij, ijkla, & + ijMax, ipEI, ipEta, ipiEta, ipMem1, ipMem2, ipP, ipQ, iPrem, iPren, iPrimi, iPrInc, iPrint, ipxA, ipXB, ipXD, & + ipxG, ipZI, iRout, iS, iSD4(0:nSD,4), iSh, iShela(4), iShlla(4), istabs(4), iSym1, iSym2, j, jAng, jBasAO, & + jBasj, jBasn, jBsInc, jDen, jlS, JndGrd(3,4), jPrimj, jPrInc, jS, jS_, k2ij, k2kl, kBasAO, kBask, kBasn, & + kBsInc, kBtch, kPrimk, kPrInc, kS, lA, lA_MP2, lBasAO, lBasl, lBasn, lBsInc, lPriml, lPrInc, lS, lS_, mBtch, & + mdci, mdcj, mdck, mdcl, Mem1, Mem2, MemMax, MemPSO, mij, nab, nBtch, ncd, nDCRR, nDCRS, nEta, nHmab, nHMcd, & + nHrrab, nij, nijkl, nIJRMax, nPairs, nQuad, nRys, nSkal, nSO, nTMax, nZeta +real(kind=wp) :: A_int, Coor(3,4), PMax, Prem, Pren, TCpu1, ThrAO, TMax_all, TWall1 +#ifdef _CD_TIMING_ +real(kind=wp) :: Pget0CPU1, Pget0CPU2, Pget0WALL1, Pget0WALL2, TwoelCPU1, TwoelCPU2, TwoelWall1, TwoelWall2 +#endif +logical(kind=iwp) :: ABCDeq, AeqB, CeqD, DoFock, DoGrad, EQ, FreeK2, Indexation, JfGrad(3,4), No_Batch, Shijij, Verbose +character(len=72) :: frmt +integer(kind=iwp), save :: MemPrm +integer(kind=iwp), allocatable :: Shij(:,:) +real(kind=wp), allocatable :: TMax1(:), TMax2(:,:), Tmp(:,:) +logical(kind=iwp), external :: Rsv_Tsk + +! * +!*********************************************************************** +! * +iRout = 9 +iPrint = nPrint(iRout) +#ifdef _CD_TIMING_ +Twoel2_CPU = Zero +Twoel2_Wall = Zero +Pget2_CPU = Zero +Pget2_Wall = Zero +#endif + +iFnc(1) = 0 +iFnc(2) = 0 +iFnc(3) = 0 +iFnc(4) = 0 +PMax = Zero +Temp(:) = Zero +! * +!*********************************************************************** +! * +! Handle only the auxiliary basis set. + +if (Do_RI) then + call Set_Basis_Mode('Auxiliary') +else + call Set_Basis_Mode('Valence') +end if +call Setup_iSD() +! * +!*********************************************************************** +! * +! Precompute k2 entities. + +Indexation = .false. +DoFock = .false. +DoGrad = .true. +ThrAO = Zero +call SetUp_Ints(nSkal,Indexation,ThrAO,DoFock,DoGrad) +mSkal = nSkal +nPairs = nTri_Elem(nSkal) +nQuad = nTri_Elem(nPairs) +Pren = Zero +Prem = Zero +! * +!*********************************************************************** +! * +MxPrm = 0 +do iAng=0,S%iAngMx + MxPrm = max(MxPrm,S%MaxPrm(iAng)) +end do +nZeta = MxPrm*MxPrm +nEta = MxPrm*MxPrm +! * +!*********************************************************************** +! * +! Compute entities for prescreening at shell level + +if (Do_RI) then + nTMax = nSkal + call mma_allocate(TMax1,nTMax,Label='TMax1') + call mma_allocate(Tmp,nSkal,nSkal,Label='Tmp') + call Shell_MxSchwz(nSkal,Tmp) + TMax1(1:nSkal) = Tmp(1:nSkal,nSkal) + call mma_deallocate(Tmp) + + TMax_all = Zero + do iS=1,nSkal-1 + TMax_all = max(TMax_all,TMax1(iS)) + end do +else + call mma_allocate(TMax2,nSkal,nSkal,Label='TMax2') + call Shell_MxSchwz(nSkal,TMax2) + TMax_all = Zero + do ij=1,nij_Eff + iS = ij2(1,ij) + jS = ij2(2,ij) + TMax_all = max(TMax_all,TMax2(iS,jS)) + end do +end if +! * +!*********************************************************************** +! * +! Allocate some scratch arrays to be used by the pget routines. +! In particular we will have temporary arrays for A_IJ and C_ijK. + +! Lower case: valence basis set +! Upper case: auxiliary basis sets + +if (DoCholExch) then + + ! Find the largest number of contractions in any given shell + ! of auxiliary functions. + + MxChVInShl = 1 + if (Do_RI) then + do i=1,nSkal + MxChVInShl = max(MxChVInShl,iSD(3,i)) + end do + else + write(u6,*) 'Not Implemented for Cholesky yet!' + call Abend() + end if + + ! Scratch for A_IJ + + lA = MxChVInShl*MxChVInShl + call mma_allocate(A,lA,Label='A') + if (iMP2Prpt == 2) then + lA_MP2 = MxChVInShl + call mma_allocate(AMP2,lA_MP2,2,Label='AMP2') + end if + + ! Find the largest set of ij. The basis i and j is due to the + ! CD of the one-particle density. + + nIJRMax = 0 + do jDen=1,nKvec + do iSym1=1,nIrrep + do iSym2=1,nIrrep + nIJRMax = max(nIJRMax,nIJR(iSym1,iSym2,jDen)) + end do + end do + end do + + ! Get scratch for C_kl^I and C_kl^J. + ! Note that we need nDen arrays for C_kl^I and one for C_kl^J + ! A_IJ = Sum(kl) C_kl^I x C_kl^J + + call mma_allocate(CijK,nIJRMax*MxChVInShl*(nKvec+1),Label='CijK') + +end if +! * +!*********************************************************************** +! * +! Create list of non-vanishing pairs + +if (Do_RI) then + mij = nSkal-1 + call mma_allocate(Shij,2,mij,Label='Shij') + nij = 0 + do iS=1,nSkal-1 + if (TMax_All*TMax1(iS) >= CutInt) then + nij = nij+1 + Shij(1,nij) = nSkal + Shij(2,nij) = iS + end if + end do +else + mij = nij_Eff + call mma_allocate(Shij,2,mij,Label='Shij') + nij = 0 + do ij=1,nij_Eff + iS = ij2(1,ij) + jS = ij2(2,ij) + if (TMax_All*TMax2(iS,jS) >= CutInt) then + nij = nij+1 + Shij(1,nij) = iS + Shij(2,nij) = jS + end if + end do +end if +! * +!*********************************************************************** +! * +! Compute FLOP's for the transfer equation. + +do iAng=0,S%iAngMx + do jAng=0,iAng + nHrrab = 0 + do i=0,iAng+1 + do j=0,jAng+1 + if (i+j <= iAng+jAng+1) then + ijMax = min(iAng,jAng)+1 + nHrrab = nHrrab+ijMax*2+1 + end if + end do + end do + end do +end do +! * +!*********************************************************************** +! * +! For a parallel implementation the iterations over shell-pairs +! are parallelized. + +call Init_Tsk(id,nTri_Elem(nij)) +! * +!*********************************************************************** +! * +! In MPP case dispatch one processor to do 1-el gradients first + +if ((nProcs > 1) .and. King()) then + if (Do_RI) call Free_iSD() + call Drvh1(Grad,Temp,nGrad) + !if (nPrint(1) >= 15) call PrGrad(' Gradient excluding two-electron contribution',Grad,lDisp(0),ChDisp) + Temp(:) = Zero + if (Do_RI) then + call Set_Basis_Mode('Auxiliary') + call Setup_iSD() + end if +end if +! * +!*********************************************************************** +! * +call mma_MaxDBLE(MemMax) +if (MemMax > 1000) MemMax = MemMax-1000 +call mma_allocate(Sew_Scr,MemMax,Label='Sew_Scr') +ipMem1 = 1 +! * +!*********************************************************************** +! * +! big loop over individual tasks, distributed over individual nodes +do while (Rsv_Tsk(id,jlS)) + ! make reservation of a task on global task list and get task range + ! in return. Function will be false if no more tasks to execute. + + ! Now do a quadruple loop over shells + + jS_ = int((One+sqrt(Eight*real(jlS,kind=wp)-Three))*Half) + iS = Shij(1,jS_) + jS = Shij(2,jS_) + lS_ = int(real(jlS,kind=wp)-real(jS_,kind=wp)*(real(jS_,kind=wp)-One)*Half) + kS = Shij(1,lS_) + lS = Shij(2,lS_) + call CWTime(TCpu1,TWall1) + + if (Do_RI) then + A_int = TMax1(jS)*TMax1(lS) + else + A_int = TMax2(iS,jS)*TMax2(kS,lS) + end if + if (A_Int < CutInt) cycle + !if ((is == 3) .and. (js == 3) .and. (ks == 1) .and. (ls == 1)) then + ! iPrint = 15 + ! nPrint(39) = 15 + !else + ! iPrint = nPrint(iRout) + ! nPrint(39) = 5 + !end if + if (iPrint >= 15) write(u6,*) 'iS,jS,kS,lS=',iS,jS,kS,lS + ! * + !********************************************************************* + ! * + call Gen_iSD4(iS,jS,kS,lS,iSD,nSD,iSD4) + call Size_SO_block_g(iSD4,nSD,nSO,No_batch) + if (No_batch) cycle + + call Int_Prep_g(iSD4,nSD,Coor,Shijij,iAOV,iStabs) + + ! * + !********************************************************************* + ! * + ! --------> Memory Managment <-------- + ! + ! Compute memory request for the primitives, i.e. + ! how much memory is needed up to the transfer equation. + + call MemRys_g(iSD4,nSD,nRys,MemPrm) + ! * + !********************************************************************* + ! * + ABCDeq = EQ(Coor(1,1),Coor(1,2)) .and. EQ(Coor(1,1),Coor(1,3)) .and. EQ(Coor(1,1),Coor(1,4)) + ijklA = iSD4(1,1)+iSD4(1,2)+iSD4(1,3)+iSD4(1,4) + if ((nIrrep == 1) .and. ABCDeq .and. (mod(ijklA,2) == 1)) cycle + ! * + !********************************************************************* + ! * + ! Decide on the partioning of the shells based on the + ! available memory and the requested memory. + ! + ! Now check if all blocks can be computed and stored at once. + + call SOAO_g(iSD4,nSD,nSO,MemPrm,MemMax,iBsInc,jBsInc,kBsInc,lBsInc,iPrInc,jPrInc,kPrInc,lPrInc,ipMem1,ipMem2,Mem1,Mem2,iFnc, & + MemPSO) + iBasi = iSD4(3,1) + jBasj = iSD4(3,2) + kBask = iSD4(3,3) + lBasl = iSD4(3,4) + ! * + !********************************************************************* + ! * + call Int_Parm_g(iSD4,nSD,iAnga,iCmpa,iShlla,iShela,iPrimi,jPrimj,kPrimk,lPriml,k2ij,nDCRR,k2kl,nDCRS,mdci,mdcj,mdck,mdcl,AeqB, & + CeqD,nZeta,nEta,ipZeta,ipZI,ipP,ipEta,ipEI,ipQ,ipiZet,ipiEta,ipxA,ipxB,ipxG,ipxD,l2DI,nab,nHmab,ncd,nHmcd,nIrrep) + ! * + !********************************************************************* + ! * + ! Scramble arrays (follow angular index) + + do iCar=1,3 + do iSh=1,4 + JndGrd(iCar,iSh) = iSD4(15+iCar,iSh) + if (((iSh == 1) .or. (iSh == 3)) .and. Do_RI) then + JfGrad(iCar,iSh) = .false. + else if (btest(iSD4(15,iSh),iCar-1)) then + JfGrad(iCar,iSh) = .true. + else + JfGrad(iCar,iSh) = .false. + end if + end do + end do + + do iBasAO=1,iBasi,iBsInc + iBasn = min(iBsInc,iBasi-iBasAO+1) + iAOst(1) = iBasAO-1 + do jBasAO=1,jBasj,jBsInc + jBasn = min(jBsInc,jBasj-jBasAO+1) + iAOst(2) = jBasAO-1 + + do kBasAO=1,kBask,kBsInc + kBasn = min(kBsInc,kBask-kBasAO+1) + iAOst(3) = kBasAO-1 + do lBasAO=1,lBasl,lBsInc + lBasn = min(lBsInc,lBasl-lBasAO+1) + iAOst(4) = lBasAO-1 + + ! Get the 2nd order density matrix in SO basis. + + nijkl = iBasn*jBasn*kBasn*lBasn +# ifdef _CD_TIMING_ + call CWTIME(Pget0CPU1,Pget0WALL1) +# endif + call PGet0(iCmpa,iBasn,jBasn,kBasn,lBasn,Shijij,iAOV,iAOst,nijkl,Sew_Scr(ipMem1),nSO,iFnc(1)*iBasn,iFnc(2)*jBasn, & + iFnc(3)*kBasn,iFnc(4)*lBasn,MemPSO,Sew_Scr(ipMem2),Mem2,iS,jS,kS,lS,nQuad,PMax) +# ifdef _CD_TIMING_ + call CWTIME(Pget0CPU2,Pget0WALL2) + Pget2_CPU = Pget2_CPU+Pget0CPU2-Pget0CPU1 + Pget2_Wall = Pget2_Wall+Pget0WALL2-Pget0WALL1 +# endif + if (A_Int*PMax < CutInt) cycle + + ! Compute gradients of shell quadruplet + +# ifdef _CD_TIMING_ + call CWTIME(TwoelCPU1,TwoelWall1) +# endif + call TwoEl_g(Coor,iAnga,iCmpa,iShela,iShlla,iAOV,mdci,mdcj,mdck,mdcl,nRys,Data_k2(k2ij),nab,nHmab,nDCRR,Data_k2(k2kl), & + ncd,nHmcd,nDCRS,Pren,Prem,iPrimi,iPrInc,jPrimj,jPrInc,kPrimk,kPrInc,lPriml,lPrInc, & + Shells(iSD4(0,1))%pCff(1,iBasAO),iBasn,Shells(iSD4(0,2))%pCff(1,jBasAO),jBasn, & + Shells(iSD4(0,3))%pCff(1,kBasAO),kBasn,Shells(iSD4(0,4))%pCff(1,lBasAO),lBasn,Mem_DBLE(ipZeta), & + Mem_DBLE(ipZI),Mem_DBLE(ipP),nZeta,Mem_DBLE(ipEta),Mem_DBLE(ipEI),Mem_DBLE(ipQ),nEta,Mem_DBLE(ipxA), & + Mem_DBLE(ipxB),Mem_DBLE(ipxG),Mem_DBLE(ipxD),Temp,nGrad,JfGrad,JndGrd,Sew_Scr(ipMem1),nSO,Sew_Scr(ipMem2), & + Mem2,Aux,nAux,Shijij) +# ifdef _CD_TIMING_ + call CWTIME(TwoelCPU2,TwoelWall2) + Twoel2_CPU = Twoel2_CPU+TwoelCPU2-TwoelCPU1 + Twoel2_Wall = Twoel2_Wall+TwoelWall2-TwoelWall1 +# endif + if (iPrint >= 15) call PrGrad(' In Drvg1_2Center_RI: Grad',Temp,nGrad,ChDisp) + + end do + end do + + end do + end do + +end do +! End of big task loop +! * +!*********************************************************************** +! * +! E P I L O G U E * +! * +!*********************************************************************** +! * +call mma_deallocate(Sew_Scr) +call Free_Tsk(id) +call mma_deallocate(Shij) +if (allocated(TMax1)) call mma_deallocate(TMax1) +if (allocated(TMax2)) call mma_deallocate(TMax2) +! * +!*********************************************************************** +! * +Verbose = .false. +FreeK2 = .true. +call Term_Ints(Verbose,FreeK2) +! * +!*********************************************************************** +! * +call Sync_Data(Pren,Prem,nBtch,mBtch,kBtch) + +iPren = 3+max(1,int(log10(Pren+0.001_wp))) +iPrem = 3+max(1,int(log10(Prem+0.001_wp))) +write(frmt,'(A,I2,A,I2,A)') '(A,F',iPren,'.0,A,F',iPrem,'.0,A)' +if (iPrint >= 6) then + write(u6,frmt) ' A total of',Pren,' entities were prescreened and',Prem,' were kept.' +end if +! * +!*********************************************************************** +! * +if (DoCholExch) then + call mma_deallocate(CijK) + call mma_deallocate(A) +end if +if (allocated(AMP2)) call mma_deallocate(AMP2) + +call Free_iSD() +! * +!*********************************************************************** +! * +return + +end subroutine Drvg1_2Center_RI diff -Nru openmolcas-22.02/src/ri_util/drvg1_3center_ri.f openmolcas-22.10/src/ri_util/drvg1_3center_ri.f --- openmolcas-22.02/src/ri_util/drvg1_3center_ri.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/drvg1_3center_ri.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,920 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991,1992,2000,2007, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Drvg1_3Center_RI(Grad,Temp,nGrad,ij3,nij_Eff) -************************************************************************ -* * -* Object: driver for two-electron integrals. The four outermost loops * -* will controll the type of the two-electron integral, eg. * -* (ss|ss), (sd|pp), etc. The next four loops will generate * -* list of symmetry distinct centers that do have basis func- * -* tions of the requested type. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* For RI-HF gradients read: * -* "Analytical Gradients of Hartee-Fock Exchange with Density Fitting * -* Approximations", J. Bostrom, F. Aquilante, T. B. Pedersen and R. * -* Lindh, JCTC, 9:204-212 (2013). * -* * -* Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -* Modified for k2 loop. August '91 * -* Modified for gradient calculation. January '92 * -* Modified for SetUp_Ints. January '00 * -* Modified for 3-center RI gradients, March '07 * -************************************************************************ - use k2_setup - use iSD_data - use pso_stuff - use k2_arrays, only: ipZeta, ipiZet, Mem_DBLE, Aux, Sew_Scr - use Basis_Info - use Sizes_of_Seward, only:S - use Gateway_Info, only: CutInt - use RICD_Info, only: Do_RI - use Symmetry_Info, only: nIrrep - use ExTerm, only: CijK, CilK, BklK, VJ - use ExTerm, only: Ymnij, ipYmnij, nYmnij, iOff_Ymnij - use ExTerm, only: Yij, BMP2, iMP2prpt, CMOi, DMLT - use Data_Structures, only: Deallocate_DT - Implicit Real*8 (A-H,O-Z) - Logical, External :: Rsv_Tsk2 -#include "Molcas.fh" -#include "itmax.fh" -#include "real.fh" -#include "stdalloc.fh" -#include "print.fh" -#include "disp.fh" -#include "nsd.fh" -#include "cholesky.fh" -#include "setup.fh" -#include "exterm.fh" -*#define _CD_TIMING_ -#ifdef _CD_TIMING_ -#include "temptime.fh" -#endif -#include "bdshell.fh" - Integer nGrad, nij_Eff - Real*8 Grad(nGrad), Temp(nGrad) - Integer, Allocatable:: ij3(:,:) -* Local arrays - Real*8 Coor(3,4) - Integer iAnga(4), iCmpa(4), iShela(4),iShlla(4), - & iAOV(4), istabs(4), iAOst(4), JndGrd(3,4), iFnc(4), - & nAct(0:7) - Logical EQ, Shijij, AeqB, CeqD, DoGrad, DoFock, Indexation, - & JfGrad(3,4), ABCDeq, No_Batch, Found, FreeK2, Verbose - Character Format*72, Method*8, KSDFT*16 - Character*50 CFmt - Character(LEN=16), Parameter :: SECNAM = 'drvg1_3center_ri' - Integer, External:: Cho_irange -* - Integer iSD4(0:nSD,4) - save MemPrm - Logical FlipFlop -#include "chotime.fh" - - Real*8, Allocatable:: MaxDens(:), SDG(:), Thhalf(:) - Integer, Allocatable:: Shij(:,:), Shij2(:,:), LBList(:) - Real*8, Allocatable:: CVec2(:,:,:), CVec(:,:) - Real*8, Allocatable:: Xmi(:,:,:,:) - Real*8, Allocatable:: Tmp(:,:), TMax_Valence(:,:), - & TMax_Auxiliary(:) -* * -************************************************************************ -* * -* Statement functions -* - iTri(i,j) = max(i,j)*(max(i,j)-3)/2 + i + j -* * -************************************************************************ -* * - iRout = 9 - iPrint = nPrint(iRout) -#ifdef _CD_TIMING_ - Twoel3_CPU = 0.0d0 - Twoel3_Wall = 0.0d0 - Pget3_CPU = 0.0d0 - Pget3_Wall = 0.0d0 -#endif - iFnc(1)=0 - iFnc(2)=0 - iFnc(3)=0 - iFnc(4)=0 - PMax=Zero - call dcopy_(nGrad,[Zero],0,Temp,1) -* * -************************************************************************ -* * - xfk=1.0D-3 ! changing this parameter tunes LK-type screening thr -* xfk=1.0D-12! Debugging -* xfk=0.0D-12! Debugging -* * -************************************************************************ -* * - Call Get_dScalar('Cholesky Threshold',ThrCom) - ThrCom=Max(ThrCom,1.0d-6) ! not to sacrify efficiency too much -* * -************************************************************************ -* * -* Handle mixed basis set -* - If (Do_RI) Then - Call Set_Basis_Mode('Auxiliary') - Call Nr_Shells(nSkal_Auxiliary) - Call Set_Basis_Mode('WithAuxiliary') - Else - Call Set_Basis_Mode('Valence') - nSkal_Auxiliary=0 - End If - Call SetUp_iSD() -* * -************************************************************************ -* * -*-----Precompute k2 entities. -* - Indexation=.False. - DoFock=.False. - DoGrad=.True. - ThrAO=Zero - Call SetUp_Ints(nSkal,Indexation,ThrAO,DoFock,DoGrad) - nSkal_Valence=nSkal-nSkal_Auxiliary - mSkal=nSkal - nPairs=nSkal*(nSkal+1)/2 - nQuad =nPairs*(nPairs+1)/2 - Pren = Zero - Prem = Zero -* * -************************************************************************ -* * - MxPrm = 0 - Do iAng = 0, S%iAngMx - MxPrm = Max(MxPrm,S%MaxPrm(iAng)) - End Do - nZeta = MxPrm * MxPrm - nEta = MxPrm * MxPrm -* * -************************************************************************ -* * - maxnAct=0 - If (lPSO) Then - Call Get_iArray('nAsh',nAct,nIrrep) - maxnnP=nnP(0) - maxnAct=nAct(0) - Do i=1,nIrrep-1 - maxnnP=max(maxnnP,nnP(i)) - maxnAct=max(maxnAct,nAct(i)) - End Do - End If -* * -************************************************************************ -* * -*--- Compute entities for prescreening at shell level -* - Call mma_allocate(TMax_Valence,nSkal_Valence,nSkal_Valence, - & Label='TMax_Valence') - nTMax=nSkal_Auxiliary - If (Do_RI) nTMax = Max(1,nTMax-1) - Call mma_allocate(TMax_Auxiliary,nTMax,Label='TMax_Auxiliary') -* - Call mma_allocate(Tmp,nSkal,nSkal,Label='Tmp') - Call Shell_MxSchwz(nSkal,Tmp) - TMax_all=Zero - Do iS = 1, nSkal_Valence - Do jS = 1, iS - TMax_Valence(iS,jS)=Tmp(iS,jS) - TMax_Valence(jS,iS)=Tmp(iS,jS) - TMax_all=Max(TMax_all,Tmp(iS,jS)) - End Do - End Do - If (Do_RI) Then - Do iS = 1, nSkal_Auxiliary-1 - iS_ = iS + nSkal_Valence - jS_ = nSkal_Valence + nSkal_Auxiliary - TMax_Auxiliary(iS)=Tmp(iS_,jS_) - End Do - End If -* - Call mma_deallocate(Tmp) - -* * -************************************************************************ -* * - MxInShl = 1 - Do i = 1, nSkal_Valence - MxInShl = max(MxInShl,iSD(3,i)*iSD(2,i)) - End Do -* -* Calculate maximum density value for each shellpair -* - lMaxDens = nSkal_Valence*(nSkal_Valence+1)/2 - Call mma_allocate(MaxDens,lMaxDens,Label='MaxDens') - MaxDens(:)=Zero -* - Do iSym = 0, nSym-1 - kS=1+nSkal_Valence*iSym ! note diff wrt declaration of iBDsh - Do j=1,nBas(iSym) - jsh=Cho_Irange(j,iBDsh(kS),nSkal_Valence,.true.) - Do i=1,j - ish=Cho_Irange(i,iBDsh(kS),nSkal_Valence,.true.) - ijS=jsh*(jsh-1)/2+ish - Do iSO=1,nJDens - If (.NOT.DMLT(iSO)%Active) Cycle - ij=j*(j-1)/2+i - Dm_ij=abs(DMLT(iSO)%SB(iSym+1)%A1(ij)) - MaxDens(ijS)=Max(MaxDens(ijS),Dm_ij) - End Do - End Do - End Do - End Do -* - Do i = 1, 5 - If (DMLT(i)%Active) Call Deallocate_DT(DMLT(i)) - End Do -* -* Create list of non-vanishing pairs -* -*1) For the valence basis set -* -* - Call mma_allocate(Shij,2,nSkal_Valence*(nSkal_Valence+1)/2, - & Label='Shij') - nSkal2=0 - Do iS = 1, nSkal_Valence - iiQ = iS*(iS+1)/2 - XDm_ii = MaxDens(iiQ) - Do jS = 1, iS - jjQ = jS*(jS+1)/2 - XDm_jj = MaxDens(jjQ) - ijQ=iS*(iS-1)/2+jS - XDm_ij = MaxDens(ijQ) - XDm_max = Max(XDm_ij,XDm_ii,XDm_jj) - Aint_ij=TMax_Valence(iS,jS) - If (TMax_All*Aint_ij .ge. CutInt) Then -* -* --- FAQ: more aggressive screening to discard shprs formed -* by AOs contributing mainly to the virtual MO space. -* - If (Aint_ij*XDm_max .ge. CutInt) Then - nSkal2 = nSkal2 + 1 - Shij(1,nSkal2)=iS - Shij(2,nSkal2)=jS - End If -* - End If - End Do - End Do -* -*2) For the auxiliary basis set -* - If (Do_RI) Then - mij = nSkal_Auxiliary - Call mma_allocate(Shij2,2,mij,Label='Shij2') - nij=0 - Do jS = nSkal_Valence+1, nSkal-1 - If (TMax_All*TMax_Auxiliary(jS-nSkal_Valence).ge.CutInt) - & Then - nij = nij + 1 - Shij2(1,nij)=nSkal - Shij2(2,nij)=jS - End If - End Do - Else - mij = nij_Eff - Call mma_allocate(Shij2,2,mij,Label='Shij2') - nij=0 - Do ij = 1, nij_Eff - iS = ij3(1,ij) - jS = ij3(2,ij) - If (TMax_All*TMax_Valence(iS,jS).ge.CutInt) Then - nij = nij + 1 - Shij2(1,nij)=iS - Shij2(2,nij)=jS - End If - End Do - End If -* * -************************************************************************ -* * - If (DoCholExch) Then -* -* Find the largest number of contractions in any given shell of -* auxiliary functions. -* - MxChVInShl = 1 - If(Do_RI) Then - Do i = nSkal_Valence+1, nSkal_Valence+nSkal_Auxiliary - MxChVInShl = max(MxChVInShl,iSD(3,i)) - End Do - Else - Write (6,*) 'Not implemented for Cholesky yet!' - Call Abend() - End If -* -* Find the largest set of ij. The i and j basis are due to the CD -* of the one-particle density matrix. -* -* nIJ1: diagonal blocks are triangularized. -* nIJR: diagonal blocks are square. -* nIMax: largest number of i basis in any irrep. -* - nIJ1Max = 0 - nIJRMax = 0 - nIMax = 0 - Do iSym = 1, nIrrep - Do iSO=1,nKDens - nIMax = max(nIMax,nChOrb(iSym-1,iSO)) - End Do - Do jSym = 1, nIrrep - Do iSO=1,nKVec - nIJ1Max = max(nIJ1Max,nIJ1(iSym,jSym,iSO)) - nIJRMax = max(nIJRMax,nIJR(iSym,jSym,iSO)) - End Do - End Do - End Do -* -* Allocate scratch memory for step 4 (Eq. 16). This is done -* in two steps. -* -* First step: Sum(j) X_lj C_ij^K = C_il^K; (l=valence basis) -* Second step: Sum(i) C_il^K X_ki = B_kl^K -* - lCijK = nIJRMax*MxChVInShl - lCilK = MxInShl*nIMax*MxChVInShl - lCilK = Max(lCilK,lCijK) ! it is used as scratch in pget - Call mma_allocate(CijK,lCilK,Label='CijK') - If (lPSO) lCilK=Max(lCilK,maxnAct) ! used as scratch - Call mma_allocate(CilK,lCilK,Label='CilK') - lBklK = MxInShl**2*MxChVInShl - Call mma_allocate(BklK,lBklK,Label='BklK') -* - If(iMp2prpt .eq. 2) Then - lB_mp2 = mxChVInShl*nBas(0)*nBas(0) - Call mma_allocate(BMP2,lB_mp2,2,Label='BMP2') - End If -* * -*----------------------------------------------------------------------* -* * -* The C_ij^K vectors are stored in triangular form. We now -* change this to stricked rectangular/square form. Diagonal -* elements are rescaled. In case of symmetry this is only -* done for the blocks with isym=jSym, i.e. kSym=1 -* - kSym = 1 - nK = NumAuxVec(kSym) -* - Do iSO=1,nKVec - If (lSA) Go to 15 - Do iSym = 1, nSym - jSym = iSym -* jSym = iEor(kSym-1,jSym-1)+1 -* -* Read a whole block of C_ij^K -* - iAdrC = iAdrCVec(kSym,iSym,iSO) - Call mma_allocate(CVec,nIJ1(iSym,jSym,iSO),nK, - & Label='CVec') - Call dDaFile(LuCVector(kSym,iSO),2,CVec, - & nIJ1(iSym,jSym,iSO)*nK,iAdrC) -* - ni = nChOrb(iSym-1,iSO) - Call mma_allocate(CVec2,ni,ni,nK,Label='CVec2') -* nj=ni - - Do KAux = 1, nK -* - Do i = 1, ni - Do j = 1, i-1 - ij = j + i*(i-1)/2 - CVec2(i,j,KAux) = CVec(ij,KAux) - CVec2(j,i,KAux) = CVec(ij,KAux) - End Do - ii = i*(i+1)/2 - CVec2(i,i,KAux) = CVec(ii,KAux)*Sqrt(Two) - End Do -* - End Do -* -* Write back to disk. Note that the file is prepared for -* rectangular/square storage so that one can safely write -* back the expanded set to disk without any overwrite -* problems. -* - iAdrC = iAdrCVec(kSym,iSym,iSO) - Call dDaFile(LuCVector(kSym,iSO),1,CVec2, - & nIJR(iSym,jSym,iSO)*nK,iAdrC) -* - Call mma_deallocate(CVec2) - Call mma_deallocate(CVec) - End Do - 15 Continue - End Do -* * -*----------------------------------------------------------------------* -* * -* Stuff used in the prescreening! -* - MumOrb=0 - NumOrb=0 - Do iSO=1,nKDens - Do jSym = 1, nSym - NumOrb = NumOrb + nChOrb(jSym-1,iSO) - MumOrb = Max( MumOrb, nChOrb(jSym-1,iSO) ) - End Do - If (iSO.lt.nKDens) ipYmnij(iSO+1)=NumOrb - End Do -* -* Scratch store the index of the MOs which finds the estimate -* according to Eq. 18 to be larger than the threshold. -* - Call mma_allocate(Ymnij,NumOrb,Label='Ymnij') - Ymnij(:)=0 - ipYmnij(1)=1 - Do i=2,nKDens - ipYmnij(i)=ipYmnij(1)+ipYmnij(i) - End Do -* -* Make a list for each shell-pair over the largest element -* SQRT(ABS( (mu,nu|mu,nu) )) -* - nnSkal = nSkal_valence*(nSkal_valence+1)/2 - Call mma_allocate(SDG,nnSkal,Label='SDG') - Call get_maxDG(SDG,nnSkal,MxBasSh) -* -* Scratch for reduced lists of X_mi. Used in pget. -* - nXki=MumOrb*MxBasSh*nSym - Call mma_allocate(Yij,nXki,2,nKDens,Label='Yij') -* -* Make a list the largest element X_mu,i for each valence shell -* and a fixed i. X_mu,i defined in Eq. 13. -* - Call mma_allocate(Xmi,MumOrb,nSkal_Valence,nIrrep,nKDens, - & Label='Xmi') -* - Do iSO=1,nKDens - Call get_mXOs(iSO,Xmi(:,:,:,iSO),MumOrb,nSkal_valence, - & nIrrep,nChOrb(0,iSO)) - End Do -* - Else -* - nXki=0 - NumOrb=0 - MumOrb=0 -* - End If -* * -************************************************************************ -* * -* For CASSCF process the active space contribution. -* - If (lPSO) Then - nBas_Aux(0)=nBas_Aux(0)-1 - Call mma_allocate(Thhalf,maxnnP,Label='Thhalf') - nThpkl=MxChVInShl*MxInShl**2 - Call mma_allocate(Thpkl,nThpkl,Label='Thpkl') -* - Call contract_Zpk_Tpxy(Z_p_k ,nZ_p_k, - & Txy ,n_Txy, - & Thhalf,maxnnP, - & DMdiag ,nG1, - & nnP,nBas_Aux, - & nADens,nAvec,nAct,nIrrep) -* - Call mma_deallocate(Thhalf) - nBas_Aux(0)=nBas_Aux(0)+1 - Else - nThpkl=1 - Call mma_allocate(Thpkl,nThpkl,Label='Thpkl') - End If -* * -************************************************************************ -* * -*-------Compute FLOP's for the transfer equation. -* - Do iAng = 0, S%iAngMx - Do jAng = 0, iAng - nHrrab = 0 - Do i = 0, iAng+1 - Do j = 0, jAng+1 - If (i+j.le.iAng+jAng+1) Then - ijMax = Min(iAng,jAng)+1 - nHrrab = nHrrab + ijMax*2+1 - End If - End Do - End Do - End Do - End Do -* * -************************************************************************ -* * -* For a parallel implementation the iterations over shell-pairs -* are parallelized. -* -* If only Coulombic terms are to be processed use dynamic setup. -* Otherwise do batches exactly in the same order as Seward did the -* 2-center terms. -* - Call Get_cArray('Relax Method',Method,8) - If (Method.ne.'KS-DFT ') Then - iOpt=1 - Else - Call Get_cArray('DFT functional',KSDFT,16) - ExFac=Get_ExFac(KSDFT) - iOpt=0 - If (ExFac.ne.Zero) iOpt=1 - End If - If(.not. Do_RI) iOpt=0 -* - If (iOpt.eq.1) Then - Call qpg_iArray('LBList',Found,nSkal2_) - If (Found) Then - Call mma_allocate(LBList,nSkal2_,Label='LBList') - Call Get_iArray('LBList',LBList,nSkal2_) - Else - Call WarningMessage(2,'LBList not found!') - Call Abend() - End If - Else - Call mma_allocate(LBList,1,Label='LBList') - End If - Call Init_Tsk2(id,nSkal2,iOpt,LBList) - Call mma_deallocate(LBList) -* * -************************************************************************ -* * - Call mma_MaxDBLE(MemMax) - Call mma_allocate(Sew_Scr,MemMax,Label='Sew_Scr') - ipMem1=1 -* * -************************************************************************ -************************************************************************ -* * -* Do klS = 1, nSkal2 - 10 Continue - If (.Not.Rsv_Tsk2(id,klS)) Go To 11 -* - kS = Shij(1,klS) - lS = Shij(2,klS) -* - AInt_kl = TMax_Valence(kS,lS) -* - klS_=iTri(kS,lS) -* * -************************************************************************ -* * -* Prescreening stuff for exchange -* - If (DoCholExch) Then -* -* -* For the shell-pair, (kS,lS), pick up the largest element -* Sqrt(Abs( (kappa,lambda|kappa,lambda) )) -* - SDGmn=SDG(klS_) -* -* -* Loop over the MO basis, jb and ib and approximate Y_ij -* (Eq. 18) -* - Do iSO=1,nKVec - FlipFlop=.True. - iMOleft=iSO - iMOright=iSO - If (lSA) iMOright=iSO+2 - 20 Continue - nj=0 - Do jSym = 1, nSym -* - mj=0 - Do jb= 1, nChOrb(jSym-1,iMOleft) - Xjk=Xmi(jb,kS,jSym,iMOleft) - Xjl=Xmi(jb,lS,jSym,iMOleft) -* - jSym_s = jSym - if (ks.ne.ls.or.iMOright.ne.iMOleft) jSym_s=1 - Do iSym = jsym_s, nSym - NumOrb_i = nChOrb(iSym-1,iMOright) - If (iSym.eq.jSym.and.ks.eq.ls - & .and.iMOright.eq.iMOleft) NumOrb_i = jb -* - Do ib = NumOrb_i, 1, -1 - Xik=Xmi(ib,kS,iSym,iMOright) - Xil=Xmi(ib,lS,iSym,iMOright) -* -* --- Yij[mn] = (1+Pij) Xim * (mn|mn)^1/2 * Xjn -* - PZmnij=(Xik*Xjl+Xil*Xjk)*SDGmn -* -* If larger than the threshold put j in the -* list and exit the loop. -* - If ( PZmnij.ge.xfk*ThrCom ) Then -! orbital in the list - Ymnij(ipYmnij(iMOleft)+mj+nj)=jb - mj=mj+1 - Go To 666 - End If - End Do ! ib - End Do ! iSym - 666 Continue - End Do -* -* The first element is to keep track on how many elements -* that were saved. -* -! nOrbs in the list ==> dim(ij)=nOrbs**2 - nYmnij(jSym,iMOleft)=mj - iOff_Ymnij(jSym,iMOleft) = nj - nj = nj + mj -* - End Do ! jSym - If (lSA.and.FlipFlop) Then - FlipFlop=.False. - itmp=iMOleft - iMOleft=iMOright - iMOright=itmp - Go To 20 - EndIf - End Do -* - End If -* * -************************************************************************ -* * - Do ijS = 1, nij - iS = Shij2(1,ijS) - jS = Shij2(2,ijS) -* - If (Do_RI) Then - Aint=AInt_kl*TMax_Auxiliary(jS-nSkal_Valence) - Else - Aint=AInt_kl*TMax_Valence(iS,jS) - End If - If (AInt.lt.CutInt) Go To 14 - If (iPrint.ge.15) Write (6,*) 'iS,jS,kS,lS=',iS,jS,kS,lS -* * -************************************************************************ -* * - Call Gen_iSD4(iS, jS, kS, lS,iSD,nSD,iSD4) - Call Size_SO_block_g(iSD4,nSD,nSO,No_batch) - If (No_batch) Go To 140 -* - Call Int_Prep_g(iSD4,nSD,Coor,Shijij,iAOV,iStabs) -* -* * -************************************************************************ -* * -* --------> Memory Managment <-------- -* -* Compute memory request for the primitives, i.e. -* how much memory is needed up to the transfer -* equation. -* - Call MemRys_g(iSD4,nSD,nRys,MemPrm) -* * -************************************************************************ -* * - ABCDeq=EQ(Coor(1,1),Coor(1,2)) .and. - & EQ(Coor(1,1),Coor(1,3)) .and. - & EQ(Coor(1,1),Coor(1,4)) - ijklA=iSD4(1,1)+iSD4(1,2) - & +iSD4(1,3)+iSD4(1,4) - If (nIrrep.eq.1.and.ABCDeq.and.Mod(ijklA,2).eq.1) - & Go To 140 -* * -************************************************************************ -* * -* Decide on the partioning of the shells based on the -* available memory and the requested memory. -* -* Now check if all blocks can be computed and stored at -* once. -* - Call SOAO_g(iSD4,nSD,nSO, - & MemPrm, MemMax, - & iBsInc,jBsInc,kBsInc,lBsInc, - & iPrInc,jPrInc,kPrInc,lPrInc, - & ipMem1,ipMem2, Mem1, Mem2, - & iFnc, MemPSO) - iBasi = iSD4(3,1) - jBasj = iSD4(3,2) - kBask = iSD4(3,3) - lBasl = iSD4(3,4) -* * -************************************************************************ -* * - Call Int_Parm_g(iSD4,nSD,iAnga, - & iCmpa,iShlla,iShela, - & iPrimi,jPrimj,kPrimk,lPriml, - & k2ij,nDCRR,k2kl,nDCRS, - & mdci,mdcj,mdck,mdcl,AeqB,CeqD, - & nZeta,nEta,ipZeta,ipZI, - & ipP,ipEta,ipEI,ipQ,ipiZet,ipiEta, - & ipxA,ipxB,ipxG,ipxD,l2DI,nab,nHmab,ncd,nHmcd, - & nIrrep) -* * -************************************************************************ -* * -* Scramble arrays (follow angular index) -* - Do iCar = 1, 3 - Do iSh = 1, 4 - JndGrd(iCar,iSh) = iSD4(15+iCar,iSh) - If (iSh.eq.1.and.Do_RI) Then - JfGrad(iCar,iSh) = .False. - JndGrd(iCar,iSh) = 0 - Else If (iAnd(iSD4(15,iSh),2**(iCar-1)) .eq. - & 2**(iCar-1)) Then - JfGrad(iCar,iSh) = .True. - Else - JfGrad(iCar,iSh) = .False. - End If - End Do - End Do -* - Do 400 iBasAO = 1, iBasi, iBsInc - iBasn=Min(iBsInc,iBasi-iBasAO+1) - iAOst(1) = iBasAO-1 - Do 410 jBasAO = 1, jBasj, jBsInc - jBasn=Min(jBsInc,jBasj-jBasAO+1) - iAOst(2) = jBasAO-1 -* - Do 420 kBasAO = 1, kBask, kBsInc - kBasn=Min(kBsInc,kBask-kBasAO+1) - iAOst(3) = kBasAO-1 - Do 430 lBasAO = 1, lBasl, lBsInc - lBasn=Min(lBsInc,lBasl-lBasAO+1) - iAOst(4) = lBasAO-1 -* -*----------Get the 2nd order density matrix in SO basis. -* - nijkl = iBasn*jBasn*kBasn*lBasn -#ifdef _CD_TIMING_ - CALL CWTIME(Pget0CPU1,Pget0WALL1) -#endif - Call PGet0(iCmpa, - & iBasn,jBasn,kBasn,lBasn,Shijij, - & iAOV,iAOst,nijkl,Sew_Scr(ipMem1),nSO, - & iFnc(1)*iBasn,iFnc(2)*jBasn, - & iFnc(3)*kBasn,iFnc(4)*lBasn,MemPSO, - & Sew_Scr(ipMem2),Mem2,iS,jS,kS,lS,nQuad,PMax) -#ifdef _CD_TIMING_ - CALL CWTIME(Pget0CPU2,Pget0WALL2) - Pget3_CPU = Pget3_CPU + Pget0CPU2-Pget0CPU1 - Pget3_Wall = Pget3_Wall + Pget0WALL2-Pget0WALL1 -#endif - If (AInt*PMax.lt.CutInt) Then - Go To 430 - End If -* -*----------Compute gradients of shell quadruplet -* -#ifdef _CD_TIMING_ - Call CWTIME(TwoelCPU1,TwoelWall1) -#endif - Call TwoEl_g(Coor, - & iAnga,iCmpa,iShela,iShlla,iAOV, - & mdci,mdcj,mdck,mdcl,nRys, - & Data_k2(k2ij),nab,nHmab,nDCRR, - & Data_k2(k2kl),ncd,nHmcd,nDCRS,Pren,Prem, - & iPrimi,iPrInc,jPrimj,jPrInc, - & kPrimk,kPrInc,lPriml,lPrInc, - & Shells(iSD4(0,1))%pCff(1,iBasAO),iBasn, - & Shells(iSD4(0,2))%pCff(1,jBasAO),jBasn, - & Shells(iSD4(0,3))%pCff(1,kBasAO),kBasn, - & Shells(iSD4(0,4))%pCff(1,lBasAO),lBasn, - & Mem_DBLE(ipZeta),Mem_DBLE(ipZI),Mem_DBLE(ipP),nZeta, - & Mem_DBLE(ipEta), Mem_DBLE(ipEI),Mem_DBLE(ipQ),nEta, - & Mem_DBLE(ipxA),Mem_DBLE(ipxB), - & Mem_DBLE(ipxG),Mem_DBLE(ipxD),Temp,nGrad, - & JfGrad,JndGrd,Sew_Scr(ipMem1), nSO,Sew_Scr(ipMem2),Mem2, - & Aux,nAux,Shijij) -#ifdef _CD_TIMING_ - Call CWTIME(TwoelCPU2,TwoelWall2) - Twoel3_CPU = Twoel3_CPU + TwoelCPU2-TwoelCPU1 - Twoel3_Wall = Twoel3_Wall + TwoelWall2-TwoelWall1 -#endif -* - If (iPrint.ge.15) - & Call PrGrad(' In Drvg1_3Center_RI: Grad', - & Temp,nGrad,ChDisp) -* - 430 Continue - 420 Continue -* - 410 Continue - 400 Continue -* - 140 Continue -* - 14 Continue - End Do -* - Go To 10 - 11 Continue -* End of big task loop -* * -************************************************************************ -* * -* Write Timings: -* - If(Timings) Then - TotCPU = tbvec(1) + tavec(1) - TotWall = tbvec(2) + tavec(2) - CFmt='(2x,A)' - Write(6,*) - Write(6,CFmt)'Cholesky Gradients timing from A and B vectors:' - Write(6,CFmt)'-----------------------------------------------' - Write(6,*) - Write(6,CFmt)'- - - - - - - - - - - - - - - - - - - - - - - - -' - Write(6,CFmt)' CPU WALL ' - Write(6,CFmt)'- - - - - - - - - - - - - - - - - - - - - - - - -' - - Write(6,'(2x,A26,2f10.2)')'Density (2-center): ' - & //' ',tavec(1),tavec(2) - Write(6,'(2x,A26,2f10.2)')'Density (3-center): ' - & //' ',tbvec(1),tbvec(2) - Write(6,*) - Write(6,'(2x,A26,2f10.2)')'TOTAL ' - & //' ',TotCPU,TotWall - Write(6,CFmt)'- - - - - - - - - - - - - - - - - - - - - - - - -' - Write(6,*) -* - End If - timings = timings_default -* * -************************************************************************ -* * -* E P I L O G U E * -* * -************************************************************************ -* * -* Deallocate scratch for exchange term -* - If (DoCholExch) Then - Call mma_deallocate(Xmi) - Call mma_deallocate(Yij) - Call mma_deallocate(SDG) - Call mma_deallocate(Ymnij) - End If - If (Allocated(CijK)) Call mma_deallocate(CijK) - If (Allocated(CilK)) Call mma_deallocate(CilK) - If (Allocated(BklK)) Call mma_deallocate(BklK) - If (Allocated(VJ)) Call mma_deallocate(VJ) - Do i=1,nKDens - Call Deallocate_DT(CMOi(i)) - End Do - Call mma_deallocate(MaxDens) -* - If (Allocated(BMP2)) Call mma_deallocate(BMP2) - If (Allocated(Thpkl)) Call mma_deallocate(Thpkl) -* - Call mma_deallocate(Sew_Scr) - Call Free_Tsk2(id) - Call mma_deallocate(Shij2) - Call mma_deallocate(Shij) - Call mma_deallocate(TMax_Auxiliary) - Call mma_deallocate(TMax_Valence) -* * -************************************************************************ -* * - Verbose = .False. - FreeK2=.True. - Call Term_Ints(Verbose,FreeK2) -* * -************************************************************************ -* * - Call Sync_Data(Pren,Prem,nBtch,mBtch,kBtch) -* - iPren=3+Max(1,Int(Log10(Pren+0.001D+00))) - iPrem=3+Max(1,Int(Log10(Prem+0.001D+00))) - Write (Format,'(A,I2,A,I2,A)') '(A,F',iPren, - & '.0,A,F',iPrem,'.0,A)' - If (iPrint.ge.6) Then - Write (6,Format) - & ' A total of', Pren,' entities were prescreened and', - & Prem,' were kept.' - End If -* - Call Free_iSD() -* -* * -************************************************************************ -* * - Return -c Avoid unused argument warnings - If (.False.) Call Unused_real_array(Grad) - End diff -Nru openmolcas-22.02/src/ri_util/drvg1_3center_ri.F90 openmolcas-22.10/src/ri_util/drvg1_3center_ri.F90 --- openmolcas-22.02/src/ri_util/drvg1_3center_ri.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/drvg1_3center_ri.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,853 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991,1992,2000,2007, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Drvg1_3Center_RI(Temp,nGrad,ij2,nij_Eff) +!*********************************************************************** +! * +! Object: driver for two-electron integrals. The four outermost loops * +! will control the type of the two-electron integral, eg. * +! (ss|ss), (sd|pp), etc. The next four loops will generate * +! list of symmetry distinct centers that do have basis func- * +! tions of the requested type. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! For RI-HF gradients read: * +! "Analytical Gradients of Hartee-Fock Exchange with Density Fitting * +! Approximations", J. Bostrom, F. Aquilante, T. B. Pedersen and R. * +! Lindh, JCTC, 9:204-212 (2013). * +! * +! Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +! Modified for k2 loop. August '91 * +! Modified for gradient calculation. January '92 * +! Modified for SetUp_Ints. January '00 * +! Modified for 3-center RI gradients, March '07 * +!*********************************************************************** + +use Index_Functions, only: iTri, nTri_Elem +use iSD_data, only: iSD +use pso_stuff, only: DMdiag, lPSO, lSA, n_Txy, nG1, nnP, nZ_p_k, Thpkl, Txy, Z_p_k +use k2_setup, only: Data_k2 +use k2_arrays, only: Aux, ipiZet, ipZeta, Mem_DBLE, Sew_Scr +use Basis_Info, only: nBas, nBas_Aux, Shells +use Sizes_of_Seward, only: S +use Gateway_Info, only: CutInt +use RICD_Info, only: Do_RI +use Symmetry_Info, only: nIrrep +use RI_glob, only: BklK, BMP2, CijK, CilK, CMOi, DMLT, DoCholExch, iAdrCVec, iBDsh, iMP2prpt, iOff_Ymnij, LuCVector, MxChVInShl, & + nAdens, nAvec, nChOrb, nIJ1, nIJR, nJdens, nKdens, nKvec, NumAuxVec, nYmnij, tavec, tbvec, Timings_default, VJ, & + Yij, Ymnij +use Data_Structures, only: Deallocate_DT +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, Two +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nGrad, nij_Eff, ij2(2,nij_Eff) +real(kind=wp), intent(out) :: Temp(nGrad) +#include "Molcas.fh" +#include "print.fh" +#include "disp.fh" +#include "nsd.fh" +#include "cholesky.fh" +#include "setup.fh" +#include "chotime.fh" +!#define _CD_TIMING_ +#ifdef _CD_TIMING_ +#include "temptime.fh" +#endif +integer(kind=iwp) :: i, iAdrC, iAng, iAnga(4), iAOst(4), iAOV(4), ib, iBasAO, iBasi, iBasn, iBsInc, iCar, iCmpa(4), id, iFnc(4), & + iiQ, ij, ijklA, ijMax, ijQ, ijS, iMOleft, iMOright, iOpt, ipEI, ipEta, ipiEta, ipMem1, ipMem2, ipP, ipQ, & + iPrem, iPren, iPrimi, iPrInc, iPrint, ipxA, ipxB, ipxD, ipxG, ipZI, iRout, iS, iS_, iSD4(0:nSD,4), ish, & + iShela(4), iShlla(4), iSO, istabs(4), iSym, itmp, j, jAng, jb, jBasAO, jBasj, jBasn, jBsInc, jjQ, & + JndGrd(3,4), jPrimj, jPrInc, jS, jS_, jsh, jSym, jSym_s, k2ij, k2kl, KAux, kBasAO, kBask, kBasn, kBsInc, & + kBtch, klS, klS_, kPrimk, kPrInc, kS, kSym, lB_mp2, lBasAO, lBasl, lBasn, lBklK, lBsInc, lCijK, lCilK, & + lMaxDens, lPriml, lPrInc, lS, maxnAct, maxnnP, mBtch, mdci, mdcj, mdck, mdcl, Mem1, Mem2, MemMax, MemPSO, & + mij, mj, MumOrb, MxBasSh, MxInShl, nab, nAct(0:7), nBtch, ncd, nDCRR, nDCRS, nEta, nHmab, nHmcd, nHrrab, ni, & + nij, nIJ1Max, nijkl, nIJRMax, nIMax, nj, nK, nnSkal, nPairs, nPrev, nQuad, nRys, nSkal, nSkal2, nSkal2_, & + nSkal_Auxiliary, nSkal_Valence, nSO, nThpkl, nTMax, NumOrb, NumOrb_i, nXki, nZeta +real(kind=wp) :: A_int, A_int_ij, A_int_kl, Coor(3,4), Dm_ij, ExFac, PMax, Prem, Pren, PZmnij, SDGmn, ThrAO, TMax_all, TotCPU, & + TotWall, XDm_ii, XDm_ij, XDm_jj, XDm_max, xfk, Xik, Xil, Xjk, Xjl +#ifdef _CD_TIMING_ +real(kind=wp) :: Pget0CPU1, Pget0CPU2, Pget0WALL1, Pget0WALL2, TwoelCPU1, TwoelCPU2, TwoelWall1, TwoelWall2 +#endif +character(len=80) :: KSDFT +character(len=72) :: frmt +character(len=50) :: CFmt +character(len=8) :: Method +integer(kind=iwp), save :: MemPrm +logical(kind=iwp) :: ABCDeq, AeqB, CeqD, DoFock, DoGrad, EQ, FlipFlop, Found, FreeK2, Indexation, JfGrad(3,4), No_Batch, Shijij, & + Verbose +real*8, allocatable :: MaxDens(:), SDG(:), Thhalf(:) +integer, allocatable :: Shij(:,:), Shij2(:,:), LBList(:) +real*8, allocatable :: CVec2(:,:,:), CVec(:,:) +real*8, allocatable :: Xmi(:,:,:,:) +real*8, allocatable :: Tmp(:,:), TMax_Valence(:,:), TMax_Auxiliary(:) +character(len=*), parameter :: SECNAM = 'drvg1_3center_ri' +integer(kind=iwp), external :: Cho_irange +real(kind=wp), external :: Get_ExFac +logical(kind=iwp), external :: Rsv_Tsk2 + +! * +!*********************************************************************** +! * +iRout = 9 +iPrint = nPrint(iRout) +#ifdef _CD_TIMING_ +Twoel3_CPU = Zero +Twoel3_Wall = Zero +Pget3_CPU = Zero +Pget3_Wall = Zero +#endif +iFnc(:) = 0 +PMax = Zero +Temp(:) = Zero +! * +!*********************************************************************** +! * +xfk = 1.0e-3_wp ! changing this parameter tunes LK-type screening thr +!xfk = 1.0e-12_wp ! Debugging +!xfk = Zero ! Debugging +! * +!*********************************************************************** +! * +call Get_dScalar('Cholesky Threshold',ThrCom) +ThrCom = max(ThrCom,1.0e-6_wp) ! not to sacrify efficiency too much +! * +!*********************************************************************** +! * +! Handle mixed basis set + +if (Do_RI) then + call Set_Basis_Mode('Auxiliary') + call Nr_Shells(nSkal_Auxiliary) + call Set_Basis_Mode('WithAuxiliary') +else + call Set_Basis_Mode('Valence') + nSkal_Auxiliary = 0 +end if +call SetUp_iSD() +! * +!*********************************************************************** +! * +! Precompute k2 entities. + +Indexation = .false. +DoFock = .false. +DoGrad = .true. +ThrAO = Zero +call SetUp_Ints(nSkal,Indexation,ThrAO,DoFock,DoGrad) +nSkal_Valence = nSkal-nSkal_Auxiliary +mSkal = nSkal +nPairs = nTri_Elem(nSkal) +nQuad = nTri_Elem(nPairs) +Pren = Zero +Prem = Zero +! * +!*********************************************************************** +! * +MxPrm = 0 +do iAng=0,S%iAngMx + MxPrm = max(MxPrm,S%MaxPrm(iAng)) +end do +nZeta = MxPrm*MxPrm +nEta = MxPrm*MxPrm +! * +!*********************************************************************** +! * +maxnAct = 0 +if (lPSO) then + call Get_iArray('nAsh',nAct,nIrrep) + maxnnP = nnP(0) + maxnAct = nAct(0) + do i=1,nIrrep-1 + maxnnP = max(maxnnP,nnP(i)) + maxnAct = max(maxnAct,nAct(i)) + end do +end if +! * +!*********************************************************************** +! * +! Compute entities for prescreening at shell level + +call mma_allocate(TMax_Valence,nSkal_Valence,nSkal_Valence,Label='TMax_Valence') +nTMax = nSkal_Auxiliary +if (Do_RI) nTMax = max(1,nTMax-1) +call mma_allocate(TMax_Auxiliary,nTMax,Label='TMax_Auxiliary') + +call mma_allocate(Tmp,nSkal,nSkal,Label='Tmp') +call Shell_MxSchwz(nSkal,Tmp) +TMax_all = Zero +do iS=1,nSkal_Valence + do jS=1,iS + TMax_Valence(iS,jS) = Tmp(iS,jS) + TMax_Valence(jS,iS) = Tmp(iS,jS) + TMax_all = max(TMax_all,Tmp(iS,jS)) + end do +end do +if (Do_RI) then + do iS=1,nSkal_Auxiliary-1 + iS_ = iS+nSkal_Valence + jS_ = nSkal_Valence+nSkal_Auxiliary + TMax_Auxiliary(iS) = Tmp(iS_,jS_) + end do +end if + +call mma_deallocate(Tmp) + +! * +!*********************************************************************** +! * +MxInShl = 1 +do i=1,nSkal_Valence + MxInShl = max(MxInShl,iSD(3,i)*iSD(2,i)) +end do + +! Calculate maximum density value for each shellpair + +lMaxDens = nTri_Elem(nSkal_Valence) +call mma_allocate(MaxDens,lMaxDens,Label='MaxDens') +MaxDens(:) = Zero + +do iSym=0,nSym-1 + kS = 1+nSkal_Valence*iSym ! note diff wrt declaration of iBDsh + do j=1,nBas(iSym) + jsh = Cho_Irange(j,iBDsh(kS),nSkal_Valence,.true.) + do i=1,j + ish = Cho_Irange(i,iBDsh(kS),nSkal_Valence,.true.) + ijS = nTri_Elem(jsh-1)+ish + do iSO=1,nJDens + if (.not. DMLT(iSO)%Active) cycle + ij = iTri(j,i) + Dm_ij = abs(DMLT(iSO)%SB(iSym+1)%A1(ij)) + MaxDens(ijS) = max(MaxDens(ijS),Dm_ij) + end do + end do + end do +end do +call mma_deallocate(iBDsh) + +do i=1,5 + if (DMLT(i)%Active) call Deallocate_DT(DMLT(i)) +end do + +! Create list of non-vanishing pairs + +! 1) For the valence basis set + +call mma_allocate(Shij,2,nTri_Elem(nSkal_Valence),Label='Shij') +nSkal2 = 0 +do iS=1,nSkal_Valence + iiQ = nTri_Elem(iS) + XDm_ii = MaxDens(iiQ) + do jS=1,iS + jjQ = nTri_Elem(jS) + XDm_jj = MaxDens(jjQ) + ijQ = iTri(iS,jS) + XDm_ij = MaxDens(ijQ) + XDm_max = max(XDm_ij,XDm_ii,XDm_jj) + A_int_ij = TMax_Valence(iS,jS) + if (TMax_All*A_int_ij >= CutInt) then + + ! FAQ: more aggressive screening to discard shprs formed + ! by AOs contributing mainly to the virtual MO space. + + if (A_int_ij*XDm_max >= CutInt) then + nSkal2 = nSkal2+1 + Shij(1,nSkal2) = iS + Shij(2,nSkal2) = jS + end if + + end if + end do +end do + +! 2) For the auxiliary basis set + +if (Do_RI) then + mij = nSkal_Auxiliary + call mma_allocate(Shij2,2,mij,Label='Shij2') + nij = 0 + do jS=nSkal_Valence+1,nSkal-1 + if (TMax_All*TMax_Auxiliary(jS-nSkal_Valence) >= CutInt) then + nij = nij+1 + Shij2(1,nij) = nSkal + Shij2(2,nij) = jS + end if + end do +else + mij = nij_Eff + call mma_allocate(Shij2,2,mij,Label='Shij2') + nij = 0 + do ij=1,nij_Eff + iS = ij2(1,ij) + jS = ij2(2,ij) + if (TMax_All*TMax_Valence(iS,jS) >= CutInt) then + nij = nij+1 + Shij2(1,nij) = iS + Shij2(2,nij) = jS + end if + end do +end if +! * +!*********************************************************************** +! * +if (DoCholExch) then + + ! Find the largest number of contractions in any given shell of + ! auxiliary functions. + + MxChVInShl = 1 + if (Do_RI) then + do i=nSkal_Valence+1,nSkal_Valence+nSkal_Auxiliary + MxChVInShl = max(MxChVInShl,iSD(3,i)) + end do + else + write(u6,*) 'Not implemented for Cholesky yet!' + call Abend() + end if + + ! Find the largest set of ij. The i and j basis are due to the CD + ! of the one-particle density matrix. + + ! nIJ1: diagonal blocks are triangularized. + ! nIJR: diagonal blocks are square. + ! nIMax: largest number of i basis in any irrep. + + nIJ1Max = 0 + nIJRMax = 0 + nIMax = 0 + do iSym=1,nIrrep + do iSO=1,nKDens + nIMax = max(nIMax,nChOrb(iSym-1,iSO)) + end do + do jSym=1,nIrrep + do iSO=1,nKVec + nIJ1Max = max(nIJ1Max,nIJ1(iSym,jSym,iSO)) + nIJRMax = max(nIJRMax,nIJR(iSym,jSym,iSO)) + end do + end do + end do + + ! Allocate scratch memory for step 4 (Eq. 16). This is done + ! in two steps. + + ! First step: Sum(j) X_lj C_ij^K = C_il^K; (l=valence basis) + ! Second step: Sum(i) C_il^K X_ki = B_kl^K + + lCijK = nIJRMax*MxChVInShl + lCilK = MxInShl*nIMax*MxChVInShl + lCilK = max(lCilK,lCijK) ! it is used as scratch in pget + call mma_allocate(CijK,lCilK,Label='CijK') + if (lPSO) lCilK = max(lCilK,maxnAct) ! used as scratch + call mma_allocate(CilK,lCilK,Label='CilK') + lBklK = MxInShl**2*MxChVInShl + call mma_allocate(BklK,lBklK,Label='BklK') + + if (iMp2prpt == 2) then + lB_mp2 = mxChVInShl*nBas(0)*nBas(0) + call mma_allocate(BMP2,lB_mp2,2,Label='BMP2') + end if + ! * + !--------------------------------------------------------------------* + ! * + ! The C_ij^K vectors are stored in triangular form. We now + ! change this to stricked rectangular/square form. Diagonal + ! elements are rescaled. In case of symmetry this is only + ! done for the blocks with isym=jSym, i.e. kSym=1 + + kSym = 1 + nK = NumAuxVec(kSym) + + do iSO=1,nKVec + if (lSA) cycle + do iSym=1,nSym + jSym = iSym + !jSym = Mul(kSym,jSym) + + ! Read a whole block of C_ij^K + + iAdrC = iAdrCVec(kSym,iSym,iSO) + call mma_allocate(CVec,nIJ1(iSym,jSym,iSO),nK,Label='CVec') + call dDaFile(LuCVector(kSym,iSO),2,CVec,nIJ1(iSym,jSym,iSO)*nK,iAdrC) + + ni = nChOrb(iSym-1,iSO) + call mma_allocate(CVec2,ni,ni,nK,Label='CVec2') + !nj = ni + + do KAux=1,nK + + ij = 0 + do i=1,ni + do j=1,i-1 + ij = ij+1 + CVec2(i,j,KAux) = CVec(ij,KAux) + CVec2(j,i,KAux) = CVec(ij,KAux) + end do + ij = ij+1 + CVec2(i,i,KAux) = CVec(ij,KAux)*sqrt(Two) + end do + + end do + + ! Write back to disk. Note that the file is prepared for + ! rectangular/square storage so that one can safely write + ! back the expanded set to disk without any overwrite problems. + + iAdrC = iAdrCVec(kSym,iSym,iSO) + call dDaFile(LuCVector(kSym,iSO),1,CVec2,nIJR(iSym,jSym,iSO)*nK,iAdrC) + + call mma_deallocate(CVec2) + call mma_deallocate(CVec) + end do + end do + ! * + !--------------------------------------------------------------------* + ! * + ! Stuff used in the prescreening! + + MumOrb = 0 + NumOrb = 0 + nPrev = 0 + do iSO=1,nKDens + do jSym=1,nSym + NumOrb = NumOrb+nChOrb(jSym-1,iSO) + MumOrb = max(MumOrb,nChOrb(jSym-1,iSO)) + end do + call mma_allocate(Ymnij(iSO)%A,NumOrb-nPrev,label='Ymnij%A') + nPrev = NumOrb + end do + + ! Scratch store the index of the MOs which finds the estimate + ! according to Eq. 18 to be larger than the threshold. + + do i=1,nKDens + Ymnij(i)%A(:) = 0 + end do + + ! Make a list for each shell-pair over the largest element + ! SQRT(ABS( (mu,nu|mu,nu) )) + + nnSkal = nTri_Elem(nSkal_valence) + call mma_allocate(SDG,nnSkal,Label='SDG') + call get_maxDG(SDG,nnSkal,MxBasSh) + + ! Scratch for reduced lists of X_mi. Used in pget. + + nXki = MumOrb*MxBasSh*nSym + call mma_allocate(Yij,nXki,2,nKDens,Label='Yij') + + ! Make a list the largest element X_mu,i for each valence shell + ! and a fixed i. X_mu,i defined in Eq. 13. + + call mma_allocate(Xmi,MumOrb,nSkal_Valence,nIrrep,nKDens,Label='Xmi') + + do iSO=1,nKDens + call get_mXOs(iSO,Xmi(:,:,:,iSO),MumOrb,nSkal_valence,nIrrep,nChOrb(0,iSO)) + end do + +else + + nXki = 0 + NumOrb = 0 + MumOrb = 0 + +end if +! * +!*********************************************************************** +! * +! For CASSCF process the active space contribution. + +if (lPSO) then + nBas_Aux(0) = nBas_Aux(0)-1 + call mma_allocate(Thhalf,maxnnP,Label='Thhalf') + nThpkl = MxChVInShl*MxInShl**2 + call mma_allocate(Thpkl,nThpkl,Label='Thpkl') + + call contract_Zpk_Tpxy(Z_p_k,nZ_p_k,Txy,n_Txy,Thhalf,maxnnP,DMdiag,nG1,nnP,nBas_Aux,nADens,nAvec,nAct,nIrrep) + + call mma_deallocate(Thhalf) + nBas_Aux(0) = nBas_Aux(0)+1 +else + nThpkl = 1 + call mma_allocate(Thpkl,nThpkl,Label='Thpkl') +end if +! * +!*********************************************************************** +! * +! Compute FLOP's for the transfer equation. + +do iAng=0,S%iAngMx + do jAng=0,iAng + nHrrab = 0 + do i=0,iAng+1 + do j=0,jAng+1 + if (i+j <= iAng+jAng+1) then + ijMax = min(iAng,jAng)+1 + nHrrab = nHrrab+ijMax*2+1 + end if + end do + end do + end do +end do +! * +!*********************************************************************** +! * +! For a parallel implementation the iterations over shell-pairs +! are parallelized. + +! If only Coulombic terms are to be processed use dynamic setup. +! Otherwise do batches exactly in the same order as Seward did the +! 2-center terms. + +call Get_cArray('Relax Method',Method,8) +if (Method /= 'KS-DFT ') then + iOpt = 1 +else + call Get_cArray('DFT functional',KSDFT,80) + ExFac = Get_ExFac(KSDFT) + iOpt = 0 + if (ExFac /= Zero) iOpt = 1 +end if +if (.not. Do_RI) iOpt = 0 + +if (iOpt == 1) then + call qpg_iArray('LBList',Found,nSkal2_) + if (Found) then + call mma_allocate(LBList,nSkal2_,Label='LBList') + call Get_iArray('LBList',LBList,nSkal2_) + else + call WarningMessage(2,'LBList not found!') + call Abend() + end if +else + call mma_allocate(LBList,1,Label='LBList') +end if +call Init_Tsk2(id,nSkal2,iOpt,LBList) +call mma_deallocate(LBList) +! * +!*********************************************************************** +! * +call mma_MaxDBLE(MemMax) +if (MemMax > 1000) MemMax = MemMax-1000 +call mma_allocate(Sew_Scr,MemMax,Label='Sew_Scr') +ipMem1 = 1 +! * +!*********************************************************************** +!*********************************************************************** +! * +!do klS=1,nSkal2 +do while (Rsv_Tsk2(id,klS)) + + kS = Shij(1,klS) + lS = Shij(2,klS) + + A_Int_kl = TMax_Valence(kS,lS) + + klS_ = iTri(kS,lS) + ! * + !********************************************************************* + ! * + ! Prescreening stuff for exchange + + if (DoCholExch) then + + ! For the shell-pair, (kS,lS), pick up the largest element + ! Sqrt(Abs( (kappa,lambda|kappa,lambda) )) + + SDGmn = SDG(klS_) + + ! Loop over the MO basis, jb and ib and approximate Y_ij (Eq. 18) + + do iSO=1,nKVec + FlipFlop = .true. + iMOleft = iSO + iMOright = iSO + if (lSA) iMOright = iSO+2 + do + nj = 0 + do jSym=1,nSym + + mj = 0 + do jb=1,nChOrb(jSym-1,iMOleft) + Xjk = Xmi(jb,kS,jSym,iMOleft) + Xjl = Xmi(jb,lS,jSym,iMOleft) + + jSym_s = jSym + if ((ks /= ls) .or. (iMOright /= iMOleft)) jSym_s = 1 + loop1: do iSym=jsym_s,nSym + NumOrb_i = nChOrb(iSym-1,iMOright) + if ((iSym == jSym) .and. (ks == ls) .and. (iMOright == iMOleft)) NumOrb_i = jb + + do ib=NumOrb_i,1,-1 + Xik = Xmi(ib,kS,iSym,iMOright) + Xil = Xmi(ib,lS,iSym,iMOright) + + ! Yij[mn] = (1+Pij) Xim * (mn|mn)^1/2 * Xjn + + PZmnij = (Xik*Xjl+Xil*Xjk)*SDGmn + + ! If larger than the threshold put j in the list and exit the loop. + + if (PZmnij >= xfk*ThrCom) then + ! orbital in the list + mj = mj+1 + Ymnij(iMOleft)%A(mj+nj) = jb + exit loop1 + end if + end do ! ib + end do loop1 ! iSym + end do + + ! The first element is to keep track on how many elements that were saved. + + ! nOrbs in the list ==> dim(ij)=nOrbs**2 + nYmnij(jSym,iMOleft) = mj + iOff_Ymnij(jSym,iMOleft) = nj + nj = nj+mj + + end do ! jSym + if (.not. (lSA .and. FlipFlop)) exit + FlipFlop = .false. + itmp = iMOleft + iMOleft = iMOright + iMOright = itmp + end do + end do + + end if + ! * + !********************************************************************* + ! * + do ijS=1,nij + iS = Shij2(1,ijS) + jS = Shij2(2,ijS) + + if (Do_RI) then + A_int = A_Int_kl*TMax_Auxiliary(jS-nSkal_Valence) + else + A_int = A_Int_kl*TMax_Valence(iS,jS) + end if + if (A_Int < CutInt) cycle + if (iPrint >= 15) write(u6,*) 'iS,jS,kS,lS=',iS,jS,kS,lS + ! * + !******************************************************************* + ! * + call Gen_iSD4(iS,jS,kS,lS,iSD,nSD,iSD4) + call Size_SO_block_g(iSD4,nSD,nSO,No_batch) + if (No_batch) cycle + + call Int_Prep_g(iSD4,nSD,Coor,Shijij,iAOV,iStabs) + ! + ! * + !******************************************************************* + ! * + !--------> Memory Managment <-------- + ! + ! Compute memory request for the primitives, i.e. + ! how much memory is needed up to the transfer equation. + + call MemRys_g(iSD4,nSD,nRys,MemPrm) + ! * + !******************************************************************* + ! * + ABCDeq = EQ(Coor(1,1),Coor(1,2)) .and. EQ(Coor(1,1),Coor(1,3)) .and. EQ(Coor(1,1),Coor(1,4)) + ijklA = iSD4(1,1)+iSD4(1,2)+iSD4(1,3)+iSD4(1,4) + if ((nIrrep == 1) .and. ABCDeq .and. (mod(ijklA,2) == 1)) cycle + ! * + !******************************************************************* + ! * + ! Decide on the partioning of the shells based on the + ! available memory and the requested memory. + + ! Now check if all blocks can be computed and stored at once. + + call SOAO_g(iSD4,nSD,nSO,MemPrm,MemMax,iBsInc,jBsInc,kBsInc,lBsInc,iPrInc,jPrInc,kPrInc,lPrInc,ipMem1,ipMem2,Mem1,Mem2,iFnc, & + MemPSO) + iBasi = iSD4(3,1) + jBasj = iSD4(3,2) + kBask = iSD4(3,3) + lBasl = iSD4(3,4) + ! * + !******************************************************************* + ! * + call Int_Parm_g(iSD4,nSD,iAnga,iCmpa,iShlla,iShela,iPrimi,jPrimj,kPrimk,lPriml,k2ij,nDCRR,k2kl,nDCRS,mdci,mdcj,mdck,mdcl,AeqB, & + CeqD,nZeta,nEta,ipZeta,ipZI,ipP,ipEta,ipEI,ipQ,ipiZet,ipiEta,ipxA,ipxB,ipxG,ipxD,l2DI,nab,nHmab,ncd,nHmcd, & + nIrrep) + ! * + !******************************************************************* + ! * + ! Scramble arrays (follow angular index) + ! + do iCar=1,3 + do iSh=1,4 + JndGrd(iCar,iSh) = iSD4(15+iCar,iSh) + if ((iSh == 1) .and. Do_RI) then + JfGrad(iCar,iSh) = .false. + JndGrd(iCar,iSh) = 0 + else if (btest(iSD4(15,iSh),iCar-1)) then + JfGrad(iCar,iSh) = .true. + else + JfGrad(iCar,iSh) = .false. + end if + end do + end do + + do iBasAO=1,iBasi,iBsInc + iBasn = min(iBsInc,iBasi-iBasAO+1) + iAOst(1) = iBasAO-1 + do jBasAO=1,jBasj,jBsInc + jBasn = min(jBsInc,jBasj-jBasAO+1) + iAOst(2) = jBasAO-1 + + do kBasAO=1,kBask,kBsInc + kBasn = min(kBsInc,kBask-kBasAO+1) + iAOst(3) = kBasAO-1 + do lBasAO=1,lBasl,lBsInc + lBasn = min(lBsInc,lBasl-lBasAO+1) + iAOst(4) = lBasAO-1 + + ! Get the 2nd order density matrix in SO basis. + + nijkl = iBasn*jBasn*kBasn*lBasn +# ifdef _CD_TIMING_ + call CWTIME(Pget0CPU1,Pget0WALL1) +# endif + call PGet0(iCmpa,iBasn,jBasn,kBasn,lBasn,Shijij,iAOV,iAOst,nijkl,Sew_Scr(ipMem1),nSO,iFnc(1)*iBasn,iFnc(2)*jBasn, & + iFnc(3)*kBasn,iFnc(4)*lBasn,MemPSO,Sew_Scr(ipMem2),Mem2,iS,jS,kS,lS,nQuad,PMax) +# ifdef _CD_TIMING_ + call CWTIME(Pget0CPU2,Pget0WALL2) + Pget3_CPU = Pget3_CPU+Pget0CPU2-Pget0CPU1 + Pget3_Wall = Pget3_Wall+Pget0WALL2-Pget0WALL1 +# endif + if (A_Int*PMax < CutInt) cycle + + ! Compute gradients of shell quadruplet + +# ifdef _CD_TIMING_ + call CWTIME(TwoelCPU1,TwoelWall1) +# endif + call TwoEl_g(Coor,iAnga,iCmpa,iShela,iShlla,iAOV,mdci,mdcj,mdck,mdcl,nRys,Data_k2(k2ij),nab,nHmab,nDCRR,Data_k2(k2kl), & + ncd,nHmcd,nDCRS,Pren,Prem,iPrimi,iPrInc,jPrimj,jPrInc,kPrimk,kPrInc,lPriml,lPrInc, & + Shells(iSD4(0,1))%pCff(1,iBasAO),iBasn,Shells(iSD4(0,2))%pCff(1,jBasAO),jBasn, & + Shells(iSD4(0,3))%pCff(1,kBasAO),kBasn,Shells(iSD4(0,4))%pCff(1,lBasAO),lBasn,Mem_DBLE(ipZeta), & + Mem_DBLE(ipZI),Mem_DBLE(ipP),nZeta,Mem_DBLE(ipEta),Mem_DBLE(ipEI),Mem_DBLE(ipQ),nEta,Mem_DBLE(ipxA), & + Mem_DBLE(ipxB),Mem_DBLE(ipxG),Mem_DBLE(ipxD),Temp,nGrad,JfGrad,JndGrd,Sew_Scr(ipMem1),nSO, & + Sew_Scr(ipMem2),Mem2,Aux,nAux,Shijij) +# ifdef _CD_TIMING_ + call CWTIME(TwoelCPU2,TwoelWall2) + Twoel3_CPU = Twoel3_CPU+TwoelCPU2-TwoelCPU1 + Twoel3_Wall = Twoel3_Wall+TwoelWall2-TwoelWall1 +# endif + + if (iPrint >= 15) call PrGrad(' In Drvg1_3Center_RI: Temp',Temp,nGrad,ChDisp) + + end do + end do + + end do + end do + + end do + +end do +! End of big task loop +! * +!*********************************************************************** +! * +! Write Timings: + +if (Timings) then + TotCPU = tbvec(1)+tavec(1) + TotWall = tbvec(2)+tavec(2) + CFmt = '(2x,A)' + write(u6,*) + write(u6,CFmt) 'Cholesky Gradients timing from A and B vectors:' + write(u6,CFmt) '-----------------------------------------------' + write(u6,*) + write(u6,CFmt) '- - - - - - - - - - - - - - - - - - - - - - - - -' + write(u6,CFmt) ' CPU WALL ' + write(u6,CFmt) '- - - - - - - - - - - - - - - - - - - - - - - - -' + + write(u6,'(2x,A26,2f10.2)') 'Density (2-center): ',tavec(1),tavec(2) + write(u6,'(2x,A26,2f10.2)') 'Density (3-center): ',tbvec(1),tbvec(2) + write(u6,*) + write(u6,'(2x,A26,2f10.2)') 'TOTAL ',TotCPU,TotWall + write(u6,CFmt) '- - - - - - - - - - - - - - - - - - - - - - - - -' + write(u6,*) + +end if +timings = timings_default +! * +!*********************************************************************** +! * +! E P I L O G U E * +! * +!*********************************************************************** +! * +! Deallocate scratch for exchange term + +if (DoCholExch) then + call mma_deallocate(Xmi) + call mma_deallocate(Yij) + call mma_deallocate(SDG) + do i=1,nKDens + call mma_deallocate(Ymnij(i)%A) + end do +end if +if (allocated(CijK)) call mma_deallocate(CijK) +if (allocated(CilK)) call mma_deallocate(CilK) +if (allocated(BklK)) call mma_deallocate(BklK) +if (allocated(VJ)) call mma_deallocate(VJ) +do i=1,nKDens + call Deallocate_DT(CMOi(i)) +end do +call mma_deallocate(MaxDens) + +if (allocated(BMP2)) call mma_deallocate(BMP2) +if (allocated(Thpkl)) call mma_deallocate(Thpkl) + +call mma_deallocate(Sew_Scr) +call Free_Tsk2(id) +call mma_deallocate(Shij2) +call mma_deallocate(Shij) +call mma_deallocate(TMax_Auxiliary) +call mma_deallocate(TMax_Valence) +! * +!*********************************************************************** +! * +Verbose = .false. +FreeK2 = .true. +call Term_Ints(Verbose,FreeK2) +! * +!*********************************************************************** +! * +call Sync_Data(Pren,Prem,nBtch,mBtch,kBtch) + +iPren = 3+max(1,int(log10(Pren+0.001_wp))) +iPrem = 3+max(1,int(log10(Prem+0.001_wp))) +write(frmt,'(A,I2,A,I2,A)') '(A,F',iPren,'.0,A,F',iPrem,'.0,A)' +if (iPrint >= 6) then + write(u6,frmt) ' A total of',Pren,' entities were prescreened and',Prem,' were kept.' +end if + +call Free_iSD() +! * +!*********************************************************************** +! * +return + +end subroutine Drvg1_3Center_RI diff -Nru openmolcas-22.02/src/ri_util/drvg1_ri.f openmolcas-22.10/src/ri_util/drvg1_ri.f --- openmolcas-22.02/src/ri_util/drvg1_ri.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/drvg1_ri.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,549 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 2007, Roland Lindh * -************************************************************************ - - SubRoutine Drvg1_RI(Grad,Temp,nGrad) -************************************************************************ -* * -* Object: superdriver for gradients for the RI/DF approximation * -* * -* * -* Author: Roland Lindh, Dep. Chem. Phys., Lund University, Sweden * -* January '07 * -* * -************************************************************************ - use Basis_Info, only: nBas, nBas_Aux - use pso_stuff - use RICD_Info, only: Do_RI, Cholesky - use Symmetry_Info, only: nIrrep - use Para_Info, only: myRank, nProcs - use Data_Structures, only: Deallocate_DT - use ExTerm, only: iMP2prpt, LuAVector, LuBVector - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "disp.fh" -#include "print.fh" -#include "cholesky.fh" -#include "stdalloc.fh" -#include "real.fh" -#include "exterm.fh" -*#define _CD_TIMING_ -#ifdef _CD_TIMING_ -#include "temptime.fh" -#endif - Real*8 Grad(nGrad), Temp(nGrad) - Character*6 Fname - Character*7 Fname2 - Character*8 Method - Logical Found - Integer nAct(0:7) - Real*8, Allocatable:: V_k_new(:,:), U_k_new(:) - Integer, Allocatable:: iZk(:), iVk(:), iUk(:) - - Real*8, Allocatable:: DMTmp(:), Tmp(:) - Integer, Allocatable :: SO_ab(:), ij2(:,:) -* * -************************************************************************ -* * - Interface - - Subroutine Compute_AuxVec(ipVk,ipZpk,myProc,nProc,ipUk) - Integer nProc, myProc - Integer ipVk(nProc), ipZpk(nProc) - Integer, Optional:: ipUk(nProc) - End Subroutine Compute_AuxVec - - Subroutine Effective_CD_Pairs(ij2,nij_Eff) - Integer, Allocatable:: ij2(:,:) - Integer nij_Eff - End Subroutine Effective_CD_Pairs - - SubRoutine Drvg1_2Center_RI(Grad,Temp,nGrad,ij2,nij_Eff) - Integer nGrad, nij_Eff - Real*8 Grad(nGrad), Temp(nGrad) - Integer, Allocatable :: ij2(:,:) - End SubRoutine Drvg1_2Center_RI - - SubRoutine Drvg1_3Center_RI(Grad,Temp,nGrad,ij3,nij_Eff) - Integer nGrad, nij_Eff - Real*8 Grad(nGrad), Temp(nGrad) - Integer, Allocatable:: ij3(:,:) - End SubRoutine Drvg1_3Center_RI - - End Interface -* * -************************************************************************ -* * - DoCholExch = .false. -* * -************************************************************************ -* * - Call CWTime(TCpu1,TWall1) -* * -************************************************************************ -* * - iRout = 33 - iPrint = nPrint(iRout) -* * -************************************************************************ -* * - Call FZero(Temp,nGrad) - Call mma_allocate(Tmp,nGrad,Label='Tmp') -* * -************************************************************************ -* * - BufFrac=0.1D0 - Call Cho_X_Init(irc,BufFrac) - If (irc.ne.0) Then - Call WarningMessage(2,' Drvg1_RI: Cho_X_Init failed') - Call Abend() - End If -* -******************************************** -* -* Decide if its MP2 -* - iMp2Prpt = 0 - Call Get_cArray('Relax Method',Method,8) - If(Method .eq. 'MBPT2 ') Then - Call Get_iScalar('mp2prpt',iMp2Prpt) - End If -* * -************************************************************************ -* * -* In case of the Cholesky approach compute the A and Q matrices. -* - If (Cholesky.and..Not.Do_RI) Then -* - If (nIrrep.ne.1) Then - Call WarningMessage(2,'Error in Drvg1_RI') - Write (6,*) ' CD gradients with symmetry is not' - & //' implemented yet!' - Call Abend() - End If -* - Call Cho_X_CalculateGMat(irc) - If (iRC.ne.0) Then - Call WarningMessage(2,'Error in Drvg1_RI') - Write (6,*) 'Failure during G matrix construction' - Call Abend() - End If -* -* Now compute the Q matrix. -* -* Note that, as the A matrix is -* computed in the full-pivoted (rows and columns) storage, -* also the resulting Q matrix is full-pivoted. -* This is necessary for the ReMap_V_k to work (see below). -* In the RI case, only the column pivoting of Q is -* preserved. One day we may want to unify the two cases. -* -* (In Cholesky the Q matrix is stored as squared. In RI, -* it is, in general, rectangular as lin. dep. may occur -* among its columns). -* - Call ICopy(nIrrep,NumCho,1,nBas_Aux,1) - Call GAIGOP(nBas_Aux,nIrrep,'+') - Call Gen_QVec(nIrrep,nBas_Aux) -* - End If -* * -************************************************************************ -* * -*-----Prepare handling of two-particle density. -* - Call PrepP() -* * -************************************************************************ -* * -* Initialize the number of sets of densities and auxiliary vectors - nAdens=1 - nAVec=1 - nKdens=1 - nJdens=1 -* - Call Qpg_iScalar('SCF mode',Found) - If (Found) Then - Call Get_iScalar('SCF mode',iUHF) ! either 0 or 1 - Else - iUHF=0 - EndIf - nKdens=nKdens+iUHF - nKvec=nKdens -* - If (lPSO.and.lSA) Then - nJdens=5 - nKdens=4 - nKVec=2 - nAdens=2 - nAvec=4 - EndIf -* -*MGD Could be more efficient memory-wise when symmetry -*--- Decompose the 2-particle active density matrix - mAO=0 - If (lPSO) Then - Call Get_iArray('nAsh',nAct,nIrrep) - n_Txy=0 - Do ijsym=0,nIrrep-1 - ntmp=0 - Do jSym=0,nIrrep-1 - isym=iEOR(jSym,ijsym) - If (iSym.gt.jSym) Then - ntmp=ntmp+nAct(iSym)*nAct(jSym) - Else if (iSym.eq.jSym) Then - ntmp=ntmp+nAct(iSym)*(nAct(iSym)+1)/2 - EndIf - EndDo - n_Txy=n_Txy+ntmp**2 - mAO=mAO+nAct(ijsym)*nBas(ijsym) - EndDo - m_Txy=nAdens - Call mma_allocate(Txy,n_Txy,nAdens,Label='Txy') - Call mma_allocate(DMdiag,nG1,nAdens,Label='DMdiag') - Call mma_allocate(DMtmp,nG1*(nG1+1)/2,Label='DMtmp') - Call iZero(nnP,nIrrep) - Call Compute_txy(G1(1,1),nG1,Txy,n_Txy,nAdens,nIrrep,DMdiag, - & DMtmp,nAct) - Call mma_deallocate(DMtmp) - Else - Call mma_allocate(Txy,1,1,Label='Txy') - Call mma_allocate(DMdiag,1,1,Label='DMdiag') - EndIf - n_ij2K=0 - nZ_p_k=0 - nZ_p_l=0 - nZ_p_k_New=0 - Do i=0,nIrrep-1 - iOff_ij2K(i+1) = n_ij2K - n_ij2K = n_ij2K + nBas(i)*(nBas(i)+1)/2 - nZ_p_k = nZ_p_k + nnP(i)*nBas_Aux(i) ! Global size - nZ_p_l = nZ_p_l + nnP(i)*NumCho(i+1) ! Local size - nZ_p_k_New = nZ_p_k_New + nnP(i)*nBas(i)*(nBas(i)+1)/2 - End Do - If (Do_RI) nZ_p_k=nZ_p_k-nnP(0) - -* Allocate the "global" Z_p_k array - - If (lPSO) Then - Call mma_allocate(Z_p_k,nZ_p_k,nAVec,Label='Z_p_k') - Else - nZ_p_k=1 - Call mma_allocate(Z_p_k,1,nAVec,Label='Z_p_k') - EndIf - Z_p_k(:,:)=Zero -* -* Preprocess the RI and Q vectors as follows -* -* Allocate memory for V_k -* - nV_k=nBas_Aux(0) - If (Do_RI) nV_k=nV_k-1 -* - nAux_Tot=0 - Do iIrrep = 0, nIrrep-1 - nAux_Tot=nAux_Tot+nBas_Aux(iIrrep) - End Do -* -* - call mma_allocate(V_K,nV_k,nJdens,Label='V_k') - V_k(:,:)=Zero - If(iMp2prpt .eq. 2) Then - call mma_allocate(U_K,nV_k,Label='U_k') - U_k(:)=Zero - Else - call mma_allocate(U_K,1,Label='U_k') - End If -* ~ -* 1) Compute the V_k vector -* ~ -* 2) Contract V_k and Q (transpose) vectors producing the V_k -* -* Note: the above two points apply to Z_p_k as well (active space) -* - Call mma_allocate(iVk,[0,nProcs-1],Label='iVk') - Call mma_allocate(iZk,[0,nProcs-1],Label='iZk') - iVk(:)=0 - iZk(:)=0 -* iVk(myRank) = NumCho(1)*nJdens - iVk(myRank) = NumCho(1) -* iZk(myRank)= nZ_p_l*nAvec ! store the local size of Zk - iZk(myRank)= nZ_p_l ! store the local size of Zk - Call GAIGOP(iVk,nProcs,'+') - Call GAIGOP(iZk,nProcs,'+') ! distribute to all nodes - -! Compute the starting position in the global sense for each node. - - iStart=1 - jStart=1 - Do j=0,nProcs-1 ! Loop over all nodes - itmp=iVk(j) - iVk(j)=iStart - iStart = iStart + itmp - - jtmp=iZk(j) - iZk(j)=jStart - jStart = jStart + jtmp - End Do -* - If(iMp2prpt .eq. 2) Then - Call mma_allocate(iUk,[0,nProcs-1],Label='iUk') - iUk(:)=0 - iUk(myRank) = NumCho(1) - Call GAIGOP(iUk,nProcs,'+') - kStart=1 - Do j = 0,nProcs-1 - kTmp=iUk(j) - iUk(j)=kStart - kStart = kStart + kTmp - End Do -* - Call Compute_AuxVec(iVk,iZk,myRank+1,nProcs,ipUk=iUk) - - Else - - Call Compute_AuxVec(iVk,iZk,myRank+1,nProcs) - - End If -* * -************************************************************************ -* * - - If (Cholesky.and..Not.Do_RI) Then -* -* Map from Cholesky auxiliary basis to the full -* 1-center valence product basis. -* - Call mma_allocate(ij2K,n_ij2K,Label='ij2K') - ij2K(:)=0 - nV_k_New=nBas(0)*(nBas(0)+1)/2 - Call mma_allocate(V_k_new,nV_k_New,nJdens,Label="V_k_new") - V_k_new(:,:)=Zero -* - If (iMp2prpt .eq. 2) Then - Call mma_allocate(U_k_new,nV_k_New,Label="U_k_new") - U_k_new(:)=Zero - End If - -* - Call mma_allocate(SO_ab,2*nAux_Tot,Label='SO_ab') - SO_ab(:)=0 - iOff = 1 - Do iSym = 1, nSym - Call CHO_X_GET_PARDIAG(iSym,SO_ab(iOff)) - - If((iSym .eq. 1) .and. (iMp2prpt .eq. 2)) Then - Call ReMap_U_k(U_k,nV_k,U_k_New,nV_k_New,SO_ab) - End If - m_ij2K = nBas(iSym-1)*(nBas(iSym-1)+1)/2 - Do i=0,nJDens-1 - Call ReMap_V_k(iSym,V_k(1,1+i),nV_k, - & V_k_new(1,1+i),nV_k_New, - & SO_ab(iOff),ij2K(iOff_ij2K(iSym)+1), - & m_ij2K) - EndDo - iOff = iOff + 2*nBas_Aux(iSym-1) - End Do -* - nV_k=nV_k_new -* - Call mma_deallocate(SO_ab) - Call mma_deallocate(V_k) - Call mma_allocate(V_k,nV_k,nJdens,Label='V_k') - V_k(:,:)=V_k_new(:,:) - Call mma_deallocate(V_k_new) - - If(iMp2prpt .eq. 2) Then - Call mma_deallocate(U_k) - Call mma_allocate(U_k,nV_k,Label='U_k') - U_k(:)=U_k_new(:) - Call mma_deallocate(U_k_new) - End If - -* * -************************************************************************ -* * -* Get the effective list of shell-pairs in case of CD -* - Call Effective_CD_Pairs(ij2,nij_Eff) - Else - nij_Eff = 0 - End If -* * -************************************************************************ -* * -* Open C-vector-files if nSym is equal to 1 -* - If(DoCholExch) Then - Do i=1,nKvec - Do jSym = 1, nSym - iSeed = 7 + jSym+(i-1)*nSym - LuCVector(jSym,i) = IsFreeUnit(iSeed) - If (i.eq.1) Then - Write(Fname,'(A4,I1,I1)') 'CVEA',jSym - ElseIf (i.eq.2) Then - Write(Fname,'(A4,I1,I1)') 'CVEB',jSym - EndIf - Call DANAME_MF_WA(LuCVector(jSym,i),Fname) - End Do - End Do -* Initialize timings - Do i = 1,2 - tavec(i) = 0.0d0 - tbvec(i) = 0.0d0 - End Do - End If - If(imp2prpt.eq.2) Then - Do i = 1, 2 - iSeed = 8 + nSym - LuAVector(i) = IsFreeUnit(iSeed) - Write(Fname2,'(A5,I1)') 'AMP2V', i - Call DaName_MF_WA(LuAVector(i),Fname2) - iSeed = 9 + nSym - LuBVector(i) = IsFreeUnit(iSeed) - Write(Fname,'(A5,I1)') 'BMP2V', i+2 - Call DaName_MF_WA(LuBVector(i),Fname) - End Do - End If -* * -************************************************************************ -* * -* Compute contributions due to the "2-center" two-electron integrals -* - Case_2C=.True. - Call Drvg1_2center_RI(Temp,Tmp,nGrad,ij2,nij_Eff) - Call GADGOP(Tmp,nGrad,'+') - If (iPrint.ge.15) Call PrGrad( - & ' RI-Two-electron contribution - 2-center term', - & Tmp,nGrad,ChDisp) - Call DaXpY_(nGrad,One,Temp,1,Grad,1) ! Move any 1-el contr. - call dcopy_(nGrad,Tmp,1,Temp,1) - Call DScal_(nGrad,-One,Temp,1) - Case_2C=.False. -* * -************************************************************************ -* * -* Compute contributions due to the "3-center" two-electron integrals -* - Case_3C=.True. - Call Drvg1_3center_RI(Temp,Tmp,nGrad,ij2,nij_Eff) - Call GADGOP(Tmp,nGrad,'+') - If (iPrint.ge.15) Call PrGrad( - & ' RI-Two-electron contribution - 3-center term', - & Tmp,nGrad,ChDisp) - Call DaXpY_(nGrad,Two,Tmp,1,Temp,1) - Case_3C=.False. - If(Allocated(Txy)) Call mma_deallocate(Txy) - If(Allocated(DMdiag)) Call mma_deallocate(DMdiag) - If (Allocated(AOrb)) Then - Do iADens = 1, nADens - Call Deallocate_DT(AOrb(iADens)) - End Do - deallocate(AOrb) - End If -* * -************************************************************************ -* * -* - If(DoCholExch) Then - Do i=1,nKvec - Do jSym = 1, nSym - Call DaClos(luCVector(jSym,i)) - EndDo - End Do - End If - If(iMp2prpt .eq. 2) Then - Do i = 1, 2 - Call DaClos(LuAVector(i)) - Call DaClos(LuBVector(i)) - End Do - End If - - - If (Cholesky.and..Not.Do_RI) Then - Call mma_deallocate(ij2) - Call mma_deallocate(ij2K) - End If - Call CloseP - Call mma_deallocate(iZk) - Call mma_deallocate(iVk) - - If (Allocated(iUk)) Call mma_deallocate(iUk) - If (Allocated(Z_p_k)) Call mma_deallocate(Z_p_k) - If (Allocated(V_k)) Call mma_deallocate(V_k) - If (Allocated(U_k)) Call mma_deallocate(U_k) - - Call Cho_X_Final(irc) - If (irc.ne.0) Then - Call WarningMessage(2,' Drvg1_RI: Cho_X_Final failed') - Call Abend() - End If - Call mma_deallocate(Tmp) - If (iPrint.ge.15) Call PrGrad( - & ' RI-Two-electron contribution - Temp', - & Temp,nGrad,ChDisp) -* * -************************************************************************ -* * - Call CWTime(TCpu2,TWall2) - Call SavTim(6,TCpu2-TCpu1,TWall2-TWall1) -* -#ifdef _CD_TIMING_ - Drvg1_CPU = TCpu2-TCpu1 - Drvg1_Wall= TWall2-TWall1 - Write(6,*) '-------------------------' - Write(6,*) 'Time spent in Cho_get_grad:' - Write(6,*) 'Wall/CPU',ChoGet_Wall, ChoGet_CPU - Write(6,*) '-------------------------' - Write(6,*) 'Time spent in Mult_Rijk_Qkl:' - Write(6,*) 'Wall/CPU',rMult_Wall, rMult_CPU - Write(6,*) '-------------------------' - Write(6,*) 'Time spent in Prepp:' - Write(6,*) 'Wall/CPU',Prepp_Wall, Prepp_CPU - Write(6,*) '-------------------------' - Write(6,*) 'Time spent in Pget_ri2:' - Write(6,*) 'Wall/CPU',Pget2_Wall, Pget2_CPU - Write(6,*) '-------------------------' - Write(6,*) 'Time spent in Pget_ri3:' - Write(6,*) 'Wall/CPU',Pget3_Wall, Pget3_CPU - Write(6,*) '-------------------------' - Write(6,*) 'Time spent in Drvg1_ri:' - Write(6,*) 'Wall/CPU',Drvg1_Wall, Drvg1_CPU - Write(6,*) '-------------------------' - Total_Dens_Wall = ChoGet_Wall+rMult_Wall+Prepp_Wall+Pget2_Wall + - & Pget3_Wall - Total_Dens_CPU = ChoGet_CPU+rMult_CPU+Prepp_CPU+Pget2_CPU + - & Pget3_CPU - Total_Der_Wall = Drvg1_Wall - Total_Dens_Wall - Total_Der_CPU = Drvg1_CPU - Total_Dens_CPU - Total_Der_Wall2 = TwoEl2_Wall + TwoEl3_Wall - Total_Der_CPU2 = TwoEl2_CPU + TwoEl3_CPU - - Write(6,*) 'Total Time for Density:' - Write(6,*) 'Wall/CPU',Total_Dens_Wall, Total_Dens_CPU - Write(6,*) '-------------------------' - Write(6,*) 'Total TIme for 2-center Derivatives:' - Write(6,*) 'Wall/CPU',Twoel2_Wall, Twoel2_CPU - Write(6,*) '-------------------------' - Write(6,*) 'Total TIme for 3-center Derivatives:' - Write(6,*) 'Wall/CPU',Twoel3_Wall, Twoel3_CPU - Write(6,*) '-------------------------' - Write(6,*) 'Total Time for Derivatives:' - Write(6,*) 'Wall/CPU',Total_Der_Wall2, Total_Der_CPU2 - Write(6,*) '-------------------------' - Write(6,*) 'Derivative check:' - Write(6,*) 'Wall/CPU',Total_Der_Wall, Total_Der_CPU - Write(6,*) '-------------------------' -#endif - - Return - End diff -Nru openmolcas-22.02/src/ri_util/drvg1_ri.F90 openmolcas-22.10/src/ri_util/drvg1_ri.F90 --- openmolcas-22.02/src/ri_util/drvg1_ri.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/drvg1_ri.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,502 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 2007, Roland Lindh * +!*********************************************************************** + +subroutine Drvg1_RI(Grad,Temp,nGrad) +!*********************************************************************** +! * +! Object: superdriver for gradients for the RI/DF approximation * +! * +! * +! Author: Roland Lindh, Dep. Chem. Phys., Lund University, Sweden * +! January '07 * +! * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem +use RI_procedures, only: Effective_CD_Pairs +use Basis_Info, only: nBas, nBas_Aux +use pso_stuff, only: AOrb, Case_2C, Case_3C, DMdiag, G1, ij2K, iOff_ij2K, lPSO, lSA, m_Txy, n_ij2K, n_Txy, nG1, nnP, nV_k, nZ_p_k, & + Txy, U_k, V_k, Z_p_k +use RICD_Info, only: Cholesky, Do_RI +use Symmetry_Info, only: Mul, nIrrep +use Para_Info, only: myRank, nProcs +use Data_Structures, only: Deallocate_DT +use RI_glob, only: DoCholExch, iMP2prpt, LuAVector, LuBVector, LuCVector, nAdens, nAvec, nJdens, nKdens, nKvec, tavec, tbvec +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, Two +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nGrad +real(kind=wp), intent(inout) :: Grad(nGrad) +real(kind=wp), intent(out) :: Temp(nGrad) +#include "Molcas.fh" +#include "disp.fh" +#include "print.fh" +#include "cholesky.fh" +!#define _CD_TIMING_ +#ifdef _CD_TIMING_ +#include "temptime.fh" +#endif +integer(kind=iwp) :: i, iIrrep, ijsym, iOff, iPrint, irc, iRout, iSeed, iStart, isym, itmp, iUHF, j, jStart, jSym, jtmp, kStart, & + kTmp, m_ij2K, mAO, nAct(0:7), nAux_Tot, nij_Eff, ntmp, nV_k_New, nVec, nZ_p_k_New, nZ_p_l +real(kind=wp) :: BufFrac, TCpu1, TCpu2, TWall1, TWall2 +#ifdef _CD_TIMING_ +real(kind=wp) :: Total_Dens_CPU, Total_Dens_Wall, Total_Der_CPU, Total_Der_CPU2, Total_Der_Wall, Total_Der_Wall2 +#endif +logical(kind=iwp) :: Found +character(len=8) :: Method +character(len=7) :: Fname2 +character(len=6) :: Fname +integer(kind=iwp), allocatable :: ij2(:,:), iVk(:,:), iZk(:), SO_ab(:) +real(kind=wp), allocatable :: DMTmp(:), Tmp(:), U_k_new(:), V_k_new(:,:) +integer(kind=iwp), external :: IsFreeUnit + +! * +!*********************************************************************** +! * +DoCholExch = .false. +! * +!*********************************************************************** +! * +call CWTime(TCpu1,TWall1) +! * +!*********************************************************************** +! * +iRout = 33 +iPrint = nPrint(iRout) +! * +!*********************************************************************** +! * +Temp(:) = Zero +call mma_allocate(Tmp,nGrad,Label='Tmp') +! * +!*********************************************************************** +! * +BufFrac = 0.1_wp +call Cho_X_Init(irc,BufFrac) +if (irc /= 0) then + call WarningMessage(2,' Drvg1_RI: Cho_X_Init failed') + call Abend() +end if +! +!******************************************* +! +! Decide if it's MP2 + +iMp2Prpt = 0 +call Get_cArray('Relax Method',Method,8) +if (Method == 'MBPT2 ') then + call Get_iScalar('mp2prpt',iMp2Prpt) +end if +! * +!*********************************************************************** +! * +! In case of the Cholesky approach compute the A and Q matrices. + +if (Cholesky .and. (.not. Do_RI)) then + + if (nIrrep /= 1) then + call WarningMessage(2,'Error in Drvg1_RI') + write(u6,*) ' CD gradients with symmetry is not implemented yet!' + call Abend() + end if + + call Cho_X_CalculateGMat(irc) + if (iRC /= 0) then + call WarningMessage(2,'Error in Drvg1_RI') + write(u6,*) 'Failure during G matrix construction' + call Abend() + end if + + ! Now compute the Q matrix. + ! + ! Note that, as the A matrix is + ! computed in the full-pivoted (rows and columns) storage, + ! also the resulting Q matrix is full-pivoted. + ! This is necessary for the ReMap_V_k to work (see below). + ! In the RI case, only the column pivoting of Q is + ! preserved. One day we may want to unify the two cases. + ! + ! (In Cholesky the Q matrix is stored as squared. In RI, + ! it is, in general, rectangular as lin. dep. may occur + ! among its columns). + + nBas_Aux(0:nIrrep-1) = NumCho(1:nIrrep) + call GAIGOP(nBas_Aux,nIrrep,'+') + call Gen_QVec(nIrrep,nBas_Aux) + +end if +! * +!*********************************************************************** +! * +! Prepare handling of two-particle density. + +call PrepP() +! * +!*********************************************************************** +! * +! Initialize the number of sets of densities and auxiliary vectors +nAdens = 1 +nAVec = 1 +nKdens = 1 +nJdens = 1 + +call Qpg_iScalar('SCF mode',Found) +if (Found) then + call Get_iScalar('SCF mode',iUHF) ! either 0 or 1 +else + iUHF = 0 +end if +nKdens = nKdens+iUHF +nKvec = nKdens + +if (lPSO .and. lSA) then + nJdens = 5 + nKdens = 4 + nKVec = 2 + nAdens = 2 + nAvec = 4 +end if + +!MGD Could be more efficient memory-wise when symmetry +! Decompose the 2-particle active density matrix +mAO = 0 +if (lPSO) then + call Get_iArray('nAsh',nAct,nIrrep) + n_Txy = 0 + do ijsym=0,nIrrep-1 + ntmp = 0 + do jSym=0,nIrrep-1 + isym = Mul(jSym+1,ijsym+1)-1 + if (iSym > jSym) then + ntmp = ntmp+nAct(iSym)*nAct(jSym) + else if (iSym == jSym) then + ntmp = ntmp+nTri_Elem(nAct(iSym)) + end if + end do + n_Txy = n_Txy+ntmp**2 + mAO = mAO+nAct(ijsym)*nBas(ijsym) + end do + m_Txy = nAdens + call mma_allocate(Txy,n_Txy,nAdens,Label='Txy') + call mma_allocate(DMdiag,nG1,nAdens,Label='DMdiag') + call mma_allocate(DMtmp,nTri_Elem(nG1),Label='DMtmp') + nnP(0:nIrrep-1) = 0 + call Compute_txy(G1(1,1),nG1,Txy,n_Txy,nAdens,nIrrep,DMdiag,DMtmp,nAct) + call mma_deallocate(DMtmp) +else + call mma_allocate(Txy,1,1,Label='Txy') + call mma_allocate(DMdiag,1,1,Label='DMdiag') +end if +n_ij2K = 0 +nZ_p_k = 0 +nZ_p_l = 0 +nZ_p_k_New = 0 +do i=0,nIrrep-1 + iOff_ij2K(i+1) = n_ij2K + n_ij2K = n_ij2K+nTri_Elem(nBas(i)) + nZ_p_k = nZ_p_k+nnP(i)*nBas_Aux(i) ! Global size + nZ_p_l = nZ_p_l+nnP(i)*NumCho(i+1) ! Local size + nZ_p_k_New = nZ_p_k_New+nnP(i)*nTri_Elem(nBas(i)) +end do +if (Do_RI) nZ_p_k = nZ_p_k-nnP(0) + +! Allocate the "global" Z_p_k array + +if (lPSO) then + call mma_allocate(Z_p_k,nZ_p_k,nAVec,Label='Z_p_k') +else + nZ_p_k = 1 + call mma_allocate(Z_p_k,1,nAVec,Label='Z_p_k') +end if +Z_p_k(:,:) = Zero + +! Preprocess the RI and Q vectors as follows + +! Allocate memory for V_k + +nV_k = nBas_Aux(0) +if (Do_RI) nV_k = nV_k-1 + +nAux_Tot = 0 +do iIrrep=0,nIrrep-1 + nAux_Tot = nAux_Tot+nBas_Aux(iIrrep) +end do + +call mma_allocate(V_K,nV_k,nJdens,Label='V_k') +V_k(:,:) = Zero +if (iMp2prpt == 2) then + nVec = 2 + call mma_allocate(U_K,nV_k,Label='U_k') + U_k(:) = Zero +else + nVec = 1 + call mma_allocate(U_K,1,Label='U_k') +end if +! ~ +! 1) Compute the V_k vector +! ~ +! 2) Contract V_k and Q (transpose) vectors producing the V_k + +! Note: the above two points apply to Z_p_k as well (active space) + +call mma_allocate(iVk,[0,nProcs-1],[1,nVec],Label='iVk') +call mma_allocate(iZk,[0,nProcs-1],Label='iZk') +iVk(:,:) = 0 +iZk(:) = 0 +!iVk(myRank,1) = NumCho(1)*nJdens +iVk(myRank,1) = NumCho(1) +!iZk(myRank) = nZ_p_l*nAvec ! store the local size of Zk +iZk(myRank) = nZ_p_l ! store the local size of Zk +call GAIGOP(iVk(:,1),nProcs,'+') +call GAIGOP(iZk,nProcs,'+') ! distribute to all nodes + +! Compute the starting position in the global sense for each node. + +iStart = 1 +jStart = 1 +do j=0,nProcs-1 ! Loop over all nodes + itmp = iVk(j,1) + iVk(j,1) = iStart + iStart = iStart+itmp + + jtmp = iZk(j) + iZk(j) = jStart + jStart = jStart+jtmp +end do + +if (iMp2prpt == 2) then + iVk(myRank,2) = NumCho(1) + call GAIGOP(iVk(:,2),nProcs,'+') + kStart = 1 + do j=0,nProcs-1 + kTmp = iVk(j,2) + iVk(j,2) = kStart + kStart = kStart+kTmp + end do +end if + +call Compute_AuxVec(iVk,iZk,myRank+1,nProcs,nVec) +call mma_deallocate(iVk) +call mma_deallocate(iZk) +! * +!*********************************************************************** +! * + +if (Cholesky .and. (.not. Do_RI)) then + + ! Map from Cholesky auxiliary basis to the full + ! 1-center valence product basis. + + call mma_allocate(ij2K,n_ij2K,Label='ij2K') + ij2K(:) = 0 + nV_k_New = nTri_Elem(nBas(0)) + call mma_allocate(V_k_new,nV_k_New,nJdens,Label='V_k_new') + V_k_new(:,:) = Zero + + if (iMp2prpt == 2) then + call mma_allocate(U_k_new,nV_k_New,Label='U_k_new') + U_k_new(:) = Zero + end if + + call mma_allocate(SO_ab,2*nAux_Tot,Label='SO_ab') + SO_ab(:) = 0 + iOff = 1 + do iSym=1,nSym + call CHO_X_GET_PARDIAG(iSym,SO_ab(iOff)) + + if ((iSym == 1) .and. (iMp2prpt == 2)) then + call ReMap_U_k(U_k,nV_k,U_k_New,nV_k_New,SO_ab) + end if + m_ij2K = nTri_Elem(nBas(iSym-1)) + do i=0,nJDens-1 + call ReMap_V_k(iSym,V_k(1,1+i),nV_k,V_k_new(1,1+i),nV_k_New,SO_ab(iOff),ij2K(iOff_ij2K(iSym)+1),m_ij2K) + end do + iOff = iOff+2*nBas_Aux(iSym-1) + end do + + nV_k = nV_k_new + + call mma_deallocate(SO_ab) + call mma_deallocate(V_k) + call mma_allocate(V_k,nV_k,nJdens,Label='V_k') + V_k(:,:) = V_k_new(:,:) + call mma_deallocate(V_k_new) + + if (iMp2prpt == 2) then + call mma_deallocate(U_k) + call mma_allocate(U_k,nV_k,Label='U_k') + U_k(:) = U_k_new(:) + call mma_deallocate(U_k_new) + end if + + ! * + !********************************************************************* + ! * + ! Get the effective list of shell-pairs in case of CD + + call Effective_CD_Pairs(ij2,nij_Eff) +else + nij_Eff = 0 + call mma_allocate(ij2,2,0,Label='ij2') +end if +! * +!*********************************************************************** +! * +! Open C-vector-files if nSym is equal to 1 + +if (DoCholExch) then + do i=1,nKvec + do jSym=1,nSym + iSeed = 7+jSym+(i-1)*nSym + LuCVector(jSym,i) = IsFreeUnit(iSeed) + if (i == 1) then + write(Fname,'(A4,I1,I1)') 'CVEA',jSym + else if (i == 2) then + write(Fname,'(A4,I1,I1)') 'CVEB',jSym + end if + call DANAME_MF_WA(LuCVector(jSym,i),Fname) + end do + end do +end if +!Initialize timings +tavec(:) = Zero +tbvec(:) = Zero +if (imp2prpt == 2) then + do i=1,2 + iSeed = 8+nSym + LuAVector(i) = IsFreeUnit(iSeed) + write(Fname2,'(A5,I1)') 'AMP2V',i + call DaName_MF_WA(LuAVector(i),Fname2) + iSeed = 9+nSym + LuBVector(i) = IsFreeUnit(iSeed) + write(Fname,'(A5,I1)') 'BMP2V',i+2 + call DaName_MF_WA(LuBVector(i),Fname) + end do +end if +! * +!*********************************************************************** +! * +! Compute contributions due to the "2-center" two-electron integrals + +Case_2C = .true. +call Drvg1_2center_RI(Temp,Tmp,nGrad,ij2,nij_Eff) +call GADGOP(Tmp,nGrad,'+') +if (iPrint >= 15) call PrGrad(' RI-Two-electron contribution - 2-center term',Tmp,nGrad,ChDisp) +Grad(:) = Grad+Temp ! Move any 1-el contr. +Temp(:) = -Tmp +Case_2C = .false. +! * +!*********************************************************************** +! * +! Compute contributions due to the "3-center" two-electron integrals + +Case_3C = .true. +call Drvg1_3center_RI(Tmp,nGrad,ij2,nij_Eff) +call GADGOP(Tmp,nGrad,'+') +if (iPrint >= 15) call PrGrad(' RI-Two-electron contribution - 3-center term',Tmp,nGrad,ChDisp) +Temp(:) = Temp+Two*Tmp +Case_3C = .false. +if (allocated(Txy)) call mma_deallocate(Txy) +if (allocated(DMdiag)) call mma_deallocate(DMdiag) +if (allocated(AOrb)) call Deallocate_DT(AOrb) +! * +!*********************************************************************** +! * +if (DoCholExch) then + do i=1,nKvec + do jSym=1,nSym + call DaClos(luCVector(jSym,i)) + end do + end do +end if +if (iMp2prpt == 2) then + do i=1,2 + call DaClos(LuAVector(i)) + call DaClos(LuBVector(i)) + end do +end if + +call mma_deallocate(ij2) +if (Cholesky .and. (.not. Do_RI)) then + call mma_deallocate(ij2K) +end if +call CloseP() + +if (allocated(Z_p_k)) call mma_deallocate(Z_p_k) +if (allocated(V_k)) call mma_deallocate(V_k) +if (allocated(U_k)) call mma_deallocate(U_k) + +call Cho_X_Final(irc) +if (irc /= 0) then + call WarningMessage(2,' Drvg1_RI: Cho_X_Final failed') + call Abend() +end if +call mma_deallocate(Tmp) +if (iPrint >= 15) call PrGrad(' RI-Two-electron contribution - Temp',Temp,nGrad,ChDisp) +! * +!*********************************************************************** +! * +call CWTime(TCpu2,TWall2) +call SavTim(6,TCpu2-TCpu1,TWall2-TWall1) + +#ifdef _CD_TIMING_ +Drvg1_CPU = TCpu2-TCpu1 +Drvg1_Wall = TWall2-TWall1 +write(u6,*) '-------------------------' +write(u6,*) 'Time spent in Cho_get_grad:' +write(u6,*) 'Wall/CPU',ChoGet_Wall,ChoGet_CPU +write(u6,*) '-------------------------' +write(u6,*) 'Time spent in Mult_Rijk_Qkl:' +write(u6,*) 'Wall/CPU',rMult_Wall,rMult_CPU +write(u6,*) '-------------------------' +write(u6,*) 'Time spent in Prepp:' +write(u6,*) 'Wall/CPU',Prepp_Wall,Prepp_CPU +write(u6,*) '-------------------------' +write(u6,*) 'Time spent in Pget_ri2:' +write(u6,*) 'Wall/CPU',Pget2_Wall,Pget2_CPU +write(u6,*) '-------------------------' +write(u6,*) 'Time spent in Pget_ri3:' +write(u6,*) 'Wall/CPU',Pget3_Wall,Pget3_CPU +write(u6,*) '-------------------------' +write(u6,*) 'Time spent in Drvg1_ri:' +write(u6,*) 'Wall/CPU',Drvg1_Wall,Drvg1_CPU +write(u6,*) '-------------------------' +Total_Dens_Wall = ChoGet_Wall+rMult_Wall+Prepp_Wall+Pget2_Wall+Pget3_Wall +Total_Dens_CPU = ChoGet_CPU+rMult_CPU+Prepp_CPU+Pget2_CPU+Pget3_CPU +Total_Der_Wall = Drvg1_Wall-Total_Dens_Wall +Total_Der_CPU = Drvg1_CPU-Total_Dens_CPU +Total_Der_Wall2 = TwoEl2_Wall+TwoEl3_Wall +Total_Der_CPU2 = TwoEl2_CPU+TwoEl3_CPU + +write(u6,*) 'Total Time for Density:' +write(u6,*) 'Wall/CPU',Total_Dens_Wall,Total_Dens_CPU +write(u6,*) '-------------------------' +write(u6,*) 'Total TIme for 2-center Derivatives:' +write(u6,*) 'Wall/CPU',Twoel2_Wall,Twoel2_CPU +write(u6,*) '-------------------------' +write(u6,*) 'Total TIme for 3-center Derivatives:' +write(u6,*) 'Wall/CPU',Twoel3_Wall,Twoel3_CPU +write(u6,*) '-------------------------' +write(u6,*) 'Total Time for Derivatives:' +write(u6,*) 'Wall/CPU',Total_Der_Wall2,Total_Der_CPU2 +write(u6,*) '-------------------------' +write(u6,*) 'Derivative check:' +write(u6,*) 'Wall/CPU',Total_Der_Wall,Total_Der_CPU +write(u6,*) '-------------------------' +#endif + +return + +end subroutine Drvg1_RI diff -Nru openmolcas-22.02/src/ri_util/effective_CD_pairs.f openmolcas-22.10/src/ri_util/effective_CD_pairs.f --- openmolcas-22.02/src/ri_util/effective_CD_pairs.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/effective_CD_pairs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,144 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Effective_CD_Pairs(ij2,nij_Eff) - use Basis_Info - use Symmetry_Info, only: nIrrep - use ChoArr, only: iSOShl - Implicit Real*8 (a-h,o-z) - Integer, Allocatable:: ij2(:,:) -#include "cholesky.fh" -#include "stdalloc.fh" - - Integer, Allocatable :: SO_ab(:), ij3(:) -* * -************************************************************************ -* * -* Compute the max number of auxiliary shells in case of CD. Hence -* we do not have any explicit auxiliary basis set! -* - nSkal_Valence=0 - Do iCnttp = 1, nCnttp - If (.Not.dbsc(iCnttp)%Aux) Then - Do iAng = 0, dbsc(iCnttp)%nVal-1 - iShll = dbsc(iCnttp)%iVal + iAng - If (.Not.Shells(iShll)%Aux) Then - nSkal_Valence = nSkal_Valence + dbsc(iCnttp)%nCntr - End If - End Do - End If - End Do -* -* Max number of pairs -* - nij=nSkal_Valence*(nSkal_Valence+1)/2 - Call mma_allocate(ij3,nij,Label='ij3') - ij3(:)=0 -C Write (*,*) 'nij3=',nij -* * -************************************************************************ -* * - nAux_Tot=0 - nVal_Tot=0 - Do iIrrep = 0, nIrrep-1 - nAux_Tot=nAux_Tot+nBas_Aux(iIrrep) - nVal_Tot=nVal_Tot+nBas(iIrrep) - End Do - - Call mma_allocate(SO_ab,2*nAux_Tot,Label='SO_ab') - SO_ab(:)=0 -* - iOff = 1 - jOff = 0 - nSym=nIrrep - Do iSym = 1, nSym - iIrrep=iSym-1 - Call CHO_X_GET_PARDIAG(iSym,SO_ab(iOff)) -* - Call Get_Auxiliary_Shells(SO_ab(iOff),nBas_Aux(iIrrep), - & jOff,iSOShl,nVal_Tot,ij3,nij) -* - jOff = jOff + nBas_Aux(iIrrep) - iOff = iOff + 2*nBas_Aux(iIrrep) - End Do - Call mma_deallocate(SO_ab) -* * -************************************************************************ -* * - nij_Eff=0 - Do i = 1, nij - nij_Eff = nij_Eff + ij3(i) - End Do -C Write (6,*) 'nij_Eff=',nij_Eff - If (nij_Eff.gt.nij) Then - Call WarningMessage(2, - & 'Effective_CD_Pairs: nij_Eff.gt.nij') - Call Abend() - End If -* - Call mma_allocate(ij2,2,nij_Eff,Label='ij2') - ij = 0 - ij_Eff = 0 - Do i = 1, nSkal_Valence - Do j = 1, i - ij = ij + 1 -C Write (6,*) 'i,j,ij=',i,j,ij - If (ij3(ij).eq.1) Then - ij_Eff = ij_Eff + 1 -C Write (*,*) 'ij_Eff=',ij_Eff - ij2(1,ij_Eff) = i - ij2(2,ij_Eff) = j - End If - End Do - End Do - If (ij_Eff.ne.nij_Eff) Then - Call WarningMessage(2, - & 'Effective_CD_Pairs: ij_Eff.ne.nij_Eff') - Call Abend() - End If - Call mma_deallocate(ij3) -* * -************************************************************************ -* * - Return - End - Subroutine Get_Auxiliary_Shells(iSO,nSO,jOff,iSO2Shl,nSO2Shl, - & iPair,nPair) - Integer iSO(2,nSO), iSO2Shl(nSO2Shl), iPair(nPair) -* -C Write (6,*) 'iSO' -C Write (6,*) '===' -C Do i = 1, nSO -C Write (6,*) iSO(1,i), iSO(2,i) -C End Do -* -C Write (6,*) 'iSO2Shl' -C Write (6,*) '=======' -C Do i = 1, nSO2Shl -C Write (6,*) i, iSO2Shl(i) -C End Do - Do i = 1, nSO - k=iSO(1,i) + jOff - l=iSO(2,i) + jOff - kSh=iSO2Shl(k) - lSh=iSO2Shl(l) -C Write (6,*) 'k,kSh=',k,kSh -C Write (6,*) 'l,lSh=',k,lSh - kl = Max(kSh,lSh)*(Max(kSh,lSh)-1)/2 + Min(kSh,lSh) - iPair(kl)=1 - End Do -C Write (6,*) 'iPairs' -C Write (6,*) '======' -C Do i = 1, nPair -C Write (6,*) iPair(i) -C End Do -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/effective_cd_pairs.F90 openmolcas-22.10/src/ri_util/effective_cd_pairs.F90 --- openmolcas-22.02/src/ri_util/effective_cd_pairs.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/effective_cd_pairs.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,119 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! This subroutine should be in a module, to avoid explicit interfaces +#ifdef _IN_MODULE_ + +subroutine Effective_CD_Pairs(ij2,nij_Eff) + +use Index_Functions, only: nTri_Elem +use Basis_Info, only: dbsc, nBas, nBas_Aux, nCnttp, Shells +use Symmetry_Info, only: nIrrep +use ChoArr, only: iSOShl +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(out) :: nij_Eff +integer(kind=iwp), allocatable, intent(out) :: ij2(:,:) +#include "cholesky.fh" +integer(kind=iwp) :: i, iAng, iCnttp, iIrrep, ij, ij_Eff, iOff, iShll, iSym, j, jOff, nAux_Tot, nij, nSkal_Valence, nVal_Tot +integer(kind=iwp), allocatable :: ij3(:), SO_ab(:) + +! * +!*********************************************************************** +! * +! Compute the max number of auxiliary shells in case of CD. +! Hence we do not have any explicit auxiliary basis set! + +nSkal_Valence = 0 +do iCnttp=1,nCnttp + if (.not. dbsc(iCnttp)%Aux) then + do iAng=0,dbsc(iCnttp)%nVal-1 + iShll = dbsc(iCnttp)%iVal+iAng + if (.not. Shells(iShll)%Aux) nSkal_Valence = nSkal_Valence+dbsc(iCnttp)%nCntr + end do + end if +end do + +! Max number of pairs + +nij = nTri_Elem(nSkal_Valence) +call mma_allocate(ij3,nij,Label='ij3') +ij3(:) = 0 +!write(u6,*) 'nij3=',nij +! * +!*********************************************************************** +! * +nAux_Tot = 0 +nVal_Tot = 0 +do iIrrep=0,nIrrep-1 + nAux_Tot = nAux_Tot+nBas_Aux(iIrrep) + nVal_Tot = nVal_Tot+nBas(iIrrep) +end do + +call mma_allocate(SO_ab,2*nAux_Tot,Label='SO_ab') +SO_ab(:) = 0 + +iOff = 1 +jOff = 0 +nSym = nIrrep +do iSym=1,nSym + iIrrep = iSym-1 + call CHO_X_GET_PARDIAG(iSym,SO_ab(iOff)) + + call Get_Auxiliary_Shells(SO_ab(iOff),nBas_Aux(iIrrep),jOff,iSOShl,nVal_Tot,ij3,nij) + + jOff = jOff+nBas_Aux(iIrrep) + iOff = iOff+2*nBas_Aux(iIrrep) +end do +call mma_deallocate(SO_ab) +! * +!*********************************************************************** +! * +nij_Eff = 0 +do i=1,nij + nij_Eff = nij_Eff+ij3(i) +end do +!write(u6,*) 'nij_Eff=',nij_Eff +if (nij_Eff > nij) then + call WarningMessage(2,'Effective_CD_Pairs: nij_Eff > nij') + call Abend() +end if + +call mma_allocate(ij2,2,nij_Eff,Label='ij2') +ij = 0 +ij_Eff = 0 +do i=1,nSkal_Valence + do j=1,i + ij = ij+1 + !write (u6,*) 'i,j,ij=',i,j,ij + if (ij3(ij) == 1) then + ij_Eff = ij_Eff+1 + !write(u6,*) 'ij_Eff=',ij_Eff + ij2(1,ij_Eff) = i + ij2(2,ij_Eff) = j + end if + end do +end do +if (ij_Eff /= nij_Eff) then + call WarningMessage(2,'Effective_CD_Pairs: ij_Eff /= nij_Eff') + call Abend() +end if +call mma_deallocate(ij3) +! * +!*********************************************************************** +! * +return + +end subroutine Effective_CD_Pairs + +#endif diff -Nru openmolcas-22.02/src/ri_util/exterm.F90 openmolcas-22.10/src/ri_util/exterm.F90 --- openmolcas-22.02/src/ri_util/exterm.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/exterm.F90 1970-01-01 00:00:00.000000000 +0000 @@ -1,37 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in <http://www.gnu.org/licenses/>. * -!*********************************************************************** -Module exterm -use Data_Structures, only: DSBA_type -Private -Public :: CijK, VJ, CilK, BklK -Public :: Ymnij, ipYmnij, nYmnij, iOff_Ymnij -Public :: Yij - -Public :: A, AMP2, BMP2 -Public :: iMP2prpt, nAuxVe -Public :: LuAVector, LuBVector - -Public :: CMOi, DMLT - -Real*8, Allocatable, Target:: CijK(:), VJ(:), CilK(:), BklK(:) -Integer, Allocatable:: Ymnij(:) -Integer ipYmnij(5), nYmnij(8,5), iOff_Ymnij(8,5) -Real*8, Allocatable, Target:: Yij(:,:,:) -Real*8, Allocatable:: A(:) - -! Cholesky Mp2-gradients -Real*8, Allocatable:: AMP2(:,:) -Real*8, Allocatable:: BMP2(:,:) -Integer :: iMP2prpt, nAuxVe -Integer :: LuAVector(2), LuBVector(2) - -Type (DSBA_Type), Target :: CMOi(5), DMLT(5) -End Module exterm diff -Nru openmolcas-22.02/src/ri_util/fix_coeff.f openmolcas-22.10/src/ri_util/fix_coeff.f --- openmolcas-22.02/src/ri_util/fix_coeff.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/fix_coeff.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Fix_Coeff(nPrim,nCntrc,Coeff_c,Coeff_p, - & Mode) - Implicit Real*8 (a-h,o-z) - Real*8 Coeff_c(nPrim,nCntrc), Coeff_p(nPrim,nPrim) - Character Mode*1 -* -* Put in the normalization constant for the product -* basis function. -* - If (Mode.eq.'F') Then - Do iC = 1, nCntrc - Do iP = 1, nPrim - Coeff_c(iP,iC) = Coeff_c(iP,iC)/Coeff_p(iP,iP) - End Do - End Do - Else - Do iC = 1, nCntrc - Do iP = 1, nPrim - Coeff_c(iP,iC) = Coeff_c(iP,iC)*Coeff_p(iP,iP) - End Do - End Do - End If -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/fix_coeff.F90 openmolcas-22.10/src/ri_util/fix_coeff.F90 --- openmolcas-22.02/src/ri_util/fix_coeff.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/fix_coeff.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,37 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Fix_Coeff(nPrim,nCntrc,Coeff_c,Coeff_p,Mode) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nPrim, nCntrc +real(kind=wp), intent(inout) :: Coeff_c(nPrim,nCntrc) +real(kind=wp), intent(in) :: Coeff_p(nPrim,nPrim) +character, intent(in) :: Mode +integer(kind=iwp) :: iP + +! Put in the normalization constant for the product basis function. + +if (Mode == 'F') then + do iP=1,nPrim + Coeff_c(iP,:) = Coeff_c(iP,:)/Coeff_p(iP,iP) + end do +else + do iP=1,nPrim + Coeff_c(iP,:) = Coeff_c(iP,:)*Coeff_p(iP,iP) + end do +end if + +return + +end subroutine Fix_Coeff diff -Nru openmolcas-22.02/src/ri_util/fix_exponents.f openmolcas-22.10/src/ri_util/fix_exponents.f --- openmolcas-22.02/src/ri_util/fix_exponents.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/fix_exponents.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,140 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Fix_Exponents(nP,mP,nC,Exp,CoeffC,CoeffP) - Implicit Real*8 (a-h,o-z) -#include "stdalloc.fh" - Real*8, Allocatable:: Exp(:), CoeffC(:,:,:), CoeffP(:,:,:) - Real*8, Allocatable:: Scr(:,:,:) -* -*#define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Call RecPrt('Fix_Exponents: Exp',' ',Exp,1,nP) - Call RecPrt('Fix_Exponents: CoeffC(1)',' ',CoeffC(1,1,1),nP,nC) - Call RecPrt('Fix_Exponents: CoeffC(2)',' ',CoeffC(1,1,2),nP,nC) - Call RecPrt('Fix_Exponents: CoeffP(1)',' ',CoeffP(1,1,1),nP,nP) - Call RecPrt('Fix_Exponents: CoeffP(2)',' ',CoeffP(1,1,2),nP,nP) -#endif -* - mP = nP - Call Fix_Exp() -* -#ifdef _DEBUGPRINT_ - Write (6,*) 'After Fix_Exp' - Call RecPrt('Fix_Exponents: Exp',' ',Exp,1,nP) - Call RecPrt('Fix_Exponents: CoeffC(1)',' ',CoeffC(1,1,1),nP,nC) - Call RecPrt('Fix_Exponents: CoeffC(2)',' ',CoeffC(1,1,2),nP,nC) - Call RecPrt('Fix_Exponents: CoeffP(1)',' ',CoeffP(1,1,1),nP,nP) - Call RecPrt('Fix_Exponents: CoeffP(2)',' ',CoeffP(1,1,2),nP,nP) -#endif -* -* Reallocate arrays if the number of primitives is reduced. -* - If (mP.ne.nP) Then - Call mma_allocate(Scr,mP,1,1,Label='Scr') - Scr(1:mP,1,1)=Exp(1:mP) - Call mma_deallocate(Exp) - Call mma_allocate(Exp,mP,Label='Exp') - Exp(:)=Scr(:,1,1) - Call mma_deallocate(Scr) -* - Call mma_allocate(Scr,mP,nC,2,Label='Scr') - Scr(1:mP,1:nC,:) = CoeffC(1:mP,1:nC,:) - Call mma_deallocate(CoeffC) - Call mma_allocate(CoeffC,mP,nC,2,Label='CoeffC') - CoeffC(:,:,:)=Scr(:,:,:) - Call mma_deallocate(Scr) -* - Call mma_allocate(Scr,mP,mP,2,Label='Scr') - Scr(1:mP,1:mP,:) = CoeffP(1:mP,1:mP,:) - Call mma_deallocate(CoeffP) - Call mma_allocate(CoeffP,mP,mP,2,Label='CoeffP') - CoeffP(:,:,:)=Scr(:,:,:) - Call mma_deallocate(Scr) - End If -* -#ifdef _DEBUGPRINT_ - Write (6,*) 'After Reallocation' - Call RecPrt('Fix_Exponents: Exp',' ',Exp,1,mP) - Call RecPrt('Fix_Exponents: CoeffC(1)',' ',CoeffC(1,1,1),mP,nC) - Call RecPrt('Fix_Exponents: CoeffC(2)',' ',CoeffC(1,1,2),mP,nC) - Call RecPrt('Fix_Exponents: CoeffP(1)',' ',CoeffP(1,1,1),mP,mP) - Call RecPrt('Fix_Exponents: CoeffP(2)',' ',CoeffP(1,1,2),mP,mP) -#endif - Return -* * -************************************************************************ -* * - Contains -* * -************************************************************************ -* * - Subroutine Fix_Exp -* -* First, put the exponents with all coefficients less than the -* threshold, Thr_Skip, at the end. -* - Thr_Skip = 1.0D-13 - Do iP = nP, 1, -1 -* - iSkip=1 - Do iC = 1, nC - If (Abs(CoeffC(iP,iC,1)).ge.Thr_Skip) iSkip=0 - End Do -* - If (iSkip.eq.1) Then - If (iP.lt.mP) Then - Temp =Exp(iP) - Exp(iP)=Exp(mP) - Exp(mP)=Temp - Do i = 1, 2 - Temp =CoeffP(iP,iP,i) - CoeffP(iP,iP,i)=CoeffP(mP,mP,i) - CoeffP(mP,mP,i)=Temp - Do iC = 1, nC - Temp = CoeffC(iP,iC,i) - CoeffC(iP,iC,i) = CoeffC(mP,iC,i) - CoeffC(mP,iC,i) = Temp - End Do - End Do - End If - mP = mP -1 - End If -* - End Do -* -* Second, order from largest to smallest exponent -* - Do iP = 1, mP-1 - Do jP = iP+1, mP - If (Exp(jP).gt.Exp(ip)) Then - Temp =Exp(iP) - Exp(iP)=Exp(jP) - Exp(jP)=Temp - Do i = 1, 2 - Temp =CoeffP(iP,iP,i) - CoeffP(iP,iP,i)=CoeffP(jP,jP,i) - CoeffP(jP,jP,i)=Temp - Do iC = 1, nC - Temp = CoeffC(iP,iC,i) - CoeffC(iP,iC,i) = CoeffC(jP,iC,i) - CoeffC(jP,iC,i) = Temp - End Do - End Do - End If - End Do - End Do -* - Return - End Subroutine Fix_Exp -* * -************************************************************************ -* * - End Subroutine Fix_Exponents diff -Nru openmolcas-22.02/src/ri_util/fix_exponents.F90 openmolcas-22.10/src/ri_util/fix_exponents.F90 --- openmolcas-22.02/src/ri_util/fix_exponents.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/fix_exponents.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,136 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! This subroutine should be in a module, to avoid explicit interfaces +#ifdef _IN_MODULE_ + +subroutine Fix_Exponents(nP,mP,nC,Expn,CoeffC,CoeffP) + +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nP, nC +integer(kind=iwp), intent(out) :: mP +real(kind=wp), allocatable, intent(inout) :: Expn(:), CoeffC(:,:,:), CoeffP(:,:,:) +integer(kind=iwp) :: i, iC, iP, jP, iSkip +real(kind=wp) :: Temp, Thr_Skip +real(kind=wp), allocatable :: Scr1(:), Scr2(:,:,:) + +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +call RecPrt('Fix_Exponents: Expn',' ',Expn,1,nP) +call RecPrt('Fix_Exponents: CoeffC(1)',' ',CoeffC(:,:,1),nP,nC) +call RecPrt('Fix_Exponents: CoeffC(2)',' ',CoeffC(:,:,2),nP,nC) +call RecPrt('Fix_Exponents: CoeffP(1)',' ',CoeffP(:,:,1),nP,nP) +call RecPrt('Fix_Exponents: CoeffP(2)',' ',CoeffP(:,:,2),nP,nP) +#endif + +mP = nP + +! First, put the exponents with all coefficients less than the +! threshold, Thr_Skip, at the end. + +Thr_Skip = 1.0e-13_wp +do iP=nP,1,-1 + + iSkip = 1 + do iC=1,nC + if (abs(CoeffC(iP,iC,1)) >= Thr_Skip) iSkip = 0 + end do + + if (iSkip == 1) then + if (iP < mP) then + Temp = Expn(iP) + Expn(iP) = Expn(mP) + Expn(mP) = Temp + do i=1,2 + Temp = CoeffP(iP,iP,i) + CoeffP(iP,iP,i) = CoeffP(mP,mP,i) + CoeffP(mP,mP,i) = Temp + do iC=1,nC + Temp = CoeffC(iP,iC,i) + CoeffC(iP,iC,i) = CoeffC(mP,iC,i) + CoeffC(mP,iC,i) = Temp + end do + end do + end if + mP = mP-1 + end if + +end do + +! Second, order from largest to smallest exponent + +do iP=1,mP-1 + do jP=iP+1,mP + if (Expn(jP) > Expn(ip)) then + Temp = Expn(iP) + Expn(iP) = Expn(jP) + Expn(jP) = Temp + do i=1,2 + Temp = CoeffP(iP,iP,i) + CoeffP(iP,iP,i) = CoeffP(jP,jP,i) + CoeffP(jP,jP,i) = Temp + do iC=1,nC + Temp = CoeffC(iP,iC,i) + CoeffC(iP,iC,i) = CoeffC(jP,iC,i) + CoeffC(jP,iC,i) = Temp + end do + end do + end if + end do +end do + +#ifdef _DEBUGPRINT_ +write(u6,*) 'After Fix_Exp' +call RecPrt('Fix_Exponents: Expn',' ',Expn,1,nP) +call RecPrt('Fix_Exponents: CoeffC(1)',' ',CoeffC(:,:,1),nP,nC) +call RecPrt('Fix_Exponents: CoeffC(2)',' ',CoeffC(:,:,2),nP,nC) +call RecPrt('Fix_Exponents: CoeffP(1)',' ',CoeffP(:,:,1),nP,nP) +call RecPrt('Fix_Exponents: CoeffP(2)',' ',CoeffP(:,:,2),nP,nP) +#endif + +! Reallocate arrays if the number of primitives is reduced. + +if (mP /= nP) then + call mma_allocate(Scr1,mP,Label='Expn') + Scr1(:) = Expn(1:mP) + call mma_deallocate(Expn) + call move_alloc(Scr1,Expn) + + call mma_allocate(Scr2,mP,nC,2,Label='CoeffC') + Scr2(:,:,:) = CoeffC(1:mP,1:nC,:) + call mma_deallocate(CoeffC) + call move_alloc(Scr2,CoeffC) + + call mma_allocate(Scr2,mP,mP,2,Label='CoeffP') + Scr2(:,:,:) = CoeffP(1:mP,1:mP,:) + call mma_deallocate(CoeffP) + call move_alloc(Scr2,CoeffP) + +# ifdef _DEBUGPRINT_ + write(u6,*) 'After Reallocation' + call RecPrt('Fix_Exponents: Expn',' ',Expn,1,mP) + call RecPrt('Fix_Exponents: CoeffC(1)',' ',CoeffC(:,:,1),mP,nC) + call RecPrt('Fix_Exponents: CoeffC(2)',' ',CoeffC(:,:,2),mP,nC) + call RecPrt('Fix_Exponents: CoeffP(1)',' ',CoeffP(:,:,1),mP,mP) + call RecPrt('Fix_Exponents: CoeffP(2)',' ',CoeffP(:,:,2),mP,mP) +else + write(u6,*) 'No Reallocation' +# endif +end if + +return + +end subroutine Fix_Exponents + +#endif diff -Nru openmolcas-22.02/src/ri_util/free_tsk2.F90 openmolcas-22.10/src/ri_util/free_tsk2.F90 --- openmolcas-22.02/src/ri_util/free_tsk2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/free_tsk2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,35 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Free_Tsk2(id) + +use RI_glob, only: iOpt, nTask, TskList +use stdalloc, only: mma_deallocate +use Definitions, only: iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: id + +if (iOpt == 0) then + call Free_Tsk(id) +else if (iOpt == 1) then + call mma_deallocate(TskList) + nTask = 0 +else + call WarningMessage(2,'Error in Free_Tsk2') + write(u6,*) 'Free_Tsk2: illegal iOpt value!' + call Abend() +end if +iOpt = -1 + +return + +end subroutine Free_Tsk2 diff -Nru openmolcas-22.02/src/ri_util/gen_qvec.f openmolcas-22.10/src/ri_util/gen_qvec.f --- openmolcas-22.02/src/ri_util/gen_qvec.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/gen_qvec.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,219 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Gen_QVec(nIrrep,nBas_Aux) - Implicit Real*8 (a-h,o-z) -#include "real.fh" -#include "stdalloc.fh" - Integer nBas_Aux(0:nIrrep-1), Lu_Q(0:7), Lu_A(0:7) - Logical Out_Of_Core - Character*6 Name_Q - - Real*8, Allocatable, Target :: Mem(:) - Real*8, Pointer:: A_l(:)=>Null(), Q_l(:)=>Null() - Real*8, Pointer:: A_k(:)=>Null(), Q_k(:)=>Null() - Real*8, Pointer:: Am(:)=>Null(), Qm(:)=>Null() - Integer, Allocatable:: iDiag(:) - Real*8, Allocatable:: Scr(:), X(:), Z(:) -* * -************************************************************************ -* * - INTERFACE - SUBROUTINE SORT_mat(irc,nDim,nVec,iD_A,nSym,lu_A0,mode,lScr,Scr, - & Diag) - Integer irc - Integer nSym - Integer nDim(nSym) - Integer nVec(nSym) - Integer iD_A(*) - Integer lu_A0(nSym) - Character(LEN=7) mode - Integer lScr - Real*8 Scr(lScr) - Real*8, Optional :: Diag(*) - END SUBROUTINE SORT_mat - END INTERFACE -* * -************************************************************************ -* * -* - ThrQ=1.0D-14 ! Threshold for Inv_Cho_Factor -* - mB=0 - nA_Diag=0 - Do iIrrep = 0, nIrrep-1 - nB = nBas_Aux(iIrrep) - nA_Diag = nA_Diag + nB - mB=Max(mB,nB) -* - iSeed=55+iIrrep - Lu_Q(iIrrep)=IsFreeUnit(iSeed) - Write(Name_Q,'(A4,I2.2)') 'QMAT',iIrrep - Call DaName_MF_WA(Lu_Q(iIrrep),Name_Q) -* - iSeed=63+iIrrep - Lu_A(iIrrep)=IsFreeUnit(iSeed) - Write(Name_Q,'(A4,I2.2)') 'AVEC',iIrrep - Call DaName_MF_WA(Lu_A(iIrrep),Name_Q) - End Do - nBfn2=mB**2 -* - Call mma_allocate(Z,mB,Label='Z') - Call mma_allocate(X,mB,Label='X') - lScr=3*mB - Call mma_allocate(Scr,lScr,Label='Scr') - Call mma_maxDBLE(Mem_Max) - Call mma_allocate(Mem,Mem_Max,Label='Mem') -* - Do iIrrep = 0, nIrrep-1 - nB = nBas_Aux(iIrrep) - nQm=nB*(nB+1)/2 -* - Out_Of_Core = 2*nQm .gt. Mem_Max - If (Out_Of_Core) Then - MaxMem = Mem_Max - 2*nB - mQm=MaxMem/2 - a=One - b=-Two*DBLE(mQm) - mB=INT(-a/Two + Sqrt( (a/Two)**2 - b )) - kQm=mB*(mB+1)/2 - If (kQm.gt.mQm) Then - Call WarningMessage(2,'Error in Gen_QVec') - Write (6,*) 'kQm.gt.mQm!' - Write (6,*) 'MaxMem=',MaxMem - Write (6,*) 'nQm,mQm,kQm=',nQm,mQm,kQm - Write (6,*) 'nB,mB=',nB,mB - Call Abend() - End If - iE = 2*kQm - iS = iE + 1 - iE = iE + mB - Q_k(1:mB) => Mem(iS:iE) - iS = iE + 1 - iE = iE + mB - A_k(1:mB) => Mem(iS:iE) - Else - mB = nB - kQm = nQm - End If -* - iS = 1 - iE = kQm - Qm(1:kQm) => Mem(iS:iE) - iS = iE + 1 - iE = iE + kQm - Am(1:kQm) => Mem(iS:iE) -* - iAddr=0 - Do kCol = 1, nB -* - If (kCol.le.mB) Then - iOff = (kCol-1)*kCol/2 - A_l(1:) => Am(1+iOff:) - Else - A_l(1:) => A_k(1:) - End If -* - iAddr_ = iAddr - If (kCol.le.mB.and.kCol.eq.1) Then - Call dDaFile(Lu_A(iIrrep),2,Am,kQm,iAddr_) - Else If (kCol.gt.mB) Then - Call dDaFile(Lu_A(iIrrep),2,A_l,kCol,iAddr_) - End If -#ifdef _DEBUGPRINT_ - Write (6,*) 'kCol=',kCol - Call TriPrt('Am',' ',Am,mB) - Call RecPrt('Al',' ',A_l,1,kCol) -#endif -* - If (kCol.le.mB) Then - iOff = (kCol-1)*kCol/2 - Q_l(1:) => Qm(1+iOff:) - Else - Q_l(1:) => Q_k(1:) - End If -* - LinDep=2 - Call Inv_Cho_Factor(A_l,kCol, - & Am,Qm,mB, - & Lu_A(iIrrep),Lu_Q(iIrrep), - & Scr,lScr, - & Z,X,ThrQ, - & Q_l,LinDep) - - If (LinDep.ne.0) Then - Call WarningMessage(2,'Error in Gen_QVec') - Write(6,*) 'Inv_Cho_Factor found linear dependence!' - Call Abend() - End If -#ifdef _DEBUGPRINT_ - Call TriPrt('Qm',' ',Qm,Min(mB,kCol)) - Call RecPrt('Ql',' ',Q_l,1,kCol) -#endif -* -* Write the new A/Q-vector to file -* - iAddr_=iAddr - If (kCol.eq.mB) Then - lQm=kCol*(kCol+1)/2 - Call dDaFile(Lu_Q(iIrrep),1,Qm,lQm,iAddr ) - Call dDaFile(Lu_A(iIrrep),1,Am,lQm,iAddr_) - Else If (kCol.gt.mB) Then - nQ_k=kCol - Call dDaFile(Lu_Q(iIrrep),1,Q_l,nQ_k,iAddr ) - Call dDaFile(Lu_A(iIrrep),1,A_l,nQ_k,iAddr_) - End If -* - End Do ! kCol - Call DaClos(Lu_A(iIrrep)) - End Do ! iIrrep -* - A_l=>Null() - Q_l=>Null() - A_k=>Null() - Q_k=>Null() - Am=>Null() - Qm=>Null() - Call mma_deallocate(Mem) - Call mma_deallocate(Scr) - Call mma_deallocate(X) - Call mma_deallocate(Z) -* -* Sort the Q-matrix to square storage. -* - Call mma_allocate(iDiag,nA_Diag,Label='iDiag') - ik = 0 - Do iIrrep=0,nIrrep-1 - Do k=1,nBas_Aux(iIrrep) - ik = ik + 1 - iDiag(ik) = k ! dummy assignement - End Do - End Do - Call mma_maxDBLE(MaxMem2) - lScr=Min(MaxMem2,nBfn2) - Call mma_allocate(Scr,lScr,Label='Scr') -* - Call SORT_Mat(irc,nBas_Aux,nBas_Aux, - & iDiag,nIrrep,Lu_Q,'Restore', - & lScr,Scr) -* -* Note: after the 'Restore' call to Sort_mat, the Q-matrix is -* no longer stored as upper-triangular but as squared -* (zeros have been added). -* - Call mma_deallocate(Scr) - Call mma_deallocate(iDiag) -* - Do iIrrep=0,nIrrep-1 - Call DaClos(Lu_Q(iIrrep)) - End Do -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/gen_qvec.F90 openmolcas-22.10/src/ri_util/gen_qvec.F90 --- openmolcas-22.02/src/ri_util/gen_qvec.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/gen_qvec.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,198 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Gen_QVec(nIrrep,nBas_Aux) + +use Index_Functions, only: nTri_Elem +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: One, Two, Half +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nIrrep, nBas_Aux(0:nIrrep-1) +integer(kind=iwp) :: iAddr, iAddr_, iE, iIrrep, ik, iOff, irc, iS, iSeed, k, kCol, kQm, LinDep, lQm, lScr, Lu_A(0:7), Lu_Q(0:7), & + MaxMem, MaxMem2, mB, Mem_Max, mQm, nA_Diag, nB, nBfn2, nQ_k, nQm, nBas_Copy(0:7) +real(kind=wp) :: a, b, dum(1), ThrQ +logical(kind=iwp) :: Out_Of_Core +character(len=6) :: Name_Q +integer(kind=iwp), allocatable :: iDiag(:) +real(kind=wp), allocatable :: Scr(:), X(:), Z(:) +real(kind=wp), allocatable, target :: Mem(:) +real(kind=wp), pointer :: A_k(:), A_l(:), Am(:), Q_k(:), Q_l(:), Qm(:) +integer(kind=iwp), external :: IsFreeUnit + +! * +!*********************************************************************** +! * +ThrQ = 1.0e-14_wp ! Threshold for Inv_Cho_Factor + +mB = 0 +nA_Diag = 0 +do iIrrep=0,nIrrep-1 + nB = nBas_Aux(iIrrep) + nA_Diag = nA_Diag+nB + mB = max(mB,nB) + + iSeed = 55+iIrrep + Lu_Q(iIrrep) = IsFreeUnit(iSeed) + write(Name_Q,'(A4,I2.2)') 'QMAT',iIrrep + call DaName_MF_WA(Lu_Q(iIrrep),Name_Q) + + iSeed = 63+iIrrep + Lu_A(iIrrep) = IsFreeUnit(iSeed) + write(Name_Q,'(A4,I2.2)') 'AVEC',iIrrep + call DaName_MF_WA(Lu_A(iIrrep),Name_Q) +end do +nBfn2 = mB**2 + +call mma_allocate(Z,mB,Label='Z') +call mma_allocate(X,mB,Label='X') +lScr = 3*mB +call mma_allocate(Scr,lScr,Label='Scr') +call mma_maxDBLE(Mem_Max) +call mma_allocate(Mem,Mem_Max,Label='Mem') + +nullify(A_k,Q_k) +do iIrrep=0,nIrrep-1 + nB = nBas_Aux(iIrrep) + nQm = nTri_Elem(nB) + + Out_Of_Core = 2*nQm > Mem_Max + if (Out_Of_Core) then + MaxMem = Mem_Max-2*nB + mQm = MaxMem/2 + a = One + b = -Two*real(mQm,kind=wp) + mB = int(-a*Half+sqrt((a*Half)**2-b)) + kQm = nTri_Elem(mB) + if (kQm > mQm) then + call WarningMessage(2,'Error in Gen_QVec') + write(u6,*) 'kQm > mQm!' + write(u6,*) 'MaxMem=',MaxMem + write(u6,*) 'nQm,mQm,kQm=',nQm,mQm,kQm + write(u6,*) 'nB,mB=',nB,mB + call Abend() + end if + iE = 2*kQm + iS = iE+1 + iE = iE+mB + Q_k(1:mB) => Mem(iS:iE) + iS = iE+1 + iE = iE+mB + A_k(1:mB) => Mem(iS:iE) + else + mB = nB + kQm = nQm + end if + + iS = 1 + iE = kQm + Qm(1:kQm) => Mem(iS:iE) + iS = iE+1 + iE = iE+kQm + Am(1:kQm) => Mem(iS:iE) + + iAddr = 0 + do kCol=1,nB + + if (kCol <= mB) then + iOff = nTri_Elem(kCol-1) + A_l(1:) => Am(1+iOff:) + else + A_l(1:) => A_k(1:mB) + end if + + iAddr_ = iAddr + if ((kCol <= mB) .and. (kCol == 1)) then + call dDaFile(Lu_A(iIrrep),2,Am,kQm,iAddr_) + else if (kCol > mB) then + call dDaFile(Lu_A(iIrrep),2,A_l,kCol,iAddr_) + end if +# ifdef _DEBUGPRINT_ + write(u6,*) 'kCol=',kCol + call TriPrt('Am',' ',Am,mB) + call RecPrt('Al',' ',A_l,1,kCol) +# endif + + if (kCol <= mB) then + iOff = nTri_Elem(kCol-1) + Q_l(1:) => Qm(1+iOff:) + else + Q_l(1:) => Q_k(1:mB) + end if + + LinDep = 2 + call Inv_Cho_Factor(A_l,kCol,Am,Qm,mB,Lu_A(iIrrep),Lu_Q(iIrrep),Scr,lScr,Z,X,ThrQ,Q_l,LinDep) + + if (LinDep /= 0) then + call WarningMessage(2,'Error in Gen_QVec') + write(u6,*) 'Inv_Cho_Factor found linear dependence!' + call Abend() + end if +# ifdef _DEBUGPRINT_ + call TriPrt('Qm',' ',Qm,min(mB,kCol)) + call RecPrt('Ql',' ',Q_l,1,kCol) +# endif + + ! Write the new A/Q-vector to file + + iAddr_ = iAddr + if (kCol == mB) then + lQm = nTri_Elem(kCol) + call dDaFile(Lu_Q(iIrrep),1,Qm,lQm,iAddr) + call dDaFile(Lu_A(iIrrep),1,Am,lQm,iAddr_) + else if (kCol > mB) then + nQ_k = kCol + call dDaFile(Lu_Q(iIrrep),1,Q_l,nQ_k,iAddr) + call dDaFile(Lu_A(iIrrep),1,A_l,nQ_k,iAddr_) + end if + + end do ! kCol + call DaClos(Lu_A(iIrrep)) +end do ! iIrrep + +nullify(A_l,Q_l,A_k,Q_k,Am,Qm) +call mma_deallocate(Mem) +call mma_deallocate(Scr) +call mma_deallocate(X) +call mma_deallocate(Z) + +! Sort the Q-matrix to square storage. + +call mma_allocate(iDiag,nA_Diag,Label='iDiag') +ik = 0 +do iIrrep=0,nIrrep-1 + do k=1,nBas_Aux(iIrrep) + ik = ik+1 + iDiag(ik) = k ! dummy assignement + end do +end do +call mma_maxDBLE(MaxMem2) +lScr = min(MaxMem2,nBfn2) +call mma_allocate(Scr,lScr,Label='Scr') + +nBas_Copy(0:nIrrep-1) = nBas_Aux +call SORT_Mat(irc,nBas_Aux,nBas_Copy,iDiag,nIrrep,Lu_Q,'Restore',lScr,Scr,dum) + +! Note: after the 'Restore' call to Sort_mat, the Q-matrix is +! no longer stored as upper-triangular but as squared +! (zeros have been added). + +call mma_deallocate(Scr) +call mma_deallocate(iDiag) + +do iIrrep=0,nIrrep-1 + call DaClos(Lu_Q(iIrrep)) +end do + +return + +end subroutine Gen_QVec diff -Nru openmolcas-22.02/src/ri_util/get_auxiliary_shells.F90 openmolcas-22.10/src/ri_util/get_auxiliary_shells.F90 --- openmolcas-22.02/src/ri_util/get_auxiliary_shells.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/get_auxiliary_shells.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,53 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Get_Auxiliary_Shells(iSO,nSO,jOff,iSO2Shl,nSO2Shl,iPair,nPair) + +use Index_Functions, only: iTri +use Definitions, only: iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: nSO, iSO(2,nSO), jOff, nSO2Shl, iSO2Shl(nSO2Shl), nPair +integer(kind=iwp), intent(_OUT_) :: iPair(nPair) +integer(kind=iwp) :: i, k, kl, kSh, l, lSh + +!write(u6,*) 'iSO' +!write(u6,*) '===' +!do i=1,nSO +! write(u6,*) iSO(1,i),iSO(2,i) +!end do + +!write(u6,*) 'iSO2Shl' +!write(u6,*) '=======' +!do i=1,nSO2Shl +! write(u6,*) i,iSO2Shl(i) +!end do +do i=1,nSO + k = iSO(1,i)+jOff + l = iSO(2,i)+jOff + kSh = iSO2Shl(k) + lSh = iSO2Shl(l) + !write(u6,*) 'k,kSh=',k,kSh + !write(u6,*) 'l,lSh=',k,lSh + kl = iTri(kSh,lSh) + iPair(kl) = 1 +end do +!write(u6,*) 'iPairs' +!write(u6,*) '======' +!do i=1,nPair +! write(u6,*) iPair(i) +!end do + +return + +end subroutine Get_Auxiliary_Shells diff -Nru openmolcas-22.02/src/ri_util/get_chunk.f openmolcas-22.10/src/ri_util/get_chunk.f --- openmolcas-22.02/src/ri_util/get_chunk.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/get_chunk.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,81 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Get_Chunk(LenVec,NumVec_,iChoVec,iSym,iVec_Global) - use Chunk_Mod -#ifdef _MOLCAS_MPP_ - Use Para_Info, Only: MyRank, Is_Real_Par -#endif - Implicit Real*8 (A-H,O-Z) -#ifdef _MOLCAS_MPP_ -#include "mafdecls.fh" -#endif -* -#ifdef _MOLCAS_MPP_ - If (Is_Real_Par()) Then - Call GA_Sync() - Call Cho_RI_SwapVecUnit(iSym) -* -* Get the subrange and check that we are within range. -* - J_s=iMap(1+MyRank) - If (J_s.gt.NumVec_) Go To 999 - J_e=iMap(1+MyRank+1)-1 - J_e=Min(J_e,NumVec_) - nJ=J_e-J_s+1 - If (nJ.gt.0) Then - MuNu_s=1 - MuNu_e=LenVec - Call GA_Access(ip_Chunk,MuNu_s,MuNu_e,J_s,J_e,Index,ld) -C Call RecPrt('Dbl_Mb(Index)',' ',Dbl_Mb(Index),LenVec,nJ) - Call Cho_PutVec(DBL_MB(Index),LenVec,nJ,iChoVec+1,iSym) - Call Cho_RI_SetInfVec_5(iVec_Global,iChoVec+1,J_s,J_e,iSym) - Call GA_Release(ip_Chunk,MuNu_s,MuNu_e,J_s,J_e) - iChoVec = iChoVec + nJ - End If - 999 Continue - Call Cho_RI_SwapVecUnit(iSym) - Else - Call Cho_PutVec(Chunk,LenVec,NumVec_,iChoVec+1,iSym) - iChoVec = iChoVec + NumVec_ - End If -* -#else - Call Cho_PutVec(Chunk,LenVec,NumVec_,iChoVec+1,iSym) - iChoVec = iChoVec + NumVec_ -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(iVec_Global) - End If -#endif -* - Return - End -#if defined (_MOLCAS_MPP_) - SubRoutine Cho_RI_SetInfVec_5(iVec_Global,iVec_Local,J_s,J_e,iSym) -C -C Set mapping from local to global vector index (needed in parallel -C RI gradient code). -C - use ChoSwp, only: InfVec - Implicit None - Integer iVec_Global, iVec_Local, J_s, J_e, iSym -#include "cholesky.fh" - - Integer iOff, nVec, iVec - - iOff = iVec_Global + J_s - 2 - nVec = J_e - J_s + 1 - Do iVec = 1,nVec - InfVec(iVec_Local-1+iVec,5,iSym) = iOff + iVec - End Do - - End -#endif diff -Nru openmolcas-22.02/src/ri_util/get_chunk.F90 openmolcas-22.10/src/ri_util/get_chunk.F90 --- openmolcas-22.02/src/ri_util/get_chunk.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/get_chunk.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,72 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Get_Chunk(LenVec,NumVec_,iChoVec,iSym,iVec_Global) + +use RI_glob, only: Chunk +#ifdef _MOLCAS_MPP_ +use RI_glob, only: iMap, ip_Chunk +use ChoSwp, only: InfVec +use Para_Info, only: MyRank, Is_Real_Par +#endif +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: LenVec, NumVec_, iSym, iVec_Global +integer(kind=iwp), intent(inout) :: iChoVec +#ifdef _MOLCAS_MPP_ +#include "mafdecls.fh" +integer(kind=iwp) :: Indx, iVec, J_e, J_s, ld, MuNu_e, MuNu_s, nJ +#endif + +#ifndef _MOLCAS_MPP_ +#include "macros.fh" +unused_var(iVec_Global) +#endif + +#ifdef _MOLCAS_MPP_ +if (Is_Real_Par()) then + call GA_Sync() + call Cho_RI_SwapVecUnit(iSym) + + ! Get the subrange and check that we are within range. + + J_s = iMap(1+MyRank) + if (J_s <= NumVec_) then + J_e = iMap(1+MyRank+1)-1 + J_e = min(J_e,NumVec_) + nJ = J_e-J_s+1 + if (nJ > 0) then + MuNu_s = 1 + MuNu_e = LenVec + call GA_Access(ip_Chunk,MuNu_s,MuNu_e,J_s,J_e,Indx,ld) + !call RecPrt('Dbl_Mb(Indx)',' ',Dbl_Mb(Indx),LenVec,nJ) + call Cho_PutVec(DBL_MB(Indx),LenVec,nJ,iChoVec+1,iSym) + ! Set mapping from local to global vector index + do iVec=1,nJ + InfVec(iChoVec+iVec,5,iSym) = iVec_Global+J_s-2+iVec + end do + call GA_Release(ip_Chunk,MuNu_s,MuNu_e,J_s,J_e) + iChoVec = iChoVec+nJ + end if + end if + call Cho_RI_SwapVecUnit(iSym) +else +#endif + call Cho_PutVec(Chunk,LenVec,NumVec_,iChoVec+1,iSym) + iChoVec = iChoVec+NumVec_ +#ifdef _MOLCAS_MPP_ +end if +#endif + +return + +end subroutine Get_Chunk diff -Nru openmolcas-22.02/src/ri_util/get_MaxDG.f openmolcas-22.10/src/ri_util/get_MaxDG.f --- openmolcas-22.02/src/ri_util/get_MaxDG.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/get_MaxDG.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,67 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Get_maxDG(SDG,nnSkal,MxBasSh) -************************************************************************ -* Compute Sqrt(Abs( (mu,nu|mu,nu) ) ) * -* Make a list of the largest such element for each shell-pair * -* Store in SDG. * -************************************************************************ - use ChoArr, only: iSOShl, iRS2F - Implicit Real*8 (a-h,o-z) - Integer nnSkal, MxBasSh - Real*8 SDG(nnSkal) -#include "real.fh" -#include "cholesky.fh" -#include "stdalloc.fh" - Real*8, Allocatable :: Diag(:) -* * -************************************************************************ -* * -* Statement functions -* - iTri(i,j)=max(i,j)*(max(i,j)-3)/2+i+j -* * -************************************************************************ -* * - SDG(:)=Zero -* - iLoc=1 ! point to 1st reduced set in index arrays - Call mma_allocate(Diag,NNBSTRT(iLoc),Label='Diag') -* -* Read the diagonal of the integrals, (mu,nu|mu,nu) -* - CALL CHO_IODIAG(DIAG,2) -* - Do jSym=1,nSym -* - Do jRab=1,nnBstR(jSym,iLoc) -* - kRab = iiBstr(jSym,iLoc) + jRab ! already in 1st red set -* - iag = iRS2F(1,kRab) !global address - ibg = iRS2F(2,kRab) -* - iaSh = iSOShl(iag) ! shell to which it belongs - ibSh = iSOShl(ibg) -* - iabSh= iTri(iaSh,ibSh) -* - SDG(iabSh)= Max(SDG(iabSh),sqrt(abs(Diag(kRab)))) -* - End Do ! jRab loop - End Do -* - Call mma_deallocate(Diag) -* - MxBasSh = MxOrSh -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/get_maxdg.F90 openmolcas-22.10/src/ri_util/get_maxdg.F90 --- openmolcas-22.02/src/ri_util/get_maxdg.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/get_maxdg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,70 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Get_maxDG(SDG,nnSkal,MxBasSh) +!*********************************************************************** +! Compute Sqrt(Abs( (mu,nu|mu,nu) ) ) * +! Make a list of the largest such element for each shell-pair * +! Store in SDG. * +!*********************************************************************** + +use Index_Functions, only: iTri +use ChoArr, only: iRS2F, iSOShl +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nnSkal +real(kind=wp), intent(inout) :: SDG(nnSkal) +integer(kind=iwp), intent(out) :: MxBasSh +#include "cholesky.fh" +integer(kind=iwp) :: iabSh, iag, iaSh, ibg, ibSh, iLoc, jRab, jSym, kRab +real(kind=wp), allocatable :: Diag(:) + +! * +!*********************************************************************** +! * +SDG(:) = Zero + +iLoc = 1 ! point to 1st reduced set in index arrays +call mma_allocate(Diag,NNBSTRT(iLoc),Label='Diag') + +! Read the diagonal of the integrals, (mu,nu|mu,nu) + +call CHO_IODIAG(DIAG,2) + +do jSym=1,nSym + + do jRab=1,nnBstR(jSym,iLoc) + + kRab = iiBstr(jSym,iLoc)+jRab ! already in 1st red set + + iag = iRS2F(1,kRab) !global address + ibg = iRS2F(2,kRab) + + iaSh = iSOShl(iag) ! shell to which it belongs + ibSh = iSOShl(ibg) + + iabSh = iTri(iaSh,ibSh) + + SDG(iabSh) = max(SDG(iabSh),sqrt(abs(Diag(kRab)))) + + end do ! jRab loop +end do + +call mma_deallocate(Diag) + +MxBasSh = MxOrSh + +return + +end subroutine Get_maxDG diff -Nru openmolcas-22.02/src/ri_util/get_mXOs.f openmolcas-22.10/src/ri_util/get_mXOs.f --- openmolcas-22.02/src/ri_util/get_mXOs.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/get_mXOs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,66 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Get_mXOs(kOrb,XO,locc,nSkal,nIrrep,nOcc) - use ChoArr, only: nBasSh - use ExTerm, only: CMOi - Implicit Real*8 (a-h,o-z) - Integer kOrb, nOcc(nIrrep), nSkal - Real*8 XO(locc,nSkal,nIrrep) -#include "cholesky.fh" -#include "choorb.fh" -#include "exterm.fh" -* * -************************************************************************ -* * - Call FZero(XO,locc*nSkal*nIrrep) -* -* -* Loop over irreps -* - Do ir=1,nIrrep -* -* The next block of X_i,mu -* -* Call RecPrt('X_i,mu',' ',CMOi(kOrb)%SB(ir)%A2,nOcc(ir), -* & nBas(ir)) -* -* Loop over all valence shells -* - iOff=0 - Do isk=1,nSkal -* -* Loop over all basis functions of this shell in this -* irrep. -* -* Write (*,*) 'isk,nBasSh(ir,isk)=',isk,nBasSh(ir,isk) -* - Do ib=1,nBasSh(ir,isk) - kb=iOff+ib ! relative SO index in this irrepp -* -* Loop over all the occupied MOs and pick up the largest -* coefficient for shell isk -* - Do iok=1,nOcc(ir) -* Write (*,*) 'iok,kb=',iok,kb -* Write (*,*) 'CMOi(kOrb)%SB(ir)%A2(iok,kb)', -* CMOi(kOrb)%SB(ir)%A2(iok,kb) - XO(iok,isk,ir)=Max(XO(iok,isk,ir), - & abs( CMOi(kOrb)%SB(ir)%A2(iok,kb) ) - & ) - End Do - End Do - iOff=iOff+nBasSh(ir,isk) - End Do -* Call RecPrt('XO(*,*,ir)',' ',XO(1,1,ir),locc,nskal) - End Do -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/get_mxos.F90 openmolcas-22.10/src/ri_util/get_mxos.F90 --- openmolcas-22.02/src/ri_util/get_mxos.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/get_mxos.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,64 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Get_mXOs(kOrb,XO,locc,nSkal,nIrrep,nOcc) + +use ChoArr, only: nBasSh +use RI_glob, only: CMOi +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: kOrb, locc, nSkal, nIrrep, nOcc(nIrrep) +real(kind=wp), intent(out) :: XO(locc,nSkal,nIrrep) +integer(kind=iwp) :: ib, iOff, iok, ir, isk, kb + +! * +!*********************************************************************** +! * +XO(:,:,:) = Zero + +! Loop over irreps + +do ir=1,nIrrep + + ! The next block of X_i,mu + + !call RecPrt('X_i,mu',' ',CMOi(kOrb)%SB(ir)%A2,nOcc(ir),nBas(ir)) + + ! Loop over all valence shells + + iOff = 0 + do isk=1,nSkal + + ! Loop over all basis functions of this shell in this irrep. + + !write (u6,*) 'isk,nBasSh(ir,isk)=',isk,nBasSh(ir,isk) + + do ib=1,nBasSh(ir,isk) + kb = iOff+ib ! relative SO index in this irrepp + + ! Loop over all the occupied MOs and pick up the largest coefficient for shell isk + + do iok=1,nOcc(ir) + !write(u6,*) 'iok,kb=',iok,kb + !write(u6,*) 'CMOi(kOrb)%SB(ir)%A2(iok,kb)',CMOi(kOrb)%SB(ir)%A2(iok,kb) + XO(iok,isk,ir) = max(XO(iok,isk,ir),abs(CMOi(kOrb)%SB(ir)%A2(iok,kb))) + end do + end do + iOff = iOff+nBasSh(ir,isk) + end do + !call RecPrt('XO(*,*,ir)',' ',XO(1,1,ir),locc,nskal) +end do + +return + +end subroutine Get_mXOs diff -Nru openmolcas-22.02/src/ri_util/get_pivot_idx.f openmolcas-22.10/src/ri_util/get_pivot_idx.f --- openmolcas-22.02/src/ri_util/get_pivot_idx.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/get_pivot_idx.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,131 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Francesco Aquilante * -************************************************************************ - SUBROUTINE get_pivot_idx(Diag,n,m,lu_A0,lu_A,iD_A,Scr,lScr,Thr) -************************************************************************ -* -* Author: F. Aquilante -* -************************************************************************ - Implicit Real*8 (a-h,o-z) - Integer n, m, lu_A0, lu_A, iD_A(n), lScr - Real*8 Diag(*), Scr(lScr) -#include "stdalloc.fh" -#include "warnings.h" - - Integer, Allocatable :: list(:) -#ifdef _DEBUGPRINT_ -C-tbp: check diagonal for negative entries - n_NegInpDiag=0 - d_NegInpDiag=0.0d0 - do i=1,n - if (Diag(i).lt.0.0d0) then - n_NegInpDiag=n_NegInpDiag+1 - if (Diag(i).lt.d_NegInpDiag) then - d_NegInpDiag=Diag(i) - end if - end if - end do - write(6,'(A,I10,A,I10)') - *'GET_PIVOT_IDX: number of negative input diagonals:',n_NegInpDiag, - * ' out of ',n - if (n_NegInpDiag.gt.0) then - write(6,'(A,1P,D12.4)') - * 'GET_PIVOT_IDX: most negative diagonal: ',d_NegInpDiag - end if -#endif -* -* - Acc=Min(1.0D-12,thr*1.0D-2) - Call mma_Allocate(List,n,Label='List') - Do i=1,n - list(i)=i - End Do -* - lmax=lScr-2*n - If (lmax .lt. n) Then - Call WarningMessage(2,'Error in Get_Pivot_idx') - write(6,*) ' Get_Pivot_idx: too little scratch space!! ' - Call Quit(_RC_CHO_LOG_) - Endif -* - nMem_Col = Min(lmax/n,n) -* - kAddr=0 - is=1+n - ij = n*nMem_Col - ks=is+ij - kScr=lScr-n-ij -* - m=0 - Do kCol = 1,n -* - iD_Col=0 - XMax=0.0D0 - Do i=1,n - If (Abs(Diag(i)).gt.xMax+Acc) Then - iD_Col=i - xMax=Abs(Diag(i)) - End If - End Do - If (iD_Col.lt.0 .or. iD_Col.gt.n) Then - Write(6,*) 'Get_Pivot_id: Index of Max Diag out of bounds!' - Write(6,*) 'iD_Col = ',iD_Col - Call Abend() - ElseIf (iD_Col.eq.0) Then - Go To 100 - End If - iD_A(kCol) = iD_Col ! set the mapping -* - js=n*(kCol-1)+is ! overlay A and Z - If (kCol.gt.nMem_Col) js=1 -* - kAddr=n*(iD_Col-1) - Call dDaFile(lu_A0,2,Scr(js),n,kAddr) -* - Call CHO_FACTOR(Diag,Scr(js),iD_A,kCol,n,Scr(is),nMem_Col,lu_A, - & Scr(ks),kScr,thr,lindep) -* - If (lindep.ne.0) Goto 100 -* - list(iD_Col)=0 - m=m+1 -* - iAddr=n*(kCol-1) - If (kCol.gt.nMem_Col) Call dDaFile(lu_A,1,Scr(1),n,iAddr) -* - End Do -* -100 Continue - iAddr=0 - Call dDaFile(lu_A,1,Scr(is),ij,iAddr) -* - If (m.lt.n) Then - istart=1 - Do k=m+1,n - Do i=istart,n - if (list(i).ne.0) Then - iD_A(k)=i - istart=i+1 - goto 200 - endif - End Do -200 Continue - End Do - ElseIf (m.gt.n) Then - Write(6,*) 'Get_Pivot_id: m > n is not possible!' - Call Abend() - EndIf - Call mma_deallocate(List) -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/get_pivot_idx.F90 openmolcas-22.10/src/ri_util/get_pivot_idx.F90 --- openmolcas-22.02/src/ri_util/get_pivot_idx.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/get_pivot_idx.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,135 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Francesco Aquilante * +!*********************************************************************** + +subroutine get_pivot_idx(Diag,n,m,lu_A0,lu_A,iD_A,Scr,lScr,Thr) +!*********************************************************************** +! * +! Author: F. Aquilante * +! * +!*********************************************************************** + +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +real(kind=wp), intent(inout) :: Diag(*) +integer(kind=iwp), intent(in) :: n, lu_A0, lu_A, lScr +integer(kind=iwp), intent(out) :: m, iD_A(n) +real(kind=wp), intent(out) :: Scr(lScr) +real(kind=wp), intent(in) :: Thr +#include "warnings.h" +integer(kind=iwp) :: i, iAddr, iD_Col, ij, is, istart, js, k, kAddr, kCol, ks, kScr, lindep, lmax, nMem_Col +real(kind=wp) :: Acc, XMax +integer(kind=iwp), allocatable :: list(:) + +#ifdef _DEBUGPRINT_ +!-tbp: check diagonal for negative entries +n_NegInpDiag = 0 +d_NegInpDiag = Zero +do i=1,n + if (Diag(i) < Zero) then + n_NegInpDiag = n_NegInpDiag+1 + if (Diag(i) < d_NegInpDiag) then + d_NegInpDiag = Diag(i) + end if + end if +end do +write(u6,'(A,I10,A,I10)') 'GET_PIVOT_IDX: number of negative input diagonals:',n_NegInpDiag,' out of ',n +if (n_NegInpDiag > 0) then + write(u6,'(A,1P,D12.4)') 'GET_PIVOT_IDX: most negative diagonal: ',d_NegInpDiag +end if +#endif + +Acc = min(1.0e-12_wp,thr*1.0e-2_wp) +call mma_Allocate(List,n,Label='List') +do i=1,n + list(i) = i +end do + +lmax = lScr-2*n +if (lmax < n) then + call WarningMessage(2,'Error in Get_Pivot_idx') + write(u6,*) ' Get_Pivot_idx: too little scratch space!! ' + call Quit(_RC_CHO_LOG_) +end if + +nMem_Col = min(lmax/n,n) + +kAddr = 0 +is = 1+n +ij = n*nMem_Col +ks = is+ij +kScr = lScr-n-ij + +m = 0 +do kCol=1,n + + iD_Col = 0 + XMax = Zero + do i=1,n + if (abs(Diag(i)) > xMax+Acc) then + iD_Col = i + xMax = abs(Diag(i)) + end if + end do + if ((iD_Col < 0) .or. (iD_Col > n)) then + write(u6,*) 'Get_Pivot_id: Index of Max Diag out of bounds!' + write(u6,*) 'iD_Col = ',iD_Col + call Abend() + else if (iD_Col == 0) then + exit + end if + iD_A(kCol) = iD_Col ! set the mapping + + js = n*(kCol-1)+is ! overlay A and Z + if (kCol > nMem_Col) js = 1 + + kAddr = n*(iD_Col-1) + call dDaFile(lu_A0,2,Scr(js),n,kAddr) + + call CHO_FACTOR(Diag,Scr(js),iD_A,kCol,n,Scr(is),nMem_Col,lu_A,Scr(ks),kScr,thr,lindep) + + if (lindep /= 0) exit + + list(iD_Col) = 0 + m = m+1 + + iAddr = n*(kCol-1) + if (kCol > nMem_Col) call dDaFile(lu_A,1,Scr,n,iAddr) + +end do + +iAddr = 0 +call dDaFile(lu_A,1,Scr(is),ij,iAddr) + +if (m < n) then + istart = 1 + do k=m+1,n + do i=istart,n + if (list(i) /= 0) then + iD_A(k) = i + istart = i+1 + exit + end if + end do + end do +else if (m > n) then + write(u6,*) 'Get_Pivot_id: m > n is not possible!' + call Abend() +end if +call mma_deallocate(List) + +return + +end subroutine get_pivot_idx diff -Nru openmolcas-22.02/src/ri_util/get_pivot_idx_w.f openmolcas-22.10/src/ri_util/get_pivot_idx_w.f --- openmolcas-22.02/src/ri_util/get_pivot_idx_w.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/get_pivot_idx_w.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,115 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Francesco Aquilante * -************************************************************************ - SUBROUTINE get_pivot_idx_w(Diag,Wg,n,m,lu_A0,lu_A,iD_A,Scr,lScr, - & Thr) -************************************************************************ -* -* Author: F. Aquilante -* -* Note: this routine differs from Get_pivot_idx because here -* the pivoting/convergence is decided based on weighted -* diagonals -************************************************************************ - Implicit Real*8 (a-h,o-z) - Integer n, m, lu_A0, lu_A, iD_A(n), lScr - Real*8 Diag(*), Wg(*), Scr(lScr) -#include "stdalloc.fh" -#include "warnings.h" - - Integer, Allocatable :: List(:) -* -* - Acc=Min(1.0D-12,thr*1.0D-2) - Call mma_allocate(List,n,Label='List') - Do i=1,n - List(i)=i - End Do -* - lmax=lScr-2*n - If (lmax .lt. n) Then - Call WarningMessage(2,'Error in Get_Pivot_idx_w') - write(6,*) ' Get_Pivot_idx_w: too little scratch space!! ' - Call Quit(_RC_CHO_LOG_) - Endif -* - nMem_Col = Min(lmax/n,n) -* - kAddr=0 - is=1+n - ij = n*nMem_Col - ks=is+ij - kScr=lScr-n-ij -* - m=0 - Do kCol = 1,n -* - iD_Col=0 - XMax=0.0D0 - Do i=1,n - If (Abs(Diag(i)*Wg(i)).gt.xMax+Acc) Then - iD_Col=i - xMax=Abs(Diag(i)) - End If - End Do - If (iD_Col.lt.0 .or. iD_Col.gt.n) Then - Write(6,*) 'Get_Pivot_idx_w: Index of MaxDiag out of bounds!' - Write(6,*) 'iD_Col = ',iD_Col - Call Abend() - ElseIf (iD_Col.eq.0) Then - Go To 100 - End If - iD_A(kCol) = iD_Col ! set the mapping -* - js=n*(kCol-1)+is ! overlay A and Z - If (kCol.gt.nMem_Col) js=1 -* - kAddr=n*(iD_Col-1) - Call dDaFile(lu_A0,2,Scr(js),n,kAddr) -* - Call CHO_FACTOR(Diag,Scr(js),iD_A,kCol,n,Scr(is),nMem_Col,lu_A, - & Scr(ks),kScr,thr,lindep) -* - If (lindep.ne.0) Goto 100 -* - list(iD_Col)=0 - m=m+1 -* - iAddr=n*(kCol-1) - If (kCol.gt.nMem_Col) Call dDaFile(lu_A,1,Scr(1),n,iAddr) -* - End Do -* -100 Continue - iAddr=0 - Call dDaFile(lu_A,1,Scr(is),ij,iAddr) -* - If (m.lt.n) Then - istart=1 - Do k=m+1,n - Do i=istart,n - if (list(i).ne.0) Then - iD_A(k)=i - istart=i+1 - goto 200 - endif - End Do -200 Continue - End Do - ElseIf (m.gt.n) Then - Write(6,*) 'Get_Pivot_idx_w: m > n is not possible!' - Call Abend() - EndIf - Call mma_deallocate(List) -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/get_pivot_idx_w.F90 openmolcas-22.10/src/ri_util/get_pivot_idx_w.F90 --- openmolcas-22.02/src/ri_util/get_pivot_idx_w.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/get_pivot_idx_w.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,120 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Francesco Aquilante * +!*********************************************************************** + +subroutine get_pivot_idx_w(Diag,Wg,n,m,lu_A0,lu_A,iD_A,Scr,lScr,Thr) +!*********************************************************************** +! * +! Author: F. Aquilante * +! * +! Note: this routine differs from Get_pivot_idx because here * +! the pivoting/convergence is decided based on weighted * +! diagonals * +!*********************************************************************** + +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +real(kind=wp), intent(inout) :: Diag(*) +real(kind=wp), intent(in) :: Wg(*), Thr +integer(kind=iwp), intent(in) :: n, lu_A0, lu_A, lScr +integer(kind=iwp), intent(out) :: m, iD_A(n) +real(kind=wp), intent(out) :: Scr(lScr) +#include "warnings.h" +integer(kind=iwp) :: i, iAddr, iD_Col, ij, is, istart, js, k, kAddr, kCol, ks, kScr, lindep, lmax, nMem_Col +real(kind=wp) :: Acc, XMax +integer(kind=iwp), allocatable :: List(:) + +Acc = min(1.0e-12_wp,thr*1.0e-2_wp) +call mma_allocate(List,n,Label='List') +do i=1,n + List(i) = i +end do + +lmax = lScr-2*n +if (lmax < n) then + call WarningMessage(2,'Error in Get_Pivot_idx_w') + write(u6,*) ' Get_Pivot_idx_w: too little scratch space!! ' + call Quit(_RC_CHO_LOG_) +end if + +nMem_Col = min(lmax/n,n) + +kAddr = 0 +is = 1+n +ij = n*nMem_Col +ks = is+ij +kScr = lScr-n-ij + +m = 0 +do kCol=1,n + + iD_Col = 0 + XMax = Zero + do i=1,n + if (abs(Diag(i)*Wg(i)) > xMax+Acc) then + iD_Col = i + xMax = abs(Diag(i)) + end if + end do + if ((iD_Col < 0) .or. (iD_Col > n)) then + write(u6,*) 'Get_Pivot_idx_w: Index of MaxDiag out of bounds!' + write(u6,*) 'iD_Col = ',iD_Col + call Abend() + else if (iD_Col == 0) then + exit + end if + iD_A(kCol) = iD_Col ! set the mapping + + js = n*(kCol-1)+is ! overlay A and Z + if (kCol > nMem_Col) js = 1 + + kAddr = n*(iD_Col-1) + call dDaFile(lu_A0,2,Scr(js),n,kAddr) + + call CHO_FACTOR(Diag,Scr(js),iD_A,kCol,n,Scr(is),nMem_Col,lu_A,Scr(ks),kScr,thr,lindep) + + if (lindep /= 0) exit + + list(iD_Col) = 0 + m = m+1 + + iAddr = n*(kCol-1) + if (kCol > nMem_Col) call dDaFile(lu_A,1,Scr(1),n,iAddr) + +end do + +iAddr = 0 +call dDaFile(lu_A,1,Scr(is),ij,iAddr) + +if (m < n) then + istart = 1 + do k=m+1,n + do i=istart,n + if (list(i) /= 0) then + iD_A(k) = i + istart = i+1 + exit + end if + end do + end do +else if (m > n) then + write(u6,*) 'Get_Pivot_idx_w: m > n is not possible!' + call Abend() +end if +call mma_deallocate(List) + +return + +end subroutine get_pivot_idx_w diff -Nru openmolcas-22.02/src/ri_util/indsft_RI_2.f openmolcas-22.10/src/ri_util/indsft_RI_2.f --- openmolcas-22.02/src/ri_util/indsft_RI_2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/indsft_RI_2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,176 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine IndSft_RI_2(iCmp,iShell,iBas,jBas,kBas,lBas, - & Shijij, iAO, iAOst, ijkl,SOint,nSOint, - & iSOSym,nSOs,TInt,nTInt,iOff, - & iSO2Ind,iOffA) -************************************************************************ -* object: to sift and index the SO integrals. * -* * -* the indices has been scrambled before calling this routine. * -* Hence we must take special care in order to regain the can- * -* onical order. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, Ca * -* april '90 * -* * -************************************************************************ - use Basis_Info, only: nBas - use SOAO_Info, only: iAOtSO - use Symmetry_Info, only: nIrrep - use sort_data, only: nSkip - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" -* - Real*8 SOint(ijkl,nSOint), TInt(nTInt) - Integer iCmp(4), iShell(4), iAO(4), iOffA(4,0:7), - & iAOst(4), iSOSym(2,nSOs), iSO2Ind(nSOs) - Integer iOff(0:7) - Logical Shijij, qijij -* local array - Integer jSym(0:7), lSym(0:7) -#ifdef _DEBUGPRINT_ - Data tr1,tr2/0.0d0,0.0d0/ - Save tr1,tr2 -#endif -* * -************************************************************************ -* * - iTri(i,j)=Max(i,j)*(Max(i,j)-1)/2 + Min(i,j) -* * -************************************************************************ -* * - k12=0 - k34=0 -#ifdef _DEBUGPRINT_ - irout = 39 - iprint = nprint(irout) - If (iPrint.ge.49) Then - r1=DDot_(ijkl*nSOInt,SOInt,1,[One],0) - r2=DDot_(ijkl*nSOInt,SOInt,1,SOInt,1) - tr1=tr1+r1 - tr2=tr2+r2 - Write (6,*) ' Sum=',r1,tr1 - Write (6,*) ' Dot=',r2,tr2 - Call RecPrt(' in indsft:SOint ',' ',SOint,ijkl,nSOint) - End If -#endif - memSO2 = 0 -* -* -* quadruple loop over elements of the basis functions angular -* description. loops are reduced to just produce unique SO integrals -* observe that we will walk through the memory in AOint in a -* sequential way. -* - i1 = 1 - i3 = 1 - j1 = 0 - j3 = 0 - Do i2 = 1, iCmp(2) - Do 201 j = 0, nIrrep-1 - ix = 0 - If (iAOtSO(iAO(2)+i2,j)>0) ix = 2**j - jSym(j) = ix -201 Continue - If (iShell(2).gt.iShell(1)) then - i12 = iCmp(2)*(i1-1) + i2 - else - i12 = iCmp(1)*(i2-1) + i1 - End If - Do 400 i4 = 1, iCmp(4) - Do 401 j = 0, nIrrep-1 - ix = 0 - If (iAOtSO(iAO(4)+i4,j)>0) ix = 2**j - lSym(j) = ix -401 Continue - If (iShell(4).gt.iShell(3)) then - i34 = iCmp(4)*(i3-1) + i4 - else - i34 = iCmp(3)*(i4-1) + i3 - End If - If (Shijij .and. i34.gt.i12) go to 400 - qijij = Shijij .and. i12.eq.i34 -C Write (6,*) 'i1,i2,i3,i4=',i1,i2,i3,i4 -* -* loop over Irreps which are spanned by the basis function. -* again, the loop structure is restricted to ensure unique -* integrals. -* - Do 210 j2 = 0, nIrrep-1 - If (jSym(j2).eq.0) go to 210 - j12 = ieor(j1,j2) - If (qijij) then - If (iShell(1).gt.iShell(2)) then - k12 = nIrrep*j1 + j2+1 - else - k12 = nIrrep*j2 + j1+1 - End If - End If -* - iOffA_= iOffA(1,j2) - iOffB_= iOffA(3,j2) - If (j2.ne.0) iOffB_=iOffB_+1 - mm_ = iOffA(4,j2) - nn = mm_ - iOffA(2,j2) - mx = nn*(nn+1)/2 -* - j4 = ieor(j12,j3) - If (lSym(j4).eq.0) go to 210 - If (qijij) then - If (iShell(3).gt.iShell(4)) then - k34 = nIrrep*j3 + j4+1 - else - k34 = nIrrep*j4 + j3+1 - End If - If (k34.gt.k12) go to 210 - End If -* - memSO2 = memSO2 + 1 - If ( (nSkip(j2+1)+nSkip(j4+1) ).ne.0 ) GoTo 210 -* -* Compute absolute starting SO index - jSO = iAOtSO(iAO(2)+i2,j2)+iAOst(2) - lSO = iAOtSO(iAO(4)+i4,j4)+iAOst(4) -* - nijkl = 0 - Do lSOl = lSO, lSO+lBas-1 - Do jSOj = jSO, jSO+jBas-1 - nijkl = nijkl + 1 - AInt=SOint(nijkl,memSO2) - iSO = jSOj-nBas(j2) - kSO = lSOl-nBas(j4) -* - iSO = iSO2Ind(iSO+iOffB_) + nn - ij= iTri(iSO,kSO) - mx + iOffA_ - TInt(ij)=AInt -* - End Do - End Do -* -210 Continue -* -400 Continue - End Do -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(iBas) - Call Unused_integer(kBas) - Call Unused_integer_array(iSOSym) - Call Unused_integer_array(iOff) - End If - End diff -Nru openmolcas-22.02/src/ri_util/indsft_ri_2.F90 openmolcas-22.10/src/ri_util/indsft_ri_2.F90 --- openmolcas-22.02/src/ri_util/indsft_ri_2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/indsft_ri_2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,164 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine IndSft_RI_2(iCmp,iShell,jBas,lBas,Shijij,iAO,iAOst,ijkl,SOint,nSOint,nSOs,TInt,nTInt,iSO2Ind,iOffA) +!*********************************************************************** +! object: to sift and index the SO integrals. * +! * +! the indices have been scrambled before calling this routine.* +! Hence we must take special care in order to regain the * +! canonical order. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, Ca * +! april '90 * +! * +!*********************************************************************** + +use Index_Functions, only: iTri, nTri_Elem +use Basis_Info, only: nBas +use SOAO_Info, only: iAOtSO +use Symmetry_Info, only: Mul, nIrrep +use sort_data, only: nSkip +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: iCmp(4), iShell(4), jBas, lBas, iAO(4), iAOst(4), ijkl, nSOint, nSOs, nTInt, iSO2Ind(nSOs), & + iOffA(4,0:7) +logical(kind=iwp), intent(in) :: Shijij +real(kind=wp), intent(in) :: SOint(ijkl,nSOint) +real(kind=wp), intent(inout) :: TInt(nTInt) +integer(kind=iwp) :: i1, i12, i2, i3, i34, i4, ij, iOffA_, iOffB_, iSO, ix, j, j1, j12, j2, j3, j4, jSO, jSOj, jSym(0:7), k12, & + k34, kSO, lSO, lSOl, lSym(0:7), memSO2, mm_, mx, nijkl, nn +#ifdef _DEBUGPRINT_ +real(kind=wp) :: tr1 = Zero, tr2 = Zero +#endif +logical(kind=iwp) :: qijij + +! * +!*********************************************************************** +! * +k12 = 0 +k34 = 0 +#ifdef _DEBUGPRINT_ +irout = 39 +iprint = nprint(irout) +if (iPrint >= 49) then + r1 = DDot_(ijkl*nSOInt,SOInt,1,[One],0) + r2 = DDot_(ijkl*nSOInt,SOInt,1,SOInt,1) + tr1 = tr1+r1 + tr2 = tr2+r2 + write(u6,*) ' Sum=',r1,tr1 + write(u6,*) ' Dot=',r2,tr2 + call RecPrt(' in indsft:SOint ',' ',SOint,ijkl,nSOint) +end if +#endif +memSO2 = 0 + +! quadruple loop over elements of the basis functions angular +! description. loops are reduced to just produce unique SO integrals +! observe that we will walk through the memory in AOint in a +! sequential way. + +i1 = 1 +i3 = 1 +j1 = 0 +j3 = 0 +do i2=1,iCmp(2) + do j=0,nIrrep-1 + ix = 0 + if (iAOtSO(iAO(2)+i2,j) > 0) ix = 2**j + jSym(j) = ix + end do + if (iShell(2) > iShell(1)) then + i12 = iCmp(2)*(i1-1)+i2 + else + i12 = iCmp(1)*(i2-1)+i1 + end if + do i4=1,iCmp(4) + do j=0,nIrrep-1 + ix = 0 + if (iAOtSO(iAO(4)+i4,j) > 0) ix = 2**j + lSym(j) = ix + end do + if (iShell(4) > iShell(3)) then + i34 = iCmp(4)*(i3-1)+i4 + else + i34 = iCmp(3)*(i4-1)+i3 + end if + if (Shijij .and. (i34 > i12)) cycle + qijij = Shijij .and. (i12 == i34) + !write(u6,*) 'i1,i2,i3,i4=',i1,i2,i3,i4 + + ! loop over Irreps which are spanned by the basis function. + ! again, the loop structure is restricted to ensure unique + ! integrals. + + do j2=0,nIrrep-1 + if (jSym(j2) == 0) cycle + j12 = Mul(j1+1,j2+1)-1 + if (qijij) then + if (iShell(1) > iShell(2)) then + k12 = nIrrep*j1+j2+1 + else + k12 = nIrrep*j2+j1+1 + end if + end if + + iOffA_ = iOffA(1,j2) + iOffB_ = iOffA(3,j2) + if (j2 /= 0) iOffB_ = iOffB_+1 + mm_ = iOffA(4,j2) + nn = mm_-iOffA(2,j2) + mx = nTri_Elem(nn) + + j4 = Mul(j12+1,j3+1)-1 + if (lSym(j4) == 0) cycle + if (qijij) then + if (iShell(3) > iShell(4)) then + k34 = nIrrep*j3+j4+1 + else + k34 = nIrrep*j4+j3+1 + end if + if (k34 > k12) cycle + end if + + memSO2 = memSO2+1 + if ((nSkip(j2+1)+nSkip(j4+1)) /= 0) cycle + + ! Compute absolute starting SO index + jSO = iAOtSO(iAO(2)+i2,j2)+iAOst(2) + lSO = iAOtSO(iAO(4)+i4,j4)+iAOst(4) + + nijkl = 0 + do lSOl=lSO,lSO+lBas-1 + do jSOj=jSO,jSO+jBas-1 + nijkl = nijkl+1 + iSO = jSOj-nBas(j2) + kSO = lSOl-nBas(j4) + + iSO = iSO2Ind(iSO+iOffB_)+nn + ij = iTri(iSO,kSO)-mx+iOffA_ + TInt(ij) = SOint(nijkl,memSO2) + + end do + end do + + end do + + end do +end do + +return + +end subroutine IndSft_RI_2 diff -Nru openmolcas-22.02/src/ri_util/indsft_RI_3.f openmolcas-22.10/src/ri_util/indsft_RI_3.f --- openmolcas-22.02/src/ri_util/indsft_RI_3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/indsft_RI_3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,203 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine IndSft_RI_3(iCmp,iShell,iBas,jBas,kBas,lBas, - & Shijij, iAO, iAOst, ijkl,SOint,nSOint, - & iSOSym,nSOs, - & TInt,nTInt,iOff,iShlSO,nBasSh, - & iSOShl,nSO,nShell,nSym,iSSOff) -************************************************************************ -* object: to sift and index the SO integrals. * -* * -* the indices has been scrambled before calling this routine. * -* Hence we must take special care in order to regain the can- * -* onical order. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, Ca * -* april '90 * -* * -************************************************************************ - use Basis_Info, only: nBas - use SOAO_Info, only: iAOtSO - use Symmetry_Info, only: nIrrep - use sort_data, only: nSkip - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" -* - Real*8 SOint(ijkl,nSOint), TInt(nTInt) - Integer iSOShl(nSO), iShlSO(nSO), nBasSh(0:nSym-1,nShell), - & iSSOff(0:nIrrep-1,0:nIrrep-1) - Integer iCmp(4), iShell(4), iAO(4), - & iAOst(4), iSOSym(2,nSOs), jOffSO(0:7) - Logical Shijij, Shkl, qkl -* local array - Integer jSym(0:7), kSym(0:7), lSym(0:7), iOff(3,0:7) -* * -************************************************************************ -* * -*define _DEBUGPRINT_ -* * -************************************************************************ -* * -* Statement function -* - iTri(i,j)=Max(i,j)*(Max(i,j)-1)/2 + Min(i,j) -* * -************************************************************************ -* * - jOffSO(0)=0 - Do iIrrep = 1, nIrrep-1 - jOffSO(iIrrep)=jOffSO(iIrrep-1)+nBas(iIrrep-1) - End Do - memSO2 = 0 -* -* -* quadruple loop over elements of the basis functions angular -* description. loops are reduced to just produce unique SO integrals -* observe that we will walk through the memory in AOint in a -* sequential way. -* - Shkl = iShell(3).eq.iShell(4) - If (iShell(4).gt.iShell(3)) Then - Call WarningMessage(2,'Error in IndSft_RI_3') - Write (6,*) 'iShell(4).gt.iShell(3)' - Call Abend() - End If -* - j1=0 - Do i2 = 1, iCmp(2) - Do 201 j = 0, nIrrep-1 - ix = 0 - If (iAOtSO(iAO(2)+i2,j)>0) ix = 2**j - jSym(j) = ix -201 Continue - Do i3 = 1, iCmp(3) - Do 301 j = 0, nIrrep-1 - ix = 0 - If (iAOtSO(iAO(3)+i3,j)>0) ix = 2**j - kSym(j) = ix -301 Continue - lCmpMx = iCmp(4) - If (Shkl) lCmpMx = i3 - Do 400 i4 = 1, lCmpMx - Do 401 j = 0, nIrrep-1 - ix = 0 - If (iAOtSO(iAO(4)+i4,j)>0) ix = 2**j - lSym(j) = ix -401 Continue - qkl = i3.eq.i4 -* -* loop over Irreps which are spanned by the basis function. -* again, the loop structure is restricted to ensure unique -* integrals. -* - Do 210 j2 = 0, nIrrep-1 - If (jSym(j2).eq.0) go to 210 - j12 = iEor(j1,j2) -* - Do 310 j3 = 0, nIrrep-1 - If (kSym(j3).eq.0) go to 310 - j4 = iEor(j12,j3) - If (lSym(j4).eq.0) go to 310 - If (Shkl .and. qkl .and. j4.gt.j3) go to 310 -* - memSO2 = memSO2 + 1 - If ( (nSkip(j2+1)+ - & nSkip(j3+1)+nSkip(j4+1) ).ne.0 ) GoTo 310 -* * -************************************************************************ -* * -* Number of auxiliary basis functions in this symmetry block. - mm = iOff(1,j12) - If (mm.eq.0) Go To 310 -* Effective number of valence basis products in this symmetry -* block. - n3C = iOff(3,j12) - If (n3C.eq.0) Go To 310 -* Offset to the symmetry block of this shell pair. - iOff_L = iSSOff(j3,j4) -* * -************************************************************************ -* * -* Compute index within the irrep. Keep the indexation -* of the two basis set sets apart. -* - jSO = iAOtSO(iAO(2)+i2,j2)+iAOst(2)-nBas(j2) - kSO = iAOtSO(iAO(3)+i3,j3)+iAOst(3)+jOffSO(j3) - lSO = iAOtSO(iAO(4)+i4,j4)+iAOst(4)+jOffSO(j4) -* - nijkl = 0 - Do lSOl = lSO, lSO+lBas-1 - iD = iShlSO(lSOl) - iShD = iSOShl(lSOl) - nD = nBasSh(j4,iShD) - Do kSOk = kSO, kSO+kBas-1 - iC = iShlSO(kSOk) - iShC = iSOShl(kSOk) - nC = nBasSh(j3,iShC) -* - If (iShC.eq.iShD) Then - If (j12.eq.0) Then - kl=iTri(iC,iD) - Else If (j3.gt.j4) Then - kl = (iC-1)*nD + iD - Else - kl = (iD-1)*nC + iC - End If - Else - If (iShC.ge.iShD) Then - kl = (iD-1)*nC + iC - Else - kl = (iC-1)*nD + iD - End If - End If -* - Do jSOj = jSO, jSO+jBas-1 - iAux= jSOj - nijkl = nijkl + 1 - AInt=SOint(nijkl,memSO2) -* * -************************************************************************ -* * - If (j12.eq.0) Then - If (kSOk.ge.lSOl) Then - kl_B=(iAux-1)*n3C+kl + iOff_L - TInt(kl_B)=AInt - End If - Else - kl_B=(iAux-1)*n3C+kl + iOff_L - TInt(kl_B)=AInt - End If -* * -************************************************************************ -* * - End Do - End Do - End Do -* -310 Continue -210 Continue -* -400 Continue - End Do - End Do -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(iBas) - Call Unused_logical(Shijij) - Call Unused_integer_array(iSOSym) - End If - End diff -Nru openmolcas-22.02/src/ri_util/indsft_ri_3.F90 openmolcas-22.10/src/ri_util/indsft_ri_3.F90 --- openmolcas-22.02/src/ri_util/indsft_ri_3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/indsft_ri_3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,182 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine IndSft_RI_3(iCmp,iShell,jBas,kBas,lBas,iAO,iAOst,ijkl,SOint,nSOint,TInt,nTInt,iOff,iShlSO,nBasSh,iSOShl,nSO, & + nShell,nSym,iSSOff) +!*********************************************************************** +! object: to sift and index the SO integrals. * +! * +! the indices have been scrambled before calling this routine.* +! Hence we must take special care in order to regain the * +! canonical order. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, Ca * +! april '90 * +! * +!*********************************************************************** + +use Index_Functions, only: iTri +use Basis_Info, only: nBas +use SOAO_Info, only: iAOtSO +use Symmetry_Info, only: Mul, nIrrep +use sort_data, only: nSkip +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iCmp(4), iShell(4), jBas, kBas, lBas, iAO(4), iAOst(4), ijkl, nSOint, nTInt, iOff(3,0:7), nSO, & + iShlSO(nSO), nShell, nSym, nBasSh(0:nSym-1,nShell), iSOShl(nSO), iSSOff(0:nIrrep-1,0:nIrrep-1) +real(kind=wp), intent(in) :: SOint(ijkl,nSOint) +real(kind=wp), intent(inout) :: TInt(nTInt) +integer(kind=iwp) :: i2, i3, i4, iAux, iC, iD, iIrrep, iOff_L, iShC, iShD, ix, j, j1, j12, j2, j3, j4, jOffSO(0:7), jSO, jSOj, & + jSym(0:7), kl, kl_B, kSO, kSOk, kSym(0:7), lCmpMx, lSO, lSOl, lSym(0:7), memSO2, mm, n3C, nC, nD, nijkl +logical(kind=iwp) :: qkl, Shkl + +! * +!*********************************************************************** +! * +!define _DEBUGPRINT_ +! * +!*********************************************************************** +! * +jOffSO(0) = 0 +do iIrrep=1,nIrrep-1 + jOffSO(iIrrep) = jOffSO(iIrrep-1)+nBas(iIrrep-1) +end do +memSO2 = 0 + +! quadruple loop over elements of the basis functions angular +! description. loops are reduced to just produce unique SO integrals +! observe that we will walk through the memory in AOint in a +! sequential way. + +Shkl = iShell(3) == iShell(4) +if (iShell(4) > iShell(3)) then + call WarningMessage(2,'Error in IndSft_RI_3') + write(u6,*) 'iShell(4) > iShell(3)' + call Abend() +end if + +j1 = 0 +do i2=1,iCmp(2) + do j=0,nIrrep-1 + ix = 0 + if (iAOtSO(iAO(2)+i2,j) > 0) ix = 2**j + jSym(j) = ix + end do + do i3=1,iCmp(3) + do j=0,nIrrep-1 + ix = 0 + if (iAOtSO(iAO(3)+i3,j) > 0) ix = 2**j + kSym(j) = ix + end do + lCmpMx = iCmp(4) + if (Shkl) lCmpMx = i3 + do i4=1,lCmpMx + do j=0,nIrrep-1 + ix = 0 + if (iAOtSO(iAO(4)+i4,j) > 0) ix = 2**j + lSym(j) = ix + end do + qkl = i3 == i4 + + ! loop over Irreps which are spanned by the basis function. + ! again, the loop structure is restricted to ensure unique + ! integrals. + + do j2=0,nIrrep-1 + if (jSym(j2) == 0) cycle + j12 = Mul(j1+1,j2+1)-1 + + do j3=0,nIrrep-1 + if (kSym(j3) == 0) cycle + j4 = Mul(j12+1,j3+1)-1 + if (lSym(j4) == 0) cycle + if (Shkl .and. qkl .and. (j4 > j3)) cycle + + memSO2 = memSO2+1 + if ((nSkip(j2+1)+nSkip(j3+1)+nSkip(j4+1)) /= 0) cycle + ! * + !************************************************************* + ! * + ! Number of auxiliary basis functions in this symmetry block. + mm = iOff(1,j12) + if (mm == 0) cycle + ! Effective number of valence basis products in this symmetry block. + n3C = iOff(3,j12) + if (n3C == 0) cycle + ! Offset to the symmetry block of this shell pair. + iOff_L = iSSOff(j3,j4) + ! * + !************************************************************* + ! * + ! Compute index within the irrep. Keep the indexation + ! of the two basis set sets apart. + + jSO = iAOtSO(iAO(2)+i2,j2)+iAOst(2)-nBas(j2) + kSO = iAOtSO(iAO(3)+i3,j3)+iAOst(3)+jOffSO(j3) + lSO = iAOtSO(iAO(4)+i4,j4)+iAOst(4)+jOffSO(j4) + + nijkl = 0 + do lSOl=lSO,lSO+lBas-1 + iD = iShlSO(lSOl) + iShD = iSOShl(lSOl) + nD = nBasSh(j4,iShD) + do kSOk=kSO,kSO+kBas-1 + iC = iShlSO(kSOk) + iShC = iSOShl(kSOk) + nC = nBasSh(j3,iShC) + + if (iShC == iShD) then + if (j12 == 0) then + kl = iTri(iC,iD) + else if (j3 > j4) then + kl = (iC-1)*nD+iD + else + kl = (iD-1)*nC+iC + end if + else + if (iShC >= iShD) then + kl = (iD-1)*nC+iC + else + kl = (iC-1)*nD+iD + end if + end if + + do jSOj=jSO,jSO+jBas-1 + iAux = jSOj + nijkl = nijkl+1 + ! * + !******************************************************* + ! * + if ((j12 /= 0) .or. (kSOk >= lSOl)) then + kl_B = (iAux-1)*n3C+kl+iOff_L + TInt(kl_B) = SOint(nijkl,memSO2) + end if + ! * + !******************************************************* + ! * + end do + end do + end do + + end do + end do + + end do + end do +end do + +return + +end subroutine IndSft_RI_3 diff -Nru openmolcas-22.02/src/ri_util/inicho_ri.f openmolcas-22.10/src/ri_util/inicho_ri.f --- openmolcas-22.02/src/ri_util/inicho_ri.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/inicho_ri.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,423 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Thomas Bondo Pedersen * -************************************************************************ -* IniCho_RI -* -*> @brief -*> Initialize Cholesky environment for RI calculations -*> @author Thomas Bondo Pedersen -*> -*> @details -*> Initialize Cholesky environment for RI calculations. -*> -*> @note -*> Needs a call to ::SetUp_Ints with indexation turned on -*> -*> @param[in] nSkal The number of shells (excl. aux. basis) -*> @param[in] nVec_Aux Number of aux. basis vectors per irrep -*> @param[in] nIrrep Number of irreps -*> @param[in] iTOffs Offset vector -*> @param[in] iShij Index vector of shell pairs -*> @param[in] nShij Number of shell pairs -************************************************************************ - SubRoutine IniCho_RI(nSkal,nVec_Aux,nIrrep,iTOffs,iShij,nShij) - Use Para_Info, Only: Is_Real_Par - use ChoArr, only: iSP2F - use ChoSwp, only: InfRed, InfVec - Implicit None - Integer nSkal, nIrrep, nShij - Integer nVec_Aux(0:nIrrep-1) - Integer iTOffs(3,nIrrep) - Integer iShij(2,nShij) -#include "cholesky.fh" -#include "choprint.fh" -#include "stdalloc.fh" -#if defined (_MOLCAS_MPP_) -#include "choglob.fh" -#endif - - Logical SetDefaultsOnly, Skip_PreScreen, Alloc_Bkm - Integer iDummy, LuOut, iSym, iVec, ijS - Integer iTri, i, j - - iTri(i,j)=max(i,j)*(max(i,j)-3)/2+i+j - -C Set defaults for those parameters that can normally be changed -C through user input to the Cholesky decomposition. -C ----------------------------------------------------------------- - - SetDefaultsOnly = .True. - iDummy = -1 - LuOut = 6 - Call Cho_Inp(SetDefaultsOnly,iDummy,LuOut) - -C Reset Cholesky Threshold for RI -C ------------------------------- - Call Get_thrc_RI(ThrCom) - -C Reset parallel config. -C ---------------------- - - CHO_FAKE_PAR = .False. - Call Cho_ParConf(CHO_FAKE_PAR) - -C Set run mode to "external" (should be irrelevant for RI). -C --------------------------------------------------------- - - RUN_MODE = RUN_EXTERNAL - -C Silence the Cholesky routines. -C ------------------------------ - - iPrint = 0 - -C Set number of shells (excl. aux. basis) in cholesky.fh -C ------------------------------------------------------- - - nShell = nSkal - -C To avoid unnecessary allocations of shell-pair-to-reduced-set -C maps, set decomposition algorithm to 1 ("one-step") and the Seward -C interface to "1" (full shell quadruple storage). Both values are, -C obviously, irrelevant for RI. In parallel runs, use default values -C to avoid warnings being printed in Cho_P_Check. -C ------------------------------------------------------------------ - - If (Is_Real_Par()) Then - Cho_DecAlg = 4 - IfcSew = 2 - Else - Cho_DecAlg = 1 - IfcSew = 1 - End If - -C Change MaxRed to 1 (all vectors have identical dimension, namely -C full => only 1 reduced set). -C ---------------------------------------------------------------- - - MaxRed = 1 - -C Set MaxVec to the largest number of vectors (= number of linearly -C independent auxiliary basis functions). In this way we avoid -C allocating more memory for InfVec than needed. -C ------------------------------------------------------------------ - - MaxVec = nVec_Aux(0) - Do iSym = 1,nIrrep-1 - MaxVec = max(MaxVec,nVec_Aux(iSym)) - End Do - -C Other initializations. Most importantly, allocate InfRed and -C InfVec arrays (defined in choswp.f90). -C We skip diagonal prescreening, as it has already been done. -C Instead, allocate and set the mapping from reduced to full shell -C pairs here. -C ---------------------------------------------------------------- - - nnShl = nShij - Call mma_allocate(iSP2F,nnShl,Label='iSP2F') - Do ijS = 1,nnShl - iSP2F(ijS) = iTri(iShij(1,ijS),iShij(2,ijS)) - End Do - Skip_PreScreen = .True. - Alloc_Bkm = .False. - Call Cho_Init(Skip_PreScreen,Alloc_Bkm) - -C Set number of vectors equal to the number of lin. indep. auxiliary -C basis functions. -C ------------------------------------------------------------------ - - Do iSym = 1,nSym - NumCho(iSym) = nVec_Aux(iSym-1) - End Do -#if defined (_MOLCAS_MPP_) - If (Is_Real_Par()) Then - Call iCopy(nSym,NumCho,1,NumCho_G,1) - Call iZero(myNumCho,nSym) - End If -#endif - -C Do allocations that are normally done during or after the -C computation of the diagonal (since the dimension of the 1st -C reduced set is unknown until the screened diagonal is known). -C ------------------------------------------------------------- - - Call IniCho_RI_Xtras(iTOffs,nIrrep,iShij,nShij) - -C Set start disk addresses. -C ------------------------- - - XnPass = 0 ! it should be zeroed in Cho_Inp, but just in case. - Call Cho_SetAddr(InfRed,InfVec,MaxRed,MaxVec,SIZE(InfVec,2),nSym) - -C Set vector info. -C Parent diagonal is set equal to the vector number, parent pass -C (i.e. reduced set) to 1. -C -------------------------------------------------------------- - - Do iSym = 1,nSym - Do iVec = 1,NumCho(iSym) - Call Cho_SetVecInf(iVec,iSym,iVec,1,1) - End Do - End Do -* - Return - End - SubRoutine IniCho_RI_Xtras(iTOffs,nIrrep,iShij,nShij) - use ChoArr, only: iRS2F, nDimRS - use ChoSwp, only: nnBstRSh, iiBstRSh - use ChoSwp, only: IndRSh, IndRSh_Hidden - use ChoSwp, only: IndRed, IndRed_Hidden - Implicit None - Integer nIrrep, nShij -#include "cholesky.fh" -#include "choorb.fh" -#include "stdalloc.fh" - - Logical DoDummy - - Integer iiBst(8), nnBst(8), iTOffs(3,nIrrep), iShij(2,nShij) - Integer iSym, iCount, nnBstT - - Integer i - -C Define max. dimensions and offsets of the symmetry blocks of the -C integrals matrix. -C ---------------------------------------------------------------- - - iCount = 0 - Do iSym = 1,nSym - iiBst(iSym) = iCount - nnBst(iSym) = iTOffs(3,iSym) - iCount = iCount + nnBst(iSym) - End Do - -C Set dimensions of reduced sets equal to full dimension. -C ------------------------------------------------------- - - Do i = 1,3 - nnBstT=0 - Do iSym = 1,nSym - iiBstR(iSym,i) = iiBst(iSym) - nnBstR(iSym,i) = nnBst(iSym) - nnBstT=nnBstT+nnBstR(iSym,i) - End Do - nnBstRT(i) = nnBstT - End Do - mmBstRT = nnBstRT(1) - -C Allocate index arrays for reduced sets: IndRed and IndRsh. -C ---------------------------------------------------------- - - Call mma_allocate(IndRed_Hidden,nnBstRT(1),3, - & Label='IndRed_Hidden') - IndRed => IndRed_Hidden - Call mma_allocate(IndRSh_Hidden,nnBstRT(1),Label='IndRSh_Hidden') - IndRSh => IndRSh_Hidden - -C Allocate iScr array used by reading routines. -C --------------------------------------------- - - DoDummy = .False. - Call Cho_Allo_iScr(DoDummy) - -C Initialize reduced set dimensions used for reading vectors. -C (Note: here they are all the same - there is one reduced sets!) -C --------------------------------------------------------------- - - Do i = 1,MaxRed - Do iSym = 1,nSym - nDimRS(iSym,i) = nnBstR(iSym,1) - End Do - End Do - -C Allocate and set mapping array from 1st reduced set to full -C storage. -C ----------------------------------------------------------- - - Call mma_allocate(iRS2F,2,nnBstRT(1),Label='iRS2F') - -C Set index arrays corresponding to full storage: -C iiBstRSh, nnBstRSh, IndRed, IndRSh, and iRS2F. -C ----------------------------------------------- - - Call SetChoIndx_RI(iiBstRSh,nnBstRSh, - & IndRed,IndRsh,iRS2F, - & nSym,nnShl,nnBstRT(1),3,2,iShij,nShij) - - Return - End - SubRoutine SetChoIndx_RI(iiBstRSh,nnBstRSh,IndRed,IndRsh,iRS2F, - & I_nSym,I_nnShl,I_mmBstRT,I_3,I_2, - & iShij,nShij) - use ChoArr, only: iSP2F, iBasSh, nBasSh, nBstSh - Implicit Real*8 (a-h,o-z) - Integer iiBstRSh(I_nSym,I_nnShl,I_3), nnBstRSh(I_nSym,I_nnShl,I_3) - Integer IndRed(I_mmBstRT,I_3), IndRsh(I_mmBstRT) - Integer iRS2F(I_2,I_mmBstRT), iShij(2,nShij) -#include "choorb.fh" -#include "cholesky.fh" - - Integer Cho_iSAOSh - External Cho_iSAOSh - - Integer iRS(8) - - MulD2h(i,j)=iEor(i-1,j-1)+1 - iTri(i,j)=max(i,j)*(max(i,j)-3)/2+i+j - -C nnBstRSh(iSym,iSh_ij,1) = #elements in compound sym. iSym of -C shell-pair ab in 1st reduced set. -C IndRSh(jRS): shell-pair to which element jRS of first reduced set -C belongs. -C IndRed(jRS,1): address (without symmetry) in shell-pair of element -C jRS of first reduced set. -C ------------------------------------------------------------------ - - Call iCopy(nSym*nnShl,[0],0,nnBstRSh(1,1,1),1) - Call iCopy(nSym,iiBstR(1,1),1,iRS,1) - Do iSh_ij= 1,nShij - iShla=iShij(1,iSh_ij) - iShlb=iShij(2,iSh_ij) - iShlab=iTri(iShla,iShlb) -C Write (*,*) 'iSh_ij,iShlab,iShla,iShlb=', -C & iSh_ij,iShlab,iShla,iShlb - If (iShlab .ne. iSP2F(iSh_ij)) Then - Call SysAbendMsg('SetChoIndx_RI','SP2F setup error',' ') - End If -* - If (iShla.gt.iShlb) Then -* -* code for shell a > shell b -* - Do iSymb = 1,nSym - Do ibb = 1,nBasSh(iSymb,iShlb) - ib = iBasSh(iSymb,iShlb) + ibb - Do iSyma = 1,nSym - iSym = MulD2h(iSyma,iSymb) - Do iaa = 1,nBasSh(iSyma,iShla) - ia = iBasSh(iSyma,iShla) + iaa - iab = nBstSh(iShla)*(ib-1) + ia - nnBstRSh(iSym,iSh_ij,1) = - & nnBstRSh(iSym,iSh_ij,1) + 1 - iRS(iSym) = iRS(iSym) + 1 - IndRSh(iRS(iSym)) = iShlab - IndRed(iRS(iSym),1) = iab - End Do - End Do - End Do - End Do -* - Else -* -* code for shell a = shell b follows -* - Do ia = 1,nBstSh(iShla) - iSyma = Cho_iSAOSh(ia,iShla) - Do ib = 1,ia - iab = iTri(ia,ib) - iSymb = Cho_iSAOSh(ib,iShlb) - iSym = MulD2h(iSyma,iSymb) - nnBstRSh(iSym,iSh_ij,1) = nnBstRSh(iSym,iSh_ij,1) + 1 - iRS(iSym) = iRS(iSym) + 1 - IndRSh(iRS(iSym)) = iShlab - IndRed(iRS(iSym),1) = iab - End Do - End Do -* - End If - End Do ! iSh_ij - -C Check. -C ------ - - nErr = 0 - Do iSym = 1,nSym - iCount = nnBstRSh(iSym,1,1) - Do iSh_ij = 2,nnShl - iCount = iCount + nnBstRSh(iSym,iSh_ij,1) - End Do - If (iCount .ne. nnBstR(iSym,1)) Then - nErr = nErr + 1 - End If - End Do - If (nErr .ne. 0) Then - Call SysAbendMsg('SetChoIndx_RI','Setup error', - & 'iCount vs. nnBstR') - End If - Do iSym = 1,nSym - If ((iRS(iSym)-iiBstR(iSym,1)) .ne. nnBstR(iSym,1)) Then - nErr = nErr + 1 - End If - End Do - If (nErr .ne. 0) Then - Call SysAbendMsg('SetChoIndx_RI','Setup error','ShP RS1 count') - End If - -C iiBstRSh(iSym,iSh_ij,1) = offset to elements in compound sym. iSym -C of shell-pair ab in 1st reduced set. -C ------------------------------------------------------------------ - - Do iSym = 1,nSym - iiBstRSh(iSym,1,1) = 0 - Do iSh_ij = 2,nnShl - iiBstRSh(iSym,iSh_ij,1) = iiBstRSh(iSym,iSh_ij-1,1) - & + nnBstRSh(iSym,iSh_ij-1,1) - End Do - End Do - -C Check. -C ------ - - nErr = 0 - Do iSym = 1,nSym - Do iSh_ij = 1,nnShl - jRS1 = iiBstR(iSym,1) + iiBstRSh(iSym,iSh_ij,1) + 1 - jRS2 = jRS1 + nnBstRSh(iSym,iSh_ij,1) - 1 - Do jRS = jRS1,jRS2 - If (IndRSh(jRS) .ne. iSP2F(iSh_ij)) Then - nErr = nErr + 1 - End If - End Do - End Do - End Do - If (nErr .ne. 0) Then - Call SysAbendMsg('SetChoIndx_RI','Setup error','IndRSh') - End If - -C Copy index arrays to "locations" 2 and 3. -C Note: IndRed here returns the index in 1st reduced set. -C ------------------------------------------------------- - - Do i = 2,3 - Do jRS = 1,nnBstRT(1) - IndRed(jRS,i) = jRS - End Do - Call iCopy(nSym*nnShl,iiBstRSh(1,1,1),1,iiBstRSh(1,1,i),1) - Call iCopy(nSym*nnShl,nnBstRSh(1,1,1),1,nnBstRSh(1,1,i),1) - End Do - - Call Cho_RStoF(iRS2F,2,nnBstRT(1),1) - - Return - End -************************************************************ -* -************************************************************ - Subroutine Get_thrc_RI(Thr_CD) - use RICD_Info, only: Thrshld_CD - Real*8 Thr_CD - - Thr_CD = Thrshld_CD - - Return - End diff -Nru openmolcas-22.02/src/ri_util/inicho_ri.F90 openmolcas-22.10/src/ri_util/inicho_ri.F90 --- openmolcas-22.02/src/ri_util/inicho_ri.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/inicho_ri.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,172 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Thomas Bondo Pedersen * +!*********************************************************************** +! IniCho_RI +! +!> @brief +!> Initialize Cholesky environment for RI calculations +!> @author Thomas Bondo Pedersen +!> +!> @details +!> Initialize Cholesky environment for RI calculations. +!> +!> @note +!> Needs a call to ::SetUp_Ints with indexation turned on +!> +!> @param[in] nSkal The number of shells (excl. aux. basis) +!> @param[in] nVec_Aux Number of aux. basis vectors per irrep +!> @param[in] nIrrep Number of irreps +!> @param[in] iTOffs Offset vector +!> @param[in] iShij Index vector of shell pairs +!> @param[in] nShij Number of shell pairs +!*********************************************************************** + +subroutine IniCho_RI(nSkal,nVec_Aux,nIrrep,iTOffs,iShij,nShij) + +use Index_Functions, only: iTri +use RICD_Info, only: Thrshld_CD +use Para_Info, only: Is_Real_Par +use ChoArr, only: iSP2F +use ChoSwp, only: InfRed, InfVec +use stdalloc, only: mma_allocate +use Definitions, only: iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nSkal, nIrrep, nVec_Aux(0:nIrrep-1), iTOffs(3,nIrrep), nShij, iShij(2,nShij) +#include "cholesky.fh" +#include "choprint.fh" +#ifdef _MOLCAS_MPP_ +#include "choglob.fh" +#endif +integer(kind=iwp) :: iDummy, ijS, iSym, iVec, LuOut +logical(kind=iwp) :: Alloc_Bkm, SetDefaultsOnly, Skip_PreScreen + +! Set defaults for those parameters that can normally be changed +! through user input to the Cholesky decomposition. +! -------------------------------------------------------------- + +SetDefaultsOnly = .true. +iDummy = -1 +LuOut = u6 +call Cho_Inp(SetDefaultsOnly,iDummy,LuOut) + +! Reset Cholesky Threshold for RI +! ------------------------------- +ThrCom = Thrshld_CD + +! Reset parallel config. +! ---------------------- + +CHO_FAKE_PAR = .false. +call Cho_ParConf(CHO_FAKE_PAR) + +! Set run mode to "external" (should be irrelevant for RI). +! --------------------------------------------------------- + +RUN_MODE = RUN_EXTERNAL + +! Silence the Cholesky routines. +! ------------------------------ + +iPrint = 0 + +! Set number of shells (excl. aux. basis) in cholesky.fh +! ------------------------------------------------------ + +nShell = nSkal + +! To avoid unnecessary allocations of shell-pair-to-reduced-set +! maps, set decomposition algorithm to 1 ("one-step") and the Seward +! interface to "1" (full shell quadruple storage). Both values are, +! obviously, irrelevant for RI. In parallel runs, use default values +! to avoid warnings being printed in Cho_P_Check. +! ------------------------------------------------------------------ + +if (Is_Real_Par()) then + Cho_DecAlg = 4 + IfcSew = 2 +else + Cho_DecAlg = 1 + IfcSew = 1 +end if + +! Change MaxRed to 1 (all vectors have identical dimension, namely +! full => only 1 reduced set). +! ---------------------------------------------------------------- + +MaxRed = 1 + +! Set MaxVec to the largest number of vectors (= number of linearly +! independent auxiliary basis functions). In this way we avoid +! allocating more memory for InfVec than needed. +! ----------------------------------------------------------------- + +MaxVec = nVec_Aux(0) +do iSym=1,nIrrep-1 + MaxVec = max(MaxVec,nVec_Aux(iSym)) +end do + +! Other initializations. Most importantly, allocate InfRed and +! InfVec arrays (defined in choswp.f90). +! We skip diagonal prescreening, as it has already been done. +! Instead, allocate and set the mapping from reduced to full shell +! pairs here. +! ---------------------------------------------------------------- + +nnShl = nShij +call mma_allocate(iSP2F,nnShl,Label='iSP2F') +do ijS=1,nnShl + iSP2F(ijS) = iTri(iShij(1,ijS),iShij(2,ijS)) +end do +Skip_PreScreen = .true. +Alloc_Bkm = .false. +call Cho_Init(Skip_PreScreen,Alloc_Bkm) + +! Set number of vectors equal to the number of lin. indep. auxiliary +! basis functions. +! ------------------------------------------------------------------ + +NumCho(1:nSym) = nVec_Aux(0:nSym-1) +#ifdef _MOLCAS_MPP_ +if (Is_Real_Par()) then + NumCho_g(1:nSym) = NumCho(1:nSym) + myNumCho(1:nSym) = 0 +end if +#endif + +! Do allocations that are normally done during or after the +! computation of the diagonal (since the dimension of the 1st +! reduced set is unknown until the screened diagonal is known). +! ------------------------------------------------------------- + +call IniCho_RI_Xtras(iTOffs,nIrrep,iShij,nShij) + +! Set start disk addresses. +! ------------------------- + +XnPass = 0 ! it should be zeroed in Cho_Inp, but just in case. +call Cho_SetAddr(InfRed,InfVec,MaxRed,MaxVec,size(InfVec,2),nSym) + +! Set vector info. +! Parent diagonal is set equal to the vector number, parent pass +! (i.e. reduced set) to 1. +! -------------------------------------------------------------- + +do iSym=1,nSym + do iVec=1,NumCho(iSym) + call Cho_SetVecInf(iVec,iSym,iVec,1,1) + end do +end do + +return + +end subroutine IniCho_RI diff -Nru openmolcas-22.02/src/ri_util/inicho_ri_xtras.F90 openmolcas-22.10/src/ri_util/inicho_ri_xtras.F90 --- openmolcas-22.02/src/ri_util/inicho_ri_xtras.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/inicho_ri_xtras.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,87 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Thomas Bondo Pedersen * +!*********************************************************************** + +subroutine IniCho_RI_Xtras(iTOffs,nIrrep,iShij,nShij) + +use ChoArr, only: iRS2F, nDimRS +use ChoSwp, only: iiBstRSh, IndRed, IndRed_Hidden, IndRSh, IndRSh_Hidden, nnBstRSh +use stdalloc, only: mma_allocate +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: nIrrep, iTOffs(3,nIrrep), nShij, iShij(2,nShij) +#include "cholesky.fh" +integer(kind=iwp) :: i, iCount, iiBst(8), iSym, nnBst(8), nnBstT +logical(kind=iwp) :: DoDummy + +! Define max. dimensions and offsets of the symmetry blocks of the +! integrals matrix. +! ---------------------------------------------------------------- + +iCount = 0 +do iSym=1,nSym + iiBst(iSym) = iCount + nnBst(iSym) = iTOffs(3,iSym) + iCount = iCount+nnBst(iSym) +end do + +! Set dimensions of reduced sets equal to full dimension. +! ------------------------------------------------------- + +do i=1,3 + nnBstT = 0 + do iSym=1,nSym + iiBstR(iSym,i) = iiBst(iSym) + nnBstR(iSym,i) = nnBst(iSym) + nnBstT = nnBstT+nnBstR(iSym,i) + end do + nnBstRT(i) = nnBstT +end do +mmBstRT = nnBstRT(1) + +! Allocate index arrays for reduced sets: IndRed and IndRsh. +! ---------------------------------------------------------- + +call mma_allocate(IndRed_Hidden,nnBstRT(1),3,Label='IndRed_Hidden') +IndRed => IndRed_Hidden +call mma_allocate(IndRSh_Hidden,nnBstRT(1),Label='IndRSh_Hidden') +IndRSh => IndRSh_Hidden + +! Allocate iScr array used by reading routines. +! --------------------------------------------- + +DoDummy = .false. +call Cho_Allo_iScr(DoDummy) + +! Initialize reduced set dimensions used for reading vectors. +! (Note: here they are all the same - there is one reduced sets!) +! --------------------------------------------------------------- + +do i=1,MaxRed + nDimRS(1:nSym,i) = nnBstR(1:nSym,1) +end do + +! Allocate and set mapping array from 1st reduced set to full storage. +! -------------------------------------------------------------------- + +call mma_allocate(iRS2F,2,nnBstRT(1),Label='iRS2F') + +! Set index arrays corresponding to full storage: +! iiBstRSh, nnBstRSh, IndRed, IndRSh, and iRS2F. +! ----------------------------------------------- + +call SetChoIndx_RI(iiBstRSh,nnBstRSh,IndRed,IndRsh,iRS2F,nSym,nnShl,nnBstRT(1),iShij,nShij) + +return + +end subroutine IniCho_RI_Xtras diff -Nru openmolcas-22.02/src/ri_util/init_tsk2.F90 openmolcas-22.10/src/ri_util/init_tsk2.F90 --- openmolcas-22.02/src/ri_util/init_tsk2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/init_tsk2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,39 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Init_Tsk2(id,mTask,jOpt,List) + +use RI_glob, only: TskList, iOpt, iRsv, nTask +use stdalloc, only: mma_allocate +use Definitions, only: iwp, u6 + +implicit none +integer(kind=iwp), intent(out) :: id +integer(kind=iwp), intent(in) :: mTask, jOpt, List(*) ! either nTask or 0 long + +nTask = mTask +iOpt = jOpt +if (iOpt == 0) then + call Init_Tsk(id,nTask) +else if (iOpt == 1) then + call mma_allocate(TskList,nTask,Label='TskList') + TskList(1:nTask) = List(1:nTask) + id = 0 + iRsv = 1 +else + call WarningMessage(2,'Error in Init_Tsk2') + write(u6,*) 'Init_Tsk2: illegal iOpt value!' + call Abend() +end if + +return + +end subroutine Init_Tsk2 diff -Nru openmolcas-22.02/src/ri_util/in_place_diag.F90 openmolcas-22.10/src/ri_util/in_place_diag.F90 --- openmolcas-22.02/src/ri_util/in_place_diag.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/in_place_diag.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,31 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine In_place_Diag(Buff,nBuff,iBs,iBe) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nBuff, iBs, iBe +real(kind=wp), intent(inout) :: Buff(nBuff,iBs:iBe) +integer(kind=iwp) :: i, j + +!call RecPrt('Buff',' ',Buff,nBuff,iBe-iBs+1) +do j=iBs,iBe + do i=iBs,j-1 + Buff(j,i) = Buff(i,j) + end do +end do +!call RecPrt('Buff',' ',Buff,nBuff,iBe-iBs+1) + +return + +end subroutine In_place_Diag diff -Nru openmolcas-22.02/src/ri_util/in_place_square.F90 openmolcas-22.10/src/ri_util/in_place_square.F90 --- openmolcas-22.02/src/ri_util/in_place_square.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/in_place_square.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,32 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine In_place_Square(Buff,nBuff) + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nBuff +real(kind=wp), intent(inout) :: Buff(nBuff,nBuff) +integer(kind=iwp) :: i, j + +!call RecPrt('Buff',' ',Buff,nBuff,nBuff) +do j=1,nBuff + do i=1,j-1 + Buff(j,i) = Buff(i,j) + end do +end do +!call RecPrt('Buff',' ',Buff,nBuff,nBuff) +!write(u6,'(10F10.3)') (Buff(i,i),i=1,nBuff) + +return + +end subroutine In_place_Square diff -Nru openmolcas-22.02/src/ri_util/integral_RI_2.f openmolcas-22.10/src/ri_util/integral_RI_2.f --- openmolcas-22.02/src/ri_util/integral_RI_2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/integral_RI_2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,47 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - SubRoutine Integral_RI_2(iCmp,iShell,MapOrg, - & iBas,jBas,kBas,lBas,kOp, - & Shijij,IJeqKL,iAO,iAOst,ijkl, - & AOInt,SOInt,nSOint, - & iSOSym,nSkal,nSOs, - & TInt,nTInt,itOffs,nSym) - use Wrj12 -* calls the proper routines IndSft/PLF -* if IntOrd_jikl==.TRUE. integral order within symblk: jikl -* else integral order within symblk: ijkl - Implicit Real*8 (A-H,O-Z) -* - Real*8 AOInt(*), SOInt(*), TInt(nTInt) - Integer iCmp(4), iShell(4), iAO(4), iAOst(4), kOp(4), - & iSOSym(2,nSOs), - & itOffs(0:nSym-1,0:nSym-1,0:nSym-1), MapOrg(4) - Logical Shijij,IJeqKL -* - If (nSym==1) Then - Call PLF_RI_2(AOInt,ijkl,iCmp(1),iCmp(2),iCmp(3),iCmp(4), - & iShell,iAO,iAOst,Shijij.and.IJeqKL, - & iBas,jBas,kBas,lBas,kOp,TInt,nTInt, - & SO2Ind,iOffA,nSOs) - Else - Call IndSft_RI_2(iCmp,iShell, - & iBas,jBas,kBas,lBas,Shijij, - & iAO,iAOst,ijkl,SOInt,nSOint,iSOSym,nSOs, - & TInt,nTInt,iTOffs,SO2Ind,iOffA) - End If -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer_array(MapOrg) - Call Unused_integer(nSkal) - End If - End diff -Nru openmolcas-22.02/src/ri_util/integral_ri_2.F90 openmolcas-22.10/src/ri_util/integral_ri_2.F90 --- openmolcas-22.02/src/ri_util/integral_ri_2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/integral_ri_2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,43 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Integral_RI_2( & +# define _CALLING_ +# include "int_wrout_interface.fh" + ) +! calls the proper routines IndSft/PLF +! if IntOrd_jikl == .true. integral order within symblk: jikl +! else integral order within symblk: ijkl + +use RI_glob, only: iOffA, SO2Ind +use Definitions, only: wp, iwp + +implicit none +#include "int_wrout_interface.fh" + +#include "macros.fh" +unused_var(MapOrg) +unused_var(iBas) +unused_var(kBas) +unused_var(IJeqKL) +unused_var(iSOSym) +unused_var(nSkal) +unused_var(itOffs) + +if (mSym == 1) then + call PLF_RI_2(AOInt,ijkl,iCmp(2),iCmp(4),iAO,iAOst,jBas,lBas,kOp,TInt,nTInt,SO2Ind,iOffA,nSOs) +else + call IndSft_RI_2(iCmp,iShell,jBas,lBas,Shijij,iAO,iAOst,ijkl,SOInt,nSOint,nSOs,TInt,nTInt,SO2Ind,iOffA) +end if + +return + +end subroutine Integral_RI_2 diff -Nru openmolcas-22.02/src/ri_util/integral_RI_3.f openmolcas-22.10/src/ri_util/integral_RI_3.f --- openmolcas-22.02/src/ri_util/integral_RI_3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/integral_RI_3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,92 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - SubRoutine Integral_RI_3(iCmp,iShell,MapOrg, - & iBas,jBas,kBas,lBas,kOp, - & Shijij,IJeqKL,iAO,iAOst,ijkl, - & AOInt,SOInt,nSOint, - & iSOSym,nSkal,nSOs, - & TInt,nTInt,itOffs,nSym) -* calls the proper routines IndSft/PLF -* if IntOrd_jikl==.TRUE. integral order within symblk: jikl -* else integral order within symblk: ijkl - Use RICD_Info, only: LDF - use j12 - Implicit Real*8 (A-H,O-Z) -* - Real*8 AOInt(*), SOInt(*), TInt(nTInt) - Integer iCmp(4), iShell(4), iAO(4), - & iAOst(4), kOp(4), iSOSym(2,nSOs), - & itOffs(0:nSym-1,0:nSym-1,0:nSym-1), MapOrg(4) - Logical Shijij,IJeqKL -* * -************************************************************************ -* * - If (LDF) Then -* * -************************************************************************ -* * - If (nSym==1) Then - Call PLF_LDF_3(AOInt,ijkl,iCmp(1),iCmp(2),iCmp(3),iCmp(4), - & iShell,iAO,iAOst,Shijij.and.IJeqKL, - & iBas,jBas,kBas,lBas,kOp, - & TInt,nTInt,iTOffs, - & ShlSO,nBasSh, - & SOShl,nSO,nSkal_Valence,nSym, - & iSSOff(0,0,klS)) - Else - Call WarningMessage(2,'Not implemented yet!') - Call Abend() -C Call IndSft_RI_3(iCmp,iShell, -C & iBas,jBas,kBas,lBas,Shijij, -C & iAO,iAOst,ijkl,SOInt,nSOint,iSOSym,nSOs, -C & TInt,nTInt,iTOffs, -C & ShlSO,nBasSh, -C & SOShl,nSO,nSkal_Valence,nSym, -C & iSSOff(:,:,klS)) - End If -* * -************************************************************************ -* * - Else -* * -************************************************************************ -* * - If (nSym==1) Then - Call PLF_RI_3(AOInt,ijkl,iCmp(1),iCmp(2),iCmp(3),iCmp(4), - & iShell,iAO,iAOst,Shijij.and.IJeqKL, - & iBas,jBas,kBas,lBas,kOp, - & TInt,nTInt,iTOffs, - & ShlSO,nBasSh, - & SOShl,nSO,nSkal_Valence,nSym, - & iSSOff(0,0,klS)) - Else - Call IndSft_RI_3(iCmp,iShell, - & iBas,jBas,kBas,lBas,Shijij, - & iAO,iAOst,ijkl,SOInt,nSOint,iSOSym,nSOs, - & TInt,nTInt,iTOffs, - & ShlSO,nBasSh, - & SOShl,nSO,nSkal_Valence,nSym, - & iSSOff(:,:,klS)) - End If -* * -************************************************************************ -* * - End If -* * -************************************************************************ -* * - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer_array(MapOrg) - Call Unused_integer(nSkal) - End If - End diff -Nru openmolcas-22.02/src/ri_util/integral_ri_3.F90 openmolcas-22.10/src/ri_util/integral_ri_3.F90 --- openmolcas-22.02/src/ri_util/integral_ri_3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/integral_ri_3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,71 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Integral_RI_3( & +# define _CALLING_ +# include "int_wrout_interface.fh" + ) +! calls the proper routines IndSft/PLF +! if IntOrd_jikl == .true. integral order within symblk: jikl +! else integral order within symblk: ijkl + +use RICD_Info, only: LDF +use RI_glob, only: iSSOff, nBasSh, klS, nSkal_Valence, nSO, SOShl, ShlSO +use Definitions, only: wp, iwp + +implicit none +#include "int_wrout_interface.fh" + +#include "macros.fh" +unused_var(MapOrg) +unused_var(iSOSym) +unused_var(nSkal) + +! * +!*********************************************************************** +! * +if (LDF) then + ! * + !********************************************************************* + ! * + if (mSym == 1) then + call PLF_LDF_3(AOInt,ijkl,iCmp(1),iCmp(2),iCmp(3),iCmp(4),iShell,iAO,iAOst,Shijij .and. IJeqKL,iBas,jBas,kBas,lBas,kOp,TInt, & + nTInt,iTOffs,ShlSO,nBasSh,SOShl,nSO,nSkal_Valence,mSym,iSSOff(0,0,klS)) + else + call WarningMessage(2,'Not implemented yet!') + call Abend() + !call IndSft_RI_3(iCmp,iShell,iBas,jBas,kBas,lBas,Shijij,iAO,iAOst,ijkl,SOInt,nSOint,iSOSym,nSOs,TInt,nTInt,iTOffs,ShlSO, & + ! nBasSh,SOShl,nSO,nSkal_Valence,mSym,iSSOff(:,:,klS)) + end if + ! * + !********************************************************************* + ! * +else + ! * + !********************************************************************* + ! * + if (mSym == 1) then + call PLF_RI_3(AOInt,ijkl,iCmp(2),iCmp(3),iCmp(4),iShell,iAO,iAOst,jBas,kBas,lBas,kOp,TInt,nTInt,iTOffs,ShlSO,nBasSh,SOShl,nSO, & + nSkal_Valence,mSym,iSSOff(0,0,klS)) + else + call IndSft_RI_3(iCmp,iShell,jBas,kBas,lBas,iAO,iAOst,ijkl,SOInt,nSOint,TInt,nTInt,iTOffs,ShlSO,nBasSh,SOShl,nSO, & + nSkal_Valence,mSym,iSSOff(:,:,klS)) + end if + ! * + !********************************************************************* + ! * +end if +! * +!*********************************************************************** +! * +return + +end subroutine Integral_RI_3 diff -Nru openmolcas-22.02/src/ri_util/integral_ricd.f openmolcas-22.10/src/ri_util/integral_ricd.f --- openmolcas-22.02/src/ri_util/integral_ricd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/integral_ricd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,46 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - SubRoutine Integral_RICD(iCmp,iShell,MapOrg, - & iBas,jBas,kBas,lBas,kOp, - & Shijij,IJeqKL,iAO,iAOst,ijkl, - & AOInt,SOInt,nSOint, - & iSOSym,nSkal,nSOs, - & TInt,nTInt,iTOffs,nSym) - Implicit Real*8 (A-H,O-Z) -* - Real*8 AOInt(*), SOInt(*), TInt(nTInt) - Integer iCmp(4), iShell(4), iAO(4), - & iAOst(4), kOp(4), iSOSym(2,nSOs), - & iTOffs(0:7,0:7,0:7), MapOrg(4) - Logical Shijij,IJeqKL -* - If (nSym==1) Then - Call PLF_RICD(AOInt,ijkl,iCmp(1),iCmp(2),iCmp(3),iCmp(4), - & iShell,iAO,iAOst,Shijij.and.IJeqKL, - & iBas,jBas,kBas,lBas,kOp,TInt, - & iTOffs(1,0,0),iTOffs(2,0,0),iTOffs(0,0,0), - & iTOffs(3,0,0),iTOffs(4,0,0)) - Else - Write (6,*) 'Integral_RICD: fatal error!' - Call Abend() - End If -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer_array(MapOrg) - Call Unused_real_array(SOInt) - Call Unused_integer(nSOint) - Call Unused_integer_array(iSOSym) - Call Unused_integer(nSkal) - Call Unused_integer(nSym) - End If - End diff -Nru openmolcas-22.02/src/ri_util/integral_ricd.F90 openmolcas-22.10/src/ri_util/integral_ricd.F90 --- openmolcas-22.02/src/ri_util/integral_ricd.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/integral_ricd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,43 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Integral_RICD( & +# define _CALLING_ +# include "int_wrout_interface.fh" + ) + +use Definitions, only: wp, iwp, u6 + +implicit none +#include "int_wrout_interface.fh" + +#include "macros.fh" +unused_var(iShell) +unused_var(MapOrg) +unused_var(Shijij) +unused_var(IJeqKL) +unused_var(SOInt(1)) +unused_var(nSOint) +unused_var(iSOSym) +unused_var(nSkal) + +if (mSym == 1) then + ! note that iTOffs is being abused for something else + call PLF_RICD(AOInt,ijkl,iCmp(1),iCmp(2),iCmp(3),iCmp(4),iAO,iAOst,iBas,jBas,kBas,lBas,kOp,TInt,iTOffs(0,0,1),iTOffs(0,0,2), & + iTOffs(0,0,0),iTOffs(0,0,3),iTOffs(0,0,4)) +else + write(u6,*) 'Integral_RICD: fatal error!' + call Abend() +end if + +return + +end subroutine Integral_RICD diff -Nru openmolcas-22.02/src/ri_util/inv_cho_factor.f openmolcas-22.10/src/ri_util/inv_cho_factor.f --- openmolcas-22.02/src/ri_util/inv_cho_factor.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/inv_cho_factor.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,333 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 2006, Francesco Aquilante * -* 2014, Thomas Bondo Pedersen * -************************************************************************ -* INV_CHO_FACTOR -* -*> @brief -*> Evaluation of the inverse Cholesky factor (\f$ Q \f$) of a SPD matrix (\f$ A \f$) -*> by using a modified Gram--Schmidt orthonormalization of a set -*> of unit vectors -*> @author F. Aquilante (Nov. 2006) -*> @modified_by T.B. Pedersen (2014) Change criterion for too negative norm -*> -*> @details -*> Evaluation of the inverse Cholesky factor (\f$ Q \f$) of a SPD matrix (\f$ A \f$) -*> by using a modified Gram--Schmidt orthonormalization of a set of unit vectors \f$ V: V(i,k)=\delta_{ik} \f$): -*> -*> \code -*> For k=1,dim(A) -*> Qu_k = V_k - sum_j=1^k-1 (Q_j^T * A * V_k) * Q_j -*> = V_k - sum_j=1^k-1 (Q_j^T * A_k) * Q_j -*> Q_k = Qu_k / sqrt(Qu_k^T * A_k * Qu_k) -*> \endcode -*> -*> The result is such that the inverse of A is Cholesky decomposed as -*> -*> \f[ A^{-1} = Q Q^\text{T} \f] -*> (\f$ Q \f$ is a full-rank upper triangular matrix) -*> -*> or in general (also for rank deficient \f$ A \f$) such that -*> -*> \f[ Q^\text{T} A Q = I \f] -*> -*> The inverse Cholesky factor is in general *NOT UNIQUE!!* -*> Therefore, and for stability reason, a full pivoting of the -*> initial matrix \f$ A \f$ would be advisable. -*> -*> Worth of mention is the fact that the lower triangular -*> matrix L such that -*> -*> \f[ A = L L^\text{T} \f] -*> (Cholesky decomposition of \f$ A \f$) -*> -*> can be computed as: \f$ L = A Q \f$ -*> -*> @side_effects -*> In output \p A_k is returned in a PACKED form (i.e. off-diagonal elements are -*> scaled by two); the latter is the form in which it should be stored as column of \p Am. -*> In case of detected linear dependence, the \p Q_k array is returned as zeros! -*> -*> @note -*> Triangular storage must be used for the \f$ Q \f$-matrix! -*> -*> @param[in,out] A_k \p kCol -th column of \f$ A \f$ (min. size \p kCol) -*> @param[in] kCol index of the column/vector -*> @param[in] Am in-core part of the matrix \f$ A \f$ (triangular storage) -*> @param[in] Qm in-core matrix whose columns are the orthonormal vectors (triangular storage) -*> @param[in] nMem max number of columns of \p Qm (and also of \p Am) kept in core -*> @param[in] lu_A file unit where the \f$ A \f$-matrix is stored -*> @param[in] lu_Q file unit where the \f$ Q \f$-matrix is stored -*> @param[in] Scr scratch space used for reading out-of-core columns of \p Qm and \p Am -*> @param[in] lScr size of the scratch space (≥ \p kCol-1 or ``0`` iff in-core) -*> @param[in] Z auxiliary array of min. size \p kCol (always needed) -*> @param[in] X auxiliary array of min. size \p kCol-1 (needed only for the out-of-core case) -*> @param[in] thr threshold for linear dependence -*> @param[out] Q_k the \p kCol -th column of \p Qm (min. size \p kCol) -*> @param[out] lindep integer indicating detected linear dependence (= ``1`` iff found lin dep, else = ``0``) -************************************************************************ - SUBROUTINE INV_CHO_FACTOR(A_k,kCol,Am,Qm,nMem,lu_A,lu_Q,Scr,lScr, - & Z,X,thr,Q_k,lindep) - -#ifdef _MOLCAS_MPP_ - Use Para_Info, Only: MyRank, nProcs, Is_Real_Par -#endif - Implicit Real*8 (a-h,o-z) - Integer kCol, nMem, lu_A, lu_Q, lScr, lindep - Real*8 A_k(*), Am(*), Qm(*), Scr(*), Z(*), X(*), Q_k(*) - Real*8 thr -#include "warnings.h" - Parameter ( two = 2.0d0, one = 1.0d0, zero = 0.0d0 ) - Parameter ( thr_neg = -1.0d-8 ) -********************************************************************** - If (thr .lt. zero) Then - Call WarningMessage(2,'Error in Inv_Cho_Factor') - write(6,*)'thr must be .ge. zero' - Call Quit(_RC_CHO_LOG_) - EndIf - - lindep = 0 - - If (kCol .le. nMem) Then -* -* Compute scalar product of A_k with previous vectors -* --------------------------------------------------- - jp=1 - Do j=1,kCol-1 - Z(j)=ddot_(j,A_k(1),1,Qm(jp),1) - jp = jp + j - End Do -C Call RecPrt('A_k*Qm',' ',Z,1,kCol) -* -* Compute unnormalized k-th vector -* --------------------------------- -C SVC: this piece of code was computing Q_k = - Qm * Z, where Q_k and Z -C are vectors of length kCol-1, and Qm is a matrix in triangular storage -C with column-wise layout: -C |Q_k(1) | |Qm(1,1) Qm(1,2) ... Qm(1,kCol-1) | |Z(1) | -C |Q_k(2) | | Qm(2,2) ... Qm(2,kCol-1) | |Z(2) | -C | ... | = - | ... ... | * |... | -C | ... | | | |... | -C |Q_k(kCol-1)| | Qm(kCol-1,kCol-1)| |Z(kCol-1)| -C In order to improve performance, I've used the DTPMV routine from -C BLAS. For parallel processes, we will block up the triangular matrix -C and divide the blocks over the processes, using either DTPMV or DGEMV -C on the blocks (depending if it is a diagonal or off-diagonal block). - - Call FZero(Q_k,kCol-1) -#ifdef _MOLCAS_MPP_ - if (is_real_par().and.kCol.ge.500) then -C SVC: the best way would probably be to chop up the triangular matrix -C into blocks, and then call DTPMV/DGEMV on those blocks. To keep things -C simple, I've just used a series of DAXPY's on each column of the -C triangular matrix, this should be sufficient (for now). - DO J=1+MYRANK,KCOL-1,NPROCS - IJ=(J*(J-1))/2+1 - CALL DAXPY_(J,-Z(J),Qm(IJ),1,Q_k,1) - END DO - Call GAdGOp(Q_k,kCol-1,'+') - else - CALL DAXPY_(kCol-1,-1.0D0,Z,1,Q_k,1) - CALL DTPMV('U','N','N',kCol-1,Qm,Q_k,1) - end if -#else - CALL DAXPY_(kCol-1,-1.0D0,Z,1,Q_k,1) - CALL DTPMV('U','N','N',kCol-1,Qm,Q_k,1) -#endif - Q_k(kCol) = one -* -* -* Normalize k-th vector : ||Q_k|| = Q_k^T * A * Q_k -* ---------------------------------------------------- - - call dscal_(kCol-1,two,A_k(1),1) ! packing of A_k - - Z(kCol)=ddot_(kCol,A_k(1),1,Q_k(1),1) !contrib fr k-th col of A - - jp=1 - Do j=1,kCol-1 ! contrib. from previous columns of A - Z(j)=ddot_(j,Q_k(1),1,Am(jp),1) - jp = jp + j - End Do - - xnorm=ddot_(kCol,Z(1),1,Q_k(1),1) - - If (xnorm.ge.thr) Then - - xnorm=one/sqrt(xnorm) - call dscal_(kCol,xnorm,Q_k(1),1) - -C-tbp: use fixed criterion for too negative diagonal -C-tbp ElseIf (xnorm.gt.zero .or. -xnorm.le.1.0d1*thr) Then - ElseIf (xnorm.gt.thr_neg) Then - - lindep = 1 - Call Fzero(Q_k(1),kCol) - - Else - - Call WarningMessage(2,'Error in Inv_Cho_Factor') - write(6,*)'INV_CHO_FACTOR: too-negative value for norm(Q_k).' - write(6,*)'INV_CHO_FACTOR: xnorm = ',xnorm - Call Quit(_RC_CHO_RUN_) - - EndIf - - -* * -************************************************************************ -* * - Else ! the first nMem columns of Q are in memory -* * -************************************************************************ -* * - - If (lScr .lt. kCol-1) Then - Call WarningMessage(2,'Error in Inv_Cho_Factor') - write(6,*)'lScr must be .ge. kCol-1' - Call Quit(_RC_CHO_LOG_) - EndIf - - Call FZero(X(1),kCol-1) -* -* Compute scalar product of A_k with in-core previous vectors -* ----------------------------------------------------------- - jp=1 - Do j=1,nMem - Z(j)=ddot_(j,A_k(1),1,Qm(jp),1) - jp = jp + j - End Do -* -* Batch for the out-of-core previous vectors -*-------------------------------------------- - kdone = nMem - lQcol = (kCol-1)*kCol/2 ! length up to kCol-1 - Do while ( kdone .lt. kCol-1 ) - - lQdone = kdone*(kdone+1)/2 - lQdone_=lQdone - lQread = lQcol - lQdone - - kread = kCol-1 - Do while ( lQread .gt. lScr ) - lQread = lQread - kread - kread = kread - 1 - End Do - - Call ddafile(lu_Q,2,Scr(1),lQread,lQdone_) ! read - - jp=1 - Do j=kdone+1,kread - Z(j)=ddot_(j,A_k(1),1,Scr(jp),1) - jp = jp + j - End Do -* -* Store an out-of-core intermediate for the Q-vectors -*----------------------------------------------------- - Do i=1,kread - sprev=zero - kstart = Max(i,kdone+1) ! (j.ge.i .and. j_out_of_core) - Do j=kstart,kread - ij = j*(j-1)/2 + i - lQdone - sprev = sprev + Z(j)*Scr(ij) - End Do - X(i) = X(i) + sprev - End Do - - kdone = kread - - End Do -C Call RecPrt('A_k*Qm',' ',Z,1,kCol) -* -* Compute unnormalized k-th vector -* --------------------------------- - Do i=1,kCol-1 - sprev = X(i) ! out-of-core contrib. - Do j=i,nMem - ij = j*(j-1)/2 + i - sprev = sprev + Z(j)*Qm(ij) - End Do - Q_k(i) = - sprev - End Do - Q_k(kCol) = one -* -* -* Normalize k-th vector : ||Q_k|| = Q_k^T * A * Q_k -* ---------------------------------------------------- - - call dscal_(kCol-1,two,A_k(1),1) ! packing of A_k - - Z(kCol)=ddot_(kCol,A_k(1),1,Q_k(1),1) !contrib fr k-th col of A -* -* Batch for the out-of-core previous vectors -*-------------------------------------------- - kdone = nMem - lQcol = (kCol-1)*kCol/2 ! length up to kCol-1 - Do while ( kdone .lt. kCol-1 ) - - lQdone = kdone*(kdone+1)/2 - lQread = lQcol - lQdone - - kread = kCol-1 - Do while ( lQread .gt. lScr ) - lQread = lQread - kread - kread = kread - 1 - End Do -* -* Out-of-core intermediate to be used for the normalization factor -*------------------------------------------------------------------ - Call ddafile(lu_A,2,Scr(1),lQread,lQdone) ! read - - jp=1 - Do j=kdone+1,kread - Z(j)=ddot_(j,Q_k(1),1,Scr(jp),1) - jp = jp + j - End Do - - kdone = kread - - End Do - - jp=1 - Do j=1,nMem ! contrib. from in-core previous columns of A - Z(j)=ddot_(j,Q_k(1),1,Am(jp),1) - jp = jp + j - End Do - - xnorm=ddot_(kCol,Z(1),1,Q_k(1),1) - - If (xnorm.ge.thr) Then - - xnorm=one/sqrt(xnorm) - call dscal_(kCol,xnorm,Q_k(1),1) - -C-tbp: use fixed criterion for too negative diagonal -C-tbp ElseIf (xnorm.gt.zero .or. -xnorm.le.1.0d1*thr) Then - ElseIf (xnorm.gt.thr_neg) Then - - lindep = 1 - Call Fzero(Q_k(1),kCol) - - Else - - Call WarningMessage(2,'Error in Inv_Cho_Factor') - write(6,*)'INV_CHO_FACTOR: too-negative value for norm(Q_k).' - write(6,*)'INV_CHO_FACTOR: xnorm = ',xnorm - Call Quit(_RC_CHO_RUN_) - - EndIf - - - EndIf - - Return - End diff -Nru openmolcas-22.02/src/ri_util/inv_cho_factor.F90 openmolcas-22.10/src/ri_util/inv_cho_factor.F90 --- openmolcas-22.02/src/ri_util/inv_cho_factor.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/inv_cho_factor.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,340 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 2006, Francesco Aquilante * +! 2014, Thomas Bondo Pedersen * +!*********************************************************************** +! INV_CHO_FACTOR +! +!> @brief +!> Evaluation of the inverse Cholesky factor (\f$ Q \f$) of a SPD matrix (\f$ A \f$) +!> by using a modified Gram--Schmidt orthonormalization of a set +!> of unit vectors +!> @author F. Aquilante (Nov. 2006) +!> @modified_by T.B. Pedersen (2014) Change criterion for too negative norm +!> +!> @details +!> Evaluation of the inverse Cholesky factor (\f$ Q \f$) of a SPD matrix (\f$ A \f$) +!> by using a modified Gram--Schmidt orthonormalization of a set of unit vectors \f$ V: V(i,k)=\delta_{ik} \f$): +!> +!> \code +!> For k=1,dim(A) +!> Qu_k = V_k - sum_j=1^k-1 (Q_j^T * A * V_k) * Q_j +!> = V_k - sum_j=1^k-1 (Q_j^T * A_k) * Q_j +!> Q_k = Qu_k / sqrt(Qu_k^T * A_k * Qu_k) +!> \endcode +!> +!> The result is such that the inverse of A is Cholesky decomposed as +!> +!> \f[ A^{-1} = Q Q^\text{T} \f] +!> (\f$ Q \f$ is a full-rank upper triangular matrix) +!> +!> or in general (also for rank deficient \f$ A \f$) such that +!> +!> \f[ Q^\text{T} A Q = I \f] +!> +!> The inverse Cholesky factor is in general *NOT UNIQUE!!* +!> Therefore, and for stability reason, a full pivoting of the +!> initial matrix \f$ A \f$ would be advisable. +!> +!> Worth of mention is the fact that the lower triangular +!> matrix L such that +!> +!> \f[ A = L L^\text{T} \f] +!> (Cholesky decomposition of \f$ A \f$) +!> +!> can be computed as: \f$ L = A Q \f$ +!> +!> @side_effects +!> In output \p A_k is returned in a PACKED form (i.e. off-diagonal elements are +!> scaled by two); the latter is the form in which it should be stored as column of \p Am. +!> In case of detected linear dependence, the \p Q_k array is returned as zeros! +!> +!> @note +!> Triangular storage must be used for the \f$ Q \f$-matrix! +!> +!> @param[in,out] A_k \p kCol -th column of \f$ A \f$ (min. size \p kCol) +!> @param[in] kCol index of the column/vector +!> @param[in] Am in-core part of the matrix \f$ A \f$ (triangular storage) +!> @param[in] Qm in-core matrix whose columns are the orthonormal vectors (triangular storage) +!> @param[in] nMem max number of columns of \p Qm (and also of \p Am) kept in core +!> @param[in] lu_A file unit where the \f$ A \f$-matrix is stored +!> @param[in] lu_Q file unit where the \f$ Q \f$-matrix is stored +!> @param[in] Scr scratch space used for reading out-of-core columns of \p Qm and \p Am +!> @param[in] lScr size of the scratch space (≥ \p kCol-1 or ``0`` iff in-core) +!> @param[in] Z auxiliary array of min. size \p kCol (always needed) +!> @param[in] X auxiliary array of min. size \p kCol-1 (needed only for the out-of-core case) +!> @param[in] thr threshold for linear dependence +!> @param[out] Q_k the \p kCol -th column of \p Qm (min. size \p kCol) +!> @param[out] lindep integer indicating detected linear dependence (= ``1`` iff found lin dep, else = ``0``) +!*********************************************************************** + +subroutine INV_CHO_FACTOR(A_k,kCol,Am,Qm,nMem,lu_A,lu_Q,Scr,lScr,Z,X,thr,Q_k,lindep) + +use Index_Functions, only: iTri, nTri_Elem +#ifdef _MOLCAS_MPP_ +use Para_Info, only: MyRank, nProcs, Is_Real_Par +#endif +use Constants, only: Zero, One, Two +use Definitions, only: wp, iwp, u6, r8 + +#include "intent.fh" + +implicit none +real(kind=wp), intent(inout) :: A_k(*) +integer(kind=iwp), intent(in) :: kCol, nMem, lu_A, lu_Q, lScr +real(kind=wp), intent(in) :: Am(*), Qm(*), thr +real(kind=wp), intent(_OUT_) :: Scr(*), Z(*), X(*), Q_k(*) +integer(kind=iwp), intent(out) :: lindep +#include "warnings.h" +integer(kind=iwp) :: i, IJ, j, jp, kdone, kread, kstart, lQcol, lQdone, lQdone_, lQread +real(kind=wp) :: sprev, xnorm +real(kind=wp), parameter :: thr_neg = -1.0e-8_wp +real(kind=r8), external :: ddot_ + +!*********************************************************************** +if (thr < zero) then + call WarningMessage(2,'Error in Inv_Cho_Factor') + write(u6,*) 'thr must be >= zero' + call Quit(_RC_CHO_LOG_) +end if + +lindep = 0 + +if (kCol <= nMem) then + + ! Compute scalar product of A_k with previous vectors + ! --------------------------------------------------- + jp = 1 + do j=1,kCol-1 + Z(j) = ddot_(j,A_k(1),1,Qm(jp),1) + jp = jp+j + end do + !call RecPrt('A_k*Qm',' ',Z,1,kCol) + + ! Compute unnormalized k-th vector + ! -------------------------------- + ! SVC: this piece of code was computing Q_k = - Qm * Z, where Q_k and Z + ! are vectors of length kCol-1, and Qm is a matrix in triangular storage + ! with column-wise layout: + ! |Q_k(1) | |Qm(1,1) Qm(1,2) ... Qm(1,kCol-1) | |Z(1) | + ! |Q_k(2) | | Qm(2,2) ... Qm(2,kCol-1) | |Z(2) | + ! | ... | = - | ... ... | * |... | + ! | ... | | | |... | + ! |Q_k(kCol-1)| | Qm(kCol-1,kCol-1)| |Z(kCol-1)| + ! In order to improve performance, I've used the DTPMV routine from + ! BLAS. For parallel processes, we will block up the triangular matrix + ! and divide the blocks over the processes, using either DTPMV or DGEMV + ! on the blocks (depending if it is a diagonal or off-diagonal block). + + Q_k(1:kCol-1) = Zero +# ifdef _MOLCAS_MPP_ + if (is_real_par() .and. (kCol >= 500)) then + ! SVC: the best way would probably be to chop up the triangular matrix + ! into blocks, and then call DTPMV/DGEMV on those blocks. To keep things + ! simple, I've just used a series of DAXPY's on each column of the + ! triangular matrix, this should be sufficient (for now). + do J=1+MYRANK,KCOL-1,NPROCS + IJ = iTri(J,1) + Q_k(1:J) = Q_k(1:J)-Z(J)*Qm(IJ:IJ+J-1) + end do + call GAdGOp(Q_k,kCol-1,'+') + else +# endif + Q_k(1:kCol-1) = Q_k(1:kCol-1)-Z(1:kCol-1) + call DTPMV('U','N','N',kCol-1,Qm,Q_k,1) +# ifdef _MOLCAS_MPP_ + end if +# endif + Q_k(kCol) = one + + ! Normalize k-th vector : ||Q_k|| = Q_k^T * A * Q_k + ! --------------------------------------------------- + + A_k(1:kCol-1) = Two*A_k(1:kCol-1) ! packing of A_k + + Z(kCol) = ddot_(kCol,A_k(1),1,Q_k(1),1) !contrib fr k-th col of A + + jp = 1 + do j=1,kCol-1 ! contrib. from previous columns of A + Z(j) = ddot_(j,Q_k(1),1,Am(jp),1) + jp = jp+j + end do + + xnorm = ddot_(kCol,Z(1),1,Q_k(1),1) + + if (xnorm >= thr) then + + xnorm = one/sqrt(xnorm) + Q_k(1:kCol) = xnorm*Q_k(1:kCol) + + !-tbp: use fixed criterion for too negative diagonal + !else if ((xnorm > zero) .or. (-xnorm <= Ten*thr)) then + else if (xnorm > thr_neg) then + + lindep = 1 + Q_k(1:kCol) = Zero + + else + + call WarningMessage(2,'Error in Inv_Cho_Factor') + write(u6,*) 'INV_CHO_FACTOR: too-negative value for norm(Q_k).' + write(u6,*) 'INV_CHO_FACTOR: xnorm = ',xnorm + call Quit(_RC_CHO_RUN_) + + end if + + ! * + !********************************************************************* + ! * +else ! the first nMem columns of Q are in memory + ! * + !********************************************************************* + ! * + + if (lScr < kCol-1) then + call WarningMessage(2,'Error in Inv_Cho_Factor') + write(u6,*) 'lScr must be >= kCol-1' + call Quit(_RC_CHO_LOG_) + end if + + X(1:kCol-1) = Zero + + ! Compute scalar product of A_k with in-core previous vectors + ! ----------------------------------------------------------- + jp = 1 + do j=1,nMem + Z(j) = ddot_(j,A_k(1),1,Qm(jp),1) + jp = jp+j + end do + + ! Batch for the out-of-core previous vectors + ! ------------------------------------------ + kdone = nMem + lQcol = nTri_Elem(kCol-1) ! length up to kCol-1 + do while (kdone < kCol-1) + + lQdone = nTri_Elem(kdone) + lQdone_ = lQdone + lQread = lQcol-lQdone + + kread = kCol-1 + do while (lQread > lScr) + lQread = lQread-kread + kread = kread-1 + end do + + call ddafile(lu_Q,2,Scr,lQread,lQdone_) ! read + + jp = 1 + do j=kdone+1,kread + Z(j) = ddot_(j,A_k,1,Scr(jp),1) + jp = jp+j + end do + + ! Store an out-of-core intermediate for the Q-vectors + ! --------------------------------------------------- + do i=1,kread + sprev = zero + kstart = max(i,kdone+1) ! ((j >= i) .and. j_out_of_core) + do j=kstart,kread + ij = iTri(j,i)-lQdone + sprev = sprev+Z(j)*Scr(ij) + end do + X(i) = X(i)+sprev + end do + + kdone = kread + + end do + !call RecPrt('A_k*Qm',' ',Z,1,kCol) + + ! Compute unnormalized k-th vector + ! -------------------------------- + do i=1,kCol-1 + sprev = X(i) ! out-of-core contrib. + do j=i,nMem + ij = iTri(j,i) + sprev = sprev+Z(j)*Qm(ij) + end do + Q_k(i) = -sprev + end do + Q_k(kCol) = one + + ! Normalize k-th vector : ||Q_k|| = Q_k^T * A * Q_k + ! --------------------------------------------------- + + A_k(1:kCol-1) = Two*A_k(1:kCol-1) ! packing of A_k + + Z(kCol) = ddot_(kCol,A_k(1),1,Q_k(1),1) !contrib fr k-th col of A + + ! Batch for the out-of-core previous vectors + ! ------------------------------------------ + kdone = nMem + lQcol = nTri_Elem(kCol-1) ! length up to kCol-1 + do while (kdone < kCol-1) + + lQdone = nTri_Elem(kdone) + lQread = lQcol-lQdone + + kread = kCol-1 + do while (lQread > lScr) + lQread = lQread-kread + kread = kread-1 + end do + + ! Out-of-core intermediate to be used for the normalization factor + ! ---------------------------------------------------------------- + call ddafile(lu_A,2,Scr,lQread,lQdone) ! read + + jp = 1 + do j=kdone+1,kread + Z(j) = ddot_(j,Q_k,1,Scr(jp),1) + jp = jp+j + end do + + kdone = kread + + end do + + jp = 1 + do j=1,nMem ! contrib. from in-core previous columns of A + Z(j) = ddot_(j,Q_k(1),1,Am(jp),1) + jp = jp+j + end do + + xnorm = ddot_(kCol,Z(1),1,Q_k(1),1) + + if (xnorm >= thr) then + + xnorm = one/sqrt(xnorm) + Q_k(1:kCol) = xnorm*Q_k(1:kCol) + + !-tbp: use fixed criterion for too negative diagonal + !else if ((xnorm > zero) .or. (-xnorm <= Ten*thr)) then + else if (xnorm > thr_neg) then + + lindep = 1 + Q_k(1:kCol) = Zero + + else + + call WarningMessage(2,'Error in Inv_Cho_Factor') + write(u6,*) 'INV_CHO_FACTOR: too-negative value for norm(Q_k).' + write(u6,*) 'INV_CHO_FACTOR: xnorm = ',xnorm + call Quit(_RC_CHO_RUN_) + + end if + +end if + +return + +end subroutine INV_CHO_FACTOR diff -Nru openmolcas-22.02/src/ri_util/iramax.f openmolcas-22.10/src/ri_util/iramax.f --- openmolcas-22.02/src/ri_util/iramax.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/iramax.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,51 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Francesco Aquilante * -************************************************************************ - integer function irAmax(n,a,inc) -c -c Finds the index of element having max. absolute value. -c -c Author: F. Aquilante -c - implicit real*8 (a-h,o-z) - REAL*8 a(*) - integer n,inc -c - iramax = 0 - if( n.lt.1 .or. inc.le.0 )return - iramax = 1 - if(n.eq.1)return - if(inc.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - smax = abs(a(1)) - ix = ix + inc - do 10 i = 2,n - if(abs(a(ix)).le.smax) go to 5 - iramax = i - smax = abs(a(ix)) - 5 ix = ix + inc - 10 continue - return -c -c code for increment equal to 1 -c - 20 smax = abs(a(1)) - do 30 i = 2,n - if(abs(a(i)).le.smax) go to 30 - iramax = i - smax = abs(a(i)) - 30 continue - return - end diff -Nru openmolcas-22.02/src/ri_util/iramax.F90 openmolcas-22.10/src/ri_util/iramax.F90 --- openmolcas-22.02/src/ri_util/iramax.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/iramax.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,64 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Francesco Aquilante * +!*********************************************************************** + +function irAmax(n,a,inc) +! Finds the index of element having max. absolute value. +! +! Author: F. Aquilante + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp) :: irAmax +integer(kind=iwp), intent(in) :: n, inc +real(kind=wp), intent(in) :: a(*) +integer(kind=iwp) :: i, ix +real(kind=wp) :: smax + +iramax = 0 +if ((n < 1) .or. (inc <= 0)) return +iramax = 1 +if (n == 1) return + +if (inc /= 1) then + + ! code for increment not equal to 1 + + ix = 1 + smax = abs(a(1)) + ix = ix+inc + do i=2,n + if (abs(a(ix)) > smax) then + iramax = i + smax = abs(a(ix)) + end if + ix = ix+inc + end do + +else + + ! code for increment equal to 1 + + smax = abs(a(1)) + do i=2,n + if (abs(a(i)) > smax) then + iramax = i + smax = abs(a(i)) + end if + end do + +end if + +return + +end function irAmax diff -Nru openmolcas-22.02/src/ri_util/j12.F90 openmolcas-22.10/src/ri_util/j12.F90 --- openmolcas-22.02/src/ri_util/j12.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/j12.F90 1970-01-01 00:00:00.000000000 +0000 @@ -1,17 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in <http://www.gnu.org/licenses/>. * -!*********************************************************************** - Module j12 - Integer :: nSO, nSkal_Valence, klS - Integer, Allocatable :: SOShl(:), ShlSO(:) - Integer, Allocatable :: nBasSh(:,:) - Integer, Allocatable :: iSSOff(:,:,:) - Integer, Allocatable :: iShij(:,:) - End Module j12 diff -Nru openmolcas-22.02/src/ri_util/mk_acd_accd_shells.f openmolcas-22.10/src/ri_util/mk_acd_accd_shells.f --- openmolcas-22.02/src/ri_util/mk_acd_accd_shells.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_acd_accd_shells.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1444 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 2012, Roland Lindh * -************************************************************************ - Subroutine Mk_aCD_acCD_Shells(iCnttp,W2L) -************************************************************************ -* * -* Objective: To generate aCD auxiliary basis sets on-the-fly. * -* * -* Called from: Mk_RICD_Shells * -* * -* Author: Roland Lindh, Dept. of Chemistry - Angstrom * -* * -************************************************************************ - use SOAO_Info, only: iAOtSO, nSOInf, SOAO_Info_Init, - & SOAO_Info_Free - Use Basis_Info - Use Sizes_of_Seward, only: S - use RICD_Info, only: Do_acCD_Basis, Skip_High_AC, Thrshld_CD - Implicit Real*8 (A-H,O-Z) - External Integral_RICD -#include "itmax.fh" -#include "Molcas.fh" -#include "SysDef.fh" -#include "real.fh" -#include "print.fh" -#include "status.fh" -#include "stdalloc.fh" - Integer, Allocatable :: iList2_c(:,:), iList2_p(:,:), iD_c(:), - & Con(:), ConR(:,:), Prm(:), Indkl_p(:), - & AL(:), LTP(:,:), iD_p(:), Indkl(:) - Real*8, Allocatable :: Wg(:), Vec(:), Scr(:), TP(:), tVt(:), - & Q(:), A(:), Z(:), tVp(:), tVtF(:), C(:), - & Temp(:), QTmp(:), Tmp(:) - Real*8, Allocatable :: TInt_c(:), TInt_p(:), ADiag(:) - Real*8 :: Dummy(1)=[0.0D0] -* * -************************************************************************ -* * -*#define _DEBUGPRINT_ -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - Real*8, Allocatable :: H(:), U(:), tVtInv(:) -#endif - Logical Hit, Found, Diagonal, Keep_Basis, In_Core, W2L - Character*80 BSLbl, Label - Character*80 atom,type,author,basis,CGTO, Aux -* * -************************************************************************ -************************************************************************ -* * - Interface - Subroutine Drv2El_Atomic_NoSym(Integral_RICD,ThrAO, - & iCnttp,jCnttp, - & TInt,nTInt, - & In_Core,ADiag,Lu_A,ijS_req, - & Keep_Shell) - External Integral_RICD - Real*8 ThrAO - Integer iCnttp, jCnttp, nTInt, Lu_A, ijS_req, Keep_Shell - Logical In_Core - Real*8, Allocatable :: TInt(:), ADiag(:) - End Subroutine - Subroutine Fix_Exponents(nP,mP,nC,Exp,CoeffC,CoeffP) - Integer nP, mP, nC - Real*8, Allocatable:: Exp(:), CoeffC(:,:,:), CoeffP(:,:,:) - End Subroutine Fix_Exponents - End Interface -* * -************************************************************************ -************************************************************************ -* * -*---- Statement Function -* - iTri(i,j)=Max(i,j)*(Max(i,j)-1)/2 + Min(i,j) -* * -************************************************************************ -* * - ThrAO=Zero - mData=4 - nCnttp_Start = nCnttp -* * -************************************************************************ -************************************************************************ -* * -* Loop now over all unique valence basis sets and generate the -* corresponding aCD auxiliary basis sets. Note that there are two -* different types of aCD auxiliary basis sets, aCD and acCD. -* - nSO_p=0 - nTheta_All=0 -* * -************************************************************************ -* * -* -* Pick up the threshold for the CD procedure. Note that basis -* sets might have individual accuracy! -* - mdc = dbsc(iCnttp)%mdci - Thr_aCD=dbsc(iCnttp)%aCD_Thr*Thrshld_CD -* - nTest= dbsc(iCnttp)%nVal-1 -* * -************************************************************************ -* * - If (Skip_High_AC) Then -* -* Pick up the angular index of the highest valence shell -* - If (dbsc(iCnttp)%AtmNr.le.2) Then - iVal=0 - Else If (dbsc(iCnttp)%AtmNr.le.10) Then - iVal=1 - Else If (dbsc(iCnttp)%AtmNr.le.18) Then - iVal=1 - Else If (dbsc(iCnttp)%AtmNr.le.36) Then - iVal=2 - Else If (dbsc(iCnttp)%AtmNr.le.54) Then - iVal=2 - Else If (dbsc(iCnttp)%AtmNr.le.86) Then - iVal=3 - Else - iVal=3 - End If - Keep_All = 2*nTest -* Find the number of polarization shells - iZ=Max(0,nTest-iVal) -* Reduce the product basis from excessive shells - Keep_Shell=Keep_All-iZ - Else - Keep_Shell=iTabmx - End If -* * -************************************************************************ -* * -* Define some parameters to facilitate the atomic calculation -* - iShell = dbsc(iCnttp)%nVal - S%nShlls=iShell -* * -************************************************************************ -* * -* Use the name of the old valence basis -* - Label=dbsc(iCnttp)%Bsl_old -* - Hit=.True. - Call Decode(Label,atom,1,Hit) - Hit=.True. - Call Decode(Label,type,2,Hit) - Hit=.True. - Call Decode(Label,author,3,Hit) - Hit=.True. - Call Decode(Label,basis,4,Hit) - Hit=.True. - Call Decode(Label,CGTO,5,Hit) - Hit=.False. - Call Decode(Label,Aux,6,Hit) - If (.Not.Hit) Aux = ' ' -* - n=Index(Atom,' ')-1 - Label=' ' - Label(1:n+1)=atom(1:n)//'.' - nn = n + 1 -* - n=Index(Type,' ')-1 - If (Do_acCD_Basis) Then - Label(nn+1:nn+n+23)=Type(1:n)//'....acCD-aux-basis.' - Else - Label(nn+1:nn+n+22)=Type(1:n)//'....aCD-aux-basis.' - End If -* - Indx=Index(Label,' ') - BSLbl=' ' - BSLbl(1:Indx-1)=Label(1:Indx-1) -* -* Make a temporary setup of the SOAO_Info arrays for the -* atomic auxiliary basis set. -* Note that the auxiliary basis set will carry an angular value -* which at most is twice that of valence basis set. -* - mSOInf = 0 - - Do iAng = 0, 2*nTest - nCmp = (iAng+1)*(iAng+2)/2 - mSOInf = mSOInf + nCmp - End Do - Call SOAO_Info_Init(mSOInf,1) -* * -************************************************************************ -************************************************************************ -* * -* C O N T R A C T E D S E C T I O N -* -* Run in contracted mode to generate the auxiliary basis for the -* aCD primitive product basis. -* - Call Flip_Flop(.False.) -* * -************************************************************************ -* * -* Define AOtSO -* - iAO = 0 - iSO = 0 - nSO=0 - Do iAng = 0, nTest - iShll_ = dbsc(iCnttp)%iVal + iAng - nCmp = (iAng+1)*(iAng+2)/2 - If (Shells(iShll_)%Prjct ) nCmp = 2*iAng+1 - iSO = 0 - If (Shells(iShll_)%nBasis_C*Shells(iShll_)%nExp==0) Cycle - Do iCmp = 1, nCmp - iAO = iAO + 1 - If (iAO>nSOInf) Then - Write (6,*) 'mk_acd_accd_shells: iAO>nSOInf (1)' - Write (6,*) 'iAO=',iAO - Write (6,*) 'nSOInf=',nSOInf - Call Abend() - End If - iAOtSO(iAO,0) = iSO + 1 - iSO = iSO + Shells(iShll_)%nBasis - End Do - nSO=nSO+iSO - End Do -* -* Generate list -* - nPhi_All=nSO*(nSO+1)/2 - Call mma_allocate(iList2_c,mData*2,nPhi_All,label='iList2_c') - Call Mk_List2(iList2_c,nPhi_All,mData,nSO,iCnttp,nTest,0) -* * -************************************************************************ -* * -* If the full product basis is used no need for decomposition! -* - If (Thr_aCD.eq.0.0D0) Then - nTInt_c=nPhi_All - Call mma_allocate(iD_c,nTInt_c,label='iD_c') - Do i = 1, nTInt_c - iD_c(i) = i - End Do - NumCho_c=nTInt_c - Go To 1881 - End If -* * -************************************************************************ -* * -* Generate atomic two-electron integrals to decompose. -* - ijS_req=0 - Call Drv2El_Atomic_NoSym(Integral_RICD,ThrAO,iCnttp,iCnttp, - & TInt_c,nTInt_c, - & In_Core,ADiag,Lu_A,ijS_req,Keep_Shell) -* * -************************************************************************ -* * -* Let us now decompose and retrieve the most important -* contracted products, indicies stored in iD_c -* - Call mma_allocate(iD_c,nTInt_c,label='iD_c') -* -* Temporary code for weights to be used in a MS-aCD/acCD -* scheme. Currently set to unit giving the convential -* all purpose aCD/acCD auxiliary basis sets. -* - Call mma_allocate(Wg,nTInt_c,label='Wg') - call dcopy_(nTInt_c,[1.0D0],0,Wg,1) -* - If (In_Core) Then -#ifdef _DEBUGPRINT_ - Call RecPrt('TInt_c',' ',TInt_c,nTInt_c,nTInt_c) -#endif - Call mma_allocate(Vec,nTInt_c**2,label='Vec') -* - Call CD_InCore_p_w(TInt_c,nTInt_c, - & Wg,Vec,nTInt_c,iD_c,NumCho_c, - & Thr_aCD,iRC) -* - If (iRC.ne.0) Then - Call WarningMessage(2,'Error in Mk_RICD_Shells') - Write (6,*) 'Mk_aCD_Shells: CD_InCore_p(c) failed!' - Call Abend() - End If -#ifdef _DEBUGPRINT_ - Call RecPrt('Vec',' ',Vec,nTInt_c,NumCho_c) -#endif - Call mma_deallocate(TInt_c) - Call mma_deallocate(Vec) -* - Else ! out-of-core part -* - Call mma_maxDBLE(lScr) - lScr=Min(lScr-2*nTInt_c,nTInt_c**2+3*nTInt_c) - Call mma_Allocate(Scr,lScr,label='Scr') -* - iSeed=Lu_A+1 - Lu_B=IsFreeUnit(iSeed) - Call DaName_MF_WA(Lu_B,'AVEC1') -* - Call Get_Pivot_idx_w(ADiag,Wg,nTInt_c, - & NumCho_c,Lu_A,Lu_B,iD_c, - & Scr,lScr,Thr_aCD) -* - Call mma_deallocate(Scr) - Call mma_deallocate(ADiag) - Call DaEras(Lu_B) - Call DaEras(Lu_A) -* - End If -* - Call mma_deallocate(Wg) -* - 1881 Continue -* - If (NumCho_c.lt.1) Then - Call WarningMessage(2,'Error in Mk_RICD_Shells') - Write (6,*) 'Mk_aCD_Shells: NumCho_c.lt.1 is illegal!' - Call Abend() - End If -* -#ifdef _DEBUGPRINT_ - Write (6,*) ' Thr_aCD:',Thr_aCD - Write (6,*) 'NumCho_c:',NumCho_c - Call iVcPrt('iD_c',' ',iD_c,NumCho_c) -#endif -* * -************************************************************************ -************************************************************************ -* * -* Define AOtSO for primitive integral calculations. -* - If (Do_acCD_Basis) Then - iAO = 0 - iSO = 0 - nSO_p=0 - Do iAng = 0, nTest - iShll_ = dbsc(iCnttp)%iVal + iAng - nCmp = (iAng+1)*(iAng+2)/2 - If (Shells(iShll_)%Prjct) nCmp = 2*iAng+1 - iSO = 0 - Do iCmp = 1, nCmp - iAO = iAO + 1 - If (iAO>nSOInf) Then - Write (6,*) 'mk_acd_accd_shells: iAO>nSOInf (2)' - Call Abend() - End If - iAOtSO(iAO,0) = iSO + 1 - iSO = iSO + Shells(iShll_)%nExp - End Do - nSO_p=nSO_p+iSO - End Do - End If -* * -************************************************************************ -************************************************************************ -************************************************************************ -* * -* Loop through angular products. Note that all the products -* of an atom require multiple basis sets since Seward is not -* structured to handle more than one shell of a specific -* angular at the time, i.e. a basis set contains only, for -* example, one d-shell. For an atomic basis spd we will have -* the p*p and d*s resulting in two independent shells with -* the same total angular momentum, d. -* - iShll=S%Mx_Shll - 1 -* -* Start now looping over the products and analys the result -* of the CD. Note the very peculiar loop structure over -* iBS, iAng, and jAng. This to reduce the number of -* created basis sets. -* - nBS = (nTest+2)/2 - Do iBS = 0, nBS-1 - iAngMin=iBS - iAngMax=nTest - iBS -* - nCnttp=nCnttp+1 - Keep_Basis = .False. -* - If (nCnttp.gt.Mxdbsc) Then - Call WarningMessage(2,'Error in Mk_RICD_Shells') - Write (6,*) 'Mk_RICD_Shells: Increase Mxdbsc' - Call Abend() - End If -* -* Some generic setting of information -* - dbsc(nCnttp)%Bsl=Label - dbsc(nCnttp)%Bsl_old=dbsc(nCnttp)%Bsl - dbsc(nCnttp)%pChrg=dbsc(iCnttp)%pChrg - dbsc(nCnttp)%Fixed=dbsc(iCnttp)%Fixed - dbsc(nCnttp)%Parent_iCnttp=iCnttp - dbsc(nCnttp)%iVal = iShll+1 - dbsc(nCnttp)%Aux =.True. - dbsc(nCnttp)%aCD_Thr=dbsc(iCnttp)%aCD_Thr - dbsc(nCnttp)%fMass=dbsc(iCnttp)%fMass -* * -************************************************************************ -* * -* Loop over shell pairs -* - jShll=iShll - Do iAng = 0, iAngMax - jAngMax=Min(iAng,iAngMin) - iShll_=dbsc(iCnttp)%iVal+iAng - If (iAng.eq.iAngMax) jAngMax=iAngMax - If (iAng.lt.iAngMin) jAngMax=0 - jAngMin=iAngMin - If (iAng.le.iAngMin) jAngMin=0 - Do jAng = jAngMin, jAngMax - jShll_=dbsc(iCnttp)%iVal+jAng -* - iShll = iShll + 1 -#ifdef _DEBUGPRINT_ - Write (6,*) - Write (6,*) 'iAng,jAng=',iAng,jAng - Write (6,*) 'iAngMax=',iAngMax -#endif - If (iShll.gt.MxShll) Then - Call WarningMessage(2,'Error in Mk_RICD_Shells') - Write (6,*) 'Mk_RICD_Shells: iShll.gt.MxShll' - Write (6,*) 'iShll,MxShll=',iShll,MxShll - Call Abend() - End If - Diagonal=iAng.eq.jAng -* -* Examine if any contracted products of these two shells -* survived the CD procedure, or that it is an empty shell. -* - Found=.False. - kShll=-1 - lShll=-1 - Do iCho_c = 1, NumCho_c - ijSO = iD_c(iCho_c) - kAng=iList2_c(1,ijSO) - lAng=iList2_c(2,ijSO) - If ( iAng.eq.kAng .and. jAng.eq.lAng ) Then - kShll=iList2_c(7,ijSO) - lShll=iList2_c(8,ijSO) - Found=.True. - Exit - End If - End Do -* -* Fake Found=.FALSE. for shells which should explicitly be -* empty. -* - Found = Found .and. jAng.ge.iAngMin - & .and. iAng.ge.iAngMin - & .and. iAng+jAng.le.Keep_Shell - Keep_Basis = Found .or. Keep_Basis -#ifdef _DEBUGPRINT_ - Write (6,*) 'Found,kShll,lShll=',Found,kShll,lShll -#endif -* * -************************************************************************ -************************************************************************ -* * -* P R I M I T I V E S E C T I O N -* -* Run in uncontracted mode to produce a SLIM -* primitive product basis. -* - If (Do_acCD_Basis.and.Found) Then -* - Call Flip_Flop(.True.) -* -* Generate list -* - npi=Shells(iShll_)%nExp - nCmpi=(iAng+1)*(iAng+2)/2 - If (Shells(iShll_)%Prjct ) nCmpi=2*iAng+1 - npj=Shells(jShll_)%nExp - nCmpj=(jAng+1)*(jAng+2)/2 - If (Shells(jShll_)%Prjct ) nCmpj=2*jAng+1 - If (iAng.eq.jAng) Then - nTheta_All=npi*nCmpi*(npi*nCmpi+1)/2 - Else - nTheta_All=npi*nCmpi*npj*nCmpj - End If -* - Call mma_allocate(iList2_p,2*mData,nTheta_all, - & label='iList2_p') -* - ijS_Req=(iAng+1)*iAng/2 + jAng + 1 -* - Call Mk_List2(iList2_p,nTheta_All,mData,nSO_p, - & iCnttp, nTest,ijS_Req) -* * -************************************************************************ -* * -* Generate atomic two-electron integrals -* - Call Drv2El_Atomic_NoSym(Integral_RICD, - & ThrAO,iCnttp,iCnttp, - & TInt_p,nTInt_p, - & In_Core,ADiag,Lu_A, - & ijS_Req,Keep_Shell) -* - If (.NOT.In_Core) Then - Call WarningMessage(2,'Error in Mk_RICD_Shells') - Write (6,*) 'Out-of-core acCD not implemented!' - Call Abend() - End If -#ifdef _DEBUGPRINT_ - Call RecPrt('TInt_p','(5G20.11)', - & TInt_p,nTInt_p,nTInt_p) -#endif - Call Flip_Flop(.False.) -* - End If -* * -************************************************************************ -************************************************************************ -* * -* Now mimic the procedure of GetBS! -* * -************************************************************************ -* * -* Working on the CONTRACTED functions. -* -* This section is identical for acCD and aCD auxiliary -* basis sets! -* * -************************************************************************ -* * - If (Found) Then -* - lAng = iAng + jAng -* -* Now figure out how many and which! -* - nk=Shells(kShll)%nBasis_C - nl=Shells(lShll)%nBasis_C - If (Diagonal) Then - nCntrc_Max=nk*(nk+1)/2 - Else - nCntrc_Max=nk*nl - End If -#ifdef _DEBUGPRINT_ - Write (6,*) 'nCntrc_Max=', - & nCntrc_Max -#endif - Call mma_allocate(Con,nCntrc_Max,label='Con') - Call mma_allocate(ConR,2,nCntrc_Max,label='ConR') - Call IZero(Con,nCntrc_Max) - Call IZero(ConR,2*nCntrc_Max) - nCntrc=0 - Do iCho_c = 1, NumCho_c - ijSO = iD_c(iCho_c) - kAng=iList2_c(1,ijSO) - lAng=iList2_c(2,ijSO) - If (kAng.eq.iAng.and.lAng.eq.jAng) Then -* -* Pick up the radial index! -* - ik=iList2_c(5,ijSO) - il=iList2_c(6,ijSO) -* - If (Diagonal) Then - ikl=iTri(ik,il) - Else - ikl=(il-1)*nk + ik - End If -* -* Note that this migh be done several time -* since several angular pairs might have the same -* radial function! -* - If (Con(ikl).eq.0) Then - nCntrc=nCntrc+1 - Con(ikl)=1 - ConR(1,nCntrc)=ik -#ifdef _DEBUGPRINT_ - Write (6,*) 'iCho_c, ijSO=', - & iCho_c+1,ijSO -#endif - ConR(2,nCntrc)=il - End If - End If - End Do ! iCho_c -#ifdef _DEBUGPRINT_ - Write (6,*) 'nCntrc=',nCntrc - Call iVcPrt('Con',' ',Con,nCntrc_Max) - Call iVcPrt('ConR',' ',ConR,2*nCntrc) - Write (6,*) - Write (6,*) 'ConR' - Write (6,'(30I3)') - & (ConR(1,i),i=1,nCntrc) - Write (6,'(30I3)') - & (ConR(2,i),i=1,nCntrc) -#endif -* - Else -* -* Let us put in an empty shell! -* - nk=0 - nl=0 - nCntrc=0 - End If -* * -************************************************************************ -* * -* Work on the PRIMITIVE products! -* -* Here the work is trivial in case of the aCD basis -* * -************************************************************************ -* * - If (Found) Then -* * -************************************************************************ -* * -* Produce the SLIM primitive products -* * -************************************************************************ -* * - If (Do_acCD_Basis) Then -* -* Now figure out how many and which! -* - npk=Shells(kShll)%nExp - npl=Shells(lShll)%nExp - If (Diagonal) Then - nPrim_Max=npk*(npk+1)/2 - Else - nPrim_Max=npk*npl - End If -#ifdef _DEBUGPRINT_ - Write (6,*) 'nPrim_Max:',nPrim_Max -#endif - Call mma_allocate(Prm,nPrim_Max,label='Prm') - Call IZero(Prm,nPrim_Max) -* -* Pick up the diagonal elements from TInt_p -* corresponding to this shell pair. We sum over -* the angular parts identical to those of the -* contracted. -* - nCompA=(iAng+1)*(iAng+2)/2 - nCompB=(jAng+1)*(jAng+2)/2 - nAB=nCompA*nCompB - Call mma_allocate(AL,nAB,label='AL') -* -* First make a list from the contracted which -* angular products to include. -* - Call Mk_AngList(AL,nCompA,nCompB, - & iD_c,NumCho_c, - & iList2_c,nPhi_All, - & 2*mData,iAng,jAng) -* - Call mma_allocate(TP,nPrim_Max**2,label='TP') - Call mma_allocate(LTP,2,nPrim_Max,label='LTP') - Call Mk_TInt_P(TInt_p,nTheta_All, - & TP,nPrim_Max, - & AL,nCompA,nCompB, - & iList2_p,nTheta_All, - & 2*mData,iAng,jAng,npk,npl,LTP) -* -#ifdef _DEBUGPRINT_ - Call RecPrt('TIntP','(5G20.10)', - & TP,nPrim_Max,nPrim_Max) - Call iVcPrt('List_TP',' ',LTP,2*nPrim_Max) -#endif -* Let us now decompose and retrieve the most -* important primitive products, indicies stored in -* iD_p -* - Call mma_allocate(iD_p,nPrim_Max,label='iD_p') - Call mma_allocate(Vec,nPrim_Max**2,label='Vec') -* - Thrshld_CD_p = Thr_aCD*2.0D-1 - 3377 Continue - Call CD_InCore_p(TP,nPrim_Max,Vec,nPrim_Max, - & iD_p,NumCho_p,Thrshld_CD_p,iRC) - If (NumCho_p.lt.1) Then - Call WarningMessage(2, - & 'Error in Mk_RICD_Shells') - Write (6,*) 'Mk_aCD_Shells: ' - & //'NumCho_p.lt.1 is illegal!' - Write (6,*) 'iAng,jAng=',iAng,jAng - Write (6,*) 'nPrim_Max=',nPrim_Max - Write (6,*) 'NumCho_p=',NumCho_p - Write (6,*) 'iRC=',iRC - Call Abend() - End If -* -#ifdef _DEBUGPRINT_ - Write (6,*) 'Thrshld_CD_p:',Thrshld_CD_p - Write (6,*) 'NumCho_p :',NumCho_p - Call iVcPrt('iD_p',' ',iD_p,NumCho_p) - Call RecPrt('Vec',' ',Vec,nPrim_Max,NumCho_p) -#endif - If (NumCho_p.lt.nCntrc) Then - Write (6,*) 'W a r n i n g!' - Write (6,*) 'Fewer primitive functions than' - & //' contracted functions!' - Write (6,*) 'NumCho_p=',NumCho_p - Write (6,*) ' nCntrc=',nCntrc - Thrshld_CD_p=Thrshld_CD_p*0.5 - If (Thrshld_CD_p.le.1.0D-14) Then - Call WarningMessage(2, - & 'Error in Mk_RICD_Shells') - Write (6,*) 'Thrshld_CD_p is too low!' - Write (6,*) 'iAng, jAng:',iAng,jAng - Call Abend() - End If - Call Mk_TInt_P(TInt_p,nTheta_All, - & TP,nPrim_Max, - & AL,nCompA,nCompB, - & iList2_p,nTheta_All, - & 2*mData,iAng,jAng,npk,npl,LTP) - Go To 3377 - End If - Call mma_deallocate(TP) - Call mma_deallocate(Vec) -* - Do iCho_p = 1, NumCho_p - ijSO = iD_p(iCho_p) - Prm(ijSO)=1 - End Do - nPrim=NumCho_p - Call mma_allocate(Shells(iShll)%Exp,nPrim, - & Label='ExpacCD') - Shells(iShll)%nExp=nPrim -* -#ifdef _DEBUGPRINT_ - Write (6,*) 'nPrim=',nPrim - Call iVcPrt('Prm',' ',Prm,nPrim_Max) -#endif - Call mma_allocate(Indkl_p,nPrim_Max, - & label='Indkl_p') - Call Mk_Indkl(Prm,Indkl_p,nPrim_Max) -* -* Observe that the exponents are ordered according -* to their importance as given by the CD. -* - Do iCho_p = 1, NumCho_p - iTheta = iD_p(iCho_p) - ik=LTP(1,iTheta) - il=LTP(2,iTheta) - Exp_i=Shells(kShll)%Exp(ik) - Exp_j=Shells(lShll)%Exp(il) - Shells(iShll)%Exp(iCho_p)=Exp_i+Exp_j - End Do -#ifdef _DEBUGPRINT_ - Call RecPrt('SLIM Exponents',' ', - & Shells(iShll)%Exp,1,nPrim) -#endif -* * -************************************************************************ -* * - Else ! Do_aCD_Basis -* * -************************************************************************ -* * -* Put in the aCD set of exponents, i.e. all unique -* sums. -* - nExpk=Shells(kShll)%nExp - nExpl=Shells(lShll)%nExp - If (Diagonal) Then - nPrim=nExpk*(nExpk+1)/2 - Else - nPrim=nExpk*nExpl - End If - Call mma_allocate(Shells(iShll)%Exp,nPrim, - & Label='ExpaCD') - Shells(iShll)%nExp=nPrim -* - iOff = 0 - Do ip_Exp = 1, nExpk - jp_Exp_Max = nExpl - If (Diagonal) jp_Exp_Max = ip_Exp - Do jp_Exp = 1, jp_Exp_Max - iOff = iOff + 1 - Shells(iShll)%Exp(iOff)= - & Shells(kShll)%Exp(ip_Exp) - & +Shells(lShll)%Exp(jp_Exp) - End Do - End Do -* - If (iOff.ne.nPrim) Then - Call WarningMessage(2, - & 'Error in Mk_RICD_Shells') - Write (6,*) 'Mk_aCD_Shell: iOff.ne.iEnd' - Call Abend() - End If -* -#ifdef _DEBUGPRINT_ - If (Diagonal) Then - Call TriPrt('aCD Exponents',' ', - & Shells(iShll)%Exp,nExpk) - Else - Call RecPrt('aCD Exponents',' ', - & Shells(iShll)%Exp,nExpk,nExpl) - End If -#endif - End If -* - Else -* * -************************************************************************ -* * -* An empty shell -* - nPrim=0 - Shells(iShll)%nExp=nPrim -* * -************************************************************************ -* * - End If ! Found -* * -************************************************************************ -* * - lAng=iAng+jAng - S%iAngMx=Max(S%iAngMx,lAng) - S%MaxPrm(lAng)=Max(S%MaxPrm(lAng),nPrim) -* -#ifdef _DEBUGPRINT_ - Write (6,*) - Write (6,*) 'iShll=',iShll - Write (6,*) 'nPrim,nCntrc=',nPrim,nCntrc - Write (6,*) 'lAng=',lAng - Write (6,*) 'S%MaxPrm(lAng)=',S%MaxPrm(lAng) -#endif -* - Shells(iShll)%nBasis_c=nCntrc -* * -************************************************************************ -* * - Call mma_allocate(Shells(iShll)%Cff_c, - & nPrim,nCntrc,2,Label='Cff_c') - Call mma_allocate(Shells(iShll)%pCff, - & nPrim,nCntrc,Label='pCff') - Shells(iShll)%nBasis = nCntrc - Call mma_allocate(Shells(iShll)%Cff_p, - & nPrim,nPrim ,2,Label='Cff_p') -* * -************************************************************************ -* * -* C O N T R A C T I O N C O E F F I C I E N T S -* - If (Found) Then -* * -************************************************************************ -* * -* For SLIM basis sets -* * -************************************************************************ -* * - If (Do_acCD_Basis) Then -* -* Alright this is a bit more elaborate than for -* the aCD basis set. Surprise! -* -* Some care has to be taken here. There might be -* different angular products, for example, px*px -* and px*py, which carry the same radial part but -* have different angular part! To overcome this -* possible source of redundancy we use the sum of -* such terms in the fitting procedure! -* - nTheta=nPrim - nExpk=Shells(kShll)%nExp - nExpl=Shells(lShll)%nExp - If (iAng.eq.jAng) Then - nTheta_Full=nExpk*(nExpk+1)/2 - Else - nTheta_Full=nExpk*nExpl - End If - nPhi=nCntrc -* -* Generate the (theta'|V|theta') matrix in the -* SLIM primitive product basis. -* - Call mma_allocate(tVt,nTheta**2,label='tVt') - Call Mk_tVt(TInt_p,nTInt_p, - & tVt,nTheta,iList2_p,2*mData, - & Prm,nPrim_Max, - & iAng,jAng,nExpk,nExpl, - & Indkl_p,nPrim_Max, - & AL,nCompA,nCompB) -* -#ifdef _DEBUGPRINT_ - Write (6,*) - Write (6,*) 'tVt(Diag)' - Write (6,*) (tVt(i),i=1,nTheta**2,nTheta+1) - Call RecPrt('tVt',' ',tVt,nTheta,nTheta) - Call iVcPrt('iD_p',' ',iD_p,NumCho_p) -#endif -* -* Generate (theta'|V|theta')^{-1} -* -* Let's do a Cholesky decomposition with pivoting -* according to the previous CD. -* - nTri=nTheta*(nTheta+1)/2 - Call mma_allocate(Q,nTri,label='Q') - Call mma_allocate(A,nTri,label='A') - Call mma_allocate(Z,nTheta,label='Z') - Do iCho_p = 1, NumCho_p - iTheta_full=iD_p(iCho_p) - iTheta =Indkl_p(iTheta_full) - Do jCho_p = 1, iCho_p - jTheta_full=iD_p(jCho_p) - jTheta =Indkl_p(jTheta_full) - ijT= iCho_p*(iCho_p-1)/2 + jCho_p - ijS= (jTheta-1)*nTheta + iTheta - A(ijT)=tVt(ijS) - End Do - End Do -#ifdef _DEBUGPRINT_ - Call TriPrt('A',' ',A,nTheta) -* - Call mma_allocate(H,nTri,label='H') - Call mma_allocate(U,nTri,label='U') - call dcopy_(nTri,A,1,H,1) - Call FZero(U,nTheta**2) - call dcopy_(nTheta,[One],0,U,nTheta+1) - Call Jacob(H,U,nTheta,nTheta) - Call TriPrt('H','(10G20.10)',H,nTheta) - Call RecPrt('U',' ',U,nTheta,nTheta) - Call mma_deallocate(H) - Call mma_deallocate(U) -#endif -* -#ifdef _DEBUGPRINT_ - Call mma_allocate(tVtInv,nTheta**2, - & label='tVtInv') - iSing=0 - Det=0.0D0 - Call MInv(tVt,tVtInv,iSing,Det,nTheta) - Write (6,*) 'iSing,Det=',iSing,Det -#endif - Call mma_deallocate(tVt) -* - Do iTheta = 1, nTheta - iOff_Ak=(iTheta-1)*iTheta/2 + 1 - iOff_Qk=(iTheta-1)*iTheta/2 + 1 - Thrs= Thrshld_CD_p -C Thrs= 1.0D-12 - Call Inv_Cho_Factor(A(iOff_Ak),iTheta,A,Q, - & iTheta,iDum,iDum, - & Dummy,0,Z, - & Dummy,Thrs, - & Q(iOff_Qk),LinDep) - If (LinDep.eq.1) Then - Call WarningMessage(2, - & 'Error in Mk_RICD_Shells') - Write (6,*) 'Mk_aCD_Shells: linear ' - & //'dependence' - & //' found in tVt!' - Write (6,*) 'Found for vector:',iTheta - Call Abend() - End If - End Do - Call mma_deallocate(Z) - Call mma_deallocate(A) -#ifdef _DEBUGPRINT_ - Call TriPrt('Q','(9G10.3)',Q,nTheta) -#endif -* -* Generate the (theta'|V|theta) matrix in the -* mixed product basis. -* - Call mma_allocate(tVp,nTheta*nPhi,label='tVp') - Call mma_allocate(tVtF,nTheta*nTheta_Full, - & label='tVtF') - Call Mk_tVtF(TInt_p,nTInt_p, - & tVtF,nTheta, - & iList2_p,2*mData, - & Prm,nPrim_Max, - & iAng,jAng,nExpk,nExpl, - & Indkl_p,nPrim_Max, - & nTheta_Full, - & AL,nCompA,nCompB) - Call mma_deallocate(AL) -#ifdef _DEBUGPRINT_ - Call RecPrt('tVtF',' ',tVtF,nTheta,nTheta_Full) -#endif -* -* Pick up the contraction coefficients of the aCD -* basis set. Be careful what this means in the -* case that the shells are identical! -* - Call mma_allocate(Indkl,nCntrc_Max, - & label='Indkl') - Call Mk_Indkl(Con,Indkl,nCntrc_Max) - Call mma_allocate(C,nTheta_Full*nPhi,label='C') - Call Mk_Coeffs(Shells(kShll)%Cff_c(1,1,1), - & nExpk,Shells(kShll)%nBasis_C, - & Shells(lShll)%Cff_c(1,1,1), - & nExpl,Shells(lShll)%nBasis_C, - & C,nTheta_Full,nPhi, - & iD_c,NumCho_c, - & iList2_c,2*mData, - & nPhi_All, - & Indkl,nCntrc_Max, - & Shells(kShll)%nBasis_C, - & Shells(lShll)%nBasis_C, - & iAng,jAng, - & Shells(kShll)%Cff_p(1,1,1), - & Shells(lShll)%Cff_p(1,1,1)) - Call mma_deallocate(Indkl) -#ifdef _DEBUGPRINT_ - Call RecPrt('C',' ',C,nTheta_Full,nPhi) -#endif -* -* Generate the (theta'|V|phi') matrix. -* - Call DGEMM_('N','N', - & nTheta,nPhi,nTheta_Full, - & 1.0d0,tVtF,nTheta, - & C,nTheta_Full, - & 0.0d0,tVp,nTheta) - Call mma_deallocate(tVtF) -#ifdef _DEBUGPRINT_ - Call RecPrt('tVp',' ',tVp,nTheta,nPhi) -#endif - Call mma_deallocate(C) -* -* Generate the contraction coefficients of the -* SLIM contracted product basis in terms of the -* SLIM primitive product basis as -* Sum(nu') (mu'|V|nu')^-1 (nu'|V|i')=C_{mu',i'} -* -* To simplify life I will put the Q matrix into -* square storage. -* - Call mma_Allocate(Temp,nTheta**2,label='Temp') - Call FZero(Temp,nTheta**2) - Do iTheta = 1, nTheta - Do jTheta = 1, iTheta - ijT = iTheta*(iTheta-1)/2 + jTheta - ijS = (iTheta-1)*nTheta + jTheta - Temp(ijS)=Q(ijT) - End Do - End Do - call mma_deallocate(Q) -#ifdef _DEBUGPRINT_ - Call RecPrt('Q',' ',Temp,nTheta,nTheta) -#endif -* -* Resort the external index back to original -* order. The column index is external. -* - Call mma_allocate(QTmp,nTheta**2,label='QTmp') - Do iCho_p = 1, NumCho_p - iTheta_Full = iD_p(iCho_p) - iTheta = Indkl_p(iTheta_Full) - call dcopy_(nTheta,Temp(iCho_p),nTheta, - & QTmp(iTheta),nTheta) - End Do - Call mma_deallocate(Temp) -#ifdef _DEBUGPRINT_ - Call RecPrt('Q',' ',QTmp,nTheta,nTheta) - Call RecPrt('tVp',' ',tVp,nTheta,nPhi) -#endif -* Q(T) tVp - Call mma_allocate(Scr,nTheta*nPhi,label='Scr') - Scr(:)=0.0D0 - Call DGEMM_('T','N', - & nTheta,nPhi,nTheta, - & 1.0d0,QTmp,nTheta, - & tVp,nTheta, - & 0.0d0,Scr,nTheta) -* QQ(T) tVp - Call DGEMM_('N','N', - & nTheta,nPhi,nTheta, - & 1.0d0,QTmp,nTheta, - & Scr,nTheta, - & 0.0d0, - & Shells(iShll)%Cff_c(1,1,1),nTheta) -#ifdef _DEBUGPRINT_ - Call RecPrt('SLIM coeffcients',' ', - & Shells(iShll)%Cff_c(1,1,1), - & nTheta,nPhi) - Scr(:)=0.0D0 - Call DGEMM_('N','N', - & nTheta,nPhi,nTheta, - & 1.0d0,tVtInv,nTheta, - & tVp,nTheta, - & 0.0d0,Scr,nTheta) - Call RecPrt('SLIM coeffcients2',' ',Scr, - & nTheta,nPhi) - Call mma_deallocate(tVtInv) -#endif - Call mma_deallocate(tVp) -* -* Now reorder the coefficients to the CD order of -* the exponents. -* - Call mma_allocate(Tmp,nTheta*nPhi,label='Tmp') - call dcopy_(nTheta*nPhi, - & Shells(iShll)%Cff_c(1,1,1),1,Tmp,1) - Do iCho_p = 1, NumCho_p - iTheta_full = iD_p(iCho_p) - iTheta = Indkl_p(iTheta_full) - call dcopy_(nPhi, - & Tmp(iTheta),nTheta, - & Shells(iShll)%Cff_c(iCho_p,1,1), - & nTheta) - End Do - Call mma_deallocate(Tmp) -* -* Modify from coefficients for normalized -* Gaussians to unnormalized Gaussians. -* - Do iCho_p = 1, NumCho_p - iTheta = iD_p(iCho_p) - ik=LTP(1,iTheta) - il=LTP(2,iTheta) - Fact = Shells(kShll)%Cff_p(ik,ik,1) - & * Shells(lShll)%Cff_p(il,il,1) - Call DScal_(nPhi,Fact, - & Shells(iShll)%Cff_c(iCho_p,1,1), - & nTheta) - End Do - Call mma_deallocate(LTP) -* - Call mma_deallocate(iD_p) - Call mma_deallocate(Indkl_p) - Call mma_deallocate(Scr) - Call mma_deallocate(QTmp) -#ifdef _DEBUGPRINT_ - Call RecPrt('SLIM coeffcients',' ', - & Shells(iShll)%Cff_c(1,1,1), - & nTheta,nPhi) -#endif -* * -************************************************************************ -* * - Else ! Do_aCD_Basis -* * -************************************************************************ -* * -* Put in the selected set of coeffients. Note -* again that the order should be that according -* to the CD in order to prepivot, since the CD -* itself is implemented without pivoting. -* - Do iCntrc = 1, nCntrc - kC = ConR(1,iCntrc) - lC = ConR(2,iCntrc) -#ifdef _DEBUGPRINT_ - Write (6,*) 'kC,lC=',kC,lC -#endif -* * -************************************************************************ -* * -* Form the unnormalized coefficients! -* - jkl = 0 - If (Diagonal) Then - Do iExp_k = 1, Shells(kShll)%nExp -* - Coeff_kk=Shells(kShll)%Cff_c(iExp_k,kC,1) - Coeff_lk=Shells(lShll)%Cff_c(iExp_k,lC,1) - - Do iExp_l = 1 , iExp_k - - Coeff_ll=Shells(lShll)%Cff_c(iExp_l,lC,1) - Coeff_kl=Shells(kShll)%Cff_c(iExp_l,kC,1) - Coeff_ =Coeff_ll*Coeff_kk - & +Coeff_kl*Coeff_lk - If (iExp_k.eq.iExp_l) Then - Coeff_ =Coeff_ *Half - End If - jkl = jkl + 1 - - Shells(iShll)%Cff_c(jkl,iCntrc,1)=Coeff_ - - End Do - End Do - Else - Do iExp_k = 1, Shells(kShll)%nExp - - Coeff_k =Shells(kShll)%Cff_c(iExp_k,kC,1) - - Do iExp_l = 1 , Shells(lShll)%nExp - - Coeff_l =Shells(lShll)%Cff_c(iExp_l,lC,1) - - Coeff_kl=Coeff_l*Coeff_k - - jkl = jkl + 1 - Shells(iShll)%Cff_c(jkl,iCntrc,1)=Coeff_kl - End Do - End Do - End If -* - End Do ! iCntrc -#ifdef _DEBUGPRINT_ - Call RecPrt('aCD Coefficients','(6G20.12)', - & Shells(iShll)%Cff_c(1,1,1), - & nPrim,nCntrc) -#endif -* * -************************************************************************ -* * - End If -* * -************************************************************************ -* * - Shells(iShll)%Cff_c(:,:,2)= - & Shells(iShll)%Cff_c(:,:,1) -* - Call mma_deallocate(Con) - Call mma_deallocate(ConR) - If (Do_acCD_Basis) Call mma_deallocate(Prm) -* -* Put in unit matrix of uncontracted set -* - Shells(iShll)%Cff_p(:,:,1)=Zero - Do i=1,nPrim - Shells(iShll)%Cff_p(i,i,1)=One - End Do -* - Shells(iShll)%Cff_p(:,:,2)= - & Shells(iShll)%Cff_p(:,:,1) - Call Nrmlz(Shells(iShll)%Exp,nPrim, - & Shells(iShll)%Cff_p(1,1,1), - & nPrim ,lAng) -#ifdef _DEBUGPRINT_ - Call RecPrt('uncon1',' ', - & Shells(iShll)%Cff_p(:,:,1), - & nPrim,nPrim) - Call RecPrt('uncon2',' ', - & Shells(iShll)%Cff_p(:,:,2), - & nPrim,nPrim) -#endif -* -* OK let's do the correction now! -* -#ifdef _DEBUGPRINT_ - Call RecPrt('Coefficients 10',' ', - & Shells(iShll)%Cff_c(:,:,1), - & nPrim,nCntrc) - iOff = nPrim*nCntrc - Call RecPrt('Coefficients 20',' ', - & Shells(iShll)%Cff_c(:,:,2), - & nPrim,nCntrc) -#endif - iOff = nPrim*nCntrc - Call Fix_Coeff(nPrim,nCntrc, - & Shells(iShll)%Cff_c(:,:,2), - & Shells(iShll)%Cff_p(:,:,1),'F') -#ifdef _DEBUGPRINT_ - Call RecPrt('Coefficients 1',' ', - & Shells(iShll)%Cff_c(:,:,1), - & nPrim,nCntrc) - iOff = nPrim*nCntrc - Call RecPrt('Coefficients 2','(6G20.13)', - & Shells(iShll)%Cff_c(:,:,2), - & nPrim,nCntrc) -#endif -* -* Now remove any primitives with all zero -* coefficents! -* - Call Fix_Exponents(nPrim,mPrim,nCntrc, - & Shells(iShll)%Exp, - & Shells(iShll)%Cff_c, - & Shells(iShll)%Cff_p) - nPrim=mPrim - Shells(iShll)%nExp=nPrim -#ifdef _DEBUGPRINT_ - Call RecPrt('Coefficients 1',' ', - & Shells(iShll)%Cff_c(:,:,1), - & nPrim,nCntrc) - iOff = nPrim*nCntrc - Call RecPrt('Coefficients 2',' ', - & Shells(iShll)%Cff_c(:,:,2), - & nPrim,nCntrc) -#endif - End If -* -* - Shells(iShll)%nBasis=Shells(iShll)%nBasis_c - If (jAng.eq.0.and.Found) Then - Shells(iShll)%Transf=Shells(kShll)%Transf - Shells(iShll)%Prjct =Shells(kShll)%Prjct - Else - Shells(iShll)%Transf=.True. - Shells(iShll)%Prjct =.False. - End If - Shells(iShll)%Aux=.True. -* - If (Do_acCD_Basis.and.Found) Then - Call mma_deallocate(iList2_p) - Call mma_deallocate(TInt_p) - End If - Shells(iShll)%pCff(:,:) = Shells(iShll)%Cff_c(:,:,1) -* - End Do ! jAng - End Do ! iAng -* - dbsc(nCnttp)%nVal = iShll-jShll - dbsc(nCnttp)%nShells = dbsc(nCnttp)%nVal -* * -************************************************************************ -************************************************************************ -************************************************************************ -* * - If (Keep_Basis) Then - If (Show.and.nPrint(2).ge.6) Then - Write (6,*) - Write (6,*) - Write(6,'(1X,A,I5,A,A)') - & 'Basis Set ',nCnttp,' Label: ', BSLbl(1:Indx-1) - Write(6,'(1X,A)') 'On-the-fly basis set generation' - End if -* -* -* Transfer the coordinate information -* - nCnt = dbsc(iCnttp)%nCntr - dbsc(nCnttp)%nCntr=nCnt - dbsc(nCnttp)%mdci =mdc -* Create a pointer to the actual coordinates - dbsc(nCnttp)%Coor => dbsc(iCnttp)%Coor(1:3,1:nCnt) -* -* Compute the number of elements stored in the dynamic -* memory so far. - S%Mx_Shll=iShll+1 - Max_Shells=S%Mx_Shll - S%Mx_mdc=mdc -* - Else -* -* If all the shells are empty, skip the whole basis set! -* - nCnttp=nCnttp-1 - End If -* - End Do ! iBS -* -* Done for this valence basis set. -* - S%Mx_Shll = iShll + 1 - Max_Shells=S%Mx_Shll -* * -************************************************************************ -* * -* Deallocate -* - Call mma_deallocate(iD_c) - Call mma_deallocate(iList2_c) -* * -************************************************************************ -* * -* * -************************************************************************ -* * -* Let us now Gram-Schmidt orthonormalize the auxiliary basis for -* better numerics and balance. -* - Do jCnttp = nCnttp_start + 1, nCnttp - Call Renorm2(jCnttp) - End Do -* * -************************************************************************ -* * -* Optionally add auxiliary basis set to the end of the -* temporary auxiliary basis set library. -* - If (W2L) Then - Lu_lib=17 - Lu_lib=IsFreeUnit(Lu_lib) - call molcas_open(Lu_lib,'RICDLIB') - ReWind(Lu_lib) - Do ! For ever - Read (Lu_lib,*,END=777) - End Do - 777 Continue - BACKSPACE(Lu_lib) -* - Do jCnttp = nCnttp_start + 1, nCnttp - If (jCnttp.eq.nCnttp_start+1) Then - Write (Lu_lib,'(A)') '/'//Label - Else - Write (Lu_lib,'(A)') Label - End If - If (jCnttp.eq.nCnttp_start+1) Then - Write (Lu_lib,'(F6.2,2I10)') dbsc(jCnttp)%Charge, - & dbsc(jCnttp)%nVal-1,nCnttp-nCnttp_start - Else - Write (Lu_lib,'(F6.2, I10)') dbsc(jCnttp)%Charge, - & dbsc(jCnttp)%nVal-1 - End If - Write (Lu_lib,*) ' Dummy reference line.' - Write (Lu_lib,*) ' Dummy reference line.' - Do iAng = 0, dbsc(jCnttp)%nVal-1 - iShll_ = dbsc(jCnttp)%iVal + iAng - nExpi=Shells(iShll_)%nExp - iSph=0 - If (Shells(iShll_)%Prjct ) iSph=1 - If (Shells(iShll_)%Transf) iSph=iSph+2 - Write (Lu_lib,'(3I10)') nExpi, Shells(iShll_)%nBasis,iSph -* -* Skip if the shell is empty. -* - If (nExpi.eq.0) Cycle -* -* Write out the exponents -* - Write (Lu_lib,'( 5(1X,D20.13))') - & (Shells(iShll_)%Exp(i),i=1,nExpi) -* -* Write out the contraction coefficients -* - Do i = 1, nExpi - Write (Lu_lib,'( 5(1X,D20.13))') - & (Shells(iShll_)%Cff_c(i,j,1), - & j=1,Shells(iShll_)%nBasis) - End Do -* - End Do - End Do - Close(Lu_lib) - End If -* - Call SOAO_Info_Free() -* * -************************************************************************ -* * - Return -* - End diff -Nru openmolcas-22.02/src/ri_util/mk_acd_accd_shells.F90 openmolcas-22.10/src/ri_util/mk_acd_accd_shells.F90 --- openmolcas-22.02/src/ri_util/mk_acd_accd_shells.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_acd_accd_shells.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,1247 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 2012, Roland Lindh * +!*********************************************************************** + +subroutine Mk_aCD_acCD_Shells(iCnttp,W2L) +!*********************************************************************** +! * +! Objective: To generate aCD auxiliary basis sets on-the-fly. * +! * +! Called from: Mk_RICD_Shells * +! * +! Author: Roland Lindh, Dept. of Chemistry - Angstrom * +! * +!*********************************************************************** + +use Index_Functions, only: iTri, nTri_Elem, nTri_Elem1 +use RI_procedures, only: Drv2El_Atomic_NoSym, Fix_Exponents +use SOAO_Info, only: iAOtSO, nSOInf, SOAO_Info_Free, SOAO_Info_Init +use Basis_Info, only: dbsc, Max_Shells, nCnttp, Shells +use Sizes_of_Seward, only: S +use RICD_Info, only: Do_acCD_Basis, Skip_High_AC, Thrshld_CD +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Half +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iCnttp +logical(kind=iwp), intent(in) :: W2L +#include "Molcas.fh" +#include "itmax.fh" +#include "print.fh" +integer(kind=iwp) :: i, iAng, iAngMax, iAngMin, iAO, iBS, iCho_c, iCho_p, iCmp, iCntrc, iDum, iExp_k, iExp_l, ijS, ijS_req, ijSO, & + ijT, ik, ikl, il, Indx, iOff, iOff_Ak, iOff_Qk, ip_Exp, iRC, iSeed, iShell, iShll, iShll_, iSO, iSph, & + istatus, iTheta, iTheta_full, iVal, iZ, j, jAng, jAngMax, jAngMin, jCho_p, jCnttp, jkl, jp_Exp, jp_Exp_Max, & + jShll, jShll_, jTheta, jTheta_full, kAng, kC, Keep_All, Keep_Shell, kShll, lAng, lC, LinDep, lScr, lShll, & + Lu_A, Lu_B, Lu_lib, mData, mdc, mPrim, mSOInf, n, nBS, nCmp, nCmpi, nCmpj, nCnt, nCntrc, nCntrc_Max, & + nCnttp_Start, nExpi, nExpk, nExpl, nk, nl, nn, nPhi, nPhi_All, npi, npj, npk, npl, nPrim, nPrim_Max, nSO, & + nSO_p, nTest, nTheta, nTheta_All, nTheta_Full, nTInt_c, nTInt_p, nTri, NumCho_c, NumCho_p +real(kind=wp) :: Coeff_, Coeff_k, Coeff_kk, Coeff_kl, Coeff_l, Coeff_lk, Coeff_ll, Dummy(1), Exp_i, Exp_j, Fact, Thr_aCD, ThrAO, & + Thrs, Thrshld_CD_p +integer(kind=iwp), allocatable :: Con(:), ConR(:,:), iD_c(:), iD_p(:), iList2_c(:,:), iList2_p(:,:), Indkl(:), Indkl_p(:), & + LTP(:,:), Prm(:) +real(kind=wp), allocatable :: A(:), ADiag(:), C(:), Q(:), QTmp(:), Scr(:), Temp(:), TInt_c(:), TInt_p(:), Tmp(:), TP(:), tVp(:), & + tVt(:), tVtF(:), Vec(:), Wg(:), Z(:) +#ifdef _DEBUGPRINT_ +real(kind=wp), allocatable :: H(:), tVtInv(:), U(:) +#endif +logical(kind=iwp) :: Diagonal, Found, Hit, In_Core, Keep_Basis +character(len=80) :: atom, author, Aux, basis, BSLbl, btype, CGTO, Label +integer(kind=iwp), external :: IsFreeUnit +external :: Integral_RICD + +! * +!*********************************************************************** +! * +ThrAO = Zero +mData = 4 +nCnttp_Start = nCnttp +! * +!*********************************************************************** +!*********************************************************************** +! * +! Loop now over all unique valence basis sets and generate the +! corresponding aCD auxiliary basis sets. Note that there are two +! different types of aCD auxiliary basis sets, aCD and acCD. + +nSO_p = 0 +nTheta_All = 0 +! * +!*********************************************************************** +! * +! Pick up the threshold for the CD procedure. Note that basis +! sets might have individual accuracy! + +mdc = dbsc(iCnttp)%mdci +Thr_aCD = dbsc(iCnttp)%aCD_Thr*Thrshld_CD +! +nTest = dbsc(iCnttp)%nVal-1 +! * +!*********************************************************************** +! * +if (Skip_High_AC) then + + ! Pick up the angular index of the highest valence shell + + if (dbsc(iCnttp)%AtmNr <= 2) then + iVal = 0 + else if (dbsc(iCnttp)%AtmNr <= 10) then + iVal = 1 + else if (dbsc(iCnttp)%AtmNr <= 18) then + iVal = 1 + else if (dbsc(iCnttp)%AtmNr <= 36) then + iVal = 2 + else if (dbsc(iCnttp)%AtmNr <= 54) then + iVal = 2 + else if (dbsc(iCnttp)%AtmNr <= 86) then + iVal = 3 + else + iVal = 3 + end if + Keep_All = 2*nTest + ! Find the number of polarization shells + iZ = max(0,nTest-iVal) + ! Reduce the product basis from excessive shells + Keep_Shell = Keep_All-iZ +else + Keep_Shell = iTabmx +end if +! * +!*********************************************************************** +! * +! Define some parameters to facilitate the atomic calculation + +iShell = dbsc(iCnttp)%nVal +S%nShlls = iShell +! * +!*********************************************************************** +! * +! Use the name of the old valence basis + +Label = dbsc(iCnttp)%Bsl_old + +Hit = .true. +call Decode(Label,atom,1,Hit) +Hit = .true. +call Decode(Label,btype,2,Hit) +Hit = .true. +call Decode(Label,author,3,Hit) +Hit = .true. +call Decode(Label,basis,4,Hit) +Hit = .true. +call Decode(Label,CGTO,5,Hit) +Hit = .false. +call Decode(Label,Aux,6,Hit) +if (.not. Hit) Aux = ' ' + +n = index(Atom,' ')-1 +Label = ' ' +Label(1:n+1) = atom(1:n)//'.' +nn = n+1 + +n = index(btype,' ')-1 +if (Do_acCD_Basis) then + Label(nn+1:nn+n+23) = btype(1:n)//'....acCD-aux-basis.' +else + Label(nn+1:nn+n+22) = btype(1:n)//'....aCD-aux-basis.' +end if + +Indx = index(Label,' ') +BSLbl = ' ' +BSLbl(1:Indx-1) = Label(1:Indx-1) + +! Make a temporary setup of the SOAO_Info arrays for the +! atomic auxiliary basis set. +! Note that the auxiliary basis set will carry an angular value +! which at most is twice that of valence basis set. + +mSOInf = 0 + +do iAng=0,2*nTest + nCmp = nTri_Elem1(iAng) + mSOInf = mSOInf+nCmp +end do +call SOAO_Info_Init(mSOInf,1) +! * +!*********************************************************************** +!*********************************************************************** +! * +! C O N T R A C T E D S E C T I O N +! +! Run in contracted mode to generate the auxiliary basis for the +! aCD primitive product basis. + +call Flip_Flop(.false.) +! * +!*********************************************************************** +! * +! Define AOtSO + +iAO = 0 +iSO = 0 +nSO = 0 +do iAng=0,nTest + iShll_ = dbsc(iCnttp)%iVal+iAng + nCmp = nTri_Elem1(iAng) + if (Shells(iShll_)%Prjct) nCmp = 2*iAng+1 + iSO = 0 + if (Shells(iShll_)%nBasis_C*Shells(iShll_)%nExp == 0) cycle + do iCmp=1,nCmp + iAO = iAO+1 + if (iAO > nSOInf) then + write(u6,*) 'mk_acd_accd_shells: iAO>nSOInf (1)' + write(u6,*) 'iAO=',iAO + write(u6,*) 'nSOInf=',nSOInf + call Abend() + end if + iAOtSO(iAO,0) = iSO+1 + iSO = iSO+Shells(iShll_)%nBasis + end do + nSO = nSO+iSO +end do + +! Generate list + +nPhi_All = nTri_Elem(nSO) +call mma_allocate(iList2_c,mData*2,nPhi_All,label='iList2_c') +call Mk_List2(iList2_c,nPhi_All,mData,nSO,iCnttp,nTest,0) +! * +!*********************************************************************** +! * +! If the full product basis is used no need for decomposition! + +if (Thr_aCD == Zero) then + nTInt_c = nPhi_All + call mma_allocate(iD_c,nTInt_c,label='iD_c') + do i=1,nTInt_c + iD_c(i) = i + end do + NumCho_c = nTInt_c +else + ! * + !********************************************************************* + ! * + ! Generate atomic two-electron integrals to decompose. + + ijS_req = 0 + call Drv2El_Atomic_NoSym(Integral_RICD,ThrAO,iCnttp,iCnttp,TInt_c,nTInt_c,In_Core,ADiag,Lu_A,ijS_req,Keep_Shell) + ! * + !********************************************************************* + ! * + ! Let us now decompose and retrieve the most important + ! contracted products, indicies stored in iD_c + + call mma_allocate(iD_c,nTInt_c,label='iD_c') + + ! Temporary code for weights to be used in a MS-aCD/acCD + ! scheme. Currently set to unit giving the convential + ! all purpose aCD/acCD auxiliary basis sets. + + call mma_allocate(Wg,nTInt_c,label='Wg') + Wg(:) = One + + if (In_Core) then +# ifdef _DEBUGPRINT_ + call RecPrt('TInt_c',' ',TInt_c,nTInt_c,nTInt_c) +# endif + call mma_allocate(Vec,nTInt_c**2,label='Vec') + + call CD_InCore_p_w(TInt_c,nTInt_c,Wg,Vec,nTInt_c,iD_c,NumCho_c,Thr_aCD,iRC) + + if (iRC /= 0) then + call WarningMessage(2,'Error in Mk_RICD_Shells') + write(u6,*) 'Mk_aCD_Shells: CD_InCore_p(c) failed!' + call Abend() + end if +# ifdef _DEBUGPRINT_ + call RecPrt('Vec',' ',Vec,nTInt_c,NumCho_c) +# endif + call mma_deallocate(TInt_c) + call mma_deallocate(Vec) + + else ! out-of-core part + + call mma_maxDBLE(lScr) + lScr = min(lScr-2*nTInt_c,nTInt_c**2+3*nTInt_c) + call mma_Allocate(Scr,lScr,label='Scr') + + iSeed = Lu_A+1 + Lu_B = IsFreeUnit(iSeed) + call DaName_MF_WA(Lu_B,'AVEC1') + + call Get_Pivot_idx_w(ADiag,Wg,nTInt_c,NumCho_c,Lu_A,Lu_B,iD_c,Scr,lScr,Thr_aCD) + + call mma_deallocate(Scr) + call mma_deallocate(ADiag) + call DaEras(Lu_B) + call DaEras(Lu_A) + + end if + + call mma_deallocate(Wg) + +end if + +if (NumCho_c < 1) then + call WarningMessage(2,'Error in Mk_RICD_Shells') + write(u6,*) 'Mk_aCD_Shells: NumCho_c < 1 is illegal!' + call Abend() +end if + +#ifdef _DEBUGPRINT_ +write(u6,*) ' Thr_aCD:',Thr_aCD +write(u6,*) 'NumCho_c:',NumCho_c +call iVcPrt('iD_c',' ',iD_c,NumCho_c) +#endif +! * +!*********************************************************************** +!*********************************************************************** +! * +! Define AOtSO for primitive integral calculations. + +if (Do_acCD_Basis) then + iAO = 0 + iSO = 0 + nSO_p = 0 + do iAng=0,nTest + iShll_ = dbsc(iCnttp)%iVal+iAng + nCmp = nTri_Elem1(iAng) + if (Shells(iShll_)%Prjct) nCmp = 2*iAng+1 + iSO = 0 + do iCmp=1,nCmp + iAO = iAO+1 + if (iAO > nSOInf) then + write(u6,*) 'mk_acd_accd_shells: iAO>nSOInf (2)' + call Abend() + end if + iAOtSO(iAO,0) = iSO+1 + iSO = iSO+Shells(iShll_)%nExp + end do + nSO_p = nSO_p+iSO + end do +end if +! * +!*********************************************************************** +!*********************************************************************** +!*********************************************************************** +! * +! Loop through angular products. Note that all the products +! of an atom require multiple basis sets since Seward is not +! structured to handle more than one shell of a specific +! angular at the time, i.e. a basis set contains only, for +! example, one d-shell. For an atomic basis spd we will have +! the p*p and d*s resulting in two independent shells with +! the same total angular momentum, d. + +iShll = S%Mx_Shll-1 + +! Start now looping over the products and analys the result +! of the CD. Note the very peculiar loop structure over +! iBS, iAng, and jAng. This to reduce the number of +! created basis sets. + +nBS = (nTest+2)/2 +do iBS=0,nBS-1 + iAngMin = iBS + iAngMax = nTest-iBS + + nCnttp = nCnttp+1 + Keep_Basis = .false. + + if (nCnttp > Mxdbsc) then + call WarningMessage(2,'Error in Mk_RICD_Shells') + write(u6,*) 'Mk_RICD_Shells: Increase Mxdbsc' + call Abend() + end if + + ! Some generic setting of information + + dbsc(nCnttp)%Bsl = Label + dbsc(nCnttp)%Bsl_old = dbsc(nCnttp)%Bsl + dbsc(nCnttp)%pChrg = dbsc(iCnttp)%pChrg + dbsc(nCnttp)%Fixed = dbsc(iCnttp)%Fixed + dbsc(nCnttp)%Parent_iCnttp = iCnttp + dbsc(nCnttp)%iVal = iShll+1 + dbsc(nCnttp)%Aux = .true. + dbsc(nCnttp)%aCD_Thr = dbsc(iCnttp)%aCD_Thr + dbsc(nCnttp)%fMass = dbsc(iCnttp)%fMass + ! * + !********************************************************************* + ! * + ! Loop over shell pairs + + jShll = iShll + do iAng=0,iAngMax + jAngMax = min(iAng,iAngMin) + iShll_ = dbsc(iCnttp)%iVal+iAng + if (iAng == iAngMax) jAngMax = iAngMax + if (iAng < iAngMin) jAngMax = 0 + jAngMin = iAngMin + if (iAng <= iAngMin) jAngMin = 0 + do jAng=jAngMin,jAngMax + jShll_ = dbsc(iCnttp)%iVal+jAng + + iShll = iShll+1 +# ifdef _DEBUGPRINT_ + write(u6,*) + write(u6,*) 'iAng,jAng=',iAng,jAng + write(u6,*) 'iAngMax=',iAngMax +# endif + if (iShll > MxShll) then + call WarningMessage(2,'Error in Mk_RICD_Shells') + write(u6,*) 'Mk_RICD_Shells: iShll > MxShll' + write(u6,*) 'iShll,MxShll=',iShll,MxShll + call Abend() + end if + Diagonal = iAng == jAng + + ! Examine if any contracted products of these two shells + ! survived the CD procedure, or that it is an empty shell. + + Found = .false. + kShll = -1 + lShll = -1 + do iCho_c=1,NumCho_c + ijSO = iD_c(iCho_c) + kAng = iList2_c(1,ijSO) + lAng = iList2_c(2,ijSO) + if ((iAng == kAng) .and. (jAng == lAng)) then + kShll = iList2_c(7,ijSO) + lShll = iList2_c(8,ijSO) + Found = .true. + exit + end if + end do + + ! Fake Found=.FALSE. for shells which should explicitly be empty. + + Found = Found .and. (jAng >= iAngMin) .and. (iAng >= iAngMin) .and. (iAng+jAng <= Keep_Shell) + Keep_Basis = Found .or. Keep_Basis +# ifdef _DEBUGPRINT_ + write(u6,*) 'Found,kShll,lShll=',Found,kShll,lShll +# endif + ! * + !***************************************************************** + !***************************************************************** + ! * + ! P R I M I T I V E S E C T I O N + ! + ! Run in uncontracted mode to produce a SLIM + ! primitive product basis. + + if (Do_acCD_Basis .and. Found) then + + call Flip_Flop(.true.) + + ! Generate list + + npi = Shells(iShll_)%nExp + nCmpi = nTri_Elem1(iAng) + if (Shells(iShll_)%Prjct) nCmpi = 2*iAng+1 + npj = Shells(jShll_)%nExp + nCmpj = nTri_Elem1(jAng) + if (Shells(jShll_)%Prjct) nCmpj = 2*jAng+1 + if (iAng == jAng) then + nTheta_All = nTri_Elem(npi*nCmpi) + else + nTheta_All = npi*nCmpi*npj*nCmpj + end if + + call mma_allocate(iList2_p,2*mData,nTheta_all,label='iList2_p') + + ijS_Req = iTri(iAng+1,jAng+1) + + call Mk_List2(iList2_p,nTheta_All,mData,nSO_p,iCnttp,nTest,ijS_Req) + ! * + !*************************************************************** + ! * + ! Generate atomic two-electron integrals + + call Drv2El_Atomic_NoSym(Integral_RICD,ThrAO,iCnttp,iCnttp,TInt_p,nTInt_p,In_Core,ADiag,Lu_A,ijS_Req,Keep_Shell) + + if (.not. In_Core) then + call WarningMessage(2,'Error in Mk_RICD_Shells') + write(u6,*) 'Out-of-core acCD not implemented!' + call Abend() + end if +# ifdef _DEBUGPRINT_ + call RecPrt('TInt_p','(5G20.11)',TInt_p,nTInt_p,nTInt_p) +# endif + call Flip_Flop(.false.) + + end if + ! * + !***************************************************************** + !***************************************************************** + ! * + ! Now mimic the procedure of GetBS! + ! * + !***************************************************************** + ! * + ! Working on the CONTRACTED functions. + ! + ! This section is identical for acCD and aCD auxiliary basis sets! + ! * + !***************************************************************** + ! * + if (Found) then + + lAng = iAng+jAng + + ! Now figure out how many and which! + + nk = Shells(kShll)%nBasis_C + nl = Shells(lShll)%nBasis_C + if (Diagonal) then + nCntrc_Max = nTri_Elem(nk) + else + nCntrc_Max = nk*nl + end if +# ifdef _DEBUGPRINT_ + write(u6,*) 'nCntrc_Max=',nCntrc_Max +# endif + call mma_allocate(Con,nCntrc_Max,label='Con') + call mma_allocate(ConR,2,nCntrc_Max,label='ConR') + Con(:) = 0 + ConR(:,:) = 0 + nCntrc = 0 + do iCho_c=1,NumCho_c + ijSO = iD_c(iCho_c) + kAng = iList2_c(1,ijSO) + lAng = iList2_c(2,ijSO) + if ((kAng == iAng) .and. (lAng == jAng)) then + + ! Pick up the radial index! + + ik = iList2_c(5,ijSO) + il = iList2_c(6,ijSO) + + if (Diagonal) then + ikl = iTri(ik,il) + else + ikl = (il-1)*nk+ik + end if + + ! Note that this migh be done several time since several + ! angular pairs might have the same radial function! + + if (Con(ikl) == 0) then + nCntrc = nCntrc+1 + Con(ikl) = 1 + ConR(1,nCntrc) = ik +# ifdef _DEBUGPRINT_ + write(u6,*) 'iCho_c, ijSO=',iCho_c+1,ijSO +# endif + ConR(2,nCntrc) = il + end if + end if + end do ! iCho_c +# ifdef _DEBUGPRINT_ + write(u6,*) 'nCntrc=',nCntrc + call iVcPrt('Con',' ',Con,nCntrc_Max) + call iVcPrt('ConR',' ',ConR,2*nCntrc) + write(u6,*) + write(u6,*) 'ConR' + write(u6,'(30I3)') (ConR(1,i),i=1,nCntrc) + write(u6,'(30I3)') (ConR(2,i),i=1,nCntrc) +# endif + + else + + ! Let us put in an empty shell! + + nk = 0 + nl = 0 + nCntrc = 0 + end if + ! * + !***************************************************************** + ! * + ! Work on the PRIMITIVE products! + ! + ! Here the work is trivial in case of the aCD basis + ! * + !***************************************************************** + ! * + if (Found) then + ! * + !*************************************************************** + ! * + ! Produce the SLIM primitive products + ! * + !*************************************************************** + ! * + if (Do_acCD_Basis) then + + ! Now figure out how many and which! + + npk = Shells(kShll)%nExp + npl = Shells(lShll)%nExp + if (Diagonal) then + nPrim_Max = nTri_Elem(npk) + else + nPrim_Max = npk*npl + end if +# ifdef _DEBUGPRINT_ + write(u6,*) 'nPrim_Max:',nPrim_Max +# endif + call mma_allocate(Prm,nPrim_Max,label='Prm') + Prm(:) = 0 + + ! Pick up the diagonal elements from TInt_p + ! corresponding to this shell pair. We sum over + ! the angular parts identical to those of the contracted. + + ! First make a list from the contracted which angular products to include. + + call mma_allocate(TP,nPrim_Max**2,label='TP') + call mma_allocate(LTP,2,nPrim_Max,label='LTP') + call Mk_TInt_P(TInt_p,nTheta_All,TP,nPrim_Max,iList2_p,nTheta_All,2*mData,iAng,jAng,npk,LTP) + +# ifdef _DEBUGPRINT_ + call RecPrt('TIntP','(5G20.10)',TP,nPrim_Max,nPrim_Max) + call iVcPrt('List_TP',' ',LTP,2*nPrim_Max) +# endif + ! Let us now decompose and retrieve the most + ! important primitive products, indicies stored in iD_p + + call mma_allocate(iD_p,nPrim_Max,label='iD_p') + call mma_allocate(Vec,nPrim_Max**2,label='Vec') + + Thrshld_CD_p = Thr_aCD*0.2_wp + do + call CD_InCore_p(TP,nPrim_Max,Vec,nPrim_Max,iD_p,NumCho_p,Thrshld_CD_p,iRC) + if (NumCho_p < 1) then + call WarningMessage(2,'Error in Mk_RICD_Shells') + write(u6,*) 'Mk_aCD_Shells: NumCho_p < 1 is illegal!' + write(u6,*) 'iAng,jAng=',iAng,jAng + write(u6,*) 'nPrim_Max=',nPrim_Max + write(u6,*) 'NumCho_p=',NumCho_p + write(u6,*) 'iRC=',iRC + call Abend() + end if + +# ifdef _DEBUGPRINT_ + write(u6,*) 'Thrshld_CD_p:',Thrshld_CD_p + write(u6,*) 'NumCho_p :',NumCho_p + call iVcPrt('iD_p',' ',iD_p,NumCho_p) + call RecPrt('Vec',' ',Vec,nPrim_Max,NumCho_p) +# endif + if (NumCho_p >= nCntrc) exit + write(u6,*) 'W a r n i n g!' + write(u6,*) 'Fewer primitive functions than contracted functions!' + write(u6,*) 'NumCho_p=',NumCho_p + write(u6,*) ' nCntrc=',nCntrc + Thrshld_CD_p = Thrshld_CD_p*Half + if (Thrshld_CD_p <= 1.0e-14_wp) then + call WarningMessage(2,'Error in Mk_RICD_Shells') + write(u6,*) 'Thrshld_CD_p is too low!' + write(u6,*) 'iAng, jAng:',iAng,jAng + call Abend() + end if + call Mk_TInt_P(TInt_p,nTheta_All,TP,nPrim_Max,iList2_p,nTheta_All,2*mData,iAng,jAng,npk,LTP) + end do + call mma_deallocate(TP) + call mma_deallocate(Vec) + + do iCho_p=1,NumCho_p + ijSO = iD_p(iCho_p) + Prm(ijSO) = 1 + end do + nPrim = NumCho_p + call mma_allocate(Shells(iShll)%Exp,nPrim,Label='ExpacCD') + Shells(iShll)%nExp = nPrim + +# ifdef _DEBUGPRINT_ + write(u6,*) 'nPrim=',nPrim + call iVcPrt('Prm',' ',Prm,nPrim_Max) +# endif + call mma_allocate(Indkl_p,nPrim_Max,label='Indkl_p') + call Mk_Indkl(Prm,Indkl_p,nPrim_Max) + + ! Observe that the exponents are ordered according + ! to their importance as given by the CD. + + do iCho_p=1,NumCho_p + iTheta = iD_p(iCho_p) + ik = LTP(1,iTheta) + il = LTP(2,iTheta) + Exp_i = Shells(kShll)%Exp(ik) + Exp_j = Shells(lShll)%Exp(il) + Shells(iShll)%Exp(iCho_p) = Exp_i+Exp_j + end do +# ifdef _DEBUGPRINT_ + call RecPrt('SLIM Exponents',' ',Shells(iShll)%Exp,1,nPrim) +# endif + ! * + !************************************************************* + ! * + else ! Do_aCD_Basis + ! * + !************************************************************* + ! * + ! Put in the aCD set of exponents, i.e. all unique sums. + + nExpk = Shells(kShll)%nExp + nExpl = Shells(lShll)%nExp + if (Diagonal) then + nPrim = nTri_Elem(nExpk) + else + nPrim = nExpk*nExpl + end if + call mma_allocate(Shells(iShll)%Exp,nPrim,Label='ExpaCD') + Shells(iShll)%nExp = nPrim + + iOff = 0 + do ip_Exp=1,nExpk + jp_Exp_Max = nExpl + if (Diagonal) jp_Exp_Max = ip_Exp + do jp_Exp=1,jp_Exp_Max + iOff = iOff+1 + Shells(iShll)%Exp(iOff) = Shells(kShll)%Exp(ip_Exp)+Shells(lShll)%Exp(jp_Exp) + end do + end do + + if (iOff /= nPrim) then + call WarningMessage(2,'Error in Mk_RICD_Shells') + write(u6,*) 'Mk_aCD_Shell: iOff /= iEnd' + call Abend() + end if + +# ifdef _DEBUGPRINT_ + if (Diagonal) then + call TriPrt('aCD Exponents',' ',Shells(iShll)%Exp,nExpk) + else + call RecPrt('aCD Exponents',' ',Shells(iShll)%Exp,nExpk,nExpl) + end if +# endif + end if + + else + ! * + !*************************************************************** + ! * + ! An empty shell + + nPrim = 0 + Shells(iShll)%nExp = nPrim + ! * + !*************************************************************** + ! * + end if ! Found + ! + !***************************************************************** + ! + lAng = iAng+jAng + S%iAngMx = max(S%iAngMx,lAng) + S%MaxPrm(lAng) = max(S%MaxPrm(lAng),nPrim) + +# ifdef _DEBUGPRINT_ + write(u6,*) + write(u6,*) 'iShll=',iShll + write(u6,*) 'nPrim,nCntrc=',nPrim,nCntrc + write(u6,*) 'lAng=',lAng + write(u6,*) 'S%MaxPrm(lAng)=',S%MaxPrm(lAng) +# endif + + Shells(iShll)%nBasis_c = nCntrc + ! * + !***************************************************************** + ! * + call mma_allocate(Shells(iShll)%Cff_c,nPrim,nCntrc,2,Label='Cff_c') + call mma_allocate(Shells(iShll)%pCff,nPrim,nCntrc,Label='pCff') + Shells(iShll)%nBasis = nCntrc + call mma_allocate(Shells(iShll)%Cff_p,nPrim,nPrim,2,Label='Cff_p') + ! * + !***************************************************************** + ! * + ! C O N T R A C T I O N C O E F F I C I E N T S + + if (Found) then + ! * + !*************************************************************** + ! * + ! For SLIM basis sets + ! * + !*************************************************************** + ! * + if (Do_acCD_Basis) then + + ! Alright this is a bit more elaborate than for + ! the aCD basis set. Surprise! + + ! Some care has to be taken here. There might be + ! different angular products, for example, px*px + ! and px*py, which carry the same radial part but + ! have different angular part! To overcome this + ! possible source of redundancy we use the sum of + ! such terms in the fitting procedure! + + nTheta = nPrim + nExpk = Shells(kShll)%nExp + nExpl = Shells(lShll)%nExp + if (iAng == jAng) then + nTheta_Full = nTri_Elem(nExpk) + else + nTheta_Full = nExpk*nExpl + end if + nPhi = nCntrc + + ! Generate the (theta'|V|theta') matrix in the + ! SLIM primitive product basis. + + call mma_allocate(tVt,nTheta**2,label='tVt') + call Mk_tVt(TInt_p,nTInt_p,tVt,nTheta,iList2_p,2*mData,Prm,nPrim_Max,iAng,jAng,nExpk,Indkl_p,nPrim_Max) + +# ifdef _DEBUGPRINT_ + write(u6,*) + write(u6,*) 'tVt(Diag)' + write(u6,*) (tVt(i),i=1,nTheta**2,nTheta+1) + call RecPrt('tVt',' ',tVt,nTheta,nTheta) + call iVcPrt('iD_p',' ',iD_p,NumCho_p) +# endif + + ! Generate (theta'|V|theta')^{-1} + + ! Let's do a Cholesky decomposition with pivoting + ! according to the previous CD. + + nTri = nTri_Elem(nTheta) + call mma_allocate(Q,nTri,label='Q') + call mma_allocate(A,nTri,label='A') + call mma_allocate(Z,nTheta,label='Z') + do iCho_p=1,NumCho_p + iTheta_full = iD_p(iCho_p) + iTheta = Indkl_p(iTheta_full) + do jCho_p=1,iCho_p + jTheta_full = iD_p(jCho_p) + jTheta = Indkl_p(jTheta_full) + ijT = iTri(iCho_p,jCho_p) + ijS = (jTheta-1)*nTheta+iTheta + A(ijT) = tVt(ijS) + end do + end do +# ifdef _DEBUGPRINT_ + call TriPrt('A',' ',A,nTheta) + + call mma_allocate(H,nTri,label='H') + call mma_allocate(U,nTri,label='U') + H(:) = A + U(1:nTheta**2) = Zero + call dcopy_(nTheta,[One],0,U,nTheta+1) + call Jacob(H,U,nTheta,nTheta) + call TriPrt('H','(10G20.10)',H,nTheta) + call RecPrt('U',' ',U,nTheta,nTheta) + call mma_deallocate(H) + call mma_deallocate(U) +# endif + +# ifdef _DEBUGPRINT_ + call mma_allocate(tVtInv,nTheta**2,label='tVtInv') + iSing = 0 + Det = Zero + call MInv(tVt,tVtInv,iSing,Det,nTheta) + write(u6,*) 'iSing,Det=',iSing,Det +# endif + call mma_deallocate(tVt) + + do iTheta=1,nTheta + iOff_Ak = nTri_Elem(iTheta-1)+1 + iOff_Qk = nTri_Elem(iTheta-1)+1 + Thrs = Thrshld_CD_p + !Thrs = 1.0e-12_wp + call Inv_Cho_Factor(A(iOff_Ak),iTheta,A,Q,iTheta,iDum,iDum,Dummy,0,Z,Dummy,Thrs,Q(iOff_Qk),LinDep) + if (LinDep == 1) then + call WarningMessage(2,'Error in Mk_RICD_Shells') + write(u6,*) 'Mk_aCD_Shells: linear dependence found in tVt!' + write(u6,*) 'Found for vector:',iTheta + call Abend() + end if + end do + call mma_deallocate(Z) + call mma_deallocate(A) +# ifdef _DEBUGPRINT_ + call TriPrt('Q','(9G10.3)',Q,nTheta) +# endif + + ! Generate the (theta'|V|theta) matrix in the mixed product basis. + + call mma_allocate(tVp,nTheta*nPhi,label='tVp') + call mma_allocate(tVtF,nTheta*nTheta_Full,label='tVtF') + call Mk_tVtF(TInt_p,nTInt_p,tVtF,nTheta,iList2_p,2*mData,Prm,nPrim_Max,iAng,jAng,nExpk,Indkl_p,nPrim_Max,nTheta_Full) +# ifdef _DEBUGPRINT_ + call RecPrt('tVtF',' ',tVtF,nTheta,nTheta_Full) +# endif + + ! Pick up the contraction coefficients of the aCD + ! basis set. Be careful what this means in the + ! case that the shells are identical! + + call mma_allocate(Indkl,nCntrc_Max,label='Indkl') + call Mk_Indkl(Con,Indkl,nCntrc_Max) + call mma_allocate(C,nTheta_Full*nPhi,label='C') + call Mk_Coeffs(Shells(kShll)%Cff_c(1,1,1),nExpk,Shells(kShll)%nBasis_C,Shells(lShll)%Cff_c(1,1,1),nExpl, & + Shells(lShll)%nBasis_C,C,nTheta_Full,nPhi,iD_c,NumCho_c,iList2_c,2*mData,nPhi_All,Indkl,nCntrc_Max, & + Shells(kShll)%nBasis_C,iAng,jAng,Shells(kShll)%Cff_p(1,1,1),Shells(lShll)%Cff_p(1,1,1)) + call mma_deallocate(Indkl) +# ifdef _DEBUGPRINT_ + call RecPrt('C',' ',C,nTheta_Full,nPhi) +# endif + + ! Generate the (theta'|V|phi') matrix. + + call DGEMM_('N','N',nTheta,nPhi,nTheta_Full,One,tVtF,nTheta,C,nTheta_Full,Zero,tVp,nTheta) + call mma_deallocate(tVtF) +# ifdef _DEBUGPRINT_ + call RecPrt('tVp',' ',tVp,nTheta,nPhi) +# endif + call mma_deallocate(C) + + ! Generate the contraction coefficients of the + ! SLIM contracted product basis in terms of the + ! SLIM primitive product basis as + ! Sum(nu') (mu'|V|nu')^-1 (nu'|V|i')=C_{mu',i'} + + ! To simplify life I will put the Q matrix into square storage. + + call mma_Allocate(Temp,nTheta**2,label='Temp') + Temp(:) = Zero + do iTheta=1,nTheta + do jTheta=1,iTheta + ijT = iTri(iTheta,jTheta) + ijS = (iTheta-1)*nTheta+jTheta + Temp(ijS) = Q(ijT) + end do + end do + call mma_deallocate(Q) +# ifdef _DEBUGPRINT_ + call RecPrt('Q',' ',Temp,nTheta,nTheta) +# endif + + ! Resort the external index back to original + ! order. The column index is external. + + call mma_allocate(QTmp,nTheta**2,label='QTmp') + do iCho_p=1,NumCho_p + iTheta_Full = iD_p(iCho_p) + iTheta = Indkl_p(iTheta_Full) + call dcopy_(nTheta,Temp(iCho_p),nTheta,QTmp(iTheta),nTheta) + end do + call mma_deallocate(Temp) +# ifdef _DEBUGPRINT_ + call RecPrt('Q',' ',QTmp,nTheta,nTheta) + call RecPrt('tVp',' ',tVp,nTheta,nPhi) +# endif + ! Q(T) tVp + call mma_allocate(Scr,nTheta*nPhi,label='Scr') + Scr(:) = Zero + call DGEMM_('T','N',nTheta,nPhi,nTheta,One,QTmp,nTheta,tVp,nTheta,Zero,Scr,nTheta) + ! QQ(T) tVp + call DGEMM_('N','N',nTheta,nPhi,nTheta,One,QTmp,nTheta,Scr,nTheta,Zero,Shells(iShll)%Cff_c(1,1,1),nTheta) +# ifdef _DEBUGPRINT_ + call RecPrt('SLIM coeffcients',' ',Shells(iShll)%Cff_c(1,1,1),nTheta,nPhi) + Scr(:) = Zero + call DGEMM_('N','N',nTheta,nPhi,nTheta,One,tVtInv,nTheta,tVp,nTheta,Zero,Scr,nTheta) + call RecPrt('SLIM coeffcients2',' ',Scr,nTheta,nPhi) + call mma_deallocate(tVtInv) +# endif + call mma_deallocate(tVp) + + ! Now reorder the coefficients to the CD order of the exponents. + + call mma_allocate(Tmp,nTheta*nPhi,label='Tmp') + call dcopy_(nTheta*nPhi,Shells(iShll)%Cff_c(:,:,1),1,Tmp,1) + do iCho_p=1,NumCho_p + iTheta_full = iD_p(iCho_p) + iTheta = Indkl_p(iTheta_full) + call dcopy_(nPhi,Tmp(iTheta),nTheta,Shells(iShll)%Cff_c(iCho_p,1,1),nTheta) + end do + call mma_deallocate(Tmp) + + ! Modify from coefficients for normalized + ! Gaussians to unnormalized Gaussians. + + do iCho_p=1,NumCho_p + iTheta = iD_p(iCho_p) + ik = LTP(1,iTheta) + il = LTP(2,iTheta) + Fact = Shells(kShll)%Cff_p(ik,ik,1)*Shells(lShll)%Cff_p(il,il,1) + Shells(iShll)%Cff_c(iCho_p,:,1) = Fact*Shells(iShll)%Cff_c(iCho_p,:,1) + end do + call mma_deallocate(LTP) + + call mma_deallocate(iD_p) + call mma_deallocate(Indkl_p) + call mma_deallocate(Scr) + call mma_deallocate(QTmp) +# ifdef _DEBUGPRINT_ + call RecPrt('SLIM coeffcients',' ',Shells(iShll)%Cff_c(:,:,1),nTheta,nPhi) +# endif + ! * + !************************************************************* + ! * + else ! Do_aCD_Basis + ! * + !************************************************************* + ! * + ! Put in the selected set of coeffients. Note + ! again that the order should be that according + ! to the CD in order to prepivot, since the CD + ! itself is implemented without pivoting. + + do iCntrc=1,nCntrc + kC = ConR(1,iCntrc) + lC = ConR(2,iCntrc) +# ifdef _DEBUGPRINT_ + write(u6,*) 'kC,lC=',kC,lC +# endif + ! * + !*********************************************************** + ! * + ! Form the unnormalized coefficients! + + jkl = 0 + if (Diagonal) then + do iExp_k=1,Shells(kShll)%nExp + + Coeff_kk = Shells(kShll)%Cff_c(iExp_k,kC,1) + Coeff_lk = Shells(lShll)%Cff_c(iExp_k,lC,1) + + do iExp_l=1,iExp_k + + Coeff_ll = Shells(lShll)%Cff_c(iExp_l,lC,1) + Coeff_kl = Shells(kShll)%Cff_c(iExp_l,kC,1) + Coeff_ = Coeff_ll*Coeff_kk+Coeff_kl*Coeff_lk + if (iExp_k == iExp_l) then + Coeff_ = Coeff_*Half + end if + jkl = jkl+1 + + Shells(iShll)%Cff_c(jkl,iCntrc,1) = Coeff_ + + end do + end do + else + do iExp_k=1,Shells(kShll)%nExp + + Coeff_k = Shells(kShll)%Cff_c(iExp_k,kC,1) + + do iExp_l=1,Shells(lShll)%nExp + + Coeff_l = Shells(lShll)%Cff_c(iExp_l,lC,1) + + Coeff_kl = Coeff_l*Coeff_k + + jkl = jkl+1 + Shells(iShll)%Cff_c(jkl,iCntrc,1) = Coeff_kl + end do + end do + end if + + end do ! iCntrc +# ifdef _DEBUGPRINT_ + call RecPrt('aCD Coefficients','(6G20.12)',Shells(iShll)%Cff_c(1,1,1),nPrim,nCntrc) +# endif + ! * + !************************************************************* + ! * + end if + ! * + !*************************************************************** + ! * + Shells(iShll)%Cff_c(:,:,2) = Shells(iShll)%Cff_c(:,:,1) + + call mma_deallocate(Con) + call mma_deallocate(ConR) + if (Do_acCD_Basis) call mma_deallocate(Prm) + + ! Put in unit matrix of uncontracted set + + Shells(iShll)%Cff_p(:,:,1) = Zero + do i=1,nPrim + Shells(iShll)%Cff_p(i,i,1) = One + end do + + Shells(iShll)%Cff_p(:,:,2) = Shells(iShll)%Cff_p(:,:,1) + call Nrmlz(Shells(iShll)%Exp,nPrim,Shells(iShll)%Cff_p(1,1,1),nPrim,lAng) +# ifdef _DEBUGPRINT_ + call RecPrt('uncon1',' ',Shells(iShll)%Cff_p(:,:,1),nPrim,nPrim) + call RecPrt('uncon2',' ',Shells(iShll)%Cff_p(:,:,2),nPrim,nPrim) +# endif + + ! OK let's do the correction now! + +# ifdef _DEBUGPRINT_ + call RecPrt('Coefficients 10',' ',Shells(iShll)%Cff_c(:,:,1),nPrim,nCntrc) + iOff = nPrim*nCntrc + call RecPrt('Coefficients 20',' ',Shells(iShll)%Cff_c(:,:,2),nPrim,nCntrc) +# endif + iOff = nPrim*nCntrc + call Fix_Coeff(nPrim,nCntrc,Shells(iShll)%Cff_c(:,:,2),Shells(iShll)%Cff_p(:,:,1),'F') +# ifdef _DEBUGPRINT_ + call RecPrt('Coefficients 1',' ',Shells(iShll)%Cff_c(:,:,1),nPrim,nCntrc) + iOff = nPrim*nCntrc + call RecPrt('Coefficients 2','(6G20.13)',Shells(iShll)%Cff_c(:,:,2),nPrim,nCntrc) +# endif + + ! Now remove any primitives with all zero coefficents! + + call Fix_Exponents(nPrim,mPrim,nCntrc,Shells(iShll)%Exp,Shells(iShll)%Cff_c,Shells(iShll)%Cff_p) + nPrim = mPrim + Shells(iShll)%nExp = nPrim +# ifdef _DEBUGPRINT_ + call RecPrt('Coefficients 1',' ',Shells(iShll)%Cff_c(:,:,1),nPrim,nCntrc) + iOff = nPrim*nCntrc + call RecPrt('Coefficients 2',' ',Shells(iShll)%Cff_c(:,:,2),nPrim,nCntrc) +# endif + end if + + Shells(iShll)%nBasis = Shells(iShll)%nBasis_c + if ((jAng == 0) .and. Found) then + Shells(iShll)%Transf = Shells(kShll)%Transf + Shells(iShll)%Prjct = Shells(kShll)%Prjct + else + Shells(iShll)%Transf = .true. + Shells(iShll)%Prjct = .false. + end if + Shells(iShll)%Aux = .true. + + if (Do_acCD_Basis .and. Found) then + call mma_deallocate(iList2_p) + call mma_deallocate(TInt_p) + end if + Shells(iShll)%pCff(:,:) = Shells(iShll)%Cff_c(:,:,1) + + end do ! jAng + end do ! iAng + + dbsc(nCnttp)%nVal = iShll-jShll + dbsc(nCnttp)%nShells = dbsc(nCnttp)%nVal + ! * + !********************************************************************* + !********************************************************************* + !********************************************************************* + ! * + if (Keep_Basis) then + if (Show .and. (nPrint(2) >= 6)) then + write(u6,*) + write(u6,*) + write(u6,'(1X,A,I5,A,A)') 'Basis Set ',nCnttp,' Label: ',BSLbl(1:Indx-1) + write(u6,'(1X,A)') 'On-the-fly basis set generation' + end if + + ! Transfer the coordinate information + + nCnt = dbsc(iCnttp)%nCntr + dbsc(nCnttp)%nCntr = nCnt + dbsc(nCnttp)%mdci = mdc + ! Create a pointer to the actual coordinates + dbsc(nCnttp)%Coor => dbsc(iCnttp)%Coor(1:3,1:nCnt) + + ! Compute the number of elements stored in the dynamic memory so far. + S%Mx_Shll = iShll+1 + Max_Shells = S%Mx_Shll + S%Mx_mdc = mdc + + else + + ! If all the shells are empty, skip the whole basis set! + + nCnttp = nCnttp-1 + end if + +end do ! iBS + +! Done for this valence basis set. + +S%Mx_Shll = iShll+1 +Max_Shells = S%Mx_Shll +! * +!*********************************************************************** +! * +! Deallocate + +call mma_deallocate(iD_c) +call mma_deallocate(iList2_c) +! * +!*********************************************************************** +! * +! Let us now Gram-Schmidt orthonormalize the auxiliary basis for +! better numerics and balance. + +do jCnttp=nCnttp_start+1,nCnttp + call Renorm2(jCnttp) +end do +! * +!*********************************************************************** +! * +! Optionally add auxiliary basis set to the end of the +! temporary auxiliary basis set library. + +if (W2L) then + Lu_lib = 17 + Lu_lib = IsFreeUnit(Lu_lib) + call molcas_open(Lu_lib,'RICDLIB') + rewind(Lu_lib) + istatus = 0 + do while (istatus == 0) + read(Lu_lib,*,iostat=istatus) + end do + backspace(Lu_lib) + + do jCnttp=nCnttp_start+1,nCnttp + if (jCnttp == nCnttp_start+1) then + write(Lu_lib,'(A)') '/'//Label + else + write(Lu_lib,'(A)') Label + end if + if (jCnttp == nCnttp_start+1) then + write(Lu_lib,'(F6.2,2I10)') dbsc(jCnttp)%Charge,dbsc(jCnttp)%nVal-1,nCnttp-nCnttp_start + else + write(Lu_lib,'(F6.2, I10)') dbsc(jCnttp)%Charge,dbsc(jCnttp)%nVal-1 + end if + write(Lu_lib,*) ' Dummy reference line.' + write(Lu_lib,*) ' Dummy reference line.' + do iAng=0,dbsc(jCnttp)%nVal-1 + iShll_ = dbsc(jCnttp)%iVal+iAng + nExpi = Shells(iShll_)%nExp + iSph = 0 + if (Shells(iShll_)%Prjct) iSph = 1 + if (Shells(iShll_)%Transf) iSph = iSph+2 + write(Lu_lib,'(3I10)') nExpi,Shells(iShll_)%nBasis,iSph + + ! Skip if the shell is empty. + + if (nExpi == 0) cycle + + ! Write out the exponents + + write(Lu_lib,'(5(1X,D20.13))') (Shells(iShll_)%Exp(i),i=1,nExpi) + + ! Write out the contraction coefficients + + do i=1,nExpi + write(Lu_lib,'(5(1X,D20.13))') (Shells(iShll_)%Cff_c(i,j,1),j=1,Shells(iShll_)%nBasis) + end do + + end do + end do + close(Lu_lib) +end if + +call SOAO_Info_Free() +! * +!*********************************************************************** +! * +return + +end subroutine Mk_aCD_acCD_Shells diff -Nru openmolcas-22.02/src/ri_util/mk_coeffs.f openmolcas-22.10/src/ri_util/mk_coeffs.f --- openmolcas-22.02/src/ri_util/mk_coeffs.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_coeffs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,85 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Mk_Coeffs(CoeffA,nPrimA,nConA,CoeffB,nPrimB,nConB, - & Coeff,nTheta_Full,nPhi,iD,NumCho, - & List2,mData,nPhi_All, - & Indkl,nkl,nk,nl,iAng,jAng, - & CoeffAP,CoeffBP) - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 CoeffA(nPrimA,nConA), CoeffB(nPrimB,nConB), - & Coeff(nTheta_Full,nPhi), - & CoeffAP(nPrimA,nPrimA), CoeffBP(nPrimB,nPrimB) - Integer List2(mData,nPhi_All), iD(NumCho), Indkl(nkl) -* * -************************************************************************ -* * - iTri(i,j)=Max(i,j)*(Max(i,j)-1)/2+Min(i,j) -* * -************************************************************************ -* * -* -*define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Call RecPrt('CoeffA',' ',CoeffA,nPrimA,nConA) - Call RecPrt('CoeffB',' ',CoeffB,nPrimB,nConB) - Call iVcPrt('Indkl',' ',Indkl,nkl) - Call iVcPrt('Mk_Coeffs: iD',' ',iD,NumCho) - Write (6,*) 'iAng,jAng=',iAng,jAng -#endif - Do iCho = 1, NumCho - iPhi_All = iD(iCho) - If (List2(1,iPhi_All).eq.iAng .and. - & List2(2,iPhi_All).eq.jAng) Then - ik=List2(5,iPhi_All) - il=List2(6,iPhi_All) -* - If (iAng.eq.jAng) Then - iPhi_Full = iTri(ik,il) - iPhi=Indkl(iPhi_Full) - If (iPhi.eq.0) Go To 101 - Do iPrimA = 1, nPrimA - Do iPrimB = 1, iPrimA - Cff =(CoeffA(iPrimA,ik)*CoeffB(iPrimB,il) - & + CoeffA(iPrimA,il)*CoeffB(iPrimB,ik))/ - & (CoeffAP(iPrimA,iPrimA)* - & CoeffBP(iPrimB,iPrimB)) - If (iPrimA.eq.iPrimB) Cff = Half * Cff - iTheta_Full=iPrimA*(iPrimA-1)/2 + iPrimB - Coeff(iTheta_Full,iPhi) = Cff - End Do - End Do - Else - iPhi_Full = (il-1)*nk + ik - iPhi=Indkl(iPhi_Full) - If (iPhi.eq.0) Go To 101 - Do iPrimA = 1, nPrimA - Do iPrimB = 1, nPrimB - Cff = CoeffA(iPrimA,ik)*CoeffB(iPrimB,il)/ - & (CoeffAP(iPrimA,iPrimA)* - & CoeffBP(iPrimB,iPrimB)) - iTheta_Full=(iPrimB-1)*nPrimA + iPrimA - Coeff(iTheta_Full,iPhi) = Cff - End Do - End Do - End If - 101 Continue -* - End If - End Do -#ifdef _DEBUGPRINT_ - Call RecPrt('Coeff',' ',Coeff,nTheta_Full,nPhi) -#endif -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(nl) - End diff -Nru openmolcas-22.02/src/ri_util/mk_coeffs.F90 openmolcas-22.10/src/ri_util/mk_coeffs.F90 --- openmolcas-22.02/src/ri_util/mk_coeffs.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_coeffs.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,78 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Mk_Coeffs(CoeffA,nPrimA,nConA,CoeffB,nPrimB,nConB,Coeff,nTheta_Full,nPhi,iD,NumCho,List2,mData,nPhi_All,Indkl,nkl,nk, & + iAng,jAng,CoeffAP,CoeffBP) + +use Index_Functions, only: iTri +use Constants, only: Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nPrimA, nConA, nPrimB, nConB, nTheta_Full, nPhi, NumCho, iD(NumCho), mData, nPhi_All, & + List2(mData,nPhi_All), nkl, Indkl(nkl), nk, iAng, jAng +real(kind=wp), intent(in) :: CoeffA(nPrimA,nConA), CoeffB(nPrimB,nConB), CoeffAP(nPrimA,nPrimA), CoeffBP(nPrimB,nPrimB) +real(kind=wp), intent(out) :: Coeff(nTheta_Full,nPhi) +integer(kind=iwp) :: iCho, ik, il, iPhi, iPhi_All, iPhi_Full, iPrimA, iPrimB, iTheta_Full +real(kind=wp) :: Cff + +! * +!*********************************************************************** +! * + +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +call RecPrt('CoeffA',' ',CoeffA,nPrimA,nConA) +call RecPrt('CoeffB',' ',CoeffB,nPrimB,nConB) +call iVcPrt('Indkl',' ',Indkl,nkl) +call iVcPrt('Mk_Coeffs: iD',' ',iD,NumCho) +write(u6,*) 'iAng,jAng=',iAng,jAng +#endif +do iCho=1,NumCho + iPhi_All = iD(iCho) + if ((List2(1,iPhi_All) == iAng) .and. (List2(2,iPhi_All) == jAng)) then + ik = List2(5,iPhi_All) + il = List2(6,iPhi_All) + + if (iAng == jAng) then + iPhi_Full = iTri(ik,il) + iPhi = Indkl(iPhi_Full) + if (iPhi == 0) cycle + do iPrimA=1,nPrimA + do iPrimB=1,iPrimA + Cff = (CoeffA(iPrimA,ik)*CoeffB(iPrimB,il)+CoeffA(iPrimA,il)*CoeffB(iPrimB,ik))/ & + (CoeffAP(iPrimA,iPrimA)*CoeffBP(iPrimB,iPrimB)) + if (iPrimA == iPrimB) Cff = Half*Cff + iTheta_Full = iTri(iPrimA,iPrimB) + Coeff(iTheta_Full,iPhi) = Cff + end do + end do + else + iPhi_Full = (il-1)*nk+ik + iPhi = Indkl(iPhi_Full) + if (iPhi == 0) cycle + do iPrimA=1,nPrimA + do iPrimB=1,nPrimB + iTheta_Full = (iPrimB-1)*nPrimA+iPrimA + Coeff(iTheta_Full,iPhi) = CoeffA(iPrimA,ik)*CoeffB(iPrimB,il)/(CoeffAP(iPrimA,iPrimA)*CoeffBP(iPrimB,iPrimB)) + end do + end do + end if + + end if +end do +#ifdef _DEBUGPRINT_ +call RecPrt('Coeff',' ',Coeff,nTheta_Full,nPhi) +#endif + +return + +end subroutine Mk_Coeffs diff -Nru openmolcas-22.02/src/ri_util/mk_dummy_shell.f openmolcas-22.10/src/ri_util/mk_dummy_shell.f --- openmolcas-22.02/src/ri_util/mk_dummy_shell.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_dummy_shell.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,105 +0,0 @@ - -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 2008, Roland Lindh * -************************************************************************ - Subroutine Mk_Dummy_Shell() -************************************************************************ -* * -* Add the final DUMMY SHELL! * -* * -* 2008 R. Lindh, Dept. of Theor. Chem., Univ. of Lund, Sweden * -************************************************************************ - use Basis_Info - use Center_Info - use Sizes_of_Seward, only: S - Implicit Real*8 (A-H,O-Z) - External Integral_RICD, Integral_RI_2 -#include "Molcas.fh" -#include "SysDef.fh" -#include "real.fh" -#include "stdalloc.fh" -* * -************************************************************************ -* * - iShll = S%Mx_Shll - 1 - mdc = dbsc(nCnttp)%mdci + dbsc(nCnttp)%nCntr - nCnttp = nCnttp + 1 - If (nCnttp.gt.Mxdbsc) Then - Call WarningMessage(2,'Mk_Dummy_Shell: Increase Mxdbsc') - Call Abend() - End If - dbsc(nCnttp)%iVal = iShll + 1 - dbsc(nCnttp)%nVal = 1 - dbsc(nCnttp)%nShells = dbsc(nCnttp)%nVal -* - dbsc(nCnttp)%Bsl='.....RI_Dummy' - dbsc(nCnttp)%AtmNr=1 - dbsc(nCnttp)%Aux=.True. - dbsc(nCnttp)%Charge=Zero -* - nPrim=1 - nCntrc=1 -* - iShll = iShll + 1 - Shells(iShll)%Aux = .True. - Call mma_allocate(Shells(iShll)%Exp,nPrim,Label='ExpDummy') - Shells(iShll)%nExp=nPrim - Shells(iShll)%nBasis=nCntrc - Shells(iShll)%nBasis_c = nCntrc -* Exponent - Shells(iShll)%Exp(1)=Zero -* Coefficients - Call mma_allocate(Shells(iShll)%Cff_c,nPrim,nCntrc,2, - & Label='Cff_c') - Call mma_allocate(Shells(iShll)%pCff,nPrim,nCntrc, - & Label='pCff') - Call mma_allocate(Shells(iShll)%Cff_p,nPrim,nPrim ,2, - & Label='Cff_p') - Shells(iShll)%Cff_c(1,1,1)=One - Shells(iShll)%Cff_c(1,1,2)=One - Shells(iShll)%pCff(:,:) = Shells(iShll)%Cff_c(:,:,1) -* - Shells(iShll)%Transf=.False. - Shells(iShll)%Prjct =.False. -* -*-----The coordinates -* - nCnt = 1 - n_dc=max(mdc+nCnt,n_dc) - If (mdc+nCnt.gt.MxAtom) Then - Call WarningMessage(2,'Mk_Dummy_Shell: Increase MxAtom') - Call Abend() - End If - dbsc(nCnttp)%mdci=mdc - dc(mdc+nCnt)%LblCnt = 'Origin' - If (mdc+nCnt.gt.1) Call Chk_LblCnt(dc(mdc+nCnt)%LblCnt,mdc+nCnt-1) - Call mma_allocate(dbsc(nCnttp)%Coor_Hidden,3,1,Label='dbsc:C') - dbsc(nCnttp)%Coor => dbsc(nCnttp)%Coor_Hidden(:,:) - dbsc(nCnttp)%Coor(1:3,1:1)=Zero - dbsc(nCnttp)%nCntr = nCnt - mdc = mdc + nCnt -* * -************************************************************************ -* * - S%Mx_Shll=iShll+1 - Max_Shells=S%Mx_Shll - S%Mx_mdc=mdc -* - If (iCnttp_Dummy.ne.0) Then - Write (6,*) 'Mk_dummy_shell: iCnttp_Dummy' - Call Abend() - End If - iCnttp_Dummy=nCnttp -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/ri_util/mk_dummy_shell.F90 openmolcas-22.10/src/ri_util/mk_dummy_shell.F90 --- openmolcas-22.02/src/ri_util/mk_dummy_shell.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_dummy_shell.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,107 @@ + +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 2008, Roland Lindh * +!*********************************************************************** + +subroutine Mk_Dummy_Shell() +!*********************************************************************** +! * +! Add the final DUMMY SHELL! * +! * +! 2008 R. Lindh, Dept. of Theor. Chem., Univ. of Lund, Sweden * +!*********************************************************************** + +use Basis_Info, only: dbsc, iCnttp_Dummy, Max_Shells, nCnttp, Shells +use Center_Info, only: dc, n_dc +use Sizes_of_Seward, only: S +use stdalloc, only: mma_allocate +use Constants, only: Zero, One +use Definitions, only: iwp, u6 + +implicit none +#include "Molcas.fh" +integer(kind=iwp) :: iShll, mdc, nCnt, nCntrc, nPrim + +! * +!*********************************************************************** +! * +iShll = S%Mx_Shll-1 +mdc = dbsc(nCnttp)%mdci+dbsc(nCnttp)%nCntr +nCnttp = nCnttp+1 +if (nCnttp > Mxdbsc) then + call WarningMessage(2,'Mk_Dummy_Shell: Increase Mxdbsc') + call Abend() +end if +dbsc(nCnttp)%iVal = iShll+1 +dbsc(nCnttp)%nVal = 1 +dbsc(nCnttp)%nShells = dbsc(nCnttp)%nVal + +dbsc(nCnttp)%Bsl = '.....RI_Dummy' +dbsc(nCnttp)%AtmNr = 1 +dbsc(nCnttp)%Aux = .true. +dbsc(nCnttp)%Charge = Zero + +nPrim = 1 +nCntrc = 1 + +iShll = iShll+1 +Shells(iShll)%Aux = .true. +call mma_allocate(Shells(iShll)%Exp,nPrim,Label='ExpDummy') +Shells(iShll)%nExp = nPrim +Shells(iShll)%nBasis = nCntrc +Shells(iShll)%nBasis_c = nCntrc +! Exponent +Shells(iShll)%Exp(1) = Zero +! Coefficients +call mma_allocate(Shells(iShll)%Cff_c,nPrim,nCntrc,2,Label='Cff_c') +call mma_allocate(Shells(iShll)%pCff,nPrim,nCntrc,Label='pCff') +call mma_allocate(Shells(iShll)%Cff_p,nPrim,nPrim,2,Label='Cff_p') +Shells(iShll)%Cff_c(1,1,1) = One +Shells(iShll)%Cff_c(1,1,2) = One +Shells(iShll)%pCff(:,:) = Shells(iShll)%Cff_c(:,:,1) + +Shells(iShll)%Transf = .false. +Shells(iShll)%Prjct = .false. + +! The coordinates + +nCnt = 1 +n_dc = max(mdc+nCnt,n_dc) +if (mdc+nCnt > MxAtom) then + call WarningMessage(2,'Mk_Dummy_Shell: Increase MxAtom') + call Abend() +end if +dbsc(nCnttp)%mdci = mdc +dc(mdc+nCnt)%LblCnt = 'Origin' +if (mdc+nCnt > 1) call Chk_LblCnt(dc(mdc+nCnt)%LblCnt,mdc+nCnt-1) +call mma_allocate(dbsc(nCnttp)%Coor_Hidden,3,1,Label='dbsc:C') +dbsc(nCnttp)%Coor => dbsc(nCnttp)%Coor_Hidden(:,:) +dbsc(nCnttp)%Coor(1:3,1:1) = Zero +dbsc(nCnttp)%nCntr = nCnt +mdc = mdc+nCnt +! * +!*********************************************************************** +! * +S%Mx_Shll = iShll+1 +Max_Shells = S%Mx_Shll +S%Mx_mdc = mdc + +if (iCnttp_Dummy /= 0) then + write(u6,*) 'Mk_dummy_shell: iCnttp_Dummy' + call Abend() +end if +iCnttp_Dummy = nCnttp +! * +!*********************************************************************** +! * +return + +end subroutine Mk_Dummy_Shell diff -Nru openmolcas-22.02/src/ri_util/mk_indkl.f openmolcas-22.10/src/ri_util/mk_indkl.f --- openmolcas-22.02/src/ri_util/mk_indkl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_indkl.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Mk_Indkl(Indkl_OnOff,Indkl,nkl) - Implicit Real*8 (a-h,o-z) - Integer Indkl_OnOff(nkl), Indkl(nkl) -* -*define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Call iVcPrt('Mk_Indkl: Indkl_OnOff',' ',Indkl_OnOff,nkl) -#endif - ikl = 0 - Do jkl = 1, nkl - If (Indkl_OnOff(jkl).eq.1) Then - ikl = ikl + 1 - Indkl(jkl)=ikl - Else - Indkl(jkl)=0 - End If - End Do -#ifdef _DEBUGPRINT_ - Call iVcPrt('Mk_Indkl: Indkl',' ',Indkl,nkl) -#endif -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/mk_indkl.F90 openmolcas-22.10/src/ri_util/mk_indkl.F90 --- openmolcas-22.02/src/ri_util/mk_indkl.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_indkl.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,40 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Mk_Indkl(Indkl_OnOff,Indkl,nkl) + +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: nkl, Indkl_OnOff(nkl) +integer(kind=iwp), intent(out) :: Indkl(nkl) +integer(kind=iwp) :: ikl, jkl + +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +call iVcPrt('Mk_Indkl: Indkl_OnOff',' ',Indkl_OnOff,nkl) +#endif +ikl = 0 +do jkl=1,nkl + if (Indkl_OnOff(jkl) == 1) then + ikl = ikl+1 + Indkl(jkl) = ikl + else + Indkl(jkl) = 0 + end if +end do +#ifdef _DEBUGPRINT_ +call iVcPrt('Mk_Indkl: Indkl',' ',Indkl,nkl) +#endif + +return + +end subroutine Mk_Indkl diff -Nru openmolcas-22.02/src/ri_util/mk_iso2ind.f openmolcas-22.10/src/ri_util/mk_iso2ind.f --- openmolcas-22.02/src/ri_util/mk_iso2ind.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_iso2ind.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,45 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Mk_iSO2Ind(iSO2Sh,iSO2Ind,nSO,nShell) -#include "stdalloc.fh" - Integer iSO2Sh(nSO), iSO2Ind(nSO) -* - Integer, Allocatable :: nTemp(:) - - Call mma_allocate(nTemp,nShell,Label='nTemp') - Call Mk_iSO2Ind_(iSO2Sh,iSO2Ind,nSO,nTemp,nShell) - Call mma_deallocate(nTemp) -* - Return - End - Subroutine Mk_iSO2Ind_(iSO2Sh,iSO2Ind,nSO,nTemp,nShell) - use Basis_Info, only: nBas_Aux - use Symmetry_Info, only: nIrrep - Integer iSO2Sh(nSO), iSO2Ind(nSO), nTemp(nShell) -* - iSO = 0 - Do iIrrep = 0, nIrrep-1 -* - Call IZero(nTemp,nShell) - Do iB = 1, nBas_Aux(iIrrep) - iSO = iSO + 1 - iSh = iSO2Sh(iSO) - nTemp(iSh) = nTemp(iSh) + 1 - Ind = nTemp(iSh) -C Write (*,*) 'iSO,iSh,Ind=',iSO,iSh,Ind - iSO2Ind(iSO)=Ind - End Do -* - End Do -C Call iVcPrt('iSO2Ind','(10I5)',iSO2Ind,nSO) -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/mk_iso2ind.F90 openmolcas-22.10/src/ri_util/mk_iso2ind.F90 --- openmolcas-22.02/src/ri_util/mk_iso2ind.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_iso2ind.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,47 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Mk_iSO2Ind(iSO2Sh,iSO2Ind,nSO,nShell) + +use Basis_Info, only: nBas_Aux +use Symmetry_Info, only: nIrrep +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: nSO, iSO2Sh(nSO), nShell +integer(kind=iwp), intent(out) :: iSO2Ind(nSO) +integer(kind=iwp) :: iB, iIrrep, Ind, iSh, iSO +integer(kind=iwp), allocatable :: nTemp(:) + +call mma_allocate(nTemp,nShell,Label='nTemp') + +iSO = 0 +do iIrrep=0,nIrrep-1 + + nTemp(:) = 0 + do iB=1,nBas_Aux(iIrrep) + iSO = iSO+1 + iSh = iSO2Sh(iSO) + nTemp(iSh) = nTemp(iSh)+1 + Ind = nTemp(iSh) + !write(u6,*) 'iSO,iSh,Ind=',iSO,iSh,Ind + iSO2Ind(iSO) = Ind + end do + +end do +!call iVcPrt('iSO2Ind','(10I5)',iSO2Ind,nSO) + +call mma_deallocate(nTemp) + +return + +end subroutine Mk_iSO2Ind diff -Nru openmolcas-22.02/src/ri_util/mk_list2.f openmolcas-22.10/src/ri_util/mk_list2.f --- openmolcas-22.02/src/ri_util/mk_list2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_list2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,107 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Mk_List2(List2,nTheta_All,mData,nSO_Tot,iCnttp,nTest, - & ijS_req) - Use Basis_Info, only: dbsc, Shells -#include "stdalloc.fh" - Integer List2(2*mData,nTheta_All) - Logical Only_DB - - Integer, allocatable:: iList(:,:) -* - Call mma_allocate(iList,mData,nSO_Tot,Label='iList') -* - Only_DB=ijS_req.ne.0 -* -* Generate intermediate list -* Generate list2, shell blocked! -* - ijSO=0 - iiSO=0 - iSO_= 0 - Do iAng = 0, nTest - iShll = dbsc(iCnttp)%iVal + iAng - nCmp = (iAng+1)*(iAng+2)/2 - If (Shells(iShll)%Prjct) nCmp = 2*iAng+1 - nSO=nCmp*Shells(iShll)%nBasis - Do iCmp = 1, nCmp - nCont = Shells(iShll)%nBasis - Do iCont = 1, nCont - iSO_= iSO_+ 1 - iList(1,iSO_)=iAng - iList(2,iSO_)=iCmp - iList(3,iSO_)=iCont - iList(4,iSO_)=iShll - End Do - End Do -C Write (6,*) 'iSO_=',iSO_ -* - jjSO=0 - Do jAng = 0, iAng -C Write (6,*) 'iAng,jAng=',iAng,jAng - jShll = dbsc(iCnttp)%iVal + jAng - mCmp = (jAng+1)*(jAng+2)/2 - If (Shells(jShll)%Prjct) mCmp = 2*jAng+1 -* - mSO=mCmp*Shells(jShll)%nBasis -* - ijS=(iAng+1)*iAng/2+jAng+1 -* - If (.NOT.Only_DB .or. ijS.eq.ijS_req) Then - Do iSO = iiSO+1, iiSO+nSO - iAng_ =iList(1,iSO) - iCmp_ =iList(2,iSO) - iCont_=iList(3,iSO) - iShll_=iList(4,iSO) -* - jSO_Max=jjSO+mSO - If (jAng.eq.iAng) jSO_Max=iSO - Do jSO = jjSO+1, jSO_Max - ijSO=ijSO+1 - jAng_ =iList(1,jSO) - jCmp_ =iList(2,jSO) - jCont_=iList(3,jSO) - jShll_=iList(4,jSO) -* -C Write (*,*) 'iSO,jSO,ijSO=',iSO,jSO,ijSO - List2(1,ijSO)=iAng_ - List2(2,ijSO)=jAng_ - List2(3,ijSO)=iCmp_ - List2(4,ijSO)=jCmp_ - List2(5,ijSO)=iCont_ - List2(6,ijSO)=jCont_ - List2(7,ijSO)=iShll_ - List2(8,ijSO)=jShll_ - End Do ! jSO - End Do ! iSO -* - End If -* - jjSO=jjSO+mSO - End Do ! jAng -* - iiSO=iiSO+nSO - End Do ! iAng -* -*define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Write (6,*) 'List2' - Write (6,*) ' iAng, jAng, iCmp, jCmp, iCont, ' - & //'jCont, iShll, jShll' - Do ijSO = 1, nTheta_All - Write (6,'(8I7)') (List2(i,ijSO),i=1,8) - End Do -#endif -* - Call mma_deallocate(iList) -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/mk_list2.F90 openmolcas-22.10/src/ri_util/mk_list2.F90 --- openmolcas-22.02/src/ri_util/mk_list2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_list2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,114 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Mk_List2(List2,nTheta_All,mData,nSO_Tot,iCnttp,nTest,ijS_req) + +use Index_Functions, only: iTri, nTri_Elem1 +use Basis_Info, only: dbsc, Shells +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: nTheta_All, mData, nSO_Tot, iCnttp, nTest, ijS_req +integer(kind=iwp), intent(out) :: List2(2*mData,nTheta_All) +integer(kind=iwp) :: iAng, iAng_, iCmp, iCmp_, iCont, iCont_, iiSO, ijS, ijSO, iShll, iShll_, iSO, iSO_, jAng, jAng_, jCmp_, & + jCont_, jjSO, jShll, jShll_, jSO, jSO_Max, mCmp, mSO, nCmp, nCont, nSO +logical(kind=iwp) :: Only_DB +integer(kind=iwp), allocatable :: iList(:,:) + +call mma_allocate(iList,mData,nSO_Tot,Label='iList') + +Only_DB = ijS_req /= 0 + +! Generate intermediate list +! Generate list2, shell blocked! + +ijSO = 0 +iiSO = 0 +iSO_ = 0 +do iAng=0,nTest + iShll = dbsc(iCnttp)%iVal+iAng + nCmp = nTri_Elem1(iAng) + if (Shells(iShll)%Prjct) nCmp = 2*iAng+1 + nSO = nCmp*Shells(iShll)%nBasis + do iCmp=1,nCmp + nCont = Shells(iShll)%nBasis + do iCont=1,nCont + iSO_ = iSO_+1 + iList(1,iSO_) = iAng + iList(2,iSO_) = iCmp + iList(3,iSO_) = iCont + iList(4,iSO_) = iShll + end do + end do + !write(u6,*) 'iSO_=',iSO_ + + jjSO = 0 + do jAng=0,iAng + !write(u6,*) 'iAng,jAng=',iAng,jAng + jShll = dbsc(iCnttp)%iVal+jAng + mCmp = nTri_Elem1(jAng) + if (Shells(jShll)%Prjct) mCmp = 2*jAng+1 + + mSO = mCmp*Shells(jShll)%nBasis + + ijS = iTri(iAng+1,jAng+1) + + if ((.not. Only_DB) .or. (ijS == ijS_req)) then + do iSO=iiSO+1,iiSO+nSO + iAng_ = iList(1,iSO) + iCmp_ = iList(2,iSO) + iCont_ = iList(3,iSO) + iShll_ = iList(4,iSO) + + jSO_Max = jjSO+mSO + if (jAng == iAng) jSO_Max = iSO + do jSO=jjSO+1,jSO_Max + ijSO = ijSO+1 + jAng_ = iList(1,jSO) + jCmp_ = iList(2,jSO) + jCont_ = iList(3,jSO) + jShll_ = iList(4,jSO) + + !write(u6,*) 'iSO,jSO,ijSO=',iSO,jSO,ijSO + List2(1,ijSO) = iAng_ + List2(2,ijSO) = jAng_ + List2(3,ijSO) = iCmp_ + List2(4,ijSO) = jCmp_ + List2(5,ijSO) = iCont_ + List2(6,ijSO) = jCont_ + List2(7,ijSO) = iShll_ + List2(8,ijSO) = jShll_ + end do ! jSO + end do ! iSO + + end if + + jjSO = jjSO+mSO + end do ! jAng + + iiSO = iiSO+nSO +end do ! iAng + +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +write(u6,*) 'List2' +write(u6,*) ' iAng, jAng, iCmp, jCmp, iCont, jCont, iShll, jShll' +do ijSO=1,nTheta_All + write(u6,'(8I7)') (List2(i,ijSO),i=1,8) +end do +#endif + +call mma_deallocate(iList) + +return + +end subroutine Mk_List2 diff -Nru openmolcas-22.02/src/ri_util/mk_naccd.f openmolcas-22.10/src/ri_util/mk_naccd.f --- openmolcas-22.02/src/ri_util/mk_naccd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_naccd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,72 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Mk_nacCD_Shells(kCnttp,lCnttp) -************************************************************************ -* * -* Flowchart * -* * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -************************************************************************ -* * -* Produce product basis * -* * -************************************************************************ - -* Loop over iAng and jAng -* Pick up exponents and coefficients - -************************************************************************ -* * -* aCD: Transform to auxiliary basis set * -* * -************************************************************************ - -* aCD subroutine: -* Still looping over yang and jAng -* Cholesky decomposition (only contracted + with a threshold) -* End loop - -************************************************************************ -* * -* naCD: Make the set nodeless * -************************************************************************ - -* Loop until yAng=nTest*2 (naCD shells) -* Loop over aCD shells (iAng and jAng) -* Put exponents at the "right place" i.e. grouping the similar -* shell's exponents -* End aCD loop -* Fitting of coefficients to their own original ones -* Projection of the space spanned by the auxiliary basis set formed -* by aCD methods to the space spanned by the new naCD -* (calculating AA and AB matrix elements) - -************************************************************************ -* * -* nacCD: Contract the set * -* * -************************************************************************ - -* Still looping over yAng -* Fit the primitives -* Reduce the exponents: eliminate contraction functions below the -* CD threshold -* Refit the contraction coefficients -* End loop -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(kCnttp) - Call Unused_integer(lCnttp) - End If - End diff -Nru openmolcas-22.02/src/ri_util/mk_ricd_shells.f openmolcas-22.10/src/ri_util/mk_ricd_shells.f --- openmolcas-22.02/src/ri_util/mk_ricd_shells.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_ricd_shells.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,248 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 2007,2008, Roland Lindh * -************************************************************************ - Subroutine Mk_RICD_Shells() -************************************************************************ -* * -* Objective: To generate aCD auxiliary basis sets on-the-fly. * -* * -* Called from: RdCtl_Seward * -* * -* Author: Roland Lindh, Dept. of Chem. Phys., Lund Univ., Sweden. * -* * -* Final implementation for aCD and acCD auxiliary * -* basis sets developed while visiting N. Ferre' at the * -* Univ. of Provance (champus Univ. Paul Cezanne) in * -* Marseille, France, 20 March - 19 April. * -* * -* Modified to transform the auxiliary basis to a true * -* Cholesky basis set while on TACC 2008 conference in * -* Songjiang District, Shanghai, China, 23-27 Sept. 2008. * -* * -************************************************************************ - use Real_Spherical - use Basis_Info - use Sizes_of_Seward, only: S - use RICD_Info, only: Do_acCD_Basis, Skip_High_AC, Do_nacCD_Basis, - & Thrshld_CD - Implicit Real*8 (A-H,O-Z) -#include "SysDef.fh" -#include "real.fh" -#include "print.fh" -#include "status.fh" -#include "stdalloc.fh" - Logical DoRys, Save_Logical, W2L -* * -************************************************************************ -* * -*define _DEBUGPRINT_ -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - iPrint=49 -C iPrint=99 -#endif -* * -************************************************************************ -* * -* - Call StatusLine('Gateway:', - & ' Generating aCD or acCD auxiliary basis set') -* * -************************************************************************ -* * -* Preamble: Compute kOffAO and lOffAO -* - Call Setup_OffAO() -* -* Set up transformation matrix from Cartesian to real spherical -* harmonics. -* - Call Sphere(S%iAngMx) -* -* Setup of tables for coefficients for the Rys roots and weights. -* - nDiff=0 - If (S%iAngMx.eq.0) nDiff=2 - DoRys=.True. - Call SetUp_RW(DoRys,nDiff) -* - mCnttp=nCnttp -* * -************************************************************************ -* * -* Add the DUMMY SHELL! -* - Call Mk_Dummy_Shell() -* * -************************************************************************ -************************************************************************ -* * -* Loop now over all unique valence basis sets and generate the -* corresponding aCD auxiliary basis sets. Note that there are two -* different types of aCD auxiliary basis sets, aCD and acCD. -* - Do 1100 iCnttp = 1, mCnttp - If (dbsc(iCnttp)%Frag.or.dbsc(iCnttp)%nVal.eq.0) goto 1100 -#ifdef _DEBUGPRINT_ - If (iPrint.ge.99) - & Write (6,*) 'Generating auxiliary basis set for valence basis' - & //':',iCnttp -#endif -* * -************************************************************************ -* * -* Procrastinate the printing of the RICD basis set to library -* until the last unique valence basis set is processed. -* - W2L=.True. - Do jCnttp = iCnttp+1, mCnttp - If (dbsc(iCnttp)%Bsl_old.eq.dbsc(jCnttp)%Bsl_old) Then - W2L=.False. - Exit - End If - End Do -* * -************************************************************************ -* * - If (Do_nacCD_Basis) Then - Do_acCD_Basis=.False. -* * -************************************************************************ -* * -* nacCD section -* -* Creat first a virgin aCD auxiliary basis set -* - Thrshld_CD_Save = Thrshld_CD - Thrshld_CD = Zero - Save_Logical = Skip_High_AC - Skip_High_AC = .False. -* - kCnttp = nCnttp - Call Mk_aCD_acCD_Shells(iCnttp,W2L) - lCnttp = nCnttp -* -* Now let us use the aCD auxiliary basis set to generate the -* nacCD auxiliary basis set. -* - Thrshld_CD = Thrshld_CD_Save - Skip_High_AC = Save_Logical - Call Mk_nacCD_Shells(kCnttp,lCnttp) -* -* Remove the temporary aCD auxiliary basis set -* - Do jCnttp = kCnttp+1, lCnttp - Call rm_AuxShell(jCnttp) - End Do -* * -************************************************************************ -* * - Else -* * -************************************************************************ -* * -* aCD and acCD section -* -* - Call Mk_aCD_acCD_Shells(iCnttp,W2L) -* - End If -* * -************************************************************************ -* * - 1100 Continue ! iCnttp -* * -************************************************************************ -* * - Call Set_Basis_Mode('Valence') -* * -************************************************************************ -* * -* Cleanup the mess! -* - Call CloseR() - Call Sphere_Free() -* * -************************************************************************ -* * - Return - End - Subroutine Remove_High_Exponents(iD,nD,List2,mData,nTheta_All) - Use Basis_Info, only: Shells - Implicit Real*8 (a-h,o-z) -************************************************************************ -* * -* Experimental code to be used with care. * -* * -************************************************************************ - Integer iD(nD), List2(mData,nTheta_All) - Logical Skip -* - Call iVcPrt('Remove_High_Exponents: iD',' ',iD,nD) - mD = nD - i = 1 - 100 Continue - iTheta_All=iD(i) - Skip=.False. - kAng = List2(1,iTheta_All) - lAng = List2(2,iTheta_All) - k = List2(5,iTheta_All) - l = List2(6,iTheta_All) - kShll = List2(7,iTheta_All) - lShll = List2(8,iTheta_All) - If (kAng.eq.lAng) Then - l = List2(6,iTheta_All) - Skip = (k.eq.1.and.l.eq.1).and.Shells(kShll)%nExp.ne.1 - Else - Skip=l.eq.1.and.Shells(lShll)%nExp.ne.1 - End If - If (Skip) Then - If (mD.eq.i) Then - mD = mD -1 - Go To 200 - End If - Do j = i+1, mD - iD(j-1) = iD(j) - End Do - mD = mD -1 - Go To 100 - End If - i = i + 1 - If (i.le.mD) Go To 100 - 200 Continue - nD = mD - Call iVcPrt('Remove_High_Exponents: iD',' ',iD,nD) -* - Return - End - Subroutine Mk_AngList(iAL,nCompA,nCompB, - & iD_c,nD_c, - & List2,nList2,mData, - & iAng,jAng) - Integer iAL(nCompA,nCompB), iD_c(nD_c), - & List2(mData,nList2) -* - Call IZero(iAL,nCompA*nCompB) - Do jD_c = 1, nD_c - ijSO=iD_c(jD_c) - If (List2(1,ijSO).eq.iAng .and. - & List2(2,ijSO).eq.jAng ) Then - iA = List2(3,ijSO) - iB = List2(4,ijSO) - iAL(iA,iB) = 1 - End If - End Do -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/mk_ricd_shells.F90 openmolcas-22.10/src/ri_util/mk_ricd_shells.F90 --- openmolcas-22.02/src/ri_util/mk_ricd_shells.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_ricd_shells.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,136 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 2007,2008, Roland Lindh * +!*********************************************************************** + +subroutine Mk_RICD_Shells() +!*********************************************************************** +! * +! Objective: To generate aCD auxiliary basis sets on-the-fly. * +! * +! Called from: RdCtl_Seward * +! * +! Author: Roland Lindh, Dept. of Chem. Phys., Lund Univ., Sweden. * +! * +! Final implementation for aCD and acCD auxiliary * +! basis sets developed while visiting N. Ferre' at the * +! Univ. of Provance (champus Univ. Paul Cezanne) in * +! Marseille, France, 20 March - 19 April. * +! * +! Modified to transform the auxiliary basis to a true * +! Cholesky basis set while on TACC 2008 conference in * +! Songjiang District, Shanghai, China, 23-27 Sept. 2008. * +! * +!*********************************************************************** + +use Real_Spherical, only: Sphere, Sphere_Free +use Basis_Info, only: dbsc, nCnttp +use Sizes_of_Seward, only: S +use Definitions, only: iwp + +implicit none +integer(kind=iwp) :: iCnttp, jCnttp, mCnttp, nDiff +logical(kind=iwp) :: DoRys, W2L + +! * +!*********************************************************************** +! * +!define _DEBUGPRINT_ +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +iPrint = 49 +!iPrint = 99 +#endif +! * +!*********************************************************************** +! * + +call StatusLine('Gateway:',' Generating aCD or acCD auxiliary basis set') +! * +!*********************************************************************** +! * +! Preamble: Compute kOffAO and lOffAO + +call Setup_OffAO() + +! Set up transformation matrix from Cartesian to real spherical harmonics. + +call Sphere(S%iAngMx) + +! Setup of tables for coefficients for the Rys roots and weights. + +nDiff = 0 +if (S%iAngMx == 0) nDiff = 2 +DoRys = .true. +call SetUp_RW(DoRys,nDiff) + +mCnttp = nCnttp +! * +!*********************************************************************** +! * +! Add the DUMMY SHELL! + +call Mk_Dummy_Shell() +! * +!*********************************************************************** +!*********************************************************************** +! * +! Loop now over all unique valence basis sets and generate the +! corresponding aCD auxiliary basis sets. Note that there are two +! different types of aCD auxiliary basis sets, aCD and acCD. + +do iCnttp=1,mCnttp + if (dbsc(iCnttp)%Frag .or. (dbsc(iCnttp)%nVal == 0)) cycle +# ifdef _DEBUGPRINT_ + if (iPrint >= 99) write(u6,*) 'Generating auxiliary basis set for valence basis:',iCnttp +# endif + ! * + !********************************************************************* + ! * + ! Procrastinate the printing of the RICD basis set to library + ! until the last unique valence basis set is processed. + + W2L = .true. + do jCnttp=iCnttp+1,mCnttp + if (dbsc(iCnttp)%Bsl_old == dbsc(jCnttp)%Bsl_old) then + W2L = .false. + exit + end if + end do + ! * + !********************************************************************* + ! * + ! aCD and acCD section + + call Mk_aCD_acCD_Shells(iCnttp,W2L) + ! * + !********************************************************************* + ! * +end do +! * +!*********************************************************************** +! * +call Set_Basis_Mode('Valence') +! * +!*********************************************************************** +! * +! Cleanup the mess! + +call CloseR() +call Sphere_Free() +! * +!*********************************************************************** +! * +return + +end subroutine Mk_RICD_Shells diff -Nru openmolcas-22.02/src/ri_util/mk_ri_shells.f openmolcas-22.10/src/ri_util/mk_ri_shells.f --- openmolcas-22.02/src/ri_util/mk_ri_shells.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_ri_shells.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,470 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Roland Lindh * -************************************************************************ - Subroutine Mk_RI_Shells(LuRd) -************************************************************************ -* * -* Objective: To expand the data for the auxiliary functions * -* * -* Called from: RdCtl * -* * -* Calling : GetBS * -* * -* Author: Roland Lindh * -* * -************************************************************************ - use Basis_Info - use Sizes_of_Seward, only: S - use RICD_Info, only: iRI_Type - use Gateway_Info, only: UnNorm - Implicit Real*8 (A-H,O-Z) -#include "Molcas.fh" -#include "stdalloc.fh" -#include "real.fh" -#include "print.fh" - Logical Hit, IfTest - Character*13 DefNm - Character*180 Ref(2), BSLB - Character*80 BSLbl - Character*80 atom,type,author,basis,CGTO, Aux - Character*80 atomb - Character *256 Basis_lib, Fname - Character*180, Allocatable :: STDINP(:) !CGGn - Character*180 Line, Get_Ln - External Get_Ln - Integer StrnLn - External StrnLn -#include "getlnqoe.fh" - Character*180 Get_Ln_Quit - - Integer BasisTypes(4) - Data DefNm/'basis_library'/ -* * -************************************************************************ -* * - iRout = 2 - iPrint = nPrint(iRout) -* -* Temporary setup of symmetry information -* - Call mma_allocate(STDINP,mxAtom*2,label='STDINP') - IfTest=.False. -* IfTest=.True. -* -* Add the auxiliary basis set -* - BasisTypes(1)=0 - BasisTypes(2)=0 - BasisTypes(3)=0 - BasisTypes(4)=0 - iShll = S%Mx_Shll - 1 - lSTDINP=0 - mCnttp=nCnttp -* -* Branch to special loop for reading external RICD basis sets -* since these have a different infrastructure. -* - If (iRI_Type.eq.5) Go To 1000 - - Do iCnttp = 1, mCnttp - If (dbsc(iCnttp)%Frag.or.dbsc(iCnttp)%nVal.eq.0) cycle - mdc = dbsc(iCnttp)%mdci - nCnttp=nCnttp+1 -* - If (nCnttp.gt.Mxdbsc) Then - Call WarningMessage(2,'Error in Mk_RI_Shells') - Write (6,*) 'Mk_RI_Shells: Increase Mxdbsc' - Call Abend() - End If -* -* Resolve the name of the valence basis and find the name of -* the appropriate auxiliary basis set. -* - dbsc(nCnttp)%Bsl=dbsc(iCnttp)%Bsl_old -* - Hit=.True. - Call Decode(dbsc(nCnttp)%Bsl,atom,1,Hit) - Hit=.True. - Call Decode(dbsc(nCnttp)%Bsl,type,2,Hit) - Hit=.True. - Call Decode(dbsc(nCnttp)%Bsl,author,3,Hit) - Hit=.True. - Call Decode(dbsc(nCnttp)%Bsl,basis,4,Hit) - Hit=.True. - Call Decode(dbsc(nCnttp)%Bsl,CGTO,5,Hit) - Hit=.False. - Call Decode(dbsc(nCnttp)%Bsl,Aux,6,Hit) - If (.Not.Hit) Aux = ' ' -* - n=Index(Atom,' ')-1 - dbsc(nCnttp)%Bsl(1:n+1)=atom(1:n)//'.' - nn = n + 1 -* - n=Index(Type,' ')-1 - dbsc(nCnttp)%Bsl(nn+1:nn+n+5)=Type(1:n)//'.....' -* -* Modify basis set library correctly -* - Indx=Index(dbsc(nCnttp)%Bsl,' ') - BSLbl=' ' - BSLbl(1:Indx-1)=dbsc(nCnttp)%Bsl(1:Indx-1) - Call WhichMolcas(Basis_lib) - If (Basis_lib(1:1).ne.' ') Then - ib=index(Basis_lib,' ')-1 - If(ib.lt.1) - & Call SysAbendMsg('rdCtl','Too long PATH to MOLCAS',' ') - If (iRI_Type.eq.1) Then - Fname=Basis_lib(1:ib)//'/basis_library/j_Basis' - Else If (iRI_Type.eq.2) Then - Fname=Basis_lib(1:ib)//'/basis_library/jk_Basis' - Else If (iRI_Type.eq.3) Then - Fname=Basis_lib(1:ib)//'/basis_library/c_Basis' - Else - Call WarningMessage(2,'Error in Mk_RI_Shells') - Write (6,*) 'Wrong iRI_Type!' - Write (6,*) 'iRI_Type=',iRI_Type - Call Abend() - End If - Else - If (iRI_Type.eq.1) Then - Fname=DefNm//'/j_Basis' - Else If (iRI_Type.eq.2) Then - Fname=DefNm//'/jk_Basis' - Else If (iRI_Type.eq.3) Then - Fname=DefNm//'/c_Basis' - Else - Call WarningMessage(2,'Error in Mk_RI_Shells') - Write (6,*) 'Wrong iRI_Type!' - Write (6,*) 'iRI_Type=',iRI_Type - Call Abend() - End If - End If -* - If (Show.and.iPrint.ge.6) Then - Write (6,*) - Write (6,*) - Write(6,'(1X,A,I5,A,A)') - & 'Basis Set ',nCnttp,' Label: ', BSLbl(1:Indx-1) - Write(6,'(1X,A,A)') 'Basis set is read from library:', - & Fname(1:index(Fname,' ')) - End if -* - jShll = iShll - dbsc(nCnttp)%Bsl_old=dbsc(nCnttp)%Bsl - Call GetBS(Fname,dbsc(nCnttp)%Bsl,iShll,Ref,UnNorm, - & LuRd,BasisTypes,STDINP,lSTDINP,.False.,.true.,' ') -* - dbsc(nCnttp)%Aux=.True. - dbsc(nCnttp)%Charge=Zero -* - If (Show.and.iPrint.ge.6 .and. - & Ref(1).ne.'' .and. Ref(2).ne.'') Then - Write (6,'(1x,a)') 'Basis Set Reference(s):' - If (Ref(1).ne.'') Write (6,'(5x,a)') Trim(Ref(1)) - If (Ref(2).ne.'') Write (6,'(5x,a)') Trim(Ref(2)) - Write (6,*) - Write (6,*) - End If - dbsc(nCnttp)%ECP=(dbsc(nCnttp)%nPrj - & + dbsc(nCnttp)%nSRO - & + dbsc(nCnttp)%nSOC - & + dbsc(nCnttp)%nPP - & + dbsc(nCnttp)%nM1 - & + dbsc(nCnttp)%nM2) .NE. 0 -* - lAng=Max(dbsc(nCnttp)%nVal, - & dbsc(nCnttp)%nSRO, - & dbsc(nCnttp)%nPrj)-1 - S%iAngMx=Max(S%iAngMx,lAng) -* No transformation needed for s and p shells - Shells(jShll+1)%Transf=.False. - Shells(jShll+1)%Prjct =.False. - Shells(jShll+2)%Transf=.False. - Shells(jShll+2)%Prjct =.False. - dbsc(nCnttp)%pChrg=dbsc(iCnttp)%pChrg - dbsc(nCnttp)%Fixed=dbsc(iCnttp)%Fixed - dbsc(nCnttp)%Parent_iCnttp=iCnttp - dbsc(nCnttp)%nShells = dbsc(nCnttp)%nVal - & + dbsc(nCnttp)%nPrj - & + dbsc(nCnttp)%nSRO - & + dbsc(nCnttp)%nSOC - & + dbsc(nCnttp)%nPP - - Do iSh = jShll+1, iShll - Shells(iSh)%nBasis=Shells(iSh)%nBasis_c - Call mma_deallocate(Shells(iShll)%pCff) - Call mma_allocate(Shells(iShll)%pCff, - & Shells(iSh)%nExp,Shells(iSh)%nBasis, - & Label='pCff') - Shells(iShll)%pCff(:,:) = Shells(iShll)%Cff_c(:,:,1) - Shells(iSh)%Aux=.True. - End Do -* - nCnt = dbsc(iCnttp)%nCntr - dbsc(nCnttp)%nCntr=nCnt - dbsc(nCnttp)%mdci =mdc -* Create a pointer to the actual coordinates of the parent dbsc - dbsc(nCnttp)%Coor=>dbsc(iCnttp)%Coor(1:3,1:nCnt) -* - S%Mx_Shll=iShll+1 - Max_Shells=S%Mx_Shll - S%Mx_mdc=mdc -* - End Do - Go To 1100 -* * -************************************************************************ -************************************************************************ -* * -* Specially designed loop to read a RICD auxiliary basis set from -* an external library. -* - 1000 Continue -* - Lu_lib=17 - Lu_lib=IsFreeUnit(Lu_lib) - call molcas_open(Lu_lib,'RICDLIB') -* - Do iCnttp = 1, mCnttp - If (dbsc(iCnttp)%Frag.or.dbsc(iCnttp)%nVal.eq.0) cycle - mdc = dbsc(iCnttp)%mdci -* - Hit=.True. - Call Decode(dbsc(iCnttp)%Bsl_old,atom,1,Hit) - Type=' ' - Author=' ' - basis=' ' - CGTO=' ' - Aux=' ' - If (IfTest) Then - Write (6,*) 'Bsl_Old=',dbsc(iCnttp)%Bsl_old - Write (6,*) 'Atom=',Atom - End If -* - Indx=Index(dbsc(iCnttp)%Bsl_old,' ') - BSLbl=' ' - BSLbl(1:Indx-1)=dbsc(iCnttp)%Bsl_old(1:Indx-1) -* -* Find the basis set -* - ReWind(Lu_lib) -* -* Loop over the basis set library to find the correct label -* - If (IfTest) Write (6,*) ' Locate basis set label in library' - 10 BSLB = Get_Ln_Quit(Lu_lib,0) - If (Quit_On_Error) Then - iLast3=StrnLn(BsLbl) - Call WarningMessage(2, - & 'The requested basis set label: '// - & BsLbl(:iLast3)//';'// - & 'was not found in basis library: '//'RICDLIB') - Call Abend() - End If -* - Call UpCase(BSLB) - If (BSLB(1:1).ne.'/') Go To 10 - If (IfTest) Write(6,*) 'BSLB=',BSLB - n=Index(BSLB,' ') - Do i=n,80 - BSLB(i:i)='.' - End Do - Hit=.True. - Call Decode(BSLB(2:80),atomb,1,Hit) - If (atomb.ne.atom) Go To 10 - If (IfTest) Write(6,*) 'atomb=',atomb -* -* Now we should have found the correct basis set label! -* - nSet=-1 - - Do While (nSet.ne.0) - Line=Get_Ln(Lu_lib) - If (IfTest) Then - Write(6,*) 'nSet=',nSet - Write(6,*) 'Line=',Line - End If - Call Get_I1(2,lAng) - If (nSet.eq.-1) Call Get_I1(3,nSet) - If (IfTest) Write(6,*) 'lAng,nSet=',lAng,nSet -* - Line=Get_Ln(Lu_lib) - Line=Get_Ln(Lu_lib) -* - nCnttp=nCnttp+1 - If (nCnttp.gt.Mxdbsc) Then - Call WarningMessage(2,'Error in Mk_RI_Shells') - Write (6,*) 'Mk_RI_Shells: Increase Mxdbsc' - Call Abend() - End If - If (Show.and.iPrint.ge.6) Then - Write (6,*) - Write (6,*) - Write(6,'(1X,A,I5,A,A)') - & 'Basis Set ',nCnttp,' Label: ', BSLb - Write(6,'(1X,A)') 'Basis set is read from the workdir.' - End if -* - dbsc(nCnttp)%Bsl=BSLB(2:80) - dbsc(nCnttp)%Bsl_old=dbsc(nCnttp)%Bsl -* -* Loop over the angular shells -* - jShll = iShll - Do iAng = 0, lAng - iShll=iShll+1 - Line=Get_Ln(Lu_lib) - Call Get_I1(1,nPrim) - Call Get_I1(2,nCntrc) - Call Get_I1(3,iSph) - If (IfTest) Then - Write (6,*) 'iAng=',iAng - Write (6,*) 'nPrim=',nPrim - Write (6,*) 'nCntrc=',nCntrc - Write (6,*) 'iSph=',iSph - End If -* -* Read Gaussian exponents -* - Call mma_Allocate(Shells(iShll)%Exp,nPrim,Label='ExpRI') - Shells(iShll)%nExp=nPrim - Shells(iShll)%nBasis_C = nCntrc - iEnd = iStrt - 1 - If (nPrim.gt.0) then - If (IfTest) Write(6,*) ' Read gaussian exponents' - Call Read_v(Lu_lib,Shells(iShll)%Exp,1,nPrim,1,Ierr) - If (Ierr.ne.0) Then - Call WarningMessage(2, - & 'GetBS: Error while reading the exponents') - Call Quit_OnUserError() - End If - If (IfTest) Write(6,*) ' Done with exponents' - If (iPrint.ge.99.or.IfTest) - & Call RecPrt(' Exponents',' ',Shells(iShll)%Exp,nPrim,1) - End If - iStrt = iEnd + 1 -* -* Read contraction coefficients. Storage of coefficients -* for both contracted and uncontracted case. -* - Call mma_allocate(Shells(iShll)%Cff_c,nPrim,nCntrc,2, - & Label='Cff_c') - Call mma_allocate(Shells(iShll)%pCff,nPrim,nCntrc, - & Label='pCff') - Shells(iShll)%nBasis=nCntrc - Call mma_allocate(Shells(iShll)%Cff_p,nPrim,nPrim,2, - & Label='Cff_p') - iEnds= iEnd - iEnd = iStrt - 1 -* Read contraction coefficients -* Observe that the matrix will have nPrim rows and -* nCntrc columns - If (IfTest) Write (6,*) ' Read coefficients' -* -* Read in coeffs. in GC format, as the standard case -* - If (IfTest) Write (6,*) ' Standard case' - If (nPrim*nCntrc.gt.0) Then - Shells(iShll)%Cff_c(:,:,:)=Zero -* -* Note that we now change the order!!! - Read (Lu_lib,*) ((Shells(iShll)%Cff_c(i,j,2), - & j=1,nCntrc),i=1,nPrim) - If (Ierr.ne.0) Then - Call WarningMessage(2, - & 'GetBS: Error reading coeffs in GC format') - Call Quit_OnUserError() - End If - If (IfTest) - & Call RecPrt(' Coeffs',' ',Shells(iShll)%Cff_c(1,1,2), - & nPrim,nCntrc) - Shells(iShll)%Cff_c(:,:,1) = Shells(iShll)%Cff_c(:,:,2) - If (IfTest) - & Call RecPrt(' Coeffs',' ',Shells(iShll)%Cff_c(1,1,1), - & nPrim,nCntrc) -* -* Put in unit matrix of uncontracted set -* - Shells(iShll)%Cff_p(:,:,1)=Zero - Do i=1,nPrim - Shells(iShll)%Cff_p(i,i,1)=One - End Do -* - Shells(iShll)%Cff_p(:,:,2)=Shells(iShll)%Cff_p(:,:,1) - Call Nrmlz(Shells(iShll)%Exp,nPrim, - & Shells(iShll)%Cff_p(1,1,1),nPrim ,iAng) - - Shells(iShll)%Cff_c(:,:,2)=Shells(iShll)%Cff_c(:,:,1) - Call Fix_Coeff(nPrim,nCntrc,Shells(iShll)%Cff_c(1,1,2), - & Shells(iShll)%Cff_p(1,1,1), - & 'F') - Shells(iShll)%pCff(:,:) = Shells(iShll)%Cff_c(:,:,1) - End If -* - iEnd =iEnds - If (iSph.eq.0) Then - Shells(iShll)%Transf=.False. - Shells(iShll)%Prjct =.False. - Else If (iSph.eq.1) Then - Shells(iShll)%Transf=.False. - Shells(iShll)%Prjct =.True. - Else If (iSph.eq.2) Then - Shells(iShll)%Transf=.True. - Shells(iShll)%Prjct =.False. - Else - Shells(iShll)%Transf=.True. - Shells(iShll)%Prjct =.True. - End If - - Shells(iShll)%nBasis=Shells(iShll)%nBasis_C - Shells(iShll)%Aux=.True. -* - End Do ! iAng -* - dbsc(nCnttp)%Aux=.True. - S%iAngMx=Max(S%iAngMx,lAng) -* - dbsc(nCnttp)%iVal = jShll + 1 - dbsc(nCnttp)%nVal = lAng+1 - dbsc(nCnttp)%nShells = dbsc(nCnttp)%nVal -* - nCnt = dbsc(iCnttp)%nCntr - dbsc(nCnttp)%nCntr=nCnt - dbsc(nCnttp)%mdci =mdc - dbsc(nCnttp)%Parent_iCnttp=iCnttp -* Create a pointer to the actual coordinates. - dbsc(nCnttp)%Coor=>dbsc(iCnttp)%Coor(1:3,1:nCnt) -* - S%Mx_Shll=iShll+1 - Max_Shells=S%Mx_Shll - S%Mx_mdc=mdc -* - nSet=nSet-1 - If (nSet.ne.0) Line=Get_Ln(Lu_lib) - End Do ! Do While (nSet.ne.0) -* - End Do ! iCnttp -* - Close(Lu_lib) -* * -************************************************************************ -* * -* Add the final DUMMY SHELL! -* - 1100 Continue - Call Mk_Dummy_Shell() - Call mma_deallocate(STDINP) -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/ri_util/mk_ri_shells.F90 openmolcas-22.10/src/ri_util/mk_ri_shells.F90 --- openmolcas-22.02/src/ri_util/mk_ri_shells.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_ri_shells.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,434 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Roland Lindh * +!*********************************************************************** + +subroutine Mk_RI_Shells(LuRd) +!*********************************************************************** +! * +! Objective: To expand the data for the auxiliary functions * +! * +! Called from: RdCtl * +! * +! Calling : GetBS * +! * +! Author: Roland Lindh * +! * +!*********************************************************************** + +use Basis_Info, only: dbsc, Max_Shells, nCnttp, Shells +use Sizes_of_Seward, only: S +use RICD_Info, only: iRI_Type +use Gateway_Info, only: UnNorm +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: LuRd +#include "Molcas.fh" +#include "print.fh" +#include "getlnqoe.fh" +integer(kind=iwp) :: BasisTypes(4), i, iAng, ib, iCnttp, iEnd, iEnds, Ierr, iLast3, Indx, iPrint, iRout, iSh, iShll, iSph, iStrt, & + j, jShll, lAng, lSTDINP, Lu_lib, mCnttp, mdc, n, nCnt, nCntrc, nn, nPrim, nSet +logical(kind=iwp) :: Hit, IfTest +character(len=256) :: Basis_lib, Fname +character(len=180) :: BSLB, Line, Ref(2) +character(len=80) :: atom, atomb, author, Aux, basis, BSLbl, btype, CGTO +character(len=180), allocatable :: STDINP(:) !CGGn +integer(kind=iwp), external :: IsFreeUnit, StrnLn +character(len=180), external :: Get_Ln, Get_Ln_Quit +character(len=*), parameter :: DefNm = 'basis_library' + +! * +!*********************************************************************** +! * +iRout = 2 +iPrint = nPrint(iRout) + +! Temporary setup of symmetry information + +call mma_allocate(STDINP,mxAtom*2,label='STDINP') +IfTest = .false. +!IfTest = .true. + +! Add the auxiliary basis set + +BasisTypes(:) = 0 +iShll = S%Mx_Shll-1 +lSTDINP = 0 +mCnttp = nCnttp + +! Branch to special loop for reading external RICD basis sets +! since these have a different infrastructure. + +if (iRI_Type == 5) then + ! * + !********************************************************************* + !********************************************************************* + ! * + ! Specially designed loop to read a RICD auxiliary basis set from + ! an external library. + + Lu_lib = 17 + Lu_lib = IsFreeUnit(Lu_lib) + call molcas_open(Lu_lib,'RICDLIB') + + do iCnttp=1,mCnttp + if (dbsc(iCnttp)%Frag .or. (dbsc(iCnttp)%nVal == 0)) cycle + mdc = dbsc(iCnttp)%mdci + + Hit = .true. + call Decode(dbsc(iCnttp)%Bsl_old,atom,1,Hit) + btype = ' ' + Author = ' ' + basis = ' ' + CGTO = ' ' + Aux = ' ' + if (IfTest) then + write(u6,*) 'Bsl_Old=',dbsc(iCnttp)%Bsl_old + write(u6,*) 'Atom=',Atom + end if + + Indx = index(dbsc(iCnttp)%Bsl_old,' ') + BSLbl = ' ' + BSLbl(1:Indx-1) = dbsc(iCnttp)%Bsl_old(1:Indx-1) + + ! Find the basis set + + rewind(Lu_lib) + + ! Loop over the basis set library to find the correct label + + if (IfTest) write(u6,*) ' Locate basis set label in library' + do + BSLB = Get_Ln_Quit(Lu_lib,0) + if (Quit_On_Error) then + iLast3 = StrnLn(BsLbl) + call WarningMessage(2,'The requested basis set label: '//BsLbl(:iLast3)//';was not found in basis library: RICDLIB') + call Abend() + end if + + call UpCase(BSLB) + if (BSLB(1:1) /= '/') cycle + if (IfTest) write(u6,*) 'BSLB=',BSLB + n = index(BSLB,' ') + do i=n,80 + BSLB(i:i) = '.' + end do + Hit = .true. + call Decode(BSLB(2:80),atomb,1,Hit) + if (atomb == atom) exit + end do + if (IfTest) write(u6,*) 'atomb=',atomb + + ! Now we should have found the correct basis set label! + + nSet = -1 + + do while (nSet /= 0) + Line = Get_Ln(Lu_lib) + if (IfTest) then + write(u6,*) 'nSet=',nSet + write(u6,*) 'Line=',Line + end if + call Get_I1(2,lAng) + if (nSet == -1) call Get_I1(3,nSet) + if (IfTest) write(u6,*) 'lAng,nSet=',lAng,nSet + + Line = Get_Ln(Lu_lib) + Line = Get_Ln(Lu_lib) + + nCnttp = nCnttp+1 + if (nCnttp > Mxdbsc) then + call WarningMessage(2,'Error in Mk_RI_Shells') + write(u6,*) 'Mk_RI_Shells: Increase Mxdbsc' + call Abend() + end if + if (Show .and. (iPrint >= 6)) then + write(u6,*) + write(u6,*) + write(u6,'(1X,A,I5,A,A)') 'Basis Set ',nCnttp,' Label: ',BSLb + write(u6,'(1X,A)') 'Basis set is read from the workdir.' + end if + + dbsc(nCnttp)%Bsl = BSLB(2:80) + dbsc(nCnttp)%Bsl_old = dbsc(nCnttp)%Bsl + + ! Loop over the angular shells + + jShll = iShll + do iAng=0,lAng + iShll = iShll+1 + Line = Get_Ln(Lu_lib) + call Get_I1(1,nPrim) + call Get_I1(2,nCntrc) + call Get_I1(3,iSph) + if (IfTest) then + write(u6,*) 'iAng=',iAng + write(u6,*) 'nPrim=',nPrim + write(u6,*) 'nCntrc=',nCntrc + write(u6,*) 'iSph=',iSph + end if + + ! Read Gaussian exponents + + call mma_Allocate(Shells(iShll)%Exp,nPrim,Label='ExpRI') + Shells(iShll)%nExp = nPrim + Shells(iShll)%nBasis_C = nCntrc + iEnd = iStrt-1 + if (nPrim > 0) then + if (IfTest) write(u6,*) ' Read gaussian exponents' + call Read_v(Lu_lib,Shells(iShll)%Exp,1,nPrim,1,Ierr) + if (Ierr /= 0) then + call WarningMessage(2,'GetBS: Error while reading the exponents') + call Quit_OnUserError() + end if + if (IfTest) write(u6,*) ' Done with exponents' + if ((iPrint >= 99) .or. IfTest) call RecPrt(' Exponents',' ',Shells(iShll)%Exp,nPrim,1) + end if + iStrt = iEnd+1 + + ! Read contraction coefficients. Storage of coefficients + ! for both contracted and uncontracted case. + + call mma_allocate(Shells(iShll)%Cff_c,nPrim,nCntrc,2,Label='Cff_c') + call mma_allocate(Shells(iShll)%pCff,nPrim,nCntrc,Label='pCff') + Shells(iShll)%nBasis = nCntrc + call mma_allocate(Shells(iShll)%Cff_p,nPrim,nPrim,2,Label='Cff_p') + iEnds = iEnd + iEnd = iStrt-1 + ! Read contraction coefficients + ! Observe that the matrix will have nPrim rows and + ! nCntrc columns + if (IfTest) write(u6,*) ' Read coefficients' + + ! Read in coeffs. in GC format, as the standard case + + if (IfTest) write(u6,*) ' Standard case' + if (nPrim*nCntrc > 0) then + Shells(iShll)%Cff_c(:,:,:) = Zero + + ! Note that we now change the order!!! + read(Lu_lib,*) ((Shells(iShll)%Cff_c(i,j,2),j=1,nCntrc),i=1,nPrim) + if (Ierr /= 0) then + call WarningMessage(2,'GetBS: Error reading coeffs in GC format') + call Quit_OnUserError() + end if + if (IfTest) call RecPrt(' Coeffs',' ',Shells(iShll)%Cff_c(1,1,2),nPrim,nCntrc) + Shells(iShll)%Cff_c(:,:,1) = Shells(iShll)%Cff_c(:,:,2) + if (IfTest) call RecPrt(' Coeffs',' ',Shells(iShll)%Cff_c(1,1,1),nPrim,nCntrc) + + ! Put in unit matrix of uncontracted set + + Shells(iShll)%Cff_p(:,:,1) = Zero + do i=1,nPrim + Shells(iShll)%Cff_p(i,i,1) = One + end do + + Shells(iShll)%Cff_p(:,:,2) = Shells(iShll)%Cff_p(:,:,1) + call Nrmlz(Shells(iShll)%Exp,nPrim,Shells(iShll)%Cff_p(1,1,1),nPrim,iAng) + + Shells(iShll)%Cff_c(:,:,2) = Shells(iShll)%Cff_c(:,:,1) + call Fix_Coeff(nPrim,nCntrc,Shells(iShll)%Cff_c(1,1,2),Shells(iShll)%Cff_p(1,1,1),'F') + Shells(iShll)%pCff(:,:) = Shells(iShll)%Cff_c(:,:,1) + end if + + iEnd = iEnds + if (iSph == 0) then + Shells(iShll)%Transf = .false. + Shells(iShll)%Prjct = .false. + else if (iSph == 1) then + Shells(iShll)%Transf = .false. + Shells(iShll)%Prjct = .true. + else if (iSph == 2) then + Shells(iShll)%Transf = .true. + Shells(iShll)%Prjct = .false. + else + Shells(iShll)%Transf = .true. + Shells(iShll)%Prjct = .true. + end if + + Shells(iShll)%nBasis = Shells(iShll)%nBasis_C + Shells(iShll)%Aux = .true. + + end do ! iAng + + dbsc(nCnttp)%Aux = .true. + S%iAngMx = max(S%iAngMx,lAng) + + dbsc(nCnttp)%iVal = jShll+1 + dbsc(nCnttp)%nVal = lAng+1 + dbsc(nCnttp)%nShells = dbsc(nCnttp)%nVal + + nCnt = dbsc(iCnttp)%nCntr + dbsc(nCnttp)%nCntr = nCnt + dbsc(nCnttp)%mdci = mdc + dbsc(nCnttp)%Parent_iCnttp = iCnttp + ! Create a pointer to the actual coordinates. + dbsc(nCnttp)%Coor => dbsc(iCnttp)%Coor(1:3,1:nCnt) + + S%Mx_Shll = iShll+1 + Max_Shells = S%Mx_Shll + S%Mx_mdc = mdc + + nSet = nSet-1 + if (nSet /= 0) Line = Get_Ln(Lu_lib) + end do ! do while (nSet /= 0) + + end do ! iCnttp + + close(Lu_lib) + +else + + do iCnttp=1,mCnttp + if (dbsc(iCnttp)%Frag .or. (dbsc(iCnttp)%nVal == 0)) cycle + mdc = dbsc(iCnttp)%mdci + nCnttp = nCnttp+1 + + if (nCnttp > Mxdbsc) then + call WarningMessage(2,'Error in Mk_RI_Shells') + write(u6,*) 'Mk_RI_Shells: Increase Mxdbsc' + call Abend() + end if + + ! Resolve the name of the valence basis and find the name of + ! the appropriate auxiliary basis set. + + dbsc(nCnttp)%Bsl = dbsc(iCnttp)%Bsl_old + + Hit = .true. + call Decode(dbsc(nCnttp)%Bsl,atom,1,Hit) + Hit = .true. + call Decode(dbsc(nCnttp)%Bsl,btype,2,Hit) + Hit = .true. + call Decode(dbsc(nCnttp)%Bsl,author,3,Hit) + Hit = .true. + call Decode(dbsc(nCnttp)%Bsl,basis,4,Hit) + Hit = .true. + call Decode(dbsc(nCnttp)%Bsl,CGTO,5,Hit) + Hit = .false. + call Decode(dbsc(nCnttp)%Bsl,Aux,6,Hit) + if (.not. Hit) Aux = ' ' + + n = index(Atom,' ')-1 + dbsc(nCnttp)%Bsl(1:n+1) = atom(1:n)//'.' + nn = n+1 + + n = index(btype,' ')-1 + dbsc(nCnttp)%Bsl(nn+1:nn+n+5) = btype(1:n)//'.....' + + ! Modify basis set library correctly + + Indx = index(dbsc(nCnttp)%Bsl,' ') + BSLbl = ' ' + BSLbl(1:Indx-1) = dbsc(nCnttp)%Bsl(1:Indx-1) + call WhichMolcas(Basis_lib) + if (Basis_lib(1:1) /= ' ') then + ib = index(Basis_lib,' ')-1 + if (ib < 1) call SysAbendMsg('rdCtl','Too long PATH to MOLCAS',' ') + if (iRI_Type == 1) then + Fname = Basis_lib(1:ib)//'/basis_library/j_Basis' + else if (iRI_Type == 2) then + Fname = Basis_lib(1:ib)//'/basis_library/jk_Basis' + else if (iRI_Type == 3) then + Fname = Basis_lib(1:ib)//'/basis_library/c_Basis' + else + call WarningMessage(2,'Error in Mk_RI_Shells') + write(u6,*) 'Wrong iRI_Type!' + write(u6,*) 'iRI_Type=',iRI_Type + call Abend() + end if + else + if (iRI_Type == 1) then + Fname = DefNm//'/j_Basis' + else if (iRI_Type == 2) then + Fname = DefNm//'/jk_Basis' + else if (iRI_Type == 3) then + Fname = DefNm//'/c_Basis' + else + call WarningMessage(2,'Error in Mk_RI_Shells') + write(u6,*) 'Wrong iRI_Type!' + write(u6,*) 'iRI_Type=',iRI_Type + call Abend() + end if + end if + + if (Show .and. (iPrint >= 6)) then + write(u6,*) + write(u6,*) + write(u6,'(1X,A,I5,A,A)') 'Basis Set ',nCnttp,' Label: ',BSLbl(1:Indx-1) + write(u6,'(1X,A,A)') 'Basis set is read from library:',Fname(1:index(Fname,' ')) + end if + + jShll = iShll + dbsc(nCnttp)%Bsl_old = dbsc(nCnttp)%Bsl + call GetBS(Fname,dbsc(nCnttp)%Bsl,iShll,Ref,UnNorm,LuRd,BasisTypes,STDINP,lSTDINP,.false.,.true.,' ') + + dbsc(nCnttp)%Aux = .true. + dbsc(nCnttp)%Charge = Zero + + if (Show .and. (iPrint >= 6) .and. (Ref(1) /= '') .and. (Ref(2) /= '')) then + write(u6,'(1x,a)') 'Basis Set Reference(s):' + if (Ref(1) /= '') write(u6,'(5x,a)') trim(Ref(1)) + if (Ref(2) /= '') write(u6,'(5x,a)') trim(Ref(2)) + write(u6,*) + write(u6,*) + end if + dbsc(nCnttp)%ECP = dbsc(nCnttp)%nPrj+dbsc(nCnttp)%nSRO+dbsc(nCnttp)%nSOC+dbsc(nCnttp)%nPP+dbsc(nCnttp)%nM1+dbsc(nCnttp)%nM2 /= 0 + + lAng = max(dbsc(nCnttp)%nVal,dbsc(nCnttp)%nSRO,dbsc(nCnttp)%nPrj)-1 + S%iAngMx = max(S%iAngMx,lAng) + ! No transformation needed for s and p shells + Shells(jShll+1)%Transf = .false. + Shells(jShll+1)%Prjct = .false. + Shells(jShll+2)%Transf = .false. + Shells(jShll+2)%Prjct = .false. + dbsc(nCnttp)%pChrg = dbsc(iCnttp)%pChrg + dbsc(nCnttp)%Fixed = dbsc(iCnttp)%Fixed + dbsc(nCnttp)%Parent_iCnttp = iCnttp + dbsc(nCnttp)%nShells = dbsc(nCnttp)%nVal+dbsc(nCnttp)%nPrj+dbsc(nCnttp)%nSRO+dbsc(nCnttp)%nSOC+dbsc(nCnttp)%nPP + + do iSh=jShll+1,iShll + Shells(iSh)%nBasis = Shells(iSh)%nBasis_c + call mma_deallocate(Shells(iShll)%pCff) + call mma_allocate(Shells(iShll)%pCff,Shells(iSh)%nExp,Shells(iSh)%nBasis,Label='pCff') + Shells(iShll)%pCff(:,:) = Shells(iShll)%Cff_c(:,:,1) + Shells(iSh)%Aux = .true. + end do + + nCnt = dbsc(iCnttp)%nCntr + dbsc(nCnttp)%nCntr = nCnt + dbsc(nCnttp)%mdci = mdc + ! Create a pointer to the actual coordinates of the parent dbsc + dbsc(nCnttp)%Coor => dbsc(iCnttp)%Coor(1:3,1:nCnt) + + S%Mx_Shll = iShll+1 + Max_Shells = S%Mx_Shll + S%Mx_mdc = mdc + + end do + +end if +! * +!*********************************************************************** +! * +! Add the final DUMMY SHELL! + +call Mk_Dummy_Shell() +call mma_deallocate(STDINP) +! * +!*********************************************************************** +! * +return + +end subroutine Mk_RI_Shells diff -Nru openmolcas-22.02/src/ri_util/mk_tint_p.f openmolcas-22.10/src/ri_util/mk_tint_p.f --- openmolcas-22.02/src/ri_util/mk_tint_p.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_tint_p.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,84 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Mk_TInt_P(TInt_p,nTInt_p, - & TP,nTP, - & iAL,nCompA,nCompB, - & List2_p,nList2_p, - & mData,iAng,jAng,npk,npl, - & List_TP) - Implicit Real*8 (a-h,o-z) - Real*8 TInt_p(nTInt_p,nTInt_p), TP(nTP,nTP) - Integer iAL(nCompA,nCompB), List2_p(mData,nList2_p), - & List_TP(2,nTP) -* - iA=iAng+1 - jA=jAng+1 - Call FZero(TP,nTP**2) - Do iList2_p = 1, nList2_p - kAng= List2_p(1,iList2_p) - lAng= List2_p(2,iList2_p) - kComp=List2_p(3,iList2_p) - lComp=List2_p(4,iList2_p) -C Write (6,*) 'kComp,lComp=',kComp,lComp - If ( - & kAng.eq.iAng .and. lAng.eq.jAng -C & .and. iAL(kComp,lComp).eq.1 - & .and. kComp.eq.iA .and. lComp.eq.jA - & ) Then -* - k=List2_p(5,iList2_p) - l=List2_p(6,iList2_p) - If (iAng.eq.jAng) Then - iTP = k*(k-1)/2 + l - Else - iTP = (l-1)*npk + k - End If - List_TP(1,iTP)=k - List_TP(2,iTP)=l -* - Do jList2_p = 1, nList2_p - mAng= List2_p(1,jList2_p) - nAng= List2_p(2,jList2_p) - mComp=List2_p(3,jList2_p) - nComp=List2_p(4,jList2_p) -C Write (6,*) 'mComp,nComp=',mComp,nComp - If ( - & mAng.eq.iAng .and. nAng.eq.jAng -C & .and. iAL(mComp,nComp).eq.1 - & .and. mComp.eq.iA .and. nComp.eq.jA - & ) Then -* - m=List2_p(5,jList2_p) - n=List2_p(6,jList2_p) - If (iAng.eq.jAng) Then - jTP = m*(m-1)/2 + n - Else - jTP = (n-1)*npk + m - End If -* - TP(iTP,jTP) = TP(iTP,jTP) - & + TInt_P(iList2_p,jList2_p) -C & + Abs(TInt_P(iList2_p,jList2_p)) -* - End If -* - End Do -* - End If - End Do -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer_array(iAL) - Call Unused_integer(npl) - End If - End diff -Nru openmolcas-22.02/src/ri_util/mk_tint_p.F90 openmolcas-22.10/src/ri_util/mk_tint_p.F90 --- openmolcas-22.02/src/ri_util/mk_tint_p.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_tint_p.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,76 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Mk_TInt_P(TInt_p,nTInt_p,TP,nTP,List2_p,nList2_p,mData,iAng,jAng,npk,List_TP) + +use Index_Functions, only: nTri_Elem +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nTInt_p, nTP, nList2_p, mData, List2_p(mData,nList2_p), iAng, jAng, npk +real(kind=wp), intent(in) :: TInt_p(nTInt_p,nTInt_p) +real(kind=wp), intent(out) :: TP(nTP,nTP) +integer(kind=iwp), intent(out) :: List_TP(2,nTP) +integer(kind=iwp) :: iA, iList2_p, iTP, jA, jList2_p, jTP, k, kAng, kComp, l, lAng, lComp, m, mAng, mComp, n, nAng, nComp + +iA = iAng+1 +jA = jAng+1 +TP(:,:) = Zero +do iList2_p=1,nList2_p + kAng = List2_p(1,iList2_p) + lAng = List2_p(2,iList2_p) + kComp = List2_p(3,iList2_p) + lComp = List2_p(4,iList2_p) + !write(u6,*) 'kComp,lComp=',kComp,lComp + !if ((kAng == iAng) .and. (iAL(kComp,lComp) == 1) .and. (lAng == jAng) .and. (kComp == iA) .and. (lComp == jA)) then + if ((kAng == iAng) .and. (lAng == jAng) .and. (kComp == iA) .and. (lComp == jA)) then + + k = List2_p(5,iList2_p) + l = List2_p(6,iList2_p) + if (iAng == jAng) then + iTP = nTri_Elem(k-1)+l + else + iTP = (l-1)*npk+k + end if + List_TP(1,iTP) = k + List_TP(2,iTP) = l + + do jList2_p=1,nList2_p + mAng = List2_p(1,jList2_p) + nAng = List2_p(2,jList2_p) + mComp = List2_p(3,jList2_p) + nComp = List2_p(4,jList2_p) + !write(u6,*) 'mComp,nComp=',mComp,nComp + !if ((mAng == iAng) .and. (iAL(mComp,nComp) == 1) .and. (nAng == jAng) .and. (mComp == iA) .and. (nComp == jA)) then + if ((mAng == iAng) .and. (nAng == jAng) .and. (mComp == iA) .and. (nComp == jA)) then + + m = List2_p(5,jList2_p) + n = List2_p(6,jList2_p) + if (iAng == jAng) then + jTP = nTri_Elem(m-1)+n + else + jTP = (n-1)*npk+m + end if + + TP(iTP,jTP) = TP(iTP,jTP)+TInt_P(iList2_p,jList2_p) + !TP(iTP,jTP) = TP(iTP,jTP)+abs(TInt_P(iList2_p,jList2_p)) + + end if + + end do + + end if +end do + +return + +end subroutine Mk_TInt_P diff -Nru openmolcas-22.02/src/ri_util/mk_tvt.f openmolcas-22.10/src/ri_util/mk_tvt.f --- openmolcas-22.02/src/ri_util/mk_tvt.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_tvt.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,81 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Mk_tVt(TInt,nTheta_All,tVt,nTheta,List2,mData, - & iPrm,nPrm,iAng,jAng,nk,nl,Indkl,nkl, - & iAL,nA,nB) - Implicit Real*8 (a-h,o-z) - Real*8 TInt(nTheta_All,nTheta_All), tVt(nTheta,nTheta) - Integer List2(mData,nTheta_All), iPrm(nPrm), Indkl(nkl), - & iAL(nA,nB) -* -*define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Call RecPrt('Mk_tVt: TInt',' ',TInt,nTheta_All,nTheta_All) - Call iVcPrt('iPrm',' ',iPrm,nPrm) - Call iVcPrt('Indkl',' ',Indkl,nkl) - Call iVcPrt('iAL',' ',iAL,nA*nB) -#endif - Call FZero(tVt,nTheta**2) - iA=iAng+1 - jA=jAng+1 - Do iTheta_All = 1, nTheta_All - kComp=List2(3,iTheta_All) - lComp=List2(4,iTheta_All) - ik= List2(5,iTheta_All) - il= List2(6,iTheta_All) - If (iAng.eq.jAng) Then - iTheta_Full = ik*(ik-1)/2+il - Else - iTheta_Full = (il-1)*nk + ik - End If - If ( -C & iAL(kComp,lComp).eq.1 .and. - & kComp.eq.iA .and. lComp.eq.jA .and. - & iPrm(iTheta_Full).eq.1) Then - iTheta=Indkl(iTheta_Full) -* - Do jTheta_All = 1, nTheta_All - mComp=List2(3,jTheta_All) - nComp=List2(4,jTheta_All) - im =List2(5,jTheta_All) - in =List2(6,jTheta_All) - If (iAng.eq.jAng) Then - jTheta_Full = im*(im-1)/2+in - Else - jTheta_Full = (in-1)*nk + im - End If - If ( -C & iAL(mComp,nComp).eq.1 .and. - & mComp.eq.iA .and. nComp.eq.jA .and. - & iPrm(jTheta_Full).eq.1) Then - jTheta=Indkl(jTheta_Full) -* - tVt(iTheta,jTheta) = tVt(iTheta,jTheta) - & + TInt(iTheta_All,jTheta_All) -C & + Abs(TInt(iTheta_All,jTheta_All)) -* - End If - End Do -* - End If - End Do -* -#ifdef _DEBUGPRINT_ - Call RecPrt('tVt',' ',tVt,nTheta,nTheta) -#else -c Avoid unused argument warnings - If (.False.) Call Unused_integer_array(iAL) -#endif -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_integer(nl) - End diff -Nru openmolcas-22.02/src/ri_util/mk_tvt.F90 openmolcas-22.10/src/ri_util/mk_tvt.F90 --- openmolcas-22.02/src/ri_util/mk_tvt.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_tvt.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,78 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Mk_tVt(TInt,nTheta_All,tVt,nTheta,List2,mData,iPrm,nPrm,iAng,jAng,nk,Indkl,nkl) + +use Index_Functions, only: nTri_Elem +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nTheta_All, nTheta, mData, List2(mData,nTheta_All), nPrm, iPrm(nPrm), iAng, jAng, nk, nkl, & + Indkl(nkl) +real(kind=wp), intent(in) :: TInt(nTheta_All,nTheta_All) +real(kind=wp), intent(out) :: tVt(nTheta,nTheta) +integer(kind=iwp) :: iA, ik, il, im, in_, iTheta, iTheta_All, iTheta_Full, jA, jTheta, jTheta_All, jTheta_Full, kComp, lComp, & + mComp, nComp + +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +call RecPrt('Mk_tVt: TInt',' ',TInt,nTheta_All,nTheta_All) +call iVcPrt('iPrm',' ',iPrm,nPrm) +call iVcPrt('Indkl',' ',Indkl,nkl) +#endif +tVt(:,:) = Zero +iA = iAng+1 +jA = jAng+1 +do iTheta_All=1,nTheta_All + kComp = List2(3,iTheta_All) + lComp = List2(4,iTheta_All) + ik = List2(5,iTheta_All) + il = List2(6,iTheta_All) + if (iAng == jAng) then + iTheta_Full = nTri_Elem(ik-1)+il + else + iTheta_Full = (il-1)*nk+ik + end if + !if ((iAL(kComp,lComp) == 1) .and. (kComp == iA) .and. (lComp == jA) .and. (iPrm(iTheta_Full) == 1)) then + if ((kComp == iA) .and. (lComp == jA) .and. (iPrm(iTheta_Full) == 1)) then + iTheta = Indkl(iTheta_Full) + + do jTheta_All=1,nTheta_All + mComp = List2(3,jTheta_All) + nComp = List2(4,jTheta_All) + im = List2(5,jTheta_All) + in_ = List2(6,jTheta_All) + if (iAng == jAng) then + jTheta_Full = nTri_Elem(im-1)+in_ + else + jTheta_Full = (in_-1)*nk+im + end if + !if ((iAL(mComp,nComp) == 1) .and. (mComp == iA) .and. (nComp == jA) .and. (iPrm(jTheta_Full) == 1)) then + if ((mComp == iA) .and. (nComp == jA) .and. (iPrm(jTheta_Full) == 1)) then + jTheta = Indkl(jTheta_Full) + + tVt(iTheta,jTheta) = tVt(iTheta,jTheta)+TInt(iTheta_All,jTheta_All) + !tVt(iTheta,jTheta) = tVt(iTheta,jTheta)+abs(TInt(iTheta_All,jTheta_All)) + + end if + end do + + end if +end do + +#ifdef _DEBUGPRINT_ +call RecPrt('tVt',' ',tVt,nTheta,nTheta) +#endif + +return + +end subroutine Mk_tVt diff -Nru openmolcas-22.02/src/ri_util/mk_tvtf.f openmolcas-22.10/src/ri_util/mk_tvtf.f --- openmolcas-22.02/src/ri_util/mk_tvtf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_tvtf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,77 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Mk_tVtF(TInt,nTheta_All,tVtF,nTheta,List2,mData, - & iPrm,nPrm, - & iAng,jAng,nk,nl,Indkl,nkl, - & nTheta_Full, - & iAL,nA,nB) - Implicit Real*8 (a-h,o-z) - Real*8 TInt(nTheta_All,nTheta_All), tVtF(nTheta,nTheta_Full) - Integer List2(mData,nTheta_All), Indkl(nkl), iPrm(nPrm), - & iAL(nA,nB) -* -#ifdef _DEBUGPRINT_ - Call RecPrt('TInt',' ',TInt,nTheta_all,nTheta_all) - Call iVcPrt('Indkl',' ',Indkl,nkl) -#endif - Call FZero(tVtF,nTheta*nTheta_Full) - iA=iAng+1 - jA=jAng+1 - Do iTheta_All = 1, nTheta_All - kComp= List2(3,iTheta_All) - lComp= List2(4,iTheta_All) - ik= List2(5,iTheta_All) - il= List2(6,iTheta_All) - If (iAng.eq.jAng) Then - iTheta_Full = ik*(ik-1)/2+il - Else - iTheta_Full = (il-1)*nk + ik - End If - If ( - & iPrm(iTheta_Full).eq.1 -C & .and. iAL(kComp,lComp).eq.1 - & .and. kComp.eq.iA .and. lComp.eq.jA - & ) Then - iTheta=Indkl(iTheta_Full) -* - Do jTheta_All = 1, nTheta_All - mComp= List2(3,jTheta_All) - nComp= List2(4,jTheta_All) -C If (iAL(mComp,nComp).eq.1) Then - If (mComp.eq.iA.and.nComp.eq.jA) Then - jk=List2(5,jTheta_All) - jl=List2(6,jTheta_All) - If (iAng.eq.jAng) Then - jTheta_Full = jk*(jk-1)/2+jl - Else - jTheta_Full = (jl-1)*nk + jk - End If -* - tVtF(iTheta,jTheta_Full)=tVtF(iTheta,jTheta_Full) -C & +Abs(TInt(iTheta_All,jTheta_All)) - & + TInt(iTheta_All,jTheta_All) -* - End If - End Do -* - End If - End Do -#ifdef _DEBUGPRINT_ - Call RecPrt('tVtF',' ',tVtF,nTheta,nTheta_Full) -#endif -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(nl) - Call Unused_integer_array(iAL) - End If - End diff -Nru openmolcas-22.02/src/ri_util/mk_tvtf.F90 openmolcas-22.10/src/ri_util/mk_tvtf.F90 --- openmolcas-22.02/src/ri_util/mk_tvtf.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mk_tvtf.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,73 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Mk_tVtF(TInt,nTheta_All,tVtF,nTheta,List2,mData,iPrm,nPrm,iAng,jAng,nk,Indkl,nkl,nTheta_Full) + +use Index_Functions, only: nTri_Elem +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nTheta_All, nTheta, mData, List2(mData,nTheta_All), nPrm, iPrm(nPrm), iAng, jAng, nk, nkl, & + Indkl(nkl), nTheta_Full +real(kind=wp), intent(in) :: TInt(nTheta_All,nTheta_All) +real(kind=wp), intent(out) :: tVtF(nTheta,nTheta_Full) +integer(kind=iwp) :: iA, ik, il, iTheta, iTheta_All, iTheta_Full, jA, jk, jl, jTheta_All, jTheta_Full, kComp, lComp, mComp, nComp + +#ifdef _DEBUGPRINT_ +call RecPrt('TInt',' ',TInt,nTheta_all,nTheta_all) +call iVcPrt('Indkl',' ',Indkl,nkl) +#endif +tVtF(:,:) = Zero +iA = iAng+1 +jA = jAng+1 +do iTheta_All=1,nTheta_All + kComp = List2(3,iTheta_All) + lComp = List2(4,iTheta_All) + ik = List2(5,iTheta_All) + il = List2(6,iTheta_All) + if (iAng == jAng) then + iTheta_Full = nTri_Elem(ik-1)+il + else + iTheta_Full = (il-1)*nk+ik + end if + !if ((iPrm(iTheta_Full) == 1) .and. (iAL(kComp,lComp) == 1) .and. (kComp == iA) .and. (lComp == jA)) then + if ((iPrm(iTheta_Full) == 1) .and. (kComp == iA) .and. (lComp == jA)) then + iTheta = Indkl(iTheta_Full) + + do jTheta_All=1,nTheta_All + mComp = List2(3,jTheta_All) + nComp = List2(4,jTheta_All) + !if (iAL(mComp,nComp) == 1) then + if ((mComp == iA) .and. (nComp == jA)) then + jk = List2(5,jTheta_All) + jl = List2(6,jTheta_All) + if (iAng == jAng) then + jTheta_Full = nTri_Elem(jk-1)+jl + else + jTheta_Full = (jl-1)*nk+jk + end if + + tVtF(iTheta,jTheta_Full) = tVtF(iTheta,jTheta_Full)+TInt(iTheta_All,jTheta_All) + !tVtF(iTheta,jTheta_Full) = tVtF(iTheta,jTheta_Full)+abs(TInt(iTheta_All,jTheta_All)) + + end if + end do + + end if +end do +#ifdef _DEBUGPRINT_ +call RecPrt('tVtF',' ',tVtF,nTheta,nTheta_Full) +#endif + +return + +end subroutine Mk_tVtF diff -Nru openmolcas-22.02/src/ri_util/mn2k.f openmolcas-22.10/src/ri_util/mn2k.f --- openmolcas-22.02/src/ri_util/mn2k.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mn2k.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - - INTEGER FUNCTION mn2K(iab,lSym) - use pso_stuff - Integer iab, lSym - - lab = iOff_ij2K(lSym) + iab - mn2K = ij2K(lab) - - End diff -Nru openmolcas-22.02/src/ri_util/modify_tint_p.f openmolcas-22.10/src/ri_util/modify_tint_p.f --- openmolcas-22.02/src/ri_util/modify_tint_p.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/modify_tint_p.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,80 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Modify_TInt_p(TInt,nTheta_All,List2,mData) - use Basis_Info - Implicit Real*8 (a-h,o-z) - Real*8 TInt(nTheta_All,nTheta_All) - Integer List2(mData,nTheta_All) -* -#ifdef _DEBUGPRINT_ - Call RecPrt('Modify_TInt_p: TInt',' ',TInt,nTheta_All,nTheta_All) -#endif - Do iTheta_All= 1, nTheta_All -#ifdef _DEBUGPRINT_ - iPrim=List2(5,iTheta_All) -#endif - iShll=List2(7,iTheta_All) - nConti=Shells(iShll)%nBasis_C - nPrimi=Shells(iShll)%nExp - Coeff_i = DDot_(nConti,Shells(iShll)%Cff_c(1,1,1),nPrimi, - & Shells(iShll)%Cff_c(1,1,1),nPrimi) - Coeff_i = Sqrt(Coeff_i) -* -#ifdef _DEBUGPRINT_ - jPrim=List2(6,iTheta_All) -#endif - jShll=List2(8,iTheta_All) - nContj=Shells(jShll)%nBasis_C - nPrimj=Shells(jShll)%nExp - Coeff_j = DDot_(nContj,Shells(jShll)%Cff_c(1,1,1),nPrimj, - & Shells(jShll)%Cff_c(1,1,1),nPrimj) - Coeff_j = Sqrt(Coeff_j) -* - Do jTheta_All = 1, nTheta_All -#ifdef _DEBUGPRINT_ - kPrim=List2(5,jTheta_All) -#endif - kShll=List2(7,jTheta_All) - nContk=Shells(kShll)%nBasis_C - nPrimk=Shells(kShll)%nExp - Coeff_k = DDot_(nContk,Shells(kShll)%Cff_c(1,1,1),nPrimk, - & Shells(kShll)%Cff_c(1,1,1),nPrimk) - Coeff_k = Sqrt(Coeff_k) -* -#ifdef _DEBUGPRINT_ - lPrim=List2(6,jTheta_All) -#endif - lShll=List2(8,jTheta_All) - nContl=Shells(lShll)%nBasis_C - nPriml=Shells(lShll)%nExp - Coeff_l = DDot_(nContl,Shells(lShll)%Cff_c(1,1,1),nPriml, - & Shells(lShll)%Cff_c(1,1,1),nPriml) - Coeff_l = Sqrt(Coeff_l) -* - TInt(iTheta_All,jTheta_All) = TInt(iTheta_All,jTheta_All) - & * Coeff_i * Coeff_j - & * Coeff_k * Coeff_l -#ifdef _DEBUGPRINT_ - Write (6,*) - Write (6,*) Coeff_i,Coeff_j,Coeff_k,Coeff_l - Write (6,*) iPrim, jPrim, kPrim, lPrim - Write (6,*) nPrimi, nPrimj, nPrimk, nPriml -#endif -* - End Do -* - End Do -#ifdef _DEBUGPRINT_ - Call RecPrt('Modify_TInt_p: TInt',' ',TInt,nTheta_All,nTheta_All) -#endif -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/modify_tint_p.F90 openmolcas-22.10/src/ri_util/modify_tint_p.F90 --- openmolcas-22.02/src/ri_util/modify_tint_p.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/modify_tint_p.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,83 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Modify_TInt_p(TInt,nTheta_All,List2,mData) + +use Basis_Info, only: Shells +use Definitions, only: wp, iwp, r8 + +implicit none +integer(kind=iwp), intent(in) :: nTheta_All, mData, List2(mData,nTheta_All) +real(kind=wp), intent(inout) :: TInt(nTheta_All,nTheta_All) +integer(kind=iwp) :: iShll, iTheta_All, jShll, jTheta_All, kShll, lShll, nConti, nContj, nContk, nContl, nPrimi, nPrimj, nPrimk, & + nPriml +real(kind=wp) :: Coeff_i, Coeff_j, Coeff_k, Coeff_l +real(kind=r8), external :: DDot_ + +#ifdef _DEBUGPRINT_ +call RecPrt('Modify_TInt_p: TInt',' ',TInt,nTheta_All,nTheta_All) +#endif +do iTheta_All=1,nTheta_All +# ifdef _DEBUGPRINT_ + iPrim = List2(5,iTheta_All) +# endif + iShll = List2(7,iTheta_All) + nConti = Shells(iShll)%nBasis_C + nPrimi = Shells(iShll)%nExp + Coeff_i = DDot_(nConti,Shells(iShll)%Cff_c(1,1,1),nPrimi,Shells(iShll)%Cff_c(1,1,1),nPrimi) + Coeff_i = sqrt(Coeff_i) + +# ifdef _DEBUGPRINT_ + jPrim = List2(6,iTheta_All) +# endif + jShll = List2(8,iTheta_All) + nContj = Shells(jShll)%nBasis_C + nPrimj = Shells(jShll)%nExp + Coeff_j = DDot_(nContj,Shells(jShll)%Cff_c(1,1,1),nPrimj,Shells(jShll)%Cff_c(1,1,1),nPrimj) + Coeff_j = sqrt(Coeff_j) + + do jTheta_All=1,nTheta_All +# ifdef _DEBUGPRINT_ + kPrim = List2(5,jTheta_All) +# endif + kShll = List2(7,jTheta_All) + nContk = Shells(kShll)%nBasis_C + nPrimk = Shells(kShll)%nExp + Coeff_k = DDot_(nContk,Shells(kShll)%Cff_c(1,1,1),nPrimk,Shells(kShll)%Cff_c(1,1,1),nPrimk) + Coeff_k = sqrt(Coeff_k) + +# ifdef _DEBUGPRINT_ + lPrim = List2(6,jTheta_All) +# endif + lShll = List2(8,jTheta_All) + nContl = Shells(lShll)%nBasis_C + nPriml = Shells(lShll)%nExp + Coeff_l = DDot_(nContl,Shells(lShll)%Cff_c(1,1,1),nPriml,Shells(lShll)%Cff_c(1,1,1),nPriml) + Coeff_l = sqrt(Coeff_l) + + TInt(iTheta_All,jTheta_All) = TInt(iTheta_All,jTheta_All)*Coeff_i*Coeff_j*Coeff_k*Coeff_l +# ifdef _DEBUGPRINT_ + write(u6,*) + write(u6,*) Coeff_i,Coeff_j,Coeff_k,Coeff_l + write(u6,*) iPrim,jPrim,kPrim,lPrim + write(u6,*) nPrimi,nPrimj,nPrimk,nPriml +# endif + + end do + +end do +#ifdef _DEBUGPRINT_ +call RecPrt('Modify_TInt_p: TInt',' ',TInt,nTheta_All,nTheta_All) +#endif + +return + +end subroutine Modify_TInt_p diff -Nru openmolcas-22.02/src/ri_util/mult_3c_qv_s.f openmolcas-22.10/src/ri_util/mult_3c_qv_s.f --- openmolcas-22.02/src/ri_util/mult_3c_qv_s.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mult_3c_qv_s.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,100 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Francesco Aquilante * -************************************************************************ - Subroutine Mult_3C_Qv_s(A_3C,nA_3C,Qv,nQv,Rv,n_Rv,nVec,iOff_3C, - & nIrrep,Out_of_Core,Lu_Q,QMode) -************************************************************************ -* Author: F. Aquilante * -* * -* Qv: is a symmetry blocked square matrix * -* * -************************************************************************ - Implicit Real*8 (a-h,o-z) - Real*8 A_3C(nA_3C), Qv(nQv), Rv(n_Rv) - Integer iOff_3C(3,0:nIrrep-1), nVec(0:7), Lu_Q(0:nIrrep-1) - Logical Out_of_Core - Character*1 QMode -* * -************************************************************************ -* * - lstepA=0 - lstepR=1 - If (Qmode.eq.'T') Then - Call FZero(Rv,n_Rv) - lstepA=1 - lstepR=0 - End If -* - iOffA=1 - iOffR=1 - - If (Out_of_Core) Then -* * -************************************************************************ -* * - Do iIrrep = 0, nIrrep-1 - nI = iOff_3C(2,iIrrep) - nMuNu = iOff_3C(1,iIrrep) - If (nMuNu.le.0 .or. nI.le.0) Go To 999 -* - iOffR2=iOffR - iOffA2=iOffA - mQv = nI*nVec(iIrrep) - iAddr=0 - Do While (mQv.ge.nI) -* - nK=Min(mQv,nQv)/nI - lQv=nI*nK - Call dDaFile(Lu_Q(iIrrep),2,Qv,lQv,iAddr) -* - Call A_3C_Qv_s(A_3C(iOffA2), - & Qv, - & Rv(iOffR2),nMuNu,nI,nK,QMode) - mQv = mQv - lQv - iOffR2 = iOffR2 + lstepR*nMuNu*nK - iOffA2 = iOffA2 + lstepA*nMuNu*nK - End Do -* - iOffA = iOffA + nMuNu*nI - iOffR = iOffR + nMuNu*nVec(iIrrep) - 999 Continue - End Do -* * -************************************************************************ -* * - Else ! In-Core -* * -************************************************************************ -* * - iOffQ=1 - Do iIrrep = 0, nIrrep-1 - nI = iOff_3C(2,iIrrep) - nMuNu = iOff_3C(1,iIrrep) - If (nMuNu.le.0 .or. nI.le.0) Go To 998 -* - Call A_3C_Qv_s(A_3C(iOffA), - & Qv(iOffQ), - & Rv(iOffR),nMuNu,nI,nVec(iIrrep),QMode) - 998 Continue - iOffA = iOffA + nMuNu*nI - iOffR = iOffR + nMuNu*nVec(iIrrep) - iOffQ = iOffQ + nI*nVec(iIrrep) - End Do -* * -************************************************************************ -* * - End If -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/ri_util/mult_3c_qv_s.F90 openmolcas-22.10/src/ri_util/mult_3c_qv_s.F90 --- openmolcas-22.02/src/ri_util/mult_3c_qv_s.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mult_3c_qv_s.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,101 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Francesco Aquilante * +!*********************************************************************** + +subroutine Mult_3C_Qv_s(A_3C,nA_3C,Qv,nQv,Rv,n_Rv,nVec,iOff_3C,nIrrep,Out_of_Core,Lu_Q,QMode) +!*********************************************************************** +! Author: F. Aquilante * +! * +! Qv: is a symmetry blocked square matrix * +! * +!*********************************************************************** + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nA_3C, nQv, n_Rv, nVec(0:7), nIrrep, iOff_3C(3,0:nIrrep-1), Lu_Q(0:nIrrep-1) +real(kind=wp), intent(in) :: A_3C(nA_3C) +real(kind=wp), intent(inout) :: Qv(nQv) +real(kind=wp), intent(out) :: Rv(n_Rv) +logical(kind=iwp), intent(in) :: Out_of_Core +character, intent(in) :: QMode +integer(kind=iwp) :: iAddr, iIrrep, iOffA, iOffA2, iOffQ, iOffR, iOffR2, lQv, lstepA, lstepR, mQv, nI, nK, nMuNu + +! * +!*********************************************************************** +! * +lstepA = 0 +lstepR = 1 +if (Qmode == 'T') then + Rv(:) = Zero + lstepA = 1 + lstepR = 0 +end if + +iOffA = 1 +iOffR = 1 + +if (Out_of_Core) then + ! * + !********************************************************************* + ! * + do iIrrep=0,nIrrep-1 + nI = iOff_3C(2,iIrrep) + nMuNu = iOff_3C(1,iIrrep) + if ((nMuNu <= 0) .or. (nI <= 0)) cycle + + iOffR2 = iOffR + iOffA2 = iOffA + mQv = nI*nVec(iIrrep) + iAddr = 0 + do while (mQv >= nI) + + nK = min(mQv,nQv)/nI + lQv = nI*nK + call dDaFile(Lu_Q(iIrrep),2,Qv,lQv,iAddr) + + call A_3C_Qv_s(A_3C(iOffA2),Qv,Rv(iOffR2),nMuNu,nI,nK,QMode) + mQv = mQv-lQv + iOffR2 = iOffR2+lstepR*nMuNu*nK + iOffA2 = iOffA2+lstepA*nMuNu*nK + end do + + iOffA = iOffA+nMuNu*nI + iOffR = iOffR+nMuNu*nVec(iIrrep) + end do + ! * + !********************************************************************* + ! * +else ! In-Core + ! * + !********************************************************************* + ! * + iOffQ = 1 + do iIrrep=0,nIrrep-1 + nI = iOff_3C(2,iIrrep) + nMuNu = iOff_3C(1,iIrrep) + if ((nMuNu > 0) .and. (nI > 0)) call A_3C_Qv_s(A_3C(iOffA),Qv(iOffQ),Rv(iOffR),nMuNu,nI,nVec(iIrrep),QMode) + iOffA = iOffA+nMuNu*nI + iOffR = iOffR+nMuNu*nVec(iIrrep) + iOffQ = iOffQ+nI*nVec(iIrrep) + end do + ! * + !********************************************************************* + ! * +end if +! * +!*********************************************************************** +! * +return + +end subroutine Mult_3C_Qv_s diff -Nru openmolcas-22.02/src/ri_util/mult_rijk_qkl.f openmolcas-22.10/src/ri_util/mult_rijk_qkl.f --- openmolcas-22.02/src/ri_util/mult_rijk_qkl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mult_rijk_qkl.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,266 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Jonas Bostrom * -************************************************************************ - Subroutine Mult_RijK_QKL(iSO,nBas_aux,nIrrep) -************************************************************************** -* Author: Jonas Bostrom -* -* Purpose: Computation of the DF coefficient vectors in MO-basis. -* -* Equation: C(il,K) = sum_J R(il,J) * Q(K,J) -* -* Input: -* iSO : alpha (iSO=1) or beta (iSO=2) orbitals -* nBas_aux : number of aux bsfs in each irrep. -* nIrrep : number of irreps. -************************************************************************** - use pso_stuff - use Para_Info, Only: Is_Real_Par - use ChoSwp, only: InfVec - Implicit Real*8 (a-h,o-z) - Integer nBas_Aux(1:nIrrep), nVec(1:nIrrep) - Character Fname*6, Fname2*6, Name_Q*6 - Character(LEN=50) CFmt - Character(LEN=13), Parameter :: SECNAM = 'MULT_RIJK_QKL' -#include "real.fh" -#include "cholesky.fh" -#include "stdalloc.fh" -#include "exterm.fh" -*#define _DEBUGPRINT_ -*#define _CD_TIMING_ -#ifdef _CD_TIMING_ -#include "temptime.fh" -#endif -* -#include "chotime.fh" - - Real*8, Allocatable:: QVector(:) - Real*8, Allocatable:: RVector(:) - Real*8, Allocatable:: CVector(:) -* -************************* -* Define some indeces - MulD2h(i,j) = iEOR(i-1,j-1) + 1 -************************* - - CALL CWTime(TotCPU1,TotWall1) - - Do i = 1, nIrrep - nVec(i) = NumCho(i) - End Do - Call GAIGOP(nVec,nIrrep,'+') - - nTotCho = 0 - MaxCho = 0 - MaxLocCho = 0 - Do jSym = 1, nIrrep - nTotCho = nTotCho + nVec(jSym) - MaxCho = Max(MaxCho,nVec(jSym)) - MaxLocCho= Max(MaxLocCho,NumCho(jSym)) - Do iSym = 1, nIrrep - iAdrCVec(jSym,iSym,iSO) = 0 - End Do - End Do - - -* Loop over the first cholesky symmetry -* - Do jSym = 1, nIrrep -* -*** Check so the symmetry contains vectors -*------------------------------------------------- - NumCV = NumCho(jSym) - NumAux = nBas_Aux(jSym) - If(jSym.eq.1) NumAux = NumAux - 1 -* Save the number of auxiliary basis functions to be -* accessed later - NumAuxVec(jSym) = NumAux - - - Call GAIGOP_SCAL(NumCV,'max') - If(NumCV .lt. 1) goto 1000 -* - nTotFIorb = 0 - MaxMOprod = 0 - MaxMOprodR = 0 - Do iSym = 1, nIrrep - kSym = MulD2h(JSym,iSym) - - nTotFIorb=nTotFIorb + nIJ1(iSym,kSym,iSO) - MaxMOprod = Max(MaxMOprod,nIJ1(iSym,kSym,iSO)) - MaxMOProdR = Max(MaxMOprodR,nIJR(iSym,kSym,iSO)) - End Do -* - Call mma_maxDBLE(MemMax) - nJvec1 = (MemMax-NumAux*MaxMOprod)/(MaxMOprod + NumAux) - If(nJvec1.lt.1) Then - Write(6,*) 'Too little memory in:',SECNAM - Call Abend - End If - nJvec1 = min(nJvec1,NumCho(jSym)) - nJbat = NumCho(jSym)/nJvec1 - iRest = mod(NumCho(jSym),nJvec1) - If(iRest.ne.0) Then - nJbat = nJbat+1 - nJvecLast = iRest - Else - nJvecLast = nJvec1 - End If -* - If(Is_Real_Par()) Then - iFirstCho = InfVec(1,5,jSym) - Else - iFirstCho = 1 - End If -* - l_QVector = nJVec1*NumAux - l_RVector = MaxMOprod*nJVec1 - l_CVector = MaxMOprodR*NumAux -* - Call mma_allocate(QVector,l_QVector,Label='QVector') - Call mma_allocate(RVector,l_RVector,Label='RVector') - Call mma_allocate(CVector,l_CVector,Label='CVector') -* - - iSeed2 = 8 - LuCVec = IsFreeUnit(iSeed2) - If (iSO.eq.1) Then - Write(Fname2,'(A4,I1,I1)') 'CVEA',jSym - ElseIf (iSO.eq.2) Then - Write(Fname2,'(A4,I1,I1)') 'CVEB',jSym - EndIf - Call DANAME_MF_WA(LuCVec,Fname2) - iAdrC = 0 -* -*** Get Q Vectors from Disk -*---------------------------------- - Do iSym = 1, nIrrep - lSym = MulD2h(iSym,jSym) -* - If(nIJ1(iSym,lSym,iSO).lt.1) Go To 2000 - CVector(:)=Zero - - Do iJBat = 1, nJBat - If(iJBat.eq.nJBat) Then - njVec = nJVecLast - Else - nJvec = nJvec1 - End If -* - iSeed=55+jSym-1 - Lu_Q=IsFreeUnit(iSeed) - Write(Name_Q,'(A4,I2.2)') 'QVEC',jSym-1 - Call DaName_MF_WA(Lu_Q,Name_Q) - l_Q = nJvec*NumAux - iAdrQ=(iFirstCho-1)*NumAux + (iJBat-1)*nJVec*NumAux - Call dDaFile(Lu_Q,2,Qvector,l_Q,iAdrQ) - -#ifdef _DEBUGPRINT_ - Call RecPrt('Q-vectors',' ',QVector,nJVec,NumAux) -#endif -* -* - iSeed=7 - LuRVec = IsFreeUnit(iSeed) - If (iSO.eq.1) Then - Write(Fname,'(A4,I1,I1)') 'CHTA',iSym,lSym - ElseIf (iSO.eq.2) Then - Write(Fname,'(A4,I1,I1)') 'CHTB',iSym,lSym - EndIf - Call DANAME_MF_WA(LuRVec,Fname) -* -*** Loop over all cholesky vectors on all nodes -*------------------------------------------------------ - -* -* Get R-Vectors from disk -*------------------------------------------- - - iAdrR = nIJ1(iSym,lSym,iSO)*nJVec1*(iJBat-1) - l_RVec = nJvec * nIJ1(iSym,lSym,iSO) - Call dDaFile(LuRVec,2,RVector,l_RVec,iAdrR) - - Call dGemm_('N','T',nIJ1(iSym,lSym,iSO),NumAux,nJVec, - & 1.0d0,RVector,nIJ1(iSym,lSym,iSO), - & QVector,NumAux, - & 0.0d0,CVector,nIJ1(iSym,lSym,iSO)) - End Do - - - -#ifdef _DEBUGPRINT_ - Write (6,*) 'jSym=',jSym - Call RecPrt('R-Vectors',' ',RVector,nIJ1(iSym,lSym,iSO),NumAux) - Call RecPrt('C-Vectors',' ',CVector,nIJ1(iSym,lSym,iSO),NumAux) -#endif - If ((.not.lSA).and.(iSym.eq.lSym)) Then - Do iAux = 1, NumAux - index = -1 - Do i = 1, nChOrb(iSym-1,iSO) - index = index+i - index2 = index + (iAux-1)*nIJ1(iSym,lSym,iSO) - CVector(1+index2) = CVector(1+index2)/sqrt(2.0d0) - End Do - End Do - End If - - Call DaClos(Lu_Q) - Call DACLOS(LuRVec) -* - 2000 Continue -* - Call GADGOP(CVector,l_CVector,'+') - iAdrCVec(jSym,iSym,iSO) = iAdrC - Call dDaFile(LuCVec,1,CVector,nIJ1(iSym,lSym,iSO)*NumAux,iAdrC) - If(nIJ1(iSym,lSym,iSO) .lt. nIJR(iSym,lSym,iSO)) Then - iAdrC = iAdrC + - & (nIJR(iSym,lSym,iSO)-nIJ1(iSym,lSym,iSO))*NumAux - End If - - End Do !iSym -* - Call mma_deallocate(CVector) - Call mma_deallocate(RVector) - Call mma_deallocate(QVector) -* - Call DACLOS(LuCVec) - 1000 Continue - - End Do ! jSym -* - CALL CWTime(TotCPU2,TotWall2) - TotCPU = TotCPU2 - TotCPU1 - TotWall= TotWall2 - TotWall1 -#ifdef _CD_TIMING_ - rMult_CPU = TOTCPU - rMult_Wall = TOTWALL -#endif -* - If(timings)then - - CFmt='(2x,A)' - Write(6,*) - Write(6,CFmt)'Cholesky Gradients timing from '//SECNAM - Write(6,CFmt)'----------------------------------------' - Write(6,*) - Write(6,CFmt)'- - - - - - - - - - - - - - - - - - - - - - - - -' - Write(6,CFmt)' CPU WALL ' - Write(6,CFmt)'- - - - - - - - - - - - - - - - - - - - - - - - -' - Write(6,'(2x,A26,2f10.2)')'TOTAL ' - & //' ',TOTCPU,TOTWALL - Write(6,CFmt)'- - - - - - - - - - - - - - - - - - - - - - - - -' - Write(6,*) - - endif - - Return - End diff -Nru openmolcas-22.02/src/ri_util/mult_rijk_qkl.F90 openmolcas-22.10/src/ri_util/mult_rijk_qkl.F90 --- openmolcas-22.02/src/ri_util/mult_rijk_qkl.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mult_rijk_qkl.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,250 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Jonas Bostrom * +!*********************************************************************** + +subroutine Mult_RijK_QKL(iSO,nBas_aux,nIrrep) +!************************************************************************* +! Author: Jonas Bostrom +! +! Purpose: Computation of the DF coefficient vectors in MO-basis. +! +! Equation: C(il,K) = sum_J R(il,J) * Q(K,J) +! +! Input: +! iSO : alpha (iSO=1) or beta (iSO=2) orbitals +! nBas_aux : number of aux bsfs in each irrep. +! nIrrep : number of irreps. +!************************************************************************* + +use RI_glob, only: iAdrCVec, nChOrb, nIJ1, nIJR, NumAuxVec +use Symmetry_Info, only: Mul +use pso_stuff, only: lSA +use Para_Info, only: Is_Real_Par +use ChoSwp, only: InfVec +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iSO, nIrrep, nBas_Aux(1:nIrrep) +#include "cholesky.fh" +!#define _CD_TIMING_ +#ifdef _CD_TIMING_ +#include "temptime.fh" +#endif +#include "chotime.fh" +integer(kind=iwp) :: i, iAdrC, iAdrQ, iAdrR, iAux, iFirstCho, iJBat, indx, indx2, iRest, iSeed, iSeed2, iSym, jSym, kSym, & + l_CVector, l_Q, l_QVector, l_RVec, l_RVector, lSym, Lu_Q, LuCVec, LuRVec, MaxCho, MaxLocCho, MaxMOprod, & + MaxMOProdR, MemMax, nJbat, njVec, nJvec1, nJvecLast, nTotCho, nTotFIorb, NumAux, NumCV, nVec(1:nIrrep) +real(kind=wp) :: TotCPU, TotCPU1, TotCPU2, TotWall, TotWall1, TotWall2 +character(len=50) :: CFmt +character(len=6) :: Fname, Fname2, Name_Q +real(kind=wp), allocatable :: CVector(:), QVector(:), RVector(:) +character(len=*), parameter :: SECNAM = 'MULT_RIJK_QKL' +integer(kind=iwp), external :: IsFreeUnit + +call CWTime(TotCPU1,TotWall1) + +nVec(1:nIrrep) = NumCho(1:nIrrep) +call GAIGOP(nVec,nIrrep,'+') + +nTotCho = 0 +MaxCho = 0 +MaxLocCho = 0 +do jSym=1,nIrrep + nTotCho = nTotCho+nVec(jSym) + MaxCho = max(MaxCho,nVec(jSym)) + MaxLocCho = max(MaxLocCho,NumCho(jSym)) +end do +iAdrCVec(1:nIrrep,1:nIrrep,iSO) = 0 + +! Loop over the first cholesky symmetry + +do jSym=1,nIrrep + + ! Check so the symmetry contains vectors + !--------------------------------------- + NumCV = NumCho(jSym) + NumAux = nBas_Aux(jSym) + if (jSym == 1) NumAux = NumAux-1 + ! Save the number of auxiliary basis functions to be accessed later + NumAuxVec(jSym) = NumAux + + call GAIGOP_SCAL(NumCV,'max') + if (NumCV < 1) cycle + + nTotFIorb = 0 + MaxMOprod = 0 + MaxMOprodR = 0 + do iSym=1,nIrrep + kSym = Mul(JSym,iSym) + + nTotFIorb = nTotFIorb+nIJ1(iSym,kSym,iSO) + MaxMOprod = max(MaxMOprod,nIJ1(iSym,kSym,iSO)) + MaxMOProdR = max(MaxMOprodR,nIJR(iSym,kSym,iSO)) + end do + + call mma_maxDBLE(MemMax) + nJvec1 = (MemMax-NumAux*MaxMOprod)/(MaxMOprod+NumAux) + if (nJvec1 < 1) then + write(u6,*) 'Too little memory in:',SECNAM + call Abend() + end if + nJvec1 = min(nJvec1,NumCho(jSym)) + nJbat = NumCho(jSym)/nJvec1 + iRest = mod(NumCho(jSym),nJvec1) + if (iRest /= 0) then + nJbat = nJbat+1 + nJvecLast = iRest + else + nJvecLast = nJvec1 + end if + + if (Is_Real_Par()) then + iFirstCho = InfVec(1,5,jSym) + else + iFirstCho = 1 + end if + + l_QVector = nJVec1*NumAux + l_RVector = MaxMOprod*nJVec1 + l_CVector = MaxMOprodR*NumAux + + call mma_allocate(QVector,l_QVector,Label='QVector') + call mma_allocate(RVector,l_RVector,Label='RVector') + call mma_allocate(CVector,l_CVector,Label='CVector') + + iSeed2 = 8 + LuCVec = IsFreeUnit(iSeed2) + if (iSO == 1) then + write(Fname2,'(A4,I1,I1)') 'CVEA',jSym + else if (iSO == 2) then + write(Fname2,'(A4,I1,I1)') 'CVEB',jSym + end if + call DANAME_MF_WA(LuCVec,Fname2) + iAdrC = 0 + + ! Get Q Vectors from Disk + !------------------------ + do iSym=1,nIrrep + lSym = Mul(iSym,jSym) + + if (nIJ1(iSym,lSym,iSO) >= 1) then + CVector(:) = Zero + + do iJBat=1,nJBat + if (iJBat == nJBat) then + njVec = nJVecLast + else + nJvec = nJvec1 + end if + + iSeed = 55+jSym-1 + Lu_Q = IsFreeUnit(iSeed) + write(Name_Q,'(A4,I2.2)') 'QVEC',jSym-1 + call DaName_MF_WA(Lu_Q,Name_Q) + l_Q = nJvec*NumAux + iAdrQ = (iFirstCho-1)*NumAux+(iJBat-1)*nJVec*NumAux + call dDaFile(Lu_Q,2,Qvector,l_Q,iAdrQ) + +# ifdef _DEBUGPRINT_ + call RecPrt('Q-vectors',' ',QVector,nJVec,NumAux) +# endif + + iSeed = 7 + LuRVec = IsFreeUnit(iSeed) + if (iSO == 1) then + write(Fname,'(A4,I1,I1)') 'CHTA',iSym,lSym + else if (iSO == 2) then + write(Fname,'(A4,I1,I1)') 'CHTB',iSym,lSym + end if + call DANAME_MF_WA(LuRVec,Fname) + + ! Loop over all cholesky vectors on all nodes + !-------------------------------------------- + + ! Get R-Vectors from disk + !------------------------ + + iAdrR = nIJ1(iSym,lSym,iSO)*nJVec1*(iJBat-1) + l_RVec = nJvec*nIJ1(iSym,lSym,iSO) + call dDaFile(LuRVec,2,RVector,l_RVec,iAdrR) + + call dGemm_('N','T',nIJ1(iSym,lSym,iSO),NumAux,nJVec,One,RVector,nIJ1(iSym,lSym,iSO),QVector,NumAux,Zero,CVector, & + nIJ1(iSym,lSym,iSO)) + end do + +# ifdef _DEBUGPRINT_ + write(u6,*) 'jSym=',jSym + call RecPrt('R-Vectors',' ',RVector,nIJ1(iSym,lSym,iSO),NumAux) + call RecPrt('C-Vectors',' ',CVector,nIJ1(iSym,lSym,iSO),NumAux) +# endif + if ((.not. lSA) .and. (iSym == lSym)) then + do iAux=1,NumAux + indx = -1 + do i=1,nChOrb(iSym-1,iSO) + indx = indx+i + indx2 = indx+(iAux-1)*nIJ1(iSym,lSym,iSO) + CVector(1+indx2) = CVector(1+indx2)/sqrt(Two) + end do + end do + end if + + call DaClos(Lu_Q) + call DACLOS(LuRVec) + + end if + + call GADGOP(CVector,l_CVector,'+') + iAdrCVec(jSym,iSym,iSO) = iAdrC + call dDaFile(LuCVec,1,CVector,nIJ1(iSym,lSym,iSO)*NumAux,iAdrC) + if (nIJ1(iSym,lSym,iSO) < nIJR(iSym,lSym,iSO)) then + iAdrC = iAdrC+(nIJR(iSym,lSym,iSO)-nIJ1(iSym,lSym,iSO))*NumAux + end if + + end do !iSym + + call mma_deallocate(CVector) + call mma_deallocate(RVector) + call mma_deallocate(QVector) + + call DACLOS(LuCVec) + +end do ! jSym + +call CWTime(TotCPU2,TotWall2) +TotCPU = TotCPU2-TotCPU1 +TotWall = TotWall2-TotWall1 +#ifdef _CD_TIMING_ +rMult_CPU = TOTCPU +rMult_Wall = TOTWALL +#endif + +if (timings) then + + CFmt = '(2x,A)' + write(u6,*) + write(u6,CFmt) 'Cholesky Gradients timing from '//SECNAM + write(u6,CFmt) '----------------------------------------' + write(u6,*) + write(u6,CFmt) '- - - - - - - - - - - - - - - - - - - - - - - - -' + write(u6,CFmt) ' CPU WALL ' + write(u6,CFmt) '- - - - - - - - - - - - - - - - - - - - - - - - -' + write(u6,'(2x,A26,2f10.2)') 'TOTAL ',TOTCPU,TOTWALL + write(u6,CFmt) '- - - - - - - - - - - - - - - - - - - - - - - - -' + write(u6,*) + +end if + +return + +end subroutine Mult_RijK_QKL diff -Nru openmolcas-22.02/src/ri_util/mult_vk_qv_s.f openmolcas-22.10/src/ri_util/mult_vk_qv_s.f --- openmolcas-22.02/src/ri_util/mult_vk_qv_s.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mult_vk_qv_s.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,88 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Mult_Vk_Qv_s(V_k,nV_k,Qv,nQv,V_kQ,nV_kQ,nBas_Aux, - & nVec,nIrrep,QMode) - Implicit Real*8 (a-h,o-z) - Real*8 Qv(nQv), V_k(nV_k), V_kQ(nV_kQ) - Integer nBas_Aux(0:nIrrep-1), nVec(0:nIrrep-1) - Logical Out_of_Core - Character QMode*1, Name_Q*6 -* * -************************************************************************ -* * - nMuNu=1 - kp_V_k=1 - lstepA=0 - lstepB=1 - If (Qmode.eq.'T') Then - Call FZero(V_kQ,nV_kQ) - lstepA=1 - lstepB=0 - End If - - Do iIrrep = 0, 0 ! loop is wisely restricted to tot. symm. irrep - iSeed=55+iIrrep - Lu_Q=IsFreeUnit(iSeed) - Write(Name_Q,'(A4,I2.2)') 'QVEC',iIrrep - Call DaName_MF_WA(Lu_Q,Name_Q) - iAddr=0 -* - nI=nBas_Aux(iIrrep) - If (iIrrep.eq.0) nI=nI-1 - nJ=nVec(iIrrep) - mQv=nI*nJ - Out_of_Core = mQv .gt. nQv -* * -************************************************************************ -* * - If (.Not.Out_of_Core) Then -* -* in-core case -* - Call dDaFile(Lu_Q,2,Qv,mQv,iAddr) -* - Call A_3C_Qv_s(V_k(kp_V_k), - & Qv, - & V_kQ,nMuNu,nI,nJ,QMode) -* - Else -* -* Out-of-core case -* - iOffA=kp_V_k - iOffB=iOffA - Do While (mQv.ge.nI) -* - nK=Min(mQv,nQv)/nI - lQv=nI*nK - Call dDaFile(Lu_Q,2,Qv,lQv,iAddr) -* - Call A_3C_Qv_s(V_k(iOffA), - & Qv, - & V_kQ(iOffB),nMuNu,nI,nK,QMode) - mQv = mQv - lQv - iOffA = iOffA + lstepA*nK - iOffB = iOffB + lstepB*nK - End Do -* - End If -* * -************************************************************************ -* * - Call DaClos(Lu_Q) -* - kp_V_k = kp_V_k + nBas_Aux(iIrrep) - End Do -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/ri_util/mult_vk_qv_s.F90 openmolcas-22.10/src/ri_util/mult_vk_qv_s.F90 --- openmolcas-22.02/src/ri_util/mult_vk_qv_s.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mult_vk_qv_s.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,94 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Mult_Vk_Qv_s(V_k,nV_k,Qv,nQv,V_kQ,nV_kQ,nBas_Aux,nVec,nIrrep,QMode) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nV_k, nQv, nV_kQ, nIrrep, nBas_Aux(0:nIrrep-1), nVec(0:nIrrep-1) +real(kind=wp), intent(in) :: V_k(nV_k) +real(kind=wp), intent(out) :: Qv(nQv), V_kQ(nV_kQ) +character, intent(in) :: QMode +integer(kind=iwp) :: iAddr, iIrrep, iOffA, iOffB, iSeed, kp_V_k, lQv, lstepA, lstepB, Lu_Q, mQv, nI, nJ, nK, nMuNu +logical(kind=iwp) :: Out_of_Core +character(len=6) :: Name_Q +integer(kind=iwp), external :: IsFreeUnit + +! * +!*********************************************************************** +! * +nMuNu = 1 +kp_V_k = 1 +lstepA = 0 +lstepB = 1 +if (Qmode == 'T') then + V_kQ(:) = Zero + lstepA = 1 + lstepB = 0 +end if + +do iIrrep=0,0 ! loop is wisely restricted to tot. symm. irrep + iSeed = 55+iIrrep + Lu_Q = IsFreeUnit(iSeed) + write(Name_Q,'(A4,I2.2)') 'QVEC',iIrrep + call DaName_MF_WA(Lu_Q,Name_Q) + iAddr = 0 + + nI = nBas_Aux(iIrrep) + if (iIrrep == 0) nI = nI-1 + nJ = nVec(iIrrep) + mQv = nI*nJ + Out_of_Core = mQv > nQv + ! * + !********************************************************************* + ! * + if (.not. Out_of_Core) then + + ! in-core case + + call dDaFile(Lu_Q,2,Qv,mQv,iAddr) + + call A_3C_Qv_s(V_k(kp_V_k),Qv,V_kQ,nMuNu,nI,nJ,QMode) + + else + + ! Out-of-core case + + iOffA = kp_V_k + iOffB = iOffA + do while (mQv >= nI) + + nK = min(mQv,nQv)/nI + lQv = nI*nK + call dDaFile(Lu_Q,2,Qv,lQv,iAddr) + + call A_3C_Qv_s(V_k(iOffA),Qv,V_kQ(iOffB),nMuNu,nI,nK,QMode) + mQv = mQv-lQv + iOffA = iOffA+lstepA*nK + iOffB = iOffB+lstepB*nK + end do + + end if + ! * + !********************************************************************* + ! * + call DaClos(Lu_Q) + + kp_V_k = kp_V_k+nBas_Aux(iIrrep) +end do +! * +!*********************************************************************** +! * +return + +end subroutine Mult_Vk_Qv_s diff -Nru openmolcas-22.02/src/ri_util/mult_with_q_mp2.f openmolcas-22.10/src/ri_util/mult_with_q_mp2.f --- openmolcas-22.02/src/ri_util/mult_with_q_mp2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mult_with_q_mp2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,216 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Jonas Bostrom * -************************************************************************ - Subroutine Mult_with_Q_MP2(nBas_aux,nBas,nIrrep) -************************************************************************** -* Author: Jonas Bostrom -* -* Purpose: Multiply MP2 A~_sep and B~_sep with inverse cholesky factors. -* -************************************************************************** - use ExTerm, only: nAuxVe, A - Implicit Real*8 (a-h,o-z) -#include "cholesky.fh" -#include "stdalloc.fh" -#include "exterm.fh" -* - Integer nBas_Aux(1:nIrrep), nBas(1:nIrrep) - Integer nLRb(8) - Character*6 Name_Q, Name - Integer Lu_B(4), Lu_A(2) , iAdrA_in(8), iAdrA_Out(8) -* - Character*15 SECNAM - Parameter (SECNAM = 'Mult_with_Q_MP2') - - Real*8, Allocatable:: QVec(:), A_t(:), A_ht(:) - Real*8, Allocatable:: B_t(:) -* -#include "chotime.fh" -* * -************************************************************************ -* * - CALL CWTime(TotCPU1,TotWall1) -* - Do i = 1,2 - iSeed=7 - Lu_A(i) = IsFreeUnit(iSeed) - Write(Name,'(A5,I1)') 'AMP2V', i - Call DaName_MF_WA(Lu_A(i),Name) - End Do -* - Do i = 1, 4 - iSeed = 7 - Lu_B(i) = IsFreeUnit(iSeed) - Write(Name,'(A5,I1)') 'BMP2V', i - Call DaName_MF_WA(Lu_B(i),Name) - End Do -* * -************************************************************************ -* * - iA_in = 1 - iA_Out = 1 - Do iSym = 1, nSym - NumCV = NumCho(iSym) - NumAux = nBas_Aux(iSym)-1 - nLR = 0 - Do jSym = 1, nSym - kSym = iEor(iSym-1,jSym-1)+1 - nLR = nLR + nBas(jSym)*nBas(kSym) - End Do - nLRb(iSym) = nLR - iAdrA_in(iSym) = iA_in - iA_in = iA_in + NumCV*NumCV - iAdrA_out(iSym) = iA_out - iA_out= iA_out+ NumAux*NumAux - End Do -* * -************************************************************************ -* * - Do iSym = 1, nSym -* - nBas2 = nLRb(iSym) - NumCV = NumCho(iSym) - NumAux = nBas_Aux(iSym)-1 - nAuxVe = NumAux -* -* Get Q-vectors from disk -* ----------------------- -* - l_Q = NumCV*NumAux - Call mma_allocate(QVec,l_Q,Label='QVec') -* - iSeed=7 - Lu_Q = IsFreeUnit(iSeed) - Write(Name_Q,'(A4,I2.2)') 'QVEC', iSym-1 - Call DaName_MF_WA(Lu_Q,Name_Q) -* - iOpt = 2 - iAdrQ=0 - Call dDaFile(Lu_Q,iOpt,QVec,l_Q,iAdrQ) -* -* Get MP2 A-tilde vectors from disk -* --------------------------------- -* - l_A_t = NumCV*NumCV - l_A = NumAux*NumAux - l_A_ht = NumAux*NumCV - Call mma_allocate(A_t,l_A_t,Label='A_t') - Call mma_allocate(A,l_A,Label='A') - Call mma_allocate(A_ht,l_A_ht,Label='A_ht') -* - Do iType = 1,2 -* - iOpt = 2 - iAdrA = iAdrA_in(iSym) - Call dDaFile(Lu_A(iType),iOpt,A_t,l_A_t,iAdrA) -#ifdef _DEBUGPRINT_ - Write(6,*) 'Q-vectors' - Do i = 1, l_Q - Write(6,*) QVec(i) - End Do - - Write(6,*) 'A-vectors' - Do i = 1, l_A - Write(6,*) A_t(i) - End Do -#endif -* -* Make first halftransformation to cholesky-base -* ---------------------------------------------- -* - Call dGemm_('N','N', NumAux, NumCV, NumCV, - & 1.0d0, QVec,NumAux, - & A_t, NumCV, - & 0.0d0, A_ht, NumAux) -* - Call dGemm_('N','T', NumAux, NumAux, NumCV, - & 1.0d0, A_ht, NumAux, - & QVec,NumAux, - & 0.0d0, A, NumAux) -* -* Put transformed A-vectors back on disk -* - iOpt = 1 - iAdrA = iAdrA_out(iSym) - Call dDaFile(Lu_A(iType),iOpt,A,l_A,iAdrA) -* - End Do -* - Call mma_deallocate(A_t) - Call mma_deallocate(A) - Call mma_deallocate(A_ht) -* * -************************************************************************ -* * - Call mma_maxDBLE(MaxMem) - MaxMem=9*(MaxMem/10) - Call mma_allocate(B_t,MaxMem,Label='B_t') -* - nVec = MaxMem / ( 2*nLRb(iSym) ) - nVec = min(Max(NumCV,NumAux),nVec) - If(nVec .lt. 1) Then - Call ChoMP2_Quit(SecNam,'nVec is non-positive','[1]') - End If -* - l_B_t = nLRb(iSym)*nVec - ip_B = 1 + l_B_t -* - Do iType = 1,2 -* -* The B-vectors should be read one batch at the time -* -------------------------------------------------- -* - Do kVec = 1, NumAux, nVec - NumVecK = Min(nVec,NumAux-(kVec-1)) -* - Do jVec = 1, NumCV, nVec - NumVecJ = Min(nVec,NumCV - (jVec-1)) -* - iOpt = 2 - lTot = NumVecJ*nLRb(iSym) - iAdr = 1 + nLRb(iSym)*(jVec-1) - Call dDaFile(Lu_B(iType),iOpt,B_t,lTot,iAdr) -* - Fac = 0.0D0 - If (jVec.ne.1) Fac = 1.0D0 - iOffQ1 = kVec + NumAux*(jVec-1) - Call dGemm_('N','T',nBas2, NumVecK, NumVecJ, - & 1.0d0,B_t, nBas2, - & QVec(iOffQ1),NumAux, - & Fac, B_t(ip_B),nBas2) - End Do -* - iOpt = 1 - lTot = NumVecK*nBas2 - iAdr = 1 + nBas2*(kVec-1) - Call dDaFile(Lu_B(iType+2),iOpt,B_t(ip_B),lTot,iAdr) -* - End Do -* - End Do -* - Call mma_deallocate(B_t) - Call mma_deallocate(QVec) -* - Call DaClos(Lu_Q) -* - End Do ! iSym -* - Do i = 1,2 - Call DaClos(Lu_A(i)) - End Do - Do i = 1, 4 - Call DaClos(Lu_B(i)) - End Do -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/mult_with_q_mp2.F90 openmolcas-22.10/src/ri_util/mult_with_q_mp2.F90 --- openmolcas-22.02/src/ri_util/mult_with_q_mp2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mult_with_q_mp2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,210 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Jonas Bostrom * +!*********************************************************************** + +subroutine Mult_with_Q_MP2(nBas_aux,nBas,nIrrep) +!************************************************************************* +! Author: Jonas Bostrom +! +! Purpose: Multiply MP2 A~_sep and B~_sep with inverse cholesky factors. +! +!************************************************************************* + +use Symmetry_Info, only: Mul +use RI_glob, only: A, nAuxVe +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nIrrep, nBas_Aux(1:nIrrep), nBas(1:nIrrep) +#include "cholesky.fh" +integer(kind=iwp) :: i, iA_in, iA_Out, iAdr, iAdrA, iAdrA_in(8), iAdrA_Out(8), iAdrQ, iOffQ1, iOpt, ip_B, iSeed, iSym, iType, & + jSym, jVec, kSym, kVec, l_A, l_A_ht, l_A_t, l_B_t, l_Q, lTot, Lu_A(2), Lu_B(4), Lu_Q, MaxMem, nBas2, nLR, & + nLRb(8), NumAux, NumCV, NumVecJ, NumVecK, nVec +real(kind=wp) :: Fac, TotCPU1, TotWall1 +character(len=6) :: FName, Name_Q +character(len=*), parameter :: SECNAM = 'Mult_with_Q_MP2' +real(kind=wp), allocatable :: A_ht(:), A_t(:), B_t(:), QVec(:) +integer(kind=iwp), external :: IsFreeUnit + +! * +!*********************************************************************** +! * +call CWTime(TotCPU1,TotWall1) + +do i=1,2 + iSeed = 7 + Lu_A(i) = IsFreeUnit(iSeed) + write(FName,'(A5,I1)') 'AMP2V',i + call DaName_MF_WA(Lu_A(i),FName) +end do + +do i=1,4 + iSeed = 7 + Lu_B(i) = IsFreeUnit(iSeed) + write(FName,'(A5,I1)') 'BMP2V',i + call DaName_MF_WA(Lu_B(i),FName) +end do +! * +!*********************************************************************** +! * +iA_in = 1 +iA_Out = 1 +do iSym=1,nSym + NumCV = NumCho(iSym) + NumAux = nBas_Aux(iSym)-1 + nLR = 0 + do jSym=1,nSym + kSym = Mul(iSym,jSym) + nLR = nLR+nBas(jSym)*nBas(kSym) + end do + nLRb(iSym) = nLR + iAdrA_in(iSym) = iA_in + iA_in = iA_in+NumCV*NumCV + iAdrA_out(iSym) = iA_out + iA_out = iA_out+NumAux*NumAux +end do +! * +!*********************************************************************** +! * +do iSym=1,nSym + + nBas2 = nLRb(iSym) + NumCV = NumCho(iSym) + NumAux = nBas_Aux(iSym)-1 + nAuxVe = NumAux + + ! Get Q-vectors from disk + ! ----------------------- + + l_Q = NumCV*NumAux + call mma_allocate(QVec,l_Q,Label='QVec') + + iSeed = 7 + Lu_Q = IsFreeUnit(iSeed) + write(Name_Q,'(A4,I2.2)') 'QVEC',iSym-1 + call DaName_MF_WA(Lu_Q,Name_Q) + + iOpt = 2 + iAdrQ = 0 + call dDaFile(Lu_Q,iOpt,QVec,l_Q,iAdrQ) + + ! Get MP2 A-tilde vectors from disk + ! --------------------------------- + + l_A_t = NumCV*NumCV + l_A = NumAux*NumAux + l_A_ht = NumAux*NumCV + call mma_allocate(A_t,l_A_t,Label='A_t') + call mma_allocate(A,l_A,Label='A') + call mma_allocate(A_ht,l_A_ht,Label='A_ht') + + do iType=1,2 + + iOpt = 2 + iAdrA = iAdrA_in(iSym) + call dDaFile(Lu_A(iType),iOpt,A_t,l_A_t,iAdrA) +# ifdef _DEBUGPRINT_ + write(u6,*) 'Q-vectors' + do i=1,l_Q + write(u6,*) QVec(i) + end do + + write(u6,*) 'A-vectors' + do i=1,l_A + write(u6,*) A_t(i) + end do +# endif + + ! Make first halftransformation to cholesky-base + ! ---------------------------------------------- + + call dGemm_('N','N',NumAux,NumCV,NumCV,One,QVec,NumAux,A_t,NumCV,Zero,A_ht,NumAux) + + call dGemm_('N','T',NumAux,NumAux,NumCV,One,A_ht,NumAux,QVec,NumAux,Zero,A,NumAux) + + ! Put transformed A-vectors back on disk + + iOpt = 1 + iAdrA = iAdrA_out(iSym) + call dDaFile(Lu_A(iType),iOpt,A,l_A,iAdrA) + + end do + + call mma_deallocate(A_t) + call mma_deallocate(A) + call mma_deallocate(A_ht) + ! * + !********************************************************************* + ! * + call mma_maxDBLE(MaxMem) + MaxMem = 9*(MaxMem/10) + call mma_allocate(B_t,MaxMem,Label='B_t') + + nVec = MaxMem/(2*nLRb(iSym)) + nVec = min(max(NumCV,NumAux),nVec) + if (nVec < 1) then + call ChoMP2_Quit(SecNam,'nVec is non-positive','[1]') + end if + + l_B_t = nLRb(iSym)*nVec + ip_B = 1+l_B_t + + do iType=1,2 + + ! The B-vectors should be read one batch at the time + ! -------------------------------------------------- + + do kVec=1,NumAux,nVec + NumVecK = min(nVec,NumAux-(kVec-1)) + + do jVec=1,NumCV,nVec + NumVecJ = min(nVec,NumCV-(jVec-1)) + + iOpt = 2 + lTot = NumVecJ*nLRb(iSym) + iAdr = 1+nLRb(iSym)*(jVec-1) + call dDaFile(Lu_B(iType),iOpt,B_t,lTot,iAdr) + + Fac = Zero + if (jVec /= 1) Fac = One + iOffQ1 = kVec+NumAux*(jVec-1) + call dGemm_('N','T',nBas2,NumVecK,NumVecJ,One,B_t,nBas2,QVec(iOffQ1),NumAux,Fac,B_t(ip_B),nBas2) + end do + + iOpt = 1 + lTot = NumVecK*nBas2 + iAdr = 1+nBas2*(kVec-1) + call dDaFile(Lu_B(iType+2),iOpt,B_t(ip_B),lTot,iAdr) + + end do + + end do + + call mma_deallocate(B_t) + call mma_deallocate(QVec) + + call DaClos(Lu_Q) + +end do ! iSym + +do i=1,2 + call DaClos(Lu_A(i)) +end do +do i=1,4 + call DaClos(Lu_B(i)) +end do + +return + +end subroutine Mult_with_Q_MP2 diff -Nru openmolcas-22.02/src/ri_util/mult_zp_qv_s.f openmolcas-22.10/src/ri_util/mult_zp_qv_s.f --- openmolcas-22.02/src/ri_util/mult_zp_qv_s.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mult_zp_qv_s.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,74 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Francesco Aquilante * -************************************************************************ - Subroutine Mult_Zp_Qv_s(Zp,nZp,Qv,nQv,Rv,n_Rv,nVec,nMuNu,nI, - & nIrrep,QMode) -************************************************************************ -* Author: F. Aquilante * -* * -* Qv: is a symmetry blocked square matrix * -* * -************************************************************************ - Implicit Real*8 (a-h,o-z) - Real*8 Zp(nZp), Qv(nQv), Rv(n_Rv) - Integer nVec(0:nIrrep-1), nMuNu(0:nIrrep-1), nI(0:nIrrep-1) - Character QMode*1, Name_Q*6 -* * -************************************************************************ -* * - lstepA=0 - lstepR=1 - If (Qmode.eq.'T') Then - Call FZero(Rv,n_Rv) - lstepA=1 - lstepR=0 - End If -* - iOffA=1 - iOffR=1 - - Do iIrrep = 0, nIrrep-1 - nI_ = nI(iIrrep) - If (iIrrep.eq.0) nI_=nI_-1 - nMuNu_ = nMuNu(iIrrep) - If (nMuNu_.le.0 .or. nI_.le.0) Go To 999 -* - iSeed=55+iIrrep - Lu_Q=IsFreeUnit(iSeed) - Write(Name_Q,'(A4,I2.2)') 'QVEC',iIrrep - Call DaName_MF_WA(Lu_Q,Name_Q) - iAddr=0 -* - iOffR2=iOffR - iOffA2=iOffA - mQv = nI_*nVec(iIrrep) - Do While (mQv.ge.nI_) -* - nK=Min(mQv,nQv)/nI_ - lQv=nI_*nK - Call dDaFile(Lu_Q,2,Qv,lQv,iAddr) -* - Call A_3C_Qv_s(Zp(iOffA2), - & Qv, - & Rv(iOffR2),nMuNu_,nI_,nK,QMode) - mQv = mQv - lQv - iOffR2 = iOffR2 + lstepR*nMuNu_*nK - iOffA2 = iOffA2 + lstepA*nMuNu_*nK - End Do -* - iOffA = iOffA + nMuNu_*nI_ - iOffR = iOffR + nMuNu_*nVec(iIrrep) - Call DaClos(Lu_Q) - 999 Continue - End Do - Return - End diff -Nru openmolcas-22.02/src/ri_util/mult_zp_qv_s.F90 openmolcas-22.10/src/ri_util/mult_zp_qv_s.F90 --- openmolcas-22.02/src/ri_util/mult_zp_qv_s.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/mult_zp_qv_s.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,82 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Francesco Aquilante * +!*********************************************************************** + +subroutine Mult_Zp_Qv_s(Zp,nZp,Qv,nQv,Rv,n_Rv,nVec,nMuNu,nI,nIrrep,QMode) +!*********************************************************************** +! Author: F. Aquilante * +! * +! Qv: is a symmetry blocked square matrix * +! * +!*********************************************************************** + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZp, nQv, n_Rv, nIrrep, nVec(0:nIrrep-1), nMuNu(0:nIrrep-1), nI(0:nIrrep-1) +real(kind=wp), intent(in) :: Zp(nZp) +real(kind=wp), intent(out) :: Qv(nQv), Rv(n_Rv) +character, intent(in) :: QMode +integer(kind=iwp) :: iAddr, iIrrep, iOffA, iOffA2, iOffR, iOffR2, iSeed, lQv, lstepA, lstepR, Lu_Q, mQv, nI_, nK, nMuNu_ +character(len=6) :: Name_Q +integer(kind=iwp), external :: IsFreeUnit + +! * +!*********************************************************************** +! * +lstepA = 0 +lstepR = 1 +if (Qmode == 'T') then + Rv(:) = Zero + lstepA = 1 + lstepR = 0 +end if + +iOffA = 1 +iOffR = 1 + +do iIrrep=0,nIrrep-1 + nI_ = nI(iIrrep) + if (iIrrep == 0) nI_ = nI_-1 + nMuNu_ = nMuNu(iIrrep) + if ((nMuNu_ <= 0) .or. (nI_ <= 0)) cycle + + iSeed = 55+iIrrep + Lu_Q = IsFreeUnit(iSeed) + write(Name_Q,'(A4,I2.2)') 'QVEC',iIrrep + call DaName_MF_WA(Lu_Q,Name_Q) + iAddr = 0 + + iOffR2 = iOffR + iOffA2 = iOffA + mQv = nI_*nVec(iIrrep) + do while (mQv >= nI_) + + nK = min(mQv,nQv)/nI_ + lQv = nI_*nK + call dDaFile(Lu_Q,2,Qv,lQv,iAddr) + + call A_3C_Qv_s(Zp(iOffA2),Qv,Rv(iOffR2),nMuNu_,nI_,nK,QMode) + mQv = mQv-lQv + iOffR2 = iOffR2+lstepR*nMuNu_*nK + iOffA2 = iOffA2+lstepA*nMuNu_*nK + end do + + iOffA = iOffA+nMuNu_*nI_ + iOffR = iOffR+nMuNu_*nVec(iIrrep) + call DaClos(Lu_Q) +end do + +return + +end subroutine Mult_Zp_Qv_s diff -Nru openmolcas-22.02/src/ri_util/nmemam.f openmolcas-22.10/src/ri_util/nmemam.f --- openmolcas-22.02/src/ri_util/nmemam.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/nmemam.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,62 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Integer Function nMemAm(nShBF,nIrrep,nS,jS,iOffA,Out_of_Core) - Integer nShBf(0:nIrrep-1,nS), iOffA(4,0:nIrrep-1) - Logical Out_of_Core -* - If (Out_Of_Core) Then -* -* Only a subblock of the upper trianular storage. -* - nMemAm=0 - Do iIrrep = 0, nIrrep-1 - nj = nShBf(iIrrep,jS) - nl = 0 - Do lS = 1, jS - nl = nl+ nShBf(iIrrep,lS) - End Do -* Offset to where this block starts - iOffA(1,iIrrep)=nMemAm -* # of basis functions for the jSs shell - iOffA(2,iIrrep)=nj -* max # number of basis functions for this block - iOffA(4,iIrrep)=nl -* Update nMemAm with the sise of this subblock. - nn = nl-nj - nMemAm = nMemAm + nl*(nl+1)/2 - nn*(nn+1)/2 - End Do - Else -* -* The whole A matrix is in core! Upper triangular storage. -* - nMemAm=0 - Do iIrrep = 0, nIrrep-1 - nj = nShBf(iIrrep,jS) - ni = 0 - Do lS = 1, jS-1 - ni = ni + nShBf(iIrrep,lS) - End Do - nl = ni + nj -* Offset to where this block starts - iOffA(1,iIrrep)=nMemAm+ni*(ni+1)/2 -* # of basis functions for the jSs shell - iOffA(2,iIrrep)=nj - iOffA(4,iIrrep)=nl -* Update nMemAm with the size of the whole block for this irrep. - Do lS = jS+1,nS - nl = nl + nShBf(iIrrep,lS) - End Do - nMemAm = nMemAm + nl*(nl+1)/2 - End Do - End If -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/nmemam.F90 openmolcas-22.10/src/ri_util/nmemam.F90 --- openmolcas-22.02/src/ri_util/nmemam.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/nmemam.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,72 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +function nMemAm(nShBF,nIrrep,nS,jS,iOffA,Out_of_Core) + +use Index_Functions, only: nTri_Elem +use Definitions, only: iwp + +implicit none +integer(kind=iwp) :: nMemAm +integer(kind=iwp),intent(in) :: nIrrep, nS, nShBf(0:nIrrep-1,nS), jS +integer(kind=iwp),intent(out) :: iOffA(4,0:nIrrep-1) +logical(kind=iwp),intent(in) :: Out_of_Core +integer(kind=iwp) :: iIrrep, lS, ni, nj, nl, nn + +if (Out_Of_Core) then + + ! Only a subblock of the upper trianular storage. + + nMemAm = 0 + do iIrrep=0,nIrrep-1 + nj = nShBf(iIrrep,jS) + nl = 0 + do lS=1,jS + nl = nl+nShBf(iIrrep,lS) + end do + ! Offset to where this block starts + iOffA(1,iIrrep) = nMemAm + ! # of basis functions for the jSs shell + iOffA(2,iIrrep) = nj + ! max # number of basis functions for this block + iOffA(4,iIrrep) = nl + ! Update nMemAm with the sise of this subblock. + nn = nl-nj + nMemAm = nMemAm+nTri_Elem(nl)-nTri_Elem(nn) + end do +else + + ! The whole A matrix is in core! Upper triangular storage. + + nMemAm = 0 + do iIrrep=0,nIrrep-1 + nj = nShBf(iIrrep,jS) + ni = 0 + do lS=1,jS-1 + ni = ni+nShBf(iIrrep,lS) + end do + nl = ni+nj + ! Offset to where this block starts + iOffA(1,iIrrep) = nMemAm+nTri_Elem(ni) + ! # of basis functions for the jSs shell + iOffA(2,iIrrep) = nj + iOffA(4,iIrrep) = nl + ! Update nMemAm with the size of the whole block for this irrep. + do lS=jS+1,nS + nl = nl+nShBf(iIrrep,lS) + end do + nMemAm = nMemAm+nTri_Elem(nl) + end do +end if + +return + +end function nMemAm diff -Nru openmolcas-22.02/src/ri_util/nsize_3c.f openmolcas-22.10/src/ri_util/nsize_3c.f --- openmolcas-22.02/src/ri_util/nsize_3c.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/nsize_3c.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,93 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Integer Function nSize_3C(kS,lS,nShBf,nShell, nIrrep,iOff, - & nBas_Aux) -************************************************************************ -* * -* Compute the size of ({nu,mu}|K) and the offsets to the * -* different symmetry blocks. * -* * -************************************************************************ - Integer nShBf(0:nIrrep-1,nShell), iOff(3,0:nIrrep-1), - & nBas_Aux(0:nIrrep-1) -* - nSize_3C=0 -* - If (nIrrep.eq.1) Then -* * -************************************************************************ -* * - Call IZero(iOff,3) - If (kS.ne.lS) Then - nK = nShBf(0,kS) - nL = nShBf(0,lS) - nKL = nK*nL - Else - nK = nShBf(0,kS) - nKL = nK*(nK+1)/2 - End If - iOff(1,0)=nKL -* - nJ = nBas_Aux(0)-1 - iOff(2,0) = nJ - nSize_3C = nJ*nkl -* * -************************************************************************ -* * - Else -* * -************************************************************************ -* * - Call IZero(iOff,3*nIrrep) - Do klIrrep = 0, nIrrep-1 - iOff(3,klIrrep) = nSize_3C -* - nKL = 0 - If (kS.ne.lS) Then - Do kIrrep = 0, nIrrep-1 - nK = nShBf(kIrrep,kS) - lIrrep = iEor(klIrrep,kIrrep) - nL = nShBf(lIrrep,lS) - nKL = nKL + nK*nL - End Do - Else - Do kIrrep = 0, nIrrep-1 - nK = nShBf(kIrrep,kS) - lIrrep = iEor(klIrrep,kIrrep) - nL = nShBf(lIrrep,lS) -* - If (kIrrep.gt.lIrrep) Then - nKL = nKL + nK*nL - Else If (kIrrep.eq.lIrrep) Then - nKL = nKL + nK*(nK+1)/2 - Else - nKL = nKL + 0 - End If -* - End Do - End If - iOff(1,klIrrep)=nKL -* - nJ = nBas_Aux(klIrrep) - If (klIrrep.eq.0) nJ = nJ-1 - iOff(2,klIrrep)=nJ - nSize_3C = nSize_3C + nJ*nKL -* - End Do -* * -************************************************************************ -* * - End If -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/ri_util/nsize_3c.F90 openmolcas-22.10/src/ri_util/nsize_3c.F90 --- openmolcas-22.02/src/ri_util/nsize_3c.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/nsize_3c.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,99 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +function nSize_3C(kS,lS,nShBf,nShell,nIrrep,iOff,nBas_Aux) +!*********************************************************************** +! * +! Compute the size of ({nu,mu}|K) and the offsets to the * +! different symmetry blocks. * +! * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem +use Symmetry_Info, only: Mul +use Definitions, only: iwp + +implicit none +integer(kind=iwp) :: nSize_3C +integer(kind=iwp), intent(in) :: kS, lS, nShell, nIrrep, nShBf(0:nIrrep-1,nShell), nBas_Aux(0:nIrrep-1) +integer(kind=iwp), intent(out) :: iOff(3,0:nIrrep-1) +integer(kind=iwp) :: kIrrep, klIrrep, lIrrep, nJ, nK, nKL, nL + +nSize_3C = 0 +iOff(:,:) = 0 + +if (nIrrep == 1) then + ! * + !********************************************************************* + ! * + if (kS /= lS) then + nK = nShBf(0,kS) + nL = nShBf(0,lS) + nKL = nK*nL + else + nK = nShBf(0,kS) + nKL = nTri_Elem(nK) + end if + iOff(1,0) = nKL + + nJ = nBas_Aux(0)-1 + iOff(2,0) = nJ + nSize_3C = nJ*nkl + ! * + !********************************************************************* + ! * +else + ! * + !********************************************************************* + ! * + do klIrrep=0,nIrrep-1 + iOff(3,klIrrep) = nSize_3C + + nKL = 0 + if (kS /= lS) then + do kIrrep=0,nIrrep-1 + nK = nShBf(kIrrep,kS) + lIrrep = Mul(klIrrep+1,kIrrep+1)-1 + nL = nShBf(lIrrep,lS) + nKL = nKL+nK*nL + end do + else + do kIrrep=0,nIrrep-1 + nK = nShBf(kIrrep,kS) + lIrrep = Mul(klIrrep+1,kIrrep+1)-1 + nL = nShBf(lIrrep,lS) + + if (kIrrep > lIrrep) then + nKL = nKL+nK*nL + else if (kIrrep == lIrrep) then + nKL = nKL+nTri_ELem(nK) + end if + + end do + end if + iOff(1,klIrrep) = nKL + + nJ = nBas_Aux(klIrrep) + if (klIrrep == 0) nJ = nJ-1 + iOff(2,klIrrep) = nJ + nSize_3C = nSize_3C+nJ*nKL + + end do + ! * + !********************************************************************* + ! * +end if +! * +!*********************************************************************** +! * +return + +end function nSize_3C diff -Nru openmolcas-22.02/src/ri_util/nsize_rv.f openmolcas-22.10/src/ri_util/nsize_rv.f --- openmolcas-22.02/src/ri_util/nsize_rv.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/nsize_rv.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,88 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Integer Function nSize_Rv(kS,lS,nShBf,nShell,nIrrep,iOff, - & nVec) -************************************************************************ -* * -* Compute the size of Rv(nu,mu,K) and the offsets to the * -* different symmetry blocks. * -* * -************************************************************************ - Integer nShBf(0:nIrrep-1,nShell), iOff(0:nIrrep-1), - & nVec(0:nIrrep-1) -* - nSize_Rv=0 -* - If (nIrrep.eq.1) Then -* * -************************************************************************ -* * - iOff(0)=0 - If (kS.ne.lS) Then - nK = nShBf(0,kS) - nL = nShBf(0,lS) - nKL = nK*nL - Else - nK = nShBf(0,kS) - nKL = nK*(nK+1)/2 - End If -* - nJ = nVec(0) - nSize_Rv = nJ*nkl -* * -************************************************************************ -* * - Else -* * -************************************************************************ -* * - Call IZero(iOff,nIrrep) - Do klIrrep = 0, nIrrep-1 - iOff(klIrrep) = nSize_Rv -* - nKL = 0 - If (kS.ne.lS) Then - Do kIrrep = 0, nIrrep-1 - nK = nShBf(kIrrep,kS) - lIrrep = iEor(klIrrep,kIrrep) - nL = nShBf(lIrrep,lS) - nKL = nKL + nK*nL - End Do - Else - Do kIrrep = 0, nIrrep-1 - nK = nShBf(kIrrep,kS) - lIrrep = iEor(klIrrep,kIrrep) - nL = nShBf(lIrrep,lS) -* - If (kIrrep.gt.lIrrep) Then - nKL = nKL + nK*nL - Else If (kIrrep.eq.lIrrep) Then - nKL = nKL + nK*(nK+1)/2 - Else - nKL = nKL + 0 - End If -* - End Do - End If -* - nJ = nVec(klIrrep) - nSize_Rv = nSize_Rv + nJ*nKL -* - End Do -* * -************************************************************************ -* * - End If -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/ri_util/nsize_rv.F90 openmolcas-22.10/src/ri_util/nsize_rv.F90 --- openmolcas-22.02/src/ri_util/nsize_rv.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/nsize_rv.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,94 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +function nSize_Rv(kS,lS,nShBf,nShell,nIrrep,iOff,nVec) +!*********************************************************************** +! * +! Compute the size of Rv(nu,mu,K) and the offsets to the * +! different symmetry blocks. * +! * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem +use Symmetry_Info, only: Mul +use Definitions, only: iwp + +implicit none +integer(kind=iwp) :: nSize_Rv +integer(kind=iwp), intent(in) :: kS, lS, nShell, nIrrep, nShBf(0:nIrrep-1,nShell), nVec(0:nIrrep-1) +integer(kind=iwp), intent(out) :: iOff(0:nIrrep-1) +integer(kind=iwp) :: kIrrep, klIrrep, lIrrep, nJ, nK, nKL, nL + +nSize_Rv = 0 +iOff(:) = 0 + +if (nIrrep == 1) then + ! * + !********************************************************************* + ! * + if (kS /= lS) then + nK = nShBf(0,kS) + nL = nShBf(0,lS) + nKL = nK*nL + else + nK = nShBf(0,kS) + nKL = nTri_Elem(nK) + end if + + nJ = nVec(0) + nSize_Rv = nJ*nkl + ! * + !********************************************************************* + ! * +else + ! * + !********************************************************************* + ! * + do klIrrep=0,nIrrep-1 + iOff(klIrrep) = nSize_Rv + + nKL = 0 + if (kS /= lS) then + do kIrrep=0,nIrrep-1 + nK = nShBf(kIrrep,kS) + lIrrep = Mul(klIrrep+1,kIrrep+1)-1 + nL = nShBf(lIrrep,lS) + nKL = nKL+nK*nL + end do + else + do kIrrep=0,nIrrep-1 + nK = nShBf(kIrrep,kS) + lIrrep = Mul(klIrrep+1,kIrrep+1)-1 + nL = nShBf(lIrrep,lS) + + if (kIrrep > lIrrep) then + nKL = nKL+nK*nL + else if (kIrrep == lIrrep) then + nKL = nKL+nTri_Elem(nK) + end if + + end do + end if + + nJ = nVec(klIrrep) + nSize_Rv = nSize_Rv+nJ*nKL + + end do + ! * + !********************************************************************* + ! * +end if +! * +!*********************************************************************** +! * +return + +end function nSize_Rv diff -Nru openmolcas-22.02/src/ri_util/o2n.f openmolcas-22.10/src/ri_util/o2n.f --- openmolcas-22.02/src/ri_util/o2n.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/o2n.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine O2N(AA,AB,BB,Temp,nA,nB,Error) - Implicit Real*8 (a-h,o-z) - Real*8 AA(nA,nA), AB(nA,nB), BB(nB,nB), Temp(nA,nB) -* * -************************************************************************ -* * -* (1) Project the new basis on to the old space and compute the -* matrix elements. -* - Call DGEMM_('N','N', - & nA,nB,nA, - & 1.0D0,AA,nA, - & AB,nA, - & 0.0D0,Temp,nA) - Call DGEMM_('T','N', - & nB,nB,nA, - & 1.0D0,AB,nA, - & Temp,nA, - & 0.0D0,BB,nB) -* * -************************************************************************ -* * -* (2) Do diagnostics on how poorly or good the -* new basis spans the old space -* - Error = DDot_(nA,AA,nA+1,AA,nA+1) - & - DDot_(nB,BB,nB+1,BB,nB+1) -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/o2n.F90 openmolcas-22.10/src/ri_util/o2n.F90 --- openmolcas-22.02/src/ri_util/o2n.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/o2n.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,41 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine O2N(AA,AB,BB,Temp,nA,nB,Error) + +use Constants, only: Zero, One +use Definitions, only: wp, iwp, r8 + +implicit none +integer(kind=iwp), intent(in) :: nA, nB +real(kind=wp), intent(in) :: AA(nA,nA), AB(nA,nB) +real(kind=wp), intent(out) :: BB(nB,nB), Temp(nA,nB), Error +real(kind=r8), external :: DDot_ + +! * +!*********************************************************************** +! * +! (1) Project the new basis on to the old space and compute the +! matrix elements. + +call DGEMM_('N','N',nA,nB,nA,One,AA,nA,AB,nA,Zero,Temp,nA) +call DGEMM_('T','N',nB,nB,nA,One,AB,nA,Temp,nA,Zero,BB,nB) +! * +!*********************************************************************** +! * +! (2) Do diagnostics on how poorly or good the +! new basis spans the old space + +Error = DDot_(nA,AA,nA+1,AA,nA+1)-DDot_(nB,BB,nB+1,BB,nB+1) + +return + +end subroutine O2N diff -Nru openmolcas-22.02/src/ri_util/ofembed_dmat.F90 openmolcas-22.10/src/ri_util/ofembed_dmat.F90 --- openmolcas-22.02/src/ri_util/ofembed_dmat.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/ofembed_dmat.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,38 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine OFembed_dmat(Dens,nDens) + +use OFembed, only: Do_OFemb +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nDens +real(kind=wp), intent(inout) :: Dens(nDens) +character(len=16) :: NamRfil +real(kind=wp), allocatable :: D_Var(:) + +if (.not. Do_OFemb) return + +call Get_NameRun(NamRfil) ! save the old RUNFILE name +call NameRun('AUXRFIL') ! switch RUNFILE name + +call mma_allocate(D_var,nDens,Label='D_var') +call get_dArray('D1aoVar',D_var,nDens) +Dens(:) = Dens-D_var +call mma_deallocate(D_Var) + +call NameRun(NamRfil) ! switch back to old RUNFILE name + +return + +end subroutine OFembed_dmat diff -Nru openmolcas-22.02/src/ri_util/off_diagonal.F90 openmolcas-22.10/src/ri_util/off_diagonal.F90 --- openmolcas-22.02/src/ri_util/off_diagonal.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/off_diagonal.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,32 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Off_Diagonal(B1,nB,iB1s,iB1e,B2,iB2s,iB2e) + +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: nB, iB1s, iB1e, iB2s, iB2e +real(kind=wp), intent(_OUT_) :: B1(nB,iB1s:iB1e) +real(kind=wp), intent(in) :: B2(nB,iB2s:iB2e) +integer(kind=iwp) :: i, j + +do j=iB2s,iB2e + do i=iB1s,iB1e + B1(j,i) = B2(i,j) + end do +end do + +return + +end subroutine Off_Diagonal diff -Nru openmolcas-22.02/src/ri_util/pget1_cd2.f openmolcas-22.10/src/ri_util/pget1_cd2.f --- openmolcas-22.02/src/ri_util/pget1_cd2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/pget1_cd2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,360 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1992,2007, Roland Lindh * -* 2009, Francesco Aquilante * -************************************************************************ - SubRoutine PGet1_CD2(PAO,ijkl,nPAO,iCmp, - & iAO,iAOst,Shijij,iBas,jBas,kBas,lBas,kOp, - & ExFac,CoulFac,PMax,V_k,U_k,mV_k,Z_p_K,nnP1) -************************************************************************ -* Object: to assemble the 2nd order density matrix of a SCF wave * -* function from the 1st order density. * -* * -* The indices has been scrambled before calling this routine. * -* Hence we must take special care in order to regain the can- * -* onical order. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -* January '92. * -* * -* Modified for Cholesky 1-center gradients May 2007 by * -* R. Lindh * -* * -* Modified for RI-HF/CAS, Dec 2009 (F. Aquilante) * -************************************************************************ - use SOAO_Info, only: iAOtSO - use ExTerm, only: CijK, iMP2prpt, nAuxVe - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "exterm.fh" - Real*8 PAO(ijkl,nPAO), V_k(mV_k), U_K(mV_K), Z_p_K(nnP1,mV_K), - & Fac_ij,Fac_kl - Integer iAO(4), kOp(4), iAOst(4), iCmp(4) - Logical Shijij - External mn2K - - Real*8, Pointer :: CiKj(:,:)=>Null(), V2(:)=>Null() -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - Call RecPrt('PGet1_CD2: V_k',' ',V_k,1,mV_k) -#endif -* * -************************************************************************ -* * -* Quadruple loop over elements of the basis functions angular -* description. -* Observe that we will walk through the memory in PAO in a -* sequential way. -* -C Fac = One / Four - - Call CWTime(Cpu1,Wall1) - - Fac = One - PMax=Zero - iPAO=0 - - iSym = 1 - jSym = 1 - lSym = 1 - iSO = 1 - - If(ExFac .eq. Zero) Then - - Do i1 = 1, iCmp(1) - Do i2 = 1, iCmp(2) - Do i3 = 1, iCmp(3) - Do i4 = 1, iCmp(4) -* -* Unfold the way the eight indicies have been reordered. - iSO = iAOtSO(iAO(1)+i1,kOp(1))+iAOst(1) - jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) - kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) - lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) -* - iPAO = iPAO + 1 - nijkl = 0 -* - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - Do kAOk = 0, kBas-1 - kSOk = kSO + kAOk - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - Do iAOi = 0, iBas-1 - iSOi = iSO + iAOi - nijkl = nijkl + 1 -* -*---------------------------V_k(ij)*V_k(kl) -* - Indi=Max(iSOi,jSOj) - Indj=iSOi+jSOj-Indi - Indk=Max(kSOk,lSOl) - Indl=kSOk+lSOl-Indk - Indij=(Indi-1)*Indi/2+Indj - Indkl=(Indk-1)*Indk/2+Indl - temp=V_k(Indij)*V_k(Indkl)*CoulFac -*-----Active space contribution (any factor?) - ijVec=mn2K(Indij,1) - klVec=mn2K(Indkl,1) - If (ijVec.eq.0 .or. klVec.eq.0) GoTo 11 - Do jp=1,nnP1 - temp = temp - & + Z_p_K(jp,ijVec)*Z_p_K(jp,klVec) - End Do -* - 11 Continue - PMax=Max(PMax,Abs(temp)) - PAO(nijkl,iPAO) = Fac * temp -* - End Do - End Do - End Do - End Do - End Do - End Do - End Do - End Do - Else If(iMP2prpt .ne. 2) Then - NumIK = nIJ1(iSym,lSym,iSO) - If(NumIK.eq.0) Return - - iS = 1 - iE = NumIK * 2 - CiKj(1:NumIK,1:2) => CijK(iS:iE) - - Do i1 = 1, iCmp(1) - Do i2 = 1, iCmp(2) - iSO = iAOtSO(iAO(1)+i1,kOp(1))+iAOst(1) - jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) - - Do i3 = 1, iCmp(3) - Do i4 = 1, iCmp(4) - kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) - lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) - - iPAO = iPAO + 1 - nijkl = 0 - - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - Do kAOk = 0, kBas-1 - kSOk = kSO + kAOk - Indk=Max(kSOk,lSOl) - Indl=kSOk+lSOl-Indk - Indkl=(Indk-1)*Indk/2+Indl - klVec=mn2K(Indkl,1) - - If(klvec.ne.0) Then - iAdrL = NumIK*(klVec-1) - & + iAdrCVec(jSym,iSym,iSO) - Call dDaFile(LuCVector(jSym,iSO),2, - & CiKj(:,1),NumIK,iAdrL) - End If - - - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - Do iAOi = 0, iBas-1 - iSOi = iSO + iAOi - nijkl = nijkl + 1 -* - Indi=Max(iSOi,jSOj) - Indj=iSOi+jSOj-Indi - Indij=(Indi-1)*Indi/2+Indj - ijVec=mn2K(Indij,1) - - If(ijVec.ne.klVec.and.ijvec.ne.0) Then - iAdrJ = NumIK*(ijVec-1) + - & iAdrCVec(jSym,iSym,iSO) - Call dDaFile(LuCVector(jSym,iSO),2, - & CiKj(:,2),NumIK,iAdrJ) - V2(1:) => CiKj(1:,2) - Else - V2(1:) => CiKj(1:,1) - End If - - temp=V_k(Indij)*V_k(Indkl)*CoulFac - - If (ijVec.eq.0 .or. klVec.eq.0) GoTo 22 - If(Indi .eq. Indj) Then - Fac_ij = 1.0d0 - Else - Fac_ij = 0.5d0 - End If - If(Indk .eq. Indl) Then - Fac_kl = 1.0d0 - Else - Fac_kl = 0.5d0 - End If - -*----- Exchange contribution - - temp = temp - ExFac*Fac_ij*Fac_kl* - & dDot_(NumIK,CiKJ(:,1),1,V2,1) -*-----Active space contribution (any factor?) - Do jp=1,nnP1 - temp = temp - & + Z_p_K(jp,ijVec)*Z_p_K(jp,klVec) - End Do -* - 22 Continue - PMax=Max(PMax,Abs(temp)) - PAO(nijkl,iPAO) = Fac * temp -* - End Do - End Do - End Do - End Do - End Do - End Do - End Do - End Do - Else - NumIK = nIJ1(iSym,lSym,iSO) - If(NumIK.eq.0) Return - - iS = 1 - iE = NumIK * 2 - CiKj(1:NumIK,1:2) => CijK(iS:iE) - - Do i1 = 1, iCmp(1) - Do i2 = 1, iCmp(2) - iSO = iAOtSO(iAO(1)+i1,kOp(1))+iAOst(1) - jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) - Do i3 = 1, iCmp(3) - Do i4 = 1, iCmp(4) - kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) - lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) - - iPAO = iPAO + 1 - nijkl = 0 -* - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - Do kAOk = 0, kBas-1 - kSOk = kSO + kAOk - Indk=Max(kSOk,lSOl) - Indl=kSOk+lSOl-Indk - Indkl=(Indk-1)*Indk/2+Indl - klVec=mn2K(Indkl,1) - If(klvec.ne.0) Then - iAdrL = NumIK*(klVec-1) - & + iAdrCVec(jSym,iSym,iSO) - Call dDaFile(LuCVector(jSym,iSO),2, - & CiKj(:,1),NumIK,iAdrL) - End If - - - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - Do iAOi = 0, iBas-1 - iSOi = iSO + iAOi - nijkl = nijkl + 1 -* - Indi=Max(iSOi,jSOj) - Indj=iSOi+jSOj-Indi - Indij=(Indi-1)*Indi/2+Indj - ijVec=mn2K(Indij,1) - - If(ijVec.ne.klVec.and.ijvec.ne.0) Then - iAdrJ = NumIK*(ijVec-1) + - & iAdrCVec(jSym,iSym,iSO) - Call dDaFile(LuCVector(jSym,iSO),2, - & CiKj(:,2),NumIK,iAdrJ) - V2(1:) => CiKj(:,2) - Else - V2(1:) => CiKj(:,1) - End If - - temp= V_k(Indij)*V_k(Indkl)*CoulFac - & + V_K(Indij)*U_K(Indkl)*CoulFac - & + U_K(Indij)*V_K(Indkl)*CoulFac - - If (ijVec.eq.0 .or. klVec.eq.0) GoTo 33 - If(Indi .eq. Indj) Then - Fac_ij = 1.0d0 - Else - Fac_ij = 0.5d0 - End If - If(Indk .eq. Indl) Then - Fac_kl = 1.0d0 - Else - Fac_kl = 0.5d0 - End If - -* -*----- MP2 contribution - Call Compute_A_jk_Mp2(1,ijVec,klVec, - & tempJ_mp2, - & Fac_ij,Fac_kl, - & nAuxVe,2) - temp = temp + tempJ_mp2*CoulFac -* -*----- Exchange contribution - - - tempK = 2.0d0*Fac_ij*Fac_kl* - & dDot_(NumIK,CiKj(:,1),1,V2,1) - Call compute_A_jk_Mp2(1,ijVec,klVec, - & tempK_mp2,fac_ij, - & fac_kl,nAuxVe,1) - - tempK = tempK + tempK_mp2 - - temp = temp - ExFac*tempK*Half -*----- Active space contribution (any factor?) - Do jp=1,nnP1 - temp = temp - & + Z_p_K(jp,ijVec)*Z_p_K(jp,klVec) - End Do -* - 33 Continue - PMax=Max(PMax,Abs(temp)) - PAO(nijkl,iPAO) = Fac * temp -* - End Do - End Do - End Do - End Do - End Do - End Do - End Do - End Do - End If -* - CiKj => Null() - V2 => Null() - - If (iPAO.ne.nPAO) Then - Write (6,*) ' Error in PGet1_CD2!' - Call Abend - End If -* -#ifdef _DEBUGPRINT_ - Call RecPrt(' In PGet1_CD2:PAO ',' ',PAO,ijkl,nPAO) -#endif - - Call CWTime(Cpu2,Wall2) - Cpu = Cpu2 - Cpu1 - Wall = Wall2 - Wall1 - tavec(1) = tavec(1) + Cpu - tavec(2) = tavec(2) + Wall - - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_logical(Shijij) - End If - End diff -Nru openmolcas-22.02/src/ri_util/pget1_cd2.F90 openmolcas-22.10/src/ri_util/pget1_cd2.F90 --- openmolcas-22.02/src/ri_util/pget1_cd2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/pget1_cd2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,323 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1992,2007, Roland Lindh * +! 2009, Francesco Aquilante * +!*********************************************************************** + +subroutine PGet1_CD2(PAO,ijkl,nPAO,iCmp,iAO,iAOst,iBas,jBas,kBas,lBas,kOp,ExFac,CoulFac,PMax,V_k,U_k,mV_k,Z_p_K,nnP1) +!*********************************************************************** +! Object: to assemble the 2nd order density matrix of a SCF wave * +! function from the 1st order density. * +! * +! The indices have been scrambled before calling this routine.* +! Hence we must take special care in order to regain the * +! canonical order. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +! January '92. * +! * +! Modified for Cholesky 1-center gradients May 2007 by * +! R. Lindh * +! * +! Modified for RI-HF/CAS, Dec 2009 (F. Aquilante) * +!*********************************************************************** + +use Index_Functions, only: iTri +use pso_stuff, only: ij2K, iOff_ij2K +use SOAO_Info, only: iAOtSO +use RI_glob, only: CijK, iAdrCVec, iMP2prpt, LuCVector, nAuxVe, nIJ1, tavec +use Constants, only: Zero, One, Two, Half +use Definitions, only: wp, iwp, u6, r8 + +implicit none +integer(kind=iwp), intent(in) :: ijkl, nPAO, iCmp(4), iAO(4), iAOst(4), iBas, jBas, kBas, lBas, kOp(4), mV_k, nnP1 +real(kind=wp), intent(out) :: PAO(ijkl,nPAO), PMax +real(kind=wp), intent(in) :: ExFac, CoulFac, V_k(mV_k), U_K(mV_K), Z_p_K(nnP1,mV_K) +integer(kind=iwp) :: i1, i2, i3, i4, iAdrJ, iAdrL, iAOi, iE, ijVec, Indij, Indkl, iPAO, iS, iSO, iSOi, iSym, jAOj, jp, jSO, jSOj, & + jSym, kAOk, klVec, kSO, kSOk, lAOl, lSO, lSOl, lSym, nijkl, NumIK +real(kind=wp) :: Cpu, Cpu1, Cpu2, Fac, Fac_ij, Fac_kl, temp, tempJ_mp2, tempK, tempK_mp2, Wall, Wall1, Wall2 +real(kind=wp), pointer :: CiKj(:,:), V2(:) +real(kind=r8), external :: dDot_ + +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +call RecPrt('PGet1_CD2: V_k',' ',V_k,1,mV_k) +#endif +! * +!*********************************************************************** +! * +! Quadruple loop over elements of the basis functions angular description. +! Observe that we will walk through the memory in PAO in a sequential way. +! +!Fac = Quart + +call CWTime(Cpu1,Wall1) + +Fac = One +PMax = Zero +iPAO = 0 + +iSym = 1 +jSym = 1 +lSym = 1 +iSO = 1 + +if (ExFac == Zero) then + + do i1=1,iCmp(1) + do i2=1,iCmp(2) + do i3=1,iCmp(3) + do i4=1,iCmp(4) + + ! Unfold the way the eight indicies have been reordered. + iSO = iAOtSO(iAO(1)+i1,kOp(1))+iAOst(1) + jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) + kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) + lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + + iPAO = iPAO+1 + nijkl = 0 + + do lAOl=0,lBas-1 + lSOl = lSO+lAOl + do kAOk=0,kBas-1 + kSOk = kSO+kAOk + do jAOj=0,jBas-1 + jSOj = jSO+jAOj + do iAOi=0,iBas-1 + iSOi = iSO+iAOi + nijkl = nijkl+1 + + ! V_k(ij)*V_k(kl) + + Indij = iTri(iSOi,jSOj) + Indkl = iTri(kSOk,lSOl) + temp = V_k(Indij)*V_k(Indkl)*CoulFac + ! Active space contribution (any factor?) + ijVec = ij2K(iOff_ij2K(1)+Indij) + klVec = ij2K(iOff_ij2K(1)+Indkl) + if ((ijVec /= 0) .and. (klVec /= 0)) then + do jp=1,nnP1 + temp = temp+Z_p_K(jp,ijVec)*Z_p_K(jp,klVec) + end do + end if + + PMax = max(PMax,abs(temp)) + PAO(nijkl,iPAO) = Fac*temp + + end do + end do + end do + end do + end do + end do + end do + end do +else if (iMP2prpt /= 2) then + NumIK = nIJ1(iSym,lSym,iSO) + if (NumIK == 0) return + + iS = 1 + iE = NumIK*2 + CiKj(1:NumIK,1:2) => CijK(iS:iE) + + do i1=1,iCmp(1) + do i2=1,iCmp(2) + iSO = iAOtSO(iAO(1)+i1,kOp(1))+iAOst(1) + jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) + + do i3=1,iCmp(3) + do i4=1,iCmp(4) + kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) + lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + + iPAO = iPAO+1 + nijkl = 0 + + do lAOl=0,lBas-1 + lSOl = lSO+lAOl + do kAOk=0,kBas-1 + kSOk = kSO+kAOk + Indkl = iTri(kSOk,lSOl) + klVec = ij2K(iOff_ij2K(1)+Indkl) + + if (klvec /= 0) then + iAdrL = NumIK*(klVec-1)+iAdrCVec(jSym,iSym,iSO) + call dDaFile(LuCVector(jSym,iSO),2,CiKj(:,1),NumIK,iAdrL) + end if + + do jAOj=0,jBas-1 + jSOj = jSO+jAOj + do iAOi=0,iBas-1 + iSOi = iSO+iAOi + nijkl = nijkl+1 + + Indij = iTri(iSOi,jSOj) + ijVec = ij2K(iOff_ij2K(1)+Indij) + + if ((ijVec /= klVec) .and. (ijvec /= 0)) then + iAdrJ = NumIK*(ijVec-1)+iAdrCVec(jSym,iSym,iSO) + call dDaFile(LuCVector(jSym,iSO),2,CiKj(:,2),NumIK,iAdrJ) + V2(1:) => CiKj(1:,2) + else + V2(1:) => CiKj(1:,1) + end if + + temp = V_k(Indij)*V_k(Indkl)*CoulFac + + if ((ijVec /= 0) .and. (klVec /= 0)) then + if (iSOi == jSOj) then + Fac_ij = One + else + Fac_ij = Half + end if + if (kSOk == lSOl) then + Fac_kl = One + else + Fac_kl = Half + end if + + ! Exchange contribution + + temp = temp-ExFac*Fac_ij*Fac_kl*dDot_(NumIK,CiKJ(:,1),1,V2,1) + ! Active space contribution (any factor?) + do jp=1,nnP1 + temp = temp+Z_p_K(jp,ijVec)*Z_p_K(jp,klVec) + end do + end if + + PMax = max(PMax,abs(temp)) + PAO(nijkl,iPAO) = Fac*temp + + end do + end do + end do + end do + end do + end do + end do + end do +else + NumIK = nIJ1(iSym,lSym,iSO) + if (NumIK == 0) return + + iS = 1 + iE = NumIK*2 + CiKj(1:NumIK,1:2) => CijK(iS:iE) + + do i1=1,iCmp(1) + do i2=1,iCmp(2) + iSO = iAOtSO(iAO(1)+i1,kOp(1))+iAOst(1) + jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) + do i3=1,iCmp(3) + do i4=1,iCmp(4) + kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) + lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + + iPAO = iPAO+1 + nijkl = 0 + + do lAOl=0,lBas-1 + lSOl = lSO+lAOl + do kAOk=0,kBas-1 + kSOk = kSO+kAOk + Indkl = iTri(kSOk,lSOl) + klVec = ij2K(iOff_ij2K(1)+Indkl) + if (klvec /= 0) then + iAdrL = NumIK*(klVec-1)+iAdrCVec(jSym,iSym,iSO) + call dDaFile(LuCVector(jSym,iSO),2,CiKj(:,1),NumIK,iAdrL) + end if + + do jAOj=0,jBas-1 + jSOj = jSO+jAOj + do iAOi=0,iBas-1 + iSOi = iSO+iAOi + nijkl = nijkl+1 + + Indij = iTri(iSOi,jSOj) + ijVec = ij2K(iOff_ij2K(1)+Indij) + + if ((ijVec /= klVec) .and. (ijvec /= 0)) then + iAdrJ = NumIK*(ijVec-1)+iAdrCVec(jSym,iSym,iSO) + call dDaFile(LuCVector(jSym,iSO),2,CiKj(:,2),NumIK,iAdrJ) + V2(1:) => CiKj(:,2) + else + V2(1:) => CiKj(:,1) + end if + + temp = V_k(Indij)*V_k(Indkl)*CoulFac+V_K(Indij)*U_K(Indkl)*CoulFac+U_K(Indij)*V_K(Indkl)*CoulFac + + if ((ijVec /= 0) .and. (klVec /= 0)) then + if (iSOi == jSOj) then + Fac_ij = One + else + Fac_ij = Half + end if + if (kSOk == lSOl) then + Fac_kl = One + else + Fac_kl = Half + end if + + ! MP2 contribution + call Compute_A_jk_Mp2(ijVec,klVec,tempJ_mp2,Fac_ij,Fac_kl,nAuxVe,2) + temp = temp+tempJ_mp2*CoulFac + + ! Exchange contribution + + tempK = Two*Fac_ij*Fac_kl*dDot_(NumIK,CiKj(:,1),1,V2,1) + call compute_A_jk_Mp2(ijVec,klVec,tempK_mp2,fac_ij,fac_kl,nAuxVe,1) + + tempK = tempK+tempK_mp2 + + temp = temp-ExFac*tempK*Half + ! Active space contribution (any factor?) + do jp=1,nnP1 + temp = temp+Z_p_K(jp,ijVec)*Z_p_K(jp,klVec) + end do + end if + + PMax = max(PMax,abs(temp)) + PAO(nijkl,iPAO) = Fac*temp + + end do + end do + end do + end do + end do + end do + end do + end do +end if + +nullify(CiKj,V2) + +if (iPAO /= nPAO) then + write(u6,*) ' Error in PGet1_CD2!' + call Abend() +end if + +#ifdef _DEBUGPRINT_ +call RecPrt(' In PGet1_CD2:PAO ',' ',PAO,ijkl,nPAO) +#endif + +call CWTime(Cpu2,Wall2) +Cpu = Cpu2-Cpu1 +Wall = Wall2-Wall1 +tavec(1) = tavec(1)+Cpu +tavec(2) = tavec(2)+Wall + +return + +end subroutine PGet1_CD2 diff -Nru openmolcas-22.02/src/ri_util/pget1_cd3.f openmolcas-22.10/src/ri_util/pget1_cd3.f --- openmolcas-22.02/src/ri_util/pget1_cd3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/pget1_cd3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,326 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1992,2007, Roland Lindh * -************************************************************************ - SubRoutine PGet1_CD3(PAO,ijkl,nPAO,iCmp, - & iAO,iAOst,Shijij,iBas,jBas,kBas,lBas,kOp, - & DSO,DSSO,DSO_Var,nDSO,ExFac,CoulFac,PMax,V_k, - & U_k,mV_k) -************************************************************************ -* Object: to assemble the 2nd order density matrix of a SCF wave * -* function from the 1st order density. * -* * -* The indices has been scrambled before calling this routine. * -* Hence we must take special care in order to regain the can- * -* onical order. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -* January '92. * -* * -* Modified for Cholesky 1-center gradients May 2007 by * -* R. Lindh * -************************************************************************ - use Basis_Info, only: nBas - use SOAO_Info, only: iAOtSO - use ExTerm, only: CijK, CilK, BklK, BMP2, iMP2prpt, LuBVector, - & CMOi - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "exterm.fh" - Real*8 PAO(ijkl,nPAO), DSO(nDSO), DSSO(nDSO), V_k(mV_k), - & U_k(mV_k), DSO_Var(nDSO) - Integer iAO(4), kOp(4), iAOst(4), iCmp(4) - Logical Shijij -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - iComp = 1 - Call PrMtrx('DSO ',[iD0Lbl],iComp,1,D0) -#endif -* * -************************************************************************ -* * -* Quadruple loop over elements of the basis functions angular -* description. -* Observe that we will walk through the memory in PAO in a -* sequential way. -* -C Fac = One / Four - - Call CWTime(Cpu1,Wall1) - - Fac = One / Two - PMax=Zero - iPAO = 0 - jSym = 1 - kSym = 1 - lSym = 1 - NumOrb = nChOrb(kSym-1,1) - - If(ExFac .ne. Zero .and. NumOrb .gt.0 .and. iMP2prpt .ne. 2) Then - - nKBas = kBas*iCmp(3) - nLBas = lBas*iCmp(4) - - kSO = iAOtSO(iAO(3)+1,kOp(3))+iAOst(3) - lSO = iAOtSO(iAO(4)+1,kOp(4))+iAOst(4) - - Do i1 = 1, iCmp(1) - iSO = iAOtSO(iAO(1)+i1,kOp(1))+iAOst(1) - Do iAOi = 0, iBas-1 - iSOi = iSO + iAOi - Do i2 = 1, iCmp(2) - jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - Indi=Max(iSOi,jSOj) - Indj=iSOi+jSOj-Indi - If(Indi .eq. Indj) Then - Fac_ij = 1.0d0 - Else - Fac_ij = 0.5d0 - End If - Indij=(Indi-1)*Indi/2+Indj - ijVec=mn2K(Indij,1) - - If(ijVec.ne.0) Then - iAdr = nIJR(kSym,lSym,1)*(ijVec-1) + - & iAdrCVec(jSym,kSym,1) - Call dDaFile(LuCVector(jSym,1),2,CijK, - & nIJR(kSym,lSym,1),iAdr) - - Call dGEMM_('T','N',NumOrb,nKBas,NumOrb, - & 1.0d0,CijK,NumOrb, - & CMOi(1)%SB(1)%A2(:,kSO),NumOrb, - & 0.0d0,CilK,Max(1,NumOrb)) - - Call dGEMM_('T','N',nKBas,nLBas,NumOrb, - & 1.0d0,CilK,NumOrb, - & CMOi(1)%SB(1)%A2(:,lSO),NumOrb, - & 0.0d0,BklK,Max(1,nKBas)) - End If - - Do i3 = 1, iCmp(3) - kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) - Do i4 = 1, iCmp(4) - lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) - - iPAO = i4 + (i3-1)*iCmp(4) - & + (i2-1)*iCmp(4)*iCmp(3) - & + (i1-1)*iCmp(4)*iCmp(3)*iCmp(2) - - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - Do kAOk = 0, kBas-1 - kSOk = kSO + kAOk - indexB = 1 + (kAOk + (i3-1)*kBas) - & + (lAOl + (i4-1)*lBas)*nKBas - nijkl = iAOi + jAOj*iBas - & + kAOk*iBas*jBas - & + lAOl*iBas*jBas*kBas + 1 - - Indk=Max(kSOk,lSOl) - Indl=kSOk+lSOl-Indk - Indkl=(Indk-1)*Indk/2+Indl - temp=V_k(Indij)*DSO(Indkl)*coulfac - If(ijVec .ne. 0) Then - tempK = BklK(indexB) - Else - tempK = 0.0d0 - End If - - temp = temp - tempK*ExFac*Half*fac_ij - PMax=Max(PMax,Abs(Temp)) - PAO(nijkl,iPAO) = Fac * temp -* - End Do - End Do - End Do - End Do - End Do - End Do - End Do - End Do - - Else If(iMP2prpt .eq. 2 .and. NumOrb .gt. 0) Then - - nKBas = kBas*iCmp(3) - nLBas = lBas*iCmp(4) - - kSO = iAOtSO(iAO(3)+1,kOp(3))+iAOst(3) - lSO = iAOtSO(iAO(4)+1,kOp(4))+iAOst(4) - - Do i1 = 1, iCmp(1) - iSO = iAOtSO(iAO(1)+i1,kOp(1))+iAOst(1) - Do iAOi = 0, iBas-1 - iSOi = iSO + iAOi - Do i2 = 1, iCmp(2) - jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - Indi=Max(iSOi,jSOj) - Indj=iSOi+jSOj-Indi - If(Indi .eq. Indj) Then - Fac_ij = 1.0d0 - Else - Fac_ij = 0.5d0 - End If - Indij=(Indi-1)*Indi/2+Indj - ijVec=mn2K(Indij,1) - If(ijVec.ne.0) Then - iAdr = nIJR(kSym,lSym,1)*(ijVec-1) + - & iAdrCVec(jSym,kSym,1) - Call dDaFile(LuCVector(jSym,1),2,CijK, - & nIJR(kSym,lSym,1),iAdr) - - Call dGEMM_('T','N',NumOrb,nKBas,NumOrb, - & 1.0d0,CijK,NumOrb, - & CMOi(1)%SB(1)%A2(:,kSO),NumOrb, - & 0.0d0,CilK,Max(1,NumOrb)) - - Call dGEMM_('T','N',nKBas,nLBas,NumOrb, - & 1.0d0,CilK,NumOrb, - & CMOi(1)%SB(1)%A2(:,lSO),NumOrb, - & 0.0d0,BklK,Max(1,nKBas)) - lBVec = nBas(0)*nBas(0) - Do i = 1,2 - iAdr = 1 + nBas(0)*nBas(0)*(ijVec-1) - Call dDaFile(LuBVector(i),2,Bmp2(:,i),lBVec, - & iAdr) - End Do - - End If - Do i3 = 1, iCmp(3) - kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) - Do i4 = 1, iCmp(4) - lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) - - iPAO = i4 + (i3-1)*iCmp(4) - & + (i2-1)*iCmp(4)*iCmp(3) - & + (i1-1)*iCmp(4)*iCmp(3)*iCmp(2) - - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - Do kAOk = 0, kBas-1 - kSOk = kSO + kAOk - indexB = 1 + (kAOk + (i3-1)*kBas) - & + (lAOl + (i4-1)*lBas)*nKBas - nijkl = iAOi + jAOj*iBas - & + kAOk*iBas*jBas - & + lAOl*iBas*jBas*kBas + 1 - - Indk=Max(kSOk,lSOl) - Indl=kSOk+lSOl-Indk - Indkl=(Indk-1)*Indk/2+Indl - temp=V_k(Indij)*DSO(Indkl)*coulfac - - If(ijVec.ne.0) Then - tempK = BklK(indexB) - Else - tempK = 0.0d0 - End If - temp = temp - & + U_k(indij)*DSO(indkl)*CoulFac - temp = temp + V_k(indij)* - & (DSO_Var(indkl)-DSO(indkl))*CoulFac - if(ijVec.ne.0) Then - tempJ = Compute_B(irc,kSOk, - & lSOl,0,nBas(0),2) - temp = temp + tempJ*CoulFac* - & fac_ij - - tempK = tempK + - & Compute_B(irc,kSOk,lSOl, - & 0,nBas(0),1) - End If - temp = temp - tempK*ExFac*Half*fac_ij - PMax=Max(PMax,Abs(Temp)) - PAO(nijkl,iPAO) = Fac * temp -* - End Do - End Do - End Do - End Do - End Do - End Do - End Do - End Do - - - Else - Do i1 = 1, iCmp(1) - Do i2 = 1, iCmp(2) - Do i3 = 1, iCmp(3) - Do i4 = 1, iCmp(4) - iSO = iAOtSO(iAO(1)+i1,kOp(1))+iAOst(1) - jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) - kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) - lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) -* - iPAO = iPAO + 1 -* - nijkl = 0 - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - Do kAOk = 0, kBas-1 - kSOk = kSO + kAOk - Indk=Max(kSOk,lSOl) - Indl=kSOk+lSOl-Indk - Indkl=(Indk-1)*Indk/2+Indl - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - Do iAOi = 0, iBas-1 - iSOi = iSO + iAOi - nijkl = nijkl + 1 -* -*---------------------------V_k(ij)*D(kl) -* - Indi=Max(iSOi,jSOj) - Indj=iSOi+jSOj-Indi - Indij=(Indi-1)*Indi/2+Indj -* - temp=V_k(Indij)*DSO(Indkl)*coulfac -* - PMax=Max(PMax,Abs(Temp)) - PAO(nijkl,iPAO) = Fac * temp - End Do - End Do - End Do - End Do - End Do - End Do - End Do - End Do - End If - If (iPAO.ne.nPAO) Then - Write (6,*) ' Error in PGet1_CD3!' - Call Abend - End If -* -#ifdef _DEBUGPRINT_ - Call RecPrt(' In PGet1_CD3:PAO ',' ',PAO,ijkl,nPAO) -#endif - - Call CWTime(Cpu2,Wall2) - Cpu = Cpu2 - Cpu1 - Wall = Wall2 - Wall1 - tbvec(1) = tbvec(1) + Cpu - tbvec(2) = tbvec(2) + Wall - - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_logical(Shijij) - Call Unused_real_array(DSSO) - End If - End diff -Nru openmolcas-22.02/src/ri_util/pget1_cd3.F90 openmolcas-22.10/src/ri_util/pget1_cd3.F90 --- openmolcas-22.02/src/ri_util/pget1_cd3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/pget1_cd3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,279 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1992,2007, Roland Lindh * +!*********************************************************************** + +subroutine PGet1_CD3(PAO,ijkl,nPAO,iCmp,iAO,iAOst,iBas,jBas,kBas,lBas,kOp,DSO,DSO_Var,nDSO,ExFac,CoulFac,PMax,V_k,U_k,mV_k) +!*********************************************************************** +! Object: to assemble the 2nd order density matrix of a SCF wave * +! function from the 1st order density. * +! * +! The indices have been scrambled before calling this routine.* +! Hence we must take special care in order to regain the * +! canonical order. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +! January '92. * +! * +! Modified for Cholesky 1-center gradients May 2007 by * +! R. Lindh * +!*********************************************************************** + +use Index_Functions, only: iTri +use pso_stuff, only: ij2K, iOff_ij2K +use Basis_Info, only: nBas +use SOAO_Info, only: iAOtSO +use RI_glob, only: BklK, BMP2, CijK, CilK, CMOi, iAdrCVec, iMP2prpt, LuBVector, LuCVector, nChOrb, nIJR, tbvec +use Constants, only: Zero, One, Half +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: ijkl, nPAO, iCmp(4), iAO(4), iAOst(4), iBas, jBas, kBas, lBas, kOp(4), nDSO, mV_k +real(kind=wp), intent(out) :: PAO(ijkl,nPAO), PMax +real(kind=wp), intent(in) :: DSO(nDSO), DSO_Var(nDSO), ExFac, CoulFac, V_k(mV_k), U_k(mV_k) +integer(kind=iwp) :: i, i1, i2, i3, i4, iAdr, iAOi, ijVec, indexB, Indij, Indkl, iPAO, irc, iSO, iSOi, jAOj, jSO, jSOj, jSym, & + kAOk, kSO, kSOk, kSym, lAOl, lBVec, lSO, lSOl, lSym, nijkl, nKBas, nLBas, NumOrb +real(kind=wp) :: Cpu, Cpu1, Cpu2, Fac, Fac_ij, temp, tempJ, tempK, Wall, Wall1, Wall2 +real(kind=wp), external :: Compute_B + +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +iComp = 1 +call PrMtrx('DSO ',[iD0Lbl],iComp,1,D0) +#endif +! * +!*********************************************************************** +! * +! Quadruple loop over elements of the basis functions angular description. +! Observe that we will walk through the memory in PAO in a sequential way. +! +!Fac = Quart + +call CWTime(Cpu1,Wall1) + +Fac = Half +PMax = Zero +iPAO = 0 +jSym = 1 +kSym = 1 +lSym = 1 +NumOrb = nChOrb(kSym-1,1) + +if ((ExFac /= Zero) .and. (NumOrb > 0) .and. (iMP2prpt /= 2)) then + + nKBas = kBas*iCmp(3) + nLBas = lBas*iCmp(4) + + kSO = iAOtSO(iAO(3)+1,kOp(3))+iAOst(3) + lSO = iAOtSO(iAO(4)+1,kOp(4))+iAOst(4) + + do i1=1,iCmp(1) + iSO = iAOtSO(iAO(1)+i1,kOp(1))+iAOst(1) + do iAOi=0,iBas-1 + iSOi = iSO+iAOi + do i2=1,iCmp(2) + jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) + do jAOj=0,jBas-1 + jSOj = jSO+jAOj + if (iSOi == jSOj) then + Fac_ij = One + else + Fac_ij = Half + end if + Indij = iTri(iSOi,jSOj) + ijVec = ij2K(iOff_ij2K(1)+Indij) + + if (ijVec /= 0) then + iAdr = nIJR(kSym,lSym,1)*(ijVec-1)+iAdrCVec(jSym,kSym,1) + call dDaFile(LuCVector(jSym,1),2,CijK,nIJR(kSym,lSym,1),iAdr) + + call dGEMM_('T','N',NumOrb,nKBas,NumOrb,One,CijK,NumOrb,CMOi(1)%SB(1)%A2(:,kSO),NumOrb,Zero,CilK,max(1,NumOrb)) + + call dGEMM_('T','N',nKBas,nLBas,NumOrb,One,CilK,NumOrb,CMOi(1)%SB(1)%A2(:,lSO),NumOrb,Zero,BklK,max(1,nKBas)) + end if + + do i3=1,iCmp(3) + kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) + do i4=1,iCmp(4) + lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + + iPAO = i4+(i3-1)*iCmp(4)+(i2-1)*iCmp(4)*iCmp(3)+(i1-1)*iCmp(4)*iCmp(3)*iCmp(2) + + do lAOl=0,lBas-1 + lSOl = lSO+lAOl + do kAOk=0,kBas-1 + kSOk = kSO+kAOk + indexB = 1+(kAOk+(i3-1)*kBas)+(lAOl+(i4-1)*lBas)*nKBas + nijkl = iAOi+jAOj*iBas+kAOk*iBas*jBas+lAOl*iBas*jBas*kBas+1 + + Indkl = iTri(kSOk,lSOl) + temp = V_k(Indij)*DSO(Indkl)*CoulFac + if (ijVec /= 0) then + tempK = BklK(indexB) + else + tempK = Zero + end if + + temp = temp-tempK*ExFac*Half*fac_ij + PMax = max(PMax,abs(Temp)) + PAO(nijkl,iPAO) = Fac*temp + + end do + end do + end do + end do + end do + end do + end do + end do + +else if ((iMP2prpt == 2) .and. (NumOrb > 0)) then + + nKBas = kBas*iCmp(3) + nLBas = lBas*iCmp(4) + + kSO = iAOtSO(iAO(3)+1,kOp(3))+iAOst(3) + lSO = iAOtSO(iAO(4)+1,kOp(4))+iAOst(4) + + do i1=1,iCmp(1) + iSO = iAOtSO(iAO(1)+i1,kOp(1))+iAOst(1) + do iAOi=0,iBas-1 + iSOi = iSO+iAOi + do i2=1,iCmp(2) + jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) + do jAOj=0,jBas-1 + jSOj = jSO+jAOj + if (iSOi == jSOj) then + Fac_ij = One + else + Fac_ij = Half + end if + Indij = iTri(iSOi,jSOj) + ijVec = ij2K(iOff_ij2K(1)+Indij) + if (ijVec /= 0) then + iAdr = nIJR(kSym,lSym,1)*(ijVec-1)+iAdrCVec(jSym,kSym,1) + call dDaFile(LuCVector(jSym,1),2,CijK,nIJR(kSym,lSym,1),iAdr) + + call dGEMM_('T','N',NumOrb,nKBas,NumOrb,One,CijK,NumOrb,CMOi(1)%SB(1)%A2(:,kSO),NumOrb,Zero,CilK,max(1,NumOrb)) + + call dGEMM_('T','N',nKBas,nLBas,NumOrb,One,CilK,NumOrb,CMOi(1)%SB(1)%A2(:,lSO),NumOrb,Zero,BklK,max(1,nKBas)) + lBVec = nBas(0)*nBas(0) + do i=1,2 + iAdr = 1+nBas(0)*nBas(0)*(ijVec-1) + call dDaFile(LuBVector(i),2,Bmp2(:,i),lBVec,iAdr) + end do + + end if + do i3=1,iCmp(3) + kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) + do i4=1,iCmp(4) + lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + + iPAO = i4+(i3-1)*iCmp(4)+(i2-1)*iCmp(4)*iCmp(3)+(i1-1)*iCmp(4)*iCmp(3)*iCmp(2) + + do lAOl=0,lBas-1 + lSOl = lSO+lAOl + do kAOk=0,kBas-1 + kSOk = kSO+kAOk + indexB = 1+(kAOk+(i3-1)*kBas)+(lAOl+(i4-1)*lBas)*nKBas + nijkl = iAOi+jAOj*iBas+kAOk*iBas*jBas+lAOl*iBas*jBas*kBas+1 + + Indkl = iTri(kSOk,lSOl) + temp = V_k(Indij)*DSO(Indkl)*CoulFac + + if (ijVec /= 0) then + tempK = BklK(indexB) + else + tempK = Zero + end if + temp = temp+U_k(indij)*DSO(indkl)*CoulFac + temp = temp+V_k(indij)*(DSO_Var(indkl)-DSO(indkl))*CoulFac + if (ijVec /= 0) then + tempJ = Compute_B(irc,kSOk,lSOl,0,nBas(0),2) + temp = temp+tempJ*CoulFac*fac_ij + + tempK = tempK+Compute_B(irc,kSOk,lSOl,0,nBas(0),1) + end if + temp = temp-tempK*ExFac*Half*fac_ij + PMax = max(PMax,abs(Temp)) + PAO(nijkl,iPAO) = Fac*temp + + end do + end do + end do + end do + end do + end do + end do + end do + +else + do i1=1,iCmp(1) + do i2=1,iCmp(2) + do i3=1,iCmp(3) + do i4=1,iCmp(4) + iSO = iAOtSO(iAO(1)+i1,kOp(1))+iAOst(1) + jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) + kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) + lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + + iPAO = iPAO+1 + + nijkl = 0 + do lAOl=0,lBas-1 + lSOl = lSO+lAOl + do kAOk=0,kBas-1 + kSOk = kSO+kAOk + Indkl = iTri(kSOk,lSOl) + do jAOj=0,jBas-1 + jSOj = jSO+jAOj + do iAOi=0,iBas-1 + iSOi = iSO+iAOi + nijkl = nijkl+1 + + ! V_k(ij)*D(kl) + + Indij = iTri(iSOi,jSOj) + + temp = V_k(Indij)*DSO(Indkl)*coulfac + + PMax = max(PMax,abs(Temp)) + PAO(nijkl,iPAO) = Fac*temp + end do + end do + end do + end do + end do + end do + end do + end do +end if +if (iPAO /= nPAO) then + write(u6,*) ' Error in PGet1_CD3!' + call Abend() +end if + +#ifdef _DEBUGPRINT_ +call RecPrt(' In PGet1_CD3:PAO ',' ',PAO,ijkl,nPAO) +#endif + +call CWTime(Cpu2,Wall2) +Cpu = Cpu2-Cpu1 +Wall = Wall2-Wall1 +tbvec(1) = tbvec(1)+Cpu +tbvec(2) = tbvec(2)+Wall + +return + +end subroutine PGet1_CD3 diff -Nru openmolcas-22.02/src/ri_util/pget1_ri2.f openmolcas-22.10/src/ri_util/pget1_ri2.f --- openmolcas-22.02/src/ri_util/pget1_ri2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/pget1_ri2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,606 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1992,2007, Roland Lindh * -* 2009, Francesco Aquilante * -************************************************************************ - SubRoutine PGet1_RI2(PAO,ijkl,nPAO,iCmp,iAO,iAOst, - & Shijij,iBas,jBas,kBas,lBas,kOp,ExFac, - & CoulFac,PMax,V_K,U_K,mV_K,Z_p_K,nSA) -************************************************************************ -* Object: to assemble the 2nd order density matrix of a SCF wave * -* function from the 1st order density. * -* * -* (Only for use with C1 point group symmetry) * -* * -* The indices has been scrambled before calling this routine. * -* Hence we must take special care in order to regain the can- * -* onical order. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -* January '92. * -* * -* Modified for RI-DFT, March 2007 * -* * -* Modified for RI-HF/CAS, Dec 2009 (F. Aquilante) * -************************************************************************ - use Basis_Info, only: nBas - use SOAO_Info, only: iAOtSO - use pso_stuff, only: nnP, lPSO, lsa, DMdiag, nPos - use ExTerm, only: CijK, AMP2, iMP2prpt, nAuxVe, LuAVector, A - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "exterm.fh" - Real*8 PAO(ijkl,nPAO), V_K(mV_K,nSA), U_K(mV_K), - & Z_p_K(nnP(0),mV_K,*) - Integer iAO(4), kOp(4), iAOst(4), iCmp(4) - Logical Shijij,Found - - Real*8, Pointer:: V2(:)=>Null() - Real*8, Pointer:: CiKj(:,:)=>Null() - Real*8, Pointer:: CiKl(:)=>Null() -* * -************************************************************************ -* * -*#define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Do i=1,nSA - Call RecPrt('PGet1_RI2: V_k',' ',V_k(1,i),1,mV_k) - End Do -#endif -* * -************************************************************************ -* * -* DeSymP will treat up to eight fold degeneracy due to permutational -* symmetry of shell quadruplets. We will have to compensate for that -* here since we only have shell doublets. -* -* - Call CWTime(Cpu1,Wall1) -* - If (Min(lBas,jBas) .eq.0) Return -* - Fac = One / Four - PMax=Zero - iPAO=0 - iOffA=nBas(0) -* - Call Qpg_iScalar('SCF mode',Found) - If (Found) Then - Call Get_iScalar('SCF mode',iUHF) ! either 0 or 1 - Else - iUHF=0 - EndIf -* -* * -************************************************************************ -* * -* Pure DFT -* - If (ExFac.eq.Zero) Then -* * -************************************************************************ -* * -* -* Pure DFT -* - Do i2 = 1, iCmp(2) - jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) -* - Do i4 = 1, iCmp(4) -* - lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) -* - iPAO = iPAO + 1 - nijkl = 0 -* - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - iOffA - Do jAOj = 0, jBas-1 -* - jSOj = jSO + jAOj - iOffA - nijkl = nijkl + 1 -* -*----- Coulomb contribution - temp=CoulFac*V_K(jSOj,1)*V_K(lSOl,1) -* temp=Zero -* - PMax=Max(PMax,Abs(temp)) - PAO(nijkl,iPAO) = Fac * temp -* - End Do - End Do - End Do - End Do -* * -************************************************************************ -* * -* Hybrid DFT and HF -* - Else If(iMP2prpt .ne. 2 .and. .not. lPSO .and. iUHF.eq.0) Then -* * -************************************************************************ -* * - iSO=1 -* - jSym = 1 - kSym = jSym - iSym = 1 - lSym = iEor(jSym-1,iSym-1)+1 -* - nik = nIJ1(iSym,kSym,iSO) - - n = nik*jBas - iS = 1 - iE = n - CiKj(1:n,1:1) => CijK(iS:iE) - n = nik*lBas - iS = iE + 1 - iE = iE + n - CiKl(1:n) => CijK(iS:iE) -* - Do i2 = 1, iCmp(2) - jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) -* -* Pick up the MO transformed fitting coefficients, C_ik^J - jSOj = jSO - iOffA - iAdrJ = nik*(jSOj-1) + iAdrCVec(jSym,iSym,1) - Call dDaFile(LuCVector(jSym,1),2,CikJ(:,1),nik*jBas,iAdrJ) - - Do i4 = 1, iCmp(4) - lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) -* - iPAO = iPAO + 1 - nijkl = 0 - - If (lSO.ne.jSO) Then - lSOl = lSO - iOffA - iAdrL = nik*(lSOl-1) + iAdrCVec(jSym,iSym,1) - Call dDaFile(LuCVector(jSym,1),2,CiKl,nik*lBas,iAdrL) - - V2(1:)=>CiKl(1:) - Else - V2(1:)=>CiKj(1:,1) - EndIf - - A(1:jBas*lBas)=Zero - CALL DGEMM_('T','N',jBas,lBas,nik, - & 1.0d0,CiKj,nik, - & V2,nik, - & 0.0d0,A,jBas) - - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - iOffA - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - iOffA - nijkl = nijkl + 1 - - temp = CoulFac*V_K(jSOj,1)*V_K(lSOl,1) - temp = temp - ExFac*A(nijkl) -* - PMax = Max(PMax,Abs(temp)) - PAO(nijkl,iPAO) = Fac*temp - End Do - End Do - End Do - End Do -* * -************************************************************************ -* * -* Hybrid UDFT and UHF -* - Else If(iMP2prpt .ne. 2 .and. .not. lPSO .and. iUHF.eq.1) Then -* * -************************************************************************ -* * - jSym = 1 - kSym = jSym - iSym = 1 - lSym = iEor(jSym-1,iSym-1)+1 - nik1= nIJ1(iSym,kSym,1) - nik2= nIJ1(iSym,kSym,2) - nik = Max(nik1,nik2) -* - n = nik * jBas - iS = 1 - iE = n * 2 - CiKj(1:n,1:2) => CijK(iS:iE) -* - Do i2 = 1, iCmp(2) - jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) - jSOj = jSO - iOffA -* -* Pick up the MO transformed fitting coefficients, C_ik^J - If (nik1.ne.0) Then - iAdrJ = nik1*(jSOj-1) + iAdrCVec(jSym,iSym,1) - Call dDaFile(LuCVector(jSym,1),2,CiKj(:,1),nik1*jBas, - & iAdrJ) - EndIf -* - If (nik2.ne.0) Then - iAdrJ = nik2*(jSOj-1) + iAdrCVec(jSym,iSym,2) - Call dDaFile(LuCVector(jSym,2),2,CikJ(:,2),nik2*jBas, - & iAdrJ) - EndIf -* - Do i4 = 1, iCmp(4) - lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) -* - iPAO = iPAO + 1 - nijkl = 0 - - Factor=Zero - A(1:jBas*lBas)=Zero - Do iSO=1,nKVec - nik = nIJ1(iSym,kSym,iSO) - - CiKl(1:nik*lBas) => CijK(iE+1:iE+nik*lBas) - - If (nik==0) Cycle - - If (lSO.ne.jSO) Then - lSOl = lSO - iOffA - iAdrL = nik*(lSOl-1) + iAdrCVec(jSym,iSym,iSO) - Call dDaFile(LuCVector(jSym,iSO),2,CiKl,nik*lBas, - & iAdrL) - V2(1:) => CiKl(1:) - Else - V2(1:) => CiKj(1:,iSO) - EndIf -* - CALL DGEMM_('T','N',jBas,lBas,nik, - & 1.0d0,CikJ(:,iSO),nik, - & V2,nik, - & Factor,A,jBas) - Factor=1.0d0 - End Do - - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - iOffA - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - iOffA - nijkl = nijkl + 1 - - temp = CoulFac*V_K(jSOj,1)*V_K(lSOl,1) - temp = temp - 2.0d0*ExFac*A(nijkl) -* - PMax = Max(PMax,Abs(temp)) - PAO(nijkl,iPAO) = Fac*temp - End Do - End Do - End Do - End Do -* * -************************************************************************ -* * -* CASSCF -* - Else If(iMP2prpt .ne. 2 .and. lPSO .and. .not.LSA) Then -* * -************************************************************************ -* * - iSO=1 -* - jSym = 1 - kSym = jSym - iSym = 1 - lSym = iEor(jSym-1,iSym-1)+1 -* - nik = nIJ1(iSym,kSym,iSO) - iS = 1 - iE = nik*jBas - CiKj(1:nik*jBas,1:1) => CijK(iS:iE) - iS = iE + 1 - iE = iE + nik*lBas - CiKl(1:nik*lBas) => CijK(iS:iE) -* - Do i2 = 1, iCmp(2) - jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) -* -* Pick up the MO transformed fitting coefficients, C_ik^J - jSOj = jSO - iOffA - iAdrJ = nik*(jSOj-1) + iAdrCVec(jSym,iSym,1) - Call dDaFile(LuCVector(jSym,1),2,CiKj(:,1),nik*jBas,iAdrJ) - - Do i4 = 1, iCmp(4) - lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) -* - iPAO = iPAO + 1 - nijkl = 0 - - If (lSO.ne.jSO) Then - lSOl = lSO - iOffA - iAdrL = nik*(lSOl-1) + iAdrCVec(jSym,iSym,1) - Call dDaFile(LuCVector(jSym,1),2,CiKl,nik*lBas,iAdrL) - - V2(1:) => CiKl(1:) - Else - V2(1:) => CiKj(1:,1) - EndIf - - A(1:jBas*lBas)=Zero - CALL DGEMM_('T','N',jBas,lBas,nik, - & 1.0d0,CiKj(:,1),nik, - & V2,nik, - & 0.0d0,A,jBas) - - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - iOffA - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - iOffA - nijkl = nijkl + 1 - - temp = CoulFac*V_K(jSOj,1)*V_K(lSOl,1) - temp = temp - ExFac*A(nijkl) -* -*----- Active space contribution - temp2=0.0d0 - Do jp=1,nnP(0) - temp2 = temp2 + - & sign(1.0d0,DMdiag(jp,1))* - & Z_p_K(jp,jSOj,1)*Z_p_K(jp,lSOl,1) - End Do - temp=temp+temp2 -* - PMax = Max(PMax,Abs(temp)) - PAO(nijkl,iPAO) = Fac*temp - End Do - End Do - End Do - End Do -* * -************************************************************************ -* * -* SA-CASSCF -* - Else If( iMP2prpt .ne. 2 .and. lPSO .and. lSA ) Then -* * -************************************************************************ -* * - jSym = 1 - kSym = jSym - iSym = 1 - lSym = iEor(jSym-1,iSym-1)+1 -* - nik1= nIJ1(iSym,kSym,1) - nik2= nIJ1(iSym,kSym,2) - nik = Max(nik1,nik2) - - iS = 1 - iE = 2 * nik * jBas - CiKj(1:nik*jBas,1:2) => CijK(iS:iE) -* - Do i2 = 1, iCmp(2) - jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) - jSOj = jSO - iOffA -* -* Pick up the MO transformed fitting coefficients, C_ik^J - If (nik1.ne.0) Then - iAdrJ = nik1*(jSOj-1) + iAdrCVec(jSym,iSym,1) - Call dDaFile(LuCVector(jSym,1),2,CikJ(:,1),nik1*jBas, - & iAdrJ) - EndIf -* - If (nik2.ne.0) Then - iAdrJ = nik2*(jSOj-1) + iAdrCVec(jSym,iSym,2) -* - Call dDaFile(LuCVector(jSym,2),2,CikJ(:,2),nik2*jBas, - & iAdrJ) - EndIf -* - Do i4 = 1, iCmp(4) - lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) -* - iPAO = iPAO + 1 - nijkl = 0 - - Factor=Zero - A(1:jBas*lBas)=Zero - - Do iSO=1,nKVec - nik = nIJ1(iSym,kSym,iSO) - - CiKl(1:nik*lBas) => CijK(iE+1:iE+nik*lBas) - - If (nik==0) Cycle - - If (lSO.ne.jSO) Then - lSOl = lSO - iOffA - iAdrL = nik*(lSOl-1) + iAdrCVec(jSym,iSym,iSO) - Call dDaFile(LuCVector(jSym,iSO),2,CikL,nik*lBas, - & iAdrL) - V2(1:) => CiKl(1:) - Else - V2(1:) => CiKj(1:,iSO) - EndIf -* -** Here one should keep track of negative eigenvalues of the densities -* - iSO2=iSO+2 -* - Do l=1,lBas - Do k=1,jBas - - tmp=0.0d0 - - Do i=1,nChOrb(0,iSO) - Do j=1,nChOrb(0,iSO2) - - jik = j + nChOrb(0,iSO2)*(i-1) + nik*(k-1) - jil = j + nChOrb(0,iSO2)*(i-1) + nik*(l-1) - If (j<=npos(0,iSO)) Then - tmp = tmp + CiKj(jik,iSO)* V2(jil) - Else - tmp = tmp - CiKj(jik,iSO)* V2(jil) - End If - End Do - End Do - - kl = k + jBas*(l-1) - A(kl)= Factor*A(kl)+tmp - - End Do - End Do - Factor=1.0d0 - - End Do - - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - iOffA - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - iOffA - nijkl = nijkl + 1 - - temp=CoulFac*(V_K(lSOl,1)*V_K(jSOj,2)+ - & V_K(lSOl,2)*V_K(jSOj,1)+ - & V_K(lSOl,3)*V_K(jSOj,4)+ - & V_K(lSOl,4)*V_K(jSOj,3)+ - & V_K(lSOl,1)*V_K(jSOj,5)+ - & V_K(lSOl,5)*V_K(jSOj,1)) - temp = temp - ExFac*A(nijkl) -* -*----- Active space contribution - temp2=0.0d0 - Do jp=1,nnP(0) - temp2 = temp2 + - & sign(1.0d0,DMdiag(jp,1))* - & Z_p_K(jp,jSOj,1)*Z_p_K(jp,lSOl,1)+ - & sign(2.0d0,DMdiag(jp,2))* - & (Z_p_K(jp,jSOj,2)*Z_p_K(jp,lSOl,3)+ - & Z_p_K(jp,jSOj,3)*Z_p_K(jp,lSOl,2)) - End Do - temp=temp+temp2 -* - PMax = Max(PMax,Abs(temp)) - PAO(nijkl,iPAO) = Fac*temp - End Do - End Do - End Do - End Do -* * -************************************************************************ -* * -* MP2 -* - Else -* * -************************************************************************ -* * - iSO=1 -* - jSym = 1 - kSym = jSym - iSym = 1 - lSym = iEor(jSym-1,iSym-1)+1 - - nik = nIJ1(iSym,lSym,iSO) - - iS = 1 - iE = nik * Max(jBas,lBas) * 2 - CiKj(1:nik * Max(jBas,lBas),1:2) => CijK(iS:iE) - - Do i2 = 1, iCmp(2) - jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) - - jSOj = jSO - iOffA - iAdrJ = nik*(jSOj-1) + iAdrCVec(jSym,iSym,1) - Call dDaFile(LuCVector(jSym,1),2,CiKj(:,1),nik*jBas,iAdrJ) - - Do i4 = 1, iCmp(4) - lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) - iPAO = iPAO + 1 - nijkl = 0 -* - If (lSO.ne.jSO) Then - lSOl = lSO - iOffA - iAdrL = nik*(lSOl-1) + iAdrCVec(jSym,iSym,1) - Call dDaFile(LuCVector(jSym,1),2,CiKj(:,2),nik*lBas, - & iAdrL) - - V2(1:) => CiKj(1:,2) - Else - V2(1:) => CiKj(1:,1) - EndIf - - A(1:jBas*lBas)=Zero - CALL DGEMM_('T','N',jBas,lBas,nik, - & 1.0d0,CiKj(:,1),nik, - & V2,nik, - & 0.0d0,A,jBas) -* - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - iOffA -* -* While the I/O here has been moved outside the -* inner loop this needs to be reconsidered and -* improved such that it can be moved out yet -* another loop (or more.) -* - lTot = jBas - iAdrA = nAuxVe*(lSOl-1) + (jSO - iOffA) - Call dDaFile(LuAVector(1),2,AMP2(:,1),lTot,iAdrA) - iAdrA = nAuxVe*(lSOl-1) + (jSO - iOffA) - Call dDaFile(LuAVector(2),2,AMP2(:,2),lTot,iAdrA) -* - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - iOffA - nijkl = nijkl + 1 -* - temp = CoulFac*V_K(jSOj,1)*V_K(lSOl,1) - & + CoulFac*V_K(jSOj,1)*U_K(lSOl) - & + CoulFac*U_K(jSOj)*V_K(lSOl,1) - & - ExFac*A(nijkl) -* - tempJ_mp2=AMP2(1+jAOj,2) - temp = temp + tempJ_mp2*CoulFac -* - tempK_mp2=AMP2(1+jAOj,1) - temp = temp - ExFac*half*tempK_mp2 -* - PMax = Max(PMax,Abs(temp)) - PAO(nijkl,iPAO) = Fac*temp - End Do - End Do - End Do - End Do -* * -************************************************************************ -* * - End If - - CiKj => Null() - CiKl => Null() - V2 => Null() -* * -************************************************************************ -* * - If (iPAO.ne.nPAO) Then - Write (6,*) ' Error in PGet1_RI2!' - Call Abend - End If -* -#ifdef _DEBUGPRINT_ - Call RecPrt(' In PGet1_RI2:PAO ',' ',PAO,ijkl,nPAO) -#endif - Call CWTime(Cpu2,Wall2) - Cpu = Cpu2 - Cpu1 - Wall = Wall2 - Wall1 - tavec(1) = tavec(1) + Cpu - tavec(2) = tavec(2) + Wall -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_logical(Shijij) - Call Unused_integer(iBas) - Call Unused_integer(kBas) - End If - End diff -Nru openmolcas-22.02/src/ri_util/pget1_ri2.F90 openmolcas-22.10/src/ri_util/pget1_ri2.F90 --- openmolcas-22.02/src/ri_util/pget1_ri2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/pget1_ri2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,566 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1992,2007, Roland Lindh * +! 2009, Francesco Aquilante * +!*********************************************************************** + +subroutine PGet1_RI2(PAO,ijkl,nPAO,iCmp,iAO,iAOst,jBas,lBas,kOp,ExFac,CoulFac,PMax,V_K,U_K,mV_K,Z_p_K,nSA) +!*********************************************************************** +! Object: to assemble the 2nd order density matrix of a SCF wave * +! function from the 1st order density. * +! * +! (Only for use with C1 point group symmetry) * +! * +! The indices have been scrambled before calling this routine.* +! Hence we must take special care in order to regain the * +! canonical order. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +! January '92. * +! * +! Modified for RI-DFT, March 2007 * +! * +! Modified for RI-HF/CAS, Dec 2009 (F. Aquilante) * +!*********************************************************************** + +use Symmetry_Info, only: Mul +use Basis_Info, only: nBas +use SOAO_Info, only: iAOtSO +use pso_stuff, only: DMdiag, lPSO, lSA, nnP, nPos +use RI_glob, only: A, AMP2, CijK, iAdrCVec, iMP2prpt, LuAVector, LuCVector, nAuxVe, nChOrb, nIJ1, nKvec, tavec +use Constants, only: Zero, One, Two, Half, Quart +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: ijkl, nPAO, iCmp(4), iAO(4), iAOst(4), jBas, lBas, kOp(4), mV_K, nSA +real(kind=wp), intent(out) :: PAO(ijkl,nPAO), PMax +real(kind=wp), intent(in) :: ExFac, CoulFac, V_K(mV_K,nSA), U_K(mV_K), Z_p_K(nnP(0),mV_K,*) +logical(kind=iwp) :: Found +integer(kind=iwp) :: i, i2, i4, iAdrA, iAdrJ, iAdrL, iE, iOffA, iPAO, iS, iSO, iSO2, iSym, iUHF, j, jAOj, jik, jil, jp, jSO, jSOj, & + jSym, k, kl, kSym, l, lAOl, lSO, lSOl, lSym, lTot, n, nijkl, nik, nik1, nik2 +real(kind=wp) :: Cpu, Cpu1, Cpu2, Fac, Factor, temp, temp2, tempJ_mp2, tempK_mp2, tmp, Wall, Wall1, Wall2 +real(kind=wp), pointer :: CiKj(:,:), CiKl(:), V2(:) + +! * +!*********************************************************************** +! * +!#define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +do i=1,nSA + call RecPrt('PGet1_RI2: V_k',' ',V_k(1,i),1,mV_k) +end do +#endif +! * +!*********************************************************************** +! * +! DeSymP will treat up to eight fold degeneracy due to permutational +! symmetry of shell quadruplets. We will have to compensate for that +! here since we only have shell doublets. + +call CWTime(Cpu1,Wall1) + +if (min(lBas,jBas) == 0) return + +Fac = Quart +PMax = Zero +iPAO = 0 +iOffA = nBas(0) + +call Qpg_iScalar('SCF mode',Found) +if (Found) then + call Get_iScalar('SCF mode',iUHF) ! either 0 or 1 +else + iUHF = 0 +end if +! * +!*********************************************************************** +! * + +if (ExFac == Zero) then + ! * + !********************************************************************* + ! * + ! Pure DFT + + do i2=1,iCmp(2) + jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) + + do i4=1,iCmp(4) + + lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + + iPAO = iPAO+1 + nijkl = 0 + + do lAOl=0,lBas-1 + lSOl = lSO+lAOl-iOffA + do jAOj=0,jBas-1 + + jSOj = jSO+jAOj-iOffA + nijkl = nijkl+1 + + ! Coulomb contribution + temp = CoulFac*V_K(jSOj,1)*V_K(lSOl,1) + !temp = Zero + + PMax = max(PMax,abs(temp)) + PAO(nijkl,iPAO) = Fac*temp + + end do + end do + end do + end do + ! * + !********************************************************************* + ! * +else if ((iMP2prpt /= 2) .and. (.not. lPSO) .and. (iUHF == 0)) then + ! * + !********************************************************************* + ! * + ! Hybrid DFT and HF + + iSO = 1 + + jSym = 1 + kSym = jSym + iSym = 1 + lSym = Mul(jSym,iSym) + + nik = nIJ1(iSym,kSym,iSO) + + n = nik*jBas + iS = 1 + iE = n + CiKj(1:n,1:1) => CijK(iS:iE) + n = nik*lBas + iS = iE+1 + iE = iE+n + CiKl(1:n) => CijK(iS:iE) + + do i2=1,iCmp(2) + jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) + + ! Pick up the MO transformed fitting coefficients, C_ik^J + jSOj = jSO-iOffA + iAdrJ = nik*(jSOj-1)+iAdrCVec(jSym,iSym,1) + call dDaFile(LuCVector(jSym,1),2,CikJ(:,1),nik*jBas,iAdrJ) + + do i4=1,iCmp(4) + lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + + iPAO = iPAO+1 + nijkl = 0 + + if (lSO /= jSO) then + lSOl = lSO-iOffA + iAdrL = nik*(lSOl-1)+iAdrCVec(jSym,iSym,1) + call dDaFile(LuCVector(jSym,1),2,CiKl,nik*lBas,iAdrL) + + V2(1:) => CiKl(1:) + else + V2(1:) => CiKj(1:,1) + end if + + A(1:jBas*lBas) = Zero + call DGEMM_('T','N',jBas,lBas,nik,One,CiKj,nik,V2,nik,Zero,A,jBas) + + do lAOl=0,lBas-1 + lSOl = lSO+lAOl-iOffA + do jAOj=0,jBas-1 + jSOj = jSO+jAOj-iOffA + nijkl = nijkl+1 + + temp = CoulFac*V_K(jSOj,1)*V_K(lSOl,1) + temp = temp-ExFac*A(nijkl) + + PMax = max(PMax,abs(temp)) + PAO(nijkl,iPAO) = Fac*temp + end do + end do + end do + end do + ! * + !********************************************************************* + ! * +else if ((iMP2prpt /= 2) .and. (.not. lPSO) .and. (iUHF == 1)) then + ! * + !********************************************************************* + ! * + ! Hybrid UDFT and UHF + + jSym = 1 + kSym = jSym + iSym = 1 + lSym = Mul(jSym,iSym) + nik1 = nIJ1(iSym,kSym,1) + nik2 = nIJ1(iSym,kSym,2) + nik = max(nik1,nik2) + + n = nik*jBas + iS = 1 + iE = n*2 + CiKj(1:n,1:2) => CijK(iS:iE) + + do i2=1,iCmp(2) + jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) + jSOj = jSO-iOffA + + ! Pick up the MO transformed fitting coefficients, C_ik^J + if (nik1 /= 0) then + iAdrJ = nik1*(jSOj-1)+iAdrCVec(jSym,iSym,1) + call dDaFile(LuCVector(jSym,1),2,CiKj(:,1),nik1*jBas,iAdrJ) + end if + + if (nik2 /= 0) then + iAdrJ = nik2*(jSOj-1)+iAdrCVec(jSym,iSym,2) + call dDaFile(LuCVector(jSym,2),2,CikJ(:,2),nik2*jBas,iAdrJ) + end if + + do i4=1,iCmp(4) + lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + + iPAO = iPAO+1 + nijkl = 0 + + Factor = Zero + A(1:jBas*lBas) = Zero + do iSO=1,nKVec + nik = nIJ1(iSym,kSym,iSO) + + CiKl(1:nik*lBas) => CijK(iE+1:iE+nik*lBas) + + if (nik == 0) cycle + + if (lSO /= jSO) then + lSOl = lSO-iOffA + iAdrL = nik*(lSOl-1)+iAdrCVec(jSym,iSym,iSO) + call dDaFile(LuCVector(jSym,iSO),2,CiKl,nik*lBas,iAdrL) + V2(1:) => CiKl(1:) + else + V2(1:) => CiKj(1:,iSO) + end if + + call DGEMM_('T','N',jBas,lBas,nik,One,CikJ(:,iSO),nik,V2,nik,Factor,A,jBas) + Factor = One + end do + + do lAOl=0,lBas-1 + lSOl = lSO+lAOl-iOffA + do jAOj=0,jBas-1 + jSOj = jSO+jAOj-iOffA + nijkl = nijkl+1 + + temp = CoulFac*V_K(jSOj,1)*V_K(lSOl,1) + temp = temp-Two*ExFac*A(nijkl) + + PMax = max(PMax,abs(temp)) + PAO(nijkl,iPAO) = Fac*temp + end do + end do + end do + end do + ! * + !********************************************************************* + ! * +else if ((iMP2prpt /= 2) .and. lPSO .and. (.not. LSA)) then + ! * + !********************************************************************* + ! * + ! CASSCF + + iSO = 1 + + jSym = 1 + kSym = jSym + iSym = 1 + lSym = Mul(jSym,iSym) + + nik = nIJ1(iSym,kSym,iSO) + iS = 1 + iE = nik*jBas + CiKj(1:nik*jBas,1:1) => CijK(iS:iE) + iS = iE+1 + iE = iE+nik*lBas + CiKl(1:nik*lBas) => CijK(iS:iE) + + do i2=1,iCmp(2) + jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) + + ! Pick up the MO transformed fitting coefficients, C_ik^J + jSOj = jSO-iOffA + iAdrJ = nik*(jSOj-1)+iAdrCVec(jSym,iSym,1) + call dDaFile(LuCVector(jSym,1),2,CiKj(:,1),nik*jBas,iAdrJ) + + do i4=1,iCmp(4) + lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + + iPAO = iPAO+1 + nijkl = 0 + + if (lSO /= jSO) then + lSOl = lSO-iOffA + iAdrL = nik*(lSOl-1)+iAdrCVec(jSym,iSym,1) + call dDaFile(LuCVector(jSym,1),2,CiKl,nik*lBas,iAdrL) + + V2(1:) => CiKl(1:) + else + V2(1:) => CiKj(1:,1) + end if + + A(1:jBas*lBas) = Zero + call DGEMM_('T','N',jBas,lBas,nik,One,CiKj(:,1),nik,V2,nik,Zero,A,jBas) + + do lAOl=0,lBas-1 + lSOl = lSO+lAOl-iOffA + do jAOj=0,jBas-1 + jSOj = jSO+jAOj-iOffA + nijkl = nijkl+1 + + temp = CoulFac*V_K(jSOj,1)*V_K(lSOl,1) + temp = temp-ExFac*A(nijkl) + + ! Active space contribution + temp2 = Zero + do jp=1,nnP(0) + temp2 = temp2+sign(One,DMdiag(jp,1))*Z_p_K(jp,jSOj,1)*Z_p_K(jp,lSOl,1) + end do + temp = temp+temp2 + + PMax = max(PMax,abs(temp)) + PAO(nijkl,iPAO) = Fac*temp + end do + end do + end do + end do + ! * + !********************************************************************* + ! * +else if ((iMP2prpt /= 2) .and. lPSO .and. lSA) then + ! * + !********************************************************************* + ! * + ! SA-CASSCF + + jSym = 1 + kSym = jSym + iSym = 1 + lSym = Mul(jSym,iSym) + + nik1 = nIJ1(iSym,kSym,1) + nik2 = nIJ1(iSym,kSym,2) + nik = max(nik1,nik2) + + iS = 1 + iE = 2*nik*jBas + CiKj(1:nik*jBas,1:2) => CijK(iS:iE) + + do i2=1,iCmp(2) + jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) + jSOj = jSO-iOffA + + ! Pick up the MO transformed fitting coefficients, C_ik^J + if (nik1 /= 0) then + iAdrJ = nik1*(jSOj-1)+iAdrCVec(jSym,iSym,1) + call dDaFile(LuCVector(jSym,1),2,CikJ(:,1),nik1*jBas,iAdrJ) + end if + + if (nik2 /= 0) then + iAdrJ = nik2*(jSOj-1)+iAdrCVec(jSym,iSym,2) + + call dDaFile(LuCVector(jSym,2),2,CikJ(:,2),nik2*jBas,iAdrJ) + end if + + do i4=1,iCmp(4) + lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + + iPAO = iPAO+1 + nijkl = 0 + + Factor = Zero + A(1:jBas*lBas) = Zero + + do iSO=1,nKVec + nik = nIJ1(iSym,kSym,iSO) + + CiKl(1:nik*lBas) => CijK(iE+1:iE+nik*lBas) + + if (nik == 0) cycle + + if (lSO /= jSO) then + lSOl = lSO-iOffA + iAdrL = nik*(lSOl-1)+iAdrCVec(jSym,iSym,iSO) + call dDaFile(LuCVector(jSym,iSO),2,CikL,nik*lBas,iAdrL) + V2(1:) => CiKl(1:) + else + V2(1:) => CiKj(1:,iSO) + end if + + ! Here one should keep track of negative eigenvalues of the densities + + iSO2 = iSO+2 + + do l=1,lBas + do k=1,jBas + + tmp = Zero + + do i=1,nChOrb(0,iSO) + do j=1,nChOrb(0,iSO2) + + jik = j+nChOrb(0,iSO2)*(i-1)+nik*(k-1) + jil = j+nChOrb(0,iSO2)*(i-1)+nik*(l-1) + if (j <= npos(0,iSO)) then + tmp = tmp+CiKj(jik,iSO)*V2(jil) + else + tmp = tmp-CiKj(jik,iSO)*V2(jil) + end if + end do + end do + + kl = k+jBas*(l-1) + A(kl) = Factor*A(kl)+tmp + + end do + end do + Factor = One + + end do + + do lAOl=0,lBas-1 + lSOl = lSO+lAOl-iOffA + do jAOj=0,jBas-1 + jSOj = jSO+jAOj-iOffA + nijkl = nijkl+1 + + temp = CoulFac*(V_K(lSOl,1)*V_K(jSOj,2)+V_K(lSOl,2)*V_K(jSOj,1)+V_K(lSOl,3)*V_K(jSOj,4)+V_K(lSOl,4)*V_K(jSOj,3)+ & + V_K(lSOl,1)*V_K(jSOj,5)+V_K(lSOl,5)*V_K(jSOj,1)) + temp = temp-ExFac*A(nijkl) + + ! Active space contribution + temp2 = Zero + do jp=1,nnP(0) + temp2 = temp2+sign(One,DMdiag(jp,1))*Z_p_K(jp,jSOj,1)*Z_p_K(jp,lSOl,1)+ & + sign(Two,DMdiag(jp,2))*(Z_p_K(jp,jSOj,2)*Z_p_K(jp,lSOl,3)+Z_p_K(jp,jSOj,3)*Z_p_K(jp,lSOl,2)) + end do + temp = temp+temp2 + + PMax = max(PMax,abs(temp)) + PAO(nijkl,iPAO) = Fac*temp + end do + end do + end do + end do + ! * + !********************************************************************* + ! * +else + ! * + !********************************************************************* + ! * + ! MP2 + + iSO = 1 + + jSym = 1 + kSym = jSym + iSym = 1 + lSym = Mul(jSym,iSym) + + nik = nIJ1(iSym,lSym,iSO) + + iS = 1 + iE = nik*max(jBas,lBas)*2 + CiKj(1:nik*max(jBas,lBas),1:2) => CijK(iS:iE) + + do i2=1,iCmp(2) + jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) + + jSOj = jSO-iOffA + iAdrJ = nik*(jSOj-1)+iAdrCVec(jSym,iSym,1) + call dDaFile(LuCVector(jSym,1),2,CiKj(:,1),nik*jBas,iAdrJ) + + do i4=1,iCmp(4) + lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + iPAO = iPAO+1 + nijkl = 0 + + if (lSO /= jSO) then + lSOl = lSO-iOffA + iAdrL = nik*(lSOl-1)+iAdrCVec(jSym,iSym,1) + call dDaFile(LuCVector(jSym,1),2,CiKj(:,2),nik*lBas,iAdrL) + + V2(1:) => CiKj(1:,2) + else + V2(1:) => CiKj(1:,1) + end if + + A(1:jBas*lBas) = Zero + call DGEMM_('T','N',jBas,lBas,nik,One,CiKj(:,1),nik,V2,nik,Zero,A,jBas) + + do lAOl=0,lBas-1 + lSOl = lSO+lAOl-iOffA + + ! While the I/O here has been moved outside the + ! inner loop this needs to be reconsidered and + ! improved such that it can be moved out yet + ! another loop (or more.) + + lTot = jBas + iAdrA = nAuxVe*(lSOl-1)+(jSO-iOffA) + call dDaFile(LuAVector(1),2,AMP2(:,1),lTot,iAdrA) + iAdrA = nAuxVe*(lSOl-1)+(jSO-iOffA) + call dDaFile(LuAVector(2),2,AMP2(:,2),lTot,iAdrA) + + do jAOj=0,jBas-1 + jSOj = jSO+jAOj-iOffA + nijkl = nijkl+1 + + temp = CoulFac*V_K(jSOj,1)*V_K(lSOl,1)+CoulFac*V_K(jSOj,1)*U_K(lSOl)+CoulFac*U_K(jSOj)*V_K(lSOl,1)-ExFac*A(nijkl) + + tempJ_mp2 = AMP2(1+jAOj,2) + temp = temp+tempJ_mp2*CoulFac + + tempK_mp2 = AMP2(1+jAOj,1) + temp = temp-ExFac*half*tempK_mp2 + + PMax = max(PMax,abs(temp)) + PAO(nijkl,iPAO) = Fac*temp + end do + end do + end do + end do + ! * + !********************************************************************* + ! * +end if + +nullify(CiKj,CiKl,V2) +! * +!*********************************************************************** +! * +if (iPAO /= nPAO) then + write(u6,*) ' Error in PGet1_RI2!' + call Abend() +end if + +#ifdef _DEBUGPRINT_ +call RecPrt(' In PGet1_RI2:PAO ',' ',PAO,ijkl,nPAO) +#endif +call CWTime(Cpu2,Wall2) +Cpu = Cpu2-Cpu1 +Wall = Wall2-Wall1 +tavec(1) = tavec(1)+Cpu +tavec(2) = tavec(2)+Wall + +return + +end subroutine PGet1_RI2 diff -Nru openmolcas-22.02/src/ri_util/pget1_ri3.f openmolcas-22.10/src/ri_util/pget1_ri3.f --- openmolcas-22.02/src/ri_util/pget1_ri3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/pget1_ri3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1162 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1992,2007, Roland Lindh * -************************************************************************ - SubRoutine PGet1_RI3(PAO,ijkl,nPAO,iCmp, - & iAO,iAOst,Shijij,iBas,jBas,kBas,lBas,kOp, - & DSO,DSSO,DSO_Var,nDSO,ExFac,CoulFac,PMax,V_K, - & U_K,mV_k,ZpK,nnP1,nSA,nAct) -************************************************************************ -* Object: to assemble the 2nd order density matrix of a SCF wave * -* function from the 1st order density. * -* * -* The indices has been scrambled before calling this routine. * -* Hence we must take special care in order to regain the can- * -* onical order. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -* January '92. * -* * -* Modified for 3-center RI gradients, March 2007 * -************************************************************************ - use Basis_Info, only: nBas - use SOAO_Info, only: iAOtSO - use pso_stuff, only: lPSO, lsa, Thpkl, AOrb - use ExTerm, only: CijK, CilK, BklK, BMP2, iMP2prpt, LuBVector - use ExTerm, only: Ymnij, ipYmnij, nYmnij, CMOi -#ifdef _DEBUGPRINT_ - use ExTerm, only: iOff_Ymnij -#endif - use ExTerm, only: Yij - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "exterm.fh" - Real*8 PAO(ijkl,nPAO), DSO(nDSO,nSA), DSSO(nDSO), V_k(mV_k,nSA), - & U_k(mV_k), DSO_Var(nDSO),ZpK(nnP1,mV_K,*) - Integer iAO(4), kOp(4), iAOst(4), iCmp(4) - Integer nj(4), jSkip(4), NumOrb(4), nAct(0:7) - Logical Shijij,Found - - Real*8, Pointer :: Xli(:)=>Null(), Xki(:)=>Null() - Type V1 - Real*8, Pointer:: A1(:)=>Null() - End Type V1 - Type (V1):: Xli2(2), Xki2(2) - Type (V1):: Xli3(2), Xki3(2) -* * -************************************************************************ -* * - Interface - - SUBROUTINE DCOPY_(N, X, INCX, Y, INCY) - INTEGER N, INCX, INCY - REAL*8 X(*), Y(*) - END SUBROUTINE DCOPY_ - - SUBROUTINE DGEMV_(TRANSA,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - CHARACTER * 1 TRANSA - INTEGER M, N, LDA, INCX, INCY - REAL*8 ALPHA, BETA - REAL*8 A(LDA,*), X(*), Y(*) - END SUBROUTINE DGEMV_ - - End Interface -* * -************************************************************************ -* * -* Statement function -* - kYmnij(l,iDen)=Ymnij(ipYmnij(iDen)-1+l) -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - iComp = 1 - Call PrMtrx('DSO ',[iD0Lbl],iComp,1,D0) - Write (6,*) - Write (6,*) 'Distribution of Ymnij' - iSym=1 - If (nYmnij(iSym,1).gt.0) Then - Write (6,*) 'iSym=',iSym - Do i = iOff_Ymnij(iSym,1)+1, iOff_Ymnij(iSym,1)+nYmnij(iSym,1) - Write (6,*) 'kYmnij=',kYmnij(i,1) - End Do - End If - Write (6,*) 'jbas,kbas,lbas=',jBas,kBas,lBas -#endif -* * -************************************************************************ -* * -* DeSymP will compensate for degeneracy due to permutational -* symmetry. We will have to compensate for that here! -* - Call CWTime(Cpu1,Wall1) -* - iOff1 = nBas(0) - Fac = One / Four - PMax=Zero - iPAO = 0 -* - jSym = 1 - kSym = 1 - lSym = iEor(jSym-1,kSym-1)+1 - NumOrb(1) = nChOrb(kSym-1,1) -* - Call Qpg_iScalar('SCF mode',Found) - If (Found) Then - Call Get_iScalar('SCF mode',iUHF) ! either 0 or 1 - Else - iUHF=0 - EndIf -* -* Test if we have any exchange contribution of significance -* -* - ExFac_=ExFac - If (ExFac.ne.0) Then -* -* Pick up the number of MOs which passed the threshold test. -* - nj2=0 - Do iSO=1,nKdens - jSkip(iSO)=0 - nj(iSO)=nYmnij(jSym,iSO) - NumOrb(iSO) = nChOrb(kSym-1,iSO) -* -* If all included skip presceening. -* -! trick for skipping unnecessary overhead - If (-nj(iSO).eq.NumOrb(iSO)) Then - jSkip(iSO)=1 - nj(iSO)=NumOrb(iSO) - EndIf -* -* If all excluded process only for Coulombic contributions. -* - nj2=nj2+nj(iSO) - End Do - If ((nj2.eq.0).and.(.not.lPSO)) ExFac=Zero - End If -* * -************************************************************************ -* * - If (ExFac.ne.Zero .and. NumOrb(1).gt.0 .and. iMP2prpt.ne.2 - & .and. .not. lPSO .and. iUHF.eq.0 ) Then -* * -************************************************************************ -* * -* HF and Hybrid DFT -* -* number of functions in the kS and lS shell -* - nKBas = kBas*iCmp(3) - nLBas = lBas*iCmp(4) -* - kSO = iAOtSO(iAO(3)+1,kOp(3))+iAOst(3) - lSO = iAOtSO(iAO(4)+1,kOp(4))+iAOst(4) -* -* Pointers to the full list of the X_mu,i elements. -* - lda = SIZE(CMOi(1)%SB(1)%A2,1) - ik = 1 + lda*(kSO-1) - il = 1 + lda*(lSO-1) - Xki(1:) => CMOi(1)%SB(1)%A1(ik:) - Xli(1:) => CMOi(1)%SB(1)%A1(il:) -* -* Collect the X_mu,i which survived the prescreening. -* Replace the pointers above, i.e. Xki, Xli. -* - If (nj(1).le.NumOrb(1) .and. jSkip(1).eq.0) Then -* -* Note that the X_mu,i are stored as X_i,mu! -* - imo=1 - Do k=1,nj(1) - kmo=kYmnij(k,1) ! CD-MO index -* -* Pick up X_mu,i for all mu's that belong to shell k -* - call dcopy_(nKBas,Xki(kmo:),NumOrb(1), - & Yij(imo,1,1),nj(1)) -* -* Pick up X_mu,i for all mu's that belong to shell l -* - call dcopy_(nLBas,Xli(kmo:),NumOrb(1), - & Yij(imo,2,1),nj(1)) -* - imo=imo+1 - End Do -* Reset pointers! - Xki(1:nj(1)*nKBas) => Yij(1:nj(1)*nKBas,1,1) - Xli(1:nj(1)*nLBas) => Yij(1:nj(1)*nLBas,2,1) - ElseIf (nj(1).gt.NumOrb(1)) Then - Call WarningMessage(2,'Pget1_RI3: nj > NumOrb.') - Call Abend() - EndIf - - Do i2 = 1, iCmp(2) - jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) - jSO_off = jSO - iOff1 -* -* Read a block of C_kl^J -* - lCVec = nIJR(kSym,lSym,1)*jBas ! Block size - iAdr = nIJR(kSym,lSym,1)*(jSO_off-1) + iAdrCVec(jSym,kSym,1) - Call dDaFile(LuCVector(jSym,1),2,CijK,lCVec,iAdr) -* -* Extract only those C_kl^Js for which we deem k and l to -* belong to the shell-pair and to be of significance. -* - If (nj(1).le.NumOrb(1) .and. jSkip(1).eq.0) Then - ij=1 - Do j=1,nj(1) - jmo=kYmnij(j,1) - Do i=1,nj(1) - imo=kYmnij(i,1) - jC=imo+NumOrb(1)*(jmo-1) - call dcopy_(jBas,CijK(jC),NumOrb(1)**2, - & CilK(ij),nj(1)**2) - ij=ij+1 - End Do - End Do - n2j=nj(1)**2*jBas - CijK(1:n2j)=CilK(1:n2j) - End If -* -* Transform according to Eq. 16 (step 4) and generate B_kl^J -* -*** ---- E(jK,m) = Sum_i C(i,jK)' * X(i,m) -* - Call dGEMM_('T','N',nj(1)*jBas,nKBas,nj(1), - & 1.0d0,CijK,nj(1), - & Xki,nj(1), - & 0.0d0,CilK,nj(1)*jBas) -* -*** ---- B(Km,n) = Sum_j E(j,Km)' * X(j,n) -* - Call dGEMM_('T','N',jBas*nKBas,nLBas,nj(1), - & 1.0d0,CilK,nj(1), - & Xli,nj(1), - & 0.0d0,BklK,jBas*nKBas) -* - Do i3 = 1, iCmp(3) - kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) - Do i4 = 1, iCmp(4) - lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) -* - iPAO = iPAO + 1 - nijkl = 0 -* - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - Do kAOk = 0, kBas-1 - kSOk = kSO + kAOk -* - indexB = (kAOk + (i3-1)*kBas)*jBas - & + (lAOl + (i4-1)*lBas)*nKBas*jBas - Indk=Max(kSOk,lSOl) - Indl=kSOk+lSOl-Indk - Indkl=(Indk-1)*Indk/2+Indl -* - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - iOff1 - nijkl = nijkl + 1 - indexB = indexB + 1 -* -*-----------------------Coulomb contribution: V_k(j)*D(kl) -* - temp=CoulFac*V_k(jSOj,1)*DSO(Indkl,1) -* -*-----------------------Exchange contribution: B(K,m,n) -* - temp = temp - ExFac*Half*BklK(indexB) -* - PMax=Max(PMax,Abs(temp)) - PAO(nijkl,iPAO) = Fac * temp - End Do - End Do - End Do - End Do - End Do - End Do - Xki=>Null() - Xli=>Null() -* * -************************************************************************ -* * - Else If (ExFac.ne.Zero .and. NumOrb(1).gt.0 .and. iMP2prpt.ne.2 - & .and. .not. lPSO .and. iUHF.eq.1 ) Then -* * -************************************************************************ -* * -* UHF and Hybrid UDFT -* -* number of functions in the kS and lS shell -* - nKBas = kBas*iCmp(3) - nLBas = lBas*iCmp(4) -* - kSO = iAOtSO(iAO(3)+1,kOp(3))+iAOst(3) - lSO = iAOtSO(iAO(4)+1,kOp(4))+iAOst(4) -* -* Pointers to the full list of the X_mu,i elements. -* - Do iSO=1,2 - If (nIJR(kSym,lSym,iSO).ne.0) Then -* - lda = SIZE(CMOi(iSO)%SB(1)%A2,1) - ik = 1 + lda*(kSO-1) - il = 1 + lda*(lSO-1) - Xki2(iSO)%A1(1:) => CMOi(iSO)%SB(1)%A1(ik:) - Xli2(iSO)%A1(1:) => CMOi(iSO)%SB(1)%A1(il:) -* -* Collect the X_mu,i which survived the prescreening. -* Replace the pointers above, i.e. Xki, Xli. -* - If (nj(iSO).le.NumOrb(iSO) .and. jSkip(iSO).eq.0) Then -* -* Note that the X_mu,i are stored as X_i,mu! -* - imo=1 - Do k=1,nj(iSO) - kmo=kYmnij(k,iSO) ! CD-MO index -* -* Pick up X_mu,i for all mu's that belong to shell k -* - call dcopy_(nKBas,Xki2(iSO)%A1(kmo:),NumOrb(iSO), - & Yij(imo,1,iSO),nj(iSO)) -* -* Pick up X_mu,i for all mu's that belong to shell l -* - call dcopy_(nLBas,Xli2(iSO)%A1(kmo:),NumOrb(iSO), - & Yij(imo,2,iSO),nj(iSO)) -* - imo=imo+1 - End Do -* Reset pointers! - Xki2(iSO)%A1(1:nj(iSO)*nKBas) => - & Yij(1:nj(iSO)*nKBas,1,iSO) - Xli2(iSO)%A1(1:nj(iSO)*nLBas) => - & Yij(1:nj(iSO)*nLBas,2,iSO) - ElseIf (nj(iSO).gt.NumOrb(iSO)) Then - Call WarningMessage(2,'Pget1_RI3: nj > NumOrb.') - Call Abend() - EndIf - EndIf - End Do - - Do i2 = 1, iCmp(2) - jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) - jSO_off = jSO - iOff1 -* - Factor=0.0d0 -* - Do iSO=1,2 - If ((nIJR(kSym,lSym,iSO).ne.0).and.(nj(iSO).ne.0)) Then -* -* Read a block of C_kl^J -* - lCVec = nIJR(kSym,lSym,iSO)*jBas ! Block size - iAdr = nIJR(kSym,lSym,iSO)*(jSO_off-1) + - & iAdrCVec(jSym,kSym,iSO) - Call dDaFile(LuCVector(jSym,iSO),2,CijK,lCVec,iAdr) -* -* Extract only those C_kl^Js for which we deem k and l to -* belong to the shell-pair and to be of significance. -* - If (nj(iSO).le.NumOrb(iSO) .and. jSkip(iSO).eq.0) Then - ij=1 - Do j=1,nj(iSO) - jmo=kYmnij(j,iSO) - Do i=1,nj(iSO) - imo=kYmnij(i,iSO) - jC=imo+NumOrb(iSO)*(jmo-1) - call dcopy_(jBas,CijK(jC),NumOrb(iSO)**2, - & Cilk(ij),nj(iSO)**2) - ij=ij+1 - End Do - End Do - n2j=nj(iSO)**2*jBas - CijK(1:n2j)=CilK(1:n2j) - End If -* -* Transform according to Eq. 16 (step 4) and generate B_kl^J -* -*** ---- E(jK,m) = Sum_i C(i,jK)' * X(i,m) -* - Call dGEMM_('T','N',nj(iSO)*jBas,nKBas,nj(iSO), - & 1.0d0,CijK,nj(iSO), - & Xki2(iSO)%A1,nj(iSO), - & 0.0d0,CilK,nj(iSO)*jBas) -* -*** ---- B(Km,n) = Sum_j E(j,Km)' * X(j,n) -* - Call dGEMM_('T','N',jBas*nKBas,nLBas,nj(iSO), - & 1.0d0,CilK,nj(iSO), - & Xli2(iSO)%A1,nj(iSO), - & Factor,BklK,jBas*nKBas) - Factor=1.0d0 - EndIf - End Do -* - Do i3 = 1, iCmp(3) - kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) - Do i4 = 1, iCmp(4) - lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) -* - iPAO = iPAO + 1 - nijkl = 0 -* - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - Do kAOk = 0, kBas-1 - kSOk = kSO + kAOk -* - indexB = (kAOk + (i3-1)*kBas)*jBas - & + (lAOl + (i4-1)*lBas)*nKBas*jBas - Indk=Max(kSOk,lSOl) - Indl=kSOk+lSOl-Indk - Indkl=(Indk-1)*Indk/2+Indl -* - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - iOff1 - nijkl = nijkl + 1 - indexB = indexB + 1 -* -*-----------------------Coulomb contribution: V_k(j)*D(kl) -* - temp=CoulFac*V_k(jSOj,1)*DSO(Indkl,1) -* -*-----------------------Exchange contribution: B(K,m,n) -* - temp = temp - ExFac*BklK(indexB) -* - PMax=Max(PMax,Abs(temp)) - PAO(nijkl,iPAO) = Fac * temp - End Do - End Do - End Do - End Do - End Do - End Do - Do iSO=1,2 - Xki2(iSO)%A1 => Null() - Xli2(iSO)%A1 => Null() - End Do -* * -************************************************************************ -* * - Else If (ExFac.ne.Zero .and. NumOrb(1).gt.0 .and. iMP2prpt.ne.2 - & .and. lPSO .and. .not. LSA ) Then -* * -************************************************************************ -* * -* CASSCF case -* -* number of functions in the kS and lS shell -* - nKBas = kBas*iCmp(3) - nLBas = lBas*iCmp(4) -* - kSO = iAOtSO(iAO(3)+1,kOp(3))+iAOst(3) - lSO = iAOtSO(iAO(4)+1,kOp(4))+iAOst(4) -* -* Pointers to the full list of the X_mu,i elements. -* - lda = SIZE(CMOi(1)%SB(1)%A2,1) - ik = 1 + lda*(kSO-1) - il = 1 + lda*(lSO-1) - Xki(1:) => CMOi(1)%SB(1)%A1(ik:) - Xli(1:) => CMOi(1)%SB(1)%A1(il:) -* -* Collect the X_mu,i which survived the prescreening. -* Replace the pointers above, i.e. Xki, Xli. -* - If (nj(1).le.NumOrb(1) .and. jSkip(1).eq.0.and.nj(1).ne.0) Then -* -* Note that the X_mu,i are stored as X_i,mu! -* - imo=1 - Do k=1,nj(1) - kmo=kYmnij(k,1) ! CD-MO index -* -* Pick up X_mu,i for all mu's that belong to shell k -* - call dcopy_(nKBas,Xki(kmo:),NumOrb(1), - & Yij(imo,1,1),nj(1)) -* -* Pick up X_mu,i for all mu's that belong to shell l -* - call dcopy_(nLBas,Xli(kmo:),NumOrb(1), - & Yij(imo,2,1),nj(1)) -* - imo=imo+1 - End Do -* Reset pointers! - Xki(1:nj(1)*nKBas) => Yij(1:nj(1)*nKBas,1,1) - Xli(1:nj(1)*nLBas) => Yij(1:nj(1)*nLBas,2,1) - ElseIf (nj(1).gt.NumOrb(1)) Then - Call WarningMessage(2,'Pget1_RI3: nj > NumOrb.') - Call Abend() - EndIf - - Do i2 = 1, iCmp(2) - jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) - jSO_off = jSO - iOff1 -* -* Read a block of C_kl^J -* - lCVec = nIJR(kSym,lSym,1)*jBas ! Block size - iAdr = nIJR(kSym,lSym,1)*(jSO_off-1) + iAdrCVec(jSym,kSym,1) - Call dDaFile(LuCVector(jSym,1),2,CijK,lCVec,iAdr) -* -* Extract only those C_kl^Js for which we deem k and l to -* belong to the shell-pair and to be of significance. -* - If (nj(1).ne.0) Then - If (nj(1).le.NumOrb(1) .and. jSkip(1).eq.0) Then - ij=1 - Do j=1,nj(1) - jmo=kYmnij(j,1) - Do i=1,nj(1) - imo=kYmnij(i,1) - jC=imo+NumOrb(1)*(jmo-1) - call dcopy_(jBas,CijK(jC),NumOrb(1)**2, - & CilK(ij),nj(1)**2) - ij=ij+1 - End Do - End Do - n2j=nj(1)**2*jBas - CijK(1:n2j)=CilK(1:n2j) - End If -* -* Transform according to Eq. 16 (step 4) and generate B_kl^J -* -*** ---- E(jK,m) = Sum_i C(i,jK)' * X(i,m) -* - Call dGEMM_('T','N',nj(1)*jBas,nKBas,nj(1), - & 1.0d0,CijK,nj(1), - & Xki,nj(1), - & 0.0d0,CilK,nj(1)*jBas) -* -*** ---- B(Km,n) = Sum_j E(j,Km)' * X(j,n) -* - Call dGEMM_('T','N',jBas*nKBas,nLBas,nj(1), - & 1.0d0,CilK,nj(1), - & Xli,nj(1), - & 0.0d0,BklK,jBas*nKBas) -* - Else - BklK(1:jBas*nKBas*nLBas)=Zero - EndIf -* -** Active term -* - Do jAOj=0,jBas-1 - jSOj = jSO_off + jAOj - Do i4 = 1, iCmp(4) - lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - Do kAct=1,nAct(kSym-1) - tmp=ddot_(kact,Zpk(kAct*(kAct-1)/2+1,jSOj,1),1, - & AOrb(1)%SB(1)%A2(:,lSOl),1) -* -* - Do lAct=kAct+1,nAct(lSym-1) - tmp=tmp+Zpk(lAct*(lAct-1)/2+kAct,jSOj,1)* - & AOrb(1)%SB(1)%A2(lAct,lSOl) - End Do - CilK(kAct)=tmp - End Do -* - Do i3 = 1, iCmp(3) - kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) - iThpkl= jAOj+ (i3-1)*kBas*jBas - & + (lAOl + (i4-1)*lBas)*nKBas*jBas+1 - lda=SIZE(AOrb(1)%SB(1)%A2,1) - ik = 1 + lda*(kSO-1) - Call dGeMV_('T',nAct(kSym-1),kBas,1.0d0, - & AOrb(1)%SB(1)%A1(ik:), - & nAct(kSym-1),Cilk,1,0.0d0, - & Thpkl(iThpkl),jBas) - End Do - End Do - End Do - End Do -* - Do i3 = 1, iCmp(3) - kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) - Do i4 = 1, iCmp(4) - lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) -* - iPAO = iPAO + 1 - nijkl = 0 -* - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - Do kAOk = 0, kBas-1 - kSOk = kSO + kAOk -* - iThpkl=(kAOk + (i3-1)*kBas)*jBas - & + (lAOl + (i4-1)*lBas)*nKBas*jBas - indexB=iThpkl - Indk=Max(kSOk,lSOl) - Indl=kSOk+lSOl-Indk - Indkl=(Indk-1)*Indk/2+Indl -* - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - iOff1 - nijkl = nijkl + 1 - indexB = indexB + 1 - iThpkl = iThpkl + 1 -* -*-----------------------Coulomb contribution: V_k(j)*D(kl) -* - temp=CoulFac*V_k(jSOj,1)*DSO(Indkl,1) -* -*-----------------------Exchange contribution: B(K,m,n) -* - temp = temp - ExFac*Half*Bklk(indexB) -* -*-----------------------Active space contribution: Sum_p Z(p,K)*Th(p,m,n) -* - temp=temp+Thpkl(iThpkl) -* - PMax=Max(PMax,Abs(temp)) - PAO(nijkl,iPAO) = Fac * temp - End Do - End Do - End Do - End Do - End Do - End Do - Xki=>Null() - Xli=>Null() -* * -************************************************************************ -* * - Else If (ExFac.ne.Zero .and. iMP2prpt.ne.2 - & .and. lPSO .and. lSA ) Then -* * -************************************************************************ -* * -* SA-CASSCF case -* -* number of functions in the kS and lS shell -* - nKBas = kBas*iCmp(3) - nLBas = lBas*iCmp(4) -* - kSO = iAOtSO(iAO(3)+1,kOp(3))+iAOst(3) - lSO = iAOtSO(iAO(4)+1,kOp(4))+iAOst(4) -* -* Pointers to the full list of the X_mu,i elements. -* - Do iSO=1,2 - If (nIJR(kSym,lSym,iSO).ne.0) Then - iMOleft=iSO - iMOright=iSO+2 -* - lda1 = SIZE(CMOi(iSO )%SB(1)%A2,1) - lda2 = SIZE(CMOi(iSO+2)%SB(1)%A2,1) - ik1 = 1 + lda1*(kSO-1) - ik2 = 1 + lda2*(kSO-1) - il1 = 1 + lda1*(lSO-1) - il2 = 1 + lda2*(lSO-1) - - Xki2(iSO)%A1(1:) => CMOi(iSO+2)%SB(1)%A1(ik2:) - Xki3(iSO)%A1(1:) => CMOi(iSO )%SB(1)%A1(ik1:) - Xli2(iSO)%A1(1:) => CMOi(iSO )%SB(1)%A1(il1:) - Xli3(iSO)%A1(1:) => CMOi(iSO+2)%SB(1)%A1(il2:) -* -* Collect the X_mu,i which survived the prescreening. -* Replace the pointers above, i.e. Xki, Xli. -* - If ((nj(iMOright).le.NumOrb(iMOright)) - & .and.(jSkip(iMOright).eq.0)) Then - -* Note that the X_mu,i are stored as X_i,mu! -* - imo=1 - Do k=1,nj(iMOright) - kmo=kYmnij(k,iMOright) ! CD-MO index -* -* Pick up X_mu,i for all mu's that belong to shell k -* - call dcopy_(nKBas, - & Xki2(iSO)%A1(kmo:),NumOrb(iMOright), - & Yij(imo,1,iMOright),nj(iMOright)) - - call dcopy_(nLBas, - & Xli3(iSO)%A1(kmo:),NumOrb(iMOright), - & Yij(imo,2,iMOright),nj(iMOright)) - - imo=imo+1 - End Do -* Reset pointers! - nk = nj(iMOright) - Xki2(iSO)%A1(1:nk*nKBas) => Yij(1:nk*nKBas,1,iMOright) - Xli3(iSO)%A1(1:nk*nLBas) => Yij(1:nk*nLBas,2,iMOright) - ElseIf (nj(iMOright).gt.NumOrb(iMOright)) Then - Call WarningMessage(2,'Pget1_RI3: nj > NumOrb.') - Call Abend() - End If -* - If ((nj(iMOleft).le.NumOrb(iMOleft)) - & .and.(jSkip(iMOleft).eq.0)) Then -* - imo=1 - Do k=1,nj(iMOleft) - kmo=kYmnij(k,iMOleft) ! CD-MO index -* -* Pick up X_mu,i for all mu's that belong to shell l -* - call dcopy_(nLBas, - & Xli2(iSO)%A1(kmo:),NumOrb(iMOleft), - & Yij(imo,2,iMOleft),nj(iMOleft)) - - call dcopy_(nKBas, - & Xki3(iSO)%A1(kmo:),NumOrb(iMOleft), - & Yij(imo,1,iMOleft),nj(iMOleft)) - imo=imo+1 - End Do - nk = nj(iMOleft) - Xli2(iSO)%A1(1:nk*nLBas) => Yij(1:nk*nLBas,2,iMOleft) - Xki3(iSO)%A1(1:nk*nKBas) => Yij(1:nk*nKBas,1,iMOleft) - ElseIf (nj(iMOleft).gt.NumOrb(iMOleft)) Then - Call WarningMessage(2,'Pget1_RI3: nj > NumOrb.') - Call Abend() - EndIf - EndIf - End Do - - Do i2 = 1, iCmp(2) -* - jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) - jSO_off = jSO - iOff1 -* - Factor=0.0d0 -* - Do iSO=1,2 - iMOleft=iSO - iMOright=iSO+2 - If ((nIJR(kSym,lSym,iSO).ne.0).and.(nj(iMOright).ne.0) - & .and.(nj(iMOleft).ne.0)) Then -* -* Read a block of C_kl^J -* - lCVec = nIJR(kSym,lSym,iSO)*jBas ! Block size - iAdr = nIJR(kSym,lSym,iSO)*(jSO_off-1) + - & iAdrCVec(jSym,kSym,iSO) - Call dDaFile(LuCVector(jSym,iSO),2,CijK, - & lCVec,iAdr) -* -* Extract only those C_kl^Js for which we deem k and l to -* belong to the shell-pair and to be of significance. -* -*MGD skipped jSkip() since not used and complicated in this case - If (nj(iMOright).le.NumOrb(iMOright).or. - & nj(iMOleft ).le.NumOrb(iMOleft )) Then - ij=1 - Do j=1,nj(iMOleft) - jmo=kYmnij(j,iMOleft) - Do i=1,nj(iMOright) - imo=kYmnij(i,iMOright) - jC=imo+NumOrb(iMOright)*(jmo-1) - call dcopy_(jBas, - & CijK(jC),NumOrb(iMOright)*NumOrb(iMOleft), - & CilK(ij),nj(iMOright)*nj(iMOleft)) - ij=ij+1 - End Do - End Do - n2j=nj(iMOright)*nj(iMOleft)*jBas - CijK(1:n2j)=CilK(1:n2j) - End If -* -* Transform according to Eq. 16 (step 4) and generate B_kl^J -* -*** ---- E(jK,m) = Sum_i C(i,jK)' * X(i,m) -* - Call dGEMM_('T','N',nj(iMOleft)*jBas,nKBas,nj(iMOright), - & 1.0d0,CijK,nj(iMOright), - & Xki2(iSO)%A1,nj(iMOright), - & 0.0d0,CilK,nj(iMOleft)*jBas) -* -*** ---- B(Km,n) = Sum_j E(j,Km)' * X(j,n) -* - Call dGEMM_('T','N',jBas*nKBas,nLBas,nj(iMOleft), - & 1.0d0,CilK,nj(iMOleft), - & Xli2(iSO)%A1,nj(iMOleft), - & Factor,BklK,jBas*nKBas) - Factor=1.0d0 -* -** Add transpose -* -*Transpose Cijk->Cjik - Do ijBas=1,jBas - nnk =nj(iMOleft)*nj(iMOright)*(ijBas-1) - - Do ileft=1,nj(iMOleft) - njk = nj(iMOright)*(ileft-1) + nnk - - Do iright=1,nj(iMOright) - nik= nj(iMOleft)*(iright-1)+ nnk - - ijk = iright + njk - jik = ileft + nik -* - CilK(jik)=CijK(ijk) - End Do - End Do - End Do -* -*** ---- E(iK,m) = Sum_j C(j,iK)' * X(j,m) -* - Call dGEMM_('T','N',nj(iMOright)*jBas,nKBas,nj(iMOleft), - & 1.0d0,CilK,nj(iMOleft), - & Xki3(iSO)%A1,nj(iMOleft), - & 0.0d0,CijK,nj(iMOright)*jBas) -* -*** ---- B(Km,n) = Sum_j E(i,Km)' * X(i,n) -* - Call dGEMM_('T','N',jBas*nKBas,nLBas,nj(iMOright), - & 1.0d0,CijK,nj(iMOright), - & Xli3(iSO)%A1,nj(iMOright), - & Factor,BklK,jBas*nKBas) - EndIf - End Do -* -** Active term -* - Call dzero(Thpkl,jBas*nKBas*nLBas) - Do iVec=1,4 - iMO1=1 - iMO2=1 - iVec_=iVec - fact=1.0d0 - If (iVec.eq.2) iMO2=2 - If (iVec.eq.3) fact=2.0d0 - If (iVec.eq.4) Then - iMO1=2 - iVec_=2 - EndIf - - Do jAOj=0,jBas-1 - jSOj = jSO_off + jAOj - Do i4 = 1, iCmp(4) - lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) - Do lAOl = 0, lBas-1 -* lSOl = lSO + lAOl-1 - lSOl = lSO + lAOl - Do kAct=1,nAct(kSym-1) - tmp=ddot_(kact,Zpk(kAct*(kAct-1)/2+1,jSOj,iVec_),1, - & AOrb(iMO1)%SB(1)%A2(:,lSOl),1) - Do lAct=kAct+1,nAct(lSym-1) - tmp=tmp+Zpk(lAct*(lAct-1)/2+kAct,jSOj,iVec_)* - & AOrb(iMO1)%SB(1)%A2(lAct,lSOl) - End Do - CilK(kAct)=tmp - End Do -* - Do i3 = 1, iCmp(3) - kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) - iThpkl= jAOj+ (i3-1)*kBas*jBas - & + (lAOl + (i4-1)*lBas)*nKBas*jBas+1 - lda = SIZE(AOrb(iMO2)%SB(1)%A2,1) - ik = 1 + lda*(kSO-1) - Call dGeMV_('T',nAct(kSym-1),kBas,fact, - & AOrb(iMO2)%SB(1)%A1(ik:), - & nAct(kSym-1),Cilk,1,1.0d0, - & Thpkl(iThpkl),jBas) - End Do - End Do - End Do - End Do - End Do -* - Do i3 = 1, iCmp(3) - kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) - Do i4 = 1, iCmp(4) - lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) -* - iPAO = iPAO + 1 - nijkl = 0 -* - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - Do kAOk = 0, kBas-1 - kSOk = kSO + kAOk -* - iThpkl=(kAOk + (i3-1)*kBas)*jBas - & + (lAOl + (i4-1)*lBas)*nKBas*jBas - indexB=iThpkl - Indk=Max(kSOk,lSOl) - Indl=kSOk+lSOl-Indk - Indkl=(Indk-1)*Indk/2+Indl -* - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - iOff1 - nijkl = nijkl + 1 - indexB = indexB + 1 - iThpkl = iThpkl + 1 -* -*-----------------------SA-CASSCF Coulomb contribution -* - temp=CoulFac*(V_k(jSOj,1)*DSO(Indkl,2)+ - & V_k(jSOj,2)*DSO(Indkl,1)+ - & V_k(jSOj,3)*DSO(Indkl,4)+ - & V_k(jSOj,4)*DSO(Indkl,3)+ - & V_k(jSOj,1)*DSO(Indkl,5)+ - & V_k(jSOj,5)*DSO(Indkl,1)) -* -*-----------------------Exchange contribution: B(K,m,n) -* -* - temp = temp - Factor*ExFac*Half*BklK(indexB) -* -*-----------------------Active space contribution: Sum_p Z(p,K)*Th(p,m,n) -* - temp=temp+Thpkl(iThpkl) -* - PMax=Max(PMax,Abs(temp)) - PAO(nijkl,iPAO) = Fac * temp - End Do - End Do - End Do - End Do - End Do - End Do - Do iSO=1,2 - Xki2(iSO)%A1 => Null() - Xki3(iSO)%A1 => Null() - Xli2(iSO)%A1 => Null() - Xli3(iSO)%A1 => Null() - End Do -* * -************************************************************************ -* * - Else If (ExFac.ne.Zero.and.NumOrb(1).gt.0.and.iMP2prpt.eq.2) Then -* * -************************************************************************ -* * -* MP2 case -* - nKBas = kBas*iCmp(3) - nLBas = lBas*iCmp(4) - - kSO = iAOtSO(iAO(3)+1,kOp(3))+iAOst(3) - lSO = iAOtSO(iAO(4)+1,kOp(4))+iAOst(4) - - lda = SIZE(CMOi(1)%SB(1)%A2,1) - ik = 1 + lda*(kSO-1) - il = 1 + lda*(lSO-1) - Xki(1:) => CMOi(1)%SB(1)%A1(ik:) - Xli(1:) => CMOi(1)%SB(1)%A1(il:) - - If (nj(1).le.NumOrb(1) .and. jSkip(1).eq.0) Then - imo=1 - Do k=1,nj(1) - kmo=kYmnij(k,1) - call dcopy_(nKBas,Xki(kmo:),NumOrb(1), - & Yij(imo,1,1),nj(1)) - call dcopy_(nLBas,Xli(kmo:),NumOrb(1), - & Yij(imo,2,1),nj(1)) - imo=imo+1 - End Do - Xki(1:nj(1)*nKBas) => Yij(1:nj(1)*nKBas,1,1) - Xli(1:nj(1)*nLBas) => Yij(1:nj(1)*nLBas,2,1) - ElseIf (nj(1).gt.NumOrb(1)) Then - Call WarningMessage(2,'Pget1_RI3: nj > NumOrb.') - Call Abend() - EndIf - - Do i2 = 1, iCmp(2) - jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) - jSO_off = jSO - iOff1 -* - lCVec = nIJR(kSym,lSym,1)*jBas - iAdr = nIJR(kSym,lSym,1)*(jSO_off-1) + iAdrCVec(jSym,kSym,1) - Call dDaFile(LuCVector(jSym,1),2,CijK,lCVec,iAdr) -* - If (nj(1).le.NumOrb(1) .and. jSkip(1).eq.0) Then - ij=1 - Do j=1,nj(1) - jmo=kYmnij(j,1) - Do i=1,nj(1) - imo=kYmnij(i,1) - jC=imo+NumOrb(1)*(jmo-1) - call dcopy_(jBas,CijK(jC),NumOrb(1)**2, - & CilK(ij),nj(1)**2) - ij=ij+1 - End Do - End Do - n2j=nj(1)**2*jBas - CijK(1:n2j)=CilK(1:n2j) - EndIf -* -*** ---- C(jK,m) = sum_i C(i,jK)' * X(i,m) -* - Call dGEMM_('T','N',nj(1)*jBas,nKBas,nj(1), - & 1.0d0,CijK,nj(1), - & Xki,nj(1), - & 0.0d0,CilK,nj(1)*jBas) -* -*** ---- B(Km,n) = sum_j C(j,Km)' * X(j,n) -* - Call dGEMM_('T','N',jBas*nKBas,nLBas,nj(1), - & 1.0d0,CilK,nj(1), - & Xli,nj(1), - & 0.0d0,BklK,jBas*nKBas) -* -**** - lBVec = nBas(0)*nBas(0)*jBas - Do i = 1,2 - iAdr = 1 + nBas(0)*nBas(0)*(jSO_off-1) - Call dDaFile(LuBVector(i),2,Bmp2(:,i),lBVec,iAdr) - End Do -* - Do i3 = 1, iCmp(3) - kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) - Do i4 = 1, iCmp(4) - lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) -* - iPAO = iPAO + 1 - nijkl = 0 -* - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - Do kAOk = 0, kBas-1 - kSOk = kSO + kAOk -* - indexB = (kAOk + (i3-1)*kBas)*jBas - & + (lAOl + (i4-1)*lBas)*nKBas*jBas - Indk=Max(kSOk,lSOl) - Indl=kSOk+lSOl-Indk - Indkl=(Indk-1)*Indk/2+Indl -* - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - iOff1 - nijkl = nijkl + 1 - indexB = indexB + 1 -* -*-----------------------Coulomb contribution: V_k(j)*D(kl) -* - temp = CoulFac*(V_k(jSOj,1)*DSO(Indkl,1) - & + U_k(jSOj)*DSO(Indkl,1) - & + V_k(jSOj,1)*(DSO_Var(Indkl)-DSO(indkl,1)) - & + Compute_B(irc,kSOk,lSOl,jAOj,iOff1,2)) -* -*-----------------------Exchange contribution: B(K,m,n) -* - temp = temp - ExFac*Half*(BklK(indexB) - & + Compute_B(irc,kSOk,lSOl,jAOj,iOff1,1)) -* temp = temp - ExFac*Half*( -* & + Compute_B(irc,kSOk,lSOl,jAOj,iOff1,1)) - - PMax=Max(PMax,Abs(temp)) - PAO(nijkl,iPAO) = Fac * temp - End Do - End Do - End Do - End Do - End Do - End Do - Xki=>Null() - Xli=>Null() -* * -************************************************************************ -* * - Else -* * -************************************************************************ -* * -* Pure DFT or case when no exhange -* - Do i2 = 1, iCmp(2) - jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) - Do i3 = 1, iCmp(3) - kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) - Do i4 = 1, iCmp(4) - lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) -* - iPAO = iPAO + 1 - nijkl = 0 -* - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - Do kAOk = 0, kBas-1 - kSOk = kSO + kAOk -* - Indk=Max(kSOk,lSOl) - Indl=kSOk+lSOl-Indk - Indkl=(Indk-1)*Indk/2+Indl -* - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - iOff1 - nijkl = nijkl + 1 -* -*-----------------------Coulomb contribution: V_k(j)*D(kl) -* - temp=CoulFac*V_k(jSOj,1)*DSO(Indkl,1) -* temp=0.0D0 -* - PMax=Max(PMax,Abs(temp)) - PAO(nijkl,iPAO) = Fac * temp - End Do - End Do - End Do - End Do - End Do - End Do -* * -************************************************************************ -* * - End If -* * -************************************************************************ -* * -* -* Reset ExFac always. -* - ExFac=ExFac_ -* - If (iPAO.ne.nPAO) Then - Write (6,*) ' Error in PGet1_RI3!' - Call Abend - End If -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - Call RecPrt(' In PGet1_RI3:PAO ',' ',PAO,ijkl,nPAO) - Do i = 1, ijkl - Write (6,*) DDot_(nPAO,PAO(i,1),ijkl,PAO(i,1),ijkl) - End Do -#endif -* * -************************************************************************ -* * - Call CWTime(Cpu2,Wall2) - Cpu = Cpu2 - Cpu1 - Wall = Wall2 - Wall1 - tbvec(1) = tbvec(1) + Cpu - tbvec(2) = tbvec(2) + Wall -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_logical(Shijij) - Call Unused_integer(iBas) - Call Unused_real_array(DSSO) - End If - End diff -Nru openmolcas-22.02/src/ri_util/pget1_ri3.F90 openmolcas-22.10/src/ri_util/pget1_ri3.F90 --- openmolcas-22.02/src/ri_util/pget1_ri3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/pget1_ri3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,1017 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1992,2007, Roland Lindh * +!*********************************************************************** + +subroutine PGet1_RI3(PAO,ijkl,nPAO,iCmp,iAO,iAOst,jBas,kBas,lBas,kOp,DSO,DSO_Var,nDSO,ExFac,CoulFac,PMax,V_K,U_K,mV_k,ZpK,nnP1, & + nSA,nAct) +!*********************************************************************** +! Object: to assemble the 2nd order density matrix of a SCF wave * +! function from the 1st order density. * +! * +! The indices have been scrambled before calling this routine.* +! Hence we must take special care in order to regain the * +! canonical order. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +! January '92. * +! * +! Modified for 3-center RI gradients, March 2007 * +!*********************************************************************** + +use Index_Functions, only: iTri +use Symmetry_Info, only: Mul +use Basis_Info, only: nBas +use SOAO_Info, only: iAOtSO +use pso_stuff, only: AOrb, lPSO, lSA, Thpkl +use Data_Structures, only: V1 +use RI_glob, only: BklK, BMP2, CijK, CilK, CMOi, iAdrCVec, iMP2prpt, LuBVector, LuCVector, nChOrb, nIJR, nKdens, nYmnij, tbvec, & + Yij, Ymnij +#ifdef _DEBUGPRINT_ +use RI_glob, only: iOff_Ymnij +#endif +use Constants, only: Zero, One, Two, Half, Quart +use Definitions, only: wp, iwp, u6, r8 + +implicit none +integer(kind=iwp), intent(in) :: ijkl, nPAO, iCmp(4), iAO(4), iAOst(4), jBas, kBas, lBas, kOp(4), nDSO, mV_k, nnP1, nSA, nAct(0:7) +real(kind=wp), intent(out) :: PAO(ijkl,nPAO), PMax +real(kind=wp), intent(in) :: DSO(nDSO,nSA), DSO_Var(nDSO), ExFac, CoulFac, V_k(mV_k,nSA), U_k(mV_k), ZpK(nnP1,mV_K,*) +integer(kind=iwp) :: i, i2, i3, i4, iAdr, ij, ijBas, ijk, ik, ik1, ik2, il, il1, il2, ileft, imo, iMO1, iMO2, iMOleft, iMOright, & + indexB, Indkl, iOff1, iPAO, irc, iright, iSO, iThpkl, iUHF, iVec, iVec_, j, jAOj, jC, jik, jmo, jSkip(4), & + jSO, jSO_off, jSOj, jSym, k, kAct, kAOk, kmo, kSO, kSOk, kSym, lAct, lAOl, lBVec, lCVec, lda, lda1, lda2, & + lSO, lSOl, lSym, n2J, nijkl, nik, nj(4), nj2, njk, nk, nKBas, nLBas, nnk, NumOrb(4) +real(kind=wp) :: Cpu, Cpu1, Cpu2, ExFac_, Fac, fact, Factor, temp, tmp, Wall, Wall1, Wall2 +logical(kind=iwp) :: Found +real(kind=wp), pointer :: Xki(:), Xli(:) +type(V1) :: Xki2(2), Xki3(2), Xli2(2), Xli3(2) +real(kind=wp), external :: Compute_B +real(kind=r8), external :: dDot_ + +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +iComp = 1 +call PrMtrx('DSO ',[iD0Lbl],iComp,1,D0) +write(u6,*) +write(u6,*) 'Distribution of Ymnij' +iSym = 1 +if (nYmnij(iSym,1) > 0) then + write(u6,*) 'iSym=',iSym + do i=iOff_Ymnij(iSym,1)+1,iOff_Ymnij(iSym,1)+nYmnij(iSym,1) + write(u6,*) 'Ymnij=',Ymnij(1)%A(i) + end do +end if +write(u6,*) 'jbas,kbas,lbas=',jBas,kBas,lBas +#endif +! * +!*********************************************************************** +! * +! DeSymP will compensate for degeneracy due to permutational +! symmetry. We will have to compensate for that here! + +call CWTime(Cpu1,Wall1) + +iOff1 = nBas(0) +Fac = Quart +PMax = Zero +iPAO = 0 + +jSym = 1 +kSym = 1 +lSym = Mul(jSym,kSym) +NumOrb(1) = nChOrb(kSym-1,1) + +call Qpg_iScalar('SCF mode',Found) +if (Found) then + call Get_iScalar('SCF mode',iUHF) ! either 0 or 1 +else + iUHF = 0 +end if + +! Test if we have any exchange contribution of significance + +ExFac_ = ExFac +if (ExFac_ /= 0) then + + ! Pick up the number of MOs which passed the threshold test. + + nj2 = 0 + do iSO=1,nKdens + jSkip(iSO) = 0 + nj(iSO) = nYmnij(jSym,iSO) + NumOrb(iSO) = nChOrb(kSym-1,iSO) + + ! If all included skip presceening. + + ! trick for skipping unnecessary overhead + if (-nj(iSO) == NumOrb(iSO)) then + jSkip(iSO) = 1 + nj(iSO) = NumOrb(iSO) + end if + + ! If all excluded process only for Coulombic contributions. + + nj2 = nj2+nj(iSO) + end do + if ((nj2 == 0) .and. (.not. lPSO)) ExFac_ = Zero +end if +! * +!*********************************************************************** +! * +if ((ExFac_ /= Zero) .and. (NumOrb(1) > 0) .and. (iMP2prpt /= 2) .and. (.not. lPSO) .and. (iUHF == 0)) then + ! * + !********************************************************************* + ! * + ! HF and Hybrid DFT + + ! number of functions in the kS and lS shell + + nKBas = kBas*iCmp(3) + nLBas = lBas*iCmp(4) + + kSO = iAOtSO(iAO(3)+1,kOp(3))+iAOst(3) + lSO = iAOtSO(iAO(4)+1,kOp(4))+iAOst(4) + + ! Pointers to the full list of the X_mu,i elements. + + lda = size(CMOi(1)%SB(1)%A2,1) + ik = 1+lda*(kSO-1) + il = 1+lda*(lSO-1) + Xki(1:) => CMOi(1)%SB(1)%A1(ik:) + Xli(1:) => CMOi(1)%SB(1)%A1(il:) + + ! Collect the X_mu,i which survived the prescreening. + ! Replace the pointers above, i.e. Xki, Xli. + + if ((nj(1) <= NumOrb(1)) .and. (jSkip(1) == 0)) then + + ! Note that the X_mu,i are stored as X_i,mu! + + imo = 1 + do k=1,nj(1) + kmo = Ymnij(1)%A(k) ! CD-MO index + + ! Pick up X_mu,i for all mu's that belong to shell k + + call dcopy_(nKBas,Xki(kmo:),NumOrb(1),Yij(imo,1,1),nj(1)) + + ! Pick up X_mu,i for all mu's that belong to shell l + + call dcopy_(nLBas,Xli(kmo:),NumOrb(1),Yij(imo,2,1),nj(1)) + + imo = imo+1 + end do + ! Reset pointers! + Xki(1:nj(1)*nKBas) => Yij(1:nj(1)*nKBas,1,1) + Xli(1:nj(1)*nLBas) => Yij(1:nj(1)*nLBas,2,1) + else if (nj(1) > NumOrb(1)) then + call WarningMessage(2,'Pget1_RI3: nj > NumOrb.') + call Abend() + end if + + do i2=1,iCmp(2) + jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) + jSO_off = jSO-iOff1 + + ! Read a block of C_kl^J + + lCVec = nIJR(kSym,lSym,1)*jBas ! Block size + iAdr = nIJR(kSym,lSym,1)*(jSO_off-1)+iAdrCVec(jSym,kSym,1) + call dDaFile(LuCVector(jSym,1),2,CijK,lCVec,iAdr) + + ! Extract only those C_kl^Js for which we deem k and l to + ! belong to the shell-pair and to be of significance. + + if ((nj(1) <= NumOrb(1)) .and. (jSkip(1) == 0)) then + ij = 1 + do j=1,nj(1) + jmo = Ymnij(1)%A(j) + do i=1,nj(1) + imo = Ymnij(1)%A(i) + jC = imo+NumOrb(1)*(jmo-1) + call dcopy_(jBas,CijK(jC),NumOrb(1)**2,CilK(ij),nj(1)**2) + ij = ij+1 + end do + end do + n2j = nj(1)**2*jBas + CijK(1:n2j) = CilK(1:n2j) + end if + + ! Transform according to Eq. 16 (step 4) and generate B_kl^J + + ! E(jK,m) = Sum_i C(i,jK)' * X(i,m) + + call dGEMM_('T','N',nj(1)*jBas,nKBas,nj(1),One,CijK,nj(1),Xki,nj(1),Zero,CilK,nj(1)*jBas) + + ! B(Km,n) = Sum_j E(j,Km)' * X(j,n) + + call dGEMM_('T','N',jBas*nKBas,nLBas,nj(1),One,CilK,nj(1),Xli,nj(1),Zero,BklK,jBas*nKBas) + + do i3=1,iCmp(3) + kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) + do i4=1,iCmp(4) + lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + + iPAO = iPAO+1 + nijkl = 0 + + do lAOl=0,lBas-1 + lSOl = lSO+lAOl + do kAOk=0,kBas-1 + kSOk = kSO+kAOk + + indexB = (kAOk+(i3-1)*kBas)*jBas+(lAOl+(i4-1)*lBas)*nKBas*jBas + Indkl = iTri(kSOk,lSOl) + + do jAOj=0,jBas-1 + jSOj = jSO+jAOj-iOff1 + nijkl = nijkl+1 + indexB = indexB+1 + + ! Coulomb contribution: V_k(j)*D(kl) + + temp = CoulFac*V_k(jSOj,1)*DSO(Indkl,1) + + ! Exchange contribution: B(K,m,n) + + temp = temp-ExFac_*Half*BklK(indexB) + + PMax = max(PMax,abs(temp)) + PAO(nijkl,iPAO) = Fac*temp + end do + end do + end do + end do + end do + end do + nullify(Xki,Xli) + ! * + !********************************************************************* + ! * +else if ((ExFac_ /= Zero) .and. (NumOrb(1) > 0) .and. (iMP2prpt /= 2) .and. (.not. lPSO) .and. (iUHF == 1)) then + ! * + !********************************************************************* + ! * + ! UHF and Hybrid UDFT + + ! number of functions in the kS and lS shell + + nKBas = kBas*iCmp(3) + nLBas = lBas*iCmp(4) + + kSO = iAOtSO(iAO(3)+1,kOp(3))+iAOst(3) + lSO = iAOtSO(iAO(4)+1,kOp(4))+iAOst(4) + + ! Pointers to the full list of the X_mu,i elements. + + do iSO=1,2 + if (nIJR(kSym,lSym,iSO) /= 0) then + + lda = size(CMOi(iSO)%SB(1)%A2,1) + ik = 1+lda*(kSO-1) + il = 1+lda*(lSO-1) + Xki2(iSO)%A(1:) => CMOi(iSO)%SB(1)%A1(ik:) + Xli2(iSO)%A(1:) => CMOi(iSO)%SB(1)%A1(il:) + + ! Collect the X_mu,i which survived the prescreening. + ! Replace the pointers above, i.e. Xki, Xli. + + if ((nj(iSO) <= NumOrb(iSO)) .and. (jSkip(iSO) == 0)) then + + ! Note that the X_mu,i are stored as X_i,mu! + + imo = 1 + do k=1,nj(iSO) + kmo = Ymnij(iSO)%A(k) ! CD-MO index + + ! Pick up X_mu,i for all mu's that belong to shell k + + call dcopy_(nKBas,Xki2(iSO)%A(kmo:),NumOrb(iSO),Yij(imo,1,iSO),nj(iSO)) + + ! Pick up X_mu,i for all mu's that belong to shell l + + call dcopy_(nLBas,Xli2(iSO)%A(kmo:),NumOrb(iSO),Yij(imo,2,iSO),nj(iSO)) + + imo = imo+1 + end do + ! Reset pointers! + Xki2(iSO)%A(1:nj(iSO)*nKBas) => Yij(1:nj(iSO)*nKBas,1,iSO) + Xli2(iSO)%A(1:nj(iSO)*nLBas) => Yij(1:nj(iSO)*nLBas,2,iSO) + else if (nj(iSO) > NumOrb(iSO)) then + call WarningMessage(2,'Pget1_RI3: nj > NumOrb.') + call Abend() + end if + end if + end do + + do i2=1,iCmp(2) + jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) + jSO_off = jSO-iOff1 + + Factor = Zero + + do iSO=1,2 + if ((nIJR(kSym,lSym,iSO) /= 0) .and. (nj(iSO) /= 0)) then + + ! Read a block of C_kl^J + + lCVec = nIJR(kSym,lSym,iSO)*jBas ! Block size + iAdr = nIJR(kSym,lSym,iSO)*(jSO_off-1)+iAdrCVec(jSym,kSym,iSO) + call dDaFile(LuCVector(jSym,iSO),2,CijK,lCVec,iAdr) + + ! Extract only those C_kl^Js for which we deem k and l to + ! belong to the shell-pair and to be of significance. + + if ((nj(iSO) <= NumOrb(iSO)) .and. (jSkip(iSO) == 0)) then + ij = 1 + do j=1,nj(iSO) + jmo = Ymnij(iSO)%A(j) + do i=1,nj(iSO) + imo = Ymnij(iSO)%A(i) + jC = imo+NumOrb(iSO)*(jmo-1) + call dcopy_(jBas,CijK(jC),NumOrb(iSO)**2,Cilk(ij),nj(iSO)**2) + ij = ij+1 + end do + end do + n2j = nj(iSO)**2*jBas + CijK(1:n2j) = CilK(1:n2j) + end if + + ! Transform according to Eq. 16 (step 4) and generate B_kl^J + + ! E(jK,m) = Sum_i C(i,jK)' * X(i,m) + + call dGEMM_('T','N',nj(iSO)*jBas,nKBas,nj(iSO),One,CijK,nj(iSO),Xki2(iSO)%A,nj(iSO),Zero,CilK,nj(iSO)*jBas) + + ! B(Km,n) = Sum_j E(j,Km)' * X(j,n) + + call dGEMM_('T','N',jBas*nKBas,nLBas,nj(iSO),One,CilK,nj(iSO),Xli2(iSO)%A,nj(iSO),Factor,BklK,jBas*nKBas) + Factor = One + end if + end do + + do i3=1,iCmp(3) + kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) + do i4=1,iCmp(4) + lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + + iPAO = iPAO+1 + nijkl = 0 + + do lAOl=0,lBas-1 + lSOl = lSO+lAOl + do kAOk=0,kBas-1 + kSOk = kSO+kAOk + + indexB = (kAOk+(i3-1)*kBas)*jBas+(lAOl+(i4-1)*lBas)*nKBas*jBas + Indkl = iTri(kSOk,lSOl) + + do jAOj=0,jBas-1 + jSOj = jSO+jAOj-iOff1 + nijkl = nijkl+1 + indexB = indexB+1 + + ! Coulomb contribution: V_k(j)*D(kl) + + temp = CoulFac*V_k(jSOj,1)*DSO(Indkl,1) + + ! Exchange contribution: B(K,m,n) + + temp = temp-ExFac_*BklK(indexB) + + PMax = max(PMax,abs(temp)) + PAO(nijkl,iPAO) = Fac*temp + end do + end do + end do + end do + end do + end do + do iSO=1,2 + nullify(Xki2(iSO)%A,Xli2(iSO)%A) + end do + ! * + !********************************************************************* + ! * +else if ((ExFac_ /= Zero) .and. (NumOrb(1) > 0) .and. (iMP2prpt /= 2) .and. lPSO .and. (.not. LSA)) then + ! * + !********************************************************************* + ! * + ! CASSCF case + + ! number of functions in the kS and lS shell + + nKBas = kBas*iCmp(3) + nLBas = lBas*iCmp(4) + + kSO = iAOtSO(iAO(3)+1,kOp(3))+iAOst(3) + lSO = iAOtSO(iAO(4)+1,kOp(4))+iAOst(4) + + ! Pointers to the full list of the X_mu,i elements. + + lda = size(CMOi(1)%SB(1)%A2,1) + ik = 1+lda*(kSO-1) + il = 1+lda*(lSO-1) + Xki(1:) => CMOi(1)%SB(1)%A1(ik:) + Xli(1:) => CMOi(1)%SB(1)%A1(il:) + + ! Collect the X_mu,i which survived the prescreening. + ! Replace the pointers above, i.e. Xki, Xli. + + if ((nj(1) <= NumOrb(1)) .and. (jSkip(1) == 0) .and. (nj(1) /= 0)) then + + ! Note that the X_mu,i are stored as X_i,mu! + + imo = 1 + do k=1,nj(1) + kmo = Ymnij(1)%A(k) + + ! Pick up X_mu,i for all mu's that belong to shell k + + call dcopy_(nKBas,Xki(kmo:),NumOrb(1),Yij(imo,1,1),nj(1)) + + ! Pick up X_mu,i for all mu's that belong to shell l + + call dcopy_(nLBas,Xli(kmo:),NumOrb(1),Yij(imo,2,1),nj(1)) + + imo = imo+1 + end do + ! Reset pointers! + Xki(1:nj(1)*nKBas) => Yij(1:nj(1)*nKBas,1,1) + Xli(1:nj(1)*nLBas) => Yij(1:nj(1)*nLBas,2,1) + else if (nj(1) > NumOrb(1)) then + call WarningMessage(2,'Pget1_RI3: nj > NumOrb.') + call Abend() + end if + + do i2=1,iCmp(2) + jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) + jSO_off = jSO-iOff1 + + ! Read a block of C_kl^J + + lCVec = nIJR(kSym,lSym,1)*jBas ! Block size + iAdr = nIJR(kSym,lSym,1)*(jSO_off-1)+iAdrCVec(jSym,kSym,1) + call dDaFile(LuCVector(jSym,1),2,CijK,lCVec,iAdr) + + ! Extract only those C_kl^Js for which we deem k and l to + ! belong to the shell-pair and to be of significance. + + if (nj(1) /= 0) then + if ((nj(1) <= NumOrb(1)) .and. (jSkip(1) == 0)) then + ij = 1 + do j=1,nj(1) + jmo = Ymnij(1)%A(j) + do i=1,nj(1) + imo = Ymnij(1)%A(i) + jC = imo+NumOrb(1)*(jmo-1) + call dcopy_(jBas,CijK(jC),NumOrb(1)**2,CilK(ij),nj(1)**2) + ij = ij+1 + end do + end do + n2j = nj(1)**2*jBas + CijK(1:n2j) = CilK(1:n2j) + end if + + ! Transform according to Eq. 16 (step 4) and generate B_kl^J + + ! E(jK,m) = Sum_i C(i,jK)' * X(i,m) + + call dGEMM_('T','N',nj(1)*jBas,nKBas,nj(1),One,CijK,nj(1),Xki,nj(1),Zero,CilK,nj(1)*jBas) + + ! B(Km,n) = Sum_j E(j,Km)' * X(j,n) + + call dGEMM_('T','N',jBas*nKBas,nLBas,nj(1),One,CilK,nj(1),Xli,nj(1),Zero,BklK,jBas*nKBas) + + else + BklK(1:jBas*nKBas*nLBas) = Zero + end if + + ! Active term + + do jAOj=0,jBas-1 + jSOj = jSO_off+jAOj + do i4=1,iCmp(4) + lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + do lAOl=0,lBas-1 + lSOl = lSO+lAOl + do kAct=1,nAct(kSym-1) + tmp = ddot_(kact,Zpk(iTri(kAct,1),jSOj,1),1,AOrb(1)%SB(1)%A2(:,lSOl),1) + + do lAct=kAct+1,nAct(lSym-1) + tmp = tmp+Zpk(iTri(lAct,kAct),jSOj,1)*AOrb(1)%SB(1)%A2(lAct,lSOl) + end do + CilK(kAct) = tmp + end do + + do i3=1,iCmp(3) + kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) + iThpkl = jAOj+(i3-1)*kBas*jBas+(lAOl+(i4-1)*lBas)*nKBas*jBas+1 + lda = size(AOrb(1)%SB(1)%A2,1) + ik = 1+lda*(kSO-1) + call dGeMV_('T',nAct(kSym-1),kBas,One,AOrb(1)%SB(1)%A1(ik:),nAct(kSym-1),Cilk,1,Zero,Thpkl(iThpkl),jBas) + end do + end do + end do + end do + + do i3=1,iCmp(3) + kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) + do i4=1,iCmp(4) + lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + + iPAO = iPAO+1 + nijkl = 0 + + do lAOl=0,lBas-1 + lSOl = lSO+lAOl + do kAOk=0,kBas-1 + kSOk = kSO+kAOk + + iThpkl = (kAOk+(i3-1)*kBas)*jBas+(lAOl+(i4-1)*lBas)*nKBas*jBas + indexB = iThpkl + Indkl = iTri(kSOk,lSOl) + + do jAOj=0,jBas-1 + jSOj = jSO+jAOj-iOff1 + nijkl = nijkl+1 + indexB = indexB+1 + iThpkl = iThpkl+1 + + ! Coulomb contribution: V_k(j)*D(kl) + + temp = CoulFac*V_k(jSOj,1)*DSO(Indkl,1) + + ! Exchange contribution: B(K,m,n) + + temp = temp-ExFac_*Half*Bklk(indexB) + + ! Active space contribution: Sum_p Z(p,K)*Th(p,m,n) + + temp = temp+Thpkl(iThpkl) + + PMax = max(PMax,abs(temp)) + PAO(nijkl,iPAO) = Fac*temp + end do + end do + end do + end do + end do + end do + nullify(Xki,Xli) + ! * + !********************************************************************* + ! * +else if ((ExFac_ /= Zero) .and. (iMP2prpt /= 2) .and. lPSO .and. lSA) then + ! * + !********************************************************************* + ! * + ! SA-CASSCF case + + ! number of functions in the kS and lS shell + + nKBas = kBas*iCmp(3) + nLBas = lBas*iCmp(4) + + kSO = iAOtSO(iAO(3)+1,kOp(3))+iAOst(3) + lSO = iAOtSO(iAO(4)+1,kOp(4))+iAOst(4) + + ! Pointers to the full list of the X_mu,i elements. + + do iSO=1,2 + if (nIJR(kSym,lSym,iSO) /= 0) then + iMOleft = iSO + iMOright = iSO+2 + + lda1 = size(CMOi(iSO)%SB(1)%A2,1) + lda2 = size(CMOi(iSO+2)%SB(1)%A2,1) + ik1 = 1+lda1*(kSO-1) + ik2 = 1+lda2*(kSO-1) + il1 = 1+lda1*(lSO-1) + il2 = 1+lda2*(lSO-1) + + Xki2(iSO)%A(1:) => CMOi(iSO+2)%SB(1)%A1(ik2:) + Xki3(iSO)%A(1:) => CMOi(iSO)%SB(1)%A1(ik1:) + Xli2(iSO)%A(1:) => CMOi(iSO)%SB(1)%A1(il1:) + Xli3(iSO)%A(1:) => CMOi(iSO+2)%SB(1)%A1(il2:) + + ! Collect the X_mu,i which survived the prescreening. + ! Replace the pointers above, i.e. Xki, Xli. + + if ((nj(iMOright) <= NumOrb(iMOright)) .and. (jSkip(iMOright) == 0)) then + + ! Note that the X_mu,i are stored as X_i,mu! + + imo = 1 + do k=1,nj(iMOright) + kmo = Ymnij(iMOright)%A(k) ! CD-MO index + + ! Pick up X_mu,i for all mu's that belong to shell k + + call dcopy_(nKBas,Xki2(iSO)%A(kmo:),NumOrb(iMOright),Yij(imo,1,iMOright),nj(iMOright)) + + call dcopy_(nLBas,Xli3(iSO)%A(kmo:),NumOrb(iMOright),Yij(imo,2,iMOright),nj(iMOright)) + + imo = imo+1 + end do + ! Reset pointers! + nk = nj(iMOright) + Xki2(iSO)%A(1:nk*nKBas) => Yij(1:nk*nKBas,1,iMOright) + Xli3(iSO)%A(1:nk*nLBas) => Yij(1:nk*nLBas,2,iMOright) + else if (nj(iMOright) > NumOrb(iMOright)) then + call WarningMessage(2,'Pget1_RI3: nj > NumOrb.') + call Abend() + end if + + if ((nj(iMOleft) <= NumOrb(iMOleft)) .and. (jSkip(iMOleft) == 0)) then + + imo = 1 + do k=1,nj(iMOleft) + kmo = Ymnij(iMOleft)%A(k) ! CD-MO index + + ! Pick up X_mu,i for all mu's that belong to shell l + + call dcopy_(nLBas,Xli2(iSO)%A(kmo:),NumOrb(iMOleft),Yij(imo,2,iMOleft),nj(iMOleft)) + + call dcopy_(nKBas,Xki3(iSO)%A(kmo:),NumOrb(iMOleft),Yij(imo,1,iMOleft),nj(iMOleft)) + imo = imo+1 + end do + nk = nj(iMOleft) + Xli2(iSO)%A(1:nk*nLBas) => Yij(1:nk*nLBas,2,iMOleft) + Xki3(iSO)%A(1:nk*nKBas) => Yij(1:nk*nKBas,1,iMOleft) + else if (nj(iMOleft) > NumOrb(iMOleft)) then + call WarningMessage(2,'Pget1_RI3: nj > NumOrb.') + call Abend() + end if + end if + end do + + do i2=1,iCmp(2) + + jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) + jSO_off = jSO-iOff1 + + Factor = Zero + + do iSO=1,2 + iMOleft = iSO + iMOright = iSO+2 + if ((nIJR(kSym,lSym,iSO) /= 0) .and. (nj(iMOright) /= 0) .and. (nj(iMOleft) /= 0)) then + + ! Read a block of C_kl^J + + lCVec = nIJR(kSym,lSym,iSO)*jBas ! Block size + iAdr = nIJR(kSym,lSym,iSO)*(jSO_off-1)+iAdrCVec(jSym,kSym,iSO) + call dDaFile(LuCVector(jSym,iSO),2,CijK,lCVec,iAdr) + + ! Extract only those C_kl^Js for which we deem k and l to + ! belong to the shell-pair and to be of significance. + + !MGD skipped jSkip() since not used and complicated in this case + if ((nj(iMOright) <= NumOrb(iMOright)) .or. (nj(iMOleft) <= NumOrb(iMOleft))) then + ij = 1 + do j=1,nj(iMOleft) + jmo = Ymnij(iMOleft)%A(j) + do i=1,nj(iMOright) + imo = Ymnij(iMOright)%A(i) + jC = imo+NumOrb(iMOright)*(jmo-1) + call dcopy_(jBas,CijK(jC),NumOrb(iMOright)*NumOrb(iMOleft),CilK(ij),nj(iMOright)*nj(iMOleft)) + ij = ij+1 + end do + end do + n2j = nj(iMOright)*nj(iMOleft)*jBas + CijK(1:n2j) = CilK(1:n2j) + end if + + ! Transform according to Eq. 16 (step 4) and generate B_kl^J + + ! E(jK,m) = Sum_i C(i,jK)' * X(i,m) + + call dGEMM_('T','N',nj(iMOleft)*jBas,nKBas,nj(iMOright),One,CijK,nj(iMOright),Xki2(iSO)%A,nj(iMOright),Zero,CilK, & + nj(iMOleft)*jBas) + + ! B(Km,n) = Sum_j E(j,Km)' * X(j,n) + + call dGEMM_('T','N',jBas*nKBas,nLBas,nj(iMOleft),One,CilK,nj(iMOleft),Xli2(iSO)%A,nj(iMOleft),Factor,BklK,jBas*nKBas) + Factor = One + + ! Add transpose + + ! Transpose Cijk->Cjik + do ijBas=1,jBas + nnk = nj(iMOleft)*nj(iMOright)*(ijBas-1) + + do ileft=1,nj(iMOleft) + njk = nj(iMOright)*(ileft-1)+nnk + + do iright=1,nj(iMOright) + nik = nj(iMOleft)*(iright-1)+nnk + + ijk = iright+njk + jik = ileft+nik + + CilK(jik) = CijK(ijk) + end do + end do + end do + + ! E(iK,m) = Sum_j C(j,iK)' * X(j,m) + + call dGEMM_('T','N',nj(iMOright)*jBas,nKBas,nj(iMOleft),One,CilK,nj(iMOleft),Xki3(iSO)%A,nj(iMOleft),Zero,CijK, & + nj(iMOright)*jBas) + + ! B(Km,n) = Sum_j E(i,Km)' * X(i,n) + + call dGEMM_('T','N',jBas*nKBas,nLBas,nj(iMOright),One,CijK,nj(iMOright),Xli3(iSO)%A,nj(iMOright),Factor,BklK,jBas*nKBas) + end if + end do + + ! Active term + + Thpkl(1:jBas*nKBas*nLBas) = Zero + do iVec=1,4 + iMO1 = 1 + iMO2 = 1 + iVec_ = iVec + fact = One + if (iVec == 2) iMO2 = 2 + if (iVec == 3) fact = Two + if (iVec == 4) then + iMO1 = 2 + iVec_ = 2 + end if + + do jAOj=0,jBas-1 + jSOj = jSO_off+jAOj + do i4=1,iCmp(4) + lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + do lAOl=0,lBas-1 + !lSOl = lSO+lAOl-1 + lSOl = lSO+lAOl + do kAct=1,nAct(kSym-1) + tmp = ddot_(kact,Zpk(iTri(kAct,1),jSOj,iVec_),1,AOrb(iMO1)%SB(1)%A2(:,lSOl),1) + do lAct=kAct+1,nAct(lSym-1) + tmp = tmp+Zpk(iTri(lAct,kAct),jSOj,iVec_)*AOrb(iMO1)%SB(1)%A2(lAct,lSOl) + end do + CilK(kAct) = tmp + end do + + do i3=1,iCmp(3) + kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) + iThpkl = jAOj+(i3-1)*kBas*jBas+(lAOl+(i4-1)*lBas)*nKBas*jBas+1 + lda = size(AOrb(iMO2)%SB(1)%A2,1) + ik = 1+lda*(kSO-1) + call dGeMV_('T',nAct(kSym-1),kBas,fact,AOrb(iMO2)%SB(1)%A1(ik:),nAct(kSym-1),Cilk,1,One,Thpkl(iThpkl),jBas) + end do + end do + end do + end do + end do + + do i3=1,iCmp(3) + kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) + do i4=1,iCmp(4) + lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + + iPAO = iPAO+1 + nijkl = 0 + + do lAOl=0,lBas-1 + lSOl = lSO+lAOl + do kAOk=0,kBas-1 + kSOk = kSO+kAOk + + iThpkl = (kAOk+(i3-1)*kBas)*jBas+(lAOl+(i4-1)*lBas)*nKBas*jBas + indexB = iThpkl + Indkl = iTri(kSOk,lSOl) + + do jAOj=0,jBas-1 + jSOj = jSO+jAOj-iOff1 + nijkl = nijkl+1 + indexB = indexB+1 + iThpkl = iThpkl+1 + + ! SA-CASSCF Coulomb contribution + + temp = CoulFac*(V_k(jSOj,1)*DSO(Indkl,2)+V_k(jSOj,2)*DSO(Indkl,1)+V_k(jSOj,3)*DSO(Indkl,4)+V_k(jSOj,4)*DSO(Indkl,3)+ & + V_k(jSOj,1)*DSO(Indkl,5)+V_k(jSOj,5)*DSO(Indkl,1)) + + ! Exchange contribution: B(K,m,n) + + temp = temp-Factor*ExFac_*Half*BklK(indexB) + + ! Active space contribution: Sum_p Z(p,K)*Th(p,m,n) + + temp = temp+Thpkl(iThpkl) + + PMax = max(PMax,abs(temp)) + PAO(nijkl,iPAO) = Fac*temp + end do + end do + end do + end do + end do + end do + do iSO=1,2 + nullify(Xki2(iSO)%A,Xki3(iSO)%A,Xli2(iSO)%A,Xli3(iSO)%A) + end do + ! * + !********************************************************************* + ! * +else if ((ExFac_ /= Zero) .and. (NumOrb(1) > 0) .and. (iMP2prpt == 2)) then + ! * + !********************************************************************* + ! * + ! MP2 case + + nKBas = kBas*iCmp(3) + nLBas = lBas*iCmp(4) + + kSO = iAOtSO(iAO(3)+1,kOp(3))+iAOst(3) + lSO = iAOtSO(iAO(4)+1,kOp(4))+iAOst(4) + + lda = size(CMOi(1)%SB(1)%A2,1) + ik = 1+lda*(kSO-1) + il = 1+lda*(lSO-1) + Xki(1:) => CMOi(1)%SB(1)%A1(ik:) + Xli(1:) => CMOi(1)%SB(1)%A1(il:) + + if ((nj(1) <= NumOrb(1)) .and. (jSkip(1) == 0)) then + imo = 1 + do k=1,nj(1) + kmo = Ymnij(1)%A(k) + call dcopy_(nKBas,Xki(kmo:),NumOrb(1),Yij(imo,1,1),nj(1)) + call dcopy_(nLBas,Xli(kmo:),NumOrb(1),Yij(imo,2,1),nj(1)) + imo = imo+1 + end do + Xki(1:nj(1)*nKBas) => Yij(1:nj(1)*nKBas,1,1) + Xli(1:nj(1)*nLBas) => Yij(1:nj(1)*nLBas,2,1) + else if (nj(1) > NumOrb(1)) then + call WarningMessage(2,'Pget1_RI3: nj > NumOrb.') + call Abend() + end if + + do i2=1,iCmp(2) + jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) + jSO_off = jSO-iOff1 + + lCVec = nIJR(kSym,lSym,1)*jBas + iAdr = nIJR(kSym,lSym,1)*(jSO_off-1)+iAdrCVec(jSym,kSym,1) + call dDaFile(LuCVector(jSym,1),2,CijK,lCVec,iAdr) + + if ((nj(1) <= NumOrb(1)) .and. (jSkip(1) == 0)) then + ij = 1 + do j=1,nj(1) + jmo = Ymnij(1)%A(j) + do i=1,nj(1) + imo = Ymnij(1)%A(i) + jC = imo+NumOrb(1)*(jmo-1) + call dcopy_(jBas,CijK(jC),NumOrb(1)**2,CilK(ij),nj(1)**2) + ij = ij+1 + end do + end do + n2j = nj(1)**2*jBas + CijK(1:n2j) = CilK(1:n2j) + end if + + ! C(jK,m) = sum_i C(i,jK)' * X(i,m) + + call dGEMM_('T','N',nj(1)*jBas,nKBas,nj(1),One,CijK,nj(1),Xki,nj(1),Zero,CilK,nj(1)*jBas) + + ! B(Km,n) = sum_j C(j,Km)' * X(j,n) + + call dGEMM_('T','N',jBas*nKBas,nLBas,nj(1),One,CilK,nj(1),Xli,nj(1),Zero,BklK,jBas*nKBas) + + lBVec = nBas(0)*nBas(0)*jBas + do i=1,2 + iAdr = 1+nBas(0)*nBas(0)*(jSO_off-1) + call dDaFile(LuBVector(i),2,Bmp2(:,i),lBVec,iAdr) + end do + + do i3=1,iCmp(3) + kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) + do i4=1,iCmp(4) + lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + + iPAO = iPAO+1 + nijkl = 0 + + do lAOl=0,lBas-1 + lSOl = lSO+lAOl + do kAOk=0,kBas-1 + kSOk = kSO+kAOk + + indexB = (kAOk+(i3-1)*kBas)*jBas+(lAOl+(i4-1)*lBas)*nKBas*jBas + Indkl = iTri(kSOk,lSOl) + + do jAOj=0,jBas-1 + jSOj = jSO+jAOj-iOff1 + nijkl = nijkl+1 + indexB = indexB+1 + + ! Coulomb contribution: V_k(j)*D(kl) + + temp = CoulFac*(V_k(jSOj,1)*DSO(Indkl,1)+U_k(jSOj)*DSO(Indkl,1)+V_k(jSOj,1)*(DSO_Var(Indkl)-DSO(indkl,1))+ & + Compute_B(irc,kSOk,lSOl,jAOj,iOff1,2)) + + ! Exchange contribution: B(K,m,n) + + temp = temp-ExFac_*Half*(BklK(indexB)+Compute_B(irc,kSOk,lSOl,jAOj,iOff1,1)) + !temp = temp-ExFac_*Half*Compute_B(irc,kSOk,lSOl,jAOj,iOff1,1) + + PMax = max(PMax,abs(temp)) + PAO(nijkl,iPAO) = Fac*temp + end do + end do + end do + end do + end do + end do + nullify(Xki,Xli) + ! * + !********************************************************************* + ! * +else + ! * + !********************************************************************* + ! * + ! Pure DFT or case when no exhange + + do i2=1,iCmp(2) + jSO = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) + do i3=1,iCmp(3) + kSO = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) + do i4=1,iCmp(4) + lSO = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + + iPAO = iPAO+1 + nijkl = 0 + + do lAOl=0,lBas-1 + lSOl = lSO+lAOl + do kAOk=0,kBas-1 + kSOk = kSO+kAOk + + Indkl = iTri(kSOk,lSOl) + + do jAOj=0,jBas-1 + jSOj = jSO+jAOj-iOff1 + nijkl = nijkl+1 + + ! Coulomb contribution: V_k(j)*D(kl) + + temp = CoulFac*V_k(jSOj,1)*DSO(Indkl,1) + !temp = Zero + + PMax = max(PMax,abs(temp)) + PAO(nijkl,iPAO) = Fac*temp + end do + end do + end do + end do + end do + end do + ! * + !********************************************************************* + ! * +end if +! * +!*********************************************************************** +! * + +if (iPAO /= nPAO) then + write(u6,*) ' Error in PGet1_RI3!' + call Abend() +end if +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +call RecPrt(' In PGet1_RI3:PAO ',' ',PAO,ijkl,nPAO) +do i=1,ijkl + write(u6,*) DDot_(nPAO,PAO(i,1),ijkl,PAO(i,1),ijkl) +end do +#endif +! * +!*********************************************************************** +! * +call CWTime(Cpu2,Wall2) +Cpu = Cpu2-Cpu1 +Wall = Wall2-Wall1 +tbvec(1) = tbvec(1)+Cpu +tbvec(2) = tbvec(2)+Wall + +return + +end subroutine PGet1_RI3 diff -Nru openmolcas-22.02/src/ri_util/pget2_cd2.f openmolcas-22.10/src/ri_util/pget2_cd2.f --- openmolcas-22.02/src/ri_util/pget2_cd2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/pget2_cd2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,196 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1992,2007, Roland Lindh * -************************************************************************ - SubRoutine PGet2_CD2(iCmp,iBas,jBas,kBas,lBas, - & Shijij, iAO, iAOst, nijkl,PSO,nPSO, - & ExFac,CoulFac,PMax,V_k,mV_k) -************************************************************************ -* Object: to assemble the 2nd order density matrix of a SCF wave * -* function from the 1st order density matrix. * -* * -* The indices has been scrambled before calling this routine. * -* Hence we must take special care in order to regain the can- * -* onical order. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -* January '92. * -* * -* Modified for Cholesky 1-center gradients May 2007 by * -* R. Lindh * -************************************************************************ - use Basis_Info, only: nBas - use SOAO_Info, only: iAOtSO - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - Real*8 PSO(nijkl,nPSO), V_K(mV_K) - Integer iCmp(4), iAO(4), iAOst(4) - Logical Shijij -* Local Array - Integer iSym(0:7), jSym(0:7), kSym(0:7), lSym(0:7) -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - Call RecPrt('V_K',' ',V_K,1,mV_K) -#endif -* * -************************************************************************ -* * - lOper=1 - PMax=Zero -* -*-----Quadruple loop over elements of the basis functions angular -* description. -* Observe that we will walk through the memory in AOInt in a -* sequential way. -* -C Fac = One/Four - Fac = One - MemSO2 = 0 - Do 100 i1 = 1, iCmp(1) - niSym = 0 - Do 101 j = 0, nIrrep-1 - If (iAOtSO(iAO(1)+i1,j)>0) Then - iSym(niSym) = j - niSym = niSym + 1 - End if -101 Continue - Do 200 i2 = 1, iCmp(2) - njSym = 0 - Do 201 j = 0, nIrrep-1 - If (iAOtSO(iAO(2)+i2,j)>0) Then - jSym(njSym) = j - njSym = njSym + 1 - End If -201 Continue - Do 300 i3 = 1, iCmp(3) - nkSym = 0 - Do 301 j = 0, nIrrep-1 - If (iAOtSO(iAO(3)+i3,j)>0) Then - kSym(nkSym) = j - nkSym = nkSym + 1 - End If -301 Continue - Do 400 i4 = 1, iCmp(4) - nlSym = 0 - Do 401 j = 0, nIrrep-1 - If (iAOtSO(iAO(4)+i4,j)>0) Then - lSym(nlSym) = j - nlSym = nlSym + 1 - End If -401 Continue -* -*------Loop over irreps which are spanned by the basis function. -* - Do 110 is = 0, niSym-1 - j1 = iSym(is) -* - Do 210 js = 0, njSym-1 - j2 = jSym(js) - j12 = iEor(j1,j2) -* - Do 310 ks = 0, nkSym-1 - j3 = kSym(ks) - j123 = iEor(j12,j3) - Do 410 ls = 0, nlSym-1 - j4 = lSym(ls) - If (j123.ne.j4) Go To 410 -* - MemSO2 = MemSO2 + 1 -* -* Unfold the way the eight indicies have been reordered. - iSO = iAOtSO(iAO(1)+i1,j1)+iAOst(1) - jSO = iAOtSO(iAO(2)+i2,j2)+iAOst(2) - kSO = iAOtSO(iAO(3)+i3,j3)+iAOst(3) - lSO = iAOtSO(iAO(4)+i4,j4)+iAOst(4) -* - If (j1.ne.j2 .and. j1.ne.j3 .and. j1.ne.j4) Then -*------------------all irreps are different and the 2nd order density -* matrix will be identical to zero for a SCF type wave -* function. - call dcopy_(nijkl,[Zero],0,PSO(1,MemSO2),1) - Go To 310 - End If -* - mijkl = 0 - Do 120 lAOl = 0, lBas-1 - lSOl = lSO + lAOl - Do 220 kAOk = 0, kBas-1 - kSOk = kSO + kAOk - Do 320 jAOj = 0, jBas-1 - jSOj = jSO + jAOj - Do 420 iAOi = 0, iBas-1 - iSOi = iSO + iAOi - mijkl = mijkl + 1 -* -*---------------------------Contribution V_k(ij)*V_k(kl) to P(ijkl) - If (j1.eq.j2) Then -*------------------------------j3.eq.j4 also - Indi=Max(iSOi,jSOj) - Indj=iSOi+jSOj-Indi - Indk=Max(kSOk,lSOl) - Indl=kSOk+lSOl-Indk - iPntij=iPntSO(j1,j2,lOper,nbas) - iPntkl=iPntSO(j3,j4,lOper,nbas) - Indij=iPntij+(Indi-1)*Indi/2+Indj - Indkl=iPntkl+(Indk-1)*Indk/2+Indl - temp=V_k(Indij)*V_k(Indkl)*Coulfac - Else - temp = Zero - End If -* -*---------------------------Contribution -1/4*D(ik)*D(jl) to P(ijkl) -C If (j1.eq.j3) Then -*------------------------------j2.eq.j4 also -C End If -* -*---------------------------Contribution -1/4*D(il)*D(jk) to P(ijkl) -C If (j1.eq.j4) Then -*------------------------------j2.eq.j3 also -C End If -* - PMax=Max(PMax,Abs(Temp)) - PSO(mijkl,MemSO2) = Fac * temp -* - 420 Continue - 320 Continue - 220 Continue - 120 Continue -* - 410 Continue - 310 Continue - 210 Continue - 110 Continue -* -* - 400 Continue - 300 Continue - 200 Continue - 100 Continue - If (nPSO.ne.MemSO2) Then - Write (6,*) ' PGet2_CD2: nPSO.ne.MemSO2' - Write (6,*) nPSO, MemSO2 - Call Abend - End If -* -#ifdef _DEBUGPRINT_ - Call RecPrt(' In PGet2_CD2:PSO ',' ',PSO,nijkl,nPSO) -#endif - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_logical(Shijij) - Call Unused_real(ExFac) - End If - End diff -Nru openmolcas-22.02/src/ri_util/pget2_cd2.F90 openmolcas-22.10/src/ri_util/pget2_cd2.F90 --- openmolcas-22.02/src/ri_util/pget2_cd2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/pget2_cd2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,193 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1992,2007, Roland Lindh * +!*********************************************************************** + +subroutine PGet2_CD2(iCmp,iBas,jBas,kBas,lBas,iAO,iAOst,nijkl,PSO,nPSO,CoulFac,PMax,V_k,mV_k) +!*********************************************************************** +! Object: to assemble the 2nd order density matrix of a SCF wave * +! function from the 1st order density matrix. * +! * +! The indices have been scrambled before calling this routine.* +! Hence we must take special care in order to regain the * +! canonical order. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +! January '92. * +! * +! Modified for Cholesky 1-center gradients May 2007 by * +! R. Lindh * +!*********************************************************************** + +use Index_Functions, only: iTri +use Basis_Info, only: nBas +use SOAO_Info, only: iAOtSO +use Symmetry_Info, only: Mul, nIrrep +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iCmp(4), iBas, jBas, kBas, lBas, iAO(4), iAOst(4), nijkl, nPSO, mV_k +real(kind=wp), intent(out) :: PSO(nijkl,nPSO), PMax +real(kind=wp), intent(in) :: CoulFac, V_K(mV_K) +integer(kind=iwp) :: i1, i2, i3, i4, iAOi, Indij, Indkl, iPntij, iPntkl, is, iSO, iSOi, iSym(0:7), j, j1, j12, j123, j2, j3, j4, & + jAOj, js, jSO, jSOj, jSym(0:7), kAOk, ks, kSO, kSOk, kSym(0:7), lAOl, lOper, ls, lSO, lSOl, lSym(0:7), & + MemSO2, mijkl, niSym, njSym, nkSym, nlSym +real(kind=wp) :: Fac, temp +integer(kind=iwp), external :: iPntSO + +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +call RecPrt('V_K',' ',V_K,1,mV_K) +#endif +! * +!*********************************************************************** +! * +lOper = 1 +PMax = Zero + +! Quadruple loop over elements of the basis functions angular description. +! Observe that we will walk through the memory in AOInt in a sequential way. + +!Fac = Quart +Fac = One +MemSO2 = 0 +do i1=1,iCmp(1) + niSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(1)+i1,j) > 0) then + iSym(niSym) = j + niSym = niSym+1 + end if + end do + do i2=1,iCmp(2) + njSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(2)+i2,j) > 0) then + jSym(njSym) = j + njSym = njSym+1 + end if + end do + do i3=1,iCmp(3) + nkSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(3)+i3,j) > 0) then + kSym(nkSym) = j + nkSym = nkSym+1 + end if + end do + do i4=1,iCmp(4) + nlSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(4)+i4,j) > 0) then + lSym(nlSym) = j + nlSym = nlSym+1 + end if + end do + + ! Loop over irreps which are spanned by the basis function. + + do is=0,niSym-1 + j1 = iSym(is) + + do js=0,njSym-1 + j2 = jSym(js) + j12 = Mul(j1+1,j2+1)-1 + + do ks=0,nkSym-1 + j3 = kSym(ks) + j123 = Mul(j12+1,j3+1)-1 + do ls=0,nlSym-1 + j4 = lSym(ls) + if (j123 /= j4) cycle + + MemSO2 = MemSO2+1 + + ! Unfold the way the eight indicies have been reordered. + iSO = iAOtSO(iAO(1)+i1,j1)+iAOst(1) + jSO = iAOtSO(iAO(2)+i2,j2)+iAOst(2) + kSO = iAOtSO(iAO(3)+i3,j3)+iAOst(3) + lSO = iAOtSO(iAO(4)+i4,j4)+iAOst(4) + + if ((j1 /= j2) .and. (j1 /= j3) .and. (j1 /= j4)) then + ! all irreps are different and the 2nd order density + ! matrix will be identical to zero for a SCF type wave + ! function. + PSO(:,MemSO2) = Zero + exit + end if + + mijkl = 0 + do lAOl=0,lBas-1 + lSOl = lSO+lAOl + do kAOk=0,kBas-1 + kSOk = kSO+kAOk + do jAOj=0,jBas-1 + jSOj = jSO+jAOj + do iAOi=0,iBas-1 + iSOi = iSO+iAOi + mijkl = mijkl+1 + + ! Contribution V_k(ij)*V_k(kl) to P(ijkl) + if (j1 == j2) then + ! j3 == j4 also + iPntij = iPntSO(j1,j2,lOper,nbas) + iPntkl = iPntSO(j3,j4,lOper,nbas) + Indij = iPntij+iTri(iSOi,jSOj) + Indkl = iPntkl+iTri(kSOk,lSOl) + temp = V_k(Indij)*V_k(Indkl)*CoulFac + else + temp = Zero + end if + + ! Contribution -1/4*D(ik)*D(jl) to P(ijkl) + !if (j1 == 3) then + ! ! j2 == 4 also + !end if + + ! Contribution -1/4*D(il)*D(jk) to P(ijkl) + !if (j1 == 4) then + ! ! j2 == 3 also + !end if + + PMax = max(PMax,abs(Temp)) + PSO(mijkl,MemSO2) = Fac*temp + + end do + end do + end do + end do + + end do + end do + end do + end do + + end do + end do + end do +end do +if (nPSO /= MemSO2) then + write(u6,*) ' PGet2_CD2: nPSO /= MemSO2' + write(u6,*) nPSO,MemSO2 + call Abend() +end if + +#ifdef _DEBUGPRINT_ +call RecPrt(' In PGet2_CD2:PSO ',' ',PSO,nijkl,nPSO) +#endif + +return + +end subroutine PGet2_CD2 diff -Nru openmolcas-22.02/src/ri_util/pget2_cd3.f openmolcas-22.10/src/ri_util/pget2_cd3.f --- openmolcas-22.02/src/ri_util/pget2_cd3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/pget2_cd3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,199 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1992,2007, Roland Lindh * -************************************************************************ - SubRoutine PGet2_CD3(iCmp,iBas,jBas,kBas,lBas, - & Shijij, iAO, iAOst, nijkl,PSO,nPSO, - & DSO,DSSO,nDSO,ExFac,CoulFac,PMax,V_k,mV_k) -************************************************************************ -* Object: to assemble the 2nd order density matrix of a SCF wave * -* function from the 1st order density matrix. * -* * -* The indices has been scrambled before calling this routine. * -* Hence we must take special care in order to regain the can- * -* onical order. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -* January '92. * -* * -* Modified for Cholesky 1-center gradients May 2007 by * -* R. Lindh * -************************************************************************ - use Basis_Info, only: nBas - use SOAO_Info, only: iAOtSO - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - Real*8 PSO(nijkl,nPSO), DSO(nDSO), DSSO(nDSO), V_k(mV_k) - Integer iCmp(4), iAO(4), iAOst(4) - Logical Shijij -* Local Array - Integer iSym(0:7), jSym(0:7), kSym(0:7), lSym(0:7) -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - iComp = 1 - Call PrMtrx(' In PGet2_CD3:DSO ',[iD0Lbl],iComp,1,D0) - Call RecPrt('V_K',' ',V_K,1,mV_K) -#endif -* * -************************************************************************ -* * -C Fac = One / Four - Fac = One / Two - lOper=1 - PMax=Zero -* -*-----Quadruple loop over elements of the basis functions angular -* description. -* Observe that we will walk through the memory in AOInt in a -* sequential way. -* - MemSO2 = 0 - Do 100 i1 = 1, iCmp(1) - niSym = 0 - Do 101 j = 0, nIrrep-1 - If (iAOtSO(iAO(1)+i1,j)>0) Then - iSym(niSym) = j - niSym = niSym + 1 - End if -101 Continue - Do 200 i2 = 1, iCmp(2) - njSym = 0 - Do 201 j = 0, nIrrep-1 - If (iAOtSO(iAO(2)+i2,j)>0) Then - jSym(njSym) = j - njSym = njSym + 1 - End If -201 Continue - Do 300 i3 = 1, iCmp(3) - nkSym = 0 - Do 301 j = 0, nIrrep-1 - If (iAOtSO(iAO(3)+i3,j)>0) Then - kSym(nkSym) = j - nkSym = nkSym + 1 - End If -301 Continue - Do 400 i4 = 1, iCmp(4) - nlSym = 0 - Do 401 j = 0, nIrrep-1 - If (iAOtSO(iAO(4)+i4,j)>0) Then - lSym(nlSym) = j - nlSym = nlSym + 1 - End If -401 Continue -* -*------Loop over irreps which are spanned by the basis function. -* - Do 110 is = 0, niSym-1 - j1 = iSym(is) -* - Do 210 js = 0, njSym-1 - j2 = jSym(js) - j12 = iEor(j1,j2) -* - Do 310 ks = 0, nkSym-1 - j3 = kSym(ks) - j123 = iEor(j12,j3) - Do 410 ls = 0, nlSym-1 - j4 = lSym(ls) - If (j123.ne.j4) Go To 410 -* - MemSO2 = MemSO2 + 1 -* -* Unfold the way the eight indicies have been reordered. - iSO = iAOtSO(iAO(1)+i1,j1)+iAOst(1) - jSO = iAOtSO(iAO(2)+i2,j2)+iAOst(2) - kSO = iAOtSO(iAO(3)+i3,j3)+iAOst(3) - lSO = iAOtSO(iAO(4)+i4,j4)+iAOst(4) -* - If (j1.ne.j2 .and. j1.ne.j3 .and. j1.ne.j4) Then -*------------------all irreps are different and the 2nd order density -* matrix will be identical to zero for a SCF type wave -* function. - call dcopy_(nijkl,[Zero],0,PSO(1,MemSO2),1) - Go To 310 - End If -* - mijkl = 0 - Do 120 lAOl = 0, lBas-1 - lSOl = lSO + lAOl - Do 220 kAOk = 0, kBas-1 - kSOk = kSO + kAOk - Do 320 jAOj = 0, jBas-1 - jSOj = jSO + jAOj - Do 420 iAOi = 0, iBas-1 - iSOi = iSO + iAOi - mijkl = mijkl + 1 -* -*---------------------------Contribution V_k(ij)*D(kl) to P(ijkl) - If (j1.eq.j2) Then -*------------------------------j3.eq.j4 also - Indi=Max(iSOi,jSOj) - Indj=iSOi+jSOj-Indi - Indk=Max(kSOk,lSOl) - Indl=kSOk+lSOl-Indk - iPntij=iPntSO(j1,j2,lOper,nbas) - iPntkl=iPntSO(j3,j4,lOper,nbas) - Indij=iPntij+(Indi-1)*Indi/2+Indj - Indkl=iPntkl+(Indk-1)*Indk/2+Indl - temp=V_k(Indij)*DSO(Indkl)*Coulfac - Else - temp = Zero - End If -* -*---------------------------Contribution -1/4*D(ik)*D(jl) to P(ijkl) -C If (j1.eq.j3) Then -*------------------------------j2.eq.j4 also -C End If -* -*---------------------------Contribution -1/4*D(il)*D(jk) to P(ijkl) -C If (j1.eq.j4) Then -*------------------------------j2.eq.j3 also -C End If -* - PMax=Max(PMax,Abs(Temp)) - PSO(mijkl,MemSO2) = Fac * temp -* - 420 Continue - 320 Continue - 220 Continue - 120 Continue -* - 410 Continue - 310 Continue - 210 Continue - 110 Continue -* -* - 400 Continue - 300 Continue - 200 Continue - 100 Continue - If (nPSO.ne.MemSO2) Then - Write (6,*) ' PGet2_CD3: nPSO.ne.MemSO2' - Write (6,*) nPSO, MemSO2 - Call Abend - End If -* -#ifdef _DEBUGPRINT_ - Call RecPrt(' In PGet2_CD3:PSO ',' ',PSO,nijkl,nPSO) -#endif - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_logical(Shijij) - Call Unused_real_array(DSSO) - Call Unused_real(ExFac) - End If - End diff -Nru openmolcas-22.02/src/ri_util/pget2_cd3.F90 openmolcas-22.10/src/ri_util/pget2_cd3.F90 --- openmolcas-22.02/src/ri_util/pget2_cd3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/pget2_cd3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,195 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1992,2007, Roland Lindh * +!*********************************************************************** + +subroutine PGet2_CD3(iCmp,iBas,jBas,kBas,lBas,iAO,iAOst,nijkl,PSO,nPSO,DSO,nDSO,CoulFac,PMax,V_k,mV_k) +!*********************************************************************** +! Object: to assemble the 2nd order density matrix of a SCF wave * +! function from the 1st order density matrix. * +! * +! The indices have been scrambled before calling this routine.* +! Hence we must take special care in order to regain the * +! canonical order. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +! January '92. * +! * +! Modified for Cholesky 1-center gradients May 2007 by * +! R. Lindh * +!*********************************************************************** + +use Index_Functions, only: iTri +use Basis_Info, only: nBas +use SOAO_Info, only: iAOtSO +use Symmetry_Info, only: Mul, nIrrep +use Constants, only: Zero, Half +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iCmp(4), iBas, jBas, kBas, lBas, iAO(4), iAOst(4), nijkl, nPSO, nDSO, mV_k +real(kind=wp), intent(out) :: PSO(nijkl,nPSO), PMax +real(kind=wp), intent(in) :: DSO(nDSO), CoulFac, V_k(mV_k) +integer(kind=iwp) :: i1, i2, i3, i4, iAOi, Indij, Indkl, iPntij, iPntkl, is, iSO, iSOi, iSym(0:7), j, j1, j12, j123, j2, j3, j4, & + jAOj, js, jSO, jSOj, jSym(0:7), kAOk, ks, kSO, kSOk, kSym(0:7), lAOl, lOper, ls, lSO, lSOl, lSym(0:7), & + MemSO2, mijkl, niSym, njSym, nkSym, nlSym +real(kind=wp) :: Fac, temp +integer(kind=iwp), external :: iPntSO + +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +iComp = 1 +call PrMtrx(' In PGet2_CD3:DSO ',[iD0Lbl],iComp,1,D0) +call RecPrt('V_K',' ',V_K,1,mV_K) +#endif +! * +!*********************************************************************** +! * +!Fac = Quart +Fac = Half +lOper = 1 +PMax = Zero + +! Quadruple loop over elements of the basis functions angular description. +! Observe that we will walk through the memory in AOInt in a sequential way. + +MemSO2 = 0 +do i1=1,iCmp(1) + niSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(1)+i1,j) > 0) then + iSym(niSym) = j + niSym = niSym+1 + end if + end do + do i2=1,iCmp(2) + njSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(2)+i2,j) > 0) then + jSym(njSym) = j + njSym = njSym+1 + end if + end do + do i3=1,iCmp(3) + nkSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(3)+i3,j) > 0) then + kSym(nkSym) = j + nkSym = nkSym+1 + end if + end do + do i4=1,iCmp(4) + nlSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(4)+i4,j) > 0) then + lSym(nlSym) = j + nlSym = nlSym+1 + end if + end do + + ! Loop over irreps which are spanned by the basis function. + + do is=0,niSym-1 + j1 = iSym(is) + + do js=0,njSym-1 + j2 = jSym(js) + j12 = Mul(j1+1,j2+1)-1 + + do ks=0,nkSym-1 + j3 = kSym(ks) + j123 = Mul(j12+1,j3+1)-1 + do ls=0,nlSym-1 + j4 = lSym(ls) + if (j123 /= j4) cycle + + MemSO2 = MemSO2+1 + + ! Unfold the way the eight indicies have been reordered. + iSO = iAOtSO(iAO(1)+i1,j1)+iAOst(1) + jSO = iAOtSO(iAO(2)+i2,j2)+iAOst(2) + kSO = iAOtSO(iAO(3)+i3,j3)+iAOst(3) + lSO = iAOtSO(iAO(4)+i4,j4)+iAOst(4) + + if ((j1 /= j2) .and. (j1 /= j3) .and. (j1 /= j4)) then + ! all irreps are different and the 2nd order density + ! matrix will be identical to zero for a SCF type wave + ! function. + PSO(:,MemSO2) = Zero + exit + end if + + mijkl = 0 + do lAOl=0,lBas-1 + lSOl = lSO+lAOl + do kAOk=0,kBas-1 + kSOk = kSO+kAOk + do jAOj=0,jBas-1 + jSOj = jSO+jAOj + do iAOi=0,iBas-1 + iSOi = iSO+iAOi + mijkl = mijkl+1 + + ! Contribution V_k(ij)*D(kl) to P(ijkl) + if (j1 == j2) then + ! j3 == j4 also + iPntij = iPntSO(j1,j2,lOper,nbas) + iPntkl = iPntSO(j3,j4,lOper,nbas) + Indij = iPntij+iTri(iSOi,jSOj) + Indkl = iPntkl+iTri(kSOk,lSOl) + temp = V_k(Indij)*DSO(Indkl)*CoulFac + else + temp = Zero + end if + + ! Contribution -1/4*D(ik)*D(jl) to P(ijkl) + !if (j1 == j3) then + ! ! j2 == j4 also + !end if + + ! Contribution -1/4*D(il)*D(jk) to P(ijkl) + !if (j1 == j4) then + ! ! j2 == j3 also + !end if + + PMax = max(PMax,abs(Temp)) + PSO(mijkl,MemSO2) = Fac*temp + + end do + end do + end do + end do + + end do + end do + end do + end do + + end do + end do + end do +end do +if (nPSO /= MemSO2) then + write(u6,*) ' PGet2_CD3: nPSO /= MemSO2' + write(u6,*) nPSO,MemSO2 + call Abend() +end if + +#ifdef _DEBUGPRINT_ +call RecPrt(' In PGet2_CD3:PSO ',' ',PSO,nijkl,nPSO) +#endif + +return + +end subroutine PGet2_CD3 diff -Nru openmolcas-22.02/src/ri_util/pget2_ri2.f openmolcas-22.10/src/ri_util/pget2_ri2.f --- openmolcas-22.02/src/ri_util/pget2_ri2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/pget2_ri2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,668 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1992,2007, Roland Lindh * -************************************************************************ - SubRoutine PGet2_RI2(iCmp,iBas,jBas,kBas,lBas, - & Shijij, iAO, iAOst, nijkl,PSO,nPSO, - & ExFac,CoulFac,PMax,V_K,mV_K,Z_p_K,nSA, - & nZ_p_k) -************************************************************************ -* Object: to assemble the 2nd order density matrix of a SCF wave * -* function from the 1st order density matrix. * -* * -* The indices has been scrambled before calling this routine. * -* Hence we must take special care in order to regain the can- * -* onical order. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -* January '92. * -* * -* Modified to RI-DFT, March 2007 * -************************************************************************ - use Basis_Info, only: nBas, nBas_Aux - use SOAO_Info, only: iAOtSO - use pso_stuff, only: nnp, lPSO, lsa, DMdiag - use Symmetry_Info, only: nIrrep - use ExTerm, only: CijK, iMP2prpt, A - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "exterm.fh" - Real*8 PSO(nijkl,nPSO), V_K(mV_K,nSA),Z_p_K(nZ_p_k,*) - Integer iCmp(4), iAO(4), iAOst(4) - Logical Shijij, Found -* Local Array - Integer jSym(0:7), lSym(0:7) - Integer CumnnP(0:7),CumnnP2(0:7) - - Real*8, Pointer :: CiKj(:)=>Null(), CiKl(:)=>Null(), - & V2(:)=>Null() -* * -************************************************************************ -* * -*#define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Call RecPrt('V_K',' ',V_K,1,mV_K) -#endif - - Call CWTime(Cpu1,Wall1) -* * -************************************************************************ -* * - PMax=Zero - iSO=1 -* - Call FZero(PSO,nijkl*nPSO) -* - If (lPSO) Then - CumnnP(0)=0 - CumnnP2(0)=0 - Do i=1,nIrrep-1 - nB = nBas_Aux(i-1) - If (i.eq.1) nB = nB-1 - CumnnP(i)=CumnnP(i-1)+nnP(i-1) - CumnnP2(i)=CumnnP2(i-1)+nnP(i-1)*nB - End Do - End If -* - Call Qpg_iScalar('SCF mode',Found) - If (Found) Then - Call Get_iScalar('SCF mode',iUHF) ! either 0 or 1 - Else - iUHF=0 - EndIf - -* * -************************************************************************ -* * - Fac = One/Four - MemSO2 = 0 -* * -************************************************************************ -* * -* Pure DFT -* - If (ExFac.eq.Zero) Then -* * -************************************************************************ -* * - Do i2 = 1, iCmp(2) - njSym = 0 - Do j = 0, nIrrep-1 - If (iAOtSO(iAO(2)+i2,j)>0) Then - jSym(njSym) = j - njSym = njSym + 1 - End If - End Do -* - Do i4 = 1, iCmp(4) - nlSym = 0 - Do j = 0, nIrrep-1 - If (iAOtSO(iAO(4)+i4,j)>0) Then - lSym(nlSym) = j - nlSym = nlSym + 1 - End If - End Do -* * -************************************************************************ -* * -* Loop over irreps which are spanned by the basis function. -* - Do js = 0, njSym-1 - j2 = jSym(js) - jSO = iAOtSO(iAO(2)+i2,j2)+iAOst(2) -* - Do ls = 0, nlSym-1 - j4 = lSym(ls) - If (j2/=j4) Cycle - lSO = iAOtSO(iAO(4)+i4,j4)+iAOst(4) -* - MemSO2 = MemSO2 + 1 - If (j2/=0) Cycle -* - mijkl = 0 - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - nBas(j4) - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - nBas(j2) - mijkl = mijkl + 1 -* -*-----------------------Coulomb contribution - If (j2.eq.0) Then -*---------------------------j4.eq.0 also - temp=V_K(jSOj,1)*V_K(lSOl,1)*Coulfac -* temp=Zero - Else - temp = Zero - End If -* - PMax=Max(PMax,Abs(Temp)) - PSO(mijkl,MemSO2) = Fac * temp -* - End Do - End Do -* - End Do - End Do -* - End Do - End Do -* * -************************************************************************ -* * -* Hybrid DFT and HF -* - Else If (iMP2prpt .ne. 2 .and. .Not.lPSO .and. iUHF.eq.0 ) Then -* * -************************************************************************ -* * - Do i2 = 1, iCmp(2) - njSym = 0 - Do j = 0, nIrrep-1 - If (iAOtSO(iAO(2)+i2,j)>0) Then - jSym(njSym) = j - njSym = njSym + 1 - End If - End Do -* - Do i4 = 1, iCmp(4) - nlSym = 0 - Do j = 0, nIrrep-1 - If (iAOtSO(iAO(4)+i4,j)>0) Then - lSym(nlSym) = j - nlSym = nlSym + 1 - End If - End Do -* * -************************************************************************ -* * -* Loop over irreps which are spanned by the basis function. -* - Do js = 0, njSym-1 - j2 = jSym(js) - jSO = iAOtSO(iAO(2)+i2,j2)+iAOst(2) -* - Do ls = 0, nlSym-1 - j4 = lSym(ls) - If (j2/=j4) Cycle - lSO = iAOtSO(iAO(4)+i4,j4)+iAOst(4) -* - MemSO2 = MemSO2 + 1 -* - A(1:jBas*lBas)=Zero -* - Do iSym = 1, nIrrep - kSym = iEor(j2,iSym-1)+1 - nik = nIJ1(iSym,kSym,iSO) -* - If (nik==0) Cycle -* - iS = 1 - iE = nik*jBas - CiKj(1:nik*jBas) => CijK(iS:iE) - - - jSOj= jSO-nBas(j2) - iAdrJ = nik*(jSOj-1)+iAdrCVec(j2+1,iSym,iSO) - Call dDaFile(LuCVector(j2+1,iSO),2,CikJ,nik*jBas, - & iAdrJ) -* - If (lSO.ne.jSO) Then - iS = iE + 1 - iE = iE + nik*lBas - CiKl(1:nik*lBas) => CijK(iS:iE) - - lSOl=lSO-nBas(j4) - iAdrL = nik*(lSOl-1)+iAdrCVec(j4+1,iSym,iSO) - Call dDaFile(LuCVector(j4+1,iSO),2,CiKl, - & nik*lBas,iAdrL) - V2(1:) => CiKl(1:) - Else - V2(1:) => CiKj(1:) - End If -* - Fact=One - If (iSym.ne.kSym) Fact=Half - Call DGEMM_('T','N',jBas,lBas,nik, - & Fact,CikJ,nik, - & V2,nik, - & 1.0D0,A,jBas) -* - End Do - - mijkl = 0 - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - nBas(j4) - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - nBas(j2) - mijkl = mijkl + 1 -* -*-----------------------Coulomb contribution - If (j2.eq.0) Then -*---------------------------j4.eq.0 also - temp=V_K(jSOj,1)*V_K(lSOl,1)*Coulfac -* temp=Zero - Else - temp = Zero - End If -* -*-----------------------Exchange contribution - temp = temp - ExFac*A(mijkl) -* - PMax=Max(PMax,Abs(Temp)) - PSO(mijkl,MemSO2) = Fac * temp -* - End Do - End Do -* - End Do - End Do -* - End Do - End Do -* * -************************************************************************ -* * -* Hybrid UDFT and UHF -* - Else If (iMP2prpt .ne. 2 .and. .Not.lPSO .and. iUHF.eq.1 ) Then -* - Write (6,*) 'Pget2_RI2: UDFT/UHF not implemented yet.' - Call Abend() -* * -************************************************************************ -* * -* CASSCF -* - Else If (iMP2prpt .ne. 2 .and. lPSO .and. .Not. LSA) Then -* * -************************************************************************ -* * - Do i2 = 1, iCmp(2) - njSym = 0 - Do j = 0, nIrrep-1 - If (iAOtSO(iAO(2)+i2,j)>0) Then - jSym(njSym) = j - njSym = njSym + 1 - End If - End Do -* - Do i4 = 1, iCmp(4) - nlSym = 0 - Do j = 0, nIrrep-1 - If (iAOtSO(iAO(4)+i4,j)>0) Then - lSym(nlSym) = j - nlSym = nlSym + 1 - End If - End Do -* * -************************************************************************ -* * -* Loop over irreps which are spanned by the basis function. -* - Do js = 0, njSym-1 - j2 = jSym(js) - jSO = iAOtSO(iAO(2)+i2,j2)+iAOst(2) -* - Do ls = 0, nlSym-1 - j4 = lSym(ls) - If (j2/=j4) Cycle - lSO = iAOtSO(iAO(4)+i4,j4)+iAOst(4) -* - MemSO2 = MemSO2 + 1 -* - A(1:jBas*lBas)=Zero -* - Do iSym = 1, nIrrep - kSym = iEor(j2,iSym-1)+1 - nik = nIJ1(iSym,kSym,iSO) -* - If (nik==0) Cycle - - iS = 1 - iE = nik*jBas - CiKj(1:nik*jBas) => CijK(iS:iE) -* - jSOj= jSO-nBas(j2) - iAdrJ = nik*(jSOj-1)+iAdrCVec(j2+1,iSym,iSO) - Call dDaFile(LuCVector(j2+1,iSO),2,CiKj,nik*jBas, - & iAdrJ) -* - If (lSO.ne.jSO) Then - iS = iE + 1 - iE = iE + nik*lBas - CiKl(1:nik*lBas) => CijK(iS:iE) - - lSOl=lSO-nBas(j4) - iAdrL = nik*(lSOl-1)+iAdrCVec(j4+1,iSym,iSO) - Call dDaFile(LuCVector(j4+1,iSO),2,CiKl, - & nik*lBas,iAdrL) - V2(1:) => CiKl(1:) - Else - V2(1:) => CiKj(1:) - End If -* - Fact=One - If (iSym.ne.kSym) Fact=Half - Call DGEMM_('T','N',jBas,lBas,nik, - & Fact,CikJ,nik, - & V2,nik, - & 1.0D0,A,jBas) -* - End Do -* - mijkl = 0 - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - nBas(j4) - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - nBas(j2) - mijkl = mijkl + 1 -* -*-----------------------Coulomb contribution - If (j2.eq.0) Then -*---------------------------j4.eq.0 also - temp=V_K(jSOj,1)*V_K(lSOl,1)*Coulfac -* temp=Zero - Else - temp = Zero - End If -* -*-----------------------Exchange contribution - temp = temp - ExFac*A(mijkl) -* - temp2=0.0d0 - jpSOj=CumnnP2(j2)+(jSOj-1)*nnP(j2) - jpSOl=CumnnP2(j2)+(lSOl-1)*nnP(j2) - Do jp=1,nnP(j2) - temp2=temp2+sign(1.0d0, - & DMdiag(CumnnP(j2)+jp,1))* - & Z_p_K(jpSOj+jp,1)*Z_p_K(jpSOl+jp,1) - End Do - temp=temp+temp2 -* - PMax=Max(PMax,Abs(Temp)) - PSO(mijkl,MemSO2) = Fac * temp -* - End Do - End Do -* - End Do - End Do -* - End Do - End Do -* * -************************************************************************ -* * -* SA-CASSCF -* - Else If ( iMP2prpt .ne. 2 .and. lPSO .and. lSA ) Then -* * -************************************************************************ -* * - Write (6,*) 'Pget2_ri2: SA-CASSCF not implemented yet' - Call Abend() -* - Do i2 = 1, iCmp(2) - njSym = 0 - Do j = 0, nIrrep-1 - If (iAOtSO(iAO(2)+i2,j)>0) Then - jSym(njSym) = j - njSym = njSym + 1 - End If - End Do -* - Do i4 = 1, iCmp(4) - nlSym = 0 - Do j = 0, nIrrep-1 - If (iAOtSO(iAO(4)+i4,j)>0) Then - lSym(nlSym) = j - nlSym = nlSym + 1 - End If - End Do -* * -************************************************************************ -* * -* Loop over irreps which are spanned by the basis function. -* - Do js = 0, njSym-1 - j2 = jSym(js) - jSO = iAOtSO(iAO(2)+i2,j2)+iAOst(2) -* - Do ls = 0, nlSym-1 - j4 = lSym(ls) - If (j2/=j4) Cycle - lSO = iAOtSO(iAO(4)+i4,j4)+iAOst(4) -* - MemSO2 = MemSO2 + 1 -* - A(1:jBas*lBas) = Zero -* - Do iSym = 1, nIrrep - kSym = iEor(j2,iSym-1)+1 - nik = nIJ1(iSym,kSym,iSO) -* - If (nik==0) Cycle - - iS = 1 - iE = nik*jBas - CiKj(1:nik*jBas) => CijK(iS:iE) -* - jSOj= jSO-nBas(j2) - iAdrJ = nik*(jSOj-1)+iAdrCVec(j2+1,iSym,iSO) - Call dDaFile(LuCVector(j2+1,iSO),2,CiKj,nik*jBas, - & iAdrJ) -* - If (lSO.ne.jSO) Then - iS = iE + 1 - iE = iE + nik*lBas - CiKl(1:nik*lBas) => CijK(iS:iE) - - lSOl=lSO-nBas(j4) - iAdrL = nik*(lSOl-1)+iAdrCVec(j4+1,iSym,iSO) - Call dDaFile(LuCVector(j4+1,iSO),2,CiKl, - & nik*lBas,iAdrL) - V2(1:) => CiKl(1:) - Else - V2(1:) => CiKj(1:) - End If -* - Fact=One - If (iSym.ne.kSym) Fact=Half - Call DGEMM_('T','N',jBas,lBas,nik, - & Fact,CiKJ,nik, - & V2,nik, - & 1.0D0,A,jBas) -* - End Do - - mijkl = 0 - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - nBas(j4) - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - nBas(j2) - mijkl = mijkl + 1 -* -*-----------------------Coulomb contribution - If (j2.eq.0) Then -*---------------------------j4.eq.0 also - temp=CoulFac*(V_K(lSOl,1)*V_K(jSOj,2)+ - & V_K(lSOl,2)*V_K(jSOj,1)+ - & V_K(lSOl,3)*V_K(jSOj,4)+ - & V_K(lSOl,4)*V_K(jSOj,3)) -* temp=Zero - Else - temp = Zero - End If -* -*-----------------------Exchange contribution - temp = temp - ExFac*A(mijkl) -* - PMax=Max(PMax,Abs(Temp)) - PSO(mijkl,MemSO2) = Fac * temp -* - End Do - End Do -* - End Do - End Do -* - End Do - End Do -* * -************************************************************************ -* * -* MP2 -* - Else -* * -************************************************************************ -* * - Write (6,*) 'Pget2_ri2: MP2 not implemented yet' - Call Abend() -* - Do i2 = 1, iCmp(2) - njSym = 0 - Do j = 0, nIrrep-1 - If (iAOtSO(iAO(2)+i2,j)>0) Then - jSym(njSym) = j - njSym = njSym + 1 - End If - End Do -* - Do i4 = 1, iCmp(4) - nlSym = 0 - Do j = 0, nIrrep-1 - If (iAOtSO(iAO(4)+i4,j)>0) Then - lSym(nlSym) = j - nlSym = nlSym + 1 - End If - End Do -* * -************************************************************************ -* * -* Loop over irreps which are spanned by the basis function. -* - Do js = 0, njSym-1 - j2 = jSym(js) - jSO = iAOtSO(iAO(2)+i2,j2)+iAOst(2) -* - Do ls = 0, nlSym-1 - j4 = lSym(ls) - If (j2/=j4) Cycle - lSO = iAOtSO(iAO(4)+i4,j4)+iAOst(4) -* - MemSO2 = MemSO2 + 1 -* - A(1:jBas*lBas) = Zero -* - Do iSym = 1, nIrrep - kSym = iEor(j2,iSym-1)+1 - nik = nIJ1(iSym,kSym,iSO) -* - If (nik==0) Cycle - - iS = 1 - iE = nik*jBas - CiKj(1:nik*jBas) => CijK(iS:iE) -* - jSOj= jSO-nBas(j2) - iAdrJ = nik*(jSOj-1)+iAdrCVec(j2+1,iSym,iSO) - Call dDaFile(LuCVector(j2+1,iSO),2,CiKj,nik*jBas, - & iAdrJ) -* - If (lSO.ne.jSO) Then - iS = iE + 1 - iE = iE + nik*lBas - CiKl(1:nik*lBas) => CijK(iS:iE) - - lSOl=lSO-nBas(j4) - iAdrL = nik*(lSOl-1)+iAdrCVec(j4+1,iSym,iSO) - Call dDaFile(LuCVector(j4+1,iSO),2,CiKl, - & nik*lBas,iAdrL) - V2(1:) => CiKl(1:) - Else - V2(1:) => CiKj(1:) - End If -* - Fact=One - If (iSym.ne.kSym) Fact=Half - Call DGEMM_('T','N',jBas,lBas,nik, - & Fact,CiKj,nik, - & V2,nik, - & 1.0D0,A,jBas) -* - End Do -* - mijkl = 0 - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - nBas(j4) - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - nBas(j2) - mijkl = mijkl + 1 -* -*-----------------------Coulomb contribution - If (j2.eq.0) Then -*---------------------------j4.eq.0 also - temp=V_K(jSOj,1)*V_K(lSOl,1)*Coulfac -* temp=Zero - Else - temp = Zero - End If -* -*-----------------------Exchange contribution - temp = temp - ExFac*A(mijkl) -* - PMax=Max(PMax,Abs(Temp)) - PSO(mijkl,MemSO2) = Fac * temp -* - End Do - End Do -* - End Do - End Do -* - End Do - End Do -* * -************************************************************************ -* * - End If - CiKj => Null() - CiKl => Null() - V2 => Null() -* * -************************************************************************ -* * - If (nPSO.ne.MemSO2) Then - Write (6,*) ' PGet2: nPSO.ne.MemSO2' - Write (6,*) nPSO, MemSO2 - Call Abend() - End If -* -#ifdef _DEBUGPRINT_ - Call RecPrt(' In PGet2_RI2:PSO ',' ',PSO,nijkl,nPSO) -#endif -* - Call CWTime(Cpu2,Wall2) - Cpu = Cpu2 - Cpu1 - Wall = Wall2 - Wall1 - tavec(1) = tavec(1) + Cpu - tavec(2) = tavec(2) + Wall -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(iBas) - Call Unused_integer(kBas) - Call Unused_logical(Shijij) - End If - End diff -Nru openmolcas-22.02/src/ri_util/pget2_ri2.F90 openmolcas-22.10/src/ri_util/pget2_ri2.F90 --- openmolcas-22.02/src/ri_util/pget2_ri2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/pget2_ri2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,637 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1992,2007, Roland Lindh * +!*********************************************************************** + +subroutine PGet2_RI2(iCmp,jBas,lBas,iAO,iAOst,nijkl,PSO,nPSO,ExFac,CoulFac,PMax,V_K,mV_K,Z_p_K,nSA,nZ_p_k) +!*********************************************************************** +! Object: to assemble the 2nd order density matrix of a SCF wave * +! function from the 1st order density matrix. * +! * +! The indices have been scrambled before calling this routine.* +! Hence we must take special care in order to regain the * +! canonical order. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +! January '92. * +! * +! Modified to RI-DFT, March 2007 * +!*********************************************************************** + +use Basis_Info, only: nBas, nBas_Aux +use SOAO_Info, only: iAOtSO +use pso_stuff, only: DMdiag, lPSO, lSA, nnP +use Symmetry_Info, only: Mul, nIrrep +use RI_glob, only: A, CijK, iAdrCVec, iMP2prpt, LuCVector, nIJ1, tavec +use Constants, only: Zero, One, Half, Quart +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iCmp(4), jBas, lBas, iAO(4), iAOst(4), nijkl, nPSO, mV_K, nSA, nZ_p_k +real(kind=wp), intent(out) :: PSO(nijkl,nPSO), PMax +real(kind=wp), intent(in) :: ExFac, CoulFac, V_K(mV_K,nSA), Z_p_K(nZ_p_k,*) +integer(kind=iwp) :: CumnnP(0:7), CumnnP2(0:7), i, i2, i4, iAdrJ, iAdrL, iE, iS, iSO, iSym, iUHF, j, j2, j4, jAOj, jp, jpSOj, & + jpSOl, js, jSO, jSOj, jSym(0:7), kSym, lAOl, ls, lSO, lSOl, lSym(0:7), MemSO2, mijkl, nB, nik, njSym, nlSym +real(kind=wp) :: Cpu, Cpu1, Cpu2, Fac, Fact, temp, temp2, Wall, Wall1, Wall2 +logical(kind=iwp) :: Found +real(kind=wp), pointer :: CiKj(:), CiKl(:), V2(:) + +! * +!*********************************************************************** +! * +!#define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +call RecPrt('V_K',' ',V_K,1,mV_K) +#endif + +call CWTime(Cpu1,Wall1) +! * +!*********************************************************************** +! * +PMax = Zero +iSO = 1 + +PSO(:,:) = Zero + +if (lPSO) then + CumnnP(0) = 0 + CumnnP2(0) = 0 + do i=1,nIrrep-1 + nB = nBas_Aux(i-1) + if (i == 1) nB = nB-1 + CumnnP(i) = CumnnP(i-1)+nnP(i-1) + CumnnP2(i) = CumnnP2(i-1)+nnP(i-1)*nB + end do +end if + +call Qpg_iScalar('SCF mode',Found) +if (Found) then + call Get_iScalar('SCF mode',iUHF) ! either 0 or 1 +else + iUHF = 0 +end if + +! * +!*********************************************************************** +! * +Fac = Quart +MemSO2 = 0 +! * +!*********************************************************************** +! * +! Pure DFT + +if (ExFac == Zero) then + ! * + !********************************************************************* + ! * + do i2=1,iCmp(2) + njSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(2)+i2,j) > 0) then + jSym(njSym) = j + njSym = njSym+1 + end if + end do + + do i4=1,iCmp(4) + nlSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(4)+i4,j) > 0) then + lSym(nlSym) = j + nlSym = nlSym+1 + end if + end do + ! * + !***************************************************************** + ! * + ! Loop over irreps which are spanned by the basis function. + + do js=0,njSym-1 + j2 = jSym(js) + jSO = iAOtSO(iAO(2)+i2,j2)+iAOst(2) + + do ls=0,nlSym-1 + j4 = lSym(ls) + if (j2 /= j4) cycle + lSO = iAOtSO(iAO(4)+i4,j4)+iAOst(4) + + MemSO2 = MemSO2+1 + if (j2 /= 0) cycle + + mijkl = 0 + do lAOl=0,lBas-1 + lSOl = lSO+lAOl-nBas(j4) + do jAOj=0,jBas-1 + jSOj = jSO+jAOj-nBas(j2) + mijkl = mijkl+1 + + ! Coulomb contribution + if (j2 == 0) then + ! j4 == 0 also + temp = V_K(jSOj,1)*V_K(lSOl,1)*CoulFac + !temp = Zero + else + temp = Zero + end if + + PMax = max(PMax,abs(Temp)) + PSO(mijkl,MemSO2) = Fac*temp + + end do + end do + + end do + end do + + end do + end do + ! * + !********************************************************************* + ! * +else if ((iMP2prpt /= 2) .and. (.not. lPSO) .and. (iUHF == 0)) then + ! * + !********************************************************************* + ! * + ! Hybrid DFT and HF + + do i2=1,iCmp(2) + njSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(2)+i2,j) > 0) then + jSym(njSym) = j + njSym = njSym+1 + end if + end do + + do i4=1,iCmp(4) + nlSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(4)+i4,j) > 0) then + lSym(nlSym) = j + nlSym = nlSym+1 + end if + end do + ! * + !***************************************************************** + ! * + ! Loop over irreps which are spanned by the basis function. + + do js=0,njSym-1 + j2 = jSym(js) + jSO = iAOtSO(iAO(2)+i2,j2)+iAOst(2) + + do ls=0,nlSym-1 + j4 = lSym(ls) + if (j2 /= j4) cycle + lSO = iAOtSO(iAO(4)+i4,j4)+iAOst(4) + + MemSO2 = MemSO2+1 + + A(1:jBas*lBas) = Zero + + do iSym=1,nIrrep + kSym = Mul(j2+1,iSym) + nik = nIJ1(iSym,kSym,iSO) + + if (nik == 0) cycle + + iS = 1 + iE = nik*jBas + CiKj(1:nik*jBas) => CijK(iS:iE) + + jSOj = jSO-nBas(j2) + iAdrJ = nik*(jSOj-1)+iAdrCVec(j2+1,iSym,iSO) + call dDaFile(LuCVector(j2+1,iSO),2,CikJ,nik*jBas,iAdrJ) + + if (lSO /= jSO) then + iS = iE+1 + iE = iE+nik*lBas + CiKl(1:nik*lBas) => CijK(iS:iE) + + lSOl = lSO-nBas(j4) + iAdrL = nik*(lSOl-1)+iAdrCVec(j4+1,iSym,iSO) + call dDaFile(LuCVector(j4+1,iSO),2,CiKl,nik*lBas,iAdrL) + V2(1:) => CiKl(1:) + else + V2(1:) => CiKj(1:) + end if + + Fact = One + if (iSym /= kSym) Fact = Half + call DGEMM_('T','N',jBas,lBas,nik,Fact,CikJ,nik,V2,nik,One,A,jBas) + + end do + + mijkl = 0 + do lAOl=0,lBas-1 + lSOl = lSO+lAOl-nBas(j4) + do jAOj=0,jBas-1 + jSOj = jSO+jAOj-nBas(j2) + mijkl = mijkl+1 + + ! Coulomb contribution + if (j2 == 0) then + ! j4 == 0 also + temp = V_K(jSOj,1)*V_K(lSOl,1)*CoulFac + !temp = Zero + else + temp = Zero + end if + + ! Exchange contribution + temp = temp-ExFac*A(mijkl) + + PMax = max(PMax,abs(Temp)) + PSO(mijkl,MemSO2) = Fac*temp + + end do + end do + + end do + end do + + end do + end do + ! * + !********************************************************************* + ! * +else if ((iMP2prpt /= 2) .and. (.not. lPSO) .and. (iUHF == 1)) then + ! * + !********************************************************************* + ! * + ! Hybrid UDFT and UHF + + write(u6,*) 'Pget2_RI2: UDFT/UHF not implemented yet.' + call Abend() + ! * + !********************************************************************* + ! * +else if ((iMP2prpt /= 2) .and. lPSO .and. (.not. LSA)) then + ! * + !********************************************************************* + ! * + ! CASSCF + + do i2=1,iCmp(2) + njSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(2)+i2,j) > 0) then + jSym(njSym) = j + njSym = njSym+1 + end if + end do + + do i4=1,iCmp(4) + nlSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(4)+i4,j) > 0) then + lSym(nlSym) = j + nlSym = nlSym+1 + end if + end do + ! * + !***************************************************************** + ! * + ! Loop over irreps which are spanned by the basis function. + + do js=0,njSym-1 + j2 = jSym(js) + jSO = iAOtSO(iAO(2)+i2,j2)+iAOst(2) + + do ls=0,nlSym-1 + j4 = lSym(ls) + if (j2 /= j4) cycle + lSO = iAOtSO(iAO(4)+i4,j4)+iAOst(4) + + MemSO2 = MemSO2+1 + + A(1:jBas*lBas) = Zero + + do iSym=1,nIrrep + kSym = Mul(j2+1,iSym) + nik = nIJ1(iSym,kSym,iSO) + + if (nik == 0) cycle + + iS = 1 + iE = nik*jBas + CiKj(1:nik*jBas) => CijK(iS:iE) + + jSOj = jSO-nBas(j2) + iAdrJ = nik*(jSOj-1)+iAdrCVec(j2+1,iSym,iSO) + call dDaFile(LuCVector(j2+1,iSO),2,CiKj,nik*jBas,iAdrJ) + + if (lSO /= jSO) then + iS = iE+1 + iE = iE+nik*lBas + CiKl(1:nik*lBas) => CijK(iS:iE) + + lSOl = lSO-nBas(j4) + iAdrL = nik*(lSOl-1)+iAdrCVec(j4+1,iSym,iSO) + call dDaFile(LuCVector(j4+1,iSO),2,CiKl,nik*lBas,iAdrL) + V2(1:) => CiKl(1:) + else + V2(1:) => CiKj(1:) + end if + + Fact = One + if (iSym /= kSym) Fact = Half + call DGEMM_('T','N',jBas,lBas,nik,Fact,CikJ,nik,V2,nik,One,A,jBas) + + end do + + mijkl = 0 + do lAOl=0,lBas-1 + lSOl = lSO+lAOl-nBas(j4) + do jAOj=0,jBas-1 + jSOj = jSO+jAOj-nBas(j2) + mijkl = mijkl+1 + + ! Coulomb contribution + if (j2 == 0) then + ! j4 == 0 also + temp = V_K(jSOj,1)*V_K(lSOl,1)*CoulFac + !temp = Zero + else + temp = Zero + end if + + ! Exchange contribution + temp = temp-ExFac*A(mijkl) + + temp2 = Zero + jpSOj = CumnnP2(j2)+(jSOj-1)*nnP(j2) + jpSOl = CumnnP2(j2)+(lSOl-1)*nnP(j2) + do jp=1,nnP(j2) + temp2 = temp2+sign(One,DMdiag(CumnnP(j2)+jp,1))*Z_p_K(jpSOj+jp,1)*Z_p_K(jpSOl+jp,1) + end do + temp = temp+temp2 + + PMax = max(PMax,abs(Temp)) + PSO(mijkl,MemSO2) = Fac*temp + + end do + end do + + end do + end do + + end do + end do + ! * + !********************************************************************* + ! * +else if ((iMP2prpt /= 2) .and. lPSO .and. lSA) then + ! * + !********************************************************************* + ! * + ! SA-CASSCF + + write(u6,*) 'Pget2_ri2: SA-CASSCF not implemented yet' + call Abend() + + do i2=1,iCmp(2) + njSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(2)+i2,j) > 0) then + jSym(njSym) = j + njSym = njSym+1 + end if + end do + + do i4=1,iCmp(4) + nlSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(4)+i4,j) > 0) then + lSym(nlSym) = j + nlSym = nlSym+1 + end if + end do + ! * + !***************************************************************** + ! * + ! Loop over irreps which are spanned by the basis function. + + do js=0,njSym-1 + j2 = jSym(js) + jSO = iAOtSO(iAO(2)+i2,j2)+iAOst(2) + + do ls=0,nlSym-1 + j4 = lSym(ls) + if (j2 /= j4) cycle + lSO = iAOtSO(iAO(4)+i4,j4)+iAOst(4) + + MemSO2 = MemSO2+1 + + A(1:jBas*lBas) = Zero + + do iSym=1,nIrrep + kSym = Mul(j2+1,iSym) + nik = nIJ1(iSym,kSym,iSO) + + if (nik == 0) cycle + + iS = 1 + iE = nik*jBas + CiKj(1:nik*jBas) => CijK(iS:iE) + + jSOj = jSO-nBas(j2) + iAdrJ = nik*(jSOj-1)+iAdrCVec(j2+1,iSym,iSO) + call dDaFile(LuCVector(j2+1,iSO),2,CiKj,nik*jBas,iAdrJ) + + if (lSO /= jSO) then + iS = iE+1 + iE = iE+nik*lBas + CiKl(1:nik*lBas) => CijK(iS:iE) + + lSOl = lSO-nBas(j4) + iAdrL = nik*(lSOl-1)+iAdrCVec(j4+1,iSym,iSO) + call dDaFile(LuCVector(j4+1,iSO),2,CiKl,nik*lBas,iAdrL) + V2(1:) => CiKl(1:) + else + V2(1:) => CiKj(1:) + end if + + Fact = One + if (iSym /= kSym) Fact = Half + call DGEMM_('T','N',jBas,lBas,nik,Fact,CiKJ,nik,V2,nik,One,A,jBas) + + end do + + mijkl = 0 + do lAOl=0,lBas-1 + lSOl = lSO+lAOl-nBas(j4) + do jAOj=0,jBas-1 + jSOj = jSO+jAOj-nBas(j2) + mijkl = mijkl+1 + + ! Coulomb contribution + if (j2 == 0) then + ! j4 == 0 also + temp = CoulFac*(V_K(lSOl,1)*V_K(jSOj,2)+V_K(lSOl,2)*V_K(jSOj,1)+V_K(lSOl,3)*V_K(jSOj,4)+V_K(lSOl,4)*V_K(jSOj,3)) + !temp = Zero + else + temp = Zero + end if + + ! Exchange contribution + temp = temp-ExFac*A(mijkl) + + PMax = max(PMax,abs(Temp)) + PSO(mijkl,MemSO2) = Fac*temp + + end do + end do + + end do + end do + + end do + end do + ! * + !********************************************************************* + ! * +else + ! * + !********************************************************************* + ! * + ! MP2 + + write(u6,*) 'Pget2_ri2: MP2 not implemented yet' + call Abend() + + do i2=1,iCmp(2) + njSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(2)+i2,j) > 0) then + jSym(njSym) = j + njSym = njSym+1 + end if + end do + + do i4=1,iCmp(4) + nlSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(4)+i4,j) > 0) then + lSym(nlSym) = j + nlSym = nlSym+1 + end if + end do + ! * + !***************************************************************** + ! * + ! Loop over irreps which are spanned by the basis function. + + do js=0,njSym-1 + j2 = jSym(js) + jSO = iAOtSO(iAO(2)+i2,j2)+iAOst(2) + + do ls=0,nlSym-1 + j4 = lSym(ls) + if (j2 /= j4) cycle + lSO = iAOtSO(iAO(4)+i4,j4)+iAOst(4) + + MemSO2 = MemSO2+1 + + A(1:jBas*lBas) = Zero + + do iSym=1,nIrrep + kSym = Mul(j2+1,iSym) + nik = nIJ1(iSym,kSym,iSO) + + if (nik == 0) cycle + + iS = 1 + iE = nik*jBas + CiKj(1:nik*jBas) => CijK(iS:iE) + + jSOj = jSO-nBas(j2) + iAdrJ = nik*(jSOj-1)+iAdrCVec(j2+1,iSym,iSO) + call dDaFile(LuCVector(j2+1,iSO),2,CiKj,nik*jBas,iAdrJ) + + if (lSO /= jSO) then + iS = iE+1 + iE = iE+nik*lBas + CiKl(1:nik*lBas) => CijK(iS:iE) + + lSOl = lSO-nBas(j4) + iAdrL = nik*(lSOl-1)+iAdrCVec(j4+1,iSym,iSO) + call dDaFile(LuCVector(j4+1,iSO),2,CiKl,nik*lBas,iAdrL) + V2(1:) => CiKl(1:) + else + V2(1:) => CiKj(1:) + end if + + Fact = One + if (iSym /= kSym) Fact = Half + call DGEMM_('T','N',jBas,lBas,nik,Fact,CiKj,nik,V2,nik,One,A,jBas) + + end do + + mijkl = 0 + do lAOl=0,lBas-1 + lSOl = lSO+lAOl-nBas(j4) + do jAOj=0,jBas-1 + jSOj = jSO+jAOj-nBas(j2) + mijkl = mijkl+1 + + ! Coulomb contribution + if (j2 == 0) then + ! j4 == 0 also + temp = V_K(jSOj,1)*V_K(lSOl,1)*CoulFac + !temp = Zero + else + temp = Zero + end if + + ! Exchange contribution + temp = temp-ExFac*A(mijkl) + + PMax = max(PMax,abs(Temp)) + PSO(mijkl,MemSO2) = Fac*temp + + end do + end do + + end do + end do + + end do + end do + ! * + !********************************************************************* + ! * +end if +nullify(CiKj,CiKl,V2) +! * +!*********************************************************************** +! * +if (nPSO /= MemSO2) then + write(u6,*) ' PGet2: nPSO /= MemSO2' + write(u6,*) nPSO,MemSO2 + call Abend() +end if + +#ifdef _DEBUGPRINT_ +call RecPrt(' In PGet2_RI2:PSO ',' ',PSO,nijkl,nPSO) +#endif + +call CWTime(Cpu2,Wall2) +Cpu = Cpu2-Cpu1 +Wall = Wall2-Wall1 +tavec(1) = tavec(1)+Cpu +tavec(2) = tavec(2)+Wall + +return + +end subroutine PGet2_RI2 diff -Nru openmolcas-22.02/src/ri_util/pget2_ri3.f openmolcas-22.10/src/ri_util/pget2_ri3.f --- openmolcas-22.02/src/ri_util/pget2_ri3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/pget2_ri3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,457 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1992,2007, Roland Lindh * -************************************************************************ - SubRoutine PGet2_RI3(iCmp,iBas,jBas,kBas,lBas, - & Shijij, iAO, iAOst, nijkl,PSO,nPSO, - & DSO,DSSO,nDSO,ExFac,CoulFac,PMax,V_k,mV_k, - & ZpK,nSA,nAct) -************************************************************************ -* Object: to assemble the 2nd order density matrix of a SCF wave * -* function from the 1st order density matrix. * -* * -* The indices has been scrambled before calling this routine. * -* Hence we must take special care in order to regain the can- * -* onical order. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -* January '92. * -* * -* Modified for 3-center RI gradients, March 2007 * -************************************************************************ - use SOAO_Info, only: iAOtSO - use pso_stuff, only: lPSO, nnp, Thpkl, AOrb - use Basis_Info, only: nBas, nBas_Aux - use Symmetry_Info, only: nIrrep - use ExTerm, only: CijK, CilK, BklK - use ExTerm, only: Ymnij, ipYmnij, nYmnij, iOff_Ymnij - use ExTerm, only: Yij, CMOi - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "exterm.fh" - Real*8 PSO(nijkl,nPSO), DSO(nDSO,nSA), DSSO(nDSO), V_k(mV_k,nSA), - & Zpk(*) - Integer iCmp(4), iAO(4), iAOst(4) - Logical Shijij -* Local Array - Integer jSym(0:7), kSym(0:7), lSym(0:7), nAct(0:7) - Integer nCumnnP(0:7),nCumnnP2(0:7) - - Real*8, Pointer :: Xki(:)=>Null() - Real*8, Pointer :: Xli(:)=>Null() -* * -************************************************************************ -* * -* Statement function -* - kYmnij(l)=Ymnij(ipYmnij(1)-1+l) -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - iComp = 1 - Call PrMtrx(' In PGET_RI3:DSO ',[iD0Lbl],iComp,1,D0) - Call RecPrt('V_K',' ',V_K,1,mV_K) - Write (6,*) - Write (6,*) 'Distribution of Ymnij' - Do iSym = 1, nIrrep - If (nYmnij(iSym,1).gt.0) Then - Write (6,*) 'iSym=',iSym - Do i= iOff_Ymnij(iSym,1)+1,iOff_Ymnij(iSym,1)+nYmnij(iSym,1) - Write (6,*) 'kYmnij=',kYmnij(i) - End Do - End If - End Do - Write (6,*) 'jbas,kbas,lbas=',jBas,kBas,lBas -#endif -* * -************************************************************************ -* * - Call CWTime(Cpu1,Wall1) -* - Fac = One / Four - lOper=1 - PMax=Zero - iSO = 1 - Call FZero(PSO,nijkl*nPSO) -* - If (lPSO) Then - nCumnnP(0)=0 - nBas_Aux(0)=nBas_Aux(0)-1 - Do i=1,nIrrep-1 - nCumnnP(i)=nCumnnP(i-1)+nnP(i-1)*nBas_Aux(i-1) - End Do - nBas_Aux(0)=nBas_Aux(0)+1 - EndIf -* -* i2, j2, jBas: auxiliary basis -* i3, j3, kBas: valence basis -* i4, j4, lBas: valence basis -* -* Note when j2 is symmetric then we can have both Coulomb and -* exchange contributions, while for j2 asymmetric we will -* only have exchange contributions -* - MemSO2 = 0 - Do i2 = 1, iCmp(2) - njSym = 0 - Do j = 0, nIrrep-1 - If (iAOtSO(iAO(2)+i2,j)>0) Then - jSym(njSym) = j - njSym = njSym + 1 - End If - End Do - Do i3 = 1, iCmp(3) - nkSym = 0 - Do 301 j = 0, nIrrep-1 - If (iAOtSO(iAO(3)+i3,j)>0) Then - kSym(nkSym) = j - nkSym = nkSym + 1 - End If -301 Continue - Do i4 = 1, iCmp(4) - nlSym = 0 - Do 401 j = 0, nIrrep-1 - If (iAOtSO(iAO(4)+i4,j)>0) Then - lSym(nlSym) = j - nlSym = nlSym + 1 - End If - 401 Continue -* -*------Loop over irreps which are spanned by the basis function. -* - Do js = 0, njSym-1 - j2 = jSym(js) -* nJ = nChOrb(j2,iSO) - nJ = jBas -* - If (lPSO) Then - ntmp=0 - Do j4=0,nIrrep-1 - j3=iEOR(j4,j2) - If (j3.le.j4) nCumnnP2(j3)=ntmp - If (j3.eq.j4) ntmp=ntmp+nAct(j3)*(nAct(j3)+1)/2 - If (j3.lt.j4) ntmp=ntmp+nAct(j3)*nAct(j4) - End Do - Do j4=0,nIrrep-1 - j3=iEOR(j4,j2) - If (j3.gt.j4) nCumnnP2(j3)=nCumnnP2(j4) - End Do - EndIf -* -* - Do 310 ks = 0, nkSym-1 - j3 = kSym(ks) - j23 = iEor(j2,j3) - nk = nYmnij(j3+1,1) - kSO = iAOtSO(iAO(3)+i3,j3)+iAOst(3) -* -* Pointers to the full list of the X_mu,i elements -* Note this list runs over all basis functions mu -* (kBas*iCmp(3)). Here we only want to pick up the -* subblock for a fixed iCmp(3) value. -* - If (nk.lt.nChOrb(j3,iSO).and.ExFac.ne.Zero.and. - & nk.gt.0) Then -* -* Offset to where the block starts (jbas,kbas,i3) -* - lda = SIZE(CMOi(1)%SB(j3+1)%A2,1) - ik = 1 + lda*(kSO-1) - Xki(1:) => CMOi(1)%SB(j3+1)%A1(ik:) -* -* Loop over the auxiliary basis functions which has -* significant contributions to the k shell. -* - imo=1 - Do k = 1, nk - kmo=kYmnij(k+iOff_Ymnij(j3+1,1)) -* - call dcopy_(kBas,Xki(kmo:),nChOrb(j3,iSO), - & Yij(imo,1,1), nk) -* - imo = imo +1 - End Do -* Reset pointers - Xki(1:nk*kBas) => Yij(1:nk*kBas,1,1) -* Call RecPrt('X(i,mu)C',' ',Xki,nk,kBas) - Else If (ExFac.ne.Zero.and.nk.gt.0) Then - lda = SIZE(CMOi(1)%SB(j3+1)%A2,1) - ik = 1 + lda*(kSO-1) - Xki(1:) => CMOi(1)%SB(j3+1)%A1(ik:) -* Call RecPrt('X(i,mu)R',' ',Xki,nk,kBas) - Else - Xki=>Null() - End If -* - Do 410 ls = 0, nlSym-1 - j4 = lSym(ls) - If (j23.ne.j4) Go To 410 - nl = nYmnij(j4+1,1) - lSO = iAOtSO(iAO(4)+i4,j4)+iAOst(4) -* -* Pointers to the full list of the X_mu,i elements -* - If (nl.lt.nChOrb(j4,iSO).and.ExFac.ne.Zero.and. - & nl.gt.0) Then - - lda = SIZE(CMOi(1)%SB(j4+1)%A2,1) - il = 1 + lda*(lSO-1) - Xli(1:) => CMOi(1)%SB(j4+1)%A1(il:) - imo=1 - Do l = 1, nl - lmo=kYmnij(l+iOff_Ymnij(j4+1,1)) -* - call dcopy_(lBas,Xli(lmo:),nChOrb(j4,iSO), - & Yij(imo,2,1), nl) -* - imo = imo +1 - End Do -* Reset pointers - Xli(1:nl*lBas) => Yij(1:nl*lBas,2,1) -* Call RecPrt('X(j,nu)C',' ',Xli,nl,lBas) - Else If (ExFac.ne.Zero.and.nl.gt.0) Then - lda = SIZE(CMOi(1)%SB(j4+1)%A2,1) - il = 1 + lda*(lSO-1) - Xli(1:) => CMOi(1)%SB(j4+1)%A1(il:) -* Call RecPrt('X(j,nu)R',' ',Xli,nl,lBas) - Else - Xli=>Null() - End If -* - MemSO2 = MemSO2 + 1 -* - jSO = iAOtSO(iAO(2)+i2,j2)+iAOst(2) - jSO_off = jSO - nBas(j2) -* - ExFac_ = ExFac - If (nJ*nk*nl.eq.0) ExFac=Zero -* * -************************************************************************ -* * -* Read a block of C_kl^J and transform it to -* AO basis. -* - If (ExFac.ne.Zero) Then -* -* Read C(i,j,J) for a fix i2 value -* - lCVec = nIJR(j3+1,j4+1,iSO)*jBas - iAdr = iAdrCVec(j2+1,j3+1,1) - & + nIJR(j3+1,j4+1,iSO)*(jSO_Off-1) - Call dDaFile(LuCVector(j2+1,1),2,Cijk,lCVec,iAdr) -* Call RecPrt('C(ij,K)',' ',CijK, -* & nIJR(j3+1,j4+1,iSO),jBas) -* -* Extract only those C_kl^Js for which we deem k and l -* to belong to the shell-pair and to be of -* significance. Use temporary memory location at -* CilK. -* - If (nk*nl.lt.nChOrb(j3,iSO)*nChOrb(j4,iSO)) Then - ij=1 - Do j=1,nl - jmo=kYmnij(j+iOff_Ymnij(j4+1,1)) - Do i=1,nk - imo=kYmnij(i+iOff_Ymnij(j3+1,1)) -* - jC=imo+nChOrb(j3,iSO)*(jmo-1) -* -* For this particular ij combination pick -* the whole row. -* - call dcopy_(jBas,CijK(jC),nChOrb(j3,iSO)* - & nChOrb(j4,iSO), - & CilK(ij),nk*nl) - ij=ij+1 - End Do - End Do -* -* Copy back to original memory position. -* - n2j=nk*nl*jBas - CijK(1:n2j)=CilK(1:n2j) - End If -* -* Transform according to Eq. 16 (step 4) and -* generate B_kl^J. This is a transformation from -* the MO basis, ij, to the AO basis mn. -* -* E(jK,m) = Sum_i C(i,jK)' * X(i,m) -* - Call dGEMM_('T','N',nl*jBas,kBas,nk, - & 1.0D0,CijK,nk, - & Xki,nk, - & 0.0D0,CilK,nl*jBas) -* -* B(Km,n) = Sum_j E(j, Km)' * X(j,n) -* - Call dGEMM_('T','N',jBas*kBas,lBas,nl, - & 1.0D0,CilK,nl, - & Xli,nl, - & 0.0D0,BklK,jBas*kBas) - - End If -* * -************************************************************************ -* * -* Active term (CASSCF and SA-CASSCF) -* - If (lPSO) Then - Call dzero(Thpkl,jBas*kBas*lBas) - If (nAct(j3)*nAct(j4).eq.0) Go to 21 - Do iVec=1,nAVec - iMO1=1 - iMO2=1 - If (iVec.eq.2) iMO2=2 - If (iVec.eq.4) Then - iMO1=2 - EndIf -* - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - nBas(j2) - jp=nCumnnP(j2)+(jSOj-1)*nnP(j2)+nCumnnP2(j3) - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl - - If (j3.eq.j4) Then - Do kAct=1,nAct(j3) -*Zpk(*,iVec) - tmp=ddot_(kAct,Zpk(jp+kAct*(kAct-1)/2+1), - & 1,AOrb(iMO1)%SB(j4+1)%A2(:,lSOl),1) - Do lAct=kAct+1,nAct(j4) - tmp=tmp+Zpk(jp+lAct*(lAct-1)/2+kAct)* - & AOrb(iMO1)%SB(j4+1)%A2(lAct,lSOl) - End Do - Cilk(kAct)=tmp - End Do - Else - If (j3.lt.j4) Then - Call dGeMV_('N',nAct(j3),nAct(j4),1.0d0, - & Zpk(jp+1),nAct(j3), - & AOrb(iMO1)%SB(j4+1)%A2(:,lSOl),1, - & 0.0d0,CilK,1) - Else - Call dGeMV_('T',nAct(j4),nAct(j3),1.0d0, - & Zpk(jp+1),nAct(j4), - & AOrb(iMO1)%SB(j4+1)%A2(:,lSOl),1, - & 0.0d0,CilK,1) - EndIf - EndIf -* - iThpkl= jAOj+ lAOl*kBas*jBas+1 - Call dGeMV_('T',nAct(j3),kBas,1.0d0, - & AOrb(iMO2)%SB(j3+1)%A2(:,kSO), - & nAct(j3),Cilk,1,1.0d0, - & Thpkl(iThpkl),jBas) - - End Do - End Do - End Do - 21 Continue - EndIf -* -* * -************************************************************************ -* * - If (ExFac .ne. Zero) Then -* * -************************************************************************ -* * -* -#define _EXCHANGE_ - If (j3.ne.j4) Then - If (lPSO) Then -* Exchange and active contributions -#define _ACTIVE_ -#include "pget2_ri3.fh" -#undef _ACTIVE_ - Else -* Exchange contribution -#include "pget2_ri3.fh" - EndIf - Else -#define _COULOMB_ - If (lPSO) Then -* Coulomb, Exchange and active contributions -#define _ACTIVE_ -#include "pget2_ri3.fh" -#undef _ACTIVE_ - Else -* Coulomb and Exchange contributions -#include "pget2_ri3.fh" - EndIf -#undef _COULOMB_ - End If -#undef _EXCHANGE_ -* * -************************************************************************ -* * - Else If (ExFac.eq.Zero .and. j3.eq.j4) Then -* * -************************************************************************ -* * -* -#define _COULOMB_ - If (lPSO) Then -* Coulomb and active contributions -#define _ACTIVE_ -#include "pget2_ri3.fh" -#undef _ACTIVE_ - Else -* Coulomb only contribution -#include "pget2_ri3.fh" - EndIf -#undef _COULOMB_ -* * -************************************************************************ -* * - End If -* * -************************************************************************ -* * -* - ExFac = ExFac_ -* - 410 Continue - Xki=>Null() - Xli=>Null() - 310 Continue - End Do -* - End Do - End Do - End Do - If (nPSO.ne.MemSO2) Then - Write (6,*) ' PGET_RI3: nPSO.ne.MemSO2' - Write (6,*) nPSO, MemSO2 - Call Abend - End If -* -#ifdef _DEBUGPRINT_ - Call RecPrt(' In PGET_RI3:PSO ',' ',PSO,nijkl,nPSO) -#endif - - Call CWTime(Cpu2,Wall2) - Cpu = Cpu2 - Cpu1 - Wall = Wall2 - Wall1 - tbvec(1) = tbvec(1) + Cpu - tbvec(2) = tbvec(2) + Wall -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(iBas) - Call Unused_logical(Shijij) - Call Unused_real_array(DSSO) - End If - End diff -Nru openmolcas-22.02/src/ri_util/pget2_ri3.F90 openmolcas-22.10/src/ri_util/pget2_ri3.F90 --- openmolcas-22.02/src/ri_util/pget2_ri3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/pget2_ri3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,415 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1992,2007, Roland Lindh * +!*********************************************************************** + +subroutine PGet2_RI3(iCmp,jBas,kBas,lBas,iAO,iAOst,nijkl,PSO,nPSO,DSO,nDSO,ExFac,CoulFac,PMax,V_k,mV_k,ZpK,nSA,nAct) +!*********************************************************************** +! Object: to assemble the 2nd order density matrix of a SCF wave * +! function from the 1st order density matrix. * +! * +! The indices have been scrambled before calling this routine.* +! Hence we must take special care in order to regain the * +! canonical order. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +! January '92. * +! * +! Modified for 3-center RI gradients, March 2007 * +!*********************************************************************** + +use Index_Functions, only: iTri, nTri_Elem +use SOAO_Info, only: iAOtSO +use pso_stuff, only: AOrb, lPSO, nnP, Thpkl +use Basis_Info, only: nBas, nBas_Aux +use Symmetry_Info, only: Mul, nIrrep +use RI_glob, only: BklK, CijK, CilK, CMOi, iAdrCVec, iOff_Ymnij, LuCVector, nAvec, nChOrb, nIJR, nYmnij, tbvec, Yij, Ymnij +use Constants, only: Zero, One, Half, Quart +use Definitions, only: wp, iwp, u6, r8 + +implicit none +integer(kind=iwp), intent(in) :: iCmp(4), jBas, kBas, lBas, iAO(4), iAOst(4), nijkl, nPSO, nDSO, mV_k, nSA, nAct(0:7) +real(kind=wp), intent(out) :: PSO(nijkl,nPSO), PMax +real(kind=wp), intent(in) :: DSO(nDSO,nSA), ExFac, CoulFac, V_k(mV_k,nSA), Zpk(*) +integer(kind=iwp) :: i, i2, i3, i4, iAdr, ij, ik, il, imo, iMO1, iMO2, Indkl, iSO, iThpkl, iVec, j, j2, j23, j3, j4, jAOj, jC, & + jmo, jp, js, jSO, jSO_off, jSOj, jSym(0:7), k, kAct, kAOk, kmo, ks, kSO, kSOk, kSym(0:7), l, lAct, lAOl, & + lCVec, lda, lmo, lOper, ls, lSO, lSOl, lSym(0:7), MemSO2, mijkl, n2j, nCumnnP(0:7), nCumnnP2(0:7), nJ, njSym, & + nk, nkSym, nl, nlSym, ntmp +real(kind=wp) :: Cpu, Cpu1, Cpu2, ExFac_, Fac, temp, tmp, Wall, Wall1, Wall2 +real(kind=wp), pointer :: Xki(:), Xli(:) +integer(kind=iwp), external :: iPntSO +real(kind=r8), external :: ddot_ + +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +iComp = 1 +call PrMtrx(' In PGET_RI3:DSO ',[iD0Lbl],iComp,1,D0) +call RecPrt('V_K',' ',V_K,1,mV_K) +write(u6,*) +write(u6,*) 'Distribution of Ymnij' +do iSym=1,nIrrep + if (nYmnij(iSym,1) > 0) then + write(u6,*) 'iSym=',iSym + do i=iOff_Ymnij(iSym,1)+1,iOff_Ymnij(iSym,1)+nYmnij(iSym,1) + write(u6,*) 'Ymnij=',Ymnij(1)%A(i) + end do + end if +end do +write(u6,*) 'jbas,kbas,lbas=',jBas,kBas,lBas +#endif +! * +!*********************************************************************** +! * +call CWTime(Cpu1,Wall1) + +Fac = Quart +lOper = 1 +PMax = Zero +iSO = 1 +PSO(:,:) = Zero + +if (lPSO) then + nCumnnP(0) = 0 + nBas_Aux(0) = nBas_Aux(0)-1 + do i=1,nIrrep-1 + nCumnnP(i) = nCumnnP(i-1)+nnP(i-1)*nBas_Aux(i-1) + end do + nBas_Aux(0) = nBas_Aux(0)+1 +end if + +! i2, j2, jBas: auxiliary basis +! i3, j3, kBas: valence basis +! i4, j4, lBas: valence basis +! +! Note when j2 is symmetric then we can have both Coulomb and +! exchange contributions, while for j2 asymmetric we will +! only have exchange contributions + +MemSO2 = 0 +do i2=1,iCmp(2) + njSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(2)+i2,j) > 0) then + jSym(njSym) = j + njSym = njSym+1 + end if + end do + do i3=1,iCmp(3) + nkSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(3)+i3,j) > 0) then + kSym(nkSym) = j + nkSym = nkSym+1 + end if + end do + do i4=1,iCmp(4) + nlSym = 0 + do j=0,nIrrep-1 + if (iAOtSO(iAO(4)+i4,j) > 0) then + lSym(nlSym) = j + nlSym = nlSym+1 + end if + end do + + ! Loop over irreps which are spanned by the basis function. + + do js=0,njSym-1 + j2 = jSym(js) + !nJ = nChOrb(j2,iSO) + nJ = jBas + + if (lPSO) then + ntmp = 0 + do j4=0,nIrrep-1 + j3 = Mul(j4+1,j2+1)-1 + if (j3 <= j4) nCumnnP2(j3) = ntmp + if (j3 == j4) ntmp = ntmp+nTri_Elem(nAct(j3)) + if (j3 < j4) ntmp = ntmp+nAct(j3)*nAct(j4) + end do + do j4=0,nIrrep-1 + j3 = Mul(j4+1,j2+1)-1 + if (j3 > j4) nCumnnP2(j3) = nCumnnP2(j4) + end do + end if + + do ks=0,nkSym-1 + j3 = kSym(ks) + j23 = Mul(j2+1,j3+1)-1 + nk = nYmnij(j3+1,1) + kSO = iAOtSO(iAO(3)+i3,j3)+iAOst(3) + + ! Pointers to the full list of the X_mu,i elements + ! Note this list runs over all basis functions mu + ! (kBas*iCmp(3)). Here we only want to pick up the + ! subblock for a fixed iCmp(3) value. + + if ((nk < nChOrb(j3,iSO)) .and. (ExFac /= Zero) .and. (nk > 0)) then + + ! Offset to where the block starts (jbas,kbas,i3) + + lda = size(CMOi(1)%SB(j3+1)%A2,1) + ik = 1+lda*(kSO-1) + Xki(1:) => CMOi(1)%SB(j3+1)%A1(ik:) + + ! Loop over the auxiliary basis functions which has + ! significant contributions to the k shell. + + imo = 1 + do k=1,nk + kmo = Ymnij(1)%A(k+iOff_Ymnij(j3+1,1)) + + call dcopy_(kBas,Xki(kmo:),nChOrb(j3,iSO),Yij(imo,1,1),nk) + + imo = imo+1 + end do + ! Reset pointers + Xki(1:nk*kBas) => Yij(1:nk*kBas,1,1) + !call RecPrt('X(i,mu)C',' ',Xki,nk,kBas) + else if ((ExFac /= Zero) .and. (nk > 0)) then + lda = size(CMOi(1)%SB(j3+1)%A2,1) + ik = 1+lda*(kSO-1) + Xki(1:) => CMOi(1)%SB(j3+1)%A1(ik:) + !call RecPrt('X(i,mu)R',' ',Xki,nk,kBas) + else + nullify(Xki) + end if + + do ls=0,nlSym-1 + j4 = lSym(ls) + if (j23 /= j4) cycle + nl = nYmnij(j4+1,1) + lSO = iAOtSO(iAO(4)+i4,j4)+iAOst(4) + + ! Pointers to the full list of the X_mu,i elements + + if ((nl < nChOrb(j4,iSO)) .and. (ExFac /= Zero) .and. (nl > 0)) then + + lda = size(CMOi(1)%SB(j4+1)%A2,1) + il = 1+lda*(lSO-1) + Xli(1:) => CMOi(1)%SB(j4+1)%A1(il:) + imo = 1 + do l=1,nl + lmo = Ymnij(1)%A(l+iOff_Ymnij(j4+1,1)) + + call dcopy_(lBas,Xli(lmo:),nChOrb(j4,iSO),Yij(imo,2,1),nl) + + imo = imo+1 + end do + ! Reset pointers + Xli(1:nl*lBas) => Yij(1:nl*lBas,2,1) + !call RecPrt('X(j,nu)C',' ',Xli,nl,lBas) + else if ((ExFac /= Zero) .and. (nl > 0)) then + lda = size(CMOi(1)%SB(j4+1)%A2,1) + il = 1+lda*(lSO-1) + Xli(1:) => CMOi(1)%SB(j4+1)%A1(il:) + !call RecPrt('X(j,nu)R',' ',Xli,nl,lBas) + else + nullify(Xli) + end if + + MemSO2 = MemSO2+1 + + jSO = iAOtSO(iAO(2)+i2,j2)+iAOst(2) + jSO_off = jSO-nBas(j2) + + ExFac_ = ExFac + if (nJ*nk*nl == 0) ExFac_ = Zero + ! * + !*********************************************************** + ! * + ! Read a block of C_kl^J and transform it to AO basis. + + if (ExFac_ /= Zero) then + + ! Read C(i,j,J) for a fix i2 value + + lCVec = nIJR(j3+1,j4+1,iSO)*jBas + iAdr = iAdrCVec(j2+1,j3+1,1)+nIJR(j3+1,j4+1,iSO)*(jSO_Off-1) + call dDaFile(LuCVector(j2+1,1),2,Cijk,lCVec,iAdr) + !call RecPrt('C(ij,K)',' ',CijK,nIJR(j3+1,j4+1,iSO),jBas) + + ! Extract only those C_kl^Js for which we deem k and l + ! to belong to the shell-pair and to be of + ! significance. Use temporary memory location at CilK. + + if (nk*nl < nChOrb(j3,iSO)*nChOrb(j4,iSO)) then + ij = 1 + do j=1,nl + jmo = Ymnij(1)%A(j+iOff_Ymnij(j4+1,1)) + do i=1,nk + imo = Ymnij(1)%A(i+iOff_Ymnij(j3+1,1)) + + jC = imo+nChOrb(j3,iSO)*(jmo-1) + + ! For this particular ij combination pick the whole row. + + call dcopy_(jBas,CijK(jC),nChOrb(j3,iSO)*nChOrb(j4,iSO),CilK(ij),nk*nl) + ij = ij+1 + end do + end do + + ! Copy back to original memory position. + + n2j = nk*nl*jBas + CijK(1:n2j) = CilK(1:n2j) + end if + + ! Transform according to Eq. 16 (step 4) and + ! generate B_kl^J. This is a transformation from + ! the MO basis, ij, to the AO basis mn. + + ! E(jK,m) = Sum_i C(i,jK)' * X(i,m) + + call dGEMM_('T','N',nl*jBas,kBas,nk,One,CijK,nk,Xki,nk,Zero,CilK,nl*jBas) + + ! B(Km,n) = Sum_j E(j, Km)' * X(j,n) + + call dGEMM_('T','N',jBas*kBas,lBas,nl,One,CilK,nl,Xli,nl,Zero,BklK,jBas*kBas) + + end if + ! * + !*********************************************************** + ! * + ! Active term (CASSCF and SA-CASSCF) + + if (lPSO) then + Thpkl(1:jBas*kBas*lBas) = Zero + if (nAct(j3)*nAct(j4) /= 0) then + do iVec=1,nAVec + iMO1 = 1 + iMO2 = 1 + if (iVec == 2) iMO2 = 2 + if (iVec == 4) then + iMO1 = 2 + end if + + do jAOj=0,jBas-1 + jSOj = jSO+jAOj-nBas(j2) + jp = nCumnnP(j2)+(jSOj-1)*nnP(j2)+nCumnnP2(j3) + do lAOl=0,lBas-1 + lSOl = lSO+lAOl + + if (j3 == j4) then + do kAct=1,nAct(j3) + ! Zpk(*,iVec) + tmp = ddot_(kAct,Zpk(jp+iTri(kAct,1)),1,AOrb(iMO1)%SB(j4+1)%A2(:,lSOl),1) + do lAct=kAct+1,nAct(j4) + tmp = tmp+Zpk(jp+iTri(lAct,kAct))*AOrb(iMO1)%SB(j4+1)%A2(lAct,lSOl) + end do + Cilk(kAct) = tmp + end do + else + if (j3 < j4) then + call dGeMV_('N',nAct(j3),nAct(j4),One,Zpk(jp+1),nAct(j3),AOrb(iMO1)%SB(j4+1)%A2(:,lSOl),1,Zero,CilK,1) + else + call dGeMV_('T',nAct(j4),nAct(j3),One,Zpk(jp+1),nAct(j4),AOrb(iMO1)%SB(j4+1)%A2(:,lSOl),1,Zero,CilK,1) + end if + end if + + iThpkl = jAOj+lAOl*kBas*jBas+1 + call dGeMV_('T',nAct(j3),kBas,One,AOrb(iMO2)%SB(j3+1)%A2(:,kSO),nAct(j3),Cilk,1,One,Thpkl(iThpkl),jBas) + + end do + end do + end do + end if + end if + + ! * + !*********************************************************** + ! * + if (ExFac_ /= Zero) then + ! * + !*********************************************************** + ! * + +# define _EXCHANGE_ + if (j3 /= j4) then + if (lPSO) then + ! Exchange and active contributions +# define _ACTIVE_ +# include "pget2_ri3.fh" +# undef _ACTIVE_ + else + ! Exchange contribution +# include "pget2_ri3.fh" + end if + else +# define _COULOMB_ + if (lPSO) then + ! Coulomb, Exchange and active contributions +# define _ACTIVE_ +# include "pget2_ri3.fh" +# undef _ACTIVE_ + else + ! Coulomb and Exchange contributions +# include "pget2_ri3.fh" + end if +# undef _COULOMB_ + end if +# undef _EXCHANGE_ + ! * + !********************************************************* + ! * + else if ((ExFac_ == Zero) .and. (j3 == j4)) then + ! * + !********************************************************* + ! * + +# define _COULOMB_ + if (lPSO) then + ! Coulomb and active contributions +# define _ACTIVE_ +# include "pget2_ri3.fh" +# undef _ACTIVE_ + else + ! Coulomb only contribution +# include "pget2_ri3.fh" + end if +# undef _COULOMB_ + ! * + !********************************************************* + ! * + end if + ! * + !*********************************************************** + ! * + + end do + nullify(Xki,Xli) + end do + end do + + end do + end do +end do +if (nPSO /= MemSO2) then + write(u6,*) ' PGET_RI3: nPSO /= MemSO2' + write(u6,*) nPSO,MemSO2 + call Abend() +end if + +#ifdef _DEBUGPRINT_ +call RecPrt(' In PGET_RI3:PSO ',' ',PSO,nijkl,nPSO) +#endif + +call CWTime(Cpu2,Wall2) +Cpu = Cpu2-Cpu1 +Wall = Wall2-Wall1 +tbvec(1) = tbvec(1)+Cpu +tbvec(2) = tbvec(2)+Wall + +return + +end subroutine PGet2_RI3 diff -Nru openmolcas-22.02/src/ri_util/pget2_ri3.fh openmolcas-22.10/src/ri_util/pget2_ri3.fh --- openmolcas-22.02/src/ri_util/pget2_ri3.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/pget2_ri3.fh 2022-10-10 14:22:40.000000000 +0000 @@ -1,45 +1,50 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - mijkl=0 - Do lAOl = 0, lBas-1 - lSOl = lSO + lAOl -* - Do kAOk = 0, kBas-1 - kSOk = kSO + kAOk -* - Do jAOj = 0, jBas-1 - jSOj = jSO + jAOj - nBas(j2) - mijkl = mijkl + 1 -* - temp=0.0d0 -#ifdef _COULOMB_ - Indk=Max(kSOk,lSOl) - Indl=kSOk+lSOl-Indk - iPntkl=iPntSO(j3,j4,lOper,nbas) - Indkl=iPntkl+(Indk-1)*Indk/2+Indl -* - temp=temp+V_k(jSOj,1)*DSO(Indkl,1)*Coulfac +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! Template used in PGet2_RI3 +#if !(defined(_COULOMB_) || defined(_EXCHANGE_) || defined(_ACTIVE_)) + ! This should be an error at compile time! + 'At least one of _COULOMB_, _EXCHANGE_, _ACTIVE_ should be defined' #endif -* -#ifdef _EXCHANGE_ - temp = temp - ExFac*Half*BklK(mijkl) -#endif -* -#ifdef _ACTIVE_ - temp=temp+Thpkl(mijkl) -#endif -* - PMax=Max(PMax,Abs(Temp)) - PSO(mijkl,MemSO2) = Fac * temp -* - End Do - End Do - End Do + +mijkl = 0 +do lAOl=0,lBas-1 + lSOl = lSO+lAOl + + do kAOk=0,kBas-1 + kSOk = kSO+kAOk + + do jAOj=0,jBas-1 + jSOj = jSO+jAOj-nBas(j2) + mijkl = mijkl+1 + +# ifdef _COULOMB_ + Indkl = iPntSO(j3,j4,lOper,nBas)+iTri(kSOk,lSOl) +# endif + + temp = (& +# ifdef _COULOMB_ + +CoulFac*V_k(jSOj,1)*DSO(Indkl,1) & +# endif +# ifdef _EXCHANGE_ + -ExFac_*Half*BklK(mijkl) & +# endif +# ifdef _ACTIVE_ + +Thpkl(mijkl) & +# endif + ) + + PMax = max(PMax,abs(temp)) + PSO(mijkl,MemSO2) = Fac*temp + + end do + end do +end do diff -Nru openmolcas-22.02/src/ri_util/pivot_mat.f openmolcas-22.10/src/ri_util/pivot_mat.f --- openmolcas-22.02/src/ri_util/pivot_mat.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/pivot_mat.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,66 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Francesco Aquilante * -************************************************************************ - SUBROUTINE Pivot_mat(n,m,lu_A0,lu_A,iD_A,Scr,lScr) -************************************************************************ -* -* Author: F. Aquilante -* -************************************************************************ - Implicit Real*8 (a-h,o-z) - Integer n, m, lu_A0, lu_A, iD_A(n), lScr - Real*8 Scr(lScr) -#include "warnings.h" - - lmax=lScr-n - If (lmax .lt. n) Then - Call WarningMessage(2,'Error in Pivot_mat') - write(6,*) ' Pivot_mat: too little scratch space !!' - Call Quit(_RC_CHO_LOG_) - Endif -* - nMem_Col = m - mNeed = nMem_Col*(nMem_Col+1)/2 - Do while (mNeed .gt. lmax) - mNeed = mNeed - nMem_Col - nMem_Col = nMem_Col - 1 - End Do -* - iScr=n - Do kCol=1,nMem_Col - jCol=iD_A(kCol) - iAddr=n*(jCol-1) - Call dDaFile(lu_A0,2,Scr(1),n,iAddr) - Do i=1,kCol - iCol=iD_A(i) - iScr=iScr+1 - Scr(iScr)=Scr(iCol) - End Do - End Do - kAddr=0 - ij=nMem_Col*(nMem_Col+1)/2 - Call dDaFile(lu_A,1,Scr(n+1),ij,kAddr) -* - Do kCol=nMem_Col+1,m - jCol=iD_A(kCol) - iAddr=n*(jCol-1) - Call dDaFile(lu_A0,2,Scr(1),n,iAddr) - Do i=1,kCol - iCol=iD_A(i) - iScr=n+i - Scr(iScr)=Scr(iCol) - End Do - Call dDaFile(lu_A,1,Scr(n+1),kCol,kAddr) - End Do -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/pivot_mat.F90 openmolcas-22.10/src/ri_util/pivot_mat.F90 --- openmolcas-22.02/src/ri_util/pivot_mat.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/pivot_mat.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,73 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Francesco Aquilante * +!*********************************************************************** + +subroutine Pivot_mat(n,m,lu_A0,lu_A,iD_A,Scr,lScr) +!*********************************************************************** +! * +! Author: F. Aquilante * +! * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: n, m, lu_A0, lu_A, iD_A(n), lScr +real(kind=wp), intent(out) :: Scr(lScr) +#include "warnings.h" +integer(kind=iwp) :: i, iAddr, iCol, ij, iScr, jCol, kAddr, kCol, lmax, mNeed, nMem_Col + +lmax = lScr-n +if (lmax < n) then + call WarningMessage(2,'Error in Pivot_mat') + write(u6,*) ' Pivot_mat: too little scratch space !!' + call Quit(_RC_CHO_LOG_) +end if + +nMem_Col = m +mNeed = nTri_Elem(nMem_Col) +do while (mNeed > lmax) + mNeed = mNeed-nMem_Col + nMem_Col = nMem_Col-1 +end do + +iScr = n +do kCol=1,nMem_Col + jCol = iD_A(kCol) + iAddr = n*(jCol-1) + call dDaFile(lu_A0,2,Scr,n,iAddr) + do i=1,kCol + iCol = iD_A(i) + iScr = iScr+1 + Scr(iScr) = Scr(iCol) + end do +end do +kAddr = 0 +ij = nTri_Elem(nMem_Col) +call dDaFile(lu_A,1,Scr(n+1),ij,kAddr) + +do kCol=nMem_Col+1,m + jCol = iD_A(kCol) + iAddr = n*(jCol-1) + call dDaFile(lu_A0,2,Scr,n,iAddr) + do i=1,kCol + iCol = iD_A(i) + iScr = n+i + Scr(iScr) = Scr(iCol) + end do + call dDaFile(lu_A,1,Scr(n+1),kCol,kAddr) +end do + +return + +end subroutine Pivot_mat diff -Nru openmolcas-22.02/src/ri_util/plf_ri_2.f openmolcas-22.10/src/ri_util/plf_ri_2.f --- openmolcas-22.02/src/ri_util/plf_ri_2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/plf_ri_2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,114 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,2005, Roland Lindh * -* 1990, IBM * -************************************************************************ - Subroutine PLF_RI_2(AOint,ijkl,iCmp,jCmp,kCmp,lCmp,iShell, - & iAO,iAOst,Shijij,iBas,jBas,kBas,lBas,kOp, - & TInt,nTInt,iSO2Ind,iOffA,nSOs) -************************************************************************ -* * -* object: to sift and index the petite list format integrals. * -* * -* the indices has been scrambled before calling this routine. * -* Hence we must take special care in order to regain the can- * -* onical order. * -* * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, Ca * -* May '90 * -* Modified to 2-center RI June '05 * -* * -************************************************************************ - use SOAO_Info, only: iAOtSO - use Basis_Info, only: nBas - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" -* - Real*8 AOint(ijkl,jCmp,lCmp), TInt(nTInt) - Integer iShell(4), iAO(4), kOp(4), iAOst(4), - & iSO2Ind(nSOs), iOffA(4) - Logical Shijij -* * -************************************************************************ -* * - iTri(i,j) = Max(i,j)*(Max(i,j)-1)/2 + Min(i,j) -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - irout = 109 - iPrint = nPrint(irout) - iPrint=99 - If (iPrint.ge.49) Then - r1=DDot_(ijkl*jCmp*lCmp,AOInt,1,[One],0) - r2=DDot_(ijkl*jCmp*lCmp,AOInt,1,AOInt,1) - Write (6,*) ' Sum=',r1 - Write (6,*) ' Dot=',r2 - End If - If (iPrint.ge.99) Call RecPrt(' In Plf_RI_2: AOInt',' ', - & AOInt,ijkl,jCmp*lCmp) -#endif -* - iAOstj=iAOst(2) - iAOstl=iAOst(4) - iAOj=iAO(2) - iAOl=iAO(4) - iOff = nBas(0) - iOffA_ = iOffA(1) - mm_= iOffA(4) - nn = mm_ - iOffA(2) - mx = nn*(nn+1)/2 -* -#ifdef _DEBUGPRINT_ - Write (6,*) 'nn,mx=',nn,mx - Write (6,*) 'iOff=',nn,mx - Write (6,*) 'lBas,jBas=',lBas,jBas - Write (6,*) 'lCmp,jCmp=',lCmp,jCmp -#endif -* - Do i2 = 1, jCmp - jSO=iAOtSO(iAOj+i2,kOp(2))+iAOstj - Do i4 = 1, lCmp - lSO=iAOtSO(iAOl+i4,kOp(4))+iAOstl -* - nijkl = 0 - Do lSOl = lSO, lSO+lBas-1 - kSO = lSOl - iOff -* - Do jSOj = jSO, jSO+jBas-1 -* - iSO = jSOj - iOff - nijkl = nijkl + 1 - AInt=AOint(nijkl,i2,i4) -* - iSO = iSO2Ind(iSO) + nn - ij = iTri(iSO,kSO) - mx + iOffA_ - TInt(ij)=AInt -* - End Do - End Do -* - End Do - End Do -* -#ifdef _WARNING_WORKAROUND_ - If (.False.) Then - Call Unused_integer(iCmp) - Call Unused_integer(kCmp) - Call Unused_integer_array(iShell) - Call Unused_logical(Shijij) - Call Unused_integer(iBas) - Call Unused_integer(kBas) - End If -#endif - End diff -Nru openmolcas-22.02/src/ri_util/plf_ri_2.F90 openmolcas-22.10/src/ri_util/plf_ri_2.F90 --- openmolcas-22.02/src/ri_util/plf_ri_2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/plf_ri_2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,101 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,2005, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine PLF_RI_2(AOint,ijkl,jCmp,lCmp,iAO,iAOst,jBas,lBas,kOp,TInt,nTInt,iSO2Ind,iOffA,nSOs) +!*********************************************************************** +! * +! object: to sift and index the petite list format integrals. * +! * +! the indices have been scrambled before calling this routine.* +! Hence we must take special care in order to regain the * +! canonical order. * +! * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, Ca * +! May '90 * +! Modified to 2-center RI June '05 * +! * +!*********************************************************************** + +use Index_Functions, only: iTri, nTri_Elem +use SOAO_Info, only: iAOtSO +use Basis_Info, only: nBas +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: ijkl, jCmp, lCmp, iAO(4), iAOst(4), jBas, lBas, kOp(4), nTInt, nSOs, iSO2Ind(nSOs), iOffA(4) +real(kind=wp), intent(in) :: AOint(ijkl,jCmp,lCmp) +real(kind=wp), intent(_OUT_) :: TInt(nTInt) +integer(kind=iwp) :: i2, i4, iAOj, iAOl, iAOstj, iAOstl, ij, iOff, iOffA_, iSO, jSO, jSOj, kSO, lSO, lSOl, mm_, mx, nijkl, nn + +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +irout = 109 +iPrint = nPrint(irout) +iPrint = 99 +if (iPrint >= 49) then + r1 = DDot_(ijkl*jCmp*lCmp,AOInt,1,[One],0) + r2 = DDot_(ijkl*jCmp*lCmp,AOInt,1,AOInt,1) + write(u6,*) ' Sum=',r1 + write(u6,*) ' Dot=',r2 +end if +if (iPrint >= 99) call RecPrt(' In Plf_RI_2: AOInt',' ',AOInt,ijkl,jCmp*lCmp) +#endif + +iAOstj = iAOst(2) +iAOstl = iAOst(4) +iAOj = iAO(2) +iAOl = iAO(4) +iOff = nBas(0) +iOffA_ = iOffA(1) +mm_ = iOffA(4) +nn = mm_-iOffA(2) +mx = nTri_Elem(nn) + +#ifdef _DEBUGPRINT_ +write(u6,*) 'nn,mx=',nn,mx +write(u6,*) 'iOff=',nn,mx +write(u6,*) 'lBas,jBas=',lBas,jBas +write(u6,*) 'lCmp,jCmp=',lCmp,jCmp +#endif + +do i2=1,jCmp + jSO = iAOtSO(iAOj+i2,kOp(2))+iAOstj + do i4=1,lCmp + lSO = iAOtSO(iAOl+i4,kOp(4))+iAOstl + + nijkl = 0 + do lSOl=lSO,lSO+lBas-1 + kSO = lSOl-iOff + + do jSOj=jSO,jSO+jBas-1 + + iSO = jSOj-iOff + nijkl = nijkl+1 + + iSO = iSO2Ind(iSO)+nn + ij = iTri(iSO,kSO)-mx+iOffA_ + TInt(ij) = AOint(nijkl,i2,i4) + + end do + end do + + end do +end do + +end subroutine PLF_RI_2 diff -Nru openmolcas-22.02/src/ri_util/plf_ri_3.f openmolcas-22.10/src/ri_util/plf_ri_3.f --- openmolcas-22.02/src/ri_util/plf_ri_3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/plf_ri_3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,154 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - Subroutine PLF_RI_3(AOint,ijkl,iCmp,jCmp,kCmp,lCmp,iShell, - & iAO,iAOst,Shijij,iBas,jBas,kBas,lBas,kOp, - & TInt,nTInt,iOff,iShlSO,nBasSh,iSOShl, - & nSO,nShell,nSym,iSSOff) -************************************************************************ -* * -* object: to sift and index the petite list format integrals. * -* * -* the indices has been scrambled before calling this routine. * -* Hence we must take special care in order to regain the can- * -* onical order. * -* * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, Ca * -* May '90 * -* * -************************************************************************ - use Basis_Info, only: nBas - use SOAO_Info, only: iAOtSO - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" -* - Real*8 AOint(ijkl,jCmp,kCmp,lCmp), TInt(nTInt) - Integer iSOShl(nSO), iShlSO(nSO), nBasSh(0:nSym-1,nShell) - Integer iShell(4), iAO(4), kOp(4), iAOst(4), iSOs(4), iOff(3) - Logical Shijij, Shkl -* * -************************************************************************ -* * -*define _DEBUGPRINT_ -* * -************************************************************************ -* * -* Statement function -* - iTri(i,j) = Max(i,j)*(Max(i,j)-1)/2 + Min(i,j) -* * -************************************************************************ -* * - Shkl = iShell(3).eq.iShell(4) - iOff1 = nBas(0) - n3C= iOff(3) - If (iShell(4).gt.iShell(3)) Then - Write (6,*) 'iShell(4).gt.iShell(3)' - Call Abend() - End If -* - Do i2 = 1, jCmp - iSOs(2)=iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) - Do i3 = 1, kCmp - iSOs(3)=iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) - lCmp_Max=lCmp - If (Shkl) lCmp_Max=i3 - Do i4 = 1, lCmp_Max - iSOs(4)=iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) -* * -************************************************************************ -* * - If (Shkl.and.i3.eq.i4) Then -* * -************************************************************************ -* * - nijkl = 0 - Do lSOl = iSOs(4), iSOs(4)+lBas-1 - iD = iShlSO(lSOl) ! Relative index - Do kSOk = iSOs(3), iSOs(3)+kBas-1 - iC = iShlSO(kSOk) - iShC=iSOShl(kSOk) - nC = nBasSh(0,iShC) -* - kl = iTri(iC,iD) + iSSOff -* - Do jSOj = iSOs(2), iSOs(2)+jBas-1 - nijkl = nijkl + 1 - If (lSOl.gt.kSOk) Go To 99 - iAux = jSOj - iOff1 - AInt=AOint(nijkl,i2,i3,i4) -* - kl_B = (iAux-1)*n3C + kl - TInt(kl_B) = AInt -* - 99 Continue -* - End Do - End Do - End Do -* * -************************************************************************ -* * - Else -* * -************************************************************************ -* * - nijkl = 0 - Do lSOl = iSOs(4), iSOs(4)+lBas-1 - iD = iShlSO(lSOl) - Do kSOk = iSOs(3), iSOs(3)+kBas-1 - iC = iShlSO(kSOk) - iShC=iSOShl(kSOk) - nC = nBasSh(0,iShC) -* - If (Shkl) Then - kl = iTri(iC,iD) - Else - kl = (iD-1)*nC + iC - End If - kl = kl + iSSOff -* - Do jSOj = iSOs(2), iSOs(2)+jBas-1 - iAux = jSOj - iOff1 - nijkl = nijkl + 1 - AInt=AOint(nijkl,i2,i3,i4) -* - kl_B = (iAux-1)*n3C + kl - TInt(kl_B) = AInt -* - End Do - End Do - End Do -* * -************************************************************************ -* * - End If -* * -************************************************************************ -* * - End Do - End Do - End Do -* * -************************************************************************ -* * - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(iCmp) - Call Unused_logical(Shijij) - Call Unused_integer(iBas) - End If - End diff -Nru openmolcas-22.02/src/ri_util/plf_ri_3.F90 openmolcas-22.10/src/ri_util/plf_ri_3.F90 --- openmolcas-22.02/src/ri_util/plf_ri_3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/plf_ri_3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,144 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine PLF_RI_3(AOint,ijkl,jCmp,kCmp,lCmp,iShell,iAO,iAOst,jBas,kBas,lBas,kOp,TInt,nTInt,iOff,iShlSO,nBasSh,iSOShl,nSO,nShell, & + nSym,iSSOff) +!*********************************************************************** +! * +! object: to sift and index the petite list format integrals. * +! * +! the indices have been scrambled before calling this routine.* +! Hence we must take special care in order to regain the * +! canonical order. * +! * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, Ca * +! May '90 * +! * +!*********************************************************************** + +use Index_Functions, only: iTri +use Basis_Info, only: nBas +use SOAO_Info, only: iAOtSO +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: ijkl, jCmp, kCmp, lCmp, iShell(4), iAO(4), iAOst(4), jBas, kBas, lBas, kOp(4), nTInt, iOff(3), & + nSO, iShlSO(nSO), nShell, nSym, nBasSh(0:nSym-1,nShell), iSOShl(nSO), iSSOff +real(kind=wp), intent(in) :: AOint(ijkl,jCmp,kCmp,lCmp) +real(kind=wp), intent(_OUT_) :: TInt(nTInt) +integer(kind=iwp) :: i2, i3, i4, iAux, iC, iD, iOff1, iShC, iSOs(4), jSOj, kl, kl_B, kSOk, lCmp_Max, lSOl, n3C, nC, nijkl +logical(kind=iwp) :: Shkl + +! * +!*********************************************************************** +! * +!define _DEBUGPRINT_ +! * +!*********************************************************************** +! * +Shkl = iShell(3) == iShell(4) +iOff1 = nBas(0) +n3C = iOff(3) +if (iShell(4) > iShell(3)) then + write(u6,*) 'iShell(4) > iShell(3)' + call Abend() +end if + +do i2=1,jCmp + iSOs(2) = iAOtSO(iAO(2)+i2,kOp(2))+iAOst(2) + do i3=1,kCmp + iSOs(3) = iAOtSO(iAO(3)+i3,kOp(3))+iAOst(3) + lCmp_Max = lCmp + if (Shkl) lCmp_Max = i3 + do i4=1,lCmp_Max + iSOs(4) = iAOtSO(iAO(4)+i4,kOp(4))+iAOst(4) + ! * + !***************************************************************** + ! * + if (Shkl .and. (i3 == i4)) then + ! * + !*************************************************************** + ! * + nijkl = 0 + do lSOl=iSOs(4),iSOs(4)+lBas-1 + iD = iShlSO(lSOl) ! Relative index + do kSOk=iSOs(3),iSOs(3)+kBas-1 + iC = iShlSO(kSOk) + iShC = iSOShl(kSOk) + nC = nBasSh(0,iShC) + + kl = iTri(iC,iD)+iSSOff + + do jSOj=iSOs(2),iSOs(2)+jBas-1 + nijkl = nijkl+1 + if (lSOl > kSOk) cycle + iAux = jSOj-iOff1 + + kl_B = (iAux-1)*n3C+kl + TInt(kl_B) = AOint(nijkl,i2,i3,i4) + + end do + end do + end do + ! * + !*************************************************************** + ! * + else + ! * + !*************************************************************** + ! * + nijkl = 0 + do lSOl=iSOs(4),iSOs(4)+lBas-1 + iD = iShlSO(lSOl) + do kSOk=iSOs(3),iSOs(3)+kBas-1 + iC = iShlSO(kSOk) + iShC = iSOShl(kSOk) + nC = nBasSh(0,iShC) + + if (Shkl) then + kl = iTri(iC,iD) + else + kl = (iD-1)*nC+iC + end if + kl = kl+iSSOff + + do jSOj=iSOs(2),iSOs(2)+jBas-1 + iAux = jSOj-iOff1 + nijkl = nijkl+1 + + kl_B = (iAux-1)*n3C+kl + TInt(kl_B) = AOint(nijkl,i2,i3,i4) + + end do + end do + end do + ! * + !*************************************************************** + ! * + end if + ! * + !***************************************************************** + ! * + end do + end do +end do +! * +!*********************************************************************** +! * +return + +end subroutine PLF_RI_3 diff -Nru openmolcas-22.02/src/ri_util/plf_ricd.f openmolcas-22.10/src/ri_util/plf_ricd.f --- openmolcas-22.02/src/ri_util/plf_ricd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/plf_ricd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,144 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - Subroutine PLF_RICD(AOint,ijkl,iCmp,jCmp,kCmp,lCmp,iShell, - & iAO,iAOst,Shijij,iBas,jBas,kBas,lBas,kOp, - & TInt,nTInt,mTInt,iTOff,iOffij,iOffkl) -************************************************************************ -* * -* object: to sift and index the petite list format integrals. * -* * -* the indices has been scrambled before calling this routine. * -* Hence we must take special care in order to regain the can- * -* onical order. * -* * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, Ca * -* May '90 * -* * -************************************************************************ - use SOAO_Info, only: iAOtSO - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" -* - Real*8 AOint(ijkl,iCmp,jCmp,kCmp,lCmp), TInt(nTInt,mTInt) - Integer iShell(4), iAO(4), kOp(4), iAOst(4), iSOs(4) - Logical Shijij -#include "ibas_ricd.fh" -* * -************************************************************************ -* * - iTri(i,j)=Max(i,j)*(Max(i,j)-1)/2 + Min(i,j) -* * -************************************************************************ -* * -*define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - r1=DDot_(ijkl*iCmp*jCmp*kCmp*lCmp,AOInt,1,[One],0) - r2=DDot_(ijkl*iCmp*jCmp*kCmp*lCmp,AOInt,1,AOInt,1) - Write (6,*) ' Sum=',r1 - Write (6,*) ' Dot=',r2 - Call RecPrt(' In PLF_RICD: AOInt',' ', - & AOInt,ijkl,iCmp*jCmp*kCmp*lCmp) -#endif -* -* quadruple loop over elements of the basis functions angular -* description. loops are reduced to just produce unique SO integrals -* observe that we will walk through the memory in AOint in a -* sequential way. -* - iAOsti=iAOst(1) - iAOstj=iAOst(2) - iAOstk=iAOst(3) - iAOstl=iAOst(4) -C Write (6,*) 'iAOsti,iAOstj,iAOstk,iAOstl=', -C & iAOsti,iAOstj,iAOstk,iAOstl - iAOi=iAO(1) - iAOj=iAO(2) - iAOk=iAO(3) - iAOl=iAO(4) -C Write (6,*) 'iAOs=',iAO -C Write (6,*) 'kOps=',kOp -C Write (6,*) 'iTOff,iOffij,iOffkl=',iTOff,iOffij,iOffkl -C Write (*,*) 'iBas,jBas,kBas,lBas=',iBas,jBas,kBas,lBas -* -* The writing of the integrals here are shell blocked. -* - Do i1 = 1, iCmp - iSOs(1)=iAOtSO(iAOi+i1,kOp(1))+iAOsti - Do i2 = 1, jCmp - iSOs(2)=iAOtSO(iAOj+i2,kOp(2))+iAOstj - Do i3 = 1, kCmp - iSOs(3)=iAOtSO(iAOk+i3,kOp(3))+iAOstk - Do i4 = 1, lCmp - iSOs(4)=iAOtSO(iAOl+i4,kOp(4))+iAOstl -* - iSO =iSOs(1) - jSO =iSOs(2) - kSO =iSOs(3) - lSO =iSOs(4) -* -C Write (6,*) -C Write (6,*) 'i1,i2,i3,i4,iSOs=',i1,i2,i3,i4,iSOs -C Write (6,*) 'iBas,jBas,kBas,lBas=',iBas,jBas,kBas,lBas -* - nijkl = 0 - Do lSOl = lSO, lSO+lBas-1 - Do kSOk = kSO, kSO+kBas-1 - If (iAO(3).eq.iAO(4)) Then - iSOkl=iTri(kSOk,lSOl) + iOffkl - Else - iSOkl=(kSOk-1)*lCmp*lBas_+ lSOl + iOffkl - End If - Do jSOj = jSO, jSO+jBas-1 - Do iSOi = iSO, iSO+iBas-1 - nijkl = nijkl + 1 - AInt=AOint(nijkl,i1,i2,i3,i4) - If (iAO(1).eq.iAO(2)) Then - iSOij=iTri(iSOi,jSOj) + iOffij - Else - iSOij=(iSOi-1)*jCmp*jBas_+ jSOj + iOffij - End If -* -C Write (6,*) 'iSOij,iSOkl,AInt=', -C & iSOij,iSOkl,AInt - ijSOij=Max(iSOij,iSOkl)-iTOff - klSOkl=Min(iSOij,iSOkl) - TInt(klSOkl,ijSOij)= AInt -* - End Do - End Do - End Do - End Do -* - End Do - End Do - End Do - End Do -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - Call RecPrt('TInt','(45G8.2)',TInt,nTInt,mTInt) -#endif -* * -************************************************************************ -* * - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer_array(iShell) - Call Unused_logical(Shijij) - End If - End diff -Nru openmolcas-22.02/src/ri_util/plf_ricd.F90 openmolcas-22.10/src/ri_util/plf_ricd.F90 --- openmolcas-22.02/src/ri_util/plf_ricd.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/plf_ricd.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,138 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine PLF_RICD(AOint,ijkl,iCmp,jCmp,kCmp,lCmp,iAO,iAOst,iBas,jBas,kBas,lBas,kOp,TInt,nTInt,mTInt,iTOff,iOffij,iOffkl) +!*********************************************************************** +! * +! object: to sift and index the petite list format integrals. * +! * +! the indices have been scrambled before calling this routine.* +! Hence we must take special care in order to regain the * +! canonical order. * +! * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, Ca * +! May '90 * +! * +!*********************************************************************** + +use Index_Functions, only: iTri +use SOAO_Info, only: iAOtSO +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: ijkl, iCmp, jCmp, kCmp, lCmp, iAO(4), iAOst(4), iBas, jBas, kBas, lBas, kOp(4), nTInt, mTInt, & + iTOff, iOffij, iOffkl +real(kind=wp), intent(in) :: AOint(ijkl,iCmp,jCmp,kCmp,lCmp) +real(kind=wp), intent(_OUT_) :: TInt(nTInt,mTInt) +#include "ibas_ricd.fh" +integer(kind=iwp) :: i1, i2, i3, i4, iAOi, iAOj, iAOk, iAOl, iAOsti, iAOstj, iAOstk, iAOstl, ijSOij, iSO, iSOi, iSOij, iSOkl, & + iSOs(4), jSO, jSOj, klSOkl, kSO, kSOk, lSO, lSOl, nijkl + +! * +!*********************************************************************** +! * +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +r1 = DDot_(ijkl*iCmp*jCmp*kCmp*lCmp,AOInt,1,[One],0) +r2 = DDot_(ijkl*iCmp*jCmp*kCmp*lCmp,AOInt,1,AOInt,1) +write(u6,*) ' Sum=',r1 +write(u6,*) ' Dot=',r2 +call RecPrt(' In PLF_RICD: AOInt',' ',AOInt,ijkl,iCmp*jCmp*kCmp*lCmp) +#endif + +! quadruple loop over elements of the basis functions angular +! description. loops are reduced to just produce unique SO integrals +! observe that we will walk through the memory in AOint in a +! sequential way. + +iAOsti = iAOst(1) +iAOstj = iAOst(2) +iAOstk = iAOst(3) +iAOstl = iAOst(4) +!write(u6,*) 'iAOsti,iAOstj,iAOstk,iAOstl=',iAOsti,iAOstj,iAOstk,iAOstl +iAOi = iAO(1) +iAOj = iAO(2) +iAOk = iAO(3) +iAOl = iAO(4) +!write(u6,*) 'iAOs=',iAO +!write(u6,*) 'kOps=',kOp +!write(u6,*) 'iTOff,iOffij,iOffkl=',iTOff,iOffij,iOffkl +!write(u6,*) 'iBas,jBas,kBas,lBas=',iBas,jBas,kBas,lBas + +! The writing of the integrals here are shell blocked. + +do i1=1,iCmp + iSOs(1) = iAOtSO(iAOi+i1,kOp(1))+iAOsti + do i2=1,jCmp + iSOs(2) = iAOtSO(iAOj+i2,kOp(2))+iAOstj + do i3=1,kCmp + iSOs(3) = iAOtSO(iAOk+i3,kOp(3))+iAOstk + do i4=1,lCmp + iSOs(4) = iAOtSO(iAOl+i4,kOp(4))+iAOstl + + iSO = iSOs(1) + jSO = iSOs(2) + kSO = iSOs(3) + lSO = iSOs(4) + + !write(u6,*) + !write(u6,*) 'i1,i2,i3,i4,iSOs=',i1,i2,i3,i4,iSOs + !write(u6,*) 'iBas,jBas,kBas,lBas=',iBas,jBas,kBas,lBas + + nijkl = 0 + do lSOl=lSO,lSO+lBas-1 + do kSOk=kSO,kSO+kBas-1 + if (iAO(3) == iAO(4)) then + iSOkl = iTri(kSOk,lSOl)+iOffkl + else + iSOkl = (kSOk-1)*lCmp*lBas_+lSOl+iOffkl + end if + do jSOj=jSO,jSO+jBas-1 + do iSOi=iSO,iSO+iBas-1 + nijkl = nijkl+1 + if (iAO(1) == iAO(2)) then + iSOij = iTri(iSOi,jSOj)+iOffij + else + iSOij = (iSOi-1)*jCmp*jBas_+jSOj+iOffij + end if + + !write(u6,*) 'iSOij,iSOkl,AOint=',iSOij,iSOkl,AOint(nijkl,i1,i2,i3,i4) + ijSOij = max(iSOij,iSOkl)-iTOff + klSOkl = min(iSOij,iSOkl) + TInt(klSOkl,ijSOij) = AOint(nijkl,i1,i2,i3,i4) + + end do + end do + end do + end do + + end do + end do + end do +end do +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +call RecPrt('TInt','(45G8.2)',TInt,nTInt,mTInt) +#endif +! * +!*********************************************************************** +! * +return + +end subroutine PLF_RICD diff -Nru openmolcas-22.02/src/ri_util/post_2center_ri.f openmolcas-22.10/src/ri_util/post_2center_ri.f --- openmolcas-22.02/src/ri_util/post_2center_ri.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/post_2center_ri.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,302 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991,1993,1998,2005, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Post_2Center_RI(A_Diag) -************************************************************************ -* * -* Object: driver for two-electron integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. * -* Modified for k2 loop. August '91 * -* Modified to minimize overhead for calculations with * -* small basis sets and large molecules. Sept. '93 * -* Modified driver. Jan. '98 * -* Modified to 2-center ERIs for RI June '05 * -************************************************************************ - use Basis_Info, only: nBas_Aux - use Wrj12 - use Gateway_global, only: force_out_of_core - use Symmetry_Info, only: nIrrep - Implicit Real*8 (A-H,O-Z) -#include "setup.fh" -#include "print.fh" -#include "real.fh" -#include "stdalloc.fh" - Real*8, Allocatable:: A_Diag(:) - Integer nDmA(0:7), nDmB(0:7) - Logical Out_of_Core - Character Name_Q*6 - - Real*8, Allocatable :: Scr(:), X(:), Z(:) - Integer, Allocatable :: iDiag(:) - Real*8, Allocatable, Target :: Am(:), Qm(:), A_k(:), Q_k(:) - Real*8, Pointer :: A_l(:)=>Null(), Q_l(:)=>Null() -* * -************************************************************************ -* * - INTERFACE - SUBROUTINE SORT_mat(irc,nDim,nVec,iD_A,nSym,lu_A0,mode,lScr,Scr, - & Diag) - Integer irc - Integer nSym - Integer nDim(nSym) - Integer nVec(nSym) - Integer iD_A(*) - Integer lu_A0(nSym) - Character(LEN=7) mode - Integer lScr - Real*8 Scr(lScr) - Real*8, Optional :: Diag(*) - END SUBROUTINE SORT_mat - END INTERFACE -* * -************************************************************************ -* * - -* * -************************************************************************ -* * -*define _DEBUGPRINT_ -* * -************************************************************************ -* * -* - nScr=0 - nBfn2 = 0 - nBfnTot=0 - Do iIrrep = 0, nIrrep-1 - lJ=nBas_Aux(iIrrep) - If (iIrrep.eq.0) lJ=lJ-1 - nDmA(iIrrep)=lJ - nDmB(iIrrep)=0 - nScr=Max(nScr,3*lJ) - nBfn2 = nBfn2 + lJ**2 - nBfnTot=nBfnTot+lJ - End Do - nA_Diag=nBfnTot -* - Call mma_maxDBLE(MaxMem) -* * -************************************************************************ -* * -* Fill in the lower part of the A matrix as it is stored on disk. -* - Do iIrrep = 0, nIrrep-1 - nB = nBas_Aux(iIrrep) - If (iIrrep.eq.0) nB = nB - 1 ! subtract dummy af - Call Square_A(Lu_A(iIrrep),nB,MaxMem,Force_Out_of_Core) - End Do -* * -************************************************************************ -* * -* Pivoting of the A matrix -* - Call mma_allocate(iDiag,nA_Diag,Label='iDiag') - Call mma_maxDBLE(MaxMem2) -* - If (Force_Out_of_Core) MaxMem2=3*nBfnTot -* lScr=Min(MaxMem2,nScr) - lScr=Max(MaxMem2-(nScr/3),nScr) - Call mma_allocate(Scr,lScr,Label='Scr') -* - Call SORT_mat(irc,nDmA,nDmB,iDiag,nIrrep, - & LU_A,'GePivot',lScr,Scr,Diag=A_Diag) - ichk=0 - Do iIrrep = 0, nIrrep-1 - nChV(iIrrep)=nDmB(iIrrep) - ichk=ichk+Min(1,nDmA(iIrrep)-nDmB(iIrrep)) - End Do - If (ichk.ne.0) Then - write(6,*) - write(6,*)'Post_2Center_RI' - write(6,*)'Detected lin. dependences in the auxiliary basis.' - Write(6,'(A,8I6)') - & ' # of AuxBas before l. d. removal: ',(nDmA(i),i=0,nIrrep-1) - Write(6,'(A,8I6)') - & ' # of AuxBas after l. d. removal: ',(nDmB(i),i=0,nIrrep-1) - write(6,*) - EndIf -* - Call SORT_mat(irc,nDmA,nDmB,iDiag,nIrrep, - & LU_A,'DoPivot',lScr,Scr) -* -* Note: after the 'DoPivot' call to Sort_mat, the A-matrix is -* no longer stored as squared but as upper-triangular -* - Call mma_deallocate(Scr) - Call mma_deallocate(A_Diag) -* -************************************************************************ -* A-vectors are now on disk. Go ahead and compute the Q-vectors! -************************************************************************ -* - ThrQ=1.0d-14 ! Threshold for Inv_Cho_Factor -* - Do iIrrep = 0, nIrrep-1 -c nB=nBas_Aux(iIrrep) -c If (iIrrep.eq.0) nB = nB - 1 - nB=nDmB(iIrrep) - If (nB.eq.0) Go To 777 - nQm=nB*(nB+1)/2 -* - nXZ=nB - nQm_full= nB*(nB+1)/2 -* - If (Force_Out_of_Core) MaxMem=(8*(2*nQm_full+5*nXZ))/10 - Out_of_Core=2*nQm_full+5*nXZ.gt.MaxMem -* - If (Out_Of_Core) Then - mQm=(nQm*MaxMem-5*nXZ)/(2*nQm_full) - a=One - b=-Two*DBLE(mQm) - mB=INT(-a/Two + Sqrt( (a/Two)**2 - b )) - kQm=mB*(mB+1)/2 - If (kQm.gt.mQm) Then - Call WarningMessage(2,'Error in Post_2Center_RI') - Write (6,*) 'kQm.gt.mQm!' - Write (6,*) 'MaxMem=',MaxMem - Write (6,*) 'nQm,mQm,kQm=',nQm,mQm,kQm - Write (6,*) 'nB,mB=',nB,mB - Call Abend() - End If - Else - mB = nB - kQm = nQm - End If -* - lQm=kQm - lAm=lQm -* - If (lQm.lt.1) Then - Call WarningMessage(2,'Error in Post_2Center_RI') - Write (6,*) 'lQm.lt.1' - Call Abend() - End If -* -* Some of memory for scratch arrays for Inv_Cho_Factor -* Allocate memory for the A- and Q-vectors and initialize. -* - lScr=nXZ - Call mma_allocate(Scr,lScr,Label='Scr') - Call mma_allocate(Z,nXZ,Label='Z') - Call mma_allocate(X,nXZ,Label='X') - Call mma_allocate(Am,lAm,Label='Am') - Call mma_allocate(Qm,lQm,Label='Qm') - Call mma_allocate(A_k,nXZ,Label='A_k') - Call mma_allocate(Q_k,nXZ,Label='Q_k') -* - Am(:)=Zero - Qm(:)=Zero -* * -*----------------------------------------------------------------------* -* * -* Process the A_ks to generate Q_ks. -* - iSeed=55+iIrrep - Lu_Q(iIrrep)=IsFreeUnit(iSeed) - Write(Name_Q,'(A4,I2.2)') 'QMAT',iIrrep - Call DaName_MF_WA(Lu_Q(iIrrep),Name_Q) -* - iAddr=0 - nMem=mB - Do kCol = 1, nB -* - iAddr_=iAddr - If (kCol.le.nMem) Then -* Point to A_k in Am - iOff = (kCol-1)*kCol/2 - A_l(1:kCol) => Am(iOff+1:iOff+kCol) - If (kCol.eq.1) Then - nAm=nMem*(nMem+1)/2 - Call dDaFile(Lu_A(iIrrep),2,Am,nAm,iAddr_) - End If -* Point to Q_k in Qm - Q_l(1:kCol) => Qm(iOff+1:iOff+kCol) - Else If (kCol.gt.nMem) Then -* Use special scratch for A_k - A_l(1:kCol) => A_k(1:kCol) - Call dDaFile(Lu_A(iIrrep),2,A_l,kCol,iAddr_) -* Use special scratch for Q_k - Q_l(1:kCol) => Q_k(1:kCol) - End If -* - LinDep=2 - Call Inv_Cho_Factor(A_l,kCol, - & Am,Qm,nMem, - & Lu_A(iIrrep),Lu_Q(iIrrep), - & Scr,lScr, - & Z,X,ThrQ, - & Q_l,LinDep) - - If (LinDep.ne.0) Then - Call WarningMessage(2,'Error in Post_2Center_RI') - Write(6,*) 'Inv_Cho_Factor found linear dependence!' - Call Abend() - End If -* -* Write the new A/Q-vector to file -* - iAddr_=iAddr - If (kCol.eq.nMem) Then - nQm=kCol*(kCol+1)/2 - Call dDaFile(Lu_Q(iIrrep),1,Qm,nQm,iAddr ) - Call dDaFile(Lu_A(iIrrep),1,Am,nQm,iAddr_) - Else If (kCol.gt.nMem) Then - Call dDaFile(Lu_Q(iIrrep),1,Q_l,kCol,iAddr ) - Call dDaFile(Lu_A(iIrrep),1,A_l,kCol,iAddr_) - End If -* - End Do -* - Q_l=>Null() - A_l=>Null() - Call mma_deallocate(Q_k) - Call mma_deallocate(A_k) - Call mma_deallocate(Qm) - Call mma_deallocate(Am) - Call mma_deallocate(X) - Call mma_deallocate(Z) - Call mma_deallocate(Scr) - Call DaClos(Lu_A(iIrrep)) - 777 Continue - End Do ! iIrrep -* * -*----------------------------------------------------------------------* -* * -* Sort the Q-matrix back to the original order. -* - Call mma_maxDBLE(MaxMem2) -* - If (Force_Out_of_Core) MaxMem2=2*nBfnTot - lScr=Min(MaxMem2,Max(nBfn2,2*nBfnTot)) - Call mma_allocate(Scr,lScr,Label='Scr') -* - Call SORT_mat(irc,nDmA,nDmB,iDiag,nIrrep, - & LU_Q,'Restore',lScr,Scr) -* -* Note: after the 'Restore' call to Sort_mat, the Q-matrix is -* no longer stored as upper-triangular but as RECTANGULAR -* (nDmA,nDmB). The column index is still pivoted. -* - Call mma_deallocate(Scr) - Call mma_deallocate(iDiag) -* * -************************************************************************ -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/ri_util/post_2center_ri.F90 openmolcas-22.10/src/ri_util/post_2center_ri.F90 --- openmolcas-22.02/src/ri_util/post_2center_ri.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/post_2center_ri.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,274 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991,1993,1998,2005, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Post_2Center_RI(A_Diag) +!*********************************************************************** +! * +! Object: driver for two-electron integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. * +! Modified for k2 loop. August '91 * +! Modified to minimize overhead for calculations with * +! small basis sets and large molecules. Sept. '93 * +! Modified driver. Jan. '98 * +! Modified to 2-center ERIs for RI June '05 * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem +use Basis_Info, only: nBas_Aux +use RI_glob, only: Lu_A, Lu_Q, nChV +use Gateway_global, only: force_out_of_core +use Symmetry_Info, only: nIrrep +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Half +use Definitions, only: wp, iwp, u6 + +implicit none +real(kind=wp), intent(inout) :: A_Diag(*) +integer(kind=iwp) :: i, iAddr, iAddr_, ichk, iIrrep, iOff, irc, iSeed, kCol, kQm, lAm, LinDep, lJ, lQm, lScr, MaxMem, MaxMem2, mB, & + mQm, nA_Diag, nAm, nB, nBfn2, nBfnTot, nDmA(0:7), nDmB(0:7), nMem, nQm, nQm_full, nScr, nXZ +real(kind=wp) :: a, b, dum(1), ThrQ +logical(kind=iwp) :: Out_of_Core +character(len=6) :: Name_Q +integer(kind=iwp), allocatable :: iDiag(:) +real(kind=wp), allocatable :: Scr(:), X(:), Z(:) +real(kind=wp), allocatable, target :: A_k(:), Am(:), Q_k(:), Qm(:) +real(kind=wp), pointer :: A_l(:), Q_l(:) +integer(kind=iwp), external :: IsFreeUnit + +! * +!*********************************************************************** +! * +!define _DEBUGPRINT_ +! * +!*********************************************************************** +! * + +nScr = 0 +nBfn2 = 0 +nBfnTot = 0 +do iIrrep=0,nIrrep-1 + lJ = nBas_Aux(iIrrep) + if (iIrrep == 0) lJ = lJ-1 + nDmA(iIrrep) = lJ + nDmB(iIrrep) = 0 + nScr = max(nScr,3*lJ) + nBfn2 = nBfn2+lJ**2 + nBfnTot = nBfnTot+lJ +end do +nA_Diag = nBfnTot + +call mma_maxDBLE(MaxMem) +! * +!*********************************************************************** +! * +! Fill in the lower part of the A matrix as it is stored on disk. + +do iIrrep=0,nIrrep-1 + nB = nBas_Aux(iIrrep) + if (iIrrep == 0) nB = nB-1 ! subtract dummy af + call Square_A(Lu_A(iIrrep),nB,MaxMem,Force_Out_of_Core) +end do +! * +!*********************************************************************** +! * +! Pivoting of the A matrix + +call mma_allocate(iDiag,nA_Diag,Label='iDiag') +call mma_maxDBLE(MaxMem2) + +if (Force_Out_of_Core) MaxMem2 = 3*nBfnTot +!lScr = Min(MaxMem2,nScr) +lScr = max(MaxMem2-(nScr/3),nScr) +call mma_allocate(Scr,lScr,Label='Scr') + +call SORT_mat(irc,nDmA,nDmB,iDiag,nIrrep,Lu_A,'GePivot',lScr,Scr,A_Diag) +ichk = 0 +do iIrrep=0,nIrrep-1 + nChV(iIrrep) = nDmB(iIrrep) + ichk = ichk+min(1,nDmA(iIrrep)-nDmB(iIrrep)) +end do +if (ichk /= 0) then + write(u6,*) + write(u6,*) 'Post_2Center_RI' + write(u6,*) 'Detected lin. dependences in the auxiliary basis.' + write(u6,'(A,8I6)') ' # of AuxBas before l. d. removal: ',(nDmA(i),i=0,nIrrep-1) + write(u6,'(A,8I6)') ' # of AuxBas after l. d. removal: ',(nDmB(i),i=0,nIrrep-1) + write(u6,*) +end if + +call SORT_mat(irc,nDmA,nDmB,iDiag,nIrrep,Lu_A,'DoPivot',lScr,Scr,dum) + +! Note: after the 'DoPivot' call to Sort_mat, the A-matrix is +! no longer stored as squared but as upper-triangular + +call mma_deallocate(Scr) + +!*********************************************************************** +! A-vectors are now on disk. Go ahead and compute the Q-vectors! +!*********************************************************************** + +ThrQ = 1.0e-14_wp ! Threshold for Inv_Cho_Factor + +do iIrrep=0,nIrrep-1 + !nB = nBas_Aux(iIrrep) + !if (iIrrep == 0) nB = nB-1 + nB = nDmB(iIrrep) + if (nB == 0) cycle + nQm = nTri_Elem(nB) + + nXZ = nB + nQm_full = nTri_Elem(nB) + + if (Force_Out_of_Core) MaxMem = (8*(2*nQm_full+5*nXZ))/10 + Out_of_Core = 2*nQm_full+5*nXZ > MaxMem + + if (Out_Of_Core) then + mQm = (nQm*MaxMem-5*nXZ)/(2*nQm_full) + a = One + b = -Two*real(mQm,kind=wp) + mB = int(-a*Half+sqrt((a*Half)**2-b)) + kQm = nTri_Elem(mB) + if (kQm > mQm) then + call WarningMessage(2,'Error in Post_2Center_RI') + write(u6,*) 'kQm > mQm!' + write(u6,*) 'MaxMem=',MaxMem + write(u6,*) 'nQm,mQm,kQm=',nQm,mQm,kQm + write(u6,*) 'nB,mB=',nB,mB + call Abend() + end if + else + mB = nB + kQm = nQm + end if + + lQm = kQm + lAm = lQm + + if (lQm < 1) then + call WarningMessage(2,'Error in Post_2Center_RI') + write(u6,*) 'lQm < 1' + call Abend() + end if + + ! Some of memory for scratch arrays for Inv_Cho_Factor + ! Allocate memory for the A- and Q-vectors and initialize. + + lScr = nXZ + call mma_allocate(Scr,lScr,Label='Scr') + call mma_allocate(Z,nXZ,Label='Z') + call mma_allocate(X,nXZ,Label='X') + call mma_allocate(Am,lAm,Label='Am') + call mma_allocate(Qm,lQm,Label='Qm') + call mma_allocate(A_k,nXZ,Label='A_k') + call mma_allocate(Q_k,nXZ,Label='Q_k') + + Am(:) = Zero + Qm(:) = Zero + ! * + !--------------------------------------------------------------------* + ! * + ! Process the A_ks to generate Q_ks. + + iSeed = 55+iIrrep + Lu_Q(iIrrep) = IsFreeUnit(iSeed) + write(Name_Q,'(A4,I2.2)') 'QMAT',iIrrep + call DaName_MF_WA(Lu_Q(iIrrep),Name_Q) + + iAddr = 0 + nMem = mB + do kCol=1,nB + + iAddr_ = iAddr + if (kCol <= nMem) then + ! Point to A_k in Am + iOff = nTri_Elem(kCol-1) + A_l(1:kCol) => Am(iOff+1:iOff+kCol) + if (kCol == 1) then + nAm = nTri_Elem(nMem) + call dDaFile(Lu_A(iIrrep),2,Am,nAm,iAddr_) + end if + ! Point to Q_k in Qm + Q_l(1:kCol) => Qm(iOff+1:iOff+kCol) + else if (kCol > nMem) then + ! Use special scratch for A_k + A_l(1:kCol) => A_k(1:kCol) + call dDaFile(Lu_A(iIrrep),2,A_l,kCol,iAddr_) + ! Use special scratch for Q_k + Q_l(1:kCol) => Q_k(1:kCol) + end if + + LinDep = 2 + call Inv_Cho_Factor(A_l,kCol,Am,Qm,nMem,Lu_A(iIrrep),Lu_Q(iIrrep),Scr,lScr,Z,X,ThrQ,Q_l,LinDep) + + if (LinDep /= 0) then + call WarningMessage(2,'Error in Post_2Center_RI') + write(u6,*) 'Inv_Cho_Factor found linear dependence!' + call Abend() + end if + + ! Write the new A/Q-vector to file + + iAddr_ = iAddr + if (kCol == nMem) then + nQm = nTri_Elem(kCol) + call dDaFile(Lu_Q(iIrrep),1,Qm,nQm,iAddr) + call dDaFile(Lu_A(iIrrep),1,Am,nQm,iAddr_) + else if (kCol > nMem) then + call dDaFile(Lu_Q(iIrrep),1,Q_l,kCol,iAddr) + call dDaFile(Lu_A(iIrrep),1,A_l,kCol,iAddr_) + end if + + end do + + nullify(Q_l,A_l) + call mma_deallocate(Q_k) + call mma_deallocate(A_k) + call mma_deallocate(Qm) + call mma_deallocate(Am) + call mma_deallocate(X) + call mma_deallocate(Z) + call mma_deallocate(Scr) + call DaClos(Lu_A(iIrrep)) +end do ! iIrrep +! * +!----------------------------------------------------------------------* +! * +! Sort the Q-matrix back to the original order. + +call mma_maxDBLE(MaxMem2) + +if (Force_Out_of_Core) MaxMem2 = 2*nBfnTot +lScr = min(MaxMem2,max(nBfn2,2*nBfnTot)) +call mma_allocate(Scr,lScr,Label='Scr') + +call SORT_mat(irc,nDmA,nDmB,iDiag,nIrrep,Lu_Q,'Restore',lScr,Scr,dum) + +! Note: after the 'Restore' call to Sort_mat, the Q-matrix is +! no longer stored as upper-triangular but as RECTANGULAR +! (nDmA,nDmB). The column index is still pivoted. + +call mma_deallocate(Scr) +call mma_deallocate(iDiag) +! * +!*********************************************************************** +!*********************************************************************** +! * +return + +end subroutine Post_2Center_RI diff -Nru openmolcas-22.02/src/ri_util/put_chunk.f openmolcas-22.10/src/ri_util/put_chunk.f --- openmolcas-22.02/src/ri_util/put_chunk.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/put_chunk.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Put_Chunk(MuNu_s,MuNu_e,j_s,j_e,Rv,nMuNu,LenVec) - Use Chunk_Mod -#ifdef _MOLCAS_MPP_ - Use Para_Info, Only: Is_Real_Par -#endif - Implicit Real*8 (A-H,O-Z) - Real*8 Rv(nMuNu,(j_e-j_s+1)) -* * -************************************************************************ -* * -#ifdef _MOLCAS_MPP_ -* - NumVec_ = j_e - j_s + 1 - If (NumVec_ .gt. 0) Then - If (Is_Real_Par()) Then - Call GA_Put(ip_Chunk,MuNu_s,MuNu_e,j_s,j_e,Rv,nMuNu) - Else - mMuNu=MuNu_s-1 - jp_ChoVec=1+mMuNu - Do jVec = 1, NumVec_ - call dcopy_(nMuNu,Rv(1,jVec),1,Chunk(jp_ChoVec),1) - jp_ChoVec = jp_ChoVec + LenVec - End Do - End If - End If -* -#else -* - mMuNu=MuNu_s-1 - NumVec_ = j_e - j_s + 1 -* - jp_ChoVec=1+mMuNu - Do jVec = 1, NumVec_ - call dcopy_(nMuNu,Rv(1,jVec),1,Chunk(jp_ChoVec),1) - jp_ChoVec = jp_ChoVec + LenVec - End Do -* -c Avoid unused argument warnings - If (.False.) Call Unused_integer(MuNu_e) -#endif -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/ri_util/put_chunk.F90 openmolcas-22.10/src/ri_util/put_chunk.F90 --- openmolcas-22.02/src/ri_util/put_chunk.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/put_chunk.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,59 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Put_Chunk(MuNu_s,MuNu_e,j_s,j_e,Rv,nMuNu,LenVec) + +use RI_glob, only: Chunk +#ifdef _MOLCAS_MPP_ +use RI_glob, only: ip_Chunk +use Para_Info, only: Is_Real_Par +#endif +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: MuNu_s, MuNu_e, j_s, j_e, nMuNu, LenVec +real(kind=wp), intent(inout) :: Rv(nMuNu,j_e-j_s+1) +integer(kind=iwp) :: jp_ChoVec, jVec, mMuNu, NumVec_ + +#ifndef _MOLCAS_MPP_ +#include "macros.fh" +unused_var(MuNu_e) +#endif + +! * +!*********************************************************************** +! * + +NumVec_ = j_e-j_s+1 + +#ifdef _MOLCAS_MPP_ +if (NumVec_ > 0) then + if (Is_Real_Par()) then + call GA_Put(ip_Chunk,MuNu_s,MuNu_e,j_s,j_e,Rv,nMuNu) + else +#endif + mMuNu = MuNu_s-1 + jp_ChoVec = 1+mMuNu + do jVec=1,NumVec_ + Chunk(jp_ChoVec:jp_ChoVec+nMuNu-1) = Rv(:,jVec) + jp_ChoVec = jp_ChoVec+LenVec + end do +#ifdef _MOLCAS_MPP_ + end if +end if +#endif + +! * +!*********************************************************************** +! * +return + +end subroutine Put_Chunk diff -Nru openmolcas-22.02/src/ri_util/remap_u_k.f openmolcas-22.10/src/ri_util/remap_u_k.f --- openmolcas-22.02/src/ri_util/remap_u_k.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/remap_u_k.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,28 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine ReMap_U_k(U_k,nU_k,U_k_New,nU_k_New,iSO_ab) - Implicit Real*8 (A-H,O-Z) - Real*8 U_k(nU_k), U_k_New(nU_k_New) - Integer iSO_ab(2,nU_k) -* - Do k=1,nU_k - i=iSO_ab(1,k) - j=iSO_ab(2,k) - ij=i*(i-1)/2 + j - If (i.eq.j) Then - U_k_New(ij) = U_k(k) - Else - U_k_New(ij) = 0.5D0*U_k(k) - End If - End Do - - Return - End diff -Nru openmolcas-22.02/src/ri_util/remap_u_k.F90 openmolcas-22.10/src/ri_util/remap_u_k.F90 --- openmolcas-22.02/src/ri_util/remap_u_k.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/remap_u_k.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,37 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine ReMap_U_k(U_k,nU_k,U_k_New,nU_k_New,iSO_ab) + +use Index_Functions, only: nTri_Elem +use Constants, only: Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nU_k, nU_k_New, iSO_ab(2,nU_k) +real(kind=wp), intent(in) :: U_k(nU_k) +real(kind=wp), intent(out) :: U_k_New(nU_k_New) +integer(kind=iwp) :: i, ij, j, k + +do k=1,nU_k + i = iSO_ab(1,k) + j = iSO_ab(2,k) + ij = nTri_Elem(i-1)+j + if (i == j) then + U_k_New(ij) = U_k(k) + else + U_k_New(ij) = Half*U_k(k) + end if +end do + +return + +end subroutine ReMap_U_k diff -Nru openmolcas-22.02/src/ri_util/remap_v_k.f openmolcas-22.10/src/ri_util/remap_v_k.f --- openmolcas-22.02/src/ri_util/remap_v_k.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/remap_v_k.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine ReMap_V_k(iSym,V_k,nV_k,V_k_New,nV_k_New,iSO_ab,ij2K, - & m_ij2K) - Implicit Real*8 (A-H,O-Z) - Real*8 V_k(nV_k), V_k_New(nV_k_New) - Integer iSym, iSO_ab(2,nV_k), ij2K(m_ij2K) -* - If (iSym .eq. 1) Then - Do k=1,nV_k - i=iSO_ab(1,k) - j=iSO_ab(2,k) - ij=i*(i-1)/2 + j - If (i.eq.j) Then - V_k_New(ij) = V_k(k) - Else - V_k_New(ij) = 0.5D0*V_k(k) - End If - ij2K(ij)=k - End Do -* -c write(6,*) 'Triang <Vk|Vk> : ',ddot_(nV_k_New,V_k_New,1, -c & V_k_New,1) -* - Else - - Do k=1,nV_k - i=iSO_ab(1,k) - j=iSO_ab(2,k) - ij=i*(i-1)/2 + j - ij2K(ij)=k - End Do - EndIf -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/remap_v_k.F90 openmolcas-22.10/src/ri_util/remap_v_k.F90 --- openmolcas-22.02/src/ri_util/remap_v_k.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/remap_v_k.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,54 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine ReMap_V_k(iSym,V_k,nV_k,V_k_New,nV_k_New,iSO_ab,ij2K,m_ij2K) + +use Index_Functions, only: nTri_Elem +use Constants, only: Half +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: iSym, nV_k, nV_k_New, iSO_ab(2,nV_k), m_ij2K +real(kind=wp), intent(in) :: V_k(nV_k) +real(kind=wp), intent(_OUT_) :: V_k_New(nV_k_New) +integer(kind=iwp), intent(out) :: ij2K(m_ij2K) +integer(kind=iwp) :: i, ij, j, k + +if (iSym == 1) then + do k=1,nV_k + i = iSO_ab(1,k) + j = iSO_ab(2,k) + ij = nTri_Elem(i-1)+j + if (i == j) then + V_k_New(ij) = V_k(k) + else + V_k_New(ij) = Half*V_k(k) + end if + ij2K(ij) = k + end do + + !write(u6,*) 'Triang <Vk|Vk> : ',ddot_(nV_k_New,V_k_New,1,V_k_New,1) + +else + + do k=1,nV_k + i = iSO_ab(1,k) + j = iSO_ab(2,k) + ij = nTri_Elem(i-1)+j + ij2K(ij) = k + end do +end if + +return + +end subroutine ReMap_V_k diff -Nru openmolcas-22.02/src/ri_util/remove_high_exponents.F90 openmolcas-22.10/src/ri_util/remove_high_exponents.F90 --- openmolcas-22.02/src/ri_util/remove_high_exponents.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/remove_high_exponents.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,65 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 2007,2008, Roland Lindh * +!*********************************************************************** + +subroutine Remove_High_Exponents(iD,nD,List2,mData,nTheta_All) +!*********************************************************************** +! * +! Experimental code to be used with care. * +! * +!*********************************************************************** + +use Basis_Info, only: Shells +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(inout) :: nD, iD(nD) +integer(kind=iwp), intent(in) :: mData, nTheta_All, List2(mData,nTheta_All) +integer(kind=iwp) :: i, iTheta_All, k, kAng, kShll, l, lAng, lShll, mD +logical(kind=iwp) :: Skip + +call iVcPrt('Remove_High_Exponents: iD',' ',iD,nD) +mD = nD +i = 1 +do + iTheta_All = iD(i) + Skip = .false. + kAng = List2(1,iTheta_All) + lAng = List2(2,iTheta_All) + k = List2(5,iTheta_All) + l = List2(6,iTheta_All) + kShll = List2(7,iTheta_All) + lShll = List2(8,iTheta_All) + if (kAng == lAng) then + l = List2(6,iTheta_All) + Skip = ((k == 1) .and. (l == 1)) .and. (Shells(kShll)%nExp /= 1) + else + Skip = (l == 1) .and. (Shells(lShll)%nExp /= 1) + end if + if (Skip) then + if (mD == i) then + mD = mD-1 + exit + end if + iD(i:mD-1) = iD(i+1:mD) + mD = mD-1 + cycle + end if + i = i+1 + if (i > mD) exit +end do +nD = mD +call iVcPrt('Remove_High_Exponents: iD',' ',iD,nD) + +return + +end subroutine Remove_High_Exponents diff -Nru openmolcas-22.02/src/ri_util/renorm2.f openmolcas-22.10/src/ri_util/renorm2.f --- openmolcas-22.02/src/ri_util/renorm2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/renorm2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,268 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 2008, Roland Lindh * -************************************************************************ - Subroutine ReNorm2(iCnttp) - use Wrj12 -* - Call ICopy(4*8,[0],0,iOffA,1) - Do ire_do = 1, 2 -* - Call ReNorm2_Internal(iCnttp) -* - End Do -* - Return - End - Subroutine ReNorm2_Internal(iCnttp) -************************************************************************ -* * -* Objective: Orthonormalize parts of the auxiliary basis set. * -* * -* Called from: Mk_RICD_Shells * -* * -* Author: Roland Lindh, Dept. of Theor. Chemi., Lund Univ., Sweden.* -* * -* Modified to transform the auxiliary basis to a true * -* Cholesky basis set while on TACC 2008 conference in * -* Songjiang District, Shanghai, China, 23-27 Sept. 2008. * -* * -************************************************************************ - use SOAO_Info, only: iAOtSO, nSOInf - use Real_Spherical - use Basis_Info - use Sizes_of_Seward, only: S - use RICD_Info, only: Thrshld_CD - Implicit Real*8 (A-H,O-Z) - External Integral_RI_2 -#include "itmax.fh" -#include "SysDef.fh" -#include "real.fh" -#include "print.fh" -#include "status.fh" -#include "stdalloc.fh" - Real*8, Allocatable :: TInt_c(:), TInt_d(:), Tmp(:), QVec(:) - Real*8, Allocatable :: Not_Used(:) - Logical In_Core - - Real*8, Allocatable :: ADiag(:) - Integer, Allocatable :: iADiag(:) -* * -************************************************************************ -* * - Interface - Subroutine Drv2El_Atomic_NoSym(Integral_RI_2, - & ThrAO,iCnttp,jCnttp, - & TInt_c,nTInt_c, - & In_Core,ADiag,Lu_A, - & ijS_req,Keep_Shell) - External Integral_RI_2 - Real*8 ThrAO - Integer iCnttp, jCnttp, nTInt_c, Lu_A,ijS_req, Keep_Shell - Real*8, Allocatable :: TInt_c(:), ADiag(:) - Logical In_Core - End Subroutine - End Interface -* * -************************************************************************ -* * -!#define _DEBUGPRINT_ -* * -************************************************************************ -* * -* Let us now Gram-Schmidt orthonormalize the auxiliary basis for -* better numerics and balance. -* -* Update kOffAO and lOffAO to include the auxiliary basis too. -* - Call Setup_OffAO() -* -* Set up transformation matrix from Cartesian to real spherical -* harmonics. -* - Call Sphere(S%iAngMx) -* - Call Flip_Flop(.False.) ! Contracted mode. -* - Thr_CB=Max(1.0D-14,Thrshld_CD*1.0D-10) - ThrAO=Zero -* -* Do iCnttp = 1, nCnttp -* Skip the dummy shell - If (iCnttp==iCnttp_dummy) Return -* skip non-auxiliary basis sets - If (.Not.dbsc(iCnttp)%Aux) Return -* * -************************************************************************ -* * -* Define some parameters to facilitate the atomic calculation -* - S%nShlls= dbsc(iCnttp)%nVal - nTest = dbsc(iCnttp)%nVal-1 -* -* Define AOtSO -* - iAO = 0 - iSO = 0 - nSO=0 - Do iAng = 0, nTest - iShll_ = dbsc(iCnttp)%iVal + iAng - nCmp = (iAng+1)*(iAng+2)/2 - If (Shells(iShll_)%Prjct) nCmp = 2*iAng+1 - iSO = 0 - If (Shells(iShll_)%nBasis_C*Shells(iShll_)%nExp==0) Cycle - Do iCmp = 1, nCmp - iAO = iAO + 1 - If (iAO>nSOInf) Then - Write (6,*) 'renorm2_internal: iAO>nSOInf' - Write (6,*) 'iAO=',iAO - Write (6,*) 'nSOInf=',nSOInf - Call Abend() - End If - iAOtSO(iAO,0) = iSO + 1 - iSO = iSO + Shells(iShll_)%nBasis - End Do - nSO=nSO+iSO - End Do -* - ijS_req=0 - Keep_Shell=iTabMx - Do iAng = 0, nTest - iShll = dbsc(iCnttp)%iVal + iAng - nExpi = Shells(iShll)%nExp - nBasisi=Shells(iShll)%nBasis - If (nExpi*nBasisi.eq.0) Cycle -* - nCmp = (iAng+1)*(iAng+2)/2 - If (Shells(iShll)%Prjct) nCmp = 2*iAng+1 -* - ijS_req=ijS_req+1 -* - Call Drv2El_Atomic_NoSym(Integral_RI_2, - & ThrAO,iCnttp,iCnttp, - & TInt_c,nTInt_c, - & In_Core,Not_Used,Lu_A,ijS_req, - & Keep_Shell) -#ifdef _DEBUGPRINT_ - Call TriPrt('TInt_c',' ',TInt_c,nTInt_c) -#endif -* - If (.NOT.In_Core) Then - Call WarningMessage(2,'Error in ReNorm') - Write (6,*) 'Out-of-core acCD not implemented!' - Call Abend() - End If -* -* Produce the reduced set, in-place reduction. -* - Call mma_allocate(TInt_d,nTInt_c**2,Label='TInt_d') - ijT=0 - Do iBas = 1, nTInt_c - Do jBas = 1, iBas - ijT=ijT+1 - ijS=(jBas-1)*nTInt_c+iBas - jiS=(iBas-1)*nTInt_c+jBas - TInt_d(ijS)=TInt_c(ijT) - TInt_d(jiS)=TInt_c(ijT) - End Do - End Do - Call mma_deallocate(TInt_c) -#ifdef _DEBUGPRINT_ - Call RecPrt('TInt_d',' ',TInt_d,nTInt_c,nTInt_c) -#endif -* - ij=0 - iCmp=1 - jCmp=1 - Do jBas = 1, nBasisi - j=(jCmp-1)*nBasisi+jBas - Do iBas = 1, nBasisi - i=(iCmp-1)*nBasisi+iBas - ijF=(j-1)*nBasisi*nCmp+i - ij=ij+1 -* - TInt_d(ij)=TInt_d(ijF) -* - End Do - End Do -#ifdef _DEBUGPRINT_ - Call RecPrt('TInt_d(r)','(5G20.10)',TInt_d,nBasisi,nBasisi) -#endif -* - Call mma_allocate( ADiag,nBasisi,Label=' ADiag') - Call mma_allocate(iADiag,nBasisi,Label='iADiag') -* - iSeed=77 - Lu_A=IsFreeUnit(iSeed) - Call DaName_MF_WA(Lu_A,'AMat09') -* - iDisk=0 - Call dDaFile(Lu_A,1,TInt_d,nBasisi**2,iDisk) -* - iSeed=iSeed+1 - Lu_Q=IsFreeUnit(iSeed) - Call DaName_MF_WA(Lu_Q,'QMat09') -* - call dcopy_(nBasisi,TInt_d,nBasisi+1,ADiag,1) -* - Call CD_AInv_(nBasisi,m,ADiag,iADiag,Lu_A,Lu_Q,Thr_CB) -* - Call mma_deallocate(iADiag) - Call mma_deallocate( ADiag) - Call mma_deallocate(TInt_d) -* -* Transform the contraction coefficients according to the -* Cholesky vectors. -* - Call mma_allocate(Tmp,nBasisi*nExpi,Label='Tmp') - Call mma_allocate(QVec,nBasisi**2,Label='QVec') - QVec(:)=Zero -* - iDisk=0 - Call dDaFile(Lu_Q,2,QVec,nBasisi*m,iDisk) - Call DaEras(Lu_Q) -#ifdef _DEBUGPRINT_ - Call RecPrt('QVec',' ',QVec,nBasisi,m) -#endif -* - Do iCase = 1, 2 - call dcopy_(nExpi*nBasisi, - & Shells(iShll)%Cff_c(1,1,iCase),1,Tmp,1) -#ifdef _DEBUGPRINT_ - Call RecPrt('Coeff(old)',' ', - & Shells(iShll)%Cff_c(1,1,iCase), - & nExpi,nBasisi) -#endif - Call DGEMM_('N','N', - & nExpi,nBasisi,nBasisi, - & 1.0D0,Tmp,nExpi, - & QVec,nBasisi, - & 0.0D0,Shells(iShll)%Cff_c(1,1,iCase), - & nExpi) -#ifdef _DEBUGPRINT_ - Call RecPrt('Coeff(new)',' ', - & Shells(iShll)%Cff_c(1,1,iCase), - & nExpi,nBasisi) -#endif - End Do -* - Call mma_deallocate(QVec) - Call mma_deallocate(Tmp) -* - End Do -* -* End Do -* * -************************************************************************ -* * - Return - End - diff -Nru openmolcas-22.02/src/ri_util/renorm2.F90 openmolcas-22.10/src/ri_util/renorm2.F90 --- openmolcas-22.02/src/ri_util/renorm2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/renorm2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,32 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 2008, Roland Lindh * +!*********************************************************************** + +subroutine ReNorm2(iCnttp) + +use RI_glob, only: iOffA +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: iCnttp +integer(kind=iwp) :: ire_do + +iOffA(:,:) = 0 +do ire_do=1,2 + + call ReNorm2_Inner(iCnttp) + +end do + +return + +end subroutine ReNorm2 diff -Nru openmolcas-22.02/src/ri_util/renorm2_inner.F90 openmolcas-22.10/src/ri_util/renorm2_inner.F90 --- openmolcas-22.02/src/ri_util/renorm2_inner.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/renorm2_inner.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,227 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 2008, Roland Lindh * +!*********************************************************************** + +subroutine ReNorm2_Inner(iCnttp) +!*********************************************************************** +! * +! Objective: Orthonormalize parts of the auxiliary basis set. * +! * +! Called from: Mk_RICD_Shells * +! * +! Author: Roland Lindh, Dept. of Theor. Chemi., Lund Univ., Sweden.* +! * +! Modified to transform the auxiliary basis to a true * +! Cholesky basis set while on TACC 2008 conference in * +! Songjiang District, Shanghai, China, 23-27 Sept. 2008. * +! * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use RI_procedures, only: Drv2El_Atomic_NoSym +use SOAO_Info, only: iAOtSO, nSOInf +use Real_Spherical, only: Sphere +use Basis_Info, only: dbsc, iCnttp_Dummy, Shells +use Sizes_of_Seward, only: S +use RICD_Info, only: Thrshld_CD +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iCnttp +#include "itmax.fh" +integer(kind=iwp) :: i, iAng, iAO, iBas, iCase, iCmp, iDisk, ij, ijF, ijS, ijS_req, ijT, iSeed, iShll, iShll_, iSO, j, jBas, jCmp, & + jiS, Keep_Shell, Lu_A, Lu_Q, m, nBasisi, nCmp, nExpi, nSO, nTest, nTInt_c +real(kind=wp) :: Thr_CB, ThrAO +logical(kind=iwp) :: In_Core +real(kind=wp), allocatable :: ADiag(:), Not_Used(:), QVec(:,:), TInt_c(:), TInt_d(:), Tmp(:,:) +integer(kind=iwp), external :: IsFreeUnit +external :: Integral_RI_2 + +! * +!*********************************************************************** +! * +!#define _DEBUGPRINT_ +! * +!*********************************************************************** +! * +! Let us now Gram-Schmidt orthonormalize the auxiliary basis for +! better numerics and balance. + +! Update kOffAO and lOffAO to include the auxiliary basis too. + +call Setup_OffAO() + +! Set up transformation matrix from Cartesian to real spherical harmonics. + +call Sphere(S%iAngMx) + +call Flip_Flop(.false.) ! Contracted mode. + +Thr_CB = max(1.0e-14_wp,Thrshld_CD*1.0e-10_wp) +ThrAO = Zero + +!do iCnttp = 1, nCnttp +! Skip the dummy shell +if (iCnttp == iCnttp_dummy) return +! skip non-auxiliary basis sets +if (.not. dbsc(iCnttp)%Aux) return +! * +!*********************************************************************** +! * +! Define some parameters to facilitate the atomic calculation + +S%nShlls = dbsc(iCnttp)%nVal +nTest = dbsc(iCnttp)%nVal-1 + +! Define AOtSO + +iAO = 0 +iSO = 0 +nSO = 0 +do iAng=0,nTest + iShll_ = dbsc(iCnttp)%iVal+iAng + nCmp = nTri_Elem1(iAng) + if (Shells(iShll_)%Prjct) nCmp = 2*iAng+1 + iSO = 0 + if (Shells(iShll_)%nBasis_C*Shells(iShll_)%nExp == 0) cycle + do iCmp=1,nCmp + iAO = iAO+1 + if (iAO > nSOInf) then + write(u6,*) 'renorm2_inner: iAO>nSOInf' + write(u6,*) 'iAO=',iAO + write(u6,*) 'nSOInf=',nSOInf + call Abend() + end if + iAOtSO(iAO,0) = iSO+1 + iSO = iSO+Shells(iShll_)%nBasis + end do + nSO = nSO+iSO +end do + +ijS_req = 0 +Keep_Shell = iTabMx +do iAng=0,nTest + iShll = dbsc(iCnttp)%iVal+iAng + nExpi = Shells(iShll)%nExp + nBasisi = Shells(iShll)%nBasis + if (nExpi*nBasisi == 0) cycle + + nCmp = nTri_Elem1(iAng) + if (Shells(iShll)%Prjct) nCmp = 2*iAng+1 + + ijS_req = ijS_req+1 + + call Drv2El_Atomic_NoSym(Integral_RI_2,ThrAO,iCnttp,iCnttp,TInt_c,nTInt_c,In_Core,Not_Used,Lu_A,ijS_req,Keep_Shell) +# ifdef _DEBUGPRINT_ + call TriPrt('TInt_c',' ',TInt_c,nTInt_c) +# endif + + if (.not. In_Core) then + call WarningMessage(2,'Error in ReNorm') + write(u6,*) 'Out-of-core acCD not implemented!' + call Abend() + end if + + ! Produce the reduced set, in-place reduction. + + call mma_allocate(TInt_d,nTInt_c**2,Label='TInt_d') + ijT = 0 + do iBas=1,nTInt_c + do jBas=1,iBas + ijT = ijT+1 + ijS = (jBas-1)*nTInt_c+iBas + jiS = (iBas-1)*nTInt_c+jBas + TInt_d(ijS) = TInt_c(ijT) + TInt_d(jiS) = TInt_c(ijT) + end do + end do + call mma_deallocate(TInt_c) +# ifdef _DEBUGPRINT_ + call RecPrt('TInt_d',' ',TInt_d,nTInt_c,nTInt_c) +# endif + + ij = 0 + iCmp = 1 + jCmp = 1 + do jBas=1,nBasisi + j = (jCmp-1)*nBasisi+jBas + do iBas=1,nBasisi + i = (iCmp-1)*nBasisi+iBas + ijF = (j-1)*nBasisi*nCmp+i + ij = ij+1 + + TInt_d(ij) = TInt_d(ijF) + + end do + end do +# ifdef _DEBUGPRINT_ + call RecPrt('TInt_d(r)','(5G20.10)',TInt_d,nBasisi,nBasisi) +# endif + + call mma_allocate(ADiag,nBasisi,Label=' ADiag') + + iSeed = 77 + Lu_A = IsFreeUnit(iSeed) + call DaName_MF_WA(Lu_A,'AMat09') + + iDisk = 0 + call dDaFile(Lu_A,1,TInt_d,nBasisi**2,iDisk) + + iSeed = iSeed+1 + Lu_Q = IsFreeUnit(iSeed) + call DaName_MF_WA(Lu_Q,'QMat09') + + call dcopy_(nBasisi,TInt_d,nBasisi+1,ADiag,1) + + call CD_AInv_Inner(nBasisi,m,ADiag,Lu_A,Lu_Q,Thr_CB) + + call mma_deallocate(ADiag) + call mma_deallocate(TInt_d) + + ! Transform the contraction coefficients according to the Cholesky vectors. + + call mma_allocate(Tmp,nExpi,nBasisi,Label='Tmp') + call mma_allocate(QVec,nBasisi,nBasisi,Label='QVec') + QVec(:,:) = Zero + + iDisk = 0 + call dDaFile(Lu_Q,2,QVec,nBasisi*m,iDisk) + call DaEras(Lu_Q) +# ifdef _DEBUGPRINT_ + call RecPrt('QVec',' ',QVec,nBasisi,m) +# endif + + do iCase=1,2 + Tmp(:,:) = Shells(iShll)%Cff_c(:,:,iCase) +# ifdef _DEBUGPRINT_ + call RecPrt('Coeff(old)',' ',Shells(iShll)%Cff_c(:,:,iCase),nExpi,nBasisi) +# endif + call DGEMM_('N','N',nExpi,nBasisi,nBasisi,One,Tmp,nExpi,QVec,nBasisi,Zero,Shells(iShll)%Cff_c(:,:,iCase),nExpi) +# ifdef _DEBUGPRINT_ + call RecPrt('Coeff(new)',' ',Shells(iShll)%Cff_c(:,:,iCase),nExpi,nBasisi) +# endif + end do + + call mma_deallocate(QVec) + call mma_deallocate(Tmp) + +end do + +!end do +! * +!*********************************************************************** +! * +return + +end subroutine ReNorm2_Inner diff -Nru openmolcas-22.02/src/ri_util/reord_vk.f openmolcas-22.10/src/ri_util/reord_vk.f --- openmolcas-22.02/src/ri_util/reord_vk.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/reord_vk.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,65 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - SUBROUTINE Reord_Vk(ip_V_k,nProcs,myProc,nV_k,nV_t,nA,jSym,Array) - use ChoSwp, only: InfVec - Implicit None - Integer nProcs, myProc, nV_k(*), nV_t(*), nA(*), jSym - Integer ip_V_k(nProcs) - Real*8 Array(*) -#include "cholesky.fh" -#include "stdalloc.fh" -* - Integer ik, ifr, ito, nAV_t, jOff, kOff, iSym - Real*8, Allocatable:: Scr(:) -* - nAV_t=0 - Do iSym=1,jSym - nAV_t = nAV_t + nA(iSym)*nV_t(iSym) - End Do - Call mma_allocate(Scr,nAV_t,Label='Scr') - Scr(:)=0.0D0 -* -* On input Array first blocked over the processes -* pointer to the block is ip_V_K(i) -* Each block is symmetry blocked -* Each symmetry is nA(iSym)*nV_k(iSym) -* -* Scr is also symmetry blocked -* Each symmetry is nA(iSym)*nV_t(iSym) -* -* InfVec(ik,5,iSym) translates the local ik'th index into -* the global index of V -* - jOff=0 - kOff=0 - Do iSym=1,jSym - Do ik=1,nV_k(iSym) ! loop over the local vector -* - ifr = ip_V_k(myProc) + jOff + nA(iSym)*(ik-1) - ito = 1 + kOff + nA(iSym)*(InfVec(ik,5,iSym)-1) - call dcopy_(nA(iSym),Array(ifr),1,Scr(ito),1) -* - End Do - jOff=jOff+nA(iSym)*nV_k(iSym) - kOff=kOff+nA(iSym)*nV_t(iSym) - End Do -* -* Copy Scr => Array - call dcopy_(nAV_t,Scr,1,Array(ip_V_k(1)),1) -* -* Make a global add to get the contributions from all nodes. - - Call GADGOP(Array(ip_V_k(1)),nAV_t,'+') -* - Call mma_deallocate(Scr) -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/reord_vk.F90 openmolcas-22.10/src/ri_util/reord_vk.F90 --- openmolcas-22.02/src/ri_util/reord_vk.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/reord_vk.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,68 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Reord_Vk(ip_V_k,nProcs,myProc,nV_k,nV_t,nA,jSym,Array) + +use ChoSwp, only: InfVec +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nProcs, ip_V_k(nProcs), myProc, jSym, nV_k(jSym), nV_t(jSym), nA(jSym) +real(kind=wp), intent(inout) :: Array(*) +integer(kind=iwp) :: ifr, ik, iSym, ito, jOff, kOff, nAV_t +real(kind=wp), allocatable :: Scr(:) + +nAV_t = 0 +do iSym=1,jSym + nAV_t = nAV_t+nA(iSym)*nV_t(iSym) +end do +call mma_allocate(Scr,nAV_t,Label='Scr') +Scr(:) = Zero + +! On input Array first blocked over the processes +! pointer to the block is ip_V_K(i) +! Each block is symmetry blocked +! Each symmetry is nA(iSym)*nV_k(iSym) +! +! Scr is also symmetry blocked +! Each symmetry is nA(iSym)*nV_t(iSym) +! +! InfVec(ik,5,iSym) translates the local ik'th index into +! the global index of V + +jOff = 0 +kOff = 0 +do iSym=1,jSym + do ik=1,nV_k(iSym) ! loop over the local vector + + ifr = ip_V_k(myProc)+jOff+nA(iSym)*(ik-1) + ito = 1+kOff+nA(iSym)*(InfVec(ik,5,iSym)-1) + Scr(ito:ito+nA(iSym)-1) = Array(ifr:ifr+nA(iSym)-1) + + end do + jOff = jOff+nA(iSym)*nV_k(iSym) + kOff = kOff+nA(iSym)*nV_t(iSym) +end do + +! Copy Scr => Array +Array(ip_V_k(1):ip_V_k(1)+nAV_t-1) = Scr(1:nAV_t) + +! Make a global add to get the contributions from all nodes. + +call GADGOP(Array(ip_V_k(1)),nAV_t,'+') + +call mma_deallocate(Scr) + +return + +end subroutine Reord_Vk diff -Nru openmolcas-22.02/src/ri_util/restore_mat.f openmolcas-22.10/src/ri_util/restore_mat.f --- openmolcas-22.02/src/ri_util/restore_mat.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/restore_mat.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,88 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Francesco Aquilante * -************************************************************************ - SUBROUTINE Restore_mat(n,m,lu_A0,lu_A,iD_A,Scr,lScr,Add0s) -************************************************************************ -* -* Author: F. Aquilante -* -************************************************************************ - Implicit Real*8 (a-h,o-z) - Integer n, m, lu_A0, lu_A, iD_A(n), lScr - Real*8 Scr(lScr) - Logical Add0s -#include "warnings.h" - - lmax=lScr-n - If (lmax .lt. n) Then - Call WarningMessage(2,'Error in Restore_mat') - write(6,*) ' Restore_mat: too little scratch space!! ' - Call Quit(_RC_CHO_LOG_) - Endif -* - nMem_Col = m - mNeed = nMem_Col*(nMem_Col+1)/2 - Do while (mNeed .gt. lmax) - mNeed = mNeed - nMem_Col - nMem_Col = nMem_Col - 1 - End Do -* - kAddr=0 - ij=nMem_Col*(nMem_Col+1)/2 - Call dDaFile(lu_A0,2,Scr(1),ij,kAddr) -* - iOff=0 - Do kCol=1,nMem_Col - Do i=1,kCol - iCol=iD_A(i) - iScr=ij+iCol - jCol=iOff+i - Scr(iScr)=Scr(jCol) - End Do - Do i=kCol+1,n - iCol=iD_A(i) - iScr=ij+iCol - Scr(iScr)=0.0d0 - End Do - iAddr=n*(kCol-1) - Call dDaFile(lu_A,1,Scr(ij+1),n,iAddr) -C Call RecPrt('QVec',' ',Scr(ij+1),1,n) - iOff=iOff+kCol - End Do -* - Do kCol=nMem_Col+1,m - Call dDaFile(lu_A0,2,Scr(1),kCol,kAddr) - Do i=1,kCol - iCol=iD_A(i) - iScr=n+iCol - Scr(iScr)=Scr(i) - End Do - Do i=kCol+1,n - iCol=iD_A(i) - iScr=n+iCol - Scr(iScr)=0.0d0 - End Do - iAddr=n*(kCol-1) - Call dDaFile(lu_A,1,Scr(n+1),n,iAddr) -C Call RecPrt('QVec',' ',Scr(n+1),1,n) - End Do -* - If (Add0s) Then - Do kCol=m+1,n ! linearly dependent cols - iAddr=n*(kCol-1) - Call FZero(Scr,n) - Call dDaFile(lu_A,1,Scr(1),n,iAddr) - End Do - EndIf -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/restore_mat.F90 openmolcas-22.10/src/ri_util/restore_mat.F90 --- openmolcas-22.02/src/ri_util/restore_mat.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/restore_mat.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,96 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Francesco Aquilante * +!*********************************************************************** + +subroutine Restore_mat(n,m,lu_A0,lu_A,iD_A,Scr,lScr,Add0s) +!*********************************************************************** +! * +! Author: F. Aquilante * +! * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem +use Constants, only: Zero +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: n, m, lu_A0, lu_A, iD_A(n), lScr +real(kind=wp), intent(out) :: Scr(lScr) +logical(kind=iwp) :: Add0s +#include "warnings.h" +integer(kind=iwp) :: i, iAddr, iCol, ij, iOff, iScr, jCol, kAddr, kCol, lmax, mNeed, nMem_Col + +lmax = lScr-n +if (lmax < n) then + call WarningMessage(2,'Error in Restore_mat') + write(u6,*) ' Restore_mat: too little scratch space!! ' + call Quit(_RC_CHO_LOG_) +end if + +nMem_Col = m +mNeed = nTri_Elem(nMem_Col) +do while (mNeed > lmax) + mNeed = mNeed-nMem_Col + nMem_Col = nMem_Col-1 +end do + +kAddr = 0 +ij = nTri_Elem(nMem_Col) +call dDaFile(lu_A0,2,Scr,ij,kAddr) + +iOff = 0 +do kCol=1,nMem_Col + do i=1,kCol + iCol = iD_A(i) + iScr = ij+iCol + jCol = iOff+i + Scr(iScr) = Scr(jCol) + end do + do i=kCol+1,n + iCol = iD_A(i) + iScr = ij+iCol + Scr(iScr) = Zero + end do + iAddr = n*(kCol-1) + call dDaFile(lu_A,1,Scr(ij+1),n,iAddr) + !call RecPrt('QVec',' ',Scr(ij+1),1,n) + iOff = iOff+kCol +end do + +do kCol=nMem_Col+1,m + call dDaFile(lu_A0,2,Scr,kCol,kAddr) + do i=1,kCol + iCol = iD_A(i) + iScr = n+iCol + Scr(iScr) = Scr(i) + end do + do i=kCol+1,n + iCol = iD_A(i) + iScr = n+iCol + Scr(iScr) = Zero + end do + iAddr = n*(kCol-1) + call dDaFile(lu_A,1,Scr(n+1),n,iAddr) + !call RecPrt('QVec',' ',Scr(n+1),1,n) +end do + +if (Add0s) then + do kCol=m+1,n ! linearly dependent cols + iAddr = n*(kCol-1) + Scr(1:n) = Zero + call dDaFile(lu_A,1,Scr,n,iAddr) + end do +end if + +return + +end subroutine Restore_mat diff -Nru openmolcas-22.02/src/ri_util/ricd_helper.f openmolcas-22.10/src/ri_util/ricd_helper.f --- openmolcas-22.02/src/ri_util/ricd_helper.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/ricd_helper.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,84 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine RICD_Helper(Do_nacCD_Basis,nTest,iAngMin_,iAngMax_, - & jAngMin_,jAngMax_,nBS,iAng,jAng,list, - & nBS_Max) - Implicit Real*8 (a-h,o-z) - Logical Do_nacCD_Basis - Integer iAngMin_(0:nBS_Max-1), - & iAngMax_(0:nBS_Max-1) - Parameter (iTabMx=15) - Integer jAngMin_(0:nBS_Max-1,0:nBS_Max-1), - & jAngMax_(0:nBS_Max-1,0:nBS_Max-1) - Integer list(2,0:((nTest+1)*(nTest+2))/2,0:nTest*2) - Integer list2(0:nTest**2) -* * -************************************************************************ -* * - if(.Not.Do_nacCD_Basis) Then -* * -************************************************************************ -* * - nBS=(nTest+2)/2 - Do iBS=0, nBS-1 - iAngMin_(iBS)=iBS - iAngMax_(iBS)=nTest-iBS - Do iAng=0, iAngMax_(iBS) - jAngMax_(iBS,iAng)=Min(iAng,iAngMin_(iBS)) - If (iAng.eq.iAngMax_(iBS)) - & jAngMax_(iBS,iAng)=iAngMax_(iBS) - If (iAng.lt.iAngMin_(iBS)) jAngMax_(iBS,iAng)=0 - jAngMin_(iBS,iAng)=iAngMin_(iBS) - If (iAng.le.iAngMin_(iBS)) jAngMin_(iBS,iAng)=0 - Do jAng=jAngMin_(iBS,iAng), jAngMax_(iBS,iAng) - list(1,0,iAng)=iAng - list(2,0,iAng)=jAng - End Do - End Do - End Do -* * -************************************************************************ -* * - Else -* * -************************************************************************ -* * - nBS=1 - iPair=0 - Do iBS=0, nBS-1 - iAngMax_(iBS)=nTest*2 - Do iAng=iAngMin_(iBS), iAngMax_(iBS) - jAngMax_(iBS,iAng)=0 - jAngMin_(iBS,iAng)=0 - Do jAng=jAngMin_(iBS,iAng), jAngMax_(iBS,iAng) - list2(iAng)=0 - Do k=0, nTest - Do l=0, k - Do m=iAng,0,-2 - n=k-l - If ((n.eq.m).and.((k+l).ge.iAng)) Then - iPair=list2(iAng) - list(1,iPair,iAng)=l - list(2,iPair,iAng)=k - list2(iAng)=list2(iAng)+1 - End If - End Do ! m - End Do ! l - End Do ! k - End Do ! jAng - End Do ! iAng - End Do ! iBS - End if -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/ri_util/ri_glob.F90 openmolcas-22.10/src/ri_util/ri_glob.F90 --- openmolcas-22.02/src/ri_util/ri_glob.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/ri_glob.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,39 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +module RI_glob + +use Data_Structures, only: Alloc1DiArray_Type, DSBA_Type +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +private + +integer(kind=iwp) :: iMP2prpt, iAdrCVec(8,8,2), iOff_Ymnij(8,5), iOffA(4,0:7), iOpt, ip_Chunk = 0, iRsv, klS, Lu_A(0:7), & + Lu_Q(0:7), LuAVector(2), LuBVector(2), LuCVector(8,2), MxChVInShl, nAdens, nAuxVe, nAvec, nChOrb(0:7,5), & + nChV(0:7), nIJ1(8,8,2), nIJR(8,8,2), nJdens, nKdens, nKvec, nScreen, nSO, nSkal_Valence, nTask, NumAuxVec(8), & + nYmnij(8,5) +real(kind=wp) :: dmpK = Zero, tavec(2), tbvec(2) +logical(kind=iwp) :: DoCholExch, Timings_default +type(Alloc1DiArray_Type) :: Ymnij(5) +type(DSBA_Type), target :: CMOi(5), DMLT(5) +integer(kind=iwp), allocatable :: iBDsh(:), iMap(:), iShij(:,:), iSSOff(:,:,:), nBasSh(:,:), ShlSO(:), SO2Ind(:), SOShl(:), & + TskList(:) +real(kind=wp), allocatable :: A(:), AMP2(:,:), BMP2(:,:), Chunk(:) +real(kind=wp), allocatable, target :: BklK(:), CijK(:), CilK(:), VJ(:), Yij(:,:,:) + +public :: A, AMP2, BklK, BMP2, Chunk, CijK, CilK, CMOi, DMLT, dmpK, DoCholExch, iAdrCVec, iBDsh, iMap, iMP2prpt, iOff_Ymnij, & + iOffA, iOpt, ip_Chunk, iRsv, iShij, iSSOff, klS, Lu_A, Lu_Q, LuAVector, LuBVector, LuCVector, MxChVInShl, nAdens, & + nAuxVe, nAvec, nBasSh, nChOrb, nChV, nIJ1, nIJR, nJdens, nKdens, nKvec, nScreen, nSkal_Valence, nSO, nTask, NumAuxVec, & + nYmnij, ShlSO, SO2Ind, SOShl, tavec, tbvec, Timings_default, TskList, VJ, Yij, Ymnij + +end module RI_glob diff -Nru openmolcas-22.02/src/ri_util/ri_procedures.F90 openmolcas-22.10/src/ri_util/ri_procedures.F90 --- openmolcas-22.02/src/ri_util/ri_procedures.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/ri_procedures.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,28 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! This module contains procedures that need an interface +module RI_procedures + +implicit none +private + +public :: Drv2El_2Center_RI, Drv2el_Atomic_Nosym, Effective_CD_Pairs, Fix_Exponents + +contains + +#define _IN_MODULE_ +#include "drv2el_2center_ri.F90" +#include "drv2el_atomic_nosym.F90" +#include "effective_cd_pairs.F90" +#include "fix_exponents.F90" + +end module RI_procedures diff -Nru openmolcas-22.02/src/ri_util/ri_xdiag.f openmolcas-22.10/src/ri_util/ri_xdiag.f --- openmolcas-22.02/src/ri_util/ri_xdiag.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/ri_xdiag.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,100 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 2007, Thomas Bondo Pedersen * -************************************************************************ - SubRoutine RI_XDiag(Diag,nDiag) -C -C Thomas Bondo Pedersen, Jan. 2007. -C -C Purpose: compute exact integral diagonal. -C - use ChoArr, only: iSP2F, nBstSh - use ChoSwp, only: nnBstRSh, iiBstRSh, IndRed - Implicit None - Integer nDiag - Real*8 Diag(nDiag) -#include "cholesky.fh" -#include "stdalloc.fh" - - Real*8, Allocatable :: Scr(:) - - Integer l_SewMem - Integer ID - Integer iSAB, iShlA, iShlB - Integer NumAB - Integer iSym, i1, i2 - - Logical Rsv_Tsk - External Rsv_Tsk - - Integer i - -C Allocate memory. -C ---------------- - - Call Init_Tsk(ID,nnShl) - - Call mma_allocate(Scr,Mx2Sh,Label='Scr') - Call mma_maxDBLE(l_SewMem) - -C Initialize diagonal array. -C -------------------------- - - Call fZero(Diag,nnBstRT(1)) - -C Parallel loop over shell pairs in first red. set. -C ------------------------------------------------- - - Do While (Rsv_Tsk(ID,iSAB)) - -C Get shells. -C ----------- - - Call Cho_InvPck(iSP2F(iSAB),iShlA,iShlB,.True.) - -C Compute (AB|AB). -C ---------------- - - If (iShlA .eq. iShlB) Then - NumAB = nBstSh(iShlA)*(nBstSh(iShlA)+1)/2 - Else - NumAB = nBstSh(iShlA)*nBstSh(iShlB) - End If - ShA = iShlA - ShB = iShlB - Call Cho_MCA_DiagInt(iShlA,iShlB,Scr,NumAB) - -C Extract diagonal elements. -C -------------------------- - - Do iSym = 1,nSym - i1 = iiBstR(iSym,1) + iiBstRSh(iSym,iSAB,1) + 1 - i2 = i1 + nnBstRSh(iSym,iSAB,1) - 1 - Do i = i1,i2 - Diag(i) = Scr(IndRed(i,1)) - End Do - End Do - - End Do - Call Free_Tsk(ID) - -C Sync diagonal. -C -------------- - - Call GAdGOP(Diag,nnBstRT(1),'+') - -C Deallocate memory. -C ------------------ - - Call xRlsMem_Ints() - Call mma_deallocate(Scr) - - End diff -Nru openmolcas-22.02/src/ri_util/ri_xdiag.F90 openmolcas-22.10/src/ri_util/ri_xdiag.F90 --- openmolcas-22.02/src/ri_util/ri_xdiag.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/ri_xdiag.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,96 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 2007, Thomas Bondo Pedersen * +!*********************************************************************** + +subroutine RI_XDiag(Diag,nDiag) +! Thomas Bondo Pedersen, Jan. 2007. +! +! Purpose: compute exact integral diagonal. + +use Index_Functions, only: nTri_Elem +use ChoArr, only: iSP2F, nBstSh +use ChoSwp, only: iiBstRSh, IndRed, nnBstRSh +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero +use Definitions, only: wp, iwp + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(in) :: nDiag +real(kind=wp), intent(_OUT_) :: Diag(nDiag) +#include "cholesky.fh" +integer(kind=iwp) :: i, i1, i2, ID, iSAB, iShlA, iShlB, iSym, l_SewMem, NumAB +real(kind=wp), allocatable :: Scr(:) +logical(kind=iwp), external :: Rsv_Tsk + +! Allocate memory. +! ---------------- + +call Init_Tsk(ID,nnShl) + +call mma_allocate(Scr,Mx2Sh,Label='Scr') +call mma_maxDBLE(l_SewMem) + +! Initialize diagonal array. +! -------------------------- + +Diag(1:nnBstRT(1)) = Zero + +! Parallel loop over shell pairs in first red. set. +! ------------------------------------------------- + +do while (Rsv_Tsk(ID,iSAB)) + + ! Get shells. + ! ----------- + + call Cho_InvPck(iSP2F(iSAB),iShlA,iShlB,.true.) + + ! Compute (AB|AB). + ! ---------------- + + if (iShlA == iShlB) then + NumAB = nTri_Elem(nBstSh(iShlA)) + else + NumAB = nBstSh(iShlA)*nBstSh(iShlB) + end if + ShA = iShlA + ShB = iShlB + call Cho_MCA_DiagInt(iShlA,iShlB,Scr,NumAB) + + ! Extract diagonal elements. + ! -------------------------- + + do iSym=1,nSym + i1 = iiBstR(iSym,1)+iiBstRSh(iSym,iSAB,1)+1 + i2 = i1+nnBstRSh(iSym,iSAB,1)-1 + do i=i1,i2 + Diag(i) = Scr(IndRed(i,1)) + end do + end do + +end do +call Free_Tsk(ID) + +! Sync diagonal. +! -------------- + +call GAdGOP(Diag,nnBstRT(1),'+') + +! Deallocate memory. +! ------------------ + +call xRlsMem_Ints() +call mma_deallocate(Scr) + +end subroutine RI_XDiag diff -Nru openmolcas-22.02/src/ri_util/rm_auxshell.f openmolcas-22.10/src/ri_util/rm_auxshell.f --- openmolcas-22.02/src/ri_util/rm_auxshell.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/rm_auxshell.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine rm_AuxShell(iCnttp) -************************************************************************ -* * -* Remove an auxiliary basis set by making it empty. * -* * -************************************************************************ - Use Basis_Info, only: dbsc, Shells - Implicit Real*8 (A-H,O-Z) -#include "SysDef.fh" -#include "real.fh" -* * -************************************************************************ -* * - Do k = 0, dbsc(iCnttp)%nShells-1 - iShll = dbsc(iCnttp)%iVal + k -* - Shells(iShll)%nExp=0 - Shells(iShll)%nBasis =0 - Shells(iShll)%nBasis_c=0 -* - End Do -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/ri_util/rm_auxshell.F90 openmolcas-22.10/src/ri_util/rm_auxshell.F90 --- openmolcas-22.02/src/ri_util/rm_auxshell.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/rm_auxshell.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,42 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine rm_AuxShell(iCnttp) +!*********************************************************************** +! * +! Remove an auxiliary basis set by making it empty. * +! * +!*********************************************************************** + +use Basis_Info, only: dbsc, Shells +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: iCnttp +integer(kind=iwp) :: iShll, k + +! * +!*********************************************************************** +! * +do k=0,dbsc(iCnttp)%nShells-1 + iShll = dbsc(iCnttp)%iVal+k + + Shells(iShll)%nExp = 0 + Shells(iShll)%nBasis = 0 + Shells(iShll)%nBasis_c = 0 + +end do +! * +!*********************************************************************** +! * +return + +end subroutine rm_AuxShell diff -Nru openmolcas-22.02/src/ri_util/rsv_tsk2.F90 openmolcas-22.10/src/ri_util/rsv_tsk2.F90 --- openmolcas-22.02/src/ri_util/rsv_tsk2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/rsv_tsk2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,44 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +function Rsv_Tsk2(id,kls) + +use RI_glob, only: iOpt, iRsv, nTask, TskList +use Definitions, only: iwp, u6 + +implicit none +logical(kind=iwp) :: Rsv_Tsk2 +integer(kind=iwp), intent(in) :: id +integer(kind=iwp), intent(out) :: kls +logical(kind=iwp), external :: Rsv_Tsk + +if (iOpt == 0) then + Rsv_Tsk2 = Rsv_Tsk(id,kls) +else if (iOpt == 1) then + Rsv_Tsk2 = .true. + if (iRsv > nTask) then + Rsv_Tsk2 = .false. + else + kls = TskList(iRsv) + iRsv = iRsv+1 + if (kls <= 0) Rsv_Tsk2 = .false. + if (kls > nTask) Rsv_Tsk2 = .false. + end if +else + Rsv_Tsk2 = .false. + call WarningMessage(2,'Error in Rsv_Tsk2') + write(u6,*) 'Rsv_Tsk2: illegal iOpt value!' + call Abend() +end if + +return + +end function Rsv_Tsk2 diff -Nru openmolcas-22.02/src/ri_util/set_cho_adrvec.f openmolcas-22.10/src/ri_util/set_cho_adrvec.f --- openmolcas-22.02/src/ri_util/set_cho_adrvec.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/set_cho_adrvec.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -C Integer Function Set_CHO_ADRVEC(ii) - Function Set_CHO_ADRVEC(ii) -#include "cholesky.fh" - Integer Set_CHO_ADRVEC -* - Set_CHO_ADRVEC=0 - If (ii.lt.0) Then - Set_CHO_ADRVEC=CHO_ADRVEC - Else If (ii.eq.1.or.ii.eq.2) Then - CHO_ADRVEC=ii - Set_CHO_ADRVEC=CHO_ADRVEC - Else - Call WarningMessage(2,'Set_CHO_ADRVEC: Illegal option') - Write (6,*) 'ii=',ii - Call Abend() - End if -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/set_cho_adrvec.F90 openmolcas-22.10/src/ri_util/set_cho_adrvec.F90 --- openmolcas-22.02/src/ri_util/set_cho_adrvec.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/set_cho_adrvec.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,35 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +function Set_CHO_ADRVEC(ii) + +use Definitions, only: iwp, u6 + +implicit none +#include "cholesky.fh" +integer(kind=iwp) :: Set_CHO_ADRVEC +integer(kind=iwp), intent(in) :: ii + +Set_CHO_ADRVEC = 0 +if (ii < 0) then + Set_CHO_ADRVEC = CHO_ADRVEC +else if ((ii == 1) .or. (ii == 2)) then + CHO_ADRVEC = ii + Set_CHO_ADRVEC = CHO_ADRVEC +else + call WarningMessage(2,'Set_CHO_ADRVEC: Illegal option') + write(u6,*) 'ii=',ii + call Abend() +end if + +return + +end function Set_CHO_ADRVEC diff -Nru openmolcas-22.02/src/ri_util/setchoindx_ri.F90 openmolcas-22.10/src/ri_util/setchoindx_ri.F90 --- openmolcas-22.02/src/ri_util/setchoindx_ri.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/setchoindx_ri.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,154 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Thomas Bondo Pedersen * +!*********************************************************************** + +subroutine SetChoIndx_RI(iiBstRSh,nnBstRSh,IndRed,IndRsh,iRS2F,I_nSym,I_nnShl,I_mmBstRT,iShij,nShij) + +use Index_Functions, only: iTri +use Symmetry_Info, only: Mul +use ChoArr, only: iSP2F, iBasSh, nBasSh, nBstSh +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: I_nSym, I_nnShl, I_mmBstRT, iRS2F(2,I_mmBstRT), nShij, iShij(2,nShij) +integer(kind=iwp), intent(out) :: iiBstRSh(I_nSym,I_nnShl,3), nnBstRSh(I_nSym,I_nnShl,3), IndRed(I_mmBstRT,3), IndRsh(I_mmBstRT) +#include "cholesky.fh" +integer(kind=iwp) :: i, ia, iaa, iab, ib, ibb, iCount, iRS(8), iSh_ij, iShla, iShlab, iShlb, iSym, iSyma, iSymb, jRS, jRS1, jRS2, & + nErr +integer(kind=iwp), external :: Cho_iSAOSh + +! nnBstRSh(iSym,iSh_ij,1) = #elements in compound sym. iSym of +! shell-pair ab in 1st reduced set. +! IndRSh(jRS): shell-pair to which element jRS of first reduced set +! belongs. +! IndRed(jRS,1): address (without symmetry) in shell-pair of element +! jRS of first reduced set. +! ------------------------------------------------------------------ + +nnBstRSh(:,:,1) = 0 +iRS(1:nSym) = iiBstR(1:nSym,1) +do iSh_ij=1,nShij + iShla = iShij(1,iSh_ij) + iShlb = iShij(2,iSh_ij) + iShlab = iTri(iShla,iShlb) + !write(u6,*) 'iSh_ij,iShlab,iShla,iShlb=',iSh_ij,iShlab,iShla,iShlb + if (iShlab /= iSP2F(iSh_ij)) call SysAbendMsg('SetChoIndx_RI','SP2F setup error',' ') + + if (iShla > iShlb) then + + ! code for shell a > shell b + + do iSymb=1,nSym + do ibb=1,nBasSh(iSymb,iShlb) + ib = iBasSh(iSymb,iShlb)+ibb + do iSyma=1,nSym + iSym = Mul(iSyma,iSymb) + do iaa=1,nBasSh(iSyma,iShla) + ia = iBasSh(iSyma,iShla)+iaa + iab = nBstSh(iShla)*(ib-1)+ia + nnBstRSh(iSym,iSh_ij,1) = nnBstRSh(iSym,iSh_ij,1)+1 + iRS(iSym) = iRS(iSym)+1 + IndRSh(iRS(iSym)) = iShlab + IndRed(iRS(iSym),1) = iab + end do + end do + end do + end do + + else + + ! code for shell a = shell b follows + + do ia=1,nBstSh(iShla) + iSyma = Cho_iSAOSh(ia,iShla) + do ib=1,ia + iab = iTri(ia,ib) + iSymb = Cho_iSAOSh(ib,iShlb) + iSym = Mul(iSyma,iSymb) + nnBstRSh(iSym,iSh_ij,1) = nnBstRSh(iSym,iSh_ij,1)+1 + iRS(iSym) = iRS(iSym)+1 + IndRSh(iRS(iSym)) = iShlab + IndRed(iRS(iSym),1) = iab + end do + end do + + end if +end do ! iSh_ij + +! Check. +! ------ + +nErr = 0 +do iSym=1,nSym + iCount = nnBstRSh(iSym,1,1) + do iSh_ij=2,nnShl + iCount = iCount+nnBstRSh(iSym,iSh_ij,1) + end do + if (iCount /= nnBstR(iSym,1)) then + nErr = nErr+1 + end if +end do +if (nErr /= 0) then + call SysAbendMsg('SetChoIndx_RI','Setup error','iCount vs. nnBstR') +end if +do iSym=1,nSym + if ((iRS(iSym)-iiBstR(iSym,1)) /= nnBstR(iSym,1)) nErr = nErr+1 +end do +if (nErr /= 0) then + call SysAbendMsg('SetChoIndx_RI','Setup error','ShP RS1 count') +end if + +! iiBstRSh(iSym,iSh_ij,1) = offset to elements in compound sym. iSym +! of shell-pair ab in 1st reduced set. +! ------------------------------------------------------------------ + +do iSym=1,nSym + iiBstRSh(iSym,1,1) = 0 + do iSh_ij=2,nnShl + iiBstRSh(iSym,iSh_ij,1) = iiBstRSh(iSym,iSh_ij-1,1)+nnBstRSh(iSym,iSh_ij-1,1) + end do +end do + +! Check. +! ------ + +nErr = 0 +do iSym=1,nSym + do iSh_ij=1,nnShl + jRS1 = iiBstR(iSym,1)+iiBstRSh(iSym,iSh_ij,1)+1 + jRS2 = jRS1+nnBstRSh(iSym,iSh_ij,1)-1 + do jRS=jRS1,jRS2 + if (IndRSh(jRS) /= iSP2F(iSh_ij)) nErr = nErr+1 + end do + end do +end do +if (nErr /= 0) then + call SysAbendMsg('SetChoIndx_RI','Setup error','IndRSh') +end if + +! Copy index arrays to "locations" 2 and 3. +! Note: IndRed here returns the index in 1st reduced set. +! ------------------------------------------------------- + +do i=2,3 + do jRS=1,nnBstRT(1) + IndRed(jRS,i) = jRS + end do + iiBstRSh(:,:,i) = iiBstRSh(:,:,1) + nnBstRSh(:,:,i) = nnBstRSh(:,:,1) +end do + +call Cho_RStoF(iRS2F,2,nnBstRT(1),1) + +return + +end subroutine SetChoIndx_RI diff -Nru openmolcas-22.02/src/ri_util/setup_aux.f openmolcas-22.10/src/ri_util/setup_aux.f --- openmolcas-22.02/src/ri_util/setup_aux.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/setup_aux.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,337 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Setup_Aux(nIrrep,nBas,nShell,nShell_Aux,nSO, - & TMax,CutOff,nij_Shell, - & nBas_Aux,nChV,iTOffs) - use iSD_data - use SOAO_Info, only: iSOInf - use j12, only: ShlSO, SOShl, nBasSh, iSSOff, iShij - Implicit Real*8 (a-h,o-z) -#include "real.fh" -#include "stdalloc.fh" -#include "setup.fh" -#include "nsd.fh" - Integer nBas(0:nIrrep-1), nBas_Aux(0:nIrrep-1), - & nChV(0:nIrrep-1), iTOffs(3,0:nIrrep-1) - Real*8 TMax(nShell,nShell) -* * -************************************************************************ -* * -*define _DEBUGPRINT_ -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - Write (6,*) 'Setup_Aux:nIrrep: ',nIrrep - Write (6,*) 'Setup_Aux:nBas: ',nBas - Write (6,*) 'Setup_Aux:nBas_Aux: ',nBas_Aux - Write (6,*) 'Setup_Aux:nChV: ',nChV -#endif -* * -************************************************************************ -* * - nSO = 0 - nSO_Aux = 0 - Do iIrrep = 0, nIrrep-1 - nSO = nSO + nBas(iIrrep) - nSO_Aux = nSO_Aux + nBas_Aux(iIrrep) - End Do -* - Call mma_allocate(SOShl,nSO+nSO_Aux,Label='SOShl') - Call mma_allocate(ShlSO,nSO+nSO_Aux,Label='ShlSO') - Call mma_allocate(nBasSh,[0,nIrrep-1], - & [1,nShell+nShell_Aux],Label='nBasSh') -* * -************************************************************************ -* * - Do iSO = 1, nSO+nSO_Aux - iCnttp=iSOInf(1,iSO) - iCnt =iSOInf(2,iSO) - iAng =iSOInf(3,iSO) -C Write (*,*) 'iCnttp,iCnt,iAng=',iCnttp,iCnt,iAng -* -* Find the Shell from which this basis function is derived. -* - Do iSkal = 1, nShell+nShell_Aux - jCnttp=iSD(13,iSkal) - jCnt =iSD(14,iSkal) - jAng =iSD( 1,iSkal) - If (jCnttp.eq.iCnttp .and. - & jCnt .eq.iCnt .and. - & jAng .eq.iAng ) Then - SOShl(iSO)=iSkal -C Write (*,*) 'Found in shell=',iSkal - Go To 99 - End If - End Do - 99 Continue - End Do -C Call iVcPrt('SOShl',' ',SOShl,nSO+nSO_Aux) -* * -************************************************************************ -* * -* Compute the number of effective shell pairs. -* - TMax_ij=Zero - Do iSkal = 1, nShell - Do jSkal = 1, iSkal - TMax_ij=Max(TMax_ij,TMax(iSkal,jSkal)) - End Do - End Do -* - nij_Shell=0 - Do iSkal = 1, nShell - Do jSkal = 1, iSkal - If (TMax(iSkal,jSkal)*TMax_ij.ge.CutOff) Then - nij_Shell = nij_Shell + 1 - End If - End Do - End Do - Call mma_allocate(iShij,2,nij_Shell,Label='iShij') -* - ij_Shell = 0 - Do iSkal = 1, nShell - Do jSkal = 1, iSkal - If (TMax(iSkal,jSkal)*TMax_ij.ge.CutOff) Then - ij_Shell = ij_Shell + 1 - iShij(1,ij_Shell)=iSkal - iShij(2,ij_Shell)=jSkal -#ifdef _DEBUGPRINT_ - Write (6,*) 'ij_Shell,iSkal,jSkal=', - & ij_Shell,iSkal,jSkal -#endif - End If - End Do - End Do -* * -************************************************************************ -* * - Call mma_allocate(iSSOff,[0,nIrrep-1],[0,nIrrep-1], - & [1,nij_Shell],Label='iSSOff') -* * -************************************************************************ -* * -* - Call Setup_Aux_Internal(SOShl,nSO+nSO_Aux,ShlSO, - & nBasSh,nShell+nShell_Aux,nIrrep,nBas, - & iSSOff,nij_Shell,iShij, - & nBas_Aux,nChV,iTOffs) -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - Write (6,*) 'nij_Shell=',nij_Shell - Write (6,*) - Do ij_Shell = 1, nij_Shell - Write (6,*) iShij(1,ij_Shell),iShij(2,ij_Shell) - End Do -#endif -* * -************************************************************************ -* * - Return - End - - - - - Subroutine Setup_Aux_Internal(iSOShl,nSO,iShlSO,nBasSh,nShell, - & nIrrep,nBas,iSSOff,nij_Shell,iShij, - & nBas_Aux,nChV,iTOffs) - Implicit Real*8 (a-h,o-z) - Integer iSOShl(nSO), iShlSO(nSO), nBasSh(0:nIrrep-1,nShell), - & nBas(0:nIrrep-1), nBas_Aux(0:nIrrep-1), nChV(0:nIrrep-1), - & iSSOff(0:nIrrep-1,0:nIrrep-1,nij_Shell), - & iShij(2,nij_Shell), iTOffs(3,0:nIrrep-1), iTtmp(0:7) -* * -************************************************************************ -* * -* Generate index array for relative index within the shell and irrep -* -C Call iVcPrt('iSOShl',' ',iSOShl,nSO) - iSO = 0 - Do iIrrep = 0, nIrrep-1 - Do iShell = 1, nShell -* - iSO_Shl = 0 - Do iBas = iSO+1 , iSO+nBas(iIrrep) - If (iSOShl(iBas).eq.iShell) Then - iSO_Shl = iSO_Shl + 1 -* * -************************************************************************ -* * -* Save the relative index within the shell and irrep -* of a given absolute SO index. -* - iShlSO(iBas) = iSO_Shl - End If - End Do -* * -************************************************************************ -* * -* Save the total number of basis functions a specific shell -* has in a given irrep. -* - nBasSh(iIrrep,iShell)=iSO_Shl -* * -************************************************************************ -* * - End Do - iSO = iSO + nBas(iIrrep) - End Do -* * -************************************************************************ -* -* Initialize -* - Call ICopy(3*nIrrep,[0],0,iTOffs,1) - Call iCopy(nij_Shell*nIrrep**2,[0],0,iSSOff,1) -* * -************************************************************************ -* * -* Compute offsets within the symmetry block for a fixed shell pair. -* -* Note that for each pair of valence shells all the products which -* are of the same irrep are consecutive. -* -* - Do ijShell = 1, nij_Shell - iShell = iShij(1,ijShell) - jShell = iShij(2,ijShell) - Call ICopy(nIrrep,[0],0,iTtmp,1) -* * -************************************************************************ -* * - If (iShell.gt.jShell) Then ! iShell > jShell -* - Do jIrrep = 0, nIrrep-1 - nB = nBasSh(jIrrep,jShell) - Do iIrrep = 0, nIrrep-1 - nA = nBasSh(iIrrep,iShell) -* - ijIrrep = iEor(iIrrep,jIrrep) - iSSOff(iIrrep,jIrrep,ijShell)=iTtmp(ijIrrep) - nab = na*nb - iTtmp(ijIrrep)=iTtmp(ijIrrep)+nab -* - End Do - End Do -* - Else ! iShell = jShell -* - Do iIrrep = 0, nIrrep-1 - nA = nBasSh(iIrrep,iShell) - Do jIrrep = 0, iIrrep - nB = nBasSh(jIrrep,jShell) -* - ijIrrep = iEor(iIrrep,jIrrep) - iSSOff(iIrrep,jIrrep,ijShell)=iTtmp(ijIrrep) - iSSOff(jIrrep,iIrrep,ijShell)=iTtmp(ijIrrep) - nab = na*nb - If (iIrrep.eq.jIrrep) nab = na*(na+1)/2 - iTtmp(ijIrrep) = iTtmp(ijIrrep) + nab - End Do - End Do -* - End If -* - Do iIrrep = 0, nIrrep-1 - iTOffs(3,iIrrep) = iTOffs(3,iIrrep) + iTtmp(iIrrep) - End Do -* -* Now update the index to be the total offset within a slice -* for a fixed shell-pair -* - iAcc = 0 - Do ijIrrep = 0, nIrrep-1 - Do iIrrep = 0, nIrrep-1 - jIrrep = iEor(ijIrrep,iIrrep) - iSSOff(iIrrep,jIrrep,ijShell)= - & iSSOff(iIrrep,jIrrep,ijShell)+iAcc - End Do - nI = nBas_Aux(ijIrrep) - If (ijIrrep.eq.0) nI=nI-1 - iAcc = iAcc + nI*iTtmp(ijIrrep) - End Do -* * -************************************************************************ -* * - End Do -#ifdef _DEBUGPRINT_ - Write (6,*) - Write (6,*) 'iSSOff' - Write (6,*) - Do ijShell = 1, nij_Shell - iShell = iShij(1,ijShell) - jShell = iShij(2,ijShell) - Write (6,*) - Write (6,*) 'iShell,jShell=',iShell,jShell - Write (6,*) - Do i = 0, nIrrep-1 - Write (6,'(8I4)') (iSSOff(i,j,ijShell),j=0,nIrrep-1) - End Do - End Do -#endif -* * -************************************************************************ -* * -* Set up pointers for the J12 matrix and compute total size of the -* 3-center integrals. -* - iOff_V12=0 - Do iIrrep = 0, nIrrep-1 - iTOffs(1,iIrrep) = nChV(iIrrep) ! # of vectors - nAux = nBas_Aux(iIrrep) - If (iIrrep.eq.0) nAux = nAux - 1 - iTOffs(2,iIrrep) = iOff_V12 - iOff_V12 = iOff_V12 + nAux**2 - End Do -* * -************************************************************************ -* * -#ifdef _DEBUGPRINT_ - Write (6,*) - Write (6,*) ' iSO, iShlSO(iSO), relative index in irrep' - Do jSO = 1, iSO - Write (6,*) jSO, iShlSO(jSO) - End Do -* - Write (6,*) - Write (6,*) ' iShell: number of basis functions in each irrep' - Do iShell = 1, nShell - Write (6,*) iShell,':', - & (nBasSh(iIrrep,iShell),iIrrep=0,nIrrep-1) - End Do - Write (6,*) - Write (6,*) 'iSSOff' - Write (6,*) - Do ijShell = 1, nij_Shell - iShell = iShij(1,ijShell) - jShell = iShij(2,ijShell) - Write (6,*) - Write (6,*) 'iShell,jShell=',iShell,jShell - Write (6,*) - Do i = 0, nIrrep-1 - Write (6,'(8I4)') (iSSOff(i,j,ijShell),j=0,nIrrep-1) - End Do - End Do - Write (6,*) - Write (6,*) 'iTOffs' - Write (6,*) - Do i = 0, nIrrep-1 - Write (6,*) (iTOffs(j,i),j=1,3) - End Do -#endif -* * -************************************************************************ -* * - Return - End diff -Nru openmolcas-22.02/src/ri_util/setup_aux.F90 openmolcas-22.10/src/ri_util/setup_aux.F90 --- openmolcas-22.02/src/ri_util/setup_aux.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/setup_aux.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,133 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Setup_Aux(nIrrep,nBas,nShell,nShell_Aux,nSO,TMax,CutOff,nij_Shell,nBas_Aux,nChV,iTOffs) + +use iSD_data, only: iSD +use SOAO_Info, only: iSOInf +use RI_glob, only: iShij, iSSOff, nBasSh, ShlSO, SOShl +use stdalloc, only: mma_allocate +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nIrrep, nBas(0:nIrrep-1), nShell, nShell_Aux, nBas_Aux(0:nIrrep-1), nChV(0:nIrrep-1) +integer(kind=iwp), intent(out) :: nSO, nij_Shell, iTOffs(3,0:nIrrep-1) +real(kind=wp), intent(in) :: TMax(nShell,nShell), CutOff +integer(kind=iwp) :: iAng, iCnt, iCnttp, iIrrep, ij_Shell, iSkal, iSO, jAng, jCnt, jCnttp, jSkal, nSO_Aux +real(kind=wp) :: TMax_ij + +! * +!*********************************************************************** +! * +!define _DEBUGPRINT_ +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +write(u6,*) 'Setup_Aux:nIrrep: ',nIrrep +write(u6,*) 'Setup_Aux:nBas: ',nBas +write(u6,*) 'Setup_Aux:nBas_Aux: ',nBas_Aux +write(u6,*) 'Setup_Aux:nChV: ',nChV +#endif +! * +!*********************************************************************** +! * +nSO = 0 +nSO_Aux = 0 +do iIrrep=0,nIrrep-1 + nSO = nSO+nBas(iIrrep) + nSO_Aux = nSO_Aux+nBas_Aux(iIrrep) +end do + +call mma_allocate(SOShl,nSO+nSO_Aux,Label='SOShl') +call mma_allocate(ShlSO,nSO+nSO_Aux,Label='ShlSO') +call mma_allocate(nBasSh,[0,nIrrep-1],[1,nShell+nShell_Aux],Label='nBasSh') +! * +!*********************************************************************** +! * +do iSO=1,nSO+nSO_Aux + iCnttp = iSOInf(1,iSO) + iCnt = iSOInf(2,iSO) + iAng = iSOInf(3,iSO) + !write(u6,*) 'iCnttp,iCnt,iAng=',iCnttp,iCnt,iAng + + ! Find the Shell from which this basis function is derived. + + do iSkal=1,nShell+nShell_Aux + jCnttp = iSD(13,iSkal) + jCnt = iSD(14,iSkal) + jAng = iSD(1,iSkal) + if ((jCnttp == iCnttp) .and. (jCnt == iCnt) .and. (jAng == iAng)) then + SOShl(iSO) = iSkal + !write(u6,*) 'Found in shell=',iSkal + exit + end if + end do +end do +!call iVcPrt('SOShl',' ',SOShl,nSO+nSO_Aux) +! * +!*********************************************************************** +! * +! Compute the number of effective shell pairs. + +TMax_ij = Zero +do iSkal=1,nShell + do jSkal=1,iSkal + TMax_ij = max(TMax_ij,TMax(iSkal,jSkal)) + end do +end do + +nij_Shell = 0 +do iSkal=1,nShell + do jSkal=1,iSkal + if (TMax(iSkal,jSkal)*TMax_ij >= CutOff) nij_Shell = nij_Shell+1 + end do +end do +call mma_allocate(iShij,2,nij_Shell,Label='iShij') + +ij_Shell = 0 +do iSkal=1,nShell + do jSkal=1,iSkal + if (TMax(iSkal,jSkal)*TMax_ij >= CutOff) then + ij_Shell = ij_Shell+1 + iShij(1,ij_Shell) = iSkal + iShij(2,ij_Shell) = jSkal +# ifdef _DEBUGPRINT_ + write(u6,*) 'ij_Shell,iSkal,jSkal=',ij_Shell,iSkal,jSkal +# endif + end if + end do +end do +! * +!*********************************************************************** +! * +call mma_allocate(iSSOff,[0,nIrrep-1],[0,nIrrep-1],[1,nij_Shell],Label='iSSOff') +! * +!*********************************************************************** +! * +call Setup_Aux_Inner(SOShl,nSO+nSO_Aux,ShlSO,nBasSh,nShell+nShell_Aux,nIrrep,nBas,iSSOff,nij_Shell,iShij,nBas_Aux,nChV,iTOffs) +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +write(u6,*) 'nij_Shell=',nij_Shell +write(u6,*) +do ij_Shell=1,nij_Shell + write(u6,*) iShij(1,ij_Shell),iShij(2,ij_Shell) +end do +#endif +! * +!*********************************************************************** +! * +return + +end subroutine Setup_Aux diff -Nru openmolcas-22.02/src/ri_util/setup_aux_inner.F90 openmolcas-22.10/src/ri_util/setup_aux_inner.F90 --- openmolcas-22.02/src/ri_util/setup_aux_inner.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/setup_aux_inner.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,207 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Setup_Aux_Inner(iSOShl,nSO,iShlSO,nBasSh,nShell,nIrrep,nBas,iSSOff,nij_Shell,iShij,nBas_Aux,nChV,iTOffs) + +use Index_Functions, only: nTri_Elem +use Symmetry_Info, only: Mul +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: nSO, iSOShl(nSO), nShell, nIrrep, nBas(0:nIrrep-1), nij_Shell, iShij(2,nij_Shell), & + nBas_Aux(0:nIrrep-1), nChV(0:nIrrep-1) +integer(kind=iwp), intent(out) :: iShlSO(nSO), nBasSh(0:nIrrep-1,nShell), iSSOff(0:nIrrep-1,0:nIrrep-1,nij_Shell), & + iTOffs(3,0:nIrrep-1) +integer(kind=iwp) :: iAcc, iBas, iIrrep, ijIrrep, ijShell, iOff_V12, iShell, iSO, iSO_Shl, iTtmp(0:7), jIrrep, jShell, nA, nab, & + nAux, nB, nI + +! * +!*********************************************************************** +! * +! Generate index array for relative index within the shell and irrep + +!call iVcPrt('iSOShl',' ',iSOShl,nSO) +iSO = 0 +do iIrrep=0,nIrrep-1 + do iShell=1,nShell + + iSO_Shl = 0 + do iBas=iSO+1,iSO+nBas(iIrrep) + if (iSOShl(iBas) == iShell) then + iSO_Shl = iSO_Shl+1 + ! * + !*************************************************************** + ! * + ! Save the relative index within the shell and irrep + ! of a given absolute SO index. + + iShlSO(iBas) = iSO_Shl + end if + end do + ! * + !******************************************************************* + ! * + ! Save the total number of basis functions a specific shell + ! has in a given irrep. + + nBasSh(iIrrep,iShell) = iSO_Shl + ! * + !******************************************************************* + ! * + end do + iSO = iSO+nBas(iIrrep) +end do +! * +!*********************************************************************** +! +! Initialize + +iTOffs(:,:) = 0 +iSSOff(:,:,:) = 0 +! * +!*********************************************************************** +! * +! Compute offsets within the symmetry block for a fixed shell pair. + +! Note that for each pair of valence shells all the products which +! are of the same irrep are consecutive. + +do ijShell=1,nij_Shell + iShell = iShij(1,ijShell) + jShell = iShij(2,ijShell) + iTtmp(0:nIrrep-1) = 0 + ! * + !********************************************************************* + ! * + if (iShell > jShell) then ! iShell > jShell + + do jIrrep=0,nIrrep-1 + nB = nBasSh(jIrrep,jShell) + do iIrrep=0,nIrrep-1 + nA = nBasSh(iIrrep,iShell) + + ijIrrep = Mul(iIrrep+1,jIrrep+1)-1 + iSSOff(iIrrep,jIrrep,ijShell) = iTtmp(ijIrrep) + nab = na*nb + iTtmp(ijIrrep) = iTtmp(ijIrrep)+nab + + end do + end do + + else ! iShell = jShell + + do iIrrep=0,nIrrep-1 + nA = nBasSh(iIrrep,iShell) + do jIrrep=0,iIrrep + nB = nBasSh(jIrrep,jShell) + + ijIrrep = Mul(iIrrep+1,jIrrep+1)-1 + iSSOff(iIrrep,jIrrep,ijShell) = iTtmp(ijIrrep) + iSSOff(jIrrep,iIrrep,ijShell) = iTtmp(ijIrrep) + nab = na*nb + if (iIrrep == jIrrep) nab = nTri_Elem(na) + iTtmp(ijIrrep) = iTtmp(ijIrrep)+nab + end do + end do + + end if + + do iIrrep=0,nIrrep-1 + iTOffs(3,iIrrep) = iTOffs(3,iIrrep)+iTtmp(iIrrep) + end do + + ! Now update the index to be the total offset within a slice + ! for a fixed shell-pair + + iAcc = 0 + do ijIrrep=0,nIrrep-1 + do iIrrep=0,nIrrep-1 + jIrrep = Mul(ijIrrep+1,iIrrep+1)-1 + iSSOff(iIrrep,jIrrep,ijShell) = iSSOff(iIrrep,jIrrep,ijShell)+iAcc + end do + nI = nBas_Aux(ijIrrep) + if (ijIrrep == 0) nI = nI-1 + iAcc = iAcc+nI*iTtmp(ijIrrep) + end do + ! * + !********************************************************************* + ! * +end do +#ifdef _DEBUGPRINT_ +write(u6,*) +write(u6,*) 'iSSOff' +write(u6,*) +do ijShell=1,nij_Shell + iShell = iShij(1,ijShell) + jShell = iShij(2,ijShell) + write(u6,*) + write(u6,*) 'iShell,jShell=',iShell,jShell + write(u6,*) + do i=0,nIrrep-1 + write(u6,'(8I4)') (iSSOff(i,j,ijShell),j=0,nIrrep-1) + end do +end do +#endif +! * +!*********************************************************************** +! * +! Set up pointers for the J12 matrix and compute total size of the +! 3-center integrals. + +iOff_V12 = 0 +do iIrrep=0,nIrrep-1 + iTOffs(1,iIrrep) = nChV(iIrrep) ! # of vectors + nAux = nBas_Aux(iIrrep) + if (iIrrep == 0) nAux = nAux-1 + iTOffs(2,iIrrep) = iOff_V12 + iOff_V12 = iOff_V12+nAux**2 +end do +! * +!*********************************************************************** +! * +#ifdef _DEBUGPRINT_ +write(u6,*) +write(u6,*) ' iSO, iShlSO(iSO), relative index in irrep' +do jSO=1,iSO + write(u6,*) jSO,iShlSO(jSO) +end do + +write(u6,*) +write(u6,*) ' iShell: number of basis functions in each irrep' +do iShell=1,nShell + write(u6,*) iShell,':',(nBasSh(iIrrep,iShell),iIrrep=0,nIrrep-1) +end do +write(u6,*) +write(u6,*) 'iSSOff' +write(u6,*) +do ijShell=1,nij_Shell + iShell = iShij(1,ijShell) + jShell = iShij(2,ijShell) + write(u6,*) + write(u6,*) 'iShell,jShell=',iShell,jShell + write(u6,*) + do i=0,nIrrep-1 + write(u6,'(8I4)') (iSSOff(i,j,ijShell),j=0,nIrrep-1) + end do +end do +write(u6,*) +write(u6,*) 'iTOffs' +write(u6,*) +do i=0,nIrrep-1 + write(u6,*) (iTOffs(j,i),j=1,3) +end do +#endif +! * +!*********************************************************************** +! * +return + +end subroutine Setup_Aux_Inner diff -Nru openmolcas-22.02/src/ri_util/sort_mat.f openmolcas-22.10/src/ri_util/sort_mat.f --- openmolcas-22.02/src/ri_util/sort_mat.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/sort_mat.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,86 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Francesco Aquilante * -************************************************************************ - SUBROUTINE SORT_mat(irc,nDim,nVec,iD_A,nSym,lu_A0,mode, - & lScr,Scr,Diag) -************************************************************************ -* -* Author: F. Aquilante -* -************************************************************************ - Implicit Real*8 (a-h,o-z) - Integer irc, nSym, lScr - Integer iD_A(*), nDim(nSym), nVec(nSym), lu_A0(nSym) - Real*8 Scr(lScr) - Character*7 mode - Character Name_A*6 - Real*8, Optional :: Diag(*) -* -C Write (6,*) 'Mode=',Mode - irc=0 - If (mode.eq.'GePivot') Then ! returns iD_A - If (.NOT.Present(Diag)) Call Abend() - is=1 -*19112013VVP: The threshold changed from 1.d-14 to 1.d-12 - Thr=1.0D-12 -*The original threshold: -* Thr=1.0D-14 - Do iSym=1,nSym - If (nDim(iSym)==0) Cycle - lu_A=7 - Write(Name_A,'(A4,I2.2)') 'ZMAT',iSym-1 - Call DaName_MF_WA(lu_A,Name_A) -C Call RecPrt('Diag',' ',Diag(iS),1,nDim(iSym)) - Call get_pivot_idx(Diag(is),nDim(iSym),nVec(iSym), - & lu_A0(iSym),lu_A, - & iD_A(is),Scr,lScr,Thr) - Call DaEras(lu_A) ! we do not need it -C Call RecPrt('Diag',' ',Diag(iS),1,nDim(iSym)) - is=is+nDim(iSym) - End Do - ElseIf (mode.eq.'DoPivot') Then ! store full-pivoted UT A-matrix - is=1 - Do iSym=1,nSym - If (nVec(iSym).eq.0) Go To 82 - lu_A=7 - Write(Name_A,'(A4,I2.2)') 'AMAT',iSym-1 - Call DaName_MF_WA(lu_A,Name_A) - Call Pivot_mat(nDim(iSym),nVec(iSym),lu_A0(iSym),lu_A, - & iD_A(is),Scr,lScr) - Call DaEras(lu_A0(iSym)) - lu_A0(iSym)=lu_A - 82 Continue - is=is+nDim(iSym) - End Do - - ElseIf (mode.eq.'Restore') Then !store squared Q-mat (col. piv.) - is=1 - Do iSym=1,nSym - If (nVec(iSym).eq.0) Go To 83 - lu_A=7 - Write(Name_A,'(A4,I2.2)') 'QVEC',iSym-1 - Call DaName_MF_WA(lu_A,Name_A) - Call Restore_mat(nDim(iSym),nVec(iSym),lu_A0(iSym),lu_A, - & iD_A(is),Scr,lScr,.false.) - Call DaEras(lu_A0(iSym)) - lu_A0(iSym)=lu_A - 83 Continue - is=is+nDim(iSym) - End Do - - Else - write(6,*)' SORT_mat: invalid mode! ' - irc=66 - EndIf - - Return - End diff -Nru openmolcas-22.02/src/ri_util/sort_mat.F90 openmolcas-22.10/src/ri_util/sort_mat.F90 --- openmolcas-22.02/src/ri_util/sort_mat.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/sort_mat.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,88 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Francesco Aquilante * +!*********************************************************************** + +subroutine SORT_mat(irc,nDim,nVec,iD_A,nSym,lu_A0,mode,lScr,Scr,Diag) +!*********************************************************************** +! * +! Author: F. Aquilante * +! * +!*********************************************************************** + +use Definitions, only: wp, iwp, u6 + +#include "intent.fh" + +implicit none +integer(kind=iwp), intent(out) :: irc +integer(kind=iwp), intent(in) :: nSym, nDim(nSym), lScr +integer(kind=iwp), intent(inout) :: nVec(nSym), lu_A0(nSym) +integer(kind=iwp), intent(_OUT_) :: iD_A(*) +character(len=7), intent(in) :: mode +real(kind=wp), intent(out) :: Scr(lScr) +real(kind=wp), intent(inout) :: Diag(*) +integer(kind=iwp) :: is, iSym, lu_A +! 19112013VVP: The threshold changed from 1.0e-14_wp to 1.0e-12_wp +real(kind=wp), parameter :: Thr = 1.0e-12_wp +character(len=6) :: Name_A + +!write(u6,*) 'Mode=',Mode +irc = 0 +if (mode == 'GePivot') then ! returns iD_A + is = 1 + do iSym=1,nSym + if (nDim(iSym) == 0) cycle + lu_A = 7 + write(Name_A,'(A4,I2.2)') 'ZMAT',iSym-1 + call DaName_MF_WA(lu_A,Name_A) + !call RecPrt('Diag',' ',Diag(iS),1,nDim(iSym)) + call get_pivot_idx(Diag(is),nDim(iSym),nVec(iSym),lu_A0(iSym),lu_A,iD_A(is),Scr,lScr,Thr) + call DaEras(lu_A) ! we do not need it + !call RecPrt('Diag',' ',Diag(iS),1,nDim(iSym)) + is = is+nDim(iSym) + end do +else if (mode == 'DoPivot') then ! store full-pivoted UT A-matrix + is = 1 + do iSym=1,nSym + if (nVec(iSym) /= 0) then + lu_A = 7 + write(Name_A,'(A4,I2.2)') 'AMAT',iSym-1 + call DaName_MF_WA(lu_A,Name_A) + call Pivot_mat(nDim(iSym),nVec(iSym),lu_A0(iSym),lu_A,iD_A(is),Scr,lScr) + call DaEras(lu_A0(iSym)) + lu_A0(iSym) = lu_A + end if + is = is+nDim(iSym) + end do + +else if (mode == 'Restore') then !store squared Q-mat (col. piv.) + is = 1 + do iSym=1,nSym + if (nVec(iSym) /= 0) then + lu_A = 7 + write(Name_A,'(A4,I2.2)') 'QVEC',iSym-1 + call DaName_MF_WA(lu_A,Name_A) + call Restore_mat(nDim(iSym),nVec(iSym),lu_A0(iSym),lu_A,iD_A(is),Scr,lScr,.false.) + call DaEras(lu_A0(iSym)) + lu_A0(iSym) = lu_A + end if + is = is+nDim(iSym) + end do + +else + write(u6,*) ' SORT_mat: invalid mode! ' + irc = 66 +end if + +return + +end subroutine SORT_mat diff -Nru openmolcas-22.02/src/ri_util/square_a.f openmolcas-22.10/src/ri_util/square_a.f --- openmolcas-22.02/src/ri_util/square_a.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/square_a.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,110 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Square_A(Lu,nB,MaxMem_,Force_out_of_Core) - Implicit Real*8 (a-h,o-z) -#include "stdalloc.fh" - Logical Force_out_of_Core - - Real*8, Allocatable :: Buf(:,:) -* - If (nB.eq.0) Return - MaxMem=MaxMem_ - nMem=nB**2 - If (Force_Out_of_Core) MaxMem=nMem/3 -* - If (nMem.le.MaxMem) Then -* -* In-core case -* - Call mma_allocate(Buf,nMem,1,Label='Buf') - iAddr=0 - Call dDaFile(Lu,2,Buf(:,1),nMem,iAddr) - Call In_place_Square(Buf(:,1),nB) - iAddr=0 - Call dDaFile(Lu,1,Buf(:,1),nMem,iAddr) - - Else -* -* Out-of-core case -* - nBuff=MaxMem/2 - Call mma_allocate(Buf,nBuff,2,Label='Buf') -* - Inc = nBuff/nB - iAddr1=0 - Do iB = 1, nB, Inc - mB=Min(Inc,nB-iB+1) - iAddrs=iAddr1 - Call dDaFile(Lu,2,Buf(:,1),nB*mB,iAddr1) -* - iAddr2=iAddr1 - Do jB = iB, nB, Inc - kB=Min(Inc,nB-jB+1) -* - If (jB.eq.iB) Then - Call In_place_Diag(Buf(:,1),nB,iB,iB+mB-1) - Else - Call dDaFile(Lu,2,Buf(:,2),nB*kB,iAddr2) - Call Off_Diagonal(Buf(:,1),nB,iB,iB+mB-1, - & Buf(:,2), jB,jB+kB-1) - End If - End Do -* - iAddr1=iAddrs - Call dDaFile(Lu,1,Buf(:,1),nB*mB,iAddr1) -* - End Do - End If - Call mma_deallocate(Buf) - - Return - End - Subroutine In_place_Square(Buff,nBuff) - Implicit Real*8 (a-h,o-z) - Real*8 Buff(nBuff,nBuff) -* -C Call RecPrt('Buff',' ',Buff,nBuff,nBuff) - Do j = 1, nBuff - Do i = 1, j-1 - Buff(j,i)=Buff(i,j) - End Do - End Do -C Call RecPrt('Buff',' ',Buff,nBuff,nBuff) -C Write (6,'(10F10.3)') (Buff(i,i),i=1,nBuff) -* - Return - End - Subroutine In_place_Diag(Buff,nBuff,iBs,iBe) - Implicit Real*8 (a-h,o-z) - Real*8 Buff(nBuff,iBs:iBe) -* -C Call RecPrt('Buff',' ',Buff,nBuff,iBe-iBs+1) - Do j = iBs, iBe - Do i = iBs, j-1 - Buff(j,i)=Buff(i,j) - End Do - End Do -C Call RecPrt('Buff',' ',Buff,nBuff,iBe-iBs+1) -* - Return - End - Subroutine Off_Diagonal(B1,nB,iB1s,iB1e,B2,iB2s,iB2e) - Implicit Real*8 (a-h,o-z) - Real*8 B1(nB,iB1s:iB1e), B2(nB,iB2s:iB2e) -* - Do j = iB2s, iB2e - Do i = iB1s, iB1e - B1(j,i)=B2(i,j) - End Do - End Do -* - Return - End diff -Nru openmolcas-22.02/src/ri_util/square_a.F90 openmolcas-22.10/src/ri_util/square_a.F90 --- openmolcas-22.02/src/ri_util/square_a.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/square_a.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,74 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Square_A(Lu,nB,MaxMem_,Force_out_of_Core) + +use stdalloc, only: mma_allocate, mma_deallocate +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: Lu, nB, MaxMem_ +logical(kind=iwp), intent(in) :: Force_out_of_Core +integer(kind=iwp) :: iAddr, iAddr1, iAddr2, iAddrs, iB, Inc, jB, kB, MaxMem, mB, nBuff, nMem +real(kind=wp), allocatable :: Buf(:,:) + +if (nB == 0) return +MaxMem = MaxMem_ +nMem = nB**2 +if (Force_Out_of_Core) MaxMem = nMem/3 + +if (nMem <= MaxMem) then + + ! In-core case + + call mma_allocate(Buf,nMem,1,Label='Buf') + iAddr = 0 + call dDaFile(Lu,2,Buf(:,1),nMem,iAddr) + call In_place_Square(Buf(:,1),nB) + iAddr = 0 + call dDaFile(Lu,1,Buf(:,1),nMem,iAddr) + +else + + ! Out-of-core case + + nBuff = MaxMem/2 + call mma_allocate(Buf,nBuff,2,Label='Buf') + + Inc = nBuff/nB + iAddr1 = 0 + do iB=1,nB,Inc + mB = min(Inc,nB-iB+1) + iAddrs = iAddr1 + call dDaFile(Lu,2,Buf(:,1),nB*mB,iAddr1) + + iAddr2 = iAddr1 + do jB=iB,nB,Inc + kB = min(Inc,nB-jB+1) + + if (jB == iB) then + call In_place_Diag(Buf(:,1),nB,iB,iB+mB-1) + else + call dDaFile(Lu,2,Buf(:,2),nB*kB,iAddr2) + call Off_Diagonal(Buf(:,1),nB,iB,iB+mB-1,Buf(:,2),jB,jB+kB-1) + end if + end do + + iAddr1 = iAddrs + call dDaFile(Lu,1,Buf(:,1),nB*mB,iAddr1) + + end do +end if +call mma_deallocate(Buf) + +return + +end subroutine Square_A diff -Nru openmolcas-22.02/src/ri_util/termcho_ri.f openmolcas-22.10/src/ri_util/termcho_ri.f --- openmolcas-22.02/src/ri_util/termcho_ri.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/termcho_ri.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,64 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - SubRoutine TermCho_RI(irc,nVec_RI,l_nVec_RI) - Implicit None - Integer irc, l_nVec_RI - Integer nVec_RI(l_nVec_RI) ! #RI vectors per irrep on this node - - irc = 0 - -C Save number of vectors and other info on runfile. -C ------------------------------------------------- - - Call Cho_Final(.False.) - Call Cho_RI_Final(irc,nVec_RI,l_nVec_RI) - If (irc .ne. 0) Return - -C Close storage files. -C -------------------- - - Call Cho_P_OpenVR(2) - -C Deallocate index arrays. -C ------------------------ - - Call Cho_X_Dealloc(irc) - If (irc .ne. 0) Return - -C More deallocations. -C ------------------- - - Call Cho_RI_XFree() - - End - SubRoutine Cho_RI_XFree() - use ChoArr, only: MySP - Implicit None -#include "stdalloc.fh" - - If (Allocated(MySP)) Call mma_deallocate(MySP) - - End - SubRoutine Cho_RI_Final(irc,nVec_RI,l_nVec_RI) - Implicit None - Integer irc, l_nVec_RI - Integer nVec_RI(l_nVec_RI) -#include "cholesky.fh" - - If (l_nVec_RI .lt. nSym) Then - irc = 1 - Return - Else - irc = 0 - Call Put_iArray('nVec_RI',nVec_RI,nSym) - End If - - End diff -Nru openmolcas-22.02/src/ri_util/termcho_ri.F90 openmolcas-22.10/src/ri_util/termcho_ri.F90 --- openmolcas-22.02/src/ri_util/termcho_ri.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/ri_util/termcho_ri.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,47 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine TermCho_RI(irc,nVec_RI,l_nVec_RI) + +use ChoArr, only: MySP +use stdalloc, only: mma_deallocate +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(out) :: irc +integer(kind=iwp), intent(in) :: l_nVec_RI, nVec_RI(l_nVec_RI) ! #RI vectors per irrep on this node + +irc = 0 + +! Save number of vectors and other info on runfile. +! ------------------------------------------------- + +call Cho_Final(.false.) +call Cho_RI_Final(irc,nVec_RI,l_nVec_RI) +if (irc /= 0) return + +! Close storage files. +! -------------------- + +call Cho_P_OpenVR(2) + +! Deallocate index arrays. +! ------------------------ + +call Cho_X_Dealloc(irc) +if (irc /= 0) return + +! More deallocations. +! ------------------- + +if (allocated(MySP)) call mma_deallocate(MySP) + +end subroutine TermCho_RI diff -Nru openmolcas-22.02/src/ri_util/tsk2.F90 openmolcas-22.10/src/ri_util/tsk2.F90 --- openmolcas-22.02/src/ri_util/tsk2.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/tsk2.F90 1970-01-01 00:00:00.000000000 +0000 @@ -1,14 +0,0 @@ -!*********************************************************************** -! This file is part of OpenMolcas. * -! * -! OpenMolcas is free software; you can redistribute it and/or modify * -! it under the terms of the GNU Lesser General Public License, v. 2.1. * -! OpenMolcas is distributed in the hope that it will be useful, but it * -! is provided "as is" and without any express or implied warranties. * -! For more details see the full text of the license in the file * -! LICENSE or in <http://www.gnu.org/licenses/>. * -!*********************************************************************** -Module Tsk2 -Integer :: iRsv,iOpt,nTask -Integer, Allocatable :: TskList(:) -End Module Tsk2 diff -Nru openmolcas-22.02/src/ri_util/tskman2.f openmolcas-22.10/src/ri_util/tskman2.f --- openmolcas-22.02/src/ri_util/tskman2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/ri_util/tskman2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,76 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Init_Tsk2(id,mTask,jOpt,List) - use Tsk2 -#include "stdalloc.fh" - Integer List(*) ! either nTask or 0 long -* - nTask=mTask - iOpt=jOpt - If (iOpt.eq.0) Then - Call Init_Tsk(id,nTask) - Else If (iOpt.eq.1) Then - Call mma_allocate(TskList,nTask,Label='TskList') - TskList(1:nTask) = List(1:nTask) - id = 0 - iRsv=1 - Else - Call WarningMessage(2,'Error in Init_Tsk2') - Write (6,*) 'Init_Tsk2: illegal iOpt value!' - Call Abend() - End If -* - Return - End - Logical Function Rsv_Tsk2(id,kls) - use Tsk2 -#include "stdalloc.fh" - Logical, External :: Rsv_Tsk -* - If (iOpt.eq.0) Then - Rsv_Tsk2=Rsv_Tsk(id,kls) - Else If (iOpt.eq.1) Then - Rsv_Tsk2=.True. - If (iRsv.gt.nTask) Then - Rsv_Tsk2=.False. - Else - kls=TskList(iRsv) - iRsv=iRsv+1 - If (kls.le.0) Rsv_Tsk2=.False. - If (kls.gt.nTask) Rsv_Tsk2=.False. - End If - Else - Rsv_Tsk2=.False. - Call WarningMessage(2,'Error in Rsv_Tsk2') - Write (6,*) 'Rsv_Tsk2: illegal iOpt value!' - Call Abend() - End If -* - Return - End - Subroutine Free_Tsk2(id) - use Tsk2 -#include "stdalloc.fh" -* - If (iOpt.eq.0) Then - Call Free_Tsk(id) - Else If (iOpt.eq.1) Then - Call mma_deallocate(TskList) - nTask=0 - Else - Call WarningMessage(2,'Error in Free_Tsk2') - Write (6,*) 'Free_Tsk2: illegal iOpt value!' - Call Abend() - End If - iOpt=-1 -* - Return - End diff -Nru openmolcas-22.02/src/rpa/rpa_globals.F90 openmolcas-22.10/src/rpa/rpa_globals.F90 --- openmolcas-22.02/src/rpa/rpa_globals.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rpa/rpa_globals.F90 2022-10-10 14:22:40.000000000 +0000 @@ -22,7 +22,7 @@ logical(kind=iwp) :: dRPA, SOSEX, doCD, doDF, doLDF, LumOrb character(len=3) :: Reference character(len=8) :: RPAModel -character(len=16) :: DFTFunctional +character(len=80) :: DFTFunctional real(kind=wp), allocatable :: CMO(:,:), EMO(:,:), OccEn(:,:), VirEn(:,:) integer(kind=iwp), parameter :: mTitle = 10 character(len=80) :: Title(mTitle) diff -Nru openmolcas-22.02/src/rpa/rpa_rdrun.F90 openmolcas-22.10/src/rpa/rpa_rdrun.F90 --- openmolcas-22.02/src/rpa/rpa_rdrun.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rpa/rpa_rdrun.F90 2022-10-10 14:22:40.000000000 +0000 @@ -107,7 +107,7 @@ ! Get DFT functional if (Reference(2:3) == 'KS') then - call Get_cArray('DFT functional',DFTFunctional,16) + call Get_cArray('DFT functional',DFTFunctional,80) else DFTFunctional = 'Hartree-Fock' end if diff -Nru openmolcas-22.02/src/runfile_util/get_analhess.f openmolcas-22.10/src/runfile_util/get_analhess.f --- openmolcas-22.02/src/runfile_util/get_analhess.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/runfile_util/get_analhess.f 2022-10-10 14:22:40.000000000 +0000 @@ -13,17 +13,17 @@ * Get_AnalHess * *> @brief -*> Read the the symmetry blocked nuclear Hessian from the runfile and return a +*> Read the the symmetry-blocked nuclear Hessian from the runfile and return a *> pointer to the array's location in \c Work and the length of the array *> @author R. Lindh *> *> @details -*> The utility will read the symmetry blocked nuclear Hessian from the runfile and +*> The utility will read the symmetry-blocked nuclear Hessian from the runfile and *> return a pointer and the length of the array. *> -*> @param[out] ipAnalHess pointer to array with the symmetry blocked nuclear Hessian -*> in Cartesian coordinates -*> @param[out] nAnalHess size of the array of the symmetry blocked nuclear Hessian +*> @param[out] Hess Array with the symmetry-blocked nuclear Hessian +*> in Cartesian coordinates +*> @param[out] nHess Size of the array of the symmetry-blocked nuclear Hessian ************************************************************************ Subroutine Get_AnalHess(Hess,nHess) Implicit Real*8 (A-H,O-Z) diff -Nru openmolcas-22.02/src/runfile_util/get_coord_new.f openmolcas-22.10/src/runfile_util/get_coord_new.f --- openmolcas-22.02/src/runfile_util/get_coord_new.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/runfile_util/get_coord_new.f 2022-10-10 14:22:40.000000000 +0000 @@ -13,14 +13,14 @@ * Get_Coord_New * *> @brief -*> Get the updated/new symmetry unique Cartesian coordinates of the basis set centers +*> Get the updated/new symmetry-unique Cartesian coordinates of the basis set centers *> @author R. Lindh *> *> @details -*> The utility will read the updated/new symmetry unique Cartesian coordinates of the basis set centers from the runfile. +*> The utility will read the updated/new symmetry-unique Cartesian coordinates of the basis set centers from the runfile. *> -*> @param[out] ipCoord Pointer to \c Work of the array of the symmetry unique Cartesian coordinates of the basis set centers -*> @param[in] nAtoms Number of symmetry unique Cartesian coordinates of the basis set centers +*> @param[out] CN Array of the symmetry-unique Cartesian coordinates of the basis set centers +*> @param[in] nAtoms Number of symmetry-unique basis set centers ************************************************************************ Subroutine Get_Coord_New(CN,nAtoms) Implicit Real*8 (a-h,o-z) diff -Nru openmolcas-22.02/src/runfile_util/get_dexcdra.f openmolcas-22.10/src/runfile_util/get_dexcdra.f --- openmolcas-22.02/src/runfile_util/get_dexcdra.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/runfile_util/get_dexcdra.f 2022-10-10 14:22:40.000000000 +0000 @@ -12,7 +12,7 @@ Implicit Real*8 (A-H,O-Z) #include "WrkSpc.fh" - Character*24 Label + Character(LEN=24) Label Logical Found Label='dExcdRa' @@ -25,3 +25,25 @@ Return End + Subroutine Get_dExcdRa_X(dExcdRa,ndExcdRa) + Implicit None + Character(LEN=24) Label + Logical Found + Integer :: mdExcdRa=-1 + Integer, Intent(In) :: ndExcdRa + Real*8, Intent(Out) :: dExcdRa(ndExcdRa) + + Label='dExcdRa' + Call qpg_dArray(Label,Found,mdExcdRa) + If(.not.Found .or. mdExcdRa.eq.0) Then + Call SysAbendmsg('Get_dExcdRa','Did not find:',Label) + End If + If (mdExcdRa/=ndExcdRa) Then + Write (6,*) 'mdExcdRa/=ndExcdRa' + Write (6,*) mdExcdRa,'/=',ndExcdRa + Call AbEnd() + End If + Call Get_dArray(Label,dExcdRa,ndExcdRa) + + Return + End diff -Nru openmolcas-22.02/src/runfile_util/get_grad_full.f openmolcas-22.10/src/runfile_util/get_grad_full.f --- openmolcas-22.02/src/runfile_util/get_grad_full.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/runfile_util/get_grad_full.f 2022-10-10 14:22:40.000000000 +0000 @@ -20,8 +20,8 @@ *> Place Cartesian gradient (in a.u.) into array \p Grad_Full(3,*). *> Includes MM atoms otherwise invisible to gateway/slapaf. *> -*> @param[out] Grad_Full Array of gradient -*> @param[in] nAtoms_All Number of atoms +*> @param[out] Grad_Full Array of gradient +*> @param[in] nAtoms_Full Number of atoms ************************************************************************ Subroutine Get_Grad_Full(Grad_Full,nAtoms_Full) Implicit None diff -Nru openmolcas-22.02/src/runfile_util/get_mass.f openmolcas-22.10/src/runfile_util/get_mass.f --- openmolcas-22.02/src/runfile_util/get_mass.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/runfile_util/get_mass.f 2022-10-10 14:22:40.000000000 +0000 @@ -19,8 +19,8 @@ *> @details *> Place atomic masses (in a.u.) into array \p Mass_All(*). *> -*> @param[out] Mass_All Array of masses -*> @param[in] nAtoms_All Number of atoms +*> @param[out] Mass Array of masses +*> @param[in] nAtoms Number of atoms ************************************************************************ Subroutine Get_Mass(Mass,nAtoms) Implicit None diff -Nru openmolcas-22.02/src/runfile_util/put_carray.f openmolcas-22.10/src/runfile_util/put_carray.f --- openmolcas-22.02/src/runfile_util/put_carray.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/runfile_util/put_carray.f 2022-10-10 14:22:40.000000000 +0000 @@ -130,6 +130,7 @@ RecLab( 26)='SymmetryCInfo ' RecLab( 27)='SewardXTitle ' RecLab( 28)='Align_Weights ' + RecLab( 29)='Quad_c ' * 1234567890123456 Call cWrRun('cArray labels',RecLab,16*nTocCA) Call iWrRun('cArray indices',RecIdx,nTocCA) diff -Nru openmolcas-22.02/src/runfile_util/put_darray.f openmolcas-22.10/src/runfile_util/put_darray.f --- openmolcas-22.02/src/runfile_util/put_darray.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/runfile_util/put_darray.f 2022-10-10 14:22:40.000000000 +0000 @@ -365,6 +365,7 @@ RecLab(205)='F1MS ' RecLab(206)='F2MS ' RecLab(207)='FxyMS ' + RecLab(208)='SH_Ovlp_Save ' * 1234567890123456 * * If you go beyond 256: update pg_da_info.fh and this line! diff -Nru openmolcas-22.02/src/runfile_util/put_dscalar.f openmolcas-22.10/src/runfile_util/put_dscalar.f --- openmolcas-22.02/src/runfile_util/put_dscalar.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/runfile_util/put_dscalar.f 2022-10-10 14:22:40.000000000 +0000 @@ -144,6 +144,7 @@ RecLab( 35)='DFT exch coeff ' RecLab( 36)='DFT corr coeff ' RecLab( 37)='Value_l ' + RecLab( 38)='R_WF_HMC ' * 1234567890123456 * * If u go beyond 64: update pg_ds_info.fh and this line! diff -Nru openmolcas-22.02/src/runfile_util/put_iarray.f openmolcas-22.10/src/runfile_util/put_iarray.f --- openmolcas-22.02/src/runfile_util/put_iarray.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/runfile_util/put_iarray.f 2022-10-10 14:22:40.000000000 +0000 @@ -116,7 +116,7 @@ RecLab( 11)='Symmetry operati' !ons RecLab( 12)='nIsh_ab ' RecLab( 13)='nStab ' - RecLab( 14)='Quad_c ' + RecLab( 14)=' ' !Free slot RecLab( 15)='Quad_i ' RecLab( 16)='RFcInfo ' RecLab( 17)='RFiInfo ' diff -Nru openmolcas-22.02/src/runfile_util/put_iscalar.f openmolcas-22.10/src/runfile_util/put_iscalar.f --- openmolcas-22.02/src/runfile_util/put_iscalar.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/runfile_util/put_iscalar.f 2022-10-10 14:22:40.000000000 +0000 @@ -187,6 +187,7 @@ RecLab( 76)='CSPF ' * For MS-PDFT gradient RecLab( 77)='NCONF ' + RecLab( 78)='SH RASSI run ' * 1234567890123456 * * Note, when the counter here exceeds 128 update this line diff -Nru openmolcas-22.02/src/rys_util/abdata.F90 openmolcas-22.10/src/rys_util/abdata.F90 --- openmolcas-22.02/src/rys_util/abdata.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/abdata.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,85 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +module abdata + +use Definitions, only: wp + +implicit none +private + +real(kind=wp), allocatable :: atab(:,:), btab(:,:), p0(:), tvalue(:) + +public :: atab, btab, close_abdata, p0, read_abdata, tvalue + +contains + +subroutine read_abdata() + + use Definitions, only: iwp + use stdalloc, only: mma_allocate + + integer(kind=iwp) :: i, k, lu_abdata, maxdeg, ntab1, ntab2 + character(len=8) :: key + logical(kind=iwp) :: found_abdata + character(len=*), parameter :: ABDATA_NAME = 'ABDATA' + integer(kind=iwp), external :: isFreeUnit + +# include "macros.fh" + + call f_Inquire(ABDATA_NAME,found_abdata) + if (.not. found_abdata) then + call warningmessage(2,' the abdata file does not exist.') + call abend() + end if + lu_abdata = isFreeUnit(22) + call molcas_open(lu_abdata,ABDATA_NAME) + + do + read(lu_abdata,'(a8)') key + if (key == 'NTAB1, N') exit + end do + read(lu_abdata,*) ntab1,ntab2,maxdeg + call mma_allocate(atab,[0,maxdeg],[ntab1,ntab2],label='atab') + call mma_allocate(btab,[0,maxdeg],[ntab1,ntab2],label='btab') + call mma_allocate(p0,[ntab1,ntab2],label='p0') + call mma_allocate(tvalue,[ntab1,ntab2],label='tvalue') + do i=ntab1,ntab2 + do + read(lu_abdata,'(a8)') key + if (key == 'TAB POIN') exit + end do + read(lu_abdata,*) k,tvalue(i),p0(i) + unused_var(k) + read(lu_abdata,*) + read(lu_abdata,*) atab(:,i) + read(lu_abdata,*) + read(lu_abdata,*) btab(:,i) + end do + + close(lu_abdata) + + return + +end subroutine read_abdata + +subroutine close_abdata() + + use stdalloc, only: mma_deallocate + + if (allocated(atab)) call mma_deallocate(atab) + if (allocated(btab)) call mma_deallocate(btab) + if (allocated(p0)) call mma_deallocate(p0) + if (allocated(tvalue)) call mma_deallocate(tvalue) + +end subroutine close_abdata + +end module abdata diff -Nru openmolcas-22.02/src/rys_util/abtab.fh openmolcas-22.10/src/rys_util/abtab.fh --- openmolcas-22.02/src/rys_util/abtab.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/abtab.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,15 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - integer, parameter :: mxsiz1=20, mxsiz2=700 - real*8 :: atab(0:mxsiz1,mxsiz2), btab(0:mxsiz1,mxsiz2) - real*8 :: tvalue(mxsiz2), p0(mxsiz2) - integer :: ntab1, ntab2, maxdeg - common /abtab/ atab,btab,tvalue,p0,ntab1,ntab2,maxdeg diff -Nru openmolcas-22.02/src/rys_util/ass1a.f openmolcas-22.10/src/rys_util/ass1a.f --- openmolcas-22.02/src/rys_util/ass1a.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ass1a.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,132 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - subroutine ass1a(D01,D1,PAO,tmp1_,nt,nrys) - implicit real*8 (a-h,o-z) - dimension D01(nrys,nt) - dimension D1(nrys,nt),PAO(nt) -c - If (nRys.eq.1) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT)*PAO(iT)) * D1(1,iT) - enddo - tmp1_ = tmp1_ + tmp1 - return - Else If (nRys.eq.2) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return -c - Else If (nRys.eq.3) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return -c - Else If (nRys.eq.4) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT) - > + D01(4,iT) * D1(4,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return - - Else If (nRys.eq.5) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT) - > + D01(4,iT) * D1(4,iT) - > + D01(5,iT) * D1(5,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return -c - Else If (nRys.eq.6) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT) - > + D01(4,iT) * D1(4,iT) - > + D01(5,iT) * D1(5,iT) - > + D01(6,iT) * D1(6,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return -c - Else If (nRys.eq.7) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT) - > + D01(4,iT) * D1(4,iT) - > + D01(5,iT) * D1(5,iT) - > + D01(6,iT) * D1(6,iT) - > + D01(7,iT) * D1(7,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return -c - Else If (nRys.eq.8) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT) - > + D01(4,iT) * D1(4,iT) - > + D01(5,iT) * D1(5,iT) - > + D01(6,iT) * D1(6,iT) - > + D01(7,iT) * D1(7,iT) - > + D01(8,iT) * D1(8,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return -c - Else If (nRys.eq.9) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT) - > + D01(4,iT) * D1(4,iT) - > + D01(5,iT) * D1(5,iT) - > + D01(6,iT) * D1(6,iT) - > + D01(7,iT) * D1(7,iT) - > + D01(8,iT) * D1(8,iT) - > + D01(9,iT) * D1(9,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return - Else - tmp1=0.0D0 - Do iT = 1, nT - Do iRys = 1, nRys - tmp1 = tmp1 + D01(iRys,iT)*PAO(It)*D1(iRys,iT) - End Do - End Do - tmp1_ = tmp1_ + tmp1 - return - End If - end diff -Nru openmolcas-22.02/src/rys_util/ass1a.F90 openmolcas-22.10/src/rys_util/ass1a.F90 --- openmolcas-22.02/src/rys_util/ass1a.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ass1a.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,88 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine ass1a(D01,D1,PAO,tmp1_,nt,nrys) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nt, nrys +real(kind=wp), intent(in) :: D01(nrys,nt), D1(nrys,nt), PAO(nt) +real(kind=wp), intent(inout) :: tmp1_ +integer(kind=iwp) :: iRys, iT +real(kind=wp) :: tmp1 + +tmp1 = Zero + +select case (nRys) + + case (1) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*PAO(iT))*D1(1,iT) + end do + + case (2) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT))*PAO(iT) + end do + + case (3) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT))*PAO(iT) + end do + + case (4) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT)+D01(4,iT)*D1(4,iT))*PAO(iT) + end do + + case (5) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT)+D01(4,iT)*D1(4,iT)+D01(5,iT)*D1(5,iT))*PAO(iT) + end do + + case (6) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT)+D01(4,iT)*D1(4,iT)+D01(5,iT)*D1(5,iT)+ & + D01(6,iT)*D1(6,iT))*PAO(iT) + end do + + case (7) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT)+D01(4,iT)*D1(4,iT)+D01(5,iT)*D1(5,iT)+ & + D01(6,iT)*D1(6,iT)+D01(7,iT)*D1(7,iT))*PAO(iT) + end do + + case (8) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT)+D01(4,iT)*D1(4,iT)+D01(5,iT)*D1(5,iT)+ & + D01(6,iT)*D1(6,iT)+D01(7,iT)*D1(7,iT)+D01(8,iT)*D1(8,iT))*PAO(iT) + end do + + case (9) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT)+D01(4,iT)*D1(4,iT)+D01(5,iT)*D1(5,iT)+ & + D01(6,iT)*D1(6,iT)+D01(7,iT)*D1(7,iT)+D01(8,iT)*D1(8,iT)+D01(9,iT)*D1(9,iT))*PAO(iT) + end do + + case default + do iT=1,nt + do iRys=1,nRys + tmp1 = tmp1+D01(iRys,iT)*PAO(iT)*D1(iRys,iT) + end do + end do + +end select + +tmp1_ = tmp1_+tmp1 + +end subroutine ass1a diff -Nru openmolcas-22.02/src/rys_util/ass1b.f openmolcas-22.10/src/rys_util/ass1b.f --- openmolcas-22.02/src/rys_util/ass1b.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ass1b.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,132 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - subroutine ass1b(D1,PAO,tmp1_,nt,nrys) - implicit real*8 (a-h,o-z) - dimension D1(nrys,nt),PAO(nt) -c - If (nRys.eq.1) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + PAO(iT) * D1(1,iT) - enddo - tmp1_ = tmp1_ + tmp1 - return - - Else If (nRys.eq.2) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return -c - Else If (nRys.eq.3) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return -c - Else If (nRys.eq.4) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT) - > + D1(4,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return - - Else If (nRys.eq.5) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT) - > + D1(4,iT) - > + D1(5,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return -c - Else If (nRys.eq.6) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT) - > + D1(4,iT) - > + D1(5,iT) - > + D1(6,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return -c - Else If (nRys.eq.7) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT) - > + D1(4,iT) - > + D1(5,iT) - > + D1(6,iT) - > + D1(7,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return -c - Else If (nRys.eq.8) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT) - > + D1(4,iT) - > + D1(5,iT) - > + D1(6,iT) - > + D1(7,iT) - > + D1(8,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return -c - Else If (nRys.eq.9) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT) - > + D1(4,iT) - > + D1(5,iT) - > + D1(6,iT) - > + D1(7,iT) - > + D1(8,iT) - > + D1(9,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return - Else - tmp1=0.0D0 - Do iT = 1, nT - Do iRys = 1, nRys - tmp1 = tmp1 + PAO(It)*D1(iRys,iT) - End Do - End Do - tmp1_ = tmp1_ + tmp1 - return - End If - end diff -Nru openmolcas-22.02/src/rys_util/ass1b.F90 openmolcas-22.10/src/rys_util/ass1b.F90 --- openmolcas-22.02/src/rys_util/ass1b.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ass1b.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,84 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine ass1b(D1,PAO,tmp1_,nt,nrys) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nt, nrys +real(kind=wp), intent(in) :: D1(nrys,nt), PAO(nt) +real(kind=wp), intent(inout) :: tmp1_ +integer(kind=iwp) :: iRys, iT +real(kind=wp) :: tmp1 + +tmp1 = Zero + +select case (nRys) + + case (1) + do iT=1,nt + tmp1 = tmp1+PAO(iT)*D1(1,iT) + end do + + case (2) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT))*PAO(iT) + end do + + case (3) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT))*PAO(iT) + end do + + case (4) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT)+D1(4,iT))*PAO(iT) + end do + + case (5) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT)+D1(4,iT)+D1(5,iT))*PAO(iT) + end do + + case (6) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT)+D1(4,iT)+D1(5,iT)+D1(6,iT))*PAO(iT) + end do + + case (7) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT)+D1(4,iT)+D1(5,iT)+D1(6,iT)+D1(7,iT))*PAO(iT) + end do + + case (8) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT)+D1(4,iT)+D1(5,iT)+D1(6,iT)+D1(7,iT)+D1(8,iT))*PAO(iT) + end do + + case (9) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT)+D1(4,iT)+D1(5,iT)+D1(6,iT)+D1(7,iT)+D1(8,iT)+D1(9,iT))*PAO(iT) + end do + + case default + do iT=1,nt + do iRys=1,nRys + tmp1 = tmp1+PAO(iT)*D1(iRys,iT) + end do + end do + +end select + +tmp1_ = tmp1_+tmp1 + +end subroutine ass1b diff -Nru openmolcas-22.02/src/rys_util/ass1.f openmolcas-22.10/src/rys_util/ass1.f --- openmolcas-22.02/src/rys_util/ass1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ass1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,133 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - subroutine ass1(D01,D02,D1,PAO,tmp1_,nt,nrys) - implicit real*8 (a-h,o-z) - dimension D01(nRys,nt),D02(nRys,nt) - dimension D1(nRys,nt),PAO(nt) -c - If (nRys.eq.1) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT)*D02(1,iT)*PAO(iT)) * D1(1,iT) - enddo - tmp1_ = tmp1_ + tmp1 - return - - Else If (nRys.eq.2) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return -c - Else If (nRys.eq.3) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return -c - Else If (nRys.eq.4) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D1(4,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return - - Else If (nRys.eq.5) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D1(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D1(5,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return -c - Else If (nRys.eq.6) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D1(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D1(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D1(6,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return -c - Else If (nRys.eq.7) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D1(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D1(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D1(6,iT) - > + (D01(7,iT)*D02(7,iT)) * D1(7,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return -c - Else If (nRys.eq.8) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D1(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D1(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D1(6,iT) - > + (D01(7,iT)*D02(7,iT)) * D1(7,iT) - > + (D01(8,iT)*D02(8,iT)) * D1(8,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return -c - Else If (nRys.eq.9) Then - tmp1=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D1(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D1(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D1(6,iT) - > + (D01(7,iT)*D02(7,iT)) * D1(7,iT) - > + (D01(8,iT)*D02(8,iT)) * D1(8,iT) - > + (D01(9,iT)*D02(9,iT)) * D1(9,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - return - Else - tmp1=0.0D0 - Do iT = 1, nT - Do iRys = 1, nRys - tmp1 = tmp1 + (D01(iRys,iT)*D02(iRys,iT)*PAO(It))*D1(iRys,iT) - End Do - End Do - tmp1_ = tmp1_ + tmp1 - return - End If - end diff -Nru openmolcas-22.02/src/rys_util/ass1.F90 openmolcas-22.10/src/rys_util/ass1.F90 --- openmolcas-22.02/src/rys_util/ass1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ass1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,93 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine ass1(D01,D02,D1,PAO,tmp1_,nt,nrys) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nt, nrys +real(kind=wp), intent(in) :: D01(nRys,nt), D02(nRys,nt), D1(nRys,nt), PAO(nt) +real(kind=wp), intent(inout) :: tmp1_ +integer(kind=iwp) :: iRys, iT +real(kind=wp) :: tmp1 + +tmp1 = Zero + +select case (nRys) + + case (1) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D02(1,iT)*PAO(iT))*D1(1,iT) + end do + + case (2) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT))*PAO(iT) + end do + + case (3) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT))*PAO(iT) + end do + + case (4) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D1(4,iT))*PAO(iT) + end do + + case (5) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D1(4,iT)+(D01(5,iT)*D02(5,iT))*D1(5,iT))*PAO(iT) + end do + + case (6) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D1(4,iT)+(D01(5,iT)*D02(5,iT))*D1(5,iT)+(D01(6,iT)*D02(6,iT))*D1(6,iT))*PAO(iT) + end do + + case (7) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D1(4,iT)+(D01(5,iT)*D02(5,iT))*D1(5,iT)+(D01(6,iT)*D02(6,iT))*D1(6,iT)+ & + (D01(7,iT)*D02(7,iT))*D1(7,iT))*PAO(iT) + end do + + case (8) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D1(4,iT)+(D01(5,iT)*D02(5,iT))*D1(5,iT)+(D01(6,iT)*D02(6,iT))*D1(6,iT)+ & + (D01(7,iT)*D02(7,iT))*D1(7,iT)+(D01(8,iT)*D02(8,iT))*D1(8,iT))*PAO(iT) + end do + + case (9) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D1(4,iT)+(D01(5,iT)*D02(5,iT))*D1(5,iT)+(D01(6,iT)*D02(6,iT))*D1(6,iT)+ & + (D01(7,iT)*D02(7,iT))*D1(7,iT)+(D01(8,iT)*D02(8,iT))*D1(8,iT)+(D01(9,iT)*D02(9,iT))*D1(9,iT))*PAO(iT) + end do + + case default + do iT=1,nt + do iRys=1,nRys + tmp1 = tmp1+(D01(iRys,iT)*D02(iRys,iT)*PAO(iT))*D1(iRys,iT) + end do + end do + +end select + +tmp1_ = tmp1_+tmp1 + +end subroutine ass1 diff -Nru openmolcas-22.02/src/rys_util/ass2a.f openmolcas-22.10/src/rys_util/ass2a.f --- openmolcas-22.02/src/rys_util/ass2a.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ass2a.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,200 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - subroutine ass2a(D01,D1,D2,PAO,tmp1_,tmp2_,nt,nrys) - implicit real*8 (a-h,o-z) - dimension D01(nrys,nt) - dimension D1(nrys,nt),d2(nrys,nt),PAO(nt) -c - If (nRys.eq.1) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT)*PAO(iT)) * D1(1,iT) - tmp2 = tmp2 + (D01(1,iT)*PAO(iT)) * D2(1,iT) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return - - Else If (nRys.eq.2) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT)) * PAO(It) - tmp2 = tmp2 + (D01(1,iT) * D2(1,iT) - > + D01(2,iT) * D2(2,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else If (nRys.eq.3) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT)) * PAO(It) - tmp2 = tmp2 + (D01(1,iT) * D2(1,iT) - > + D01(2,iT) * D2(2,iT) - > + D01(3,iT) * D2(3,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else If (nRys.eq.4) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT) - > + D01(4,iT) * D1(4,iT)) * PAO(It) - tmp2 = tmp2 + (D01(1,iT) * D2(1,iT) - > + D01(2,iT) * D2(2,iT) - > + D01(3,iT) * D2(3,iT) - > + D01(4,iT) * D2(4,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return - - Else If (nRys.eq.5) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT) - > + D01(4,iT) * D1(4,iT) - > + D01(5,iT) * D1(5,iT)) * PAO(It) - tmp2 = tmp2 + (D01(1,iT) * D2(1,iT) - > + D01(2,iT) * D2(2,iT) - > + D01(3,iT) * D2(3,iT) - > + D01(4,iT) * D2(4,iT) - > + D01(5,iT) * D2(5,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else If (nRys.eq.6) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT) - > + D01(4,iT) * D1(4,iT) - > + D01(5,iT) * D1(5,iT) - > + D01(6,iT) * D1(6,iT)) * PAO(It) - tmp2 = tmp2 + (D01(1,iT) * D2(1,iT) - > + D01(2,iT) * D2(2,iT) - > + D01(3,iT) * D2(3,iT) - > + D01(4,iT) * D2(4,iT) - > + D01(5,iT) * D2(5,iT) - > + D01(6,iT) * D2(6,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else If (nRys.eq.7) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT) - > + D01(4,iT) * D1(4,iT) - > + D01(5,iT) * D1(5,iT) - > + D01(6,iT) * D1(6,iT) - > + D01(7,iT) * D1(7,iT)) * PAO(It) - tmp2 = tmp2 + (D01(1,iT) * D2(1,iT) - > + D01(2,iT) * D2(2,iT) - > + D01(3,iT) * D2(3,iT) - > + D01(4,iT) * D2(4,iT) - > + D01(5,iT) * D2(5,iT) - > + D01(6,iT) * D2(6,iT) - > + D01(7,iT) * D2(7,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else If (nRys.eq.8) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT) - > + D01(4,iT) * D1(4,iT) - > + D01(5,iT) * D1(5,iT) - > + D01(6,iT) * D1(6,iT) - > + D01(7,iT) * D1(7,iT) - > + D01(8,iT) * D1(8,iT)) * PAO(It) - tmp2 = tmp2 + (D01(1,iT) * D2(1,iT) - > + D01(2,iT) * D2(2,iT) - > + D01(3,iT) * D2(3,iT) - > + D01(4,iT) * D2(4,iT) - > + D01(5,iT) * D2(5,iT) - > + D01(6,iT) * D2(6,iT) - > + D01(7,iT) * D2(7,iT) - > + D01(8,iT) * D2(8,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else If (nRys.eq.9) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT) - > + D01(4,iT) * D1(4,iT) - > + D01(5,iT) * D1(5,iT) - > + D01(6,iT) * D1(6,iT) - > + D01(7,iT) * D1(7,iT) - > + D01(8,iT) * D1(8,iT) - > + D01(9,iT) * D1(9,iT)) * PAO(It) - tmp2 = tmp2 + (D01(1,iT) * D2(1,iT) - > + D01(2,iT) * D2(2,iT) - > + D01(3,iT) * D2(3,iT) - > + D01(4,iT) * D2(4,iT) - > + D01(5,iT) * D2(5,iT) - > + D01(6,iT) * D2(6,iT) - > + D01(7,iT) * D2(7,iT) - > + D01(8,iT) * D2(8,iT) - > + D01(9,iT) * D2(9,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else - tmp1=0.0D0 - tmp2=0.0D0 - Do iT = 1, nT - Do iRys = 1, nRys - tmp1 = tmp1 + (D01(iRys,iT)*PAO(It))*D1(iRys,iT) - tmp2 = tmp2 + (D01(iRys,iT)*PAO(It))*D2(iRys,iT) - End Do - End Do - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return - End If - end diff -Nru openmolcas-22.02/src/rys_util/ass2a.F90 openmolcas-22.10/src/rys_util/ass2a.F90 --- openmolcas-22.02/src/rys_util/ass2a.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ass2a.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,104 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine ass2a(D01,D1,D2,PAO,tmp1_,tmp2_,nt,nrys) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nt, nrys +real(kind=wp), intent(in) :: D01(nrys,nt), D1(nrys,nt), D2(nrys,nt), PAO(nt) +real(kind=wp), intent(inout) :: tmp1_, tmp2_ +integer(kind=iwp) :: iRys, iT +real(kind=wp) :: tmp1, tmp2 + +tmp1 = Zero +tmp2 = Zero + +select case (nRys) + + case (1) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*PAO(iT))*D1(1,iT) + tmp2 = tmp2+(D01(1,iT)*PAO(iT))*D2(1,iT) + end do + + case (2) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT))*PAO(iT) + tmp2 = tmp2+(D01(1,iT)*D2(1,iT)+D01(2,iT)*D2(2,iT))*PAO(iT) + end do + + case (3) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT))*PAO(iT) + tmp2 = tmp2+(D01(1,iT)*D2(1,iT)+D01(2,iT)*D2(2,iT)+D01(3,iT)*D2(3,iT))*PAO(iT) + end do + + case (4) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT)+D01(4,iT)*D1(4,iT))*PAO(iT) + tmp2 = tmp2+(D01(1,iT)*D2(1,iT)+D01(2,iT)*D2(2,iT)+D01(3,iT)*D2(3,iT)+D01(4,iT)*D2(4,iT))*PAO(iT) + end do + + case (5) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT)+D01(4,iT)*D1(4,iT)+D01(5,iT)*D1(5,iT))*PAO(iT) + tmp2 = tmp2+(D01(1,iT)*D2(1,iT)+D01(2,iT)*D2(2,iT)+D01(3,iT)*D2(3,iT)+D01(4,iT)*D2(4,iT)+D01(5,iT)*D2(5,iT))*PAO(iT) + end do + + case (6) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT)+D01(4,iT)*D1(4,iT)+D01(5,iT)*D1(5,iT)+ & + D01(6,iT)*D1(6,iT))*PAO(iT) + tmp2 = tmp2+(D01(1,iT)*D2(1,iT)+D01(2,iT)*D2(2,iT)+D01(3,iT)*D2(3,iT)+D01(4,iT)*D2(4,iT)+D01(5,iT)*D2(5,iT)+ & + D01(6,iT)*D2(6,iT))*PAO(iT) + end do + + case (7) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT)+D01(4,iT)*D1(4,iT)+D01(5,iT)*D1(5,iT)+ & + D01(6,iT)*D1(6,iT)+D01(7,iT)*D1(7,iT))*PAO(iT) + tmp2 = tmp2+(D01(1,iT)*D2(1,iT)+D01(2,iT)*D2(2,iT)+D01(3,iT)*D2(3,iT)+D01(4,iT)*D2(4,iT)+D01(5,iT)*D2(5,iT)+ & + D01(6,iT)*D2(6,iT)+D01(7,iT)*D2(7,iT))*PAO(iT) + end do + + case (8) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT)+D01(4,iT)*D1(4,iT)+D01(5,iT)*D1(5,iT)+ & + D01(6,iT)*D1(6,iT)+D01(7,iT)*D1(7,iT)+D01(8,iT)*D1(8,iT))*PAO(iT) + tmp2 = tmp2+(D01(1,iT)*D2(1,iT)+D01(2,iT)*D2(2,iT)+D01(3,iT)*D2(3,iT)+D01(4,iT)*D2(4,iT)+D01(5,iT)*D2(5,iT)+ & + D01(6,iT)*D2(6,iT)+D01(7,iT)*D2(7,iT)+D01(8,iT)*D2(8,iT))*PAO(iT) + end do + + case (9) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT)+D01(4,iT)*D1(4,iT)+D01(5,iT)*D1(5,iT)+ & + D01(6,iT)*D1(6,iT)+D01(7,iT)*D1(7,iT)+D01(8,iT)*D1(8,iT)+D01(9,iT)*D1(9,iT))*PAO(iT) + tmp2 = tmp2+(D01(1,iT)*D2(1,iT)+D01(2,iT)*D2(2,iT)+D01(3,iT)*D2(3,iT)+D01(4,iT)*D2(4,iT)+D01(5,iT)*D2(5,iT)+ & + D01(6,iT)*D2(6,iT)+D01(7,iT)*D2(7,iT)+D01(8,iT)*D2(8,iT)+D01(9,iT)*D2(9,iT))*PAO(iT) + end do + + case default + do iT=1,nt + do iRys=1,nRys + tmp1 = tmp1+(D01(iRys,iT)*PAO(iT))*D1(iRys,iT) + tmp2 = tmp2+(D01(iRys,iT)*PAO(iT))*D2(iRys,iT) + end do + end do + +end select + +tmp1_ = tmp1_+tmp1 +tmp2_ = tmp2_+tmp2 + +end subroutine ass2a diff -Nru openmolcas-22.02/src/rys_util/ass2b.f openmolcas-22.10/src/rys_util/ass2b.f --- openmolcas-22.02/src/rys_util/ass2b.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ass2b.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,199 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - subroutine ass2b(D1,D2,PAO,tmp1_,tmp2_,nt,nrys) - implicit real*8 (a-h,o-z) - dimension D1(nRys,nt),d2(nRys,nt),PAO(nt) -c - If (nRys.eq.1) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + PAO(iT) * D1(1,iT) - tmp2 = tmp2 + PAO(iT) * D2(1,iT) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return - - Else If (nRys.eq.2) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT)) * PAO(It) - tmp2 = tmp2 + (D2(1,iT) - > + D2(2,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else If (nRys.eq.3) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT)) * PAO(It) - tmp2 = tmp2 + (D2(1,iT) - > + D2(2,iT) - > + D2(3,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else If (nRys.eq.4) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT) - > + D1(4,iT)) * PAO(It) - tmp2 = tmp2 + (D2(1,iT) - > + D2(2,iT) - > + D2(3,iT) - > + D2(4,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return - - Else If (nRys.eq.5) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT) - > + D1(4,iT) - > + D1(5,iT)) * PAO(It) - tmp2 = tmp2 + (D2(1,iT) - > + D2(2,iT) - > + D2(3,iT) - > + D2(4,iT) - > + D2(5,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else If (nRys.eq.6) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT) - > + D1(4,iT) - > + D1(5,iT) - > + D1(6,iT)) * PAO(It) - tmp2 = tmp2 + (D2(1,iT) - > + D2(2,iT) - > + D2(3,iT) - > + D2(4,iT) - > + D2(5,iT) - > + D2(6,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else If (nRys.eq.7) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT) - > + D1(4,iT) - > + D1(5,iT) - > + D1(6,iT) - > + D1(7,iT)) * PAO(It) - tmp2 = tmp2 + (D2(1,iT) - > + D2(2,iT) - > + D2(3,iT) - > + D2(4,iT) - > + D2(5,iT) - > + D2(6,iT) - > + D2(7,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else If (nRys.eq.8) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT) - > + D1(4,iT) - > + D1(5,iT) - > + D1(6,iT) - > + D1(7,iT) - > + D1(8,iT)) * PAO(It) - tmp2 = tmp2 + (D2(1,iT) - > + D2(2,iT) - > + D2(3,iT) - > + D2(4,iT) - > + D2(5,iT) - > + D2(6,iT) - > + D2(7,iT) - > + D2(8,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else If (nRys.eq.9) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT) - > + D1(4,iT) - > + D1(5,iT) - > + D1(6,iT) - > + D1(7,iT) - > + D1(8,iT) - > + D1(9,iT)) * PAO(It) - tmp2 = tmp2 + (D2(1,iT) - > + D2(2,iT) - > + D2(3,iT) - > + D2(4,iT) - > + D2(5,iT) - > + D2(6,iT) - > + D2(7,iT) - > + D2(8,iT) - > + D2(9,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else - tmp1=0.0D0 - tmp2=0.0D0 - Do iT = 1, nT - Do iRys = 1, nRys - tmp1 = tmp1 + PAO(It)*D1(iRys,iT) - tmp2 = tmp2 + PAO(It)*D2(iRys,iT) - End Do - End Do - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return - End If - end diff -Nru openmolcas-22.02/src/rys_util/ass2b.F90 openmolcas-22.10/src/rys_util/ass2b.F90 --- openmolcas-22.02/src/rys_util/ass2b.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ass2b.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,96 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine ass2b(D1,D2,PAO,tmp1_,tmp2_,nt,nrys) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nt, nrys +real(kind=wp), intent(in) :: D1(nRys,nt), D2(nRys,nt), PAO(nt) +real(kind=wp), intent(inout) :: tmp1_, tmp2_ +integer(kind=iwp) :: iRys, iT +real(kind=wp) :: tmp1, tmp2 + +tmp1 = Zero +tmp2 = Zero + +select case (nRys) + + case (1) + do iT=1,nt + tmp1 = tmp1+PAO(iT)*D1(1,iT) + tmp2 = tmp2+PAO(iT)*D2(1,iT) + end do + + case (2) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT))*PAO(iT) + tmp2 = tmp2+(D2(1,iT)+D2(2,iT))*PAO(iT) + end do + + case (3) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT))*PAO(iT) + tmp2 = tmp2+(D2(1,iT)+D2(2,iT)+D2(3,iT))*PAO(iT) + end do + + case (4) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT)+D1(4,iT))*PAO(iT) + tmp2 = tmp2+(D2(1,iT)+D2(2,iT)+D2(3,iT)+D2(4,iT))*PAO(iT) + end do + + case (5) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT)+D1(4,iT)+D1(5,iT))*PAO(iT) + tmp2 = tmp2+(D2(1,iT)+D2(2,iT)+D2(3,iT)+D2(4,iT)+D2(5,iT))*PAO(iT) + end do + + case (6) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT)+D1(4,iT)+D1(5,iT)+D1(6,iT))*PAO(iT) + tmp2 = tmp2+(D2(1,iT)+D2(2,iT)+D2(3,iT)+D2(4,iT)+D2(5,iT)+D2(6,iT))*PAO(iT) + end do + + case (7) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT)+D1(4,iT)+D1(5,iT)+D1(6,iT)+D1(7,iT))*PAO(iT) + tmp2 = tmp2+(D2(1,iT)+D2(2,iT)+D2(3,iT)+D2(4,iT)+D2(5,iT)+D2(6,iT)+D2(7,iT))*PAO(iT) + end do + + case (8) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT)+D1(4,iT)+D1(5,iT)+D1(6,iT)+D1(7,iT)+D1(8,iT))*PAO(iT) + tmp2 = tmp2+(D2(1,iT)+D2(2,iT)+D2(3,iT)+D2(4,iT)+D2(5,iT)+D2(6,iT)+D2(7,iT)+D2(8,iT))*PAO(iT) + end do + + case (9) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT)+D1(4,iT)+D1(5,iT)+D1(6,iT)+D1(7,iT)+D1(8,iT)+D1(9,iT))*PAO(iT) + tmp2 = tmp2+(D2(1,iT)+D2(2,iT)+D2(3,iT)+D2(4,iT)+D2(5,iT)+D2(6,iT)+D2(7,iT)+D2(8,iT)+D2(9,iT))*PAO(iT) + end do + + case default + do iT=1,nt + do iRys=1,nRys + tmp1 = tmp1+PAO(iT)*D1(iRys,iT) + tmp2 = tmp2+PAO(iT)*D2(iRys,iT) + end do + end do + +end select + +tmp1_ = tmp1_+tmp1 +tmp2_ = tmp2_+tmp2 + +end subroutine ass2b diff -Nru openmolcas-22.02/src/rys_util/ass2.f openmolcas-22.10/src/rys_util/ass2.f --- openmolcas-22.02/src/rys_util/ass2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ass2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,200 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - subroutine ass2(D01,D02,D1,D2,PAO,tmp1_,tmp2_,nt,nrys) - implicit real*8 (a-h,o-z) - dimension D01(nRys,nt),D02(nRys,nt) - dimension D1(nRys,nt),d2(nRys,nt),PAO(nt) -c - If (nRys.eq.1) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT)*D02(1,iT)*PAO(iT)) * D1(1,iT) - tmp2 = tmp2 + (D01(1,iT)*D02(1,iT)*PAO(iT)) * D2(1,iT) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return - - Else If (nRys.eq.2) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT)) * PAO(It) - tmp2 = tmp2 + ((D01(1,iT)*D02(1,iT)) * D2(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D2(2,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else If (nRys.eq.3) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT)) * PAO(It) - tmp2 = tmp2 + ((D01(1,iT)*D02(1,iT)) * D2(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D2(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D2(3,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else If (nRys.eq.4) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D1(4,iT)) * PAO(It) - tmp2 = tmp2 + ((D01(1,iT)*D02(1,iT)) * D2(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D2(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D2(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D2(4,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return - - Else If (nRys.eq.5) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D1(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D1(5,iT)) * PAO(It) - tmp2 = tmp2 + ((D01(1,iT)*D02(1,iT)) * D2(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D2(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D2(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D2(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D2(5,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else If (nRys.eq.6) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D1(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D1(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D1(6,iT)) * PAO(It) - tmp2 = tmp2 + ((D01(1,iT)*D02(1,iT)) * D2(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D2(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D2(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D2(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D2(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D2(6,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else If (nRys.eq.7) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D1(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D1(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D1(6,iT) - > + (D01(7,iT)*D02(7,iT)) * D1(7,iT)) * PAO(It) - tmp2 = tmp2 + ((D01(1,iT)*D02(1,iT)) * D2(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D2(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D2(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D2(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D2(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D2(6,iT) - > + (D01(7,iT)*D02(7,iT)) * D2(7,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else If (nRys.eq.8) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D1(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D1(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D1(6,iT) - > + (D01(7,iT)*D02(7,iT)) * D1(7,iT) - > + (D01(8,iT)*D02(8,iT)) * D1(8,iT)) * PAO(It) - tmp2 = tmp2 + ((D01(1,iT)*D02(1,iT)) * D2(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D2(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D2(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D2(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D2(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D2(6,iT) - > + (D01(7,iT)*D02(7,iT)) * D2(7,iT) - > + (D01(8,iT)*D02(8,iT)) * D2(8,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else If (nRys.eq.9) Then - tmp1=0.0D0 - tmp2=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D1(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D1(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D1(6,iT) - > + (D01(7,iT)*D02(7,iT)) * D1(7,iT) - > + (D01(8,iT)*D02(8,iT)) * D1(8,iT) - > + (D01(9,iT)*D02(9,iT)) * D1(9,iT)) * PAO(It) - tmp2 = tmp2 + ((D01(1,iT)*D02(1,iT)) * D2(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D2(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D2(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D2(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D2(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D2(6,iT) - > + (D01(7,iT)*D02(7,iT)) * D2(7,iT) - > + (D01(8,iT)*D02(8,iT)) * D2(8,iT) - > + (D01(9,iT)*D02(9,iT)) * D2(9,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return -c - Else - tmp1=0.0D0 - tmp2=0.0D0 - Do iT = 1, nT - Do iRys = 1, nRys - tmp1 = tmp1 + (D01(iRys,iT)*D02(iRys,iT)*PAO(It))*D1(iRys,iT) - tmp2 = tmp2 + (D01(iRys,iT)*D02(iRys,iT)*PAO(It))*D2(iRys,iT) - End Do - End Do - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - return - End If - end diff -Nru openmolcas-22.02/src/rys_util/ass2.F90 openmolcas-22.10/src/rys_util/ass2.F90 --- openmolcas-22.02/src/rys_util/ass2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ass2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,114 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine ass2(D01,D02,D1,D2,PAO,tmp1_,tmp2_,nt,nrys) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nt, nrys +real(kind=wp), intent(in) :: D01(nRys,nt), D02(nRys,nt), D1(nRys,nt), D2(nRys,nt), PAO(nt) +real(kind=wp), intent(inout) :: tmp1_, tmp2_ +integer(kind=iwp) :: iRys, iT +real(kind=wp) :: tmp1, tmp2 + +tmp1 = Zero +tmp2 = Zero + +select case (nRys) + + case (1) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D02(1,iT)*PAO(iT))*D1(1,iT) + tmp2 = tmp2+(D01(1,iT)*D02(1,iT)*PAO(iT))*D2(1,iT) + end do + + case (2) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT))*PAO(iT) + tmp2 = tmp2+((D01(1,iT)*D02(1,iT))*D2(1,iT)+(D01(2,iT)*D02(2,iT))*D2(2,iT))*PAO(iT) + end do + + case (3) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT))*PAO(iT) + tmp2 = tmp2+((D01(1,iT)*D02(1,iT))*D2(1,iT)+(D01(2,iT)*D02(2,iT))*D2(2,iT)+(D01(3,iT)*D02(3,iT))*D2(3,iT))*PAO(iT) + end do + + case (4) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D1(4,iT))*PAO(iT) + tmp2 = tmp2+((D01(1,iT)*D02(1,iT))*D2(1,iT)+(D01(2,iT)*D02(2,iT))*D2(2,iT)+(D01(3,iT)*D02(3,iT))*D2(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D2(4,iT))*PAO(iT) + end do + + case (5) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D1(4,iT)+(D01(5,iT)*D02(5,iT))*D1(5,iT))*PAO(iT) + tmp2 = tmp2+((D01(1,iT)*D02(1,iT))*D2(1,iT)+(D01(2,iT)*D02(2,iT))*D2(2,iT)+(D01(3,iT)*D02(3,iT))*D2(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D2(4,iT)+(D01(5,iT)*D02(5,iT))*D2(5,iT))*PAO(iT) + end do + + case (6) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D1(4,iT)+(D01(5,iT)*D02(5,iT))*D1(5,iT)+(D01(6,iT)*D02(6,iT))*D1(6,iT))*PAO(iT) + tmp2 = tmp2+((D01(1,iT)*D02(1,iT))*D2(1,iT)+(D01(2,iT)*D02(2,iT))*D2(2,iT)+(D01(3,iT)*D02(3,iT))*D2(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D2(4,iT)+(D01(5,iT)*D02(5,iT))*D2(5,iT)+(D01(6,iT)*D02(6,iT))*D2(6,iT))*PAO(iT) + end do + + case (7) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D1(4,iT)+(D01(5,iT)*D02(5,iT))*D1(5,iT)+(D01(6,iT)*D02(6,iT))*D1(6,iT)+ & + (D01(7,iT)*D02(7,iT))*D1(7,iT))*PAO(iT) + tmp2 = tmp2+((D01(1,iT)*D02(1,iT))*D2(1,iT)+(D01(2,iT)*D02(2,iT))*D2(2,iT)+(D01(3,iT)*D02(3,iT))*D2(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D2(4,iT)+(D01(5,iT)*D02(5,iT))*D2(5,iT)+(D01(6,iT)*D02(6,iT))*D2(6,iT)+ & + (D01(7,iT)*D02(7,iT))*D2(7,iT))*PAO(iT) + end do + + case (8) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D1(4,iT)+(D01(5,iT)*D02(5,iT))*D1(5,iT)+(D01(6,iT)*D02(6,iT))*D1(6,iT)+ & + (D01(7,iT)*D02(7,iT))*D1(7,iT)+(D01(8,iT)*D02(8,iT))*D1(8,iT))*PAO(iT) + tmp2 = tmp2+((D01(1,iT)*D02(1,iT))*D2(1,iT)+(D01(2,iT)*D02(2,iT))*D2(2,iT)+(D01(3,iT)*D02(3,iT))*D2(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D2(4,iT)+(D01(5,iT)*D02(5,iT))*D2(5,iT)+(D01(6,iT)*D02(6,iT))*D2(6,iT)+ & + (D01(7,iT)*D02(7,iT))*D2(7,iT)+(D01(8,iT)*D02(8,iT))*D2(8,iT))*PAO(iT) + end do + + case (9) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D1(4,iT)+(D01(5,iT)*D02(5,iT))*D1(5,iT)+(D01(6,iT)*D02(6,iT))*D1(6,iT)+ & + (D01(7,iT)*D02(7,iT))*D1(7,iT)+(D01(8,iT)*D02(8,iT))*D1(8,iT)+(D01(9,iT)*D02(9,iT))*D1(9,iT))*PAO(iT) + tmp2 = tmp2+((D01(1,iT)*D02(1,iT))*D2(1,iT)+(D01(2,iT)*D02(2,iT))*D2(2,iT)+(D01(3,iT)*D02(3,iT))*D2(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D2(4,iT)+(D01(5,iT)*D02(5,iT))*D2(5,iT)+(D01(6,iT)*D02(6,iT))*D2(6,iT)+ & + (D01(7,iT)*D02(7,iT))*D2(7,iT)+(D01(8,iT)*D02(8,iT))*D2(8,iT)+(D01(9,iT)*D02(9,iT))*D2(9,iT))*PAO(iT) + end do + + case default + do iT=1,nt + do iRys=1,nRys + tmp1 = tmp1+(D01(iRys,iT)*D02(iRys,iT)*PAO(iT))*D1(iRys,iT) + tmp2 = tmp2+(D01(iRys,iT)*D02(iRys,iT)*PAO(iT))*D2(iRys,iT) + end do + end do + +end select + +tmp1_ = tmp1_+tmp1 +tmp2_ = tmp2_+tmp2 + +end subroutine ass2 diff -Nru openmolcas-22.02/src/rys_util/ass3a.f openmolcas-22.10/src/rys_util/ass3a.f --- openmolcas-22.02/src/rys_util/ass3a.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ass3a.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,266 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - subroutine ass3a(D01,D1,D2,D3,PAO,tmp1_,tmp2_,tmp3_,nt,nrys) - implicit real*8 (a-h,o-z) - dimension D01(nrys,nt) - dimension D1(nrys,nt),d2(nrys,nt),D3(nrys,nt),PAO(nt) -c - If (nRys.eq.1) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT)*PAO(iT)) * D1(1,iT) - tmp2 = tmp2 + (D01(1,iT)*PAO(iT)) * D2(1,iT) - tmp3 = tmp3 + (D01(1,iT)*PAO(iT)) * D3(1,iT) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return - - Else If (nRys.eq.2) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT)) * PAO(It) - tmp2 = tmp2 + (D01(1,iT) * D2(1,iT) - > + D01(2,iT) * D2(2,iT)) * PAO(It) - tmp3 = tmp3 + (D01(1,iT) * D3(1,iT) - > + D01(2,iT) * D3(2,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else If (nRys.eq.3) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT)) * PAO(It) - tmp2 = tmp2 + (D01(1,iT) * D2(1,iT) - > + D01(2,iT) * D2(2,iT) - > + D01(3,iT) * D2(3,iT)) * PAO(It) - tmp3 = tmp3 + (D01(1,iT) * D3(1,iT) - > + D01(2,iT) * D3(2,iT) - > + D01(3,iT) * D3(3,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else If (nRys.eq.4) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT) - > + D01(4,iT) * D1(4,iT)) * PAO(It) - tmp2 = tmp2 + (D01(1,iT) * D2(1,iT) - > + D01(2,iT) * D2(2,iT) - > + D01(3,iT) * D2(3,iT) - > + D01(4,iT) * D2(4,iT)) * PAO(It) - tmp3 = tmp3 + (D01(1,iT) * D3(1,iT) - > + D01(2,iT) * D3(2,iT) - > + D01(3,iT) * D3(3,iT) - > + D01(4,iT) * D3(4,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return - - Else If (nRys.eq.5) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT) - > + D01(4,iT) * D1(4,iT) - > + D01(5,iT) * D1(5,iT)) * PAO(It) - tmp2 = tmp2 + (D01(1,iT) * D2(1,iT) - > + D01(2,iT) * D2(2,iT) - > + D01(3,iT) * D2(3,iT) - > + D01(4,iT) * D2(4,iT) - > + D01(5,iT) * D2(5,iT)) * PAO(It) - tmp3 = tmp3 + (D01(1,iT) * D3(1,iT) - > + D01(2,iT) * D3(2,iT) - > + D01(3,iT) * D3(3,iT) - > + D01(4,iT) * D3(4,iT) - > + D01(5,iT) * D3(5,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else If (nRys.eq.6) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT) - > + D01(4,iT) * D1(4,iT) - > + D01(5,iT) * D1(5,iT) - > + D01(6,iT) * D1(6,iT)) * PAO(It) - tmp2 = tmp2 + (D01(1,iT) * D2(1,iT) - > + D01(2,iT) * D2(2,iT) - > + D01(3,iT) * D2(3,iT) - > + D01(4,iT) * D2(4,iT) - > + D01(5,iT) * D2(5,iT) - > + D01(6,iT) * D2(6,iT)) * PAO(It) - tmp3 = tmp3 + (D01(1,iT) * D3(1,iT) - > + D01(2,iT) * D3(2,iT) - > + D01(3,iT) * D3(3,iT) - > + D01(4,iT) * D3(4,iT) - > + D01(5,iT) * D3(5,iT) - > + D01(6,iT) * D3(6,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else If (nRys.eq.7) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT) - > + D01(4,iT) * D1(4,iT) - > + D01(5,iT) * D1(5,iT) - > + D01(6,iT) * D1(6,iT) - > + D01(7,iT) * D1(7,iT)) * PAO(It) - tmp2 = tmp2 + (D01(1,iT) * D2(1,iT) - > + D01(2,iT) * D2(2,iT) - > + D01(3,iT) * D2(3,iT) - > + D01(4,iT) * D2(4,iT) - > + D01(5,iT) * D2(5,iT) - > + D01(6,iT) * D2(6,iT) - > + D01(7,iT) * D2(7,iT)) * PAO(It) - tmp3 = tmp3 + (D01(1,iT) * D3(1,iT) - > + D01(2,iT) * D3(2,iT) - > + D01(3,iT) * D3(3,iT) - > + D01(4,iT) * D3(4,iT) - > + D01(5,iT) * D3(5,iT) - > + D01(6,iT) * D3(6,iT) - > + D01(7,iT) * D3(7,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else If (nRys.eq.8) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT) - > + D01(4,iT) * D1(4,iT) - > + D01(5,iT) * D1(5,iT) - > + D01(6,iT) * D1(6,iT) - > + D01(7,iT) * D1(7,iT) - > + D01(8,iT) * D1(8,iT)) * PAO(It) - tmp2 = tmp2 + (D01(1,iT) * D2(1,iT) - > + D01(2,iT) * D2(2,iT) - > + D01(3,iT) * D2(3,iT) - > + D01(4,iT) * D2(4,iT) - > + D01(5,iT) * D2(5,iT) - > + D01(6,iT) * D2(6,iT) - > + D01(7,iT) * D2(7,iT) - > + D01(8,iT) * D2(8,iT)) * PAO(It) - tmp3 = tmp3 + (D01(1,iT) * D3(1,iT) - > + D01(2,iT) * D3(2,iT) - > + D01(3,iT) * D3(3,iT) - > + D01(4,iT) * D3(4,iT) - > + D01(5,iT) * D3(5,iT) - > + D01(6,iT) * D3(6,iT) - > + D01(7,iT) * D3(7,iT) - > + D01(8,iT) * D3(8,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else If (nRys.eq.9) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT) * D1(1,iT) - > + D01(2,iT) * D1(2,iT) - > + D01(3,iT) * D1(3,iT) - > + D01(4,iT) * D1(4,iT) - > + D01(5,iT) * D1(5,iT) - > + D01(6,iT) * D1(6,iT) - > + D01(7,iT) * D1(7,iT) - > + D01(8,iT) * D1(8,iT) - > + D01(9,iT) * D1(9,iT)) * PAO(It) - tmp2 = tmp2 + (D01(1,iT) * D2(1,iT) - > + D01(2,iT) * D2(2,iT) - > + D01(3,iT) * D2(3,iT) - > + D01(4,iT) * D2(4,iT) - > + D01(5,iT) * D2(5,iT) - > + D01(6,iT) * D2(6,iT) - > + D01(7,iT) * D2(7,iT) - > + D01(8,iT) * D2(8,iT) - > + D01(9,iT) * D2(9,iT)) * PAO(It) - tmp3 = tmp3 + (D01(1,iT) * D3(1,iT) - > + D01(2,iT) * D3(2,iT) - > + D01(3,iT) * D3(3,iT) - > + D01(4,iT) * D3(4,iT) - > + D01(5,iT) * D3(5,iT) - > + D01(6,iT) * D3(6,iT) - > + D01(7,iT) * D3(7,iT) - > + D01(8,iT) * D3(8,iT) - > + D01(9,iT) * D3(9,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - Do iT = 1, nT - Do iRys = 1, nRys - tmp1 = tmp1 + (D01(iRys,iT)*PAO(It))*D1(iRys,iT) - tmp2 = tmp2 + (D01(iRys,iT)*PAO(It))*D2(iRys,iT) - tmp3 = tmp3 + (D01(iRys,iT)*PAO(It))*D3(iRys,iT) - End Do - End Do - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return - End If - end diff -Nru openmolcas-22.02/src/rys_util/ass3a.F90 openmolcas-22.10/src/rys_util/ass3a.F90 --- openmolcas-22.02/src/rys_util/ass3a.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ass3a.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,120 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine ass3a(D01,D1,D2,D3,PAO,tmp1_,tmp2_,tmp3_,nt,nrys) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nt, nrys +real(kind=wp), intent(in) :: D01(nrys,nt), D1(nrys,nt), D2(nrys,nt), D3(nrys,nt), PAO(nt) +real(kind=wp), intent(inout) :: tmp1_, tmp2_, tmp3_ +integer(kind=iwp) :: iRys, iT +real(kind=wp) :: tmp1, tmp2, tmp3 + +tmp1 = Zero +tmp2 = Zero +tmp3 = Zero + +select case (nRys) + + case (1) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*PAO(iT))*D1(1,iT) + tmp2 = tmp2+(D01(1,iT)*PAO(iT))*D2(1,iT) + tmp3 = tmp3+(D01(1,iT)*PAO(iT))*D3(1,iT) + end do + + case (2) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT))*PAO(iT) + tmp2 = tmp2+(D01(1,iT)*D2(1,iT)+D01(2,iT)*D2(2,iT))*PAO(iT) + tmp3 = tmp3+(D01(1,iT)*D3(1,iT)+D01(2,iT)*D3(2,iT))*PAO(iT) + end do + + case (3) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT))*PAO(iT) + tmp2 = tmp2+(D01(1,iT)*D2(1,iT)+D01(2,iT)*D2(2,iT)+D01(3,iT)*D2(3,iT))*PAO(iT) + tmp3 = tmp3+(D01(1,iT)*D3(1,iT)+D01(2,iT)*D3(2,iT)+D01(3,iT)*D3(3,iT))*PAO(iT) + end do + + case (4) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT)+D01(4,iT)*D1(4,iT))*PAO(iT) + tmp2 = tmp2+(D01(1,iT)*D2(1,iT)+D01(2,iT)*D2(2,iT)+D01(3,iT)*D2(3,iT)+D01(4,iT)*D2(4,iT))*PAO(iT) + tmp3 = tmp3+(D01(1,iT)*D3(1,iT)+D01(2,iT)*D3(2,iT)+D01(3,iT)*D3(3,iT)+D01(4,iT)*D3(4,iT))*PAO(iT) + end do + + case (5) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT)+D01(4,iT)*D1(4,iT)+D01(5,iT)*D1(5,iT))*PAO(iT) + tmp2 = tmp2+(D01(1,iT)*D2(1,iT)+D01(2,iT)*D2(2,iT)+D01(3,iT)*D2(3,iT)+D01(4,iT)*D2(4,iT)+D01(5,iT)*D2(5,iT))*PAO(iT) + tmp3 = tmp3+(D01(1,iT)*D3(1,iT)+D01(2,iT)*D3(2,iT)+D01(3,iT)*D3(3,iT)+D01(4,iT)*D3(4,iT)+D01(5,iT)*D3(5,iT))*PAO(iT) + end do + + case (6) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT)+D01(4,iT)*D1(4,iT)+D01(5,iT)*D1(5,iT)+ & + D01(6,iT)*D1(6,iT))*PAO(iT) + tmp2 = tmp2+(D01(1,iT)*D2(1,iT)+D01(2,iT)*D2(2,iT)+D01(3,iT)*D2(3,iT)+D01(4,iT)*D2(4,iT)+D01(5,iT)*D2(5,iT)+ & + D01(6,iT)*D2(6,iT))*PAO(iT) + tmp3 = tmp3+(D01(1,iT)*D3(1,iT)+D01(2,iT)*D3(2,iT)+D01(3,iT)*D3(3,iT)+D01(4,iT)*D3(4,iT)+D01(5,iT)*D3(5,iT)+ & + D01(6,iT)*D3(6,iT))*PAO(iT) + end do + + case (7) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT)+D01(4,iT)*D1(4,iT)+D01(5,iT)*D1(5,iT)+ & + D01(6,iT)*D1(6,iT)+D01(7,iT)*D1(7,iT))*PAO(iT) + tmp2 = tmp2+(D01(1,iT)*D2(1,iT)+D01(2,iT)*D2(2,iT)+D01(3,iT)*D2(3,iT)+D01(4,iT)*D2(4,iT)+D01(5,iT)*D2(5,iT)+ & + D01(6,iT)*D2(6,iT)+D01(7,iT)*D2(7,iT))*PAO(iT) + tmp3 = tmp3+(D01(1,iT)*D3(1,iT)+D01(2,iT)*D3(2,iT)+D01(3,iT)*D3(3,iT)+D01(4,iT)*D3(4,iT)+D01(5,iT)*D3(5,iT)+ & + D01(6,iT)*D3(6,iT)+D01(7,iT)*D3(7,iT))*PAO(iT) + end do + + case (8) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT)+D01(4,iT)*D1(4,iT)+D01(5,iT)*D1(5,iT)+ & + D01(6,iT)*D1(6,iT)+D01(7,iT)*D1(7,iT)+D01(8,iT)*D1(8,iT))*PAO(iT) + tmp2 = tmp2+(D01(1,iT)*D2(1,iT)+D01(2,iT)*D2(2,iT)+D01(3,iT)*D2(3,iT)+D01(4,iT)*D2(4,iT)+D01(5,iT)*D2(5,iT)+ & + D01(6,iT)*D2(6,iT)+D01(7,iT)*D2(7,iT)+D01(8,iT)*D2(8,iT))*PAO(iT) + tmp3 = tmp3+(D01(1,iT)*D3(1,iT)+D01(2,iT)*D3(2,iT)+D01(3,iT)*D3(3,iT)+D01(4,iT)*D3(4,iT)+D01(5,iT)*D3(5,iT)+ & + D01(6,iT)*D3(6,iT)+D01(7,iT)*D3(7,iT)+D01(8,iT)*D3(8,iT))*PAO(iT) + end do + + case (9) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D1(1,iT)+D01(2,iT)*D1(2,iT)+D01(3,iT)*D1(3,iT)+D01(4,iT)*D1(4,iT)+D01(5,iT)*D1(5,iT)+ & + D01(6,iT)*D1(6,iT)+D01(7,iT)*D1(7,iT)+D01(8,iT)*D1(8,iT)+D01(9,iT)*D1(9,iT))*PAO(iT) + tmp2 = tmp2+(D01(1,iT)*D2(1,iT)+D01(2,iT)*D2(2,iT)+D01(3,iT)*D2(3,iT)+D01(4,iT)*D2(4,iT)+D01(5,iT)*D2(5,iT)+ & + D01(6,iT)*D2(6,iT)+D01(7,iT)*D2(7,iT)+D01(8,iT)*D2(8,iT)+D01(9,iT)*D2(9,iT))*PAO(iT) + tmp3 = tmp3+(D01(1,iT)*D3(1,iT)+D01(2,iT)*D3(2,iT)+D01(3,iT)*D3(3,iT)+D01(4,iT)*D3(4,iT)+D01(5,iT)*D3(5,iT)+ & + D01(6,iT)*D3(6,iT)+D01(7,iT)*D3(7,iT)+D01(8,iT)*D3(8,iT)+D01(9,iT)*D3(9,iT))*PAO(iT) + end do + + case default + do iT=1,nt + do iRys=1,nRys + tmp1 = tmp1+(D01(iRys,iT)*PAO(iT))*D1(iRys,iT) + tmp2 = tmp2+(D01(iRys,iT)*PAO(iT))*D2(iRys,iT) + tmp3 = tmp3+(D01(iRys,iT)*PAO(iT))*D3(iRys,iT) + end do + end do + +end select + +tmp1_ = tmp1_+tmp1 +tmp2_ = tmp2_+tmp2 +tmp3_ = tmp3_+tmp3 + +end subroutine ass3a diff -Nru openmolcas-22.02/src/rys_util/ass3b.f openmolcas-22.10/src/rys_util/ass3b.f --- openmolcas-22.02/src/rys_util/ass3b.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ass3b.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,265 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - subroutine ass3b(D1,D2,D3,PAO,tmp1_,tmp2_,tmp3_,nt,nrys) - implicit real*8 (a-h,o-z) - dimension D1(nrys,nt),d2(nrys,nt),D3(nrys,nt),PAO(nt) -c - If (nRys.eq.1) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + PAO(iT) * D1(1,iT) - tmp2 = tmp2 + PAO(iT) * D2(1,iT) - tmp3 = tmp3 + PAO(iT) * D3(1,iT) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return - - Else If (nRys.eq.2) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT)) * PAO(It) - tmp2 = tmp2 + (D2(1,iT) - > + D2(2,iT)) * PAO(It) - tmp3 = tmp3 + (D3(1,iT) - > + D3(2,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else If (nRys.eq.3) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT)) * PAO(It) - tmp2 = tmp2 + (D2(1,iT) - > + D2(2,iT) - > + D2(3,iT)) * PAO(It) - tmp3 = tmp3 + (D3(1,iT) - > + D3(2,iT) - > + D3(3,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else If (nRys.eq.4) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT) - > + D1(4,iT)) * PAO(It) - tmp2 = tmp2 + (D2(1,iT) - > + D2(2,iT) - > + D2(3,iT) - > + D2(4,iT)) * PAO(It) - tmp3 = tmp3 + (D3(1,iT) - > + D3(2,iT) - > + D3(3,iT) - > + D3(4,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return - - Else If (nRys.eq.5) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT) - > + D1(4,iT) - > + D1(5,iT)) * PAO(It) - tmp2 = tmp2 + (D2(1,iT) - > + D2(2,iT) - > + D2(3,iT) - > + D2(4,iT) - > + D2(5,iT)) * PAO(It) - tmp3 = tmp3 + (D3(1,iT) - > + D3(2,iT) - > + D3(3,iT) - > + D3(4,iT) - > + D3(5,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else If (nRys.eq.6) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT) - > + D1(4,iT) - > + D1(5,iT) - > + D1(6,iT)) * PAO(It) - tmp2 = tmp2 + (D2(1,iT) - > + D2(2,iT) - > + D2(3,iT) - > + D2(4,iT) - > + D2(5,iT) - > + D2(6,iT)) * PAO(It) - tmp3 = tmp3 + (D3(1,iT) - > + D3(2,iT) - > + D3(3,iT) - > + D3(4,iT) - > + D3(5,iT) - > + D3(6,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else If (nRys.eq.7) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT) - > + D1(4,iT) - > + D1(5,iT) - > + D1(6,iT) - > + D1(7,iT)) * PAO(It) - tmp2 = tmp2 + (D2(1,iT) - > + D2(2,iT) - > + D2(3,iT) - > + D2(4,iT) - > + D2(5,iT) - > + D2(6,iT) - > + D2(7,iT)) * PAO(It) - tmp3 = tmp3 + (D3(1,iT) - > + D3(2,iT) - > + D3(3,iT) - > + D3(4,iT) - > + D3(5,iT) - > + D3(6,iT) - > + D3(7,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else If (nRys.eq.8) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT) - > + D1(4,iT) - > + D1(5,iT) - > + D1(6,iT) - > + D1(7,iT) - > + D1(8,iT)) * PAO(It) - tmp2 = tmp2 + (D2(1,iT) - > + D2(2,iT) - > + D2(3,iT) - > + D2(4,iT) - > + D2(5,iT) - > + D2(6,iT) - > + D2(7,iT) - > + D2(8,iT)) * PAO(It) - tmp3 = tmp3 + (D3(1,iT) - > + D3(2,iT) - > + D3(3,iT) - > + D3(4,iT) - > + D3(5,iT) - > + D3(6,iT) - > + D3(7,iT) - > + D3(8,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else If (nRys.eq.9) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D1(1,iT) - > + D1(2,iT) - > + D1(3,iT) - > + D1(4,iT) - > + D1(5,iT) - > + D1(6,iT) - > + D1(7,iT) - > + D1(8,iT) - > + D1(9,iT)) * PAO(It) - tmp2 = tmp2 + (D2(1,iT) - > + D2(2,iT) - > + D2(3,iT) - > + D2(4,iT) - > + D2(5,iT) - > + D2(6,iT) - > + D2(7,iT) - > + D2(8,iT) - > + D2(9,iT)) * PAO(It) - tmp3 = tmp3 + (D3(1,iT) - > + D3(2,iT) - > + D3(3,iT) - > + D3(4,iT) - > + D3(5,iT) - > + D3(6,iT) - > + D3(7,iT) - > + D3(8,iT) - > + D3(9,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - Do iT = 1, nT - Do iRys = 1, nRys - tmp1 = tmp1 + PAO(It)*D1(iRys,iT) - tmp2 = tmp2 + PAO(It)*D2(iRys,iT) - tmp3 = tmp3 + PAO(It)*D3(iRys,iT) - End Do - End Do - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return - End If - end diff -Nru openmolcas-22.02/src/rys_util/ass3b.F90 openmolcas-22.10/src/rys_util/ass3b.F90 --- openmolcas-22.02/src/rys_util/ass3b.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ass3b.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,108 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine ass3b(D1,D2,D3,PAO,tmp1_,tmp2_,tmp3_,nt,nrys) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nt, nrys +real(kind=wp), intent(in) :: D1(nrys,nt), D2(nrys,nt), D3(nrys,nt), PAO(nt) +real(kind=wp), intent(inout) :: tmp1_, tmp2_, tmp3_ +integer(kind=iwp) :: iRys, iT +real(kind=wp) :: tmp1, tmp2, tmp3 + +tmp1 = Zero +tmp2 = Zero +tmp3 = Zero + +select case (nRys) + + case (1) + do iT=1,nt + tmp1 = tmp1+PAO(iT)*D1(1,iT) + tmp2 = tmp2+PAO(iT)*D2(1,iT) + tmp3 = tmp3+PAO(iT)*D3(1,iT) + end do + + case (2) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT))*PAO(iT) + tmp2 = tmp2+(D2(1,iT)+D2(2,iT))*PAO(iT) + tmp3 = tmp3+(D3(1,iT)+D3(2,iT))*PAO(iT) + end do + + case (3) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT))*PAO(iT) + tmp2 = tmp2+(D2(1,iT)+D2(2,iT)+D2(3,iT))*PAO(iT) + tmp3 = tmp3+(D3(1,iT)+D3(2,iT)+D3(3,iT))*PAO(iT) + end do + + case (4) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT)+D1(4,iT))*PAO(iT) + tmp2 = tmp2+(D2(1,iT)+D2(2,iT)+D2(3,iT)+D2(4,iT))*PAO(iT) + tmp3 = tmp3+(D3(1,iT)+D3(2,iT)+D3(3,iT)+D3(4,iT))*PAO(iT) + end do + + case (5) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT)+D1(4,iT)+D1(5,iT))*PAO(iT) + tmp2 = tmp2+(D2(1,iT)+D2(2,iT)+D2(3,iT)+D2(4,iT)+D2(5,iT))*PAO(iT) + tmp3 = tmp3+(D3(1,iT)+D3(2,iT)+D3(3,iT)+D3(4,iT)+D3(5,iT))*PAO(iT) + end do + + case (6) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT)+D1(4,iT)+D1(5,iT)+D1(6,iT))*PAO(iT) + tmp2 = tmp2+(D2(1,iT)+D2(2,iT)+D2(3,iT)+D2(4,iT)+D2(5,iT)+D2(6,iT))*PAO(iT) + tmp3 = tmp3+(D3(1,iT)+D3(2,iT)+D3(3,iT)+D3(4,iT)+D3(5,iT)+D3(6,iT))*PAO(iT) + end do + + case (7) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT)+D1(4,iT)+D1(5,iT)+D1(6,iT)+D1(7,iT))*PAO(iT) + tmp2 = tmp2+(D2(1,iT)+D2(2,iT)+D2(3,iT)+D2(4,iT)+D2(5,iT)+D2(6,iT)+D2(7,iT))*PAO(iT) + tmp3 = tmp3+(D3(1,iT)+D3(2,iT)+D3(3,iT)+D3(4,iT)+D3(5,iT)+D3(6,iT)+D3(7,iT))*PAO(iT) + end do + + case (8) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT)+D1(4,iT)+D1(5,iT)+D1(6,iT)+D1(7,iT)+D1(8,iT))*PAO(iT) + tmp2 = tmp2+(D2(1,iT)+D2(2,iT)+D2(3,iT)+D2(4,iT)+D2(5,iT)+D2(6,iT)+D2(7,iT)+D2(8,iT))*PAO(iT) + tmp3 = tmp3+(D3(1,iT)+D3(2,iT)+D3(3,iT)+D3(4,iT)+D3(5,iT)+D3(6,iT)+D3(7,iT)+D3(8,iT))*PAO(iT) + end do + + case (9) + do iT=1,nt + tmp1 = tmp1+(D1(1,iT)+D1(2,iT)+D1(3,iT)+D1(4,iT)+D1(5,iT)+D1(6,iT)+D1(7,iT)+D1(8,iT)+D1(9,iT))*PAO(iT) + tmp2 = tmp2+(D2(1,iT)+D2(2,iT)+D2(3,iT)+D2(4,iT)+D2(5,iT)+D2(6,iT)+D2(7,iT)+D2(8,iT)+D2(9,iT))*PAO(iT) + tmp3 = tmp3+(D3(1,iT)+D3(2,iT)+D3(3,iT)+D3(4,iT)+D3(5,iT)+D3(6,iT)+D3(7,iT)+D3(8,iT)+D3(9,iT))*PAO(iT) + end do + + case default + do iT=1,nt + do iRys=1,nRys + tmp1 = tmp1+PAO(iT)*D1(iRys,iT) + tmp2 = tmp2+PAO(iT)*D2(iRys,iT) + tmp3 = tmp3+PAO(iT)*D3(iRys,iT) + end do + end do + +end select + +tmp1_ = tmp1_+tmp1 +tmp2_ = tmp2_+tmp2 +tmp3_ = tmp3_+tmp3 + +end subroutine ass3b diff -Nru openmolcas-22.02/src/rys_util/ass3.f openmolcas-22.10/src/rys_util/ass3.f --- openmolcas-22.02/src/rys_util/ass3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ass3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,266 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - subroutine ass3(D01,D02,D1,D2,D3,PAO,tmp1_,tmp2_,tmp3_,nt,nrys) - implicit real*8 (a-h,o-z) - dimension D01(nrys,nt),D02(nrys,nt) - dimension D1(nrys,nt),d2(nrys,nt),D3(nrys,nt),PAO(nt) -c - If (nRys.eq.1) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + (D01(1,iT)*D02(1,iT)*PAO(iT)) * D1(1,iT) - tmp2 = tmp2 + (D01(1,iT)*D02(1,iT)*PAO(iT)) * D2(1,iT) - tmp3 = tmp3 + (D01(1,iT)*D02(1,iT)*PAO(iT)) * D3(1,iT) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return - - Else If (nRys.eq.2) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT)) * PAO(It) - tmp2 = tmp2 + ((D01(1,iT)*D02(1,iT)) * D2(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D2(2,iT)) * PAO(It) - tmp3 = tmp3 + ((D01(1,iT)*D02(1,iT)) * D3(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D3(2,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else If (nRys.eq.3) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT)) * PAO(It) - tmp2 = tmp2 + ((D01(1,iT)*D02(1,iT)) * D2(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D2(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D2(3,iT)) * PAO(It) - tmp3 = tmp3 + ((D01(1,iT)*D02(1,iT)) * D3(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D3(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D3(3,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else If (nRys.eq.4) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D1(4,iT)) * PAO(It) - tmp2 = tmp2 + ((D01(1,iT)*D02(1,iT)) * D2(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D2(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D2(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D2(4,iT)) * PAO(It) - tmp3 = tmp3 + ((D01(1,iT)*D02(1,iT)) * D3(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D3(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D3(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D3(4,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return - - Else If (nRys.eq.5) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D1(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D1(5,iT)) * PAO(It) - tmp2 = tmp2 + ((D01(1,iT)*D02(1,iT)) * D2(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D2(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D2(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D2(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D2(5,iT)) * PAO(It) - tmp3 = tmp3 + ((D01(1,iT)*D02(1,iT)) * D3(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D3(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D3(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D3(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D3(5,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else If (nRys.eq.6) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D1(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D1(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D1(6,iT)) * PAO(It) - tmp2 = tmp2 + ((D01(1,iT)*D02(1,iT)) * D2(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D2(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D2(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D2(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D2(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D2(6,iT)) * PAO(It) - tmp3 = tmp3 + ((D01(1,iT)*D02(1,iT)) * D3(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D3(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D3(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D3(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D3(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D3(6,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else If (nRys.eq.7) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D1(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D1(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D1(6,iT) - > + (D01(7,iT)*D02(7,iT)) * D1(7,iT)) * PAO(It) - tmp2 = tmp2 + ((D01(1,iT)*D02(1,iT)) * D2(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D2(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D2(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D2(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D2(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D2(6,iT) - > + (D01(7,iT)*D02(7,iT)) * D2(7,iT)) * PAO(It) - tmp3 = tmp3 + ((D01(1,iT)*D02(1,iT)) * D3(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D3(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D3(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D3(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D3(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D3(6,iT) - > + (D01(7,iT)*D02(7,iT)) * D3(7,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else If (nRys.eq.8) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D1(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D1(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D1(6,iT) - > + (D01(7,iT)*D02(7,iT)) * D1(7,iT) - > + (D01(8,iT)*D02(8,iT)) * D1(8,iT)) * PAO(It) - tmp2 = tmp2 + ((D01(1,iT)*D02(1,iT)) * D2(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D2(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D2(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D2(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D2(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D2(6,iT) - > + (D01(7,iT)*D02(7,iT)) * D2(7,iT) - > + (D01(8,iT)*D02(8,iT)) * D2(8,iT)) * PAO(It) - tmp3 = tmp3 + ((D01(1,iT)*D02(1,iT)) * D3(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D3(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D3(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D3(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D3(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D3(6,iT) - > + (D01(7,iT)*D02(7,iT)) * D3(7,iT) - > + (D01(8,iT)*D02(8,iT)) * D3(8,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else If (nRys.eq.9) Then - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - do it=1,nt - tmp1 = tmp1 + ((D01(1,iT)*D02(1,iT)) * D1(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D1(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D1(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D1(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D1(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D1(6,iT) - > + (D01(7,iT)*D02(7,iT)) * D1(7,iT) - > + (D01(8,iT)*D02(8,iT)) * D1(8,iT) - > + (D01(9,iT)*D02(9,iT)) * D1(9,iT)) * PAO(It) - tmp2 = tmp2 + ((D01(1,iT)*D02(1,iT)) * D2(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D2(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D2(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D2(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D2(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D2(6,iT) - > + (D01(7,iT)*D02(7,iT)) * D2(7,iT) - > + (D01(8,iT)*D02(8,iT)) * D2(8,iT) - > + (D01(9,iT)*D02(9,iT)) * D2(9,iT)) * PAO(It) - tmp3 = tmp3 + ((D01(1,iT)*D02(1,iT)) * D3(1,iT) - > + (D01(2,iT)*D02(2,iT)) * D3(2,iT) - > + (D01(3,iT)*D02(3,iT)) * D3(3,iT) - > + (D01(4,iT)*D02(4,iT)) * D3(4,iT) - > + (D01(5,iT)*D02(5,iT)) * D3(5,iT) - > + (D01(6,iT)*D02(6,iT)) * D3(6,iT) - > + (D01(7,iT)*D02(7,iT)) * D3(7,iT) - > + (D01(8,iT)*D02(8,iT)) * D3(8,iT) - > + (D01(9,iT)*D02(9,iT)) * D3(9,iT)) * PAO(It) - enddo - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return -c - Else - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - Do iT = 1, nT - Do iRys = 1, nRys - tmp1 = tmp1 + (D01(iRys,iT)*D02(iRys,iT)*PAO(It))*D1(iRys,iT) - tmp2 = tmp2 + (D01(iRys,iT)*D02(iRys,iT)*PAO(It))*D2(iRys,iT) - tmp3 = tmp3 + (D01(iRys,iT)*D02(iRys,iT)*PAO(It))*D3(iRys,iT) - End Do - End Do - tmp1_ = tmp1_ + tmp1 - tmp2_ = tmp2_ + tmp2 - tmp3_ = tmp3_ + tmp3 - return - End If - end diff -Nru openmolcas-22.02/src/rys_util/ass3.F90 openmolcas-22.10/src/rys_util/ass3.F90 --- openmolcas-22.02/src/rys_util/ass3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ass3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,135 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine ass3(D01,D02,D1,D2,D3,PAO,tmp1_,tmp2_,tmp3_,nt,nrys) + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nt, nrys +real(kind=wp), intent(in) :: D01(nrys,nt), D02(nrys,nt), D1(nrys,nt), D2(nrys,nt), D3(nrys,nt), PAO(nt) +real(kind=wp), intent(inout) :: tmp1_, tmp2_, tmp3_ +integer(kind=iwp) :: iRys, iT +real(kind=wp) :: tmp1, tmp2, tmp3 + +tmp1 = Zero +tmp2 = Zero +tmp3 = Zero + +select case (nRys) + + case (1) + do iT=1,nt + tmp1 = tmp1+(D01(1,iT)*D02(1,iT)*PAO(iT))*D1(1,iT) + tmp2 = tmp2+(D01(1,iT)*D02(1,iT)*PAO(iT))*D2(1,iT) + tmp3 = tmp3+(D01(1,iT)*D02(1,iT)*PAO(iT))*D3(1,iT) + end do + + case (2) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT))*PAO(iT) + tmp2 = tmp2+((D01(1,iT)*D02(1,iT))*D2(1,iT)+(D01(2,iT)*D02(2,iT))*D2(2,iT))*PAO(iT) + tmp3 = tmp3+((D01(1,iT)*D02(1,iT))*D3(1,iT)+(D01(2,iT)*D02(2,iT))*D3(2,iT))*PAO(iT) + end do + + case (3) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT))*PAO(iT) + tmp2 = tmp2+((D01(1,iT)*D02(1,iT))*D2(1,iT)+(D01(2,iT)*D02(2,iT))*D2(2,iT)+(D01(3,iT)*D02(3,iT))*D2(3,iT))*PAO(iT) + tmp3 = tmp3+((D01(1,iT)*D02(1,iT))*D3(1,iT)+(D01(2,iT)*D02(2,iT))*D3(2,iT)+(D01(3,iT)*D02(3,iT))*D3(3,iT))*PAO(iT) + end do + + case (4) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D1(4,iT))*PAO(iT) + tmp2 = tmp2+((D01(1,iT)*D02(1,iT))*D2(1,iT)+(D01(2,iT)*D02(2,iT))*D2(2,iT)+(D01(3,iT)*D02(3,iT))*D2(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D2(4,iT))*PAO(iT) + tmp3 = tmp3+((D01(1,iT)*D02(1,iT))*D3(1,iT)+(D01(2,iT)*D02(2,iT))*D3(2,iT)+(D01(3,iT)*D02(3,iT))*D3(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D3(4,iT))*PAO(iT) + end do + + case (5) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D1(4,iT)+(D01(5,iT)*D02(5,iT))*D1(5,iT))*PAO(iT) + tmp2 = tmp2+((D01(1,iT)*D02(1,iT))*D2(1,iT)+(D01(2,iT)*D02(2,iT))*D2(2,iT)+(D01(3,iT)*D02(3,iT))*D2(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D2(4,iT)+(D01(5,iT)*D02(5,iT))*D2(5,iT))*PAO(iT) + tmp3 = tmp3+((D01(1,iT)*D02(1,iT))*D3(1,iT)+(D01(2,iT)*D02(2,iT))*D3(2,iT)+(D01(3,iT)*D02(3,iT))*D3(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D3(4,iT)+(D01(5,iT)*D02(5,iT))*D3(5,iT))*PAO(iT) + end do + + case (6) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D1(4,iT)+(D01(5,iT)*D02(5,iT))*D1(5,iT)+(D01(6,iT)*D02(6,iT))*D1(6,iT))*PAO(iT) + tmp2 = tmp2+((D01(1,iT)*D02(1,iT))*D2(1,iT)+(D01(2,iT)*D02(2,iT))*D2(2,iT)+(D01(3,iT)*D02(3,iT))*D2(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D2(4,iT)+(D01(5,iT)*D02(5,iT))*D2(5,iT)+(D01(6,iT)*D02(6,iT))*D2(6,iT))*PAO(iT) + tmp3 = tmp3+((D01(1,iT)*D02(1,iT))*D3(1,iT)+(D01(2,iT)*D02(2,iT))*D3(2,iT)+(D01(3,iT)*D02(3,iT))*D3(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D3(4,iT)+(D01(5,iT)*D02(5,iT))*D3(5,iT)+(D01(6,iT)*D02(6,iT))*D3(6,iT))*PAO(iT) + end do + + case (7) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D1(4,iT)+(D01(5,iT)*D02(5,iT))*D1(5,iT)+(D01(6,iT)*D02(6,iT))*D1(6,iT)+ & + (D01(7,iT)*D02(7,iT))*D1(7,iT))*PAO(iT) + tmp2 = tmp2+((D01(1,iT)*D02(1,iT))*D2(1,iT)+(D01(2,iT)*D02(2,iT))*D2(2,iT)+(D01(3,iT)*D02(3,iT))*D2(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D2(4,iT)+(D01(5,iT)*D02(5,iT))*D2(5,iT)+(D01(6,iT)*D02(6,iT))*D2(6,iT)+ & + (D01(7,iT)*D02(7,iT))*D2(7,iT))*PAO(iT) + tmp3 = tmp3+((D01(1,iT)*D02(1,iT))*D3(1,iT)+(D01(2,iT)*D02(2,iT))*D3(2,iT)+(D01(3,iT)*D02(3,iT))*D3(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D3(4,iT)+(D01(5,iT)*D02(5,iT))*D3(5,iT)+(D01(6,iT)*D02(6,iT))*D3(6,iT)+ & + (D01(7,iT)*D02(7,iT))*D3(7,iT))*PAO(iT) + end do + + case (8) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D1(4,iT)+(D01(5,iT)*D02(5,iT))*D1(5,iT)+(D01(6,iT)*D02(6,iT))*D1(6,iT)+ & + (D01(7,iT)*D02(7,iT))*D1(7,iT)+(D01(8,iT)*D02(8,iT))*D1(8,iT))*PAO(iT) + tmp2 = tmp2+((D01(1,iT)*D02(1,iT))*D2(1,iT)+(D01(2,iT)*D02(2,iT))*D2(2,iT)+(D01(3,iT)*D02(3,iT))*D2(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D2(4,iT)+(D01(5,iT)*D02(5,iT))*D2(5,iT)+(D01(6,iT)*D02(6,iT))*D2(6,iT)+ & + (D01(7,iT)*D02(7,iT))*D2(7,iT)+(D01(8,iT)*D02(8,iT))*D2(8,iT))*PAO(iT) + tmp3 = tmp3+((D01(1,iT)*D02(1,iT))*D3(1,iT)+(D01(2,iT)*D02(2,iT))*D3(2,iT)+(D01(3,iT)*D02(3,iT))*D3(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D3(4,iT)+(D01(5,iT)*D02(5,iT))*D3(5,iT)+(D01(6,iT)*D02(6,iT))*D3(6,iT)+ & + (D01(7,iT)*D02(7,iT))*D3(7,iT)+(D01(8,iT)*D02(8,iT))*D3(8,iT))*PAO(iT) + end do + + case (9) + do iT=1,nt + tmp1 = tmp1+((D01(1,iT)*D02(1,iT))*D1(1,iT)+(D01(2,iT)*D02(2,iT))*D1(2,iT)+(D01(3,iT)*D02(3,iT))*D1(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D1(4,iT)+(D01(5,iT)*D02(5,iT))*D1(5,iT)+(D01(6,iT)*D02(6,iT))*D1(6,iT)+ & + (D01(7,iT)*D02(7,iT))*D1(7,iT)+(D01(8,iT)*D02(8,iT))*D1(8,iT)+(D01(9,iT)*D02(9,iT))*D1(9,iT))*PAO(iT) + tmp2 = tmp2+((D01(1,iT)*D02(1,iT))*D2(1,iT)+(D01(2,iT)*D02(2,iT))*D2(2,iT)+(D01(3,iT)*D02(3,iT))*D2(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D2(4,iT)+(D01(5,iT)*D02(5,iT))*D2(5,iT)+(D01(6,iT)*D02(6,iT))*D2(6,iT)+ & + (D01(7,iT)*D02(7,iT))*D2(7,iT)+(D01(8,iT)*D02(8,iT))*D2(8,iT)+(D01(9,iT)*D02(9,iT))*D2(9,iT))*PAO(iT) + tmp3 = tmp3+((D01(1,iT)*D02(1,iT))*D3(1,iT)+(D01(2,iT)*D02(2,iT))*D3(2,iT)+(D01(3,iT)*D02(3,iT))*D3(3,iT)+ & + (D01(4,iT)*D02(4,iT))*D3(4,iT)+(D01(5,iT)*D02(5,iT))*D3(5,iT)+(D01(6,iT)*D02(6,iT))*D3(6,iT)+ & + (D01(7,iT)*D02(7,iT))*D3(7,iT)+(D01(8,iT)*D02(8,iT))*D3(8,iT)+(D01(9,iT)*D02(9,iT))*D3(9,iT))*PAO(iT) + end do + + case default + do iT=1,nt + do iRys=1,nRys + tmp1 = tmp1+(D01(iRys,iT)*D02(iRys,iT)*PAO(iT))*D1(iRys,iT) + tmp2 = tmp2+(D01(iRys,iT)*D02(iRys,iT)*PAO(iT))*D2(iRys,iT) + tmp3 = tmp3+(D01(iRys,iT)*D02(iRys,iT)*PAO(iT))*D3(iRys,iT) + end do + end do + +end select + +tmp1_ = tmp1_+tmp1 +tmp2_ = tmp2_+tmp2 +tmp3_ = tmp3_+tmp3 + +end subroutine ass3 diff -Nru openmolcas-22.02/src/rys_util/assg1.f openmolcas-22.10/src/rys_util/assg1.f --- openmolcas-22.02/src/rys_util/assg1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/assg1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,294 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1991, Roland Lindh * -* 1996, Hans-Joachim Werner * -************************************************************************ - SubRoutine Assg1(Temp,PAO,nT,nRys,la,lb,lc,ld,xyz2D0,xyz2D1, - & IfGrad,Index,mVec) -************************************************************************ -* * -* Object: to assemble the gradients of the ERI's. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* October '91; modified by H.-J. Werner, Mai 1996 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" -#include "itmax.fh" -#include "iavec.fh" - Real*8 PAO(nT,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2, - & (lc+1)*(lc+2)/2,(ld+1)*(ld+2)/2), - & xyz2D0(nRys,nT,0:la+1,0:lb+1,0:lc+1,0:ld+1,3), - & xyz2D1(nRys,nT,0:la ,0:lb ,0:lc ,0:ld ,9), - & Temp(9) - Logical IfGrad(3,4) - Integer Ind1(3,3), Ind2(3,3), Index(3,4), nVec(3) -* -* Statement functions -* - nElem(i) = (i+1)*(i+2)/2 -* - call dcopy_(9,[Zero],0,Temp,1) -* - ii = la*(la+1)*(la+2)/6 - jj = lb*(lb+1)*(lb+2)/6 - kk = lc*(lc+1)*(lc+2)/6 - ll = ld*(ld+1)*(ld+2)/6 -* - mVec = 0 - Do i = 1, 3 ! Cartesian directions - nVec(i) = 0 - Do iCent = 1, 4 ! Centers of integral - If (IfGrad(i,iCent)) Then - mVec = mVec + 1 - nVec(i) = nVec(i) + 1 - Ind1(nVec(i),i) = 3*(Index(i,iCent)-1) + i - Ind2(nVec(i),i) = mVec - End If - End Do - End Do -* - Do 100 ipd = 1, nElem(ld) - ixd = ixyz(1,ll+ipd) - iyd = ixyz(2,ll+ipd) - izd = ixyz(3,ll+ipd) -* - Do 200 ipc = 1, nElem(lc) - ixc = ixyz(1,kk+ipc) - iyc = ixyz(2,kk+ipc) - izc = ixyz(3,kk+ipc) -* - ixcd = ixc + ixd - iycd = iyc + iyd -* - Do 300 ipb = 1, nElem(lb) - ixb = ixyz(1,jj+ipb) - iyb = ixyz(2,jj+ipb) - izb = ixyz(3,jj+ipb) -* - ixbcd = ixcd + ixb - iybcd = iycd + iyb -* - Do 400 ipa = 1, nElem(la) - ixa = ixyz(1,ii+ipa) - iya = ixyz(2,ii+ipa) - iza = ixyz(3,ii+ipa) -* - ixabcd = ixbcd + ixa - iyabcd = iybcd + iya -* -* -* Compute all desired gradients with respect to an x-component. -* - If (iyabcd.ne.0) Then -* - If (nVec(1).eq.3) Then - call ass3(xyz2D0(1,1,iya,iyb,iyc,iyd,2), - & xyz2D0(1,1,iza,izb,izc,izd,3), - & xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(1,1)), - & xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(2,1)), - & xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(3,1)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,1)), - & Temp(Ind2(2,1)),Temp(Ind2(3,1)),nT,nRys) - Else If (nVec(1).eq.2) Then - call ass2(xyz2D0(1,1,iya,iyb,iyc,iyd,2), - & xyz2D0(1,1,iza,izb,izc,izd,3), - & xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(1,1)), - & xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(2,1)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,1)), - & Temp(Ind2(2,1)),nT,nRys) - Else If (nVec(1).eq.1) Then - call ass1(xyz2D0(1,1,iya,iyb,iyc,iyd,2), - & xyz2D0(1,1,iza,izb,izc,izd,3), - & xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(1,1)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,1)), - & nT,nRys) - End If -* - Else -* - If (nVec(1).eq.3) Then - call ass3a(xyz2D0(1,1,iza,izb,izc,izd,3), - & xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(1,1)), - & xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(2,1)), - & xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(3,1)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,1)), - & Temp(Ind2(2,1)),Temp(Ind2(3,1)),nT,nRys) - Else If (nVec(1).eq.2) Then - call ass2a(xyz2D0(1,1,iza,izb,izc,izd,3), - & xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(1,1)), - & xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(2,1)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,1)), - & Temp(Ind2(2,1)),nT,nRys) - Else If (nVec(1).eq.1) Then - call ass1a(xyz2D0(1,1,iza,izb,izc,izd,3), - & xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(1,1)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,1)), - & nT,nRys) - End If -* - End If -* -* Compute all desired gradients with respect to an y-component. -* - If (ixabcd.ne.0) Then -* - If (nVec(2).eq.3) Then - call ass3(xyz2D0(1,1,ixa,ixb,ixc,ixd,1), - & xyz2D0(1,1,iza,izb,izc,izd,3), - & xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(1,2)), - & xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(2,2)), - & xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(3,2)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,2)), - & Temp(Ind2(2,2)),Temp(Ind2(3,2)),nT,nRys) - Else If (nVec(2).eq.2) Then - call ass2(xyz2D0(1,1,ixa,ixb,ixc,ixd,1), - & xyz2D0(1,1,iza,izb,izc,izd,3), - & xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(1,2)), - & xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(2,2)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,2)), - & Temp(Ind2(2,2)),nT,nRys) - Else If (nVec(2).eq.1) Then - call ass1(xyz2D0(1,1,ixa,ixb,ixc,ixd,1), - & xyz2D0(1,1,iza,izb,izc,izd,3), - & xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(1,2)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,2)), - & nT,nRys) - End If -* - Else -* - If (nVec(2).eq.3) Then - call ass3a(xyz2D0(1,1,iza,izb,izc,izd,3), - & xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(1,2)), - & xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(2,2)), - & xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(3,2)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,2)), - & Temp(Ind2(2,2)),Temp(Ind2(3,2)),nT,nRys) - Else If (nVec(2).eq.2) Then - call ass2a(xyz2D0(1,1,iza,izb,izc,izd,3), - & xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(1,2)), - & xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(2,2)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,2)), - & Temp(Ind2(2,2)),nT,nRys) - Else If (nVec(2).eq.1) Then - call ass1a(xyz2D0(1,1,iza,izb,izc,izd,3), - & xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(1,2)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,2)), - & nT,nRys) - End If -* - End If -* -* Compute all desired gradients with respect to an z-component. -* - If (ixabcd*iyabcd.ne.0) Then -* - If (nVec(3).eq.3) Then - call ass3(xyz2D0(1,1,ixa,ixb,ixc,ixd,1), - & xyz2D0(1,1,iya,iyb,iyc,iyd,2), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(2,3)), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(3,3)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,3)), - & Temp(Ind2(2,3)),Temp(Ind2(3,3)),nT,nRys) - Else If (nVec(3).eq.2) Then - call ass2(xyz2D0(1,1,ixa,ixb,ixc,ixd,1), - & xyz2D0(1,1,iya,iyb,iyc,iyd,2), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(2,3)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,3)), - & Temp(Ind2(2,3)),nT,nRys) - Else If (nVec(3).eq.1) Then - call ass1(xyz2D0(1,1,ixa,ixb,ixc,ixd,1), - & xyz2D0(1,1,iya,iyb,iyc,iyd,2), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,3)), - & nT,nRys) - End If -* - Else If (ixabcd.eq.0.and.iyabcd.ne.0) Then -* - If (nVec(3).eq.3) Then - call ass3a(xyz2D0(1,1,iya,iyb,iyc,iyd,2), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(2,3)), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(3,3)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,3)), - & Temp(Ind2(2,3)),Temp(Ind2(3,3)),nT,nRys) - Else If (nVec(3).eq.2) Then - call ass2a(xyz2D0(1,1,iya,iyb,iyc,iyd,2), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(2,3)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,3)), - & Temp(Ind2(2,3)),nT,nRys) - Else If (nVec(3).eq.1) Then - call ass1a(xyz2D0(1,1,iya,iyb,iyc,iyd,2), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,3)), - & nT,nRys) - End If -* - Else If (iyabcd.eq.0.and.ixabcd.ne.0) Then -* - If (nVec(3).eq.3) Then - call ass3a(xyz2D0(1,1,ixa,ixb,ixc,ixd,1), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(2,3)), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(3,3)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,3)), - & Temp(Ind2(2,3)),Temp(Ind2(3,3)),nT,nRys) - Else If (nVec(3).eq.2) Then - call ass2a(xyz2D0(1,1,ixa,ixb,ixc,ixd,1), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(2,3)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,3)), - & Temp(Ind2(2,3)),nT,nRys) - Else If (nVec(3).eq.1) Then - call ass1a(xyz2D0(1,1,ixa,ixb,ixc,ixd,1), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,3)), - & nT,nRys) - End If -* - Else -* - If (nVec(3).eq.3) Then - call ass3b(xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(2,3)), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(3,3)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,3)), - & Temp(Ind2(2,3)),Temp(Ind2(3,3)),nT,nRys) - Else If (nVec(3).eq.2) Then - call ass2b(xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)), - & xyz2D1(1,1,iza,izb,izc,izd,Ind1(2,3)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,3)), - & Temp(Ind2(2,3)),nT,nRys) - Else If (nVec(3).eq.1) Then - call ass1b(xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)), - & PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,3)), - & nT,nRys) - End If -* - End If -* - 400 Continue -* - 300 Continue -* - 200 Continue -* - 100 Continue -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/assg1.F90 openmolcas-22.10/src/rys_util/assg1.F90 --- openmolcas-22.02/src/rys_util/assg1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/assg1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,229 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1991, Roland Lindh * +! 1996, Hans-Joachim Werner * +!*********************************************************************** + +subroutine Assg1(Temp,PAO,nT,nRys,la,lb,lc,ld,xyz2D0,xyz2D1,IfGrad,Indx,mVec) +!*********************************************************************** +! * +! Object: to assemble the gradients of the ERI's. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! October '91; modified by H.-J. Werner, Mai 1996 * +!*********************************************************************** + +use Index_Functions, only: C_Ind3_Rev, nTri_Elem1 +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(out) :: Temp(9) +integer(kind=iwp), intent(in) :: nT, nRys, la, lb, lc, ld, Indx(3,4) +real(kind=wp), intent(in) :: PAO(nT,nTri_Elem1(la),nTri_Elem1(lb),nTri_Elem1(lc),nTri_Elem1(ld)), & + xyz2D0(nRys,nT,0:la+1,0:lb+1,0:lc+1,0:ld+1,3), xyz2D1(nRys,nT,0:la,0:lb,0:lc,0:ld,9) +logical(kind=iwp), intent(in) :: IfGrad(3,4) +integer(kind=iwp), intent(out) :: mVec +#include "itmax.fh" +integer(kind=iwp) :: i, iCent, icir(3), Ind1(3,3), Ind2(3,3), ipa, ipb, ipc, ipd, ixa, ixabcd, ixb, ixbcd, ixc, ixcd, ixd, iya, & + iyabcd, iyb, iybcd, iyc, iycd, iyd, iza, izb, izc, izd, nVec(3) + +Temp(:) = Zero + +mVec = 0 +nVec(:) = 0 +do i=1,3 ! Cartesian directions + do iCent=1,4 ! Centers of integral + if (IfGrad(i,iCent)) then + mVec = mVec+1 + nVec(i) = nVec(i)+1 + Ind1(nVec(i),i) = 3*(Indx(i,iCent)-1)+i + Ind2(nVec(i),i) = mVec + end if + end do +end do + +do ipd=1,nTri_Elem1(ld) + icir(:) = C_Ind3_Rev(ipd,ld) + ixd = icir(1) + iyd = icir(2) + izd = icir(3) + + do ipc=1,nTri_Elem1(lc) + icir(:) = C_Ind3_Rev(ipc,lc) + ixc = icir(1) + iyc = icir(2) + izc = icir(3) + + ixcd = ixc+ixd + iycd = iyc+iyd + + do ipb=1,nTri_Elem1(lb) + icir(:) = C_Ind3_Rev(ipb,lb) + ixb = icir(1) + iyb = icir(2) + izb = icir(3) + + ixbcd = ixcd+ixb + iybcd = iycd+iyb + + do ipa=1,nTri_Elem1(la) + icir(:) = C_Ind3_Rev(ipa,la) + ixa = icir(1) + iya = icir(2) + iza = icir(3) + + ixabcd = ixbcd+ixa + iyabcd = iybcd+iya + + ! Compute all desired gradients with respect to an x-component. + + if (iyabcd /= 0) then + + select case (nVec(1)) + case (3) + call ass3(xyz2D0(1,1,iya,iyb,iyc,iyd,2),xyz2D0(1,1,iza,izb,izc,izd,3),xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(1,1)), & + xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(2,1)),xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(3,1)),PAO(1,ipa,ipb,ipc,ipd), & + Temp(Ind2(1,1)),Temp(Ind2(2,1)),Temp(Ind2(3,1)),nT,nRys) + case (2) + call ass2(xyz2D0(1,1,iya,iyb,iyc,iyd,2),xyz2D0(1,1,iza,izb,izc,izd,3),xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(1,1)), & + xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(2,1)),PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,1)),Temp(Ind2(2,1)),nT,nRys) + case (1) + call ass1(xyz2D0(1,1,iya,iyb,iyc,iyd,2),xyz2D0(1,1,iza,izb,izc,izd,3),xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(1,1)), & + PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,1)),nT,nRys) + end select + + else + + select case (nVec(1)) + case (3) + call ass3a(xyz2D0(1,1,iza,izb,izc,izd,3),xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(1,1)), & + xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(2,1)),xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(3,1)),PAO(1,ipa,ipb,ipc,ipd), & + Temp(Ind2(1,1)),Temp(Ind2(2,1)),Temp(Ind2(3,1)),nT,nRys) + case (2) + call ass2a(xyz2D0(1,1,iza,izb,izc,izd,3),xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(1,1)), & + xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(2,1)),PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,1)),Temp(Ind2(2,1)),nT,nRys) + case (1) + call ass1a(xyz2D0(1,1,iza,izb,izc,izd,3),xyz2D1(1,1,ixa,ixb,ixc,ixd,Ind1(1,1)),PAO(1,ipa,ipb,ipc,ipd), & + Temp(Ind2(1,1)),nT,nRys) + end select + + end if + + ! Compute all desired gradients with respect to a y-component. + + if (ixabcd /= 0) then + + select case (nVec(2)) + case (3) + call ass3(xyz2D0(1,1,ixa,ixb,ixc,ixd,1),xyz2D0(1,1,iza,izb,izc,izd,3),xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(1,2)), & + xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(2,2)),xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(3,2)),PAO(1,ipa,ipb,ipc,ipd), & + Temp(Ind2(1,2)),Temp(Ind2(2,2)),Temp(Ind2(3,2)),nT,nRys) + case (2) + call ass2(xyz2D0(1,1,ixa,ixb,ixc,ixd,1),xyz2D0(1,1,iza,izb,izc,izd,3),xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(1,2)), & + xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(2,2)),PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,2)),Temp(Ind2(2,2)),nT,nRys) + case (1) + call ass1(xyz2D0(1,1,ixa,ixb,ixc,ixd,1),xyz2D0(1,1,iza,izb,izc,izd,3),xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(1,2)), & + PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,2)),nT,nRys) + end select + + else + + select case (nVec(2)) + case (3) + call ass3a(xyz2D0(1,1,iza,izb,izc,izd,3),xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(1,2)), & + xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(2,2)),xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(3,2)),PAO(1,ipa,ipb,ipc,ipd), & + Temp(Ind2(1,2)),Temp(Ind2(2,2)),Temp(Ind2(3,2)),nT,nRys) + case (2) + call ass2a(xyz2D0(1,1,iza,izb,izc,izd,3),xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(1,2)), & + xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(2,2)),PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,2)),Temp(Ind2(2,2)),nT,nRys) + case (1) + call ass1a(xyz2D0(1,1,iza,izb,izc,izd,3),xyz2D1(1,1,iya,iyb,iyc,iyd,Ind1(1,2)),PAO(1,ipa,ipb,ipc,ipd), & + Temp(Ind2(1,2)),nT,nRys) + end select + + end if + + ! Compute all desired gradients with respect to a z-component. + + if (ixabcd*iyabcd /= 0) then + + select case (nVec(3)) + case (3) + call ass3(xyz2D0(1,1,ixa,ixb,ixc,ixd,1),xyz2D0(1,1,iya,iyb,iyc,iyd,2),xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)), & + xyz2D1(1,1,iza,izb,izc,izd,Ind1(2,3)),xyz2D1(1,1,iza,izb,izc,izd,Ind1(3,3)),PAO(1,ipa,ipb,ipc,ipd), & + Temp(Ind2(1,3)),Temp(Ind2(2,3)),Temp(Ind2(3,3)),nT,nRys) + case (2) + call ass2(xyz2D0(1,1,ixa,ixb,ixc,ixd,1),xyz2D0(1,1,iya,iyb,iyc,iyd,2),xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)), & + xyz2D1(1,1,iza,izb,izc,izd,Ind1(2,3)),PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,3)),Temp(Ind2(2,3)),nT,nRys) + case (1) + call ass1(xyz2D0(1,1,ixa,ixb,ixc,ixd,1),xyz2D0(1,1,iya,iyb,iyc,iyd,2),xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)), & + PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,3)),nT,nRys) + end select + + else if ((ixabcd == 0) .and. (iyabcd /= 0)) then + + select case (nVec(3)) + case (3) + call ass3a(xyz2D0(1,1,iya,iyb,iyc,iyd,2),xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)), & + xyz2D1(1,1,iza,izb,izc,izd,Ind1(2,3)),xyz2D1(1,1,iza,izb,izc,izd,Ind1(3,3)),PAO(1,ipa,ipb,ipc,ipd), & + Temp(Ind2(1,3)),Temp(Ind2(2,3)),Temp(Ind2(3,3)),nT,nRys) + case (2) + call ass2a(xyz2D0(1,1,iya,iyb,iyc,iyd,2),xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)), & + xyz2D1(1,1,iza,izb,izc,izd,Ind1(2,3)),PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,3)),Temp(Ind2(2,3)),nT,nRys) + case (1) + call ass1a(xyz2D0(1,1,iya,iyb,iyc,iyd,2),xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)),PAO(1,ipa,ipb,ipc,ipd), & + Temp(Ind2(1,3)),nT,nRys) + end select + + else if ((iyabcd == 0) .and. (ixabcd /= 0)) then + + select case (nVec(3)) + case (3) + call ass3a(xyz2D0(1,1,ixa,ixb,ixc,ixd,1),xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)), & + xyz2D1(1,1,iza,izb,izc,izd,Ind1(2,3)),xyz2D1(1,1,iza,izb,izc,izd,Ind1(3,3)),PAO(1,ipa,ipb,ipc,ipd), & + Temp(Ind2(1,3)),Temp(Ind2(2,3)),Temp(Ind2(3,3)),nT,nRys) + case (2) + call ass2a(xyz2D0(1,1,ixa,ixb,ixc,ixd,1),xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)), & + xyz2D1(1,1,iza,izb,izc,izd,Ind1(2,3)),PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,3)),Temp(Ind2(2,3)),nT,nRys) + case (1) + call ass1a(xyz2D0(1,1,ixa,ixb,ixc,ixd,1),xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)),PAO(1,ipa,ipb,ipc,ipd), & + Temp(Ind2(1,3)),nT,nRys) + end select + + else + + select case (nVec(3)) + case (3) + call ass3b(xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)),xyz2D1(1,1,iza,izb,izc,izd,Ind1(2,3)), & + xyz2D1(1,1,iza,izb,izc,izd,Ind1(3,3)),PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,3)),Temp(Ind2(2,3)), & + Temp(Ind2(3,3)),nT,nRys) + case (2) + call ass2b(xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)),xyz2D1(1,1,iza,izb,izc,izd,Ind1(2,3)),PAO(1,ipa,ipb,ipc,ipd), & + Temp(Ind2(1,3)),Temp(Ind2(2,3)),nT,nRys) + case (1) + call ass1b(xyz2D1(1,1,iza,izb,izc,izd,Ind1(1,3)),PAO(1,ipa,ipb,ipc,ipd),Temp(Ind2(1,3)),nT,nRys) + end select + + end if + + end do + + end do + + end do + +end do + +return + +end subroutine Assg1 diff -Nru openmolcas-22.02/src/rys_util/assg1_mck.f openmolcas-22.10/src/rys_util/assg1_mck.f --- openmolcas-22.02/src/rys_util/assg1_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/assg1_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,556 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine Assg1_mck(g1,nT,nRys,la,lb,lc,ld,xyz2D0,xyz2D1, - & IfGrad,Index,mVec,Index2) -************************************************************************ -* * -* Object: to assemble the gradients of the ERI's. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* October '91 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -c#include "print.fh" -#include "real.fh" -#include "itmax.fh" -#include "iavec.fh" - Real*8 g1(nT,(la+1)*(la+2)/2,(lb+1)*(lb+2)/2, - & (lc+1)*(lc+2)/2,(ld+1)*(ld+2)/2,9), - & xyz2D0(nRys,nT,0:la+2,0:lb+2,0:lc+2,0:ld+2,3), - & xyz2D1(nRys,nT,0:la ,0:lb ,0:lc ,0:ld ,9) - Logical IfGrad(3,4) - Integer Ind1(3), Ind2(3), Index(3,4),Index2(3,4) -* -* Statement functions -* - nElem(i) = (i+1)*(i+2)/2 -* - ka=(la+1)*(la+2)/2 - kb=(lb+1)*(lb+2)/2 - kc=(lc+1)*(lc+2)/2 - kd=(ld+1)*(ld+2)/2 - nG1=nT*9*ka*kb*kc*kd - call dcopy_(nG1,[Zero],0,G1,1) - Call ICOPY(12,[0],0,Index2,1) -* - ii = la*(la+1)*(la+2)/6 - jj = lb*(lb+1)*(lb+2)/6 - kk = lc*(lc+1)*(lc+2)/6 - ll = ld*(ld+1)*(ld+2)/6 -* - Do 100 ipa = 1, nElem(la) - ipaii=ipa+ii - ixa = ixyz(1,ipaii) - iya = ixyz(2,ipaii) - iza = ixyz(3,ipaii) -* - Do 200 ipb = 1, nElem(lb) - ipbjj=ipb+jj - ixb = ixyz(1,ipbjj) - iyb = ixyz(2,ipbjj) - izb = ixyz(3,ipbjj) -* - ixab = ixa + ixb - iyab = iya + iyb -* - Do 300 ipc = 1, nElem(lc) - ipckk=ipc+kk - ixc = ixyz(1,ipckk) - iyc = ixyz(2,ipckk) - izc = ixyz(3,ipckk) -* - ixabc = ixab + ixc - iyabc = iyab + iyc -* - Do 400 ipd = 1, nElem(ld) - ipdll=ipd+ll - ixd = ixyz(1,ipdll) - iyd = ixyz(2,ipdll) - izd = ixyz(3,ipdll) -* - ixabcd = ixabc + ixd - iyabcd = iyabc + iyd -* -* Compute all desired gradients with respect to an x-component. -* - mVec = 0 - nVec = 0 - Do 1000 iCent = 1, 4 - If (IfGrad(1,iCent)) Then - mVec = mVec + 1 - nVec = nVec + 1 - Ind1(nVec) = 3*(Index(1,iCent)-1) + 1 - Ind2(nVec) = mVec - Index2(1,iCent)=mVec - End If - 1000 Continue -* - If (iyabcd.ne.0) Then -* - If (nVec.eq.3) Then - Do iT = 1, nT - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,iya,iyb,iyc,iyd,2) * - & xyz2D0(iRys,iT,iza,izb,izc,izd,3) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(1)) - tmp2 = tmp2 + tmp * - & xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(2)) - tmp3 = tmp3 + tmp * - & xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(3)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) + tmp2 - g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) + tmp3 - End Do - Else If (nVec.eq.2) Then - Do iT = 1, nT - tmp1 = 0.0D0 - tmp2 = 0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,iya,iyb,iyc,iyd,2) * - & xyz2D0(iRys,iT,iza,izb,izc,izd,3) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(1)) - tmp2 = tmp2 + tmp * - & xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(2)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) + tmp2 - End Do - Else If (nVec.eq.1) Then - Do iT = 1, nT - tmp1 = 0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,iya,iyb,iyc,iyd,2) * - & xyz2D0(iRys,iT,iza,izb,izc,izd,3) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(1)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - End Do - End If -* - Else -* - If (nVec.eq.3) Then - Do iT = 1, nT - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,iza,izb,izc,izd,3) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(1)) - tmp2 = tmp2 + tmp * - & xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(2)) - tmp3 = tmp3 + tmp * - & xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(3)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) + tmp2 - g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) + tmp3 - End Do - Else If (nVec.eq.2) Then - Do iT = 1, nT - tmp1=0.0D0 - tmp2=0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,iza,izb,izc,izd,3) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(1)) - tmp2 = tmp2 + tmp * - & xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(2)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) + tmp2 - End Do - Else If (nVec.eq.1) Then - Do iT = 1, nT - tmp1=0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,iza,izb,izc,izd,3) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(1)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - End Do - End If -* - End If -* -* Compute all desired gradients with respect to an y-component. -* - nVec = 0 - Do 2000 iCent = 1, 4 - If (IfGrad(2,iCent)) Then - mVec = mVec + 1 - nVec = nVec + 1 - Ind1(nVec) = 3*(Index(2,iCent)-1) + 2 - Ind2(nVec) = mVec - Index2(2,iCent)=mVec - End If - 2000 Continue -* - If (ixabcd.ne.0) Then -* - If (nVec.eq.3) Then - Do iT = 1, nT - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,ixa,ixb,ixc,ixd,1) * - & xyz2D0(iRys,iT,iza,izb,izc,izd,3) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(1)) - tmp2 = tmp2 + tmp * - & xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(2)) - tmp3 = tmp3 + tmp * - & xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(3)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) + tmp2 - g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) + tmp3 - End Do - Else If (nVec.eq.2) Then - Do iT = 1, nT - tmp1=0.0D0 - tmp2=0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,ixa,ixb,ixc,ixd,1) * - & xyz2D0(iRys,iT,iza,izb,izc,izd,3) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(1)) - tmp2 = tmp2 + tmp * - & xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(2)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) + tmp2 - End Do - Else If (nVec.eq.1) Then - Do iT = 1, nT - tmp1 = 0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,ixa,ixb,ixc,ixd,1) * - & xyz2D0(iRys,iT,iza,izb,izc,izd,3) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(1)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - End Do - End If -* - Else -* - If (nVec.eq.3) Then - Do iT = 1, nT - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,iza,izb,izc,izd,3) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(1)) - tmp2 = tmp2 + tmp * - & xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(2)) - tmp3 = tmp3 + tmp * - & xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(3)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) + tmp2 - g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) + tmp3 - End Do - Else If (nVec.eq.2) Then - Do iT = 1, nT - tmp1=0.0D0 - tmp2=0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,iza,izb,izc,izd,3) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(1)) - tmp2 = tmp2 + tmp * - & xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(2)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) + tmp2 - End Do - Else If (nVec.eq.1) Then - Do iT = 1, nT - tmp1 = 0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,iza,izb,izc,izd,3) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(1)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - End Do - End If -* - End If -* -* Compute all desired gradients with respect to an z-component. -* - nVec = 0 - Do 3000 iCent = 1, 4 - If (IfGrad(3,iCent)) Then - mVec = mVec + 1 - nVec = nVec + 1 - Ind1(nVec) = 3*(Index(3,iCent)-1) + 3 - Ind2(nVec) = mVec - Index2(3,iCent)=mVec - End If - 3000 Continue -* - If (ixabcd*iyabcd.ne.0) Then -* - If (nVec.eq.3) Then - Do iT = 1, nT - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,ixa,ixb,ixc,ixd,1) * - & xyz2D0(iRys,iT,iya,iyb,iyc,iyd,2) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) - tmp2 = tmp2 + tmp * - & xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(2)) - tmp3 = tmp3 + tmp * - & xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(3)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) + tmp2 - g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) + tmp3 - End Do - Else If (nVec.eq.2) Then - Do iT = 1, nT - tmp1=0.0D0 - tmp2=0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,ixa,ixb,ixc,ixd,1) * - & xyz2D0(iRys,iT,iya,iyb,iyc,iyd,2) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) - tmp2 = tmp2 + tmp * - & xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(2)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) + tmp2 - End Do - Else If (nVec.eq.1) Then - Do iT = 1, nT - tmp1=0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,ixa,ixb,ixc,ixd,1) * - & xyz2D0(iRys,iT,iya,iyb,iyc,iyd,2) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - End Do - End If -* - Else If (ixabcd.eq.0.and.iyabcd.ne.0) Then -* - If (nVec.eq.3) Then - Do iT = 1, nT - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,iya,iyb,iyc,iyd,2) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) - tmp2 = tmp2 + tmp * - & xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(2)) - tmp3 = tmp3 + tmp * - & xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(3)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) + tmp2 - g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) + tmp3 - End Do - Else If (nVec.eq.2) Then - Do iT = 1, nT - tmp1=0.0D0 - tmp2=0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,iya,iyb,iyc,iyd,2) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) - tmp2 = tmp2 + tmp * - & xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(2)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) + tmp2 - End Do - Else If (nVec.eq.1) Then - Do iT = 1, nT - tmp1=0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,iya,iyb,iyc,iyd,2) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - End Do - End If -* - Else If (iyabcd.eq.0.and.ixabcd.ne.0) Then -* - If (nVec.eq.3) Then - Do iT = 1, nT - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,ixa,ixb,ixc,ixd,1) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) - tmp2 = tmp2 + tmp * - & xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(2)) - tmp3 = tmp3 + tmp * - & xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(3)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) + tmp2 - g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) + tmp3 - End Do - Else If (nVec.eq.2) Then - Do iT = 1, nT - tmp1=0.0D0 - tmp2=0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,ixa,ixb,ixc,ixd,1) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) - tmp2 = tmp2 + tmp * - & xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(2)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) + tmp2 - End Do - Else If (nVec.eq.1) Then - Do iT = 1, nT - tmp1=0.0D0 - Do iRys = 1, nRys - tmp = xyz2D0(iRys,iT,ixa,ixb,ixc,ixd,1) - tmp1 = tmp1 + tmp * - & xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - End Do - End If -* - Else -* - If (nVec.eq.3) Then - Do iT = 1, nT - tmp1=0.0D0 - tmp2=0.0D0 - tmp3=0.0D0 - Do iRys = 1, nRys - tmp1 = tmp1 + xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) - tmp2 = tmp2 + xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(2)) - tmp3 = tmp3 + xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(3)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) + tmp2 - g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) + tmp3 - End Do - Else If (nVec.eq.2) Then - Do iT = 1, nT - tmp1=0.0D0 - tmp2=0.0D0 - Do iRys = 1, nRys - tmp1 = tmp1 + xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) - tmp2 = tmp2 + xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(2)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) + tmp2 - End Do - Else If (nVec.eq.1) Then - Do iT = 1, nT - tmp1=0.0D0 - Do iRys = 1, nRys - tmp1 = tmp1 + xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) - End Do - g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = - & g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) + tmp1 - End Do - End If -* - End If -* - 400 Continue -* - 300 Continue -* - 200 Continue -* - 100 Continue -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/assg1_mck.F90 openmolcas-22.10/src/rys_util/assg1_mck.F90 --- openmolcas-22.02/src/rys_util/assg1_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/assg1_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,456 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine Assg1_mck(g1,nT,nRys,la,lb,lc,ld,xyz2D0,xyz2D1,IfGrad,Indx,mVec,Indx2) +!*********************************************************************** +! * +! Object: to assemble the gradients of the ERI's. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! October '91 * +!*********************************************************************** + +use Index_Functions, only: C_Ind3_Rev, nTri_Elem1 +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nT, nRys, la, lb, lc, ld, Indx(3,4) +real(kind=wp), intent(out) :: g1(nT,nTri_Elem1(la),nTri_Elem1(lb),nTri_Elem1(lc),nTri_Elem1(ld),9) +real(kind=wp), intent(in) :: xyz2D0(nRys,nT,0:la+2,0:lb+2,0:lc+2,0:ld+2,3), xyz2D1(nRys,nT,0:la,0:lb,0:lc,0:ld,9) +logical(kind=iwp), intent(in) :: IfGrad(3,4) +integer(kind=iwp), intent(out) :: mVec, Indx2(3,4) +#include "itmax.fh" +integer(kind=iwp) :: iCent, icir(3), Ind1(3), Ind2(3), ipa, ipb, ipc, ipd, iRys, iT, ixa, ixab, ixabc, ixabcd, ixb, ixc, ixd, iya, & + iyab, iyabc, iyabcd, iyb, iyc, iyd, iza, izb, izc, izd, nVec +real(kind=wp) :: tmp, tmp1, tmp2, tmp3 + +g1(:,:,:,:,:,:) = Zero +Indx2(:,:) = 0 + +do ipa=1,nTri_Elem1(la) + icir(:) = C_Ind3_Rev(ipa,la) + ixa = icir(1) + iya = icir(2) + iza = icir(3) + + do ipb=1,nTri_Elem1(lb) + icir(:) = C_Ind3_Rev(ipb,lb) + ixb = icir(1) + iyb = icir(2) + izb = icir(3) + + ixab = ixa+ixb + iyab = iya+iyb + + do ipc=1,nTri_Elem1(lc) + icir(:) = C_Ind3_Rev(ipc,lc) + ixc = icir(1) + iyc = icir(2) + izc = icir(3) + + ixabc = ixab+ixc + iyabc = iyab+iyc + + do ipd=1,nTri_Elem1(ld) + icir(:) = C_Ind3_Rev(ipd,ld) + ixd = icir(1) + iyd = icir(2) + izd = icir(3) + + ixabcd = ixabc+ixd + iyabcd = iyabc+iyd + + ! Compute all desired gradients with respect to an x-component. + + mVec = 0 + nVec = 0 + do iCent=1,4 + if (IfGrad(1,iCent)) then + mVec = mVec+1 + nVec = nVec+1 + Ind1(nVec) = 3*(Indx(1,iCent)-1)+1 + Ind2(nVec) = mVec + Indx2(1,iCent) = mVec + end if + end do + + if (iyabcd /= 0) then + + select case (nVec) + case (3) + do iT=1,nT + tmp1 = Zero + tmp2 = Zero + tmp3 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,iya,iyb,iyc,iyd,2)*xyz2D0(iRys,iT,iza,izb,izc,izd,3) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(1)) + tmp2 = tmp2+tmp*xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(2)) + tmp3 = tmp3+tmp*xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(3)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(2))+tmp2 + g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(3))+tmp3 + end do + case (2) + do iT=1,nT + tmp1 = Zero + tmp2 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,iya,iyb,iyc,iyd,2)*xyz2D0(iRys,iT,iza,izb,izc,izd,3) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(1)) + tmp2 = tmp2+tmp*xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(2)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(2))+tmp2 + end do + case (1) + do iT=1,nT + tmp1 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,iya,iyb,iyc,iyd,2)*xyz2D0(iRys,iT,iza,izb,izc,izd,3) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(1)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + end do + end select + + else + + select case (nVec) + case (3) + do iT=1,nT + tmp1 = Zero + tmp2 = Zero + tmp3 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,iza,izb,izc,izd,3) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(1)) + tmp2 = tmp2+tmp*xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(2)) + tmp3 = tmp3+tmp*xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(3)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(2))+tmp2 + g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(3))+tmp3 + end do + case (2) + do iT=1,nT + tmp1 = Zero + tmp2 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,iza,izb,izc,izd,3) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(1)) + tmp2 = tmp2+tmp*xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(2)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(2))+tmp2 + end do + case (1) + do iT=1,nT + tmp1 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,iza,izb,izc,izd,3) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,ixa,ixb,ixc,ixd,Ind1(1)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + end do + end select + + end if + + ! Compute all desired gradients with respect to a y-component. + + nVec = 0 + do iCent=1,4 + if (IfGrad(2,iCent)) then + mVec = mVec+1 + nVec = nVec+1 + Ind1(nVec) = 3*(Indx(2,iCent)-1)+2 + Ind2(nVec) = mVec + Indx2(2,iCent) = mVec + end if + end do + + if (ixabcd /= 0) then + + select case (nVec) + case (3) + do iT=1,nT + tmp1 = Zero + tmp2 = Zero + tmp3 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,ixa,ixb,ixc,ixd,1)*xyz2D0(iRys,iT,iza,izb,izc,izd,3) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(1)) + tmp2 = tmp2+tmp*xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(2)) + tmp3 = tmp3+tmp*xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(3)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(2))+tmp2 + g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(3))+tmp3 + end do + case (2) + do iT=1,nT + tmp1 = Zero + tmp2 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,ixa,ixb,ixc,ixd,1)*xyz2D0(iRys,iT,iza,izb,izc,izd,3) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(1)) + tmp2 = tmp2+tmp*xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(2)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(2))+tmp2 + end do + case (1) + do iT=1,nT + tmp1 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,ixa,ixb,ixc,ixd,1)*xyz2D0(iRys,iT,iza,izb,izc,izd,3) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(1)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + end do + end select + + else + + select case (nVec) + case (3) + do iT=1,nT + tmp1 = Zero + tmp2 = Zero + tmp3 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,iza,izb,izc,izd,3) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(1)) + tmp2 = tmp2+tmp*xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(2)) + tmp3 = tmp3+tmp*xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(3)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(2))+tmp2 + g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(3))+tmp3 + end do + case (2) + do iT=1,nT + tmp1 = Zero + tmp2 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,iza,izb,izc,izd,3) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(1)) + tmp2 = tmp2+tmp*xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(2)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(2))+tmp2 + end do + case (1) + do iT=1,nT + tmp1 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,iza,izb,izc,izd,3) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,iya,iyb,iyc,iyd,Ind1(1)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + end do + end select + + end if + + ! Compute all desired gradients with respect to a z-component. + + nVec = 0 + do iCent=1,4 + if (IfGrad(3,iCent)) then + mVec = mVec+1 + nVec = nVec+1 + Ind1(nVec) = 3*(Indx(3,iCent)-1)+3 + Ind2(nVec) = mVec + Indx2(3,iCent) = mVec + end if + end do + + if (ixabcd*iyabcd /= 0) then + + select case (nVec) + case (3) + do iT=1,nT + tmp1 = Zero + tmp2 = Zero + tmp3 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,ixa,ixb,ixc,ixd,1)*xyz2D0(iRys,iT,iya,iyb,iyc,iyd,2) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) + tmp2 = tmp2+tmp*xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(2)) + tmp3 = tmp3+tmp*xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(3)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(2))+tmp2 + g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(3))+tmp3 + end do + case (2) + do iT=1,nT + tmp1 = Zero + tmp2 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,ixa,ixb,ixc,ixd,1)*xyz2D0(iRys,iT,iya,iyb,iyc,iyd,2) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) + tmp2 = tmp2+tmp*xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(2)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(2))+tmp2 + end do + case (1) + do iT=1,nT + tmp1 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,ixa,ixb,ixc,ixd,1)*xyz2D0(iRys,iT,iya,iyb,iyc,iyd,2) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + end do + end select + + else if ((ixabcd == 0) .and. (iyabcd /= 0)) then + + select case (nVec) + case (3) + do iT=1,nT + tmp1 = Zero + tmp2 = Zero + tmp3 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,iya,iyb,iyc,iyd,2) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) + tmp2 = tmp2+tmp*xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(2)) + tmp3 = tmp3+tmp*xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(3)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(2))+tmp2 + g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(3))+tmp3 + end do + case (2) + do iT=1,nT + tmp1 = Zero + tmp2 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,iya,iyb,iyc,iyd,2) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) + tmp2 = tmp2+tmp*xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(2)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(2))+tmp2 + end do + case (1) + do iT=1,nT + tmp1 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,iya,iyb,iyc,iyd,2) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + end do + end select + + else if ((iyabcd == 0) .and. (ixabcd /= 0)) then + + select case (nVec) + case (3) + do iT=1,nT + tmp1 = Zero + tmp2 = Zero + tmp3 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,ixa,ixb,ixc,ixd,1) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) + tmp2 = tmp2+tmp*xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(2)) + tmp3 = tmp3+tmp*xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(3)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(2))+tmp2 + g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(3))+tmp3 + end do + case (2) + do iT=1,nT + tmp1 = Zero + tmp2 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,ixa,ixb,ixc,ixd,1) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) + tmp2 = tmp2+tmp*xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(2)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(2))+tmp2 + end do + case (1) + do iT=1,nT + tmp1 = Zero + do iRys=1,nRys + tmp = xyz2D0(iRys,iT,ixa,ixb,ixc,ixd,1) + tmp1 = tmp1+tmp*xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + end do + end select + + else + + select case (nVec) + case (3) + do iT=1,nT + tmp1 = Zero + tmp2 = Zero + tmp3 = Zero + do iRys=1,nRys + tmp1 = tmp1+xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) + tmp2 = tmp2+xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(2)) + tmp3 = tmp3+xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(3)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(2))+tmp2 + g1(iT,ipa,ipb,ipc,ipd,Ind2(3)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(3))+tmp3 + end do + case (2) + do iT=1,nT + tmp1 = Zero + tmp2 = Zero + do iRys=1,nRys + tmp1 = tmp1+xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) + tmp2 = tmp2+xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(2)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + g1(iT,ipa,ipb,ipc,ipd,Ind2(2)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(2))+tmp2 + end do + case (1) + do iT=1,nT + tmp1 = Zero + do iRys=1,nRys + tmp1 = tmp1+xyz2D1(iRys,iT,iza,izb,izc,izd,Ind1(1)) + end do + g1(iT,ipa,ipb,ipc,ipd,Ind2(1)) = g1(iT,ipa,ipb,ipc,ipd,Ind2(1))+tmp1 + end do + end select + + end if + + end do + + end do + + end do + +end do + +return + +end subroutine Assg1_mck diff -Nru openmolcas-22.02/src/rys_util/assg2.f openmolcas-22.10/src/rys_util/assg2.f --- openmolcas-22.02/src/rys_util/assg2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/assg2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,188 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine Assg2(g2,nT,nRys,la,lb,lc,ld,xyz2D0,xyz2D1,xyz2D2, - & IfHss,Index1,Index2,ng,nh,PAO) -************************************************************************ -* * -* Object: to assemble the gradients of the ERI's. * -* * -* Author: Anders Bernhardsson * -* Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* March '95 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -c#include "print.fh" -#include "real.fh" -#include "itmax.fh" -#include "iavec.fh" - Real*8 g2(78),PAO(nt,(la+1)*(la+2)/2, - & (lb+1)*(lb+2)/2, - & (lc+1)*(lc+2)/2, - & (ld+1)*(ld+2)/2), - & xyz2D0(nRys,nT,0:la+2,0:lb+2,0:lc+2,0:ld+2,3), - & xyz2D1(nRys,nT,0:la ,0:lb ,0:lc ,0:ld ,9), - & xyz2D2(nRys,nT,0:la ,0:lb ,0:lc ,0:ld ,18) - Logical IfHss(4,3,4,3) - Integer Index2(2,6,3),Index1(3,3),ng(3),nh(3) -* -* Statement functions -* - nElem(i) = (i+1)*(i+2)/2 - Ind(Icent,Icar,Jcent,jCar)=((iCent-1)*3+iCar-1)* - & ((iCent-1)*3+iCar)/2+ - & (jCent-1)*3+jCar -* -*define _DEBUGPRINT_ -c iRout = 248 -c iPrint = nPrint(iRout) - call dcopy_(78,[Zero],0,g2,1) -#ifdef _DEBUGPRINT_ - Call RecPrt('Assg2: g2(0)',' ',g2,1,78) -#endif - ii = la*(la+1)*(la+2)/6 - jj = lb*(lb+1)*(lb+2)/6 - kk = lc*(lc+1)*(lc+2)/6 - ll = ld*(ld+1)*(ld+2)/6 - kcar = 0 ! dummy initialize -* -* First we construct the non diagonal derivatives -* - Do 90 iCar=1,3 - Do 95 jCar=1,3 -* -* Determine the permutation of the cartesian indexes -* - - If (jCar.eq.iCar) Goto 94 - If (iCar*jCar.eq.2) Kcar=3 - If (iCar*jCar.eq.6) kCar=1 - If (iCar*jCar.eq.3) KCar=2 -* -* Loop over the atomic centre, in order -* that the intgrals are calculated in. -* - - Do 100 iDer=1,ng(iCar) - Do 110 jDer=1,ng(jCar) - iCent=Index1(iDer,iCar) - jCent=Index1(jDer,jCar) -* - If (IfHss(iCent,iCar,jCent,jCar)) Then - I=Ind(iCent,iCar,jCent,jCar) - ix1=(iDer-1)*3+iCar - ix2=(jDer-1)*3+jCar -* -* Loop over angular momentas -* - Do 120 ipd=1,nelem(ld) - id1= ixyz(iCar,ll+ipd) - id2 =ixyz(jCar,ll+ipd) - id3= ixyz(kCar,ll+ipd) - Do 130 ipc=1,nelem(lc) - ic1= ixyz(iCar,kk+ipc) - ic2 =ixyz(jCar,kk+ipc) - ic3= ixyz(kCar,kk+ipc) - Do 140 ipb=1,nelem(lb) - ib1= ixyz(iCar,jj+ipb) - ib2 =ixyz(jCar,jj+ipb) - ib3= ixyz(kCar,jj+ipb) - Do 150 ipa=1,nelem(la) - ia1= ixyz(iCar,ii+ipa) - ia2 =ixyz(jCar,ii+ipa) - ia3= ixyz(kCar,ii+ipa) -* -* Loop over Rys-polynomia and exponents of the -* basis set! -* - tmp=0.0D0 - Do it=1,nt - Do iRys=1,nRys - tmp=tmp+ - & PAO(iT,ipa,ipb,ipc,ipd)* - & xyz2D0(iRys,iT,ia3,ib3,ic3,id3,kCar)* - & xyz2D1(iRys,iT,ia1,ib1,ic1,id1,ix1)* - & xyz2D1(iRys,iT,ia2,ib2,ic2,id2,ix2) - End Do - End Do - g2(I) = g2(I) + tmp - 150 Continue - 140 Continue - 130 Continue - 120 Continue - End If - 110 Continue - 100 Continue - 94 Continue - 95 Continue - 90 Continue -#ifdef _DEBUGPRINT_ - Call RecPrt('Assg2: g2 non-diagonal',' ',g2,1,78) -#endif -* -* Then construct the diagonal derivatives -* - Do 200 iCar=1,3 - jCar=Mod(iCar,3)+1 - kCar=Mod(jCar,3)+1 - Do 210 iDer=1,nh(iCar) - ix1=(iDer-1)*3+iCar - iCent=Index2(1,iDer,iCar) - jCent=Index2(2,iDer,iCar) - If (IfHss(iCent,iCar,jCent,iCar)) Then - I=Ind(iCent,iCar,jCent,iCar) -* - Do 220 ipd=1,nelem(ld) - id1= ixyz(iCar,ll+ipd) - id2 =ixyz(jCar,ll+ipd) - id3= ixyz(kCar,ll+ipd) - - Do 230 ipc=1,nelem(lc) - ic1= ixyz(iCar,kk+ipc) - ic2 =ixyz(jCar,kk+ipc) - ic3= ixyz(kCar,kk+ipc) - - Do 240 ipb=1,nelem(lb) - ib1= ixyz(iCar,jj+ipb) - ib2 =ixyz(jCar,jj+ipb) - ib3= ixyz(kCar,jj+ipb) - Do 250 ipa=1,nelem(la) - ia1= ixyz(iCar,ii+ipa) - ia2 =ixyz(jCar,ii+ipa) - ia3= ixyz(kCar,ii+ipa) -* - tmp=0.0D0 - Do it=1,nt - Do iRys=1,nRys - tmp = tmp + - & PAO(iT,ipa,ipb,ipc,ipd)* - & xyz2D0(iRys,iT,ia2,ib2,ic2,id2,jCar)* - & xyz2D0(iRys,iT,ia3,ib3,ic3,id3,kCar)* - & xyz2D2(iRys,iT,ia1,ib1,ic1,id1,ix1) - End Do - End Do - g2(I)=g2(I)+tmp -* - 250 Continue - 240 Continue - 230 Continue - 220 Continue - End If - 210 Continue - 200 Continue -#ifdef _DEBUGPRINT_ - Call RecPrt('Assg2: g2 full',' ',g2,1,78) -#endif -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/assg2.F90 openmolcas-22.10/src/rys_util/assg2.F90 --- openmolcas-22.02/src/rys_util/assg2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/assg2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,176 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine Assg2(g2,nT,nRys,la,lb,lc,ld,xyz2D0,xyz2D1,xyz2D2,IfHss,Index1,Index2,ng,nh,PAO) +!*********************************************************************** +! * +! Object: to assemble the gradients of the ERI's. * +! * +! Author: Anders Bernhardsson * +! Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! March '95 * +!*********************************************************************** + +use Index_Functions, only: C_Ind3_Rev, nTri_Elem, nTri_Elem1 +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +real(kind=wp), intent(out) :: g2(78) +integer(kind=iwp), intent(in) :: nT, nRys, la, lb, lc, ld, Index1(3,3), Index2(2,6,3), ng(3), nh(3) +real(kind=wp), intent(in) :: xyz2D0(nRys,nT,0:la+2,0:lb+2,0:lc+2,0:ld+2,3), xyz2D1(nRys,nT,0:la,0:lb,0:lc,0:ld,9), & + xyz2D2(nRys,nT,0:la,0:lb,0:lc,0:ld,18), & + PAO(nT,nTri_Elem1(la),nTri_Elem1(lb),nTri_Elem1(lc),nTri_Elem1(ld)) +logical(kind=iwp), intent(in) :: IfHss(4,3,4,3) +#include "itmax.fh" +integer(kind=iwp) :: I, ia1, ia2, ia3, ib1, ib2, ib3, ic1, ic2, ic3, iCar, iCent, icir(3), id1, id2, id3, iDer, ipa, ipb, ipc, & + ipd, iRys, it, ix1, ix2, jCar, jCent, jDer, kCar +real(kind=wp) :: tmp + +!define _DEBUGPRINT_ +!iRout = 248 +!iPrint = nPrint(iRout) +g2(:) = Zero +#ifdef _DEBUGPRINT_ +call RecPrt('Assg2: g2(0)',' ',g2,1,78) +#endif +kCar = 0 ! dummy initialize + +! First we construct the non diagonal derivatives + +do iCar=1,3 + do jCar=1,3 + + ! Determine the permutation of the cartesian indices + + if (jCar == iCar) cycle + if (iCar*jCar == 2) Kcar = 3 + if (iCar*jCar == 6) kCar = 1 + if (iCar*jCar == 3) KCar = 2 + + ! Loop over the atomic centre, in order + ! that the integrals are calculated in. + + do iDer=1,ng(iCar) + do jDer=1,ng(jCar) + iCent = Index1(iDer,iCar) + jCent = Index1(jDer,jCar) + + if (IfHss(iCent,iCar,jCent,jCar)) then + I = nTri_Elem((iCent-1)*3+iCar-1)+(jCent-1)*3+jCar + ix1 = (iDer-1)*3+iCar + ix2 = (jDer-1)*3+jCar + + ! Loop over angular momentas + + do ipd=1,nTri_Elem1(ld) + icir(:) = C_Ind3_Rev(ipd,ld) + id1 = icir(iCar) + id2 = icir(jCar) + id3 = icir(kCar) + do ipc=1,nTri_Elem1(lc) + icir(:) = C_Ind3_Rev(ipc,lc) + ic1 = icir(iCar) + ic2 = icir(jCar) + ic3 = icir(kCar) + do ipb=1,nTri_Elem1(lb) + icir(:) = C_Ind3_Rev(ipb,lb) + ib1 = icir(iCar) + ib2 = icir(jCar) + ib3 = icir(kCar) + do ipa=1,nTri_Elem1(la) + icir(:) = C_Ind3_Rev(ipa,la) + ia1 = icir(iCar) + ia2 = icir(jCar) + ia3 = icir(kCar) + + ! Loop over Rys-polynomia and exponents of the basis set! + + tmp = Zero + do it=1,nt + do iRys=1,nRys + tmp = tmp+PAO(iT,ipa,ipb,ipc,ipd)*xyz2D0(iRys,iT,ia3,ib3,ic3,id3,kCar)*xyz2D1(iRys,iT,ia1,ib1,ic1,id1,ix1)* & + xyz2D1(iRys,iT,ia2,ib2,ic2,id2,ix2) + end do + end do + g2(I) = g2(I)+tmp + end do + end do + end do + end do + end if + end do + end do + end do +end do +#ifdef _DEBUGPRINT_ +call RecPrt('Assg2: g2 non-diagonal',' ',g2,1,78) +#endif + +! Then construct the diagonal derivatives + +do iCar=1,3 + jCar = mod(iCar,3)+1 + kCar = mod(jCar,3)+1 + do iDer=1,nh(iCar) + ix1 = (iDer-1)*3+iCar + iCent = Index2(1,iDer,iCar) + jCent = Index2(2,iDer,iCar) + if (IfHss(iCent,iCar,jCent,iCar)) then + I = nTri_Elem((iCent-1)*3+iCar-1)+(jCent-1)*3+iCar + + do ipd=1,nTri_Elem1(ld) + icir(:) = C_Ind3_Rev(ipd,ld) + id1 = icir(iCar) + id2 = icir(jCar) + id3 = icir(kCar) + do ipc=1,nTri_Elem1(lc) + icir(:) = C_Ind3_Rev(ipc,lc) + ic1 = icir(iCar) + ic2 = icir(jCar) + ic3 = icir(kCar) + do ipb=1,nTri_Elem1(lb) + icir(:) = C_Ind3_Rev(ipb,lb) + ib1 = icir(iCar) + ib2 = icir(jCar) + ib3 = icir(kCar) + do ipa=1,nTri_Elem1(la) + icir(:) = C_Ind3_Rev(ipa,la) + ia1 = icir(iCar) + ia2 = icir(jCar) + ia3 = icir(kCar) + + tmp = Zero + do it=1,nt + do iRys=1,nRys + tmp = tmp+PAO(iT,ipa,ipb,ipc,ipd)*xyz2D0(iRys,iT,ia2,ib2,ic2,id2,jCar)*xyz2D0(iRys,iT,ia3,ib3,ic3,id3,kCar)* & + xyz2D2(iRys,iT,ia1,ib1,ic1,id1,ix1) + end do + end do + g2(I) = g2(I)+tmp + + end do + end do + end do + end do + end if + end do +end do +#ifdef _DEBUGPRINT_ +call RecPrt('Assg2: g2 full',' ',g2,1,78) +#endif + +return + +end subroutine Assg2 diff -Nru openmolcas-22.02/src/rys_util/cff2d.f openmolcas-22.10/src/rys_util/cff2d.f --- openmolcas-22.02/src/rys_util/cff2d.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/cff2d.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,248 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Cff2D(nabMax,ncdMax,nRys, - & Zeta,ZInv,Eta,EInv,nT, - & Coori,CoorAC,P,Q, - & la,lb,lc,ld, - & U2,PAQP,QCPQ,B10,B00,lac,B01) -************************************************************************ -* * -* Object: to compute the coefficients in the three terms recurrence * -* relation of the 2D-integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* Modified loop structure for RISC 1991 R. Lindh, Dept. of Theoretical * -* Chemistry, University of Lund, Sweden. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - Real*8 Zeta(nT), ZInv(nT), Eta(nT), EInv(nT), - & Coori(3,4), CoorAC(3,2), - & P(nT,3), Q(nT,3), U2(nRys,nT), - & PAQP(nRys,nT,3), QCPQ(nRys,nT,3), - & B10(nRys,nT,3), - & B00(nRys,nT,3), - & B01(nRys,nT,3) -*define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ -* Local arrays - Character*30 Label -#endif - Logical AeqB, CeqD, EQ -* -#ifdef _DEBUGPRINT_ - Call RecPrt(' In vCff2D: Coori',' ',Coori,3,4) - Call RecPrt(' In vCff2D: U2',' ',U2,nRys,nT) -#endif - AeqB = EQ(Coori(1,1),Coori(1,2)) - CeqD = EQ(Coori(1,3),Coori(1,4)) -* - h12 = Half - If (nabMax.ne.0 .and. ncdMax.ne.0) Then - Do iT = 1, nT - Do iRys = 1, nRys - B00(iRys,iT,1) = (h12 * U2(iRys,iT)) - B10(iRys,iT,1) = ( h12 - - & (h12 * U2(iRys,iT)) * - & Eta(iT))*ZInv(iT) - B01(iRys,iT,1) = ( h12 - - & (h12 * U2(iRys,iT)) * - & Zeta(iT))*EInv(iT) - End Do - End Do - Else If (ncdMax.eq.0 .and. nabMax.ne.0 .and. lac.eq.0) Then - Do iT = 1, nT - Do iRys = 1, nRys - B10(iRys,iT,1) = ( h12 - - & h12 * U2(iRys,iT) * Eta(iT))*ZInv(iT) - End Do - End Do - Else If (nabMax.eq.0 .and. ncdMax.ne.0 .and. lac.eq.0) Then - Do iT = 1, nT - Do iRys = 1, nRys - B01(iRys,iT,1) = ( h12 - - & h12 * U2(iRys,iT) * Zeta(iT))*EInv(iT) - End Do - End Do - Else If (ncdMax.eq.0 .and. nabMax.ne.0) Then - Do iT = 1, nT - Do iRys = 1, nRys - B00(iRys,iT,1) = (h12 * U2(iRys,iT)) - B10(iRys,iT,1) = ( h12 - - & (h12 * U2(iRys,iT)) * Eta(iT))*ZInv(iT) - End Do - End Do - Else If (nabMax.eq.0 .and. ncdMax.ne.0) Then - Do iT = 1, nT - Do iRys = 1, nRys - B00(iRys,iT,1) = (h12 * U2(iRys,iT)) - B01(iRys,iT,1) = ( h12 - - & (h12 * U2(iRys,iT)) * Zeta(iT))*EInv(iT) - End Do - End Do - Else If (nabMax.eq.0 .and. ncdMax.eq.0 .and. lac.ne.0) Then - Call DYaX(nRys*nT,h12,U2(1,1),1,B00(1,1,1),1) - End If - If (nabMax.ne.0) Then - call dcopy_(nRys*nT,B10(1,1,1),1,B10(1,1,2),1) - call dcopy_(nRys*nT,B10(1,1,1),1,B10(1,1,3),1) - End If - If (lac.ne.0) Then - call dcopy_(nRys*nT,B00(1,1,1),1,B00(1,1,2),1) - call dcopy_(nRys*nT,B00(1,1,1),1,B00(1,1,3),1) - End If - If (ncdMax.ne.0) Then - call dcopy_(nRys*nT,B01(1,1,1),1,B01(1,1,2),1) - call dcopy_(nRys*nT,B01(1,1,1),1,B01(1,1,3),1) - End If -* - If (la+lb.ne.0 .and. lc+ld.ne.0) Then - If (.Not.AeqB .and. .Not.CeqD) Then - Do 100 iCar = 1, 3 - Do iT = 1, nT - Do iRys = 1, nRys - PAQP(iRys,iT,iCar) = - & P(iT,iCar) - CoorAC(iCar,1) + Eta(iT) - & * (U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar))) - QCPQ(iRys,iT,iCar) = - & Q(iT,iCar) - CoorAC(iCar,2) - Zeta(iT) - & * (U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar))) - End Do - End Do - 100 Continue - Else If (AeqB .and. .Not.CeqD) Then - Do 200 iCar = 1, 3 - Do iT = 1, nT - Do iRys = 1, nRys - PAQP(iRys,iT,iCar) = Eta(iT) - & * (U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar))) - QCPQ(iRys,iT,iCar) = - & Q(iT,iCar) - CoorAC(iCar,2) - Zeta(iT) - & * (U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar))) - End Do - End Do - 200 Continue - Else If (.Not.AeqB .and. CeqD) Then - Do 300 iCar = 1, 3 - Do iT = 1, nT - Do iRys = 1, nRys - PAQP(iRys,iT,iCar) = - & P(iT,iCar) - CoorAC(iCar,1) + Eta(iT) - & * (U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar))) - QCPQ(iRys,iT,iCar) = - Zeta(iT) - & * (U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar))) - End Do - End Do - 300 Continue - Else - Do 400 iCar = 1, 3 - Do iT = 1, nT - Do iRys = 1, nRys - PAQP(iRys,iT,iCar) = Eta(iT) - & * (U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar))) - QCPQ(iRys,iT,iCar) = - Zeta(iT) - & * (U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar))) - End Do - End Do - 400 Continue - End If - Else If (la+lb.ne.0) Then - If (.Not.AeqB) Then - Do 101 iCar = 1, 3 - Do iT = 1, nT - Do iRys = 1, nRys - PAQP(iRys,iT,iCar) = P(iT,iCar) - CoorAC(iCar,1) + - & Eta(iT) * U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar)) - End Do - End Do - 101 Continue - Else - Do 201 iCar = 1, 3 - Do iT = 1, nT - Do iRys = 1, nRys - PAQP(iRys,iT,iCar) = - & Eta(iT) * U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar)) - End Do - End Do - 201 Continue - End If - Else If (lc+ld.ne.0) Then - If (.Not.CeqD) Then - Do 102 iCar = 1, 3 - Do iT = 1, nT - Do iRys = 1, nRys - QCPQ(iRys,iT,iCar) = - & Q(iT,iCar) - CoorAC(iCar,2) + - & Zeta(iT) * U2(iRys,iT) * (P(iT,iCar)-Q(iT,iCar)) - End Do - End Do - 102 Continue - Else - Do 202 iCar = 1, 3 - Do iT = 1, nT - Do iRys = 1, nRys - QCPQ(iRys,iT,iCar) = - & Zeta(iT) * U2(iRys,iT) * (P(iT,iCar)-Q(iT,iCar)) - End Do - End Do - 202 Continue - End If - End If -#ifdef _DEBUGPRINT_ - If (la+lb.gt.0) Then - Write (Label,'(A)') ' PAQP(x)' - Call RecPrt(Label,' ',PAQP(1,1,1),nRys,nT) - Write (Label,'(A)') ' PAQP(y)' - Call RecPrt(Label,' ',PAQP(1,1,2),nRys,nT) - Write (Label,'(A)') ' PAQP(z)' - Call RecPrt(Label,' ',PAQP(1,1,3),nRys,nT) - End If - If (lc+ld.gt.0) Then - Write (Label,'(A)') ' QCPQ(x)' - Call RecPrt(Label,' ',QCPQ(1,1,1),nRys,nT) - Write (Label,'(A)') ' QCPQ(y)' - Call RecPrt(Label,' ',QCPQ(1,1,2),nRys,nT) - Write (Label,'(A)') ' QCPQ(z)' - Call RecPrt(Label,' ',QCPQ(1,1,3),nRys,nT) - End If - If (nabMax.ne.0) Then - Write (Label,'(A)') ' B10(x)' - Call RecPrt(Label,' ',B10(1,1,1),nRys,nT) - Write (Label,'(A)') ' B10(y)' - Call RecPrt(Label,' ',B10(1,1,2),nRys,nT) - Write (Label,'(A)') ' B10(z)' - Call RecPrt(Label,' ',B10(1,1,3),nRys,nT) - End If - If (lac.ne.0) Then - Write (Label,'(A)') ' B00(x)' - Call RecPrt(Label,' ',B00(1,1,1),nRys,nT) - Write (Label,'(A)') ' B00(y)' - Call RecPrt(Label,' ',B00(1,1,2),nRys,nT) - Write (Label,'(A)') ' B00(z)' - Call RecPrt(Label,' ',B00(1,1,3),nRys,nT) - End If - If (ncdMax.ne.0) Then - Write (Label,'(A)') ' B01(x)' - Call RecPrt(Label,' ',B01(1,1,1),nRys,nT) - Write (Label,'(A)') ' B01(y)' - Call RecPrt(Label,' ',B01(1,1,2),nRys,nT) - Write (Label,'(A)') ' B01(z)' - Call RecPrt(Label,' ',B01(1,1,3),nRys,nT) - End If -#endif - Return - End diff -Nru openmolcas-22.02/src/rys_util/cff2d.F90 openmolcas-22.10/src/rys_util/cff2d.F90 --- openmolcas-22.02/src/rys_util/cff2d.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/cff2d.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,177 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Cff2D(nabMax,ncdMax,nRys,Zeta,ZInv,Eta,EInv,nT,Coori,CoorAC,P,Q,la,lb,lc,ld,U2,PAQP,QCPQ,B10,B00,lac,B01) +!*********************************************************************** +! * +! Object: to compute the coefficients in the three terms recurrence * +! relation of the 2D-integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! Modified loop structure for RISC 1991 R. Lindh, Dept. of Theoretical * +! Chemistry, University of Lund, Sweden. * +!*********************************************************************** + +use Constants, only: Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nabMax, ncdMax, nRys, nT, la, lb, lc, ld, lac +real(kind=wp), intent(in) :: Zeta(nT), ZInv(nT), Eta(nT), EInv(nT), Coori(3,4), CoorAC(3,2), P(nT,3), Q(nT,3), U2(nRys,nT) +real(kind=wp), intent(inout) :: PAQP(nRys,nT,3), QCPQ(nRys,nT,3), B10(nRys,nT,3), B00(nRys,nT,3), B01(nRys,nT,3) +integer(kind=iwp) :: iCar, iT +real(kind=wp) :: h12 +logical(kind=iwp) :: AeqB, CeqD, EQ + +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +call RecPrt(' In Cff2D: Coori',' ',Coori,3,4) +call RecPrt(' In Cff2D: U2',' ',U2,nRys,nT) +#endif +AeqB = EQ(Coori(1,1),Coori(1,2)) +CeqD = EQ(Coori(1,3),Coori(1,4)) + +h12 = Half +if ((nabMax /= 0) .and. (ncdMax /= 0)) then + B00(:,:,1) = h12*U2(:,:) + do iT=1,nT + B10(:,iT,1) = (h12-h12*U2(:,iT)*Eta(iT))*ZInv(iT) + B01(:,iT,1) = (h12-h12*U2(:,iT)*Zeta(iT))*EInv(iT) + end do +else if ((ncdMax == 0) .and. (nabMax /= 0) .and. (lac == 0)) then + do iT=1,nT + B10(:,iT,1) = (h12-h12*U2(:,iT)*Eta(iT))*ZInv(iT) + end do +else if ((nabMax == 0) .and. (ncdMax /= 0) .and. (lac == 0)) then + do iT=1,nT + B01(:,iT,1) = (h12-h12*U2(:,iT)*Zeta(iT))*EInv(iT) + end do +else if ((ncdMax == 0) .and. (nabMax /= 0)) then + B00(:,:,1) = h12*U2(:,:) + do iT=1,nT + B10(:,iT,1) = (h12-h12*U2(:,iT)*Eta(iT))*ZInv(iT) + end do +else if ((nabMax == 0) .and. (ncdMax /= 0)) then + B00(:,:,1) = h12*U2(:,:) + do iT=1,nT + B01(:,iT,1) = (h12-h12*U2(:,iT)*Zeta(iT))*EInv(iT) + end do +else if ((nabMax == 0) .and. (ncdMax == 0) .and. (lac /= 0)) then + B00(:,:,1) = h12*U2(:,:) +end if +if (nabMax /= 0) then + B10(:,:,2) = B10(:,:,1) + B10(:,:,3) = B10(:,:,1) +end if +if (lac /= 0) then + B00(:,:,2) = B00(:,:,1) + B00(:,:,3) = B00(:,:,1) +end if +if (ncdMax /= 0) then + B01(:,:,2) = B01(:,:,1) + B01(:,:,3) = B01(:,:,1) +end if + +if ((la+lb /= 0) .and. (lc+ld /= 0)) then + if ((.not. AeqB) .and. (.not. CeqD)) then + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = P(iT,iCar)-CoorAC(iCar,1)+Eta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + QCPQ(:,iT,iCar) = Q(iT,iCar)-CoorAC(iCar,2)-Zeta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + end do + end do + else if (AeqB .and. (.not. CeqD)) then + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = Eta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + QCPQ(:,iT,iCar) = Q(iT,iCar)-CoorAC(iCar,2)-Zeta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + end do + end do + else if ((.not. AeqB) .and. CeqD) then + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = P(iT,iCar)-CoorAC(iCar,1)+Eta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + QCPQ(:,iT,iCar) = -Zeta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + end do + end do + else + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = Eta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + QCPQ(:,iT,iCar) = -Zeta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + end do + end do + end if +else if (la+lb /= 0) then + if (.not. AeqB) then + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = P(iT,iCar)-CoorAC(iCar,1)+Eta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + end do + end do + else + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = Eta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + end do + end do + end if +else if (lc+ld /= 0) then + if (.not. CeqD) then + do iCar=1,3 + do iT=1,nT + QCPQ(:,iT,iCar) = Q(iT,iCar)-CoorAC(iCar,2)+Zeta(iT)*U2(:,iT)*(P(iT,iCar)-Q(iT,iCar)) + end do + end do + else + do iCar=1,3 + do iT=1,nT + QCPQ(:,iT,iCar) = Zeta(iT)*U2(:,iT)*(P(iT,iCar)-Q(iT,iCar)) + end do + end do + end if +end if +#ifdef _DEBUGPRINT_ +if (la+lb > 0) then + call RecPrt(' PAQP(x)',' ',PAQP(:,:,1),nRys,nT) + call RecPrt(' PAQP(y)',' ',PAQP(:,:,2),nRys,nT) + call RecPrt(' PAQP(z)',' ',PAQP(:,:,3),nRys,nT) +end if +if (lc+ld > 0) then + call RecPrt(' QCPQ(x)',' ',QCPQ(:,:,1),nRys,nT) + call RecPrt(' QCPQ(y)',' ',QCPQ(:,:,2),nRys,nT) + call RecPrt(' QCPQ(z)',' ',QCPQ(:,:,3),nRys,nT) +end if +if (nabMax /= 0) then + call RecPrt(' B10(x)',' ',B10(:,:,1),nRys,nT) + call RecPrt(' B10(y)',' ',B10(:,:,2),nRys,nT) + call RecPrt(' B10(z)',' ',B10(:,:,3),nRys,nT) +end if +if (lac /= 0) then + call RecPrt(' B00(x)',' ',B00(:,:,1),nRys,nT) + call RecPrt(' B00(y)',' ',B00(:,:,2),nRys,nT) + call RecPrt(' B00(z)',' ',B00(:,:,3),nRys,nT) +end if +if (ncdMax /= 0) then + call RecPrt(' B01(x)',' ',B01(:,:,1),nRys,nT) + call RecPrt(' B01(y)',' ',B01(:,:,2),nRys,nT) + call RecPrt(' B01(z)',' ',B01(:,:,3),nRys,nT) +end if +#endif + +return + +end subroutine Cff2D diff -Nru openmolcas-22.02/src/rys_util/cff2dq.f openmolcas-22.10/src/rys_util/cff2dq.f --- openmolcas-22.02/src/rys_util/cff2dq.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/cff2dq.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,202 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990-1992, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Cff2Dq(nabMax,ncdMax,nRys, - & Zeta,ZInv,Eta,EInv,nT, - & Coori,CoorAC,P,Q,la,lb,lc,ld, - & U2,PAQP,QCPQ,B10,B00,lac,B01) -************************************************************************ -* * -* Object: to compute the coefficients in the three terms recurrence * -* relation of the 2D-integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* Modified loop structure for RISC 1991 R. Lindh, Dept. of Theoretical * -* Chemistry, University of Lund, Sweden. * -* May '92. Modified for 2nd order differentiation needed * -* for the evaluation of the gradient estimates. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - Real*8 Zeta(nT), ZInv(nT), Eta(nT), EInv(nT), - & Coori(3,4), CoorAC(3,2), - & P(nT,3), Q(nT,3), U2(nRys,nT), - & PAQP(nRys,nT,3), QCPQ(nRys,nT,3), - & B10(nRys,nT,3), - & B00(nRys,nT,3), - & B01(nRys,nT,3) -* Local arrays - Logical AeqB, CeqD, EQ -*define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ -* Local arrays - Character*30 Label - Call RecPrt(' In Cff2dq: Coori',' ',Coori,3,4) - Call RecPrt(' In Cff2dq: U2',' ',U2,nRys,nT) -#endif - AeqB = EQ(Coori(1,1),Coori(1,2)) - CeqD = EQ(Coori(1,3),Coori(1,4)) -* - h12 = Half - If (nabMax.ne.0 .and. ncdMax.ne.0) Then - Do iT = 1, nT - Do iRys = 1, nRys - B00(iRys,iT,1) = (h12 * U2(iRys,iT)) - B10(iRys,iT,1) = ( h12 - - & (h12 * U2(iRys,iT)) * - & Eta(iT))*ZInv(iT) - B01(iRys,iT,1) = ( h12 - - & (h12 * U2(iRys,iT)) * - & Zeta(iT))*EInv(iT) - End Do - End Do - Else If (ncdMax.eq.0 .and. nabMax.ne.0 .and. lac.eq.0) Then - Call WarningMessage(2,' Cff2dq: You should not be here!') - Call Abend() - Else If (nabMax.eq.0 .and. ncdMax.ne.0 .and. lac.eq.0) Then - Call WarningMessage(2,' Cff2dq: You should not be here!') - Call Abend() - Else If (ncdMax.eq.0 .and. nabMax.ne.0) Then - Call WarningMessage(2,' Cff2dq: You should not be here!') - Call Abend() - Else If (nabMax.eq.0 .and. ncdMax.ne.0) Then - Call WarningMessage(2,' Cff2dq: You should not be here!') - Call Abend() - Else If (nabMax.eq.0 .and. ncdMax.eq.0 .and. lac.ne.0) Then - Call DYaX(nRys*nT,h12,U2(1,1),1,B00(1,1,1),1) - End If - If (nabMax.ne.0) Then - call dcopy_(nRys*nT,B10(1,1,1),1,B10(1,1,2),1) - call dcopy_(nRys*nT,B10(1,1,1),1,B10(1,1,3),1) - End If - If (lac.ne.0) Then - call dcopy_(nRys*nT,B00(1,1,1),1,B00(1,1,2),1) - call dcopy_(nRys*nT,B00(1,1,1),1,B00(1,1,3),1) - End If - If (ncdMax.ne.0) Then - call dcopy_(nRys*nT,B01(1,1,1),1,B01(1,1,2),1) - call dcopy_(nRys*nT,B01(1,1,1),1,B01(1,1,3),1) - End If -* - If (la+lb.ne.0 .and. lc+ld.ne.0) Then - If (.Not.AeqB .and. .Not.CeqD) Then - Do 100 iCar = 1, 3 - Do 110 iT = 1, nT - Do 130 iRys = 1, nRys - PAQP(iRys,iT,iCar) = - & P(iT,iCar) - CoorAC(iCar,1) + Eta(iT) - & * (U2(iRys,iT) - & * (Q(iT,iCar)-P(iT,iCar))) - QCPQ(iRys,iT,iCar) = - & Q(iT,iCar) - CoorAC(iCar,2) - Zeta(iT) - & * (U2(iRys,iT) - & * (Q(iT,iCar)-P(iT,iCar))) - 130 Continue - 110 Continue - 100 Continue - Else If (AeqB .and. .Not.CeqD) Then - Do 200 iCar = 1, 3 - Do 210 iT = 1, nT - Do 230 iRys = 1, nRys - PAQP(iRys,iT,iCar) = Eta(iT) - & * (U2(iRys,iT) - & * (Q(iT,iCar)-P(iT,iCar))) - QCPQ(iRys,iT,iCar) = - & Q(iT,iCar) - CoorAC(iCar,2) - - & Zeta(iT) * (U2(iRys,iT) - & * (Q(iT,iCar)-P(iT,iCar))) - 230 Continue - 210 Continue - 200 Continue - Else If (.Not.AeqB .and. CeqD) Then - Do 300 iCar = 1, 3 - Do 310 iT = 1, nT - Do 330 iRys = 1, nRys - PAQP(iRys,iT,iCar) = - & P(iT,iCar) - CoorAC(iCar,1) + - & Eta(iT) * (U2(iRys,iT) - & * (Q(iT,iCar)-P(iT,iCar))) - QCPQ(iRys,iT,iCar) = - - & Zeta(iT) * (U2(iRys,iT) - & * (Q(iT,iCar)-P(iT,iCar))) - 330 Continue - 310 Continue - 300 Continue - Else - Do 400 iCar = 1, 3 - Do 410 iT = 1, nT - Do 430 iRys = 1, nRys - PAQP(iRys,iT,iCar) = - & Eta(iT) * (U2(iRys,iT) - & * (Q(iT,iCar)-P(iT,iCar))) - QCPQ(iRys,iT,iCar) = - - & Zeta(iT) * (U2(iRys,iT) - & * (Q(iT,iCar)-P(iT,iCar))) - 430 Continue - 410 Continue - 400 Continue - End If - Else If (la+lb.ne.0) Then - Call WarningMessage(2,' Cff2dq: You should not be here!') - Call Abend() - Else If (lc+ld.ne.0) Then - Call WarningMessage(2,' Cff2dq: You should not be here!') - Call Abend() - End If -#ifdef _DEBUGPRINT_ - If (la+lb.gt.0) Then - Write (Label,'(A)') ' PAQP(x)' - Call RecPrt(Label,' ',PAQP(1,1,1),nRys,nT) - Write (Label,'(A)') ' PAQP(y)' - Call RecPrt(Label,' ',PAQP(1,1,2),nRys,nT) - Write (Label,'(A)') ' PAQP(z)' - Call RecPrt(Label,' ',PAQP(1,1,3),nRys,nT) - End If - If (lc+ld.gt.0) Then - Write (Label,'(A)') ' QCPQ(x)' - Call RecPrt(Label,' ',QCPQ(1,1,1),nRys,nT) - Write (Label,'(A)') ' QCPQ(y)' - Call RecPrt(Label,' ',QCPQ(1,1,2),nRys,nT) - Write (Label,'(A)') ' QCPQ(z)' - Call RecPrt(Label,' ',QCPQ(1,1,3),nRys,nT) - End If - If (nabMax.ne.0) Then - Write (Label,'(A)') ' B10(x)' - Call RecPrt(Label,' ',B10(1,1,1),nRys,nT) - Write (Label,'(A)') ' B10(y)' - Call RecPrt(Label,' ',B10(1,1,2),nRys,nT) - Write (Label,'(A)') ' B10(z)' - Call RecPrt(Label,' ',B10(1,1,3),nRys,nT) - End If - If (lac.ne.0) Then - Write (Label,'(A)') ' B00(x)' - Call RecPrt(Label,' ',B00(1,1,1),nRys,nT) - Write (Label,'(A)') ' B00(y)' - Call RecPrt(Label,' ',B00(1,1,2),nRys,nT) - Write (Label,'(A)') ' B00(z)' - Call RecPrt(Label,' ',B00(1,1,3),nRys,nT) - End If - If (ncdMax.ne.0) Then - Write (Label,'(A)') ' B01(x)' - Call RecPrt(Label,' ',B01(1,1,1),nRys,nT) - Write (Label,'(A)') ' B01(y)' - Call RecPrt(Label,' ',B01(1,1,2),nRys,nT) - Write (Label,'(A)') ' B01(z)' - Call RecPrt(Label,' ',B01(1,1,3),nRys,nT) - End If -#endif - Return - End diff -Nru openmolcas-22.02/src/rys_util/cff2dq.F90 openmolcas-22.10/src/rys_util/cff2dq.F90 --- openmolcas-22.02/src/rys_util/cff2dq.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/cff2dq.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,151 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990-1992, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Cff2Dq(nabMax,ncdMax,nRys,Zeta,ZInv,Eta,EInv,nT,Coori,CoorAC,P,Q,la,lb,lc,ld,U2,PAQP,QCPQ,B10,B00,lac,B01) +!*********************************************************************** +! * +! Object: to compute the coefficients in the three terms recurrence * +! relation of the 2D-integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! Modified loop structure for RISC 1991 R. Lindh, Dept. of Theoretical * +! Chemistry, University of Lund, Sweden. * +! May '92. Modified for 2nd order differentiation needed * +! for the evaluation of the gradient estimates. * +!*********************************************************************** + +use Constants, only: Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nabMax, ncdMax, nRys, nT, la, lb, lc, ld, lac +real(kind=wp), intent(in) :: Zeta(nT), ZInv(nT), Eta(nT), EInv(nT), Coori(3,4), CoorAC(3,2), P(nT,3), Q(nT,3), U2(nRys,nT) +real(kind=wp), intent(inout) :: PAQP(nRys,nT,3), QCPQ(nRys,nT,3), B10(nRys,nT,3), B00(nRys,nT,3), B01(nRys,nT,3) +integer(kind=iwp) :: iCar, iT +real(kind=wp) :: h12 +logical(kind=iwp) :: AeqB, CeqD, EQ + +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +call RecPrt(' In Cff2dq: Coori',' ',Coori,3,4) +call RecPrt(' In Cff2dq: U2',' ',U2,nRys,nT) +#endif +AeqB = EQ(Coori(1,1),Coori(1,2)) +CeqD = EQ(Coori(1,3),Coori(1,4)) + +h12 = Half +if ((nabMax /= 0) .and. (ncdMax /= 0)) then + B00(:,:,1) = h12*U2(:,:) + do iT=1,nT + B10(:,iT,1) = (h12-h12*U2(:,iT)*Eta(iT))*ZInv(iT) + B01(:,iT,1) = (h12-h12*U2(:,iT)*Zeta(iT))*EInv(iT) + end do +else if ((ncdMax == 0) .and. (nabMax /= 0) .and. (lac == 0)) then + call WarningMessage(2,' Cff2dq: You should not be here!') + call Abend() +else if ((nabMax == 0) .and. (ncdMax /= 0) .and. (lac == 0)) then + call WarningMessage(2,' Cff2dq: You should not be here!') + call Abend() +else if ((ncdMax == 0) .and. (nabMax /= 0)) then + call WarningMessage(2,' Cff2dq: You should not be here!') + call Abend() +else if ((nabMax == 0) .and. (ncdMax /= 0)) then + call WarningMessage(2,' Cff2dq: You should not be here!') + call Abend() +else if ((nabMax == 0) .and. (ncdMax == 0) .and. (lac /= 0)) then + B00(:,:,1) = h12*U2(:,:) +end if +if (nabMax /= 0) then + B10(:,:,2) = B10(:,:,1) + B10(:,:,3) = B10(:,:,1) +end if +if (lac /= 0) then + B00(:,:,2) = B00(:,:,1) + B00(:,:,3) = B00(:,:,1) +end if +if (ncdMax /= 0) then + B01(:,:,2) = B01(:,:,1) + B01(:,:,3) = B01(:,:,1) +end if + +if ((la+lb /= 0) .and. (lc+ld /= 0)) then + if ((.not. AeqB) .and. (.not. CeqD)) then + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = P(iT,iCar)-CoorAC(iCar,1)+Eta(iT)*(U2(:,iT)*(Q(iT,iCar)-P(iT,iCar))) + QCPQ(:,iT,iCar) = Q(iT,iCar)-CoorAC(iCar,2)-Zeta(iT)*(U2(:,iT)*(Q(iT,iCar)-P(iT,iCar))) + end do + end do + else if (AeqB .and. (.not. CeqD)) then + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = Eta(iT)*(U2(:,iT)*(Q(iT,iCar)-P(iT,iCar))) + QCPQ(:,iT,iCar) = Q(iT,iCar)-CoorAC(iCar,2)-Zeta(iT)*(U2(:,iT)*(Q(iT,iCar)-P(iT,iCar))) + end do + end do + else if ((.not. AeqB) .and. CeqD) then + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = P(iT,iCar)-CoorAC(iCar,1)+Eta(iT)*(U2(:,iT)*(Q(iT,iCar)-P(iT,iCar))) + QCPQ(:,iT,iCar) = -Zeta(iT)*(U2(:,iT)*(Q(iT,iCar)-P(iT,iCar))) + end do + end do + else + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = Eta(iT)*(U2(:,iT)*(Q(iT,iCar)-P(iT,iCar))) + QCPQ(:,iT,iCar) = -Zeta(iT)*(U2(:,iT)*(Q(iT,iCar)-P(iT,iCar))) + end do + end do + end if +else if (la+lb /= 0) then + call WarningMessage(2,' Cff2dq: You should not be here!') + call Abend() +else if (lc+ld /= 0) then + call WarningMessage(2,' Cff2dq: You should not be here!') + call Abend() +end if +#ifdef _DEBUGPRINT_ +if (la+lb > 0) then + call RecPrt(' PAQP(x)',' ',PAQP(:,:,1),nRys,nT) + call RecPrt(' PAQP(y)',' ',PAQP(:,:,2),nRys,nT) + call RecPrt(' PAQP(z)',' ',PAQP(:,:,3),nRys,nT) +end if +if (lc+ld > 0) then + call RecPrt(' QCPQ(x)',' ',QCPQ(:,:,1),nRys,nT) + call RecPrt(' QCPQ(y)',' ',QCPQ(:,:,2),nRys,nT) + call RecPrt(' QCPQ(z)',' ',QCPQ(:,:,3),nRys,nT) +end if +if (nabMax /= 0) then + call RecPrt(' B10(x)',' ',B10(:,:,1),nRys,nT) + call RecPrt(' B10(y)',' ',B10(:,:,2),nRys,nT) + call RecPrt(' B10(z)',' ',B10(:,:,3),nRys,nT) +end if +if (lac /= 0) then + call RecPrt(' B00(x)',' ',B00(:,:,1),nRys,nT) + call RecPrt(' B00(y)',' ',B00(:,:,2),nRys,nT) + call RecPrt(' B00(z)',' ',B00(:,:,3),nRys,nT) +end if +if (ncdMax /= 0) then + call RecPrt(' B01(x)',' ',B01(:,:,1),nRys,nT) + call RecPrt(' B01(y)',' ',B01(:,:,2),nRys,nT) + call RecPrt(' B01(z)',' ',B01(:,:,3),nRys,nT) +end if +#endif + +return + +end subroutine Cff2Dq diff -Nru openmolcas-22.02/src/rys_util/cff2ds.f openmolcas-22.10/src/rys_util/cff2ds.f --- openmolcas-22.02/src/rys_util/cff2ds.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/cff2ds.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,174 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Cff2DS(nabMax,ncdMax,nRys, - & Zeta,ZInv,Eta,EInv,nT, - & Coori,CoorAC,P,Q, - & la,lb,lc,ld, - & U2,PAQP,QCPQ,B10,B00,lac,B01) -************************************************************************ -* * -* Object: to compute the coefficients in the three terms recurrence * -* relation of the 2D-integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March 1990 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - Real*8 Zeta(nT), ZInv(nT), Eta(nT), EInv(nT), - & Coori(3,4), CoorAC(3,2), - & P(nT,3), Q(nT,3), U2(nRys,nT), - & PAQP(nRys,nT,3), QCPQ(nRys,nT,3), - & B10(nRys,nT,3), - & B00(nRys,nT,3), - & B01(nRys,nT,3) -* Local arrays - Logical AeqB, CeqD, EQ -*define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Character*30 Label - Call RecPrt(' In Cff2Ds: Coori',' ',Coori,3,4) - Call RecPrt(' In Cff2Ds: U2',' ',U2,nRys,nT) -#endif - AeqB = EQ(Coori(1,1),Coori(1,2)) - CeqD = EQ(Coori(1,3),Coori(1,4)) -* - h12 = Half - If (nabMax.ne.0 .and. ncdMax.ne.0) Then - Do 10 iT = 1, nT - Do iRys = 1, nRys - B00(iRys,iT,1) = h12 * U2(iRys,iT) - B10(iRys,iT,1) = ( h12 - - & h12 * U2(iRys,iT) * Zeta(iT))*ZInv(iT) - B01(iRys,iT,1) = B10(iRys,iT,1) - End Do - 10 Continue - Else If (ncdMax.eq.0 .and. nabMax.ne.0 .and. lac.eq.0) Then - Call WarningMessage(2, - & 'Cff2DS: ncdMax.eq.0 .and. nabMax.ne.0 .and. lac.eq.0') - Write (6,*) 'ncdMax,nabMax,lac=',ncdMax,nabMax,lac - Call Abend() - Else If (nabMax.eq.0 .and. ncdMax.ne.0 .and. lac.eq.0) Then - Call WarningMessage(2, - & 'Cff2DS: nabMax.eq.0 .and. ncdMax.ne.0 .and. lac.eq.0') - Write (6,*) 'ncdMax,nabMax,lac=',ncdMax,nabMax,lac - Call Abend() - Else If (ncdMax.eq.0 .and. nabMax.ne.0) Then - Call WarningMessage(2, - & 'Cff2DS: ncdMax.eq.0 .and. nabMax.ne.0') - Write (6,*) 'ncdMax,nabMax,lac=',ncdMax,nabMax,lac - Call Abend() - Else If (nabMax.eq.0 .and. ncdMax.ne.0) Then - Call WarningMessage(2, - & 'Cff2DS: nabMax.eq.0 .and. ncdMax.ne.0') - Write (6,*) 'ncdMax,nabMax,lac=',ncdMax,nabMax,lac - Call Abend() - Else If (nabMax.eq.0 .and. ncdMax.eq.0 .and. lac.ne.0) Then - Call DYaX(nRys*nT,h12,U2(1,1),1,B00(1,1,1),1) - End If - If (nabMax.ne.0) Then - call dcopy_(nRys*nT,B10(1,1,1),1,B10(1,1,2),1) - call dcopy_(nRys*nT,B10(1,1,1),1,B10(1,1,3),1) - End If - If (lac.ne.0) Then - call dcopy_(nRys*nT,B00(1,1,1),1,B00(1,1,2),1) - call dcopy_(nRys*nT,B00(1,1,1),1,B00(1,1,3),1) - End If - If (ncdMax.ne.0) Then - call dcopy_(nRys*nT,B01(1,1,1),1,B01(1,1,2),1) - call dcopy_(nRys*nT,B01(1,1,1),1,B01(1,1,3),1) - End If -* - If (la+lb.ne.0 .and. lc+ld.ne.0) Then - If (.Not.AeqB .and. .Not.CeqD) Then - Do 100 iCar = 1, 3 - Do 110 iT = 1, nT - Do iRys = 1, nRys - PAQP(iRys,iT,iCar) = P(iT,iCar) - CoorAC(iCar,1) - QCPQ(iRys,iT,iCar) = PAQP(iRys,iT,iCar) - End Do - 110 Continue - 100 Continue - Else If (AeqB .and. .Not.CeqD) Then - Call WarningMessage(2,'Cff2DS: AeqB .and. .Not.CeqD') - Write (6,*) 'AeqB,CeqD=',AeqB,CeqD - Call Abend() - Else If (.Not.AeqB .and. CeqD) Then - Call WarningMessage(2,'Cff2DS: .Not.AeqB .and. CeqD') - Write (6,*) 'AeqB,CeqD=',AeqB,CeqD - Call Abend() - Else - call dcopy_(3*nRys*nT,[Zero],0,PAQP,1) - call dcopy_(3*nRys*nT,[Zero],0,QCPQ,1) - End If - Else If (la+lb.ne.0) Then - Call WarningMessage(2,'Cff2DS: la+lb.ne.0') - Write (6,*) 'la,lb=',la,lb - Call Abend() - Else If (lc+ld.ne.0) Then - Call WarningMessage(2,'Cff2DS: lc+ld.ne.0') - Write (6,*) 'lc,ld=',lc,ld - Call Abend() - End If -#ifdef _DEBUGPRINT_ - If (la+lb.gt.0) Then - Write (Label,'(A)') ' PAQP(x)' - Call RecPrt(Label,' ',PAQP(1,1,1),nRys,nT) - Write (Label,'(A)') ' PAQP(y)' - Call RecPrt(Label,' ',PAQP(1,1,2),nRys,nT) - Write (Label,'(A)') ' PAQP(z)' - Call RecPrt(Label,' ',PAQP(1,1,3),nRys,nT) - End If - If (lc+ld.gt.0) Then - Write (Label,'(A)') ' QCPQ(x)' - Call RecPrt(Label,' ',QCPQ(1,1,1),nRys,nT) - Write (Label,'(A)') ' QCPQ(y)' - Call RecPrt(Label,' ',QCPQ(1,1,2),nRys,nT) - Write (Label,'(A)') ' QCPQ(z)' - Call RecPrt(Label,' ',QCPQ(1,1,3),nRys,nT) - End If - If (nabMax.ne.0) Then - Write (Label,'(A)') ' B10(x)' - Call RecPrt(Label,' ',B10(1,1,1),nRys,nT) - Write (Label,'(A)') ' B10(y)' - Call RecPrt(Label,' ',B10(1,1,2),nRys,nT) - Write (Label,'(A)') ' B10(z)' - Call RecPrt(Label,' ',B10(1,1,3),nRys,nT) - End If - If (lac.ne.0) Then - Write (Label,'(A)') ' B00(x)' - Call RecPrt(Label,' ',B00(1,1,1),nRys,nT) - Write (Label,'(A)') ' B00(y)' - Call RecPrt(Label,' ',B00(1,1,2),nRys,nT) - Write (Label,'(A)') ' B00(z)' - Call RecPrt(Label,' ',B00(1,1,3),nRys,nT) - End If - If (ncdMax.ne.0) Then - Write (Label,'(A)') ' B01(x)' - Call RecPrt(Label,' ',B01(1,1,1),nRys,nT) - Write (Label,'(A)') ' B01(y)' - Call RecPrt(Label,' ',B01(1,1,2),nRys,nT) - Write (Label,'(A)') ' B01(z)' - Call RecPrt(Label,' ',B01(1,1,3),nRys,nT) - End If -#endif - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(EInv) - Call Unused_real_array(Eta) - Call Unused_real_array(Q) - End If - End diff -Nru openmolcas-22.02/src/rys_util/cff2ds.F90 openmolcas-22.10/src/rys_util/cff2ds.F90 --- openmolcas-22.02/src/rys_util/cff2ds.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/cff2ds.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,147 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Cff2DS(nabMax,ncdMax,nRys,Zeta,ZInv,Eta,EInv,nT,Coori,CoorAC,P,Q,la,lb,lc,ld,U2,PAQP,QCPQ,B10,B00,lac,B01) +!*********************************************************************** +! * +! Object: to compute the coefficients in the three terms recurrence * +! relation of the 2D-integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March 1990 * +!*********************************************************************** + +use Constants, only: Zero, Half +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: nabMax, ncdMax, nRys, nT, la, lb, lc, ld, lac +real(kind=wp), intent(in) :: Zeta(nT), ZInv(nT), Eta(nT), EInv(nT), Coori(3,4), CoorAC(3,2), P(nT,3), Q(nT,3), U2(nRys,nT) +real(kind=wp), intent(inout) :: PAQP(nRys,nT,3), QCPQ(nRys,nT,3), B10(nRys,nT,3), B00(nRys,nT,3), B01(nRys,nT,3) +integer(kind=iwp) :: iCar, iT +real(kind=wp) :: h12 +logical(kind=iwp) :: AeqB, CeqD, EQ + +#include "macros.fh" +unused_var(EInv) +unused_var(Eta) +unused_var(Q) + +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +call RecPrt(' In Cff2Ds: Coori',' ',Coori,3,4) +call RecPrt(' In Cff2Ds: U2',' ',U2,nRys,nT) +#endif +AeqB = EQ(Coori(1,1),Coori(1,2)) +CeqD = EQ(Coori(1,3),Coori(1,4)) + +h12 = Half +if ((nabMax /= 0) .and. (ncdMax /= 0)) then + B00(:,:,1) = h12*U2(:,:) + do iT=1,nT + B10(:,iT,1) = (h12-h12*U2(:,iT)*Zeta(iT))*ZInv(iT) + end do + B01(:,:,1) = B10(:,:,1) +else if ((ncdMax == 0) .and. (nabMax /= 0) .and. (lac == 0)) then + call WarningMessage(2,'Cff2DS: ncdMax == 0 .and. nabMax /= 0 .and. lac == 0') + write(u6,*) 'ncdMax,nabMax,lac=',ncdMax,nabMax,lac + call Abend() +else if ((nabMax == 0) .and. (ncdMax /= 0) .and. (lac == 0)) then + call WarningMessage(2,'Cff2DS: nabMax == 0 .and. ncdMax /= 0 .and. lac == 0') + write(u6,*) 'ncdMax,nabMax,lac=',ncdMax,nabMax,lac + call Abend() +else if ((ncdMax == 0) .and. (nabMax /= 0)) then + call WarningMessage(2,'Cff2DS: ncdMax == 0 .and. nabMax /= 0') + write(u6,*) 'ncdMax,nabMax,lac=',ncdMax,nabMax,lac + call Abend() +else if ((nabMax == 0) .and. (ncdMax /= 0)) then + call WarningMessage(2,'Cff2DS: nabMax == 0 .and. ncdMax /= 0') + write(u6,*) 'ncdMax,nabMax,lac=',ncdMax,nabMax,lac + call Abend() +else if ((nabMax == 0) .and. (ncdMax == 0) .and. (lac /= 0)) then + B00(:,:,1) = h12*U2(:,:) +end if +if (nabMax /= 0) then + B10(:,:,2) = B10(:,:,1) + B10(:,:,3) = B10(:,:,1) +end if +if (lac /= 0) then + B00(:,:,2) = B00(:,:,1) + B00(:,:,3) = B00(:,:,1) +end if +if (ncdMax /= 0) then + B01(:,:,2) = B01(:,:,1) + B01(:,:,3) = B01(:,:,1) +end if + +if ((la+lb /= 0) .and. (lc+ld /= 0)) then + if ((.not. AeqB) .and. (.not. CeqD)) then + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = P(iT,iCar)-CoorAC(iCar,1) + end do + end do + QCPQ(:,:,:) = PAQP(:,:,:) + else if (AeqB .and. (.not. CeqD)) then + call WarningMessage(2,'Cff2DS: AeqB .and. .not.CeqD') + write(u6,*) 'AeqB,CeqD=',AeqB,CeqD + call Abend() + else if ((.not. AeqB) .and. CeqD) then + call WarningMessage(2,'Cff2DS: .not.AeqB .and. CeqD') + write(u6,*) 'AeqB,CeqD=',AeqB,CeqD + call Abend() + else + PAQP(:,:,:) = Zero + QCPQ(:,:,:) = Zero + end if +else if (la+lb /= 0) then + call WarningMessage(2,'Cff2DS: la+lb /= 0') + write(u6,*) 'la,lb=',la,lb + call Abend() +else if (lc+ld /= 0) then + call WarningMessage(2,'Cff2DS: lc+ld /= 0') + write(u6,*) 'lc,ld=',lc,ld + call Abend() +end if +#ifdef _DEBUGPRINT_ +if (la+lb > 0) then + call RecPrt(' PAQP(x)',' ',PAQP(:,:,1),nRys,nT) + call RecPrt(' PAQP(y)',' ',PAQP(:,:,2),nRys,nT) + call RecPrt(' PAQP(z)',' ',PAQP(:,:,3),nRys,nT) +end if +if (lc+ld > 0) then + call RecPrt(' QCPQ(x)',' ',QCPQ(:,:,1),nRys,nT) + call RecPrt(' QCPQ(y)',' ',QCPQ(:,:,2),nRys,nT) + call RecPrt(' QCPQ(z)',' ',QCPQ(:,:,3),nRys,nT) +end if +if (nabMax /= 0) then + call RecPrt(' B10(x)',' ',B10(:,:,1),nRys,nT) + call RecPrt(' B10(y)',' ',B10(:,:,2),nRys,nT) + call RecPrt(' B10(z)',' ',B10(:,:,3),nRys,nT) +end if +if (lac /= 0) then + call RecPrt(' B00(x)',' ',B00(:,:,1),nRys,nT) + call RecPrt(' B00(y)',' ',B00(:,:,2),nRys,nT) + call RecPrt(' B00(z)',' ',B00(:,:,3),nRys,nT) +end if +if (ncdMax /= 0) then + call RecPrt(' B01(x)',' ',B01(:,:,1),nRys,nT) + call RecPrt(' B01(y)',' ',B01(:,:,2),nRys,nT) + call RecPrt(' B01(z)',' ',B01(:,:,3),nRys,nT) +end if +#endif + +return + +end subroutine Cff2DS diff -Nru openmolcas-22.02/src/rys_util/closer.f openmolcas-22.10/src/rys_util/closer.f --- openmolcas-22.02/src/rys_util/closer.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/closer.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine CloseR -************************************************************************ -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* September '90 * -************************************************************************ - use vRys_RW - use Leg_RW - Implicit Real*8 (A-H,O-Z) -#include "stdalloc.fh" -* -#ifdef _RYS_SCRATCH_ - Call UnSetAux() -#endif - If (.Not.Allocated(iHerW2)) Return - Call mma_deallocate(iHerW2) - Call mma_deallocate(iHerR2) - Call mma_deallocate(HerW2) - Call mma_deallocate(HerR2) - Call mma_deallocate(Cff) - Call mma_deallocate(x0) - Call mma_deallocate(Map) - call mma_deallocate(ddx) - Call mma_deallocate(TMax) -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/closer.F90 openmolcas-22.10/src/rys_util/closer.F90 --- openmolcas-22.02/src/rys_util/closer.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/closer.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,50 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine CloseR() +!*********************************************************************** +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! September '90 * +!*********************************************************************** + +use vRys_RW, only: Cff, ddx, HerR2, HerW2, iHerR2, iHerW2, Map, TMax, x0 +use abdata, only: close_abdata +#ifdef _RYS_SCRATCH_ +use RysScratch, only: UnSetAux +#endif +use stdalloc, only: mma_deallocate + +implicit none + +#ifdef _RYS_SCRATCH_ +call UnSetAux() +#endif + +call close_abdata() + +if (.not. allocated(iHerW2)) return +call mma_deallocate(iHerW2) +call mma_deallocate(iHerR2) +call mma_deallocate(HerW2) +call mma_deallocate(HerR2) +call mma_deallocate(Cff) +call mma_deallocate(x0) +call mma_deallocate(Map) +call mma_deallocate(ddx) +call mma_deallocate(TMax) + +return + +end subroutine CloseR diff -Nru openmolcas-22.02/src/rys_util/CMakeLists.txt openmolcas-22.10/src/rys_util/CMakeLists.txt --- openmolcas-22.02/src/rys_util/CMakeLists.txt 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -9,4 +9,101 @@ # LICENSE or in <http://www.gnu.org/licenses/>. * #*********************************************************************** +set (sources + abdata.F90 + ass1a.F90 + ass1b.F90 + ass1.F90 + ass2a.F90 + ass2b.F90 + ass2.F90 + ass3a.F90 + ass3b.F90 + ass3.F90 + assg1.F90 + assg1_mck.F90 + assg2.F90 + cff2d.F90 + cff2dq.F90 + cff2ds.F90 + closer.F90 + distg1.F90 + distg1x.F90 + distg2.F90 + drvrys.F90 + exp_1.F90 + exp_2.F90 + fake.F90 + her_rw.F90 + hrr2da.F90 + hrr2da_mck.F90 + hrr2db.F90 + hrr2db_mck.F90 + hrrctl.F90 + hrrctl_mck.F90 + memrg1.F90 + memrg2.F90 + memrys.F90 + memrys_g.F90 + modu2.F90 + pppp.F90 + ppps.F90 + ppss.F90 + pr2d.F90 + psps.F90 + psss.F90 + read_rysrw.F90 + rs2dgh.F90 + rs2dmm.F90 + rtswgh.F90 + rys01.F90 + rys11.F90 + rys22.F90 + rys2d.F90 + rys2dg.F90 + rys33.F90 + rys44.F90 + rys55.F90 + rys66.F90 + rys77.F90 + rys88.F90 + rys99.F90 + rysef0.F90 + rysef1.F90 + rysef2.F90 + rysef3.F90 + rysef4.F90 + rysef.F90 + rys.F90 + rysg1.F90 + rysg2.F90 + rysscratch.F90 + sether.F90 + setupr.F90 + setup_rw.F90 + sppp.F90 + spsp.F90 + sspp.F90 + sssp.F90 + ssss.F90 + teri1.F90 + teri.F90 + teris.F90 + terisq.F90 + tnai1.F90 + tnai.F90 + vcff2d.F90 + vrys2d.F90 + vrys2dm.F90 + vrys_rw.F90 + vrysrw.F90 + xcff2d.F90 + xrys2d.F90 +) + +# Source files defining modules that should be available to other *_util directories +set (modfile_list + her_rw.F90 +) + include (${PROJECT_SOURCE_DIR}/cmake/util_template.cmake) diff -Nru openmolcas-22.02/src/rys_util/distg1.f openmolcas-22.10/src/rys_util/distg1.f --- openmolcas-22.02/src/rys_util/distg1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/distg1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,127 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine Distg1(Temp,mVec,Grad,nGrad,IfGrad,IndGrd, - & iStab,kOp) -************************************************************************ -* * -* Object: trace the gradient of the ERI's with the second order * -* density matrix * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* October '91 * -************************************************************************ - use Symmetry_Info, only: nIrrep, iChBas - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Grad(nGrad), Temp(9), PAOg1(12), Prmt(0:7) - Logical IfGrad(3,4) - Integer IndGrd(3,4), kOp(4), iStab(4) - Data Prmt/1.d0,-1.d0,-1.d0,1.d0,-1.d0,1.d0,1.d0,-1.d0/ -* -* Statement Function -* - xPrmt(i,j) = Prmt(iAnd(i,j)) -* -#ifdef _DEBUGPRINT_ - iRout = 239 - iPrint = nPrint(iRout) - If (iPrint.ge.99) Then - Call RecPrt('Accumulated gradient on entrance', - & ' ',Grad,nGrad,1) - Write (6,*) ' kOp=',kOp - Write (6,*) ' iStab=',iStab - Call RecPrt('Distg1: Temp',' ',Temp,9,1) - End If - If (iPrint.ge.49) Write (6,*) IndGrd -#endif -* -*----- Distribute Temp in PAOg1 -* - nVec = 0 -#ifdef __INTEL_COMPILER - Do kl = 1, 12 - iCar = (kl-1)/4 + 1 - iCent = kl - (iCar-1)*4 - ij = 3*(iCent-1)+iCar - If (IfGrad(iCar,iCent)) Then - nVec = nVec + 1 - PAOg1(ij) = Temp(nVec) - Else - PAOg1(ij) = Zero - End If - End Do -#else -* -* Original code didn't work for Intel compiler with -O3 -* options since it swaps the loops. -* - Do iCar = 1, 3 - Do iCent = 1, 4 - ij = 3*(iCent-1)+iCar - If (IfGrad(iCar,iCent)) Then - nVec = nVec + 1 - PAOg1(ij) = Temp(nVec) - Else - PAOg1(ij) = Zero - End If - End Do - End Do -#endif -* -*-----a) Compute some of the contributions via the translational -* invariance -*-----b) Distribute contribution to the gradient. -* - Do iCn = 1, 4 - Do iCar = 1, 3 - ij = 3*(iCn-1) + iCar -* -* a) -* - If (IndGrd(iCar,iCn).lt.0) Then - Do jCn = 1, 4 - If (iCn.ne.jCn.and.IfGrad(iCar,jCn)) Then - kl = 3*(jCn-1) + iCar - PAOg1(ij)=PAOg1(ij)-PAOg1(kl) - End If - End Do - End If -* -* b) -* - If (IndGrd(iCar,iCn).ne.0) Then - iGrad = Abs(IndGrd(iCar,iCn)) -*--------------Parity due to integration direction - ps = xPrmt(kOp(iCn),iChBas(1+iCar)) - Fact = ps * DBLE(iStab(iCn)) / DBLE(nIrrep) - Grad(iGrad) = Grad(iGrad) + Fact * PAOg1(ij) - End If -* - End Do - End Do -* -#ifdef _DEBUGPRINT_ - If (iPrint.ge.49) Then - Call RecPrt('PAOg1',' ',PAOg1,12,1) - Call RecPrt('Accumulated gradient on exit', - & ' ',Grad,nGrad,1) - End If -#endif -* - Return -#ifdef _WARNING_WORKAROUND_ - If (.False.) Call Unused_integer(mVec) -#endif - End diff -Nru openmolcas-22.02/src/rys_util/distg1.F90 openmolcas-22.10/src/rys_util/distg1.F90 --- openmolcas-22.02/src/rys_util/distg1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/distg1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,108 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine Distg1(Temp,Grad,nGrad,IfGrad,IndGrd,iStab,kOp) +!*********************************************************************** +! * +! Object: trace the gradient of the ERI's with the second order * +! density matrix * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! October '91 * +!*********************************************************************** + +use Symmetry_Info, only: nIrrep, iChBas +use Constants, only: Zero, One +use Definitions, only: wp, iwp +#ifdef _DEBUGPRINT_ +use Definitions, only: u6 +#endif + +implicit none +real(kind=wp), intent(in) :: Temp(9) +integer(kind=iwp), intent(in) :: nGrad, IndGrd(3,4), iStab(4), kOp(4) +real(kind=wp), intent(inout) :: Grad(nGrad) +logical(kind=iwp), intent(in) :: IfGrad(3,4) +integer(kind=iwp) :: iCar, iCent, iCn, iGrad, ij, jCn, kl, nVec +real(kind=wp) :: Fact, PAOg1(12), ps +real(kind=wp), parameter :: Prmt(0:7) = [One,-One,-One,One,-One,One,One,-One] + +#ifdef _DEBUGPRINT_ +iRout = 239 +iPrint = nPrint(iRout) +if (iPrint >= 99) then + call RecPrt('Accumulated gradient on entrance',' ',Grad,nGrad,1) + write(u6,*) ' kOp=',kOp + write(u6,*) ' iStab=',iStab + call RecPrt('Distg1: Temp',' ',Temp,9,1) +end if +if (iPrint >= 49) write(u6,*) IndGrd +#endif + +! Distribute Temp in PAOg1 + +nVec = 0 +do iCar=1,3 + do iCent=1,4 + ij = 3*(iCent-1)+iCar + if (IfGrad(iCar,iCent)) then + nVec = nVec+1 + PAOg1(ij) = Temp(nVec) + else + PAOg1(ij) = Zero + end if + end do +end do + +! a) Compute some of the contributions via the translational invariance +! b) Distribute contribution to the gradient. + +do iCn=1,4 + do iCar=1,3 + ij = 3*(iCn-1)+iCar + + ! a) + + if (IndGrd(iCar,iCn) < 0) then + do jCn=1,4 + if ((iCn /= jCn) .and. IfGrad(iCar,jCn)) then + kl = 3*(jCn-1)+iCar + PAOg1(ij) = PAOg1(ij)-PAOg1(kl) + end if + end do + end if + + ! b) + + if (IndGrd(iCar,iCn) /= 0) then + iGrad = abs(IndGrd(iCar,iCn)) + ! Parity due to integration direction + ps = Prmt(iand(kOp(iCn),iChBas(1+iCar))) + Fact = ps*real(iStab(iCn),kind=wp)/real(nIrrep,kind=wp) + Grad(iGrad) = Grad(iGrad)+Fact*PAOg1(ij) + end if + + end do +end do + +#ifdef _DEBUGPRINT_ +if (iPrint >= 49) then + call RecPrt('PAOg1',' ',PAOg1,12,1) + call RecPrt('Accumulated gradient on exit',' ',Grad,nGrad,1) +end if +#endif + +return + +end subroutine Distg1 diff -Nru openmolcas-22.02/src/rys_util/distg1x.f openmolcas-22.10/src/rys_util/distg1x.f --- openmolcas-22.02/src/rys_util/distg1x.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/distg1x.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,136 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine Distg1X(g1,PAO,nT,mPAO,mVec,Grad,nGrad,IfGrad,IndGrd, - & iStab,kOp) -************************************************************************ -* * -* Object: trace the gradient of the ERI's with the second order * -* density matrix * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* October '91 * -************************************************************************ - use Symmetry_Info, only: nIrrep, iChBas - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 g1(nT,mPAO,mVec), PAO(nT,mPAO), Grad(nGrad), - & Temp(9), PAOg1(12), Prmt(0:7) - Logical IfGrad(3,4) - Integer IndGrd(3,4), kOp(4), iStab(4) -#ifdef _DEBUGPRINT_ - Character*80 Label -#endif - Data Prmt/1.d0,-1.d0,-1.d0,1.d0,-1.d0,1.d0,1.d0,-1.d0/ -* -* Statement Function -* - xPrmt(i,j) = Prmt(iAnd(i,j)) -* -#ifdef _DEBUGPRINT_ - iRout = 239 - iPrint = nPrint(iRout) - If (iPrint.ge.99) Then - Call RecPrt('PAO',' ',PAO,nT,mPAO) - Do 500 iVec = 1, mVec - Write (Label,'(A,I2,A)') ' g1(',iVec,')' - Call RecPrt(Label,' ',g1(1,1,iVec),nT,mPAO) - 500 Continue - Call RecPrt('Accumulated gradient on entrance', - & ' ',Grad,nGrad,1) - End If - If (iPrint.ge.49) Write (6,*) IndGrd -#endif -* -*-----Trace the integral derivatives with the second order density -* matrix. -* - Call dGeMV_('T',nT*mPAO,mVec, - & One,g1,nT*mPAO, - & PAO,1, - & Zero,Temp,1) - nVec = 0 -#ifdef __INTEL_COMPILER - Do kl = 1, 12 - iCar = (kl-1)/4 + 1 - iCent = kl - (iCar-1)*4 - ij = 3*(iCent-1)+iCar - If (IfGrad(iCar,iCent)) Then - nVec = nVec + 1 - PAOg1(ij) = Temp(nVec) - Else - PAOg1(ij) = Zero - End If - End Do -#else -* -* Original code didn't work for Intel compiler with -O3 -* options since it swaps the loops. -* - Do iCar = 1, 3 - Do iCent = 1, 4 - ij = 3*(iCent-1)+iCar - If (IfGrad(iCar,iCent)) Then - nVec = nVec + 1 - PAOg1(ij) = Temp(nVec) - Else - PAOg1(ij) = Zero - End If - End Do - End Do -#endif -* -*-----Compute some of the contributions via the translational invariance -* - Do 200 iCn = 1, 4 - Do 210 iCar = 1, 3 - If (IndGrd(iCar,iCn).lt.0) Then - ij = 3*(iCn-1) + iCar - Do 220 jCn = 1, 4 - If (iCn.eq.jCn) Go To 220 - If (IfGrad(iCar,jCn)) Then - kl = 3*(jCn-1) + iCar - PAOg1(ij)=PAOg1(ij)-PAOg1(kl) - End If - 220 Continue - End If - 210 Continue - 200 Continue -#ifdef _DEBUGPRINT_ - If (iPrint.ge.49) Call RecPrt('PAOg1',' ',PAOg1,12,1) -#endif -* -*-----Distribute contribution to the gradient. -* - Do 100 iCn = 1, 4 - Do 110 iCar = 1, 3 - ij = 3*(iCn-1) + iCar - If (IndGrd(iCar,iCn).ne.0) Then - iGrad = Abs(IndGrd(iCar,iCn)) -*--------------Parity due to integration direction - ps = xPrmt(kOp(iCn),iChBas(1+iCar)) - Fact = ps * DBLE(iStab(iCn)) / DBLE(nIrrep) - Grad(iGrad) = Grad(iGrad) + Fact * PAOg1(ij) - End If - 110 Continue - 100 Continue -#ifdef _DEBUGPRINT_ - If (iPrint.ge.49) Then - Call RecPrt('Accumulated gradient on exit', - & ' ',Grad,nGrad,1) - End If -* -#endif - Return - End diff -Nru openmolcas-22.02/src/rys_util/distg1x.F90 openmolcas-22.10/src/rys_util/distg1x.F90 --- openmolcas-22.02/src/rys_util/distg1x.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/distg1x.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,116 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine Distg1X(g1,PAO,nT,mPAO,mVec,Grad,nGrad,IfGrad,IndGrd,iStab,kOp) +!*********************************************************************** +! * +! Object: trace the gradient of the ERI's with the second order * +! density matrix * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! October '91 * +!*********************************************************************** + +use Symmetry_Info, only: nIrrep, iChBas +use Constants, only: Zero, One +use Definitions, only: wp, iwp +#ifdef _DEBUGPRINT_ +use Definitions, only: u6 +#endif + +implicit none +integer(kind=iwp), intent(in) :: nT, mPAO, mVec, nGrad, IndGrd(3,4), iStab(4), kOp(4) +real(kind=wp), intent(in) :: g1(nT,mPAO,mVec), PAO(nT,mPAO) +real(kind=wp), intent(inout) :: Grad(nGrad) +logical(kind=iwp), intent(in) :: IfGrad(3,4) +integer(kind=iwp) :: iCar, iCent, iCn, iGrad, ij, jCn, kl, nVec +real(kind=wp) :: Fact, PAOg1(12), ps, Temp(9) +#ifdef _DEBUGPRINT_ +character(len=80) :: Label +#endif +real(kind=wp), parameter :: Prmt(0:7) = [One,-One,-One,One,-One,One,One,-One] + +#ifdef _DEBUGPRINT_ +iRout = 239 +iPrint = nPrint(iRout) +if (iPrint >= 99) then + call RecPrt('PAO',' ',PAO,nT,mPAO) + do iVec=1,mVec + write(Label,'(A,I2,A)') ' g1(',iVec,')' + call RecPrt(Label,' ',g1(:,:,iVec),nT,mPAO) + end do + call RecPrt('Accumulated gradient on entrance',' ',Grad,nGrad,1) +end if +if (iPrint >= 49) write(u6,*) IndGrd +#endif + +! Trace the integral derivatives with the second order density matrix. + +call dGeMV_('T',nT*mPAO,mVec,One,g1,nT*mPAO,PAO,1,Zero,Temp,1) +nVec = 0 +do iCar=1,3 + do iCent=1,4 + ij = 3*(iCent-1)+iCar + if (IfGrad(iCar,iCent)) then + nVec = nVec+1 + PAOg1(ij) = Temp(nVec) + else + PAOg1(ij) = Zero + end if + end do +end do + +! Compute some of the contributions via the translational invariance + +do iCn=1,4 + do iCar=1,3 + if (IndGrd(iCar,iCn) < 0) then + ij = 3*(iCn-1)+iCar + do jCn=1,4 + if (iCn == jCn) cycle + if (IfGrad(iCar,jCn)) then + kl = 3*(jCn-1)+iCar + PAOg1(ij) = PAOg1(ij)-PAOg1(kl) + end if + end do + end if + end do +end do +#ifdef _DEBUGPRINT_ +if (iPrint >= 49) call RecPrt('PAOg1',' ',PAOg1,12,1) +#endif + +! Distribute contribution to the gradient. + +do iCn=1,4 + do iCar=1,3 + ij = 3*(iCn-1)+iCar + if (IndGrd(iCar,iCn) /= 0) then + iGrad = abs(IndGrd(iCar,iCn)) + ! Parity due to integration direction + ps = Prmt(iand(kOp(iCn),iChBas(1+iCar))) + Fact = ps*real(iStab(iCn),kind=wp)/real(nIrrep,kind=wp) + Grad(iGrad) = Grad(iGrad)+Fact*PAOg1(ij) + end if + end do +end do +#ifdef _DEBUGPRINT_ +if (iPrint >= 49) then + call RecPrt('Accumulated gradient on exit',' ',Grad,nGrad,1) +end if +#endif + +return + +end subroutine Distg1X diff -Nru openmolcas-22.02/src/rys_util/distg2.f openmolcas-22.10/src/rys_util/distg2.f --- openmolcas-22.02/src/rys_util/distg2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/distg2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,236 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) Anders Bernhardsson * -************************************************************************ - SubRoutine Distg2(g2,Hess,nHess,IndGrd, - & IfHss,IndHss,iuvwx,kOp,nop,Tr,IfGr) -************************************************************************ -* * -* @parameter kop operators for center generator * -* * -* Object: trace the gradient of the ERI's with the second order * -* density matrix * -* * -* Author: Anders Bernhardsson Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -************************************************************************ - use Symmetry_Info, only: nIrrep, iChTbl, iChBas - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - Real*8 g2(78), Prmt(0:7),Hess(nHess) - Logical IfHss(4,3,4,3),Tr(4),IfGr(4) - Integer IndGrd(3,4,0:(nIrrep-1)),kOp(4),iuvwx(4), - & IndHss(4,3,4,3,0:(nIrrep-1)),nop(4) - Data Prmt/1.d0,-1.d0,-1.d0,1.d0,-1.d0,1.d0,1.d0,-1.d0/ -* * -************************************************************************ -* * -* Statement Function -* - xPrmt(i,j) = Prmt(iAnd(i,j)) - ix(icn,icar,jcn,jcar)=(((icn-1)*3+icar)*((icn-1)*3+icar-1))/2+ - & (jcn-1)*3+jcar -* * -************************************************************************ -* * -c iRout = 239 -c iPrint = nPrint(iRout) -*define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Call recprt('Distg2: g2(raw) ',' ',g2,1,78) - Call recprt('Distg2: Hess(raw) ',' ',Hess,1,nHess) -#endif -* - -*-----Compute some of the contributions via the translational invariance -* - Do 200 iCn = 1, 4 - Do 210 iCar = 1, 3 - Do 220 jCn = 1,iCn - If (iCn.eq.jCn) Then - iStop=iCar - Else - iStop=3 - End If - Do 230 jCar = 1, iStop - if (Tr(iCn).or.Tr(jCn)) Then - ij = ix(iCn,iCar,jCn,jCar) - g2(ij)=zero -*------------------------------------------------------------* -* -* Both derivatives by translation! -* -*------------------------------------------------------------* - if (tr(iCn).and.tr(jCn)) - & Then - Do 240 kCn = 1, 4 - Do 250 lCn = 1,kCn - If (lCn.eq.kCn) then -c iMax=Max(iCar,jCar) - iCa2=Min(iCar,jCar) - iCa1=Max(iCar,jCar) - If (IfHss(kCn,iCa1,lCn,iCa2)) Then - k1=Ix(kCn,iCa1,lCn,iCa2) - g2(ij)=g2(ij)+g2(k1) - End If - Else - If (IfHss(kCn,iCar,lCn,jCar)) Then - k1=Ix(kCn,iCar,lCn,jCar) - k2=Ix(kCn,jCar,lCn,iCar) - g2(ij)=g2(ij)+g2(k1)+ - & g2(k2) - End If - End If - 250 Continue - 240 Continue -*------------------------------------------------------------* -* -* Centre jCn by translation -* -*------------------------------------------------------------* - Else If (ifgr(iCn).and.tr(jCn)) - & Then - Do 260 kCn = 1, 4 - If (kCn.gt.iCn) Then - iCn1=kCn - iCn2=iCn - iCa1=jCar - iCa2=iCar - Else If (kCn.lt.iCn) Then - iCn1=iCn - iCn2=kCn - iCa1=iCar - iCa2=jCar - Else - iCn1=iCn - iCn2=kCn - iCa1=Max(iCar,jCar) - iCa2=Min(iCar,jCar) - End If - If (IfHss(iCn1,iCa1,iCn2,iCa2)) - & Then - kl=Ix(iCn1,iCa1,iCn2,iCa2) - g2(ij)=g2(ij)-g2(kl) - End If - 260 Continue -*------------------------------------------------------------* -* -* Centre iCn by translation -* -*------------------------------------------------------------* - Else If (IfGr(jCn).and.tr(iCn)) - & Then - Do 270 kCn = 1, 4 - If (kCn.gt.jCn) Then - iCn1=kCn - iCn2=jCn - iCa1=iCar - iCa2=jCar - Else If (kCn.lt.jCn) Then - iCn1=jCn - iCn2=kCn - iCa1=jCar - iCa2=iCar - Else - iCn1=jCn - iCn2=kCn - iCa1=Max(iCar,jCar) - iCa2=Min(iCar,jCar) - End If - If (IfHss(iCn1,iCa1,iCn2,iCa2)) - & Then - kl=Ix(iCn1,iCa1,iCn2,iCa2) - g2(ij)=g2(ij)-g2(kl) - End If - 270 Continue - End If - End If - 230 Continue - 220 Continue - 210 Continue - 200 Continue -*----------------------------------------------------------------------* -* -#ifdef _DEBUGPRINT_ - Call recprt('Distg2: g2 ',' ',g2,1,78) -#endif -*-----Distribute contribution to the hessian. -* -*----------------------------------------------------------------------* - Do 90 iIrrep=0,nIrrep-1 - Do 100 iCn = 1, 4 - Do 110 iCar = 1, 3 - Do 120 jCn =1,iCn - if (iCn.eq.jCn) Then - iStop=iCar - Else - iStop=3 - End If - Do 130 jCar=1,istop - If (IndHss(iCn,iCar,jCn,jCar,iIrrep).ne.0) Then -*----------------------------------------------------------------------* -* -* Get indexes -* -*----------------------------------------------------------------------* - ij = Ix(iCn,iCar,jCn,jCar) - iHess = Abs(IndHss(iCn,iCar,jCn,jCar,iIrrep)) -*----------------------------------------------------------------------* -* -* Sign due to integral direction -* -*----------------------------------------------------------------------* - ps=DBLE(iChTbl(iIrrep,nOp(iCn))* - & iChTbl(iIrrep,nOp(jCn))) -*----------------------------------------------------------------------* -* -* If over & under triangular integrals are needed -* multiply by two instead! -* -*----------------------------------------------------------------------* - if ((iCn.ne.jCn).and.(iCar.eq.jCar).and. - & (Abs(indgrd(iCar,iCn,iIrrep)).eq. - & Abs(indgrd(jCar,jCn,iIrrep)))) Then - ps=ps*Two - End If -*----------------------------------------------------------------------* -* -* Sign due to which symmetry group the translation is in -* -*----------------------------------------------------------------------* - iCh1=iChBas(iCar+1) - iCh2=iChBas(jCar+1) - ps = ps*xPrmt(kOp(iCn),iCh1)*xPrmt(kOp(jCn),iCh2) -*----------------------------------------------------------------------* -* -* Multiply by number of stabilisators. -* -*----------------------------------------------------------------------* - Fact=ps*DBLE(iuvwx(iCn))/DBLE(nIrrep*nirrep) - & * DBLE(iuvwx(jCn)) -*----------------------------------------------------------------------* -* -* Add to hessian -* -*----------------------------------------------------------------------* - Hess(iHess) = Hess(iHess) + Fact * g2(ij) - End If - 130 Continue - 120 Continue - 110 Continue - 100 Continue - 90 Continue -#ifdef _DEBUGPRINT_ - Call recprt('Distg2: Hess ',' ',Hess,1,nHess) -#endif -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/distg2.F90 openmolcas-22.10/src/rys_util/distg2.F90 --- openmolcas-22.02/src/rys_util/distg2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/distg2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,222 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) Anders Bernhardsson * +!*********************************************************************** + +subroutine Distg2(g2,Hess,nHess,IndGrd,IfHss,IndHss,iuvwx,kOp,nop,Tr,IfGr) +!*********************************************************************** +! * +! @parameter kOp operators for center generator * +! * +! Object: trace the gradient of the ERI's with the second order * +! density matrix * +! * +! Author: Anders Bernhardsson Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +!*********************************************************************** + +use Symmetry_Info, only: nIrrep, iChTbl, iChBas +use Index_Functions, only: iTri +use Constants, only: Zero, One, Two +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nHess, IndGrd(3,4,0:(nIrrep-1)), IndHss(4,3,4,3,0:(nIrrep-1)), iuvwx(4), kOp(4), nOp(4) +real(kind=wp), intent(inout) :: g2(78), Hess(nHess) +logical(kind=iwp), intent(in) :: IfHss(4,3,4,3), Tr(4), IfGr(4) +integer(kind=iwp) :: iCa1, iCa2, iCar, iCn, iCn1, iCn2, iHess, iIrrep, ij, iStop, jCar, jCn, k1, k2, kCn, kl, lCn +real(kind=wp) :: Fact, ps +real(kind=wp), parameter :: Prmt(0:7) = [One,-One,-One,One,-One,One,One,-One] + +! * +!*********************************************************************** +! * +!iRout = 239 +!iPrint = nPrint(iRout) +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +call recprt('Distg2: g2(raw) ',' ',g2,1,78) +call recprt('Distg2: Hess(raw) ',' ',Hess,1,nHess) +#endif + +! Compute some of the contributions via the translational invariance + +do iCn=1,4 + do iCar=1,3 + do jCn=1,iCn + if (iCn == jCn) then + iStop = iCar + else + iStop = 3 + end if + do jCar=1,iStop + if (Tr(iCn) .or. Tr(jCn)) then + ij = iTri((iCn-1)*3+iCar,(jCn-1)*3+jCar) + g2(ij) = Zero + !------------------------------------------------------------* + ! + ! Both derivatives by translation! + ! + !------------------------------------------------------------* + if (Tr(iCn) .and. Tr(jCn)) then + do kCn=1,4 + do lCn=1,kCn + if (lCn == kCn) then + !iMax = Max(iCar,jCar) + iCa2 = min(iCar,jCar) + iCa1 = max(iCar,jCar) + if (IfHss(kCn,iCa1,lCn,iCa2)) then + k1 = iTri((kCn-1)*3+iCa1,(lCn-1)*3+iCa2) + g2(ij) = g2(ij)+g2(k1) + end if + else + if (IfHss(kCn,iCar,lCn,jCar)) then + k1 = iTri((kCn-1)*3+iCar,(lCn-1)*3+jCar) + k2 = iTri((kCn-1)*3+jCar,(lCn-1)*3+iCar) + g2(ij) = g2(ij)+g2(k1)+g2(k2) + end if + end if + end do + end do + else if (IfGr(iCn) .and. Tr(jCn)) then + !----------------------------------------------------------* + ! + ! Centre jCn by translation + ! + !----------------------------------------------------------* + do kCn=1,4 + if (kCn > iCn) then + iCn1 = kCn + iCn2 = iCn + iCa1 = jCar + iCa2 = iCar + else if (kCn < iCn) then + iCn1 = iCn + iCn2 = kCn + iCa1 = iCar + iCa2 = jCar + else + iCn1 = iCn + iCn2 = kCn + iCa1 = max(iCar,jCar) + iCa2 = min(iCar,jCar) + end if + if (IfHss(iCn1,iCa1,iCn2,iCa2)) then + kl = iTri((iCn1-1)*3+iCa1,(iCn2-1)*3+iCa2) + g2(ij) = g2(ij)-g2(kl) + end if + end do + else if (IfGr(jCn) .and. Tr(iCn)) then + !----------------------------------------------------------* + ! + ! Centre iCn by translation + ! + !----------------------------------------------------------* + do kCn=1,4 + if (kCn > jCn) then + iCn1 = kCn + iCn2 = jCn + iCa1 = iCar + iCa2 = jCar + else if (kCn < jCn) then + iCn1 = jCn + iCn2 = kCn + iCa1 = jCar + iCa2 = iCar + else + iCn1 = jCn + iCn2 = kCn + iCa1 = max(iCar,jCar) + iCa2 = min(iCar,jCar) + end if + if (IfHss(iCn1,iCa1,iCn2,iCa2)) then + kl = iTri((iCn1-1)*3+iCa1,(iCn2-1)*3+iCa2) + g2(ij) = g2(ij)-g2(kl) + end if + end do + end if + end if + end do + end do + end do +end do +!----------------------------------------------------------------------* + +#ifdef _DEBUGPRINT_ +call recprt('Distg2: g2 ',' ',g2,1,78) +#endif +! Distribute contribution to the hessian. + +!----------------------------------------------------------------------* +do iIrrep=0,nIrrep-1 + do iCn=1,4 + do iCar=1,3 + do jCn=1,iCn + if (iCn == jCn) then + iStop = iCar + else + iStop = 3 + end if + do jCar=1,istop + if (IndHss(iCn,iCar,jCn,jCar,iIrrep) /= 0) then + !----------------------------------------------------------* + ! + ! Get indices + ! + !----------------------------------------------------------* + ij = iTri((iCn-1)*3+iCar,(jCn-1)*3+jCar) + iHess = abs(IndHss(iCn,iCar,jCn,jCar,iIrrep)) + !----------------------------------------------------------* + ! + ! Sign due to integral direction + ! + !----------------------------------------------------------* + ps = real(iChTbl(iIrrep,nOp(iCn))*iChTbl(iIrrep,nOp(jCn)),kind=wp) + !----------------------------------------------------------* + ! + ! If over & under triangular integrals are needed + ! multiply by two instead! + ! + !----------------------------------------------------------* + if ((iCn /= jCn) .and. (iCar == jCar) .and. (abs(IndGrd(iCar,iCn,iIrrep)) == abs(IndGrd(jCar,jCn,iIrrep)))) then + ps = ps*Two + end if + !----------------------------------------------------------* + ! + ! Sign due to which symmetry group the translation is in + ! + !----------------------------------------------------------* + ps = ps*Prmt(iand(kOp(iCn),iChBas(1+iCar)))*Prmt(iand(kOp(jCn),iChBas(1+jCar))) + !----------------------------------------------------------* + ! + ! Multiply by number of stabilisers. + ! + !----------------------------------------------------------* + Fact = ps*real(iuvwx(iCn),kind=wp)/real(nIrrep*nirrep,kind=wp)*real(iuvwx(jCn),kind=wp) + !----------------------------------------------------------* + ! + ! Add to hessian + ! + !----------------------------------------------------------* + Hess(iHess) = Hess(iHess)+Fact*g2(ij) + end if + end do + end do + end do + end do +end do +#ifdef _DEBUGPRINT_ +call recprt('Distg2: Hess ',' ',Hess,1,nHess) +#endif + +return + +end subroutine Distg2 diff -Nru openmolcas-22.02/src/rys_util/drvrys.f openmolcas-22.10/src/rys_util/drvrys.f --- openmolcas-22.02/src/rys_util/drvrys.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/drvrys.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,214 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 2015, Roland Lindh * -************************************************************************ - Subroutine DrvRys(iZeta,iEta,nZeta,nEta,mZeta,mEta, - & nZeta_Tot,nEta_Tot,Data1,mData1,Data2,mData2, - & nAlpha,nBeta,nGamma,nDelta, - & IndZ,Zeta,ZInv,P,KappAB,IndZet, - & IndE, Eta,EInv,Q,KappCD,IndEta, - & ix1,iy1,iz1,ix2,iy2,iz2,ThrInt,CutInt, - & vij,vkl,vik,vil,vjk,vjl, - & Prescreen_On_Int_Only,NoInts,iAnga,Coor,CoorAC, - & mabMin,mabMax,mcdMin,mcdMax,nijkl,nabcd,mabcd, - & Wrk,iW2,iW4,nWork2,mWork2, - & HMtrxAB,HMtrxCD,la,lb,lc,ld,iCmp,iShll, - & NoPInts,Dij,mDij,Dkl,mDkl,Do_TnsCtl,kabcd, - & Coeff1,iBasi,Coeff2,jBasj, - & Coeff3,kBask,Coeff4,lBasl) -************************************************************************ -* Routine for the computation of primitive integrals and accumulation * -* to the (ab|cd) or the (e0|f0) set of integrals. If the primitive * -* set of integrals are smaller than the set of contracted integrals * -* the code selects to apply the HRR recursion {e0|f0} -> {ab|cd} here * -* before the contraction generating the (ab|cd) set of integrals, if * -* not the {e0|f0} set is contracted to the (e0|f0) set directly and * -* HRR recursion is applied outside this routine. * -* * -* For the contraction we have that either all primitive integrals * -* can be computed in a single step, otherwise subsets of primitive * -* integrals are computed and acculumulated to the contracted set. * -* * -* The Wrk array is subdiveded into 2 or 3 blocks depending on if the * -* calling code iterate over subsets of primitive integrals. * -* * -* Memory blocking * -* =============== * -* For an interative use: * -* iW4 points to the start of Wkr, length nWork2-mWork2 * -* iW2 points at nWork2-mWork+1, length mWork2 * -* iW3 points at nWork2, length nWork3 * -* * -* For single iteration use: * -* iW4 and iW2 points at the start of Wkr, length nWork2 * -* iW3 points at nWork2, length nWork3 * -* * -* Usage of memory * -* Screen: does not use Wrk * -* Rys: use iW2 secrtion * -* HRR: use the aggregated iW2 and iW3 section * -* Cntrct: use the iW2, iW3, and iW4 sections seperately * -* * -* Author: Roland Lindh * -* Dept Chemistry - Angstrom, the Theoretical Chem. Prog. * -* Uppsala University, Uppsala, Sweden * -* 2015 * -************************************************************************ - Implicit None - External TERI,ModU2,vCff2D,vRys2D - External ip_ZtMax, ip_abMax, ip_ZtMaxD, ip_abMaxD - Integer iZeta,iEta,nZeta,nEta,mZeta,mEta,nZeta_Tot,nEta_Tot, - & mData1,mData2,nAlpha,nBeta,nGamma,nDelta, - & IndZ(nZeta), IndE(nEta), IndZet(nZeta), IndEta(nEta), - & ix1, iy1, iz1, ix2, iy2, iz2, mDij, mDkl, iOffZ, iOffE, - & iAnga(4),iCmp(4), iShll(4), la,lb,lc,ld, - & mabMin,mabMax,mcdMin,mcdMax,nijkl,nabcd,mabcd, - & nWork2, mWork2, iW2, iW4, - & iBasi,jBasj,kBask,lBasl, kabcd, - & ip_ZtMax, ip_abMax, ip_ZtMaxD, ip_abMaxD - Real*8 Data1(mData1), Data2(mData2), - & Zeta(nZeta), ZInv(nZeta), P(nZeta,3), KappAB(nZeta), - & Eta(nEta), EInv(nEta), Q(nEta, 3), KappCD(nEta), - & ThrInt,CutInt,vij,vkl,vik,vil,vjk,vjl, - & Coor(3,4), CoorAC(3,2), Wrk(nWork2), - & HMtrxAB(*), HMtrxCD(*), Dij(mDij), Dkl(mDkl), - & Coeff1(nAlpha,iBasi), Coeff2(nBeta,jBasj), - & Coeff3(nGamma,kBask), Coeff4(nDelta,lBasl) - Logical Prescreen_On_Int_Only, NoInts,NoPInts, Do_TnsCtl -* Local arrays - Integer lZeta, lEta, i_Int, n1, n2, n3, n4, iW3, nWork3, nW2 - Logical Nospecial -!#define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Write (6,*) 'Enter DrvRys' - Write (6,*) 'iZeta, nZeta, mZeta, nZeta_Tot=', - & iZeta, nZeta, mZeta, nZeta_Tot - Write (6,*) 'iEta , nEta , mEta , nEta_Tot=', - & iEta , nEta , mEta , nEta_Tot - Call RecPrt('Coeff1',' ',Coeff1,nAlpha,iBasi) - Call RecPrt('Coeff2',' ',Coeff2,nBeta ,jBasj) - Call RecPrt('Coeff3',' ',Coeff3,nGamma,kBask) - Call RecPrt('Coeff4',' ',Coeff4,nDelta,lBasl) - Call RecPrt('KappAB',' ',KappAB,1,nZeta) - Call RecPrt('KappCD',' ',KappCD,1,nEta) -#endif -* - NoSpecial=.False. ! Use special code if possible -* -*-----Transfer k2 data and prescreen -* - iOffZ = mDij-nZeta - iOffE = mDkl-nEta - Call Screen(nZeta,nEta,mZeta,mEta,lZeta,lEta, - & Zeta,ZInv,P,KappAB,IndZet, - & Data1(iZeta),nAlpha,nBeta,IndZ(iZeta), - & Data1(ip_ZtMax (nZeta)), - & Data1(ip_abMax (nZeta)), - & Data1(ip_ZtMaxD(nZeta)), - & Data1(ip_abMaxD(nZeta)), - & Eta,EInv,Q,KappCD,IndEta, - & Data2(iEta),nGamma,nDelta,IndE(iEta), - & Data2(ip_ZtMax ( nEta)), - & Data2(ip_abMax ( nEta)), - & Data2(ip_ZtMaxD( nEta)), - & Data2(ip_abMaxD( nEta)), - & Dij(iOffZ),Dkl(iOffE), - & ix1,iy1,iz1,ix2,iy2,iz2,ThrInt,CutInt, - & vij,vkl,vik,vil,vjk,vjl, - & Prescreen_On_Int_Only) -* Write (6,*) 'lZeta,lEta:', lZeta, lEta - If (lZeta*lEta.eq.0) Then - Call FZero(Wrk(iW2),mWork2) - Go To 99 - End If - NoInts=.False. -* -*-----Compute [a0|c0], ijkl,a,c -* - Call Rys(iAnga,lZeta*lEta, - & Zeta,ZInv,lZeta, - & Eta,EInv,lEta, - & P,nZeta,Q,nEta, - & KappAB,KappCD, - & Coor,Coor,CoorAC, - & mabMin,mabMax,mcdMin,mcdMax, - & Wrk(iW2),mWork2,TERI,ModU2, - & vCff2D,vRys2D,NoSpecial) -* -*-----Select between HRR before contraction or to contract -* and perform the HRR later once the complete set of -* contracted integrals have been generated. -* - If (lZeta*lEta.lt.nijkl .and. - & mZeta.eq.nZeta_tot .and. mEta.eq.nEta_tot ) Then -* -*--------Apply the HRR recusions first. Note that this is only -* executed if used in single iteration mode. Hence, -* iW2 and iW4 are identical. -* - iW3=iW2+lZeta*lEta*mabcd - Call DGeTMO(Wrk(iW2),lZeta*lEta,lZeta*lEta, - & mabcd,Wrk(iW3),mabcd) - call dcopy_(mabcd*lZeta*lEta,Wrk(iW3),1,Wrk(iW2),1) - Call TnsCtl(Wrk(iW2),nWork2,Coor, - & mabcd,lZeta*lEta, - & mabMax,mabMin,mcdMax,mcdMin, - & HMtrxAB,HMtrxCD,la,lb,lc,ld, - & iCmp(1),iCmp(2),iCmp(3),iCmp(4), - & iShll(1),iShll(2),iShll(3),iShll(4),i_Int) - If (i_Int.ne.iW2) call dcopy_(lZeta*lEta*nabcd,Wrk(i_int),1, - & Wrk(iW2),1) - Do_TnsCtl=.False. - n1=1 - n2=iCmp(1)*iCmp(2) - n3=1 - n4=iCmp(3)*iCmp(4) - kabcd=nabcd - Else -* -*--------Postpone application of the HRR recusions until later. -* - Do_TnsCtl=.True. - n1=mabMin - n2=mabMax - n3=mcdMin - n4=mcdMax - kabcd=mabcd - End If -* -*-----Accumulate to the contracted integrals -* - If (iW4.ne.iW2) Then -* Account for size of the integrals in - nW2=lZeta*lEta * kabcd - Else ! iW4.eq.iW2 -* Account for size of the integrals in and out - nW2=Max(iBasi*jBasj*kBask*lBasl,lZeta*lEta) * kabcd - End If - iW3=iW2+nW2 - nWork3=mWork2-nW2 -* Write (6,*) 'iW4,iW2,iW3:',iW4,iW2,iW3 -* Write (6,*) 'nWork3:',nWork3 - Call Cntrct(NoPInts, - & Coeff1,nAlpha,iBasi,Coeff2,nBeta ,jBasj, - & Coeff3,nGamma,kBask,Coeff4,nDelta,lBasl, - & Wrk(iW2),n1,n2,n3,n4,Wrk(iW3),nWork3,Wrk(iW4), - & IndZet,lZeta,IndEta,lEta) -* - 99 Continue -#ifdef _DEBUGPRINT_ - Write (6,*) 'iW4,iW2,iW3:',iW4,iW2,iW3 - Call RecPrt('DrvRys:(e0|0f)',' ',Wrk(iW4),kabcd, - & iBasi*jBasj*kBask*lBasl) -#endif -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/drvrys.F90 openmolcas-22.10/src/rys_util/drvrys.F90 --- openmolcas-22.02/src/rys_util/drvrys.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/drvrys.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,176 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 2015, Roland Lindh * +!*********************************************************************** +subroutine DrvRys(iZeta,iEta,nZeta,nEta,mZeta,mEta,nZeta_Tot,nEta_Tot,Data1,mData1,Data2,mData2,nAlpha,nBeta,nGamma,nDelta,IndZ, & + Zeta,ZInv,P,KappAB,IndZet,IndE,Eta,EInv,Q,KappCD,IndEta,ix1,iy1,iz1,ix2,iy2,iz2,ThrInt,CutInt,vij,vkl,vik,vil, & + vjk,vjl,Prescreen_On_Int_Only,NoInts,iAnga,Coor,CoorAC,mabMin,mabMax,mcdMin,mcdMax,nijkl,nabcd,mabcd,Wrk,iW2, & + iW4,nWork2,mWork2,HMtrxAB,HMtrxCD,la,lb,lc,ld,iCmp,iShll,NoPInts,Dij,mDij,Dkl,mDkl,Do_TnsCtl,kabcd,Coeff1,iBasi, & + Coeff2,jBasj,Coeff3,kBask,Coeff4,lBasl) +!*********************************************************************** +! Routine for the computation of primitive integrals and accumulation * +! to the (ab|cd) or the (e0|f0) set of integrals. If the primitive * +! set of integrals is smaller than the set of contracted integrals * +! the code selects to apply the HRR recursion {e0|f0} -> {ab|cd} here * +! before the contraction generating the (ab|cd) set of integrals, if * +! not the {e0|f0} set is contracted to the (e0|f0) set directly and * +! HRR recursion is applied outside this routine. * +! * +! For the contraction we have that either all primitive integrals * +! can be computed in a single step, otherwise subsets of primitive * +! integrals are computed and accumulated to the contracted set. * +! * +! The Wrk array is subdivided into 2 or 3 blocks depending on if the * +! calling code iterates over subsets of primitive integrals. * +! * +! Memory blocking * +! =============== * +! For an iterative use: * +! iW4 points to the start of Wrk, length nWork2-mWork2 * +! iW2 points at nWork2-mWork+1, length mWork2 * +! iW3 points at nWork2, length nWork3 * +! * +! For single iteration use: * +! iW4 and iW2 point at the start of Wrk, length nWork2 * +! iW3 points at nWork2, length nWork3 * +! * +! Usage of memory * +! Screen: does not use Wrk * +! Rys: use iW2 section * +! HRR: use the aggregated iW2 and iW3 section * +! Cntrct: use the iW2, iW3, and iW4 sections separately * +! * +! Author: Roland Lindh * +! Dept Chemistry - Angstrom, the Theoretical Chem. Prog. * +! Uppsala University, Uppsala, Sweden * +! 2015 * +!*********************************************************************** + +use Constants, only: Zero +use Definitions, only: wp, iwp +!#define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +use Definitions, only: u6 +#endif + +implicit none +integer(kind=iwp), intent(in) :: iZeta, iEta, nZeta, nEta, mZeta, mEta, nZeta_Tot, nEta_Tot, mData1, mData2, nAlpha, nBeta, & + nGamma, nDelta, IndZ(nZeta), IndE(nEta), ix1, iy1, iz1, ix2, iy2, iz2, iAnga(4), mabMin, mabMax, & + mcdMin, mcdMax, nijkl, nabcd, mabcd, iW2, iW4, nWork2, mWork2, la, lb, lc, ld, iCmp(4), iShll(4), & + mDij, mDkl, iBasi, jBasj, kBask, lBasl +real(kind=wp), intent(in) :: Data1(mData1), Data2(mData2), ThrInt, CutInt, vij, vkl, vik, vil, vjk, vjl, Coor(3,4), CoorAC(3,2), & + HMtrxAB(*), HMtrxCD(*), Dij(mDij), Dkl(mDkl), Coeff1(nAlpha,iBasi), Coeff2(nBeta,jBasj), & + Coeff3(nGamma,kBask), Coeff4(nDelta,lBasl) +real(kind=wp), intent(out) :: Zeta(nZeta), ZInv(nZeta), P(nZeta,3), Eta(nEta), EInv(nEta), Q(nEta,3) +real(kind=wp), intent(inout) :: KappAB(nZeta), KappCD(nEta), Wrk(nWork2) +integer(kind=iwp), intent(out) :: IndZet(nZeta), IndEta(nEta), kabcd +logical(kind=iwp), intent(in) :: Prescreen_On_Int_Only +logical(kind=iwp), intent(inout) :: NoInts, NoPInts, Do_TnsCtl +integer(kind=iwp) :: i_Int, iOffE, iOffZ, iW3, lEta, lZeta, n1, n2, n3, n4, nW2, nWork3 +logical(kind=iwp) :: Nospecial +external :: TERI, ModU2, vCff2D, vRys2D +integer(kind=iwp), external :: ip_abMax, ip_abMaxD, ip_ZtMax, ip_ZtMaxD + +#ifdef _DEBUGPRINT_ +write(u6,*) 'Enter DrvRys' +write(u6,*) 'iZeta, nZeta, mZeta, nZeta_Tot=',iZeta,nZeta,mZeta,nZeta_Tot +write(u6,*) 'iEta , nEta , mEta , nEta_Tot=',iEta,nEta,mEta,nEta_Tot +call RecPrt('Coeff1',' ',Coeff1,nAlpha,iBasi) +call RecPrt('Coeff2',' ',Coeff2,nBeta,jBasj) +call RecPrt('Coeff3',' ',Coeff3,nGamma,kBask) +call RecPrt('Coeff4',' ',Coeff4,nDelta,lBasl) +call RecPrt('KappAB',' ',KappAB,1,nZeta) +call RecPrt('KappCD',' ',KappCD,1,nEta) +#endif + +NoSpecial = .false. ! Use special code if possible + +! Transfer k2 data and prescreen + +iOffZ = mDij-nZeta +iOffE = mDkl-nEta +call Screen(nZeta,nEta,mZeta,mEta,lZeta,lEta,Zeta,ZInv,P,KappAB,IndZet,Data1(iZeta),nAlpha,nBeta,IndZ(iZeta), & + Data1(ip_ZtMax(nZeta)),Data1(ip_abMax(nZeta)),Data1(ip_ZtMaxD(nZeta)),Data1(ip_abMaxD(nZeta)),Eta,EInv,Q,KappCD, & + IndEta,Data2(iEta),nGamma,nDelta,IndE(iEta),Data2(ip_ZtMax(nEta)),Data2(ip_abMax(nEta)),Data2(ip_ZtMaxD(nEta)), & + Data2(ip_abMaxD(nEta)),Dij(iOffZ),Dkl(iOffE),ix1,iy1,iz1,ix2,iy2,iz2,ThrInt,CutInt,vij,vkl,vik,vil,vjk,vjl, & + Prescreen_On_Int_Only) +!write(u6,*) 'lZeta,lEta:',lZeta,lEta +if (lZeta*lEta == 0) then + Wrk(iW2:iW2+mWork2-1) = Zero +else + NoInts = .false. + + ! Compute [a0|c0], ijkl,a,c + + call Rys(iAnga,lZeta*lEta,Zeta,ZInv,lZeta,Eta,EInv,lEta,P,nZeta,Q,nEta,KappAB,KappCD,Coor,Coor,CoorAC,mabMin,mabMax,mcdMin, & + mcdMax,Wrk(iW2),mWork2,TERI,ModU2,vCff2D,vRys2D,NoSpecial) + + ! Select between HRR before contraction or to contract + ! and perform the HRR later once the complete set of + ! contracted integrals have been generated. + + if ((lZeta*lEta < nijkl) .and. (mZeta == nZeta_tot) .and. (mEta == nEta_tot)) then + + ! Apply the HRR recursions first. Note that this is only + ! executed if used in single iteration mode. Hence, + ! iW2 and iW4 are identical. + + n1 = lZeta*lEta*mabcd + iW3 = iW2+n1 + call DGeTMO(Wrk(iW2),lZeta*lEta,lZeta*lEta,mabcd,Wrk(iW3),mabcd) + Wrk(iW2:iW2+n1-1) = Wrk(iW3:iW3+n1-1) + call TnsCtl(Wrk(iW2),nWork2,Coor,mabcd,lZeta*lEta,mabMax,mabMin,mcdMax,mcdMin,HMtrxAB,HMtrxCD,la,lb,lc,ld,iCmp(1),iCmp(2), & + iCmp(3),iCmp(4),iShll(1),iShll(2),iShll(3),iShll(4),i_Int) + n2 = lZeta*lEta*nabcd + if (i_Int /= iW2) Wrk(iW2:iW2+n2-1) = Wrk(i_Int:i_Int+n2-1) + Do_TnsCtl = .false. + n1 = 1 + n2 = iCmp(1)*iCmp(2) + n3 = 1 + n4 = iCmp(3)*iCmp(4) + kabcd = nabcd + else + + ! Postpone application of the HRR recursions until later. + + Do_TnsCtl = .true. + n1 = mabMin + n2 = mabMax + n3 = mcdMin + n4 = mcdMax + kabcd = mabcd + end if + + ! Accumulate to the contracted integrals + + if (iW4 /= iW2) then + ! Account for size of the integrals in + nW2 = lZeta*lEta*kabcd + else ! iW4 == iW2 + ! Account for size of the integrals in and out + nW2 = max(iBasi*jBasj*kBask*lBasl,lZeta*lEta)*kabcd + end if + iW3 = iW2+nW2 + nWork3 = mWork2-nW2 + !write(u6,*) 'iW4,iW2,iW3:',iW4,iW2,iW3 + !write(u6,*) 'nWork3:',nWork3 + call Cntrct(NoPInts,Coeff1,nAlpha,iBasi,Coeff2,nBeta,jBasj,Coeff3,nGamma,kBask,Coeff4,nDelta,lBasl,Wrk(iW2),n1,n2,n3,n4, & + Wrk(iW3),nWork3,Wrk(iW4),IndZet,lZeta,IndEta,lEta) +end if + +#ifdef _DEBUGPRINT_ +write(u6,*) 'iW4,iW2,iW3:',iW4,iW2,iW3 +call RecPrt('DrvRys:(e0|0f)',' ',Wrk(iW4),kabcd,iBasi*jBasj*kBask*lBasl) +#endif + +return + +end subroutine DrvRys diff -Nru openmolcas-22.02/src/rys_util/exp_1.f openmolcas-22.10/src/rys_util/exp_1.f --- openmolcas-22.02/src/rys_util/exp_1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/exp_1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine Exp_1(Vector,n1,n2,Array,Fact) -************************************************************************ -* * -* Object: expand an array. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* October '91 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) - Real*8 Vector(n1,n2), Array(n1) -* -* - Do 10 i2 = 1, n2 - Do 20 i1 = 1, n1 - Vector(i1,i2) = Array(i1)*Fact - 20 Continue - 10 Continue -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/exp_1.F90 openmolcas-22.10/src/rys_util/exp_1.F90 --- openmolcas-22.02/src/rys_util/exp_1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/exp_1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,38 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine Exp_1(Vector,n1,n2,Array,Fact) +!*********************************************************************** +! * +! Object: expand an array. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! October '91 * +!*********************************************************************** + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: n1, n2 +real(kind=wp), intent(out) :: Vector(n1,n2) +real(kind=wp), intent(in) :: Array(n1), Fact +integer(kind=iwp) :: i2 + +do i2=1,n2 + Vector(:,i2) = Array*Fact +end do + +return + +end subroutine Exp_1 diff -Nru openmolcas-22.02/src/rys_util/exp_2.f openmolcas-22.10/src/rys_util/exp_2.f --- openmolcas-22.02/src/rys_util/exp_2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/exp_2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine Exp_2(Vector,n1,n2,Array,Fact) -************************************************************************ -* * -* Object: expand an array. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* October '91 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) - Real*8 Vector(n1,n2), Array(n2) -* -* - Do 10 i2 = 1, n2 - Do 20 i1 = 1, n1 - Vector(i1,i2) = Array(i2)*Fact - 20 Continue - 10 Continue -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/exp_2.F90 openmolcas-22.10/src/rys_util/exp_2.F90 --- openmolcas-22.02/src/rys_util/exp_2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/exp_2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,38 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine Exp_2(Vector,n1,n2,Array,Fact) +!*********************************************************************** +! * +! Object: expand an array. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! October '91 * +!*********************************************************************** + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: n1, n2 +real(kind=wp), intent(out) :: Vector(n1,n2) +real(kind=wp), intent(in) :: Array(n2), Fact +integer(kind=iwp) :: i1 + +do i1=1,n1 + Vector(i1,:) = Array*Fact +end do + +return + +end subroutine Exp_2 diff -Nru openmolcas-22.02/src/rys_util/fake.f openmolcas-22.10/src/rys_util/fake.f --- openmolcas-22.02/src/rys_util/fake.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/fake.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,28 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Fake(U2,mT,nRys,ZEInv) -************************************************************************ -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* May '90 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" - Real*8 U2(mT,nRys), ZEInv(mT) - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(U2) - Call Unused_real_array(ZEInv) - End If - End diff -Nru openmolcas-22.02/src/rys_util/fake.F90 openmolcas-22.10/src/rys_util/fake.F90 --- openmolcas-22.02/src/rys_util/fake.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/fake.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,34 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Fake(U2,mT,nRys,ZEInv) +!*********************************************************************** +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! May '90 * +!*********************************************************************** + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: mT, nRys +real(kind=wp), intent(inout) :: U2(mT,nRys) +real(kind=wp), intent(in) :: ZEInv(mT) + +#include "macros.fh" +unused_var(U2) +unused_var(ZEInv) + +return + +end subroutine Fake diff -Nru openmolcas-22.02/src/rys_util/her_rw.f openmolcas-22.10/src/rys_util/her_rw.f --- openmolcas-22.02/src/rys_util/her_rw.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/her_rw.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,16 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Module Her_RW - Integer, Parameter :: nPrpMx=20 - Integer MaxHer, nPrp - Integer, Dimension(:), Allocatable :: iHerR, iHerW - Real*8, Dimension (:), Allocatable :: HerR, HerW - End Module Her_RW diff -Nru openmolcas-22.02/src/rys_util/her_rw.F90 openmolcas-22.10/src/rys_util/her_rw.F90 --- openmolcas-22.02/src/rys_util/her_rw.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/her_rw.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,25 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +module Her_RW + +use Definitions, only: wp, iwp + +implicit none +private + +integer(kind=iwp) :: MaxHer = 0, nPrp +integer(kind=iwp), allocatable :: iHerR(:), iHerW(:) +real(kind=wp), allocatable :: HerR(:), HerW(:) + +public :: HerR, HerW, iHerR, iHerW, MaxHer, nPrp + +end module Her_RW diff -Nru openmolcas-22.02/src/rys_util/hrr2da.f openmolcas-22.10/src/rys_util/hrr2da.f --- openmolcas-22.02/src/rys_util/hrr2da.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/hrr2da.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,141 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1991,1992, Roland Lindh * -************************************************************************ - SubRoutine HRR2Da(Arr1,nVec,nabMax,ncdMax,Arr2,A,B,la,lb,lc,ld, - & IfGrad) -************************************************************************ -* * -* Object: to apply the transfer equation to the 2D-integrals. * -* The transformation is in place and the recursion * -* is replaced with the indentity when applicable. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* September '91 * -* Modified to recurrence algorithm, February '92. * -* Improved algorithm, June '92. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 A(3), B(3), Arr1(nVec,3,0:nabMax,0:ncdMax), - & Arr2(nVec,0:la+1,0:lb+1,0:ncdMax,3) - Logical IfGrad(3,4) -* -* iQ = 0 -* - Do 10 iCar = 1, 3 - lla = 0 - If(IfGrad(iCar,1)) lla = 1 - llb = 0 - If(IfGrad(iCar,2)) llb = 1 - llcd = 0 - If(IfGrad(iCar,3).or.IfGrad(iCar,4)) llcd = 1 -* - AB = A(iCar)-B(iCar) - If (AB.eq.Zero) Then - Do 100 icd = 0, lc+ld+llcd -*-----------Using the identity - Do 200 ia = 0, la+lla - Do 210 ib = 0, lb+llb - iab = ia + ib - If (iab.gt.la+lb+Max(lla,llb)) Go To 210 - do i=1,nVec - Arr2(i,ia,ib,icd,iCar)=Arr1(i,iCar,iab,icd) - enddo -210 Continue -200 Continue -100 Continue - Else - If (la.ge.lb) Then - Do 101 icd = 0, lc+ld+llcd -*-----------------Move the first row I(ia,0) - Do 20 ia = 0, la+lb+Max(lla,llb) - ja = ia - jb = 0 - If (ja.gt.la+1) Then - ja = ja - (la+2) - jb = 1 - End If - do i=1,nVec - Arr2(i,ja,jb,icd,iCar)=Arr1(i,iCar,ia,icd) - end do - 20 Continue -*-----------------Generate I(ia,ib) for fixed ib - Do 30 ib = 1, lb + llb - Do 31 ia = la+lb+Max(lla,llb)-ib, 0, -1 - ja = ia - jb = ib - mb = ib-1 - If (ja.gt.la+1) Then - ja = ja - (la+2) - jb = jb + 1 - mb = mb + 1 - End If - ma = ja - ka = ia+1 - kb = ib-1 - If (ka.gt.la+1) Then - ka = ka - (la+2) - kb = kb + 1 - End If - Call DZaXpY(nVec,AB,Arr2(1,ma,mb,icd,iCar),1, - & Arr2(1,ka,kb,icd,iCar),1, - & Arr2(1,ja,jb,icd,iCar),1) - 31 Continue - 30 Continue - 101 Continue - Else - AB = -AB - Do 102 icd = 0, lc+ld+llcd -*-----------------Move the first row I(0,ib) - Do 40 ib = 0, la+lb+Max(lla,llb) - jb = ib - ja = 0 - If (jb.gt.lb+1) Then - jb = jb - (lb+2) - ja = 1 - End If - do i=1,nVec - Arr2(i,ja,jb,icd,iCar)=Arr1(i,iCar,ib,icd) - end do - 40 Continue -*-----------------Generate I(ia,ib) for fixed ia - Do 50 ia = 1, la + lla - Do 51 ib = la+lb+Max(lla,llb)-ia, 0, -1 - jb = ib - ja = ia - ma = ia-1 - If (jb.gt.lb+1) Then - jb = jb - (lb+2) - ja = ja + 1 - ma = ma + 1 - End If - mb = jb - kb = ib+1 - ka = ia-1 - If (kb.gt.lb+1) Then - kb = kb - (lb+2) - ka = ka + 1 - End If - Call DZaXpY(nVec,AB,Arr2(1,ma,mb,icd,iCar),1, - & Arr2(1,ka,kb,icd,iCar),1, - & Arr2(1,ja,jb,icd,iCar),1) - 51 Continue - 50 Continue - 102 Continue - End If - End If - 10 Continue -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/hrr2da.F90 openmolcas-22.10/src/rys_util/hrr2da.F90 --- openmolcas-22.02/src/rys_util/hrr2da.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/hrr2da.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,135 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1991,1992, Roland Lindh * +!*********************************************************************** + +subroutine HRR2Da(Arr1,nVec,nabMax,ncdMax,Arr2,A,B,la,lb,lc,ld,IfGrad) +!*********************************************************************** +! * +! Object: to apply the transfer equation to the 2D-integrals. * +! The transformation is in place and the recursion * +! is replaced with the indentity when applicable. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! September '91 * +! Modified to recurrence algorithm, February '92. * +! Improved algorithm, June '92. * +!*********************************************************************** + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nVec, nabMax, ncdMax, la, lb, lc, ld +real(kind=wp), intent(in) :: Arr1(nVec,3,0:nabMax,0:ncdMax), A(3), B(3) +real(kind=wp), intent(out) :: Arr2(nVec,0:la+1,0:lb+1,0:ncdMax,3) +logical(kind=iwp), intent(in) :: IfGrad(3,4) +integer(kind=iwp) :: ia, iab, ib, iCar, icd, ja, jb, ka, kb, lla, llb, llcd, ma, mb +real(kind=wp) :: AB + +!iQ = 0 + +do iCar=1,3 + lla = 0 + if (IfGrad(iCar,1)) lla = 1 + llb = 0 + if (IfGrad(iCar,2)) llb = 1 + llcd = 0 + if (IfGrad(iCar,3) .or. IfGrad(iCar,4)) llcd = 1 + + AB = A(iCar)-B(iCar) + if (AB == Zero) then + do icd=0,lc+ld+llcd + ! Using the identity + do ia=0,la+lla + do ib=0,lb+llb + iab = ia+ib + if (iab > la+lb+max(lla,llb)) cycle + Arr2(:,ia,ib,icd,iCar) = Arr1(:,iCar,iab,icd) + end do + end do + end do + else if (la >= lb) then + do icd=0,lc+ld+llcd + ! Move the first row I(ia,0) + do ia=0,la+lb+max(lla,llb) + ja = ia + jb = 0 + if (ja > la+1) then + ja = ja-(la+2) + jb = 1 + end if + Arr2(:,ja,jb,icd,iCar) = Arr1(:,iCar,ia,icd) + end do + ! Generate I(ia,ib) for fixed ib + do ib=1,lb+llb + do ia=la+lb+max(lla,llb)-ib,0,-1 + ja = ia + jb = ib + mb = ib-1 + if (ja > la+1) then + ja = ja-(la+2) + jb = jb+1 + mb = mb+1 + end if + ma = ja + ka = ia+1 + kb = ib-1 + if (ka > la+1) then + ka = ka-(la+2) + kb = kb+1 + end if + Arr2(:,ja,jb,icd,iCar) = AB*Arr2(:,ma,mb,icd,iCar)+Arr2(:,ka,kb,icd,iCar) + end do + end do + end do + else + AB = -AB + do icd=0,lc+ld+llcd + ! Move the first row I(0,ib) + do ib=0,la+lb+max(lla,llb) + jb = ib + ja = 0 + if (jb > lb+1) then + jb = jb-(lb+2) + ja = 1 + end if + Arr2(:,ja,jb,icd,iCar) = Arr1(:,iCar,ib,icd) + end do + ! Generate I(ia,ib) for fixed ia + do ia=1,la+lla + do ib=la+lb+max(lla,llb)-ia,0,-1 + jb = ib + ja = ia + ma = ia-1 + if (jb > lb+1) then + jb = jb-(lb+2) + ja = ja+1 + ma = ma+1 + end if + mb = jb + kb = ib+1 + ka = ia-1 + if (kb > lb+1) then + kb = kb-(lb+2) + ka = ka+1 + end if + Arr2(:,ja,jb,icd,iCar) = AB*Arr2(:,ma,mb,icd,iCar)+Arr2(:,ka,kb,icd,iCar) + end do + end do + end do + end if +end do + +return + +end subroutine HRR2Da diff -Nru openmolcas-22.02/src/rys_util/hrr2da_mck.f openmolcas-22.10/src/rys_util/hrr2da_mck.f --- openmolcas-22.02/src/rys_util/hrr2da_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/hrr2da_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,145 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1991,1992, Roland Lindh * -************************************************************************ - SubRoutine HRR2Da_mck(Arr1,nVec,nabMax,ncdMax, - & Arr2,A,B,la,lb,lc,ld, - & IfHss,IfGrd) -************************************************************************ -* * -* Object: to apply the transfer equation to the 2D-integrals. * -* The transformation is in place and the recursion * -* is replaced with the indentity when applicable. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* September '91 * -* Modified to recurrence algorithm, February '92. * -* Improved algorithm, June '92. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -c#include "print.fh" -#include "real.fh" - Real*8 A(3), B(3), Arr1(nVec,3,0:nabMax,0:ncdMax), - & Arr2(nVec,0:la+2,0:lb+2,0:ncdMax,3) - Logical IfHss(4,3,4,3),IfGrd(3,4) -* -c iRout = 233 -c iPrint = nPrint(iRout) -* - Do 10 iCar = 1, 3 - lla = 0 - llb = 0 - llcd = 0 - If(IfGrd(iCar,1)) lla=Max(1,lla) - If(IfHss(1,iCar,1,iCar)) lla = 2 - If(IfGrd(iCar,2)) llb=Max(1,llb) - If(IfHss(2,iCar,2,iCar)) llb = 2 - If(IfGrd(iCar,3).or.IfGrd(iCar,4)) llcd = MAx(1,llcd) - If(IfHss(3,iCar,3,iCar).or.IfHss(4,iCar,4,iCar)) llcd = 2 - AB = A(iCar)-B(iCar) - If (AB.eq.Zero) Then - Do 100 icd = 0, lc+ld+llcd -*-----------Using the identity - Do 200 ia = 0, la+lla - Do 210 ib = 0, lb+llb - iab = ia + ib - If (iab.gt.la+lb+Max(lla,llb)) Go To 210 - do i=1,nVec - Arr2(i,ia,ib,icd,iCar)=Arr1(i,iCar,iab,icd) - end do -210 Continue -200 Continue -100 Continue - Else - If (la.ge.lb) Then - Do 101 icd = 0, lc+ld+llcd -*-----------------Move the first row I(ia,0) - Do 20 ia = 0, la+lb+Max(lla,llb) - ja = ia - jb = 0 - If (ja.gt.la+2) Then - ja = ja - (la+3) - jb = 1 - End If - do i=1,nVec - Arr2(i,ja,jb,icd,iCar)=Arr1(i,iCar,ia,icd) - end do - 20 Continue -*-----------------Generate I(ia,ib) for fixed ib - Do 30 ib = 1, lb + llb - Do 31 ia = la+lb+Max(lla,llb)-ib, 0, -1 - ja = ia - jb = ib - mb = ib-1 - If (ja.gt.la+2) Then - ja = ja - (la+3) - jb = jb + 1 - mb = mb + 1 - End If - ma = ja - ka = ia+1 - kb = ib-1 - If (ka.gt.la+2) Then - ka = ka - (la+3) - kb = kb + 1 - End If - Call DZaXpY(nVec,AB,Arr2(1,ma,mb,icd,iCar),1, - & Arr2(1,ka,kb,icd,iCar),1, - & Arr2(1,ja,jb,icd,iCar),1) - 31 Continue - 30 Continue - 101 Continue - Else - AB = -AB - Do 102 icd = 0, lc+ld+llcd -*-----------------Move the first row I(0,ib) - Do 40 ib = 0, la+lb+Max(lla,llb) - jb = ib - ja = 0 - If (jb.gt.lb+2) Then - jb = jb - (lb+3) - ja = 1 - End If - do i=1,nVec - Arr2(i,ja,jb,icd,iCar)=Arr1(i,iCar,ib,icd) - end do - 40 Continue -*-----------------Generate I(ia,ib) for fixed ia - Do 50 ia = 1, la + lla - Do 51 ib = la+lb+Max(lla,llb)-ia, 0, -1 - jb = ib - ja = ia - ma = ia-1 - If (jb.gt.lb+2) Then - jb = jb - (lb+3) - ja = ja + 1 - ma = ma + 1 - End If - mb = jb - kb = ib+1 - ka = ia-1 - If (kb.gt.lb+2) Then - kb = kb - (lb+3) - ka = ka + 1 - End If - Call DZaXpY(nVec,AB,Arr2(1,ma,mb,icd,iCar),1, - & Arr2(1,ka,kb,icd,iCar),1, - & Arr2(1,ja,jb,icd,iCar),1) - 51 Continue - 50 Continue - 102 Continue - End If - End If - 10 Continue -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/hrr2da_mck.F90 openmolcas-22.10/src/rys_util/hrr2da_mck.F90 --- openmolcas-22.02/src/rys_util/hrr2da_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/hrr2da_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,138 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1991,1992, Roland Lindh * +!*********************************************************************** + +subroutine HRR2Da_mck(Arr1,nVec,nabMax,ncdMax,Arr2,A,B,la,lb,lc,ld,IfHss,IfGrd) +!*********************************************************************** +! * +! Object: to apply the transfer equation to the 2D-integrals. * +! The transformation is in place and the recursion * +! is replaced with the indentity when applicable. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! September '91 * +! Modified to recurrence algorithm, February '92. * +! Improved algorithm, June '92. * +!*********************************************************************** + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nVec, nabMax, ncdMax, la, lb, lc, ld +real(kind=wp), intent(in) :: Arr1(nVec,3,0:nabMax,0:ncdMax), A(3), B(3) +real(kind=wp), intent(out) :: Arr2(nVec,0:la+2,0:lb+2,0:ncdMax,3) +logical(kind=iwp), intent(in) :: IfHss(4,3,4,3), IfGrd(3,4) +integer(kind=iwp) :: ia, iab, ib, iCar, icd, ja, jb, ka, kb, lla, llb, llcd, ma, mb +real(kind=wp) :: AB + +!iRout = 233 +!iPrint = nPrint(iRout) + +do iCar=1,3 + lla = 0 + llb = 0 + llcd = 0 + if (IfGrd(iCar,1)) lla = max(1,lla) + if (IfHss(1,iCar,1,iCar)) lla = 2 + if (IfGrd(iCar,2)) llb = max(1,llb) + if (IfHss(2,iCar,2,iCar)) llb = 2 + if (IfGrd(iCar,3) .or. IfGrd(iCar,4)) llcd = max(1,llcd) + if (IfHss(3,iCar,3,iCar) .or. IfHss(4,iCar,4,iCar)) llcd = 2 + AB = A(iCar)-B(iCar) + if (AB == Zero) then + do icd=0,lc+ld+llcd + ! Using the identity + do ia=0,la+lla + do ib=0,lb+llb + iab = ia+ib + if (iab > la+lb+max(lla,llb)) cycle + Arr2(:,ia,ib,icd,iCar) = Arr1(:,iCar,iab,icd) + end do + end do + end do + else if (la >= lb) then + do icd=0,lc+ld+llcd + ! Move the first row I(ia,0) + do ia=0,la+lb+max(lla,llb) + ja = ia + jb = 0 + if (ja > la+2) then + ja = ja-(la+3) + jb = 1 + end if + Arr2(:,ja,jb,icd,iCar) = Arr1(:,iCar,ia,icd) + end do + ! Generate I(ia,ib) for fixed ib + do ib=1,lb+llb + do ia=la+lb+max(lla,llb)-ib,0,-1 + ja = ia + jb = ib + mb = ib-1 + if (ja > la+2) then + ja = ja-(la+3) + jb = jb+1 + mb = mb+1 + end if + ma = ja + ka = ia+1 + kb = ib-1 + if (ka > la+2) then + ka = ka-(la+3) + kb = kb+1 + end if + Arr2(:,ja,jb,icd,iCar) = AB*Arr2(:,ma,mb,icd,iCar)+Arr2(:,ka,kb,icd,iCar) + end do + end do + end do + else + AB = -AB + do icd=0,lc+ld+llcd + ! Move the first row I(0,ib) + do ib=0,la+lb+max(lla,llb) + jb = ib + ja = 0 + if (jb > lb+2) then + jb = jb-(lb+3) + ja = 1 + end if + Arr2(:,ja,jb,icd,iCar) = Arr1(:,iCar,ib,icd) + end do + ! Generate I(ia,ib) for fixed ia + do ia=1,la+lla + do ib=la+lb+max(lla,llb)-ia,0,-1 + jb = ib + ja = ia + ma = ia-1 + if (jb > lb+2) then + jb = jb-(lb+3) + ja = ja+1 + ma = ma+1 + end if + mb = jb + kb = ib+1 + ka = ia-1 + if (kb > lb+2) then + kb = kb-(lb+3) + ka = ka+1 + end if + Arr2(:,ja,jb,icd,iCar) = AB*Arr2(:,ma,mb,icd,iCar)+Arr2(:,ka,kb,icd,iCar) + end do + end do + end do + end if +end do + +return + +end subroutine HRR2Da_mck diff -Nru openmolcas-22.02/src/rys_util/hrr2db.f openmolcas-22.10/src/rys_util/hrr2db.f --- openmolcas-22.02/src/rys_util/hrr2db.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/hrr2db.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,152 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1991,1992, Roland Lindh * -************************************************************************ - SubRoutine Hrr2Db(Arr1,nVec,ncdMax,Arr2,C,D,la,lb,lc,ld,IfGrad) -************************************************************************ -* * -* Object: to apply the transfer equation to the 2D-integrals. * -* The transformation is in place and the recursion * -* is replaced with the indentity when applicable. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* September '91 * -* Modified to recurrence algorithm, February '92 * -* Improved algorithm, June '92. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 C(3), D(3), - & Arr1(nVec,0:la+1,0:lb+1,0:ncdMax,3), - & Arr2(nVec,0:la+1,0:lb+1,0:lc+1,0:ld+1,3) - Logical IfGrad(3,4) -* -* iQ = 0 -* - Do 10 iCar = 1, 3 - llc = 0 - If(IfGrad(iCar,3)) llc = 1 - lld = 0 - If(IfGrad(iCar,4)) lld = 1 - lla = 0 - If(IfGrad(iCar,1)) lla = 1 - llb = 0 - If(IfGrad(iCar,2)) llb = 1 -* - CD = C(iCar)-D(iCar) - If (CD.eq.Zero) Then - Do 100 ia = 0, la+lla - Do 101 ib = 0, lb+llb - If (ia+ib.gt.la+lb+Max(lla,llb)) Go To 101 -*--------------Using the identity - Do 200 ic = 0, lc+llc - Do 210 id = 0, ld+lld - icd = ic + id - If (icd.gt.lc+ld+Max(llc,lld)) Go To 210 - do i=1,nVec - Arr2(i,ia,ib,ic,id,iCar)=Arr1(i,ia,ib,icd,iCar) - enddo -210 Continue -200 Continue -101 Continue -100 Continue - Else - If (lc.ge.ld) Then - Do 102 ia = 0, la+lla - Do 103 ib = 0, lb+llb - If (ia+ib.gt.la+lb+Max(lla,llb)) Go To 103 -*-----------------Move the first row I(ic,0) - Do 20 ic = 0, lc+ld+Max(llc,lld) - jc = ic - jd = 0 - If (jc.gt.lc+1) Then - jc = jc - (lc+2) - jd = 1 - End If - do i=1,nVec - Arr2(i,ia,ib,jc,jd,iCar)=Arr1(i,ia,ib,ic,iCar) - enddo - 20 Continue -*-----------------Generate I(ic,id) for fixed id - Do 30 id = 1, ld + lld - Do 31 ic = lc+ld+Max(llc,lld)-id, 0, -1 - jc = ic - jd = id - md = id-1 - If (jc.gt.lc+1) Then - jc = jc - (lc+2) - jd = jd + 1 - md = md + 1 - End If - mc = jc - kc = ic+1 - kd = id-1 - If (kc.gt.lc+1) Then - kc = kc - (lc+2) - kd = kd + 1 - End If - Call DZaXpY(nVec,CD,Arr2(1,ia,ib,mc,md,iCar),1, - & Arr2(1,ia,ib,kc,kd,iCar),1, - & Arr2(1,ia,ib,jc,jd,iCar),1) - 31 Continue - 30 Continue - 103 Continue - 102 Continue - Else - CD = -CD - Do 104 ia = 0, la+lla - Do 105 ib = 0, lb+llb - If (ia+ib.gt.la+lb+Max(lla,llb)) Go To 105 -*-----------------Move the first row I(0,id) - Do 40 id = 0, lc+ld+Max(llc,lld) - jd = id - jc = 0 - If (jd.gt.ld+1) Then - jd = jd - (ld+2) - jc = 1 - End If - do i=1,nVec - Arr2(i,ia,ib,jc,jd,iCar)=Arr1(i,ia,ib,id,iCar) - enddo - 40 Continue -*-----------------Generate I(ic,id) for fixed ic - Do 50 ic = 1, lc + llc - Do 51 id = lc+ld+Max(llc,lld)-ic, 0, -1 - jd = id - jc = ic - mc = ic-1 - If (jd.gt.ld+1) Then - jd = jd - (ld+2) - jc = jc + 1 - mc = mc + 1 - End If - md = jd - kd = id+1 - kc = ic-1 - If (kd.gt.ld+1) Then - kd = kd - (ld+2) - kc = kc + 1 - End If - Call DZaXpY(nVec,CD,Arr2(1,ia,ib,mc,md,iCar),1, - & Arr2(1,ia,ib,kc,kd,iCar),1, - & Arr2(1,ia,ib,jc,jd,iCar),1) - 51 Continue - 50 Continue - 105 Continue - 104 Continue - End If - End If - 10 Continue -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/hrr2db.F90 openmolcas-22.10/src/rys_util/hrr2db.F90 --- openmolcas-22.02/src/rys_util/hrr2db.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/hrr2db.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,146 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1991,1992, Roland Lindh * +!*********************************************************************** + +subroutine Hrr2Db(Arr1,nVec,ncdMax,Arr2,C,D,la,lb,lc,ld,IfGrad) +!*********************************************************************** +! * +! Object: to apply the transfer equation to the 2D-integrals. * +! The transformation is in place and the recursion * +! is replaced with the indentity when applicable. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! September '91 * +! Modified to recurrence algorithm, February '92 * +! Improved algorithm, June '92. * +!*********************************************************************** + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nVec, ncdMax, la, lb, lc, ld +real(kind=wp), intent(in) :: Arr1(nVec,0:la+1,0:lb+1,0:ncdMax,3), C(3), D(3) +real(kind=wp), intent(out) :: Arr2(nVec,0:la+1,0:lb+1,0:lc+1,0:ld+1,3) +logical(kind=iwp), intent(in) :: IfGrad(3,4) +integer(kind=iwp) :: ia, ib, ic, iCar, icd, id, jc, jd, kc, kd, lla, llb, llc, lld, mc, md +real(kind=wp) :: CD + +!iQ = 0 + +do iCar=1,3 + llc = 0 + if (IfGrad(iCar,3)) llc = 1 + lld = 0 + if (IfGrad(iCar,4)) lld = 1 + lla = 0 + if (IfGrad(iCar,1)) lla = 1 + llb = 0 + if (IfGrad(iCar,2)) llb = 1 + + CD = C(iCar)-D(iCar) + if (CD == Zero) then + do ia=0,la+lla + do ib=0,lb+llb + if (ia+ib > la+lb+max(lla,llb)) cycle + ! Using the identity + do ic=0,lc+llc + do id=0,ld+lld + icd = ic+id + if (icd > lc+ld+max(llc,lld)) cycle + Arr2(:,ia,ib,ic,id,iCar) = Arr1(:,ia,ib,icd,iCar) + end do + end do + end do + end do + else if (lc >= ld) then + do ia=0,la+lla + do ib=0,lb+llb + if (ia+ib > la+lb+max(lla,llb)) cycle + ! Move the first row I(ic,0) + do ic=0,lc+ld+max(llc,lld) + jc = ic + jd = 0 + if (jc > lc+1) then + jc = jc-(lc+2) + jd = 1 + end if + Arr2(:,ia,ib,jc,jd,iCar) = Arr1(:,ia,ib,ic,iCar) + end do + ! Generate I(ic,id) for fixed id + do id=1,ld+lld + do ic=lc+ld+max(llc,lld)-id,0,-1 + jc = ic + jd = id + md = id-1 + if (jc > lc+1) then + jc = jc-(lc+2) + jd = jd+1 + md = md+1 + end if + mc = jc + kc = ic+1 + kd = id-1 + if (kc > lc+1) then + kc = kc-(lc+2) + kd = kd+1 + end if + Arr2(:,ia,ib,jc,jd,iCar) = CD*Arr2(:,ia,ib,mc,md,iCar)+Arr2(:,ia,ib,kc,kd,iCar) + end do + end do + end do + end do + else + CD = -CD + do ia=0,la+lla + do ib=0,lb+llb + if (ia+ib > la+lb+max(lla,llb)) cycle + ! Move the first row I(0,id) + do id=0,lc+ld+max(llc,lld) + jd = id + jc = 0 + if (jd > ld+1) then + jd = jd-(ld+2) + jc = 1 + end if + Arr2(:,ia,ib,jc,jd,iCar) = Arr1(:,ia,ib,id,iCar) + end do + ! Generate I(ic,id) for fixed ic + do ic=1,lc+llc + do id=lc+ld+max(llc,lld)-ic,0,-1 + jd = id + jc = ic + mc = ic-1 + if (jd > ld+1) then + jd = jd-(ld+2) + jc = jc+1 + mc = mc+1 + end if + md = jd + kd = id+1 + kc = ic-1 + if (kd > ld+1) then + kd = kd-(ld+2) + kc = kc+1 + end if + Arr2(:,ia,ib,jc,jd,iCar) = CD*Arr2(:,ia,ib,mc,md,iCar)+Arr2(:,ia,ib,kc,kd,iCar) + end do + end do + end do + end do + end if +end do + +return + +end subroutine Hrr2Db diff -Nru openmolcas-22.02/src/rys_util/hrr2db_mck.f openmolcas-22.10/src/rys_util/hrr2db_mck.f --- openmolcas-22.02/src/rys_util/hrr2db_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/hrr2db_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,163 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1991,1992, Roland Lindh * -************************************************************************ - SubRoutine Hrr2Db_mck(Arr1,nVec,ncdMax, - & Arr2,C,D,la,lb,lc,ld,IfHss, - & IfGrd ,nt,nrys) -************************************************************************ -* * -* Object: to apply the transfer equation to the 2D-integrals. * -* The transformation is in place and the recursion * -* is replaced with the indentity when applicable. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* September '91 * -* Modified to recurrence algorithm, February '92 * -* Improved algorithm, June '92. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -c#include "print.fh" -#include "real.fh" - Real*8 C(3), D(3), - & Arr1(nVec,0:la+2,0:lb+2,0:ncdMax,3), - & Arr2(nVec,0:la+2,0:lb+2,0:lc+2,0:ld+2,3) - Logical IfHss(4,3,4,3),ifgrd(3,4) -* -c iRout = 233 -c iPrint = nPrint(iRout) -* - Do 10 iCar = 1, 3 - llc = 0 - lld = 0 - lla = 0 - llb = 0 - If(IfGrd(iCar,3)) llc = Max(llc,1) - If(IfHss(3,iCar,3,iCar)) llc = 2 - If(IfGrd(iCar,4)) lld = Max(1,lld) - If(IfHss(4,iCar,4,iCar)) lld = 2 - If(IfGrd(iCar,1)) lla = Max(1,lla) - If(IfHss(1,iCar,1,iCar)) lla = 2 - If(IfGrd(iCar,2)) llb = Max(llb,1) - If(IfHss(2,iCar,2,iCar)) llb = 2 - CD = C(iCar)-D(iCar) - If (CD.eq.Zero) Then - Do 100 ia = 0, la+lla - Do 101 ib = 0, lb+llb - If (ia+ib.gt.la+lb+Max(lla,llb)) Go To 101 -*--------------Using the identity - Do 200 ic = 0, lc+llc - Do 210 id = 0, ld+lld - icd = ic + id - If (icd.gt.lc+ld+Max(llc,lld)) Go To 210 - do i=1,nVec - Arr2(i,ia,ib,ic,id,iCar)=Arr1(i,ia,ib,icd,iCar) - enddo -210 Continue -200 Continue -101 Continue -100 Continue - Else - If (lc.ge.ld) Then - Do 102 ia = 0, la+lla - Do 103 ib = 0, lb+llb - If (ia+ib.gt.la+lb+Max(lla,llb)) Go To 103 -*-----------------Move the first row I(ic,0) - Do 20 ic = 0, lc+ld+Max(llc,lld) - jc = ic - jd = 0 - If (jc.gt.lc+2) Then - jc = jc - (lc+3) - jd = 1 - End If - do i=1,nVec - Arr2(i,ia,ib,jc,jd,iCar)=Arr1(i,ia,ib,ic,iCar) - enddo - 20 Continue -*-----------------Generate I(ic,id) for fixed id - Do 30 id = 1, ld + lld - Do 31 ic = lc+ld+Max(llc,lld)-id, 0, -1 - jc = ic - jd = id - md = id-1 - If (jc.gt.lc+2) Then - jc = jc - (lc+3) - jd = jd + 1 - md = md + 1 - End If - mc = jc - kc = ic+1 - kd = id-1 - If (kc.gt.lc+2) Then - kc = kc - (lc+3) - kd = kd + 1 - End If - Call DZaXpY(nVec,CD,Arr2(1,ia,ib,mc,md,iCar),1, - & Arr2(1,ia,ib,kc,kd,iCar),1, - & Arr2(1,ia,ib,jc,jd,iCar),1) - 31 Continue - 30 Continue - 103 Continue - 102 Continue - Else - CD = -CD - Do 104 ia = 0, la+lla - Do 105 ib = 0, lb+llb - If (ia+ib.gt.la+lb+Max(lla,llb)) Go To 105 -*-----------------Move the first row I(0,id) - Do 40 id = 0, lc+ld+Max(llc,lld) - jd = id - jc = 0 - If (jd.gt.ld+2) Then - jd = jd - (ld+3) - jc = 1 - End If - do i=1,nVec - Arr2(i,ia,ib,jc,jd,iCar)=Arr1(i,ia,ib,id,iCar) - enddo - 40 Continue -*-----------------Generate I(ic,id) for fixed ic - Do 50 ic = 1, lc + llc - Do 51 id = lc+ld+Max(llc,lld)-ic, 0, -1 - jd = id - jc = ic - mc = ic-1 - If (jd.gt.ld+2) Then - jd = jd - (ld+3) - jc = jc + 1 - mc = mc + 1 - End If - md = jd - kd = id+1 - kc = ic-1 - If (kd.gt.ld+2) Then - kd = kd - (ld+3) - kc = kc + 1 - End If - Call DZaXpY(nVec,CD,Arr2(1,ia,ib,mc,md,iCar),1, - & Arr2(1,ia,ib,kc,kd,iCar),1, - & Arr2(1,ia,ib,jc,jd,iCar),1) - 51 Continue - 50 Continue - 105 Continue - 104 Continue - End If - End If - 10 Continue -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(nt) - Call Unused_integer(nrys) - End If - End diff -Nru openmolcas-22.02/src/rys_util/hrr2db_mck.F90 openmolcas-22.10/src/rys_util/hrr2db_mck.F90 --- openmolcas-22.02/src/rys_util/hrr2db_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/hrr2db_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,150 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1991,1992, Roland Lindh * +!*********************************************************************** + +subroutine Hrr2Db_mck(Arr1,nVec,ncdMax,Arr2,C,D,la,lb,lc,ld,IfHss,IfGrd) +!*********************************************************************** +! * +! Object: to apply the transfer equation to the 2D-integrals. * +! The transformation is in place and the recursion * +! is replaced with the indentity when applicable. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! September '91 * +! Modified to recurrence algorithm, February '92 * +! Improved algorithm, June '92. * +!*********************************************************************** + +use Constants, only: Zero +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nVec, ncdMax, la, lb, lc, ld +real(kind=wp), intent(in) :: Arr1(nVec,0:la+2,0:lb+2,0:ncdMax,3), C(3), D(3) +real(kind=wp), intent(out) :: Arr2(nVec,0:la+2,0:lb+2,0:lc+2,0:ld+2,3) +logical(kind=iwp), intent(in) :: IfHss(4,3,4,3), ifGrd(3,4) +integer(kind=iwp) :: ia, ib, ic, iCar, icd, id, jc, jd, kc, kd, lla, llb, llc, lld, mc, md +real(kind=wp) :: CD + +!iRout = 233 +!iPrint = nPrint(iRout) + +do iCar=1,3 + llc = 0 + lld = 0 + lla = 0 + llb = 0 + if (IfGrd(iCar,3)) llc = max(llc,1) + if (IfHss(3,iCar,3,iCar)) llc = 2 + if (IfGrd(iCar,4)) lld = max(1,lld) + if (IfHss(4,iCar,4,iCar)) lld = 2 + if (IfGrd(iCar,1)) lla = max(1,lla) + if (IfHss(1,iCar,1,iCar)) lla = 2 + if (IfGrd(iCar,2)) llb = max(llb,1) + if (IfHss(2,iCar,2,iCar)) llb = 2 + CD = C(iCar)-D(iCar) + if (CD == Zero) then + do ia=0,la+lla + do ib=0,lb+llb + if (ia+ib > la+lb+max(lla,llb)) cycle + ! Using the identity + do ic=0,lc+llc + do id=0,ld+lld + icd = ic+id + if (icd > lc+ld+max(llc,lld)) cycle + Arr2(:,ia,ib,ic,id,iCar) = Arr1(:,ia,ib,icd,iCar) + end do + end do + end do + end do + else if (lc >= ld) then + do ia=0,la+lla + do ib=0,lb+llb + if (ia+ib > la+lb+max(lla,llb)) cycle + ! Move the first row I(ic,0) + do ic=0,lc+ld+max(llc,lld) + jc = ic + jd = 0 + if (jc > lc+2) then + jc = jc-(lc+3) + jd = 1 + end if + Arr2(:,ia,ib,jc,jd,iCar) = Arr1(:,ia,ib,ic,iCar) + end do + ! Generate I(ic,id) for fixed id + do id=1,ld+lld + do ic=lc+ld+max(llc,lld)-id,0,-1 + jc = ic + jd = id + md = id-1 + if (jc > lc+2) then + jc = jc-(lc+3) + jd = jd+1 + md = md+1 + end if + mc = jc + kc = ic+1 + kd = id-1 + if (kc > lc+2) then + kc = kc-(lc+3) + kd = kd+1 + end if + Arr2(:,ia,ib,jc,jd,iCar) = CD*Arr2(:,ia,ib,mc,md,iCar)+Arr2(:,ia,ib,kc,kd,iCar) + end do + end do + end do + end do + else + CD = -CD + do ia=0,la+lla + do ib=0,lb+llb + if (ia+ib > la+lb+max(lla,llb)) cycle + ! Move the first row I(0,id) + do id=0,lc+ld+max(llc,lld) + jd = id + jc = 0 + if (jd > ld+2) then + jd = jd-(ld+3) + jc = 1 + end if + Arr2(:,ia,ib,jc,jd,iCar) = Arr1(:,ia,ib,id,iCar) + end do + ! Generate I(ic,id) for fixed ic + do ic=1,lc+llc + do id=lc+ld+max(llc,lld)-ic,0,-1 + jd = id + jc = ic + mc = ic-1 + if (jd > ld+2) then + jd = jd-(ld+3) + jc = jc+1 + mc = mc+1 + end if + md = jd + kd = id+1 + kc = ic-1 + if (kd > ld+2) then + kd = kd-(ld+3) + kc = kc+1 + end if + Arr2(:,ia,ib,jc,jd,iCar) = CD*Arr2(:,ia,ib,mc,md,iCar)+Arr2(:,ia,ib,kc,kd,iCar) + end do + end do + end do + end do + end if +end do + +return + +end subroutine Hrr2Db_mck diff -Nru openmolcas-22.02/src/rys_util/hrrctl.f openmolcas-22.10/src/rys_util/hrrctl.f --- openmolcas-22.02/src/rys_util/hrrctl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/hrrctl.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1992, Roland Lindh * -************************************************************************ - SubRoutine HrrCtl(Arr1,nArr1,Arr2,nArr2, - & la,lb,lc,ld,nabMax,ncdMax,nTR, - & A,B,C,D,IfGrad) -************************************************************************ -* * -* Object: to act as a shell towards the HRR subroutines. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Arr1(nTR,3*nArr1), Arr2(nTR,3*nArr2), - & A(3), B(3), C(3), D(3) - Logical IfGrad(3,4) -* - Call Hrr2Da(Arr1,nTR,nabMax,ncdMax,Arr2,A,B,la,lb,lc,ld,IfGrad) -* - Call Hrr2Db(Arr2,nTR, ncdMax,Arr1,C,D,la,lb,lc,ld,IfGrad) -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/hrrctl.F90 openmolcas-22.10/src/rys_util/hrrctl.F90 --- openmolcas-22.02/src/rys_util/hrrctl.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/hrrctl.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,38 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1992, Roland Lindh * +!*********************************************************************** + +subroutine HrrCtl(Arr1,nArr1,Arr2,nArr2,la,lb,lc,ld,nabMax,ncdMax,nTR,A,B,C,D,IfGrad) +!*********************************************************************** +! * +! Object: to act as a shell towards the HRR subroutines. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +!*********************************************************************** + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArr1, nArr2, la, lb, lc, ld, nabMax, ncdMax, nTR +real(kind=wp), intent(inout) :: Arr1(nTR,3*nArr1) +real(kind=wp), intent(out) :: Arr2(nTR,3*nArr2) +real(kind=wp), intent(in) :: A(3), B(3), C(3), D(3) +logical(kind=iwp), intent(in) :: IfGrad(3,4) + +call Hrr2Da(Arr1,nTR,nabMax,ncdMax,Arr2,A,B,la,lb,lc,ld,IfGrad) + +call Hrr2Db(Arr2,nTR,ncdMax,Arr1,C,D,la,lb,lc,ld,IfGrad) + +return + +end subroutine HrrCtl diff -Nru openmolcas-22.02/src/rys_util/hrrctl_mck.f openmolcas-22.10/src/rys_util/hrrctl_mck.f --- openmolcas-22.02/src/rys_util/hrrctl_mck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/hrrctl_mck.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1992, Roland Lindh * -************************************************************************ - SubRoutine HrrCtl_mck(Arr1,nArr1,Arr2,nArr2, - & la,lb,lc,ld,nabMax,ncdMax,nTR, - & A,B,C,D,IfHss,IfGrd,nt,nrys) -************************************************************************ -* * -* Object: to act as a shell towards the HRR subroutines. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -c#include "print.fh" -#include "real.fh" - Real*8 Arr1(nTR,3*nArr1), Arr2(nTR,3*nArr2), - & A(3), B(3), C(3), D(3) - Logical IfHss(4,3,4,3),IfGrd(3,4) -* -c iRout = 233 -c iPrint = nPrint(iRout) -* - Call Hrr2Da_mck(Arr1,nTR,nabMax,ncdMax,Arr2,A,B, - & la,lb,lc,ld,IfHss, - & IfGrd) -* - Call Hrr2Db_mck(Arr2,nTR, ncdMax,Arr1,C,D, - & la,lb,lc,ld,IfHss, - & IfGrd,nt,nrys) -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/hrrctl_mck.F90 openmolcas-22.10/src/rys_util/hrrctl_mck.F90 --- openmolcas-22.02/src/rys_util/hrrctl_mck.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/hrrctl_mck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,38 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1992, Roland Lindh * +!*********************************************************************** + +subroutine HrrCtl_mck(Arr1,nArr1,Arr2,nArr2,la,lb,lc,ld,nabMax,ncdMax,nTR,A,B,C,D,IfHss,IfGrd) +!*********************************************************************** +! * +! Object: to act as a shell towards the HRR subroutines. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +!*********************************************************************** + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArr1, nArr2, la, lb, lc, ld, nabMax, ncdMax, nTR +real(kind=wp), intent(inout) :: Arr1(nTR,3*nArr1) +real(kind=wp), intent(out) :: Arr2(nTR,3*nArr2) +real(kind=wp), intent(in) :: A(3), B(3), C(3), D(3) +logical(kind=iwp), intent(in) :: IfHss(4,3,4,3), IfGrd(3,4) + +call Hrr2Da_mck(Arr1,nTR,nabMax,ncdMax,Arr2,A,B,la,lb,lc,ld,IfHss,IfGrd) + +call Hrr2Db_mck(Arr2,nTR,ncdMax,Arr1,C,D,la,lb,lc,ld,IfHss,IfGrd) + +return + +end subroutine HrrCtl_mck diff -Nru openmolcas-22.02/src/rys_util/leg_rw.f openmolcas-22.10/src/rys_util/leg_rw.f --- openmolcas-22.02/src/rys_util/leg_rw.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/leg_rw.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,68 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 2017, Ignacio Fdez. Galvan * -************************************************************************ -* -* Compute and store roots and weights for a shifted Legendre quadrature, -* used for boot-strapping Rys roots and weights. -* Different sets of roots and weights are computed -* - Module Leg_RW - Implicit None - Integer, Dimension(11), Parameter :: naux=[30,35,40,45,50, - & 55,60,65,70,75,300] - Real*8, Dimension(:,:), Allocatable :: Leg_r, Leg_w - - Contains - - Subroutine SetAux(eps) - Real*8, Intent(In) :: eps - Integer, Parameter :: nquad=Size(naux) - Real*8, Dimension(:), Allocatable :: a, b - Integer :: maux, i, j, Err -#include "stdalloc.fh" -#include "real.fh" - If (Allocated(Leg_r)) Return - maux = MaxVal(naux) - Call mma_allocate(Leg_r,maux,nquad,label="Leg_r") - Call mma_allocate(Leg_w,maux,nquad,label="Leg_w") - Call mma_allocate(a,maux) - Call mma_allocate(b,maux) - Do j = 1, nquad - Do i = 1, naux(j) - a(i) = Half - If (i == 1) Then - b(1) = One - Else - b(i) = Quart/(Four-One/(i-1)**2) - End If - End Do - Call GaussQuad(naux(j),a,b,eps,Leg_r(1,j),Leg_w(1,j),Err) - If (Err.ne.0) Then - write(6,*) Err - Call WarningMessage(2,'Error in GaussQuad') - Call AbEnd() - End If - Do i = 1, naux(j) - Leg_r(i,j)=Leg_r(i,j)*Leg_r(i,j) - End Do - End Do - Call mma_deallocate(a) - Call mma_deallocate(b) - End Subroutine SetAux - - Subroutine UnSetAux -#include "stdalloc.fh" - If (Allocated(Leg_r)) Call mma_deallocate(Leg_r) - If (Allocated(Leg_w)) Call mma_deallocate(Leg_w) - End Subroutine UnSetAux - - End Module Leg_RW diff -Nru openmolcas-22.02/src/rys_util/memrg1.f openmolcas-22.10/src/rys_util/memrg1.f --- openmolcas-22.02/src/rys_util/memrg1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/memrg1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,87 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991, Roland Lindh * -* 1990, IBM * -************************************************************************ - Subroutine MemRg1(iAnga,nRys,MemPrm) -************************************************************************ -* * -* Modified to gradients 1991 R. Lindh, Dept. of Theoretical Chemistry, * -* University of Lund. * -************************************************************************ - Implicit Real*8 (a-h,o-z) -* -* This routine will compute the memory requirement of Rysg1 -* Memory requirement is per primitive! -* -c#include "print.fh" -#include "itmax.fh" - Integer iAnga(4) -* -* Statement function -* -* nElem(i) = (i+1)*(i+2)/2 -* -c iRout = 13 -c iPrint = nPrint(iRout) - la = iAnga(1) - lb = iAnga(2) - lc = iAnga(3) - ld = iAnga(4) - nRys = (la+lb+lc+ld+2 +1)/2 -* - MemPrm = 0 -* nPAO = nElem(la)*nElem(lb)*nElem(lc)*nElem(ld) -* 1st order gradient of [ab|cd] -* MemPrm = MemPrm + nPAO * 9 - nabMax = la+lb +1 - ncdMax = lc+ld +1 - nabcd = (nabMax+1)*(ncdMax+1) - lB10=Max(Min(nabMax-1,1),0) - lB01=Max(Min(ncdMax-1,1),0) - lB00=Max(Min(Min(nabMax,ncdMax),1),0) -* 2D-Integrals - n2D0=Max(nabcd, - & (la+2)*(lb+2)*(ncdMax+1), - & (la+2)*(lb+2)*(lc+2)*(ld+2)) - MemPrm = MemPrm + 3*nRys*n2D0 -* 1st order gradient of the 2D-integrals - n2D1=Max(nabcd, - & (la+2)*(lb+2)*(ncdMax+1), - & (la+1)*(lb+1)*(lc+1)*(ld+1)*3) - MemPrm = MemPrm + 3*nRys*n2D1 -* Coefficients for recurrence relations - MemPrm = MemPrm + 3*nRys + 3*nRys + 3*nRys*(lB10+lB01+lB00) -* Roots - MemPrm = MemPrm + nRys -* The inverse of the arguments - MemPrm = MemPrm + 1 -* Arguments - MemPrm = MemPrm + 1 -* Expanded versions of Zeta, ZetInv, Eta, EtaInv, -* P and Q - MemPrm = MemPrm + 10 -* If (iPrint.ge.99) Then -* Write (*,*) ' [ab|cd] 1st grad. :', nPAO*9 -* Write (*,*) ' 2D-integrals :', n2D0*3*nRys -* Write (*,*) ' 2D-integrals (1st) :', n2D1*3*nRys -* Write (*,*) ' PAQP vector :', 3*nRys -* Write (*,*) ' QCPQ vector :', 3*nRys -* Write (*,*) ' B10 coefficients :', nRys*3*lB10 -* Write (*,*) ' B00 coefficients :', nRys*3*lB00 -* Write (*,*) ' B01 coefficients :', nRys*3*lB01 -* Write (*,*) ' Roots :', nRys -* Write (*,*) ' Inverse arguments :', 1 -* Write (*,*) ' Arguments :', 1 -* End If -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/memrg1.F90 openmolcas-22.10/src/rys_util/memrg1.F90 --- openmolcas-22.02/src/rys_util/memrg1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/memrg1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,81 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine MemRg1(iAnga,nRys,MemPrm) +!*********************************************************************** +! This routine will compute the memory requirement of Rysg1 * +! Memory requirement is per primitive! * +! * +! Modified to gradients 1991 R. Lindh, Dept. of Theoretical Chemistry, * +! University of Lund. * +!*********************************************************************** + +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: iAnga(4) +integer(kind=iwp), intent(out) :: nRys, MemPrm +integer(kind=iwp) :: la, lb, lB00, lB01, lB10, lc, ld, n2D0, n2D1, nabcd, nabMax, ncdMax + +!iRout = 13 +!iPrint = nPrint(iRout) +la = iAnga(1) +lb = iAnga(2) +lc = iAnga(3) +ld = iAnga(4) +nRys = (la+lb+lc+ld+2+1)/2 + +MemPrm = 0 +!nPAO = nTri_Elem1(la)*nTri_Elem1(lb)*nTri_Elem1(lc)*nTri_Elem1(ld) +! 1st order gradient of [ab|cd] +!MemPrm = MemPrm+nPAO*9 +nabMax = la+lb+1 +ncdMax = lc+ld+1 +nabcd = (nabMax+1)*(ncdMax+1) +lB10 = max(min(nabMax-1,1),0) +lB01 = max(min(ncdMax-1,1),0) +lB00 = max(min(min(nabMax,ncdMax),1),0) +! 2D-Integrals +n2D0 = max(nabcd,(la+2)*(lb+2)*(ncdMax+1),(la+2)*(lb+2)*(lc+2)*(ld+2)) +MemPrm = MemPrm+3*nRys*n2D0 +! 1st order gradient of the 2D-integrals +n2D1 = max(nabcd,(la+2)*(lb+2)*(ncdMax+1),(la+1)*(lb+1)*(lc+1)*(ld+1)*3) +MemPrm = MemPrm+3*nRys*n2D1 +! Coefficients for recurrence relations +MemPrm = MemPrm+3*nRys+3*nRys+3*nRys*(lB10+lB01+lB00) +! Roots +MemPrm = MemPrm+nRys +! The inverse of the arguments +MemPrm = MemPrm+1 +! Arguments +MemPrm = MemPrm+1 +! Expanded versions of Zeta, ZetInv, Eta, EtaInv, P and Q +MemPrm = MemPrm+10 +!if (iPrint >= 99) then +! write(u6,*) ' [ab|cd] 1st grad. :',nPAO*9 +! write(u6,*) ' 2D-integrals :',n2D0*3*nRys +! write(u6,*) ' 2D-integrals (1st) :',n2D1*3*nRys +! write(u6,*) ' PAQP vector :',3*nRys +! write(u6,*) ' QCPQ vector :',3*nRys +! write(u6,*) ' B10 coefficients :',nRys*3*lB10 +! write(u6,*) ' B00 coefficients :',nRys*3*lB00 +! write(u6,*) ' B01 coefficients :',nRys*3*lB01 +! write(u6,*) ' Roots :',nRys +! write(u6,*) ' Inverse arguments :',1 +! write(u6,*) ' Arguments :',1 +!end if + +return + +end subroutine MemRg1 diff -Nru openmolcas-22.02/src/rys_util/memrg2.f openmolcas-22.10/src/rys_util/memrg2.f --- openmolcas-22.02/src/rys_util/memrg2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/memrg2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,104 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991, Roland Lindh * -* 1990, IBM * -* 1995, Anders Bernhardsson * -************************************************************************ - Subroutine MemRg2(iAnga,nRys,MemPrm,ider) -************************************************************************ -* * -* Modified to gradients 1991 R. Lindh, Dept. of Theoretical Chemistry, * -* University of Lund. * -* Modified to hessians 1995 Anders Bernhardsson Dept. of Theoretical * -* Chemistry, University of Lund. * -************************************************************************ - Implicit Real*8 (a-h,o-z) -* -* This routine will compute the memory requirement of Rysg2 -* Memory requirement is per primitive! -* -c#include "print.fh" -#include "itmax.fh" - Integer iAnga(4) -* -* Statement function -* - nElem(i) = (i+1)*(i+2)/2 -* -c iRout = 13 -c iPrint = nPrint(iRout) - la = iAnga(1) - lb = iAnga(2) - lc = iAnga(3) - ld = iAnga(4) - nRys = (la+lb+lc+ld+2 +ider)/2 -* - MemPrm = 0 - nPAO = nElem(la)*nElem(lb)*nElem(lc)*nElem(ld) -* 1st order gradient of [ab|cd] - MemPrm = MemPrm + nPAO *9 -* - nabMax = la+lb +2 - ncdMax = lc+ld +2 - nabcd = (nabMax+1)*(ncdMax+1) -* lB10=Max(Min(nabMax-1,1),0) -* lB01=Max(Min(ncdMax-1,1),0) -* lB00=Max(Min(Min(nabMax,ncdMax),1),0) - lB10=1 - lB01=1 - lB00=1 -* -* 2D-Integrals -* - n2D0=Max(nabcd, - & (la+3)*(lb+3)*(ncdMax+1), - & (la+3)*(lb+3)*(lc+3)*(ld+3)) - MemPrm = MemPrm + 3*nRys*n2D0 -* -* 1st order gradient of the 2D-integrals -* - n2D1=Max(nabcd, - & (la+3)*(lb+3)*(ncdMax+1), - & (la+1)*(lb+1)*(lc+1)*(ld+1)*3) - n2D2=(la+1)*(lb+1)*(lc+1)*(ld+1)*6 - MemPrm = MemPrm + 3*nRys*n2D1 - MemPrm3=3*nRys*n2D2+3*nRys -* -* Coefficients for recurrence relations -* - MemPrm2 = 3*nRys + 3*nRys + 3*nRys*(lB10+lB01+lB00) -* Roots - MemPrm2 = MemPrm2 + nRys -* The inverse of the arguments - MemPrm2 = MemPrm2 + 1 -* Arguments - MemPrm2 = MemPrm2 + 1 -* Expanded versions of Zeta, ZetInv, Eta, EtaInv, -* P and Q - MemPrm = MemPrm + 10 -* If (iPrint.ge.99) Then -* Write (*,*) ' [ab|cd] 1st grad. :', nPAO*9 -* Write (*,*) ' 2D-integrals :', n2D0*3*nRys -* Write (*,*) ' 2D-integrals (1st) :', n2D1*3*nRys -* Write (*,*) ' 2D-integrals (2nd) :', n2D2*3*nRys -* Write (*,*) ' PAQP vector :', 3*nRys -* Write (*,*) ' QCPQ vector :', 3*nRys -* Write (*,*) ' B10 coefficients :', nRys*3*lB10 -* Write (*,*) ' B00 coefficients :', nRys*3*lB00 -* Write (*,*) ' B01 coefficients :', nRys*3*lB01 -* Write (*,*) ' Roots :', nRys -* Write (*,*) ' Inverse arguments :', 1 -* Write (*,*) ' Arguments :', 1 -* End If - MemPrm=MemPrm+Max(MemPrm2,MemPrm3) -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/memrg2.F90 openmolcas-22.10/src/rys_util/memrg2.F90 --- openmolcas-22.02/src/rys_util/memrg2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/memrg2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,99 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991, Roland Lindh * +! 1990, IBM * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine MemRg2(iAnga,nRys,MemPrm,ider) +!*********************************************************************** +! This routine will compute the memory requirement of Rysg2 * +! Memory requirement is per primitive! * +! * +! Modified to gradients 1991 R. Lindh, Dept. of Theoretical Chemistry, * +! University of Lund. * +! Modified to hessians 1995 Anders Bernhardsson Dept. of Theoretical * +! Chemistry, University of Lund. * +!*********************************************************************** + +use Index_Functions, only: nTri_Elem1 +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: iAnga(4), ider +integer(kind=iwp), intent(out) :: nRys, MemPrm +integer(kind=iwp) :: la, lb, lB00, lB01, lB10, lc, ld, MemPrm2, MemPrm3, n2D0, n2D1, n2D2, nabcd, nabMax, ncdMax, nPAO + +!iRout = 13 +!iPrint = nPrint(iRout) +la = iAnga(1) +lb = iAnga(2) +lc = iAnga(3) +ld = iAnga(4) +nRys = (la+lb+lc+ld+2+ider)/2 + +MemPrm = 0 +nPAO = nTri_Elem1(la)*nTri_Elem1(lb)*nTri_Elem1(lc)*nTri_Elem1(ld) +! 1st order gradient of [ab|cd] +MemPrm = MemPrm+nPAO*9 + +nabMax = la+lb+2 +ncdMax = lc+ld+2 +nabcd = (nabMax+1)*(ncdMax+1) +!lB10 = max(min(nabMax-1,1),0) +!lB01 = max(min(ncdMax-1,1),0) +!lB00 = max(min(Min(nabMax,ncdMax),1),0) +lB10 = 1 +lB01 = 1 +lB00 = 1 + +! 2D-Integrals + +n2D0 = max(nabcd,(la+3)*(lb+3)*(ncdMax+1),(la+3)*(lb+3)*(lc+3)*(ld+3)) +MemPrm = MemPrm+3*nRys*n2D0 + +! 1st order gradient of the 2D-integrals + +n2D1 = max(nabcd,(la+3)*(lb+3)*(ncdMax+1),(la+1)*(lb+1)*(lc+1)*(ld+1)*3) +n2D2 = (la+1)*(lb+1)*(lc+1)*(ld+1)*6 +MemPrm = MemPrm+3*nRys*n2D1 +MemPrm3 = 3*nRys*n2D2+3*nRys + +! Coefficients for recurrence relations + +MemPrm2 = 3*nRys+3*nRys+3*nRys*(lB10+lB01+lB00) +! Roots +MemPrm2 = MemPrm2+nRys +! The inverse of the arguments +MemPrm2 = MemPrm2+1 +! Arguments +MemPrm2 = MemPrm2+1 +! Expanded versions of Zeta, ZetInv, Eta, EtaInv, P and Q +MemPrm = MemPrm+10 +!if (iPrint >=99) then +! write(u6,*) ' [ab|cd] 1st grad. :',nPAO*9 +! write(u6,*) ' 2D-integrals :',n2D0*3*nRys +! write(u6,*) ' 2D-integrals (1st) :',n2D1*3*nRys +! write(u6,*) ' 2D-integrals (2nd) :',n2D2*3*nRys +! write(u6,*) ' PAQP vector :',3*nRys +! write(u6,*) ' QCPQ vector :',3*nRys +! write(u6,*) ' B10 coefficients :',nRys*3*lB10 +! write(u6,*) ' B00 coefficients :',nRys*3*lB00 +! write(u6,*) ' B01 coefficients :',nRys*3*lB01 +! write(u6,*) ' Roots :',nRys +! write(u6,*) ' Inverse arguments :',1 +! write(u6,*) ' Arguments :',1 +!end if +MemPrm = MemPrm+max(MemPrm2,MemPrm3) + +return + +end subroutine MemRg2 diff -Nru openmolcas-22.02/src/rys_util/memrys.f openmolcas-22.10/src/rys_util/memrys.f --- openmolcas-22.02/src/rys_util/memrys.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/memrys.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,101 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - Subroutine MemRys(iAnga,MemPrm) - Implicit Real*8 (a-h,o-z) -* -* This routine will compute the memory requirement of RYS -* Memory requirement is per primitive! -* -#include "itmax.fh" -#include "print.fh" -#include "FMM.fh" -cgh - stuff for short range integrals -#include "srint.fh" - Integer iAnga(4) -* -* Statement function for canonical index, etc. -* - nabSz(ixyz) = (ixyz+1)*(ixyz+2)*(ixyz+3)/6 - 1 -* - iRout = 13 - iPrint = nPrint(iRout) - la = iAnga(1) - lb = iAnga(2) - lc = iAnga(3) - ld = iAnga(4) - nRys = (la+lb+lc+ld+2)/2 - labMin=nabSz(Max(la,lb)-1)+1 - labMax=nabSz(la+lb) - lcdMin=nabSz(Max(lc,ld)-1)+1 - lcdMax=nabSz(lc+ld) - labcd = (labMax-labMin+1)*(lcdMax-lcdMin+1) - If (iPrint.ge.99) Then - Write (6,*) ' labMin=',labMin - Write (6,*) ' labMax=',labMax - Write (6,*) ' lcdMin=',lcdMin - Write (6,*) ' lcdMax=',lcdMax - End If - MemPrm = 0 -* [a0|c0] - MemPrm = MemPrm + labcd -* * -************************************************************************ -* * -* For FMM, we only want short-range integrals, using twice the memory -* to store full and long-range components (which are subtracted) -* -same for MOLPRO shortrange -* - If (FMM_shortrange.or.shortrange) MemPrm = MemPrm + labcd -* * -************************************************************************ -* * - nabMax = la+lb -* nabMin = Max(la,lb) - ncdMax = lc+ld -* ncdMin = Max(lc,ld) - nabcd = (nabMax+1)*(ncdMax+1) - lB10=Max(Min(nabMax-1,1),0) - lB01=Max(Min(ncdMax-1,1),0) - lB00=Max(Min(Min(nabMax,ncdMax),1),0) -* Normalization - MemPrm = MemPrm + 1 -* 2D-Integrals - MemPrm = MemPrm + nabcd*3*nRys -* Coefficients for recurrence relations - MemPrm = MemPrm + 3*nRys + 3*nRys + 3*nRys*(lB10+lB01+lB00) -* Roots - MemPrm = MemPrm + nRys -* The inverse of the arguments - MemPrm = MemPrm + 1 -* Arguments - MemPrm = MemPrm + 1 -* Expanded versions of Zeta, ZetInv, Eta, EtaInv, -* rKapab, rKapcd, P and Q - MemPrm = MemPrm + 12 - If (iPrint.ge.99) Then - Write (6,*) ' [e0|f0] integrals :', labcd - Write (6,*) ' Normalization factor:', 1 - Write (6,*) ' 2D-integrals :', nabcd*3*nRys - Write (6,*) ' PAQP vector :', 3*nRys - Write (6,*) ' QCPQ vector :', 3*nRys - Write (6,*) ' B10 coefficients :', nRys*3*lB10 - Write (6,*) ' B00 coefficients :', nRys*3*lB00 - Write (6,*) ' B01 coefficients :', nRys*3*lB01 - Write (6,*) ' Roots :', nRys - Write (6,*) ' Inverse arguments :', 1 - Write (6,*) ' Arguments :', 1 - End If -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/memrys.F90 openmolcas-22.10/src/rys_util/memrys.F90 --- openmolcas-22.02/src/rys_util/memrys.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/memrys.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,99 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine MemRys(iAnga,MemPrm) +! This routine will compute the memory requirement of RYS +! Memory requirement is per primitive! + +use Gateway_global, only: FMM_shortrange +use Index_Functions, only: nTri3_Elem1 +use Definitions, only: iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iAnga(4) +integer(kind=iwp), intent(out) :: MemPrm +#include "print.fh" +integer(kind=iwp) :: iPrint, iRout, la, labcd, labMax, labMin, lb, lB00, lB01, lB10, lc, lcdMax, lcdMin, ld, nabcd, nabMax, & + ncdMax, nRys + +iRout = 13 +iPrint = nPrint(iRout) +la = iAnga(1) +lb = iAnga(2) +lc = iAnga(3) +ld = iAnga(4) +nRys = (la+lb+lc+ld+2)/2 +labMin = nTri3_Elem1(max(la,lb)-1) +labMax = nTri3_Elem1(la+lb)-1 +lcdMin = nTri3_Elem1(max(lc,ld)-1) +lcdMax = nTri3_Elem1(lc+ld)-1 +labcd = (labMax-labMin+1)*(lcdMax-lcdMin+1) +if (iPrint >= 99) then + write(u6,*) ' labMin=',labMin + write(u6,*) ' labMax=',labMax + write(u6,*) ' lcdMin=',lcdMin + write(u6,*) ' lcdMax=',lcdMax +end if +MemPrm = 0 +! [a0|c0] +MemPrm = MemPrm+labcd +! * +!*********************************************************************** +! * +! For FMM, we only want short-range integrals, using twice the memory +! to store full and long-range components (which are subtracted) + +if (FMM_shortrange) MemPrm = MemPrm+labcd +! * +!*********************************************************************** +! * +nabMax = la+lb +!nabMin = max(la,lb) +ncdMax = lc+ld +!ncdMin = max(lc,ld) +nabcd = (nabMax+1)*(ncdMax+1) +lB10 = max(min(nabMax-1,1),0) +lB01 = max(min(ncdMax-1,1),0) +lB00 = max(min(min(nabMax,ncdMax),1),0) +! Normalization +MemPrm = MemPrm+1 +! 2D-Integrals +MemPrm = MemPrm+nabcd*3*nRys +! Coefficients for recurrence relations +MemPrm = MemPrm+3*nRys+3*nRys+3*nRys*(lB10+lB01+lB00) +! Roots +MemPrm = MemPrm+nRys +! The inverse of the arguments +MemPrm = MemPrm+1 +! Arguments +MemPrm = MemPrm+1 +! Expanded versions of Zeta, ZetInv, Eta, EtaInv, rKapab, rKapcd, P and Q +MemPrm = MemPrm+12 +if (iPrint >= 99) then + write(u6,*) ' [e0|f0] integrals :',labcd + write(u6,*) ' Normalization factor:',1 + write(u6,*) ' 2D-integrals :',nabcd*3*nRys + write(u6,*) ' PAQP vector :',3*nRys + write(u6,*) ' QCPQ vector :',3*nRys + write(u6,*) ' B10 coefficients :',nRys*3*lB10 + write(u6,*) ' B00 coefficients :',nRys*3*lB00 + write(u6,*) ' B01 coefficients :',nRys*3*lB01 + write(u6,*) ' Roots :',nRys + write(u6,*) ' Inverse arguments :',1 + write(u6,*) ' Arguments :',1 +end if + +return + +end subroutine MemRys diff -Nru openmolcas-22.02/src/rys_util/memrys_g.f openmolcas-22.10/src/rys_util/memrys_g.f --- openmolcas-22.02/src/rys_util/memrys_g.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/memrys_g.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine MemRys_g(iSD4,nSD,nRys,MemPrm) - Implicit Real*8 (a-h,o-z) - Integer iSD4(0:nSD,4), iAnga(4) -* - iAnga(1) = iSD4(1,1) - iAnga(2) = iSD4(1,2) - iAnga(3) = iSD4(1,3) - iAnga(4) = iSD4(1,4) - Call MemRg1(iAnga,nRys,MemPrm) -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/memrys_g.F90 openmolcas-22.10/src/rys_util/memrys_g.F90 --- openmolcas-22.02/src/rys_util/memrys_g.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/memrys_g.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,26 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine MemRys_g(iSD4,nSD,nRys,MemPrm) + +use Definitions, only: iwp + +implicit none +integer(kind=iwp), intent(in) :: nSD, iSD4(0:nSD,4) +integer(kind=iwp), intent(out) :: nRys, MemPrm +integer(kind=iwp) :: iAnga(4) + +iAnga(:) = iSD4(1,:) +call MemRg1(iAnga,nRys,MemPrm) + +return + +end subroutine MemRys_g diff -Nru openmolcas-22.02/src/rys_util/modu2.f openmolcas-22.10/src/rys_util/modu2.f --- openmolcas-22.02/src/rys_util/modu2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/modu2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,48 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine ModU2(U2,mT,nRys,ZEInv) -************************************************************************ -* * -* Object: precompute u2/(zeta+eta) * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* May '90 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - Real*8 U2(nRys,mT), ZEInv(mT) -* - iRout = 255 - iPrint = nPrint(iRout) -* - If (iPrint.ge.99) Then - Call RecPrt(' In ModU2: U2',' ',U2,nRys,mT) - Call RecPrt(' In ModU2: ZEInv',' ',ZEInv,1,mT) - End If -* - If (nRys.gt.1) Then - Do 11 iT = 1, mT - Do 21 iRys = 1, nRys - U2(iRys,iT) = U2(iRys,iT) * ZEInv(iT) - 21 Continue - 11 Continue - Else - Do 31 iT = 1, mT - U2(1,iT) = U2(1,iT) * ZEInv(iT) - 31 Continue - End If -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/modu2.F90 openmolcas-22.10/src/rys_util/modu2.F90 --- openmolcas-22.02/src/rys_util/modu2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/modu2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,51 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine ModU2(U2,mT,nRys,ZEInv) +!*********************************************************************** +! * +! Object: precompute u2/(zeta+eta) * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! May '90 * +!*********************************************************************** + +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: mT, nRys +real(kind=wp), intent(inout) :: U2(nRys,mT) +real(kind=wp), intent(in) :: ZEInv(mT) +#include "print.fh" +integer(kind=iwp) :: iPrint, iRout, iT + +iRout = 255 +iPrint = nPrint(iRout) + +if (iPrint >= 99) then + call RecPrt(' In ModU2: U2',' ',U2,nRys,mT) + call RecPrt(' In ModU2: ZEInv',' ',ZEInv,1,mT) +end if + +if (nRys > 1) then + do iT=1,mT + U2(:,iT) = U2(:,iT)*ZEInv(iT) + end do +else + U2(1,:) = U2(1,:)*ZEInv(:) +end if + +return + +end subroutine ModU2 diff -Nru openmolcas-22.02/src/rys_util/pppp.f openmolcas-22.10/src/rys_util/pppp.f --- openmolcas-22.02/src/rys_util/pppp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/pppp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1231 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1994, Roland Lindh * -************************************************************************ - Subroutine pppp(EFInt,Zeta,ZInv,nZeta,P,lP,rKappAB,A,B, - & Eta,EInv, nEta,Q,lQ,rKappCD,C,D, - & CoorAC,TMax, - & iPntr,nPntr,x0,nMax,CW6,CW5,CW4,CW3,CW2,CW1,CW0, - & CR6,CR5,CR4,CR3,CR2,CR1,CR0, - & ddx,HerW,HerR2,IsChi,ChiI2) -************************************************************************ -* * -* Object: to compute the primitive integrals of type (pp|pp). * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. 1994 * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 EFInt(nZeta,nEta,81), Zeta(nZeta), Eta(nEta), - & CoorAC(3,2), ZInv(nZeta), EInv(nEta), - & P(lP,3), Q(lQ,3), A(3), B(3), C(3), D(3), - & rKappAB(nZeta), rKappCD(nEta), - & x0(nMax), - & CW6(nMax,3), CW5(nMax,3), CW4(nMax,3), CW3(nMax,3), - & CW2(nMax,3), CW1(nMax,3), CW0(nMax,3), - & CR6(nMax,3), CR5(nMax,3), CR4(nMax,3), CR3(nMax,3), - & CR2(nMax,3), CR1(nMax,3), CR0(nMax,3), - & HerW(3), HerR2(3) - Integer iPntr(nPntr) - Logical ABeqCD, EQ -* -* - xdInv=One/ddx - dddx = ddx/10d0 + ddx -* - ABeqCD = EQ(A,B) .and. EQ(A,C) .and. EQ(A,D) - If ( ABeqCD ) Go To 100 - If ( EQ(A,B).and..Not.EQ(C,D)) Go To 200 - If (.Not.EQ(A,B).and. EQ(C,D)) Go To 300 - If ( EQ(A,B).and. EQ(C,D)) Go To 400 -* -*-----ABCD case -* - Do 10 iEta = 1, nEta - Do 20 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) - PQx = P(iZeta,1)-Q(iEta,1) - PQy = P(iZeta,2)-Q(iEta,2) - PQz = P(iZeta,3)-Q(iEta,3) - T = rho * (PQx**2 + PQy**2 + PQz**2) - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - w3=(((((CW6(n,3)*z+CW5(n,3))*z+CW4(n,3))*z+CW3(n,3))*z+ - & CW2(n,3))*z+CW1(n,3))*z+Cw0(n,3) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - r3=(((((CR6(n,3)*z+CR5(n,3))*z+CR4(n,3))*z+CR3(n,3))*z+ - & CR2(n,3))*z+CR1(n,3))*z+CR0(n,3) - Else - ai = 1.0D0/T - si = Sqrt(ai) - r1= HerR2(1)*ai - r2= HerR2(2)*ai - r3= HerR2(3)*ai - w1= HerW(1)*si - w2= HerW(2)*si - w3= HerW(3)*si - End If - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - w1 = PreFct*w1 - w2 = PreFct*w2 - w3 = PreFct*w3 - Eu21 = Eta(iEta)*(r1*ZEInv) - Eu22 = Eta(iEta)*(r2*ZEInv) - Eu23 = Eta(iEta)*(r3*ZEInv) - Zu21 = Zeta(iZeta)*(r1*ZEInv) - Zu22 = Zeta(iZeta)*(r2*ZEInv) - Zu23 = Zeta(iZeta)*(r3*ZEInv) - PAQPx1 = (P(iZeta,1) - CoorAC(1,1)) - Eu21 * PQx - PAQPx2 = (P(iZeta,1) - CoorAC(1,1)) - Eu22 * PQx - PAQPx3 = (P(iZeta,1) - CoorAC(1,1)) - Eu23 * PQx - PAQPy1 = (P(iZeta,2) - CoorAC(2,1)) - Eu21 * PQy - PAQPy2 = (P(iZeta,2) - CoorAC(2,1)) - Eu22 * PQy - PAQPy3 = (P(iZeta,2) - CoorAC(2,1)) - Eu23 * PQy - PAQPz1 = (P(iZeta,3) - CoorAC(3,1)) - Eu21 * PQz - PAQPz2 = (P(iZeta,3) - CoorAC(3,1)) - Eu22 * PQz - PAQPz3 = (P(iZeta,3) - CoorAC(3,1)) - Eu23 * PQz - QCPQx1 = ( Q(iEta,1) - CoorAC(1,2)) + Zu21 * PQx - QCPQx2 = ( Q(iEta,1) - CoorAC(1,2)) + Zu22 * PQx - QCPQx3 = ( Q(iEta,1) - CoorAC(1,2)) + Zu23 * PQx - QCPQy1 = ( Q(iEta,2) - CoorAC(2,2)) + Zu21 * PQy - QCPQy2 = ( Q(iEta,2) - CoorAC(2,2)) + Zu22 * PQy - QCPQy3 = ( Q(iEta,2) - CoorAC(2,2)) + Zu23 * PQy - QCPQz1 = ( Q(iEta,3) - CoorAC(3,2)) + Zu21 * PQz - QCPQz2 = ( Q(iEta,3) - CoorAC(3,2)) + Zu22 * PQz - QCPQz3 = ( Q(iEta,3) - CoorAC(3,2)) + Zu23 * PQz - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - B003 = Half * (r3*ZEInv) - B101 = (Half - Half * Eu21) * ZInv(iZeta) - B102 = (Half - Half * Eu22) * ZInv(iZeta) - B103 = (Half - Half * Eu23) * ZInv(iZeta) - B011 = (Half - Half * Zu21) * EInv(iEta) - B012 = (Half - Half * Zu22) * EInv(iEta) - B013 = (Half - Half * Zu23) * EInv(iEta) - x101= PAQPx1 - x102= PAQPx2 - x103= PAQPx3 - x011= QCPQx1 - x012= QCPQx2 - x013= QCPQx3 - x201= PAQPx1*x101 + B101 - x202= PAQPx2*x102 + B102 - x203= PAQPx3*x103 + B103 - x021= QCPQx1*x011 + B011 - x022= QCPQx2*x012 + B012 - x023= QCPQx3*x013 + B013 - x111= PAQPx1*QCPQx1 + B001 - x112= PAQPx2*QCPQx2 + B002 - x113= PAQPx3*QCPQx3 + B003 - x211= PAQPx1*x111 + B101*x011 + B001*x101 - x212= PAQPx2*x112 + B102*x012 + B002*x102 - x213= PAQPx3*x113 + B103*x013 + B003*x103 - x121= QCPQx1*x111 + B011*x101 + B001*x011 - x122= QCPQx2*x112 + B012*x102 + B002*x012 - x123= QCPQx3*x113 + B013*x103 + B003*x013 - x221= PAQPx1*x121 + B101*x021 + Two*B001*x111 - x222= PAQPx2*x122 + B102*x022 + Two*B002*x112 - x223= PAQPx3*x123 + B103*x023 + Two*B003*x113 - y101= PAQPy1 - y102= PAQPy2 - y103= PAQPy3 - y011= QCPQy1 - y012= QCPQy2 - y013= QCPQy3 - y201= PAQPy1*y101 + B101 - y202= PAQPy2*y102 + B102 - y203= PAQPy3*y103 + B103 - y021= QCPQy1*y011 + B011 - y022= QCPQy2*y012 + B012 - y023= QCPQy3*y013 + B013 - y111= PAQPy1*QCPQy1 + B001 - y112= PAQPy2*QCPQy2 + B002 - y113= PAQPy3*QCPQy3 + B003 - y211= PAQPy1*y111 + B101*y011 + B001*y101 - y212= PAQPy2*y112 + B102*y012 + B002*y102 - y213= PAQPy3*y113 + B103*y013 + B003*y103 - y121= QCPQy1*y111 + B011*y101 + B001*y011 - y122= QCPQy2*y112 + B012*y102 + B002*y012 - y123= QCPQy3*y113 + B013*y103 + B003*y013 - y221= PAQPy1*y121 + B101*y021 + Two*B001*y111 - y222= PAQPy2*y122 + B102*y022 + Two*B002*y112 - y223= PAQPy3*y123 + B103*y023 + Two*B003*y113 - z101= PAQPz1*w1 - z102= PAQPz2*w2 - z103= PAQPz3*w3 - z011= QCPQz1*w1 - z012= QCPQz2*w2 - z013= QCPQz3*w3 - z201= PAQPz1*z101 + B101*w1 - z202= PAQPz2*z102 + B102*w2 - z203= PAQPz3*z103 + B103*w3 - z021= QCPQz1*z011 + B011*w1 - z022= QCPQz2*z012 + B012*w2 - z023= QCPQz3*z013 + B013*w3 - z111= PAQPz1*QCPQz1*w1 + B001*w1 - z112= PAQPz2*QCPQz2*w2 + B002*w2 - z113= PAQPz3*QCPQz3*w3 + B003*w3 - z211= PAQPz1*z111 + B101*z011 + B001*z101 - z212= PAQPz2*z112 + B102*z012 + B002*z102 - z213= PAQPz3*z113 + B103*z013 + B003*z103 - z121= QCPQz1*z111 + B011*z101 + B001*z011 - z122= QCPQz2*z112 + B012*z102 + B002*z012 - z123= QCPQz3*z113 + B013*z103 + B003*z013 - z221= PAQPz1*z121 + B101*z021 + Two*B001*z111 - z222= PAQPz2*z122 + B102*z022 + Two*B002*z112 - z223= PAQPz3*z123 + B103*z023 + Two*B003*z113 - EFInt(iZeta,iEta, 1)= - & (x111 * w1)+(x112 * w2)+(x113 * w3) - EFInt(iZeta,iEta, 2)= - & (x011 * y101)* w1 +(x012 * y102)* w2 +(x013 * y103)* w3 - EFInt(iZeta,iEta, 3)= - & x011 * z101 + x012 * z102 + x013 * z103 - EFInt(iZeta,iEta, 4)= - & (x211 * w1)+(x212 * w2)+(x213 * w3) - EFInt(iZeta,iEta, 5)= - & (x111 * w1)* y101 +(x112 * w2)* y102 +(x113 * w3)* y103 - EFInt(iZeta,iEta, 6)= - & x111 * z101 + x112 * z102 + x113 * z103 - EFInt(iZeta,iEta, 7)= - & x011 * y201 * w1 + x012 * y202 * w2 + x013 * y203 * w3 - EFInt(iZeta,iEta, 8)= - & (x011 * y101)* z101 +(x012 * y102)* z102 +(x013 * y103)* z103 - EFInt(iZeta,iEta, 9)= - & x011 * z201 + x012 * z202 + x013 * z203 - EFInt(iZeta,iEta,10)= - & (x101 * y011)* w1 +(x102 * y012)* w2 +(x103 * y013)* w3 - EFInt(iZeta,iEta,11)= - & y111 * w1 + y112 * w2 + y113 * w3 - EFInt(iZeta,iEta,12)= - & (y011 * z101)+ (y012 * z102)+ (y013 * z103) - EFInt(iZeta,iEta,13)= - & (x201 * y011)* w1 +(x202 * y012)* w2 +(x203 * y013)* w3 - EFInt(iZeta,iEta,14)= - & (x101 * y111)* w1 +(x102 * y112)* w2 +(x103 * y113)* w3 - EFInt(iZeta,iEta,15)= - & (x101 * y011)* z101 +(x102 * y012)* z102 +(x103 * y013)* z103 - EFInt(iZeta,iEta,16)= - & (y211 * w1)+ (y212 * w2)+ (y213 * w3) - EFInt(iZeta,iEta,17)= - & y111 * z101 + y112 * z102 + y113 * z103 - EFInt(iZeta,iEta,18)= - & y011 * z201 + y012 * z202 + y013 * z203 - EFInt(iZeta,iEta,19)= - & x101 * z011 + x102 * z012 + x103 * z013 - EFInt(iZeta,iEta,20)= - & (y101 * z011)+ (y102 * z012)+ (y103 * z013) - EFInt(iZeta,iEta,21)= - & z111 + z112 + z113 - EFInt(iZeta,iEta,22)= - & x201 * z011 + x202 * z012 + x203 * z013 - EFInt(iZeta,iEta,23)= - & x101 *(y101 * z011)+ x102 *(y102 * z012)+ x103 *(y103 * z013) - EFInt(iZeta,iEta,24)= - & x101 * z111 + x102 * z112 + x103 * z113 - EFInt(iZeta,iEta,25)= - & y201 * z011 + y202 * z012 + y203 * z013 - EFInt(iZeta,iEta,26)= - & y101 * z111 + y102 * z112 + y103 * z113 - EFInt(iZeta,iEta,27)= - & z211 + z212 + z213 - EFInt(iZeta,iEta,28)= - & (x121 * w1)+(x122 * w2)+(x123 * w3) - EFInt(iZeta,iEta,29)= - & (x021 * y101)* w1 +(x022 * y102)* w2 +(x023 * y103)* w3 - EFInt(iZeta,iEta,30)= - & x021 * z101 + x022 * z102 + x023 * z103 - EFInt(iZeta,iEta,31)= - & x221 * w1 + x222 * w2 + x223 * w3 - EFInt(iZeta,iEta,32)= - & (x121 * w1)* y101 +(x122 * w2)* y102 +(x123 * w3)* y103 - EFInt(iZeta,iEta,33)= - & x121 * z101 + x122 * z102 + x123 * z103 - EFInt(iZeta,iEta,34)= - & x021 * y201 * w1 + x022 * y202 * w2 + x023 * y203 * w3 - EFInt(iZeta,iEta,35)= - & (x021 * y101)* z101 +(x022 * y102)* z102 +(x023 * y103)* z103 - EFInt(iZeta,iEta,36)= - & x021 * z201 + x022 * z202 + x023 * z203 - EFInt(iZeta,iEta,37)= - & (x111 * w1)* y011 +(x112 * w2)* y012 +(x113 * w3)* y013 - EFInt(iZeta,iEta,38)= - & (x011 * y111)* w1 +(x012 * y112)* w2 +(x013 * y113)* w3 - EFInt(iZeta,iEta,39)= - & (x011 * y011)* z101 +(x012 * y012)* z102 +(x013 * y013)* z103 - EFInt(iZeta,iEta,40)= - & (x211 * w1)* y011 +(x212 * w2)* y012 +(x213 * w3)* y013 - EFInt(iZeta,iEta,41)= - & x111 * y111 * w1 + x112 * y112 * w2 + x113 * y113 * w3 - EFInt(iZeta,iEta,42)= - & x111 *(y011 * z101)+ x112 *(y012 * z102)+ x113 *(y013 * z103) - EFInt(iZeta,iEta,43)= - & x011 *(y211 * w1)+ x012 *(y212 * w2)+ x013 *(y213 * w3) - EFInt(iZeta,iEta,44)= - & (x011 * y111)* z101 +(x012 * y112)* z102 +(x013 * y113)* z103 - EFInt(iZeta,iEta,45)= - & (x011 * y011)* z201 +(x012 * y012)* z202 +(x013 * y013)* z203 - EFInt(iZeta,iEta,46)= - & x111 * z011 + x112 * z012 + x113 * z013 - EFInt(iZeta,iEta,47)= - & (x011 * y101)* z011 +(x012 * y102)* z012 +(x013 * y103)* z013 - EFInt(iZeta,iEta,48)= - & x011 * z111 + x012 * z112 + x013 * z113 - EFInt(iZeta,iEta,49)= - & x211 * z011 + x212 * z012 + x213 * z013 - EFInt(iZeta,iEta,50)= - & x111 *(y101 * z011)+ x112 *(y102 * z012)+ x113 *(y103 * z013) - EFInt(iZeta,iEta,51)= - & x111 * z111 + x112 * z112 + x113 * z113 - EFInt(iZeta,iEta,52)= - & (x011 * y201)* z011 +(x012 * y202)* z012 +(x013 * y203)* z013 - EFInt(iZeta,iEta,53)= - & (x011 * y101)* z111 +(x012 * y102)* z112 +(x013 * y103)* z113 - EFInt(iZeta,iEta,54)= - & x011 * z211 + x012 * z212 + x013 * z213 - EFInt(iZeta,iEta,55)= - & x101 * y021 * w1 + x102 * y022 * w2 + x103 * y023 * w3 - EFInt(iZeta,iEta,56)= - & (y121 * w1)+ (y122 * w2)+ (y123 * w3) - EFInt(iZeta,iEta,57)= - & (y021 * z101)+ (y022 * z102)+ (y023 * z103) - EFInt(iZeta,iEta,58)= - & x201 * y021 * w1 + x202 * y022 * w2 + x203 * y023 * w3 - EFInt(iZeta,iEta,59)= - & x101 *(y121 * w1)+ x102 *(y122 * w2)+ x103 *(y123 * w3) - EFInt(iZeta,iEta,60)= - & x101 *(y021 * z101)+ x102 *(y022 * z102)+ x103 *(y023 * z103) - EFInt(iZeta,iEta,61)= - & y221 * w1 + y222 * w2 + y223 * w3 - EFInt(iZeta,iEta,62)= - & y121 * z101 + y122 * z102 + y123 * z103 - EFInt(iZeta,iEta,63)= - & y021 * z201 + y022 * z202 + y023 * z203 - EFInt(iZeta,iEta,64)= - & (x101 * y011)* z011 +(x102 * y012)* z012 +(x103 * y013)* z013 - EFInt(iZeta,iEta,65)= - & y111 * z011 + y112 * z012 + y113 * z013 - EFInt(iZeta,iEta,66)= - & y011 * z111 + y012 * z112 + y013 * z113 - EFInt(iZeta,iEta,67)= - & (x201 * y011)* z011 +(x202 * y012)* z012 +(x203 * y013)* z013 - EFInt(iZeta,iEta,68)= - & (x101 * y111)* z011 +(x102 * y112)* z012 +(x103 * y113)* z013 - EFInt(iZeta,iEta,69)= - & (x101 * y011)* z111 +(x102 * y012)* z112 +(x103 * y013)* z113 - EFInt(iZeta,iEta,70)= - & y211 * z011 + y212 * z012 + y213 * z013 - EFInt(iZeta,iEta,71)= - & y111 * z111 + y112 * z112 + y113 * z113 - EFInt(iZeta,iEta,72)= - & y011 * z211 + y012 * z212 + y013 * z213 - EFInt(iZeta,iEta,73)= - & x101 * z021 + x102 * z022 + x103 * z023 - EFInt(iZeta,iEta,74)= - & (y101 * z021)+ (y102 * z022)+ (y103 * z023) - EFInt(iZeta,iEta,75)= - & z121 + z122 + z123 - EFInt(iZeta,iEta,76)= - & x201 * z021 + x202 * z022 + x203 * z023 - EFInt(iZeta,iEta,77)= - & x101 *(y101 * z021)+ x102 *(y102 * z022)+ x103 *(y103 * z023) - EFInt(iZeta,iEta,78)= - & x101 * z121 + x102 * z122 + x103 * z123 - EFInt(iZeta,iEta,79)= - & y201 * z021 + y202 * z022 + y203 * z023 - EFInt(iZeta,iEta,80)= - & y101 * z121 + y102 * z122 + y103 * z123 - EFInt(iZeta,iEta,81)= - & z221 + z222 + z223 - 20 Continue - 10 Continue - Go To 99 -* -*-----AAAA case -* - 100 Continue - z = - x0(1) - ww1=(((((CW6(1,1)*z+CW5(1,1))*z+CW4(1,1))*z+CW3(1,1))*z+ - & CW2(1,1))*z+CW1(1,1))*z+Cw0(1,1) - ww2=(((((CW6(1,2)*z+CW5(1,2))*z+CW4(1,2))*z+CW3(1,2))*z+ - & CW2(1,2))*z+CW1(1,2))*z+Cw0(1,2) - ww3=(((((CW6(1,3)*z+CW5(1,3))*z+CW4(1,3))*z+CW3(1,3))*z+ - & CW2(1,3))*z+CW1(1,3))*z+Cw0(1,3) - r1=(((((CR6(1,1)*z+CR5(1,1))*z+CR4(1,1))*z+CR3(1,1))*z+ - & CR2(1,1))*z+CR1(1,1))*z+CR0(1,1) - r2=(((((CR6(1,2)*z+CR5(1,2))*z+CR4(1,2))*z+CR3(1,2))*z+ - & CR2(1,2))*z+CR1(1,2))*z+CR0(1,2) - r3=(((((CR6(1,3)*z+CR5(1,3))*z+CR4(1,3))*z+CR3(1,3))*z+ - & CR2(1,3))*z+CR1(1,3))*z+CR0(1,3) - Do 11 iEta = 1, nEta - Do 21 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - w1 = PreFct*ww1 - w2 = PreFct*ww2 - w3 = PreFct*ww3 - Eu21 = Eta(iEta)*(r1*ZEInv) - Eu22 = Eta(iEta)*(r2*ZEInv) - Eu23 = Eta(iEta)*(r3*ZEInv) - Zu21 = Zeta(iZeta)*(r1*ZEInv) - Zu22 = Zeta(iZeta)*(r2*ZEInv) - Zu23 = Zeta(iZeta)*(r3*ZEInv) - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - B003 = Half * (r3*ZEInv) - B101 = (Half - Half * Eu21) * ZInv(iZeta) - B102 = (Half - Half * Eu22) * ZInv(iZeta) - B103 = (Half - Half * Eu23) * ZInv(iZeta) - B011 = (Half - Half * Zu21) * EInv(iEta) - B012 = (Half - Half * Zu22) * EInv(iEta) - B013 = (Half - Half * Zu23) * EInv(iEta) - x201= B101 - x202= B102 - x203= B103 - x021= B011 - x022= B012 - x023= B013 - x111= B001 - x112= B002 - x113= B003 - x221= B101*x021 + Two*B001*x111 - x222= B102*x022 + Two*B002*x112 - x223= B103*x023 + Two*B003*x113 - y201= B101 - y202= B102 - y203= B103 - y021= B011 - y022= B012 - y023= B013 - y111= B001 - y112= B002 - y113= B003 - y221= B101*y021 + Two*B001*y111 - y222= B102*y022 + Two*B002*y112 - y223= B103*y023 + Two*B003*y113 - z201= B101*w1 - z202= B102*w2 - z203= B103*w3 - z021= B011*w1 - z022= B012*w2 - z023= B013*w3 - z111= B001*w1 - z112= B002*w2 - z113= B003*w3 - z221= B101*z021 + Two*B001*z111 - z222= B102*z022 + Two*B002*z112 - z223= B103*z023 + Two*B003*z113 - EFInt(iZeta,iEta, 1)= - & x221 * w1 + x222 * w2 + x223 * w3 - EFInt(iZeta,iEta, 2)= Zero - EFInt(iZeta,iEta, 3)= Zero - EFInt(iZeta,iEta, 4)= - & x021 * y201 * w1 + x022 * y202 * w2 + x023 * y203 * w3 - EFInt(iZeta,iEta, 5)= Zero - EFInt(iZeta,iEta, 6)= - & x021 * z201 + x022 * z202 + x023 * z203 - EFInt(iZeta,iEta, 7)= Zero - EFInt(iZeta,iEta, 8)= - & x111 * y111 * w1 + x112 * y112 * w2 + x113 * y113 * w3 - EFInt(iZeta,iEta, 9)= Zero - EFInt(iZeta,iEta,10)= Zero - EFInt(iZeta,iEta,11)= Zero - EFInt(iZeta,iEta,12)= Zero - EFInt(iZeta,iEta,13)= Zero - EFInt(iZeta,iEta,14)= Zero - EFInt(iZeta,iEta,15)= - & x111 * z111 + x112 * z112 + x113 * z113 - EFInt(iZeta,iEta,16)= Zero - EFInt(iZeta,iEta,17)= Zero - EFInt(iZeta,iEta,18)= Zero - EFInt(iZeta,iEta,19)= - & x201 * y021 * w1 + x202 * y022 * w2 + x203 * y023 * w3 - EFInt(iZeta,iEta,20)= Zero - EFInt(iZeta,iEta,21)= Zero - EFInt(iZeta,iEta,22)= - & y221 * w1 + y222 * w2 + y223 * w3 - EFInt(iZeta,iEta,23)= Zero - EFInt(iZeta,iEta,24)= - & y021 * z201 + y022 * z202 + y023 * z203 - EFInt(iZeta,iEta,25)= Zero - EFInt(iZeta,iEta,26)= Zero - EFInt(iZeta,iEta,27)= Zero - EFInt(iZeta,iEta,28)= Zero - EFInt(iZeta,iEta,29)= - & y111 * z111 + y112 * z112 + y113 * z113 - EFInt(iZeta,iEta,30)= Zero - EFInt(iZeta,iEta,31)= - & x201 * z021 + x202 * z022 + x203 * z023 - EFInt(iZeta,iEta,32)= Zero - EFInt(iZeta,iEta,33)= Zero - EFInt(iZeta,iEta,34)= - & y201 * z021 + y202 * z022 + y203 * z023 - EFInt(iZeta,iEta,35)= Zero - EFInt(iZeta,iEta,36)= - & z221 + z222 + z223 - 21 Continue - 11 Continue - Go To 99 -* -*-----AACD case -* - 200 Continue - Do 12 iEta = 1, nEta - Do 22 iZeta = 1, nZeta - PQx = CoorAC(1,1)-Q(iEta,1) - PQy = CoorAC(2,1)-Q(iEta,2) - PQz = CoorAC(3,1)-Q(iEta,3) - PQ2 = PQx**2 + PQy**2 + PQz**2 - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) - T = rho * PQ2 - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - w3=(((((CW6(n,3)*z+CW5(n,3))*z+CW4(n,3))*z+CW3(n,3))*z+ - & CW2(n,3))*z+CW1(n,3))*z+Cw0(n,3) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - r3=(((((CR6(n,3)*z+CR5(n,3))*z+CR4(n,3))*z+CR3(n,3))*z+ - & CR2(n,3))*z+CR1(n,3))*z+CR0(n,3) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - w3= HerW(3)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - r3= HerR2(3)*ai - End If - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - w1 = PreFct*w1 - w2 = PreFct*w2 - w3 = PreFct*w3 - Eu21 = Eta(iEta)*(r1*ZEInv) - Eu22 = Eta(iEta)*(r2*ZEInv) - Eu23 = Eta(iEta)*(r3*ZEInv) - Zu21 = Zeta(iZeta)*(r1*ZEInv) - Zu22 = Zeta(iZeta)*(r2*ZEInv) - Zu23 = Zeta(iZeta)*(r3*ZEInv) - PAQPx1 = - Eu21 * PQx - PAQPx2 = - Eu22 * PQx - PAQPx3 = - Eu23 * PQx - PAQPy1 = - Eu21 * PQy - PAQPy2 = - Eu22 * PQy - PAQPy3 = - Eu23 * PQy - PAQPz1 = - Eu21 * PQz - PAQPz2 = - Eu22 * PQz - PAQPz3 = - Eu23 * PQz - QCPQx1 = ( Q(iEta,1) - CoorAC(1,2)) + Zu21 * PQx - QCPQx2 = ( Q(iEta,1) - CoorAC(1,2)) + Zu22 * PQx - QCPQx3 = ( Q(iEta,1) - CoorAC(1,2)) + Zu23 * PQx - QCPQy1 = ( Q(iEta,2) - CoorAC(2,2)) + Zu21 * PQy - QCPQy2 = ( Q(iEta,2) - CoorAC(2,2)) + Zu22 * PQy - QCPQy3 = ( Q(iEta,2) - CoorAC(2,2)) + Zu23 * PQy - QCPQz1 = ( Q(iEta,3) - CoorAC(3,2)) + Zu21 * PQz - QCPQz2 = ( Q(iEta,3) - CoorAC(3,2)) + Zu22 * PQz - QCPQz3 = ( Q(iEta,3) - CoorAC(3,2)) + Zu23 * PQz - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - B003 = Half * (r3*ZEInv) - B101 = (Half - Half * Eu21) * ZInv(iZeta) - B102 = (Half - Half * Eu22) * ZInv(iZeta) - B103 = (Half - Half * Eu23) * ZInv(iZeta) - B011 = (Half - Half * Zu21) * EInv(iEta) - B012 = (Half - Half * Zu22) * EInv(iEta) - B013 = (Half - Half * Zu23) * EInv(iEta) - x101= PAQPx1 - x102= PAQPx2 - x103= PAQPx3 - x011= QCPQx1 - x012= QCPQx2 - x013= QCPQx3 - x201= PAQPx1*x101 + B101 - x202= PAQPx2*x102 + B102 - x203= PAQPx3*x103 + B103 - x021= QCPQx1*x011 + B011 - x022= QCPQx2*x012 + B012 - x023= QCPQx3*x013 + B013 - x111= PAQPx1*QCPQx1 + B001 - x112= PAQPx2*QCPQx2 + B002 - x113= PAQPx3*QCPQx3 + B003 - x211= PAQPx1*x111 + B101*x011 + B001*x101 - x212= PAQPx2*x112 + B102*x012 + B002*x102 - x213= PAQPx3*x113 + B103*x013 + B003*x103 - x121= QCPQx1*x111 + B011*x101 + B001*x011 - x122= QCPQx2*x112 + B012*x102 + B002*x012 - x123= QCPQx3*x113 + B013*x103 + B003*x013 - x221= PAQPx1*x121 + B101*x021 + Two*B001*x111 - x222= PAQPx2*x122 + B102*x022 + Two*B002*x112 - x223= PAQPx3*x123 + B103*x023 + Two*B003*x113 - y101= PAQPy1 - y102= PAQPy2 - y103= PAQPy3 - y011= QCPQy1 - y012= QCPQy2 - y013= QCPQy3 - y201= PAQPy1*y101 + B101 - y202= PAQPy2*y102 + B102 - y203= PAQPy3*y103 + B103 - y021= QCPQy1*y011 + B011 - y022= QCPQy2*y012 + B012 - y023= QCPQy3*y013 + B013 - y111= PAQPy1*QCPQy1 + B001 - y112= PAQPy2*QCPQy2 + B002 - y113= PAQPy3*QCPQy3 + B003 - y211= PAQPy1*y111 + B101*y011 + B001*y101 - y212= PAQPy2*y112 + B102*y012 + B002*y102 - y213= PAQPy3*y113 + B103*y013 + B003*y103 - y121= QCPQy1*y111 + B011*y101 + B001*y011 - y122= QCPQy2*y112 + B012*y102 + B002*y012 - y123= QCPQy3*y113 + B013*y103 + B003*y013 - y221= PAQPy1*y121 + B101*y021 + Two*B001*y111 - y222= PAQPy2*y122 + B102*y022 + Two*B002*y112 - y223= PAQPy3*y123 + B103*y023 + Two*B003*y113 - z101= PAQPz1*w1 - z102= PAQPz2*w2 - z103= PAQPz3*w3 - z011= QCPQz1*w1 - z012= QCPQz2*w2 - z013= QCPQz3*w3 - z201= PAQPz1*z101 + B101*w1 - z202= PAQPz2*z102 + B102*w2 - z203= PAQPz3*z103 + B103*w3 - z021= QCPQz1*z011 + B011*w1 - z022= QCPQz2*z012 + B012*w2 - z023= QCPQz3*z013 + B013*w3 - z111= PAQPz1*QCPQz1*w1 + B001*w1 - z112= PAQPz2*QCPQz2*w2 + B002*w2 - z113= PAQPz3*QCPQz3*w3 + B003*w3 - z211= PAQPz1*z111 + B101*z011 + B001*z101 - z212= PAQPz2*z112 + B102*z012 + B002*z102 - z213= PAQPz3*z113 + B103*z013 + B003*z103 - z121= QCPQz1*z111 + B011*z101 + B001*z011 - z122= QCPQz2*z112 + B012*z102 + B002*z012 - z123= QCPQz3*z113 + B013*z103 + B003*z013 - z221= PAQPz1*z121 + B101*z021 + Two*B001*z111 - z222= PAQPz2*z122 + B102*z022 + Two*B002*z112 - z223= PAQPz3*z123 + B103*z023 + Two*B003*z113 - EFInt(iZeta,iEta, 1)= - & (x211 * w1)+(x212 * w2)+(x213 * w3) - EFInt(iZeta,iEta, 2)= - & (x111 * w1)* y101 +(x112 * w2)* y102 +(x113 * w3)* y103 - EFInt(iZeta,iEta, 3)= - & x111 * z101 + x112 * z102 + x113 * z103 - EFInt(iZeta,iEta, 4)= - & x011 * y201 * w1 + x012 * y202 * w2 + x013 * y203 * w3 - EFInt(iZeta,iEta, 5)= - & (x011 * y101)* z101 +(x012 * y102)* z102 +(x013 * y103)* z103 - EFInt(iZeta,iEta, 6)= - & x011 * z201 + x012 * z202 + x013 * z203 - EFInt(iZeta,iEta, 7)= - & (x201 * y011)* w1 +(x202 * y012)* w2 +(x203 * y013)* w3 - EFInt(iZeta,iEta, 8)= - & (x101 * y111)* w1 +(x102 * y112)* w2 +(x103 * y113)* w3 - EFInt(iZeta,iEta, 9)= - & (x101 * y011)* z101 +(x102 * y012)* z102 +(x103 * y013)* z103 - EFInt(iZeta,iEta,10)= - & (y211 * w1)+ (y212 * w2)+ (y213 * w3) - EFInt(iZeta,iEta,11)= - & y111 * z101 + y112 * z102 + y113 * z103 - EFInt(iZeta,iEta,12)= - & y011 * z201 + y012 * z202 + y013 * z203 - EFInt(iZeta,iEta,13)= - & x201 * z011 + x202 * z012 + x203 * z013 - EFInt(iZeta,iEta,14)= - & x101 *(y101 * z011)+ x102 *(y102 * z012)+ x103 *(y103 * z013) - EFInt(iZeta,iEta,15)= - & x101 * z111 + x102 * z112 + x103 * z113 - EFInt(iZeta,iEta,16)= - & y201 * z011 + y202 * z012 + y203 * z013 - EFInt(iZeta,iEta,17)= - & y101 * z111 + y102 * z112 + y103 * z113 - EFInt(iZeta,iEta,18)= - & z211 + z212 + z213 - EFInt(iZeta,iEta,19)= - & x221 * w1 + x222 * w2 + x223 * w3 - EFInt(iZeta,iEta,20)= - & (x121 * w1)* y101 +(x122 * w2)* y102 +(x123 * w3)* y103 - EFInt(iZeta,iEta,21)= - & x121 * z101 + x122 * z102 + x123 * z103 - EFInt(iZeta,iEta,22)= - & x021 * y201 * w1 + x022 * y202 * w2 + x023 * y203 * w3 - EFInt(iZeta,iEta,23)= - & (x021 * y101)* z101 +(x022 * y102)* z102 +(x023 * y103)* z103 - EFInt(iZeta,iEta,24)= - & x021 * z201 + x022 * z202 + x023 * z203 - EFInt(iZeta,iEta,25)= - & (x211 * w1)* y011 +(x212 * w2)* y012 +(x213 * w3)* y013 - EFInt(iZeta,iEta,26)= - & x111 * y111 * w1 + x112 * y112 * w2 + x113 * y113 * w3 - EFInt(iZeta,iEta,27)= - & x111 *(y011 * z101)+ x112 *(y012 * z102)+ x113 *(y013 * z103) - EFInt(iZeta,iEta,28)= - & x011 *(y211 * w1)+ x012 *(y212 * w2)+ x013 *(y213 * w3) - EFInt(iZeta,iEta,29)= - & (x011 * y111)* z101 +(x012 * y112)* z102 +(x013 * y113)* z103 - EFInt(iZeta,iEta,30)= - & (x011 * y011)* z201 +(x012 * y012)* z202 +(x013 * y013)* z203 - EFInt(iZeta,iEta,31)= - & x211 * z011 + x212 * z012 + x213 * z013 - EFInt(iZeta,iEta,32)= - & x111 *(y101 * z011)+ x112 *(y102 * z012)+ x113 *(y103 * z013) - EFInt(iZeta,iEta,33)= - & x111 * z111 + x112 * z112 + x113 * z113 - EFInt(iZeta,iEta,34)= - & (x011 * y201)* z011 +(x012 * y202)* z012 +(x013 * y203)* z013 - EFInt(iZeta,iEta,35)= - & (x011 * y101)* z111 +(x012 * y102)* z112 +(x013 * y103)* z113 - EFInt(iZeta,iEta,36)= - & x011 * z211 + x012 * z212 + x013 * z213 - EFInt(iZeta,iEta,37)= - & x201 * y021 * w1 + x202 * y022 * w2 + x203 * y023 * w3 - EFInt(iZeta,iEta,38)= - & x101 *(y121 * w1)+ x102 *(y122 * w2)+ x103 *(y123 * w3) - EFInt(iZeta,iEta,39)= - & x101 *(y021 * z101)+ x102 *(y022 * z102)+ x103 *(y023 * z103) - EFInt(iZeta,iEta,40)= - & y221 * w1 + y222 * w2 + y223 * w3 - EFInt(iZeta,iEta,41)= - & y121 * z101 + y122 * z102 + y123 * z103 - EFInt(iZeta,iEta,42)= - & y021 * z201 + y022 * z202 + y023 * z203 - EFInt(iZeta,iEta,43)= - & (x201 * y011)* z011 +(x202 * y012)* z012 +(x203 * y013)* z013 - EFInt(iZeta,iEta,44)= - & (x101 * y111)* z011 +(x102 * y112)* z012 +(x103 * y113)* z013 - EFInt(iZeta,iEta,45)= - & (x101 * y011)* z111 +(x102 * y012)* z112 +(x103 * y013)* z113 - EFInt(iZeta,iEta,46)= - & y211 * z011 + y212 * z012 + y213 * z013 - EFInt(iZeta,iEta,47)= - & y111 * z111 + y112 * z112 + y113 * z113 - EFInt(iZeta,iEta,48)= - & y011 * z211 + y012 * z212 + y013 * z213 - EFInt(iZeta,iEta,49)= - & x201 * z021 + x202 * z022 + x203 * z023 - EFInt(iZeta,iEta,50)= - & x101 *(y101 * z021)+ x102 *(y102 * z022)+ x103 *(y103 * z023) - EFInt(iZeta,iEta,51)= - & x101 * z121 + x102 * z122 + x103 * z123 - EFInt(iZeta,iEta,52)= - & y201 * z021 + y202 * z022 + y203 * z023 - EFInt(iZeta,iEta,53)= - & y101 * z121 + y102 * z122 + y103 * z123 - EFInt(iZeta,iEta,54)= - & z221 + z222 + z223 - 22 Continue - 12 Continue - Go To 99 -* -*-----ABCC case -* - 300 Continue - Do 13 iEta = 1, nEta - Do 23 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) - PQx = P(iZeta,1)-CoorAC(1,2) - PQy = P(iZeta,2)-CoorAC(2,2) - PQz = P(iZeta,3)-CoorAC(3,2) - T = rho * (PQx**2 + PQy**2 + PQz**2) - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - w3=(((((CW6(n,3)*z+CW5(n,3))*z+CW4(n,3))*z+CW3(n,3))*z+ - & CW2(n,3))*z+CW1(n,3))*z+Cw0(n,3) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - r3=(((((CR6(n,3)*z+CR5(n,3))*z+CR4(n,3))*z+CR3(n,3))*z+ - & CR2(n,3))*z+CR1(n,3))*z+CR0(n,3) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - w3= HerW(3)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - r3= HerR2(3)*ai - End If - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - w1 = PreFct*w1 - w2 = PreFct*w2 - w3 = PreFct*w3 - Eu21 = Eta(iEta)*(r1*ZEInv) - Eu22 = Eta(iEta)*(r2*ZEInv) - Eu23 = Eta(iEta)*(r3*ZEInv) - Zu21 = Zeta(iZeta)*(r1*ZEInv) - Zu22 = Zeta(iZeta)*(r2*ZEInv) - Zu23 = Zeta(iZeta)*(r3*ZEInv) - PAQPx1 = (P(iZeta,1) - CoorAC(1,1)) - Eu21 * PQx - PAQPx2 = (P(iZeta,1) - CoorAC(1,1)) - Eu22 * PQx - PAQPx3 = (P(iZeta,1) - CoorAC(1,1)) - Eu23 * PQx - PAQPy1 = (P(iZeta,2) - CoorAC(2,1)) - Eu21 * PQy - PAQPy2 = (P(iZeta,2) - CoorAC(2,1)) - Eu22 * PQy - PAQPy3 = (P(iZeta,2) - CoorAC(2,1)) - Eu23 * PQy - PAQPz1 = (P(iZeta,3) - CoorAC(3,1)) - Eu21 * PQz - PAQPz2 = (P(iZeta,3) - CoorAC(3,1)) - Eu22 * PQz - PAQPz3 = (P(iZeta,3) - CoorAC(3,1)) - Eu23 * PQz - QCPQx1 = Zu21 * PQx - QCPQx2 = Zu22 * PQx - QCPQx3 = Zu23 * PQx - QCPQy1 = Zu21 * PQy - QCPQy2 = Zu22 * PQy - QCPQy3 = Zu23 * PQy - QCPQz1 = Zu21 * PQz - QCPQz2 = Zu22 * PQz - QCPQz3 = Zu23 * PQz - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - B003 = Half * (r3*ZEInv) - B101 = (Half - Half * Eu21) * ZInv(iZeta) - B102 = (Half - Half * Eu22) * ZInv(iZeta) - B103 = (Half - Half * Eu23) * ZInv(iZeta) - B011 = (Half - Half * Zu21) * EInv(iEta) - B012 = (Half - Half * Zu22) * EInv(iEta) - B013 = (Half - Half * Zu23) * EInv(iEta) - x101= PAQPx1 - x102= PAQPx2 - x103= PAQPx3 - x011= QCPQx1 - x012= QCPQx2 - x013= QCPQx3 - x201= PAQPx1*x101 + B101 - x202= PAQPx2*x102 + B102 - x203= PAQPx3*x103 + B103 - x021= QCPQx1*x011 + B011 - x022= QCPQx2*x012 + B012 - x023= QCPQx3*x013 + B013 - x111= PAQPx1*QCPQx1 + B001 - x112= PAQPx2*QCPQx2 + B002 - x113= PAQPx3*QCPQx3 + B003 - x211= PAQPx1*x111 + B101*x011 + B001*x101 - x212= PAQPx2*x112 + B102*x012 + B002*x102 - x213= PAQPx3*x113 + B103*x013 + B003*x103 - x121= QCPQx1*x111 + B011*x101 + B001*x011 - x122= QCPQx2*x112 + B012*x102 + B002*x012 - x123= QCPQx3*x113 + B013*x103 + B003*x013 - x221= PAQPx1*x121 + B101*x021 + Two*B001*x111 - x222= PAQPx2*x122 + B102*x022 + Two*B002*x112 - x223= PAQPx3*x123 + B103*x023 + Two*B003*x113 - y101= PAQPy1 - y102= PAQPy2 - y103= PAQPy3 - y011= QCPQy1 - y012= QCPQy2 - y013= QCPQy3 - y201= PAQPy1*y101 + B101 - y202= PAQPy2*y102 + B102 - y203= PAQPy3*y103 + B103 - y021= QCPQy1*y011 + B011 - y022= QCPQy2*y012 + B012 - y023= QCPQy3*y013 + B013 - y111= PAQPy1*QCPQy1 + B001 - y112= PAQPy2*QCPQy2 + B002 - y113= PAQPy3*QCPQy3 + B003 - y211= PAQPy1*y111 + B101*y011 + B001*y101 - y212= PAQPy2*y112 + B102*y012 + B002*y102 - y213= PAQPy3*y113 + B103*y013 + B003*y103 - y121= QCPQy1*y111 + B011*y101 + B001*y011 - y122= QCPQy2*y112 + B012*y102 + B002*y012 - y123= QCPQy3*y113 + B013*y103 + B003*y013 - y221= PAQPy1*y121 + B101*y021 + Two*B001*y111 - y222= PAQPy2*y122 + B102*y022 + Two*B002*y112 - y223= PAQPy3*y123 + B103*y023 + Two*B003*y113 - z101= PAQPz1*w1 - z102= PAQPz2*w2 - z103= PAQPz3*w3 - z011= QCPQz1*w1 - z012= QCPQz2*w2 - z013= QCPQz3*w3 - z201= PAQPz1*z101 + B101*w1 - z202= PAQPz2*z102 + B102*w2 - z203= PAQPz3*z103 + B103*w3 - z021= QCPQz1*z011 + B011*w1 - z022= QCPQz2*z012 + B012*w2 - z023= QCPQz3*z013 + B013*w3 - z111= PAQPz1*QCPQz1*w1 + B001*w1 - z112= PAQPz2*QCPQz2*w2 + B002*w2 - z113= PAQPz3*QCPQz3*w3 + B003*w3 - z211= PAQPz1*z111 + B101*z011 + B001*z101 - z212= PAQPz2*z112 + B102*z012 + B002*z102 - z213= PAQPz3*z113 + B103*z013 + B003*z103 - z121= QCPQz1*z111 + B011*z101 + B001*z011 - z122= QCPQz2*z112 + B012*z102 + B002*z012 - z123= QCPQz3*z113 + B013*z103 + B003*z013 - z221= PAQPz1*z121 + B101*z021 + Two*B001*z111 - z222= PAQPz2*z122 + B102*z022 + Two*B002*z112 - z223= PAQPz3*z123 + B103*z023 + Two*B003*z113 - EFInt(iZeta,iEta, 1)= - & (x121 * w1)+(x122 * w2)+(x123 * w3) - EFInt(iZeta,iEta, 2)= - & (x021 * y101)* w1 +(x022 * y102)* w2 +(x023 * y103)* w3 - EFInt(iZeta,iEta, 3)= - & x021 * z101 + x022 * z102 + x023 * z103 - EFInt(iZeta,iEta, 4)= - & x221 * w1 + x222 * w2 + x223 * w3 - EFInt(iZeta,iEta, 5)= - & (x121 * w1)* y101 +(x122 * w2)* y102 +(x123 * w3)* y103 - EFInt(iZeta,iEta, 6)= - & x121 * z101 + x122 * z102 + x123 * z103 - EFInt(iZeta,iEta, 7)= - & x021 * y201 * w1 + x022 * y202 * w2 + x023 * y203 * w3 - EFInt(iZeta,iEta, 8)= - & (x021 * y101)* z101 +(x022 * y102)* z102 +(x023 * y103)* z103 - EFInt(iZeta,iEta, 9)= - & x021 * z201 + x022 * z202 + x023 * z203 - EFInt(iZeta,iEta,10)= - & (x111 * w1)* y011 +(x112 * w2)* y012 +(x113 * w3)* y013 - EFInt(iZeta,iEta,11)= - & (x011 * y111)* w1 +(x012 * y112)* w2 +(x013 * y113)* w3 - EFInt(iZeta,iEta,12)= - & (x011 * y011)* z101 +(x012 * y012)* z102 +(x013 * y013)* z103 - EFInt(iZeta,iEta,13)= - & (x211 * w1)* y011 +(x212 * w2)* y012 +(x213 * w3)* y013 - EFInt(iZeta,iEta,14)= - & x111 * y111 * w1 + x112 * y112 * w2 + x113 * y113 * w3 - EFInt(iZeta,iEta,15)= - & x111 *(y011 * z101)+ x112 *(y012 * z102)+ x113 *(y013 * z103) - EFInt(iZeta,iEta,16)= - & x011 *(y211 * w1)+ x012 *(y212 * w2)+ x013 *(y213 * w3) - EFInt(iZeta,iEta,17)= - & (x011 * y111)* z101 +(x012 * y112)* z102 +(x013 * y113)* z103 - EFInt(iZeta,iEta,18)= - & (x011 * y011)* z201 +(x012 * y012)* z202 +(x013 * y013)* z203 - EFInt(iZeta,iEta,19)= - & x111 * z011 + x112 * z012 + x113 * z013 - EFInt(iZeta,iEta,20)= - & (x011 * y101)* z011 +(x012 * y102)* z012 +(x013 * y103)* z013 - EFInt(iZeta,iEta,21)= - & x011 * z111 + x012 * z112 + x013 * z113 - EFInt(iZeta,iEta,22)= - & x211 * z011 + x212 * z012 + x213 * z013 - EFInt(iZeta,iEta,23)= - & x111 *(y101 * z011)+ x112 *(y102 * z012)+ x113 *(y103 * z013) - EFInt(iZeta,iEta,24)= - & x111 * z111 + x112 * z112 + x113 * z113 - EFInt(iZeta,iEta,25)= - & (x011 * y201)* z011 +(x012 * y202)* z012 +(x013 * y203)* z013 - EFInt(iZeta,iEta,26)= - & (x011 * y101)* z111 +(x012 * y102)* z112 +(x013 * y103)* z113 - EFInt(iZeta,iEta,27)= - & x011 * z211 + x012 * z212 + x013 * z213 - EFInt(iZeta,iEta,28)= - & x101 * y021 * w1 + x102 * y022 * w2 + x103 * y023 * w3 - EFInt(iZeta,iEta,29)= - & (y121 * w1)+ (y122 * w2)+ (y123 * w3) - EFInt(iZeta,iEta,30)= - & (y021 * z101)+ (y022 * z102)+ (y023 * z103) - EFInt(iZeta,iEta,31)= - & x201 * y021 * w1 + x202 * y022 * w2 + x203 * y023 * w3 - EFInt(iZeta,iEta,32)= - & x101 *(y121 * w1)+ x102 *(y122 * w2)+ x103 *(y123 * w3) - EFInt(iZeta,iEta,33)= - & x101 *(y021 * z101)+ x102 *(y022 * z102)+ x103 *(y023 * z103) - EFInt(iZeta,iEta,34)= - & y221 * w1 + y222 * w2 + y223 * w3 - EFInt(iZeta,iEta,35)= - & y121 * z101 + y122 * z102 + y123 * z103 - EFInt(iZeta,iEta,36)= - & y021 * z201 + y022 * z202 + y023 * z203 - EFInt(iZeta,iEta,37)= - & (x101 * y011)* z011 +(x102 * y012)* z012 +(x103 * y013)* z013 - EFInt(iZeta,iEta,38)= - & y111 * z011 + y112 * z012 + y113 * z013 - EFInt(iZeta,iEta,39)= - & y011 * z111 + y012 * z112 + y013 * z113 - EFInt(iZeta,iEta,40)= - & (x201 * y011)* z011 +(x202 * y012)* z012 +(x203 * y013)* z013 - EFInt(iZeta,iEta,41)= - & (x101 * y111)* z011 +(x102 * y112)* z012 +(x103 * y113)* z013 - EFInt(iZeta,iEta,42)= - & (x101 * y011)* z111 +(x102 * y012)* z112 +(x103 * y013)* z113 - EFInt(iZeta,iEta,43)= - & y211 * z011 + y212 * z012 + y213 * z013 - EFInt(iZeta,iEta,44)= - & y111 * z111 + y112 * z112 + y113 * z113 - EFInt(iZeta,iEta,45)= - & y011 * z211 + y012 * z212 + y013 * z213 - EFInt(iZeta,iEta,46)= - & x101 * z021 + x102 * z022 + x103 * z023 - EFInt(iZeta,iEta,47)= - & (y101 * z021)+ (y102 * z022)+ (y103 * z023) - EFInt(iZeta,iEta,48)= - & z121 + z122 + z123 - EFInt(iZeta,iEta,49)= - & x201 * z021 + x202 * z022 + x203 * z023 - EFInt(iZeta,iEta,50)= - & x101 *(y101 * z021)+ x102 *(y102 * z022)+ x103 *(y103 * z023) - EFInt(iZeta,iEta,51)= - & x101 * z121 + x102 * z122 + x103 * z123 - EFInt(iZeta,iEta,52)= - & y201 * z021 + y202 * z022 + y203 * z023 - EFInt(iZeta,iEta,53)= - & y101 * z121 + y102 * z122 + y103 * z123 - EFInt(iZeta,iEta,54)= - & z221 + z222 + z223 - 23 Continue - 13 Continue - Go To 99 -* -*-----AACC case -* - 400 Continue - PQx = CoorAC(1,1)-CoorAC(1,2) - PQy = CoorAC(2,1)-CoorAC(2,2) - PQz = CoorAC(3,1)-CoorAC(3,2) - PQ2 = PQx**2 + PQy**2 + PQz**2 - Do 14 iEta = 1, nEta - Do 24 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) - T = rho * PQ2 - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - w3=(((((CW6(n,3)*z+CW5(n,3))*z+CW4(n,3))*z+CW3(n,3))*z+ - & CW2(n,3))*z+CW1(n,3))*z+Cw0(n,3) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - r3=(((((CR6(n,3)*z+CR5(n,3))*z+CR4(n,3))*z+CR3(n,3))*z+ - & CR2(n,3))*z+CR1(n,3))*z+CR0(n,3) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - w3= HerW(3)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - r3= HerR2(3)*ai - End If - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - w1 = PreFct*w1 - w2 = PreFct*w2 - w3 = PreFct*w3 - Eu21 = Eta(iEta)*(r1*ZEInv) - Eu22 = Eta(iEta)*(r2*ZEInv) - Eu23 = Eta(iEta)*(r3*ZEInv) - Zu21 = Zeta(iZeta)*(r1*ZEInv) - Zu22 = Zeta(iZeta)*(r2*ZEInv) - Zu23 = Zeta(iZeta)*(r3*ZEInv) - PAQPx1 = - Eu21 * PQx - PAQPx2 = - Eu22 * PQx - PAQPx3 = - Eu23 * PQx - PAQPy1 = - Eu21 * PQy - PAQPy2 = - Eu22 * PQy - PAQPy3 = - Eu23 * PQy - PAQPz1 = - Eu21 * PQz - PAQPz2 = - Eu22 * PQz - PAQPz3 = - Eu23 * PQz - QCPQx1 = Zu21 * PQx - QCPQx2 = Zu22 * PQx - QCPQx3 = Zu23 * PQx - QCPQy1 = Zu21 * PQy - QCPQy2 = Zu22 * PQy - QCPQy3 = Zu23 * PQy - QCPQz1 = Zu21 * PQz - QCPQz2 = Zu22 * PQz - QCPQz3 = Zu23 * PQz - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - B003 = Half * (r3*ZEInv) - B101 = (Half - Half * Eu21) * ZInv(iZeta) - B102 = (Half - Half * Eu22) * ZInv(iZeta) - B103 = (Half - Half * Eu23) * ZInv(iZeta) - B011 = (Half - Half * Zu21) * EInv(iEta) - B012 = (Half - Half * Zu22) * EInv(iEta) - B013 = (Half - Half * Zu23) * EInv(iEta) - x101= PAQPx1 - x102= PAQPx2 - x103= PAQPx3 - x011= QCPQx1 - x012= QCPQx2 - x013= QCPQx3 - x201= PAQPx1*x101 + B101 - x202= PAQPx2*x102 + B102 - x203= PAQPx3*x103 + B103 - x021= QCPQx1*x011 + B011 - x022= QCPQx2*x012 + B012 - x023= QCPQx3*x013 + B013 - x111= PAQPx1*QCPQx1 + B001 - x112= PAQPx2*QCPQx2 + B002 - x113= PAQPx3*QCPQx3 + B003 - x211= PAQPx1*x111 + B101*x011 + B001*x101 - x212= PAQPx2*x112 + B102*x012 + B002*x102 - x213= PAQPx3*x113 + B103*x013 + B003*x103 - x121= QCPQx1*x111 + B011*x101 + B001*x011 - x122= QCPQx2*x112 + B012*x102 + B002*x012 - x123= QCPQx3*x113 + B013*x103 + B003*x013 - x221= PAQPx1*x121 + B101*x021 + Two*B001*x111 - x222= PAQPx2*x122 + B102*x022 + Two*B002*x112 - x223= PAQPx3*x123 + B103*x023 + Two*B003*x113 - y101= PAQPy1 - y102= PAQPy2 - y103= PAQPy3 - y011= QCPQy1 - y012= QCPQy2 - y013= QCPQy3 - y201= PAQPy1*y101 + B101 - y202= PAQPy2*y102 + B102 - y203= PAQPy3*y103 + B103 - y021= QCPQy1*y011 + B011 - y022= QCPQy2*y012 + B012 - y023= QCPQy3*y013 + B013 - y111= PAQPy1*QCPQy1 + B001 - y112= PAQPy2*QCPQy2 + B002 - y113= PAQPy3*QCPQy3 + B003 - y211= PAQPy1*y111 + B101*y011 + B001*y101 - y212= PAQPy2*y112 + B102*y012 + B002*y102 - y213= PAQPy3*y113 + B103*y013 + B003*y103 - y121= QCPQy1*y111 + B011*y101 + B001*y011 - y122= QCPQy2*y112 + B012*y102 + B002*y012 - y123= QCPQy3*y113 + B013*y103 + B003*y013 - y221= PAQPy1*y121 + B101*y021 + Two*B001*y111 - y222= PAQPy2*y122 + B102*y022 + Two*B002*y112 - y223= PAQPy3*y123 + B103*y023 + Two*B003*y113 - z101= PAQPz1*w1 - z102= PAQPz2*w2 - z103= PAQPz3*w3 - z011= QCPQz1*w1 - z012= QCPQz2*w2 - z013= QCPQz3*w3 - z201= PAQPz1*z101 + B101*w1 - z202= PAQPz2*z102 + B102*w2 - z203= PAQPz3*z103 + B103*w3 - z021= QCPQz1*z011 + B011*w1 - z022= QCPQz2*z012 + B012*w2 - z023= QCPQz3*z013 + B013*w3 - z111= PAQPz1*QCPQz1*w1 + B001*w1 - z112= PAQPz2*QCPQz2*w2 + B002*w2 - z113= PAQPz3*QCPQz3*w3 + B003*w3 - z211= PAQPz1*z111 + B101*z011 + B001*z101 - z212= PAQPz2*z112 + B102*z012 + B002*z102 - z213= PAQPz3*z113 + B103*z013 + B003*z103 - z121= QCPQz1*z111 + B011*z101 + B001*z011 - z122= QCPQz2*z112 + B012*z102 + B002*z012 - z123= QCPQz3*z113 + B013*z103 + B003*z013 - z221= PAQPz1*z121 + B101*z021 + Two*B001*z111 - z222= PAQPz2*z122 + B102*z022 + Two*B002*z112 - z223= PAQPz3*z123 + B103*z023 + Two*B003*z113 - EFInt(iZeta,iEta, 1)= - & x221 * w1 + x222 * w2 + x223 * w3 - EFInt(iZeta,iEta, 2)= - & (x121 * w1)* y101 +(x122 * w2)* y102 +(x123 * w3)* y103 - EFInt(iZeta,iEta, 3)= - & x121 * z101 + x122 * z102 + x123 * z103 - EFInt(iZeta,iEta, 4)= - & x021 * y201 * w1 + x022 * y202 * w2 + x023 * y203 * w3 - EFInt(iZeta,iEta, 5)= - & (x021 * y101)* z101 +(x022 * y102)* z102 +(x023 * y103)* z103 - EFInt(iZeta,iEta, 6)= - & x021 * z201 + x022 * z202 + x023 * z203 - EFInt(iZeta,iEta, 7)= - & (x211 * w1)* y011 +(x212 * w2)* y012 +(x213 * w3)* y013 - EFInt(iZeta,iEta, 8)= - & x111 * y111 * w1 + x112 * y112 * w2 + x113 * y113 * w3 - EFInt(iZeta,iEta, 9)= - & x111 *(y011 * z101)+ x112 *(y012 * z102)+ x113 *(y013 * z103) - EFInt(iZeta,iEta,10)= - & x011 *(y211 * w1)+ x012 *(y212 * w2)+ x013 *(y213 * w3) - EFInt(iZeta,iEta,11)= - & (x011 * y111)* z101 +(x012 * y112)* z102 +(x013 * y113)* z103 - EFInt(iZeta,iEta,12)= - & (x011 * y011)* z201 +(x012 * y012)* z202 +(x013 * y013)* z203 - EFInt(iZeta,iEta,13)= - & x211 * z011 + x212 * z012 + x213 * z013 - EFInt(iZeta,iEta,14)= - & x111 *(y101 * z011)+ x112 *(y102 * z012)+ x113 *(y103 * z013) - EFInt(iZeta,iEta,15)= - & x111 * z111 + x112 * z112 + x113 * z113 - EFInt(iZeta,iEta,16)= - & (x011 * y201)* z011 +(x012 * y202)* z012 +(x013 * y203)* z013 - EFInt(iZeta,iEta,17)= - & (x011 * y101)* z111 +(x012 * y102)* z112 +(x013 * y103)* z113 - EFInt(iZeta,iEta,18)= - & x011 * z211 + x012 * z212 + x013 * z213 - EFInt(iZeta,iEta,19)= - & x201 * y021 * w1 + x202 * y022 * w2 + x203 * y023 * w3 - EFInt(iZeta,iEta,20)= - & x101 *(y121 * w1)+ x102 *(y122 * w2)+ x103 *(y123 * w3) - EFInt(iZeta,iEta,21)= - & x101 *(y021 * z101)+ x102 *(y022 * z102)+ x103 *(y023 * z103) - EFInt(iZeta,iEta,22)= - & y221 * w1 + y222 * w2 + y223 * w3 - EFInt(iZeta,iEta,23)= - & y121 * z101 + y122 * z102 + y123 * z103 - EFInt(iZeta,iEta,24)= - & y021 * z201 + y022 * z202 + y023 * z203 - EFInt(iZeta,iEta,25)= - & (x201 * y011)* z011 +(x202 * y012)* z012 +(x203 * y013)* z013 - EFInt(iZeta,iEta,26)= - & (x101 * y111)* z011 +(x102 * y112)* z012 +(x103 * y113)* z013 - EFInt(iZeta,iEta,27)= - & (x101 * y011)* z111 +(x102 * y012)* z112 +(x103 * y013)* z113 - EFInt(iZeta,iEta,28)= - & y211 * z011 + y212 * z012 + y213 * z013 - EFInt(iZeta,iEta,29)= - & y111 * z111 + y112 * z112 + y113 * z113 - EFInt(iZeta,iEta,30)= - & y011 * z211 + y012 * z212 + y013 * z213 - EFInt(iZeta,iEta,31)= - & x201 * z021 + x202 * z022 + x203 * z023 - EFInt(iZeta,iEta,32)= - & x101 *(y101 * z021)+ x102 *(y102 * z022)+ x103 *(y103 * z023) - EFInt(iZeta,iEta,33)= - & x101 * z121 + x102 * z122 + x103 * z123 - EFInt(iZeta,iEta,34)= - & y201 * z021 + y202 * z022 + y203 * z023 - EFInt(iZeta,iEta,35)= - & y101 * z121 + y102 * z122 + y103 * z123 - EFInt(iZeta,iEta,36)= - & z221 + z222 + z223 - 24 Continue - 14 Continue -* - 99 Continue -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/pppp.F90 openmolcas-22.10/src/rys_util/pppp.F90 --- openmolcas-22.02/src/rys_util/pppp.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/pppp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,960 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1994, Roland Lindh * +!*********************************************************************** + +subroutine pppp(EFInt,Zeta,ZInv,nZeta,P,lP,rKappAB,A,B,Eta,EInv,nEta,Q,lQ,rKappCD,C,D,CoorAC,TMax,iPntr,nPntr,x0,nMax,CW6,CW5,CW4, & + CW3,CW2,CW1,CW0,CR6,CR5,CR4,CR3,CR2,CR1,CR0,ddx,HerW,HerR2,IsChi,ChiI2) +!*********************************************************************** +! * +! Object: to compute the primitive integrals of type (pp|pp). * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. 1994 * +!*********************************************************************** + +use Constants, only: Zero, One, Two, Ten, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, lP, nEta, lQ, nPntr, iPntr(nPntr), nMax, IsChi +real(kind=wp), intent(out) :: EFInt(nZeta,nEta,81) +real(kind=wp), intent(in) :: Zeta(nZeta), ZInv(nZeta), P(lP,3), rKappAB(nZeta), A(3), B(3), Eta(nEta), EInv(nEta), Q(lQ,3), & + rKappCD(nEta), C(3), D(3), CoorAC(3,2), TMax, x0(nMax), CW6(nMax,3), CW5(nMax,3), CW4(nMax,3), & + CW3(nMax,3), CW2(nMax,3), CW1(nMax,3), CW0(nMax,3), CR6(nMax,3), CR5(nMax,3), CR4(nMax,3), & + CR3(nMax,3), CR2(nMax,3), CR1(nMax,3), CR0(nMax,3), ddx, HerW(3), HerR2(3), ChiI2 +integer(kind=iwp) :: iEta, iZeta, n +real(kind=wp) :: ai, B001, B002, B003, B011, B012, B013, B101, B102, B103, dddx, Eu21, Eu22, Eu23, PAQPx1, PAQPx2, PAQPx3, PAQPy1, & + PAQPy2, PAQPy3, PAQPz1, PAQPz2, PAQPz3, PQ2, PQx, PQy, PQz, PreFct, QCPQx1, QCPQx2, QCPQx3, QCPQy1, QCPQy2, & + QCPQy3, QCPQz1, QCPQz2, QCPQz3, r1, r2, r3, rho, si, t, w1, w2, w3, ww1, ww2, ww3, x011, x012, x013, x021, x022, & + x023, x101, x102, x103, x111, x112, x113, x121, x122, x123, x201, x202, x203, x211, x212, x213, x221, x222, x223, & + xdInv, y011, y012, y013, y021, y022, y023, y101, y102, y103, y111, y112, y113, y121, y122, y123, y201, y202, & + y203, y211, y212, y213, y221, y222, y223, z, z011, z012, z013, z021, z022, z023, z101, z102, z103, z111, z112, & + z113, z121, z122, z123, z201, z202, z203, z211, z212, z213, z221, z222, z223, ZEInv, Zu21, Zu22, Zu23 +logical(kind=iwp) :: ABeqCD, EQ + +xdInv = One/ddx +dddx = ddx/Ten+ddx + +ABeqCD = EQ(A,B) .and. EQ(A,C) .and. EQ(A,D) + +if (ABeqCD) then + + ! AAAA case + + z = -x0(1) + ww1 = (((((CW6(1,1)*z+CW5(1,1))*z+CW4(1,1))*z+CW3(1,1))*z+CW2(1,1))*z+CW1(1,1))*z+Cw0(1,1) + ww2 = (((((CW6(1,2)*z+CW5(1,2))*z+CW4(1,2))*z+CW3(1,2))*z+CW2(1,2))*z+CW1(1,2))*z+Cw0(1,2) + ww3 = (((((CW6(1,3)*z+CW5(1,3))*z+CW4(1,3))*z+CW3(1,3))*z+CW2(1,3))*z+CW1(1,3))*z+Cw0(1,3) + r1 = (((((CR6(1,1)*z+CR5(1,1))*z+CR4(1,1))*z+CR3(1,1))*z+CR2(1,1))*z+CR1(1,1))*z+CR0(1,1) + r2 = (((((CR6(1,2)*z+CR5(1,2))*z+CR4(1,2))*z+CR3(1,2))*z+CR2(1,2))*z+CR1(1,2))*z+CR0(1,2) + r3 = (((((CR6(1,3)*z+CR5(1,3))*z+CR4(1,3))*z+CR3(1,3))*z+CR2(1,3))*z+CR1(1,3))*z+CR0(1,3) + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + w1 = PreFct*ww1 + w2 = PreFct*ww2 + w3 = PreFct*ww3 + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Eu23 = Eta(iEta)*(r3*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + Zu23 = Zeta(iZeta)*(r3*ZEInv) + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + B003 = Half*(r3*ZEInv) + B101 = (Half-Half*Eu21)*ZInv(iZeta) + B102 = (Half-Half*Eu22)*ZInv(iZeta) + B103 = (Half-Half*Eu23)*ZInv(iZeta) + B011 = (Half-Half*Zu21)*EInv(iEta) + B012 = (Half-Half*Zu22)*EInv(iEta) + B013 = (Half-Half*Zu23)*EInv(iEta) + x201 = B101 + x202 = B102 + x203 = B103 + x021 = B011 + x022 = B012 + x023 = B013 + x111 = B001 + x112 = B002 + x113 = B003 + x221 = B101*x021+Two*B001*x111 + x222 = B102*x022+Two*B002*x112 + x223 = B103*x023+Two*B003*x113 + y201 = B101 + y202 = B102 + y203 = B103 + y021 = B011 + y022 = B012 + y023 = B013 + y111 = B001 + y112 = B002 + y113 = B003 + y221 = B101*y021+Two*B001*y111 + y222 = B102*y022+Two*B002*y112 + y223 = B103*y023+Two*B003*y113 + z201 = B101*w1 + z202 = B102*w2 + z203 = B103*w3 + z021 = B011*w1 + z022 = B012*w2 + z023 = B013*w3 + z111 = B001*w1 + z112 = B002*w2 + z113 = B003*w3 + z221 = B101*z021+Two*B001*z111 + z222 = B102*z022+Two*B002*z112 + z223 = B103*z023+Two*B003*z113 + EFInt(iZeta,iEta,1) = x221*w1+x222*w2+x223*w3 + EFInt(iZeta,iEta,2) = Zero + EFInt(iZeta,iEta,3) = Zero + EFInt(iZeta,iEta,4) = x021*y201*w1+x022*y202*w2+x023*y203*w3 + EFInt(iZeta,iEta,5) = Zero + EFInt(iZeta,iEta,6) = x021*z201+x022*z202+x023*z203 + EFInt(iZeta,iEta,7) = Zero + EFInt(iZeta,iEta,8) = x111*y111*w1+x112*y112*w2+x113*y113*w3 + EFInt(iZeta,iEta,9) = Zero + EFInt(iZeta,iEta,10) = Zero + EFInt(iZeta,iEta,11) = Zero + EFInt(iZeta,iEta,12) = Zero + EFInt(iZeta,iEta,13) = Zero + EFInt(iZeta,iEta,14) = Zero + EFInt(iZeta,iEta,15) = x111*z111+x112*z112+x113*z113 + EFInt(iZeta,iEta,16) = Zero + EFInt(iZeta,iEta,17) = Zero + EFInt(iZeta,iEta,18) = Zero + EFInt(iZeta,iEta,19) = x201*y021*w1+x202*y022*w2+x203*y023*w3 + EFInt(iZeta,iEta,20) = Zero + EFInt(iZeta,iEta,21) = Zero + EFInt(iZeta,iEta,22) = y221*w1+y222*w2+y223*w3 + EFInt(iZeta,iEta,23) = Zero + EFInt(iZeta,iEta,24) = y021*z201+y022*z202+y023*z203 + EFInt(iZeta,iEta,25) = Zero + EFInt(iZeta,iEta,26) = Zero + EFInt(iZeta,iEta,27) = Zero + EFInt(iZeta,iEta,28) = Zero + EFInt(iZeta,iEta,29) = y111*z111+y112*z112+y113*z113 + EFInt(iZeta,iEta,30) = Zero + EFInt(iZeta,iEta,31) = x201*z021+x202*z022+x203*z023 + EFInt(iZeta,iEta,32) = Zero + EFInt(iZeta,iEta,33) = Zero + EFInt(iZeta,iEta,34) = y201*z021+y202*z022+y203*z023 + EFInt(iZeta,iEta,35) = Zero + EFInt(iZeta,iEta,36) = z221+z222+z223 + end do + end do + +else if (EQ(A,B) .and. (.not. EQ(C,D))) then + + ! AACD case + + do iEta=1,nEta + do iZeta=1,nZeta + PQx = CoorAC(1,1)-Q(iEta,1) + PQy = CoorAC(2,1)-Q(iEta,2) + PQz = CoorAC(3,1)-Q(iEta,3) + PQ2 = PQx**2+PQy**2+PQz**2 + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) + T = rho*PQ2 + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + w3 = (((((CW6(n,3)*z+CW5(n,3))*z+CW4(n,3))*z+CW3(n,3))*z+CW2(n,3))*z+CW1(n,3))*z+Cw0(n,3) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + r3 = (((((CR6(n,3)*z+CR5(n,3))*z+CR4(n,3))*z+CR3(n,3))*z+CR2(n,3))*z+CR1(n,3))*z+CR0(n,3) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + w3 = HerW(3)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + r3 = HerR2(3)*ai + end if + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + w1 = PreFct*w1 + w2 = PreFct*w2 + w3 = PreFct*w3 + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Eu23 = Eta(iEta)*(r3*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + Zu23 = Zeta(iZeta)*(r3*ZEInv) + PAQPx1 = -Eu21*PQx + PAQPx2 = -Eu22*PQx + PAQPx3 = -Eu23*PQx + PAQPy1 = -Eu21*PQy + PAQPy2 = -Eu22*PQy + PAQPy3 = -Eu23*PQy + PAQPz1 = -Eu21*PQz + PAQPz2 = -Eu22*PQz + PAQPz3 = -Eu23*PQz + QCPQx1 = (Q(iEta,1)-CoorAC(1,2))+Zu21*PQx + QCPQx2 = (Q(iEta,1)-CoorAC(1,2))+Zu22*PQx + QCPQx3 = (Q(iEta,1)-CoorAC(1,2))+Zu23*PQx + QCPQy1 = (Q(iEta,2)-CoorAC(2,2))+Zu21*PQy + QCPQy2 = (Q(iEta,2)-CoorAC(2,2))+Zu22*PQy + QCPQy3 = (Q(iEta,2)-CoorAC(2,2))+Zu23*PQy + QCPQz1 = (Q(iEta,3)-CoorAC(3,2))+Zu21*PQz + QCPQz2 = (Q(iEta,3)-CoorAC(3,2))+Zu22*PQz + QCPQz3 = (Q(iEta,3)-CoorAC(3,2))+Zu23*PQz + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + B003 = Half*(r3*ZEInv) + B101 = (Half-Half*Eu21)*ZInv(iZeta) + B102 = (Half-Half*Eu22)*ZInv(iZeta) + B103 = (Half-Half*Eu23)*ZInv(iZeta) + B011 = (Half-Half*Zu21)*EInv(iEta) + B012 = (Half-Half*Zu22)*EInv(iEta) + B013 = (Half-Half*Zu23)*EInv(iEta) + x101 = PAQPx1 + x102 = PAQPx2 + x103 = PAQPx3 + x011 = QCPQx1 + x012 = QCPQx2 + x013 = QCPQx3 + x201 = PAQPx1*x101+B101 + x202 = PAQPx2*x102+B102 + x203 = PAQPx3*x103+B103 + x021 = QCPQx1*x011+B011 + x022 = QCPQx2*x012+B012 + x023 = QCPQx3*x013+B013 + x111 = PAQPx1*QCPQx1+B001 + x112 = PAQPx2*QCPQx2+B002 + x113 = PAQPx3*QCPQx3+B003 + x211 = PAQPx1*x111+B101*x011+B001*x101 + x212 = PAQPx2*x112+B102*x012+B002*x102 + x213 = PAQPx3*x113+B103*x013+B003*x103 + x121 = QCPQx1*x111+B011*x101+B001*x011 + x122 = QCPQx2*x112+B012*x102+B002*x012 + x123 = QCPQx3*x113+B013*x103+B003*x013 + x221 = PAQPx1*x121+B101*x021+Two*B001*x111 + x222 = PAQPx2*x122+B102*x022+Two*B002*x112 + x223 = PAQPx3*x123+B103*x023+Two*B003*x113 + y101 = PAQPy1 + y102 = PAQPy2 + y103 = PAQPy3 + y011 = QCPQy1 + y012 = QCPQy2 + y013 = QCPQy3 + y201 = PAQPy1*y101+B101 + y202 = PAQPy2*y102+B102 + y203 = PAQPy3*y103+B103 + y021 = QCPQy1*y011+B011 + y022 = QCPQy2*y012+B012 + y023 = QCPQy3*y013+B013 + y111 = PAQPy1*QCPQy1+B001 + y112 = PAQPy2*QCPQy2+B002 + y113 = PAQPy3*QCPQy3+B003 + y211 = PAQPy1*y111+B101*y011+B001*y101 + y212 = PAQPy2*y112+B102*y012+B002*y102 + y213 = PAQPy3*y113+B103*y013+B003*y103 + y121 = QCPQy1*y111+B011*y101+B001*y011 + y122 = QCPQy2*y112+B012*y102+B002*y012 + y123 = QCPQy3*y113+B013*y103+B003*y013 + y221 = PAQPy1*y121+B101*y021+Two*B001*y111 + y222 = PAQPy2*y122+B102*y022+Two*B002*y112 + y223 = PAQPy3*y123+B103*y023+Two*B003*y113 + z101 = PAQPz1*w1 + z102 = PAQPz2*w2 + z103 = PAQPz3*w3 + z011 = QCPQz1*w1 + z012 = QCPQz2*w2 + z013 = QCPQz3*w3 + z201 = PAQPz1*z101+B101*w1 + z202 = PAQPz2*z102+B102*w2 + z203 = PAQPz3*z103+B103*w3 + z021 = QCPQz1*z011+B011*w1 + z022 = QCPQz2*z012+B012*w2 + z023 = QCPQz3*z013+B013*w3 + z111 = PAQPz1*QCPQz1*w1+B001*w1 + z112 = PAQPz2*QCPQz2*w2+B002*w2 + z113 = PAQPz3*QCPQz3*w3+B003*w3 + z211 = PAQPz1*z111+B101*z011+B001*z101 + z212 = PAQPz2*z112+B102*z012+B002*z102 + z213 = PAQPz3*z113+B103*z013+B003*z103 + z121 = QCPQz1*z111+B011*z101+B001*z011 + z122 = QCPQz2*z112+B012*z102+B002*z012 + z123 = QCPQz3*z113+B013*z103+B003*z013 + z221 = PAQPz1*z121+B101*z021+Two*B001*z111 + z222 = PAQPz2*z122+B102*z022+Two*B002*z112 + z223 = PAQPz3*z123+B103*z023+Two*B003*z113 + EFInt(iZeta,iEta,1) = (x211*w1)+(x212*w2)+(x213*w3) + EFInt(iZeta,iEta,2) = (x111*w1)*y101+(x112*w2)*y102+(x113*w3)*y103 + EFInt(iZeta,iEta,3) = x111*z101+x112*z102+x113*z103 + EFInt(iZeta,iEta,4) = x011*y201*w1+x012*y202*w2+x013*y203*w3 + EFInt(iZeta,iEta,5) = (x011*y101)*z101+(x012*y102)*z102+(x013*y103)*z103 + EFInt(iZeta,iEta,6) = x011*z201+x012*z202+x013*z203 + EFInt(iZeta,iEta,7) = (x201*y011)*w1+(x202*y012)*w2+(x203*y013)*w3 + EFInt(iZeta,iEta,8) = (x101*y111)*w1+(x102*y112)*w2+(x103*y113)*w3 + EFInt(iZeta,iEta,9) = (x101*y011)*z101+(x102*y012)*z102+(x103*y013)*z103 + EFInt(iZeta,iEta,10) = (y211*w1)+(y212*w2)+(y213*w3) + EFInt(iZeta,iEta,11) = y111*z101+y112*z102+y113*z103 + EFInt(iZeta,iEta,12) = y011*z201+y012*z202+y013*z203 + EFInt(iZeta,iEta,13) = x201*z011+x202*z012+x203*z013 + EFInt(iZeta,iEta,14) = x101*(y101*z011)+x102*(y102*z012)+x103*(y103*z013) + EFInt(iZeta,iEta,15) = x101*z111+x102*z112+x103*z113 + EFInt(iZeta,iEta,16) = y201*z011+y202*z012+y203*z013 + EFInt(iZeta,iEta,17) = y101*z111+y102*z112+y103*z113 + EFInt(iZeta,iEta,18) = z211+z212+z213 + EFInt(iZeta,iEta,19) = x221*w1+x222*w2+x223*w3 + EFInt(iZeta,iEta,20) = (x121*w1)*y101+(x122*w2)*y102+(x123*w3)*y103 + EFInt(iZeta,iEta,21) = x121*z101+x122*z102+x123*z103 + EFInt(iZeta,iEta,22) = x021*y201*w1+x022*y202*w2+x023*y203*w3 + EFInt(iZeta,iEta,23) = (x021*y101)*z101+(x022*y102)*z102+(x023*y103)*z103 + EFInt(iZeta,iEta,24) = x021*z201+x022*z202+x023*z203 + EFInt(iZeta,iEta,25) = (x211*w1)*y011+(x212*w2)*y012+(x213*w3)*y013 + EFInt(iZeta,iEta,26) = x111*y111*w1+x112*y112*w2+x113*y113*w3 + EFInt(iZeta,iEta,27) = x111*(y011*z101)+x112*(y012*z102)+x113*(y013*z103) + EFInt(iZeta,iEta,28) = x011*(y211*w1)+x012*(y212*w2)+x013*(y213*w3) + EFInt(iZeta,iEta,29) = (x011*y111)*z101+(x012*y112)*z102+(x013*y113)*z103 + EFInt(iZeta,iEta,30) = (x011*y011)*z201+(x012*y012)*z202+(x013*y013)*z203 + EFInt(iZeta,iEta,31) = x211*z011+x212*z012+x213*z013 + EFInt(iZeta,iEta,32) = x111*(y101*z011)+x112*(y102*z012)+x113*(y103*z013) + EFInt(iZeta,iEta,33) = x111*z111+x112*z112+x113*z113 + EFInt(iZeta,iEta,34) = (x011*y201)*z011+(x012*y202)*z012+(x013*y203)*z013 + EFInt(iZeta,iEta,35) = (x011*y101)*z111+(x012*y102)*z112+(x013*y103)*z113 + EFInt(iZeta,iEta,36) = x011*z211+x012*z212+x013*z213 + EFInt(iZeta,iEta,37) = x201*y021*w1+x202*y022*w2+x203*y023*w3 + EFInt(iZeta,iEta,38) = x101*(y121*w1)+x102*(y122*w2)+x103*(y123*w3) + EFInt(iZeta,iEta,39) = x101*(y021*z101)+x102*(y022*z102)+x103*(y023*z103) + EFInt(iZeta,iEta,40) = y221*w1+y222*w2+y223*w3 + EFInt(iZeta,iEta,41) = y121*z101+y122*z102+y123*z103 + EFInt(iZeta,iEta,42) = y021*z201+y022*z202+y023*z203 + EFInt(iZeta,iEta,43) = (x201*y011)*z011+(x202*y012)*z012+(x203*y013)*z013 + EFInt(iZeta,iEta,44) = (x101*y111)*z011+(x102*y112)*z012+(x103*y113)*z013 + EFInt(iZeta,iEta,45) = (x101*y011)*z111+(x102*y012)*z112+(x103*y013)*z113 + EFInt(iZeta,iEta,46) = y211*z011+y212*z012+y213*z013 + EFInt(iZeta,iEta,47) = y111*z111+y112*z112+y113*z113 + EFInt(iZeta,iEta,48) = y011*z211+y012*z212+y013*z213 + EFInt(iZeta,iEta,49) = x201*z021+x202*z022+x203*z023 + EFInt(iZeta,iEta,50) = x101*(y101*z021)+x102*(y102*z022)+x103*(y103*z023) + EFInt(iZeta,iEta,51) = x101*z121+x102*z122+x103*z123 + EFInt(iZeta,iEta,52) = y201*z021+y202*z022+y203*z023 + EFInt(iZeta,iEta,53) = y101*z121+y102*z122+y103*z123 + EFInt(iZeta,iEta,54) = z221+z222+z223 + end do + end do + +else if ((.not. EQ(A,B)) .and. EQ(C,D)) then + + ! ABCC case + + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) + PQx = P(iZeta,1)-CoorAC(1,2) + PQy = P(iZeta,2)-CoorAC(2,2) + PQz = P(iZeta,3)-CoorAC(3,2) + T = rho*(PQx**2+PQy**2+PQz**2) + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + w3 = (((((CW6(n,3)*z+CW5(n,3))*z+CW4(n,3))*z+CW3(n,3))*z+CW2(n,3))*z+CW1(n,3))*z+Cw0(n,3) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + r3 = (((((CR6(n,3)*z+CR5(n,3))*z+CR4(n,3))*z+CR3(n,3))*z+CR2(n,3))*z+CR1(n,3))*z+CR0(n,3) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + w3 = HerW(3)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + r3 = HerR2(3)*ai + end if + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + w1 = PreFct*w1 + w2 = PreFct*w2 + w3 = PreFct*w3 + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Eu23 = Eta(iEta)*(r3*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + Zu23 = Zeta(iZeta)*(r3*ZEInv) + PAQPx1 = (P(iZeta,1)-CoorAC(1,1))-Eu21*PQx + PAQPx2 = (P(iZeta,1)-CoorAC(1,1))-Eu22*PQx + PAQPx3 = (P(iZeta,1)-CoorAC(1,1))-Eu23*PQx + PAQPy1 = (P(iZeta,2)-CoorAC(2,1))-Eu21*PQy + PAQPy2 = (P(iZeta,2)-CoorAC(2,1))-Eu22*PQy + PAQPy3 = (P(iZeta,2)-CoorAC(2,1))-Eu23*PQy + PAQPz1 = (P(iZeta,3)-CoorAC(3,1))-Eu21*PQz + PAQPz2 = (P(iZeta,3)-CoorAC(3,1))-Eu22*PQz + PAQPz3 = (P(iZeta,3)-CoorAC(3,1))-Eu23*PQz + QCPQx1 = Zu21*PQx + QCPQx2 = Zu22*PQx + QCPQx3 = Zu23*PQx + QCPQy1 = Zu21*PQy + QCPQy2 = Zu22*PQy + QCPQy3 = Zu23*PQy + QCPQz1 = Zu21*PQz + QCPQz2 = Zu22*PQz + QCPQz3 = Zu23*PQz + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + B003 = Half*(r3*ZEInv) + B101 = (Half-Half*Eu21)*ZInv(iZeta) + B102 = (Half-Half*Eu22)*ZInv(iZeta) + B103 = (Half-Half*Eu23)*ZInv(iZeta) + B011 = (Half-Half*Zu21)*EInv(iEta) + B012 = (Half-Half*Zu22)*EInv(iEta) + B013 = (Half-Half*Zu23)*EInv(iEta) + x101 = PAQPx1 + x102 = PAQPx2 + x103 = PAQPx3 + x011 = QCPQx1 + x012 = QCPQx2 + x013 = QCPQx3 + x201 = PAQPx1*x101+B101 + x202 = PAQPx2*x102+B102 + x203 = PAQPx3*x103+B103 + x021 = QCPQx1*x011+B011 + x022 = QCPQx2*x012+B012 + x023 = QCPQx3*x013+B013 + x111 = PAQPx1*QCPQx1+B001 + x112 = PAQPx2*QCPQx2+B002 + x113 = PAQPx3*QCPQx3+B003 + x211 = PAQPx1*x111+B101*x011+B001*x101 + x212 = PAQPx2*x112+B102*x012+B002*x102 + x213 = PAQPx3*x113+B103*x013+B003*x103 + x121 = QCPQx1*x111+B011*x101+B001*x011 + x122 = QCPQx2*x112+B012*x102+B002*x012 + x123 = QCPQx3*x113+B013*x103+B003*x013 + x221 = PAQPx1*x121+B101*x021+Two*B001*x111 + x222 = PAQPx2*x122+B102*x022+Two*B002*x112 + x223 = PAQPx3*x123+B103*x023+Two*B003*x113 + y101 = PAQPy1 + y102 = PAQPy2 + y103 = PAQPy3 + y011 = QCPQy1 + y012 = QCPQy2 + y013 = QCPQy3 + y201 = PAQPy1*y101+B101 + y202 = PAQPy2*y102+B102 + y203 = PAQPy3*y103+B103 + y021 = QCPQy1*y011+B011 + y022 = QCPQy2*y012+B012 + y023 = QCPQy3*y013+B013 + y111 = PAQPy1*QCPQy1+B001 + y112 = PAQPy2*QCPQy2+B002 + y113 = PAQPy3*QCPQy3+B003 + y211 = PAQPy1*y111+B101*y011+B001*y101 + y212 = PAQPy2*y112+B102*y012+B002*y102 + y213 = PAQPy3*y113+B103*y013+B003*y103 + y121 = QCPQy1*y111+B011*y101+B001*y011 + y122 = QCPQy2*y112+B012*y102+B002*y012 + y123 = QCPQy3*y113+B013*y103+B003*y013 + y221 = PAQPy1*y121+B101*y021+Two*B001*y111 + y222 = PAQPy2*y122+B102*y022+Two*B002*y112 + y223 = PAQPy3*y123+B103*y023+Two*B003*y113 + z101 = PAQPz1*w1 + z102 = PAQPz2*w2 + z103 = PAQPz3*w3 + z011 = QCPQz1*w1 + z012 = QCPQz2*w2 + z013 = QCPQz3*w3 + z201 = PAQPz1*z101+B101*w1 + z202 = PAQPz2*z102+B102*w2 + z203 = PAQPz3*z103+B103*w3 + z021 = QCPQz1*z011+B011*w1 + z022 = QCPQz2*z012+B012*w2 + z023 = QCPQz3*z013+B013*w3 + z111 = PAQPz1*QCPQz1*w1+B001*w1 + z112 = PAQPz2*QCPQz2*w2+B002*w2 + z113 = PAQPz3*QCPQz3*w3+B003*w3 + z211 = PAQPz1*z111+B101*z011+B001*z101 + z212 = PAQPz2*z112+B102*z012+B002*z102 + z213 = PAQPz3*z113+B103*z013+B003*z103 + z121 = QCPQz1*z111+B011*z101+B001*z011 + z122 = QCPQz2*z112+B012*z102+B002*z012 + z123 = QCPQz3*z113+B013*z103+B003*z013 + z221 = PAQPz1*z121+B101*z021+Two*B001*z111 + z222 = PAQPz2*z122+B102*z022+Two*B002*z112 + z223 = PAQPz3*z123+B103*z023+Two*B003*z113 + EFInt(iZeta,iEta,1) = (x121*w1)+(x122*w2)+(x123*w3) + EFInt(iZeta,iEta,2) = (x021*y101)*w1+(x022*y102)*w2+(x023*y103)*w3 + EFInt(iZeta,iEta,3) = x021*z101+x022*z102+x023*z103 + EFInt(iZeta,iEta,4) = x221*w1+x222*w2+x223*w3 + EFInt(iZeta,iEta,5) = (x121*w1)*y101+(x122*w2)*y102+(x123*w3)*y103 + EFInt(iZeta,iEta,6) = x121*z101+x122*z102+x123*z103 + EFInt(iZeta,iEta,7) = x021*y201*w1+x022*y202*w2+x023*y203*w3 + EFInt(iZeta,iEta,8) = (x021*y101)*z101+(x022*y102)*z102+(x023*y103)*z103 + EFInt(iZeta,iEta,9) = x021*z201+x022*z202+x023*z203 + EFInt(iZeta,iEta,10) = (x111*w1)*y011+(x112*w2)*y012+(x113*w3)*y013 + EFInt(iZeta,iEta,11) = (x011*y111)*w1+(x012*y112)*w2+(x013*y113)*w3 + EFInt(iZeta,iEta,12) = (x011*y011)*z101+(x012*y012)*z102+(x013*y013)*z103 + EFInt(iZeta,iEta,13) = (x211*w1)*y011+(x212*w2)*y012+(x213*w3)*y013 + EFInt(iZeta,iEta,14) = x111*y111*w1+x112*y112*w2+x113*y113*w3 + EFInt(iZeta,iEta,15) = x111*(y011*z101)+x112*(y012*z102)+x113*(y013*z103) + EFInt(iZeta,iEta,16) = x011*(y211*w1)+x012*(y212*w2)+x013*(y213*w3) + EFInt(iZeta,iEta,17) = (x011*y111)*z101+(x012*y112)*z102+(x013*y113)*z103 + EFInt(iZeta,iEta,18) = (x011*y011)*z201+(x012*y012)*z202+(x013*y013)*z203 + EFInt(iZeta,iEta,19) = x111*z011+x112*z012+x113*z013 + EFInt(iZeta,iEta,20) = (x011*y101)*z011+(x012*y102)*z012+(x013*y103)*z013 + EFInt(iZeta,iEta,21) = x011*z111+x012*z112+x013*z113 + EFInt(iZeta,iEta,22) = x211*z011+x212*z012+x213*z013 + EFInt(iZeta,iEta,23) = x111*(y101*z011)+x112*(y102*z012)+x113*(y103*z013) + EFInt(iZeta,iEta,24) = x111*z111+x112*z112+x113*z113 + EFInt(iZeta,iEta,25) = (x011*y201)*z011+(x012*y202)*z012+(x013*y203)*z013 + EFInt(iZeta,iEta,26) = (x011*y101)*z111+(x012*y102)*z112+(x013*y103)*z113 + EFInt(iZeta,iEta,27) = x011*z211+x012*z212+x013*z213 + EFInt(iZeta,iEta,28) = x101*y021*w1+x102*y022*w2+x103*y023*w3 + EFInt(iZeta,iEta,29) = (y121*w1)+(y122*w2)+(y123*w3) + EFInt(iZeta,iEta,30) = (y021*z101)+(y022*z102)+(y023*z103) + EFInt(iZeta,iEta,31) = x201*y021*w1+x202*y022*w2+x203*y023*w3 + EFInt(iZeta,iEta,32) = x101*(y121*w1)+x102*(y122*w2)+x103*(y123*w3) + EFInt(iZeta,iEta,33) = x101*(y021*z101)+x102*(y022*z102)+x103*(y023*z103) + EFInt(iZeta,iEta,34) = y221*w1+y222*w2+y223*w3 + EFInt(iZeta,iEta,35) = y121*z101+y122*z102+y123*z103 + EFInt(iZeta,iEta,36) = y021*z201+y022*z202+y023*z203 + EFInt(iZeta,iEta,37) = (x101*y011)*z011+(x102*y012)*z012+(x103*y013)*z013 + EFInt(iZeta,iEta,38) = y111*z011+y112*z012+y113*z013 + EFInt(iZeta,iEta,39) = y011*z111+y012*z112+y013*z113 + EFInt(iZeta,iEta,40) = (x201*y011)*z011+(x202*y012)*z012+(x203*y013)*z013 + EFInt(iZeta,iEta,41) = (x101*y111)*z011+(x102*y112)*z012+(x103*y113)*z013 + EFInt(iZeta,iEta,42) = (x101*y011)*z111+(x102*y012)*z112+(x103*y013)*z113 + EFInt(iZeta,iEta,43) = y211*z011+y212*z012+y213*z013 + EFInt(iZeta,iEta,44) = y111*z111+y112*z112+y113*z113 + EFInt(iZeta,iEta,45) = y011*z211+y012*z212+y013*z213 + EFInt(iZeta,iEta,46) = x101*z021+x102*z022+x103*z023 + EFInt(iZeta,iEta,47) = (y101*z021)+(y102*z022)+(y103*z023) + EFInt(iZeta,iEta,48) = z121+z122+z123 + EFInt(iZeta,iEta,49) = x201*z021+x202*z022+x203*z023 + EFInt(iZeta,iEta,50) = x101*(y101*z021)+x102*(y102*z022)+x103*(y103*z023) + EFInt(iZeta,iEta,51) = x101*z121+x102*z122+x103*z123 + EFInt(iZeta,iEta,52) = y201*z021+y202*z022+y203*z023 + EFInt(iZeta,iEta,53) = y101*z121+y102*z122+y103*z123 + EFInt(iZeta,iEta,54) = z221+z222+z223 + end do + end do + +else if (EQ(A,B) .and. EQ(C,D)) then + + ! AACC case + + PQx = CoorAC(1,1)-CoorAC(1,2) + PQy = CoorAC(2,1)-CoorAC(2,2) + PQz = CoorAC(3,1)-CoorAC(3,2) + PQ2 = PQx**2+PQy**2+PQz**2 + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) + T = rho*PQ2 + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + w3 = (((((CW6(n,3)*z+CW5(n,3))*z+CW4(n,3))*z+CW3(n,3))*z+CW2(n,3))*z+CW1(n,3))*z+Cw0(n,3) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + r3 = (((((CR6(n,3)*z+CR5(n,3))*z+CR4(n,3))*z+CR3(n,3))*z+CR2(n,3))*z+CR1(n,3))*z+CR0(n,3) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + w3 = HerW(3)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + r3 = HerR2(3)*ai + end if + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + w1 = PreFct*w1 + w2 = PreFct*w2 + w3 = PreFct*w3 + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Eu23 = Eta(iEta)*(r3*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + Zu23 = Zeta(iZeta)*(r3*ZEInv) + PAQPx1 = -Eu21*PQx + PAQPx2 = -Eu22*PQx + PAQPx3 = -Eu23*PQx + PAQPy1 = -Eu21*PQy + PAQPy2 = -Eu22*PQy + PAQPy3 = -Eu23*PQy + PAQPz1 = -Eu21*PQz + PAQPz2 = -Eu22*PQz + PAQPz3 = -Eu23*PQz + QCPQx1 = Zu21*PQx + QCPQx2 = Zu22*PQx + QCPQx3 = Zu23*PQx + QCPQy1 = Zu21*PQy + QCPQy2 = Zu22*PQy + QCPQy3 = Zu23*PQy + QCPQz1 = Zu21*PQz + QCPQz2 = Zu22*PQz + QCPQz3 = Zu23*PQz + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + B003 = Half*(r3*ZEInv) + B101 = (Half-Half*Eu21)*ZInv(iZeta) + B102 = (Half-Half*Eu22)*ZInv(iZeta) + B103 = (Half-Half*Eu23)*ZInv(iZeta) + B011 = (Half-Half*Zu21)*EInv(iEta) + B012 = (Half-Half*Zu22)*EInv(iEta) + B013 = (Half-Half*Zu23)*EInv(iEta) + x101 = PAQPx1 + x102 = PAQPx2 + x103 = PAQPx3 + x011 = QCPQx1 + x012 = QCPQx2 + x013 = QCPQx3 + x201 = PAQPx1*x101+B101 + x202 = PAQPx2*x102+B102 + x203 = PAQPx3*x103+B103 + x021 = QCPQx1*x011+B011 + x022 = QCPQx2*x012+B012 + x023 = QCPQx3*x013+B013 + x111 = PAQPx1*QCPQx1+B001 + x112 = PAQPx2*QCPQx2+B002 + x113 = PAQPx3*QCPQx3+B003 + x211 = PAQPx1*x111+B101*x011+B001*x101 + x212 = PAQPx2*x112+B102*x012+B002*x102 + x213 = PAQPx3*x113+B103*x013+B003*x103 + x121 = QCPQx1*x111+B011*x101+B001*x011 + x122 = QCPQx2*x112+B012*x102+B002*x012 + x123 = QCPQx3*x113+B013*x103+B003*x013 + x221 = PAQPx1*x121+B101*x021+Two*B001*x111 + x222 = PAQPx2*x122+B102*x022+Two*B002*x112 + x223 = PAQPx3*x123+B103*x023+Two*B003*x113 + y101 = PAQPy1 + y102 = PAQPy2 + y103 = PAQPy3 + y011 = QCPQy1 + y012 = QCPQy2 + y013 = QCPQy3 + y201 = PAQPy1*y101+B101 + y202 = PAQPy2*y102+B102 + y203 = PAQPy3*y103+B103 + y021 = QCPQy1*y011+B011 + y022 = QCPQy2*y012+B012 + y023 = QCPQy3*y013+B013 + y111 = PAQPy1*QCPQy1+B001 + y112 = PAQPy2*QCPQy2+B002 + y113 = PAQPy3*QCPQy3+B003 + y211 = PAQPy1*y111+B101*y011+B001*y101 + y212 = PAQPy2*y112+B102*y012+B002*y102 + y213 = PAQPy3*y113+B103*y013+B003*y103 + y121 = QCPQy1*y111+B011*y101+B001*y011 + y122 = QCPQy2*y112+B012*y102+B002*y012 + y123 = QCPQy3*y113+B013*y103+B003*y013 + y221 = PAQPy1*y121+B101*y021+Two*B001*y111 + y222 = PAQPy2*y122+B102*y022+Two*B002*y112 + y223 = PAQPy3*y123+B103*y023+Two*B003*y113 + z101 = PAQPz1*w1 + z102 = PAQPz2*w2 + z103 = PAQPz3*w3 + z011 = QCPQz1*w1 + z012 = QCPQz2*w2 + z013 = QCPQz3*w3 + z201 = PAQPz1*z101+B101*w1 + z202 = PAQPz2*z102+B102*w2 + z203 = PAQPz3*z103+B103*w3 + z021 = QCPQz1*z011+B011*w1 + z022 = QCPQz2*z012+B012*w2 + z023 = QCPQz3*z013+B013*w3 + z111 = PAQPz1*QCPQz1*w1+B001*w1 + z112 = PAQPz2*QCPQz2*w2+B002*w2 + z113 = PAQPz3*QCPQz3*w3+B003*w3 + z211 = PAQPz1*z111+B101*z011+B001*z101 + z212 = PAQPz2*z112+B102*z012+B002*z102 + z213 = PAQPz3*z113+B103*z013+B003*z103 + z121 = QCPQz1*z111+B011*z101+B001*z011 + z122 = QCPQz2*z112+B012*z102+B002*z012 + z123 = QCPQz3*z113+B013*z103+B003*z013 + z221 = PAQPz1*z121+B101*z021+Two*B001*z111 + z222 = PAQPz2*z122+B102*z022+Two*B002*z112 + z223 = PAQPz3*z123+B103*z023+Two*B003*z113 + EFInt(iZeta,iEta,1) = x221*w1+x222*w2+x223*w3 + EFInt(iZeta,iEta,2) = (x121*w1)*y101+(x122*w2)*y102+(x123*w3)*y103 + EFInt(iZeta,iEta,3) = x121*z101+x122*z102+x123*z103 + EFInt(iZeta,iEta,4) = x021*y201*w1+x022*y202*w2+x023*y203*w3 + EFInt(iZeta,iEta,5) = (x021*y101)*z101+(x022*y102)*z102+(x023*y103)*z103 + EFInt(iZeta,iEta,6) = x021*z201+x022*z202+x023*z203 + EFInt(iZeta,iEta,7) = (x211*w1)*y011+(x212*w2)*y012+(x213*w3)*y013 + EFInt(iZeta,iEta,8) = x111*y111*w1+x112*y112*w2+x113*y113*w3 + EFInt(iZeta,iEta,9) = x111*(y011*z101)+x112*(y012*z102)+x113*(y013*z103) + EFInt(iZeta,iEta,10) = x011*(y211*w1)+x012*(y212*w2)+x013*(y213*w3) + EFInt(iZeta,iEta,11) = (x011*y111)*z101+(x012*y112)*z102+(x013*y113)*z103 + EFInt(iZeta,iEta,12) = (x011*y011)*z201+(x012*y012)*z202+(x013*y013)*z203 + EFInt(iZeta,iEta,13) = x211*z011+x212*z012+x213*z013 + EFInt(iZeta,iEta,14) = x111*(y101*z011)+x112*(y102*z012)+x113*(y103*z013) + EFInt(iZeta,iEta,15) = x111*z111+x112*z112+x113*z113 + EFInt(iZeta,iEta,16) = (x011*y201)*z011+(x012*y202)*z012+(x013*y203)*z013 + EFInt(iZeta,iEta,17) = (x011*y101)*z111+(x012*y102)*z112+(x013*y103)*z113 + EFInt(iZeta,iEta,18) = x011*z211+x012*z212+x013*z213 + EFInt(iZeta,iEta,19) = x201*y021*w1+x202*y022*w2+x203*y023*w3 + EFInt(iZeta,iEta,20) = x101*(y121*w1)+x102*(y122*w2)+x103*(y123*w3) + EFInt(iZeta,iEta,21) = x101*(y021*z101)+x102*(y022*z102)+x103*(y023*z103) + EFInt(iZeta,iEta,22) = y221*w1+y222*w2+y223*w3 + EFInt(iZeta,iEta,23) = y121*z101+y122*z102+y123*z103 + EFInt(iZeta,iEta,24) = y021*z201+y022*z202+y023*z203 + EFInt(iZeta,iEta,25) = (x201*y011)*z011+(x202*y012)*z012+(x203*y013)*z013 + EFInt(iZeta,iEta,26) = (x101*y111)*z011+(x102*y112)*z012+(x103*y113)*z013 + EFInt(iZeta,iEta,27) = (x101*y011)*z111+(x102*y012)*z112+(x103*y013)*z113 + EFInt(iZeta,iEta,28) = y211*z011+y212*z012+y213*z013 + EFInt(iZeta,iEta,29) = y111*z111+y112*z112+y113*z113 + EFInt(iZeta,iEta,30) = y011*z211+y012*z212+y013*z213 + EFInt(iZeta,iEta,31) = x201*z021+x202*z022+x203*z023 + EFInt(iZeta,iEta,32) = x101*(y101*z021)+x102*(y102*z022)+x103*(y103*z023) + EFInt(iZeta,iEta,33) = x101*z121+x102*z122+x103*z123 + EFInt(iZeta,iEta,34) = y201*z021+y202*z022+y203*z023 + EFInt(iZeta,iEta,35) = y101*z121+y102*z122+y103*z123 + EFInt(iZeta,iEta,36) = z221+z222+z223 + end do + end do + +else + + ! ABCD case + + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) + PQx = P(iZeta,1)-Q(iEta,1) + PQy = P(iZeta,2)-Q(iEta,2) + PQz = P(iZeta,3)-Q(iEta,3) + T = rho*(PQx**2+PQy**2+PQz**2) + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + w3 = (((((CW6(n,3)*z+CW5(n,3))*z+CW4(n,3))*z+CW3(n,3))*z+CW2(n,3))*z+CW1(n,3))*z+Cw0(n,3) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + r3 = (((((CR6(n,3)*z+CR5(n,3))*z+CR4(n,3))*z+CR3(n,3))*z+CR2(n,3))*z+CR1(n,3))*z+CR0(n,3) + else + ai = One/T + si = sqrt(ai) + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + r3 = HerR2(3)*ai + w1 = HerW(1)*si + w2 = HerW(2)*si + w3 = HerW(3)*si + end if + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + w1 = PreFct*w1 + w2 = PreFct*w2 + w3 = PreFct*w3 + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Eu23 = Eta(iEta)*(r3*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + Zu23 = Zeta(iZeta)*(r3*ZEInv) + PAQPx1 = (P(iZeta,1)-CoorAC(1,1))-Eu21*PQx + PAQPx2 = (P(iZeta,1)-CoorAC(1,1))-Eu22*PQx + PAQPx3 = (P(iZeta,1)-CoorAC(1,1))-Eu23*PQx + PAQPy1 = (P(iZeta,2)-CoorAC(2,1))-Eu21*PQy + PAQPy2 = (P(iZeta,2)-CoorAC(2,1))-Eu22*PQy + PAQPy3 = (P(iZeta,2)-CoorAC(2,1))-Eu23*PQy + PAQPz1 = (P(iZeta,3)-CoorAC(3,1))-Eu21*PQz + PAQPz2 = (P(iZeta,3)-CoorAC(3,1))-Eu22*PQz + PAQPz3 = (P(iZeta,3)-CoorAC(3,1))-Eu23*PQz + QCPQx1 = (Q(iEta,1)-CoorAC(1,2))+Zu21*PQx + QCPQx2 = (Q(iEta,1)-CoorAC(1,2))+Zu22*PQx + QCPQx3 = (Q(iEta,1)-CoorAC(1,2))+Zu23*PQx + QCPQy1 = (Q(iEta,2)-CoorAC(2,2))+Zu21*PQy + QCPQy2 = (Q(iEta,2)-CoorAC(2,2))+Zu22*PQy + QCPQy3 = (Q(iEta,2)-CoorAC(2,2))+Zu23*PQy + QCPQz1 = (Q(iEta,3)-CoorAC(3,2))+Zu21*PQz + QCPQz2 = (Q(iEta,3)-CoorAC(3,2))+Zu22*PQz + QCPQz3 = (Q(iEta,3)-CoorAC(3,2))+Zu23*PQz + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + B003 = Half*(r3*ZEInv) + B101 = (Half-Half*Eu21)*ZInv(iZeta) + B102 = (Half-Half*Eu22)*ZInv(iZeta) + B103 = (Half-Half*Eu23)*ZInv(iZeta) + B011 = (Half-Half*Zu21)*EInv(iEta) + B012 = (Half-Half*Zu22)*EInv(iEta) + B013 = (Half-Half*Zu23)*EInv(iEta) + x101 = PAQPx1 + x102 = PAQPx2 + x103 = PAQPx3 + x011 = QCPQx1 + x012 = QCPQx2 + x013 = QCPQx3 + x201 = PAQPx1*x101+B101 + x202 = PAQPx2*x102+B102 + x203 = PAQPx3*x103+B103 + x021 = QCPQx1*x011+B011 + x022 = QCPQx2*x012+B012 + x023 = QCPQx3*x013+B013 + x111 = PAQPx1*QCPQx1+B001 + x112 = PAQPx2*QCPQx2+B002 + x113 = PAQPx3*QCPQx3+B003 + x211 = PAQPx1*x111+B101*x011+B001*x101 + x212 = PAQPx2*x112+B102*x012+B002*x102 + x213 = PAQPx3*x113+B103*x013+B003*x103 + x121 = QCPQx1*x111+B011*x101+B001*x011 + x122 = QCPQx2*x112+B012*x102+B002*x012 + x123 = QCPQx3*x113+B013*x103+B003*x013 + x221 = PAQPx1*x121+B101*x021+Two*B001*x111 + x222 = PAQPx2*x122+B102*x022+Two*B002*x112 + x223 = PAQPx3*x123+B103*x023+Two*B003*x113 + y101 = PAQPy1 + y102 = PAQPy2 + y103 = PAQPy3 + y011 = QCPQy1 + y012 = QCPQy2 + y013 = QCPQy3 + y201 = PAQPy1*y101+B101 + y202 = PAQPy2*y102+B102 + y203 = PAQPy3*y103+B103 + y021 = QCPQy1*y011+B011 + y022 = QCPQy2*y012+B012 + y023 = QCPQy3*y013+B013 + y111 = PAQPy1*QCPQy1+B001 + y112 = PAQPy2*QCPQy2+B002 + y113 = PAQPy3*QCPQy3+B003 + y211 = PAQPy1*y111+B101*y011+B001*y101 + y212 = PAQPy2*y112+B102*y012+B002*y102 + y213 = PAQPy3*y113+B103*y013+B003*y103 + y121 = QCPQy1*y111+B011*y101+B001*y011 + y122 = QCPQy2*y112+B012*y102+B002*y012 + y123 = QCPQy3*y113+B013*y103+B003*y013 + y221 = PAQPy1*y121+B101*y021+Two*B001*y111 + y222 = PAQPy2*y122+B102*y022+Two*B002*y112 + y223 = PAQPy3*y123+B103*y023+Two*B003*y113 + z101 = PAQPz1*w1 + z102 = PAQPz2*w2 + z103 = PAQPz3*w3 + z011 = QCPQz1*w1 + z012 = QCPQz2*w2 + z013 = QCPQz3*w3 + z201 = PAQPz1*z101+B101*w1 + z202 = PAQPz2*z102+B102*w2 + z203 = PAQPz3*z103+B103*w3 + z021 = QCPQz1*z011+B011*w1 + z022 = QCPQz2*z012+B012*w2 + z023 = QCPQz3*z013+B013*w3 + z111 = PAQPz1*QCPQz1*w1+B001*w1 + z112 = PAQPz2*QCPQz2*w2+B002*w2 + z113 = PAQPz3*QCPQz3*w3+B003*w3 + z211 = PAQPz1*z111+B101*z011+B001*z101 + z212 = PAQPz2*z112+B102*z012+B002*z102 + z213 = PAQPz3*z113+B103*z013+B003*z103 + z121 = QCPQz1*z111+B011*z101+B001*z011 + z122 = QCPQz2*z112+B012*z102+B002*z012 + z123 = QCPQz3*z113+B013*z103+B003*z013 + z221 = PAQPz1*z121+B101*z021+Two*B001*z111 + z222 = PAQPz2*z122+B102*z022+Two*B002*z112 + z223 = PAQPz3*z123+B103*z023+Two*B003*z113 + EFInt(iZeta,iEta,1) = (x111*w1)+(x112*w2)+(x113*w3) + EFInt(iZeta,iEta,2) = (x011*y101)*w1+(x012*y102)*w2+(x013*y103)*w3 + EFInt(iZeta,iEta,3) = x011*z101+x012*z102+x013*z103 + EFInt(iZeta,iEta,4) = (x211*w1)+(x212*w2)+(x213*w3) + EFInt(iZeta,iEta,5) = (x111*w1)*y101+(x112*w2)*y102+(x113*w3)*y103 + EFInt(iZeta,iEta,6) = x111*z101+x112*z102+x113*z103 + EFInt(iZeta,iEta,7) = x011*y201*w1+x012*y202*w2+x013*y203*w3 + EFInt(iZeta,iEta,8) = (x011*y101)*z101+(x012*y102)*z102+(x013*y103)*z103 + EFInt(iZeta,iEta,9) = x011*z201+x012*z202+x013*z203 + EFInt(iZeta,iEta,10) = (x101*y011)*w1+(x102*y012)*w2+(x103*y013)*w3 + EFInt(iZeta,iEta,11) = y111*w1+y112*w2+y113*w3 + EFInt(iZeta,iEta,12) = (y011*z101)+(y012*z102)+(y013*z103) + EFInt(iZeta,iEta,13) = (x201*y011)*w1+(x202*y012)*w2+(x203*y013)*w3 + EFInt(iZeta,iEta,14) = (x101*y111)*w1+(x102*y112)*w2+(x103*y113)*w3 + EFInt(iZeta,iEta,15) = (x101*y011)*z101+(x102*y012)*z102+(x103*y013)*z103 + EFInt(iZeta,iEta,16) = (y211*w1)+(y212*w2)+(y213*w3) + EFInt(iZeta,iEta,17) = y111*z101+y112*z102+y113*z103 + EFInt(iZeta,iEta,18) = y011*z201+y012*z202+y013*z203 + EFInt(iZeta,iEta,19) = x101*z011+x102*z012+x103*z013 + EFInt(iZeta,iEta,20) = (y101*z011)+(y102*z012)+(y103*z013) + EFInt(iZeta,iEta,21) = z111+z112+z113 + EFInt(iZeta,iEta,22) = x201*z011+x202*z012+x203*z013 + EFInt(iZeta,iEta,23) = x101*(y101*z011)+x102*(y102*z012)+x103*(y103*z013) + EFInt(iZeta,iEta,24) = x101*z111+x102*z112+x103*z113 + EFInt(iZeta,iEta,25) = y201*z011+y202*z012+y203*z013 + EFInt(iZeta,iEta,26) = y101*z111+y102*z112+y103*z113 + EFInt(iZeta,iEta,27) = z211+z212+z213 + EFInt(iZeta,iEta,28) = (x121*w1)+(x122*w2)+(x123*w3) + EFInt(iZeta,iEta,29) = (x021*y101)*w1+(x022*y102)*w2+(x023*y103)*w3 + EFInt(iZeta,iEta,30) = x021*z101+x022*z102+x023*z103 + EFInt(iZeta,iEta,31) = x221*w1+x222*w2+x223*w3 + EFInt(iZeta,iEta,32) = (x121*w1)*y101+(x122*w2)*y102+(x123*w3)*y103 + EFInt(iZeta,iEta,33) = x121*z101+x122*z102+x123*z103 + EFInt(iZeta,iEta,34) = x021*y201*w1+x022*y202*w2+x023*y203*w3 + EFInt(iZeta,iEta,35) = (x021*y101)*z101+(x022*y102)*z102+(x023*y103)*z103 + EFInt(iZeta,iEta,36) = x021*z201+x022*z202+x023*z203 + EFInt(iZeta,iEta,37) = (x111*w1)*y011+(x112*w2)*y012+(x113*w3)*y013 + EFInt(iZeta,iEta,38) = (x011*y111)*w1+(x012*y112)*w2+(x013*y113)*w3 + EFInt(iZeta,iEta,39) = (x011*y011)*z101+(x012*y012)*z102+(x013*y013)*z103 + EFInt(iZeta,iEta,40) = (x211*w1)*y011+(x212*w2)*y012+(x213*w3)*y013 + EFInt(iZeta,iEta,41) = x111*y111*w1+x112*y112*w2+x113*y113*w3 + EFInt(iZeta,iEta,42) = x111*(y011*z101)+x112*(y012*z102)+x113*(y013*z103) + EFInt(iZeta,iEta,43) = x011*(y211*w1)+x012*(y212*w2)+x013*(y213*w3) + EFInt(iZeta,iEta,44) = (x011*y111)*z101+(x012*y112)*z102+(x013*y113)*z103 + EFInt(iZeta,iEta,45) = (x011*y011)*z201+(x012*y012)*z202+(x013*y013)*z203 + EFInt(iZeta,iEta,46) = x111*z011+x112*z012+x113*z013 + EFInt(iZeta,iEta,47) = (x011*y101)*z011+(x012*y102)*z012+(x013*y103)*z013 + EFInt(iZeta,iEta,48) = x011*z111+x012*z112+x013*z113 + EFInt(iZeta,iEta,49) = x211*z011+x212*z012+x213*z013 + EFInt(iZeta,iEta,50) = x111*(y101*z011)+x112*(y102*z012)+x113*(y103*z013) + EFInt(iZeta,iEta,51) = x111*z111+x112*z112+x113*z113 + EFInt(iZeta,iEta,52) = (x011*y201)*z011+(x012*y202)*z012+(x013*y203)*z013 + EFInt(iZeta,iEta,53) = (x011*y101)*z111+(x012*y102)*z112+(x013*y103)*z113 + EFInt(iZeta,iEta,54) = x011*z211+x012*z212+x013*z213 + EFInt(iZeta,iEta,55) = x101*y021*w1+x102*y022*w2+x103*y023*w3 + EFInt(iZeta,iEta,56) = (y121*w1)+(y122*w2)+(y123*w3) + EFInt(iZeta,iEta,57) = (y021*z101)+(y022*z102)+(y023*z103) + EFInt(iZeta,iEta,58) = x201*y021*w1+x202*y022*w2+x203*y023*w3 + EFInt(iZeta,iEta,59) = x101*(y121*w1)+x102*(y122*w2)+x103*(y123*w3) + EFInt(iZeta,iEta,60) = x101*(y021*z101)+x102*(y022*z102)+x103*(y023*z103) + EFInt(iZeta,iEta,61) = y221*w1+y222*w2+y223*w3 + EFInt(iZeta,iEta,62) = y121*z101+y122*z102+y123*z103 + EFInt(iZeta,iEta,63) = y021*z201+y022*z202+y023*z203 + EFInt(iZeta,iEta,64) = (x101*y011)*z011+(x102*y012)*z012+(x103*y013)*z013 + EFInt(iZeta,iEta,65) = y111*z011+y112*z012+y113*z013 + EFInt(iZeta,iEta,66) = y011*z111+y012*z112+y013*z113 + EFInt(iZeta,iEta,67) = (x201*y011)*z011+(x202*y012)*z012+(x203*y013)*z013 + EFInt(iZeta,iEta,68) = (x101*y111)*z011+(x102*y112)*z012+(x103*y113)*z013 + EFInt(iZeta,iEta,69) = (x101*y011)*z111+(x102*y012)*z112+(x103*y013)*z113 + EFInt(iZeta,iEta,70) = y211*z011+y212*z012+y213*z013 + EFInt(iZeta,iEta,71) = y111*z111+y112*z112+y113*z113 + EFInt(iZeta,iEta,72) = y011*z211+y012*z212+y013*z213 + EFInt(iZeta,iEta,73) = x101*z021+x102*z022+x103*z023 + EFInt(iZeta,iEta,74) = (y101*z021)+(y102*z022)+(y103*z023) + EFInt(iZeta,iEta,75) = z121+z122+z123 + EFInt(iZeta,iEta,76) = x201*z021+x202*z022+x203*z023 + EFInt(iZeta,iEta,77) = x101*(y101*z021)+x102*(y102*z022)+x103*(y103*z023) + EFInt(iZeta,iEta,78) = x101*z121+x102*z122+x103*z123 + EFInt(iZeta,iEta,79) = y201*z021+y202*z022+y203*z023 + EFInt(iZeta,iEta,80) = y101*z121+y102*z122+y103*z123 + EFInt(iZeta,iEta,81) = z221+z222+z223 + end do + end do + +end if + +return + +end subroutine pppp diff -Nru openmolcas-22.02/src/rys_util/ppps.f openmolcas-22.10/src/rys_util/ppps.f --- openmolcas-22.02/src/rys_util/ppps.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ppps.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,497 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1994, Roland Lindh * -************************************************************************ - Subroutine ppps(EFInt,Zeta,ZInv,nZeta,P,lP,rKappAB,A,B, - & Eta,EInv, nEta,Q,lQ,rKappCD,C,D, - & CoorAC,TMax, - & iPntr,nPntr,x0,nMax,CW6,CW5,CW4,CW3,CW2,CW1,CW0, - & CR6,CR5,CR4,CR3,CR2,CR1,CR0, - & ddx,HerW,HerR2,IsChi,ChiI2) -************************************************************************ -* * -* Object: to compute the primitive integrals of type (pp|ps). * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. 1994 * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 EFInt(nZeta,nEta,27), Zeta(nZeta), Eta(nEta), - & CoorAC(3,2), ZInv(nZeta), EInv(nEta), - & P(lP,3), Q(lQ,3), A(3), B(3), C(3), D(3), - & rKappAB(nZeta), rKappCD(nEta), - & x0(nMax), - & CW6(nMax,2), CW5(nMax,2), CW4(nMax,2), CW3(nMax,2), - & CW2(nMax,2), CW1(nMax,2), CW0(nMax,2), - & CR6(nMax,2), CR5(nMax,2), CR4(nMax,2), CR3(nMax,2), - & CR2(nMax,2), CR1(nMax,2), CR0(nMax,2), - & HerW(2), HerR2(2) - Integer iPntr(nPntr) - Logical EQ -* -* - xdInv=One/ddx - dddx = ddx/10d0 + ddx -* - If ( EQ(A,B).and..Not.EQ(C,D)) Go To 200 - If (.Not.EQ(A,B).and. EQ(C,D)) Go To 300 - If ( EQ(A,B).and. EQ(C,D)) Go To 400 -* -*-----ABCD case -* - Do 10 iEta = 1, nEta - Do 20 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*DBLE(IsChi)) - rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) - PQx = P(iZeta,1)-Q(iEta,1) - PQy = P(iZeta,2)-Q(iEta,2) - PQz = P(iZeta,3)-Q(iEta,3) - T = rho * (PQx**2 + PQy**2 + PQz**2) - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - w1 = PreFct*w1 - w2 = PreFct*w2 - Eu21 = Eta(iEta)*(r1*ZEInv) - Eu22 = Eta(iEta)*(r2*ZEInv) - Zu21 = Zeta(iZeta)*(r1*ZEInv) - Zu22 = Zeta(iZeta)*(r2*ZEInv) - PAQPx1 = (P(iZeta,1) - CoorAC(1,1)) - Eu21 * PQx - PAQPx2 = (P(iZeta,1) - CoorAC(1,1)) - Eu22 * PQx - PAQPy1 = (P(iZeta,2) - CoorAC(2,1)) - Eu21 * PQy - PAQPy2 = (P(iZeta,2) - CoorAC(2,1)) - Eu22 * PQy - PAQPz1 = (P(iZeta,3) - CoorAC(3,1)) - Eu21 * PQz - PAQPz2 = (P(iZeta,3) - CoorAC(3,1)) - Eu22 * PQz - QCPQx1 = ( Q(iEta,1) - CoorAC(1,2)) + Zu21 * PQx - QCPQx2 = ( Q(iEta,1) - CoorAC(1,2)) + Zu22 * PQx - QCPQy1 = ( Q(iEta,2) - CoorAC(2,2)) + Zu21 * PQy - QCPQy2 = ( Q(iEta,2) - CoorAC(2,2)) + Zu22 * PQy - QCPQz1 = ( Q(iEta,3) - CoorAC(3,2)) + Zu21 * PQz - QCPQz2 = ( Q(iEta,3) - CoorAC(3,2)) + Zu22 * PQz - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - B101 = (Half - Half * Eu21) * ZInv(iZeta) - B102 = (Half - Half * Eu22) * ZInv(iZeta) - x101= PAQPx1 - x102= PAQPx2 - x011= QCPQx1 - x012= QCPQx2 - x201= PAQPx1*x101 + B101 - x202= PAQPx2*x102 + B102 - x111= PAQPx1*QCPQx1 + B001 - x112= PAQPx2*QCPQx2 + B002 - x211= PAQPx1*x111 + B101*x011 + B001*x101 - x212= PAQPx2*x112 + B102*x012 + B002*x102 - y101= PAQPy1 - y102= PAQPy2 - y011= QCPQy1 - y012= QCPQy2 - y201= PAQPy1*y101 + B101 - y202= PAQPy2*y102 + B102 - y111= PAQPy1*QCPQy1 + B001 - y112= PAQPy2*QCPQy2 + B002 - y211= PAQPy1*y111 + B101*y011 + B001*y101 - y212= PAQPy2*y112 + B102*y012 + B002*y102 - z101= PAQPz1*w1 - z102= PAQPz2*w2 - z011= QCPQz1*w1 - z012= QCPQz2*w2 - z201= PAQPz1*z101 + B101*w1 - z202= PAQPz2*z102 + B102*w2 - z111= PAQPz1*QCPQz1*w1 + B001*w1 - z112= PAQPz2*QCPQz2*w2 + B002*w2 - z211= PAQPz1*z111 + B101*z011 + B001*z101 - z212= PAQPz2*z112 + B102*z012 + B002*z102 - EFInt(iZeta,iEta, 1)= x111*w1+ x112*w2 - EFInt(iZeta,iEta, 2)= y101*x011*w1+ y102*x012*w2 - EFInt(iZeta,iEta, 3)= (z101*x011) +(z102*x012) - EFInt(iZeta,iEta, 4)= x211*w1+ x212*w2 - EFInt(iZeta,iEta, 5)= x111*y101*w1+ x112*y102*w2 - EFInt(iZeta,iEta, 6)= x111*z101 + x112*z102 - EFInt(iZeta,iEta, 7)= y201*x011*w1+ y202*x012*w2 - EFInt(iZeta,iEta, 8)=y101*(z101*x011)+ y102*(z102*x012) - EFInt(iZeta,iEta, 9)= z201*x011 + z202*x012 - EFInt(iZeta,iEta,10)= x101*y011*w1+ x102*y012*w2 - EFInt(iZeta,iEta,11)= y111*w1+ y112*w2 - EFInt(iZeta,iEta,12)= (z101*y011) +(z102*y012) - EFInt(iZeta,iEta,13)= x201*y011*w1+ x202*y012*w2 - EFInt(iZeta,iEta,14)= x101*y111*w1+ x102*y112*w2 - EFInt(iZeta,iEta,15)=x101*(z101*y011)+ x102*(z102*y012) - EFInt(iZeta,iEta,16)= y211*w1+ y212*w2 - EFInt(iZeta,iEta,17)= y111*z101 + y112*z102 - EFInt(iZeta,iEta,18)= z201*y011 + z202*y012 - EFInt(iZeta,iEta,19)= x101*z011 + x102*z012 - EFInt(iZeta,iEta,20)= (y101*z011) +(y102*z012) - EFInt(iZeta,iEta,21)= z111 + z112 - EFInt(iZeta,iEta,22)= x201*z011 + x202*z012 - EFInt(iZeta,iEta,23)=x101*(y101*z011)+ x102*(y102*z012) - EFInt(iZeta,iEta,24)= x101*z111 + x102*z112 - EFInt(iZeta,iEta,25)= y201*z011 + y202*z012 - EFInt(iZeta,iEta,26)= y101*z111 + y102*z112 - EFInt(iZeta,iEta,27)= z211 + z212 - 20 Continue - 10 Continue - Go To 99 -* -*-----AACD case -* - 200 Continue - Do 12 iEta = 1, nEta - Do 22 iZeta = 1, nZeta - PQx = CoorAC(1,1)-Q(iEta,1) - PQy = CoorAC(2,1)-Q(iEta,2) - PQz = CoorAC(3,1)-Q(iEta,3) - PQ2 = (PQx**2 + PQy**2 + PQz**2) - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*DBLE(IsChi)) - rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) - T = rho * PQ2 - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - w1 = PreFct*w1 - w2 = PreFct*w2 - Eu21 = Eta(iEta)*(r1*ZEInv) - Eu22 = Eta(iEta)*(r2*ZEInv) - Zu21 = Zeta(iZeta)*(r1*ZEInv) - Zu22 = Zeta(iZeta)*(r2*ZEInv) - PAQPx1 = - Eu21 * PQx - PAQPx2 = - Eu22 * PQx - PAQPy1 = - Eu21 * PQy - PAQPy2 = - Eu22 * PQy - PAQPz1 = - Eu21 * PQz - PAQPz2 = - Eu22 * PQz - QCPQx1 = ( Q(iEta,1) - CoorAC(1,2)) + Zu21 * PQx - QCPQx2 = ( Q(iEta,1) - CoorAC(1,2)) + Zu22 * PQx - QCPQy1 = ( Q(iEta,2) - CoorAC(2,2)) + Zu21 * PQy - QCPQy2 = ( Q(iEta,2) - CoorAC(2,2)) + Zu22 * PQy - QCPQz1 = ( Q(iEta,3) - CoorAC(3,2)) + Zu21 * PQz - QCPQz2 = ( Q(iEta,3) - CoorAC(3,2)) + Zu22 * PQz - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - B101 = (Half - Half * Eu21) * ZInv(iZeta) - B102 = (Half - Half * Eu22) * ZInv(iZeta) - x101= PAQPx1 - x102= PAQPx2 - x011= QCPQx1 - x012= QCPQx2 - x201= PAQPx1*x101 + B101 - x202= PAQPx2*x102 + B102 - x111= PAQPx1*QCPQx1 + B001 - x112= PAQPx2*QCPQx2 + B002 - x211= PAQPx1*x111 + B101*x011 + B001*x101 - x212= PAQPx2*x112 + B102*x012 + B002*x102 - y101= PAQPy1 - y102= PAQPy2 - y011= QCPQy1 - y012= QCPQy2 - y201= PAQPy1*y101 + B101 - y202= PAQPy2*y102 + B102 - y111= PAQPy1*QCPQy1 + B001 - y112= PAQPy2*QCPQy2 + B002 - y211= PAQPy1*y111 + B101*y011 + B001*y101 - y212= PAQPy2*y112 + B102*y012 + B002*y102 - z101= PAQPz1*w1 - z102= PAQPz2*w2 - z011= QCPQz1*w1 - z012= QCPQz2*w2 - z201= PAQPz1*z101 + B101*w1 - z202= PAQPz2*z102 + B102*w2 - z111= PAQPz1*QCPQz1*w1 + B001*w1 - z112= PAQPz2*QCPQz2*w2 + B002*w2 - z211= PAQPz1*z111 + B101*z011 + B001*z101 - z212= PAQPz2*z112 + B102*z012 + B002*z102 - EFInt(iZeta,iEta, 1)= x211*w1+ x212*w2 - EFInt(iZeta,iEta, 2)= x111*y101*w1+ x112*y102*w2 - EFInt(iZeta,iEta, 3)= x111*z101 + x112*z102 - EFInt(iZeta,iEta, 4)= y201*x011*w1+ y202*x012*w2 - EFInt(iZeta,iEta, 5)=y101*(z101*x011)+ y102*(z102*x012) - EFInt(iZeta,iEta, 6)= z201*x011 + z202*x012 - EFInt(iZeta,iEta, 7)= x201*y011*w1+ x202*y012*w2 - EFInt(iZeta,iEta, 8)= x101*y111*w1+ x102*y112*w2 - EFInt(iZeta,iEta, 9)=x101*(z101*y011)+ x102*(z102*y012) - EFInt(iZeta,iEta,10)= y211*w1+ y212*w2 - EFInt(iZeta,iEta,11)= y111*z101 + y112*z102 - EFInt(iZeta,iEta,12)= z201*y011 + z202*y012 - EFInt(iZeta,iEta,13)= x201*z011 + x202*z012 - EFInt(iZeta,iEta,14)=x101*(y101*z011)+ x102*(y102*z012) - EFInt(iZeta,iEta,15)= x101*z111 + x102*z112 - EFInt(iZeta,iEta,16)= y201*z011 + y202*z012 - EFInt(iZeta,iEta,17)= y101*z111 + y102*z112 - EFInt(iZeta,iEta,18)= z211 + z212 - 22 Continue - 12 Continue - Go To 99 -* -*-----ABCC case -* - 300 Continue - - Do 13 iEta = 1, nEta - Do 23 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*DBLE(IsChi)) - rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) - PQx = P(iZeta,1)-CoorAC(1,2) - PQy = P(iZeta,2)-CoorAC(2,2) - PQz = P(iZeta,3)-CoorAC(3,2) - T = rho * (PQx**2 + PQy**2 + PQz**2) - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - w1 = PreFct*w1 - w2 = PreFct*w2 - Eu21 = Eta(iEta)*(r1*ZEInv) - Eu22 = Eta(iEta)*(r2*ZEInv) - Zu21 = Zeta(iZeta)*(r1*ZEInv) - Zu22 = Zeta(iZeta)*(r2*ZEInv) - PAQPx1 = (P(iZeta,1) - CoorAC(1,1)) - Eu21 * PQx - PAQPx2 = (P(iZeta,1) - CoorAC(1,1)) - Eu22 * PQx - PAQPy1 = (P(iZeta,2) - CoorAC(2,1)) - Eu21 * PQy - PAQPy2 = (P(iZeta,2) - CoorAC(2,1)) - Eu22 * PQy - PAQPz1 = (P(iZeta,3) - CoorAC(3,1)) - Eu21 * PQz - PAQPz2 = (P(iZeta,3) - CoorAC(3,1)) - Eu22 * PQz - QCPQx1 = Zu21 * PQx - QCPQx2 = Zu22 * PQx - QCPQy1 = Zu21 * PQy - QCPQy2 = Zu22 * PQy - QCPQz1 = Zu21 * PQz - QCPQz2 = Zu22 * PQz - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - B101 = (Half - Half * Eu21) * ZInv(iZeta) - B102 = (Half - Half * Eu22) * ZInv(iZeta) - x101= PAQPx1 - x102= PAQPx2 - x011= QCPQx1 - x012= QCPQx2 - x201= PAQPx1*x101 + B101 - x202= PAQPx2*x102 + B102 - x111= PAQPx1*QCPQx1 + B001 - x112= PAQPx2*QCPQx2 + B002 - x211= PAQPx1*x111 + B101*x011 + B001*x101 - x212= PAQPx2*x112 + B102*x012 + B002*x102 - y101= PAQPy1 - y102= PAQPy2 - y011= QCPQy1 - y012= QCPQy2 - y201= PAQPy1*y101 + B101 - y202= PAQPy2*y102 + B102 - y111= PAQPy1*QCPQy1 + B001 - y112= PAQPy2*QCPQy2 + B002 - y211= PAQPy1*y111 + B101*y011 + B001*y101 - y212= PAQPy2*y112 + B102*y012 + B002*y102 - z101= PAQPz1*w1 - z102= PAQPz2*w2 - z011= QCPQz1*w1 - z012= QCPQz2*w2 - z201= PAQPz1*z101 + B101*w1 - z202= PAQPz2*z102 + B102*w2 - z111= PAQPz1*QCPQz1*w1 + B001*w1 - z112= PAQPz2*QCPQz2*w2 + B002*w2 - z211= PAQPz1*z111 + B101*z011 + B001*z101 - z212= PAQPz2*z112 + B102*z012 + B002*z102 - EFInt(iZeta,iEta, 1)= x111*w1+ x112*w2 - EFInt(iZeta,iEta, 2)= y101*x011*w1+ y102*x012*w2 - EFInt(iZeta,iEta, 3)= (z101*x011) +(z102*x012) - EFInt(iZeta,iEta, 4)= x211*w1+ x212*w2 - EFInt(iZeta,iEta, 5)= x111*y101*w1+ x112*y102*w2 - EFInt(iZeta,iEta, 6)= x111*z101 + x112*z102 - EFInt(iZeta,iEta, 7)= y201*x011*w1+ y202*x012*w2 - EFInt(iZeta,iEta, 8)=y101*(z101*x011)+ y102*(z102*x012) - EFInt(iZeta,iEta, 9)= z201*x011 + z202*x012 - EFInt(iZeta,iEta,10)= x101*y011*w1+ x102*y012*w2 - EFInt(iZeta,iEta,11)= y111*w1+ y112*w2 - EFInt(iZeta,iEta,12)= (z101*y011) +(z102*y012) - EFInt(iZeta,iEta,13)= x201*y011*w1+ x202*y012*w2 - EFInt(iZeta,iEta,14)= x101*y111*w1+ x102*y112*w2 - EFInt(iZeta,iEta,15)=x101*(z101*y011)+ x102*(z102*y012) - EFInt(iZeta,iEta,16)= y211*w1+ y212*w2 - EFInt(iZeta,iEta,17)= y111*z101 + y112*z102 - EFInt(iZeta,iEta,18)= z201*y011 + z202*y012 - EFInt(iZeta,iEta,19)= x101*z011 + x102*z012 - EFInt(iZeta,iEta,20)= (y101*z011) +(y102*z012) - EFInt(iZeta,iEta,21)= z111 + z112 - EFInt(iZeta,iEta,22)= x201*z011 + x202*z012 - EFInt(iZeta,iEta,23)=x101*(y101*z011)+ x102*(y102*z012) - EFInt(iZeta,iEta,24)= x101*z111 + x102*z112 - EFInt(iZeta,iEta,25)= y201*z011 + y202*z012 - EFInt(iZeta,iEta,26)= y101*z111 + y102*z112 - EFInt(iZeta,iEta,27)= z211 + z212 - 23 Continue - 13 Continue - Go To 99 -* -*-----AACC case -* - 400 Continue - PQx = CoorAC(1,1)-CoorAC(1,2) - PQy = CoorAC(2,1)-CoorAC(2,2) - PQz = CoorAC(3,1)-CoorAC(3,2) - PQ2 = (PQx**2 + PQy**2 + PQz**2) - Do 14 iEta = 1, nEta - Do 24 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*DBLE(IsChi)) - rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) - T = rho * PQ2 - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - w1 = PreFct*w1 - w2 = PreFct*w2 - Eu21 = Eta(iEta)*(r1*ZEInv) - Eu22 = Eta(iEta)*(r2*ZEInv) - Zu21 = Zeta(iZeta)*(r1*ZEInv) - Zu22 = Zeta(iZeta)*(r2*ZEInv) - PAQPx1 = - Eu21 * PQx - PAQPx2 = - Eu22 * PQx - PAQPy1 = - Eu21 * PQy - PAQPy2 = - Eu22 * PQy - PAQPz1 = - Eu21 * PQz - PAQPz2 = - Eu22 * PQz - QCPQx1 = Zu21 * PQx - QCPQx2 = Zu22 * PQx - QCPQy1 = Zu21 * PQy - QCPQy2 = Zu22 * PQy - QCPQz1 = Zu21 * PQz - QCPQz2 = Zu22 * PQz - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - B101 = (Half - Half * Eu21) * ZInv(iZeta) - B102 = (Half - Half * Eu22) * ZInv(iZeta) - x101= PAQPx1 - x102= PAQPx2 - x011= QCPQx1 - x012= QCPQx2 - x201= PAQPx1*x101 + B101 - x202= PAQPx2*x102 + B102 - x111= PAQPx1*QCPQx1 + B001 - x112= PAQPx2*QCPQx2 + B002 - x211= PAQPx1*x111 + B101*x011 + B001*x101 - x212= PAQPx2*x112 + B102*x012 + B002*x102 - y101= PAQPy1 - y102= PAQPy2 - y011= QCPQy1 - y012= QCPQy2 - y201= PAQPy1*y101 + B101 - y202= PAQPy2*y102 + B102 - y111= PAQPy1*QCPQy1 + B001 - y112= PAQPy2*QCPQy2 + B002 - y211= PAQPy1*y111 + B101*y011 + B001*y101 - y212= PAQPy2*y112 + B102*y012 + B002*y102 - z101= PAQPz1*w1 - z102= PAQPz2*w2 - z011= QCPQz1*w1 - z012= QCPQz2*w2 - z201= PAQPz1*z101 + B101*w1 - z202= PAQPz2*z102 + B102*w2 - z111= PAQPz1*QCPQz1*w1 + B001*w1 - z112= PAQPz2*QCPQz2*w2 + B002*w2 - z211= PAQPz1*z111 + B101*z011 + B001*z101 - z212= PAQPz2*z112 + B102*z012 + B002*z102 - EFInt(iZeta,iEta, 1)= x211*w1+ x212*w2 - EFInt(iZeta,iEta, 2)= x111*y101*w1+ x112*y102*w2 - EFInt(iZeta,iEta, 3)= x111*z101 + x112*z102 - EFInt(iZeta,iEta, 4)= y201*x011*w1+ y202*x012*w2 - EFInt(iZeta,iEta, 5)=y101*(z101*x011)+ y102*(z102*x012) - EFInt(iZeta,iEta, 6)= z201*x011 + z202*x012 - EFInt(iZeta,iEta, 7)= x201*y011*w1+ x202*y012*w2 - EFInt(iZeta,iEta, 8)= x101*y111*w1+ x102*y112*w2 - EFInt(iZeta,iEta, 9)=x101*(z101*y011)+ x102*(z102*y012) - EFInt(iZeta,iEta,10)= y211*w1+ y212*w2 - EFInt(iZeta,iEta,11)= y111*z101 + y112*z102 - EFInt(iZeta,iEta,12)= z201*y011 + z202*y012 - EFInt(iZeta,iEta,13)= x201*z011 + x202*z012 - EFInt(iZeta,iEta,14)=x101*(y101*z011)+ x102*(y102*z012) - EFInt(iZeta,iEta,15)= x101*z111 + x102*z112 - EFInt(iZeta,iEta,16)= y201*z011 + y202*z012 - EFInt(iZeta,iEta,17)= y101*z111 + y102*z112 - EFInt(iZeta,iEta,18)= z211 + z212 - 24 Continue - 14 Continue -* - 99 Continue -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_real_array(EInv) - End diff -Nru openmolcas-22.02/src/rys_util/ppps.F90 openmolcas-22.10/src/rys_util/ppps.F90 --- openmolcas-22.02/src/rys_util/ppps.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ppps.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,475 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1994, Roland Lindh * +!*********************************************************************** + +subroutine ppps(EFInt,Zeta,ZInv,nZeta,P,lP,rKappAB,A,B,Eta,EInv,nEta,Q,lQ,rKappCD,C,D,CoorAC,TMax,iPntr,nPntr,x0,nMax,CW6,CW5,CW4, & + CW3,CW2,CW1,CW0,CR6,CR5,CR4,CR3,CR2,CR1,CR0,ddx,HerW,HerR2,IsChi,ChiI2) +!*********************************************************************** +! * +! Object: to compute the primitive integrals of type (pp|ps). * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. 1994 * +!*********************************************************************** + +use Constants, only: One, Ten, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, lP, nEta, lQ, nPntr, iPntr(nPntr), nMax, IsChi +real(kind=wp), intent(out) :: EFInt(nZeta,nEta,27) +real(kind=wp), intent(in) :: Zeta(nZeta), ZInv(nZeta), P(lP,3), rKappAB(nZeta), A(3), B(3), Eta(nEta), EInv(nEta), Q(lQ,3), & + rKappCD(nEta), C(3), D(3), CoorAC(3,2), TMax, x0(nMax), CW6(nMax,2), CW5(nMax,2), CW4(nMax,2), & + CW3(nMax,2), CW2(nMax,2), CW1(nMax,2), CW0(nMax,2), CR6(nMax,2), CR5(nMax,2), CR4(nMax,2), & + CR3(nMax,2), CR2(nMax,2), CR1(nMax,2), CR0(nMax,2), ddx, HerW(2), HerR2(2), ChiI2 +integer(kind=iwp) :: iEta, iZeta, n +real(kind=wp) :: ai, B001, B002, B101, B102, dddx, Eu21, Eu22, PAQPx1, PAQPx2, PAQPy1, PAQPy2, PAQPz1, PAQPz2, PQ2, PQx, PQy, PQz, & + PreFct, QCPQx1, QCPQx2, QCPQy1, QCPQy2, QCPQz1, QCPQz2, r1, r2, rho, si, T, w1, w2, x011, x012, x101, x102, x111, & + x112, x201, x202, x211, x212, xdInv, y011, y012, y101, y102, y111, y112, y201, y202, y211, y212, z, z011, z012, & + z101, z102, z111, z112, z201, z202, z211, z212, ZEInv, Zu21, Zu22 +logical(kind=iwp) :: EQ + +#include "macros.fh" +unused_var(EInv) + +xdInv = One/ddx +dddx = ddx/Ten+ddx + +if (EQ(A,B) .and. (.not. EQ(C,D))) then + + ! AACD case + + do iEta=1,nEta + do iZeta=1,nZeta + PQx = CoorAC(1,1)-Q(iEta,1) + PQy = CoorAC(2,1)-Q(iEta,2) + PQz = CoorAC(3,1)-Q(iEta,3) + PQ2 = (PQx**2+PQy**2+PQz**2) + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) + T = rho*PQ2 + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + w1 = PreFct*w1 + w2 = PreFct*w2 + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + PAQPx1 = -Eu21*PQx + PAQPx2 = -Eu22*PQx + PAQPy1 = -Eu21*PQy + PAQPy2 = -Eu22*PQy + PAQPz1 = -Eu21*PQz + PAQPz2 = -Eu22*PQz + QCPQx1 = (Q(iEta,1)-CoorAC(1,2))+Zu21*PQx + QCPQx2 = (Q(iEta,1)-CoorAC(1,2))+Zu22*PQx + QCPQy1 = (Q(iEta,2)-CoorAC(2,2))+Zu21*PQy + QCPQy2 = (Q(iEta,2)-CoorAC(2,2))+Zu22*PQy + QCPQz1 = (Q(iEta,3)-CoorAC(3,2))+Zu21*PQz + QCPQz2 = (Q(iEta,3)-CoorAC(3,2))+Zu22*PQz + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + B101 = (Half-Half*Eu21)*ZInv(iZeta) + B102 = (Half-Half*Eu22)*ZInv(iZeta) + x101 = PAQPx1 + x102 = PAQPx2 + x011 = QCPQx1 + x012 = QCPQx2 + x201 = PAQPx1*x101+B101 + x202 = PAQPx2*x102+B102 + x111 = PAQPx1*QCPQx1+B001 + x112 = PAQPx2*QCPQx2+B002 + x211 = PAQPx1*x111+B101*x011+B001*x101 + x212 = PAQPx2*x112+B102*x012+B002*x102 + y101 = PAQPy1 + y102 = PAQPy2 + y011 = QCPQy1 + y012 = QCPQy2 + y201 = PAQPy1*y101+B101 + y202 = PAQPy2*y102+B102 + y111 = PAQPy1*QCPQy1+B001 + y112 = PAQPy2*QCPQy2+B002 + y211 = PAQPy1*y111+B101*y011+B001*y101 + y212 = PAQPy2*y112+B102*y012+B002*y102 + z101 = PAQPz1*w1 + z102 = PAQPz2*w2 + z011 = QCPQz1*w1 + z012 = QCPQz2*w2 + z201 = PAQPz1*z101+B101*w1 + z202 = PAQPz2*z102+B102*w2 + z111 = PAQPz1*QCPQz1*w1+B001*w1 + z112 = PAQPz2*QCPQz2*w2+B002*w2 + z211 = PAQPz1*z111+B101*z011+B001*z101 + z212 = PAQPz2*z112+B102*z012+B002*z102 + EFInt(iZeta,iEta,1) = x211*w1+x212*w2 + EFInt(iZeta,iEta,2) = x111*y101*w1+x112*y102*w2 + EFInt(iZeta,iEta,3) = x111*z101+x112*z102 + EFInt(iZeta,iEta,4) = y201*x011*w1+y202*x012*w2 + EFInt(iZeta,iEta,5) = y101*(z101*x011)+y102*(z102*x012) + EFInt(iZeta,iEta,6) = z201*x011+z202*x012 + EFInt(iZeta,iEta,7) = x201*y011*w1+x202*y012*w2 + EFInt(iZeta,iEta,8) = x101*y111*w1+x102*y112*w2 + EFInt(iZeta,iEta,9) = x101*(z101*y011)+x102*(z102*y012) + EFInt(iZeta,iEta,10) = y211*w1+y212*w2 + EFInt(iZeta,iEta,11) = y111*z101+y112*z102 + EFInt(iZeta,iEta,12) = z201*y011+z202*y012 + EFInt(iZeta,iEta,13) = x201*z011+x202*z012 + EFInt(iZeta,iEta,14) = x101*(y101*z011)+x102*(y102*z012) + EFInt(iZeta,iEta,15) = x101*z111+x102*z112 + EFInt(iZeta,iEta,16) = y201*z011+y202*z012 + EFInt(iZeta,iEta,17) = y101*z111+y102*z112 + EFInt(iZeta,iEta,18) = z211+z212 + end do + end do + +else if ((.not. EQ(A,B)) .and. EQ(C,D)) then + + ! ABCC case + + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) + PQx = P(iZeta,1)-CoorAC(1,2) + PQy = P(iZeta,2)-CoorAC(2,2) + PQz = P(iZeta,3)-CoorAC(3,2) + T = rho*(PQx**2+PQy**2+PQz**2) + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + w1 = PreFct*w1 + w2 = PreFct*w2 + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + PAQPx1 = (P(iZeta,1)-CoorAC(1,1))-Eu21*PQx + PAQPx2 = (P(iZeta,1)-CoorAC(1,1))-Eu22*PQx + PAQPy1 = (P(iZeta,2)-CoorAC(2,1))-Eu21*PQy + PAQPy2 = (P(iZeta,2)-CoorAC(2,1))-Eu22*PQy + PAQPz1 = (P(iZeta,3)-CoorAC(3,1))-Eu21*PQz + PAQPz2 = (P(iZeta,3)-CoorAC(3,1))-Eu22*PQz + QCPQx1 = Zu21*PQx + QCPQx2 = Zu22*PQx + QCPQy1 = Zu21*PQy + QCPQy2 = Zu22*PQy + QCPQz1 = Zu21*PQz + QCPQz2 = Zu22*PQz + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + B101 = (Half-Half*Eu21)*ZInv(iZeta) + B102 = (Half-Half*Eu22)*ZInv(iZeta) + x101 = PAQPx1 + x102 = PAQPx2 + x011 = QCPQx1 + x012 = QCPQx2 + x201 = PAQPx1*x101+B101 + x202 = PAQPx2*x102+B102 + x111 = PAQPx1*QCPQx1+B001 + x112 = PAQPx2*QCPQx2+B002 + x211 = PAQPx1*x111+B101*x011+B001*x101 + x212 = PAQPx2*x112+B102*x012+B002*x102 + y101 = PAQPy1 + y102 = PAQPy2 + y011 = QCPQy1 + y012 = QCPQy2 + y201 = PAQPy1*y101+B101 + y202 = PAQPy2*y102+B102 + y111 = PAQPy1*QCPQy1+B001 + y112 = PAQPy2*QCPQy2+B002 + y211 = PAQPy1*y111+B101*y011+B001*y101 + y212 = PAQPy2*y112+B102*y012+B002*y102 + z101 = PAQPz1*w1 + z102 = PAQPz2*w2 + z011 = QCPQz1*w1 + z012 = QCPQz2*w2 + z201 = PAQPz1*z101+B101*w1 + z202 = PAQPz2*z102+B102*w2 + z111 = PAQPz1*QCPQz1*w1+B001*w1 + z112 = PAQPz2*QCPQz2*w2+B002*w2 + z211 = PAQPz1*z111+B101*z011+B001*z101 + z212 = PAQPz2*z112+B102*z012+B002*z102 + EFInt(iZeta,iEta,1) = x111*w1+x112*w2 + EFInt(iZeta,iEta,2) = y101*x011*w1+y102*x012*w2 + EFInt(iZeta,iEta,3) = (z101*x011)+(z102*x012) + EFInt(iZeta,iEta,4) = x211*w1+x212*w2 + EFInt(iZeta,iEta,5) = x111*y101*w1+x112*y102*w2 + EFInt(iZeta,iEta,6) = x111*z101+x112*z102 + EFInt(iZeta,iEta,7) = y201*x011*w1+y202*x012*w2 + EFInt(iZeta,iEta,8) = y101*(z101*x011)+y102*(z102*x012) + EFInt(iZeta,iEta,9) = z201*x011+z202*x012 + EFInt(iZeta,iEta,10) = x101*y011*w1+x102*y012*w2 + EFInt(iZeta,iEta,11) = y111*w1+y112*w2 + EFInt(iZeta,iEta,12) = (z101*y011)+(z102*y012) + EFInt(iZeta,iEta,13) = x201*y011*w1+x202*y012*w2 + EFInt(iZeta,iEta,14) = x101*y111*w1+x102*y112*w2 + EFInt(iZeta,iEta,15) = x101*(z101*y011)+x102*(z102*y012) + EFInt(iZeta,iEta,16) = y211*w1+y212*w2 + EFInt(iZeta,iEta,17) = y111*z101+y112*z102 + EFInt(iZeta,iEta,18) = z201*y011+z202*y012 + EFInt(iZeta,iEta,19) = x101*z011+x102*z012 + EFInt(iZeta,iEta,20) = (y101*z011)+(y102*z012) + EFInt(iZeta,iEta,21) = z111+z112 + EFInt(iZeta,iEta,22) = x201*z011+x202*z012 + EFInt(iZeta,iEta,23) = x101*(y101*z011)+x102*(y102*z012) + EFInt(iZeta,iEta,24) = x101*z111+x102*z112 + EFInt(iZeta,iEta,25) = y201*z011+y202*z012 + EFInt(iZeta,iEta,26) = y101*z111+y102*z112 + EFInt(iZeta,iEta,27) = z211+z212 + end do + end do + +else if (EQ(A,B) .and. EQ(C,D)) then + + ! AACC case + + PQx = CoorAC(1,1)-CoorAC(1,2) + PQy = CoorAC(2,1)-CoorAC(2,2) + PQz = CoorAC(3,1)-CoorAC(3,2) + PQ2 = (PQx**2+PQy**2+PQz**2) + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) + T = rho*PQ2 + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + w1 = PreFct*w1 + w2 = PreFct*w2 + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + PAQPx1 = -Eu21*PQx + PAQPx2 = -Eu22*PQx + PAQPy1 = -Eu21*PQy + PAQPy2 = -Eu22*PQy + PAQPz1 = -Eu21*PQz + PAQPz2 = -Eu22*PQz + QCPQx1 = Zu21*PQx + QCPQx2 = Zu22*PQx + QCPQy1 = Zu21*PQy + QCPQy2 = Zu22*PQy + QCPQz1 = Zu21*PQz + QCPQz2 = Zu22*PQz + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + B101 = (Half-Half*Eu21)*ZInv(iZeta) + B102 = (Half-Half*Eu22)*ZInv(iZeta) + x101 = PAQPx1 + x102 = PAQPx2 + x011 = QCPQx1 + x012 = QCPQx2 + x201 = PAQPx1*x101+B101 + x202 = PAQPx2*x102+B102 + x111 = PAQPx1*QCPQx1+B001 + x112 = PAQPx2*QCPQx2+B002 + x211 = PAQPx1*x111+B101*x011+B001*x101 + x212 = PAQPx2*x112+B102*x012+B002*x102 + y101 = PAQPy1 + y102 = PAQPy2 + y011 = QCPQy1 + y012 = QCPQy2 + y201 = PAQPy1*y101+B101 + y202 = PAQPy2*y102+B102 + y111 = PAQPy1*QCPQy1+B001 + y112 = PAQPy2*QCPQy2+B002 + y211 = PAQPy1*y111+B101*y011+B001*y101 + y212 = PAQPy2*y112+B102*y012+B002*y102 + z101 = PAQPz1*w1 + z102 = PAQPz2*w2 + z011 = QCPQz1*w1 + z012 = QCPQz2*w2 + z201 = PAQPz1*z101+B101*w1 + z202 = PAQPz2*z102+B102*w2 + z111 = PAQPz1*QCPQz1*w1+B001*w1 + z112 = PAQPz2*QCPQz2*w2+B002*w2 + z211 = PAQPz1*z111+B101*z011+B001*z101 + z212 = PAQPz2*z112+B102*z012+B002*z102 + EFInt(iZeta,iEta,1) = x211*w1+x212*w2 + EFInt(iZeta,iEta,2) = x111*y101*w1+x112*y102*w2 + EFInt(iZeta,iEta,3) = x111*z101+x112*z102 + EFInt(iZeta,iEta,4) = y201*x011*w1+y202*x012*w2 + EFInt(iZeta,iEta,5) = y101*(z101*x011)+y102*(z102*x012) + EFInt(iZeta,iEta,6) = z201*x011+z202*x012 + EFInt(iZeta,iEta,7) = x201*y011*w1+x202*y012*w2 + EFInt(iZeta,iEta,8) = x101*y111*w1+x102*y112*w2 + EFInt(iZeta,iEta,9) = x101*(z101*y011)+x102*(z102*y012) + EFInt(iZeta,iEta,10) = y211*w1+y212*w2 + EFInt(iZeta,iEta,11) = y111*z101+y112*z102 + EFInt(iZeta,iEta,12) = z201*y011+z202*y012 + EFInt(iZeta,iEta,13) = x201*z011+x202*z012 + EFInt(iZeta,iEta,14) = x101*(y101*z011)+x102*(y102*z012) + EFInt(iZeta,iEta,15) = x101*z111+x102*z112 + EFInt(iZeta,iEta,16) = y201*z011+y202*z012 + EFInt(iZeta,iEta,17) = y101*z111+y102*z112 + EFInt(iZeta,iEta,18) = z211+z212 + end do + end do + +else + + ! ABCD case + + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) + PQx = P(iZeta,1)-Q(iEta,1) + PQy = P(iZeta,2)-Q(iEta,2) + PQz = P(iZeta,3)-Q(iEta,3) + T = rho*(PQx**2+PQy**2+PQz**2) + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + w1 = PreFct*w1 + w2 = PreFct*w2 + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + PAQPx1 = (P(iZeta,1)-CoorAC(1,1))-Eu21*PQx + PAQPx2 = (P(iZeta,1)-CoorAC(1,1))-Eu22*PQx + PAQPy1 = (P(iZeta,2)-CoorAC(2,1))-Eu21*PQy + PAQPy2 = (P(iZeta,2)-CoorAC(2,1))-Eu22*PQy + PAQPz1 = (P(iZeta,3)-CoorAC(3,1))-Eu21*PQz + PAQPz2 = (P(iZeta,3)-CoorAC(3,1))-Eu22*PQz + QCPQx1 = (Q(iEta,1)-CoorAC(1,2))+Zu21*PQx + QCPQx2 = (Q(iEta,1)-CoorAC(1,2))+Zu22*PQx + QCPQy1 = (Q(iEta,2)-CoorAC(2,2))+Zu21*PQy + QCPQy2 = (Q(iEta,2)-CoorAC(2,2))+Zu22*PQy + QCPQz1 = (Q(iEta,3)-CoorAC(3,2))+Zu21*PQz + QCPQz2 = (Q(iEta,3)-CoorAC(3,2))+Zu22*PQz + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + B101 = (Half-Half*Eu21)*ZInv(iZeta) + B102 = (Half-Half*Eu22)*ZInv(iZeta) + x101 = PAQPx1 + x102 = PAQPx2 + x011 = QCPQx1 + x012 = QCPQx2 + x201 = PAQPx1*x101+B101 + x202 = PAQPx2*x102+B102 + x111 = PAQPx1*QCPQx1+B001 + x112 = PAQPx2*QCPQx2+B002 + x211 = PAQPx1*x111+B101*x011+B001*x101 + x212 = PAQPx2*x112+B102*x012+B002*x102 + y101 = PAQPy1 + y102 = PAQPy2 + y011 = QCPQy1 + y012 = QCPQy2 + y201 = PAQPy1*y101+B101 + y202 = PAQPy2*y102+B102 + y111 = PAQPy1*QCPQy1+B001 + y112 = PAQPy2*QCPQy2+B002 + y211 = PAQPy1*y111+B101*y011+B001*y101 + y212 = PAQPy2*y112+B102*y012+B002*y102 + z101 = PAQPz1*w1 + z102 = PAQPz2*w2 + z011 = QCPQz1*w1 + z012 = QCPQz2*w2 + z201 = PAQPz1*z101+B101*w1 + z202 = PAQPz2*z102+B102*w2 + z111 = PAQPz1*QCPQz1*w1+B001*w1 + z112 = PAQPz2*QCPQz2*w2+B002*w2 + z211 = PAQPz1*z111+B101*z011+B001*z101 + z212 = PAQPz2*z112+B102*z012+B002*z102 + EFInt(iZeta,iEta,1) = x111*w1+x112*w2 + EFInt(iZeta,iEta,2) = y101*x011*w1+y102*x012*w2 + EFInt(iZeta,iEta,3) = (z101*x011)+(z102*x012) + EFInt(iZeta,iEta,4) = x211*w1+x212*w2 + EFInt(iZeta,iEta,5) = x111*y101*w1+x112*y102*w2 + EFInt(iZeta,iEta,6) = x111*z101+x112*z102 + EFInt(iZeta,iEta,7) = y201*x011*w1+y202*x012*w2 + EFInt(iZeta,iEta,8) = y101*(z101*x011)+y102*(z102*x012) + EFInt(iZeta,iEta,9) = z201*x011+z202*x012 + EFInt(iZeta,iEta,10) = x101*y011*w1+x102*y012*w2 + EFInt(iZeta,iEta,11) = y111*w1+y112*w2 + EFInt(iZeta,iEta,12) = (z101*y011)+(z102*y012) + EFInt(iZeta,iEta,13) = x201*y011*w1+x202*y012*w2 + EFInt(iZeta,iEta,14) = x101*y111*w1+x102*y112*w2 + EFInt(iZeta,iEta,15) = x101*(z101*y011)+x102*(z102*y012) + EFInt(iZeta,iEta,16) = y211*w1+y212*w2 + EFInt(iZeta,iEta,17) = y111*z101+y112*z102 + EFInt(iZeta,iEta,18) = z201*y011+z202*y012 + EFInt(iZeta,iEta,19) = x101*z011+x102*z012 + EFInt(iZeta,iEta,20) = (y101*z011)+(y102*z012) + EFInt(iZeta,iEta,21) = z111+z112 + EFInt(iZeta,iEta,22) = x201*z011+x202*z012 + EFInt(iZeta,iEta,23) = x101*(y101*z011)+x102*(y102*z012) + EFInt(iZeta,iEta,24) = x101*z111+x102*z112 + EFInt(iZeta,iEta,25) = y201*z011+y202*z012 + EFInt(iZeta,iEta,26) = y101*z111+y102*z112 + EFInt(iZeta,iEta,27) = z211+z212 + end do + end do + +end if + +return + +end subroutine ppps diff -Nru openmolcas-22.02/src/rys_util/ppss.f openmolcas-22.10/src/rys_util/ppss.f --- openmolcas-22.02/src/rys_util/ppss.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ppss.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,349 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1994, Roland Lindh * -************************************************************************ - Subroutine ppss(EFInt,Zeta,ZInv,nZeta,P,lP,rKappAB,A,B, - & Eta,EInv, nEta,Q,lQ,rKappCD,C,D, - & CoorAC,TMax, - & iPntr,nPntr,x0,nMax,CW6,CW5,CW4,CW3,CW2,CW1,CW0, - & CR6,CR5,CR4,CR3,CR2,CR1,CR0, - & ddx,HerW,HerR2,IsChi,ChiI2) -************************************************************************ -* * -* Object: to compute the primitive integrals of type (pp|ss). * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. 1994 * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 EFInt(nZeta,nEta,9), Zeta(nZeta), Eta(nEta), - & CoorAC(3,2), ZInv(nZeta), EInv(nEta), - & P(lP,3), Q(lQ,3), A(3), B(3), C(3), D(3), - & rKappAB(nZeta), rKappCD(nEta), - & x0(nMax), - & CW6(nMax,2), CW5(nMax,2), CW4(nMax,2), CW3(nMax,2), - & CW2(nMax,2), CW1(nMax,2), CW0(nMax,2), - & CR6(nMax,2), CR5(nMax,2), CR4(nMax,2), CR3(nMax,2), - & CR2(nMax,2), CR1(nMax,2), CR0(nMax,2), - & HerW(2), HerR2(2) - Integer iPntr(nPntr) - Logical ABeqCD, EQ -* -* - xdInv=One/ddx - dddx = ddx/10d0 + ddx -* - ABeqCD = EQ(A,B) .and. EQ(A,C) .and. EQ(A,D) - If ( ABeqCD ) Go To 100 - If ( EQ(A,B).and..Not.EQ(C,D)) Go To 200 - If (.Not.EQ(A,B).and. EQ(C,D)) Go To 300 - If ( EQ(A,B).and. EQ(C,D)) Go To 400 -* -*-----ABCD case -* - Do 10 iEta = 1, nEta - Do 20 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) - PQx = P(iZeta,1)-Q(iEta,1) - PQy = P(iZeta,2)-Q(iEta,2) - PQz = P(iZeta,3)-Q(iEta,3) - T = rho * (PQx**2 + PQy**2 + PQz**2) - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - Eu21 = r1*(Eta(iEta)*ZEInv) - Eu22 = r2*(Eta(iEta)*ZEInv) - PAQPx1 = (P(iZeta,1) - CoorAC(1,1)) - Eu21 * PQx - PAQPx2 = (P(iZeta,1) - CoorAC(1,1)) - Eu22 * PQx - PAQPy1 = (P(iZeta,2) - CoorAC(2,1)) - Eu21 * PQy - PAQPy2 = (P(iZeta,2) - CoorAC(2,1)) - Eu22 * PQy - PAQPz1 = (P(iZeta,3) - CoorAC(3,1)) - Eu21 * PQz - PAQPz2 = (P(iZeta,3) - CoorAC(3,1)) - Eu22 * PQz - B101 = (Half - Half * Eu21) * ZInv(iZeta) - B102 = (Half - Half * Eu22) * ZInv(iZeta) - x101= PAQPx1 - x102= PAQPx2 - x201= PAQPx1*x101 + B101 - x202= PAQPx2*x102 + B102 - y101= PAQPy1 - y102= PAQPy2 - y201= PAQPy1*y101 + B101 - y202= PAQPy2*y102 + B102 - z101= PAQPz1*w1 - z102= PAQPz2*w2 - z201= PAQPz1*z101 + B101*w1 - z202= PAQPz2*z102 + B102*w2 - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - EFInt(iZeta,iEta,1) = PreFct * ( x101*w1+ x102*w2) - EFInt(iZeta,iEta,2) = PreFct * ( y101*w1+ y102*w2) - EFInt(iZeta,iEta,3) = PreFct * ( z101 + z102 ) - EFInt(iZeta,iEta,4) = PreFct * ( x201*w1+ x202*w2) - EFInt(iZeta,iEta,5) = PreFct * (x101*y101*w1+x102*y102*w2) - EFInt(iZeta,iEta,6) = PreFct * (x101*z101 +x102*z102 ) - EFInt(iZeta,iEta,7) = PreFct * ( y201*w1+ y202*w2) - EFInt(iZeta,iEta,8) = PreFct * (y101*z101 +y102*z102 ) - EFInt(iZeta,iEta,9) = PreFct * ( z201 + z202 ) - 20 Continue - 10 Continue - Go To 99 -* -*-----AAAA case -* - 100 Continue - z = - x0(1) - w1=(((((CW6(1,1)*z+CW5(1,1))*z+CW4(1,1))*z+CW3(1,1))*z+ - & CW2(1,1))*z+CW1(1,1))*z+Cw0(1,1) - w2=(((((CW6(1,2)*z+CW5(1,2))*z+CW4(1,2))*z+CW3(1,2))*z+ - & CW2(1,2))*z+CW1(1,2))*z+Cw0(1,2) - r1=(((((CR6(1,1)*z+CR5(1,1))*z+CR4(1,1))*z+CR3(1,1))*z+ - & CR2(1,1))*z+CR1(1,1))*z+CR0(1,1) - r2=(((((CR6(1,2)*z+CR5(1,2))*z+CR4(1,2))*z+CR3(1,2))*z+ - & CR2(1,2))*z+CR1(1,2))*z+CR0(1,2) - Do 11 iEta = 1, nEta - Do 21 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - Eu21 = r1*(Eta(iEta)*ZEInv) - Eu22 = r2*(Eta(iEta)*ZEInv) - B101 = (Half - Half * Eu21) * ZInv(iZeta) - B102 = (Half - Half * Eu22) * ZInv(iZeta) - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - EFInt(iZeta,iEta,1) = (PreFct * (B101*w1+B102*w2)) - EFInt(iZeta,iEta,2) = Zero - EFInt(iZeta,iEta,3) = Zero - EFInt(iZeta,iEta,4) = (PreFct * (B101*w1+B102*w2)) - EFInt(iZeta,iEta,5) = Zero - EFInt(iZeta,iEta,6) = (PreFct * (B101*w1+B102*w2)) - 21 Continue - 11 Continue - Go To 99 -* -*-----AACD case -* - 200 Continue - Do 12 iEta = 1, nEta - Do 22 iZeta = 1, nZeta - PQx = CoorAC(1,1)-Q(iEta,1) - PQy = CoorAC(2,1)-Q(iEta,2) - PQz = CoorAC(3,1)-Q(iEta,3) - PQ2 = (PQx**2 + PQy**2 + PQz**2) - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) - T = rho * PQ2 - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - Eu21 = r1*(Eta(iEta)*ZEInv) - Eu22 = r2*(Eta(iEta)*ZEInv) - PAQPx1 = - Eu21 * PQx - PAQPx2 = - Eu22 * PQx - PAQPy1 = - Eu21 * PQy - PAQPy2 = - Eu22 * PQy - PAQPz1 = - Eu21 * PQz - PAQPz2 = - Eu22 * PQz - B101 = (Half - Half * Eu21) * ZInv(iZeta) - B102 = (Half - Half * Eu22) * ZInv(iZeta) - x101= PAQPx1 - x102= PAQPx2 - x201= PAQPx1*x101 + B101 - x202= PAQPx2*x102 + B102 - y101= PAQPy1 - y102= PAQPy2 - y201= PAQPy1*y101 + B101 - y202= PAQPy2*y102 + B102 - z101= PAQPz1*w1 - z102= PAQPz2*w2 - z201= PAQPz1*z101 + B101*w1 - z202= PAQPz2*z102 + B102*w2 - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - EFInt(iZeta,iEta,1) = PreFct * ( x201*w1+ x202*w2) - EFInt(iZeta,iEta,2) = PreFct * (x101*y101*w1+x102*y102*w2) - EFInt(iZeta,iEta,3) = PreFct * (x101*z101 +x102*z102 ) - EFInt(iZeta,iEta,4) = PreFct * ( y201*w1+ y202*w2) - EFInt(iZeta,iEta,5) = PreFct * (y101*z101 +y102*z102 ) - EFInt(iZeta,iEta,6) = PreFct * ( z201 + z202 ) - 22 Continue - 12 Continue - Go To 99 -* -*-----ABCC case -* - 300 Continue - Do 13 iEta = 1, nEta - Do 23 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) - PQx = P(iZeta,1)-CoorAC(1,2) - PQy = P(iZeta,2)-CoorAC(2,2) - PQz = P(iZeta,3)-CoorAC(3,2) - T = rho * (PQx**2 + PQy**2 + PQz**2) - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - Eu21 = r1*(Eta(iEta)*ZEInv) - Eu22 = r2*(Eta(iEta)*ZEInv) - PAQPx1 = (P(iZeta,1) - CoorAC(1,1)) - Eu21 * PQx - PAQPx2 = (P(iZeta,1) - CoorAC(1,1)) - Eu22 * PQx - PAQPy1 = (P(iZeta,2) - CoorAC(2,1)) - Eu21 * PQy - PAQPy2 = (P(iZeta,2) - CoorAC(2,1)) - Eu22 * PQy - PAQPz1 = (P(iZeta,3) - CoorAC(3,1)) - Eu21 * PQz - PAQPz2 = (P(iZeta,3) - CoorAC(3,1)) - Eu22 * PQz - B101 = (Half - Half * Eu21) * ZInv(iZeta) - B102 = (Half - Half * Eu22) * ZInv(iZeta) - x101= PAQPx1 - x102= PAQPx2 - x201= PAQPx1*x101 + B101 - x202= PAQPx2*x102 + B102 - y101= PAQPy1 - y102= PAQPy2 - y201= PAQPy1*y101 + B101 - y202= PAQPy2*y102 + B102 - z101= PAQPz1*w1 - z102= PAQPz2*w2 - z201= PAQPz1*z101 + B101*w1 - z202= PAQPz2*z102 + B102*w2 - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - EFInt(iZeta,iEta,1) = PreFct * ( x101*w1+ x102*w2) - EFInt(iZeta,iEta,2) = PreFct * ( y101*w1+ y102*w2) - EFInt(iZeta,iEta,3) = PreFct * ( z101 + z102 ) - EFInt(iZeta,iEta,4) = PreFct * ( x201*w1+ x202*w2) - EFInt(iZeta,iEta,5) = PreFct * (x101*y101*w1+x102*y102*w2) - EFInt(iZeta,iEta,6) = PreFct * (x101*z101 +x102*z102 ) - EFInt(iZeta,iEta,7) = PreFct * ( y201*w1+ y202*w2) - EFInt(iZeta,iEta,8) = PreFct * (y101*z101 +y102*z102 ) - EFInt(iZeta,iEta,9) = PreFct * ( z201 + z202 ) - 23 Continue - 13 Continue - Go To 99 -* -*-----AACC case -* - 400 Continue - PQx = CoorAC(1,1)-CoorAC(1,2) - PQy = CoorAC(2,1)-CoorAC(2,2) - PQz = CoorAC(3,1)-CoorAC(3,2) - PQ2 = (PQx**2 + PQy**2 + PQz**2) - Do 14 iEta = 1, nEta - Do 24 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) - T = rho * PQ2 - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - Eu21 = r1*(Eta(iEta)*ZEInv) - Eu22 = r2*(Eta(iEta)*ZEInv) - PAQPx1 = - Eu21 * PQx - PAQPx2 = - Eu22 * PQx - PAQPy1 = - Eu21 * PQy - PAQPy2 = - Eu22 * PQy - PAQPz1 = - Eu21 * PQz - PAQPz2 = - Eu22 * PQz - B101 = (Half - Half * Eu21) * ZInv(iZeta) - B102 = (Half - Half * Eu22) * ZInv(iZeta) - x101= PAQPx1 - x102= PAQPx2 - x201= PAQPx1*x101 + B101 - x202= PAQPx2*x102 + B102 - y101= PAQPy1 - y102= PAQPy2 - y201= PAQPy1*y101 + B101 - y202= PAQPy2*y102 + B102 - z101= PAQPz1*w1 - z102= PAQPz2*w2 - z201= PAQPz1*z101 + B101*w1 - z202= PAQPz2*z102 + B102*w2 - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - EFInt(iZeta,iEta,1) = PreFct * ( x201*w1+ x202*w2) - EFInt(iZeta,iEta,2) = PreFct * (x101*y101*w1+x102*y102*w2) - EFInt(iZeta,iEta,3) = PreFct * (x101*z101 +x102*z102 ) - EFInt(iZeta,iEta,4) = PreFct * ( y201*w1+ y202*w2) - EFInt(iZeta,iEta,5) = PreFct * (y101*z101 +y102*z102 ) - EFInt(iZeta,iEta,6) = PreFct * ( z201 + z202 ) - 24 Continue - 14 Continue -* - 99 Continue -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_real_array(EInv) - End diff -Nru openmolcas-22.02/src/rys_util/ppss.F90 openmolcas-22.10/src/rys_util/ppss.F90 --- openmolcas-22.02/src/rys_util/ppss.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ppss.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,321 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1994, Roland Lindh * +!*********************************************************************** + +subroutine ppss(EFInt,Zeta,ZInv,nZeta,P,lP,rKappAB,A,B,Eta,EInv,nEta,Q,lQ,rKappCD,C,D,CoorAC,TMax,iPntr,nPntr,x0,nMax,CW6,CW5,CW4, & + CW3,CW2,CW1,CW0,CR6,CR5,CR4,CR3,CR2,CR1,CR0,ddx,HerW,HerR2,IsChi,ChiI2) +!*********************************************************************** +! * +! Object: to compute the primitive integrals of type (pp|ss). * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. 1994 * +!*********************************************************************** + +use Constants, only: Zero, One, Ten, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, lP, nEta, lQ, nPntr, iPntr(nPntr), nMax, IsChi +real(kind=wp), intent(out) :: EFInt(nZeta,nEta,9) +real(kind=wp), intent(in) :: Zeta(nZeta), ZInv(nZeta), P(lP,3), rKappAB(nZeta), A(3), B(3), Eta(nEta), EInv(nEta), Q(lQ,3), & + rKappCD(nEta), C(3), D(3), CoorAC(3,2), TMax, x0(nMax), CW6(nMax,2), CW5(nMax,2), CW4(nMax,2), & + CW3(nMax,2), CW2(nMax,2), CW1(nMax,2), CW0(nMax,2), CR6(nMax,2), CR5(nMax,2), CR4(nMax,2), & + CR3(nMax,2), CR2(nMax,2), CR1(nMax,2), CR0(nMax,2), ddx, HerW(2), HerR2(2), ChiI2 +integer(kind=iwp) :: iEta, iZeta, n +real(kind=wp) :: ai, B101, B102, dddx, Eu21, Eu22, PAQPx1, PAQPx2, PAQPy1, PAQPy2, PAQPz1, PAQPz2, PQ2, PQx, PQy, PQz, PreFct, r1, & + r2, rho, si, T, w1, w2, x101, x102, x201, x202, xdInv, y101, y102, y201, y202, z, z101, z102, z201, z202, ZEInv +logical(kind=iwp) :: ABeqCD, EQ + +#include "macros.fh" +unused_var(EInv) + +xdInv = One/ddx +dddx = ddx/Ten+ddx + +ABeqCD = EQ(A,B) .and. EQ(A,C) .and. EQ(A,D) + +if (ABeqCD) then + + ! AAAA case + + z = -x0(1) + w1 = (((((CW6(1,1)*z+CW5(1,1))*z+CW4(1,1))*z+CW3(1,1))*z+CW2(1,1))*z+CW1(1,1))*z+Cw0(1,1) + w2 = (((((CW6(1,2)*z+CW5(1,2))*z+CW4(1,2))*z+CW3(1,2))*z+CW2(1,2))*z+CW1(1,2))*z+Cw0(1,2) + r1 = (((((CR6(1,1)*z+CR5(1,1))*z+CR4(1,1))*z+CR3(1,1))*z+CR2(1,1))*z+CR1(1,1))*z+CR0(1,1) + r2 = (((((CR6(1,2)*z+CR5(1,2))*z+CR4(1,2))*z+CR3(1,2))*z+CR2(1,2))*z+CR1(1,2))*z+CR0(1,2) + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + Eu21 = r1*(Eta(iEta)*ZEInv) + Eu22 = r2*(Eta(iEta)*ZEInv) + B101 = (Half-Half*Eu21)*ZInv(iZeta) + B102 = (Half-Half*Eu22)*ZInv(iZeta) + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + EFInt(iZeta,iEta,1) = (PreFct*(B101*w1+B102*w2)) + EFInt(iZeta,iEta,2) = Zero + EFInt(iZeta,iEta,3) = Zero + EFInt(iZeta,iEta,4) = (PreFct*(B101*w1+B102*w2)) + EFInt(iZeta,iEta,5) = Zero + EFInt(iZeta,iEta,6) = (PreFct*(B101*w1+B102*w2)) + end do + end do + +else if (EQ(A,B) .and. (.not. EQ(C,D))) then + + ! AACD case + + do iEta=1,nEta + do iZeta=1,nZeta + PQx = CoorAC(1,1)-Q(iEta,1) + PQy = CoorAC(2,1)-Q(iEta,2) + PQz = CoorAC(3,1)-Q(iEta,3) + PQ2 = (PQx**2+PQy**2+PQz**2) + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) + T = rho*PQ2 + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + Eu21 = r1*(Eta(iEta)*ZEInv) + Eu22 = r2*(Eta(iEta)*ZEInv) + PAQPx1 = -Eu21*PQx + PAQPx2 = -Eu22*PQx + PAQPy1 = -Eu21*PQy + PAQPy2 = -Eu22*PQy + PAQPz1 = -Eu21*PQz + PAQPz2 = -Eu22*PQz + B101 = (Half-Half*Eu21)*ZInv(iZeta) + B102 = (Half-Half*Eu22)*ZInv(iZeta) + x101 = PAQPx1 + x102 = PAQPx2 + x201 = PAQPx1*x101+B101 + x202 = PAQPx2*x102+B102 + y101 = PAQPy1 + y102 = PAQPy2 + y201 = PAQPy1*y101+B101 + y202 = PAQPy2*y102+B102 + z101 = PAQPz1*w1 + z102 = PAQPz2*w2 + z201 = PAQPz1*z101+B101*w1 + z202 = PAQPz2*z102+B102*w2 + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + EFInt(iZeta,iEta,1) = PreFct*(x201*w1+x202*w2) + EFInt(iZeta,iEta,2) = PreFct*(x101*y101*w1+x102*y102*w2) + EFInt(iZeta,iEta,3) = PreFct*(x101*z101+x102*z102) + EFInt(iZeta,iEta,4) = PreFct*(y201*w1+y202*w2) + EFInt(iZeta,iEta,5) = PreFct*(y101*z101+y102*z102) + EFInt(iZeta,iEta,6) = PreFct*(z201+z202) + end do + end do + +else if ((.not. EQ(A,B)) .and. EQ(C,D)) then + + ! ABCC case + + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) + PQx = P(iZeta,1)-CoorAC(1,2) + PQy = P(iZeta,2)-CoorAC(2,2) + PQz = P(iZeta,3)-CoorAC(3,2) + T = rho*(PQx**2+PQy**2+PQz**2) + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + Eu21 = r1*(Eta(iEta)*ZEInv) + Eu22 = r2*(Eta(iEta)*ZEInv) + PAQPx1 = (P(iZeta,1)-CoorAC(1,1))-Eu21*PQx + PAQPx2 = (P(iZeta,1)-CoorAC(1,1))-Eu22*PQx + PAQPy1 = (P(iZeta,2)-CoorAC(2,1))-Eu21*PQy + PAQPy2 = (P(iZeta,2)-CoorAC(2,1))-Eu22*PQy + PAQPz1 = (P(iZeta,3)-CoorAC(3,1))-Eu21*PQz + PAQPz2 = (P(iZeta,3)-CoorAC(3,1))-Eu22*PQz + B101 = (Half-Half*Eu21)*ZInv(iZeta) + B102 = (Half-Half*Eu22)*ZInv(iZeta) + x101 = PAQPx1 + x102 = PAQPx2 + x201 = PAQPx1*x101+B101 + x202 = PAQPx2*x102+B102 + y101 = PAQPy1 + y102 = PAQPy2 + y201 = PAQPy1*y101+B101 + y202 = PAQPy2*y102+B102 + z101 = PAQPz1*w1 + z102 = PAQPz2*w2 + z201 = PAQPz1*z101+B101*w1 + z202 = PAQPz2*z102+B102*w2 + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + EFInt(iZeta,iEta,1) = PreFct*(x101*w1+x102*w2) + EFInt(iZeta,iEta,2) = PreFct*(y101*w1+y102*w2) + EFInt(iZeta,iEta,3) = PreFct*(z101+z102) + EFInt(iZeta,iEta,4) = PreFct*(x201*w1+x202*w2) + EFInt(iZeta,iEta,5) = PreFct*(x101*y101*w1+x102*y102*w2) + EFInt(iZeta,iEta,6) = PreFct*(x101*z101+x102*z102) + EFInt(iZeta,iEta,7) = PreFct*(y201*w1+y202*w2) + EFInt(iZeta,iEta,8) = PreFct*(y101*z101+y102*z102) + EFInt(iZeta,iEta,9) = PreFct*(z201+z202) + end do + end do + +else if (EQ(A,B) .and. EQ(C,D)) then + + ! AACC case + + PQx = CoorAC(1,1)-CoorAC(1,2) + PQy = CoorAC(2,1)-CoorAC(2,2) + PQz = CoorAC(3,1)-CoorAC(3,2) + PQ2 = (PQx**2+PQy**2+PQz**2) + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) + T = rho*PQ2 + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + Eu21 = r1*(Eta(iEta)*ZEInv) + Eu22 = r2*(Eta(iEta)*ZEInv) + PAQPx1 = -Eu21*PQx + PAQPx2 = -Eu22*PQx + PAQPy1 = -Eu21*PQy + PAQPy2 = -Eu22*PQy + PAQPz1 = -Eu21*PQz + PAQPz2 = -Eu22*PQz + B101 = (Half-Half*Eu21)*ZInv(iZeta) + B102 = (Half-Half*Eu22)*ZInv(iZeta) + x101 = PAQPx1 + x102 = PAQPx2 + x201 = PAQPx1*x101+B101 + x202 = PAQPx2*x102+B102 + y101 = PAQPy1 + y102 = PAQPy2 + y201 = PAQPy1*y101+B101 + y202 = PAQPy2*y102+B102 + z101 = PAQPz1*w1 + z102 = PAQPz2*w2 + z201 = PAQPz1*z101+B101*w1 + z202 = PAQPz2*z102+B102*w2 + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + EFInt(iZeta,iEta,1) = PreFct*(x201*w1+x202*w2) + EFInt(iZeta,iEta,2) = PreFct*(x101*y101*w1+x102*y102*w2) + EFInt(iZeta,iEta,3) = PreFct*(x101*z101+x102*z102) + EFInt(iZeta,iEta,4) = PreFct*(y201*w1+y202*w2) + EFInt(iZeta,iEta,5) = PreFct*(y101*z101+y102*z102) + EFInt(iZeta,iEta,6) = PreFct*(z201+z202) + end do + end do + +else + + ! ABCD case + + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) + PQx = P(iZeta,1)-Q(iEta,1) + PQy = P(iZeta,2)-Q(iEta,2) + PQz = P(iZeta,3)-Q(iEta,3) + T = rho*(PQx**2+PQy**2+PQz**2) + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + Eu21 = r1*(Eta(iEta)*ZEInv) + Eu22 = r2*(Eta(iEta)*ZEInv) + PAQPx1 = (P(iZeta,1)-CoorAC(1,1))-Eu21*PQx + PAQPx2 = (P(iZeta,1)-CoorAC(1,1))-Eu22*PQx + PAQPy1 = (P(iZeta,2)-CoorAC(2,1))-Eu21*PQy + PAQPy2 = (P(iZeta,2)-CoorAC(2,1))-Eu22*PQy + PAQPz1 = (P(iZeta,3)-CoorAC(3,1))-Eu21*PQz + PAQPz2 = (P(iZeta,3)-CoorAC(3,1))-Eu22*PQz + B101 = (Half-Half*Eu21)*ZInv(iZeta) + B102 = (Half-Half*Eu22)*ZInv(iZeta) + x101 = PAQPx1 + x102 = PAQPx2 + x201 = PAQPx1*x101+B101 + x202 = PAQPx2*x102+B102 + y101 = PAQPy1 + y102 = PAQPy2 + y201 = PAQPy1*y101+B101 + y202 = PAQPy2*y102+B102 + z101 = PAQPz1*w1 + z102 = PAQPz2*w2 + z201 = PAQPz1*z101+B101*w1 + z202 = PAQPz2*z102+B102*w2 + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + EFInt(iZeta,iEta,1) = PreFct*(x101*w1+x102*w2) + EFInt(iZeta,iEta,2) = PreFct*(y101*w1+y102*w2) + EFInt(iZeta,iEta,3) = PreFct*(z101+z102) + EFInt(iZeta,iEta,4) = PreFct*(x201*w1+x202*w2) + EFInt(iZeta,iEta,5) = PreFct*(x101*y101*w1+x102*y102*w2) + EFInt(iZeta,iEta,6) = PreFct*(x101*z101+x102*z102) + EFInt(iZeta,iEta,7) = PreFct*(y201*w1+y202*w2) + EFInt(iZeta,iEta,8) = PreFct*(y101*z101+y102*z102) + EFInt(iZeta,iEta,9) = PreFct*(z201+z202) + end do + end do + +end if + +return + +end subroutine ppss diff -Nru openmolcas-22.02/src/rys_util/pr2d.f openmolcas-22.10/src/rys_util/pr2d.f --- openmolcas-22.02/src/rys_util/pr2d.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/pr2d.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,65 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Subroutine Pr2D(xyz2D,nT,nRys,la,lb,lc,ld,IfGrad,iPrint) - Implicit Real*8 (a-h,o-z) - Real*8 xyz2d(nT,nRys,0:la+1,0:lb+1,0:lc+1,0:ld+1,3) - Logical IfGrad(3,4) - Character Label*80, ch(3)*3 - Data ch/',x)',',y)',',z)'/ -* - Write (6,*) - Write (6,*) ' Printing the 2d-integrals' - Write (6,*) -* - Label = ' ' - ja = 0 - If (IfGrad(1,1).or.IfGrad(2,1).or.IfGrad(3,1)) ja = 1 - jb = 0 - If (IfGrad(1,2).or.IfGrad(2,2).or.IfGrad(3,1)) jb = 1 - jc = 0 - If (IfGrad(1,3).or.IfGrad(2,3).or.IfGrad(3,3)) jc = 1 - jd = 0 - If (IfGrad(1,4).or.IfGrad(2,4).or.IfGrad(3,4)) jd = 1 - Do 10 ia = 0, la+ja - If (ia.gt.la) jb = 0 - Do 20 ib = 0, lb+jb - If (ia.gt.la.or.ib.gt.lb) jc = 0 - Do 30 ic = 0, lc+jc - Do 40 id = 0, ld+jd - Do 50 iCar = 1, 3 - If (ja.eq.1.and.ia.eq.la+ja.and. - & .Not.IfGrad(iCar,1)) Go To 51 - If (jb.eq.1.and.ib.eq.lb+jb.and. - & .Not.IfGrad(iCar,2)) Go To 51 - If (jc.eq.1.and.ic.eq.lc+jc.and. - & .Not.IfGrad(iCar,3)) Go To 51 - If (jd.eq.1.and.id.eq.ld+jd.and. - & .Not.IfGrad(iCar,4)) Go To 51 - Write (Label,'(A,4(I1,A))') - & ' xyz2D0(',ia,',',ib,',',ic,',',id,ch(iCar) - If (iPrint.ge.99) Then - Call RecPrt(Label,' ', - & xyz2d(1,1,ia,ib,ic,id,iCar),nT,nRys) - Else - Write (6,'(A)') Label - Write (6,*) DDot_(nT*nRys, - & xyz2d(1,1,ia,ib,ic,id,iCar),1, - & xyz2d(1,1,ia,ib,ic,id,iCar),1) - End If - 51 Continue - 50 Continue - 40 Continue - 30 Continue - 20 Continue - 10 Continue -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/pr2d.F90 openmolcas-22.10/src/rys_util/pr2d.F90 --- openmolcas-22.02/src/rys_util/pr2d.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/pr2d.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,64 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine Pr2D(xyz2d,nT,nRys,la,lb,lc,ld,IfGrad,iPrint) + +use Definitions, only: wp, iwp, u6, r8 + +implicit none +integer(kind=iwp), intent(in) :: nT, nRys, la, lb, lc, ld, iPrint +real(kind=wp), intent(in) :: xyz2d(nT,nRys,0:la+1,0:lb+1,0:lc+1,0:ld+1,3) +logical(kind=iwp), intent(in) :: IfGrad(3,4) +integer(kind=iwp) :: ia, ib, ic, iCar, id, ja, jb, jc, jd +character(len=80) :: Label +character(len=*), parameter :: ch(3) = [',x)',',y)',',z)'] +real(kind=r8), external :: DDot_ + +write(u6,*) +write(u6,*) ' Printing the 2d-integrals' +write(u6,*) + +Label = ' ' +ja = 0 +if (IfGrad(1,1) .or. IfGrad(2,1) .or. IfGrad(3,1)) ja = 1 +jb = 0 +if (IfGrad(1,2) .or. IfGrad(2,2) .or. IfGrad(3,1)) jb = 1 +jc = 0 +if (IfGrad(1,3) .or. IfGrad(2,3) .or. IfGrad(3,3)) jc = 1 +jd = 0 +if (IfGrad(1,4) .or. IfGrad(2,4) .or. IfGrad(3,4)) jd = 1 +do ia=0,la+ja + if (ia > la) jb = 0 + do ib=0,lb+jb + if ((ia > la) .or. (ib > lb)) jc = 0 + do ic=0,lc+jc + do id=0,ld+jd + do iCar=1,3 + if ((ja == 1) .and. (ia == la+ja) .and. (.not. IfGrad(iCar,1))) cycle + if ((jb == 1) .and. (ib == lb+jb) .and. (.not. IfGrad(iCar,2))) cycle + if ((jc == 1) .and. (ic == lc+jc) .and. (.not. IfGrad(iCar,3))) cycle + if ((jd == 1) .and. (id == ld+jd) .and. (.not. IfGrad(iCar,4))) cycle + write(Label,'(A,4(I1,A))') ' xyz2D0(',ia,',',ib,',',ic,',',id,ch(iCar) + if (iPrint >= 99) then + call RecPrt(Label,' ',xyz2d(:,:,ia,ib,ic,id,iCar),nT,nRys) + else + write(u6,'(A)') Label + write(u6,*) DDot_(nT*nRys,xyz2d(:,:,ia,ib,ic,id,iCar),1,xyz2d(:,:,ia,ib,ic,id,iCar),1) + end if + end do + end do + end do + end do +end do + +return + +end subroutine Pr2D diff -Nru openmolcas-22.02/src/rys_util/psps.f openmolcas-22.10/src/rys_util/psps.f --- openmolcas-22.02/src/rys_util/psps.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/psps.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,410 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1994, Roland Lindh * -************************************************************************ - Subroutine psps(EFInt,Zeta,nZeta,P,lP,rKappAB,A,B, - & Eta, nEta,Q,lQ,rKappCD,C,D, - & CoorAC,TMax, - & iPntr,nPntr,x0,nMax,CW6,CW5,CW4,CW3,CW2,CW1,CW0, - & CR6,CR5,CR4,CR3,CR2,CR1,CR0, - & ddx,HerW,HerR2,IsChi,ChiI2) -************************************************************************ -* * -* Object: to compute the primitive integrals of type (ps|ps). * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. 1994 * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 EFInt(nZeta,nEta,3,3), Zeta(nZeta), Eta(nEta), - & CoorAC(3,2), - & P(lP,3), Q(lQ,3), A(3), B(3), C(3), D(3), - & rKappAB(nZeta), rKappCD(nEta), - & x0(nMax), - & CW6(nMax,2), CW5(nMax,2), CW4(nMax,2), CW3(nMax,2), - & CW2(nMax,2), CW1(nMax,2), CW0(nMax,2), - & CR6(nMax,2), CR5(nMax,2), CR4(nMax,2), CR3(nMax,2), - & CR2(nMax,2), CR1(nMax,2), CR0(nMax,2), - & HerW(2), HerR2(2) - Integer iPntr(nPntr) - Logical ABeqCD, EQ -* -* - xdInv=One/ddx - dddx = ddx/10d0 + ddx -* - ABeqCD = EQ(A,B) .and. EQ(A,C) .and. EQ(A,D) - If ( ABeqCD ) Go To 100 - If ( EQ(A,B).and..Not.EQ(C,D)) Go To 200 - If (.Not.EQ(A,B).and. EQ(C,D)) Go To 300 - If ( EQ(A,B).and. EQ(C,D)) Go To 400 -* -*-----ABCD case -* - Do 10 iEta = 1, nEta - Do 20 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - rho = Zeta(iZeta)*Eta(iEta)*ZEInv - PQx = P(iZeta,1)-Q(iEta,1) - PQy = P(iZeta,2)-Q(iEta,2) - PQz = P(iZeta,3)-Q(iEta,3) - T = rho * (PQx**2 + PQy**2 + PQz**2) - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - Eu21 = Eta(iEta) * (r1*ZEInv) - Eu22 = Eta(iEta) * (r2*ZEInv) - Zu21 = Zeta(iZeta) * (r1*ZEInv) - Zu22 = Zeta(iZeta) * (r2*ZEInv) - PAQPx1 = (P(iZeta,1) - CoorAC(1,1)) - Eu21 * PQx - PAQPx2 = (P(iZeta,1) - CoorAC(1,1)) - Eu22 * PQx - PAQPy1 = (P(iZeta,2) - CoorAC(2,1)) - Eu21 * PQy - PAQPy2 = (P(iZeta,2) - CoorAC(2,1)) - Eu22 * PQy - PAQPz1 = (P(iZeta,3) - CoorAC(3,1)) - Eu21 * PQz - PAQPz2 = (P(iZeta,3) - CoorAC(3,1)) - Eu22 * PQz - QCPQx1 = (Q(iEta,1) - CoorAC(1,2)) + Zu21 * PQx - QCPQx2 = (Q(iEta,1) - CoorAC(1,2)) + Zu22 * PQx - QCPQy1 = (Q(iEta,2) - CoorAC(2,2)) + Zu21 * PQy - QCPQy2 = (Q(iEta,2) - CoorAC(2,2)) + Zu22 * PQy - QCPQz1 = (Q(iEta,3) - CoorAC(3,2)) + Zu21 * PQz - QCPQz2 = (Q(iEta,3) - CoorAC(3,2)) + Zu22 * PQz - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - x101= PAQPx1 - x011= QCPQx1 - x111= PAQPx1*QCPQx1 + B001 - x102= PAQPx2 - x012= QCPQx2 - x112= PAQPx2*QCPQx2 + B002 - y101= PAQPy1 - y011= QCPQy1 - y111= PAQPy1*QCPQy1 + B001 - y102= PAQPy2 - y012= QCPQy2 - y112= PAQPy2*QCPQy2 + B002 - z101= PAQPz1 - z011= QCPQz1 - z111= PAQPz1*QCPQz1 + B001 - z102= PAQPz2 - z012= QCPQz2 - z112= PAQPz2*QCPQz2 + B002 - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - EFInt(iZeta,iEta,1,1) = PreFct * (x111 *w1+x112 *w2) - EFInt(iZeta,iEta,1,2) = PreFct * (x101*y011*w1+x102*y012*w2) - EFInt(iZeta,iEta,1,3) = PreFct * (x101*z011*w1+x102*z012*w2) - EFInt(iZeta,iEta,2,1) = PreFct * (y101*x011*w1+y102*x012*w2) - EFInt(iZeta,iEta,2,2) = PreFct * (y111 *w1 + y112 *w2) - EFInt(iZeta,iEta,2,3) = PreFct * (y101*z011*w1+y102*z012*w2) - EFInt(iZeta,iEta,3,1) = PreFct * (z101*x011*w1+z102*x012*w2) - EFInt(iZeta,iEta,3,2) = PreFct * (z101*y011*w1+z102*y012*w2) - EFInt(iZeta,iEta,3,3) = PreFct * (z111 *w1 + z112 *w2) - 20 Continue - 10 Continue - Go To 99 -* -*-----AAAA case -* - 100 Continue - z = - x0(1) - w1=(((((CW6(1,1)*z+CW5(1,1))*z+CW4(1,1))*z+CW3(1,1))*z+ - & CW2(1,1))*z+CW1(1,1))*z+Cw0(1,1) - w2=(((((CW6(1,2)*z+CW5(1,2))*z+CW4(1,2))*z+CW3(1,2))*z+ - & CW2(1,2))*z+CW1(1,2))*z+Cw0(1,2) - r1=(((((CR6(1,1)*z+CR5(1,1))*z+CR4(1,1))*z+CR3(1,1))*z+ - & CR2(1,1))*z+CR1(1,1))*z+CR0(1,1) - r2=(((((CR6(1,2)*z+CR5(1,2))*z+CR4(1,2))*z+CR3(1,2))*z+ - & CR2(1,2))*z+CR1(1,2))*z+CR0(1,2) - Do 11 iEta = 1, nEta - Do 21 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - B001 = w1* Half * (r1*ZEInv) - B002 = w2* Half * (r2*ZEInv) - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - EFInt(iZeta,iEta,1,1) = (PreFct * (B001+B002)) - EFInt(iZeta,iEta,1,2) = Zero - EFInt(iZeta,iEta,1,3) = Zero - EFInt(iZeta,iEta,2,1) = Zero - EFInt(iZeta,iEta,2,2) = (PreFct * (B001+B002)) - EFInt(iZeta,iEta,2,3) = Zero - EFInt(iZeta,iEta,3,1) = Zero - EFInt(iZeta,iEta,3,2) = Zero - EFInt(iZeta,iEta,3,3) = (PreFct * (B001+B002)) - 21 Continue - 11 Continue - Go To 99 -* -*-----AACD case -* - 200 Continue - Do 12 iEta = 1, nEta - Do 22 iZeta = 1, nZeta - PQx = CoorAC(1,1)-Q(iEta,1) - PQy = CoorAC(2,1)-Q(iEta,2) - PQz = CoorAC(3,1)-Q(iEta,3) - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - rho = Zeta(iZeta)*Eta(iEta)*ZEInv - T = rho * (PQx**2 + PQy**2 + PQz**2) - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - Eu21 = Eta(iEta) * (r1*ZEInv) - Eu22 = Eta(iEta) * (r2*ZEInv) - Zu21 = Zeta(iZeta) * (r1*ZEInv) - Zu22 = Zeta(iZeta) * (r2*ZEInv) - PAQPx1 = - Eu21 * PQx - PAQPx2 = - Eu22 * PQx - PAQPy1 = - Eu21 * PQy - PAQPy2 = - Eu22 * PQy - PAQPz1 = - Eu21 * PQz - PAQPz2 = - Eu22 * PQz - QCPQx1 = (Q(iEta,1) - CoorAC(1,2)) + Zu21 * PQx - QCPQx2 = (Q(iEta,1) - CoorAC(1,2)) + Zu22 * PQx - QCPQy1 = (Q(iEta,2) - CoorAC(2,2)) + Zu21 * PQy - QCPQy2 = (Q(iEta,2) - CoorAC(2,2)) + Zu22 * PQy - QCPQz1 = (Q(iEta,3) - CoorAC(3,2)) + Zu21 * PQz - QCPQz2 = (Q(iEta,3) - CoorAC(3,2)) + Zu22 * PQz - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - x101= PAQPx1 - x011= QCPQx1 - x111= PAQPx1*QCPQx1 + B001 - x102= PAQPx2 - x012= QCPQx2 - x112= PAQPx2*QCPQx2 + B002 - y101= PAQPy1 - y011= QCPQy1 - y111= PAQPy1*QCPQy1 + B001 - y102= PAQPy2 - y012= QCPQy2 - y112= PAQPy2*QCPQy2 + B002 - z101= PAQPz1 - z011= QCPQz1 - z111= PAQPz1*QCPQz1 + B001 - z102= PAQPz2 - z012= QCPQz2 - z112= PAQPz2*QCPQz2 + B002 - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - EFInt(iZeta,iEta,1,1) = PreFct * (x111 *w1+x112 *w2) - EFInt(iZeta,iEta,1,2) = PreFct * (x101*y011*w1+x102*y012*w2) - EFInt(iZeta,iEta,1,3) = PreFct * (x101*z011*w1+x102*z012*w2) - EFInt(iZeta,iEta,2,1) = PreFct * (y101*x011*w1+y102*x012*w2) - EFInt(iZeta,iEta,2,2) = PreFct * (y111 *w1 + y112 *w2) - EFInt(iZeta,iEta,2,3) = PreFct * (y101*z011*w1+y102*z012*w2) - EFInt(iZeta,iEta,3,1) = PreFct * (z101*x011*w1+z102*x012*w2) - EFInt(iZeta,iEta,3,2) = PreFct * (z101*y011*w1+z102*y012*w2) - EFInt(iZeta,iEta,3,3) = PreFct * (z111 *w1 + z112 *w2) - 22 Continue - 12 Continue - Go To 99 -* -*-----ABCC case -* - 300 Continue - Do 13 iEta = 1, nEta - Do 23 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - rho = Zeta(iZeta)*Eta(iEta)*ZEInv - PQx = P(iZeta,1)-CoorAC(1,2) - PQy = P(iZeta,2)-CoorAC(2,2) - PQz = P(iZeta,3)-CoorAC(3,2) - T = rho * (PQx**2 + PQy**2 + PQz**2) - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - Eu21 = Eta(iEta) * (r1*ZEInv) - Eu22 = Eta(iEta) * (r2*ZEInv) - Zu21 = Zeta(iZeta) * (r1*ZEInv) - Zu22 = Zeta(iZeta) * (r2*ZEInv) - PAQPx1 = (P(iZeta,1) - CoorAC(1,1)) - Eu21 * PQx - PAQPx2 = (P(iZeta,1) - CoorAC(1,1)) - Eu22 * PQx - PAQPy1 = (P(iZeta,2) - CoorAC(2,1)) - Eu21 * PQy - PAQPy2 = (P(iZeta,2) - CoorAC(2,1)) - Eu22 * PQy - PAQPz1 = (P(iZeta,3) - CoorAC(3,1)) - Eu21 * PQz - PAQPz2 = (P(iZeta,3) - CoorAC(3,1)) - Eu22 * PQz - QCPQx1 = Zu21 * PQx - QCPQx2 = Zu22 * PQx - QCPQy1 = Zu21 * PQy - QCPQy2 = Zu22 * PQy - QCPQz1 = Zu21 * PQz - QCPQz2 = Zu22 * PQz - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - x101= PAQPx1 - x011= QCPQx1 - x111= PAQPx1*QCPQx1 + B001 - x102= PAQPx2 - x012= QCPQx2 - x112= PAQPx2*QCPQx2 + B002 - y101= PAQPy1 - y011= QCPQy1 - y111= PAQPy1*QCPQy1 + B001 - y102= PAQPy2 - y012= QCPQy2 - y112= PAQPy2*QCPQy2 + B002 - z101= PAQPz1 - z011= QCPQz1 - z111= PAQPz1*QCPQz1 + B001 - z102= PAQPz2 - z012= QCPQz2 - z112= PAQPz2*QCPQz2 + B002 - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - EFInt(iZeta,iEta,1,1) = PreFct * (x111 *w1+x112 *w2) - EFInt(iZeta,iEta,1,2) = PreFct * (x101*y011*w1+x102*y012*w2) - EFInt(iZeta,iEta,1,3) = PreFct * (x101*z011*w1+x102*z012*w2) - EFInt(iZeta,iEta,2,1) = PreFct * (y101*x011*w1+y102*x012*w2) - EFInt(iZeta,iEta,2,2) = PreFct * (y111 *w1 + y112 *w2) - EFInt(iZeta,iEta,2,3) = PreFct * (y101*z011*w1+y102*z012*w2) - EFInt(iZeta,iEta,3,1) = PreFct * (z101*x011*w1+z102*x012*w2) - EFInt(iZeta,iEta,3,2) = PreFct * (z101*y011*w1+z102*y012*w2) - EFInt(iZeta,iEta,3,3) = PreFct * (z111 *w1 + z112 *w2) - 23 Continue - 13 Continue - Go To 99 -* -*-----AACC case -* - 400 Continue - PQx = CoorAC(1,1)-CoorAC(1,2) - PQy = CoorAC(2,1)-CoorAC(2,2) - PQz = CoorAC(3,1)-CoorAC(3,2) - PQ2 = (PQx**2 + PQy**2 + PQz**2) - Do 14 iEta = 1, nEta - Do 24 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - rho = Zeta(iZeta)*Eta(iEta)*ZEInv - T = rho * PQ2 - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - Eu21 = Eta(iEta) * (r1*ZEInv) - Eu22 = Eta(iEta) * (r2*ZEInv) - Zu21 = Zeta(iZeta) * (r1*ZEInv) - Zu22 = Zeta(iZeta) * (r2*ZEInv) - PAQPx1 = - Eu21 * PQx - PAQPx2 = - Eu22 * PQx - PAQPy1 = - Eu21 * PQy - PAQPy2 = - Eu22 * PQy - PAQPz1 = - Eu21 * PQz - PAQPz2 = - Eu22 * PQz - QCPQx1 = Zu21 * PQx - QCPQx2 = Zu22 * PQx - QCPQy1 = Zu21 * PQy - QCPQy2 = Zu22 * PQy - QCPQz1 = Zu21 * PQz - QCPQz2 = Zu22 * PQz - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - x101= PAQPx1 - x011= QCPQx1 - x111= PAQPx1*QCPQx1 + B001 - x102= PAQPx2 - x012= QCPQx2 - x112= PAQPx2*QCPQx2 + B002 - y101= PAQPy1 - y011= QCPQy1 - y111= PAQPy1*QCPQy1 + B001 - y102= PAQPy2 - y012= QCPQy2 - y112= PAQPy2*QCPQy2 + B002 - z101= PAQPz1 - z011= QCPQz1 - z111= PAQPz1*QCPQz1 + B001 - z102= PAQPz2 - z012= QCPQz2 - z112= PAQPz2*QCPQz2 + B002 - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - EFInt(iZeta,iEta,1,1) = PreFct * (x111 *w1+x112 *w2) - EFInt(iZeta,iEta,1,2) = PreFct * (x101*y011*w1+x102*y012*w2) - EFInt(iZeta,iEta,1,3) = PreFct * (x101*z011*w1+x102*z012*w2) - EFInt(iZeta,iEta,2,1) = PreFct * (y101*x011*w1+y102*x012*w2) - EFInt(iZeta,iEta,2,2) = PreFct * (y111 *w1 + y112 *w2) - EFInt(iZeta,iEta,2,3) = PreFct * (y101*z011*w1+y102*z012*w2) - EFInt(iZeta,iEta,3,1) = PreFct * (z101*x011*w1+z102*x012*w2) - EFInt(iZeta,iEta,3,2) = PreFct * (z101*y011*w1+z102*y012*w2) - EFInt(iZeta,iEta,3,3) = PreFct * (z111 *w1 + z112 *w2) - 24 Continue - 14 Continue - Go To 99 -* - 99 Continue -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/psps.F90 openmolcas-22.10/src/rys_util/psps.F90 --- openmolcas-22.02/src/rys_util/psps.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/psps.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,381 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1994, Roland Lindh * +!*********************************************************************** + +subroutine psps(EFInt,Zeta,nZeta,P,lP,rKappAB,A,B,Eta,nEta,Q,lQ,rKappCD,C,D,CoorAC,TMax,iPntr,nPntr,x0,nMax,CW6,CW5,CW4,CW3,CW2, & + CW1,CW0,CR6,CR5,CR4,CR3,CR2,CR1,CR0,ddx,HerW,HerR2,IsChi,ChiI2) +!*********************************************************************** +! * +! Object: to compute the primitive integrals of type (ps|ps). * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. 1994 * +!*********************************************************************** + +use Constants, only: Zero, One, Ten, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, lP, nEta, lQ, nPntr, iPntr(nPntr), nMax, IsChi +real(kind=wp), intent(out) :: EFInt(nZeta,nEta,3,3) +real(kind=wp), intent(in) :: Zeta(nZeta), P(lP,3), rKappAB(nZeta), A(3), B(3), Eta(nEta), Q(lQ,3), rKappCD(nEta), C(3), D(3), & + CoorAC(3,2), TMax, x0(nMax), CW6(nMax,2), CW5(nMax,2), CW4(nMax,2), CW3(nMax,2), CW2(nMax,2), & + CW1(nMax,2), CW0(nMax,2), CR6(nMax,2), CR5(nMax,2), CR4(nMax,2), CR3(nMax,2), CR2(nMax,2), & + CR1(nMax,2), CR0(nMax,2), ddx, HerW(2), HerR2(2), ChiI2 +integer(kind=iwp) :: iEta, iZeta, n +real(kind=wp) :: ai, B001, B002, dddx, Eu21, Eu22, PAQPx1, PAQPx2, PAQPy1, PAQPy2, PAQPz1, PAQPz2, PQ2, PQx, PQy, PQz, PreFct, & + QCPQx1, QCPQx2, QCPQy1, QCPQy2, QCPQz1, QCPQz2, r1, r2, rho, si, T, w1, w2, x011, x012, x101, x102, x111, x112, & + xdInv, y011, y012, y101, y102, y111, y112, z, z011, z012, z101, z102, z111, z112, ZEInv, Zu21, Zu22 +logical(kind=iwp) :: ABeqCD, EQ + +xdInv = One/ddx +dddx = ddx/Ten+ddx + +ABeqCD = EQ(A,B) .and. EQ(A,C) .and. EQ(A,D) + +if (ABeqCD) then + + ! AAAA case + + z = -x0(1) + w1 = (((((CW6(1,1)*z+CW5(1,1))*z+CW4(1,1))*z+CW3(1,1))*z+CW2(1,1))*z+CW1(1,1))*z+Cw0(1,1) + w2 = (((((CW6(1,2)*z+CW5(1,2))*z+CW4(1,2))*z+CW3(1,2))*z+CW2(1,2))*z+CW1(1,2))*z+Cw0(1,2) + r1 = (((((CR6(1,1)*z+CR5(1,1))*z+CR4(1,1))*z+CR3(1,1))*z+CR2(1,1))*z+CR1(1,1))*z+CR0(1,1) + r2 = (((((CR6(1,2)*z+CR5(1,2))*z+CR4(1,2))*z+CR3(1,2))*z+CR2(1,2))*z+CR1(1,2))*z+CR0(1,2) + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + B001 = w1*Half*(r1*ZEInv) + B002 = w2*Half*(r2*ZEInv) + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + EFInt(iZeta,iEta,1,1) = (PreFct*(B001+B002)) + EFInt(iZeta,iEta,1,2) = Zero + EFInt(iZeta,iEta,1,3) = Zero + EFInt(iZeta,iEta,2,1) = Zero + EFInt(iZeta,iEta,2,2) = (PreFct*(B001+B002)) + EFInt(iZeta,iEta,2,3) = Zero + EFInt(iZeta,iEta,3,1) = Zero + EFInt(iZeta,iEta,3,2) = Zero + EFInt(iZeta,iEta,3,3) = (PreFct*(B001+B002)) + end do + end do + +else if (EQ(A,B) .and. (.not. EQ(C,D))) then + + ! AACD case + + do iEta=1,nEta + do iZeta=1,nZeta + PQx = CoorAC(1,1)-Q(iEta,1) + PQy = CoorAC(2,1)-Q(iEta,2) + PQz = CoorAC(3,1)-Q(iEta,3) + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*Eta(iEta)*ZEInv + T = rho*(PQx**2+PQy**2+PQz**2) + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + PAQPx1 = -Eu21*PQx + PAQPx2 = -Eu22*PQx + PAQPy1 = -Eu21*PQy + PAQPy2 = -Eu22*PQy + PAQPz1 = -Eu21*PQz + PAQPz2 = -Eu22*PQz + QCPQx1 = (Q(iEta,1)-CoorAC(1,2))+Zu21*PQx + QCPQx2 = (Q(iEta,1)-CoorAC(1,2))+Zu22*PQx + QCPQy1 = (Q(iEta,2)-CoorAC(2,2))+Zu21*PQy + QCPQy2 = (Q(iEta,2)-CoorAC(2,2))+Zu22*PQy + QCPQz1 = (Q(iEta,3)-CoorAC(3,2))+Zu21*PQz + QCPQz2 = (Q(iEta,3)-CoorAC(3,2))+Zu22*PQz + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + x101 = PAQPx1 + x011 = QCPQx1 + x111 = PAQPx1*QCPQx1+B001 + x102 = PAQPx2 + x012 = QCPQx2 + x112 = PAQPx2*QCPQx2+B002 + y101 = PAQPy1 + y011 = QCPQy1 + y111 = PAQPy1*QCPQy1+B001 + y102 = PAQPy2 + y012 = QCPQy2 + y112 = PAQPy2*QCPQy2+B002 + z101 = PAQPz1 + z011 = QCPQz1 + z111 = PAQPz1*QCPQz1+B001 + z102 = PAQPz2 + z012 = QCPQz2 + z112 = PAQPz2*QCPQz2+B002 + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + EFInt(iZeta,iEta,1,1) = PreFct*(x111*w1+x112*w2) + EFInt(iZeta,iEta,1,2) = PreFct*(x101*y011*w1+x102*y012*w2) + EFInt(iZeta,iEta,1,3) = PreFct*(x101*z011*w1+x102*z012*w2) + EFInt(iZeta,iEta,2,1) = PreFct*(y101*x011*w1+y102*x012*w2) + EFInt(iZeta,iEta,2,2) = PreFct*(y111*w1+y112*w2) + EFInt(iZeta,iEta,2,3) = PreFct*(y101*z011*w1+y102*z012*w2) + EFInt(iZeta,iEta,3,1) = PreFct*(z101*x011*w1+z102*x012*w2) + EFInt(iZeta,iEta,3,2) = PreFct*(z101*y011*w1+z102*y012*w2) + EFInt(iZeta,iEta,3,3) = PreFct*(z111*w1+z112*w2) + end do + end do + +else if ((.not. EQ(A,B)) .and. EQ(C,D)) then + + ! ABCC case + + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*Eta(iEta)*ZEInv + PQx = P(iZeta,1)-CoorAC(1,2) + PQy = P(iZeta,2)-CoorAC(2,2) + PQz = P(iZeta,3)-CoorAC(3,2) + T = rho*(PQx**2+PQy**2+PQz**2) + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + PAQPx1 = (P(iZeta,1)-CoorAC(1,1))-Eu21*PQx + PAQPx2 = (P(iZeta,1)-CoorAC(1,1))-Eu22*PQx + PAQPy1 = (P(iZeta,2)-CoorAC(2,1))-Eu21*PQy + PAQPy2 = (P(iZeta,2)-CoorAC(2,1))-Eu22*PQy + PAQPz1 = (P(iZeta,3)-CoorAC(3,1))-Eu21*PQz + PAQPz2 = (P(iZeta,3)-CoorAC(3,1))-Eu22*PQz + QCPQx1 = Zu21*PQx + QCPQx2 = Zu22*PQx + QCPQy1 = Zu21*PQy + QCPQy2 = Zu22*PQy + QCPQz1 = Zu21*PQz + QCPQz2 = Zu22*PQz + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + x101 = PAQPx1 + x011 = QCPQx1 + x111 = PAQPx1*QCPQx1+B001 + x102 = PAQPx2 + x012 = QCPQx2 + x112 = PAQPx2*QCPQx2+B002 + y101 = PAQPy1 + y011 = QCPQy1 + y111 = PAQPy1*QCPQy1+B001 + y102 = PAQPy2 + y012 = QCPQy2 + y112 = PAQPy2*QCPQy2+B002 + z101 = PAQPz1 + z011 = QCPQz1 + z111 = PAQPz1*QCPQz1+B001 + z102 = PAQPz2 + z012 = QCPQz2 + z112 = PAQPz2*QCPQz2+B002 + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + EFInt(iZeta,iEta,1,1) = PreFct*(x111*w1+x112*w2) + EFInt(iZeta,iEta,1,2) = PreFct*(x101*y011*w1+x102*y012*w2) + EFInt(iZeta,iEta,1,3) = PreFct*(x101*z011*w1+x102*z012*w2) + EFInt(iZeta,iEta,2,1) = PreFct*(y101*x011*w1+y102*x012*w2) + EFInt(iZeta,iEta,2,2) = PreFct*(y111*w1+y112*w2) + EFInt(iZeta,iEta,2,3) = PreFct*(y101*z011*w1+y102*z012*w2) + EFInt(iZeta,iEta,3,1) = PreFct*(z101*x011*w1+z102*x012*w2) + EFInt(iZeta,iEta,3,2) = PreFct*(z101*y011*w1+z102*y012*w2) + EFInt(iZeta,iEta,3,3) = PreFct*(z111*w1+z112*w2) + end do + end do + +else if (EQ(A,B) .and. EQ(C,D)) then + + ! AACC case + + PQx = CoorAC(1,1)-CoorAC(1,2) + PQy = CoorAC(2,1)-CoorAC(2,2) + PQz = CoorAC(3,1)-CoorAC(3,2) + PQ2 = (PQx**2+PQy**2+PQz**2) + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*Eta(iEta)*ZEInv + T = rho*PQ2 + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + PAQPx1 = -Eu21*PQx + PAQPx2 = -Eu22*PQx + PAQPy1 = -Eu21*PQy + PAQPy2 = -Eu22*PQy + PAQPz1 = -Eu21*PQz + PAQPz2 = -Eu22*PQz + QCPQx1 = Zu21*PQx + QCPQx2 = Zu22*PQx + QCPQy1 = Zu21*PQy + QCPQy2 = Zu22*PQy + QCPQz1 = Zu21*PQz + QCPQz2 = Zu22*PQz + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + x101 = PAQPx1 + x011 = QCPQx1 + x111 = PAQPx1*QCPQx1+B001 + x102 = PAQPx2 + x012 = QCPQx2 + x112 = PAQPx2*QCPQx2+B002 + y101 = PAQPy1 + y011 = QCPQy1 + y111 = PAQPy1*QCPQy1+B001 + y102 = PAQPy2 + y012 = QCPQy2 + y112 = PAQPy2*QCPQy2+B002 + z101 = PAQPz1 + z011 = QCPQz1 + z111 = PAQPz1*QCPQz1+B001 + z102 = PAQPz2 + z012 = QCPQz2 + z112 = PAQPz2*QCPQz2+B002 + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + EFInt(iZeta,iEta,1,1) = PreFct*(x111*w1+x112*w2) + EFInt(iZeta,iEta,1,2) = PreFct*(x101*y011*w1+x102*y012*w2) + EFInt(iZeta,iEta,1,3) = PreFct*(x101*z011*w1+x102*z012*w2) + EFInt(iZeta,iEta,2,1) = PreFct*(y101*x011*w1+y102*x012*w2) + EFInt(iZeta,iEta,2,2) = PreFct*(y111*w1+y112*w2) + EFInt(iZeta,iEta,2,3) = PreFct*(y101*z011*w1+y102*z012*w2) + EFInt(iZeta,iEta,3,1) = PreFct*(z101*x011*w1+z102*x012*w2) + EFInt(iZeta,iEta,3,2) = PreFct*(z101*y011*w1+z102*y012*w2) + EFInt(iZeta,iEta,3,3) = PreFct*(z111*w1+z112*w2) + end do + end do + +else + + ! ABCD case + + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*Eta(iEta)*ZEInv + PQx = P(iZeta,1)-Q(iEta,1) + PQy = P(iZeta,2)-Q(iEta,2) + PQz = P(iZeta,3)-Q(iEta,3) + T = rho*(PQx**2+PQy**2+PQz**2) + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + PAQPx1 = (P(iZeta,1)-CoorAC(1,1))-Eu21*PQx + PAQPx2 = (P(iZeta,1)-CoorAC(1,1))-Eu22*PQx + PAQPy1 = (P(iZeta,2)-CoorAC(2,1))-Eu21*PQy + PAQPy2 = (P(iZeta,2)-CoorAC(2,1))-Eu22*PQy + PAQPz1 = (P(iZeta,3)-CoorAC(3,1))-Eu21*PQz + PAQPz2 = (P(iZeta,3)-CoorAC(3,1))-Eu22*PQz + QCPQx1 = (Q(iEta,1)-CoorAC(1,2))+Zu21*PQx + QCPQx2 = (Q(iEta,1)-CoorAC(1,2))+Zu22*PQx + QCPQy1 = (Q(iEta,2)-CoorAC(2,2))+Zu21*PQy + QCPQy2 = (Q(iEta,2)-CoorAC(2,2))+Zu22*PQy + QCPQz1 = (Q(iEta,3)-CoorAC(3,2))+Zu21*PQz + QCPQz2 = (Q(iEta,3)-CoorAC(3,2))+Zu22*PQz + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + x101 = PAQPx1 + x011 = QCPQx1 + x111 = PAQPx1*QCPQx1+B001 + x102 = PAQPx2 + x012 = QCPQx2 + x112 = PAQPx2*QCPQx2+B002 + y101 = PAQPy1 + y011 = QCPQy1 + y111 = PAQPy1*QCPQy1+B001 + y102 = PAQPy2 + y012 = QCPQy2 + y112 = PAQPy2*QCPQy2+B002 + z101 = PAQPz1 + z011 = QCPQz1 + z111 = PAQPz1*QCPQz1+B001 + z102 = PAQPz2 + z012 = QCPQz2 + z112 = PAQPz2*QCPQz2+B002 + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + EFInt(iZeta,iEta,1,1) = PreFct*(x111*w1+x112*w2) + EFInt(iZeta,iEta,1,2) = PreFct*(x101*y011*w1+x102*y012*w2) + EFInt(iZeta,iEta,1,3) = PreFct*(x101*z011*w1+x102*z012*w2) + EFInt(iZeta,iEta,2,1) = PreFct*(y101*x011*w1+y102*x012*w2) + EFInt(iZeta,iEta,2,2) = PreFct*(y111*w1+y112*w2) + EFInt(iZeta,iEta,2,3) = PreFct*(y101*z011*w1+y102*z012*w2) + EFInt(iZeta,iEta,3,1) = PreFct*(z101*x011*w1+z102*x012*w2) + EFInt(iZeta,iEta,3,2) = PreFct*(z101*y011*w1+z102*y012*w2) + EFInt(iZeta,iEta,3,3) = PreFct*(z111*w1+z112*w2) + end do + end do + +end if + +return + +end subroutine psps diff -Nru openmolcas-22.02/src/rys_util/psss.f openmolcas-22.10/src/rys_util/psss.f --- openmolcas-22.02/src/rys_util/psss.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/psss.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,133 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1994, Roland Lindh * -************************************************************************ - Subroutine psss(EFInt,Zeta,nZeta,P,lP,rKappAB,A,B, - & Eta, nEta ,Q,lQ,rKappCD,C,D, - & CoorAC,TMax, - & iPntr,nPntr,x0,nMax,W6,W5,W4,W3,W2,W1,W0, - & R6,R5,R4,R3,R2,R1,R0, - & ddx,HerW,HerR2,IsChi,ChiI2) -************************************************************************ -* * -* Object: to compute the primitive integrals of type (ps|ss). * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. 1994 * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 EFInt(nZeta,nEta,3), Zeta(nZeta), Eta(nEta), - & CoorAC(3,2), - & P(lP,3), Q(lQ,3), A(3), B(3), C(3), D(3), - & rKappAB(nZeta), rKappCD(nEta), - & x0(nMax), W6(nMax), W5(nMax), - & W4(nMax), W3(nMax), W2(nMax), W1(nMax), W0(nMax), - & R6(nMax), R5(nMax), - & R4(nMax), R3(nMax), R2(nMax), R1(nMax), R0(nMax) - Integer iPntr(nPntr) - Logical ABeqCD, EQ -* -* - xdInv=One/ddx - dddx = ddx/10d0 + ddx -* - ABeqCD = EQ(A,B) .and. EQ(A,C) .and. EQ(A,D) - If (ABeqCD) Go To 300 - If (EQ(A,B)) Go To 200 -* -*-----ABCD case -* - Do 10 iEta = 1, nEta - Do 20 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - ZE = Zeta(iZeta)*Eta(iEta) - rho = ZE*ZEInv - PQx = P(iZeta,1)-Q(iEta,1) - PQy = P(iZeta,2)-Q(iEta,2) - PQz = P(iZeta,3)-Q(iEta,3) - PQ2 = PQx**2 + PQy**2 + PQz**2 - T = rho * PQ2 - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w =(((((W6(n)*z+W5(n))*z+W4(n))*z+W3(n))*z+W2(n)) - & *z+W1(n))*z+w0(n) - r =(((((R6(n)*z+R5(n))*z+R4(n))*z+R3(n))*z+R2(n)) - & *z+R1(n))*z+R0(n) - Eu2 = r * (Eta(iEta)*ZEInv) - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) * w - Else - Eu2 = HerR2 / (Zeta(iZeta)*PQ2) - PreFct = rKappCD(iEta) * rKappAB(iZeta) - & * HerW / Sqrt(ZE*PQ2) - End If - PAQPx = P(iZeta,1) - CoorAC(1,1) - Eu2 * PQx - PAQPy = P(iZeta,2) - CoorAC(2,1) - Eu2 * PQy - PAQPz = P(iZeta,3) - CoorAC(3,1) - Eu2 * PQz - EFInt(iZeta,iEta,1) = PreFct * PAQPx - EFInt(iZeta,iEta,2) = PreFct * PAQPy - EFInt(iZeta,iEta,3) = PreFct * PAQPz - 20 Continue - 10 Continue - Go To 99 -* -*-----AACD case -* - 200 Continue - Do 11 iEta = 1, nEta - Do 21 iZeta = 1, nZeta - PQx = (Q(iEta,1)-CoorAC(1,1)) - PQy = (Q(iEta,2)-CoorAC(2,1)) - PQz = (Q(iEta,3)-CoorAC(3,1)) - PQ2 = PQx**2 + PQy**2 + PQz**2 - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - ZE = Zeta(iZeta)*Eta(iEta) - rho = ZE*ZEInv - T = rho*PQ2 - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w =(((((W6(n)*z+W5(n))*z+W4(n))*z+W3(n))*z+W2(n)) - & *z+W1(n))*z+w0(n) - r =(((((R6(n)*z+R5(n))*z+R4(n))*z+R3(n))*z+R2(n)) - & *z+R1(n))*z+R0(n) - Eu2 = r * (Eta(iEta)*ZEInv) - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) * w - Else - Eu2 = HerR2 / (Zeta(iZeta)*PQ2) - PreFct = rKappCD(iEta) * rKappAB(iZeta) - & * HerW / Sqrt(ZE*PQ2) - End If - EFInt(iZeta,iEta,1) = PreFct * Eu2 * PQx - EFInt(iZeta,iEta,2) = PreFct * Eu2 * PQy - EFInt(iZeta,iEta,3) = PreFct * Eu2 * PQz - 21 Continue - 11 Continue - Go To 99 -* -*-----CCCC case -* - 300 Continue - Do iEta = 1, nEta - Do iZeta = 1, nZeta - EFInt(iZeta,iEta,1) = Zero - EFInt(iZeta,iEta,2) = Zero - EFInt(iZeta,iEta,3) = Zero - End Do - End Do -* - 99 Continue -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/psss.F90 openmolcas-22.10/src/rys_util/psss.F90 --- openmolcas-22.02/src/rys_util/psss.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/psss.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,117 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1994, Roland Lindh * +!*********************************************************************** + +subroutine psss(EFInt,Zeta,nZeta,P,lP,rKappAB,A,B,Eta,nEta,Q,lQ,rKappCD,C,D,CoorAC,TMax,iPntr,nPntr,x0,nMax,W6,W5,W4,W3,W2,W1,W0, & + R6,R5,R4,R3,R2,R1,R0,ddx,HerW,HerR2,IsChi,ChiI2) +!*********************************************************************** +! * +! Object: to compute the primitive integrals of type (ps|ss). * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. 1994 * +!*********************************************************************** + +use Constants, only: Zero, One, Ten +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, lP, nEta, lQ, nPntr, iPntr(nPntr), nMax, IsChi +real(kind=wp), intent(out) :: EFInt(nZeta,nEta,3) +real(kind=wp), intent(in) :: Zeta(nZeta), P(lP,3), rKappAB(nZeta), A(3), B(3), Eta(nEta), Q(lQ,3), rKappCD(nEta), C(3), D(3), & + CoorAC(3,2), TMax, x0(nMax), W6(nMax), W5(nMax), W4(nMax), W3(nMax), W2(nMax), W1(nMax), W0(nMax), & + R6(nMax), R5(nMax), R4(nMax), R3(nMax), R2(nMax), R1(nMax), R0(nMax), ddx, HerW, HerR2, ChiI2 +integer(kind=iwp) :: iEta, iZeta, n +real(kind=wp) :: dddx, Eu2, PAQPx, PAQPy, PAQPz, PQ2, PQx, PQy, PQz, PreFct, r, rho, t, w, xdInv, z, ZE, ZEInv +logical(kind=iwp) :: ABeqCD, EQ + +xdInv = One/ddx +dddx = ddx/Ten+ddx + +ABeqCD = EQ(A,B) .and. EQ(A,C) .and. EQ(A,D) + +if (ABeqCD) then + + ! CCCC case + + EFInt(:,:,:) = Zero + +else if (EQ(A,B)) then + + ! AACD case + + do iEta=1,nEta + do iZeta=1,nZeta + PQx = (Q(iEta,1)-CoorAC(1,1)) + PQy = (Q(iEta,2)-CoorAC(2,1)) + PQz = (Q(iEta,3)-CoorAC(3,1)) + PQ2 = PQx**2+PQy**2+PQz**2 + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + ZE = Zeta(iZeta)*Eta(iEta) + rho = ZE*ZEInv + T = rho*PQ2 + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w = (((((W6(n)*z+W5(n))*z+W4(n))*z+W3(n))*z+W2(n))*z+W1(n))*z+w0(n) + r = (((((R6(n)*z+R5(n))*z+R4(n))*z+R3(n))*z+R2(n))*z+R1(n))*z+R0(n) + Eu2 = r*(Eta(iEta)*ZEInv) + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv)*w + else + Eu2 = HerR2/(Zeta(iZeta)*PQ2) + PreFct = rKappCD(iEta)*rKappAB(iZeta)*HerW/sqrt(ZE*PQ2) + end if + EFInt(iZeta,iEta,1) = PreFct*Eu2*PQx + EFInt(iZeta,iEta,2) = PreFct*Eu2*PQy + EFInt(iZeta,iEta,3) = PreFct*Eu2*PQz + end do + end do + +else + + ! ABCD case + + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + ZE = Zeta(iZeta)*Eta(iEta) + rho = ZE*ZEInv + PQx = P(iZeta,1)-Q(iEta,1) + PQy = P(iZeta,2)-Q(iEta,2) + PQz = P(iZeta,3)-Q(iEta,3) + PQ2 = PQx**2+PQy**2+PQz**2 + T = rho*PQ2 + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w = (((((W6(n)*z+W5(n))*z+W4(n))*z+W3(n))*z+W2(n))*z+W1(n))*z+w0(n) + r = (((((R6(n)*z+R5(n))*z+R4(n))*z+R3(n))*z+R2(n))*z+R1(n))*z+R0(n) + Eu2 = r*(Eta(iEta)*ZEInv) + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv)*w + else + Eu2 = HerR2/(Zeta(iZeta)*PQ2) + PreFct = rKappCD(iEta)*rKappAB(iZeta)*HerW/sqrt(ZE*PQ2) + end if + PAQPx = P(iZeta,1)-CoorAC(1,1)-Eu2*PQx + PAQPy = P(iZeta,2)-CoorAC(2,1)-Eu2*PQy + PAQPz = P(iZeta,3)-CoorAC(3,1)-Eu2*PQz + EFInt(iZeta,iEta,1) = PreFct*PAQPx + EFInt(iZeta,iEta,2) = PreFct*PAQPy + EFInt(iZeta,iEta,3) = PreFct*PAQPz + end do + end do + +end if + +return + +end subroutine psss diff -Nru openmolcas-22.02/src/rys_util/read_abdata.f openmolcas-22.10/src/rys_util/read_abdata.f --- openmolcas-22.02/src/rys_util/read_abdata.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/read_abdata.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,62 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - subroutine read_abdata - implicit none -#include "SysDef.fh" -#include "abtab.fh" - character(len=*), parameter :: ABDATA_NAME = 'ABDATA' - integer, parameter :: lu_abdata = 22 - logical :: found_abdata -* - character(len=8) :: key - integer :: i, itab, ipos, k, nerr -* - call f_Inquire(ABDATA_NAME,found_abdata) - if (.not.found_abdata) then - call warningmessage(2, - & ' the abdata file does not exist.') - call abend() - end if - call molcas_open(lu_abdata,ABDATA_NAME) - - 10 read(lu_abdata,'(a8)') key - if(key.ne.'NTAB1, N') goto 10 - read(lu_abdata,*) ntab1,ntab2,maxdeg - nerr=0 - if(ntab2-ntab1+1.gt.mxsiz2) then - call warningmessage(2,' mxsiz2 is too small in readab.') - write(6,*)' recompile. needs mxsiz2=',ntab2-ntab1+1 - nerr=1 - end if - if(maxdeg.gt.mxsiz1) then - call warningmessage(2,' mxsiz1 is too small in readab.') - write(6,*)' recompile. needs mxsiz1=',maxdeg - nerr=1 - end if - if(nerr.eq.1) call abend() - ipos=0 - do i=ntab1,ntab2 - 20 read(lu_abdata,'(a8)') key - if(key.ne.'TAB POIN') goto 20 - ipos=ipos+1 - read(lu_abdata,*) itab, tvalue(ipos), p0(ipos) - read(lu_abdata,*) - read(lu_abdata,*)(atab(k,ipos),k=0,maxdeg) - read(lu_abdata,*) - read(lu_abdata,*)(btab(k,ipos),k=0,maxdeg) - end do -* - close (lu_abdata) - return -#ifdef _WARNING_WORKAROUND_ - if (.false.) call Unused_integer(itab) -#endif - end diff -Nru openmolcas-22.02/src/rys_util/read_rysrw.f openmolcas-22.10/src/rys_util/read_rysrw.f --- openmolcas-22.02/src/rys_util/read_rysrw.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/read_rysrw.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,200 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991, Roland Lindh * -************************************************************************ - subroutine read_rysrw -************************************************************************ -* * -* Object: to setup the coefficients for the Rys roots and weights. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* September '90 * -* Modified to DaFile February '91 * -************************************************************************ - use vRys_RW -CVV: some variables used under #ifdef are not defined. -c implicit none -#include "SysDef.fh" -#include "itmax.fh" -#include "stdalloc.fh" - character(len=*), parameter :: RYSRW_NAME = 'RYSRW' - integer, parameter :: lu_rysrw = 22 - logical :: found_rysrw -* - integer :: mRys, nOrder, nCff - real*8 :: acc(maxrys) -* - integer :: iRys, iOff - integer :: nMap_Tot, nMem_Tot, nx0_Tot, nMem - integer :: io -* -* Open file for data base -* - call f_Inquire(RYSRW_NAME,found_rysrw) - if (.not.found_rysrw) then - call warningmessage(2, - & ' the rysrw file does not exist.') - call abend() - end if - call molcas_open(lu_rysrw,RYSRW_NAME) -#ifdef _DEBUGPRINT_ - Write (6,*) ' nDisk=',nDisk -#endif -* -* Read initial data -* - io = 1 - Do While (io .ne. 0) - Read (lu_rysrw,*,IOStat=io) mRys,nOrder - End Do - If (mRys.gt.MaxRys) Then - Call WarningMessage(2, - & ' Database requires new code!'// - & ' Database and code are at incompatible levels!') - Call Abend() - End If - nMxRys=mRys - nCff=2*(nOrder+1) - Read (lu_rysrw,*) (Acc(i),i=1,mRys) -#ifdef _DEBUGPRINT_ - Write (6,*) - Write (6,*) ' Reading tables for roots and weights of Rys poly.' - Write (6,*) ' Highest order is:',mRys - Write (6,*) ' Order of approximating polynomial:',nOrder - Write (6,*) ' Relative accuracy of computed values:',(Acc(i), - & i=1,mRys) - Write (6,*) -#endif -* -* Read value of T at which asymptotic formulas will be used -* - Call mma_allocate(TMax,mRys,label='TMax') -c Call InR(Tmax,mRys,lu_rysrw) - Read (lu_rysrw,*) (TMax(i),i=1,mRys) -#ifdef _DEBUGPRINT_ - Call RecPrt(' Tmax',' ',Tmax,mRys,1) -#endif -* -* Read increment of tables -* - Call mma_allocate(ddx,mRys,label='ddx') -c Call InR(ddx,mRys,lu_rysrw) - Read (lu_rysrw,*) (ddx(i),i=1,mRys) -#ifdef _DEBUGPRINT_ - Call RecPrt(' ddx ',' ',ddx,mRys,1) -#endif -* -* Read size of map array -* -c Call InI(nMap,mRys,lu_rysrw) - Read (lu_rysrw,*) (nMap(i),i=1,mRys) -#ifdef _DEBUGPRINT_ - Write (6,*) ' nMap=',nMap -#endif -* -* Read number of subranges -* -c Call InI(nx0,mRys,lu_rysrw) - Read (lu_rysrw,*) (nx0(i),i=1,mRys) -#ifdef _DEBUGPRINT_ - Write (6,*) ' nx0=',nx0 -#endif -* -* Read map array and x0 array for each order of Rys polynomials -* - nMap_Tot = 0 - nx0_Tot = 0 - Do iRys = 1, mRys - iMap(iRys) = nMap_Tot + 1 - nMap_Tot = nMap_Tot + nMap(iRys) - ix0(iRys) = nx0_Tot + 1 - nx0_Tot = nx0_Tot + nx0(iRys) - End Do - call mma_allocate(Map,nMap_Tot,label='Map') - Call mma_allocate(x0,nx0_Tot,label='x0') - Do iRys = 1, mRys -c Call InI(Map(iMap(iRys)),nMap(iRys),lu_rysrw) - iOff=iMap(iRys)-1 - Read (lu_rysrw,*) (Map(i),i=iOff+1,iOff+nMap(iRys)) -* -c Call InR(x0(ix0(iRys)),nx0(iRys),lu_rysrw) - iOff=ix0(iRys)-1 - Read (lu_rysrw,*) (x0(i),i=iOff+1,iOff+nx0(iRys)) - End Do -* -* Allocate memory for coefficients -* - nMem_Tot = 0 - Do iRys = 1, mRys - iCffR(0,iRys) = nMem_Tot + 1 - nMem=nx0(iRys)*iRys - nMem_Tot = nMem_Tot + nCff*nMem - End Do - Call mma_allocate(Cff,nMem_Tot,label='Cff') - Do iRys = 1, mRys -* -* Read coefficients from file -* - nMem=nx0(iRys)*iRys - iCffR(1,iRys) = iCffR(0,iRys) + nMem - iCffR(2,iRys) = iCffR(1,iRys) + nMem - iCffR(3,iRys) = iCffR(2,iRys) + nMem - iCffR(4,iRys) = iCffR(3,iRys) + nMem - iCffR(5,iRys) = iCffR(4,iRys) + nMem - iCffR(6,iRys) = iCffR(5,iRys) + nMem -* - ICffW(0,iRys) = iCffR(6,iRys) + nMem - iCffW(1,iRys) = iCffW(0,iRys) + nMem - iCffW(2,iRys) = iCffW(1,iRys) + nMem - iCffW(3,iRys) = iCffW(2,iRys) + nMem - iCffW(4,iRys) = iCffW(3,iRys) + nMem - iCffW(5,iRys) = iCffW(4,iRys) + nMem - iCffW(6,iRys) = iCffW(5,iRys) + nMem -* -c Call InR(Cff(iCffR(0,iRys)),nMem*nCff,lu_rysrw) - iOff=iCffR(0,iRys)-1 - Read (lu_rysrw,*) (Cff(i),i=iOff+1,iOff+nMem*nCff) -* - End Do -* - Close (lu_rysrw) -* - Return -#ifdef _WARNING_WORKAROUND_ - If (.False.) Call Unusued_real_array(Acc) -#endif - End - - Subroutine InR(A,n,Lu) - Implicit None - Integer n, Lu - Real*8 A(n) - Integer i, iEnd, j - Do i = 1, n, 3 - iend = Min(i+2,n) -c The numbers are actually E21.15, but some compilers -c warn about the size, and it shouldn't matter for reading - Read (Lu,'(3E21.14)') (A(j),j=i,iend) - End Do - Return - End - - Subroutine InI(A,n,Lu) - Implicit None - Integer n, Lu - Integer A(n) - Integer i, iEnd, j - Do i = 1, n, 3 - iend = Min(i+2,n) - Read (Lu,*) (A(j),j=i,iend) - End Do - Return - End diff -Nru openmolcas-22.02/src/rys_util/read_rysrw.F90 openmolcas-22.10/src/rys_util/read_rysrw.F90 --- openmolcas-22.02/src/rys_util/read_rysrw.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/read_rysrw.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,161 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991, Roland Lindh * +!*********************************************************************** + +subroutine read_rysrw() +!*********************************************************************** +! * +! Object: to setup the coefficients for the Rys roots and weights. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! September '90 * +! Modified to DaFile February '91 * +!*********************************************************************** + +use vRys_RW, only: Cff, ddx, iCffR, iCffW, iMap, ix0, Map, nMap, nMxRys, nx0, TMax, x0 +use stdalloc, only: mma_allocate +use Definitions, only: wp, iwp +#ifdef _DEBUGPRINT_ +use Definitions, only: u6 +#endif + +implicit none +integer(kind=iwp) :: i, io, iOff, iRys, lu_rysrw, mRys, nCff, nMap_Tot, nMem, nMem_Tot, nOrder, nx0_Tot +real(kind=wp) :: acc(size(iMap)) +logical(kind=iwp) :: found_rysrw +character(len=*), parameter :: RYSRW_NAME = 'RYSRW' +integer(kind=iwp), external :: isFreeUnit + +! Open file for data base + +call f_Inquire(RYSRW_NAME,found_rysrw) +if (.not. found_rysrw) then + call warningmessage(2,' the rysrw file does not exist.') + call abend() +end if +lu_rysrw = isFreeUnit(22) +call molcas_open(lu_rysrw,RYSRW_NAME) + +! Read initial data + +io = 1 +do while (io /= 0) + read(lu_rysrw,*,iostat=io) mRys,nOrder +end do +if (mRys > size(iMap)) then + call WarningMessage(2,' Database requires new code! Database and code are at incompatible levels!') + call Abend() +end if +nMxRys = mRys +nCff = 2*(nOrder+1) +read(lu_rysrw,*) (Acc(i),i=1,mRys) +#ifdef _DEBUGPRINT_ +write(u6,*) +write(u6,*) ' Reading tables for roots and weights of Rys poly.' +write(u6,*) ' Highest order is:',mRys +write(u6,*) ' Order of approximating polynomial:',nOrder +write(u6,*) ' Relative accuracy of computed values:',(Acc(i),i=1,mRys) +write(u6,*) +#endif + +! Read value of T at which asymptotic formulas will be used + +call mma_allocate(TMax,mRys,label='TMax') +read(lu_rysrw,*) (TMax(i),i=1,mRys) +#ifdef _DEBUGPRINT_ +call RecPrt(' Tmax',' ',Tmax,mRys,1) +#endif + +! Read increment of tables + +call mma_allocate(ddx,mRys,label='ddx') +read(lu_rysrw,*) (ddx(i),i=1,mRys) +#ifdef _DEBUGPRINT_ +call RecPrt(' ddx ',' ',ddx,mRys,1) +#endif + +! Read size of map array + +read(lu_rysrw,*) (nMap(i),i=1,mRys) +#ifdef _DEBUGPRINT_ +write(u6,*) ' nMap=',nMap +#endif + +! Read number of subranges + +read(lu_rysrw,*) (nx0(i),i=1,mRys) +#ifdef _DEBUGPRINT_ +write(u6,*) ' nx0=',nx0 +#endif + +! Read map array and x0 array for each order of Rys polynomials + +nMap_Tot = 0 +nx0_Tot = 0 +do iRys=1,mRys + iMap(iRys) = nMap_Tot+1 + nMap_Tot = nMap_Tot+nMap(iRys) + ix0(iRys) = nx0_Tot+1 + nx0_Tot = nx0_Tot+nx0(iRys) +end do +call mma_allocate(Map,nMap_Tot,label='Map') +call mma_allocate(x0,nx0_Tot,label='x0') +do iRys=1,mRys + iOff = iMap(iRys)-1 + read(lu_rysrw,*) (Map(i),i=iOff+1,iOff+nMap(iRys)) + + iOff = ix0(iRys)-1 + read(lu_rysrw,*) (x0(i),i=iOff+1,iOff+nx0(iRys)) +end do + +! Allocate memory for coefficients + +nMem_Tot = 0 +do iRys=1,mRys + iCffR(0,iRys) = nMem_Tot+1 + nMem = nx0(iRys)*iRys + nMem_Tot = nMem_Tot+nCff*nMem +end do +call mma_allocate(Cff,nMem_Tot,label='Cff') +do iRys=1,mRys + + ! Read coefficients from file + + nMem = nx0(iRys)*iRys + iCffR(1,iRys) = iCffR(0,iRys)+nMem + iCffR(2,iRys) = iCffR(1,iRys)+nMem + iCffR(3,iRys) = iCffR(2,iRys)+nMem + iCffR(4,iRys) = iCffR(3,iRys)+nMem + iCffR(5,iRys) = iCffR(4,iRys)+nMem + iCffR(6,iRys) = iCffR(5,iRys)+nMem + + ICffW(0,iRys) = iCffR(6,iRys)+nMem + iCffW(1,iRys) = iCffW(0,iRys)+nMem + iCffW(2,iRys) = iCffW(1,iRys)+nMem + iCffW(3,iRys) = iCffW(2,iRys)+nMem + iCffW(4,iRys) = iCffW(3,iRys)+nMem + iCffW(5,iRys) = iCffW(4,iRys)+nMem + iCffW(6,iRys) = iCffW(5,iRys)+nMem + + iOff = iCffR(0,iRys)-1 + read(lu_rysrw,*) (Cff(i),i=iOff+1,iOff+nMem*nCff) + +end do + +close(lu_rysrw) + +return +#ifdef _WARNING_WORKAROUND_ +if (.false.) call Unusued_real_array(Acc) +#endif + +end subroutine read_rysrw diff -Nru openmolcas-22.02/src/rys_util/rs2dgh.f openmolcas-22.10/src/rys_util/rs2dgh.f --- openmolcas-22.02/src/rys_util/rs2dgh.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rs2dgh.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1443 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1995, Roland Lindh * -* 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine Rs2Dgh(xyz2D0,nT,nRys,la,lb,lc,ld,xyz2D1,xyz2D2, - & IfHss,IndHss,IfGrad,IndGrd,IfG, - & Coora,Alpha,Beta,Gamma,Delta,nZeta, - & nEta,Scrtch,Scrtch2,Temp,Index1,Index2, - & Index3,Index4,ng,nh, - & ExpX,ExpY,mZeta,mEta,nIrrep,Tr) -************************************************************************ -* * -* Object:To compute the gradients and the Hessians of the 2D-integrals.* -* * -* Author: Anders Bernhardsson & Roland Lindh, * -* Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* Februar '95 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) - External ExpX, ExpY -#include "real.fh" - Real*8 xyz2D0(nRys*nT,0:la+2,0:lb+2,0:lc+2,0:ld+2,3), - & xyz2D1(nRys*nT,0:la ,0:lb ,0:lc ,0:ld ,3,3), - & xyz2D2(nRys*nT,0:la ,0:lb ,0:lc ,0:ld ,3,6), - & Coora(3,4), - & Alpha(nZeta), Beta(nZeta), Gamma(nEta), Delta(nEta), - & Scrtch2(nRys*nT),Scrtch(nRys*nT), Temp(nT) - Logical IfGrad(3,4),IfHss(4,3,4,3),IfG(4), EQ, Tr(4) - Integer IndGrd(3,4,0:nIrrep-1), Ind1(3), - & Ind2(3),Ind3(3),Ind4(3), - & Index2(3,4,4),Index1(3,4), - & Index3(3,3),Index4(2,6,3),ng(3),nh(3), - & IndHss(4,3,4,3,0:nIrrep-1) -#ifdef NAGFOR - Save Ind1, Ind2, Ind3, Ind4 -#endif -* - nx = 0 - ny = 0 - nz = 0 - mx=0 - my=0 - mz=0 - Call ICopy(12,[0],0,Index1,1) - Call ICopy(48,[0],0,Index2,1) -* -* Differentiate with respect to the first center -* - If (IfG(1)) Then - Call ExpX(Temp ,mZeta,mEta,Alpha,Sqrt(Two)) - Call Exp_2(Scrtch,nRys,nT,Temp,Sqrt(Two)) - nVec = 0 - If (IfGrad(1,1)) Then - nx = nx + 1 - nVec = nVec + 1 - Ind1(nVec) = nx - Ind2(nVec) = 1 - Index1(1,1) =nx - Index3(nx,1)=1 - End If - If (IfGrad(2,1)) Then - ny = ny + 1 - nVec = nVec + 1 - Ind1(nVec) = ny - Ind2(nVec) = 2 - Index1(2,1) = ny - Index3(ny,2)=1 - End If - If (IfGrad(3,1)) Then - nz = nz + 1 - nVec = nVec + 1 - Ind1(nVec) = nz - Ind2(nVec) = 3 - Index1(3,1) = nz - Index3(nz,3)=1 - End If - Do i=nvec+1,3 - Ind1(i)=0 - End Do -* - mvec=0 - If (IfHss(1,1,1,1)) Then - mx=mx+1 - mvec=mvec+1 - Ind3(mVec) = mx - Ind4(mVec) = 1 - Index2(1,1,1) = mx - Index4(1,mx,1)=1 - Index4(2,mx,1)=1 - End If - If (IfHss(1,2,1,2)) Then - my=my+1 - mvec=mvec+1 - Ind3(mVec) = my - Ind4(mVec) = 2 - Index2(2,1,1) = my - Index4(1,my,2)=1 - Index4(2,my,2)=1 - End If - If (IfHss(1,3,1,3)) Then - mz=mz+1 - mvec=mvec+1 - Ind3(mVec) = mz - Ind4(mVec) = 3 - Index2(3,1,1) = mz - Index4(1,mz,3)=1 - Index4(2,mz,3)=1 - End If - Do i=mvec+1,3 - Ind3(i)=0 - End Do - nvecx=max(nvec,mvec) - If (nVecx.ne.0) Then -* -* Here we go with center 1 -* - Do n=1,nvec - Do id = 0, ld - Do ic = 0, lc - Do ib = 0, lb - ra=-One - Do ia=0,la - ra=ra+Two - Do iVec = 1, nRys*nT - xyz2D1(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & Scrtch(iVec) * - & xyz2D0(iVec,ia+1,ib,ic,id,Ind2(n)) - End Do - End Do - End Do - End Do - End Do - End Do - Do n=1,mvec - Do id = 0, ld - Do ic = 0, lc - Do ib = 0, lb - ra=-One - Do ia=0,la - ra=ra+Two - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind4(n),Ind3(n))= - & Scrtch(iVec)**2* - & xyz2D0(iVec,ia+2,ib,ic,id,Ind4(n))- - & ra* Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic,id,Ind4(n)) - End Do - End Do - End Do - End Do - End Do - End Do - If (la.ge.1) Then - Do n=1,nvec - Do id=0,ld - Do ic=0,lc - Do ib=0,lb - ra=Zero - Do ia=1,la - ra=ra+One - Call DaXpY_inline(nRys*nT,-ra, - & xyz2D0(1,ia-1,ib,ic,id,Ind2(n)),1, - & xyz2D1(1,ia,ib,ic,id,Ind2(n),Ind1(n)),1) - End Do - End Do - End Do - End Do - End Do - End If - If (la.ge.2) Then - Do n=1,mvec - Do id=0,ld - Do ic=0,lc - Do ib=0,lb - ra=One - Do ia=2,la - ra=ra+One - Fact=ra*ra-ra - Call Daxpy_inline(nRys*nT,Fact, - & xyz2D0(1,ia-2,ib,ic,id,Ind4(n)),1, - & xyz2D2(1,ia,ib,ic,id,Ind4(n),Ind3(n)),1) - End Do - End Do - End Do - End Do - End Do - End If - End If - End If - -* -* Cross term center 1 and center 2 -* - If (IfG(2)) Then - Call ExpX(Temp ,mZeta,mEta,Beta,Sqrt(Two)) - Call Exp_2(Scrtch2,nRys,nT,Temp,Sqrt(Two)) - End If - If (IfG(2).and.Ifg(1)) Then - nVec=0 - If (ifHss(2,1,1,1)) Then - mx=mx+1 - nVec = nVec + 1 - Ind1(nvec)=mx - Ind2(nVec)=1 - Index2(1,2,1)=mx - Index4(1,mx,1)=2 - Index4(2,mx,1)=1 - End If - If (ifHss(2,2,1,2)) Then - my=my+1 - nVec = nVec + 1 - Ind1(nvec)=my - Ind2(nVec)=2 - Index2(2,2,1)=my - Index4(1,my,2)=2 - Index4(2,my,2)=1 - End If - If (ifHss(2,3,1,3)) Then - mz=mz+1 - nVec = nVec + 1 - Ind1(nvec)=mz - Ind2(nVec)=3 - Index2(3,2,1)=mz - Index4(1,mz,3)=2 - Index4(2,mz,3)=1 - End If - Do i=nVec+1,3 - Ind1(i)=0 - End Do - If (nvec.ne.0) Then - Do n=1,nvec - Do id = 0, ld - Do ic = 0, lc - Do ib=0,lb - Do ia=0,la - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & Scrtch(iVec) * Scrtch2(iVec)* - & xyz2D0(iVec,ia+1,ib+1,ic,id,Ind2(n)) - End DO - End DO - End DO - End DO - End DO - End DO - If (la.ge.1) Then - Do n=1,nvec - Do id = 0, ld - Do ic = 0, lc - Do ib=0,lb - ra=Zero - Do ia=1,la - ra=ra+One - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) - - & ra * Scrtch2(iVec)* - & xyz2D0(iVec,ia-1,ib+1,ic,id,Ind2(n)) - End Do - End Do - End Do - End Do - End Do - End Do - End If - If (lb.ge.1) Then - Do n=1,nvec - Do id = 0, ld - Do ic = 0, lc - rb=Zero - Do ib=1,lb - rb=rb+One - Do ia=0,la - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) - - & rb * Scrtch(iVec)* - & xyz2D0(iVec,ia+1,ib-1,ic,id,Ind2(n)) - End Do - End Do - End Do - End Do - End Do - End Do - End If - If ((la.ge.1).and.(lb.ge.1)) Then - Do n=1,nvec - Do id = 0, ld - Do ic = 0, lc - rb=Zero - Do ib=1,lb - rb=rb+One - ra=Zero - Do ia=1,la - ra=ra+One - Fact=ra*rb - Call DaXpY_inline(nRys*nT,Fact, - & xyz2D0(1,ia-1,ib-1,ic,id,Ind2(n)),1, - & xyz2D2(1,ia,ib,ic,id,Ind2(n),Ind1(n)),1) - End Do - End Do - End Do - End Do - End Do - End If - End If - End If -* -* Differentiate with respect to the second center -* -* - If (IfG(2) ) Then - Call ExpX(Temp ,mZeta,mEta,Beta,Sqrt(Two)) - Call Exp_2(Scrtch2,nRys,nT,Temp,Sqrt(Two)) - nVec = 0 - If (IfGrad(1,2)) Then - nx = nx + 1 - nVec = nVec + 1 - Ind1(nVec) = nx - Ind2(nVec) = 1 - Index1(1,2) = nx - Index3(nx,1)=2 - End If - If (IfGrad(2,2)) Then - ny = ny + 1 - nVec = nVec + 1 - Ind1(nVec) = ny - Ind2(nVec) = 2 - Index3(ny,2)=2 - Index1(2,2) = ny - End If - If (IfGrad(3,2)) Then - nz = nz + 1 - nVec = nVec + 1 - Ind1(nVec) = nz - Ind2(nVec) = 3 - Index1(3,2) = nz - Index3(nz,3)=2 - End If - Do i=nvec+1,3 - Ind1(i)=0 - End Do -* - mvec=0 - If (IfHss(2,1,2,1)) Then - mx=mx+1 - mvec=mvec+1 - Ind3(mVec) = mx - Ind4(mVec) = 1 - Index2(1,2,2) = mx - Index4(1,mx,1)=2 - Index4(2,mx,1)=2 - End If - If (IfHss(2,2,2,2)) Then - my=my+1 - mvec=mvec+1 - Ind3(mVec) = my - Ind4(mvec)=2 - Index2(2,2,2) = my - Index4(1,my,2)=2 - Index4(2,my,2)=2 - End If - If (IfHss(2,3,2,3)) Then - mz=mz+1 - mvec=mvec+1 - Ind3(mVec) = mz - Ind4(mVec) = 3 - Index2(3,2,2) = mz - Index4(1,mz,3)=2 - Index4(2,mz,3)=2 - End If - Do i=mvec+1,3 - Ind3(i)=0 - End Do - nvecx=max(nvec,mvec) - If (nVecx.ne.0) Then -* - Do n=1,nVec - Do id = 0, ld - Do ic = 0, lc - rb=-One - Do ib=0,lb - rb=rb+Two - Do ia = 0, la - Do iVec = 1, nRys*nT - xyz2D1(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & Scrtch2(iVec) * - & xyz2D0(iVec,ia,ib+1,ic,id,Ind2(n)) - End Do - End Do - End Do - End Do - End Do - End Do - Do n=1,mVec - Do id = 0, ld - Do ic = 0, lc - rb=-One - Do ib=0,lb - rb=rb+Two - Do ia = 0, la - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind4(n),Ind3(n))= - & Scrtch2(iVec)**2* - & xyz2D0(iVec,ia,ib+2,ic,id,Ind4(n))- - & rb * Scrtch2(iVec) * - & xyz2D0(iVec,ia,ib,ic,id,Ind4(n)) - End Do - End Do - End Do - End Do - End Do - End Do - - If (lb.ge.1) Then - Do n=1,nvec - Do id=0,ld - Do ic=0,lc - rb=Zero - Do ib=1,lb - rb=rb+One - Do ia=0,la - Call DaXpy_inline(nRys*nT,-rb, - & xyz2D0(1,ia,ib-1,ic,id,Ind2(n)),1, - & xyz2D1(1,ia,ib,ic,id,Ind2(n),Ind1(n)),1) - End Do - End Do - End Do - End Do - End Do - End If - If (lb.ge.2) Then - Do n=1,mvec - Do id=0,ld - Do ic=0,lc - rb=One - Do ib=2,lb - rb=rb+One - Fact=rb*rb-rb - Do ia=0,la - Call DaXpy_inline(nRys*nT,Fact, - & xyz2D0(1,ia,ib-2,ic,id,Ind4(n)),1, - & xyz2D2(1,ia,ib,ic,id,Ind4(n),Ind3(n)),1) - End Do - End Do - End Do - End Do - End Do - End If - End If - End If -* Cross Term center 2 and 3 -* - If (IfG(2).and.IfG(3)) Then - Call ExpX(Temp ,mZeta,mEta,Beta,Sqrt(Two)) - Call Exp_2(Scrtch2,nRys,nT,Temp,Sqrt(Two)) - Call ExpY(Temp ,mZeta,mEta,Gamma,Sqrt(Two)) - Call Exp_2(Scrtch,nRys,nT,Temp,Sqrt(Two)) - nVec=0 - If (ifHss(3,1,2,1)) Then - mx=mx+1 - nVec = nVec + 1 - Ind1(nvec)=mx - Ind2(nVec)=1 - Index2(1,3,2)=mx - Index4(1,mx,1)=3 - Index4(2,mx,1)=2 - End If - If (ifHss(3,2,2,2)) Then - my=my+1 - nVec = nVec + 1 - Ind1(nvec)=my - Ind2(nVec)=2 - Index2(2,3,2)=my - Index4(1,my,2)=3 - Index4(2,my,2)=2 - End If - If (ifHss(3,3,2,3)) Then - mz=mz+1 - nVec = nVec + 1 - Ind1(nvec)=mz - Ind2(nVec)=3 - Index2(3,3,2)=mz - Index4(1,mz,3)=3 - Index4(2,mz,3)=2 - End If - Do i=nVec+1,3 - Ind1(i)=0 - End Do - If (nvec.ne.0) Then - - Do n=1,nvec - Do id = 0, ld - Do ic = 0, lc - Do ib = 0, lb - Do ia = 0, la - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & Scrtch(iVec) * Scrtch2(iVec)* - & xyz2D0(iVec,ia,ib+1,ic+1,id,Ind2(n)) - End Do - End Do - End Do - End Do - End Do - End Do - If (lb.ge.1) Then - Do n=1,nvec - Do id = 0, ld - Do ic = 0, lc - rb=Zero - Do ib=1,lb - rb=rb+One - Do ia=0,la - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) - - & rb * Scrtch(iVec)* - & xyz2D0(iVec,ia,ib-1,ic+1,id,Ind2(n)) - End DO - End DO - End DO - End DO - End DO - End DO - End If - If (lc.ge.1) Then - Do n=1,nvec - Do id = 0, ld - rc=Zero - Do ic = 1, lc - rc=rc+One - Do ib=0,lb - Do ia=0,la - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) - - & rc * Scrtch2(iVec)* - & xyz2D0(iVec,ia,ib+1,ic-1,id,Ind2(n)) - End Do - End Do - End Do - End Do - End Do - End Do - End If - If ((lb.ge.1).and.(lc.ge.1)) Then - Do n=1,nvec - Do id = 0, ld - rc=Zero - Do ic = 1, lc - rc=rc+One - rb=Zero - Do ib=1,lb - rb=rb+One - Fact=rb*rc - Do ia=0,la - Call DaxPy_inline(nRys*nT,Fact, - & xyz2D0(1,ia,ib-1,ic-1,id,Ind2(n)),1, - & xyz2D2(1,ia,ib,ic,id,Ind2(n),Ind1(n)),1) - End Do - End Do - End Do - End Do - End Do - End If - End If - End If -* -* -* Differentiate with respect to the third center -* - If (IfG(3)) Then - Call ExpY(Temp ,mZeta,mEta,Gamma,Sqrt(Two)) - Call Exp_2(Scrtch,nRys,nT,Temp,Sqrt(Two)) - nvec=0 - If (IfGrad(1,3)) Then - nx = nx + 1 - nVec = nVec + 1 - Ind1(nVec) = nx - Ind2(nVec) = 1 - Index1(1,3) = nx - Index3(nx,1)=3 - End If - If (IfGrad(2,3)) Then - ny = ny + 1 - nVec = nVec + 1 - Ind1(nVec) = ny - Ind2(nVec) = 2 - Index1(2,3) = ny - Index3(ny,2)=3 - End If - If (IfGrad(3,3)) Then - nz = nz + 1 - nVec = nVec + 1 - Ind1(nVec) = nz - Ind2(nVec) = 3 - Index1(3,3) = nz - Index3(nz,3)=3 - End If - Do i=nvec+1,3 - Ind1(i)=0 - End Do -* - mvec=0 - If (IfHss(3,1,3,1)) Then - mx=mx+1 - mvec=mvec+1 - Ind3(mVec) = mx - Ind4(mVec) = 1 - Index2(1,3,3) = mx - Index4(1,mx,1)=3 - Index4(2,mx,1)=3 - End If - If (IfHss(3,2,3,2)) Then - my=my+1 - mvec=mvec+1 - Ind3(mVec) = my - Ind4(mVec) = 2 - Index2(2,3,3) = my - Index4(1,my,2)=3 - Index4(2,my,2)=3 - End If - If (IfHss(3,3,3,3)) Then - mz=mz+1 - mvec=mvec+1 - Ind3(mVec) = mz - Ind4(mVec) = 3 - Index2(3,3,3) = mz - Index4(1,mz,3)=3 - Index4(2,mz,3)=3 - End If - Do i=mvec+1,3 - Ind3(i)=0 - End Do - nvecx=max(nvec,mvec) - If (nVecx.ne.0) Then - Do n=1,nvec - Do id = 0, ld - rc=-One - Do ic = 0, lc - rc=rc+Two - Do ib=0,lb - Do ia = 0, la - Do iVec = 1, nRys*nT - xyz2D1(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic+1,id,Ind2(n)) - End Do - End Do - End Do - End Do - End Do - End Do - Do n=1,mvec - Do id = 0, ld - rc=-One - Do ic = 0, lc - rc=rc+Two - Do ib=0,lb - Do ia = 0, la - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind4(n),Ind3(n))= - & Scrtch(iVec)**2* - & xyz2D0(iVec,ia,ib,ic+2,id,Ind4(n))- - & Rc* Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic,id,Ind4(n)) - End Do - End Do - End Do - End Do - End Do - End Do - - If (lc.ge.1) Then - Do n=1,nvec - Do id=0,ld - rc=Zero - Do ic=1,lc - rc=rc+One - Do ib=0,lb - Do ia=0,la - Call DaXpY_inline(nRys*nT,-rc, - & xyz2D0(1,ia,ib,ic-1,id,Ind2(n)),1, - & xyz2D1(1,ia,ib,ic,id,Ind2(n),Ind1(n)),1) - End Do - End Do - End Do - End Do - End Do - End If - If (lc.ge.2) Then - Do n=1,mvec - Do id=0,ld - rc=One - Do ic=2,lc - rc=rc+One - Fact=rc*rc-rc - Do ib=0,lb - Do ia=0,la - Call DaXpY_inline(nt*nrys,Fact, - & xyz2D0(1,ia,ib,ic-2,id,Ind4(n)),1, - & xyz2D2(1,ia,ib,ic,id,Ind4(n),Ind3(n)) ,1) - End Do - End Do - End Do - End Do - End Do - End If - End If - End If -* -* Cross term 1 3 -* - If (IfG(1).and.IfG(3)) Then - Call ExpX(Temp ,mZeta,mEta,Alpha,Sqrt(Two)) - Call Exp_2(Scrtch2,nRys,nT,Temp,Sqrt(Two)) - Call ExpY(Temp ,mZeta,mEta,Gamma,Sqrt(Two)) - Call Exp_2(Scrtch,nRys,nT,Temp,Sqrt(Two)) - nVec = 0 - If (ifHss(3,1,1,1)) Then - mx=mx+1 - nVec = nVec + 1 - Ind1(nvec)=mx - Ind2(nVec)=1 - Index4(1,mx,1)=3 - Index4(2,mx,1)=1 - Index2(1,3,1)=mx - End If - If (ifHss(3,2,1,2)) Then - my=my+1 - nVec = nVec + 1 - Ind1(nvec)=my - Ind2(nVec)=2 - Index4(1,my,2)=3 - Index4(2,my,2)=1 - Index2(2,3,1)=my - End If - If (ifHss(3,3,1,3)) Then - mz=mz+1 - nVec = nVec + 1 - Ind1(nvec)=mz - Ind2(nVec)=3 - Index4(1,mz,3)=3 - Index4(2,mz,3)=1 - Index2(3,3,1)=mz - End If - Do i=nVec+1,3 - Ind1(i)=0 - End Do - If (nVec.ne.0) Then - Do n=1,nvec - Do id = 0, ld - Do ic = 0, lc - Do ib = 0, lb - Do ia = 0, la - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & Scrtch(iVec) * Scrtch2(iVec)* - & xyz2D0(iVec,ia+1,ib,ic+1,id,Ind2(n)) - End Do - End Do - End Do - End Do - End Do - End Do - If (la.ge.1) Then - Do n=1,nvec - Do id = 0, ld - Do ic = 0, lc - Do ib=0,lb - ra=Zero - Do ia=1,la - ra=ra+One - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) - - & ra * Scrtch(iVec)* - & xyz2D0(iVec,ia-1,ib,ic+1,id,Ind2(n)) - End Do - End Do - End Do - End Do - End Do - End Do - End If - If (lc.ge.1) Then - Do n=1,nVec - Do id = 0, ld - rc=Zero - Do ic = 1, lc - rc=rc+One - Do ib=0,lb - Do ia=0,la - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) - - & rc * Scrtch2(iVec)* - & xyz2D0(iVec,ia+1,ib,ic-1,id,Ind2(n)) - End Do - End Do - End Do - End Do - End Do - End Do - End If - If ((la.ge.1).and.(lc.ge.1)) Then - Do n=1,nvec - Do id = 0, ld - rc=Zero - Do ic = 1, lc - rc=rc+One - Do ib=0,lb - ra=Zero - Do ia=1,la - ra=ra+One - Fact=rc*ra - Call DaXpy_inline(nt*nrys,Fact, - & xyz2D0(1,ia-1,ib,ic-1,id,Ind2(n)),1, - & xyz2D2(1,ia,ib,ic,id,Ind2(n),Ind1(n)) ,1) - End Do - End Do - End Do - End Do - End Do - End If - End If - End If -* 1 4 - - If (IfG(4)) Then - Call ExpY(Temp ,mZeta,mEta,Delta,Sqrt(Two)) - Call Exp_2(Scrtch,nRys,nT,Temp,Sqrt(Two)) - If (IfG(1)) Then - Call ExpX(Temp ,mZeta,mEta,Alpha,Sqrt(Two)) - Call Exp_2(Scrtch2,nRys,nT,Temp,Sqrt(Two)) - nVec=0 - If (ifHss(4,1,1,1)) Then - mx=mx+1 - nVec = nVec + 1 - Ind1(nvec)=mx - Ind2(nVec)=1 - Index2(1,4,1)=mx - Index4(1,mx,1)=4 - Index4(2,mx,1)=1 - End If - If (ifHss(4,2,1,2)) Then - my=my+1 - nVec = nVec + 1 - Ind1(nvec)=my - Ind2(nVec)=2 - Index2(2,4,1)=my - Index4(1,my,2)=4 - Index4(2,my,2)=1 - End If - If (ifHss(4,3,1,3)) Then - mz=mz+1 - nVec = nVec + 1 - Ind1(nvec)=mz - Ind2(nVec)=3 - Index2(3,4,1)=mz - Index4(1,mz,3)=4 - Index4(2,mz,3)=1 - End If - Do i=nVec+1,3 - Ind1(i)=0 - End Do -* - If (nVec.ne.0) Then -* - Do n=1,nvec - Do id = 0, ld - Do ic = 0, lc - Do ib = 0, lb - Do ia = 0, la - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & Scrtch(iVec) * Scrtch2(iVec)* - & xyz2D0(iVec,ia+1,ib,ic,id+1,Ind2(n)) - End Do - End Do - End Do - End Do - End Do - End Do - - If (la.ge.1) Then - Do n=1,nvec - Do id = 0, ld - Do ic = 0, lc - Do ib=0,lb - ra=Zero - Do ia=1,la - ra=ra+One - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) - - & ra * Scrtch(iVec)* - & xyz2D0(iVec,ia-1,ib,ic,id+1,Ind2(n)) - End Do - End Do - End Do - End Do - End Do - End Do - End If - - - If (ld.ge.1) Then - Do n=1,nvec - rd=Zero - Do id = 1, ld - rd=rd+One - Do ic = 0, lc - Do ib=0,lb - Do ia=0,la - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) - - & rd * Scrtch2(iVec)* - & xyz2D0(iVec,ia+1,ib,ic,id-1,Ind2(n)) - End Do - End Do - End Do - End Do - End Do - End Do - End If - If ((la.ge.1).and.(ld.ge.1)) Then - Do n=1,nvec - rd=Zero - Do id = 1, ld - rd=rd+One - Do ic = 0, lc - Do ib=0,lb - ra=Zero - Do ia=1,la - ra=ra+One - Fact=rd*ra - Call DaxPy_inline( nRys*nT,Fact, - & xyz2D0(1,ia-1,ib,ic,id-1,Ind2(n)),1, - & xyz2D2(1,ia,ib,ic,id,Ind2(n),Ind1(n)),1) - End Do - End Do - End Do - End Do - End Do - End If - End If - End If -* -* Cross terms between 2 4 -* - If (IfG(2).and.Ifg(4)) Then - Call ExpX(Temp ,mZeta,mEta,Beta,Sqrt(Two)) - Call Exp_2(Scrtch2,nRys,nT,Temp,Sqrt(Two)) - nVec=0 - If (ifHss(4,1,2,1)) Then - mx=mx+1 - nVec = nVec + 1 - Ind1(nvec)=mx - Ind2(nVec)=1 - Index2(1,4,2)=mx - Index4(1,mx,1)=4 - Index4(2,mx,1)=2 - End If - If (ifHss(4,2,2,2)) Then - my=my+1 - nVec = nVec + 1 - Ind1(nvec)=my - Ind2(nVec)=2 - Index2(2,4,2)=my - Index4(1,my,2)=4 - Index4(2,my,2)=2 - End If - If (ifHss(4,3,2,3)) Then - mz=mz+1 - nVec = nVec + 1 - Ind1(nvec)=mz - Ind2(nVec)=3 - Index2(3,4,2)=mz - Index4(1,mz,3)=4 - Index4(2,mz,3)=2 - End If - Do i=nVec+1,3 - Ind1(i)=0 - End Do -* - If (nvec.ne.0) Then -* - - Do n=1,nvec - Do id = 0, ld - Do ic = 0, lc - Do ib = 0, lb - Do ia = 0, la - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & Scrtch(iVec) * Scrtch2(iVec)* - & xyz2D0(iVec,ia,ib+1,ic,id+1,Ind2(n)) - End Do - End Do - End Do - End Do - End Do - End Do - - If (lb.ge.1) Then - Do n=1,nvec - Do id = 0, ld - Do ic = 0, lc - rb=Zero - Do ib=1,lb - rb=rb+One - Do ia=0,la - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) - - & rb * Scrtch(iVec)* - & xyz2D0(iVec,ia,ib-1,ic,id+1,Ind2(n)) - End Do - End Do - End Do - End Do - End Do - End Do - End If - - - If (ld.ge.1) Then - Do n=1,nvec - rd=Zero - Do id = 1, ld - rd=rd+One - Do ic = 0, lc - Do ib=0,lb - Do ia=0,la - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) - - & rd * Scrtch2(iVec)* - & xyz2D0(iVec,ia,ib+1,ic,id-1,Ind2(n)) - End do - End do - End do - End do - End do - End do - End If - If ((lb.ge.1).and.(ld.ge.1)) Then - Do n=1,nvec - rd=Zero - Do id = 1, ld - rd=rd+One - Do ic = 0, lc - rb=Zero - Do ib=1,lb - rb=rb+One - Do ia=0,la - Fact=rb*rd - Call DaxPy_inline(nt*nrys,Fact, - & xyz2D0(1,ia,ib-1,ic,id-1,Ind2(n)),1, - & xyz2D2(1,ia,ib,ic,id,Ind2(n),Ind1(n)),1) - End Do - End Do - End Do - End Do - End Do - End If - End If - End If -* -* Cross Term 3 4 -* - If (IfG(3).and.IfG(4)) Then - Call ExpY(Temp ,mZeta,mEta,Gamma,Sqrt(Two)) - Call Exp_2(Scrtch2,nRys,nT,Temp,Sqrt(Two)) - nVec=0 - If (ifHss(4,1,3,1)) Then - mx=mx+1 - nVec = nVec + 1 - Ind1(nvec)=mx - Ind2(nVec)=1 - Index2(1,4,3)=mx - Index4(1,mx,1)=4 - Index4(2,mx,1)=3 - End If - If (ifHss(4,2,3,2)) Then - my=my+1 - nVec = nVec + 1 - Ind1(nvec)=my - Ind2(nVec)=2 - Index2(2,4,3)=my - Index4(1,my,2)=4 - Index4(2,my,2)=3 - - End If - If (ifHss(4,3,3,3)) Then - mz=mz+1 - nVec = nVec + 1 - Ind1(nvec)=mz - Ind2(nVec)=3 - Index2(3,4,3)=mz - Index4(1,mz,3)=4 - Index4(2,mz,3)=3 - End If - Do i=nVec+1,3 - Ind1(i)=0 - End Do -* - If (nvec.ne.0) Then -* - Do n=1,nvec - Do id = 0, ld - Do ic = 0, lc - Do ib = 0, lb - Do ia = 0, la - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & Scrtch(iVec) * Scrtch2(iVec)* - & xyz2D0(iVec,ia,ib,ic+1,id+1,Ind2(n)) - End Do - End Do - End Do - End Do - End Do - End Do - - If (lc.ge.1) Then - Do n=1,nvec - Do id = 0, ld - rc=Zero - Do ic = 1, lc - rc=rc+One - Do ib=0,lb - Do ia=0,la - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) - - & rc * Scrtch(iVec)* - & xyz2D0(iVec,ia,ib,ic-1,id+1,Ind2(n)) - End Do - End Do - End Do - End Do - End Do - End Do - End If - If (ld.ge.1) Then - Do n=1,nvec - rd=Zero - Do id = 1, ld - rd=rd+One - Do ic = 0, lc - Do ib=0,lb - Do ia=0,la - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & xyz2D2(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) - - & rd * Scrtch2(iVec)* - & xyz2D0(iVec,ia,ib,ic+1,id-1,Ind2(n)) - End DO - End DO - End DO - End DO - End DO - End DO - End If - If ((lc.ge.1).and.(ld.ge.1)) Then - Do n=1,nvec - rd=Zero - Do id = 1, ld - rd=rd+One - rc=Zero - Do ic = 1, lc - rc=rc+One - Do ib=0,lb - Do ia=0,la - Fact=rc*rd - Call DaxPy_inline(nt*nRys,fact, - & xyz2D0(1,ia,ib,ic-1,id-1,Ind2(n)),1, - & xyz2D2(1,ia,ib,ic,id,Ind2(n),Ind1(n)),1) - End Do - End Do - End Do - End Do - End Do - End If - End If - End If -* -* Differentiate with respect to the fourth center -* - nvec=0 - If (IfGrad(1,4)) Then - nx = nx + 1 - nVec = nVec + 1 - Ind1(nVec) = nx - Ind2(nVec) = 1 - Index1(1,4) = nx - Index3(nx,1)=4 - End If - If (IfGrad(2,4)) Then - ny = ny + 1 - nVec = nVec + 1 - Ind1(nVec) = ny - Ind2(nVec) = 2 - Index1(2,4) = ny - Index3(ny,2)=4 - End If - If (IfGrad(3,4)) Then - nz = nz + 1 - nVec = nVec + 1 - Ind1(nVec) = nz - Ind2(nVec) = 3 - Index1(3,4) = nz - Index3(nz,3)=4 - End If - Do i=nvec+1,3 - Ind1(i)=0 - End Do -* - mvec=0 - If (IfHss(4,1,4,1)) Then - mx=mx+1 - mvec=mvec+1 - Ind3(mVec) = mx - Ind4(mVec) = 1 - Index2(1,4,4) = mx - Index4(1,mx,1)=4 - Index4(2,mx,1)=4 - End If - If (IfHss(4,2,4,2)) Then - my=my+1 - mvec=mvec+1 - Ind3(mVec) = my - Ind4(mVec) = 2 - Index2(2,4,4) = my - Index4(1,my,2)=4 - Index4(2,my,2)=4 - End If - If (IfHss(4,3,4,3)) Then - mz=mz+1 - mvec=mvec+1 - Ind3(mVec) = mz - Ind4(mVec) = 3 - Index2(3,4,4) = mz - Index4(1,mz,3)=4 - Index4(2,mz,3)=4 - End If - Do i=mvec+1,3 - Ind3(i)=0 - End Do - nvecx=max(nvec,mvec) -* - If (nVecx.ne.0) Then -* - Do n=1,nvec - rd=-One - Do id = 0, ld - rd=rd+Two - Do ic = 0, lc - Do ib=0,lb - Do ia = 0, la - Do iVec = 1, nRys*nT - xyz2D1(iVec,ia,ib,ic,id,Ind2(n),Ind1(n)) = - & Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic,id+1,Ind2(n)) - End do - End do - End do - End do - End do - End do - Do n=1,mvec - rd=-One - Do id = 0, ld - rd=rd+Two - Do ic = 0, lc - Do ib=0,lb - Do ia = 0, la - Do iVec = 1, nRys*nT - xyz2D2(iVec,ia,ib,ic,id,Ind4(n),Ind3(n))= - & Scrtch(iVec)**2* - & xyz2D0(iVec,ia,ib,ic,id+2,Ind4(n))- - & rd* Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic,id,Ind4(n)) - End do - End do - End do - End do - End do - End do - If (ld.ge.1) Then - Do n=1,nvec - rd=Zero - Do id=1,ld - rd=rd+One - Do ic=0,lc - Do ib=0,lb - Do ia=0,la - Call Daxpy_inline(nt*nrys,-rd, - & xyz2D0(1,ia,ib,ic,id-1,Ind2(n)),1, - & xyz2D1(1,ia,ib,ic,id,Ind2(n),Ind1(n)),1) - End DO - End DO - End DO - End DO - End DO - End If - If (ld.ge.2) Then - Do n=1,mvec - rd=One - Do id=2,ld - rd=rd+One - Fact=rd*rd-rd - Do ic=0,lc - Do ib=0,lb - Do ia=0,la - Call Daxpy_inline(nt*nrys,Fact, - & xyz2D0(1,ia,ib,ic,id-2,Ind4(n)),1, - & xyz2D2(1,ia,ib,ic,id,Ind4(n),Ind3(n)),1) - End Do - End Do - End Do - End Do - End Do - End If - - End If - End If -* -*-----Sum over common centers -* - Do iCent = 1, 3 - If (IfG(iCent)) Then - Do jCent = iCent+1, 4 - If (EQ(Coora(1,iCent),Coora(1,jCent))) Then - If (IfG(jCent)) Then - Do iCar = 1, 3 - i1 = Index2(iCar,iCent,iCent) - i2 = Index2(iCar,jCent,jCent) - i3 = Index2(iCar,jCent,iCent) - j4=Index1(iCar,jCent) - j5=Index1(iCar,iCent) - If (IfHss(jCent,iCar,jCent,iCar).and. - & IfHss(iCent,iCar,iCent,iCar)) Then - Call DaXpY_inline( - & nRys*nT*(la+1)*(lb+1)*(lc+1)*(ld+1), - & One,xyz2D2(1,0,0,0,0,iCar,i2),1, - & xyz2D2(1,0,0,0,0,iCar,i1),1) - End If - If (IfHss(jCent,iCar,iCent,iCar).and. - & IfHss(iCent,iCar,iCent,iCar)) Then - Call DaXpY_inline( - & nRys*nT*(la+1)*(lb+1)*(lc+1)*(ld+1), - & Two,xyz2D2(1,0,0,0,0,iCar,i3),1, - & xyz2D2(1,0,0,0,0,iCar,i1),1) - End If - If ((j4.ne.0).and.(j5.ne.0).and. - & (ifgrad(iCar,iCent).and.ifgrad(iCar,jCent))) - & Call DaXpY_inline( - & nRys*nT*(la+1)*(lb+1)* - & (lc+1)*(ld+1), - & One,xyz2D1(1,0,0,0,0,iCar,j4),1, - & xyz2D1(1,0,0,0,0,iCar,j5),1) - Do kCent=1,4 - If (IfG(kCent)) Then - If ((kcent.ne.iCent).and.(kcent.ne.jcent)) - & Then - If (ifHss(kCent,iCar,jCent,iCar).or. - & ifHss(jCent,iCar,kCent,iCar)) Then - i4=Index2(iCar,Max(kCent,jCent), - & Min(jCent,kCent)) - i5=Index2(iCar,Max(kCent,iCent), - & Min(iCent,kCent)) - Call DaXpY_inline( - & nRys*nT*(la+1)*(lb+1)*(lc+1)*(ld+1), - & One,xyz2D2(1,0,0,0,0,iCar,i4),1, - & xyz2D2(1,0,0,0,0,iCar,i5),1) - End If - End If - End If - End Do ! kCent - End Do ! iCar -* - IfG(jCent)=.false. - Tr(jCent)=.false. - Do jCar=1,3 - IfGrad(jcar,jCent)=.false. - Do iIrrep=0,nIrrep-1 - IndGrd(jCar,jcent,iIrrep)=0 - End Do - Do kCent=1,4 - Do kCar=1,3 - IfHss(jCent,jCar,kCent,kCar)=.false. - IfHss(kCent,kCar,jCent,jCar)=.false. - Do iIrrep=0,nIrrep-1 - IndHss(jCent,jCar,kCent,kCar,iIrrep)=0 - IndHss(kCent,kCar,jCent,jCar,iIrrep)=0 - End Do - End Do - End Do - End Do -* - End If - End If ! end eq - End Do ! jCent - End If - End Do ! iCent -* - nh(1)=mx - nh(2)=my - nh(3)=mz - ng(1)=nx - ng(2)=ny - ng(3)=nz - - Return - End - Subroutine Daxpy_inline(nt,r,A,inca,B,incB) - Implicit Real*8 (A-H,O-Z) - Real*8 A(*),B(*) - Do i=1,nt - B(i)=B(i)+r*A(i) - end do - return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(inca) - Call Unused_integer(incB) - End If - end diff -Nru openmolcas-22.02/src/rys_util/rs2dgh.F90 openmolcas-22.10/src/rys_util/rs2dgh.F90 --- openmolcas-22.02/src/rys_util/rs2dgh.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rs2dgh.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,1196 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1995, Roland Lindh * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine Rs2Dgh(xyz2D0,nT,nRys,la,lb,lc,ld,xyz2D1,xyz2D2,IfHss,IndHss,IfGrad,IndGrd,IfG,Coora,Alpha,Beta,Gmma,Delta,nZeta,nEta, & + Scrtch,Scrtch2,Temp,Index1,Index2,Index3,Index4,ng,nh,ExpX,ExpY,mZeta,mEta,nIrrep,Tr) +!*********************************************************************** +! * +! Object:To compute the gradients and the Hessians of the 2D-integrals.* +! * +! Author: Anders Bernhardsson & Roland Lindh, * +! Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! Februar '95 * +!*********************************************************************** + +use Constants, only: Zero, One, Two +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nT, nRys, la, lb, lc, ld, nZeta, nEta, mZeta, mEta, nIrrep +real(kind=wp), intent(in) :: xyz2D0(nRys*nT,0:la+2,0:lb+2,0:lc+2,0:ld+2,3), Coora(3,4), Alpha(nZeta), Beta(nZeta), Gmma(nEta), & + Delta(nEta) +real(kind=wp), intent(out) :: xyz2D1(nRys*nT,0:la,0:lb,0:lc,0:ld,3,3), xyz2D2(nRys*nT,0:la,0:lb,0:lc,0:ld,3,6), Scrtch(nRys*nT), & + Scrtch2(nRys*nT), Temp(nT) +logical(kind=iwp), intent(inout) :: IfHss(4,3,4,3), IfGrad(3,4), IfG(4), Tr(4) +integer(kind=iwp), intent(inout) :: IndHss(4,3,4,3,0:nIrrep-1), IndGrd(3,4,0:nIrrep-1) +integer(kind=iwp), intent(out) :: Index1(3,4), Index2(3,4,4), Index3(3,3), Index4(2,6,3), ng(3), nh(3) +external :: ExpX, ExpY +integer(kind=iwp) :: i1, i2, i3, i4, i5, ia, ib, ic, iCar, iCent, id, Ind1(3), Ind2(3), Ind3(3), Ind4(3), j4, j5, jCent, kCent, & + mVec, mx, my, mz, n, nVec, nvecx, nx, ny, nz +real(kind=wp) :: Fact, ra, rb, rc, rd +logical(kind=iwp), external :: EQ + +nx = 0 +ny = 0 +nz = 0 +mx = 0 +my = 0 +mz = 0 +Index1(:,:) = 0 +Index2(:,:,:) = 0 + +! Differentiate with respect to the first center + +if (IfG(1)) then + call ExpX(Temp,mZeta,mEta,Alpha,sqrt(Two)) + call Exp_2(Scrtch,nRys,nT,Temp,sqrt(Two)) + nVec = 0 + if (IfGrad(1,1)) then + nx = nx+1 + nVec = nVec+1 + Ind1(nVec) = nx + Ind2(nVec) = 1 + Index1(1,1) = nx + Index3(nx,1) = 1 + end if + if (IfGrad(2,1)) then + ny = ny+1 + nVec = nVec+1 + Ind1(nVec) = ny + Ind2(nVec) = 2 + Index1(2,1) = ny + Index3(ny,2) = 1 + end if + if (IfGrad(3,1)) then + nz = nz+1 + nVec = nVec+1 + Ind1(nVec) = nz + Ind2(nVec) = 3 + Index1(3,1) = nz + Index3(nz,3) = 1 + end if + Ind1(nVec+1:) = 0 + + mVec = 0 + if (IfHss(1,1,1,1)) then + mx = mx+1 + mVec = mVec+1 + Ind3(mVec) = mx + Ind4(mVec) = 1 + Index2(1,1,1) = mx + Index4(1,mx,1) = 1 + Index4(2,mx,1) = 1 + end if + if (IfHss(1,2,1,2)) then + my = my+1 + mVec = mVec+1 + Ind3(mVec) = my + Ind4(mVec) = 2 + Index2(2,1,1) = my + Index4(1,my,2) = 1 + Index4(2,my,2) = 1 + end if + if (IfHss(1,3,1,3)) then + mz = mz+1 + mVec = mVec+1 + Ind3(mVec) = mz + Ind4(mVec) = 3 + Index2(3,1,1) = mz + Index4(1,mz,3) = 1 + Index4(2,mz,3) = 1 + end if + Ind3(mVec+1:) = 0 + nvecx = max(nVec,mVec) + if (nVecx /= 0) then + + ! Here we go with center 1 + + do n=1,nVec + do id=0,ld + do ic=0,lc + do ib=0,lb + ra = -One + do ia=0,la + ra = ra+Two + xyz2D1(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = Scrtch(:)*xyz2D0(:,ia+1,ib,ic,id,Ind2(n)) + end do + end do + end do + end do + end do + do n=1,mVec + do id=0,ld + do ic=0,lc + do ib=0,lb + ra = -One + do ia=0,la + ra = ra+Two + xyz2D2(:,ia,ib,ic,id,Ind4(n),Ind3(n)) = Scrtch(:)**2*xyz2D0(:,ia+2,ib,ic,id,Ind4(n))- & + ra*Scrtch(:)*xyz2D0(:,ia,ib,ic,id,Ind4(n)) + end do + end do + end do + end do + end do + if (la >= 1) then + do n=1,nVec + do id=0,ld + do ic=0,lc + do ib=0,lb + ra = Zero + do ia=1,la + ra = ra+One + xyz2D1(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = xyz2D1(:,ia,ib,ic,id,Ind2(n),Ind1(n))-ra*xyz2D0(:,ia-1,ib,ic,id,Ind2(n)) + end do + end do + end do + end do + end do + end if + if (la >= 2) then + do n=1,mVec + do id=0,ld + do ic=0,lc + do ib=0,lb + ra = One + do ia=2,la + ra = ra+One + Fact = ra*ra-ra + xyz2D2(:,ia,ib,ic,id,Ind4(n),Ind3(n)) = xyz2D2(:,ia,ib,ic,id,Ind4(n),Ind3(n))+Fact*xyz2D0(:,ia-2,ib,ic,id,Ind4(n)) + end do + end do + end do + end do + end do + end if + end if +end if + +! Cross term center 1 and center 2 +if (IfG(2)) then + call ExpX(Temp,mZeta,mEta,Beta,sqrt(Two)) + call Exp_2(Scrtch2,nRys,nT,Temp,sqrt(Two)) +end if +if (IfG(2) .and. IfG(1)) then + nVec = 0 + if (IfHss(2,1,1,1)) then + mx = mx+1 + nVec = nVec+1 + Ind1(nVec) = mx + Ind2(nVec) = 1 + Index2(1,2,1) = mx + Index4(1,mx,1) = 2 + Index4(2,mx,1) = 1 + end if + if (IfHss(2,2,1,2)) then + my = my+1 + nVec = nVec+1 + Ind1(nVec) = my + Ind2(nVec) = 2 + Index2(2,2,1) = my + Index4(1,my,2) = 2 + Index4(2,my,2) = 1 + end if + if (IfHss(2,3,1,3)) then + mz = mz+1 + nVec = nVec+1 + Ind1(nVec) = mz + Ind2(nVec) = 3 + Index2(3,2,1) = mz + Index4(1,mz,3) = 2 + Index4(2,mz,3) = 1 + end if + Ind1(nVec+1:) = 0 + if (nVec /= 0) then + do n=1,nVec + do id=0,ld + do ic=0,lc + do ib=0,lb + do ia=0,la + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = Scrtch(:)*Scrtch2(:)*xyz2D0(:,ia+1,ib+1,ic,id,Ind2(n)) + end do + end do + end do + end do + end do + if (la >= 1) then + do n=1,nVec + do id=0,ld + do ic=0,lc + do ib=0,lb + ra = Zero + do ia=1,la + ra = ra+One + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n))- & + ra*Scrtch2(:)*xyz2D0(:,ia-1,ib+1,ic,id,Ind2(n)) + end do + end do + end do + end do + end do + end if + if (lb >= 1) then + do n=1,nVec + do id=0,ld + do ic=0,lc + rb = Zero + do ib=1,lb + rb = rb+One + do ia=0,la + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n))- & + rb*Scrtch(:)*xyz2D0(:,ia+1,ib-1,ic,id,Ind2(n)) + end do + end do + end do + end do + end do + end if + if ((la >= 1) .and. (lb >= 1)) then + do n=1,nVec + do id=0,ld + do ic=0,lc + rb = Zero + do ib=1,lb + rb = rb+One + ra = Zero + do ia=1,la + ra = ra+One + Fact = ra*rb + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n))+Fact*xyz2D0(:,ia-1,ib-1,ic,id,Ind2(n)) + end do + end do + end do + end do + end do + end if + end if +end if + +! Differentiate with respect to the second center + +if (IfG(2)) then + call ExpX(Temp,mZeta,mEta,Beta,sqrt(Two)) + call Exp_2(Scrtch2,nRys,nT,Temp,sqrt(Two)) + nVec = 0 + if (IfGrad(1,2)) then + nx = nx+1 + nVec = nVec+1 + Ind1(nVec) = nx + Ind2(nVec) = 1 + Index1(1,2) = nx + Index3(nx,1) = 2 + end if + if (IfGrad(2,2)) then + ny = ny+1 + nVec = nVec+1 + Ind1(nVec) = ny + Ind2(nVec) = 2 + Index3(ny,2) = 2 + Index1(2,2) = ny + end if + if (IfGrad(3,2)) then + nz = nz+1 + nVec = nVec+1 + Ind1(nVec) = nz + Ind2(nVec) = 3 + Index1(3,2) = nz + Index3(nz,3) = 2 + end if + Ind1(nVec+1:) = 0 + + mVec = 0 + if (IfHss(2,1,2,1)) then + mx = mx+1 + mVec = mVec+1 + Ind3(mVec) = mx + Ind4(mVec) = 1 + Index2(1,2,2) = mx + Index4(1,mx,1) = 2 + Index4(2,mx,1) = 2 + end if + if (IfHss(2,2,2,2)) then + my = my+1 + mVec = mVec+1 + Ind3(mVec) = my + Ind4(mVec) = 2 + Index2(2,2,2) = my + Index4(1,my,2) = 2 + Index4(2,my,2) = 2 + end if + if (IfHss(2,3,2,3)) then + mz = mz+1 + mVec = mVec+1 + Ind3(mVec) = mz + Ind4(mVec) = 3 + Index2(3,2,2) = mz + Index4(1,mz,3) = 2 + Index4(2,mz,3) = 2 + end if + Ind3(mVec+1:) = 0 + nvecx = max(nVec,mVec) + if (nVecx /= 0) then + + do n=1,nVec + do id=0,ld + do ic=0,lc + rb = -One + do ib=0,lb + rb = rb+Two + do ia=0,la + xyz2D1(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = Scrtch2(:)*xyz2D0(:,ia,ib+1,ic,id,Ind2(n)) + end do + end do + end do + end do + end do + do n=1,mVec + do id=0,ld + do ic=0,lc + rb = -One + do ib=0,lb + rb = rb+Two + do ia=0,la + xyz2D2(:,ia,ib,ic,id,Ind4(n),Ind3(n)) = Scrtch2(:)**2*xyz2D0(:,ia,ib+2,ic,id,Ind4(n))- & + rb*Scrtch2(:)*xyz2D0(:,ia,ib,ic,id,Ind4(n)) + end do + end do + end do + end do + end do + + if (lb >= 1) then + do n=1,nVec + do id=0,ld + do ic=0,lc + rb = Zero + do ib=1,lb + rb = rb+One + xyz2D1(:,:,ib,ic,id,Ind2(n),Ind1(n)) = xyz2D1(:,:,ib,ic,id,Ind2(n),Ind1(n))-rb*xyz2D0(:,0:la,ib-1,ic,id,Ind2(n)) + end do + end do + end do + end do + end if + if (lb >= 2) then + do n=1,mVec + do id=0,ld + do ic=0,lc + rb = One + do ib=2,lb + rb = rb+One + Fact = rb*rb-rb + xyz2D2(:,:,ib,ic,id,Ind4(n),Ind3(n)) = xyz2D2(:,:,ib,ic,id,Ind4(n),Ind3(n))+Fact*xyz2D0(:,0:la,ib-2,ic,id,Ind4(n)) + end do + end do + end do + end do + end if + end if +end if + +! Cross Term center 2 and 3 + +if (IfG(2) .and. IfG(3)) then + call ExpX(Temp,mZeta,mEta,Beta,sqrt(Two)) + call Exp_2(Scrtch2,nRys,nT,Temp,sqrt(Two)) + call ExpY(Temp,mZeta,mEta,Gmma,sqrt(Two)) + call Exp_2(Scrtch,nRys,nT,Temp,sqrt(Two)) + nVec = 0 + if (IfHss(3,1,2,1)) then + mx = mx+1 + nVec = nVec+1 + Ind1(nVec) = mx + Ind2(nVec) = 1 + Index2(1,3,2) = mx + Index4(1,mx,1) = 3 + Index4(2,mx,1) = 2 + end if + if (IfHss(3,2,2,2)) then + my = my+1 + nVec = nVec+1 + Ind1(nVec) = my + Ind2(nVec) = 2 + Index2(2,3,2) = my + Index4(1,my,2) = 3 + Index4(2,my,2) = 2 + end if + if (IfHss(3,3,2,3)) then + mz = mz+1 + nVec = nVec+1 + Ind1(nVec) = mz + Ind2(nVec) = 3 + Index2(3,3,2) = mz + Index4(1,mz,3) = 3 + Index4(2,mz,3) = 2 + end if + Ind1(nVec+1:) = 0 + if (nVec /= 0) then + + do n=1,nVec + do id=0,ld + do ic=0,lc + do ib=0,lb + do ia=0,la + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = Scrtch(:)*Scrtch2(:)*xyz2D0(:,ia,ib+1,ic+1,id,Ind2(n)) + end do + end do + end do + end do + end do + if (lb >= 1) then + do n=1,nVec + do id=0,ld + do ic=0,lc + rb = Zero + do ib=1,lb + rb = rb+One + do ia=0,la + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n))- & + rb*Scrtch(:)*xyz2D0(:,ia,ib-1,ic+1,id,Ind2(n)) + end do + end do + end do + end do + end do + end if + if (lc >= 1) then + do n=1,nvec + do id=0,ld + rc = Zero + do ic=1,lc + rc = rc+One + do ib=0,lb + do ia=0,la + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n))- & + rc*Scrtch2(:)*xyz2D0(:,ia,ib+1,ic-1,id,Ind2(n)) + end do + end do + end do + end do + end do + end if + if ((lb >= 1) .and. (lc >= 1)) then + do n=1,nVec + do id=0,ld + rc = Zero + do ic=1,lc + rc = rc+One + rb = Zero + do ib=1,lb + rb = rb+One + Fact = rb*rc + xyz2D2(:,:,ib,ic,id,Ind2(n),Ind1(n)) = xyz2D2(:,:,ib,ic,id,Ind2(n),Ind1(n))+Fact*xyz2D0(:,0:la,ib-1,ic-1,id,Ind2(n)) + end do + end do + end do + end do + end if + end if +end if + +! Differentiate with respect to the third center + +if (IfG(3)) then + call ExpY(Temp,mZeta,mEta,Gmma,sqrt(Two)) + call Exp_2(Scrtch,nRys,nT,Temp,sqrt(Two)) + nVec = 0 + if (IfGrad(1,3)) then + nx = nx+1 + nVec = nVec+1 + Ind1(nVec) = nx + Ind2(nVec) = 1 + Index1(1,3) = nx + Index3(nx,1) = 3 + end if + if (IfGrad(2,3)) then + ny = ny+1 + nVec = nVec+1 + Ind1(nVec) = ny + Ind2(nVec) = 2 + Index1(2,3) = ny + Index3(ny,2) = 3 + end if + if (IfGrad(3,3)) then + nz = nz+1 + nVec = nVec+1 + Ind1(nVec) = nz + Ind2(nVec) = 3 + Index1(3,3) = nz + Index3(nz,3) = 3 + end if + Ind1(nVec+1:) = 0 + + mVec = 0 + if (IfHss(3,1,3,1)) then + mx = mx+1 + mVec = mVec+1 + Ind3(mVec) = mx + Ind4(mVec) = 1 + Index2(1,3,3) = mx + Index4(1,mx,1) = 3 + Index4(2,mx,1) = 3 + end if + if (IfHss(3,2,3,2)) then + my = my+1 + mVec = mVec+1 + Ind3(mVec) = my + Ind4(mVec) = 2 + Index2(2,3,3) = my + Index4(1,my,2) = 3 + Index4(2,my,2) = 3 + end if + if (IfHss(3,3,3,3)) then + mz = mz+1 + mVec = mVec+1 + Ind3(mVec) = mz + Ind4(mVec) = 3 + Index2(3,3,3) = mz + Index4(1,mz,3) = 3 + Index4(2,mz,3) = 3 + end if + Ind3(mVec+1:) = 0 + nvecx = max(nVec,mVec) + if (nVecx /= 0) then + do n=1,nVec + do id=0,ld + rc = -One + do ic=0,lc + rc = rc+Two + do ib=0,lb + do ia=0,la + xyz2D1(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = Scrtch(:)*xyz2D0(:,ia,ib,ic+1,id,Ind2(n)) + end do + end do + end do + end do + end do + do n=1,mVec + do id=0,ld + rc = -One + do ic=0,lc + rc = rc+Two + do ib=0,lb + do ia=0,la + xyz2D2(:,ia,ib,ic,id,Ind4(n),Ind3(n)) = Scrtch(:)**2*xyz2D0(:,ia,ib,ic+2,id,Ind4(n))- & + rc*Scrtch(:)*xyz2D0(:,ia,ib,ic,id,Ind4(n)) + end do + end do + end do + end do + end do + + if (lc >= 1) then + do n=1,nVec + do id=0,ld + rc = Zero + do ic=1,lc + rc = rc+One + xyz2D1(:,:,:,ic,id,Ind2(n),Ind1(n)) = xyz2D1(:,:,:,ic,id,Ind2(n),Ind1(n))-rc*xyz2D0(:,0:la,0:lb,ic-1,id,Ind2(n)) + end do + end do + end do + end if + if (lc >= 2) then + do n=1,mVec + do id=0,ld + rc = One + do ic=2,lc + rc = rc+One + Fact = rc*rc-rc + xyz2D2(:,:,:,ic,id,Ind4(n),Ind3(n)) = xyz2D2(:,:,:,ic,id,Ind4(n),Ind3(n))+Fact*xyz2D0(:,0:la,0:lb,ic-2,id,Ind4(n)) + end do + end do + end do + end if + end if +end if + +! Cross term 1 3 + +if (IfG(1) .and. IfG(3)) then + call ExpX(Temp,mZeta,mEta,Alpha,sqrt(Two)) + call Exp_2(Scrtch2,nRys,nT,Temp,sqrt(Two)) + call ExpY(Temp,mZeta,mEta,Gmma,sqrt(Two)) + call Exp_2(Scrtch,nRys,nT,Temp,sqrt(Two)) + nVec = 0 + if (IfHss(3,1,1,1)) then + mx = mx+1 + nVec = nVec+1 + Ind1(nVec) = mx + Ind2(nVec) = 1 + Index4(1,mx,1) = 3 + Index4(2,mx,1) = 1 + Index2(1,3,1) = mx + end if + if (IfHss(3,2,1,2)) then + my = my+1 + nVec = nVec+1 + Ind1(nVec) = my + Ind2(nVec) = 2 + Index4(1,my,2) = 3 + Index4(2,my,2) = 1 + Index2(2,3,1) = my + end if + if (IfHss(3,3,1,3)) then + mz = mz+1 + nVec = nVec+1 + Ind1(nVec) = mz + Ind2(nVec) = 3 + Index4(1,mz,3) = 3 + Index4(2,mz,3) = 1 + Index2(3,3,1) = mz + end if + Ind1(nVec+1:) = 0 + if (nVec /= 0) then + do n=1,nVec + do id=0,ld + do ic=0,lc + do ib=0,lb + do ia=0,la + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = Scrtch(:)*Scrtch2(:)*xyz2D0(:,ia+1,ib,ic+1,id,Ind2(n)) + end do + end do + end do + end do + end do + if (la >= 1) then + do n=1,nVec + do id=0,ld + do ic=0,lc + do ib=0,lb + ra = Zero + do ia=1,la + ra = ra+One + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n))- & + ra*Scrtch(:)*xyz2D0(:,ia-1,ib,ic+1,id,Ind2(n)) + end do + end do + end do + end do + end do + end if + if (lc >= 1) then + do n=1,nVec + do id=0,ld + rc = Zero + do ic=1,lc + rc = rc+One + do ib=0,lb + do ia=0,la + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n))- & + rc*Scrtch2(:)*xyz2D0(:,ia+1,ib,ic-1,id,Ind2(n)) + end do + end do + end do + end do + end do + end if + if ((la >= 1) .and. (lc >= 1)) then + do n=1,nVec + do id=0,ld + rc = Zero + do ic=1,lc + rc = rc+One + do ib=0,lb + ra = Zero + do ia=1,la + ra = ra+One + Fact = rc*ra + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n))+Fact*xyz2D0(:,ia-1,ib,ic-1,id,Ind2(n)) + end do + end do + end do + end do + end do + end if + end if +end if + +! 1 4 + +if (IfG(4)) then + call ExpY(Temp,mZeta,mEta,Delta,sqrt(Two)) + call Exp_2(Scrtch,nRys,nT,Temp,sqrt(Two)) + if (IfG(1)) then + call ExpX(Temp,mZeta,mEta,Alpha,sqrt(Two)) + call Exp_2(Scrtch2,nRys,nT,Temp,sqrt(Two)) + nVec = 0 + if (IfHss(4,1,1,1)) then + mx = mx+1 + nVec = nVec+1 + Ind1(nVec) = mx + Ind2(nVec) = 1 + Index2(1,4,1) = mx + Index4(1,mx,1) = 4 + Index4(2,mx,1) = 1 + end if + if (IfHss(4,2,1,2)) then + my = my+1 + nVec = nVec+1 + Ind1(nVec) = my + Ind2(nVec) = 2 + Index2(2,4,1) = my + Index4(1,my,2) = 4 + Index4(2,my,2) = 1 + end if + if (IfHss(4,3,1,3)) then + mz = mz+1 + nVec = nVec+1 + Ind1(nVec) = mz + Ind2(nVec) = 3 + Index2(3,4,1) = mz + Index4(1,mz,3) = 4 + Index4(2,mz,3) = 1 + end if + Ind1(nVec+1:) = 0 + + if (nVec /= 0) then + + do n=1,nVec + do id=0,ld + do ic=0,lc + do ib=0,lb + do ia=0,la + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = Scrtch(:)*Scrtch2(:)*xyz2D0(:,ia+1,ib,ic,id+1,Ind2(n)) + end do + end do + end do + end do + end do + + if (la >= 1) then + do n=1,nVec + do id=0,ld + do ic=0,lc + do ib=0,lb + ra = Zero + do ia=1,la + ra = ra+One + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n))- & + ra*Scrtch(:)*xyz2D0(:,ia-1,ib,ic,id+1,Ind2(n)) + end do + end do + end do + end do + end do + end if + + if (ld >= 1) then + do n=1,nVec + rd = Zero + do id=1,ld + rd = rd+One + do ic=0,lc + do ib=0,lb + do ia=0,la + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n))- & + rd*Scrtch2(:)*xyz2D0(:,ia+1,ib,ic,id-1,Ind2(n)) + end do + end do + end do + end do + end do + end if + if ((la >= 1) .and. (ld >= 1)) then + do n=1,nVec + rd = Zero + do id=1,ld + rd = rd+One + do ic=0,lc + do ib=0,lb + ra = Zero + do ia=1,la + ra = ra+One + Fact = rd*ra + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n))+ & + Fact*xyz2D0(:,ia-1,ib,ic,id-1,Ind2(n)) + end do + end do + end do + end do + end do + end if + end if + end if + + ! Cross terms between 2 4 + + if (IfG(2) .and. IfG(4)) then + call ExpX(Temp,mZeta,mEta,Beta,sqrt(Two)) + call Exp_2(Scrtch2,nRys,nT,Temp,sqrt(Two)) + nVec = 0 + if (IfHss(4,1,2,1)) then + mx = mx+1 + nVec = nVec+1 + Ind1(nVec) = mx + Ind2(nVec) = 1 + Index2(1,4,2) = mx + Index4(1,mx,1) = 4 + Index4(2,mx,1) = 2 + end if + if (IfHss(4,2,2,2)) then + my = my+1 + nVec = nVec+1 + Ind1(nVec) = my + Ind2(nVec) = 2 + Index2(2,4,2) = my + Index4(1,my,2) = 4 + Index4(2,my,2) = 2 + end if + if (IfHss(4,3,2,3)) then + mz = mz+1 + nVec = nVec+1 + Ind1(nVec) = mz + Ind2(nVec) = 3 + Index2(3,4,2) = mz + Index4(1,mz,3) = 4 + Index4(2,mz,3) = 2 + end if + Ind1(nVec+1:) = 0 + + if (nVec /= 0) then + + do n=1,nVec + do id=0,ld + do ic=0,lc + do ib=0,lb + do ia=0,la + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = Scrtch(:)*Scrtch2(:)*xyz2D0(:,ia,ib+1,ic,id+1,Ind2(n)) + end do + end do + end do + end do + end do + + if (lb >= 1) then + do n=1,nVec + do id=0,ld + do ic=0,lc + rb = Zero + do ib=1,lb + rb = rb+One + do ia=0,la + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n))- & + rb*Scrtch(:)*xyz2D0(:,ia,ib-1,ic,id+1,Ind2(n)) + end do + end do + end do + end do + end do + end if + + if (ld >= 1) then + do n=1,nVec + rd = Zero + do id=1,ld + rd = rd+One + do ic=0,lc + do ib=0,lb + do ia=0,la + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n))- & + rd*Scrtch2(:)*xyz2D0(:,ia,ib+1,ic,id-1,Ind2(n)) + end do + end do + end do + end do + end do + end if + if ((lb >= 1) .and. (ld >= 1)) then + do n=1,nVec + rd = Zero + do id=1,ld + rd = rd+One + do ic=0,lc + rb = Zero + do ib=1,lb + rb = rb+One + Fact = rb*rd + xyz2D2(:,:,ib,ic,id,Ind2(n),Ind1(n)) = xyz2D2(:,:,ib,ic,id,Ind2(n),Ind1(n))+Fact*xyz2D0(:,0:la,ib-1,ic,id-1,Ind2(n)) + end do + end do + end do + end do + end if + end if + end if + + ! Cross Term 3 4 + + if (IfG(3) .and. IfG(4)) then + call ExpY(Temp,mZeta,mEta,Gmma,sqrt(Two)) + call Exp_2(Scrtch2,nRys,nT,Temp,sqrt(Two)) + nVec = 0 + if (IfHss(4,1,3,1)) then + mx = mx+1 + nVec = nVec+1 + Ind1(nVec) = mx + Ind2(nVec) = 1 + Index2(1,4,3) = mx + Index4(1,mx,1) = 4 + Index4(2,mx,1) = 3 + end if + if (IfHss(4,2,3,2)) then + my = my+1 + nVec = nVec+1 + Ind1(nVec) = my + Ind2(nVec) = 2 + Index2(2,4,3) = my + Index4(1,my,2) = 4 + Index4(2,my,2) = 3 + + end if + if (IfHss(4,3,3,3)) then + mz = mz+1 + nVec = nVec+1 + Ind1(nVec) = mz + Ind2(nVec) = 3 + Index2(3,4,3) = mz + Index4(1,mz,3) = 4 + Index4(2,mz,3) = 3 + end if + Ind1(nVec+1:) = 0 + + if (nVec /= 0) then + + do n=1,nVec + do id=0,ld + do ic=0,lc + do ib=0,lb + do ia=0,la + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = Scrtch(:)*Scrtch2(:)*xyz2D0(:,ia,ib,ic+1,id+1,Ind2(n)) + end do + end do + end do + end do + end do + + if (lc >= 1) then + do n=1,nVec + do id=0,ld + rc = Zero + do ic=1,lc + rc = rc+One + do ib=0,lb + do ia=0,la + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n))- & + rc*Scrtch(:)*xyz2D0(:,ia,ib,ic-1,id+1,Ind2(n)) + end do + end do + end do + end do + end do + end if + if (ld >= 1) then + do n=1,nVec + rd = Zero + do id=1,ld + rd = rd+One + do ic=0,lc + do ib=0,lb + do ia=0,la + xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = xyz2D2(:,ia,ib,ic,id,Ind2(n),Ind1(n))- & + rd*Scrtch2(:)*xyz2D0(:,ia,ib,ic+1,id-1,Ind2(n)) + end do + end do + end do + end do + end do + end if + if ((lc >= 1) .and. (ld >= 1)) then + do n=1,nVec + rd = Zero + do id=1,ld + rd = rd+One + rc = Zero + do ic=1,lc + rc = rc+One + Fact = rc*rd + xyz2D2(:,:,:,ic,id,Ind2(n),Ind1(n)) = xyz2D2(:,:,:,ic,id,Ind2(n),Ind1(n))+Fact*xyz2D0(:,0:la,0:lb,ic-1,id-1,Ind2(n)) + end do + end do + end do + end if + end if + end if + + ! Differentiate with respect to the fourth center + + nVec = 0 + if (IfGrad(1,4)) then + nx = nx+1 + nVec = nVec+1 + Ind1(nVec) = nx + Ind2(nVec) = 1 + Index1(1,4) = nx + Index3(nx,1) = 4 + end if + if (IfGrad(2,4)) then + ny = ny+1 + nVec = nVec+1 + Ind1(nVec) = ny + Ind2(nVec) = 2 + Index1(2,4) = ny + Index3(ny,2) = 4 + end if + if (IfGrad(3,4)) then + nz = nz+1 + nVec = nVec+1 + Ind1(nVec) = nz + Ind2(nVec) = 3 + Index1(3,4) = nz + Index3(nz,3) = 4 + end if + Ind1(nVec+1:) = 0 + + mVec = 0 + if (IfHss(4,1,4,1)) then + mx = mx+1 + mVec = mVec+1 + Ind3(mVec) = mx + Ind4(mVec) = 1 + Index2(1,4,4) = mx + Index4(1,mx,1) = 4 + Index4(2,mx,1) = 4 + end if + if (IfHss(4,2,4,2)) then + my = my+1 + mVec = mVec+1 + Ind3(mVec) = my + Ind4(mVec) = 2 + Index2(2,4,4) = my + Index4(1,my,2) = 4 + Index4(2,my,2) = 4 + end if + if (IfHss(4,3,4,3)) then + mz = mz+1 + mVec = mVec+1 + Ind3(mVec) = mz + Ind4(mVec) = 3 + Index2(3,4,4) = mz + Index4(1,mz,3) = 4 + Index4(2,mz,3) = 4 + end if + Ind3(mVec+1:) = 0 + nvecx = max(nVec,mVec) + + if (nVecx /= 0) then + + do n=1,nVec + rd = -One + do id=0,ld + rd = rd+Two + do ic=0,lc + do ib=0,lb + do ia=0,la + xyz2D1(:,ia,ib,ic,id,Ind2(n),Ind1(n)) = Scrtch(:)*xyz2D0(:,ia,ib,ic,id+1,Ind2(n)) + end do + end do + end do + end do + end do + do n=1,mVec + rd = -One + do id=0,ld + rd = rd+Two + do ic=0,lc + do ib=0,lb + do ia=0,la + xyz2D2(:,ia,ib,ic,id,Ind4(n),Ind3(n)) = Scrtch(:)**2*xyz2D0(:,ia,ib,ic,id+2,Ind4(n))- & + rd*Scrtch(:)*xyz2D0(:,ia,ib,ic,id,Ind4(n)) + end do + end do + end do + end do + end do + if (ld >= 1) then + do n=1,nVec + rd = Zero + do id=1,ld + rd = rd+One + xyz2D1(:,:,:,:,id,Ind2(n),Ind1(n)) = xyz2D1(:,:,:,:,id,Ind2(n),Ind1(n))-rd*xyz2D0(:,0:la,0:lb,0:lc,id-1,Ind2(n)) + end do + end do + end if + if (ld >= 2) then + do n=1,mVec + rd = One + do id=2,ld + rd = rd+One + Fact = rd*rd-rd + xyz2D2(:,:,:,:,id,Ind4(n),Ind3(n)) = xyz2D2(:,:,:,:,id,Ind4(n),Ind3(n))+Fact*xyz2D0(:,0:la,0:lb,0:lc,id-2,Ind4(n)) + end do + end do + end if + + end if +end if + +! Sum over common centers + +do iCent=1,3 + if (IfG(iCent)) then + do jCent=iCent+1,4 + if (EQ(Coora(1,iCent),Coora(1,jCent))) then + if (IfG(jCent)) then + do iCar=1,3 + i1 = Index2(iCar,iCent,iCent) + i2 = Index2(iCar,jCent,jCent) + i3 = Index2(iCar,jCent,iCent) + j4 = Index1(iCar,jCent) + j5 = Index1(iCar,iCent) + if (IfHss(jCent,iCar,jCent,iCar) .and. IfHss(iCent,iCar,iCent,iCar)) & + xyz2D2(:,:,:,:,:,iCar,i1) = xyz2D2(:,:,:,:,:,iCar,i1)+xyz2D2(:,:,:,:,:,iCar,i2) + if (IfHss(jCent,iCar,iCent,iCar) .and. IfHss(iCent,iCar,iCent,iCar)) & + xyz2D2(:,:,:,:,:,iCar,i1) = xyz2D2(:,:,:,:,:,iCar,i1)+Two*xyz2D2(:,:,:,:,:,iCar,i3) + if ((j4 /= 0) .and. (j5 /= 0) .and. IfGrad(iCar,iCent) .and. IfGrad(iCar,jCent)) & + xyz2D1(:,:,:,:,:,iCar,j5) = xyz2D1(:,:,:,:,:,iCar,j5)+xyz2D1(:,:,:,:,:,iCar,j4) + do kCent=1,4 + if (IfG(kCent)) then + if ((kCent /= iCent) .and. (kCent /= jCent)) then + if (IfHss(kCent,iCar,jCent,iCar) .or. IfHss(jCent,iCar,kCent,iCar)) then + i4 = Index2(iCar,max(kCent,jCent),min(jCent,kCent)) + i5 = Index2(iCar,max(kCent,iCent),min(iCent,kCent)) + xyz2D2(:,:,:,:,:,iCar,i5) = xyz2D2(:,:,:,:,:,iCar,i5)+xyz2D2(:,:,:,:,:,iCar,i4) + end if + end if + end if + end do ! kCent + end do ! iCar + + IfG(jCent) = .false. + Tr(jCent) = .false. + IfGrad(:,jCent) = .false. + IndGrd(:,jCent,:) = 0 + IfHss(jCent,:,:,:) = .false. + IfHss(:,:,jCent,:) = .false. + IndHss(jCent,:,:,:,:) = 0 + IndHss(:,:,jCent,:,:) = 0 + + end if + end if ! end eq + end do ! jCent + end if +end do ! iCent + +nh(1) = mx +nh(2) = my +nh(3) = mz +ng(1) = nx +ng(2) = ny +ng(3) = nz + +return + +end subroutine Rs2Dgh diff -Nru openmolcas-22.02/src/rys_util/rs2dmm.f openmolcas-22.10/src/rys_util/rs2dmm.f --- openmolcas-22.02/src/rys_util/rs2dmm.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rs2dmm.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,196 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Rs2Dmm(xyz2D,nArg,lRys,nabMax,ncdMax,PAWP,QCWQ, - & B10,laa,B00,lac,B01,lcc, - & la,lb,lc,ld,IfHss,ifgrd) -************************************************************************ -* * -* Object: to compute the 2-dimensional integrals of the Rys * -* quadrature. The z components are assumed to be pre- * -* conditioned with the weights of the roots of the * -* Rys polynomial. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* Modified loop structure for RISC 1991 R. Lindh Dept. of Theoretical * -* Chemistry, University of Lund, Sweden. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -c#include "print.fh" - Real*8 xyz2D(nArg*lRys,3,0:nabMax,0:ncdMax), - & PAWP(nArg*lRys,3), QCWQ(nArg*lRys,3), - & B10(nArg*lRys,3), B00(nArg*lRys,3), - & B01(nArg*lRys,3) - Logical IfGrd(3,4),ifhss(4,3,4,3) -* Character*30 Label -* -c iRout = 15 -c iPrint = nPrint(iRout) -* If (iPrint.ge.99) Then -* If (nabMax.gt.0) Call RecPrt('PAWP',' ',PAWP,nArg,lRys*3) -* If (ncdMax.gt.0) Call RecPrt('QCWQ',' ',QCWQ,nArg,lRys*3) -* If (laa.ne.0) Call RecPrt(' B10',' ',B10,nArg*lRys,3) -* If (lac.ne.0) Call RecPrt(' B00',' ',B00,nArg*lRys,3) -* If (lcc.ne.0) Call RecPrt(' B01',' ',B01,nArg*lRys,3) -* End If -* -* Compute 2D integrals with index (0,0). Observe that the z -* component already contains the weight factor. -* - call dcopy_(2*nArg*lRys,[One],0,xyz2D(1,1,0,0),1) -* -* Compute 2D integrals with index (i,0) -* - Do 200 iCar = 1, 3 - llab = 0 - llcd = 0 - if (IfHss(2,iCar,2,iCar).or. - & IfHss(1,iCar,1,iCar)) llab=2 - if (IfGrd(iCar,2).or.IfGrd(iCar,1)) - & llab=Max(llab,1) - if (IfHss(3,iCar,3,iCar).or. - & IfHss(4,iCar,4,iCar)) llcd=2 - if (IfGrd(iCar,3).or.IfGrd(iCar,4)) - & llcd=Max(llcd,1) - - mabMax = la + lb + llab - mcdMax = lc + ld + llcd -* - If (mabMax.ne.0) Then - Do 201 i = 1, nArg*lRys - xyz2D(i,iCar,1,0) = PAWP(i,iCar) * xyz2D(i,iCar,0,0) - 201 Continue - End If - If (mabMax-1.eq.1) Then - Do 210 i = 1, nArg*lRys - xyz2D(i,iCar,2,0) = PAWP(i,iCar) * xyz2D(i,iCar,1,0) - & + B10(i,iCar) * xyz2D(i,iCar,0,0) - 210 Continue - Else If (mabMax-1.gt.1) Then - Fact = One - Do 250 iab = 1, mabMax-1 - Do 260 i = 1, nArg*lRys - temp1 = PAWP(i,iCar) * xyz2D(i,iCar,iab,0) - temp2 = Fact * B10(i,iCar) * xyz2D(i,iCar,iab-1,0) - xyz2D(i,iCar,iab+1,0) = temp1 + temp2 - 260 Continue - Fact = Fact + One - 250 Continue - End If -* -* Compute 2D integrals with index (0,i) -* - If (mcdMax.ne.0) Then - Do 301 i = 1, nArg*lRys - xyz2D(i,iCar,0,1) = QCWQ(i,iCar) * xyz2D(i,iCar,0,0) - 301 Continue - End If - If (mcdMax-1.eq.1) Then - Do 310 i = 1, nArg*lRys - xyz2D(i,iCar,0,2) = QCWQ(i,iCar) * xyz2D(i,iCar,0,1) - & + B01(i,iCar) * xyz2D(i,iCar,0,0) - 310 Continue - Else If (mcdMax-1.gt.1) Then - Fact = One - Do 350 icd = 1, mcdMax-1 - Do 360 i = 1, nArg*lRys - temp1 = QCWQ(i,iCar) * xyz2D(i,iCar,0,icd) - temp2 = Fact * B01(i,iCar) * xyz2D(i,iCar,0,icd-1) - xyz2D(i,iCar,0,icd+1) = temp1 + temp2 - 360 Continue - Fact = Fact + One - 350 Continue - End If -* -* Compute 2D integrals with index (i,iCar,j) -* - If (mcdMax.le.mabMax) Then - Fac1 = One - Do 400 icd = 1, mcdMax - Do 425 i = 1, nArg*lRys - xyz2D(i,iCar,1,icd)=PAWP(i,iCar)*xyz2D(i,iCar,0,icd) - & + Fac1 * B00(i,iCar)*xyz2D(i,iCar,0,icd-1) - 425 Continue - If (mabMax-1.eq.1) Then - Do 420 i = 1, nArg*lRys - xyz2D(i,iCar,2,icd)=PAWP(i,iCar)*xyz2D(i,iCar,1,icd) - & + B10(i,iCar)*xyz2D(i,iCar,0,icd) - & + Fac1 *B00(i,iCar)*xyz2D(i,iCar,1,icd-1) - 420 Continue - Else If (mabMax-1.gt.1) Then - Fac2 = One - Do 450 iab = 1, mabMax-1 - Do 460 i = 1, nArg*lRys - temp1 = PAWP(i,iCar) * xyz2D(i,iCar,iab,icd) - temp2 = Fac2 *B10(i,iCar) *xyz2D(i,iCar,iab-1,icd) - temp3 = Fac1 *B00(i,iCar) *xyz2D(i,iCar,iab,icd-1) - xyz2D(i,iCar,iab+1,icd) = temp1 + temp2 + temp3 - 460 Continue - Fac2 = Fac2 + One - 450 Continue - End If - Fac1 = Fac1 + One - 400 Continue - Else - Fac1 = One - Do 500 iab = 1, mabMax - Do 525 i = 1, nArg*lRys - xyz2D(i,iCar,iab,1)=QCWQ(i,iCar)*xyz2D(i,iCar,iab,0) - & + Fac1 *B00(i,iCar)*xyz2D(i,iCar,iab-1,0) - 525 Continue - If (mcdMax-1.eq.1) Then - Do 520 i = 1, nArg*lRys - xyz2D(i,iCar,iab,2)=QCWQ(i,iCar)*xyz2D(i,iCar,iab,1) - & + B01(i,iCar) *xyz2D(i,iCar,iab,0) - & + Fac1 *B00(i,iCar)*xyz2D(i,iCar,iab-1,1) - 520 Continue - Else If (mcdMax-1.gt.1) Then - Fac2 = One - Do 550 icd = 1, mcdMax-1 - Do 560 i = 1, nArg*lRys - temp1 = QCWQ(i,iCar) *xyz2D(i,iCar,iab,icd) - temp2 = Fac2 *B01(i,iCar) *xyz2D(i,iCar,iab,icd-1) - temp3 = Fac1 *B00(i,iCar) *xyz2D(i,iCar,iab-1,icd) - xyz2D(i,iCar,iab,icd+1) = temp1 + temp2 + temp3 - 560 Continue - Fac2 = Fac2 + One - 550 Continue - End If - Fac1 = Fac1 + One - 500 Continue - End If - 200 Continue -* -* If (iPrint.ge.99) Then -* Do 600 iab = 0, nabMax -* Do 610 icd = 0, ncdMax -* Write (Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(x)' -* Call RecPrt(Label,' ',xyz2D(1,1,iab,icd),nArg,lRys) -* Write (Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(y)' -* Call RecPrt(Label,' ',xyz2D(1,2,iab,icd),nArg,lRys) -* Write (Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(z)' -* Call RecPrt(Label,' ',xyz2D(1,3,iab,icd),nArg,lRys) -*610 Continue -*600 Continue -* End If - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(laa) - Call Unused_integer(lac) - Call Unused_integer(lcc) - End If - End diff -Nru openmolcas-22.02/src/rys_util/rs2dmm.F90 openmolcas-22.10/src/rys_util/rs2dmm.F90 --- openmolcas-22.02/src/rys_util/rs2dmm.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rs2dmm.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,151 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Rs2Dmm(xyz2D,nArg,lRys,nabMax,ncdMax,PAWP,QCWQ,B10,B00,B01,la,lb,lc,ld,IfHss,IfGrd) +!*********************************************************************** +! * +! Object: to compute the 2-dimensional integrals of the Rys * +! quadrature. The z components are assumed to be pre- * +! conditioned with the weights of the roots of the * +! Rys polynomial. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! Modified loop structure for RISC 1991 R. Lindh Dept. of Theoretical * +! Chemistry, University of Lund, Sweden. * +!*********************************************************************** + +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArg, lRys, nabMax, ncdMax, la, lb, lc, ld +real(kind=wp), intent(inout) :: xyz2D(nArg*lRys,3,0:nabMax,0:ncdMax) +real(kind=wp), intent(in) :: PAWP(nArg*lRys,3), QCWQ(nArg*lRys,3), B10(nArg*lRys,3), B00(nArg*lRys,3), B01(nArg*lRys,3) +logical(kind=iwp), intent(in) :: IfHss(4,3,4,3), IfGrd(3,4) +integer(kind=iwp) :: iab, iCar, icd, llab, llcd, mabMax, mcdMax +real(kind=wp) :: Fac1, Fac2, Fact + +!iRout = 15 +!iPrint = nPrint(iRout) +!if (iPrint >= 99) then +! if (nabMax > 0) call RecPrt('PAWP',' ',PAWP,nArg,lRys*3) +! if (ncdMax > 0) call RecPrt('QCWQ',' ',QCWQ,nArg,lRys*3) +! call RecPrt(' B10',' ',B10,nArg*lRys,3) +! call RecPrt(' B00',' ',B00,nArg*lRys,3) +! call RecPrt(' B01',' ',B01,nArg*lRys,3) +!end if + +! Compute 2D integrals with index (0,0). Observe that the z +! component already contains the weight factor. + +xyz2D(:,1:2,0,0) = One + +! Compute 2D integrals with index (i,0) + +do iCar=1,3 + llab = 0 + llcd = 0 + if (IfHss(2,iCar,2,iCar) .or. IfHss(1,iCar,1,iCar)) llab = 2 + if (IfGrd(iCar,2) .or. IfGrd(iCar,1)) llab = max(llab,1) + if (IfHss(3,iCar,3,iCar) .or. IfHss(4,iCar,4,iCar)) llcd = 2 + if (IfGrd(iCar,3) .or. IfGrd(iCar,4)) llcd = max(llcd,1) + + mabMax = la+lb+llab + mcdMax = lc+ld+llcd + + if (mabMax /= 0) then + xyz2D(:,iCar,1,0) = PAWP(:,iCar)*xyz2D(:,iCar,0,0) + end if + if (mabMax-1 == 1) then + xyz2D(:,iCar,2,0) = PAWP(:,iCar)*xyz2D(:,iCar,1,0)+B10(:,iCar)*xyz2D(:,iCar,0,0) + else if (mabMax-1 > 1) then + Fact = One + do iab=1,mabMax-1 + xyz2D(:,iCar,iab+1,0) = PAWP(:,iCar)*xyz2D(:,iCar,iab,0)+Fact*B10(:,iCar)*xyz2D(:,iCar,iab-1,0) + Fact = Fact+One + end do + end if + + ! Compute 2D integrals with index (0,i) + + if (mcdMax /= 0) then + xyz2D(:,iCar,0,1) = QCWQ(:,iCar)*xyz2D(:,iCar,0,0) + end if + if (mcdMax-1 == 1) then + xyz2D(:,iCar,0,2) = QCWQ(:,iCar)*xyz2D(:,iCar,0,1)+B01(:,iCar)*xyz2D(:,iCar,0,0) + else if (mcdMax-1 > 1) then + Fact = One + do icd=1,mcdMax-1 + xyz2D(:,iCar,0,icd+1) = QCWQ(:,iCar)*xyz2D(:,iCar,0,icd)+Fact*B01(:,iCar)*xyz2D(:,iCar,0,icd-1) + Fact = Fact+One + end do + end if + + ! Compute 2D integrals with index (i,iCar,j) + + if (mcdMax <= mabMax) then + Fac1 = One + do icd=1,mcdMax + xyz2D(:,iCar,1,icd) = PAWP(:,iCar)*xyz2D(:,iCar,0,icd)+Fac1*B00(:,iCar)*xyz2D(:,iCar,0,icd-1) + if (mabMax-1 == 1) then + xyz2D(:,iCar,2,icd) = PAWP(:,iCar)*xyz2D(:,iCar,1,icd)+B10(:,iCar)*xyz2D(:,iCar,0,icd)+ & + Fac1*B00(:,iCar)*xyz2D(:,iCar,1,icd-1) + else if (mabMax-1 > 1) then + Fac2 = One + do iab=1,mabMax-1 + xyz2D(:,iCar,iab+1,icd) = PAWP(:,iCar)*xyz2D(:,iCar,iab,icd)+Fac2*B10(:,iCar)*xyz2D(:,iCar,iab-1,icd)+ & + Fac1*B00(:,iCar)*xyz2D(:,iCar,iab,icd-1) + Fac2 = Fac2+One + end do + end if + Fac1 = Fac1+One + end do + else + Fac1 = One + do iab=1,mabMax + xyz2D(:,iCar,iab,1) = QCWQ(:,iCar)*xyz2D(:,iCar,iab,0)+Fac1*B00(:,iCar)*xyz2D(:,iCar,iab-1,0) + if (mcdMax-1 == 1) then + xyz2D(:,iCar,iab,2) = QCWQ(:,iCar)*xyz2D(:,iCar,iab,1)+B01(:,iCar)*xyz2D(:,iCar,iab,0)+ & + Fac1*B00(:,iCar)*xyz2D(:,iCar,iab-1,1) + else if (mcdMax-1 > 1) then + Fac2 = One + do icd=1,mcdMax-1 + xyz2D(:,iCar,iab,icd+1) = QCWQ(:,iCar)*xyz2D(:,iCar,iab,icd)+Fac2*B01(:,iCar)*xyz2D(:,iCar,iab,icd-1)+ & + Fac1*B00(:,iCar)*xyz2D(:,iCar,iab-1,icd) + Fac2 = Fac2+One + end do + end if + Fac1 = Fac1+One + end do + end if +end do + +!if (iPrint >= 99) then +! do iab=0,nabMax +! do icd=0,ncdMax +! write(Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(x)' +! call RecPrt(Label,' ',xyz2D(:,1,iab,icd),nArg,lRys) +! write(Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(y)' +! call RecPrt(Label,' ',xyz2D(:,2,iab,icd),nArg,lRys) +! write(Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(z)' +! call RecPrt(Label,' ',xyz2D(:,3,iab,icd),nArg,lRys) +! end do +! end do +!end if + +return + +end subroutine Rs2Dmm diff -Nru openmolcas-22.02/src/rys_util/rtswgh.f openmolcas-22.10/src/rys_util/rtswgh.f --- openmolcas-22.02/src/rys_util/rtswgh.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rtswgh.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,178 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - SUBROUTINE RTSWGH(TARR,NT,U2,WGH,NRYS) - use vRys_RW - IMPLICIT REAL*8 (A-H,O-Z) -#include "itmax.fh" -#include "real.fh" -#include "print.fh" -#include "abtab.fh" -CMAW -#include "FMM.fh" - DIMENSION TARR(NT),U2(NRYS,NT),WGH(NRYS,NT) - DIMENSION ROOT(MXSIZ1,MXSIZ1),RYS(0:MXSIZ1),RYSD(0:MXSIZ1) - DIMENSION ALPHA(0:MXSIZ1),BETA(0:MXSIZ1) - DIMENSION BINV(0:MXSIZ1) - parameter (coef1=-1.0d0/120d0, coef2=-5d0*coef1, coef3=-2d0*coef2) - parameter (coef4=-coef3, coef5=-coef2, coef6=-coef1) -c -#ifdef _DEBUGPRINT_ - iRout = 78 - iPrint = nPrint(iRout) -#endif - RYSD(0)=ZERO -c - IF (NRYS.gt.maxdeg) THEN - CALL WarningMessage(2,' Too many requested Rys roots.') - CALL AbEnd() - ENDIF -c - DO 5000 IT=1,NT - T=TARR(IT) -c Use asymptotic formulae if outside table. -CMAW if(t.gt.TVALUE(NTAB2-NTAB1-1)) then -* -* For the FMM we use the asymptotic limit to compute the -* multipole-component of the integrals -* - If( (t.gt.TVALUE(NTAB2-NTAB1-1)) .OR. asymptotic_Rys ) Then - do 25 iroot=1,nRYS - tmp = 1.0D0/T - U2(iroot,IT)=HerR2(iHerR2(nRys)+iroot-1)*tmp - WGH(iroot,IT)=HerW2(iHerW2(nRys)+iroot-1)*SQRT(tmp) - 25 Continue - Go To 5000 - end if -c translate to tabulation function for equidist. interp. -c xn=interpol. variable. -c Ex: T=0.0--0.05 gives xn=0.0--1.0 (approx.) -c itab= Start tab index for interp. Ex above: itab=1. - xn=5d0*T + 200d0*T/(14d0+T) - nx=Int(xn) - itab=nx-1-NTAB1 - p=xn-dble(nx) - a2=(p+2d0) - a3=(p+1d0)*a2 - a4=(p )*a3 - a5=(p-1d0)*a4 - a6=(p-2d0)*a5 - b5=(p-3d0) - b4=(p-2d0)*b5 - b3=(p-1d0)*b4 - b2=(p )*b3 - b1=(p+1d0)*b2 - c1=coef1* b1 - c2=coef2*a2*b2 - c3=coef3*a3*b3 - c4=coef4*a4*b4 - c5=coef5*a5*b5 - c6=coef6*a6 - ALPHA(0)=c1*ATAB(0,itab)+c2*ATAB(0,itab+1)+ - & c3*ATAB(0,itab+2)+c4*ATAB(0,itab+3)+ - & c5*ATAB(0,itab+4)+c6*ATAB(0,itab+5) - do 20 k=1,NRYS - ALPHA(k)=c1*ATAB(k,itab)+c2*ATAB(k,itab+1)+ - & c3*ATAB(k,itab+2)+c4*ATAB(k,itab+3)+ - & c5*ATAB(k,itab+4)+c6*ATAB(k,itab+5) - BETA(k)=c1*BTAB(k,itab)+c2*BTAB(k,itab+1)+ - & c3*BTAB(k,itab+2)+c4*BTAB(k,itab+3)+ - & c5*BTAB(k,itab+4)+c6*BTAB(k,itab+5) - BINV(K)=ONE/BETA(K) - 20 continue - rys(0)=c1*p0(itab)+c2*p0(itab+1)+ - & c3*p0(itab+2)+c4*p0(itab+3)+ - & c5*p0(itab+4)+c6*p0(itab+5) - ROOT(1,1)=ALPHA(0) - x1=(ALPHA(0)+ALPHA(1))/2d0 - x2=(ALPHA(0)-ALPHA(1))/2d0 - x3=SQRT(x2**2+BETA(1)**2) - ROOT(1,2)=x1-x3 - ROOT(2,2)=x1+x3 -C LOOP OVER DEGREE OF RYS POLY - DO 2000 IDEG=3,NRYS -C ESTIMATE POSITION OF U2 OF THIS DEGREE: - ROOT(1,IDEG)=(DBLE(IDEG)-0.5D00)*ROOT(1,IDEG-1)/DBLE(IDEG) - ROOT(IDEG,IDEG)= - & ONE-(DBLE(IDEG)-0.5D00)*(ONE-ROOT(IDEG-1,IDEG-1))/DBLE(IDEG) - DO 80 IROOT=2,IDEG-1 - R1=ROOT(IROOT,IDEG-1) - R2=ROOT(IROOT-1,IDEG-1) - x2=(DBLE(IROOT)-0.5D00)/DBLE(IDEG) - x1=ONE-x2 - R=x1*R1+x2*R2 - ROOT(IROOT,IDEG)=R - 80 CONTINUE -C IF(IDEG.EQ.NRYS) ITER=0 - RYSD(1)=RYS(0)*BINV(1) - DO 1000 IROOT=1,IDEG - Z=ROOT(IROOT,IDEG) -C Compute the correction coefficient: - corr=zero - do 91 J=1,iroot-1 - corr=corr+one/(root(iroot,ideg)-root(j,ideg)) - 91 continue - do 92 J=iroot+1,ideg - corr=corr+one/(root(iroot,ideg)-root(j,ideg)) - 92 continue -C COMPUTE RYS AND FIRST DERIVATIVE, DO NEWTON-RAPHSON: - 99 CONTINUE - RYS(1)=(Z-ALPHA(0))*RYSD(1) - ZZ=(Z-ALPHA(1)) - RYSD(2)=(ZZ*RYSD(1)+RYS(1))*BINV(2) - RYS(2) =(ZZ*RYS(1)-BETA(1)*RYS(0))*BINV(2) - DO 110 K=2,IDEG-1 - ZZ=Z-ALPHA(K) - BK= BETA(K) - RYSD(K+1)=(RYS(K)+ZZ*RYSD(K)-BK*RYSD(K-1))*BINV(K+1) - RYS(K+1) =( ZZ*RYS(K) -BK*RYS (K-1))*BINV(K+1) - 110 CONTINUE - DELTA=-RYS(IDEG)/(RYSD(IDEG)-CORR*RYS(IDEG)) - Z=Z+DELTA -C IF(IDEG.EQ.NRYS) ITER=ITER+1 - IF(ABS(DELTA).GT.1.0d-08) goto 99 - ROOT(IROOT,IDEG)=Z - 1000 CONTINUE - 2000 CONTINUE -C IF(NRYS.GT.2) -C & write(*,'(1x,a,f8.2)')' Avg. iter/root:',(iter*one)/NRYS - DO 3010 IROOT=1,NRYS - Z=ROOT(IROOT,NRYS) -C COMPUTE RYS VALUES AND ADD SQUARES TO GET WGH: - SUM=RYS(0)**2 - IF(NRYS.EQ.1) goto 3021 - RYS(1)=(Z-ALPHA(0))*RYS(0)*BINV(1) - SUM=SUM+RYS(1)**2 - IF(NRYS.EQ.2) goto 3021 - ZZ=(Z-ALPHA(1)) - RYS(2) =(ZZ*RYS(1)-BETA(1)*RYS(0))*BINV(2) - SUM=SUM+RYS(2)**2 - IF(NRYS.EQ.3) goto 3021 - DO 3020 K=2,NRYS-2 - ZZ=Z-ALPHA(K) - BK= BETA(K) - RYS(K+1) =(ZZ*RYS(K) -BK*RYS (K-1))*BINV(K+1) - SUM=SUM+RYS(K+1)**2 - 3020 CONTINUE - 3021 CONTINUE - WGH(IROOT,IT)=ONE/SUM - U2(IROOT,IT)=ROOT(IROOT,NRYS) - 3010 CONTINUE -C - 5000 CONTINUE -C -#ifdef _DEBUGPRINT_ - If (iPrint.ge.99) Then - Call RecPrt(' Roots',' ',U2,nRys,nT) - Call RecPrt(' Weights',' ',Wgh,nRys,nT) - End If -#endif - RETURN - END diff -Nru openmolcas-22.02/src/rys_util/rtswgh.F90 openmolcas-22.10/src/rys_util/rtswgh.F90 --- openmolcas-22.02/src/rys_util/rtswgh.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rtswgh.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,188 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine RTSWGH(TARR,NT,U2,WGH,NRYS) + +use vRys_RW, only: HerR2, HerW2, iHerR2, iHerW2 +use abdata, only: atab, btab, p0, tvalue +use Gateway_global, only: asymptotic_Rys +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Three, Five, Twelve, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: NT, NRYS +real(kind=wp), intent(in) :: TARR(NT) +real(kind=wp), intent(out) :: U2(NRYS,NT), WGH(NRYS,NT) +integer(kind=iwp) :: IDEG, iroot, IT, J, k, nx +real(kind=wp) :: a2, a3, a4, a5, a6, b1, b2, b3, b4, b5, BK, c1, c2, c3, c4, c5, c6, corr, DELTA, p, R, R1, R2, RSUM, T, tmp, x1, & + x2, x3, xn, Z, ZZ +real(kind=wp), allocatable :: ALPHA(:), BETA(:), BINV(:), ROOT(:,:), RYS(:), RYSD(:) +real(kind=wp), parameter :: coef1 = -One/120.0_wp, coef2 = Five/120.0_wp, coef3 = -One/Twelve, coef4 = One/Twelve, & + coef5 = -Five/120.0_wp, coef6 = One/120.0_wp + +#ifdef _DEBUGPRINT_ +iRout = 78 +iPrint = nPrint(iRout) +#endif + +if (NRYS > ubound(atab,1)) then + call WarningMessage(2,' Too many requested Rys roots.') + call AbEnd() +end if + +call mma_allocate(ALPHA,[0,max(NRYS,1)],label='ALPHA') +call mma_allocate(BETA,[0,max(NRYS,1)],label='BETA') +call mma_allocate(BINV,max(NRYS,2),label='BINV') +call mma_allocate(ROOT,max(NRYS,2),max(NRYS,2),label='ROOT') +call mma_allocate(RYS,[0,max(NRYS,2)],label='RYS') +call mma_allocate(RYSD,[0,max(NRYS,1)],label='RYSD') +RYSD(0) = Zero + +do IT=1,NT + T = TARR(IT) + ! Use asymptotic formulae if outside table. + !MAW if (t > TVALUE(ubound(TVALUE,1)-2)) then + + ! For the FMM we use the asymptotic limit to compute the + ! multipole-component of the integrals + + if ((t > TVALUE(ubound(TVALUE,1)-2)) .or. asymptotic_Rys) then + tmp = One/T + U2(:,IT) = HerR2(iHerR2(nRys):iHerR2(nRys)+nRys-1)*tmp + WGH(:,IT) = HerW2(iHerW2(nRys):iHerW2(nRys)+nRys-1)*sqrt(tmp) + cycle + end if + ! translate to tabulation function for equidist. interp. + ! xn=interpol. variable. + ! Ex: T=0.0--0.05 gives xn=0.0--1.0 (approx.) + xn = Five*T+200.0_wp*T/(14.0_wp+T) + nx = int(xn) + p = xn-real(nx,kind=wp) + a2 = (p+Two) + a3 = (p+One)*a2 + a4 = (p)*a3 + a5 = (p-One)*a4 + a6 = (p-Two)*a5 + b5 = (p-Three) + b4 = (p-Two)*b5 + b3 = (p-One)*b4 + b2 = (p)*b3 + b1 = (p+One)*b2 + c1 = coef1*b1 + c2 = coef2*a2*b2 + c3 = coef3*a3*b3 + c4 = coef4*a4*b4 + c5 = coef5*a5*b5 + c6 = coef6*a6 + ALPHA(0) = c1*ATAB(0,nx-2)+c2*ATAB(0,nx-1)+c3*ATAB(0,nx)+c4*ATAB(0,nx+1)+c5*ATAB(0,nx+2)+c6*ATAB(0,nx+3) + ALPHA(1:NRYS) = c1*ATAB(1:NRYS,nx-2)+c2*ATAB(1:NRYS,nx-1)+c3*ATAB(1:NRYS,nx)+c4*ATAB(1:NRYS,nx+1)+c5*ATAB(1:NRYS,nx+2)+ & + c6*ATAB(1:NRYS,nx+3) + BETA(1:NRYS) = c1*BTAB(1:NRYS,nx-2)+c2*BTAB(1:NRYS,nx-1)+c3*BTAB(1:NRYS,nx)+c4*BTAB(1:NRYS,nx+1)+c5*BTAB(1:NRYS,nx+2)+ & + c6*BTAB(1:NRYS,nx+3) + BINV(1:NRYS) = One/BETA(1:NRYS) + rys(0) = c1*p0(nx-2)+c2*p0(nx-1)+c3*p0(nx)+c4*p0(nx+1)+c5*p0(nx+2)+c6*p0(nx+3) + ROOT(1,1) = ALPHA(0) + x1 = (ALPHA(0)+ALPHA(1))*Half + x2 = (ALPHA(0)-ALPHA(1))*Half + x3 = sqrt(x2**2+BETA(1)**2) + ROOT(1,2) = x1-x3 + ROOT(2,2) = x1+x3 + ! LOOP OVER DEGREE OF RYS POLY + do IDEG=3,NRYS + ! ESTIMATE POSITION OF U2 OF THIS DEGREE: + ROOT(1,IDEG) = (real(IDEG,kind=wp)-Half)*ROOT(1,IDEG-1)/real(IDEG,kind=wp) + ROOT(IDEG,IDEG) = ONE-(real(IDEG,kind=wp)-Half)*(ONE-ROOT(IDEG-1,IDEG-1))/real(IDEG,kind=wp) + do IROOT=2,IDEG-1 + R1 = ROOT(IROOT,IDEG-1) + R2 = ROOT(IROOT-1,IDEG-1) + x2 = (real(IROOT,kind=wp)-Half)/real(IDEG,kind=wp) + x1 = ONE-x2 + R = x1*R1+x2*R2 + ROOT(IROOT,IDEG) = R + end do + !if (IDEG == NRYS) ITER = 0 + RYSD(1) = RYS(0)*BINV(1) + do IROOT=1,IDEG + Z = ROOT(IROOT,IDEG) + ! Compute the correction coefficient: + corr = Zero + do J=1,iroot-1 + corr = corr+one/(root(iroot,ideg)-root(j,ideg)) + end do + do J=iroot+1,ideg + corr = corr+one/(root(iroot,ideg)-root(j,ideg)) + end do + ! COMPUTE RYS AND FIRST DERIVATIVE, DO NEWTON-RAPHSON: + do + RYS(1) = (Z-ALPHA(0))*RYSD(1) + ZZ = (Z-ALPHA(1)) + RYSD(2) = (ZZ*RYSD(1)+RYS(1))*BINV(2) + RYS(2) = (ZZ*RYS(1)-BETA(1)*RYS(0))*BINV(2) + do K=2,IDEG-1 + ZZ = Z-ALPHA(K) + BK = BETA(K) + RYSD(K+1) = (RYS(K)+ZZ*RYSD(K)-BK*RYSD(K-1))*BINV(K+1) + RYS(K+1) = (ZZ*RYS(K)-BK*RYS(K-1))*BINV(K+1) + end do + DELTA = -RYS(IDEG)/(RYSD(IDEG)-CORR*RYS(IDEG)) + Z = Z+DELTA + !if (IDEG == NRYS) ITER = ITER+1 + if (abs(DELTA) <= 1.0e-8_wp) exit + end do + ROOT(IROOT,IDEG) = Z + end do + end do + !if (NRYS > 2) write(u6,'(1x,a,f8.2)') ' Avg. iter/root:',(iter*one)/NRYS + do IROOT=1,NRYS + Z = ROOT(IROOT,NRYS) + ! COMPUTE RYS VALUES AND ADD SQUARES TO GET WGH: + RSUM = RYS(0)**2 + if (NRYS /= 1) then + RYS(1) = (Z-ALPHA(0))*RYS(0)*BINV(1) + RSUM = RSUM+RYS(1)**2 + if (NRYS /= 2) then + ZZ = (Z-ALPHA(1)) + RYS(2) = (ZZ*RYS(1)-BETA(1)*RYS(0))*BINV(2) + RSUM = RSUM+RYS(2)**2 + if (NRYS /= 3) then + do K=2,NRYS-2 + ZZ = Z-ALPHA(K) + BK = BETA(K) + RYS(K+1) = (ZZ*RYS(K)-BK*RYS(K-1))*BINV(K+1) + RSUM = RSUM+RYS(K+1)**2 + end do + end if + end if + end if + WGH(IROOT,IT) = ONE/RSUM + U2(IROOT,IT) = ROOT(IROOT,NRYS) + end do + +end do + +call mma_deallocate(ALPHA) +call mma_deallocate(BETA) +call mma_deallocate(BINV) +call mma_deallocate(ROOT) +call mma_deallocate(RYS) +call mma_deallocate(RYSD) + +#ifdef _DEBUGPRINT_ +if (iPrint >= 99) then + call RecPrt(' Roots',' ',U2,nRys,nT) + call RecPrt(' Weights',' ',Wgh,nRys,nT) +end if +#endif + +return + +end subroutine RTSWGH diff -Nru openmolcas-22.02/src/rys_util/rys01.f openmolcas-22.10/src/rys_util/rys01.f --- openmolcas-22.02/src/rys_util/rys01.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys01.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Rys01(Arg,nArg,Weight,iPntr,nPntr, - & x0,nMax,W6,W5,W4,W3,W2,W1,W0,ddx,HerW,Tmax) -************************************************************************ -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* September '90 * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 Arg(nArg), Weight(nArg), x0(nMax), W6(nMax), W5(nMax), - & W4(nMax), W3(nMax), W2(nMax), W1(nMax), W0(nMax) - Integer iPntr(nPntr) -* - xdInv=One/ddx - dddx = ddx/10d0 + ddx - Do 10 iArg = 1, nArg - If (Arg(iArg).lt.TMax) Then - n = iPntr(Int((Arg(iArg)+dddx)*xdInv)) - z = Arg(iArg) - x0(n) - w =(((((W6(n)*z+W5(n))*z+W4(n))*z+W3(n))*z+W2(n))*z+W1(n)) - & *z+w0(n) - Weight(iArg) = w - Else - ai = 1.0D0/Arg(iArg) - Weight(iArg) = HerW*Sqrt(ai) - End If - 10 Continue - Return - End diff -Nru openmolcas-22.02/src/rys_util/rys01.F90 openmolcas-22.10/src/rys_util/rys01.F90 --- openmolcas-22.02/src/rys_util/rys01.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys01.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,48 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Rys01(Arg,nArg,Weight,iPntr,nPntr,x0,nMax,W6,W5,W4,W3,W2,W1,W0,ddx,HerW,Tmax) +!*********************************************************************** +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! September '90 * +!*********************************************************************** + +use Constants, only: One, Ten +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArg, nPntr, iPntr(nPntr), nMax +real(kind=wp), intent(in) :: Arg(nArg), x0(nMax), W6(nMax), W5(nMax), W4(nMax), W3(nMax), W2(nMax), W1(nMax), W0(nMax), ddx, HerW, & + TMax +real(kind=wp), intent(out) :: Weight(nArg) +integer(kind=iwp) :: iArg, n +real(kind=wp) :: ai, dddx, xdInv, z + +xdInv = One/ddx +dddx = ddx/Ten+ddx +do iArg=1,nArg + if (Arg(iArg) < TMax) then + n = iPntr(int((Arg(iArg)+dddx)*xdInv)) + z = Arg(iArg)-x0(n) + Weight(iArg) = (((((W6(n)*z+W5(n))*z+W4(n))*z+W3(n))*z+W2(n))*z+W1(n))*z+w0(n) + else + ai = One/Arg(iArg) + Weight(iArg) = HerW*sqrt(ai) + end if +end do + +return + +end subroutine Rys01 diff -Nru openmolcas-22.02/src/rys_util/rys11.f openmolcas-22.10/src/rys_util/rys11.f --- openmolcas-22.02/src/rys_util/rys11.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys11.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,49 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Rys11(Arg,nArg,Root,Weight,iPntr,nPntr, - & x0,nMax,R6,R5,R4,R3,R2,R1,R0, - & W6,W5,W4,W3,W2,W1,W0,ddx, - & HerW,HerR2,TMax) -************************************************************************ -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* September '90 * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 Arg(nArg), Root(nArg), Weight(nArg), x0(nMax), - & R6(nMax), R5(nMax), - & R4(nMax), R3(nMax), R2(nMax), R1(nMax), R0(nMax), - & W6(nMax), W5(nMax), - & W4(nMax), W3(nMax), W2(nMax), W1(nMax), W0(nMax) - Integer iPntr(nPntr) -* - xdInv=One/ddx - dddx=ddx/10d0 + ddx - Do iArg = 1, nArg - If (Arg(iArg).lt.TMax) Then - n = iPntr(Int((Arg(iArg)+dddx)*xdInv)) - z = Arg(iArg) - x0(n) - Root(iArg)=(((((r6(n)*z+r5(n))*z+r4(n))*z+r3(n))*z - & +r2(n))*z+r1(n))*z+r0(n) - Weight(iArg)=(((((w6(n)*z+w5(n))*z+w4(n))*z+w3(n))*z - & +w2(n))*z+w1(n))*z+w0(n) - Else - ai=1.0d0/Arg(iArg) - Root(iArg) = HerR2*ai - Weight(iArg) = HerW*Sqrt(ai) - End If - End Do - Return - End diff -Nru openmolcas-22.02/src/rys_util/rys11.F90 openmolcas-22.10/src/rys_util/rys11.F90 --- openmolcas-22.02/src/rys_util/rys11.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys11.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,50 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Rys11(Arg,nArg,Root,Weight,iPntr,nPntr,x0,nMax,R6,R5,R4,R3,R2,R1,R0,W6,W5,W4,W3,W2,W1,W0,ddx,HerW,HerR2,TMax) +!*********************************************************************** +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! September '90 * +!*********************************************************************** + +use Constants, only: One, Ten +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArg, nPntr, iPntr(nPntr), nMax +real(kind=wp), intent(in) :: Arg(nArg), x0(nMax), R6(nMax), R5(nMax), R4(nMax), R3(nMax), R2(nMax), R1(nMax), R0(nMax), W6(nMax), & + W5(nMax), W4(nMax), W3(nMax), W2(nMax), W1(nMax), W0(nMax), ddx, HerW, HerR2, TMax +real(kind=wp), intent(out) :: Root(nArg), Weight(nArg) +integer(kind=iwp) :: iArg, n +real(kind=wp) :: ai, dddx, xdInv, z + +xdInv = One/ddx +dddx = ddx/Ten+ddx +do iArg=1,nArg + if (Arg(iArg) < TMax) then + n = iPntr(int((Arg(iArg)+dddx)*xdInv)) + z = Arg(iArg)-x0(n) + Root(iArg) = (((((r6(n)*z+r5(n))*z+r4(n))*z+r3(n))*z+r2(n))*z+r1(n))*z+r0(n) + Weight(iArg) = (((((w6(n)*z+w5(n))*z+w4(n))*z+w3(n))*z+w2(n))*z+w1(n))*z+w0(n) + else + ai = One/Arg(iArg) + Root(iArg) = HerR2*ai + Weight(iArg) = HerW*sqrt(ai) + end if +end do + +return + +end subroutine Rys11 diff -Nru openmolcas-22.02/src/rys_util/rys22.f openmolcas-22.10/src/rys_util/rys22.f --- openmolcas-22.02/src/rys_util/rys22.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys22.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Rys22(Arg,nArg,Root,Weight,iPntr,nPntr, - & x0,nMax,R6,R5,R4,R3,R2,R1,R0, - & W6,W5,W4,W3,W2,W1,W0,ddx, - & HerW,HerR2,TMax) -************************************************************************ -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* September '90 * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 Arg(nArg), Root(2,nArg), Weight(2,nArg), x0(nMax), - & R6(nMax,2), R5(nMax,2), - & R4(nMax,2), R3(nMax,2), R2(nMax,2), R1(nMax,2), R0(nMax,2), - & W6(nMax,2), W5(nMax,2), - & W4(nMax,2), W3(nMax,2), W2(nMax,2), W1(nMax,2), W0(nMax,2), - & HerW(3), HerR2(3) - Integer iPntr(nPntr) -* - xdInv=One/ddx - dddx=ddx/10d0 + ddx - Do iArg = 1, nArg - If (Arg(iArg).lt.TMax) Then - n = iPntr(Int((Arg(iArg)+dddx)*xdInv)) - z = Arg(iArg) - x0(n) - r = (((((R6(n,1)*z+R5(n,1))*z+R4(n,1))*z+R3(n,1))*z+R2(n,1)) - & *z+R1(n,1))*z+R0(n,1) - Root(1,iArg)= r - r = (((((R6(n,2)*z+R5(n,2))*z+R4(n,2))*z+R3(n,2))*z+R2(n,2)) - & *z+R1(n,2))*z+R0(n,2) - Root(2,iArg)= r - r = (((((W6(n,1)*z+W5(n,1))*z+W4(n,1))*z+W3(n,1))*z+W2(n,1)) - & *z+W1(n,1))*z+W0(n,1) - Weight(1,iArg) = r - r = (((((W6(n,2)*z+W5(n,2))*z+W4(n,2))*z+W3(n,2))*z+W2(n,2)) - & *z+W1(n,2))*z+W0(n,2) - Weight(2,iArg) = r - Else - ai = 1.0D0/Arg(iArg) - si = Sqrt(ai) - Root(1,iArg) = HerR2(1)*ai - Root(2,iArg) = HerR2(2)*ai - Weight(1,iArg) = HerW(1)*si - Weight(2,iArg) = HerW(2)*si - - End If - End Do -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/rys22.F90 openmolcas-22.10/src/rys_util/rys22.F90 --- openmolcas-22.02/src/rys_util/rys22.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys22.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,52 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Rys22(Arg,nArg,Root,Weight,iPntr,nPntr,x0,nMax,R6,R5,R4,R3,R2,R1,R0,W6,W5,W4,W3,W2,W1,W0,ddx,HerW,HerR2,TMax) +!*********************************************************************** +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! September '90 * +!*********************************************************************** + +use Constants, only: One, Ten +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArg, nPntr, iPntr(nPntr), nMax +real(kind=wp), intent(in) :: Arg(nArg), x0(nMax), R6(nMax,2), R5(nMax,2), R4(nMax,2), R3(nMax,2), R2(nMax,2), R1(nMax,2), & + R0(nMax,2), W6(nMax,2), W5(nMax,2), W4(nMax,2), W3(nMax,2), W2(nMax,2), W1(nMax,2), W0(nMax,2), ddx, & + HerW(2), HerR2(2), TMax +real(kind=wp), intent(out) :: Root(2,nArg), Weight(2,nArg) +integer(kind=iwp) :: iArg, n +real(kind=wp) :: ai, dddx, si, xdInv, z + +xdInv = One/ddx +dddx = ddx/Ten+ddx +do iArg=1,nArg + if (Arg(iArg) < TMax) then + n = iPntr(int((Arg(iArg)+dddx)*xdInv)) + z = Arg(iArg)-x0(n) + Root(:,iArg) = (((((R6(n,:)*z+R5(n,:))*z+R4(n,:))*z+R3(n,:))*z+R2(n,:))*z+R1(n,:))*z+R0(n,:) + Weight(:,iArg) = (((((W6(n,:)*z+W5(n,:))*z+W4(n,:))*z+W3(n,:))*z+W2(n,:))*z+W1(n,:))*z+W0(n,:) + else + ai = One/Arg(iArg) + si = sqrt(ai) + Root(:,iArg) = HerR2(:)*ai + Weight(:,iArg) = HerW(:)*si + end if +end do + +return + +end subroutine Rys22 diff -Nru openmolcas-22.02/src/rys_util/rys2d.f openmolcas-22.10/src/rys_util/rys2d.f --- openmolcas-22.02/src/rys_util/rys2d.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys2d.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,170 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Rys2D(xyz2D,nArg,lRys,nabMax,ncdMax,PAWP,QCWQ, - & B10,laa,B00,lac,B01,lcc) -************************************************************************ -* * -* Object: to compute the 2-dimensional integrals of the Rys * -* quadrature. The z components are assumed to be pre- * -* conditioned with the weights of the roots of the * -* Rys polynomial. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* Modified loop structure for RISC 1991 R. Lindh Dept. of Theoretical * -* Chemistry, University of Lund, Sweden. * -* VV: improve loop structure * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - Real*8 xyz2D(nArg*lRys*3,0:nabMax,0:ncdMax), - & PAWP(nArg*lRys*3), QCWQ(nArg*lRys*3), - & B10(nArg*lRys*3), B00(nArg*lRys*3), - & B01(nArg*lRys*3) -#ifdef _DEBUGPRINT_ - Character*30 Label - If (nabMax.gt.0) Call RecPrt('PAWP',' ',PAWP,nArg,lRys*3) - If (ncdMax.gt.0) Call RecPrt('QCWQ',' ',QCWQ,nArg,lRys*3) - If (laa.ne.0) Call RecPrt(' B10',' ',B10,nArg*lRys,3) - If (lac.ne.0) Call RecPrt(' B00',' ',B00,nArg*lRys,3) - If (lcc.ne.0) Call RecPrt(' B01',' ',B01,nArg*lRys,3) -#endif -* -* Compute 2D integrals with index (0,0). Observe that the z -* component already contains the weight factor. -* - call dcopy_(2*nArg*lRys,[One],0,xyz2D(1,0,0),1) -* -* Compute 2D integrals with index (i,0) -* - If (nabMax.ne.0) Then - Do 201 i = 1, nArg*lRys*3 - xyz2D(i,1,0) = PAWP(i) * xyz2D(i,0,0) - 201 Continue - End If - If (nabMax.eq.2) Then - Do 210 i = 1, nArg*lRys*3 - xyz2D(i,2,0) = PAWP(i) * xyz2D(i,1,0) - & + B10(i) * xyz2D(i,0,0) - 210 Continue - Else If (nabMax.gt.2) Then - Do 250 iab = 1, nabMax-1 - Do 260 i = 1, nArg*lRys*3 - temp1 = PAWP(i) * xyz2D(i,iab,0) - temp2 = Dble(iab) * B10(i) * xyz2D(i,iab-1,0) - xyz2D(i,iab+1,0) = temp1 + temp2 - 260 Continue - 250 Continue - End If -* -* Compute 2D integrals with index (0,i) -* - If (ncdMax.ne.0) Then - Do 301 i = 1, nArg*lRys*3 - xyz2D(i,0,1) = QCWQ(i) * xyz2D(i,0,0) - 301 Continue - End If - If (ncdMax.eq.2) Then - Do 310 i = 1, nArg*lRys*3 - xyz2D(i,0,2) = QCWQ(i) * xyz2D(i,0,1) - & + B01(i) * xyz2D(i,0,0) - 310 Continue - Else If (ncdMax.gt.2) Then - Do 350 icd = 1, ncdMax-1 - Do 360 i = 1, nArg*lRys*3 - temp1 = QCWQ(i) * xyz2D(i,0,icd) - temp2 = Dble(icd) * B01(i) * xyz2D(i,0,icd-1) - xyz2D(i,0,icd+1) = temp1 + temp2 - 360 Continue - 350 Continue - End If -* -* Compute 2D integrals with index (i,j) -* - If (ncdMax.le.nabMax) Then - Do 400 icd = 1, ncdMax - Do 425 i = 1, nArg*lRys*3 - xyz2D(i,1,icd) = PAWP(i) * xyz2D(i,0,icd) - & + Dble(icd) * B00(i) * xyz2D(i,0,icd-1) - 425 Continue - If (nabMax.eq.2) Then - Do 420 i = 1, nArg*lRys*3 - xyz2D(i,2,icd) = PAWP(i) * xyz2D(i,1,icd) - & + B10(i) * xyz2D(i,0,icd) - & + Dble(icd) *B00(i) *xyz2D(i,1,icd-1) - 420 Continue - Else If (nabMax.gt.2) Then - Do 450 iab = 1, nabMax-1 - Do 460 i = 1, nArg*lRys*3 - temp1 = PAWP(i) * xyz2D(i,iab,icd) - temp2 = Dble(iab) *B10(i) *xyz2D(i,iab-1,icd) - temp3 = Dble(icd) *B00(i) *xyz2D(i,iab,icd-1) - xyz2D(i,iab+1,icd) = temp1 + temp2 + temp3 - 460 Continue - 450 Continue - End If - 400 Continue - Else - Do 500 iab = 1, nabMax - Do 525 i = 1, nArg*lRys*3 - xyz2D(i,iab,1) = QCWQ(i) *xyz2D(i,iab,0) - & + Dble(iab) *B00(i) *xyz2D(i,iab-1,0) - 525 Continue - If (ncdMax.eq.2) Then - Do 520 i = 1, nArg*lRys*3 - xyz2D(i,iab,2) = QCWQ(i) *xyz2D(i,iab,1) - & + B01(i) *xyz2D(i,iab,0) - & + Dble(iab) *B00(i) *xyz2D(i,iab-1,1) - 520 Continue - Else If (ncdMax.gt.2) Then - Do 550 icd = 1, ncdmax-1 - Do 560 i = 1, nArg*lRys*3 - temp1 = QCWQ(i) *xyz2D(i,iab,icd) - temp2 = Dble(icd) *B01(i) *xyz2D(i,iab,icd-1) - temp3 = Dble(iab) *B00(i) *xyz2D(i,iab-1,icd) - xyz2D(i,iab,icd+1) = temp1 + temp2 + temp3 - 560 Continue - - 550 Continue - End If - 500 Continue - - End If -* -#ifdef _DEBUGPRINT_ - Do 600 iab = 0, nabMax - Do 610 icd = 0, ncdMax - Write (Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(x)' - Call RecPrt(Label,' ', - & xyz2D(1,iab,icd),lRys,nArg) - Write (Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(y)' - Call RecPrt(Label,' ', - & xyz2D(1+nArg*lRys,iab,icd),lRys,nArg) - Write (Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(z)' - Call RecPrt(Label,' ', - & xyz2D(1+2*nArg*lRys,iab,icd),lRys,nArg) - 610 Continue - 600 Continue -#else -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(laa) - Call Unused_integer(lac) - Call Unused_integer(lcc) - End If -#endif - Return - End diff -Nru openmolcas-22.02/src/rys_util/rys2d.F90 openmolcas-22.10/src/rys_util/rys2d.F90 --- openmolcas-22.02/src/rys_util/rys2d.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys2d.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,124 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Rys2D(xyz2D,nArg,lRys,nabMax,ncdMax,PAWP,QCWQ,B10,B00,B01) +!*********************************************************************** +! * +! Object: to compute the 2-dimensional integrals of the Rys * +! quadrature. The z components are assumed to be pre- * +! conditioned with the weights of the roots of the * +! Rys polynomial. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! Modified loop structure for RISC 1991 R. Lindh Dept. of Theoretical * +! Chemistry, University of Lund, Sweden. * +! VV: improve loop structure * +!*********************************************************************** + +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArg, lRys, nabMax, ncdMax +real(kind=wp), intent(inout) :: xyz2D(nArg*lRys,3,0:nabMax,0:ncdMax) +real(kind=wp), intent(in) :: PAWP(nArg*lRys,3), QCWQ(nArg*lRys,3), B10(nArg*lRys,3), B00(nArg*lRys,3), B01(nArg*lRys,3) +integer(kind=iwp) :: iab, icd + +#ifdef _DEBUGPRINT_ +character*30 Label +if (nabMax > 0) call RecPrt('PAWP',' ',PAWP,nArg,lRys*3) +if (ncdMax > 0) call RecPrt('QCWQ',' ',QCWQ,nArg,lRys*3) +call RecPrt(' B10',' ',B10,nArg*lRys,3) +call RecPrt(' B00',' ',B00,nArg*lRys,3) +call RecPrt(' B01',' ',B01,nArg*lRys,3) +#endif + +! Compute 2D integrals with index (0,0). Observe that the z +! component already contains the weight factor. + +xyz2D(:,1:2,0,0) = One + +! Compute 2D integrals with index (i,0) + +if (nabMax /= 0) then + xyz2D(:,:,1,0) = PAWP(:,:)*xyz2D(:,:,0,0) + if (nabMax == 2) then + xyz2D(:,:,2,0) = PAWP(:,:)*xyz2D(:,:,1,0)+B10(:,:)*xyz2D(:,:,0,0) + else if (nabMax > 2) then + do iab=1,nabMax-1 + xyz2D(:,:,iab+1,0) = PAWP(:,:)*xyz2D(:,:,iab,0)+real(iab,kind=wp)*B10(:,:)*xyz2D(:,:,iab-1,0) + end do + end if +end if + +! Compute 2D integrals with index (0,i) + +if (ncdMax /= 0) then + xyz2D(:,:,0,1) = QCWQ(:,:)*xyz2D(:,:,0,0) + if (ncdMax == 2) then + xyz2D(:,:,0,2) = QCWQ(:,:)*xyz2D(:,:,0,1)+B01(:,:)*xyz2D(:,:,0,0) + else if (ncdMax > 2) then + do icd=1,ncdMax-1 + xyz2D(:,:,0,icd+1) = QCWQ(:,:)*xyz2D(:,:,0,icd)+real(icd,kind=wp)*B01(:,:)*xyz2D(:,:,0,icd-1) + end do + end if +end if + +! Compute 2D integrals with index (i,j) + +if (ncdMax <= nabMax) then + do icd=1,ncdMax + xyz2D(:,:,1,icd) = PAWP(:,:)*xyz2D(:,:,0,icd)+real(icd,kind=wp)*B00(:,:)*xyz2D(:,:,0,icd-1) + if (nabMax == 2) then + xyz2D(:,:,2,icd) = PAWP(:,:)*xyz2D(:,:,1,icd)+B10(:,:)*xyz2D(:,:,0,icd)+real(icd,kind=wp)*B00(:,:)*xyz2D(:,:,1,icd-1) + else if (nabMax > 2) then + do iab=1,nabMax-1 + xyz2D(:,:,iab+1,icd) = PAWP(:,:)*xyz2D(:,:,iab,icd)+real(iab,kind=wp)*B10(:,:)*xyz2D(:,:,iab-1,icd)+ & + real(icd,kind=wp)*B00(:,:)*xyz2D(:,:,iab,icd-1) + end do + end if + end do +else + do iab=1,nabMax + xyz2D(:,:,iab,1) = QCWQ(:,:)*xyz2D(:,:,iab,0)+real(iab,kind=wp)*B00(:,:)*xyz2D(:,:,iab-1,0) + if (ncdMax == 2) then + xyz2D(:,:,iab,2) = QCWQ(:,:)*xyz2D(:,:,iab,1)+B01(:,:)*xyz2D(:,:,iab,0)+real(iab,kind=wp)*B00(:,:)*xyz2D(:,:,iab-1,1) + else if (ncdMax > 2) then + do icd=1,ncdmax-1 + xyz2D(:,:,iab,icd+1) = QCWQ(:,:)*xyz2D(:,:,iab,icd)+real(icd,kind=wp)*B01(:,:)*xyz2D(:,:,iab,icd-1)+ & + real(iab,kind=wp)*B00(:,:)*xyz2D(:,:,iab-1,icd) + end do + end if + end do + +end if + +#ifdef _DEBUGPRINT_ +do iab=0,nabMax + do icd=0,ncdMax + write(Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(x)' + call RecPrt(Label,' ',xyz2D(:,1,iab,icd),lRys,nArg) + write(Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(y)' + call RecPrt(Label,' ',xyz2D(:,2,iab,icd),lRys,nArg) + write(Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(z)' + call RecPrt(Label,' ',xyz2D(:,3,iab,icd),lRys,nArg) + end do +end do +#endif + +return + +end subroutine Rys2D diff -Nru openmolcas-22.02/src/rys_util/rys2dg.f openmolcas-22.10/src/rys_util/rys2dg.f --- openmolcas-22.02/src/rys_util/rys2dg.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys2dg.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,633 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1991, Roland Lindh * -************************************************************************ - SubRoutine Rys2Dg(xyz2D0,nT,nRys,la,lb,lc,ld,xyz2D1,IfGrad, - & IndGrd,Coora,Alpha,Beta,Gamma,Delta,nZeta, - & nEta,Scrtch,Temp,Index,ExpX,ExpY,mZeta,mEta) -************************************************************************ -* * -* Object: to compute the gradients of the 2D-integrals. * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, * -* University of Lund, SWEDEN * -* October '91 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) - External ExpX, ExpY -#include "print.fh" -#include "real.fh" - Real*8 xyz2D0(nRys*nT,0:la+1,0:lb+1,0:lc+1,0:ld+1,3), - & xyz2D1(nRys*nT,0:la ,0:lb ,0:lc ,0:ld ,3,3), - & Coora(3,4), - & Alpha(nZeta), Beta(nZeta), Gamma(nEta), Delta(nEta), - & Scrtch(nRys*nT), Temp(nT) - Logical IfGrad(3,4), EQ - Integer IndGrd(3,4), Ind1(3), Ind2(3), Index(3,4) -* -#ifdef _DEBUGPRINT_ - iRout = 249 - iPrint = nPrint(iRout) - If (iPrint.ge.99) Then - Call RecPrt(' In Rys2Dg: Alpha',' ',Alpha,1,nZeta) - Call RecPrt(' In Rys2Dg: Beta ',' ',Beta ,1,nZeta) - Call RecPrt(' In Rys2Dg: Gamma',' ',Gamma,1,nEta ) - Call RecPrt(' In Rys2Dg: Delta',' ',Delta,1,nEta ) - Write (6,*) ' IfGrad=',IfGrad - Write (6,*) ' IndGrd=',IndGrd - End If -#endif - tOne = -One - tTwo = Two - nx = 0 - ny = 0 - nz = 0 - Call ICopy(12,[0],0,Index,1) -* -* Differentiate with respect to the first center -* - If (IfGrad(1,1) .or.IfGrad(2,1) .or. - & IfGrad(3,1)) Then - Call ExpX(Temp ,mZeta,mEta,Alpha,One) - Call Exp_2(Scrtch,nRys,nT,Temp,One) -* If (iPrint.ge.99) Call RecPrt( -* & 'Expanded exponents (alpha)',' ',Scrtch, -* & nT,nRys) - End If - nVec = 0 - If (IfGrad(1,1)) Then - nx = nx + 1 - nVec = nVec + 1 - Ind1(nVec) = nx - Ind2(nVec) = 1 - Index(1,1) = nx - End If - If (IfGrad(2,1)) Then - ny = ny + 1 - nVec = nVec + 1 - Ind1(nVec) = ny - Ind2(nVec) = 2 - Index(2,1) = ny - End If - If (IfGrad(3,1)) Then - nz = nz + 1 - nVec = nVec + 1 - Ind1(nVec) = nz - Ind2(nVec) = 3 - Index(3,1) = nz - End If - If (nVec.eq.0) Go To 211 -* - Do 101 id = 0, ld - Do 201 ic = 0, lc - Do 301 ib = 0, lb - If (nVec.eq.3) Then - Do 501 iVec = 1, nT*nRys - xyz2D1(iVec,0,ib,ic,id,Ind2(1),Ind1(1)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,1,ib,ic,id,Ind2(1)) - xyz2D1(iVec,0,ib,ic,id,Ind2(2),Ind1(2)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,1,ib,ic,id,Ind2(2)) - xyz2D1(iVec,0,ib,ic,id,Ind2(3),Ind1(3)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,1,ib,ic,id,Ind2(3)) - 501 Continue - If (la.ge.1) Then - Fact = tOne - Do 511 ia = 1, la - Do 521 iVec = 1, nT*nRys - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia+1,ib,ic,id,Ind2(1)) - tmp2 = Fact * - & xyz2D0(iVec,ia-1,ib,ic,id,Ind2(1)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(1),Ind1(1)) = - & tmp1 + tmp2 - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia+1,ib,ic,id,Ind2(2)) - tmp2 = Fact * - & xyz2D0(iVec,ia-1,ib,ic,id,Ind2(2)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(2),Ind1(2)) = - & tmp1 + tmp2 - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia+1,ib,ic,id,Ind2(3)) - tmp2 = Fact * - & xyz2D0(iVec,ia-1,ib,ic,id,Ind2(3)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(3),Ind1(3)) = - & tmp1 + tmp2 - 521 Continue - Fact = Fact + tOne - 511 Continue - End If - Else If (nVec.eq.2) Then - Do 601 iVec = 1, nT*nRys - xyz2D1(iVec,0,ib,ic,id,Ind2(1),Ind1(1)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,1,ib,ic,id,Ind2(1)) - xyz2D1(iVec,0,ib,ic,id,Ind2(2),Ind1(2)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,1,ib,ic,id,Ind2(2)) - 601 Continue - If (la.ge.1) Then - Fact = tOne - Do 611 ia = 1, la - Do 621 iVec = 1, nT*nRys - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia+1,ib,ic,id,Ind2(1)) - tmp2 = Fact * - & xyz2D0(iVec,ia-1,ib,ic,id,Ind2(1)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(1),Ind1(1)) = - & tmp1 + tmp2 - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia+1,ib,ic,id,Ind2(2)) - tmp2 = Fact * - & xyz2D0(iVec,ia-1,ib,ic,id,Ind2(2)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(2),Ind1(2)) = - & tmp1 + tmp2 - 621 Continue - Fact = Fact + tOne - 611 Continue - End If - Else If (nVec.eq.1) Then - Do 701 iVec = 1, nT*nRys - xyz2D1(iVec,0,ib,ic,id,Ind2(1),Ind1(1)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,1,ib,ic,id,Ind2(1)) - 701 Continue - If (la.ge.1) Then - Fact = tOne - Do 711 ia = 1, la - Do 721 iVec = 1, nT*nRys - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia+1,ib,ic,id,Ind2(1)) - tmp2 = Fact * - & xyz2D0(iVec,ia-1,ib,ic,id,Ind2(1)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(1),Ind1(1)) = - & tmp1 + tmp2 - 721 Continue - Fact = Fact + tOne - 711 Continue - End If - End If - 301 Continue - 201 Continue - 101 Continue -* -* Differentiate with respect to the second center -* - 211 Continue - If (IfGrad(1,2) .or.IfGrad(2,2) .or. - & IfGrad(3,2)) Then - Call ExpX(Temp ,mZeta,mEta,Beta,One) - Call Exp_2(Scrtch,nRys,nT,Temp,One) -* If (iPrint.ge.99) Call RecPrt( -* & 'Expanded exponents (beta) ',' ',Scrtch, -* & nT,nRys) - End If - nVec = 0 - If (IfGrad(1,2)) Then - nx = nx + 1 - nVec = nVec + 1 - Ind1(nVec) = nx - Ind2(nVec) = 1 - Index(1,2) = nx - End If - If (IfGrad(2,2)) Then - ny = ny + 1 - nVec = nVec + 1 - Ind1(nVec) = ny - Ind2(nVec) = 2 - Index(2,2) = ny - End If - If (IfGrad(3,2)) Then - nz = nz + 1 - nVec = nVec + 1 - Ind1(nVec) = nz - Ind2(nVec) = 3 - Index(3,2) = nz - End If - If (nVec.eq.0) Go To 311 -* - Do 102 id = 0, ld - Do 202 ic = 0, lc - Do 302 ia = 0, la - If (nVec.eq.3) Then - Do 502 iVec = 1, nT*nRys - xyz2D1(iVec,ia,0,ic,id,Ind2(1),Ind1(1)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,1,ic,id,Ind2(1)) - xyz2D1(iVec,ia,0,ic,id,Ind2(2),Ind1(2)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,1,ic,id,Ind2(2)) - xyz2D1(iVec,ia,0,ic,id,Ind2(3),Ind1(3)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,1,ic,id,Ind2(3)) - 502 Continue - If (lb.ge.1) Then - Fact = tOne - Do 512 ib = 1, lb - Do 522 iVec = 1, nT*nRys - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib+1,ic,id,Ind2(1)) - tmp2 = Fact * - & xyz2D0(iVec,ia,ib-1,ic,id,Ind2(1)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(1),Ind1(1)) = - & tmp1 + tmp2 - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib+1,ic,id,Ind2(2)) - tmp2 = Fact * - & xyz2D0(iVec,ia,ib-1,ic,id,Ind2(2)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(2),Ind1(2)) = - & tmp1 + tmp2 - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib+1,ic,id,Ind2(3)) - tmp2 = Fact * - & xyz2D0(iVec,ia,ib-1,ic,id,Ind2(3)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(3),Ind1(3)) = - & tmp1 + tmp2 - 522 Continue - Fact = Fact + tOne - 512 Continue - End If - Else If (nVec.eq.2) Then - Do 602 iVec = 1, nT*nRys - xyz2D1(iVec,ia,0,ic,id,Ind2(1),Ind1(1)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,1,ic,id,Ind2(1)) - xyz2D1(iVec,ia,0,ic,id,Ind2(2),Ind1(2)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,1,ic,id,Ind2(2)) - 602 Continue - If (lb.ge.1) Then - Fact = tOne - Do 612 ib = 1, lb - Do 622 iVec = 1, nT*nRys - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib+1,ic,id,Ind2(1)) - tmp2 = Fact * - & xyz2D0(iVec,ia,ib-1,ic,id,Ind2(1)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(1),Ind1(1)) = - & tmp1 + tmp2 - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib+1,ic,id,Ind2(2)) - tmp2 = Fact * - & xyz2D0(iVec,ia,ib-1,ic,id,Ind2(2)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(2),Ind1(2)) = - & tmp1 + tmp2 - 622 Continue - Fact = Fact + tOne - 612 Continue - End If - Else If (nVec.eq.1) Then - Do 702 iVec = 1, nT*nRys - xyz2D1(iVec,ia,0,ic,id,Ind2(1),Ind1(1)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,1,ic,id,Ind2(1)) - 702 Continue - If (lb.ge.1) Then - Fact = tOne - Do 712 ib = 1, lb - Do 722 iVec = 1, nT*nRys - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib+1,ic,id,Ind2(1)) - tmp2 = Fact * - & xyz2D0(iVec,ia,ib-1,ic,id,Ind2(1)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(1),Ind1(1)) = - & tmp1 + tmp2 - 722 Continue - Fact = Fact + tOne - 712 Continue - End If - End If - 302 Continue - 202 Continue - 102 Continue -* -* Differentiate with respect to the third center -* - 311 Continue - If (IfGrad(1,3) .or.IfGrad(2,3) .or. - & IfGrad(3,3)) Then - Call ExpY(Temp ,mZeta,mEta,Gamma,One) - Call Exp_2(Scrtch,nRys,nT,Temp,One) -* If (iPrint.ge.99) Call RecPrt( -* & 'Expanded exponents (gamma)',' ',Scrtch, -* & nT,nRys) - End If - nVec = 0 - If (IfGrad(1,3)) Then - nx = nx + 1 - nVec = nVec + 1 - Ind1(nVec) = nx - Ind2(nVec) = 1 - Index(1,3) = nx - End If - If (IfGrad(2,3)) Then - ny = ny + 1 - nVec = nVec + 1 - Ind1(nVec) = ny - Ind2(nVec) = 2 - Index(2,3) = ny - End If - If (IfGrad(3,3)) Then - nz = nz + 1 - nVec = nVec + 1 - Ind1(nVec) = nz - Ind2(nVec) = 3 - Index(3,3) = nz - End If - If (nVec.eq.0) Go To 411 -* - Do 103 id = 0, ld - Do 203 ib = 0, lb - Do 303 ia = 0, la - If (nVec.eq.3) Then - Do 503 iVec = 1, nT*nRys - xyz2D1(iVec,ia,ib,0,id,Ind2(1),Ind1(1)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,1,id,Ind2(1)) - xyz2D1(iVec,ia,ib,0,id,Ind2(2),Ind1(2)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,1,id,Ind2(2)) - xyz2D1(iVec,ia,ib,0,id,Ind2(3),Ind1(3)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,1,id,Ind2(3)) - 503 Continue - If (lc.ge.1) Then - Fact = tOne - Do 513 ic = 1, lc - Do 523 iVec = 1, nT*nRys - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic+1,id,Ind2(1)) - tmp2 = Fact * - & xyz2D0(iVec,ia,ib,ic-1,id,Ind2(1)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(1),Ind1(1)) = - & tmp1 + tmp2 - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic+1,id,Ind2(2)) - tmp2 = Fact * - & xyz2D0(iVec,ia,ib,ic-1,id,Ind2(2)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(2),Ind1(2)) = - & tmp1 + tmp2 - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic+1,id,Ind2(3)) - tmp2 = Fact * - & xyz2D0(iVec,ia,ib,ic-1,id,Ind2(3)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(3),Ind1(3)) = - & tmp1 + tmp2 - 523 Continue - Fact = Fact + tOne - 513 Continue - End If - Else If (nVec.eq.2) Then - Do 603 iVec = 1, nT*nRys - xyz2D1(iVec,ia,ib,0,id,Ind2(1),Ind1(1)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,1,id,Ind2(1)) - xyz2D1(iVec,ia,ib,0,id,Ind2(2),Ind1(2)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,1,id,Ind2(2)) - 603 Continue - If (lc.ge.1) Then - Fact = tOne - Do 613 ic = 1, lc - Do 623 iVec = 1, nT*nRys - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic+1,id,Ind2(1)) - tmp2 = Fact * - & xyz2D0(iVec,ia,ib,ic-1,id,Ind2(1)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(1),Ind1(1)) = - & tmp1 + tmp2 - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic+1,id,Ind2(2)) - tmp2 = Fact * - & xyz2D0(iVec,ia,ib,ic-1,id,Ind2(2)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(2),Ind1(2)) = - & tmp1 + tmp2 - 623 Continue - Fact = Fact + tOne - 613 Continue - End If - Else If (nVec.eq.1) Then - Do 703 iVec = 1, nT*nRys - xyz2D1(iVec,ia,ib,0,id,Ind2(1),Ind1(1)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,1,id,Ind2(1)) - 703 Continue - If (lc.ge.1) Then - Fact = tOne - Do 713 ic = 1, lc - Do 723 iVec = 1, nT*nRys - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic+1,id,Ind2(1)) - tmp2 = Fact * - & xyz2D0(iVec,ia,ib,ic-1,id,Ind2(1)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(1),Ind1(1)) = - & tmp1 + tmp2 - 723 Continue - Fact = Fact + tOne - 713 Continue - End If - End If - 303 Continue - 203 Continue - 103 Continue -* -* Differentiate with respect to the fourth center -* - 411 Continue - If (IfGrad(1,4) .or. IfGrad(2,4) .or. - & IfGrad(3,4)) Then - Call ExpY(Temp ,mZeta,mEta,Delta,One) - Call Exp_2(Scrtch,nRys,nT,Temp,One) -* If (iPrint.ge.99) Call RecPrt( -* & 'Expanded exponents (delta)',' ',Scrtch, -* & nT,nRys) - End If - nVec = 0 - If (IfGrad(1,4)) Then - nx = nx + 1 - nVec = nVec + 1 - Ind1(nVec) = nx - Ind2(nVec) = 1 - Index(1,4) = nx - End If - If (IfGrad(2,4)) Then - ny = ny + 1 - nVec = nVec + 1 - Ind1(nVec) = ny - Ind2(nVec) = 2 - Index(2,4) = ny - End If - If (IfGrad(3,4)) Then - nz = nz + 1 - nVec = nVec + 1 - Ind1(nVec) = nz - Ind2(nVec) = 3 - Index(3,4) = nz - End If - If (nVec.eq.0) Go To 999 -* - Do 104 ic = 0, lc - Do 204 ib = 0, lb - Do 304 ia = 0, la - If (nVec.eq.3) Then - Do 504 iVec = 1, nT*nRys - xyz2D1(iVec,ia,ib,ic,0,Ind2(1),Ind1(1)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic,1,Ind2(1)) - xyz2D1(iVec,ia,ib,ic,0,Ind2(2),Ind1(2)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic,1,Ind2(2)) - xyz2D1(iVec,ia,ib,ic,0,Ind2(3),Ind1(3)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic,1,Ind2(3)) - 504 Continue - If (ld.ge.1) Then - Fact = tOne - Do 514 id = 1, ld - Do 524 iVec = 1, nT*nRys - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic,id+1,Ind2(1)) - tmp2 = Fact * - & xyz2D0(iVec,ia,ib,ic,id-1,Ind2(1)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(1),Ind1(1)) = - & tmp1 + tmp2 - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic,id+1,Ind2(2)) - tmp2 = Fact * - & xyz2D0(iVec,ia,ib,ic,id-1,Ind2(2)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(2),Ind1(2)) = - & tmp1 + tmp2 - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic,id+1,Ind2(3)) - tmp2 = Fact * - & xyz2D0(iVec,ia,ib,ic,id-1,Ind2(3)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(3),Ind1(3)) = - & tmp1 + tmp2 - 524 Continue - Fact = Fact + tOne - 514 Continue - End If - Else If (nVec.eq.2) Then - Do 604 iVec = 1, nT*nRys - xyz2D1(iVec,ia,ib,ic,0,Ind2(1),Ind1(1)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic,1,Ind2(1)) - xyz2D1(iVec,ia,ib,ic,0,Ind2(2),Ind1(2)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic,1,Ind2(2)) - 604 Continue - If (ld.ge.1) Then - Fact = tOne - Do 614 id = 1, ld - Do 624 iVec = 1, nT*nRys - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic,id+1,Ind2(1)) - tmp2 = Fact * - & xyz2D0(iVec,ia,ib,ic,id-1,Ind2(1)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(1),Ind1(1)) = - & tmp1 + tmp2 - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic,id+1,Ind2(2)) - tmp2 = Fact * - & xyz2D0(iVec,ia,ib,ic,id-1,Ind2(2)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(2),Ind1(2)) = - & tmp1 + tmp2 - 624 Continue - Fact = Fact + tOne - 614 Continue - End If - Else If (nVec.eq.1) Then - Do 704 iVec = 1, nT*nRys - xyz2D1(iVec,ia,ib,ic,0,Ind2(1),Ind1(1)) = - & tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic,1,Ind2(1)) - 704 Continue - If (ld.ge.1) Then - Fact = tOne - Do 714 id = 1, ld - Do 724 iVec = 1, nT*nRys - tmp1 = tTwo * Scrtch(iVec) * - & xyz2D0(iVec,ia,ib,ic,id+1,Ind2(1)) - tmp2 = Fact * - & xyz2D0(iVec,ia,ib,ic,id-1,Ind2(1)) - xyz2D1(iVec,ia,ib,ic,id,Ind2(1),Ind1(1)) = - & tmp1 + tmp2 - 724 Continue - Fact = Fact + tOne - 714 Continue - End If - End If - 304 Continue - 204 Continue - 104 Continue -* - 999 Continue -* -*-----Sum over common centers -* - Do 1000 iCent = 1, 3 - Do 2000 jCent = iCent+1, 4 - If (EQ(Coora(1,iCent),Coora(1,jCent))) Then - Do 3000 iCar = 1, 3 -* - If (IfGrad(iCar,iCent) .and. - & IfGrad(iCar,jCent) ) Then -*--------------------Change flags so gradient will not be assembled and -* that there will be no contribution to the gradient. - IfGrad(iCar,jCent) = .False. - IndGrd(iCar,jCent) = 0 - i1 = Index(iCar,iCent) - i2 = Index(iCar,jCent) - Call DaXpY_(nRys*nT*(la+1)*(lb+1)*(lc+1)*(ld+1), - & One, - & xyz2D1(1,0,0,0,0,iCar,i2),1, - & xyz2D1(1,0,0,0,0,iCar,i1),1) - End If -* - 3000 Continue - End If - 2000 Continue - 1000 Continue -* -c If (iPrint.ge.49) Then -c Do 900 iCn = 1, 4 -c Do 901 iCar = 1, 3 -c If (IfGrad(iCar,iCn)) Then -c ij = Index(iCar,iCn) -c Do 902 ia = 0, la -c Do 903 ib = 0, lb -c Do 904 ic = 0, lc -c Do 905 id = 0, ld -c Write -c & (Label,'(A,4(I2,'',''),A,'','',I2,A)') -c & ' xyz2D1(', -c & ia,ib,ic,id,ch(iCar),iCn,')' -c If (iPrint.ge.99) Then -c Call RecPrt(Label,' ',xyz2d1(1,ia,ib, -c & ic,id,iCar,ij),nT,nRys) -c Else -c Write (*,'(A)') Label -c Write (*,*) DDot_(nT*nRys, -c & xyz2d1(1,ia,ib,ic,id,iCar,ij),1, -c & xyz2d1(1,ia,ib,ic,id,iCar,ij),1) -c End If -c905 Continue -c904 Continue -c903 Continue -c902 Continue -c End If -c901 Continue -c900 Continue -c End If - Return - End diff -Nru openmolcas-22.02/src/rys_util/rys2dg.F90 openmolcas-22.10/src/rys_util/rys2dg.F90 --- openmolcas-22.02/src/rys_util/rys2dg.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys2dg.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,433 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1991, Roland Lindh * +!*********************************************************************** + +subroutine Rys2Dg(xyz2D0,nT,nRys,la,lb,lc,ld,xyz2D1,IfGrad,IndGrd,Coora,Alpha,Beta,Gmma,Delta,nZeta,nEta,Scrtch,Temp,Indx,ExpX, & + ExpY,mZeta,mEta) +!*********************************************************************** +! * +! Object: to compute the gradients of the 2D-integrals. * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, * +! University of Lund, SWEDEN * +! October '91 * +!*********************************************************************** + +use Constants, only: One, Two +use Definitions, only: wp, iwp +#ifdef _DEBUGPRINT_ +use Definitions, only: u6 +#endif + +implicit none +integer(kind=iwp), intent(in) :: nT, nRys, la, lb, lc, ld, nZeta, nEta, mZeta, mEta +real(kind=wp), intent(in) :: xyz2D0(nRys*nT,0:la+1,0:lb+1,0:lc+1,0:ld+1,3), Coora(3,4), Alpha(nZeta), Beta(nZeta), Gmma(nEta), & + Delta(nEta) +real(kind=wp), intent(out) :: xyz2D1(nRys*nT,0:la,0:lb,0:lc,0:ld,3,3), Scrtch(nRys*nT), Temp(nT) +logical(kind=iwp), intent(inout) :: IfGrad(3,4) +integer(kind=iwp), intent(inout) :: IndGrd(3,4), Indx(3,4) +external :: ExpX, ExpY +integer(kind=iwp) :: i1, i2, ia, ib, ic, iCar, iCent, id, Ind1(3), Ind2(3), jCent, nVec, nx, ny, nz +real(kind=wp) :: Fact +logical(kind=iwp), external :: EQ + +#ifdef _DEBUGPRINT_ +iRout = 249 +iPrint = nPrint(iRout) +if (iPrint >= 99) then + call RecPrt(' In Rys2Dg: Alpha',' ',Alpha,1,nZeta) + call RecPrt(' In Rys2Dg: Beta ',' ',Beta,1,nZeta) + call RecPrt(' In Rys2Dg: Gamma',' ',Gmma,1,nEta) + call RecPrt(' In Rys2Dg: Delta',' ',Delta,1,nEta) + write(u6,*) ' IfGrad=',IfGrad + write(u6,*) ' IndGrd=',IndGrd +end if +#endif +nx = 0 +ny = 0 +nz = 0 +Indx(:,:) = 0 + +! Differentiate with respect to the first center + +if (IfGrad(1,1) .or. IfGrad(2,1) .or. IfGrad(3,1)) then + call ExpX(Temp,mZeta,mEta,Alpha,One) + call Exp_2(Scrtch,nRys,nT,Temp,One) + !if (iPrint >= 99) call RecPrt('Expanded exponents (alpha)',' ',Scrtch,nT,nRys) +end if +nVec = 0 +if (IfGrad(1,1)) then + nx = nx+1 + nVec = nVec+1 + Ind1(nVec) = nx + Ind2(nVec) = 1 + Indx(1,1) = nx +end if +if (IfGrad(2,1)) then + ny = ny+1 + nVec = nVec+1 + Ind1(nVec) = ny + Ind2(nVec) = 2 + Indx(2,1) = ny +end if +if (IfGrad(3,1)) then + nz = nz+1 + nVec = nVec+1 + Ind1(nVec) = nz + Ind2(nVec) = 3 + Indx(3,1) = nz +end if + +if (nVec /= 0) then + + do id=0,ld + do ic=0,lc + do ib=0,lb + if (nVec == 3) then + xyz2D1(:,0,ib,ic,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,1,ib,ic,id,Ind2(1)) + xyz2D1(:,0,ib,ic,id,Ind2(2),Ind1(2)) = Two*Scrtch(:)*xyz2D0(:,1,ib,ic,id,Ind2(2)) + xyz2D1(:,0,ib,ic,id,Ind2(3),Ind1(3)) = Two*Scrtch(:)*xyz2D0(:,1,ib,ic,id,Ind2(3)) + if (la >= 1) then + Fact = -One + do ia=1,la + xyz2D1(:,ia,ib,ic,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia+1,ib,ic,id,Ind2(1))+ & + Fact*xyz2D0(:,ia-1,ib,ic,id,Ind2(1)) + xyz2D1(:,ia,ib,ic,id,Ind2(2),Ind1(2)) = Two*Scrtch(:)*xyz2D0(:,ia+1,ib,ic,id,Ind2(2))+ & + Fact*xyz2D0(:,ia-1,ib,ic,id,Ind2(2)) + xyz2D1(:,ia,ib,ic,id,Ind2(3),Ind1(3)) = Two*Scrtch(:)*xyz2D0(:,ia+1,ib,ic,id,Ind2(3))+ & + Fact*xyz2D0(:,ia-1,ib,ic,id,Ind2(3)) + Fact = Fact-One + end do + end if + else if (nVec == 2) then + xyz2D1(:,0,ib,ic,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,1,ib,ic,id,Ind2(1)) + xyz2D1(:,0,ib,ic,id,Ind2(2),Ind1(2)) = Two*Scrtch(:)*xyz2D0(:,1,ib,ic,id,Ind2(2)) + if (la >= 1) then + Fact = -One + do ia=1,la + xyz2D1(:,ia,ib,ic,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia+1,ib,ic,id,Ind2(1))+ & + Fact*xyz2D0(:,ia-1,ib,ic,id,Ind2(1)) + xyz2D1(:,ia,ib,ic,id,Ind2(2),Ind1(2)) = Two*Scrtch(:)*xyz2D0(:,ia+1,ib,ic,id,Ind2(2))+ & + Fact*xyz2D0(:,ia-1,ib,ic,id,Ind2(2)) + Fact = Fact-One + end do + end if + else if (nVec == 1) then + xyz2D1(:,0,ib,ic,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,1,ib,ic,id,Ind2(1)) + if (la >= 1) then + Fact = -One + do ia=1,la + xyz2D1(:,ia,ib,ic,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia+1,ib,ic,id,Ind2(1))+ & + Fact*xyz2D0(:,ia-1,ib,ic,id,Ind2(1)) + Fact = Fact-One + end do + end if + end if + end do + end do + end do + +end if + +! Differentiate with respect to the second center + +if (IfGrad(1,2) .or. IfGrad(2,2) .or. IfGrad(3,2)) then + call ExpX(Temp,mZeta,mEta,Beta,One) + call Exp_2(Scrtch,nRys,nT,Temp,One) + !if (iPrint >= 99) call RecPrt('Expanded exponents (beta) ',' ',Scrtch,nT,nRys) +end if +nVec = 0 +if (IfGrad(1,2)) then + nx = nx+1 + nVec = nVec+1 + Ind1(nVec) = nx + Ind2(nVec) = 1 + Indx(1,2) = nx +end if +if (IfGrad(2,2)) then + ny = ny+1 + nVec = nVec+1 + Ind1(nVec) = ny + Ind2(nVec) = 2 + Indx(2,2) = ny +end if +if (IfGrad(3,2)) then + nz = nz+1 + nVec = nVec+1 + Ind1(nVec) = nz + Ind2(nVec) = 3 + Indx(3,2) = nz +end if + +if (nVec /= 0) then + + do id=0,ld + do ic=0,lc + do ia=0,la + if (nVec == 3) then + xyz2D1(:,ia,0,ic,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia,1,ic,id,Ind2(1)) + xyz2D1(:,ia,0,ic,id,Ind2(2),Ind1(2)) = Two*Scrtch(:)*xyz2D0(:,ia,1,ic,id,Ind2(2)) + xyz2D1(:,ia,0,ic,id,Ind2(3),Ind1(3)) = Two*Scrtch(:)*xyz2D0(:,ia,1,ic,id,Ind2(3)) + if (lb >= 1) then + Fact = -One + do ib=1,lb + xyz2D1(:,ia,ib,ic,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia,ib+1,ic,id,Ind2(1))+ & + Fact*xyz2D0(:,ia,ib-1,ic,id,Ind2(1)) + xyz2D1(:,ia,ib,ic,id,Ind2(2),Ind1(2)) = Two*Scrtch(:)*xyz2D0(:,ia,ib+1,ic,id,Ind2(2))+ & + Fact*xyz2D0(:,ia,ib-1,ic,id,Ind2(2)) + xyz2D1(:,ia,ib,ic,id,Ind2(3),Ind1(3)) = Two*Scrtch(:)*xyz2D0(:,ia,ib+1,ic,id,Ind2(3))+ & + Fact*xyz2D0(:,ia,ib-1,ic,id,Ind2(3)) + Fact = Fact-One + end do + end if + else if (nVec == 2) then + xyz2D1(:,ia,0,ic,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia,1,ic,id,Ind2(1)) + xyz2D1(:,ia,0,ic,id,Ind2(2),Ind1(2)) = Two*Scrtch(:)*xyz2D0(:,ia,1,ic,id,Ind2(2)) + if (lb >= 1) then + Fact = -One + do ib=1,lb + xyz2D1(:,ia,ib,ic,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia,ib+1,ic,id,Ind2(1))+ & + Fact*xyz2D0(:,ia,ib-1,ic,id,Ind2(1)) + xyz2D1(:,ia,ib,ic,id,Ind2(2),Ind1(2)) = Two*Scrtch(:)*xyz2D0(:,ia,ib+1,ic,id,Ind2(2))+ & + Fact*xyz2D0(:,ia,ib-1,ic,id,Ind2(2)) + Fact = Fact-One + end do + end if + else if (nVec == 1) then + xyz2D1(:,ia,0,ic,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia,1,ic,id,Ind2(1)) + if (lb >= 1) then + Fact = -One + do ib=1,lb + xyz2D1(:,ia,ib,ic,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia,ib+1,ic,id,Ind2(1))+ & + Fact*xyz2D0(:,ia,ib-1,ic,id,Ind2(1)) + Fact = Fact-One + end do + end if + end if + end do + end do + end do + +end if + +! Differentiate with respect to the third center + +if (IfGrad(1,3) .or. IfGrad(2,3) .or. IfGrad(3,3)) then + call ExpY(Temp,mZeta,mEta,Gmma,One) + call Exp_2(Scrtch,nRys,nT,Temp,One) + !if (iPrint >= 99) Call RecPrt('Expanded exponents (Gamma)',' ',Scrtch,nT,nRys) +end if +nVec = 0 +if (IfGrad(1,3)) then + nx = nx+1 + nVec = nVec+1 + Ind1(nVec) = nx + Ind2(nVec) = 1 + Indx(1,3) = nx +end if +if (IfGrad(2,3)) then + ny = ny+1 + nVec = nVec+1 + Ind1(nVec) = ny + Ind2(nVec) = 2 + Indx(2,3) = ny +end if +if (IfGrad(3,3)) then + nz = nz+1 + nVec = nVec+1 + Ind1(nVec) = nz + Ind2(nVec) = 3 + Indx(3,3) = nz +end if + +if (nVec /= 0) then + + do id=0,ld + do ib=0,lb + do ia=0,la + if (nVec == 3) then + xyz2D1(:,ia,ib,0,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,1,id,Ind2(1)) + xyz2D1(:,ia,ib,0,id,Ind2(2),Ind1(2)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,1,id,Ind2(2)) + xyz2D1(:,ia,ib,0,id,Ind2(3),Ind1(3)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,1,id,Ind2(3)) + if (lc >= 1) then + Fact = -One + do ic=1,lc + xyz2D1(:,ia,ib,ic,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,ic+1,id,Ind2(1))+ & + Fact*xyz2D0(:,ia,ib,ic-1,id,Ind2(1)) + xyz2D1(:,ia,ib,ic,id,Ind2(2),Ind1(2)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,ic+1,id,Ind2(2))+ & + Fact*xyz2D0(:,ia,ib,ic-1,id,Ind2(2)) + xyz2D1(:,ia,ib,ic,id,Ind2(3),Ind1(3)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,ic+1,id,Ind2(3))+ & + Fact*xyz2D0(:,ia,ib,ic-1,id,Ind2(3)) + Fact = Fact-One + end do + end if + else if (nVec == 2) then + xyz2D1(:,ia,ib,0,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,1,id,Ind2(1)) + xyz2D1(:,ia,ib,0,id,Ind2(2),Ind1(2)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,1,id,Ind2(2)) + if (lc >= 1) then + Fact = -One + do ic=1,lc + xyz2D1(:,ia,ib,ic,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,ic+1,id,Ind2(1))+ & + Fact*xyz2D0(:,ia,ib,ic-1,id,Ind2(1)) + xyz2D1(:,ia,ib,ic,id,Ind2(2),Ind1(2)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,ic+1,id,Ind2(2))+ & + Fact*xyz2D0(:,ia,ib,ic-1,id,Ind2(2)) + Fact = Fact-One + end do + end if + else if (nVec == 1) then + xyz2D1(:,ia,ib,0,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,1,id,Ind2(1)) + if (lc >= 1) then + Fact = -One + do ic=1,lc + xyz2D1(:,ia,ib,ic,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,ic+1,id,Ind2(1))+ & + Fact*xyz2D0(:,ia,ib,ic-1,id,Ind2(1)) + Fact = Fact-One + end do + end if + end if + end do + end do + end do + +end if + +! Differentiate with respect to the fourth center + +if (IfGrad(1,4) .or. IfGrad(2,4) .or. IfGrad(3,4)) then + call ExpY(Temp,mZeta,mEta,Delta,One) + call Exp_2(Scrtch,nRys,nT,Temp,One) + !if (iPrint >= 99) call RecPrt('Expanded exponents (delta)',' ',Scrtch,nT,nRys) +end if +nVec = 0 +if (IfGrad(1,4)) then + nx = nx+1 + nVec = nVec+1 + Ind1(nVec) = nx + Ind2(nVec) = 1 + Indx(1,4) = nx +end if +if (IfGrad(2,4)) then + ny = ny+1 + nVec = nVec+1 + Ind1(nVec) = ny + Ind2(nVec) = 2 + Indx(2,4) = ny +end if +if (IfGrad(3,4)) then + nz = nz+1 + nVec = nVec+1 + Ind1(nVec) = nz + Ind2(nVec) = 3 + Indx(3,4) = nz +end if + +if (nVec /= 0) then + + do ic=0,lc + do ib=0,lb + do ia=0,la + if (nVec == 3) then + xyz2D1(:,ia,ib,ic,0,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,ic,1,Ind2(1)) + xyz2D1(:,ia,ib,ic,0,Ind2(2),Ind1(2)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,ic,1,Ind2(2)) + xyz2D1(:,ia,ib,ic,0,Ind2(3),Ind1(3)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,ic,1,Ind2(3)) + if (ld >= 1) then + Fact = -One + do id=1,ld + xyz2D1(:,ia,ib,ic,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,ic,id+1,Ind2(1))+ & + Fact*xyz2D0(:,ia,ib,ic,id-1,Ind2(1)) + xyz2D1(:,ia,ib,ic,id,Ind2(2),Ind1(2)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,ic,id+1,Ind2(2))+ & + Fact*xyz2D0(:,ia,ib,ic,id-1,Ind2(2)) + xyz2D1(:,ia,ib,ic,id,Ind2(3),Ind1(3)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,ic,id+1,Ind2(3))+ & + Fact*xyz2D0(:,ia,ib,ic,id-1,Ind2(3)) + Fact = Fact-One + end do + end if + else if (nVec == 2) then + xyz2D1(:,ia,ib,ic,0,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,ic,1,Ind2(1)) + xyz2D1(:,ia,ib,ic,0,Ind2(2),Ind1(2)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,ic,1,Ind2(2)) + if (ld >= 1) then + Fact = -One + do id=1,ld + xyz2D1(:,ia,ib,ic,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,ic,id+1,Ind2(1))+ & + Fact*xyz2D0(:,ia,ib,ic,id-1,Ind2(1)) + xyz2D1(:,ia,ib,ic,id,Ind2(2),Ind1(2)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,ic,id+1,Ind2(2))+ & + Fact*xyz2D0(:,ia,ib,ic,id-1,Ind2(2)) + Fact = Fact-One + end do + end if + else if (nVec == 1) then + xyz2D1(:,ia,ib,ic,0,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,ic,1,Ind2(1)) + if (ld >= 1) then + Fact = -One + do id=1,ld + xyz2D1(:,ia,ib,ic,id,Ind2(1),Ind1(1)) = Two*Scrtch(:)*xyz2D0(:,ia,ib,ic,id+1,Ind2(1))+ & + Fact*xyz2D0(:,ia,ib,ic,id-1,Ind2(1)) + Fact = Fact-One + end do + end if + end if + end do + end do + end do + +end if + +! Sum over common centers + +do iCent=1,3 + do jCent=iCent+1,4 + if (EQ(Coora(1,iCent),Coora(1,jCent))) then + do iCar=1,3 + + if (IfGrad(iCar,iCent) .and. IfGrad(iCar,jCent)) then + ! Change flags so gradient will not be assembled and + ! that there will be no contribution to the gradient. + IfGrad(iCar,jCent) = .false. + IndGrd(iCar,jCent) = 0 + i1 = Indx(iCar,iCent) + i2 = Indx(iCar,jCent) + xyz2D1(:,:,:,:,:,iCar,i1) = xyz2D1(:,:,:,:,:,iCar,i1)+xyz2D1(:,:,:,:,:,iCar,i2) + end if + + end do + end if + end do +end do + +!if (iPrint >= 49) then +! do iCn=1,4 +! do iCar=1,3 +! if (IfGrad(iCar,iCn)) then +! ij = Indx(iCar,iCn) +! do ia=0,la +! do ib=0,lb +! do ic=0,lc +! do id=0,ld +! write(Label,'(A,4(I2,'',''),A,'','',I2,A)') ' xyz2D1(',ia,ib,ic,id,ch(iCar),iCn,')' +! if (iPrint >= 99) then +! call RecPrt(Label,' ',xyz2d1(1,ia,ib,ic,id,iCar,ij),nT,nRys) +! else +! write(u6,'(A)') Label +! write(u6,*) DDot_(nT*nRys,xyz2d1(1,ia,ib,ic,id,iCar,ij),1,xyz2d1(1,ia,ib,ic,id,iCar,ij),1) +! end if +! end do +! end do +! end do +! end do +! end if +! end do +! end do +!end if + +return + +end subroutine Rys2Dg diff -Nru openmolcas-22.02/src/rys_util/rys33.f openmolcas-22.10/src/rys_util/rys33.f --- openmolcas-22.02/src/rys_util/rys33.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys33.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,70 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Rys33(Arg,nArg,Root,Weight,iPntr,nPntr, - & x0,nMax,R6,R5,R4,R3,R2,R1,R0, - & W6,W5,W4,W3,W2,W1,W0,ddx, - & HerW,HerR2,TMax) -************************************************************************ -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* September '90 * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 Arg(nArg), Root(3,nArg), Weight(3,nArg), x0(nMax), - & R6(nMax,3), R5(nMax,3), - & R4(nMax,3), R3(nMax,3), R2(nMax,3), R1(nMax,3), R0(nMax,3), - & W6(nMax,3), W5(nMax,3), - & W4(nMax,3), W3(nMax,3), W2(nMax,3), W1(nMax,3), W0(nMax,3), - & HerW(3), HerR2(3) - Integer iPntr(nPntr) -* - xdInv=One/ddx - dddx=ddx/10d0 + ddx - Do iArg = 1, nArg - If (Arg(iArg).lt.TMax) Then - n = iPntr(Int((Arg(iArg)+dddx)*xdInv)) - z = Arg(iArg) - x0(n) - r = (((((R6(n,1)*z+R5(n,1))*z+R4(n,1))*z+R3(n,1))*z+R2(n,1)) - & *z+R1(n,1))*z+R0(n,1) - Root(1,iArg)= r - r = (((((R6(n,2)*z+R5(n,2))*z+R4(n,2))*z+R3(n,2))*z+R2(n,2)) - & *z+R1(n,2))*z+R0(n,2) - Root(2,iArg)= r - r = (((((R6(n,3)*z+R5(n,3))*z+R4(n,3))*z+R3(n,3))*z+R2(n,3)) - & *z+R1(n,3))*z+R0(n,3) - Root(3,iArg)= r - r = (((((W6(n,1)*z+W5(n,1))*z+W4(n,1))*z+W3(n,1))*z+W2(n,1)) - & *z+W1(n,1))*z+W0(n,1) - Weight(1,iArg) = r - r = (((((W6(n,2)*z+W5(n,2))*z+W4(n,2))*z+W3(n,2))*z+W2(n,2)) - & *z+W1(n,2))*z+W0(n,2) - Weight(2,iArg) = r - r = (((((W6(n,3)*z+W5(n,3))*z+W4(n,3))*z+W3(n,3))*z+W2(n,3)) - & *z+W1(n,3))*z+W0(n,3) - Weight(3,iArg) = r - Else - ai = 1.0D0/Arg(iArg) - si = Sqrt(ai) - Root(1,iArg) = HerR2(1)*ai - Root(2,iArg) = HerR2(2)*ai - Root(3,iArg) = HerR2(3)*ai - Weight(1,iArg) = HerW(1)*si - Weight(2,iArg) = HerW(2)*si - Weight(3,iArg) = HerW(3)*si - End If - End Do -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/rys33.F90 openmolcas-22.10/src/rys_util/rys33.F90 --- openmolcas-22.02/src/rys_util/rys33.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys33.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,52 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Rys33(Arg,nArg,Root,Weight,iPntr,nPntr,x0,nMax,R6,R5,R4,R3,R2,R1,R0,W6,W5,W4,W3,W2,W1,W0,ddx,HerW,HerR2,TMax) +!*********************************************************************** +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! September '90 * +!*********************************************************************** + +use Constants, only: One, Ten +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArg, nPntr, iPntr(nPntr), nMax +real(kind=wp), intent(in) :: Arg(nArg), x0(nMax), R6(nMax,3), R5(nMax,3), R4(nMax,3), R3(nMax,3), R2(nMax,3), R1(nMax,3), & + R0(nMax,3), W6(nMax,3), W5(nMax,3), W4(nMax,3), W3(nMax,3), W2(nMax,3), W1(nMax,3), W0(nMax,3), ddx, & + HerW(3), HerR2(3), TMax +real(kind=wp), intent(out) :: Root(3,nArg), Weight(3,nArg) +integer(kind=iwp) :: iArg, n +real(kind=wp) :: ai, dddx, si, xdInv, z + +xdInv = One/ddx +dddx = ddx/Ten+ddx +do iArg=1,nArg + if (Arg(iArg) < TMax) then + n = iPntr(int((Arg(iArg)+dddx)*xdInv)) + z = Arg(iArg)-x0(n) + Root(:,iArg) = (((((R6(n,:)*z+R5(n,:))*z+R4(n,:))*z+R3(n,:))*z+R2(n,:))*z+R1(n,:))*z+R0(n,:) + Weight(:,iArg) = (((((W6(n,:)*z+W5(n,:))*z+W4(n,:))*z+W3(n,:))*z+W2(n,:))*z+W1(n,:))*z+W0(n,:) + else + ai = One/Arg(iArg) + si = sqrt(ai) + Root(:,iArg) = HerR2(:)*ai + Weight(:,iArg) = HerW(:)*si + end if +end do + +return + +end subroutine Rys33 diff -Nru openmolcas-22.02/src/rys_util/rys44.f openmolcas-22.10/src/rys_util/rys44.f --- openmolcas-22.02/src/rys_util/rys44.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys44.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,77 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Rys44(Arg,nArg,Root,Weight,iPntr,nPntr, - & x0,nMax,R6,R5,R4,R3,R2,R1,R0, - & W6,W5,W4,W3,W2,W1,W0,ddx, - & HerW,HerR2,TMax) -************************************************************************ -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* September '90 * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 Arg(nArg), Root(4,nArg), Weight(4,nArg), x0(nMax), - & R6(nMax,4), R5(nMax,4), - & R4(nMax,4), R3(nMax,4), R2(nMax,4), R1(nMax,4), R0(nMax,4), - & W6(nMax,4), W5(nMax,4), - & W4(nMax,4), W3(nMax,4), W2(nMax,4), W1(nMax,4), W0(nMax,4), - & HerW(4), HerR2(4) - Integer iPntr(nPntr) -* - xdInv=One/ddx - dddx=ddx/10d0 + ddx - Do iArg = 1, nArg - If (Arg(iArg).lt.TMax) Then - n = iPntr(Int((Arg(iArg)+dddx)*xdInv)) - z = Arg(iArg) - x0(n) - r = (((((R6(n,1)*z+R5(n,1))*z+R4(n,1))*z+R3(n,1))*z+R2(n,1)) - & *z+R1(n,1))*z+R0(n,1) - Root(1,iArg)= r - r = (((((R6(n,2)*z+R5(n,2))*z+R4(n,2))*z+R3(n,2))*z+R2(n,2)) - & *z+R1(n,2))*z+R0(n,2) - Root(2,iArg)= r - r = (((((R6(n,3)*z+R5(n,3))*z+R4(n,3))*z+R3(n,3))*z+R2(n,3)) - & *z+R1(n,3))*z+R0(n,3) - Root(3,iArg)= r - r = (((((R6(n,4)*z+R5(n,4))*z+R4(n,4))*z+R3(n,4))*z+R2(n,4)) - & *z+R1(n,4))*z+R0(n,4) - Root(4,iArg)= r - r = (((((W6(n,1)*z+W5(n,1))*z+W4(n,1))*z+W3(n,1))*z+W2(n,1)) - & *z+W1(n,1))*z+W0(n,1) - Weight(1,iArg) = r - r = (((((W6(n,2)*z+W5(n,2))*z+W4(n,2))*z+W3(n,2))*z+W2(n,2)) - & *z+W1(n,2))*z+W0(n,2) - Weight(2,iArg) = r - r = (((((W6(n,3)*z+W5(n,3))*z+W4(n,3))*z+W3(n,3))*z+W2(n,3)) - & *z+W1(n,3))*z+W0(n,3) - Weight(3,iArg) = r - r = (((((W6(n,4)*z+W5(n,4))*z+W4(n,4))*z+W3(n,4))*z+W2(n,4)) - & *z+W1(n,4))*z+W0(n,4) - Weight(4,iArg) = r - Else - ai = 1.0D0/Arg(iArg) - si = Sqrt(ai) - Root(1,iArg) = HerR2(1)*ai - Root(2,iArg) = HerR2(2)*ai - Root(3,iArg) = HerR2(3)*ai - Root(4,iArg) = HerR2(4)*ai - Weight(1,iArg) = HerW(1)*si - Weight(2,iArg) = HerW(2)*si - Weight(3,iArg) = HerW(3)*si - Weight(4,iArg) = HerW(4)*si - End If - End Do - Return - End diff -Nru openmolcas-22.02/src/rys_util/rys44.F90 openmolcas-22.10/src/rys_util/rys44.F90 --- openmolcas-22.02/src/rys_util/rys44.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys44.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,52 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Rys44(Arg,nArg,Root,Weight,iPntr,nPntr,x0,nMax,R6,R5,R4,R3,R2,R1,R0,W6,W5,W4,W3,W2,W1,W0,ddx,HerW,HerR2,TMax) +!*********************************************************************** +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! September '90 * +!*********************************************************************** + +use Constants, only: One, Ten +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArg, nPntr, iPntr(nPntr), nMax +real(kind=wp), intent(in) :: Arg(nArg), x0(nMax), R6(nMax,4), R5(nMax,4), R4(nMax,4), R3(nMax,4), R2(nMax,4), R1(nMax,4), & + R0(nMax,4), W6(nMax,4), W5(nMax,4), W4(nMax,4), W3(nMax,4), W2(nMax,4), W1(nMax,4), W0(nMax,4), ddx, & + HerW(4), HerR2(4), TMax +real(kind=wp), intent(out) :: Root(4,nArg), Weight(4,nArg) +integer(kind=iwp) :: iArg, n +real(kind=wp) :: ai, dddx, si, xdInv, z + +xdInv = One/ddx +dddx = ddx/Ten+ddx +do iArg=1,nArg + if (Arg(iArg) < TMax) then + n = iPntr(int((Arg(iArg)+dddx)*xdInv)) + z = Arg(iArg)-x0(n) + Root(:,iArg) = (((((R6(n,:)*z+R5(n,:))*z+R4(n,:))*z+R3(n,:))*z+R2(n,:))*z+R1(n,:))*z+R0(n,:) + Weight(:,iArg) = (((((W6(n,:)*z+W5(n,:))*z+W4(n,:))*z+W3(n,:))*z+W2(n,:))*z+W1(n,:))*z+W0(n,:) + else + ai = One/Arg(iArg) + si = sqrt(ai) + Root(:,iArg) = HerR2(:)*ai + Weight(:,iArg) = HerW(:)*si + end if +end do + +return + +end subroutine Rys44 diff -Nru openmolcas-22.02/src/rys_util/rys55.f openmolcas-22.10/src/rys_util/rys55.f --- openmolcas-22.02/src/rys_util/rys55.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys55.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,85 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Rys55(Arg,nArg,Root,Weight,iPntr,nPntr, - & x0,nMax,R6,R5,R4,R3,R2,R1,R0, - & W6,W5,W4,W3,W2,W1,W0,ddx, - & HerW,HerR2,TMax) -************************************************************************ -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* September '90 * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 Arg(nArg), Root(5,nArg), Weight(5,nArg), x0(nMax), - & R6(nMax,5), R5(nMax,5), - & R4(nMax,5), R3(nMax,5), R2(nMax,5), R1(nMax,5), R0(nMax,5), - & W6(nMax,5), W5(nMax,5), - & W4(nMax,5), W3(nMax,5), W2(nMax,5), W1(nMax,5), W0(nMax,5), - & HerW(5), HerR2(5) - Integer iPntr(nPntr) -* - xdInv=One/ddx - dddx=ddx/10d0 + ddx - Do iArg = 1, nArg - If (ARg(iArg).lt.TMax) Then - n = iPntr(Int((Arg(iArg)+dddx)*xdInv)) - z = Arg(iArg) - x0(n) - r = (((((R6(n,1)*z+R5(n,1))*z+R4(n,1))*z+R3(n,1))*z+R2(n,1)) - & *z+R1(n,1))*z+R0(n,1) - Root(1,iArg)= r - r = (((((R6(n,2)*z+R5(n,2))*z+R4(n,2))*z+R3(n,2))*z+R2(n,2)) - & *z+R1(n,2))*z+R0(n,2) - Root(2,iArg)= r - r = (((((R6(n,3)*z+R5(n,3))*z+R4(n,3))*z+R3(n,3))*z+R2(n,3)) - & *z+R1(n,3))*z+R0(n,3) - Root(3,iArg)= r - r = (((((R6(n,4)*z+R5(n,4))*z+R4(n,4))*z+R3(n,4))*z+R2(n,4)) - & *z+R1(n,4))*z+R0(n,4) - Root(4,iArg)= r - r = (((((R6(n,5)*z+R5(n,5))*z+R4(n,5))*z+R3(n,5))*z+R2(n,5)) - & *z+R1(n,5))*z+R0(n,5) - Root(5,iArg)= r - r = (((((W6(n,1)*z+W5(n,1))*z+W4(n,1))*z+W3(n,1))*z+W2(n,1)) - & *z+W1(n,1))*z+W0(n,1) - Weight(1,iArg) = r - r = (((((W6(n,2)*z+W5(n,2))*z+W4(n,2))*z+W3(n,2))*z+W2(n,2)) - & *z+W1(n,2))*z+W0(n,2) - Weight(2,iArg) = r - r = (((((W6(n,3)*z+W5(n,3))*z+W4(n,3))*z+W3(n,3))*z+W2(n,3)) - & *z+W1(n,3))*z+W0(n,3) - Weight(3,iArg) = r - r = (((((W6(n,4)*z+W5(n,4))*z+W4(n,4))*z+W3(n,4))*z+W2(n,4)) - & *z+W1(n,4))*z+W0(n,4) - Weight(4,iArg) = r - r = (((((W6(n,5)*z+W5(n,5))*z+W4(n,5))*z+W3(n,5))*z+W2(n,5)) - & *z+W1(n,5))*z+W0(n,5) - Weight(5,iArg) = r - Else - ai = 1.0D0/Arg(iArg) - si = Sqrt(ai) - Root(1,iArg) = HerR2(1)*ai - Root(2,iArg) = HerR2(2)*ai - Root(3,iArg) = HerR2(3)*ai - Root(4,iArg) = HerR2(4)*ai - Root(5,iArg) = HerR2(5)*ai - Weight(1,iArg) = HerW(1)*si - Weight(2,iArg) = HerW(2)*si - Weight(3,iArg) = HerW(3)*si - Weight(4,iArg) = HerW(4)*si - Weight(5,iArg) = HerW(5)*si - End If - End Do - Return - End diff -Nru openmolcas-22.02/src/rys_util/rys55.F90 openmolcas-22.10/src/rys_util/rys55.F90 --- openmolcas-22.02/src/rys_util/rys55.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys55.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,52 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Rys55(Arg,nArg,Root,Weight,iPntr,nPntr,x0,nMax,R6,R5,R4,R3,R2,R1,R0,W6,W5,W4,W3,W2,W1,W0,ddx,HerW,HerR2,TMax) +!*********************************************************************** +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! September '90 * +!*********************************************************************** + +use Constants, only: One, Ten +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArg, nPntr, iPntr(nPntr), nMax +real(kind=wp), intent(in) :: Arg(nArg), x0(nMax), R6(nMax,5), R5(nMax,5), R4(nMax,5), R3(nMax,5), R2(nMax,5), R1(nMax,5), & + R0(nMax,5), W6(nMax,5), W5(nMax,5), W4(nMax,5), W3(nMax,5), W2(nMax,5), W1(nMax,5), W0(nMax,5), ddx, & + HerW(5), HerR2(5), TMax +real(kind=wp), intent(out) :: Root(5,nArg), Weight(5,nArg) +integer(kind=iwp) :: iArg, n +real(kind=wp) :: ai, dddx, si, xdInv, z + +xdInv = One/ddx +dddx = ddx/Ten+ddx +do iArg=1,nArg + if (ARg(iArg) < TMax) then + n = iPntr(int((Arg(iArg)+dddx)*xdInv)) + z = Arg(iArg)-x0(n) + Root(:,iArg) = (((((R6(n,:)*z+R5(n,:))*z+R4(n,:))*z+R3(n,:))*z+R2(n,:))*z+R1(n,:))*z+R0(n,:) + Weight(:,iArg) = (((((W6(n,:)*z+W5(n,:))*z+W4(n,:))*z+W3(n,:))*z+W2(n,:))*z+W1(n,:))*z+W0(n,:) + else + ai = One/Arg(iArg) + si = sqrt(ai) + Root(:,iArg) = HerR2(:)*ai + Weight(:,iArg) = HerW(:)*si + end if +end do + +return + +end subroutine Rys55 diff -Nru openmolcas-22.02/src/rys_util/rys66.f openmolcas-22.10/src/rys_util/rys66.f --- openmolcas-22.02/src/rys_util/rys66.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys66.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,93 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Rys66(Arg,nArg,Root,Weight,iPntr,nPntr, - & x0,nMax,R6,R5,R4,R3,R2,R1,R0, - & W6,W5,W4,W3,W2,W1,W0,ddx, - & HerW,HerR2,TMax) -************************************************************************ -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* September '90 * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 Arg(nArg), Root(6,nArg), Weight(6,nArg), x0(nMax), - & R6(nMax,6), R5(nMax,6), - & R4(nMax,6), R3(nMax,6), R2(nMax,6), R1(nMax,6), R0(nMax,6), - & W6(nMax,6), W5(nMax,6), - & W4(nMax,6), W3(nMax,6), W2(nMax,6), W1(nMax,6), W0(nMax,6), - & HerW(6), HerR2(6) - Integer iPntr(nPntr) -* - xdInv=One/ddx - dddx=ddx/10d0 + ddx - Do iArg = 1, nArg - If (Arg(iArg).lt.TMax) Then - n = iPntr(Int((Arg(iArg)+dddx)*xdInv)) - z = Arg(iArg) - x0(n) - r = (((((R6(n,1)*z+R5(n,1))*z+R4(n,1))*z+R3(n,1))*z+R2(n,1)) - & *z+R1(n,1))*z+R0(n,1) - Root(1,iArg)= r - r = (((((R6(n,2)*z+R5(n,2))*z+R4(n,2))*z+R3(n,2))*z+R2(n,2)) - & *z+R1(n,2))*z+R0(n,2) - Root(2,iArg)= r - r = (((((R6(n,3)*z+R5(n,3))*z+R4(n,3))*z+R3(n,3))*z+R2(n,3)) - & *z+R1(n,3))*z+R0(n,3) - Root(3,iArg)= r - r = (((((R6(n,4)*z+R5(n,4))*z+R4(n,4))*z+R3(n,4))*z+R2(n,4)) - & *z+R1(n,4))*z+R0(n,4) - Root(4,iArg)= r - r = (((((R6(n,5)*z+R5(n,5))*z+R4(n,5))*z+R3(n,5))*z+R2(n,5)) - & *z+R1(n,5))*z+R0(n,5) - Root(5,iArg)= r - r = (((((R6(n,6)*z+R5(n,6))*z+R4(n,6))*z+R3(n,6))*z+R2(n,6)) - & *z+R1(n,6))*z+R0(n,6) - Root(6,iArg)= r - r = (((((W6(n,1)*z+W5(n,1))*z+W4(n,1))*z+W3(n,1))*z+W2(n,1)) - & *z+W1(n,1))*z+W0(n,1) - Weight(1,iArg) = r - r = (((((W6(n,2)*z+W5(n,2))*z+W4(n,2))*z+W3(n,2))*z+W2(n,2)) - & *z+W1(n,2))*z+W0(n,2) - Weight(2,iArg) = r - r = (((((W6(n,3)*z+W5(n,3))*z+W4(n,3))*z+W3(n,3))*z+W2(n,3)) - & *z+W1(n,3))*z+W0(n,3) - Weight(3,iArg) = r - r = (((((W6(n,4)*z+W5(n,4))*z+W4(n,4))*z+W3(n,4))*z+W2(n,4)) - & *z+W1(n,4))*z+W0(n,4) - Weight(4,iArg) = r - r = (((((W6(n,5)*z+W5(n,5))*z+W4(n,5))*z+W3(n,5))*z+W2(n,5)) - & *z+W1(n,5))*z+W0(n,5) - Weight(5,iArg) = r - r = (((((W6(n,6)*z+W5(n,6))*z+W4(n,6))*z+W3(n,6))*z+W2(n,6)) - & *z+W1(n,6))*z+W0(n,6) - Weight(6,iArg) = r - Else - ai = 1.0D0/Arg(iArg) - si = Sqrt(ai) - Root(1,iArg) = HerR2(1)*ai - Root(2,iArg) = HerR2(2)*ai - Root(3,iArg) = HerR2(3)*ai - Root(4,iArg) = HerR2(4)*ai - Root(5,iArg) = HerR2(5)*ai - Root(6,iArg) = HerR2(6)*ai - Weight(1,iArg) = HerW(1)*si - Weight(2,iArg) = HerW(2)*si - Weight(3,iArg) = HerW(3)*si - Weight(4,iArg) = HerW(4)*si - Weight(5,iArg) = HerW(5)*si - Weight(6,iArg) = HerW(6)*si - End If - End Do - Return - End diff -Nru openmolcas-22.02/src/rys_util/rys66.F90 openmolcas-22.10/src/rys_util/rys66.F90 --- openmolcas-22.02/src/rys_util/rys66.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys66.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,52 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Rys66(Arg,nArg,Root,Weight,iPntr,nPntr,x0,nMax,R6,R5,R4,R3,R2,R1,R0,W6,W5,W4,W3,W2,W1,W0,ddx,HerW,HerR2,TMax) +!*********************************************************************** +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! September '90 * +!*********************************************************************** + +use Constants, only: One, Ten +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArg, nPntr, iPntr(nPntr), nMax +real(kind=wp), intent(in) :: Arg(nArg), x0(nMax), R6(nMax,6), R5(nMax,6), R4(nMax,6), R3(nMax,6), R2(nMax,6), R1(nMax,6), & + R0(nMax,6), W6(nMax,6), W5(nMax,6), W4(nMax,6), W3(nMax,6), W2(nMax,6), W1(nMax,6), W0(nMax,6), ddx, & + HerW(6), HerR2(6), TMax +real(kind=wp), intent(out) :: Root(6,nArg), Weight(6,nArg) +integer(kind=iwp) :: iArg, n +real(kind=wp) :: ai, dddx, si, xdInv, z + +xdInv = One/ddx +dddx = ddx/Ten+ddx +do iArg=1,nArg + if (Arg(iArg) < TMax) then + n = iPntr(int((Arg(iArg)+dddx)*xdInv)) + z = Arg(iArg)-x0(n) + Root(:,iArg) = (((((R6(n,:)*z+R5(n,:))*z+R4(n,:))*z+R3(n,:))*z+R2(n,:))*z+R1(n,:))*z+R0(n,:) + Weight(:,iArg) = (((((W6(n,:)*z+W5(n,:))*z+W4(n,:))*z+W3(n,:))*z+W2(n,:))*z+W1(n,:))*z+W0(n,:) + else + ai = One/Arg(iArg) + si = sqrt(ai) + Root(:,iArg) = HerR2(:)*ai + Weight(:,iArg) = HerW(:)*si + end if +end do + +return + +end subroutine Rys66 diff -Nru openmolcas-22.02/src/rys_util/rys77.f openmolcas-22.10/src/rys_util/rys77.f --- openmolcas-22.02/src/rys_util/rys77.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys77.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,101 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Rys77(Arg,nArg,Root,Weight,iPntr,nPntr, - & x0,nMax,R6,R5,R4,R3,R2,R1,R0, - & W6,W5,W4,W3,W2,W1,W0,ddx, - & HerW,HerR2,TMax) -************************************************************************ -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* September '90 * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 Arg(nArg), Root(7,nArg), Weight(7,nArg), x0(nMax), - & R6(nMax,7), R5(nMax,7), - & R4(nMax,7), R3(nMax,7), R2(nMax,7), R1(nMax,7), R0(nMax,7), - & W6(nMax,7), W5(nMax,7), - & W4(nMax,7), W3(nMax,7), W2(nMax,7), W1(nMax,7), W0(nMax,7), - & HerW(7), HerR2(7) - Integer iPntr(nPntr) -* - xdInv=One/ddx - dddx=ddx/10d0 + ddx - Do iArg = 1, nArg - If (Arg(iArg).lt.TMax) Then - n = iPntr(Int((Arg(iArg)+dddx)*xdInv)) - z = Arg(iArg) - x0(n) - r = (((((R6(n,1)*z+R5(n,1))*z+R4(n,1))*z+R3(n,1))*z+R2(n,1)) - & *z+R1(n,1))*z+R0(n,1) - Root(1,iArg)= r - r = (((((R6(n,2)*z+R5(n,2))*z+R4(n,2))*z+R3(n,2))*z+R2(n,2)) - & *z+R1(n,2))*z+R0(n,2) - Root(2,iArg)= r - r = (((((R6(n,3)*z+R5(n,3))*z+R4(n,3))*z+R3(n,3))*z+R2(n,3)) - & *z+R1(n,3))*z+R0(n,3) - Root(3,iArg)= r - r = (((((R6(n,4)*z+R5(n,4))*z+R4(n,4))*z+R3(n,4))*z+R2(n,4)) - & *z+R1(n,4))*z+R0(n,4) - Root(4,iArg)= r - r = (((((R6(n,5)*z+R5(n,5))*z+R4(n,5))*z+R3(n,5))*z+R2(n,5)) - & *z+R1(n,5))*z+R0(n,5) - Root(5,iArg)= r - r = (((((R6(n,6)*z+R5(n,6))*z+R4(n,6))*z+R3(n,6))*z+R2(n,6)) - & *z+R1(n,6))*z+R0(n,6) - Root(6,iArg)= r - r = (((((R6(n,7)*z+R5(n,7))*z+R4(n,7))*z+R3(n,7))*z+R2(n,7)) - & *z+R1(n,7))*z+R0(n,7) - Root(7,iArg)= r - r = (((((W6(n,1)*z+W5(n,1))*z+W4(n,1))*z+W3(n,1))*z+W2(n,1)) - & *z+W1(n,1))*z+W0(n,1) - Weight(1,iArg) = r - r = (((((W6(n,2)*z+W5(n,2))*z+W4(n,2))*z+W3(n,2))*z+W2(n,2)) - & *z+W1(n,2))*z+W0(n,2) - Weight(2,iArg) = r - r = (((((W6(n,3)*z+W5(n,3))*z+W4(n,3))*z+W3(n,3))*z+W2(n,3)) - & *z+W1(n,3))*z+W0(n,3) - Weight(3,iArg) = r - r = (((((W6(n,4)*z+W5(n,4))*z+W4(n,4))*z+W3(n,4))*z+W2(n,4)) - & *z+W1(n,4))*z+W0(n,4) - Weight(4,iArg) = r - r = (((((W6(n,5)*z+W5(n,5))*z+W4(n,5))*z+W3(n,5))*z+W2(n,5)) - & *z+W1(n,5))*z+W0(n,5) - Weight(5,iArg) = r - r = (((((W6(n,6)*z+W5(n,6))*z+W4(n,6))*z+W3(n,6))*z+W2(n,6)) - & *z+W1(n,6))*z+W0(n,6) - Weight(6,iArg) = r - r = (((((W6(n,7)*z+W5(n,7))*z+W4(n,7))*z+W3(n,7))*z+W2(n,7)) - & *z+W1(n,7))*z+W0(n,7) - Weight(7,iArg) = r - Else - ai = 1.0D0/Arg(iArg) - si = Sqrt(ai) - Root(1,iArg) = HerR2(1)*ai - Root(2,iArg) = HerR2(2)*ai - Root(3,iArg) = HerR2(3)*ai - Root(4,iArg) = HerR2(4)*ai - Root(5,iArg) = HerR2(5)*ai - Root(6,iArg) = HerR2(6)*ai - Root(7,iArg) = HerR2(7)*ai - Weight(1,iArg) = HerW(1)*si - Weight(2,iArg) = HerW(2)*si - Weight(3,iArg) = HerW(3)*si - Weight(4,iArg) = HerW(4)*si - Weight(5,iArg) = HerW(5)*si - Weight(6,iArg) = HerW(6)*si - Weight(7,iArg) = HerW(7)*si - End If - End Do - Return - End diff -Nru openmolcas-22.02/src/rys_util/rys77.F90 openmolcas-22.10/src/rys_util/rys77.F90 --- openmolcas-22.02/src/rys_util/rys77.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys77.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,52 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Rys77(Arg,nArg,Root,Weight,iPntr,nPntr,x0,nMax,R6,R5,R4,R3,R2,R1,R0,W6,W5,W4,W3,W2,W1,W0,ddx,HerW,HerR2,TMax) +!*********************************************************************** +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! September '90 * +!*********************************************************************** + +use Constants, only: One, Ten +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArg, nPntr, iPntr(nPntr), nMax +real(kind=wp), intent(in) :: Arg(nArg), x0(nMax), R6(nMax,7), R5(nMax,7), R4(nMax,7), R3(nMax,7), R2(nMax,7), R1(nMax,7), & + R0(nMax,7), W6(nMax,7), W5(nMax,7), W4(nMax,7), W3(nMax,7), W2(nMax,7), W1(nMax,7), W0(nMax,7), ddx, & + HerW(7), HerR2(7), TMax +real(kind=wp), intent(out) :: Root(7,nArg), Weight(7,nArg) +integer(kind=iwp) :: iArg, n +real(kind=wp) :: ai, dddx, si, xdInv, z + +xdInv = One/ddx +dddx = ddx/Ten+ddx +do iArg=1,nArg + if (Arg(iArg) < TMax) then + n = iPntr(int((Arg(iArg)+dddx)*xdInv)) + z = Arg(iArg)-x0(n) + Root(:,iArg) = (((((R6(n,:)*z+R5(n,:))*z+R4(n,:))*z+R3(n,:))*z+R2(n,:))*z+R1(n,:))*z+R0(n,:) + Weight(:,iArg) = (((((W6(n,:)*z+W5(n,:))*z+W4(n,:))*z+W3(n,:))*z+W2(n,:))*z+W1(n,:))*z+W0(n,:) + else + ai = One/Arg(iArg) + si = sqrt(ai) + Root(:,iArg) = HerR2(:)*ai + Weight(:,iArg) = HerW(:)*si + end if +end do + +return + +end subroutine Rys77 diff -Nru openmolcas-22.02/src/rys_util/rys88.f openmolcas-22.10/src/rys_util/rys88.f --- openmolcas-22.02/src/rys_util/rys88.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys88.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,109 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Rys88(Arg,nArg,Root,Weight,iPntr,nPntr, - & x0,nMax,R6,R5,R4,R3,R2,R1,R0, - & W6,W5,W4,W3,W2,W1,W0,ddx, - & HerW,HerR2,TMax) -************************************************************************ -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* September '90 * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 Arg(nArg), Root(8,nArg), Weight(8,nArg), x0(nMax), - & R6(nMax,8), R5(nMax,8), - & R4(nMax,8), R3(nMax,8), R2(nMax,8), R1(nMax,8), R0(nMax,8), - & W6(nMax,8), W5(nMax,8), - & W4(nMax,8), W3(nMax,8), W2(nMax,8), W1(nMax,8), W0(nMax,8), - & HerW(8), HerR2(8) - Integer iPntr(nPntr) -* - xdInv=One/ddx - dddx=ddx/10d0 + ddx - Do iArg = 1, nArg - If (Arg(iArg).lt.TMax) Then - n = iPntr(Int((Arg(iArg)+dddx)*xdInv)) - z = Arg(iArg) - x0(n) - r = (((((R6(n,1)*z+R5(n,1))*z+R4(n,1))*z+R3(n,1))*z+R2(n,1)) - & *z+R1(n,1))*z+R0(n,1) - Root(1,iArg)= r - r = (((((R6(n,2)*z+R5(n,2))*z+R4(n,2))*z+R3(n,2))*z+R2(n,2)) - & *z+R1(n,2))*z+R0(n,2) - Root(2,iArg)= r - r = (((((R6(n,3)*z+R5(n,3))*z+R4(n,3))*z+R3(n,3))*z+R2(n,3)) - & *z+R1(n,3))*z+R0(n,3) - Root(3,iArg)= r - r = (((((R6(n,4)*z+R5(n,4))*z+R4(n,4))*z+R3(n,4))*z+R2(n,4)) - & *z+R1(n,4))*z+R0(n,4) - Root(4,iArg)= r - r = (((((R6(n,5)*z+R5(n,5))*z+R4(n,5))*z+R3(n,5))*z+R2(n,5)) - & *z+R1(n,5))*z+R0(n,5) - Root(5,iArg)= r - r = (((((R6(n,6)*z+R5(n,6))*z+R4(n,6))*z+R3(n,6))*z+R2(n,6)) - & *z+R1(n,6))*z+R0(n,6) - Root(6,iArg)= r - r = (((((R6(n,7)*z+R5(n,7))*z+R4(n,7))*z+R3(n,7))*z+R2(n,7)) - & *z+R1(n,7))*z+R0(n,7) - Root(7,iArg)= r - r = (((((R6(n,8)*z+R5(n,8))*z+R4(n,8))*z+R3(n,8))*z+R2(n,8)) - & *z+R1(n,8))*z+R0(n,8) - Root(8,iArg)= r - r = (((((W6(n,1)*z+W5(n,1))*z+W4(n,1))*z+W3(n,1))*z+W2(n,1)) - & *z+W1(n,1))*z+W0(n,1) - Weight(1,iArg) = r - r = (((((W6(n,2)*z+W5(n,2))*z+W4(n,2))*z+W3(n,2))*z+W2(n,2)) - & *z+W1(n,2))*z+W0(n,2) - Weight(2,iArg) = r - r = (((((W6(n,3)*z+W5(n,3))*z+W4(n,3))*z+W3(n,3))*z+W2(n,3)) - & *z+W1(n,3))*z+W0(n,3) - Weight(3,iArg) = r - r = (((((W6(n,4)*z+W5(n,4))*z+W4(n,4))*z+W3(n,4))*z+W2(n,4)) - & *z+W1(n,4))*z+W0(n,4) - Weight(4,iArg) = r - r = (((((W6(n,5)*z+W5(n,5))*z+W4(n,5))*z+W3(n,5))*z+W2(n,5)) - & *z+W1(n,5))*z+W0(n,5) - Weight(5,iArg) = r - r = (((((W6(n,6)*z+W5(n,6))*z+W4(n,6))*z+W3(n,6))*z+W2(n,6)) - & *z+W1(n,6))*z+W0(n,6) - Weight(6,iArg) = r - r = (((((W6(n,7)*z+W5(n,7))*z+W4(n,7))*z+W3(n,7))*z+W2(n,7)) - & *z+W1(n,7))*z+W0(n,7) - Weight(7,iArg) = r - r = (((((W6(n,8)*z+W5(n,8))*z+W4(n,8))*z+W3(n,8))*z+W2(n,8)) - & *z+W1(n,8))*z+W0(n,8) - Weight(8,iArg) = r - Else - ai = 1.0D0/Arg(iArg) - si = Sqrt(ai) - Root(1,iArg) = HerR2(1)*ai - Root(2,iArg) = HerR2(2)*ai - Root(3,iArg) = HerR2(3)*ai - Root(4,iArg) = HerR2(4)*ai - Root(5,iArg) = HerR2(5)*ai - Root(6,iArg) = HerR2(6)*ai - Root(7,iArg) = HerR2(7)*ai - Root(8,iArg) = HerR2(8)*ai - Weight(1,iArg) = HerW(1)*si - Weight(2,iArg) = HerW(2)*si - Weight(3,iArg) = HerW(3)*si - Weight(4,iArg) = HerW(4)*si - Weight(5,iArg) = HerW(5)*si - Weight(6,iArg) = HerW(6)*si - Weight(7,iArg) = HerW(7)*si - Weight(8,iArg) = HerW(8)*si - End If - End Do - Return - End diff -Nru openmolcas-22.02/src/rys_util/rys88.F90 openmolcas-22.10/src/rys_util/rys88.F90 --- openmolcas-22.02/src/rys_util/rys88.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys88.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,52 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Rys88(Arg,nArg,Root,Weight,iPntr,nPntr,x0,nMax,R6,R5,R4,R3,R2,R1,R0,W6,W5,W4,W3,W2,W1,W0,ddx,HerW,HerR2,TMax) +!*********************************************************************** +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! September '90 * +!*********************************************************************** + +use Constants, only: One, Ten +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArg, nPntr, iPntr(nPntr), nMax +real(kind=wp), intent(in) :: Arg(nArg), x0(nMax), R6(nMax,8), R5(nMax,8), R4(nMax,8), R3(nMax,8), R2(nMax,8), R1(nMax,8), & + R0(nMax,8), W6(nMax,8), W5(nMax,8), W4(nMax,8), W3(nMax,8), W2(nMax,8), W1(nMax,8), W0(nMax,8), ddx, & + HerW(8), HerR2(8), TMax +real(kind=wp), intent(out) :: Root(8,nArg), Weight(8,nArg) +integer(kind=iwp) :: iArg, n +real(kind=wp) :: ai, dddx, si, xdInv, z + +xdInv = One/ddx +dddx = ddx/Ten+ddx +do iArg=1,nArg + if (Arg(iArg) < TMax) then + n = iPntr(int((Arg(iArg)+dddx)*xdInv)) + z = Arg(iArg)-x0(n) + Root(:,iArg) = (((((R6(n,:)*z+R5(n,:))*z+R4(n,:))*z+R3(n,:))*z+R2(n,:))*z+R1(n,:))*z+R0(n,:) + Weight(:,iArg) = (((((W6(n,:)*z+W5(n,:))*z+W4(n,:))*z+W3(n,:))*z+W2(n,:))*z+W1(n,:))*z+W0(n,:) + else + ai = One/Arg(iArg) + si = sqrt(ai) + Root(:,iArg) = HerR2(:)*ai + Weight(:,iArg) = HerW(:)*si + end if +end do + +return + +end subroutine Rys88 diff -Nru openmolcas-22.02/src/rys_util/rys99.f openmolcas-22.10/src/rys_util/rys99.f --- openmolcas-22.02/src/rys_util/rys99.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys99.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,117 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Rys99(Arg,nArg,Root,Weight,iPntr,nPntr, - & x0,nMax,R6,R5,R4,R3,R2,R1,R0, - & W6,W5,W4,W3,W2,W1,W0,ddx, - & HerW,HerR2,TMax) -************************************************************************ -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* September '90 * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 Arg(nArg), Root(9,nArg), Weight(9,nArg), x0(nMax), - & R6(nMax,9), R5(nMax,9), - & R4(nMax,9), R3(nMax,9), R2(nMax,9), R1(nMax,9), R0(nMax,9), - & W6(nMax,9), W5(nMax,9), - & W4(nMax,9), W3(nMax,9), W2(nMax,9), W1(nMax,9), W0(nMax,9), - & HerW(9), HerR2(9) - Integer iPntr(nPntr) -* - xdInv=One/ddx - dddx=ddx/10d0 + ddx - Do iArg = 1, nArg - If (Arg(iArg).lt.TMax) Then - n = iPntr(Int((Arg(iArg)+dddx)*xdInv)) - z = Arg(iArg) - x0(n) - r = (((((R6(n,1)*z+R5(n,1))*z+R4(n,1))*z+R3(n,1))*z+R2(n,1)) - & *z+R1(n,1))*z+R0(n,1) - Root(1,iArg)= r - r = (((((R6(n,2)*z+R5(n,2))*z+R4(n,2))*z+R3(n,2))*z+R2(n,2)) - & *z+R1(n,2))*z+R0(n,2) - Root(2,iArg)= r - r = (((((R6(n,3)*z+R5(n,3))*z+R4(n,3))*z+R3(n,3))*z+R2(n,3)) - & *z+R1(n,3))*z+R0(n,3) - Root(3,iArg)= r - r = (((((R6(n,4)*z+R5(n,4))*z+R4(n,4))*z+R3(n,4))*z+R2(n,4)) - & *z+R1(n,4))*z+R0(n,4) - Root(4,iArg)= r - r = (((((R6(n,5)*z+R5(n,5))*z+R4(n,5))*z+R3(n,5))*z+R2(n,5)) - & *z+R1(n,5))*z+R0(n,5) - Root(5,iArg)= r - r = (((((R6(n,6)*z+R5(n,6))*z+R4(n,6))*z+R3(n,6))*z+R2(n,6)) - & *z+R1(n,6))*z+R0(n,6) - Root(6,iArg)= r - r = (((((R6(n,7)*z+R5(n,7))*z+R4(n,7))*z+R3(n,7))*z+R2(n,7)) - & *z+R1(n,7))*z+R0(n,7) - Root(7,iArg)= r - r = (((((R6(n,8)*z+R5(n,8))*z+R4(n,8))*z+R3(n,8))*z+R2(n,8)) - & *z+R1(n,8))*z+R0(n,8) - Root(8,iArg)= r - r = (((((R6(n,9)*z+R5(n,9))*z+R4(n,9))*z+R3(n,9))*z+R2(n,9)) - & *z+R1(n,9))*z+R0(n,9) - Root(9,iArg)= r - r = (((((W6(n,1)*z+W5(n,1))*z+W4(n,1))*z+W3(n,1))*z+W2(n,1)) - & *z+W1(n,1))*z+W0(n,1) - Weight(1,iArg) = r - r = (((((W6(n,2)*z+W5(n,2))*z+W4(n,2))*z+W3(n,2))*z+W2(n,2)) - & *z+W1(n,2))*z+W0(n,2) - Weight(2,iArg) = r - r = (((((W6(n,3)*z+W5(n,3))*z+W4(n,3))*z+W3(n,3))*z+W2(n,3)) - & *z+W1(n,3))*z+W0(n,3) - Weight(3,iArg) = r - r = (((((W6(n,4)*z+W5(n,4))*z+W4(n,4))*z+W3(n,4))*z+W2(n,4)) - & *z+W1(n,4))*z+W0(n,4) - Weight(4,iArg) = r - r = (((((W6(n,5)*z+W5(n,5))*z+W4(n,5))*z+W3(n,5))*z+W2(n,5)) - & *z+W1(n,5))*z+W0(n,5) - Weight(5,iArg) = r - r = (((((W6(n,6)*z+W5(n,6))*z+W4(n,6))*z+W3(n,6))*z+W2(n,6)) - & *z+W1(n,6))*z+W0(n,6) - Weight(6,iArg) = r - r = (((((W6(n,7)*z+W5(n,7))*z+W4(n,7))*z+W3(n,7))*z+W2(n,7)) - & *z+W1(n,7))*z+W0(n,7) - Weight(7,iArg) = r - r = (((((W6(n,8)*z+W5(n,8))*z+W4(n,8))*z+W3(n,8))*z+W2(n,8)) - & *z+W1(n,8))*z+W0(n,8) - Weight(8,iArg) = r - r = (((((W6(n,9)*z+W5(n,9))*z+W4(n,9))*z+W3(n,9))*z+W2(n,9)) - & *z+W1(n,9))*z+W0(n,9) - Weight(9,iArg) = r - Else - ai = 1.0D0/Arg(iArg) - si = Sqrt(ai) - Root(1,iArg) = HerR2(1)*ai - Root(2,iArg) = HerR2(2)*ai - Root(3,iArg) = HerR2(3)*ai - Root(4,iArg) = HerR2(4)*ai - Root(5,iArg) = HerR2(5)*ai - Root(6,iArg) = HerR2(6)*ai - Root(7,iArg) = HerR2(7)*ai - Root(8,iArg) = HerR2(8)*ai - Root(9,iArg) = HerR2(9)*ai - Weight(1,iArg) = HerW(1)*si - Weight(2,iArg) = HerW(2)*si - Weight(3,iArg) = HerW(3)*si - Weight(4,iArg) = HerW(4)*si - Weight(5,iArg) = HerW(5)*si - Weight(6,iArg) = HerW(6)*si - Weight(7,iArg) = HerW(7)*si - Weight(8,iArg) = HerW(8)*si - Weight(9,iArg) = HerW(9)*si - End If - End Do - Return - End diff -Nru openmolcas-22.02/src/rys_util/rys99.F90 openmolcas-22.10/src/rys_util/rys99.F90 --- openmolcas-22.02/src/rys_util/rys99.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys99.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,52 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Rys99(Arg,nArg,Root,Weight,iPntr,nPntr,x0,nMax,R6,R5,R4,R3,R2,R1,R0,W6,W5,W4,W3,W2,W1,W0,ddx,HerW,HerR2,TMax) +!*********************************************************************** +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! September '90 * +!*********************************************************************** + +use Constants, only: One, Ten +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArg, nPntr, iPntr(nPntr), nMax +real(kind=wp), intent(in) :: Arg(nArg), x0(nMax), R6(nMax,9), R5(nMax,9), R4(nMax,9), R3(nMax,9), R2(nMax,9), R1(nMax,9), & + R0(nMax,9), W6(nMax,9), W5(nMax,9), W4(nMax,9), W3(nMax,9), W2(nMax,9), W1(nMax,9), W0(nMax,9), ddx, & + HerW(9), HerR2(9), TMax +real(kind=wp), intent(out) :: Root(9,nArg), Weight(9,nArg) +integer(kind=iwp) :: iArg, n +real(kind=wp) :: ai, dddx, si, xdInv, z + +xdInv = One/ddx +dddx = ddx/Ten+ddx +do iArg=1,nArg + if (Arg(iArg) < TMax) then + n = iPntr(int((Arg(iArg)+dddx)*xdInv)) + z = Arg(iArg)-x0(n) + Root(:,iArg) = (((((R6(n,:)*z+R5(n,:))*z+R4(n,:))*z+R3(n,:))*z+R2(n,:))*z+R1(n,:))*z+R0(n,:) + Weight(:,iArg) = (((((W6(n,:)*z+W5(n,:))*z+W4(n,:))*z+W3(n,:))*z+W2(n,:))*z+W1(n,:))*z+W0(n,:) + else + ai = One/Arg(iArg) + si = sqrt(ai) + Root(:,iArg) = HerR2(:)*ai + Weight(:,iArg) = HerW(:)*si + end if +end do + +return + +end subroutine Rys99 diff -Nru openmolcas-22.02/src/rys_util/rysef0.f openmolcas-22.10/src/rys_util/rysef0.f --- openmolcas-22.02/src/rys_util/rysef0.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rysef0.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,132 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1994, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine RysEF0(Ixy4D,Iz2D,nArg,mArg,nRys,neMin,neMax,nfMin, - & nfMax,EFInt,meMin,meMax,mfMin,mfMax, - & PreFct,ixe,ixf,ixye,ixyf, - & nzeMin,nzeMax,nzfMin,nzfMax) -************************************************************************ -* * -* Object: kernel routine to assemble the integrals from the Ixy * -* and Iz integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* August '90 * -* * -* Modified for decreased memory access January '94. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - Real*8 Ixy4D(nRys,mArg), Iz2D(nRys,mArg,3,0:neMax,0:nfMax), - & PreFct(mArg), EFInt(nArg,meMin:meMax,mfMin:mfMax) -* -* Statement function to compute canonical index -* - iCan(ixyz,ix,iz) = ixyz*(ixyz+1)*(ixyz+2)/6 + - & (ixyz-ix)*(ixyz-ix+1)/2 + iz -* - If (nRys.eq.1) Then - Do izf = nzfMin, nzfMax - Indf=iCan(ixyf+izf,ixf,izf) - Do ize = nzeMin, nzeMax - Inde=iCan(ixye+ize,ixe,ize) - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * - & Ixy4D(1,iArg) * Iz2D(1,iArg,3,ize,izf) - End Do - End Do - End Do - Else If (nRys.eq.2) Then - Do izf = nzfMin, nzfMax - Indf=iCan(ixyf+izf,ixf,izf) - Do ize = nzeMin, nzeMax - Inde=iCan(ixye+ize,ixe,ize) - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * ( - & Ixy4D(1,iArg) * Iz2D(1,iArg,3,ize,izf) - & + Ixy4D(2,iArg) * Iz2D(2,iArg,3,ize,izf)) - End Do - End Do - End Do - Else If (nRys.eq.3) Then - Do izf = nzfMin, nzfMax - Indf=iCan(ixyf+izf,ixf,izf) - Do ize = nzeMin, nzeMax - Inde=iCan(ixye+ize,ixe,ize) - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * ( - & Ixy4D(1,iArg) * Iz2D(1,iArg,3,ize,izf) - & + Ixy4D(2,iArg) * Iz2D(2,iArg,3,ize,izf) - & + Ixy4D(3,iArg) * Iz2D(3,iArg,3,ize,izf)) - End Do - End Do - End Do - Else If (nRys.eq.4) Then - Do izf = nzfMin, nzfMax - Indf=iCan(ixyf+izf,ixf,izf) - Do ize = nzeMin, nzeMax - Inde=iCan(ixye+ize,ixe,ize) - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * ( - & Ixy4D(1,iArg) * Iz2D(1,iArg,3,ize,izf) - & + Ixy4D(2,iArg) * Iz2D(2,iArg,3,ize,izf) - & + Ixy4D(3,iArg) * Iz2D(3,iArg,3,ize,izf) - & + Ixy4D(4,iArg) * Iz2D(4,iArg,3,ize,izf)) - End Do - End Do - End Do - Else If (nRys.eq.5) Then - Do izf = nzfMin, nzfMax - Indf=iCan(ixyf+izf,ixf,izf) - Do ize = nzeMin, nzeMax - Inde=iCan(ixye+ize,ixe,ize) - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * ( - & Ixy4D(1,iArg) * Iz2D(1,iArg,3,ize,izf) - & + Ixy4D(2,iArg) * Iz2D(2,iArg,3,ize,izf) - & + Ixy4D(3,iArg) * Iz2D(3,iArg,3,ize,izf) - & + Ixy4D(4,iArg) * Iz2D(4,iArg,3,ize,izf) - & + Ixy4D(5,iArg) * Iz2D(5,iArg,3,ize,izf)) - End Do - End Do - End Do - Else -* -*--------------General code -* - Do izf = nzfMin, nzfMax - Indf=iCan(ixyf+izf,ixf,izf) - Do ize = nzeMin, nzeMax - Inde=iCan(ixye+ize,ixe,ize) - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = Ixy4D(1,iArg) * - & Iz2D(1,iArg,3,ize,izf) - Do iRys = 2, nRys - EFInt(iArg,Inde,Indf) = EFInt(iArg,Inde,Indf) + - & Ixy4D(iRys,iArg) * Iz2D(iRys,iArg,3,ize,izf) - End Do - EFInt(iArg,Inde,Indf) = EFInt(iArg,Inde,Indf) * - & PreFct(iArg) - End Do - End Do - End Do - End If -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(neMin) - Call Unused_integer(nfMin) - End If - End diff -Nru openmolcas-22.02/src/rys_util/rysef0.F90 openmolcas-22.10/src/rys_util/rysef0.F90 --- openmolcas-22.02/src/rys_util/rysef0.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rysef0.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,102 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1994, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine RysEF0(Ixy4D,Iz2D,nArg,mArg,nRys,neMax,nfMax,EFInt,meMin,meMax,mfMin,mfMax,PreFct,ixe,ixf,ixye,ixyf,nzeMin,nzeMax, & + nzfMin,nzfMax) +!*********************************************************************** +! * +! Object: kernel routine to assemble the integrals from the Ixy * +! and Iz integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! August '90 * +! * +! Modified for decreased memory access January '94. * +!*********************************************************************** + +use Index_Functions, only: C3_Ind +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArg, mArg, nRys, neMax, nfMax, meMin, meMax, mfMin, mfMax, ixe, ixf, ixye, ixyf, nzeMin, nzeMax, & + nzfMin, nzfMax +real(kind=wp), intent(in) :: Ixy4D(nRys,mArg), Iz2D(nRys,mArg,3,0:neMax,0:nfMax), PreFct(mArg) +real(kind=wp), intent(inout) :: EFInt(nArg,meMin:meMax,mfMin:mfMax) +integer(kind=iwp) :: Inde, Indf, iRys, ize, izf + +select case (nRys) + case (1) + do izf=nzfMin,nzfMax + Indf = C3_Ind(ixyf+izf,ixf,izf)-1 + do ize=nzeMin,nzeMax + Inde = C3_Ind(ixye+ize,ixe,ize)-1 + EFInt(1:mArg,Inde,Indf) = PreFct(:)*Ixy4D(1,:)*Iz2D(1,:,3,ize,izf) + end do + end do + case (2) + do izf=nzfMin,nzfMax + Indf = C3_Ind(ixyf+izf,ixf,izf)-1 + do ize=nzeMin,nzeMax + Inde = C3_Ind(ixye+ize,ixe,ize)-1 + EFInt(1:mArg,Inde,Indf) = PreFct(:)*(Ixy4D(1,:)*Iz2D(1,:,3,ize,izf)+Ixy4D(2,:)*Iz2D(2,:,3,ize,izf)) + end do + end do + case (3) + do izf=nzfMin,nzfMax + Indf = C3_Ind(ixyf+izf,ixf,izf)-1 + do ize=nzeMin,nzeMax + Inde = C3_Ind(ixye+ize,ixe,ize)-1 + EFInt(1:mArg,Inde,Indf) = PreFct(:)*(Ixy4D(1,:)*Iz2D(1,:,3,ize,izf)+Ixy4D(2,:)*Iz2D(2,:,3,ize,izf)+ & + Ixy4D(3,:)*Iz2D(3,:,3,ize,izf)) + end do + end do + case (4) + do izf=nzfMin,nzfMax + Indf = C3_Ind(ixyf+izf,ixf,izf)-1 + do ize=nzeMin,nzeMax + Inde = C3_Ind(ixye+ize,ixe,ize)-1 + EFInt(1:mArg,Inde,Indf) = PreFct(:)*(Ixy4D(1,:)*Iz2D(1,:,3,ize,izf)+Ixy4D(2,:)*Iz2D(2,:,3,ize,izf)+ & + Ixy4D(3,:)*Iz2D(3,:,3,ize,izf)+Ixy4D(4,:)*Iz2D(4,:,3,ize,izf)) + end do + end do + case (5) + do izf=nzfMin,nzfMax + Indf = C3_Ind(ixyf+izf,ixf,izf)-1 + do ize=nzeMin,nzeMax + Inde = C3_Ind(ixye+ize,ixe,ize)-1 + EFInt(1:mArg,Inde,Indf) = PreFct(:)*(Ixy4D(1,:)*Iz2D(1,:,3,ize,izf)+Ixy4D(2,:)*Iz2D(2,:,3,ize,izf)+ & + Ixy4D(3,:)*Iz2D(3,:,3,ize,izf)+Ixy4D(4,:)*Iz2D(4,:,3,ize,izf)+ & + Ixy4D(5,:)*Iz2D(5,:,3,ize,izf)) + end do + end do + case default + + ! General code + + do izf=nzfMin,nzfMax + Indf = C3_Ind(ixyf+izf,ixf,izf)-1 + do ize=nzeMin,nzeMax + Inde = C3_Ind(ixye+ize,ixe,ize)-1 + EFInt(1:mArg,Inde,Indf) = Ixy4D(1,:)*Iz2D(1,:,3,ize,izf) + do iRys=2,nRys + EFInt(1:mArg,Inde,Indf) = EFInt(1:mArg,Inde,Indf)+Ixy4D(iRys,:)*Iz2D(iRys,:,3,ize,izf) + end do + EFInt(1:mArg,Inde,Indf) = EFInt(1:mArg,Inde,Indf)*PreFct(:) + end do + end do +end select + +return + +end subroutine RysEF0 diff -Nru openmolcas-22.02/src/rys_util/rysef1.f openmolcas-22.10/src/rys_util/rysef1.f --- openmolcas-22.02/src/rys_util/rysef1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rysef1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,132 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1994, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine RysEF1( Iz2D,nArg,mArg,nRys,neMin,neMax,nfMin, - & nfMax,EFInt,meMin,meMax,mfMin,mfMax, - & PreFct,ixe,ixf,ixye,ixyf, - & nzeMin,nzeMax,nzfMin,nzfMax) -************************************************************************ -* * -* Object: kernel routine to assemble the integrals from the Ixy * -* and Iz integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* August '90 * -* * -* Modified for decreased memory access January '94. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - Real*8 Iz2D(nRys,mArg,3,0:neMax,0:nfMax), - & PreFct(mArg), EFInt(nArg,meMin:meMax,mfMin:mfMax) -* -* Statement function to compute canonical index -* - iCan(ixyz,ix,iz) = ixyz*(ixyz+1)*(ixyz+2)/6 + - & (ixyz-ix)*(ixyz-ix+1)/2 + iz -* - If (nRys.eq.1) Then - Do izf = nzfMin, nzfMax - Indf=iCan(ixyf+izf,ixf,izf) - Do ize = nzeMin, nzeMax - Inde=iCan(ixye+ize,ixe,ize) - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * - & Iz2D(1,iArg,3,ize,izf) - End Do - End Do - End Do - Else If (nRys.eq.2) Then - Do izf = nzfMin, nzfMax - Indf=iCan(ixyf+izf,ixf,izf) - Do ize = nzeMin, nzeMax - Inde=iCan(ixye+ize,ixe,ize) - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * ( - & Iz2D(1,iArg,3,ize,izf) - & + Iz2D(2,iArg,3,ize,izf)) - End Do - End Do - End Do - Else If (nRys.eq.3) Then - Do izf = nzfMin, nzfMax - Indf=iCan(ixyf+izf,ixf,izf) - Do ize = nzeMin, nzeMax - Inde=iCan(ixye+ize,ixe,ize) - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * ( - & Iz2D(1,iArg,3,ize,izf) - & + Iz2D(2,iArg,3,ize,izf) - & + Iz2D(3,iArg,3,ize,izf)) - End Do - End Do - End Do - Else If (nRys.eq.4) Then - Do izf = nzfMin, nzfMax - Indf=iCan(ixyf+izf,ixf,izf) - Do ize = nzeMin, nzeMax - Inde=iCan(ixye+ize,ixe,ize) - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * ( - & Iz2D(1,iArg,3,ize,izf) - & + Iz2D(2,iArg,3,ize,izf) - & + Iz2D(3,iArg,3,ize,izf) - & + Iz2D(4,iArg,3,ize,izf)) - End Do - End Do - End Do - Else If (nRys.eq.5) Then - Do izf = nzfMin, nzfMax - Indf=iCan(ixyf+izf,ixf,izf) - Do ize = nzeMin, nzeMax - Inde=iCan(ixye+ize,ixe,ize) - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * ( - & Iz2D(1,iArg,3,ize,izf) - & + Iz2D(2,iArg,3,ize,izf) - & + Iz2D(3,iArg,3,ize,izf) - & + Iz2D(4,iArg,3,ize,izf) - & + Iz2D(5,iArg,3,ize,izf)) - End Do - End Do - End Do - Else -* -*--------------General code -* - Do izf = nzfMin, nzfMax - Indf=iCan(ixyf+izf,ixf,izf) - Do ize = nzeMin, nzeMax - Inde=iCan(ixye+ize,ixe,ize) - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = - & Iz2D(1,iArg,3,ize,izf) - Do iRys = 2, nRys - EFInt(iArg,Inde,Indf) = EFInt(iArg,Inde,Indf) + - & Iz2D(iRys,iArg,3,ize,izf) - End Do - EFInt(iArg,Inde,Indf) = EFInt(iArg,Inde,Indf) * - & PreFct(iArg) - End Do - End Do - End Do - End If -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(neMin) - Call Unused_integer(nfMin) - End If - End diff -Nru openmolcas-22.02/src/rys_util/rysef1.F90 openmolcas-22.10/src/rys_util/rysef1.F90 --- openmolcas-22.02/src/rys_util/rysef1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rysef1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,99 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1994, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine RysEF1(Iz2D,nArg,mArg,nRys,neMax,nfMax,EFInt,meMin,meMax,mfMin,mfMax,PreFct,ixe,ixf,ixye,ixyf,nzeMin,nzeMax,nzfMin, & + nzfMax) +!*********************************************************************** +! * +! Object: kernel routine to assemble the integrals from the Ixy * +! and Iz integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! August '90 * +! * +! Modified for decreased memory access January '94. * +!*********************************************************************** + +use Index_Functions, only: C3_Ind +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArg, mArg, nRys, neMax, nfMax, meMin, meMax, mfMin, mfMax, ixe, ixf, ixye, ixyf, nzeMin, nzeMax, & + nzfMin, nzfMax +real(kind=wp), intent(in) :: Iz2D(nRys,mArg,3,0:neMax,0:nfMax), PreFct(mArg) +real(kind=wp), intent(inout) :: EFInt(nArg,meMin:meMax,mfMin:mfMax) +integer(kind=iwp) :: Inde, Indf, iRys, ize, izf + +select case (nRys) + case (1) + do izf=nzfMin,nzfMax + Indf = C3_Ind(ixyf+izf,ixf,izf)-1 + do ize=nzeMin,nzeMax + Inde = C3_Ind(ixye+ize,ixe,ize)-1 + EFInt(1:mArg,Inde,Indf) = PreFct(:)*Iz2D(1,:,3,ize,izf) + end do + end do + case (2) + do izf=nzfMin,nzfMax + Indf = C3_Ind(ixyf+izf,ixf,izf)-1 + do ize=nzeMin,nzeMax + Inde = C3_Ind(ixye+ize,ixe,ize)-1 + EFInt(1:mArg,Inde,Indf) = PreFct(:)*(Iz2D(1,:,3,ize,izf)+Iz2D(2,:,3,ize,izf)) + end do + end do + case (3) + do izf=nzfMin,nzfMax + Indf = C3_Ind(ixyf+izf,ixf,izf)-1 + do ize=nzeMin,nzeMax + Inde = C3_Ind(ixye+ize,ixe,ize)-1 + EFInt(1:mArg,Inde,Indf) = PreFct(:)*(Iz2D(1,:,3,ize,izf)+Iz2D(2,:,3,ize,izf)+Iz2D(3,:,3,ize,izf)) + end do + end do + case (4) + do izf=nzfMin,nzfMax + Indf = C3_Ind(ixyf+izf,ixf,izf)-1 + do ize=nzeMin,nzeMax + Inde = C3_Ind(ixye+ize,ixe,ize)-1 + EFInt(1:mArg,Inde,Indf) = PreFct(:)*(Iz2D(1,:,3,ize,izf)+Iz2D(2,:,3,ize,izf)+Iz2D(3,:,3,ize,izf)+Iz2D(4,:,3,ize,izf)) + end do + end do + case (5) + do izf=nzfMin,nzfMax + Indf = C3_Ind(ixyf+izf,ixf,izf)-1 + do ize=nzeMin,nzeMax + Inde = C3_Ind(ixye+ize,ixe,ize)-1 + EFInt(1:mArg,Inde,Indf) = PreFct(:)*(Iz2D(1,:,3,ize,izf)+Iz2D(2,:,3,ize,izf)+Iz2D(3,:,3,ize,izf)+Iz2D(4,:,3,ize,izf)+ & + Iz2D(5,:,3,ize,izf)) + end do + end do + case default + + ! General code + + do izf=nzfMin,nzfMax + Indf = C3_Ind(ixyf+izf,ixf,izf)-1 + do ize=nzeMin,nzeMax + Inde = C3_Ind(ixye+ize,ixe,ize)-1 + EFInt(1:mArg,Inde,Indf) = Iz2D(1,:,3,ize,izf) + do iRys=2,nRys + EFInt(1:mArg,Inde,Indf) = EFInt(1:mArg,Inde,Indf)+Iz2D(iRys,:,3,ize,izf) + end do + EFInt(1:mArg,Inde,Indf) = EFInt(1:mArg,Inde,Indf)*PreFct(:) + end do + end do +end select + +return + +end subroutine RysEF1 diff -Nru openmolcas-22.02/src/rys_util/rysef2.f openmolcas-22.10/src/rys_util/rysef2.f --- openmolcas-22.02/src/rys_util/rysef2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rysef2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,105 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1994, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine RysEF2( Iz2D,nArg,mArg,nRys,neMin,neMax,nfMin, - & nfMax,EFInt,meMin,meMax,mfMin,mfMax, - & PreFct,ixe,ixf,ixye,ixyf, - & nzeMin,nzeMax,nzfMin,nzfMax) -************************************************************************ -* * -* Object: kernel routine to assemble the integrals from the Ixy * -* and Iz integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* August '90 * -* * -* Modified for decreased memory access January '94. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - Real*8 Iz2D(nRys,mArg,3,0:neMax,0:nfMax), - & PreFct(mArg), EFInt(nArg,meMin:meMax,mfMin:mfMax) -* -* Statement function to compute canonical index -* - iCan(ixyz,ix,iz) = ixyz*(ixyz+1)*(ixyz+2)/6 + - & (ixyz-ix)*(ixyz-ix+1)/2 + iz -* - izf=nzfMax - ize=nzeMax - Indf=iCan(ixyf+izf,ixf,izf) - Inde=iCan(ixye+ize,ixe,ize) -* - If (nRys.eq.1) Then - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * - & Iz2D(1,iArg,3,ize,izf) - End Do - Else If (nRys.eq.2) Then - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * ( - & Iz2D(1,iArg,3,ize,izf) - & + Iz2D(2,iArg,3,ize,izf)) - End Do - Else If (nRys.eq.3) Then - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * ( - & Iz2D(1,iArg,3,ize,izf) - & + Iz2D(2,iArg,3,ize,izf) - & + Iz2D(3,iArg,3,ize,izf)) - End Do - Else If (nRys.eq.4) Then - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * ( - & Iz2D(1,iArg,3,ize,izf) - & + Iz2D(2,iArg,3,ize,izf) - & + Iz2D(3,iArg,3,ize,izf) - & + Iz2D(4,iArg,3,ize,izf)) - End Do - Else If (nRys.eq.5) Then - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * ( - & Iz2D(1,iArg,3,ize,izf) - & + Iz2D(2,iArg,3,ize,izf) - & + Iz2D(3,iArg,3,ize,izf) - & + Iz2D(4,iArg,3,ize,izf) - & + Iz2D(5,iArg,3,ize,izf)) - End Do - Else -* -*--------------General code -* - Indf=iCan(ixyf+izf,ixf,izf) - Inde=iCan(ixye+ize,ixe,ize) - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = - & Iz2D(1,iArg,3,ize,izf) - Do iRys = 2, nRys - EFInt(iArg,Inde,Indf) = EFInt(iArg,Inde,Indf) - & + Iz2D(iRys,iArg,3,ize,izf) - End Do - EFInt(iArg,Inde,Indf) = EFInt(iArg,Inde,Indf) - & * PreFct(iArg) - End Do - End If -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(neMin) - Call Unused_integer(nfMin) - Call Unused_integer(nzeMin) - Call Unused_integer(nzfMin) - End If - End diff -Nru openmolcas-22.02/src/rys_util/rysef2.F90 openmolcas-22.10/src/rys_util/rysef2.F90 --- openmolcas-22.02/src/rys_util/rysef2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rysef2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,66 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1994, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine RysEF2(Iz2D,nArg,mArg,nRys,neMax,nfMax,EFInt,meMin,meMax,mfMin,mfMax,PreFct,ixe,ixf,ixye,ixyf,nzeMax,nzfMax) +!*********************************************************************** +! * +! Object: kernel routine to assemble the integrals from the Ixy * +! and Iz integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! August '90 * +! * +! Modified for decreased memory access January '94. * +!*********************************************************************** + +use Index_Functions, only: C3_Ind +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArg, mArg, nRys, neMax, nfMax, meMin, meMax, mfMin, mfMax, ixe, ixf, ixye, ixyf, nzeMax, nzfMax +real(kind=wp), intent(in) :: Iz2D(nRys,mArg,3,0:neMax,0:nfMax), PreFct(mArg) +real(kind=wp), intent(inout) :: EFInt(nArg,meMin:meMax,mfMin:mfMax) +integer(kind=iwp) :: Inde, Indf, iRys, ize, izf + +izf = nzfMax +ize = nzeMax +Indf = C3_Ind(ixyf+izf,ixf,izf)-1 +Inde = C3_Ind(ixye+ize,ixe,ize)-1 + +select case (nRys) + case (1) + EFInt(1:mArg,Inde,Indf) = PreFct(:)*Iz2D(1,:,3,ize,izf) + case (2) + EFInt(1:mArg,Inde,Indf) = PreFct(:)*(Iz2D(1,:,3,ize,izf)+Iz2D(2,:,3,ize,izf)) + case (3) + EFInt(1:mArg,Inde,Indf) = PreFct(:)*(Iz2D(1,:,3,ize,izf)+Iz2D(2,:,3,ize,izf)+Iz2D(3,:,3,ize,izf)) + case (4) + EFInt(1:mArg,Inde,Indf) = PreFct(:)*(Iz2D(1,:,3,ize,izf)+Iz2D(2,:,3,ize,izf)+Iz2D(3,:,3,ize,izf)+Iz2D(4,:,3,ize,izf)) + case (5) + EFInt(1:mArg,Inde,Indf) = PreFct(:)*(Iz2D(1,:,3,ize,izf)+Iz2D(2,:,3,ize,izf)+Iz2D(3,:,3,ize,izf)+Iz2D(4,:,3,ize,izf)+ & + Iz2D(5,:,3,ize,izf)) + case default + + ! General code + + EFInt(1:mArg,Inde,Indf) = Iz2D(1,:,3,ize,izf) + do iRys=2,nRys + EFInt(1:mArg,Inde,Indf) = EFInt(1:mArg,Inde,Indf)+Iz2D(iRys,:,3,ize,izf) + end do + EFInt(1:mArg,Inde,Indf) = EFInt(1:mArg,Inde,Indf)*PreFct(:) +end select + +return + +end subroutine RysEF2 diff -Nru openmolcas-22.02/src/rys_util/rysef3.f openmolcas-22.10/src/rys_util/rysef3.f --- openmolcas-22.02/src/rys_util/rysef3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rysef3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,102 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1994, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine RysEF3(Ixy4D,Iz2D,nArg,mArg,nRys,neMin,neMax,nfMin, - & nfMax,EFInt,meMin,meMax,mfMin,mfMax, - & PreFct,ixe,ixf,ixye,ixyf, - & nzeMin,nzeMax,nzfMin,nzfMax) -************************************************************************ -* * -* Object: kernel routine to assemble the integrals from the Ixy * -* and Iz integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* August '90 * -* * -* Modified for decreased memory access January '94. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - Real*8 Ixy4D(nRys,mArg), Iz2D(nRys,mArg,3,0:neMax,0:nfMax), - & PreFct(mArg), EFInt(nArg,meMin:meMax,mfMin:mfMax) -* -* Statement function to compute canonical index -* - iCan(ixyz,ix,iz) = ixyz*(ixyz+1)*(ixyz+2)/6 + - & (ixyz-ix)*(ixyz-ix+1)/2 + iz -* - izf=nzfMax - ize=nzeMax - Indf=iCan(ixyf+izf,ixf,izf) - Inde=iCan(ixye+ize,ixe,ize) - If (nRys.eq.1) Then - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * - & Ixy4D(1,iArg) * Iz2D(1,iArg,3,ize,izf) - End Do - Else If (nRys.eq.2) Then - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * ( - & Ixy4D(1,iArg) * Iz2D(1,iArg,3,ize,izf) - & + Ixy4D(2,iArg) * Iz2D(2,iArg,3,ize,izf)) - End Do - Else If (nRys.eq.3) Then - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * ( - & Ixy4D(1,iArg) * Iz2D(1,iArg,3,ize,izf) - & + Ixy4D(2,iArg) * Iz2D(2,iArg,3,ize,izf) - & + Ixy4D(3,iArg) * Iz2D(3,iArg,3,ize,izf)) - End Do - Else If (nRys.eq.4) Then - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * ( - & Ixy4D(1,iArg) * Iz2D(1,iArg,3,ize,izf) - & + Ixy4D(2,iArg) * Iz2D(2,iArg,3,ize,izf) - & + Ixy4D(3,iArg) * Iz2D(3,iArg,3,ize,izf) - & + Ixy4D(4,iArg) * Iz2D(4,iArg,3,ize,izf)) - End Do - Else If (nRys.eq.5) Then - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * ( - & Ixy4D(1,iArg) * Iz2D(1,iArg,3,ize,izf) - & + Ixy4D(2,iArg) * Iz2D(2,iArg,3,ize,izf) - & + Ixy4D(3,iArg) * Iz2D(3,iArg,3,ize,izf) - & + Ixy4D(4,iArg) * Iz2D(4,iArg,3,ize,izf) - & + Ixy4D(5,iArg) * Iz2D(5,iArg,3,ize,izf)) - End Do - Else -* -*--------------General code -* - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = Ixy4D(1,iArg) * - & Iz2D(1,iArg,3,ize,izf) - Do iRys = 2, nRys - EFInt(iArg,Inde,Indf) = EFInt(iArg,Inde,Indf) + - & Ixy4D(iRys,iArg) * Iz2D(iRys,iArg,3,ize,izf) - End Do - EFInt(iArg,Inde,Indf) = EFInt(iArg,Inde,Indf) * - & PreFct(iArg) - End Do - End If -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(neMin) - Call Unused_integer(nfMin) - Call Unused_integer(nzeMin) - Call Unused_integer(nzfMin) - End If - End diff -Nru openmolcas-22.02/src/rys_util/rysef3.F90 openmolcas-22.10/src/rys_util/rysef3.F90 --- openmolcas-22.02/src/rys_util/rysef3.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rysef3.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,68 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1994, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine RysEF3(Ixy4D,Iz2D,nArg,mArg,nRys,neMax,nfMax,EFInt,meMin,meMax,mfMin,mfMax,PreFct,ixe,ixf,ixye,ixyf,nzeMax,nzfMax) +!*********************************************************************** +! * +! Object: kernel routine to assemble the integrals from the Ixy * +! and Iz integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! August '90 * +! * +! Modified for decreased memory access January '94. * +!*********************************************************************** + +use Index_Functions, only: C3_Ind +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArg, mArg, nRys, neMax, nfMax, meMin, meMax, mfMin, mfMax, ixe, ixf, ixye, ixyf, nzeMax, nzfMax +real(kind=wp), intent(in) :: Ixy4D(nRys,mArg), Iz2D(nRys,mArg,3,0:neMax,0:nfMax), PreFct(mArg) +real(kind=wp), intent(inout) :: EFInt(nArg,meMin:meMax,mfMin:mfMax) +integer(kind=iwp) :: Inde, Indf, iRys, ize, izf + +izf = nzfMax +ize = nzeMax +Indf = C3_Ind(ixyf+izf,ixf,izf)-1 +Inde = C3_Ind(ixye+ize,ixe,ize)-1 +select case (nRys) + case (1) + EFInt(1:mArg,Inde,Indf) = PreFct(:)*Ixy4D(1,:)*Iz2D(1,:,3,ize,izf) + case (2) + EFInt(1:mArg,Inde,Indf) = PreFct(:)*(Ixy4D(1,:)*Iz2D(1,:,3,ize,izf)+Ixy4D(2,:)*Iz2D(2,:,3,ize,izf)) + case (3) + EFInt(1:mArg,Inde,Indf) = PreFct(:)*(Ixy4D(1,:)*Iz2D(1,:,3,ize,izf)+Ixy4D(2,:)*Iz2D(2,:,3,ize,izf)+ & + Ixy4D(3,:)*Iz2D(3,:,3,ize,izf)) + case (4) + EFInt(1:mArg,Inde,Indf) = PreFct(:)*(Ixy4D(1,:)*Iz2D(1,:,3,ize,izf)+Ixy4D(2,:)*Iz2D(2,:,3,ize,izf)+ & + Ixy4D(3,:)*Iz2D(3,:,3,ize,izf)+Ixy4D(4,:)*Iz2D(4,:,3,ize,izf)) + case (5) + EFInt(1:mArg,Inde,Indf) = PreFct(:)*(Ixy4D(1,:)*Iz2D(1,:,3,ize,izf)+Ixy4D(2,:)*Iz2D(2,:,3,ize,izf)+ & + Ixy4D(3,:)*Iz2D(3,:,3,ize,izf)+Ixy4D(4,:)*Iz2D(4,:,3,ize,izf)+ & + Ixy4D(5,:)*Iz2D(5,:,3,ize,izf)) + case default + + ! General code + + EFInt(1:mArg,Inde,Indf) = Ixy4D(1,:)*Iz2D(1,:,3,ize,izf) + do iRys=2,nRys + EFInt(1:mArg,Inde,Indf) = EFInt(1:mArg,Inde,Indf)+Ixy4D(iRys,:)*Iz2D(iRys,:,3,ize,izf) + end do + EFInt(1:mArg,Inde,Indf) = EFInt(1:mArg,Inde,Indf)*PreFct(:) +end select + +return + +end subroutine RysEF3 diff -Nru openmolcas-22.02/src/rys_util/rysef4.f openmolcas-22.10/src/rys_util/rysef4.f --- openmolcas-22.02/src/rys_util/rysef4.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rysef4.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,138 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1994, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine RysEF4(xyz2D,nArg,mArg,nRys,neMin,neMax,nfMin, - & nfMax,EFInt,meMin,meMax,mfMin,mfMax, - & PreFct,ixe,ixf,ixye,ixyf, - & nzeMin,nzeMax,nzfMin,nzfMax) -************************************************************************ -* * -* Object: kernel routine to assemble the integrals from the Ixy * -* and Iz integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* August '90 * -* * -* Modified for decreased memory access January '94. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - Real*8 xyz2D(nRys,mArg,3,0:neMax,0:nfMax), - & PreFct(mArg), EFInt(nArg,meMin:meMax,mfMin:mfMax) -* -* Statement function to compute canonical index -* - iCan(ixyz,ix,iz) = ixyz*(ixyz+1)*(ixyz+2)/6 + - & (ixyz-ix)*(ixyz-ix+1)/2 + iz -* - iyf=ixyf-ixf - iye=ixye-ixe - izf=nzfMax - ize=nzeMax - Indf=iCan(ixyf+izf,ixf,izf) - Inde=iCan(ixye+ize,ixe,ize) - If (nRys.eq.1) Then - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * - & xyz2D(1,iArg,1,ixe,ixf) * - & xyz2D(1,iArg,2,iye,iyf) * - & xyz2D(1,iArg,3,ize,izf) - End Do - Else If (nRys.eq.2) Then - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * ( - & xyz2D(1,iArg,1,ixe,ixf) * - & xyz2D(1,iArg,2,iye,iyf) * - & xyz2D(1,iArg,3,ize,izf) - & + xyz2D(2,iArg,1,ixe,ixf) * - & xyz2D(2,iArg,2,iye,iyf) * - & xyz2D(2,iArg,3,ize,izf)) - End Do - Else If (nRys.eq.3) Then - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * ( - & xyz2D(1,iArg,1,ixe,ixf) * - & xyz2D(1,iArg,2,iye,iyf) * - & xyz2D(1,iArg,3,ize,izf) - & + xyz2D(2,iArg,1,ixe,ixf) * - & xyz2D(2,iArg,2,iye,iyf) * - & xyz2D(2,iArg,3,ize,izf) - & + xyz2D(3,iArg,1,ixe,ixf) * - & xyz2D(3,iArg,2,iye,iyf) * - & xyz2D(3,iArg,3,ize,izf)) - End Do - Else If (nRys.eq.4) Then - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * ( - & xyz2D(1,iArg,1,ixe,ixf) * - & xyz2D(1,iArg,2,iye,iyf) * - & xyz2D(1,iArg,3,ize,izf) - & + xyz2D(2,iArg,1,ixe,ixf) * - & xyz2D(2,iArg,2,iye,iyf) * - & xyz2D(2,iArg,3,ize,izf) - & + xyz2D(3,iArg,1,ixe,ixf) * - & xyz2D(3,iArg,2,iye,iyf) * - & xyz2D(3,iArg,3,ize,izf) - & + xyz2D(4,iArg,1,ixe,ixf) * - & xyz2D(4,iArg,2,iye,iyf) * - & xyz2D(4,iArg,3,ize,izf)) - End Do - Else If (nRys.eq.5) Then - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = PreFct(iArg) * ( - & xyz2D(1,iArg,1,ixe,ixf) * - & xyz2D(1,iArg,2,iye,iyf) * - & xyz2D(1,iArg,3,ize,izf) - & + xyz2D(2,iArg,1,ixe,ixf) * - & xyz2D(2,iArg,2,iye,iyf) * - & xyz2D(2,iArg,3,ize,izf) - & + xyz2D(3,iArg,1,ixe,ixf) * - & xyz2D(3,iArg,2,iye,iyf) * - & xyz2D(3,iArg,3,ize,izf) - & + xyz2D(4,iArg,1,ixe,ixf) * - & xyz2D(4,iArg,2,iye,iyf) * - & xyz2D(4,iArg,3,ize,izf) - & + xyz2D(5,iArg,1,ixe,ixf) * - & xyz2D(5,iArg,2,iye,iyf) * - & xyz2D(5,iArg,3,ize,izf)) - End Do - Else -* -*--------------General code -* - Do iArg = 1, mArg - EFInt(iArg,Inde,Indf) = - & xyz2D(1,iArg,1,ixe,ixf) * - & xyz2D(1,iArg,2,iye,iyf) * - & xyz2D(1,iArg,3,ize,izf) - Do iRys = 2, nRys - EFInt(iArg,Inde,Indf) = EFInt(iArg,Inde,Indf) + - & xyz2D(iRys,iArg,1,ixe,ixf) * - & xyz2D(iRys,iArg,2,iye,iyf) * - & xyz2D(iRys,iArg,3,ize,izf) - End Do - EFInt(iArg,Inde,Indf) = EFInt(iArg,Inde,Indf) * - & PreFct(iArg) - End Do - End If -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(neMin) - Call Unused_integer(nfMin) - Call Unused_integer(nzeMin) - Call Unused_integer(nzfMin) - End If - End diff -Nru openmolcas-22.02/src/rys_util/rysef4.F90 openmolcas-22.10/src/rys_util/rysef4.F90 --- openmolcas-22.02/src/rys_util/rysef4.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rysef4.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,76 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1994, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine RysEF4(xyz2D,nArg,mArg,nRys,neMax,nfMax,EFInt,meMin,meMax,mfMin,mfMax,PreFct,ixe,ixf,ixye,ixyf,nzeMax,nzfMax) +!*********************************************************************** +! * +! Object: kernel routine to assemble the integrals from the Ixy * +! and Iz integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! August '90 * +! * +! Modified for decreased memory access January '94. * +!*********************************************************************** + +use Index_Functions, only: C3_Ind +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArg, mArg, nRys, neMax, nfMax, meMin, meMax, mfMin, mfMax, ixe, ixf, ixye, ixyf, nzeMax, nzfMax +real(kind=wp), intent(in) :: xyz2D(nRys,mArg,3,0:neMax,0:nfMax), PreFct(mArg) +real(kind=wp), intent(inout) :: EFInt(nArg,meMin:meMax,mfMin:mfMax) +integer(kind=iwp) :: Inde, Indf, iRys, iye, iyf, ize, izf + +iyf = ixyf-ixf +iye = ixye-ixe +izf = nzfMax +ize = nzeMax +Indf = C3_Ind(ixyf+izf,ixf,izf)-1 +Inde = C3_Ind(ixye+ize,ixe,ize)-1 +select case (nRys) + case (1) + EFInt(1:mArg,Inde,Indf) = PreFct(:)*xyz2D(1,:,1,ixe,ixf)*xyz2D(1,:,2,iye,iyf)*xyz2D(1,:,3,ize,izf) + case (2) + EFInt(1:mArg,Inde,Indf) = PreFct(:)*(xyz2D(1,:,1,ixe,ixf)*xyz2D(1,:,2,iye,iyf)*xyz2D(1,:,3,ize,izf)+ & + xyz2D(2,:,1,ixe,ixf)*xyz2D(2,:,2,iye,iyf)*xyz2D(2,:,3,ize,izf)) + case (3) + EFInt(1:mArg,Inde,Indf) = PreFct(:)*(xyz2D(1,:,1,ixe,ixf)*xyz2D(1,:,2,iye,iyf)*xyz2D(1,:,3,ize,izf)+ & + xyz2D(2,:,1,ixe,ixf)*xyz2D(2,:,2,iye,iyf)*xyz2D(2,:,3,ize,izf)+ & + xyz2D(3,:,1,ixe,ixf)*xyz2D(3,:,2,iye,iyf)*xyz2D(3,:,3,ize,izf)) + case (4) + EFInt(1:mArg,Inde,Indf) = PreFct(:)*(xyz2D(1,:,1,ixe,ixf)*xyz2D(1,:,2,iye,iyf)*xyz2D(1,:,3,ize,izf)+ & + xyz2D(2,:,1,ixe,ixf)*xyz2D(2,:,2,iye,iyf)*xyz2D(2,:,3,ize,izf)+ & + xyz2D(3,:,1,ixe,ixf)*xyz2D(3,:,2,iye,iyf)*xyz2D(3,:,3,ize,izf)+ & + xyz2D(4,:,1,ixe,ixf)*xyz2D(4,:,2,iye,iyf)*xyz2D(4,:,3,ize,izf)) + case (5) + EFInt(1:mArg,Inde,Indf) = PreFct(:)*(xyz2D(1,:,1,ixe,ixf)*xyz2D(1,:,2,iye,iyf)*xyz2D(1,:,3,ize,izf)+ & + xyz2D(2,:,1,ixe,ixf)*xyz2D(2,:,2,iye,iyf)*xyz2D(2,:,3,ize,izf)+ & + xyz2D(3,:,1,ixe,ixf)*xyz2D(3,:,2,iye,iyf)*xyz2D(3,:,3,ize,izf)+ & + xyz2D(4,:,1,ixe,ixf)*xyz2D(4,:,2,iye,iyf)*xyz2D(4,:,3,ize,izf)+ & + xyz2D(5,:,1,ixe,ixf)*xyz2D(5,:,2,iye,iyf)*xyz2D(5,:,3,ize,izf)) + case default + + ! General code + + EFInt(1:mArg,Inde,Indf) = xyz2D(1,:,1,ixe,ixf)*xyz2D(1,:,2,iye,iyf)*xyz2D(1,:,3,ize,izf) + do iRys=2,nRys + EFInt(1:mArg,Inde,Indf) = EFInt(1:mArg,Inde,Indf)+xyz2D(iRys,:,1,ixe,ixf)*xyz2D(iRys,:,2,iye,iyf)*xyz2D(iRys,:,3,ize,izf) + end do + EFInt(1:mArg,Inde,Indf) = EFInt(1:mArg,Inde,Indf)*PreFct(:) +end select + +return + +end subroutine RysEF4 diff -Nru openmolcas-22.02/src/rys_util/rysef.f openmolcas-22.10/src/rys_util/rysef.f --- openmolcas-22.02/src/rys_util/rysef.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rysef.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,185 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991,1994, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine RysEF(xyz2D,nArg,mArg,nRys,neMin,neMax,nfMin,nfMax, - & EFInt,meMin,meMax,mfMin,mfMax,Scrtch,PreFct, - & AeqB, CeqD) -************************************************************************ -* * -* Object: to compute integrals corresponding to the primitive set * -* used for the HRR. The primitive integrals are generated * -* from the 2D-integrals according to the Rys quadrature. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* January '90. * -* * -* Modified for kernel routine RysEF0 August '90. * -* Modified for kernel routines RysS1, RysS2, and RysS3 * -* September '90. * -* Modified for improved vectorization August '91. * -* Modified for decreased memory access January '94. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "TriInd.fh" -#include "real.fh" -#include "print.fh" - Real*8 xyz2D(nRys,mArg,3,0:neMax,0:nfMax), PreFct(mArg), - & Scrtch(nRys,mArg), EFInt(nArg,meMin:meMax,mfMin:mfMax) - Logical AeqB, CeqD -*define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Character*80 Label -#endif -* * -************************************************************************ -* * - ne = (neMax+1)*(neMax+2)/2 - nf = (nfMax+1)*(nfMax+2)/2 -* - If (ne.gt.IJ_Max .or. nf.gt.IJ_Max) Then - Write (6,*) 'ne,nf=',ne,nf - Call WarningMessage(2, - & 'Increase IJ_Max to the larger of the above!') - Call Abend() - End If -* - Do ief = 1, ne*nf - if = (ief-1)/ne + 1 - ie = ief - (if-1)*ne -* - ixe = iTriInd(1,ie) - iye = iTriInd(2,ie) - ixye = ixe + iye -* - ixf = iTriInd(1,if) - iyf = iTriInd(2,if) - ixyf = ixf + iyf -* * -************************************************************************ -* * - nzeMax=Max(0,neMax-ixe-iye) - nzfMax=Max(0,nfMax-ixf-iyf) - nzeMin=Max(0,neMin-ixe-iye) - If (AeqB) nzeMin = nzeMax - nzfMin=Max(0,nfMin-ixf-iyf) - If (CeqD) nzfMin = nzfMax -* - nItem=(nzeMax-nzeMin+1)*(nzfMax-nzfMin+1) - If (nItem.gt.1) Then -* -* Precompute for all arguments Ix*Iy, avoid multiplying -* with ones. -* -* -* Combine with possible Iz -* - If (ixe+ixf+iye+iyf.eq.0) Then -* - Call RysEF1( xyz2D, - & nArg,mArg,nRys,neMin,neMax,nfMin, - & nfMax,EFInt,meMin,meMax,mfMin,mfMax, - & PreFct,ixe,ixf,ixye,ixyf, - & nzeMin,nzeMax,nzfMin,nzfMax) -* - Else If(ixe+ixf.eq.0) Then -* - Call RysEF0(xyz2D(1,1,2,iye,iyf),xyz2D, - & nArg,mArg,nRys,neMin,neMax,nfMin, - & nfMax,EFInt,meMin,meMax,mfMin,mfMax, - & PreFct,ixe,ixf,ixye,ixyf, - & nzeMin,nzeMax,nzfMin,nzfMax) -* - Else If(iye+iyf.eq.0) Then -* - Call RysEF0(xyz2D(1,1,1,ixe,ixf),xyz2D, - & nArg,mArg,nRys,neMin,neMax,nfMin, - & nfMax,EFInt,meMin,meMax,mfMin,mfMax, - & PreFct,ixe,ixf,ixye,ixyf, - & nzeMin,nzeMax,nzfMin,nzfMax) -* - Else -* - Do iArg = 1, mArg - Do iRys=1,nRys - Scrtch(iRys,iArg) = xyz2D(iRys,iArg,1,ixe,ixf) - & * xyz2D(iRys,iArg,2,iye,iyf) - End Do - End Do - Call RysEF0(Scrtch, xyz2D, - & nArg,mArg,nRys,neMin,neMax,nfMin, - & nfMax,EFInt,meMin,meMax,mfMin,mfMax, - & PreFct,ixe,ixf,ixye,ixyf, - & nzeMin,nzeMax,nzfMin,nzfMax) -* - End If -* - Else -* -* Here if only one triplet of 2D-integrals -* -* Contract over roots -* - If (ixe+ixf+iye+iyf.eq.0) Then -* - Call RysEF2( xyz2D, - & nArg,mArg,nRys,neMin,neMax,nfMin, - & nfMax,EFInt,meMin,meMax,mfMin,mfMax, - & PreFct,ixe,ixf,ixye,ixyf, - & nzeMin,nzeMax,nzfMin,nzfMax) -* - Else If (ixe+ixf.eq.0) Then -* - Call RysEF3(xyz2D(1,1,2,iye,iyf),xyz2D, - & nArg,mArg,nRys,neMin,neMax,nfMin, - & nfMax,EFInt,meMin,meMax,mfMin,mfMax, - & PreFct,ixe,ixf,ixye,ixyf, - & nzeMin,nzeMax,nzfMin,nzfMax) -* - Else If (iye+iyf.eq.0) Then -* - Call RysEF3(xyz2D(1,1,1,ixe,ixf),xyz2D, - & nArg,mArg,nRys,neMin,neMax,nfMin, - & nfMax,EFInt,meMin,meMax,mfMin,mfMax, - & PreFct,ixe,ixf,ixye,ixyf, - & nzeMin,nzeMax,nzfMin,nzfMax) -* - Else -* - Call RysEF4( xyz2D, - & nArg,mArg,nRys,neMin,neMax,nfMin, - & nfMax,EFInt,meMin,meMax,mfMin,mfMax, - & PreFct,ixe,ixf,ixye,ixyf, - & nzeMin,nzeMax,nzfMin,nzfMax) -* - End If -* - End If -* * -************************************************************************ -* * - End Do -* * -************************************************************************ -* * -* -#ifdef _DEBUGPRINT_ - Do iab = meMin, meMax - Do icd = mfMin, mfMax - Write (Label,'(A,I3,A,I3,A)') ' In RysEF: [', iab, ',0|', - & icd, ',0]' - Call RecPrt(Label,' ',EFInt(1,iab,icd),1,nArg) - End Do - End Do -#endif - Return - End diff -Nru openmolcas-22.02/src/rys_util/rysef.F90 openmolcas-22.10/src/rys_util/rysef.F90 --- openmolcas-22.02/src/rys_util/rysef.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rysef.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,152 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991,1994, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine RysEF(xyz2D,nArg,mArg,nRys,neMin,neMax,nfMin,nfMax,EFInt,meMin,meMax,mfMin,mfMax,Scrtch,PreFct,AeqB,CeqD) +!*********************************************************************** +! * +! Object: to compute integrals corresponding to the primitive set * +! used for the HRR. The primitive integrals are generated * +! from the 2D-integrals according to the Rys quadrature. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! January '90. * +! * +! Modified for kernel routine RysEF0 August '90. * +! Modified for kernel routines RysS1, RysS2, and RysS3 * +! September '90. * +! Modified for improved vectorization August '91. * +! Modified for decreased memory access January '94. * +!*********************************************************************** + +use Index_Functions, only: iTri_Rev +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArg, mArg, nRys, neMin, neMax, nfMin, nfMax, meMin, meMax, mfMin, mfMax +real(kind=wp), intent(in) :: xyz2D(nRys,mArg,3,0:neMax,0:nfMax), PreFct(mArg) +real(kind=wp), intent(out) :: EFInt(nArg,meMin:meMax,mfMin:mfMax) +real(kind=wp), intent(inout) :: Scrtch(nRys,mArg) +logical(kind=iwp), intent(in) :: AeqB, CeqD +integer(kind=iwp) :: ie, ief, if_, itr(2), ixe, ixf, ixye, ixyf, iye, iyf, ne, nf, nItem, nzeMax, nzeMin, nzfMax, nzfMin +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +character(len=80) :: Label +#endif + +! * +!*********************************************************************** +! * +ne = (neMax+1)*(neMax+2)/2 +nf = (nfMax+1)*(nfMax+2)/2 + +do ief=1,ne*nf + if_ = (ief-1)/ne+1 + ie = ief-(if_-1)*ne + + itr(:) = iTri_Rev(ie) + ixye = itr(1)-1 + ixe = itr(2)-1 + iye = ixye-ixe + + itr(:) = iTri_Rev(if_) + ixyf = itr(1)-1 + ixf = itr(2)-1 + iyf = ixyf-ixf + ! * + !********************************************************************* + ! * + nzeMax = max(0,neMax-ixye) + nzfMax = max(0,nfMax-ixyf) + nzeMin = max(0,neMin-ixye) + if (AeqB) nzeMin = nzeMax + nzfMin = max(0,nfMin-ixyf) + if (CeqD) nzfMin = nzfMax + + nItem = (nzeMax-nzeMin+1)*(nzfMax-nzfMin+1) + if (nItem > 1) then + + ! Precompute for all arguments Ix*Iy, avoid multiplying with ones. + + ! Combine with possible Iz + + if (ixye+ixyf == 0) then + + call RysEF1(xyz2D,nArg,mArg,nRys,neMax,nfMax,EFInt,meMin,meMax,mfMin,mfMax,PreFct,ixe,ixf,ixye,ixyf,nzeMin,nzeMax,nzfMin, & + nzfMax) + + else if (ixe+ixf == 0) then + + call RysEF0(xyz2D(:,:,2,iye,iyf),xyz2D,nArg,mArg,nRys,neMax,nfMax,EFInt,meMin,meMax,mfMin,mfMax,PreFct,ixe,ixf,ixye,ixyf, & + nzeMin,nzeMax,nzfMin,nzfMax) + + else if (iye+iyf == 0) then + + call RysEF0(xyz2D(:,:,1,ixe,ixf),xyz2D,nArg,mArg,nRys,neMax,nfMax,EFInt,meMin,meMax,mfMin,mfMax,PreFct,ixe,ixf,ixye,ixyf, & + nzeMin,nzeMax,nzfMin,nzfMax) + + else + + Scrtch(:,:) = xyz2D(:,:,1,ixe,ixf)*xyz2D(:,:,2,iye,iyf) + call RysEF0(Scrtch,xyz2D,nArg,mArg,nRys,neMax,nfMax,EFInt,meMin,meMax,mfMin,mfMax,PreFct,ixe,ixf,ixye,ixyf,nzeMin,nzeMax, & + nzfMin,nzfMax) + + end if + + else + + ! Here if only one triplet of 2D-integrals + + ! Contract over roots + + if (ixye+ixyf == 0) then + + call RysEF2(xyz2D,nArg,mArg,nRys,neMax,nfMax,EFInt,meMin,meMax,mfMin,mfMax,PreFct,ixe,ixf,ixye,ixyf,nzeMax,nzfMax) + + else if (ixe+ixf == 0) then + + call RysEF3(xyz2D(:,:,2,iye,iyf),xyz2D,nArg,mArg,nRys,neMax,nfMax,EFInt,meMin,meMax,mfMin,mfMax,PreFct,ixe,ixf,ixye,ixyf, & + nzeMax,nzfMax) + + else if (iye+iyf == 0) then + + call RysEF3(xyz2D(:,:,1,ixe,ixf),xyz2D,nArg,mArg,nRys,neMax,nfMax,EFInt,meMin,meMax,mfMin,mfMax,PreFct,ixe,ixf,ixye,ixyf, & + nzeMax,nzfMax) + + else + + call RysEF4(xyz2D,nArg,mArg,nRys,neMax,nfMax,EFInt,meMin,meMax,mfMin,mfMax,PreFct,ixe,ixf,ixye,ixyf,nzeMax,nzfMax) + + end if + + end if + ! * + !********************************************************************* + ! * +end do +! * +!*********************************************************************** +! * + +#ifdef _DEBUGPRINT_ +do iab=meMin,meMax + do icd=mfMin,mfMax + write(Label,'(A,I3,A,I3,A)') ' In RysEF: [',iab,',0|',icd,',0]' + call RecPrt(Label,' ',EFInt(1,iab,icd),1,nArg) + end do +end do +#endif + +return + +end subroutine RysEF diff -Nru openmolcas-22.02/src/rys_util/rys.f openmolcas-22.10/src/rys_util/rys.f --- openmolcas-22.02/src/rys_util/rys.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,593 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991,1994, Roland Lindh * -* 1990, IBM * -* 2017, Ignacio Fdez. Galvan * -************************************************************************ - SubRoutine Rys(iAnga,nT,Zeta,ZInv,nZeta, - & Eta,EInv,nEta, - & P,lP,Q,lQ,rKapab,rKapcd,Coori,Coora,CoorAC, - & mabMin,mabMax,mcdMin,mcdMax,Array,nArray, - & Tvalue,ModU2,Cff2D,Rys2D,NoSpecial) -************************************************************************ -* * -* Object: to compute the source integrals for the transfer equation * -* with the Rys quadrature, i.e. the integrals [e0|f0] will be * -* computed (e=Max(la,lb),la+lb,f=Max(lc,ld),lc+ld). * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* Modified for k2 loop. August '91 * -* Modified for decreased memory access January '94 * -* Modified for special routines Jan-Mar '94 * -************************************************************************ - use vRys_RW - use Gateway_Info, only: ChiI2 - use Gateway_global, only: IsChi - Implicit Real*8 (A-H,O-Z) - External Tvalue, ModU2, Cff2D, Rys2D -#include "notab.fh" -#include "print.fh" -#include "real.fh" -cgh - stuff for short range integrals -#include "FMM.fh" - logical secondpass -#include "srint.fh" - Real*8 Zeta(nZeta), ZInv(nZeta), P(lP,3), rKapab(nZeta), - & Eta(nEta), EInv(nEta), Q(lQ,3), rKapcd(nEta), - & CoorAC(3,2), Coora(3,4), Coori(3,4), Array(nArray) - Integer iAnga(4) - Logical AeqB, CeqD, EQ, NoSpecial -* -* Statement function for canonical index, etc. -* - iTri(i,j) = (Max(i,j)*(Max(i,j)-1))/2 + Min(i,j) -* - -!#define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Write (6,*) 'NoSpecial=',NoSpecial - Call RecPrt(' In Rys:P','(10G15.5)',P,lP,3) - Call RecPrt(' In Rys:Q','(10G15.5)',Q,lQ,3) - Call RecPrt(' In Rys:Zeta','(10G15.5)',Zeta,nZeta,1) - Call RecPrt(' In Rys:Eta','(10G15.5)',Eta,nEta,1) - Write (6,*) ' In Rys: iAnga=',iAnga - Call RecPrt('CoorAC',' ',CoorAC,3,2) - Call RecPrt('Coora',' ',Coora,3,4) - Call RecPrt('Coori',' ',Coori,3,4) - Call RecPrt('rKapab',' ',rKapab,1,nZeta) - Call RecPrt('rKapcd',' ',rKapcd,1,nEta) -#endif - la = iAnga(1) - lb = iAnga(2) - lc = iAnga(3) - ld = iAnga(4) - AeqB = EQ(Coori(1,1),Coori(1,2)) - CeqD = EQ(Coori(1,3),Coori(1,4)) - nRys = (la+lb+lc+ld+2)/2 - nabMax = la+lb - nabMin = Max(la,lb) - ncdMax = lc+ld - ncdMin = Max(lc,ld) - nabcd = (nabMax+1)*(ncdMax+1) -* -* In some cases a pointer to Array will not be used. However, the -* subroutine call still have the same number of arguments. In this -* cases a "dummy pointer" is used. The pointer could point to any -* odd element in Array. I will use the last one for some unknown reason. -* - ip_Array_Dummy=nArray -* - ijkl = 0 - If (NoSpecial) ijkl = -1 -* -* For FMM, compute short-range integrals disabling special cases -cgh - disable special cases anyway for the short range integrals -* - If (shortrange.or.FMM_shortrange) ijkl = -1 -* - ij = iTri(la+1,lb+1) - kl = iTri(lc+1,ld+1) - If (ijkl.eq.0) ijkl = iTri(ij,kl) - Select Case (ijkl) -* - Case (1) -* -*--------(ss|ss) -* - Call ssss(Array, - & Zeta,nZeta,P,lP,rKapAB,Coori(1,1),Coori(1,2), - & Eta, nEta,Q,lQ,rKapCD,Coori(1,3),Coori(1,4), - & Tmax(1),Map(iMap(1)),nMap(1), - & x0(ix0(1)),nx0(1),Cff(iCffW(6,1)), - & Cff(iCffW(5,1)),Cff(iCffW(4,1)),Cff(iCffW(3,1)), - & Cff(iCffW(2,1)),Cff(iCffW(1,1)),Cff(iCffW(0,1)), - & ddx(1),HerW2(iHerW2(1)),IsChi,ChiI2) -* - Case (2) -* -*--------(ps|ss) & (ss|ps) -* - If (kl.eq.2) - & Call sssp(Array,Zeta,nZeta,P,lP,rKapAB,Coori(1,1),Coori(1,2), - & Eta, nEta,Q,lQ,rKapCD,Coori(1,3),Coori(1,4), - & CoorAC, - & Tmax(1),Map(iMap(1)),nMap(1), - & x0(ix0(1)),nx0(1),Cff(iCffW(6,1)), - & Cff(iCffW(5,1)),Cff(iCffW(4,1)),Cff(iCffW(3,1)), - & Cff(iCffW(2,1)),Cff(iCffW(1,1)),Cff(iCffW(0,1)), - & Cff(iCffR(6,1)), - & Cff(iCffR(5,1)),Cff(iCffR(4,1)),Cff(iCffR(3,1)), - & Cff(iCffR(2,1)),Cff(iCffR(1,1)),Cff(iCffR(0,1)), - & ddx(1),HerW2(iHerW2(1)),HerR2(iHerR2(1)),IsChi,ChiI2) - If (ij.eq.2) - & Call psss(Array, - & Zeta,nZeta,P,lP,rKapAB,Coori(1,1),Coori(1,2), - & Eta, nEta,Q,lQ,rKapCD,Coori(1,3),Coori(1,4), - & CoorAC, - & Tmax(1),Map(iMap(1)),nMap(1), - & x0(ix0(1)),nx0(1),Cff(iCffW(6,1)), - & Cff(iCffW(5,1)),Cff(iCffW(4,1)),Cff(iCffW(3,1)), - & Cff(iCffW(2,1)),Cff(iCffW(1,1)),Cff(iCffW(0,1)), - & Cff(iCffR(6,1)), - & Cff(iCffR(5,1)),Cff(iCffR(4,1)),Cff(iCffR(3,1)), - & Cff(iCffR(2,1)),Cff(iCffR(1,1)),Cff(iCffR(0,1)), - & ddx(1),HerW2(iHerW2(1)),HerR2(iHerR2(1)),IsChi,ChiI2) -* - Case (3) -* -*--------(ps|ps) -* - Call psps(Array,Zeta,nZeta,P,lP,rKapAB,Coori(1,1),Coori(1,2), - & Eta, nEta,Q,lQ,rKapCD,Coori(1,3),Coori(1,4), - & CoorAC, - & Tmax(2),Map(iMap(2)),nMap(2), - & x0(ix0(2)),nx0(2),Cff(iCffW(6,2)), - & Cff(iCffW(5,2)),Cff(iCffW(4,2)),Cff(iCffW(3,2)), - & Cff(iCffW(2,2)),Cff(iCffW(1,2)),Cff(iCffW(0,2)), - & Cff(iCffR(6,2)), - & Cff(iCffR(5,2)),Cff(iCffR(4,2)),Cff(iCffR(3,2)), - & Cff(iCffR(2,2)),Cff(iCffR(1,2)),Cff(iCffR(0,2)), - & ddx(2),HerW2(iHerW2(2)),HerR2(iHerR2(2)),IsChi,ChiI2) -* - Case (4) -* -*--------(pp|ss) & (ss|pp) -* - If (ij.eq.3) - & Call ppss(Array,Zeta,ZInv,nZeta,P,lP,rKapAB, - & Coori(1,1),Coori(1,2), - & Eta,EInv, nEta,Q,lQ,rKapCD, - & Coori(1,3),Coori(1,4), - & CoorAC, - & Tmax(2),Map(iMap(2)),nMap(2), - & x0(ix0(2)),nx0(2),Cff(iCffW(6,2)), - & Cff(iCffW(5,2)),Cff(iCffW(4,2)),Cff(iCffW(3,2)), - & Cff(iCffW(2,2)),Cff(iCffW(1,2)),Cff(iCffW(0,2)), - & Cff(iCffR(6,2)), - & Cff(iCffR(5,2)),Cff(iCffR(4,2)),Cff(iCffR(3,2)), - & Cff(iCffR(2,2)),Cff(iCffR(1,2)),Cff(iCffR(0,2)), - & ddx(2),HerW2(iHerW2(2)),HerR2(iHerR2(2)),IsChi,ChiI2) - If (kl.eq.3) - & Call sspp(Array,Zeta,ZInv,nZeta,P,lP,rKapAB, - & Coori(1,1),Coori(1,2), - & Eta,EInv, nEta,Q,lQ,rKapCD, - & Coori(1,3),Coori(1,4), - & CoorAC, - & Tmax(2),Map(iMap(2)),nMap(2), - & x0(ix0(2)),nx0(2),Cff(iCffW(6,2)), - & Cff(iCffW(5,2)),Cff(iCffW(4,2)),Cff(iCffW(3,2)), - & Cff(iCffW(2,2)),Cff(iCffW(1,2)),Cff(iCffW(0,2)), - & Cff(iCffR(6,2)), - & Cff(iCffR(5,2)),Cff(iCffR(4,2)),Cff(iCffR(3,2)), - & Cff(iCffR(2,2)),Cff(iCffR(1,2)),Cff(iCffR(0,2)), - & ddx(2),HerW2(iHerW2(2)),HerR2(iHerR2(2)),IsChi,ChiI2) -* - Case (5) -* -*--------(pp|ps) & (sp|pp) -* - If (ij.eq.3) - & Call ppps(Array,Zeta,ZInv,nZeta,P,lP,rKapAB, - & Coori(1,1),Coori(1,2), - & Eta,EInv, nEta,Q,lQ,rKapCD, - & Coori(1,3),Coori(1,4), - & CoorAC, - & Tmax(2),Map(iMap(2)),nMap(2), - & x0(ix0(2)),nx0(2),Cff(iCffW(6,2)), - & Cff(iCffW(5,2)),Cff(iCffW(4,2)),Cff(iCffW(3,2)), - & Cff(iCffW(2,2)),Cff(iCffW(1,2)),Cff(iCffW(0,2)), - & Cff(iCffR(6,2)), - & Cff(iCffR(5,2)),Cff(iCffR(4,2)),Cff(iCffR(3,2)), - & Cff(iCffR(2,2)),Cff(iCffR(1,2)),Cff(iCffR(0,2)), - & ddx(2),HerW2(iHerW2(2)),HerR2(iHerR2(2)),IsChi,ChiI2) - If (kl.eq.3) - & Call sppp(Array,Zeta,ZInv,nZeta,P,lP,rKapAB, - & Coori(1,1),Coori(1,2), - & Eta,EInv, nEta,Q,lQ,rKapCD, - & Coori(1,3),Coori(1,4), - & CoorAC, - & Tmax(2),Map(iMap(2)),nMap(2), - & x0(ix0(2)),nx0(2),Cff(iCffW(6,2)), - & Cff(iCffW(5,2)),Cff(iCffW(4,2)),Cff(iCffW(3,2)), - & Cff(iCffW(2,2)),Cff(iCffW(1,2)),Cff(iCffW(0,2)), - & Cff(iCffR(6,2)), - & Cff(iCffR(5,2)),Cff(iCffR(4,2)),Cff(iCffR(3,2)), - & Cff(iCffR(2,2)),Cff(iCffR(1,2)),Cff(iCffR(0,2)), - & ddx(2),HerW2(iHerW2(2)),HerR2(iHerR2(2)),IsChi,ChiI2) -* - Case (6) -* -*--------(pp|pp) -* - Call pppp(Array,Zeta,ZInv,nZeta,P,lP,rKapAB, - & Coori(1,1),Coori(1,2), - & Eta,EInv, nEta,Q,lQ,rKapCD, - & Coori(1,3),Coori(1,4), - & CoorAC, - & Tmax(3),Map(iMap(3)),nMap(3), - & x0(ix0(3)),nx0(3),Cff(iCffW(6,3)), - & Cff(iCffW(5,3)),Cff(iCffW(4,3)),Cff(iCffW(3,3)), - & Cff(iCffW(2,3)),Cff(iCffW(1,3)),Cff(iCffW(0,3)), - & Cff(iCffR(6,3)), - & Cff(iCffR(5,3)),Cff(iCffR(4,3)),Cff(iCffR(3,3)), - & Cff(iCffR(2,3)),Cff(iCffR(1,3)),Cff(iCffR(0,3)), - & ddx(3),HerW2(iHerW2(3)),HerR2(iHerR2(3)),IsChi,ChiI2) -* - Case Default -* -*-----General code -* -* Allocate memory for integrals of [a0|c0] type - ip = 1 - ipAC = ip - ip = ip + nT*(mabMax-mabMin+1)*(mcdMax-mcdMin+1) -cgh - in order to produce the short range integrals, two arrays of -cgh - this type are needed - one for the ordinary full range, one for -cgh - the long range integrals -cgh - (additional memory has been declared in MemRys) - ipAC_long = ipAC - If (shortrange.or.FMM_shortrange) Then - ipAC_long = ip - ip = ip + nT*(mabMax-mabMin+1)*(mcdMax-mcdMin+1) - EndIf -* Allocate memory for the normalization factors - ipFact = ip - ip = ip + nT -* Allocate memory for the 2D-integrals. - ipxyz = ip - ip = ip + nabcd*3*nT*nRys - secondpass=.false. -* - jump mark for second pass: - 2304 continue -* Allocate memory for the coefficients in the recurrence relation -* of the 2D-integrals. - nTR=nT*nRys - If (NoSpecial) Then - ipPAQP = ip - Else - If (nabMax.ge.1) Then - iab = 2 - icd = 1 - iabcd = (nabMax+1)*(icd-1) + iab - 1 - ipPAQP = ipxyz + 3*nT*nRys*iabcd - Else - ipPAQP = ip_Array_Dummy - End If - End If - ip = ip + nTR*3 - If (NoSpecial) Then - ipQCPQ = ip - Else - If (ncdMax.ge.1) Then - iab = 1 - icd = 2 - iabcd = (nabMax+1)*(icd-1) + iab - 1 - ipQCPQ = ipxyz + 3*nT*nRys*iabcd - Else - ipQCPQ = ip_Array_Dummy - End If - End If - ip = ip + nTR*3 - lB10=Max(Min(nabMax-1,1),0) - If (lB10.ge.1) Then - ipB10 = ip - Else - ipB10 = ip_Array_Dummy - End If - ip = ip + nTR*3*lB10 - labMax = Min(nabMax,ncdMax) - lB00=Max(Min(labMax,1),0) - If (lB00.ge.1) Then - ipB00 = ip - Else - ipB00 = ip_Array_Dummy - End If - ip = ip + nTR*3*lB00 - lB01=Max(Min(ncdMax-1,1),0) - If (lB01.ge.1) Then - ipB01 = ip - Else - ipB01 = ip_Array_Dummy - End If - ip = ip + nTR*3*lB01 -* Allocate memory for the roots. - ipU2 = ip - ip = ip + nT*nRys -* Allocate memory for Zeta, ZInv, Eta, EInv - ipZeta = ip - ip = ip + nT - ipEta = ip - ip = ip + nT - ipZInv = ip - ip = ip + nT - ipEInv = ip - ip = ip + nT -* Allocate memory for P and Q - ipP = ip - ip = ip + 3*nT - ipQ = ip - ip = ip + 3*nT -* Allocate memory for the inverse. - ipDiv = ip - ip = ip + nT -* Allocate memory for the arguments. - ipTv = ip - ip = ip + nT -* Allocate memory for rKapab and rKapcd - iprKapab = ip - ip = ip + nT - iprKapcd = ip - ip = ip + nT -*define _CHECK_ -#ifdef _CHECK_ - If (ip-1.gt.nArray) Then - Call WarningMessage(2,'Rys: ip-1 =/= nArray (pos.1)') - Write (6,*) ' nArray=',nArray - Write (6,*) ' ip-1 =',ip-1 - Write (6,*) ' nRys =',nRys - Write (6,*) ' nZeta =',nZeta - Write (6,*) ' nEta =',nEta - Call Abend() - End If -#endif -* -* Expand Zeta, ZInv, Eta ,EInv, rKapab, rKapcd, P, and Q -* - If (nEta*nZeta.ne.nT) Then - If (nEta.ne.nT .and.nZeta.ne.nT) Then - Write (6,*) 'Corrupted parameters!' - Call Abend() - End If - iOff = 0 - call dcopy_(nZeta,Zeta, 1,Array(iOff+ipZeta ),1) - call dcopy_(nZeta,ZInv, 1,Array(iOff+ipZInv ),1) - call dcopy_(nZeta,rKapab,1,Array(iOff+iprKapab),1) - call dcopy_(nZeta,P(1,1),1,Array(iOff+ipP ),1) - iOff = iOff + nT - call dcopy_(nZeta,P(1,2),1,Array(iOff+ipP ),1) - iOff = iOff + nT - call dcopy_(nZeta,P(1,3),1,Array(iOff+ipP ),1) - iOff = 0 - call dcopy_(nEta, Eta, 1,Array(iOff+ipEta) ,1) - call dcopy_(nEta,EInv, 1,Array(iOff+ipEInv),1) - call dcopy_(nEta,rKapcd,1,Array(iOff+iprKapcd),1) - call dcopy_(nEta,Q(1,1),1,Array(iOff+ipQ ),1) - iOff = iOff + nT - call dcopy_(nEta,Q(1,2),1,Array(iOff+ipQ ),1) - iOff = iOff + nT - call dcopy_(nEta,Q(1,3),1,Array(iOff+ipQ ),1) - Else - Do iEta = 1, nEta - iOff = (iEta-1)*nZeta - call dcopy_(nZeta,Zeta, 1,Array(iOff+ipZeta ),1) - call dcopy_(nZeta,ZInv, 1,Array(iOff+ipZInv ),1) - call dcopy_(nZeta,rKapab,1,Array(iOff+iprKapab),1) - call dcopy_(nZeta,P(1,1),1,Array(iOff+ipP ),1) - iOff = iOff + nZeta*nEta - call dcopy_(nZeta,P(1,2),1,Array(iOff+ipP ),1) - iOff = iOff + nZeta*nEta - call dcopy_(nZeta,P(1,3),1,Array(iOff+ipP ),1) - End Do - Do iZeta = 1, nZeta - iOff = iZeta-1 - call dcopy_(nEta, Eta, 1,Array(iOff+ipEta) ,nZeta) - call dcopy_(nEta,EInv, 1,Array(iOff+ipEInv),nZeta) - call dcopy_(nEta,rKapcd,1,Array(iOff+iprKapcd),nZeta) - call dcopy_(nEta,Q(1,1),1,Array(iOff+ipQ ),nZeta) - iOff = iOff + nZeta*nEta - call dcopy_(nEta,Q(1,2),1,Array(iOff+ipQ ),nZeta) - iOff = iOff + nZeta*nEta - call dcopy_(nEta,Q(1,3),1,Array(iOff+ipQ ),nZeta) - End Do - End If -* -* Compute tha arguments for which we will compute the roots and -* the weights. -* - Call Tvalue(Array(ipZeta),Array(ipEta),Array(ipP),Array(ipQ), - & Array(iprKapab),Array(iprKapcd),Array(ipTv), - & Array(ipFact), Array(ipDiv),nT,IsChi,ChiI2) -* Let go of rKapab and rKapcd - ip = ip - 2*nT -* -* Compute roots and weights. Make sure that the weights ends up in -* the array where the z component of the 2D integrals will be. -* Call vRysRW if roots and weights are tabulated in various Taylor -* expansions. If not tabulated call RtsWgh. If from scratch -* (no table at all), call RysRtsWgh -* -* Pointer to z-component of 2D-integrals where the weights will be -* put directly. This corresponds to xyz2D(1,1,3,0,0). - ipWgh = ipxyz + 2*nT*nRys -#ifdef _RYS_SCRATCH_ -#ifdef _CHECK_ - If (ip-1.gt.nArray) Then - Call WarningMessage(2,'Rys: ip-1 =/= nArray (pos.2)') - Write (6,*) ' nArray=',nArray - Write (6,*) ' ip-1 =',ip-1 - Call Abend() - End If -#endif - Call RysRtsWgh(Array(ipTv),nT,Array(ipU2),Array(ipWgh),nRys) -#else - If (nRys.gt.nMxRys .or. NoTab) Then -#ifdef _CHECK_ - If (ip-1.gt.nArray) Then - Call WarningMessage(2,'Rys: ip-1 =/= nArray (pos.2)') - Write (6,*) ' nArray=',nArray - Write (6,*) ' ip-1 =',ip-1 - Call Abend() - End If -#endif - Call RtsWgh(Array(ipTv),nT,Array(ipU2),Array(ipWgh),nRys) - Else -#ifdef _CHECK_ - If (ip-1.gt.nArray) Then - Call WarningMessage(2,'Rys: ip-1 =/= nArray (pos.3)') - Write (6,*) ' nArray=',nArray - Write (6,*) ' ip-1 =',ip-1 - Call Abend() - End If -#endif - Call vRysRW(la,lb,lc,ld,Array(ipTv),Array(ipU2),Array(ipWgh), - & nT,nRys) - End If -#endif -* Let go of arguments - ip = ip - nT -* -* Compute coefficients for the recurrence relations of the -* 2D-integrals -* - If (la+lb+lc+ld.gt.0) Call ModU2(Array(ipU2),nT,nRys,Array(ipDiv)) -* Let go of inverse - ip = ip - nT - - Call Cff2D(Max(nabMax-1,0),Max(ncdMax-1,0),nRys, - & Array(ipZeta),Array(ipZInv),Array(ipEta),Array(ipEInv), - & nT,Coori,CoorAC,Array(ipP),Array(ipQ),la,lb,lc,ld, - & Array(ipU2),Array(ipPAQP),Array(ipQCPQ), - & Array(ipB10),Array(ipB00),labMax,Array(ipB01)) -* Let go of roots - ip = ip - nT*nRys -* Let go of Zeta, ZInv, Eta, and EInv - ip = ip - nT*4 -* Let go of P and Q - ip = ip - 6*nT -* -* Compute the 2D-integrals from the roots and weights -* - Call Rys2D(Array(ipxyz),nT,nRys,nabMax, - & ncdMax,Array(ipPAQP),Array(ipQCPQ), - & Array(ipB10),Max(nabMax-1,0), - & Array(ipB00),labMax, - & Array(ipB01),Max(ncdMax-1,0)) - ip = ip - nTR*3*lB01 - ip = ip - nTR*3*lB00 - ip = ip - nTR*3*lB10 - ip = ip - nTR*3 - ip = ip - nTR*3 -* -* Compute [a0|c0] integrals -* - ipScr = ip - ip = ip + nT*nRys - AeqB = EQ(Coora(1,1),Coora(1,2)) - CeqD = EQ(Coora(1,3),Coora(1,4)) -* * -************************************************************************ -* * -* Use Molpro Coulomb attenuation driver for the -* FMM short-range integrals -* - If ((shortrange.and..not.(isr_simulate.gt.1)) .or. - & FMM_shortrange) Then -* * -************************************************************************ -* * - If (.not.secondpass) Then -* -* [in the first pass, the ordinary full integrals are created -* in Array(ipScr)] - Call RysEF(Array(ipxyz),nT,nT,nRys, - & nabMin,nabMax,ncdMin,ncdMax, - & Array(ipAC),mabMin,mabMax,mcdMin,mcdMax, - & Array(ipScr),Array(ipFact),AeqB,CeqD) -* [release memory at ipScr] - ip = ip - nT*nRys -* [in the second pass we will make the long range integrals:] - If (FMM_shortrange) Then - asymptotic_Rys = .True. - Else - IsChi = 1 - End If -* [set flag for 2nd pass, then go ahead and do 2nd pass] - secondpass=.true. - goto 2304 -* - Else -* -* [in the second run, the long range integrals are created -* in Array(ipScr_long)] - Call RysEF(Array(ipxyz),nT,nT,nRys, - & nabMin,nabMax,ncdMin,ncdMax, - & Array(ipAC_long),mabMin,mabMax,mcdMin,mcdMax, - & Array(ipScr),Array(ipFact),AeqB,CeqD) -* [make difference to produce the desired short range -* integrals] - If((.not.(isr_simulate.gt.0)) .or. - & FMM_shortrange) then - call daxpy_(nT*(mabMax-mabMin+1)*(mcdMax-mcdMin+1), - & -One,Array(ipAC_long),1,Array(ipAC),1) - End If -* -* [reset IsChi for ordinary full integrals] - If (FMM_shortrange) Then - asymptotic_Rys = .False. - Else - IsChi=0 - End If -* - End If -* * -************************************************************************ -* * - Else -* * -************************************************************************ -* * - Call RysEF(Array(ipxyz),nT,nT,nRys, - & nabMin,nabMax,ncdMin,ncdMax, - & Array(ipAC),mabMin,mabMax,mcdMin,mcdMax, - & Array(ipScr),Array(ipFact),AeqB,CeqD) -* * -************************************************************************ -* * - End If -* * -************************************************************************ -* * - ip = ip - nT*nRys - ip = ip - nabcd*3*nT*nRys - ip = ip - nT -* - release additional memory allocated for long range integrals - If (shortrange.or.FMM_shortrange) - & ip = ip - nT*(mabMax-mabMin+1)*(mcdMax-mcdMin+1) - End Select -#ifdef _DEBUGPRINT_ - mabcd=(mabMax-mabMin+1)*(mcdMax-mcdMin+1) - Call RecPrt('{e0|f0}',' ',Array,nT,mabcd) -#endif -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/rys.F90 openmolcas-22.10/src/rys_util/rys.F90 --- openmolcas-22.02/src/rys_util/rys.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rys.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,503 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991,1994, Roland Lindh * +! 1990, IBM * +! 2017, Ignacio Fdez. Galvan * +!*********************************************************************** + +subroutine Rys(iAnga,nT,Zeta,ZInv,nZeta,Eta,EInv,nEta,P,lP,Q,lQ,rKapab,rKapcd,Coori,Coora,CoorAC,mabMin,mabMax,mcdMin,mcdMax, & + Array,nArray,Tvalue,ModU2,Cff2D,Rys2D,NoSpecial) +!*********************************************************************** +! * +! Object: to compute the source integrals for the transfer equation * +! with the Rys quadrature, i.e. the integrals [e0|f0] will be * +! computed (e=Max(la,lb),la+lb,f=Max(lc,ld),lc+ld). * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! Modified for k2 loop. August '91 * +! Modified for decreased memory access January '94 * +! Modified for special routines Jan-Mar '94 * +!*********************************************************************** + +use vRys_RW, only: Cff, ddx, HerR2, HerW2, iCffR, iCffW, iHerR2, iHerW2, iMap, ix0, Map, nMap, nx0, TMax, x0 +use Gateway_Info, only: ChiI2 +use Gateway_global, only: asymptotic_Rys, FMM_shortrange, IsChi, NoTab +#ifdef _RYS_SCRATCH_ +use RysScratch, only: RysRtsWgh +#else +use vRys_RW, only: nMxRys +#endif +use Index_Functions, only: iTri +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iAnga(4), nT, nZeta, nEta, lP, lQ, mabMin, mabMax, mcdMin, mcdMax, nArray +real(kind=wp), intent(in) :: Zeta(nZeta), ZInv(nZeta), Eta(nEta), EInv(nEta), P(lP,3), Q(lQ,3), rKapab(nZeta), rKapcd(nEta), & + Coori(3,4), Coora(3,4), CoorAC(3,2) +real(kind=wp), intent(inout) :: Array(nArray) +external :: Tvalue, ModU2, Cff2D, Rys2D +logical(kind=iwp), intent(in) :: NoSpecial +integer(kind=iwp) :: iab, iabcd, icd, iEta, ij, ijkl, iOff, ip, ip_Array_Dummy, ipAC, ipAC_long, ipB00, ipB01, ipB10, ipDiv, & + ipEInv, ipEta, ipFact, ipP, ipPAQP, ipQ, ipQCPQ, iprKapab, iprKapcd, ipScr, ipTv, ipU2, ipWgh, ipxyz, ipZeta, & + ipZInv, iZeta, kl, la, labMax, lb, lB00, lB01, lB10, lc, ld, nabcd, nabMax, nabMin, ncdMax, ncdMin, nRys, & + ntmp, nTR +logical(kind=iwp) :: AeqB, CeqD, secondpass +logical(kind=iwp), external :: EQ + +!#define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +write(u6,*) 'NoSpecial=',NoSpecial +call RecPrt(' In Rys:P','(10G15.5)',P,lP,3) +call RecPrt(' In Rys:Q','(10G15.5)',Q,lQ,3) +call RecPrt(' In Rys:Zeta','(10G15.5)',Zeta,nZeta,1) +call RecPrt(' In Rys:Eta','(10G15.5)',Eta,nEta,1) +write(u6,*) ' In Rys: iAnga=',iAnga +call RecPrt('CoorAC',' ',CoorAC,3,2) +call RecPrt('Coora',' ',Coora,3,4) +call RecPrt('Coori',' ',Coori,3,4) +call RecPrt('rKapab',' ',rKapab,1,nZeta) +call RecPrt('rKapcd',' ',rKapcd,1,nEta) +#endif +la = iAnga(1) +lb = iAnga(2) +lc = iAnga(3) +ld = iAnga(4) +AeqB = EQ(Coori(1,1),Coori(1,2)) +CeqD = EQ(Coori(1,3),Coori(1,4)) +nRys = (la+lb+lc+ld+2)/2 +nabMax = la+lb +nabMin = max(la,lb) +ncdMax = lc+ld +ncdMin = max(lc,ld) +nabcd = (nabMax+1)*(ncdMax+1) + +! In some cases a pointer to Array will not be used. However, the +! subroutine call still have the same number of arguments. In this +! cases a "dummy pointer" is used. The pointer could point to any +! odd element in Array. I will use the last one for some unknown reason. + +ip_Array_Dummy = nArray + +ijkl = 0 +if (NoSpecial) ijkl = -1 + +! For FMM, compute short-range integrals disabling special cases +!gh - disable special cases anyway for the short range integrals + +if (FMM_shortrange) ijkl = -1 + +ij = iTri(la+1,lb+1) +kl = iTri(lc+1,ld+1) +if (ijkl == 0) ijkl = iTri(ij,kl) +select case (ijkl) + + case (1) + + ! (ss|ss) + + call ssss(Array,Zeta,nZeta,P,lP,rKapAB,Coori(1,1),Coori(1,2),Eta,nEta,Q,lQ,rKapCD,Coori(1,3),Coori(1,4),Tmax(1),Map(iMap(1)), & + nMap(1),x0(ix0(1)),nx0(1),Cff(iCffW(6,1)),Cff(iCffW(5,1)),Cff(iCffW(4,1)),Cff(iCffW(3,1)),Cff(iCffW(2,1)), & + Cff(iCffW(1,1)),Cff(iCffW(0,1)),ddx(1),HerW2(iHerW2(1)),IsChi,ChiI2) + + case (2) + + ! (ps|ss) & (ss|ps) + + if (kl == 2) call sssp(Array,Zeta,nZeta,P,lP,rKapAB,Coori(1,1),Coori(1,2),Eta,nEta,Q,lQ,rKapCD,Coori(1,3),Coori(1,4),CoorAC, & + Tmax(1),Map(iMap(1)),nMap(1),x0(ix0(1)),nx0(1),Cff(iCffW(6,1)),Cff(iCffW(5,1)),Cff(iCffW(4,1)), & + Cff(iCffW(3,1)),Cff(iCffW(2,1)),Cff(iCffW(1,1)),Cff(iCffW(0,1)),Cff(iCffR(6,1)),Cff(iCffR(5,1)), & + Cff(iCffR(4,1)),Cff(iCffR(3,1)),Cff(iCffR(2,1)),Cff(iCffR(1,1)),Cff(iCffR(0,1)),ddx(1), & + HerW2(iHerW2(1)),HerR2(iHerR2(1)),IsChi,ChiI2) + if (ij == 2) call psss(Array,Zeta,nZeta,P,lP,rKapAB,Coori(1,1),Coori(1,2),Eta,nEta,Q,lQ,rKapCD,Coori(1,3),Coori(1,4),CoorAC, & + Tmax(1),Map(iMap(1)),nMap(1),x0(ix0(1)),nx0(1),Cff(iCffW(6,1)),Cff(iCffW(5,1)),Cff(iCffW(4,1)), & + Cff(iCffW(3,1)),Cff(iCffW(2,1)),Cff(iCffW(1,1)),Cff(iCffW(0,1)),Cff(iCffR(6,1)),Cff(iCffR(5,1)), & + Cff(iCffR(4,1)),Cff(iCffR(3,1)),Cff(iCffR(2,1)),Cff(iCffR(1,1)),Cff(iCffR(0,1)),ddx(1), & + HerW2(iHerW2(1)),HerR2(iHerR2(1)),IsChi,ChiI2) + + case (3) + + ! (ps|ps) + + call psps(Array,Zeta,nZeta,P,lP,rKapAB,Coori(1,1),Coori(1,2),Eta,nEta,Q,lQ,rKapCD,Coori(1,3),Coori(1,4),CoorAC,Tmax(2), & + Map(iMap(2)),nMap(2),x0(ix0(2)),nx0(2),Cff(iCffW(6,2)),Cff(iCffW(5,2)),Cff(iCffW(4,2)),Cff(iCffW(3,2)), & + Cff(iCffW(2,2)),Cff(iCffW(1,2)),Cff(iCffW(0,2)),Cff(iCffR(6,2)),Cff(iCffR(5,2)),Cff(iCffR(4,2)),Cff(iCffR(3,2)), & + Cff(iCffR(2,2)),Cff(iCffR(1,2)),Cff(iCffR(0,2)),ddx(2),HerW2(iHerW2(2)),HerR2(iHerR2(2)),IsChi,ChiI2) + + case (4) + + ! (pp|ss) & (ss|pp) + + if (ij == 3) call ppss(Array,Zeta,ZInv,nZeta,P,lP,rKapAB,Coori(1,1),Coori(1,2),Eta,EInv,nEta,Q,lQ,rKapCD,Coori(1,3), & + Coori(1,4),CoorAC,Tmax(2),Map(iMap(2)),nMap(2),x0(ix0(2)),nx0(2),Cff(iCffW(6,2)),Cff(iCffW(5,2)), & + Cff(iCffW(4,2)),Cff(iCffW(3,2)),Cff(iCffW(2,2)),Cff(iCffW(1,2)),Cff(iCffW(0,2)),Cff(iCffR(6,2)), & + Cff(iCffR(5,2)),Cff(iCffR(4,2)),Cff(iCffR(3,2)),Cff(iCffR(2,2)),Cff(iCffR(1,2)),Cff(iCffR(0,2)),ddx(2), & + HerW2(iHerW2(2)),HerR2(iHerR2(2)),IsChi,ChiI2) + if (kl == 3) call sspp(Array,Zeta,ZInv,nZeta,P,lP,rKapAB,Coori(1,1),Coori(1,2),Eta,EInv,nEta,Q,lQ,rKapCD,Coori(1,3), & + Coori(1,4),CoorAC,Tmax(2),Map(iMap(2)),nMap(2),x0(ix0(2)),nx0(2),Cff(iCffW(6,2)),Cff(iCffW(5,2)), & + Cff(iCffW(4,2)),Cff(iCffW(3,2)),Cff(iCffW(2,2)),Cff(iCffW(1,2)),Cff(iCffW(0,2)),Cff(iCffR(6,2)), & + Cff(iCffR(5,2)),Cff(iCffR(4,2)),Cff(iCffR(3,2)),Cff(iCffR(2,2)),Cff(iCffR(1,2)),Cff(iCffR(0,2)),ddx(2), & + HerW2(iHerW2(2)),HerR2(iHerR2(2)),IsChi,ChiI2) + + case (5) + + ! (pp|ps) & (sp|pp) + + if (ij == 3) call ppps(Array,Zeta,ZInv,nZeta,P,lP,rKapAB,Coori(1,1),Coori(1,2),Eta,EInv,nEta,Q,lQ,rKapCD,Coori(1,3), & + Coori(1,4),CoorAC,Tmax(2),Map(iMap(2)),nMap(2),x0(ix0(2)),nx0(2),Cff(iCffW(6,2)),Cff(iCffW(5,2)), & + Cff(iCffW(4,2)),Cff(iCffW(3,2)),Cff(iCffW(2,2)),Cff(iCffW(1,2)),Cff(iCffW(0,2)),Cff(iCffR(6,2)), & + Cff(iCffR(5,2)),Cff(iCffR(4,2)),Cff(iCffR(3,2)),Cff(iCffR(2,2)),Cff(iCffR(1,2)),Cff(iCffR(0,2)),ddx(2), & + HerW2(iHerW2(2)),HerR2(iHerR2(2)),IsChi,ChiI2) + if (kl == 3) call sppp(Array,Zeta,ZInv,nZeta,P,lP,rKapAB,Coori(1,1),Coori(1,2),Eta,EInv,nEta,Q,lQ,rKapCD,Coori(1,3), & + Coori(1,4),CoorAC,Tmax(2),Map(iMap(2)),nMap(2),x0(ix0(2)),nx0(2),Cff(iCffW(6,2)),Cff(iCffW(5,2)), & + Cff(iCffW(4,2)),Cff(iCffW(3,2)),Cff(iCffW(2,2)),Cff(iCffW(1,2)),Cff(iCffW(0,2)),Cff(iCffR(6,2)), & + Cff(iCffR(5,2)),Cff(iCffR(4,2)),Cff(iCffR(3,2)),Cff(iCffR(2,2)),Cff(iCffR(1,2)),Cff(iCffR(0,2)),ddx(2), & + HerW2(iHerW2(2)),HerR2(iHerR2(2)),IsChi,ChiI2) + + case (6) + + ! (pp|pp) + + call pppp(Array,Zeta,ZInv,nZeta,P,lP,rKapAB,Coori(1,1),Coori(1,2),Eta,EInv,nEta,Q,lQ,rKapCD,Coori(1,3),Coori(1,4),CoorAC, & + Tmax(3),Map(iMap(3)),nMap(3),x0(ix0(3)),nx0(3),Cff(iCffW(6,3)),Cff(iCffW(5,3)),Cff(iCffW(4,3)),Cff(iCffW(3,3)), & + Cff(iCffW(2,3)),Cff(iCffW(1,3)),Cff(iCffW(0,3)),Cff(iCffR(6,3)),Cff(iCffR(5,3)),Cff(iCffR(4,3)),Cff(iCffR(3,3)), & + Cff(iCffR(2,3)),Cff(iCffR(1,3)),Cff(iCffR(0,3)),ddx(3),HerW2(iHerW2(3)),HerR2(iHerR2(3)),IsChi,ChiI2) + + case default + + ! General code + + ! Allocate memory for integrals of [a0|c0] type + ip = 1 + ipAC = ip + ip = ip+nT*(mabMax-mabMin+1)*(mcdMax-mcdMin+1) + !gh - in order to produce the short range integrals, two arrays of + !gh - this type are needed - one for the ordinary full range, one for + !gh - the long range integrals + !gh - (additional memory has been declared in MemRys) + ipAC_long = ipAC + if (FMM_shortrange) then + ipAC_long = ip + ip = ip+nT*(mabMax-mabMin+1)*(mcdMax-mcdMin+1) + end if + ! Allocate memory for the normalization factors + ipFact = ip + ip = ip+nT + ! Allocate memory for the 2D-integrals. + ipxyz = ip + ip = ip+nabcd*3*nT*nRys + secondpass = .false. + ! jump mark for second pass: + do + ! Allocate memory for the coefficients in the recurrence relation + ! of the 2D-integrals. + nTR = nT*nRys + if (NoSpecial) then + ipPAQP = ip + else + if (nabMax >= 1) then + iab = 2 + icd = 1 + iabcd = (nabMax+1)*(icd-1)+iab-1 + ipPAQP = ipxyz+3*nT*nRys*iabcd + else + ipPAQP = ip_Array_Dummy + end if + end if + ip = ip+nTR*3 + if (NoSpecial) then + ipQCPQ = ip + else + if (ncdMax >= 1) then + iab = 1 + icd = 2 + iabcd = (nabMax+1)*(icd-1)+iab-1 + ipQCPQ = ipxyz+3*nT*nRys*iabcd + else + ipQCPQ = ip_Array_Dummy + end if + end if + ip = ip+nTR*3 + lB10 = max(min(nabMax-1,1),0) + if (lB10 >= 1) then + ipB10 = ip + else + ipB10 = ip_Array_Dummy + end if + ip = ip+nTR*3*lB10 + labMax = min(nabMax,ncdMax) + lB00 = max(min(labMax,1),0) + if (lB00 >= 1) then + ipB00 = ip + else + ipB00 = ip_Array_Dummy + end if + ip = ip+nTR*3*lB00 + lB01 = max(min(ncdMax-1,1),0) + if (lB01 >= 1) then + ipB01 = ip + else + ipB01 = ip_Array_Dummy + end if + ip = ip+nTR*3*lB01 + ! Allocate memory for the roots. + ipU2 = ip + ip = ip+nT*nRys + ! Allocate memory for Zeta, ZInv, Eta, EInv + ipZeta = ip + ip = ip+nT + ipEta = ip + ip = ip+nT + ipZInv = ip + ip = ip+nT + ipEInv = ip + ip = ip+nT + ! Allocate memory for P and Q + ipP = ip + ip = ip+3*nT + ipQ = ip + ip = ip+3*nT + ! Allocate memory for the inverse. + ipDiv = ip + ip = ip+nT + ! Allocate memory for the arguments. + ipTv = ip + ip = ip+nT + ! Allocate memory for rKapab and rKapcd + iprKapab = ip + ip = ip+nT + iprKapcd = ip + ip = ip+nT +!# define _CHECK_ +# ifdef _CHECK_ + if (ip-1 > nArray) then + call WarningMessage(2,'Rys: ip-1 =/= nArray (pos.1)') + write(u6,*) ' nArray=',nArray + write(u6,*) ' ip-1 =',ip-1 + write(u6,*) ' nRys =',nRys + write(u6,*) ' nZeta =',nZeta + write(u6,*) ' nEta =',nEta + call Abend() + end if +# endif + + ! Expand Zeta, ZInv, Eta ,EInv, rKapab, rKapcd, P, and Q + + if (nEta*nZeta /= nT) then + if ((nEta /= nT) .and. (nZeta /= nT)) then + write(u6,*) 'Corrupted parameters!' + call Abend() + end if + iOff = 0 + call dcopy_(nZeta,Zeta,1,Array(iOff+ipZeta),1) + call dcopy_(nZeta,ZInv,1,Array(iOff+ipZInv),1) + call dcopy_(nZeta,rKapab,1,Array(iOff+iprKapab),1) + call dcopy_(nZeta,P(1,1),1,Array(iOff+ipP),1) + iOff = iOff+nT + call dcopy_(nZeta,P(1,2),1,Array(iOff+ipP),1) + iOff = iOff+nT + call dcopy_(nZeta,P(1,3),1,Array(iOff+ipP),1) + iOff = 0 + call dcopy_(nEta,Eta,1,Array(iOff+ipEta),1) + call dcopy_(nEta,EInv,1,Array(iOff+ipEInv),1) + call dcopy_(nEta,rKapcd,1,Array(iOff+iprKapcd),1) + call dcopy_(nEta,Q(1,1),1,Array(iOff+ipQ),1) + iOff = iOff+nT + call dcopy_(nEta,Q(1,2),1,Array(iOff+ipQ),1) + iOff = iOff+nT + call dcopy_(nEta,Q(1,3),1,Array(iOff+ipQ),1) + else + do iEta=1,nEta + iOff = (iEta-1)*nZeta + call dcopy_(nZeta,Zeta,1,Array(iOff+ipZeta),1) + call dcopy_(nZeta,ZInv,1,Array(iOff+ipZInv),1) + call dcopy_(nZeta,rKapab,1,Array(iOff+iprKapab),1) + call dcopy_(nZeta,P(1,1),1,Array(iOff+ipP),1) + iOff = iOff+nZeta*nEta + call dcopy_(nZeta,P(1,2),1,Array(iOff+ipP),1) + iOff = iOff+nZeta*nEta + call dcopy_(nZeta,P(1,3),1,Array(iOff+ipP),1) + end do + do iZeta=1,nZeta + iOff = iZeta-1 + call dcopy_(nEta,Eta,1,Array(iOff+ipEta),nZeta) + call dcopy_(nEta,EInv,1,Array(iOff+ipEInv),nZeta) + call dcopy_(nEta,rKapcd,1,Array(iOff+iprKapcd),nZeta) + call dcopy_(nEta,Q(1,1),1,Array(iOff+ipQ),nZeta) + iOff = iOff+nZeta*nEta + call dcopy_(nEta,Q(1,2),1,Array(iOff+ipQ),nZeta) + iOff = iOff+nZeta*nEta + call dcopy_(nEta,Q(1,3),1,Array(iOff+ipQ),nZeta) + end do + end if + + ! Compute the arguments for which we will compute the roots and the weights. + + call Tvalue(Array(ipZeta),Array(ipEta),Array(ipP),Array(ipQ),Array(iprKapab),Array(iprKapcd),Array(ipTv),Array(ipFact), & + Array(ipDiv),nT,IsChi,ChiI2) + ! Let go of rKapab and rKapcd + ip = ip-2*nT + + ! Compute roots and weights. Make sure that the weights ends up in + ! the array where the z component of the 2D integrals will be. + ! Call vRysRW if roots and weights are tabulated in various Taylor + ! expansions. If not tabulated call RtsWgh. If from scratch + ! (no table at all), call RysRtsWgh + + ! Pointer to z-component of 2D-integrals where the weights will be + ! put directly. This corresponds to xyz2D(1,1,3,0,0). + ipWgh = ipxyz+2*nT*nRys +# ifdef _RYS_SCRATCH_ +# ifdef _CHECK_ + if (ip-1 > nArray) then + call WarningMessage(2,'Rys: ip-1 =/= nArray (pos.2)') + write(u6,*) ' nArray=',nArray + write(u6,*) ' ip-1 =',ip-1 + call Abend() + end if +# endif + call RysRtsWgh(Array(ipTv),nT,Array(ipU2),Array(ipWgh),nRys) +# else + if ((nRys > nMxRys) .or. NoTab) then +# ifdef _CHECK_ + if (ip-1 > nArray) then + call WarningMessage(2,'Rys: ip-1 =/= nArray (pos.2)') + write(u6,*) ' nArray=',nArray + write(u6,*) ' ip-1 =',ip-1 + call Abend() + end if +# endif + call RtsWgh(Array(ipTv),nT,Array(ipU2),Array(ipWgh),nRys) + else +# ifdef _CHECK_ + if (ip-1 > nArray) then + call WarningMessage(2,'Rys: ip-1 =/= nArray (pos.3)') + write(u6,*) ' nArray=',nArray + write(u6,*) ' ip-1 =',ip-1 + call Abend() + end if +# endif + call vRysRW(la,lb,lc,ld,Array(ipTv),Array(ipU2),Array(ipWgh),nT,nRys) + end if +# endif + ! Let go of arguments + ip = ip-nT + + ! Compute coefficients for the recurrence relations of the 2D-integrals + + if (la+lb+lc+ld > 0) call ModU2(Array(ipU2),nT,nRys,Array(ipDiv)) + ! Let go of inverse + ip = ip-nT + + call Cff2D(max(nabMax-1,0),max(ncdMax-1,0),nRys,Array(ipZeta),Array(ipZInv),Array(ipEta),Array(ipEInv),nT,Coori,CoorAC, & + Array(ipP),Array(ipQ),la,lb,lc,ld,Array(ipU2),Array(ipPAQP),Array(ipQCPQ),Array(ipB10),Array(ipB00),labMax, & + Array(ipB01)) + ! Let go of roots + ip = ip-nT*nRys + ! Let go of Zeta, ZInv, Eta, and EInv + ip = ip-nT*4 + ! Let go of P and Q + ip = ip-6*nT + + ! Compute the 2D-integrals from the roots and weights + + call Rys2D(Array(ipxyz),nT,nRys,nabMax,ncdMax,Array(ipPAQP),Array(ipQCPQ),Array(ipB10),Array(ipB00),Array(ipB01)) + ip = ip-nTR*3*lB01 + ip = ip-nTR*3*lB00 + ip = ip-nTR*3*lB10 + ip = ip-nTR*3 + ip = ip-nTR*3 + + ! Compute [a0|c0] integrals + + ipScr = ip + ip = ip+nT*nRys + AeqB = EQ(Coora(1,1),Coora(1,2)) + CeqD = EQ(Coora(1,3),Coora(1,4)) + ! * + !***************************************************************** + ! * + ! Use Molpro Coulomb attenuation driver for the + ! FMM short-range integrals + + if (FMM_shortrange) then + ! * + !*************************************************************** + ! * + if (.not. secondpass) then + + ! [in the first pass, the ordinary full integrals are created in Array(ipScr)] + call RysEF(Array(ipxyz),nT,nT,nRys,nabMin,nabMax,ncdMin,ncdMax,Array(ipAC),mabMin,mabMax,mcdMin,mcdMax,Array(ipScr), & + Array(ipFact),AeqB,CeqD) + ! [release memory at ipScr] + ip = ip-nT*nRys + ! [in the second pass we will make the long range integrals:] + if (FMM_shortrange) then + asymptotic_Rys = .true. + else + IsChi = 1 + end if + ! [set flag for 2nd pass, then go ahead and do 2nd pass] + secondpass = .true. + + else + + ! [in the second run, the long range integrals are created in Array(ipScr_long)] + call RysEF(Array(ipxyz),nT,nT,nRys,nabMin,nabMax,ncdMin,ncdMax,Array(ipAC_long),mabMin,mabMax,mcdMin,mcdMax, & + Array(ipScr),Array(ipFact),AeqB,CeqD) + ! [make difference to produce the desired short range integrals] + if (FMM_shortrange) then + ntmp = nT*(mabMax-mabMin+1)*(mcdMax-mcdMin+1) + Array(ipAC:ipAC+ntmp-1) = Array(ipAC:ipAC+ntmp-1)-Array(ipAC_long:ipAC_long+ntmp-1) + end if + + ! [reset IsChi for ordinary full integrals] + if (FMM_shortrange) then + asymptotic_Rys = .false. + else + IsChi = 0 + end if + exit + + end if + ! * + !*************************************************************** + ! * + else + ! * + !*************************************************************** + ! * + call RysEF(Array(ipxyz),nT,nT,nRys,nabMin,nabMax,ncdMin,ncdMax,Array(ipAC),mabMin,mabMax,mcdMin,mcdMax,Array(ipScr), & + Array(ipFact),AeqB,CeqD) + exit + ! * + !*************************************************************** + ! * + end if + end do + ! * + !******************************************************************* + ! * + ip = ip-nT*nRys + ip = ip-nabcd*3*nT*nRys + ip = ip-nT + ! - release additional memory allocated for long range integrals + if (FMM_shortrange) ip = ip-nT*(mabMax-mabMin+1)*(mcdMax-mcdMin+1) +end select +#ifdef _DEBUGPRINT_ +mabcd = (mabMax-mabMin+1)*(mcdMax-mcdMin+1) +call RecPrt('{e0|f0}',' ',Array,nT,mabcd) +#endif + +return + +end subroutine Rys diff -Nru openmolcas-22.02/src/rys_util/rysg1.f openmolcas-22.10/src/rys_util/rysg1.f --- openmolcas-22.02/src/rys_util/rysg1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rysg1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,335 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine Rysg1(iAnga,nRys,nT, - & Alpha,Beta,Gamma,Delta, - & Zeta,ZInv,nZeta,Eta,EInv,nEta, - & P,lP,Q,lQ,Coori,Coora,CoorAC, - & Array,nArray, - & Tvalue,ModU2,Cff2D, - & PAO,nPAO,Grad,nGrad,IfGrad,IndGrd,kOp,iuvwx) -************************************************************************ -* * -* Object: to compute the gradient of the two-electron integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* Modified to 1st order derivatives October '91 * -************************************************************************ - use vRys_RW - use Symmetry_Info, only: iOper - use Gateway_Info, only: ChiI2 - use Gateway_global, only: IsChi - Implicit Real*8 (A-H,O-Z) - External Tvalue, ModU2, Cff2D - External Exp_1, Exp_2 -#include "real.fh" -#include "notab.fh" -#include "print.fh" - Real*8 Zeta(nZeta), ZInv(nZeta), P(lP,3), - & Eta(nEta), EInv(nEta), Q(lQ,3), - & Alpha(nZeta), Beta(nZeta), Gamma(nEta), Delta(nEta), - & CoorAC(3,2), Coora(3,4), Coori(3,4), Array(nArray), - & PAO(nT,nPAO), Grad(nGrad), Temp(9) - Integer iAnga(4), IndGrd(3,4), Index(3,4), - & kOp(4), iuvwx(4), JndGrd(3,4), lOp(4) - Logical IfGrad(3,4), JfGrad(3,4) -* - lOp(1) = iOper(kOp(1)) - lOp(2) = iOper(kOp(2)) - lOp(3) = iOper(kOp(3)) - lOp(4) = iOper(kOp(4)) -#ifdef _DEBUGPRINT_ - call dcopy_(lP-nZeta,[Zero],0,P(nZeta+1,1),1) - call dcopy_(lP-nZeta,[Zero],0,P(nZeta+1,2),1) - call dcopy_(lP-nZeta,[Zero],0,P(nZeta+1,3),1) - Call RecPrt(' In Rysg1:P',' ',P,lP,3) - call dcopy_(lQ-nEta,[Zero],0,Q(nEta+1,1),1) - call dcopy_(lQ-nEta,[Zero],0,Q(nEta+1,2),1) - call dcopy_(lQ-nEta,[Zero],0,Q(nEta+1,3),1) - Call RecPrt(' In Rysg1:Q',' ',Q,lQ,3) - Call RecPrt(' In Rysg1:Zeta',' ',Zeta,nZeta,1) - Call RecPrt(' In Rysg1:ZInv',' ',ZInv,nZeta,1) - Call RecPrt(' In Rysg1:Eta',' ',Eta,nEta,1) - Call RecPrt(' In Rysg1:EInv',' ',EInv,nEta,1) - Call RecPrt(' In Rysg1:Alpha',' ',Alpha,nZeta,1) - Call RecPrt(' In Rysg1:Beta ',' ',Beta ,nZeta,1) - Call RecPrt(' In Rysg1:Gamma',' ',Gamma,nEta,1) - Call RecPrt(' In Rysg1:Delta',' ',Delta,nEta,1) - Call RecPrt(' In Rysg1:Coora',' ',Coora,3,4) - Call RecPrt(' In Rysg1:Coori',' ',Coori,3,4) - Call RecPrt(' In Rysg1:CoorAC',' ',CoorAC,3,2) - Write (6,*) ' In Rysg1: iAnga=',iAnga -#endif - la = iAnga(1) - lb = iAnga(2) - lc = iAnga(3) - ld = iAnga(4) - lla = 0 - llb = 0 - llc = 0 - lld = 0 - Do 10 i = 1, 3 - If (IfGrad(i,1)) Then - lla = 1 - End If - If (IfGrad(i,2)) Then - llb = 1 - End If - If (IfGrad(i,3)) Then - llc = 1 - End If - If (IfGrad(i,4)) Then - lld = 1 - End If - 10 Continue - lab = Max(lla,llb) - lcd = Max(llc,lld) - nabMax = la + lb + lab - ncdMax = lc + ld + lcd -* -* Allocate memory for the integral gradients. -* - ip = 1 -* ipAC = ip -* ip = ip + nT*nPAO * 9 -* -* Allocate memory for the 2D-integrals. -* - ip2D0 = ip - n2D0 = Max( (nabMax+1)*(ncdMax+1), - & (la+2)*(lb+2)*(ncdMax+1), - & (la+2)*(lb+2)*(lc+2)*(ld+2)) - ip = ip + n2D0*3*nT*nRys -* -* Allocate memory for the 1st order derivatives of the 2D-integrals. -* - ip2D1 = ip - n2D1 = Max( (nabMax+1)*(ncdMax+1), - & (la+2)*(lb+2)*(ncdMax+1), - & (la+1)*(lb+1)*(lc+1)*(ld+1)*3) - ip = ip + n2D1*3*nT*nRys -* -* Allocate memory for the coefficients in the recurrence relation -* of the 2D-integrals. -* - nTR=nT*nRys - ipPAQP = ip - ip = ip + nTR*3 - ipQCPQ = ip - ip = ip + nTR*3 - ipB10 = ip - lB10=Max(Min(nabMax-1,1),0) - ip = ip + nTR*3*lB10 - labMax = Min(nabMax,ncdMax) - ipB00 = ip - lB00=Max(Min(labMax,1),0) - ip = ip + nTR*3*lB00 - ipB01 = ip - lB01=Max(Min(ncdMax-1,1),0) - ip = ip + nTR*3*lB01 -* Allocate memory for the roots. - ipU2 = ip - ip = ip + nT*nRys -* Allocate memory for Zeta, ZInv, Eta, EInv - ipZeta = ip - ip = ip + nT - ipEta = ip - ip = ip + nT - ipZInv = ip - ip = ip + nT - ipEInv = ip - ip = ip + nT -* Allocate memory for P and Q - ipP = ip - ip = ip + 3*nT - ipQ = ip - ip = ip + 3*nT -* Allocate memory for the inverse. - ipDiv = ip - ip = ip + nT -* Allocate memory for the arguments. - ipTv = ip - ip = ip + nT -*define _CHECK_ -#ifdef _CHECK_ - If (ip-1.gt.nArray) Then - Call WarningMessage(2,'Rysg1: ip-1 =/= nArray (pos.1)') - Write (6,*) ' nArray=',nArray - Write (6,*) ' ip-1 =',ip-1 - Write (6,*) ' nRys =',nRys - Write (6,*) ' nZeta =',nZeta - Write (6,*) ' nEta =',nEta - Call Abend() - End If -#endif -* -* Expand Zeta, ZInv, Eta ,EInv, P, and Q -* - Do iEta = 1, nEta - iOff = (iEta-1)*nZeta - call dcopy_(nZeta,Zeta, 1,Array(iOff+ipZeta ),1) - call dcopy_(nZeta,ZInv, 1,Array(iOff+ipZInv ),1) - call dcopy_(nZeta,P(1,1),1,Array(iOff+ipP ),1) - iOff = iOff + nZeta*nEta - call dcopy_(nZeta,P(1,2),1,Array(iOff+ipP ),1) - iOff = iOff + nZeta*nEta - call dcopy_(nZeta,P(1,3),1,Array(iOff+ipP ),1) - End Do - Do iZeta = 1, nZeta - iOff = iZeta-1 - call dcopy_(nEta, Eta, 1,Array(iOff+ipEta) ,nZeta) - call dcopy_(nEta,EInv, 1,Array(iOff+ipEInv),nZeta) - call dcopy_(nEta,Q(1,1),1,Array(iOff+ipQ ),nZeta) - iOff = iOff + nZeta*nEta - call dcopy_(nEta,Q(1,2),1,Array(iOff+ipQ ),nZeta) - iOff = iOff + nZeta*nEta - call dcopy_(nEta,Q(1,3),1,Array(iOff+ipQ ),nZeta) - End Do -* -* Compute the arguments for which we will compute the roots and -* the weights. -* - Call Tvalue(Array(ipZeta),Array(ipEta),Array(ipP),Array(ipQ),nT, - & Array(ipTv),Array(ipDiv),IsChi,ChiI2) -* -* Compute roots and weights. Make sure that the weights ends up in -* the array where the z component of the 2D integrals will be. -* Call vRysRW if roots and weights are tabulated in various Taylor -* expansions. If not tabulated call RtsWgh. -* -* Pointer to z-component of 2D-integrals where the weights will be -* put directly. This corresponds to xyz2D(1,1,3,0,0). - ipWgh = ip2D0 + 2*nT*nRys - If (nRys.gt.nMxRys .or. NoTab) Then -#ifdef _CHECK_ - If (ip-1.gt.nArray) Then - Call WarningMessage(2,'Rysg1: ip-1 =/= nArray (pos.2)') - Write (6,*) ' nArray=',nArray - Write (6,*) ' ip-1 =',ip-1 - Call Abend() - End If -#endif - Call RtsWgh(Array(ipTv),nT,Array(ipU2),Array(ipWgh),nRys) - Else -#ifdef _CHECK_ - If (ip-1.gt.nArray) Then - Call WarningMessage(2,'Rysg1: ip-1 =/= nArray (pos.3)') - Write (6,*) ' nArray=',nArray - Write (6,*) ' ip-1 =',ip-1 - Call Abend() - End If -#endif - Call vRysRW(la+1,lb,lc,ld,Array(ipTv),Array(ipU2),Array(ipWgh), - & nT,nRys) - End If -*-----Drop ipTv - ip = ip - nT -* -* Modify the roots. -* - Call ModU2(Array(ipU2),nT,nRys,Array(ipDiv)) -*-----Drop ipDiv - ip = ip - nT -* -* Compute coefficients for the recurrence relations of the -* 2D-integrals -* - Call Cff2D(Max(nabMax-1,0),Max(ncdMax-1,0),nRys, - & Array(ipZeta),Array(ipZInv),Array(ipEta),Array(ipEInv), - & nT,Coori,CoorAC,Array(ipP),Array(ipQ), - & la+lab,lb,lc+lcd,ld, - & Array(ipU2),Array(ipPAQP),Array(ipQCPQ), - & Array(ipB10),Array(ipB00),labMax,Array(ipB01)) -*-----Drop ipU2 - ip = ip - nT*nRys -* Let go of Zeta, ZInv, Eta, and EInv - ip = ip - nT*4 -* Let go of P and Q - ip = ip - 6*nT -* -* Compute the intermediate 2D-integrals from the roots and weights. -* - Call vRys2Dm(Array(ip2D0),nT,nRys,nabMax, - & ncdMax,Array(ipPAQP),Array(ipQCPQ), - & Array(ipB10),Max(nabMax-1,0), - & Array(ipB00),labMax, - & Array(ipB01),Max(ncdMax-1,0), - & la,lb,lc,ld,IfGrad) -*-----Drop ipB01 - ip = ip - nTR*3*lB01 -*-----Drop ipB00 - ip = ip - nTR*3*lB00 -*-----Drop ipB10 - ip = ip - nTR*3*lB10 -*-----Drop ipQCPQ - ip = ip - nTR*3 -*-----Drop ipPAQP - ip = ip - nTR*3 -* -*-----Apply the transfer equation to the intermediate 2D-integrals. -* - Call HrrCtl(Array(ip2D0),n2D0,Array(ip2D1),n2D1, - & la,lb,lc,ld,nabmax,ncdmax, - & nTR,Coora(1,1),Coora(1,2),Coora(1,3),Coora(1,4), - & IfGrad) -* -* Compute the gradients of the 2D-integrals. Copy some information -* which will be modified. This has to be done in order to facilitate -* partitioning. -* - ipScr = ip - ip = ip + nT*nRys - ipTmp = ip - ip = ip + nT - Call ICopy(12,IndGrd,1,JndGrd,1) - Do 8877 i = 1, 3 - Do 7788 j = 1, 4 - JfGrad(i,j) = IfGrad(i,j) - 7788 Continue - 8877 Continue - Call Rys2Dg(Array(ip2D0),nT,nRys,la,lb,lc,ld, - & Array(ip2D1),JfGrad, - & JndGrd,Coora,Alpha,Beta,Gamma,Delta,nZeta,nEta, - & Array(ipScr),Array(ipTmp),Index, - & Exp_1,Exp_2,nZeta,nEta) -*-----Drop ipScr - ip = ip - nTR -*-----Drop ipTmp - ip = ip - nT -* -* Assemble the gradients of the ERI's -* - Call Assg1(Temp,PAO,nT,nRys,la,lb,lc,ld,Array(ip2D0), - & Array(ip2D1),JfGrad,Index,mVec) -*-----Drop ip2D1 - ip = ip - nTR*3*n2D1 -*-----Drop ip2D0 - ip = ip - nTR*3*n2D0 -* -* Distribute the contributions to the molecular gradient -* - Call Distg1(Temp,mVec,Grad,nGrad,JfGrad,JndGrd, - & iuvwx,lOp) -*-----Drop ipAC -* ip = ip - nT*nPAO * 9 -#ifdef _CHECK_ - If (ip.ne.1) Then - Call WarningMessage(2,'Rysg1: ip=/=1') - Call Abend() - End If -#endif -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/rysg1.F90 openmolcas-22.10/src/rys_util/rysg1.F90 --- openmolcas-22.02/src/rys_util/rysg1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rysg1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,294 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine Rysg1(iAnga,nRys,nT,Alpha,Beta,Gmma,Delta,Zeta,ZInv,nZeta,Eta,EInv,nEta,P,lP,Q,lQ,Coori,Coora,CoorAC,Array,nArray, & + Tvalue,ModU2,Cff2D,PAO,nPAO,Grad,nGrad,IfGrad,IndGrd,kOp,iuvwx) +!*********************************************************************** +! * +! Object: to compute the gradient of the two-electron integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! Modified to 1st order derivatives October '91 * +!*********************************************************************** + +use vRys_RW, only: nMxRys +use Symmetry_Info, only: iOper +use Gateway_Info, only: ChiI2 +use Gateway_global, only: IsChi, NoTab +use Definitions, only: wp, iwp +#if defined(_DEBUGPRINT_) || defined (_CHECK_) +use Definitions, only: u6 +#endif + +implicit none +integer(kind=iwp), intent(in) :: iAnga(4), nRys, nT, nZeta, nEta, lP, lQ, nArray, nPAO, nGrad, IndGrd(3,4), kOp(4), iuvwx(4) +real(kind=wp), intent(in) :: Alpha(nZeta), Beta(nZeta), Gmma(nEta), Delta(nEta), Zeta(nZeta), ZInv(nZeta), Eta(nEta), EInv(nEta), & + P(lP,3), Q(lQ,3), Coori(3,4), Coora(3,4), CoorAC(3,2), PAO(nT,nPAO) +real(kind=wp), intent(inout) :: Grad(nGrad) +real(kind=wp), intent(out) :: Array(nArray) +external :: Tvalue, ModU2, Cff2D +logical(kind=iwp), intent(in) :: IfGrad(3,4) +integer(kind=iwp) :: iEta, Indx(3,4), iOff, ip, ip2D0, ip2D1, ipB00, ipB01, ipB10, ipDiv, ipEInv, ipEta, ipP, ipPAQP, ipQ, ipQCPQ, & + ipScr, ipTmp, ipTv, ipU2, ipWgh, ipZeta, ipZInv, iZeta, JndGrd(3,4), la, lab, labMax, lb, lB00, lB01, lB10, & + lc, lcd, ld, lla, llb, llc, lld, lOp(4), mVec, n2D0, n2D1, nabMax, ncdMax, nTR +real(kind=wp) :: Temp(9) +logical(kind=iwp) :: JfGrad(3,4) +external :: Exp_1, Exp_2 + +lOp(1) = iOper(kOp(1)) +lOp(2) = iOper(kOp(2)) +lOp(3) = iOper(kOp(3)) +lOp(4) = iOper(kOp(4)) +#ifdef _DEBUGPRINT_ +call RecPrt(' In Rysg1:P',' ',P(1:nZeta,:),nZeta,3) +call RecPrt(' In Rysg1:Q',' ',Q(1:nEta,:),nEta,3) +call RecPrt(' In Rysg1:Zeta',' ',Zeta,nZeta,1) +call RecPrt(' In Rysg1:ZInv',' ',ZInv,nZeta,1) +call RecPrt(' In Rysg1:Eta',' ',Eta,nEta,1) +call RecPrt(' In Rysg1:EInv',' ',EInv,nEta,1) +call RecPrt(' In Rysg1:Alpha',' ',Alpha,nZeta,1) +call RecPrt(' In Rysg1:Beta ',' ',Beta,nZeta,1) +call RecPrt(' In Rysg1:Gamma',' ',Gmma,nEta,1) +call RecPrt(' In Rysg1:Delta',' ',Delta,nEta,1) +call RecPrt(' In Rysg1:Coora',' ',Coora,3,4) +call RecPrt(' In Rysg1:Coori',' ',Coori,3,4) +call RecPrt(' In Rysg1:CoorAC',' ',CoorAC,3,2) +write(u6,*) ' In Rysg1: iAnga=',iAnga +#endif +la = iAnga(1) +lb = iAnga(2) +lc = iAnga(3) +ld = iAnga(4) +lla = 0 +llb = 0 +llc = 0 +lld = 0 +if (any(IfGrad(:,1))) lla = 1 +if (any(IfGrad(:,2))) llb = 1 +if (any(IfGrad(:,3))) llc = 1 +if (any(IfGrad(:,4))) lld = 1 +lab = max(lla,llb) +lcd = max(llc,lld) +nabMax = la+lb+lab +ncdMax = lc+ld+lcd + +! Allocate memory for the integral gradients. + +ip = 1 +!ipAC = ip +!ip = ip+nT*nPAO*9 + +! Allocate memory for the 2D-integrals. + +ip2D0 = ip +n2D0 = max((nabMax+1)*(ncdMax+1),(la+2)*(lb+2)*(ncdMax+1),(la+2)*(lb+2)*(lc+2)*(ld+2)) +ip = ip+n2D0*3*nT*nRys + +! Allocate memory for the 1st order derivatives of the 2D-integrals. + +ip2D1 = ip +n2D1 = max((nabMax+1)*(ncdMax+1),(la+2)*(lb+2)*(ncdMax+1),(la+1)*(lb+1)*(lc+1)*(ld+1)*3) +ip = ip+n2D1*3*nT*nRys + +! Allocate memory for the coefficients in the recurrence relation +! of the 2D-integrals. + +nTR = nT*nRys +ipPAQP = ip +ip = ip+nTR*3 +ipQCPQ = ip +ip = ip+nTR*3 +ipB10 = ip +lB10 = max(min(nabMax-1,1),0) +ip = ip+nTR*3*lB10 +labMax = min(nabMax,ncdMax) +ipB00 = ip +lB00 = max(min(labMax,1),0) +ip = ip+nTR*3*lB00 +ipB01 = ip +lB01 = max(min(ncdMax-1,1),0) +ip = ip+nTR*3*lB01 +! Allocate memory for the roots. +ipU2 = ip +ip = ip+nT*nRys +! Allocate memory for Zeta, ZInv, Eta, EInv +ipZeta = ip +ip = ip+nT +ipEta = ip +ip = ip+nT +ipZInv = ip +ip = ip+nT +ipEInv = ip +ip = ip+nT +! Allocate memory for P and Q +ipP = ip +ip = ip+3*nT +ipQ = ip +ip = ip+3*nT +! Allocate memory for the inverse. +ipDiv = ip +ip = ip+nT +! Allocate memory for the arguments. +ipTv = ip +ip = ip+nT +!define _CHECK_ +#ifdef _CHECK_ +if (ip-1 > nArray) then + call WarningMessage(2,'Rysg1: ip-1 =/= nArray (pos.1)') + write(u6,*) ' nArray=',nArray + write(u6,*) ' ip-1 =',ip-1 + write(u6,*) ' nRys =',nRys + write(u6,*) ' nZeta =',nZeta + write(u6,*) ' nEta =',nEta + call Abend() +end if +#endif + +! Expand Zeta, ZInv, Eta, EInv, P, and Q + +do iEta=1,nEta + iOff = (iEta-1)*nZeta + call dcopy_(nZeta,Zeta,1,Array(iOff+ipZeta),1) + call dcopy_(nZeta,ZInv,1,Array(iOff+ipZInv),1) + call dcopy_(nZeta,P(1,1),1,Array(iOff+ipP),1) + iOff = iOff+nZeta*nEta + call dcopy_(nZeta,P(1,2),1,Array(iOff+ipP),1) + iOff = iOff+nZeta*nEta + call dcopy_(nZeta,P(1,3),1,Array(iOff+ipP),1) +end do +do iZeta=1,nZeta + iOff = iZeta-1 + call dcopy_(nEta,Eta,1,Array(iOff+ipEta),nZeta) + call dcopy_(nEta,EInv,1,Array(iOff+ipEInv),nZeta) + call dcopy_(nEta,Q(1,1),1,Array(iOff+ipQ),nZeta) + iOff = iOff+nZeta*nEta + call dcopy_(nEta,Q(1,2),1,Array(iOff+ipQ),nZeta) + iOff = iOff+nZeta*nEta + call dcopy_(nEta,Q(1,3),1,Array(iOff+ipQ),nZeta) +end do + +! Compute the arguments for which we will compute the roots and the weights. + +call Tvalue(Array(ipZeta),Array(ipEta),Array(ipP),Array(ipQ),nT,Array(ipTv),Array(ipDiv),IsChi,ChiI2) + +! Compute roots and weights. Make sure that the weights ends up in +! the array where the z component of the 2D integrals will be. +! Call vRysRW if roots and weights are tabulated in various Taylor +! expansions. If not tabulated call RtsWgh. + +! Pointer to z-component of 2D-integrals where the weights will be +! put directly. This corresponds to xyz2D(1,1,3,0,0). +ipWgh = ip2D0+2*nT*nRys +if ((nRys > nMxRys) .or. NoTab) then +# ifdef _CHECK_ + if (ip-1 > nArray) then + call WarningMessage(2,'Rysg1: ip-1 =/= nArray (pos.2)') + write(u6,*) ' nArray=',nArray + write(u6,*) ' ip-1 =',ip-1 + call Abend() + end if +# endif + call RtsWgh(Array(ipTv),nT,Array(ipU2),Array(ipWgh),nRys) +else +# ifdef _CHECK_ + if (ip-1 > nArray) then + call WarningMessage(2,'Rysg1: ip-1 =/= nArray (pos.3)') + write(u6,*) ' nArray=',nArray + write(u6,*) ' ip-1 =',ip-1 + call Abend() + end if +# endif + call vRysRW(la+1,lb,lc,ld,Array(ipTv),Array(ipU2),Array(ipWgh),nT,nRys) +end if +! Drop ipTv +ip = ip-nT + +! Modify the roots. + +call ModU2(Array(ipU2),nT,nRys,Array(ipDiv)) +! Drop ipDiv +ip = ip-nT + +! Compute coefficients for the recurrence relations of the 2D-integrals + +call Cff2D(max(nabMax-1,0),max(ncdMax-1,0),nRys,Array(ipZeta),Array(ipZInv),Array(ipEta),Array(ipEInv),nT,Coori,CoorAC,Array(ipP), & + Array(ipQ),la+lab,lb,lc+lcd,ld,Array(ipU2),Array(ipPAQP),Array(ipQCPQ),Array(ipB10),Array(ipB00),labMax,Array(ipB01)) +! Drop ipU2 +ip = ip-nT*nRys +! Let go of Zeta, ZInv, Eta, and EInv +ip = ip-nT*4 +! Let go of P and Q +ip = ip-6*nT + +! Compute the intermediate 2D-integrals from the roots and weights. + +call vRys2Dm(Array(ip2D0),nT,nRys,nabMax,ncdMax,Array(ipPAQP),Array(ipQCPQ),Array(ipB10),Array(ipB00),Array(ipB01),la,lb,lc,ld, & + IfGrad) +! Drop ipB01 +ip = ip-nTR*3*lB01 +! Drop ipB00 +ip = ip-nTR*3*lB00 +! Drop ipB10 +ip = ip-nTR*3*lB10 +! Drop ipQCPQ +ip = ip-nTR*3 +! Drop ipPAQP +ip = ip-nTR*3 + +! Apply the transfer equation to the intermediate 2D-integrals. + +call HrrCtl(Array(ip2D0),n2D0,Array(ip2D1),n2D1,la,lb,lc,ld,nabmax,ncdmax,nTR,Coora(1,1),Coora(1,2),Coora(1,3),Coora(1,4),IfGrad) + +! Compute the gradients of the 2D-integrals. Copy some information +! which will be modified. This has to be done in order to facilitate +! partitioning. + +ipScr = ip +ip = ip+nT*nRys +ipTmp = ip +ip = ip+nT +JndGrd(:,:) = IndGrd +JfGrad(:,:) = IfGrad +call Rys2Dg(Array(ip2D0),nT,nRys,la,lb,lc,ld,Array(ip2D1),JfGrad,JndGrd,Coora,Alpha,Beta,Gmma,Delta,nZeta,nEta,Array(ipScr), & + Array(ipTmp),Indx,Exp_1,Exp_2,nZeta,nEta) +! Drop ipScr +ip = ip-nTR +! Drop ipTmp +ip = ip-nT + +! Assemble the gradients of the ERI's + +call Assg1(Temp,PAO,nT,nRys,la,lb,lc,ld,Array(ip2D0),Array(ip2D1),JfGrad,Indx,mVec) +! Drop ip2D1 +ip = ip-nTR*3*n2D1 +! Drop ip2D0 +ip = ip-nTR*3*n2D0 + +! Distribute the contributions to the molecular gradient + +call Distg1(Temp,Grad,nGrad,JfGrad,JndGrd,iuvwx,lOp) +! Drop ipAC +!ip = ip-nT*nPAO*9 +#ifdef _CHECK_ +if (ip /= 1) then + call WarningMessage(2,'Rysg1: ip=/=1') + call Abend() +end if +#endif + +return + +end subroutine Rysg1 diff -Nru openmolcas-22.02/src/rys_util/rysg2.f openmolcas-22.10/src/rys_util/rysg2.f --- openmolcas-22.02/src/rys_util/rysg2.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rysg2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,424 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991, Roland Lindh * -* 1990, IBM * -* 1995, Anders Bernhardsson * -************************************************************************ - SubRoutine Rysg2(iAnga,nRys,nT, - & Alpha,Beta,Gamma,Delta, - & Zeta,ZInv,nZeta,Eta,EInv,nEta, - & P,lP,Q,lQ,Coori,Coora,CoorAC, - & Array,nArray, - & Tvalue,ModU2,Cff2D, - & PAO,nPAO,Hess,nHess,IfGrd,IndGrd, - & IfHss,IndHss,nOp,iuvwx,IfG, - & mvec,Index_Out,lGrad,lHess,Tr) -************************************************************************ -* * -* Object: to compute the gradient of the two-electron integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* Modified to 1st order derivatives October '91 * -* Modified to 2nd order derviatives Mars '95 by * -* Anders Bernhardsson Theoretical Chemistry, * -* University of Lund * -************************************************************************ -* @parameter iAnga Angular momenta for each center -* @parameter nRys Order of rys polynomia -* @parameter nT Number of alpha-beta-gamma-delta multiplies -* @parameter Alpha Explonents on 1st center -* @parameter Beta Explonents on 2nd center -* @parameter Gamma Explonents on 3rd center -* @parameter Delta Explonents on 4ht center -* @parameter Zeta Alpha*Beta -* @parameter Zeta Zeta invers -* @parameter nZeta Alpha Beta multiplies -* @parameter Eta Gamma*Delta -* @parameter Eta Eta invers -* @parameter nEta gamma delta multiplies -* @parameter P -* @parameter lP Length of p -* @parameter Q -* @parameter lQ Length of Q -* @parameter Coori Coordinates of center just used to check AeqB CeqD etc -* @parameter Coora Coordinates of center used in hor. recursion -* @parameter CoorAC Coordinates of center <max(la,lb),max(lc,ld)> -* @parameter Array Scratch and output area for 1st derivatives -* @parameter nArray Size of scratch area -* @parameter PAO Density -* @parameter nPAO lenth of density -* @parameter Hess Output area for hessian (added) -* @parameter nHess Size of hessian -* @parameter ifgrad true for all 1st derivatives that are needed -* @parameter indgrad index in gradient on which integrals should be added -* @parameter ifhss true for all 2nd derivatives that are needed -* @parameter indhss index in hess on which contracted integrals should be added -* @parameter nop oerator number for the operator that generates center -* @parameter iuvwx number of stabilazors -* @parameter ifg true for all centers on which derivatives should be calculated -* @parameter index_out index where first derivatives are stored (out) -* @parameter lhess true if 2nd derivatives should be calculated -* @parameter lgrad true if 1st derivatives should be calculated -* @parameter tr true for all centers on which should be calculated via translation invarians - use vRys_RW - use Symmetry_Info, only: nIrrep, iOper - use Gateway_Info, only: ChiI2 - use Gateway_global, only: IsChi - Implicit Real*8 (A-H,O-Z) - External Tvalue, ModU2, Cff2D - External Exp_1, Exp_2 -#include "notab.fh" -#include "real.fh" - Real*8 Zeta(nZeta), ZInv(nZeta), P(lP,3), - & Eta(nEta), EInv(nEta), Q(lQ,3), - & Alpha(nZeta), Beta(nZeta), Gamma(nEta), Delta(nEta), - & CoorAC(3,2), Coora(3,4), Coori(3,4), Array(nArray), - & PAO(nT,nPAO), Hess(nHess) - Integer iAnga(4), IndGrd(3,4,0:7), Index1(3,4), - & nOp(4), iuvwx(4), JndGrd(3,4,0:7), lOp(4), - & IndHss(4,3,4,3,0:7),Index2(3,4,4), - & Index3(3,3),Index4(2,6,3),ng(3),nh(3),Index_Out(3,4) - Logical IfGrd(3,4), - & JfGrd(3,4),IfG(4),KfGrd(3,4), - & ifhss(4,3,4,3),lgrad,lhess,Tr(4) - nElem(i) = (i+1)*(i+2)/2 -* - - Call LCopy(12,[.false.],0,JfGrd,1) - Call LCopy(12,[.false.],0,KfGrd,1) - lOp(1) = iOper(nOp(1)) - lOp(2) = iOper(nOp(2)) - lOp(3) = iOper(nOp(3)) - lOp(4) = iOper(nOp(4)) - la = iAnga(1) - lb = iAnga(2) - lc = iAnga(3) - ld = iAnga(4) - lla = 0 - llb = 0 - llc = 0 - lld = 0 - Do 10 i = 1, 3 - If (IfHss(1,i,1,i)) lla=2 - If (IfGrd(i,1)) lla=max(lla,1) - If (IfHss(2,i,2,i)) llb=2 - If (IfGrd(i,2)) llb=max(llb,1) - If (IfHss(3,i,3,i)) llc=2 - If (IfGrd(i,3)) llc=max(llc,1) - If (IfHss(4,i,4,i)) lld=2 - If (IfGrd(i,4)) lld=max(lld,1) - 10 Continue - lab = Max(lla,llb) - lcd = Max(llc,lld) - nabMax = la + lb + lab - ncdMax = lc + ld + lcd -* -* Allocate memory for the integral gradients. -* -* - ip = 1 - - MemFinal=9*nt*nElem(la)*nElem(lb)*nElem(lc)*nElem(ld) - ip=ip+MemFinal -* -* Allocate memory for the 2D-integrals. -* - ip2D0 = ip - n2D0 = Max( (nabMax+1)*(ncdMax+1), - & (la+3)*(lb+3)*(ncdMax+1), - & (la+3)*(lb+3)*(lc+3)*(ld+3)) - ip = ip + n2D0*3*nT*nRys -* -* Allocate memory for the 2nd order derivatives of the 2D-integrals. -* - ip2D1 = ip - n2D1 = Max( (nabMax+1)*(ncdMax+1), - & (la+3)*(lb+3)*(ncdMax+1), - & (la+1)*(lb+1)*(lc+1)*(ld+1)*3) - ip = ip + n2D1*3*nT*nRys - -* -* Allocate memory for the coefficients in the recurrence relation -* of the 2D-integrals. -* - nTR=nT*nRys - ipPAQP = ip - ip = ip + nTR*3 - ipQCPQ = ip - ip = ip + nTR*3 - ipB10 = ip - lB10=Max(Min(nabMax-1,1),0) - ip = ip + nTR*3*lB10 - labMax = Min(nabMax,ncdMax) - ipB00 = ip - lB00=Max(Min(labMax,1),0) - ip = ip + nTR*3*lB00 - ipB01 = ip - lB01=Max(Min(ncdMax-1,1),0) - ip = ip + nTR*3*lB01 -* Allocate memory for the roots. - ipU2 = ip - ip = ip + nT*nRys -* Allocate memory for Zeta, ZInv, Eta, EInv - ipZeta = ip - ip = ip + nT - ipEta = ip - ip = ip + nT - ipZInv = ip - ip = ip + nT - ipEInv = ip - ip = ip + nT -* Allocate memory for P and Q - ipP = ip - ip = ip + 3*nT - ipQ = ip - ip = ip + 3*nT -* Allocate memory for the inverse. - ipDiv = ip - ip = ip + nT -* Allocate memory for the arguments. - ipTv = ip - ip = ip + nT - If (ip-1.gt.nArray) Then - Call WarningMessage(2,'Rysg2: ip-1.gt.nArray (pos. 1)') - Write (6,*) 'ip,nArray=',ip,nArray - Call Abend() - End If -* -* Expand Zeta, ZInv, Eta ,EInv, P, and Q -* - Do iEta = 1, nEta - iOff = (iEta-1)*nZeta - call dcopy_(nZeta,Zeta, 1,Array(iOff+ipZeta ),1) - call dcopy_(nZeta,ZInv, 1,Array(iOff+ipZInv ),1) - call dcopy_(nZeta,P(1,1),1,Array(iOff+ipP ),1) - iOff = iOff + nZeta*nEta - call dcopy_(nZeta,P(1,2),1,Array(iOff+ipP ),1) - iOff = iOff + nZeta*nEta - call dcopy_(nZeta,P(1,3),1,Array(iOff+ipP ),1) - End Do - Do iZeta = 1, nZeta - iOff = iZeta-1 - call dcopy_(nEta, Eta, 1,Array(iOff+ipEta) ,nZeta) - call dcopy_(nEta,EInv, 1,Array(iOff+ipEInv),nZeta) - call dcopy_(nEta,Q(1,1),1,Array(iOff+ipQ ),nZeta) - iOff = iOff + nZeta*nEta - call dcopy_(nEta,Q(1,2),1,Array(iOff+ipQ ),nZeta) - iOff = iOff + nZeta*nEta - call dcopy_(nEta,Q(1,3),1,Array(iOff+ipQ ),nZeta) - End Do -* -* Compute tha arguments for which we will compute the roots and -* the weights. -* - Call Tvalue(Array(ipZeta),Array(ipEta),Array(ipP),Array(ipQ),nT, - & Array(ipTv),Array(ipDiv),IsChi,ChiI2) -* -* -* Compute roots and weights. Make sure that the weights ends up in -* the array where the z component of the 2D integrals will be. -* Call vRysRW if roots and weights are tabulated in various Taylor -* expansions. If not tabulated call RtsWgh. -* -* Pointer to z-component of 2D-integrals where the weights will be -* put directly. This corresponds to xyz2D(1,1,3,0,0). - ipWgh = ip2D0 + 2*nT*nRys - If (nRys.gt.nMxRys .or. NoTab) Then - If (ip-1.gt.nArray) Then - Call WarningMessage(2,'Rysg2: ip-1.gt.nArray (pos. 2)') - Write (6,*) 'ip,nArray=',ip,nArray - Call Abend() - End If -* - Call RtsWgh(Array(ipTv),nT,Array(ipU2),Array(ipWgh),nRys) - Else - If (ip-1.gt.nArray) Then - Call WarningMessage(2,'Rysg2: ip-1.gt.nArray (pos. 3)') - Write (6,*) 'ip,nArray=',ip,nArray - Call Abend() - End If - -* Make sure rys11/her11 is called (la+1) - Call vRysRW(la+1,lb,lc,ld,Array(ipTv),Array(ipU2),Array(ipWgh), - & nT,nRys) - End If -*-----Drop ipTv - ip = ip - nT -* -* Modify the roots. -* - Call ModU2(Array(ipU2),nT,nRys,Array(ipDiv)) - -*-----Drop ipDiv - ip = ip - nT -* -* Compute coefficients for the recurrence relations of the -* 2D-integrals -* - Call Cff2D(Max(nabMax-1,0),Max(ncdMax-1,0),nRys, - & Array(ipZeta),Array(ipZInv),Array(ipEta),Array(ipEInv), - & nT,Coori,CoorAC,Array(ipP),Array(ipQ), - & la+lab,lb,lc+lcd,ld, - & Array(ipU2),Array(ipPAQP),Array(ipQCPQ), - & Array(ipB10),Array(ipB00),labMax,Array(ipB01)) -*-----Drop ipU2 - ip = ip - nT*nRys -* Let go of Zeta, ZInv, Eta, and EInv - ip = ip - nT*4 -* Let go of P and Q - ip = ip - 6*nT -* -* ------------------------------- -* Compute the intermediate 2D-integrals from the roots and weights. -* - Call Rs2Dmm(Array(ip2D0),nT,nRys,nabMax, - & ncdMax,Array(ipPAQP),Array(ipQCPQ), - & Array(ipB10),Max(nabMax-1,0), - & Array(ipB00),labMax, - & Array(ipB01),Max(ncdMax-1,0), - & la,lb,lc,ld,IfHss,IfGrd) -* -*-----Drop ipB01 - ip = ip - nTR*3*lB01 -*-----Drop ipB00 - ip = ip - nTR*3*lB00 -*-----Drop ipB10 - ip = ip - nTR*3*lB10 -*-----Drop ipQCPQ - ip = ip - nTR*3 -*-----Drop ipPAQP - ip = ip - nTR*3 -* -*-----Apply the transfer equation to the intermediate 2D-integrals. -* - Call HrrCtl_mck(Array(ip2D0),n2D0,Array(ip2D1),n2D1, - & la,lb,lc,ld,nabmax,ncdmax, - & nTR,Coora(1,1),Coora(1,2),Coora(1,3),Coora(1,4), - & IfHss,IfGrd,nt,nrys) -* -* Compute the gradients of the 2D-integrals. Copy some information -* which will be modified. This has to be done in order to facilitate -* partioning. -* - ip2D2= ip - n2D2 = (la+1)*(lb+1)*(lc+1)*(ld+1)*18 - ip = ip + n2D2*nT*nRys - ipScr = ip - ip = ip + nT*nRys - ipTmp = ip - ip = ip + nrys*nT - ipScr2=ip - ip=ip+nT*nRys - If (ip-1.gt.nArray) Then - Call WarningMessage(2,'Rysg2: ip-1.gt.nArray (pos. 4)') - Write (6,*) 'ip,nArray=',ip,nArray - Call Abend() - End If - Call ICopy(12*nirrep,IndGrd,1,JndGrd,1) - Do 8877 i = 1, 3 - Do 7788 j = 1, 4 - JfGrd(i,j) = IfGrd(i,j) - 7788 Continue - 8877 Continue - Do iCent=1,4 - Do jCar=1,3 - Do kCent=1,i - If (iCent.eq.kCent) then - iStop=3 - Else - iStop=jCar-1 - End If - Do lCar=1,istop - if (jCar.ne.lCar) Then - if (ifhss(iCent,jCar,kCent,lCar)) Then - kfgrd(jCar,iCent)=.true. - kfgrd(lCar,kCent)=.true. - End If - End If - End Do - End Do - End Do - End Do - Do jCent=1,4 - Do iCar=1,3 - if (kfgrd(iCar,jCent).or.Ifgrd(iCar,jCent)) Then - kfgrd(iCar,jCent)=.true. - End If - End Do - End Do -* - Call Rs2Dgh(Array(ip2D0),nT,nRys,la,lb,lc,ld, - & Array(ip2D1),Array(ip2D2), - & IfHss,IndHss,KfGrd,JndGrd,IfG, - & Coora,Alpha,Beta,Gamma,Delta,nZeta,nEta, - & Array(ipScr),Array(ipScr2),Array(ipTmp), - & Index1,Index2,Index3,Index4,ng,nh, - & Exp_1,Exp_2,nZeta,nEta,nIrrep,Tr) -*-----Drop ipScr - ip = ip - nTR -*-----Drop ipScr2 - ip = ip - nTR -*-----Drop ipTmp - ip = ip - nTR -* -* G2 -* - ipg2 = ip - ip = ip + 78 - If (ip-1.gt.nArray) Then - Call WarningMessage(2,'Rysg2: ip-1.gt.nArray (pos. 5)') - Write (6,*) 'ip,nArray=',ip,nArray - Call Abend() - End If -* - If (lGrad) Then - Do iCe=1,4 - Do iCa=1,3 - kfGrd(iCa,iCe)=(kfgrd(iCa,iCe).and.ifgrd(iCa,iCe)) - End Do - End Do - Call Assg1_mck(Array,nT,nRys,la,lb,lc,ld,Array(ip2D0), - & Array(ip2D1),kfGrd,Index1,mVec_,Index_out) - mVec = mVec_ - - End If -* - If (lHess) Then - Call Assg2(Array(ipg2),nT,nRys,la,lb,lc,ld,Array(ip2D0), - & Array(ip2D1),Array(ip2D2),IfHss, - & Index3,Index4,ng,nh,PAO) -* -* Distribute the contributions to the molecular static hessian -* - Call Distg2(Array(ipg2),Hess,nHess,JndGrd, - & IfHss,IndHss,iuvwx,lOp,nop,Tr,IfG) - End If -* -*-----Drop ipg2 - ip = ip - 78 -*-----Drop ip2D1 - ip = ip - nTR*3*n2D1 -*-----Drop ip2D0 - ip = ip - nTR*3*n2D0 -*-----Drop ip2D2 - ip=ip-n2D2*nT*nRys -* - If (ip.ne.1+MemFinal) Then - Call WarningMessage(2,'Rysg2: ip.ne.1+MemFinal (pos. 5)') - Write (6,*) 'ip,MemFinal=',ip,MemFinal - Call Abend() - End If - Call lCopy(12,kfgrd,1,ifgrd,1) -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/rysg2.F90 openmolcas-22.10/src/rys_util/rysg2.F90 --- openmolcas-22.02/src/rys_util/rysg2.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rysg2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,373 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991, Roland Lindh * +! 1990, IBM * +! 1995, Anders Bernhardsson * +!*********************************************************************** + +subroutine Rysg2(iAnga,nRys,nT,Alpha,Beta,Gmma,Delta,Zeta,ZInv,nZeta,Eta,EInv,nEta,P,lP,Q,lQ,Coori,Coora,CoorAC,Array,nArray, & + Tvalue,ModU2,Cff2D,PAO,nPAO,Hess,nHess,IfGrd,IndGrd,IfHss,IndHss,nOp,iuvwx,IfG,mVec,Index_Out,lGrad,lHess,Tr) +!*********************************************************************** +! * +! Object: to compute the gradient of the two-electron integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! Modified to 1st order derivatives October '91 * +! Modified to 2nd order derviatives Mars '95 by * +! Anders Bernhardsson Theoretical Chemistry, * +! University of Lund * +!*********************************************************************** +! @parameter iAnga Angular momenta for each center +! @parameter nRys Order of Rys polynomia +! @parameter nT Number of alpha-beta-gamma-delta multiplies +! @parameter Alpha Exponents on 1st center +! @parameter Beta Exponents on 2nd center +! @parameter Gmma Exponents on 3rd center +! @parameter Delta Exponents on 4th center +! @parameter Zeta Alpha*Beta +! @parameter Zeta Zeta inverse +! @parameter nZeta Alpha Beta multiplies +! @parameter Eta Gmma*Delta +! @parameter Eta Eta inverse +! @parameter nEta Gmma Delta multiplies +! @parameter P +! @parameter lP Length of P +! @parameter Q +! @parameter lQ Length of Q +! @parameter Coori Coordinates of center just used to check AeqB CeqD etc. +! @parameter Coora Coordinates of center used in hor. recursion +! @parameter CoorAC Coordinates of center <max(la,lb),max(lc,ld)> +! @parameter Array Scratch and output area for 1st derivatives +! @parameter nArray Size of scratch area +! @parameter PAO Density +! @parameter nPAO Length of density +! @parameter Hess Output area for Hessian (added) +! @parameter nHess Size of Hessian +! @parameter IfGrad True for all 1st derivatives that are needed +! @parameter IndGrad Index in gradient on which integrals should be added +! @parameter IfHss True for all 2nd derivatives that are needed +! @parameter IndHss Index in Hess on which contracted integrals should be added +! @parameter nOp Operator number for the operator that generates center +! @parameter iuvwx Number of stabilizers +! @parameter IfG True for all centers on which derivatives should be calculated +! @parameter Index_Out Index where first derivatives are stored (out) +! @parameter lHess True if 2nd derivatives should be calculated +! @parameter lGrad True if 1st derivatives should be calculated +! @parameter Tr True for all centers on which should be calculated via translation invariance + +use vRys_RW, only: nMxRys +use Symmetry_Info, only: nIrrep, iOper +use Gateway_Info, only: ChiI2 +use Gateway_global, only: IsChi, NoTab +use Index_Functions, only: nTri_Elem1 +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: iAnga(4), nRys, nT, nZeta, nEta, lP, lQ, nArray, nPAO, nHess, IndGrd(3,4,0:7), nOp(4), iuvwx(4) +real(kind=wp), intent(in) :: Alpha(nZeta), Beta(nZeta), Gmma(nEta), Delta(nEta), Zeta(nZeta), ZInv(nZeta), Eta(nEta), EInv(nEta), & + P(lP,3), Q(lQ,3), Coori(3,4), Coora(3,4), CoorAC(3,2), PAO(nT,nPAO) +real(kind=wp), intent(inout) :: Array(nArray), Hess(nHess) +external :: Tvalue, ModU2, Cff2D +logical(kind=iwp), intent(inout) :: IfGrd(3,4), IfHss(4,3,4,3), IfG(4), Tr(4) +integer(kind=iwp), intent(inout) :: IndHss(4,3,4,3,0:7) +integer(kind=iwp), intent(out) :: mVec, Index_Out(3,4) +logical(kind=iwp), intent(in) :: lGrad, lHess +integer(kind=iwp) :: i, iCent, iEta, Index1(3,4), Index2(3,4,4), Index3(3,3), Index4(2,6,3), iOff, ip, ip2D0, ip2D1, ip2D2, ipB00, & + ipB01, ipB10, ipDiv, ipEInv, ipEta, ipg2, ipP, ipPAQP, ipQ, ipQCPQ, ipScr, ipScr2, ipTmp, ipTv, ipU2, ipWgh, & + ipZeta, ipZInv, iStop, iZeta, jCar, JndGrd(3,4,0:7), kCent, la, lab, labMax, lb, lB00, lB01, lB10, lc, lCar, & + lcd, ld, lla, llb, llc, lld, lOp(4), MemFinal, n2D0, n2D1, n2D2, nabMax, ncdMax, ng(3), nh(3), nTR +logical(kind=iwp) :: KfGrd(3,4) +external :: Exp_1, Exp_2 + +KfGrd(:,:) = .false. +lOp(1) = iOper(nOp(1)) +lOp(2) = iOper(nOp(2)) +lOp(3) = iOper(nOp(3)) +lOp(4) = iOper(nOp(4)) +la = iAnga(1) +lb = iAnga(2) +lc = iAnga(3) +ld = iAnga(4) +lla = 0 +llb = 0 +llc = 0 +lld = 0 +if (any(IfGrd(:,1))) lla = 1 +if (any(IfGrd(:,2))) llb = 1 +if (any(IfGrd(:,3))) llc = 1 +if (any(IfGrd(:,4))) lld = 1 +do i=1,3 + if (IfHss(1,i,1,i)) lla = 2 + if (IfHss(2,i,2,i)) llb = 2 + if (IfHss(3,i,3,i)) llc = 2 + if (IfHss(4,i,4,i)) lld = 2 +end do +lab = max(lla,llb) +lcd = max(llc,lld) +nabMax = la+lb+lab +ncdMax = lc+ld+lcd + +! Allocate memory for the integral gradients. + +ip = 1 + +MemFinal = 9*nT*nTri_Elem1(la)*nTri_Elem1(lb)*nTri_Elem1(lc)*nTri_Elem1(ld) +ip = ip+MemFinal + +! Allocate memory for the 2D-integrals. + +ip2D0 = ip +n2D0 = max((nabMax+1)*(ncdMax+1),(la+3)*(lb+3)*(ncdMax+1),(la+3)*(lb+3)*(lc+3)*(ld+3)) +ip = ip+n2D0*3*nT*nRys + +! Allocate memory for the 2nd order derivatives of the 2D-integrals. + +ip2D1 = ip +n2D1 = max((nabMax+1)*(ncdMax+1),(la+3)*(lb+3)*(ncdMax+1),(la+1)*(lb+1)*(lc+1)*(ld+1)*3) +ip = ip+n2D1*3*nT*nRys + +! Allocate memory for the coefficients in the recurrence relation +! of the 2D-integrals. + +nTR = nT*nRys +ipPAQP = ip +ip = ip+nTR*3 +ipQCPQ = ip +ip = ip+nTR*3 +ipB10 = ip +lB10 = max(min(nabMax-1,1),0) +ip = ip+nTR*3*lB10 +labMax = min(nabMax,ncdMax) +ipB00 = ip +lB00 = max(min(labMax,1),0) +ip = ip+nTR*3*lB00 +ipB01 = ip +lB01 = max(min(ncdMax-1,1),0) +ip = ip+nTR*3*lB01 +! Allocate memory for the roots. +ipU2 = ip +ip = ip+nT*nRys +! Allocate memory for Zeta, ZInv, Eta, EInv +ipZeta = ip +ip = ip+nT +ipEta = ip +ip = ip+nT +ipZInv = ip +ip = ip+nT +ipEInv = ip +ip = ip+nT +! Allocate memory for P and Q +ipP = ip +ip = ip+3*nT +ipQ = ip +ip = ip+3*nT +! Allocate memory for the inverse. +ipDiv = ip +ip = ip+nT +! Allocate memory for the arguments. +ipTv = ip +ip = ip+nT +if (ip-1 > nArray) then + call WarningMessage(2,'Rysg2: ip-1 > nArray (pos. 1)') + write(u6,*) 'ip,nArray=',ip,nArray + call Abend() +end if + +! Expand Zeta, ZInv, Eta, EInv, P, and Q + +do iEta=1,nEta + iOff = (iEta-1)*nZeta + call dcopy_(nZeta,Zeta,1,Array(iOff+ipZeta),1) + call dcopy_(nZeta,ZInv,1,Array(iOff+ipZInv),1) + call dcopy_(nZeta,P(1,1),1,Array(iOff+ipP),1) + iOff = iOff+nZeta*nEta + call dcopy_(nZeta,P(1,2),1,Array(iOff+ipP),1) + iOff = iOff+nZeta*nEta + call dcopy_(nZeta,P(1,3),1,Array(iOff+ipP),1) +end do +do iZeta=1,nZeta + iOff = iZeta-1 + call dcopy_(nEta,Eta,1,Array(iOff+ipEta),nZeta) + call dcopy_(nEta,EInv,1,Array(iOff+ipEInv),nZeta) + call dcopy_(nEta,Q(1,1),1,Array(iOff+ipQ),nZeta) + iOff = iOff+nZeta*nEta + call dcopy_(nEta,Q(1,2),1,Array(iOff+ipQ),nZeta) + iOff = iOff+nZeta*nEta + call dcopy_(nEta,Q(1,3),1,Array(iOff+ipQ),nZeta) +end do + +! Compute the arguments for which we will compute the roots and the weights. + +call Tvalue(Array(ipZeta),Array(ipEta),Array(ipP),Array(ipQ),nT,Array(ipTv),Array(ipDiv),IsChi,ChiI2) + +! Compute roots and weights. Make sure that the weights ends up in +! the array where the z component of the 2D integrals will be. +! Call vRysRW if roots and weights are tabulated in various Taylor +! expansions. If not tabulated call RtsWgh. + +! Pointer to z-component of 2D-integrals where the weights will be +! put directly. This corresponds to xyz2D(1,1,3,0,0). +ipWgh = ip2D0+2*nT*nRys +if ((nRys > nMxRys) .or. NoTab) then + if (ip-1 > nArray) then + call WarningMessage(2,'Rysg2: ip-1 > nArray (pos. 2)') + write(u6,*) 'ip,nArray=',ip,nArray + call Abend() + end if + + call RtsWgh(Array(ipTv),nT,Array(ipU2),Array(ipWgh),nRys) +else + if (ip-1 > nArray) then + call WarningMessage(2,'Rysg2: ip-1 > nArray (pos. 3)') + write(u6,*) 'ip,nArray=',ip,nArray + call Abend() + end if + + ! Make sure rys11/her11 is called (la+1) + call vRysRW(la+1,lb,lc,ld,Array(ipTv),Array(ipU2),Array(ipWgh),nT,nRys) +end if +! Drop ipTv +ip = ip-nT + +! Modify the roots. + +call ModU2(Array(ipU2),nT,nRys,Array(ipDiv)) + +! Drop ipDiv +ip = ip-nT + +! Compute coefficients for the recurrence relations of the 2D-integrals + +call Cff2D(max(nabMax-1,0),max(ncdMax-1,0),nRys,Array(ipZeta),Array(ipZInv),Array(ipEta),Array(ipEInv),nT,Coori,CoorAC,Array(ipP), & + Array(ipQ),la+lab,lb,lc+lcd,ld,Array(ipU2),Array(ipPAQP),Array(ipQCPQ),Array(ipB10),Array(ipB00),labMax,Array(ipB01)) +! Drop ipU2 +ip = ip-nT*nRys +! Let go of Zeta, ZInv, Eta, and EInv +ip = ip-nT*4 +! Let go of P and Q +ip = ip-6*nT + +! ------------------------------- +! Compute the intermediate 2D-integrals from the roots and weights. + +call Rs2Dmm(Array(ip2D0),nT,nRys,nabMax,ncdMax,Array(ipPAQP),Array(ipQCPQ),Array(ipB10),Array(ipB00),Array(ipB01),la,lb,lc,ld, & + IfHss,IfGrd) + +! Drop ipB01 +ip = ip-nTR*3*lB01 +! Drop ipB00 +ip = ip-nTR*3*lB00 +! Drop ipB10 +ip = ip-nTR*3*lB10 +! Drop ipQCPQ +ip = ip-nTR*3 +! Drop ipPAQP +ip = ip-nTR*3 + +! Apply the transfer equation to the intermediate 2D-integrals. + +call HrrCtl_mck(Array(ip2D0),n2D0,Array(ip2D1),n2D1,la,lb,lc,ld,nabmax,ncdmax,nTR,Coora(1,1),Coora(1,2),Coora(1,3),Coora(1,4), & + IfHss,IfGrd) + +! Compute the gradients of the 2D-integrals. Copy some information +! which will be modified. This has to be done in order to facilitate +! partitioning. + +ip2D2 = ip +n2D2 = (la+1)*(lb+1)*(lc+1)*(ld+1)*18 +ip = ip+n2D2*nT*nRys +ipScr = ip +ip = ip+nT*nRys +ipTmp = ip +ip = ip+nT*nRys +ipScr2 = ip +ip = ip+nT*nRys +if (ip-1 > nArray) then + call WarningMessage(2,'Rysg2: ip-1 > nArray (pos. 4)') + write(u6,*) 'ip,nArray=',ip,nArray + call Abend() +end if +JndGrd(:,:,:) = IndGrd(:,:,:) +do iCent=1,4 + do jCar=1,3 + do kCent=1,i + if (iCent == kCent) then + iStop = 3 + else + iStop = jCar-1 + end if + do lCar=1,istop + if (jCar /= lCar) then + if (IfHss(iCent,jCar,kCent,lCar)) then + KfGrd(jCar,iCent) = .true. + KfGrd(lCar,kCent) = .true. + end if + end if + end do + end do + end do +end do +KfGrd(:,:) = KfGrd .or. IfGrd + +call Rs2Dgh(Array(ip2D0),nT,nRys,la,lb,lc,ld,Array(ip2D1),Array(ip2D2),IfHss,IndHss,KfGrd,JndGrd,IfG,Coora,Alpha,Beta,Gmma,Delta, & + nZeta,nEta,Array(ipScr),Array(ipScr2),Array(ipTmp),Index1,Index2,Index3,Index4,ng,nh,Exp_1,Exp_2,nZeta,nEta,nIrrep,Tr) +! Drop ipScr +ip = ip-nTR +! Drop ipScr2 +ip = ip-nTR +! Drop ipTmp +ip = ip-nTR + +! G2 + +ipg2 = ip +ip = ip+78 +if (ip-1 > nArray) then + call WarningMessage(2,'Rysg2: ip-1 > nArray (pos. 5)') + write(u6,*) 'ip,nArray=',ip,nArray + call Abend() +end if + +if (lGrad) then + KfGrd(:,:) = KfGrd .and. IfGrd + call Assg1_mck(Array,nT,nRys,la,lb,lc,ld,Array(ip2D0),Array(ip2D1),KfGrd,Index1,mVec,Index_out) + +end if + +if (lHess) then + call Assg2(Array(ipg2),nT,nRys,la,lb,lc,ld,Array(ip2D0),Array(ip2D1),Array(ip2D2),IfHss,Index3,Index4,ng,nh,PAO) + + ! Distribute the contributions to the molecular static hessian + + call Distg2(Array(ipg2),Hess,nHess,JndGrd,IfHss,IndHss,iuvwx,lOp,nop,Tr,IfG) +end if + +! Drop ipg2 +ip = ip-78 +! Drop ip2D1 +ip = ip-nTR*3*n2D1 +! Drop ip2D0 +ip = ip-nTR*3*n2D0 +! Drop ip2D2 +ip = ip-n2D2*nT*nRys + +if (ip /= 1+MemFinal) then + call WarningMessage(2,'Rysg2: ip /= 1+MemFinal (pos. 5)') + write(u6,*) 'ip,MemFinal=',ip,MemFinal + call Abend() +end if +IfGrd(:,:) = KfGrd + +return + +end subroutine Rysg2 diff -Nru openmolcas-22.02/src/rys_util/rysrtswgh.f openmolcas-22.10/src/rys_util/rysrtswgh.f --- openmolcas-22.02/src/rys_util/rysrtswgh.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rysrtswgh.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,441 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1994, Walter Gautschi * -* 1994, Gene H. Golub * -* 2017, Ignacio Fdez. Galvan * -************************************************************************ -* -* Compute Rys roots and weights from scratch: -* - For high t values use the asymptotic scaled Hermite quadrature -* - For lower t, get first alpha and beta from the auxiliary Legendre -* quadrature, then compute roots and weights -* - Subroutine RysRtsWgh(TValues,nT,Roots,Weights,Order) - Use Leg_RW - Use vRys_RW - Implicit None - Integer, Intent(In) :: nT, Order - Real*8, Intent(In) :: TValues(nT) - Real*8, Intent(Out) :: Roots(Order,nT), Weights(Order, nT) -#include "stdalloc.fh" -#include "real.fh" -#include "FMM.fh" - Integer :: i, j, iquad, Err - Real*8, Dimension(:), Allocatable :: a, b - Real*8 :: Alpha(Order), Beta(Order) - Real*8, Parameter :: eps=1.0d-16 - Real*8, External :: TAsymp - Integer, External :: WhichQuad -* - Do i = 1, nT - If (TValues(i).gt.TAsymp(Order) .or. asymptotic_Rys) Then - Do j = 1, Order - Roots(j,i)=HerR2(iHerR2(Order)+j-1)/TValues(i) - Weights(j,i)=HerW2(iHerW2(Order)+j-1)/Sqrt(TValues(i)) - End Do - Else - iquad = WhichQuad(Order) - Call mma_allocate(a,naux(iquad)) - Call mma_allocate(b,naux(iquad)) - Do j = 1, naux(iquad) - a(j)=Leg_r(j,iquad) - b(j)=Leg_w(j,iquad)*Exp(-TValues(i)*a(j)) - End Do - Call Lanczos(Order,naux(iquad),a,b,Alpha,Beta,Err) - If (Err.ne.0) Then - write(6,*) Err - Call WarningMessage(2,'Error in Lanczos') - Call AbEnd() - End If - Call GaussQuad(Order,Alpha,Beta,eps, - & Roots(1,i),Weights(1,i),Err) - If (Err.ne.0) Then - write(6,*) Err - Call WarningMessage(2,'Error in GaussQuad 2') - Call AbEnd() - End If - Call mma_deallocate(a) - Call mma_deallocate(b) - End If - End Do -* - End Subroutine RysRtsWgh -* -* This function returns the asymptotic limit for the t parameter, -* for values larger than this the scaled Hermite quadrature is -* accurate enough. These values are quite conservative, with -* estimated errors below 1e-16. -* - Function TAsymp(Order) - Implicit None - Real*8 :: TAsymp - Integer, Intent(In) :: Order - Select Case(Order) - Case (1) - TAsymp=39.0D0 - Case (2) - TAsymp=47.0D0 - Case (3) - TAsymp=54.0D0 - Case (4) - TAsymp=60.0D0 - Case (5) - TAsymp=66.0D0 - Case (6) - TAsymp=72.0D0 - Case (7) - TAsymp=78.0D0 - Case (8) - TAsymp=83.0D0 - Case (9) - TAsymp=89.0D0 - Case (10) - TAsymp=94.0D0 - Case (11) - TAsymp=99.0D0 - Case (12) - TAsymp=104.0D0 - Case (13) - TAsymp=109.0D0 - Case (14) - TAsymp=115.0D0 - Case (15) - TAsymp=120.0D0 - Case (16) - TAsymp=125.0D0 - Case (17) - TAsymp=130.0D0 - Case (18) - TAsymp=134.0D0 - Case (19) - TAsymp=139.0D0 - Case (20) - TAsymp=144.0D0 - Case Default -* Rough fit - TAsymp=50.0D0+5*Order - End Select - End Function TAsymp -* -* This function returns the number of points to use in the auxiliary -* Legendre quadrature. -* - Function WhichQuad(Order) - Use Leg_RW - Implicit None - Integer :: WhichQuad - Integer, Intent(In) :: Order - Select Case(Order) - Case (1) - WhichQuad = 1 !24 - Case (2) - WhichQuad = 1 !27 - Case (3) - WhichQuad = 1 !30 - Case (4) - WhichQuad = 2 !34 - Case (5) - WhichQuad = 3 !37 - Case (6) - WhichQuad = 3 !39 - Case (7) - WhichQuad = 4 !42 - Case (8) - WhichQuad = 4 !45 - Case (9) - WhichQuad = 5 !46 - Case (10) - WhichQuad = 5 !50 - Case (11) - WhichQuad = 6 !51 - Case (12) - WhichQuad = 6 !54 - Case (13) - WhichQuad = 7 !56 - Case (14) - WhichQuad = 7 !59 - Case (15) - WhichQuad = 8 !61 - Case (16) - WhichQuad = 8 !63 - Case (17) - WhichQuad = 9 !66 - Case (18) - WhichQuad = 9 !68 - Case (19) - WhichQuad = 9 !70 - Case (20) - WhichQuad = 10 !73 - Case Default -* Maximum naux - WhichQuad = 11 !300 - End Select - End Function WhichQuad -* -************************************************************************ -* Routines GaussQuad and Lanczos adapted from: -* -* Algorithm 726: ORTHPOL -- A package of Routines for Generating -* Orthogonal Polynomials and Gauss-Type Quadrature Rules -* Walter Gautschi. ACM Trans. Math. Softw. 20 (1994) 21-62 -* doi:10.1145/174603.174605 -************************************************************************ -* - Subroutine GaussQuad(n,alpha,beta,eps,roots,weights,ierr) -c Given n and a measure dlambda, this routine generates the n-point -c Gaussian quadrature formula -c -c integral over supp(dlambda) of f(x)dlambda(x) -c -c = sum from k=1 to k=n of w(k)f(x(k)) + R(n;f). -c -c The nodes are returned as roots(k)=x(k) and the weights as -c weights(k)=w(k), k=1,2,...,n. The user has to supply the recursion -c coefficients alpha(k), beta(k), k=0,1,2,...,n-1, for the measure -c dlambda. The routine computes the nodes as eigenvalues, and the -c weights in term of the first component of the respective normalized -c eigenvectors of the n-th order Jacobi matrix associated with dlambda. -c It uses a translation and adaptation of the algol procedure imtql2, -c Numer. Math. 12, 1968, 377-383, by Martin and Wilkinson, as modified -c by Dubrulle, Numer. Math. 15, 1970, 450. See also Handbook for -c Autom. Comput., vol. 2 - Linear Algebra, pp.241-248, and the eispack -c routine imtql2. -c -c Input: n - - the number of points in the Gaussian quadrature -c formula; type integer -c alpha,beta - arrays of dimension n to be filled -c with the values of alpha(k-1), beta(k-1), k=1,2, -c ...,n -c eps - the relative accuracy desired in the nodes -c and weights -c -c Output: roots - array of dimension n containing the Gaussian -c nodes (in increasing order) roots(k)=x(k), k=1,2, -c ...,n -c weights - array of dimension n containing the -c Gaussian weights weights(k)=w(k), k=1,2,...,n -c ierr - an error flag equal to 0 on normal return, -c equal to i if the QR algorithm does not -c converge within 30 iterations on evaluating the -c i-th eigenvalue, equal to -1 if n is not in -c range, and equal to -2 if one of the beta's is -c negative. - Implicit None - Integer :: n,ierr,i,ii,j,k,l,m,mml - Integer, Parameter :: maxcyc=30 - Real*8 :: alpha(n),beta(n),roots(n),weights(n),eps,e(n), - & b,c,f,g,p,s,r -#include "real.fh" - ierr=0 - if (n.lt.1) then - ierr=-1 - return - end if -c -c Initialization -c - do k=1,n - roots(k)=alpha(k) - if (beta(k).lt.zero) then - ierr=-2 - return - end if - weights(k)=zero - if (k.gt.1) e(k-1)=sqrt(beta(k)) - end do - if (n.eq.1) then - weights(1)=beta(1) - return - else - weights(1)=one - e(n) = zero - endif -c -c Loop over roots -c - do l=1,n - do j=1,maxcyc -c -c Look for a small subdiagonal element. -c - do m=l,n - if (m.eq.n) exit - if (abs(e(m)).le.eps*(abs(roots(m))+abs(roots(m+1)))) exit - end do - p=roots(l) - if (m.eq.l) exit -c -c Form shift. -c - g=(roots(l+1)-p)/(two*e(l)) - r=sqrt(g*g+one) - g=roots(m)-p+e(l)/(g+sign(r,g)) - s=one - c=one - p=zero - mml=m-l -c -c For i=m-1 step -1 until l do ... -c - do ii=1,mml - i=m-ii - f=s*e(i) - b=c*e(i) - if (abs(f).lt.abs(g)) then - s=f/g - r=sqrt(s*s+one) - e(i+1)=g*r - c=one/r - s=s*c - else - c=g/f - r=sqrt(c*c+one) - e(i+1)=f*r - s=one/r - c=c*s - endif - g=roots(i+1)-p - r=(roots(i)-g)*s+two*c*b - p=s*r - roots(i+1)=g+p - g=c*r-b -c -c Form first component of vector. -c - f=weights(i+1) - weights(i+1)=s*weights(i)+c*f - weights(i)=c*weights(i)-s*f - end do - roots(l)=roots(l)-p - e(l)=g - e(m)=zero - end do -c -c Set error - no convergence to an eigenvalue after maxcyc iterations. -c - if (j.gt.maxcyc) then - ierr=l - return - end if - end do -c -c Order eigenvalues and eigenvectors. -c - do ii=2,n - i=ii-1 - k=i - p=roots(i) - do j=ii,n - if (roots(j).lt.p) then - k=j - p=roots(j) - end if - end do - if (k.ne.i) then - roots(k)=roots(i) - roots(i)=p - p=weights(i) - weights(i)=weights(k) - weights(k)=p - end if - end do - do k=1,n - weights(k)=beta(1)*weights(k)*weights(k) - end do - return - end -* - Subroutine Lanczos(n,ncap,x,w,alpha,beta,ierr) -c This routine carries out the same task as the routine sti, but -c uses the more stable Lanczos method. The meaning of the input -c and output parameters is the same as in the routine sti. (This -c routine is adapted from the routine RKPW in W.B. Gragg and -c W.J. Harrod, "The numerically stable reconstruction of Jacobi -c matrices from spectral data", Numer. Math. 44, 1984, 317-335.) -c -c Routine sti: -c -c This routine applies "Stieltjes's procedure" (cf. Section 2.1 of -c W. Gautschi, "On generating orthogonal polynomials", SIAM J. Sci. -c Statist. Comput. 3, 1982, 289-317) to generate the recursion -c coefficients alpha(k), beta(k) , k=0,1,...,n-1, for the discrete -c (monic) orthogonal polynomials associated with the inner product -c -c (f,g)=sum over k from 1 to ncap of w(k)*f(x(k))*g(x(k)). -c -c The integer n must be between 1 and ncap, inclusive; otherwise, -c there is an error exit with ierr=1. The results are stored in the -c arrays alpha, beta. -c -c If there is a threat of underflow or overflow in the calculation -c of the coefficients alpha(k) and beta(k), the routine exits with -c the error flag ierr set equal to -k (in the case of underflow) -c or +k (in the case of overflow), where k is the recursion index -c for which the problem occurs. The former [latter] can often be avoided -c by multiplying all weights w(k) by a sufficiently large [small] -c scaling factor prior to entering the routine, and, upon exit, divide -c the coefficient beta(0) by the same factor. -c -c This routine should be used with caution if n is relatively close -c to ncap, since there is a distinct possibility of numerical -c instability developing. (See W. Gautschi, "Is the recurrence relation -c for orthogonal polynomials always stable?", BIT, 1993, to appear.) -c In that case, the routine lancz should be used. - Implicit None - Integer :: n,ncap,ierr,i,k - Real*8 :: x(ncap),w(ncap),alpha(n),beta(n),p0(ncap),p1(ncap), - & gam,pj,rho,sig,t,tk,tmp,tsig,xlam -#include "real.fh" - ierr=0 - if (n.le.0 .or. n.gt.ncap) then - ierr=1 - return - end if - do i=1,ncap - p0(i)=x(i) - p1(i)=zero - end do - p1(1)=w(1) - do i=1,ncap-1 - pj=w(i+1) - gam=one - sig=zero - t=zero - xlam=x(i+1) - do k=1,i+1 - rho=p1(k)+pj - tmp=gam*rho - tsig=sig - if (rho.le.zero) then - gam=one - sig=zero - else - gam=p1(k)/rho - sig=pj/rho - end if - tk=sig*(p0(k)-xlam)-gam*t - p0(k)=p0(k)-(tk-t) - t=tk - if (sig.le.zero) then - pj=tsig*p1(k) - else - pj=(t**2)/sig - end if - tsig=sig - p1(k)=tmp - end do - end do - do k=1,n - alpha(k)=p0(k) - beta(k)=p1(k) - end do - return - End diff -Nru openmolcas-22.02/src/rys_util/rysscratch.F90 openmolcas-22.10/src/rys_util/rysscratch.F90 --- openmolcas-22.02/src/rys_util/rysscratch.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/rysscratch.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,422 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1994, Walter Gautschi * +! 1994, Gene H. Golub * +! 2017, Ignacio Fdez. Galvan * +!*********************************************************************** + +module RysScratch +! Compute Rys roots and weights from scratch + +use Definitions, only: wp, iwp + +implicit none +private + +! WhichQuad: which shifted Legendre quadrature to use +! (number of points would be 24,27,30,34,37,39,42,45,46,50,51,54,56,59,61,63,66,68,70,73,300) +! TAsymp: asymptotic limit for the t parameter, for values larger than +! this, the scaled Hermite quadrature is accurate enough. +! These values are quite conservative, with estimated errors +! below 1e-16. + +integer(kind=iwp), parameter :: naux(11) = [30,35,40,45,50,55,60,65,70,75,300], & + WhichQuad(21) = [1,1,1,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,9,10,size(naux)] +real(kind=wp), parameter :: TAsymp(20) = [39.0_wp,47.0_wp,54.0_wp,60.0_wp,66.0_wp,72.0_wp,78.0_wp,83.0_wp,89.0_wp,94.0_wp,99.0_wp, & + 104.0_wp,109.0_wp,115.0_wp,120.0_wp,125.0_wp,130.0_wp,134.0_wp,139.0_wp,144.0_wp] +real(kind=wp), allocatable :: Leg_r(:,:), Leg_w(:,:) + +public :: RysRtsWgh, SetAux, UnSetAux + +contains + +! Compute and store roots and weights for a shifted Legendre quadrature, +! used for boot-strapping Rys roots and weights. +! Different sets of roots and weights are computed + +subroutine SetAux(eps) + + use stdalloc, only: mma_allocate, mma_deallocate + use Constants, only: One, Four, Half, Quart + use Definitions, only: u6 + + real(kind=wp), intent(in) :: eps + integer(kind=iwp) :: Err, i, j, maux + real(kind=wp), allocatable :: a(:), b(:) + integer(kind=iwp), parameter :: nquad = size(naux) + + if (allocated(Leg_r)) return + maux = maxval(naux) + call mma_allocate(Leg_r,maux,nquad,label='Leg_r') + call mma_allocate(Leg_w,maux,nquad,label='Leg_w') + call mma_allocate(a,maux) + call mma_allocate(b,maux) + do j=1,nquad + a(1:naux(j)) = Half + b(1) = One + do i=2,naux(j) + b(i) = Quart/(Four-One/(i-1)**2) + end do + call GaussQuad(naux(j),a,b,eps,Leg_r(1,j),Leg_w(1,j),Err) + if (Err /= 0) then + write(u6,*) Err + call WarningMessage(2,'Error in GaussQuad') + call AbEnd() + end if + Leg_r(1:naux(j),j) = Leg_r(1:naux(j),j)**2 + end do + call mma_deallocate(a) + call mma_deallocate(b) + +end subroutine SetAux + +subroutine UnSetAux() + + use stdalloc, only: mma_deallocate + + if (allocated(Leg_r)) call mma_deallocate(Leg_r) + if (allocated(Leg_w)) call mma_deallocate(Leg_w) + +end subroutine UnSetAux + +! Compute Rys roots and weights from scratch: +! - For high t values use the asymptotic scaled Hermite quadrature +! - For lower t, get first alpha and beta from the auxiliary Legendre +! quadrature, then compute roots and weights + +subroutine RysRtsWgh(TValues,nT,Roots,Weights,Order) + + use vRys_RW, only: HerR2, HerW2, iHerR2, iHerW2 + use Gateway_global, only: asymptotic_Rys + use stdalloc, only: mma_allocate, mma_deallocate + use Constants, only: Five + use Definitions, only: u6 + + integer(kind=iwp), intent(in) :: nT, Order + real(kind=wp), intent(in) :: TValues(nT) + real(kind=wp), intent(out) :: Roots(Order,nT), Weights(Order,nT) + integer(kind=iwp) :: i, iquad, Err + real(kind=wp) :: Alpha(Order), Beta(Order), TA + real(kind=wp), allocatable :: a(:), b(:) + real(kind=wp), parameter :: eps = 1.0e-16_wp + + if (Order > size(TAsymp)) then + ! Rough fit for asymptotic T + TA = 50.0_wp+Five*Order + else + TA = TAsymp(Order) + end if + + do i=1,nT + if ((TValues(i) > TA) .or. asymptotic_Rys) then + Roots(:,i) = HerR2(iHerR2(Order):iHerR2(Order)+Order-1)/TValues(i) + Weights(:,i) = HerW2(iHerW2(Order):iHerW2(Order)+Order-1)/sqrt(TValues(i)) + else + iquad = WhichQuad(min(Order,size(WhichQuad))) + call mma_allocate(a,naux(iquad)) + call mma_allocate(b,naux(iquad)) + a(1:naux(iquad)) = Leg_r(1:naux(iquad),iquad) + b(1:naux(iquad)) = Leg_w(1:naux(iquad),iquad)*exp(-TValues(i)*a(1:naux(iquad))) + call Lanczos(Order,naux(iquad),a,b,Alpha,Beta,Err) + if (Err /= 0) then + write(u6,*) Err + call WarningMessage(2,'Error in Lanczos') + call AbEnd() + end if + call GaussQuad(Order,Alpha,Beta,eps,Roots(1,i),Weights(1,i),Err) + if (Err /= 0) then + write(u6,*) Err + call WarningMessage(2,'Error in GaussQuad 2') + call AbEnd() + end if + call mma_deallocate(a) + call mma_deallocate(b) + end if + end do + +end subroutine RysRtsWgh + +!*********************************************************************** +! Routines GaussQuad and Lanczos adapted from: +! +! Algorithm 726: ORTHPOL -- A package of Routines for Generating +! Orthogonal Polynomials and Gauss-Type Quadrature Rules +! Walter Gautschi. ACM Trans. Math. Softw. 20 (1994) 21-62 +! doi:10.1145/174603.174605 +!*********************************************************************** + +subroutine GaussQuad(n,alpha,beta,eps,roots,weights,ierr) +! Given n and a measure dlambda, this routine generates the n-point +! Gaussian quadrature formula +! +! integral over supp(dlambda) of f(x)dlambda(x) +! +! = sum from k=1 to k=n of w(k)f(x(k)) + R(n;f). +! +! The nodes are returned as roots(k)=x(k) and the weights as +! weights(k)=w(k), k=1,2,...,n. The user has to supply the recursion +! coefficients alpha(k), beta(k), k=0,1,2,...,n-1, for the measure +! dlambda. The routine computes the nodes as eigenvalues, and the +! weights in term of the first component of the respective normalized +! eigenvectors of the n-th order Jacobi matrix associated with dlambda. +! It uses a translation and adaptation of the algol procedure imtql2, +! Numer. Math. 12, 1968, 377-383, by Martin and Wilkinson, as modified +! by Dubrulle, Numer. Math. 15, 1970, 450. See also Handbook for +! Autom. Comput., vol. 2 - Linear Algebra, pp.241-248, and the eispack +! routine imtql2. +! +! Input: n - - the number of points in the Gaussian quadrature +! formula; type integer +! alpha,beta - arrays of dimension n to be filled +! with the values of alpha(k-1), beta(k-1), k=1,2, +! ...,n +! eps - the relative accuracy desired in the nodes +! and weights +! +! Output: roots - array of dimension n containing the Gaussian +! nodes (in increasing order) roots(k)=x(k), k=1,2, +! ...,n +! weights - array of dimension n containing the +! Gaussian weights weights(k)=w(k), k=1,2,...,n +! ierr - an error flag equal to 0 on normal return, +! equal to i if the QR algorithm does not +! converge within 30 iterations on evaluating the +! i-th eigenvalue, equal to -1 if n is not in +! range, and equal to -2 if one of the beta's is +! negative. + + use stdalloc, only: mma_allocate, mma_deallocate + use Constants, only: Zero, One, Two + + integer(kind=iwp), intent(in) :: n + real(kind=wp), intent(in) :: alpha(n), beta(n), eps + real(kind=wp), intent(out) :: roots(n), weights(n) + integer(kind=iwp), intent(out) :: ierr + integer(kind=iwp) :: i, ii, j, k, l, m, mml + real(kind=wp) :: b, c, f, g, p, r, s + real(kind=wp), allocatable :: e(:) + integer(kind=iwp), parameter :: maxcyc = 30 + + ierr = 0 + if (n < 1) then + ierr = -1 + return + end if + + ! Initialization + + call mma_allocate(e,n,label='e') + roots(:) = alpha + weights(:) = Zero + if (any(beta < Zero)) then + ierr = -2 + return + end if + e(1:n-1) = sqrt(beta(2:n)) + if (n == 1) then + weights(1) = beta(1) + return + else + weights(1) = One + e(n) = Zero + end if + + ! Loop over roots + + do l=1,n + do j=1,maxcyc + + ! Look for a small subdiagonal element. + + do m=l,n-1 + if (abs(e(m)) <= eps*(abs(roots(m))+abs(roots(m+1)))) exit + end do + p = roots(l) + if (m == l) exit + + ! Form shift. + + g = (roots(l+1)-p)/(Two*e(l)) + r = sqrt(g*g+One) + g = roots(m)-p+e(l)/(g+sign(r,g)) + s = One + c = One + p = Zero + mml = m-l + + ! For i=m-1 step -1 until l do ... + + do ii=1,mml + i = m-ii + f = s*e(i) + b = c*e(i) + if (abs(f) < abs(g)) then + s = f/g + r = sqrt(s*s+One) + e(i+1) = g*r + c = One/r + s = s*c + else + c = g/f + r = sqrt(c*c+One) + e(i+1) = f*r + s = One/r + c = c*s + end if + g = roots(i+1)-p + r = (roots(i)-g)*s+Two*c*b + p = s*r + roots(i+1) = g+p + g = c*r-b + + ! Form first component of vector. + + f = weights(i+1) + weights(i+1) = s*weights(i)+c*f + weights(i) = c*weights(i)-s*f + end do + roots(l) = roots(l)-p + e(l) = g + e(m) = Zero + end do + + ! Set error - no convergence to an eigenvalue after maxcyc iterations. + + if (j > maxcyc) then + ierr = l + return + end if + end do + call mma_deallocate(e) + + ! Order eigenvalues and eigenvectors. + + do ii=2,n + i = ii-1 + k = i + p = roots(i) + do j=ii,n + if (roots(j) < p) then + k = j + p = roots(j) + end if + end do + if (k /= i) then + roots(k) = roots(i) + roots(i) = p + p = weights(i) + weights(i) = weights(k) + weights(k) = p + end if + end do + weights(:) = beta(1)*weights**2 + + return + +end subroutine GaussQuad + +subroutine Lanczos(n,ncap,x,w,alpha,beta,ierr) +! This routine carries out the same task as the routine sti, but +! uses the more stable Lanczos method. The meaning of the input +! and output parameters is the same as in the routine sti. (This +! routine is adapted from the routine RKPW in W.B. Gragg and +! W.J. Harrod, "The numerically stable reconstruction of Jacobi +! matrices from spectral data", Numer. Math. 44, 1984, 317-335.) +! +! Routine sti: +! +! This routine applies "Stieltjes's procedure" (cf. Section 2.1 of +! W. Gautschi, "On generating orthogonal polynomials", SIAM J. Sci. +! Statist. Comput. 3, 1982, 289-317) to generate the recursion +! coefficients alpha(k), beta(k) , k=0,1,...,n-1, for the discrete +! (monic) orthogonal polynomials associated with the inner product +! +! (f,g)=sum over k from 1 to ncap of w(k)*f(x(k))*g(x(k)). +! +! The integer n must be between 1 and ncap, inclusive; otherwise, +! there is an error exit with ierr=1. The results are stored in the +! arrays alpha, beta. +! +! If there is a threat of underflow or overflow in the calculation +! of the coefficients alpha(k) and beta(k), the routine exits with +! the error flag ierr set equal to -k (in the case of underflow) +! or +k (in the case of overflow), where k is the recursion index +! for which the problem occurs. The former [latter] can often be avoided +! by multiplying all weights w(k) by a sufficiently large [small] +! scaling factor prior to entering the routine, and, upon exit, divide +! the coefficient beta(0) by the same factor. +! +! This routine should be used with caution if n is relatively close +! to ncap, since there is a distinct possibility of numerical +! instability developing. (See W. Gautschi, "Is the recurrence relation +! for orthogonal polynomials always stable?", BIT, 1993, to appear.) +! In that case, the routine lancz should be used. + + use stdalloc, only: mma_allocate, mma_deallocate + use Constants, only: Zero, One + + integer(kind=iwp), intent(in) :: n, ncap + real(kind=wp), intent(in) :: x(ncap), w(ncap) + real(kind=wp), intent(out) :: alpha(n), beta(n) + integer(kind=iwp), intent(out) :: ierr + integer(kind=iwp) :: i, k + real(kind=wp) :: gam, pj, rho, sig, t, tk, tmp, tsig, xlam + real(kind=wp), allocatable :: p0(:), p1(:) + + ierr = 0 + if ((n <= 0) .or. (n > ncap)) then + ierr = 1 + return + end if + call mma_allocate(p0,ncap,label='p0') + call mma_allocate(p1,ncap,label='p1') + p0(:) = x + p1(:) = Zero + p1(1) = w(1) + do i=1,ncap-1 + pj = w(i+1) + gam = One + sig = Zero + t = Zero + xlam = x(i+1) + do k=1,i+1 + rho = p1(k)+pj + tmp = gam*rho + tsig = sig + if (rho <= Zero) then + gam = One + sig = Zero + else + gam = p1(k)/rho + sig = pj/rho + end if + tk = sig*(p0(k)-xlam)-gam*t + p0(k) = p0(k)-(tk-t) + t = tk + if (sig <= Zero) then + pj = tsig*p1(k) + else + pj = (t**2)/sig + end if + tsig = sig + p1(k) = tmp + end do + end do + alpha(:) = p0(1:n) + beta(:) = p1(1:n) + call mma_deallocate(p0) + call mma_deallocate(p1) + + return + +end subroutine Lanczos + +end module RysScratch diff -Nru openmolcas-22.02/src/rys_util/sether.f openmolcas-22.10/src/rys_util/sether.f --- openmolcas-22.02/src/rys_util/sether.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/sether.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,173 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1992, Per Ake Malmqvist * -* 1992, Roland Lindh * -************************************************************************ - Subroutine SetHer(nDiff) -************************************************************************ -* * -* Object: to setup the roots and weights of the Hermite polynomials * -* for the evaluation of one electron integrals. * -* * -* Authors: Per-AAke Malmqvist and Roland Lindh, * -* March 1992. * -************************************************************************ - use Her_RW - use Sizes_of_Seward, only: S - Implicit Real*8 (A-H,O-Z) -#include "stdalloc.fh" -#include "real.fh" -#include "status.fh" - Real*8, Dimension(:), Allocatable :: Beta, BInv, Herm -* - If (nPrp.gt.nPrpMx) Then - Write (6,*) 'nPrp, nPrpMx=',nPrp, nPrpMx - Call WarningMessage(2,'SetHer: nPrp too large!') - Call Abend() - End If -* -* -* 1) Hermite-Gauss -* 2) Rys-Gauss (asymtotic formula) -* - n_1111 = (2*S%iAngMx+nPrp+2+nDiff)/2 - n_2222 = 4*S%iAngMx+2+nDiff -* - If (Allocated(HerR) .and. Max(n_1111,n_2222).le.MaxHer) Then - Return - Else If (Allocated(HerR)) Then - Call Free_HerRW() - End If - MaxHer = Max(n_1111,n_2222) - Call mma_allocate(iHerR,MaxHer,label='iHerR') - Call mma_allocate(iHerW,MaxHer,label='iHerW') -* -* Set up square of roots and weights for Hermite polynomials -* - nMem = (MaxHer*MaxHer+MaxHer)/2 - Call mma_Allocate(HerR,nMem,label='HerR') - iHerR(1)=1 - Call dCopy_(nMem,[0.0d0],0,HerR,1) - Call mma_allocate(HerW,nMem,label='HerW') - iHerW(1)=1 - Call dCopy_(nMem,[0.0d0],0,HerW,1) - Call mma_allocate(Beta,MaxHer,label='Beta') - Call dCopy_(MaxHer,[0.0d0],0,Beta,1) - Call mma_allocate(BInv,MaxHer,label='BInv') - Call dCopy_(MaxHer,[0.0d0],0,BInv,1) - Call mma_allocate(Herm,MaxHer+1,label='Herm') - Call dCopy_(MaxHer+1,[0.0d0],0,Herm,1) - DO 10 K=1,MaxHer - b_1111 = HALF*DBLE(K) - B=SQRT(b_1111) - Beta(K)=B - BInv(K)=1.0d0/B - 10 CONTINUE - HerR(iHerR(1))=0.0d0 - HerR(iHerR(1)+2)=SQRT(HALF) - HerR(iHerR(1)+1)=-HerR(iHerR(1)+2) - HerW(iHerW(1))=SQRT(PI) - HerW(iHerW(1)+1)=HerW(iHerW(1))*HALF - HerW(iHerW(1)+2)=HerW(iHerW(1)+1) - Herm(1)=1.0d0/SQRT( HerW(iHerW(1)) ) - Do 11 iHer = 2, MaxHer - i_1111 = (iHer*iHer-iHer)/2 - iHerR(iHer) = iHerR(1) + i_1111 - iHerW(iHer) = iHerW(1) + i_1111 - 11 Continue -* - Alpha = BInv(1) - DO 2000 IDEG=3,MaxHer - i_0000 = (IDEG*IDEG-IDEG)/2 - IR=iHerR(1)-1+i_0000 - IW=iHerW(1)-1+i_0000 - IDH=IDEG/2 - i_1111 = IR+IDH+1 - i_3333 = i_1111-IDEG - w_3333 = HerR(i_3333) - i_2222 = i_3333+1 - w_2222 = HerR(i_2222) - X=(w_2222-w_3333)/2.0d0 - HerR(i_1111)=0.0d0 - DO 20 IROOT=2,IDEG,2 - j_0000 = IROOT/2 - j_1111 = IR+j_0000 - j_2222 = IR-IDEG+1+j_0000 - j_3333 = IR+IDEG+1-j_0000 - R = HerR(j_2222)-X - HerR(j_1111) = R - HerR(j_3333) = -R - 20 CONTINUE - DO 1000 IROOT=1,IDH - j_0000 = IR+IROOT - Z = HerR(j_0000) - CORR = 0.0d0 - Do j = 1,ideg - If ( j.ne.iroot ) then - c_0000 = Z-HerR(IR+J) - CORR=CORR+(1.0d0/c_0000) - End If - End Do - 99 CONTINUE - Herm(2)=Z*Herm(1)*Alpha - DO 110 K=1,IDEG-1 - w_1111 = Herm(K+1) - w_3333 = Herm(K) - w_4444 = Beta(K) - w_5555 = BInv(K+1) - w_2222 = (Z*w_1111-w_4444*w_3333)*w_5555 - Herm(K+2) = w_2222 - 110 CONTINUE - HDER=2.0d0*Beta(IDEG)*Herm(IDEG) - DELTA=-Herm(IDEG+1)/(HDER-CORR*Herm(IDEG+1)) - Z=Z+DELTA - IF(ABS(DELTA).GT.1.0d-8) then - if(abs(DELTA).gt.1.0d8) then - Call WarningMessage(1,'Warning: large value in sether') -c write(6,*) delta - endif - goto 99 - endif - HerR(IR+IROOT)=Z - HerR(IR+IDEG+1-IROOT)=-Z - 1000 CONTINUE - DO 3010 IROOT=1,IDH+1 - j_0000 = IR+IROOT - Z = HerR(j_0000) - Herm(2)=Z*Herm(1)*Alpha - SUM=Herm(1)**2 - SUM=SUM+Herm(2)**2 - DO 3020 K=1,IDEG-2 - w_1111 = Herm(K+1) - w_3333 = Herm(K) - w_4444 = Beta(K) - w_5555 = BInv(K+1) - w_2222 = (Z*w_1111-w_4444*w_3333)*w_5555 - Herm(K+2) = w_2222 - SUM=SUM+w_2222*w_2222 - 3020 CONTINUE - W = 1.0d0/SUM - HerW(IW+IROOT) = W - HerW(IW+IDEG+1-IROOT) = W - 3010 CONTINUE - 2000 CONTINUE - Call mma_deallocate(Beta) - Call mma_deallocate(BInv) - Call mma_deallocate(Herm) -* -*define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Call TriPrt(' Hermite roots',' ',HerR(iHerR(1)),MaxHer) - Call TriPrt(' Hermite weights',' ',HerW(iHerW(1)),MaxHer) - Write (6,*) ' MaxHer=',MaxHer,nPrp,S%iAngMx -#endif - Return - End diff -Nru openmolcas-22.02/src/rys_util/sether.F90 openmolcas-22.10/src/rys_util/sether.F90 --- openmolcas-22.02/src/rys_util/sether.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/sether.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,150 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1992, Per Ake Malmqvist * +! 1992, Roland Lindh * +!*********************************************************************** + +subroutine SetHer(nDiff) +!*********************************************************************** +! * +! Object: to set up the roots and weights of the Hermite polynomials * +! for the evaluation of one-electron integrals. * +! * +! Authors: Per-AAke Malmqvist and Roland Lindh, * +! March 1992. * +!*********************************************************************** + +use Her_RW, only: HerR, HerW, iHerR, iHerW, MaxHer, nPrp +use Sizes_of_Seward, only: S +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One, Two, Half, Pi +use Definitions, only: wp, iwp +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +use Definitions, only: u6 +#endif + +implicit none +integer(kind=iwp), intent(in) :: nDiff +integer(kind=iwp) :: i_0, i_1, IDEG, IDH, iHer, IR, IROOT, IW, j, j_0, K, n_1, n_2, nMem +real(kind=wp) :: Alpha, CORR, DELTA, HDER, R, RSUM, W, X, Z +real(kind=wp), allocatable :: Beta(:), BInv(:), Herm(:) + +! 1) Hermite-Gauss +! 2) Rys-Gauss (asymptotic formula) + +n_1 = (2*S%iAngMx+nPrp+2+nDiff)/2 +n_2 = 4*S%iAngMx+2+nDiff + +if (allocated(HerR) .and. (max(n_1,n_2) <= MaxHer)) then + return +else if (allocated(HerR)) then + call Free_HerRW() +end if +MaxHer = max(n_1,n_2) +call mma_allocate(iHerR,MaxHer,label='iHerR') +iHerR(1) = 1 +call mma_allocate(iHerW,MaxHer,label='iHerW') +iHerW(1) = 1 + +! Set up square of roots and weights for Hermite polynomials + +nMem = (MaxHer*MaxHer+MaxHer)/2 +call mma_Allocate(HerR,nMem,label='HerR') +HerR(:) = Zero +call mma_allocate(HerW,nMem,label='HerW') +HerW(:) = Zero +call mma_allocate(Beta,MaxHer,label='Beta') +call mma_allocate(BInv,MaxHer,label='BInv') +call mma_allocate(Herm,MaxHer+1,label='Herm') +Herm(:) = Zero +do K=1,MaxHer + Beta(K) = sqrt(Half*K) +end do +BInv(:) = One/Beta +HerR(iHerR(1)) = Zero +HerR(iHerR(1)+2) = sqrt(HALF) +HerR(iHerR(1)+1) = -HerR(iHerR(1)+2) +HerW(iHerW(1)) = sqrt(PI) +HerW(iHerW(1)+1) = HerW(iHerW(1))*HALF +HerW(iHerW(1)+2) = HerW(iHerW(1)+1) +Herm(1) = One/sqrt(HerW(iHerW(1))) +do iHer=2,MaxHer + i_1 = (iHer*iHer-iHer)/2 + iHerR(iHer) = iHerR(1)+i_1 + iHerW(iHer) = iHerW(1)+i_1 +end do + +Alpha = BInv(1) +do IDEG=3,MaxHer + i_0 = (IDEG*IDEG-IDEG)/2 + IR = iHerR(1)-1+i_0 + IW = iHerW(1)-1+i_0 + IDH = IDEG/2 + i_1 = IR+IDH+1 + X = Half*(HerR(i_1-IDEG+1)-HerR(i_1-IDEG)) + HerR(i_1) = Zero + do IROOT=2,IDEG,2 + j_0 = IROOT/2 + R = HerR(IR-IDEG+1+j_0)-X + HerR(IR+j_0) = R + HerR(IR+IDEG+1-j_0) = -R + end do + do IROOT=1,IDH + Z = HerR(IR+IROOT) + CORR = Zero + do j=1,ideg + if (j /= iroot) CORR = CORR+(One/Z-HerR(IR+J)) + end do + do + Herm(2) = Z*Herm(1)*Alpha + do K=1,IDEG-1 + Herm(K+2) = (Z*Herm(K+1)-Beta(K)*Herm(K))*BInv(K+1) + end do + HDER = Two*Beta(IDEG)*Herm(IDEG) + DELTA = -Herm(IDEG+1)/(HDER-CORR*Herm(IDEG+1)) + Z = Z+DELTA + if (abs(DELTA) <= 1.0e-8_wp) exit + if (abs(DELTA) > 1.0e8_wp) then + call WarningMessage(1,'Warning: large value in sether') + !write(u6,*) delta + end if + end do + HerR(IR+IROOT) = Z + HerR(IR+IDEG+1-IROOT) = -Z + end do + do IROOT=1,IDH+1 + Z = HerR(IR+IROOT) + Herm(2) = Z*Herm(1)*Alpha + RSUM = Herm(1)**2 + RSUM = RSUM+Herm(2)**2 + do K=1,IDEG-2 + Herm(K+2) = (Z*Herm(K+1)-Beta(K)*Herm(K))*BInv(K+1) + RSUM = RSUM+Herm(K+2)**2 + end do + W = One/RSUM + HerW(IW+IROOT) = W + HerW(IW+IDEG+1-IROOT) = W + end do +end do +call mma_deallocate(Beta) +call mma_deallocate(BInv) +call mma_deallocate(Herm) + +#ifdef _DEBUGPRINT_ +call TriPrt(' Hermite roots',' ',HerR(iHerR(1)),MaxHer) +call TriPrt(' Hermite weights',' ',HerW(iHerW(1)),MaxHer) +write(u6,*) ' MaxHer=',MaxHer,nPrp,S%iAngMx +#endif + +return + +end subroutine SetHer diff -Nru openmolcas-22.02/src/rys_util/setupr.f openmolcas-22.10/src/rys_util/setupr.f --- openmolcas-22.02/src/rys_util/setupr.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/setupr.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,91 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991, Roland Lindh * -* 1992, Per Ake Malmqvist * -************************************************************************ - SubRoutine SetUpR(nRys) -************************************************************************ -* * -* Object: to setup the coefficients for the Rys roots and weights. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* September '90 * -* * -* Roland Lindh, Dept. of Theoretical Cehmistry, University * -* of Lund, SWEDEN. * -* Modified to DaFile February '91 * -* * -* Added: Call to READAB, P.-A. Malmqvist March 1992, to set up * -* the tables needed to calculate large-order roots and * -* weights on request. * -************************************************************************ - use Her_RW - use vRys_RW - use Leg_RW - implicit none -#include "real.fh" -#include "stdalloc.fh" -#include "status.fh" -#include "print.fh" -* - integer :: nRys -* - integer :: iRys, jRys - integer :: MemHer, iHer, iOffR -* - If (Allocated(iHerR2)) Then - Call WarningMessage(2, - & 'SetupR: Rys_Status is already active!') - Call Abend() - End If -* -#ifdef _RYS_SCRATCH_ - CALL SetAux(1.0D-16) -#endif -* - CALL Read_ABData -* - CALL Read_RysRW -* -* Set up the square of roots and the weights for Hermite polynomials -* We will only do this for the even numbered polynomials. -* - MemHer=nRys*(nRys+1)/2 - Call mma_allocate(iHerR2,nRys,label='iHerR2') - iHerR2(1)=1 - Call mma_allocate(iHerW2,nRys,label='iHerW2') - iHerW2(1)=1 - Call mma_allocate(HerR2,MemHer,label='HerR2') - Call mma_allocate(HerW2,MemHer,label='HerW2') -* - If (2*nRys.gt.MaxHer) Then - Call WarningMessage(2,'SetupR: 2*nRys>MaxHer') - Call Abend() - End If - Do 110 iRys=1,nRys - iHer=2*iRys - iOffR=(iRys*(iRys-1))/2 - iHerR2(iRys) = iHerR2(1) + iOffR - iHerW2(iRys) = iHerW2(1) + iOffR - Do 105 jRys=0,iRys-1 - HerR2(iHerR2(iRys)+jRys) = HerR(iHerR(iHer)+iRys+jRys)**2 - HerW2(iHerW2(iRys)+jRys) = HerW(iHerW(iHer)+iRys+jRys) - 105 Continue - 110 Continue -* -*define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Call TriPrt(' Hermite squared roots',' ',HerR2(iHerR2(1)),nRys) - Call TriPrt(' Hermite weights ',' ',HerW2(iHerW2(1)),nRys) -#endif -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/setupr.F90 openmolcas-22.10/src/rys_util/setupr.F90 --- openmolcas-22.02/src/rys_util/setupr.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/setupr.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,93 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991, Roland Lindh * +! 1992, Per Ake Malmqvist * +!*********************************************************************** + +subroutine SetUpR(nRys) +!*********************************************************************** +! * +! Object: to setup the coefficients for the Rys roots and weights. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! September '90 * +! * +! Roland Lindh, Dept. of Theoretical Cehmistry, University * +! of Lund, SWEDEN. * +! Modified to DaFile February '91 * +! * +! Added: Call to READAB, P.-A. Malmqvist March 1992, to set up * +! the tables needed to calculate large-order roots and * +! weights on request. * +!*********************************************************************** + +use Her_RW, only: HerR, HerW, iHerR, iHerW, MaxHer +use vRys_RW, only: HerR2, HerW2, iHerR2, iHerW2 +use abdata, only: read_abdata +use stdalloc, only: mma_allocate +use Definitions, only: iwp +#ifdef _RYS_SCRATCH_ +use RysScratch, only: SetAux +use Definitions, only: wp +#endif + +implicit none +integer(kind=iwp), intent(in) :: nRys +integer(kind=iwp) :: iHer, iOffR, iRys, jRys, MemHer + +if (allocated(iHerR2)) then + call WarningMessage(2,'SetupR: Rys_Status is already active!') + call Abend() +end if + +#ifdef _RYS_SCRATCH_ +call SetAux(1.0e-16_wp) +#endif + +call Read_ABData() + +call Read_RysRW() + +! Set up the square of roots and the weights for Hermite polynomials +! We will only do this for the even numbered polynomials. + +MemHer = nRys*(nRys+1)/2 +call mma_allocate(iHerR2,nRys,label='iHerR2') +iHerR2(1) = 1 +call mma_allocate(iHerW2,nRys,label='iHerW2') +iHerW2(1) = 1 +call mma_allocate(HerR2,MemHer,label='HerR2') +call mma_allocate(HerW2,MemHer,label='HerW2') + +if (2*nRys > MaxHer) then + call WarningMessage(2,'SetupR: 2*nRys>MaxHer') + call Abend() +end if +do iRys=1,nRys + iHer = 2*iRys + iOffR = (iRys*(iRys-1))/2 + iHerR2(iRys) = iHerR2(1)+iOffR + iHerW2(iRys) = iHerW2(1)+iOffR + do jRys=0,iRys-1 + HerR2(iHerR2(iRys)+jRys) = HerR(iHerR(iHer)+iRys+jRys)**2 + HerW2(iHerW2(iRys)+jRys) = HerW(iHerW(iHer)+iRys+jRys) + end do +end do + +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +call TriPrt(' Hermite squared roots',' ',HerR2(iHerR2(1)),nRys) +call TriPrt(' Hermite weights ',' ',HerW2(iHerW2(1)),nRys) +#endif + +return + +end subroutine SetUpR diff -Nru openmolcas-22.02/src/rys_util/setup_rw.f openmolcas-22.10/src/rys_util/setup_rw.f --- openmolcas-22.02/src/rys_util/setup_rw.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/setup_rw.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1996, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine SetUp_RW(DoRys,nDiff) -************************************************************************ -* * -* Object: to setup tables for auxiliary functions to be used direct * -* in the recurrence relations of integral form or indirectly * -* to compute the Rys roots and weights which are used in the * -* recurrence relations of integrand form. For the lower order * -* Rys polynomials the roots and weight are computed from expa- * -* nsion coefficients. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* January '90 * -* * -* Unified version August '96, RL. * -************************************************************************ - use External_Centers, only: XF, nOrdEF - use Sizes_of_Seward, only: S - use Gateway_Info, only: GIAO - Implicit Real*8 (A-H,O-Z) - Logical DoRys - Integer nDiff -* -* Compute max sum of angular momentum index -* - iAng2 = 4*S%iAngMx -* -* Set up roots and weights for Hermite polynomials. -* - Call SetHer(nDiff) -* -* Set up coefficients for Rys polynomials. -* -* 1) for two-electron integrals -* 2) for external field and nuclear attraction -* - mRys =(iAng2+2+nDiff)/2 - If (Allocated(XF).or.(nOrdEF.eq.1).or.GIAO) - & mRys=Max(mRys,(2*S%iAngMx+1+2+nDiff)/2) - If (nOrdEF.eq.2) mRys=Max(mRys,(2*S%iAngMx+2+2+nDiff)/2) - If (DoRys) Call SetUpR(mRys) -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/setup_rw.F90 openmolcas-22.10/src/rys_util/setup_rw.F90 --- openmolcas-22.02/src/rys_util/setup_rw.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/setup_rw.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,61 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1996, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine SetUp_RW(DoRys,nDiff) +!*********************************************************************** +! * +! Object: to setup tables for auxiliary functions to be used direct * +! in the recurrence relations of integral form or indirectly * +! to compute the Rys roots and weights which are used in the * +! recurrence relations of integrand form. For the lower order * +! Rys polynomials the roots and weight are computed from expa- * +! nsion coefficients. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! January '90 * +! * +! Unified version August '96, RL. * +!*********************************************************************** + +use External_Centers, only: nOrdEF, XF +use Sizes_of_Seward, only: S +use Gateway_Info, only: GIAO +use Definitions, only: iwp + +implicit none +logical(kind=iwp), intent(in) :: DoRys +integer(kind=iwp), intent(in) :: nDiff +integer(kind=iwp) :: iAng2, mRys + +! Compute max sum of angular momentum index + +iAng2 = 4*S%iAngMx + +! Set up roots and weights for Hermite polynomials. + +call SetHer(nDiff) + +! Set up coefficients for Rys polynomials. + +! 1) for two-electron integrals +! 2) for external field and nuclear attraction + +mRys = (iAng2+2+nDiff)/2 +if (allocated(XF) .or. (nOrdEF == 1) .or. GIAO) mRys = max(mRys,(2*S%iAngMx+1+2+nDiff)/2) +if (nOrdEF == 2) mRys = max(mRys,(2*S%iAngMx+2+2+nDiff)/2) +if (DoRys) call SetUpR(mRys) + +return + +end subroutine SetUp_RW diff -Nru openmolcas-22.02/src/rys_util/sppp.f openmolcas-22.10/src/rys_util/sppp.f --- openmolcas-22.02/src/rys_util/sppp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/sppp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,496 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1994, Roland Lindh * -************************************************************************ - Subroutine sppp(EFInt,Zeta,ZInv,nZeta,P,lP,rKappAB,A,B, - & Eta,EInv, nEta,Q,lQ,rKappCD,C,D, - & CoorAC,TMax, - & iPntr,nPntr,x0,nMax,CW6,CW5,CW4,CW3,CW2,CW1,CW0, - & CR6,CR5,CR4,CR3,CR2,CR1,CR0, - & ddx,HerW,HerR2,IsChi,ChiI2) -************************************************************************ -* * -* Object: to compute the primitive integrals of type (sp|pp). * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. 1994 * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 EFInt(nZeta,nEta,27), Zeta(nZeta), Eta(nEta), - & CoorAC(3,2), ZInv(nZeta), EInv(nEta), - & P(lP,3), Q(lQ,3), A(3), B(3), C(3), D(3), - & rKappAB(nZeta), rKappCD(nEta), - & x0(nMax), - & CW6(nMax,2), CW5(nMax,2), CW4(nMax,2), CW3(nMax,2), - & CW2(nMax,2), CW1(nMax,2), CW0(nMax,2), - & CR6(nMax,2), CR5(nMax,2), CR4(nMax,2), CR3(nMax,2), - & CR2(nMax,2), CR1(nMax,2), CR0(nMax,2), - & HerW(2), HerR2(2) - Integer iPntr(nPntr) - Logical EQ -* -* - xdInv=One/ddx - dddx = ddx/10d0 + ddx -* - If ( EQ(A,B).and..Not.EQ(C,D)) Go To 200 - If (.Not.EQ(A,B).and. EQ(C,D)) Go To 300 - If ( EQ(A,B).and. EQ(C,D)) Go To 400 -* -*-----ABCD case -* - Do 10 iEta = 1, nEta - Do 20 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*DBLE(IsChi)) - rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) - PQx = P(iZeta,1)-Q(iEta,1) - PQy = P(iZeta,2)-Q(iEta,2) - PQz = P(iZeta,3)-Q(iEta,3) - T = rho * (PQx**2 + PQy**2 + PQz**2) - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - w1 = PreFct*w1 - w2 = PreFct*w2 - Eu21 = Eta(iEta)*(r1*ZEInv) - Eu22 = Eta(iEta)*(r2*ZEInv) - Zu21 = Zeta(iZeta)*(r1*ZEInv) - Zu22 = Zeta(iZeta)*(r2*ZEInv) - PAQPx1 = (P(iZeta,1) - CoorAC(1,1)) - Eu21 * PQx - PAQPx2 = (P(iZeta,1) - CoorAC(1,1)) - Eu22 * PQx - PAQPy1 = (P(iZeta,2) - CoorAC(2,1)) - Eu21 * PQy - PAQPy2 = (P(iZeta,2) - CoorAC(2,1)) - Eu22 * PQy - PAQPz1 = (P(iZeta,3) - CoorAC(3,1)) - Eu21 * PQz - PAQPz2 = (P(iZeta,3) - CoorAC(3,1)) - Eu22 * PQz - QCPQx1 = ( Q(iEta,1) - CoorAC(1,2)) + Zu21 * PQx - QCPQx2 = ( Q(iEta,1) - CoorAC(1,2)) + Zu22 * PQx - QCPQy1 = ( Q(iEta,2) - CoorAC(2,2)) + Zu21 * PQy - QCPQy2 = ( Q(iEta,2) - CoorAC(2,2)) + Zu22 * PQy - QCPQz1 = ( Q(iEta,3) - CoorAC(3,2)) + Zu21 * PQz - QCPQz2 = ( Q(iEta,3) - CoorAC(3,2)) + Zu22 * PQz - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - B011 = (Half - Half * Zu21) * EInv(iEta) - B012 = (Half - Half * Zu22) * EInv(iEta) - x101= PAQPx1 - x102= PAQPx2 - x011= QCPQx1 - x012= QCPQx2 - x021= QCPQx1*x011 + B011 - x022= QCPQx2*x012 + B012 - x111= PAQPx1*QCPQx1 + B001 - x112= PAQPx2*QCPQx2 + B002 - x121= QCPQx1*x111 + B011*x101 + B001*x011 - x122= QCPQx2*x112 + B012*x102 + B002*x012 - y101= PAQPy1 - y102= PAQPy2 - y011= QCPQy1 - y012= QCPQy2 - y021= QCPQy1*y011 + B011 - y022= QCPQy2*y012 + B012 - y111= PAQPy1*QCPQy1 + B001 - y112= PAQPy2*QCPQy2 + B002 - y121= QCPQy1*y111 + B011*y101 + B001*y011 - y122= QCPQy2*y112 + B012*y102 + B002*y012 - z101= PAQPz1*w1 - z102= PAQPz2*w2 - z011= QCPQz1*w1 - z012= QCPQz2*w2 - z021= QCPQz1*z011 + B011*w1 - z022= QCPQz2*z012 + B012*w2 - z111= PAQPz1*QCPQz1*w1 + B001*w1 - z112= PAQPz2*QCPQz2*w2 + B002*w2 - z121= QCPQz1*z111 + B011*z101 + B001*z011 - z122= QCPQz2*z112 + B012*z102 + B002*z012 - EFInt(iZeta,iEta, 1)= x111*w1+ x112*w2 - EFInt(iZeta,iEta, 2)= y101*x011*w1+ y102*x012*w2 - EFInt(iZeta,iEta, 3)= z101*x011 + z102*x012 - EFInt(iZeta,iEta, 4)= x101*y011*w1+ x102*y012*w2 - EFInt(iZeta,iEta, 5)= y111*w1+ y112*w2 - EFInt(iZeta,iEta, 6)= (z101*y011) +(z102*y012) - EFInt(iZeta,iEta, 7)= (x101*z011) +(x102*z012) - EFInt(iZeta,iEta, 8)= (y101*z011) +(y102*z012) - EFInt(iZeta,iEta, 9)= z111 + z112 - EFInt(iZeta,iEta,10)= x121*w1+ x122*w2 - EFInt(iZeta,iEta,11)= y101*x021*w1+ y102*x022*w2 - EFInt(iZeta,iEta,12)= z101*x021 + z102*x022 - EFInt(iZeta,iEta,13)= x111*y011*w1+ x112*y012*w2 - EFInt(iZeta,iEta,14)= y111*x011*w1+ y112*x012*w2 - EFInt(iZeta,iEta,15)=x011*(z101*y011)+ x012*(z102*y012) - EFInt(iZeta,iEta,16)= x111*z011 + x112*z012 - EFInt(iZeta,iEta,17)=x011*(y101*z011)+ x012*(y102*z012) - EFInt(iZeta,iEta,18)= z111*x011 + z112*x012 - EFInt(iZeta,iEta,19)= x101*y021*w1+ x102*y022*w2 - EFInt(iZeta,iEta,20)= y121*w1+ y122*w2 - EFInt(iZeta,iEta,21)= z101*y021 + z102*y022 - EFInt(iZeta,iEta,22)=y011*(x101*z011)+y012*(x102*z012) - EFInt(iZeta,iEta,23)= y111*z011 + y112*z012 - EFInt(iZeta,iEta,24)= z111*y011 + z112*y012 - EFInt(iZeta,iEta,25)= x101*z021 + x102*z022 - EFInt(iZeta,iEta,26)= y101*z021 + y102*z022 - EFInt(iZeta,iEta,27)= z121 + z122 - 20 Continue - 10 Continue - Go To 99 -* -*-----AACD case -* - 200 Continue - Do 12 iEta = 1, nEta - Do 22 iZeta = 1, nZeta - PQx = CoorAC(1,1)-Q(iEta,1) - PQy = CoorAC(2,1)-Q(iEta,2) - PQz = CoorAC(3,1)-Q(iEta,3) - PQ2 = PQx**2 + PQy**2 + PQz**2 - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(eta(iEta)*Zeta(iZeta)*ChiI2)*DBLE(IsChi)) - rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) - T = rho * PQ2 - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - w1 = PreFct*w1 - w2 = PreFct*w2 - Eu21 = Eta(iEta)*(r1*ZEInv) - Eu22 = Eta(iEta)*(r2*ZEInv) - Zu21 = Zeta(iZeta)*(r1*ZEInv) - Zu22 = Zeta(iZeta)*(r2*ZEInv) - PAQPx1 = - Eu21 * PQx - PAQPx2 = - Eu22 * PQx - PAQPy1 = - Eu21 * PQy - PAQPy2 = - Eu22 * PQy - PAQPz1 = - Eu21 * PQz - PAQPz2 = - Eu22 * PQz - QCPQx1 = ( Q(iEta,1) - CoorAC(1,2)) + Zu21 * PQx - QCPQx2 = ( Q(iEta,1) - CoorAC(1,2)) + Zu22 * PQx - QCPQy1 = ( Q(iEta,2) - CoorAC(2,2)) + Zu21 * PQy - QCPQy2 = ( Q(iEta,2) - CoorAC(2,2)) + Zu22 * PQy - QCPQz1 = ( Q(iEta,3) - CoorAC(3,2)) + Zu21 * PQz - QCPQz2 = ( Q(iEta,3) - CoorAC(3,2)) + Zu22 * PQz - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - B011 = (Half - Half * Zu21) * EInv(iEta) - B012 = (Half - Half * Zu22) * EInv(iEta) - x101= PAQPx1 - x102= PAQPx2 - x011= QCPQx1 - x012= QCPQx2 - x021= QCPQx1*x011 + B011 - x022= QCPQx2*x012 + B012 - x111= PAQPx1*QCPQx1 + B001 - x112= PAQPx2*QCPQx2 + B002 - x121= QCPQx1*x111 + B011*x101 + B001*x011 - x122= QCPQx2*x112 + B012*x102 + B002*x012 - y101= PAQPy1 - y102= PAQPy2 - y011= QCPQy1 - y012= QCPQy2 - y021= QCPQy1*y011 + B011 - y022= QCPQy2*y012 + B012 - y111= PAQPy1*QCPQy1 + B001 - y112= PAQPy2*QCPQy2 + B002 - y121= QCPQy1*y111 + B011*y101 + B001*y011 - y122= QCPQy2*y112 + B012*y102 + B002*y012 - z101= PAQPz1*w1 - z102= PAQPz2*w2 - z011= QCPQz1*w1 - z012= QCPQz2*w2 - z021= QCPQz1*z011 + B011*w1 - z022= QCPQz2*z012 + B012*w2 - z111= PAQPz1*QCPQz1*w1 + B001*w1 - z112= PAQPz2*QCPQz2*w2 + B002*w2 - z121= QCPQz1*z111 + B011*z101 + B001*z011 - z122= QCPQz2*z112 + B012*z102 + B002*z012 - EFInt(iZeta,iEta, 1)= x111*w1+ x112*w2 - EFInt(iZeta,iEta, 2)= y101*x011*w1+ y102*x012*w2 - EFInt(iZeta,iEta, 3)= z101*x011 + z102*x012 - EFInt(iZeta,iEta, 4)= x101*y011*w1+ x102*y012*w2 - EFInt(iZeta,iEta, 5)= y111*w1+ y112*w2 - EFInt(iZeta,iEta, 6)= (z101*y011) +(z102*y012) - EFInt(iZeta,iEta, 7)= (x101*z011) +(x102*z012) - EFInt(iZeta,iEta, 8)= (y101*z011) +(y102*z012) - EFInt(iZeta,iEta, 9)= z111 + z112 - EFInt(iZeta,iEta,10)= x121*w1+ x122*w2 - EFInt(iZeta,iEta,11)= y101*x021*w1+ y102*x022*w2 - EFInt(iZeta,iEta,12)= z101*x021 + z102*x022 - EFInt(iZeta,iEta,13)= x111*y011*w1+ x112*y012*w2 - EFInt(iZeta,iEta,14)= y111*x011*w1+ y112*x012*w2 - EFInt(iZeta,iEta,15)=x011*(z101*y011)+ x012*(z102*y012) - EFInt(iZeta,iEta,16)= x111*z011 + x112*z012 - EFInt(iZeta,iEta,17)=x011*(y101*z011)+ x012*(y102*z012) - EFInt(iZeta,iEta,18)= z111*x011 + z112*x012 - EFInt(iZeta,iEta,19)= x101*y021*w1+ x102*y022*w2 - EFInt(iZeta,iEta,20)= y121*w1+ y122*w2 - EFInt(iZeta,iEta,21)= z101*y021 + z102*y022 - EFInt(iZeta,iEta,22)=y011*(x101*z011)+y012*(x102*z012) - EFInt(iZeta,iEta,23)= y111*z011 + y112*z012 - EFInt(iZeta,iEta,24)= z111*y011 + z112*y012 - EFInt(iZeta,iEta,25)= x101*z021 + x102*z022 - EFInt(iZeta,iEta,26)= y101*z021 + y102*z022 - EFInt(iZeta,iEta,27)= z121 + z122 - 22 Continue - 12 Continue - Go To 99 -* -*-----ABCC case -* - 300 Continue - Do 13 iEta = 1, nEta - Do 23 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*DBLE(IsChi)) - rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) - PQx = P(iZeta,1)-CoorAC(1,2) - PQy = P(iZeta,2)-CoorAC(2,2) - PQz = P(iZeta,3)-CoorAC(3,2) - T = rho * (PQx**2 + PQy**2 + PQz**2) - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - w1 = PreFct*w1 - w2 = PreFct*w2 - Eu21 = Eta(iEta)*(r1*ZEInv) - Eu22 = Eta(iEta)*(r2*ZEInv) - Zu21 = Zeta(iZeta)*(r1*ZEInv) - Zu22 = Zeta(iZeta)*(r2*ZEInv) - PAQPx1 = (P(iZeta,1) - CoorAC(1,1)) - Eu21 * PQx - PAQPx2 = (P(iZeta,1) - CoorAC(1,1)) - Eu22 * PQx - PAQPy1 = (P(iZeta,2) - CoorAC(2,1)) - Eu21 * PQy - PAQPy2 = (P(iZeta,2) - CoorAC(2,1)) - Eu22 * PQy - PAQPz1 = (P(iZeta,3) - CoorAC(3,1)) - Eu21 * PQz - PAQPz2 = (P(iZeta,3) - CoorAC(3,1)) - Eu22 * PQz - QCPQx1 = Zu21 * PQx - QCPQx2 = Zu22 * PQx - QCPQy1 = Zu21 * PQy - QCPQy2 = Zu22 * PQy - QCPQz1 = Zu21 * PQz - QCPQz2 = Zu22 * PQz - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - B011 = (Half - Half * Zu21) * EInv(iEta) - B012 = (Half - Half * Zu22) * EInv(iEta) - x101= PAQPx1 - x102= PAQPx2 - x011= QCPQx1 - x012= QCPQx2 - x021= QCPQx1*x011 + B011 - x022= QCPQx2*x012 + B012 - x111= PAQPx1*QCPQx1 + B001 - x112= PAQPx2*QCPQx2 + B002 - x121= QCPQx1*x111 + B011*x101 + B001*x011 - x122= QCPQx2*x112 + B012*x102 + B002*x012 - y101= PAQPy1 - y102= PAQPy2 - y011= QCPQy1 - y012= QCPQy2 - y021= QCPQy1*y011 + B011 - y022= QCPQy2*y012 + B012 - y111= PAQPy1*QCPQy1 + B001 - y112= PAQPy2*QCPQy2 + B002 - y121= QCPQy1*y111 + B011*y101 + B001*y011 - y122= QCPQy2*y112 + B012*y102 + B002*y012 - z101= PAQPz1*w1 - z102= PAQPz2*w2 - z011= QCPQz1*w1 - z012= QCPQz2*w2 - z021= QCPQz1*z011 + B011*w1 - z022= QCPQz2*z012 + B012*w2 - z111= PAQPz1*QCPQz1*w1 + B001*w1 - z112= PAQPz2*QCPQz2*w2 + B002*w2 - z121= QCPQz1*z111 + B011*z101 + B001*z011 - z122= QCPQz2*z112 + B012*z102 + B002*z012 - EFInt(iZeta,iEta, 1)= x121*w1+ x122*w2 - EFInt(iZeta,iEta, 2)= y101*x021*w1+ y102*x022*w2 - EFInt(iZeta,iEta, 3)= z101*x021 + z102*x022 - EFInt(iZeta,iEta, 4)= x111*y011*w1+ x112*y012*w2 - EFInt(iZeta,iEta, 5)= y111*x011*w1+ y112*x012*w2 - EFInt(iZeta,iEta, 6)=x011*(z101*y011)+ x012*(z102*y012) - EFInt(iZeta,iEta, 7)= x111*z011 + x112*z012 - EFInt(iZeta,iEta, 8)=x011*(y101*z011)+ x012*(y102*z012) - EFInt(iZeta,iEta, 9)= z111*x011 + z112*x012 - EFInt(iZeta,iEta,10)= x101*y021*w1+ x102*y022*w2 - EFInt(iZeta,iEta,11)= y121*w1+ y122*w2 - EFInt(iZeta,iEta,12)= z101*y021 + z102*y022 - EFInt(iZeta,iEta,13)=y011*(x101*z011)+y012*(x102*z012) - EFInt(iZeta,iEta,14)= y111*z011 + y112*z012 - EFInt(iZeta,iEta,15)= z111*y011 + z112*y012 - EFInt(iZeta,iEta,16)= x101*z021 + x102*z022 - EFInt(iZeta,iEta,17)= y101*z021 + y102*z022 - EFInt(iZeta,iEta,18)= z121 + z122 - 23 Continue - 13 Continue - Go To 99 -* -*-----AACC case -* - 400 Continue - PQx = CoorAC(1,1)-CoorAC(1,2) - PQy = CoorAC(2,1)-CoorAC(2,2) - PQz = CoorAC(3,1)-CoorAC(3,2) - PQ2 = PQx**2 + PQy**2 + PQz**2 - Do 14 iEta = 1, nEta - Do 24 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*DBLE(IsChi)) - rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) - T = rho * PQ2 - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - w1 = PreFct*w1 - w2 = PreFct*w2 - Eu21 = Eta(iEta)*(r1*ZEInv) - Eu22 = Eta(iEta)*(r2*ZEInv) - Zu21 = Zeta(iZeta)*(r1*ZEInv) - Zu22 = Zeta(iZeta)*(r2*ZEInv) - PAQPx1 = - Eu21 * PQx - PAQPx2 = - Eu22 * PQx - PAQPy1 = - Eu21 * PQy - PAQPy2 = - Eu22 * PQy - PAQPz1 = - Eu21 * PQz - PAQPz2 = - Eu22 * PQz - QCPQx1 = Zu21 * PQx - QCPQx2 = Zu22 * PQx - QCPQy1 = Zu21 * PQy - QCPQy2 = Zu22 * PQy - QCPQz1 = Zu21 * PQz - QCPQz2 = Zu22 * PQz - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - B011 = (Half - Half * Zu21) * EInv(iEta) - B012 = (Half - Half * Zu22) * EInv(iEta) - x101= PAQPx1 - x102= PAQPx2 - x011= QCPQx1 - x012= QCPQx2 - x021= QCPQx1*x011 + B011 - x022= QCPQx2*x012 + B012 - x111= PAQPx1*QCPQx1 + B001 - x112= PAQPx2*QCPQx2 + B002 - x121= QCPQx1*x111 + B011*x101 + B001*x011 - x122= QCPQx2*x112 + B012*x102 + B002*x012 - y101= PAQPy1 - y102= PAQPy2 - y011= QCPQy1 - y012= QCPQy2 - y021= QCPQy1*y011 + B011 - y022= QCPQy2*y012 + B012 - y111= PAQPy1*QCPQy1 + B001 - y112= PAQPy2*QCPQy2 + B002 - y121= QCPQy1*y111 + B011*y101 + B001*y011 - y122= QCPQy2*y112 + B012*y102 + B002*y012 - z101= PAQPz1*w1 - z102= PAQPz2*w2 - z011= QCPQz1*w1 - z012= QCPQz2*w2 - z021= QCPQz1*z011 + B011*w1 - z022= QCPQz2*z012 + B012*w2 - z111= PAQPz1*QCPQz1*w1 + B001*w1 - z112= PAQPz2*QCPQz2*w2 + B002*w2 - z121= QCPQz1*z111 + B011*z101 + B001*z011 - z122= QCPQz2*z112 + B012*z102 + B002*z012 - EFInt(iZeta,iEta, 1)= x121*w1+ x122*w2 - EFInt(iZeta,iEta, 2)= y101*x021*w1+ y102*x022*w2 - EFInt(iZeta,iEta, 3)= z101*x021 + z102*x022 - EFInt(iZeta,iEta, 4)= x111*y011*w1+ x112*y012*w2 - EFInt(iZeta,iEta, 5)= y111*x011*w1+ y112*x012*w2 - EFInt(iZeta,iEta, 6)=x011*(z101*y011)+ x012*(z102*y012) - EFInt(iZeta,iEta, 7)= x111*z011 + x112*z012 - EFInt(iZeta,iEta, 8)=x011*(y101*z011)+ x012*(y102*z012) - EFInt(iZeta,iEta, 9)= z111*x011 + z112*x012 - EFInt(iZeta,iEta,10)= x101*y021*w1+ x102*y022*w2 - EFInt(iZeta,iEta,11)= y121*w1+ y122*w2 - EFInt(iZeta,iEta,12)= z101*y021 + z102*y022 - EFInt(iZeta,iEta,13)=y011*(x101*z011)+y012*(x102*z012) - EFInt(iZeta,iEta,14)= y111*z011 + y112*z012 - EFInt(iZeta,iEta,15)= z111*y011 + z112*y012 - EFInt(iZeta,iEta,16)= x101*z021 + x102*z022 - EFInt(iZeta,iEta,17)= y101*z021 + y102*z022 - EFInt(iZeta,iEta,18)= z121 + z122 - 24 Continue - 14 Continue -* - 99 Continue -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_real_array(ZInv) - End diff -Nru openmolcas-22.02/src/rys_util/sppp.F90 openmolcas-22.10/src/rys_util/sppp.F90 --- openmolcas-22.02/src/rys_util/sppp.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/sppp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,475 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1994, Roland Lindh * +!*********************************************************************** + +subroutine sppp(EFInt,Zeta,ZInv,nZeta,P,lP,rKappAB,A,B,Eta,EInv,nEta,Q,lQ,rKappCD,C,D,CoorAC,TMax,iPntr,nPntr,x0,nMax,CW6,CW5,CW4, & + CW3,CW2,CW1,CW0,CR6,CR5,CR4,CR3,CR2,CR1,CR0,ddx,HerW,HerR2,IsChi,ChiI2) +!*********************************************************************** +! * +! Object: to compute the primitive integrals of type (sp|pp). * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. 1994 * +!*********************************************************************** + +use Constants, only: One, Ten, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, lP, nEta, lQ, nPntr, iPntr(nPntr), nMax, IsChi +real(kind=wp), intent(out) :: EFInt(nZeta,nEta,27) +real(kind=wp), intent(in) :: Zeta(nZeta), ZInv(nZeta), P(lP,3), rKappAB(nZeta), A(3), B(3), Eta(nEta), EInv(nEta), Q(lQ,3), & + rKappCD(nEta), C(3), D(3), CoorAC(3,2), TMax, x0(nMax), CW6(nMax,2), CW5(nMax,2), CW4(nMax,2), & + CW3(nMax,2), CW2(nMax,2), CW1(nMax,2), CW0(nMax,2), CR6(nMax,2), CR5(nMax,2), CR4(nMax,2), & + CR3(nMax,2), CR2(nMax,2), CR1(nMax,2), CR0(nMax,2), ddx, HerW(2), HerR2(2), ChiI2 +integer(kind=iwp) :: iEta, iZeta, n +real(kind=wp) :: ai, B001, B002, B011, B012, dddx, Eu21, Eu22, PAQPx1, PAQPx2, PAQPy1, PAQPy2, PAQPz1, PAQPz2, PQ2, PQx, PQy, PQz, & + PreFct, QCPQx1, QCPQx2, QCPQy1, QCPQy2, QCPQz1, QCPQz2, r1, r2, rho, si, T, w1, w2, x011, x012, x021, x022, x101, & + x102, x111, x112, x121, x122, xdInv, y011, y012, y021, y022, y101, y102, y111, y112, y121, y122, z, z011, z012, & + z021, z022, z101, z102, z111, z112, z121, z122, ZEInv, Zu21, Zu22 +logical(kind=iwp), external :: EQ + +#include "macros.fh" +unused_var(ZInv) + +xdInv = One/ddx +dddx = ddx/Ten+ddx + +if (EQ(A,B) .and. (.not. EQ(C,D))) then + + ! AACD case + + do iEta=1,nEta + do iZeta=1,nZeta + PQx = CoorAC(1,1)-Q(iEta,1) + PQy = CoorAC(2,1)-Q(iEta,2) + PQz = CoorAC(3,1)-Q(iEta,3) + PQ2 = PQx**2+PQy**2+PQz**2 + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) + T = rho*PQ2 + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + w1 = PreFct*w1 + w2 = PreFct*w2 + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + PAQPx1 = -Eu21*PQx + PAQPx2 = -Eu22*PQx + PAQPy1 = -Eu21*PQy + PAQPy2 = -Eu22*PQy + PAQPz1 = -Eu21*PQz + PAQPz2 = -Eu22*PQz + QCPQx1 = (Q(iEta,1)-CoorAC(1,2))+Zu21*PQx + QCPQx2 = (Q(iEta,1)-CoorAC(1,2))+Zu22*PQx + QCPQy1 = (Q(iEta,2)-CoorAC(2,2))+Zu21*PQy + QCPQy2 = (Q(iEta,2)-CoorAC(2,2))+Zu22*PQy + QCPQz1 = (Q(iEta,3)-CoorAC(3,2))+Zu21*PQz + QCPQz2 = (Q(iEta,3)-CoorAC(3,2))+Zu22*PQz + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + B011 = (Half-Half*Zu21)*EInv(iEta) + B012 = (Half-Half*Zu22)*EInv(iEta) + x101 = PAQPx1 + x102 = PAQPx2 + x011 = QCPQx1 + x012 = QCPQx2 + x021 = QCPQx1*x011+B011 + x022 = QCPQx2*x012+B012 + x111 = PAQPx1*QCPQx1+B001 + x112 = PAQPx2*QCPQx2+B002 + x121 = QCPQx1*x111+B011*x101+B001*x011 + x122 = QCPQx2*x112+B012*x102+B002*x012 + y101 = PAQPy1 + y102 = PAQPy2 + y011 = QCPQy1 + y012 = QCPQy2 + y021 = QCPQy1*y011+B011 + y022 = QCPQy2*y012+B012 + y111 = PAQPy1*QCPQy1+B001 + y112 = PAQPy2*QCPQy2+B002 + y121 = QCPQy1*y111+B011*y101+B001*y011 + y122 = QCPQy2*y112+B012*y102+B002*y012 + z101 = PAQPz1*w1 + z102 = PAQPz2*w2 + z011 = QCPQz1*w1 + z012 = QCPQz2*w2 + z021 = QCPQz1*z011+B011*w1 + z022 = QCPQz2*z012+B012*w2 + z111 = PAQPz1*QCPQz1*w1+B001*w1 + z112 = PAQPz2*QCPQz2*w2+B002*w2 + z121 = QCPQz1*z111+B011*z101+B001*z011 + z122 = QCPQz2*z112+B012*z102+B002*z012 + EFInt(iZeta,iEta,1) = x111*w1+x112*w2 + EFInt(iZeta,iEta,2) = y101*x011*w1+y102*x012*w2 + EFInt(iZeta,iEta,3) = z101*x011+z102*x012 + EFInt(iZeta,iEta,4) = x101*y011*w1+x102*y012*w2 + EFInt(iZeta,iEta,5) = y111*w1+y112*w2 + EFInt(iZeta,iEta,6) = (z101*y011)+(z102*y012) + EFInt(iZeta,iEta,7) = (x101*z011)+(x102*z012) + EFInt(iZeta,iEta,8) = (y101*z011)+(y102*z012) + EFInt(iZeta,iEta,9) = z111+z112 + EFInt(iZeta,iEta,10) = x121*w1+x122*w2 + EFInt(iZeta,iEta,11) = y101*x021*w1+y102*x022*w2 + EFInt(iZeta,iEta,12) = z101*x021+z102*x022 + EFInt(iZeta,iEta,13) = x111*y011*w1+x112*y012*w2 + EFInt(iZeta,iEta,14) = y111*x011*w1+y112*x012*w2 + EFInt(iZeta,iEta,15) = x011*(z101*y011)+x012*(z102*y012) + EFInt(iZeta,iEta,16) = x111*z011+x112*z012 + EFInt(iZeta,iEta,17) = x011*(y101*z011)+x012*(y102*z012) + EFInt(iZeta,iEta,18) = z111*x011+z112*x012 + EFInt(iZeta,iEta,19) = x101*y021*w1+x102*y022*w2 + EFInt(iZeta,iEta,20) = y121*w1+y122*w2 + EFInt(iZeta,iEta,21) = z101*y021+z102*y022 + EFInt(iZeta,iEta,22) = y011*(x101*z011)+y012*(x102*z012) + EFInt(iZeta,iEta,23) = y111*z011+y112*z012 + EFInt(iZeta,iEta,24) = z111*y011+z112*y012 + EFInt(iZeta,iEta,25) = x101*z021+x102*z022 + EFInt(iZeta,iEta,26) = y101*z021+y102*z022 + EFInt(iZeta,iEta,27) = z121+z122 + end do + end do + +else if ((.not. EQ(A,B)) .and. EQ(C,D)) then + + ! ABCC case + + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) + PQx = P(iZeta,1)-CoorAC(1,2) + PQy = P(iZeta,2)-CoorAC(2,2) + PQz = P(iZeta,3)-CoorAC(3,2) + T = rho*(PQx**2+PQy**2+PQz**2) + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + w1 = PreFct*w1 + w2 = PreFct*w2 + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + PAQPx1 = (P(iZeta,1)-CoorAC(1,1))-Eu21*PQx + PAQPx2 = (P(iZeta,1)-CoorAC(1,1))-Eu22*PQx + PAQPy1 = (P(iZeta,2)-CoorAC(2,1))-Eu21*PQy + PAQPy2 = (P(iZeta,2)-CoorAC(2,1))-Eu22*PQy + PAQPz1 = (P(iZeta,3)-CoorAC(3,1))-Eu21*PQz + PAQPz2 = (P(iZeta,3)-CoorAC(3,1))-Eu22*PQz + QCPQx1 = Zu21*PQx + QCPQx2 = Zu22*PQx + QCPQy1 = Zu21*PQy + QCPQy2 = Zu22*PQy + QCPQz1 = Zu21*PQz + QCPQz2 = Zu22*PQz + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + B011 = (Half-Half*Zu21)*EInv(iEta) + B012 = (Half-Half*Zu22)*EInv(iEta) + x101 = PAQPx1 + x102 = PAQPx2 + x011 = QCPQx1 + x012 = QCPQx2 + x021 = QCPQx1*x011+B011 + x022 = QCPQx2*x012+B012 + x111 = PAQPx1*QCPQx1+B001 + x112 = PAQPx2*QCPQx2+B002 + x121 = QCPQx1*x111+B011*x101+B001*x011 + x122 = QCPQx2*x112+B012*x102+B002*x012 + y101 = PAQPy1 + y102 = PAQPy2 + y011 = QCPQy1 + y012 = QCPQy2 + y021 = QCPQy1*y011+B011 + y022 = QCPQy2*y012+B012 + y111 = PAQPy1*QCPQy1+B001 + y112 = PAQPy2*QCPQy2+B002 + y121 = QCPQy1*y111+B011*y101+B001*y011 + y122 = QCPQy2*y112+B012*y102+B002*y012 + z101 = PAQPz1*w1 + z102 = PAQPz2*w2 + z011 = QCPQz1*w1 + z012 = QCPQz2*w2 + z021 = QCPQz1*z011+B011*w1 + z022 = QCPQz2*z012+B012*w2 + z111 = PAQPz1*QCPQz1*w1+B001*w1 + z112 = PAQPz2*QCPQz2*w2+B002*w2 + z121 = QCPQz1*z111+B011*z101+B001*z011 + z122 = QCPQz2*z112+B012*z102+B002*z012 + EFInt(iZeta,iEta,1) = x121*w1+x122*w2 + EFInt(iZeta,iEta,2) = y101*x021*w1+y102*x022*w2 + EFInt(iZeta,iEta,3) = z101*x021+z102*x022 + EFInt(iZeta,iEta,4) = x111*y011*w1+x112*y012*w2 + EFInt(iZeta,iEta,5) = y111*x011*w1+y112*x012*w2 + EFInt(iZeta,iEta,6) = x011*(z101*y011)+x012*(z102*y012) + EFInt(iZeta,iEta,7) = x111*z011+x112*z012 + EFInt(iZeta,iEta,8) = x011*(y101*z011)+x012*(y102*z012) + EFInt(iZeta,iEta,9) = z111*x011+z112*x012 + EFInt(iZeta,iEta,10) = x101*y021*w1+x102*y022*w2 + EFInt(iZeta,iEta,11) = y121*w1+y122*w2 + EFInt(iZeta,iEta,12) = z101*y021+z102*y022 + EFInt(iZeta,iEta,13) = y011*(x101*z011)+y012*(x102*z012) + EFInt(iZeta,iEta,14) = y111*z011+y112*z012 + EFInt(iZeta,iEta,15) = z111*y011+z112*y012 + EFInt(iZeta,iEta,16) = x101*z021+x102*z022 + EFInt(iZeta,iEta,17) = y101*z021+y102*z022 + EFInt(iZeta,iEta,18) = z121+z122 + end do + end do + +else if (EQ(A,B) .and. EQ(C,D)) then + + ! AACC case + + PQx = CoorAC(1,1)-CoorAC(1,2) + PQy = CoorAC(2,1)-CoorAC(2,2) + PQz = CoorAC(3,1)-CoorAC(3,2) + PQ2 = PQx**2+PQy**2+PQz**2 + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) + T = rho*PQ2 + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + w1 = PreFct*w1 + w2 = PreFct*w2 + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + PAQPx1 = -Eu21*PQx + PAQPx2 = -Eu22*PQx + PAQPy1 = -Eu21*PQy + PAQPy2 = -Eu22*PQy + PAQPz1 = -Eu21*PQz + PAQPz2 = -Eu22*PQz + QCPQx1 = Zu21*PQx + QCPQx2 = Zu22*PQx + QCPQy1 = Zu21*PQy + QCPQy2 = Zu22*PQy + QCPQz1 = Zu21*PQz + QCPQz2 = Zu22*PQz + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + B011 = (Half-Half*Zu21)*EInv(iEta) + B012 = (Half-Half*Zu22)*EInv(iEta) + x101 = PAQPx1 + x102 = PAQPx2 + x011 = QCPQx1 + x012 = QCPQx2 + x021 = QCPQx1*x011+B011 + x022 = QCPQx2*x012+B012 + x111 = PAQPx1*QCPQx1+B001 + x112 = PAQPx2*QCPQx2+B002 + x121 = QCPQx1*x111+B011*x101+B001*x011 + x122 = QCPQx2*x112+B012*x102+B002*x012 + y101 = PAQPy1 + y102 = PAQPy2 + y011 = QCPQy1 + y012 = QCPQy2 + y021 = QCPQy1*y011+B011 + y022 = QCPQy2*y012+B012 + y111 = PAQPy1*QCPQy1+B001 + y112 = PAQPy2*QCPQy2+B002 + y121 = QCPQy1*y111+B011*y101+B001*y011 + y122 = QCPQy2*y112+B012*y102+B002*y012 + z101 = PAQPz1*w1 + z102 = PAQPz2*w2 + z011 = QCPQz1*w1 + z012 = QCPQz2*w2 + z021 = QCPQz1*z011+B011*w1 + z022 = QCPQz2*z012+B012*w2 + z111 = PAQPz1*QCPQz1*w1+B001*w1 + z112 = PAQPz2*QCPQz2*w2+B002*w2 + z121 = QCPQz1*z111+B011*z101+B001*z011 + z122 = QCPQz2*z112+B012*z102+B002*z012 + EFInt(iZeta,iEta,1) = x121*w1+x122*w2 + EFInt(iZeta,iEta,2) = y101*x021*w1+y102*x022*w2 + EFInt(iZeta,iEta,3) = z101*x021+z102*x022 + EFInt(iZeta,iEta,4) = x111*y011*w1+x112*y012*w2 + EFInt(iZeta,iEta,5) = y111*x011*w1+y112*x012*w2 + EFInt(iZeta,iEta,6) = x011*(z101*y011)+x012*(z102*y012) + EFInt(iZeta,iEta,7) = x111*z011+x112*z012 + EFInt(iZeta,iEta,8) = x011*(y101*z011)+x012*(y102*z012) + EFInt(iZeta,iEta,9) = z111*x011+z112*x012 + EFInt(iZeta,iEta,10) = x101*y021*w1+x102*y022*w2 + EFInt(iZeta,iEta,11) = y121*w1+y122*w2 + EFInt(iZeta,iEta,12) = z101*y021+z102*y022 + EFInt(iZeta,iEta,13) = y011*(x101*z011)+y012*(x102*z012) + EFInt(iZeta,iEta,14) = y111*z011+y112*z012 + EFInt(iZeta,iEta,15) = z111*y011+z112*y012 + EFInt(iZeta,iEta,16) = x101*z021+x102*z022 + EFInt(iZeta,iEta,17) = y101*z021+y102*z022 + EFInt(iZeta,iEta,18) = z121+z122 + end do + end do + +else + + ! ABCD case + + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*(Eta(iEta)*ZEInv) + PQx = P(iZeta,1)-Q(iEta,1) + PQy = P(iZeta,2)-Q(iEta,2) + PQz = P(iZeta,3)-Q(iEta,3) + T = rho*(PQx**2+PQy**2+PQz**2) + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + w1 = PreFct*w1 + w2 = PreFct*w2 + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + PAQPx1 = (P(iZeta,1)-CoorAC(1,1))-Eu21*PQx + PAQPx2 = (P(iZeta,1)-CoorAC(1,1))-Eu22*PQx + PAQPy1 = (P(iZeta,2)-CoorAC(2,1))-Eu21*PQy + PAQPy2 = (P(iZeta,2)-CoorAC(2,1))-Eu22*PQy + PAQPz1 = (P(iZeta,3)-CoorAC(3,1))-Eu21*PQz + PAQPz2 = (P(iZeta,3)-CoorAC(3,1))-Eu22*PQz + QCPQx1 = (Q(iEta,1)-CoorAC(1,2))+Zu21*PQx + QCPQx2 = (Q(iEta,1)-CoorAC(1,2))+Zu22*PQx + QCPQy1 = (Q(iEta,2)-CoorAC(2,2))+Zu21*PQy + QCPQy2 = (Q(iEta,2)-CoorAC(2,2))+Zu22*PQy + QCPQz1 = (Q(iEta,3)-CoorAC(3,2))+Zu21*PQz + QCPQz2 = (Q(iEta,3)-CoorAC(3,2))+Zu22*PQz + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + B011 = (Half-Half*Zu21)*EInv(iEta) + B012 = (Half-Half*Zu22)*EInv(iEta) + x101 = PAQPx1 + x102 = PAQPx2 + x011 = QCPQx1 + x012 = QCPQx2 + x021 = QCPQx1*x011+B011 + x022 = QCPQx2*x012+B012 + x111 = PAQPx1*QCPQx1+B001 + x112 = PAQPx2*QCPQx2+B002 + x121 = QCPQx1*x111+B011*x101+B001*x011 + x122 = QCPQx2*x112+B012*x102+B002*x012 + y101 = PAQPy1 + y102 = PAQPy2 + y011 = QCPQy1 + y012 = QCPQy2 + y021 = QCPQy1*y011+B011 + y022 = QCPQy2*y012+B012 + y111 = PAQPy1*QCPQy1+B001 + y112 = PAQPy2*QCPQy2+B002 + y121 = QCPQy1*y111+B011*y101+B001*y011 + y122 = QCPQy2*y112+B012*y102+B002*y012 + z101 = PAQPz1*w1 + z102 = PAQPz2*w2 + z011 = QCPQz1*w1 + z012 = QCPQz2*w2 + z021 = QCPQz1*z011+B011*w1 + z022 = QCPQz2*z012+B012*w2 + z111 = PAQPz1*QCPQz1*w1+B001*w1 + z112 = PAQPz2*QCPQz2*w2+B002*w2 + z121 = QCPQz1*z111+B011*z101+B001*z011 + z122 = QCPQz2*z112+B012*z102+B002*z012 + EFInt(iZeta,iEta,1) = x111*w1+x112*w2 + EFInt(iZeta,iEta,2) = y101*x011*w1+y102*x012*w2 + EFInt(iZeta,iEta,3) = z101*x011+z102*x012 + EFInt(iZeta,iEta,4) = x101*y011*w1+x102*y012*w2 + EFInt(iZeta,iEta,5) = y111*w1+y112*w2 + EFInt(iZeta,iEta,6) = (z101*y011)+(z102*y012) + EFInt(iZeta,iEta,7) = (x101*z011)+(x102*z012) + EFInt(iZeta,iEta,8) = (y101*z011)+(y102*z012) + EFInt(iZeta,iEta,9) = z111+z112 + EFInt(iZeta,iEta,10) = x121*w1+x122*w2 + EFInt(iZeta,iEta,11) = y101*x021*w1+y102*x022*w2 + EFInt(iZeta,iEta,12) = z101*x021+z102*x022 + EFInt(iZeta,iEta,13) = x111*y011*w1+x112*y012*w2 + EFInt(iZeta,iEta,14) = y111*x011*w1+y112*x012*w2 + EFInt(iZeta,iEta,15) = x011*(z101*y011)+x012*(z102*y012) + EFInt(iZeta,iEta,16) = x111*z011+x112*z012 + EFInt(iZeta,iEta,17) = x011*(y101*z011)+x012*(y102*z012) + EFInt(iZeta,iEta,18) = z111*x011+z112*x012 + EFInt(iZeta,iEta,19) = x101*y021*w1+x102*y022*w2 + EFInt(iZeta,iEta,20) = y121*w1+y122*w2 + EFInt(iZeta,iEta,21) = z101*y021+z102*y022 + EFInt(iZeta,iEta,22) = y011*(x101*z011)+y012*(x102*z012) + EFInt(iZeta,iEta,23) = y111*z011+y112*z012 + EFInt(iZeta,iEta,24) = z111*y011+z112*y012 + EFInt(iZeta,iEta,25) = x101*z021+x102*z022 + EFInt(iZeta,iEta,26) = y101*z021+y102*z022 + EFInt(iZeta,iEta,27) = z121+z122 + end do + end do + +end if + +return + +end subroutine sppp diff -Nru openmolcas-22.02/src/rys_util/spsp.f openmolcas-22.10/src/rys_util/spsp.f --- openmolcas-22.02/src/rys_util/spsp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/spsp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,410 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1994, Roland Lindh * -************************************************************************ - Subroutine spsp(EFInt,Zeta,nZeta,P,lP,rKappAB,A,B, - & Eta, nEta,Q,lQ,rKappCD,C,D, - & CoorAC,TMax, - & iPntr,nPntr,x0,nMax,CW6,CW5,CW4,CW3,CW2,CW1,CW0, - & CR6,CR5,CR4,CR3,CR2,CR1,CR0, - & ddx,HerW,HerR2,IsChi,ChiI2) -************************************************************************ -* * -* Object: to compute the primitive integrals of type (sp|sp). * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. 1994 * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 EFInt(nZeta,nEta,3,3), Zeta(nZeta), Eta(nEta), - & CoorAC(3,2), - & P(lP,3), Q(lQ,3), A(3), B(3), C(3), D(3), - & rKappAB(nZeta), rKappCD(nEta), - & x0(nMax), - & CW6(nMax,2), CW5(nMax,2), CW4(nMax,2), CW3(nMax,2), - & CW2(nMax,2), CW1(nMax,2), CW0(nMax,2), - & CR6(nMax,2), CR5(nMax,2), CR4(nMax,2), CR3(nMax,2), - & CR2(nMax,2), CR1(nMax,2), CR0(nMax,2), - & HerW(2), HerR2(2) - Integer iPntr(nPntr) - Logical ABeqCD, EQ -* -* - xdInv=One/ddx - dddx = ddx/10 + ddx -* - ABeqCD = EQ(A,B) .and. EQ(A,C) .and. EQ(A,D) - If ( ABeqCD ) Go To 100 - If ( EQ(A,B).and..Not.EQ(C,D)) Go To 200 - If (.Not.EQ(A,B).and. EQ(C,D)) Go To 300 - If ( EQ(A,B).and. EQ(C,D)) Go To 400 -* -*-----ABCD case -* - Do 10 iEta = 1, nEta - Do 20 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*IsChi) - rho = Zeta(iZeta)*Eta(iEta)*ZEInv - PQx = P(iZeta,1)-Q(iEta,1) - PQy = P(iZeta,2)-Q(iEta,2) - PQz = P(iZeta,3)-Q(iEta,3) - T = rho * (PQx**2 + PQy**2 + PQz**2) - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - Eu21 = Eta(iEta) * (r1*ZEInv) - Eu22 = Eta(iEta) * (r2*ZEInv) - Zu21 = Zeta(iZeta) * (r1*ZEInv) - Zu22 = Zeta(iZeta) * (r2*ZEInv) - PAQPx1 = (P(iZeta,1) - CoorAC(1,1)) - Eu21 * PQx - PAQPx2 = (P(iZeta,1) - CoorAC(1,1)) - Eu22 * PQx - PAQPy1 = (P(iZeta,2) - CoorAC(2,1)) - Eu21 * PQy - PAQPy2 = (P(iZeta,2) - CoorAC(2,1)) - Eu22 * PQy - PAQPz1 = (P(iZeta,3) - CoorAC(3,1)) - Eu21 * PQz - PAQPz2 = (P(iZeta,3) - CoorAC(3,1)) - Eu22 * PQz - QCPQx1 = (Q(iEta,1) - CoorAC(1,2)) + Zu21 * PQx - QCPQx2 = (Q(iEta,1) - CoorAC(1,2)) + Zu22 * PQx - QCPQy1 = (Q(iEta,2) - CoorAC(2,2)) + Zu21 * PQy - QCPQy2 = (Q(iEta,2) - CoorAC(2,2)) + Zu22 * PQy - QCPQz1 = (Q(iEta,3) - CoorAC(3,2)) + Zu21 * PQz - QCPQz2 = (Q(iEta,3) - CoorAC(3,2)) + Zu22 * PQz - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - x101= PAQPx1 - x011= QCPQx1 - x111= PAQPx1*QCPQx1 + B001 - x102= PAQPx2 - x012= QCPQx2 - x112= PAQPx2*QCPQx2 + B002 - y101= PAQPy1 - y011= QCPQy1 - y111= PAQPy1*QCPQy1 + B001 - y102= PAQPy2 - y012= QCPQy2 - y112= PAQPy2*QCPQy2 + B002 - z101= PAQPz1 - z011= QCPQz1 - z111= PAQPz1*QCPQz1 + B001 - z102= PAQPz2 - z012= QCPQz2 - z112= PAQPz2*QCPQz2 + B002 - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - EFInt(iZeta,iEta,1,1) = PreFct * (x111 *w1+x112 *w2) - EFInt(iZeta,iEta,2,1) = PreFct * (x101*y011*w1+x102*y012*w2) - EFInt(iZeta,iEta,3,1) = PreFct * (x101*z011*w1+x102*z012*w2) - EFInt(iZeta,iEta,1,2) = PreFct * (y101*x011*w1+y102*x012*w2) - EFInt(iZeta,iEta,2,2) = PreFct * (y111 *w1 + y112 *w2) - EFInt(iZeta,iEta,3,2) = PreFct * (y101*z011*w1+y102*z012*w2) - EFInt(iZeta,iEta,1,3) = PreFct * (z101*x011*w1+z102*x012*w2) - EFInt(iZeta,iEta,2,3) = PreFct * (z101*y011*w1+z102*y012*w2) - EFInt(iZeta,iEta,3,3) = PreFct * (z111 *w1 + z112 *w2) - 20 Continue - 10 Continue - Go To 99 -* -*-----AAAA case -* - 100 Continue - z = - x0(1) - w1=(((((CW6(1,1)*z+CW5(1,1))*z+CW4(1,1))*z+CW3(1,1))*z+ - & CW2(1,1))*z+CW1(1,1))*z+Cw0(1,1) - w2=(((((CW6(1,2)*z+CW5(1,2))*z+CW4(1,2))*z+CW3(1,2))*z+ - & CW2(1,2))*z+CW1(1,2))*z+Cw0(1,2) - r1=(((((CR6(1,1)*z+CR5(1,1))*z+CR4(1,1))*z+CR3(1,1))*z+ - & CR2(1,1))*z+CR1(1,1))*z+CR0(1,1) - r2=(((((CR6(1,2)*z+CR5(1,2))*z+CR4(1,2))*z+CR3(1,2))*z+ - & CR2(1,2))*z+CR1(1,2))*z+CR0(1,2) - Do 11 iEta = 1, nEta - Do 21 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > + (Eta(iEta)*Zeta(iZeta)*ChiI2)*IsChi) - B001 = w1* Half * (r1*ZEInv) - B002 = w2* Half * (r2*ZEInv) - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - EFInt(iZeta,iEta,1,1) = (PreFct * (B001+B002)) - EFInt(iZeta,iEta,2,1) = Zero - EFInt(iZeta,iEta,3,1) = Zero - EFInt(iZeta,iEta,1,2) = Zero - EFInt(iZeta,iEta,2,2) = (PreFct * (B001+B002)) - EFInt(iZeta,iEta,3,2) = Zero - EFInt(iZeta,iEta,1,3) = Zero - EFInt(iZeta,iEta,2,3) = Zero - EFInt(iZeta,iEta,3,3) = (PreFct * (B001+B002)) - 21 Continue - 11 Continue - Go To 99 -* -*-----AACD case -* - 200 Continue - Do 12 iEta = 1, nEta - Do 22 iZeta = 1, nZeta - PQx = CoorAC(1,1)-Q(iEta,1) - PQy = CoorAC(2,1)-Q(iEta,2) - PQz = CoorAC(3,1)-Q(iEta,3) - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*IsChi) - rho = Zeta(iZeta)*Eta(iEta)*ZEInv - T = rho * (PQx**2 + PQy**2 + PQz**2) - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - Eu21 = Eta(iEta) * (r1*ZEInv) - Eu22 = Eta(iEta) * (r2*ZEInv) - Zu21 = Zeta(iZeta) * (r1*ZEInv) - Zu22 = Zeta(iZeta) * (r2*ZEInv) - PAQPx1 = - Eu21 * PQx - PAQPx2 = - Eu22 * PQx - PAQPy1 = - Eu21 * PQy - PAQPy2 = - Eu22 * PQy - PAQPz1 = - Eu21 * PQz - PAQPz2 = - Eu22 * PQz - QCPQx1 = (Q(iEta,1) - CoorAC(1,2)) + Zu21 * PQx - QCPQx2 = (Q(iEta,1) - CoorAC(1,2)) + Zu22 * PQx - QCPQy1 = (Q(iEta,2) - CoorAC(2,2)) + Zu21 * PQy - QCPQy2 = (Q(iEta,2) - CoorAC(2,2)) + Zu22 * PQy - QCPQz1 = (Q(iEta,3) - CoorAC(3,2)) + Zu21 * PQz - QCPQz2 = (Q(iEta,3) - CoorAC(3,2)) + Zu22 * PQz - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - x101= PAQPx1 - x011= QCPQx1 - x111= PAQPx1*QCPQx1 + B001 - x102= PAQPx2 - x012= QCPQx2 - x112= PAQPx2*QCPQx2 + B002 - y101= PAQPy1 - y011= QCPQy1 - y111= PAQPy1*QCPQy1 + B001 - y102= PAQPy2 - y012= QCPQy2 - y112= PAQPy2*QCPQy2 + B002 - z101= PAQPz1 - z011= QCPQz1 - z111= PAQPz1*QCPQz1 + B001 - z102= PAQPz2 - z012= QCPQz2 - z112= PAQPz2*QCPQz2 + B002 - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - EFInt(iZeta,iEta,1,1) = PreFct * (x111 *w1+x112 *w2) - EFInt(iZeta,iEta,2,1) = PreFct * (x101*y011*w1+x102*y012*w2) - EFInt(iZeta,iEta,3,1) = PreFct * (x101*z011*w1+x102*z012*w2) - EFInt(iZeta,iEta,1,2) = PreFct * (y101*x011*w1+y102*x012*w2) - EFInt(iZeta,iEta,2,2) = PreFct * (y111 *w1 + y112 *w2) - EFInt(iZeta,iEta,3,2) = PreFct * (y101*z011*w1+y102*z012*w2) - EFInt(iZeta,iEta,1,3) = PreFct * (z101*x011*w1+z102*x012*w2) - EFInt(iZeta,iEta,2,3) = PreFct * (z101*y011*w1+z102*y012*w2) - EFInt(iZeta,iEta,3,3) = PreFct * (z111 *w1 + z112 *w2) - 22 Continue - 12 Continue - Go To 99 -* -*-----ABCC case -* - 300 Continue - Do 13 iEta = 1, nEta - Do 23 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*IsChi) - rho = Zeta(iZeta)*Eta(iEta)*ZEInv - PQx = P(iZeta,1)-CoorAC(1,2) - PQy = P(iZeta,2)-CoorAC(2,2) - PQz = P(iZeta,3)-CoorAC(3,2) - T = rho * (PQx**2 + PQy**2 + PQz**2) - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - Eu21 = Eta(iEta) * (r1*ZEInv) - Eu22 = Eta(iEta) * (r2*ZEInv) - Zu21 = Zeta(iZeta) * (r1*ZEInv) - Zu22 = Zeta(iZeta) * (r2*ZEInv) - PAQPx1 = (P(iZeta,1) - CoorAC(1,1)) - Eu21 * PQx - PAQPx2 = (P(iZeta,1) - CoorAC(1,1)) - Eu22 * PQx - PAQPy1 = (P(iZeta,2) - CoorAC(2,1)) - Eu21 * PQy - PAQPy2 = (P(iZeta,2) - CoorAC(2,1)) - Eu22 * PQy - PAQPz1 = (P(iZeta,3) - CoorAC(3,1)) - Eu21 * PQz - PAQPz2 = (P(iZeta,3) - CoorAC(3,1)) - Eu22 * PQz - QCPQx1 = Zu21 * PQx - QCPQx2 = Zu22 * PQx - QCPQy1 = Zu21 * PQy - QCPQy2 = Zu22 * PQy - QCPQz1 = Zu21 * PQz - QCPQz2 = Zu22 * PQz - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - x101= PAQPx1 - x011= QCPQx1 - x111= PAQPx1*QCPQx1 + B001 - x102= PAQPx2 - x012= QCPQx2 - x112= PAQPx2*QCPQx2 + B002 - y101= PAQPy1 - y011= QCPQy1 - y111= PAQPy1*QCPQy1 + B001 - y102= PAQPy2 - y012= QCPQy2 - y112= PAQPy2*QCPQy2 + B002 - z101= PAQPz1 - z011= QCPQz1 - z111= PAQPz1*QCPQz1 + B001 - z102= PAQPz2 - z012= QCPQz2 - z112= PAQPz2*QCPQz2 + B002 - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - EFInt(iZeta,iEta,1,1) = PreFct * (x111 *w1+x112 *w2) - EFInt(iZeta,iEta,2,1) = PreFct * (x101*y011*w1+x102*y012*w2) - EFInt(iZeta,iEta,3,1) = PreFct * (x101*z011*w1+x102*z012*w2) - EFInt(iZeta,iEta,1,2) = PreFct * (y101*x011*w1+y102*x012*w2) - EFInt(iZeta,iEta,2,2) = PreFct * (y111 *w1 + y112 *w2) - EFInt(iZeta,iEta,3,2) = PreFct * (y101*z011*w1+y102*z012*w2) - EFInt(iZeta,iEta,1,3) = PreFct * (z101*x011*w1+z102*x012*w2) - EFInt(iZeta,iEta,2,3) = PreFct * (z101*y011*w1+z102*y012*w2) - EFInt(iZeta,iEta,3,3) = PreFct * (z111 *w1 + z112 *w2) - 23 Continue - 13 Continue - Go To 99 -* -*-----AACC case -* - 400 Continue - PQx = CoorAC(1,1)-CoorAC(1,2) - PQy = CoorAC(2,1)-CoorAC(2,2) - PQz = CoorAC(3,1)-CoorAC(3,2) - PQ2 = (PQx**2 + PQy**2 + PQz**2) - Do 14 iEta = 1, nEta - Do 24 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*IsChi) - rho = Zeta(iZeta)*Eta(iEta)*ZEInv - T = rho * PQ2 - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - Eu21 = Eta(iEta) * (r1*ZEInv) - Eu22 = Eta(iEta) * (r2*ZEInv) - Zu21 = Zeta(iZeta) * (r1*ZEInv) - Zu22 = Zeta(iZeta) * (r2*ZEInv) - PAQPx1 = - Eu21 * PQx - PAQPx2 = - Eu22 * PQx - PAQPy1 = - Eu21 * PQy - PAQPy2 = - Eu22 * PQy - PAQPz1 = - Eu21 * PQz - PAQPz2 = - Eu22 * PQz - QCPQx1 = Zu21 * PQx - QCPQx2 = Zu22 * PQx - QCPQy1 = Zu21 * PQy - QCPQy2 = Zu22 * PQy - QCPQz1 = Zu21 * PQz - QCPQz2 = Zu22 * PQz - B001 = Half * (r1*ZEInv) - B002 = Half * (r2*ZEInv) - x101= PAQPx1 - x011= QCPQx1 - x111= PAQPx1*QCPQx1 + B001 - x102= PAQPx2 - x012= QCPQx2 - x112= PAQPx2*QCPQx2 + B002 - y101= PAQPy1 - y011= QCPQy1 - y111= PAQPy1*QCPQy1 + B001 - y102= PAQPy2 - y012= QCPQy2 - y112= PAQPy2*QCPQy2 + B002 - z101= PAQPz1 - z011= QCPQz1 - z111= PAQPz1*QCPQz1 + B001 - z102= PAQPz2 - z012= QCPQz2 - z112= PAQPz2*QCPQz2 + B002 - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - EFInt(iZeta,iEta,1,1) = PreFct * (x111 *w1+x112 *w2) - EFInt(iZeta,iEta,2,1) = PreFct * (x101*y011*w1+x102*y012*w2) - EFInt(iZeta,iEta,3,1) = PreFct * (x101*z011*w1+x102*z012*w2) - EFInt(iZeta,iEta,1,2) = PreFct * (y101*x011*w1+y102*x012*w2) - EFInt(iZeta,iEta,2,2) = PreFct * (y111 *w1 + y112 *w2) - EFInt(iZeta,iEta,3,2) = PreFct * (y101*z011*w1+y102*z012*w2) - EFInt(iZeta,iEta,1,3) = PreFct * (z101*x011*w1+z102*x012*w2) - EFInt(iZeta,iEta,2,3) = PreFct * (z101*y011*w1+z102*y012*w2) - EFInt(iZeta,iEta,3,3) = PreFct * (z111 *w1 + z112 *w2) - 24 Continue - 14 Continue - Go To 99 -* - 99 Continue -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/spsp.F90 openmolcas-22.10/src/rys_util/spsp.F90 --- openmolcas-22.02/src/rys_util/spsp.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/spsp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,382 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1994, Roland Lindh * +!*********************************************************************** + +subroutine spsp(EFInt,Zeta,nZeta,P,lP,rKappAB,A,B,Eta,nEta,Q,lQ,rKappCD,C,D,CoorAC,TMax,iPntr,nPntr,x0,nMax,CW6,CW5,CW4,CW3,CW2, & + CW1,CW0,CR6,CR5,CR4,CR3,CR2,CR1,CR0,ddx,HerW,HerR2,IsChi,ChiI2) +!*********************************************************************** +! * +! Object: to compute the primitive integrals of type (sp|sp). * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. 1994 * +!*********************************************************************** + +use Constants, only: Zero, One, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, lP, nEta, lQ, nPntr, iPntr(nPntr), nMax, IsChi +real(kind=wp), intent(out) :: EFInt(nZeta,nEta,3,3) +real(kind=wp), intent(in) :: Zeta(nZeta), P(lP,3), rKappAB(nZeta), A(3), B(3), Eta(nEta), Q(lQ,3), rKappCD(nEta), C(3), D(3), & + CoorAC(3,2), TMax, x0(nMax), CW6(nMax,2), CW5(nMax,2), CW4(nMax,2), CW3(nMax,2), CW2(nMax,2), & + CW1(nMax,2), CW0(nMax,2), CR6(nMax,2), CR5(nMax,2), CR4(nMax,2), CR3(nMax,2), CR2(nMax,2), & + CR1(nMax,2), CR0(nMax,2), ddx, HerW(2), HerR2(2), ChiI2 +integer(kind=iwp) :: iEta, iZeta, n +real(kind=wp) :: ai, B001, B002, dddx, Eu21, Eu22, PAQPx1, PAQPx2, PAQPy1, PAQPy2, PAQPz1, PAQPz2, PQ2, PQx, PQy, PQz, PreFct, & + QCPQx1, QCPQx2, QCPQy1, QCPQy2, QCPQz1, QCPQz2, r1, r2, rho, si, T, w1, w2, x011, x012, x101, x102, x111, x112, & + xdInv, y011, y012, y101, y102, y111, y112, z, z011, z012, z101, z102, z111, z112, ZEInv, Zu21, Zu22 +logical(kind=iwp) :: ABeqCD +logical(kind=iwp), external :: EQ + +xdInv = One/ddx +dddx = ddx/10+ddx + +ABeqCD = EQ(A,B) .and. EQ(A,C) .and. EQ(A,D) + +if (ABeqCD) then + + ! AAAA case + + z = -x0(1) + w1 = (((((CW6(1,1)*z+CW5(1,1))*z+CW4(1,1))*z+CW3(1,1))*z+CW2(1,1))*z+CW1(1,1))*z+Cw0(1,1) + w2 = (((((CW6(1,2)*z+CW5(1,2))*z+CW4(1,2))*z+CW3(1,2))*z+CW2(1,2))*z+CW1(1,2))*z+Cw0(1,2) + r1 = (((((CR6(1,1)*z+CR5(1,1))*z+CR4(1,1))*z+CR3(1,1))*z+CR2(1,1))*z+CR1(1,1))*z+CR0(1,1) + r2 = (((((CR6(1,2)*z+CR5(1,2))*z+CR4(1,2))*z+CR3(1,2))*z+CR2(1,2))*z+CR1(1,2))*z+CR0(1,2) + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + B001 = w1*Half*(r1*ZEInv) + B002 = w2*Half*(r2*ZEInv) + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + EFInt(iZeta,iEta,1,1) = PreFct*(B001+B002) + EFInt(iZeta,iEta,2,1) = Zero + EFInt(iZeta,iEta,3,1) = Zero + EFInt(iZeta,iEta,1,2) = Zero + EFInt(iZeta,iEta,2,2) = PreFct*(B001+B002) + EFInt(iZeta,iEta,3,2) = Zero + EFInt(iZeta,iEta,1,3) = Zero + EFInt(iZeta,iEta,2,3) = Zero + EFInt(iZeta,iEta,3,3) = PreFct*(B001+B002) + end do + end do + +else if (EQ(A,B) .and. (.not. EQ(C,D))) then + + ! AACD case + + do iEta=1,nEta + do iZeta=1,nZeta + PQx = CoorAC(1,1)-Q(iEta,1) + PQy = CoorAC(2,1)-Q(iEta,2) + PQz = CoorAC(3,1)-Q(iEta,3) + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*Eta(iEta)*ZEInv + T = rho*(PQx**2+PQy**2+PQz**2) + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + PAQPx1 = -Eu21*PQx + PAQPx2 = -Eu22*PQx + PAQPy1 = -Eu21*PQy + PAQPy2 = -Eu22*PQy + PAQPz1 = -Eu21*PQz + PAQPz2 = -Eu22*PQz + QCPQx1 = (Q(iEta,1)-CoorAC(1,2))+Zu21*PQx + QCPQx2 = (Q(iEta,1)-CoorAC(1,2))+Zu22*PQx + QCPQy1 = (Q(iEta,2)-CoorAC(2,2))+Zu21*PQy + QCPQy2 = (Q(iEta,2)-CoorAC(2,2))+Zu22*PQy + QCPQz1 = (Q(iEta,3)-CoorAC(3,2))+Zu21*PQz + QCPQz2 = (Q(iEta,3)-CoorAC(3,2))+Zu22*PQz + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + x101 = PAQPx1 + x011 = QCPQx1 + x111 = PAQPx1*QCPQx1+B001 + x102 = PAQPx2 + x012 = QCPQx2 + x112 = PAQPx2*QCPQx2+B002 + y101 = PAQPy1 + y011 = QCPQy1 + y111 = PAQPy1*QCPQy1+B001 + y102 = PAQPy2 + y012 = QCPQy2 + y112 = PAQPy2*QCPQy2+B002 + z101 = PAQPz1 + z011 = QCPQz1 + z111 = PAQPz1*QCPQz1+B001 + z102 = PAQPz2 + z012 = QCPQz2 + z112 = PAQPz2*QCPQz2+B002 + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + EFInt(iZeta,iEta,1,1) = PreFct*(x111*w1+x112*w2) + EFInt(iZeta,iEta,2,1) = PreFct*(x101*y011*w1+x102*y012*w2) + EFInt(iZeta,iEta,3,1) = PreFct*(x101*z011*w1+x102*z012*w2) + EFInt(iZeta,iEta,1,2) = PreFct*(y101*x011*w1+y102*x012*w2) + EFInt(iZeta,iEta,2,2) = PreFct*(y111*w1+y112*w2) + EFInt(iZeta,iEta,3,2) = PreFct*(y101*z011*w1+y102*z012*w2) + EFInt(iZeta,iEta,1,3) = PreFct*(z101*x011*w1+z102*x012*w2) + EFInt(iZeta,iEta,2,3) = PreFct*(z101*y011*w1+z102*y012*w2) + EFInt(iZeta,iEta,3,3) = PreFct*(z111*w1+z112*w2) + end do + end do + +else if ((.not. EQ(A,B)) .and. EQ(C,D)) then + + ! ABCC case + + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*Eta(iEta)*ZEInv + PQx = P(iZeta,1)-CoorAC(1,2) + PQy = P(iZeta,2)-CoorAC(2,2) + PQz = P(iZeta,3)-CoorAC(3,2) + T = rho*(PQx**2+PQy**2+PQz**2) + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + PAQPx1 = (P(iZeta,1)-CoorAC(1,1))-Eu21*PQx + PAQPx2 = (P(iZeta,1)-CoorAC(1,1))-Eu22*PQx + PAQPy1 = (P(iZeta,2)-CoorAC(2,1))-Eu21*PQy + PAQPy2 = (P(iZeta,2)-CoorAC(2,1))-Eu22*PQy + PAQPz1 = (P(iZeta,3)-CoorAC(3,1))-Eu21*PQz + PAQPz2 = (P(iZeta,3)-CoorAC(3,1))-Eu22*PQz + QCPQx1 = Zu21*PQx + QCPQx2 = Zu22*PQx + QCPQy1 = Zu21*PQy + QCPQy2 = Zu22*PQy + QCPQz1 = Zu21*PQz + QCPQz2 = Zu22*PQz + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + x101 = PAQPx1 + x011 = QCPQx1 + x111 = PAQPx1*QCPQx1+B001 + x102 = PAQPx2 + x012 = QCPQx2 + x112 = PAQPx2*QCPQx2+B002 + y101 = PAQPy1 + y011 = QCPQy1 + y111 = PAQPy1*QCPQy1+B001 + y102 = PAQPy2 + y012 = QCPQy2 + y112 = PAQPy2*QCPQy2+B002 + z101 = PAQPz1 + z011 = QCPQz1 + z111 = PAQPz1*QCPQz1+B001 + z102 = PAQPz2 + z012 = QCPQz2 + z112 = PAQPz2*QCPQz2+B002 + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + EFInt(iZeta,iEta,1,1) = PreFct*(x111*w1+x112*w2) + EFInt(iZeta,iEta,2,1) = PreFct*(x101*y011*w1+x102*y012*w2) + EFInt(iZeta,iEta,3,1) = PreFct*(x101*z011*w1+x102*z012*w2) + EFInt(iZeta,iEta,1,2) = PreFct*(y101*x011*w1+y102*x012*w2) + EFInt(iZeta,iEta,2,2) = PreFct*(y111*w1+y112*w2) + EFInt(iZeta,iEta,3,2) = PreFct*(y101*z011*w1+y102*z012*w2) + EFInt(iZeta,iEta,1,3) = PreFct*(z101*x011*w1+z102*x012*w2) + EFInt(iZeta,iEta,2,3) = PreFct*(z101*y011*w1+z102*y012*w2) + EFInt(iZeta,iEta,3,3) = PreFct*(z111*w1+z112*w2) + end do + end do + +else if (EQ(A,B) .and. EQ(C,D)) then + + ! AACC case + + PQx = CoorAC(1,1)-CoorAC(1,2) + PQy = CoorAC(2,1)-CoorAC(2,2) + PQz = CoorAC(3,1)-CoorAC(3,2) + PQ2 = (PQx**2+PQy**2+PQz**2) + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*Eta(iEta)*ZEInv + T = rho*PQ2 + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + PAQPx1 = -Eu21*PQx + PAQPx2 = -Eu22*PQx + PAQPy1 = -Eu21*PQy + PAQPy2 = -Eu22*PQy + PAQPz1 = -Eu21*PQz + PAQPz2 = -Eu22*PQz + QCPQx1 = Zu21*PQx + QCPQx2 = Zu22*PQx + QCPQy1 = Zu21*PQy + QCPQy2 = Zu22*PQy + QCPQz1 = Zu21*PQz + QCPQz2 = Zu22*PQz + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + x101 = PAQPx1 + x011 = QCPQx1 + x111 = PAQPx1*QCPQx1+B001 + x102 = PAQPx2 + x012 = QCPQx2 + x112 = PAQPx2*QCPQx2+B002 + y101 = PAQPy1 + y011 = QCPQy1 + y111 = PAQPy1*QCPQy1+B001 + y102 = PAQPy2 + y012 = QCPQy2 + y112 = PAQPy2*QCPQy2+B002 + z101 = PAQPz1 + z011 = QCPQz1 + z111 = PAQPz1*QCPQz1+B001 + z102 = PAQPz2 + z012 = QCPQz2 + z112 = PAQPz2*QCPQz2+B002 + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + EFInt(iZeta,iEta,1,1) = PreFct*(x111*w1+x112*w2) + EFInt(iZeta,iEta,2,1) = PreFct*(x101*y011*w1+x102*y012*w2) + EFInt(iZeta,iEta,3,1) = PreFct*(x101*z011*w1+x102*z012*w2) + EFInt(iZeta,iEta,1,2) = PreFct*(y101*x011*w1+y102*x012*w2) + EFInt(iZeta,iEta,2,2) = PreFct*(y111*w1+y112*w2) + EFInt(iZeta,iEta,3,2) = PreFct*(y101*z011*w1+y102*z012*w2) + EFInt(iZeta,iEta,1,3) = PreFct*(z101*x011*w1+z102*x012*w2) + EFInt(iZeta,iEta,2,3) = PreFct*(z101*y011*w1+z102*y012*w2) + EFInt(iZeta,iEta,3,3) = PreFct*(z111*w1+z112*w2) + end do + end do + +else + + ! ABCD case + + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Zeta(iZeta)*Eta(iEta)*ZEInv + PQx = P(iZeta,1)-Q(iEta,1) + PQy = P(iZeta,2)-Q(iEta,2) + PQz = P(iZeta,3)-Q(iEta,3) + T = rho*(PQx**2+PQy**2+PQz**2) + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + Eu21 = Eta(iEta)*(r1*ZEInv) + Eu22 = Eta(iEta)*(r2*ZEInv) + Zu21 = Zeta(iZeta)*(r1*ZEInv) + Zu22 = Zeta(iZeta)*(r2*ZEInv) + PAQPx1 = (P(iZeta,1)-CoorAC(1,1))-Eu21*PQx + PAQPx2 = (P(iZeta,1)-CoorAC(1,1))-Eu22*PQx + PAQPy1 = (P(iZeta,2)-CoorAC(2,1))-Eu21*PQy + PAQPy2 = (P(iZeta,2)-CoorAC(2,1))-Eu22*PQy + PAQPz1 = (P(iZeta,3)-CoorAC(3,1))-Eu21*PQz + PAQPz2 = (P(iZeta,3)-CoorAC(3,1))-Eu22*PQz + QCPQx1 = (Q(iEta,1)-CoorAC(1,2))+Zu21*PQx + QCPQx2 = (Q(iEta,1)-CoorAC(1,2))+Zu22*PQx + QCPQy1 = (Q(iEta,2)-CoorAC(2,2))+Zu21*PQy + QCPQy2 = (Q(iEta,2)-CoorAC(2,2))+Zu22*PQy + QCPQz1 = (Q(iEta,3)-CoorAC(3,2))+Zu21*PQz + QCPQz2 = (Q(iEta,3)-CoorAC(3,2))+Zu22*PQz + B001 = Half*(r1*ZEInv) + B002 = Half*(r2*ZEInv) + x101 = PAQPx1 + x011 = QCPQx1 + x111 = PAQPx1*QCPQx1+B001 + x102 = PAQPx2 + x012 = QCPQx2 + x112 = PAQPx2*QCPQx2+B002 + y101 = PAQPy1 + y011 = QCPQy1 + y111 = PAQPy1*QCPQy1+B001 + y102 = PAQPy2 + y012 = QCPQy2 + y112 = PAQPy2*QCPQy2+B002 + z101 = PAQPz1 + z011 = QCPQz1 + z111 = PAQPz1*QCPQz1+B001 + z102 = PAQPz2 + z012 = QCPQz2 + z112 = PAQPz2*QCPQz2+B002 + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + EFInt(iZeta,iEta,1,1) = PreFct*(x111*w1+x112*w2) + EFInt(iZeta,iEta,2,1) = PreFct*(x101*y011*w1+x102*y012*w2) + EFInt(iZeta,iEta,3,1) = PreFct*(x101*z011*w1+x102*z012*w2) + EFInt(iZeta,iEta,1,2) = PreFct*(y101*x011*w1+y102*x012*w2) + EFInt(iZeta,iEta,2,2) = PreFct*(y111*w1+y112*w2) + EFInt(iZeta,iEta,3,2) = PreFct*(y101*z011*w1+y102*z012*w2) + EFInt(iZeta,iEta,1,3) = PreFct*(z101*x011*w1+z102*x012*w2) + EFInt(iZeta,iEta,2,3) = PreFct*(z101*y011*w1+z102*y012*w2) + EFInt(iZeta,iEta,3,3) = PreFct*(z111*w1+z112*w2) + end do + end do + +end if + +return + +end subroutine spsp diff -Nru openmolcas-22.02/src/rys_util/sspp.f openmolcas-22.10/src/rys_util/sspp.f --- openmolcas-22.02/src/rys_util/sspp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/sspp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,350 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1994, Roland Lindh * -************************************************************************ - Subroutine sspp(EFInt,Zeta,ZInv,nZeta,P,lP,rKappAB,A,B, - & Eta,EInv, nEta,Q,lQ,rKappCD,C,D, - & CoorAC,TMax, - & iPntr,nPntr,x0,nMax,CW6,CW5,CW4,CW3,CW2,CW1,CW0, - & CR6,CR5,CR4,CR3,CR2,CR1,CR0, - & ddx,HerW,HerR2,IsChi,ChiI2) -************************************************************************ -* * -* Object: to compute the primitive integrals of type (ss|pp). * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. 1994 * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 EFInt(nZeta,nEta,9), Zeta(nZeta), Eta(nEta), - & CoorAC(3,2), ZInv(nZeta), EInv(nEta), - & P(lP,3), Q(lQ,3), A(3), B(3), C(3), D(3), - & rKappAB(nZeta), rKappCD(nEta), - & x0(nMax), - & CW6(nMax,2), CW5(nMax,2), CW4(nMax,2), CW3(nMax,2), - & CW2(nMax,2), CW1(nMax,2), CW0(nMax,2), - & CR6(nMax,2), CR5(nMax,2), CR4(nMax,2), CR3(nMax,2), - & CR2(nMax,2), CR1(nMax,2), CR0(nMax,2), - & HerW(2), HerR2(2) - Integer iPntr(nPntr) - Logical ABeqCD, EQ -* -* - xdInv=One/ddx - dddx = ddx/10d0 + ddx -* - ABeqCD = EQ(A,B) .and. EQ(A,C) .and. EQ(A,D) - If ( ABeqCD ) Go To 100 - If ( EQ(A,B).and..Not.EQ(C,D)) Go To 200 - If (.Not.EQ(A,B).and. EQ(C,D)) Go To 300 - If ( EQ(A,B).and. EQ(C,D)) Go To 400 -* -*-----ABCD case -* - Do 10 iEta = 1, nEta - Do 20 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > + (Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - rho = Eta(iEta)*(Zeta(iZeta)*ZEInv) - PQx = P(iZeta,1)-Q(iEta,1) - PQy = P(iZeta,2)-Q(iEta,2) - PQz = P(iZeta,3)-Q(iEta,3) - T = rho * (PQx**2 + PQy**2 + PQz**2) - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - Zu21 = r1*(Zeta(iZeta)*ZEInv) - Zu22 = r2*(Zeta(iZeta)*ZEInv) - QCPQx1 = (Q(iEta,1) - CoorAC(1,2)) + Zu21 * PQx - QCPQx2 = (Q(iEta,1) - CoorAC(1,2)) + Zu22 * PQx - QCPQy1 = (Q(iEta,2) - CoorAC(2,2)) + Zu21 * PQy - QCPQy2 = (Q(iEta,2) - CoorAC(2,2)) + Zu22 * PQy - QCPQz1 = (Q(iEta,3) - CoorAC(3,2)) + Zu21 * PQz - QCPQz2 = (Q(iEta,3) - CoorAC(3,2)) + Zu22 * PQz - B011 = (Half - Half * Zu21) * EInv(iEta) - B012 = (Half - Half * Zu22) * EInv(iEta) - x011= QCPQx1 - x012= QCPQx2 - x021= QCPQx1*x011 + B011 - x022= QCPQx2*x012 + B012 - y011= QCPQy1 - y012= QCPQy2 - y021= QCPQy1*y011 + B011 - y022= QCPQy2*y012 + B012 - z011= QCPQz1*w1 - z012= QCPQz2*w2 - z021= QCPQz1*z011 + B011*w1 - z022= QCPQz2*z012 + B012*w2 - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - EFInt(iZeta,iEta,1) = PreFct * ( x011*w1+ x012*w2) - EFInt(iZeta,iEta,2) = PreFct * ( y011*w1+ y012*w2) - EFInt(iZeta,iEta,3) = PreFct * ( z011 + z012 ) - EFInt(iZeta,iEta,4) = PreFct * ( x021*w1+ x022*w2) - EFInt(iZeta,iEta,5) = PreFct * (x011*y011*w1+x012*y012*w2) - EFInt(iZeta,iEta,6) = PreFct * (x011*z011 +x012*z012 ) - EFInt(iZeta,iEta,7) = PreFct * ( y021*w1+ y022*w2) - EFInt(iZeta,iEta,8) = PreFct * (y011*z011 +y012*z012 ) - EFInt(iZeta,iEta,9) = PreFct * ( z021 + z022 ) - 20 Continue - 10 Continue - Go To 99 -* -*-----AAAA case -* - 100 Continue - z = - x0(1) - w1=(((((CW6(1,1)*z+CW5(1,1))*z+CW4(1,1))*z+CW3(1,1))*z+ - & CW2(1,1))*z+CW1(1,1))*z+Cw0(1,1) - w2=(((((CW6(1,2)*z+CW5(1,2))*z+CW4(1,2))*z+CW3(1,2))*z+ - & CW2(1,2))*z+CW1(1,2))*z+Cw0(1,2) - r1=(((((CR6(1,1)*z+CR5(1,1))*z+CR4(1,1))*z+CR3(1,1))*z+ - & CR2(1,1))*z+CR1(1,1))*z+CR0(1,1) - r2=(((((CR6(1,2)*z+CR5(1,2))*z+CR4(1,2))*z+CR3(1,2))*z+ - & CR2(1,2))*z+CR1(1,2))*z+CR0(1,2) - Do 11 iEta = 1, nEta - Do 21 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - rho = Eta(iEta)*(Zeta(iZeta)*ZEInv) - Zu21 = r1*(Zeta(iZeta)*ZEInv) - Zu22 = r2*(Zeta(iZeta)*ZEInv) - B011 = (Half - Half * Zu21) * EInv(iEta) - B012 = (Half - Half * Zu22) * EInv(iEta) - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - EFInt(iZeta,iEta,1) = (PreFct * (B011*w1+B012*w2)) - EFInt(iZeta,iEta,2) = Zero - EFInt(iZeta,iEta,3) = Zero - EFInt(iZeta,iEta,4) = (PreFct * (B011*w1+B012*w2)) - EFInt(iZeta,iEta,5) = Zero - EFInt(iZeta,iEta,6) = (PreFct * (B011*w1+B012*w2)) - 21 Continue - 11 Continue - Go To 99 -* -*-----AACD case -* - 200 Continue - Do 12 iEta = 1, nEta - Do 22 iZeta = 1, nZeta - PQx = CoorAC(1,1)-Q(iEta,1) - PQy = CoorAC(2,1)-Q(iEta,2) - PQz = CoorAC(3,1)-Q(iEta,3) - PQ2 = (PQx**2 + PQy**2 + PQz**2) - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - rho = Eta(iEta)*(Zeta(iZeta)*ZEInv) - T = rho * PQ2 - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - Zu21 = r1*(Zeta(iZeta)*ZEInv) - Zu22 = r2*(Zeta(iZeta)*ZEInv) - QCPQx1 = (Q(iEta,1) - CoorAC(1,2)) + Zu21 * PQx - QCPQx2 = (Q(iEta,1) - CoorAC(1,2)) + Zu22 * PQx - QCPQy1 = (Q(iEta,2) - CoorAC(2,2)) + Zu21 * PQy - QCPQy2 = (Q(iEta,2) - CoorAC(2,2)) + Zu22 * PQy - QCPQz1 = (Q(iEta,3) - CoorAC(3,2)) + Zu21 * PQz - QCPQz2 = (Q(iEta,3) - CoorAC(3,2)) + Zu22 * PQz - B011 = (Half - Half * Zu21) * EInv(iEta) - B012 = (Half - Half * Zu22) * EInv(iEta) - x011= QCPQx1 - x012= QCPQx2 - x021= QCPQx1*x011 + B011 - x022= QCPQx2*x012 + B012 - y011= QCPQy1 - y012= QCPQy2 - y021= QCPQy1*y011 + B011 - y022= QCPQy2*y012 + B012 - z011= QCPQz1*w1 - z012= QCPQz2*w2 - z021= QCPQz1*z011 + B011*w1 - z022= QCPQz2*z012 + B012*w2 - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - EFInt(iZeta,iEta,1) = PreFct * ( x011*w1+ x012*w2) - EFInt(iZeta,iEta,2) = PreFct * ( y011*w1+ y012*w2) - EFInt(iZeta,iEta,3) = PreFct * ( z011 + z012 ) - EFInt(iZeta,iEta,4) = PreFct * ( x021*w1+ x022*w2) - EFInt(iZeta,iEta,5) = PreFct * (x011*y011*w1+x012*y012*w2) - EFInt(iZeta,iEta,6) = PreFct * (x011*z011 +x012*z012 ) - EFInt(iZeta,iEta,7) = PreFct * ( y021*w1+ y022*w2) - EFInt(iZeta,iEta,8) = PreFct * (y011*z011 +y012*z012 ) - EFInt(iZeta,iEta,9) = PreFct * ( z021 + z022 ) - 22 Continue - 12 Continue - Go To 99 -* -*-----ABCC case -* - 300 Continue - Do 13 iEta = 1, nEta - Do 23 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - rho = Eta(iEta)*(Zeta(iZeta)*ZEInv) - PQx = P(iZeta,1)-CoorAC(1,2) - PQy = P(iZeta,2)-CoorAC(2,2) - PQz = P(iZeta,3)-CoorAC(3,2) - T = rho * (PQx**2 + PQy**2 + PQz**2) - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - Zu21 = r1*(Zeta(iZeta)*ZEInv) - Zu22 = r2*(Zeta(iZeta)*ZEInv) - QCPQx1 = Zu21 * PQx - QCPQx2 = Zu22 * PQx - QCPQy1 = Zu21 * PQy - QCPQy2 = Zu22 * PQy - QCPQz1 = Zu21 * PQz - QCPQz2 = Zu22 * PQz - B011 = (Half - Half * Zu21) * EInv(iEta) - B012 = (Half - Half * Zu22) * EInv(iEta) - x011= QCPQx1 - x012= QCPQx2 - x021= QCPQx1*x011 + B011 - x022= QCPQx2*x012 + B012 - y011= QCPQy1 - y012= QCPQy2 - y021= QCPQy1*y011 + B011 - y022= QCPQy2*y012 + B012 - z011= QCPQz1*w1 - z012= QCPQz2*w2 - z021= QCPQz1*z011 + B011*w1 - z022= QCPQz2*z012 + B012*w2 - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - EFInt(iZeta,iEta,1) = PreFct * ( x021*w1+ x022*w2) - EFInt(iZeta,iEta,2) = PreFct * (x011*y011*w1+x012*y012*w2) - EFInt(iZeta,iEta,3) = PreFct * (x011*z011 +x012*z012 ) - EFInt(iZeta,iEta,4) = PreFct * ( y021*w1+ y022*w2) - EFInt(iZeta,iEta,5) = PreFct * (y011*z011 +y012*z012 ) - EFInt(iZeta,iEta,6) = PreFct * ( z021 + z022 ) - 23 Continue - 13 Continue - Go To 99 -* -*-----AACC case -* - 400 Continue - PQx = CoorAC(1,1)-CoorAC(1,2) - PQy = CoorAC(2,1)-CoorAC(2,2) - PQz = CoorAC(3,1)-CoorAC(3,2) - PQ2 = (PQx**2 + PQy**2 + PQz**2) - Do 14 iEta = 1, nEta - Do 24 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - rho = Eta(iEta)*(Zeta(iZeta)*ZEInv) - T = rho * PQ2 - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w1=(((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+ - & CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) - w2=(((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+ - & CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) - r1=(((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+ - & CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) - r2=(((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+ - & CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) - Else - ai = 1.0D0/T - si = Sqrt(ai) - w1= HerW(1)*si - w2= HerW(2)*si - r1= HerR2(1)*ai - r2= HerR2(2)*ai - End If - Zu21 = r1*(Zeta(iZeta)*ZEInv) - Zu22 = r2*(Zeta(iZeta)*ZEInv) - QCPQx1 = Zu21 * PQx - QCPQx2 = Zu22 * PQx - QCPQy1 = Zu21 * PQy - QCPQy2 = Zu22 * PQy - QCPQz1 = Zu21 * PQz - QCPQz2 = Zu22 * PQz - B011 = (Half - Half * Zu21) * EInv(iEta) - B012 = (Half - Half * Zu22) * EInv(iEta) - x011= QCPQx1 - x012= QCPQx2 - x021= QCPQx1*x011 + B011 - x022= QCPQx2*x012 + B012 - y011= QCPQy1 - y012= QCPQy2 - y021= QCPQy1*y011 + B011 - y022= QCPQy2*y012 + B012 - z011= QCPQz1*w1 - z012= QCPQz2*w2 - z021= QCPQz1*z011 + B011*w1 - z022= QCPQz2*z012 + B012*w2 - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) - EFInt(iZeta,iEta,1) = PreFct * ( x021*w1+ x022*w2) - EFInt(iZeta,iEta,2) = PreFct * (x011*y011*w1+x012*y012*w2) - EFInt(iZeta,iEta,3) = PreFct * (x011*z011 +x012*z012 ) - EFInt(iZeta,iEta,4) = PreFct * ( y021*w1+ y022*w2) - EFInt(iZeta,iEta,5) = PreFct * (y011*z011 +y012*z012 ) - EFInt(iZeta,iEta,6) = PreFct * ( z021 + z022 ) - 24 Continue - 14 Continue -* - 99 Continue -* - Return -c Avoid unused argument warnings - If (.False.) Call Unused_real_array(ZInv) - End diff -Nru openmolcas-22.02/src/rys_util/sspp.F90 openmolcas-22.10/src/rys_util/sspp.F90 --- openmolcas-22.02/src/rys_util/sspp.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/sspp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,323 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1994, Roland Lindh * +!*********************************************************************** + +subroutine sspp(EFInt,Zeta,ZInv,nZeta,P,lP,rKappAB,A,B,Eta,EInv,nEta,Q,lQ,rKappCD,C,D,CoorAC,TMax,iPntr,nPntr,x0,nMax,CW6,CW5,CW4, & + CW3,CW2,CW1,CW0,CR6,CR5,CR4,CR3,CR2,CR1,CR0,ddx,HerW,HerR2,IsChi,ChiI2) +!*********************************************************************** +! * +! Object: to compute the primitive integrals of type (ss|pp). * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. 1994 * +!*********************************************************************** + +use Constants, only: Zero, One, Ten, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, lP, nEta, lQ, nPntr, iPntr(nPntr), nMax, IsChi +real(kind=wp), intent(out) :: EFInt(nZeta,nEta,9) +real(kind=wp), intent(in) :: Zeta(nZeta), ZInv(nZeta), P(lP,3), rKappAB(nZeta), A(3), B(3), Eta(nEta), EInv(nEta), Q(lQ,3), & + rKappCD(nEta), C(3), D(3), CoorAC(3,2), TMax, x0(nMax), CW6(nMax,2), CW5(nMax,2), CW4(nMax,2), & + CW3(nMax,2), CW2(nMax,2), CW1(nMax,2), CW0(nMax,2), CR6(nMax,2), CR5(nMax,2), CR4(nMax,2), & + CR3(nMax,2), CR2(nMax,2), CR1(nMax,2), CR0(nMax,2), ddx, HerW(2), HerR2(2), ChiI2 +integer(kind=iwp) :: iEta, iZeta, n +real(kind=wp) :: ai, B011, B012, dddx, PQ2, PQx, PQy, PQz, PreFct, QCPQx1, QCPQx2, QCPQy1, QCPQy2, QCPQz1, QCPQz2, r1, r2, rho, & + si, T, w1, w2, x011, x012, x021, x022, xdInv, y011, y012, y021, y022, z, z011, z012, z021, z022, ZEInv, Zu21, Zu22 +logical(kind=iwp) :: ABeqCD +logical(kind=iwp), external :: EQ + +#include "macros.fh" +unused_var(ZInv) + +xdInv = One/ddx +dddx = ddx/Ten+ddx + +ABeqCD = EQ(A,B) .and. EQ(A,C) .and. EQ(A,D) + +if (ABeqCD) then + + ! AAAA case + + z = -x0(1) + w1 = (((((CW6(1,1)*z+CW5(1,1))*z+CW4(1,1))*z+CW3(1,1))*z+CW2(1,1))*z+CW1(1,1))*z+Cw0(1,1) + w2 = (((((CW6(1,2)*z+CW5(1,2))*z+CW4(1,2))*z+CW3(1,2))*z+CW2(1,2))*z+CW1(1,2))*z+Cw0(1,2) + r1 = (((((CR6(1,1)*z+CR5(1,1))*z+CR4(1,1))*z+CR3(1,1))*z+CR2(1,1))*z+CR1(1,1))*z+CR0(1,1) + r2 = (((((CR6(1,2)*z+CR5(1,2))*z+CR4(1,2))*z+CR3(1,2))*z+CR2(1,2))*z+CR1(1,2))*z+CR0(1,2) + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Eta(iEta)*(Zeta(iZeta)*ZEInv) + Zu21 = r1*(Zeta(iZeta)*ZEInv) + Zu22 = r2*(Zeta(iZeta)*ZEInv) + B011 = (Half-Half*Zu21)*EInv(iEta) + B012 = (Half-Half*Zu22)*EInv(iEta) + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + EFInt(iZeta,iEta,1) = PreFct*(B011*w1+B012*w2) + EFInt(iZeta,iEta,2) = Zero + EFInt(iZeta,iEta,3) = Zero + EFInt(iZeta,iEta,4) = PreFct*(B011*w1+B012*w2) + EFInt(iZeta,iEta,5) = Zero + EFInt(iZeta,iEta,6) = PreFct*(B011*w1+B012*w2) + end do + end do + +else if (EQ(A,B) .and. (.not. EQ(C,D))) then + + ! AACD case + + do iEta=1,nEta + do iZeta=1,nZeta + PQx = CoorAC(1,1)-Q(iEta,1) + PQy = CoorAC(2,1)-Q(iEta,2) + PQz = CoorAC(3,1)-Q(iEta,3) + PQ2 = (PQx**2+PQy**2+PQz**2) + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Eta(iEta)*(Zeta(iZeta)*ZEInv) + T = rho*PQ2 + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + Zu21 = r1*(Zeta(iZeta)*ZEInv) + Zu22 = r2*(Zeta(iZeta)*ZEInv) + QCPQx1 = (Q(iEta,1)-CoorAC(1,2))+Zu21*PQx + QCPQx2 = (Q(iEta,1)-CoorAC(1,2))+Zu22*PQx + QCPQy1 = (Q(iEta,2)-CoorAC(2,2))+Zu21*PQy + QCPQy2 = (Q(iEta,2)-CoorAC(2,2))+Zu22*PQy + QCPQz1 = (Q(iEta,3)-CoorAC(3,2))+Zu21*PQz + QCPQz2 = (Q(iEta,3)-CoorAC(3,2))+Zu22*PQz + B011 = (Half-Half*Zu21)*EInv(iEta) + B012 = (Half-Half*Zu22)*EInv(iEta) + x011 = QCPQx1 + x012 = QCPQx2 + x021 = QCPQx1*x011+B011 + x022 = QCPQx2*x012+B012 + y011 = QCPQy1 + y012 = QCPQy2 + y021 = QCPQy1*y011+B011 + y022 = QCPQy2*y012+B012 + z011 = QCPQz1*w1 + z012 = QCPQz2*w2 + z021 = QCPQz1*z011+B011*w1 + z022 = QCPQz2*z012+B012*w2 + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + EFInt(iZeta,iEta,1) = PreFct*(x011*w1+x012*w2) + EFInt(iZeta,iEta,2) = PreFct*(y011*w1+y012*w2) + EFInt(iZeta,iEta,3) = PreFct*(z011+z012) + EFInt(iZeta,iEta,4) = PreFct*(x021*w1+x022*w2) + EFInt(iZeta,iEta,5) = PreFct*(x011*y011*w1+x012*y012*w2) + EFInt(iZeta,iEta,6) = PreFct*(x011*z011+x012*z012) + EFInt(iZeta,iEta,7) = PreFct*(y021*w1+y022*w2) + EFInt(iZeta,iEta,8) = PreFct*(y011*z011+y012*z012) + EFInt(iZeta,iEta,9) = PreFct*(z021+z022) + end do + end do + +else if ((.not. EQ(A,B)) .and. EQ(C,D)) then + + ! ABCC case + + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Eta(iEta)*(Zeta(iZeta)*ZEInv) + PQx = P(iZeta,1)-CoorAC(1,2) + PQy = P(iZeta,2)-CoorAC(2,2) + PQz = P(iZeta,3)-CoorAC(3,2) + T = rho*(PQx**2+PQy**2+PQz**2) + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + Zu21 = r1*(Zeta(iZeta)*ZEInv) + Zu22 = r2*(Zeta(iZeta)*ZEInv) + QCPQx1 = Zu21*PQx + QCPQx2 = Zu22*PQx + QCPQy1 = Zu21*PQy + QCPQy2 = Zu22*PQy + QCPQz1 = Zu21*PQz + QCPQz2 = Zu22*PQz + B011 = (Half-Half*Zu21)*EInv(iEta) + B012 = (Half-Half*Zu22)*EInv(iEta) + x011 = QCPQx1 + x012 = QCPQx2 + x021 = QCPQx1*x011+B011 + x022 = QCPQx2*x012+B012 + y011 = QCPQy1 + y012 = QCPQy2 + y021 = QCPQy1*y011+B011 + y022 = QCPQy2*y012+B012 + z011 = QCPQz1*w1 + z012 = QCPQz2*w2 + z021 = QCPQz1*z011+B011*w1 + z022 = QCPQz2*z012+B012*w2 + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + EFInt(iZeta,iEta,1) = PreFct*(x021*w1+x022*w2) + EFInt(iZeta,iEta,2) = PreFct*(x011*y011*w1+x012*y012*w2) + EFInt(iZeta,iEta,3) = PreFct*(x011*z011+x012*z012) + EFInt(iZeta,iEta,4) = PreFct*(y021*w1+y022*w2) + EFInt(iZeta,iEta,5) = PreFct*(y011*z011+y012*z012) + EFInt(iZeta,iEta,6) = PreFct*(z021+z022) + end do + end do + +else if (EQ(A,B) .and. EQ(C,D)) then + + ! AACC case + + PQx = CoorAC(1,1)-CoorAC(1,2) + PQy = CoorAC(2,1)-CoorAC(2,2) + PQz = CoorAC(3,1)-CoorAC(3,2) + PQ2 = (PQx**2+PQy**2+PQz**2) + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Eta(iEta)*(Zeta(iZeta)*ZEInv) + T = rho*PQ2 + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + Zu21 = r1*(Zeta(iZeta)*ZEInv) + Zu22 = r2*(Zeta(iZeta)*ZEInv) + QCPQx1 = Zu21*PQx + QCPQx2 = Zu22*PQx + QCPQy1 = Zu21*PQy + QCPQy2 = Zu22*PQy + QCPQz1 = Zu21*PQz + QCPQz2 = Zu22*PQz + B011 = (Half-Half*Zu21)*EInv(iEta) + B012 = (Half-Half*Zu22)*EInv(iEta) + x011 = QCPQx1 + x012 = QCPQx2 + x021 = QCPQx1*x011+B011 + x022 = QCPQx2*x012+B012 + y011 = QCPQy1 + y012 = QCPQy2 + y021 = QCPQy1*y011+B011 + y022 = QCPQy2*y012+B012 + z011 = QCPQz1*w1 + z012 = QCPQz2*w2 + z021 = QCPQz1*z011+B011*w1 + z022 = QCPQz2*z012+B012*w2 + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + EFInt(iZeta,iEta,1) = PreFct*(x021*w1+x022*w2) + EFInt(iZeta,iEta,2) = PreFct*(x011*y011*w1+x012*y012*w2) + EFInt(iZeta,iEta,3) = PreFct*(x011*z011+x012*z012) + EFInt(iZeta,iEta,4) = PreFct*(y021*w1+y022*w2) + EFInt(iZeta,iEta,5) = PreFct*(y011*z011+y012*z012) + EFInt(iZeta,iEta,6) = PreFct*(z021+z022) + end do + end do + +else + + ! ABCD case + + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + rho = Eta(iEta)*(Zeta(iZeta)*ZEInv) + PQx = P(iZeta,1)-Q(iEta,1) + PQy = P(iZeta,2)-Q(iEta,2) + PQz = P(iZeta,3)-Q(iEta,3) + T = rho*(PQx**2+PQy**2+PQz**2) + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w1 = (((((CW6(n,1)*z+CW5(n,1))*z+CW4(n,1))*z+CW3(n,1))*z+CW2(n,1))*z+CW1(n,1))*z+Cw0(n,1) + w2 = (((((CW6(n,2)*z+CW5(n,2))*z+CW4(n,2))*z+CW3(n,2))*z+CW2(n,2))*z+CW1(n,2))*z+Cw0(n,2) + r1 = (((((CR6(n,1)*z+CR5(n,1))*z+CR4(n,1))*z+CR3(n,1))*z+CR2(n,1))*z+CR1(n,1))*z+CR0(n,1) + r2 = (((((CR6(n,2)*z+CR5(n,2))*z+CR4(n,2))*z+CR3(n,2))*z+CR2(n,2))*z+CR1(n,2))*z+CR0(n,2) + else + ai = One/T + si = sqrt(ai) + w1 = HerW(1)*si + w2 = HerW(2)*si + r1 = HerR2(1)*ai + r2 = HerR2(2)*ai + end if + Zu21 = r1*(Zeta(iZeta)*ZEInv) + Zu22 = r2*(Zeta(iZeta)*ZEInv) + QCPQx1 = (Q(iEta,1)-CoorAC(1,2))+Zu21*PQx + QCPQx2 = (Q(iEta,1)-CoorAC(1,2))+Zu22*PQx + QCPQy1 = (Q(iEta,2)-CoorAC(2,2))+Zu21*PQy + QCPQy2 = (Q(iEta,2)-CoorAC(2,2))+Zu22*PQy + QCPQz1 = (Q(iEta,3)-CoorAC(3,2))+Zu21*PQz + QCPQz2 = (Q(iEta,3)-CoorAC(3,2))+Zu22*PQz + B011 = (Half-Half*Zu21)*EInv(iEta) + B012 = (Half-Half*Zu22)*EInv(iEta) + x011 = QCPQx1 + x012 = QCPQx2 + x021 = QCPQx1*x011+B011 + x022 = QCPQx2*x012+B012 + y011 = QCPQy1 + y012 = QCPQy2 + y021 = QCPQy1*y011+B011 + y022 = QCPQy2*y012+B012 + z011 = QCPQz1*w1 + z012 = QCPQz2*w2 + z021 = QCPQz1*z011+B011*w1 + z022 = QCPQz2*z012+B012*w2 + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv) + EFInt(iZeta,iEta,1) = PreFct*(x011*w1+x012*w2) + EFInt(iZeta,iEta,2) = PreFct*(y011*w1+y012*w2) + EFInt(iZeta,iEta,3) = PreFct*(z011+z012) + EFInt(iZeta,iEta,4) = PreFct*(x021*w1+x022*w2) + EFInt(iZeta,iEta,5) = PreFct*(x011*y011*w1+x012*y012*w2) + EFInt(iZeta,iEta,6) = PreFct*(x011*z011+x012*z012) + EFInt(iZeta,iEta,7) = PreFct*(y021*w1+y022*w2) + EFInt(iZeta,iEta,8) = PreFct*(y011*z011+y012*z012) + EFInt(iZeta,iEta,9) = PreFct*(z021+z022) + end do + end do + +end if + +return + +end subroutine sspp diff -Nru openmolcas-22.02/src/rys_util/sssp.f openmolcas-22.10/src/rys_util/sssp.f --- openmolcas-22.02/src/rys_util/sssp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/sssp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,133 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1994, Roland Lindh * -************************************************************************ - Subroutine sssp(EFInt,Zeta,nZeta,P,lP,rKappAB,A,B, - & Eta, nEta,Q,lQ,rKappCD,C,D, - & CoorAC,TMax, - & iPntr,nPntr,x0,nMax,W6,W5,W4,W3,W2,W1,W0, - & R6,R5,R4,R3,R2,R1,R0, - & ddx,HerW,HerR2,IsChi,ChiI2) -************************************************************************ -* * -* Object: to compute the primitive integrals of type (ss|sp). * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. 1994 * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 EFInt(nZeta,nEta,3), Zeta(nZeta), Eta(nEta), - & CoorAC(3,2), - & P(lP,3), Q(lQ,3), A(3), B(3), C(3), D(3), - & rKappAB(nZeta), rKappCD(nEta), - & x0(nMax), W6(nMax), W5(nMax), - & W4(nMax), W3(nMax), W2(nMax), W1(nMax), W0(nMax), - & R6(nMax), R5(nMax), - & R4(nMax), R3(nMax), R2(nMax), R1(nMax), R0(nMax) - Integer iPntr(nPntr) - Logical ABeqCD, EQ -* -* - xdInv=One/ddx - dddx = ddx/10d0 + ddx -* - ABeqCD = EQ(A,B) .and. EQ(A,C) .and. EQ(A,D) - If (ABeqCD) Go To 300 - If (EQ(C,D)) Go To 200 -* -*-----ABCD case -* - Do 10 iEta = 1, nEta - Do 20 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - ZE = Zeta(iZeta)*Eta(iEta) - rho = ZE*ZEInv - PQx = P(iZeta,1)-Q(iEta,1) - PQy = P(iZeta,2)-Q(iEta,2) - PQz = P(iZeta,3)-Q(iEta,3) - PQ2 = PQx**2 + PQy**2 + PQz**2 - T = rho*PQ2 - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w =(((((W6(n)*z+W5(n))*z+W4(n))*z+W3(n))*z+W2(n)) - & *z+W1(n))*z+w0(n) - r =(((((R6(n)*z+R5(n))*z+R4(n))*z+R3(n))*z+R2(n)) - & *z+R1(n))*z+R0(n) - Zu2 = r * (Zeta(iZeta)*ZEInv) - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) * w - Else - Zu2 = HerR2 / (Eta(iEta)*PQ2) - PreFct = rKappCD(iEta) * rKappAB(iZeta) - & * HerW / Sqrt(ZE*PQ2) - End If - QCPQx = Q(iEta,1) - CoorAC(1,2) + Zu2 * PQx - QCPQy = Q(iEta,2) - CoorAC(2,2) + Zu2 * PQy - QCPQz = Q(iEta,3) - CoorAC(3,2) + Zu2 * PQz - EFInt(iZeta,iEta,1) = PreFct * QCPQx - EFInt(iZeta,iEta,2) = PreFct * QCPQy - EFInt(iZeta,iEta,3) = PreFct * QCPQz - 20 Continue - 10 Continue - Go To 99 -* -*-----ABCC case -* - 200 Continue - Do 11 iEta = 1, nEta - Do 21 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - ZE = Zeta(iZeta)*Eta(iEta) - rho = ZE*ZEInv - PQx = (P(iZeta,1)-CoorAC(1,2)) - PQy = (P(iZeta,2)-CoorAC(2,2)) - PQz = (P(iZeta,3)-CoorAC(3,2)) - PQ2 = PQx**2 + PQy**2 + PQz**2 - T = rho*PQ2 - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w =(((((W6(n)*z+W5(n))*z+W4(n))*z+W3(n))*z+W2(n)) - & *z+W1(n))*z+w0(n) - r =(((((R6(n)*z+R5(n))*z+R4(n))*z+R3(n))*z+R2(n)) - & *z+R1(n))*z+R0(n) - Zu2 = r * (Zeta(iZeta)*ZEInv) - PreFct = rKappCD(iEta) * rKappAB(iZeta) * Sqrt(ZEInv) * w - Else - Zu2 = HerR2 / (Eta(iEta)*PQ2) - PreFct = rKappCD(iEta) * rKappAB(iZeta) - & * HerW / Sqrt(ZE*PQ2) - End If - EFInt(iZeta,iEta,1) = PreFct * Zu2 * PQx - EFInt(iZeta,iEta,2) = PreFct * Zu2 * PQy - EFInt(iZeta,iEta,3) = PreFct * Zu2 * PQz - 21 Continue - 11 Continue - Go To 99 -* -*-----CCCC case -* - 300 Continue - Do iEta = 1, nEta - Do iZeta = 1, nZeta - EFInt(iZeta,iEta,1) = Zero - EFInt(iZeta,iEta,2) = Zero - EFInt(iZeta,iEta,3) = Zero - End Do - End Do -* - 99 Continue -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/sssp.F90 openmolcas-22.10/src/rys_util/sssp.F90 --- openmolcas-22.02/src/rys_util/sssp.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/sssp.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,118 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1994, Roland Lindh * +!*********************************************************************** + +subroutine sssp(EFInt,Zeta,nZeta,P,lP,rKappAB,A,B,Eta,nEta,Q,lQ,rKappCD,C,D,CoorAC,TMax,iPntr,nPntr,x0,nMax,W6,W5,W4,W3,W2,W1,W0, & + R6,R5,R4,R3,R2,R1,R0,ddx,HerW,HerR2,IsChi,ChiI2) +!*********************************************************************** +! * +! Object: to compute the primitive integrals of type (ss|sp). * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. 1994 * +!*********************************************************************** + +use Constants, only: Zero, One, Ten +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, lP, nEta, lQ, nPntr, iPntr(nPntr), nMax, IsChi +real(kind=wp), intent(out) :: EFInt(nZeta,nEta,3) +real(kind=wp), intent(in) :: Zeta(nZeta), P(lP,3), rKappAB(nZeta), A(3), B(3), Eta(nEta), Q(lQ,3), rKappCD(nEta), C(3), D(3), & + CoorAC(3,2), TMax, x0(nMax), W6(nMax), W5(nMax), W4(nMax), W3(nMax), W2(nMax), W1(nMax), W0(nMax), & + R6(nMax), R5(nMax), R4(nMax), R3(nMax), R2(nMax), R1(nMax), R0(nMax), ddx, HerW, HerR2, ChiI2 +integer(kind=iwp) :: iEta, iZeta, n +real(kind=wp) :: dddx, PQ2, PQx, PQy, PQz, PreFct, QCPQx, QCPQy, QCPQz, r, rho, T, w, xdInv, z, ZE, ZEInv, Zu2 +logical(kind=iwp) :: ABeqCD +logical(kind=iwp), external :: EQ + +xdInv = One/ddx +dddx = ddx/Ten+ddx + +ABeqCD = EQ(A,B) .and. EQ(A,C) .and. EQ(A,D) + +if (ABeqCD) then + + ! CCCC case + + EFInt(:,:,:) = Zero + +else if (EQ(C,D)) then + + ! ABCC case + + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + ZE = Zeta(iZeta)*Eta(iEta) + rho = ZE*ZEInv + PQx = (P(iZeta,1)-CoorAC(1,2)) + PQy = (P(iZeta,2)-CoorAC(2,2)) + PQz = (P(iZeta,3)-CoorAC(3,2)) + PQ2 = PQx**2+PQy**2+PQz**2 + T = rho*PQ2 + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w = (((((W6(n)*z+W5(n))*z+W4(n))*z+W3(n))*z+W2(n))*z+W1(n))*z+w0(n) + r = (((((R6(n)*z+R5(n))*z+R4(n))*z+R3(n))*z+R2(n))*z+R1(n))*z+R0(n) + Zu2 = r*(Zeta(iZeta)*ZEInv) + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv)*w + else + Zu2 = HerR2/(Eta(iEta)*PQ2) + PreFct = rKappCD(iEta)*rKappAB(iZeta)*HerW/sqrt(ZE*PQ2) + end if + EFInt(iZeta,iEta,1) = PreFct*Zu2*PQx + EFInt(iZeta,iEta,2) = PreFct*Zu2*PQy + EFInt(iZeta,iEta,3) = PreFct*Zu2*PQz + end do + end do + +else + + ! ABCD case + + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + ZE = Zeta(iZeta)*Eta(iEta) + rho = ZE*ZEInv + PQx = P(iZeta,1)-Q(iEta,1) + PQy = P(iZeta,2)-Q(iEta,2) + PQz = P(iZeta,3)-Q(iEta,3) + PQ2 = PQx**2+PQy**2+PQz**2 + T = rho*PQ2 + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w = (((((W6(n)*z+W5(n))*z+W4(n))*z+W3(n))*z+W2(n))*z+W1(n))*z+w0(n) + r = (((((R6(n)*z+R5(n))*z+R4(n))*z+R3(n))*z+R2(n))*z+R1(n))*z+R0(n) + Zu2 = r*(Zeta(iZeta)*ZEInv) + PreFct = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv)*w + else + Zu2 = HerR2/(Eta(iEta)*PQ2) + PreFct = rKappCD(iEta)*rKappAB(iZeta)*HerW/sqrt(ZE*PQ2) + end if + QCPQx = Q(iEta,1)-CoorAC(1,2)+Zu2*PQx + QCPQy = Q(iEta,2)-CoorAC(2,2)+Zu2*PQy + QCPQz = Q(iEta,3)-CoorAC(3,2)+Zu2*PQz + EFInt(iZeta,iEta,1) = PreFct*QCPQx + EFInt(iZeta,iEta,2) = PreFct*QCPQy + EFInt(iZeta,iEta,3) = PreFct*QCPQz + end do + end do + +end if + +return + +end subroutine sssp diff -Nru openmolcas-22.02/src/rys_util/ssss.f openmolcas-22.10/src/rys_util/ssss.f --- openmolcas-22.02/src/rys_util/ssss.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ssss.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,82 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1994, Roland Lindh * -************************************************************************ - Subroutine ssss(EFInt,Zeta,nZeta,P,lP,rKappAB,A,B, - & Eta, nEta,Q,lQ,rKappCD,C,D,TMax, - & iPntr,nPntr,x0,nMax,W6,W5,W4,W3,W2,W1,W0,ddx,HerW, - & IsChi,ChiI2) -************************************************************************ -* * -* Object: to compute the primitive integrals of type (ss|ss). * -* * -* Author: Roland Lindh, Dept. of Theoretical Chemistry, University * -* of Lund, SWEDEN. 1994 * -************************************************************************ - Implicit Real*8 (a-h,o-z) -#include "real.fh" - Real*8 EFInt(nZeta,nEta), Zeta(nZeta), Eta(nEta), - & P(lP,3), Q(lQ,3), A(3), B(3), C(3), D(3), - & rKappAB(nZeta), rKappCD(nEta), - & x0(nMax), W6(nMax), W5(nMax), - & W4(nMax), W3(nMax), W2(nMax), W1(nMax), W0(nMax) - Integer iPntr(nPntr) - Logical ABeqCD, EQ -* -* - xdInv=One/ddx - dddx = ddx/10d0 + ddx -* - ABeqCD = EQ(A,B) .and. EQ(A,C) .and. EQ(A,D) - If (ABeqCD) Go To 100 -* - Do 10 iEta = 1, nEta - Do 20 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - ZE = Zeta(iZeta)*Eta(iEta) - rho = ZE*ZEInv - PQ2 = (P(iZeta,1)-Q(iEta,1))**2 - & + (P(iZeta,2)-Q(iEta,2))**2 - & + (P(iZeta,3)-Q(iEta,3))**2 - T = rho*PQ2 - If (T.lt.TMax) Then - n = iPntr(Int((T+dddx)*xdInv)) - z = T - x0(n) - w =(((((W6(n)*z+W5(n))*z+W4(n))*z+W3(n))*z+W2(n)) - & *z+W1(n))*z+w0(n) - EFInt(iZeta,iEta) = rKappCD(iEta) * rKappAB(iZeta) - & * Sqrt(ZEInv) * w - Else - EFInt(iZeta,iEta) = rKappCD(iEta) * rKappAB(iZeta) - & * HerW * Sqrt(One/(ZE*PQ2)) - End If - 20 Continue - 10 Continue - Go To 99 -* - 100 Continue - z = - x0(1) - w =(((((W6(1)*z+W5(1))*z+W4(1))*z+W3(1))*z+W2(1)) - & *z+W1(1))*z+w0(1) - Do 11 iEta = 1, nEta - Do 21 iZeta = 1, nZeta - ZEInv = One/(Eta(iEta)+Zeta(iZeta) - > +(Eta(iEta)*Zeta(iZeta)*ChiI2)*Dble(IsChi)) - EFInt(iZeta,iEta) = rKappCD(iEta) * rKappAB(iZeta) - & * Sqrt(ZEInv) * w - 21 Continue - 11 Continue -* - 99 Continue -* - Return - End diff -Nru openmolcas-22.02/src/rys_util/ssss.F90 openmolcas-22.10/src/rys_util/ssss.F90 --- openmolcas-22.02/src/rys_util/ssss.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/ssss.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,77 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1994, Roland Lindh * +!*********************************************************************** + +subroutine ssss(EFInt,Zeta,nZeta,P,lP,rKappAB,A,B,Eta,nEta,Q,lQ,rKappCD,C,D,TMax,iPntr,nPntr,x0,nMax,W6,W5,W4,W3,W2,W1,W0,ddx, & + HerW,IsChi,ChiI2) +!*********************************************************************** +! * +! Object: to compute the primitive integrals of type (ss|ss). * +! * +! Author: Roland Lindh, Dept. of Theoretical Chemistry, University * +! of Lund, SWEDEN. 1994 * +!*********************************************************************** + +use Constants, only: One, Ten +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nZeta, lP, nEta, lQ, nPntr, iPntr(nPntr), nMax, IsChi +real(kind=wp), intent(out) :: EFInt(nZeta,nEta) +real(kind=wp), intent(in) :: Zeta(nZeta), P(lP,3), rKappAB(nZeta), A(3), B(3), Eta(nEta), Q(lQ,3), rKappCD(nEta), C(3), D(3), & + TMax, x0(nMax), W6(nMax), W5(nMax), W4(nMax), W3(nMax), W2(nMax), W1(nMax), W0(nMax), ddx, HerW, ChiI2 +integer(kind=iwp) :: iEta, iZeta, n +real(kind=wp) :: dddx, PQ2, rho, T, w, xdInv, z, ZE, ZEInv +logical(kind=iwp) :: ABeqCD +logical(kind=iwp), external :: EQ + +xdInv = One/ddx +dddx = ddx/Ten+ddx + +ABeqCD = EQ(A,B) .and. EQ(A,C) .and. EQ(A,D) + +if (ABeqCD) then + + z = -x0(1) + w = (((((W6(1)*z+W5(1))*z+W4(1))*z+W3(1))*z+W2(1))*z+W1(1))*z+w0(1) + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + EFInt(iZeta,iEta) = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv)*w + end do + end do + +else + + do iEta=1,nEta + do iZeta=1,nZeta + ZEInv = One/(Eta(iEta)+Zeta(iZeta)+(Eta(iEta)*Zeta(iZeta)*ChiI2)*real(IsChi,kind=wp)) + ZE = Zeta(iZeta)*Eta(iEta) + rho = ZE*ZEInv + PQ2 = (P(iZeta,1)-Q(iEta,1))**2+(P(iZeta,2)-Q(iEta,2))**2+(P(iZeta,3)-Q(iEta,3))**2 + T = rho*PQ2 + if (T < TMax) then + n = iPntr(int((T+dddx)*xdInv)) + z = T-x0(n) + w = (((((W6(n)*z+W5(n))*z+W4(n))*z+W3(n))*z+W2(n))*z+W1(n))*z+w0(n) + EFInt(iZeta,iEta) = rKappCD(iEta)*rKappAB(iZeta)*sqrt(ZEInv)*w + else + EFInt(iZeta,iEta) = rKappCD(iEta)*rKappAB(iZeta)*HerW*sqrt(One/(ZE*PQ2)) + end if + end do + end do + +end if + +return + +end subroutine ssss diff -Nru openmolcas-22.02/src/rys_util/teri1.f openmolcas-22.10/src/rys_util/teri1.f --- openmolcas-22.02/src/rys_util/teri1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/teri1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine TERI1(Zeta,Eta,P,Q,nT,T,ZEInv,IsChi,ChiI2) -************************************************************************ -* * -* Object: to entities for the two-electron integrals which are used in * -* in the Rys quadrature to evaluate these integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Zeta(nT), Eta(nT), P(nT,3), Q(nT,3), - & T(nT), ZEInv(nT) -* -#ifdef _DEBUGPRINT_ - iRout = 56 - iPrint = nPrint(iRout) - If (iPrint.ge.99) Then - Call RecPrt(' Zeta in TERI1',' ',Zeta,nT,1) - Call RecPrt(' Eta in TERI1',' ',Eta,nT,1) - Call RecPrt(' P in TERI1',' ',P,nT,3) - Call RecPrt(' Q in TERI1',' ',Q,nT,3) - End If -#endif -* - Do iT = 1, nT - tmp = 1.0d0/(Zeta(iT)+Eta(iT) - & +(Eta(iT)*Zeta(iT)*ChiI2)*Dble(IsChi)) - ZEInv(iT) = tmp - Rho = Zeta(iT)*Eta(iT)*tmp - PQ2 = (P(iT,1)-Q(iT,1))**2 - & + (P(iT,2)-Q(iT,2))**2 - & + (P(iT,3)-Q(iT,3))**2 - T(iT) = Rho*PQ2 - End Do -* -#ifdef _DEBUGPRINT_ - If (iPrint.ge.99) Then - Call RecPrt('Tvalue',' ',T,nT,1) - End If -#endif - Return - End diff -Nru openmolcas-22.02/src/rys_util/teri1.F90 openmolcas-22.10/src/rys_util/teri1.F90 --- openmolcas-22.02/src/rys_util/teri1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/teri1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,62 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine TERI1(Zeta,Eta,P,Q,nT,T,ZEInv,IsChi,ChiI2) +!*********************************************************************** +! * +! Object: to entities for the two-electron integrals which are used in * +! in the Rys quadrature to evaluate these integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +!*********************************************************************** + +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nT, IsChi +real(kind=wp), intent(in) :: Zeta(nT), Eta(nT), P(nT,3), Q(nT,3), ChiI2 +real(kind=wp), intent(out) :: T(nT), ZEInv(nT) +integer(kind=iwp) :: iT +real(kind=wp) :: PQ2, Rho, tmp + +#ifdef _DEBUGPRINT_ +iRout = 56 +iPrint = nPrint(iRout) +if (iPrint >= 99) then + call RecPrt(' Zeta in TERI1',' ',Zeta,nT,1) + call RecPrt(' Eta in TERI1',' ',Eta,nT,1) + call RecPrt(' P in TERI1',' ',P,nT,3) + call RecPrt(' Q in TERI1',' ',Q,nT,3) +end if +#endif + +do iT=1,nT + tmp = One/(Zeta(iT)+Eta(iT)+(Eta(iT)*Zeta(iT)*ChiI2)*real(IsChi,kind=wp)) + ZEInv(iT) = tmp + Rho = Zeta(iT)*Eta(iT)*tmp + PQ2 = (P(iT,1)-Q(iT,1))**2+(P(iT,2)-Q(iT,2))**2+(P(iT,3)-Q(iT,3))**2 + T(iT) = Rho*PQ2 +end do + +#ifdef _DEBUGPRINT_ +if (iPrint >= 99) then + call RecPrt('Tvalue',' ',T,nT,1) +end if +#endif + +return + +end subroutine TERI1 diff -Nru openmolcas-22.02/src/rys_util/teri.f openmolcas-22.10/src/rys_util/teri.f --- openmolcas-22.02/src/rys_util/teri.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/teri.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,58 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine TERI(Zeta,Eta,P,Q,rKapab,rKapcd,T,Fact,ZEInv,nT,IsChi, - & ChiI2) -************************************************************************ -* * -* Object: to entities for the two-electron integrals which are used in * -* in the Rys quadrature to evaluate these integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) - Intrinsic Sqrt -#include "print.fh" -#include "real.fh" - Real*8 Zeta(nT), Eta(nT), P(nT,3), Q(nT,3), - & rKapab(nT), rKapcd(nT), - & T(nT), Fact(nT), ZEInv(nT) -* -*define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Call RecPrt(' Zeta in TERI',' ',Zeta,1,nT) - Call RecPrt(' Eta in TERI',' ',Eta,1,nT) - Call RecPrt(' P in TERI',' ',P,nT,3) - Call RecPrt(' Q in TERI',' ',Q,nT,3) - Call RecPrt(' Kab in TERI',' ',rKapab,1,nT) - Call RecPrt(' Kcd in TERI',' ',rKapcd,1,nT) -#endif -* - Do iT = 1, nT - tmp = 1.0D0/(Zeta(iT)+Eta(iT) - > +(Eta(iT)*Zeta(iT)*ChiI2)*Dble(IsChi)) - ZEInv(iT) = tmp - Rho = Zeta(iT)*Eta(iT)*tmp - PQ2 = (P(iT,1)-Q(iT,1))**2 - & + (P(iT,2)-Q(iT,2))**2 - & + (P(iT,3)-Q(iT,3))**2 - T(iT) = Rho*PQ2 - Fact(iT) = rKapab(iT) * rKapcd(iT) * Sqrt(tmp) - End Do -#ifdef _DEBUGPRINT_ - Call RecPrt('Tvalue',' ',T,1,nT) - Call RecPrt('Fact ',' ',Fact,1,nT) -#endif - Return - End diff -Nru openmolcas-22.02/src/rys_util/teri.F90 openmolcas-22.10/src/rys_util/teri.F90 --- openmolcas-22.02/src/rys_util/teri.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/teri.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,60 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine TERI(Zeta,Eta,P,Q,rKapab,rKapcd,T,Fact,ZEInv,nT,IsChi,ChiI2) +!*********************************************************************** +! * +! Object: to entities for the two-electron integrals which are used in * +! in the Rys quadrature to evaluate these integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +!*********************************************************************** + +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nT, IsChi +real(kind=wp), intent(in) :: Zeta(nT), Eta(nT), P(nT,3), Q(nT,3), rKapab(nT), rKapcd(nT), ChiI2 +real(kind=wp), intent(out) :: T(nT), Fact(nT), ZEInv(nT) +integer(kind=iwp) :: iT +real(kind=wp) :: PQ2, Rho, tmp + +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +call RecPrt(' Zeta in TERI',' ',Zeta,1,nT) +call RecPrt(' Eta in TERI',' ',Eta,1,nT) +call RecPrt(' P in TERI',' ',P,nT,3) +call RecPrt(' Q in TERI',' ',Q,nT,3) +call RecPrt(' Kab in TERI',' ',rKapab,1,nT) +call RecPrt(' Kcd in TERI',' ',rKapcd,1,nT) +#endif + +do iT=1,nT + tmp = One/(Zeta(iT)+Eta(iT)+(Eta(iT)*Zeta(iT)*ChiI2)*real(IsChi,kind=wp)) + ZEInv(iT) = tmp + Rho = Zeta(iT)*Eta(iT)*tmp + PQ2 = (P(iT,1)-Q(iT,1))**2+(P(iT,2)-Q(iT,2))**2+(P(iT,3)-Q(iT,3))**2 + T(iT) = Rho*PQ2 + Fact(iT) = rKapab(iT)*rKapcd(iT)*sqrt(tmp) +end do +#ifdef _DEBUGPRINT_ +call RecPrt('Tvalue',' ',T,1,nT) +call RecPrt('Fact ',' ',Fact,1,nT) +#endif + +return + +end subroutine TERI diff -Nru openmolcas-22.02/src/rys_util/teris.f openmolcas-22.10/src/rys_util/teris.f --- openmolcas-22.02/src/rys_util/teris.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/teris.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,67 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine TERIS(Zeta,Eta,P,Q,rKapab,rKapcd,T,Fact,ZEInv,nT,IsChi, - & ChiI2) -************************************************************************ -* * -* Object: compute the arguments for the reduced list of integrals which* -* are used in prescreening. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* June '91, modified for k2 loop. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Zeta(nT), P(nT,3), rKapab(nT), T(nT), Fact(nT), - & ZEInv(nT) -* -#ifdef _DEBUGPRINT_ - iRout = 244 - iPrint = nPrint(iRout) - If (iPrint.ge.99) Then - Call RecPrt(' Zeta in TERIS',' ',Zeta,nT,1) - Call RecPrt(' P in TERIS',' ',P,nT,3) - Call RecPrt(' Kab in TERIS',' ',rKapab,nT,1) - End If -#endif -* - Do iT = 1, nT - T(iT) = 0.0D0 - tmp = 1.0D0/(Zeta(iT)+Zeta(iT) - > +(Zeta(iT)*Zeta(iT)*ChiI2)*Dble(IsChi)) - ZEInv(iT) = tmp - Fact(iT) = rKapab(iT) **2 * Sqrt(tmp) - End Do -* -#ifdef _DEBUGPRINT_ - If (iPrint.ge.99) Then - Call RecPrt('In TERIS: Tvalue',' ',T,nT,1) - Call RecPrt('In TERIS: Fact ',' ',Fact,nT,1) - End If -#else -c Avoid unused argument warnings - If (.False.) Call Unused_real_array(P) -#endif -* - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real(Eta) - Call Unused_real(Q) - Call Unused_real(rKapcd) - End If - End diff -Nru openmolcas-22.02/src/rys_util/teris.F90 openmolcas-22.10/src/rys_util/teris.F90 --- openmolcas-22.02/src/rys_util/teris.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/teris.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,68 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine TERIS(Zeta,Eta,P,Q,rKapab,rKapcd,T,Fact,ZEInv,nT,IsChi,ChiI2) +!*********************************************************************** +! * +! Object: compute the arguments for the reduced list of integrals which* +! are used in prescreening. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! June '91, modified for k2 loop. * +!*********************************************************************** + +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nT, IsChi +real(kind=wp), intent(in) :: Zeta(nT), Eta(nT), P(nT,3), Q(nT,3), rKapab(nT), rKapcd(nT), ChiI2 +real(kind=wp), intent(out) :: T(nT), Fact(nT), ZEInv(nT) +integer(kind=iwp) :: iT +real(kind=wp) :: tmp + +#include "macros.fh" +unused_var(Eta) +unused_var(P) +unused_var(Q) +unused_var(rKapcd) + +#ifdef _DEBUGPRINT_ +iRout = 244 +iPrint = nPrint(iRout) +if (iPrint >= 99) then + call RecPrt(' Zeta in TERIS',' ',Zeta,nT,1) + call RecPrt(' Kab in TERIS',' ',rKapab,nT,1) +end if +#endif + +T(:) = Zero +do iT=1,nT + tmp = One/(Zeta(iT)+Zeta(iT)+(Zeta(iT)*Zeta(iT)*ChiI2)*real(IsChi,kind=wp)) + ZEInv(iT) = tmp + Fact(iT) = rKapab(iT)**2*sqrt(tmp) +end do + +#ifdef _DEBUGPRINT_ +if (iPrint >= 99) then + call RecPrt('In TERIS: Tvalue',' ',T,nT,1) + call RecPrt('In TERIS: Fact ',' ',Fact,nT,1) +end if +#endif + +return + +end subroutine TERIS diff -Nru openmolcas-22.02/src/rys_util/terisq.f openmolcas-22.10/src/rys_util/terisq.f --- openmolcas-22.02/src/rys_util/terisq.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/terisq.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,68 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1992, Roland Lindh * -************************************************************************ - SubRoutine TERISq(Zeta,Eta,P,Q,rKapab,rKapcd,T,Fact,ZEInv,nT, - & IsChi,ChiI2) -************************************************************************ -* * -* Object: to entities for the two-electron integrals which are used in * -* in the Rys quadrature to evaluate these integrals. * -* * -* OBSERVE that the prefactor is only partial!!! * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* May '92 Modified to fit 2nd order differential scheme for* -* the gradient estimates. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "print.fh" -#include "real.fh" - Real*8 Zeta(nT), Eta(nT), P(nT,3), Q(nT,3), - & rKapab(nT), rKapcd(nT), - & T(nT), Fact(nT), ZEInv(nT) -* -#ifdef _DEBUGPRINT_ - iRout = 56 - iPrint = nPrint(iRout) - If (iPrint.ge.99) Then - Call RecPrt(' Zeta in TERISq',' ',Zeta,nT,1) - Call RecPrt(' P in TERISq',' ',P,nT,3) - Call RecPrt(' Q in TERISq',' ',Q,nT,3) - Call RecPrt(' Kab in TERISq',' ',rKapab,nT,1) - Call RecPrt(' Kcd in TERISq',' ',rKapcd,nT,1) - End If -#endif -* - Do iT = 1, nT - tmp = 1.0D0/(Zeta(iT)+Zeta(iT) - > +(Zeta(iT)*Zeta(iT)*ChiI2)*Dble(IsChi)) - ZEInv(iT) = tmp - Rho = Zeta(iT)*Zeta(iT)*tmp - PQ2 = (P(iT,1)-Q(iT,1))**2 - & + (P(iT,2)-Q(iT,2))**2 - & + (P(iT,3)-Q(iT,3))**2 - T(iT) = Rho*PQ2 - Fact(iT) = rKapab(iT) * rKapcd(iT) - End Do -* -#ifdef _DEBUGPRINT_ - If (iPrint.ge.99) Then - Call RecPrt('Tvalue',' ',T,nT,1) - Call RecPrt('Fact ',' ',Fact,nT,1) - End If -#endif - Return -c Avoid unused argument warnings - If (.False.) Call Unused_real_array(Eta) - End diff -Nru openmolcas-22.02/src/rys_util/terisq.F90 openmolcas-22.10/src/rys_util/terisq.F90 --- openmolcas-22.02/src/rys_util/terisq.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/terisq.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,72 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1992, Roland Lindh * +!*********************************************************************** + +subroutine TERISq(Zeta,Eta,P,Q,rKapab,rKapcd,T,Fact,ZEInv,nT,IsChi,ChiI2) +!*********************************************************************** +! * +! Object: to compute entities for the two-electron integrals which are * +! used in the Rys quadrature to evaluate these integrals. * +! * +! OBSERVE that the prefactor is only partial!!! * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! May '92 Modified to fit 2nd order differential scheme for* +! the gradient estimates. * +!*********************************************************************** + +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nT, IsChi +real(kind=wp), intent(in) :: Zeta(nT), Eta(nT), P(nT,3), Q(nT,3), rKapab(nT), rKapcd(nT), ChiI2 +real(kind=wp), intent(out) :: T(nT), Fact(nT), ZEInv(nT) +integer(kind=iwp) :: iT +real(kind=wp) :: PQ2, Rho, tmp + +#include "macros.fh" +unused_var(Eta) + +#ifdef _DEBUGPRINT_ +iRout = 56 +iPrint = nPrint(iRout) +if (iPrint >= 99) then + call RecPrt(' Zeta in TERISq',' ',Zeta,nT,1) + call RecPrt(' P in TERISq',' ',P,nT,3) + call RecPrt(' Q in TERISq',' ',Q,nT,3) + call RecPrt(' Kab in TERISq',' ',rKapab,nT,1) + call RecPrt(' Kcd in TERISq',' ',rKapcd,nT,1) +end if +#endif + +do iT=1,nT + tmp = One/(Zeta(iT)+Zeta(iT)+(Zeta(iT)*Zeta(iT)*ChiI2)*real(IsChi,kind=wp)) + ZEInv(iT) = tmp + Rho = Zeta(iT)*Zeta(iT)*tmp + PQ2 = (P(iT,1)-Q(iT,1))**2+(P(iT,2)-Q(iT,2))**2+(P(iT,3)-Q(iT,3))**2 + T(iT) = Rho*PQ2 +end do +Fact(:) = rKapab*rKapcd + +#ifdef _DEBUGPRINT_ +if (iPrint >= 99) then + call RecPrt('Tvalue',' ',T,nT,1) + call RecPrt('Fact ',' ',Fact,nT,1) +end if +#endif + +return + +end subroutine TERISq diff -Nru openmolcas-22.02/src/rys_util/tnai1.f openmolcas-22.10/src/rys_util/tnai1.f --- openmolcas-22.02/src/rys_util/tnai1.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/tnai1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1992, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine TNAI1(Zeta,Eta,P,Q,nT,T,ZEInv,IsChi,ChiI2) -************************************************************************ -* * -* Object: to entities for the nucelar attraction integrals which are * -* used in the Rys quadrature to evaluate these integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* March '92 modified to gradient calculation. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - Real*8 Zeta(nT), Eta(nT), P(nT,3), Q(nT,3), - & ZEInv(nT), T(nT) -* -#ifdef _DEBUGPRINT_ - iRout = 57 - iPrint = nPrint(iRout) - If (iPrint.ge.99) Then - Call RecPrt(' Zeta in TNAI1',' ',Zeta,nT,1) - Call RecPrt(' Eta in TNAI1',' ',Eta,nT,1) - Call RecPrt(' P in TNAI1',' ',P,nT,3) - Call RecPrt(' Q in TNAI1',' ',Q,nT,3) - End If -#endif - Do iT = 1, nT - PQ2 = (P(iT,1)-Q(iT,1))**2 - & + (P(iT,2)-Q(iT,2))**2 - & + (P(iT,3)-Q(iT,3))**2 - T(iT) = Zeta(iT)*PQ2 - ZEInv(iT) = 1.0D0/Zeta(iT) - End Do -* -#ifdef _DEBUGPRINT_ - If (iPrint.ge.99) Then - Call RecPrt('Tvalue',' ',T,nT,1) - End If -#endif -c Avoid unused argument warnings - If (.False.) Call Unused_real_array(Eta) - If (.False.) Call Unused_integer(IsChi) - If (.False.) Call Unused_real(ChiI2) - Return - End diff -Nru openmolcas-22.02/src/rys_util/tnai1.F90 openmolcas-22.10/src/rys_util/tnai1.F90 --- openmolcas-22.02/src/rys_util/tnai1.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/tnai1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,67 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1992, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine TNAI1(Zeta,Eta,P,Q,nT,T,ZEInv,IsChi,ChiI2) +!*********************************************************************** +! * +! Object: to compute entities for the nuclear attraction integrals * +! which are used in the Rys quadrature to evaluate these * +! integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! March '92 modified to gradient calculation. * +!*********************************************************************** + +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nT, IsChi +real(kind=wp), intent(in) :: Zeta(nT), Eta(nT), P(nT,3), Q(nT,3), ChiI2 +real(kind=wp), intent(out) :: T(nT), ZEInv(nT) +integer(kind=iwp) :: iT +real(kind=wp) :: PQ2 + +#include "macros.fh" +unused_var(Eta) +unused_var(IsChi) +unused_var(ChiI2) + +#ifdef _DEBUGPRINT_ +iRout = 57 +iPrint = nPrint(iRout) +if (iPrint >= 99) then + call RecPrt(' Zeta in TNAI1',' ',Zeta,nT,1) + call RecPrt(' Eta in TNAI1',' ',Eta,nT,1) + call RecPrt(' P in TNAI1',' ',P,nT,3) + call RecPrt(' Q in TNAI1',' ',Q,nT,3) +end if +#endif +do iT=1,nT + PQ2 = (P(iT,1)-Q(iT,1))**2+(P(iT,2)-Q(iT,2))**2+(P(iT,3)-Q(iT,3))**2 + T(iT) = Zeta(iT)*PQ2 +end do +ZEInv(:) = One/Zeta + +#ifdef _DEBUGPRINT_ +if (iPrint >= 99) then + call RecPrt('Tvalue',' ',T,nT,1) +end if +#endif + +return + +end subroutine TNAI1 diff -Nru openmolcas-22.02/src/rys_util/tnai.f openmolcas-22.10/src/rys_util/tnai.f --- openmolcas-22.02/src/rys_util/tnai.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/tnai.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,67 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine TNAI(Zeta,Eta,P,Q,rKapab,rKapcd,T,Fact,ZEInv,nT,IsChi, - & ChiI2) -************************************************************************ -* * -* Object: to entities for the nucelar attraction integrals which are * -* used in the Rys quadrature to evaluate these integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - Real*8 Zeta(nT), Eta(nT), P(nT,3), Q(nT,3), - & rKapab(nT), rKapcd(nT), ZEInv(nT), T(nT), Fact(nT) -* -#ifdef _DEBUGPRINT_ - iRout = 57 - iPrint = nPrint(iRout) - If (iPrint.ge.99) Then - Call RecPrt(' Zeta in TNAI',' ',Zeta,nT,1) - Call RecPrt(' Eta in TNAI',' ',Eta,nT,1) - Call RecPrt(' P in TNAI',' ',P,nT,3) - Call RecPrt(' Q in TNAI',' ',Q,nT,3) - Call RecPrt(' Kab in TNAI',' ',rKapab,nT,1) - Call RecPrt(' Kcd in TNAI',' ',rKapcd,nT,1) - Write (6,*) ' In TNAI: ABeqCD=',ABeqCD - End If -#endif - Do iT = 1, nT - PQ2 = (P(iT,1)-Q(iT,1))**2 - & + (P(iT,2)-Q(iT,2))**2 - & + (P(iT,3)-Q(iT,3))**2 - T(iT) = Zeta(iT)*PQ2 - ZEInv(iT) = 1.0D0/Zeta(iT) - Fact(iT) = 2.0D0*rKapab(iT)*Pi/Zeta(iT) - End Do -* -#ifdef _DEBUGPRINT_ - If (iPrint.ge.99) Then - Call RecPrt('Tvalue',' ',T,nT,1) - Call RecPrt('Fact ',' ',Fact,nT,1) - End If -#endif -c Avoid unused argument warnings - If (.False.) Then - Call Unused_real_array(Eta) - Call Unused_real_array(rKapcd) - Call Unused_integer(IsChi) - Call Unused_real(ChiI2) - End If - - Return - End diff -Nru openmolcas-22.02/src/rys_util/tnai.F90 openmolcas-22.10/src/rys_util/tnai.F90 --- openmolcas-22.02/src/rys_util/tnai.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/tnai.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,74 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine TNAI(Zeta,Eta,P,Q,rKapab,rKapcd,T,Fact,ZEInv,nT,IsChi,ChiI2) +!*********************************************************************** +! * +! Object: to compute entities for the nuclear attraction integrals * +! which are used in the Rys quadrature to evaluate these * +! integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +!*********************************************************************** + +use Constants, only: One, Two, Pi +use Definitions, only: wp, iwp +#ifdef _DEBUGPRINT_ +use Definitions, only: u6 +#endif + +implicit none +integer(kind=iwp), intent(in) :: nT, IsChi +real(kind=wp), intent(in) :: Zeta(nT), Eta(nT), P(nT,3), Q(nT,3), rKapab(nT), rKapcd(nT), ChiI2 +real(kind=wp), intent(out) :: T(nT), Fact(nT), ZEInv(nT) +integer(kind=iwp) :: iT +real(kind=wp) :: PQ2 + +#include "macros.fh" +unused_var(Eta) +unused_var(rKapcd) +unused_var(IsChi) +unused_var(ChiI2) + +#ifdef _DEBUGPRINT_ +iRout = 57 +iPrint = nPrint(iRout) +if (iPrint >= 99) then + call RecPrt(' Zeta in TNAI',' ',Zeta,nT,1) + call RecPrt(' Eta in TNAI',' ',Eta,nT,1) + call RecPrt(' P in TNAI',' ',P,nT,3) + call RecPrt(' Q in TNAI',' ',Q,nT,3) + call RecPrt(' Kab in TNAI',' ',rKapab,nT,1) + call RecPrt(' Kcd in TNAI',' ',rKapcd,nT,1) + write(u6,*) ' In TNAI: ABeqCD=',ABeqCD +end if +#endif +do iT=1,nT + PQ2 = (P(iT,1)-Q(iT,1))**2+(P(iT,2)-Q(iT,2))**2+(P(iT,3)-Q(iT,3))**2 + T(iT) = Zeta(iT)*PQ2 +end do +ZEInv(:) = One/Zeta +Fact(:) = Two*rKapab*Pi*ZEInv + +#ifdef _DEBUGPRINT_ +if (iPrint >= 99) then + call RecPrt('Tvalue',' ',T,nT,1) + call RecPrt('Fact ',' ',Fact,nT,1) +end if +#endif + +return + +end subroutine TNAI diff -Nru openmolcas-22.02/src/rys_util/vcff2d.f openmolcas-22.10/src/rys_util/vcff2d.f --- openmolcas-22.02/src/rys_util/vcff2d.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/vcff2d.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,261 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991,1994, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine vCff2D(iDum1 ,iDum2 ,nRys, - & Zeta,ZInv,Eta,EInv,nT, - & Coori,CoorAC,P,Q, - & la,lb,lc,ld, - & U2,PAQP,QCPQ,B10,B00,lac,B01) -************************************************************************ -* * -* Object: to compute the coefficients in the three terms recurrence * -* relation of the 2D-integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* Modified loop structure for RISC 1991 * -* Modified for decreased memory access January '94. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - Real*8 Zeta(nT), ZInv(nT), Eta(nT), EInv(nT), - & Coori(3,4), CoorAC(3,2), - & P(nT,3), Q(nT,3), U2(nRys,nT), - & PAQP(nRys,nT,3), QCPQ(nRys,nT,3), - & B10(nRys,nT), - & B00(nRys,nT), - & B01(nRys,nT) - Real*8 tmp -*define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ -* Local arrays - Character*30 Label -#endif - Logical AeqB, CeqD, EQ -* -#ifdef _DEBUGPRINT_ - Logical PrintB10, PrintB00, PrintB01 - Call RecPrt(' In vCff2D: Coori',' ',Coori,3,4) - Call RecPrt(' In vCff2D: U2',' ',U2,nRys,nT) - Call RecPrt(' in vCff2d: Zeta',' ',Zeta,1,nT) - Call RecPrt(' in vCff2d: Eta ',' ',Eta, 1,nT) - Call RecPrt(' in vCff2d: ZInv',' ',ZInv,1,nT) - Call RecPrt(' in vCff2d: EInv',' ',EInv,1,nT) -#endif - AeqB = EQ(Coori(1,1),Coori(1,2)) - CeqD = EQ(Coori(1,3),Coori(1,4)) -#ifdef _DEBUGPRINT_ - PrintB10=.False. - PrintB01=.False. - PrintB00=.False. -#endif -* - nabMax = la+lb - ncdMax = lc+ld - h12 = Half - If (nabMax.ge.2 .and. ncdMax.ge.2) Then - Do iT = 1, nT - Do iRys = 1, nRys - tmp=h12 * U2(iRys,iT) - B00(iRys,iT) = tmp - B10(iRys,iT) = ( h12 - tmp * Eta(iT))*ZInv(iT) - B01(iRys,iT) = ( h12 - tmp * Zeta(iT))*EInv(iT) - EndDo - EndDo -#ifdef _DEBUGPRINT_ - PrintB10=.True. - PrintB01=.True. - PrintB00=.True. -#endif - Else If (ncdMax.eq.0 .and. nabMax.ge.2) Then - Do iT = 1, nT - Do iRys = 1, nRys - B10(iRys,iT) = ( h12 - h12 * U2(iRys,iT) * Eta(iT))*ZInv(iT) - EndDo - EndDo -#ifdef _DEBUGPRINT_ - PrintB10=.True. -#endif - Else If (nabMax.eq.0 .and. ncdMax.ge.2) Then - Do iT = 1, nT - Do iRys = 1, nRys - B01(iRys,iT) =( h12 - h12 * U2(iRys,iT) * Zeta(iT))*EInv(iT) - EndDo - EndDo -#ifdef _DEBUGPRINT_ - PrintB01=.True. -#endif - Else If (ncdMax.eq.1 .and. nabMax.ge.2) Then - Do iT = 1, nT - Do iRys = 1, nRys - tmp=h12 * U2(iRys,iT) - B00(iRys,iT) = tmp - B10(iRys,iT) = ( h12 - tmp * Eta(iT))*ZInv(iT) - EndDo - EndDo -#ifdef _DEBUGPRINT_ - PrintB10=.True. - PrintB00=.True. -#endif - Else If (nabMax.eq.1 .and. ncdMax.ge.2) Then - Do iT = 1, nT - Do iRys = 1, nRys - tmp=h12 * U2(iRys,iT) - B00(iRys,iT) = tmp - B01(iRys,iT) = ( h12 - tmp * Zeta(iT))*EInv(iT) - EndDo - EndDo -#ifdef _DEBUGPRINT_ - PrintB01=.True. - PrintB00=.True. -#endif - Else If (nabMax.eq.1 .and. ncdMax.eq.1) Then - Do iT = 1, nT - Do iRys = 1, nRys - B00(iRys,iT) = h12*U2(iRys,iT) - EndDo - EndDo -#ifdef _DEBUGPRINT_ - PrintB00=.True. -#endif - End If -* - If (nabMax.ne.0 .and. ncdMax.ne.0) Then - If (.Not.AeqB .and. .Not.CeqD) Then - Do iCar = 1,3 - Do iT = 1, nT - Do iRys = 1, nRys - tmp=U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar)) - PAQP(iRys,iT,iCar) = - & P(iT,iCar) - CoorAC(iCar,1) + Eta(iT)*tmp - QCPQ(iRys,iT,iCar) = - & Q(iT,iCar) - CoorAC(iCar,2) - Zeta(iT)*tmp - EndDo - EndDo - EndDo - Else If (AeqB .and. .Not.CeqD) Then - Do iCar=1,3 - Do iT = 1, nT - Do iRys = 1, nRys - tmp=U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar)) - PAQP(iRys,iT,iCar) = Eta(iT)*tmp - QCPQ(iRys,iT,iCar) = - & Q(iT,iCar) - CoorAC(iCar,2) - Zeta(iT)*tmp - EndDo - EndDo - EndDo - Else If (.Not.AeqB .and. CeqD) Then - Do iCar=1,3 - Do iT = 1, nT - Do iRys = 1, nRys - tmp= U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar)) - PAQP(iRys,iT,iCar) = - & P(iT,iCar) - CoorAC(iCar,1) + Eta(iT)*tmp - QCPQ(iRys,iT,iCar) = - Zeta(iT)*tmp - EndDo - EndDo - EndDo - Else - Do iCar=1,3 - Do iT = 1, nT - Do iRys = 1, nRys - tmp=U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar)) - PAQP(iRys,iT,iCar) = Eta(iT)*tmp - QCPQ(iRys,iT,iCar) = - Zeta(iT)*tmp - EndDo - EndDo - EndDo - End If - Else If (nabMax.ne.0) Then - If (.Not.AeqB) Then - Do iCar=1,3 - Do iT = 1, nT - Do iRys = 1, nRys - PAQP(iRys,iT,iCar) = - & P(iT,iCar) - CoorAC(iCar,1) + Eta(iT) - & * (U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar))) - EndDo - EndDo - EndDo - Else - Do iCar=1,3 - Do iT = 1, nT - Do iRys = 1, nRys - PAQP(iRys,iT,iCar) = Eta(iT) - & * (U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar))) - EndDo - EndDo - EndDO - End If - Else If (ncdMax.ne.0) Then - If (.Not.CeqD) Then - Do iCar=1,3 - Do iT = 1, nT - Do iRys = 1, nRys - QCPQ(iRys,iT,iCar) = - & Q(iT,iCar) - CoorAC(iCar,2) - Zeta(iT) - & * (U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar))) - EndDo - EndDo - EndDO - Else - Do iCar=1,3 - Do iT = 1, nT - Do iRys = 1, nRys - QCPQ(iRys,iT,iCar) = - Zeta(iT) - & * (U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar))) - EndDo - EndDo - EndDo - End If - End If -#ifdef _DEBUGPRINT_ - If (la+lb.gt.0) Then - Write (Label,'(A)') ' PAQP(x)' -* Call RecPrt(Label,' ',PAQP(1,1,1),nRys,nT) - Write (Label,'(A)') ' PAQP(y)' -* Call RecPrt(Label,' ',PAQP(1,1,2),nRys,nT) - Write (Label,'(A)') ' PAQP(z)' -* Call RecPrt(Label,' ',PAQP(1,1,3),nRys,nT) - End If - If (lc+ld.gt.0) Then - Write (Label,'(A)') ' QCPQ(x)' -* Call RecPrt(Label,' ',QCPQ(1,1,1),nRys,nT) - Write (Label,'(A)') ' QCPQ(y)' -* Call RecPrt(Label,' ',QCPQ(1,1,2),nRys,nT) - Write (Label,'(A)') ' QCPQ(z)' -* Call RecPrt(Label,' ',QCPQ(1,1,3),nRys,nT) - End If - If (PrintB10) Then - Write (Label,'(A)') ' B10' - Call RecPrt(Label,' ',B10(1,1),nRys,nT) - End If - If (PrintB00) Then - Write (Label,'(A)') ' B00' - Call RecPrt(Label,' ',B00(1,1),nRys,nT) - End If - If (PrintB01) Then - Write (Label,'(A)') ' B01' - Call RecPrt(Label,' ',B01(1,1),nRys,nT) - End If -#endif - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(iDum1) - Call Unused_integer(iDum2) - Call Unused_integer(lac) - End If - End diff -Nru openmolcas-22.02/src/rys_util/vcff2d.F90 openmolcas-22.10/src/rys_util/vcff2d.F90 --- openmolcas-22.02/src/rys_util/vcff2d.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/vcff2d.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,193 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991,1994, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine vCff2D(nabMax,ncdMax,nRys,Zeta,ZInv,Eta,EInv,nT,Coori,CoorAC,P,Q,la,lb,lc,ld,U2,PAQP,QCPQ,B10,B00,lac,B01) +!*********************************************************************** +! * +! Object: to compute the coefficients in the three terms recurrence * +! relation of the 2D-integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! Modified loop structure for RISC 1991 * +! Modified for decreased memory access January '94. * +!*********************************************************************** + +use Constants, only: One, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nabMax, ncdMax, nRys, nT, la, lb, lc, ld, lac +real(kind=wp), intent(in) :: Zeta(nT), ZInv(nT), Eta(nT), EInv(nT), Coori(3,4), CoorAC(3,2), P(nT,3), Q(nT,3), U2(nRys,nT) +real(kind=wp), intent(inout) :: PAQP(nRys,nT,3), QCPQ(nRys,nT,3), B10(nRys,nT), B00(nRys,nT), B01(nRys,nT) +integer(kind=iwp) :: iCar, iT, nabMax_, ncdMax_ +logical(kind=iwp) :: AeqB, CeqD +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +logical(kind=iwp) :: PrintB00, PrintB01, PrintB10 +#endif +logical(kind=iwp), external :: EQ + +#include "macros.fh" +unused_var(nabMax) +unused_var(ncdMax) +unused_var(lac) + +#ifdef _DEBUGPRINT_ +call RecPrt(' In vCff2D: Coori',' ',Coori,3,4) +call RecPrt(' In vCff2D: U2',' ',U2,nRys,nT) +call RecPrt(' in vCff2d: Zeta',' ',Zeta,1,nT) +call RecPrt(' in vCff2d: Eta ',' ',Eta,1,nT) +call RecPrt(' in vCff2d: ZInv',' ',ZInv,1,nT) +call RecPrt(' in vCff2d: EInv',' ',EInv,1,nT) +#endif +AeqB = EQ(Coori(1,1),Coori(1,2)) +CeqD = EQ(Coori(1,3),Coori(1,4)) +#ifdef _DEBUGPRINT_ +PrintB10 = .false. +PrintB01 = .false. +PrintB00 = .false. +#endif + +nabMax_ = la+lb +ncdMax_ = lc+ld +if ((nabMax_ >= 2) .and. (ncdMax_ >= 2)) then + B00(:,:) = Half*U2 + do iT=1,nT + B10(:,iT) = Half*(One-U2(:,iT)*Eta(iT))*ZInv(iT) + B01(:,iT) = Half*(One-U2(:,iT)*Zeta(iT))*EInv(iT) + end do +# ifdef _DEBUGPRINT_ + PrintB10 = .true. + PrintB01 = .true. + PrintB00 = .true. +# endif +else if ((ncdMax_ == 0) .and. (nabMax_ >= 2)) then + do iT=1,nT + B10(:,iT) = Half*(One-U2(:,iT)*Eta(iT))*ZInv(iT) + end do +# ifdef _DEBUGPRINT_ + PrintB10 = .true. +# endif +else if ((nabMax_ == 0) .and. (ncdMax_ >= 2)) then + do iT=1,nT + B01(:,iT) = Half*(One-U2(:,iT)*Zeta(iT))*EInv(iT) + end do +# ifdef _DEBUGPRINT_ + PrintB01 = .true. +# endif +else if ((ncdMax_ == 1) .and. (nabMax_ >= 2)) then + B00(:,:) = Half*U2 + do iT=1,nT + B10(:,iT) = Half*(One-U2(:,iT)*Eta(iT))*ZInv(iT) + end do +# ifdef _DEBUGPRINT_ + PrintB10 = .true. + PrintB00 = .true. +# endif +else if ((nabMax_ == 1) .and. (ncdMax_ >= 2)) then + B00(:,:) = Half*U2 + do iT=1,nT + B01(:,iT) = Half*(One-U2(:,iT)*Zeta(iT))*EInv(iT) + end do +# ifdef _DEBUGPRINT_ + PrintB01 = .true. + PrintB00 = .true. +# endif +else if ((nabMax_ == 1) .and. (ncdMax_ == 1)) then + B00(:,:) = Half*U2 +# ifdef _DEBUGPRINT_ + PrintB00 = .true. +# endif +end if + +if ((nabMax_ /= 0) .and. (ncdMax_ /= 0)) then + if ((.not. AeqB) .and. (.not. CeqD)) then + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = P(iT,iCar)-CoorAC(iCar,1)+Eta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + QCPQ(:,iT,iCar) = Q(iT,iCar)-CoorAC(iCar,2)-Zeta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + end do + end do + else if (AeqB .and. (.not. CeqD)) then + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = Eta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + QCPQ(:,iT,iCar) = Q(iT,iCar)-CoorAC(iCar,2)-Zeta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + end do + end do + else if ((.not. AeqB) .and. CeqD) then + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = P(iT,iCar)-CoorAC(iCar,1)+Eta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + QCPQ(:,iT,iCar) = -Zeta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + end do + end do + else + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = Eta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + QCPQ(:,iT,iCar) = -Zeta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + end do + end do + end if +else if (nabMax_ /= 0) then + if (.not. AeqB) then + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = P(iT,iCar)-CoorAC(iCar,1)+Eta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + end do + end do + else + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = Eta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + end do + end do + end if +else if (ncdMax_ /= 0) then + if (.not. CeqD) then + do iCar=1,3 + do iT=1,nT + QCPQ(:,iT,iCar) = Q(iT,iCar)-CoorAC(iCar,2)-Zeta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + end do + end do + else + do iCar=1,3 + do iT=1,nT + QCPQ(:,iT,iCar) = -Zeta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + end do + end do + end if +end if +#ifdef _DEBUGPRINT_ +if (la+lb > 0) then + !call RecPrt(' PAQP(x)',' ',PAQP(:,:,1),nRys,nT) + !call RecPrt(' PAQP(y)',' ',PAQP(:,:,2),nRys,nT) + !call RecPrt(' PAQP(z)',' ',PAQP(:,:,3),nRys,nT) +end if +if (lc+ld > 0) then + !call RecPrt(' QCPQ(x)',' ',QCPQ(:,:,1),nRys,nT) + !call RecPrt(' QCPQ(y)',' ',QCPQ(:,:,2),nRys,nT) + !call RecPrt(' QCPQ(z)',' ',QCPQ(:,:,3),nRys,nT) +end if +if (PrintB10) call RecPrt(' B10',' ',B10(:,:),nRys,nT) +if (PrintB00) call RecPrt(' B00',' ',B00(:,:),nRys,nT) +if (PrintB01) call RecPrt(' B01',' ',B01(:,:),nRys,nT) +#endif + +return + +end subroutine vCff2D diff -Nru openmolcas-22.02/src/rys_util/vrys2d.f openmolcas-22.10/src/rys_util/vrys2d.f --- openmolcas-22.02/src/rys_util/vrys2d.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/vrys2d.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,335 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991,1994, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine vRys2D(xyz2D,nArg,lRys,nabMax,ncdMax,PAWP,QCWQ, - & B10,laa,B00,lac,B01,lcc) -************************************************************************ -* * -* Object: to compute the 2-dimensional integrals of the Rys * -* quadrature. The z components are assumed to be pre- * -* conditioned with the weights of the roots of the * -* Rys polynomial. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* Modified loop structure for RISC 1991 R. Lindh Dept. of Theoretical * -* Chemistry, University of Lund, Sweden. * -* Further modifications in Jan-Feb. 1994. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - Real*8 xyz2D(nArg*lRys*3,0:nabMax,0:ncdMax), - & PAWP(nArg*lRys*3), QCWQ(nArg*lRys*3), - & B10(nArg*lRys), B00(nArg*lRys), - & B01(nArg*lRys) - Logical lPAWP, lQCWQ -*define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Character*30 Label -* - If (nabMax.gt.0) Call RecPrt('PAWP',' ',PAWP,lRys,nArg*3) - If (ncdMax.gt.0) Call RecPrt('QCWQ',' ',QCWQ,lRys,nArg*3) - If (laa.ne.0) Call RecPrt(' B10',' ',B10,lRys,nArg) - If (lac.ne.0) Call RecPrt(' B00',' ',B00,lRys,nArg) - If (lcc.ne.0) Call RecPrt(' B01',' ',B01,lRys,nArg) -#endif -* - iOffy = nArg*lRys - iOffz = 2*nArg*lRys - If (nabMax.eq.0 .and. ncdMax.eq.0) Then - Else -* -*--------General code -* -*-----Store away PAWPz and QCPQz -* - lPAWP = nabMax.gt.2 - lQCWQ = ncdMax.gt.2 - If (nabMax.ge.1 .and. ncdMax.ge.1) Then - If (ncdMax.le.nabMax) Then - lPAWP = .True. - Else - lQCWQ = .True. - End If - End If - If (lPAWP) - & call dcopy_(nArg*lRys,PAWP(1+iOffz),1,xyz2D(1 ,0,0),1) - If (lQCWQ) - & call dcopy_(nArg*lRys,QCWQ(1+iOffz),1,xyz2D(1+iOffy,0,0),1) -* -* Compute 2D integrals with index (i,0) -* - If (nabMax.eq.0) Then -* - Else If (nabMax.eq.1) Then - Do 2000 i = 1, nArg*lRys - PAWPz = xyz2D(i+iOffz,1,0) - xyz2D(i+iOffz,1,0) = PAWPz*xyz2D(i+iOffz,0,0) - 2000 Continue - Else If (nabMax.ge.2) Then - Do 2001 i = 1, nArg*lRys - PAWPx = xyz2D(i,1,0) - xyz2D(i ,2,0) = PAWPx*xyz2D(i ,1,0) - & + B10(i) -* - PAWPy = xyz2D(i+iOffy,1,0) - xyz2D(i+iOffy,2,0) = PAWPy*xyz2D(i+iOffy,1,0) - & + B10(i) -* - PAWPz = xyz2D(i+iOffz,1,0) - xyz2D(i+iOffz,1,0) = PAWPz*xyz2D(i+iOffz,0,0) - xyz2D(i+iOffz,2,0) = PAWPz*xyz2D(i+iOffz,1,0) - & + B10(i)*xyz2D(i+iOffz,0,0) - 2001 Continue - If (nabMax.gt.2) Then - Fact = Two - Do 250 iab = 2, nabMax-1 - Do 260 i = 1, nArg*lRys - PAWPx = xyz2D(i ,1,0) - PAWPy = xyz2D(i+iOffy,1,0) - PAWPz = xyz2D(i ,0,0) - temp1x= PAWPx * xyz2D(i ,iab,0) - temp1y= PAWPy * xyz2D(i+iOffy,iab,0) - temp1z= PAWPz * xyz2D(i+iOffz,iab,0) - temp2x= Fact * B10(i) * xyz2D(i ,iab-1,0) - temp2y= Fact * B10(i) * xyz2D(i+iOffy,iab-1,0) - temp2z= Fact * B10(i) * xyz2D(i+iOffz,iab-1,0) - xyz2D(i ,iab+1,0) = temp1x + temp2x - xyz2D(i+iOffy,iab+1,0) = temp1y + temp2y - xyz2D(i+iOffz,iab+1,0) = temp1z + temp2z - 260 Continue - Fact = Fact + One - 250 Continue - End If - End If -* -* Compute 2D integrals with index (0,i) -* - If (ncdMax.eq.1) Then - Do 2002 i = 1, nArg*lRys -* - QCWQz = xyz2D(i+iOffz,0,1) - xyz2D(i+iOffz,0,1) = QCWQz*xyz2D(i+iOffz,0,0) - 2002 Continue - Else If (ncdMax.ge.2) Then - Do 2003 i = 1, nArg*lRys - QCWQx = xyz2D(i,0,1) - xyz2D(i ,0,2) = QCWQx*xyz2D(i ,0,1) - & + B01(i) -* - QCWQy = xyz2D(i+iOffy,0,1) - xyz2D(i+iOffy,0,2) = QCWQy*xyz2D(i+iOffy,0,1) - & + B01(i) -* - QCWQz = xyz2D(i+iOffz,0,1) - xyz2D(i+iOffz,0,1) = QCWQz*xyz2D(i+iOffz,0,0) - xyz2D(i+iOffz,0,2) = QCWQz*xyz2D(i+iOffz,0,1) - & + B01(i)*xyz2D(i+iOffz,0,0) - 2003 Continue - If (ncdMax.gt.2) Then - Fact = Two - Do 350 icd = 2, ncdMax-1 - Do 360 i = 1, nArg*lRys - QCWQx = xyz2D(i ,0,1) - QCWQy = xyz2D(i+iOffy,0,1) - QCWQz = xyz2D(i+iOffy,0,0) - temp1x= QCWQx * xyz2D(i ,0,icd) - temp1y= QCWQy * xyz2D(i+iOffy,0,icd) - temp1z= QCWQz * xyz2D(i+iOffz,0,icd) - temp2x= Fact * B01(i) * xyz2D(i ,0,icd-1) - temp2y= Fact * B01(i) * xyz2D(i+iOffy,0,icd-1) - temp2z= Fact * B01(i) * xyz2D(i+iOffz,0,icd-1) - xyz2D(i ,0,icd+1) = temp1x+ temp2x - xyz2D(i+iOffy,0,icd+1) = temp1y+ temp2y - xyz2D(i+iOffz,0,icd+1) = temp1z+ temp2z - 360 Continue - Fact = Fact + One - 350 Continue - End If - End If -* -* -* Compute 2D integrals with index (i,j) -* - If (ncdMax.le.nabMax) Then - Fac1 = One - Do 400 icd = 1, ncdMax - If (icd.eq.1) Then - Do 425 i = 1, nArg*lRys - PAWPx = xyz2D(i ,1,0) - PAWPy = xyz2D(i+iOffy,1,0) - PAWPz = xyz2D(i ,0,0) - xyz2D(i ,1,1) = PAWPx*xyz2D(i ,0,1) - & + B00(i) - xyz2D(i+iOffy,1,1) = PAWPy*xyz2D(i+iOffy,0,1) - & + B00(i) - xyz2D(i+iOffz,1,1) = PAWPz*xyz2D(i+iOffz,0,1) - & + B00(i)*xyz2D(i+iOffz,0,0) - 425 Continue - Else - Do 4251 i = 1, nArg*lRys - PAWPx = xyz2D(i ,1,0) - PAWPy = xyz2D(i+iOffy,1,0) - PAWPz = xyz2D(i, 0,0) - xyz2D(i ,1,icd) = PAWPx * xyz2D(i,0,icd) - & + Fac1 * B00(i) * xyz2D(i,0,icd-1) - xyz2D(i+iOffy,1,icd) = PAWPy * xyz2D(i+iOffy,0,icd) - & + Fac1* B00(i) * xyz2D(i+iOffy,0,icd-1) - xyz2D(i+iOffz,1,icd) = PAWPz * xyz2D(i+iOffz,0,icd) - & + Fac1* B00(i) * xyz2D(i+iOffz,0,icd-1) - 4251 Continue - End If - If (nabMax.eq.2) Then - Do 420 i = 1, nArg*lRys - PAWPx = xyz2D(i ,1,0) - PAWPy = xyz2D(i+iOffy,1,0) - PAWPz = xyz2D(i ,0,0) - xyz2D(i,2,icd) = - & PAWPx * xyz2D(i,1,icd) - & + B10(i) * xyz2D(i,0,icd) - & + Fac1 *B00(i) * xyz2D(i,1,icd-1) - xyz2D(i+iOffy,2,icd) = - & PAWPy * xyz2D(i+iOffy,1,icd) - & + B10(i) * xyz2D(i+iOffy,0,icd) - & + Fac1 *B00(i) * xyz2D(i+iOffy,1,icd-1) - xyz2D(i+iOffz,2,icd) = - & PAWPz * xyz2D(i+iOffz,1,icd) - & + B10(i) * xyz2D(i+iOffz,0,icd) - & + Fac1 *B00(i) * xyz2D(i+iOffz,1,icd-1) - 420 Continue - Else If (nabMax.gt.2) Then - Fac2 = One - Do 450 iab = 1, nabMax-1 - Do 460 i = 1, nArg*lRys - PAWPx = xyz2D(i ,1,0) - PAWPy = xyz2D(i+iOffy,1,0) - PAWPz = xyz2D(i ,0,0) - temp1x= PAWPx * xyz2D(i ,iab,icd) - temp1y= PAWPy * xyz2D(i+iOffy,iab,icd) - temp1z= PAWPz * xyz2D(i+iOffz,iab,icd) - temp2x= Fac2 *B10(i) *xyz2D(i ,iab-1,icd) - temp2y= Fac2 *B10(i) *xyz2D(i+iOffy,iab-1,icd) - temp2z= Fac2 *B10(i) *xyz2D(i+iOffz,iab-1,icd) - temp3x= Fac1 *B00(i) *xyz2D(i ,iab,icd-1) - temp3y= Fac1 *B00(i) *xyz2D(i+iOffy,iab,icd-1) - temp3z= Fac1 *B00(i) *xyz2D(i+iOffz,iab,icd-1) - xyz2D(i ,iab+1,icd) = temp1x+ temp2x+ temp3x - xyz2D(i+iOffy,iab+1,icd) = temp1y+ temp2y+ temp3y - xyz2D(i+iOffz,iab+1,icd) = temp1z+ temp2z+ temp3z - 460 Continue - Fac2 = Fac2 + One - 450 Continue - End If - Fac1 = Fac1 + One - 400 Continue - Else - Fac1 = One - Do 500 iab = 1, nabMax - If (iab.eq.1) Then - Do 525 i = 1, nArg*lRys - QCWQx = xyz2D(i ,0,1) - QCWQy = xyz2D(i+iOffy,0,1) - QCWQz = xyz2D(i+iOffy,0,0) - xyz2D(i ,1,1) = QCWQx*xyz2D(i ,1,0) - & + B00(i) - xyz2D(i+iOffy,1,1) = QCWQy*xyz2D(i+iOffy,1,0) - & + B00(i) - xyz2D(i+iOffz,1,1) = QCWQz*xyz2D(i+iOffz,1,0) - & + B00(i)*xyz2D(i+iOffz,0,0) - 525 Continue - Else - Do 5251 i = 1, nArg*lRys - QCWQx = xyz2D(i ,0,1) - QCWQy = xyz2D(i+iOffy,0,1) - QCWQz = xyz2D(i+iOffy,0,0) - xyz2D(i,iab,1) = QCWQx *xyz2D(i,iab,0) - & + Fac1 *B00(i) *xyz2D(i,iab-1,0) - xyz2D(i+iOffy,iab,1) = - & QCWQy *xyz2D(i+iOffy,iab,0) - & + Fac1 *B00(i) *xyz2D(i+iOffy,iab-1,0) - xyz2D(i+iOffz,iab,1) = - & QCWQz *xyz2D(i+iOffz,iab,0) - & + Fac1 *B00(i) *xyz2D(i+iOffz,iab-1,0) - 5251 Continue - End If - If (ncdMax.eq.2) Then - Do 520 i = 1, nArg*lRys - QCWQx = xyz2D(i ,0,1) - QCWQy = xyz2D(i+iOffy,0,1) - QCWQz = xyz2D(i+iOffy,0,0) - xyz2D(i,iab,2) =QCWQx *xyz2D(i,iab,1) - & + B01(i) *xyz2D(i,iab,0) - & + Fac1 *B00(i) *xyz2D(i,iab-1,1) - xyz2D(i+iOffy,iab,2) = - & QCWQy *xyz2D(i+iOffy,iab,1) - & + B01(i) *xyz2D(i+iOffy,iab,0) - & + Fac1 *B00(i) *xyz2D(i+iOffy,iab-1,1) - xyz2D(i+iOffz,iab,2) = - & QCWQz *xyz2D(i+iOffz,iab,1) - & + B01(i) *xyz2D(i+iOffz,iab,0) - & + Fac1 *B00(i) *xyz2D(i+iOffz,iab-1,1) - 520 Continue - Else If (ncdMax.gt.2) Then - Fac2 = One - Do 550 icd = 1, ncdmax-1 - Do 560 i = 1, nArg*lRys - QCWQx = xyz2D(i ,0,1) - QCWQy = xyz2D(i+iOffy,0,1) - QCWQz = xyz2D(i+iOffy,0,0) - temp1x= QCWQx *xyz2D(i ,iab,icd) - temp1y= QCWQy *xyz2D(i+iOffy,iab,icd) - temp1z= QCWQz *xyz2D(i+iOffz,iab,icd) - temp2x= Fac2 *B01(i) *xyz2D(i ,iab,icd-1) - temp2y= Fac2 *B01(i) *xyz2D(i+iOffy,iab,icd-1) - temp2z= Fac2 *B01(i) *xyz2D(i+iOffz,iab,icd-1) - temp3x= Fac1 *B00(i) *xyz2D(i ,iab-1,icd) - temp3y= Fac1 *B00(i) *xyz2D(i+iOffy,iab-1,icd) - temp3z= Fac1 *B00(i) *xyz2D(i+iOffz,iab-1,icd) - xyz2D(i ,iab,icd+1) = temp1x+ temp2x+ temp3x - xyz2D(i+iOffy,iab,icd+1) = temp1y+ temp2y+ temp3y - xyz2D(i+iOffz,iab,icd+1) = temp1z+ temp2z+ temp3z - 560 Continue - Fac2 = Fac2 + One - 550 Continue - End If - Fac1 = Fac1 + One - 500 Continue - End If - End If -* -#ifdef _DEBUGPRINT_ - Do iab = 0, nabMax - Do icd = 0, ncdMax - Write (Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(x)' - Call RecPrt(Label,' ', - & xyz2D(1 ,iab,icd),lRys,nArg) - Write (Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(y)' - Call RecPrt(Label,' ', - & xyz2D(1+ nArg*lRys,iab,icd),lRys,nArg) - Write (Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(z)' - Call RecPrt(Label,' ', - & xyz2D(1+2*nArg*lRys,iab,icd),lRys,nArg) - End Do - End Do -#else -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(laa) - Call Unused_integer(lac) - Call Unused_integer(lcc) - End If -#endif - Return - End diff -Nru openmolcas-22.02/src/rys_util/vrys2d.F90 openmolcas-22.10/src/rys_util/vrys2d.F90 --- openmolcas-22.02/src/rys_util/vrys2d.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/vrys2d.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,188 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991,1994, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine vRys2D(xyz2D,nArg,lRys,nabMax,ncdMax,PAWP,QCWQ,B10,B00,B01) +!*********************************************************************** +! * +! Object: to compute the 2-dimensional integrals of the Rys * +! quadrature. The z components are assumed to be pre- * +! conditioned with the weights of the roots of the * +! Rys polynomial. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! Modified loop structure for RISC 1991 R. Lindh Dept. of Theoretical * +! Chemistry, University of Lund, Sweden. * +! Further modifications in Jan-Feb. 1994. * +!*********************************************************************** + +use Constants, only: One, Two +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArg, lRys, nabMax, ncdMax +real(kind=wp), intent(inout) :: xyz2D(nArg*lRys,3,0:nabMax,0:ncdMax) +real(kind=wp), intent(in) :: PAWP(nArg*lRys,3), QCWQ(nArg*lRys,3), B10(nArg*lRys), B00(nArg*lRys), B01(nArg*lRys) +integer(kind=iwp) :: iab, icd +real(kind=wp) :: Fac1, Fac2, Fact +logical(kind=iwp) :: lPAWP, lQCWQ +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +character(len=30) :: Label +#endif + +#ifdef _DEBUGPRINT_ +if (nabMax > 0) call RecPrt('PAWP',' ',PAWP,lRys,nArg*3) +if (ncdMax > 0) call RecPrt('QCWQ',' ',QCWQ,lRys,nArg*3) +call RecPrt(' B10',' ',B10,lRys,nArg) +call RecPrt(' B00',' ',B00,lRys,nArg) +call RecPrt(' B01',' ',B01,lRys,nArg) +#endif + +if ((nabMax /= 0) .or. (ncdMax /= 0)) then + + ! General code + + ! Store away PAWPz and QCPQz + + lPAWP = nabMax > 2 + lQCWQ = ncdMax > 2 + if ((nabMax >= 1) .and. (ncdMax >= 1)) then + if (ncdMax <= nabMax) then + lPAWP = .true. + else + lQCWQ = .true. + end if + end if + if (lPAWP) xyz2D(:,1,0,0) = PAWP(:,3) + if (lQCWQ) xyz2D(:,2,0,0) = QCWQ(:,3) + + ! Compute 2D integrals with index (i,0) + + if (nabMax == 0) then + + else if (nabMax == 1) then + xyz2D(:,3,1,0) = xyz2D(:,3,1,0)*xyz2D(:,3,0,0) + else if (nabMax >= 2) then + xyz2D(:,1,2,0) = xyz2D(:,1,1,0)**2+B10(:) + xyz2D(:,2,2,0) = xyz2D(:,2,1,0)**2+B10(:) + xyz2D(:,3,2,0) = (xyz2D(:,3,1,0)**2+B10(:))*xyz2D(:,3,0,0) + xyz2D(:,3,1,0) = xyz2D(:,3,1,0)*xyz2D(:,3,0,0) + if (nabMax > 2) then + Fact = Two + do iab=2,nabMax-1 + xyz2D(:,1,iab+1,0) = xyz2D(:,1,1,0)*xyz2D(:,1,iab,0)+Fact*B10(:)*xyz2D(:,1,iab-1,0) + xyz2D(:,2,iab+1,0) = xyz2D(:,2,1,0)*xyz2D(:,2,iab,0)+Fact*B10(:)*xyz2D(:,2,iab-1,0) + xyz2D(:,3,iab+1,0) = xyz2D(:,1,0,0)*xyz2D(:,3,iab,0)+Fact*B10(:)*xyz2D(:,3,iab-1,0) + Fact = Fact+One + end do + end if + end if + + ! Compute 2D integrals with index (0,i) + + if (ncdMax == 1) then + xyz2D(:,3,0,1) = xyz2D(:,3,0,1)*xyz2D(:,3,0,0) + else if (ncdMax >= 2) then + xyz2D(:,1,0,2) = xyz2D(:,1,0,1)**2+B01(:) + xyz2D(:,2,0,2) = xyz2D(:,2,0,1)**2+B01(:) + xyz2D(:,3,0,2) = (xyz2D(:,3,0,1)**2+B01(:))*xyz2D(:,3,0,0) + xyz2D(:,3,0,1) = xyz2D(:,3,0,1)*xyz2D(:,3,0,0) + if (ncdMax > 2) then + Fact = Two + do icd=2,ncdMax-1 + xyz2D(:,1,0,icd+1) = xyz2D(:,1,0,1)*xyz2D(:,1,0,icd)+Fact*B01(:)*xyz2D(:,1,0,icd-1) + xyz2D(:,2,0,icd+1) = xyz2D(:,2,0,1)*xyz2D(:,2,0,icd)+Fact*B01(:)*xyz2D(:,2,0,icd-1) + xyz2D(:,3,0,icd+1) = xyz2D(:,2,0,0)*xyz2D(:,3,0,icd)+Fact*B01(:)*xyz2D(:,3,0,icd-1) + Fact = Fact+One + end do + end if + end if + + ! Compute 2D integrals with index (i,j) + + if (ncdMax <= nabMax) then + Fac1 = One + do icd=1,ncdMax + if (icd == 1) then + xyz2D(:,1,1,1) = xyz2D(:,1,1,0)*xyz2D(:,1,0,1)+B00(:) + xyz2D(:,2,1,1) = xyz2D(:,2,1,0)*xyz2D(:,2,0,1)+B00(:) + xyz2D(:,3,1,1) = xyz2D(:,1,0,0)*xyz2D(:,3,0,1)+B00(:)*xyz2D(:,3,0,0) + else + xyz2D(:,1,1,icd) = xyz2D(:,1,1,0)*xyz2D(:,1,0,icd)+Fac1*B00(:)*xyz2D(:,1,0,icd-1) + xyz2D(:,2,1,icd) = xyz2D(:,2,1,0)*xyz2D(:,2,0,icd)+Fac1*B00(:)*xyz2D(:,2,0,icd-1) + xyz2D(:,3,1,icd) = xyz2D(:,1,0,0)*xyz2D(:,3,0,icd)+Fac1*B00(:)*xyz2D(:,3,0,icd-1) + end if + if (nabMax == 2) then + xyz2D(:,1,2,icd) = xyz2D(:,1,1,0)*xyz2D(:,1,1,icd)+B10(:)*xyz2D(:,1,0,icd)+Fac1*B00(:)*xyz2D(:,1,1,icd-1) + xyz2D(:,2,2,icd) = xyz2D(:,2,1,0)*xyz2D(:,2,1,icd)+B10(:)*xyz2D(:,2,0,icd)+Fac1*B00(:)*xyz2D(:,2,1,icd-1) + xyz2D(:,3,2,icd) = xyz2D(:,1,0,0)*xyz2D(:,3,1,icd)+B10(:)*xyz2D(:,3,0,icd)+Fac1*B00(:)*xyz2D(:,3,1,icd-1) + else if (nabMax > 2) then + Fac2 = One + do iab=1,nabMax-1 + xyz2D(:,1,iab+1,icd) = xyz2D(:,1,1,0)*xyz2D(:,1,iab,icd)+Fac2*B10(:)*xyz2D(:,1,iab-1,icd)+Fac1*B00(:)*xyz2D(:,1,iab,icd-1) + xyz2D(:,2,iab+1,icd) = xyz2D(:,2,1,0)*xyz2D(:,2,iab,icd)+Fac2*B10(:)*xyz2D(:,2,iab-1,icd)+Fac1*B00(:)*xyz2D(:,2,iab,icd-1) + xyz2D(:,3,iab+1,icd) = xyz2D(:,1,0,0)*xyz2D(:,3,iab,icd)+Fac2*B10(:)*xyz2D(:,3,iab-1,icd)+Fac1*B00(:)*xyz2D(:,3,iab,icd-1) + Fac2 = Fac2+One + end do + end if + Fac1 = Fac1+One + end do + else + Fac1 = One + do iab=1,nabMax + if (iab == 1) then + xyz2D(:,1,1,1) = xyz2D(:,1,0,1)*xyz2D(:,1,1,0)+B00(:) + xyz2D(:,2,1,1) = xyz2D(:,2,0,1)*xyz2D(:,2,1,0)+B00(:) + xyz2D(:,3,1,1) = xyz2D(:,2,0,0)*xyz2D(:,3,1,0)+B00(:)*xyz2D(:,3,0,0) + else + xyz2D(:,1,iab,1) = xyz2D(:,1,0,1)*xyz2D(:,1,iab,0)+Fac1*B00(:)*xyz2D(:,1,iab-1,0) + xyz2D(:,2,iab,1) = xyz2D(:,2,0,1)*xyz2D(:,2,iab,0)+Fac1*B00(:)*xyz2D(:,2,iab-1,0) + xyz2D(:,3,iab,1) = xyz2D(:,2,0,0)*xyz2D(:,3,iab,0)+Fac1*B00(:)*xyz2D(:,3,iab-1,0) + end if + if (ncdMax == 2) then + xyz2D(:,1,iab,2) = xyz2D(:,1,0,1)*xyz2D(:,1,iab,1)+B01(:)*xyz2D(:,1,iab,0)+Fac1*B00(:)*xyz2D(:,1,iab-1,1) + xyz2D(:,2,iab,2) = xyz2D(:,2,0,1)*xyz2D(:,2,iab,1)+B01(:)*xyz2D(:,2,iab,0)+Fac1*B00(:)*xyz2D(:,2,iab-1,1) + xyz2D(:,3,iab,2) = xyz2D(:,2,0,0)*xyz2D(:,3,iab,1)+B01(:)*xyz2D(:,3,iab,0)+Fac1*B00(:)*xyz2D(:,3,iab-1,1) + else if (ncdMax > 2) then + Fac2 = One + do icd=1,ncdmax-1 + xyz2D(:,1,iab,icd+1) = xyz2D(:,1,0,1)*xyz2D(:,1,iab,icd)+Fac2*B01(:)*xyz2D(:,1,iab,icd-1)+Fac1*B00(:)*xyz2D(:,1,iab-1,icd) + xyz2D(:,2,iab,icd+1) = xyz2D(:,2,0,1)*xyz2D(:,2,iab,icd)+Fac2*B01(:)*xyz2D(:,2,iab,icd-1)+Fac1*B00(:)*xyz2D(:,2,iab-1,icd) + xyz2D(:,3,iab,icd+1) = xyz2D(:,2,0,0)*xyz2D(:,3,iab,icd)+Fac2*B01(:)*xyz2D(:,3,iab,icd-1)+Fac1*B00(:)*xyz2D(:,3,iab-1,icd) + Fac2 = Fac2+One + end do + end if + Fac1 = Fac1+One + end do + end if +end if + +#ifdef _DEBUGPRINT_ +do iab=0,nabMax + do icd=0,ncdMax + write(Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(x)' + call RecPrt(Label,' ',xyz2D(:,1,iab,icd),lRys,nArg) + write(Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(y)' + call RecPrt(Label,' ',xyz2D(:,2,iab,icd),lRys,nArg) + write(Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(z)' + call RecPrt(Label,' ',xyz2D(:,3,iab,icd),lRys,nArg) + end do +end do +#endif + +return + +end subroutine vRys2D diff -Nru openmolcas-22.02/src/rys_util/vrys2dm.f openmolcas-22.10/src/rys_util/vrys2dm.f --- openmolcas-22.02/src/rys_util/vrys2dm.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/vrys2dm.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,187 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine vRys2Dm(xyz2D,nArg,lRys,nabMax,ncdMax,PAWP,QCWQ, - & B10,laa,B00,lac,B01,lcc, - & la,lb,lc,ld,IfGrad) -************************************************************************ -* * -* Object: to compute the 2-dimensional integrals of the Rys * -* quadrature. The z components are assumed to be pre- * -* conditioned with the weights of the roots of the * -* Rys polynomial. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* Modified loop structure for RISC 1991 R. Lindh Dept. of Theoretical * -* Chemistry, University of Lund, Sweden. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - Real*8 xyz2D(nArg*lRys,3,0:nabMax,0:ncdMax), - & PAWP(nArg*lRys,3), QCWQ(nArg*lRys,3), - & B10(nArg*lRys), B00(nArg*lRys), - & B01(nArg*lRys) - Logical IfGrad(3,4) -#ifdef _DEBUGPRINT_ - Character*30 Label - If (nabMax.gt.0) Call RecPrt('PAWP',' ',PAWP,nArg,lRys*3) - If (ncdMax.gt.0) Call RecPrt('QCWQ',' ',QCWQ,nArg,lRys*3) - If (laa.ne.0) Call RecPrt(' B10',' ',B10,nArg*lRys,3) - If (lac.ne.0) Call RecPrt(' B00',' ',B00,nArg*lRys,3) - If (lcc.ne.0) Call RecPrt(' B01',' ',B01,nArg*lRys,3) -#endif -* -* Compute 2D integrals with index (0,0). Observe that the z -* component already contains the weight factor. -* - call dcopy_(2*nArg*lRys,[One],0,xyz2D(1,1,0,0),1) -* -* Compute 2D integrals with index (i,0) -* - Do 200 iCar = 1, 3 - llab = 0 - If (IfGrad(iCar,1).or.IfGrad(iCar,2)) llab = 1 - llcd = 0 - If (IfGrad(iCar,3).or.IfGrad(iCar,4)) llcd = 1 - mabMax = la + lb + llab - mcdMax = lc + ld + llcd -* - If (mabMax.ne.0) Then - Do 201 i = 1, nArg*lRys - xyz2D(i,iCar,1,0) = PAWP(i,iCar) * xyz2D(i,iCar,0,0) - 201 Continue - End If - If (mabMax-1.eq.1) Then - Do 210 i = 1, nArg*lRys - xyz2D(i,iCar,2,0) = PAWP(i,iCar) * xyz2D(i,iCar,1,0) - & + B10(i) * xyz2D(i,iCar,0,0) - 210 Continue - Else If (mabMax-1.gt.1) Then - Fact = One - Do 250 iab = 1, mabMax-1 - Do 260 i = 1, nArg*lRys - temp1 = PAWP(i,iCar) * xyz2D(i,iCar,iab,0) - temp2 = Fact * B10(i) * xyz2D(i,iCar,iab-1,0) - xyz2D(i,iCar,iab+1,0) = temp1 + temp2 - 260 Continue - Fact = Fact + One - 250 Continue - End If -* -* Compute 2D integrals with index (0,i) -* - If (mcdMax.ne.0) Then - Do 301 i = 1, nArg*lRys - xyz2D(i,iCar,0,1) = QCWQ(i,iCar) * xyz2D(i,iCar,0,0) - 301 Continue - End If - If (mcdMax-1.eq.1) Then - Do 310 i = 1, nArg*lRys - xyz2D(i,iCar,0,2) = QCWQ(i,iCar) * xyz2D(i,iCar,0,1) - & + B01(i ) * xyz2D(i,iCar,0,0) - 310 Continue - Else If (mcdMax-1.gt.1) Then - Fact = One - Do 350 icd = 1, mcdMax-1 - Do 360 i = 1, nArg*lRys - temp1 = QCWQ(i,iCar) * xyz2D(i,iCar,0,icd) - temp2 = Fact * B01(i ) * xyz2D(i,iCar,0,icd-1) - xyz2D(i,iCar,0,icd+1) = temp1 + temp2 - 360 Continue - Fact = Fact + One - 350 Continue - End If -* -* Compute 2D integrals with index (i,iCar,j) -* - If (mcdMax.le.mabMax) Then - Fac1 = One - Do 400 icd = 1, mcdMax - Do 425 i = 1, nArg*lRys - xyz2D(i,iCar,1,icd)=PAWP(i,iCar)*xyz2D(i,iCar,0,icd) - & + Fac1 * B00(i )*xyz2D(i,iCar,0,icd-1) - 425 Continue - If (mabMax-1.eq.1) Then - Do 420 i = 1, nArg*lRys - xyz2D(i,iCar,2,icd)=PAWP(i,iCar)*xyz2D(i,iCar,1,icd) - & + B10(i )*xyz2D(i,iCar,0,icd) - & + Fac1 *B00(i )*xyz2D(i,iCar,1,icd-1) - 420 Continue - Else If (mabMax-1.gt.1) Then - Fac2 = One - Do 450 iab = 1, mabMax-1 - Do 460 i = 1, nArg*lRys - temp1 = PAWP(i,iCar) * xyz2D(i,iCar,iab,icd) - temp2 = Fac2 *B10(i ) *xyz2D(i,iCar,iab-1,icd) - temp3 = Fac1 *B00(i ) *xyz2D(i,iCar,iab,icd-1) - xyz2D(i,iCar,iab+1,icd) = temp1 + temp2 + temp3 - 460 Continue - Fac2 = Fac2 + One - 450 Continue - End If - Fac1 = Fac1 + One - 400 Continue - Else - Fac1 = One - Do 500 iab = 1, mabMax - Do 525 i = 1, nArg*lRys - xyz2D(i,iCar,iab,1)=QCWQ(i,iCar)*xyz2D(i,iCar,iab,0) - & + Fac1 *B00(i )*xyz2D(i,iCar,iab-1,0) - 525 Continue - If (mcdMax-1.eq.1) Then - Do 520 i = 1, nArg*lRys - xyz2D(i,iCar,iab,2)=QCWQ(i,iCar)*xyz2D(i,iCar,iab,1) - & + B01(i ) *xyz2D(i,iCar,iab,0) - & + Fac1 *B00(i )*xyz2D(i,iCar,iab-1,1) - 520 Continue - Else If (mcdMax-1.gt.1) Then - Fac2 = One - Do 550 icd = 1, mcdMax-1 - Do 560 i = 1, nArg*lRys - temp1 = QCWQ(i,iCar) *xyz2D(i,iCar,iab,icd) - temp2 = Fac2 *B01(i ) *xyz2D(i,iCar,iab,icd-1) - temp3 = Fac1 *B00(i ) *xyz2D(i,iCar,iab-1,icd) - xyz2D(i,iCar,iab,icd+1) = temp1 + temp2 + temp3 - 560 Continue - Fac2 = Fac2 + One - 550 Continue - End If - Fac1 = Fac1 + One - 500 Continue - End If - 200 Continue -* -#ifdef _DEBUGPRINT_ - Do 600 iab = 0, nabMax - Do 610 icd = 0, ncdMax - Write (Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(x)' - Call RecPrt(Label,' ',xyz2D(1,1,iab,icd),nArg,lRys) - Write (Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(y)' - Call RecPrt(Label,' ',xyz2D(1,2,iab,icd),nArg,lRys) - Write (Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(z)' - Call RecPrt(Label,' ',xyz2D(1,3,iab,icd),nArg,lRys) - 610 Continue - 600 Continue -#else -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(laa) - Call Unused_integer(lac) - Call Unused_integer(lcc) - End If -#endif - Return - End diff -Nru openmolcas-22.02/src/rys_util/vrys2dm.F90 openmolcas-22.10/src/rys_util/vrys2dm.F90 --- openmolcas-22.02/src/rys_util/vrys2dm.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/vrys2dm.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,147 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine vRys2Dm(xyz2D,nArg,lRys,nabMax,ncdMax,PAWP,QCWQ,B10,B00,B01,la,lb,lc,ld,IfGrad) +!*********************************************************************** +! * +! Object: to compute the 2-dimensional integrals of the Rys * +! quadrature. The z components are assumed to be pre- * +! conditioned with the weights of the roots of the * +! Rys polynomial. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! Modified loop structure for RISC 1991 R. Lindh Dept. of Theoretical * +! Chemistry, University of Lund, Sweden. * +!*********************************************************************** + +use Constants, only: One +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nArg, lRys, nabMax, ncdMax, la, lb, lc, ld +real(kind=wp), intent(inout) :: xyz2D(nArg*lRys,3,0:nabMax,0:ncdMax) +real(kind=wp), intent(in) :: PAWP(nArg*lRys,3), QCWQ(nArg*lRys,3), B10(nArg*lRys), B00(nArg*lRys), B01(nArg*lRys) +logical(kind=iwp), intent(in) :: IfGrad(3,4) +integer(kind=iwp) :: iab, iCar, icd, llab, llcd, mabMax, mcdMax +real(kind=wp) :: Fac1, Fac2, Fact +#ifdef _DEBUGPRINT_ +character(len=30) :: Label +#endif + +#ifdef _DEBUGPRINT_ +if (nabMax > 0) call RecPrt('PAWP',' ',PAWP,nArg,lRys*3) +if (ncdMax > 0) call RecPrt('QCWQ',' ',QCWQ,nArg,lRys*3) +call RecPrt(' B10',' ',B10,nArg*lRys,3) +call RecPrt(' B00',' ',B00,nArg*lRys,3) +call RecPrt(' B01',' ',B01,nArg*lRys,3) +#endif + +! Compute 2D integrals with index (0,0). Observe that the z +! component already contains the weight factor. + +xyz2D(:,1:2,0,0) = One + +! Compute 2D integrals with index (i,0) + +do iCar=1,3 + llab = 0 + if (IfGrad(iCar,1) .or. IfGrad(iCar,2)) llab = 1 + llcd = 0 + if (IfGrad(iCar,3) .or. IfGrad(iCar,4)) llcd = 1 + mabMax = la+lb+llab + mcdMax = lc+ld+llcd + + if (mabMax /= 0) then + xyz2D(:,iCar,1,0) = PAWP(:,iCar)*xyz2D(:,iCar,0,0) + if (mabMax == 2) then + xyz2D(:,iCar,2,0) = PAWP(:,iCar)*xyz2D(:,iCar,1,0)+B10(:)*xyz2D(:,iCar,0,0) + else if (mabMax > 2) then + Fact = One + do iab=1,mabMax-1 + xyz2D(:,iCar,iab+1,0) = PAWP(:,iCar)*xyz2D(:,iCar,iab,0)+Fact*B10(:)*xyz2D(:,iCar,iab-1,0) + Fact = Fact+One + end do + end if + end if + + ! Compute 2D integrals with index (0,i) + + if (mcdMax /= 0) then + xyz2D(:,iCar,0,1) = QCWQ(:,iCar)*xyz2D(:,iCar,0,0) + if (mcdMax == 2) then + xyz2D(:,iCar,0,2) = QCWQ(:,iCar)*xyz2D(:,iCar,0,1)+B01(:)*xyz2D(:,iCar,0,0) + else if (mcdMax > 2) then + Fact = One + do icd=1,mcdMax-1 + xyz2D(:,iCar,0,icd+1) = QCWQ(:,iCar)*xyz2D(:,iCar,0,icd)+Fact*B01(:)*xyz2D(:,iCar,0,icd-1) + Fact = Fact+One + end do + end if + end if + + ! Compute 2D integrals with index (i,iCar,j) + + if (mcdMax <= mabMax) then + Fac1 = One + do icd=1,mcdMax + xyz2D(:,iCar,1,icd) = PAWP(:,iCar)*xyz2D(:,iCar,0,icd)+Fac1*B00(:)*xyz2D(:,iCar,0,icd-1) + if (mabMax == 2) then + xyz2D(:,iCar,2,icd) = PAWP(:,iCar)*xyz2D(:,iCar,1,icd)+B10(:)*xyz2D(:,iCar,0,icd)+Fac1*B00(:)*xyz2D(:,iCar,1,icd-1) + else if (mabMax > 2) then + Fac2 = One + do iab=1,mabMax-1 + xyz2D(:,iCar,iab+1,icd) = PAWP(:,iCar)*xyz2D(:,iCar,iab,icd)+Fac2*B10(:)*xyz2D(:,iCar,iab-1,icd)+ & + Fac1*B00(:)*xyz2D(:,iCar,iab,icd-1) + Fac2 = Fac2+One + end do + end if + Fac1 = Fac1+One + end do + else + Fac1 = One + do iab=1,mabMax + xyz2D(:,iCar,iab,1) = QCWQ(:,iCar)*xyz2D(:,iCar,iab,0)+Fac1*B00(:)*xyz2D(:,iCar,iab-1,0) + if (mcdMax == 2) then + xyz2D(:,iCar,iab,2) = QCWQ(:,iCar)*xyz2D(:,iCar,iab,1)+B01(:)*xyz2D(:,iCar,iab,0)+Fac1*B00(:)*xyz2D(:,iCar,iab-1,1) + else if (mcdMax > 2) then + Fac2 = One + do icd=1,mcdMax-1 + xyz2D(:,iCar,iab,icd+1) = QCWQ(:,iCar)*xyz2D(:,iCar,iab,icd)+Fac2*B01(:)*xyz2D(:,iCar,iab,icd-1)+ & + Fac1*B00(:)*xyz2D(:,iCar,iab-1,icd) + Fac2 = Fac2+One + end do + end if + Fac1 = Fac1+One + end do + end if +end do + +#ifdef _DEBUGPRINT_ +do iab=0,nabMax + do icd=0,ncdMax + write(Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(x)' + call RecPrt(Label,' ',xyz2D(:,1,iab,icd),nArg,lRys) + write(Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(y)' + call RecPrt(Label,' ',xyz2D(:,2,iab,icd),nArg,lRys) + write(Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(z)' + call RecPrt(Label,' ',xyz2D(:,3,iab,icd),nArg,lRys) + end do +end do +#endif + +return + +end subroutine vRys2Dm diff -Nru openmolcas-22.02/src/rys_util/vrys_rw.f openmolcas-22.10/src/rys_util/vrys_rw.f --- openmolcas-22.02/src/rys_util/vrys_rw.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/vrys_rw.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Module vRys_RW - Integer, Parameter :: MaxRys=9 - Real*8, Dimension(:), Allocatable :: TMax, ddx, x0 - Real*8, Dimension(:), Allocatable :: HerR2, HerW2, Cff - Integer, Dimension(:), Allocatable :: Map - Integer, Dimension(:), Allocatable :: iHerR2, iHerW2 - Integer iMap(MaxRys), nMap(MaxRys), ix0(MaxRys), nx0(MaxRys), - & iCffR(0:6,MaxRys), iCffW(0:6,MaxRys), nMxRys - End Module vRys_RW diff -Nru openmolcas-22.02/src/rys_util/vrysrw.f openmolcas-22.10/src/rys_util/vrysrw.f --- openmolcas-22.02/src/rys_util/vrysrw.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/vrysrw.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,178 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine vRysRW(la,lb,lc,ld,Arg,Root,Weight,nArg,nRys) -************************************************************************ -* * -* Object: to compute the roots and weights of the Rys polynomials. * -* This is done with two approximations. For low arguments * -* we will use a 6'th order polynomial and for high arguments * -* we will use the asymptotic formulas which are based on the * -* roots and weight of Hermite polynomials. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* September '90 * -************************************************************************ - use vRys_RW - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" -#include "FMM.fh" - Real*8 Arg(nArg), Root(nRys,nArg), Weight(nRys,nArg), Tmax_ -* -#ifdef _DEBUGPRINT_ - iRout = 78 - iPrint = nPrint(iRout) - If (iPrint.ge.99) Call RecPrt('In vRysRW:Arg',' ',Arg,nArg,1) -#endif - labcd=1 -* - If (nRys.gt.nMxRys) Then - Call WarningMessage(2, - & 'vRysrw: nRys in vRysRW is larger than nMxRys!') - Write (6,*) ' nRys =',nRys - Write (6,*) ' nMxRys=',nMxRys - Call Abend() - End If -* -* For the FMM we use the asymptotic limit to compute the -* multipole-component of the integrals -* - TMax_=TMax(nRys) - If (asymptotic_Rys) TMax_=1.0D99 -* - If (nRys.eq.1) Then - labcd=la+lb+lc+ld - If (labcd.eq.0) Then - Call Rys01(Arg,nArg,Weight,Map(iMap(1)),nMap(1), - & x0(ix0(1)),nx0(1),Cff(iCffW(6,1)), - & Cff(iCffW(5,1)),Cff(iCffW(4,1)),Cff(iCffW(3,1)), - & Cff(iCffW(2,1)), - & Cff(iCffW(1,1)),Cff(iCffW(0,1)),ddx(nRys), - & HerW2(iHerW2(1)),TMax_) - Else - Call Rys11(Arg,nArg,Root,Weight, - & Map(iMap(1)),nMap(1), - & x0(ix0(1)),nx0(1),Cff(iCffR(6,1)), - & Cff(iCffR(5,1)),Cff(iCffR(4,1)),Cff(iCffR(3,1)), - & Cff(iCffR(2,1)),Cff(iCffR(1,1)),Cff(iCffR(0,1)), - & Cff(iCffW(6,1)),Cff(iCffW(5,1)),Cff(iCffW(4,1)), - & Cff(iCffW(3,1)),Cff(iCffW(2,1)),Cff(iCffW(1,1)), - & Cff(iCffW(0,1)),ddx(nRys), - & HerW2(iHerW2(1)),HerR2(iHerR2(1)),TMax_) - End If -* - Else If (nRys.eq.2) Then - Call Rys22(Arg,nArg,Root,Weight, - & Map(iMap(2)),nMap(2), - & x0(ix0(2)),nx0(2),Cff(iCffR(6,2)), - & Cff(iCffR(5,2)),Cff(iCffR(4,2)),Cff(iCffR(3,2)), - & Cff(iCffR(2,2)),Cff(iCffR(1,2)),Cff(iCffR(0,2)), - & Cff(iCffW(6,2)),Cff(iCffW(5,2)),Cff(iCffW(4,2)), - & Cff(iCffW(3,2)),Cff(iCffW(2,2)),Cff(iCffW(1,2)), - & Cff(iCffW(0,2)),ddx(nRys), - & HerW2(iHerW2(2)),HerR2(iHerR2(2)),TMax_) -* - Else If (nRys.eq.3) Then - Call Rys33(Arg,nArg,Root,Weight, - & Map(iMap(3)),nMap(3), - & x0(ix0(3)),nx0(3),Cff(iCffR(6,3)), - & Cff(iCffR(5,3)),Cff(iCffR(4,3)),Cff(iCffR(3,3)), - & Cff(iCffR(2,3)),Cff(iCffR(1,3)),Cff(iCffR(0,3)), - & Cff(iCffW(6,3)),Cff(iCffW(5,3)),Cff(iCffW(4,3)), - & Cff(iCffW(3,3)),Cff(iCffW(2,3)),Cff(iCffW(1,3)), - & Cff(iCffW(0,3)),ddx(nRys), - & HerW2(iHerW2(3)),HerR2(iHerR2(3)),TMax_) -* - Else If (nRys.eq.4) Then - Call Rys44(Arg,nArg,Root,Weight, - & Map(iMap(4)),nMap(4), - & x0(ix0(4)),nx0(4),Cff(iCffR(6,4)), - & Cff(iCffR(5,4)),Cff(iCffR(4,4)),Cff(iCffR(3,4)), - & Cff(iCffR(2,4)),Cff(iCffR(1,4)),Cff(iCffR(0,4)), - & Cff(iCffW(6,4)),Cff(iCffW(5,4)),Cff(iCffW(4,4)), - & Cff(iCffW(3,4)),Cff(iCffW(2,4)),Cff(iCffW(1,4)), - & Cff(iCffW(0,4)),ddx(nRys), - & HerW2(iHerW2(4)),HerR2(iHerR2(4)),TMax_) -* - Else If (nRys.eq.5) Then - Call Rys55(Arg,nArg,Root,Weight, - & Map(iMap(5)),nMap(5), - & x0(ix0(5)),nx0(5),Cff(iCffR(6,5)), - & Cff(iCffR(5,5)),Cff(iCffR(4,5)),Cff(iCffR(3,5)), - & Cff(iCffR(2,5)),Cff(iCffR(1,5)),Cff(iCffR(0,5)), - & Cff(iCffW(6,5)),Cff(iCffW(5,5)),Cff(iCffW(4,5)), - & Cff(iCffW(3,5)),Cff(iCffW(2,5)),Cff(iCffW(1,5)), - & Cff(iCffW(0,5)),ddx(nRys), - & HerW2(iHerW2(5)),HerR2(iHerR2(5)),TMax_) -* - Else If (nRys.eq.6) Then - Call Rys66(Arg,nArg,Root,Weight, - & Map(iMap(6)),nMap(6), - & x0(ix0(6)),nx0(6),Cff(iCffR(6,6)), - & Cff(iCffR(5,6)),Cff(iCffR(4,6)),Cff(iCffR(3,6)), - & Cff(iCffR(2,6)),Cff(iCffR(1,6)),Cff(iCffR(0,6)), - & Cff(iCffW(6,6)),Cff(iCffW(5,6)),Cff(iCffW(4,6)), - & Cff(iCffW(3,6)),Cff(iCffW(2,6)),Cff(iCffW(1,6)), - & Cff(iCffW(0,6)),ddx(nRys), - & HerW2(iHerW2(6)),HerR2(iHerR2(6)),TMax_) -* - Else If (nRys.eq.7) Then - Call Rys77(Arg,nArg,Root,Weight, - & Map(iMap(7)),nMap(7), - & x0(ix0(7)),nx0(7),Cff(iCffR(6,7)), - & Cff(iCffR(5,7)),Cff(iCffR(4,7)),Cff(iCffR(3,7)), - & Cff(iCffR(2,7)),Cff(iCffR(1,7)),Cff(iCffR(0,7)), - & Cff(iCffW(6,7)),Cff(iCffW(5,7)),Cff(iCffW(4,7)), - & Cff(iCffW(3,7)),Cff(iCffW(2,7)),Cff(iCffW(1,7)), - & Cff(iCffW(0,7)),ddx(nRys), - & HerW2(iHerW2(7)),HerR2(iHerR2(7)),TMax_) -* - Else If (nRys.eq.8) Then - Call Rys88(Arg,nArg,Root,Weight, - & Map(iMap(8)),nMap(8), - & x0(ix0(8)),nx0(8),Cff(iCffR(6,8)), - & Cff(iCffR(5,8)),Cff(iCffR(4,8)),Cff(iCffR(3,8)), - & Cff(iCffR(2,8)),Cff(iCffR(1,8)),Cff(iCffR(0,8)), - & Cff(iCffW(6,8)),Cff(iCffW(5,8)),Cff(iCffW(4,8)), - & Cff(iCffW(3,8)),Cff(iCffW(2,8)),Cff(iCffW(1,8)), - & Cff(iCffW(0,8)),ddx(nRys), - & HerW2(iHerW2(8)),HerR2(iHerR2(8)),TMax_) -* - Else If (nRys.eq.9) Then - Call Rys99(Arg,nArg,Root,Weight, - & Map(iMap(9)),nMap(9), - & x0(ix0(9)),nx0(9),Cff(iCffR(6,9)), - & Cff(iCffR(5,9)),Cff(iCffR(4,9)),Cff(iCffR(3,9)), - & Cff(iCffR(2,9)),Cff(iCffR(1,9)),Cff(iCffR(0,9)), - & Cff(iCffW(6,9)),Cff(iCffW(5,9)),Cff(iCffW(4,9)), - & Cff(iCffW(3,9)),Cff(iCffW(2,9)),Cff(iCffW(1,9)), - & Cff(iCffW(0,9)),ddx(nRys), - & HerW2(iHerW2(9)),HerR2(iHerR2(9)),TMax_) -* - Else - Call WarningMessage(2, - & ' vRysRW: nRys in vRysRW is larger than MaxRys!') - Call Abend() -* - End If -* -#ifdef _DEBUGPRINT_ - If (iPrint.ge.99) Then - If (labcd.ne.0) - & Call Recprt(' In vRysRW: Roots ',' ',Root ,nRys,nArg) - Call Recprt(' In vRysRW: Weight',' ',Weight,nRys,nArg) - End If -#endif - Return - End diff -Nru openmolcas-22.02/src/rys_util/vrys_rw.F90 openmolcas-22.10/src/rys_util/vrys_rw.F90 --- openmolcas-22.02/src/rys_util/vrys_rw.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/vrys_rw.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,26 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +module vRys_RW + +use Definitions, only: wp, iwp + +implicit none +private + +integer(kind=iwp), parameter :: MaxRys = 9 +integer(kind=iwp) :: iCffR(0:6,MaxRys), iCffW(0:6,MaxRys), iMap(MaxRys), ix0(MaxRys), nMap(MaxRys), nMxRys, nx0(MaxRys) +real(kind=wp), allocatable :: Cff(:), ddx(:), HerR2(:), HerW2(:), TMax(:), x0(:) +integer(kind=iwp), allocatable :: iHerR2(:), iHerW2(:), Map(:) + +public :: Cff, ddx, HerR2, HerW2, iCffR, iCffW, iHerR2, iHerW2, iMap, ix0, Map, nMap, nMxRys, nx0, TMax, x0 + +end module vRys_RW diff -Nru openmolcas-22.02/src/rys_util/vrysrw.F90 openmolcas-22.10/src/rys_util/vrysrw.F90 --- openmolcas-22.02/src/rys_util/vrysrw.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/vrysrw.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,127 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine vRysRW(la,lb,lc,ld,Arg,Root,Weight,nArg,nRys) +!*********************************************************************** +! * +! Object: to compute the roots and weights of the Rys polynomials. * +! This is done with two approximations. For low arguments * +! we will use a 6th order polynomial and for high arguments * +! we will use the asymptotic formulas which are based on the * +! roots and weight of Hermite polynomials. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! September '90 * +!*********************************************************************** + +use vRys_RW, only: Cff, ddx, HerR2, HerW2, iCffR, iCffW, iHerR2, iHerW2, iMap, ix0, Map, nMap, nMxRys, nx0, TMax, x0 +use Gateway_global, only: asymptotic_Rys +use Definitions, only: wp, iwp, u6 + +implicit none +integer(kind=iwp), intent(in) :: la, lb, lc, ld, nArg, nRys +real(kind=wp), intent(in) :: Arg(nArg) +real(kind=wp), intent(inout) :: Root(nRys,nArg) +real(kind=wp), intent(out) :: Weight(nRys,nArg) +integer(kind=iwp) :: labcd +real(kind=wp) :: Tmax_ + +#ifdef _DEBUGPRINT_ +iRout = 78 +iPrint = nPrint(iRout) +if (iPrint >= 99) call RecPrt('In vRysRW:Arg',' ',Arg,nArg,1) +#endif +labcd = 1 + +if (nRys > nMxRys) then + call WarningMessage(2,'vRysrw: nRys in vRysRW is larger than nMxRys!') + write(u6,*) ' nRys =',nRys + write(u6,*) ' nMxRys=',nMxRys + call Abend() +end if + +! For the FMM we use the asymptotic limit to compute the +! multipole-component of the integrals + +TMax_ = TMax(nRys) +if (asymptotic_Rys) TMax_ = huge(TMax_) + +select case (nRys) + + case (1) + labcd = la+lb+lc+ld + if (labcd == 0) then + call Rys01(Arg,nArg,Weight,Map(iMap(1)),nMap(1),x0(ix0(1)),nx0(1),Cff(iCffW(6,1)),Cff(iCffW(5,1)),Cff(iCffW(4,1)), & + Cff(iCffW(3,1)),Cff(iCffW(2,1)),Cff(iCffW(1,1)),Cff(iCffW(0,1)),ddx(nRys),HerW2(iHerW2(1)),TMax_) + else + call Rys11(Arg,nArg,Root,Weight,Map(iMap(1)),nMap(1),x0(ix0(1)),nx0(1),Cff(iCffR(6,1)),Cff(iCffR(5,1)),Cff(iCffR(4,1)), & + Cff(iCffR(3,1)),Cff(iCffR(2,1)),Cff(iCffR(1,1)),Cff(iCffR(0,1)),Cff(iCffW(6,1)),Cff(iCffW(5,1)),Cff(iCffW(4,1)), & + Cff(iCffW(3,1)),Cff(iCffW(2,1)),Cff(iCffW(1,1)),Cff(iCffW(0,1)),ddx(nRys),HerW2(iHerW2(1)),HerR2(iHerR2(1)),TMax_) + end if + + case (2) + call Rys22(Arg,nArg,Root,Weight,Map(iMap(2)),nMap(2),x0(ix0(2)),nx0(2),Cff(iCffR(6,2)),Cff(iCffR(5,2)),Cff(iCffR(4,2)), & + Cff(iCffR(3,2)),Cff(iCffR(2,2)),Cff(iCffR(1,2)),Cff(iCffR(0,2)),Cff(iCffW(6,2)),Cff(iCffW(5,2)),Cff(iCffW(4,2)), & + Cff(iCffW(3,2)),Cff(iCffW(2,2)),Cff(iCffW(1,2)),Cff(iCffW(0,2)),ddx(nRys),HerW2(iHerW2(2)),HerR2(iHerR2(2)),TMax_) + + case (3) + call Rys33(Arg,nArg,Root,Weight,Map(iMap(3)),nMap(3),x0(ix0(3)),nx0(3),Cff(iCffR(6,3)),Cff(iCffR(5,3)),Cff(iCffR(4,3)), & + Cff(iCffR(3,3)),Cff(iCffR(2,3)),Cff(iCffR(1,3)),Cff(iCffR(0,3)),Cff(iCffW(6,3)),Cff(iCffW(5,3)),Cff(iCffW(4,3)), & + Cff(iCffW(3,3)),Cff(iCffW(2,3)),Cff(iCffW(1,3)),Cff(iCffW(0,3)),ddx(nRys),HerW2(iHerW2(3)),HerR2(iHerR2(3)),TMax_) + + case (4) + call Rys44(Arg,nArg,Root,Weight,Map(iMap(4)),nMap(4),x0(ix0(4)),nx0(4),Cff(iCffR(6,4)),Cff(iCffR(5,4)),Cff(iCffR(4,4)), & + Cff(iCffR(3,4)),Cff(iCffR(2,4)),Cff(iCffR(1,4)),Cff(iCffR(0,4)),Cff(iCffW(6,4)),Cff(iCffW(5,4)),Cff(iCffW(4,4)), & + Cff(iCffW(3,4)),Cff(iCffW(2,4)),Cff(iCffW(1,4)),Cff(iCffW(0,4)),ddx(nRys),HerW2(iHerW2(4)),HerR2(iHerR2(4)),TMax_) + + case (5) + call Rys55(Arg,nArg,Root,Weight,Map(iMap(5)),nMap(5),x0(ix0(5)),nx0(5),Cff(iCffR(6,5)),Cff(iCffR(5,5)),Cff(iCffR(4,5)), & + Cff(iCffR(3,5)),Cff(iCffR(2,5)),Cff(iCffR(1,5)),Cff(iCffR(0,5)),Cff(iCffW(6,5)),Cff(iCffW(5,5)),Cff(iCffW(4,5)), & + Cff(iCffW(3,5)),Cff(iCffW(2,5)),Cff(iCffW(1,5)),Cff(iCffW(0,5)),ddx(nRys),HerW2(iHerW2(5)),HerR2(iHerR2(5)),TMax_) + + case (6) + call Rys66(Arg,nArg,Root,Weight,Map(iMap(6)),nMap(6),x0(ix0(6)),nx0(6),Cff(iCffR(6,6)),Cff(iCffR(5,6)),Cff(iCffR(4,6)), & + Cff(iCffR(3,6)),Cff(iCffR(2,6)),Cff(iCffR(1,6)),Cff(iCffR(0,6)),Cff(iCffW(6,6)),Cff(iCffW(5,6)),Cff(iCffW(4,6)), & + Cff(iCffW(3,6)),Cff(iCffW(2,6)),Cff(iCffW(1,6)),Cff(iCffW(0,6)),ddx(nRys),HerW2(iHerW2(6)),HerR2(iHerR2(6)),TMax_) + + case (7) + call Rys77(Arg,nArg,Root,Weight,Map(iMap(7)),nMap(7),x0(ix0(7)),nx0(7),Cff(iCffR(6,7)),Cff(iCffR(5,7)),Cff(iCffR(4,7)), & + Cff(iCffR(3,7)),Cff(iCffR(2,7)),Cff(iCffR(1,7)),Cff(iCffR(0,7)),Cff(iCffW(6,7)),Cff(iCffW(5,7)),Cff(iCffW(4,7)), & + Cff(iCffW(3,7)),Cff(iCffW(2,7)),Cff(iCffW(1,7)),Cff(iCffW(0,7)),ddx(nRys),HerW2(iHerW2(7)),HerR2(iHerR2(7)),TMax_) + + case (8) + call Rys88(Arg,nArg,Root,Weight,Map(iMap(8)),nMap(8),x0(ix0(8)),nx0(8),Cff(iCffR(6,8)),Cff(iCffR(5,8)),Cff(iCffR(4,8)), & + Cff(iCffR(3,8)),Cff(iCffR(2,8)),Cff(iCffR(1,8)),Cff(iCffR(0,8)),Cff(iCffW(6,8)),Cff(iCffW(5,8)),Cff(iCffW(4,8)), & + Cff(iCffW(3,8)),Cff(iCffW(2,8)),Cff(iCffW(1,8)),Cff(iCffW(0,8)),ddx(nRys),HerW2(iHerW2(8)),HerR2(iHerR2(8)),TMax_) + + case (9) + call Rys99(Arg,nArg,Root,Weight,Map(iMap(9)),nMap(9),x0(ix0(9)),nx0(9),Cff(iCffR(6,9)),Cff(iCffR(5,9)),Cff(iCffR(4,9)), & + Cff(iCffR(3,9)),Cff(iCffR(2,9)),Cff(iCffR(1,9)),Cff(iCffR(0,9)),Cff(iCffW(6,9)),Cff(iCffW(5,9)),Cff(iCffW(4,9)), & + Cff(iCffW(3,9)),Cff(iCffW(2,9)),Cff(iCffW(1,9)),Cff(iCffW(0,9)),ddx(nRys),HerW2(iHerW2(9)),HerR2(iHerR2(9)),TMax_) + + case default + call WarningMessage(2,' vRysRW: nRys in vRysRW is larger than MaxRys!') + call Abend() + +end select + +#ifdef _DEBUGPRINT_ +if (iPrint >= 99) then + if (labcd /= 0) call Recprt(' In vRysRW: Roots ',' ',Root,nRys,nArg) + call Recprt(' In vRysRW: Weight',' ',Weight,nRys,nArg) +end if +#endif +return + +end subroutine vRysRW diff -Nru openmolcas-22.02/src/rys_util/wrj12.f openmolcas-22.10/src/rys_util/wrj12.f --- openmolcas-22.02/src/rys_util/wrj12.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/wrj12.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,14 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ - Module Wrj12 - Integer iOffA(4,0:7), Lu_Q(0:7), Lu_A(0:7), nChV(0:7) - Integer, Allocatable:: SO2Ind(:) - End Module Wrj12 diff -Nru openmolcas-22.02/src/rys_util/xcff2d.f openmolcas-22.10/src/rys_util/xcff2d.f --- openmolcas-22.02/src/rys_util/xcff2d.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/xcff2d.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,192 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine XCff2D(iDum1,iDum2,nRys, - & Zeta,ZInv,rDum3,rDum4,nT, - & Coori,CoorAC,P,Q, - & la,lb,lc,ld, - & U2,PAQP,QCPQ,B10,B00,lac,B01) -************************************************************************ -* * -* Object: to compute the coefficients in the three terms recurrence * -* relation of the 2D-integrals. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* Modified loop structure for RISC 1991 R. Lindh, Dept. of Theoretical * -* Chemistry, University of Lund, Sweden. * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - Real*8 Zeta(nT), ZInv(nT), - & Coori(3,4), CoorAC(3,2), - & P(nT,3), Q(nT,3), U2(nRys,nT), - & PAQP(nRys,nT,3), QCPQ(nRys,nT,3), - & B10(nRys,nT,3), - & B00(nRys,nT,3), - & B01(nRys,nT,3) -* Local arrays -*define _DEBUGPRINT_ -#ifdef _DEBUGPRINT_ - Character*30 Label -#endif - Logical AeqB, CeqD, EQ -* -#ifdef _DEBUGPRINT_ - Call RecPrt(' In XCff2D: Coori',' ',Coori,3,4) - Call RecPrt(' In XCff2D: P',' ',P,nT,3) - Call RecPrt(' In XCff2D: Q',' ',Q,nT,3) -#endif - AeqB = EQ(Coori(1,1),Coori(1,2)) - CeqD = EQ(Coori(1,3),Coori(1,4)) -* - nabMax=la+lb - ncdMax=ld+lc - h12 = Half -* -*---- Compute B10, B00, and B01 -* - If (nabMax.gt.1) Then - Do 10 iT = 1, nT - Do 31 iRys = 1, nRys - B10(iRys,iT,1) = ( h12 - - & h12 * U2(iRys,iT))*ZInv(iT) - 31 Continue - 10 Continue - call dcopy_(nRys*nT,B10(1,1,1),1,B10(1,1,2),1) - call dcopy_(nRys*nT,B10(1,1,1),1,B10(1,1,3),1) - End If - If (lac.ne.0) Then - call dcopy_(nRys*nT,U2(1,1),1,B00(1,1,1),1) - call dcopy_(nRys*nT,U2(1,1),1,B00(1,1,2),1) - call dcopy_(nRys*nT,U2(1,1),1,B00(1,1,3),1) - End If - If (ncdMax.gt.1) Then - Do iT = 1, nT - Do iRys = 1, nRys - B01(iRys,iT,1) = Two * Zeta(iT) * U2(iRys,iT) - End Do - End Do - call dcopy_(nRys*nT,B01(1,1,1),1,B01(1,1,2),1) - call dcopy_(nRys*nT,B01(1,1,1),1,B01(1,1,3),1) - End If -* - If (nabMax.ne.0 .and. ncdMax.ne.0) Then - If (.Not.AeqB .and. CeqD) Then - Do 300 iCar = 1, 3 - Do 310 iT = 1, nT - Do 330 iRys = 1, nRys - PAQP(iRys,iT,iCar) = - & P(iT,iCar) - CoorAC(iCar,1) + - & (U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar))) - QCPQ(iRys,iT,iCar) = - Two * Zeta(iT) * - & (U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar))) - 330 Continue - 310 Continue - 300 Continue - Else - Do 400 iCar = 1, 3 - Do 410 iT = 1, nT - Do 430 iRys = 1, nRys - PAQP(iRys,iT,iCar) = - & (U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar))) - QCPQ(iRys,iT,iCar) = - Two * Zeta(iT) * - & (U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar))) - 430 Continue - 410 Continue - 400 Continue - End If - Else If (nabMax.ne.0) Then - If (.Not.AeqB) Then - Do 101 iCar = 1, 3 - Do 111 iT = 1, nT - Do 131 iRys = 1, nRys - PAQP(iRys,iT,iCar) = - & P(iT,iCar) - CoorAC(iCar,1) + - & U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar)) - 131 Continue - 111 Continue - 101 Continue - Else - Do 201 iCar = 1, 3 - Do 211 iT = 1, nT - Do 231 iRys = 1, nRys - PAQP(iRys,iT,iCar) = - & U2(iRys,iT) * (Q(iT,iCar)-P(iT,iCar)) - 231 Continue - 211 Continue - 201 Continue - End If - Else If (ncdMax.ne.0) Then - Do 202 iCar = 1, 3 - Do 212 iT = 1, nT - Do 232 iRys = 1, nRys - QCPQ(iRys,iT,iCar) = Two * Zeta(iT) * - & U2(iRys,iT) * (P(iT,iCar)-Q(iT,iCar)) - 232 Continue - 212 Continue - 202 Continue - End If -#ifdef _DEBUGPRINT_ - If (la+lb.gt.0) Then - Write (Label,'(A)') ' PAQP(x)' - Call RecPrt(Label,' ',PAQP(1,1,1),nRys,nT) - Write (Label,'(A)') ' PAQP(y)' - Call RecPrt(Label,' ',PAQP(1,1,2),nRys,nT) - Write (Label,'(A)') ' PAQP(z)' - Call RecPrt(Label,' ',PAQP(1,1,3),nRys,nT) - End If - If (lc+ld.gt.0) Then - Write (Label,'(A)') ' QCPQ(x)' - Call RecPrt(Label,' ',QCPQ(1,1,1),nRys,nT) - Write (Label,'(A)') ' QCPQ(y)' - Call RecPrt(Label,' ',QCPQ(1,1,2),nRys,nT) - Write (Label,'(A)') ' QCPQ(z)' - Call RecPrt(Label,' ',QCPQ(1,1,3),nRys,nT) - End If - If (nabMax.ne.0) Then - Write (Label,'(A)') ' B10(x)' - Call RecPrt(Label,' ',B10(1,1,1),nRys,nT) - Write (Label,'(A)') ' B10(y)' - Call RecPrt(Label,' ',B10(1,1,2),nRys,nT) - Write (Label,'(A)') ' B10(z)' - Call RecPrt(Label,' ',B10(1,1,3),nRys,nT) - End If - If (lac.ne.0) Then - Write (Label,'(A)') ' B00(x)' - Call RecPrt(Label,' ',B00(1,1,1),nRys,nT) - Write (Label,'(A)') ' B00(y)' - Call RecPrt(Label,' ',B00(1,1,2),nRys,nT) - Write (Label,'(A)') ' B00(z)' - Call RecPrt(Label,' ',B00(1,1,3),nRys,nT) - End If - If (ncdMax.ne.0) Then - Write (Label,'(A)') ' B01(x)' - Call RecPrt(Label,' ',B01(1,1,1),nRys,nT) - Write (Label,'(A)') ' B01(y)' - Call RecPrt(Label,' ',B01(1,1,2),nRys,nT) - Write (Label,'(A)') ' B01(z)' - Call RecPrt(Label,' ',B01(1,1,3),nRys,nT) - End If -#endif - Return -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(iDum1) - Call Unused_integer(iDum2) - Call Unused_real(rDum3) - Call Unused_real(rDum4) - End If - End diff -Nru openmolcas-22.02/src/rys_util/xcff2d.F90 openmolcas-22.10/src/rys_util/xcff2d.F90 --- openmolcas-22.02/src/rys_util/xcff2d.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/xcff2d.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,146 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine XCff2D(nabMax,ncdMax,nRys,Zeta,ZInv,Eta,EInv,nT,Coori,CoorAC,P,Q,la,lb,lc,ld,U2,PAQP,QCPQ,B10,B00,lac,B01) +!*********************************************************************** +! * +! Object: to compute the coefficients in the three terms recurrence * +! relation of the 2D-integrals. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! Modified loop structure for RISC 1991 R. Lindh, Dept. of Theoretical * +! Chemistry, University of Lund, Sweden. * +!*********************************************************************** + +use Constants, only: One, Two, Half +use Definitions, only: wp, iwp + +implicit none +integer(kind=iwp), intent(in) :: nabMax, ncdMax, nRys, nT, la, lb, lc, ld, lac +real(kind=wp), intent(in) :: Zeta(nT), ZInv(nT), Eta(nT), EInv(nT), Coori(3,4), CoorAC(3,2), P(nT,3), Q(nT,3), U2(nRys,nT) +real(kind=wp), intent(inout) :: PAQP(nRys,nT,3), QCPQ(nRys,nT,3), B10(nRys,nT,3), B00(nRys,nT,3), B01(nRys,nT,3) +integer(kind=iwp) :: iCar, iT, nabMax_, ncdMax_ +logical(kind=iwp) :: AeqB, CeqD +logical(kind=iwp), external :: EQ + +#include "macros.fh" +unused_var(nabMax) +unused_var(ncdMax) +unused_var(Eta) +unused_var(EInv) + +!define _DEBUGPRINT_ +#ifdef _DEBUGPRINT_ +call RecPrt(' In XCff2D: Coori',' ',Coori,3,4) +call RecPrt(' In XCff2D: P',' ',P,nT,3) +call RecPrt(' In XCff2D: Q',' ',Q,nT,3) +#endif +AeqB = EQ(Coori(1,1),Coori(1,2)) +CeqD = EQ(Coori(1,3),Coori(1,4)) + +nabMax_ = la+lb +ncdMax_ = ld+lc + +! Compute B10, B00, and B01 + +if (nabMax_ > 1) then + do iT=1,nT + B10(:,iT,1) = Half*(One-U2(:,iT))*ZInv(iT) + end do + B10(:,:,2) = B10(:,:,1) + B10(:,:,3) = B10(:,:,1) +end if +if (lac /= 0) then + B00(:,:,1) = U2 + B00(:,:,2) = U2 + B00(:,:,3) = U2 +end if +if (ncdMax_ > 1) then + do iT=1,nT + B01(:,iT,1) = Two*Zeta(iT)*U2(:,iT) + end do + B01(:,:,2) = B01(:,:,1) + B01(:,:,3) = B01(:,:,1) +end if + +if ((nabMax_ /= 0) .and. (ncdMax_ /= 0)) then + if ((.not. AeqB) .and. CeqD) then + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = P(iT,iCar)-CoorAC(iCar,1)+U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + QCPQ(:,iT,iCar) = -Two*Zeta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + end do + end do + else + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + QCPQ(:,iT,iCar) = -Two*Zeta(iT)*U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + end do + end do + end if +else if (nabMax_ /= 0) then + if (.not. AeqB) then + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = P(iT,iCar)-CoorAC(iCar,1)+U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + end do + end do + else + do iCar=1,3 + do iT=1,nT + PAQP(:,iT,iCar) = U2(:,iT)*(Q(iT,iCar)-P(iT,iCar)) + end do + end do + end if +else if (ncdMax_ /= 0) then + do iCar=1,3 + do iT=1,nT + QCPQ(:,iT,iCar) = Two*Zeta(iT)*U2(:,iT)*(P(iT,iCar)-Q(iT,iCar)) + end do + end do +end if +#ifdef _DEBUGPRINT_ +if (la+lb > 0) then + call RecPrt(' PAQP(x)',' ',PAQP(:,:,1),nRys,nT) + call RecPrt(' PAQP(y)',' ',PAQP(:,:,2),nRys,nT) + call RecPrt(' PAQP(z)',' ',PAQP(:,:,3),nRys,nT) +end if +if (lc+ld > 0) then + call RecPrt(' QCPQ(x)',' ',QCPQ(:,:,1),nRys,nT) + call RecPrt(' QCPQ(y)',' ',QCPQ(:,:,2),nRys,nT) + call RecPrt(' QCPQ(z)',' ',QCPQ(:,:,3),nRys,nT) +end if +if (nabMax_ /= 0) then + call RecPrt(' B10(x)',' ',B10(:,:,1),nRys,nT) + call RecPrt(' B10(y)',' ',B10(:,:,2),nRys,nT) + call RecPrt(' B10(z)',' ',B10(:,:,3),nRys,nT) +end if +if (lac /= 0) then + call RecPrt(' B00(x)',' ',B00(:,:,1),nRys,nT) + call RecPrt(' B00(y)',' ',B00(:,:,2),nRys,nT) + call RecPrt(' B00(z)',' ',B00(:,:,3),nRys,nT) +end if +if (ncdMax_ /= 0) then + call RecPrt(' B01(x)',' ',B01(:,:,1),nRys,nT) + call RecPrt(' B01(y)',' ',B01(:,:,2),nRys,nT) + call RecPrt(' B01(z)',' ',B01(:,:,3),nRys,nT) +end if +#endif + +return + +end subroutine XCff2D diff -Nru openmolcas-22.02/src/rys_util/xrys2d.f openmolcas-22.10/src/rys_util/xrys2d.f --- openmolcas-22.02/src/rys_util/xrys2d.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/rys_util/xrys2d.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,122 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1990,1991,1995, Roland Lindh * -* 1990, IBM * -************************************************************************ - SubRoutine XRys2D(xyz2D,nArg,lRys,nabMax,ncdMax,PAWP,QCWQ, - & B10,laa,B00,lac,B01,lcc) -************************************************************************ -* * -* Object: to compute the 2-dimensional integrals of the Rys * -* quadrature. The z components are assumed to be pre- * -* conditioned with the weights of the roots of the * -* Rys polynomial. * -* * -* Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * -* March '90 * -* * -* Modified loop structure for RISC 1991 R. Lindh Dept. of Theoretical * -* Chemistry, University of Lund, Sweden. * -* Modified for external field version, Feb '95. * -* VV: improve loop structure * -************************************************************************ - Implicit Real*8 (A-H,O-Z) -#include "real.fh" -#include "print.fh" - Real*8 xyz2D(nArg*lRys*3,0:nabMax,0:ncdMax), - & PAWP(nArg*lRys*3), QCWQ(nArg*lRys*3), - & B10(nArg*lRys*3), B00(nArg*lRys*3), B01(nArg*lRys*3) -#ifdef _DEBUGPRINT_ - Character*30 Label - iRout = 15 - iPrint = nPrint(iRout) - If (iPrint.ge.59) Then - If (nabMax.gt.0) Call RecPrt('PAWP',' ',PAWP,nArg,lRys*3) - If (ncdMax.gt.0) Call RecPrt('QCWQ',' ',QCWQ,nArg,lRys*3) - If (laa.ne.0) Call RecPrt(' B10',' ',B10,nArg*lRys,3) - If (lac.ne.0) Call RecPrt(' B00',' ',B00,nArg*lRys,3) - If (lcc.ne.0) Call RecPrt(' B01',' ',B01,nArg*lRys,3) - End If -#endif -* -* Compute 2D integrals with index (0,0). Observe that the z -* component already contains the weight factor. -* - call dcopy_(2*nArg*lRys,[One],0,xyz2D(1,0,0),1) -* -*---- Span first I(i,0) -* - If (nabMax.ge.1) Then - Do i = 1, nArg*lRys*3 - xyz2D(i,1,0) = PAWP(i)*xyz2D(i,0,0) - End Do - End If - Do iab = 1, nabMax-1 - Do i = 1, nArg*lRys*3 - xyz2D(i,iab+1,0) = PAWP(i)*xyz2D(i,iab,0) - & + Dble(iab)*B10(i)*xyz2D(i,iab-1,0) - End Do - End Do -* -*---- Now do the rest! -* - If (ncdMax.ge.1) Then - Do i = 1, nArg*lRys*3 - xyz2D(i,0,1)=QCWQ(i)*xyz2D(i,0,0) - End Do - Do iab = 1, nabMax - Do i = 1, nArg*lRys*3 - xyz2D(i,iab,1)=QCWQ(i)*xyz2D(i,iab,0) - & +Dble(iab)*B00(i)*xyz2D(i,iab-1,0) - End Do - End Do - End If - Do in = 1, ncdMax-1 - Do i = 1, nArg*lRys*3 - xyz2D(i,0,in+1)=QCWQ(i)*xyz2D(i,0,in) - & -Dble(in)*B01(i)*xyz2D(i,0,in-1) - End Do - Do iab = 1, nabMax - Do i = 1, nArg*lRys*3 - xyz2D(i,iab,in+1)=QCWQ(i)*xyz2D(i,iab,in) - & +Dble(iab)*B00(i)*xyz2D(i,iab-1,in) - & -Dble( in)*B01(i)*xyz2D(i,iab,in-1) - End Do - End Do - End Do -* -#ifdef _DEBUGPRINT_ - If (iPrint.ge.99) Then - Write (6,*) ' 2D-integral computed in XRys2D' - Do 600 iab = 0, nabMax - Do 610 icd = 0, ncdMax - Write (Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(x)' - Call RecPrt(Label,' ', - & xyz2D(1,iab,icd),nArg,lRys) - Write (Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(y)' - Call RecPrt(Label,' ', - & xyz2D(1+nArg*lRys,iab,icd),nArg,lRys) - Write (Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(z)' - Call RecPrt(Label,' ', - & xyz2D(1+2*nArg*lRys,iab,icd),nArg,lRys) - 610 Continue - 600 Continue - End If -#else -c Avoid unused argument warnings - If (.False.) Then - Call Unused_integer(laa) - Call Unused_integer(lac) - Call Unused_integer(lcc) - End If -#endif - Return - End diff -Nru openmolcas-22.02/src/rys_util/xrys2d.F90 openmolcas-22.10/src/rys_util/xrys2d.F90 --- openmolcas-22.02/src/rys_util/xrys2d.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/rys_util/xrys2d.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,107 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 1990,1991,1995, Roland Lindh * +! 1990, IBM * +!*********************************************************************** + +subroutine XRys2D(xyz2D,nArg,lRys,nabMax,ncdMax,PAWP,QCWQ,B10,B00,B01) +!*********************************************************************** +! * +! Object: to compute the 2-dimensional integrals of the Rys * +! quadrature. The z components are assumed to be pre- * +! conditioned with the weights of the roots of the * +! Rys polynomial. * +! * +! Author: Roland Lindh, IBM Almaden Research Center, San Jose, CA * +! March '90 * +! * +! Modified loop structure for RISC 1991 R. Lindh Dept. of Theoretical * +! Chemistry, University of Lund, Sweden. * +! Modified for external field version, Feb '95. * +! VV: improve loop structure * +!*********************************************************************** + +use Constants, only: One +use Definitions, only: wp, iwp +#ifdef _DEBUGPRINT_ +use Definitions, only: u6 +#endif + +implicit none +integer(kind=iwp), intent(in) :: nArg, lRys, nabMax, ncdMax +real(kind=wp), intent(inout) :: xyz2D(nArg*lRys,3,0:nabMax,0:ncdMax) +real(kind=wp), intent(in) :: PAWP(nArg*lRys,3), QCWQ(nArg*lRys,3), B10(nArg*lRys,3), B00(nArg*lRys,3), B01(nArg*lRys,3) +integer(kind=iwp) :: iab, in_ +#ifdef _DEBUGPRINT_ +character(len=30) :: Label +#endif + +#ifdef _DEBUGPRINT_ +iRout = 15 +iPrint = nPrint(iRout) +if (iPrint >= 59) then + if (nabMax > 0) call RecPrt('PAWP',' ',PAWP,nArg,lRys*3) + if (ncdMax > 0) call RecPrt('QCWQ',' ',QCWQ,nArg,lRys*3) + call RecPrt(' B10',' ',B10,nArg*lRys,3) + call RecPrt(' B00',' ',B00,nArg*lRys,3) + call RecPrt(' B01',' ',B01,nArg*lRys,3) +end if +#endif + +! Compute 2D integrals with index (0,0). Observe that the z +! component already contains the weight factor. + +xyz2D(:,1:2,0,0) = One + +! Span first I(i,0) + +if (nabMax >= 1) then + xyz2D(:,:,1,0) = PAWP(:,:)*xyz2D(:,:,0,0) + do iab=1,nabMax-1 + xyz2D(:,:,iab+1,0) = PAWP(:,:)*xyz2D(:,:,iab,0)+real(iab,kind=wp)*B10(:,:)*xyz2D(:,:,iab-1,0) + end do +end if + +! Now do the rest! + +if (ncdMax >= 1) then + xyz2D(:,:,0,1) = QCWQ(:,:)*xyz2D(:,:,0,0) + do iab=1,nabMax + xyz2D(:,:,iab,1) = QCWQ(:,:)*xyz2D(:,:,iab,0)+real(iab,kind=wp)*B00(:,:)*xyz2D(:,:,iab-1,0) + end do +end if +do in_=1,ncdMax-1 + xyz2D(:,:,0,in_+1) = QCWQ(:,:)*xyz2D(:,:,0,in_)-real(in_,kind=wp)*B01(:,:)*xyz2D(:,:,0,in_-1) + do iab=1,nabMax + xyz2D(:,:,iab,in_+1) = QCWQ(:,:)*xyz2D(:,:,iab,in_)+real(iab,kind=wp)*B00(:,:)*xyz2D(:,:,iab-1,in_)- & + real(in_,kind=wp)*B01(:,:)*xyz2D(:,:,iab,in_-1) + end do +end do + +#ifdef _DEBUGPRINT_ +if (iPrint >= 99) then + write(u6,*) ' 2D-integral computed in XRys2D' + do iab=0,nabMax + do icd=0,ncdMax + write(Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(x)' + call RecPrt(Label,' ',xyz2D(:,1,iab,icd),nArg,lRys) + write(Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(y)' + call RecPrt(Label,' ',xyz2D(:,2,iab,icd),nArg,lRys) + write(Label,'(A,I2,A,I2,A)') ' 2D(',iab,',',icd,')(z)' + call RecPrt(Label,' ',xyz2D(:,3,iab,icd),nArg,lRys) + end do + end do +end if +#endif + +return + +end subroutine XRys2D diff -Nru openmolcas-22.02/src/scf/addcorr.fh openmolcas-22.10/src/scf/addcorr.fh --- openmolcas-22.02/src/scf/addcorr.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/addcorr.fh 2022-10-10 14:22:40.000000000 +0000 @@ -10,7 +10,7 @@ ************************************************************************ Logical Do_Tw COMMON / Tw_corr_L / Do_Tw - Character*16 ADDC_KSDFT + Character(LEN=80) ADDC_KSDFT COMMON / ADDcorr_C / ADDC_KSDFT Logical Do_Addc COMMON / ADDcorr_L / Do_Addc diff -Nru openmolcas-22.02/src/scf/choscf_drv.f openmolcas-22.10/src/scf/choscf_drv.f --- openmolcas-22.02/src/scf/choscf_drv.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/choscf_drv.f 2022-10-10 14:22:40.000000000 +0000 @@ -10,8 +10,8 @@ * * * Copyright (C) 2010, Thomas Bondo Pedersen * ************************************************************************ - Subroutine ChoSCF_Drv(iUHF,nSym,nBas,DSQ,DLT,DSQ_ab,DLT_ab, - & FLT,FLT_ab,nFLT,ExFac,FSQ,FSQ_ab,nOcc,nOcc_ab) + Subroutine ChoSCF_Drv(nBSQT,nD,nSym,nBas,DSQ,DLT,DSQ_ab,DLT_ab, + & FLT,FLT_ab,nFLT,ExFac,FSQ,nOcc,nOcc_ab) C C Thomas Bondo Pedersen, September 2010. C @@ -20,12 +20,12 @@ C is called in case of local DF (LDF). C Implicit None - Integer iUHF, nSym, nFLT + Integer nBSQT, nD, nSym, nFLT Integer nBas(nSym), nOcc(nSym), nOcc_ab(nSym) Real*8 DSQ(*), DLT(*) Real*8 DSQ_ab(*), DLT_ab(*) Real*8 FLT(*), FLT_ab(*) - Real*8 FSQ(*), FSQ_ab(*) + Real*8 FSQ(nBSQT,nD) Real*8 ExFac Logical DoLDF @@ -33,12 +33,12 @@ ************************************************************************ * * Interface - SUBROUTINE CHOSCF_DRV_Internal(iUHF,nSym,nBas,W_DSQ,W_DLT, + SUBROUTINE CHOSCF_DRV_Internal(nD,nSym,nBas,W_DSQ,W_DLT, & W_DSQ_ab,W_DLT_ab,W_FLT, & W_FLT_ab,nFLT,ExFac, & W_FSQ,W_FSQ_ab, & nOcc,nOcc_ab) - Integer iUHF, nSym + Integer nD, nSym Integer nBas(nSym) Real*8 W_FLT(*),W_FLT_ab(*) Real*8 W_FSQ(*),W_FSQ_ab(*) @@ -55,18 +55,18 @@ Call DecideOnLocalDF(DoLDF) If (DoLDF) Then - Call LDFSCF_Drv(iUHF,nSym,nBas,DSQ,DLT,DSQ_ab,DLT_ab, - & FLT,FLT_ab,nFLT,ExFac,FSQ,FSQ_ab,nOcc,nOcc_ab) + Call LDFSCF_Drv(nD,nSym,nBas,DSQ,DLT,DSQ_ab,DLT_ab, + & FLT,FLT_ab,nFLT,ExFac,nOcc,nOcc_ab) Else - Call ChoSCF_Drv_Internal(iUHF,nSym,nBas,DSQ,DLT, + Call ChoSCF_Drv_Internal(nD,nSym,nBas,DSQ,DLT, & DSQ_ab,DLT_ab,FLT, & FLT_ab,nFLT,ExFac, - & FSQ,FSQ_ab, + & FSQ(:,1),FSQ(:,2), & nOcc,nOcc_ab) End If End - SUBROUTINE CHOSCF_DRV_Internal(iUHF,nSym,nBas,W_DSQ,W_DLT, + SUBROUTINE CHOSCF_DRV_Internal(nD,nSym,nBas,W_DSQ,W_DLT, & W_DSQ_ab,W_DLT_ab,W_FLT, & W_FLT_ab,nFLT,ExFac, & W_FSQ,W_FSQ_ab, @@ -76,10 +76,11 @@ Use Fock_util_global, only: Deco, Lunit use Data_Structures, only: Allocate_DT, Deallocate_DT use Data_Structures, only: DSBA_Type, Integer_Pointer + use SpinAV, only: Do_SpinAV Implicit Real*8 (a-h,o-z) #include "real.fh" #include "stdalloc.fh" - Integer iUHF, nSym + Integer nD, nSym Integer nBas(nSym), MinMem(nSym),rc Parameter (MaxDs = 3) Logical DoCoulomb(MaxDs),DoExchange(MaxDs) @@ -95,7 +96,6 @@ #include "choscf.fh" #include "choauf.fh" -#include "spave.fh" Type (Integer_Pointer) :: pNocc(3) @@ -109,13 +109,12 @@ C ************************************************** rc=0 - Lunit(:) = -1 * * ************************************************************************ ************************************************************************ * * - IF(iUHF.eq.0) THEN + IF(nD==1) THEN * * ************************************************************************ ************************************************************************ @@ -193,7 +192,7 @@ ENDIF - Call CHOSCF_MEM(nSym,nBas,iUHF,DoExchange,pNocc,ALGO,REORD, + Call CHOSCF_MEM(nSym,nBas,nD,DoExchange,pNocc,ALGO,REORD, & MinMem,loff1) * * ************************************************************************ @@ -315,7 +314,7 @@ If (ALGO.lt.3.and.ExFac.ne.0.0d0) Then - CALL CHO_SUM(rc,nSym,nBas,iUHF,DoExchange,FLT,FSQ) + CALL CHO_SUM(rc,nSym,nBas,nD,DoExchange,FLT,FSQ) EndIf C---------------------------------------------------- @@ -473,7 +472,7 @@ ENDIF - Call CHOSCF_MEM(nSym,nBas,iUHF,DoExchange,pNocc, + Call CHOSCF_MEM(nSym,nBas,nD,DoExchange,pNocc, & ALGO,REORD,MinMem,loff1) @@ -599,7 +598,7 @@ C --- Accumulates Coulomb and Exchange contributions If (ALGO.lt.3.and.ExFac.ne.0.0d0) then - CALL CHO_SUM(rc,nSym,nBas,iUHF,DoExchange,FLT,FSQ) + CALL CHO_SUM(rc,nSym,nBas,nD,DoExchange,FLT,FSQ) Endif C---------------------------------------------------- diff -Nru openmolcas-22.02/src/scf/cho_scf_rdinp.f openmolcas-22.10/src/scf/cho_scf_rdinp.f --- openmolcas-22.02/src/scf/cho_scf_rdinp.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/cho_scf_rdinp.f 2022-10-10 14:22:40.000000000 +0000 @@ -71,7 +71,7 @@ DensityCheck=.false. timings=.false. NSCREEN = 10 ! default screening interval (# of red sets) - dmpk = 1.0d0 ! default damping of the screening threshold + dmpk = 0.1d0 ! default damping of the screening threshold Estimate = .false. Update = .true. goto 999 !return flag @@ -84,11 +84,11 @@ DensityCheck=.false. timings=.false. NSCREEN = 10 - dmpk = 1.0d0 + dmpk = 0.1d0 Estimate = .false. Update = .true. - dmpk_dfl = 1.0d0 + dmpk_dfl = 0.1d0 ************************************************************************ * * iPrint=5 diff -Nru openmolcas-22.02/src/scf/davidson_scf.f openmolcas-22.10/src/scf/davidson_scf.f --- openmolcas-22.02/src/scf/davidson_scf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/davidson_scf.f 2022-10-10 14:22:40.000000000 +0000 @@ -34,12 +34,11 @@ *> @param[in] Fact Scaling factor *> @param[out] Eig Lowest eigenvalues *> @param[in,out] Vec Lowest eigenvectors -*> @param[in] MemRsv Amount of reserved memory *> @param[out] iRC Return code (0 if converged) ************************************************************************ - SUBROUTINE Davidson_SCF(HDiag,g,m,k,Fact,Eig,Vec,MemRsv,iRC) + SUBROUTINE Davidson_SCF(HDiag,g,m,k,Fact,Eig,Vec,iRC) IMPLICIT NONE - INTEGER m,n,k,iRC, MemRsv + INTEGER m,n,k,iRC REAL*8 HDiag(m),g(m),Eig(k),Vec(m+1,k), Fact REAL*8, DIMENSION(:,:), ALLOCATABLE :: Sub, Ab REAL*8, DIMENSION(:), ALLOCATABLE :: Eig_old, EVec, Proj, EVal @@ -48,15 +47,16 @@ real*8 ddot_ INTEGER mk,old_mk,mink,maxk,ig,info,nTmp,iter,maxiter INTEGER i,j,ii,jj - INTEGER ipTmp,ipDum - INTEGER ipDiag,ipTVec,ipTAV,ipTRes LOGICAL Last,Augmented,Reduced external ddot_ PARAMETER (Thr=1.0D-6, maxiter=300, Thr2=1.0D-16, Thr3=1.0D-16) + Real*8, Allocatable :: TmpVec(:), Diag(:), TVec(:), TAV(:), + & TRes(:) + Real*8 :: Dum(1)=0.0D0 + * #include "stdalloc.fh" #include "real.fh" -#include "WrkSpc.fh" #include "print.fh" *define _DEBUGPRINT_ #ifdef _DEBUGPRINT_ @@ -151,14 +151,14 @@ * The rest is set to zero, just in case * nTmp=0 - CALL Allocate_Work(ipTmp,n) + Call mma_allocate(TmpVec,n,Label='TmpVec') DO i=1,k - call dcopy_(n,Vec(1,i),1,Work(ipTmp),1) - CALL Add_Vector(n,nTmp,Sub,Work(ipTmp),Thr3) + call dcopy_(n,Vec(1,i),1,TmpVec,1) + CALL Add_Vector(n,nTmp,Sub,TmpVec,Thr3) END DO * ii=0 - CALL DZero(Work(ipTmp),n) + TmpVec(:)=Zero * DO WHILE ((nTmp .LT. mk) .AND. (ii .LT. n)) ii=ii+1 @@ -174,15 +174,15 @@ Aux=HDiag(jj) End If If (Aux.lt.1.0D10.and.Aux.gt.-0.10D0) Then - Work(ipTmp+jj-1)=One - CALL Add_Vector(n,nTmp,Sub,Work(ipTmp),Thr3) - Work(ipTmp+jj-1)=Zero + TmpVec(jj)=One + CALL Add_Vector(n,nTmp,Sub,TmpVec,Thr3) + TmpVec(jj)=Zero End If END DO * * ig will be a global counter to loop across all n base vectors ig=ii - CALL Free_Work(ipTmp) + Call mma_deallocate(TmpVec) CALL DZero(Sub(1,mk+1),(maxk-mk)*n) *---- Iterative procedure starts here @@ -194,11 +194,10 @@ Last=.FALSE. old_mk=0 iter=0 - CALL Allocate_Work(ipDum,1) - CALL Allocate_Work(ipDiag,n) - CALL Allocate_Work(ipTVec,n) - CALL Allocate_Work(ipTAV,n) - CALL Allocate_Work(ipTRes,n) + Call mma_allocate(Diag,n,Label='Diag') + Call mma_allocate(TVec,n,Label='TVec') + Call mma_allocate(TAV ,n,Label='TAV ') + Call mma_allocate(TRes,n,Label='TRes') DO WHILE (.NOT. Last) iter=iter+1 IF (iter .GT. 1) call dcopy_(k,Eig,1,Eig_old,1) @@ -230,7 +229,7 @@ * * Pick up the contribution for the updated Hessian (BFGS update) * - Call SOrUpV(MemRsv,Sub(1,j+1),HDiag,m,Ab(1,j+1),'GRAD', + Call SOrUpV(Sub(1,j+1),HDiag,m,Ab(1,j+1),'GRAD', & 'BFGS') Call DScal_(m,One/Fact,Ab(1,j+1),1) * @@ -275,12 +274,12 @@ #endif call dcopy_(maxk*maxk,Proj,1,EVec,1) call dsyev_('V','L',mk,EVec,maxk,EVal, - & Work(ipDum),-1,info) - nTmp=INT(Work(ipDum)) - CALL Allocate_Work(ipTmp,nTmp) + & Dum,-1,info) + nTmp=INT(Dum(1)) + Call mma_allocate(TmpVec,nTmp,Label='TmpVec') call dsyev_('V','L',mk,EVec,maxk,EVal, - & Work(ipTmp),nTmp,info) - CALL Free_Work(ipTmp) + & TmpVec,nTmp,info) + Call mma_deallocate(TmpVec) CALL JacOrd2(EVal,EVec,mk,maxk) call dcopy_(k,EVal,1,Eig,1) #ifdef _DEBUGPRINT_ @@ -400,14 +399,14 @@ #ifdef _DEBUGPRINT_ WRITE(6,'(2X,A,1X,I5)') 'Reducing search space to',mink #endif - CALL Allocate_Work(ipTmp,mink*n) + Call mma_allocate(TmpVec,mink*n,Label='TmpVec') CALL DGeMM_('N','N', & n,mink,mk, & One,Sub,n, & EVec,maxk, - & Zero,Work(ipTmp),n) - call dcopy_(mink*n,Work(ipTmp),1,Sub,1) - CALL Free_Work(ipTmp) + & Zero,TmpVec,n) + call dcopy_(mink*n,TmpVec,1,Sub,1) + Call mma_deallocate(TmpVec) *---- To make sure Sub' is orthonormal, add the vectors one by one * @@ -451,7 +450,7 @@ * computed from r and the eigenpair * (different possible variants) * - CALL Allocate_Work(ipTmp,n) + Call mma_allocate(TmpVec,n,Label='TmpVec') Conv=Zero * jj=0 @@ -459,15 +458,15 @@ * Vector in full space: Sub*Vec(i) Call dGeMV_('N',n,mk,One,Sub,n, & EVec(1+i*maxk),1, - & Zero,Work(ipTVec),1) + & Zero,TVec,1) * Product of matrix and vector: Ab*Vec(i) Call dGeMV_('N',n,mk,One,Ab,n, & EVec(1+i*maxk),1, - & Zero,Work(ipTAV),1) + & Zero,TAV,1) * Residual: (A-Val(i))*Vec(i) = Ab*Vec(i) - Val(i)*Sub*Vec(i) - call dcopy_(n,Work(ipTAV),1,Work(ipTRes),1) - call daxpy_(n,-EVal(1+i),Work(ipTVec),1,Work(ipTRes),1) - Conv=MAX(Conv,DDot_(n,Work(ipTRes),1,Work(ipTRes),1)) + call dcopy_(n,TAV,1,TRes,1) + call daxpy_(n,-EVal(1+i),TVec,1,TRes,1) + Conv=MAX(Conv,DDot_(n,TRes,1,TRes,1)) *---- Scale vector, orthonormalize, and add to subspace * @@ -480,45 +479,45 @@ Aux=HDiag(j+1)-Eval(1+i) End If If (j.eq.n-1) Then - Work(ipDiag+j)=One/SIGN(MAX(ABS(Aux),Thr2),Aux) + Diag(1+j)=One/SIGN(MAX(ABS(Aux),Thr2),Aux) Else If (HDiag(j+1).lt.1.0D20) Then - Work(ipDiag+j)=One/SIGN(MAX(ABS(Aux),Thr2),Aux) + Diag(1+j)=One/SIGN(MAX(ABS(Aux),Thr2),Aux) Else - Work(ipDiag+j)=1.0D20 + Diag(1+j)=1.0D20 End If End If END DO * * scale DO j=0,n-1 - If (Work(ipDiag+j).lt.1.0D02) Then - Work(ipTmp+j)=Work(ipTRes+j)*Work(ipDiag+j) + If (Diag(1+j).lt.1.0D02) Then + TmpVec(1+j)=TRes(1+j)*Diag(1+j) Else - Work(ipTmp+j)=Zero + TmpVec(1+j)=Zero End If END DO * Alpha=Zero DO j=0,n-1 - If (Work(ipDiag+j).lt.1.0D02) Then - Alpha=Alpha+Work(ipDiag+j)*Work(ipTVec+j)**2 + If (Diag(1+j).lt.1.0D02) Then + Alpha=Alpha+Diag(1+j)*TVec(1+j)**2 End If END DO - Alpha=DDot_(n,Work(ipTVec),1,Work(ipTmp),1)/Alpha + Alpha=DDot_(n,TVec,1,TmpVec,1)/Alpha * subtract DO j=0,n-1 - If (Work(ipDiag+j).lt.1.0D02) Then - Work(ipTVec+j)=Work(ipTVec+j)*Work(ipDiag+j) + If (Diag(1+j).lt.1.0D02) Then + TVec(1+j)=TVec(1+j)*Diag(1+j) Else - Work(ipTVec+j)=Zero + TVec(1+j)=Zero End If END DO - call daxpy_(n,-Alpha,Work(ipTVec),1,Work(ipTmp),1) + call daxpy_(n,-Alpha,TVec,1,TmpVec,1) * IF (mk+jj .LE. n-1) THEN jj=mk+jj - CALL Add_Vector(n,jj,Sub,Work(ipTmp),Thr3) + CALL Add_Vector(n,jj,Sub,TmpVec,Thr3) jj=jj-mk END IF END DO @@ -555,7 +554,7 @@ WRITE(6,'(A)') 'Process stagnated' #endif IF (mk .LT. maxk) THEN - CALL DZero(Work(ipTmp),n) + TmpVec(:n)=Zero i=0 * DO WHILE ((jj .LT. 1) .AND. (i .LT. n)) @@ -573,10 +572,10 @@ Aux=HDiag(ii) End If If (Aux.lt.1.0D20 .and. Aux.gt.-0.10D0) Then - Work(ipTmp+ii-1)=One + TmpVec(ii)=One jj=mk+jj - CALL Add_Vector(n,jj,Sub,Work(ipTmp),Thr3) - Work(ipTmp+ii-1)=Zero + CALL Add_Vector(n,jj,Sub,TmpVec,Thr3) + TmpVec(ii)=Zero jj=jj-mk End If * @@ -599,7 +598,7 @@ * * *----------------------------------------------------------------------* * * - CALL Free_Work(ipTmp) + Call mma_deallocate(TmpVec) Reduced=.FALSE. * * ************************************************************************ @@ -610,16 +609,15 @@ * * END DO * - CALL Free_Work(ipDum) - CALL Free_Work(ipDiag) - CALL Free_Work(ipTVec) - CALL Free_Work(ipTAV) - CALL Free_Work(ipTRes) + Call mma_deallocate(Diag) + Call mma_deallocate(TVec) + Call mma_deallocate(TAV ) + Call mma_deallocate(TRes) Call mma_deallocate(Index_D) -*---- Store the current lowest k eigenvectors (in the full space) -* Vec' = Sub * Vec(1:k) -* +!---- Store the current lowest k eigenvectors (in the full space) +! Vec' = Sub * Vec(1:k) + CALL DGeMM_('N','N', & n,k,mk, & One,Sub,n, diff -Nru openmolcas-22.02/src/scf/dgrd.f openmolcas-22.10/src/scf/dgrd.f --- openmolcas-22.02/src/scf/dgrd.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/dgrd.f 2022-10-10 14:22:40.000000000 +0000 @@ -12,13 +12,12 @@ * Compute the difference with the previous gradient * Subroutine dGrd() + use LnkLst, only: SCF_V Implicit None #include "mxdm.fh" #include "real.fh" #include "infscf.fh" -#include "infso.fh" #include "stdalloc.fh" -#include "WrkSpc.fh" #include "file.fh" #include "llists.fh" Integer nD,jpgrd,inode @@ -26,16 +25,16 @@ Integer, External :: LstPtr nD=iUHF+1 Call mma_allocate(Scr,nOV,nD,Label='Scr') - jpgrd=LstPtr(LuGrd,iter,LLGrad) + jpgrd=LstPtr(iter,LLGrad) Call GetNod(iter-1,LLGrad,inode) If (inode.eq.0) Then Write (6,*) 'inode.eq.0' Call Abend() End If - Call iVPtr(LuGrd,Scr,nOV*nD,inode) - Call DaXpY_(nOV*nD,-One,Work(jpgrd),1,Scr,1) + Call iVPtr(Scr,nOV*nD,inode) + Call DaXpY_(nOV*nD,-One,SCF_V(jpgrd)%A,1,Scr,1) Call DScal_(nOV*nD,-One,Scr,1) - Call PutVec(Scr,nOV*nD,LudGd,iter-1,MemRsv,'NOOP',LLdGrd) + Call PutVec(Scr,nOV*nD,iter-1,'NOOP',LLdGrd) Call mma_deallocate(Scr) Return End diff -Nru openmolcas-22.02/src/scf/diis_i.f openmolcas-22.10/src/scf/diis_i.f --- openmolcas-22.02/src/scf/diis_i.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/diis_i.f 2022-10-10 14:22:40.000000000 +0000 @@ -47,6 +47,7 @@ * history: UHF - V.Veryazov, 2003 * * * ************************************************************************ + use SpinAV, only: Do_SpinAV Implicit Real*8 (a-h,o-z) #include "real.fh" #include "mxdm.fh" @@ -55,7 +56,6 @@ * Real*8 CInter(nCI,nD),TrDh(nTr,nTr,nD),TrDP(nTr,nTr,nD), & TrDD(nTr,nTr,nD) -#include "spave.fh" * *---- Define local variables Real*8 Eline(MxOptm,2),Equad(MxOptm**2,2),DD(MxOptm**2,2) diff -Nru openmolcas-22.02/src/scf/diis_x.f openmolcas-22.10/src/scf/diis_x.f --- openmolcas-22.02/src/scf/diis_x.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/diis_x.f 2022-10-10 14:22:40.000000000 +0000 @@ -44,12 +44,12 @@ * history: none * * * ************************************************************************ + use InfSO Implicit Real*8 (a-h,o-z) * #include "real.fh" #include "mxdm.fh" #include "infscf.fh" -#include "infso.fh" #include "stdalloc.fh" #include "file.fh" #include "llists.fh" diff -Nru openmolcas-22.02/src/scf/done_scf.f openmolcas-22.10/src/scf/done_scf.f --- openmolcas-22.02/src/scf/done_scf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/done_scf.f 2022-10-10 14:22:40.000000000 +0000 @@ -50,6 +50,7 @@ #ifndef POINTER_REMAP Use, Intrinsic :: ISO_C_BINDING #endif + use SpinAV Implicit Real*8 (a-h,o-z) * Real*8, Target:: CMO(nCMO), Occ(*), Dlt(*) @@ -58,8 +59,6 @@ Logical alpha_density * #include "real.fh" -#include "WrkSpc.fh" -#include "spave.fh" * *---- Statement function for triangular storage @@ -142,16 +141,16 @@ * pDlt => Dlt(iOffD:iOffD+lth-1) * - ipDScc=ip_DSc+lOff + ipDScc=1+lOff Do j=1,nBas(iSym) Do i=1,j-1 ji=j*(j-1)/2+i iDSc=ipDScc-1+nBas(iSym)*(j-1)+i - pDlt(ji)=pDlt(ji)+xsign*2.0d0*Work(iDSc) + pDlt(ji)=pDlt(ji)+xsign*2.0d0*DSc(iDSc) End Do jj=j*(j+1)/2 iDSc=ipDScc-1+nBas(iSym)*(j-1)+j - pDlt(jj)=pDlt(jj)+xsign*Work(iDSc) + pDlt(jj)=pDlt(jj)+xsign*DSc(iDSc) End Do iOff=iOff+lth lOff=lOff+nBas(iSym)**2 diff -Nru openmolcas-22.02/src/scf/errv.f openmolcas-22.10/src/scf/errv.f --- openmolcas-22.02/src/scf/errv.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/errv.f 2022-10-10 14:22:40.000000000 +0000 @@ -30,7 +30,6 @@ #include "real.fh" #include "mxdm.fh" #include "infscf.fh" -#include "infso.fh" #include "stdalloc.fh" #include "file.fh" #include "llists.fh" @@ -47,13 +46,13 @@ * we eventually need one more vector * Call mma_allocate(Grad,lvec,Label='Grad') - Call iVPtr(LuGrd,Grad,lvec,inode) - Call SOrUpV(MemRsv,Grad,HDiag,lvec,ErrVec,'DISP','BFGS') + Call iVPtr(Grad,lvec,inode) + Call SOrUpV(Grad,HDiag,lvec,ErrVec,'DISP','BFGS') Call mma_deallocate(Grad) * Else * - Call iVPtr(LuGrd,ErrVec,lvec,inode) + Call iVPtr(ErrVec,lvec,inode) * End If * diff -Nru openmolcas-22.02/src/scf/expkap.f openmolcas-22.10/src/scf/expkap.f --- openmolcas-22.02/src/scf/expkap.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/expkap.f 2022-10-10 14:22:40.000000000 +0000 @@ -29,37 +29,52 @@ SubRoutine ExpKap(kapOV,U,mynOcc) * Implicit None + +#define qnext #include "real.fh" #include "mxdm.fh" #include "infscf.fh" * -* declaration subroutine parameters +* Declaration subroutine parameters Real*8 kapOV(nOV),U(nOFS) Integer mynOcc(8) * Integer iKap,iSym,iU,j,jU,mOcc,mOrb,mVir - Real*8 Cpu1,Cpu2,Tim1,Tim2,Tim3,theta + Real*8 Cpu1,Cpu2,Tim1,Tim2,Tim3 + +#ifndef qnext + Real*8 theta +#endif + Real*8, Parameter :: Thrs = 1.0D-14 -* + Call Timing(Cpu1,Tim1,Tim2,Tim3) * iU = 1 iKap = 1 U(:) = Zero + Do iSym=1,nSym mOrb = nOrb(iSym)-nFro(iSym) mOcc = mynOcc(iSym)-nFro(iSym) mVir = mOrb-mOcc + If (mVir*mOcc == 0) Cycle - ! Put the non-zero values in the occ-vir offdiagonal block + jU = iU+mOcc + Do j=1,mOcc U(jU:jU+mVir-1) = kapOV(iKap:iKap+mVir-1) iKap = iKap+mVir jU = jU+mOrb End Do - ! Compute the exponential - Call Exp_Schur(mOrb,U(iU),theta) + +#ifdef qnext + Call matexp(mOrb,mOcc,U(iU:iU+mOrb**2)) +#else + Call Exp_Schur(mOrb,U(iU:iU+mOrb**2),theta) +#endif + iU = iU+mOrb**2 End Do * @@ -69,5 +84,6 @@ * Call Timing(Cpu2,Tim1,Tim2,Tim3) TimFld(10) = TimFld(10) + (Cpu2 - Cpu1) + Return - End + End \ No newline at end of file diff -Nru openmolcas-22.02/src/scf/final.f openmolcas-22.10/src/scf/final.f --- openmolcas-22.02/src/scf/final.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/final.f 2022-10-10 14:22:40.000000000 +0000 @@ -58,10 +58,11 @@ Use mh5, Only: mh5_put_dset #endif Use Interfaces_SCF, Only: dOne_SCF - use OFembed, only: Do_OFemb, FMaux + use OFembed, only: Do_OFemb, FMaux, NDSD #ifdef _FDE_ use Embedding_Global, only: embPot, embWriteEsp #endif + use SpinAV, only: DSc Implicit Real*8 (a-h,o-z) * #include "real.fh" @@ -76,7 +77,6 @@ & Fock(mBT,nD), OccNo(mmB,nD), KntE(mBT), MssVlc(mBT), & Darwin(mBT) * -#include "spave.fh" #include "addcorr.fh" #ifdef _EFP_ Logical EFP_On @@ -527,16 +527,9 @@ #endif & KSDFT.ne.'SCF' ) Call ClsSew * - If (Do_OFemb) Then - Call mma_deallocate(FMaux) -#ifdef _NOT_USED_CODE_ - If (l_NDSD.gt.0) - & Call GetMem('NDSD','Free','Real',ip_NDSD,l_NDSD) -#endif - EndIf - If (MxConstr.gt.0) Then - If (Do_SpinAV) Call GetMem('DSc','Free','Real',ip_DSc,nBB) - EndIf + If (Allocated(FMaux)) Call mma_deallocate(FMaux) + If (Allocated(NDSD)) Call mma_deallocate(NDSD) + If (Allocated(DSc)) Call mma_deallocate(DSc) #ifdef _EFP_ If (EFP_On()) Then Call EFP_ShutDown(EFP_Instance) diff -Nru openmolcas-22.02/src/scf/focktwo_drv_scf.f openmolcas-22.10/src/scf/focktwo_drv_scf.f --- openmolcas-22.02/src/scf/focktwo_drv_scf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/focktwo_drv_scf.f 2022-10-10 14:22:40.000000000 +0000 @@ -10,25 +10,29 @@ ************************************************************************ Subroutine FockTwo_Drv_scf(nSym,nBas,nAux,Keep, & DLT,DSQ,FLT,nFLT, - & ExFac,nBSQT,nBMX,iUHF,DLT_ab, - & DSQ_ab,FLT_ab,nOcc,nOcc_ab,iDummy_run) + & ExFac,nBSQT,nBMX,nD, + & FLT_ab,nOcc,lOcc,iDummy_run) use OFembed, only: Do_OFemb,OFE_first,FMaux use OFembed, only: Rep_EN Implicit Real*8 (a-h,o-z) #include "real.fh" -#include "WrkSpc.fh" #include "stdalloc.fh" + Integer nD Integer nSym,nBas(8), nAux(8), Keep(8) - Integer nOcc(nSym),nOcc_ab(nSym) + Integer nOcc(lOcc,nD) Logical DoCholesky,GenInt,DoLDF - Real*8 DLT(*),DSQ(*),FLT(nFLT) - Real*8 DLT_ab(*),DSQ_ab(*),FLT_ab(*) + Real*8 FLT(nFLT) + Real*8 FLT_ab(*) + Real*8 DLT(nFLT,nD) + Real*8 DSQ(nBSQT,nD) Character*50 CFmt #include "choscf.fh" #include "chotime.fh" + Real*8, Allocatable :: FSQ(:,:) + Real*8, Allocatable :: W1(:), W2(:) + Real*8, Allocatable :: tFLT(:,:) * - GenInt=.false. DoCholesky=.false. if(ALGO.eq.0) GenInt=.true. !use GenInt to regenerate integrals @@ -43,46 +47,32 @@ c write(6,*)'ExFac= ',ExFac * If (Do_OFemb) Then ! Coul. potential from subsys B - nFM=1 - If (iUHF.eq.1) nFM=2 If (OFE_first) Call mma_allocate(FMaux,nFlt,Label='FMaux') - Call Coul_DMB(OFE_first,nFM,Rep_EN,FMaux,DLT,DLT_ab,nFlt) + Call Coul_DMB(OFE_first,nD,Rep_EN,FMaux,DLT(:,1),DLT(:,nD), + & nFlt) OFE_first=.false. End If * - Call GetMem('LWFSQ','Allo','Real',LWFSQ,NBSQT) -C zeroing the elements - call dcopy_(NBSQT,[Zero],0,Work(LWFSQ),1) + Call mma_allocate(FSQ,nBSQT,nD,Label='FSQ') + FSQ(:,:)=Zero - if((.not.DoCholesky).or.(GenInt)) then - Call GetMem('LW2','Allo','Real',LW2,NBMX*NBMX) + if ((.not.DoCholesky).or.(GenInt)) then + Call mma_Allocate(W2,NBMX*NBMX,Label='W2') end if * * nFlt is the total dimension of the LT fock matrix - Call Getmem('tempFLT','Allo','Real',ipTemp,nFlt) - Call FZero(Work(ipTemp),nFlt) -* - IF(iUHF.eq.1) THEN - Call GetMem('LWFSQ_ab','Allo','Real',LWFSQ_ab,NBSQT) - call dcopy_(NBSQT,[Zero],0,Work(LWFSQ_ab),1) - Call Getmem('FLT_ab','Allo','Real',ipTemp_ab,nFlt) - Call FZero(Work(ipTemp_ab),nFlt) -* - if((.not.DoCholesky).or.(GenInt)) then - Call GetMem('LW2_ab','Allo','Real',LW2_ab,NBMX*NBMX) - endif -* - ENDIF + Call mma_allocate(tFLT,nFLT,nD,Label='tFLT') + tFLT(:,:)=Zero * * - Call GetMem('LW1','MAX','Real',LW1,LBUF) + Call mma_maxDBLE(LBUF) * * Standard building of the Fock matrix from Two-el integrals * Call CWTIME(TotCPU1,TotWALL1) IF (.not.DoCholesky) THEN - Call GetMem('LW1','Allo','Real',LW1,LBUF) + Call mma_allocate(W1,LBUF,Label='W1') * If (LBUF.LT.NBMX**2) Then WRITE(6,*)'FockTwo_Drv_SCF Error: Too little memory remains' @@ -94,22 +84,10 @@ Call ABEND() End If * - If (iUHF.eq.1) Then - - Call FOCKTWO_scf(nSym,nBas,nAux,Keep, - & DLT,DSQ,Work(ipTemp),nFlt, - & Work(LWFSQ),LBUF,Work(LW1),Work(LW2),ExFac,iUHF, - & DLT_ab,DSQ_ab,Work(ipTemp_ab),Work(LWFSQ_ab)) - - Else ! RHF calculation - - Call FOCKTWO_scf(nSym,nBas,nAux,Keep, - & DLT,DSQ,Work(ipTemp),nFlt, - & Work(LWFSQ),LBUF,Work(LW1),Work(LW2),ExFac,iUHF, - & Work(ip_Dummy),Work(ip_Dummy),Work(ip_Dummy), - & Work(ip_Dummy)) - - EndIf + Call FOCKTWO_scf(nSym,nBas,nAux,Keep, + & DLT(:,1),DSQ(:,1),tFLT,nFlt, + & FSQ,LBUF,W1,W2,ExFac,nD,nBSQT, + & DLT(:,nD),DSQ(:,nD)) ENDIF * @@ -117,7 +95,7 @@ * IF ((DoCholesky).and.(GenInt)) THEN ! save some space for GenInt LBUF = MAX(LBUF-LBUF/10,0) - Call GetMem('LW1','Allo','Real',LW1,LBUF) + Call mma_allocate(W1,LBUF,Label='W1') * If (LBUF.LT.NBMX**2) Then WRITE(6,*)' FockTwo_Drv Error: Too little memory remains for' @@ -129,22 +107,10 @@ Call ABEND() End If * - If (iUHF.eq.1) Then - - Call FOCKTWO_scf(nSym,nBas,nAux,Keep, - & DLT,DSQ,Work(ipTemp),nFlt, - & Work(LWFSQ),LBUF,Work(LW1),Work(LW2),ExFac,iUHF, - & DLT_ab,DSQ_ab,Work(ipTemp_ab),Work(LWFSQ_ab)) - - Else ! RHF calculation - - Call FOCKTWO_scf(nSym,nBas,nAux,Keep, - & DLT,DSQ,Work(ipTemp),nFlt, - & Work(LWFSQ),LBUF,Work(LW1),Work(LW2),ExFac,iUHF, - & Work(ip_Dummy),Work(ip_Dummy),Work(ip_Dummy), - & Work(ip_Dummy)) - - EndIf + Call FOCKTWO_scf(nSym,nBas,nAux,Keep, + & DLT(:,1),DSQ(:,1),tFLT,nFlt, + & FSQ,LBUF,W1,W2,ExFac,nD,nBSQT, + & DLT(:,nD),DSQ(:,nD)) ENDIF * @@ -183,48 +149,31 @@ IF (DoCholesky .and. .not.GenInt.and.iDummy_run.eq.0) THEN * - If (iUHF.eq.1) Then - - CALL CHOscf_drv(iUHF,nSym,nBas,DSQ,DLT,DSQ_ab,DLT_ab, - & Work(ipTemp),Work(ipTemp_ab),nFLT,ExFac, - & Work(LWFSQ),Work(LWFSQ_ab),nOcc,nOcc_ab) - Else -* - CALL CHOscf_drv(iUHF,nSym,nBas,DSQ,DLT, - & Work(ip_Dummy),Work(ip_Dummy), - & Work(ipTemp),Work(ip_Dummy),nFLT,ExFac, - & Work(LWFSQ),Work(ip_Dummy),nOcc,iWork(ip_iDummy)) - EndIf + CALL CHOscf_drv(nBSQT,nD,nSym,nBas,DSQ(:,1),DLT(:,1), + & DSQ(:,nD),DLT(:,nD), + & tFLT(:,1),tFLT(:,nD),nFLT,ExFac, + & FSQ,nOcc(:,1),nOcc(:,nD)) ENDIF * - Call DaXpY_(nFlt,One,Work(ipTemp),1,FLT,1) - if(iUHF.eq.1) then - Call DaXpY_(nFlt,One,Work(ipTemp_ab),1,FLT_ab,1) + Call DaXpY_(nFlt,One,tFLT(:,1),1,FLT,1) + if(nD==2) then + Call DaXpY_(nFlt,One,tFLT(:,2),1,FLT_ab,1) endif * - Call GetMem('tempFLT','Free','Real',ipTemp,nFlt) - if(iUHF.eq.1) then - Call GetMem('FLT_ab','Free','Real',ipTemp_ab,nFlt) - endif + Call mma_deallocate(tFLT) * If (Do_OFemb) Then ! add FM from subsystem B Call DaXpY_(nFlt,One,FMaux,1,FLT,1) - If (iUHF.eq.1) Call DaXpY_(nFlt,One,FMaux,1,FLT_ab,1) + If (nD==2) Call DaXpY_(nFlt,One,FMaux,1,FLT_ab,1) EndIf * IF ((.not.DoCholesky).or.(GenInt)) THEN - Call GetMem('LW1','Free','Real',LW1,LBUF) - Call GetMem('LW2','Free','Real',LW2,NBMX*NBMX) + Call mma_deallocate(W1) + Call mma_deallocate(W2) END IF - Call GetMem('LWFSQ','Free','Real',LWFSQ,NBSQT) - if(iUHF.eq.1) then - IF ((.not.DoCholesky).or.(GenInt)) THEN - Call GetMem('LW2_ab','Free','Real',LW2_ab,NBMX*NBMX) - END IF - Call GetMem('LWFSQ_ab','Free','Real',LWFSQ_ab,NBSQT) - endif + Call mma_deallocate(FSQ) * Return End diff -Nru openmolcas-22.02/src/scf/focktwo_scf.f openmolcas-22.10/src/scf/focktwo_scf.f --- openmolcas-22.02/src/scf/focktwo_scf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/focktwo_scf.f 2022-10-10 14:22:40.000000000 +0000 @@ -13,11 +13,13 @@ * 2002, Roland Lindh * ************************************************************************ SUBROUTINE FOCKTWO_scf(NSYM,NBAS,NFRO,KEEP, - & DLT,DSQ,FLT,nFlt,FSQ,LBUF,X1,X2,ExFac,iUHF, - & DLT_ab,DSQ_ab,FLT_ab,FSQ_ab) + & DLT,DSQ,FLT,nFlt,FSQ,LBUF,X1,X2,ExFac,nD,nBSQT, + & DLT_ab,DSQ_ab) IMPLICIT REAL*8 (A-H,O-Z) - Real*8 FSQ(*),FLT(nFlt),DSQ(*),DLT(*),X1(*),X2(*) - Real*8 DLT_ab(*),DSQ_ab(*),FLT_ab(*),FSQ_ab(*) + Real*8 DSQ(*),DLT(*),X1(*),X2(*) + Real*8 DLT_ab(*),DSQ_ab(*) + Real*8 FSQ(nBSQT,nD) + Real*8 FLT(nFlt,nD) Integer ISTLT(8),ISTSQ(8),KEEP(8),NBAS(8),NFRO(8) Logical myDebug c @@ -43,7 +45,7 @@ ************************************************************************ myDebug=.false. Factor=0.5D0 - if(iUHF.eq.1) Factor=1.0D0 + if(nD==2) Factor=1.0D0 #ifdef _BUGPRINT_ c myDebug=.true. ! very extensive print out #endif @@ -112,65 +114,52 @@ ISF=ISTLT(IS)+LPQ ISD=ISTLT(IS)+1 TEMP=DDOT_(KLB,X1(ISX),1,DLT(ISD),1) - FLT(ISF)=FLT(ISF)+TEMP - if(iUHF.eq.1) then + FLT(ISF,1)=FLT(ISF,1)+TEMP + if(nD==2) then TEMP_ab=DDOT_(KLB,X1(ISX),1,DLT_ab(ISD),1) - FLT(ISF)=FLT(ISF)+TEMP_ab - FLT_ab(ISF)=FLT(ISF) + FLT(ISF,1)=FLT(ISF,1)+TEMP_ab + FLT(ISF,2)=FLT(ISF,1) endif if(myDebug) then - write (6,'(a,i5,a,f12.6)') '00 Flt(',isf,')=',FLT(ISF) - if(iUHF.eq.1) then - write (6,'(a,i5,a,f12.6)') '00 Flt_ab(',isf,')=',FLT_ab(ISF) + write (6,'(a,i5,a,f12.6)') '00 Flt(',isf,',1)=',FLT(ISF,1) + if(nD==2) then + write (6,'(a,i5,a,f12.6)') '00 Flt(',isf,',2)=',FLT(ISF,2) endif endif CALL SQUARE (X1(ISX),X2(1),1,KB,LB) ISF=ISTSQ(IS)+(JQ-1)*JB+1 ISD=ISTSQ(IS)+(IP-1)*IB+1 c - if(iUHF.eq.0) then -* CALL DGEMX (KB,LB,-Factor*ExFac,X2(1),KB, -* & DSQ(ISD),1,FSQ(ISF),1) + if(nD==1) then CALL DGEMV_('N',KB,LB,-Factor*ExFac,X2(1),KB, - & DSQ(ISD),1,1.0D0,FSQ(ISF),1) + & DSQ(ISD),1,1.0D0,FSQ(ISF,1),1) else -* CALL DGEMX (KB,LB,-Factor*ExFac,X2(1),KB, -* & DSQ(ISD),1,FSQ(ISF),1) -* -* CALL DGEMX (KB,LB,-Factor*ExFac,X2(1),KB, -* & DSQ_ab(ISD),1,FSQ_ab(ISF),1) CALL DGEMV_('N',KB,LB,-Factor*ExFac,X2(1),KB, - & DSQ(ISD),1,1.0D0,FSQ(ISF),1) + & DSQ(ISD),1,1.0D0,FSQ(ISF,1),1) CALL DGEMV_('N',KB,LB,-Factor*ExFac,X2(1),KB, - & DSQ_ab(ISD),1,1.0D0,FSQ_ab(ISF),1) + & DSQ_ab(ISD),1,1.0D0,FSQ(ISF,2),1) endif IF ( IP.NE.JQ ) THEN ISF=ISTSQ(IS)+(IP-1)*IB+1 ISD=ISTSQ(IS)+(JQ-1)*JB+1 c - if(iUHF.eq.0) then -* CALL DGEMX (KB,LB,-Factor*ExFac,X2(1),KB, -* & DSQ(ISD),1,FSQ(ISF),1) + if(nD==1) then CALL DGEMV_('N',KB,LB,-Factor*ExFac,X2(1),KB, - & DSQ(ISD),1,1.0D0,FSQ(ISF),1) + & DSQ(ISD),1,1.0D0,FSQ(ISF,1),1) else -* CALL DGEMX (KB,LB,-Factor*ExFac,X2(1),KB, -* & DSQ(ISD),1,FSQ(ISF),1) -* CALL DGEMX (KB,LB,-Factor*ExFac,X2(1),KB, -* & DSQ_ab(ISD),1,FSQ_ab(ISF),1) CALL DGEMV_('N',KB,LB,-Factor*ExFac,X2(1),KB, - & DSQ(ISD),1,1.0D0,FSQ(ISF),1) + & DSQ(ISD),1,1.0D0,FSQ(ISF,1),1) CALL DGEMV_('N',KB,LB,-Factor*ExFac,X2(1),KB, - & DSQ_ab(ISD),1,1.0D0,FSQ_ab(ISF),1) + & DSQ_ab(ISD),1,1.0D0,FSQ(ISF,2),1) endif ENDIF if(myDebug) then write (6,'(a,i5,a,f12.6)') - & ('01 Fsq(',isf+ivv-1,')=',FSQ(ISF+ivv-1),ivv=1,kb) - if(iUHF.eq.1) then + & ('01 Fsq(',isf+ivv-1,',1)=',FSQ(ISF+ivv-1,1),ivv=1,kb) + if(nD==2) then write (6,'(a,i5,a,f12.6)') - & ('01 Fsq_ab(',isf+ivv-1,')=',FSQ_ab(ISF+ivv-1),ivv=1,kb) + & ('01 Fsq(',isf+ivv-1,',2)=',FSQ(ISF+ivv-1,2),ivv=1,kb) endif endif @@ -199,26 +188,26 @@ ISF=ISTLT(KS)+1 ISD=ISTLT(IS)+LPQ TEMP=DLT(ISD) - if(iUHF.eq.1) then + if(nD==2) then TEMP=DLT(ISD)+DLT_ab(ISD) endif - CALL DAXPY_(KLB,TEMP,X1(ISX),1,FLT(ISF),1) - if(iUHF.eq.1) then - CALL DAXPY_(KLB,TEMP,X1(ISX),1,FLT_ab(ISF),1) + CALL DAXPY_(KLB,TEMP,X1(ISX),1,FLT(ISF,1),1) + if(nD==2) then + CALL DAXPY_(KLB,TEMP,X1(ISX),1,FLT(ISF,2),1) endif ENDIF IF ( NFK.NE.0 ) THEN ISF=ISTLT(IS)+LPQ ISD=ISTLT(KS)+1 TEMP=DDOT_(KLB,X1(ISX),1,DLT(ISD),1) - FLT(ISF)=FLT(ISF)+TEMP - if(iUHF.eq.1) then - TEMP_ab=DDOT_(KLB,X1(ISX),1,DLT_ab(ISD),1) - FLT(ISF)=FLT(ISF)+TEMP_ab - FLT_ab(ISF)=FLT(ISF) - endif + FLT(ISF,1)=FLT(ISF,1)+TEMP + if (nD==2) then + TEMP_ab=DDOT_(KLB,X1(ISX),1,DLT_ab(ISD),1) + FLT(ISF,1)=FLT(ISF,1)+TEMP_ab + FLT(ISF,2)=FLT(ISF,1) + endif if(myDebug) then - write (6,'(a,i5,a,f12.6)') '02 Flt(',isf,')=',FLT(ISF) + write (6,'(a,i5,a,f12.6)') '02 Flt(',isf,',1)=',FLT(ISF,1) endif ENDIF @@ -245,48 +234,36 @@ IF ( NFI.NE.0 ) THEN ISD=ISTSQ(IS)+(IP-1)*IB+1 ISF=ISTSQ(JS)+(JQ-1)*JB+1 - if(iUHF.eq.0) then -* CALL DGEMX (LB,KB,-Factor*ExFac,X1(ISX),LB, -* & DSQ(ISD),1,FSQ(ISF),1) + if(nD==1) then CALL DGEMV_('N',LB,KB,-Factor*ExFac,X1(ISX),LB, - & DSQ(ISD),1,1.0D0,FSQ(ISF),1) + & DSQ(ISD),1,1.0D0,FSQ(ISF,1),1) else -* CALL DGEMX (LB,KB,-Factor*ExFac,X1(ISX),LB, -* & DSQ(ISD),1,FSQ(ISF),1) -* CALL DGEMX (LB,KB,-Factor*ExFac,X1(ISX),LB, -* & DSQ_ab(ISD),1,FSQ_ab(ISF),1) CALL DGEMV_('N',LB,KB,-Factor*ExFac,X1(ISX),LB, - & DSQ(ISD),1,1.0D0,FSQ(ISF),1) + & DSQ(ISD),1,1.0D0,FSQ(ISF,1),1) CALL DGEMV_('N',LB,KB,-Factor*ExFac,X1(ISX),LB, - & DSQ_ab(ISD),1,1.0D0,FSQ_ab(ISF),1) + & DSQ_ab(ISD),1,1.0D0,FSQ(ISF,2),1) endif ENDIF IF ( NFJ.NE.0 ) THEN ISD=ISTSQ(JS)+(JQ-1)*JB+1 ISF=ISTSQ(IS)+(IP-1)*IB+1 - if(iUHF.eq.0) then -* CALL DGEMTX (LB,KB,-Factor*ExFac,X1(ISX),LB, -* & DSQ(ISD),1,FSQ(ISF),1) + if(nD==1) then CALL DGEMV_('T',LB,KB,-Factor*ExFac,X1(ISX),LB, - & DSQ(ISD),1,1.0D0,FSQ(ISF),1) + & DSQ(ISD),1,1.0D0,FSQ(ISF,1),1) else -* CALL DGEMTX (LB,KB,-Factor*ExFac,X1(ISX),LB, -* & DSQ(ISD),1,FSQ(ISF),1) -* CALL DGEMTX (LB,KB,-factor*ExFac,X1(ISX),LB, -* & DSQ_ab(ISD),1,FSQ_ab(ISF),1) CALL DGEMV_('T',LB,KB,-Factor*ExFac,X1(ISX),LB, - & DSQ(ISD),1,1.0D0,FSQ(ISF),1) + & DSQ(ISD),1,1.0D0,FSQ(ISF,1),1) CALL DGEMV_('T',LB,KB,-factor*ExFac,X1(ISX),LB, - & DSQ_ab(ISD),1,1.0D0,FSQ_ab(ISF),1) + & DSQ_ab(ISD),1,1.0D0,FSQ(ISF,2),1) endif ENDIF if(myDebug) then write (6,'(a,i5,a,f20.6)') - & ('03 Fsq(',isf+ivv-1,')=',FSQ(ISF+ivv-1),ivv=1,kb) - if(iUHF.eq.1) then + & ('03 Fsq(',isf+ivv-1,',1)=',FSQ(ISF+ivv-1,1),ivv=1,kb) + if(nD==2) then write (6,'(a,i5,a,f20.6)') - & ('03 Fsq_ab(',isf+ivv-1,')=',FSQ_ab(ISF+ivv-1),ivv=1,kb) + & ('03 Fsq(',isf+ivv-1,',2)=',FSQ(ISF+ivv-1,2),ivv=1,kb) endif endif @@ -304,19 +281,17 @@ K2=ISTSQ(ISYM) DO 310 IB=1,NB DO 315 JB=1,IB -c write (6,'(a,i5,a,f12.6)') ' >> Flt(',K1+JB,')=',FLT(K1+JB) -c write (6,'(a,i5,a,f12.6)') ' >> Fsq(',K2+JB,')=',FSQ(K2+JB) - FLT(K1+JB)=FLT(K1+JB)+FSQ(K2+JB) - if(iUHF.eq.1) then - FLT_ab(K1+JB)=FLT_ab(K1+JB)+FSQ_ab(K2+JB) + FLT(K1+JB,1)=FLT(K1+JB,1)+FSQ(K2+JB,1) + if(nD==2) then + FLT(K1+JB,2)=FLT(K1+JB,2)+FSQ(K2+JB,2) endif if(myDebug) then - if(iUHF.eq.0)then - write (6,'(a,i5,a,f12.6)') 'Flt(',K1+JB,')=',FLT(K1+JB) + if(nD==1)then + write (6,'(a,i5,a,f12.6)') 'Flt(',K1+JB,',1)=',FLT(K1+JB,1) else - write (6,'(a,i5,a,2f12.6)') 'Flt_ab(',K1+JB,')=', - & FLT(K1+JB),FLT_ab(K1+JB) + write (6,'(a,i5,a,2f12.6)') 'Flt(',K1+JB,',:)=', + & FLT(K1+JB,1),FLT(K1+JB,2) endif endif @@ -326,8 +301,7 @@ 310 CONTINUE 300 CONTINUE * - Call GADSum(Flt,nFlt) - If (iUHF.eq.1) Call GADSum(Flt_ab,nFlt) + Call GADSum(Flt,nFlt*nD) * c Print the Fock-matrix #ifdef _DEBUGPRINT_ @@ -338,9 +312,9 @@ NB=NBAS(ISYM) IF ( NB.GT.0 ) THEN WRITE(6,'(6X,A,I2)')'SYMMETRY SPECIES:',ISYM - CALL TRIPRT(' ',' ',FLT(ISTLTT),NB) - if(iUHF.eq.1) then - CALL TRIPRT(' ',' ',FLT_ab(ISTLTT),NB) + CALL TRIPRT(' ',' ',FLT(ISTLTT,1),NB) + if(nD==2) then + CALL TRIPRT(' ',' ',FLT(ISTLTT,2),NB) endif ISTLTT=ISTLTT+NB*(NB+1)/2 END IF diff -Nru openmolcas-22.02/src/scf/get_DEcorr.f openmolcas-22.10/src/scf/get_DEcorr.f --- openmolcas-22.02/src/scf/get_DEcorr.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/get_DEcorr.f 2022-10-10 14:22:40.000000000 +0000 @@ -10,27 +10,26 @@ ************************************************************************ Subroutine Get_DEcorr(nh1,Grad,nGrad,DFTFOCK) use SCF_Arrays, only: CMO + use SpinAV Implicit Real*8 (a-h,o-z) #include "real.fh" #include "mxdm.fh" -#include "WrkSpc.fh" +#include "stdalloc.fh" #include "infscf.fh" Real*8 Grad(nGrad), Ec_AB(2) Character*4 DFTFOCK #include "addcorr.fh" -#include "spave.fh" + Real*8, Allocatable :: F_DFT(:,:), D_DS(:,:) + nD=2 * - Call GetMem('F-DS','Allo','Real',ipF_DFT,2*nBT) - Call GetMem('D-DS','Allo','Real',ip_D_DS,2*nBT) - ip_Da=ip_D_DS - ip_Db=ip_D_DS+nBT + Call mma_allocate(F_DFT,nBT,nD,Label='F_DFT') + Call mma_allocate(D_DS ,nBT,nD,Label='D_DS') * Do iAB=1,2 iOff=1 - jOff=0 + jOff=1 lOff=0 Do iSym=1,nSym - ipDaa=ip_Da+jOff If (iAB.eq.1) Then nXoX=nOcc(iSym,1) iXoX=0 @@ -42,8 +41,7 @@ Call DGEMM_tri('N','T',nBas(iSym),nBas(iSym),nXoX, & 1.0d0,CMO(mAdCMOO,1),nBas(iSym), & CMO(mAdCMOO,1),nBas(iSym), - & 0.0d0,Work(ipDaa),nBas(iSym)) - ipDbb=ip_Db+jOff + & 0.0d0,D_DS(jOff,1),nBas(iSym)) If (iAB.eq.1) Then nXoX=nOcc(iSym,2) iXoX=0 @@ -55,17 +53,16 @@ Call DGEMM_tri('N','T',nBas(iSym),nBas(iSym),nXoX, & 1.0d0,CMO(mAdCMOO,2),nBas(iSym), & CMO(mAdCMOO,2),nBas(iSym), - & 0.0d0,Work(ipDbb),nBas(iSym)) + & 0.0d0,D_DS(jOff,2),nBas(iSym)) * If (Do_SpinAV) Then Do j=1,nBas(iSym) Do i=1,j - iDSc=ip_DSc-1+nBas(iSym)*(j-1)+i + iDSc=nBas(iSym)*(j-1)+i ji=j*(j-1)/2+i - iDaa=ipDaa-1+ji - Work(iDaa)=Work(iDaa)-Work(iDSc) - iDbb=ipDbb-1+ji - Work(iDbb)=Work(iDbb)+Work(iDSc) + iDij=jOff-1+ji + D_DS(iDij,1)=D_DS(iDij,1)-DSc(iDSc) + D_DS(iDij,2)=D_DS(iDij,2)+DSc(iDSc) End Do End Do lOff=lOff+nBas(iSym)**2 @@ -74,43 +71,42 @@ Do j=1,nBas(iSym) Do i=1,j-1 ji=j*(j-1)/2+i - iDaa=ipDaa-1+ji - Work(iDaa)=2.0d0*Work(iDaa) - iDbb=ipDbb-1+ji - Work(iDbb)=2.0d0*Work(iDbb) + iDij=jOff-1+ji + D_DS(iDij,1)=2.0d0*D_DS(iDij,1) + D_DS(iDij,2)=2.0d0*D_DS(iDij,2) End Do End Do iOff=iOff+nBas(iSym)*nOrb(iSym) jOff=jOff+nBas(iSym)*(nBas(iSym)+1)/2 End Do * - Call Get_Ecorr_dft(nh1,Grad,nGrad,DFTFOCK,ipF_DFT,ip_D_DS, + Call Get_Ecorr_dft(nh1,Grad,nGrad,DFTFOCK,F_DFT,D_DS,nBT,nD, & ADDC_KSDFT,Ec_AB(iAB)) End Do *----------------------------------------------------------------------* DE_KSDFT_c=Ec_AB(1)-Ec_AB(2) *----------------------------------------------------------------------* * - Call GetMem('D-DS','Free','Real',ip_D_DS,2*nBT) - Call GetMem('F-DS','Free','Real',ipF_DFT,2*nBT) + Call mma_deallocate(D_DS) + Call mma_deallocate(F_DFT) Return End * * ************************************************************************ * * - Subroutine Get_Ecorr_dft(nh1,Grad,nGrad,DFTFOCK,ipF_DFT,ip_D_DS, - & KSDFT,Ec_AB) + Subroutine Get_Ecorr_dft(nh1,Grad,nGrad,DFTFOCK,F_DFT,D_DS, + & nBT,nD,KSDFT,Ec_AB) use OFembed, only: dFMD, Do_Core - use nq_Info + use nq_Info, only: Dens_I, Grad_I, Tau_I Implicit Real*8 (a-h,o-z) #include "real.fh" -#include "WrkSpc.fh" #include "debug.fh" Real*8 Grad(nGrad) Logical Do_MO,Do_TwoEl,Do_Grad - Character*4 DFTFOCK - Character*16 KSDFT + Character(LEN=4) DFTFOCK + Character(LEN=80) KSDFT + Real*8 :: F_DFT(nBT,nD), D_DS(nBT,nD) Debug=.False. * * @@ -134,8 +130,7 @@ * * Do_Core=.True. Call Driver(KSDFT,Do_Grad,Func,Grad,nGrad, - & Do_MO,Do_TwoEl,Work(ip_D_DS), - & Work(ipF_DFT),nh1,nFckDim,DFTFOCK) + & Do_MO,Do_TwoEl,D_DS,F_DFT,nh1,nFckDim,DFTFOCK) Do_Core=.False. * * ************************************************************************ @@ -148,8 +143,7 @@ write(6,*) ' Correlation potentials: (itri,F_alpha,F_beta)' write(6,*) Do i=1,nh1 - Write(6,'(i4,3f22.16)') i,Work(ipF_DFT+i-1), - & Work(ipF_DFT+i-1+nh1) + Write(6,'(i4,3f22.16)') i,F_DFT(i,1),F_DFT(i,2) End Do #endif * diff -Nru openmolcas-22.02/src/scf/get_Enondyn_dft.f openmolcas-22.10/src/scf/get_Enondyn_dft.f --- openmolcas-22.02/src/scf/get_Enondyn_dft.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/get_Enondyn_dft.f 2022-10-10 14:22:40.000000000 +0000 @@ -13,38 +13,34 @@ Implicit Real*8 (a-h,o-z) #include "real.fh" #include "mxdm.fh" -#include "WrkSpc.fh" +#include "stdalloc.fh" #include "infscf.fh" Real*8 Grad(nGrad) Character*4 DFTFOCK #include "dcscf.fh" + Real*8, Allocatable :: F_DFT(:,:), D_DS(:,:) * Erest_xc=0.0d0 - Call GetMem('F-DS','Allo','Real',ipF_DFT,2*nBT) - Call GetMem('D-DS','Allo','Real',ip_D_DS,2*nBT) - ip_Da=ip_D_DS - ip_Db=ip_D_DS+nBT + Call mma_allocate(D_DS ,nBT,2,Label='D_DS ') + D_DS(:,:)=Zero * iOff=1 - jOff=0 + jOff=1 Do iSym=1,nSym - ipDaa=ip_Da+jOff Call DGEMM_tri('N','T',nBas(iSym),nBas(iSym),nOcc(iSym,1), & 1.0d0,CMO(iOff,1),nBas(iSym), & CMO(iOff,1),nBas(iSym), - & 0.0d0,Work(ipDaa),nBas(iSym)) - ipDbb=ip_Db+jOff + & 0.0d0,D_DS(jOff:,1),nBas(iSym)) Call DGEMM_tri('N','T',nBas(iSym),nBas(iSym),nOcc(iSym,2), & 1.0d0,CMO(iOff,2),nBas(iSym), & CMO(iOff,2),nBas(iSym), - & 0.0d0,Work(ipDbb),nBas(iSym)) + & 0.0d0,D_DS(jOff:,2),nBas(iSym)) Do j=1,nBas(iSym) Do i=1,j-1 ji=j*(j-1)/2+i - iDaa=ipDaa-1+ji - Work(iDaa)=2.0d0*Work(iDaa) - iDbb=ipDbb-1+ji - Work(iDbb)=2.0d0*Work(iDbb) + iDji=iOff-1+ji + D_DS(iDji,1)=2.0d0*D_DS(iDji,1) + D_DS(iDji,2)=2.0d0*D_DS(iDji,2) End Do End Do iOff=iOff+nBas(iSym)*nOrb(iSym) @@ -52,34 +48,34 @@ End Do * *----------------------------------------------------------------------* - Call Get_Fmat_nondyn(Work(ip_Da),Work(ip_Db),nBT,.true.) + Call Get_Fmat_nondyn(D_DS(:,1),D_DS(:,2),nBT,.true.) *----------------------------------------------------------------------* * *----------------------------------------------------------------------* - Call Get_Exc_dft(nh1,Grad,nGrad,DFTFOCK,ipF_DFT,ip_D_DS, + Call mma_allocate(F_DFT,nBT,2,Label='F_DFT') + Call Get_Exc_dft(nh1,Grad,nGrad,DFTFOCK,F_DFT,D_DS,nBT,2, & KSDFT) *----------------------------------------------------------------------* * - Call GetMem('D-DS','Free','Real',ip_D_DS,2*nBT) - Call GetMem('F-DS','Free','Real',ipF_DFT,2*nBT) + Call mma_deallocate(D_DS) + Call mma_deallocate(F_DFT) Return End * * ************************************************************************ * * - Subroutine Get_Exc_dft(nh1,Grad,nGrad,DFTFOCK,ipF_DFT,ip_D_DS, + Subroutine Get_Exc_dft(nh1,Grad,nGrad,DFTFOCK,F_DFT,D_DS,nBT,nD, & KSDFT) - use nq_Info + use nq_Info, only: Dens_I, Grad_I, Tau_I Implicit Real*8 (a-h,o-z) #include "real.fh" -#include "WrkSpc.fh" #include "debug.fh" Real*8 Grad(nGrad) Logical Do_MO,Do_TwoEl,Do_Grad Character*4 DFTFOCK - Character*16 KSDFT + Character*80 KSDFT #include "dcscf.fh" - + Real*8 :: D_DS(nBT,nD), F_DFT(nBT,nD) * Debug=.False. * * @@ -100,8 +96,7 @@ ************************************************************************ * * Call Driver(KSDFT,Do_Grad,Func,Grad,nGrad, - & Do_MO,Do_TwoEl,Work(ip_D_DS), - & Work(ipF_DFT),nh1,nFckDim,DFTFOCK) + & Do_MO,Do_TwoEl,D_DS,F_DFT,nh1,nFckDim,DFTFOCK) * * ************************************************************************ * * @@ -113,8 +108,7 @@ write(6,*) ' XC-potentials: (itri,F_alpha,F_beta)' write(6,*) Do i=1,nh1 - Write(6,'(i4,3f22.16)') i,Work(ipF_DFT+i-1), - & Work(ipF_DFT+i-1+nh1) + Write(6,'(i4,3f22.16)') i,F_DFT(i,1),F_DFT(i,2) End Do #endif * diff -Nru openmolcas-22.02/src/scf/grdclc.f openmolcas-22.10/src/scf/grdclc.f --- openmolcas-22.02/src/scf/grdclc.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/grdclc.f 2022-10-10 14:22:40.000000000 +0000 @@ -21,7 +21,6 @@ #include "real.fh" #include "mxdm.fh" #include "infscf.fh" -#include "WrkSpc.fh" * nD = iUHF + 1 * * @@ -68,11 +67,11 @@ * * ************************************************************************ Use Interfaces_SCF, Only: vOO2OV + Use InfSO Implicit Real*8 (a-h,o-z) #include "real.fh" #include "mxdm.fh" #include "infscf.fh" -#include "infso.fh" #include "stdalloc.fh" #include "file.fh" #include "llists.fh" @@ -138,7 +137,7 @@ * *------- Write Gradient to linked list * - Call PutVec(GrdOV,nD*nOV,LuGrd,iDT+iter0,MemRsv,'OVWR',LLGrad) + Call PutVec(GrdOV,nD*nOV,iDT+iter0,'OVWR',LLGrad) * #ifdef _DEBUGPRINT_ Write (6,*) 'GrdClc: Put Gradient iteration:',iDT+iter0 diff -Nru openmolcas-22.02/src/scf/infscf.fh openmolcas-22.10/src/scf/infscf.fh --- openmolcas-22.02/src/scf/infscf.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/infscf.fh 2022-10-10 14:22:40.000000000 +0000 @@ -195,7 +195,7 @@ Character*(LENIN) Atom(MxBS) Character*8 Type(MxBS) Character*4 Neg2_Action - Character*16 KSDFT + Character*80 KSDFT Character*512 SCF_FileOrb Logical isHDF5 Integer fileorb_id diff -Nru openmolcas-22.02/src/scf/infso.f90 openmolcas-22.10/src/scf/infso.f90 --- openmolcas-22.02/src/scf/infso.f90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/scf/infso.f90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,28 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** +! Module for second order update info +! +! iterso - second order iteration number +! - comes into play +! MemRsv - memory kept unallocated in LList management +! QNRTh - threshold for QNR/C2Diis startup +! DltNTh - convergence threshold for Norm of delta +! DltNrm - actual Norm of delta after QNR/C2Diis extrapolation + +Module InfSO + +Integer :: iterso=0 +Integer :: MemRsv=0 +Real*8 :: QNRTh = 0.075d+00 +Real*8 :: DltNTh= 0.2d-4 +Real*8 :: DltNrm= 0.0D0 + +End Module InfSO diff -Nru openmolcas-22.02/src/scf/infso.fh openmolcas-22.10/src/scf/infso.fh --- openmolcas-22.02/src/scf/infso.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/infso.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -* include file for second order update info -* eventually can be merged with infscf.fh -* and addr.fh -* -* iterso - second order iteration number -* - comes into play -* micItT - # of linesearch (micro) iterations -* MemRsv - memory kept unallocated in LList management -* QNRTh - threshold for QNR/C2Diis startup -* DltNTh - convergence threshold for Norm of delta -* DltNrm - actual Norm of delta after QNR/C2Diis extrapolation - Integer iterso, MemRsv, micItT - Real*8 QNRTh,DltNTh,DltNrm -* - Common /INFSO/ QNRTh,DltNTh,DltNrm,iterso,micItT,MemRsv diff -Nru openmolcas-22.02/src/scf/inibuf.f openmolcas-22.10/src/scf/inibuf.f --- openmolcas-22.02/src/scf/inibuf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/inibuf.f 2022-10-10 14:22:40.000000000 +0000 @@ -11,17 +11,17 @@ * Copyright (C) 1998, Roland Lindh * ************************************************************************ SubRoutine IniBuf(nDisc,nCore) -************************************************************************ -* * -* Object: Initiate I/O buffer for semi-direct SCF * -* * -* Called from: * -* * -* Calling : * -* * -* Author: Roland Lindh, Dept. of Chemical Physics, * -* University of Lund, Sweden. October '98 * -************************************************************************ +!*********************************************************************** +! * +! Object: Initiate I/O buffer for semi-direct SCF * +! * +! Called from: * +! * +! Calling : * +! * +! Author: Roland Lindh, Dept. of Chemical Physics, * +! University of Lund, Sweden. October '98 * +!*********************************************************************** use IOBUF Implicit Real*8 (A-H,O-Z) #include "stdalloc.fh" @@ -59,7 +59,7 @@ * If (OnDisk.or.InCore) Then MemMin_Seward=1024**2 ! Real*8 - Call GetMem('IniBuf','Max','Real',iDum,MaxMem) + Call mma_maxDBLE(MaxMem) * lBuf in units of Real*8 per buffer lBuf=(1024*nCore)/(8*nBuf) if(InCore) then diff -Nru openmolcas-22.02/src/scf/ldfscf_drv.f openmolcas-22.10/src/scf/ldfscf_drv.f --- openmolcas-22.02/src/scf/ldfscf_drv.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/ldfscf_drv.f 2022-10-10 14:22:40.000000000 +0000 @@ -10,8 +10,8 @@ * * * Copyright (C) 2010, Thomas Bondo Pedersen * ************************************************************************ - Subroutine LDFSCF_Drv(iUHF,nSym,nBas,DSQ,DLT,DSQ_ab,DLT_ab, - & FLT,FLT_ab,nFLT,ExFac,FSQ,FSQ_ab, + Subroutine LDFSCF_Drv(nD,nSym,nBas,DSQ,DLT,DSQ_ab,DLT_ab, + & FLT,FLT_ab,nFLT,ExFac, & nOcc,nOcc_ab) C C Thomas Bondo Pedersen, September 2010. @@ -20,14 +20,13 @@ C using Local Density Fitting (LDF) coefficients. C Implicit None - Integer iUHF, nSym, nFLT + Integer nD, nSym, nFLT Integer nBas(nSym), nOcc(nSym), nOcc_ab(nSym) Real*8 DSQ(*), DLT(*) Real*8 DSQ_ab(*), DLT_ab(*) Real*8 FLT(*), FLT_ab(*) - Real*8 FSQ(*), FSQ_ab(*) Real*8 ExFac -#include "WrkSpc.fh" +#include "stdalloc.fh" #include "ldfscf.fh" #include "localdf.fh" @@ -61,14 +60,12 @@ Real*8 ThrPS(2) Real*8 FactC(nDen_Max) Integer ip_D(nDen_Max) - Integer ip_F(nDen_Max) Integer nDen Integer u, v, uv Integer iPrint Integer irc - Integer ip_UBFNorm, l_UBFNorm - Integer ipF, lF, ipF2 + Integer lF Integer iDen Integer AB_MAE, AB_MRNrm Integer lMode @@ -93,6 +90,8 @@ Integer i, j Integer iTri + Real*8, Allocatable:: UBFNorm(:), DrvF(:,:) + iTri(i,j)=max(i,j)*(max(i,j)-3)/2+i+j #if defined (_DEBUGPRINT_) @@ -343,14 +342,13 @@ End If ! Set scaling factors FactC(1)=1.0d0 - If (iUHF.eq.0) Then ! spin-restricted Coulomb-only + If (nD==1) Then ! spin-restricted Coulomb-only ! Get pointers to D and F ! Off-diagonal elements of DLT are scaled by 2 by the SCF ! program. This is incompatible with the LDF implementation. ! So, use instead the quadratic DSQ. ! Use packed F (FLT) for result. ip_D(1)=ip_of_Work(DSQ(1)) - ip_F(1)=ip_of_Work(FLT(1)) ! Set flags for quadratic (SQ) density matrix and packed ! Fock matrix PackedD=.False. @@ -370,12 +368,11 @@ Call WarningMessage(0,SecNam// & ': Computing norm of upper bound to Coulomb error') Call xFlush(6) - l_UBFNorm=nDen - Call GetMem('UBFNorm','Allo','Real',ip_UBFNorm,l_UBFNorm) + Call mma_Allocate(UBFNorm,nDen,Label='UBFNorm') Call LDF_Fock_CoulombUpperBoundNorm_Full(.True.,PackedD, & nDen,FactC,ip_D, - & Work(ip_UBFNorm)) - Call GetMem('UBFNorm','Free','Real',ip_UBFNorm,l_UBFNorm) + & UBFNorm) + Call mma_deAllocate(UBFNorm) End If ! Print args If (iPrint.ge.3) Then @@ -398,8 +395,6 @@ If (iPrint.ge.5) Then Write(6,'(2X,A,3I15)') & 'ip_D.............',(ip_D(i),i=1,nDen) - Write(6,'(2X,A,3I15)') - & 'ip_F.............',(ip_F(i),i=1,nDen) End If End If ! Compute two-electron contributions to Fock matrix @@ -417,17 +412,17 @@ Else lF=nBas(1)**2 End If - Call GetMem('DrvF','Allo','Real',ipF,nDen*lF) + Call mma_allocate(DrvF,lF,nDen,Label='DrvF') Do iDen=1,nDen - Call dCopy_(lF,Work(ip_F(iDen)),1, - & Work(ipF+(iDen-1)*lF),1) + Call dCopy_(lF,FLT(iDen),1, + & DrvF(:,iDen),1) End Do ComputeF=.False. Call LDF_Fock_CoulombErrorAnalysis(ComputeF,Mode, & PackedD,PackedF, & nDen,FactC,ip_D, - & Work(ipF)) - Call GetMem('DrvF','Free','Real',ipF,nDen*lF) + & DrvF) + Call mma_deallocate(DrvF) End If ! Debug: check mode consistency If (LDF_ModeCheck) Then @@ -439,11 +434,10 @@ Else lF=nBas(1)**2 End If - Call GetMem('DrvF','Allo','Real',ipF,nDen*2*lF) + Call mma_allocate(DrvF,lF,2*nDen,Label='DrvF') Do iDen=1,nDen - ipF2=ip_F(iDen) - Call dCopy_(lF,Work(ipF2),1, - & Work(ipF+(nDen+iDen-1)*lF),1) + Call dCopy_(lF,FLT(iDen),1, + & DrvF(:,nDen+iDen),1) End Do If (Mode.eq.1) Then lMode=3 @@ -453,7 +447,7 @@ factor=-2.0d0 Else If (Mode.eq.3) Then Do iDen=1,nDen - Call dScal_(lF,2.0d0,Work(ipF+(nDen+iDen-1)*lF),1) + Call dScal_(lF,2.0d0,DrvF(:,nDen+iDen),1) End Do lMode=1 factor=-1.0d0 @@ -467,10 +461,10 @@ & Timing,lMode,ThrPS, & Add,PackedD,PackedF, & nDen,FactC,ip_D, - & Work(ipF)) + & DrvF) Do iDen=1,nDen - Call dAXPY_(lF,factor,Work(ipF+(iDen-1)*lF),1, - & Work(ipF+(nDen+iDen-1)*lF),1) + Call dAXPY_(lF,factor,DrvF(:, iDen),1, + & DrvF(:,nDen+iDen),1) End Do If (Mode.eq.1) Then lMode=2 @@ -491,16 +485,16 @@ & Timing,lMode,ThrPS, & Add,PackedD,PackedF, & nDen,FactC,ip_D, - & Work(ipF)) + & DrvF) Do iDen=1,nDen - Call dAXPY_(lF,factor,Work(ipF+(iDen-1)*lF),1, - & Work(ipF+(nDen+iDen-1)*lF),1) + Call dAXPY_(lF,factor,DrvF(:, iDen),1, + & DrvF(:,nDen+iDen),1) End Do Call Cho_Head(SecNam//': Mode Check','=',80,6) n=0 Do iDen=1,nDen - FNorm=sqrt(dDot_(lF,Work(ipF+(nDen+iDen-1)*lF),1, - & Work(ipF+(nDen+iDen-1)*lF),1)) + FNorm=sqrt(dDot_(lF,DrvF(:,nDen+iDen),1, + & DrvF(:,nDen+iDen),1)) If (FNorm.gt.Tol_ModeCheck) Then Write(6,'(3X,A,I3,A,1P,D20.10,A)') & 'Density no.',iDen,' Check norm=',Fnorm, @@ -517,7 +511,7 @@ Call LDF_Quit(1) End If Call xFlush(6) - Call GetMem('DrvF','Free','Real',ipF,nDen*2*lF) + Call mma_deallocate(DrvF) End If Else ! spin-unrestricted Coulomb-only ! Add alpha and beta parts of density matrix @@ -528,7 +522,6 @@ ! So, use instead the quadratic DSQ. ! Use packed F (FLT) for result. ip_D(1)=ip_of_Work(DSQ(1)) - ip_F(1)=ip_of_Work(FLT(1)) ! Set flags for quadratic (SQ) density matrix and packed ! Fock matrix PackedD=.False. @@ -548,12 +541,11 @@ Call WarningMessage(0,SecNam// & ': Computing norm of upper bound to Coulomb error') Call xFlush(6) - l_UBFNorm=nDen - Call GetMem('UBFNorm','Allo','Real',ip_UBFNorm,l_UBFNorm) + Call mma_Allocate(UBFNorm,nDen,Label='UBFNorm') Call LDF_Fock_CoulombUpperBoundNorm_Full(.True.,PackedD, & nDen,FactC,ip_D, - & Work(ip_UBFNorm)) - Call GetMem('UBFNorm','Free','Real',ip_UBFNorm,l_UBFNorm) + & UBFNorm) + Call mma_deAllocate(UBFNorm) End If ! Print args If (iPrint.ge.3) Then @@ -576,8 +568,6 @@ If (iPrint.ge.5) Then Write(6,'(2X,A,3I15)') & 'ip_D.............',(ip_D(i),i=1,nDen) - Write(6,'(2X,A,3I15)') - & 'ip_F.............',(ip_F(i),i=1,nDen) End If End If ! Compute two-electron contributions to Fock matrix @@ -595,17 +585,17 @@ Else lF=nBas(1)**2 End If - Call GetMem('DrvF','Allo','Real',ipF,nDen*lF) + Call mma_Allocate(DrvF,lF,nDen,Label='DrvF') Do iDen=1,nDen - Call dCopy_(lF,Work(ip_F(iDen)),1, - & Work(ipF+(iDen-1)*lF),1) + Call dCopy_(lF,FLT(iDen),1, + & DrvF(:,iDen),1) End Do ComputeF=.False. Call LDF_Fock_CoulombErrorAnalysis(ComputeF,Mode, & PackedD,PackedF, & nDen,FactC,ip_D, - & Work(ipF)) - Call GetMem('DrvF','Free','Real',ipF,nDen*lF) + & DrvF) + Call mma_deallocate(DrvF) End If ! Debug: check mode consistency If (LDF_ModeCheck) Then @@ -617,11 +607,10 @@ Else lF=nBas(1)**2 End If - Call GetMem('DrvF','Allo','Real',ipF,nDen*2*lF) + Call mma_Allocate(DrvF,lF,2*nDen,Label='DrvF') Do iDen=1,nDen - ipF2=ip_F(iDen) - Call dCopy_(lF,Work(ipF2),1, - & Work(ipF+(nDen+iDen-1)*lF),1) + Call dCopy_(lF,FLT(iDen),1, + & DrvF(:,nDen+iDen),1) End Do If (Mode.eq.1) Then lMode=3 @@ -631,7 +620,7 @@ factor=-2.0d0 Else If (Mode.eq.3) Then Do iDen=1,nDen - Call dScal_(lF,2.0d0,Work(ipF+(nDen+iDen-1)*lF),1) + Call dScal_(lF,2.0d0,DrvF(:,nDen+iDen),1) End Do lMode=1 factor=-1.0d0 @@ -645,10 +634,10 @@ & Timing,lMode,ThrPS, & Add,PackedD,PackedF, & nDen,FactC,ip_D, - & Work(ipF)) + & DrvF) Do iDen=1,nDen - Call dAXPY_(lF,factor,Work(ipF+(iDen-1)*lF),1, - & Work(ipF+(nDen+iDen-1)*lF),1) + Call dAXPY_(lF,factor,DrvF(:, iDen),1, + & DrvF(:,nDen+iDen),1) End Do If (Mode.eq.1) Then lMode=2 @@ -669,16 +658,16 @@ & Timing,lMode,ThrPS, & Add,PackedD,PackedF, & nDen,FactC,ip_D, - & Work(ipF)) + & DrvF) Do iDen=1,nDen - Call dAXPY_(lF,factor,Work(ipF+(iDen-1)*lF),1, - & Work(ipF+(nDen+iDen-1)*lF),1) + Call dAXPY_(lF,factor,DrvF(:, iDen),1, + & DrvF(:,nDen+iDen),1) End Do Call Cho_Head(SecNam//': Mode Check','=',80,6) n=0 Do iDen=1,nDen - FNorm=sqrt(dDot_(lF,Work(ipF+(nDen+iDen-1)*lF),1, - & Work(ipF+(nDen+iDen-1)*lF),1)) + FNorm=sqrt(dDot_(lF,DrvF(:,nDen+iDen),1, + & DrvF(:,nDen+iDen),1)) If (FNorm.gt.Tol_ModeCheck) Then Write(6,'(3X,A,I3,A,1P,D20.10,A)') & 'Density no.',iDen,' Check norm=',Fnorm, @@ -695,7 +684,7 @@ Call LDF_Quit(1) End If Call xFlush(6) - Call GetMem('DrvF','Free','Real',ipF,nDen*2*lF) + Call mma_deallocate(DrvF) End If ! Copy result to FLT_ab Call dCopy_(nFLT,FLT,1,FLT_ab,1) @@ -730,8 +719,6 @@ c Avoid unused argument warnings If (.False.) Then Call Unused_real_array(DLT_ab) - Call Unused_real_array(FSQ) - Call Unused_real_array(FSQ_ab) Call Unused_integer_array(nOcc) Call Unused_integer_array(nOcc_ab) End If diff -Nru openmolcas-22.02/src/scf/lnklst.f openmolcas-22.10/src/scf/lnklst.f --- openmolcas-22.02/src/scf/lnklst.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/lnklst.f 2022-10-10 14:22:40.000000000 +0000 @@ -40,9 +40,9 @@ * the following purposes: * * IniLst(LList,incore) * * -> initialize list * -* PutVec(vec,lvec,LUnit,iterat,NoAllo,opcode,LList) * +* PutVec(vec,lvec,iterat,opcode,LList) * * -> store vector on list, ev. move the tailnode vector on disk * -* GetVec(LUnit,iterat,LList,inode,vec,lvec) * +* GetVec(iterat,LList,inode,vec,lvec) * * -> fetch vector from list, which corresponds to iterat * * GetNod(iterat,LList,inode) * * -> does not read out vector, just returns address of node in inode * @@ -50,12 +50,12 @@ * -> returns info of node indicated by inode * * Logical InCore(inode) * * -> returns true, if corresponding vector is incore, false otherwise * -* Integer iVPtr(LUnit,ivptr1,inode) * +* Integer iVPtr(vptr1,nvtr1,inode) * * -> uses InfNod or GetVec to read out vector of inode, depending * * if InCore or not. If the result is ivptr1, the vector was read * * from disk. ivptr1 has to be allocated before (same vector length * * as stored in inode). * -* Integer LstPtr(LUnit,iterat,LList) * +* Integer LstPtr(iterat,LList) * * -> uses GetNod and InfNod to get the pointer to the vector, which * * corresponds to iterat. The pointer is the return value of the * * function. If the vector is not InCore, the function terminates * @@ -83,13 +83,11 @@ SubRoutine IniLst(iLList,incore) + use LnkLst Implicit Real*8 (a-h,o-z) Integer iLList,incore #include "real.fh" -#include "mxdm.fh" -#include "lnklst.fh" -* Debug_LnkLst=.False. * * allocate list header CNOD @@ -111,7 +109,7 @@ *----------------------------------------------------------------------* - SubRoutine PutVec(vec,lvec,LUnit,iterat,NoAllo,opcode,iLList) + SubRoutine PutVec(vec,lvec,iterat,opcode,iLList) * NoAllo is the amount of memory (in DWords) one wants to keep * for other purposes. * opcode is a 4 character string: @@ -123,22 +121,20 @@ * vector is not overwritten and iWork(LList) is set to * ErrCode 1 * + use LnkLst Implicit Real*8 (a-h,o-z) * * declaration subroutine parameters - Integer lvec,LUnit,iterat,iLList,NoAllo,iroot,lislen + Integer lvec,iterat,iLList,iroot,lislen Real*8 vec(lvec) Character opcode*4 * * declaration local variables - Integer iPtr1,iPtr2,MaxMem + Integer iPtr2,MaxMem C Integer iDskPt,len * #include "real.fh" -#include "WrkSpc.fh" -#include "mxdm.fh" -#include "lnklst.fh" - +#include "stdalloc.fh" #include "SysDef.fh" * If (Debug_LnkLst) Then @@ -161,7 +157,7 @@ * Set error code: inconsistency in vector lengths nLList(iLList,0)=1 Else - call dcopy_(lvec,vec,1,Work(nLList(iroot,1)),1) + SCF_V(iroot)%A(1:lVec)=vec(1:lVec) End If Return Else If (opcode.ne.'APND') Then @@ -172,23 +168,21 @@ End If End If * check if there is still enough memory to store vec - Call GetMem('LVec ','Max','Real',iPtr1,MaxMem) -cvv Enough memory -* let's allocate some memory - Call GetMem('LVec ','Allo','Real',iPtr1,lvec) -* End If + Call mma_maxDBLE(MaxMem) +* let's allocate some memory * allocate new node lLList=lLList+1 iPtr2=lLList + Call mma_allocate(SCF_V(iPtr2)%A,lVec,Label='LVec') nLList(iPtr2,0)=iroot - nLList(iPtr2,1)=iPtr1 + nLList(iPtr2,1)=iPtr2 nLList(iPtr2,2)=0 nLList(iPtr2,3)=lvec nLList(iPtr2,4)=iterat nLList(iPtr2,5)=1 - call dcopy_(lvec,vec,1,Work(iPtr1),1) + SCF_V(iPtr2)%A(:)=Vec(:) iroot=iPtr2 lislen=lislen+1 nLList(iLList,1)=iroot @@ -196,18 +190,11 @@ * Return - -#ifdef _WARNING_WORKAROUND_ - If (.False.) Then - Call Unused_integer(LUnit) - Call Unused_integer(NoAllo) - End If -#endif End *----------------------------------------------------------------------* - SubRoutine GetVec(LUnit,iterat,iLList,inode,vec,lvec) + SubRoutine GetVec(iterat,iLList,inode,vec,lvec) * searches linked list for node corresponding to iterat, starting * from iroot=iWork(LList+1). * inode points to the node found after searching. @@ -218,35 +205,27 @@ * address, if an inconsistent entry was found. * if LList<0, then -LList is interpreted as a direct node address, * and not the address of the listhead (faster access). + use LnkLst Implicit Real*8 (a-h,o-z) * * declaration subroutine parameters - Integer lvec,LUnit,iterat,iLList,inode + Integer lvec,iterat,iLList,inode Real*8 vec(lvec) * -* declaration local variables -c Integer iDskPt -* #include "real.fh" -#include "WrkSpc.fh" -#include "mxdm.fh" -#include "lnklst.fh" - #include "SysDef.fh" * -* - inode=nLList(iLList,1) + inode=nLList(iLList,1) - 100 If ((nLList(inode,4).ne.iterat).and.(nLList(inode,0).ne.0)) Then + Do While ((nLList(inode,4).ne.iterat).and.(nLList(inode,0).ne.0)) inode=nLList(inode,0) + End Do - GoTo 100 - End If If (nLList(inode,4).eq.iterat) Then * we've found matching entry, so check if consistent If (nLList(inode,3).eq.lvec) Then -* everything's allright, we made it, let's copy to vec - call dcopy_(lvec,Work(nLList(inode,1)),1,vec,1) +* everything's alright, we made it, let's copy to vec + vec(1:lVec)=SCF_V(iNode)%A(1:lVec) Else * inconsistency write(6,*)' Found inconsistency.' @@ -257,9 +236,6 @@ inode=0 End If * -#ifdef _WARNING_WORKAROUND_ - If (.False.) Call Unused_integer(LUnit) -#endif End *----------------------------------------------------------------------* @@ -269,15 +245,13 @@ * from iroot. inode points to the node found after searching. * inode is set to zero and iWork(LList)=0 is set to ErrCode 1, * if no correspondance was found. + use LnkLst Implicit Real*8 (a-h,o-z) * * declaration subroutine parameters Integer iterat,iLList,inode * #include "real.fh" -#include "mxdm.fh" -#include "lnklst.fh" - * * If (Debug_LnkLst) Then @@ -290,10 +264,9 @@ * set inode to iroot inode=nLList(iLList,1) - 100 If ((nLList(inode,4).ne.iterat).and.(nLList(inode,0).ne.0)) Then + Do While ((nLList(inode,4).ne.iterat).and.(nLList(inode,0).ne.0)) inode=nLList(inode,0) - GoTo 100 - End If + End Do If (nLList(inode,4).eq.iterat) Then * we've found matching entry Else @@ -309,15 +282,13 @@ SubRoutine InfNod(inode,iterat,ipnext,ipvec,lvec) * returns info of node indicated by inode. iterat,ipnext,ipvec,lvec * are overwritten with the corresponding info on the node + use LnkLst Implicit Real*8 (a-h,o-z) * * declaration of procedure parameters Integer inode,iterat,ipnext,ipvec,lvec * -#include "mxdm.fh" -#include "lnklst.fh" -* iterat=nLList(inode,4) ipnext=nLList(inode,0) ipvec= nLList(inode,1) @@ -330,13 +301,11 @@ Logical Function InCore(inode) * returns true, if corresponding vector is incore, false otherwise + use LnkLst Implicit Real*8 (a-h,o-z) Integer inode * -#include "mxdm.fh" -#include "lnklst.fh" -* If (nLList(inode,5).eq.1) Then InCore=.TRUE. Else @@ -349,14 +318,11 @@ Logical Function LLErr(iLList) * checks, if ErrCode was set in previous LL Operation + use LnkLst Implicit Real*8 (a-h,o-z) Integer iLList * -#include "mxdm.fh" -#include "lnklst.fh" -* - If (nLList(iLList,0).eq.0) Then LLErr=.FALSE. Else @@ -369,20 +335,18 @@ Integer Function LLLen(iLList) * returns the actual length of the LL + use LnkLst Implicit Real*8 (a-h,o-z) Integer iLList * -#include "mxdm.fh" -#include "lnklst.fh" -* LLLen=nLList(iLList,2) Return End *----------------------------------------------------------------------* - Subroutine iVPtr(LUnit,vptr1,nvptr1,inode) + Subroutine iVPtr(vptr1,nvptr1,inode) * uses InfNod or GetVec to read out vector of inode, depending * if InCore or not. If the result is ivptr1, the vector was read * from disk. ivptr1 has to be allocated before (same vector length @@ -391,22 +355,19 @@ * the inode value of GetVec is returned. * * 2017-03-15:Converted to return the array in vptr1. + use LnkLst Implicit Real*8 (a-h,o-z) - Integer LUnit,nvptr1,ivptr2,inode,idum + Integer nvptr1,ivptr2,inode,idum Logical InCore Real*8 vptr1(nvptr1) * #include "real.fh" -#include "WrkSpc.fh" -#include "mxdm.fh" -#include "lnklst.fh" * If (InCore(inode)) Then Call InfNod(inode,idum,idum,ivptr2,idum) - Call DCopy_(nvptr1,Work(ivptr2),1,vptr1,1) + vPtr1(1:nvptr1)=SCF_V(inode)%A(1:nvptr1) Else - Call GetVec(LUnit,nLList(inode,4),inode,inode, - & vptr1,nLList(inode,3)) + Call GetVec(nLList(inode,4),inode,inode,vptr1,nLList(inode,3)) End If * Return @@ -414,7 +375,7 @@ *----------------------------------------------------------------------* - Integer Function LstPtr(LUnit,iterat,iLList) + Integer Function LstPtr(iterat,iLList) * uses GetNod and InfNod to obtain the pointer to the vector, which * corresponds to iterat. The pointer is the return value of the * function. If the vector is not InCore, the function terminates @@ -424,7 +385,7 @@ Implicit Real*8 (a-h,o-z) * * declaration subroutine parameters - Integer LUnit,iterat,iLList + Integer iterat,iLList * * declaration local variables Integer inode,idum,ivptr @@ -447,23 +408,18 @@ Write (6,*) 'inode=',inode Call Abend() End If - -#ifdef _WARNING_WORKAROUND_ - If (.False.) Call Unused_integer(LUnit) -#endif End *----------------------------------------------------------------------* SubRoutine KilLst(iLList) + use LnkLst Implicit Real*8 (a-h,o-z) * Free all memory of linked list LList #include "real.fh" -#include "WrkSpc.fh" -#include "mxdm.fh" -#include "lnklst.fh" +#include "stdalloc.fh" * local vars - Integer iLList,iroot,iPtr1 + Integer iLList,iroot * * If (Debug_LnkLst) Then @@ -472,31 +428,25 @@ End If * iroot=nLList(iLList,1) - 100 Continue - If (iroot.ne.0) Then - iPtr1=nLList(iroot,1) + Do While (iroot.ne.0) iFlag=nLList(iroot,5) If (iFlag.eq.1) Then - Call GetMem('LVec ','Free','Real',iPtr1,nLList(iroot,3)) + Call mma_deallocate(SCF_V(iroot)%A) End If - iPtr1=iroot iroot=nLList(iroot,0) - GoTo 100 - End If + End Do * End *----------------------------------------------------------------------* SubRoutine DmpLst(iLList,LUnit,lDskPt) + use LnkLst Implicit Real*8 (a-h,o-z) Integer iLList,LUnit,lDskPt * -#include "WrkSpc.fh" -#include "mxdm.fh" -#include "lnklst.fh" - +#include "stdalloc.fh" #include "SysDef.fh" * * clear ErrCode @@ -510,20 +460,18 @@ lDskPt=0 iDskPt=lDskPt Call iDaFile(LUnit,1,nLList(iLList,0),NodSiz,iDskPt) -* Call GetMem('CNOD ','Free','Inte',LList,NodSiz) Return End If - 10 Continue - If (nLList(iroot,5).eq.1) Then - iPtr1=iroot - iPtr2=iPtr1 + + Do While (nLList(iroot,5).eq.1) + iPtr1=iroot + iPtr2=iPtr1 * go either to last element or list or to last element in core * and flush vector - 100 If ((nLList(iPtr1,0).ne.0).and.(nLList(iPtr1,5).eq.1)) Then + Do While ((nLList(iPtr1,0).ne.0).and.(nLList(iPtr1,5).eq.1)) iPtr2=iPtr1 iPtr1=nLList(iPtr1,0) - GoTo 100 - End If + End Do If (nLList(iPtr1,5).eq.1) Then * nothing written on disk yet iDskPt=0 @@ -538,35 +486,29 @@ nLList(iPtr2,5)=0 len=nLList(iPtr2,3) - Call dDaFile(LUnit,1,Work(iPtr1),len,iDskPt) - Call GetMem('LVec ','Free','Real',iPtr1,len) - Go To 10 - End If + Call dDaFile(LUnit,1,SCF_V(iPtr2)%A,len,iDskPt) + Call mma_deallocate(SCF_V(iPtr2)%A) + End Do lDskPt=iDskPt * now all vectors are flushed... so dump linked list... Call iDaFile(LUnit,1,nLList(iLList,0),NodSiz,iDskPt) * - 200 If (iroot.ne.0) Then + Do While (iroot.ne.0) iPtr1=iroot iroot=nLList(iroot,0) Call iDaFile(LUnit,1,nLList(iPtr1,0),NodSiz,iDskPt) -* Call GetMem('LNode','Free','Inte',iPtr1,NodSiz) - GoTo 200 - End If -* Call GetMem('CNOD ','Free','Inte',LList,NodSiz) + End Do * End *----------------------------------------------------------------------* SubRoutine RclLst(iLList,LUnit,lDskPt,NoAllo) + use LnkLst Implicit Real*8 (a-h,o-z) Integer iLList,LUnit,lDskPt,NoAllo * -#include "WrkSpc.fh" -#include "mxdm.fh" -#include "lnklst.fh" - +#include "stdalloc.fh" #include "SysDef.fh" * * load listhead... @@ -594,7 +536,7 @@ iroot=iPtr1 iPtr2=iroot - 100 If (nLList(iPtr2,0).ne.0) Then + Do While (nLList(iPtr2,0).ne.0) lislen=lislen+1 lLList=lLList+1 iPtr1=lLList @@ -602,8 +544,7 @@ Call iDaFile(LUnit,2,nLList(iPtr1,0),NodSiz,lDskPt) iPtr2=iPtr1 - Go To 100 - End If + End Do If (nLList(iLList,2).ne.lislen) Then Write(6,*) 'RclLst:LList length mismatch:', & nLList(iLList,2),lislen @@ -612,23 +553,22 @@ Write (6,*) 'Let''s restore...' * now we have restored the list, let's fetch some vectors incore=nLList(iLList,3) - Call GetMem('LVec ','Max','Real',iPtr1,MaxMem) + Call mma_maxDBLE(MaxMem) lvec=nLList(iroot,3) iPtr2=iroot - 200 If ((incore.gt.0).AND.(MaxMem-NoAllo.ge.lvec).AND.(iPtr2.gt.0)) - & Then + Do While ((incore.gt.0).AND.(MaxMem-NoAllo.ge.lvec).AND. + & (iPtr2.gt.0)) lDskPt=nLList(iPtr2,1) - Call GetMem('LVec ','Allo','Real',iPtr1,lvec) - Call dDaFile(LUnit,2,Work(iPtr1),lvec,lDskPt) - nLList(iPtr2,1)=iPtr1 + Call mma_Allocate(SCF_V(iPtr2)%A,lvec,Label='LVec') + Call dDaFile(LUnit,2,SCF_V(iPtr2)%A,lvec,lDskPt) + nLList(iPtr2,1)=iPtr2 nLList(iPtr2,2)=0 nLList(iPtr2,5)=1 iPtr2=nLList(iPtr2,0) incore=incore-1 - Call GetMem('LVec ','Max','Real',iPtr1,MaxMem) - Go To 200 - End If + Call mma_maxDBLE(MaxMem) + End Do If (iPtr2.gt.0) nLList(iLList,3)=nLList(iLList,3)-incore * End diff -Nru openmolcas-22.02/src/scf/lnklst.F90 openmolcas-22.10/src/scf/lnklst.F90 --- openmolcas-22.02/src/scf/lnklst.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/scf/lnklst.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,31 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** +! module file for module lnklst (linked list stuff) +! +Module LnkLst +Private +Public :: Debug_LnkLst, lLList, nLList, MAXnodes, NodSiz +Public :: SCF_V +#include "mxdm.fh" +Integer, Parameter :: NodSiz=6 +Integer, Parameter :: MAXnodes=MxIter*5 +Logical Debug_LnkLst +Integer lLList +Integer nLList(MAXnodes,0:NodSiz-1) + +Type Vector + Real*8, Allocatable :: A(:) +End Type Vector + +Type (Vector) :: SCF_V(Maxnodes) + +End Module LnkLst + diff -Nru openmolcas-22.02/src/scf/lnklst.fh openmolcas-22.10/src/scf/lnklst.fh --- openmolcas-22.02/src/scf/lnklst.fh 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/lnklst.fh 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -************************************************************************ -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -************************************************************************ -* include file for module lnklst (linked list stuff) -* - Parameter(NodSiz=6) - Parameter(MAXnodes=MxIter*5) - Logical Debug_LnkLst - Integer lLList, nLList - Common /LnkLst/ Debug_LnkLst - Common /nLList/ lLList, nLList(MAXnodes,0:NodSiz-1) -* diff -Nru openmolcas-22.02/src/scf/matexp.f90 openmolcas-22.10/src/scf/matexp.f90 --- openmolcas-22.02/src/scf/matexp.f90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/scf/matexp.f90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,160 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +! * +! Copyright (C) 2022, Danjo De Chavez * +!*********************************************************************** +! matexp +! +!> @brief Compute the exponential of the U matrix +!> @author Danjo De Chavez (2022) +!> +!> @details +!> Computes the exponential of an antisymmetric real matrix U through +!> a modified Taylor expansion of the K matrix. This takes advantage of the +!> subblocks and trend in the powers of K matrix. \cite Sei2022-JCTC-18-4164 +!> +!> \note +!> Some equations in the reference are wrong. +!> +!> @param[in] N Size of the square matrix +!> @param[in] No Number of Occupied Orbitals +!> @param[in,out] U U matrix is replaced by its exponential +!*********************************************************************** + +subroutine matexp(N,No,U) + +use stdalloc, only: mma_allocate, mma_deallocate +use Constants, only: Zero, One +use Definitions, only: wp, iwp + +implicit none + +integer(kind=iwp), intent(in) :: N, No +real(kind=wp), intent(inout) :: U(N,N) + +integer(kind=iwp) :: Nv +integer(kind=iwp) :: count, i + +real(kind=wp), parameter :: thrsh = 1.0D-20 +real(kind=wp) :: ithrsh, ithrshoo, ithrshvv, ithrshvo, factor + +real(kind=wp), allocatable :: Uoo(:,:), xUoo(:,:), Koo(:,:) +real(kind=wp), allocatable :: Uvv(:,:), xUvv(:,:), Kvv(:,:) +real(kind=wp), allocatable :: Uvo(:,:), xUvo(:,:), Kvo(:,:) +real(kind=wp), allocatable :: Uov(:,:) +real(kind=wp), allocatable :: theta(:,:) + +if (N < 1) return +Nv = N-No + +call mma_allocate(theta,Nv,No,label='theta') + +call mma_allocate(Koo,No,No,label='Koo') +call mma_allocate(Kvv,Nv,Nv,label='Kvv') +call mma_allocate(Kvo,Nv,No,label='Kvo') + +call mma_allocate(Uoo,No,No,label='Uoo') +call mma_allocate(Uvv,Nv,Nv,label='Uvv') +call mma_allocate(Uov,No,Nv,label='Uov') +call mma_allocate(Uvo,Nv,No,label='Uvo') + +call mma_allocate(xUoo,No,No,label='xUoo') +call mma_allocate(xUvv,Nv,Nv,label='xUvv') +call mma_allocate(xUvo,Nv,No,label='xUvo') + +theta(:,:) = U(No+1:N,:No) + +U(:,:) = Zero + +count = 1 +factor = One + +ithrsh = 2.0E-16_wp + +! Initialization +! Taylor expansion terms to n=1 + +Uov(:,:) = Zero +Uvo(:,:) = Zero + +Uoo(:,:) = Zero + +xUoo(:,:) = Zero +xUvv(:,:) = Zero +xUvo(:,:) = Zero + +do i=1,No + Uoo(i,i) = One +end do + +Uvv(:,:) = Zero + +do i=1,Nv + Uvv(i,i) = One +end do + +Kvo(:,:) = theta +Uvo(:,:) = theta + +! Main Loop +! Taylor expansion terms from n=2 to convergence + +do while (thrsh < ithrsh) + count = count+1 + + if (mod(count,2)==0) then + call dgemm_('T','N',No,No,Nv,One,-theta,Nv,Kvo,Nv,Zero,Koo,No) + call dgemm_('N','T',Nv,Nv,No,One,Kvo,Nv,-theta,Nv,Zero,Kvv,Nv) + factor = factor*count + Uoo(:,:) = Uoo + Koo/factor + Uvv(:,:) = Uvv + Kvv/factor + + else + call dgemm_('N','N',Nv,No,No,One,theta,Nv,Koo,No,Zero,Kvo,Nv) + factor = factor*count + Uvo(:,:) = Uvo + Kvo/factor + + ithrshoo = maxval(abs(Uoo-xUoo)/(abs(Uoo)+thrsh)) + ithrshvv = maxval(abs(Uvv-xUvv)/(abs(Uvv)+thrsh)) + ithrshvo = maxval(abs(Uvo-xUvo)/(abs(Uvo)+thrsh)) + ithrsh = max(ithrshoo, ithrshvv, ithrshvo) + + xUoo(:,:) = Uoo + xUvv(:,:) = Uvv + xUvo(:,:) = Uvo + + end if +end do + +Uov(:,:) = -transpose(Uvo) + +U(:No,:No) = Uoo +U(No+1:N,:No) = Uvo +U(:No,No+1:N) = Uov +U(No+1:N,No+1:N) = Uvv + +call mma_deallocate(Koo) +call mma_deallocate(Kvv) +call mma_deallocate(Kvo) + +call mma_deallocate(Uoo) +call mma_deallocate(Uvv) +call mma_deallocate(Uov) +call mma_deallocate(Uvo) + +call mma_deallocate(xUoo) +call mma_deallocate(xUvv) +call mma_deallocate(xUvo) + +call mma_deallocate(theta) + +return + +end subroutine matexp diff -Nru openmolcas-22.02/src/scf/memalo.f openmolcas-22.10/src/scf/memalo.f --- openmolcas-22.02/src/scf/memalo.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/memalo.f 2022-10-10 14:22:40.000000000 +0000 @@ -36,13 +36,13 @@ ************************************************************************ use SCF_Arrays use Orb_Type + use LnkLst + use InfSO Implicit Real*8 (a-h,o-z) #include "real.fh" #include "mxdm.fh" #include "infscf.fh" #include "stdalloc.fh" -#include "lnklst.fh" -#include "infso.fh" * *----------------------------------------------------------------------* * Start * @@ -92,7 +92,7 @@ c MemRsv = lthTot MemRsv = 0 cmgs - Call GetMem('SCF','Max','Real',iDum,MxMem) + Call mma_maxDBLE(MxMem) lthTot = lthTot + 5*nOV lthRst = MxMem - lthTot nDens = Min(lthRst/(nBT*nD)/2,6) diff -Nru openmolcas-22.02/src/scf/neworb_scf.f openmolcas-22.10/src/scf/neworb_scf.f --- openmolcas-22.02/src/scf/neworb_scf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/neworb_scf.f 2022-10-10 14:22:40.000000000 +0000 @@ -47,6 +47,7 @@ * history: none * * * ************************************************************************ + use SpinAV, only: Do_SpinAV Implicit Real*8 (a-h,o-z) #include "real.fh" #include "mxdm.fh" @@ -61,7 +62,6 @@ Logical AllowFlip Logical Scram, em_On * -#include "spave.fh" Real*8 Ovlp(nFO) Save iSeed Data iSeed/13/ diff -Nru openmolcas-22.02/src/scf/optclc_nqr.f openmolcas-22.10/src/scf/optclc_nqr.f --- openmolcas-22.02/src/scf/optclc_nqr.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/optclc_nqr.f 2022-10-10 14:22:40.000000000 +0000 @@ -29,8 +29,8 @@ * * get last gradient grad(n) from LList * - Call GetVec(LuGrd,Ind(kOptim),LLGrad,inode,Grd1,nOV*nD) - Call GetVec(Lux, Ind(kOptim),LLx, inode,Xnp1,nOV*nD) + Call GetVec(Ind(kOptim),LLGrad,inode,Grd1,nOV*nD) + Call GetVec(Ind(kOptim),LLx, inode,Xnp1,nOV*nD) * Do iD = 1, nD Call DSCAL_(nOV,CInter(kOptim,iD),Grd1(1,iD),1) @@ -43,7 +43,7 @@ * get proper gradient from LList. Call GetNod(ivec,LLGrad,inode) If (inode.eq.0) GoTo 555 - Call iVPtr(LuGrd,Aux,nOV*nD,inode) + Call iVPtr(Aux,nOV*nD,inode) Do iD = 1, nD Call Daxpy_(nOV,CInter(i,iD),Aux(1,iD),1,Grd1(1,iD),1) End Do @@ -51,7 +51,7 @@ * get proper X-vector from LList. Call GetNod(ivec,LLx,inode) If (inode.eq.0) GoTo 555 - Call iVPtr(Lux,Aux,nOV*nD,inode) + Call iVPtr(Aux,nOV*nD,inode) Do iD = 1, nD Call Daxpy_(nOV,CInter(i,iD),Aux(1,iD),1,Xnp1(1,iD),1) End Do diff -Nru openmolcas-22.02/src/scf/pmat_scf.f openmolcas-22.10/src/scf/pmat_scf.f --- openmolcas-22.02/src/scf/pmat_scf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/pmat_scf.f 2022-10-10 14:22:40.000000000 +0000 @@ -49,7 +49,6 @@ #include "real.fh" #include "mxdm.fh" #include "infscf.fh" -#include "WrkSpc.fh" #include "stdalloc.fh" #include "rctfld.fh" #include "file.fh" @@ -75,7 +74,8 @@ Real*8, Allocatable, Target:: Temp(:,:) Real*8, Dimension(:,:), Allocatable, Target:: Aux Real*8, Dimension(:,:), Pointer:: pTwoHam - Dimension Dummy(1),iDummy(1),Dumm0(1),Dumm1(1) + Real*8, Allocatable :: tVxc(:) + Dimension Dummy(1),Dumm0(1),Dumm1(1) #include "SysDef.fh" * Interface @@ -167,9 +167,11 @@ * potential is neither linear nor bi-linear. * If (KSDFT.ne.'SCF') Then - Call Get_dExcdRa(ipVxc,nVxc) - Call DCopy_(nVxc,Work(ipVxc),1,Vxc(1,1,iPsLst),1) - Call Free_Work(ipVxc) + nVxc=Size(Vxc,1)*Size(Vxc,2) + Call mma_allocate(tVxc,nVxc,Label='tVxc') + Call Get_dExcdRa_x(tVxc,nVxc) + Call DCopy_(nVxc,tVxc,1,Vxc(1,1,iPsLst),1) + Call mma_deallocate(tVxc) Else Call FZero(Vxc(1,1,iPsLst),nBT*nD) End If @@ -177,9 +179,11 @@ If (Do_OFemb) Then Call Get_NameRun(NamRfil) ! save the old RUNFILE name Call NameRun('AUXRFIL') ! switch the RUNFILE name - Call Get_dExcdRa(ipVemb,nVemb) - Call DaXpY_(nDT*nD,One,Work(ipVemb),1,Vxc(1,1,iPsLst),1) - Call Free_Work(ipVemb) + nVxc=Size(Vxc,1)*Size(Vxc,2) + Call mma_allocate(tVxc,nVxc,Label='tVxc') + Call Get_dExcdRa_x(tVxc,nVxc) + Call DaXpY_(nDT*nD,One,tVxc,1,Vxc(1,1,iPsLst),1) + Call mma_deallocate(tVxc) Call NameRun(NamRfil) ! switch back RUNFILE name End If #ifdef _DEBUGPRINT_ @@ -277,20 +281,18 @@ Do iD = 1, nD Call Unfold(Dens(1,iD,iPsLst),nBT,DnsS(1,iD),nBB,nSym,nBas) End Do - If (iUHF.eq.0) Then + If (nD==1) Then Call FockTwo_Drv_scf(nSym,nBas,nBas,nSkip, - & Dens(1,1,iPsLst),DnsS(1,1),Temp(1,1), - & nBT,ExFac,nBB,MaxBas,iUHF, - & Dummy, - & Dummy,Dummy,nOcc(1,1),idummy, + & Dens(:,:,iPsLst),DnsS(:,:),Temp(1,1), + & nBT,ExFac,nBB,MaxBas,nD, + & Dummy,nOcc(:,:),Size(nOcc,1), & iDummy_run) Else Call FockTwo_Drv_scf(nSym,nBas,nBas,nSkip, - & Dens(1,1,iPsLst),DnsS(1,1),Temp(1,1), - & nBT,ExFac,nBB,MaxBas,iUHF, - & Dens(1,2,iPsLst), - & DnsS(1,2),Temp(1,2),nOcc(1,1), - & nOcc(1,2),iDummy_run) + & Dens(:,:,iPsLst),DnsS(:,:),Temp(1,1), + & nBT,ExFac,nBB,MaxBas,nD, + & Temp(1,2),nOcc(:,:),Size(nOcc,1), + & iDummy_run) End If * *------- Deallocate memory for squared density matrix diff -Nru openmolcas-22.02/src/scf/prfin0.f openmolcas-22.10/src/scf/prfin0.f --- openmolcas-22.02/src/scf/prfin0.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/prfin0.f 2022-10-10 14:22:40.000000000 +0000 @@ -35,10 +35,12 @@ #ifdef _HDF5_ Use mh5, Only: mh5_put_dset #endif + Use KSDFT_Info, Only: CoefR, CoefX use OFembed, only: Do_OFemb #ifdef _FDE_ - use Embedding_Global, only: embPot + use Embedding_Global, only: Eemb, embPot #endif + use SpinAV, only: Do_SpinAV Implicit Real*8 (a-h,o-z) * Real*8 Dens(nDT),Dens_ab(nDT), EOrb(nEO),CMO(nCMO), KntE(nDT) @@ -52,11 +54,9 @@ #include "rctfld.fh" #include "oneswi.fh" #include "scfwfn.fh" -#include "ksdft.fh" #include "addcorr.fh" #include "dcscf.fh" -#include "spave.fh" Integer Cho_X_GetTol External Cho_X_GetTol diff -Nru openmolcas-22.02/src/scf/prfin.f openmolcas-22.10/src/scf/prfin.f --- openmolcas-22.02/src/scf/prfin.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/prfin.f 2022-10-10 14:22:40.000000000 +0000 @@ -44,6 +44,7 @@ * history: UHF - V.Veryazov, 2003 * * * ************************************************************************ + use SpinAV, only: Do_SpinAV Implicit Real*8 (a-h,o-z) External EFP_ON * @@ -58,7 +59,6 @@ #include "stdalloc.fh" #include "rctfld.fh" #include "oneswi.fh" -#include "spave.fh" * *---- Define local variables Character Fmt*60 @@ -128,7 +128,7 @@ *---- Print numerical quadrature information iSpin=1 if(iUHF.eq.1) iSpin=2 - If (KSDFT.ne.'SCF'.and.iCase.eq.0) Call Print_NQ_Info(iSpin) + If (KSDFT.ne.'SCF'.and.iCase.eq.0) Call Print_NQ_Info() * *---- Write out last density matrix to output If (DeBug) Then diff -Nru openmolcas-22.02/src/scf/prite.f openmolcas-22.10/src/scf/prite.f --- openmolcas-22.02/src/scf/prite.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/prite.f 2022-10-10 14:22:40.000000000 +0000 @@ -30,6 +30,7 @@ * history: none * * * ************************************************************************ + use InfSO Implicit Real*8 (a-h,o-z) Real*8 CMO(mBB,nD), Ovrlp(mBT), OccNo(mmB,nD) Logical QNR @@ -39,7 +40,6 @@ * #include "mxdm.fh" #include "infscf.fh" -#include "infso.fh" character cEDiff, cDMOMax, cFMOMax,cDltNrm If(iterprlv.gt.0) Then diff -Nru openmolcas-22.02/src/scf/rdinp_scf.f openmolcas-22.10/src/scf/rdinp_scf.f --- openmolcas-22.02/src/scf/rdinp_scf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/rdinp_scf.f 2022-10-10 14:22:40.000000000 +0000 @@ -34,13 +34,17 @@ * * ************************************************************************ use OccSets + use KSDFT_Info, only: CoefR, CoefX use OFembed + use Functionals, only: Custom_File, Custom_Func use IOBuf, only: lDaRec,nSect!,DiskMx_MByte + use InfSO #ifdef _HDF5_ use mh5, only: mh5_is_hdf5, mh5_open_file_r #endif use Fock_util_global, only: Deco, DensityCheck, Estimate, Update * + use SpinAV, only: Do_SpinAV Implicit Real*8 (a-h,o-z) External Allocdisk Integer Allocdisk @@ -48,12 +52,10 @@ #include "real.fh" #include "mxdm.fh" #include "infscf.fh" -#include "infso.fh" #include "stdalloc.fh" #include "ldfscf.fh" #include "file.fh" #include "iprlv.fh" -#include "ksdft.fh" #include "hfc_logical.fh" * *---- Define local variables @@ -74,7 +76,6 @@ #include "choauf.fh" #include "addcorr.fh" -#include "spave.fh" * * copy input from standard input to a local scratch file @@ -100,7 +101,7 @@ timings=.false. UHFSet=.false. Nscreen = 10 ! default screening interval (# of red sets) - dmpk = 1.0d0 ! default damping of the screening threshold + dmpk = 0.1d0 ! default damping of the screening threshold Estimate=.false. Update=.true. #if defined (_MOLCAS_MPP_) @@ -117,11 +118,7 @@ MxConstr=0 klockan=1 Do_Addc=.false. - Do_SpinAV=.false. iTer2run=2 -* KSDFT exch. and corr. scaling factors - CoefX = 1.0D0 - CoefR = 1.0D0 * Delta_Tw correlation energy calculation Do_Tw=.false. * Read Cholesky info from runfile and save in infscf.fh @@ -1026,7 +1023,20 @@ Line=Get_Ln(LuSpool) Call UpCase(Line) Line = adjustl(Line) - KSDFT=Line(1:16) + KSDFT=Line(1:80) + nFunc = 0 + Read(Line,*,iostat=istatus) nFunc + If ((istatus == 0) .and. (nFunc > 0)) Then + KSDFT = Custom_Func + LuCF = IsFreeUnit(10) + Call molcas_open(LuCF,Custom_File) + Write(LuCF,*) Trim(KSDFT),nFunc + Do i=1,nFunc + Line=Get_Ln(LuSpool) + Write(LuCF,*) Trim(Line) + End Do + Close(LuCF) + End If GoTo 1000 * *>>>>>>>>>>>>> DFCF <<<< Factors to scale exch. and corr. << @@ -1103,7 +1113,7 @@ Line=Get_Ln(LuSpool) Call UpCase(Line) Line = adjustl(Line) - ADDC_KSDFT=Line(1:16) + ADDC_KSDFT=Line(1:80) GoTo 1000 * *>>>>>>>>>>>>> SAVE << Spin-Averaged wavelets (CONStraint) < diff -Nru openmolcas-22.02/src/scf/readin_scf.f openmolcas-22.10/src/scf/readin_scf.f --- openmolcas-22.02/src/scf/readin_scf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/readin_scf.f 2022-10-10 14:22:40.000000000 +0000 @@ -39,11 +39,11 @@ * * ************************************************************************ * + use InfSO Implicit Real*8 (a-h,o-z) * #include "mxdm.fh" #include "infscf.fh" -#include "infso.fh" * Real*8 SIntTh Logical PkMode diff -Nru openmolcas-22.02/src/scf/rs-rfo-scf.f openmolcas-22.10/src/scf/rs-rfo-scf.f --- openmolcas-22.02/src/scf/rs-rfo-scf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/rs-rfo-scf.f 2022-10-10 14:22:40.000000000 +0000 @@ -12,7 +12,7 @@ * 2014,2018, Ignacio Fdez. Galvan * ************************************************************************ Subroutine RS_RFO_SCF(HDiag,g,nInter,dq,UpMeth,dqdq,dqHdq,StepMax, - & Step_Trunc,MemRsv) + & Step_Trunc) ************************************************************************ * * * Object: Automatic restricted-step rational functional * @@ -95,8 +95,7 @@ * which computes Hc, where c is a trial vector, from an initial * Hessian based on a diagonal approximation and a BFGS update. * - Call Davidson_SCF(HDiag,g,nInter,NumVal,A_RFO,Val,Vec,MemRsv, - & iStatus) + Call Davidson_SCF(HDiag,g,nInter,NumVal,A_RFO,Val,Vec,iStatus) If (iStatus.gt.0) Then Call SysWarnMsg('RS_RFO', & 'Davidson procedure did not converge','') diff -Nru openmolcas-22.02/src/scf/scf.f openmolcas-22.10/src/scf/scf.f --- openmolcas-22.02/src/scf/scf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/scf.f 2022-10-10 14:22:40.000000000 +0000 @@ -36,11 +36,11 @@ Use SCF_Arrays Use Interfaces_SCF, Only: OccDef use OFembed, only: Do_OFemb + use InfSO Implicit Real*8 (a-h,o-z) * #include "mxdm.fh" #include "infscf.fh" -#include "infso.fh" #include "stdalloc.fh" #include "twoswi.fh" #include "file.fh" @@ -150,17 +150,14 @@ ************************************************************************ SubRoutine IniLLs * initialize the diverse linked lists + use LnkLst Implicit Real*8 (a-h,o-z) #include "mxdm.fh" #include "infscf.fh" -#include "infso.fh" #include "llists.fh" -#include "lnklst.fh" * * -* MemRsv set tentatively to the size of six density matrices -c MemRsv=6*nBT LLlist=0 LLGrad=0 Call IniLst(LLGrad,20) @@ -209,8 +206,8 @@ End *----------------------------------------------------------------------* Subroutine RclLLs(iDskPt) + use InfSO, only: MemRsv Implicit Real*8 (a-h,o-z) -#include "infso.fh" #include "file.fh" #include "llists.fh" Integer iDskPt(5) @@ -244,8 +241,8 @@ End *----------------------------------------------------------------------* Subroutine StlLst(LLink) + use LnkLst, only: nLList Implicit Real*8 (a-h,o-z) -#include "WrkSpc.fh" return Write (6,*) Write (6,*) '*********** Status of Linked List *************' @@ -253,27 +250,27 @@ Write (6,*) ' LLink:',LLink Write (6,*) Write (6,*) ' CNOD data' - Write (6,*) 'Error code: ',iWork(LLink ) - Write (6,*) 'Pointer to first NODE in the list:',iWork(LLink+1) - Write (6,*) 'Actual length of list: ',iWork(LLink+2) - Write (6,*) '# of vectors in core: ',iWork(LLink+3) + Write (6,*) 'Error code: ',nLList(LLink,0) + Write (6,*) 'Pointer to first NODE in the list:',nLList(LLink,1) + Write (6,*) 'Actual length of list: ',nLList(LLink,2) + Write (6,*) '# of vectors in core: ',nLList(LLink,3) Write (6,*) - iRoot=iWork(LLink+1) + iRoot=nLList(LLink,1) Do while (iRoot.ne.0) Write (6,*) ' NODE data' Write (6,*) 'NODE @: ',iRoot - Write (6,*) 'Pointer to next NODE: ',iWork(iRoot ) - Write (6,*) 'Pointer to stored vector: ',iWork(iRoot+1) - If (iWork(iRoot+5).ge.1) Then + Write (6,*) 'Pointer to next NODE: ',nLList(iRoot,0) + Write (6,*) 'Pointer to stored vector: ',nLList(iRoot,1) + If (nLList(iRoot,5).ge.1) Then Write (6,*) 'Vector status: in Core' Else Write (6,*) 'Vector status: on Disk' End If - Write (6,*) 'Next free position: ',iWork(iRoot+2) - Write (6,*) 'Length of vector: ',iWork(iRoot+3) - Write (6,*) 'Iteration number: ',iWork(iRoot+4) + Write (6,*) 'Next free position: ',nLList(iRoot,2) + Write (6,*) 'Length of vector: ',nLList(iRoot,3) + Write (6,*) 'Iteration number: ',nLList(iRoot,4) Write (6,*) - iRoot=iWork(iRoot) + iRoot=nLList(iRoot,0) End Do Write (6,*) '************ End of Status Report *************' Write (6,*) @@ -297,12 +294,12 @@ End *----------------------------------------------------------------------* Subroutine Reduce_Thresholds(EThr_,SIntTh) + use InfSO, only: DltNTh Implicit Real*8 (a-h,o-z) #include "real.fh" * #include "mxdm.fh" #include "infscf.fh" -#include "infso.fh" #include "save.fh" * Write (6,*) @@ -334,11 +331,11 @@ Return End Subroutine Reset_Thresholds + use InfSO, only: DltNTh Implicit Real*8 (a-h,o-z) * #include "mxdm.fh" #include "infscf.fh" -#include "infso.fh" #include "save.fh" * Write (6,*) diff -Nru openmolcas-22.02/src/scf/scf_init.f openmolcas-22.10/src/scf/scf_init.f --- openmolcas-22.02/src/scf/scf_init.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/scf_init.f 2022-10-10 14:22:40.000000000 +0000 @@ -16,12 +16,12 @@ * purpose: set up parameters that has to be predefined in SCF * * * ************************************************************************ + Use InfSO Implicit Real*8 (a-h,o-z) * #include "mxdm.fh" #include "file.fh" #include "infscf.fh" -#include "infso.fh" #include "llists.fh" #include "twoswi.fh" #include "hfc_logical.fh" diff -Nru openmolcas-22.02/src/scf/sorb.f openmolcas-22.10/src/scf/sorb.f --- openmolcas-22.02/src/scf/sorb.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/sorb.f 2022-10-10 14:22:40.000000000 +0000 @@ -61,16 +61,16 @@ #ifdef _HDF5_ Use mh5, Only: mh5_close_file #endif + use InfSO Implicit Real*8 (a-h,o-z) * #include "real.fh" #include "mxdm.fh" #include "infscf.fh" -#include "infso.fh" #include "file.fh" Real*8 CMO(mBB,nD), TrM(mBB,nD), OneHam(mBT), Fock(mBT,nD), & Ovrlp(mBT), EOrb(mmB,nD), OccNo(mmB,nD) - Character FName*512, KSDFT_save*16 + Character FName*512, KSDFT_save*80 Logical FstItr Logical found * diff -Nru openmolcas-22.02/src/scf/sorupv.f openmolcas-22.10/src/scf/sorupv.f --- openmolcas-22.02/src/scf/sorupv.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/sorupv.f 2022-10-10 14:22:40.000000000 +0000 @@ -12,19 +12,14 @@ * 2017, Roland Lindh * * 2018, Ignacio Fdez. Galvan * ************************************************************************ - SubRoutine SOrUpV(NoAllo,V,HDiag,lvec,W,Mode,UpTp) + SubRoutine SOrUpV(V,HDiag,lvec,W,Mode,UpTp) ************************************************************************ * for Ref., see T.H. Fischer and J. Almloef, JPC 96, 9768 (1992) * * doi:10.1021/j100203a036 * * * * purpose: Second Order Updated vector V using BFGS and * * diagonal Hessian of Orbital Rotations * -* input : NoAllo -> this routine tries to allocate memory * -* to construct linked lists, so you have to tell, how * -* much you want to keep for your own purpose... * -* for all procedure parameters, iad prefix means the * -* address of the var on Work Array * -* V -> input vector * +* input : V -> input vector * * HDiag -> initial diagonal Hessian * * lvec -> lengths of vectors delta, grad, HDiag & V * * Mode -> update mode, see below * @@ -64,19 +59,19 @@ * history: none * * * ************************************************************************ + use LnkLst, only: SCF_V +* only tentatively this Module + use InfSO Implicit Real*8 (a-h,o-z) #include "file.fh" #include "llists.fh" #include "real.fh" #include "mxdm.fh" #include "infscf.fh" -* only tentatively this inc file -#include "infso.fh" -#include "WrkSpc.fh" #include "stdalloc.fh" * * declaration subroutine parameters - Integer NoAllo,lvec + Integer lvec Real*8 W(lVec), HDiag(lVec), V(lvec) Character*4 Mode, UpTp * @@ -102,7 +97,6 @@ Inverse_H=.False. Lu1=-1 LL1=-1 - Lu2=-1 LL2=-1 * * This section will control the mode @@ -114,7 +108,6 @@ Inverse_H=.True. Lu1=LuDel LL1=LLDelt - Lu2=LudGd LL2=LLdGrd * Else If (Mode.eq.'GRAD') Then @@ -124,7 +117,6 @@ Inverse_H=.False. Lu1=LudGd LL1=LLdGrd - Lu2=LuDel LL2=LLDelt * End If @@ -192,7 +184,7 @@ * Call GetNod(iter-1,LL2,inode) If (inode.eq.0) GoTo 555 - Call iVPtr(Lu2,SOGrd,lvec,inode) + Call iVPtr(SOGrd,lvec,inode) * * (3b): initialize y(n-1)=HDiag*dGrd(n-1) ... * @@ -214,7 +206,7 @@ * and store it on appropriate linked list * leny=LLLen(LLy) - Call PutVec(SOScr,lvec,Luy,iter-1,NoAllo,'NOOP',LLy) + Call PutVec(SOScr,lvec,iter-1,'NOOP',LLy) If (leny.eq.LLLen(LLy)) Then * already there, so we don't have to recalculate later updy=.False. @@ -231,15 +223,15 @@ * Call GetNod(it,LL1,inode) If (inode.eq.0) GoTo 555 - Call iVPtr(Lu1,SODel,lvec,inode) + Call iVPtr(SODel,lvec,inode) * Call GetNod(it,LL2,inode) If (inode.eq.0) GoTo 555 - Call iVPtr(Lu2,SOGrd,lvec,inode) + Call iVPtr(SOGrd,lvec,inode) * Call GetNod(it,LLy,inode) If (inode.eq.0) GoTo 555 - Call iVPtr(Luy,SOScr,lvec,inode) + Call iVPtr(SOScr,lvec,inode) * * calculate S_k and T_k dot products. * (note that S(2) is the inverse of the one in the paper @@ -259,10 +251,10 @@ * here we have to reload dGrd(n-1) from llist, but this * for sure is a memory hit, since it was put there last * - ipdgd=LstPtr(Lu2,iter-1,LL2) + ipdgd=LstPtr(iter-1,LL2) * - S(5)=ddot_(lvec,SODel,1,Work(ipdgd),1) - S(6)=ddot_(lvec,SOScr,1,Work(ipdgd),1) + S(5)=ddot_(lvec,SODel,1,SCF_V(ipdgd)%A,1) + S(6)=ddot_(lvec,SOScr,1,SCF_V(ipdgd)%A,1) Else S(5)=Zero S(6)=Zero @@ -314,9 +306,9 @@ * -> we operate directly on the memory cells of the LList, * where y(n-1) resides. * - ipynm1=LstPtr(Luy,iter-1,LLy) - Call daxpy_(lvec, T(3),SODel,1,Work(ipynm1),1) - Call daxpy_(lvec,-T(4),SOScr,1,Work(ipynm1),1) + ipynm1=LstPtr(iter-1,LLy) + Call daxpy_(lvec, T(3),SODel,1,SCF_V(ipynm1)%A,1) + Call daxpy_(lvec,-T(4),SOScr,1,SCF_V(ipynm1)%A,1) End If * End Do @@ -324,32 +316,32 @@ * (5): reload y(n-1), delta(n-1) & dGrd(n-1) from linked list. * these all are memory hits, of course * - ipynm1=LstPtr(Luy,iter-1,LLy) - ipdel =LstPtr(Lu1,iter-1,LL1) - ipdgd =LstPtr(Lu2,iter-1,LL2) + ipynm1=LstPtr(iter-1,LLy) + ipdel =LstPtr(iter-1,LL1) + ipdgd =LstPtr(iter-1,LL2) #ifdef _DEBUGPRINT_ - Call RecPrt('y(n-1)',' ',Work(ipynm1),1,lVec) + Call RecPrt('y(n-1)',' ',SCF_V(ipynm1)%A,1,lVec) If (Mode.eq.'DISP') Then - Call RecPrt('dX(n-1)',' ',Work(ipdel),1,lVec) - Call RecPrt('dg(n-1)',' ',Work(ipdgd),1,lVec) + Call RecPrt('dX(n-1)',' ',SCF_V(ipdel)%A,1,lVec) + Call RecPrt('dg(n-1)',' ',SCF_V(ipdgd)%A,1,lVec) Else - Call RecPrt('dg(n-1)',' ',Work(ipdel),1,lVec) - Call RecPrt('dX(n-1)',' ',Work(ipdgd),1,lVec) + Call RecPrt('dg(n-1)',' ',SCF_V(ipdel)%A,1,lVec) + Call RecPrt('dX(n-1)',' ',SCF_V(ipdgd)%A,1,lVec) End If #endif * * calculate diverse dot products... * - S(1)=ddot_(lvec,Work(ipdel),1,Work(ipdgd),1) + S(1)=ddot_(lvec,SCF_V(ipdel)%A,1,SCF_V(ipdgd)%A,1) If (Abs(S(1)).lt.Thr) Then S(1)=Zero !S(1)=One/Thr Else S(1)=One/S(1) End If - S(2)=ddot_(lvec,Work(ipdgd),1,Work(ipynm1),1) - S(3)=ddot_(lvec,Work(ipdel),1,V,1) - S(4)=ddot_(lvec,Work(ipynm1),1,V,1) + S(2)=ddot_(lvec,SCF_V(ipdgd)%A,1,SCF_V(ipynm1)%A,1) + S(3)=ddot_(lvec,SCF_V(ipdel)%A,1,V,1) + S(4)=ddot_(lvec,SCF_V(ipynm1)%A,1,V,1) #ifdef _DEBUGPRINT_ Write (6,*) '(S(i),i=1,4)=',(S(i),i=1,4) #endif @@ -380,8 +372,8 @@ #ifdef _DEBUGPRINT_ Write (6,*) '(T(i),i=1,2)=',(T(i),i=1,2) #endif - Call daxpy_(lvec, T(1),Work(ipdel),1,W,1) - Call daxpy_(lvec,-T(2),Work(ipynm1),1,W,1) + Call daxpy_(lvec, T(1),SCF_V(ipdel)%A,1,W,1) + Call daxpy_(lvec,-T(2),SCF_V(ipynm1)%A,1,W,1) #ifdef _DEBUGPRINT_ Call RecPrt('The final W array',' ',W,1,lVec) #endif diff -Nru openmolcas-22.02/src/scf/start3.f openmolcas-22.10/src/scf/start3.f --- openmolcas-22.02/src/scf/start3.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/start3.f 2022-10-10 14:22:40.000000000 +0000 @@ -38,7 +38,6 @@ #include "file.fh" #include "mxdm.fh" #include "infscf.fh" -#include "WrkSpc.fh" Real*8 CMO(mBB,nD), TrM(mBB,nD), OneHam(mBT), Ovrlp(mBT), & Dens(mBT,nD) * diff -Nru openmolcas-22.02/src/scf/start6.f openmolcas-22.10/src/scf/start6.f --- openmolcas-22.02/src/scf/start6.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/start6.f 2022-10-10 14:22:40.000000000 +0000 @@ -18,25 +18,24 @@ * called from: SOrb * * * ************************************************************************ + use SpinAV Implicit Real*8 (a-h,o-z) #include "real.fh" #include "file.fh" #include "mxdm.fh" #include "infscf.fh" -#include "WrkSpc.fh" #include "stdalloc.fh" * Character FName*(*), Line*62 Integer nTmp(8), nIF(8), nRASO(8), nBD(8), nZero(8), nHoles(8) Integer nSsh(8), nSsh_ab(8) #include "dcscf.fh" -#include "spave.fh" * Pam 2012 Changed VECSORT arg list, need dummy array: Integer iDummy(1) Real*8 CMO(mBB,nD), EOrb(mmB,nD), OccNo(mmB,nD) Integer, Dimension(:), Allocatable:: IndT, ID_vir - Real*8, Dimension(:,:), Allocatable:: Da - Integer, Dimension(:,:), Allocatable:: Match + Real*8, Allocatable:: Da(:,:) + Integer, Allocatable:: Match(:,:) Real*8, Dimension(:), Allocatable:: Corb, SAV, SLT, SQ Real*8 Dummy(1) ************************************************************************ @@ -180,7 +179,7 @@ Call TrimEor(EOrb,EOrb,nSym,nBas,nOrb) Call mma_deallocate(IndT) * - Call Setup + Call Setup() * Call Izero(nBD,nSym) Do iSym=2,nSym @@ -188,7 +187,7 @@ & + nBas(iSym-1)*(nBas(iSym-1)+1)/2 End Do Call mma_allocate(Da,nBT,2,Label='Da') - Call Fzero(Da,2*nBT) + Da(:,:)=Zero Call mma_allocate(Match,2,MxConstr,Label='Match') Call mma_allocate(Corb,MaxBas,Label='Corb') * @@ -293,7 +292,8 @@ * If (Do_SpinAV) Then Call mma_deallocate(SAV) - Call GetMem('DSc','Allo','Real',ip_DSc,nBB) + Call mma_Allocate(DSc,nBB,Label='DSc') + DSC(:)=Zero EndIf * iOff=1 @@ -313,16 +313,16 @@ & 0.0d0,Da(ipDbb,2),nBas(iSym)) * If (Do_SpinAV) Then - ipDScc=ip_DSc+lOff + ipDScc=lOff Do j=1,nBas(iSym) Do i=1,j ji=j*(j-1)/2+i iDaa=ipDaa-1+ji iDbb=ipDbb-1+ji - iDSc=ipDScc-1+nBas(iSym)*(j-1)+i - Work(iDSc)=0.5d0*(Da(iDaa,1)-Da(iDbb,2)) - kDSc=ipDScc-1+nBas(iSym)*(i-1)+j - Work(kDSc)=Work(iDSc) + iDSc=ipDScc+nBas(iSym)*(j-1)+i + DSc(iDSc)=0.5d0*(Da(iDaa,1)-Da(iDbb,2)) + kDSc=ipDScc+nBas(iSym)*(i-1)+j + DSc(kDSc)=DSc(iDSc) End Do End Do lOff=lOff+nBas(iSym)**2 @@ -345,9 +345,8 @@ Call WarningMessage(2,'Start6. Non-zero rc in Cho_X_init.') Call Abend endif - *----------------------------------------------------------------------* - Call Get_Fmat_nondyn(Da(1,1),Da(1,2),nBT,.false.) + Call Get_Fmat_nondyn(Da(:,1),Da(:,2),nBT,.false.) *----------------------------------------------------------------------* Call Cho_X_Final(irc) @@ -473,11 +472,11 @@ Subroutine Get_Fmat_nondyn(Dma,Dmb,nBDT,DFTX) Use Fock_util_global, only: Deco use Data_Structures, only: Allocate_DT, Deallocate_DT, DSBA_Type + use SpinAV Implicit Real*8 (a-h,o-z) #include "real.fh" #include "mxdm.fh" #include "infscf.fh" -#include "WrkSpc.fh" #include "stdalloc.fh" * Integer nBDT @@ -493,9 +492,7 @@ Type (DSBA_Type) FLT(2), KLT(2), POrb(2), PLT(2) * #include "dcscf.fh" -#include "spave.fh" * - nDMat=2 Do i=1,nSym nForb(i,1)=0 @@ -519,8 +516,8 @@ Call Allocate_DT(POrb(2),nBas,nBas,nSym) Call mma_allocate(Dm,nBB,2,Label='Dm') - Call UnFold(Dma,nBDT,Dm(1,1),nBB,nSym,nBas) - Call UnFold(Dmb,nBDT,Dm(1,2),nBB,nSym,nBas) + Call UnFold(Dma,nBDT,Dm(:,1),nBB,nSym,nBas) + Call UnFold(Dmb,nBDT,Dm(:,2),nBB,nSym,nBas) * If (Do_SpinAV) Then If (.not.DECO) Then @@ -528,8 +525,8 @@ write(6,*) ' NODE will be reset to default. ' DECO=.true. EndIf - Call daxpy_(NBB,-1.0d0,Work(ip_DSc),1,Dm(1,1),1) - Call daxpy_(NBB, 1.0d0,Work(ip_DSc),1,Dm(1,2),1) + Call daxpy_(NBB,-1.0d0,DSc,1,Dm(:,1),1) + Call daxpy_(NBB, 1.0d0,DSc,1,Dm(:,2),1) EndIf * iOff=0 @@ -539,6 +536,7 @@ & nIorb(i,1),1.0d-12,irc) If (irc.ne.0) Then write(6,*) ' Alpha density. Sym= ',i,' rc= ',irc + Call RecPrt('Dm',' ',Dm(ipDai,1),nBas(i),nBas(i)) Call Abend() EndIf ipDbi=1+iOff @@ -546,6 +544,7 @@ & nIorb(i,2),1.0d-12,irc) If (irc.ne.0) Then write(6,*) ' Beta density. Sym= ',i,' rc= ',irc + Call RecPrt('Dm',' ',Dm(ipDbi,1),nBas(i),nBas(i)) Call Abend() EndIf iOff=iOff+nBas(i)**2 @@ -572,8 +571,8 @@ If (Do_SpinAV) Then Call UnFold(Dma,nBDT,Dm(1,1),nBB,nSym,nBas) Call UnFold(Dmb,nBDT,Dm(1,2),nBB,nSym,nBas) - Call daxpy_(NBB,-1.0d0,Work(ip_DSc),1,Dm(1,1),1) - Call daxpy_(NBB, 1.0d0,Work(ip_DSc),1,Dm(1,2),1) + Call daxpy_(NBB,-1.0d0,DSc,1,Dm(1,1),1) + Call daxpy_(NBB, 1.0d0,DSc,1,Dm(1,2),1) Call Fold(nSym,nBas,Dm(1,1),Dma) Call Fold(nSym,nBas,Dm(1,2),Dmb) EndIf diff -Nru openmolcas-22.02/src/scf/swiopt.f openmolcas-22.10/src/scf/swiopt.f --- openmolcas-22.02/src/scf/swiopt.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/swiopt.f 2022-10-10 14:22:40.000000000 +0000 @@ -32,11 +32,11 @@ * * ************************************************************************ * + Use InfSO Implicit Real*8 (a-h,o-z) #include "real.fh" #include "mxdm.fh" #include "infscf.fh" -#include "infso.fh" #include "twoswi.fh" #include "file.fh" * diff -Nru openmolcas-22.02/src/scf/traclc_x.f openmolcas-22.10/src/scf/traclc_x.f --- openmolcas-22.02/src/scf/traclc_x.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/traclc_x.f 2022-10-10 14:22:40.000000000 +0000 @@ -11,11 +11,11 @@ * Copyright (C) 2017, Roland Lindh * ************************************************************************ Subroutine TraClc_x(kOptim,opQNR,FrstDs,QNR1st,CInter,nCI,nD, - & nOV,Lux,iter,memRsv,LLx) + & nOV,iter,LLx) Implicit None #include "real.fh" #include "stdalloc.fh" - Integer kOptim,nCI,nD,nOV,Lux,iter,memRsv,LLx + Integer kOptim,nCI,nD,nOV,iter,LLx Logical opQNR, FrstDs, QNR1st Real*8 CInter(nCI,nD) Real*8, Dimension(:,:), Allocatable:: Xn @@ -56,7 +56,7 @@ Call mma_allocate(Xn,nOV,nD,Label='Xn') Call FZero(Xn,nOV*nD) * and store it on appropriate LList - Call PutVec(Xn,nOV*nD,Lux,iter,MemRsv,'NOOP',LLx) + Call PutVec(Xn,nOV*nD,iter,'NOOP',LLx) *define _DEBUGPRINT_ #ifdef _DEBUGPRINT_ Write (6,*) 'TraClc_x: Initiate X(n), iter=',iter diff -Nru openmolcas-22.02/src/scf/trafck.f openmolcas-22.10/src/scf/trafck.f --- openmolcas-22.02/src/scf/trafck.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/trafck.f 2022-10-10 14:22:40.000000000 +0000 @@ -47,6 +47,7 @@ * history: none * * * ************************************************************************ + use SpinAV, only: Do_SpinAV Implicit Real*8 (a-h,o-z) #include "real.fh" #include "mxdm.fh" @@ -58,8 +59,6 @@ & Ovrlp(nFock) Logical canorb * -#include "spave.fh" -* Real*8, Dimension(:), Allocatable:: FckM, FckS, HlfF, EigV, & Ctmp, Scratch, CMOOld, & Scrt, COvrlp diff -Nru openmolcas-22.02/src/scf/tw_corr_drv.f openmolcas-22.10/src/scf/tw_corr_drv.f --- openmolcas-22.02/src/scf/tw_corr_drv.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/tw_corr_drv.f 2022-10-10 14:22:40.000000000 +0000 @@ -15,12 +15,14 @@ Implicit Real*8 (a-h,o-z) #include "mxdm.fh" #include "infscf.fh" -#include "WrkSpc.fh" +#include "stdalloc.fh" Integer nEO, nCMO Real*8 EOrb(nEO), CMO(nCMO), Ecorr + Real*8, Allocatable :: Eov(:) - Call GetMem('Eov','Allo','Real',ipEOkk,nEO) + Call mma_Allocate(Eov,nEO,Label='Eov') + ipEOkk=1 ipEVir=ipEOkk+nnOc iOff=0 jOff=0 @@ -31,21 +33,21 @@ jOrb=1+jOff jOkk=ipEOkk+iOff Do i=0,nOkk-1 - Work(jOkk+i)=EOrb(jOrb+i) + Eov(jOkk+i)=EOrb(jOrb+i) End Do jOrb=jOrb+nOkk jVir=ipEVir+kOff Do i=0,nExt-1 - Work(jVir+i)=EOrb(jOrb+i) + Eov(jVir+i)=EOrb(jOrb+i) End Do iOff=iOff+nOkk jOff=jOff+nOrb(iSym) kOff=kOff+nExt End Do - Call Tw_corr(irc,Ecorr,CMO,Work(ipEOkk),Work(ipEVir)) + Call Tw_corr(irc,Ecorr,CMO,Eov(:ipEVir-1),Eov(ipEVir:)) - Call GetMem('Eov','Free','Real',ipEOkk,nEO) + Call mma_deallocate(Eov) Return End ***************************************************************************** @@ -54,7 +56,7 @@ SUBROUTINE Tw_corr(irc,DeTW,CMOI,EOcc,EVir) #include "implicit.fh" -#include "WrkSpc.fh" +#include "stdalloc.fh" Real*8 DeTW, CMOI(*), EOcc(*), EVir(*) C Integer nExt(8) @@ -62,12 +64,12 @@ #include "infscf.fh" #include "chomp2_cfg.fh" Dimension Grad(1) + Real*8, Allocatable :: DMAT(:,:), F_DFT(:) DoDens = .false. ChoAlg = 2 * - CALL GETMEM('DMAT','ALLO','REAL',ip_DM0,2*nBT) - ip_DM=ip_DM0+nBT + CALL mma_allocate(DMAT,nBT,2,Label='DMAT') nElk=0 Do i=1,nSym @@ -76,7 +78,7 @@ End Do CALL DM_FNO_RHF(irc,nSym,nBas,nFro,nOcc(1,1),nExt,nDel, - & CMOI,EOcc,EVir,Work(ip_DM0),Work(ip_DM)) + & CMOI,EOcc,EVir,DMAT(:,2),DMAT(:,1)) If (irc .ne. 0) Then Write(6,*) 'DM_FNO_RHF returned ',irc Call SysAbendMsg('DM_FNO_RHF', @@ -84,27 +86,27 @@ & ' ') EndIf - CALL GETMEM('FMAT','ALLO','REAL',ipF_DFT,nBT) + CALL mma_allocate(F_DFT,nBT,Label='F_DFT') * - Call Fold_tMat(nSym,nBas,Work(ip_DM),Work(ip_DM)) - call dscal_(nBT,0.5d0,Work(ip_DM),1) - Call Fold_tMat(nSym,nBas,Work(ip_DM0),Work(ip_DM0)) - call dscal_(nBT,0.5d0,Work(ip_DM0),1) + Call Fold_tMat(nSym,nBas,DMAT(:,1),DMAT(:,1)) + call dscal_(nBT,0.5d0,DMAT(:,1),1) + Call Fold_tMat(nSym,nBas,DMAT(:,2),DMAT(:,2)) + call dscal_(nBT,0.5d0,DMAT(:,2),1) Grad=0.0d0 - Call wrap_DrvNQ('HUNTER',Work(ipF_DFT),1,TW, - & Work(ip_DM),nBT,1, + Call wrap_DrvNQ('HUNTER',F_DFT,1,TW, + & DMAT(:,1),nBT,1, & .false., & Grad,1,'SCF ') - Call wrap_DrvNQ('HUNTER',Work(ipF_DFT),1,TW0, - & Work(ip_DM0),nBT,1, + Call wrap_DrvNQ('HUNTER',F_DFT,1,TW0, + & DMAT(:,2),nBT,1, & .false., & Grad,1,'SCF ') DeTW=(TW-TW0)/dble(nElk) * - CALL GETMEM('FMAT','FREE','REAL',ipF_DFT,nBT) - CALL GETMEM('DMAT','FREE','REAL',ip_DM0,2*nBT) + Call mma_deallocate(F_DFT) + Call mma_deallocate(DMAT) * Return End @@ -124,7 +126,7 @@ Implicit Real*8 (A-H,O-Z) #include "Molcas.fh" #include "real.fh" -#include "WrkSpc.fh" +#include "stdalloc.fh" * Integer nBas(nSym),nFro(nSym),nIsh(nSym),nSsh(nSym), & nDel(nSym) @@ -132,6 +134,7 @@ #include "chfnopt.fh" * Integer lnOrb(8), lnOcc(8), lnFro(8), lnDel(8), lnVir(8) + Real*8, Allocatable:: CMO(:,:), EOrb(:,:), DMAT(:) * * irc=0 @@ -162,9 +165,8 @@ Endif * NCMO=nSQ - CALL GETMEM('LCMO','ALLO','REAL',LCMO,2*NCMO) - iCMO=LCMO+NCMO - CALL DCOPY_(NCMO,CMOI,1,WORK(LCMO),1) + Call mma_allocate(CMO,nCMO,2,Label='CMO') + CALL DCOPY_(NCMO,CMOI,1,CMO(:,1),1) * nOA=0 Do iSym=1,nSym ! setup info @@ -176,59 +178,57 @@ lnDel(iSym)=nDel(iSym) End Do * - Call GetMem('Eorb','Allo','Real',ipOrbE,4*nOrb) + Call mma_Allocate(EOrb,nOrb,4,Label='EOrb') jOff=0 kOff=0 lOff=0 Do iSym=1,nSym - jp=ipOrbE+lOff+nFro(iSym) + jp=1+lOff+nFro(iSym) jOcc=jOff+1 - call dcopy_(nIsh(iSym),EOcc(jOcc),1,Work(jp),1) + call dcopy_(nIsh(iSym),EOcc(jOcc),1,EOrb(jp,1),1) jVir=kOff+1 jp=jp+nIsh(iSym) - call dcopy_(nSsh(iSym),EVir(jVir),1,Work(jp),1) + call dcopy_(nSsh(iSym),EVir(jVir),1,EOrb(jp,1),1) jOff=jOff+nIsh(iSym) kOff=kOff+nSsh(iSym) lOff=lOff+nBas(iSym) End Do - ip_ZZ=ipOrbE - ipEorb=ipOrbE+nOrb - ip_Z=ipEorb - kEOcc=ipEorb+nOrb - kEVir=kEOcc+nOrb ioff=0 joff=0 koff=0 Do iSym=1,nSym - ifr=ipOrbE+ioff+nFro(iSym) - ito=kEOcc+joff - call dcopy_(nIsh(iSym),Work(ifr),1,Work(ito),1) - ifr=ipOrbE+ioff+nFro(iSym)+nIsh(iSym) - ito=kEVir+koff - call dcopy_(nSsh(iSym),Work(ifr),1,Work(ito),1) + ifr=1+ioff+nFro(iSym) + ito=1+joff + call dcopy_(nIsh(iSym),EOrb(ifr,1),1,EOrb(ito,3),1) + ifr=1+ioff+nFro(iSym)+nIsh(iSym) + ito=1+koff + call dcopy_(nSsh(iSym),EOrb(ifr,1),1,EOrb(ito,4),1) ioff=ioff+nBas(iSym) joff=joff+nIsh(iSym) koff=koff+nSsh(iSym) End Do - Call GetMem('Dmat','Allo','Real',ip_X,nVV+nOA) - ip_Y=ip_X+nVV - Call FZero(Work(ip_X),nVV+nOA) -* + Call mma_Allocate(DMAT,nVV+nOA,Label='DMAT') + DMAT(:)=Zero + + ip_X = ip_of_Work(DMAT(1)) + ip_Y = ip_X+nVV Call FnoSCF_putInf(nSym,lnOrb,lnOcc,lnFro,lnDel,lnVir,ip_X,ip_Y) - Call FZero(Work(iCMO),NCMO) + ip_X = 1 + + CMO(:,2)=Zero iOff=0 Do iSym=1,nSym - kfr=LCMO+iOff+nBas(iSym)*nFro(iSym) - kto=iCMO+iOff+nBas(iSym)*lnFro(iSym) - call dcopy_(nBas(iSym)*lnOcc(iSym),Work(kfr),1,Work(kto),1) - kfr=LCMO+iOff+nBas(iSym)*(nFro(iSym)+nIsh(iSym)) + kfr=1+iOff+nBas(iSym)*nFro(iSym) + kto=1+iOff+nBas(iSym)*lnFro(iSym) + call dcopy_(nBas(iSym)*lnOcc(iSym),CMO(kfr,1),1,CMO(kto,2),1) + kfr=1+iOff+nBas(iSym)*(nFro(iSym)+nIsh(iSym)) kto=kto+nBas(iSym)*lnOcc(iSym) - call dcopy_(nBas(iSym)*lnVir(iSym),Work(kfr),1,Work(kto),1) + call dcopy_(nBas(iSym)*lnVir(iSym),CMO(kfr,1),1,CMO(kto,2),1) iOff=iOff+nBas(iSym)**2 End Do Call Check_Amp_SCF(nSym,lnOcc,lnVir,iSkip) If (iSkip.gt.0) Then - Call ChoMP2_Drv(irc,Dummy,Work(iCMO),Work(kEOcc),Work(kEVir)) + Call ChoMP2_Drv(irc,Dummy,CMO(:,2),EOrb(:,3),EOrb(:,4)) If(irc.ne.0) then write(6,*) 'MP2 pseudodensity calculation failed !' Call Abend @@ -245,71 +245,71 @@ * Compute the correlated density in AO basis * ------------------------------------------------------------- jOcc=ip_X+nVV -c write(6,*) ' Occ : ',(Work(jOcc+j),j=0,nOA-1) -c write(6,*) ' Sum : ',ddot_(nOA,1.0d0,0,Work(jOcc),1) - call dscal_(nOA,2.0d0,Work(jOcc),1) - Call daxpy_(nOA,2.0d0,[1.0d0],0,Work(jOcc),1) +c write(6,*) ' Occ : ',(DMAT(jOcc+j),j=0,nOA-1) +c write(6,*) ' Sum : ',ddot_(nOA,1.0d0,0,DMAT(jOcc),1) + call dscal_(nOA,2.0d0,DMAT(jOcc),1) + Call daxpy_(nOA,2.0d0,[1.0d0],0,DMAT(jOcc),1) * iOff=0 jOff=0 kDM=1 Do iSym=1,nSym * - kto=LCMO+jOff + kto=1+jOff nOkk=nFro(iSym)+nIsh(iSym) Call DGEMM_Tri('N','T',nBas(iSym),nBas(iSym),nOkk, - & 2.0d0,Work(kto),nBas(iSym), - & Work(kto),nBas(iSym), + & 2.0d0,CMO(kto,1),nBas(iSym), + & CMO(kto,1),nBas(iSym), & 0.0d0,DM0(kDM),nBas(iSym)) * sqocc=sqrt(2.0d0) - call dscal_(nBas(iSym)*nFro(iSym),sqocc,Work(kto),1) + call dscal_(nBas(iSym)*nFro(iSym),sqocc,CMO(kto,1),1) Do j=0,nIsh(iSym)-1 - sqocc=sqrt(Work(jOcc+j)) + sqocc=sqrt(DMAT(jOcc+j)) ito=kto+nBas(iSym)*j - call dscal_(nBas(iSym),sqocc,Work(ito),1) + call dscal_(nBas(iSym),sqocc,CMO(ito,1),1) End Do Call DGEMM_Tri('N','T',nBas(iSym),nBas(iSym),nOkk, - & 1.0d0,Work(kto),nBas(iSym), - & Work(kto),nBas(iSym), + & 1.0d0,CMO(kto,1),nBas(iSym), + & CMO(kto,1),nBas(iSym), & 0.0d0,DM(kDM),nBas(iSym)) * if (nSsh(iSym).gt.0) then jD=ip_X+iOff * Eigenvectors will be in increasing order of eigenvalues - Call Eigen_Molcas(nSsh(iSym),Work(jD),Work(ip_Z),Work(ip_ZZ)) + Call Eigen_Molcas(nSsh(iSym),DMAT(jD),EOrb(:,2),Eorb(:,1)) * Reorder to get relevant eigenpairs first Do j=1,nSsh(iSym)/2 Do i=1,nSsh(iSym) lij=jD-1+nSsh(iSym)*(j-1)+i kij=jD-1+nSsh(iSym)**2-(nSsh(iSym)*j-i) - tmp=Work(lij) - Work(lij)=Work(kij) - Work(kij)=tmp + tmp=DMAT(lij) + DMAT(lij)=DMAT(kij) + DMAT(kij)=tmp End Do - tmp=Work(ip_Z-1+j) - Work(ip_Z-1+j)=Work(ip_Z+nSsh(iSym)-j) - Work(ip_Z+nSsh(iSym)-j)=tmp + tmp=EOrb(j,2) + EOrb(j,2)=EOrb(nSsh(iSym)-j,2) + EOrb(nSsh(iSym)-j,2)=tmp End Do * * Compute new MO coeff. : X=C*U - kfr=iCMO+jOff+nBas(iSym)*(nFro(iSym)+nIsh(iSym)) - kto=LCMO+jOff+nBas(iSym)*(nFro(iSym)+nIsh(iSym)) + kfr=1+jOff+nBas(iSym)*(nFro(iSym)+nIsh(iSym)) + kto=1+jOff+nBas(iSym)*(nFro(iSym)+nIsh(iSym)) Call DGEMM_('N','N',nBas(iSym),nSsh(iSym),nSsh(iSym), - & 1.0d0,Work(kfr),nBas(iSym), - & Work(jD),nSsh(iSym), - & 0.0d0,Work(kto),nBas(iSym)) + & 1.0d0,CMO(kfr,2),nBas(iSym), + & DMAT(jD),nSsh(iSym), + & 0.0d0,CMO(kto,1),nBas(iSym)) -c write(6,*) ' Occ_vir: ',(Work(ip_Z+j),j=0,nSsh(iSym)-1) -c write(6,*) ' Sum_vir: ',ddot_(nSsh(iSym),1.0d0,0,Work(ip_Z),1) +c write(6,*) ' Occ_vir: ',(EOrb(j,2),j=1,nSsh(iSym)) +c write(6,*) ' Sum_vir: ',ddot_(nSsh(iSym),1.0d0,0,EOrb(:,2),1) Do j=0,nSsh(iSym)-1 - sqocc=sqrt(2.0d0*Work(ip_Z+j)) + sqocc=sqrt(2.0d0*EOrb(1+j,2)) jto=kto+nBas(iSym)*j - call dscal_(nBas(iSym),sqocc,Work(jto),1) + call dscal_(nBas(iSym),sqocc,CMO(jto,1),1) End Do Call DGEMM_Tri('N','T',nBas(iSym),nBas(iSym),nSsh(iSym), - & 1.0d0,Work(kto),nBas(iSym), - & Work(kto),nBas(iSym), + & 1.0d0,CMO(kto,1),nBas(iSym), + & CMO(kto,1),nBas(iSym), & 1.0d0,DM(kDM),nBas(iSym)) iOff=iOff+nSsh(iSym)**2 @@ -319,9 +319,9 @@ jOcc=jOcc+nIsh(iSym) End Do * - Call GetMem('Eorb','Free','Real',ipOrbE,4*nOrb) - Call GetMem('Dmat','Free','Real',ip_X,nVV+nOA) - CALL GETMEM('LCMO','FREE','REAL',LCMO,2*NCMO) + Call mma_deAllocate(EOrb) + Call mma_deAllocate(DMAT) + Call mma_deallocate(CMO) * Return End diff -Nru openmolcas-22.02/src/scf/wfctl_scf.f openmolcas-22.10/src/scf/wfctl_scf.f --- openmolcas-22.02/src/scf/wfctl_scf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/wfctl_scf.f 2022-10-10 14:22:40.000000000 +0000 @@ -89,6 +89,8 @@ Use, Intrinsic :: iso_c_binding, only: c_ptr #endif Use Interfaces_SCF, Only: TraClc_i + use LnkLst, only: SCF_V + use InfSO Implicit Real*8 (a-h,o-z) External Seconds Real*8 Seconds @@ -100,8 +102,6 @@ #include "real.fh" #include "mxdm.fh" #include "infscf.fh" -#include "infso.fh" -#include "WrkSpc.fh" #include "stdalloc.fh" #include "file.fh" #include "llists.fh" @@ -117,7 +117,7 @@ *--- Define local variables Logical QNR1st,FstItr - Character Meth*(*) + Character Meth*(*), Meth_*10 Character*72 Note Logical AufBau_Done, Diis_Save, Reset, Reset_Thresh, AllowFlip Logical ScramNeworb @@ -140,6 +140,11 @@ Call Put_D1Sao(D1Sao,nBT) Call mma_deallocate(D1Sao) * + If (Len_Trim(Meth) > Len(Meth_)) Then + Meth_ = '[...]' + Else + Meth_ = Trim(Meth) + End If iTerm=0 iDMin = - 1 *--- Choose between normal and minimized differences @@ -226,7 +231,7 @@ * *--- Print header to iterations * - If(KSDFT.eq.'SCF'.or.One_Grid) Call PrBeg(Meth) + If(KSDFT.eq.'SCF'.or.One_Grid) Call PrBeg(Meth_) AufBau_Done=.False. * * *======================================================================* @@ -251,7 +256,7 @@ If(KSDFT.ne.'SCF'.and..Not.One_Grid) Then Reset=.True. Call Modify_NQ_Grid() - Call PrBeg(Meth) + Call PrBeg(Meth_) End If * End If @@ -477,7 +482,7 @@ Call SCF_Energy(FstItr,E1V,E2V,EneV) * Call TraClc_x(kOptim,iOpt.eq.2,FrstDs,.FALSE.,CInter,nCI,nD, - & nOV,Lux,iter,memRsv,LLx) + & nOV,iter,LLx) * Call DIIS_x(nD,CInter,nCI,iOpt.eq.2,HDiag,mOV,Ind) * @@ -530,7 +535,7 @@ Call SCF_Energy(FstItr,E1V,E2V,EneV) * Call TraClc_x(kOptim,iOpt.eq.2,FrstDs,QNR1st,CInter,nCI, - & nD,nOV,Lux,iter,memRsv,LLx) + & nD,nOV,iter,LLx) * Call dGrd() * @@ -564,26 +569,26 @@ *------- compute new displacement vector delta * dX(n) = -H(-1)*grd'(n), grd'(n): extrapolated gradient * - Call SOrUpV(MemRsv,Grd1,HDiag,nOV*nD,Disp,'DISP','BFGS') + Call SOrUpV(Grd1,HDiag,nOV*nD,Disp,'DISP','BFGS') * * from this, compute new orb rot parameter X(n+1) * * X(n+1) = X(n) -H(-1)grd'(X(n)) * Call Daxpy_(nOV*nD,-One,Disp,1,Xnp1,1) - Call PutVec(Xnp1,nOV*nD,Lux,iter+1,MemRsv,'NOOP',LLx) + Call PutVec(Xnp1,nOV*nD,iter+1,'NOOP',LLx) * * get address of actual X(n) in corresponding LList * - jpXn=LstPtr(Lux,iter,LLx) + jpXn=LstPtr(iter,LLx) * * and compute actual displacement dX(n)=X(n+1)-X(n) * - Call DZAXPY(nOV*nD,-One,Work(jpXn),1,Xnp1,1,Disp,1) + Call DZAXPY(nOV*nD,-One,SCF_V(jpXn)%A,1,Xnp1,1,Disp,1) * * store dX(n) vector from Disp to LList * - Call PutVec(Disp,nOV*nD,LuDel,iter,MemRsv,'NOOP',LLDelt) + Call PutVec(Disp,nOV*nD,iter,'NOOP',LLDelt) * * compute Norm of dX(n) * @@ -630,7 +635,7 @@ Call SCF_Energy(FstItr,E1V,E2V,EneV) * Call TraClc_x(kOptim,iOpt.ge.2,FrstDs,QNR1st,CInter,nCI, - & nD,nOV,Lux,iter,memRsv,LLx) + & nD,nOV,iter,LLx) * Call dGrd() * @@ -657,7 +662,7 @@ * * get last gradient grad(n) from LList * - Call GetVec(LuGrd,iter,LLGrad,inode,Grd1,nOV*nD) + Call GetVec(iter,LLGrad,inode,Grd1,nOV*nD) #ifdef _DEBUGPRINT_ Call RecPrt('Wfctl: g(n)',' ',Grd1,1,nOV*nD) #endif @@ -667,11 +672,11 @@ * StepMax=0.3D0 Call rs_rfo_scf(HDiag,Grd1,nOV*nD,Disp,AccCon(1:6),dqdq, - & dqHdq,StepMax,AccCon(9:9),MemRsv) + & dqHdq,StepMax,AccCon(9:9)) * * store dX(n) vector from Disp to LList * - Call PutVec(Disp,nOV*nD,LuDel,iter,MemRsv,'NOOP',LLDelt) + Call PutVec(Disp,nOV*nD,iter,'NOOP',LLDelt) #ifdef _DEBUGPRINT_ Write (6,*) 'LuDel,LLDelt:',LuDel,LLDelt Call RecPrt('Wfctl: dX(n)',' ',Disp,1,nOV*nD) @@ -877,6 +882,7 @@ * * EmConv is true. * + If (EDiff>0.0.and..Not.Reset) EDiff=Ten*EThr If (iter.ne.1 .AND. & (Abs(EDiff).le.EThr) .AND. & (Abs(FMOMax).le.FThr) .AND. @@ -1023,7 +1029,7 @@ If (.Not.One_Grid) Then iterX=0 Call Reset_NQ_grid() -* Call PrBeg(Meth) +* Call PrBeg(Meth_) End If If ( iOpt.eq.0 ) kOptim=1 End If diff -Nru openmolcas-22.02/src/scf/wrinp_scf.f openmolcas-22.10/src/scf/wrinp_scf.f --- openmolcas-22.02/src/scf/wrinp_scf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/scf/wrinp_scf.f 2022-10-10 14:22:40.000000000 +0000 @@ -36,6 +36,8 @@ ************************************************************************ * Use Functionals, only: Print_Info + Use KSDFT_Info, only: CoefR, CoefX + Use InfSO * Implicit Real*8 (a-h,o-z) * @@ -44,10 +46,8 @@ #include "mxdm.fh" #include "infscf.fh" -#include "infso.fh" #include "rctfld.fh" #include "ldfscf.fh" -#include "ksdft.fh" * *---- Define local variables Character*60 Fmt, FmtR, FmtI diff -Nru openmolcas-22.02/src/seward/drv1el.F90 openmolcas-22.10/src/seward/drv1el.F90 --- openmolcas-22.02/src/seward/drv1el.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/seward/drv1el.F90 2022-10-10 14:22:40.000000000 +0000 @@ -53,8 +53,8 @@ iMltpl, iOpt, iPAMBas, iPAMf, iPAMltpl, iPrint, iRC, iRout, iSym, iSymBx, iSymBy, iSymBz, iSymC, iSymCX, & iSymCXY, iSymCy, iSymCz, iSymD, iSymLx, iSymLy, iSymLz, iSymR(0:3), iSymRx, iSymRy, iSymRz, iSymX, iSymxLx, & iSymxLy, iSymxLz, iSymXY, iSymXZ, iSymY, iSymyLx, iSymyLy, iSymyLz, iSymYZ, iSymZ, iSymzLx, iSymzLy, iSymzLz, & - iSyXYZ, iTemp, iTol, iWel, ix, ixyz, iy, iz, jx, jxyz, jy, jz, kCnttpPAM_, lOper, LuTmp, mCnt, mComp, & - mDMS, mMltpl, mOrdOp, nB, nComp, nOrdOp, nPAMltpl + iSyXYZ, iTemp, iTol, iWel, ix, ixyz, iy, iz, jx, jxyz, jy, jz, kCnttpPAM_, lOper, LuTmp, mCnt, mComp, mDMS, & + mMltpl, mOrdOp, nB, nComp, nOrdOp, nPAMltpl real(kind=wp) :: Ccoor(3), dum(1), Fact, rHrmt logical(kind=iwp) :: lECPnp, lECP, lPAM2np, lPAM2, lPP, lFAIEMP character(len=8) :: Label @@ -84,7 +84,7 @@ #endif #ifdef _GEN1INT_ integer(kind=iwp) :: nAtoms, jCnt -real(kind=wp) :: XTCInt, XTCMem !XTCInt and XTCMem are dummy names +external :: DumInt, DumMem ! These won't actually be called, but need to be passed around #endif iRout = 131 @@ -1552,7 +1552,7 @@ end if end do - call Drv_AMFI(Label,ipList,OperI,nComp,rHrmt,OperC,iAtmNr2,Charge2) + call Drv_AMFI(Label,OperI,nComp,iAtmNr2,Charge2) call mma_deallocate(iAtmNr2) call mma_deallocate(Charge2) @@ -1573,34 +1573,34 @@ ! Assume symmetric rHrmt = One nComp = 9 - Call Get_nAtoms_All(nAtoms) - Do iCnt = 1, nAtoms - Do jCnt = 1, 2 - if (jCnt.eq.1) then - ! Label for lower triangular portion - Write (Label,'(A,I3)') 'MAGXP', iCnt - Write (PLabel,'(A6)') 'MagInt' + call Get_nAtoms_All(nAtoms) + do iCnt = 1, nAtoms + do jCnt = 1, 2 + if (jCnt == 1) then + ! Label for lower triangular portion + write(Label,'(A,I3)') 'MAGXP',iCnt + write(PLabel,'(A6)') 'MagInt' else - ! Label for upper triangular portion - Write (Label,'(A,I3)') 'MAGPX', iCnt - Write (PLabel,'(A6)') 'MagInt' - endif - Call Allocate_Auxiliary() - ! Dummy symmetry indices + ! Label for upper triangular portion + write(Label,'(A,I3)') 'MAGPX',iCnt + write(PLabel,'(A6)') 'MagInt' + end if + call Allocate_Auxiliary() + ! Dummy symmetry indices do i=1,nComp OperI(i) = 255 OperC(i) = 0 - enddo - ! Zero nuclear contribution - Call dcopy_(nComp,[Zero],0,Nuc,1) - ! Compute one electron integrals - Call OneEl(XTCInt,XTCMem,Label,ipList,OperI,nComp,CoorO,nOrdOp,Nuc,rHrmt,OperC,dum,1,dum,idum,0,0,dum,1,0) - Call Deallocate_Auxiliary() - enddo - enddo + end do + ! Zero nuclear contribution + call dcopy_(nComp,[Zero],0,Nuc,1) + ! Compute one electron integrals + call OneEl(DumInt,DumMem,Label,ipList,OperI,nComp,CoorO,nOrdOp,Nuc,rHrmt,OperC,dum,1,dum,idum,0,0,dum,1,0) + call Deallocate_Auxiliary() + end do + end do # else - Call WarningMessage(2,'Drv1El: NO Gen1int interface available!') - Call Abend() + call WarningMessage(2,'Drv1El: NO Gen1int interface available!') + call Abend() # endif end if ! lMXTC !*********************************************************************** diff -Nru openmolcas-22.02/src/seward/drv_fck.F90 openmolcas-22.10/src/seward/drv_fck.F90 --- openmolcas-22.02/src/seward/drv_fck.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/seward/drv_fck.F90 2022-10-10 14:22:40.000000000 +0000 @@ -85,7 +85,7 @@ ! Will just store the unique elements, i.e. low triangular blocks ! and lower triangular elements in the diagonal blocks. -call ICopy(nComp,[-1],0,ip,1) +ip(:) = -1 LenTot = 0 do iComp=1,nComp LenInt = n2Tri(lOper(iComp)) diff -Nru openmolcas-22.02/src/seward/nemo_opt1.F90 openmolcas-22.10/src/seward/nemo_opt1.F90 --- openmolcas-22.02/src/seward/nemo_opt1.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/seward/nemo_opt1.F90 2022-10-10 14:22:40.000000000 +0000 @@ -131,7 +131,7 @@ ! * ! Close ONEINT and re-open ONEREL -call iCopy(8,nBas,1,nBas_Cont,1) +nBas_Cont(:) = nBas nSym = nIrrep iOpt = 0 diff -Nru openmolcas-22.02/src/seward/output1_seward.F90 openmolcas-22.10/src/seward/output1_seward.F90 --- openmolcas-22.02/src/seward/output1_seward.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/seward/output1_seward.F90 2022-10-10 14:22:40.000000000 +0000 @@ -33,7 +33,7 @@ use DKH_Info, only: BSS, DKroll, iCtrLD, iRELAE, iRELMP, LDKroll, nCtrLD, radiLD use Sizes_of_Seward, only: S use Gateway_Info, only: CutInt, DoFMM, EMFR, FNMC, GIAO, kVector, lAMFI, lMXTC, lRel, RPQMin, ThrInt, Vlct -use RICD_Info, only: iRI_Type, LDF, Do_RI, Cholesky, Do_acCD_Basis, Skip_High_AC, Cho_OneCenter, LocalDF, Do_nacCD_Basis, Thrshld_CD +use RICD_Info, only: iRI_Type, LDF, Do_RI, Cholesky, Do_acCD_Basis, Skip_High_AC, Cho_OneCenter, LocalDF, Thrshld_CD use Symmetry_Info, only: nIrrep use Gateway_global, only: GS_Mode, Onenly, Run_Mode, Prprt, Test use Constants, only: Zero, One, Two, Ten, Pi, Angstrom @@ -280,14 +280,10 @@ else if (iRI_Type == 5) then write(LuWr,'(17X,A)') ' - External RICD auxiliary basis' else - if (Do_nacCD_Basis) then - write(LuWr,'(17X,A)') ' - nacCD auxiliary basis' + if (Do_acCD_Basis) then + write(LuWr,'(17X,A)') ' - acCD auxiliary basis' else - if (Do_acCD_Basis) then - write(LuWr,'(17X,A)') ' - acCD auxiliary basis' - else - write(LuWr,'(17X,A)') ' - aCD auxiliary basis' - end if + write(LuWr,'(17X,A)') ' - aCD auxiliary basis' end if write(LuWr,'(17X,A,G10.2)') ' - CD Threshold: ',Thrshld_CD l_aCD_Thr = .false. diff -Nru openmolcas-22.02/src/single_aniso/restart_check.f openmolcas-22.10/src/single_aniso/restart_check.f --- openmolcas-22.02/src/single_aniso/restart_check.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/single_aniso/restart_check.f 2022-10-10 14:22:40.000000000 +0000 @@ -20,11 +20,11 @@ Integer :: nDir, nDirZee, nMult, i Logical :: Ifrestart Logical :: GRAD - Real :: rdummy + Real(kind=wp) :: rdummy Character(Len=280) :: line, tmp Character(Len=180) :: input_file_name Integer :: ncut,nk,mg - Real :: encut_rate + Real(kind=wp) :: encut_rate Logical :: KeyHEXP,KeyHINT,KeyTMAG, & KeyMVEC,KeyZEEM,KeyNCUT,KeyENCU,KeyERAT c Logical :: KeyREST,KeyTEXP,KeyTINT,KeyMLTP,KeyGRAD,KeyDATA diff -Nru openmolcas-22.02/src/slapaf/rlxctl.f openmolcas-22.10/src/slapaf/rlxctl.f --- openmolcas-22.02/src/slapaf/rlxctl.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/slapaf/rlxctl.f 2022-10-10 14:22:40.000000000 +0000 @@ -1,4 +1,4 @@ -********************************************************************** +************************************************************************ * This file is part of OpenMolcas. * * * * OpenMolcas is free software; you can redistribute it and/or modify * diff -Nru openmolcas-22.02/src/slapaf/rs-rfo.f openmolcas-22.10/src/slapaf/rs-rfo.f --- openmolcas-22.02/src/slapaf/rs-rfo.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/slapaf/rs-rfo.f 2022-10-10 14:22:40.000000000 +0000 @@ -1,4 +1,4 @@ -*********************************************************************** +************************************************************************ * This file is part of OpenMolcas. * * * * OpenMolcas is free software; you can redistribute it and/or modify * diff -Nru openmolcas-22.02/src/slapaf/update_inner.f openmolcas-22.10/src/slapaf/update_inner.f --- openmolcas-22.02/src/slapaf/update_inner.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/slapaf/update_inner.f 2022-10-10 14:22:40.000000000 +0000 @@ -374,17 +374,17 @@ Call mma_allocate(Mult,nBVec**2,Label='Mult') Call mma_allocate(iFlip,nBVec,Label='iFlip') Call mma_allocate(dBVec,nBVec*(3*nsAtom)**2,Label='dBVec') -* * -*********************************************************************** -* * +* * +************************************************************************ +* * * Compute the constraints -* * -*********************************************************************** -* * +* * +************************************************************************ +* * Do lIter = 1, kIter -* * -*********************************************************************** -* * +* * +************************************************************************ +* * Call DefInt2(BVec,dBVec,nBVec,BM,nLambda,nsAtom, & iRow_c,Value,cInt,cInt0,Lbl(nQQ+1), & (lIter.eq.kIter).and.First_MicroIteration, @@ -438,13 +438,13 @@ Call RecPrt('Update_inner: dRdq(1,1,lIter)',' ', & dRdq(1,1,lIter),nQQ,nLambda) #endif -* * -*********************************************************************** -* * +* * +************************************************************************ +* * End Do ! lIter -* * -*********************************************************************** -* * +* * +************************************************************************ +* * Call mma_deallocate(dBVec) Call mma_deallocate(iFlip) Call mma_deallocate(Mult) diff -Nru openmolcas-22.02/src/slapaf_util/ddv.f openmolcas-22.10/src/slapaf_util/ddv.f --- openmolcas-22.02/src/slapaf_util/ddv.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/slapaf_util/ddv.f 2022-10-10 14:22:40.000000000 +0000 @@ -379,8 +379,6 @@ ykl=Cart(2,kAtom)-Cart(2,lAtom) zkl=Cart(3,kAtom)-Cart(3,lAtom) rkl2 = xkl**2 + ykl**2 + zkl**2 - r0=rAv(kr,lr) - alpha=aAv(kr,lr) * If (ddV_Schlegel.or.Help) Then Rab=Sqrt(rkl2) @@ -392,6 +390,8 @@ gmm=Fact*A_Str/(Rab-B_Str(ij))**3 End If Else + r0=rAv(kr,lr) + alpha=aAv(kr,lr) gmm=rkr *Exp(alpha *(r0 **2-rkl2)) If (iAnd(iOptC,1024).eq.1024) Then r0_vdW= r_ref_vdW(kr,lr) @@ -471,8 +471,6 @@ zmi=(Cart(3,iAtom)-Cart(3,mAtom)) rmi2 = xmi**2 + ymi**2 + zmi**2 rmi=sqrt(rmi2) - r0mi=rAv(mr,ir) - ami=aAv(mr,ir) * Do jNeighbor = 1, iNeighbor-1 jAtom=iTabAtoms(1,jNeighbor,mAtom) @@ -487,8 +485,6 @@ zmj=(Cart(3,jAtom)-Cart(3,mAtom)) rmj2 = xmj**2 + ymj**2 + zmj**2 rmj=sqrt(rmj2) - r0mj=rAv(mr,jr) - amj=aAv(mr,jr) * *------------- Test if zero angle * @@ -513,6 +509,10 @@ gij=Fact*A_Bend(2) End If Else + r0mi=rAv(mr,ir) + ami=aAv(mr,ir) + r0mj=rAv(mr,jr) + amj=aAv(mr,jr) gim=exp(ami*(r0mi**2-rmi2)) gjm=exp(amj*(r0mj**2-rmj2)) If (iAnd(iOptC,1024).eq.1024) Then @@ -785,22 +785,16 @@ rij(2)=Cart(2,iAtom)-Cart(2,jAtom) rij(3)=Cart(3,iAtom)-Cart(3,jAtom) rij2=rij(1)**2+rij(2)**2+rij(3)**2 - rij0=rAv(ir,jr)**2 - aij =aAv(ir,jr) * rjk(1)=Cart(1,jAtom)-Cart(1,kAtom) rjk(2)=Cart(2,jAtom)-Cart(2,kAtom) rjk(3)=Cart(3,jAtom)-Cart(3,kAtom) rjk2=rjk(1)**2+rjk(2)**2+rjk(3)**2 - rjk0=rAv(jr,kr)**2 - ajk =aAv(jr,kr) * rkl(1)=Cart(1,kAtom)-Cart(1,lAtom) rkl(2)=Cart(2,kAtom)-Cart(2,lAtom) rkl(3)=Cart(3,kAtom)-Cart(3,lAtom) rkl2=rkl(1)**2+rkl(2)**2+rkl(3)**2 - rkl0=rAv(kr,lr)**2 - akl =aAv(kr,lr) * * Allow only angles in the range of 35-145 A35 = (35.0D0/180.D0)* Pi @@ -829,6 +823,12 @@ If (Diff.lt.Zero) Diff=Zero tij=Fact*A_Trsn(1)+A_Trsn(2)*Diff Else + rij0=rAv(ir,jr)**2 + aij =aAv(ir,jr) + rjk0=rAv(jr,kr)**2 + ajk =aAv(jr,kr) + rkl0=rAv(kr,lr)**2 + akl =aAv(kr,lr) * Magic bond fix rjk2=rjk2/Fact**2 * @@ -1011,20 +1011,14 @@ rij(1)=Cart(1,iAtom)-Cart(1,jAtom) rij(2)=Cart(2,iAtom)-Cart(2,jAtom) rij(3)=Cart(3,iAtom)-Cart(3,jAtom) - rij0=rAv(ir,jr)**2 - aij =aAv(ir,jr) * rik(1)=Cart(1,iAtom)-Cart(1,kAtom) rik(2)=Cart(2,iAtom)-Cart(2,kAtom) rik(3)=Cart(3,iAtom)-Cart(3,kAtom) - rik0=rAv(ir,kr)**2 - aik =aAv(ir,kr) * ril(1)=Cart(1,iAtom)-Cart(1,lAtom) ril(2)=Cart(2,iAtom)-Cart(2,lAtom) ril(3)=Cart(3,iAtom)-Cart(3,lAtom) - ril0=rAv(ir,lr)**2 - ail =aAv(ir,lr) * rij2=rij(1)**2+rij(2)**2+rij(3)**2 rik2=rik(1)**2+rik(2)**2+rik(3)**2 @@ -1054,6 +1048,12 @@ * tij = f_const_Min_ Else + rij0=rAv(ir,jr)**2 + aij =aAv(ir,jr) + rik0=rAv(ir,kr)**2 + aik =aAv(ir,kr) + ril0=rAv(ir,lr)**2 + ail =aAv(ir,lr) beta=rko* & exp( (aij*rij0+aik*rik0+ail*ril0)) tij=beta*exp(-(aij*rij2+aik*rik2+ail*ril2)) diff -Nru openmolcas-22.02/src/slapaf_util/rdctl_slapaf.f openmolcas-22.10/src/slapaf_util/rdctl_slapaf.f --- openmolcas-22.02/src/slapaf_util/rdctl_slapaf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/slapaf_util/rdctl_slapaf.f 2022-10-10 14:22:40.000000000 +0000 @@ -395,7 +395,7 @@ * Introduce supersymmetry * Input format * nsg (number of super groups) -* Reapeat nsg times +* Repeat nsg times * nmem, (ind.., i = 1, nmem) * 911 Char=Get_Ln(LuRd) diff -Nru openmolcas-22.02/src/surfacehop/initial_surfacehop.F90 openmolcas-22.10/src/surfacehop/initial_surfacehop.F90 --- openmolcas-22.02/src/surfacehop/initial_surfacehop.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/surfacehop/initial_surfacehop.F90 2022-10-10 14:22:40.000000000 +0000 @@ -11,7 +11,8 @@ subroutine initial_surfacehop() -use Tully_variables, only: tullyL, decoherence, DECO, Ethreshold, RandThreshold, tullySubVerb, fixedrandL, FixedRand, NSUBSTEPS +use Tully_variables, only: tullyL, decoherence, DECO, Ethreshold, RandThreshold, tullySubVerb, fixedrandL, FixedRand, NSUBSTEPS, & + rassi_ovlp, Run_rassi use Surfacehop_globals, only: lH5Restart use Constants, only: Zero, One, auTofs use Definitions, only: wp, iwp @@ -29,6 +30,8 @@ fixedrandL = .false. FixedRand = -One lH5Restart = .false. +rassi_ovlp = .true. +Run_rassi = .true. call qpg_dscalar('Timestep',Found) if (Found) then diff -Nru openmolcas-22.02/src/surfacehop/rdinp_surfacehop.F90 openmolcas-22.10/src/surfacehop/rdinp_surfacehop.F90 --- openmolcas-22.02/src/surfacehop/rdinp_surfacehop.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/surfacehop/rdinp_surfacehop.F90 2022-10-10 14:22:40.000000000 +0000 @@ -12,7 +12,7 @@ subroutine rdinp_surfacehop() use Tully_variables, only: tullyL, DECO, decoherence, NSUBSTEPS, Ethreshold, RandThreshold, fixedrandL, FixedRand, InitSeed, & - iseedL, tullySubVerb + iseedL, tullySubVerb, rassi_ovlp, Run_rassi #ifdef _HDF5_ use Surfacehop_globals, only: lH5Restart, File_H5Res #endif @@ -99,6 +99,9 @@ call Get_I1(1,maxHop) call Put_iScalar('MaxHopsTully',maxHop) !write(u6,*) 'MaxHops set to ', maxHop + case ('NORA') + rassi_ovlp = .false. + Run_rassi = .false. case ('H5RE') # ifdef _HDF5_ lH5Restart = .true. diff -Nru openmolcas-22.02/src/surfacehop/restart_surfacehop.F90 openmolcas-22.10/src/surfacehop/restart_surfacehop.F90 --- openmolcas-22.02/src/surfacehop/restart_surfacehop.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/surfacehop/restart_surfacehop.F90 2022-10-10 14:22:40.000000000 +0000 @@ -25,7 +25,7 @@ character(len=128) :: sFile logical(kind=iwp) :: Exists real(kind=wp) :: dt -real(kind=wp), allocatable :: ener(:), ciarray(:), real_amatrix(:), imag_amatrix(:) +real(kind=wp), allocatable :: ener(:), ciarray(:), real_amatrix(:), imag_amatrix(:), overlap_save(:) complex(kind=wp), allocatable :: amatrix(:) write(u6,'(A)') 'Restarting surfacehop from h5 file',file_h5res @@ -75,33 +75,41 @@ end if ! read relax root number and save in RunFile -call mh5_fetch_dset(restart_fileid,'Relax CAS root',i) +call mh5_fetch_dset(restart_fileid,'RELAX CAS ROOT',i) call Put_iScalar('Relax CASSCF root',i) ! read the energies of the previous step and save in RunFile call mma_allocate(ener,nstates) -call mh5_fetch_dset(restart_fileid,'Energ Prev',ener) +call mh5_fetch_dset(restart_fileid,'ENERG PREV',ener) call Put_darray('VenergyP',ener,nstates) call mma_deallocate(ener) ! read the CI arrays of the previous step and save in RunFile call mma_allocate(ciarray,nstates*nconfs) -call mh5_fetch_dset(restart_fileid,'CI Prev',ciarray) +call mh5_fetch_dset(restart_fileid,'CI PREV',ciarray) call Put_darray('AllCIP',ciarray,nstates*nconfs) call mma_deallocate(ciarray) ! read the CI arrays of the step before the previous step and save in RunFile call mma_allocate(ciarray,nstates*nconfs) -call mh5_fetch_dset(restart_fileid,'CI PPrev',ciarray) +call mh5_fetch_dset(restart_fileid,'CI PPREV',ciarray) call Put_darray('AllCIPP',ciarray,nstates*nconfs) call mma_deallocate(ciarray) +! read <t-2dt|t-dt> overlap if exists and save in RunFile +if (mh5_exists_dset(restart_fileid,'RASSI_SAVE_OVLP')) then + call mma_allocate(overlap_save,nstates*nstates) + call mh5_fetch_dset(restart_fileid,'RASSI_SAVE_OVLP',overlap_save) + call Put_darray('SH_Ovlp_Save',overlap_save,nstates*nstates) + call mma_deallocate(overlap_save) +end if + ! read the AmatrixV and save in RunFile call mma_allocate(real_amatrix,nstates*nstates) call mma_allocate(imag_amatrix,nstates*nstates) call mma_allocate(amatrix,nstates*nstates) -call mh5_fetch_dset(restart_fileid,'AmatrixV-R',real_amatrix) -call mh5_fetch_dset(restart_fileid,'AmatrixV-I',imag_amatrix) +call mh5_fetch_dset(restart_fileid,'AMATRIXV-R',real_amatrix) +call mh5_fetch_dset(restart_fileid,'AMATRIXV-I',imag_amatrix) amatrix(:) = cmplx(real_amatrix,imag_amatrix,kind=wp) call Put_zarray('AmatrixV',amatrix,nstates*nstates) call mma_deallocate(amatrix) diff -Nru openmolcas-22.02/src/surfacehop/surfacehop.F90 openmolcas-22.10/src/surfacehop/surfacehop.F90 --- openmolcas-22.02/src/surfacehop/surfacehop.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/surfacehop/surfacehop.F90 2022-10-10 14:22:40.000000000 +0000 @@ -11,20 +11,31 @@ ! Copyright (C) 2015, Luis Manuel Frutos * ! 2015, Ignacio Fdez. Galvan * ! 2015, Alessio Valentini * +! 2022, Isabella C. D. Merritt * +! 2022, Morgane Vacher * !*********************************************************************** +! Modifications to calculate Wave-function Overlap using &RASSI carried out by IM +! and MV 2022 + subroutine surfacehop(rc) +use Tully_variables, only: rassi_ovlp, firststep, Run_rassi use stdalloc, only: mma_allocate, mma_deallocate use Constants, only: Zero -use Definitions, only: wp, iwp +use Definitions, only: wp, iwp, u6 implicit none integer(kind=iwp), intent(out) :: rc #include "warnings.h" -integer(kind=iwp) :: NSTATE, LUIPH, IAD, ITOC15(15), NCI, IDISK, I +integer(kind=iwp) :: NSTATE, LUIPH, IAD, ITOC15(15), NCI, IDISK, I, LuInput, LuSpool, istatus +logical(kind=iwp) :: Exists +character(len=180) :: Line +character(len=128) :: FileName +character(len=16) :: StdIn real(kind=wp), allocatable :: CIBigArray(:) +integer(kind=iwp), external :: IsFreeUnit call initial_surfacehop() call rdinp_surfacehop() @@ -45,10 +56,91 @@ !call recprt('CI coefficients','',CIBigArray,NCI,NSTATE) +! If using CI vector product, only run tully once and quit +if (.not. rassi_ovlp) then + call tully(CIBigArray,NSTATE,NCI) + call mma_deallocate(CIBigArray) + rc = _RC_ALL_IS_WELL_ + return +end if + +! Otherwise using RASSI for WF overlap + call tully(CIBigArray,NSTATE,NCI) +if (.not. Run_rassi) then ! RASSI Already Run + call mma_deallocate(CIBigArray) + rc = _RC_ALL_IS_WELL_ + return +end if + +! Else if tully has set Run_rassi as True, continue to run RASSI + +! If first step, cannot do overlap - just save JobIph as JobOld and return + +if (firststep) then + write(u6,*) 'First Step' + LuInput = 11 + LuInput = IsFreeUnit(LuInput) + write(u6,*) 'Saving old JobIPH' + call StdIn_Name(StdIn) + call Molcas_Open(LuInput,StdIn) + write(LuInput,'(A)') ' >copy $Project.JobIph $Project.JobIph.Old' + close(LuInput) + call mma_deallocate(CIBigArray) + rc = _RC_INVOKED_OTHER_MODULE_ + return +end if + +! Otherwise, Call RASSI then rerun SURFACEHOP with same input options (check +! within tully.f90 if RASSI run yet or not) +! Call RASSI between .JobIph and .JobOld + +LuInput = 11 +LuInput = IsFreeUnit(LuInput) +!write(u6,*) 'Calling RASSI then re-entering SURFACEHOP' + +call StdIn_Name(StdIn) +call Molcas_Open(LuInput,StdIn) + +write(LuInput,'(A)') '>copy $Project.JobIph.Old JOB001' +write(LuInput,'(A)') '>copy $Project.JobIph JOB002' + +write(LuInput,'(A)') '&RASSI &End' +write(LuInput,'(A)') 'Nr of JobIPhs' +write(LuInput,'(A)') '2 all' +write(LuInput,'(A)') 'STOV' +write(LuInput,'(A)') 'End of Input' +write(LuInput,'(A)') '> copy $Project.JobIph $Project.JobIph.Old' + +FileName = 'SURFAINP' +call f_inquire(FileName,Exists) + +if (Exists) then + LuSpool = 77 + LuSpool = IsFreeUnit(LuSpool) + call Molcas_Open(LuSpool,FileName) + + do + read(LuSpool,'(A)',iostat=istatus) Line + if (istatus > 0) call Abend() + if (istatus < 0) exit + write(LuInput,'(A)') Line + end do + close(LuSpool) +else + rc = _RC_INTERNAL_ERROR_ + call mma_deallocate(CIBigArray) + close(LuInput) + return +end if + +write(LuInput,'(A)') '' +close(LuInput) + call mma_deallocate(CIBigArray) -rc = _RC_ALL_IS_WELL_ + +rc = _RC_INVOKED_OTHER_MODULE_ return diff -Nru openmolcas-22.02/src/surfacehop/tully.F90 openmolcas-22.10/src/surfacehop/tully.F90 --- openmolcas-22.02/src/surfacehop/tully.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/surfacehop/tully.F90 2022-10-10 14:22:40.000000000 +0000 @@ -12,7 +12,7 @@ subroutine Tully(CIBigArray,NSTATE,NCI) use Tully_variables, only: decoherence, tullySubVerb, fixedrandL, iseedL, DECO, Ethreshold, RandThreshold, FixedRand, NSUBSTEPS, & - InitSeed + InitSeed, rassi_ovlp, Run_rassi, firststep #ifdef _HDF5_ use Surfacehop_globals, only: lH5Restart #endif @@ -22,16 +22,18 @@ implicit none integer(kind=iwp), intent(in) :: NSTATE, NCI real(kind=wp), intent(inout) :: CIBigArray(NCI*NSTATE) +#include "warnings.h" integer :: values(8) ! note default integer kind for date_and_time call character(len=8) :: date character(len=10) :: time character(len=5) :: zone logical(kind=iwp) :: HOPPED, normalTully, found, lmaxHop, lnhop -integer(kind=iwp) :: maxhop, nhop +integer(kind=iwp) :: maxhop, nhop, RASSI_time_run real(kind=wp) :: DT, LO, EKIN, TAU(NSTATE) -real(kind=wp) :: CIBigArrayP(NCI*NSTATE) -real(kind=wp) :: CIBigArrayPP(NCI*NSTATE), Etot, ediffcheck +real(kind=wp) :: CIBigArrayP(NCI*NSTATE), readOVLP(NSTATE*2*NSTATE*2) +real(kind=wp) :: CIBigArrayPP(NCI*NSTATE), Etot, ediffcheck, currOVLP_ras(NSTATE,NSTATE), currOVLP_ras_2(NSTATE,NSTATE) +real(kind=wp) :: currOVLP(NSTATE,NSTATE), prevOVLP(NSTATE,NSTATE), saveOVLP(NSTATE,NSTATE) real(kind=wp) :: Dmatrix(NSTATE,NSTATE), sp(NSTATE,NSTATE) real(kind=wp) :: D32matrix(NSTATE,NSTATE), D12matrix(NSTATE,NSTATE) real(kind=wp) :: ExtrSlope(NSTATE,NSTATE), ExtrInter(NSTATE,NSTATE) @@ -39,9 +41,9 @@ real(kind=wp) :: tempVector2(NSTATE), VenergyInter(NSTATE) real(kind=wp) :: V(NSTATE,NSTATE), Bmatrix(NSTATE,NSTATE) real(kind=wp) :: Gprobab(NSTATE), Popul(NSTATE) -real(kind=wp) :: VenergyP(NSTATE), Venergy(NSTATE), temp +real(kind=wp) :: VenergyP(NSTATE), Venergy(NSTATE), temp, root_ovlp real(kind=wp) :: SumProb, scalarprod, prod, populOS -integer(kind=iwp) :: k, l, j, i, ii, jjj +integer(kind=iwp) :: k, l, j, i, ii, jjj, t, tt, o, root_ovlp_el integer(kind=iwp) :: rightOrder(NSTATE), decVec(NSTATE) integer(kind=iwp) :: nstatesq, nciquery, stateRi, temproot, nsatom integer(kind=iwp) :: ISTATE2, iseed, irlxroot @@ -58,6 +60,14 @@ write(u6,*) '------------------------------------------' write(u6,*) '' +if (rassi_ovlp) then + write(u6,*) 'Using RASSI for WF overlap' + write(u6,*) '' +else + write(u6,*) 'Using CI vector product for WF overlap' + write(u6,*) '' +end if + call get_darray('Last energies',Venergy,NSTATE) call Get_iScalar('Relax CASSCF root',iRlxRoot) @@ -73,6 +83,10 @@ if (.not. Found .and. lH5Restart) then call restart_surfacehop() Found = .true. + call Get_iScalar('Relax CASSCF root',iRlxRoot) + call Put_iScalar('NumGradRoot',iRlxRoot) + call Put_iScalar('Relax Original root',iRlxRoot) + call Put_dScalar('Last energy',Venergy(iRlxRoot)) end if #endif @@ -101,12 +115,60 @@ end do write(u6,*) 'Gnuplot:',(Popul(j),j=1,NSTATE,1),(Venergy(j),j=1,NSTATE,1),Venergy(iRlxRoot) write(u6,*) 'Cannot do deltas at first step, see you later! ' + firststep = .true. return else + firststep = .false. call Get_dArray('AllCIP',CIBigArrayP,NCI*NSTATE) call Get_dArray('VenergyP',VenergyP,NSTATE) end if +! Check if overlap exists and if RASSI is run yet for this timestep + +if (rassi_ovlp) then + call Qpg_iscalar('SH RASSI run',Found) + !write(u6,*) 'Has RASSI ever been run?', Found + if (.not. Found) then ! RASSI never run before (step 2) or restart + Run_rassi = .true. + else + call get_iscalar('SH RASSI run',RASSI_time_run) + !write(u6,*) 'RASSI_time_run variable = ',RASSI_time_run + if (RASSI_time_run == 0) then ! Need to run RASSI for this timestep still + Run_rassi = .true. + else if (RASSI_time_run == 1) then + Run_rassi = .false. ! RASSI already run for this timestep + else + write(u6,*) 'Problem checking if RASSI previously run' + call Abend() + end if + end if + + ! return to call RASSI in surfacehop.f90 if not yet run + + if (Run_rassi) then + write(u6,*) 'Calling RASSI...' + RASSI_time_run = 1 + call put_iscalar('SH RASSI run',RASSI_time_run) + return + else + write(u6,*) 'RASSI already called, continuing...' + RASSI_time_run = 0 ! Reset for next iteration + call put_iscalar('SH RASSI run',RASSI_time_run) + write(u6,*) '' + call get_dArray('State Overlaps',readOVLP,NSTATE*2*NSTATE*2) + !do i=1,NSTATE**4 + ! write(u6,*) readOVLP(i) + !end do + do t=1,NSTATE + do tt=1,NSTATE + o = ((2*t-1)*NSTATE)+tt + currOVLP_ras(tt,t) = readOVLP(o) ! Transpose to match RASSI printed version + currOVLP_ras_2(tt,t) = readOVLP(o) ! Make extra copy for root flipping correction + end do + end do + end if +end if + ! now check for the CI coefficients at Pre-Pre-Step (PP) call Qpg_dArray('AllCIPP',Found,nCiQuery) @@ -119,6 +181,16 @@ else normalTully = .false. call Get_dArray('AllCIPP',CIBigArrayPP,NCI*NSTATE) + if (rassi_ovlp) then + write(u6,*) 'Grabbing previous overlap <t-2dt|t-dt>' + call Get_dArray('SH_Ovlp_save',prevOVLP,NSTATE*NSTATE) + write(u6,*) '' + write(u6,*) '<t-2dt|t-dt> RASSI Overlap' + do i=1,NSTATE + write(u6,*) (prevOVLP(i,j),j=1,NSTATE,1) + end do + write(u6,*) '' + end if end if call Get_dScalar('MD_Etot',Etot) @@ -129,14 +201,19 @@ write(u6,*) (Amatrix(i,j),j=1,NSTATE,1) end do -! Timestep: DT -! Total Energy Etot -! Coefficients: CIBigArray(i) length = NCI*NSTATE -! Prev step coefficients: CIBigArrayP(i) length = NCI*NSTATE -! Prev-Prev coefficients: CIBigArrayPP(i) length = NCI*NSTATE -! V energy: Venergy(i) length = NSTATE -! V Prev step energy: VenergyP(i) length = NSTATE -! MatriX A: Amatrix(i,j) length = NSTATE*NSTATE +! Timestep: DT +! Total Energy Etot +! Coefficients: CIBigArray(i) length = NCI*NSTATE +! Prev step coefficients: CIBigArrayP(i) length = NCI*NSTATE +! Prev-Prev coefficients: CIBigArrayPP(i) length = NCI*NSTATE +! V energy: Venergy(i) length = NSTATE +! V Prev step energy: VenergyP(i) length = NSTATE +! MatriX A: Amatrix(i,j) length = NSTATE*NSTATE +! IF RASSI +! Overlap <t-dt|t> uncorrected currOVLP_ras length = NSTATE*NSTATE +! Overlap <t-dt|t> uncorr (copy) currOVLP_ras_2 length = NSTATE*NSTATE +! Overlap <t-dt|t> currOVLP length = NSTATE*NSTATE +! Overlap <t-2dt|t-dt> prevOVLP length = NSTATE*NSTATE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! @@ -146,63 +223,162 @@ ! so first of all I create 2 temp vectors that store the absolute value ! of the energy difference -do i=1,NSTATE - tempVector(i) = abs(Venergy(i)-Venergy(irlxRoot)) - tempVector2(i) = abs(Venergy(i)-Venergy(irlxRoot)) -end do +if (.not. rassi_ovlp) then + ! Original sign corrector/root reordering using CI vector product + write(u6,*) 'Using CI vector products for sign correction/root ordering' + do i=1,NSTATE + tempVector(i) = abs(Venergy(i)-Venergy(irlxRoot)) + tempVector2(i) = abs(Venergy(i)-Venergy(irlxRoot)) + end do + + ! then I sort one of them, (relaxroot becomes first, it's zero) + + do j=1,(NSTATE-1) + do k=(j+1),NSTATE + if (tempVector(j) > tempVector(k)) then + temp = tempVector(j) + tempVector(j) = tempVector(k) + tempVector(k) = temp + end if + end do + end do + + ! I get the right order I need to process roots -! then I sort one of them, (relaxroot becomes first, it's zero) + do i=1,NSTATE + do j=1,NSTATE + if (tempVector(i) == tempVector2(j)) then + rightOrder(i) = j + end if + end do + end do + ! ii counter on CURRENT STEP + do ii=1,NSTATE + do i=1,NSTATE + scalarprod = Zero + do j=1,NCI + scalarprod = scalarprod+CIBigArray(NCI*(ii-1)+j)*CIBigArrayP(NCI*(i-1)+j) + end do + sp(ii,i) = scalarprod + end do + decVec(ii) = 1 + end do -do j=1,(NSTATE-1) - do k=(j+1),NSTATE - if (tempVector(j) > tempVector(k)) then - temp = tempVector(j) - tempVector(j) = tempVector(k) - tempVector(k) = temp + do ii=1,NSTATE + stateRi = rightOrder(ii) + prod = Zero + jjj = 0 + do i=1,NSTATE + if (decVec(i) == 1) then + if (abs(sp(stateRi,i)) > abs(prod)) then + prod = sp(stateRi,i) + jjj = i + end if + end if + end do + decVec(jjj) = 0 + if (prod < 0) then + do k=1,NCI + CIBigArray(NCI*(stateRi-1)+k) = -CIBigArray(NCI*(stateRi-1)+k) + end do end if end do -end do -! I get the right order I need to process roots +else -do i=1,NSTATE - do j=1,NSTATE - if (tempVector(i) == tempVector2(j)) then - rightOrder(i) = j + ! Sign correction and root reordering using RASSI overlap matrix <t-dt|t> + ! currOVLP has sign/root correction applied so |t> is changed - to match with prevOVLP + ! saveOVLP has sign/root correction applied so <t-dt| is changed - to match with next timesteps calculated overlap + write(u6,*) '' + write(u6,*) 'Using RASSI overlap matrix for sign correction/root ordering' + + ! For current Overlap (swapping rows) + + ! Root flipping + + do i=1,NSTATE + root_ovlp = abs(currOVLP_ras(i,i)) ! Diagonal element + root_ovlp_el = i + do j=i,NSTATE + if (abs(currOVLP_ras(j,i)) > root_ovlp) then + root_ovlp_el = j + root_ovlp = abs(currOVLP_ras(j,i)) + end if + end do + if (root_ovlp < 0.4) then + write(u6,*) 'WARNING: No overlap greater than 0.4 for root:',i + end if + if (root_ovlp_el /= i) then + write(u6,*) 'Root rotation detected' + do ii=1,NSTATE + currOVLP(i,ii) = currOVLP_ras(root_ovlp_el,ii) + currOVLP_ras(root_ovlp_el,ii) = currOVLP_ras(i,ii) + currOVLP_ras(i,ii) = currOVLP(i,ii) + end do + else + do ii=1,NSTATE + currOVLP(i,ii) = currOVLP_ras(i,ii) + end do end if end do -end do -! ii counter on CURRENT STEP -do ii=1,NSTATE + + ! Sign correction do i=1,NSTATE - scalarprod = Zero - do j=1,NCI - scalarprod = scalarprod+CIBigArray(NCI*(ii-1)+j)*CIBigArrayP(NCI*(i-1)+j) - end do - sp(ii,i) = scalarprod + if (currOVLP(i,i) < 0) then + write(u6,*) 'Correcting sign for root',i + do ii=1,NSTATE + currOVLP(i,ii) = -currOVLP(i,ii) + end do + end if end do - decVec(ii) = 1 -end do -do ii=1,NSTATE - stateRi = rightOrder(ii) - prod = Zero - jjj = 0 - do i=1,NSTATE - if (decVec(i) == 1) then - if (abs(sp(stateRi,i)) > abs(prod)) then - prod = sp(stateRi,i) - jjj = i + write(u6,*) '' + write(u6,*) 'Corrected <t-dt|t> RASSI Overlap' + do i=1,NSTATE + write(u6,*) (currOVLP(i,j),j=1,NSTATE,1) + end do + write(u6,*) '' + + ! For save Overlap (swapping columns) + + ! Root flipping + + do i=1,NSTATE + root_ovlp = abs(currOVLP_ras_2(i,i)) ! Diagonal element + root_ovlp_el = i + do j=i,NSTATE + if (abs(currOVLP_ras_2(i,j)) > root_ovlp) then + root_ovlp_el = j + root_ovlp = abs(currOVLP_ras_2(i,j)) end if + end do + !if (root_ovlp < 0.4_wp) then + ! write(u6,*) 'WARNING: No overlap greater than 0.4 for root:', i + !end if + if (root_ovlp_el /= i) then + !write(u6,*) 'Root rotation detected' + do ii=1,NSTATE + saveOVLP(ii,i) = currOVLP_ras_2(ii,root_ovlp_el) + currOVLP_ras_2(ii,root_ovlp_el) = currOVLP_ras_2(ii,i) + currOVLP_ras_2(ii,i) = saveOVLP(ii,i) + end do + else + do ii=1,NSTATE + saveOVLP(ii,i) = currOVLP_ras_2(ii,i) + end do end if end do - decVec(jjj) = 0 - if (prod < 0) then - do k=1,NCI - CIBigArray(NCI*(stateRi-1)+k) = -CIBigArray(NCI*(stateRi-1)+k) - end do - end if -end do + + ! Sign correction + do i=1,NSTATE + if (saveOVLP(i,i) < 0) then + do ii=1,NSTATE + saveOVLP(ii,i) = -saveOVLP(ii,i) + end do + end if + end do + +end if ! ! ! end of sign corrector ! ! ! @@ -216,19 +392,35 @@ write(u6,*) 'Executing Normal Tully !!' write(u6,*) '' - do i=1,NSTATE - do j=1,NSTATE - if (i /= j) then - Dmatrix(i,j) = Zero - do ii=1,NCI - Dmatrix(i,j) = Dmatrix(i,j)+CIBigArray(NCI*(i-1)+ii)*CIBigArrayP(NCI*(j-1)+ii) - end do - Dmatrix(i,j) = -Dmatrix(i,j)/DT - else - Dmatrix(i,i) = Zero - end if + if (.not. rassi_ovlp) then + write(u6,*) 'Using CI vector product to calculate D matrix' + do i=1,NSTATE + do j=1,NSTATE + if (i /= j) then + Dmatrix(i,j) = Zero + do ii=1,NCI + Dmatrix(i,j) = Dmatrix(i,j)+CIBigArray(NCI*(i-1)+ii)*CIBigArrayP(NCI*(j-1)+ii) + end do + Dmatrix(i,j) = -Dmatrix(i,j)/DT + else + Dmatrix(i,i) = Zero + end if + end do end do - end do + else + write(u6,*) 'Using RASSI overlap to calculate D matrix' + do i=1,NSTATE + do j=1,NSTATE + if (i /= j) then + Dmatrix(i,j) = -currOVLP(i,j)/DT + else + Dmatrix(i,i) = Zero + end if + end do + end do + !write(u6,*) 'NOT YET IMPLEMENTED' + end if + normalTully = .false. do i=1,NSTATE @@ -245,38 +437,67 @@ ! Create D matrix according to Hammes-Schiffer-Tully (interpolating extrapolating) ! D32matrix + if (.not. rassi_ovlp) then + write(u6,*) 'Using CI vector product to calculate D Matrix' + do i=1,NSTATE + do j=1,NSTATE + if (i /= j) then + D32matrix(i,j) = Zero + do ii=1,NCI + D32matrix(i,j) = D32matrix(i,j)+CIBigArrayPP(NCI*(i-1)+ii)*CIBigArrayP(NCI*(j-1)+ii) + D32matrix(i,j) = D32matrix(i,j)-CIBigArrayP(NCI*(i-1)+ii)*CIBigArrayPP(NCI*(j-1)+ii) + end do + D32matrix(i,j) = D32matrix(i,j)/(2*DT) + else + D32matrix(i,i) = Zero + end if + end do + end do - do i=1,NSTATE - do j=1,NSTATE - if (i /= j) then - D32matrix(i,j) = Zero - do ii=1,NCI - D32matrix(i,j) = D32matrix(i,j)+CIBigArrayPP(NCI*(i-1)+ii)*CIBigArrayP(NCI*(j-1)+ii) - D32matrix(i,j) = D32matrix(i,j)-CIBigArrayP(NCI*(i-1)+ii)*CIBigArrayPP(NCI*(j-1)+ii) - end do - D32matrix(i,j) = D32matrix(i,j)/(2*DT) - else - D32matrix(i,i) = Zero - end if + ! D12matrix + + do i=1,NSTATE + do j=1,NSTATE + if (i /= j) then + D12matrix(i,j) = Zero + do ii=1,NCI + D12matrix(i,j) = D12matrix(i,j)+CIBigArrayP(NCI*(i-1)+ii)*CIBigArray(NCI*(j-1)+ii) + D12matrix(i,j) = D12matrix(i,j)-CIBigArray(NCI*(i-1)+ii)*CIBigArrayP(NCI*(j-1)+ii) + end do + D12matrix(i,j) = D12matrix(i,j)/(2*DT) + else + D12matrix(i,i) = Zero + end if + end do end do - end do - ! D12matrix + else ! RASSI overlaps - do i=1,NSTATE - do j=1,NSTATE - if (i /= j) then - D12matrix(i,j) = Zero - do ii=1,NCI - D12matrix(i,j) = D12matrix(i,j)+CIBigArrayP(NCI*(i-1)+ii)*CIBigArray(NCI*(j-1)+ii) - D12matrix(i,j) = D12matrix(i,j)-CIBigArray(NCI*(i-1)+ii)*CIBigArrayP(NCI*(j-1)+ii) - end do - D12matrix(i,j) = D12matrix(i,j)/(2*DT) - else - D12matrix(i,i) = Zero - end if + write(u6,*) 'Using RASSI overlap to calculate D matrix' + + ! D32matrix + do i=1,NSTATE + do j=1,NSTATE + if (i /= j) then + D32matrix(i,j) = (prevOVLP(i,j)-prevOVLP(j,i))/(2*DT) + else + D32matrix(i,j) = Zero + end if + end do + end do + + ! D12matrix + do i=1,NSTATE + do j=1,NSTATE + if (i /= j) then + D12matrix(i,j) = (currOVLP(i,j)-currOVLP(j,i))/(2*DT) + else + D12matrix(i,j) = Zero + end if + end do end do - end do + + end if ! definition of Y intercept (ExtrInter) and slope (ExtrSlope) for EXTRapolation line @@ -293,13 +514,13 @@ ! UNCOMMENT to print coefficients !!! ! Just a few coefficients -write(u6,*) 'WaveFunctionsCoefficients are: ',NCI,'*',NSTATE -write(u6,*) ' This step Previous step: PP:' +! write(u6,*) 'WaveFunctionsCoefficients are: ',NCI,'*',NSTATE +! write(u6,*) ' This step Previous step: PP:' -write(u6,*) CIBigArray(1),CIBigArrayP(1),CIBigArrayPP(1) -write(u6,*) CIBigArray(2),CIBigArrayP(2),CIBigArrayPP(2) -write(u6,*) CIBigArray(3),CIBigArrayP(3),CIBigArrayPP(3) -write(u6,*) CIBigArray(4),CIBigArrayP(4),CIBigArrayPP(4) +! write(u6,*) CIBigArray(1),CIBigArrayP(1),CIBigArrayPP(1) +! write(u6,*) CIBigArray(2),CIBigArrayP(2),CIBigArrayPP(2) +! write(u6,*) CIBigArray(3),CIBigArrayP(3),CIBigArrayPP(3) +! write(u6,*) CIBigArray(4),CIBigArrayP(4),CIBigArrayPP(4) ! All coefficients !do i=1,NCI*NSTATE @@ -327,8 +548,8 @@ iseed = InitSeed ! initial seed read from input write(u6,*) 'Seed number read from input file: ',iseed end if - ! or generate a new random seed number else + ! or generate a new random seed number call date_and_time(date,time,zone,values) ! Just milliseconds multiplied by seconds iseed = ((values(7)+1)*values(8)+1) @@ -515,6 +736,8 @@ write(u6,*) 'Gnuplot:',(Popul(j),j=1,NSTATE,1),(Venergy(j),j=1,NSTATE,1),Venergy(temproot) !write(u6,*) 'Gnuplot:',(Popul(j),j=1,NSTATE,1),(V(j,j),j=1,NSTATE,1),V(temproot,temproot) +!write(u6,*) 'CASSCF rlxrt', iRlxRoot + if (temproot == iRlxRoot) then HOPPED = .false. else @@ -565,27 +788,27 @@ ! scale velocities ! -! call get_dArray('Velocities',vel,nsAtom*3) +!call get_dArray('Velocities',vel,nsAtom*3) ! -! write(u6,*) 'Velocities before Hop:' -! do i=1,nsAtom -! write(u6,*) vel(i*3-2),vel(i*3-1),vel(i*3) -! end do -! EKIN=Etot-Venergy(iRlxRoot) -! EKIN_target=Etot-Venergy(temproot) -! scalfac=sqrt(Ekin_target/Ekin) -! write(u6,*) Etot,Venergy(iRlxRoot),Venergy(temproot),EKIN,EKIN_target,scalfac -! do i=1,nsAtom -! do j=1,3 -! vel(3*(i-1)+j)=scalfac*vel(3*(i-1)+j) -! end do -! end do -! write(u6,*) 'Velocities after Hop:' -! do i=1,nsAtom -! write(u6,*) vel(i*3-2),vel(i*3-1),vel(i*3) +!write(u6,*) 'Velocities before Hop:' +!do i=1,nsAtom +! write(u6,*) vel(i*3-2),vel(i*3-1),vel(i*3) +!end do +!EKIN = Etot-Venergy(iRlxRoot) +!EKIN_target = Etot-Venergy(temproot) +!scalfac = sqrt(Ekin_target/Ekin) +!write(u6,*) Etot,Venergy(iRlxRoot),Venergy(temproot),EKIN,EKIN_target,scalfac +!do i=1,nsAtom +! do j=1,3 +! vel(3*(i-1)+j) = scalfac*vel(3*(i-1)+j) ! end do +!end do +!write(u6,*) 'Velocities after Hop:' +!do i=1,nsAtom +! write(u6,*) vel(i*3-2),vel(i*3-1),vel(i*3) +!end do ! -! call put_dArray('Velocities',vel,nsAtom*3) +!call put_dArray('Velocities',vel,nsAtom*3) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! @@ -598,6 +821,9 @@ call Put_dArray('AllCIP',CIBigArray,NCI*NSTATE) call put_zarray('AmatrixV',Amatrix,NSTATE*NSTATE) +if (rassi_ovlp) then + call Put_dArray('SH_Ovlp_Save',saveOVLP,NSTATE*NSTATE) +end if ! ! ! END SAVING ! ! ! diff -Nru openmolcas-22.02/src/surfacehop/tully_variables.F90 openmolcas-22.10/src/surfacehop/tully_variables.F90 --- openmolcas-22.02/src/surfacehop/tully_variables.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/surfacehop/tully_variables.F90 2022-10-10 14:22:40.000000000 +0000 @@ -16,10 +16,11 @@ implicit none private -logical(kind=iwp) :: tullyL, decoherence, tullySubVerb, fixedrandL, iseedL +logical(kind=iwp) :: tullyL, decoherence, tullySubVerb, fixedrandL, iseedL, rassi_ovlp, Run_rassi, firststep real(kind=wp) :: DECO, Ethreshold, RandThreshold, FixedRand integer(kind=iwp) :: NSUBSTEPS, InitSeed -public :: tullyL, decoherence, tullySubVerb, fixedrandL, iseedL, DECO, Ethreshold, RandThreshold, FixedRand, NSUBSTEPS, InitSeed +public :: tullyL, decoherence, tullySubVerb, fixedrandL, iseedL, DECO, Ethreshold, RandThreshold, FixedRand, NSUBSTEPS, InitSeed, & + rassi_ovlp, Run_rassi, firststep end module diff -Nru openmolcas-22.02/src/system_util/CMakeLists.txt openmolcas-22.10/src/system_util/CMakeLists.txt --- openmolcas-22.02/src/system_util/CMakeLists.txt 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/system_util/CMakeLists.txt 2022-10-10 14:22:40.000000000 +0000 @@ -20,7 +20,8 @@ constants.F90 cwtime.F90 data_structures.F90 - datimx.c + datimx.F90 + datimxc.c definitions.F90 filesystem.F90 finish.F90 diff -Nru openmolcas-22.02/src/system_util/constants.F90 openmolcas-22.10/src/system_util/constants.F90 --- openmolcas-22.02/src/system_util/constants.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/system_util/constants.F90 2022-10-10 14:22:40.000000000 +0000 @@ -18,11 +18,11 @@ #include "real.fh" public :: Zero, One, Two, Three, Four, Five, Six, Seven, Eight, Nine, Ten, Eleven, Twelve -public :: Half, Quart, OneHalf, Pi, SqrtP2, TwoP34, TwoP54, One2C2 +public :: Half, Quart, OneHalf, Pi, SqrtP2, TwoP34, TwoP54 #include "constants2.fh" public :: diel, deg2rad, UTOAU, elmass, ATOKG, elcharge, rNAVO, cLight, auTocm, rPlanck, kBoltzmann, rBohr, cm_s, Debye, Angstrom, & - RF, auToHz, auTofs, auToN, auToeV, auTokJ, auTokcalmol, c_in_au, cal_to_J, Rgas, mu2elmass + RF, auToHz, auTofs, auToN, auToeV, auTokJ, auTokcalmol, c_in_au, cal_to_J, Rgas, mu2elmass, atmToau complex(kind=wp), parameter :: cZero = (Zero,Zero), cOne = (One,Zero), Onei = (Zero,One) diff -Nru openmolcas-22.02/src/system_util/data_structures.F90 openmolcas-22.10/src/system_util/data_structures.F90 --- openmolcas-22.02/src/system_util/data_structures.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/system_util/data_structures.F90 2022-10-10 14:22:40.000000000 +0000 @@ -25,8 +25,8 @@ implicit none private -public :: Alloc1DArray_Type, Alloc2DArray_Type, Allocate_DT, Deallocate_DT, DSBA_Type, G2_Type, Integer_Pointer, L_Full_Type, & - Lab_Type, NDSBA_Type, SBA_Type, twxy_Type +public :: Alloc1DiArray_Type, Alloc1DArray_Type, Alloc2DArray_Type, Allocate_DT, Deallocate_DT, DSBA_Type, G2_Type, & + Integer_Pointer, L_Full_Type, Lab_Type, NDSBA_Type, SBA_Type, twxy_Type, V1, V2 ! temporary subroutines for interface with old code public :: Map_to_DSBA, Map_to_SBA, Map_to_twxy @@ -77,7 +77,7 @@ logical(kind=iwp) :: Fake = .false. logical(kind=iwp) :: Active = .false. real(kind=wp), allocatable :: A00(:) - real(kind=wp), contiguous, pointer :: A0(:) + real(kind=wp), contiguous, pointer :: A0(:) => null() type(DSB_Type) :: SB(8) end type DSBA_Type @@ -130,26 +130,31 @@ real(kind=wp), allocatable :: A(:,:) end type Alloc2DArray_Type +type Alloc1DiArray_Type + integer(kind=iwp), allocatable :: A(:) +end type Alloc1DiArray_Type + ! Allocate/deallocate data types interface Allocate_DT module procedure :: Allocate_DSBA, Allocate_SBA, Allocate_twxy, Allocate_NDSBA, Allocate_G2, Allocate_L_Full, Allocate_Lab, & - Alloc_Alloc1DArray, Alloc_Alloc2DArray + Alloc_Alloc_DSBA, Alloc_Alloc1DArray, Alloc2D_Alloc1DArray, Alloc_Alloc2DArray end interface Allocate_DT interface Deallocate_DT module procedure :: Deallocate_DSBA, Deallocate_SBA, Deallocate_twxy, Deallocate_NDSBA, Deallocate_G2, Deallocate_L_Full, & - Deallocate_Lab, Free_Alloc1DArray, Free_Alloc2DArray + Deallocate_Lab, Free_Alloc_DSBA, Free_Alloc1DArray, Free2D_Alloc1DArray, Free_Alloc2DArray end interface Deallocate_DT ! Private extensions to mma interfaces interface cptr2loff - module procedure :: lfp_cptr2loff, v1_cptr2loff, a1da_cptr2loff, a2da_cptr2loff + module procedure :: lfp_cptr2loff, v1_cptr2loff, dsba_cptr2loff, a1da_cptr2loff, a2da_cptr2loff end interface interface mma_allocate - module procedure :: lfp_mma_allo_3D, lfp_mma_allo_3D_lim, v1_mma_allo_3D, v1_mma_allo_3D_lim, a1da_mma_allo_1D, & - a1da_mma_allo_1D_lim, a2da_mma_allo_1D, a2da_mma_allo_1D_lim + module procedure :: lfp_mma_allo_3D, lfp_mma_allo_3D_lim, v1_mma_allo_3D, v1_mma_allo_3D_lim, dsba_mma_allo_1D, & + dsba_mma_allo_1D_lim, a1da_mma_allo_1D, a1da_mma_allo_1D_lim, a1da_mma_allo_2D, a1da_mma_allo_2D_lim, & + a2da_mma_allo_1D, a2da_mma_allo_1D_lim end interface interface mma_deallocate - module procedure :: lfp_mma_free_3D, v1_mma_free_3D, a1da_mma_free_1D, a2da_mma_free_1D + module procedure :: lfp_mma_free_3D, v1_mma_free_3D, dsba_mma_free_1D, a1da_mma_free_1D, a1da_mma_free_2D, a2da_mma_free_1D end interface contains @@ -901,8 +906,8 @@ type(L_Full_Type), target, intent(out) :: Adam integer(kind=iwp) :: nShell, iShp_rs(nShell*(nShell+2)/2), JNUM, JSYM, nSym - integer(kind=iwp), intent(out), optional :: Memory - integer(kind=iwp) :: iaSh, ibSh, iShp, iSyma, iSymb, LFULL, iS, iE, n1, n2 + integer(kind=iwp), intent(out), optional :: Memory(2) + integer(kind=iwp) :: iaSh, ibSh, iShp, iSyma, iSymb, LFULL, iS, iE, MemSPB, n1, n2 LFULL = 0 do iaSh=1,nShell @@ -929,7 +934,9 @@ LFULL = LFULL*JNUM if (present(Memory)) then - Memory = LFULL + MemSPB = nSym*nShell*(nShell+1) + MemSPB = (MemSPB*storage_size(Adam%SPB)-1)/storage_size(Adam%A0)+1 + Memory = [LFULL,MemSPB] return end if @@ -1032,8 +1039,8 @@ type(Lab_Type), target, intent(out) :: Lab integer(kind=iwp), intent(in) :: JNUM, nShell, nSym, nBasSh(nSym,nShell), nBas(nSym), nDen - integer(kind=iwp), intent(out), optional :: Memory - integer(kind=iwp) :: iSym, iDen, Lab_Memory, iE, iS, iSh + integer(kind=iwp), intent(out), optional :: Memory(2) + integer(kind=iwp) :: iSym, iDen, Lab_Memory, iE, iS, iSh, MemKeep, MemSB Lab_Memory = 0 do iSym=1,nSym @@ -1042,7 +1049,11 @@ Lab_Memory = Lab_Memory*JNUM*nDen if (present(Memory)) then - Memory = Lab_Memory + MemKeep = nShell*nDen + MemKeep = (MemKeep*storage_size(Lab%Keep)-1)/storage_size(Lab%A0)+1 + MemSB = nShell*nSym*nDen + MemSB = (MemSB*storage_size(Lab%SB)-1)/storage_size(Lab%A0)+1 + Memory = [Lab_Memory,MemKeep+MemSB] return end if @@ -1095,7 +1106,49 @@ end subroutine Deallocate_Lab +subroutine Alloc_Alloc_DSBA(Array,n_Array,n,m,nSym,aCase,Label) + + type(DSBA_Type), allocatable, intent(out) :: Array(:) + integer(kind=iwp), intent(in) :: n_Array, nSym, n(nSym), m(nSym) + character(len=3), intent(in), optional :: aCase + character(len=*), intent(in), optional :: Label + integer(kind=iwp) :: i + + if (present(Label)) then + call mma_allocate(Array,n_Array,label=Label) + else + call mma_allocate(Array,n_Array,label='DSBA(:)') + end if + + if (present(aCase)) then + do i=1,n_Array + call Allocate_DT(Array(i),n,m,nSym,aCase) + end do + else + do i=1,n_Array + call Allocate_DT(Array(i),n,m,nSym) + end do + end if + +# include "macros.fh" + unused_proc(mma_allocate(Array,[0,0])) + +end subroutine Alloc_Alloc_DSBA + +subroutine Free_Alloc_DSBA(Array) + + type(DSBA_Type), allocatable, intent(inout) :: Array(:) + integer(kind=iwp) :: i + + do i=lbound(Array,1),ubound(Array,1) + call Deallocate_DT(Array(i)) + end do + call mma_deallocate(Array) + +end subroutine Free_Alloc_DSBA + subroutine Alloc_Alloc1DArray(Array,N,Label) + type(Alloc1DArray_Type), allocatable, intent(inout) :: Array(:) integer(kind=iwp), intent(in) :: N(2) character(len=*), intent(in) :: Label @@ -1108,6 +1161,7 @@ end interface integer(kind=iwp) :: i # endif + call mma_allocate(Array,N,label=Label) # ifdef _GARBLE_ ! Garbling corrupts the allocation status of allocatable components, use a hack to reset it @@ -1121,7 +1175,38 @@ end subroutine Alloc_Alloc1DArray +subroutine Alloc2D_Alloc1DArray(Array,N1,N2,Label) + + type(Alloc1DArray_Type), allocatable, intent(inout) :: Array(:,:) + integer(kind=iwp), intent(in) :: N1(2), N2(2) + character(len=*), intent(in) :: Label +# ifdef _GARBLE_ + interface + subroutine c_null_alloc(A) + import :: wp + real(kind=wp), allocatable :: A(:) + end subroutine c_null_alloc + end interface + integer(kind=iwp) :: i, j +# endif + + call mma_allocate(Array,N1,N2,label=Label) +# ifdef _GARBLE_ + ! Garbling corrupts the allocation status of allocatable components, use a hack to reset it + do j=N2(1),N2(2) + do i=N1(1),N1(2) + call c_null_alloc(Array(i,j)%A) + end do + end do +# endif + +# include "macros.fh" + unused_proc(mma_allocate(Array,0,0)) + +end subroutine Alloc2D_Alloc1DArray + subroutine Alloc_Alloc2DArray(Array,N,Label) + type(Alloc2DArray_Type), allocatable, intent(inout) :: Array(:) integer(kind=iwp), intent(in) :: N(2) character(len=*), intent(in) :: Label @@ -1134,6 +1219,7 @@ end interface integer(kind=iwp) :: i # endif + call mma_allocate(Array,N,label=Label) # ifdef _GARBLE_ ! Garbling corrupts the allocation status of allocatable components, use a hack to reset it @@ -1149,25 +1235,48 @@ end subroutine Alloc_Alloc2DArray subroutine Free_Alloc1DArray(Array) + type(Alloc1DArray_Type), allocatable, intent(inout) :: Array(:) integer(kind=iwp) :: i + do i=lbound(Array,1),ubound(Array,1) if (allocated(Array(i)%A)) call mma_deallocate(Array(i)%A) end do call mma_deallocate(Array) + end subroutine Free_Alloc1DArray +subroutine Free2D_Alloc1DArray(Array) + + type(Alloc1DArray_Type), allocatable, intent(inout) :: Array(:,:) + integer(kind=iwp) :: i, j + + do j=lbound(Array,2),ubound(Array,2) + do i=lbound(Array,1),ubound(Array,1) + if (allocated(Array(i,j)%A)) call mma_deallocate(Array(i,j)%A) + end do + end do + call mma_deallocate(Array) + +end subroutine Free2D_Alloc1DArray + subroutine Free_Alloc2DArray(Array) + type(Alloc2DArray_Type), allocatable, intent(inout) :: Array(:) integer(kind=iwp) :: i + do i=lbound(Array,1),ubound(Array,1) if (allocated(Array(i)%A)) call mma_deallocate(Array(i)%A) end do call mma_deallocate(Array) + end subroutine Free_Alloc2DArray ! Define lfp_cptr2loff, lfp_mma_allo_3D, lfp_mma_allo_3D_lim, lfp_mma_free_3D -! a1da_cptr2loff, a1da_mma_allo_1D, a1da_mma_allo_1D_lim, a1da_mma_free_1D +! v1_cptr2loff, v1_mma_allo_3D, v1_mma_allo_3D_lim, v1_mma_free_3D +! dsba_cptr2loff, dsba_mma_allo_1D, dsba_mma_allo_1D_lim, dsba_mma_free_1D +! a1da_cptr2loff, a1da_mma_allo_1D, a1da_mma_allo_1D_lim, a1da_mma_free_1D, +! a1da_mma_allo_2D, a1da_mma_allo_2D_lim, a1da_mma_free_2D ! a2da_cptr2loff, a2da_mma_allo_1D, a2da_mma_allo_1D_lim, a2da_mma_free_1D #define _TYPE_ type(L_Full_Pointers) # define _FUNC_NAME_ lfp_cptr2loff @@ -1188,13 +1297,29 @@ # undef _FUNC_NAME_ # define _SUBR_NAME_ v1_mma # define _DIMENSIONS_ 3 -# define _DEF_LABEL_ 'lfp_mma' +# define _DEF_LABEL_ 'v1_mma' # include "mma_allo_template.fh" # undef _SUBR_NAME_ # undef _DIMENSIONS_ # undef _DEF_LABEL_ #undef _TYPE_ +! (using _NO_GARBLE_ because all members are initialized) +#define _TYPE_ type(DSBA_Type) +# define _NO_GARBLE_ +# define _FUNC_NAME_ dsba_cptr2loff +# include "cptr2loff_template.fh" +# undef _FUNC_NAME_ +# define _SUBR_NAME_ dsba_mma +# define _DIMENSIONS_ 1 +# define _DEF_LABEL_ 'dsba_mma' +# include "mma_allo_template.fh" +# undef _SUBR_NAME_ +# undef _DIMENSIONS_ +# undef _DEF_LABEL_ +# undef _NO_GARBLE_ +#undef _TYPE_ + #define _TYPE_ type(Alloc1DArray_Type) # define _FUNC_NAME_ a1da_cptr2loff # include "cptr2loff_template.fh" @@ -1203,6 +1328,9 @@ # define _DIMENSIONS_ 1 # define _DEF_LABEL_ 'a1da_mma' # include "mma_allo_template.fh" +# undef _DIMENSIONS_ +# define _DIMENSIONS_ 2 +# include "mma_allo_template.fh" # undef _SUBR_NAME_ # undef _DIMENSIONS_ # undef _DEF_LABEL_ diff -Nru openmolcas-22.02/src/system_util/datimx.c openmolcas-22.10/src/system_util/datimx.c --- openmolcas-22.02/src/system_util/datimx.c 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/system_util/datimx.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,75 +0,0 @@ -/*********************************************************************** -* This file is part of OpenMolcas. * -* * -* OpenMolcas is free software; you can redistribute it and/or modify * -* it under the terms of the GNU Lesser General Public License, v. 2.1. * -* OpenMolcas is distributed in the hope that it will be useful, but it * -* is provided "as is" and without any express or implied warranties. * -* For more details see the full text of the license in the file * -* LICENSE or in <http://www.gnu.org/licenses/>. * -* * -* Copyright (C) 1992, Markus P. Fuelscher * -***********************************************************************/ -/**********************************************************************/ -/* */ -/* Extract the current date and time. */ -/* */ -/* Note: */ -/* The VS-FORTRAN subrotuines, Datim and Datimx, are replaced */ -/* by this routine. */ -/* */ -/*--------------------------------------------------------------------*/ -/* */ -/* written by: */ -/* M.P. Fuelscher */ -/* University of Lund, Sweden, 1992 */ -/* */ -/*--------------------------------------------------------------------*/ -/* */ -/* history: none */ -/* */ -/**********************************************************************/ - -#include <stdio.h> -#include <stdlib.h> -#include <errno.h> -#include <time.h> -#ifndef _WIN32_ -#include <sys/time.h> -#endif -#include <string.h> - -#include "molcastype.h" - -#ifdef _CAPITALS_ -#define datimx DATIMX -#else -#ifndef ADD_ -#define datimx datimx_ -#endif -#endif - - -void datimx(char *TimeStamp) -{ -#ifdef _WIN32_ -strcpy(TimeStamp,"Once upon a time..."); -#else - static int CTIME_RES_LENGTH = 24; - char *ptr; - time_t x; - struct timeval t; - struct timezone tz; - if ( gettimeofday(&t,&tz) != 0 ) { - printf(" *** Error in procedure datimx: %s\n",strerror(errno)); - exit(20); - } else { - x=(time_t)t.tv_sec; - ptr=ctime(&x); - if(ptr!=NULL) { - strncpy(TimeStamp,ptr, CTIME_RES_LENGTH); - TimeStamp[CTIME_RES_LENGTH+1]=0; - } - } -#endif -} diff -Nru openmolcas-22.02/src/system_util/datimxc.c openmolcas-22.10/src/system_util/datimxc.c --- openmolcas-22.02/src/system_util/datimxc.c 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/system_util/datimxc.c 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,75 @@ +/*********************************************************************** +* This file is part of OpenMolcas. * +* * +* OpenMolcas is free software; you can redistribute it and/or modify * +* it under the terms of the GNU Lesser General Public License, v. 2.1. * +* OpenMolcas is distributed in the hope that it will be useful, but it * +* is provided "as is" and without any express or implied warranties. * +* For more details see the full text of the license in the file * +* LICENSE or in <http://www.gnu.org/licenses/>. * +* * +* Copyright (C) 1992, Markus P. Fuelscher * +***********************************************************************/ +/**********************************************************************/ +/* */ +/* Extract the current date and time. */ +/* */ +/* Note: */ +/* The VS-FORTRAN subrotuines, Datim and Datimx, are replaced */ +/* by this routine. */ +/* */ +/*--------------------------------------------------------------------*/ +/* */ +/* written by: */ +/* M.P. Fuelscher */ +/* University of Lund, Sweden, 1992 */ +/* */ +/*--------------------------------------------------------------------*/ +/* */ +/* history: none */ +/* */ +/**********************************************************************/ + +#include <stdio.h> +#include <stdlib.h> +#include <errno.h> +#include <time.h> +#ifndef _WIN32_ +#include <sys/time.h> +#endif +#include <string.h> + +#include "molcastype.h" + +#ifdef _CAPITALS_ +#define datimxc DATIMXC +#else +#ifndef ADD_ +#define datimxc datimxc_ +#endif +#endif + + +void datimxc(char *TimeStamp) +{ +#ifdef _WIN32_ + strcpy(TimeStamp,"Once upon a time..."); +#else + static int CTIME_RES_LENGTH = 24; + char *ptr; + time_t x; + struct timeval t; + struct timezone tz; + if ( gettimeofday(&t,&tz) != 0 ) { + printf(" *** Error in procedure datimxc: %s\n",strerror(errno)); + exit(20); + } else { + x=(time_t)t.tv_sec; + ptr=ctime(&x); + if(ptr!=NULL) { + strncpy(TimeStamp,ptr, CTIME_RES_LENGTH); + TimeStamp[CTIME_RES_LENGTH+1]=0; + } + } +#endif +} diff -Nru openmolcas-22.02/src/system_util/datimx.F90 openmolcas-22.10/src/system_util/datimx.F90 --- openmolcas-22.02/src/system_util/datimx.F90 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/src/system_util/datimx.F90 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,25 @@ +!*********************************************************************** +! This file is part of OpenMolcas. * +! * +! OpenMolcas is free software; you can redistribute it and/or modify * +! it under the terms of the GNU Lesser General Public License, v. 2.1. * +! OpenMolcas is distributed in the hope that it will be useful, but it * +! is provided "as is" and without any express or implied warranties. * +! For more details see the full text of the license in the file * +! LICENSE or in <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine datimx(TimeStamp) + +implicit none +character(len=*), intent(out) :: TimeStamp +interface + subroutine datimxc(TimeStamp) bind(C,name='datimxc_') + use, intrinsic :: iso_c_binding, only: c_char + character(kind=c_char) :: TimeStamp(*) + end subroutine +end interface + +call datimxc(TimeStamp) + +end subroutine datimx diff -Nru openmolcas-22.02/src/system_util/filesystem.F90 openmolcas-22.10/src/system_util/filesystem.F90 --- openmolcas-22.02/src/system_util/filesystem.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/system_util/filesystem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -17,12 +17,14 @@ use, intrinsic :: iso_c_binding, only: c_char, c_int, c_ptr, c_null_char use fortran_strings, only: split, StringWrapper_t, Cptr_to_str, str +use linalg_mod, only: abort_ use Definitions, only: iwp, MOLCAS_C_INT implicit none private -public :: getcwd_, chdir_, symlink_, get_errno_, strerror_, mkdir_, remove_, real_path, basename, inquire_ +public :: getcwd_, chdir_, symlink_, get_errno_, strerror_, mkdir_, & + remove_, real_path, basename, inquire_, copy_ interface subroutine getcwd_c(path,n,err) bind(C,name='getcwd_wrapper') @@ -70,6 +72,12 @@ integer(kind=MOLCAS_C_INT), intent(out) :: err end subroutine remove_c + subroutine copy_c(src,dst,err) bind(C,name='copy') + import :: c_char, MOLCAS_C_INT + character(len=1,kind=c_char), intent(in) :: src(*),dst(*) + integer(kind=MOLCAS_C_INT), intent(out) :: err + end subroutine copy_c + function access_c(path) bind(C,name='access_wrapper') import :: c_char, MOLCAS_C_INT integer(kind=MOLCAS_C_INT) :: access_c @@ -191,4 +199,23 @@ inquire_ = access_c(trim(path)//c_null_char) == 0 end function +!> @brief +!> Copy file from src to dst +!> +!> @details +!> This function is not guaranteed to be thread-safe. +!> As long as `dst` is different for two processes calling at the same +!> time, it is safe to use in process-based parallelisation. +subroutine copy_(src, dst, err) + character(len=*), intent(in) :: src, dst + integer(kind=iwp), intent(out), optional :: err + integer(kind=iwp) :: err_ + call copy_c(trim(src)//c_null_char, trim(dst)//c_null_char, err_) + if (present(err)) then + err = err_ + else if (err_ /= 0) then + call abort_('Error in copy') + end if +end subroutine + end module filesystem diff -Nru openmolcas-22.02/src/system_util/print_module_header.F90 openmolcas-22.10/src/system_util/print_module_header.F90 --- openmolcas-22.02/src/system_util/print_module_header.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/system_util/print_module_header.F90 2022-10-10 14:22:40.000000000 +0000 @@ -19,7 +19,7 @@ use omp_lib, only: omp_get_max_threads #endif use stdalloc, only: mxMem -use Definitions, only: iwp, wp, u6, RtoB +use Definitions, only: wp, iwp, u6, RtoB implicit none character(len=*) :: modulename diff -Nru openmolcas-22.02/src/system_util/sysexpand.F90 openmolcas-22.10/src/system_util/sysexpand.F90 --- openmolcas-22.02/src/system_util/sysexpand.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/system_util/sysexpand.F90 2022-10-10 14:22:40.000000000 +0000 @@ -42,7 +42,7 @@ character :: c character(len=*), parameter :: up = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ ', & lw = 'abcdefghijklmnopqrstuvwxyz ', & - printable = '1234567890-=~!@#$%^&*()_+<>,.?/[]":;' + printable = '1234567890-=~!@#$%^&*()_+<>,.?/\[]":;' ! FORTRAN hash :-) integer(kind=iwp), parameter :: MAXlabel = 8 integer(kind=iwp), save :: MSGlen(MAXlabel) @@ -64,7 +64,7 @@ 'Premature abort while seeking the file', & !SEEK 'An invalid option or combination of options has been supplied', & !INVALIDOPTION 'Invalid unit number. The file is already opened', & !USED - 'File is not Opened' & !NOT OPENED + 'File is not Opened' & !NOTOPENED ] ! preset of saved data @@ -93,15 +93,9 @@ if (sstrin(1:4) /= 'MSG:') then do ii=1,len(sstrin) c = sstrin(ii:ii) -# ifdef NAGFOR - if (c /= '\') then -# endif ip = index(up,c)+index(lw,c)+index(printable,c) !write(u6,*) 'ii',ii if (ip == 0) sstrin(ii:ii) = ' ' -# ifdef NAGFOR - end if -# endif end do iRet = 0 return diff -Nru openmolcas-22.02/src/transform_util/cho_genc.F90 openmolcas-22.10/src/transform_util/cho_genc.F90 --- openmolcas-22.02/src/transform_util/cho_genc.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/transform_util/cho_genc.F90 2022-10-10 14:22:40.000000000 +0000 @@ -23,9 +23,11 @@ !> secondary ``A,B`` MO. !> !> @param[in] iSymI,iSymJ,iSymA,iSymB Symmetry block of the two-electrons integrals +!> @param[in] iI,iJ !> @param[in] NumV Number of Cholesky vectors to transform in the current batch !> @param[in,out] AddCou Array of the ``A,B`` integrals block !> @param[in] LenCou Length of the ``A,B`` integrals block +!> @param[in] LenEx !*********************************************************************** subroutine Cho_GenC(iSymI,iSymJ,iSymA,iSymB,iI,iJ,numV,AddCou,LenCou,LenEx) diff -Nru openmolcas-22.02/src/transform_util/cho_gene.F90 openmolcas-22.10/src/transform_util/cho_gene.F90 --- openmolcas-22.02/src/transform_util/cho_gene.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/transform_util/cho_gene.F90 2022-10-10 14:22:40.000000000 +0000 @@ -23,6 +23,7 @@ !> secondary ``A,B`` MO. !> !> @param[in] iSymI,iSymJ,iSymA,iSymB Symmetry block of the two-electrons integrals +!> @param[in] iI,iJ !> @param[in] NumV Number of Cholesky vectors to transform in the current batch !> @param[in,out] AddEx Array of the ``A,B`` integrals block !> @param[in] LenEx Length of the ``A,B`` integrals block diff -Nru openmolcas-22.02/src/transform_util/tr2nsa2.F90 openmolcas-22.10/src/transform_util/tr2nsa2.F90 --- openmolcas-22.02/src/transform_util/tr2nsa2.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/transform_util/tr2nsa2.F90 2022-10-10 14:22:40.000000000 +0000 @@ -107,7 +107,7 @@ ! (pq,TU) -> (Aq,TU) call DGEMM_('N','N',NBQ,NOP,NBP,One,X2,NBQ,CMO(LMOP),NBP,Zero,X1,NBQ) ! (Aq,TU) -> (AB,TU) - Call DGEMM_Tri('T','N',NOP,NOP,NBQ,One,X1,NBQ,CMO(LMOQ),NBQ,Zero,X2,NOP) + call DGEMM_Tri('T','N',NOP,NOP,NBQ,One,X1,NBQ,CMO(LMOQ),NBQ,Zero,X2,NOP) IX2 = (NOP+NOP**2)/2 else ! (pq,TU) -> (Aq,TU) diff -Nru openmolcas-22.02/src/transform_util/tr2nsb.F90 openmolcas-22.10/src/transform_util/tr2nsb.F90 --- openmolcas-22.02/src/transform_util/tr2nsb.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/transform_util/tr2nsb.F90 2022-10-10 14:22:40.000000000 +0000 @@ -144,7 +144,7 @@ ! (pq,rs) -> (pU,rs) call DGEMM_('T','N',NBP,NOCQ,NBQ,One,X2,NBQ,CMO(LMOQ2),NBQ,Zero,X1,NBP) ! (pU,rs) -> (TU,rs) - Call DGEMM_Tri('T','N',NOCP,NOCP,NBP,One,X1,NBP,CMO(LMOP2),NBP,Zero,X2,NOCP) + call DGEMM_Tri('T','N',NOCP,NOCP,NBP,One,X1,NBP,CMO(LMOP2),NBP,Zero,X2,NOCP) else call dcopy_(NBPQ,PQRS(NBPQ*(LRS-1)+1),1,X2,1) ! (pq,rs) -> (pU,rs) @@ -189,7 +189,7 @@ ! (TU,rs) -> (TU,sB) call DGEMM_('T','N',NBR,NOS,NBS,One,X2,NBS,CMO(LMOS2),NBS,Zero,X1,NBR) ! (TU,sB) -> (TU,AB) - Call DGEMM_Tri('T','N',NOR,NOR,NBR,One,X1,NBR,CMO(LMOR2),NBR,Zero,X2,NOR) + call DGEMM_Tri('T','N',NOR,NOR,NBR,One,X1,NBR,CMO(LMOR2),NBR,Zero,X2,NOR) IX2 = (NOR*NOR+NOR)/2 else call dcopy_(NBRS,TURS(IPQST),1,X2,1) diff -Nru openmolcas-22.02/src/transform_util/tr2sq.F90 openmolcas-22.10/src/transform_util/tr2sq.F90 --- openmolcas-22.02/src/transform_util/tr2sq.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/transform_util/tr2sq.F90 2022-10-10 14:22:40.000000000 +0000 @@ -167,7 +167,7 @@ if (NOCR*NOCS /= 0) then if (ISR == ISS) then - Call DGEMM_Tri('T','N',NOCR,NOCR,NBR,One,X3,NBR,CMO(LMOR2),NBR,Zero,X2,NOCR) + call DGEMM_Tri('T','N',NOCR,NOCR,NBR,One,X3,NBR,CMO(LMOR2),NBR,Zero,X2,NOCR) else call DGEMM_('T','N',NOCS,NOCR,NBR,One,X3,NBR,CMO(LMOR2),NBR,Zero,X2,NOCS) end if @@ -247,7 +247,7 @@ if (ISP == ISQ) then call SQUARE(TUPQ(IPQST),X2,1,NBQ,NBQ) call DGEMM_('N','N',NBQ,NOP,NBP,One,X2,NBQ,CMO(LMOP),NBP,Zero,X1,NBP) - Call DGEMM_Tri('T','N',NOP,NOP,NBQ,One,X1,NBQ,CMO(LMOQ),NBQ,ZERO,X2,NOP) + call DGEMM_Tri('T','N',NOP,NOP,NBQ,One,X1,NBQ,CMO(LMOQ),NBQ,ZERO,X2,NOP) IX2 = (NOP+NOP**2)/2 else call DGEMM_('N','N',NBQ,NOP,NBP,One,TUPQ(IPQST),NBQ,CMO(LMOP),NBP,Zero,X1,NBQ) diff -Nru openmolcas-22.02/src/transform_util/tractl.F90 openmolcas-22.10/src/transform_util/tractl.F90 --- openmolcas-22.02/src/transform_util/tractl.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/transform_util/tractl.F90 2022-10-10 14:22:40.000000000 +0000 @@ -28,7 +28,7 @@ ! GENERATED BY INTSORT ON UNIT LUINTA=40. ! ! WRITTEN IN GARCHING IN SEPTEMBER 1987 -! AUTHOR: BYOERN ROOS +! AUTHOR: BJOERN ROOS ! DEPARTMENT OF THEORETICAL CHEMISTRY ! CHEMICAL CENTRE ! P.O.B. 124 diff -Nru openmolcas-22.02/src/wfn_util/rasscf_data.F90 openmolcas-22.10/src/wfn_util/rasscf_data.F90 --- openmolcas-22.02/src/wfn_util/rasscf_data.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/src/wfn_util/rasscf_data.F90 2022-10-10 14:22:40.000000000 +0000 @@ -18,7 +18,6 @@ implicit none -! Order of inclusion matters! #include "rasdim.fh" #include "rasscf.fh" diff -Nru openmolcas-22.02/.tags openmolcas-22.10/.tags --- openmolcas-22.02/.tags 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/.tags 2022-10-10 14:22:40.000000000 +0000 @@ -1,2 +1,2 @@ -f8df69cf87b241a15ebc82d72a8f9a031a385dd4 - (tag: v22.02, refs/merge-requests/519/head, refs/keep-around/f8df69cf87b241a15ebc82d72a8f9a031a385dd4) +aedb15be52d6dee285dd3e10e9d05f44e4ca969a + (tag: v22.10, refs/merge-requests/574/head, refs/keep-around/aedb15be52d6dee285dd3e10e9d05f44e4ca969a) diff -Nru openmolcas-22.02/test/additional/105.input openmolcas-22.10/test/additional/105.input --- openmolcas-22.02/test/additional/105.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/105.input 2022-10-10 14:22:40.000000000 +0000 @@ -49,9 +49,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 18.09-743-ga148db94 -* Linux lucifer 4.15.0-58-generic #64-Ubuntu SMP Tue Aug 6 11:12:41 UTC 2019 x86_64 x86_64 x86_64 GNU/Linux -* Wed Sep 4 11:49:59 2019 +* Molcas version 22.02-260-gd39e60428 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Wed Apr 27 18:28:24 2022 * #>> 1 #> POTNUC="7.500529624373"/6 @@ -59,163 +59,163 @@ #> SEWARD_KINETIC="0.516840303497"/5 #> SEWARD_ATTRACT="-6.370334685861"/5 #>> 2 -#> SCF_ITER="10"/8 -#> E_SCF="-76.333380785108"/8 -#> DFT_ENERGY="-7.402222353299"/6 -#> NQ_DENSITY="10.000001693835"/8 +#> SCF_ITER="9"/8 +#> E_SCF="-76.333380785088"/8 +#> DFT_ENERGY="-7.402221821441"/6 +#> NQ_DENSITY="10.000001693793"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 -#> MLTPL__1[2]="0.831200093025"/5 -#> MLTPL__2[0]="-1.842655444917"/5 +#> MLTPL__1[2]="0.831199060825"/5 +#> MLTPL__2[0]="-1.842653807591"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.245257185180"/5 +#> MLTPL__2[3]="1.245255595025"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.597398259738"/5 +#> MLTPL__2[5]="0.597398212567"/5 #>> 3 #> GRAD[0]="0.0"/6 -#> GRAD[1]="0.066487817122"/6 -#> GRAD[2]="0.072411934901"/6 +#> GRAD[1]="0.066487816740"/6 +#> GRAD[2]="0.072411935200"/6 #> GRAD[3]="0.0"/6 #> GRAD[4]="0.0"/6 -#> GRAD[5]="-0.144823869802"/6 +#> GRAD[5]="-0.144823870399"/6 #>> 4 #>> 5 #>> 7 -#> POTNUC="8.385504560845"/6 -#> SEWARD_MLTPL1X="0.810867259662"/5 -#> SEWARD_KINETIC="0.525525822367"/5 -#> SEWARD_ATTRACT="-7.073773524071"/5 +#> POTNUC="8.385504558471"/6 +#> SEWARD_MLTPL1X="0.810867258149"/5 +#> SEWARD_KINETIC="0.525525821751"/5 +#> SEWARD_ATTRACT="-7.073773509391"/5 #>> 8 #> SCF_ITER="9"/8 -#> E_SCF="-76.373246638275"/8 -#> DFT_ENERGY="-7.474658986320"/6 -#> NQ_DENSITY="10.000000145357"/8 +#> E_SCF="-76.373246638292"/8 +#> DFT_ENERGY="-7.474658855382"/6 +#> NQ_DENSITY="10.000000145327"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 -#> MLTPL__1[2]="0.798292794363"/5 -#> MLTPL__2[0]="-1.627700252106"/5 +#> MLTPL__1[2]="0.798291895634"/5 +#> MLTPL__2[0]="-1.627698908429"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.392156290504"/5 +#> MLTPL__2[3]="1.392154704959"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.235543961601"/5 +#> MLTPL__2[5]="0.235544203470"/5 #>> 9 #> GRAD[0]="0.0"/6 -#> GRAD[1]="0.041301245388"/6 -#> GRAD[2]="0.040491947625"/6 +#> GRAD[1]="0.041301245453"/6 +#> GRAD[2]="0.040491947585"/6 #> GRAD[3]="0.0"/6 #> GRAD[4]="0.0"/6 -#> GRAD[5]="-0.080983895250"/6 +#> GRAD[5]="-0.080983895169"/6 #>> 10 #>> 11 #>> 13 -#> POTNUC="9.243422410875"/6 -#> SEWARD_MLTPL1X="0.844881000835"/5 -#> SEWARD_KINETIC="0.540327902919"/5 -#> SEWARD_ATTRACT="-7.838233553836"/5 +#> POTNUC="9.243422427894"/6 +#> SEWARD_MLTPL1X="0.844880999578"/5 +#> SEWARD_KINETIC="0.540327902338"/5 +#> SEWARD_ATTRACT="-7.838233551910"/5 #>> 14 #> SCF_ITER="8"/8 -#> E_SCF="-76.382396387987"/8 -#> DFT_ENERGY="-7.543311944598"/6 -#> NQ_DENSITY="9.999999333772"/8 +#> E_SCF="-76.382396388026"/8 +#> DFT_ENERGY="-7.543311800754"/6 +#> NQ_DENSITY="9.999999333739"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 -#> MLTPL__1[2]="0.781480037358"/5 -#> MLTPL__2[0]="-1.430204431880"/5 +#> MLTPL__1[2]="0.781479071820"/5 +#> MLTPL__2[0]="-1.430203001761"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.278238955971"/5 +#> MLTPL__2[3]="1.278237177200"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.151965475909"/5 +#> MLTPL__2[5]="0.151965824561"/5 #>> 15 #> GRAD[0]="0.0"/6 -#> GRAD[1]="-0.019318138775"/6 -#> GRAD[2]="-0.005409966051"/6 +#> GRAD[1]="-0.019318144938"/6 +#> GRAD[2]="-0.005409965957"/6 #> GRAD[3]="0.0"/6 #> GRAD[4]="0.0"/6 -#> GRAD[5]="0.010819932101"/6 +#> GRAD[5]="0.010819931914"/6 #>> 16 #>> 17 #>> 19 -#> POTNUC="9.085718292543"/6 -#> SEWARD_MLTPL1X="0.829387367498"/5 -#> SEWARD_KINETIC="0.533348462920"/5 -#> SEWARD_ATTRACT="-7.618449497390"/5 +#> POTNUC="9.085718301616"/6 +#> SEWARD_MLTPL1X="0.829387362426"/5 +#> SEWARD_KINETIC="0.533348460699"/5 +#> SEWARD_ATTRACT="-7.618449457170"/5 #>> 20 #> SCF_ITER="7"/8 -#> E_SCF="-76.383451293254"/8 -#> DFT_ENERGY="-7.531483369448"/6 -#> NQ_DENSITY="9.999998944260"/8 +#> E_SCF="-76.383451293355"/8 +#> DFT_ENERGY="-7.531483227803"/6 +#> NQ_DENSITY="9.999998944222"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 -#> MLTPL__1[2]="0.767918582484"/5 -#> MLTPL__2[0]="-1.480168970255"/5 +#> MLTPL__1[2]="0.767917613944"/5 +#> MLTPL__2[0]="-1.480167556604"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.441471392079"/5 +#> MLTPL__2[3]="1.441469653198"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.038697578176"/5 +#> MLTPL__2[5]="0.038697903405"/5 #>> 21 #> GRAD[0]="0.0"/6 -#> GRAD[1]="-0.001201659628"/6 -#> GRAD[2]="0.001284430595"/6 +#> GRAD[1]="-0.001201657981"/6 +#> GRAD[2]="0.001284428138"/6 #> GRAD[3]="0.0"/6 #> GRAD[4]="0.0"/6 -#> GRAD[5]="-0.002568861190"/6 +#> GRAD[5]="-0.002568856276"/6 #>> 22 #>> 23 #>> 25 -#> POTNUC="9.087553250165"/6 -#> SEWARD_MLTPL1X="0.826640563520"/5 -#> SEWARD_KINETIC="0.532151982526"/5 -#> SEWARD_ATTRACT="-7.594970495550"/5 +#> POTNUC="9.087553250922"/6 +#> SEWARD_MLTPL1X="0.826640561107"/5 +#> SEWARD_KINETIC="0.532151981480"/5 +#> SEWARD_ATTRACT="-7.594970474411"/5 #>> 26 #> SCF_ITER="7"/8 -#> E_SCF="-76.383482277329"/8 -#> DFT_ENERGY="-7.531846971000"/6 -#> NQ_DENSITY="9.999998918856"/8 +#> E_SCF="-76.383482277314"/8 +#> DFT_ENERGY="-7.531846827489"/6 +#> NQ_DENSITY="9.999998918820"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 -#> MLTPL__1[2]="0.762229709917"/5 -#> MLTPL__2[0]="-1.485200586532"/5 +#> MLTPL__1[2]="0.762228742153"/5 +#> MLTPL__2[0]="-1.485199161977"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.486772815450"/5 +#> MLTPL__2[3]="1.486771006434"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.001572228918"/5 +#> MLTPL__2[5]="-0.001571844456"/5 #>> 27 #> GRAD[0]="0.0"/6 -#> GRAD[1]="0.000033976133"/6 -#> GRAD[2]="0.000039347511"/6 +#> GRAD[1]="0.000033989125"/6 +#> GRAD[2]="0.000039342909"/6 #> GRAD[3]="0.0"/6 #> GRAD[4]="0.0"/6 -#> GRAD[5]="-0.000078695023"/6 +#> GRAD[5]="-0.000078685818"/6 #>> 28 #>> 29 #> GEO_ITER="5"/8 -#> POTNUC="9.088047790657"/6 -#> SEWARD_MLTPL1X="0.826639877931"/5 -#> SEWARD_KINETIC="0.532151685448"/5 -#> SEWARD_ATTRACT="-7.595225830864"/5 -#> SCF_ITER="3"/8 -#> E_SCF="-76.383482284780"/8 -#> DFT_ENERGY="-7.531868274915"/6 -#> NQ_DENSITY="9.999998919723"/8 +#> POTNUC="9.088047835477"/6 +#> SEWARD_MLTPL1X="0.826639895848"/5 +#> SEWARD_KINETIC="0.532151693212"/5 +#> SEWARD_ATTRACT="-7.595226014491"/5 +#> SCF_ITER="4"/8 +#> E_SCF="-76.383482285411"/8 +#> DFT_ENERGY="-7.531888040639"/6 +#> NQ_DENSITY="9.999998919691"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 -#> MLTPL__1[2]="0.762180080661"/5 -#> MLTPL__2[0]="-1.485130333604"/5 +#> MLTPL__1[2]="0.762176226855"/5 +#> MLTPL__2[0]="-1.485127413428"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.487015687189"/5 +#> MLTPL__2[3]="1.487012825002"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.001885353584"/5 +#> MLTPL__2[5]="-0.001885411574"/5 #>> 30 >>EOF diff -Nru openmolcas-22.02/test/additional/107.input openmolcas-22.10/test/additional/107.input --- openmolcas-22.02/test/additional/107.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/107.input 2022-10-10 14:22:40.000000000 +0000 @@ -88,9 +88,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-943-g4c2682958 -* Linux lucifer 5.13.0-27-generic #29~20.04.1-Ubuntu SMP Fri Jan 14 00:32:30 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux -* Sat Feb 5 17:07:33 2022 +* Molcas version 22.02-260-gd39e60428 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Wed Apr 27 18:28:24 2022 * #>> 1 #> POTNUC="8.906622248211"/6 @@ -99,111 +99,111 @@ #> SEWARD_ATTRACT="-5.969592796903"/5 #>> 2 #> SCF_ITER="13"/8 -#> E_SCF="-76.337211212291"/4 -#> DFT_ENERGY="-9.309242428603"/6 -#> NQ_DENSITY="9.999998484524"/8 +#> E_SCF="-76.337211212190"/4 +#> DFT_ENERGY="-9.309242428452"/6 +#> NQ_DENSITY="9.999998484440"/8 #> MLTPL__0="-0.000000000000"/2 #> MLTPL__1[0]="0.000000000001"/2 -#> MLTPL__1[1]="0.776026763632"/2 +#> MLTPL__1[1]="0.776026763622"/2 #> MLTPL__1[2]="0.000000000000"/2 -#> MLTPL__2[0]="1.357479584489"/2 +#> MLTPL__2[0]="1.357479584517"/2 #> MLTPL__2[1]="0.000000000000"/2 #> MLTPL__2[2]="0.000000000000"/2 -#> MLTPL__2[3]="0.078473548043"/2 +#> MLTPL__2[3]="0.078473548037"/2 #> MLTPL__2[4]="-0.000000000000"/2 -#> MLTPL__2[5]="-1.435953132532"/2 +#> MLTPL__2[5]="-1.435953132554"/2 #>> 3 -#> GRAD[0]="0.005332002448"/6 -#> GRAD[1]="0.007626717708"/6 +#> GRAD[0]="0.005332002290"/6 +#> GRAD[1]="0.007626717563"/6 #> GRAD[2]="0.0"/6 -#> GRAD[3]="-0.005332002447"/6 -#> GRAD[4]="0.007626717707"/6 +#> GRAD[3]="-0.005332002290"/6 +#> GRAD[4]="0.007626717563"/6 #> GRAD[5]="0.000000000000"/6 #> GRAD[6]="-0.000000000000"/6 -#> GRAD[7]="-0.015253435415"/6 +#> GRAD[7]="-0.015253435126"/6 #> GRAD[8]="-0.000000000000"/6 #>> 4 #>> 6 -#> POTNUC="8.970231900794"/6 -#> SEWARD_MLTPL1X="1.434666973165"/5 +#> POTNUC="8.970231899210"/6 +#> SEWARD_MLTPL1X="1.434666973369"/5 #> SEWARD_KINETIC="0.969225931578"/5 -#> SEWARD_ATTRACT="-5.998910139472"/5 +#> SEWARD_ATTRACT="-5.998910138709"/5 #>> 7 #> SCF_ITER="8"/8 -#> E_SCF="-76.337452689505"/4 -#> DFT_ENERGY="-9.315667858004"/6 -#> NQ_DENSITY="9.999998707271"/8 +#> E_SCF="-76.337452689404"/4 +#> DFT_ENERGY="-9.315667857737"/6 +#> NQ_DENSITY="9.999998707188"/8 #> MLTPL__0="-0.000000000000"/2 #> MLTPL__1[0]="-0.000000000001"/2 -#> MLTPL__1[1]="0.769744870938"/2 +#> MLTPL__1[1]="0.769744870980"/2 #> MLTPL__1[2]="0.000000000000"/2 -#> MLTPL__2[0]="1.396985146749"/2 +#> MLTPL__2[0]="1.396985146884"/2 #> MLTPL__2[1]="-0.000000000001"/2 #> MLTPL__2[2]="0.000000000000"/2 -#> MLTPL__2[3]="0.032100155263"/2 +#> MLTPL__2[3]="0.032100155476"/2 #> MLTPL__2[4]="-0.000000000000"/2 -#> MLTPL__2[5]="-1.429085302012"/2 +#> MLTPL__2[5]="-1.429085302360"/2 #>> 8 -#> GRAD[0]="0.001985711646"/6 -#> GRAD[1]="0.002881623998"/6 +#> GRAD[0]="0.001985711619"/6 +#> GRAD[1]="0.002881623983"/6 #> GRAD[2]="0.0"/6 -#> GRAD[3]="-0.001985711646"/6 -#> GRAD[4]="0.002881623998"/6 +#> GRAD[3]="-0.001985711619"/6 +#> GRAD[4]="0.002881623983"/6 #> GRAD[5]="0.000000000000"/6 #> GRAD[6]="0.000000000000"/6 -#> GRAD[7]="-0.005763247997"/6 +#> GRAD[7]="-0.005763247966"/6 #> GRAD[8]="-0.000000000000"/6 #>> 9 #>> 11 -#> POTNUC="9.008371502487"/6 -#> SEWARD_MLTPL1X="1.436158295762"/5 +#> POTNUC="9.008371491690"/6 +#> SEWARD_MLTPL1X="1.436158293826"/5 #> SEWARD_KINETIC="0.969225931578"/5 -#> SEWARD_ATTRACT="-6.016430842054"/5 +#> SEWARD_ATTRACT="-6.016430837295"/5 #>> 12 #> SCF_ITER="8"/8 -#> E_SCF="-76.337492682990"/4 -#> DFT_ENERGY="-9.319519607193"/6 -#> NQ_DENSITY="9.999998929902"/8 +#> E_SCF="-76.337492682891"/4 +#> DFT_ENERGY="-9.319519605954"/6 +#> NQ_DENSITY="9.999998929820"/8 #> MLTPL__0="-0.000000000000"/2 #> MLTPL__1[0]="-0.000000000001"/2 -#> MLTPL__1[1]="0.765798895162"/2 +#> MLTPL__1[1]="0.765798897033"/2 #> MLTPL__1[2]="0.000000000000"/2 -#> MLTPL__2[0]="1.421026948375"/2 +#> MLTPL__2[0]="1.421026935368"/2 #> MLTPL__2[1]="-0.000000000000"/2 #> MLTPL__2[2]="0.000000000000"/2 -#> MLTPL__2[3]="0.004078281890"/2 +#> MLTPL__2[3]="0.004078295229"/2 #> MLTPL__2[4]="-0.000000000000"/2 -#> MLTPL__2[5]="-1.425105230266"/2 +#> MLTPL__2[5]="-1.425105230597"/2 #>> 13 -#> GRAD[0]="-0.000127957690"/6 -#> GRAD[1]="-0.000012209741"/6 +#> GRAD[0]="-0.000127957405"/6 +#> GRAD[1]="-0.000012208881"/6 #> GRAD[2]="0.0"/6 -#> GRAD[3]="0.000127957688"/6 -#> GRAD[4]="-0.000012209740"/6 +#> GRAD[3]="0.000127957404"/6 +#> GRAD[4]="-0.000012208880"/6 #> GRAD[5]="0.000000000000"/6 #> GRAD[6]="0.000000000001"/6 -#> GRAD[7]="0.000024419482"/6 +#> GRAD[7]="0.000024417760"/6 #> GRAD[8]="-0.000000000000"/6 #>> 14 #> GEO_ITER="3"/8 -#> POTNUC="9.007568291203"/6 -#> SEWARD_MLTPL1X="1.436628966103"/5 +#> POTNUC="9.007568289828"/6 +#> SEWARD_MLTPL1X="1.436628965978"/5 #> SEWARD_KINETIC="0.969225931578"/5 -#> SEWARD_ATTRACT="-6.015997151160"/5 -#> SCF_ITER="3"/8 -#> E_SCF="-76.337492747844"/4 -#> DFT_ENERGY="-9.319471036347"/6 -#> NQ_DENSITY="9.999998937142"/8 +#> SEWARD_ATTRACT="-6.015997150538"/5 +#> SCF_ITER="4"/8 +#> E_SCF="-76.337492748184"/4 +#> DFT_ENERGY="-9.319451198659"/6 +#> NQ_DENSITY="9.999998937057"/8 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="-0.000000000001"/2 -#> MLTPL__1[1]="0.765638166237"/2 +#> MLTPL__1[0]="-0.000000000000"/2 +#> MLTPL__1[1]="0.765640549558"/2 #> MLTPL__1[2]="0.000000000000"/2 -#> MLTPL__2[0]="1.422595296542"/2 +#> MLTPL__2[0]="1.422596030325"/2 #> MLTPL__2[1]="0.000000000001"/2 #> MLTPL__2[2]="0.000000000000"/2 -#> MLTPL__2[3]="0.002866582277"/2 +#> MLTPL__2[3]="0.002866615495"/2 #> MLTPL__2[4]="-0.000000000000"/2 -#> MLTPL__2[5]="-1.425461878819"/2 +#> MLTPL__2[5]="-1.425462645821"/2 #>> 15 #>> 17 #> POTNUC="8.906622248211"/6 @@ -212,95 +212,95 @@ #> SEWARD_ATTRACT="-6.843027465630"/5 #>> 18 #> SCF_ITER="13"/8 -#> E_SCF="-76.337211212291"/4 -#> DFT_ENERGY="-9.309242431669"/6 -#> NQ_DENSITY="9.999998484525"/8 +#> E_SCF="-76.337211212190"/4 +#> DFT_ENERGY="-9.309242431518"/6 +#> NQ_DENSITY="9.999998484440"/8 #> MLTPL__0="-0.000000000000"/2 #> MLTPL__1[0]="0.0"/2 -#> MLTPL__1[1]="0.776026766383"/2 +#> MLTPL__1[1]="0.776026766373"/2 #> MLTPL__1[2]="0.0"/2 -#> MLTPL__2[0]="1.357479583453"/2 +#> MLTPL__2[0]="1.357479583481"/2 #> MLTPL__2[1]="0.0"/2 #> MLTPL__2[2]="0.0"/2 -#> MLTPL__2[3]="0.078473549521"/2 +#> MLTPL__2[3]="0.078473549516"/2 #> MLTPL__2[4]="0.0"/2 -#> MLTPL__2[5]="-1.435953132974"/2 +#> MLTPL__2[5]="-1.435953132997"/2 #>> 19 -#> GRAD[0]="0.005332003632"/6 -#> GRAD[1]="0.007626719669"/6 -#> GRAD[2]="-0.015253439338"/6 +#> GRAD[0]="0.005332003474"/6 +#> GRAD[1]="0.007626719524"/6 +#> GRAD[2]="-0.015253439048"/6 #>> 20 #>> 21 #>> 23 -#> POTNUC="8.970231916052"/6 -#> SEWARD_MLTPL1X="1.434666974506"/5 -#> SEWARD_KINETIC="0.938615033083"/5 -#> SEWARD_ATTRACT="-6.875362611847"/5 +#> POTNUC="8.970231914467"/6 +#> SEWARD_MLTPL1X="1.434666974710"/5 +#> SEWARD_KINETIC="0.938615033071"/5 +#> SEWARD_ATTRACT="-6.875362610477"/5 #>> 24 #> SCF_ITER="8"/8 -#> E_SCF="-76.337452689539"/4 -#> DFT_ENERGY="-9.315667860056"/6 -#> NQ_DENSITY="9.999998707271"/8 +#> E_SCF="-76.337452689437"/4 +#> DFT_ENERGY="-9.315667859790"/6 +#> NQ_DENSITY="9.999998707188"/8 #> MLTPL__0="-0.000000000000"/2 #> MLTPL__1[0]="0.0"/2 -#> MLTPL__1[1]="0.769744869064"/2 +#> MLTPL__1[1]="0.769744869105"/2 #> MLTPL__1[2]="0.0"/2 -#> MLTPL__2[0]="1.396985159532"/2 +#> MLTPL__2[0]="1.396985159667"/2 #> MLTPL__2[1]="0.0"/2 #> MLTPL__2[2]="0.0"/2 -#> MLTPL__2[3]="0.032100141349"/2 +#> MLTPL__2[3]="0.032100141563"/2 #> MLTPL__2[4]="0.0"/2 -#> MLTPL__2[5]="-1.429085300882"/2 +#> MLTPL__2[5]="-1.429085301230"/2 #>> 25 -#> GRAD[0]="0.001985711160"/6 -#> GRAD[1]="0.002881622911"/6 -#> GRAD[2]="-0.005763245821"/6 +#> GRAD[0]="0.001985711133"/6 +#> GRAD[1]="0.002881622895"/6 +#> GRAD[2]="-0.005763245791"/6 #>> 26 #>> 27 #>> 29 -#> POTNUC="9.008371550964"/6 -#> SEWARD_MLTPL1X="1.436158309093"/5 -#> SEWARD_KINETIC="0.938529378274"/5 -#> SEWARD_ATTRACT="-6.894453122900"/5 +#> POTNUC="9.008371540408"/6 +#> SEWARD_MLTPL1X="1.436158307217"/5 +#> SEWARD_KINETIC="0.938529378381"/5 +#> SEWARD_ATTRACT="-6.894453120790"/5 #>> 30 #> SCF_ITER="8"/8 -#> E_SCF="-76.337492682992"/4 -#> DFT_ENERGY="-9.319519612607"/6 -#> NQ_DENSITY="9.999998929902"/8 +#> E_SCF="-76.337492682893"/4 +#> DFT_ENERGY="-9.319519611394"/6 +#> NQ_DENSITY="9.999998929820"/8 #> MLTPL__0="-0.000000000000"/2 #> MLTPL__1[0]="0.0"/2 -#> MLTPL__1[1]="0.765798884564"/2 +#> MLTPL__1[1]="0.765798886386"/2 #> MLTPL__1[2]="0.0"/2 -#> MLTPL__2[0]="1.421027026172"/2 +#> MLTPL__2[0]="1.421027013523"/2 #> MLTPL__2[1]="0.0"/2 #> MLTPL__2[2]="0.0"/2 -#> MLTPL__2[3]="0.004078205347"/2 +#> MLTPL__2[3]="0.004078218329"/2 #> MLTPL__2[4]="0.0"/2 -#> MLTPL__2[5]="-1.425105231519"/2 +#> MLTPL__2[5]="-1.425105231852"/2 #>> 31 -#> GRAD[0]="-0.000127958893"/6 -#> GRAD[1]="-0.000012214507"/6 -#> GRAD[2]="0.000024429013"/6 +#> GRAD[0]="-0.000127958617"/6 +#> GRAD[1]="-0.000012213669"/6 +#> GRAD[2]="0.000024427339"/6 #>> 32 #> GEO_ITER="3"/8 -#> POTNUC="9.007568289498"/6 -#> SEWARD_MLTPL1X="1.436628967932"/5 -#> SEWARD_KINETIC="0.938502593729"/5 -#> SEWARD_ATTRACT="-6.892965068840"/5 -#> SCF_ITER="3"/8 -#> E_SCF="-76.337492747843"/4 -#> DFT_ENERGY="-9.319471041287"/6 -#> NQ_DENSITY="9.999998937142"/8 +#> POTNUC="9.007568288109"/6 +#> SEWARD_MLTPL1X="1.436628967816"/5 +#> SEWARD_KINETIC="0.938502593735"/5 +#> SEWARD_ATTRACT="-6.892965068278"/5 +#> SCF_ITER="4"/8 +#> E_SCF="-76.337492748184"/4 +#> DFT_ENERGY="-9.319451437426"/6 +#> NQ_DENSITY="9.999998937057"/8 #> MLTPL__0="-0.000000000000"/2 #> MLTPL__1[0]="0.0"/2 -#> MLTPL__1[1]="0.765638457541"/2 +#> MLTPL__1[1]="0.765639979426"/2 #> MLTPL__1[2]="0.0"/2 -#> MLTPL__2[0]="1.422595651192"/2 +#> MLTPL__2[0]="1.422595384838"/2 #> MLTPL__2[1]="0.0"/2 #> MLTPL__2[2]="0.0"/2 -#> MLTPL__2[3]="0.002866594283"/2 +#> MLTPL__2[3]="0.002866576826"/2 #> MLTPL__2[4]="0.0"/2 -#> MLTPL__2[5]="-1.425462245475"/2 +#> MLTPL__2[5]="-1.425461961664"/2 #>> 33 #>> 34 >>EOF diff -Nru openmolcas-22.02/test/additional/247.input openmolcas-22.10/test/additional/247.input --- openmolcas-22.02/test/additional/247.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/247.input 2022-10-10 14:22:40.000000000 +0000 @@ -136,46 +136,46 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 20.10-828-gbe05a0da5 -* Linux dirac 5.10.7-3-MANJARO #1 SMP PREEMPT Fri Jan 15 21:11:34 UTC 2021 x86_64 GNU/Linux -* Tue Feb 9 13:48:13 2021 +* Molcas version 22.02-135-ge74223037 +* Linux otis 5.4.0-104-generic #118~18.04.1-Ubuntu SMP Thu Mar 3 13:53:15 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Sun Apr 3 08:58:10 2022 * #>> 1 #> SEWARD_KINETIC="17955988.950000014156"/5 #> SEWARD_ATTRACT="-168848.637428736489"/5 #> POTNUC="29.173907573667"/12 -#> SEWARD_KINETIC="552.394993687088"/5 +#> SEWARD_KINETIC="552.394993687087"/5 #> SEWARD_ATTRACT="-1058.908576735454"/5 #>> 2 #> SCF_ITER="14"/8 -#> E_SCF="-2094.329154652416"/8 +#> E_SCF="-2094.329154652365"/8 #> MLTPL__0="2"/5 #>> 3 #> RASSCF_ITER="9"/8 -#> E_RASSCF[0]="-2097.012839549608"/8 -#> E_RASSCF[1]="-2096.999839330319"/8 -#> E_RASSCF[2]="-2096.961122700750"/8 +#> E_RASSCF[0]="-2097.012839549556"/8 +#> E_RASSCF[1]="-2096.999839330268"/8 +#> E_RASSCF[2]="-2096.961122700697"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__0="-0.000000000000"/5 #>> 4 -#> E_CASPT2="-2097.033165588553"/8 +#> E_CASPT2="-2097.033165588498"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2097.020346711876"/8 +#> E_CASPT2="-2097.020346711821"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2096.982208613939"/8 +#> E_CASPT2="-2096.982208613882"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_MSPT2[0]="-2097.033165588553"/8 -#> E_MSPT2[1]="-2097.020346711876"/8 -#> E_MSPT2[2]="-2096.982208613939"/8 +#> E_MSPT2[0]="-2097.033165588498"/8 +#> E_MSPT2[1]="-2097.020346711821"/8 +#> E_MSPT2[2]="-2096.982208613882"/8 #>> 5 #> RASSCF_ITER="8"/8 -#> E_RASSCF[0]="-2097.003292228087"/8 -#> E_RASSCF[1]="-2096.972885272986"/8 -#> E_RASSCF[2]="-2096.959739520701"/8 -#> E_RASSCF[3]="-2096.925801510860"/8 -#> E_RASSCF[4]="-2096.920335697155"/8 -#> E_RASSCF[5]="-2096.888113358409"/8 +#> E_RASSCF[0]="-2097.003292228035"/8 +#> E_RASSCF[1]="-2096.972885272933"/8 +#> E_RASSCF[2]="-2096.959739520649"/8 +#> E_RASSCF[3]="-2096.925801510808"/8 +#> E_RASSCF[4]="-2096.920335697105"/8 +#> E_RASSCF[5]="-2096.888113358356"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__0="-0.000000000000"/5 @@ -183,47 +183,47 @@ #> MLTPL__0="-0.000000000000"/5 #> MLTPL__0="-0.000000000000"/5 #>> 6 -#> E_CASPT2="-2097.023933039964"/8 +#> E_CASPT2="-2097.023933039914"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2096.994601041802"/8 +#> E_CASPT2="-2096.994601041753"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2096.981694853655"/8 +#> E_CASPT2="-2096.981694853603"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2096.947775752693"/8 +#> E_CASPT2="-2096.947775752642"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2096.942852982716"/8 +#> E_CASPT2="-2096.942852982666"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2096.909048961301"/8 +#> E_CASPT2="-2096.909048961250"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_MSPT2[0]="-2097.023959595332"/8 -#> E_MSPT2[1]="-2096.994601041802"/8 -#> E_MSPT2[2]="-2096.981694853655"/8 -#> E_MSPT2[3]="-2096.947865763176"/8 -#> E_MSPT2[4]="-2096.942852982716"/8 -#> E_MSPT2[5]="-2096.908932395452"/8 +#> E_MSPT2[0]="-2097.023959595282"/8 +#> E_MSPT2[1]="-2096.994601041753"/8 +#> E_MSPT2[2]="-2096.981694853603"/8 +#> E_MSPT2[3]="-2096.947865763125"/8 +#> E_MSPT2[4]="-2096.942852982666"/8 +#> E_MSPT2[5]="-2096.908932395402"/8 #>> 7 -#> E_RASSI[0]="-2097.033165588553"/6 -#> E_RASSI[1]="-2097.020346711876"/6 -#> E_RASSI[2]="-2096.982208613939"/6 -#> E_RASSI[3]="-2097.023959595335"/6 -#> E_RASSI[4]="-2096.994601041803"/6 -#> E_RASSI[5]="-2096.981694853657"/6 -#> E_RASSI[6]="-2096.947865763178"/6 -#> E_RASSI[7]="-2096.942852982719"/6 -#> E_RASSI[8]="-2096.908932395455"/6 -#> ESO_LOW[0]="-2097.034165541781"/8 -#> ESO_LOW[1]="-2097.033478398852"/8 -#> ESO_LOW[2]="-2097.033292407878"/8 -#> ESO_LOW[3]="-2097.024230041702"/8 -#> ESO_LOW[4]="-2097.020552005804"/8 -#> ESO_LOW[5]="-2097.020104152721"/8 -#> ESO_LOW[6]="-2097.019379945404"/8 -#> ESO_LOW[7]="-2096.994730832509"/8 -#> ESO_LOW[8]="-2096.983644238273"/8 -#> ESO_LOW[9]="-2096.982273821545"/8 -#> ESO_LOW[10]="-2096.981873529306"/8 -#> ESO_LOW[11]="-2096.980132409999"/8 -#> ESO_LOW[12]="-2096.947739307707"/8 -#> ESO_LOW[13]="-2096.942782731575"/8 -#> ESO_LOW[14]="-2096.908690010199"/8 +#> E_RASSI[0]="-2097.033165588498"/6 +#> E_RASSI[1]="-2097.020346711821"/6 +#> E_RASSI[2]="-2096.982208613882"/6 +#> E_RASSI[3]="-2097.023959595284"/6 +#> E_RASSI[4]="-2096.994601041756"/6 +#> E_RASSI[5]="-2096.981694853606"/6 +#> E_RASSI[6]="-2096.947865763126"/6 +#> E_RASSI[7]="-2096.942852982669"/6 +#> E_RASSI[8]="-2096.908932395405"/6 +#> ESO_LOW[0]="-2097.034165541727"/6 +#> ESO_LOW[1]="-2097.033478398797"/6 +#> ESO_LOW[2]="-2097.033292407823"/6 +#> ESO_LOW[3]="-2097.024230041650"/6 +#> ESO_LOW[4]="-2097.020552005748"/6 +#> ESO_LOW[5]="-2097.020104152665"/6 +#> ESO_LOW[6]="-2097.019379945349"/6 +#> ESO_LOW[7]="-2096.994730832461"/6 +#> ESO_LOW[8]="-2096.983644238218"/6 +#> ESO_LOW[9]="-2096.982273821488"/6 +#> ESO_LOW[10]="-2096.981873529249"/6 +#> ESO_LOW[11]="-2096.980132409945"/6 +#> ESO_LOW[12]="-2096.947739307655"/6 +#> ESO_LOW[13]="-2096.942782731526"/6 +#> ESO_LOW[14]="-2096.908690010149"/6 >>EOF diff -Nru openmolcas-22.02/test/additional/259.input openmolcas-22.10/test/additional/259.input --- openmolcas-22.02/test/additional/259.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/259.input 2022-10-10 14:22:40.000000000 +0000 @@ -45,51 +45,51 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 18.09-531-ge0632f48 -* Linux serrano 3.13.0-162-generic #212-Ubuntu SMP Mon Oct 29 12:08:50 UTC 2018 x86_64 x86_64 x86_64 GNU/Linux -* Mon May 20 16:50:28 2019 +* Molcas version 22.02-264-gd603c8837 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Thu Apr 28 14:13:28 2022 * #>> 1 #> SEWARD_MLTPL1X="-0.000218650600"/5 -#> SEWARD_KINETIC="45717647.400000035763"/5 +#> SEWARD_KINETIC="45717647.400000043213"/5 #> SEWARD_ATTRACT="-440496.814010833565"/5 #> POTNUC="393.590698660883"/12 #> SEWARD_MLTPL1X="-0.000218650600"/5 #> SEWARD_KINETIC="1606.801716537273"/5 -#> SEWARD_ATTRACT="-2793.788494449192"/5 +#> SEWARD_ATTRACT="-2793.788494449193"/5 #>> 2 #> SCF_ITER="10"/8 -#> E_SCF="-6292.071727312546"/8 +#> E_SCF="-6292.071727308753"/8 #> MLTPL__0="-1.000000000001"/5 -#> MLTPL__1[0]="-0.000713148010"/5 -#> MLTPL__1[1]="-0.000351464057"/5 -#> MLTPL__1[2]="-0.001102187794"/5 -#> MLTPL__2[0]="1.420852192481"/5 -#> MLTPL__2[1]="-9.675840328355"/5 -#> MLTPL__2[2]="6.579988027060"/5 -#> MLTPL__2[3]="-4.158174148260"/5 -#> MLTPL__2[4]="8.750368870317"/5 -#> MLTPL__2[5]="2.737321955779"/5 -#> EF0___EL="312.391745427560"/5 +#> MLTPL__1[0]="-0.000713148011"/5 +#> MLTPL__1[1]="-0.000351464052"/5 +#> MLTPL__1[2]="-0.001102187795"/5 +#> MLTPL__2[0]="1.420852190101"/5 +#> MLTPL__2[1]="-9.675840312089"/5 +#> MLTPL__2[2]="6.579988015949"/5 +#> MLTPL__2[3]="-4.158174141201"/5 +#> MLTPL__2[4]="8.750368855590"/5 +#> MLTPL__2[5]="2.737321951101"/5 +#> EF0___EL="312.391745427349"/5 #> EF0__NUC="6.494170397932"/5 -#> EF1___EL[0]="-0.000267884975"/5 -#> EF1___EL[1]="-0.000076624302"/5 -#> EF1___EL[2]="-0.000555336916"/5 +#> EF1___EL[0]="-0.000267884977"/5 +#> EF1___EL[1]="-0.000076624300"/5 +#> EF1___EL[2]="-0.000555336915"/5 #> EF1__NUC[0]="0.000266637649"/5 #> EF1__NUC[1]="0.000075948360"/5 #> EF1__NUC[2]="0.000549104108"/5 -#> EF2___EL[0]="0.049927588042"/5 -#> EF2___EL[1]="-0.338761593131"/5 -#> EF2___EL[2]="0.234238418148"/5 -#> EF2___EL[3]="-0.148215153502"/5 -#> EF2___EL[4]="0.307325173538"/5 -#> EF2___EL[5]="-6019933.879936261103"/5 -#> EF2__NUC[0]="-0.022450907963"/5 -#> EF2__NUC[1]="0.153077060775"/5 -#> EF2__NUC[2]="-0.104612034883"/5 -#> EF2__NUC[3]="0.066139314164"/5 -#> EF2__NUC[4]="-0.138628331831"/5 -#> EF2__NUC[5]="-0.043688406201"/5 -#> CNT___EL="479051.117039113597"/5 +#> EF2___EL[0]="0.049927588195"/4 +#> EF2___EL[1]="-0.338761593809"/4 +#> EF2___EL[2]="0.234238418791"/4 +#> EF2___EL[3]="-0.148215153857"/4 +#> EF2___EL[4]="0.307325174000"/4 +#> EF2___EL[5]="-6019933.879934876226"/4 +#> EF2__NUC[0]="-0.022450907963"/4 +#> EF2__NUC[1]="0.153077060775"/4 +#> EF2__NUC[2]="-0.104612034883"/4 +#> EF2__NUC[3]="0.066139314164"/4 +#> EF2__NUC[4]="-0.138628331831"/4 +#> EF2__NUC[5]="-0.043688406201"/4 +#> CNT___EL="479051.117039003700"/5 #> CNT__NUC="0.0"/5 >>EOF diff -Nru openmolcas-22.02/test/additional/263.input openmolcas-22.10/test/additional/263.input --- openmolcas-22.02/test/additional/263.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/263.input 2022-10-10 14:22:40.000000000 +0000 @@ -47,223 +47,223 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 20.10-241-g70ed4f8b -* Linux otis 4.15.0-1073-oem #83-Ubuntu SMP Mon Feb 17 11:21:18 UTC 2020 x86_64 x86_64 x86_64 GNU/Linux -* Fri Nov 27 15:35:18 2020 +* Molcas version 22.02-260-gd39e60428 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Wed Apr 27 18:28:24 2022 * #>> 1 #> POTNUC="9.288886445353"/6 #> SEWARD_MLTPL1X="1.424778013600"/5 -#> SEWARD_KINETIC="1.395678281299"/5 -#> SEWARD_ATTRACT="-6.460774107253"/5 +#> SEWARD_KINETIC="1.395678380620"/5 +#> SEWARD_ATTRACT="-6.460774177571"/5 #>> 2 #> SCF_ITER="10"/8 -#> E_SCF="-76.010746497660"/8 +#> E_SCF="-76.010746504749"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="0.865215585111"/5 +#> MLTPL__1[1]="0.865215442259"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="1.773671900355"/5 +#> MLTPL__2[0]="1.773671333747"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.090953456801"/5 +#> MLTPL__2[3]="-0.090953375829"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-1.682718443554"/5 +#> MLTPL__2[5]="-1.682717957918"/5 #>> 3 -#> GRAD[0]="-0.000052761423"/6 -#> GRAD[1]="0.000001248941"/6 +#> GRAD[0]="-0.000052835269"/6 +#> GRAD[1]="0.000001160866"/6 #> GRAD[2]="0.0"/6 -#> GRAD[3]="0.000052761423"/6 -#> GRAD[4]="0.000001248941"/6 +#> GRAD[3]="0.000052835269"/6 +#> GRAD[4]="0.000001160866"/6 #> GRAD[5]="0.0"/6 #> GRAD[6]="0.0"/6 -#> GRAD[7]="-0.000002497881"/6 +#> GRAD[7]="-0.000002321732"/6 #> GRAD[8]="0.0"/6 #>> 4 #>> 6 #> POTNUC="9.289024321820"/6 #> SEWARD_MLTPL1X="1.422300596807"/5 -#> SEWARD_KINETIC="1.395678281299"/5 -#> SEWARD_ATTRACT="-6.477995291273"/5 +#> SEWARD_KINETIC="1.395678380620"/5 +#> SEWARD_ATTRACT="-6.477995361561"/5 #>> 7 -#> SCF_ITER="6"/8 -#> E_SCF="-76.010715505508"/8 +#> SCF_ITER="7"/8 +#> E_SCF="-76.010715513063"/8 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="-0.003617795133"/5 -#> MLTPL__1[1]="0.865206578695"/5 +#> MLTPL__1[0]="-0.003618064170"/5 +#> MLTPL__1[1]="0.865207298004"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="1.773718079953"/5 -#> MLTPL__2[1]="-0.009010796395"/5 +#> MLTPL__2[0]="1.773718749041"/5 +#> MLTPL__2[1]="-0.009012171963"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.090987632911"/5 +#> MLTPL__2[3]="-0.090987656165"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-1.682730447043"/5 +#> MLTPL__2[5]="-1.682731092876"/5 #>> 8 -#> GRAD[0]="-0.003582198932"/6 -#> GRAD[1]="-0.002695580023"/6 +#> GRAD[0]="-0.003581133878"/6 +#> GRAD[1]="-0.002693197654"/6 #> GRAD[2]="0.0"/6 -#> GRAD[3]="-0.003396628291"/6 -#> GRAD[4]="0.002616066900"/6 +#> GRAD[3]="-0.003395990987"/6 +#> GRAD[4]="0.002614151156"/6 #> GRAD[5]="0.0"/6 -#> GRAD[6]="0.006978827223"/6 -#> GRAD[7]="0.000079513123"/6 +#> GRAD[6]="0.006977124864"/6 +#> GRAD[7]="0.000079046498"/6 #> GRAD[8]="0.0"/6 #>> 9 #>> 11 #> POTNUC="9.289024321820"/6 #> SEWARD_MLTPL1X="1.427265767700"/5 -#> SEWARD_KINETIC="1.395678281299"/5 -#> SEWARD_ATTRACT="-6.443671000936"/5 +#> SEWARD_KINETIC="1.395678380620"/5 +#> SEWARD_ATTRACT="-6.443671071285"/5 #>> 12 #> SCF_ITER="6"/8 -#> E_SCF="-76.010715505964"/8 +#> E_SCF="-76.010715513053"/8 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="0.003617608979"/5 -#> MLTPL__1[1]="0.865206496944"/5 +#> MLTPL__1[0]="0.003617631969"/5 +#> MLTPL__1[1]="0.865206573545"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="1.773717980401"/5 -#> MLTPL__2[1]="0.009010868610"/5 +#> MLTPL__2[0]="1.773717972640"/5 +#> MLTPL__2[1]="0.009011105246"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.090987611482"/5 +#> MLTPL__2[3]="-0.090987586461"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-1.682730368919"/5 +#> MLTPL__2[5]="-1.682730386179"/5 #>> 13 -#> GRAD[0]="0.003396061972"/6 -#> GRAD[1]="0.002614077006"/6 +#> GRAD[0]="0.003396023512"/6 +#> GRAD[1]="0.002614037184"/6 #> GRAD[2]="0.0"/6 -#> GRAD[3]="0.003581029517"/6 -#> GRAD[4]="-0.002693110379"/6 +#> GRAD[3]="0.003581004991"/6 +#> GRAD[4]="-0.002693067981"/6 #> GRAD[5]="0.0"/6 -#> GRAD[6]="-0.006977091488"/6 -#> GRAD[7]="0.000079033373"/6 +#> GRAD[6]="-0.006977028503"/6 +#> GRAD[7]="0.000079030797"/6 #> GRAD[8]="0.0"/6 #>> 14 #>> 16 #> POTNUC="9.258915804308"/6 #> SEWARD_MLTPL1X="1.426543884189"/5 -#> SEWARD_KINETIC="1.395678281299"/5 -#> SEWARD_ATTRACT="-6.445977450732"/5 +#> SEWARD_KINETIC="1.395678380620"/5 +#> SEWARD_ATTRACT="-6.445977521075"/5 #>> 17 #> SCF_ITER="7"/8 -#> E_SCF="-76.010724471716"/8 +#> E_SCF="-76.010724478795"/8 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="0.000005671007"/5 -#> MLTPL__1[1]="0.868478637138"/5 +#> MLTPL__1[0]="0.000005671012"/5 +#> MLTPL__1[1]="0.868478596281"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="1.766775418008"/5 -#> MLTPL__2[1]="-0.000010450744"/5 +#> MLTPL__2[0]="1.766775285412"/5 +#> MLTPL__2[1]="-0.000010450662"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.078569470957"/5 +#> MLTPL__2[3]="-0.078569437290"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-1.688205947050"/5 +#> MLTPL__2[5]="-1.688205848123"/5 #>> 18 -#> GRAD[0]="0.002412907532"/6 -#> GRAD[1]="0.002381329111"/6 +#> GRAD[0]="0.002412910562"/6 +#> GRAD[1]="0.002381328999"/6 #> GRAD[2]="0.0"/6 -#> GRAD[3]="-0.002413988936"/6 -#> GRAD[4]="0.002380831584"/6 +#> GRAD[3]="-0.002413992054"/6 +#> GRAD[4]="0.002380831541"/6 #> GRAD[5]="0.0"/6 -#> GRAD[6]="0.000001081404"/6 -#> GRAD[7]="-0.004762160694"/6 +#> GRAD[6]="0.000001081492"/6 +#> GRAD[7]="-0.004762160540"/6 #> GRAD[8]="0.0"/6 #>> 19 #>> 21 #> POTNUC="9.319062099098"/6 #> SEWARD_MLTPL1X="1.422986567398"/5 -#> SEWARD_KINETIC="1.395678281299"/5 -#> SEWARD_ATTRACT="-6.475664683666"/5 +#> SEWARD_KINETIC="1.395678380620"/5 +#> SEWARD_ATTRACT="-6.475664753959"/5 #>> 22 #> SCF_ITER="8"/8 -#> E_SCF="-76.010723830953"/8 +#> E_SCF="-76.010723838049"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.000005343237"/5 -#> MLTPL__1[1]="0.861933869688"/5 +#> MLTPL__1[1]="0.861933829423"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="1.780394620317"/5 -#> MLTPL__2[1]="-0.000011676606"/5 +#> MLTPL__2[0]="1.780394489040"/5 +#> MLTPL__2[1]="-0.000011676605"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.103190623572"/5 +#> MLTPL__2[3]="-0.103190589818"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-1.677203996745"/5 +#> MLTPL__2[5]="-1.677203899222"/5 #>> 23 -#> GRAD[0]="-0.002592534862"/6 -#> GRAD[1]="-0.002412330379"/6 +#> GRAD[0]="-0.002592531796"/6 +#> GRAD[1]="-0.002412330558"/6 #> GRAD[2]="0.0"/6 -#> GRAD[3]="0.002592504970"/6 -#> GRAD[4]="-0.002412362524"/6 +#> GRAD[3]="0.002592501904"/6 +#> GRAD[4]="-0.002412362703"/6 #> GRAD[5]="0.0"/6 #> GRAD[6]="0.000000029891"/6 -#> GRAD[7]="0.004824692903"/6 +#> GRAD[7]="0.004824693262"/6 #> GRAD[8]="0.0"/6 #>> 24 #>> 26 #> POTNUC="9.267874444402"/6 #> SEWARD_MLTPL1X="1.432384888686"/5 -#> SEWARD_KINETIC="1.395678281299"/5 -#> SEWARD_ATTRACT="-6.449600739529"/5 +#> SEWARD_KINETIC="1.395678380620"/5 +#> SEWARD_ATTRACT="-6.449600809864"/5 #>> 27 #> SCF_ITER="7"/8 -#> E_SCF="-76.010729841940"/8 +#> E_SCF="-76.010729848981"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.000005347336"/5 -#> MLTPL__1[1]="0.862594107385"/5 +#> MLTPL__1[1]="0.862594066379"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="1.800222712804"/5 -#> MLTPL__2[1]="-0.000011843526"/5 +#> MLTPL__2[0]="1.800222580007"/5 +#> MLTPL__2[1]="-0.000011843525"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.110290538648"/5 +#> MLTPL__2[3]="-0.110290504465"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-1.689932174156"/5 +#> MLTPL__2[5]="-1.689932075541"/5 #>> 28 -#> GRAD[0]="0.002594654894"/6 -#> GRAD[1]="0.000727719451"/6 +#> GRAD[0]="0.002594657949"/6 +#> GRAD[1]="0.000727719267"/6 #> GRAD[2]="0.0"/6 -#> GRAD[3]="-0.002594645871"/6 -#> GRAD[4]="0.000727751621"/6 +#> GRAD[3]="-0.002594648926"/6 +#> GRAD[4]="0.000727751436"/6 #> GRAD[5]="0.0"/6 #> GRAD[6]="-0.000000009023"/6 -#> GRAD[7]="-0.001455471072"/6 +#> GRAD[7]="-0.001455470704"/6 #> GRAD[8]="0.0"/6 #>> 29 #>> 31 #> POTNUC="9.310002230095"/6 #> SEWARD_MLTPL1X="1.417170052340"/5 -#> SEWARD_KINETIC="1.395678281299"/5 -#> SEWARD_ATTRACT="-6.472004659210"/5 +#> SEWARD_KINETIC="1.395678380620"/5 +#> SEWARD_ATTRACT="-6.472004729511"/5 #>> 32 #> SCF_ITER="7"/8 -#> E_SCF="-76.010728076406"/8 +#> E_SCF="-76.010728083541"/8 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="0.000005379695"/5 -#> MLTPL__1[1]="0.867813986319"/5 +#> MLTPL__1[0]="0.000005379694"/5 +#> MLTPL__1[1]="0.867813946209"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="1.747248954213"/5 -#> MLTPL__2[1]="-0.000011275913"/5 +#> MLTPL__2[0]="1.747248823214"/5 +#> MLTPL__2[1]="-0.000011275912"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.071700963989"/5 +#> MLTPL__2[3]="-0.071700930781"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-1.675547990223"/5 +#> MLTPL__2[5]="-1.675547892433"/5 #>> 33 -#> GRAD[0]="-0.002730935428"/6 -#> GRAD[1]="-0.000758302666"/6 +#> GRAD[0]="-0.002730932392"/6 +#> GRAD[1]="-0.000758302771"/6 #> GRAD[2]="0.0"/6 -#> GRAD[3]="0.002730926026"/6 -#> GRAD[4]="-0.000758336525"/6 +#> GRAD[3]="0.002730922990"/6 +#> GRAD[4]="-0.000758336629"/6 #> GRAD[5]="0.0"/6 #> GRAD[6]="0.000000009402"/6 -#> GRAD[7]="0.001516639191"/6 +#> GRAD[7]="0.001516639400"/6 #> GRAD[8]="0.0"/6 #>> 34 -#> NUMERICAL_HESSIAN[0]="0.619964039424"/2 -#> NUMERICAL_HESSIAN[1]="0.000006548033"/2 -#> NUMERICAL_HESSIAN[2]="-0.000007086187"/2 -#> NUMERICAL_HESSIAN[3]="0.000006548033"/2 -#> NUMERICAL_HESSIAN[4]="0.446933516878"/2 -#> NUMERICAL_HESSIAN[5]="0.205661020259"/2 -#> NUMERICAL_HESSIAN[6]="-0.000007086187"/2 -#> NUMERICAL_HESSIAN[7]="0.205661020259"/2 -#> NUMERICAL_HESSIAN[8]="0.350873713606"/2 -#> NUMERICAL_IR_INTENSITIES[0]="107.253372997568"/2 -#> NUMERICAL_IR_INTENSITIES[1]="18.207772373844"/2 -#> NUMERICAL_IR_INTENSITIES[2]="58.028576994280"/2 +#> NUMERICAL_HESSIAN[0]="0.619856910659"/2 +#> NUMERICAL_HESSIAN[1]="0.000017182793"/2 +#> NUMERICAL_HESSIAN[2]="-0.000002935869"/2 +#> NUMERICAL_HESSIAN[3]="0.000017182793"/2 +#> NUMERICAL_HESSIAN[4]="0.446933522750"/2 +#> NUMERICAL_HESSIAN[5]="0.205661017462"/2 +#> NUMERICAL_HESSIAN[6]="-0.000002935869"/2 +#> NUMERICAL_HESSIAN[7]="0.205661017462"/2 +#> NUMERICAL_HESSIAN[8]="0.350873717770"/2 +#> NUMERICAL_IR_INTENSITIES[0]="107.253381985764"/2 +#> NUMERICAL_IR_INTENSITIES[1]="18.207762426561"/2 +#> NUMERICAL_IR_INTENSITIES[2]="58.035775761920"/2 >>EOF diff -Nru openmolcas-22.02/test/additional/280.input openmolcas-22.10/test/additional/280.input --- openmolcas-22.02/test/additional/280.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/280.input 2022-10-10 14:22:40.000000000 +0000 @@ -92,9 +92,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-943-g4c2682958 -* Linux lucifer 5.13.0-27-generic #29~20.04.1-Ubuntu SMP Fri Jan 14 00:32:30 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux -* Sat Feb 5 17:07:33 2022 +* Molcas version 22.02-260-gd39e60428 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Wed Apr 27 18:28:24 2022 * #>> 1 #> POTNUC="204.360444202574"/12 @@ -103,37 +103,37 @@ #> SEWARD_ATTRACT="-43.811893469875"/5 #>> 2 #> SCF_ITER="13"/8 -#> E_SCF="-229.916038160562"/4 -#> DFT_ENERGY="-32.558348812161"/6 -#> NQ_DENSITY="42.000049376079"/8 +#> E_SCF="-229.916038160519"/4 +#> DFT_ENERGY="-32.558348812126"/6 +#> NQ_DENSITY="42.000049375938"/8 #> MLTPL__0="-0.000000000001"/2 #> MLTPL__1[0]="0.0"/2 #> MLTPL__1[1]="0.0"/2 #> MLTPL__1[2]="0.0"/2 -#> MLTPL__2[0]="2.778981577167"/2 +#> MLTPL__2[0]="2.778981577305"/2 #> MLTPL__2[1]="0.0"/2 #> MLTPL__2[2]="0.0"/2 -#> MLTPL__2[3]="2.778566539118"/2 +#> MLTPL__2[3]="2.778566539322"/2 #> MLTPL__2[4]="0.0"/2 -#> MLTPL__2[5]="-5.557548116286"/2 +#> MLTPL__2[5]="-5.557548116627"/2 #>> 3 #> POTNUC="204.360444202574"/12 #> SEWARD_MLTPL1X="-2.273534915151"/5 #> SEWARD_KINETIC="16.088361063390"/5 #> SEWARD_ATTRACT="-43.811893469875"/5 #>> 4 -#> SCF_ITER="2"/8 -#> E_SCF="-229.916038160623"/4 -#> DFT_ENERGY="-32.558359930879"/6 -#> NQ_DENSITY="42.000049375754"/8 +#> SCF_ITER="3"/8 +#> E_SCF="-229.916038160709"/4 +#> DFT_ENERGY="-32.558361030765"/6 +#> NQ_DENSITY="42.000049375669"/8 #> MLTPL__0="-0.000000000001"/2 #> MLTPL__1[0]="0.0"/2 #> MLTPL__1[1]="0.0"/2 #> MLTPL__1[2]="0.0"/2 -#> MLTPL__2[0]="2.778832778630"/2 +#> MLTPL__2[0]="2.778871585179"/2 #> MLTPL__2[1]="0.0"/2 #> MLTPL__2[2]="0.0"/2 -#> MLTPL__2[3]="2.778637010613"/2 +#> MLTPL__2[3]="2.778624203144"/2 #> MLTPL__2[4]="0.0"/2 -#> MLTPL__2[5]="-5.557469789243"/2 +#> MLTPL__2[5]="-5.557495788323"/2 >>EOF diff -Nru openmolcas-22.02/test/additional/285.input openmolcas-22.10/test/additional/285.input --- openmolcas-22.02/test/additional/285.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/285.input 2022-10-10 14:22:40.000000000 +0000 @@ -82,9 +82,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-943-g4c2682958 -* Linux lucifer 5.13.0-27-generic #29~20.04.1-Ubuntu SMP Fri Jan 14 00:32:30 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux -* Sat Feb 5 17:07:33 2022 +* Molcas version 22.02-260-gd39e60428 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Wed Apr 27 18:28:24 2022 * #>> 1 #> POTNUC="12.034011116317"/12 @@ -93,37 +93,37 @@ #> SEWARD_ATTRACT="-48.236916638222"/5 #>> 2 #> SCF_ITER="11"/8 -#> E_SCF="-56.007563003995"/4 -#> DFT_ENERGY="-7.544326622653"/6 -#> NQ_DENSITY="9.999996836902"/8 +#> E_SCF="-56.007563003983"/4 +#> DFT_ENERGY="-7.544326622643"/6 +#> NQ_DENSITY="9.999996836860"/8 #> MLTPL__0="-0.000000000000"/2 #> MLTPL__1[0]="0.000000536414"/2 #> MLTPL__1[1]="0.0"/2 -#> MLTPL__1[2]="-0.764630001151"/2 -#> MLTPL__2[0]="0.886062648875"/2 +#> MLTPL__1[2]="-0.764630001153"/2 +#> MLTPL__2[0]="0.886062648879"/2 #> MLTPL__2[1]="0.0"/2 -#> MLTPL__2[2]="-0.000002684558"/2 -#> MLTPL__2[3]="0.886060473431"/2 +#> MLTPL__2[2]="-0.000002684557"/2 +#> MLTPL__2[3]="0.886060473433"/2 #> MLTPL__2[4]="0.0"/2 -#> MLTPL__2[5]="-1.772123122306"/2 +#> MLTPL__2[5]="-1.772123122312"/2 #>> 3 #> POTNUC="12.034011116317"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_KINETIC="22.226916473236"/5 #> SEWARD_ATTRACT="-48.236916638222"/5 #>> 4 -#> SCF_ITER="2"/8 -#> E_SCF="-56.007563003964"/4 -#> DFT_ENERGY="-7.544328949306"/6 -#> NQ_DENSITY="9.999996836909"/8 +#> SCF_ITER="3"/8 +#> E_SCF="-56.007563004002"/4 +#> DFT_ENERGY="-7.544324285734"/6 +#> NQ_DENSITY="9.999996836855"/8 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="0.000001090781"/2 +#> MLTPL__1[0]="0.000000890937"/2 #> MLTPL__1[1]="0.0"/2 -#> MLTPL__1[2]="-0.764635184623"/2 -#> MLTPL__2[0]="0.886066220493"/2 +#> MLTPL__1[2]="-0.764633857452"/2 +#> MLTPL__2[0]="0.886065239207"/2 #> MLTPL__2[1]="0.0"/2 -#> MLTPL__2[2]="-0.000002812835"/2 -#> MLTPL__2[3]="0.886063659687"/2 +#> MLTPL__2[2]="-0.000002740701"/2 +#> MLTPL__2[3]="0.886062857027"/2 #> MLTPL__2[4]="0.0"/2 -#> MLTPL__2[5]="-1.772129880180"/2 +#> MLTPL__2[5]="-1.772128096235"/2 >>EOF diff -Nru openmolcas-22.02/test/additional/294.input openmolcas-22.10/test/additional/294.input --- openmolcas-22.02/test/additional/294.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/294.input 2022-10-10 14:22:40.000000000 +0000 @@ -133,46 +133,46 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 18.09-1063-g2a1e081d -* Linux serrano 3.13.0-162-generic #212-Ubuntu SMP Mon Oct 29 12:08:50 UTC 2018 x86_64 x86_64 x86_64 GNU/Linux -* Thu Oct 31 11:50:46 2019 +* Molcas version 22.02-135-ge74223037 +* Linux otis 5.4.0-104-generic #118~18.04.1-Ubuntu SMP Thu Mar 3 13:53:15 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Sun Apr 3 08:58:10 2022 * #>> 1 #> SEWARD_KINETIC="17955988.950000014156"/5 #> SEWARD_ATTRACT="-168848.637428736489"/5 #> POTNUC="29.173907573667"/12 -#> SEWARD_KINETIC="552.394993687088"/5 +#> SEWARD_KINETIC="552.394993687087"/5 #> SEWARD_ATTRACT="-1058.908576735454"/5 #>> 2 #> SCF_ITER="14"/8 -#> E_SCF="-2094.329154652436"/8 +#> E_SCF="-2094.329154652365"/8 #> MLTPL__0="2"/5 #>> 3 #> RASSCF_ITER="9"/8 -#> E_RASSCF[0]="-2097.012839549629"/8 -#> E_RASSCF[1]="-2096.999839330342"/8 -#> E_RASSCF[2]="-2096.961122700772"/8 +#> E_RASSCF[0]="-2097.012839549556"/8 +#> E_RASSCF[1]="-2096.999839330268"/8 +#> E_RASSCF[2]="-2096.961122700697"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__0="-0.000000000000"/5 #>> 4 -#> E_CASPT2="-2097.031303739340"/8 +#> E_CASPT2="-2097.031303739266"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2097.018462978152"/8 +#> E_CASPT2="-2097.018462978077"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2096.980256994515"/8 +#> E_CASPT2="-2096.980256994440"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_MSPT2[0]="-2097.031303739340"/8 -#> E_MSPT2[1]="-2097.018462978152"/8 -#> E_MSPT2[2]="-2096.980256994515"/8 +#> E_MSPT2[0]="-2097.031303739266"/8 +#> E_MSPT2[1]="-2097.018462978077"/8 +#> E_MSPT2[2]="-2096.980256994440"/8 #>> 5 #> RASSCF_ITER="8"/8 -#> E_RASSCF[0]="-2097.003292228107"/8 -#> E_RASSCF[1]="-2096.972885273006"/8 -#> E_RASSCF[2]="-2096.959739520722"/8 -#> E_RASSCF[3]="-2096.925801510880"/8 -#> E_RASSCF[4]="-2096.920335697174"/8 -#> E_RASSCF[5]="-2096.888113358429"/8 +#> E_RASSCF[0]="-2097.003292228035"/8 +#> E_RASSCF[1]="-2096.972885272933"/8 +#> E_RASSCF[2]="-2096.959739520649"/8 +#> E_RASSCF[3]="-2096.925801510808"/8 +#> E_RASSCF[4]="-2096.920335697105"/8 +#> E_RASSCF[5]="-2096.888113358356"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__0="-0.000000000000"/5 @@ -180,47 +180,47 @@ #> MLTPL__0="-0.000000000000"/5 #> MLTPL__0="-0.000000000000"/5 #>> 6 -#> E_CASPT2="-2097.022011068239"/8 +#> E_CASPT2="-2097.022011068163"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2096.992806609835"/8 +#> E_CASPT2="-2096.992806609760"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2096.979872244412"/8 +#> E_CASPT2="-2096.979872244336"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2096.946033196387"/8 +#> E_CASPT2="-2096.946033196311"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2096.940966505324"/8 +#> E_CASPT2="-2096.940966505247"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2096.906953848070"/8 +#> E_CASPT2="-2096.906953847995"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_MSPT2[0]="-2097.022028560401"/8 -#> E_MSPT2[1]="-2096.992806609835"/8 -#> E_MSPT2[2]="-2096.979872244412"/8 -#> E_MSPT2[3]="-2096.946058959306"/8 -#> E_MSPT2[4]="-2096.940966505324"/8 -#> E_MSPT2[5]="-2096.906910592990"/8 +#> E_MSPT2[0]="-2097.022028560324"/8 +#> E_MSPT2[1]="-2096.992806609760"/8 +#> E_MSPT2[2]="-2096.979872244336"/8 +#> E_MSPT2[3]="-2096.946058959229"/8 +#> E_MSPT2[4]="-2096.940966505247"/8 +#> E_MSPT2[5]="-2096.906910592915"/8 #>> 7 -#> E_RASSI[0]="-2097.031303739340"/6 -#> E_RASSI[1]="-2097.018462978152"/6 -#> E_RASSI[2]="-2096.980256994515"/6 -#> E_RASSI[3]="-2097.022028560401"/6 -#> E_RASSI[4]="-2096.992806609835"/6 -#> E_RASSI[5]="-2096.979872244412"/6 -#> E_RASSI[6]="-2096.946058959306"/6 -#> E_RASSI[7]="-2096.940966505324"/6 -#> E_RASSI[8]="-2096.906910592990"/6 -#> ESO_LOW[0]="-2097.032296952529"/8 -#> ESO_LOW[1]="-2097.031616085946"/8 -#> ESO_LOW[2]="-2097.031430510849"/8 -#> ESO_LOW[3]="-2097.022312861375"/8 -#> ESO_LOW[4]="-2097.018668605807"/8 -#> ESO_LOW[5]="-2097.018220871995"/8 -#> ESO_LOW[6]="-2097.017489231669"/8 -#> ESO_LOW[7]="-2096.992932767603"/8 -#> ESO_LOW[8]="-2096.981748663323"/8 -#> ESO_LOW[9]="-2096.980321601647"/8 -#> ESO_LOW[10]="-2096.979925209091"/8 -#> ESO_LOW[11]="-2096.978253804095"/8 -#> ESO_LOW[12]="-2096.945933370549"/8 -#> ESO_LOW[13]="-2096.940896264875"/8 -#> ESO_LOW[14]="-2096.906667806935"/8 +#> E_RASSI[0]="-2097.031303739266"/6 +#> E_RASSI[1]="-2097.018462978077"/6 +#> E_RASSI[2]="-2096.980256994440"/6 +#> E_RASSI[3]="-2097.022028560324"/6 +#> E_RASSI[4]="-2096.992806609760"/6 +#> E_RASSI[5]="-2096.979872244336"/6 +#> E_RASSI[6]="-2096.946058959229"/6 +#> E_RASSI[7]="-2096.940966505247"/6 +#> E_RASSI[8]="-2096.906910592915"/6 +#> ESO_LOW[0]="-2097.032296952455"/6 +#> ESO_LOW[1]="-2097.031616085872"/6 +#> ESO_LOW[2]="-2097.031430510775"/6 +#> ESO_LOW[3]="-2097.022312861299"/6 +#> ESO_LOW[4]="-2097.018668605733"/6 +#> ESO_LOW[5]="-2097.018220871920"/6 +#> ESO_LOW[6]="-2097.017489231594"/6 +#> ESO_LOW[7]="-2096.992932767528"/6 +#> ESO_LOW[8]="-2096.981748663247"/6 +#> ESO_LOW[9]="-2096.980321601572"/6 +#> ESO_LOW[10]="-2096.979925209016"/6 +#> ESO_LOW[11]="-2096.978253804020"/6 +#> ESO_LOW[12]="-2096.945933370473"/6 +#> ESO_LOW[13]="-2096.940896264799"/6 +#> ESO_LOW[14]="-2096.906667806859"/6 >>EOF diff -Nru openmolcas-22.02/test/additional/296.input openmolcas-22.10/test/additional/296.input --- openmolcas-22.02/test/additional/296.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/296.input 2022-10-10 14:22:40.000000000 +0000 @@ -41,9 +41,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-943-g4c2682958 -* Linux lucifer 5.13.0-27-generic #29~20.04.1-Ubuntu SMP Fri Jan 14 00:32:30 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux -* Sat Feb 5 17:07:33 2022 +* Molcas version 22.02-260-gd39e60428 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Wed Apr 27 18:28:24 2022 * #>> 1 #> POTNUC="8.906622248211"/6 @@ -52,110 +52,110 @@ #> SEWARD_ATTRACT="-5.969592796903"/5 #>> 2 #> SCF_ITER="13"/8 -#> E_SCF="-76.337211212291"/4 -#> DFT_ENERGY="-9.309242428603"/6 -#> NQ_DENSITY="9.999998484524"/8 +#> E_SCF="-76.337211212190"/4 +#> DFT_ENERGY="-9.309242428452"/6 +#> NQ_DENSITY="9.999998484440"/8 #> MLTPL__0="-0.000000000000"/2 #> MLTPL__1[0]="0.000000000001"/2 -#> MLTPL__1[1]="0.776026763632"/2 +#> MLTPL__1[1]="0.776026763622"/2 #> MLTPL__1[2]="0.000000000000"/2 -#> MLTPL__2[0]="1.357479584489"/2 +#> MLTPL__2[0]="1.357479584517"/2 #> MLTPL__2[1]="0.000000000000"/2 #> MLTPL__2[2]="0.000000000000"/2 -#> MLTPL__2[3]="0.078473548043"/2 +#> MLTPL__2[3]="0.078473548037"/2 #> MLTPL__2[4]="-0.000000000000"/2 -#> MLTPL__2[5]="-1.435953132532"/2 +#> MLTPL__2[5]="-1.435953132554"/2 #>> 3 -#> GRAD[0]="0.005332002448"/6 -#> GRAD[1]="0.007626717708"/6 +#> GRAD[0]="0.005332002290"/6 +#> GRAD[1]="0.007626717563"/6 #> GRAD[2]="0.0"/6 -#> GRAD[3]="-0.005332002447"/6 -#> GRAD[4]="0.007626717707"/6 +#> GRAD[3]="-0.005332002290"/6 +#> GRAD[4]="0.007626717563"/6 #> GRAD[5]="0.000000000000"/6 #> GRAD[6]="-0.000000000000"/6 -#> GRAD[7]="-0.015253435415"/6 +#> GRAD[7]="-0.015253435126"/6 #> GRAD[8]="-0.000000000000"/6 #>> 4 #>> 6 -#> POTNUC="8.970231900794"/6 -#> SEWARD_MLTPL1X="1.434666973165"/5 +#> POTNUC="8.970231899210"/6 +#> SEWARD_MLTPL1X="1.434666973369"/5 #> SEWARD_KINETIC="0.969225931578"/5 -#> SEWARD_ATTRACT="-5.998910139472"/5 +#> SEWARD_ATTRACT="-5.998910138709"/5 #>> 7 #> SCF_ITER="8"/8 -#> E_SCF="-76.337452689505"/4 -#> DFT_ENERGY="-9.315667858004"/6 -#> NQ_DENSITY="9.999998707271"/8 +#> E_SCF="-76.337452689404"/4 +#> DFT_ENERGY="-9.315667857737"/6 +#> NQ_DENSITY="9.999998707188"/8 #> MLTPL__0="-0.000000000000"/2 #> MLTPL__1[0]="-0.000000000001"/2 -#> MLTPL__1[1]="0.769744870938"/2 +#> MLTPL__1[1]="0.769744870980"/2 #> MLTPL__1[2]="0.000000000000"/2 -#> MLTPL__2[0]="1.396985146749"/2 +#> MLTPL__2[0]="1.396985146884"/2 #> MLTPL__2[1]="-0.000000000001"/2 #> MLTPL__2[2]="0.000000000000"/2 -#> MLTPL__2[3]="0.032100155263"/2 +#> MLTPL__2[3]="0.032100155476"/2 #> MLTPL__2[4]="-0.000000000000"/2 -#> MLTPL__2[5]="-1.429085302012"/2 +#> MLTPL__2[5]="-1.429085302360"/2 #>> 8 -#> GRAD[0]="0.001985711646"/6 -#> GRAD[1]="0.002881623998"/6 +#> GRAD[0]="0.001985711619"/6 +#> GRAD[1]="0.002881623983"/6 #> GRAD[2]="0.0"/6 -#> GRAD[3]="-0.001985711646"/6 -#> GRAD[4]="0.002881623998"/6 +#> GRAD[3]="-0.001985711619"/6 +#> GRAD[4]="0.002881623983"/6 #> GRAD[5]="0.000000000000"/6 #> GRAD[6]="0.000000000000"/6 -#> GRAD[7]="-0.005763247997"/6 +#> GRAD[7]="-0.005763247966"/6 #> GRAD[8]="-0.000000000000"/6 #>> 9 #>> 11 -#> POTNUC="9.008371502487"/6 -#> SEWARD_MLTPL1X="1.436158295762"/5 +#> POTNUC="9.008371491690"/6 +#> SEWARD_MLTPL1X="1.436158293826"/5 #> SEWARD_KINETIC="0.969225931578"/5 -#> SEWARD_ATTRACT="-6.016430842054"/5 +#> SEWARD_ATTRACT="-6.016430837295"/5 #>> 12 #> SCF_ITER="8"/8 -#> E_SCF="-76.337492682990"/4 -#> DFT_ENERGY="-9.319519607193"/6 -#> NQ_DENSITY="9.999998929902"/8 +#> E_SCF="-76.337492682891"/4 +#> DFT_ENERGY="-9.319519605954"/6 +#> NQ_DENSITY="9.999998929820"/8 #> MLTPL__0="-0.000000000000"/2 #> MLTPL__1[0]="-0.000000000001"/2 -#> MLTPL__1[1]="0.765798895162"/2 +#> MLTPL__1[1]="0.765798897033"/2 #> MLTPL__1[2]="0.000000000000"/2 -#> MLTPL__2[0]="1.421026948375"/2 +#> MLTPL__2[0]="1.421026935368"/2 #> MLTPL__2[1]="-0.000000000000"/2 #> MLTPL__2[2]="0.000000000000"/2 -#> MLTPL__2[3]="0.004078281890"/2 +#> MLTPL__2[3]="0.004078295229"/2 #> MLTPL__2[4]="-0.000000000000"/2 -#> MLTPL__2[5]="-1.425105230266"/2 +#> MLTPL__2[5]="-1.425105230597"/2 #>> 13 -#> GRAD[0]="-0.000127957690"/6 -#> GRAD[1]="-0.000012209741"/6 +#> GRAD[0]="-0.000127957405"/6 +#> GRAD[1]="-0.000012208881"/6 #> GRAD[2]="0.0"/6 -#> GRAD[3]="0.000127957688"/6 -#> GRAD[4]="-0.000012209740"/6 +#> GRAD[3]="0.000127957404"/6 +#> GRAD[4]="-0.000012208880"/6 #> GRAD[5]="0.000000000000"/6 #> GRAD[6]="0.000000000001"/6 -#> GRAD[7]="0.000024419482"/6 +#> GRAD[7]="0.000024417760"/6 #> GRAD[8]="-0.000000000000"/6 #>> 14 #> GEO_ITER="3"/8 -#> POTNUC="9.007568291203"/6 -#> SEWARD_MLTPL1X="1.436628966103"/5 +#> POTNUC="9.007568289828"/6 +#> SEWARD_MLTPL1X="1.436628965978"/5 #> SEWARD_KINETIC="0.969225931578"/5 -#> SEWARD_ATTRACT="-6.015997151160"/5 -#> SCF_ITER="3"/8 -#> E_SCF="-76.337492747844"/4 -#> DFT_ENERGY="-9.319471036347"/6 -#> NQ_DENSITY="9.999998937142"/8 +#> SEWARD_ATTRACT="-6.015997150538"/5 +#> SCF_ITER="4"/8 +#> E_SCF="-76.337492748184"/4 +#> DFT_ENERGY="-9.319451198659"/6 +#> NQ_DENSITY="9.999998937057"/8 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="-0.000000000001"/2 -#> MLTPL__1[1]="0.765638166237"/2 +#> MLTPL__1[0]="-0.000000000000"/2 +#> MLTPL__1[1]="0.765640549558"/2 #> MLTPL__1[2]="0.000000000000"/2 -#> MLTPL__2[0]="1.422595296542"/2 +#> MLTPL__2[0]="1.422596030325"/2 #> MLTPL__2[1]="0.000000000001"/2 #> MLTPL__2[2]="0.000000000000"/2 -#> MLTPL__2[3]="0.002866582277"/2 +#> MLTPL__2[3]="0.002866615495"/2 #> MLTPL__2[4]="-0.000000000000"/2 -#> MLTPL__2[5]="-1.425461878819"/2 +#> MLTPL__2[5]="-1.425462645821"/2 #>> 15 >>EOF diff -Nru openmolcas-22.02/test/additional/313.input openmolcas-22.10/test/additional/313.input --- openmolcas-22.02/test/additional/313.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/313.input 2022-10-10 14:22:40.000000000 +0000 @@ -49,6 +49,7 @@ Inactive=2 0 0 0 Ras2=4 1 0 1 Nactel=8 0 0 +CMSO=Jacobi CMSI &MCPDFT @@ -118,9 +119,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-532-g47fe76cae -* Linux lucifer 5.11.0-43-generic #47~20.04.2-Ubuntu SMP Mon Dec 13 11:06:56 UTC 2021 x86_64 x86_64 x86_64 GNU/Linux -* Sun Jan 9 18:03:04 2022 +* Molcas version 22.02-124-gb10fe57 +* Linux ln1001 3.10.0-1160.53.1.el7.x86_64 #1 SMP Fri Jan 14 13:59:45 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Fri Apr 1 17:20:28 2022 * #>> 1 #> POTNUC="5.495301805531"/12 @@ -131,32 +132,32 @@ #> SEWARD_ATTRACT="-9.814648561086"/5 #>> 3 #> RASSCF_ITER="7"/8 -#> E_RASSCF[0]="-105.318013661698"/8 +#> E_RASSCF[0]="-105.318013661699"/8 #> E_RASSCF[1]="-105.242083440523"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 -#> MLTPL__1[2]="0.402171577775"/5 -#> MLTPL__2[0]="-1.649985900278"/5 +#> MLTPL__1[2]="0.402171577774"/5 +#> MLTPL__2[0]="-1.649985900275"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-1.649985900278"/5 +#> MLTPL__2[3]="-1.649985900275"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="3.299971800556"/5 -#> MLTPL__0="0.0"/5 +#> MLTPL__2[5]="3.299971800550"/5 +#> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 -#> MLTPL__1[2]="-0.232099108159"/5 -#> MLTPL__2[0]="3.307576541734"/5 +#> MLTPL__1[2]="-0.232099108158"/5 +#> MLTPL__2[0]="3.307576541732"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="3.307576541734"/5 +#> MLTPL__2[3]="3.307576541732"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-6.615153083469"/5 +#> MLTPL__2[5]="-6.615153083463"/5 #>> 4 #> E_RASSCF[0]="-105.295678254937"/8 #> E_RASSCF[1]="-105.264418847284"/8 -#> MLTPL__0="-0.000000000000"/5 +#> MLTPL__0="0.0"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="1.973382613107"/5 @@ -166,7 +167,7 @@ #> MLTPL__2[3]="-5.605589425190"/5 #> MLTPL__2[4]="0.0"/5 #> MLTPL__2[5]="11.211178850380"/5 -#> MLTPL__0="-0.000000000000"/5 +#> MLTPL__0="0.0"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="-1.803310143490"/5 @@ -175,74 +176,74 @@ #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="7.263180066647"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-14.526360133293"/5 +#> MLTPL__2[5]="-14.526360133294"/5 #>> 5 -#> DENS_TT="12.000001057099"/6 -#> DENS_A1="6.000000528549"/6 -#> DENS_B1="6.000000528549"/6 -#> DENS_A2="6.803763291200"/6 -#> DENS_B2="5.196237765899"/6 +#> DENS_TT="12.000001057075"/6 +#> DENS_A1="6.000000528537"/6 +#> DENS_B1="6.000000528537"/6 +#> DENS_A2="6.803763291181"/6 +#> DENS_B2="5.196237765893"/6 #> EXCH_F="1"/6 #> CORR_F="1"/6 -#> EXCHA_A="-6.416013751494"/6 -#> EXCHA_B="-5.539501235299"/6 -#> CORR_E="-0.382205063392"/6 -#> CASDFTE="-105.529110250230"/8 -#> DENS_TT="12.000000438954"/6 -#> DENS_A1="6.000000219477"/6 -#> DENS_B1="6.000000219477"/6 -#> DENS_A2="6.950914711591"/6 -#> DENS_B2="5.049085727363"/6 +#> EXCHA_A="-6.416013751486"/6 +#> EXCHA_B="-5.539501235310"/6 +#> CORR_E="-0.382205063394"/6 +#> CASDFTE="-105.529110250236"/8 +#> DENS_TT="12.000000438943"/6 +#> DENS_A1="6.000000219471"/6 +#> DENS_B1="6.000000219471"/6 +#> DENS_A2="6.950914711586"/6 +#> DENS_B2="5.049085727357"/6 #> EXCH_F="1"/6 #> CORR_F="1"/6 #> EXCHA_A="-6.458795039866"/6 -#> EXCHA_B="-5.453945019123"/6 +#> EXCHA_B="-5.453945019112"/6 #> CORR_E="-0.374116659711"/6 -#> CASDFTE="-105.478554901993"/8 +#> CASDFTE="-105.478554901983"/8 #>> 6 -#> E_RASSCF[0]="-105.273478672585"/8 -#> E_RASSCF[1]="-105.286618429637"/8 -#> MLTPL__0="0.0"/5 +#> E_RASSCF[0]="-105.286618429637"/8 +#> E_RASSCF[1]="-105.273478672585"/8 +#> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 -#> MLTPL__1[2]="-1.869567065824"/5 -#> MLTPL__2[0]="7.108813583449"/5 +#> MLTPL__1[2]="2.039639535441"/5 +#> MLTPL__2[0]="-5.451222941991"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="7.108813583449"/5 +#> MLTPL__2[3]="-5.451222941991"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-14.217627166899"/5 -#> MLTPL__0="0.0"/5 +#> MLTPL__2[5]="10.902445883982"/5 +#> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 -#> MLTPL__1[2]="2.039639535441"/5 -#> MLTPL__2[0]="-5.451222941993"/5 +#> MLTPL__1[2]="-1.869567065824"/5 +#> MLTPL__2[0]="7.108813583448"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-5.451222941993"/5 +#> MLTPL__2[3]="7.108813583448"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="10.902445883986"/5 +#> MLTPL__2[5]="-14.217627166896"/5 #>> 7 -#> DENS_TT="12.000000349684"/6 -#> DENS_A1="6.000000174842"/6 -#> DENS_B1="6.000000174842"/6 -#> DENS_A2="6.975557769766"/6 -#> DENS_B2="5.024442579918"/6 +#> DENS_TT="12.000001146343"/6 +#> DENS_A1="6.000000573172"/6 +#> DENS_B1="6.000000573172"/6 +#> DENS_A2="6.791866070115"/6 +#> DENS_B2="5.208135076229"/6 #> EXCH_F="1"/6 #> CORR_F="1"/6 -#> EXCHA_A="-6.464084800332"/6 -#> EXCHA_B="-5.443412364377"/6 -#> CORR_E="-0.373514671739"/6 -#> CASDFTE="-105.482639198918"/8 -#> DENS_TT="12.000001146368"/6 -#> DENS_A1="6.000000573184"/6 -#> DENS_B1="6.000000573184"/6 -#> DENS_A2="6.791866070133"/6 -#> DENS_B2="5.208135076234"/6 +#> EXCHA_A="-6.413903336790"/6 +#> EXCHA_B="-5.547447324563"/6 +#> CORR_E="-0.382892683984"/6 +#> CASDFTE="-105.522271241280"/8 +#> DENS_TT="12.000000349674"/6 +#> DENS_A1="6.000000174837"/6 +#> DENS_B1="6.000000174837"/6 +#> DENS_A2="6.975557769764"/6 +#> DENS_B2="5.024442579910"/6 #> EXCH_F="1"/6 #> CORR_F="1"/6 -#> EXCHA_A="-6.413903336798"/6 -#> EXCHA_B="-5.547447324553"/6 -#> CORR_E="-0.382892683982"/6 -#> CASDFTE="-105.522271241276"/8 +#> EXCHA_A="-6.464084800333"/6 +#> EXCHA_B="-5.443412364368"/6 +#> CORR_E="-0.373514671739"/6 +#> CASDFTE="-105.482639198910"/8 >>EOF diff -Nru openmolcas-22.02/test/additional/314.input openmolcas-22.10/test/additional/314.input --- openmolcas-22.02/test/additional/314.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/314.input 2022-10-10 14:22:40.000000000 +0000 @@ -1,8 +1,8 @@ * Molecule: LiF * Basis: STO-3G * Symmetry: C2V -* Features tested: XMS-PDFT calculation -* Responsible person: Jie J. Bao, 2020 +* Features tested: CMS-PDFT gradient calculation +* Responsible person: Jie J. Bao, 2022 * Comments: *------------------------------------------------------------------------------- &GATEWAY @@ -25,6 +25,7 @@ Inactive=2 Ras2=5; CIRoot=2 2 1;RLXR=2 CMSI + CMSO=Jacobi &MCPDFT; KSDFT=ft:LSDA; GRAD;MSPD &SLAPAF diff -Nru openmolcas-22.02/test/additional/345.input openmolcas-22.10/test/additional/345.input --- openmolcas-22.02/test/additional/345.input 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/test/additional/345.input 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,389 @@ +>> RM -FORCE TEST_HDF5 +>> IF ( $MOLCAS_DRIVER = UNKNOWN_VARIABLE ) +>> EXPORT MOLCAS_DRIVER=molcas +>> ENDIF +>> SHELL $MOLCAS_DRIVER have_feature hdf5 || touch TEST_HDF5 +>> EXPORT HAVE_HDF5=1 +>> IF ( -FILE TEST_HDF5 ) +>> EXPORT HAVE_HDF5=0 +>> ENDIF + +>export MOLCAS_REDUCE_PRT=NO + +>COPY velocity.xyz $Project.velocity.xyz +>COPY C3H6N.xyz . +&GATEWAY +COORD=C3H6N.xyz +BASIS= 3-21G +GROUP= nosym +NoCD + +> EXPORT MOLCAS_MAXITER=3 +> DOWHILE + +&SEWARD + +&SCF +Charge= 1 +Thresholds=1.0d-12,1.0d-6,1.5d-6,0.2d-6 + + +&ALASKA +CutOff= 1.0D-8 + +&DYNAMIX +VelVer +DT= 10.0 +VELO= 1 +THERMO= 2 +> END DO + +* Check that we can resume the dynamics +>> EXPORT MOLCAS_NOCHECK=POTNUC +>> IF ($HAVE_HDF5 == 0) + >COPY $Project.RunFile RunOld + &GATEWAY + COORD=C3H6N.xyz + BASIS= 3-21G + GROUP= nosym + NoCD + >COPY RunOld $Project.RunFile +>> ENDIF +>> IF ($HAVE_HDF5 == 1) + >COPY $Project.dyn.h5 restart.h5 + &GATEWAY + COORD=restart.h5 + BASIS= 3-21G + GROUP= nosym + NoCD +>> ENDIF +>> EXPORT MOLCAS_NOCHECK= + +> EXPORT MOLCAS_MAXITER=2 +> DOWHILE + +&SEWARD + +&SCF +Charge= 1 +>> COPY $Project.ScfOrb INPORB + +&ALASKA +CutOff= 1.0D-8 + +>> IF ($HAVE_HDF5 == 0) + &DYNAMIX + VelVer + DT= 10.0 + VELO= 1 + THERMO= 2 +>> ENDIF +>> IF ($HAVE_HDF5 == 1) + &DYNAMIX + VelVer + DT= 10.0 + VELO= 1 + THERMO= 2 + H5RESTART=restart.h5 +>> ENDIF +> END DO + +**** + +>> FILE C3H6N.xyz +10 + +N -0.17844329 0.01161150 -0.01688328 +C 0.07088615 -0.08282700 1.35870684 +C 1.29547512 0.00054447 2.05740828 +C 1.40103221 0.06669674 3.41809731 +H -1.11386837 0.06235205 -0.29227869 +H 0.58533199 0.01324699 -0.90130186 +H -0.84008562 -0.06262236 1.94268475 +H 2.12354746 0.19234384 1.35199423 +H 2.46837242 0.01910801 3.90626564 +H 0.52619824 -0.04296805 4.03575364 +>> EOF + +>> FILE velocity.xyz + 0.2631450000D-03 0.1178040000D-03 0.3267080000D-03 + -0.2821050000D-03 -0.1191400000D-03 -0.6325810000D-03 + 0.2316880000D-03 -0.6792500000D-04 0.1972640000D-03 + -0.3818310000D-03 0.1110300000D-04 -0.1185190000D-03 + -0.2431438000D-02 0.2310120000D-03 -0.2185710000D-03 + -0.6608070000D-03 -0.7599030000D-03 0.1584705000D-02 + 0.2530980000D-03 -0.6772860000D-03 0.6435180000D-03 + 0.1462972000D-02 0.9545490000D-03 -0.1576390000D-03 + 0.2678850000D-02 -0.3868520000D-03 -0.5928400000D-04 + 0.1880680000D-03 0.1097036000D-02 0.2623120000D-03 +>> EOF + +>>FILE checkfile +* This file is autogenerated: +* Molcas version 22.06-83-gd5f2c2c60 +* Linux Lowdin 5.15.0-47-generic #51-Ubuntu SMP Thu Aug 11 07:51:15 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Mon Sep 12 13:48:46 2022 +* +#>> 1 +#> POTNUC="108.573734158921"/12 +#>> 2 +#> POTNUC="108.573734158921"/6 +#> SEWARD_MLTPL1X="-0.337208946877"/5 +#> SEWARD_KINETIC="23.002383065898"/5 +#> SEWARD_ATTRACT="-53.363761721127"/5 +#>> 3 +#> SCF_ITER="22"/8 +#> E_SCF="-170.294949350993"/8 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="0.718437506056"/5 +#> MLTPL__1[1]="0.027685825097"/5 +#> MLTPL__1[2]="2.739258785414"/5 +#> MLTPL__2[0]="0.518768096664"/5 +#> MLTPL__2[1]="0.379515773447"/5 +#> MLTPL__2[2]="5.900574080744"/5 +#> MLTPL__2[3]="-12.734516212814"/5 +#> MLTPL__2[4]="-0.360629561719"/5 +#> MLTPL__2[5]="12.215748116151"/5 +#>> 4 +#> GRAD[0]="-0.102036119509"/6 +#> GRAD[1]="0.012258896382"/6 +#> GRAD[2]="-0.038177087899"/6 +#> GRAD[3]="0.040660482287"/6 +#> GRAD[4]="-0.025513503063"/6 +#> GRAD[5]="0.075475379530"/6 +#> GRAD[6]="-0.029718448574"/6 +#> GRAD[7]="-0.018949911344"/6 +#> GRAD[8]="0.016224257157"/6 +#> GRAD[9]="-0.041366636001"/6 +#> GRAD[10]="0.029173281911"/6 +#> GRAD[11]="0.019834268253"/6 +#> GRAD[12]="0.027279817570"/6 +#> GRAD[13]="0.001095348666"/6 +#> GRAD[14]="0.010021780775"/6 +#> GRAD[15]="0.054083139056"/6 +#> GRAD[16]="-0.000254894748"/6 +#> GRAD[17]="-0.079443939273"/6 +#> GRAD[18]="-0.001479821518"/6 +#> GRAD[19]="0.006745202638"/6 +#> GRAD[20]="0.005156025516"/6 +#> GRAD[21]="0.002478726107"/6 +#> GRAD[22]="0.012213030536"/6 +#> GRAD[23]="-0.026241446870"/6 +#> GRAD[24]="0.054764766615"/6 +#> GRAD[25]="-0.013128401275"/6 +#> GRAD[26]="0.021115486618"/6 +#> GRAD[27]="-0.004665906033"/6 +#> GRAD[28]="-0.003639049704"/6 +#> GRAD[29]="-0.003964723807"/6 +#>> 5 +#> EKIN="0.031019213420"/6 +#>> 7 +#> POTNUC="108.512927386482"/6 +#> SEWARD_MLTPL1X="-0.334377677502"/5 +#> SEWARD_KINETIC="23.002383065898"/5 +#> SEWARD_ATTRACT="-53.368896788223"/5 +#>> 8 +#> SCF_ITER="12"/8 +#> E_SCF="-170.296485317775"/8 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="0.696862455098"/5 +#> MLTPL__1[1]="0.024701444377"/5 +#> MLTPL__1[2]="2.716564762315"/5 +#> MLTPL__2[0]="0.644833475569"/5 +#> MLTPL__2[1]="0.380808465655"/5 +#> MLTPL__2[2]="5.985091303479"/5 +#> MLTPL__2[3]="-12.763303024351"/5 +#> MLTPL__2[4]="-0.337436594793"/5 +#> MLTPL__2[5]="12.118469548782"/5 +#>> 9 +#> GRAD[0]="-0.083222579340"/6 +#> GRAD[1]="0.012106245799"/6 +#> GRAD[2]="-0.033977568087"/6 +#> GRAD[3]="0.037216461407"/6 +#> GRAD[4]="-0.025557870031"/6 +#> GRAD[5]="0.070463140911"/6 +#> GRAD[6]="-0.030004468677"/6 +#> GRAD[7]="-0.019618673433"/6 +#> GRAD[8]="0.020849300091"/6 +#> GRAD[9]="-0.048302780992"/6 +#> GRAD[10]="0.028664510703"/6 +#> GRAD[11]="0.017793488483"/6 +#> GRAD[12]="0.011791508209"/6 +#> GRAD[13]="0.001872912719"/6 +#> GRAD[14]="0.005965860271"/6 +#> GRAD[15]="0.052051521827"/6 +#> GRAD[16]="-0.000857096322"/6 +#> GRAD[17]="-0.076919639784"/6 +#> GRAD[18]="-0.001735846127"/6 +#> GRAD[19]="0.006514666017"/6 +#> GRAD[20]="0.006332538202"/6 +#> GRAD[21]="0.005908617063"/6 +#> GRAD[22]="0.013288202239"/6 +#> GRAD[23]="-0.028452892627"/6 +#> GRAD[24]="0.060008760521"/6 +#> GRAD[25]="-0.013307879283"/6 +#> GRAD[26]="0.022542775438"/6 +#> GRAD[27]="-0.003711193890"/6 +#> GRAD[28]="-0.003105018408"/6 +#> GRAD[29]="-0.004597002899"/6 +#>> 10 +#> EKIN="0.032551158910"/6 +#> EKIN="0.032544985190"/6 +#>> 12 +#> POTNUC="108.474526116682"/6 +#> SEWARD_MLTPL1X="-0.331220828450"/5 +#> SEWARD_KINETIC="23.002383065898"/5 +#> SEWARD_ATTRACT="-53.375832122341"/5 +#>> 13 +#> SCF_ITER="15"/8 +#> E_SCF="-170.298073632512"/8 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="0.673265764597"/5 +#> MLTPL__1[1]="0.021823741564"/5 +#> MLTPL__1[2]="2.695172132459"/5 +#> MLTPL__2[0]="0.778065360058"/5 +#> MLTPL__2[1]="0.383051015511"/5 +#> MLTPL__2[2]="6.078430658986"/5 +#> MLTPL__2[3]="-12.781195098856"/5 +#> MLTPL__2[4]="-0.312323046665"/5 +#> MLTPL__2[5]="12.003129738798"/5 +#>> 14 +#> GRAD[0]="-0.064461416938"/6 +#> GRAD[1]="0.011976044007"/6 +#> GRAD[2]="-0.030640087273"/6 +#> GRAD[3]="0.033623091627"/6 +#> GRAD[4]="-0.025548822012"/6 +#> GRAD[5]="0.065142781723"/6 +#> GRAD[6]="-0.029876098865"/6 +#> GRAD[7]="-0.020156764121"/6 +#> GRAD[8]="0.025054473803"/6 +#> GRAD[9]="-0.054117924690"/6 +#> GRAD[10]="0.028080349974"/6 +#> GRAD[11]="0.016123087818"/6 +#> GRAD[12]="-0.002774039286"/6 +#> GRAD[13]="0.002592736951"/6 +#> GRAD[14]="0.002187217936"/6 +#> GRAD[15]="0.049212748693"/6 +#> GRAD[16]="-0.001452067264"/6 +#> GRAD[17]="-0.073488924021"/6 +#> GRAD[18]="-0.001949278200"/6 +#> GRAD[19]="0.006256646422"/6 +#> GRAD[20]="0.007480956581"/6 +#> GRAD[21]="0.008927326175"/6 +#> GRAD[22]="0.014260100048"/6 +#> GRAD[23]="-0.030222450913"/6 +#> GRAD[24]="0.064213428572"/6 +#> GRAD[25]="-0.013428663353"/6 +#> GRAD[26]="0.023512545558"/6 +#> GRAD[27]="-0.002797837088"/6 +#> GRAD[28]="-0.002579560653"/6 +#> GRAD[29]="-0.005149601211"/6 +#>> 15 +#> EKIN="0.034124709459"/6 +#> EKIN="0.034112536756"/6 +#>> 17 +#>> 18 +#> POTNUC="108.460945379883"/6 +#> SEWARD_MLTPL1X="-0.327812478692"/5 +#> SEWARD_KINETIC="23.002383065898"/5 +#> SEWARD_ATTRACT="-53.384787743352"/5 +#>> 19 +#> SCF_ITER="8"/8 +#> E_SCF="-170.299709056842"/8 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="0.648065563749"/5 +#> MLTPL__1[1]="0.019061484064"/5 +#> MLTPL__1[2]="2.675344895371"/5 +#> MLTPL__2[0]="0.915937094083"/5 +#> MLTPL__2[1]="0.386496516859"/5 +#> MLTPL__2[2]="6.178064146611"/5 +#> MLTPL__2[3]="-12.787131349159"/5 +#> MLTPL__2[4]="-0.285303196739"/5 +#> MLTPL__2[5]="11.871194255076"/5 +#>> 20 +#> GRAD[0]="-0.046038406913"/6 +#> GRAD[1]="0.011878651292"/6 +#> GRAD[2]="-0.028423634701"/6 +#> GRAD[3]="0.029899556025"/6 +#> GRAD[4]="-0.025485295732"/6 +#> GRAD[5]="0.059515048689"/6 +#> GRAD[6]="-0.029339080981"/6 +#> GRAD[7]="-0.020560300049"/6 +#> GRAD[8]="0.028827120104"/6 +#> GRAD[9]="-0.058908938083"/6 +#> GRAD[10]="0.027430179886"/6 +#> GRAD[11]="0.014738569963"/6 +#> GRAD[12]="-0.016014819239"/6 +#> GRAD[13]="0.003232907602"/6 +#> GRAD[14]="-0.001201094112"/6 +#> GRAD[15]="0.045436404541"/6 +#> GRAD[16]="-0.002028551766"/6 +#> GRAD[17]="-0.068987039328"/6 +#> GRAD[18]="-0.002110837305"/6 +#> GRAD[19]="0.005971171698"/6 +#> GRAD[20]="0.008587707942"/6 +#> GRAD[21]="0.011527051971"/6 +#> GRAD[22]="0.015121343811"/6 +#> GRAD[23]="-0.031549540431"/6 +#> GRAD[24]="0.067503851073"/6 +#> GRAD[25]="-0.013493445313"/6 +#> GRAD[26]="0.024093889283"/6 +#> GRAD[27]="-0.001954781090"/6 +#> GRAD[28]="-0.002066661429"/6 +#> GRAD[29]="-0.005601027409"/6 +#>> 21 +#> EKIN="0.035732412392"/6 +#> EKIN="0.035713207385"/6 +#>> 23 +#> POTNUC="108.474071164912"/6 +#> SEWARD_MLTPL1X="-0.324225489602"/5 +#> SEWARD_KINETIC="23.002383065898"/5 +#> SEWARD_ATTRACT="-53.395931238921"/5 +#>> 24 +#> SCF_ITER="8"/8 +#> E_SCF="-170.301387707569"/8 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="0.621690451409"/5 +#> MLTPL__1[1]="0.016425433792"/5 +#> MLTPL__1[2]="2.657279108814"/5 +#> MLTPL__2[0]="1.055858651823"/5 +#> MLTPL__2[1]="0.391347232602"/5 +#> MLTPL__2[2]="6.281459446222"/5 +#> MLTPL__2[3]="-12.780413212514"/5 +#> MLTPL__2[4]="-0.256432780170"/5 +#> MLTPL__2[5]="11.724554560691"/5 +#>> 25 +#> GRAD[0]="-0.028012259490"/6 +#> GRAD[1]="0.011806095287"/6 +#> GRAD[2]="-0.027574286161"/6 +#> GRAD[3]="0.026068597337"/6 +#> GRAD[4]="-0.025364700467"/6 +#> GRAD[5]="0.053583052953"/6 +#> GRAD[6]="-0.028408393469"/6 +#> GRAD[7]="-0.020826593157"/6 +#> GRAD[8]="0.032162748522"/6 +#> GRAD[9]="-0.062749421116"/6 +#> GRAD[10]="0.026722975347"/6 +#> GRAD[11]="0.013567390314"/6 +#> GRAD[12]="-0.027712758527"/6 +#> GRAD[13]="0.003782092871"/6 +#> GRAD[14]="-0.004140331267"/6 +#> GRAD[15]="0.040553503222"/6 +#> GRAD[16]="-0.002569239560"/6 +#> GRAD[17]="-0.063208545126"/6 +#> GRAD[18]="-0.002214669544"/6 +#> GRAD[19]="0.005658718924"/6 +#> GRAD[20]="0.009637594931"/6 +#> GRAD[21]="0.013703917688"/6 +#> GRAD[22]="0.015865744493"/6 +#> GRAD[23]="-0.032438630629"/6 +#> GRAD[24]="0.069982688628"/6 +#> GRAD[25]="-0.013505962333"/6 +#> GRAD[26]="0.024342277709"/6 +#> GRAD[27]="-0.001211204730"/6 +#> GRAD[28]="-0.001569131405"/6 +#> GRAD[29]="-0.005931271246"/6 +#>> 26 +#> EKIN="0.037366907255"/6 +#> EKIN="0.037339546909"/6 +>>EOF diff -Nru openmolcas-22.02/test/additional/349.input openmolcas-22.10/test/additional/349.input --- openmolcas-22.02/test/additional/349.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/349.input 2022-10-10 14:22:40.000000000 +0000 @@ -38,9 +38,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-943-g4c2682958 -* Linux lucifer 5.13.0-27-generic #29~20.04.1-Ubuntu SMP Fri Jan 14 00:32:30 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux -* Sat Feb 5 17:07:33 2022 +* Molcas version 22.02-260-gd39e60428 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Wed Apr 27 18:28:24 2022 * #>> 1 #> POTNUC="9.087997503463"/12 @@ -51,113 +51,113 @@ #> SEWARD_ATTRACT="-5.397844814912"/5 #>> 3 #> SCF_ITER="10"/8 -#> E_SCF="-76.398735630520"/4 -#> DFT_ENERGY="-9.338299902015"/6 -#> NQ_DENSITY="9.999998916553"/8 +#> E_SCF="-76.398735630497"/4 +#> DFT_ENERGY="-9.338299901996"/6 +#> NQ_DENSITY="9.999998916517"/8 #> MLTPL__0="-0.000000000000"/2 #> MLTPL__1[0]="0.0"/2 #> MLTPL__1[1]="0.0"/2 -#> MLTPL__1[2]="0.735029925318"/2 -#> MLTPL__2[0]="-1.436535041286"/2 +#> MLTPL__1[2]="0.735029925344"/2 +#> MLTPL__2[0]="-1.436535041317"/2 #> MLTPL__2[1]="0.0"/2 #> MLTPL__2[2]="0.0"/2 -#> MLTPL__2[3]="1.437684559569"/2 +#> MLTPL__2[3]="1.437684559604"/2 #> MLTPL__2[4]="0.0"/2 -#> MLTPL__2[5]="-0.001149518283"/2 +#> MLTPL__2[5]="-0.001149518287"/2 #>> 4 #> GRAD[0]="0.0"/6 -#> GRAD[1]="0.006981978736"/6 -#> GRAD[2]="-0.006456089161"/6 +#> GRAD[1]="0.006981978756"/6 +#> GRAD[2]="-0.006456089169"/6 #> GRAD[3]="0.0"/6 -#> GRAD[4]="-0.006981973346"/6 -#> GRAD[5]="-0.006456084852"/6 +#> GRAD[4]="-0.006981973361"/6 +#> GRAD[5]="-0.006456084856"/6 #> GRAD[6]="0.0"/6 -#> GRAD[7]="-0.000000005390"/6 -#> GRAD[8]="0.012912174013"/6 +#> GRAD[7]="-0.000000005395"/6 +#> GRAD[8]="0.012912174025"/6 #>> 5 #>> 6 #>> 8 -#> POTNUC="9.020468568735"/6 +#> POTNUC="9.020468568603"/6 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_KINETIC="0.499289232500"/5 -#> SEWARD_ATTRACT="-5.372771228774"/5 +#> SEWARD_ATTRACT="-5.372771228712"/5 #>> 9 #> SCF_ITER="8"/8 -#> E_SCF="-76.398912363874"/4 -#> DFT_ENERGY="-9.331649956343"/6 -#> NQ_DENSITY="9.999998831198"/8 +#> E_SCF="-76.398912363853"/4 +#> DFT_ENERGY="-9.331649956314"/6 +#> NQ_DENSITY="9.999998831163"/8 #> MLTPL__0="-0.000000000000"/2 #> MLTPL__1[0]="0.0"/2 -#> MLTPL__1[1]="-0.000000001439"/2 -#> MLTPL__1[2]="0.736922167455"/2 -#> MLTPL__2[0]="-1.449387136211"/2 +#> MLTPL__1[1]="-0.000000001440"/2 +#> MLTPL__1[2]="0.736922167469"/2 +#> MLTPL__2[0]="-1.449387136284"/2 #> MLTPL__2[1]="0.0"/2 #> MLTPL__2[2]="0.0"/2 -#> MLTPL__2[3]="1.438076695418"/2 -#> MLTPL__2[4]="-0.000000005270"/2 -#> MLTPL__2[5]="0.011310440794"/2 +#> MLTPL__2[3]="1.438076695587"/2 +#> MLTPL__2[4]="-0.000000005275"/2 +#> MLTPL__2[5]="0.011310440697"/2 #>> 10 #> GRAD[0]="0.0"/6 -#> GRAD[1]="0.001770905597"/6 -#> GRAD[2]="-0.002315963872"/6 +#> GRAD[1]="0.001770843793"/6 +#> GRAD[2]="-0.002315983686"/6 #> GRAD[3]="0.0"/6 -#> GRAD[4]="-0.001770903970"/6 -#> GRAD[5]="-0.002315962578"/6 +#> GRAD[4]="-0.001770842183"/6 +#> GRAD[5]="-0.002315982405"/6 #> GRAD[6]="0.0"/6 -#> GRAD[7]="-0.000000001627"/6 -#> GRAD[8]="0.004631926450"/6 +#> GRAD[7]="-0.000000001611"/6 +#> GRAD[8]="0.004631966090"/6 #>> 11 #>> 12 #>> 14 -#> POTNUC="8.988795935095"/6 +#> POTNUC="8.988796416122"/6 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_KINETIC="0.499289232500"/5 -#> SEWARD_ATTRACT="-5.361440683622"/5 +#> SEWARD_ATTRACT="-5.361440911452"/5 #>> 15 #> SCF_ITER="7"/8 -#> E_SCF="-76.398937676061"/4 -#> DFT_ENERGY="-9.328443191541"/6 -#> NQ_DENSITY="9.999998843921"/8 +#> E_SCF="-76.398937676207"/4 +#> DFT_ENERGY="-9.328443230395"/6 +#> NQ_DENSITY="9.999998843888"/8 #> MLTPL__0="-0.000000000000"/2 #> MLTPL__1[0]="0.0"/2 -#> MLTPL__1[1]="-0.000000002113"/2 -#> MLTPL__1[2]="0.739538615811"/2 -#> MLTPL__2[0]="-1.453622470494"/2 +#> MLTPL__1[1]="-0.000000002108"/2 +#> MLTPL__1[2]="0.739538774643"/2 +#> MLTPL__2[0]="-1.453622195722"/2 #> MLTPL__2[1]="0.0"/2 #> MLTPL__2[2]="0.0"/2 -#> MLTPL__2[3]="1.423334962582"/2 -#> MLTPL__2[4]="-0.000000007888"/2 -#> MLTPL__2[5]="0.030287507911"/2 +#> MLTPL__2[3]="1.423333497469"/2 +#> MLTPL__2[4]="-0.000000007869"/2 +#> MLTPL__2[5]="0.030288698253"/2 #>> 16 #> GRAD[0]="0.0"/6 -#> GRAD[1]="-0.000151508993"/6 -#> GRAD[2]="-0.000059091840"/6 +#> GRAD[1]="-0.000151429276"/6 +#> GRAD[2]="-0.000059085334"/6 #> GRAD[3]="0.0"/6 -#> GRAD[4]="0.000151508867"/6 -#> GRAD[5]="-0.000059091943"/6 +#> GRAD[4]="0.000151429161"/6 +#> GRAD[5]="-0.000059085429"/6 #> GRAD[6]="0.0"/6 -#> GRAD[7]="0.000000000126"/6 -#> GRAD[8]="0.000118183783"/6 +#> GRAD[7]="0.000000000115"/6 +#> GRAD[8]="0.000118170763"/6 #>> 17 #>> 18 #> GEO_ITER="3"/8 -#> POTNUC="8.989030245377"/6 +#> POTNUC="8.989030396777"/6 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_KINETIC="0.499289232500"/5 -#> SEWARD_ATTRACT="-5.361629965402"/5 -#> SCF_ITER="5"/8 -#> E_SCF="-76.398937875624"/4 -#> DFT_ENERGY="-9.328453664784"/6 -#> NQ_DENSITY="9.999998848578"/8 +#> SEWARD_ATTRACT="-5.361630029807"/5 +#> SCF_ITER="6"/8 +#> E_SCF="-76.398937875646"/4 +#> DFT_ENERGY="-9.328448085183"/6 +#> NQ_DENSITY="9.999998848543"/8 #> MLTPL__0="-0.000000000000"/2 #> MLTPL__1[0]="0.0"/2 #> MLTPL__1[1]="-0.000000002083"/2 -#> MLTPL__1[2]="0.739896014768"/2 -#> MLTPL__2[0]="-1.453191944440"/2 +#> MLTPL__1[2]="0.739895529391"/2 +#> MLTPL__2[0]="-1.453191969891"/2 #> MLTPL__2[1]="0.0"/2 #> MLTPL__2[2]="0.0"/2 -#> MLTPL__2[3]="1.420235856007"/2 -#> MLTPL__2[4]="-0.000000007796"/2 -#> MLTPL__2[5]="0.032956088433"/2 +#> MLTPL__2[3]="1.420236070903"/2 +#> MLTPL__2[4]="-0.000000007789"/2 +#> MLTPL__2[5]="0.032955898988"/2 #>> 19 >>EOF diff -Nru openmolcas-22.02/test/additional/350.input openmolcas-22.10/test/additional/350.input --- openmolcas-22.02/test/additional/350.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/350.input 2022-10-10 14:22:40.000000000 +0000 @@ -40,9 +40,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-943-g4c2682958 -* Linux lucifer 5.13.0-27-generic #29~20.04.1-Ubuntu SMP Fri Jan 14 00:32:30 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux -* Sat Feb 5 17:07:33 2022 +* Molcas version 22.02-260-gd39e60428 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Wed Apr 27 18:28:24 2022 * #>> 1 #> POTNUC="9.087997503463"/12 @@ -53,113 +53,113 @@ #> SEWARD_ATTRACT="-5.397844814912"/5 #>> 3 #> SCF_ITER="10"/8 -#> E_SCF="-76.398660459022"/8 -#> DFT_ENERGY="-9.338206688761"/6 -#> NQ_DENSITY="9.999998916687"/8 +#> E_SCF="-76.398660459000"/8 +#> DFT_ENERGY="-9.338206688743"/6 +#> NQ_DENSITY="9.999998916651"/8 #> MLTPL__0="-0.000000000000"/6 #> MLTPL__1[0]="0.0"/6 #> MLTPL__1[1]="0.0"/6 -#> MLTPL__1[2]="0.735007276683"/6 -#> MLTPL__2[0]="-1.436577671791"/6 +#> MLTPL__1[2]="0.735007276708"/6 +#> MLTPL__2[0]="-1.436577671821"/6 #> MLTPL__2[1]="0.0"/6 #> MLTPL__2[2]="0.0"/6 -#> MLTPL__2[3]="1.437772891829"/6 +#> MLTPL__2[3]="1.437772891864"/6 #> MLTPL__2[4]="0.0"/6 -#> MLTPL__2[5]="-0.001195220039"/6 +#> MLTPL__2[5]="-0.001195220043"/6 #>> 4 #> GRAD[0]="0.0"/6 -#> GRAD[1]="0.007051650704"/6 -#> GRAD[2]="-0.006502776154"/6 +#> GRAD[1]="0.007051650708"/6 +#> GRAD[2]="-0.006502776151"/6 #> GRAD[3]="0.0"/6 -#> GRAD[4]="-0.007051645284"/6 -#> GRAD[5]="-0.006502771821"/6 +#> GRAD[4]="-0.007051645294"/6 +#> GRAD[5]="-0.006502771823"/6 #> GRAD[6]="0.0"/6 -#> GRAD[7]="-0.000000005420"/6 -#> GRAD[8]="0.013005547975"/6 +#> GRAD[7]="-0.000000005414"/6 +#> GRAD[8]="0.013005547974"/6 #>> 5 #>> 6 #>> 8 -#> POTNUC="9.019864639835"/6 +#> POTNUC="9.019864639794"/6 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_KINETIC="0.499289232500"/5 -#> SEWARD_ATTRACT="-5.372538302892"/5 +#> SEWARD_ATTRACT="-5.372538302883"/5 #>> 9 #> SCF_ITER="8"/8 -#> E_SCF="-76.398840033889"/8 -#> DFT_ENERGY="-9.331500360997"/6 -#> NQ_DENSITY="9.999998830703"/8 +#> E_SCF="-76.398840033869"/8 +#> DFT_ENERGY="-9.331500360977"/6 +#> NQ_DENSITY="9.999998830668"/8 #> MLTPL__0="-0.000000000000"/6 #> MLTPL__1[0]="0.0"/6 -#> MLTPL__1[1]="-0.000000001448"/6 -#> MLTPL__1[2]="0.736889163442"/6 -#> MLTPL__2[0]="-1.449575426524"/6 +#> MLTPL__1[1]="-0.000000001446"/6 +#> MLTPL__1[2]="0.736889163457"/6 +#> MLTPL__2[0]="-1.449575426575"/6 #> MLTPL__2[1]="0.0"/6 #> MLTPL__2[2]="0.0"/6 -#> MLTPL__2[3]="1.438406759000"/6 -#> MLTPL__2[4]="-0.000000005304"/6 -#> MLTPL__2[5]="0.011168667524"/6 +#> MLTPL__2[3]="1.438406759137"/6 +#> MLTPL__2[4]="-0.000000005297"/6 +#> MLTPL__2[5]="0.011168667438"/6 #>> 10 #> GRAD[0]="0.0"/6 -#> GRAD[1]="0.001785092311"/6 -#> GRAD[2]="-0.002330754923"/6 +#> GRAD[1]="0.001785030745"/6 +#> GRAD[2]="-0.002330774724"/6 #> GRAD[3]="0.0"/6 -#> GRAD[4]="-0.001785090697"/6 -#> GRAD[5]="-0.002330753639"/6 +#> GRAD[4]="-0.001785029130"/6 +#> GRAD[5]="-0.002330773440"/6 #> GRAD[6]="0.0"/6 -#> GRAD[7]="-0.000000001614"/6 -#> GRAD[8]="0.004661508562"/6 +#> GRAD[7]="-0.000000001615"/6 +#> GRAD[8]="0.004661548164"/6 #>> 11 #>> 12 #>> 14 -#> POTNUC="8.987982759053"/6 +#> POTNUC="8.987983244339"/6 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_KINETIC="0.499289232500"/5 -#> SEWARD_ATTRACT="-5.361129502902"/5 +#> SEWARD_ATTRACT="-5.361129732080"/5 #>> 15 #> SCF_ITER="7"/8 -#> E_SCF="-76.398865667440"/8 -#> DFT_ENERGY="-9.328273687091"/6 -#> NQ_DENSITY="9.999998843834"/8 +#> E_SCF="-76.398865667588"/8 +#> DFT_ENERGY="-9.328273726394"/6 +#> NQ_DENSITY="9.999998843802"/8 #> MLTPL__0="-0.000000000000"/6 #> MLTPL__1[0]="0.0"/6 -#> MLTPL__1[1]="-0.000000002117"/6 -#> MLTPL__1[2]="0.739514157458"/6 -#> MLTPL__2[0]="-1.453849576510"/6 +#> MLTPL__1[1]="-0.000000002115"/6 +#> MLTPL__1[2]="0.739514315324"/6 +#> MLTPL__2[0]="-1.453849301784"/6 #> MLTPL__2[1]="0.0"/6 #> MLTPL__2[2]="0.0"/6 -#> MLTPL__2[3]="1.423643950983"/6 -#> MLTPL__2[4]="-0.000000007904"/6 -#> MLTPL__2[5]="0.030205625527"/6 +#> MLTPL__2[3]="1.423642492831"/6 +#> MLTPL__2[4]="-0.000000007899"/6 +#> MLTPL__2[5]="0.030206808953"/6 #>> 16 #> GRAD[0]="0.0"/6 -#> GRAD[1]="-0.000152321300"/6 -#> GRAD[2]="-0.000060902974"/6 +#> GRAD[1]="-0.000152241447"/6 +#> GRAD[2]="-0.000060896873"/6 #> GRAD[3]="0.0"/6 -#> GRAD[4]="0.000152321165"/6 -#> GRAD[5]="-0.000060903084"/6 +#> GRAD[4]="0.000152241314"/6 +#> GRAD[5]="-0.000060896982"/6 #> GRAD[6]="0.0"/6 -#> GRAD[7]="0.000000000135"/6 -#> GRAD[8]="0.000121806058"/6 +#> GRAD[7]="0.000000000133"/6 +#> GRAD[8]="0.000121793854"/6 #>> 17 #>> 18 #> GEO_ITER="3"/8 -#> POTNUC="8.988204682133"/6 +#> POTNUC="8.988204832757"/6 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_KINETIC="0.499289232500"/5 -#> SEWARD_ATTRACT="-5.361315540225"/5 -#> SCF_ITER="5"/8 -#> E_SCF="-76.398865872221"/8 -#> DFT_ENERGY="-9.328282703323"/6 -#> NQ_DENSITY="9.999998848565"/8 +#> SEWARD_ATTRACT="-5.361315604300"/5 +#> SCF_ITER="6"/8 +#> E_SCF="-76.398865872244"/8 +#> DFT_ENERGY="-9.328277103738"/6 +#> NQ_DENSITY="9.999998848530"/8 #> MLTPL__0="-0.000000000000"/6 #> MLTPL__1[0]="0.0"/6 -#> MLTPL__1[1]="-0.000000002085"/6 -#> MLTPL__1[2]="0.739876805217"/6 -#> MLTPL__2[0]="-1.453416200280"/6 +#> MLTPL__1[1]="-0.000000002086"/6 +#> MLTPL__1[2]="0.739876304051"/6 +#> MLTPL__2[0]="-1.453416231997"/6 #> MLTPL__2[1]="0.0"/6 #> MLTPL__2[2]="0.0"/6 -#> MLTPL__2[3]="1.420502523726"/6 -#> MLTPL__2[4]="-0.000000007803"/6 -#> MLTPL__2[5]="0.032913676554"/6 +#> MLTPL__2[3]="1.420502756657"/6 +#> MLTPL__2[4]="-0.000000007801"/6 +#> MLTPL__2[5]="0.032913475339"/6 #>> 19 >>EOF diff -Nru openmolcas-22.02/test/additional/358.input openmolcas-22.10/test/additional/358.input --- openmolcas-22.02/test/additional/358.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/358.input 2022-10-10 14:22:40.000000000 +0000 @@ -42,9 +42,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 20.10-834-gc99b12fe8 -* Linux lucifer 5.4.0-65-generic #73-Ubuntu SMP Mon Jan 18 17:25:17 UTC 2021 x86_64 x86_64 x86_64 GNU/Linux -* Tue Feb 2 08:47:18 2021 +* Molcas version 22.02-113-g3e6c18d4f +* Linux lucifer 5.13.0-35-generic #40~20.04.1-Ubuntu SMP Mon Mar 7 09:18:32 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Fri Mar 18 17:07:39 2022 * #>> 1 #>> 2 @@ -53,356 +53,356 @@ #> SEWARD_ATTRACT="-65.039770228297"/5 #>> 3 #> SCF_ITER="13"/8 -#> E_SCF="-150.735609016746"/4 -#> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="0.012485411352"/2 -#> MLTPL__1[1]="-0.128356790362"/2 -#> MLTPL__1[2]="0.135339553459"/2 -#> MLTPL__2[0]="-1.707387718780"/2 -#> MLTPL__2[1]="2.908703053754"/2 -#> MLTPL__2[2]="-0.055565875411"/2 -#> MLTPL__2[3]="3.430772541651"/2 -#> MLTPL__2[4]="0.102238956841"/2 -#> MLTPL__2[5]="-1.723384822871"/2 +#> E_SCF="-150.735609016744"/4 +#> MLTPL__0="-0.000000000001"/2 +#> MLTPL__1[0]="0.012485290238"/2 +#> MLTPL__1[1]="-0.128356834372"/2 +#> MLTPL__1[2]="0.135339541320"/2 +#> MLTPL__2[0]="-1.707387684370"/2 +#> MLTPL__2[1]="2.908703042465"/2 +#> MLTPL__2[2]="-0.055565890103"/2 +#> MLTPL__2[3]="3.430772549049"/2 +#> MLTPL__2[4]="0.102238942631"/2 +#> MLTPL__2[5]="-1.723384864679"/2 #>> 4 -#> GRAD[0]="0.013449024314"/6 -#> GRAD[1]="0.141674067820"/6 -#> GRAD[2]="0.017727765894"/6 -#> GRAD[3]="-0.040507583380"/6 -#> GRAD[4]="-0.195682964419"/6 -#> GRAD[5]="-0.019075615314"/6 -#> GRAD[6]="-0.017295869930"/6 -#> GRAD[7]="0.145323005612"/6 -#> GRAD[8]="-0.013415240429"/6 -#> GRAD[9]="0.044354428995"/6 -#> GRAD[10]="-0.091314109013"/6 -#> GRAD[11]="0.014763089849"/6 +#> GRAD[0]="0.013448977270"/6 +#> GRAD[1]="0.141674170210"/6 +#> GRAD[2]="0.017727779679"/6 +#> GRAD[3]="-0.040507604441"/6 +#> GRAD[4]="-0.195683067441"/6 +#> GRAD[5]="-0.019075630432"/6 +#> GRAD[6]="-0.017295811121"/6 +#> GRAD[7]="0.145322946649"/6 +#> GRAD[8]="-0.013415216821"/6 +#> GRAD[9]="0.044354438293"/6 +#> GRAD[10]="-0.091314049418"/6 +#> GRAD[11]="0.014763067574"/6 #>> 5 #>> 7 -#> SEWARD_MLTPL1X="1.358125481779"/5 +#> SEWARD_MLTPL1X="1.358125503605"/5 #> SEWARD_KINETIC="29.214928025013"/5 -#> SEWARD_ATTRACT="-64.959883136590"/5 +#> SEWARD_ATTRACT="-64.959883027658"/5 #>> 8 -#> SCF_ITER="11"/8 -#> E_SCF="-150.778796128665"/4 +#> SCF_ITER="12"/8 +#> E_SCF="-150.778796127188"/4 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="-0.023760104325"/2 -#> MLTPL__1[1]="-0.036912911287"/2 -#> MLTPL__1[2]="0.133756749796"/2 -#> MLTPL__2[0]="-1.583579831877"/2 -#> MLTPL__2[1]="3.330660339483"/2 -#> MLTPL__2[2]="-0.029172871551"/2 -#> MLTPL__2[3]="3.536644620290"/2 -#> MLTPL__2[4]="0.191717028505"/2 -#> MLTPL__2[5]="-1.953064788414"/2 +#> MLTPL__1[0]="-0.023760779559"/2 +#> MLTPL__1[1]="-0.036912830495"/2 +#> MLTPL__1[2]="0.133756760561"/2 +#> MLTPL__2[0]="-1.583579784101"/2 +#> MLTPL__2[1]="3.330660313869"/2 +#> MLTPL__2[2]="-0.029172982868"/2 +#> MLTPL__2[3]="3.536644545241"/2 +#> MLTPL__2[4]="0.191717061479"/2 +#> MLTPL__2[5]="-1.953064761140"/2 #>> 9 -#> GRAD[0]="0.024383974163"/6 -#> GRAD[1]="0.008637497188"/6 -#> GRAD[2]="0.005164874494"/6 -#> GRAD[3]="-0.019297729108"/6 -#> GRAD[4]="-0.031515535872"/6 -#> GRAD[5]="-0.004403962475"/6 -#> GRAD[6]="-0.018885348261"/6 -#> GRAD[7]="0.067568543794"/6 -#> GRAD[8]="-0.006946931493"/6 -#> GRAD[9]="0.013799103206"/6 -#> GRAD[10]="-0.044690505110"/6 -#> GRAD[11]="0.006186019474"/6 +#> GRAD[0]="0.024384271574"/6 +#> GRAD[1]="0.008637081770"/6 +#> GRAD[2]="0.005165303979"/6 +#> GRAD[3]="-0.019298292022"/6 +#> GRAD[4]="-0.031514952368"/6 +#> GRAD[5]="-0.004403952096"/6 +#> GRAD[6]="-0.018885412505"/6 +#> GRAD[7]="0.067568527210"/6 +#> GRAD[8]="-0.006947350250"/6 +#> GRAD[9]="0.013799432954"/6 +#> GRAD[10]="-0.044690656612"/6 +#> GRAD[11]="0.006185998367"/6 #>> 10 #>> 12 -#> SEWARD_MLTPL1X="1.344561491953"/5 +#> SEWARD_MLTPL1X="1.344560764086"/5 #> SEWARD_KINETIC="29.214928025013"/5 -#> SEWARD_ATTRACT="-64.978231876178"/5 +#> SEWARD_ATTRACT="-64.978232266073"/5 #>> 13 -#> SCF_ITER="10"/8 -#> E_SCF="-150.784186318054"/4 +#> SCF_ITER="11"/8 +#> E_SCF="-150.784186265297"/4 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="-0.025762519548"/2 -#> MLTPL__1[1]="0.014091547173"/2 -#> MLTPL__1[2]="0.156971396900"/2 -#> MLTPL__2[0]="-1.452202336808"/2 -#> MLTPL__2[1]="3.602896773116"/2 -#> MLTPL__2[2]="-0.004658761531"/2 -#> MLTPL__2[3]="3.524076912130"/2 -#> MLTPL__2[4]="0.249150956281"/2 -#> MLTPL__2[5]="-2.071874575322"/2 +#> MLTPL__1[0]="-0.025761520244"/2 +#> MLTPL__1[1]="0.014092510858"/2 +#> MLTPL__1[2]="0.156972923921"/2 +#> MLTPL__2[0]="-1.452200407304"/2 +#> MLTPL__2[1]="3.602901656003"/2 +#> MLTPL__2[2]="-0.004658298723"/2 +#> MLTPL__2[3]="3.524077314365"/2 +#> MLTPL__2[4]="0.249151439675"/2 +#> MLTPL__2[5]="-2.071876907061"/2 #>> 14 -#> GRAD[0]="0.010420724732"/6 -#> GRAD[1]="0.011575825876"/6 -#> GRAD[2]="0.001454414129"/6 -#> GRAD[3]="0.002342306622"/6 -#> GRAD[4]="-0.003833585284"/6 -#> GRAD[5]="-0.000791754322"/6 -#> GRAD[6]="-0.010070137172"/6 -#> GRAD[7]="-0.040194627983"/6 -#> GRAD[8]="0.004414535571"/6 -#> GRAD[9]="-0.002692894182"/6 -#> GRAD[10]="0.032452387392"/6 -#> GRAD[11]="-0.005077195378"/6 +#> GRAD[0]="0.010419914458"/6 +#> GRAD[1]="0.011576322859"/6 +#> GRAD[2]="0.001454769033"/6 +#> GRAD[3]="0.002342252870"/6 +#> GRAD[4]="-0.003833379628"/6 +#> GRAD[5]="-0.000791979327"/6 +#> GRAD[6]="-0.010069437139"/6 +#> GRAD[7]="-0.040197194796"/6 +#> GRAD[8]="0.004414736968"/6 +#> GRAD[9]="-0.002692730190"/6 +#> GRAD[10]="0.032454251565"/6 +#> GRAD[11]="-0.005077526674"/6 #>> 15 #>> 17 -#> SEWARD_MLTPL1X="1.334130595315"/5 +#> SEWARD_MLTPL1X="1.334130612016"/5 #> SEWARD_KINETIC="29.214928025013"/5 -#> SEWARD_ATTRACT="-64.993505631270"/5 +#> SEWARD_ATTRACT="-64.993505169666"/5 #>> 18 #> SCF_ITER="10"/8 -#> E_SCF="-150.785402285383"/4 +#> E_SCF="-150.785402302366"/4 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="-0.025226915438"/2 -#> MLTPL__1[1]="0.002132748960"/2 -#> MLTPL__1[2]="0.206937049586"/2 -#> MLTPL__2[0]="-1.492579171517"/2 -#> MLTPL__2[1]="3.554767441361"/2 -#> MLTPL__2[2]="-0.017382915311"/2 -#> MLTPL__2[3]="3.510494592686"/2 -#> MLTPL__2[4]="0.232129206153"/2 -#> MLTPL__2[5]="-2.017915421169"/2 +#> MLTPL__1[0]="-0.025227389043"/2 +#> MLTPL__1[1]="0.002132517962"/2 +#> MLTPL__1[2]="0.206947661837"/2 +#> MLTPL__2[0]="-1.492579536519"/2 +#> MLTPL__2[1]="3.554766398089"/2 +#> MLTPL__2[2]="-0.017384116675"/2 +#> MLTPL__2[3]="3.510487838112"/2 +#> MLTPL__2[4]="0.232128443971"/2 +#> MLTPL__2[5]="-2.017908301593"/2 #>> 19 -#> GRAD[0]="0.005755321279"/6 -#> GRAD[1]="0.003525710675"/6 -#> GRAD[2]="0.001381866772"/6 -#> GRAD[3]="-0.000777773117"/6 -#> GRAD[4]="-0.002822617456"/6 -#> GRAD[5]="-0.001103114700"/6 -#> GRAD[6]="-0.004143064656"/6 -#> GRAD[7]="-0.001370754921"/6 -#> GRAD[8]="0.000597239298"/6 -#> GRAD[9]="-0.000834483506"/6 -#> GRAD[10]="0.000667661701"/6 -#> GRAD[11]="-0.000875991370"/6 +#> GRAD[0]="0.005755389463"/6 +#> GRAD[1]="0.003526218264"/6 +#> GRAD[2]="0.001381966499"/6 +#> GRAD[3]="-0.000777497553"/6 +#> GRAD[4]="-0.002822823560"/6 +#> GRAD[5]="-0.001103175369"/6 +#> GRAD[6]="-0.004143203220"/6 +#> GRAD[7]="-0.001370169835"/6 +#> GRAD[8]="0.000597115223"/6 +#> GRAD[9]="-0.000834688690"/6 +#> GRAD[10]="0.000666775131"/6 +#> GRAD[11]="-0.000875906353"/6 #>> 20 #>> 22 -#> SEWARD_MLTPL1X="1.328620938313"/5 +#> SEWARD_MLTPL1X="1.328621816368"/5 #> SEWARD_KINETIC="29.214928025013"/5 -#> SEWARD_ATTRACT="-65.004945407659"/5 +#> SEWARD_ATTRACT="-65.004945552064"/5 #>> 23 #> SCF_ITER="10"/8 -#> E_SCF="-150.785594065620"/4 +#> E_SCF="-150.785594121899"/4 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="-0.027981974169"/2 -#> MLTPL__1[1]="0.003935351798"/2 -#> MLTPL__1[2]="0.283625306561"/2 -#> MLTPL__2[0]="-1.514082097611"/2 -#> MLTPL__2[1]="3.504246645028"/2 -#> MLTPL__2[2]="-0.026632578080"/2 -#> MLTPL__2[3]="3.440488666465"/2 -#> MLTPL__2[4]="0.228369761123"/2 -#> MLTPL__2[5]="-1.926406568854"/2 +#> MLTPL__1[0]="-0.027984111202"/2 +#> MLTPL__1[1]="0.003935713546"/2 +#> MLTPL__1[2]="0.283651560166"/2 +#> MLTPL__2[0]="-1.514088499782"/2 +#> MLTPL__2[1]="3.504226851765"/2 +#> MLTPL__2[2]="-0.026636435969"/2 +#> MLTPL__2[3]="3.440460031594"/2 +#> MLTPL__2[4]="0.228368502936"/2 +#> MLTPL__2[5]="-1.926371531813"/2 #>> 24 -#> GRAD[0]="0.001559116362"/6 -#> GRAD[1]="-0.000632359504"/6 -#> GRAD[2]="0.000946423447"/6 -#> GRAD[3]="-0.000587996800"/6 -#> GRAD[4]="0.000073587467"/6 -#> GRAD[5]="-0.000898869749"/6 -#> GRAD[6]="-0.001086079403"/6 -#> GRAD[7]="0.002836873128"/6 -#> GRAD[8]="0.000304361250"/6 -#> GRAD[9]="0.000114959841"/6 -#> GRAD[10]="-0.002278101091"/6 -#> GRAD[11]="-0.000351914948"/6 +#> GRAD[0]="0.001559199223"/6 +#> GRAD[1]="-0.000632581078"/6 +#> GRAD[2]="0.000946477778"/6 +#> GRAD[3]="-0.000588025663"/6 +#> GRAD[4]="0.000073688047"/6 +#> GRAD[5]="-0.000898905590"/6 +#> GRAD[6]="-0.001086232785"/6 +#> GRAD[7]="0.002837476854"/6 +#> GRAD[8]="0.000304232368"/6 +#> GRAD[9]="0.000115059225"/6 +#> GRAD[10]="-0.002278583823"/6 +#> GRAD[11]="-0.000351804556"/6 #>> 25 #>> 27 -#> SEWARD_MLTPL1X="1.314872311183"/5 +#> SEWARD_MLTPL1X="1.314875516605"/5 #> SEWARD_KINETIC="29.214928025013"/5 -#> SEWARD_ATTRACT="-65.038432142489"/5 +#> SEWARD_ATTRACT="-65.038430949428"/5 #>> 28 #> SCF_ITER="11"/8 -#> E_SCF="-150.786112576403"/4 +#> E_SCF="-150.786112648803"/4 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="-0.042779519266"/2 -#> MLTPL__1[1]="0.011252161759"/2 -#> MLTPL__1[2]="0.563858838085"/2 -#> MLTPL__2[0]="-1.622951967447"/2 -#> MLTPL__2[1]="3.178127161030"/2 -#> MLTPL__2[2]="-0.066766624108"/2 -#> MLTPL__2[3]="2.969735673435"/2 -#> MLTPL__2[4]="0.212683686872"/2 -#> MLTPL__2[5]="-1.346783705989"/2 +#> MLTPL__1[0]="-0.042783249886"/2 +#> MLTPL__1[1]="0.011253211699"/2 +#> MLTPL__1[2]="0.563882720150"/2 +#> MLTPL__2[0]="-1.622964550555"/2 +#> MLTPL__2[1]="3.178080721847"/2 +#> MLTPL__2[2]="-0.066775769525"/2 +#> MLTPL__2[3]="2.969677192224"/2 +#> MLTPL__2[4]="0.212683713220"/2 +#> MLTPL__2[5]="-1.346712641668"/2 #>> 29 -#> GRAD[0]="-0.009191743019"/6 -#> GRAD[1]="-0.010401552798"/6 -#> GRAD[2]="-0.001501190072"/6 -#> GRAD[3]="-0.000265158596"/6 -#> GRAD[4]="0.006226381724"/6 -#> GRAD[5]="0.001610071937"/6 -#> GRAD[6]="0.006172978368"/6 -#> GRAD[7]="0.010951674765"/6 -#> GRAD[8]="-0.002766058487"/6 -#> GRAD[9]="0.003283923248"/6 -#> GRAD[10]="-0.006776503691"/6 -#> GRAD[11]="0.002657176622"/6 +#> GRAD[0]="-0.009190611891"/6 +#> GRAD[1]="-0.010402324960"/6 +#> GRAD[2]="-0.001501520936"/6 +#> GRAD[3]="-0.000265947965"/6 +#> GRAD[4]="0.006226549692"/6 +#> GRAD[5]="0.001610352478"/6 +#> GRAD[6]="0.006172238670"/6 +#> GRAD[7]="0.010951111341"/6 +#> GRAD[8]="-0.002765804027"/6 +#> GRAD[9]="0.003284321185"/6 +#> GRAD[10]="-0.006775336074"/6 +#> GRAD[11]="0.002656972484"/6 #>> 30 #>> 32 -#> SEWARD_MLTPL1X="1.310996036777"/5 +#> SEWARD_MLTPL1X="1.311000731604"/5 #> SEWARD_KINETIC="29.214928025013"/5 -#> SEWARD_ATTRACT="-65.050336833904"/5 +#> SEWARD_ATTRACT="-65.050332527959"/5 #>> 33 #> SCF_ITER="10"/8 -#> E_SCF="-150.786301147979"/4 +#> E_SCF="-150.786301206732"/4 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="-0.054410691327"/2 -#> MLTPL__1[1]="0.014334392543"/2 -#> MLTPL__1[2]="0.715228483446"/2 -#> MLTPL__2[0]="-1.687813114238"/2 -#> MLTPL__2[1]="2.915976677096"/2 -#> MLTPL__2[2]="-0.096746042271"/2 -#> MLTPL__2[3]="2.564976980722"/2 -#> MLTPL__2[4]="0.204925193771"/2 -#> MLTPL__2[5]="-0.877163866485"/2 +#> MLTPL__1[0]="-0.054411803241"/2 +#> MLTPL__1[1]="0.014335043143"/2 +#> MLTPL__1[2]="0.715210828853"/2 +#> MLTPL__2[0]="-1.687805566263"/2 +#> MLTPL__2[1]="2.916003767430"/2 +#> MLTPL__2[2]="-0.096750072772"/2 +#> MLTPL__2[3]="2.565026894729"/2 +#> MLTPL__2[4]="0.204929000279"/2 +#> MLTPL__2[5]="-0.877221328466"/2 #>> 34 -#> GRAD[0]="-0.011791937949"/6 -#> GRAD[1]="-0.011210693085"/6 -#> GRAD[2]="-0.002989540544"/6 -#> GRAD[3]="0.000046888986"/6 -#> GRAD[4]="0.006540991012"/6 -#> GRAD[5]="0.003495847623"/6 -#> GRAD[6]="0.007936356636"/6 -#> GRAD[7]="0.010492647359"/6 -#> GRAD[8]="-0.004640470376"/6 -#> GRAD[9]="0.003808692327"/6 -#> GRAD[10]="-0.005822945286"/6 -#> GRAD[11]="0.004134163297"/6 +#> GRAD[0]="-0.011790052917"/6 +#> GRAD[1]="-0.011210799601"/6 +#> GRAD[2]="-0.002989606853"/6 +#> GRAD[3]="0.000046130367"/6 +#> GRAD[4]="0.006541008528"/6 +#> GRAD[5]="0.003495623251"/6 +#> GRAD[6]="0.007935275368"/6 +#> GRAD[7]="0.010491116717"/6 +#> GRAD[8]="-0.004638913999"/6 +#> GRAD[9]="0.003808647182"/6 +#> GRAD[10]="-0.005821325644"/6 +#> GRAD[11]="0.004132897601"/6 #>> 35 #>> 37 -#> SEWARD_MLTPL1X="1.319682080948"/5 +#> SEWARD_MLTPL1X="1.319683964656"/5 #> SEWARD_KINETIC="29.214928025013"/5 -#> SEWARD_ATTRACT="-65.039417950504"/5 +#> SEWARD_ATTRACT="-65.039417320607"/5 #>> 38 #> SCF_ITER="9"/8 -#> E_SCF="-150.786560948478"/4 +#> E_SCF="-150.786560962703"/4 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="-0.059969113667"/2 -#> MLTPL__1[1]="0.013053240613"/2 -#> MLTPL__1[2]="0.730918688199"/2 -#> MLTPL__2[0]="-1.669434424884"/2 -#> MLTPL__2[1]="2.911763849798"/2 -#> MLTPL__2[2]="-0.104873276810"/2 -#> MLTPL__2[3]="2.515908743569"/2 -#> MLTPL__2[4]="0.210243560538"/2 -#> MLTPL__2[5]="-0.846474318685"/2 +#> MLTPL__1[0]="-0.059970858222"/2 +#> MLTPL__1[1]="0.013054413815"/2 +#> MLTPL__1[2]="0.730917870797"/2 +#> MLTPL__2[0]="-1.669431524628"/2 +#> MLTPL__2[1]="2.911764091864"/2 +#> MLTPL__2[2]="-0.104879644254"/2 +#> MLTPL__2[3]="2.515908718020"/2 +#> MLTPL__2[4]="0.210245560279"/2 +#> MLTPL__2[5]="-0.846477193393"/2 #>> 39 -#> GRAD[0]="-0.006945453099"/6 -#> GRAD[1]="-0.004693481160"/6 -#> GRAD[2]="-0.001613174890"/6 -#> GRAD[3]="0.001005407093"/6 -#> GRAD[4]="0.003474999470"/6 -#> GRAD[5]="0.001859757546"/6 -#> GRAD[6]="0.004869856198"/6 -#> GRAD[7]="0.002778485797"/6 -#> GRAD[8]="-0.001268929269"/6 -#> GRAD[9]="0.001070189807"/6 -#> GRAD[10]="-0.001560004107"/6 -#> GRAD[11]="0.001022346613"/6 +#> GRAD[0]="-0.006945005787"/6 +#> GRAD[1]="-0.004693304863"/6 +#> GRAD[2]="-0.001613291554"/6 +#> GRAD[3]="0.001005232955"/6 +#> GRAD[4]="0.003474950384"/6 +#> GRAD[5]="0.001859718812"/6 +#> GRAD[6]="0.004869713253"/6 +#> GRAD[7]="0.002777086407"/6 +#> GRAD[8]="-0.001267926714"/6 +#> GRAD[9]="0.001070059579"/6 +#> GRAD[10]="-0.001558731927"/6 +#> GRAD[11]="0.001021499456"/6 #>> 40 #>> 42 -#> SEWARD_MLTPL1X="1.329290132624"/5 +#> SEWARD_MLTPL1X="1.329290039840"/5 #> SEWARD_KINETIC="29.214928025013"/5 -#> SEWARD_ATTRACT="-65.028110397100"/5 +#> SEWARD_ATTRACT="-65.028111480672"/5 #>> 43 #> SCF_ITER="10"/8 -#> E_SCF="-150.786630343291"/4 +#> E_SCF="-150.786630341557"/4 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="-0.064876632635"/2 -#> MLTPL__1[1]="0.010903113693"/2 -#> MLTPL__1[2]="0.743066656911"/2 -#> MLTPL__2[0]="-1.665105136330"/2 -#> MLTPL__2[1]="2.890366255926"/2 -#> MLTPL__2[2]="-0.115583664710"/2 -#> MLTPL__2[3]="2.474214154268"/2 -#> MLTPL__2[4]="0.209632164907"/2 -#> MLTPL__2[5]="-0.809109017938"/2 +#> MLTPL__1[0]="-0.064877182729"/2 +#> MLTPL__1[1]="0.010904241364"/2 +#> MLTPL__1[2]="0.743061287956"/2 +#> MLTPL__2[0]="-1.665101854856"/2 +#> MLTPL__2[1]="2.890377157449"/2 +#> MLTPL__2[2]="-0.115587191214"/2 +#> MLTPL__2[3]="2.474230403631"/2 +#> MLTPL__2[4]="0.209632444334"/2 +#> MLTPL__2[5]="-0.809128548775"/2 #>> 44 -#> GRAD[0]="-0.001754985476"/6 -#> GRAD[1]="-0.000093737592"/6 -#> GRAD[2]="-0.000136201350"/6 -#> GRAD[3]="0.000515904628"/6 -#> GRAD[4]="0.000299558970"/6 -#> GRAD[5]="0.000133417231"/6 -#> GRAD[6]="0.001403462666"/6 -#> GRAD[7]="-0.000401154647"/6 -#> GRAD[8]="0.000205866459"/6 -#> GRAD[9]="-0.000164381818"/6 -#> GRAD[10]="0.000195333268"/6 -#> GRAD[11]="-0.000203082340"/6 +#> GRAD[0]="-0.001755448861"/6 +#> GRAD[1]="-0.000093901296"/6 +#> GRAD[2]="-0.000136211065"/6 +#> GRAD[3]="0.000515952637"/6 +#> GRAD[4]="0.000299655150"/6 +#> GRAD[5]="0.000133418031"/6 +#> GRAD[6]="0.001403835857"/6 +#> GRAD[7]="-0.000401053191"/6 +#> GRAD[8]="0.000205902378"/6 +#> GRAD[9]="-0.000164339633"/6 +#> GRAD[10]="0.000195299338"/6 +#> GRAD[11]="-0.000203109343"/6 #>> 45 #>> 47 -#> SEWARD_MLTPL1X="1.331988612499"/5 +#> SEWARD_MLTPL1X="1.331989049598"/5 #> SEWARD_KINETIC="29.214928025013"/5 -#> SEWARD_ATTRACT="-65.024549689798"/5 +#> SEWARD_ATTRACT="-65.024550124382"/5 #>> 48 #> SCF_ITER="8"/8 -#> E_SCF="-150.786634830906"/4 +#> E_SCF="-150.786634830876"/4 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="-0.065448223486"/2 -#> MLTPL__1[1]="0.010331750632"/2 -#> MLTPL__1[2]="0.740821775567"/2 -#> MLTPL__2[0]="-1.665806693208"/2 -#> MLTPL__2[1]="2.890902189875"/2 -#> MLTPL__2[2]="-0.116894772617"/2 -#> MLTPL__2[3]="2.480610275047"/2 -#> MLTPL__2[4]="0.209204559215"/2 -#> MLTPL__2[5]="-0.814803581839"/2 +#> MLTPL__1[0]="-0.065449714536"/2 +#> MLTPL__1[1]="0.010332855110"/2 +#> MLTPL__1[2]="0.740825130581"/2 +#> MLTPL__2[0]="-1.665806661138"/2 +#> MLTPL__2[1]="2.890895323282"/2 +#> MLTPL__2[2]="-0.116901475109"/2 +#> MLTPL__2[3]="2.480598665288"/2 +#> MLTPL__2[4]="0.209203928207"/2 +#> MLTPL__2[5]="-0.814792004150"/2 #>> 49 -#> GRAD[0]="-0.000308881602"/6 -#> GRAD[1]="0.000216128020"/6 -#> GRAD[2]="0.000050300392"/6 -#> GRAD[3]="0.000104842198"/6 -#> GRAD[4]="-0.000099862343"/6 -#> GRAD[5]="-0.000086958230"/6 -#> GRAD[6]="0.000334922006"/6 -#> GRAD[7]="-0.000229710280"/6 -#> GRAD[8]="0.000162414338"/6 -#> GRAD[9]="-0.000130882602"/6 -#> GRAD[10]="0.000113444603"/6 -#> GRAD[11]="-0.000125756499"/6 +#> GRAD[0]="-0.000308975306"/6 +#> GRAD[1]="0.000216169220"/6 +#> GRAD[2]="0.000050303786"/6 +#> GRAD[3]="0.000104840848"/6 +#> GRAD[4]="-0.000099925262"/6 +#> GRAD[5]="-0.000086966388"/6 +#> GRAD[6]="0.000335016307"/6 +#> GRAD[7]="-0.000229635349"/6 +#> GRAD[8]="0.000162353428"/6 +#> GRAD[9]="-0.000130881849"/6 +#> GRAD[10]="0.000113391391"/6 +#> GRAD[11]="-0.000125690825"/6 #>> 50 #>> 52 -#> SEWARD_MLTPL1X="1.332426958273"/5 +#> SEWARD_MLTPL1X="1.332427501305"/5 #> SEWARD_KINETIC="29.214928025013"/5 -#> SEWARD_ATTRACT="-65.023781966288"/5 +#> SEWARD_ATTRACT="-65.023781996402"/5 #>> 53 #> SCF_ITER="7"/8 -#> E_SCF="-150.786635184090"/4 +#> E_SCF="-150.786635184065"/4 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="-0.065639299579"/2 -#> MLTPL__1[1]="0.010337610329"/2 -#> MLTPL__1[2]="0.742883330476"/2 -#> MLTPL__2[0]="-1.667867745078"/2 -#> MLTPL__2[1]="2.884880301100"/2 -#> MLTPL__2[2]="-0.117790955883"/2 -#> MLTPL__2[3]="2.473963173150"/2 -#> MLTPL__2[4]="0.208806696905"/2 -#> MLTPL__2[5]="-0.806095428072"/2 +#> MLTPL__1[0]="-0.065640237722"/2 +#> MLTPL__1[1]="0.010338677730"/2 +#> MLTPL__1[2]="0.742880292979"/2 +#> MLTPL__2[0]="-1.667865033474"/2 +#> MLTPL__2[1]="2.884886799158"/2 +#> MLTPL__2[2]="-0.117795477770"/2 +#> MLTPL__2[3]="2.473972114881"/2 +#> MLTPL__2[4]="0.208806799302"/2 +#> MLTPL__2[5]="-0.806107081407"/2 #>> 54 -#> GRAD[0]="-0.000003611225"/6 -#> GRAD[1]="0.000046312243"/6 -#> GRAD[2]="0.000004021093"/6 -#> GRAD[3]="-0.000024180285"/6 -#> GRAD[4]="-0.000050884759"/6 -#> GRAD[5]="-0.000022594815"/6 -#> GRAD[6]="0.000049085657"/6 -#> GRAD[7]="-0.000005917642"/6 -#> GRAD[8]="0.000021393509"/6 -#> GRAD[9]="-0.000021294147"/6 -#> GRAD[10]="0.000010490158"/6 -#> GRAD[11]="-0.000002819787"/6 +#> GRAD[0]="-0.000003663545"/6 +#> GRAD[1]="0.000046309517"/6 +#> GRAD[2]="0.000004041702"/6 +#> GRAD[3]="-0.000024156413"/6 +#> GRAD[4]="-0.000050863655"/6 +#> GRAD[5]="-0.000022615678"/6 +#> GRAD[6]="0.000049128759"/6 +#> GRAD[7]="-0.000005910327"/6 +#> GRAD[8]="0.000021415083"/6 +#> GRAD[9]="-0.000021308800"/6 +#> GRAD[10]="0.000010464465"/6 +#> GRAD[11]="-0.000002841107"/6 #>> 55 #> GEO_ITER="11"/8 -#> SEWARD_MLTPL1X="1.332396554288"/5 +#> SEWARD_MLTPL1X="1.332397117724"/5 #> SEWARD_KINETIC="29.214928025013"/5 -#> SEWARD_ATTRACT="-65.023652428884"/5 +#> SEWARD_ATTRACT="-65.023652486783"/5 #> SCF_ITER="6"/8 -#> E_SCF="-150.786635202378"/4 +#> E_SCF="-150.786635202291"/4 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="-0.065476539761"/2 -#> MLTPL__1[1]="0.010358395508"/2 -#> MLTPL__1[2]="0.741741500218"/2 -#> MLTPL__2[0]="-1.667512695345"/2 -#> MLTPL__2[1]="2.887216688276"/2 -#> MLTPL__2[2]="-0.117291196092"/2 -#> MLTPL__2[3]="2.477706821765"/2 -#> MLTPL__2[4]="0.208901056763"/2 -#> MLTPL__2[5]="-0.810194126420"/2 +#> MLTPL__1[0]="-0.065477749131"/2 +#> MLTPL__1[1]="0.010359505758"/2 +#> MLTPL__1[2]="0.741741821750"/2 +#> MLTPL__2[0]="-1.667511337551"/2 +#> MLTPL__2[1]="2.887216159578"/2 +#> MLTPL__2[2]="-0.117296843672"/2 +#> MLTPL__2[3]="2.477704935813"/2 +#> MLTPL__2[4]="0.208900868032"/2 +#> MLTPL__2[5]="-0.810193598262"/2 #>> 56 >>EOF diff -Nru openmolcas-22.02/test/additional/382.input openmolcas-22.10/test/additional/382.input --- openmolcas-22.02/test/additional/382.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/382.input 2022-10-10 14:22:40.000000000 +0000 @@ -4,7 +4,7 @@ * Symmetry: C1 * Features tested: SEWARD, GUESSORB, RASSCF, CASPT2 with Cholesky * Responsible person: Steven Vancoillie -* Comments: Test of Cholesky MS-CASPT2, RHS on-demand without symmetry +* Comments: Test of Cholesky MS-CASPT2, RHS on-demand without symmetry, EFFE *------------------------------------------------------------------------------- >export MOLCAS_THR=1 >export MOLCAS_PRINT=Verbose @@ -57,12 +57,22 @@ RHSD Frozen = 1 MultiState = 2 1 4 +* Note: extra long lines to test they're not truncated EffectiveHamiltonian = 2 - -106.996145202170 0.019061862198 - 0.023338576494 -106.988629386055 +-106.996145202170 0.019061862198 +0.023338576494 -106.988629386055 MaxIter = 40 PROPerties + &CASPT2 +Frozen = 1 +xMultiState = 2 1 4 +Effe = 2 + -106.98018118 -0.00811475 + -0.00774097 -107.01044388 +MaxIter = 40 + + >> FILE lif.xyz 2 LiF @@ -72,9 +82,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 19.11-470-g37001a33 -* Linux lucifer 4.15.0-96-generic #97-Ubuntu SMP Wed Apr 1 03:25:46 UTC 2020 x86_64 x86_64 x86_64 GNU/Linux -* Mon Apr 27 08:22:41 2020 +* Molcas version 22.02-325-g3ccbee302 +* Linux schrodinger 5.17.9-1-MANJARO #1 SMP PREEMPT Wed May 18 09:20:53 UTC 2022 x86_64 GNU/Linux +* Tue Jun 7 10:42:27 2022 * #>> 1 #> POTNUC="3.176470794921"/12 @@ -85,13 +95,16 @@ #> SEWARD_ATTRACT="-9.111557434772"/5 #>> 3 #> RASSCF_ITER="33"/8 -#> E_RASSCF[0]="-106.857598580275"/6 -#> E_RASSCF[1]="-106.836457097953"/6 +#> E_RASSCF[0]="-106.857598581048"/6 +#> E_RASSCF[1]="-106.836457097179"/6 #>> 4 -#> E_CASPT2="-106.996145350109"/6 +#> E_CASPT2="-106.996145454224"/6 #>> 5 -#> E_CASPT2="-106.988629394565"/6 +#> E_CASPT2="-106.988629415478"/6 #>> 6 #> E_MSPT2[0]="-107.013917997150"/6 #> E_MSPT2[1]="-106.970856591075"/6 +#>> 7 +#> E_MSPT2[0]="-107.012394939578"/6 +#> E_MSPT2[1]="-106.978230120422"/6 >>EOF diff -Nru openmolcas-22.02/test/additional/392.input openmolcas-22.10/test/additional/392.input --- openmolcas-22.02/test/additional/392.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/392.input 2022-10-10 14:22:40.000000000 +0000 @@ -168,9 +168,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 20.10-241-g70ed4f8b -* Linux otis 4.15.0-1073-oem #83-Ubuntu SMP Mon Feb 17 11:21:18 UTC 2020 x86_64 x86_64 x86_64 GNU/Linux -* Fri Nov 27 15:35:18 2020 +* Molcas version 22.02-135-ge74223037 +* Linux otis 5.4.0-104-generic #118~18.04.1-Ubuntu SMP Thu Mar 3 13:53:15 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Sun Apr 3 08:58:10 2022 * #>> 1 #> POTNUC="0.0"/12 @@ -185,7 +185,7 @@ #>> 3 #> RASSCF_ITER="4"/8 #> E_RASSCF="-341.531462728033"/8 -#> MLTPL__0="-0.000000000000"/5 +#> MLTPL__0="0.0"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 @@ -197,122 +197,122 @@ #> MLTPL__2[5]="0.0"/5 #>> 4 #> RASSCF_ITER="4"/8 -#> E_RASSCF[0]="-341.459898220842"/8 -#> E_RASSCF[1]="-341.459898220842"/8 -#> E_RASSCF[2]="-341.459898220842"/8 -#> E_RASSCF[3]="-341.459898220842"/8 -#> E_RASSCF[4]="-341.459898220842"/8 -#> E_RASSCF[5]="-341.412200578598"/8 -#> E_RASSCF[6]="-341.412200578598"/8 -#> E_RASSCF[7]="-341.412200578598"/8 +#> E_RASSCF[0]="-341.459898220843"/8 +#> E_RASSCF[1]="-341.459898220843"/8 +#> E_RASSCF[2]="-341.459898220843"/8 +#> E_RASSCF[3]="-341.459898220843"/8 +#> E_RASSCF[4]="-341.459898220843"/8 +#> E_RASSCF[5]="-341.412200578599"/8 +#> E_RASSCF[6]="-341.412200578599"/8 +#> E_RASSCF[7]="-341.412200578599"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.000000000019"/5 +#> MLTPL__2[0]="0.000000000012"/5 #> MLTPL__2[1]="-0.000000000000"/5 -#> MLTPL__2[2]="-0.000000000012"/5 -#> MLTPL__2[3]="-0.000000000002"/5 -#> MLTPL__2[4]="-0.000000000000"/5 -#> MLTPL__2[5]="0.000000000020"/5 +#> MLTPL__2[2]="0.000000000001"/5 +#> MLTPL__2[3]="0.000000000001"/5 +#> MLTPL__2[4]="-0.000000000001"/5 +#> MLTPL__2[5]="-0.000000000012"/5 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.000000000070"/5 -#> MLTPL__2[1]="-0.000000000000"/5 -#> MLTPL__2[2]="0.000000000011"/5 -#> MLTPL__2[3]="0.000000000061"/5 -#> MLTPL__2[4]="-0.000000000000"/5 -#> MLTPL__2[5]="0.000000000008"/5 +#> MLTPL__2[0]="0.000000000018"/5 +#> MLTPL__2[1]="0.000000000003"/5 +#> MLTPL__2[2]="0.000000000013"/5 +#> MLTPL__2[3]="-0.000000000024"/5 +#> MLTPL__2[4]="0.000000000006"/5 +#> MLTPL__2[5]="0.000000000006"/5 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.000000000000"/5 -#> MLTPL__2[1]="-0.000000000000"/5 -#> MLTPL__2[2]="0.000000000001"/5 -#> MLTPL__2[3]="0.0"/5 -#> MLTPL__2[4]="0.000000000000"/5 -#> MLTPL__2[5]="0.000000000000"/5 -#> MLTPL__0="0.0"/5 +#> MLTPL__2[0]="0.000000000014"/5 +#> MLTPL__2[1]="-0.000000000001"/5 +#> MLTPL__2[2]="0.000000000000"/5 +#> MLTPL__2[3]="-0.000000000000"/5 +#> MLTPL__2[4]="0.000000000001"/5 +#> MLTPL__2[5]="-0.000000000014"/5 +#> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.000000000107"/5 -#> MLTPL__2[1]="0.000000000000"/5 -#> MLTPL__2[2]="-0.000000000013"/5 -#> MLTPL__2[3]="0.0"/5 -#> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.000000000107"/5 +#> MLTPL__2[0]="0.000000000016"/5 +#> MLTPL__2[1]="-0.000000000002"/5 +#> MLTPL__2[2]="0.000000000001"/5 +#> MLTPL__2[3]="-0.000000000001"/5 +#> MLTPL__2[4]="-0.000000000005"/5 +#> MLTPL__2[5]="-0.000000000014"/5 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.000000000001"/5 +#> MLTPL__2[0]="0.000000000000"/5 #> MLTPL__2[1]="0.000000000000"/5 -#> MLTPL__2[2]="0.000000000012"/5 -#> MLTPL__2[3]="0.0"/5 -#> MLTPL__2[4]="0.000000000000"/5 -#> MLTPL__2[5]="0.000000000001"/5 +#> MLTPL__2[2]="-0.000000000000"/5 +#> MLTPL__2[3]="-0.000000000000"/5 +#> MLTPL__2[4]="-0.000000000000"/5 +#> MLTPL__2[5]="0.0"/5 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.000000000028"/5 -#> MLTPL__2[1]="0.000000000000"/5 -#> MLTPL__2[2]="-0.000000000013"/5 -#> MLTPL__2[3]="-0.000000000010"/5 -#> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.000000000017"/5 +#> MLTPL__2[0]="0.000000000001"/5 +#> MLTPL__2[1]="-0.000000000001"/5 +#> MLTPL__2[2]="-0.000000000009"/5 +#> MLTPL__2[3]="-0.000000000007"/5 +#> MLTPL__2[4]="-0.000000000001"/5 +#> MLTPL__2[5]="0.000000000006"/5 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.000000000060"/5 +#> MLTPL__2[0]="-0.000000000031"/5 #> MLTPL__2[1]="-0.000000000000"/5 -#> MLTPL__2[2]="0.000000000014"/5 -#> MLTPL__2[3]="-0.000000000049"/5 -#> MLTPL__2[4]="0.000000000000"/5 -#> MLTPL__2[5]="-0.000000000011"/5 +#> MLTPL__2[2]="-0.000000000005"/5 +#> MLTPL__2[3]="0.000000000032"/5 +#> MLTPL__2[4]="-0.000000000003"/5 +#> MLTPL__2[5]="-0.000000000000"/5 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.000000000109"/5 -#> MLTPL__2[1]="-0.000000000000"/5 +#> MLTPL__2[0]="-0.000000000029"/5 +#> MLTPL__2[1]="0.000000000000"/5 #> MLTPL__2[2]="-0.000000000000"/5 -#> MLTPL__2[3]="0.0"/5 -#> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.000000000109"/5 +#> MLTPL__2[3]="0.000000000000"/5 +#> MLTPL__2[4]="0.000000000002"/5 +#> MLTPL__2[5]="0.000000000029"/5 #>> 5 #> E_RASSI[0]="-341.531462728033"/7 -#> E_RASSI[1]="-341.459898220842"/7 -#> E_RASSI[2]="-341.459898220842"/7 -#> E_RASSI[3]="-341.459898220842"/7 -#> E_RASSI[4]="-341.459898220842"/7 -#> E_RASSI[5]="-341.459898220842"/7 -#> E_RASSI[6]="-341.412200578598"/7 -#> E_RASSI[7]="-341.412200578598"/7 -#> E_RASSI[8]="-341.412200578598"/7 -#> ESO_LOW[0]="-341.531472985632"/8 -#> ESO_LOW[1]="-341.531472985632"/8 -#> ESO_LOW[2]="-341.531472985632"/8 -#> ESO_LOW[3]="-341.531472985632"/8 -#> ESO_LOW[4]="-341.459930540964"/8 -#> ESO_LOW[5]="-341.459930540964"/8 -#> ESO_LOW[6]="-341.459930540964"/8 -#> ESO_LOW[7]="-341.459930540964"/8 -#> ESO_LOW[8]="-341.459898220842"/8 -#> ESO_LOW[9]="-341.459898220842"/8 -#> ESO_LOW[10]="-341.459898220842"/8 -#> ESO_LOW[11]="-341.459898220842"/8 -#> ESO_LOW[12]="-341.459898220842"/8 -#> ESO_LOW[13]="-341.459898220842"/8 -#> ESO_LOW[14]="-341.412200578598"/8 -#> ESO_LOW[15]="-341.412200578598"/8 -#> ESO_LOW[16]="-341.412158000877"/8 -#> ESO_LOW[17]="-341.412158000877"/8 -#> ESO_LOW[18]="-341.412158000877"/8 -#> ESO_LOW[19]="-341.412158000877"/8 +#> E_RASSI[1]="-341.459898220843"/7 +#> E_RASSI[2]="-341.459898220843"/7 +#> E_RASSI[3]="-341.459898220843"/7 +#> E_RASSI[4]="-341.459898220843"/7 +#> E_RASSI[5]="-341.459898220843"/7 +#> E_RASSI[6]="-341.412200578599"/7 +#> E_RASSI[7]="-341.412200578599"/7 +#> E_RASSI[8]="-341.412200578599"/7 +#> ESO_LOW[0]="-341.531472985633"/7 +#> ESO_LOW[1]="-341.531472985633"/7 +#> ESO_LOW[2]="-341.531472985633"/7 +#> ESO_LOW[3]="-341.531472985633"/7 +#> ESO_LOW[4]="-341.459930540964"/7 +#> ESO_LOW[5]="-341.459930540964"/7 +#> ESO_LOW[6]="-341.459930540964"/7 +#> ESO_LOW[7]="-341.459930540964"/7 +#> ESO_LOW[8]="-341.459898220843"/7 +#> ESO_LOW[9]="-341.459898220843"/7 +#> ESO_LOW[10]="-341.459898220843"/7 +#> ESO_LOW[11]="-341.459898220843"/7 +#> ESO_LOW[12]="-341.459898220843"/7 +#> ESO_LOW[13]="-341.459898220843"/7 +#> ESO_LOW[14]="-341.412200578599"/7 +#> ESO_LOW[15]="-341.412200578599"/7 +#> ESO_LOW[16]="-341.412158000877"/7 +#> ESO_LOW[17]="-341.412158000877"/7 +#> ESO_LOW[18]="-341.412158000877"/7 +#> ESO_LOW[19]="-341.412158000877"/7 >>EOF diff -Nru openmolcas-22.02/test/additional/400.input openmolcas-22.10/test/additional/400.input --- openmolcas-22.02/test/additional/400.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/400.input 2022-10-10 14:22:40.000000000 +0000 @@ -20,9 +20,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.02-1119-gde6a49c4e -* Linux otis 4.15.0-1073-oem #83-Ubuntu SMP Mon Feb 17 11:21:18 UTC 2020 x86_64 x86_64 x86_64 GNU/Linux -* Thu May 13 19:53:52 2021 +* Molcas version 22.02-260-gd39e60428 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Wed Apr 27 18:28:24 2022 * #>> 1 #> POTNUC="141.399122221533"/12 @@ -32,35 +32,35 @@ #> SEWARD_KINETIC="16.052757759106"/5 #> SEWARD_ATTRACT="-41.786176458464"/5 #>> 3 -#> SCF_ITER="12"/8 -#> E_SCF="-338.197645833348"/4 -#> MLTPL__0="-0.000000000002"/2 -#> MLTPL__1[0]="-0.001085958800"/2 -#> MLTPL__1[1]="-0.001621737252"/2 -#> MLTPL__1[2]="0.000344057899"/2 -#> MLTPL__2[0]="0.008047481639"/2 -#> MLTPL__2[1]="2.699974572879"/2 -#> MLTPL__2[2]="2.697729362660"/2 -#> MLTPL__2[3]="-0.020891521969"/2 -#> MLTPL__2[4]="2.678567648889"/2 -#> MLTPL__2[5]="0.012844040330"/2 +#> SCF_ITER="13"/8 +#> E_SCF="-338.197645833593"/4 +#> MLTPL__0="-0.000000000003"/2 +#> MLTPL__1[0]="-0.001086941877"/2 +#> MLTPL__1[1]="-0.001625921496"/2 +#> MLTPL__1[2]="0.000349194568"/2 +#> MLTPL__2[0]="0.008074926051"/2 +#> MLTPL__2[1]="2.699952394360"/2 +#> MLTPL__2[2]="2.697736534039"/2 +#> MLTPL__2[3]="-0.020890748770"/2 +#> MLTPL__2[4]="2.678601524190"/2 +#> MLTPL__2[5]="0.012815822719"/2 #>> 4 -#> GRAD[0]="0.139560604319"/6 -#> GRAD[1]="-0.035646782686"/6 -#> GRAD[2]="-0.104871156145"/6 -#> GRAD[3]="-0.129249836536"/6 -#> GRAD[4]="0.033067217760"/6 -#> GRAD[5]="0.097097498191"/6 -#> GRAD[6]="-0.035422731173"/6 -#> GRAD[7]="-0.105507269313"/6 -#> GRAD[8]="0.139984136811"/6 -#> GRAD[9]="0.032808271790"/6 -#> GRAD[10]="0.097742847090"/6 -#> GRAD[11]="-0.129608342547"/6 -#> GRAD[12]="-0.104921807419"/6 -#> GRAD[13]="0.139933361669"/6 -#> GRAD[14]="-0.034786981238"/6 -#> GRAD[15]="0.097225499018"/6 -#> GRAD[16]="-0.129589374520"/6 -#> GRAD[17]="0.032184844928"/6 +#> GRAD[0]="0.139561924038"/6 +#> GRAD[1]="-0.035647108070"/6 +#> GRAD[2]="-0.104872152758"/6 +#> GRAD[3]="-0.129251285057"/6 +#> GRAD[4]="0.033067568139"/6 +#> GRAD[5]="0.097098598744"/6 +#> GRAD[6]="-0.035422638932"/6 +#> GRAD[7]="-0.105506974099"/6 +#> GRAD[8]="0.139983781629"/6 +#> GRAD[9]="0.032808216290"/6 +#> GRAD[10]="0.097742659122"/6 +#> GRAD[11]="-0.129608130564"/6 +#> GRAD[12]="-0.104922879865"/6 +#> GRAD[13]="0.139934821756"/6 +#> GRAD[14]="-0.034787360866"/6 +#> GRAD[15]="0.097226663526"/6 +#> GRAD[16]="-0.129590966847"/6 +#> GRAD[17]="0.032185263816"/6 >>EOF diff -Nru openmolcas-22.02/test/additional/417.input openmolcas-22.10/test/additional/417.input --- openmolcas-22.02/test/additional/417.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/417.input 2022-10-10 14:22:40.000000000 +0000 @@ -154,9 +154,9 @@ >>>> EOF >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-1064-g65e03e984 -* Linux lucifer 5.13.0-28-generic #31~20.04.1-Ubuntu SMP Wed Jan 19 14:08:10 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux -* Wed Feb 9 22:25:50 2022 +* Molcas version 22.02-135-ge74223037 +* Linux otis 5.4.0-104-generic #118~18.04.1-Ubuntu SMP Thu Mar 3 13:53:15 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Sun Apr 3 08:58:10 2022 * #>> 1 #> POTNUC="-421.013388994427"/12 @@ -170,7 +170,7 @@ #> SEWARD_ATTRACT="-685.483762330828"/5 #>> 3 #> RASSCF_ITER="4"/8 -#> E_RASSCF="-1303.139462818836"/8 +#> E_RASSCF="-1303.139462818800"/8 #> MLTPL__0="2"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 @@ -183,8 +183,8 @@ #> MLTPL__2[5]="0.001652689090"/5 #>> 4 #> RASSCF_ITER="5"/8 -#> E_RASSCF[0]="-1276.333531914274"/8 -#> E_RASSCF[1]="-1276.293491781286"/8 +#> E_RASSCF[0]="-1276.333531914239"/8 +#> E_RASSCF[1]="-1276.293491781249"/8 #> MLTPL__0="2"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 @@ -192,47 +192,47 @@ #> MLTPL__2[0]="0.522943784425"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.296364734629"/5 +#> MLTPL__2[3]="-0.296364734630"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.226579049796"/5 +#> MLTPL__2[5]="-0.226579049795"/5 #> MLTPL__0="2"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.380950430917"/5 +#> MLTPL__2[0]="-0.380950430916"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="0.222812430860"/5 +#> MLTPL__2[3]="0.222812430861"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.158138000057"/5 +#> MLTPL__2[5]="0.158138000055"/5 #>> 6 #> RASSCF_ITER="5"/8 -#> E_RASSCF[0]="-1276.336783966511"/8 -#> E_RASSCF[1]="-1276.291060642775"/8 +#> E_RASSCF[0]="-1276.336783966475"/8 +#> E_RASSCF[1]="-1276.291060642738"/8 #> MLTPL__0="2"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.322869836786"/5 +#> MLTPL__2[0]="-0.322869836787"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="0.523357079129"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.200487242343"/5 +#> MLTPL__2[5]="-0.200487242342"/5 #> MLTPL__0="2"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.241897315060"/5 +#> MLTPL__2[0]="0.241897315061"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.371970070238"/5 +#> MLTPL__2[3]="-0.371970070237"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.130072755178"/5 +#> MLTPL__2[5]="0.130072755176"/5 #>> 8 #> RASSCF_ITER="5"/8 -#> E_RASSCF[0]="-1276.339693627599"/8 -#> E_RASSCF[1]="-1276.288994636010"/8 +#> E_RASSCF[0]="-1276.339693627562"/8 +#> E_RASSCF[1]="-1276.288994635974"/8 #> MLTPL__0="2"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 @@ -247,98 +247,98 @@ #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.209709205102"/5 +#> MLTPL__2[0]="0.209709205103"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="0.159938261434"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.369647466536"/5 +#> MLTPL__2[5]="-0.369647466537"/5 #>> 11 #> RASSCF_ITER="5"/8 -#> E_RASSCF[0]="-1276.390350051875"/8 -#> E_RASSCF[1]="-1276.334722431432"/8 +#> E_RASSCF[0]="-1276.390350051839"/8 +#> E_RASSCF[1]="-1276.334722431396"/8 #> MLTPL__0="2"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.417645380107"/5 +#> MLTPL__2[0]="-0.417645380108"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="0.185058231104"/5 +#> MLTPL__2[3]="0.185058231101"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.232587149003"/5 +#> MLTPL__2[5]="0.232587149006"/5 #> MLTPL__0="2"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.468920274654"/5 +#> MLTPL__2[0]="0.468920274655"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.213375358270"/5 +#> MLTPL__2[3]="-0.213375358267"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.255544916385"/5 +#> MLTPL__2[5]="-0.255544916388"/5 #>> 13 #> RASSCF_ITER="5"/8 -#> E_RASSCF[0]="-1276.388012726497"/8 -#> E_RASSCF[1]="-1276.337336053764"/8 +#> E_RASSCF[0]="-1276.388012726459"/8 +#> E_RASSCF[1]="-1276.337336053727"/8 #> MLTPL__0="2"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.154199345090"/5 +#> MLTPL__2[0]="0.154199345091"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="-0.412196504529"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.257997159439"/5 +#> MLTPL__2[5]="0.257997159438"/5 #> MLTPL__0="2"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.188494582111"/5 +#> MLTPL__2[0]="-0.188494582112"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="0.470061762062"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.281567179951"/5 +#> MLTPL__2[5]="-0.281567179950"/5 #>> 15 #> RASSCF_ITER="5"/8 -#> E_RASSCF[0]="-1276.385385288199"/8 -#> E_RASSCF[1]="-1276.340246321191"/8 +#> E_RASSCF[0]="-1276.385385288163"/8 +#> E_RASSCF[1]="-1276.340246321155"/8 #> MLTPL__0="2"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.176857598962"/5 +#> MLTPL__2[0]="0.176857598948"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="0.234779994774"/5 +#> MLTPL__2[3]="0.234779994789"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.411637593737"/5 +#> MLTPL__2[5]="-0.411637593736"/5 #> MLTPL__0="2"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.211705349979"/5 +#> MLTPL__2[0]="-0.211705349964"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.264261079170"/5 +#> MLTPL__2[3]="-0.264261079184"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.475966429149"/5 +#> MLTPL__2[5]="0.475966429148"/5 #>> 18 -#> E_RASSI[0]="-1303.139462818835"/7 -#> E_RASSI[1]="-1276.333531914275"/7 -#> E_RASSI[2]="-1276.293491781287"/7 -#> E_RASSI[3]="-1276.336783966511"/7 -#> E_RASSI[4]="-1276.291060642775"/7 -#> E_RASSI[5]="-1276.339693627599"/7 -#> E_RASSI[6]="-1276.288994636010"/7 -#> E_RASSI[7]="-1276.390350051876"/7 -#> E_RASSI[8]="-1276.334722431433"/7 -#> E_RASSI[9]="-1276.388012726495"/7 -#> E_RASSI[10]="-1276.337336053763"/7 -#> E_RASSI[11]="-1276.385385288198"/7 -#> E_RASSI[12]="-1276.340246321190"/7 +#> E_RASSI[0]="-1303.139462818800"/7 +#> E_RASSI[1]="-1276.333531914238"/7 +#> E_RASSI[2]="-1276.293491781250"/7 +#> E_RASSI[3]="-1276.336783966475"/7 +#> E_RASSI[4]="-1276.291060642740"/7 +#> E_RASSI[5]="-1276.339693627561"/7 +#> E_RASSI[6]="-1276.288994635971"/7 +#> E_RASSI[7]="-1276.390350051840"/7 +#> E_RASSI[8]="-1276.334722431397"/7 +#> E_RASSI[9]="-1276.388012726458"/7 +#> E_RASSI[10]="-1276.337336053726"/7 +#> E_RASSI[11]="-1276.385385288161"/7 +#> E_RASSI[12]="-1276.340246321153"/7 #> TMS(SF,LEN)="0.0"/6 #> TMS(SF,LEN)="0.0"/6 #> TMS(SF,LEN)="0.0"/6 @@ -397,35 +397,35 @@ #> ROTS(SF)="0.0"/4 #> ITMS(SF)="0.118889525460"/6 #> ROTS(SF)="0.0"/4 -#> ITMS(SF)="0.118627736490"/6 +#> ITMS(SF)="0.118627736491"/6 #> ROTS(SF)="0.0"/4 -#> ESO_LOW[0]="-1303.139462818835"/8 -#> ESO_LOW[1]="-1276.526338637094"/8 -#> ESO_LOW[2]="-1276.515767138661"/8 -#> ESO_LOW[3]="-1276.513450433816"/8 -#> ESO_LOW[4]="-1276.510485417935"/8 -#> ESO_LOW[5]="-1276.494982575667"/8 -#> ESO_LOW[6]="-1276.494118970782"/8 -#> ESO_LOW[7]="-1276.493565666476"/8 -#> ESO_LOW[8]="-1276.493301764642"/8 -#> ESO_LOW[9]="-1276.492818896931"/8 -#> ESO_LOW[10]="-1276.470447668576"/8 -#> ESO_LOW[11]="-1276.470086320493"/8 -#> ESO_LOW[12]="-1276.469757299027"/8 -#> ESO_LOW[13]="-1276.469148047446"/8 -#> ESO_LOW[14]="-1276.442077444851"/8 -#> ESO_LOW[15]="-1276.439194979637"/8 -#> ESO_LOW[16]="-1276.436777312727"/8 -#> ESO_LOW[17]="-1276.098122915208"/8 -#> ESO_LOW[18]="-1276.097992210402"/8 -#> ESO_LOW[19]="-1276.095727182583"/8 -#> ESO_LOW[20]="-1276.093472431564"/8 -#> ESO_LOW[21]="-1276.092983569337"/8 -#> ESO_LOW[22]="-1276.068805666116"/8 -#> ESO_LOW[23]="-1276.066909540438"/8 -#> ESO_LOW[24]="-1276.065383096910"/8 +#> ESO_LOW[0]="-1303.139462818800"/7 +#> ESO_LOW[1]="-1276.526338637058"/7 +#> ESO_LOW[2]="-1276.515767138625"/7 +#> ESO_LOW[3]="-1276.513450433780"/7 +#> ESO_LOW[4]="-1276.510485417898"/7 +#> ESO_LOW[5]="-1276.494982575631"/7 +#> ESO_LOW[6]="-1276.494118970745"/7 +#> ESO_LOW[7]="-1276.493565666439"/7 +#> ESO_LOW[8]="-1276.493301764605"/7 +#> ESO_LOW[9]="-1276.492818896895"/7 +#> ESO_LOW[10]="-1276.470447668540"/7 +#> ESO_LOW[11]="-1276.470086320456"/7 +#> ESO_LOW[12]="-1276.469757298991"/7 +#> ESO_LOW[13]="-1276.469148047410"/7 +#> ESO_LOW[14]="-1276.442077444815"/7 +#> ESO_LOW[15]="-1276.439194979602"/7 +#> ESO_LOW[16]="-1276.436777312690"/7 +#> ESO_LOW[17]="-1276.098122915171"/7 +#> ESO_LOW[18]="-1276.097992210365"/7 +#> ESO_LOW[19]="-1276.095727182548"/7 +#> ESO_LOW[20]="-1276.093472431527"/7 +#> ESO_LOW[21]="-1276.092983569300"/7 +#> ESO_LOW[22]="-1276.068805666079"/7 +#> ESO_LOW[23]="-1276.066909540401"/7 +#> ESO_LOW[24]="-1276.065383096873"/7 #> TMS(SO,LEN)="0.0"/6 -#> TMS(SO,LEN)="0.001592374993"/6 +#> TMS(SO,LEN)="0.001592374992"/6 #> TMS(SO,LEN)="0.001948043690"/6 #> TMS(SO,LEN)="0.002424799592"/6 #> TMS(SO,LEN)="0.0"/6 @@ -438,7 +438,7 @@ #> TMS(SO,LEN)="0.000171491506"/6 #> TMS(SO,LEN)="0.0"/6 #> TMS(SO,LEN)="0.078018500226"/6 -#> TMS(SO,LEN)="0.077513643878"/6 +#> TMS(SO,LEN)="0.077513643879"/6 #> TMS(SO,LEN)="0.078147675285"/6 #> TMS(SO,LEN)="0.000091523182"/6 #> TMS(SO,LEN)="0.0"/6 @@ -451,7 +451,7 @@ #> TMS(SO,VEL)="0.0"/6 #> TMS(SO,VEL)="0.001437256337"/6 #> TMS(SO,VEL)="0.001758092641"/6 -#> TMS(SO,VEL)="0.002188178494"/6 +#> TMS(SO,VEL)="0.002188178495"/6 #> TMS(SO,VEL)="0.0"/6 #> TMS(SO,VEL)="0.0"/6 #> TMS(SO,VEL)="0.000002126692"/6 @@ -471,7 +471,7 @@ #> TMS(SO,VEL)="0.000148172195"/6 #> TMS(SO,VEL)="0.047801849123"/6 #> TMS(SO,VEL)="0.047194983331"/6 -#> TMS(SO,VEL)="0.047169880759"/6 +#> TMS(SO,VEL)="0.047169880760"/6 #> TMS(SO,2ND)="0.0"/6 #> TMS(SO,2ND)="0.000000643541"/6 #> TMS(SO,2ND)="-0.000015027954"/6 @@ -526,7 +526,7 @@ #> ROTS(SO)="0.0"/4 #> ITMS(SO)="0.069466121498"/6 #> ROTS(SO)="0.0"/4 -#> ITMS(SO)="0.070000497528"/6 +#> ITMS(SO)="0.070000497527"/6 #> ROTS(SO)="0.0"/4 #> ITMS(SO)="0.000082123582"/6 #> ROTS(SO)="0.0"/4 @@ -538,9 +538,9 @@ #> ROTS(SO)="0.0"/4 #> ITMS(SO)="0.000144844969"/6 #> ROTS(SO)="0.0"/4 -#> ITMS(SO)="0.047720795836"/6 +#> ITMS(SO)="0.047720795837"/6 #> ROTS(SO)="0.0"/4 -#> ITMS(SO)="0.047082890695"/6 +#> ITMS(SO)="0.047082890694"/6 #> ROTS(SO)="0.0"/4 #> ITMS(SO)="0.047084711339"/6 #> ROTS(SO)="0.0"/4 diff -Nru openmolcas-22.02/test/additional/470.input openmolcas-22.10/test/additional/470.input --- openmolcas-22.02/test/additional/470.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/470.input 2022-10-10 14:22:40.000000000 +0000 @@ -178,9 +178,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-842-g5cd5b97d2 -* Darwin Livius-MacBook-Pro.local 20.6.0 Darwin Kernel Version 20.6.0: Wed Nov 10 22:23:07 PST 2021; root:xnu-7195.141.14~1/RELEASE_X86_64 x86_64 -* Wed Jan 26 11:24:05 2022 +* Molcas version 22.02-135-ge74223037 +* Linux otis 5.4.0-104-generic #118~18.04.1-Ubuntu SMP Thu Mar 3 13:53:15 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Sun Apr 3 08:58:10 2022 * #>> 1 #> POTNUC="0.0"/12 @@ -191,9 +191,9 @@ #> SEWARD_ATTRACT="-281.511037244823"/5 #>> 3 #> RASSCF_ITER="4"/8 -#> E_RASSCF[0]="-459.466831870749"/8 -#> E_RASSCF[1]="-459.466831870749"/8 -#> E_RASSCF[2]="-459.466831870749"/8 +#> E_RASSCF[0]="-459.466831870748"/8 +#> E_RASSCF[1]="-459.466831870748"/8 +#> E_RASSCF[2]="-459.466831870748"/8 #>> 4 #> DENS_TT="17"/6 #> DENS_A1="9"/6 @@ -202,10 +202,10 @@ #> DENS_B2="8"/6 #> EXCH_F="1"/6 #> CORR_F="1"/6 -#> EXCHA_A="-13.947810616187"/6 -#> EXCHA_B="-13.415961247373"/6 -#> CORR_E="-0.646029176608"/6 -#> CASDFTE="-459.941019518588"/8 +#> EXCHA_A="-13.947810616065"/6 +#> EXCHA_B="-13.415961247517"/6 +#> CORR_E="-0.646029176595"/6 +#> CASDFTE="-459.941019518596"/8 #> DENS_TT="17"/6 #> DENS_A1="9"/6 #> DENS_B1="8"/6 @@ -213,10 +213,10 @@ #> DENS_B2="8"/6 #> EXCH_F="1"/6 #> CORR_F="1"/6 -#> EXCHA_A="-13.947810616130"/6 -#> EXCHA_B="-13.415961247443"/6 -#> CORR_E="-0.646029176608"/6 -#> CASDFTE="-459.941019518601"/8 +#> EXCHA_A="-13.947810616112"/6 +#> EXCHA_B="-13.415961247472"/6 +#> CORR_E="-0.646029176595"/6 +#> CASDFTE="-459.941019518598"/8 #> DENS_TT="17"/6 #> DENS_A1="9"/6 #> DENS_B1="8"/6 @@ -224,20 +224,20 @@ #> DENS_B2="8"/6 #> EXCH_F="1"/6 #> CORR_F="1"/6 -#> EXCHA_A="-13.947810616073"/6 -#> EXCHA_B="-13.415961247502"/6 -#> CORR_E="-0.646029176608"/6 -#> CASDFTE="-459.941019518603"/8 +#> EXCHA_A="-13.947810616247"/6 +#> EXCHA_B="-13.415961247339"/6 +#> CORR_E="-0.646029176595"/6 +#> CASDFTE="-459.941019518600"/8 #>> 5 -#> E_RASSI[0]="-459.941019518588"/7 -#> E_RASSI[1]="-459.941019518588"/7 -#> E_RASSI[2]="-459.941019518588"/7 -#> ESO_LOW[0]="-459.942263242925"/8 -#> ESO_LOW[1]="-459.942263242925"/8 -#> ESO_LOW[2]="-459.942263242925"/8 -#> ESO_LOW[3]="-459.942263242925"/8 -#> ESO_LOW[4]="-459.938532069915"/8 -#> ESO_LOW[5]="-459.938532069915"/8 +#> E_RASSI[0]="-459.941019518596"/7 +#> E_RASSI[1]="-459.941019518596"/7 +#> E_RASSI[2]="-459.941019518596"/7 +#> ESO_LOW[0]="-459.942263242933"/7 +#> ESO_LOW[1]="-459.942263242933"/7 +#> ESO_LOW[2]="-459.942263242933"/7 +#> ESO_LOW[3]="-459.942263242933"/7 +#> ESO_LOW[4]="-459.938532069923"/7 +#> ESO_LOW[5]="-459.938532069923"/7 #>> 6 #> TEMPERATURE[0]="0.000100000000"/5 #> TEMPERATURE[1]="1"/5 diff -Nru openmolcas-22.02/test/additional/471.input openmolcas-22.10/test/additional/471.input --- openmolcas-22.02/test/additional/471.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/471.input 2022-10-10 14:22:40.000000000 +0000 @@ -180,9 +180,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-842-g5cd5b97d2 -* Darwin Livius-MacBook-Pro.local 20.6.0 Darwin Kernel Version 20.6.0: Wed Nov 10 22:23:07 PST 2021; root:xnu-7195.141.14~1/RELEASE_X86_64 x86_64 -* Wed Jan 26 11:24:05 2022 +* Molcas version 22.02-135-ge74223037 +* Linux otis 5.4.0-104-generic #118~18.04.1-Ubuntu SMP Thu Mar 3 13:53:15 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Sun Apr 3 08:58:10 2022 * #>> 1 #> POTNUC="0.0"/12 @@ -193,9 +193,9 @@ #> SEWARD_ATTRACT="-281.511037244823"/5 #>> 3 #> RASSCF_ITER="4"/8 -#> E_RASSCF[0]="-459.466831870749"/8 -#> E_RASSCF[1]="-459.466831870749"/8 -#> E_RASSCF[2]="-459.466831870749"/8 +#> E_RASSCF[0]="-459.466831870748"/8 +#> E_RASSCF[1]="-459.466831870748"/8 +#> E_RASSCF[2]="-459.466831870748"/8 #>> 4 #> DENS_TT="17"/6 #> DENS_A1="9"/6 @@ -204,10 +204,10 @@ #> DENS_B2="8"/6 #> EXCH_F="1"/6 #> CORR_F="1"/6 -#> EXCHA_A="-13.947810616005"/6 -#> EXCHA_B="-13.415961247566"/6 -#> CORR_E="-0.646029176608"/6 -#> CASDFTE="-459.941019518599"/8 +#> EXCHA_A="-13.947810616644"/6 +#> EXCHA_B="-13.415961246933"/6 +#> CORR_E="-0.646029176595"/6 +#> CASDFTE="-459.941019518591"/8 #> DENS_TT="17"/6 #> DENS_A1="9"/6 #> DENS_B1="8"/6 @@ -215,10 +215,10 @@ #> DENS_B2="8"/6 #> EXCH_F="1"/6 #> CORR_F="1"/6 -#> EXCHA_A="-13.947810616108"/6 -#> EXCHA_B="-13.415961247457"/6 -#> CORR_E="-0.646029176608"/6 -#> CASDFTE="-459.941019518593"/8 +#> EXCHA_A="-13.947810616415"/6 +#> EXCHA_B="-13.415961247170"/6 +#> CORR_E="-0.646029176595"/6 +#> CASDFTE="-459.941019518600"/8 #> DENS_TT="17"/6 #> DENS_A1="9"/6 #> DENS_B1="8"/6 @@ -226,20 +226,20 @@ #> DENS_B2="8"/6 #> EXCH_F="1"/6 #> CORR_F="1"/6 -#> EXCHA_A="-13.947810616193"/6 -#> EXCHA_B="-13.415961247378"/6 -#> CORR_E="-0.646029176608"/6 -#> CASDFTE="-459.941019518599"/8 +#> EXCHA_A="-13.947810616496"/6 +#> EXCHA_B="-13.415961247090"/6 +#> CORR_E="-0.646029176595"/6 +#> CASDFTE="-459.941019518600"/8 #>> 5 -#> E_RASSI[0]="-459.941019518599"/7 -#> E_RASSI[1]="-459.941019518599"/7 -#> E_RASSI[2]="-459.941019518599"/7 -#> ESO_LOW[0]="-459.942263242936"/8 -#> ESO_LOW[1]="-459.942263242936"/8 -#> ESO_LOW[2]="-459.942263242936"/8 -#> ESO_LOW[3]="-459.942263242936"/8 -#> ESO_LOW[4]="-459.938532069925"/8 -#> ESO_LOW[5]="-459.938532069925"/8 +#> E_RASSI[0]="-459.941019518600"/7 +#> E_RASSI[1]="-459.941019518600"/7 +#> E_RASSI[2]="-459.941019518600"/7 +#> ESO_LOW[0]="-459.942263242937"/7 +#> ESO_LOW[1]="-459.942263242937"/7 +#> ESO_LOW[2]="-459.942263242937"/7 +#> ESO_LOW[3]="-459.942263242937"/7 +#> ESO_LOW[4]="-459.938532069926"/7 +#> ESO_LOW[5]="-459.938532069926"/7 #>> 6 #> TEMPERATURE[0]="0.000100000000"/5 #> TEMPERATURE[1]="1"/5 diff -Nru openmolcas-22.02/test/additional/482.input openmolcas-22.10/test/additional/482.input --- openmolcas-22.02/test/additional/482.input 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/test/additional/482.input 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,367 @@ +*------------------------------------------------------------------------------- +* Molecule: N2 dimer +* Basis: ANO +* Symmetry: D2h +* Features tested: Copy RASORB files per iteration +* Responsible person: Oskar Weser +*------------------------------------------------------------------------------- +> export SKIPPED_TEST_CODE=36 +> rm -force SUPPORTS_HDF5 + +> IF ( ${MOLCAS_DRIVER} = UNKNOWN_VARIABLE ) +> EXPORT MOLCAS_DRIVER=molcas +> ENDIF + +> shell ${MOLCAS_DRIVER} have_feature hdf5 && touch SUPPORTS_HDF5 || true + &GATEWAY + RICD + coord + 2 + nitrogen + N 0.0 0.0 0.546237924 + N 0.0 0.0 -0.546237924 + basis = ANO-RCC-VTZP + group = full + +&SEWARD + +> copy N2.InpOrb INPORB + +&RASSCF + LUMORB + Spin = 1 + nactel = 6 + ciroot = 2 2 1 + inactive = 2 0 0 0 2 0 0 0 + RAS2 = 1 1 1 0 1 1 1 0 + PerIteration + +/* We are not interested in the copy, it should just fail, + if the source is not there */ +> foreach i in ( 1 .. 5 ) + > copy ${Project}.IterOrb.${i} asdf +> end do + +> if ( -file SUPPORTS_HDF5 ) + > foreach i in ( 1 .. 5 ) + > copy ${Project}.rasscf.h5.${i} asdf + > end do +> endif + +> rm asdf + +> file N2.InpOrb +#INPORB 2.2 +#INFO +* RASSCF average (pseudo-natural) orbitals + 0 8 0 + 13 7 7 3 13 7 7 3 + 13 7 7 3 13 7 7 3 +*BC:HOST pcal029 PID 18782 DATE Tue May 17 16:04:28 2022 +#EXTRAS +* ACTIVE TWO-EL ENERGY + 0.860774129018E+01 +#ORB +* ORBITAL 1 1 + 1.00020134566741E+00 -4.51930790085819E-03 -2.82642061256242E-03 3.87456959747510E-04 -1.99109667176576E-04 + 1.71976056385602E-03 -1.31681798326821E-03 -2.23608315776000E-04 -7.62758687720273E-04 -8.32405159086326E-18 + -1.46648609089569E-19 2.16572388492427E-04 1.23585439800495E-17 +* ORBITAL 1 2 + -4.07074500954680E-03 8.75158876274111E-01 3.53001624359768E-02 5.39117948526600E-03 4.07721837148295E-01 + 2.08260462855166E-02 3.86879057654446E-03 -8.78722334369399E-03 -3.81615269346864E-03 -9.84712777287428E-17 + -9.86027900897781E-17 -1.13953788083458E-03 1.66637092284796E-16 +* ORBITAL 1 3 + 7.91660657323993E-02 -1.48229781276972E-01 1.33526292876042E-01 7.52964672553203E-03 7.87001224566754E-01 + -1.09948688781573E-01 9.75839329143689E-03 -7.06938152290366E-02 1.31749497946000E-02 -1.36239091121241E-16 + -1.36766666436510E-16 1.31563270308476E-02 3.22176736968356E-17 +* ORBITAL 1 4 + -2.39128840068739E-02 -1.78660682559392E-01 7.22228634724201E-01 3.16438354023620E-01 -2.94619505460601E-01 + 6.40760283788964E-02 4.44192092004179E-02 -1.01240364644020E-01 -6.56659563878400E-02 -1.41577688985045E-15 + -8.95162563422159E-16 3.67369647548819E-03 -2.57026471675673E-16 +* ORBITAL 1 5 + 1.90575464024307E-01 6.10020722996162E-01 -1.08762738121655E-02 1.14152458648641E-02 7.35378901130864E-01 + 1.45090996147432E+00 3.48479678378682E-01 -9.86674464503543E-02 -9.67150727877266E-02 1.77300970817068E-15 + 1.63788216558044E-15 8.14181524449637E-02 2.12664274543474E-16 +* ORBITAL 1 6 + -1.11053278963821E-15 -3.32824440685630E-15 2.14659020073822E-15 7.77365091551611E-16 -3.52650612908242E-15 + -5.53998201455699E-15 -1.16176311994124E-15 1.61008972178204E-15 1.15295658992153E-15 7.10104423487939E-01 + 4.06011259982025E-01 -3.54910913145161E-16 -2.93757175809972E-03 +* ORBITAL 1 7 + 5.91745530281898E-01 1.61581674205845E+00 -5.53349724836862E-01 -4.54464829479848E-01 1.35049075363215E+00 + 1.90244814599599E+00 6.16173939642913E-01 -1.93678932591664E+00 -8.86465928663084E-01 -4.83089982023897E-18 + 3.10453310063130E-16 8.06731277505048E-02 -8.49093567292627E-16 +* ORBITAL 1 8 + -1.04057102268349E-01 -2.87119417534650E-01 4.90214955745542E-01 -6.15007885890036E-01 -1.89377496083554E-01 + -1.70346588016958E-01 -2.10260801068408E-02 3.80240471690344E-01 3.73474842669079E-01 -6.11240887825315E-16 + 7.15624121105997E-16 3.63335563161581E-01 -9.64322362932236E-17 +* ORBITAL 1 9 + 5.42266993775477E-02 8.24679413224648E-02 -1.94909571912958E-01 4.28066967777268E-01 9.10712166989853E-02 + -9.48734013751622E-02 6.66227746510450E-01 -4.07141744642851E-02 1.52256524721277E-01 1.33061948895265E-16 + -3.42423822806733E-15 4.75017405102270E-01 -6.40573751441882E-15 +* ORBITAL 1 10 + 5.60793998517158E-17 -2.22308099043943E-16 -9.65676032499766E-16 3.53100476534159E-15 -7.38565557314471E-17 + -1.66087288624973E-15 5.59383772955526E-15 -6.08086730918192E-16 1.98913856202933E-15 2.38335562748865E-02 + 3.50224309523769E-01 2.91970620344209E-15 8.29543868862432E-01 +* ORBITAL 1 11 + 2.38226921349249E-16 5.97464175580639E-16 4.10224578605696E-17 -8.92404164902860E-16 3.97172003926462E-16 + 1.50662042077344E-15 -4.36350503126291E-16 -8.15794101729805E-16 3.01225418472766E-16 6.10039108098148E-01 + -7.23183252307476E-01 1.36002493508869E-16 3.56890119578753E-01 +* ORBITAL 1 12 + 3.51531696895818E-01 1.01681154955114E+00 -1.74838143025613E-01 -4.28247361319993E-01 1.16929740843707E+00 + 1.07010774015412E+00 6.86168091170223E-01 -4.73198043865320E-01 -1.33926504928179E+00 5.77896674265182E-16 + -3.05321367978475E-16 9.09094761993913E-02 7.07099627707447E-16 +* ORBITAL 1 13 + 1.35314119817790E+00 2.91206612512817E+00 -1.76065675368141E+00 8.38777242483194E-02 2.20592719086708E+00 + 3.18904019198759E+00 -3.06404872062764E-01 -2.57026246639817E+00 -2.02547800063683E+00 8.06852227796990E-17 + 2.14371577784135E-17 1.55723333508294E+00 4.26476986600395E-16 +* ORBITAL 2 1 + 8.46806330395995E-01 -3.06967858327435E-02 -2.95698383384996E-03 -6.83204963868469E-02 -8.92115331671980E-04 + 1.29368724323129E-02 3.59177945780643E-16 +* ORBITAL 2 2 + -8.22381791449519E-02 7.45629759898986E-01 2.87517115974600E-01 1.17408735255913E-01 4.10470787036254E-02 + 1.11615341747306E-02 -3.68589900055513E-16 +* ORBITAL 2 3 + 4.40326001635554E-01 -9.84035360146387E-02 -1.28516084342043E-01 8.78811964228391E-01 4.74587145310604E-01 + 5.73114372628535E-02 4.26345753792184E-16 +* ORBITAL 2 4 + -5.13756426175021E-02 -3.33363372135513E-01 8.40782955901566E-01 -2.29775264160445E-01 1.22158796027571E-01 + 2.66415914356745E-01 -1.43401078311437E-14 +* ORBITAL 2 5 + -3.28271713263048E-16 -5.63835621973801E-15 1.38614105016004E-14 -3.58079388227453E-15 2.19359765245958E-15 + 1.56427353561208E-15 8.97187110277603E-01 +* ORBITAL 2 6 + -1.51690952443282E-01 3.05767339646148E-01 -2.83128768057245E-01 -2.55117984303499E-01 5.87952024103255E-01 + 4.67600127554264E-01 1.61467220591238E-15 +* ORBITAL 2 7 + -5.55032110570081E-01 1.13392533130126E-01 1.49882819959549E-01 1.78515273268941E-03 -9.12025262738008E-01 + 1.10640139247261E+00 1.43895324359052E-15 +* ORBITAL 3 1 + 8.46806330395994E-01 -3.06967858327358E-02 -2.95698383385343E-03 -6.83204963868465E-02 -8.92115331671100E-04 + -2.07777135366449E-16 1.29368724323146E-02 +* ORBITAL 3 2 + -8.22381791449569E-02 7.45629759898985E-01 2.87517115974602E-01 1.17408735255913E-01 4.10470787036251E-02 + 3.17508540084796E-16 1.11615341747294E-02 +* ORBITAL 3 3 + 4.40326001635553E-01 -9.84035360146363E-02 -1.28516084342046E-01 8.78811964228390E-01 4.74587145310605E-01 + -7.13481710068366E-16 5.73114372628560E-02 +* ORBITAL 3 4 + -5.13756426175005E-02 -3.33363372135509E-01 8.40782955901561E-01 -2.29775264160449E-01 1.22158796027582E-01 + -8.48263482246985E-14 2.66415914356757E-01 +* ORBITAL 3 5 + -5.71555295405878E-15 -3.05527371111588E-14 7.84863729020011E-14 -2.20451146122624E-14 1.25814828576024E-14 + 8.97187110277603E-01 2.89315843132780E-14 +* ORBITAL 3 6 + -1.51690952443289E-01 3.05767339646156E-01 -2.83128768057259E-01 -2.55117984303497E-01 5.87952024103249E-01 + -3.50779678218078E-15 4.67600127554263E-01 +* ORBITAL 3 7 + -5.55032110570083E-01 1.13392533130126E-01 1.49882819959549E-01 1.78515273268995E-03 -9.12025262738010E-01 + -1.64385939319676E-15 1.10640139247261E+00 +* ORBITAL 4 1 + 7.10104423487938E-01 4.06011259982026E-01 -2.93757175810058E-03 +* ORBITAL 4 2 + 2.38335562748856E-02 3.50224309523771E-01 8.29543868862431E-01 +* ORBITAL 4 3 + 6.10039108098149E-01 -7.23183252307475E-01 3.56890119578755E-01 +* ORBITAL 5 1 + 1.00114898597215E+00 3.08527055440953E-04 1.16470556275943E-03 1.19398644458611E-03 -3.04244808588330E-03 + -7.96176943468572E-04 -1.33989264376709E-03 8.87575809845006E-04 -1.80618950126984E-05 6.06816376065097E-16 + 5.03684703436480E-16 -3.79953483653031E-04 -6.99992348208067E-16 +* ORBITAL 5 2 + 3.21148416801901E-02 1.04854425929948E+00 6.30551692164973E-02 4.07516710223630E-03 3.71054695000242E-01 + -2.02595010388808E-02 3.72143382179808E-03 -2.28892350400967E-02 -1.58531301562109E-03 -1.85897763239631E-15 + -9.64726404699757E-16 1.65011212983700E-03 -1.90768949029156E-16 +* ORBITAL 5 3 + -8.89670675773324E-02 -1.46037903254172E-01 -7.67107863608393E-01 -2.00965580291779E-02 -7.55687929232257E-01 + 6.67720789510346E-01 -6.12143514301923E-02 -1.43086956013481E-01 -9.66260999085740E-02 5.53564066554858E-14 + 2.99374619274635E-14 5.74698282757078E-02 7.82302541157237E-15 +* ORBITAL 5 4 + 5.02487214080608E-01 3.01616086858579E+00 1.17216396762114E+00 7.08241300744368E-02 -1.10184456698923E+00 + -1.65124303401597E+00 -3.49349211159826E-01 3.99667158994826E-02 6.49955133793786E-02 -8.65537328791078E-15 + -4.60120705537663E-15 5.45363875597644E-02 -5.18418032208189E-16 +* ORBITAL 5 5 + 3.83137632455884E+00 2.13201687012455E+01 1.15958804181190E+01 1.56173037061395E+00 -9.29120575440789E+00 + -6.75602068854797E+00 9.65193145925824E-02 1.33154425283301E+00 5.07593532336823E-01 -6.93477695995806E-14 + -3.68828233418004E-14 -1.83243072514489E-01 -3.59491333691370E-15 +* ORBITAL 5 6 + 3.19155444178308E-13 1.75088870009780E-12 9.63069053478080E-13 1.25755093459955E-13 -7.19728300904935E-13 + -5.78074361283529E-13 -2.05414015066987E-16 1.43800442110305E-13 5.49217940382117E-14 1.20022722335424E+00 + 6.66929009827392E-01 -1.54098799501458E-14 3.29644398088253E-02 +* ORBITAL 5 7 + 4.68748241756404E+00 2.55052406912410E+01 1.28744330365505E+01 1.41676833667615E+00 -1.11264615993268E+01 + -7.47967138148420E+00 -2.77517581715949E-01 2.93118071046975E+00 1.37604216690777E+00 -2.22715366965123E-14 + -6.49804815354791E-15 8.40469888945032E-02 -3.78043997709939E-16 +* ORBITAL 5 8 + 5.73659485793476E+00 3.11152696474545E+01 1.50898011467054E+01 2.64136071289562E+00 -1.39500827340774E+01 + -9.39069012596879E+00 8.60849651923379E-01 3.45868533935340E+00 1.37648972259001E+00 -7.27374397400089E-15 + 1.36738222543553E-14 6.25181556767997E-02 -1.53220251119499E-15 +* ORBITAL 5 9 + -7.39008685922172E-14 -4.29403624071314E-13 -2.45301897951615E-13 -5.50325548328285E-14 1.74672307849577E-13 + 1.39624687086790E-13 8.85041771940102E-15 -3.87715478652987E-14 -4.08186872704536E-15 -4.68148297651523E-01 + 9.27049562464192E-01 -1.07592149713582E-14 2.80498781432828E-01 +* ORBITAL 5 10 + -4.12574312511115E-01 -1.55036715497133E+00 -5.20729470488856E-01 -8.09533286577930E-01 4.40402662055927E-01 + 1.37053486859738E-01 5.37922674343104E-01 -6.86424896998561E-01 1.12472325307013E-01 -4.96423449866148E-15 + -1.06801719203541E-14 1.18770553762241E+00 1.94596604414065E-14 +* ORBITAL 5 11 + -6.06687566208158E-14 -3.18333603345166E-13 -1.34582137899036E-13 -1.38998078814761E-15 1.55625870224124E-13 + 8.99521518789668E-14 -1.96078069483938E-14 -3.14167334990748E-14 -3.20465560071004E-14 -1.05771425298554E+00 + -8.29513461840557E-01 -2.32257479397856E-15 1.63682236670324E+00 +* ORBITAL 5 12 + 6.30853546529876E+00 3.30717601995245E+01 1.54081520285162E+01 1.91566590548963E+00 -1.47216673881598E+01 + -9.70579154917706E+00 7.39806843015696E-01 3.36808988102585E+00 2.75337131246481E+00 -7.58363920776150E-16 + -2.11587954458926E-14 -8.15008587853706E-01 1.48012461286480E-14 +* ORBITAL 5 13 + 1.20984651877783E+01 5.89632109504005E+01 1.98520685056538E+01 -7.56034154585737E-01 -3.18622232808586E+01 + -1.43380252600695E+01 5.21824997372755E+00 1.06421829992372E+01 3.15939132811601E+00 4.04375446525020E-15 + -1.25492886736720E-14 -2.51730964200624E+00 -5.47492541024368E-16 +* ORBITAL 6 1 + 1.30716939273019E+00 1.74774038330101E-01 4.25035523108059E-03 -1.55043374411958E-02 -1.31665251176332E-02 + -6.34980556101839E-03 7.92484082897622E-16 +* ORBITAL 6 2 + 1.28836360340490E+00 2.08467082775298E+00 3.91403839076440E-01 -4.55754828979798E-01 -2.35276130981244E-01 + 1.18666987161209E-01 5.84473704624152E-17 +* ORBITAL 6 3 + -3.38548042636054E+00 -2.34590858123735E+00 -1.06076189286886E-01 2.68434969009561E+00 1.35312273879049E+00 + -4.75235369226692E-02 -5.09909586799240E-15 +* ORBITAL 6 4 + 5.58327434530008E-01 1.99928214236182E-01 9.56926191404566E-01 -2.35991957828394E-01 -3.55587678922962E-02 + 4.92852090009937E-01 9.29428097945332E-16 +* ORBITAL 6 5 + 2.48002326482520E-14 1.35737471571214E-14 -7.03022925258866E-15 -1.41774089031643E-14 -1.03333206080222E-14 + 1.12406269103198E-14 1.14883451588855E+00 +* ORBITAL 6 6 + -3.06180736984048E+00 -2.27358376639575E+00 3.77893663271568E-02 1.31331604811790E+00 2.00364259080163E+00 + -4.26298097065591E-01 4.40907228766383E-15 +* ORBITAL 6 7 + -7.53971651294126E+00 -3.96203230305693E+00 1.46329114479240E+00 5.44753447687526E+00 2.20101272638529E+00 + -2.58796310449121E+00 4.15554334078374E-15 +* ORBITAL 7 1 + 1.30716939273020E+00 1.74774038330121E-01 4.25035523107889E-03 -1.55043374412039E-02 -1.31665251176384E-02 + -6.61707815581064E-16 -6.34980556101433E-03 +* ORBITAL 7 2 + 1.28836360340528E+00 2.08467082775322E+00 3.91403839076419E-01 -4.55754828980076E-01 -2.35276130981387E-01 + 2.57034830568560E-16 1.18666987161284E-01 +* ORBITAL 7 3 + -3.38548042636066E+00 -2.34590858123735E+00 -1.06076189286839E-01 2.68434969009570E+00 1.35312273879055E+00 + 4.19022162313596E-15 -4.75235369227179E-02 +* ORBITAL 7 4 + 5.58327434530114E-01 1.99928214236224E-01 9.56926191404542E-01 -2.35991957828469E-01 -3.55587678923295E-02 + -2.57573309559302E-15 4.92852090009973E-01 +* ORBITAL 7 5 + -3.50717896318606E-14 -1.98920607437435E-14 9.72752741888854E-15 2.17909159170342E-14 1.37112994576499E-14 + 1.14883451588855E+00 -1.33140657864078E-14 +* ORBITAL 7 6 + -3.06180736984080E+00 -2.27358376639588E+00 3.77893663272510E-02 1.31331604811813E+00 2.00364259080171E+00 + -4.44677961151512E-15 -4.26298097065732E-01 +* ORBITAL 7 7 + -7.53971651294078E+00 -3.96203230305658E+00 1.46329114479241E+00 5.44753447687499E+00 2.20101272638507E+00 + -5.72061384610014E-15 -2.58796310449113E+00 +* ORBITAL 8 1 + 1.20022722335424E+00 6.66929009827390E-01 3.29644398088299E-02 +* ORBITAL 8 2 + -4.68148297651525E-01 9.27049562464191E-01 2.80498781432830E-01 +* ORBITAL 8 3 + -1.05771425298554E+00 -8.29513461840560E-01 1.63682236670324E+00 +#OCC +* OCCUPATION NUMBERS + 2.00000000000000E+00 2.00000000000000E+00 1.98571317977315E+00 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 1.47259785714434E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 + 1.47259785714430E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 2.00000000000000E+00 2.00000000000000E+00 1.42627590693787E-02 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 5.27414173434395E-01 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 + 5.27414173434428E-01 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 +#OCHR +* OCCUPATION NUMBERS (HUMAN-READABLE) + 2.0000 2.0000 1.9857 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 + 0.0000 0.0000 0.0000 + 1.4726 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 + 1.4726 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 + 0.0000 0.0000 0.0000 + 2.0000 2.0000 0.0143 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 + 0.0000 0.0000 0.0000 + 0.5274 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 + 0.5274 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 + 0.0000 0.0000 0.0000 +#ONE +* ONE ELECTRON ENERGIES + -1.5645E+01 -9.7398E-01 0.0000E+00 3.9628E-01 5.4850E-01 7.9854E-01 1.9647E+00 2.4109E+00 2.7604E+00 2.8961E+00 + 3.7173E+00 4.5624E+00 7.3040E+00 + 0.0000E+00 4.5538E-01 1.1609E+00 2.6845E+00 2.6926E+00 3.2013E+00 5.0054E+00 + 0.0000E+00 4.5538E-01 1.1609E+00 2.6845E+00 2.6926E+00 3.2013E+00 5.0054E+00 + 7.9854E-01 2.8961E+00 3.7173E+00 + -1.5642E+01 -7.6669E-01 0.0000E+00 4.7016E-01 1.0909E+00 1.2937E+00 2.3347E+00 3.3194E+00 4.1344E+00 4.6576E+00 + 5.0591E+00 5.6999E+00 1.5957E+01 + 0.0000E+00 7.2794E-01 1.9855E+00 3.2235E+00 3.5828E+00 5.1716E+00 7.1119E+00 + 0.0000E+00 7.2794E-01 1.9855E+00 3.2235E+00 3.5828E+00 5.1716E+00 7.1119E+00 + 1.2937E+00 4.1344E+00 5.0591E+00 +#INDEX +* 1234567890 +0 ii2sssssss +1 sss +* 1234567890 +0 2ssssss +* 1234567890 +0 2ssssss +* 1234567890 +0 sss +* 1234567890 +0 ii2sssssss +1 sss +* 1234567890 +0 2ssssss +* 1234567890 +0 2ssssss +* 1234567890 +0 sss +> EOF +>>FILE checkfile +* This file is autogenerated: +* Molcas version 22.02-309-gadd84f809 +* Linux pcal029 5.3.18-150300.59.63-default #1 SMP Tue Apr 5 12:47:31 UTC 2022 (d77db66) x86_64 x86_64 x86_64 GNU/Linux +* Thu May 19 18:09:56 2022 +* +#>> 1 +#> POTNUC="23.734788628707"/12 +#>> 2 +#> SEWARD_MLTPL1X="0.000003540755"/5 +#> SEWARD_KINETIC="112142.572500000082"/5 +#> SEWARD_ATTRACT="-3057.662782819980"/5 +#> POTNUC="23.734788628707"/12 +#> SEWARD_MLTPL1X="0.085606635114"/5 +#> SEWARD_KINETIC="22.193500357187"/5 +#> SEWARD_ATTRACT="-50.041915025817"/5 +#>> 3 +#> RASSCF_ITER="4"/8 +#> E_RASSCF[0]="-109.169703549262"/4 +#> E_RASSCF[1]="-108.503689654435"/4 +#> MLTPL__0="-0.000000000000"/2 +#> MLTPL__1[0]="0.0"/2 +#> MLTPL__1[1]="0.0"/2 +#> MLTPL__1[2]="0.0"/2 +#> MLTPL__2[0]="0.598146935916"/2 +#> MLTPL__2[1]="0.0"/2 +#> MLTPL__2[2]="0.0"/2 +#> MLTPL__2[3]="0.598146935916"/2 +#> MLTPL__2[4]="0.0"/2 +#> MLTPL__2[5]="-1.196293871833"/2 +#> MLTPL__0="-0.000000000000"/2 +#> MLTPL__1[0]="0.0"/2 +#> MLTPL__1[1]="0.0"/2 +#> MLTPL__1[2]="0.0"/2 +#> MLTPL__2[0]="1.485467957458"/2 +#> MLTPL__2[1]="0.0"/2 +#> MLTPL__2[2]="0.0"/2 +#> MLTPL__2[3]="1.485467957458"/2 +#> MLTPL__2[4]="0.0"/2 +#> MLTPL__2[5]="-2.970935914916"/2 +>>EOF diff -Nru openmolcas-22.02/test/additional/499.input openmolcas-22.10/test/additional/499.input --- openmolcas-22.02/test/additional/499.input 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/test/additional/499.input 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,383 @@ +* Molecule: C2H4 +* Basis: 3-21G +* Symmetry: C1 +* Features tested: CMS-PDFT calculation +* Responsible person: Jie J. Bao, 2022 +* Comments: +*------------------------------------------------------------------------------- +&Gateway +Coord +6 +Angstrom +C1 0.18344552 -0.17697119 -0.08665052 +C2 -0.16779249 0.16191153 1.59114306 +H3 -0.76232123 -0.46508408 -0.84058274 +H4 -0.06644826 0.27494564 2.69211027 +H5 0.61879625 -0.55724852 -1.01795687 +H6 0.02357942 0.92675911 -0.11348889 +Group=NoSym +Basis=3-21G + +&Seward + +>> COPY InitOrb INPORB +&RASSCF +LumOrb +SPIN=1 +NACTEL=2 0 0 +INACTIVE=7 +RAS2=3 +CIROOT=3 3 1 + +>> COPY $Project.RasOrb INPORB +&RASSCF +LumOrb +CION +SPIN=1 +NACTEL=2 0 0 +INACTIVE=7 +RAS2=3 +CIROOT=3 3 1 +CMSI +CMSO=Newton +CMTH=1.0d-10 + +&MCPDFT +KSDFT=T:PBE +MSPD + +>>FILE InitOrb +#INPORB 2.2 +#INFO +* testorb + 0 1 0 + 26 + 26 +*BC:HOST ln0004 PID 918402 DATE Mon Jun 27 22:40:31 2022 +#EXTRAS +* ACTIVE TWO-EL ENERGY + 0.530132183057E+00 +#ORB +* ORBITAL 1 1 + -9.87126026943562E-01 -9.72075049866775E-02 6.35479871858936E-02 1.83033187843950E-03 -8.07614373186085E-03 + -1.05731445611312E-03 7.99579904144378E-03 3.86069064371815E-04 6.65000454823599E-04 -1.48865327914063E-02 + -8.39906746992234E-04 -6.95478801261704E-03 -3.23963133897773E-04 -1.85237559172107E-04 -4.37230937154620E-04 + 3.50121349553365E-03 2.87471550465002E-04 1.06329923205393E-02 -1.28919516449651E-03 -1.03490992408392E-02 + -8.50849378090814E-04 -4.12099840491429E-03 1.23589068279158E-03 -7.30497179213571E-03 -6.27286408802508E-04 + -1.52681844410447E-02 +* ORBITAL 1 2 + -1.52762748925690E-02 -1.62901163186768E-03 4.66820265938858E-03 -1.10719337138983E-04 -1.17784603593030E-03 + 2.84616453013593E-04 -1.36756258083154E-04 -3.32550333349307E-04 1.06382789237242E-02 9.86511199684027E-01 + 9.04425471015759E-02 -4.26453402134316E-02 7.86588801875344E-04 -2.76372974375992E-03 -1.92623182243331E-04 + 1.18331708358119E-03 -4.07858518470308E-04 4.95630542208151E-03 1.69463082849681E-05 1.31960235782444E-03 + -3.06431390164583E-03 8.58890230092083E-03 1.12074815909024E-03 2.90892964365945E-03 -8.59462973349732E-04 + 5.06672776269360E-03 +* ORBITAL 1 3 + -1.90732973218495E-01 1.84582460882182E-01 5.58905009170846E-01 -1.91745167085108E-02 -3.79705420345715E-02 + 3.69242691061100E-02 4.47483542382566E-02 -4.25750607657109E-02 -4.55475547029857E-02 -8.45019517437558E-02 + 8.89240979050331E-02 2.08480478806206E-01 1.03388361352969E-02 1.16690401204741E-02 -6.25892976842985E-03 + 3.11878532547310E-03 -4.17833476539734E-02 -1.64266249439784E-02 1.00221744894426E-01 2.28135990851706E-02 + 4.06481004858676E-02 1.09962197618329E-02 1.28109681922177E-01 3.83683991309253E-02 1.26245545021237E-01 + 6.74641697798804E-03 +* ORBITAL 1 4 + 5.35939773219779E-02 -6.04238266609896E-02 -1.60769654292473E-01 -8.45540379306013E-03 -1.54098743936191E-02 + 2.52248583273220E-02 2.86203294571885E-02 1.36655320085424E-01 1.42968315982562E-01 -1.82391533016412E-01 + 2.01408197343098E-01 5.02879504255803E-01 1.26271931311211E-02 3.23943882983417E-03 1.52712755862470E-02 + 1.66825843166002E-02 1.06207723077419E-01 9.36305093832247E-02 -6.65113198936450E-02 -3.85080173723635E-02 + 2.03375855408931E-01 1.00637886626915E-01 -1.04865995963099E-01 -2.52777423816590E-02 -2.01417163956163E-02 + -7.36107433648041E-03 +* ORBITAL 1 5 + 1.30756447320504E-02 -6.59426274684952E-03 -4.34251700904879E-02 6.85818097501114E-02 5.56867645133597E-02 + -2.25542585102678E-01 -1.86099364965731E-01 -2.21961514339480E-01 -2.05826212694647E-01 -1.06474590943981E-02 + 1.32622705809296E-02 7.44584022771749E-02 -1.10505190348047E-02 -4.97182765388299E-03 1.59889743008154E-02 + 1.29750098533407E-02 2.30291936995677E-01 1.43061681996482E-01 6.99552417028515E-02 5.94716697589157E-02 + 1.51097605091065E-01 1.16446066498407E-01 1.83144156552025E-01 1.25531612027720E-01 -1.55489607321090E-01 + -1.19647649143619E-01 +* ORBITAL 1 6 + 1.95233148770661E-02 -1.57821921384506E-02 -5.61702935229805E-02 7.33527442306943E-02 6.35059261916598E-02 + 2.93454089333701E-01 2.65896904400832E-01 -1.66103334454020E-01 -1.77697412107716E-01 4.65114212133016E-02 + -3.73735835040828E-02 -1.94253217138365E-01 -2.40397384399208E-03 -6.47055673992860E-03 1.01696155657575E-01 + 9.26375032466106E-02 1.97867089318270E-01 1.92757618821882E-01 -6.03161744157472E-02 -1.03444546843743E-01 + 1.09055123063444E-01 1.00035404942776E-01 6.32475787709098E-03 -1.07439401491202E-02 2.09796919798080E-01 + 2.48914860129482E-01 +* ORBITAL 1 7 + -2.99184080815928E-02 4.08393223124914E-02 7.67865195884540E-02 3.56043963176003E-01 3.53663814244362E-01 + -2.78485357841225E-02 -3.13535042850245E-02 6.07924327000563E-02 6.20441945644127E-02 -1.27820731215246E-02 + 4.75314166765819E-03 7.19714028823092E-02 5.47613404845016E-02 4.59855326085849E-02 -1.67854966855351E-02 + -2.21179936844524E-02 -6.35177588570094E-02 -8.91305869262481E-02 -2.25042370439817E-01 -3.30949542979419E-01 + -3.99114161536898E-02 -2.94344468883452E-02 1.45076159802760E-01 2.01899950514122E-01 -1.69423063704593E-02 + -1.46174198427121E-02 +* ORBITAL 1 8 + -3.09203640414656E-02 2.25147646389326E-02 1.84288688855181E-01 -3.10905099857268E-02 -1.89624661379522E-02 + 4.66132556816024E-02 5.26480886924269E-02 6.04047299504227E-02 3.96317381527191E-02 5.71901139828199E-02 + -5.43932901086840E-02 -3.10080674525286E-01 3.32836238771204E-01 4.09197150468796E-01 -3.10929425135736E-01 + -4.01466447705614E-01 1.42766995905177E-01 1.49908627340895E-01 2.84770978870676E-02 6.53930736377571E-02 + 7.88680759885396E-02 1.24140526874119E-01 -7.39649448857732E-02 -1.53864573283150E-01 4.00525583134655E-02 + 3.32563464715725E-02 +* ORBITAL 1 9 + 8.14953610770898E-03 -1.67840957489929E-03 -7.63167367915626E-02 -2.92776359469142E-02 -1.53061230655651E-02 + -6.75242378794811E-02 -8.34315246882557E-02 2.43425428337283E-02 2.57233042531649E-02 1.80813143832866E-04 + -4.23856209001989E-03 1.66626256239212E-02 3.47302194315590E-01 4.41169710912631E-01 3.59157758565634E-01 + 4.63386135659124E-01 -6.19594836014014E-02 -9.98800277452802E-02 6.38744633550236E-02 1.53538550553035E-01 + 6.54856385092041E-05 -3.35109834951707E-05 -1.02258775595685E-02 -2.47599231567287E-02 -5.03529448083580E-02 + -8.69064465647113E-02 +* ORBITAL 1 10 + -1.08333718533341E-01 2.33825130658467E-02 7.69998226112066E-01 4.22795194316360E-04 -1.01261878921241E-01 + -5.98834337036699E-02 3.18304212462395E-02 2.30192562551340E-01 7.77074024258376E-01 1.53839528589909E-01 + -2.06725050282226E-01 -1.07030602675338E+00 -2.70743734470295E-01 -1.44894769979612E-01 1.66916127481989E-01 + 2.02643467373715E-01 7.61058598185224E-02 3.07125190208884E-01 -1.99243720910573E-02 -2.80948283441559E-02 + 2.40085101585357E-01 4.65294740261400E-01 -5.33594491948363E-02 1.23249831741181E-01 -1.17927455350012E-02 + -1.41124505791947E-01 +* ORBITAL 1 11 + 9.75187480910247E-02 -3.35488617315810E-02 -1.22370906186689E+00 2.34270014366730E-01 7.41161509142427E-01 + 5.06760890960113E-02 1.08450194102327E-01 1.48385738592213E-01 7.59892395697013E-01 9.67423960549683E-03 + -1.33021829810166E-02 -1.42039046087751E-01 -5.80589474447617E-02 -1.85166971460874E-01 -2.19711033502044E-02 + -4.68939137626290E-02 -2.30080232779124E-04 1.36426590814231E-01 8.36147829231368E-02 1.50459249545298E+00 + -1.96732878860877E-02 -3.04790552619429E-02 -7.27843916354494E-02 3.66004495170644E-01 -1.60578478918985E-02 + 4.15599866346358E-01 +* ORBITAL 1 12 + 8.80714615615070E-02 -2.02492758639432E-02 -1.19196987611591E+00 -1.70369238735501E-01 -5.30649125714797E-01 + 6.61375244953731E-02 2.53564556202827E-01 1.18213361841554E-01 5.56709394488207E-01 3.73911542349982E-02 + 4.03932175639376E-03 -7.13891517643985E-01 4.70431782657881E-02 6.62620415698775E-02 -5.55731883962542E-02 + -1.12461593611001E-01 -1.87011467945305E-01 -4.88686055644454E-01 -6.47010692082204E-02 -2.11414360922445E-01 + 1.98976144540269E-02 9.52731408589295E-01 8.49139763289071E-02 1.65379101462929E+00 1.57579973457632E-02 + 7.31865878862203E-02 +* ORBITAL 1 13 + 5.84676052837990E-02 -9.85526030978027E-03 -9.07059795027556E-01 -5.75877129597963E-02 -7.76154710708648E-02 + -2.49940119891182E-01 -1.12625604312740E+00 1.34297886722636E-02 5.44689575508692E-02 1.13711997836427E-02 + -3.64047285945922E-02 1.24163087417851E-01 2.10962723258590E-02 5.65179451584271E-02 -1.03759592821883E-02 + -6.80798358489548E-03 9.67016861708793E-02 2.56503936530565E-01 -6.41131757576363E-02 -2.83652541906800E-01 + -1.07364057202034E-02 -3.35209145534392E-01 -1.99015482180885E-02 3.07465922058389E-02 1.02642921920438E-01 + 1.83003992896747E+00 +* ORBITAL 1 14 + -3.67913945554307E-02 -6.89504390633986E-03 3.53383304836580E-01 -1.40399883757238E-01 -6.02566001933429E-01 + 1.02920646281450E-01 5.69369784197200E-01 1.73688504147456E-01 1.36556806578697E+00 -8.11081125495608E-03 + 4.33166942116687E-02 2.27958294760164E-01 1.27268011977876E-02 -3.18938956939795E-02 4.72421436112915E-02 + 2.61999384323628E-01 3.03613722583270E-01 1.69327114976951E+00 -8.36276128251306E-03 -1.43033255132744E-01 + 1.02900426169696E-01 -1.86651038745336E+00 -5.65419100554750E-02 1.48571237959036E+00 4.15333689843454E-02 + -4.38269177300593E-01 +* ORBITAL 1 15 + -4.75535343015317E-03 1.11899164552342E-01 -1.09635179943201E-01 5.67446245573264E-01 -5.13595879427851E-01 + 1.40565757345364E-01 -1.70819140436181E-01 2.99127569134019E-02 1.51294900710302E-01 1.89050772219831E-02 + 2.48440752347863E-02 -2.11777971381155E-01 6.48886490180446E-01 -5.33777810620361E-01 -4.96224035587115E-02 + 1.17400814574776E-01 1.49137093321546E-01 -2.15472675287574E-01 -4.21442873619566E-01 3.54547952679846E-01 + 1.84971935442071E-01 5.16794907907294E-02 3.61992218025111E-01 -2.20892297368693E-01 1.91318662642796E-01 + -1.58913361055773E-01 +* ORBITAL 1 16 + 3.40877795338032E-02 -7.64900411332271E-02 -2.11463228360806E-01 -5.94272147146448E-02 1.39211172498155E-01 + 8.17026630107207E-01 -1.14277218441508E+00 -4.04008383668867E-01 2.06620658798422E-01 -8.60360353660410E-03 + -1.09869503820382E-01 1.39521047926020E-01 -1.45479273651464E-01 1.51911548019547E-01 1.60256547910214E-01 + 1.83901814035218E-02 -2.81505037535606E-02 -6.23146634043586E-02 -9.37858775529434E-02 1.26884016163980E-01 + -2.51488026870811E-01 2.16361336873382E-01 -1.21347957473040E-01 -4.10259853607424E-02 4.61057066978753E-01 + 8.19553327853379E-02 +* ORBITAL 1 17 + 1.74378751559861E-03 5.76558295182258E-02 2.78426711753133E-02 7.64090236604607E-03 -3.50751774020088E-02 + 8.80413698721589E-02 -2.04041408103992E-01 -6.50856248167132E-02 2.52438902480737E-01 2.02138012071096E-03 + 6.66418282748272E-03 -8.27295056041661E-02 -1.58511144242454E-01 1.27647694185590E-01 -1.03017828450308E+00 + 1.06545042752899E+00 1.15699608835602E-01 -7.26004636719203E-02 1.14268170916618E-01 -1.66464738957060E-02 + -1.34202685745040E-02 1.87322179795049E-02 7.79240203962712E-02 3.83671489346509E-02 1.17893479055035E-01 + -2.08795800150792E-01 +* ORBITAL 1 18 + -2.56867025385665E-02 -8.87292401252675E-02 4.11146300459514E-01 -4.58644967460460E-01 6.20145597178676E-01 + -1.65314449721880E-02 1.10701309103599E-01 -2.11649428544129E-01 6.17863320743070E-01 2.32407030085734E-02 + -9.48854234971734E-02 -2.31009267060825E-01 7.72524600679833E-01 -9.60941720369700E-01 -1.23714277272666E-01 + 2.13396955238495E-01 -1.48437463467246E-01 6.06451315737144E-01 2.09729993850922E-01 1.86678845569254E-03 + -2.81850223240367E-01 5.27595087307855E-02 -3.56779049323792E-01 3.34016975481681E-01 -1.32542501202556E-01 + 6.74893563680431E-02 +* ORBITAL 1 19 + -2.04537377872581E-02 2.08412822859548E-01 -1.68266092312053E-01 -1.15561466855769E-01 1.35605295118090E-01 + -9.46109782619471E-02 9.56809079217689E-02 3.83534282031281E-01 -5.80035933402259E-01 -1.24602543225655E-02 + -3.73381053999263E-01 4.79445985419621E-01 -4.14869237698079E-02 1.03135731459995E-01 3.42157328893633E-02 + -3.13700793701515E-02 4.36234179018795E-01 -3.34195380888464E-01 -3.26953069299574E-01 3.43010677604905E-01 + -1.04791062608286E+00 8.52964307659008E-01 2.31041847952002E-01 -4.66888931038056E-01 6.06738283843996E-02 + -2.33861060421085E-01 +* ORBITAL 1 20 + -5.74301203433221E-03 -7.36437297148243E-02 4.02332351077807E-01 6.06679944225137E-01 -7.11742873683417E-01 + 2.30511709687630E-01 -4.94122110546796E-01 5.24686145086153E-01 -8.97496521361790E-01 -1.67099073057479E-02 + 4.13126639191060E-02 2.25644179268330E-01 8.09754243225037E-02 6.27200757953108E-02 1.20169691929750E-02 + 4.21025128977379E-04 -8.21493544830835E-02 4.23647784420949E-02 7.50058673506167E-01 -1.40608596609734E+00 + -2.67701498097784E-01 1.55618815855876E-01 -4.21355955648841E-01 2.57473279587716E-01 1.92138383966436E-02 + 2.13824830308191E-01 +* ORBITAL 1 21 + -2.32500561384575E-02 1.21425915633909E-01 3.27011949553516E-01 4.00039617696288E-01 -8.96044765340249E-01 + -5.83816017328340E-01 1.03543112343755E+00 -4.86054176886892E-01 1.83335405549877E+00 6.84430951843723E-03 + -1.14515225152745E-01 -2.22141829860122E-01 -1.02188706218739E-01 8.52243164568378E-02 -2.83429143261170E-02 + 2.35758189619645E-01 -5.48931134127341E-01 2.06463773749479E+00 -6.88724681023467E-02 1.39682424536835E-01 + -3.37417390543239E-01 -8.83181782127557E-01 -2.19236490450324E-01 1.44005278134850E+00 4.98306665464547E-01 + -7.34011164037387E-01 +* ORBITAL 1 22 + -7.81578282429795E-02 2.66578820794957E-01 -3.86333241416157E-02 2.51848677826375E-01 -7.01153481199254E-01 + 3.52928579534135E-01 -5.97512284138821E-02 -1.90866322673943E-01 6.60758406605997E-01 3.01436413510379E-02 + -4.01516052788242E-01 3.48895964276921E-01 -1.04521722959933E-01 1.91682139650883E-01 -9.62985691272659E-02 + 1.60917792886737E-01 -3.47205317594966E-01 1.39382703462687E+00 -3.35583112785166E-01 -5.79342757161389E-02 + -1.00044061007366E-01 -8.77618690297056E-01 -1.70101382025235E-01 5.66712321880603E-01 -1.03404220352249E+00 + 1.00728424260959E+00 +* ORBITAL 1 23 + -4.34203029149287E-02 1.28632517855735E-01 -5.61024911666922E-01 2.25366683636246E-01 -1.52861160621568E-01 + -1.74398299759769E-01 1.29250707109439E-01 -3.79185111635708E-01 -2.87980722019439E-01 -2.21894378526921E-02 + 4.15928834212611E-01 -7.61621752292436E-01 -4.63830983476326E-02 8.96732867250618E-02 3.49497069621865E-02 + -1.47250948115454E-01 7.23770019625440E-01 -1.73686914743008E+00 -2.44075966108423E-01 -6.66420368007234E-02 + -6.53800235622402E-02 1.27453691882893E+00 -9.00471666052306E-01 7.64408589898503E-01 -1.09026022674644E-01 + -2.44866172038471E-01 +* ORBITAL 1 24 + 4.76380264325376E-02 -6.32052927440502E-02 -4.79367992390691E-01 1.88165270727093E-01 -4.22393989726424E-01 + -9.33944932602125E-02 6.17311427798178E-01 -6.08869471502077E-01 1.66067800444811E+00 4.51708184633801E-02 + -5.02801048718705E-01 -2.38543736625967E-01 -3.72312800137847E-03 -8.27691141052857E-02 1.35974637630859E-01 + -1.31152248378628E-01 4.62788619143394E-01 8.28320642222252E-03 7.68467790925185E-01 -4.08558354201352E-01 + -1.09987019832718E-01 7.52044076774763E-02 5.10535887987352E-01 8.75550285271806E-01 -2.61126494680599E-01 + 1.18715864715409E-01 +* ORBITAL 1 25 + -2.29800803666328E-02 4.93003256761457E-01 -5.32111089423763E-01 -3.19133371230221E-02 -2.23919383482301E-01 + 1.17392425580685E-01 1.34868764151434E-01 -2.08523990163144E-01 1.95141737915246E+00 -2.27532702804326E-02 + 1.41801698307104E+00 -2.36900400076652E+00 -7.66559399547265E-04 -2.12260558635364E-01 6.14581270211244E-02 + 6.50607868861768E-02 -1.17244556820268E-01 1.20876230938928E+00 2.62803450060666E-01 2.32240293863129E-01 + -3.95960608475124E-01 2.59836307765394E-01 5.15024769895322E-01 6.67068565209485E-01 -3.06995603538012E-01 + 8.64585882507126E-01 +* ORBITAL 1 26 + 2.68314200545035E-02 1.86322907687167E+00 -3.49835668329025E+00 -1.92030814789839E-01 8.35827205650567E-01 + 7.31657100537346E-02 -7.06994258792320E-01 6.40230587065184E-02 -7.47456960534130E-01 -1.60882290537478E-02 + -4.21452386379016E-01 1.13420500453407E+00 4.83548212576859E-02 5.99190486211934E-03 7.75243994402050E-02 + -3.32970091398686E-01 4.01271412109929E-02 -1.41621370886180E+00 2.98373427610127E-01 4.68368384476928E-01 + 3.13601643660357E-01 3.42266161365698E-01 -7.07928957615249E-02 4.74005138308896E-02 3.69783607428459E-01 + 6.38586617522489E-01 +#OCC +* OCCUPATION NUMBERS + 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 + 2.00000000000000E+00 2.00000000000000E+00 9.96834278614931E-01 9.94208773273331E-01 8.95694811173731E-03 + 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 +#OCHR +* OCCUPATION NUMBERS (HUMAN-READABLE) + 2.0000 2.0000 2.0000 2.0000 2.0000 2.0000 2.0000 0.9968 0.9942 0.0090 + 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 + 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 +#ONE +* ONE ELECTRON ENERGIES + 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 + 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 + 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 +#INDEX +* 1234567890 +0 iiiiiii222 +1 ssssssssss +2 ssssss +>>EOF +>>FILE checkfile +* This file is autogenerated: +* Molcas version 18.09-6934-ga780cd8 +* Linux ln0004 3.10.0-1160.66.1.el7.x86_64 #1 SMP Wed May 18 16:02:34 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Mon Jun 27 22:45:20 2022 +* +#>> 1 +#> POTNUC="28.659763687133"/12 +#>> 2 +#> POTNUC="28.659763687133"/12 +#> SEWARD_MLTPL1X="0.346661791590"/5 +#> SEWARD_KINETIC="16.578973779721"/5 +#> SEWARD_ATTRACT="-37.824814970634"/5 +#>> 3 +#> RASSCF_ITER="4"/8 +#> E_RASSCF[0]="-77.307184469824"/8 +#> E_RASSCF[1]="-77.298093701740"/8 +#> E_RASSCF[2]="-77.236152415045"/8 +#> MLTPL__0="-0.000000000000"/5 +#> MLTPL__1[0]="0.289957144256"/5 +#> MLTPL__1[1]="0.012256789451"/5 +#> MLTPL__1[2]="-0.076162690266"/5 +#> MLTPL__2[0]="-4.042491127665"/5 +#> MLTPL__2[1]="1.017452398359"/5 +#> MLTPL__2[2]="0.582501245782"/5 +#> MLTPL__2[3]="-0.982278773072"/5 +#> MLTPL__2[4]="0.885311330696"/5 +#> MLTPL__2[5]="5.024769900737"/5 +#> MLTPL__0="-0.000000000000"/5 +#> MLTPL__1[0]="0.122824005012"/5 +#> MLTPL__1[1]="0.038816960607"/5 +#> MLTPL__1[2]="-0.140965732889"/5 +#> MLTPL__2[0]="-3.233086790783"/5 +#> MLTPL__2[1]="-0.229935132507"/5 +#> MLTPL__2[2]="0.330881361526"/5 +#> MLTPL__2[3]="-1.747739238666"/5 +#> MLTPL__2[4]="1.214497623396"/5 +#> MLTPL__2[5]="4.980826029449"/5 +#> MLTPL__0="-0.000000000000"/5 +#> MLTPL__1[0]="-0.058903389168"/5 +#> MLTPL__1[1]="0.081051518996"/5 +#> MLTPL__1[2]="-0.201705567124"/5 +#> MLTPL__2[0]="-2.292329873103"/5 +#> MLTPL__2[1]="-1.405117246712"/5 +#> MLTPL__2[2]="0.072970415994"/5 +#> MLTPL__2[3]="-2.589070998802"/5 +#> MLTPL__2[4]="1.587123682189"/5 +#> MLTPL__2[5]="4.881400871906"/5 +#>> 4 +#> E_RASSCF[0]="-77.298737279564"/8 +#> E_RASSCF[1]="-77.261220307579"/8 +#> E_RASSCF[2]="-77.281472999463"/8 +#> MLTPL__0="-0.000000000000"/5 +#> MLTPL__1[0]="0.392170702573"/5 +#> MLTPL__1[1]="0.192346676618"/5 +#> MLTPL__1[2]="-0.063307484723"/5 +#> MLTPL__2[0]="-5.201227866084"/5 +#> MLTPL__2[1]="0.567081186322"/5 +#> MLTPL__2[2]="0.677060004713"/5 +#> MLTPL__2[3]="0.136030428029"/5 +#> MLTPL__2[4]="0.931907900175"/5 +#> MLTPL__2[5]="5.065197438055"/5 +#> MLTPL__0="-0.000000000000"/5 +#> MLTPL__1[0]="-0.037188550142"/5 +#> MLTPL__1[1]="0.219008779587"/5 +#> MLTPL__1[2]="-0.208603526866"/5 +#> MLTPL__2[0]="-2.843644641484"/5 +#> MLTPL__2[1]="-2.329171916474"/5 +#> MLTPL__2[2]="0.082819971259"/5 +#> MLTPL__2[3]="-2.050999079164"/5 +#> MLTPL__2[4]="1.730897805186"/5 +#> MLTPL__2[5]="4.894643720648"/5 +#> MLTPL__0="-0.000000000000"/5 +#> MLTPL__1[0]="-0.001104392330"/5 +#> MLTPL__1[1]="-0.279230187150"/5 +#> MLTPL__1[2]="-0.146922978690"/5 +#> MLTPL__2[0]="-1.523035283983"/5 +#> MLTPL__2[1]="1.144490749291"/5 +#> MLTPL__2[2]="0.226473047330"/5 +#> MLTPL__2[3]="-3.404120359405"/5 +#> MLTPL__2[4]="1.024126930920"/5 +#> MLTPL__2[5]="4.927155643389"/5 +#>> 5 +#> DENS_TT="16.000009761150"/6 +#> DENS_A1="8.000004880575"/6 +#> DENS_B1="8.000004880575"/6 +#> DENS_A2="8.359172860328"/6 +#> DENS_B2="7.640836900823"/6 +#> EXCH_F="1"/6 +#> CORR_F="1"/6 +#> EXCHA_A="-5.868949829328"/6 +#> EXCHA_B="-5.533335574699"/6 +#> CORR_E="-0.480243835822"/6 +#> CASDFTE="-77.728501139562"/8 +#> DENS_TT="15.999999769173"/6 +#> DENS_A1="7.999999884586"/6 +#> DENS_B1="7.999999884586"/6 +#> DENS_A2="8.338742468192"/6 +#> DENS_B2="7.661257300980"/6 +#> EXCH_F="1"/6 +#> CORR_F="1"/6 +#> EXCHA_A="-5.862047662906"/6 +#> EXCHA_B="-5.545507515872"/6 +#> CORR_E="-0.480557920522"/6 +#> CASDFTE="-77.694893754036"/8 +#> DENS_TT="16.000004924960"/6 +#> DENS_A1="8.000002462480"/6 +#> DENS_B1="8.000002462480"/6 +#> DENS_A2="8.355221237745"/6 +#> DENS_B2="7.644783687216"/6 +#> EXCH_F="1"/6 +#> CORR_F="1"/6 +#> EXCHA_A="-5.873904535234"/6 +#> EXCHA_B="-5.541254129521"/6 +#> CORR_E="-0.480668788081"/6 +#> CASDFTE="-77.712784180978"/8 +>>EOF diff -Nru openmolcas-22.02/test/additional/501.input openmolcas-22.10/test/additional/501.input --- openmolcas-22.02/test/additional/501.input 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/test/additional/501.input 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,373 @@ +* Molecule: C2H4 +* Basis: 3-21G +* Symmetry: C1 +* Features tested: hybrid MC-PDFT energy and gradient calculations +* Responsible person: Jie J. Bao, 2022 +* Comments: +*------------------------------------------------------------------------------- +&Gateway +Coord +6 +Angstrom +C1 0.18344552 -0.17697119 -0.08665052 +C2 -0.16779249 0.16191153 1.59114306 +H3 -0.76232123 -0.46508408 -0.84058274 +H4 -0.06644826 0.27494564 2.69211027 +H5 0.61879625 -0.55724852 -1.01795687 +H6 0.02357942 0.92675911 -0.11348889 +Group=NoSym +Basis=3-21G + +&Seward + +>> COPY InitOrb INPORB +&RASSCF +LumOrb +SPIN=1 +NACTEL=2 0 0 +INACTIVE=7 +RAS2=3 +CIROOT=3 3 1 +RLXR=2 + +&MCPDFT +KSDFT=T:PBE +LAMB=0.25 +GRAD + +&MCLR +THRE=1.0e-8 + +&ALASKA + +>>FILE InitOrb +#INPORB 2.2 +#INFO +* testorb + 0 1 0 + 26 + 26 +*BC:HOST ln0004 PID 918402 DATE Mon Jun 27 22:40:31 2022 +#EXTRAS +* ACTIVE TWO-EL ENERGY + 0.530132183057E+00 +#ORB +* ORBITAL 1 1 + -9.87126026943562E-01 -9.72075049866775E-02 6.35479871858936E-02 1.83033187843950E-03 -8.07614373186085E-03 + -1.05731445611312E-03 7.99579904144378E-03 3.86069064371815E-04 6.65000454823599E-04 -1.48865327914063E-02 + -8.39906746992234E-04 -6.95478801261704E-03 -3.23963133897773E-04 -1.85237559172107E-04 -4.37230937154620E-04 + 3.50121349553365E-03 2.87471550465002E-04 1.06329923205393E-02 -1.28919516449651E-03 -1.03490992408392E-02 + -8.50849378090814E-04 -4.12099840491429E-03 1.23589068279158E-03 -7.30497179213571E-03 -6.27286408802508E-04 + -1.52681844410447E-02 +* ORBITAL 1 2 + -1.52762748925690E-02 -1.62901163186768E-03 4.66820265938858E-03 -1.10719337138983E-04 -1.17784603593030E-03 + 2.84616453013593E-04 -1.36756258083154E-04 -3.32550333349307E-04 1.06382789237242E-02 9.86511199684027E-01 + 9.04425471015759E-02 -4.26453402134316E-02 7.86588801875344E-04 -2.76372974375992E-03 -1.92623182243331E-04 + 1.18331708358119E-03 -4.07858518470308E-04 4.95630542208151E-03 1.69463082849681E-05 1.31960235782444E-03 + -3.06431390164583E-03 8.58890230092083E-03 1.12074815909024E-03 2.90892964365945E-03 -8.59462973349732E-04 + 5.06672776269360E-03 +* ORBITAL 1 3 + -1.90732973218495E-01 1.84582460882182E-01 5.58905009170846E-01 -1.91745167085108E-02 -3.79705420345715E-02 + 3.69242691061100E-02 4.47483542382566E-02 -4.25750607657109E-02 -4.55475547029857E-02 -8.45019517437558E-02 + 8.89240979050331E-02 2.08480478806206E-01 1.03388361352969E-02 1.16690401204741E-02 -6.25892976842985E-03 + 3.11878532547310E-03 -4.17833476539734E-02 -1.64266249439784E-02 1.00221744894426E-01 2.28135990851706E-02 + 4.06481004858676E-02 1.09962197618329E-02 1.28109681922177E-01 3.83683991309253E-02 1.26245545021237E-01 + 6.74641697798804E-03 +* ORBITAL 1 4 + 5.35939773219779E-02 -6.04238266609896E-02 -1.60769654292473E-01 -8.45540379306013E-03 -1.54098743936191E-02 + 2.52248583273220E-02 2.86203294571885E-02 1.36655320085424E-01 1.42968315982562E-01 -1.82391533016412E-01 + 2.01408197343098E-01 5.02879504255803E-01 1.26271931311211E-02 3.23943882983417E-03 1.52712755862470E-02 + 1.66825843166002E-02 1.06207723077419E-01 9.36305093832247E-02 -6.65113198936450E-02 -3.85080173723635E-02 + 2.03375855408931E-01 1.00637886626915E-01 -1.04865995963099E-01 -2.52777423816590E-02 -2.01417163956163E-02 + -7.36107433648041E-03 +* ORBITAL 1 5 + 1.30756447320504E-02 -6.59426274684952E-03 -4.34251700904879E-02 6.85818097501114E-02 5.56867645133597E-02 + -2.25542585102678E-01 -1.86099364965731E-01 -2.21961514339480E-01 -2.05826212694647E-01 -1.06474590943981E-02 + 1.32622705809296E-02 7.44584022771749E-02 -1.10505190348047E-02 -4.97182765388299E-03 1.59889743008154E-02 + 1.29750098533407E-02 2.30291936995677E-01 1.43061681996482E-01 6.99552417028515E-02 5.94716697589157E-02 + 1.51097605091065E-01 1.16446066498407E-01 1.83144156552025E-01 1.25531612027720E-01 -1.55489607321090E-01 + -1.19647649143619E-01 +* ORBITAL 1 6 + 1.95233148770661E-02 -1.57821921384506E-02 -5.61702935229805E-02 7.33527442306943E-02 6.35059261916598E-02 + 2.93454089333701E-01 2.65896904400832E-01 -1.66103334454020E-01 -1.77697412107716E-01 4.65114212133016E-02 + -3.73735835040828E-02 -1.94253217138365E-01 -2.40397384399208E-03 -6.47055673992860E-03 1.01696155657575E-01 + 9.26375032466106E-02 1.97867089318270E-01 1.92757618821882E-01 -6.03161744157472E-02 -1.03444546843743E-01 + 1.09055123063444E-01 1.00035404942776E-01 6.32475787709098E-03 -1.07439401491202E-02 2.09796919798080E-01 + 2.48914860129482E-01 +* ORBITAL 1 7 + -2.99184080815928E-02 4.08393223124914E-02 7.67865195884540E-02 3.56043963176003E-01 3.53663814244362E-01 + -2.78485357841225E-02 -3.13535042850245E-02 6.07924327000563E-02 6.20441945644127E-02 -1.27820731215246E-02 + 4.75314166765819E-03 7.19714028823092E-02 5.47613404845016E-02 4.59855326085849E-02 -1.67854966855351E-02 + -2.21179936844524E-02 -6.35177588570094E-02 -8.91305869262481E-02 -2.25042370439817E-01 -3.30949542979419E-01 + -3.99114161536898E-02 -2.94344468883452E-02 1.45076159802760E-01 2.01899950514122E-01 -1.69423063704593E-02 + -1.46174198427121E-02 +* ORBITAL 1 8 + -3.09203640414656E-02 2.25147646389326E-02 1.84288688855181E-01 -3.10905099857268E-02 -1.89624661379522E-02 + 4.66132556816024E-02 5.26480886924269E-02 6.04047299504227E-02 3.96317381527191E-02 5.71901139828199E-02 + -5.43932901086840E-02 -3.10080674525286E-01 3.32836238771204E-01 4.09197150468796E-01 -3.10929425135736E-01 + -4.01466447705614E-01 1.42766995905177E-01 1.49908627340895E-01 2.84770978870676E-02 6.53930736377571E-02 + 7.88680759885396E-02 1.24140526874119E-01 -7.39649448857732E-02 -1.53864573283150E-01 4.00525583134655E-02 + 3.32563464715725E-02 +* ORBITAL 1 9 + 8.14953610770898E-03 -1.67840957489929E-03 -7.63167367915626E-02 -2.92776359469142E-02 -1.53061230655651E-02 + -6.75242378794811E-02 -8.34315246882557E-02 2.43425428337283E-02 2.57233042531649E-02 1.80813143832866E-04 + -4.23856209001989E-03 1.66626256239212E-02 3.47302194315590E-01 4.41169710912631E-01 3.59157758565634E-01 + 4.63386135659124E-01 -6.19594836014014E-02 -9.98800277452802E-02 6.38744633550236E-02 1.53538550553035E-01 + 6.54856385092041E-05 -3.35109834951707E-05 -1.02258775595685E-02 -2.47599231567287E-02 -5.03529448083580E-02 + -8.69064465647113E-02 +* ORBITAL 1 10 + -1.08333718533341E-01 2.33825130658467E-02 7.69998226112066E-01 4.22795194316360E-04 -1.01261878921241E-01 + -5.98834337036699E-02 3.18304212462395E-02 2.30192562551340E-01 7.77074024258376E-01 1.53839528589909E-01 + -2.06725050282226E-01 -1.07030602675338E+00 -2.70743734470295E-01 -1.44894769979612E-01 1.66916127481989E-01 + 2.02643467373715E-01 7.61058598185224E-02 3.07125190208884E-01 -1.99243720910573E-02 -2.80948283441559E-02 + 2.40085101585357E-01 4.65294740261400E-01 -5.33594491948363E-02 1.23249831741181E-01 -1.17927455350012E-02 + -1.41124505791947E-01 +* ORBITAL 1 11 + 9.75187480910247E-02 -3.35488617315810E-02 -1.22370906186689E+00 2.34270014366730E-01 7.41161509142427E-01 + 5.06760890960113E-02 1.08450194102327E-01 1.48385738592213E-01 7.59892395697013E-01 9.67423960549683E-03 + -1.33021829810166E-02 -1.42039046087751E-01 -5.80589474447617E-02 -1.85166971460874E-01 -2.19711033502044E-02 + -4.68939137626290E-02 -2.30080232779124E-04 1.36426590814231E-01 8.36147829231368E-02 1.50459249545298E+00 + -1.96732878860877E-02 -3.04790552619429E-02 -7.27843916354494E-02 3.66004495170644E-01 -1.60578478918985E-02 + 4.15599866346358E-01 +* ORBITAL 1 12 + 8.80714615615070E-02 -2.02492758639432E-02 -1.19196987611591E+00 -1.70369238735501E-01 -5.30649125714797E-01 + 6.61375244953731E-02 2.53564556202827E-01 1.18213361841554E-01 5.56709394488207E-01 3.73911542349982E-02 + 4.03932175639376E-03 -7.13891517643985E-01 4.70431782657881E-02 6.62620415698775E-02 -5.55731883962542E-02 + -1.12461593611001E-01 -1.87011467945305E-01 -4.88686055644454E-01 -6.47010692082204E-02 -2.11414360922445E-01 + 1.98976144540269E-02 9.52731408589295E-01 8.49139763289071E-02 1.65379101462929E+00 1.57579973457632E-02 + 7.31865878862203E-02 +* ORBITAL 1 13 + 5.84676052837990E-02 -9.85526030978027E-03 -9.07059795027556E-01 -5.75877129597963E-02 -7.76154710708648E-02 + -2.49940119891182E-01 -1.12625604312740E+00 1.34297886722636E-02 5.44689575508692E-02 1.13711997836427E-02 + -3.64047285945922E-02 1.24163087417851E-01 2.10962723258590E-02 5.65179451584271E-02 -1.03759592821883E-02 + -6.80798358489548E-03 9.67016861708793E-02 2.56503936530565E-01 -6.41131757576363E-02 -2.83652541906800E-01 + -1.07364057202034E-02 -3.35209145534392E-01 -1.99015482180885E-02 3.07465922058389E-02 1.02642921920438E-01 + 1.83003992896747E+00 +* ORBITAL 1 14 + -3.67913945554307E-02 -6.89504390633986E-03 3.53383304836580E-01 -1.40399883757238E-01 -6.02566001933429E-01 + 1.02920646281450E-01 5.69369784197200E-01 1.73688504147456E-01 1.36556806578697E+00 -8.11081125495608E-03 + 4.33166942116687E-02 2.27958294760164E-01 1.27268011977876E-02 -3.18938956939795E-02 4.72421436112915E-02 + 2.61999384323628E-01 3.03613722583270E-01 1.69327114976951E+00 -8.36276128251306E-03 -1.43033255132744E-01 + 1.02900426169696E-01 -1.86651038745336E+00 -5.65419100554750E-02 1.48571237959036E+00 4.15333689843454E-02 + -4.38269177300593E-01 +* ORBITAL 1 15 + -4.75535343015317E-03 1.11899164552342E-01 -1.09635179943201E-01 5.67446245573264E-01 -5.13595879427851E-01 + 1.40565757345364E-01 -1.70819140436181E-01 2.99127569134019E-02 1.51294900710302E-01 1.89050772219831E-02 + 2.48440752347863E-02 -2.11777971381155E-01 6.48886490180446E-01 -5.33777810620361E-01 -4.96224035587115E-02 + 1.17400814574776E-01 1.49137093321546E-01 -2.15472675287574E-01 -4.21442873619566E-01 3.54547952679846E-01 + 1.84971935442071E-01 5.16794907907294E-02 3.61992218025111E-01 -2.20892297368693E-01 1.91318662642796E-01 + -1.58913361055773E-01 +* ORBITAL 1 16 + 3.40877795338032E-02 -7.64900411332271E-02 -2.11463228360806E-01 -5.94272147146448E-02 1.39211172498155E-01 + 8.17026630107207E-01 -1.14277218441508E+00 -4.04008383668867E-01 2.06620658798422E-01 -8.60360353660410E-03 + -1.09869503820382E-01 1.39521047926020E-01 -1.45479273651464E-01 1.51911548019547E-01 1.60256547910214E-01 + 1.83901814035218E-02 -2.81505037535606E-02 -6.23146634043586E-02 -9.37858775529434E-02 1.26884016163980E-01 + -2.51488026870811E-01 2.16361336873382E-01 -1.21347957473040E-01 -4.10259853607424E-02 4.61057066978753E-01 + 8.19553327853379E-02 +* ORBITAL 1 17 + 1.74378751559861E-03 5.76558295182258E-02 2.78426711753133E-02 7.64090236604607E-03 -3.50751774020088E-02 + 8.80413698721589E-02 -2.04041408103992E-01 -6.50856248167132E-02 2.52438902480737E-01 2.02138012071096E-03 + 6.66418282748272E-03 -8.27295056041661E-02 -1.58511144242454E-01 1.27647694185590E-01 -1.03017828450308E+00 + 1.06545042752899E+00 1.15699608835602E-01 -7.26004636719203E-02 1.14268170916618E-01 -1.66464738957060E-02 + -1.34202685745040E-02 1.87322179795049E-02 7.79240203962712E-02 3.83671489346509E-02 1.17893479055035E-01 + -2.08795800150792E-01 +* ORBITAL 1 18 + -2.56867025385665E-02 -8.87292401252675E-02 4.11146300459514E-01 -4.58644967460460E-01 6.20145597178676E-01 + -1.65314449721880E-02 1.10701309103599E-01 -2.11649428544129E-01 6.17863320743070E-01 2.32407030085734E-02 + -9.48854234971734E-02 -2.31009267060825E-01 7.72524600679833E-01 -9.60941720369700E-01 -1.23714277272666E-01 + 2.13396955238495E-01 -1.48437463467246E-01 6.06451315737144E-01 2.09729993850922E-01 1.86678845569254E-03 + -2.81850223240367E-01 5.27595087307855E-02 -3.56779049323792E-01 3.34016975481681E-01 -1.32542501202556E-01 + 6.74893563680431E-02 +* ORBITAL 1 19 + -2.04537377872581E-02 2.08412822859548E-01 -1.68266092312053E-01 -1.15561466855769E-01 1.35605295118090E-01 + -9.46109782619471E-02 9.56809079217689E-02 3.83534282031281E-01 -5.80035933402259E-01 -1.24602543225655E-02 + -3.73381053999263E-01 4.79445985419621E-01 -4.14869237698079E-02 1.03135731459995E-01 3.42157328893633E-02 + -3.13700793701515E-02 4.36234179018795E-01 -3.34195380888464E-01 -3.26953069299574E-01 3.43010677604905E-01 + -1.04791062608286E+00 8.52964307659008E-01 2.31041847952002E-01 -4.66888931038056E-01 6.06738283843996E-02 + -2.33861060421085E-01 +* ORBITAL 1 20 + -5.74301203433221E-03 -7.36437297148243E-02 4.02332351077807E-01 6.06679944225137E-01 -7.11742873683417E-01 + 2.30511709687630E-01 -4.94122110546796E-01 5.24686145086153E-01 -8.97496521361790E-01 -1.67099073057479E-02 + 4.13126639191060E-02 2.25644179268330E-01 8.09754243225037E-02 6.27200757953108E-02 1.20169691929750E-02 + 4.21025128977379E-04 -8.21493544830835E-02 4.23647784420949E-02 7.50058673506167E-01 -1.40608596609734E+00 + -2.67701498097784E-01 1.55618815855876E-01 -4.21355955648841E-01 2.57473279587716E-01 1.92138383966436E-02 + 2.13824830308191E-01 +* ORBITAL 1 21 + -2.32500561384575E-02 1.21425915633909E-01 3.27011949553516E-01 4.00039617696288E-01 -8.96044765340249E-01 + -5.83816017328340E-01 1.03543112343755E+00 -4.86054176886892E-01 1.83335405549877E+00 6.84430951843723E-03 + -1.14515225152745E-01 -2.22141829860122E-01 -1.02188706218739E-01 8.52243164568378E-02 -2.83429143261170E-02 + 2.35758189619645E-01 -5.48931134127341E-01 2.06463773749479E+00 -6.88724681023467E-02 1.39682424536835E-01 + -3.37417390543239E-01 -8.83181782127557E-01 -2.19236490450324E-01 1.44005278134850E+00 4.98306665464547E-01 + -7.34011164037387E-01 +* ORBITAL 1 22 + -7.81578282429795E-02 2.66578820794957E-01 -3.86333241416157E-02 2.51848677826375E-01 -7.01153481199254E-01 + 3.52928579534135E-01 -5.97512284138821E-02 -1.90866322673943E-01 6.60758406605997E-01 3.01436413510379E-02 + -4.01516052788242E-01 3.48895964276921E-01 -1.04521722959933E-01 1.91682139650883E-01 -9.62985691272659E-02 + 1.60917792886737E-01 -3.47205317594966E-01 1.39382703462687E+00 -3.35583112785166E-01 -5.79342757161389E-02 + -1.00044061007366E-01 -8.77618690297056E-01 -1.70101382025235E-01 5.66712321880603E-01 -1.03404220352249E+00 + 1.00728424260959E+00 +* ORBITAL 1 23 + -4.34203029149287E-02 1.28632517855735E-01 -5.61024911666922E-01 2.25366683636246E-01 -1.52861160621568E-01 + -1.74398299759769E-01 1.29250707109439E-01 -3.79185111635708E-01 -2.87980722019439E-01 -2.21894378526921E-02 + 4.15928834212611E-01 -7.61621752292436E-01 -4.63830983476326E-02 8.96732867250618E-02 3.49497069621865E-02 + -1.47250948115454E-01 7.23770019625440E-01 -1.73686914743008E+00 -2.44075966108423E-01 -6.66420368007234E-02 + -6.53800235622402E-02 1.27453691882893E+00 -9.00471666052306E-01 7.64408589898503E-01 -1.09026022674644E-01 + -2.44866172038471E-01 +* ORBITAL 1 24 + 4.76380264325376E-02 -6.32052927440502E-02 -4.79367992390691E-01 1.88165270727093E-01 -4.22393989726424E-01 + -9.33944932602125E-02 6.17311427798178E-01 -6.08869471502077E-01 1.66067800444811E+00 4.51708184633801E-02 + -5.02801048718705E-01 -2.38543736625967E-01 -3.72312800137847E-03 -8.27691141052857E-02 1.35974637630859E-01 + -1.31152248378628E-01 4.62788619143394E-01 8.28320642222252E-03 7.68467790925185E-01 -4.08558354201352E-01 + -1.09987019832718E-01 7.52044076774763E-02 5.10535887987352E-01 8.75550285271806E-01 -2.61126494680599E-01 + 1.18715864715409E-01 +* ORBITAL 1 25 + -2.29800803666328E-02 4.93003256761457E-01 -5.32111089423763E-01 -3.19133371230221E-02 -2.23919383482301E-01 + 1.17392425580685E-01 1.34868764151434E-01 -2.08523990163144E-01 1.95141737915246E+00 -2.27532702804326E-02 + 1.41801698307104E+00 -2.36900400076652E+00 -7.66559399547265E-04 -2.12260558635364E-01 6.14581270211244E-02 + 6.50607868861768E-02 -1.17244556820268E-01 1.20876230938928E+00 2.62803450060666E-01 2.32240293863129E-01 + -3.95960608475124E-01 2.59836307765394E-01 5.15024769895322E-01 6.67068565209485E-01 -3.06995603538012E-01 + 8.64585882507126E-01 +* ORBITAL 1 26 + 2.68314200545035E-02 1.86322907687167E+00 -3.49835668329025E+00 -1.92030814789839E-01 8.35827205650567E-01 + 7.31657100537346E-02 -7.06994258792320E-01 6.40230587065184E-02 -7.47456960534130E-01 -1.60882290537478E-02 + -4.21452386379016E-01 1.13420500453407E+00 4.83548212576859E-02 5.99190486211934E-03 7.75243994402050E-02 + -3.32970091398686E-01 4.01271412109929E-02 -1.41621370886180E+00 2.98373427610127E-01 4.68368384476928E-01 + 3.13601643660357E-01 3.42266161365698E-01 -7.07928957615249E-02 4.74005138308896E-02 3.69783607428459E-01 + 6.38586617522489E-01 +#OCC +* OCCUPATION NUMBERS + 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 + 2.00000000000000E+00 2.00000000000000E+00 9.96834278614931E-01 9.94208773273331E-01 8.95694811173731E-03 + 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 +#OCHR +* OCCUPATION NUMBERS (HUMAN-READABLE) + 2.0000 2.0000 2.0000 2.0000 2.0000 2.0000 2.0000 0.9968 0.9942 0.0090 + 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 + 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 +#ONE +* ONE ELECTRON ENERGIES + 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 + 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 + 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 +#INDEX +* 1234567890 +0 iiiiiii222 +1 ssssssssss +2 ssssss +>>EOF +>>FILE checkfile +* This file is autogenerated: +* Molcas version 22.06-59-g840ff27 +* Linux ln0006 3.10.0-1160.66.1.el7.x86_64 #1 SMP Wed May 18 16:02:34 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Sun Jul 17 21:27:47 2022 +* +#>> 1 +#> POTNUC="28.659763687133"/12 +#>> 2 +#> POTNUC="28.659763687133"/12 +#> SEWARD_MLTPL1X="0.346661791590"/5 +#> SEWARD_KINETIC="16.578973779721"/5 +#> SEWARD_ATTRACT="-37.824814970634"/5 +#>> 3 +#> RASSCF_ITER="4"/8 +#> E_RASSCF[0]="-77.307184469824"/8 +#> E_RASSCF[1]="-77.298093701740"/8 +#> E_RASSCF[2]="-77.236152415045"/8 +#> MLTPL__0="-0.000000000000"/5 +#> MLTPL__1[0]="0.289957144255"/5 +#> MLTPL__1[1]="0.012256789451"/5 +#> MLTPL__1[2]="-0.076162690266"/5 +#> MLTPL__2[0]="-4.042491127662"/5 +#> MLTPL__2[1]="1.017452398359"/5 +#> MLTPL__2[2]="0.582501245782"/5 +#> MLTPL__2[3]="-0.982278773074"/5 +#> MLTPL__2[4]="0.885311330696"/5 +#> MLTPL__2[5]="5.024769900737"/5 +#> MLTPL__0="-0.000000000000"/5 +#> MLTPL__1[0]="0.122824005013"/5 +#> MLTPL__1[1]="0.038816960608"/5 +#> MLTPL__1[2]="-0.140965732889"/5 +#> MLTPL__2[0]="-3.233086790785"/5 +#> MLTPL__2[1]="-0.229935132508"/5 +#> MLTPL__2[2]="0.330881361526"/5 +#> MLTPL__2[3]="-1.747739238664"/5 +#> MLTPL__2[4]="1.214497623397"/5 +#> MLTPL__2[5]="4.980826029450"/5 +#> MLTPL__0="-0.000000000000"/5 +#> MLTPL__1[0]="-0.058903389168"/5 +#> MLTPL__1[1]="0.081051518996"/5 +#> MLTPL__1[2]="-0.201705567124"/5 +#> MLTPL__2[0]="-2.292329873104"/5 +#> MLTPL__2[1]="-1.405117246711"/5 +#> MLTPL__2[2]="0.072970415994"/5 +#> MLTPL__2[3]="-2.589070998802"/5 +#> MLTPL__2[4]="1.587123682189"/5 +#> MLTPL__2[5]="4.881400871906"/5 +#>> 4 +#> DENS_TT="16.000008893734"/6 +#> DENS_A1="8.000004446867"/6 +#> DENS_B1="8.000004446867"/6 +#> DENS_A2="8.384051711487"/6 +#> DENS_B2="7.615957182247"/6 +#> EXCH_F="1"/6 +#> CORR_F="1"/6 +#> EXCHA_A="-5.872857544855"/6 +#> EXCHA_B="-5.520138033556"/6 +#> CORR_E="-0.480778071434"/6 +#> CASDFTE="-77.632411292604"/8 +#> DENS_TT="16.000004869274"/6 +#> DENS_A1="8.000002434637"/6 +#> DENS_B1="8.000002434637"/6 +#> DENS_A2="8.383278740204"/6 +#> DENS_B2="7.616726129071"/6 +#> EXCH_F="1"/6 +#> CORR_F="1"/6 +#> EXCHA_A="-5.863675437581"/6 +#> EXCHA_B="-5.517388715740"/6 +#> CORR_E="-0.481663547329"/6 +#> CASDFTE="-77.629166925010"/8 +#> DENS_TT="16.000000692276"/6 +#> DENS_A1="8.000000346138"/6 +#> DENS_B1="8.000000346138"/6 +#> DENS_A2="8.025882830584"/6 +#> DENS_B2="7.974117861692"/6 +#> EXCH_F="1"/6 +#> CORR_F="1"/6 +#> EXCHA_A="-5.703444138942"/6 +#> EXCHA_B="-5.678526921571"/6 +#> CORR_E="-0.483886793350"/6 +#> CASDFTE="-77.582241895411"/8 +#>> 5 +#> MLTPL__0="-0.000000000000"/5 +#> MLTPL__1[0]="0.122824005013"/5 +#> MLTPL__1[1]="0.038816960608"/5 +#> MLTPL__1[2]="-0.140965732889"/5 +#> MLTPL__2[0]="-3.233086790785"/5 +#> MLTPL__2[1]="-0.229935132508"/5 +#> MLTPL__2[2]="0.330881361526"/5 +#> MLTPL__2[3]="-1.747739238664"/5 +#> MLTPL__2[4]="1.214497623397"/5 +#> MLTPL__2[5]="4.980826029450"/5 +#>> 6 +#> GRAD[0]="0.102635793212"/6 +#> GRAD[1]="-0.059377283950"/6 +#> GRAD[2]="-0.004443415553"/6 +#> GRAD[3]="-0.009682691372"/6 +#> GRAD[4]="0.036658139720"/6 +#> GRAD[5]="0.053350008573"/6 +#> GRAD[6]="0.005195730637"/6 +#> GRAD[7]="-0.002985137527"/6 +#> GRAD[8]="-0.064387550570"/6 +#> GRAD[9]="-0.007813254088"/6 +#> GRAD[10]="0.012699550521"/6 +#> GRAD[11]="0.014597354375"/6 +#> GRAD[12]="-0.066008764960"/6 +#> GRAD[13]="0.011699604720"/6 +#> GRAD[14]="-0.028956751589"/6 +#> GRAD[15]="-0.024326813429"/6 +#> GRAD[16]="0.001305126515"/6 +#> GRAD[17]="0.029840354764"/6 +>>EOF diff -Nru openmolcas-22.02/test/additional/803.input openmolcas-22.10/test/additional/803.input --- openmolcas-22.02/test/additional/803.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/803.input 2022-10-10 14:22:40.000000000 +0000 @@ -1,6 +1,6 @@ *------------------------------------------------------------------------------- * Molecule: CH2=NH2+ -* Basis: STO-3G +* Basis: 3-21G * Symmetry: C1 * Features tested: Tully Surface Hop * Responsible person: Alessio Valentini @@ -52,6 +52,7 @@ PSUB SUBSTEPS = 10 FRAND = 0.01 + NORASSI &Alaska &Dynamix diff -Nru openmolcas-22.02/test/additional/806.input openmolcas-22.10/test/additional/806.input --- openmolcas-22.02/test/additional/806.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/806.input 2022-10-10 14:22:40.000000000 +0000 @@ -30,9 +30,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-293-g6d8396f30 -* Linux otis 5.4.0-90-generic #101~18.04.1-Ubuntu SMP Fri Oct 22 09:25:04 UTC 2021 x86_64 x86_64 x86_64 GNU/Linux -* Sat Dec 18 18:48:54 2021 +* Molcas version 22.02-113-g3e6c18d4f +* Linux lucifer 5.13.0-35-generic #40~20.04.1-Ubuntu SMP Mon Mar 7 09:18:32 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Fri Mar 18 17:07:39 2022 * #>> 1 #> POTNUC="28.575569388762"/12 @@ -42,178 +42,178 @@ #> SEWARD_KINETIC="37.257451875475"/5 #> SEWARD_ATTRACT="-80.849852572063"/5 #>> 3 -#> SCF_ITER="9"/8 -#> E_SCF="-198.673030821061"/6 +#> SCF_ITER="8"/8 +#> E_SCF="-198.673030821059"/6 #> MLTPL__0="-0.000000000000"/3 #> MLTPL__1[0]="0.0"/3 #> MLTPL__1[1]="0.0"/3 -#> MLTPL__1[2]="-0.000000122707"/3 -#> MLTPL__2[0]="-0.319365304886"/3 +#> MLTPL__1[2]="0.000000001451"/3 +#> MLTPL__2[0]="-0.319365270267"/3 #> MLTPL__2[1]="0.0"/3 #> MLTPL__2[2]="0.0"/3 -#> MLTPL__2[3]="-0.319365304885"/3 +#> MLTPL__2[3]="-0.319365270267"/3 #> MLTPL__2[4]="0.0"/3 -#> MLTPL__2[5]="0.638730609771"/3 +#> MLTPL__2[5]="0.638730540533"/3 #>> 4 #> MLTPL__0="-0.000000000000"/3 #> MLTPL__1[0]="0.0"/3 #> MLTPL__1[1]="0.0"/3 -#> MLTPL__1[2]="-0.000000145295"/3 -#> MLTPL__2[0]="-0.410762070147"/3 +#> MLTPL__1[2]="0.000000000956"/3 +#> MLTPL__2[0]="-0.410762039040"/3 #> MLTPL__2[1]="0.0"/3 #> MLTPL__2[2]="0.0"/3 -#> MLTPL__2[3]="-0.410762070146"/3 +#> MLTPL__2[3]="-0.410762039040"/3 #> MLTPL__2[4]="0.0"/3 -#> MLTPL__2[5]="0.821524140293"/3 -#> E_MP2="-199.076640784420"/6 -#> HF_REF_WEIGHT="0.906921056435"/6 +#> MLTPL__2[5]="0.821524078080"/3 +#> E_MP2="-199.076640773573"/6 +#> HF_REF_WEIGHT="0.906921061652"/6 #>> 5 #> GRAD[0]="0.0"/6 #> GRAD[1]="0.0"/6 -#> GRAD[2]="-0.035177235192"/6 +#> GRAD[2]="-0.035177170778"/6 #> GRAD[3]="0.0"/6 #> GRAD[4]="0.0"/6 -#> GRAD[5]="0.035177235192"/6 +#> GRAD[5]="0.035177170778"/6 #>> 6 #>> 7 #>> 9 -#> POTNUC="29.335973585670"/6 +#> POTNUC="29.335972171583"/6 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_KINETIC="37.257451875475"/5 -#> SEWARD_ATTRACT="-80.934341924205"/5 +#> SEWARD_ATTRACT="-80.934341767084"/5 #>> 10 -#> SCF_ITER="8"/8 -#> E_SCF="-198.679377855196"/6 +#> SCF_ITER="7"/8 +#> E_SCF="-198.679377844825"/6 #> MLTPL__0="-0.000000000000"/3 #> MLTPL__1[0]="0.0"/3 #> MLTPL__1[1]="0.0"/3 -#> MLTPL__1[2]="-0.000000157434"/3 -#> MLTPL__2[0]="-0.282489875342"/3 +#> MLTPL__1[2]="0.000000000699"/3 +#> MLTPL__2[0]="-0.282489846884"/3 #> MLTPL__2[1]="0.0"/3 #> MLTPL__2[2]="0.0"/3 -#> MLTPL__2[3]="-0.282489875342"/3 +#> MLTPL__2[3]="-0.282489846884"/3 #> MLTPL__2[4]="0.0"/3 -#> MLTPL__2[5]="0.564979750685"/3 +#> MLTPL__2[5]="0.564979693767"/3 #>> 11 #> MLTPL__0="-0.000000000000"/3 #> MLTPL__1[0]="0.0"/3 #> MLTPL__1[1]="0.0"/3 -#> MLTPL__1[2]="-0.000000111521"/3 -#> MLTPL__2[0]="-0.370128056880"/3 +#> MLTPL__1[2]="0.000000000470"/3 +#> MLTPL__2[0]="-0.370128042400"/3 #> MLTPL__2[1]="0.0"/3 #> MLTPL__2[2]="0.0"/3 -#> MLTPL__2[3]="-0.370128056880"/3 +#> MLTPL__2[3]="-0.370128042400"/3 #> MLTPL__2[4]="0.0"/3 -#> MLTPL__2[5]="0.740256113760"/3 -#> E_MP2="-199.078674365804"/6 -#> HF_REF_WEIGHT="0.910661929673"/6 +#> MLTPL__2[5]="0.740256084800"/3 +#> E_MP2="-199.078674367899"/6 +#> HF_REF_WEIGHT="0.910661914553"/6 #>> 12 #> GRAD[0]="0.0"/6 #> GRAD[1]="0.0"/6 -#> GRAD[2]="-0.019454151655"/6 +#> GRAD[2]="-0.019454197648"/6 #> GRAD[3]="0.0"/6 #> GRAD[4]="0.0"/6 -#> GRAD[5]="0.019454151655"/6 +#> GRAD[5]="0.019454197648"/6 #>> 13 #>> 14 #>> 16 -#> POTNUC="30.115268534833"/6 +#> POTNUC="30.115170505137"/6 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_KINETIC="37.257451875475"/5 -#> SEWARD_ATTRACT="-81.020930247708"/5 +#> SEWARD_ATTRACT="-81.020919355520"/5 #>> 17 #> SCF_ITER="7"/8 -#> E_SCF="-198.684245360786"/6 +#> E_SCF="-198.684244856514"/6 #> MLTPL__0="-0.000000000000"/3 #> MLTPL__1[0]="0.0"/3 #> MLTPL__1[1]="0.0"/3 -#> MLTPL__1[2]="0.000000263258"/3 -#> MLTPL__2[0]="-0.244589417720"/3 +#> MLTPL__1[2]="-0.000000000377"/3 +#> MLTPL__2[0]="-0.244594178731"/3 #> MLTPL__2[1]="0.0"/3 #> MLTPL__2[2]="0.0"/3 -#> MLTPL__2[3]="-0.244589417720"/3 +#> MLTPL__2[3]="-0.244594178731"/3 #> MLTPL__2[4]="0.0"/3 -#> MLTPL__2[5]="0.489178835440"/3 +#> MLTPL__2[5]="0.489188357461"/3 #>> 18 #> MLTPL__0="-0.000000000000"/3 #> MLTPL__1[0]="0.0"/3 #> MLTPL__1[1]="0.0"/3 -#> MLTPL__1[2]="0.000000188851"/3 -#> MLTPL__2[0]="-0.328032921205"/3 +#> MLTPL__1[2]="-0.000000000269"/3 +#> MLTPL__2[0]="-0.328038226872"/3 #> MLTPL__2[1]="0.0"/3 #> MLTPL__2[2]="0.0"/3 -#> MLTPL__2[3]="-0.328032921205"/3 +#> MLTPL__2[3]="-0.328038226872"/3 #> MLTPL__2[4]="0.0"/3 -#> MLTPL__2[5]="0.656065842410"/3 -#> E_MP2="-199.079383691644"/6 -#> HF_REF_WEIGHT="0.914125575981"/6 +#> MLTPL__2[5]="0.656076453745"/3 +#> E_MP2="-199.079383695245"/6 +#> HF_REF_WEIGHT="0.914125161729"/6 #>> 19 #> GRAD[0]="0.0"/6 #> GRAD[1]="0.0"/6 -#> GRAD[2]="0.000429203226"/6 +#> GRAD[2]="0.000426450023"/6 #> GRAD[3]="0.0"/6 #> GRAD[4]="0.0"/6 -#> GRAD[5]="-0.000429203226"/6 +#> GRAD[5]="-0.000426450023"/6 #>> 20 #>> 21 #>> 23 -#> POTNUC="30.099897288164"/6 +#> POTNUC="30.099897379851"/6 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_KINETIC="37.257451875475"/5 -#> SEWARD_ATTRACT="-81.019222331506"/5 +#> SEWARD_ATTRACT="-81.019222341693"/5 #>> 24 #> SCF_ITER="4"/8 -#> E_SCF="-198.684165952877"/6 +#> E_SCF="-198.684165953327"/6 #> MLTPL__0="-0.000000000000"/3 #> MLTPL__1[0]="0.0"/3 #> MLTPL__1[1]="0.0"/3 -#> MLTPL__1[2]="0.000000274069"/3 -#> MLTPL__2[0]="-0.245339272153"/3 +#> MLTPL__1[2]="-0.000000000362"/3 +#> MLTPL__2[0]="-0.245339253704"/3 #> MLTPL__2[1]="0.0"/3 #> MLTPL__2[2]="0.0"/3 -#> MLTPL__2[3]="-0.245339272153"/3 +#> MLTPL__2[3]="-0.245339253704"/3 #> MLTPL__2[4]="0.0"/3 -#> MLTPL__2[5]="0.490678544306"/3 +#> MLTPL__2[5]="0.490678507409"/3 #>> 25 #> MLTPL__0="-0.000000000000"/3 #> MLTPL__1[0]="0.0"/3 #> MLTPL__1[1]="0.0"/3 -#> MLTPL__1[2]="0.000000203307"/3 -#> MLTPL__2[0]="-0.328868494918"/3 +#> MLTPL__1[2]="-0.000000000268"/3 +#> MLTPL__2[0]="-0.328868474793"/3 #> MLTPL__2[1]="0.0"/3 #> MLTPL__2[2]="0.0"/3 -#> MLTPL__2[3]="-0.328868494918"/3 +#> MLTPL__2[3]="-0.328868474793"/3 #> MLTPL__2[4]="0.0"/3 -#> MLTPL__2[5]="0.657736989836"/3 -#> E_MP2="-199.079383975237"/6 -#> HF_REF_WEIGHT="0.914060522281"/6 +#> MLTPL__2[5]="0.657736949585"/3 +#> E_MP2="-199.079383975265"/6 +#> HF_REF_WEIGHT="0.914060522901"/6 #>> 26 #> GRAD[0]="0.0"/6 #> GRAD[1]="0.0"/6 -#> GRAD[2]="-0.000001930191"/6 +#> GRAD[2]="-0.000001925087"/6 #> GRAD[3]="0.0"/6 #> GRAD[4]="0.0"/6 -#> GRAD[5]="0.000001930191"/6 +#> GRAD[5]="0.000001925087"/6 #>> 27 #> GEO_ITER="4"/8 -#> POTNUC="30.099973650440"/6 +#> POTNUC="30.099973499241"/6 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_KINETIC="37.257451875475"/5 -#> SEWARD_ATTRACT="-81.019230816203"/5 +#> SEWARD_ATTRACT="-81.019230799403"/5 #> SCF_ITER="2"/8 -#> E_SCF="-198.684166349153"/6 +#> E_SCF="-198.684166348364"/6 #> MLTPL__0="-0.000000000000"/3 #> MLTPL__1[0]="0.0"/3 #> MLTPL__1[1]="0.0"/3 -#> MLTPL__1[2]="0.000000203247"/3 -#> MLTPL__2[0]="-0.245333845919"/3 +#> MLTPL__1[2]="-0.000000000269"/3 +#> MLTPL__2[0]="-0.245333851756"/3 #> MLTPL__2[1]="0.0"/3 #> MLTPL__2[2]="0.0"/3 -#> MLTPL__2[3]="-0.245333845919"/3 +#> MLTPL__2[3]="-0.245333851756"/3 #> MLTPL__2[4]="0.0"/3 -#> MLTPL__2[5]="0.490667691838"/3 -#> E_MP2="-199.079383980517"/6 -#> HF_REF_WEIGHT="0.914060871549"/6 +#> MLTPL__2[5]="0.490667703511"/3 +#> E_MP2="-199.079383980514"/6 +#> HF_REF_WEIGHT="0.914060870949"/6 #>> 28 #>> 29 >>EOF diff -Nru openmolcas-22.02/test/additional/807.input openmolcas-22.10/test/additional/807.input --- openmolcas-22.02/test/additional/807.input 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/test/additional/807.input 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,837 @@ +*------------------------------------------------------------------------------- +* Molecule: CH2=NH2+ +* Basis: 3-21G +* Symmetry: C1 +* Features tested: Tully Surface Hop +* Responsible people: Isabella Merritt & Morgane Vacher +* Comments: This trajectory should HOP at step 9 from S1 to S0 +*------------------------------------------------------------------------------- + +&Gateway + coord + 6 + + C -4.55474962 0.68643690 -0.00758729 + N -3.18080631 0.57906092 0.10064107 + H -5.27639440 0.39586375 0.86821135 + H -5.04520597 1.01019992 -0.90364477 + H -2.55373696 -0.29766686 0.29353201 + H -2.63813360 1.45716219 0.12140935 + + basis=3-21G + group=NoSym +NoCD + +>> EXPORT MOLCAS_MAXITER=10 +>> DOWHILE +&Seward + +&Rasscf +SYMMETRY + 1 +SPIN + 1 +NACTEL + 4 0 0 +FROZEN + 0 +INACTIVE + 6 +RAS2 + 4 +CIROOT + 3 3 + 1 2 3 + 1 1 1 +MDRLXROOT + 2 + +&surfacehop + TULLY + DECOHERENCE = 0.1 + PSUB + SUBSTEPS = 10 + FRAND = 0.05 + +&Alaska +&Dynamix + VELVER + DT = 20 + VELO = 0 +>>> End Do +>>FILE checkfile +* This file is autogenerated: +* Molcas version 21.10-817-g9714b21 +* Linux jaws 3.10.0-1160.31.1.el7.x86_64 #1 SMP Thu Jun 10 13:32:12 UTC 2021 x86_64 x86_64 x86_64 GNU/Linux +* Fri Feb 18 16:41:25 2022 +* +#>> 1 +#> POTNUC="36.351747064625"/12 +#>> 2 +#> POTNUC="36.351747064625"/6 +#> SEWARD_MLTPL1X="-8.607229348043"/5 +#> SEWARD_KINETIC="16.578973779721"/5 +#> SEWARD_ATTRACT="-38.553788581695"/5 +#>> 3 +#> RASSCF_ITER="22"/8 +#> E_RASSCF[0]="-93.795555470760"/8 +#> E_RASSCF[1]="-93.676506614037"/8 +#> E_RASSCF[2]="-93.456752311319"/8 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.071897698215"/5 +#> MLTPL__1[1]="1.222427079564"/5 +#> MLTPL__1[2]="0.213062484521"/5 +#> MLTPL__2[0]="4.908646555150"/5 +#> MLTPL__2[1]="-0.750066561081"/5 +#> MLTPL__2[2]="0.931169549623"/5 +#> MLTPL__2[3]="-1.502650152894"/5 +#> MLTPL__2[4]="-0.827370428889"/5 +#> MLTPL__2[5]="-3.405996402256"/5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.308333117776"/5 +#> MLTPL__1[1]="1.197027568226"/5 +#> MLTPL__1[2]="0.230496170455"/5 +#> MLTPL__2[0]="4.659872990501"/5 +#> MLTPL__2[1]="-0.463134987778"/5 +#> MLTPL__2[2]="0.861709475634"/5 +#> MLTPL__2[3]="-0.741604216845"/5 +#> MLTPL__2[4]="-1.324457088247"/5 +#> MLTPL__2[5]="-3.918268773656"/5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.094536500833"/5 +#> MLTPL__1[1]="1.188891941971"/5 +#> MLTPL__1[2]="0.344238618665"/5 +#> MLTPL__2[0]="6.200349307524"/5 +#> MLTPL__2[1]="-0.330509935001"/5 +#> MLTPL__2[2]="0.538949947835"/5 +#> MLTPL__2[3]="-1.961714955176"/5 +#> MLTPL__2[4]="-1.327059121186"/5 +#> MLTPL__2[5]="-4.238634352348"/5 +#>> 4 +#>> 5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.208897960447"/5 +#> MLTPL__1[1]="1.206145938000"/5 +#> MLTPL__1[2]="0.192366444173"/5 +#> MLTPL__2[0]="4.667250016733"/5 +#> MLTPL__2[1]="-0.652980685332"/5 +#> MLTPL__2[2]="1.190933741301"/5 +#> MLTPL__2[3]="-0.716477746097"/5 +#> MLTPL__2[4]="-1.483845092003"/5 +#> MLTPL__2[5]="-3.950772270636"/5 +#>> 6 +#> GRAD[0]="0.119758930101"/6 +#> GRAD[1]="0.028381896858"/6 +#> GRAD[2]="-0.055553767723"/6 +#> GRAD[3]="-0.117643639030"/6 +#> GRAD[4]="0.012928385026"/6 +#> GRAD[5]="-0.001813924531"/6 +#> GRAD[6]="-0.045875775846"/6 +#> GRAD[7]="-0.052330753682"/6 +#> GRAD[8]="0.028911011516"/6 +#> GRAD[9]="-0.009479434248"/6 +#> GRAD[10]="0.032695733476"/6 +#> GRAD[11]="0.027427049011"/6 +#> GRAD[12]="0.038956932558"/6 +#> GRAD[13]="-0.028176336106"/6 +#> GRAD[14]="0.047209836225"/6 +#> GRAD[15]="0.014282986465"/6 +#> GRAD[16]="0.006501074429"/6 +#> GRAD[17]="-0.046180204498"/6 +#>> 7 +#>> 8 +#> EKIN="0.0"/6 +#>> 10 +#> POTNUC="36.366879774263"/6 +#> SEWARD_MLTPL1X="-8.608324303760"/5 +#> SEWARD_KINETIC="16.578973779721"/5 +#> SEWARD_ATTRACT="-38.553479601121"/5 +#>> 11 +#> RASSCF_ITER="16"/8 +#> E_RASSCF[0]="-93.796047676976"/8 +#> E_RASSCF[1]="-93.678324989287"/8 +#> E_RASSCF[2]="-93.457255549458"/8 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.072775636569"/5 +#> MLTPL__1[1]="1.221596845586"/5 +#> MLTPL__1[2]="0.213861704191"/5 +#> MLTPL__2[0]="4.896022671982"/5 +#> MLTPL__2[1]="-0.739553428503"/5 +#> MLTPL__2[2]="0.930656199888"/5 +#> MLTPL__2[3]="-1.502508904554"/5 +#> MLTPL__2[4]="-0.811953601733"/5 +#> MLTPL__2[5]="-3.393513767428"/5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.312771492983"/5 +#> MLTPL__1[1]="1.201456484831"/5 +#> MLTPL__1[2]="0.229929324238"/5 +#> MLTPL__2[0]="4.640852528745"/5 +#> MLTPL__2[1]="-0.466117212387"/5 +#> MLTPL__2[2]="0.867908591142"/5 +#> MLTPL__2[3]="-0.737022431070"/5 +#> MLTPL__2[4]="-1.296891729810"/5 +#> MLTPL__2[5]="-3.903830097675"/5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.082367567994"/5 +#> MLTPL__1[1]="1.193155022596"/5 +#> MLTPL__1[2]="0.333632352296"/5 +#> MLTPL__2[0]="6.178138853998"/5 +#> MLTPL__2[1]="-0.350211076058"/5 +#> MLTPL__2[2]="0.608786835178"/5 +#> MLTPL__2[3]="-1.939903796426"/5 +#> MLTPL__2[4]="-1.309463480322"/5 +#> MLTPL__2[5]="-4.238235057572"/5 +#>> 12 +#>> 13 +#>> 14 +#>> 15 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.238742762751"/5 +#> MLTPL__1[1]="1.204636499008"/5 +#> MLTPL__1[2]="0.198821886909"/5 +#> MLTPL__2[0]="4.636738541554"/5 +#> MLTPL__2[1]="-0.625088903142"/5 +#> MLTPL__2[2]="1.134631806762"/5 +#> MLTPL__2[3]="-0.726625960530"/5 +#> MLTPL__2[4]="-1.463661584997"/5 +#> MLTPL__2[5]="-3.910112581025"/5 +#>> 16 +#> GRAD[0]="0.109622636292"/6 +#> GRAD[1]="0.026642442299"/6 +#> GRAD[2]="-0.049440687590"/6 +#> GRAD[3]="-0.109932967207"/6 +#> GRAD[4]="0.012349454447"/6 +#> GRAD[5]="-0.003534980527"/6 +#> GRAD[6]="-0.042799576053"/6 +#> GRAD[7]="-0.051118159301"/6 +#> GRAD[8]="0.026034250405"/6 +#> GRAD[9]="-0.007773524390"/6 +#> GRAD[10]="0.033059650794"/6 +#> GRAD[11]="0.025495390233"/6 +#> GRAD[12]="0.037488938132"/6 +#> GRAD[13]="-0.027963662780"/6 +#> GRAD[14]="0.047157918492"/6 +#> GRAD[15]="0.013394493226"/6 +#> GRAD[16]="0.007030274541"/6 +#> GRAD[17]="-0.045711891013"/6 +#>> 17 +#>> 18 +#> EKIN="0.001787414634"/6 +#> EKIN="0.001787414634"/6 +#>> 20 +#> POTNUC="36.412396714918"/6 +#> SEWARD_MLTPL1X="-8.611423818671"/5 +#> SEWARD_KINETIC="16.578973779721"/5 +#> SEWARD_ATTRACT="-38.552714497505"/5 +#>> 21 +#> RASSCF_ITER="17"/8 +#> E_RASSCF[0]="-93.796954201971"/8 +#> E_RASSCF[1]="-93.683337762105"/8 +#> E_RASSCF[2]="-93.459125685361"/8 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.075146445931"/5 +#> MLTPL__1[1]="1.220623234048"/5 +#> MLTPL__1[2]="0.214558156271"/5 +#> MLTPL__2[0]="4.854117648022"/5 +#> MLTPL__2[1]="-0.710692108472"/5 +#> MLTPL__2[2]="0.934572302870"/5 +#> MLTPL__2[3]="-1.499145319231"/5 +#> MLTPL__2[4]="-0.763003595655"/5 +#> MLTPL__2[5]="-3.354972328791"/5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.327224146794"/5 +#> MLTPL__1[1]="1.212426529311"/5 +#> MLTPL__1[2]="0.227795654276"/5 +#> MLTPL__2[0]="4.589520706388"/5 +#> MLTPL__2[1]="-0.469067094739"/5 +#> MLTPL__2[2]="0.883574725370"/5 +#> MLTPL__2[3]="-0.725532328059"/5 +#> MLTPL__2[4]="-1.222841676929"/5 +#> MLTPL__2[5]="-3.863988378329"/5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.063747048269"/5 +#> MLTPL__1[1]="1.203250707428"/5 +#> MLTPL__1[2]="0.310050204709"/5 +#> MLTPL__2[0]="6.110090191047"/5 +#> MLTPL__2[1]="-0.389796473518"/5 +#> MLTPL__2[2]="0.762965023185"/5 +#> MLTPL__2[3]="-1.894000777603"/5 +#> MLTPL__2[4]="-1.255202260293"/5 +#> MLTPL__2[5]="-4.216089413444"/5 +#>> 22 +#>> 23 +#>> 24 +#>> 25 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.290151625667"/5 +#> MLTPL__1[1]="1.206663055355"/5 +#> MLTPL__1[2]="0.207505029323"/5 +#> MLTPL__2[0]="4.568991433357"/5 +#> MLTPL__2[1]="-0.573294448236"/5 +#> MLTPL__2[2]="1.050987851000"/5 +#> MLTPL__2[3]="-0.732861266165"/5 +#> MLTPL__2[4]="-1.396664638907"/5 +#> MLTPL__2[5]="-3.836130167192"/5 +#>> 26 +#> GRAD[0]="0.093219822660"/6 +#> GRAD[1]="0.023156539315"/6 +#> GRAD[2]="-0.037439163366"/6 +#> GRAD[3]="-0.096114979344"/6 +#> GRAD[4]="0.010507551472"/6 +#> GRAD[5]="-0.006002416322"/6 +#> GRAD[6]="-0.036830500924"/6 +#> GRAD[7]="-0.048789746873"/6 +#> GRAD[8]="0.019961082876"/6 +#> GRAD[9]="-0.005569066401"/6 +#> GRAD[10]="0.033825677488"/6 +#> GRAD[11]="0.021712683942"/6 +#> GRAD[12]="0.033691464606"/6 +#> GRAD[13]="-0.025762689060"/6 +#> GRAD[14]="0.046713718453"/6 +#> GRAD[15]="0.011603259402"/6 +#> GRAD[16]="0.007062667658"/6 +#> GRAD[17]="-0.044945905583"/6 +#>> 27 +#>> 28 +#> EKIN="0.006749745511"/6 +#> EKIN="0.006749745511"/6 +#>> 30 +#> POTNUC="36.487119177231"/6 +#> SEWARD_MLTPL1X="-8.616227950977"/5 +#> SEWARD_KINETIC="16.578973779721"/5 +#> SEWARD_ATTRACT="-38.551742334506"/5 +#>> 31 +#> RASSCF_ITER="17"/8 +#> E_RASSCF[0]="-93.797256197160"/8 +#> E_RASSCF[1]="-93.690698589362"/8 +#> E_RASSCF[2]="-93.462452128315"/8 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.077708002002"/5 +#> MLTPL__1[1]="1.221140080829"/5 +#> MLTPL__1[2]="0.213487706591"/5 +#> MLTPL__2[0]="4.780179524644"/5 +#> MLTPL__2[1]="-0.667562843202"/5 +#> MLTPL__2[2]="0.947596867343"/5 +#> MLTPL__2[3]="-1.490769601932"/5 +#> MLTPL__2[4]="-0.678976621275"/5 +#> MLTPL__2[5]="-3.289409922712"/5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.352808741063"/5 +#> MLTPL__1[1]="1.227135855157"/5 +#> MLTPL__1[2]="0.223743695256"/5 +#> MLTPL__2[0]="4.514654391964"/5 +#> MLTPL__2[1]="-0.464375978885"/5 +#> MLTPL__2[2]="0.904447072118"/5 +#> MLTPL__2[3]="-0.709827830495"/5 +#> MLTPL__2[4]="-1.112243650582"/5 +#> MLTPL__2[5]="-3.804826561468"/5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.058593034892"/5 +#> MLTPL__1[1]="1.216049117658"/5 +#> MLTPL__1[2]="0.283945688744"/5 +#> MLTPL__2[0]="5.999506072703"/5 +#> MLTPL__2[1]="-0.422466509453"/5 +#> MLTPL__2[2]="0.931226707376"/5 +#> MLTPL__2[3]="-1.846046617514"/5 +#> MLTPL__2[4]="-1.161177358595"/5 +#> MLTPL__2[5]="-4.153459455189"/5 +#>> 32 +#>> 33 +#>> 34 +#>> 35 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.337612628992"/5 +#> MLTPL__1[1]="1.215270135439"/5 +#> MLTPL__1[2]="0.211076821334"/5 +#> MLTPL__2[0]="4.482663865254"/5 +#> MLTPL__2[1]="-0.522572616346"/5 +#> MLTPL__2[2]="0.997020888750"/5 +#> MLTPL__2[3]="-0.723985038638"/5 +#> MLTPL__2[4]="-1.283938655546"/5 +#> MLTPL__2[5]="-3.758678826616"/5 +#>> 36 +#> GRAD[0]="0.078405280183"/6 +#> GRAD[1]="0.019340052393"/6 +#> GRAD[2]="-0.023941625762"/6 +#> GRAD[3]="-0.081371173390"/6 +#> GRAD[4]="0.006595724971"/6 +#> GRAD[5]="-0.007248920152"/6 +#> GRAD[6]="-0.029831098291"/6 +#> GRAD[7]="-0.046213857331"/6 +#> GRAD[8]="0.012237294303"/6 +#> GRAD[9]="-0.004516507260"/6 +#> GRAD[10]="0.034672199468"/6 +#> GRAD[11]="0.017605767495"/6 +#> GRAD[12]="0.027791559545"/6 +#> GRAD[13]="-0.020205134188"/6 +#> GRAD[14]="0.045677940113"/6 +#> GRAD[15]="0.009521939213"/6 +#> GRAD[16]="0.005811014687"/6 +#> GRAD[17]="-0.044330455998"/6 +#>> 37 +#>> 38 +#> EKIN="0.014052395843"/6 +#> EKIN="0.014052395843"/6 +#>> 40 +#> POTNUC="36.586833864532"/6 +#> SEWARD_MLTPL1X="-8.622465801999"/5 +#> SEWARD_KINETIC="16.578973779721"/5 +#> SEWARD_ATTRACT="-38.550700446778"/5 +#>> 41 +#> RASSCF_ITER="16"/8 +#> E_RASSCF[0]="-93.795900233125"/8 +#> E_RASSCF[1]="-93.699455300643"/8 +#> E_RASSCF[2]="-93.466591944074"/8 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.077611970046"/5 +#> MLTPL__1[1]="1.223348966772"/5 +#> MLTPL__1[2]="0.210608063950"/5 +#> MLTPL__2[0]="4.676484341767"/5 +#> MLTPL__2[1]="-0.614219111039"/5 +#> MLTPL__2[2]="0.968861977523"/5 +#> MLTPL__2[3]="-1.479747662362"/5 +#> MLTPL__2[4]="-0.562602273753"/5 +#> MLTPL__2[5]="-3.196736679405"/5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.390125636414"/5 +#> MLTPL__1[1]="1.244145877237"/5 +#> MLTPL__1[2]="0.217727466862"/5 +#> MLTPL__2[0]="4.423033316400"/5 +#> MLTPL__2[1]="-0.450133168824"/5 +#> MLTPL__2[2]="0.928826732655"/5 +#> MLTPL__2[3]="-0.690234137694"/5 +#> MLTPL__2[4]="-0.969064403627"/5 +#> MLTPL__2[5]="-3.732799178706"/5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.070926656551"/5 +#> MLTPL__1[1]="1.230112718540"/5 +#> MLTPL__1[2]="0.259947595154"/5 +#> MLTPL__2[0]="5.855948399631"/5 +#> MLTPL__2[1]="-0.436693047003"/5 +#> MLTPL__2[2]="1.083310879450"/5 +#> MLTPL__2[3]="-1.803239634808"/5 +#> MLTPL__2[4]="-1.025870541067"/5 +#> MLTPL__2[5]="-4.052708764823"/5 +#>> 42 +#>> 43 +#>> 44 +#>> 45 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.383960098284"/5 +#> MLTPL__1[1]="1.228462960557"/5 +#> MLTPL__1[2]="0.209695636116"/5 +#> MLTPL__2[0]="4.382388551340"/5 +#> MLTPL__2[1]="-0.477654531191"/5 +#> MLTPL__2[2]="0.970696842831"/5 +#> MLTPL__2[3]="-0.704398769096"/5 +#> MLTPL__2[4]="-1.132264392057"/5 +#> MLTPL__2[5]="-3.677989782245"/5 +#>> 46 +#> GRAD[0]="0.063120093085"/6 +#> GRAD[1]="0.015516432116"/6 +#> GRAD[2]="-0.008863107625"/6 +#> GRAD[3]="-0.064448529383"/6 +#> GRAD[4]="-0.000446376690"/6 +#> GRAD[5]="-0.007278479753"/6 +#> GRAD[6]="-0.021321884477"/6 +#> GRAD[7]="-0.043403999318"/6 +#> GRAD[8]="0.002486173163"/6 +#> GRAD[9]="-0.004184664879"/6 +#> GRAD[10]="0.035443345739"/6 +#> GRAD[11]="0.013383351938"/6 +#> GRAD[12]="0.019579176209"/6 +#> GRAD[13]="-0.010933180329"/6 +#> GRAD[14]="0.044140516983"/6 +#> GRAD[15]="0.007255809445"/6 +#> GRAD[16]="0.003823778483"/6 +#> GRAD[17]="-0.043868454707"/6 +#>> 47 +#>> 48 +#> EKIN="0.022744035944"/6 +#> EKIN="0.022744035944"/6 +#>> 50 +#> POTNUC="36.702924391329"/6 +#> SEWARD_MLTPL1X="-8.629857866851"/5 +#> SEWARD_KINETIC="16.578973779721"/5 +#> SEWARD_ATTRACT="-38.549522827873"/5 +#>> 51 +#> RASSCF_ITER="14"/8 +#> E_RASSCF[0]="-93.791857892775"/8 +#> E_RASSCF[1]="-93.708610939540"/8 +#> E_RASSCF[2]="-93.470584015759"/8 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.069165775181"/5 +#> MLTPL__1[1]="1.226342757574"/5 +#> MLTPL__1[2]="0.206813708908"/5 +#> MLTPL__2[0]="4.547625611025"/5 +#> MLTPL__2[1]="-0.556022667199"/5 +#> MLTPL__2[2]="0.994131645644"/5 +#> MLTPL__2[3]="-1.471968532761"/5 +#> MLTPL__2[4]="-0.419343668241"/5 +#> MLTPL__2[5]="-3.075657078264"/5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.441485041679"/5 +#> MLTPL__1[1]="1.262348700870"/5 +#> MLTPL__1[2]="0.209846334646"/5 +#> MLTPL__2[0]="4.320645416965"/5 +#> MLTPL__2[1]="-0.428995821535"/5 +#> MLTPL__2[2]="0.956755138562"/5 +#> MLTPL__2[3]="-0.664200609601"/5 +#> MLTPL__2[4]="-0.794304082155"/5 +#> MLTPL__2[5]="-3.656444807365"/5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.096613679447"/5 +#> MLTPL__1[1]="1.244177367605"/5 +#> MLTPL__1[2]="0.239717479119"/5 +#> MLTPL__2[0]="5.691224286922"/5 +#> MLTPL__2[1]="-0.434133747790"/5 +#> MLTPL__2[2]="1.210543010829"/5 +#> MLTPL__2[3]="-1.767147364525"/5 +#> MLTPL__2[4]="-0.850113396466"/5 +#> MLTPL__2[5]="-3.924076922397"/5 +#>> 52 +#>> 53 +#>> 54 +#>> 55 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.436660405600"/5 +#> MLTPL__1[1]="1.244323400643"/5 +#> MLTPL__1[2]="0.204280189038"/5 +#> MLTPL__2[0]="4.271783222185"/5 +#> MLTPL__2[1]="-0.440010833719"/5 +#> MLTPL__2[2]="0.964300465267"/5 +#> MLTPL__2[3]="-0.675642383750"/5 +#> MLTPL__2[4]="-0.946516905271"/5 +#> MLTPL__2[5]="-3.596140838435"/5 +#>> 56 +#> GRAD[0]="0.045022657945"/6 +#> GRAD[1]="0.011932687148"/6 +#> GRAD[2]="0.008185699893"/6 +#> GRAD[3]="-0.044090692471"/6 +#> GRAD[4]="-0.011260796587"/6 +#> GRAD[5]="-0.006517098184"/6 +#> GRAD[6]="-0.010857819841"/6 +#> GRAD[7]="-0.040387332023"/6 +#> GRAD[8]="-0.009633944156"/6 +#> GRAD[9]="-0.004022977193"/6 +#> GRAD[10]="0.035983909223"/6 +#> GRAD[11]="0.009082740276"/6 +#> GRAD[12]="0.009039129684"/6 +#> GRAD[13]="0.001951015913"/6 +#> GRAD[14]="0.042339406520"/6 +#> GRAD[15]="0.004909701876"/6 +#> GRAD[16]="0.001780516326"/6 +#> GRAD[17]="-0.043456804349"/6 +#>> 57 +#>> 58 +#> EKIN="0.031844490363"/6 +#> EKIN="0.031844490363"/6 +#>> 60 +#> POTNUC="36.820923184580"/6 +#> SEWARD_MLTPL1X="-8.638073215890"/5 +#> SEWARD_KINETIC="16.578973779721"/5 +#> SEWARD_ATTRACT="-38.547837073568"/5 +#>> 61 +#> RASSCF_ITER="13"/8 +#> E_RASSCF[0]="-93.784426651126"/8 +#> E_RASSCF[1]="-93.717366601621"/8 +#> E_RASSCF[2]="-93.473643127677"/8 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.040174409635"/5 +#> MLTPL__1[1]="1.228417280214"/5 +#> MLTPL__1[2]="0.203473543311"/5 +#> MLTPL__2[0]="4.398880196412"/5 +#> MLTPL__2[1]="-0.500710397157"/5 +#> MLTPL__2[2]="1.016551351837"/5 +#> MLTPL__2[3]="-1.479561028800"/5 +#> MLTPL__2[4]="-0.257488920328"/5 +#> MLTPL__2[5]="-2.919319167611"/5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.515175306166"/5 +#> MLTPL__1[1]="1.280633308185"/5 +#> MLTPL__1[2]="0.200042124213"/5 +#> MLTPL__2[0]="4.213790158243"/5 +#> MLTPL__2[1]="-0.405528783483"/5 +#> MLTPL__2[2]="0.989938348859"/5 +#> MLTPL__2[3]="-0.623236088585"/5 +#> MLTPL__2[4]="-0.586311213598"/5 +#> MLTPL__2[5]="-3.590554069657"/5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.129165665897"/5 +#> MLTPL__1[1]="1.256860401271"/5 +#> MLTPL__1[2]="0.223732364529"/5 +#> MLTPL__2[0]="5.517088239002"/5 +#> MLTPL__2[1]="-0.423822912605"/5 +#> MLTPL__2[2]="1.311857725022"/5 +#> MLTPL__2[3]="-1.738827357693"/5 +#> MLTPL__2[4]="-0.635935111395"/5 +#> MLTPL__2[5]="-3.778260881310"/5 +#>> 62 +#>> 63 +#>> 64 +#>> 65 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.507682185344"/5 +#> MLTPL__1[1]="1.261447199700"/5 +#> MLTPL__1[2]="0.195298748871"/5 +#> MLTPL__2[0]="4.156404963442"/5 +#> MLTPL__2[1]="-0.411169743440"/5 +#> MLTPL__2[2]="0.974374946139"/5 +#> MLTPL__2[3]="-0.633311193413"/5 +#> MLTPL__2[4]="-0.727724975002"/5 +#> MLTPL__2[5]="-3.523093770029"/5 +#>> 66 +#> GRAD[0]="0.022897928491"/6 +#> GRAD[1]="0.009017691659"/6 +#> GRAD[2]="0.026718353322"/6 +#> GRAD[3]="-0.020153284370"/6 +#> GRAD[4]="-0.025588023010"/6 +#> GRAD[5]="-0.005513486653"/6 +#> GRAD[6]="0.001399809101"/6 +#> GRAD[7]="-0.037327917719"/6 +#> GRAD[8]="-0.023743265449"/6 +#> GRAD[9]="-0.003641848995"/6 +#> GRAD[10]="0.036011411374"/6 +#> GRAD[11]="0.004776389614"/6 +#> GRAD[12]="-0.003193019992"/6 +#> GRAD[13]="0.017514573713"/6 +#> GRAD[14]="0.040544408629"/6 +#> GRAD[15]="0.002690415764"/6 +#> GRAD[16]="0.000372263983"/6 +#> GRAD[17]="-0.042782399462"/6 +#>> 67 +#>> 68 +#> EKIN="0.040578298975"/6 +#> EKIN="0.040578298975"/6 +#>> 70 +#> POTNUC="36.919900604659"/6 +#> SEWARD_MLTPL1X="-8.646707276381"/5 +#> SEWARD_KINETIC="16.578973779721"/5 +#> SEWARD_ATTRACT="-38.544886351880"/5 +#>> 71 +#> RASSCF_ITER="12"/8 +#> E_RASSCF[0]="-93.773811854563"/8 +#> E_RASSCF[1]="-93.725434982303"/8 +#> E_RASSCF[2]="-93.475667676035"/8 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-6.959697537877"/5 +#> MLTPL__1[1]="1.226789339984"/5 +#> MLTPL__1[2]="0.202793873120"/5 +#> MLTPL__2[0]="4.235593001872"/5 +#> MLTPL__2[1]="-0.459787510697"/5 +#> MLTPL__2[2]="1.023687766695"/5 +#> MLTPL__2[3]="-1.533016287323"/5 +#> MLTPL__2[4]="-0.093622608297"/5 +#> MLTPL__2[5]="-2.702576714549"/5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.638271604785"/5 +#> MLTPL__1[1]="1.298426561057"/5 +#> MLTPL__1[2]="0.187480912813"/5 +#> MLTPL__2[0]="4.108966847202"/5 +#> MLTPL__2[1]="-0.383240683696"/5 +#> MLTPL__2[2]="1.034139853502"/5 +#> MLTPL__2[3]="-0.541525286039"/5 +#> MLTPL__2[4]="-0.333873398433"/5 +#> MLTPL__2[5]="-3.567441561163"/5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.162225731310"/5 +#> MLTPL__1[1]="1.266497310912"/5 +#> MLTPL__1[2]="0.211992068263"/5 +#> MLTPL__2[0]="5.344888240256"/5 +#> MLTPL__2[1]="-0.419466963932"/5 +#> MLTPL__2[2]="1.387466857241"/5 +#> MLTPL__2[3]="-1.721293568803"/5 +#> MLTPL__2[4]="-0.385589477631"/5 +#> MLTPL__2[5]="-3.623594671452"/5 +#>> 72 +#>> 73 +#>> 74 +#>> 75 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.626012056442"/5 +#> MLTPL__1[1]="1.279123736128"/5 +#> MLTPL__1[2]="0.182253762120"/5 +#> MLTPL__2[0]="4.043764940721"/5 +#> MLTPL__2[1]="-0.392666346839"/5 +#> MLTPL__2[2]="1.003797104975"/5 +#> MLTPL__2[3]="-0.558900338073"/5 +#> MLTPL__2[4]="-0.465893442267"/5 +#> MLTPL__2[5]="-3.484864602648"/5 +#>> 76 +#> GRAD[0]="-0.003914216562"/6 +#> GRAD[1]="0.007383686196"/6 +#> GRAD[2]="0.044750685436"/6 +#> GRAD[3]="0.006600177271"/6 +#> GRAD[4]="-0.041657428691"/6 +#> GRAD[5]="-0.004740407267"/6 +#> GRAD[6]="0.014516227141"/6 +#> GRAD[7]="-0.034027795319"/6 +#> GRAD[8]="-0.038108990694"/6 +#> GRAD[9]="-0.002722823312"/6 +#> GRAD[10]="0.034703001733"/6 +#> GRAD[11]="0.000474037086"/6 +#> GRAD[12]="-0.015339825011"/6 +#> GRAD[13]="0.033371521798"/6 +#> GRAD[14]="0.038431377003"/6 +#> GRAD[15]="0.000860460472"/6 +#> GRAD[16]="0.000227014284"/6 +#> GRAD[17]="-0.040806701564"/6 +#>> 77 +#>> 78 +#> EKIN="0.048645491488"/6 +#> EKIN="0.048645491488"/6 +#>> 80 +#> POTNUC="36.974607660174"/6 +#> SEWARD_MLTPL1X="-8.655269761519"/5 +#> SEWARD_KINETIC="16.578973779721"/5 +#> SEWARD_ATTRACT="-38.539605378357"/5 +#>> 81 +#> RASSCF_ITER="12"/8 +#> E_RASSCF[0]="-93.762064040297"/8 +#> E_RASSCF[1]="-93.732695936539"/8 +#> E_RASSCF[2]="-93.477559374116"/8 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-6.736131909056"/5 +#> MLTPL__1[1]="1.216893630626"/5 +#> MLTPL__1[2]="0.209941525200"/5 +#> MLTPL__2[0]="4.062920413149"/5 +#> MLTPL__2[1]="-0.453786035394"/5 +#> MLTPL__2[2]="0.983655652545"/5 +#> MLTPL__2[3]="-1.718418085248"/5 +#> MLTPL__2[4]="0.015119073072"/5 +#> MLTPL__2[5]="-2.344502327901"/5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.898968418845"/5 +#> MLTPL__1[1]="1.316813573955"/5 +#> MLTPL__1[2]="0.168679280186"/5 +#> MLTPL__2[0]="4.011411357359"/5 +#> MLTPL__2[1]="-0.357059135500"/5 +#> MLTPL__2[2]="1.111631021006"/5 +#> MLTPL__2[3]="-0.338704135765"/5 +#> MLTPL__2[4]="0.017269936172"/5 +#> MLTPL__2[5]="-3.672707221594"/5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.190195654899"/5 +#> MLTPL__1[1]="1.271805642481"/5 +#> MLTPL__1[2]="0.204250219409"/5 +#> MLTPL__2[0]="5.183683528853"/5 +#> MLTPL__2[1]="-0.433333197593"/5 +#> MLTPL__2[2]="1.437005241571"/5 +#> MLTPL__2[3]="-1.718681374826"/5 +#> MLTPL__2[4]="-0.100878148833"/5 +#> MLTPL__2[5]="-3.465002154027"/5 +#>> 82 +#>> 83 +#>> 84 +#>> 85 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-6.724761207314"/5 +#> MLTPL__1[1]="1.213093617321"/5 +#> MLTPL__1[2]="0.225159225706"/5 +#> MLTPL__2[0]="3.898144149897"/5 +#> MLTPL__2[1]="-0.427819284098"/5 +#> MLTPL__2[2]="0.922101985036"/5 +#> MLTPL__2[3]="-1.559914972095"/5 +#> MLTPL__2[4]="0.131865772372"/5 +#> MLTPL__2[5]="-2.338229177802"/5 +#>> 86 +#> GRAD[0]="0.009220018063"/6 +#> GRAD[1]="-0.005033833407"/6 +#> GRAD[2]="0.056356605404"/6 +#> GRAD[3]="0.015517513994"/6 +#> GRAD[4]="-0.049098087215"/6 +#> GRAD[5]="-0.005978079107"/6 +#> GRAD[6]="0.022973514864"/6 +#> GRAD[7]="0.036681881953"/6 +#> GRAD[8]="-0.038627047277"/6 +#> GRAD[9]="-0.013151652281"/6 +#> GRAD[10]="-0.024619983896"/6 +#> GRAD[11]="-0.015168793709"/6 +#> GRAD[12]="-0.020377814283"/6 +#> GRAD[13]="0.054456279251"/6 +#> GRAD[14]="-0.028736028378"/6 +#> GRAD[15]="-0.014181580357"/6 +#> GRAD[16]="-0.012386256687"/6 +#> GRAD[17]="0.032153343068"/6 +#>> 87 +#>> 88 +#> EKIN="0.047646579177"/6 +#> EKIN="0.085274549481"/6 +#>> 90 +#> POTNUC="36.957406748592"/6 +#> SEWARD_MLTPL1X="-8.666921798345"/5 +#> SEWARD_KINETIC="16.578973779721"/5 +#> SEWARD_ATTRACT="-38.527767881394"/5 +#>> 91 +#> RASSCF_ITER="12"/8 +#> E_RASSCF[0]="-93.756272403651"/8 +#> E_RASSCF[1]="-93.733520590870"/8 +#> E_RASSCF[2]="-93.481973310355"/8 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-6.519918798856"/5 +#> MLTPL__1[1]="1.223072854075"/5 +#> MLTPL__1[2]="0.218312441085"/5 +#> MLTPL__2[0]="3.860586085817"/5 +#> MLTPL__2[1]="-0.488031293794"/5 +#> MLTPL__2[2]="0.884295639829"/5 +#> MLTPL__2[3]="-1.834837073606"/5 +#> MLTPL__2[4]="-0.018826031329"/5 +#> MLTPL__2[5]="-2.025749012211"/5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-8.153104152832"/5 +#> MLTPL__1[1]="1.311287869040"/5 +#> MLTPL__1[2]="0.147695750912"/5 +#> MLTPL__2[0]="3.854210547993"/5 +#> MLTPL__2[1]="-0.308322703757"/5 +#> MLTPL__2[2]="1.233984924443"/5 +#> MLTPL__2[3]="-0.190090319141"/5 +#> MLTPL__2[4]="0.607339104102"/5 +#> MLTPL__2[5]="-3.664120228852"/5 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-7.214388556146"/5 +#> MLTPL__1[1]="1.272990676257"/5 +#> MLTPL__1[2]="0.198566029071"/5 +#> MLTPL__2[0]="4.989625800481"/5 +#> MLTPL__2[1]="-0.469591900756"/5 +#> MLTPL__2[2]="1.463127399164"/5 +#> MLTPL__2[3]="-1.721092590559"/5 +#> MLTPL__2[4]="0.249452714286"/5 +#> MLTPL__2[5]="-3.268533209922"/5 +#>> 92 +#>> 93 +#>> 94 +#>> 95 +#> MLTPL__0="1"/5 +#> MLTPL__1[0]="-6.511001761062"/5 +#> MLTPL__1[1]="1.215746535098"/5 +#> MLTPL__1[2]="0.228456209451"/5 +#> MLTPL__2[0]="3.692088039507"/5 +#> MLTPL__2[1]="-0.447025720473"/5 +#> MLTPL__2[2]="0.818744218856"/5 +#> MLTPL__2[3]="-1.606411275444"/5 +#> MLTPL__2[4]="0.000388839855"/5 +#> MLTPL__2[5]="-2.085676764062"/5 +#>> 96 +#> GRAD[0]="0.009436544572"/6 +#> GRAD[1]="-0.001680541391"/6 +#> GRAD[2]="0.079850220570"/6 +#> GRAD[3]="0.020141668132"/6 +#> GRAD[4]="-0.063144177669"/6 +#> GRAD[5]="-0.014686446587"/6 +#> GRAD[6]="0.028144828999"/6 +#> GRAD[7]="-0.006418416561"/6 +#> GRAD[8]="-0.059176281890"/6 +#> GRAD[9]="-0.009701351022"/6 +#> GRAD[10]="0.013155447492"/6 +#> GRAD[11]="-0.011680717829"/6 +#> GRAD[12]="-0.036359782108"/6 +#> GRAD[13]="0.062284087105"/6 +#> GRAD[14]="0.017264618275"/6 +#> GRAD[15]="-0.011661908572"/6 +#> GRAD[16]="-0.004196398976"/6 +#> GRAD[17]="-0.011571392539"/6 +#>> 97 +#>> 98 +#> EKIN="0.080365528651"/6 +#> EKIN="0.080365528651"/6 +>>EOF diff -Nru openmolcas-22.02/test/additional/814.input openmolcas-22.10/test/additional/814.input --- openmolcas-22.02/test/additional/814.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/814.input 2022-10-10 14:22:40.000000000 +0000 @@ -74,6 +74,7 @@ >>> EOF >>> COPY C2H2.xyz . +>export MOLCAS_NOCHECK=SCF_ITER >>> FOREACH MOL in (IBN, NBD, COClH, C2H2) &GATEWAY @@ -101,291 +102,283 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.02-836-ge93ef98c5 -* Linux otis 4.15.0-1073-oem #83-Ubuntu SMP Mon Feb 17 11:21:18 UTC 2020 x86_64 x86_64 x86_64 GNU/Linux -* Mon Apr 19 13:00:13 2021 +* Molcas version 22.02-264-gd603c8837 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Thu Apr 28 17:00:45 2022 * #>> 1 #> POTNUC="119.665161245059"/12 #>> 2 #> POTNUC="119.665161245059"/12 #> SEWARD_MLTPL1X="1.991998102491"/5 -#> SEWARD_KINETIC="15.891121688446"/5 -#> SEWARD_ATTRACT="-40.607704797707"/5 +#> SEWARD_KINETIC="15.891121812396"/5 +#> SEWARD_ATTRACT="-40.607704929955"/5 #>> 3 -#> SCF_ITER="12"/8 -#> E_SCF="-154.228501927073"/4 -#> MLTPL__0="-0.000000000001"/2 -#> MLTPL__1[0]="-0.074655149300"/2 -#> MLTPL__1[1]="0.141222059056"/2 -#> MLTPL__1[2]="-0.049995640189"/2 -#> MLTPL__2[0]="0.464557747981"/2 -#> MLTPL__2[1]="0.216949579267"/2 -#> MLTPL__2[2]="-0.076811267768"/2 -#> MLTPL__2[3]="0.054076291510"/2 -#> MLTPL__2[4]="-0.231811716803"/2 -#> MLTPL__2[5]="-0.518634039491"/2 +#> E_SCF="-154.228501919371"/4 +#> MLTPL__0="-0.000000000000"/2 +#> MLTPL__1[0]="-0.074655214475"/2 +#> MLTPL__1[1]="0.141222087478"/2 +#> MLTPL__1[2]="-0.049995650079"/2 +#> MLTPL__2[0]="0.464557899909"/2 +#> MLTPL__2[1]="0.216949993460"/2 +#> MLTPL__2[2]="-0.076811414763"/2 +#> MLTPL__2[3]="0.054075966077"/2 +#> MLTPL__2[4]="-0.231811514258"/2 +#> MLTPL__2[5]="-0.518633865987"/2 #>> 4 -#> GRAD[0]="0.029005274869"/6 -#> GRAD[1]="0.003868933425"/6 -#> GRAD[2]="-0.001372139547"/6 -#> GRAD[3]="-0.032540703179"/6 -#> GRAD[4]="0.061706912049"/6 -#> GRAD[5]="-0.021843165975"/6 -#> GRAD[6]="0.021972103066"/6 -#> GRAD[7]="-0.033497735973"/6 -#> GRAD[8]="0.011858652447"/6 -#> GRAD[9]="-0.010661896965"/6 -#> GRAD[10]="-0.028954534520"/6 -#> GRAD[11]="0.010253050777"/6 -#> GRAD[12]="-0.004608342235"/6 -#> GRAD[13]="-0.005555985467"/6 -#> GRAD[14]="0.001967831431"/6 -#> GRAD[15]="-0.000087991915"/6 -#> GRAD[16]="-0.001888584395"/6 -#> GRAD[17]="-0.004919461989"/6 -#> GRAD[18]="-0.000087756998"/6 -#> GRAD[19]="0.001626836448"/6 -#> GRAD[20]="0.005012721851"/6 -#> GRAD[21]="-0.003077112342"/6 -#> GRAD[22]="-0.002700510248"/6 -#> GRAD[23]="0.000955917251"/6 -#> GRAD[24]="0.003619109871"/6 -#> GRAD[25]="0.001373987391"/6 -#> GRAD[26]="-0.000486672432"/6 -#> GRAD[27]="-0.004372868633"/6 -#> GRAD[28]="0.005167390948"/6 -#> GRAD[29]="-0.001829544679"/6 -#> GRAD[30]="0.000421248479"/6 -#> GRAD[31]="-0.002655804123"/6 -#> GRAD[32]="-0.005682440813"/6 -#> GRAD[33]="0.000418935982"/6 -#> GRAD[34]="0.001509094466"/6 -#> GRAD[35]="0.006085251678"/6 +#> GRAD[0]="0.029005152623"/6 +#> GRAD[1]="0.003868950933"/6 +#> GRAD[2]="-0.001372145633"/6 +#> GRAD[3]="-0.032540681160"/6 +#> GRAD[4]="0.061706843444"/6 +#> GRAD[5]="-0.021843141697"/6 +#> GRAD[6]="0.021972057453"/6 +#> GRAD[7]="-0.033497645194"/6 +#> GRAD[8]="0.011858620333"/6 +#> GRAD[9]="-0.010661782064"/6 +#> GRAD[10]="-0.028954451632"/6 +#> GRAD[11]="0.010253021494"/6 +#> GRAD[12]="-0.004608317560"/6 +#> GRAD[13]="-0.005555924297"/6 +#> GRAD[14]="0.001967809697"/6 +#> GRAD[15]="-0.000087966451"/6 +#> GRAD[16]="-0.001888603574"/6 +#> GRAD[17]="-0.004919384009"/6 +#> GRAD[18]="-0.000087731661"/6 +#> GRAD[19]="0.001626772465"/6 +#> GRAD[20]="0.005012673233"/6 +#> GRAD[21]="-0.003077131700"/6 +#> GRAD[22]="-0.002700558517"/6 +#> GRAD[23]="0.000955934320"/6 +#> GRAD[24]="0.003619166592"/6 +#> GRAD[25]="0.001373973397"/6 +#> GRAD[26]="-0.000486667461"/6 +#> GRAD[27]="-0.004372842732"/6 +#> GRAD[28]="0.005167343722"/6 +#> GRAD[29]="-0.001829527960"/6 +#> GRAD[30]="0.000421194589"/6 +#> GRAD[31]="-0.002655777967"/6 +#> GRAD[32]="-0.005682381085"/6 +#> GRAD[33]="0.000418882071"/6 +#> GRAD[34]="0.001509077220"/6 +#> GRAD[35]="0.006085188767"/6 #>> 5 #> GEO_ITER="1"/8 -#> POTNUC="119.446406451287"/6 -#> SEWARD_MLTPL1X="1.965749946785"/5 -#> SEWARD_KINETIC="15.891121688446"/5 -#> SEWARD_ATTRACT="-40.563395963274"/5 -#> SCF_ITER="10"/8 -#> E_SCF="-154.231793363608"/4 +#> POTNUC="119.446406507354"/6 +#> SEWARD_MLTPL1X="1.965749982336"/5 +#> SEWARD_KINETIC="15.891121812396"/5 +#> SEWARD_ATTRACT="-40.563396083425"/5 +#> E_SCF="-154.231793354852"/4 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="-0.069441942693"/2 -#> MLTPL__1[1]="0.135034045261"/2 -#> MLTPL__1[2]="-0.047804250674"/2 -#> MLTPL__2[0]="0.537972002014"/2 -#> MLTPL__2[1]="0.211382662790"/2 -#> MLTPL__2[2]="-0.074830619490"/2 -#> MLTPL__2[3]="0.103299325122"/2 -#> MLTPL__2[4]="-0.301360041741"/2 -#> MLTPL__2[5]="-0.641271327136"/2 +#> MLTPL__1[0]="-0.069442166079"/2 +#> MLTPL__1[1]="0.135034214930"/2 +#> MLTPL__1[2]="-0.047804311449"/2 +#> MLTPL__2[0]="0.537972470564"/2 +#> MLTPL__2[1]="0.211383152656"/2 +#> MLTPL__2[2]="-0.074830790130"/2 +#> MLTPL__2[3]="0.103298387754"/2 +#> MLTPL__2[4]="-0.301359477019"/2 +#> MLTPL__2[5]="-0.641270858318"/2 #>> 6 #>> 8 #> POTNUC="455.543841446757"/12 #>> 9 #> POTNUC="455.543841446757"/12 #> SEWARD_MLTPL1X="2.327159927954"/5 -#> SEWARD_KINETIC="15.891121688446"/5 -#> SEWARD_ATTRACT="-47.414988267473"/5 +#> SEWARD_KINETIC="15.891121812396"/5 +#> SEWARD_ATTRACT="-47.414988399721"/5 #>> 10 -#> SCF_ITER="21"/8 -#> E_SCF="-343.546572785138"/4 +#> E_SCF="-343.546572773411"/4 #> MLTPL__0="-0.000000000003"/2 -#> MLTPL__1[0]="0.000000000015"/2 -#> MLTPL__1[1]="-0.000000000123"/2 -#> MLTPL__1[2]="0.060727410127"/2 -#> MLTPL__2[0]="-0.456582236322"/2 -#> MLTPL__2[1]="-0.000000001500"/2 -#> MLTPL__2[2]="-0.000000000238"/2 -#> MLTPL__2[3]="1.337630293243"/2 -#> MLTPL__2[4]="0.000000000628"/2 -#> MLTPL__2[5]="-0.881048056922"/2 +#> MLTPL__1[0]="0.000000000039"/2 +#> MLTPL__1[1]="-0.000000003302"/2 +#> MLTPL__1[2]="0.060727392674"/2 +#> MLTPL__2[0]="-0.456582195015"/2 +#> MLTPL__2[1]="0.000000000877"/2 +#> MLTPL__2[2]="-0.000000000334"/2 +#> MLTPL__2[3]="1.337630155300"/2 +#> MLTPL__2[4]="0.000000008103"/2 +#> MLTPL__2[5]="-0.881047960285"/2 #>> 11 -#> GRAD[0]="-0.004183611008"/6 -#> GRAD[1]="0.037938829947"/6 -#> GRAD[2]="0.004558663197"/6 -#> GRAD[3]="-0.000000000101"/6 -#> GRAD[4]="-0.005618783636"/6 -#> GRAD[5]="-0.011446634291"/6 -#> GRAD[6]="0.000000000036"/6 -#> GRAD[7]="0.005618784378"/6 -#> GRAD[8]="-0.011446633903"/6 -#> GRAD[9]="-0.004183612322"/6 -#> GRAD[10]="-0.037938829447"/6 -#> GRAD[11]="0.004558664372"/6 -#> GRAD[12]="-0.000000000096"/6 -#> GRAD[13]="-0.000000000218"/6 -#> GRAD[14]="0.021956066770"/6 -#> GRAD[15]="0.004183611162"/6 -#> GRAD[16]="0.037938829854"/6 -#> GRAD[17]="0.004558663261"/6 -#> GRAD[18]="0.004183611836"/6 -#> GRAD[19]="-0.037938829779"/6 -#> GRAD[20]="0.004558663692"/6 -#> GRAD[21]="-0.000000000004"/6 -#> GRAD[22]="0.002668966526"/6 -#> GRAD[23]="0.001494195214"/6 -#> GRAD[24]="-0.000000000003"/6 -#> GRAD[25]="-0.002668966535"/6 -#> GRAD[26]="0.001494195226"/6 -#> GRAD[27]="-0.001562312177"/6 -#> GRAD[28]="-0.000628185009"/6 -#> GRAD[29]="-0.001704002164"/6 -#> GRAD[30]="-0.001562311245"/6 -#> GRAD[31]="0.000628184149"/6 -#> GRAD[32]="-0.001704001077"/6 -#> GRAD[33]="0.001562311243"/6 -#> GRAD[34]="-0.000628184142"/6 -#> GRAD[35]="-0.001704000626"/6 -#> GRAD[36]="0.001562311634"/6 -#> GRAD[37]="0.000628184462"/6 -#> GRAD[38]="-0.001704001368"/6 -#> GRAD[39]="-0.015032109449"/6 -#> GRAD[40]="0.000000000398"/6 -#> GRAD[41]="-0.016819006947"/6 -#> GRAD[42]="-0.000199675301"/6 -#> GRAD[43]="-0.005737067930"/6 -#> GRAD[44]="0.006039861269"/6 -#> GRAD[45]="0.005193831691"/6 -#> GRAD[46]="-0.000000000238"/6 -#> GRAD[47]="-0.001995635316"/6 -#> GRAD[48]="-0.000199674837"/6 -#> GRAD[49]="0.005737068008"/6 -#> GRAD[50]="0.006039862015"/6 -#> GRAD[51]="0.015032109026"/6 -#> GRAD[52]="0.000000000459"/6 -#> GRAD[53]="-0.016819006103"/6 -#> GRAD[54]="0.000199676477"/6 -#> GRAD[55]="0.005737067124"/6 -#> GRAD[56]="0.006039860266"/6 -#> GRAD[57]="-0.005193831551"/6 -#> GRAD[58]="-0.000000000261"/6 -#> GRAD[59]="-0.001995635363"/6 -#> GRAD[60]="0.000199674990"/6 -#> GRAD[61]="-0.005737068110"/6 -#> GRAD[62]="0.006039861877"/6 +#> GRAD[0]="-0.004183609961"/6 +#> GRAD[1]="0.037938833960"/6 +#> GRAD[2]="0.004558662562"/6 +#> GRAD[3]="0.000000000173"/6 +#> GRAD[4]="-0.005618780991"/6 +#> GRAD[5]="-0.011446631065"/6 +#> GRAD[6]="0.000000000081"/6 +#> GRAD[7]="0.005618781068"/6 +#> GRAD[8]="-0.011446630866"/6 +#> GRAD[9]="-0.004183609787"/6 +#> GRAD[10]="-0.037938832466"/6 +#> GRAD[11]="0.004558662427"/6 +#> GRAD[12]="-0.000000000236"/6 +#> GRAD[13]="0.000000000466"/6 +#> GRAD[14]="0.021956066308"/6 +#> GRAD[15]="0.004183609531"/6 +#> GRAD[16]="0.037938834213"/6 +#> GRAD[17]="0.004558661996"/6 +#> GRAD[18]="0.004183609636"/6 +#> GRAD[19]="-0.037938832510"/6 +#> GRAD[20]="0.004558662273"/6 +#> GRAD[21]="-0.000000000012"/6 +#> GRAD[22]="0.002668966828"/6 +#> GRAD[23]="0.001494195155"/6 +#> GRAD[24]="-0.000000000006"/6 +#> GRAD[25]="-0.002668968512"/6 +#> GRAD[26]="0.001494195712"/6 +#> GRAD[27]="-0.001562314432"/6 +#> GRAD[28]="-0.000628186834"/6 +#> GRAD[29]="-0.001704004479"/6 +#> GRAD[30]="-0.001562312567"/6 +#> GRAD[31]="0.000628185424"/6 +#> GRAD[32]="-0.001704003111"/6 +#> GRAD[33]="0.001562312914"/6 +#> GRAD[34]="-0.000628185688"/6 +#> GRAD[35]="-0.001704002500"/6 +#> GRAD[36]="0.001562311561"/6 +#> GRAD[37]="0.000628184488"/6 +#> GRAD[38]="-0.001704001506"/6 +#> GRAD[39]="-0.015032106809"/6 +#> GRAD[40]="-0.000000000303"/6 +#> GRAD[41]="-0.016819005231"/6 +#> GRAD[42]="-0.000199675014"/6 +#> GRAD[43]="-0.005737069122"/6 +#> GRAD[44]="0.006039862853"/6 +#> GRAD[45]="0.005193832810"/6 +#> GRAD[46]="0.000000000257"/6 +#> GRAD[47]="-0.001995635809"/6 +#> GRAD[48]="-0.000199674539"/6 +#> GRAD[49]="0.005737069564"/6 +#> GRAD[50]="0.006039863340"/6 +#> GRAD[51]="0.015032106325"/6 +#> GRAD[52]="-0.000000000380"/6 +#> GRAD[53]="-0.016819004532"/6 +#> GRAD[54]="0.000199676116"/6 +#> GRAD[55]="0.005737068518"/6 +#> GRAD[56]="0.006039861334"/6 +#> GRAD[57]="-0.005193832465"/6 +#> GRAD[58]="0.000000000240"/6 +#> GRAD[59]="-0.001995635924"/6 +#> GRAD[60]="0.000199676679"/6 +#> GRAD[61]="-0.005737068220"/6 +#> GRAD[62]="0.006039861062"/6 #>> 12 #> GEO_ITER="1"/8 -#> POTNUC="456.099291360813"/6 -#> SEWARD_MLTPL1X="2.328658133284"/5 -#> SEWARD_KINETIC="15.891121688446"/5 -#> SEWARD_ATTRACT="-47.462646104682"/5 -#> SCF_ITER="12"/8 -#> E_SCF="-343.549439311997"/4 -#> MLTPL__0="-0.000000000001"/2 -#> MLTPL__1[0]="-0.000000079063"/2 -#> MLTPL__1[1]="-0.000000002711"/2 -#> MLTPL__1[2]="0.058853196695"/2 -#> MLTPL__2[0]="-0.392194901316"/2 -#> MLTPL__2[1]="0.000003515082"/2 -#> MLTPL__2[2]="0.000002570894"/2 -#> MLTPL__2[3]="1.375772241057"/2 -#> MLTPL__2[4]="-0.000000019037"/2 -#> MLTPL__2[5]="-0.983577339741"/2 +#> POTNUC="456.099292314631"/6 +#> SEWARD_MLTPL1X="2.328658133101"/5 +#> SEWARD_KINETIC="15.891121812396"/5 +#> SEWARD_ATTRACT="-47.462646251361"/5 +#> E_SCF="-343.549439300593"/4 +#> MLTPL__0="-0.000000000002"/2 +#> MLTPL__1[0]="-0.000000082371"/2 +#> MLTPL__1[1]="-0.000000002426"/2 +#> MLTPL__1[2]="0.058853182499"/2 +#> MLTPL__2[0]="-0.392194850416"/2 +#> MLTPL__2[1]="0.000003538177"/2 +#> MLTPL__2[2]="0.000002513803"/2 +#> MLTPL__2[3]="1.375772115923"/2 +#> MLTPL__2[4]="-0.000000036421"/2 +#> MLTPL__2[5]="-0.983577265507"/2 #>> 13 #>> 15 #> POTNUC="79.869759268972"/12 #>> 16 #> POTNUC="79.869759268972"/12 #> SEWARD_MLTPL1X="-0.689750035488"/5 -#> SEWARD_KINETIC="29.003199945540"/5 -#> SEWARD_ATTRACT="-66.545073390211"/5 +#> SEWARD_KINETIC="29.003204064678"/5 +#> SEWARD_ATTRACT="-66.545077670084"/5 #>> 17 -#> SCF_ITER="18"/8 -#> E_SCF="-566.265850508875"/4 +#> E_SCF="-566.265859659525"/4 #> MLTPL__0="-0.000000000001"/2 -#> MLTPL__1[0]="-1.013850685159"/2 +#> MLTPL__1[0]="-1.013849043305"/2 #> MLTPL__1[1]="0.0"/2 -#> MLTPL__1[2]="-0.124084970986"/2 -#> MLTPL__2[0]="-0.798453125992"/2 +#> MLTPL__1[2]="-0.124084673434"/2 +#> MLTPL__2[0]="-0.798452917768"/2 #> MLTPL__2[1]="0.0"/2 -#> MLTPL__2[2]="-1.580841306629"/2 -#> MLTPL__2[3]="1.635656617976"/2 +#> MLTPL__2[2]="-1.580840904215"/2 +#> MLTPL__2[3]="1.635657246965"/2 #> MLTPL__2[4]="0.0"/2 -#> MLTPL__2[5]="-0.837203491983"/2 +#> MLTPL__2[5]="-0.837204329196"/2 #>> 18 -#> GRAD[0]="0.013521893293"/6 +#> GRAD[0]="0.013521880914"/6 #> GRAD[1]="0.0"/6 -#> GRAD[2]="0.059266252370"/6 -#> GRAD[3]="0.086564110887"/6 +#> GRAD[2]="0.059266317148"/6 +#> GRAD[3]="0.086564205065"/6 #> GRAD[4]="0.0"/6 -#> GRAD[5]="-0.019470578996"/6 -#> GRAD[6]="-0.296875450840"/6 +#> GRAD[5]="-0.019470612864"/6 +#> GRAD[6]="-0.296875209612"/6 #> GRAD[7]="0.0"/6 -#> GRAD[8]="0.010018855194"/6 -#> GRAD[9]="0.196789446660"/6 +#> GRAD[8]="0.010018783827"/6 +#> GRAD[9]="0.196789123633"/6 #> GRAD[10]="0.0"/6 -#> GRAD[11]="-0.049814528568"/6 +#> GRAD[11]="-0.049814488111"/6 #>> 19 #> GEO_ITER="1"/8 -#> POTNUC="76.622629313293"/6 -#> SEWARD_MLTPL1X="-0.720482599838"/5 -#> SEWARD_KINETIC="29.003199945540"/5 -#> SEWARD_ATTRACT="-66.399531296653"/5 -#> SCF_ITER="11"/8 -#> E_SCF="-566.320165071945"/4 +#> POTNUC="76.622628581008"/6 +#> SEWARD_MLTPL1X="-0.720482286794"/5 +#> SEWARD_KINETIC="29.003204064678"/5 +#> SEWARD_ATTRACT="-66.399535513626"/5 +#> E_SCF="-566.320174186345"/4 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="-1.067184371979"/2 +#> MLTPL__1[0]="-1.067182657620"/2 #> MLTPL__1[1]="0.0"/2 -#> MLTPL__1[2]="-0.047896182356"/2 -#> MLTPL__2[0]="-0.652333974130"/2 +#> MLTPL__1[2]="-0.047895989951"/2 +#> MLTPL__2[0]="-0.652331984670"/2 #> MLTPL__2[1]="0.0"/2 -#> MLTPL__2[2]="-1.646053077992"/2 -#> MLTPL__2[3]="1.474725279863"/2 +#> MLTPL__2[2]="-1.646051912313"/2 +#> MLTPL__2[3]="1.474725411439"/2 #> MLTPL__2[4]="0.0"/2 -#> MLTPL__2[5]="-0.822391305732"/2 +#> MLTPL__2[5]="-0.822393426769"/2 #>> 20 #>> 22 #> POTNUC="24.577260976621"/12 #>> 23 #> POTNUC="24.577260976621"/12 #> SEWARD_MLTPL1X="-0.826337172105"/5 -#> SEWARD_KINETIC="15.891121688446"/5 -#> SEWARD_ATTRACT="-37.075247628264"/5 +#> SEWARD_KINETIC="15.891121812396"/5 +#> SEWARD_ATTRACT="-37.075247760512"/5 #>> 24 -#> SCF_ITER="17"/8 -#> E_SCF="-75.744012100381"/4 +#> E_SCF="-75.744012083156"/4 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="0.163634836727"/2 -#> MLTPL__1[1]="-0.910481003156"/2 -#> MLTPL__1[2]="0.144999107970"/2 -#> MLTPL__2[0]="0.185127961794"/2 -#> MLTPL__2[1]="-0.470081653051"/2 -#> MLTPL__2[2]="-0.827751182631"/2 -#> MLTPL__2[3]="-0.397130977169"/2 -#> MLTPL__2[4]="0.496158449215"/2 -#> MLTPL__2[5]="0.212003015375"/2 +#> MLTPL__1[0]="0.163634815682"/2 +#> MLTPL__1[1]="-0.910480943689"/2 +#> MLTPL__1[2]="0.144999111389"/2 +#> MLTPL__2[0]="0.185127978719"/2 +#> MLTPL__2[1]="-0.470081635368"/2 +#> MLTPL__2[2]="-0.827751130048"/2 +#> MLTPL__2[3]="-0.397130990906"/2 +#> MLTPL__2[4]="0.496158456785"/2 +#> MLTPL__2[5]="0.212003012187"/2 #>> 25 -#> GRAD[0]="-0.017450195370"/6 -#> GRAD[1]="-0.000587433564"/6 -#> GRAD[2]="0.021894654087"/6 -#> GRAD[3]="0.019687633378"/6 -#> GRAD[4]="-0.008294321213"/6 -#> GRAD[5]="-0.021276746838"/6 -#> GRAD[6]="0.005908833323"/6 -#> GRAD[7]="-0.011774283194"/6 -#> GRAD[8]="-0.002834652401"/6 -#> GRAD[9]="-0.008146271331"/6 -#> GRAD[10]="0.020656037972"/6 -#> GRAD[11]="0.002216745152"/6 +#> GRAD[0]="-0.017450193269"/6 +#> GRAD[1]="-0.000587434875"/6 +#> GRAD[2]="0.021894652325"/6 +#> GRAD[3]="0.019687631347"/6 +#> GRAD[4]="-0.008294312546"/6 +#> GRAD[5]="-0.021276748107"/6 +#> GRAD[6]="0.005908832050"/6 +#> GRAD[7]="-0.011774285406"/6 +#> GRAD[8]="-0.002834649860"/6 +#> GRAD[9]="-0.008146270128"/6 +#> GRAD[10]="0.020656032827"/6 +#> GRAD[11]="0.002216745642"/6 #>> 26 #> GEO_ITER="1"/8 -#> POTNUC="24.652843644234"/6 -#> SEWARD_MLTPL1X="-0.823548520234"/5 -#> SEWARD_KINETIC="15.891121688446"/5 -#> SEWARD_ATTRACT="-37.098320182210"/5 -#> SCF_ITER="10"/8 -#> E_SCF="-75.746073239920"/4 +#> POTNUC="24.652843704168"/6 +#> SEWARD_MLTPL1X="-0.823548512633"/5 +#> SEWARD_KINETIC="15.891121812396"/5 +#> SEWARD_ATTRACT="-37.098320320996"/5 +#> E_SCF="-75.746073222305"/4 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="0.166525884057"/2 -#> MLTPL__1[1]="-0.893003096626"/2 -#> MLTPL__1[2]="0.134774093949"/2 -#> MLTPL__2[0]="0.212739114281"/2 -#> MLTPL__2[1]="-0.534125756721"/2 -#> MLTPL__2[2]="-0.838553222962"/2 -#> MLTPL__2[3]="-0.405933435430"/2 -#> MLTPL__2[4]="0.578581577616"/2 -#> MLTPL__2[5]="0.193194321148"/2 +#> MLTPL__1[0]="0.166525776284"/2 +#> MLTPL__1[1]="-0.893002927826"/2 +#> MLTPL__1[2]="0.134774163459"/2 +#> MLTPL__2[0]="0.212739532444"/2 +#> MLTPL__2[1]="-0.534126318225"/2 +#> MLTPL__2[2]="-0.838553339872"/2 +#> MLTPL__2[3]="-0.405933803531"/2 +#> MLTPL__2[4]="0.578582479479"/2 +#> MLTPL__2[5]="0.193194271086"/2 #>> 27 >>EOF diff -Nru openmolcas-22.02/test/additional/820.input openmolcas-22.10/test/additional/820.input --- openmolcas-22.02/test/additional/820.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/820.input 2022-10-10 14:22:40.000000000 +0000 @@ -10,6 +10,7 @@ *> EXIT 36 *> ENDIF +>>> COPY $Project.RasOrb . &SEWARD &END Title @@ -25,20 +26,8 @@ End Of Input - &RASSCF &END -Title - C2 singlet GS -Spin - 1 -Nactel - 6 0 0 -Inactive - 3 -Ras2 - 6 -End Of Input - &SCF &END +FileOrb=$Project.RasOrb Title C2 singlet Constrained UHF @@ -55,11 +44,243 @@ pbe End Of Input +>>FILE $Project.RasOrb +#INPORB 2.2 +#INFO +* RASSCF average (pseudo-natural) orbitals + 0 1 0 + 28 + 28 +*BC:HOST lucifer PID 18197 DATE Wed Feb 23 12:53:59 2022 +#EXTRAS +* ACTIVE TWO-EL ENERGY + 0.646775354471E+01 +#ORB +* ORBITAL 1 1 + 7.06057928775362E-01 2.18583844196132E-03 -1.02581974201762E-03 9.75364726712743E-17 -5.61534022042669E-16 + -3.76981761333555E-17 2.05669522695593E-16 2.44160662152443E-03 -8.64589004751824E-04 -1.99015778531763E-17 + -7.31738519435412E-17 1.38104101096600E-03 -1.29178010140831E-16 -9.24601620105388E-17 7.06057928879689E-01 + 2.18583843969283E-03 -1.02581974150678E-03 -3.46893042851681E-16 7.89837148360604E-16 5.16928257712838E-16 + -8.12259996369448E-16 -2.44160661953873E-03 8.64589003861806E-04 -8.34333718565161E-18 -5.56797063703338E-17 + 1.38104101038384E-03 -1.71052660460195E-16 5.08022032817395E-18 +* ORBITAL 1 2 + -7.09118014683015E-01 -5.23602750250908E-03 1.77413255871764E-02 -1.83334043667248E-16 1.72358253611459E-16 + -5.06821674120653E-16 1.10136234390099E-15 -1.94593360149345E-03 5.70064999733337E-03 -1.54285037930037E-18 + 1.90114652746872E-16 2.34027861682729E-05 -1.94557329800498E-16 -1.83973016776103E-17 7.09118014578552E-01 + 5.23602750303999E-03 -1.77413255878742E-02 2.35276708728466E-16 -3.86766173714104E-16 5.15089534488892E-17 + -8.61004380856523E-16 -1.94593360063438E-03 5.70064999667995E-03 5.46754125797806E-17 1.68203852836962E-16 + -2.34027864646071E-05 -1.13329753505675E-16 3.71084179411152E-17 +* ORBITAL 1 3 + -4.46597058187393E-02 6.36651751803211E-01 -2.05752254302225E-01 -1.84276516515287E-15 7.23125551486718E-15 + 9.01968923953011E-16 -1.78599818192452E-15 3.72164392198873E-01 -1.41704820011923E-01 -2.79551459725736E-16 + 5.42538827542092E-17 2.68309682743121E-02 1.98178526656771E-15 -1.19452863373299E-15 -4.46597058174461E-02 + 6.36651751804419E-01 -2.05752254348756E-01 1.63902998331913E-15 -7.01302528090728E-15 -6.68871581042587E-16 + 1.54301812087235E-15 -3.72164392207295E-01 1.41704820037720E-01 -2.94339453392576E-16 -1.22895006329149E-17 + 2.68309682733830E-02 2.16252281363455E-15 -1.23496829092151E-15 +* ORBITAL 1 4 + 1.31429752011800E-15 4.71412802671964E-15 -4.35608830678771E-15 1.47815410287177E-01 -2.32069946546105E-02 + 6.50390320896087E-01 -1.02111171434180E-01 2.22782954158142E-15 2.10927122618185E-18 8.02351438842020E-17 + 2.98671775120211E-02 1.48829625396070E-15 6.78796863393774E-03 3.55752996997702E-17 -1.26335732114360E-15 + -5.10891012136930E-15 4.17149390724945E-15 1.47815410287441E-01 -2.32069946550838E-02 6.50390320897251E-01 + -1.02111171436238E-01 1.50781195934216E-15 -1.04073962283154E-16 2.45365479725603E-16 -2.98671775123395E-02 + -1.51965458687807E-15 -6.78796863400997E-03 4.41347963165932E-17 +* ORBITAL 1 5 + 5.60358328208122E-16 1.95462053240900E-15 -2.23492563697661E-15 6.50390320896084E-01 -1.02111171434170E-01 + -1.47815410287176E-01 2.32069946546131E-02 1.00119128291912E-15 -4.82897448560220E-16 6.52536058038433E-16 + -6.78796863393721E-03 3.88146089186375E-16 2.98671775120221E-02 -3.73309772325734E-17 9.70636656243724E-17 + 4.09767824351959E-16 -7.89181067368901E-16 6.50390320897259E-01 -1.02111171436252E-01 -1.47815410287442E-01 + 2.32069946550816E-02 -4.11516822840535E-16 2.45018918507162E-16 5.96204812701980E-18 6.78796863401030E-03 + -7.82195960930695E-16 -2.98671775123382E-02 8.51066754328852E-17 +* ORBITAL 1 6 + -6.87499471159164E-03 -6.24909699977130E-01 -4.13798626410280E-02 -9.46800276808364E-16 4.21362641630615E-16 + -9.23058232501444E-16 4.34483634758607E-16 3.75581521667846E-01 -3.81500021645533E-02 -6.36315945455775E-17 + -1.29658672769607E-16 -1.13871007216795E-02 -8.83614664425616E-17 1.97514193404662E-16 6.87499471053462E-03 + 6.24909699975853E-01 4.13798626448211E-02 -4.84657441444266E-16 8.81342541129263E-16 -1.78827384282603E-15 + 1.35489500704623E-15 3.75581521663066E-01 -3.81500021592246E-02 -5.41808453413268E-17 6.80582675943292E-16 + 1.13871007221110E-02 5.77918858079994E-16 -2.24253609998427E-16 +* ORBITAL 1 7 + 3.78171365226697E-02 3.65774106401774E-01 6.00875354007577E-02 1.26528730001589E-15 -3.85232427456071E-15 + 5.78566849005840E-16 6.48265185838245E-16 -7.24171951930589E-01 1.38402495044377E-01 2.70672068749767E-16 + 1.38148923510424E-16 6.24130571676087E-03 -1.06842869864631E-15 5.96068868911677E-16 3.78171365219331E-02 + 3.65774106399402E-01 6.00875354273898E-02 2.34054492042317E-16 3.60248454934335E-15 -3.79170243660356E-16 + -3.58387193691399E-16 7.24171951924718E-01 -1.38402495049729E-01 1.56052676762211E-16 2.47704026165465E-16 + 6.24130571771732E-03 -1.24111079614240E-15 4.96875024289180E-16 +* ORBITAL 1 8 + 1.70587942267124E-15 7.05081998590550E-15 -1.48842364260597E-14 -9.64153343144104E-01 1.32712037569505E-01 + 1.73388783487103E-01 -2.38663060309796E-02 1.40982831397344E-15 -3.48409834870067E-15 -2.96480297872944E-16 + -1.39837885913754E-02 4.31759902849255E-16 7.77588737232079E-02 5.16021229812806E-17 -1.46180409593912E-15 + -6.79224122911421E-15 1.37722545264233E-14 9.64153343147985E-01 -1.32712037574049E-01 -1.73388783487799E-01 + 2.38663060317951E-02 2.33548158124158E-15 -6.09931532405860E-15 5.19915366562052E-16 -1.39837885912951E-02 + -1.10818239234382E-15 7.77588737227613E-02 3.93461122890170E-17 +* ORBITAL 1 9 + 6.34435126638571E-16 2.22904219137103E-15 8.68837189337870E-15 -1.73388783487105E-01 2.38663060309808E-02 + -9.64153343144105E-01 1.32712037569509E-01 1.30149989618090E-15 2.85864573769978E-15 -2.30080961123854E-16 + 7.77588737232091E-02 3.15480456933079E-16 1.39837885913737E-02 -1.16932134280242E-16 2.63467976255065E-16 + 7.99210680981313E-16 -1.07699488535592E-14 1.73388783487802E-01 -2.38663060317968E-02 9.64153343147977E-01 + -1.32712037574041E-01 1.63894664761491E-15 4.20725034830013E-15 4.82089755443291E-16 7.77588737227626E-02 + -1.58359432931967E-15 1.39837885912931E-02 -1.00283692014137E-16 +* ORBITAL 1 10 + -3.59026933492417E-02 2.29091061761904E-01 7.09464730687681E+00 -2.30421872090027E-16 1.06095611716288E-16 + -4.13971249618446E-16 1.06501956425572E-15 -7.80584334555581E-02 3.58976298709376E+00 8.94692133731146E-18 + 2.08203698499275E-17 8.93533993097708E-02 -2.11271064958146E-18 -4.67918666900732E-16 3.59026933498664E-02 + -2.29091061765332E-01 -7.09464730687553E+00 -3.22582183068357E-17 2.33233750460903E-16 -5.54625235546653E-16 + -6.85918055767593E-16 -7.80584334552523E-02 3.58976298709656E+00 2.93208394044516E-18 2.94349897401578E-17 + -8.93533993099183E-02 -7.43818935737153E-18 3.07974491876378E-16 +* ORBITAL 1 11 + 1.19462819824631E-01 4.08830052792145E-01 -9.98835599767554E-02 -3.94829090739202E-16 -1.35587744136298E-15 + -9.83000556415405E-17 1.01228819068420E-15 6.58327088803680E-01 -1.48926159886665E+00 -1.15512394795211E-16 + -2.05042454569518E-17 -2.25599293097102E-02 -1.72526903468612E-17 -8.06531573898994E-17 1.19462819824975E-01 + 4.08830052791502E-01 -9.98835599595136E-02 4.56916420867999E-16 1.23086109440870E-15 -7.19791988664867E-17 + -6.22309117851802E-16 -6.58327088805171E-01 1.48926159885801E+00 3.18228467212472E-17 1.06464827515270E-16 + -2.25599293092917E-02 2.46953875901797E-17 -2.71451502126670E-17 +* ORBITAL 1 12 + -2.12505610730419E-16 6.68612868167736E-17 -1.04835455007149E-16 -8.66987658128779E-01 1.02085524469132E+00 + 6.16936182441531E-02 -7.26426185633162E-02 8.68094228157446E-17 -5.94733910486319E-16 -8.24874461857443E-17 + 6.43131502169533E-03 -1.43037100514808E-16 -9.03800248396530E-02 -1.05059346656937E-17 3.29752228691552E-17 + -4.08438836461093E-16 3.87504446965442E-16 -8.66987658138511E-01 1.02085524472665E+00 6.16936182448076E-02 + -7.26426185657292E-02 1.61108883417304E-16 -4.64523796496676E-16 -3.43876023742449E-17 -6.43131502150672E-03 + 1.64835388103904E-16 9.03800248368550E-02 -4.97400165292194E-17 +* ORBITAL 1 13 + 4.64925079707360E-16 1.84629329446122E-15 -2.12941319252722E-15 -6.16936182441348E-02 7.26426185632714E-02 + -8.66987658128912E-01 1.02085524469166E+00 -2.52139782138066E-16 -1.88498841735511E-16 1.76508951120726E-17 + -9.03800248396243E-02 -1.54751598760199E-16 -6.43131502169974E-03 -3.85206521256276E-17 4.53980870834004E-16 + 9.20241804747457E-16 -8.99888718744289E-16 -6.16936182448240E-02 7.26426185657731E-02 -8.66987658138382E-01 + 1.02085524472630E+00 1.09445507311160E-16 -9.95072589963030E-16 -5.26312441308778E-18 9.03800248368860E-02 + 2.29849587085317E-16 6.43131502150402E-03 4.06443802002821E-17 +* ORBITAL 1 14 + -5.27870006893516E-16 -2.18086558656583E-15 4.09196163598302E-15 -3.22695054404885E-02 8.45442331166789E-02 + 7.51124466470662E-01 -1.96790254843070E+00 -2.16546026318148E-16 4.90337773033977E-16 2.17483836022955E-17 + -2.01285791564117E-01 -9.85693900523710E-17 8.64755874148419E-03 1.05051949463413E-16 1.12984835419654E-16 + -3.26026623478686E-15 1.09421273749772E-15 3.22695054398019E-02 -8.45442331158993E-02 -7.51124466454467E-01 + 1.96790254841232E+00 -1.86669584805306E-16 1.67408584486563E-15 -2.39549227390344E-16 -2.01285791565925E-01 + 1.41091859436442E-16 8.64755874156107E-03 9.38714917510425E-17 +* ORBITAL 1 15 + -8.66970947551720E-16 -9.28849138888866E-15 5.38388894642402E-15 -7.51124466470815E-01 1.96790254843088E+00 + -3.22695054404899E-02 8.45442331166820E-02 -6.50784829672814E-16 -2.69114146059008E-15 -1.61368131245742E-17 + 8.64755874148447E-03 -4.45471676993788E-16 2.01285791564093E-01 -4.26113944896382E-17 -1.91205956522504E-15 + -1.24230758367709E-14 1.58589620518973E-14 7.51124466454319E-01 -1.96790254841214E+00 3.22695054397994E-02 + -8.45442331158982E-02 5.92901796948161E-16 -1.27931267413820E-16 2.24849932823002E-16 8.64755874156242E-03 + -6.41835554891218E-16 2.01285791565944E-01 5.80887101464097E-18 +* ORBITAL 1 16 + -4.27348619625753E-01 -2.09585300071357E+00 2.14449115097085E+00 3.87623439801414E-15 -9.30572107545731E-15 + -1.30892822420412E-15 2.34212233556854E-15 3.31956067521642E-01 -1.90092557638462E-01 -3.34457936696888E-17 + 8.06531734255554E-17 -7.22397042376082E-02 -8.23588260588405E-16 -4.79832144562687E-16 -4.27348619625750E-01 + -2.09585300071562E+00 2.14449115097224E+00 -3.24774796088545E-15 9.23203796649630E-15 1.52148370398313E-17 + -9.31264938684518E-16 -3.31956067522067E-01 1.90092557638012E-01 -1.83775298100957E-17 2.34513395841964E-16 + -7.22397042378363E-02 -8.69960270805577E-16 -7.51366395444837E-16 +* ORBITAL 1 17 + -4.57715911577330E-01 -1.74833441249526E+00 7.05341290191322E+00 -2.72615314323647E-16 6.15691370054726E-16 + 1.34925980337086E-15 -4.48296313978395E-16 8.71380943338036E-01 1.55420919718592E+00 -2.72633196249532E-18 + -8.29688757158008E-17 -2.49927322008115E-01 3.56946217108663E-16 -2.94751309116286E-15 4.57715911576723E-01 + 1.74833441249635E+00 -7.05341290191214E+00 1.74387304990227E-15 -1.38482421084220E-15 9.68668914033967E-16 + -5.17245451577858E-16 8.71380943339521E-01 1.55420919718520E+00 -1.52266177975647E-17 8.86296811751088E-18 + 2.49927322008917E-01 6.49417876583612E-17 9.93196627439938E-16 +* ORBITAL 1 18 + 2.11435075088406E-17 1.23120436496472E-16 -2.49877588454529E-16 -1.59317198009139E-16 -2.34307228085976E-16 + 1.89436240567980E-16 -3.90615598549243E-16 5.50051018110321E-16 -3.31998662957974E-16 6.12478614154489E-01 + -9.27828660249702E-17 -3.12092334381469E-17 -2.31051646709339E-16 2.02615701993410E-15 -5.03747443554677E-17 + 1.80895755093290E-16 1.15235801074757E-16 -6.75686528310452E-16 4.76810152647582E-16 -3.52975782344935E-16 + 3.89538421296212E-16 -4.30260036757917E-16 1.54091704621554E-16 6.12478614156048E-01 -9.41504018838598E-17 + -1.16244905001633E-18 -5.55670293520838E-17 2.02615701994042E-15 +* ORBITAL 1 19 + -5.79733097164713E-16 -9.25392804061953E-16 3.05509613431387E-15 -7.44120688185096E-17 8.68950625784823E-17 + -2.35938218512814E-16 4.01854645693196E-16 3.82024850680210E-15 -1.70254647629039E-15 -2.04405892272719E-15 + 3.16259537997706E-16 -1.70724524598912E-15 -5.11102578995711E-17 6.12478614154490E-01 -1.86301606916243E-16 + -1.32937593106320E-15 3.72092405618231E-16 -6.28450032611571E-17 1.21352083538966E-17 5.23176353379467E-17 + -3.19553718869261E-16 -8.49997600277782E-18 2.72222816438053E-16 -2.00825511714736E-15 1.81637934313368E-16 + 8.07062439843953E-16 -1.86547556261506E-17 6.12478614156048E-01 +* ORBITAL 1 20 + 3.90377998467226E-01 2.05636842254189E+00 -9.42264148462085E+00 7.97080961726683E-16 -5.29083233610799E-16 + -7.20679735487024E-16 3.39920767660104E-16 4.40488136361489E-02 -3.18675813571503E+00 -1.45862308399864E-17 + 1.94298556329731E-16 -5.75955751564438E-01 2.50584850020516E-16 5.97515841140249E-15 -3.90377998468443E-01 + -2.05636842254361E+00 9.42264148462262E+00 -7.05965611913924E-16 6.08782747653417E-16 1.04412733656175E-15 + -6.69044883843985E-16 4.40488136350620E-02 -3.18675813571588E+00 -1.30611880091420E-17 2.12341627551724E-17 + 5.75955751565952E-01 -6.95457691408164E-16 -8.35445994652989E-15 +* ORBITAL 1 21 + 2.69695996702049E-16 1.14394542610450E-15 -4.89724450358618E-15 5.40271744826588E-01 -3.68251844323496E-01 + -1.06444512446784E-01 7.25530964778162E-02 -9.62622077658162E-17 -1.73414029223308E-15 -1.53254486434346E-16 + 1.21979088020786E-01 -4.60227877092173E-16 -6.19119325200467E-01 6.61717157258916E-17 -1.74655353073368E-16 + -1.27186094896904E-15 4.99301544439224E-15 5.40271744824806E-01 -3.68251844323151E-01 -1.06444512446435E-01 + 7.25530964777559E-02 1.38245437889910E-16 -1.83179715403679E-15 3.51624442545690E-17 -1.21979088021182E-01 + 4.23990212239399E-16 6.19119325202471E-01 -1.11285214945779E-16 +* ORBITAL 1 22 + 1.26791550155727E-16 1.15149652806112E-15 -2.90130008069851E-15 1.06444512446785E-01 -7.25530964778217E-02 + 5.40271744826582E-01 -3.68251844323479E-01 -1.97106700958055E-16 -6.81748938196033E-16 7.61759250247888E-17 + -6.19119325200461E-01 1.27109857414723E-17 -1.21979088020787E-01 1.93838565759171E-16 -2.55306509551530E-16 + -1.36941171548372E-15 2.99090821189707E-15 1.06444512446434E-01 -7.25530964777519E-02 5.40271744824811E-01 + -3.68251844323168E-01 -1.53494784148777E-16 -9.88551884507829E-16 -9.26243427548806E-17 6.19119325202475E-01 + 9.17640700210156E-17 1.21979088021181E-01 -6.71635308592250E-17 +* ORBITAL 1 23 + 5.45865909134655E-15 2.51705270375164E-14 -1.26069501304021E-13 -1.70289589932513E-16 -9.11402820906464E-17 + 1.88011589785504E-16 -1.09723691299507E-16 -3.01495024436853E-15 -4.19727537467946E-14 3.40935480886763E-15 + -1.31117752425945E-17 -6.18036941350790E-15 -3.30585322598611E-16 -8.65725319883594E-01 -4.72069286789893E-15 + -2.30920842425593E-14 1.24705165923863E-13 1.86031568355218E-16 4.80747783789681E-17 4.96036139243371E-17 + -8.53415844611442E-17 -3.49343154107687E-15 -4.04005225991461E-14 -3.40935480886411E-15 1.39318429891146E-16 + 4.21923409244044E-15 -1.59104114633468E-16 8.65725319882492E-01 +* ORBITAL 1 24 + 7.63881109626875E-17 2.21905690896440E-16 -6.39348266035833E-17 7.60617453510885E-16 -3.69450012750968E-16 + 2.84419865883126E-16 -3.68650007203571E-16 -4.78524559738384E-17 8.16029628066358E-17 -8.65725319883594E-01 + -2.38876784532483E-16 -7.59949533355072E-17 -8.55705864631149E-17 -3.42201994913974E-15 1.44216544896488E-17 + 1.51569065089846E-16 -2.33068913878720E-16 -3.53356048737406E-16 3.08817855096207E-16 -4.16739475862993E-16 + 3.48922555492768E-16 1.22600103721125E-16 -3.64143734061022E-17 8.65725319882491E-01 -7.80964006026417E-17 + -1.00374102438802E-16 -2.22395508331266E-16 3.39668966859198E-15 +* ORBITAL 1 25 + -6.41811514157174E-01 -2.04712163553056E+00 1.65709862004079E+00 -3.48084807942824E-16 2.03905016543817E-16 + -1.59723688135127E-16 4.00048537229869E-16 -2.17606647430949E-01 9.11622775652488E-01 -6.09170612197679E-17 + 7.25304449879307E-16 1.07709379405067E+00 4.89134715258727E-17 -5.59975326405230E-16 -6.41811514156182E-01 + -2.04712163552655E+00 1.65709862003330E+00 6.60189534262518E-16 -2.84856128044413E-16 2.98844718564400E-17 + -3.18133670855707E-16 2.17606647428142E-01 -9.11622775649215E-01 8.59557052102034E-17 6.70569207578706E-16 + 1.07709379405050E+00 3.88300557984497E-17 1.28763496360507E-15 +* ORBITAL 1 26 + 3.50275571230867E-16 7.92595278936506E-16 -2.88165406555340E-16 -7.70534517179933E-02 -6.29416819648200E-03 + 1.12641021133155E+00 9.20116512665062E-02 7.61377350495168E-17 -2.81916964588182E-16 -4.32891436853192E-17 + 1.39311927923981E+00 -5.10452547930627E-16 -9.52980078131707E-02 -3.84678456319602E-17 3.27690032854497E-16 + 8.01750359892738E-16 -1.14594707669862E-15 7.70534517180087E-02 6.29416819647379E-03 -1.12641021133180E+00 + -9.20116512663638E-02 -3.40217906276919E-16 6.22228822424150E-16 7.51131351002608E-17 1.39311927923882E+00 + -4.70779002168438E-16 -9.52980078131036E-02 -1.39768659367239E-16 +* ORBITAL 1 27 + 2.37215995187469E-17 -2.17273652579149E-16 -1.01249420762989E-15 1.12641021133155E+00 9.20116512665066E-02 + 7.70534517179929E-02 6.29416819648118E-03 -1.17366451110418E-15 -1.88851664680450E-18 -1.45910471032785E-17 + 9.52980078131701E-02 -1.78815070263439E-16 1.39311927923981E+00 -1.35651080398528E-16 2.72114383233397E-16 + -2.55864348247577E-16 1.11046553998414E-15 -1.12641021133179E+00 -9.20116512663718E-02 -7.70534517180091E-02 + -6.29416819647237E-03 4.56337920183350E-16 -5.55561381956743E-16 9.89735815546177E-17 9.52980078131031E-02 + 9.43033433168893E-17 1.39311927923882E+00 1.55317081824888E-16 +* ORBITAL 1 28 + -9.68179227491163E-01 -3.74414125223802E+00 -8.68902836091253E-02 -9.43833984429365E-16 3.23207169838896E-16 + 2.00722527669066E-16 1.19096974984690E-17 -2.76347865552370E+00 3.25094218161327E-01 -8.42531199718743E-18 + -1.15683658880609E-17 -1.08576872475431E+00 -7.20621537520582E-18 6.68140686633347E-16 9.68179227492082E-01 + 3.74414125223772E+00 8.68902836085084E-02 1.48074481986393E-15 -3.58561470313808E-16 1.02229961833348E-15 + -2.33783889341696E-16 -2.76347865552413E+00 3.25094218161684E-01 1.24886310689248E-17 -4.94242086884369E-20 + 1.08576872475348E+00 -3.75565609462774E-17 -4.25430452970983E-16 +#OCC +* OCCUPATION NUMBERS + 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 1.92860940005952E+00 1.92860940005952E+00 + 1.52355672543759E+00 4.73843303146789E-01 7.26905856482900E-02 7.26905856482871E-02 0.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 +#OCHR +* OCCUPATION NUMBERS (HUMAN-READABLE) + 2.0000 2.0000 2.0000 1.9286 1.9286 1.5236 0.4738 0.0727 0.0727 0.0000 + 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 + 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 +#ONE +* ONE ELECTRON ENERGIES + -1.1254E+01 -1.1244E+01 -1.0829E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 4.1692E-01 + 5.5947E-01 6.0968E-01 6.0968E-01 7.0799E-01 7.0799E-01 7.5443E-01 1.0981E+00 1.2231E+00 1.2231E+00 1.4425E+00 + 1.5330E+00 1.5330E+00 1.7321E+00 1.7321E+00 2.0947E+00 2.2638E+00 2.2638E+00 3.1313E+00 +#INDEX +* 1234567890 +0 iii222222s +1 ssssssssss +2 ssssssss +>>EOF >>FILE checkfile * This file is autogenerated: -* Molcas version 20.10-241-g70ed4f8b -* Linux otis 4.15.0-1073-oem #83-Ubuntu SMP Mon Feb 17 11:21:18 UTC 2020 x86_64 x86_64 x86_64 GNU/Linux -* Fri Nov 27 18:01:51 2020 +* Molcas version 22.02-49-g93bd2f379 +* Linux lucifer 5.13.0-30-generic #33~20.04.1-Ubuntu SMP Mon Feb 7 14:25:10 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Wed Feb 23 15:28:47 2022 * #>> 1 #> POTNUC="18"/12 @@ -67,32 +288,19 @@ #> SEWARD_KINETIC="16.052757759106"/5 #> SEWARD_ATTRACT="-36.987046619188"/5 #>> 2 -#> RASSCF_ITER="9"/8 -#> E_RASSCF="-75.503986905213"/4 -#> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="0.0"/2 -#> MLTPL__1[1]="0.0"/2 -#> MLTPL__1[2]="-0.000000000000"/2 -#> MLTPL__2[0]="-0.780912028843"/2 -#> MLTPL__2[1]="0.0"/2 -#> MLTPL__2[2]="-0.000000000000"/2 -#> MLTPL__2[3]="-0.780912028842"/2 -#> MLTPL__2[4]="0.0"/2 -#> MLTPL__2[5]="1.561824057685"/2 -#>> 3 #> SCF_ITER="6"/8 -#> E_CNO="-75.693279646386"/4 -#> E_SCF="-75.696835596017"/4 -#> DFT_ENERGY="-10.752796791922"/6 -#> NQ_DENSITY="6.000000106241"/8 +#> E_CNO="-75.693279649019"/4 +#> E_SCF="-75.696835588832"/4 +#> DFT_ENERGY="-10.752796709278"/6 +#> NQ_DENSITY="6.000000106207"/8 #> MLTPL__0="-0.000000000000"/2 #> MLTPL__1[0]="0.0"/2 #> MLTPL__1[1]="0.0"/2 -#> MLTPL__1[2]="0.000000000000"/2 -#> MLTPL__2[0]="-0.759124950322"/2 +#> MLTPL__1[2]="0.000000000001"/2 +#> MLTPL__2[0]="-0.759124579290"/2 #> MLTPL__2[1]="0.0"/2 #> MLTPL__2[2]="-0.000000000000"/2 -#> MLTPL__2[3]="-0.759124950322"/2 +#> MLTPL__2[3]="-0.759124579290"/2 #> MLTPL__2[4]="-0.000000000000"/2 -#> MLTPL__2[5]="1.518249900645"/2 +#> MLTPL__2[5]="1.518249158581"/2 >>EOF diff -Nru openmolcas-22.02/test/additional/893.input openmolcas-22.10/test/additional/893.input --- openmolcas-22.02/test/additional/893.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/893.input 2022-10-10 14:22:40.000000000 +0000 @@ -222,9 +222,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-47-gf3a58c74f -* Linux MSI 4.4.0-22000-Microsoft #1-Microsoft Fri Jun 04 16:28:00 PST 2021 x86_64 x86_64 x86_64 GNU/Linux -* Wed Oct 27 10:48:51 2021 +* Molcas version 22.02-135-ge74223037 +* Linux otis 5.4.0-104-generic #118~18.04.1-Ubuntu SMP Thu Mar 3 13:53:15 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Sun Apr 3 08:58:10 2022 * #>> 1 #> POTNUC="207.967530930892"/12 @@ -238,185 +238,185 @@ #> SEWARD_ATTRACT="-11.667112938247"/5 #>> 3 #> SCF_ITER="11"/8 -#> E_SCF="-262.811649455845"/8 -#> MLTPL__0="-0.000000000000"/5 +#> E_SCF="-262.811649455828"/8 +#> MLTPL__0="-0.000000000001"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-7.072959831296"/5 +#> MLTPL__2[0]="-7.072959831305"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="9.146851409175"/5 +#> MLTPL__2[3]="9.146851409205"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-2.073891577878"/5 +#> MLTPL__2[5]="-2.073891577901"/5 #>> 4 #> RASSCF_ITER="11"/8 -#> E_RASSCF="-262.898375443093"/8 +#> E_RASSCF="-262.898375443077"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-7.034323378918"/5 +#> MLTPL__2[0]="-7.034323378926"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="8.536405168790"/5 +#> MLTPL__2[3]="8.536405168820"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-1.502081789871"/5 +#> MLTPL__2[5]="-1.502081789894"/5 #>> 5 #> RASSCF_ITER="11"/8 -#> E_RASSCF="-262.713598868131"/8 +#> E_RASSCF="-262.713598868114"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-7.667441905571"/5 +#> MLTPL__2[0]="-7.667441905628"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="8.609964196315"/5 +#> MLTPL__2[3]="8.609964196700"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.942522290744"/5 +#> MLTPL__2[5]="-0.942522291072"/5 #>> 6 #> RASSCF_ITER="13"/8 -#> E_RASSCF="-262.719807012189"/8 +#> E_RASSCF="-262.719807012173"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-3.314580863659"/5 +#> MLTPL__2[0]="-3.314580863700"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="7.301824088822"/5 +#> MLTPL__2[3]="7.301824088892"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-3.987243225163"/5 +#> MLTPL__2[5]="-3.987243225192"/5 #>> 7 #> RASSCF_ITER="12"/8 -#> E_RASSCF="-262.680087946717"/8 +#> E_RASSCF="-262.680087946700"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-2.063340279483"/5 +#> MLTPL__2[0]="-2.063340279410"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="5.991857974889"/5 +#> MLTPL__2[3]="5.991857974911"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-3.928517695406"/5 +#> MLTPL__2[5]="-3.928517695501"/5 #>> 8 #> RASSCF_ITER="12"/8 -#> E_RASSCF[0]="-262.736859983072"/8 -#> E_RASSCF[1]="-262.532688996879"/8 -#> E_RASSCF[2]="-262.524414174114"/8 +#> E_RASSCF[0]="-262.736859983055"/8 +#> E_RASSCF[1]="-262.532688996862"/8 +#> E_RASSCF[2]="-262.524414174096"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-2.539705995263"/5 +#> MLTPL__2[0]="-2.539705995267"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="6.571522799244"/5 +#> MLTPL__2[3]="6.571522799296"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-4.031816803981"/5 +#> MLTPL__2[5]="-4.031816804029"/5 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-2.264894560378"/5 +#> MLTPL__2[0]="-2.264894560374"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="5.337748010389"/5 +#> MLTPL__2[3]="5.337748010430"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-3.072853450012"/5 +#> MLTPL__2[5]="-3.072853450057"/5 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-3.574345325438"/5 +#> MLTPL__2[0]="-3.574345325445"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="6.460557681768"/5 +#> MLTPL__2[3]="6.460557681819"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-2.886212356330"/5 +#> MLTPL__2[5]="-2.886212356373"/5 #>> 9 #> RASSCF_ITER="10"/8 -#> E_RASSCF[0]="-262.674208907460"/8 -#> E_RASSCF[1]="-262.482716189240"/8 -#> E_RASSCF[2]="-262.475615658368"/8 +#> E_RASSCF[0]="-262.674208907448"/8 +#> E_RASSCF[1]="-262.482716189219"/8 +#> E_RASSCF[2]="-262.475615658351"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-1.897462013320"/5 +#> MLTPL__2[0]="-1.897462013969"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="5.755052565596"/5 +#> MLTPL__2[3]="5.755052565833"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-3.857590552276"/5 +#> MLTPL__2[5]="-3.857590551863"/5 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-3.780395053985"/5 +#> MLTPL__2[0]="-3.780395053896"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="6.883771607505"/5 +#> MLTPL__2[3]="6.883771606796"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-3.103376553520"/5 +#> MLTPL__2[5]="-3.103376552900"/5 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-2.850368486463"/5 +#> MLTPL__2[0]="-2.850368488199"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="5.946714307213"/5 +#> MLTPL__2[3]="5.946714308580"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-3.096345820750"/5 +#> MLTPL__2[5]="-3.096345820381"/5 #>> 10 #> RASSCF_ITER="8"/8 -#> E_RASSCF[0]="-262.706487488791"/8 -#> E_RASSCF[1]="-262.590434283880"/8 -#> E_RASSCF[2]="-262.500249385469"/8 +#> E_RASSCF[0]="-262.706487488773"/8 +#> E_RASSCF[1]="-262.590434283862"/8 +#> E_RASSCF[2]="-262.500249385452"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-9.438373707703"/5 +#> MLTPL__2[0]="-9.438373707707"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="10.370473006600"/5 +#> MLTPL__2[3]="10.370473006630"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.932099298897"/5 +#> MLTPL__2[5]="-0.932099298924"/5 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-6.192218403028"/5 +#> MLTPL__2[0]="-6.192218403038"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="7.318939880223"/5 +#> MLTPL__2[3]="7.318939880261"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-1.126721477195"/5 +#> MLTPL__2[5]="-1.126721477223"/5 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="4.493811840047"/5 +#> MLTPL__2[0]="4.493811840041"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="2.196209493324"/5 +#> MLTPL__2[3]="2.196209493368"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-6.690021333372"/5 +#> MLTPL__2[5]="-6.690021333409"/5 #>> 11 -#> E_RASSI[0]="-262.898375443094"/7 -#> E_RASSI[1]="-262.719807012190"/7 -#> E_RASSI[2]="-262.680087946717"/7 -#> E_RASSI[3]="-262.713598868131"/7 -#> E_RASSI[4]="-262.736859983073"/7 -#> E_RASSI[5]="-262.674208907460"/7 -#> E_RASSI[6]="-262.706487488791"/7 +#> E_RASSI[0]="-262.898375443077"/7 +#> E_RASSI[1]="-262.719807012173"/7 +#> E_RASSI[2]="-262.680087946700"/7 +#> E_RASSI[3]="-262.713598868114"/7 +#> E_RASSI[4]="-262.736859983055"/7 +#> E_RASSI[5]="-262.674208907448"/7 +#> E_RASSI[6]="-262.706487488774"/7 #> TMS(SF,LEN)="0.0"/6 #> TMS(SF,LEN)="0.011963712565"/6 -#> TMS(SF,LEN)="0.045000426820"/6 +#> TMS(SF,LEN)="0.045000426816"/6 #> TMS(SF,LEN)="0.0"/6 #> TMS(SF,LEN)="0.0"/6 #> TMS(SF,LEN)="0.0"/6 @@ -437,7 +437,7 @@ #> TMS(SF,LEN)="0.0"/6 #> TMS(SF,VEL)="0.0"/6 #> TMS(SF,VEL)="0.015613602162"/6 -#> TMS(SF,VEL)="0.026703537552"/6 +#> TMS(SF,VEL)="0.026703537546"/6 #> TMS(SF,VEL)="0.0"/6 #> TMS(SF,VEL)="0.0"/6 #> TMS(SF,VEL)="0.0"/6 @@ -456,24 +456,24 @@ #> TMS(SF,VEL)="0.0"/6 #> TMS(SF,VEL)="0.0"/6 #> TMS(SF,VEL)="0.0"/6 -#> ESO_LOW[0]="-262.898375443094"/8 -#> ESO_LOW[1]="-262.736859987144"/8 -#> ESO_LOW[2]="-262.736859984903"/8 -#> ESO_LOW[3]="-262.736859984903"/8 -#> ESO_LOW[4]="-262.719807015574"/8 -#> ESO_LOW[5]="-262.713599071140"/8 -#> ESO_LOW[6]="-262.706487663311"/8 -#> ESO_LOW[7]="-262.706487661757"/8 -#> ESO_LOW[8]="-262.706487654772"/8 -#> ESO_LOW[9]="-262.680087778906"/8 -#> ESO_LOW[10]="-262.674208731111"/8 -#> ESO_LOW[11]="-262.674208731111"/8 -#> ESO_LOW[12]="-262.674208700380"/8 +#> ESO_LOW[0]="-262.898375443077"/7 +#> ESO_LOW[1]="-262.736859987127"/7 +#> ESO_LOW[2]="-262.736859984885"/7 +#> ESO_LOW[3]="-262.736859984885"/7 +#> ESO_LOW[4]="-262.719807015556"/7 +#> ESO_LOW[5]="-262.713599071123"/7 +#> ESO_LOW[6]="-262.706487663294"/7 +#> ESO_LOW[7]="-262.706487661740"/7 +#> ESO_LOW[8]="-262.706487654755"/7 +#> ESO_LOW[9]="-262.680087778889"/7 +#> ESO_LOW[10]="-262.674208731098"/7 +#> ESO_LOW[11]="-262.674208731098"/7 +#> ESO_LOW[12]="-262.674208700368"/7 #> TMS(SO,LEN)="0.000000006884"/6 #> TMS(SO,LEN)="0.0"/6 #> TMS(SO,LEN)="0.0"/6 #> TMS(SO,LEN)="0.011963709300"/6 -#> TMS(SO,LEN)="0.045000132931"/6 +#> TMS(SO,LEN)="0.045000132926"/6 #> TMS(SO,LEN)="0.0"/6 #> TMS(SO,LEN)="0.000000003266"/6 #> TMS(SO,LEN)="0.0"/6 @@ -544,7 +544,7 @@ #> TMS(SO,VEL)="0.0"/6 #> TMS(SO,VEL)="0.0"/6 #> TMS(SO,VEL)="0.015613598492"/6 -#> TMS(SO,VEL)="0.026703421833"/6 +#> TMS(SO,VEL)="0.026703421827"/6 #> TMS(SO,VEL)="0.0"/6 #> TMS(SO,VEL)="0.000000003691"/6 #> TMS(SO,VEL)="0.0"/6 @@ -611,9 +611,9 @@ #> TMS(SO,VEL)="0.0"/6 #> TMS(SO,VEL)="0.0"/6 #> TMS(SO,VEL)="0.0"/6 -#> LAMBDA[0]="1.023274751302"/4 -#> LAMBDA[1]="0.624376772455"/4 -#> LAMBDA[2]="0.178629579357"/4 -#> LAMBDA[3]="0.077749901505"/4 +#> LAMBDA[0]="1.023274751290"/4 +#> LAMBDA[1]="0.624376772472"/4 +#> LAMBDA[2]="0.178629579354"/4 +#> LAMBDA[3]="0.077749901508"/4 #> LAMBDA[4]="0.0"/4 >>EOF diff -Nru openmolcas-22.02/test/additional/896.input openmolcas-22.10/test/additional/896.input --- openmolcas-22.02/test/additional/896.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/additional/896.input 2022-10-10 14:22:40.000000000 +0000 @@ -96,9 +96,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 18.09-531-ge0632f48 -* Linux serrano 3.13.0-162-generic #212-Ubuntu SMP Mon Oct 29 12:08:50 UTC 2018 x86_64 x86_64 x86_64 GNU/Linux -* Mon May 20 16:50:28 2019 +* Molcas version 22.02-264-gd603c8837 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Thu Apr 28 14:14:23 2022 * #>> 1 #> SEWARD_MLTPL1X="0.0"/5 @@ -109,224 +109,224 @@ #> SEWARD_KINETIC="16.088985800456"/5 #> SEWARD_ATTRACT="-35.484863372730"/5 #>> 2 -#> SCF_ITER="17"/8 -#> E_SCF="-39.495077935868"/4 +#> SCF_ITER="18"/8 +#> E_SCF="-39.495077935866"/4 #> MLTPL__0="-1.000000000000"/2 -#> MLTPL__1[0]="0.000013798653"/2 -#> MLTPL__1[1]="0.000001138344"/2 -#> MLTPL__1[2]="-0.000000000001"/2 -#> MLTPL__2[0]="1.212877348333"/2 -#> MLTPL__2[1]="-0.000001166185"/2 -#> MLTPL__2[2]="-0.000000000000"/2 -#> MLTPL__2[3]="1.213079730637"/2 +#> MLTPL__1[0]="0.000013806242"/2 +#> MLTPL__1[1]="-0.000001136754"/2 +#> MLTPL__1[2]="0.000000000000"/2 +#> MLTPL__2[0]="1.212877368660"/2 +#> MLTPL__2[1]="0.000001163991"/2 +#> MLTPL__2[2]="0.000000000000"/2 +#> MLTPL__2[3]="1.213079706650"/2 #> MLTPL__2[4]="0.000000000000"/2 -#> MLTPL__2[5]="-2.425957078970"/2 -#> EF0___EL="31.315955660299"/5 +#> MLTPL__2[5]="-2.425957075310"/2 +#> EF0___EL="31.315955666171"/5 #> EF0__NUC="11.922422052617"/5 -#> EF1___EL[0]="-0.000166790188"/5 -#> EF1___EL[1]="-0.000001091723"/5 -#> EF1___EL[2]="0.000000000001"/5 +#> EF1___EL[0]="-0.000166794479"/5 +#> EF1___EL[1]="0.000001090777"/5 +#> EF1___EL[2]="-0.000000000000"/5 #> EF1__NUC[0]="0.000197807641"/5 #> EF1__NUC[1]="0.0"/5 #> EF1__NUC[2]="0.0"/5 -#> EF2___EL[0]="0.639333352761"/5 -#> EF2___EL[1]="0.000001041698"/5 -#> EF2___EL[2]="-0.000000000001"/5 -#> EF2___EL[3]="0.639277372238"/5 -#> EF2___EL[4]="0.000000000001"/5 -#> EF2___EL[5]="-1674.711996684803"/5 -#> EF2__NUC[0]="-1.282229217095"/5 -#> EF2__NUC[1]="0.0"/5 -#> EF2__NUC[2]="0.0"/5 -#> EF2__NUC[3]="-1.282086795820"/5 -#> EF2__NUC[4]="0.0"/5 -#> EF2__NUC[5]="2.564316012915"/5 -#> CNT___EL="133.269346263842"/5 +#> EF2___EL[0]="0.639333362683"/4 +#> EF2___EL[1]="-0.000001042749"/4 +#> EF2___EL[2]="-0.000000000000"/4 +#> EF2___EL[3]="0.639277362709"/4 +#> EF2___EL[4]="-0.000000000000"/4 +#> EF2___EL[5]="-1674.711996830238"/4 +#> EF2__NUC[0]="-1.282229217095"/4 +#> EF2__NUC[1]="0.0"/4 +#> EF2__NUC[2]="0.0"/4 +#> EF2__NUC[3]="-1.282086795820"/4 +#> EF2__NUC[4]="0.0"/4 +#> EF2__NUC[5]="2.564316012915"/4 +#> CNT___EL="133.269346275416"/5 #> CNT__NUC="0.0"/5 #>> 3 #> RASSCF_ITER="17"/8 -#> E_RASSCF="-39.688974408379"/4 -#> MLTPL__0="-0.000000000001"/2 -#> MLTPL__1[0]="0.000001205679"/2 -#> MLTPL__1[1]="0.000000896788"/2 -#> MLTPL__1[2]="-0.000000000000"/2 -#> MLTPL__2[0]="0.620378462578"/2 -#> MLTPL__2[1]="-0.000001902633"/2 +#> E_RASSCF="-39.688974408384"/4 +#> MLTPL__0="-0.000000000000"/2 +#> MLTPL__1[0]="0.000001205725"/2 +#> MLTPL__1[1]="-0.000000897139"/2 +#> MLTPL__1[2]="0.000000000000"/2 +#> MLTPL__2[0]="0.620378462776"/2 +#> MLTPL__2[1]="0.000001902709"/2 #> MLTPL__2[2]="0.000000000000"/2 -#> MLTPL__2[3]="0.620758905319"/2 +#> MLTPL__2[3]="0.620758905310"/2 #> MLTPL__2[4]="-0.000000000000"/2 -#> MLTPL__2[5]="-1.241137367897"/2 -#> EF0___EL="30.006802026877"/5 +#> MLTPL__2[5]="-1.241137368086"/2 +#> EF0___EL="30.006802026902"/5 #> EF0__NUC="11.922422052617"/5 -#> EF1___EL[0]="-0.000164710036"/5 -#> EF1___EL[1]="-0.000001085971"/5 -#> EF1___EL[2]="-0.000000000000"/5 +#> EF1___EL[0]="-0.000164710043"/5 +#> EF1___EL[1]="0.000001085985"/5 +#> EF1___EL[2]="0.000000000000"/5 #> EF1__NUC[0]="0.000197807641"/5 #> EF1__NUC[1]="0.0"/5 #> EF1__NUC[2]="0.0"/5 -#> EF2___EL[0]="1.135575394391"/5 -#> EF2___EL[1]="0.000002399297"/5 -#> EF2___EL[2]="0.000000000000"/5 -#> EF2___EL[3]="1.135538044625"/5 -#> EF2___EL[4]="0.0"/5 -#> EF2___EL[5]="-1679.686595814053"/5 -#> EF2__NUC[0]="-1.282229217095"/5 -#> EF2__NUC[1]="0.0"/5 -#> EF2__NUC[2]="0.0"/5 -#> EF2__NUC[3]="-1.282086795820"/5 -#> EF2__NUC[4]="0.0"/5 -#> EF2__NUC[5]="2.564316012915"/5 -#> CNT___EL="133.665212284503"/5 +#> EF2___EL[0]="1.135575394421"/4 +#> EF2___EL[1]="-0.000002399423"/4 +#> EF2___EL[2]="0.000000000000"/4 +#> EF2___EL[3]="1.135538044578"/4 +#> EF2___EL[4]="-0.000000000000"/4 +#> EF2___EL[5]="-1679.686595815356"/4 +#> EF2__NUC[0]="-1.282229217095"/4 +#> EF2__NUC[1]="0.0"/4 +#> EF2__NUC[2]="0.0"/4 +#> EF2__NUC[3]="-1.282086795820"/4 +#> EF2__NUC[4]="0.0"/4 +#> EF2__NUC[5]="2.564316012915"/4 +#> CNT___EL="133.665212284606"/5 #> CNT__NUC="0.0"/5 #>> 4 -#> E_RASSI="-39.688974408382"/4 -#> ESO_LOW[0]="-39.688974408382"/4 -#> ESO_LOW[1]="-39.688974408382"/4 +#> E_RASSI="-39.688974408384"/4 +#> ESO_LOW[0]="-39.688974408384"/4 +#> ESO_LOW[1]="-39.688974408384"/4 #> EPRGVAL[0]="0.0"/6 #> EPRGVAL[1]="0.0"/6 #> EPRGVAL[2]="0.0"/6 -#> ASDFC1="0.771633110752"/5 -#> ASDFC2="0.000000108335"/5 +#> ASDFC1="0.771633110741"/5 +#> ASDFC2="-0.000000108327"/5 #> ASDFC3="0.000000000000"/5 -#> ASDFC4="0.771644262967"/5 +#> ASDFC4="0.771644262975"/5 #> ASDFC5="-0.000000000000"/5 -#> ASDFC6="2.738868313844"/5 -#> ASDFC1="0.771633110752"/5 -#> ASDFC2="0.000000108335"/5 +#> ASDFC6="2.738868313853"/5 +#> ASDFC1="0.771633110741"/5 +#> ASDFC2="-0.000000108327"/5 #> ASDFC3="0.000000000000"/5 -#> ASDFC4="0.771644262967"/5 +#> ASDFC4="0.771644262975"/5 #> ASDFC5="-0.000000000000"/5 -#> ASDFC6="2.738868313844"/5 -#> ASDFC1="0.771633110752"/5 -#> ASDFC2="0.000000108335"/5 +#> ASDFC6="2.738868313853"/5 +#> ASDFC1="0.771633110741"/5 +#> ASDFC2="-0.000000108327"/5 #> ASDFC3="0.000000000000"/5 -#> ASDFC4="0.771644262967"/5 +#> ASDFC4="0.771644262975"/5 #> ASDFC5="-0.000000000000"/5 -#> ASDFC6="2.738868313844"/5 -#> ASDFC1="0.771633110752"/5 -#> ASDFC2="0.000000108335"/5 +#> ASDFC6="2.738868313853"/5 +#> ASDFC1="0.771633110741"/5 +#> ASDFC2="-0.000000108327"/5 #> ASDFC3="0.000000000000"/5 -#> ASDFC4="0.771644262967"/5 +#> ASDFC4="0.771644262975"/5 #> ASDFC5="-0.000000000000"/5 -#> ASDFC6="2.738868313844"/5 -#> ATENS[0]="0.630035796659"/5 -#> ATENS[1]="0.000000088455"/5 +#> ASDFC6="2.738868313853"/5 +#> ATENS[0]="0.630035796651"/5 +#> ATENS[1]="-0.000000088449"/5 #> ATENS[2]="0.000000000000"/5 -#> ATENS[3]="0.000000088455"/5 -#> ATENS[4]="0.630044902405"/5 +#> ATENS[3]="-0.000000088449"/5 +#> ATENS[4]="0.630044902412"/5 #> ATENS[5]="-0.000000000000"/5 #> ATENS[6]="0.000000000000"/5 #> ATENS[7]="-0.000000000000"/5 -#> ATENS[8]="2.236276613865"/5 -#> ATENS2[0]="0.396945103989"/5 -#> ATENS2[1]="0.396956580130"/5 -#> ATENS2[2]="5.000933093718"/5 -#> ASDFC1="-0.133841696706"/5 -#> ASDFC2="0.000000060202"/5 -#> ASDFC3="-0.000000000000"/5 -#> ASDFC4="-0.316689689304"/5 -#> ASDFC5="-0.000000000000"/5 -#> ASDFC6="-0.228425768387"/5 -#> ASDFC1="-0.133841696706"/5 -#> ASDFC2="0.000000060202"/5 -#> ASDFC3="-0.000000000000"/5 -#> ASDFC4="-0.316689689304"/5 -#> ASDFC5="-0.000000000000"/5 -#> ASDFC6="-0.228425768387"/5 -#> ASDFC1="-0.133841696706"/5 -#> ASDFC2="0.000000060202"/5 -#> ASDFC3="-0.000000000000"/5 -#> ASDFC4="-0.316689689304"/5 -#> ASDFC5="-0.000000000000"/5 -#> ASDFC6="-0.228425768387"/5 -#> ASDFC1="-0.133841696706"/5 -#> ASDFC2="0.000000060202"/5 -#> ASDFC3="-0.000000000000"/5 -#> ASDFC4="-0.316689689304"/5 -#> ASDFC5="-0.000000000000"/5 -#> ASDFC6="-0.228425768387"/5 -#> ATENS[0]="0.109281287746"/5 -#> ATENS[1]="-0.000000049154"/5 -#> ATENS[2]="0.000000000000"/5 -#> ATENS[3]="-0.000000049154"/5 -#> ATENS[4]="0.258576048531"/5 +#> ATENS[8]="2.236276613872"/5 +#> ATENS2[0]="0.396945103979"/5 +#> ATENS2[1]="0.396956580137"/5 +#> ATENS2[2]="5.000933093752"/5 +#> ASDFC1="-0.133841696668"/5 +#> ASDFC2="-0.000000060215"/5 +#> ASDFC3="0.0"/5 +#> ASDFC4="-0.316689689271"/5 +#> ASDFC5="-0.000000000000"/5 +#> ASDFC6="-0.228425768352"/5 +#> ASDFC1="-0.133841696668"/5 +#> ASDFC2="-0.000000060215"/5 +#> ASDFC3="0.0"/5 +#> ASDFC4="-0.316689689271"/5 +#> ASDFC5="-0.000000000000"/5 +#> ASDFC6="-0.228425768352"/5 +#> ASDFC1="-0.133841696668"/5 +#> ASDFC2="-0.000000060215"/5 +#> ASDFC3="0.0"/5 +#> ASDFC4="-0.316689689271"/5 +#> ASDFC5="-0.000000000000"/5 +#> ASDFC6="-0.228425768352"/5 +#> ASDFC1="-0.133841696668"/5 +#> ASDFC2="-0.000000060215"/5 +#> ASDFC3="0.0"/5 +#> ASDFC4="-0.316689689271"/5 +#> ASDFC5="-0.000000000000"/5 +#> ASDFC6="-0.228425768352"/5 +#> ATENS[0]="0.109281287715"/5 +#> ATENS[1]="0.000000049165"/5 +#> ATENS[2]="0.0"/5 +#> ATENS[3]="0.000000049165"/5 +#> ATENS[4]="0.258576048504"/5 #> ATENS[5]="0.000000000000"/5 -#> ATENS[6]="0.000000000000"/5 +#> ATENS[6]="0.0"/5 #> ATENS[7]="0.000000000000"/5 -#> ATENS[8]="0.186508858884"/5 -#> ATENS2[0]="0.011942399851"/5 -#> ATENS2[1]="0.066861572874"/5 -#> ATENS2[2]="0.034785554442"/5 -#> ASDFC1="-0.270980206922"/5 -#> ASDFC2="-0.079167259333"/5 -#> ASDFC3="-0.000000000000"/5 -#> ASDFC4="-0.179551223235"/5 +#> ATENS[8]="0.186508858855"/5 +#> ATENS2[0]="0.011942399845"/5 +#> ATENS2[1]="0.066861572860"/5 +#> ATENS2[2]="0.034785554431"/5 +#> ASDFC1="-0.270981934113"/5 +#> ASDFC2="-0.079166924570"/5 +#> ASDFC3="0.0"/5 +#> ASDFC4="-0.179552590409"/5 #> ASDFC5="0.000000000000"/5 -#> ASDFC6="-0.228434108073"/5 -#> ASDFC1="-0.270980206922"/5 -#> ASDFC2="-0.079167259333"/5 -#> ASDFC3="-0.000000000000"/5 -#> ASDFC4="-0.179551223235"/5 +#> ASDFC6="-0.228435074412"/5 +#> ASDFC1="-0.270981934113"/5 +#> ASDFC2="-0.079166924570"/5 +#> ASDFC3="0.0"/5 +#> ASDFC4="-0.179552590409"/5 #> ASDFC5="0.000000000000"/5 -#> ASDFC6="-0.228434108073"/5 -#> ASDFC1="-0.270980206922"/5 -#> ASDFC2="-0.079167259333"/5 -#> ASDFC3="-0.000000000000"/5 -#> ASDFC4="-0.179551223235"/5 +#> ASDFC6="-0.228435074412"/5 +#> ASDFC1="-0.270981934113"/5 +#> ASDFC2="-0.079166924570"/5 +#> ASDFC3="0.0"/5 +#> ASDFC4="-0.179552590409"/5 #> ASDFC5="0.000000000000"/5 -#> ASDFC6="-0.228434108073"/5 -#> ASDFC1="-0.270980206922"/5 -#> ASDFC2="-0.079167259333"/5 -#> ASDFC3="-0.000000000000"/5 -#> ASDFC4="-0.179551223235"/5 +#> ASDFC6="-0.228435074412"/5 +#> ASDFC1="-0.270981934113"/5 +#> ASDFC2="-0.079166924570"/5 +#> ASDFC3="0.0"/5 +#> ASDFC4="-0.179552590409"/5 #> ASDFC5="0.000000000000"/5 -#> ASDFC6="-0.228434108073"/5 -#> ATENS[0]="0.221254412451"/5 -#> ATENS[1]="0.064639796567"/5 -#> ATENS[2]="0.000000000000"/5 -#> ATENS[3]="0.064639796567"/5 -#> ATENS[4]="0.146602959872"/5 +#> ASDFC6="-0.228435074412"/5 +#> ATENS[0]="0.221255822696"/5 +#> ATENS[1]="0.064639523234"/5 +#> ATENS[2]="0.0"/5 +#> ATENS[3]="0.064639523234"/5 +#> ATENS[4]="0.146604076166"/5 #> ATENS[5]="-0.000000000000"/5 -#> ATENS[6]="0.000000000000"/5 +#> ATENS[6]="0.0"/5 #> ATENS[7]="-0.000000000000"/5 -#> ATENS[8]="0.186515668209"/5 -#> ATENS2[0]="0.066859094122"/5 -#> ATENS2[1]="0.011943455351"/5 -#> ATENS2[2]="0.034788094487"/5 -#> ASDFC1="-0.270981934193"/5 -#> ASDFC2="0.079166924565"/5 +#> ATENS[8]="0.186516457221"/5 +#> ATENS2[0]="0.066859663012"/5 +#> ATENS2[1]="0.011943767141"/5 +#> ATENS2[2]="0.034788388814"/5 +#> ASDFC1="-0.270980207080"/5 +#> ASDFC2="0.079167259336"/5 #> ASDFC3="0.000000000000"/5 -#> ASDFC4="-0.179552590478"/5 +#> ASDFC4="-0.179551223395"/5 #> ASDFC5="-0.000000000000"/5 -#> ASDFC6="-0.228435074532"/5 -#> ASDFC1="-0.270981934193"/5 -#> ASDFC2="0.079166924565"/5 +#> ASDFC6="-0.228434108276"/5 +#> ASDFC1="-0.270980207080"/5 +#> ASDFC2="0.079167259336"/5 #> ASDFC3="0.000000000000"/5 -#> ASDFC4="-0.179552590478"/5 +#> ASDFC4="-0.179551223395"/5 #> ASDFC5="-0.000000000000"/5 -#> ASDFC6="-0.228435074532"/5 -#> ASDFC1="-0.270981934193"/5 -#> ASDFC2="0.079166924565"/5 +#> ASDFC6="-0.228434108276"/5 +#> ASDFC1="-0.270980207080"/5 +#> ASDFC2="0.079167259336"/5 #> ASDFC3="0.000000000000"/5 -#> ASDFC4="-0.179552590478"/5 +#> ASDFC4="-0.179551223395"/5 #> ASDFC5="-0.000000000000"/5 -#> ASDFC6="-0.228435074532"/5 -#> ASDFC1="-0.270981934193"/5 -#> ASDFC2="0.079166924565"/5 +#> ASDFC6="-0.228434108276"/5 +#> ASDFC1="-0.270980207080"/5 +#> ASDFC2="0.079167259336"/5 #> ASDFC3="0.000000000000"/5 -#> ASDFC4="-0.179552590478"/5 +#> ASDFC4="-0.179551223395"/5 #> ASDFC5="-0.000000000000"/5 -#> ASDFC6="-0.228435074532"/5 -#> ATENS[0]="0.221255822761"/5 -#> ATENS[1]="-0.064639523230"/5 +#> ASDFC6="-0.228434108276"/5 +#> ATENS[0]="0.221254412580"/5 +#> ATENS[1]="-0.064639796569"/5 #> ATENS[2]="-0.000000000000"/5 -#> ATENS[3]="-0.064639523230"/5 -#> ATENS[4]="0.146604076222"/5 +#> ATENS[3]="-0.064639796569"/5 +#> ATENS[4]="0.146602960003"/5 #> ATENS[5]="0.000000000000"/5 #> ATENS[6]="-0.000000000000"/5 #> ATENS[7]="0.000000000000"/5 -#> ATENS[8]="0.186516457319"/5 -#> ATENS2[0]="0.066859663043"/5 -#> ATENS2[1]="0.011943767155"/5 -#> ATENS2[2]="0.034788388851"/5 +#> ATENS[8]="0.186515668374"/5 +#> ATENS2[0]="0.066859094190"/5 +#> ATENS2[1]="0.011943455379"/5 +#> ATENS2[2]="0.034788094549"/5 >>EOF diff -Nru openmolcas-22.02/test/additional/918.input openmolcas-22.10/test/additional/918.input --- openmolcas-22.02/test/additional/918.input 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/test/additional/918.input 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,154 @@ +*------------------------------------------------------------------------------- +* Molecule: N2 +* Basis: STO-3G +* Symmetry: C1 +* Features tested: Spin-Spin Correlation Function (SSCR) +*------------------------------------------------------------------------------- +>> COPY StartOrbFile . + +&GATEWAY + coord + 2 + Angstrom + N 0.000000 0.000000 0.000000 + N 2.500000 0.000000 0.000000 + basis = N.STO-3G + group = nosym + +&SEWARD + +&RASSCF + fileorb = StartOrbFile + cionly + ciroot = 2 2 1 + spin = 1 + nactel = 6 0 0 + inactive = 4 + ras2 = 6 + sscr = 3; 1 2 3; 4 5 6 + +&RASSCF + fileorb = StartOrbFile + cion + ciroot = 2 2 1 + spin = 1 + nactel = 6 0 0 + inactive = 4 + ras2 = 6 + sscr = 3 1 + +>>FILE StartOrbFile +#INPORB 2.2 +#INFO +*Localised orbitals + 0 1 0 + 10 + 10 +*BC:HOST pcal008 PID 18342 DATE Tue Apr 19 07:28:42 2022 +#ORB +* ORBITAL 1 1 + -7.03431187482962E-01 -1.50356474512713E-02 -5.44187745156817E-04 -8.60981327464286E-17 1.00230106283067E-40 + 7.03431187406028E-01 1.50356474496927E-02 -5.44187745207725E-04 4.35372164391228E-18 -3.81382735094024E-39 +* ORBITAL 1 2 + 7.03568033890719E-01 1.44318473669096E-02 -4.62352160590408E-04 2.97499546435094E-17 -4.02542062441209E-39 + 7.03568033967639E-01 1.44318473685537E-02 4.62352160530620E-04 6.85688294980400E-17 2.23707130714563E-39 +* ORBITAL 1 3 + -1.83262291440515E-01 7.18371755990962E-01 1.57160400005819E-03 -4.41763621643169E-16 -3.91082603455889E-39 + -1.83262291440543E-01 7.18371755991075E-01 -1.57160400005720E-03 -4.16148124809335E-16 -2.34520305166913E-39 +* ORBITAL 1 4 + 1.87139335086411E-01 -7.35924480225276E-01 1.29642463658414E-02 -2.30101465486798E-16 5.93152474212572E-39 + -1.87139335086382E-01 7.35924480225166E-01 1.29642463658393E-02 -1.62036821672233E-16 -5.54971046572994E-39 +* ORBITAL 1 5 + -1.20235221645740E-02 5.10421345710428E-02 2.90993431237829E-02 -1.41086324459220E-10 1.88692294046640E-15 + 2.57170955724798E-03 -1.02907810411218E-02 1.00196757802743E+00 5.79310290487729E-12 -1.01246875047261E-15 +* ORBITAL 1 6 + -6.18628677723734E-14 2.62837235271945E-13 1.50169016177227E-13 4.53946817966030E-03 1.51373735176774E-07 + 1.34125343588160E-14 -5.34532396644657E-14 5.16285202537916E-12 -1.00003090827418E+00 -3.33471696750913E-05 +* ORBITAL 1 7 + -1.45070981289280E-17 6.15014429496197E-17 1.79889727227930E-16 1.51373736648189E-07 -4.53946817954975E-03 + 4.77699788548586E-18 -1.95339408640581E-17 1.18225930766526E-15 -3.33471696750980E-05 1.00003090827418E+00 +* ORBITAL 1 8 + 7.81924304525507E-18 -3.33156443185310E-17 1.69286015132829E-16 8.44687191657537E-06 1.00003090879451E+00 + 4.95299541207142E-19 -2.53438511917841E-18 -6.86701065517462E-16 -3.83431229036449E-08 -4.53946818213426E-03 +* ORBITAL 1 9 + 1.69568710254926E-12 -7.19826430655125E-12 -3.92797415796129E-12 -1.00003090879451E+00 8.44687191656872E-06 + -3.60554397782351E-13 1.44210744777423E-12 -1.41330903903973E-10 4.53946818202232E-03 -3.83431214368627E-08 +* ORBITAL 1 10 + 2.57170955724772E-03 -1.02907810411247E-02 -1.00196757802743E+00 -1.76651987720688E-13 1.89852174520239E-16 + -1.20235221645745E-02 5.10421345710436E-02 -2.90993431237836E-02 4.69192949449270E-16 1.44521648074957E-16 +#OCC +* OCCUPATION NUMBERS + 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 +#OCHR +* OCCUPATION NUMBERS (HUMAN-READABLE) + 2.0000 2.0000 2.0000 2.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 +#ONE +* ONE ELECTRON ENERGIES + -1.5316E+01 -1.5316E+01 -8.8373E-01 -8.4650E-01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 +#INDEX +* 1234567890 +0 iiii222222 +>>EOF +>>FILE checkfile +* This file is autogenerated: +* Molcas version 22.02-240-gcff21545b +* Linux pcal008 5.3.18-lp152.66-default #1 SMP Tue Mar 2 13:18:19 UTC 2021 (73933a3) x86_64 x86_64 x86_64 GNU/Linux +* Tue Apr 19 09:31:59 2022 +* +#>> 1 +#> POTNUC="10.371873333699"/12 +#>> 2 +#> POTNUC="10.371873333699"/12 +#> SEWARD_MLTPL1X="0.0"/5 +#> SEWARD_KINETIC="21.990753316657"/5 +#> SEWARD_ATTRACT="-47.667659952813"/5 +#>> 3 +#> SPIN_CORRELATION="-3.715690615123"/8 +#> E_RASSCF[0]="-107.439887623644"/8 +#> E_RASSCF[1]="-107.202010110233"/8 +#> MLTPL__0="-0.000000000000"/5 +#> MLTPL__1[0]="-0.000000000000"/5 +#> MLTPL__1[1]="0.0"/5 +#> MLTPL__1[2]="0.0"/5 +#> MLTPL__2[0]="-0.138423474595"/5 +#> MLTPL__2[1]="0.0"/5 +#> MLTPL__2[2]="0.0"/5 +#> MLTPL__2[3]="0.069211737298"/5 +#> MLTPL__2[4]="0.0"/5 +#> MLTPL__2[5]="0.069211737298"/5 +#> MLTPL__0="-0.000000000000"/5 +#> MLTPL__1[0]="-0.000000000000"/5 +#> MLTPL__1[1]="0.0"/5 +#> MLTPL__1[2]="0.0"/5 +#> MLTPL__2[0]="-0.106789246638"/5 +#> MLTPL__2[1]="0.0"/5 +#> MLTPL__2[2]="0.0"/5 +#> MLTPL__2[3]="0.053394623319"/5 +#> MLTPL__2[4]="0.0"/5 +#> MLTPL__2[5]="0.053394623319"/5 +#>> 4 +#> SPIN_CORRELATION="3.715690615123"/8 +#> E_RASSCF[0]="-107.439887623644"/8 +#> E_RASSCF[1]="-107.202010110233"/8 +#> MLTPL__0="-0.000000000000"/5 +#> MLTPL__1[0]="-0.000000000000"/5 +#> MLTPL__1[1]="0.0"/5 +#> MLTPL__1[2]="0.0"/5 +#> MLTPL__2[0]="-0.138423474595"/5 +#> MLTPL__2[1]="0.0"/5 +#> MLTPL__2[2]="0.0"/5 +#> MLTPL__2[3]="0.069211737298"/5 +#> MLTPL__2[4]="0.0"/5 +#> MLTPL__2[5]="0.069211737298"/5 +#> MLTPL__0="-0.000000000000"/5 +#> MLTPL__1[0]="-0.000000000000"/5 +#> MLTPL__1[1]="0.0"/5 +#> MLTPL__1[2]="0.0"/5 +#> MLTPL__2[0]="-0.106789246638"/5 +#> MLTPL__2[1]="0.0"/5 +#> MLTPL__2[2]="0.0"/5 +#> MLTPL__2[3]="0.053394623319"/5 +#> MLTPL__2[4]="0.0"/5 +#> MLTPL__2[5]="0.053394623319"/5 +>>EOF diff -Nru openmolcas-22.02/test/exhaustive/basis.input openmolcas-22.10/test/exhaustive/basis.input --- openmolcas-22.02/test/exhaustive/basis.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/exhaustive/basis.input 2022-10-10 14:22:40.000000000 +0000 @@ -14493,9 +14493,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.02-1119-gde6a49c4e -* Linux otis 4.15.0-1073-oem #83-Ubuntu SMP Mon Feb 17 11:21:18 UTC 2020 x86_64 x86_64 x86_64 GNU/Linux -* Thu May 13 21:27:58 2021 +* Molcas version 22.02-264-gd603c8837 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Thu Apr 28 14:17:48 2022 * #>> 1 #> POTNUC="0.0"/12 @@ -14608,7 +14608,7 @@ #>> 28 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-779.307469729463"/5 +#> SEWARD_ATTRACT="-779.307469729462"/5 #>> 29 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -14632,15 +14632,15 @@ #>> 34 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1153.352823286957"/5 +#> SEWARD_ATTRACT="-1153.352823286956"/5 #>> 35 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1222.813518359087"/5 +#> SEWARD_ATTRACT="-1222.813518359086"/5 #>> 36 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1294.233361667812"/5 +#> SEWARD_ATTRACT="-1294.233361667811"/5 #>> 37 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -14648,7 +14648,7 @@ #>> 38 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1443.433960313943"/5 +#> SEWARD_ATTRACT="-1443.433960313942"/5 #>> 39 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -14692,7 +14692,7 @@ #>> 49 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-2409.968172077956"/5 +#> SEWARD_ATTRACT="-2409.968172077955"/5 #>> 50 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -14700,7 +14700,7 @@ #>> 51 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-2612.413571729687"/5 +#> SEWARD_ATTRACT="-2612.413571729686"/5 #>> 52 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -14884,7 +14884,7 @@ #>> 97 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-4249.147557815665"/5 +#> SEWARD_ATTRACT="-4249.147557815664"/5 #>> 98 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -14968,7 +14968,7 @@ #>> 118 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-433.090197979136"/5 +#> SEWARD_ATTRACT="-433.090197979137"/5 #>> 119 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -15024,7 +15024,7 @@ #>> 132 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1213.522929076551"/5 +#> SEWARD_ATTRACT="-1213.522929076552"/5 #>> 133 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -15112,7 +15112,7 @@ #>> 154 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-433.090197979136"/5 +#> SEWARD_ATTRACT="-433.090197979137"/5 #>> 155 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -15168,7 +15168,7 @@ #>> 168 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1213.522929076551"/5 +#> SEWARD_ATTRACT="-1213.522929076552"/5 #>> 169 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -15260,7 +15260,7 @@ #>> 191 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-475.789273962015"/5 +#> SEWARD_ATTRACT="-475.789273962016"/5 #>> 192 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -15308,7 +15308,7 @@ #>> 203 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1144.804686969578"/5 +#> SEWARD_ATTRACT="-1144.804686969577"/5 #>> 204 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -15388,11 +15388,11 @@ #>> 223 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-751.851735235987"/5 +#> SEWARD_ATTRACT="-751.851735235986"/5 #>> 224 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-597.776465439375"/5 +#> SEWARD_ATTRACT="-597.776465439374"/5 #>> 225 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -15420,23 +15420,23 @@ #>> 231 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1136.016147768543"/5 +#> SEWARD_ATTRACT="-1136.016147768542"/5 #>> 232 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1227.125920588223"/5 +#> SEWARD_ATTRACT="-1227.125920588224"/5 #>> 233 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1321.776016458120"/5 +#> SEWARD_ATTRACT="-1321.776016458121"/5 #>> 234 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1420.215627602050"/5 +#> SEWARD_ATTRACT="-1420.215627602049"/5 #>> 235 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1521.710531246487"/5 +#> SEWARD_ATTRACT="-1521.710531246486"/5 #>> 236 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -15545,7 +15545,7 @@ #> SEWARD_ATTRACT="-165.008359545426"/5 #>> 256 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-26931.561493197732"/5 +#> SEWARD_ATTRACT="-26931.561493197725"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-191.954083571066"/5 @@ -15635,7 +15635,7 @@ #> SEWARD_ATTRACT="-800.099641522003"/5 #>> 271 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-381033.201471063250"/5 +#> SEWARD_ATTRACT="-381033.201471063483"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-861.070468459356"/5 @@ -15653,7 +15653,7 @@ #> SEWARD_ATTRACT="-990.513725634765"/5 #>> 274 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-420624.449725182960"/5 +#> SEWARD_ATTRACT="-420624.449725183134"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-1059.073730286823"/5 @@ -15692,7 +15692,7 @@ #> SEWARD_ATTRACT="-2233735.445633667056"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1526.875337965257"/5 +#> SEWARD_ATTRACT="-1526.875337965258"/5 #>> 281 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-2260796.189012394752"/5 @@ -15704,10 +15704,10 @@ #> SEWARD_ATTRACT="-2337416.023584011476"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1705.473609663517"/5 +#> SEWARD_ATTRACT="-1705.473609663516"/5 #>> 283 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-2271053.858002217952"/5 +#> SEWARD_ATTRACT="-2271053.858002218883"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-1799.264635850595"/5 @@ -15719,10 +15719,10 @@ #> SEWARD_ATTRACT="-1896.122373812781"/5 #>> 285 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-2419692.537807777058"/5 +#> SEWARD_ATTRACT="-2419692.537807777990"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1996.107785204666"/5 +#> SEWARD_ATTRACT="-1996.107785204667"/5 #>> 286 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-3360963.576562117785"/5 @@ -15731,7 +15731,7 @@ #> SEWARD_ATTRACT="-2099.294452427681"/5 #>> 287 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-2189166.354461865034"/5 +#> SEWARD_ATTRACT="-2189166.354461865965"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-2205.739983078701"/5 @@ -15758,7 +15758,7 @@ #> SEWARD_ATTRACT="-2829968.237481486518"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-2665.560606110318"/5 +#> SEWARD_ATTRACT="-2665.560606110317"/5 #>> 292 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-2924318.212479799520"/5 @@ -15779,22 +15779,22 @@ #> SEWARD_ATTRACT="-3048.352832790870"/5 #>> 295 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-3108387.710311251692"/5 +#> SEWARD_ATTRACT="-3108387.710311252624"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-3183.636507608063"/5 +#> SEWARD_ATTRACT="-3183.636507608064"/5 #>> 296 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-3400419.737038592342"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-3322.919111781336"/5 +#> SEWARD_ATTRACT="-3322.919111781334"/5 #>> 297 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-16124187.929888069630"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-3466.317267935117"/5 +#> SEWARD_ATTRACT="-3466.317267935116"/5 #>> 298 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-13603553.916499743238"/5 @@ -15809,22 +15809,22 @@ #> SEWARD_ATTRACT="-3765.835798623331"/5 #>> 300 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-17066922.594348844141"/5 +#> SEWARD_ATTRACT="-17066922.594348840415"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-3922.202977491999"/5 +#> SEWARD_ATTRACT="-3922.202977491997"/5 #>> 301 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-20890092.401661500335"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-4083.134689839098"/5 +#> SEWARD_ATTRACT="-4083.134689839099"/5 #>> 302 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-16331796.178864479065"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-4248.740634686874"/5 +#> SEWARD_ATTRACT="-4248.740634686875"/5 #>> 303 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-25612387.440873317420"/5 @@ -15842,19 +15842,19 @@ #> SEWARD_ATTRACT="-20542780.890716370195"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-4775.008889486209"/5 +#> SEWARD_ATTRACT="-4775.008889486208"/5 #>> 306 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-19645405.306293591857"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-4960.718636075814"/5 +#> SEWARD_ATTRACT="-4960.718636075813"/5 #>> 307 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-23044845.711614929140"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-5151.854550460263"/5 +#> SEWARD_ATTRACT="-5151.854550460264"/5 #>> 308 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-27305207.757862161845"/5 @@ -15866,7 +15866,7 @@ #> SEWARD_ATTRACT="-25721487.228519078344"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-5551.004377819758"/5 +#> SEWARD_ATTRACT="-5551.004377819759"/5 #>> 310 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-28328618.767774507403"/5 @@ -15890,7 +15890,7 @@ #> SEWARD_ATTRACT="-29329747.339942000806"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-6422.094739700620"/5 +#> SEWARD_ATTRACT="-6422.094739700619"/5 #>> 314 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-34026147.594106830657"/5 @@ -15902,7 +15902,7 @@ #> SEWARD_ATTRACT="-32464920.558587793261"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-6897.356829599079"/5 +#> SEWARD_ATTRACT="-6897.356829599078"/5 #>> 316 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-32862203.238069564104"/5 @@ -15914,7 +15914,7 @@ #> SEWARD_ATTRACT="-38045568.509240120649"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-7401.635325534670"/5 +#> SEWARD_ATTRACT="-7401.635325534672"/5 #>> 318 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-49313868.192154332995"/5 @@ -15923,16 +15923,16 @@ #> SEWARD_ATTRACT="-7665.335684723128"/5 #>> 319 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-48231423.942335918546"/5 +#> SEWARD_ATTRACT="-48231423.942335896194"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-7937.107013883615"/5 +#> SEWARD_ATTRACT="-7937.107013883614"/5 #>> 320 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-53497276.188255675137"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-8217.283192795085"/5 +#> SEWARD_ATTRACT="-8217.283192795088"/5 #>> 321 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-53918601.404688499868"/5 @@ -15944,7 +15944,7 @@ #> SEWARD_ATTRACT="-56051874.667646013200"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-8804.148599645052"/5 +#> SEWARD_ATTRACT="-8804.148599645050"/5 #>> 323 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-58140263.492903895676"/5 @@ -15968,19 +15968,19 @@ #> SEWARD_ATTRACT="-73885904.931873440742"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-10094.485880261371"/5 +#> SEWARD_ATTRACT="-10094.485880261373"/5 #>> 327 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-82968052.147368758917"/5 +#> SEWARD_ATTRACT="-82968052.147368744016"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-10443.846713444893"/5 +#> SEWARD_ATTRACT="-10443.846713444897"/5 #>> 328 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-84941805.802680447698"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-10804.879318336994"/5 +#> SEWARD_ATTRACT="-10804.879318337000"/5 #>> 329 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-249296926.616618603468"/5 @@ -15992,25 +15992,25 @@ #> SEWARD_ATTRACT="-252162408.531752139330"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-11564.195155367992"/5 +#> SEWARD_ATTRACT="-11564.195155367990"/5 #>> 331 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-256686764.493242144585"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-11963.633733252305"/5 +#> SEWARD_ATTRACT="-11963.633733252302"/5 #>> 332 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-259570885.442604392767"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-12377.142210238590"/5 +#> SEWARD_ATTRACT="-12377.142210238593"/5 #>> 333 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-262455006.391966670752"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-12805.437796203702"/5 +#> SEWARD_ATTRACT="-12805.437796203698"/5 #>> 334 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-265339127.341328918934"/5 @@ -16022,67 +16022,67 @@ #> SEWARD_ATTRACT="-269062758.906683981419"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-13709.438689244813"/5 +#> SEWARD_ATTRACT="-13709.438689244807"/5 #>> 336 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-272012347.995654702187"/5 +#> SEWARD_ATTRACT="-272012347.995654761791"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-14186.864919695367"/5 +#> SEWARD_ATTRACT="-14186.864919695361"/5 #>> 337 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-274906096.378587245941"/5 +#> SEWARD_ATTRACT="-274906096.378587305546"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-14682.484617083124"/5 +#> SEWARD_ATTRACT="-14682.484617083121"/5 #>> 338 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-277799844.761519730091"/5 +#> SEWARD_ATTRACT="-277799844.761519789696"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-15197.320389687875"/5 +#> SEWARD_ATTRACT="-15197.320389687868"/5 #>> 339 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-280728891.282880067825"/5 +#> SEWARD_ATTRACT="-280728891.282879889011"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-15732.514577475336"/5 +#> SEWARD_ATTRACT="-15732.514577475335"/5 #>> 340 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-283623003.564146935940"/5 +#> SEWARD_ATTRACT="-283623003.564146757126"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-16289.283036763172"/5 +#> SEWARD_ATTRACT="-16289.283036763178"/5 #>> 341 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-286517020.026180505753"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-16868.944240515601"/5 +#> SEWARD_ATTRACT="-16868.944240515593"/5 #>> 342 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-290429432.134088277817"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-17472.935120687587"/5 +#> SEWARD_ATTRACT="-17472.935120687594"/5 #>> 343 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-293658266.209897518158"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-18102.838579780975"/5 +#> SEWARD_ATTRACT="-18102.838579780979"/5 #>> 344 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-293389136.277115523815"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-18760.379153418915"/5 +#> SEWARD_ATTRACT="-18760.379153418911"/5 #>> 345 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-327387982.659612417221"/5 +#> SEWARD_ATTRACT="-327387982.659612357616"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-19447.462870984553"/5 +#> SEWARD_ATTRACT="-19447.462870984549"/5 #>> 346 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -16130,7 +16130,7 @@ #>> 357 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-139.174738931288"/5 +#> SEWARD_ATTRACT="-139.174738931289"/5 #>> 358 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -16303,13 +16303,13 @@ #> SEWARD_ATTRACT="-23.400755065158"/5 #>> 398 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1194.564255944884"/5 +#> SEWARD_ATTRACT="-1194.564255944883"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-34.054657222602"/5 #>> 399 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-2391.202420126483"/5 +#> SEWARD_ATTRACT="-2391.202420126484"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-46.692327230272"/5 @@ -16357,25 +16357,25 @@ #> SEWARD_ATTRACT="-189.526577628518"/5 #>> 407 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-18053.388214194609"/5 +#> SEWARD_ATTRACT="-18053.388214194605"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-217.622589501175"/5 +#> SEWARD_ATTRACT="-217.622589501176"/5 #>> 408 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-29043.830906467152"/5 +#> SEWARD_ATTRACT="-29043.830906467145"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-247.176039989985"/5 #>> 409 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-33805.251349694518"/5 +#> SEWARD_ATTRACT="-33805.251349694503"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-279.642198123433"/5 #>> 410 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-39710.979657581825"/5 +#> SEWARD_ATTRACT="-39710.979657581840"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-314.065604251692"/5 @@ -16393,13 +16393,13 @@ #> SEWARD_ATTRACT="-403.308206672884"/5 #>> 413 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-54899.350659833799"/5 +#> SEWARD_ATTRACT="-54899.350659833814"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-397.129334398607"/5 #>> 414 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-61550.864460095814"/5 +#> SEWARD_ATTRACT="-61550.864460095829"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-464.688843226546"/5 @@ -16411,7 +16411,7 @@ #> SEWARD_ATTRACT="-520.809839487370"/5 #>> 416 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-100373.113669425089"/5 +#> SEWARD_ATTRACT="-100373.113669425104"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-578.320156336695"/5 @@ -16420,13 +16420,13 @@ #> SEWARD_ATTRACT="-108991.065609594356"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-632.374586004420"/5 +#> SEWARD_ATTRACT="-632.374586004419"/5 #>> 418 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-118846.677716970604"/5 +#> SEWARD_ATTRACT="-118846.677716970575"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-678.026145523819"/5 +#> SEWARD_ATTRACT="-678.026145523818"/5 #>> 419 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-129351.221922852201"/5 @@ -16459,7 +16459,7 @@ #> SEWARD_ATTRACT="-943.554756694203"/5 #>> 424 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-191732.527720225160"/5 +#> SEWARD_ATTRACT="-191732.527720225218"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-1002.265119105842"/5 @@ -16480,7 +16480,7 @@ #> SEWARD_ATTRACT="-275684.619789394550"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1219.846745615681"/5 +#> SEWARD_ATTRACT="-1219.846745615682"/5 #>> 428 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-289134.175663489383"/5 @@ -16489,7 +16489,7 @@ #> SEWARD_ATTRACT="-1277.866920206909"/5 #>> 429 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-276678.034340017068"/5 +#> SEWARD_ATTRACT="-276678.034340017126"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-1362.580478440648"/5 @@ -16498,22 +16498,22 @@ #> SEWARD_ATTRACT="-277082.507064785284"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1575.028721217192"/5 +#> SEWARD_ATTRACT="-1575.028721217191"/5 #>> 431 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-327393.969952464686"/5 +#> SEWARD_ATTRACT="-327393.969952464860"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-1383.509235022699"/5 #>> 432 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-340787.928389106935"/5 +#> SEWARD_ATTRACT="-340787.928389106994"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1687.226515588534"/5 +#> SEWARD_ATTRACT="-1687.226515588535"/5 #>> 433 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-354657.516638412664"/5 +#> SEWARD_ATTRACT="-354657.516638412548"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-1788.088989190291"/5 @@ -16522,7 +16522,7 @@ #> SEWARD_ATTRACT="-364600.255670307553"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1864.814168781017"/5 +#> SEWARD_ATTRACT="-1864.814168781016"/5 #>> 435 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-374489.459281743562"/5 @@ -16531,16 +16531,16 @@ #> SEWARD_ATTRACT="-1998.439965368492"/5 #>> 436 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-387055.797278537066"/5 +#> SEWARD_ATTRACT="-387055.797278537182"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-2107.871580819082"/5 +#> SEWARD_ATTRACT="-2107.871580819083"/5 #>> 437 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-399014.139700586325"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-2212.608031505475"/5 +#> SEWARD_ATTRACT="-2212.608031505476"/5 #>> 438 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-413323.578090818773"/5 @@ -16549,10 +16549,10 @@ #> SEWARD_ATTRACT="-2107.848076963413"/5 #>> 439 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-393939.504396266071"/5 +#> SEWARD_ATTRACT="-393939.504396265955"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-2428.716282884959"/5 +#> SEWARD_ATTRACT="-2428.716282884960"/5 #>> 440 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-426333.523192146502"/5 @@ -16570,7 +16570,7 @@ #> SEWARD_ATTRACT="-451026.071112716862"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-2537.166716342375"/5 +#> SEWARD_ATTRACT="-2537.166716342376"/5 #>> 443 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-464934.430013529491"/5 @@ -16588,13 +16588,13 @@ #> SEWARD_ATTRACT="-487155.383315157029"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-2901.772733291791"/5 +#> SEWARD_ATTRACT="-2901.772733291790"/5 #>> 446 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-494707.391649321245"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-3011.885680233128"/5 +#> SEWARD_ATTRACT="-3011.885680233129"/5 #>> 447 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-507597.748410027125"/5 @@ -16609,13 +16609,13 @@ #> SEWARD_ATTRACT="-3212.508379346300"/5 #>> 449 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-541388.645862875157"/5 +#> SEWARD_ATTRACT="-541388.645862875041"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-3255.822697926378"/5 #>> 450 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-539398.385442026425"/5 +#> SEWARD_ATTRACT="-539398.385442026542"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-4018.105713715023"/5 @@ -16624,13 +16624,13 @@ #> SEWARD_ATTRACT="-550098.282795334235"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-3984.238858739308"/5 +#> SEWARD_ATTRACT="-3984.238858739310"/5 #>> 452 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-561053.259091296466"/5 +#> SEWARD_ATTRACT="-561053.259091296117"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-4142.169342246517"/5 +#> SEWARD_ATTRACT="-4142.169342246516"/5 #>> 453 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-569818.106045952416"/5 @@ -16642,7 +16642,7 @@ #> SEWARD_ATTRACT="-574541.767162932432"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-4629.535605901203"/5 +#> SEWARD_ATTRACT="-4629.535605901202"/5 #>> 455 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-585143.644088152214"/5 @@ -16657,7 +16657,7 @@ #> SEWARD_ATTRACT="-5078.538279749920"/5 #>> 457 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-602401.982550559449"/5 +#> SEWARD_ATTRACT="-602401.982550559565"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-5011.881558279503"/5 @@ -16666,7 +16666,7 @@ #> SEWARD_ATTRACT="-608738.827037094976"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-5199.829102733767"/5 +#> SEWARD_ATTRACT="-5199.829102733769"/5 #>> 459 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-619184.264061396359"/5 @@ -16678,49 +16678,49 @@ #> SEWARD_ATTRACT="-629400.411899772706"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-5579.709715909770"/5 +#> SEWARD_ATTRACT="-5579.709715909769"/5 #>> 461 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-637578.299669176922"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-5719.585935015310"/5 +#> SEWARD_ATTRACT="-5719.585935015309"/5 #>> 462 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-643532.932100763079"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-5872.936382925693"/5 +#> SEWARD_ATTRACT="-5872.936382925694"/5 #>> 463 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-654384.721376518137"/5 +#> SEWARD_ATTRACT="-654384.721376517904"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-5386.616655990061"/5 +#> SEWARD_ATTRACT="-5386.616655990060"/5 #>> 464 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-660674.096291605500"/5 +#> SEWARD_ATTRACT="-660674.096291605849"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-6431.698060157437"/5 +#> SEWARD_ATTRACT="-6431.698060157438"/5 #>> 465 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-670750.825358735281"/5 +#> SEWARD_ATTRACT="-670750.825358735048"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-4816.132604269133"/5 #>> 466 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-678646.547918656259"/5 +#> SEWARD_ATTRACT="-678646.547918655910"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-7101.372491102193"/5 +#> SEWARD_ATTRACT="-7101.372491102195"/5 #>> 467 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-686212.305833983584"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-4969.354392540705"/5 +#> SEWARD_ATTRACT="-4969.354392540704"/5 #>> 468 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-691843.968992682756"/5 @@ -16732,28 +16732,28 @@ #> SEWARD_ATTRACT="-701287.698659170768"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-8041.425963846410"/5 +#> SEWARD_ATTRACT="-8041.425963846411"/5 #>> 470 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-714609.873265509261"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-7473.873913220601"/5 +#> SEWARD_ATTRACT="-7473.873913220602"/5 #>> 471 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-722593.215289068758"/5 +#> SEWARD_ATTRACT="-722593.215289068874"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-5488.025932852582"/5 +#> SEWARD_ATTRACT="-5488.025932852584"/5 #>> 472 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-722945.584070627345"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-9247.681279036633"/5 +#> SEWARD_ATTRACT="-9247.681279036631"/5 #>> 473 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-731694.104682109784"/5 +#> SEWARD_ATTRACT="-731694.104682109668"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-5580.484270632252"/5 @@ -16774,19 +16774,19 @@ #> SEWARD_ATTRACT="-759491.008330600802"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-8314.178700151455"/5 +#> SEWARD_ATTRACT="-8314.178700151457"/5 #>> 477 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-768603.353715382633"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-8553.353500754762"/5 +#> SEWARD_ATTRACT="-8553.353500754756"/5 #>> 478 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-766141.064216502942"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-8007.209273360068"/5 +#> SEWARD_ATTRACT="-8007.209273360070"/5 #>> 479 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="10"/5 @@ -16835,7 +16835,7 @@ #> SEWARD_ATTRACT="-46.620674220340"/5 #>> 487 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-4144.085765359448"/5 +#> SEWARD_ATTRACT="-4144.085765359449"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-61.329995062857"/5 @@ -16853,7 +16853,7 @@ #> SEWARD_ATTRACT="-96.650247561460"/5 #>> 490 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-6539.075585578532"/5 +#> SEWARD_ATTRACT="-6539.075585578534"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-119.724931591653"/5 @@ -16943,7 +16943,7 @@ #> SEWARD_ATTRACT="-631.829587461357"/5 #>> 505 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-86198.052828170970"/5 +#> SEWARD_ATTRACT="-86198.052828170941"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-685.483762330828"/5 @@ -16952,10 +16952,10 @@ #> SEWARD_ATTRACT="-93175.975580877202"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-741.538331909452"/5 +#> SEWARD_ATTRACT="-741.538331909453"/5 #>> 507 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-100389.477019330530"/5 +#> SEWARD_ATTRACT="-100389.477019330574"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-800.020881647905"/5 @@ -16964,13 +16964,13 @@ #> SEWARD_ATTRACT="-139975.520754596218"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-860.968902305526"/5 +#> SEWARD_ATTRACT="-860.968902305527"/5 #>> 509 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-115492.448234074487"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-924.404571404334"/5 +#> SEWARD_ATTRACT="-924.404571404335"/5 #>> 510 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-159191.139561881981"/5 @@ -17006,7 +17006,7 @@ #> SEWARD_ATTRACT="-247331.355552463065"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1359.555671129818"/5 +#> SEWARD_ATTRACT="-1359.555671129817"/5 #>> 516 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-252309.157956843614"/5 @@ -17042,7 +17042,7 @@ #> SEWARD_ATTRACT="-308165.452915537870"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1895.333712668214"/5 +#> SEWARD_ATTRACT="-1895.333712668213"/5 #>> 522 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-330164.377308010997"/5 @@ -17051,10 +17051,10 @@ #> SEWARD_ATTRACT="-1995.210449184076"/5 #>> 523 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-344035.567935226252"/5 +#> SEWARD_ATTRACT="-344035.567935226078"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-2098.270105575753"/5 +#> SEWARD_ATTRACT="-2098.270105575754"/5 #>> 524 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-359377.438448840869"/5 @@ -17090,7 +17090,7 @@ #> SEWARD_ATTRACT="-440490.319840435579"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-2787.294324051271"/5 +#> SEWARD_ATTRACT="-2787.294324051273"/5 #>> 530 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-459749.042680855899"/5 @@ -17102,7 +17102,7 @@ #> SEWARD_ATTRACT="-473441.320997948060"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-3045.708979383092"/5 +#> SEWARD_ATTRACT="-3045.708979383093"/5 #>> 532 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-494589.334992132965"/5 @@ -17114,13 +17114,13 @@ #> SEWARD_ATTRACT="-510118.583186065953"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-3319.634787459711"/5 +#> SEWARD_ATTRACT="-3319.634787459712"/5 #>> 534 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-580470.366752359667"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-3462.676467253465"/5 +#> SEWARD_ATTRACT="-3462.676467253466"/5 #>> 535 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-597182.800971931079"/5 @@ -17132,19 +17132,19 @@ #> SEWARD_ATTRACT="-605643.779844235396"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-3761.346702608219"/5 +#> SEWARD_ATTRACT="-3761.346702608221"/5 #>> 537 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-622193.616649312200"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-3917.231653104770"/5 +#> SEWARD_ATTRACT="-3917.231653104769"/5 #>> 538 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-638077.143669596524"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-4077.633271469854"/5 +#> SEWARD_ATTRACT="-4077.633271469855"/5 #>> 539 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-652366.579417593312"/5 @@ -17162,13 +17162,13 @@ #> SEWARD_ATTRACT="-678311.467991441139"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-4587.155149469799"/5 +#> SEWARD_ATTRACT="-4587.155149469798"/5 #>> 542 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-695099.777937036240"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-4766.889086453852"/5 +#> SEWARD_ATTRACT="-4766.889086453851"/5 #>> 543 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-705785.765792997205"/5 @@ -17186,7 +17186,7 @@ #> SEWARD_ATTRACT="-735010.832907788921"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-5337.776447786790"/5 +#> SEWARD_ATTRACT="-5337.776447786787"/5 #>> 546 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-751628.800829784013"/5 @@ -17210,7 +17210,7 @@ #> SEWARD_ATTRACT="-789345.935693690088"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-6179.291078526427"/5 +#> SEWARD_ATTRACT="-6179.291078526426"/5 #>> 550 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-803670.172984546283"/5 @@ -17222,31 +17222,31 @@ #> SEWARD_ATTRACT="-815186.654229405918"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-6637.812508297504"/5 +#> SEWARD_ATTRACT="-6637.812508297507"/5 #>> 552 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-831397.645177925006"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-6877.275737261673"/5 +#> SEWARD_ATTRACT="-6877.275737261671"/5 #>> 553 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-841165.376096604043"/5 +#> SEWARD_ATTRACT="-841165.376096603693"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-7123.835684130268"/5 +#> SEWARD_ATTRACT="-7123.835684130272"/5 #>> 554 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-858514.701799059403"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-7377.776255804613"/5 +#> SEWARD_ATTRACT="-7377.776255804615"/5 #>> 555 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-869654.789888871717"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-7639.328855141685"/5 +#> SEWARD_ATTRACT="-7639.328855141684"/5 #>> 556 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-885041.478213727823"/5 @@ -17258,25 +17258,25 @@ #> SEWARD_ATTRACT="-895040.474416621495"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-8186.464606267256"/5 +#> SEWARD_ATTRACT="-8186.464606267253"/5 #>> 558 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-903420.505001875339"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-8472.627949193207"/5 +#> SEWARD_ATTRACT="-8472.627949193205"/5 #>> 559 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-923330.011081317789"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-8767.688496554803"/5 +#> SEWARD_ATTRACT="-8767.688496554802"/5 #>> 560 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-939906.864512811182"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-9071.927910028697"/5 +#> SEWARD_ATTRACT="-9071.927910028699"/5 #>> 561 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-955194.306822705083"/5 @@ -17288,7 +17288,7 @@ #> SEWARD_ATTRACT="-972009.693150851876"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-9709.499182416965"/5 +#> SEWARD_ATTRACT="-9709.499182416967"/5 #>> 563 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-989562.115825148067"/5 @@ -17306,55 +17306,55 @@ #> SEWARD_ATTRACT="-1007606.787731505116"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-10744.740927271838"/5 +#> SEWARD_ATTRACT="-10744.740927271836"/5 #>> 566 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-1024488.194778485340"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-11075.391536364652"/5 +#> SEWARD_ATTRACT="-11075.391536364650"/5 #>> 567 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-1037796.808292672154"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-11451.050440984229"/5 +#> SEWARD_ATTRACT="-11451.050440984232"/5 #>> 568 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-1052279.446751907934"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-11886.345864063704"/5 +#> SEWARD_ATTRACT="-11886.345864063702"/5 #>> 569 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-1060951.874751137570"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-12292.985339171875"/5 +#> SEWARD_ATTRACT="-12292.985339171873"/5 #>> 570 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-1077100.541075595189"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-12713.891548632469"/5 +#> SEWARD_ATTRACT="-12713.891548632471"/5 #>> 571 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-1083338.975531573407"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-13149.440004186517"/5 +#> SEWARD_ATTRACT="-13149.440004186514"/5 #>> 572 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-1099257.365476901177"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-13600.745066079291"/5 +#> SEWARD_ATTRACT="-13600.745066079287"/5 #>> 573 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-1104852.653799640946"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-14068.165470603350"/5 +#> SEWARD_ATTRACT="-14068.165470603351"/5 #>> 574 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-1120555.453236301895"/5 @@ -17366,7 +17366,7 @@ #> SEWARD_ATTRACT="-1129713.552873898298"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-15055.852774864174"/5 +#> SEWARD_ATTRACT="-15055.852774864175"/5 #>> 576 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -17434,7 +17434,7 @@ #>> 592 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-276.217884597258"/5 +#> SEWARD_ATTRACT="-276.217884597257"/5 #>> 593 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -17462,7 +17462,7 @@ #>> 599 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-525.548319950191"/5 +#> SEWARD_ATTRACT="-525.548319950192"/5 #>> 600 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -17506,7 +17506,7 @@ #>> 610 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1137.903774641447"/5 +#> SEWARD_ATTRACT="-1137.903774641446"/5 #>> 611 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -17662,7 +17662,7 @@ #>> 649 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-415.267506799505"/5 +#> SEWARD_ATTRACT="-415.267506799504"/5 #>> 650 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -17698,7 +17698,7 @@ #>> 658 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-945.801224100191"/5 +#> SEWARD_ATTRACT="-945.801224100190"/5 #>> 659 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -17866,7 +17866,7 @@ #>> 700 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-568.441681030971"/5 +#> SEWARD_ATTRACT="-568.441681030970"/5 #>> 701 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -17990,7 +17990,7 @@ #>> 731 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-415.309343965859"/5 +#> SEWARD_ATTRACT="-415.309343965860"/5 #>> 732 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18010,7 +18010,7 @@ #>> 736 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-647.823912648633"/5 +#> SEWARD_ATTRACT="-647.823912648634"/5 #>> 737 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18034,7 +18034,7 @@ #>> 742 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1072.666327352263"/5 +#> SEWARD_ATTRACT="-1072.666327352264"/5 #>> 743 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18114,7 +18114,7 @@ #>> 762 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-281.514145720715"/5 +#> SEWARD_ATTRACT="-281.514145720716"/5 #>> 763 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18138,7 +18138,7 @@ #>> 768 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-568.441681030971"/5 +#> SEWARD_ATTRACT="-568.441681030970"/5 #>> 769 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18338,7 +18338,7 @@ #>> 818 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-163.057864904843"/5 +#> SEWARD_ATTRACT="-163.057864904842"/5 #>> 819 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18382,7 +18382,7 @@ #>> 829 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-564.471122426516"/5 +#> SEWARD_ATTRACT="-564.471122426517"/5 #>> 830 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18402,7 +18402,7 @@ #>> 834 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-826.725170515313"/5 +#> SEWARD_ATTRACT="-826.725170515314"/5 #>> 835 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18538,7 +18538,7 @@ #>> 868 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-715.895447856546"/5 +#> SEWARD_ATTRACT="-715.895447856545"/5 #>> 869 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18654,7 +18654,7 @@ #>> 897 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-390.719681808283"/5 +#> SEWARD_ATTRACT="-390.719681808284"/5 #>> 898 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18678,7 +18678,7 @@ #>> 903 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-663.444601783634"/5 +#> SEWARD_ATTRACT="-663.444601783633"/5 #>> 904 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18710,7 +18710,7 @@ #>> 911 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1139.022139071003"/5 +#> SEWARD_ATTRACT="-1139.022139071002"/5 #>> 912 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18718,7 +18718,7 @@ #>> 913 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1277.875085346620"/5 +#> SEWARD_ATTRACT="-1277.875085346619"/5 #>> 914 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18826,7 +18826,7 @@ #>> 940 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-715.899843465451"/5 +#> SEWARD_ATTRACT="-715.899843465452"/5 #>> 941 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18842,11 +18842,11 @@ #>> 944 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-945.708611503661"/5 +#> SEWARD_ATTRACT="-945.708611503660"/5 #>> 945 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1008.157403459582"/5 +#> SEWARD_ATTRACT="-1008.157403459583"/5 #>> 946 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18946,7 +18946,7 @@ #>> 970 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-415.267506799505"/5 +#> SEWARD_ATTRACT="-415.267506799504"/5 #>> 971 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18982,7 +18982,7 @@ #>> 979 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-945.801224100191"/5 +#> SEWARD_ATTRACT="-945.801224100190"/5 #>> 980 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -19078,7 +19078,7 @@ #>> 1003 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-386.230539719089"/5 +#> SEWARD_ATTRACT="-386.230539719088"/5 #>> 1004 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -19138,7 +19138,7 @@ #>> 1018 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1359.566789709794"/5 +#> SEWARD_ATTRACT="-1359.566789709795"/5 #>> 1019 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -19234,7 +19234,7 @@ #>> 1042 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-568.441681030971"/5 +#> SEWARD_ATTRACT="-568.441681030970"/5 #>> 1043 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -19310,7 +19310,7 @@ #>> 1061 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-61.324591723519"/5 +#> SEWARD_ATTRACT="-61.324591723518"/5 #>> 1062 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -19346,7 +19346,7 @@ #>> 1070 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-285.469008022333"/5 +#> SEWARD_ATTRACT="-285.469008022332"/5 #>> 1071 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -19498,7 +19498,7 @@ #>> 1108 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-415.309343965859"/5 +#> SEWARD_ATTRACT="-415.309343965860"/5 #>> 1109 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -19518,7 +19518,7 @@ #>> 1113 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-647.823912648633"/5 +#> SEWARD_ATTRACT="-647.823912648634"/5 #>> 1114 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -19542,7 +19542,7 @@ #>> 1119 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1072.666327352263"/5 +#> SEWARD_ATTRACT="-1072.666327352264"/5 #>> 1120 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -19642,7 +19642,7 @@ #>> 1144 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-516.461269590460"/5 +#> SEWARD_ATTRACT="-516.461269590459"/5 #>> 1145 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -19662,11 +19662,11 @@ #>> 1149 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-765.518306438723"/5 +#> SEWARD_ATTRACT="-765.518306438722"/5 #>> 1150 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-924.412690487132"/5 +#> SEWARD_ATTRACT="-924.412690487131"/5 #>> 1151 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -19786,7 +19786,7 @@ #>> 1180 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-568.441681030971"/5 +#> SEWARD_ATTRACT="-568.441681030970"/5 #>> 1181 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -19898,7 +19898,7 @@ #>> 1208 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-285.481901330383"/5 +#> SEWARD_ATTRACT="-285.481901330382"/5 #>> 1209 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -19946,7 +19946,7 @@ #>> 1220 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-990.369307174552"/5 +#> SEWARD_ATTRACT="-990.369307174553"/5 #>> 1221 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -19954,7 +19954,7 @@ #>> 1222 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1130.044244024854"/5 +#> SEWARD_ATTRACT="-1130.044244024855"/5 #>> 1223 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -19986,7 +19986,7 @@ #>> 1230 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1915.165322765549"/5 +#> SEWARD_ATTRACT="-1915.165322765548"/5 #>> 1231 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -19998,11 +19998,11 @@ #>> 1233 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1758.206652251875"/5 +#> SEWARD_ATTRACT="-1758.206652251876"/5 #>> 1234 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-386.230539719089"/5 +#> SEWARD_ATTRACT="-386.230539719088"/5 #>> 1235 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -20054,7 +20054,7 @@ #>> 1247 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-516.461269590460"/5 +#> SEWARD_ATTRACT="-516.461269590459"/5 #>> 1248 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -20074,11 +20074,11 @@ #>> 1252 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-765.518306438723"/5 +#> SEWARD_ATTRACT="-765.518306438722"/5 #>> 1253 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-924.412690487132"/5 +#> SEWARD_ATTRACT="-924.412690487131"/5 #>> 1254 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -20138,7 +20138,7 @@ #>> 1268 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1915.165322765549"/5 +#> SEWARD_ATTRACT="-1915.165322765548"/5 #>> 1269 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -20150,7 +20150,7 @@ #>> 1271 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1758.206652251875"/5 +#> SEWARD_ATTRACT="-1758.206652251876"/5 #>> 1272 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -20242,7 +20242,7 @@ #>> 1294 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-475.789273962015"/5 +#> SEWARD_ATTRACT="-475.789273962016"/5 #>> 1295 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -20290,7 +20290,7 @@ #>> 1306 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1144.804686969578"/5 +#> SEWARD_ATTRACT="-1144.804686969577"/5 #>> 1307 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -20398,7 +20398,7 @@ #>> 1333 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-614.649066358927"/5 +#> SEWARD_ATTRACT="-614.649066358928"/5 #>> 1334 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -20422,7 +20422,7 @@ #>> 1339 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-948.382218909014"/5 +#> SEWARD_ATTRACT="-948.382218909015"/5 #>> 1340 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -20438,7 +20438,7 @@ #>> 1343 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1211.090381622254"/5 +#> SEWARD_ATTRACT="-1211.090381622255"/5 #>> 1344 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -20530,7 +20530,7 @@ #>> 1366 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-475.789273962015"/5 +#> SEWARD_ATTRACT="-475.789273962016"/5 #>> 1367 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -20578,7 +20578,7 @@ #>> 1378 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1144.804686969578"/5 +#> SEWARD_ATTRACT="-1144.804686969577"/5 #>> 1379 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -20686,7 +20686,7 @@ #>> 1405 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-614.649066358927"/5 +#> SEWARD_ATTRACT="-614.649066358928"/5 #>> 1406 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -20710,7 +20710,7 @@ #>> 1411 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-948.382218909014"/5 +#> SEWARD_ATTRACT="-948.382218909015"/5 #>> 1412 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -20726,7 +20726,7 @@ #>> 1415 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1211.090381622254"/5 +#> SEWARD_ATTRACT="-1211.090381622255"/5 #>> 1416 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -20830,7 +20830,7 @@ #>> 1441 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-614.649066358927"/5 +#> SEWARD_ATTRACT="-614.649066358928"/5 #>> 1442 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -20854,7 +20854,7 @@ #>> 1447 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-948.382218909014"/5 +#> SEWARD_ATTRACT="-948.382218909015"/5 #>> 1448 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -20870,7 +20870,7 @@ #>> 1451 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1211.090381622254"/5 +#> SEWARD_ATTRACT="-1211.090381622255"/5 #>> 1452 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -21046,7 +21046,7 @@ #>> 1495 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-30970.375728060131"/5 +#> SEWARD_ATTRACT="-30970.375728060135"/5 #>> 1496 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -21058,11 +21058,11 @@ #>> 1498 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-129797.012783502432"/5 +#> SEWARD_ATTRACT="-129797.012783502476"/5 #>> 1499 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-153468.835387459229"/5 +#> SEWARD_ATTRACT="-153468.835387459170"/5 #>> 1500 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -21094,15 +21094,15 @@ #>> 1507 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-323316.808189989068"/5 +#> SEWARD_ATTRACT="-323316.808189988951"/5 #>> 1508 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-338006.316978532996"/5 +#> SEWARD_ATTRACT="-338006.316978533054"/5 #>> 1509 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-358149.695271294389"/5 +#> SEWARD_ATTRACT="-358149.695271294331"/5 #>> 1510 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -21270,7 +21270,7 @@ #>> 1551 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-163.057864904843"/5 +#> SEWARD_ATTRACT="-163.057864904842"/5 #>> 1552 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -21314,7 +21314,7 @@ #>> 1562 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-564.471122426516"/5 +#> SEWARD_ATTRACT="-564.471122426517"/5 #>> 1563 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -21334,7 +21334,7 @@ #>> 1567 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-826.725170515313"/5 +#> SEWARD_ATTRACT="-826.725170515314"/5 #>> 1568 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -21470,7 +21470,7 @@ #>> 1601 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-715.895447856546"/5 +#> SEWARD_ATTRACT="-715.895447856545"/5 #>> 1602 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -21586,7 +21586,7 @@ #>> 1630 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-390.719681808283"/5 +#> SEWARD_ATTRACT="-390.719681808284"/5 #>> 1631 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -21610,7 +21610,7 @@ #>> 1636 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-663.444601783634"/5 +#> SEWARD_ATTRACT="-663.444601783633"/5 #>> 1637 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -21642,7 +21642,7 @@ #>> 1644 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1139.022139071003"/5 +#> SEWARD_ATTRACT="-1139.022139071002"/5 #>> 1645 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -21650,7 +21650,7 @@ #>> 1646 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1277.875085346620"/5 +#> SEWARD_ATTRACT="-1277.875085346619"/5 #>> 1647 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -21758,7 +21758,7 @@ #>> 1673 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-715.899843465451"/5 +#> SEWARD_ATTRACT="-715.899843465452"/5 #>> 1674 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -21774,11 +21774,11 @@ #>> 1677 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-945.708611503661"/5 +#> SEWARD_ATTRACT="-945.708611503660"/5 #>> 1678 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1008.157403459582"/5 +#> SEWARD_ATTRACT="-1008.157403459583"/5 #>> 1679 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -21806,7 +21806,7 @@ #> SEWARD_ATTRACT="-42293.083911897484"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1613.612193915639"/5 +#> SEWARD_ATTRACT="-1613.612193915640"/5 #>> 1685 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-44104.449326853508"/5 @@ -21830,13 +21830,13 @@ #> SEWARD_ATTRACT="-53194.217977847351"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1994.385899168938"/5 +#> SEWARD_ATTRACT="-1994.385899168937"/5 #>> 1689 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-55079.508200668883"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-2097.339106576168"/5 +#> SEWARD_ATTRACT="-2097.339106576169"/5 #>> 1690 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-58644.252111915674"/5 @@ -21845,7 +21845,7 @@ #> SEWARD_ATTRACT="-2203.574366765675"/5 #>> 1691 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-62375.098622918980"/5 +#> SEWARD_ATTRACT="-62375.098622918951"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-2313.117667832897"/5 @@ -21854,7 +21854,7 @@ #> SEWARD_ATTRACT="-654238.710740457405"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-6637.409523145005"/5 +#> SEWARD_ATTRACT="-6637.409523145006"/5 #>> 1693 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-674532.582687902497"/5 @@ -21869,34 +21869,34 @@ #> SEWARD_ATTRACT="-7123.402414124468"/5 #>> 1695 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-715917.397283183760"/5 +#> SEWARD_ATTRACT="-715917.397283183411"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-7377.327437645469"/5 +#> SEWARD_ATTRACT="-7377.327437645468"/5 #>> 1696 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-737093.373916848330"/5 +#> SEWARD_ATTRACT="-737093.373916848563"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-7638.890485026383"/5 +#> SEWARD_ATTRACT="-7638.890485026381"/5 #>> 1697 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-758481.086783933337"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-7908.310006631547"/5 +#> SEWARD_ATTRACT="-7908.310006631550"/5 #>> 1698 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-778838.386553922086"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-8186.001268650532"/5 +#> SEWARD_ATTRACT="-8186.001268650536"/5 #>> 1699 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-800312.870530933724"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-8472.167083169825"/5 +#> SEWARD_ATTRACT="-8472.167083169827"/5 #>> 1700 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-824001.329335996648"/5 @@ -21908,25 +21908,25 @@ #> SEWARD_ATTRACT="-869907.287052758038"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-9071.607967705126"/5 +#> SEWARD_ATTRACT="-9071.607967705128"/5 #>> 1702 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-939493.572221675189"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-10043.442760001650"/5 +#> SEWARD_ATTRACT="-10043.442760001659"/5 #>> 1703 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-1082957.209565467201"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-12293.801853228377"/5 +#> SEWARD_ATTRACT="-12293.801853228375"/5 #>> 1704 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_ATTRACT="-671770.260801145341"/5 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-13134.969333268911"/5 +#> SEWARD_ATTRACT="-13134.969333268913"/5 #>> 1705 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -21994,7 +21994,7 @@ #>> 1721 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1008.228552271590"/5 +#> SEWARD_ATTRACT="-1008.228552271591"/5 #>> 1722 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -22014,7 +22014,7 @@ #>> 1726 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1424.579253789418"/5 +#> SEWARD_ATTRACT="-1424.579253789419"/5 #>> 1727 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -22030,11 +22030,11 @@ #>> 1730 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-2780.738007521269"/5 +#> SEWARD_ATTRACT="-2780.738007521268"/5 #>> 1731 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-34746.692133122968"/5 +#> SEWARD_ATTRACT="-34746.692133122961"/5 #>> 1732 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -22066,15 +22066,15 @@ #>> 1739 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-51332.357049626953"/5 +#> SEWARD_ATTRACT="-51332.357049626960"/5 #>> 1740 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-52624.718279299166"/5 +#> SEWARD_ATTRACT="-52624.718279299159"/5 #>> 1741 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-55073.240613283400"/5 +#> SEWARD_ATTRACT="-55073.240613283422"/5 #>> 1742 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -22082,15 +22082,15 @@ #>> 1743 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-60080.465263651517"/5 +#> SEWARD_ATTRACT="-60080.465263651531"/5 #>> 1744 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-62727.088698889886"/5 +#> SEWARD_ATTRACT="-62727.088698889864"/5 #>> 1745 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-66279.859081216593"/5 +#> SEWARD_ATTRACT="-66279.859081216578"/5 #>> 1746 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -22150,7 +22150,7 @@ #>> 1760 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-215.152005107382"/5 +#> SEWARD_ATTRACT="-215.152005107383"/5 #>> 1761 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -22218,7 +22218,7 @@ #>> 1777 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-993.952803419622"/5 +#> SEWARD_ATTRACT="-993.952803419621"/5 #>> 1778 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -22226,7 +22226,7 @@ #>> 1779 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1122.331779065204"/5 +#> SEWARD_ATTRACT="-1122.331779065203"/5 #>> 1780 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -22242,11 +22242,11 @@ #>> 1783 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1402.474527849851"/5 +#> SEWARD_ATTRACT="-1402.474527849852"/5 #>> 1784 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1477.189152885544"/5 +#> SEWARD_ATTRACT="-1477.189152885545"/5 #>> 1785 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -22278,7 +22278,7 @@ #>> 1792 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-2145.634283534676"/5 +#> SEWARD_ATTRACT="-2145.634283534677"/5 #>> 1793 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -22286,7 +22286,7 @@ #>> 1794 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-2332.425792245664"/5 +#> SEWARD_ATTRACT="-2332.425792245665"/5 #>> 1795 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -22298,7 +22298,7 @@ #>> 1797 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-2626.971360565773"/5 +#> SEWARD_ATTRACT="-2626.971360565774"/5 #>> 1798 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 diff -Nru openmolcas-22.02/test/exhaustive/ecp.input openmolcas-22.10/test/exhaustive/ecp.input --- openmolcas-22.02/test/exhaustive/ecp.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/exhaustive/ecp.input 2022-10-10 14:22:40.000000000 +0000 @@ -12817,9 +12817,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.02-1119-gde6a49c4e -* Linux otis 4.15.0-1073-oem #83-Ubuntu SMP Mon Feb 17 11:21:18 UTC 2020 x86_64 x86_64 x86_64 GNU/Linux -* Thu May 13 21:27:58 2021 +* Molcas version 22.02-264-gd603c8837 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Thu Apr 28 16:46:30 2022 * #>> 1 #> POTNUC="0.0"/12 @@ -13500,7 +13500,7 @@ #>> 170 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-56.781679531594"/5 +#> SEWARD_ATTRACT="-56.781679531595"/5 #>> 171 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -13540,7 +13540,7 @@ #>> 180 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-16.379278559340"/5 +#> SEWARD_ATTRACT="-16.379278559342"/5 #>> 181 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -13572,7 +13572,7 @@ #>> 188 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1376.559687750061"/5 +#> SEWARD_ATTRACT="-1376.559687750060"/5 #>> 189 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -13588,7 +13588,7 @@ #>> 192 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1656.795217661500"/5 +#> SEWARD_ATTRACT="-1656.795217661501"/5 #>> 193 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -13624,7 +13624,7 @@ #>> 201 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-85.682267339121"/5 +#> SEWARD_ATTRACT="-85.682267339120"/5 #>> 202 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -13684,7 +13684,7 @@ #>> 216 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-69.226045092929"/5 +#> SEWARD_ATTRACT="-69.226045092928"/5 #>> 217 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -13796,7 +13796,7 @@ #>> 244 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1723.890799779398"/5 +#> SEWARD_ATTRACT="-1723.890799779397"/5 #>> 245 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -13804,11 +13804,11 @@ #>> 246 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-65.869130423540"/5 +#> SEWARD_ATTRACT="-65.869130423548"/5 #>> 247 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-66.153830180224"/5 +#> SEWARD_ATTRACT="-66.153830180228"/5 #>> 248 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -13884,7 +13884,7 @@ #>> 266 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-69.226045092929"/5 +#> SEWARD_ATTRACT="-69.226045092928"/5 #>> 267 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -13996,7 +13996,7 @@ #>> 294 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-1723.890799779398"/5 +#> SEWARD_ATTRACT="-1723.890799779397"/5 #>> 295 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -14004,11 +14004,11 @@ #>> 296 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-65.869130423540"/5 +#> SEWARD_ATTRACT="-65.869130423548"/5 #>> 297 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-66.153830180224"/5 +#> SEWARD_ATTRACT="-66.153830180228"/5 #>> 298 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -15980,7 +15980,7 @@ #>> 790 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-23.069294060608"/5 +#> SEWARD_ATTRACT="-23.069294060609"/5 #>> 791 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -16320,7 +16320,7 @@ #>> 875 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-23.069294060608"/5 +#> SEWARD_ATTRACT="-23.069294060609"/5 #>> 876 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -16884,7 +16884,7 @@ #>> 1016 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-23.069294060608"/5 +#> SEWARD_ATTRACT="-23.069294060609"/5 #>> 1017 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -17224,7 +17224,7 @@ #>> 1101 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-23.069294060608"/5 +#> SEWARD_ATTRACT="-23.069294060609"/5 #>> 1102 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -17680,7 +17680,7 @@ #>> 1215 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-3.171415482500"/5 +#> SEWARD_ATTRACT="-3.171415482501"/5 #>> 1216 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18084,7 +18084,7 @@ #>> 1316 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-16.662165867596"/5 +#> SEWARD_ATTRACT="-16.662165867597"/5 #>> 1317 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18216,7 +18216,7 @@ #>> 1349 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-42.406880007338"/5 +#> SEWARD_ATTRACT="-42.406880007339"/5 #>> 1350 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18224,7 +18224,7 @@ #>> 1351 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-50.342604229836"/5 +#> SEWARD_ATTRACT="-50.342604229837"/5 #>> 1352 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18528,7 +18528,7 @@ #>> 1427 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-16.662165867596"/5 +#> SEWARD_ATTRACT="-16.662165867597"/5 #>> 1428 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18660,7 +18660,7 @@ #>> 1460 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-42.406880007338"/5 +#> SEWARD_ATTRACT="-42.406880007339"/5 #>> 1461 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 @@ -18668,7 +18668,7 @@ #>> 1462 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 -#> SEWARD_ATTRACT="-50.342604229836"/5 +#> SEWARD_ATTRACT="-50.342604229837"/5 #>> 1463 #> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 diff -Nru openmolcas-22.02/test/extra/852.input openmolcas-22.10/test/extra/852.input --- openmolcas-22.02/test/extra/852.input 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/test/extra/852.input 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,343 @@ +*------------------------------------------------------------------------------- +* Molecule: C6H6 +* Basis: ANO-RCC-MB +* Symmetry: D2h +* Features tested: Molcas-Dice interface, CAS(6,6) singlet +* Responsible person: Quan Phung +*------------------------------------------------------------------------------- +* Test if Dice is available and skip the test if not +>> RM -FORCE TEST_DICE +>> IF ( $MOLCAS_DRIVER = UNKNOWN_VARIABLE ) +>> EXPORT MOLCAS_DRIVER=molcas +>> ENDIF +>> SHELL $MOLCAS_DRIVER have_feature dice || touch TEST_DICE +>> IF ( -FILE TEST_DICE ) +>> EXIT 36 +>> ENDIF + +&GATEWAY +Coord +12 +Benzene +H 1.242914921 2.152791792 0.000000000 +C 0.695567452 1.204758167 0.000000000 +C -0.695567452 1.204758167 0.000000000 +H -1.242914921 2.152791792 0.000000000 +C -1.391134904 0.000000000 0.000000000 +H -2.485829842 0.000000000 0.000000000 +C -0.695567452 -1.204758167 0.000000000 +H -1.242914921 -2.152791792 0.000000000 +C 0.695567452 -1.204758167 0.000000000 +H 1.242914921 -2.152791792 0.000000000 +C 1.391134904 0.000000000 0.000000000 +H 2.485829842 0.000000000 0.000000000 +Basis set +ANO-RCC-MB + +&SEWARD +Medium + +>> COPY startorb INPORB + +&RASSCF +LumOrb +Spin +1 +Symmetry +1 +nActEl +6 0 0 +Inactive +6 5 4 3 0 0 0 0 +Ras2 +0 0 0 0 2 2 1 1 + +CIRoot +1 1 +1 + + +&RASSCF +LumOrb +Spin +1 +Symmetry +1 +nActEl +6 0 0 +Inactive +6 5 4 3 0 0 0 0 +Ras2 +0 0 0 0 2 2 1 1 + +CIRoot +1 1 +1 + +THRS +1.0e-07 1.0e-03 1.0e-03 + +DICE +EPSilon + 1.0d-4 1.0d-5 +DIOC + 1 +2 0 2 0 2 0 +DITErations + 30 + + +&RASSCF +LumOrb +Spin +1 +Symmetry +1 +nActEl +6 0 0 +Inactive +6 5 4 3 0 0 0 0 +Ras2 +0 0 0 0 2 2 1 1 + +CIRoot +1 1 +1 + +THRS +1.0e-07 1.0e-03 1.0e-03 + +DICE +EPSilon + 1.0d-4 1.0d-5 +DIOC + 5 +2 0 2 0 2 0 +2 2 0 0 2 0 +2 0 2 0 0 2 +2 u u 0 d d +u 0 2 u d d + +DITErations + 30 +DIREstart + +>> FILE startorb +#INPORB 2.2 +#INFO +* RASSCF natural orbitals for root number 1 E= -230.607711714500 + 0 8 0 + 9 9 6 6 2 2 1 1 + 9 9 6 6 2 2 1 1 +*BC:HOST qcl.qcl.chem.nagoya-u.ac.jp PID 16431 DATE Tue Oct 4 16:47:36 2022 +#ORB +* ORBITAL 1 1 + -1.34907588789317E-03 8.22807354678710E-01 -9.66259078722384E-04 1.59269266505046E-04 2.73247703942621E-04 + 5.67618740158632E-01 -7.01253262436163E-04 -2.32087343434916E-04 -9.48406298182082E-04 +* ORBITAL 1 2 + 2.08270605673692E-04 -5.68114866062924E-01 -7.45031432793868E-04 7.46213183785263E-05 3.58164257137528E-04 + 8.23492002143631E-01 1.02976388278778E-03 4.83615874015667E-04 -3.27595546475160E-04 +* ORBITAL 1 3 + 5.83323770577700E-02 -6.97762161263261E-02 4.88014872957010E-01 -6.39569591615489E-02 -1.10758736912406E-01 + -4.93388596132911E-02 3.45059132801761E-01 9.04363866725526E-02 4.12431401818510E-02 +* ORBITAL 1 4 + -1.40008202693998E-01 2.54401843480838E-02 -3.27707878193486E-01 3.53692210599380E-01 -2.77069237840955E-01 + -3.59821465881071E-02 4.63456271934167E-01 -8.91904962049514E-02 1.97979783021700E-01 +* ORBITAL 1 5 + 2.93086850806243E-01 1.04675469499504E-02 1.37180314777200E-01 2.37418875414950E-01 4.11150717162103E-01 + 7.39943236638336E-03 9.70327698694029E-02 -3.35696477301781E-01 2.07240595698209E-01 +* ORBITAL 1 6 + 3.04295651815905E-01 5.49381938169381E-03 2.04599500910287E-02 6.79686142294413E-01 -1.06018646148674E-02 + -7.77048536623185E-03 -2.89408324932848E-02 4.67657409261531E-01 -4.30357266805354E-01 +* ORBITAL 1 7 + 1.09762094438480E+00 -9.85721109409435E-02 -7.67307950118714E-01 -3.15826170510693E-01 -5.47011896157477E-01 + -6.96970175388632E-02 -5.42535914726024E-01 4.46605255211639E-01 7.76092371029120E-01 +* ORBITAL 1 8 + 4.67175646683161E-01 -1.37883660367849E-01 -1.10260946185997E+00 -6.48362654441997E-01 4.21977789144172E-01 + 1.95000381363515E-01 1.55935627280630E+00 5.83306660156167E-02 -6.60728069019499E-01 +* ORBITAL 1 9 + -6.68852518160440E-01 -3.50244696867451E-02 -2.28597595751095E-01 1.03191231436775E-01 9.61883838129953E-01 + 4.95281714951608E-02 3.23257644312192E-01 1.25105627758239E+00 9.45939281344661E-01 +* ORBITAL 2 1 + 5.03554462754445E-04 -5.86234205514035E-01 -4.50524623529014E-05 4.62284835317055E-04 1.72191087677385E-04 + 8.10008496996581E-01 3.55122495928922E-05 5.33868402024441E-04 -7.07926323558582E-04 +* ORBITAL 2 2 + -1.74994348839378E-04 8.10639661037420E-01 1.21253723277259E-03 -7.74005619030959E-05 -1.41055413045142E-04 + 5.86670181524774E-01 8.58309778363642E-04 1.22612864046158E-04 -1.35453109695490E-04 +* ORBITAL 2 3 + -7.51616294051786E-02 4.10892523507816E-02 -3.84859425530769E-01 -1.75226576691734E-01 1.68424502783497E-01 + -5.81102766947158E-02 5.44249493924592E-01 8.23790331348814E-02 1.06285068760876E-01 +* ORBITAL 2 4 + 4.50236453486415E-01 -1.36110913194865E-02 4.39349883551901E-01 1.84558537878994E-01 3.19735576835942E-01 + -9.62803845604375E-03 3.10693086673341E-01 -2.60903123497669E-01 3.18279313643303E-01 +* ORBITAL 2 5 + 2.53729675992098E-01 5.82275848402672E-03 -4.86389211955069E-02 4.00053205858662E-02 4.42818639826020E-01 + -8.23121587151059E-03 6.86208687022482E-02 5.70747591701679E-01 -3.58990881360345E-01 +* ORBITAL 2 6 + -7.60165336252992E-01 2.78200377744650E-02 2.24242969210745E-01 7.60591816342561E-01 2.54551003015689E-01 + -3.93274433316658E-02 -3.16980011869584E-01 8.49513538835162E-01 1.07489743865763E+00 +* ORBITAL 2 7 + -9.69762587211353E-01 1.74033125470528E-01 1.50984930771647E+00 7.79649614234619E-02 1.35239073370085E-01 + 1.23052199831181E-01 1.06758108016595E+00 -1.10446480358773E-01 -6.85793153096181E-01 +* ORBITAL 2 8 + 2.52375820690734E-01 -1.17534214770186E-01 -7.84513304112659E-01 1.34285561350549E+00 -8.48872025514524E-01 + 1.66231481240387E-01 1.10958975610194E+00 -9.01545870608968E-02 -3.57015833916141E-01 +* ORBITAL 2 9 + 6.85102040496354E-01 1.48663632805395E-01 1.00490567007532E+00 -7.46539950524510E-01 -1.29308925169223E+00 + 1.05122351438652E-01 7.10585865206376E-01 1.05581518796934E+00 4.84458067131675E-01 +* ORBITAL 3 1 + -8.68843338982531E-04 9.99892073683612E-01 5.50317707365433E-05 -1.70578820727403E-04 -6.58349971563587E-04 + -2.56723680760397E-04 +* ORBITAL 3 2 + 1.30175774554432E-01 -7.11692835722233E-02 6.66578826012879E-01 -1.68434390924306E-01 -1.92521739420136E-02 + 1.92652739582684E-01 +* ORBITAL 3 3 + 1.97535642796460E-05 4.96660430532090E-07 1.45817939880114E-05 5.99356991432788E-01 -3.46010677053305E-01 + 4.89345072545557E-01 +* ORBITAL 3 4 + 4.39601560803226E-01 1.00825400412827E-02 -8.41111145761045E-02 4.42843955063122E-01 5.51430561896823E-01 + -1.52508765527323E-01 +* ORBITAL 3 5 + -1.31654536310400E+00 4.81782236313958E-02 3.88317897176006E-01 2.54547399076039E-01 1.05446252402076E+00 + 4.33865276407878E-01 +* ORBITAL 3 6 + 4.37174705609324E-01 -2.03584592592087E-01 -1.35890317047858E+00 -8.48880498629675E-01 3.62657217628029E-01 + 1.29610839346674E+00 +* ORBITAL 4 1 + -3.87704607751252E-04 1.00044680825318E+00 1.27093571291979E-03 -3.55002953116658E-04 -4.82741084531770E-04 + 9.35913960751192E-05 +* ORBITAL 4 2 + 2.42498656128253E-01 -4.40653179329173E-02 5.67625090167866E-01 2.77047997461231E-01 -3.37742581841258E-02 + -3.63187803403435E-01 +* ORBITAL 4 3 + 5.27061685958611E-01 9.51653061632844E-03 3.54117463207249E-02 -1.05973386935357E-02 6.67473400777615E-01 + 4.84944122285518E-01 +* ORBITAL 4 4 + -8.09230457105804E-01 2.38823288716090E-01 1.90978918762729E+00 -4.21999164246866E-01 1.61180048143262E-01 + 6.30689721908164E-01 +* ORBITAL 4 5 + -1.15850224125486E+00 -6.06662661539433E-02 -3.95961295583981E-01 9.61938440070063E-01 1.21387226862269E+00 + -3.19708325391830E-01 +* ORBITAL 4 6 + 1.67361028930392E-07 9.78520393813375E-06 7.44847312027538E-05 1.44889932377726E+00 -8.36565334259310E-01 + 1.18308376830485E+00 +* ORBITAL 5 1 + 6.18006302512027E-01 4.37005856109402E-01 +* ORBITAL 5 2 + -7.00069361936396E-01 9.90039280272103E-01 +* ORBITAL 6 1 + -5.28772498883690E-01 7.47814045573784E-01 +* ORBITAL 6 2 + 1.14339627809017E+00 8.08495489490038E-01 +* ORBITAL 7 1 + 9.15874555960768E-01 +* ORBITAL 8 1 + 1.21254892192903E+00 +#OCC +* OCCUPATION NUMBERS + 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 + 2.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 + 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 + 1.95374260271890E+00 1.19074285204537E-01 + 1.88141742265118E+00 4.52773207743170E-02 + 1.88141674492858E+00 + 1.19071623721940E-01 +#OCHR +* OCCUPATION NUMBERS (HUMAN-READABLE) + 2.0000 2.0000 2.0000 2.0000 2.0000 2.0000 0.0000 0.0000 0.0000 + 2.0000 2.0000 2.0000 2.0000 2.0000 0.0000 0.0000 0.0000 0.0000 + 2.0000 2.0000 2.0000 2.0000 0.0000 0.0000 + 2.0000 2.0000 2.0000 0.0000 0.0000 0.0000 + 1.9537 0.1191 + 1.8814 0.0453 + 1.8814 + 0.1191 +#ONE +* ONE ELECTRON ENERGIES + -1.1349E+01 -1.1348E+01 -1.1901E+00 -8.5624E-01 -7.4190E-01 -5.3152E-01 4.1432E-01 5.6643E-01 7.4145E-01 + -1.1349E+01 -1.1347E+01 -1.0535E+00 -6.6869E-01 -6.2651E-01 5.1119E-01 5.7040E-01 7.3865E-01 1.0134E+00 + -1.1349E+01 -1.0535E+00 -6.6665E-01 -6.2652E-01 5.1118E-01 7.3867E-01 + -1.1348E+01 -8.5624E-01 -5.3153E-01 5.6643E-01 7.4144E-01 9.4987E-01 + 0.0000E+00 0.0000E+00 + 0.0000E+00 0.0000E+00 + 0.0000E+00 + 0.0000E+00 +#INDEX +* 1234567890 +0 iiiiiisss +* 1234567890 +0 iiiiissss +* 1234567890 +0 iiiiss +* 1234567890 +0 iiisss +* 1234567890 +0 22 +* 1234567890 +0 22 +* 1234567890 +0 2 +* 1234567890 +0 2 +>> EOF +>>FILE checkfile +* This file is autogenerated: +* Molcas version 22.06-148-gba4258fe8 +* Linux qcl.qcl.chem.nagoya-u.ac.jp 3.10.0-862.9.1.el7.x86_64 #1 SMP Mon Jul 16 16:29:36 UTC 2018 x86_64 x86_64 x86_64 GNU/Linux +* Wed Oct 5 16:00:15 2022 +* +#>> 1 +#> POTNUC="203.650455917606"/12 +#>> 2 +#> SEWARD_MLTPL1X="2.348768796901"/5 +#> SEWARD_KINETIC="282.921675000000"/5 +#> SEWARD_ATTRACT="-31.222586270705"/5 +#> POTNUC="203.650455917606"/12 +#> SEWARD_MLTPL1X="2.371431477851"/5 +#> SEWARD_KINETIC="0.601260051372"/5 +#> SEWARD_ATTRACT="-11.506606999023"/5 +#>> 3 +#> RASSCF_ITER="4"/8 +#> E_RASSCF="-230.607711715018"/6 +#> MLTPL__0="-0.000000000000"/3 +#> MLTPL__1[0]="0.0"/3 +#> MLTPL__1[1]="0.0"/3 +#> MLTPL__1[2]="0.0"/3 +#> MLTPL__2[0]="2.254138836593"/3 +#> MLTPL__2[1]="0.0"/3 +#> MLTPL__2[2]="0.0"/3 +#> MLTPL__2[3]="2.254166945556"/3 +#> MLTPL__2[4]="0.0"/3 +#> MLTPL__2[5]="-4.508305782149"/3 +#>> 4 +#> RASSCF_ITER="4"/8 +#> E_RASSCF="-230.607711714900"/6 +#> MLTPL__0="-0.000000000001"/3 +#> MLTPL__1[0]="0.0"/3 +#> MLTPL__1[1]="0.0"/3 +#> MLTPL__1[2]="0.0"/3 +#> MLTPL__2[0]="2.254046982502"/3 +#> MLTPL__2[1]="0.0"/3 +#> MLTPL__2[2]="0.0"/3 +#> MLTPL__2[3]="2.254262425157"/3 +#> MLTPL__2[4]="0.0"/3 +#> MLTPL__2[5]="-4.508309407659"/3 +#>> 5 +#> RASSCF_ITER="4"/8 +#> E_RASSCF="-230.607711714900"/6 +#> MLTPL__0="-0.000000000001"/3 +#> MLTPL__1[0]="0.0"/3 +#> MLTPL__1[1]="0.0"/3 +#> MLTPL__1[2]="0.0"/3 +#> MLTPL__2[0]="2.254046982502"/3 +#> MLTPL__2[1]="0.0"/3 +#> MLTPL__2[2]="0.0"/3 +#> MLTPL__2[3]="2.254262425157"/3 +#> MLTPL__2[4]="0.0"/3 +#> MLTPL__2[5]="-4.508309407659"/3 +>>EOF diff -Nru openmolcas-22.02/test/extra/853.input openmolcas-22.10/test/extra/853.input --- openmolcas-22.02/test/extra/853.input 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/test/extra/853.input 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,293 @@ +*------------------------------------------------------------------------------- +* Molecule: C6H6 +* Basis: ANO-RCC-MB +* Symmetry: D2h +* Features tested: Molcas-Dice interface, CAS(6,6) triplet +* Responsible person: Quan Phung +*------------------------------------------------------------------------------- +* Test if Dice is available and skip the test if not +>> RM -FORCE TEST_DICE +>> IF ( $MOLCAS_DRIVER = UNKNOWN_VARIABLE ) +>> EXPORT MOLCAS_DRIVER=molcas +>> ENDIF +>> SHELL $MOLCAS_DRIVER have_feature dice || touch TEST_DICE +>> IF ( -FILE TEST_DICE ) +>> EXIT 36 +>> ENDIF + +&GATEWAY +Coord +12 +Benzene +H 1.242914921 2.152791792 0.000000000 +C 0.695567452 1.204758167 0.000000000 +C -0.695567452 1.204758167 0.000000000 +H -1.242914921 2.152791792 0.000000000 +C -1.391134904 0.000000000 0.000000000 +H -2.485829842 0.000000000 0.000000000 +C -0.695567452 -1.204758167 0.000000000 +H -1.242914921 -2.152791792 0.000000000 +C 0.695567452 -1.204758167 0.000000000 +H 1.242914921 -2.152791792 0.000000000 +C 1.391134904 0.000000000 0.000000000 +H 2.485829842 0.000000000 0.000000000 +Basis set +ANO-RCC-MB + +&SEWARD +Medium + +>> COPY startorb INPORB + +&RASSCF +LumOrb +Spin +3 +Symmetry +1 +nActEl +6 0 0 +Inactive +6 5 4 3 0 0 0 0 +Ras2 +0 0 0 0 2 2 1 1 + +CIRoot +1 1 +1 + +&RASSCF +LumOrb +Spin +3 +Symmetry +1 +nActEl +6 0 0 +Inactive +6 5 4 3 0 0 0 0 +Ras2 +0 0 0 0 2 2 1 1 + +CIRoot +1 1 +1 + +THRS +1.0e-07 1.0e-03 1.0e-03 + +DICE +EPSilon + 1.0d-4 1.0d-5 +DIOC + 1 +a a 2 0 2 0 +DITErations + 30 + +>> FILE startorb +#INPORB 2.2 +#INFO +* RASSCF natural orbitals for root number 1 E= -230.327567900000 + 0 8 0 + 9 9 6 6 2 2 1 1 + 9 9 6 6 2 2 1 1 +*BC:HOST qcl.qcl.chem.nagoya-u.ac.jp PID 221984 DATE Wed Oct 5 16:06:10 2022 +#ORB +* ORBITAL 1 1 + -1.30438465815512E-03 9.98503003679565E-01 -1.98225376458301E-04 1.42514227388092E-04 -1.91033061161350E-05 + 5.19619274151114E-02 -1.32108829821691E-03 -5.19907510115060E-04 -6.43870286812216E-04 +* ORBITAL 1 2 + -5.40647267958035E-04 -5.28034241946862E-02 -1.41588115159945E-03 8.05808296915618E-05 6.14344286514390E-04 + 9.98856651196967E-01 1.05094506631111E-03 4.34661975048941E-04 -8.27775205772085E-04 +* ORBITAL 1 3 + 6.00242793635886E-02 -7.01791622971323E-02 4.87191922824798E-01 -6.73020646583866E-02 -1.15656236699467E-01 + -4.98462080061285E-02 3.38474059822487E-01 9.45328067228255E-02 4.15655349642299E-02 +* ORBITAL 1 4 + -1.43017827090784E-01 2.49810621884942E-02 -3.28209802964169E-01 3.52653274234179E-01 -2.78752601783552E-01 + -3.62842622147431E-02 4.64852926151446E-01 -8.10152210810611E-02 1.98264426209794E-01 +* ORBITAL 1 5 + 2.95982551201373E-01 9.97352825754891E-03 1.36696537384050E-01 2.44727345145694E-01 4.07401351159388E-01 + 6.50753314802392E-03 1.02825528609568E-01 -3.30236866654907E-01 2.08596813298340E-01 +* ORBITAL 1 6 + 3.04460503900513E-01 5.21544456715275E-03 1.83138007756526E-02 6.75609055240271E-01 -1.40309180225154E-02 + -7.38491787119127E-03 -2.77752728853260E-02 4.67283666744408E-01 -4.36412736591803E-01 +* ORBITAL 1 7 + 1.10482245957020E+00 -9.95281999603401E-02 -7.78785135959242E-01 -3.22843889845032E-01 -5.47675550622316E-01 + -6.78004265156012E-02 -5.30175370636456E-01 4.41763808177178E-01 7.64152180459348E-01 +* ORBITAL 1 8 + 4.45938882834902E-01 -1.37386466969005E-01 -1.09757181594586E+00 -6.45296625651535E-01 4.41455010040949E-01 + 1.96110838113935E-01 1.56960008543751E+00 7.13937404282938E-02 -6.53330831677052E-01 +* ORBITAL 1 9 + -6.69354954832539E-01 -3.35261527277402E-02 -2.15137809243160E-01 1.11487676081484E-01 9.53213850134164E-01 + 4.62715590306730E-02 2.96334310511356E-01 1.25394057333077E+00 9.57580335618202E-01 +* ORBITAL 2 1 + -4.89628476316565E-04 9.98482928522238E-01 1.41110067444608E-03 -4.55550468009875E-04 -3.19657090116918E-04 + -6.19074934337852E-02 8.31115847580150E-04 -1.69500268074851E-04 3.45139326724907E-04 +* ORBITAL 2 2 + 2.75161944108631E-04 6.27199601530235E-02 1.04842892704684E-03 3.58769251097791E-04 -1.41456541459878E-04 + 9.98273396714471E-01 1.11304743948970E-03 6.48093920483937E-04 -6.77711383358386E-04 +* ORBITAL 2 3 + -7.74998175489914E-02 4.12442314392007E-02 -3.86274227669975E-01 -1.75084746168496E-01 1.71058742047739E-01 + -5.87254667318540E-02 5.40187233416019E-01 8.71811096340818E-02 1.07869300120169E-01 +* ORBITAL 2 4 + 4.61918552435521E-01 -1.31787884878010E-02 4.36936793994809E-01 1.83846465396065E-01 3.32526195440163E-01 + -1.00676557759380E-02 3.14984025783779E-01 -2.35685614737251E-01 3.08166804490377E-01 +* ORBITAL 2 5 + 2.38782305910315E-01 5.67086157187500E-03 -6.72488021788318E-02 3.55446203401878E-02 4.29635173241669E-01 + -7.48493584805589E-03 5.68579647930368E-02 5.76161369247741E-01 -3.74492918808327E-01 +* ORBITAL 2 6 + -7.87795025302580E-01 3.16228344816470E-02 2.60553293026221E-01 7.70790666090738E-01 2.59400999848676E-01 + -3.54110203864107E-02 -2.86332696374256E-01 8.43484150397704E-01 1.05087108147063E+00 +* ORBITAL 2 7 + -9.42044221204138E-01 1.74444937331975E-01 1.51270524754988E+00 4.86717703869744E-02 1.19082972274675E-01 + 1.24520003592026E-01 1.08136573650853E+00 -1.25319495041296E-01 -7.10565926483758E-01 +* ORBITAL 2 8 + 2.55271760815095E-01 -1.17008840200292E-01 -7.81614288134255E-01 1.33777330519049E+00 -8.53412805994785E-01 + 1.66614357986142E-01 1.11440247903626E+00 -9.22316639925039E-02 -3.60284652411234E-01 +* ORBITAL 2 9 + 6.88814980726777E-01 1.47513935424945E-01 9.93481541479886E-01 -7.48121540596218E-01 -1.29160020114415E+00 + 1.03426971943778E-01 6.97346083971013E-01 1.06139874794701E+00 4.93419497203203E-01 +* ORBITAL 3 1 + -9.03197278669052E-04 9.99903640778937E-01 2.90501844179314E-04 -1.19351279794460E-04 -7.29377125374025E-04 + -3.67915719831669E-04 +* ORBITAL 3 2 + 1.32559072497744E-01 -7.12527238560338E-02 6.67080899019999E-01 -1.70063619322266E-01 -2.37388972414354E-02 + 1.89764952763814E-01 +* ORBITAL 3 3 + 4.75040871567507E-03 3.99210016366538E-04 2.47444400653841E-03 6.05085505142149E-01 -3.42182900899129E-01 + 4.84957769547516E-01 +* ORBITAL 3 4 + 4.42186789287297E-01 9.41406158552755E-03 -8.60865773040135E-02 4.34185300184994E-01 5.54654829991439E-01 + -1.54222077130549E-01 +* ORBITAL 3 5 + -1.31829446025308E+00 4.91890809910524E-02 3.98273258826951E-01 2.59992924529327E-01 1.05247853012699E+00 + 4.27001007433557E-01 +* ORBITAL 3 6 + 4.28467858481546E-01 -2.03288268264049E-01 -1.35564560617392E+00 -8.47312758721203E-01 3.66845148809101E-01 + 1.30025362638325E+00 +* ORBITAL 4 1 + -4.19754051513323E-04 1.00048875966761E+00 1.71735071314721E-03 -4.40166335062534E-04 -5.79257700091927E-04 + 2.03734527723143E-04 +* ORBITAL 4 2 + 2.46697660770228E-01 -4.37176171019173E-02 5.71019641143711E-01 2.76127717494846E-01 -3.56309397275106E-02 + -3.57949767310910E-01 +* ORBITAL 4 3 + 5.30102827747775E-01 8.69806280782686E-03 2.52335963773356E-02 -1.22168869838962E-02 6.67524941187913E-01 + 4.82119061832286E-01 +* ORBITAL 4 4 + -7.99776645920307E-01 2.39118384979631E-01 1.91175715863078E+00 -4.31206656436794E-01 1.57797736185583E-01 + 6.33062744186390E-01 +* ORBITAL 4 5 + -1.16278331682407E+00 -5.91641341161016E-02 -3.82100626040077E-01 9.63973963265352E-01 1.21276339286688E+00 + -3.13091520612831E-01 +* ORBITAL 4 6 + 2.12127121054694E-03 6.71235861376907E-04 3.80895287998566E-03 1.44499314365558E+00 -8.38697505718816E-01 + 1.18633246897625E+00 +* ORBITAL 5 1 + 6.09604581732481E-01 4.48794156443273E-01 +* ORBITAL 5 2 + -7.07397452212959E-01 9.84751592990834E-01 +* ORBITAL 6 1 + -5.50329783745939E-01 7.32369751057014E-01 +* ORBITAL 6 2 + 1.13317806784649E+00 8.22511611480259E-01 +* ORBITAL 7 1 + 9.15874555960768E-01 +* ORBITAL 8 1 + 1.21254892192903E+00 +#OCC +* OCCUPATION NUMBERS + 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 + 2.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 + 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 + 2.00000000000000E+00 2.00000000000000E+00 2.00000000000000E+00 0.00000000000000E+00 0.00000000000000E+00 + 0.00000000000000E+00 + 1.49175924969288E+00 7.42716844469140E-01 + 1.41710406912751E+00 3.48191465762608E-01 + 1.63576951800140E+00 + 3.64458852943300E-01 +#OCHR +* OCCUPATION NUMBERS (HUMAN-READABLE) + 2.0000 2.0000 2.0000 2.0000 2.0000 2.0000 0.0000 0.0000 0.0000 + 2.0000 2.0000 2.0000 2.0000 2.0000 0.0000 0.0000 0.0000 0.0000 + 2.0000 2.0000 2.0000 2.0000 0.0000 0.0000 + 2.0000 2.0000 2.0000 0.0000 0.0000 0.0000 + 1.4918 0.7427 + 1.4171 0.3482 + 1.6358 + 0.3645 +#ONE +* ONE ELECTRON ENERGIES + -1.1326E+01 -1.1314E+01 -1.1788E+00 -8.4740E-01 -7.3500E-01 -5.2168E-01 4.2261E-01 5.7352E-01 7.5316E-01 + -1.1325E+01 -1.1314E+01 -1.0407E+00 -6.6029E-01 -6.1758E-01 5.2160E-01 5.7682E-01 7.5078E-01 1.0229E+00 + -1.1326E+01 -1.0439E+00 -6.5594E-01 -6.2025E-01 5.1952E-01 7.5219E-01 + -1.1325E+01 -8.4750E-01 -5.2242E-01 5.7421E-01 7.4984E-01 9.6482E-01 + 0.0000E+00 0.0000E+00 + 0.0000E+00 0.0000E+00 + 0.0000E+00 + 0.0000E+00 +#INDEX +* 1234567890 +0 iiiiiisss +* 1234567890 +0 iiiiissss +* 1234567890 +0 iiiiss +* 1234567890 +0 iiisss +* 1234567890 +0 22 +* 1234567890 +0 22 +* 1234567890 +0 2 +* 1234567890 +0 2 +>> EOF +>>FILE checkfile +* This file is autogenerated: +* Molcas version 22.06-148-gba4258fe8 +* Linux qcl.qcl.chem.nagoya-u.ac.jp 3.10.0-862.9.1.el7.x86_64 #1 SMP Mon Jul 16 16:29:36 UTC 2018 x86_64 x86_64 x86_64 GNU/Linux +* Wed Oct 5 16:11:26 2022 +* +#>> 1 +#> POTNUC="203.650455917606"/12 +#>> 2 +#> SEWARD_MLTPL1X="2.348768796901"/5 +#> SEWARD_KINETIC="282.921675000000"/5 +#> SEWARD_ATTRACT="-31.222586270705"/5 +#> POTNUC="203.650455917606"/12 +#> SEWARD_MLTPL1X="2.371431477851"/5 +#> SEWARD_KINETIC="0.601260051372"/5 +#> SEWARD_ATTRACT="-11.506606999023"/5 +#>> 3 +#> RASSCF_ITER="4"/8 +#> E_RASSCF="-230.327567902675"/6 +#> MLTPL__0="-0.000000000000"/3 +#> MLTPL__1[0]="0.0"/3 +#> MLTPL__1[1]="0.0"/3 +#> MLTPL__1[2]="0.0"/3 +#> MLTPL__2[0]="1.416099766452"/3 +#> MLTPL__2[1]="0.0"/3 +#> MLTPL__2[2]="0.0"/3 +#> MLTPL__2[3]="1.635388999074"/3 +#> MLTPL__2[4]="0.0"/3 +#> MLTPL__2[5]="-3.051488765526"/3 +#>> 4 +#> RASSCF_ITER="4"/8 +#> E_RASSCF="-230.327567898600"/6 +#> MLTPL__0="-0.000000000005"/3 +#> MLTPL__1[0]="0.0"/3 +#> MLTPL__1[1]="0.0"/3 +#> MLTPL__1[2]="0.0"/3 +#> MLTPL__2[0]="1.415959290891"/3 +#> MLTPL__2[1]="0.0"/3 +#> MLTPL__2[2]="0.0"/3 +#> MLTPL__2[3]="1.635498114266"/3 +#> MLTPL__2[4]="0.0"/3 +#> MLTPL__2[5]="-3.051457405157"/3 +>>EOF diff -Nru openmolcas-22.02/test/extra/854.input openmolcas-22.10/test/extra/854.input --- openmolcas-22.02/test/extra/854.input 1970-01-01 00:00:00.000000000 +0000 +++ openmolcas-22.10/test/extra/854.input 2022-10-10 14:22:40.000000000 +0000 @@ -0,0 +1,263 @@ +*------------------------------------------------------------------------------- +* Molecule: C6H6 +* Basis: ANO-RCC-MB +* Symmetry: D2h +* Features tested: Molcas-Dice interface, CAS(30,24) singlet +* Responsible person: Quan Phung +*------------------------------------------------------------------------------- +* Test if Dice is available and skip the test if not +>> RM -FORCE TEST_DICE +>> IF ( $MOLCAS_DRIVER = UNKNOWN_VARIABLE ) +>> EXPORT MOLCAS_DRIVER=molcas +>> ENDIF +>> SHELL $MOLCAS_DRIVER have_feature dice || touch TEST_DICE +>> IF ( -FILE TEST_DICE ) +>> EXIT 36 +>> ENDIF + +&GATEWAY +Coord +12 +Benzene +H 1.242914921 2.152791792 0.000000000 +C 0.695567452 1.204758167 0.000000000 +C -0.695567452 1.204758167 0.000000000 +H -1.242914921 2.152791792 0.000000000 +C -1.391134904 0.000000000 0.000000000 +H -2.485829842 0.000000000 0.000000000 +C -0.695567452 -1.204758167 0.000000000 +H -1.242914921 -2.152791792 0.000000000 +C 0.695567452 -1.204758167 0.000000000 +H 1.242914921 -2.152791792 0.000000000 +C 1.391134904 0.000000000 0.000000000 +H 2.485829842 0.000000000 0.000000000 +Basis set +ANO-RCC-MB + +&SEWARD +Medium + +>> COPY startorb INPORB + +&RASSCF +LumOrb +Spin +1 +Symmetry +1 +nActEl +30 0 0 +Inactive +2 2 1 1 0 0 0 0 +Ras2 +6 5 4 3 2 2 1 1 +CIOnly + +CIRoot +1 1 +1 + +THRS +1.0e-07 1.0e-03 1.0e-03 + +DICE +EPSilon + 1.0d-4 1.0d-5 +DIOC + 1 +2 2 2 2 0 0 2 2 2 0 0 2 2 2 0 2 2 0 2 0 2 0 2 0 +DITErations + 30 + +>> FILE startorb +#INPORB 2.2 +#INFO +* RASSCF natural orbitals for root number 1 E= -230.758657154000 + 0 8 0 + 9 9 6 6 2 2 1 1 + 9 9 6 6 2 2 1 1 +*BC:HOST qcl.qcl.chem.nagoya-u.ac.jp PID 20218 DATE Tue Oct 4 16:52:16 2022 +#ORB +* ORBITAL 1 1 + -1.02974964344120E-02 8.00409329867648E-01 -8.00323916548317E-03 -6.11971695582495E-03 -7.12920268906659E-03 + -6.00635100936185E-01 5.70151776725663E-03 -7.72492032954147E-03 9.00872154799670E-03 +* ORBITAL 1 2 + -1.06658567816128E-02 5.99537409932629E-01 -1.23039695479840E-02 -5.94103256369544E-03 -1.25303210260457E-02 + 7.99818708921731E-01 -1.50265971516482E-02 1.74077049741850E-02 -1.60621952727574E-02 +* ORBITAL 1 3 + 1.87900874353885E-01 1.29063891797687E-02 2.45756891522740E-01 1.18141053134975E-01 2.53720051051966E-01 + 1.80762455362488E-02 3.29735612713546E-01 -3.63976035512271E-01 3.21572859288316E-01 +* ORBITAL 1 4 + 7.11227243832024E-02 6.80938026405521E-02 -3.71563614724716E-01 1.37350972055872E-01 2.85349392426272E-01 + 5.04320267393547E-02 -2.82056643718624E-01 -2.32656043852083E-01 5.59970290330531E-02 +* ORBITAL 1 5 + 3.87258691269605E-01 -6.59574832410740E-04 3.39954903271992E-01 2.40908151309186E-01 2.72951494583085E-01 + 1.08881949299250E-03 -2.79367980627768E-01 2.88088448600114E-01 -3.59753138053349E-01 +* ORBITAL 1 6 + 1.37153675519760E-01 2.29648095096094E-02 -2.22167025765800E-01 7.43180827440459E-01 -1.86263023802106E-01 + -2.85091568920817E-02 2.85017233768425E-01 2.76064471963670E-01 -1.79503756818376E-01 +* ORBITAL 1 7 + 1.33828505204040E+00 -9.87239254125711E-02 -8.10145062959850E-01 -5.36936876944920E-01 -8.04165591713424E-01 + -7.10415580514819E-04 5.01684991635058E-02 -4.62925144283092E-01 -3.29377588871045E-01 +* ORBITAL 1 8 + 3.98734429926454E-02 -1.35541936187277E-01 -1.05521414587525E+00 -4.93262939471308E-01 8.70976366520195E-01 + 1.90886859721818E-01 1.48583910518239E+00 7.23026344933187E-01 -4.71924560402443E-02 +* ORBITAL 1 9 + 2.64440748786440E-01 -4.27528674380101E-02 -2.96891619746713E-01 5.86433972721542E-02 -1.46841848039730E-02 + -9.44206410880124E-02 -7.85168048889028E-01 1.01601508681529E+00 1.35036718997386E+00 +* ORBITAL 2 1 + -7.52754409236738E-03 8.88574940912880E-01 -5.62588146085097E-03 -3.11746120679294E-03 -5.66056092550126E-03 + 4.60407940904750E-01 -3.52034426264247E-03 2.75106953002905E-03 -3.92091235125296E-03 +* ORBITAL 2 2 + 8.69906447408838E-03 -4.60188195902373E-01 5.84013845458767E-03 5.67074664099001E-03 9.34269957288827E-03 + 8.88343275213520E-01 -1.38086209178839E-02 2.03725653692576E-02 -1.83465002968378E-02 +* ORBITAL 2 3 + 8.51358818627601E-02 3.63713317317272E-02 -3.49118911839659E-01 -1.07536458393961E-01 3.93148414659470E-01 + -5.06699715556892E-02 4.62283792266450E-01 4.32261364530979E-01 -1.50328405911143E-01 +* ORBITAL 2 4 + 4.83456695890513E-01 -5.31704860560318E-04 4.66482281874449E-01 2.01211515969436E-01 3.64910459538879E-01 + 6.45658153740409E-04 2.81948960751669E-01 -1.75823748088925E-01 2.50446508638081E-01 +* ORBITAL 2 5 + 1.65995039129864E-01 1.21762818196673E-03 1.26756310927701E-01 1.14292528206481E-01 1.80411842404237E-01 + -8.51548108339598E-03 -3.35229538733130E-01 4.29638870226449E-01 -3.91448641090909E-01 +* ORBITAL 2 6 + -8.45221637003530E-02 -9.48986851767679E-02 -6.11232269860619E-01 1.53610830217429E+00 -6.78642933017531E-01 + 1.38545436501479E-01 9.02363765611207E-01 2.48962793262276E-01 9.31921760563688E-02 +* ORBITAL 2 7 + -2.04935614490631E-01 2.29757802158998E-01 1.78441099112516E+00 -4.88387642982256E-01 -8.15068361695674E-01 + 1.58863240111905E-01 1.23725956174633E+00 6.83710923287293E-01 -1.24907672085533E-01 +* ORBITAL 2 8 + 7.77088633854419E-01 -6.90578294908366E-02 -4.89282156555822E-01 -1.60812103031911E-01 -5.64576764494663E-01 + 1.04330998102679E-01 7.51597655024227E-01 -8.19286476337987E-01 -1.14323082993042E+00 +* ORBITAL 2 9 + 1.18423638225639E+00 -2.15572513348138E-02 -3.82088380015002E-01 -5.67769173977788E-01 -1.01902047581359E+00 + -1.08665555188799E-02 -2.40874650924831E-01 8.08644310685398E-01 8.11899229218219E-01 +* ORBITAL 3 1 + -1.35430250738359E-02 1.00048747020695E+00 -9.61500946550599E-03 -7.25132499465896E-03 -1.37366234787442E-02 + 1.25817968326203E-04 +* ORBITAL 3 2 + -1.74199630568688E-01 -6.15470715088991E-02 5.71715287640478E-01 -3.33449756705793E-01 -4.06732753715617E-01 + 2.93335789683370E-01 +* ORBITAL 3 3 + 2.66926966069386E-02 6.57452960762664E-03 -6.13196464810955E-02 6.47095290759287E-01 -2.92994330711782E-01 + 4.57996234052465E-01 +* ORBITAL 3 4 + 4.18989252357908E-01 -7.96985287853917E-03 3.55816932883148E-01 2.25202122154585E-01 4.23675901960367E-01 + -4.85871472023093E-06 +* ORBITAL 3 5 + -1.29901011697521E-01 -1.67409404207993E-01 -1.08664858029228E+00 -6.78690281801321E-01 7.51649097852476E-01 + 1.36277309287391E+00 +* ORBITAL 3 6 + 1.38236816545146E+00 -1.25788868595062E-01 -9.00382632983325E-01 -5.72531302611452E-01 -8.19535272647583E-01 + 1.22522482917021E-01 +* ORBITAL 4 1 + -1.08207760285960E-02 1.00071600500969E+00 -6.78189995970281E-03 -3.86766404033435E-03 -9.14967129965134E-03 + -1.72650533118435E-03 +* ORBITAL 4 2 + -2.08778951938974E-01 -3.78547528807846E-02 3.72249715816142E-01 1.99946767357551E-01 -5.02544608632354E-01 + -6.00098437511558E-01 +* ORBITAL 4 3 + 5.38973826916265E-01 -5.11032931188637E-03 4.37673494346450E-01 1.89810231518997E-01 4.41139745853880E-01 + 8.00766380025728E-02 +* ORBITAL 4 4 + -7.18304230915187E-02 2.34651395079669E-01 1.82689584341305E+00 -8.78367896766585E-01 -5.03408748674929E-01 + 6.97009072156688E-01 +* ORBITAL 4 5 + -1.41216792584324E+00 7.54210691371666E-02 6.78015267913866E-01 5.93522834776577E-01 1.11190876569300E+00 + 6.61798693693663E-02 +* ORBITAL 4 6 + 2.18140215356142E-03 1.36256190576139E-03 1.03385405098774E-02 1.44213904322742E+00 -8.42002124846353E-01 + 1.18743906254373E+00 +* ORBITAL 5 1 + 6.18268932064773E-01 4.36634352667623E-01 +* ORBITAL 5 2 + -6.99837430486613E-01 9.90203179567781E-01 +* ORBITAL 6 1 + -5.29356162349394E-01 7.47401190967993E-01 +* ORBITAL 6 2 + 1.14312617751012E+00 8.08877161887262E-01 +* ORBITAL 7 1 + 9.15874555960768E-01 +* ORBITAL 8 1 + 1.21254892192903E+00 +#OCC +* OCCUPATION NUMBERS + 2.00000000000000E+00 2.00000000000000E+00 1.99812951302978E+00 1.98991477671564E+00 1.99712930899445E+00 + 1.98291947313734E+00 6.28778013469944E-03 2.16472245328184E-02 0.00000000000000E+00 + 2.00000000000000E+00 2.00000000000000E+00 1.98498583270245E+00 1.99520280956322E+00 1.99807499813474E+00 + 1.76918295357009E-02 1.84807950949331E-02 0.00000000000000E+00 0.00000000000000E+00 + 2.00000000000000E+00 1.98495825700579E+00 1.98340098586697E+00 1.99743348791776E+00 1.75759416135218E-02 + 0.00000000000000E+00 + 2.00000000000000E+00 1.98302689692324E+00 1.99641985269790E+00 2.17106031887757E-02 0.00000000000000E+00 + 0.00000000000000E+00 + 1.95461197191770E+00 1.04068892287134E-01 + 1.89766451500105E+00 4.69049029591500E-02 + 1.89723463667711E+00 + 1.04524714376552E-01 +#OCHR +* OCCUPATION NUMBERS (HUMAN-READABLE) + 2.0000 2.0000 1.9981 1.9899 1.9971 1.9829 0.0063 0.0216 0.0000 + 2.0000 2.0000 1.9850 1.9952 1.9981 0.0177 0.0185 0.0000 0.0000 + 2.0000 1.9850 1.9834 1.9974 0.0176 0.0000 + 2.0000 1.9830 1.9964 0.0217 0.0000 0.0000 + 1.9546 0.1041 + 1.8977 0.0469 + 1.8972 + 0.1045 +#ONE +* ONE ELECTRON ENERGIES + -1.1336E+01 -1.1320E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 5.3943E-01 + -1.1339E+01 -1.1322E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 5.4777E-01 7.8978E-01 + -1.1334E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 5.4865E-01 + -1.1338E+01 0.0000E+00 0.0000E+00 0.0000E+00 6.9327E-01 9.5113E-01 + 0.0000E+00 0.0000E+00 + 0.0000E+00 0.0000E+00 + 0.0000E+00 + 0.0000E+00 +#INDEX +* 1234567890 +0 ii222222s +* 1234567890 +0 ii22222ss +* 1234567890 +0 i2222s +* 1234567890 +0 i222ss +* 1234567890 +0 22 +* 1234567890 +0 22 +* 1234567890 +0 2 +* 1234567890 +0 2 +>> EOF +>>FILE checkfile +* This file is autogenerated: +* Molcas version 22.06-148-gba4258fe8 +* Linux qcl.qcl.chem.nagoya-u.ac.jp 3.10.0-862.9.1.el7.x86_64 #1 SMP Mon Jul 16 16:29:36 UTC 2018 x86_64 x86_64 x86_64 GNU/Linux +* Wed Oct 5 16:23:19 2022 +* +#>> 1 +#> POTNUC="203.650455917606"/12 +#>> 2 +#> SEWARD_MLTPL1X="2.348768796901"/5 +#> SEWARD_KINETIC="282.921675000000"/5 +#> SEWARD_ATTRACT="-31.222586270705"/5 +#> POTNUC="203.650455917606"/12 +#> SEWARD_MLTPL1X="2.371431477851"/5 +#> SEWARD_KINETIC="0.601260051372"/5 +#> SEWARD_ATTRACT="-11.506606999023"/5 +#>> 3 +#> E_RASSCF="-230.759074584900"/6 +#> MLTPL__0="0.000000000006"/3 +#> MLTPL__1[0]="0.0"/3 +#> MLTPL__1[1]="0.0"/3 +#> MLTPL__1[2]="0.0"/3 +#> MLTPL__2[0]="2.422068252114"/3 +#> MLTPL__2[1]="0.0"/3 +#> MLTPL__2[2]="0.0"/3 +#> MLTPL__2[3]="2.235617899071"/3 +#> MLTPL__2[4]="0.0"/3 +#> MLTPL__2[5]="-4.657686151185"/3 +>>EOF diff -Nru openmolcas-22.02/test/extra/861.input openmolcas-22.10/test/extra/861.input --- openmolcas-22.02/test/extra/861.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/extra/861.input 2022-10-10 14:22:40.000000000 +0000 @@ -138,6 +138,33 @@ >>> End Do +>> SHELL $MOLCAS/Tools/dynamixtools/dynamixtools.py -D -i water.freq.molden -s 123456789 -t 300 -c 1 -m 4 -l $Project + +&Gateway + coord = $Project.xyz + basis = STO-3G + group = NoSym + NoCD + +>> EXPORT MOLCAS_MAXITER=5 +>> DOWHILE + +&Seward + +&rasscf +INACTIVE = 0 +RAS2 = 2 +nactel = 2 0 0 + +&Alaska + +&Dynamix + VELVER + DT = 20.65 + VELO = 1 + +>>> End Do + >>FILE create_test_numpy head -n 1 $1 > test_numpy.py echo "import numpy" >> test_numpy.py @@ -146,9 +173,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.02-1206-gdd982ad4b -* Linux curie 5.4.0-73-generic #82-Ubuntu SMP Wed Apr 14 17:39:42 UTC 2021 x86_64 x86_64 x86_64 GNU/Linux -* Thu Jun 17 14:11:54 2021 +* Molcas version 22.02-120-ga9dbede7e +* Linux curie05 5.4.0-107-generic #121-Ubuntu SMP Thu Mar 24 16:04:27 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Sun May 15 00:46:53 2022 * #>> 1 #> POTNUC="8.905289404153"/12 @@ -172,34 +199,34 @@ #> MLTPL__2[5]="1.573755021303"/5 #>> 4 #> GRAD[0]="0.013541087914"/6 -#> GRAD[1]="0.265677908030"/6 -#> GRAD[2]="-1.799227977921"/6 +#> GRAD[1]="0.265677908029"/6 +#> GRAD[2]="-1.799227977916"/6 #> GRAD[3]="0.033708193381"/6 -#> GRAD[4]="-1.787203576892"/6 -#> GRAD[5]="0.228079204055"/6 +#> GRAD[4]="-1.787203576888"/6 +#> GRAD[5]="0.228079204054"/6 #> GRAD[6]="-0.047249281295"/6 -#> GRAD[7]="1.521525668862"/6 -#> GRAD[8]="1.571148773866"/6 +#> GRAD[7]="1.521525668859"/6 +#> GRAD[8]="1.571148773862"/6 #>> 5 #> EKIN="0.647314558748"/6 #>> 7 -#> POTNUC="6.893606728487"/6 +#> POTNUC="6.893606728489"/6 #> SEWARD_MLTPL1X="0.019773867878"/5 #> SEWARD_KINETIC="0.760031879922"/5 -#> SEWARD_ATTRACT="-4.635106532750"/5 +#> SEWARD_ATTRACT="-4.635106532751"/5 #>> 8 #> RASSCF_ITER="7"/8 -#> E_RASSCF="-53.219406479915"/8 +#> E_RASSCF="-53.219406479914"/8 #> MLTPL__0="8"/5 #> MLTPL__1[0]="0.233282336914"/5 #> MLTPL__1[1]="2.620659112733"/5 -#> MLTPL__1[2]="2.562523316305"/5 -#> MLTPL__2[0]="-5.499572239414"/5 +#> MLTPL__1[2]="2.562523316304"/5 +#> MLTPL__2[0]="-5.499572239412"/5 #> MLTPL__2[1]="-0.118087947417"/5 #> MLTPL__2[2]="-0.021581383024"/5 -#> MLTPL__2[3]="2.175496074117"/5 -#> MLTPL__2[4]="-3.523801417496"/5 -#> MLTPL__2[5]="3.324076165297"/5 +#> MLTPL__2[3]="2.175496074116"/5 +#> MLTPL__2[4]="-3.523801417495"/5 +#> MLTPL__2[5]="3.324076165296"/5 #>> 9 #> GRAD[0]="0.005906621749"/6 #> GRAD[1]="0.217109391365"/6 @@ -211,26 +238,26 @@ #> GRAD[7]="0.931973930316"/6 #> GRAD[8]="0.744567355790"/6 #>> 10 -#> EKIN="2.100127986011"/6 -#> EKIN="2.100127986011"/6 +#> EKIN="2.100127986009"/6 +#> EKIN="2.100127986009"/6 #>> 12 -#> POTNUC="5.153732901398"/6 +#> POTNUC="5.153732901400"/6 #> SEWARD_MLTPL1X="0.017616064052"/5 #> SEWARD_KINETIC="0.760031879922"/5 #> SEWARD_ATTRACT="-3.751563667026"/5 #>> 13 #> RASSCF_ITER="7"/8 -#> E_RASSCF="-54.541329434987"/8 +#> E_RASSCF="-54.541329434986"/8 #> MLTPL__0="8"/5 #> MLTPL__1[0]="0.225297018827"/5 #> MLTPL__1[1]="2.820798614458"/5 #> MLTPL__1[2]="2.942095142929"/5 -#> MLTPL__2[0]="-9.936632256119"/5 +#> MLTPL__2[0]="-9.936632256113"/5 #> MLTPL__2[1]="-0.193348449754"/5 #> MLTPL__2[2]="-0.019911948125"/5 -#> MLTPL__2[3]="3.537792730935"/5 -#> MLTPL__2[4]="-7.515930801668"/5 -#> MLTPL__2[5]="6.398839525184"/5 +#> MLTPL__2[3]="3.537792730933"/5 +#> MLTPL__2[4]="-7.515930801665"/5 +#> MLTPL__2[5]="6.398839525180"/5 #>> 14 #> GRAD[0]="0.002759057306"/6 #> GRAD[1]="0.137492518175"/6 @@ -238,30 +265,30 @@ #> GRAD[3]="0.011473410973"/6 #> GRAD[4]="-0.653797863369"/6 #> GRAD[5]="0.165334795761"/6 -#> GRAD[6]="-0.014232468278"/6 +#> GRAD[6]="-0.014232468279"/6 #> GRAD[7]="0.516305345194"/6 #> GRAD[8]="0.361349848520"/6 #>> 15 -#> EKIN="3.427795175601"/6 -#> EKIN="3.427795175601"/6 +#> EKIN="3.427795175598"/6 +#> EKIN="3.427795175598"/6 #>> 17 -#> POTNUC="3.965997642714"/6 +#> POTNUC="3.965997642715"/6 #> SEWARD_MLTPL1X="0.014817853934"/5 #> SEWARD_KINETIC="0.760031879922"/5 -#> SEWARD_ATTRACT="-3.165320128195"/5 +#> SEWARD_ATTRACT="-3.165320128196"/5 #>> 18 #> RASSCF_ITER="6"/8 -#> E_RASSCF="-55.443113387330"/8 +#> E_RASSCF="-55.443113387329"/8 #> MLTPL__0="8"/5 #> MLTPL__1[0]="0.215259486520"/5 -#> MLTPL__1[1]="3.095395529275"/5 +#> MLTPL__1[1]="3.095395529274"/5 #> MLTPL__1[2]="3.373751419833"/5 -#> MLTPL__2[0]="-16.845194965128"/5 -#> MLTPL__2[1]="-0.314401991711"/5 +#> MLTPL__2[0]="-16.845194965117"/5 +#> MLTPL__2[1]="-0.314401991710"/5 #> MLTPL__2[2]="-0.014182628678"/5 -#> MLTPL__2[3]="5.873087373456"/5 -#> MLTPL__2[4]="-13.775203482856"/5 -#> MLTPL__2[5]="10.972107591672"/5 +#> MLTPL__2[3]="5.873087373451"/5 +#> MLTPL__2[4]="-13.775203482851"/5 +#> MLTPL__2[5]="10.972107591666"/5 #>> 19 #> GRAD[0]="0.001482872688"/6 #> GRAD[1]="0.087230559598"/6 @@ -273,26 +300,26 @@ #> GRAD[7]="0.299196068750"/6 #> GRAD[8]="0.199766639745"/6 #>> 20 -#> EKIN="4.345679600643"/6 -#> EKIN="4.345679600643"/6 +#> EKIN="4.345679600640"/6 +#> EKIN="4.345679600640"/6 #>> 22 -#> POTNUC="3.168092775622"/6 +#> POTNUC="3.168092775623"/6 #> SEWARD_MLTPL1X="0.011675453431"/5 #> SEWARD_KINETIC="0.760031879922"/5 #> SEWARD_ATTRACT="-2.777057237140"/5 #>> 23 #> RASSCF_ITER="5"/8 -#> E_RASSCF="-56.048734216971"/8 +#> E_RASSCF="-56.048734216970"/8 #> MLTPL__0="8"/5 #> MLTPL__1[0]="0.204046804125"/5 -#> MLTPL__1[1]="3.413147372454"/5 -#> MLTPL__1[2]="3.834226088840"/5 -#> MLTPL__2[0]="-26.434048108949"/5 +#> MLTPL__1[1]="3.413147372453"/5 +#> MLTPL__1[2]="3.834226088839"/5 +#> MLTPL__2[0]="-26.434048108933"/5 #> MLTPL__2[1]="-0.484791033294"/5 #> MLTPL__2[2]="-0.002446030919"/5 -#> MLTPL__2[3]="9.283341540050"/5 -#> MLTPL__2[4]="-22.562273261892"/5 -#> MLTPL__2[5]="17.150706568900"/5 +#> MLTPL__2[3]="9.283341540043"/5 +#> MLTPL__2[4]="-22.562273261883"/5 +#> MLTPL__2[5]="17.150706568891"/5 #>> 24 #> GRAD[0]="0.000894761403"/6 #> GRAD[1]="0.058165832722"/6 @@ -304,318 +331,474 @@ #> GRAD[7]="0.186686868769"/6 #> GRAD[8]="0.123479650512"/6 #>> 25 -#> EKIN="4.961859754669"/6 -#> EKIN="4.961859754669"/6 +#> EKIN="4.961859754666"/6 +#> EKIN="4.961859754666"/6 #>> 27 -#> POTNUC="9.022017035082"/6 +#> POTNUC="9.022017701291"/6 #>> 28 -#> POTNUC="9.022017035082"/6 -#> SEWARD_MLTPL1X="-0.012057747525"/5 +#> POTNUC="9.022017701291"/6 +#> SEWARD_MLTPL1X="-0.012057743614"/5 #> SEWARD_KINETIC="0.760031879922"/5 -#> SEWARD_ATTRACT="-5.769950217021"/5 +#> SEWARD_ATTRACT="-5.769950530944"/5 #>> 29 #> RASSCF_ITER="8"/8 -#> E_RASSCF="-51.599807211820"/8 +#> E_RASSCF="-51.599806711286"/8 #> MLTPL__0="8"/5 -#> MLTPL__1[0]="-0.027673866076"/5 -#> MLTPL__1[1]="0.896083340420"/5 -#> MLTPL__1[2]="0.910749293945"/5 -#> MLTPL__2[0]="-3.168138801196"/5 -#> MLTPL__2[1]="-0.081832515642"/5 -#> MLTPL__2[2]="-0.020514223253"/5 -#> MLTPL__2[3]="1.627272555505"/5 -#> MLTPL__2[4]="-1.435151646980"/5 -#> MLTPL__2[5]="1.540866245691"/5 +#> MLTPL__1[0]="-0.027673861332"/5 +#> MLTPL__1[1]="0.896083193861"/5 +#> MLTPL__1[2]="0.910749124223"/5 +#> MLTPL__2[0]="-3.168138364114"/5 +#> MLTPL__2[1]="-0.081832498906"/5 +#> MLTPL__2[2]="-0.020514205238"/5 +#> MLTPL__2[3]="1.627272426722"/5 +#> MLTPL__2[4]="-1.435152150716"/5 +#> MLTPL__2[5]="1.540865937392"/5 #>> 30 -#> GRAD[0]="0.013412975246"/6 -#> GRAD[1]="0.293718658941"/6 -#> GRAD[2]="-1.840940946239"/6 -#> GRAD[3]="0.034386451058"/6 -#> GRAD[4]="-1.834895004997"/6 -#> GRAD[5]="0.255218002523"/6 -#> GRAD[6]="-0.047799426304"/6 -#> GRAD[7]="1.541176346056"/6 -#> GRAD[8]="1.585722943717"/6 +#> GRAD[0]="0.013412974643"/6 +#> GRAD[1]="0.293718836870"/6 +#> GRAD[2]="-1.840941230862"/6 +#> GRAD[3]="0.034386453880"/6 +#> GRAD[4]="-1.834895229573"/6 +#> GRAD[5]="0.255218165774"/6 +#> GRAD[6]="-0.047799428522"/6 +#> GRAD[7]="1.541176392702"/6 +#> GRAD[8]="1.585723065088"/6 #>> 31 -#> EKIN="0.000216913788"/6 +#> EKIN="0.000217175582"/6 #>> 33 -#> POTNUC="8.029030492996"/6 -#> SEWARD_MLTPL1X="-0.013758944014"/5 +#> POTNUC="8.028991216665"/6 +#> SEWARD_MLTPL1X="-0.013758940033"/5 #> SEWARD_KINETIC="0.760031879922"/5 -#> SEWARD_ATTRACT="-5.319114606361"/5 +#> SEWARD_ATTRACT="-5.319079441212"/5 #>> 34 #> RASSCF_ITER="6"/8 -#> E_RASSCF="-52.353525383681"/8 +#> E_RASSCF="-52.353555179724"/8 #> MLTPL__0="8"/5 -#> MLTPL__1[0]="-0.031271468066"/5 -#> MLTPL__1[1]="1.013035099004"/5 -#> MLTPL__1[2]="1.030837419326"/5 -#> MLTPL__2[0]="-3.997677528453"/5 -#> MLTPL__2[1]="-0.103744524893"/5 -#> MLTPL__2[2]="-0.027107235108"/5 -#> MLTPL__2[3]="2.046591377919"/5 -#> MLTPL__2[4]="-1.753208187708"/5 -#> MLTPL__2[5]="1.951086150535"/5 +#> MLTPL__1[0]="-0.031271463576"/5 +#> MLTPL__1[1]="1.013034954003"/5 +#> MLTPL__1[2]="1.030857917319"/5 +#> MLTPL__2[0]="-3.997716303961"/5 +#> MLTPL__2[1]="-0.103744507992"/5 +#> MLTPL__2[2]="-0.027107586028"/5 +#> MLTPL__2[3]="2.046552138531"/5 +#> MLTPL__2[4]="-1.753221021810"/5 +#> MLTPL__2[5]="1.951164165430"/5 #>> 35 -#> GRAD[0]="0.010752717537"/6 -#> GRAD[1]="0.225795609124"/6 -#> GRAD[2]="-1.457564792508"/6 -#> GRAD[3]="0.027348606876"/6 -#> GRAD[4]="-1.455358944629"/6 -#> GRAD[5]="0.195604931952"/6 -#> GRAD[6]="-0.038101324413"/6 -#> GRAD[7]="1.229563335505"/6 -#> GRAD[8]="1.261959860556"/6 +#> GRAD[0]="0.010752385771"/6 +#> GRAD[1]="0.225790147751"/6 +#> GRAD[2]="-1.457537285310"/6 +#> GRAD[3]="0.027348598729"/6 +#> GRAD[4]="-1.455358129340"/6 +#> GRAD[5]="0.195604760663"/6 +#> GRAD[6]="-0.038100984500"/6 +#> GRAD[7]="1.229567981590"/6 +#> GRAD[8]="1.261932524647"/6 #>> 36 -#> EKIN="0.681043709156"/6 -#> EKIN="0.681043709156"/6 +#> EKIN="0.681072277154"/6 +#> EKIN="0.681072277154"/6 #>> 38 -#> POTNUC="6.260418701042"/6 -#> SEWARD_MLTPL1X="-0.017955959618"/5 +#> POTNUC="6.260378897253"/6 +#> SEWARD_MLTPL1X="-0.017955878560"/5 #> SEWARD_KINETIC="0.760031879922"/5 -#> SEWARD_ATTRACT="-4.461566115344"/5 +#> SEWARD_ATTRACT="-4.461527727771"/5 #>> 39 #> RASSCF_ITER="7"/8 -#> E_RASSCF="-53.696367352966"/8 +#> E_RASSCF="-53.696397544928"/8 #> MLTPL__0="8"/5 -#> MLTPL__1[0]="-0.040371255710"/5 -#> MLTPL__1[1]="1.307547272051"/5 -#> MLTPL__1[2]="1.333164236271"/5 -#> MLTPL__2[0]="-6.570812807973"/5 -#> MLTPL__2[1]="-0.171311718128"/5 -#> MLTPL__2[2]="-0.046861558255"/5 -#> MLTPL__2[3]="3.346947367386"/5 -#> MLTPL__2[4]="-2.775454190486"/5 -#> MLTPL__2[5]="3.223865440587"/5 +#> MLTPL__1[0]="-0.040371202298"/5 +#> MLTPL__1[1]="1.307547801640"/5 +#> MLTPL__1[2]="1.333201445113"/5 +#> MLTPL__2[0]="-6.570895704546"/5 +#> MLTPL__2[1]="-0.171311757059"/5 +#> MLTPL__2[2]="-0.046862024137"/5 +#> MLTPL__2[3]="3.346861252804"/5 +#> MLTPL__2[4]="-2.775476936261"/5 +#> MLTPL__2[5]="3.224034451742"/5 #>> 40 -#> GRAD[0]="0.006622899034"/6 -#> GRAD[1]="0.132628778583"/6 -#> GRAD[2]="-0.885502118606"/6 -#> GRAD[3]="0.016712946675"/6 -#> GRAD[4]="-0.886708645357"/6 -#> GRAD[5]="0.114520817775"/6 -#> GRAD[6]="-0.023335845709"/6 -#> GRAD[7]="0.754079866775"/6 -#> GRAD[8]="0.770981300830"/6 +#> GRAD[0]="0.006622606632"/6 +#> GRAD[1]="0.132624188318"/6 +#> GRAD[2]="-0.885480437693"/6 +#> GRAD[3]="0.016712940180"/6 +#> GRAD[4]="-0.886707983858"/6 +#> GRAD[5]="0.114520792836"/6 +#> GRAD[6]="-0.023335546812"/6 +#> GRAD[7]="0.754083795539"/6 +#> GRAD[8]="0.770959644858"/6 #>> 41 -#> EKIN="1.982824595726"/6 -#> EKIN="1.982824595726"/6 +#> EKIN="1.982855406992"/6 +#> EKIN="1.982855406992"/6 #>> 43 -#> POTNUC="4.808066333516"/6 -#> SEWARD_MLTPL1X="-0.023690219917"/5 +#> POTNUC="4.808037290780"/6 +#> SEWARD_MLTPL1X="-0.023689993914"/5 #> SEWARD_KINETIC="0.760031879922"/5 -#> SEWARD_ATTRACT="-3.722067171037"/5 +#> SEWARD_ATTRACT="-3.722038178297"/5 #>> 44 #> RASSCF_ITER="7"/8 -#> E_RASSCF="-54.799348759705"/8 +#> E_RASSCF="-54.799370786138"/8 #> MLTPL__0="8"/5 -#> MLTPL__1[0]="-0.052837854745"/5 -#> MLTPL__1[1]="1.710855795587"/5 -#> MLTPL__1[2]="1.746724614366"/5 -#> MLTPL__2[0]="-11.134007752473"/5 -#> MLTPL__2[1]="-0.291358721008"/5 -#> MLTPL__2[2]="-0.082408085990"/5 -#> MLTPL__2[3]="5.651352838938"/5 -#> MLTPL__2[4]="-4.563775299978"/5 -#> MLTPL__2[5]="5.482654913536"/5 +#> MLTPL__1[0]="-0.052837709231"/5 +#> MLTPL__1[1]="1.710857567194"/5 +#> MLTPL__1[2]="1.746775405300"/5 +#> MLTPL__2[0]="-11.134141154736"/5 +#> MLTPL__2[1]="-0.291358914335"/5 +#> MLTPL__2[2]="-0.082408189544"/5 +#> MLTPL__2[3]="5.651208934490"/5 +#> MLTPL__2[4]="-4.563803720034"/5 +#> MLTPL__2[5]="5.482932220246"/5 #>> 45 -#> GRAD[0]="0.003946256177"/6 -#> GRAD[1]="0.076139687430"/6 -#> GRAD[2]="-0.522123462500"/6 -#> GRAD[3]="0.009896392265"/6 -#> GRAD[4]="-0.523851278380"/6 -#> GRAD[5]="0.065541349258"/6 -#> GRAD[6]="-0.013842648442"/6 -#> GRAD[7]="0.447711590950"/6 -#> GRAD[8]="0.456582113241"/6 +#> GRAD[0]="0.003946069998"/6 +#> GRAD[1]="0.076136872617"/6 +#> GRAD[2]="-0.522111317768"/6 +#> GRAD[3]="0.009896388950"/6 +#> GRAD[4]="-0.523850924449"/6 +#> GRAD[5]="0.065541438233"/6 +#> GRAD[6]="-0.013842458948"/6 +#> GRAD[7]="0.447714051832"/6 +#> GRAD[8]="0.456569879535"/6 #>> 46 -#> EKIN="3.092732643262"/6 -#> EKIN="3.092732643262"/6 +#> EKIN="3.092755733830"/6 +#> EKIN="3.092755733830"/6 #>> 48 -#> POTNUC="3.788690415370"/6 -#> SEWARD_MLTPL1X="-0.030340447885"/5 +#> POTNUC="3.788670250305"/6 +#> SEWARD_MLTPL1X="-0.030340033721"/5 #> SEWARD_KINETIC="0.760031879922"/5 -#> SEWARD_ATTRACT="-3.194108135617"/5 +#> SEWARD_ATTRACT="-3.194087794214"/5 #>> 49 #> RASSCF_ITER="6"/8 -#> E_RASSCF="-55.573676942602"/8 +#> E_RASSCF="-55.573692231891"/8 #> MLTPL__0="8"/5 -#> MLTPL__1[0]="-0.067301025185"/5 -#> MLTPL__1[1]="2.178739458442"/5 -#> MLTPL__1[2]="2.226138969014"/5 -#> MLTPL__2[0]="-17.924655318430"/5 -#> MLTPL__2[1]="-0.470356488907"/5 -#> MLTPL__2[2]="-0.136056860776"/5 -#> MLTPL__2[3]="9.079010179066"/5 -#> MLTPL__2[4]="-7.188641608362"/5 -#> MLTPL__2[5]="8.845645139364"/5 +#> MLTPL__1[0]="-0.067300760235"/5 +#> MLTPL__1[1]="2.178742826850"/5 +#> MLTPL__1[2]="2.226201578213"/5 +#> MLTPL__2[0]="-17.924844310854"/5 +#> MLTPL__2[1]="-0.470356966458"/5 +#> MLTPL__2[2]="-0.136055937712"/5 +#> MLTPL__2[3]="9.078797849342"/5 +#> MLTPL__2[4]="-7.188669601094"/5 +#> MLTPL__2[5]="8.846046461512"/5 #>> 50 -#> GRAD[0]="0.002468016633"/6 -#> GRAD[1]="0.046368110128"/6 -#> GRAD[2]="-0.324153670834"/6 -#> GRAD[3]="0.006160728210"/6 -#> GRAD[4]="-0.325586365431"/6 -#> GRAD[5]="0.039811853675"/6 -#> GRAD[6]="-0.008628744843"/6 -#> GRAD[7]="0.279218255303"/6 -#> GRAD[8]="0.284341817159"/6 +#> GRAD[0]="0.002467901096"/6 +#> GRAD[1]="0.046366404328"/6 +#> GRAD[2]="-0.324147025856"/6 +#> GRAD[3]="0.006160726611"/6 +#> GRAD[4]="-0.325586184450"/6 +#> GRAD[5]="0.039811968913"/6 +#> GRAD[6]="-0.008628627707"/6 +#> GRAD[7]="0.279219780122"/6 +#> GRAD[8]="0.284335056943"/6 #>> 51 -#> EKIN="3.878730549131"/6 -#> EKIN="3.878730549131"/6 +#> EKIN="3.878746845197"/6 +#> EKIN="3.878746845197"/6 #>> 53 -#> POTNUC="8.716158739574"/6 +#> POTNUC="8.406120558164"/6 #>> 54 -#> POTNUC="8.716158739574"/6 -#> SEWARD_MLTPL1X="-0.013494401694"/5 +#> POTNUC="8.406120558164"/6 +#> SEWARD_MLTPL1X="-0.015991686967"/5 #> SEWARD_KINETIC="0.760031879922"/5 -#> SEWARD_ATTRACT="-5.680461463033"/5 +#> SEWARD_ATTRACT="-5.435742769399"/5 #>> 55 #> RASSCF_ITER="8"/8 -#> E_RASSCF="-51.829881804644"/8 +#> E_RASSCF="-52.062636553983"/8 #> MLTPL__0="8"/5 -#> MLTPL__1[0]="-0.029952161045"/5 -#> MLTPL__1[1]="0.979143476271"/5 -#> MLTPL__1[2]="0.967872321133"/5 -#> MLTPL__2[0]="-3.382897946147"/5 -#> MLTPL__2[1]="-0.092847185168"/5 -#> MLTPL__2[2]="-0.027054325673"/5 -#> MLTPL__2[3]="1.846127329576"/5 -#> MLTPL__2[4]="-1.221155532131"/5 -#> MLTPL__2[5]="1.536770616570"/5 +#> MLTPL__1[0]="-0.032075694000"/5 +#> MLTPL__1[1]="1.022280119439"/5 +#> MLTPL__1[2]="1.087015039541"/5 +#> MLTPL__2[0]="-3.622514083971"/5 +#> MLTPL__2[1]="-0.096726150808"/5 +#> MLTPL__2[2]="-0.040456698848"/5 +#> MLTPL__2[3]="1.638988033468"/5 +#> MLTPL__2[4]="-0.914903688692"/5 +#> MLTPL__2[5]="1.983526050503"/5 #>> 56 -#> GRAD[0]="0.013903639196"/6 -#> GRAD[1]="0.228397443039"/6 -#> GRAD[2]="-1.762061324761"/6 -#> GRAD[3]="0.031986871561"/6 -#> GRAD[4]="-1.680491287120"/6 -#> GRAD[5]="0.186735994089"/6 -#> GRAD[6]="-0.045890510756"/6 -#> GRAD[7]="1.452093844081"/6 -#> GRAD[8]="1.575325330673"/6 +#> GRAD[0]="0.013192572309"/6 +#> GRAD[1]="0.153901041095"/6 +#> GRAD[2]="-1.551192814182"/6 +#> GRAD[3]="0.032229746994"/6 +#> GRAD[4]="-1.659993345443"/6 +#> GRAD[5]="0.124221281144"/6 +#> GRAD[6]="-0.045422319302"/6 +#> GRAD[7]="1.506092304348"/6 +#> GRAD[8]="1.426971533037"/6 #>> 57 -#> EKIN="0.008367237452"/6 +#> EKIN="0.003342356906"/6 #>> 59 -#> POTNUC="7.730748426489"/6 -#> SEWARD_MLTPL1X="-0.015500342321"/5 +#> POTNUC="7.580465148800"/6 +#> SEWARD_MLTPL1X="-0.018121604534"/5 #> SEWARD_KINETIC="0.760031879922"/5 -#> SEWARD_ATTRACT="-5.250443116232"/5 +#> SEWARD_ATTRACT="-5.056188936032"/5 #>> 60 -#> RASSCF_ITER="7"/8 -#> E_RASSCF="-52.577784675405"/8 +#> RASSCF_ITER="6"/8 +#> E_RASSCF="-52.689400563617"/8 #> MLTPL__0="8"/5 -#> MLTPL__1[0]="-0.034299993680"/5 -#> MLTPL__1[1]="1.132829645069"/5 -#> MLTPL__1[2]="1.089683105792"/5 -#> MLTPL__2[0]="-4.298344879081"/5 -#> MLTPL__2[1]="-0.121222697915"/5 -#> MLTPL__2[2]="-0.035958052460"/5 -#> MLTPL__2[3]="2.440318503155"/5 -#> MLTPL__2[4]="-1.425111277497"/5 -#> MLTPL__2[5]="1.858026375926"/5 +#> MLTPL__1[0]="-0.035955672137"/5 +#> MLTPL__1[1]="1.146334796632"/5 +#> MLTPL__1[2]="1.218053596648"/5 +#> MLTPL__2[0]="-4.449577599194"/5 +#> MLTPL__2[1]="-0.120190211821"/5 +#> MLTPL__2[2]="-0.052210603894"/5 +#> MLTPL__2[3]="2.014213938831"/5 +#> MLTPL__2[4]="-0.997609821317"/5 +#> MLTPL__2[5]="2.435363660363"/5 #>> 61 -#> GRAD[0]="0.011383396501"/6 -#> GRAD[1]="0.168782263879"/6 -#> GRAD[2]="-1.407174986709"/6 -#> GRAD[3]="0.024933528600"/6 -#> GRAD[4]="-1.303916489319"/6 -#> GRAD[5]="0.134190818253"/6 -#> GRAD[6]="-0.036316925101"/6 -#> GRAD[7]="1.135134225441"/6 -#> GRAD[8]="1.272984168456"/6 +#> GRAD[0]="0.010941773412"/6 +#> GRAD[1]="0.115199010757"/6 +#> GRAD[2]="-1.262967536253"/6 +#> GRAD[3]="0.026333989616"/6 +#> GRAD[4]="-1.349690469222"/6 +#> GRAD[5]="0.089346931384"/6 +#> GRAD[6]="-0.037275763028"/6 +#> GRAD[7]="1.234491458465"/6 +#> GRAD[8]="1.173620604870"/6 #>> 62 -#> EKIN="0.692158394045"/6 -#> EKIN="0.692158394045"/6 +#> EKIN="0.579687412013"/6 +#> EKIN="0.579687412013"/6 #>> 64 -#> POTNUC="6.098342700147"/6 -#> SEWARD_MLTPL1X="-0.020148489300"/5 +#> POTNUC="6.092756073383"/6 +#> SEWARD_MLTPL1X="-0.022791223077"/5 #> SEWARD_KINETIC="0.760031879922"/5 -#> SEWARD_ATTRACT="-4.437019370238"/5 +#> SEWARD_ATTRACT="-4.352634257300"/5 #>> 65 #> RASSCF_ITER="7"/8 -#> E_RASSCF="-53.817502359706"/8 +#> E_RASSCF="-53.819674171549"/8 #> MLTPL__0="8"/5 -#> MLTPL__1[0]="-0.043891946595"/5 -#> MLTPL__1[1]="1.450420018886"/5 -#> MLTPL__1[2]="1.395326125998"/5 -#> MLTPL__2[0]="-6.898933731220"/5 -#> MLTPL__2[1]="-0.195508174238"/5 -#> MLTPL__2[2]="-0.061612174221"/5 -#> MLTPL__2[3]="3.874588506660"/5 -#> MLTPL__2[4]="-2.117484844149"/5 -#> MLTPL__2[5]="3.024345224560"/5 +#> MLTPL__1[0]="-0.045218491998"/5 +#> MLTPL__1[1]="1.448659937144"/5 +#> MLTPL__1[2]="1.518564959006"/5 +#> MLTPL__2[0]="-6.878182933847"/5 +#> MLTPL__2[1]="-0.189972298915"/5 +#> MLTPL__2[2]="-0.082706803747"/5 +#> MLTPL__2[3]="3.234003457736"/5 +#> MLTPL__2[4]="-1.379406965028"/5 +#> MLTPL__2[5]="3.644179476110"/5 #>> 66 -#> GRAD[0]="0.007195723981"/6 -#> GRAD[1]="0.098252877223"/6 -#> GRAD[2]="-0.873088089574"/6 -#> GRAD[3]="0.015652032092"/6 -#> GRAD[4]="-0.815072326188"/6 -#> GRAD[5]="0.077666746962"/6 -#> GRAD[6]="-0.022847756073"/6 -#> GRAD[7]="0.716819448965"/6 -#> GRAD[8]="0.795421342612"/6 +#> GRAD[0]="0.007270877568"/6 +#> GRAD[1]="0.069421480341"/6 +#> GRAD[2]="-0.825707936185"/6 +#> GRAD[3]="0.016889786383"/6 +#> GRAD[4]="-0.862549569220"/6 +#> GRAD[5]="0.051629858546"/6 +#> GRAD[6]="-0.024160663951"/6 +#> GRAD[7]="0.793128088879"/6 +#> GRAD[8]="0.774078077639"/6 #>> 67 -#> EKIN="1.897308698934"/6 -#> EKIN="1.897308698934"/6 +#> EKIN="1.675790183476"/6 +#> EKIN="1.675790183476"/6 #>> 69 -#> POTNUC="4.738152133861"/6 -#> SEWARD_MLTPL1X="-0.026466839685"/5 +#> POTNUC="4.790059416508"/6 +#> SEWARD_MLTPL1X="-0.029148488966"/5 #> SEWARD_KINETIC="0.760031879922"/5 -#> SEWARD_ATTRACT="-3.722553261982"/5 +#> SEWARD_ATTRACT="-3.706928365820"/5 #>> 70 #> RASSCF_ITER="7"/8 -#> E_RASSCF="-54.850845019734"/8 +#> E_RASSCF="-54.809766896007"/8 #> MLTPL__0="8"/5 -#> MLTPL__1[0]="-0.056780400274"/5 -#> MLTPL__1[1]="1.871433418526"/5 -#> MLTPL__1[2]="1.815734354536"/5 -#> MLTPL__2[0]="-11.415708631021"/5 -#> MLTPL__2[1]="-0.322497932543"/5 -#> MLTPL__2[2]="-0.107463292037"/5 -#> MLTPL__2[3]="6.260329707967"/5 -#> MLTPL__2[4]="-3.310709714972"/5 -#> MLTPL__2[5]="5.155378923054"/5 +#> MLTPL__1[0]="-0.057967563197"/5 +#> MLTPL__1[1]="1.865426947327"/5 +#> MLTPL__1[2]="1.930775667073"/5 +#> MLTPL__2[0]="-11.118199623083"/5 +#> MLTPL__2[1]="-0.312805047929"/5 +#> MLTPL__2[2]="-0.135358485865"/5 +#> MLTPL__2[3]="5.414815140669"/5 +#> MLTPL__2[4]="-2.048744139983"/5 +#> MLTPL__2[5]="5.703384482414"/5 #>> 71 -#> GRAD[0]="0.004362119543"/6 -#> GRAD[1]="0.056370559318"/6 -#> GRAD[2]="-0.523068587728"/6 -#> GRAD[3]="0.009562928726"/6 -#> GRAD[4]="-0.496455034438"/6 -#> GRAD[5]="0.044542003995"/6 -#> GRAD[6]="-0.013925048269"/6 -#> GRAD[7]="0.440084475120"/6 -#> GRAD[8]="0.478526583733"/6 +#> GRAD[0]="0.004597081560"/6 +#> GRAD[1]="0.040765465745"/6 +#> GRAD[2]="-0.516114045257"/6 +#> GRAD[3]="0.010356111132"/6 +#> GRAD[4]="-0.527669532475"/6 +#> GRAD[5]="0.029439563421"/6 +#> GRAD[6]="-0.014953192693"/6 +#> GRAD[7]="0.486904066730"/6 +#> GRAD[8]="0.486674481835"/6 #>> 72 -#> EKIN="2.935766124905"/6 -#> EKIN="2.935766124905"/6 +#> EKIN="2.667575672325"/6 +#> EKIN="2.667575672325"/6 #>> 74 -#> POTNUC="3.764576599650"/6 -#> SEWARD_MLTPL1X="-0.033797684010"/5 +#> POTNUC="3.830270920069"/6 +#> SEWARD_MLTPL1X="-0.036572785956"/5 #> SEWARD_KINETIC="0.760031879922"/5 -#> SEWARD_ATTRACT="-3.204335603641"/5 +#> SEWARD_ATTRACT="-3.219089808980"/5 #>> 75 #> RASSCF_ITER="5"/8 -#> E_RASSCF="-55.590670563769"/8 +#> E_RASSCF="-55.539437952567"/8 #> MLTPL__0="8"/5 -#> MLTPL__1[0]="-0.071677511243"/5 -#> MLTPL__1[1]="2.355930088022"/5 -#> MLTPL__1[2]="2.305164988855"/5 -#> MLTPL__2[0]="-18.070399055159"/5 -#> MLTPL__2[1]="-0.508386794965"/5 -#> MLTPL__2[2]="-0.176470373318"/5 -#> MLTPL__2[3]="9.698803933776"/5 -#> MLTPL__2[4]="-5.036726995027"/5 -#> MLTPL__2[5]="8.371595121384"/5 +#> MLTPL__1[0]="-0.072873697330"/5 +#> MLTPL__1[1]="2.352429913403"/5 +#> MLTPL__1[2]="2.413195248521"/5 +#> MLTPL__2[0]="-17.379990006976"/5 +#> MLTPL__2[1]="-0.495202992500"/5 +#> MLTPL__2[2]="-0.213169384891"/5 +#> MLTPL__2[3]="8.673031354516"/5 +#> MLTPL__2[4]="-3.015056754618"/5 +#> MLTPL__2[5]="8.706958652460"/5 #>> 76 -#> GRAD[0]="0.002755335126"/6 -#> GRAD[1]="0.034342233106"/6 -#> GRAD[2]="-0.327939263610"/6 -#> GRAD[3]="0.006096390603"/6 -#> GRAD[4]="-0.315824325881"/6 -#> GRAD[5]="0.027125853378"/6 -#> GRAD[6]="-0.008851725729"/6 -#> GRAD[7]="0.281482092775"/6 -#> GRAD[8]="0.300813410232"/6 +#> GRAD[0]="0.002985333288"/6 +#> GRAD[1]="0.025133568089"/6 +#> GRAD[2]="-0.332613816695"/6 +#> GRAD[3]="0.006582781984"/6 +#> GRAD[4]="-0.334918348601"/6 +#> GRAD[5]="0.017812326665"/6 +#> GRAD[6]="-0.009568115272"/6 +#> GRAD[7]="0.309784780512"/6 +#> GRAD[8]="0.314801490031"/6 #>> 77 -#> EKIN="3.685603630645"/6 -#> EKIN="3.685603630645"/6 +#> EKIN="3.405656759408"/6 +#> EKIN="3.405656759408"/6 +#>> 79 +#> POTNUC="9.249375806541"/6 +#>> 80 +#> POTNUC="9.249375806541"/6 +#> SEWARD_MLTPL1X="-0.011209860183"/5 +#> SEWARD_KINETIC="0.760031879922"/5 +#> SEWARD_ATTRACT="-5.905138917967"/5 +#>> 81 +#> RASSCF_ITER="8"/8 +#> E_RASSCF="-51.427930201269"/8 +#> MLTPL__0="8"/5 +#> MLTPL__1[0]="-0.026726197761"/5 +#> MLTPL__1[1]="0.873155597982"/5 +#> MLTPL__1[2]="0.864648244209"/5 +#> MLTPL__2[0]="-3.019557499083"/5 +#> MLTPL__2[1]="-0.078868812681"/5 +#> MLTPL__2[2]="-0.016753877340"/5 +#> MLTPL__2[3]="1.641725587281"/5 +#> MLTPL__2[4]="-1.459134060655"/5 +#> MLTPL__2[5]="1.377831911802"/5 +#>> 82 +#> GRAD[0]="0.013956559149"/6 +#> GRAD[1]="0.333661093624"/6 +#> GRAD[2]="-1.969448420707"/6 +#> GRAD[3]="0.035200795431"/6 +#> GRAD[4]="-1.889235384107"/6 +#> GRAD[5]="0.282188898209"/6 +#> GRAD[6]="-0.049157354580"/6 +#> GRAD[7]="1.555574290483"/6 +#> GRAD[8]="1.687259522498"/6 +#>> 83 +#> EKIN="0.001278628236"/6 +#>> 85 +#> POTNUC="8.135022566769"/6 +#> SEWARD_MLTPL1X="-0.012664392449"/5 +#> SEWARD_KINETIC="0.760031879922"/5 +#> SEWARD_ATTRACT="-5.410834732418"/5 +#>> 86 +#> RASSCF_ITER="7"/8 +#> E_RASSCF="-52.274119590998"/8 +#> MLTPL__0="8"/5 +#> MLTPL__1[0]="-0.030422224325"/5 +#> MLTPL__1[1]="0.994154478621"/5 +#> MLTPL__1[2]="0.978531355748"/5 +#> MLTPL__2[0]="-3.904751645857"/5 +#> MLTPL__2[1]="-0.102285727360"/5 +#> MLTPL__2[2]="-0.021116570453"/5 +#> MLTPL__2[3]="2.147943165004"/5 +#> MLTPL__2[4]="-1.901659942402"/5 +#> MLTPL__2[5]="1.756808480853"/5 +#>> 87 +#> GRAD[0]="0.010805143971"/6 +#> GRAD[1]="0.260880896094"/6 +#> GRAD[2]="-1.529577263663"/6 +#> GRAD[3]="0.027073610258"/6 +#> GRAD[4]="-1.454935816707"/6 +#> GRAD[5]="0.219450766466"/6 +#> GRAD[6]="-0.037878754229"/6 +#> GRAD[7]="1.194054920614"/6 +#> GRAD[8]="1.310126497197"/6 +#>> 88 +#> EKIN="0.761593613085"/6 +#> EKIN="0.761593613085"/6 +#>> 90 +#> POTNUC="6.258676879682"/6 +#> SEWARD_MLTPL1X="-0.016626912559"/5 +#> SEWARD_KINETIC="0.760031879922"/5 +#> SEWARD_ATTRACT="-4.486314151084"/5 +#>> 91 +#> RASSCF_ITER="7"/8 +#> E_RASSCF="-53.698726368103"/8 +#> MLTPL__0="8"/5 +#> MLTPL__1[0]="-0.039588052614"/5 +#> MLTPL__1[1]="1.287573791397"/5 +#> MLTPL__1[2]="1.281609564990"/5 +#> MLTPL__2[0]="-6.593830912192"/5 +#> MLTPL__2[1]="-0.171361054511"/5 +#> MLTPL__2[2]="-0.037008734398"/5 +#> MLTPL__2[3]="3.549167604905"/5 +#> MLTPL__2[4]="-3.185667175725"/5 +#> MLTPL__2[5]="3.044663307287"/5 +#>> 92 +#> GRAD[0]="0.006365890194"/6 +#> GRAD[1]="0.152359462235"/6 +#> GRAD[2]="-0.898546997868"/6 +#> GRAD[3]="0.016167818923"/6 +#> GRAD[4]="-0.868301946177"/6 +#> GRAD[5]="0.129489646571"/6 +#> GRAD[6]="-0.022533709117"/6 +#> GRAD[7]="0.715942483942"/6 +#> GRAD[8]="0.769057351297"/6 +#>> 93 +#> EKIN="2.145531326408"/6 +#> EKIN="2.145531326408"/6 +#>> 95 +#> POTNUC="4.769406687136"/6 +#> SEWARD_MLTPL1X="-0.022067022903"/5 +#> SEWARD_KINETIC="0.760031879922"/5 +#> SEWARD_ATTRACT="-3.713765642857"/5 +#>> 96 +#> RASSCF_ITER="7"/8 +#> E_RASSCF="-54.829598019687"/8 +#> MLTPL__0="8"/5 +#> MLTPL__1[0]="-0.052004681419"/5 +#> MLTPL__1[1]="1.684279261040"/5 +#> MLTPL__1[2]="1.695632247987"/5 +#> MLTPL__2[0]="-11.349755496283"/5 +#> MLTPL__2[1]="-0.292748534775"/5 +#> MLTPL__2[2]="-0.066354928473"/5 +#> MLTPL__2[3]="5.971735585048"/5 +#> MLTPL__2[4]="-5.424113326198"/5 +#> MLTPL__2[5]="5.378019911235"/5 +#>> 97 +#> GRAD[0]="0.003684090381"/6 +#> GRAD[1]="0.087065376283"/6 +#> GRAD[2]="-0.517868255872"/6 +#> GRAD[3]="0.009478816048"/6 +#> GRAD[4]="-0.508539269790"/6 +#> GRAD[5]="0.074735906488"/6 +#> GRAD[6]="-0.013162906429"/6 +#> GRAD[7]="0.421473893508"/6 +#> GRAD[8]="0.443132349384"/6 +#>> 98 +#> EKIN="3.286282340667"/6 +#> EKIN="3.286282340667"/6 +#>> 100 +#> POTNUC="3.743484277875"/6 +#> SEWARD_MLTPL1X="-0.028362249469"/5 +#> SEWARD_KINETIC="0.760031879922"/5 +#> SEWARD_ATTRACT="-3.174874341210"/5 +#>> 101 +#> RASSCF_ITER="5"/8 +#> E_RASSCF="-55.608758980719"/8 +#> MLTPL__0="8"/5 +#> MLTPL__1[0]="-0.066319751807"/5 +#> MLTPL__1[1]="2.141774405070"/5 +#> MLTPL__1[2]="2.173562781460"/5 +#> MLTPL__2[0]="-18.418048791162"/5 +#> MLTPL__2[1]="-0.472673654238"/5 +#> MLTPL__2[2]="-0.111023282158"/5 +#> MLTPL__2[3]="9.532267556065"/5 +#> MLTPL__2[4]="-8.719537229126"/5 +#> MLTPL__2[5]="8.885781235097"/5 +#>> 102 +#> GRAD[0]="0.002265643587"/6 +#> GRAD[1]="0.052949139030"/6 +#> GRAD[2]="-0.317332546854"/6 +#> GRAD[3]="0.005880005696"/6 +#> GRAD[4]="-0.315179281670"/6 +#> GRAD[5]="0.045752819615"/6 +#> GRAD[6]="-0.008145649283"/6 +#> GRAD[7]="0.262230142641"/6 +#> GRAD[8]="0.271579727239"/6 +#>> 103 +#> EKIN="4.078255416265"/6 +#> EKIN="4.078255416265"/6 >>EOF diff -Nru openmolcas-22.02/test/qcmaquis/011.input openmolcas-22.10/test/qcmaquis/011.input --- openmolcas-22.02/test/qcmaquis/011.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/qcmaquis/011.input 2022-10-10 14:22:40.000000000 +0000 @@ -49,9 +49,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-659-gf37ce07dd -* Linux lucifer 5.11.0-43-generic #47~20.04.2-Ubuntu SMP Mon Dec 13 11:06:56 UTC 2021 x86_64 x86_64 x86_64 GNU/Linux -* Wed Jan 12 13:17:54 2022 +* Molcas version 22.02-135-ge74223037 +* Linux otis 5.4.0-104-generic #118~18.04.1-Ubuntu SMP Thu Mar 3 13:53:15 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Sun Apr 3 08:58:10 2022 * #>> 1 #> POTNUC="28.222784581493"/12 @@ -65,32 +65,32 @@ #> SEWARD_ATTRACT="-64.860673449499"/5 #>> 3 #> RASSCF_ITER="12"/8 -#> E_RASSCF="-149.793947832949"/6 +#> E_RASSCF="-149.793947832943"/6 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 -#> MLTPL__1[2]="-0.000000000000"/5 -#> MLTPL__2[0]="0.100287123670"/5 +#> MLTPL__1[2]="0.000000000002"/5 +#> MLTPL__2[0]="0.100287123667"/5 #> MLTPL__2[1]="0.000000000000"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="0.100287123670"/5 +#> MLTPL__2[3]="0.100287123668"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.200574247339"/5 +#> MLTPL__2[5]="-0.200574247335"/5 #>> 4 -#> DENS_TT="16.000000581581"/6 -#> DENS_A1="9.000000425912"/6 -#> DENS_B1="7.000000155668"/6 -#> DENS_A2="9.557638945812"/6 -#> DENS_B2="6.442361635768"/6 +#> DENS_TT="16.000000581547"/6 +#> DENS_A1="9.000000425898"/6 +#> DENS_B1="7.000000155650"/6 +#> DENS_A2="9.557638945795"/6 +#> DENS_B2="6.442361635752"/6 #> EXCH_F="1"/6 #> CORR_F="1"/6 -#> EXCHA_A="-9.960606363991"/6 -#> EXCHA_B="-6.464517281779"/6 -#> CORR_E="-0.529800431395"/6 -#> CASDFTE="-150.371538376992"/8 +#> EXCHA_A="-9.960606363972"/6 +#> EXCHA_B="-6.464517281766"/6 +#> CORR_E="-0.529800431396"/6 +#> CASDFTE="-150.371538376955"/8 #>> 5 -#> E_RASSI="-150.371538376992"/7 -#> ESO_LOW[0]="-150.371538376992"/8 -#> ESO_LOW[1]="-150.371538376992"/8 -#> ESO_LOW[2]="-150.371538376992"/8 +#> E_RASSI="-150.371538376955"/7 +#> ESO_LOW[0]="-150.371538376955"/7 +#> ESO_LOW[1]="-150.371538376955"/7 +#> ESO_LOW[2]="-150.371538376955"/7 >>EOF diff -Nru openmolcas-22.02/test/standard/001.input openmolcas-22.10/test/standard/001.input --- openmolcas-22.02/test/standard/001.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/standard/001.input 2022-10-10 14:22:40.000000000 +0000 @@ -38,12 +38,11 @@ &SCF OneGrid KSDFT = $DFT ->>enddo -*------------------------------------------------------------------------------- &SCF OneGrid -KSDFT = BLYP +KSDFT = $DFT DFCF=1.25 0.5 +>>enddo *------------------------------------------------------------------------------- @@ -58,20 +57,32 @@ y xz NoCD &SEWARD ->>foreach DFT in (BLYP, B3LYP ) + +* Testing custom Libxc input: +* These should be equivalent to BLYP and B3LYP + &SCF OneGrid UHF -KSDFT = $DFT ->>enddo +KSDFT=2 + 2.0 GGA_X_B88 + 0.5 GGA_C_LYP +* note that DFCF cancels out the above factors +DFCF = 0.5 2.0 + + &SCF +OneGrid +UHF +KSDFT=HYB_GGA_XC_B3LYP + *------------------------------------------------------------------------------- >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-943-g4c2682958 -* Linux lucifer 5.13.0-27-generic #29~20.04.1-Ubuntu SMP Fri Jan 14 00:32:30 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux -* Sat Feb 5 17:07:33 2022 +* Molcas version 22.02-74-g097232700 +* Linux hirundo 5.4.0-96-generic #109~18.04.1-Ubuntu SMP Thu Jan 13 15:06:26 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Sat Feb 26 14:28:07 2022 * #>> 1 #> POTNUC="42.253312780109"/12 @@ -82,60 +93,75 @@ #> SEWARD_ATTRACT="-38.252494332942"/5 #>> 3 #> SCF_ITER="8"/8 -#> E_SCF="-79.751053069847"/8 -#> DFT_ENERGY="-13.006427049352"/6 -#> NQ_DENSITY="17.999972365793"/8 +#> E_SCF="-79.751053069823"/8 +#> DFT_ENERGY="-13.006427049336"/6 +#> NQ_DENSITY="17.999972365756"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.218366029441"/5 +#> MLTPL__2[0]="0.218366029400"/5 #> MLTPL__2[1]="0.0"/5 -#> MLTPL__2[2]="-0.095818484375"/5 -#> MLTPL__2[3]="0.231810296817"/5 +#> MLTPL__2[2]="-0.095818484397"/5 +#> MLTPL__2[3]="0.231810296788"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.450176326258"/5 -#>> 5 -#> SCF_ITER="5"/8 -#> E_SCF="-79.816264847831"/8 -#> DFT_ENERGY="-10.580631771596"/6 -#> NQ_DENSITY="17.999972141690"/8 +#> MLTPL__2[5]="-0.450176326188"/5 +#>> 4 +#> SCF_ITER="8"/8 +#> E_SCF="-82.608364892116"/8 +#> DFT_ENERGY="-16.046424996618"/6 +#> NQ_DENSITY="17.999972480878"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.230154316939"/5 +#> MLTPL__2[0]="0.136094186583"/5 #> MLTPL__2[1]="0.0"/5 -#> MLTPL__2[2]="-0.100974675988"/5 -#> MLTPL__2[3]="0.244334431938"/5 +#> MLTPL__2[2]="-0.059717851561"/5 +#> MLTPL__2[3]="0.144463675109"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.474488748877"/5 -#>> 7 +#> MLTPL__2[5]="-0.280557861692"/5 +#>> 6 #> SCF_ITER="8"/8 -#> E_SCF="-82.608364892149"/8 -#> DFT_ENERGY="-16.046424997520"/6 -#> NQ_DENSITY="17.999972480908"/8 +#> E_SCF="-79.816264847929"/8 +#> DFT_ENERGY="-10.580625232328"/6 +#> NQ_DENSITY="17.999972141589"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.136094180280"/5 +#> MLTPL__2[0]="0.230142809501"/5 #> MLTPL__2[1]="0.0"/5 -#> MLTPL__2[2]="-0.059717861567"/5 -#> MLTPL__2[3]="0.144463679246"/5 +#> MLTPL__2[2]="-0.100969669844"/5 +#> MLTPL__2[3]="0.244322214501"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.280557859526"/5 -#>> 8 -#> POTNUC="0.0"/12 +#> MLTPL__2[5]="-0.474465024002"/5 +#>> 7 +#> SCF_ITER="2"/8 +#> E_SCF="-79.816264847929"/8 +#> DFT_ENERGY="-10.580625209193"/6 +#> NQ_DENSITY="17.999972141587"/8 +#> MLTPL__0="-0.000000000000"/5 +#> MLTPL__1[0]="0.0"/5 +#> MLTPL__1[1]="0.0"/5 +#> MLTPL__1[2]="0.0"/5 +#> MLTPL__2[0]="0.230142813029"/5 +#> MLTPL__2[1]="0.0"/5 +#> MLTPL__2[2]="-0.100969664402"/5 +#> MLTPL__2[3]="0.244322212851"/5 +#> MLTPL__2[4]="0.0"/5 +#> MLTPL__2[5]="-0.474465025880"/5 #>> 9 #> POTNUC="0.0"/12 +#>> 10 +#> POTNUC="0.0"/12 #> SEWARD_MLTPL1X="0.0"/5 #> SEWARD_KINETIC="0.588103730668"/5 #> SEWARD_ATTRACT="-1.084170720692"/5 -#>> 10 +#>> 11 #> SCF_ITER="5"/8 -#> E_SCF="-0.497731583888"/8 -#> DFT_ENERGY="-0.306480878151"/6 +#> E_SCF="-0.497731583887"/8 +#> DFT_ENERGY="-0.306480878150"/6 #> NQ_DENSITY="1"/8 #> MLTPL__0="0.0"/5 #> MLTPL__1[0]="0.0"/5 diff -Nru openmolcas-22.02/test/standard/003.input openmolcas-22.10/test/standard/003.input --- openmolcas-22.02/test/standard/003.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/standard/003.input 2022-10-10 14:22:40.000000000 +0000 @@ -135,46 +135,46 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 20.10-824-gd83f65c67 -* Linux dirac 5.10.7-3-MANJARO #1 SMP PREEMPT Fri Jan 15 21:11:34 UTC 2021 x86_64 GNU/Linux -* Tue Feb 9 13:40:04 2021 +* Molcas version 22.02-135-ge74223037 +* Linux otis 5.4.0-104-generic #118~18.04.1-Ubuntu SMP Thu Mar 3 13:53:15 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Sun Apr 3 08:58:10 2022 * #>> 1 #> SEWARD_KINETIC="17955988.950000014156"/5 #> SEWARD_ATTRACT="-168848.637428736489"/5 #> POTNUC="29.173907573667"/12 -#> SEWARD_KINETIC="552.394993687088"/5 +#> SEWARD_KINETIC="552.394993687087"/5 #> SEWARD_ATTRACT="-1058.908576735454"/5 #>> 2 #> SCF_ITER="14"/8 -#> E_SCF="-2094.329154652416"/8 +#> E_SCF="-2094.329154652365"/8 #> MLTPL__0="2"/5 #>> 3 #> RASSCF_ITER="9"/8 -#> E_RASSCF[0]="-2097.012839549608"/8 -#> E_RASSCF[1]="-2096.999839330319"/8 -#> E_RASSCF[2]="-2096.961122700750"/8 +#> E_RASSCF[0]="-2097.012839549556"/8 +#> E_RASSCF[1]="-2096.999839330268"/8 +#> E_RASSCF[2]="-2096.961122700697"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__0="-0.000000000000"/5 #>> 4 -#> E_CASPT2="-2097.031303739321"/8 +#> E_CASPT2="-2097.031303739266"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2097.018462978133"/8 +#> E_CASPT2="-2097.018462978077"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2096.980256994497"/8 +#> E_CASPT2="-2096.980256994440"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_MSPT2[0]="-2097.031303739321"/8 -#> E_MSPT2[1]="-2097.018462978133"/8 -#> E_MSPT2[2]="-2096.980256994497"/8 +#> E_MSPT2[0]="-2097.031303739266"/8 +#> E_MSPT2[1]="-2097.018462978077"/8 +#> E_MSPT2[2]="-2096.980256994440"/8 #>> 5 #> RASSCF_ITER="8"/8 -#> E_RASSCF[0]="-2097.003292228087"/8 -#> E_RASSCF[1]="-2096.972885272986"/8 -#> E_RASSCF[2]="-2096.959739520701"/8 -#> E_RASSCF[3]="-2096.925801510860"/8 -#> E_RASSCF[4]="-2096.920335697155"/8 -#> E_RASSCF[5]="-2096.888113358409"/8 +#> E_RASSCF[0]="-2097.003292228035"/8 +#> E_RASSCF[1]="-2096.972885272933"/8 +#> E_RASSCF[2]="-2096.959739520649"/8 +#> E_RASSCF[3]="-2096.925801510808"/8 +#> E_RASSCF[4]="-2096.920335697105"/8 +#> E_RASSCF[5]="-2096.888113358356"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__0="-0.000000000000"/5 @@ -182,47 +182,47 @@ #> MLTPL__0="-0.000000000000"/5 #> MLTPL__0="-0.000000000000"/5 #>> 6 -#> E_CASPT2="-2097.022011068213"/8 +#> E_CASPT2="-2097.022011068163"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2096.992806609808"/8 +#> E_CASPT2="-2096.992806609760"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2096.979872244388"/8 +#> E_CASPT2="-2096.979872244336"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2096.946033196361"/8 +#> E_CASPT2="-2096.946033196311"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2096.940966505297"/8 +#> E_CASPT2="-2096.940966505247"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_CASPT2="-2096.906953848045"/8 +#> E_CASPT2="-2096.906953847995"/8 #> MLTPL__0="-0.000000000000"/5 -#> E_MSPT2[0]="-2097.022028560375"/8 -#> E_MSPT2[1]="-2096.992806609808"/8 -#> E_MSPT2[2]="-2096.979872244388"/8 -#> E_MSPT2[3]="-2096.946058959280"/8 -#> E_MSPT2[4]="-2096.940966505297"/8 -#> E_MSPT2[5]="-2096.906910592965"/8 +#> E_MSPT2[0]="-2097.022028560324"/8 +#> E_MSPT2[1]="-2096.992806609760"/8 +#> E_MSPT2[2]="-2096.979872244336"/8 +#> E_MSPT2[3]="-2096.946058959229"/8 +#> E_MSPT2[4]="-2096.940966505247"/8 +#> E_MSPT2[5]="-2096.906910592915"/8 #>> 7 -#> E_RASSI[0]="-2097.031303739321"/6 -#> E_RASSI[1]="-2097.018462978133"/6 -#> E_RASSI[2]="-2096.980256994497"/6 -#> E_RASSI[3]="-2097.022028560377"/6 -#> E_RASSI[4]="-2096.992806609810"/6 -#> E_RASSI[5]="-2096.979872244389"/6 -#> E_RASSI[6]="-2096.946058959281"/6 -#> E_RASSI[7]="-2096.940966505300"/6 -#> E_RASSI[8]="-2096.906910592966"/6 -#> ESO_LOW[0]="-2097.032296952509"/8 -#> ESO_LOW[1]="-2097.031616085927"/8 -#> ESO_LOW[2]="-2097.031430510830"/8 -#> ESO_LOW[3]="-2097.022312861352"/8 -#> ESO_LOW[4]="-2097.018668605788"/8 -#> ESO_LOW[5]="-2097.018220871976"/8 -#> ESO_LOW[6]="-2097.017489231650"/8 -#> ESO_LOW[7]="-2096.992932767579"/8 -#> ESO_LOW[8]="-2096.981748663302"/8 -#> ESO_LOW[9]="-2096.980321601628"/8 -#> ESO_LOW[10]="-2096.979925209072"/8 -#> ESO_LOW[11]="-2096.978253804074"/8 -#> ESO_LOW[12]="-2096.945933370524"/8 -#> ESO_LOW[13]="-2096.940896264852"/8 -#> ESO_LOW[14]="-2096.906667806911"/8 +#> E_RASSI[0]="-2097.031303739266"/6 +#> E_RASSI[1]="-2097.018462978077"/6 +#> E_RASSI[2]="-2096.980256994440"/6 +#> E_RASSI[3]="-2097.022028560325"/6 +#> E_RASSI[4]="-2096.992806609762"/6 +#> E_RASSI[5]="-2096.979872244338"/6 +#> E_RASSI[6]="-2096.946058959230"/6 +#> E_RASSI[7]="-2096.940966505250"/6 +#> E_RASSI[8]="-2096.906910592917"/6 +#> ESO_LOW[0]="-2097.032296952455"/6 +#> ESO_LOW[1]="-2097.031616085872"/6 +#> ESO_LOW[2]="-2097.031430510775"/6 +#> ESO_LOW[3]="-2097.022312861299"/6 +#> ESO_LOW[4]="-2097.018668605733"/6 +#> ESO_LOW[5]="-2097.018220871920"/6 +#> ESO_LOW[6]="-2097.017489231594"/6 +#> ESO_LOW[7]="-2096.992932767530"/6 +#> ESO_LOW[8]="-2096.981748663248"/6 +#> ESO_LOW[9]="-2096.980321601572"/6 +#> ESO_LOW[10]="-2096.979925209016"/6 +#> ESO_LOW[11]="-2096.978253804021"/6 +#> ESO_LOW[12]="-2096.945933370473"/6 +#> ESO_LOW[13]="-2096.940896264802"/6 +#> ESO_LOW[14]="-2096.906667806861"/6 >>EOF diff -Nru openmolcas-22.02/test/standard/017.input openmolcas-22.10/test/standard/017.input --- openmolcas-22.02/test/standard/017.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/standard/017.input 2022-10-10 14:22:40.000000000 +0000 @@ -38,9 +38,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-943-g4c2682958 -* Linux lucifer 5.13.0-27-generic #29~20.04.1-Ubuntu SMP Fri Jan 14 00:32:30 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux -* Sat Feb 5 17:07:33 2022 +* Molcas version 22.02-260-gd39e60428 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Wed Apr 27 18:28:24 2022 * #>> 1 #> POTNUC="13.522136977422"/6 @@ -49,98 +49,98 @@ #> SEWARD_ATTRACT="-35.941520411926"/5 #>> 2 #> SCF_ITER="8"/8 -#> E_SCF="-40.515612956798"/8 -#> DFT_ENERGY="-5.597618868963"/6 -#> NQ_DENSITY="10.000007868873"/8 +#> E_SCF="-40.515612956788"/8 +#> DFT_ENERGY="-5.597618868956"/6 +#> NQ_DENSITY="10.000007868841"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="0.0"/5 +#> MLTPL__1[1]="0.000000000000"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.000004364287"/5 +#> MLTPL__2[0]="-0.000004364286"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="0.000008728574"/5 +#> MLTPL__2[3]="0.000008728571"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.000004364287"/5 +#> MLTPL__2[5]="-0.000004364286"/5 #>> 3 -#> GRAD[0]="-0.000000000000"/6 -#> GRAD[1]="-0.009563213793"/6 -#> GRAD[2]="0.006760367811"/6 -#> GRAD[3]="-0.006760367811"/6 -#> GRAD[4]="-0.009563213793"/6 +#> GRAD[0]="0.000000000000"/6 +#> GRAD[1]="-0.009563213821"/6 +#> GRAD[2]="0.006760367828"/6 +#> GRAD[3]="-0.006760367828"/6 +#> GRAD[4]="-0.009563213821"/6 #>> 4 #>> 6 -#> POTNUC="13.366871185804"/6 +#> POTNUC="13.366871185381"/6 #> SEWARD_MLTPL1X="0.077508834155"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.919078539309"/5 +#> SEWARD_ATTRACT="-35.919078539248"/5 #>> 7 #> SCF_ITER="7"/8 -#> E_SCF="-40.516302264369"/8 -#> DFT_ENERGY="-5.583328780000"/6 -#> NQ_DENSITY="10.000007958023"/8 +#> E_SCF="-40.516302264359"/8 +#> DFT_ENERGY="-5.583328779954"/6 +#> NQ_DENSITY="10.000007957989"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="0.000000000000"/5 +#> MLTPL__1[1]="-0.000000000000"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.000025460994"/5 +#> MLTPL__2[0]="0.000025461030"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.000050921989"/5 +#> MLTPL__2[3]="-0.000050922059"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.000025460995"/5 +#> MLTPL__2[5]="0.000025461030"/5 #>> 8 #> GRAD[0]="-0.000000000000"/6 -#> GRAD[1]="-0.002359796911"/6 -#> GRAD[2]="0.001668819407"/6 -#> GRAD[3]="-0.001668819407"/6 -#> GRAD[4]="-0.002359796911"/6 +#> GRAD[1]="-0.002359796918"/6 +#> GRAD[2]="0.001668819413"/6 +#> GRAD[3]="-0.001668819413"/6 +#> GRAD[4]="-0.002359796918"/6 #>> 9 #>> 11 -#> POTNUC="13.314287005720"/6 +#> POTNUC="13.314287003302"/6 #> SEWARD_MLTPL1X="0.077508834155"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.911478103649"/5 +#> SEWARD_ATTRACT="-35.911478103300"/5 #>> 12 -#> SCF_ITER="5"/8 -#> E_SCF="-40.516349297951"/8 -#> DFT_ENERGY="-5.578461739096"/6 -#> NQ_DENSITY="10.000007936163"/8 +#> SCF_ITER="6"/8 +#> E_SCF="-40.516349298743"/8 +#> DFT_ENERGY="-5.578476756908"/6 +#> NQ_DENSITY="10.000007935932"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="-0.000000000000"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.000021158446"/5 +#> MLTPL__2[0]="0.000021158239"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.000042316892"/5 +#> MLTPL__2[3]="-0.000042316478"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.000021158446"/5 +#> MLTPL__2[5]="0.000021158239"/5 #>> 13 #> GRAD[0]="0.0"/6 -#> GRAD[1]="-0.000005028462"/6 -#> GRAD[2]="0.000003548891"/6 -#> GRAD[3]="-0.000003548891"/6 -#> GRAD[4]="-0.000005028462"/6 +#> GRAD[1]="0.000001952849"/6 +#> GRAD[2]="-0.000001387606"/6 +#> GRAD[3]="0.000001387606"/6 +#> GRAD[4]="0.000001952849"/6 #>> 14 #> GEO_ITER="3"/8 -#> POTNUC="13.314172808187"/6 +#> POTNUC="13.314330916909"/6 #> SEWARD_MLTPL1X="0.077508834155"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.911461597715"/5 +#> SEWARD_ATTRACT="-35.911484450505"/5 #> SCF_ITER="2"/8 -#> E_SCF="-40.516349298347"/8 -#> DFT_ENERGY="-5.578464349533"/6 -#> NQ_DENSITY="10.000007935918"/8 +#> E_SCF="-40.516349298774"/8 +#> DFT_ENERGY="-5.578481723093"/6 +#> NQ_DENSITY="10.000007935939"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.000000000000"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.000021278840"/5 +#> MLTPL__2[0]="0.000021280807"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.000042557680"/5 +#> MLTPL__2[3]="-0.000042561614"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.000021278840"/5 +#> MLTPL__2[5]="0.000021280807"/5 #>> 15 >>EOF diff -Nru openmolcas-22.02/test/standard/038.input openmolcas-22.10/test/standard/038.input --- openmolcas-22.02/test/standard/038.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/standard/038.input 2022-10-10 14:22:40.000000000 +0000 @@ -57,9 +57,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.02-1119-gde6a49c4e -* Linux otis 4.15.0-1073-oem #83-Ubuntu SMP Mon Feb 17 11:21:18 UTC 2020 x86_64 x86_64 x86_64 GNU/Linux -* Thu May 13 18:25:54 2021 +* Molcas version 22.02-264-gd603c8837 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Thu Apr 28 14:14:23 2022 * #>> 1 #> POTNUC="9.300717793898"/12 @@ -79,7 +79,7 @@ #> MLTPL__2[3]="1.712398980030"/5 #> MLTPL__2[4]="0.0"/5 #> MLTPL__2[5]="-0.126857038696"/5 -#> EF0___EL="35.061382700450"/5 +#> EF0___EL="35.061382700451"/5 #> EF0__NUC="10.772492217986"/5 #> EF1___EL[0]="0.0"/5 #> EF1___EL[1]="0.0"/5 @@ -87,19 +87,19 @@ #> EF1__NUC[0]="0.0"/5 #> EF1__NUC[1]="0.0"/5 #> EF1__NUC[2]="-2.676909458723"/5 -#> EF2___EL[0]="-0.620935595949"/5 -#> EF2___EL[1]="0.0"/5 -#> EF2___EL[2]="0.0"/5 -#> EF2___EL[3]="0.590648208182"/5 -#> EF2___EL[4]="0.0"/5 -#> EF2___EL[5]="-3669.294067179726"/5 -#> EF2__NUC[0]="3.235971598629"/5 -#> EF2__NUC[1]="0.0"/5 -#> EF2__NUC[2]="0.0"/5 -#> EF2__NUC[3]="-2.941494238891"/5 -#> EF2__NUC[4]="0.0"/5 -#> EF2__NUC[5]="-0.294477359738"/5 -#> CNT___EL="291.993144224709"/5 +#> EF2___EL[0]="-0.620935595949"/4 +#> EF2___EL[1]="0.0"/4 +#> EF2___EL[2]="0.0"/4 +#> EF2___EL[3]="0.590648208182"/4 +#> EF2___EL[4]="0.0"/4 +#> EF2___EL[5]="-3669.294067179756"/4 +#> EF2__NUC[0]="3.235971598629"/4 +#> EF2__NUC[1]="0.0"/4 +#> EF2__NUC[2]="0.0"/4 +#> EF2__NUC[3]="-2.941494238891"/4 +#> EF2__NUC[4]="0.0"/4 +#> EF2__NUC[5]="-0.294477359738"/4 +#> CNT___EL="291.993144224712"/5 #> CNT__NUC="0.0"/5 #>> 3 #> POTNUC="9.300717793898"/12 @@ -123,22 +123,22 @@ #> EF0__NUC="5.945456349694"/5 #> EF1___EL[0]="0.0"/5 #> EF1___EL[1]="-1.989289432275"/5 -#> EF1___EL[2]="1.362764483117"/5 +#> EF1___EL[2]="1.362764483118"/5 #> EF1__NUC[0]="0.0"/5 #> EF1__NUC[1]="2.104449676217"/5 #> EF1__NUC[2]="-1.147246910881"/5 -#> EF2___EL[0]="0.497307295001"/5 -#> EF2___EL[1]="0.0"/5 -#> EF2___EL[2]="0.0"/5 -#> EF2___EL[3]="-0.422018747948"/5 -#> EF2___EL[4]="-1.636670442265"/5 -#> EF2___EL[5]="-3663.956609524231"/5 -#> EF2__NUC[0]="1.792859841122"/5 -#> EF2__NUC[1]="0.0"/5 -#> EF2__NUC[2]="0.0"/5 -#> EF2__NUC[3]="-1.624359149818"/5 -#> EF2__NUC[4]="2.030613097450"/5 -#> EF2__NUC[5]="-0.168500691304"/5 +#> EF2___EL[0]="0.497307295001"/4 +#> EF2___EL[1]="0.0"/4 +#> EF2___EL[2]="0.0"/4 +#> EF2___EL[3]="-0.422018747948"/4 +#> EF2___EL[4]="-1.636670442265"/4 +#> EF2___EL[5]="-3663.956609524223"/4 +#> EF2__NUC[0]="1.792859841122"/4 +#> EF2__NUC[1]="0.0"/4 +#> EF2__NUC[2]="0.0"/4 +#> EF2__NUC[3]="-1.624359149818"/4 +#> EF2__NUC[4]="2.030613097450"/4 +#> EF2__NUC[5]="-0.168500691304"/4 #> CNT___EL="291.568402840001"/5 #> CNT__NUC="0.0"/5 >>EOF diff -Nru openmolcas-22.02/test/standard/044.input openmolcas-22.10/test/standard/044.input --- openmolcas-22.02/test/standard/044.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/standard/044.input 2022-10-10 14:22:40.000000000 +0000 @@ -47,9 +47,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-943-g4c2682958 -* Linux lucifer 5.13.0-27-generic #29~20.04.1-Ubuntu SMP Fri Jan 14 00:32:30 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux -* Sun Feb 6 10:34:38 2022 +* Molcas version 22.02-260-gd39e60428 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Wed Apr 27 18:28:24 2022 * #>> 1 #> POTNUC="8.906622248211"/6 @@ -58,95 +58,95 @@ #> SEWARD_ATTRACT="-6.843027465630"/5 #>> 2 #> SCF_ITER="13"/8 -#> E_SCF="-76.337211212291"/4 -#> DFT_ENERGY="-9.309242431669"/6 -#> NQ_DENSITY="9.999998484525"/8 +#> E_SCF="-76.337211212190"/4 +#> DFT_ENERGY="-9.309242431518"/6 +#> NQ_DENSITY="9.999998484440"/8 #> MLTPL__0="-0.000000000000"/2 #> MLTPL__1[0]="0.0"/2 -#> MLTPL__1[1]="0.776026766383"/2 +#> MLTPL__1[1]="0.776026766373"/2 #> MLTPL__1[2]="0.0"/2 -#> MLTPL__2[0]="1.357479583453"/2 +#> MLTPL__2[0]="1.357479583481"/2 #> MLTPL__2[1]="0.0"/2 #> MLTPL__2[2]="0.0"/2 -#> MLTPL__2[3]="0.078473549521"/2 +#> MLTPL__2[3]="0.078473549516"/2 #> MLTPL__2[4]="0.0"/2 -#> MLTPL__2[5]="-1.435953132974"/2 +#> MLTPL__2[5]="-1.435953132997"/2 #>> 3 -#> GRAD[0]="0.005332003632"/6 -#> GRAD[1]="0.007626719669"/6 -#> GRAD[2]="-0.015253439338"/6 +#> GRAD[0]="0.005332003474"/6 +#> GRAD[1]="0.007626719524"/6 +#> GRAD[2]="-0.015253439048"/6 #>> 4 #>> 5 #>> 7 -#> POTNUC="8.970231916052"/6 -#> SEWARD_MLTPL1X="1.434666974506"/5 -#> SEWARD_KINETIC="0.938615033083"/5 -#> SEWARD_ATTRACT="-6.875362611847"/5 +#> POTNUC="8.970231914467"/6 +#> SEWARD_MLTPL1X="1.434666974710"/5 +#> SEWARD_KINETIC="0.938615033071"/5 +#> SEWARD_ATTRACT="-6.875362610477"/5 #>> 8 #> SCF_ITER="8"/8 -#> E_SCF="-76.337452689539"/4 -#> DFT_ENERGY="-9.315667860056"/6 -#> NQ_DENSITY="9.999998707271"/8 +#> E_SCF="-76.337452689437"/4 +#> DFT_ENERGY="-9.315667859790"/6 +#> NQ_DENSITY="9.999998707188"/8 #> MLTPL__0="-0.000000000000"/2 #> MLTPL__1[0]="0.0"/2 -#> MLTPL__1[1]="0.769744869064"/2 +#> MLTPL__1[1]="0.769744869105"/2 #> MLTPL__1[2]="0.0"/2 -#> MLTPL__2[0]="1.396985159532"/2 +#> MLTPL__2[0]="1.396985159667"/2 #> MLTPL__2[1]="0.0"/2 #> MLTPL__2[2]="0.0"/2 -#> MLTPL__2[3]="0.032100141349"/2 +#> MLTPL__2[3]="0.032100141563"/2 #> MLTPL__2[4]="0.0"/2 -#> MLTPL__2[5]="-1.429085300882"/2 +#> MLTPL__2[5]="-1.429085301230"/2 #>> 9 -#> GRAD[0]="0.001985711160"/6 -#> GRAD[1]="0.002881622911"/6 -#> GRAD[2]="-0.005763245821"/6 +#> GRAD[0]="0.001985711133"/6 +#> GRAD[1]="0.002881622895"/6 +#> GRAD[2]="-0.005763245791"/6 #>> 10 #>> 11 #>> 13 -#> POTNUC="9.008371550964"/6 -#> SEWARD_MLTPL1X="1.436158309093"/5 -#> SEWARD_KINETIC="0.938529378274"/5 -#> SEWARD_ATTRACT="-6.894453122900"/5 +#> POTNUC="9.008371540408"/6 +#> SEWARD_MLTPL1X="1.436158307217"/5 +#> SEWARD_KINETIC="0.938529378381"/5 +#> SEWARD_ATTRACT="-6.894453120790"/5 #>> 14 #> SCF_ITER="8"/8 -#> E_SCF="-76.337492682992"/4 -#> DFT_ENERGY="-9.319519612607"/6 -#> NQ_DENSITY="9.999998929902"/8 +#> E_SCF="-76.337492682893"/4 +#> DFT_ENERGY="-9.319519611394"/6 +#> NQ_DENSITY="9.999998929820"/8 #> MLTPL__0="-0.000000000000"/2 #> MLTPL__1[0]="0.0"/2 -#> MLTPL__1[1]="0.765798884564"/2 +#> MLTPL__1[1]="0.765798886386"/2 #> MLTPL__1[2]="0.0"/2 -#> MLTPL__2[0]="1.421027026172"/2 +#> MLTPL__2[0]="1.421027013523"/2 #> MLTPL__2[1]="0.0"/2 #> MLTPL__2[2]="0.0"/2 -#> MLTPL__2[3]="0.004078205347"/2 +#> MLTPL__2[3]="0.004078218329"/2 #> MLTPL__2[4]="0.0"/2 -#> MLTPL__2[5]="-1.425105231519"/2 +#> MLTPL__2[5]="-1.425105231852"/2 #>> 15 -#> GRAD[0]="-0.000127958893"/6 -#> GRAD[1]="-0.000012214507"/6 -#> GRAD[2]="0.000024429013"/6 +#> GRAD[0]="-0.000127958617"/6 +#> GRAD[1]="-0.000012213669"/6 +#> GRAD[2]="0.000024427339"/6 #>> 16 #> GEO_ITER="3"/8 -#> POTNUC="9.007568289498"/6 -#> SEWARD_MLTPL1X="1.436628967932"/5 -#> SEWARD_KINETIC="0.938502593729"/5 -#> SEWARD_ATTRACT="-6.892965068840"/5 -#> SCF_ITER="3"/8 -#> E_SCF="-76.337492747843"/4 -#> DFT_ENERGY="-9.319471041287"/6 -#> NQ_DENSITY="9.999998937142"/8 +#> POTNUC="9.007568288109"/6 +#> SEWARD_MLTPL1X="1.436628967816"/5 +#> SEWARD_KINETIC="0.938502593735"/5 +#> SEWARD_ATTRACT="-6.892965068278"/5 +#> SCF_ITER="4"/8 +#> E_SCF="-76.337492748184"/4 +#> DFT_ENERGY="-9.319451437426"/6 +#> NQ_DENSITY="9.999998937057"/8 #> MLTPL__0="-0.000000000000"/2 #> MLTPL__1[0]="0.0"/2 -#> MLTPL__1[1]="0.765638457541"/2 +#> MLTPL__1[1]="0.765639979426"/2 #> MLTPL__1[2]="0.0"/2 -#> MLTPL__2[0]="1.422595651192"/2 +#> MLTPL__2[0]="1.422595384838"/2 #> MLTPL__2[1]="0.0"/2 #> MLTPL__2[2]="0.0"/2 -#> MLTPL__2[3]="0.002866594283"/2 +#> MLTPL__2[3]="0.002866576826"/2 #> MLTPL__2[4]="0.0"/2 -#> MLTPL__2[5]="-1.425462245475"/2 +#> MLTPL__2[5]="-1.425461961664"/2 #>> 17 #>> 18 >>EOF diff -Nru openmolcas-22.02/test/standard/053.input openmolcas-22.10/test/standard/053.input --- openmolcas-22.02/test/standard/053.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/standard/053.input 2022-10-10 14:22:40.000000000 +0000 @@ -69,9 +69,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-1067-g09eff8f6d -* Linux lucifer 5.13.0-28-generic #31~20.04.1-Ubuntu SMP Wed Jan 19 14:08:10 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux -* Thu Feb 10 22:17:19 2022 +* Molcas version 22.02-260-gd39e60428 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Wed Apr 27 18:28:24 2022 * #>> 1 #> POTNUC="9.497078520819"/12 @@ -101,58 +101,58 @@ #> SEWARD_KINETIC="16.052757759106"/5 #> SEWARD_ATTRACT="-35.430954027347"/5 #>> 5 -#> SCF_ITER="2"/8 -#> E_SCF="-39.805186076083"/6 -#> DFT_ENERGY="-6.443874149027"/6 -#> NQ_DENSITY="8.999998026994"/8 +#> SCF_ITER="3"/8 +#> E_SCF="-39.805186076134"/6 +#> DFT_ENERGY="-6.443879030979"/6 +#> NQ_DENSITY="8.999998027027"/8 #> MLTPL__0="-0.000000000000"/3 -#> MLTPL__1[0]="-0.000000865606"/3 -#> MLTPL__1[1]="-0.000000705153"/3 -#> MLTPL__1[2]="0.000011402861"/3 -#> MLTPL__2[0]="0.570978976543"/3 -#> MLTPL__2[1]="-0.000010563844"/3 -#> MLTPL__2[2]="0.001665567244"/3 -#> MLTPL__2[3]="0.570886177748"/3 -#> MLTPL__2[4]="-0.000747999049"/3 -#> MLTPL__2[5]="-1.141865154291"/3 +#> MLTPL__1[0]="-0.000000865650"/3 +#> MLTPL__1[1]="-0.000000705337"/3 +#> MLTPL__1[2]="0.000011402693"/3 +#> MLTPL__2[0]="0.570978604289"/3 +#> MLTPL__2[1]="-0.000010563714"/3 +#> MLTPL__2[2]="0.001665566158"/3 +#> MLTPL__2[3]="0.570885805513"/3 +#> MLTPL__2[4]="-0.000747998561"/3 +#> MLTPL__2[5]="-1.141864409802"/3 #>> 6 #> POTNUC="9.497078520819"/12 #> SEWARD_MLTPL1X="-0.003845890500"/5 #> SEWARD_KINETIC="16.052757759106"/5 #> SEWARD_ATTRACT="-35.430954027347"/5 #>> 7 -#> SCF_ITER="3"/8 -#> E_SCF="-39.805171431796"/6 -#> DFT_ENERGY="-6.443870739648"/6 -#> NQ_DENSITY="8.999998029429"/8 +#> SCF_ITER="6"/8 +#> E_SCF="-39.805171433026"/6 +#> DFT_ENERGY="-6.443894160812"/6 +#> NQ_DENSITY="8.999998029587"/8 #> MLTPL__0="-0.000000000000"/3 -#> MLTPL__1[0]="-0.000000841506"/3 -#> MLTPL__1[1]="-0.000000700391"/3 -#> MLTPL__1[2]="0.000011410309"/3 -#> MLTPL__2[0]="0.571282699660"/3 -#> MLTPL__2[1]="-0.000010579269"/3 -#> MLTPL__2[2]="0.001666452349"/3 -#> MLTPL__2[3]="0.571188875240"/3 -#> MLTPL__2[4]="-0.000748396069"/3 -#> MLTPL__2[5]="-1.142471574901"/3 +#> MLTPL__1[0]="-0.000000852274"/3 +#> MLTPL__1[1]="-0.000000700308"/3 +#> MLTPL__1[2]="0.000011410694"/3 +#> MLTPL__2[0]="0.571285032272"/3 +#> MLTPL__2[1]="-0.000010579382"/3 +#> MLTPL__2[2]="0.001666459152"/3 +#> MLTPL__2[3]="0.571191198282"/3 +#> MLTPL__2[4]="-0.000748399117"/3 +#> MLTPL__2[5]="-1.142476230554"/3 #>> 8 #> POTNUC="9.497078520819"/12 #> SEWARD_MLTPL1X="-0.003845890500"/5 #> SEWARD_KINETIC="16.052757759106"/5 #> SEWARD_ATTRACT="-35.430954027347"/5 #>> 9 -#> SCF_ITER="2"/8 -#> E_SCF="-39.805171431853"/6 -#> DFT_ENERGY="-6.443895470146"/6 -#> NQ_DENSITY="8.999998029595"/8 +#> SCF_ITER="5"/8 +#> E_SCF="-39.805171431856"/6 +#> DFT_ENERGY="-6.443894162022"/6 +#> NQ_DENSITY="8.999998029587"/8 #> MLTPL__0="-0.000000000000"/3 -#> MLTPL__1[0]="-0.000000854355"/3 -#> MLTPL__1[1]="-0.000000700274"/3 -#> MLTPL__1[2]="0.000011410820"/3 -#> MLTPL__2[0]="0.571285189957"/3 -#> MLTPL__2[1]="-0.000010579399"/3 -#> MLTPL__2[2]="0.001666459603"/3 -#> MLTPL__2[3]="0.571191345491"/3 -#> MLTPL__2[4]="-0.000748399316"/3 -#> MLTPL__2[5]="-1.142476535448"/3 +#> MLTPL__1[0]="-0.000000851698"/3 +#> MLTPL__1[1]="-0.000000700298"/3 +#> MLTPL__1[2]="0.000011410725"/3 +#> MLTPL__2[0]="0.571285038957"/3 +#> MLTPL__2[1]="-0.000010579387"/3 +#> MLTPL__2[2]="0.001666459163"/3 +#> MLTPL__2[3]="0.571191195267"/3 +#> MLTPL__2[4]="-0.000748399119"/3 +#> MLTPL__2[5]="-1.142476234224"/3 >>EOF diff -Nru openmolcas-22.02/test/standard/055.input openmolcas-22.10/test/standard/055.input --- openmolcas-22.02/test/standard/055.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/standard/055.input 2022-10-10 14:22:40.000000000 +0000 @@ -39,9 +39,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.02-1119-gde6a49c4e -* Linux otis 4.15.0-1073-oem #83-Ubuntu SMP Mon Feb 17 11:21:18 UTC 2020 x86_64 x86_64 x86_64 GNU/Linux -* Thu May 13 18:15:47 2021 +* Molcas version 22.02-113-g3e6c18d4f +* Linux lucifer 5.13.0-35-generic #40~20.04.1-Ubuntu SMP Mon Mar 7 09:18:32 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Fri Mar 18 17:07:39 2022 * #>> 1 #> POTNUC="9.575509691095"/12 @@ -52,114 +52,114 @@ #> SEWARD_ATTRACT="-35.442878432133"/5 #>> 3 #> SCF_ITER="15"/8 -#> E_SCF="-39.563649281822"/4 +#> E_SCF="-39.563649281825"/4 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="-0.000001420895"/2 -#> MLTPL__1[1]="0.000001094213"/2 -#> MLTPL__1[2]="0.000009850474"/2 -#> MLTPL__2[0]="0.609986734752"/2 -#> MLTPL__2[1]="0.000020272993"/2 -#> MLTPL__2[2]="0.001779500058"/2 -#> MLTPL__2[3]="0.609882656111"/2 -#> MLTPL__2[4]="-0.000798703195"/2 -#> MLTPL__2[5]="-1.219869390863"/2 +#> MLTPL__1[0]="-0.000001049380"/2 +#> MLTPL__1[1]="0.000000789087"/2 +#> MLTPL__1[2]="0.000009830354"/2 +#> MLTPL__2[0]="0.609987169641"/2 +#> MLTPL__2[1]="0.000020536091"/2 +#> MLTPL__2[2]="0.001779507996"/2 +#> MLTPL__2[3]="0.609882063902"/2 +#> MLTPL__2[4]="-0.000798708078"/2 +#> MLTPL__2[5]="-1.219869233544"/2 #>> 4 -#> GRAD[0]="0.000006959450"/6 -#> GRAD[1]="-0.000000623572"/6 -#> GRAD[2]="-0.000000493743"/6 -#> GRAD[3]="0.006826927719"/6 -#> GRAD[4]="0.000000910659"/6 -#> GRAD[5]="0.000006825774"/6 -#> GRAD[6]="-0.003417857892"/6 -#> GRAD[7]="-0.005913358897"/6 -#> GRAD[8]="-0.000000581897"/6 -#> GRAD[9]="-0.003416029276"/6 -#> GRAD[10]="0.005913071811"/6 -#> GRAD[11]="-0.000005750134"/6 +#> GRAD[0]="0.000005777058"/6 +#> GRAD[1]="0.000000391612"/6 +#> GRAD[2]="-0.000000428187"/6 +#> GRAD[3]="0.006827159485"/6 +#> GRAD[4]="0.000000836975"/6 +#> GRAD[5]="0.000006780499"/6 +#> GRAD[6]="-0.003417357862"/6 +#> GRAD[7]="-0.005913931889"/6 +#> GRAD[8]="-0.000000596874"/6 +#> GRAD[9]="-0.003415578682"/6 +#> GRAD[10]="0.005912703302"/6 +#> GRAD[11]="-0.000005755438"/6 #>> 5 #>> 6 #>> 8 -#> POTNUC="9.642030376230"/6 -#> SEWARD_MLTPL1X="-0.003857595305"/5 +#> POTNUC="9.642030159028"/6 +#> SEWARD_MLTPL1X="-0.003854924732"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.452992006222"/5 +#> SEWARD_ATTRACT="-35.452991973198"/5 #>> 9 #> SCF_ITER="8"/8 -#> E_SCF="-39.563823558047"/4 +#> E_SCF="-39.563823557879"/4 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="0.000000389168"/2 -#> MLTPL__1[1]="-0.000000091026"/2 -#> MLTPL__1[2]="0.000002254671"/2 -#> MLTPL__2[0]="0.602134034776"/2 -#> MLTPL__2[1]="-0.000003163418"/2 -#> MLTPL__2[2]="0.001756727765"/2 -#> MLTPL__2[3]="0.602148764621"/2 -#> MLTPL__2[4]="-0.000788550685"/2 -#> MLTPL__2[5]="-1.204282799397"/2 +#> MLTPL__1[0]="0.000000013222"/2 +#> MLTPL__1[1]="0.000000035138"/2 +#> MLTPL__1[2]="0.000004213717"/2 +#> MLTPL__2[0]="0.602145119651"/2 +#> MLTPL__2[1]="0.000001299615"/2 +#> MLTPL__2[2]="0.001756733005"/2 +#> MLTPL__2[3]="0.602137623011"/2 +#> MLTPL__2[4]="-0.000788542377"/2 +#> MLTPL__2[5]="-1.204282742662"/2 #>> 10 -#> GRAD[0]="0.000000533530"/6 -#> GRAD[1]="0.000001439808"/6 -#> GRAD[2]="-0.000000078577"/6 -#> GRAD[3]="0.001303915206"/6 -#> GRAD[4]="-0.000000364530"/6 -#> GRAD[5]="0.000001301001"/6 -#> GRAD[6]="-0.000652336254"/6 -#> GRAD[7]="-0.001130637845"/6 -#> GRAD[8]="-0.000000118935"/6 -#> GRAD[9]="-0.000652112481"/6 -#> GRAD[10]="0.001129562566"/6 -#> GRAD[11]="-0.000001103489"/6 +#> GRAD[0]="0.000001312258"/6 +#> GRAD[1]="0.000000042685"/6 +#> GRAD[2]="-0.000000120669"/6 +#> GRAD[3]="0.001303870845"/6 +#> GRAD[4]="0.000000030489"/6 +#> GRAD[5]="0.000001304431"/6 +#> GRAD[6]="-0.000652639087"/6 +#> GRAD[7]="-0.001130001593"/6 +#> GRAD[8]="-0.000000099860"/6 +#> GRAD[9]="-0.000652544017"/6 +#> GRAD[10]="0.001129928418"/6 +#> GRAD[11]="-0.000001083903"/6 #>> 11 #>> 12 #>> 14 -#> POTNUC="9.657468897180"/6 -#> SEWARD_MLTPL1X="-0.003856743944"/5 +#> POTNUC="9.657468995231"/6 +#> SEWARD_MLTPL1X="-0.003856556614"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.455339225132"/5 +#> SEWARD_ATTRACT="-35.455339240041"/5 #>> 15 #> SCF_ITER="6"/8 -#> E_SCF="-39.563829968843"/4 +#> E_SCF="-39.563829968755"/4 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="-0.000000031078"/2 -#> MLTPL__1[1]="0.000000126891"/2 -#> MLTPL__1[2]="0.000008333227"/2 -#> MLTPL__2[0]="0.600357046528"/2 -#> MLTPL__2[1]="0.000005489312"/2 -#> MLTPL__2[2]="0.001751518579"/2 -#> MLTPL__2[3]="0.600357428286"/2 -#> MLTPL__2[4]="-0.000786203389"/2 -#> MLTPL__2[5]="-1.200714474814"/2 +#> MLTPL__1[0]="-0.000000024892"/2 +#> MLTPL__1[1]="-0.000000003465"/2 +#> MLTPL__1[2]="0.000006761784"/2 +#> MLTPL__2[0]="0.600357153677"/2 +#> MLTPL__2[1]="0.000000503391"/2 +#> MLTPL__2[2]="0.001751524465"/2 +#> MLTPL__2[3]="0.600357298881"/2 +#> MLTPL__2[4]="-0.000786208362"/2 +#> MLTPL__2[5]="-1.200714452558"/2 #>> 16 -#> GRAD[0]="-0.000000132274"/6 -#> GRAD[1]="-0.000000973569"/6 -#> GRAD[2]="-0.000000147884"/6 -#> GRAD[3]="0.000000239674"/6 -#> GRAD[4]="0.000000404445"/6 -#> GRAD[5]="0.000000046439"/6 -#> GRAD[6]="-0.000000121560"/6 -#> GRAD[7]="0.000000230867"/6 -#> GRAD[8]="0.000000049576"/6 -#> GRAD[9]="0.000000014160"/6 -#> GRAD[10]="0.000000338256"/6 -#> GRAD[11]="0.000000051869"/6 +#> GRAD[0]="0.000000095923"/6 +#> GRAD[1]="0.000000013109"/6 +#> GRAD[2]="-0.000000147229"/6 +#> GRAD[3]="0.000000085463"/6 +#> GRAD[4]="-0.000000011784"/6 +#> GRAD[5]="0.000000045193"/6 +#> GRAD[6]="-0.000000084283"/6 +#> GRAD[7]="-0.000000109324"/6 +#> GRAD[8]="0.000000049876"/6 +#> GRAD[9]="-0.000000097103"/6 +#> GRAD[10]="0.000000107998"/6 +#> GRAD[11]="0.000000052160"/6 #>> 17 #> GEO_ITER="3"/8 -#> POTNUC="9.657470418875"/6 -#> SEWARD_MLTPL1X="-0.003856765729"/5 +#> POTNUC="9.657470428857"/6 +#> SEWARD_MLTPL1X="-0.003856712728"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.455339456490"/5 +#> SEWARD_ATTRACT="-35.455339458008"/5 #> SCF_ITER="2"/8 -#> E_SCF="-39.563829968835"/4 +#> E_SCF="-39.563829968843"/4 #> MLTPL__0="-0.000000000000"/2 -#> MLTPL__1[0]="-0.000000012976"/2 -#> MLTPL__1[1]="-0.000000189802"/2 -#> MLTPL__1[2]="0.000003288341"/2 -#> MLTPL__2[0]="0.600353964401"/2 -#> MLTPL__2[1]="-0.000002034126"/2 -#> MLTPL__2[2]="0.001751517234"/2 -#> MLTPL__2[3]="0.600355481578"/2 -#> MLTPL__2[4]="-0.000786207989"/2 -#> MLTPL__2[5]="-1.200709445979"/2 +#> MLTPL__1[0]="0.000000006797"/2 +#> MLTPL__1[1]="0.000000002126"/2 +#> MLTPL__1[2]="0.000001766187"/2 +#> MLTPL__2[0]="0.600354168866"/2 +#> MLTPL__2[1]="0.000000733833"/2 +#> MLTPL__2[2]="0.001751516336"/2 +#> MLTPL__2[3]="0.600355279862"/2 +#> MLTPL__2[4]="-0.000786205072"/2 +#> MLTPL__2[5]="-1.200709448728"/2 #>> 18 #>> 19 >>EOF diff -Nru openmolcas-22.02/test/standard/083.input openmolcas-22.10/test/standard/083.input --- openmolcas-22.02/test/standard/083.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/standard/083.input 2022-10-10 14:22:40.000000000 +0000 @@ -39,9 +39,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-943-g4c2682958 -* Linux lucifer 5.13.0-27-generic #29~20.04.1-Ubuntu SMP Fri Jan 14 00:32:30 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux -* Sat Feb 5 17:07:33 2022 +* Molcas version 22.02-260-gd39e60428 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Wed Apr 27 18:28:24 2022 * #>> 1 #> POTNUC="13.522136977422"/6 @@ -50,98 +50,98 @@ #> SEWARD_ATTRACT="-35.941520411926"/5 #>> 2 #> SCF_ITER="8"/8 -#> E_SCF="-40.515612956798"/8 -#> DFT_ENERGY="-5.597618868963"/6 -#> NQ_DENSITY="10.000007868873"/8 +#> E_SCF="-40.515612956788"/8 +#> DFT_ENERGY="-5.597618868956"/6 +#> NQ_DENSITY="10.000007868841"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="0.0"/5 +#> MLTPL__1[1]="0.000000000000"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.000004364287"/5 +#> MLTPL__2[0]="-0.000004364286"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="0.000008728574"/5 +#> MLTPL__2[3]="0.000008728571"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.000004364287"/5 +#> MLTPL__2[5]="-0.000004364286"/5 #>> 3 -#> GRAD[0]="-0.000000000000"/6 -#> GRAD[1]="-0.009563213793"/6 -#> GRAD[2]="0.006760367811"/6 -#> GRAD[3]="-0.006760367811"/6 -#> GRAD[4]="-0.009563213793"/6 +#> GRAD[0]="0.000000000000"/6 +#> GRAD[1]="-0.009563213821"/6 +#> GRAD[2]="0.006760367828"/6 +#> GRAD[3]="-0.006760367828"/6 +#> GRAD[4]="-0.009563213821"/6 #>> 4 #>> 6 -#> POTNUC="13.366523454001"/6 +#> POTNUC="13.366523453575"/6 #> SEWARD_MLTPL1X="0.077508834155"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.919028278696"/5 +#> SEWARD_ATTRACT="-35.919028278635"/5 #>> 7 #> SCF_ITER="7"/8 -#> E_SCF="-40.516302884977"/8 -#> DFT_ENERGY="-5.583296715272"/6 -#> NQ_DENSITY="10.000007957947"/8 +#> E_SCF="-40.516302884968"/8 +#> DFT_ENERGY="-5.583296715226"/6 +#> NQ_DENSITY="10.000007957914"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="-0.000000000000"/5 +#> MLTPL__1[1]="0.000000000000"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.000025729722"/5 +#> MLTPL__2[0]="0.000025729757"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.000051459444"/5 +#> MLTPL__2[3]="-0.000051459515"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.000025729722"/5 +#> MLTPL__2[5]="0.000025729758"/5 #>> 8 -#> GRAD[0]="-0.000000000000"/6 -#> GRAD[1]="-0.002344041683"/6 -#> GRAD[2]="0.001657696155"/6 -#> GRAD[3]="-0.001657696155"/6 -#> GRAD[4]="-0.002344041683"/6 +#> GRAD[0]="0.0"/6 +#> GRAD[1]="-0.002344041689"/6 +#> GRAD[2]="0.001657696161"/6 +#> GRAD[3]="-0.001657696161"/6 +#> GRAD[4]="-0.002344041689"/6 #>> 9 #>> 11 -#> POTNUC="13.314287353786"/6 +#> POTNUC="13.314287351278"/6 #> SEWARD_MLTPL1X="0.077508834155"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.911478153958"/5 +#> SEWARD_ATTRACT="-35.911478153596"/5 #>> 12 -#> SCF_ITER="5"/8 -#> E_SCF="-40.516349297963"/8 -#> DFT_ENERGY="-5.578461872561"/6 -#> NQ_DENSITY="10.000007936161"/8 -#> MLTPL__0="0.0"/5 +#> SCF_ITER="6"/8 +#> E_SCF="-40.516349298744"/8 +#> DFT_ENERGY="-5.578476790007"/6 +#> NQ_DENSITY="10.000007935931"/8 +#> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="-0.000000000000"/5 +#> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.000021122584"/5 +#> MLTPL__2[0]="0.000021122365"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.000042245168"/5 +#> MLTPL__2[3]="-0.000042244730"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.000021122584"/5 +#> MLTPL__2[5]="0.000021122365"/5 #>> 13 -#> GRAD[0]="-0.000000000000"/6 -#> GRAD[1]="-0.000004998371"/6 -#> GRAD[2]="0.000003525349"/6 -#> GRAD[3]="-0.000003525349"/6 -#> GRAD[4]="-0.000004998371"/6 +#> GRAD[0]="0.000000000000"/6 +#> GRAD[1]="0.000001936289"/6 +#> GRAD[2]="-0.000001378165"/6 +#> GRAD[3]="0.000001378165"/6 +#> GRAD[4]="0.000001936289"/6 #>> 14 #> GEO_ITER="3"/8 -#> POTNUC="13.314173864541"/6 +#> POTNUC="13.314330917082"/6 #> SEWARD_MLTPL1X="0.077508834155"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.911461750399"/5 +#> SEWARD_ATTRACT="-35.911484450530"/5 #> SCF_ITER="2"/8 -#> E_SCF="-40.516349298353"/8 -#> DFT_ENERGY="-5.578464459533"/6 -#> NQ_DENSITY="10.000007935919"/8 +#> E_SCF="-40.516349298774"/8 +#> DFT_ENERGY="-5.578481717035"/6 +#> NQ_DENSITY="10.000007935939"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="-0.000000000000"/5 +#> MLTPL__1[1]="0.000000000000"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.000021284071"/5 +#> MLTPL__2[0]="0.000021285980"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.000042568143"/5 +#> MLTPL__2[3]="-0.000042571959"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.000021284072"/5 +#> MLTPL__2[5]="0.000021285980"/5 #>> 15 >>EOF diff -Nru openmolcas-22.02/test/standard/084.input openmolcas-22.10/test/standard/084.input --- openmolcas-22.02/test/standard/084.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/standard/084.input 2022-10-10 14:22:40.000000000 +0000 @@ -39,9 +39,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-943-g4c2682958 -* Linux lucifer 5.13.0-27-generic #29~20.04.1-Ubuntu SMP Fri Jan 14 00:32:30 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux -* Sat Feb 5 17:07:33 2022 +* Molcas version 22.02-260-gd39e60428 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Wed Apr 27 18:28:24 2022 * #>> 1 #> POTNUC="13.522136977422"/6 @@ -50,98 +50,98 @@ #> SEWARD_ATTRACT="-35.941520411926"/5 #>> 2 #> SCF_ITER="8"/8 -#> E_SCF="-40.515612956798"/8 -#> DFT_ENERGY="-5.597618868963"/6 -#> NQ_DENSITY="10.000007868873"/8 +#> E_SCF="-40.515612956788"/8 +#> DFT_ENERGY="-5.597618868956"/6 +#> NQ_DENSITY="10.000007868841"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="0.0"/5 +#> MLTPL__1[1]="0.000000000000"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.000004364287"/5 +#> MLTPL__2[0]="-0.000004364286"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="0.000008728574"/5 +#> MLTPL__2[3]="0.000008728571"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.000004364287"/5 +#> MLTPL__2[5]="-0.000004364286"/5 #>> 3 -#> GRAD[0]="-0.000000000000"/6 -#> GRAD[1]="-0.009563213793"/6 -#> GRAD[2]="0.006760367811"/6 -#> GRAD[3]="-0.006760367811"/6 -#> GRAD[4]="-0.009563213793"/6 +#> GRAD[0]="0.000000000000"/6 +#> GRAD[1]="-0.009563213821"/6 +#> GRAD[2]="0.006760367828"/6 +#> GRAD[3]="-0.006760367828"/6 +#> GRAD[4]="-0.009563213821"/6 #>> 4 #>> 6 -#> POTNUC="13.366523454001"/6 +#> POTNUC="13.366523453575"/6 #> SEWARD_MLTPL1X="0.077508834155"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.919028278696"/5 +#> SEWARD_ATTRACT="-35.919028278635"/5 #>> 7 #> SCF_ITER="7"/8 -#> E_SCF="-40.516302884977"/8 -#> DFT_ENERGY="-5.583296715272"/6 -#> NQ_DENSITY="10.000007957947"/8 +#> E_SCF="-40.516302884968"/8 +#> DFT_ENERGY="-5.583296715226"/6 +#> NQ_DENSITY="10.000007957914"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="-0.000000000000"/5 +#> MLTPL__1[1]="0.000000000000"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.000025729722"/5 +#> MLTPL__2[0]="0.000025729757"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.000051459444"/5 +#> MLTPL__2[3]="-0.000051459515"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.000025729722"/5 +#> MLTPL__2[5]="0.000025729758"/5 #>> 8 -#> GRAD[0]="-0.000000000000"/6 -#> GRAD[1]="-0.002344041683"/6 -#> GRAD[2]="0.001657696155"/6 -#> GRAD[3]="-0.001657696155"/6 -#> GRAD[4]="-0.002344041683"/6 +#> GRAD[0]="0.0"/6 +#> GRAD[1]="-0.002344041689"/6 +#> GRAD[2]="0.001657696161"/6 +#> GRAD[3]="-0.001657696161"/6 +#> GRAD[4]="-0.002344041689"/6 #>> 9 #>> 11 -#> POTNUC="13.314287353773"/6 +#> POTNUC="13.314287351266"/6 #> SEWARD_MLTPL1X="0.077508834155"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.911478153956"/5 +#> SEWARD_ATTRACT="-35.911478153594"/5 #>> 12 -#> SCF_ITER="5"/8 -#> E_SCF="-40.516349297963"/8 -#> DFT_ENERGY="-5.578461872560"/6 -#> NQ_DENSITY="10.000007936161"/8 -#> MLTPL__0="-0.000000000000"/5 +#> SCF_ITER="6"/8 +#> E_SCF="-40.516349298743"/8 +#> DFT_ENERGY="-5.578476790006"/6 +#> NQ_DENSITY="10.000007935931"/8 +#> MLTPL__0="0.0"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="-0.000000000000"/5 +#> MLTPL__1[1]="0.000000000000"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.000021122585"/5 +#> MLTPL__2[0]="0.000021122365"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.000042245168"/5 +#> MLTPL__2[3]="-0.000042244730"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.000021122584"/5 +#> MLTPL__2[5]="0.000021122365"/5 #>> 13 -#> GRAD[0]="0.0"/6 -#> GRAD[1]="-0.000004998371"/6 -#> GRAD[2]="0.000003525349"/6 -#> GRAD[3]="-0.000003525349"/6 -#> GRAD[4]="-0.000004998371"/6 +#> GRAD[0]="0.000000000000"/6 +#> GRAD[1]="0.000001936289"/6 +#> GRAD[2]="-0.000001378166"/6 +#> GRAD[3]="0.000001378165"/6 +#> GRAD[4]="0.000001936289"/6 #>> 14 #> GEO_ITER="3"/8 -#> POTNUC="13.314200643541"/6 +#> POTNUC="13.314354350207"/6 #> SEWARD_MLTPL1X="0.077508834155"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.911465620994"/5 +#> SEWARD_ATTRACT="-35.911487837517"/5 #> SCF_ITER="2"/8 -#> E_SCF="-40.516349298490"/8 -#> DFT_ENERGY="-5.578467400064"/6 -#> NQ_DENSITY="10.000007935927"/8 +#> E_SCF="-40.516349298762"/8 +#> DFT_ENERGY="-5.578484290163"/6 +#> NQ_DENSITY="10.000007935947"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="-0.000000000000"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.000021262822"/5 +#> MLTPL__2[0]="0.000021266163"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.000042525645"/5 +#> MLTPL__2[3]="-0.000042532326"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.000021262822"/5 +#> MLTPL__2[5]="0.000021266163"/5 #>> 15 >>EOF diff -Nru openmolcas-22.02/test/standard/085.input openmolcas-22.10/test/standard/085.input --- openmolcas-22.02/test/standard/085.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/standard/085.input 2022-10-10 14:22:40.000000000 +0000 @@ -51,13 +51,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-943-g4c2682958 -* Linux lucifer 5.13.0-27-generic #29~20.04.1-Ubuntu SMP Fri Jan 14 00:32:30 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux -<<<<<<< HEAD -* Sat Feb 5 17:07:33 2022 -======= -* Sat Feb 5 10:41:00 2022 ->>>>>>> 5c90c039acb7870c868530aacb70c599130a2cf9 +* Molcas version 22.02-260-gd39e60428 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Wed Apr 27 18:28:24 2022 * #>> 1 #> POTNUC="13.522136977422"/6 @@ -66,98 +62,98 @@ #> SEWARD_ATTRACT="-35.941520411926"/5 #>> 2 #> SCF_ITER="8"/8 -#> E_SCF="-40.515612956798"/8 -#> DFT_ENERGY="-5.597618868963"/6 -#> NQ_DENSITY="10.000007868873"/8 +#> E_SCF="-40.515612956788"/8 +#> DFT_ENERGY="-5.597618868956"/6 +#> NQ_DENSITY="10.000007868841"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="0.0"/5 +#> MLTPL__1[1]="0.000000000000"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.000004364287"/5 +#> MLTPL__2[0]="-0.000004364286"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="0.000008728574"/5 +#> MLTPL__2[3]="0.000008728571"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.000004364287"/5 +#> MLTPL__2[5]="-0.000004364286"/5 #>> 3 -#> GRAD[0]="-0.000000000000"/6 -#> GRAD[1]="-0.009563213793"/6 -#> GRAD[2]="0.006760367811"/6 -#> GRAD[3]="-0.006760367811"/6 -#> GRAD[4]="-0.009563213793"/6 +#> GRAD[0]="0.000000000000"/6 +#> GRAD[1]="-0.009563213821"/6 +#> GRAD[2]="0.006760367828"/6 +#> GRAD[3]="-0.006760367828"/6 +#> GRAD[4]="-0.009563213821"/6 #>> 4 #>> 6 -#> POTNUC="13.366523454001"/6 +#> POTNUC="13.366523453575"/6 #> SEWARD_MLTPL1X="0.077508834155"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.919028278696"/5 +#> SEWARD_ATTRACT="-35.919028278635"/5 #>> 7 #> SCF_ITER="7"/8 -#> E_SCF="-40.516302884977"/8 -#> DFT_ENERGY="-5.583296715272"/6 -#> NQ_DENSITY="10.000007957947"/8 +#> E_SCF="-40.516302884968"/8 +#> DFT_ENERGY="-5.583296715226"/6 +#> NQ_DENSITY="10.000007957914"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="-0.000000000000"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.000025729722"/5 +#> MLTPL__2[0]="0.000025729757"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.000051459444"/5 +#> MLTPL__2[3]="-0.000051459515"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.000025729722"/5 +#> MLTPL__2[5]="0.000025729757"/5 #>> 8 #> GRAD[0]="-0.000000000000"/6 -#> GRAD[1]="-0.002344041683"/6 -#> GRAD[2]="0.001657696155"/6 -#> GRAD[3]="-0.001657696155"/6 -#> GRAD[4]="-0.002344041683"/6 +#> GRAD[1]="-0.002344041689"/6 +#> GRAD[2]="0.001657696161"/6 +#> GRAD[3]="-0.001657696161"/6 +#> GRAD[4]="-0.002344041689"/6 #>> 9 #>> 11 -#> POTNUC="13.314287353785"/6 +#> POTNUC="13.314287351276"/6 #> SEWARD_MLTPL1X="0.077508834155"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.911478153958"/5 +#> SEWARD_ATTRACT="-35.911478153596"/5 #>> 12 -#> SCF_ITER="5"/8 -#> E_SCF="-40.516349297963"/8 -#> DFT_ENERGY="-5.578461872561"/6 -#> NQ_DENSITY="10.000007936161"/8 -#> MLTPL__0="0.0"/5 +#> SCF_ITER="6"/8 +#> E_SCF="-40.516349298744"/8 +#> DFT_ENERGY="-5.578476790007"/6 +#> NQ_DENSITY="10.000007935931"/8 +#> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="-0.000000000000"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.000021122585"/5 +#> MLTPL__2[0]="0.000021122365"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.000042245168"/5 +#> MLTPL__2[3]="-0.000042244730"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.000021122584"/5 +#> MLTPL__2[5]="0.000021122365"/5 #>> 13 #> GRAD[0]="0.000000000000"/6 -#> GRAD[1]="-0.000004998371"/6 -#> GRAD[2]="0.000003525349"/6 -#> GRAD[3]="-0.000003525349"/6 -#> GRAD[4]="-0.000004998371"/6 +#> GRAD[1]="0.000001936289"/6 +#> GRAD[2]="-0.000001378165"/6 +#> GRAD[3]="0.000001378165"/6 +#> GRAD[4]="0.000001936289"/6 #>> 14 #> GEO_ITER="3"/8 -#> POTNUC="13.314200643582"/6 +#> POTNUC="13.314354350223"/6 #> SEWARD_MLTPL1X="0.077508834155"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.911465621000"/5 +#> SEWARD_ATTRACT="-35.911487837519"/5 #> SCF_ITER="2"/8 -#> E_SCF="-40.516349298490"/8 -#> DFT_ENERGY="-5.578467400068"/6 -#> NQ_DENSITY="10.000007935927"/8 +#> E_SCF="-40.516349298762"/8 +#> DFT_ENERGY="-5.578484290164"/6 +#> NQ_DENSITY="10.000007935947"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.000000000000"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.000021262822"/5 +#> MLTPL__2[0]="0.000021266163"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.000042525645"/5 +#> MLTPL__2[3]="-0.000042532326"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.000021262822"/5 +#> MLTPL__2[5]="0.000021266163"/5 #>> 15 >>EOF diff -Nru openmolcas-22.02/test/standard/090.input openmolcas-22.10/test/standard/090.input --- openmolcas-22.02/test/standard/090.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/standard/090.input 2022-10-10 14:22:40.000000000 +0000 @@ -20,9 +20,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.02-1119-gde6a49c4e -* Linux otis 4.15.0-1073-oem #83-Ubuntu SMP Mon Feb 17 11:21:18 UTC 2020 x86_64 x86_64 x86_64 GNU/Linux -* Thu May 13 18:05:54 2021 +* Molcas version 22.02-260-gd39e60428 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Wed Apr 27 18:28:24 2022 * #>> 1 #> POTNUC="101.716050102706"/12 @@ -49,7 +49,7 @@ #> MLTPL__1[0]="0.635145055135"/5 #> MLTPL__1[1]="0.133640427347"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-1.751986044988"/5 +#> MLTPL__2[0]="-1.751986044989"/5 #> MLTPL__2[1]="-0.403304768416"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.604971764772"/5 @@ -62,7 +62,7 @@ #> MLTPL__1[0]="0.635145055135"/5 #> MLTPL__1[1]="0.133640427347"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-1.751986044988"/5 +#> MLTPL__2[0]="-1.751986044989"/5 #> MLTPL__2[1]="-0.403304768416"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.604971764772"/5 @@ -94,7 +94,7 @@ #> MLTPL__1[0]="0.633649622501"/5 #> MLTPL__1[1]="0.134350412735"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-1.755708210746"/5 +#> MLTPL__2[0]="-1.755708210747"/5 #> MLTPL__2[1]="-0.406821501988"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.606752153702"/5 @@ -136,29 +136,29 @@ #> SEWARD_ATTRACT="-39.850430088079"/5 #>> 16 #> SCF_ITER="8"/8 -#> E_SCF="-188.282655923709"/8 +#> E_SCF="-188.282655923710"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.852112720268"/5 #> MLTPL__1[1]="0.200869313644"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-2.072778272930"/5 +#> MLTPL__2[0]="-2.072778272932"/5 #> MLTPL__2[1]="-0.489941334946"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.880456562271"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.192321710659"/5 +#> MLTPL__2[5]="0.192321710660"/5 #>> 17 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="0.636612329461"/5 +#> MLTPL__1[0]="0.636612329460"/5 #> MLTPL__1[1]="0.132926333703"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-1.748241321853"/5 +#> MLTPL__2[0]="-1.748241321855"/5 #> MLTPL__2[1]="-0.399811525494"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.603200329614"/5 +#> MLTPL__2[3]="1.603200329615"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.145040992239"/5 -#> E_MP2="-188.527966017078"/8 +#> MLTPL__2[5]="0.145040992240"/5 +#> E_MP2="-188.527966017079"/8 #> HF_REF_WEIGHT="0.888661822239"/8 #>> 18 #> GRAD[0]="0.039071443101"/6 @@ -197,14 +197,14 @@ #> E_SCF="-188.283593332402"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.850710776034"/5 -#> MLTPL__1[1]="0.199701722879"/5 +#> MLTPL__1[1]="0.199701722878"/5 #> MLTPL__1[2]="0.0"/5 #> MLTPL__2[0]="-2.075361654961"/5 #> MLTPL__2[1]="-0.491318740564"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.880846286267"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.194515368693"/5 +#> MLTPL__2[5]="0.194515368694"/5 #>> 24 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.636742922576"/5 @@ -216,7 +216,7 @@ #> MLTPL__2[3]="1.600782988640"/5 #> MLTPL__2[4]="0.0"/5 #> MLTPL__2[5]="0.145704792211"/5 -#> E_MP2="-188.528417609880"/8 +#> E_MP2="-188.528417609879"/8 #> HF_REF_WEIGHT="0.889109203117"/8 #>> 25 #> GRAD[0]="0.032586426199"/6 @@ -252,7 +252,7 @@ #> SEWARD_ATTRACT="-39.853373185652"/5 #>> 30 #> SCF_ITER="8"/8 -#> E_SCF="-188.283983036051"/8 +#> E_SCF="-188.283983036052"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.846395509383"/5 #> MLTPL__1[1]="0.202260529141"/5 @@ -304,7 +304,7 @@ #>> 33 #>> 34 #>> 36 -#> POTNUC="101.686813597694"/6 +#> POTNUC="101.686813597695"/6 #> SEWARD_MLTPL1X="3.548652088691"/5 #> SEWARD_KINETIC="15.891121812396"/5 #> SEWARD_ATTRACT="-39.860558842489"/5 @@ -316,7 +316,7 @@ #> MLTPL__1[1]="0.201910180698"/5 #> MLTPL__1[2]="0.0"/5 #> MLTPL__2[0]="-2.081749609108"/5 -#> MLTPL__2[1]="-0.495875864566"/5 +#> MLTPL__2[1]="-0.495875864565"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.888964459852"/5 #> MLTPL__2[4]="0.0"/5 @@ -370,13 +370,13 @@ #> SCF_ITER="8"/8 #> E_SCF="-188.284553115434"/8 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="0.847195174438"/5 +#> MLTPL__1[0]="0.847195174439"/5 #> MLTPL__1[1]="0.200034743989"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-2.078979659454"/5 +#> MLTPL__2[0]="-2.078979659455"/5 #> MLTPL__2[1]="-0.493173624940"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.879845564945"/5 +#> MLTPL__2[3]="1.879845564946"/5 #> MLTPL__2[4]="0.0"/5 #> MLTPL__2[5]="0.199134094510"/5 #>> 45 @@ -384,13 +384,13 @@ #> MLTPL__1[0]="0.635419990000"/5 #> MLTPL__1[1]="0.132787784020"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-1.752143280625"/5 -#> MLTPL__2[1]="-0.402863343720"/5 +#> MLTPL__2[0]="-1.752143280626"/5 +#> MLTPL__2[1]="-0.402863343721"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.600536673067"/5 #> MLTPL__2[4]="0.0"/5 #> MLTPL__2[5]="0.151606607559"/5 -#> E_MP2="-188.528961087633"/8 +#> E_MP2="-188.528961087634"/8 #> HF_REF_WEIGHT="0.889474256528"/8 #>> 46 #> GRAD[0]="0.037339000783"/6 @@ -426,17 +426,17 @@ #> SEWARD_ATTRACT="-39.858549743995"/5 #>> 51 #> SCF_ITER="7"/8 -#> E_SCF="-188.283992006399"/8 +#> E_SCF="-188.283992006400"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.849962739315"/5 #> MLTPL__1[1]="0.199888590837"/5 #> MLTPL__1[2]="0.0"/5 #> MLTPL__2[0]="-2.077540960255"/5 -#> MLTPL__2[1]="-0.491978267054"/5 +#> MLTPL__2[1]="-0.491978267055"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.881234060016"/5 +#> MLTPL__2[3]="1.881234060017"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.196306900238"/5 +#> MLTPL__2[5]="0.196306900239"/5 #>> 52 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.636514447936"/5 @@ -445,10 +445,10 @@ #> MLTPL__2[0]="-1.750252829120"/5 #> MLTPL__2[1]="-0.400473749411"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.601948922580"/5 +#> MLTPL__2[3]="1.601948922581"/5 #> MLTPL__2[4]="0.0"/5 #> MLTPL__2[5]="0.148303906539"/5 -#> E_MP2="-188.528674825225"/8 +#> E_MP2="-188.528674825226"/8 #> HF_REF_WEIGHT="0.889236900979"/8 #>> 53 #> GRAD[0]="0.032372944661"/6 @@ -530,7 +530,7 @@ #> GRAD[18]="-0.014426412811"/6 #> GRAD[19]="-0.037860500426"/6 #> GRAD[20]="0.0"/6 -#> GRAD[21]="0.000463457551"/6 +#> GRAD[21]="0.000463457552"/6 #> GRAD[22]="0.022347467099"/6 #> GRAD[23]="0.0"/6 #>> 61 @@ -547,21 +547,21 @@ #> MLTPL__1[0]="0.851690137964"/5 #> MLTPL__1[1]="0.201076067512"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-2.076061545238"/5 +#> MLTPL__2[0]="-2.076061545239"/5 #> MLTPL__2[1]="-0.488413024224"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.882552495660"/5 +#> MLTPL__2[3]="1.882552495661"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.193509049578"/5 +#> MLTPL__2[5]="0.193509049579"/5 #>> 66 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.636645444576"/5 #> MLTPL__1[1]="0.133022978352"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-1.748910737841"/5 +#> MLTPL__2[0]="-1.748910737842"/5 #> MLTPL__2[1]="-0.398313263297"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.603443474317"/5 +#> MLTPL__2[3]="1.603443474318"/5 #> MLTPL__2[4]="0.0"/5 #> MLTPL__2[5]="0.145467263524"/5 #> E_MP2="-188.528626331892"/8 @@ -602,26 +602,26 @@ #> SCF_ITER="8"/8 #> E_SCF="-188.283831926762"/8 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="0.845405964273"/5 +#> MLTPL__1[0]="0.845405964274"/5 #> MLTPL__1[1]="0.200901016261"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-2.084650922621"/5 -#> MLTPL__2[1]="-0.500687294980"/5 +#> MLTPL__2[0]="-2.084650922622"/5 +#> MLTPL__2[1]="-0.500687294979"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.886280537648"/5 +#> MLTPL__2[3]="1.886280537649"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.198370384972"/5 +#> MLTPL__2[5]="0.198370384973"/5 #>> 73 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.633646437202"/5 #> MLTPL__1[1]="0.134271497686"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-1.754963800679"/5 +#> MLTPL__2[0]="-1.754963800680"/5 #> MLTPL__2[1]="-0.408277846969"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.606401966776"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.148561833903"/5 +#> MLTPL__2[5]="0.148561833904"/5 #> E_MP2="-188.528616518837"/8 #> HF_REF_WEIGHT="0.889145407945"/8 #>> 74 @@ -663,7 +663,7 @@ #> MLTPL__1[0]="0.848009041541"/5 #> MLTPL__1[1]="0.200326523804"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-2.093289378773"/5 +#> MLTPL__2[0]="-2.093289378774"/5 #> MLTPL__2[1]="-0.492068791800"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.891939268946"/5 @@ -674,10 +674,10 @@ #> MLTPL__1[0]="0.633980085623"/5 #> MLTPL__1[1]="0.132934915014"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-1.756243677771"/5 -#> MLTPL__2[1]="-0.399530547781"/5 +#> MLTPL__2[0]="-1.756243677772"/5 +#> MLTPL__2[1]="-0.399530547782"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.607630041969"/5 +#> MLTPL__2[3]="1.607630041970"/5 #> MLTPL__2[4]="0.0"/5 #> MLTPL__2[5]="0.148613635802"/5 #> E_MP2="-188.528667399092"/8 @@ -721,8 +721,8 @@ #> MLTPL__1[0]="0.849087530087"/5 #> MLTPL__1[1]="0.201630111367"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-2.067567382821"/5 -#> MLTPL__2[1]="-0.497081682988"/5 +#> MLTPL__2[0]="-2.067567382822"/5 +#> MLTPL__2[1]="-0.497081682987"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.876993085900"/5 #> MLTPL__2[4]="0.0"/5 @@ -732,8 +732,8 @@ #> MLTPL__1[0]="0.636272803493"/5 #> MLTPL__1[1]="0.134330639829"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-1.747737837363"/5 -#> MLTPL__2[1]="-0.407089818770"/5 +#> MLTPL__2[0]="-1.747737837364"/5 +#> MLTPL__2[1]="-0.407089818769"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.602302891409"/5 #> MLTPL__2[4]="0.0"/5 @@ -774,29 +774,29 @@ #> SEWARD_ATTRACT="-39.849877768944"/5 #>> 93 #> SCF_ITER="8"/8 -#> E_SCF="-188.283589364353"/8 +#> E_SCF="-188.283589364354"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.849915024432"/5 -#> MLTPL__1[1]="0.202506777431"/5 +#> MLTPL__1[1]="0.202506777430"/5 #> MLTPL__1[2]="0.0"/5 #> MLTPL__2[0]="-2.084695781517"/5 -#> MLTPL__2[1]="-0.497762567823"/5 +#> MLTPL__2[1]="-0.497762567824"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.895400065917"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.189295715599"/5 +#> MLTPL__2[5]="0.189295715600"/5 #>> 94 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.634294670734"/5 #> MLTPL__1[1]="0.134335760105"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-1.752728436754"/5 +#> MLTPL__2[0]="-1.752728436753"/5 #> MLTPL__2[1]="-0.404883383042"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.613004684025"/5 #> MLTPL__2[4]="0.0"/5 #> MLTPL__2[5]="0.139723752728"/5 -#> E_MP2="-188.529216530725"/8 +#> E_MP2="-188.529216530726"/8 #> HF_REF_WEIGHT="0.888583699985"/8 #>> 95 #> GRAD[0]="0.034636282129"/6 @@ -832,28 +832,28 @@ #> SEWARD_ATTRACT="-39.865541404379"/5 #>> 100 #> SCF_ITER="8"/8 -#> E_SCF="-188.283980178928"/8 +#> E_SCF="-188.283980178927"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.847191542269"/5 #> MLTPL__1[1]="0.199462843904"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-2.076109357490"/5 -#> MLTPL__2[1]="-0.491367250722"/5 +#> MLTPL__2[0]="-2.076109357491"/5 +#> MLTPL__2[1]="-0.491367250723"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.873539761398"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.202569596092"/5 +#> MLTPL__2[5]="0.202569596093"/5 #>> 101 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.635974497673"/5 #> MLTPL__1[1]="0.132939860949"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-1.751208213745"/5 +#> MLTPL__2[0]="-1.751208213746"/5 #> MLTPL__2[1]="-0.401709314330"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.596930216586"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.154277997159"/5 +#> MLTPL__2[5]="0.154277997160"/5 #> E_MP2="-188.528021200588"/8 #> HF_REF_WEIGHT="0.889634687960"/8 #>> 102 @@ -895,18 +895,18 @@ #> MLTPL__1[0]="0.846856834334"/5 #> MLTPL__1[1]="0.203372436093"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-2.077550733852"/5 +#> MLTPL__2[0]="-2.077550733853"/5 #> MLTPL__2[1]="-0.503132176026"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.881226121994"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.196324611858"/5 +#> MLTPL__2[5]="0.196324611859"/5 #>> 108 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.633227719468"/5 -#> MLTPL__1[1]="0.135344928137"/5 +#> MLTPL__1[1]="0.135344928136"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-1.746431125263"/5 +#> MLTPL__2[0]="-1.746431125264"/5 #> MLTPL__2[1]="-0.408999793388"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.599918285359"/5 @@ -947,55 +947,55 @@ #> SEWARD_KINETIC="15.891121812396"/5 #> SEWARD_ATTRACT="-39.855037576102"/5 #>> 114 -#> SCF_ITER="8"/8 -#> E_SCF="-188.283802628488"/8 +#> SCF_ITER="9"/8 +#> E_SCF="-188.283802628673"/8 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="0.850240222812"/5 -#> MLTPL__1[1]="0.198601453703"/5 +#> MLTPL__1[0]="0.850238156730"/5 +#> MLTPL__1[1]="0.198600678568"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-2.083240196272"/5 -#> MLTPL__2[1]="-0.485961298028"/5 +#> MLTPL__2[0]="-2.083235047910"/5 +#> MLTPL__2[1]="-0.485961190109"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.887718289445"/5 +#> MLTPL__2[3]="1.887715508862"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.195521906826"/5 +#> MLTPL__2[5]="0.195519539048"/5 #>> 115 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="0.637056051912"/5 -#> MLTPL__1[1]="0.131939129882"/5 +#> MLTPL__1[0]="0.637055079832"/5 +#> MLTPL__1[1]="0.131938601461"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-1.757523049261"/5 -#> MLTPL__2[1]="-0.397572078740"/5 +#> MLTPL__2[0]="-1.757518180846"/5 +#> MLTPL__2[1]="-0.397571819456"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.610041009252"/5 +#> MLTPL__2[3]="1.610037883799"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.147482040009"/5 -#> E_MP2="-188.528574487046"/8 -#> HF_REF_WEIGHT="0.889164139151"/8 +#> MLTPL__2[5]="0.147480297048"/5 +#> E_MP2="-188.528574570312"/8 +#> HF_REF_WEIGHT="0.889164076751"/8 #>> 116 -#> GRAD[0]="0.034491325902"/6 -#> GRAD[1]="0.017028675265"/6 +#> GRAD[0]="0.034491296841"/6 +#> GRAD[1]="0.017028713120"/6 #> GRAD[2]="0.0"/6 -#> GRAD[3]="-0.085802295640"/6 -#> GRAD[4]="0.011632919773"/6 +#> GRAD[3]="-0.085802666812"/6 +#> GRAD[4]="0.011633261919"/6 #> GRAD[5]="0.0"/6 -#> GRAD[6]="0.101700167732"/6 -#> GRAD[7]="-0.005809521960"/6 +#> GRAD[6]="0.101701557969"/6 +#> GRAD[7]="-0.005809918467"/6 #> GRAD[8]="0.0"/6 -#> GRAD[9]="-0.015394565854"/6 -#> GRAD[10]="-0.000402696434"/6 +#> GRAD[9]="-0.015394941284"/6 +#> GRAD[10]="-0.000402103742"/6 #> GRAD[11]="0.0"/6 -#> GRAD[12]="-0.001165735058"/6 -#> GRAD[13]="-0.020217948637"/6 +#> GRAD[12]="-0.001165771699"/6 +#> GRAD[13]="-0.020218253397"/6 #> GRAD[14]="0.0"/6 -#> GRAD[15]="-0.018560640055"/6 -#> GRAD[16]="0.013209991673"/6 +#> GRAD[15]="-0.018560828079"/6 +#> GRAD[16]="0.013210135079"/6 #> GRAD[17]="0.0"/6 -#> GRAD[18]="-0.015086998801"/6 -#> GRAD[19]="-0.037210435874"/6 +#> GRAD[18]="-0.015087431436"/6 +#> GRAD[19]="-0.037210951070"/6 #> GRAD[20]="0.0"/6 -#> GRAD[21]="-0.000181258227"/6 -#> GRAD[22]="0.021769016194"/6 +#> GRAD[21]="-0.000181215501"/6 +#> GRAD[22]="0.021769116557"/6 #> GRAD[23]="0.0"/6 #>> 117 #>> 118 @@ -1008,52 +1008,52 @@ #> SCF_ITER="8"/8 #> E_SCF="-188.283601198398"/8 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="0.850189326357"/5 -#> MLTPL__1[1]="0.200913626951"/5 +#> MLTPL__1[0]="0.850189335346"/5 +#> MLTPL__1[1]="0.200913629892"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-2.067839298433"/5 -#> MLTPL__2[1]="-0.499506149472"/5 +#> MLTPL__2[0]="-2.067839285545"/5 +#> MLTPL__2[1]="-0.499506144600"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.870613148902"/5 +#> MLTPL__2[3]="1.870613142047"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.197226149531"/5 +#> MLTPL__2[5]="0.197226143498"/5 #>> 122 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="0.635349199680"/5 -#> MLTPL__1[1]="0.133326769045"/5 +#> MLTPL__1[0]="0.635349205649"/5 +#> MLTPL__1[1]="0.133326771179"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-1.739303047337"/5 -#> MLTPL__2[1]="-0.407503319715"/5 +#> MLTPL__2[0]="-1.739303037164"/5 +#> MLTPL__2[1]="-0.407503315497"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.591720683161"/5 +#> MLTPL__2[3]="1.591720677851"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.147582364176"/5 -#> E_MP2="-188.528578986432"/8 -#> HF_REF_WEIGHT="0.888990729563"/8 +#> MLTPL__2[5]="0.147582359313"/5 +#> E_MP2="-188.528578986385"/8 +#> HF_REF_WEIGHT="0.888990729610"/8 #>> 123 -#> GRAD[0]="0.034010639372"/6 -#> GRAD[1]="0.017416934845"/6 +#> GRAD[0]="0.034010639123"/6 +#> GRAD[1]="0.017416934695"/6 #> GRAD[2]="0.0"/6 -#> GRAD[3]="-0.085812898032"/6 -#> GRAD[4]="0.011603178813"/6 +#> GRAD[3]="-0.085812898662"/6 +#> GRAD[4]="0.011603178647"/6 #> GRAD[5]="0.0"/6 -#> GRAD[6]="0.102550820987"/6 -#> GRAD[7]="-0.005336653021"/6 +#> GRAD[6]="0.102550821048"/6 +#> GRAD[7]="-0.005336652883"/6 #> GRAD[8]="0.0"/6 -#> GRAD[9]="-0.017761810052"/6 -#> GRAD[10]="-0.002097527035"/6 +#> GRAD[9]="-0.017761809801"/6 +#> GRAD[10]="-0.002097527379"/6 #> GRAD[11]="0.0"/6 -#> GRAD[12]="-0.001783608546"/6 -#> GRAD[13]="-0.021961572519"/6 +#> GRAD[12]="-0.001783608417"/6 +#> GRAD[13]="-0.021961572153"/6 #> GRAD[14]="0.0"/6 -#> GRAD[15]="-0.017713445338"/6 -#> GRAD[16]="0.013006813298"/6 +#> GRAD[15]="-0.017713444990"/6 +#> GRAD[16]="0.013006813103"/6 #> GRAD[17]="0.0"/6 -#> GRAD[18]="-0.013893423267"/6 -#> GRAD[19]="-0.036639616541"/6 +#> GRAD[18]="-0.013893423295"/6 +#> GRAD[19]="-0.036639616475"/6 #> GRAD[20]="0.0"/6 -#> GRAD[21]="0.000403724875"/6 -#> GRAD[22]="0.024008442160"/6 +#> GRAD[21]="0.000403724994"/6 +#> GRAD[22]="0.024008442446"/6 #> GRAD[23]="0.0"/6 #>> 124 #>> 125 @@ -1066,52 +1066,52 @@ #> SCF_ITER="8"/8 #> E_SCF="-188.283991314318"/8 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="0.846925948412"/5 +#> MLTPL__1[0]="0.846925948411"/5 #> MLTPL__1[1]="0.201045204829"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-2.092907276178"/5 +#> MLTPL__2[0]="-2.092907276180"/5 #> MLTPL__2[1]="-0.489652048282"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.898304938169"/5 +#> MLTPL__2[3]="1.898304938170"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.194602338009"/5 +#> MLTPL__2[5]="0.194602338010"/5 #>> 129 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="0.634940097691"/5 +#> MLTPL__1[0]="0.634940097692"/5 #> MLTPL__1[1]="0.133946186567"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-1.764611098450"/5 -#> MLTPL__2[1]="-0.399125186577"/5 +#> MLTPL__2[0]="-1.764611098449"/5 +#> MLTPL__2[1]="-0.399125186576"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.618213770307"/5 +#> MLTPL__2[3]="1.618213770306"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.146397328143"/5 -#> E_MP2="-188.528680489555"/8 +#> MLTPL__2[5]="0.146397328142"/5 +#> E_MP2="-188.528680489554"/8 #> HF_REF_WEIGHT="0.889228643103"/8 #>> 130 -#> GRAD[0]="0.034639259087"/6 -#> GRAD[1]="0.017124664777"/6 +#> GRAD[0]="0.034639259086"/6 +#> GRAD[1]="0.017124664776"/6 #> GRAD[2]="0.0"/6 -#> GRAD[3]="-0.086295293991"/6 -#> GRAD[4]="0.011809641790"/6 +#> GRAD[3]="-0.086295293992"/6 +#> GRAD[4]="0.011809641789"/6 #> GRAD[5]="0.0"/6 -#> GRAD[6]="0.101520440882"/6 -#> GRAD[7]="-0.006026259584"/6 +#> GRAD[6]="0.101520440883"/6 +#> GRAD[7]="-0.006026259585"/6 #> GRAD[8]="0.0"/6 #> GRAD[9]="-0.014784388769"/6 #> GRAD[10]="-0.001224888124"/6 #> GRAD[11]="0.0"/6 #> GRAD[12]="-0.000655003905"/6 -#> GRAD[13]="-0.021648128951"/6 +#> GRAD[13]="-0.021648128950"/6 #> GRAD[14]="0.0"/6 -#> GRAD[15]="-0.019786776728"/6 -#> GRAD[16]="0.014730175892"/6 +#> GRAD[15]="-0.019786776727"/6 +#> GRAD[16]="0.014730175891"/6 #> GRAD[17]="0.0"/6 #> GRAD[18]="-0.014790763543"/6 #> GRAD[19]="-0.035176520232"/6 #> GRAD[20]="0.0"/6 -#> GRAD[21]="0.000152526966"/6 -#> GRAD[22]="0.020411314433"/6 +#> GRAD[21]="0.000152526967"/6 +#> GRAD[22]="0.020411314434"/6 #> GRAD[23]="0.0"/6 #>> 131 #>> 132 @@ -1124,13 +1124,13 @@ #> SCF_ITER="7"/8 #> E_SCF="-188.284155776026"/8 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="0.846522740726"/5 +#> MLTPL__1[0]="0.846522740727"/5 #> MLTPL__1[1]="0.200598475139"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-2.082222436082"/5 +#> MLTPL__2[0]="-2.082222436081"/5 #> MLTPL__2[1]="-0.514740223627"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.887272694816"/5 +#> MLTPL__2[3]="1.887272694815"/5 #> MLTPL__2[4]="0.0"/5 #> MLTPL__2[5]="0.194949741266"/5 #>> 136 @@ -1138,10 +1138,10 @@ #> MLTPL__1[0]="0.634280606056"/5 #> MLTPL__1[1]="0.133791262708"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-1.754385635648"/5 -#> MLTPL__2[1]="-0.422086473472"/5 +#> MLTPL__2[0]="-1.754385635647"/5 +#> MLTPL__2[1]="-0.422086473473"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.608014036353"/5 +#> MLTPL__2[3]="1.608014036352"/5 #> MLTPL__2[4]="0.0"/5 #> MLTPL__2[5]="0.146371599295"/5 #> E_MP2="-188.528909909703"/8 @@ -1185,19 +1185,19 @@ #> MLTPL__1[0]="0.850595363760"/5 #> MLTPL__1[1]="0.201375283078"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-2.078453650579"/5 +#> MLTPL__2[0]="-2.078453650580"/5 #> MLTPL__2[1]="-0.474365146592"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.881573104708"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.196880545871"/5 +#> MLTPL__2[5]="0.196880545872"/5 #>> 143 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.636014833604"/5 #> MLTPL__1[1]="0.133497098116"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-1.749489456136"/5 -#> MLTPL__2[1]="-0.384515574958"/5 +#> MLTPL__2[0]="-1.749489456137"/5 +#> MLTPL__2[1]="-0.384515574959"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.601871541635"/5 #> MLTPL__2[4]="0.0"/5 @@ -1211,7 +1211,7 @@ #> GRAD[3]="-0.087117945967"/6 #> GRAD[4]="0.011979786091"/6 #> GRAD[5]="0.0"/6 -#> GRAD[6]="0.103111747216"/6 +#> GRAD[6]="0.103111747217"/6 #> GRAD[7]="-0.006010886260"/6 #> GRAD[8]="0.0"/6 #> GRAD[9]="-0.016738498639"/6 @@ -1243,7 +1243,7 @@ #> MLTPL__1[0]="0.851542856731"/5 #> MLTPL__1[1]="0.198717759038"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-2.066287443579"/5 +#> MLTPL__2[0]="-2.066287443580"/5 #> MLTPL__2[1]="-0.481459155448"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.871957805171"/5 @@ -1255,11 +1255,11 @@ #> MLTPL__1[1]="0.131701862752"/5 #> MLTPL__1[2]="0.0"/5 #> MLTPL__2[0]="-1.738647119520"/5 -#> MLTPL__2[1]="-0.392471968826"/5 +#> MLTPL__2[1]="-0.392471968825"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.593618758308"/5 +#> MLTPL__2[3]="1.593618758309"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.145028361211"/5 +#> MLTPL__2[5]="0.145028361212"/5 #> E_MP2="-188.528757172364"/8 #> HF_REF_WEIGHT="0.888828631336"/8 #>> 151 @@ -1312,10 +1312,10 @@ #> MLTPL__1[0]="0.634112205977"/5 #> MLTPL__1[1]="0.135579252268"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-1.765277141930"/5 +#> MLTPL__2[0]="-1.765277141931"/5 #> MLTPL__2[1]="-0.414115876560"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.616293753407"/5 +#> MLTPL__2[3]="1.616293753408"/5 #> MLTPL__2[4]="0.0"/5 #> MLTPL__2[5]="0.148983388523"/5 #> E_MP2="-188.528498739027"/8 @@ -1359,21 +1359,21 @@ #> MLTPL__1[0]="0.850059176042"/5 #> MLTPL__1[1]="0.199218887658"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-2.088428255011"/5 +#> MLTPL__2[0]="-2.088428255012"/5 #> MLTPL__2[1]="-0.493808746537"/5 #> MLTPL__2[2]="0.0"/5 #> MLTPL__2[3]="1.889976340745"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.198451914266"/5 +#> MLTPL__2[5]="0.198451914267"/5 #>> 164 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.636006055282"/5 #> MLTPL__1[1]="0.132044067176"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-1.758211119816"/5 +#> MLTPL__2[0]="-1.758211119817"/5 #> MLTPL__2[1]="-0.404441754080"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="1.609748779972"/5 +#> MLTPL__2[3]="1.609748779973"/5 #> MLTPL__2[4]="0.0"/5 #> MLTPL__2[5]="0.148462339844"/5 #> E_MP2="-188.528762253103"/8 @@ -1414,7 +1414,7 @@ #> SCF_ITER="7"/8 #> E_SCF="-188.283704974945"/8 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="0.847021852662"/5 +#> MLTPL__1[0]="0.847021852661"/5 #> MLTPL__1[1]="0.202746758446"/5 #> MLTPL__1[2]="0.0"/5 #> MLTPL__2[0]="-2.072279952832"/5 @@ -1477,7 +1477,7 @@ #> MLTPL__1[2]="-0.000187373631"/5 #> MLTPL__2[0]="-2.080390004655"/5 #> MLTPL__2[1]="-0.494563332177"/5 -#> MLTPL__2[2]="0.001275390617"/5 +#> MLTPL__2[2]="0.001275390618"/5 #> MLTPL__2[3]="1.884446163462"/5 #> MLTPL__2[4]="0.002597421148"/5 #> MLTPL__2[5]="0.195943841193"/5 @@ -1486,7 +1486,7 @@ #> MLTPL__1[0]="0.635148604630"/5 #> MLTPL__1[1]="0.133642038217"/5 #> MLTPL__1[2]="-0.000127193676"/5 -#> MLTPL__2[0]="-1.751978862276"/5 +#> MLTPL__2[0]="-1.751978862275"/5 #> MLTPL__2[1]="-0.403304334709"/5 #> MLTPL__2[2]="0.001525070285"/5 #> MLTPL__2[3]="1.604959346649"/5 @@ -1528,29 +1528,29 @@ #> SEWARD_ATTRACT="-39.857700047430"/5 #>> 184 #> SCF_ITER="7"/8 -#> E_SCF="-188.283810414738"/8 +#> E_SCF="-188.283810414739"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.848552358959"/5 #> MLTPL__1[1]="0.200984226229"/5 #> MLTPL__1[2]="0.000186099649"/5 -#> MLTPL__2[0]="-2.080385654678"/5 -#> MLTPL__2[1]="-0.494565625472"/5 +#> MLTPL__2[0]="-2.080385654680"/5 +#> MLTPL__2[1]="-0.494565625473"/5 #> MLTPL__2[2]="-0.001266426594"/5 -#> MLTPL__2[3]="1.884444634043"/5 +#> MLTPL__2[3]="1.884444634044"/5 #> MLTPL__2[4]="-0.002596954995"/5 -#> MLTPL__2[5]="0.195941020635"/5 +#> MLTPL__2[5]="0.195941020637"/5 #>> 185 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.635147631960"/5 #> MLTPL__1[1]="0.133641711569"/5 #> MLTPL__1[2]="0.000126368137"/5 -#> MLTPL__2[0]="-1.751977789689"/5 -#> MLTPL__2[1]="-0.403307313299"/5 +#> MLTPL__2[0]="-1.751977789692"/5 +#> MLTPL__2[1]="-0.403307313300"/5 #> MLTPL__2[2]="-0.001518503655"/5 -#> MLTPL__2[3]="1.604959945231"/5 +#> MLTPL__2[3]="1.604959945232"/5 #> MLTPL__2[4]="-0.002370376224"/5 -#> MLTPL__2[5]="0.147017844459"/5 -#> E_MP2="-188.528643441657"/8 +#> MLTPL__2[5]="0.147017844460"/5 +#> E_MP2="-188.528643441658"/8 #> HF_REF_WEIGHT="0.889110050373"/8 #>> 186 #> GRAD[0]="0.034322636607"/6 @@ -1588,26 +1588,26 @@ #> SCF_ITER="7"/8 #> E_SCF="-188.283810287462"/8 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="0.848543363086"/5 +#> MLTPL__1[0]="0.848543363087"/5 #> MLTPL__1[1]="0.200981343139"/5 #> MLTPL__1[2]="-0.000927566086"/5 -#> MLTPL__2[0]="-2.080389477811"/5 +#> MLTPL__2[0]="-2.080389477815"/5 #> MLTPL__2[1]="-0.494564541055"/5 #> MLTPL__2[2]="0.000327871698"/5 -#> MLTPL__2[3]="1.884447179144"/5 +#> MLTPL__2[3]="1.884447179145"/5 #> MLTPL__2[4]="0.000656044070"/5 -#> MLTPL__2[5]="0.195942298667"/5 +#> MLTPL__2[5]="0.195942298670"/5 #>> 192 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.635142297300"/5 #> MLTPL__1[1]="0.133639949870"/5 #> MLTPL__1[2]="-0.000846556354"/5 -#> MLTPL__2[0]="-1.751977992420"/5 -#> MLTPL__2[1]="-0.403306498038"/5 +#> MLTPL__2[0]="-1.751977992424"/5 +#> MLTPL__2[1]="-0.403306498039"/5 #> MLTPL__2[2]="0.000196229452"/5 -#> MLTPL__2[3]="1.604961186266"/5 +#> MLTPL__2[3]="1.604961186268"/5 #> MLTPL__2[4]="0.000694891735"/5 -#> MLTPL__2[5]="0.147016806154"/5 +#> MLTPL__2[5]="0.147016806157"/5 #> E_MP2="-188.528643358429"/8 #> HF_REF_WEIGHT="0.889110030624"/8 #>> 193 @@ -1646,26 +1646,26 @@ #> SCF_ITER="7"/8 #> E_SCF="-188.283810287460"/8 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="0.848545024323"/5 -#> MLTPL__1[1]="0.200981953352"/5 +#> MLTPL__1[0]="0.848545024321"/5 +#> MLTPL__1[1]="0.200981953351"/5 #> MLTPL__1[2]="0.000927913748"/5 -#> MLTPL__2[0]="-2.080401675611"/5 -#> MLTPL__2[1]="-0.494566793879"/5 +#> MLTPL__2[0]="-2.080401675601"/5 +#> MLTPL__2[1]="-0.494566793877"/5 #> MLTPL__2[2]="-0.000326042038"/5 -#> MLTPL__2[3]="1.884452535957"/5 -#> MLTPL__2[4]="-0.000668143498"/5 -#> MLTPL__2[5]="0.195949139654"/5 +#> MLTPL__2[3]="1.884452535952"/5 +#> MLTPL__2[4]="-0.000668143499"/5 +#> MLTPL__2[5]="0.195949139649"/5 #>> 199 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="0.635143504535"/5 -#> MLTPL__1[1]="0.133640451893"/5 +#> MLTPL__1[0]="0.635143504533"/5 +#> MLTPL__1[1]="0.133640451892"/5 #> MLTPL__1[2]="0.000846836400"/5 -#> MLTPL__2[0]="-1.751988563904"/5 -#> MLTPL__2[1]="-0.403308357874"/5 +#> MLTPL__2[0]="-1.751988563895"/5 +#> MLTPL__2[1]="-0.403308357872"/5 #> MLTPL__2[2]="-0.000192499465"/5 -#> MLTPL__2[3]="1.604965770517"/5 +#> MLTPL__2[3]="1.604965770513"/5 #> MLTPL__2[4]="-0.000707771512"/5 -#> MLTPL__2[5]="0.147022793387"/5 +#> MLTPL__2[5]="0.147022793382"/5 #> E_MP2="-188.528643317486"/8 #> HF_REF_WEIGHT="0.889110053001"/8 #>> 200 @@ -1679,7 +1679,7 @@ #> GRAD[7]="-0.005680084342"/6 #> GRAD[8]="0.000419286958"/6 #> GRAD[9]="-0.016277867115"/6 -#> GRAD[10]="-0.001663273066"/6 +#> GRAD[10]="-0.001663273065"/6 #> GRAD[11]="-0.000189279468"/6 #> GRAD[12]="-0.001218964777"/6 #> GRAD[13]="-0.021802626027"/6 @@ -1704,26 +1704,26 @@ #> SCF_ITER="7"/8 #> E_SCF="-188.283860651230"/8 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="0.851241330612"/5 +#> MLTPL__1[0]="0.851241330613"/5 #> MLTPL__1[1]="0.197394063559"/5 #> MLTPL__1[2]="0.000000295488"/5 -#> MLTPL__2[0]="-2.091571347481"/5 -#> MLTPL__2[1]="-0.474966441983"/5 +#> MLTPL__2[0]="-2.091571347488"/5 +#> MLTPL__2[1]="-0.474966441984"/5 #> MLTPL__2[2]="-0.000003151669"/5 -#> MLTPL__2[3]="1.891474907342"/5 +#> MLTPL__2[3]="1.891474907345"/5 #> MLTPL__2[4]="0.000005277511"/5 -#> MLTPL__2[5]="0.200096440139"/5 +#> MLTPL__2[5]="0.200096440143"/5 #>> 206 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.636900756077"/5 #> MLTPL__1[1]="0.130633398760"/5 #> MLTPL__1[2]="0.000000236929"/5 -#> MLTPL__2[0]="-1.760960101763"/5 +#> MLTPL__2[0]="-1.760960101769"/5 #> MLTPL__2[1]="-0.387463498920"/5 #> MLTPL__2[2]="-0.000003928917"/5 -#> MLTPL__2[3]="1.610681283771"/5 +#> MLTPL__2[3]="1.610681283774"/5 #> MLTPL__2[4]="0.000006146494"/5 -#> MLTPL__2[5]="0.150278817992"/5 +#> MLTPL__2[5]="0.150278817995"/5 #> E_MP2="-188.528634644793"/8 #> HF_REF_WEIGHT="0.889161223496"/8 #>> 207 @@ -1767,7 +1767,7 @@ #> MLTPL__1[2]="0.000000042847"/5 #> MLTPL__2[0]="-2.069068831166"/5 #> MLTPL__2[1]="-0.514144763006"/5 -#> MLTPL__2[2]="-0.000000368501"/5 +#> MLTPL__2[2]="-0.000000368500"/5 #> MLTPL__2[3]="1.877288199356"/5 #> MLTPL__2[4]="-0.000001223823"/5 #> MLTPL__2[5]="0.191780631810"/5 @@ -1823,21 +1823,21 @@ #> MLTPL__1[0]="0.848551040446"/5 #> MLTPL__1[1]="0.200984049483"/5 #> MLTPL__1[2]="-0.000641204540"/5 -#> MLTPL__2[0]="-2.080381834754"/5 -#> MLTPL__2[1]="-0.494563797188"/5 +#> MLTPL__2[0]="-2.080381834755"/5 +#> MLTPL__2[1]="-0.494563797189"/5 #> MLTPL__2[2]="-0.007041696899"/5 -#> MLTPL__2[3]="1.884437287493"/5 +#> MLTPL__2[3]="1.884437287494"/5 #> MLTPL__2[4]="0.001009457819"/5 #> MLTPL__2[5]="0.195944547261"/5 #>> 220 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.635145148720"/5 -#> MLTPL__1[1]="0.133641259531"/5 +#> MLTPL__1[1]="0.133641259530"/5 #> MLTPL__1[2]="-0.000628974027"/5 -#> MLTPL__2[0]="-1.751971895643"/5 +#> MLTPL__2[0]="-1.751971895644"/5 #> MLTPL__2[1]="-0.403305745171"/5 #> MLTPL__2[2]="-0.006423212551"/5 -#> MLTPL__2[3]="1.604952272011"/5 +#> MLTPL__2[3]="1.604952272012"/5 #> MLTPL__2[4]="0.000962959884"/5 #> MLTPL__2[5]="0.147019623632"/5 #> E_MP2="-188.528643319814"/8 @@ -1876,29 +1876,29 @@ #> SEWARD_ATTRACT="-39.857699919830"/5 #>> 226 #> SCF_ITER="7"/8 -#> E_SCF="-188.283810235009"/8 +#> E_SCF="-188.283810235008"/8 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="0.848568111203"/5 +#> MLTPL__1[0]="0.848568111201"/5 #> MLTPL__1[1]="0.200990333045"/5 #> MLTPL__1[2]="0.000638271151"/5 -#> MLTPL__2[0]="-2.080496995354"/5 -#> MLTPL__2[1]="-0.494584748419"/5 +#> MLTPL__2[0]="-2.080496995347"/5 +#> MLTPL__2[1]="-0.494584748418"/5 #> MLTPL__2[2]="0.007055300848"/5 -#> MLTPL__2[3]="1.884487912753"/5 +#> MLTPL__2[3]="1.884487912749"/5 #> MLTPL__2[4]="-0.001010405154"/5 -#> MLTPL__2[5]="0.196009082601"/5 +#> MLTPL__2[5]="0.196009082597"/5 #>> 227 #> MLTPL__0="-0.000000000000"/5 -#> MLTPL__1[0]="0.635158666315"/5 -#> MLTPL__1[1]="0.133646665965"/5 +#> MLTPL__1[0]="0.635158666314"/5 +#> MLTPL__1[1]="0.133646665964"/5 #> MLTPL__1[2]="0.000627102720"/5 -#> MLTPL__2[0]="-1.752071537743"/5 -#> MLTPL__2[1]="-0.403322976524"/5 +#> MLTPL__2[0]="-1.752071537737"/5 +#> MLTPL__2[1]="-0.403322976523"/5 #> MLTPL__2[2]="0.006431632502"/5 -#> MLTPL__2[3]="1.604995346447"/5 +#> MLTPL__2[3]="1.604995346444"/5 #> MLTPL__2[4]="-0.000962693483"/5 -#> MLTPL__2[5]="0.147076191296"/5 -#> E_MP2="-188.528642952277"/8 +#> MLTPL__2[5]="0.147076191293"/5 +#> E_MP2="-188.528642952276"/8 #> HF_REF_WEIGHT="0.889110230353"/8 #>> 228 #> GRAD[0]="0.034323503775"/6 @@ -1939,7 +1939,7 @@ #> MLTPL__1[0]="0.848550298327"/5 #> MLTPL__1[1]="0.200983690555"/5 #> MLTPL__1[2]="-0.001302554903"/5 -#> MLTPL__2[0]="-2.080378073157"/5 +#> MLTPL__2[0]="-2.080378073158"/5 #> MLTPL__2[1]="-0.494565440612"/5 #> MLTPL__2[2]="0.014859473284"/5 #> MLTPL__2[3]="1.884448702174"/5 @@ -1992,29 +1992,29 @@ #> SEWARD_ATTRACT="-39.857699726221"/5 #>> 240 #> SCF_ITER="8"/8 -#> E_SCF="-188.283810608811"/8 +#> E_SCF="-188.283810608810"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.848549959540"/5 #> MLTPL__1[1]="0.200983571576"/5 #> MLTPL__1[2]="0.001302939331"/5 -#> MLTPL__2[0]="-2.080381804244"/5 +#> MLTPL__2[0]="-2.080381804243"/5 #> MLTPL__2[1]="-0.494566218846"/5 #> MLTPL__2[2]="-0.014862861988"/5 -#> MLTPL__2[3]="1.884450510671"/5 +#> MLTPL__2[3]="1.884450510670"/5 #> MLTPL__2[4]="-0.000735359684"/5 -#> MLTPL__2[5]="0.195931293573"/5 +#> MLTPL__2[5]="0.195931293572"/5 #>> 241 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.635144806353"/5 -#> MLTPL__1[1]="0.133640979694"/5 +#> MLTPL__1[1]="0.133640979693"/5 #> MLTPL__1[2]="0.000926111320"/5 -#> MLTPL__2[0]="-1.751968703021"/5 +#> MLTPL__2[0]="-1.751968703020"/5 #> MLTPL__2[1]="-0.403305909917"/5 #> MLTPL__2[2]="-0.012881013204"/5 -#> MLTPL__2[3]="1.604962602428"/5 +#> MLTPL__2[3]="1.604962602427"/5 #> MLTPL__2[4]="-0.000752677104"/5 -#> MLTPL__2[5]="0.147006100594"/5 -#> E_MP2="-188.528643562109"/8 +#> MLTPL__2[5]="0.147006100593"/5 +#> E_MP2="-188.528643562108"/8 #> HF_REF_WEIGHT="0.889110148095"/8 #>> 242 #> GRAD[0]="0.034323474735"/6 @@ -2050,13 +2050,13 @@ #> SEWARD_ATTRACT="-39.857698582777"/5 #>> 247 #> SCF_ITER="9"/8 -#> E_SCF="-188.283810219664"/8 +#> E_SCF="-188.283810219665"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.848550284099"/5 #> MLTPL__1[1]="0.200982036160"/5 #> MLTPL__1[2]="-0.001264958496"/5 #> MLTPL__2[0]="-2.080391133845"/5 -#> MLTPL__2[1]="-0.494556992194"/5 +#> MLTPL__2[1]="-0.494556992195"/5 #> MLTPL__2[2]="0.005752742332"/5 #> MLTPL__2[3]="1.884442830688"/5 #> MLTPL__2[4]="0.003835717417"/5 @@ -2064,15 +2064,15 @@ #>> 248 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.635146302234"/5 -#> MLTPL__1[1]="0.133640194168"/5 +#> MLTPL__1[1]="0.133640194167"/5 #> MLTPL__1[2]="-0.000990320400"/5 -#> MLTPL__2[0]="-1.751981042536"/5 +#> MLTPL__2[0]="-1.751981042535"/5 #> MLTPL__2[1]="-0.403298653253"/5 #> MLTPL__2[2]="0.004657286248"/5 #> MLTPL__2[3]="1.604958590018"/5 #> MLTPL__2[4]="0.004085791779"/5 -#> MLTPL__2[5]="0.147022452517"/5 -#> E_MP2="-188.528643166559"/8 +#> MLTPL__2[5]="0.147022452518"/5 +#> E_MP2="-188.528643166560"/8 #> HF_REF_WEIGHT="0.889110133101"/8 #>> 249 #> GRAD[0]="0.034322909303"/6 @@ -2111,25 +2111,25 @@ #> E_SCF="-188.283810219513"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.848548591514"/5 -#> MLTPL__1[1]="0.200981318013"/5 +#> MLTPL__1[1]="0.200981318014"/5 #> MLTPL__1[2]="0.001267565952"/5 #> MLTPL__2[0]="-2.080407857476"/5 #> MLTPL__2[1]="-0.494560298666"/5 #> MLTPL__2[2]="-0.005764255908"/5 -#> MLTPL__2[3]="1.884450772942"/5 +#> MLTPL__2[3]="1.884450772941"/5 #> MLTPL__2[4]="-0.003840183325"/5 -#> MLTPL__2[5]="0.195957084534"/5 +#> MLTPL__2[5]="0.195957084535"/5 #>> 255 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.635145707925"/5 #> MLTPL__1[1]="0.133639777102"/5 #> MLTPL__1[2]="0.000992566857"/5 -#> MLTPL__2[0]="-1.751994933334"/5 +#> MLTPL__2[0]="-1.751994933335"/5 #> MLTPL__2[1]="-0.403301321161"/5 #> MLTPL__2[2]="-0.004666946174"/5 #> MLTPL__2[3]="1.604965277193"/5 #> MLTPL__2[4]="-0.004089459630"/5 -#> MLTPL__2[5]="0.147029656141"/5 +#> MLTPL__2[5]="0.147029656142"/5 #> E_MP2="-188.528643098346"/8 #> HF_REF_WEIGHT="0.889110190704"/8 #>> 256 @@ -2137,7 +2137,7 @@ #> GRAD[1]="0.017271935692"/6 #> GRAD[2]="0.000019334331"/6 #> GRAD[3]="-0.086052065330"/6 -#> GRAD[4]="0.011710316870"/6 +#> GRAD[4]="0.011710316871"/6 #> GRAD[5]="0.000032097590"/6 #> GRAD[6]="0.102037057740"/6 #> GRAD[7]="-0.005680041444"/6 @@ -2163,53 +2163,53 @@ #> NUMERICAL_HESSIAN[2]="0.045002931354"/2 #> NUMERICAL_HESSIAN[3]="-0.020242290588"/2 #> NUMERICAL_HESSIAN[4]="0.003180589708"/2 -#> NUMERICAL_HESSIAN[5]="0.001853922737"/2 -#> NUMERICAL_HESSIAN[6]="-0.014847190840"/2 -#> NUMERICAL_HESSIAN[7]="-0.019807319559"/2 -#> NUMERICAL_HESSIAN[8]="0.004264787386"/2 +#> NUMERICAL_HESSIAN[5]="0.001853922739"/2 +#> NUMERICAL_HESSIAN[6]="-0.014847190839"/2 +#> NUMERICAL_HESSIAN[7]="-0.019798624750"/2 +#> NUMERICAL_HESSIAN[8]="0.004264783519"/2 #> NUMERICAL_HESSIAN[9]="0.109553025904"/2 -#> NUMERICAL_HESSIAN[10]="-0.076089181322"/2 -#> NUMERICAL_HESSIAN[11]="0.071272265322"/2 +#> NUMERICAL_HESSIAN[10]="-0.076089181321"/2 +#> NUMERICAL_HESSIAN[11]="0.071272265323"/2 #> NUMERICAL_HESSIAN[12]="-0.000000657816"/2 -#> NUMERICAL_HESSIAN[13]="-0.000000149112"/2 +#> NUMERICAL_HESSIAN[13]="-0.000000149113"/2 #> NUMERICAL_HESSIAN[14]="0.014440174200"/2 -#> NUMERICAL_HESSIAN[15]="0.000000340782"/2 +#> NUMERICAL_HESSIAN[15]="0.000000340781"/2 #> NUMERICAL_HESSIAN[16]="-0.000001208029"/2 #> NUMERICAL_HESSIAN[17]="-0.000001328364"/2 #> NUMERICAL_HESSIAN[18]="0.030387063210"/2 #> NUMERICAL_HESSIAN[19]="0.443722609830"/2 #> NUMERICAL_HESSIAN[20]="0.032480902995"/2 #> NUMERICAL_HESSIAN[21]="0.017076674532"/2 -#> NUMERICAL_HESSIAN[22]="0.002196911376"/2 +#> NUMERICAL_HESSIAN[22]="0.002196911375"/2 #> NUMERICAL_HESSIAN[23]="0.007812640145"/2 #> NUMERICAL_HESSIAN[24]="0.015976171304"/2 -#> NUMERICAL_HESSIAN[25]="0.002884764304"/2 -#> NUMERICAL_HESSIAN[26]="-0.041953519892"/2 +#> NUMERICAL_HESSIAN[25]="0.002873829873"/2 +#> NUMERICAL_HESSIAN[26]="-0.041953520103"/2 #> NUMERICAL_HESSIAN[27]="-0.060131834598"/2 -#> NUMERICAL_HESSIAN[28]="-0.122221253997"/2 +#> NUMERICAL_HESSIAN[28]="-0.122221253996"/2 #> NUMERICAL_HESSIAN[29]="-0.002319575329"/2 #> NUMERICAL_HESSIAN[30]="-0.000000247100"/2 -#> NUMERICAL_HESSIAN[31]="0.000001059029"/2 -#> NUMERICAL_HESSIAN[32]="0.047588540389"/2 +#> NUMERICAL_HESSIAN[31]="0.000001059028"/2 +#> NUMERICAL_HESSIAN[32]="0.047588540388"/2 #> NUMERICAL_HESSIAN[33]="0.000003957356"/2 #> NUMERICAL_HESSIAN[34]="0.000002391023"/2 #> NUMERICAL_HESSIAN[35]="0.000003356467"/2 #> NUMERICAL_HESSIAN[36]="0.045002931354"/2 #> NUMERICAL_HESSIAN[37]="0.032480902995"/2 -#> NUMERICAL_HESSIAN[38]="0.474013218570"/2 +#> NUMERICAL_HESSIAN[38]="0.474013218569"/2 #> NUMERICAL_HESSIAN[39]="-0.007636259946"/2 -#> NUMERICAL_HESSIAN[40]="-0.019770275094"/2 -#> NUMERICAL_HESSIAN[41]="0.052942816276"/2 -#> NUMERICAL_HESSIAN[42]="0.046064484820"/2 -#> NUMERICAL_HESSIAN[43]="0.041939004112"/2 -#> NUMERICAL_HESSIAN[44]="0.127090620691"/2 -#> NUMERICAL_HESSIAN[45]="-0.025087274817"/2 -#> NUMERICAL_HESSIAN[46]="0.005676725397"/2 -#> NUMERICAL_HESSIAN[47]="0.029992867610"/2 -#> NUMERICAL_HESSIAN[48]="0.000010027561"/2 -#> NUMERICAL_HESSIAN[49]="0.000001556617"/2 +#> NUMERICAL_HESSIAN[40]="-0.019770275093"/2 +#> NUMERICAL_HESSIAN[41]="0.052942816277"/2 +#> NUMERICAL_HESSIAN[42]="0.046064484821"/2 +#> NUMERICAL_HESSIAN[43]="0.041926944667"/2 +#> NUMERICAL_HESSIAN[44]="0.127090622398"/2 +#> NUMERICAL_HESSIAN[45]="-0.025087274818"/2 +#> NUMERICAL_HESSIAN[46]="0.005676725396"/2 +#> NUMERICAL_HESSIAN[47]="0.029992867611"/2 +#> NUMERICAL_HESSIAN[48]="0.000010027562"/2 +#> NUMERICAL_HESSIAN[49]="0.000001556615"/2 #> NUMERICAL_HESSIAN[50]="0.031638951744"/2 -#> NUMERICAL_HESSIAN[51]="0.000004061121"/2 +#> NUMERICAL_HESSIAN[51]="0.000004061120"/2 #> NUMERICAL_HESSIAN[52]="0.000004859305"/2 #> NUMERICAL_HESSIAN[53]="0.000008161393"/2 #> NUMERICAL_HESSIAN[54]="-0.020242290588"/2 @@ -2219,10 +2219,10 @@ #> NUMERICAL_HESSIAN[58]="-0.016538129162"/2 #> NUMERICAL_HESSIAN[59]="-0.051298421312"/2 #> NUMERICAL_HESSIAN[60]="-0.016682444386"/2 -#> NUMERICAL_HESSIAN[61]="0.047935005254"/2 -#> NUMERICAL_HESSIAN[62]="0.012557030918"/2 +#> NUMERICAL_HESSIAN[61]="0.047934837351"/2 +#> NUMERICAL_HESSIAN[62]="0.012557030845"/2 #> NUMERICAL_HESSIAN[63]="0.068611728078"/2 -#> NUMERICAL_HESSIAN[64]="-0.021464901738"/2 +#> NUMERICAL_HESSIAN[64]="-0.021464901739"/2 #> NUMERICAL_HESSIAN[65]="-0.059186541911"/2 #> NUMERICAL_HESSIAN[66]="-0.000006640940"/2 #> NUMERICAL_HESSIAN[67]="-0.000000056534"/2 @@ -2231,152 +2231,152 @@ #> NUMERICAL_HESSIAN[70]="-0.000001179135"/2 #> NUMERICAL_HESSIAN[71]="-0.000002990099"/2 #> NUMERICAL_HESSIAN[72]="0.003180589708"/2 -#> NUMERICAL_HESSIAN[73]="0.002196911376"/2 -#> NUMERICAL_HESSIAN[74]="-0.019770275094"/2 +#> NUMERICAL_HESSIAN[73]="0.002196911375"/2 +#> NUMERICAL_HESSIAN[74]="-0.019770275093"/2 #> NUMERICAL_HESSIAN[75]="-0.016538129162"/2 #> NUMERICAL_HESSIAN[76]="0.460735447482"/2 #> NUMERICAL_HESSIAN[77]="0.010627876226"/2 #> NUMERICAL_HESSIAN[78]="0.028944011217"/2 -#> NUMERICAL_HESSIAN[79]="0.021055521551"/2 -#> NUMERICAL_HESSIAN[80]="0.075630496919"/2 +#> NUMERICAL_HESSIAN[79]="0.021055589276"/2 +#> NUMERICAL_HESSIAN[80]="0.075630505745"/2 #> NUMERICAL_HESSIAN[81]="-0.009062113852"/2 #> NUMERICAL_HESSIAN[82]="-0.051351678742"/2 #> NUMERICAL_HESSIAN[83]="0.005204986779"/2 #> NUMERICAL_HESSIAN[84]="-0.000007468246"/2 -#> NUMERICAL_HESSIAN[85]="0.000000470604"/2 -#> NUMERICAL_HESSIAN[86]="-0.012714101743"/2 -#> NUMERICAL_HESSIAN[87]="-0.000005113483"/2 -#> NUMERICAL_HESSIAN[88]="-0.000000449761"/2 -#> NUMERICAL_HESSIAN[89]="-0.000006722684"/2 -#> NUMERICAL_HESSIAN[90]="0.001853922737"/2 +#> NUMERICAL_HESSIAN[85]="0.000000470605"/2 +#> NUMERICAL_HESSIAN[86]="-0.012714101744"/2 +#> NUMERICAL_HESSIAN[87]="-0.000005113482"/2 +#> NUMERICAL_HESSIAN[88]="-0.000000449762"/2 +#> NUMERICAL_HESSIAN[89]="-0.000006722683"/2 +#> NUMERICAL_HESSIAN[90]="0.001853922739"/2 #> NUMERICAL_HESSIAN[91]="0.007812640145"/2 -#> NUMERICAL_HESSIAN[92]="0.052942816276"/2 +#> NUMERICAL_HESSIAN[92]="0.052942816277"/2 #> NUMERICAL_HESSIAN[93]="-0.051298421312"/2 #> NUMERICAL_HESSIAN[94]="0.010627876226"/2 #> NUMERICAL_HESSIAN[95]="0.482350851015"/2 -#> NUMERICAL_HESSIAN[96]="0.042531332352"/2 -#> NUMERICAL_HESSIAN[97]="0.136837341134"/2 -#> NUMERICAL_HESSIAN[98]="0.002221718789"/2 +#> NUMERICAL_HESSIAN[96]="0.042531332351"/2 +#> NUMERICAL_HESSIAN[97]="0.136833134767"/2 +#> NUMERICAL_HESSIAN[98]="0.002221703373"/2 #> NUMERICAL_HESSIAN[99]="0.018935811618"/2 #> NUMERICAL_HESSIAN[100]="0.038873220389"/2 #> NUMERICAL_HESSIAN[101]="0.062496310193"/2 #> NUMERICAL_HESSIAN[102]="-0.000003071159"/2 -#> NUMERICAL_HESSIAN[103]="-0.000002916186"/2 -#> NUMERICAL_HESSIAN[104]="0.005177006017"/2 -#> NUMERICAL_HESSIAN[105]="-0.000010337739"/2 +#> NUMERICAL_HESSIAN[103]="-0.000002916184"/2 +#> NUMERICAL_HESSIAN[104]="0.005177006018"/2 +#> NUMERICAL_HESSIAN[105]="-0.000010337738"/2 #> NUMERICAL_HESSIAN[106]="-0.000003092398"/2 #> NUMERICAL_HESSIAN[107]="0.000000395911"/2 -#> NUMERICAL_HESSIAN[108]="-0.014847190840"/2 +#> NUMERICAL_HESSIAN[108]="-0.014847190839"/2 #> NUMERICAL_HESSIAN[109]="0.015976171304"/2 -#> NUMERICAL_HESSIAN[110]="0.046064484820"/2 +#> NUMERICAL_HESSIAN[110]="0.046064484821"/2 #> NUMERICAL_HESSIAN[111]="-0.016682444386"/2 #> NUMERICAL_HESSIAN[112]="0.028944011217"/2 -#> NUMERICAL_HESSIAN[113]="0.042531332352"/2 -#> NUMERICAL_HESSIAN[114]="0.511969322444"/2 -#> NUMERICAL_HESSIAN[115]="0.004022002734"/2 -#> NUMERICAL_HESSIAN[116]="-0.010782058014"/2 -#> NUMERICAL_HESSIAN[117]="0.020791298596"/2 -#> NUMERICAL_HESSIAN[118]="0.115966545996"/2 +#> NUMERICAL_HESSIAN[113]="0.042531332351"/2 +#> NUMERICAL_HESSIAN[114]="0.511969322442"/2 +#> NUMERICAL_HESSIAN[115]="0.004047093040"/2 +#> NUMERICAL_HESSIAN[116]="-0.010782052920"/2 +#> NUMERICAL_HESSIAN[117]="0.020791298595"/2 +#> NUMERICAL_HESSIAN[118]="0.115966545995"/2 #> NUMERICAL_HESSIAN[119]="0.007000824461"/2 #> NUMERICAL_HESSIAN[120]="-0.000008296425"/2 -#> NUMERICAL_HESSIAN[121]="-0.000004364685"/2 -#> NUMERICAL_HESSIAN[122]="-0.024683355850"/2 -#> NUMERICAL_HESSIAN[123]="-0.000031519400"/2 -#> NUMERICAL_HESSIAN[124]="-0.000007297054"/2 -#> NUMERICAL_HESSIAN[125]="-0.000014086323"/2 -#> NUMERICAL_HESSIAN[126]="-0.019807319559"/2 -#> NUMERICAL_HESSIAN[127]="0.002884764304"/2 -#> NUMERICAL_HESSIAN[128]="0.041939004112"/2 -#> NUMERICAL_HESSIAN[129]="0.047935005254"/2 -#> NUMERICAL_HESSIAN[130]="0.021055521551"/2 -#> NUMERICAL_HESSIAN[131]="0.136837341134"/2 -#> NUMERICAL_HESSIAN[132]="0.004022002734"/2 -#> NUMERICAL_HESSIAN[133]="0.266630368120"/2 -#> NUMERICAL_HESSIAN[134]="0.022308702358"/2 -#> NUMERICAL_HESSIAN[135]="0.017794162006"/2 -#> NUMERICAL_HESSIAN[136]="-0.042179977017"/2 -#> NUMERICAL_HESSIAN[137]="-0.010658757553"/2 +#> NUMERICAL_HESSIAN[121]="-0.000004364678"/2 +#> NUMERICAL_HESSIAN[122]="-0.024683355849"/2 +#> NUMERICAL_HESSIAN[123]="-0.000031519399"/2 +#> NUMERICAL_HESSIAN[124]="-0.000007297055"/2 +#> NUMERICAL_HESSIAN[125]="-0.000014086324"/2 +#> NUMERICAL_HESSIAN[126]="-0.019798624750"/2 +#> NUMERICAL_HESSIAN[127]="0.002873829873"/2 +#> NUMERICAL_HESSIAN[128]="0.041926944667"/2 +#> NUMERICAL_HESSIAN[129]="0.047934837351"/2 +#> NUMERICAL_HESSIAN[130]="0.021055589276"/2 +#> NUMERICAL_HESSIAN[131]="0.136833134767"/2 +#> NUMERICAL_HESSIAN[132]="0.004047093040"/2 +#> NUMERICAL_HESSIAN[133]="0.266658704758"/2 +#> NUMERICAL_HESSIAN[134]="0.022308691748"/2 +#> NUMERICAL_HESSIAN[135]="0.017793062761"/2 +#> NUMERICAL_HESSIAN[136]="-0.042187786065"/2 +#> NUMERICAL_HESSIAN[137]="-0.010666982813"/2 #> NUMERICAL_HESSIAN[138]="0.000008812251"/2 -#> NUMERICAL_HESSIAN[139]="-0.000000980050"/2 -#> NUMERICAL_HESSIAN[140]="-0.002808903016"/2 +#> NUMERICAL_HESSIAN[139]="-0.000000980049"/2 +#> NUMERICAL_HESSIAN[140]="-0.002823363916"/2 #> NUMERICAL_HESSIAN[141]="-0.000007963456"/2 #> NUMERICAL_HESSIAN[142]="-0.000000897156"/2 -#> NUMERICAL_HESSIAN[143]="-0.000000078331"/2 -#> NUMERICAL_HESSIAN[144]="0.004264787386"/2 -#> NUMERICAL_HESSIAN[145]="-0.041953519892"/2 -#> NUMERICAL_HESSIAN[146]="0.127090620691"/2 -#> NUMERICAL_HESSIAN[147]="0.012557030918"/2 -#> NUMERICAL_HESSIAN[148]="0.075630496919"/2 -#> NUMERICAL_HESSIAN[149]="0.002221718789"/2 -#> NUMERICAL_HESSIAN[150]="-0.010782058014"/2 -#> NUMERICAL_HESSIAN[151]="0.022308702358"/2 -#> NUMERICAL_HESSIAN[152]="0.294423900447"/2 -#> NUMERICAL_HESSIAN[153]="-0.011537168586"/2 -#> NUMERICAL_HESSIAN[154]="0.051913164373"/2 -#> NUMERICAL_HESSIAN[155]="0.012840845705"/2 +#> NUMERICAL_HESSIAN[143]="-0.000000078332"/2 +#> NUMERICAL_HESSIAN[144]="0.004264783519"/2 +#> NUMERICAL_HESSIAN[145]="-0.041953520103"/2 +#> NUMERICAL_HESSIAN[146]="0.127090622398"/2 +#> NUMERICAL_HESSIAN[147]="0.012557030845"/2 +#> NUMERICAL_HESSIAN[148]="0.075630505745"/2 +#> NUMERICAL_HESSIAN[149]="0.002221703373"/2 +#> NUMERICAL_HESSIAN[150]="-0.010782052920"/2 +#> NUMERICAL_HESSIAN[151]="0.022308691748"/2 +#> NUMERICAL_HESSIAN[152]="0.294423903258"/2 +#> NUMERICAL_HESSIAN[153]="-0.011537169446"/2 +#> NUMERICAL_HESSIAN[154]="0.051913155626"/2 +#> NUMERICAL_HESSIAN[155]="0.012840838190"/2 #> NUMERICAL_HESSIAN[156]="-0.000003673729"/2 -#> NUMERICAL_HESSIAN[157]="-0.000000863433"/2 -#> NUMERICAL_HESSIAN[158]="-0.023533709045"/2 +#> NUMERICAL_HESSIAN[157]="-0.000000863432"/2 +#> NUMERICAL_HESSIAN[158]="-0.023533726718"/2 #> NUMERICAL_HESSIAN[159]="-0.000010897483"/2 #> NUMERICAL_HESSIAN[160]="-0.000000494745"/2 -#> NUMERICAL_HESSIAN[161]="-0.000002693971"/2 +#> NUMERICAL_HESSIAN[161]="-0.000002693972"/2 #> NUMERICAL_HESSIAN[162]="0.109553025904"/2 #> NUMERICAL_HESSIAN[163]="-0.060131834598"/2 -#> NUMERICAL_HESSIAN[164]="-0.025087274817"/2 +#> NUMERICAL_HESSIAN[164]="-0.025087274818"/2 #> NUMERICAL_HESSIAN[165]="0.068611728078"/2 #> NUMERICAL_HESSIAN[166]="-0.009062113852"/2 #> NUMERICAL_HESSIAN[167]="0.018935811618"/2 -#> NUMERICAL_HESSIAN[168]="0.020791298596"/2 -#> NUMERICAL_HESSIAN[169]="0.017794162006"/2 -#> NUMERICAL_HESSIAN[170]="-0.011537168586"/2 -#> NUMERICAL_HESSIAN[171]="0.261671557719"/2 +#> NUMERICAL_HESSIAN[168]="0.020791298595"/2 +#> NUMERICAL_HESSIAN[169]="0.017793062761"/2 +#> NUMERICAL_HESSIAN[170]="-0.011537169446"/2 +#> NUMERICAL_HESSIAN[171]="0.261671557718"/2 #> NUMERICAL_HESSIAN[172]="0.017656908164"/2 #> NUMERICAL_HESSIAN[173]="0.019812122435"/2 #> NUMERICAL_HESSIAN[174]="0.000001660613"/2 -#> NUMERICAL_HESSIAN[175]="0.000000425084"/2 +#> NUMERICAL_HESSIAN[175]="0.000000425083"/2 #> NUMERICAL_HESSIAN[176]="-0.014722210388"/2 #> NUMERICAL_HESSIAN[177]="0.000005701832"/2 #> NUMERICAL_HESSIAN[178]="-0.000000156891"/2 #> NUMERICAL_HESSIAN[179]="0.000000581331"/2 -#> NUMERICAL_HESSIAN[180]="-0.076089181322"/2 -#> NUMERICAL_HESSIAN[181]="-0.122221253997"/2 -#> NUMERICAL_HESSIAN[182]="0.005676725397"/2 -#> NUMERICAL_HESSIAN[183]="-0.021464901738"/2 +#> NUMERICAL_HESSIAN[180]="-0.076089181321"/2 +#> NUMERICAL_HESSIAN[181]="-0.122221253996"/2 +#> NUMERICAL_HESSIAN[182]="0.005676725396"/2 +#> NUMERICAL_HESSIAN[183]="-0.021464901739"/2 #> NUMERICAL_HESSIAN[184]="-0.051351678742"/2 #> NUMERICAL_HESSIAN[185]="0.038873220389"/2 -#> NUMERICAL_HESSIAN[186]="0.115966545996"/2 -#> NUMERICAL_HESSIAN[187]="-0.042179977017"/2 -#> NUMERICAL_HESSIAN[188]="0.051913164373"/2 +#> NUMERICAL_HESSIAN[186]="0.115966545995"/2 +#> NUMERICAL_HESSIAN[187]="-0.042187786065"/2 +#> NUMERICAL_HESSIAN[188]="0.051913155626"/2 #> NUMERICAL_HESSIAN[189]="0.017656908164"/2 -#> NUMERICAL_HESSIAN[190]="0.329765545294"/2 +#> NUMERICAL_HESSIAN[190]="0.329765545295"/2 #> NUMERICAL_HESSIAN[191]="0.018341869383"/2 #> NUMERICAL_HESSIAN[192]="-0.000018493498"/2 -#> NUMERICAL_HESSIAN[193]="-0.000002014065"/2 -#> NUMERICAL_HESSIAN[194]="-0.042213048817"/2 -#> NUMERICAL_HESSIAN[195]="-0.000010464532"/2 +#> NUMERICAL_HESSIAN[193]="-0.000002014063"/2 +#> NUMERICAL_HESSIAN[194]="-0.042213048816"/2 +#> NUMERICAL_HESSIAN[195]="-0.000010464531"/2 #> NUMERICAL_HESSIAN[196]="-0.000003297043"/2 #> NUMERICAL_HESSIAN[197]="-0.000005594600"/2 -#> NUMERICAL_HESSIAN[198]="0.071272265322"/2 +#> NUMERICAL_HESSIAN[198]="0.071272265323"/2 #> NUMERICAL_HESSIAN[199]="-0.002319575329"/2 -#> NUMERICAL_HESSIAN[200]="0.029992867610"/2 +#> NUMERICAL_HESSIAN[200]="0.029992867611"/2 #> NUMERICAL_HESSIAN[201]="-0.059186541911"/2 #> NUMERICAL_HESSIAN[202]="0.005204986779"/2 #> NUMERICAL_HESSIAN[203]="0.062496310193"/2 #> NUMERICAL_HESSIAN[204]="0.007000824461"/2 -#> NUMERICAL_HESSIAN[205]="-0.010658757553"/2 -#> NUMERICAL_HESSIAN[206]="0.012840845705"/2 +#> NUMERICAL_HESSIAN[205]="-0.010666982813"/2 +#> NUMERICAL_HESSIAN[206]="0.012840838190"/2 #> NUMERICAL_HESSIAN[207]="0.019812122435"/2 #> NUMERICAL_HESSIAN[208]="0.018341869383"/2 #> NUMERICAL_HESSIAN[209]="0.163399355408"/2 #> NUMERICAL_HESSIAN[210]="-0.000014411037"/2 #> NUMERICAL_HESSIAN[211]="-0.000000550218"/2 -#> NUMERICAL_HESSIAN[212]="0.001282147884"/2 +#> NUMERICAL_HESSIAN[212]="0.001282147883"/2 #> NUMERICAL_HESSIAN[213]="-0.000001765250"/2 -#> NUMERICAL_HESSIAN[214]="-0.000000783272"/2 +#> NUMERICAL_HESSIAN[214]="-0.000000783273"/2 #> NUMERICAL_HESSIAN[215]="-0.000001036143"/2 #> NUMERICAL_HESSIAN[216]="-0.000000657816"/2 #> NUMERICAL_HESSIAN[217]="-0.000000247100"/2 -#> NUMERICAL_HESSIAN[218]="0.000010027561"/2 +#> NUMERICAL_HESSIAN[218]="0.000010027562"/2 #> NUMERICAL_HESSIAN[219]="-0.000006640940"/2 #> NUMERICAL_HESSIAN[220]="-0.000007468246"/2 #> NUMERICAL_HESSIAN[221]="-0.000003071159"/2 @@ -2388,118 +2388,118 @@ #> NUMERICAL_HESSIAN[227]="-0.000014411037"/2 #> NUMERICAL_HESSIAN[228]="0.020483611017"/2 #> NUMERICAL_HESSIAN[229]="0.005743677097"/2 -#> NUMERICAL_HESSIAN[230]="-0.000020735106"/2 +#> NUMERICAL_HESSIAN[230]="-0.000020735107"/2 #> NUMERICAL_HESSIAN[231]="-0.000996012340"/2 #> NUMERICAL_HESSIAN[232]="-0.000111176753"/2 #> NUMERICAL_HESSIAN[233]="0.000904755586"/2 -#> NUMERICAL_HESSIAN[234]="-0.000000149112"/2 -#> NUMERICAL_HESSIAN[235]="0.000001059029"/2 -#> NUMERICAL_HESSIAN[236]="0.000001556617"/2 +#> NUMERICAL_HESSIAN[234]="-0.000000149113"/2 +#> NUMERICAL_HESSIAN[235]="0.000001059028"/2 +#> NUMERICAL_HESSIAN[236]="0.000001556615"/2 #> NUMERICAL_HESSIAN[237]="-0.000000056534"/2 -#> NUMERICAL_HESSIAN[238]="0.000000470604"/2 -#> NUMERICAL_HESSIAN[239]="-0.000002916186"/2 -#> NUMERICAL_HESSIAN[240]="-0.000004364685"/2 -#> NUMERICAL_HESSIAN[241]="-0.000000980050"/2 -#> NUMERICAL_HESSIAN[242]="-0.000000863433"/2 -#> NUMERICAL_HESSIAN[243]="0.000000425084"/2 -#> NUMERICAL_HESSIAN[244]="-0.000002014065"/2 +#> NUMERICAL_HESSIAN[238]="0.000000470605"/2 +#> NUMERICAL_HESSIAN[239]="-0.000002916184"/2 +#> NUMERICAL_HESSIAN[240]="-0.000004364678"/2 +#> NUMERICAL_HESSIAN[241]="-0.000000980049"/2 +#> NUMERICAL_HESSIAN[242]="-0.000000863432"/2 +#> NUMERICAL_HESSIAN[243]="0.000000425083"/2 +#> NUMERICAL_HESSIAN[244]="-0.000002014063"/2 #> NUMERICAL_HESSIAN[245]="-0.000000550218"/2 #> NUMERICAL_HESSIAN[246]="0.005743677097"/2 #> NUMERICAL_HESSIAN[247]="0.022602870108"/2 -#> NUMERICAL_HESSIAN[248]="-0.000001283789"/2 +#> NUMERICAL_HESSIAN[248]="-0.000001283790"/2 #> NUMERICAL_HESSIAN[249]="-0.002673902632"/2 #> NUMERICAL_HESSIAN[250]="-0.003814670415"/2 #> NUMERICAL_HESSIAN[251]="0.000589234408"/2 #> NUMERICAL_HESSIAN[252]="0.014440174200"/2 -#> NUMERICAL_HESSIAN[253]="0.047588540389"/2 +#> NUMERICAL_HESSIAN[253]="0.047588540388"/2 #> NUMERICAL_HESSIAN[254]="0.031638951744"/2 #> NUMERICAL_HESSIAN[255]="0.005240680625"/2 -#> NUMERICAL_HESSIAN[256]="-0.012714101743"/2 -#> NUMERICAL_HESSIAN[257]="0.005177006017"/2 -#> NUMERICAL_HESSIAN[258]="-0.024683355850"/2 -#> NUMERICAL_HESSIAN[259]="-0.002808903016"/2 -#> NUMERICAL_HESSIAN[260]="-0.023533709045"/2 +#> NUMERICAL_HESSIAN[256]="-0.012714101744"/2 +#> NUMERICAL_HESSIAN[257]="0.005177006018"/2 +#> NUMERICAL_HESSIAN[258]="-0.024683355849"/2 +#> NUMERICAL_HESSIAN[259]="-0.002823363916"/2 +#> NUMERICAL_HESSIAN[260]="-0.023533726718"/2 #> NUMERICAL_HESSIAN[261]="-0.014722210388"/2 -#> NUMERICAL_HESSIAN[262]="-0.042213048817"/2 -#> NUMERICAL_HESSIAN[263]="0.001282147884"/2 -#> NUMERICAL_HESSIAN[264]="-0.000020735106"/2 -#> NUMERICAL_HESSIAN[265]="-0.000001283789"/2 -#> NUMERICAL_HESSIAN[266]="0.145853160555"/2 +#> NUMERICAL_HESSIAN[262]="-0.042213048816"/2 +#> NUMERICAL_HESSIAN[263]="0.001282147883"/2 +#> NUMERICAL_HESSIAN[264]="-0.000020735107"/2 +#> NUMERICAL_HESSIAN[265]="-0.000001283790"/2 +#> NUMERICAL_HESSIAN[266]="0.145853160554"/2 #> NUMERICAL_HESSIAN[267]="0.000000403736"/2 -#> NUMERICAL_HESSIAN[268]="-0.000001953180"/2 +#> NUMERICAL_HESSIAN[268]="-0.000001953181"/2 #> NUMERICAL_HESSIAN[269]="-0.000015016498"/2 -#> NUMERICAL_HESSIAN[270]="0.000000340782"/2 +#> NUMERICAL_HESSIAN[270]="0.000000340781"/2 #> NUMERICAL_HESSIAN[271]="0.000003957356"/2 -#> NUMERICAL_HESSIAN[272]="0.000004061121"/2 +#> NUMERICAL_HESSIAN[272]="0.000004061120"/2 #> NUMERICAL_HESSIAN[273]="0.000000553106"/2 -#> NUMERICAL_HESSIAN[274]="-0.000005113483"/2 -#> NUMERICAL_HESSIAN[275]="-0.000010337739"/2 -#> NUMERICAL_HESSIAN[276]="-0.000031519400"/2 +#> NUMERICAL_HESSIAN[274]="-0.000005113482"/2 +#> NUMERICAL_HESSIAN[275]="-0.000010337738"/2 +#> NUMERICAL_HESSIAN[276]="-0.000031519399"/2 #> NUMERICAL_HESSIAN[277]="-0.000007963456"/2 #> NUMERICAL_HESSIAN[278]="-0.000010897483"/2 #> NUMERICAL_HESSIAN[279]="0.000005701832"/2 -#> NUMERICAL_HESSIAN[280]="-0.000010464532"/2 +#> NUMERICAL_HESSIAN[280]="-0.000010464531"/2 #> NUMERICAL_HESSIAN[281]="-0.000001765250"/2 #> NUMERICAL_HESSIAN[282]="-0.000996012340"/2 #> NUMERICAL_HESSIAN[283]="-0.002673902632"/2 #> NUMERICAL_HESSIAN[284]="0.000000403736"/2 -#> NUMERICAL_HESSIAN[285]="0.023843567993"/2 -#> NUMERICAL_HESSIAN[286]="0.001359314585"/2 -#> NUMERICAL_HESSIAN[287]="-0.007040141543"/2 +#> NUMERICAL_HESSIAN[285]="0.023843567992"/2 +#> NUMERICAL_HESSIAN[286]="0.001359314586"/2 +#> NUMERICAL_HESSIAN[287]="-0.007040141542"/2 #> NUMERICAL_HESSIAN[288]="-0.000001208029"/2 #> NUMERICAL_HESSIAN[289]="0.000002391023"/2 #> NUMERICAL_HESSIAN[290]="0.000004859305"/2 #> NUMERICAL_HESSIAN[291]="-0.000001179135"/2 -#> NUMERICAL_HESSIAN[292]="-0.000000449761"/2 +#> NUMERICAL_HESSIAN[292]="-0.000000449762"/2 #> NUMERICAL_HESSIAN[293]="-0.000003092398"/2 -#> NUMERICAL_HESSIAN[294]="-0.000007297054"/2 +#> NUMERICAL_HESSIAN[294]="-0.000007297055"/2 #> NUMERICAL_HESSIAN[295]="-0.000000897156"/2 #> NUMERICAL_HESSIAN[296]="-0.000000494745"/2 #> NUMERICAL_HESSIAN[297]="-0.000000156891"/2 #> NUMERICAL_HESSIAN[298]="-0.000003297043"/2 -#> NUMERICAL_HESSIAN[299]="-0.000000783272"/2 +#> NUMERICAL_HESSIAN[299]="-0.000000783273"/2 #> NUMERICAL_HESSIAN[300]="-0.000111176753"/2 #> NUMERICAL_HESSIAN[301]="-0.003814670415"/2 -#> NUMERICAL_HESSIAN[302]="-0.000001953180"/2 -#> NUMERICAL_HESSIAN[303]="0.001359314585"/2 +#> NUMERICAL_HESSIAN[302]="-0.000001953181"/2 +#> NUMERICAL_HESSIAN[303]="0.001359314586"/2 #> NUMERICAL_HESSIAN[304]="0.017507667411"/2 -#> NUMERICAL_HESSIAN[305]="-0.012784638229"/2 +#> NUMERICAL_HESSIAN[305]="-0.012784638230"/2 #> NUMERICAL_HESSIAN[306]="-0.000001328364"/2 #> NUMERICAL_HESSIAN[307]="0.000003356467"/2 #> NUMERICAL_HESSIAN[308]="0.000008161393"/2 #> NUMERICAL_HESSIAN[309]="-0.000002990099"/2 -#> NUMERICAL_HESSIAN[310]="-0.000006722684"/2 +#> NUMERICAL_HESSIAN[310]="-0.000006722683"/2 #> NUMERICAL_HESSIAN[311]="0.000000395911"/2 -#> NUMERICAL_HESSIAN[312]="-0.000014086323"/2 -#> NUMERICAL_HESSIAN[313]="-0.000000078331"/2 -#> NUMERICAL_HESSIAN[314]="-0.000002693971"/2 +#> NUMERICAL_HESSIAN[312]="-0.000014086324"/2 +#> NUMERICAL_HESSIAN[313]="-0.000000078332"/2 +#> NUMERICAL_HESSIAN[314]="-0.000002693972"/2 #> NUMERICAL_HESSIAN[315]="0.000000581331"/2 #> NUMERICAL_HESSIAN[316]="-0.000005594600"/2 #> NUMERICAL_HESSIAN[317]="-0.000001036143"/2 #> NUMERICAL_HESSIAN[318]="0.000904755586"/2 #> NUMERICAL_HESSIAN[319]="0.000589234408"/2 #> NUMERICAL_HESSIAN[320]="-0.000015016498"/2 -#> NUMERICAL_HESSIAN[321]="-0.007040141543"/2 -#> NUMERICAL_HESSIAN[322]="-0.012784638229"/2 +#> NUMERICAL_HESSIAN[321]="-0.007040141542"/2 +#> NUMERICAL_HESSIAN[322]="-0.012784638230"/2 #> NUMERICAL_HESSIAN[323]="0.025852791462"/2 -#> NUMERICAL_IR_INTENSITIES[0]="0.642451892392"/2 -#> NUMERICAL_IR_INTENSITIES[1]="3.363958952016"/2 -#> NUMERICAL_IR_INTENSITIES[2]="3.170686996469"/2 -#> NUMERICAL_IR_INTENSITIES[3]="4.449445343789"/2 -#> NUMERICAL_IR_INTENSITIES[4]="15.306867872524"/2 -#> NUMERICAL_IR_INTENSITIES[5]="0.001527223738"/2 -#> NUMERICAL_IR_INTENSITIES[6]="3.632765403802"/2 -#> NUMERICAL_IR_INTENSITIES[7]="5.941279240521"/2 -#> NUMERICAL_IR_INTENSITIES[8]="12.562160104682"/2 -#> NUMERICAL_IR_INTENSITIES[9]="0.423502371820"/2 -#> NUMERICAL_IR_INTENSITIES[10]="2.116368437485"/2 -#> NUMERICAL_IR_INTENSITIES[11]="0.217199094596"/2 -#> NUMERICAL_IR_INTENSITIES[12]="2.203194205333"/2 -#> NUMERICAL_IR_INTENSITIES[13]="9.963450280351"/2 -#> NUMERICAL_IR_INTENSITIES[14]="15.716420075665"/2 -#> NUMERICAL_IR_INTENSITIES[15]="20.211724900770"/2 -#> NUMERICAL_IR_INTENSITIES[16]="1.897019699992"/2 -#> NUMERICAL_IR_INTENSITIES[17]="0.309812038161"/2 +#> NUMERICAL_IR_INTENSITIES[0]="0.642451892253"/2 +#> NUMERICAL_IR_INTENSITIES[1]="3.363655111426"/2 +#> NUMERICAL_IR_INTENSITIES[2]="3.170563108352"/2 +#> NUMERICAL_IR_INTENSITIES[3]="4.449445340029"/2 +#> NUMERICAL_IR_INTENSITIES[4]="15.306867868828"/2 +#> NUMERICAL_IR_INTENSITIES[5]="0.001527217398"/2 +#> NUMERICAL_IR_INTENSITIES[6]="3.632475536250"/2 +#> NUMERICAL_IR_INTENSITIES[7]="5.941279223996"/2 +#> NUMERICAL_IR_INTENSITIES[8]="12.558976535866"/2 +#> NUMERICAL_IR_INTENSITIES[9]="0.423393483453"/2 +#> NUMERICAL_IR_INTENSITIES[10]="2.116102829415"/2 +#> NUMERICAL_IR_INTENSITIES[11]="0.218274116830"/2 +#> NUMERICAL_IR_INTENSITIES[12]="2.204780771809"/2 +#> NUMERICAL_IR_INTENSITIES[13]="9.964166234529"/2 +#> NUMERICAL_IR_INTENSITIES[14]="15.713234700825"/2 +#> NUMERICAL_IR_INTENSITIES[15]="20.210357877180"/2 +#> NUMERICAL_IR_INTENSITIES[16]="1.898228949557"/2 +#> NUMERICAL_IR_INTENSITIES[17]="0.310075264640"/2 #>> 258 #>> 260 >>EOF diff -Nru openmolcas-22.02/test/standard/093.input openmolcas-22.10/test/standard/093.input --- openmolcas-22.02/test/standard/093.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/standard/093.input 2022-10-10 14:22:40.000000000 +0000 @@ -51,9 +51,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-943-g4c2682958 -* Linux lucifer 5.13.0-27-generic #29~20.04.1-Ubuntu SMP Fri Jan 14 00:32:30 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux -* Sat Feb 5 17:07:33 2022 +* Molcas version 22.02-260-gd39e60428 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Wed Apr 27 18:28:24 2022 * #>> 1 #> POTNUC="13.522136977422"/6 @@ -62,98 +62,98 @@ #> SEWARD_ATTRACT="-35.941520411926"/5 #>> 2 #> SCF_ITER="8"/8 -#> E_SCF="-40.515612956798"/8 -#> DFT_ENERGY="-5.597618868963"/6 -#> NQ_DENSITY="10.000007868873"/8 +#> E_SCF="-40.515612956788"/8 +#> DFT_ENERGY="-5.597618868956"/6 +#> NQ_DENSITY="10.000007868841"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="0.0"/5 +#> MLTPL__1[1]="0.000000000000"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.000004364287"/5 +#> MLTPL__2[0]="-0.000004364286"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="0.000008728574"/5 +#> MLTPL__2[3]="0.000008728571"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.000004364287"/5 +#> MLTPL__2[5]="-0.000004364286"/5 #>> 3 -#> GRAD[0]="-0.000000000000"/6 -#> GRAD[1]="-0.009563213793"/6 -#> GRAD[2]="0.006760367811"/6 -#> GRAD[3]="-0.006760367811"/6 -#> GRAD[4]="-0.009563213793"/6 +#> GRAD[0]="0.000000000000"/6 +#> GRAD[1]="-0.009563213821"/6 +#> GRAD[2]="0.006760367828"/6 +#> GRAD[3]="-0.006760367828"/6 +#> GRAD[4]="-0.009563213821"/6 #>> 4 #>> 6 -#> POTNUC="13.366523454001"/6 +#> POTNUC="13.366523453575"/6 #> SEWARD_MLTPL1X="0.077508834155"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.919028278696"/5 +#> SEWARD_ATTRACT="-35.919028278635"/5 #>> 7 #> SCF_ITER="7"/8 -#> E_SCF="-40.516302884977"/8 -#> DFT_ENERGY="-5.583296715272"/6 -#> NQ_DENSITY="10.000007957947"/8 +#> E_SCF="-40.516302884968"/8 +#> DFT_ENERGY="-5.583296715226"/6 +#> NQ_DENSITY="10.000007957914"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.000000000000"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.000025729722"/5 +#> MLTPL__2[0]="0.000025729757"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.000051459444"/5 +#> MLTPL__2[3]="-0.000051459515"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.000025729722"/5 +#> MLTPL__2[5]="0.000025729758"/5 #>> 8 #> GRAD[0]="-0.000000000000"/6 -#> GRAD[1]="-0.002344041683"/6 -#> GRAD[2]="0.001657696155"/6 -#> GRAD[3]="-0.001657696155"/6 -#> GRAD[4]="-0.002344041683"/6 +#> GRAD[1]="-0.002344041689"/6 +#> GRAD[2]="0.001657696161"/6 +#> GRAD[3]="-0.001657696161"/6 +#> GRAD[4]="-0.002344041689"/6 #>> 9 #>> 11 -#> POTNUC="13.314287353824"/6 +#> POTNUC="13.314287351353"/6 #> SEWARD_MLTPL1X="0.077508834155"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.911478153964"/5 +#> SEWARD_ATTRACT="-35.911478153607"/5 #>> 12 -#> SCF_ITER="5"/8 -#> E_SCF="-40.516349297963"/8 -#> DFT_ENERGY="-5.578461872565"/6 -#> NQ_DENSITY="10.000007936161"/8 +#> SCF_ITER="6"/8 +#> E_SCF="-40.516349298743"/8 +#> DFT_ENERGY="-5.578476790014"/6 +#> NQ_DENSITY="10.000007935931"/8 #> MLTPL__0="0.0"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="-0.000000000000"/5 +#> MLTPL__1[1]="0.000000000000"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.000021122584"/5 +#> MLTPL__2[0]="0.000021122364"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.000042245168"/5 +#> MLTPL__2[3]="-0.000042244730"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.000021122584"/5 +#> MLTPL__2[5]="0.000021122366"/5 #>> 13 #> GRAD[0]="0.000000000000"/6 -#> GRAD[1]="-0.000004998373"/6 -#> GRAD[2]="0.000003525350"/6 -#> GRAD[3]="-0.000003525350"/6 -#> GRAD[4]="-0.000004998373"/6 +#> GRAD[1]="0.000001936285"/6 +#> GRAD[2]="-0.000001378163"/6 +#> GRAD[3]="0.000001378163"/6 +#> GRAD[4]="0.000001936285"/6 #>> 14 #> GEO_ITER="3"/8 -#> POTNUC="13.314173864541"/6 +#> POTNUC="13.314330917082"/6 #> SEWARD_MLTPL1X="0.077508834155"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.911461750399"/5 +#> SEWARD_ATTRACT="-35.911484450530"/5 #> SCF_ITER="2"/8 -#> E_SCF="-40.516349298353"/8 -#> DFT_ENERGY="-5.578464459532"/6 -#> NQ_DENSITY="10.000007935919"/8 -#> MLTPL__0="-0.000000000000"/5 +#> E_SCF="-40.516349298774"/8 +#> DFT_ENERGY="-5.578481717034"/6 +#> NQ_DENSITY="10.000007935939"/8 +#> MLTPL__0="0.0"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.0"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.000021284071"/5 +#> MLTPL__2[0]="0.000021285980"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.000042568143"/5 +#> MLTPL__2[3]="-0.000042571960"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.000021284072"/5 +#> MLTPL__2[5]="0.000021285980"/5 #>> 15 >>EOF diff -Nru openmolcas-22.02/test/standard/096.input openmolcas-22.10/test/standard/096.input --- openmolcas-22.02/test/standard/096.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/standard/096.input 2022-10-10 14:22:40.000000000 +0000 @@ -31,9 +31,9 @@ >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-943-g4c2682958 -* Linux lucifer 5.13.0-27-generic #29~20.04.1-Ubuntu SMP Fri Jan 14 00:32:30 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux -* Sat Feb 5 17:07:33 2022 +* Molcas version 22.02-260-gd39e60428 +* Linux lucifer 5.13.0-40-generic #45~20.04.1-Ubuntu SMP Mon Apr 4 09:38:31 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Wed Apr 27 18:28:24 2022 * #>> 1 #> POTNUC="13.522136977422"/12 @@ -44,25 +44,25 @@ #> SEWARD_ATTRACT="-35.941520411926"/5 #>> 3 #> SCF_ITER="8"/8 -#> E_SCF="-40.515612956798"/8 -#> DFT_ENERGY="-5.597618868963"/6 -#> NQ_DENSITY="10.000007868873"/8 +#> E_SCF="-40.515612956788"/8 +#> DFT_ENERGY="-5.597618868956"/6 +#> NQ_DENSITY="10.000007868841"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="0.0"/5 +#> MLTPL__1[1]="0.000000000000"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.000004364287"/5 +#> MLTPL__2[0]="-0.000004364286"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="0.000008728574"/5 +#> MLTPL__2[3]="0.000008728571"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.000004364287"/5 +#> MLTPL__2[5]="-0.000004364286"/5 #>> 4 -#> GRAD[0]="-0.000000000000"/6 -#> GRAD[1]="-0.009563213793"/6 -#> GRAD[2]="0.006760367811"/6 -#> GRAD[3]="-0.006760367811"/6 -#> GRAD[4]="-0.009563213793"/6 +#> GRAD[0]="0.000000000000"/6 +#> GRAD[1]="-0.009563213821"/6 +#> GRAD[2]="0.006760367828"/6 +#> GRAD[3]="-0.006760367828"/6 +#> GRAD[4]="-0.009563213821"/6 #>> 5 #>> 7 #> POTNUC="13.522201046829"/6 @@ -71,25 +71,25 @@ #> SEWARD_ATTRACT="-35.941530773720"/5 #>> 8 #> SCF_ITER="5"/8 -#> E_SCF="-40.515596245765"/8 -#> DFT_ENERGY="-5.597622027091"/6 -#> NQ_DENSITY="10.000007869827"/8 +#> E_SCF="-40.515596245755"/8 +#> DFT_ENERGY="-5.597622027084"/6 +#> NQ_DENSITY="10.000007869795"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="0.000814844302"/5 +#> MLTPL__1[1]="0.000814844303"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.003094256360"/5 +#> MLTPL__2[0]="-0.003094256359"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="0.000036500515"/5 +#> MLTPL__2[3]="0.000036500511"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.003057755845"/5 +#> MLTPL__2[5]="0.003057755848"/5 #>> 9 -#> GRAD[0]="0.004169531774"/6 -#> GRAD[1]="-0.008177627277"/6 -#> GRAD[2]="0.005724028481"/6 -#> GRAD[3]="-0.007808794368"/6 -#> GRAD[4]="-0.010974260626"/6 +#> GRAD[0]="0.004169531778"/6 +#> GRAD[1]="-0.008177627305"/6 +#> GRAD[2]="0.005724028497"/6 +#> GRAD[3]="-0.007808794386"/6 +#> GRAD[4]="-0.010974260654"/6 #>> 10 #>> 12 #> POTNUC="13.522201046829"/6 @@ -98,25 +98,25 @@ #> SEWARD_ATTRACT="-35.941530773720"/5 #>> 13 #> SCF_ITER="6"/8 -#> E_SCF="-40.515596245869"/8 -#> DFT_ENERGY="-5.597625858609"/6 -#> NQ_DENSITY="10.000007869775"/8 +#> E_SCF="-40.515596245859"/8 +#> DFT_ENERGY="-5.597625858602"/6 +#> NQ_DENSITY="10.000007869743"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="-0.000812875167"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.003057373275"/5 +#> MLTPL__2[0]="0.003057373277"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="0.000036502639"/5 +#> MLTPL__2[3]="0.000036502635"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.003093875914"/5 +#> MLTPL__2[5]="-0.003093875913"/5 #>> 14 -#> GRAD[0]="-0.004171591143"/6 -#> GRAD[1]="-0.010971970335"/6 -#> GRAD[2]="0.007808247217"/6 -#> GRAD[3]="-0.005722451646"/6 -#> GRAD[4]="-0.008176891141"/6 +#> GRAD[0]="-0.004171591147"/6 +#> GRAD[1]="-0.010971970364"/6 +#> GRAD[2]="0.007808247235"/6 +#> GRAD[3]="-0.005722451662"/6 +#> GRAD[4]="-0.008176891169"/6 #>> 15 #>> 17 #> POTNUC="13.489181673536"/6 @@ -125,25 +125,25 @@ #> SEWARD_ATTRACT="-35.936757104751"/5 #>> 18 #> SCF_ITER="6"/8 -#> E_SCF="-40.515828065704"/8 -#> DFT_ENERGY="-5.594587708246"/6 -#> NQ_DENSITY="10.000007911979"/8 +#> E_SCF="-40.515828065694"/8 +#> DFT_ENERGY="-5.594587708239"/6 +#> NQ_DENSITY="10.000007911947"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 #> MLTPL__1[1]="0.000000730977"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.000003456828"/5 +#> MLTPL__2[0]="-0.000003456825"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="0.000008704626"/5 +#> MLTPL__2[3]="0.000008704621"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.000005247799"/5 +#> MLTPL__2[5]="-0.000005247796"/5 #>> 19 #> GRAD[0]="0.000000333800"/6 -#> GRAD[1]="-0.008007133520"/6 -#> GRAD[2]="0.005659929069"/6 -#> GRAD[3]="-0.005660095969"/6 -#> GRAD[4]="-0.008006949481"/6 +#> GRAD[1]="-0.008007133549"/6 +#> GRAD[2]="0.005659929085"/6 +#> GRAD[3]="-0.005660095984"/6 +#> GRAD[4]="-0.008006949509"/6 #>> 20 #>> 22 #> POTNUC="13.555253701311"/6 @@ -151,26 +151,26 @@ #> SEWARD_KINETIC="16.052757759106"/5 #> SEWARD_ATTRACT="-35.946307050228"/5 #>> 23 -#> SCF_ITER="5"/8 -#> E_SCF="-40.515359416425"/8 -#> DFT_ENERGY="-5.600677924627"/6 -#> NQ_DENSITY="10.000007809784"/8 -#> MLTPL__0="0.0"/5 +#> SCF_ITER="7"/8 +#> E_SCF="-40.515359417548"/8 +#> DFT_ENERGY="-5.600659686232"/6 +#> NQ_DENSITY="10.000007810032"/8 +#> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="-0.000000011146"/5 +#> MLTPL__1[1]="-0.000000002484"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.000004374892"/5 +#> MLTPL__2[0]="-0.000004376667"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="0.000008754190"/5 +#> MLTPL__2[3]="0.000008754307"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.000004379298"/5 +#> MLTPL__2[5]="-0.000004377639"/5 #>> 24 -#> GRAD[0]="0.000000004213"/6 -#> GRAD[1]="-0.011135226779"/6 -#> GRAD[2]="0.007871925062"/6 -#> GRAD[3]="-0.007871927169"/6 -#> GRAD[4]="-0.011135224934"/6 +#> GRAD[0]="0.000000000227"/6 +#> GRAD[1]="-0.011143743810"/6 +#> GRAD[2]="0.007877949248"/6 +#> GRAD[3]="-0.007877949362"/6 +#> GRAD[4]="-0.011143744042"/6 #>> 25 #>> 27 #> POTNUC="13.522140352616"/6 @@ -178,26 +178,26 @@ #> SEWARD_KINETIC="16.052757759106"/5 #> SEWARD_ATTRACT="-35.941520411926"/5 #>> 28 -#> SCF_ITER="5"/8 -#> E_SCF="-40.515609016189"/8 -#> DFT_ENERGY="-5.597599468586"/6 -#> NQ_DENSITY="10.000007666630"/8 +#> SCF_ITER="7"/8 +#> E_SCF="-40.515609017392"/8 +#> DFT_ENERGY="-5.597618165473"/6 +#> NQ_DENSITY="10.000007666331"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="0.000000000141"/5 +#> MLTPL__1[1]="0.000000000008"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.007919067006"/5 +#> MLTPL__2[0]="-0.007919611686"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="0.015838133956"/5 +#> MLTPL__2[3]="0.015839223369"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.007919066950"/5 +#> MLTPL__2[5]="-0.007919611683"/5 #>> 29 -#> GRAD[0]="-0.000000000051"/6 -#> GRAD[1]="-0.009804889921"/6 -#> GRAD[2]="0.006439459164"/6 -#> GRAD[3]="-0.006439459139"/6 -#> GRAD[4]="-0.009804889946"/6 +#> GRAD[0]="-0.000000000001"/6 +#> GRAD[1]="-0.009796198497"/6 +#> GRAD[2]="0.006433209439"/6 +#> GRAD[3]="-0.006433209438"/6 +#> GRAD[4]="-0.009796198497"/6 #>> 30 #>> 32 #> POTNUC="13.522140334620"/6 @@ -206,25 +206,25 @@ #> SEWARD_ATTRACT="-35.941520411926"/5 #>> 33 #> SCF_ITER="4"/8 -#> E_SCF="-40.515609064235"/8 -#> DFT_ENERGY="-5.597619537153"/6 -#> NQ_DENSITY="10.000008064916"/8 +#> E_SCF="-40.515609064225"/8 +#> DFT_ENERGY="-5.597619526463"/6 +#> NQ_DENSITY="10.000008064882"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="0.000000000010"/5 +#> MLTPL__1[1]="0.000000000001"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.007905810140"/5 +#> MLTPL__2[0]="0.007905810072"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.015811620285"/5 +#> MLTPL__2[3]="-0.015811620145"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.007905810145"/5 +#> MLTPL__2[5]="0.007905810073"/5 #>> 34 -#> GRAD[0]="-0.000000000001"/6 -#> GRAD[1]="-0.009332078432"/6 -#> GRAD[2]="0.007088917357"/6 -#> GRAD[3]="-0.007088917356"/6 -#> GRAD[4]="-0.009332078431"/6 +#> GRAD[0]="0.000000000000"/6 +#> GRAD[1]="-0.009332080654"/6 +#> GRAD[2]="0.007088918896"/6 +#> GRAD[3]="-0.007088918896"/6 +#> GRAD[4]="-0.009332080654"/6 #>> 35 #>> 37 #> POTNUC="13.522157779253"/6 @@ -233,25 +233,25 @@ #> SEWARD_ATTRACT="-35.941521715682"/5 #>> 38 #> SCF_ITER="5"/8 -#> E_SCF="-40.515604751050"/8 -#> DFT_ENERGY="-5.597616449293"/6 -#> NQ_DENSITY="10.000007867770"/8 +#> E_SCF="-40.515604751040"/8 +#> DFT_ENERGY="-5.597616461625"/6 +#> NQ_DENSITY="10.000007867737"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="-0.002022854778"/5 +#> MLTPL__1[1]="-0.002022841685"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.014725622751"/5 +#> MLTPL__2[0]="-0.014725625539"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="0.000064574769"/5 +#> MLTPL__2[3]="0.000064575327"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="0.014661047982"/5 +#> MLTPL__2[5]="0.014661050211"/5 #>> 39 -#> GRAD[0]="-0.000488502910"/6 -#> GRAD[1]="-0.010397373557"/6 -#> GRAD[2]="0.006884937381"/6 -#> GRAD[3]="-0.006640685926"/6 -#> GRAD[4]="-0.008736794584"/6 +#> GRAD[0]="-0.000488505395"/6 +#> GRAD[1]="-0.010397368182"/6 +#> GRAD[2]="0.006884934142"/6 +#> GRAD[3]="-0.006640681445"/6 +#> GRAD[4]="-0.008736789181"/6 #>> 40 #>> 42 #> POTNUC="13.522157779253"/6 @@ -260,118 +260,118 @@ #> SEWARD_ATTRACT="-35.941521715682"/5 #>> 43 #> SCF_ITER="5"/8 -#> E_SCF="-40.515604751012"/8 -#> DFT_ENERGY="-5.597617509651"/6 -#> NQ_DENSITY="10.000007867758"/8 +#> E_SCF="-40.515604751001"/8 +#> DFT_ENERGY="-5.597617508113"/6 +#> NQ_DENSITY="10.000007867725"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="0.002022146331"/5 +#> MLTPL__1[1]="0.002022147490"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.014660917221"/5 +#> MLTPL__2[0]="0.014660917209"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="0.000065158494"/5 +#> MLTPL__2[3]="0.000065158495"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.014726075715"/5 +#> MLTPL__2[5]="-0.014726075705"/5 #>> 44 -#> GRAD[0]="0.000487956096"/6 -#> GRAD[1]="-0.008736056254"/6 -#> GRAD[2]="0.006640494555"/6 -#> GRAD[3]="-0.006884472603"/6 -#> GRAD[4]="-0.010397246594"/6 +#> GRAD[0]="0.000487955916"/6 +#> GRAD[1]="-0.008736056861"/6 +#> GRAD[2]="0.006640495024"/6 +#> GRAD[3]="-0.006884472983"/6 +#> GRAD[4]="-0.010397247197"/6 #>> 45 -#> NUMERICAL_HESSIAN[0]="0.334233468782"/2 -#> NUMERICAL_HESSIAN[1]="-0.000090841476"/2 -#> NUMERICAL_HESSIAN[2]="0.000000189646"/2 -#> NUMERICAL_HESSIAN[3]="-0.100641468922"/2 -#> NUMERICAL_HESSIAN[4]="-0.000090841476"/2 -#> NUMERICAL_HESSIAN[5]="0.383120074137"/2 -#> NUMERICAL_HESSIAN[6]="-0.000555537033"/2 -#> NUMERICAL_HESSIAN[7]="-0.000018538082"/2 -#> NUMERICAL_HESSIAN[8]="0.000000189646"/2 -#> NUMERICAL_HESSIAN[9]="-0.000555537033"/2 -#> NUMERICAL_HESSIAN[10]="0.078315341979"/2 -#> NUMERICAL_HESSIAN[11]="-0.000000843915"/2 -#> NUMERICAL_HESSIAN[12]="-0.100641468922"/2 -#> NUMERICAL_HESSIAN[13]="-0.000018538082"/2 -#> NUMERICAL_HESSIAN[14]="-0.000000843915"/2 -#> NUMERICAL_HESSIAN[15]="0.164300409574"/2 -#> NUMERICAL_IR_INTENSITIES[0]="13.869866444244"/2 -#> NUMERICAL_IR_INTENSITIES[1]="0.000000009832"/2 -#> NUMERICAL_IR_INTENSITIES[2]="0.000161005939"/2 -#> NUMERICAL_IR_INTENSITIES[3]="18.635145781663"/2 +#> NUMERICAL_HESSIAN[0]="0.334233469040"/2 +#> NUMERICAL_HESSIAN[1]="-0.000090820216"/2 +#> NUMERICAL_HESSIAN[2]="0.000000189899"/2 +#> NUMERICAL_HESSIAN[3]="-0.100641496726"/2 +#> NUMERICAL_HESSIAN[4]="-0.000090820216"/2 +#> NUMERICAL_HESSIAN[5]="0.384163317385"/2 +#> NUMERICAL_HESSIAN[6]="-0.000020153978"/2 +#> NUMERICAL_HESSIAN[7]="-0.000018069149"/2 +#> NUMERICAL_HESSIAN[8]="0.000000189899"/2 +#> NUMERICAL_HESSIAN[9]="-0.000020153978"/2 +#> NUMERICAL_HESSIAN[10]="0.078320909139"/2 +#> NUMERICAL_HESSIAN[11]="-0.000000840821"/2 +#> NUMERICAL_HESSIAN[12]="-0.100641496726"/2 +#> NUMERICAL_HESSIAN[13]="-0.000018069149"/2 +#> NUMERICAL_HESSIAN[14]="-0.000000840821"/2 +#> NUMERICAL_HESSIAN[15]="0.164300355177"/2 +#> NUMERICAL_IR_INTENSITIES[0]="13.869768214400"/2 +#> NUMERICAL_IR_INTENSITIES[1]="0.000000006756"/2 +#> NUMERICAL_IR_INTENSITIES[2]="0.000169841993"/2 +#> NUMERICAL_IR_INTENSITIES[3]="18.635093408450"/2 #>> 47 -#> POTNUC="13.323863449372"/6 +#> POTNUC="13.324391896542"/6 #> SEWARD_MLTPL1X="0.077508834155"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.912862267219"/5 +#> SEWARD_ATTRACT="-35.912938648902"/5 #>> 48 #> SCF_ITER="7"/8 -#> E_SCF="-40.516347743928"/8 -#> DFT_ENERGY="-5.579360895658"/6 -#> NQ_DENSITY="10.000007933112"/8 +#> E_SCF="-40.516347574390"/8 +#> DFT_ENERGY="-5.579409675256"/6 +#> NQ_DENSITY="10.000007941251"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="-0.000001845672"/5 +#> MLTPL__1[1]="-0.000001805462"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="-0.000356035592"/5 +#> MLTPL__2[0]="-0.000026468614"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="0.000635356826"/5 +#> MLTPL__2[3]="-0.000022863714"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.000279321234"/5 +#> MLTPL__2[5]="0.000049332329"/5 #>> 49 -#> GRAD[0]="0.000008266285"/6 -#> GRAD[1]="-0.000434249875"/6 -#> GRAD[2]="0.000284360201"/6 -#> GRAD[3]="-0.000288493343"/6 -#> GRAD[4]="-0.000436487710"/6 +#> GRAD[0]="0.000008224667"/6 +#> GRAD[1]="-0.000448053360"/6 +#> GRAD[2]="0.000314924993"/6 +#> GRAD[3]="-0.000319037327"/6 +#> GRAD[4]="-0.000450304149"/6 #>> 50 #>> 52 -#> POTNUC="13.314584600632"/6 +#> POTNUC="13.314601095621"/6 #> SEWARD_MLTPL1X="0.077508834155"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.911521114658"/5 +#> SEWARD_ATTRACT="-35.911523498470"/5 #>> 53 -#> SCF_ITER="5"/8 -#> E_SCF="-40.516349282685"/8 -#> DFT_ENERGY="-5.578502137725"/6 -#> NQ_DENSITY="10.000007936023"/8 +#> SCF_ITER="6"/8 +#> E_SCF="-40.516349280758"/8 +#> DFT_ENERGY="-5.578505966810"/6 +#> NQ_DENSITY="10.000007936096"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="0.000084828188"/5 +#> MLTPL__1[1]="0.000090333177"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.000650229221"/5 +#> MLTPL__2[0]="0.000692236671"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.000031031740"/5 +#> MLTPL__2[3]="-0.000041730101"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.000619197481"/5 +#> MLTPL__2[5]="-0.000650506570"/5 #>> 54 -#> GRAD[0]="0.000017882607"/6 -#> GRAD[1]="0.000023457550"/6 -#> GRAD[2]="0.000003988215"/6 -#> GRAD[3]="-0.000012929518"/6 -#> GRAD[4]="-0.000048408603"/6 +#> GRAD[0]="0.000018780503"/6 +#> GRAD[1]="0.000026047181"/6 +#> GRAD[2]="0.000003771957"/6 +#> GRAD[3]="-0.000013162208"/6 +#> GRAD[4]="-0.000050060995"/6 #>> 55 #> GEO_ITER="11"/8 -#> POTNUC="13.314313792836"/6 +#> POTNUC="13.314339117468"/6 #> SEWARD_MLTPL1X="0.077508834155"/5 #> SEWARD_KINETIC="16.052757759106"/5 -#> SEWARD_ATTRACT="-35.911481975414"/5 +#> SEWARD_ATTRACT="-35.911485635799"/5 #> SCF_ITER="3"/8 -#> E_SCF="-40.516349298564"/8 -#> DFT_ENERGY="-5.578484702406"/6 -#> NQ_DENSITY="10.000007935988"/8 +#> E_SCF="-40.516349298560"/8 +#> DFT_ENERGY="-5.578486741752"/6 +#> NQ_DENSITY="10.000007935889"/8 #> MLTPL__0="-0.000000000000"/5 #> MLTPL__1[0]="0.0"/5 -#> MLTPL__1[1]="0.000003862794"/5 +#> MLTPL__1[1]="0.000004003695"/5 #> MLTPL__1[2]="0.0"/5 -#> MLTPL__2[0]="0.000059013553"/5 +#> MLTPL__2[0]="0.000055235257"/5 #> MLTPL__2[1]="0.0"/5 #> MLTPL__2[2]="0.0"/5 -#> MLTPL__2[3]="-0.000049711702"/5 +#> MLTPL__2[3]="-0.000042558401"/5 #> MLTPL__2[4]="0.0"/5 -#> MLTPL__2[5]="-0.000009301851"/5 +#> MLTPL__2[5]="-0.000012676856"/5 #>> 56 >>EOF diff -Nru openmolcas-22.02/test/standard/808.input openmolcas-22.10/test/standard/808.input --- openmolcas-22.02/test/standard/808.input 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/test/standard/808.input 2022-10-10 14:22:40.000000000 +0000 @@ -1,10 +1,10 @@ *------------------------------------------------------------------------------- * Molecule: Glycine * Basis: ANO-S, DZ -* Symmetry: C2h +* Symmetry: C1 * Features tested: GUESSORB, SCF, DFT * Responsible person: Roland Lindh -* Comments: Check the correction to the gradient due to a moving grid +* Comments: Check the correction to the gradient due to a moving grid *------------------------------------------------------------------------------- >> FILE Glycine.xyz 10 @@ -40,13 +40,14 @@ &SCF UHF KSDFT = BLYP + Scramble = 0.1 &ALASKA >>FILE checkfile * This file is autogenerated: -* Molcas version 21.10-943-g4c2682958 -* Linux lucifer 5.13.0-27-generic #29~20.04.1-Ubuntu SMP Fri Jan 14 00:32:30 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux -* Sat Feb 5 17:07:33 2022 +* Molcas version 22.06-45-g76f2ac7e7 +* Linux otis 5.4.0-120-generic #136~18.04.1-Ubuntu SMP Fri Jun 10 18:00:44 UTC 2022 x86_64 x86_64 x86_64 GNU/Linux +* Tue Jul 5 11:48:47 2022 * #>> 1 #> POTNUC="177.019538479271"/12 @@ -56,95 +57,95 @@ #> SEWARD_KINETIC="16.053520259070"/5 #> SEWARD_ATTRACT="-43.638176236377"/5 #>> 3 -#> SCF_ITER="15"/8 -#> E_SCF="-284.311328945616"/4 -#> DFT_ENERGY="-36.641058375341"/6 -#> NQ_DENSITY="40.000034312072"/8 +#> SCF_ITER="16"/8 +#> E_SCF="-284.311328946016"/4 +#> DFT_ENERGY="-36.641075836420"/6 +#> NQ_DENSITY="40.000034310158"/8 #> MLTPL__0="-0.000000000003"/2 -#> MLTPL__1[0]="-0.764091622274"/2 -#> MLTPL__1[1]="0.923711876261"/2 -#> MLTPL__1[2]="0.045759278383"/2 -#> MLTPL__2[0]="8.055030147013"/2 -#> MLTPL__2[1]="2.793086278582"/2 -#> MLTPL__2[2]="2.580241209779"/2 -#> MLTPL__2[3]="-3.851985655834"/2 -#> MLTPL__2[4]="0.436566225209"/2 -#> MLTPL__2[5]="-4.203044491179"/2 +#> MLTPL__1[0]="-0.764096468197"/2 +#> MLTPL__1[1]="0.923707052386"/2 +#> MLTPL__1[2]="0.045760643486"/2 +#> MLTPL__2[0]="8.055028922318"/2 +#> MLTPL__2[1]="2.793093253048"/2 +#> MLTPL__2[2]="2.580249763873"/2 +#> MLTPL__2[3]="-3.852007674844"/2 +#> MLTPL__2[4]="0.436583132016"/2 +#> MLTPL__2[5]="-4.203021247475"/2 #>> 4 -#> GRAD[0]="-0.016070751763"/6 -#> GRAD[1]="0.005689133082"/6 -#> GRAD[2]="-0.004349737597"/6 -#> GRAD[3]="0.045454161273"/6 -#> GRAD[4]="-0.013367546777"/6 -#> GRAD[5]="0.027421869645"/6 -#> GRAD[6]="0.006476975874"/6 -#> GRAD[7]="-0.009283101071"/6 -#> GRAD[8]="-0.000309609691"/6 -#> GRAD[9]="-0.022670796615"/6 -#> GRAD[10]="0.038194974714"/6 -#> GRAD[11]="-0.026569246299"/6 -#> GRAD[12]="0.002468286880"/6 -#> GRAD[13]="-0.013854191143"/6 -#> GRAD[14]="0.005769673116"/6 -#> GRAD[15]="0.007307916952"/6 -#> GRAD[16]="-0.009347279209"/6 -#> GRAD[17]="-0.009837396717"/6 -#> GRAD[18]="0.000813483292"/6 -#> GRAD[19]="0.010120543589"/6 -#> GRAD[20]="-0.001592211728"/6 -#> GRAD[21]="-0.011046865297"/6 -#> GRAD[22]="-0.006284675054"/6 -#> GRAD[23]="0.005217637139"/6 -#> GRAD[24]="0.006602163449"/6 -#> GRAD[25]="0.006854927872"/6 -#> GRAD[26]="0.009817191855"/6 -#> GRAD[27]="-0.019334574046"/6 -#> GRAD[28]="-0.008722786003"/6 -#> GRAD[29]="-0.005568169724"/6 +#> GRAD[0]="-0.016072476105"/6 +#> GRAD[1]="0.005690305291"/6 +#> GRAD[2]="-0.004344051745"/6 +#> GRAD[3]="0.045456390817"/6 +#> GRAD[4]="-0.013368815545"/6 +#> GRAD[5]="0.027422725977"/6 +#> GRAD[6]="0.006482804877"/6 +#> GRAD[7]="-0.009287561169"/6 +#> GRAD[8]="-0.000319851022"/6 +#> GRAD[9]="-0.022671525770"/6 +#> GRAD[10]="0.038196425360"/6 +#> GRAD[11]="-0.026569731470"/6 +#> GRAD[12]="0.002468712349"/6 +#> GRAD[13]="-0.013855260348"/6 +#> GRAD[14]="0.005770307901"/6 +#> GRAD[15]="0.007306783923"/6 +#> GRAD[16]="-0.009346524671"/6 +#> GRAD[17]="-0.009835038170"/6 +#> GRAD[18]="0.000813084112"/6 +#> GRAD[19]="0.010119370567"/6 +#> GRAD[20]="-0.001590811872"/6 +#> GRAD[21]="-0.011047527699"/6 +#> GRAD[22]="-0.006281020196"/6 +#> GRAD[23]="0.005218348408"/6 +#> GRAD[24]="0.006598787344"/6 +#> GRAD[25]="0.006856100301"/6 +#> GRAD[26]="0.009816261027"/6 +#> GRAD[27]="-0.019335033848"/6 +#> GRAD[28]="-0.008723019590"/6 +#> GRAD[29]="-0.005568159034"/6 #>> 5 -#> SCF_ITER="2"/8 -#> E_SCF="-284.311328946080"/4 -#> DFT_ENERGY="-36.641074383039"/6 -#> NQ_DENSITY="40.000034310924"/8 -#> MLTPL__0="-0.000000000003"/2 -#> MLTPL__1[0]="-0.764096655950"/2 -#> MLTPL__1[1]="0.923708225473"/2 -#> MLTPL__1[2]="0.045760268436"/2 -#> MLTPL__2[0]="8.055026343979"/2 -#> MLTPL__2[1]="2.793091218090"/2 -#> MLTPL__2[2]="2.580250841857"/2 -#> MLTPL__2[3]="-3.852011487154"/2 -#> MLTPL__2[4]="0.436582679362"/2 -#> MLTPL__2[5]="-4.203014856826"/2 +#> SCF_ITER="13"/8 +#> E_SCF="-284.311328946027"/4 +#> DFT_ENERGY="-36.641079117864"/6 +#> NQ_DENSITY="40.000034310146"/8 +#> MLTPL__0="-0.000000000005"/2 +#> MLTPL__1[0]="-0.764098003178"/2 +#> MLTPL__1[1]="0.923707500748"/2 +#> MLTPL__1[2]="0.045759620382"/2 +#> MLTPL__2[0]="8.055027077987"/2 +#> MLTPL__2[1]="2.793089471102"/2 +#> MLTPL__2[2]="2.580240065189"/2 +#> MLTPL__2[3]="-3.851999323529"/2 +#> MLTPL__2[4]="0.436584171477"/2 +#> MLTPL__2[5]="-4.203027754458"/2 #>> 6 -#> GRAD[0]="-0.016073630640"/6 -#> GRAD[1]="0.005689706730"/6 -#> GRAD[2]="-0.004343617256"/6 -#> GRAD[3]="0.045457099086"/6 -#> GRAD[4]="-0.013368112587"/6 -#> GRAD[5]="0.027423032675"/6 -#> GRAD[6]="0.006483114321"/6 -#> GRAD[7]="-0.009287571334"/6 -#> GRAD[8]="-0.000320482818"/6 -#> GRAD[9]="-0.022671260674"/6 -#> GRAD[10]="0.038196012827"/6 -#> GRAD[11]="-0.026569581052"/6 -#> GRAD[12]="0.002468755872"/6 -#> GRAD[13]="-0.013855219970"/6 -#> GRAD[14]="0.005770227266"/6 -#> GRAD[15]="0.007306582888"/6 -#> GRAD[16]="-0.009346274321"/6 -#> GRAD[17]="-0.009834921315"/6 -#> GRAD[18]="0.000813063804"/6 -#> GRAD[19]="0.010119155435"/6 -#> GRAD[20]="-0.001590808705"/6 -#> GRAD[21]="-0.011047427083"/6 -#> GRAD[22]="-0.006280809748"/6 -#> GRAD[23]="0.005218039140"/6 -#> GRAD[24]="0.006598554025"/6 -#> GRAD[25]="0.006856168108"/6 -#> GRAD[26]="0.009816239906"/6 -#> GRAD[27]="-0.019334851600"/6 -#> GRAD[28]="-0.008723055142"/6 -#> GRAD[29]="-0.005568127841"/6 +#> GRAD[0]="-0.016074676803"/6 +#> GRAD[1]="0.005689668178"/6 +#> GRAD[2]="-0.004343276541"/6 +#> GRAD[3]="0.045458619742"/6 +#> GRAD[4]="-0.013368423570"/6 +#> GRAD[5]="0.027424526034"/6 +#> GRAD[6]="0.006483243562"/6 +#> GRAD[7]="-0.009287532039"/6 +#> GRAD[8]="-0.000321763712"/6 +#> GRAD[9]="-0.022671496040"/6 +#> GRAD[10]="0.038196184729"/6 +#> GRAD[11]="-0.026570001020"/6 +#> GRAD[12]="0.002468729636"/6 +#> GRAD[13]="-0.013854909613"/6 +#> GRAD[14]="0.005769999858"/6 +#> GRAD[15]="0.007306341366"/6 +#> GRAD[16]="-0.009346045412"/6 +#> GRAD[17]="-0.009834817278"/6 +#> GRAD[18]="0.000812856863"/6 +#> GRAD[19]="0.010118708471"/6 +#> GRAD[20]="-0.001590759953"/6 +#> GRAD[21]="-0.011047305162"/6 +#> GRAD[22]="-0.006280692713"/6 +#> GRAD[23]="0.005218051680"/6 +#> GRAD[24]="0.006598520197"/6 +#> GRAD[25]="0.006856088027"/6 +#> GRAD[26]="0.009816269935"/6 +#> GRAD[27]="-0.019334833361"/6 +#> GRAD[28]="-0.008723046057"/6 +#> GRAD[29]="-0.005568229002"/6 >>EOF diff -Nru openmolcas-22.02/Tools/dynamixtools/dynamixtools.py openmolcas-22.10/Tools/dynamixtools/dynamixtools.py --- openmolcas-22.02/Tools/dynamixtools/dynamixtools.py 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/Tools/dynamixtools/dynamixtools.py 2022-10-10 14:22:40.000000000 +0000 @@ -10,8 +10,8 @@ # * # Copyright (C) 2018, Alessio Valentini * # 2018, Luis Manuel Frutos * -# 2021, Jonathan Richard Church * -# 2021, Igor Schapiro * +# 2021,2022, Jonathan Richard Church * +# 2021,2022, Igor Schapiro * #*********************************************************************** import numpy as np @@ -153,17 +153,31 @@ if (method==3): sample=0 while (sample==0): - rand1=random.uniform(0, 1)*np.sqrt(hbar/freqSI) - rand2=random.uniform(0, 1)*np.sqrt(hbar*freqSI) + rand1=random.uniform(-1, 1)*np.sqrt(hbar/freqSI) + rand2=random.uniform(-1, 1)*np.sqrt(hbar*freqSI) rand3=random.uniform(0, 1) Ei=0.5*(np.power(freqSI*rand1,2)+np.power(rand2,2)) probability=1.0/(np.pi)*np.exp(-(2.0*Ei)/(hbar*freqSI)) - if (probability/np.pi > rand3): + if (probability > rand3/np.pi): + sample=sample+1 + x=rand1 + v=rand2 + Etot=Etot+Ei + ##Thermal Wigner sampling + if (method==4): + sample=0 + while (sample==0): + alpha=np.tanh(hbar*freqSI/(2.0*kb*T)) + rand1=random.uniform(-1, 1)*np.sqrt(hbar/(freqSI*alpha)) + rand2=random.uniform(-1, 1)*np.sqrt(hbar*freqSI*(1.0/alpha)) + rand3=random.uniform(0, 1) + Ei=0.5*(np.power(freqSI*rand1,2)+np.power(rand2,2)) + probability=alpha/(np.pi)*np.exp(-2.0*alpha*(np.power(freqSI*rand1,2)+np.power(rand2,2))/(hbar*freqSI)) + if (probability > rand3/(np.pi/alpha)): sample=sample+1 x=rand1 v=rand2 Etot=Etot+Ei - ##Will add wigner sampling with thermal distribution ##Generate displacements and velocities based on sampling method coord_samp=coord_samp+x*NCMatx[j, :]/np.sqrt(mmatrix) coord_samp_save[i, :]=x*NCMatx[j, :]/np.sqrt(mmatrix) @@ -185,30 +199,41 @@ E=E+np.sum(Ei) j=j+1 E=E+KE - #print("initial E, KE, Etot", E-KE, " ", KE, " " , Etot, '\n') + #This can be uncommented for testing print("initial E, KE, Etot", E-KE, " ", KE, " " , Etot, '\n') ##Begin to removal any supurious COM translation or rotation in the molecule and then adjusting the velocities and displacements to conserve energy accept=0.0 + Mass=AtMass*amu_to_kg while (accept==0): - ##First remove any COM in velocities and calculate the cartesian coordinates of new molecular coordinates with the COM at origin - com=CenterOfMass(AtMass, vel_reshape, atomN) - com_xyz=CenterOfMass(AtMass, xyz_reshape, atomN) + ##First calculate the cartesian coordinates with the COM at origin + com=CenterOfMass(Mass, vel_reshape, atomN) + com_xyz=CenterOfMass(Mass, xyz_reshape, atomN) xyz_reshape_COM=xyz_reshape - vel_reshape[:, 0] -= com[0] - vel_reshape[:, 1] -= com[1] - vel_reshape[:, 2] -= com[2] xyz_reshape_COM[:, 0] -= com_xyz[0] xyz_reshape_COM[:, 1] -= com_xyz[1] xyz_reshape_COM[:, 2] -= com_xyz[2] - ##Next generate angular momentum, moment of interia, and angular velocity correction - Ltot=angular_mo(AtMass, xyz_reshape_COM, vel_reshape, atomN) - invI=inertia(xyz_reshape_COM, AtMass, atomN) + ##Next generate angular momentum, inverse moment of interia matrix, and angular velocity + Ltot=angular_mo(Mass, xyz_reshape_COM, vel_reshape, atomN) + invI=inertia(xyz_reshape_COM, Mass, atomN) ang_vel=np.dot(invI, Ltot) - ang_corr=angular_vel(AtMass, xyz_reshape_COM, ang_vel, atomN) - ##Remove any spurious angular velocity - vel_reshape[:, 0] -= ang_corr[0] - vel_reshape[:, 1] -= ang_corr[1] - vel_reshape[:, 2] -= ang_corr[2] - ##Calculate Harmonic energy and compare to original value + xyz_reshaped=np.reshape(xyz_reshape_COM, (atomN, 3)) + j=0 + while (j < atomN): + ##Remove spurious rotational velocity + x=xyz_reshaped[j,0] + y=xyz_reshaped[j,1] + z=xyz_reshaped[j,2] + xyz_corr=np.array([x, y, z]) + ang_corr=angular_vel(Mass, xyz_corr, ang_vel, atomN) + vel_reshape[j, 0] -= ang_corr[0] + vel_reshape[j, 1] -= ang_corr[1] + vel_reshape[j, 2] -= ang_corr[2] + j=j+1 + ##Remove spurious COM velocity + com=CenterOfMass(Mass, vel_reshape, atomN) + vel_reshape[:, 0] -= com[0] + vel_reshape[:, 1] -= com[1] + vel_reshape[:, 2] -= com[2] + ##Calculate harmonic energy and compare to original value E=0.0 j=COM_modes KE=np.power(mmatrix[:]*np.reshape(vel_reshape, (1, 3*atomN)), 2.0)/(2.0*mmatrix[:]) @@ -218,7 +243,7 @@ E=E+np.sum(Ei) j=j+1 E=E+KE - #print("after error removal E, KE, Etot", E-KE, " ", KE, " " , Etot) + #This can be uncommented for testing print("after error removal E, KE, Etot", E-KE, " ", KE, " " , Etot) ##If the value differs by less than 1 percent accept and move to next conndition, otherwise scale the displacements and velocities and try again if (abs(E-Etot)/Etot*100 < 1): accept=accept+1 @@ -228,8 +253,6 @@ vel_reshape=vel_reshape*np.power(Etot/E, 0.5) xyz_reshape=np.reshape(xyz_old+(coord_samp)*np.power(Etot/E, 0.5), (atomN, 3)) coord_samp_save=(coord_samp_save)*np.power(Etot/E, 0.5) - # Transformed into ANGSTROM !! - # in Jan 2019, Dynamix takes geometries in angstrom but velocities in bohr ##Prepare for final coordinate and velocity file writing xyz_final=np.reshape(coord_final, (atomN, 3)) vel_final=np.reshape(vel_final, (atomN, 3)) @@ -390,7 +413,8 @@ Keyword to specify the sampling method: 1 Initial conditions based on the molecular vibrational frequencies and energies sampled from a Boltzmann distribution (Default). 2 Thermal normal mode sampling where the cumulitative distribution function for a classical boltzmann distribution at temperature T is used to approximate the energy of each mode. -3 Wigner distribution for the ground vibrational state, n=0.''')) +3 Wigner distribution for the ground vibrational state, n=0. +4 Thermal Wigner distribution for temperature T based on the analytical solution for a canonical ensemble of harmonic oscillators.''')) args = parser.parse_args() return args @@ -619,23 +643,13 @@ return Ltot def angular_vel (mass, xyz, vel, atomN): - wxtot=0 - wytot=0 - wztot=0 - h=0 - xyz=np.reshape(xyz, (atomN, 3)) - while (h < atomN): - px=float(vel[0]) - py=float(vel[1]) - pz=float(vel[2]) - wx=-float(xyz[h, 1])*pz+float(xyz[h, 2])*py - wy=-float(xyz[h, 2])*px+float(xyz[h, 0])*pz - wz=-float(xyz[h, 0])*py+float(xyz[h, 1])*px - wxtot=wxtot+wx - wytot=wytot+wy - wztot=wztot+wz - h=h+1 - wtot=np.array([wxtot, wytot, wztot]) + px=float(vel[0]) + py=float(vel[1]) + pz=float(vel[2]) + wx=-float(xyz[1])*pz+float(xyz[2])*py + wy=-float(xyz[2])*px+float(xyz[0])*pz + wz=-float(xyz[0])*py+float(xyz[1])*px + wtot=np.array([wx, wy, wz]) return wtot def main(): @@ -657,7 +671,7 @@ # I do not like this termination here, but I still have to figure out how # to properly do mutually exclusive argparse keywords. # I will keep this exit code here in the meanwhile... - sys.exit('-i input freq file is a required keyword') + sys.exit('-i input freq file is a required keyword, --help for help') if args.seed: seedI = args.seed print('seed set to: {}'.format(seedI)) @@ -710,9 +724,9 @@ complete_label = '{}{:04}'.format(label,counter) if (method==1): generate_one_boltz(inputs,complete_label) - elif (method==2 or method==3): + elif (method==2 or method==3 or method==4): normal_mode(inputs,complete_label,method) - print('\nThis routine generates geometries in angstrom and velocities in bohr (the format that Molcas requires for a Semiclassical Molecular Dynamics)\n') + print('\nThis routine generates geometries in angstrom and velocities in bohr (the format that Molcas requires for a Semiclassical Molecular Dynamics\n') if __name__ == "__main__": main() diff -Nru openmolcas-22.02/Tools/grid2cube/grid2cube.F90 openmolcas-22.10/Tools/grid2cube/grid2cube.F90 --- openmolcas-22.02/Tools/grid2cube/grid2cube.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/Tools/grid2cube/grid2cube.F90 2022-10-10 14:22:40.000000000 +0000 @@ -158,6 +158,9 @@ CHARACTER :: TestChar REAL(KIND=REAL64) :: TestFloat +#include "macros.fh" +unused_var(Test) + ! Try to read as ASCII, the first line should be 0 OPEN(U,FILE=FileName,STATUS='OLD',ACTION='READ',IOSTAT=Error,FORM='FORMATTED') IF (Error /= 0) RETURN @@ -351,6 +354,9 @@ ! Hard-coded value for Luscus format REAL(KIND=REAL64), PARAMETER :: Angstrom=0.52917721067D0 +#include "macros.fh" +unused_var(Word) + READ(FileIn,*) Natom READ(FileIn,*) ALLOCATE(Coor(Natom,3),Label(Natom)) diff -Nru openmolcas-22.02/Tools/mort/mort.py openmolcas-22.10/Tools/mort/mort.py --- openmolcas-22.02/Tools/mort/mort.py 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/Tools/mort/mort.py 2022-10-10 14:22:40.000000000 +0000 @@ -131,7 +131,7 @@ return Rot # Compute the rotation matrix for the functions in a spherical harmonics shell -# of angular momentum l, given the real-space rotation matrix R (implict). +# of angular momentum l, given the real-space rotation matrix R (implicit). # Uses the recursive algorithm of Ivanic and Ruedenberg (doi:10.1021/jp953350u, doi:10.1021/jp9833350), # which is valid for l > 1. # Note that this builds the inverse/transpose, so indexing may look reversed. diff -Nru openmolcas-22.02/Tools/patch2tinker/patch_tinker-6.3.3.diff openmolcas-22.10/Tools/patch2tinker/patch_tinker-6.3.3.diff --- openmolcas-22.02/Tools/patch2tinker/patch_tinker-6.3.3.diff 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/Tools/patch2tinker/patch_tinker-6.3.3.diff 2022-10-10 14:22:40.000000000 +0000 @@ -12232,6 +12232,32 @@ nbpi = nbpi + 1 do m = 1, nbond if (iorb.eq.ibnd(1,m) .and. +diff -Nu -x '*~' -x '*.o' 6.3.3/source_orig/pmestuff.f 6.3.3/source/pmestuff.f +--- 6.3.3/source_orig/pmestuff.f 2022-09-30 09:09:28.116394906 +0200 ++++ 6.3.3/source/pmestuff.f 2022-09-30 09:04:52.978118592 +0200 +@@ -51,19 +51,19 @@ + ifr = int(fr-eps) + w = fr - dble(ifr) + igrid(1,i) = ifr - bsorder +- call bsplgen (w,thetai1(1,1,i)) ++ call bsplgen (w,thetai1(:,:,i)) + w = xi*recip(1,2) + yi*recip(2,2) + zi*recip(3,2) + fr = dble(nfft2) * (w-anint(w)+0.5d0) + ifr = int(fr-eps) + w = fr - dble(ifr) + igrid(2,i) = ifr - bsorder +- call bsplgen (w,thetai2(1,1,i)) ++ call bsplgen (w,thetai2(:,:,i)) + w = xi*recip(1,3) + yi*recip(2,3) + zi*recip(3,3) + fr = dble(nfft3) * (w-anint(w)+0.5d0) + ifr = int(fr-eps) + w = fr - dble(ifr) + igrid(3,i) = ifr - bsorder +- call bsplgen (w,thetai3(1,1,i)) ++ call bsplgen (w,thetai3(:,:,i)) + end do + return + end diff -Nu -x '*~' -x '*.o' 6.3.3/source_orig/promo.f 6.3.3/source/promo.f --- 6.3.3/source_orig/promo.f 2015-04-14 13:58:10.118343730 +0200 +++ 6.3.3/source/promo.f 2015-04-15 14:03:48.548057299 +0200 @@ -13919,6 +13945,18 @@ +c + return + end +diff -Nu -x '*~' -x '*.o' 6.3.3/source_orig/valence.f 6.3.3/source/valence.f +--- 6.3.3/source_orig/valence.f 2022-09-30 09:16:19.605860155 +0200 ++++ 6.3.3/source/valence.f 2022-09-30 09:18:00.125251072 +0200 +@@ -16,7 +16,7 @@ + c on a quantum mechanical optimized structure and frequencies + c + c +- program valence ++ program valence_prog + implicit none + include 'sizes.i' + include 'atoms.i' diff -Nu -x '*~' -x '*.o' 6.3.3/source_orig/xyzedit.f 6.3.3/source/xyzedit.f --- 6.3.3/source_orig/xyzedit.f 2015-04-14 13:58:10.122343730 +0200 +++ 6.3.3/source/xyzedit.f 2015-04-15 13:48:53.796041225 +0200 diff -Nru openmolcas-22.02/Tools/pymolcas/export.py openmolcas-22.10/Tools/pymolcas/export.py --- openmolcas-22.02/Tools/pymolcas/export.py 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/Tools/pymolcas/export.py 2022-10-10 14:22:40.000000000 +0000 @@ -11,7 +11,7 @@ # For more details see the full text of the license in the file * # LICENSE or in <http://www.gnu.org/licenses/>. * # * -# Copyright (C) 2015,2017,2018, Ignacio Fdez. Galván * +# Copyright (C) 2015,2017,2018,2022, Ignacio Fdez. Galván * #*********************************************************************** ''' @@ -28,7 +28,7 @@ from future.builtins import (bytes, str) from io import open -import sys, zlib, base64, os, stat +import sys, zlib, base64, os, stat, subprocess sys.dont_write_bytecode = True files = ['tee', 'molcas_aux', 'emil_grammar', 'simpleeval', 'abstract_flow', 'emil_parse', 'python_parse', 'check_test', 'validate', 'molcas_wrapper', 'pymolcas'] @@ -65,6 +65,19 @@ string = pm.dedent(string) return string +def find_interpreter(): + exe = sys.executable + if exe is None: + return None + # If python3 or python2 point to the current executable, use those instead + p3 = subprocess.check_output(['/usr/bin/env','python3','-c','import sys; print(sys.executable)']).decode().strip() + if os.path.realpath(p3) == os.path.realpath(exe): + return '/usr/bin/env python3' + p2 = subprocess.check_output(['/usr/bin/env','python2','-c','import sys; print(sys.executable)']).decode().strip() + if os.path.realpath(p2) == os.path.realpath(exe): + return '/usr/bin/env python2' + return exe + if (compress_and_b64): code = 'import zlib,base64;exec(zlib.decompress(base64.b64decode(bytes(m[1],\\\'ascii\\\'))),module.__dict__);del zlib,base64' else: @@ -79,7 +92,7 @@ failed = False with open(exe_name, 'w', encoding='utf-8') as f: - interpreter = sys.executable + interpreter = find_interpreter() if (interpreter is None): interpreter = '/usr/bin/env python' f.write('''#!{0} diff -Nru openmolcas-22.02/Tools/pymolcas/molcas_wrapper.py openmolcas-22.10/Tools/pymolcas/molcas_wrapper.py --- openmolcas-22.02/Tools/pymolcas/molcas_wrapper.py 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/Tools/pymolcas/molcas_wrapper.py 2022-10-10 14:22:40.000000000 +0000 @@ -97,7 +97,7 @@ class Molcas_wrapper(object): - version = 'py2.21' + version = 'py2.23' rc = 0 def __init__(self, **kwargs): diff -Nru openmolcas-22.02/Tools/pymolcas/pymolcas.py openmolcas-22.10/Tools/pymolcas/pymolcas.py --- openmolcas-22.02/Tools/pymolcas/pymolcas.py 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/Tools/pymolcas/pymolcas.py 2022-10-10 14:22:40.000000000 +0000 @@ -79,6 +79,7 @@ parser.add_argument('-ign', '--ignore_environment', help='run ignoring resource files', action='store_true') parser.add_argument('-val', '--validate', help='validate input only (dry run)', action='store_true') parser.add_argument('-np', '--nprocs', help='number of parallel (MPI) processes', type=int) + parser.add_argument('-nt', '--nthreads', help='number of (OpenMP) threads per process', type=int) parser.add_argument('-v', '--version', help='print version of the driver', action='store_true') parser.add_argument('-o', '--output', help='redirect output stream to FILE', metavar='FILE') parser.add_argument('-e', '--error', help='redirect error stream to FILE', metavar='FILE') @@ -143,6 +144,9 @@ if (args['nprocs']): os.environ['MOLCAS_NPROCS'] = text_type(args['nprocs']) + if (args['nthreads']): + os.environ['MOLCAS_THREADS'] = text_type(args['nthreads']) + if (args['clean_scratch']): os.environ['MOLCAS_KEEP_WORKDIR'] = 'NO' diff -Nru openmolcas-22.02/Tools/pymolcas/validate.py openmolcas-22.10/Tools/pymolcas/validate.py --- openmolcas-22.02/Tools/pymolcas/validate.py 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/Tools/pymolcas/validate.py 2022-10-10 14:22:40.000000000 +0000 @@ -185,8 +185,11 @@ return None n = int(size) if (computed): - n *= first_int(lines[l]) - l += 1 + try: + n *= int(first_word(lines[l])) # should not accept environment variables for number of lines + l += 1 + except ValueError: + return None l += n if (l >= len(lines)): return None @@ -215,7 +218,7 @@ return None for part in fortran_split(lines[l]): try: - i = fortran_int(part) + i = int(part) # should not accept environment variables for number of lines ints += 1 if ((gv.lookup.get(gv.current_name) is None) and (ints == 1)): gv.lookup[gv.current_name] = i @@ -274,7 +277,7 @@ if (off == 0): i = fortran_float(part) else: - i = fortran_int(part) + i = int(part) # should not accept environment variables for number of lines nums += 1 except: return None diff -Nru openmolcas-22.02/Tools/rf2asc/asc2rf.f openmolcas-22.10/Tools/rf2asc/asc2rf.f --- openmolcas-22.02/Tools/rf2asc/asc2rf.f 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/Tools/rf2asc/asc2rf.f 2022-10-10 14:22:40.000000000 +0000 @@ -82,7 +82,6 @@ Write(*,*) 'Unknown data type:',Type End If GoTo 100 - Continue *----------------------------------------------------------------------* * * *----------------------------------------------------------------------* diff -Nru openmolcas-22.02/unit_tests/filesystem/test_filesystem.F90 openmolcas-22.10/unit_tests/filesystem/test_filesystem.F90 --- openmolcas-22.02/unit_tests/filesystem/test_filesystem.F90 2022-02-10 21:22:31.000000000 +0000 +++ openmolcas-22.10/unit_tests/filesystem/test_filesystem.F90 2022-10-10 14:22:40.000000000 +0000 @@ -15,7 +15,7 @@ module test_filesystem_mod use fruit - use filesystem, only: basename, inquire_, mkdir_, remove_, chdir_, getcwd_ + use filesystem, only: basename, inquire_, mkdir_, remove_, chdir_, getcwd_, copy_ implicit none private public :: test_filesystem @@ -42,16 +42,22 @@ call assert_true(basename(cwd) == test_dir) block - integer :: file_id - character(*), parameter :: test_file = 'asdf' + integer :: file_id, err + character(*), parameter :: test_file = 'asdf', new_file = 'hallo Wrzlbrmft' call assert_false(inquire_(test_file)) open(newunit=file_id, file=test_file) write(file_id, '(A)') 'Hello World' close(file_id) call assert_true(inquire_(test_file)) + call copy_(test_file, new_file) + call assert_true(inquire_(new_file)) + call remove_(new_file) call remove_(test_file, err) call assert_true(err == 0) call assert_false(inquire_(test_file)) + + call copy_(test_file, new_file, err) + call assert_true(err /= 0) end block call chdir_(root) @@ -72,7 +78,6 @@ call random_seed(size=seed_size) call random_seed(put=[(i, i = 1, seed_size)]) call init_fruit() - call init_linalg() call inimem() call run_test_case(test_filesystem, "test_filesystem")